summaryrefslogtreecommitdiff
path: root/Build/source/texk/web2c/mplibdir
diff options
context:
space:
mode:
authorKarl Berry <karl@freefriends.org>2021-02-25 19:22:25 +0000
committerKarl Berry <karl@freefriends.org>2021-02-25 19:22:25 +0000
commitad547a6b5986815fda458221149728d9d9ab1d87 (patch)
tree16296910eb3eca724371474ea9aea3994dc69614 /Build/source/texk/web2c/mplibdir
parent947b43de3dd21d58ccc2ffadefc4441ea1c2a813 (diff)
restore Build,TODO from r57911
git-svn-id: svn://tug.org/texlive/trunk@57915 c570f23f-e606-0410-a88d-b1316a301751
Diffstat (limited to 'Build/source/texk/web2c/mplibdir')
-rw-r--r--Build/source/texk/web2c/mplibdir/ChangeLog575
-rw-r--r--Build/source/texk/web2c/mplibdir/am/libmplib.am103
-rw-r--r--Build/source/texk/web2c/mplibdir/am/libmputil.am15
-rw-r--r--Build/source/texk/web2c/mplibdir/am/mplib.am92
-rw-r--r--Build/source/texk/web2c/mplibdir/avl.c2638
-rw-r--r--Build/source/texk/web2c/mplibdir/avl.h466
-rw-r--r--Build/source/texk/web2c/mplibdir/decContext.c437
-rw-r--r--Build/source/texk/web2c/mplibdir/decContext.h254
-rw-r--r--Build/source/texk/web2c/mplibdir/decNumber.c8141
-rw-r--r--Build/source/texk/web2c/mplibdir/decNumber.h182
-rw-r--r--Build/source/texk/web2c/mplibdir/decNumberLocal.h757
-rwxr-xr-xBuild/source/texk/web2c/mplibdir/dvitomp.test21
-rw-r--r--Build/source/texk/web2c/mplibdir/lmplib.c2060
-rw-r--r--Build/source/texk/web2c/mplibdir/mp.w35650
-rw-r--r--Build/source/texk/web2c/mplibdir/mpmath.w1925
-rw-r--r--Build/source/texk/web2c/mplibdir/mpmathbinary.w1838
-rw-r--r--Build/source/texk/web2c/mplibdir/mpmathdecimal.w2011
-rw-r--r--Build/source/texk/web2c/mplibdir/mpmathdouble.w1487
-rw-r--r--Build/source/texk/web2c/mplibdir/mpost.w1492
-rw-r--r--Build/source/texk/web2c/mplibdir/mpstrings.w447
-rwxr-xr-xBuild/source/texk/web2c/mplibdir/mptraptest.test40
-rw-r--r--Build/source/texk/web2c/mplibdir/mpxout.w4380
-rw-r--r--Build/source/texk/web2c/mplibdir/pngout.w911
-rw-r--r--Build/source/texk/web2c/mplibdir/psout.w6502
-rw-r--r--Build/source/texk/web2c/mplibdir/svgout.w1343
-rw-r--r--Build/source/texk/web2c/mplibdir/tfmin.w253
26 files changed, 74020 insertions, 0 deletions
diff --git a/Build/source/texk/web2c/mplibdir/ChangeLog b/Build/source/texk/web2c/mplibdir/ChangeLog
new file mode 100644
index 00000000000..87b2fa9be65
--- /dev/null
+++ b/Build/source/texk/web2c/mplibdir/ChangeLog
@@ -0,0 +1,575 @@
+2020-12-28 Luigi Scarso <luigi.scarso@gmail.com>
+ * Temp, fix in mpx_copy_mpto, changed || with && to avoid a wrong final %
+
+
+2020-12-27 Luigi Scarso <luigi.scarso@gmail.com>
+ * Fixed some typos in manual (thank to 胡亚捷 (Hu Yajie) )
+ * Added the undocumented -T option
+ * Added some autotools files to make reautoconf working again
+
+2020-11-26 Luigi Scarso <luigi.scarso@gmail.com>
+ * Added mp-tangle dependency to libmplib.am
+ to fix parallel compilation
+
+2020-08-21 Luigi Scarso <luigi.scarso@gmail.com>
+ * Changed epsilon in binary and decimal mode from 1E-52 to
+ 2^-173 =~0.835E-52, so that mp_solve_rising_cubic now works as
+ expected.
+ * Fix @<Set the height and depth to zero if the bounding box is empty@>
+ in mp_set_text_box when height and depth are both -inf.
+
+2020-06-30 Luigi Scarso <luigi.scarso@gmail.com>
+ * SOURCE_DATE_EPOCH support (A. Kakuto)
+
+2020-02-18 Luigi Scarso <luigi.scarso@gmail.com>
+ * better mp_snprintf macro
+
+
+2019-03-06 Luigi Scarso <luigi.scarso@gmail.com>
+ * Code clean-up.
+
+2019-02-06: Taco Hoekwater <taco@elvenkind.com>
+ * New primitive void: convert a suffix to a boolean. Work in progress.
+
+
+2019-01-28 Andreas Scherer <https://ascherer.github.io>
+ * mpost.w: TeXnical nitpicking.
+
+2019-01-26 Luigi Scarso <luigi.scarso@gmail.com>
+ * Fixed bisection algorithm (overflow of number of bisections in decimal mode with low precision)
+ * Added 2 levels to the bisection algorithm for cubic intersection. Need testing.
+ * Fixed a buffer overflow on command line; for consistency with mp_reallocate_buffer,
+ now accepting input from command line of at most 0xFFFFFFF bytes.
+
+
+2019-01-06 Luigi Scarso <luigi.scarso@gmail.com>
+ * Added r-mpost as an alias for mpost --restricted
+
+
+2018-10-22 Luigi Scarso <luigi.scarso@gmail.com>
+ * Fixed a bug in cubic intersection in arbitrary precision math with low precision.
+ * Raised minimal precision to 2 for decimal and binary mode.
+ * Added 3 levels to the bisection algorithm for for cubic intersection.
+
+2018-08-27 Luigi Scarso <luigi.scarso@gmail.com>
+ * separation of mpmathbinary from the the core
+
+
+2018-02-19 Luigi Scarso <luigi.scarso@gmail.com>
+ * Small cleanup of the code
+ * Bump to version 2.0rc2: the current version is 2.00
+ * Added the envelope primitives to mpman
+
+2017-03-31 Luigi Scarso <luigi.scarso@gmail.com>
+ * fixed the value header_last to be sure
+ to store always the latest position.
+ * Bump to version 2.0rc1. It's a release candidate for
+ testing latest patches and eventually new primitives
+ (to be discussed at 2017 BachoTeX/TUG meeting).
+ As the version is always a number, the current version is 2.000
+ (a way to say 2.0rc1).
+
+2017-02-13 Luigi Scarso <luigi.scarso@gmail.com>
+ new primitive boundingpath
+
+
+2016-03-06 Luigi Scarso <luigi.scarso@gmail.com>
+ Bump to version 1.9991.
+
+
+
+2015-12-16 Luigi Scarso <luigi.scarso@gmail.com>
+ Updated to cairo-1.14.6, gmp-6.1.0 and libpng-1.6.20.
+ Fixed some issues with tfm files.
+
+2015-11-11 Akira Kakuto <kakuto@fuk.kindai.ac.jp>
+
+ * mp.w: Sync with the upstream.
+
+2015-10-16 Akira Kakuto <kakuto@fuk.kindai.ac.jp>
+
+ * mpmathbinary.w: Sync with the upstream.
+
+2015-10-15 Akira Kakuto <kakuto@fuk.kindai.ac.jp>
+
+ * mpmathbinary.w: Sync with the upstream.
+
+2015-10-07 Akira Kakuto <kakuto@fuk.kindai.ac.jp>
+
+ * mpmath.w, mpmathbinary.w, mpmathdecimal.w, mp.w, mpmathdouble.w:
+ Sync with the upstream trunk.
+
+2015-09-21 Akira Kakuto <kakuto@fuk.kindai.ac.jp>
+
+ * mpmathdecimal.w: Sync with the upstream trunk.
+
+2015-07-10 Peter Breitenlohner <peb@mppmu.mpg.de>
+
+ * mptraptest (removed): Renamed ...
+ * mptraptest.test (new): ... into this.
+ * am/mplib.am: Better dependencies for 'make check'.
+
+
+2015-03-21 Luigi Scarso <luigi.scarso@gmail.com>
+ make_text for mplib only.
+
+
+2015-03-19 Luigi Scarso <luigi.scarso@gmail.com>
+ Fixed normal rand. generator for double/decimal/binary
+ systems.
+
+2015-01-20 Luigi Scarso <luigi.scarso@gmail.com>
+ Added cur_sym_mod() == mp_normal_sym
+ to the cur_sym==0 condition mp_cur_tok
+
+
+2015-01-19 Luigi Scarso <luigi.scarso@gmail.com>
+ fixed a bug in mp_recycle_value with NULL node
+
+
+2015-01-15 Luigi Scarso <luigi.scarso@gmail.com>
+ mpmathdecimal.w: better management for static data in mpmathdecimal.w
+ (thanks to Philipp Gesang <phg@phi-gamma.net>)
+
+2014-12-04 Luigi Scarso <luigi.scarso@gmail.com>
+
+ * mpost.w: fixed exit values to match metafont/old metapost behavior.
+ (thanks to Wojciech A. Koszek <wkoszek@freebsd.org>).
+
+2014-11-05 Akira Kakuto <kakuto@fuk.kindai.ac.jp>
+
+ * psout.w: Sync with the trunk. Luigi fixes to avoid enormous number
+ of warnings.
+
+2014-10-30 Peter Breitenlohner <peb@mppmu.mpg.de>
+
+ * mpost.w [W32TeX]: Handle building of mpost.dll as for tex & Co.
+
+2014-09-22 Peter Breitenlohner <peb@mppmu.mpg.de>
+
+ * mp.w: Fixed an error message typo.
+
+2014-09-19 Akira Kakuto <kakuto@fuk.kindai.ac.jp>
+
+ * pngout.w: Sync with the trunk. Luigi fixes a bug in png text output.
+
+2014-09-16 Peter Breitenlohner <peb@mppmu.mpg.de>
+
+ * am/libmplib.am: Build a separate library libmputil.a from
+ distributed *.[ch] files. Move respective rules from here ...
+ * am/libmputil.am (new): ... to here.
+ * am/mplib.am (mpost_LDADD): Add libmputil.a.
+
+2014-09-06 Peter Breitenlohner <peb@mppmu.mpg.de>
+
+ * mpxout.w (bad_dvi_two): Correctly use mpx_abort().
+
+2014-09-03 Akira Kakuto <kakuto@fuk.kindai.ac.jp>
+
+ * lmplib.c, mp.w, mpmath.w, mpmathbinary.w, mpmathdecimal.w,
+ mpmathdouble.w, mpost.w, mpxout.w, psout.w: Sync with the trunk.
+
+2014-07-15 Peter Breitenlohner <peb@mppmu.mpg.de>
+
+ * mpxout.w: Replace the deprecated spawnvp() by _spawnvp(),
+ they differ for 64-bit MinGW.
+
+2014-06-21 Peter Breitenlohner <peb@mppmu.mpg.de>
+
+ * mpxout.w: Avoid undefined behaviour when char is signed.
+
+2014-06-20 Peter Breitenlohner <peb@mppmu.mpg.de>
+
+ Import metapost 1.999
+
+2014-04-23 Taco Hoekwater <taco@luatex.org>
+
+ Import metapost 1.902
+
+2014-04-09 Taco Hoekwater <taco@luatex.org>
+
+ Import metapost 1.901
+
+2014-03-16 Akira Kakuto <kakuto@fuk.kindai.ac.jp>
+
+ * mp.w: An unimportant typo (1.890 --> 1.900).
+
+2014-03-14 Taco Hoekwater <taco@luatex.org>
+
+ Import metapost 1.900
+
+2014-02-03 Peter Breitenlohner <peb@mppmu.mpg.de>
+
+ * psout.w: Avoid to redefine Byte and Bytef from <zlib.h>.
+
+2014-01-31 Peter Breitenlohner <peb@mppmu.mpg.de>
+
+ * mp.w: Do not declare zlibVersion, #include <zlib.h>, etc.
+ Display header (compiled with) and library (using) versions.
+
+2014-01-30 Akira Kakuto <kakuto@fuk.kindai.ac.jp>
+
+ * mp.w, mpost.w, pngout.w: Import from MetaPost trunk.
+
+2014-01-29 Akira Kakuto <kakuto@fuk.kindai.ac.jp>
+
+ * mpost.w, mp.w: Import from MetaPost trunk.
+
+2014-01-17 Peter Breitenlohner <peb@mppmu.mpg.de>
+
+ * mptrap.test (removed): Renamed ...
+ * mptraptest (new): ... into this.
+ * am/mplib.am: Adapted.
+
+2014-01-06 Akira Kakuto <kakuto@fuk.kindai.ac.jp>
+
+ * mp.w, mpmathdouble.w: Bug fixes by Taco, imported from MetaPost trunk.
+
+2013-09-23 Akira Kakuto <kakuto@fuk.kindai.ac.jp>
+
+ * mp.w: A bug is fixed by Taco.
+
+2013-09-20 Karl Berry <karl@tug.org>
+
+ * mpost.w (Set up the banner line) [NATIVE_TEXLIVE_BUILD]:
+ use WEB2CVERSION instead of kpathsea_version_string for TL.
+
+2013-07-05 Peter Breitenlohner <peb@mppmu.mpg.de>
+
+ * mpost.w (main): Use kpse_program_basename().
+
+2013-06-28 Peter Breitenlohner <peb@mppmu.mpg.de>
+
+ * pngout.w: Replace index() => strchr().
+
+ * mp.w: Include <stdio.h> after <w2c/config.h>.
+
+2013-06-19 Peter Breitenlohner <peb@mppmu.mpg.de>
+
+ * lmplib.c: Replace '<../lua52/lua.h>' => '<lua.h>'.
+
+2013-06-16 Taco Hoekwater <taco@luatex.org>
+
+ Import metapost 1.803 (released version)
+
+2013-05-22 Taco Hoekwater <taco@luatex.org>
+
+ * svgout.w: fix a problem with overly large characters in
+ SVG output mode when prologues != 3.
+ * mp.w: quick fix for a fatal crash during free-ing of TFM
+ metric data at the end of the run.
+
+2013-04-23 Taco Hoekwater <taco@luatex.org>
+
+ * svgout.w: fix a problem with colors in SVG output mode.
+ * mp.w: bump version to 1.802
+
+2013-04-05 Taco Hoekwater <taco@luatex.org>
+
+ Import metapost 1.801 (released version)
+
+2013-03-26 Peter Breitenlohner <peb@mppmu.mpg.de>
+
+ * mpost.w: First arg of kpse_set_program_name() must be argv[0],
+ otherwise the assertion in kpathsea/progname.c:316 may fail.
+
+2013-03-25 Peter Breitenlohner <peb@mppmu.mpg.de>
+
+ Update MetaPost 1.800 from LuaTeX repository (r4612).
+
+2013-03-21 Peter Breitenlohner <peb@mppmu.mpg.de>
+
+ Import MetaPost 1.800 from LuaTeX repository (r4604).
+
+2013-01-29 Peter Breitenlohner <peb@mppmu.mpg.de>
+
+ * am/mplib.am: Allow subdir-objects.
+
+2013-01-15 Peter Breitenlohner <peb@mppmu.mpg.de>
+
+ * am/mplib.am, mptrap.test: Enable parallel-tests.
+
+2012-12-18 Peter Breitenlohner <peb@mppmu.mpg.de>
+
+ * am/mplib.am: Enable silent rules.
+
+2012-12-07 Peter Breitenlohner <peb@mppmu.mpg.de>
+
+ * mpxout.w: Cast arg3 of spawnvp() to `const char* const*'.
+
+2012-08-03 Peter Breitenlohner <peb@mppmu.mpg.de>
+
+ * mpost.w: Reduce diffs between TeX Live and W32TeX.
+ * mpxout.w: Replace P_WAIT by _P_WAIT.
+
+2012-08-01 Peter Breitenlohner <peb@mppmu.mpg.de>
+
+ * mp.w: Drop replacement function for snprintf().
+
+2012-07-28 Peter Breitenlohner <peb@mppmu.mpg.de>
+
+ * am/mplib.am (nodist_libmplib_a_SOURCES): Omit $(tfmin_c_h).
+
+2012-05-22 Peter Breitenlohner <peb@mppmu.mpg.de>
+
+ * dvitomp.test: Cope with spaces in paths returned by kpsewhich.
+
+2012-05-20 Peter Breitenlohner <peb@mppmu.mpg.de>
+
+ * am/mplib.am (mpost_LDADD): Drop explicit '-lm'.
+
+2012-05-10 Peter Breitenlohner <peb@mppmu.mpg.de>
+
+ * mpost.w: Use WEB2CVERSION.
+
+2011-10-04 Peter Breitenlohner <peb@mppmu.mpg.de>
+
+ * am/libmplib.am (EXTRA_DIST): Drop lmplib.c, used by luaTeX.
+
+2011-06-06 Taco Hoekwater <taco@luatex.org>
+
+ * mpost.w (mpost_run_editor): Do not attempt to use EDITOR.
+
+2011-06-04 Peter Breitenlohner <peb@mppmu.mpg.de>
+
+ * am/mplib.am (bin_links): Remove no longer existing 'metafun'.
+
+2011-05-31 Peter Breitenlohner <peb@mppmu.mpg.de>
+
+ * am/mplib.am (bin_links): Move mpost:metafun and mpost:mfplain
+ from ../../texlive/linked_scripts/Makefile.am to here.
+ [MinGW]: Build call_mpost.exe wrapper binary and install as
+ dvitomp.exe, metafun.exe, amd mfplain.exe.
+
+2011-05-30 Taco Hoekwater <taco@luatex.org>
+
+ * all files: clarify that base MetaPost is public domain,
+ but uses LGPL'd libraries.
+
+2011-05-13 Taco Hoekwater <taco@luatex.org>
+
+ * mpost.w (main): change setting of kpse program name
+ (on a hint by PEB).
+
+2011-05-09 Taco Hoekwater <taco@luatex.org>
+
+ * mpxout.w (mpx_in_TFM): close tfm files.
+
+2011-04-29 Peter Breitenlohner <peb@mppmu.mpg.de>
+
+ * mp.w (mp_do_snprintf): Removed, instead declare and define
+ static internal version of mp_snprintf().
+ Compare change from 2009-12-05:
+ FIXME: Should unconditionally assume snprintf() exists.
+
+2011-04-06 Peter Breitenlohner <peb@mppmu.mpg.de>
+
+ * am/libmplib.am: Only one rule for tfmin.w => tfmin.c.
+
+2011-04-05 Taco Hoekwater <taco@luatex.org>
+
+ * mp.w, mpost.w: import metapost 1.504
+
+2011-04-05 Taco Hoekwater <taco@luatex.org>
+
+ * Import of MetaPost 1.503, updating the .w files as well
+ as lmplib.c and avl.c, and adding mpmath.w and removing memio.w
+ * am/libmplib.am: add support for mpmath.w, remove memio.w
+ * mptrap.test: remove the second part as metapost no longer
+ uses .mem files at all
+
+2011-03-28 Peter Breitenlohner <peb@mppmu.mpg.de>
+
+ * am/libmplib.am: Use AM_CFLAGS instead of libmplib_a_CFLAGS.
+ * am/mplib.am: Use AM_CFLAGS instead of mpost_CFLAGS.
+
+2011-02-15 Peter Breitenlohner <peb@mppmu.mpg.de>
+
+ * am/mplib.am [WIN32]: Add dvitomp.exe wrapper for MinGW.
+
+2011-01-17 Peter Breitenlohner <peb@mppmu.mpg.de>
+
+ * am/mplib.am (mptrap.diffs): Use $(triptrap_diffs).
+
+2011-01-14 Peter Breitenlohner <peb@mppmu.mpg.de>
+
+ * am/mplib.am (mptrap-clean): Use TRIPTRAP_CLEAN.
+
+2010-12-23 Peter Breitenlohner <peb@mppmu.mpg.de>
+
+ * am/mplib.am: install-exec-hook and uninstall-hook rules now
+ in ../Makefile.am; append required symlink to bin_links.
+
+2010-06-11 Taco Hoekwater <taco@luatex.org>
+
+ * *.w, lmplib.h: change include of "config.h" to <w2c/config.h>.
+
+2010-06-10 Peter Breitenlohner <peb@mppmu.mpg.de>
+
+ * am/libmplib.am (libmplib_a_CPPFLAGS): Add $(AM_CPPFLAGS).
+ * am/mplib.am (mpost_CPPFLAGS): Add $(AM_CPPFLAGS).
+
+2010-05-31 Taco Hoekwater <taco@luatex.org>
+
+ * mp.w (mp_set_output_file_name): prevent reallocation of
+ string pool during output file name generation.
+
+2010-05-19 Taco Hoekwater <taco@luatex.org>
+
+ * mpost.w: add WEB2CVERSION to the banner.
+
+2010-04-13 Taco Hoekwater <taco@luatex.org>
+
+ * new import from luatex repository (HEAD of 0.60.x branch)
+
+2010-04-05 Karl Berry <karl@tug.org>
+
+ * mptrap.test: use --mem, not --memname (which does not exist).
+
+2010-04-01 Taco Hoekwater <taco@elvenkind.com>
+
+ * lmplib.c: revert #include "../luatex-api.h".
+
+2010-04-01 Taco Hoekwater <taco@elvenkind.com>
+
+ * Released version of MPLib 1.211
+
+2010-03-04 Peter Breitenlohner <peb@mppmu.mpg.de>
+
+ * am/mplib.am (TRIPTRAP): Add mptrap.diffs.
+
+2010-01-26 Peter Breitenlohner <peb@mppmu.mpg.de>
+
+ * psout.w: Remove charsetstr[].
+
+2010-01-24 Peter Breitenlohner <peb@mppmu.mpg.de>
+
+ * mp.w (mp_execute, mp_get_char_dimension): Declare string params
+ as const.
+ * lmplib.c: #include "../luatex-api.h".
+ Remove 'char *' casts of Lua strings.
+ Declare various string variables as const.
+
+2009-12-05 Peter Breitenlohner <peb@mppmu.mpg.de>
+
+ * mpxout.w: Convert CRLF to native line endings.
+
+ * mpost.w, mpxout.w: Use HAVE_STRUCT_STAT_ST_MTIM as define by
+ configure instead of (the undefined) HAVE_ST_MTIM.
+ * mp.w (mp_do_snprintf): Declare and define only when used.
+ FIXME: Should unconditionally assume snprintf() exists.
+
+2009-10-06 Peter Breitenlohner <peb@mppmu.mpg.de>
+
+ * am/libmplib.am, am/mplib.am: Enable compiler warnings.
+
+ * memio.w: Create and #include mpmemio.h (new internal header).
+ * tfmin.w: Create and #include mptfmin.h (new internal header).
+ * mp.w: #include mpmemio.h and mptfmin.h; drop extern decls for
+ functions from memio.w and tfmin.w.
+
+ Avoid many (--enable-...=max) compiler warnings.
+
+ * mp.w (mp_set_internal): Declare local string errid as const.
+ (mp_check_mem): Declare as static.
+ (mp_w_open_in, mp_print_word, mp_search_mem, mp_divide_scaled):
+ Comment out unused functions.
+ * psout.w (cs_do_debug, mp_gr_htap_ypoc): Comment out unused
+ functions.
+ * svgout.w: #include mplibsvg.h.
+ (mp_svg_font_pair_out, mp_svg_trans_pair_out,
+ mp_svg_print_glyph_defs): Declare as static.
+ (mp_svg_open_starttag, mp_svg_endtag, mp_svg_attribute): Declare
+ param strings as const.
+ (append_string): Declare local string ss as const.
+ (mp_svg_print): Drop useless (const *) cast.
+
+ * mpost.w (recorder_start, internal_set_option, run_set_list):
+ Declare as static.
+ (mpost_run_make_mpx, mpost_run_dvitomp): Declare local string
+ banner as const.
+ * mpxout.w (mpx_printf, mpx_report, mpx_warn, mpx_error,
+ mpx_abort, mpx_xfopen, mpx_match_str, mpx_def_named_color,
+ mpx_fsearch, mpx_read_fmap, mpx_read_char_adj, mpx_rename):
+ Declare param strings as const.
+ (progname): Declare global string as const.
+ (named_color_record): Declare member strings as const.
+
+2009-10-02 Taco Hoekwater <taco@elvenkind.com>
+
+ * Released version of MPLib 1.208
+
+2009-08-21 Peter Breitenlohner <peb@mppmu.mpg.de>
+
+ * mpost.w (kpathsea_version_string): Drop extern decl.
+
+2009-08-16 Peter Breitenlohner <peb@mppmu.mpg.de>
+
+ * am/mplib.am (mplib_ctangle): Use tangle-sh.
+ * am/libmplib.am, am/mplib.am: Adapt to tangle-sh.
+
+2009-08-12 Taco Hoekwater <taco@elvenkind.com>
+
+ * Released version of MPLib 1.207, including
+ a new mptrap.test
+
+2009-07-31 Taco Hoekwater <taco@elvenkind.com>
+
+ * Released version of MPLib 1.206
+
+2009-07-20 Taco Hoekwater <taco@elvenkind.com>
+
+ * mp.w: hotfix for a possible crash in lib mode
+
+2009-07-13 Taco Hoekwater <taco@elvenkind.com>
+
+ * Released version of MPLib 1.205
+
+2009-06-25 Peter Breitenlohner <peb@mppmu.mpg.de>
+
+ * mpost.w: add KPSEDLL to declaration of
+ kpathsea_version_string.
+
+2009-06-25 Taco Hoekwater <taco@elvenkind.com>
+
+ * Released version of MPLib 1.204
+
+2009-06-09 Taco Hoekwater <taco@elvenkind.com>
+
+ * Released version of MPLib 1.203
+
+2009-06-03 Taco Hoekwater <taco@elvenkind.com>
+
+ * Released version of MPLib 1.202
+
+2009-05-30 Peter Breitenlohner <peb@mppmu.mpg.de>
+
+ * am/mplib.am (install-exec-hook, uninstall-hook):
+ avoid dangling symlinks.
+
+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/mplib.am (install-exec-hook, uninstall-hook): new targets
+ to (un)install dvitomp symlink.
+
+2009-05-13 Peter Breitenlohner <peb@mppmu.mpg.de>
+
+ * mptrap.test (new): Shell script for MPTRAP test.
+ * am/mplib.am: Added MPTRAP test.
+
+2009-05-11 Taco Hoekwater <taco@elvenkind.com>
+
+ * Released version of MPLib 1.200
+
+2009-05-08 Taco Hoekwater <taco@elvenkind.com>
+
+ * Recent MPlib updates
+
+2009-04-22 Taco Hoekwater <taco@elvenkind.com>
+
+ * Import of MPlib version 1.200
diff --git a/Build/source/texk/web2c/mplibdir/am/libmplib.am b/Build/source/texk/web2c/mplibdir/am/libmplib.am
new file mode 100644
index 00000000000..4b0fc7fd59f
--- /dev/null
+++ b/Build/source/texk/web2c/mplibdir/am/libmplib.am
@@ -0,0 +1,103 @@
+## texk/web2c/mplibdir/am/libmplib.am: Makefile fragment for libmplib.
+##
+## Copyright (C) 2015-2020 Luigi Scarso <tex-live@tug.org>
+## Copyright (C) 2009-2014 Peter Breitenlohner <tex-live@tug.org>
+## You may freely use, modify and/or distribute this file.
+
+## libmplib.a, used by MetaPost and luaTeX
+##
+EXTRA_LIBRARIES += libmplibcore.a libmplibextramath.a libmplibbackends.a
+
+
+libmplibcore_a_CPPFLAGS = $(LIBPNG_INCLUDES) $(ZLIB_INCLUDES) $(AM_CPPFLAGS) -I$(srcdir)/mplibdir
+libmplibextramath_a_CPPFLAGS = $(MPFR_INCLUDES) $(GMP_INCLUDES) -I${top_builddir}/../../libs $(AM_CPPFLAGS) -I$(srcdir)/mplibdir
+libmplibbackends_a_CPPFLAGS = $(MPFR_INCLUDES) $(GMP_INCLUDES) $(CAIRO_INCLUDES) $(PIXMAN_INCLUDES) \
+ $(LIBPNG_INCLUDES) $(ZLIB_INCLUDES) $(AM_CPPFLAGS) -I$(srcdir)/mplibdir
+
+## libmplib C sources core + extramath + backends
+nodist_libmplibcore_a_SOURCES = tfmin.c $(mp_c_h) $(mpmath_c_h) $(mpmathdecimal_c_h) \
+ $(mpmathdouble_c_h) $(mpstrings_c_h) $(psout_c_h)
+nodist_libmplibextramath_a_SOURCES = $(mpmathbinary_c_h)
+nodist_libmplibbackends_a_SOURCES = $(pngout_c_h) $(svgout_c_h)
+
+
+
+mp_c_h = mp.c mplib.h mpmp.h
+mpmath_c_h = mpmath.h mpmath.c
+mpmathbinary_c_h = mpmathbinary.h mpmathbinary.c
+mpmathdecimal_c_h = mpmathdecimal.h mpmathdecimal.c
+mpmathdouble_c_h = mpmathdouble.h mpmathdouble.c
+mpstrings_c_h = mpstrings.h mpstrings.c
+psout_c_h = mplibps.h mppsout.h psout.c
+svgout_c_h = mplibsvg.h mpsvgout.h svgout.c
+pngout_c_h = mplibpng.h mppngout.h pngout.c
+
+# Creating one file: just one rule
+tfmin.c: ctangle$(EXEEXT) mplibdir/tfmin.w
+ $(mp_ctangle) tfmin.w
+
+# Creating several files: need stamp file and two rules with identical recipes
+$(mp_c_h): mp-tangle
+ @$(mp_ctangle_sh) mp
+mp-tangle: ctangle$(EXEEXT) mplibdir/mp.w tangle-sh
+ @$(mp_ctangle_sh) mp
+
+$(mpmath_c_h): mpmath-tangle mp-tangle
+ @$(mp_ctangle_sh) mpmath
+mpmath-tangle: ctangle$(EXEEXT) mplibdir/mpmath.w tangle-sh
+ @$(mp_ctangle_sh) mpmath
+
+$(mpmathbinary_c_h): mpmathbinary-tangle mp-tangle
+ @$(mp_ctangle_sh) mpmathbinary
+mpmathbinary-tangle: ctangle$(EXEEXT) mplibdir/mpmathbinary.w tangle-sh
+ @$(mp_ctangle_sh) mpmathbinary
+
+$(mpmathdecimal_c_h): mpmathdecimal-tangle mp-tangle
+ @$(mp_ctangle_sh) mpmathdecimal
+mpmathdecimal-tangle: ctangle$(EXEEXT) mplibdir/mpmathdecimal.w tangle-sh
+ @$(mp_ctangle_sh) mpmathdecimal
+
+$(mpmathdouble_c_h): mpmathdouble-tangle mp-tangle
+ @$(mp_ctangle_sh) mpmathdouble
+mpmathdouble-tangle: ctangle$(EXEEXT) mplibdir/mpmathdouble.w tangle-sh
+ @$(mp_ctangle_sh) mpmathdouble
+
+$(mpstrings_c_h): mpstrings-tangle
+ @$(mp_ctangle_sh) mpstrings
+mpstrings-tangle: ctangle$(EXEEXT) mplibdir/mpstrings.w tangle-sh
+ @$(mp_ctangle_sh) mpstrings
+
+$(pngout_c_h): pngout-tangle
+ @$(mp_ctangle_sh) pngout
+pngout-tangle: ctangle$(EXEEXT) mplibdir/pngout.w tangle-sh
+ @$(mp_ctangle_sh) pngout
+
+$(psout_c_h): psout-tangle
+ @$(mp_ctangle_sh) psout
+psout-tangle: ctangle$(EXEEXT) mplibdir/psout.w tangle-sh
+ @$(mp_ctangle_sh) psout
+
+$(svgout_c_h): svgout-tangle
+ @$(mp_ctangle_sh) svgout
+svgout-tangle: ctangle$(EXEEXT) mplibdir/svgout.w tangle-sh
+ @$(mp_ctangle_sh) svgout
+
+## libmplib CWeb sources
+libmplib_web = mplibdir/mp.w mplibdir/psout.w mplibdir/svgout.w mplibdir/pngout.w
+libmplib_web += mplibdir/mpmath.w mplibdir/mpmathbinary.w mplibdir/mpmathdecimal.w
+libmplib_web += mplibdir/mpmathdouble.w mplibdir/mpstrings.w mplibdir/tfmin.w
+
+## core need headers backends
+$(nodist_libmplibcore_a_SOURCES): $(mpmathbinary_c_h) $(svgout_c_h) $(pngout_c_h)
+
+$(libmplibcore_a_OBJECTS): $(nodist_libmplibcore_a_SOURCES) $(KPATHSEA_DEPEND)
+$(libmplibextramath_a_OBJECTS): $(nodist_libmplibextramath_a_SOURCES) $(KPATHSEA_DEPEND) $(MPFR_DEPEND)
+$(libmplibbackends_a_OBJECTS): $(nodist_libmplibbackends_a_SOURCES) $(KPATHSEA_DEPEND) $(CAIRO_DEPEND) $(MPFR_DEPEND)
+
+
+EXTRA_DIST += $(libmplib_web)
+
+DISTCLEANFILES += $(nodist_libmplibcore_a_SOURCES) $(nodist_libmplibextramath_a_SOURCES) $(nodist_libmplibbackends_a_SOURCES) \
+ mp-tangle mpmath-tangle mpmathdecimal-tangle mpmathdouble-tangle \
+ mpstrings-tangle psout-tangle svgout-tangle pngout-tangle
+
diff --git a/Build/source/texk/web2c/mplibdir/am/libmputil.am b/Build/source/texk/web2c/mplibdir/am/libmputil.am
new file mode 100644
index 00000000000..09ace983a0b
--- /dev/null
+++ b/Build/source/texk/web2c/mplibdir/am/libmputil.am
@@ -0,0 +1,15 @@
+## texk/web2c/mplibdir/am/libmplib.am: Makefile fragment for libmplib.
+##
+## Copyright (C) 2014 Peter Breitenlohner <tex-live@tug.org>
+## You may freely use, modify and/or distribute this file.
+
+## libmplib.a, used by MetaPost and luaTeX
+##
+EXTRA_LIBRARIES += libmputil.a
+
+libmputil_a_CPPFLAGS = $(AM_CPPFLAGS) -I$(srcdir)/mplibdir
+
+## libmputil C sources
+libmputil_a_SOURCES = mplibdir/avl.h mplibdir/avl.c mplibdir/decNumber.c mplibdir/decNumber.h \
+ mplibdir/decNumberLocal.h mplibdir/decContext.h mplibdir/decContext.c
+
diff --git a/Build/source/texk/web2c/mplibdir/am/mplib.am b/Build/source/texk/web2c/mplibdir/am/mplib.am
new file mode 100644
index 00000000000..a8b0da6ee26
--- /dev/null
+++ b/Build/source/texk/web2c/mplibdir/am/mplib.am
@@ -0,0 +1,92 @@
+## texk/web2c/mplibdir/am/mplib.am: Makefile fragment for MetaPost.
+##
+## Copyright 2017-2018 Luigi Scarso <tex-live@tug.org>
+## Copyright 2009-2015 Peter Breitenlohner <tex-live@tug.org>
+## You may freely use, modify and/or distribute this file.
+
+## MetaPost
+##
+if MP
+bin_PROGRAMS += mpost
+if WIN32
+noinst_PROGRAMS += call_mpost
+install_exe_links += install-mpost-links
+uninstall_exe_links += uninstall-mpost-links
+else !WIN32
+bin_links += mpost$(EXEEXT):dvitomp mpost$(EXEEXT):mfplain
+bin_links += mpost$(EXEEXT):r-mpost
+endif !WIN32
+endif MP
+EXTRA_PROGRAMS += mpost
+
+mpost_CPPFLAGS = $(AM_CPPFLAGS) $(ZLIB_INCLUDES) $(LIBPNG_INCLUDES) -I$(srcdir)/mplibdir
+mpost_LDADD = libmplibcore.a libmplibextramath.a libmplibbackends.a $(KPATHSEA_LIBS) $(MPFR_LIBS) $(GMP_LIBS) \
+ $(CAIRO_LIBS) $(PIXMAN_LIBS) $(LIBPNG_LIBS) $(ZLIB_LIBS) libmputil.a
+
+
+
+call_mpost_CPPFLAGS = -DEXEPROG=\"mpost.exe\"
+nodist_call_mpost_SOURCES = callexe.c
+call_mpost_LDADD =
+
+.PHONY: install-mpost-links uninstall-mpost-links
+if WIN32
+install-mpost-links: call_mpost$(EXEEXT)
+ $(INSTALL_PROGRAM) call_mpost$(EXEEXT) $(DESTDIR)$(bindir)/dvitomp$(EXEEXT)
+ $(INSTALL_PROGRAM) call_mpost$(EXEEXT) $(DESTDIR)$(bindir)/mfplain$(EXEEXT)
+uninstall-mpost-links:
+ rm -f $(DESTDIR)$(bindir)/dvitomp$(EXEEXT)
+ rm -f $(DESTDIR)$(bindir)/mfplain$(EXEEXT)
+endif WIN32
+
+# Creating one file: just one rule
+mp_ctangle = $(ctangle_silent)CWEBINPUTS=$(srcdir)/mplibdir $(ctangle)
+# Creating several files: need stamp file and two rules with identical recipes
+mp_ctangle_sh = CWEBINPUTS=$(srcdir)/mplibdir AM_V_P=$(AM_V_P) $(SHELL) ./tangle-sh $@ $(CTANGLE)
+
+## MetaPost C sources
+nodist_mpost_SOURCES = mpost.c $(mpxout_c_h)
+mpxout_c_h = mpxout.c mpxout.h
+
+mpost.c: ctangle$(EXEEXT) mplibdir/mpost.w
+ $(mp_ctangle) mpost.w
+
+$(mpxout_c_h): mpxout-tangle
+ @$(mp_ctangle_sh) mpxout
+mpxout-tangle: ctangle$(EXEEXT) mplibdir/mpxout.w tangle-sh
+ @$(mp_ctangle_sh) mpxout
+
+## MetaPost CWeb sources
+mpost_web = mplibdir/mpost.w mplibdir/mpxout.w
+
+#$(mpost_OBJECTS): $(nodist_mpost_SOURCES) libmplib.a $(LIBPNG_DEPEND)
+$(mpost_OBJECTS): $(nodist_mpost_SOURCES) libmplibcore.a libmplibextramath.a libmplibbackends.a $(LIBPNG_DEPEND)
+
+EXTRA_DIST += mplibdir/ChangeLog $(mpost_web)
+
+DISTCLEANFILES += $(nodist_mpost_SOURCES) mpxout-tangle
+
+## MetaPost Tests
+##
+mp_tests = mplibdir/dvitomp.test mplibdir/mptraptest.test
+mplibdir/dvitomp.log: mpost$(EXEEXT)
+mplibdir/mptraptest.log: mpost$(EXEEXT) pltotf$(EXEEXT) tftopl$(EXEEXT)
+
+EXTRA_DIST += $(mp_tests)
+
+if MP
+TESTS += $(mp_tests)
+TRIPTRAP += mptrap.diffs
+TRIPTRAP_CLEAN += mptrap-clean
+endif MP
+DISTCLEANFILES += mptrap.diffs
+
+## mplibdir/dvitomp.test
+DISTCLEANFILES += ptmr.mpx tests/xptmr.mpx tests/xstory.mpx
+## mplibdir/mptraptest
+mptrap.diffs: mpost$(EXEEXT) pltotf$(EXEEXT) tftopl$(EXEEXT)
+ $(triptrap_diffs) $@
+.PHONY: mptrap-clean
+mptrap-clean:
+ rm -rf mptrapdir
+
diff --git a/Build/source/texk/web2c/mplibdir/avl.c b/Build/source/texk/web2c/mplibdir/avl.c
new file mode 100644
index 00000000000..de3c63322ad
--- /dev/null
+++ b/Build/source/texk/web2c/mplibdir/avl.c
@@ -0,0 +1,2638 @@
+
+/* pyavl -- File "avl.c" */
+
+/* AVL trees with RANK field and parent pointers */
+
+#include "avl.h"
+
+#ifdef AVL_SHOW_ERROR_ON
+#define AVL_SHOW_ERROR(fmt,arg) fprintf(stderr, "! avl.c: " fmt, arg)
+#else
+#define AVL_SHOW_ERROR(fmt,arg) (void) (fmt), (void) (arg)
+#endif
+
+const void *
+avl_default_item_copy (const void *item)
+{
+ return (const void *) item;
+}
+
+void *
+avl_default_item_dispose (void *item)
+{
+ (void)item; /* for -Wall */
+ return (void *) NULL;
+}
+
+#ifndef MPW_C
+typedef uint32_t rbal_t; /* integral type to encode rank and skew bits */
+#else
+typedef UInt32 rbal_t;
+#endif
+
+/*
+ * avl_node structure
+ */
+
+typedef struct avl_node
+{
+ struct avl_node *sub[2];
+ struct avl_node *up;
+ rbal_t rbal;
+ void *item;
+}
+avl_node;
+
+/*
+ * avl_tree structure
+ */
+
+struct avl_tree_
+{
+ avl_node *root;
+ avl_size_t count; /* how many nodes in tree rooted at [root] */
+ avl_compare_func compare; /* compare items */
+ avl_item_copy_func copy;
+ avl_item_dispose_func dispose;
+ avl_alloc_func alloc; /* to allocate memory (same signature as malloc) */
+ avl_dealloc_func dealloc; /* to deallocate memory (same signature as free) */
+ void *param;
+};
+
+#define Item_Compare(cmp, tree, item1, item2)\
+ (*cmp)(tree->param, item1, item2)
+
+/* patches (November 2004) */
+
+#if AVL_CMPERR != 0
+#define CMPERR_CHECK__FIND(param) if (avl_errcmp_occurred(param)) return NULL
+#define CMPERR_CHECK__INDEX(param) if (avl_errcmp_occurred(param)) return 0
+#define CMPERR_CHECK__SPAN(param) if (avl_errcmp_occurred(param)) return -2
+#define CMPERR_CHECK__INS(param) if (avl_errcmp_occurred(param)) return -2
+#define CMPERR_CHECK__DEL(param) (avl_errcmp_occurred(param) ? -2 : 0)
+#define CMPERR_CHECK__SPLIT(param) if (avl_errcmp_occurred(param)) return -2
+#define CMPERR_CHECK__VERIFY(param) && (!avl_errcmp_occurred(param))
+#else
+#define CMPERR_CHECK__FIND(param) (void) param
+#define CMPERR_CHECK__INDEX(param) (void) param
+#define CMPERR_CHECK__SPAN(param) (void) param
+#define CMPERR_CHECK__INS(param) (void) param
+#define CMPERR_CHECK__DEL(param) 0
+#define CMPERR_CHECK__SPLIT(param) (void) param
+#define CMPERR_CHECK__VERIFY(param) /* nothing */
+#endif
+
+#define sub_left(a) (a)->sub[0]
+#define sub_right(a) (a)->sub[1]
+#define get_item(a) (a)->item
+
+/* RANK(a) = size of left subtree + 1 */
+
+#define rbal(a)\
+ (a)->rbal
+#define rzero(a)\
+ ( rbal(a) & ~3 )
+#define get_bal(a)\
+ ( rbal(a) & 3 )
+#define is_lskew(a)\
+ ( rbal(a) & 1 )
+#define is_rskew(a)\
+ ( rbal(a)>>1 & 1)
+#define set_lskew(a)\
+ ( rbal(a) |= 1 )
+#define set_rskew(a)\
+ ( rbal(a) |= 2 )
+#define set_skew(a,d)\
+ ( rbal(a) |= (1 << d) )
+#define unset_lskew(a)\
+ ( rbal(a) &= ~1 )
+#define unset_rskew(a)\
+ ( rbal(a) &= ~2 )
+#define get_rank(a)\
+ ( rbal(a) >> 2 )
+#define set_rank(a,r)\
+ ( rbal(a) = (r<<2 | get_bal(a)) )
+#define incr_rank(a,r)\
+ ( rbal(a) += r<<2 )
+#define decr_rank(a,r)\
+ ( rbal(a) -= r<<2 )
+
+#define AVL_MIN_DEPTH 0
+
+/*** Node management ***/
+
+#define DETACH_FUNC 1 /* nonzero to use function not macro */
+
+/* helper structure */
+typedef enum
+{
+ OP_BACKUP, OP_DETACH, OP_FREE
+}
+whichop_t;
+struct ptr_handler
+{
+ whichop_t whichop;
+ void *ptr;
+};
+
+#define ini_ptr_handler(h,op) struct ptr_handler h = { OP_##op, NULL }
+#define clear_node(a) \
+ sub_left(a) = NULL; \
+ sub_right(a) = NULL; \
+ (a)->up = NULL; \
+ rbal(a) = 4u
+
+/* Called by 'avl_ins', 'avl_dup', 'node_slice' */
+static avl_node *
+new_node (void *item, avl_node * up, avl_tree t)
+{
+ avl_node *a = (*t->alloc) (sizeof (avl_node));
+
+ if (a != NULL)
+ {
+ sub_left (a) = NULL;
+ sub_right (a) = NULL;
+ a->up = up;
+ a->rbal = 4u;
+ a->item = (*t->copy) (item);
+ }
+ return a;
+}
+
+static void
+free_node (avl_node * a, avl_tree t)
+{
+ a->item = (*t->dispose) (a->item);
+ (*t->dealloc) (a);
+}
+
+#define backup_item(backup,item,t) if (backup == NULL) ; else *backup = (*t->copy)(item)
+
+#if ! DETACH_FUNC
+
+/* macro to detach node [a] from tree [t] */
+#define detach_node(a,t,h) { struct ptr_handler *ch = h; \
+ clear_node(a); \
+ do { \
+ if (ch == NULL) ; \
+ else if (ch->whichop == OP_DETACH){ \
+ ch->ptr = a; \
+ break; \
+ } else if (ch->whichop == OP_BACKUP){ \
+ ch->ptr = (*t->copy)(a->item); \
+ } \
+ free_node(a, t); \
+ } while (0);} \
+ t->count--
+#else
+
+/* function to detach node [a] from tree [t] */
+static void
+detach_node (avl_node * a, avl_tree t, struct ptr_handler *h)
+{
+ clear_node (a);
+ do
+ {
+ if (h == NULL);
+ else if (h->whichop == OP_DETACH)
+ {
+ h->ptr = a;
+ break;
+ }
+ else if (h->whichop == OP_BACKUP)
+ {
+ h->ptr = (*t->copy) (a->item);
+ }
+ free_node (a, t);
+ }
+ while (0);
+ t->count--;
+}
+#endif /* DETACH_FUNC */
+
+/*** Tree methods ***/
+
+avl_tree
+avl_create (avl_compare_func compare, avl_item_copy_func copy,
+ avl_item_dispose_func dispose, avl_alloc_func alloc,
+ avl_dealloc_func dealloc, void *param)
+{
+ avl_tree t = (*alloc) (sizeof (struct avl_tree_));
+
+ if (t == NULL)
+ AVL_SHOW_ERROR ("%s\n", "couldn't create new handle in avl_create()");
+ else
+ {
+ t->root = NULL;
+ t->count = 0;
+ t->param = param;
+ t->compare = compare;
+ t->copy = copy;
+ t->dispose = dispose;
+ t->alloc = alloc;
+ t->dealloc = dealloc;
+ }
+ return t;
+}
+
+/* Empty the tree, using rotations */
+
+static void
+node_empty (avl_tree t)
+{
+ avl_node *a, *p;
+
+ for (a = t->root; a != NULL;)
+ {
+ p = a;
+ if (sub_right (a) == NULL)
+ a = sub_left (a);
+ else
+ {
+ while (sub_left (a) != NULL)
+ {
+ /* rotR(a) */
+ a = sub_left (a);
+ sub_left (p) = sub_right (a);
+ sub_right (a) = p;
+ p = a;
+ }
+ a = sub_right (p);
+ }
+ free_node (p, t);
+ t->count--;
+ }
+ t->root = NULL;
+}
+
+/* [t] is an existing tree handle */
+
+/* this function invokes node_empty() */
+
+void
+avl_reset (avl_tree t,
+ avl_compare_func compare,
+ avl_item_copy_func copy,
+ avl_item_dispose_func dispose,
+ avl_alloc_func alloc, avl_dealloc_func dealloc)
+{
+ if (t == NULL)
+ return;
+ node_empty (t);
+ t->compare = compare;
+ t->copy = copy;
+ t->dispose = dispose;
+ t->alloc = alloc;
+ t->dealloc = dealloc;
+}
+
+void
+avl_empty (avl_tree t)
+{
+ if (t != NULL)
+ node_empty (t);
+}
+
+/* Destroy nodes, free handle */
+
+void
+avl_destroy (avl_tree t)
+{
+#ifndef AVL_NULLCHECKS
+ if (t == NULL)
+ return;
+#endif
+ node_empty (t);
+ (*t->dealloc) (t);
+}
+
+avl_tree
+avl_dup (avl_tree t, void *param)
+{
+#ifndef AVL_NULLCHECKS
+ if (t == NULL)
+ return NULL;
+#endif
+ {
+ avl_tree tt = avl_create (
+ /*(avl_compare_func) */ t->compare,
+ /*(avl_item_copy_func) */ t->copy,
+ /*(avl_item_dispose_func) */ t->dispose,
+ /*(avl_alloc_func) */ t->alloc,
+ /*(avl_dealloc_func) */ t->dealloc,
+ param);
+
+ if (tt == NULL)
+ {
+ AVL_SHOW_ERROR ("%s\n", "couldn't create new handle in avl_dup()");
+ return NULL;
+ }
+
+ tt->count = t->count;
+
+ if (t->root == NULL)
+ return tt;
+
+ {
+ avl_node *a, *c, *s;
+
+ a = t->root;
+ tt->root = c = new_node (get_item (a), NULL, t);
+ if (c == NULL)
+ goto abort;
+
+ sub_right (c) = NULL; /*!!! */
+ rbal (c) = rbal (a);
+
+ while (1)
+ {
+ while (sub_left (a) != NULL)
+ {
+ a = sub_left (a);
+ sub_left (c) = s = new_node (get_item (a), NULL, t);
+ if (s == NULL)
+ goto recover;
+ s->up = c;
+ sub_right (s) = c;
+ c = s;
+ rbal (c) = rbal (a);
+ }
+
+ sub_left (c) = NULL;
+
+ while (sub_right (a) == NULL)
+ {
+ s = sub_right (c);
+ sub_right (c) = NULL;
+ c = s;
+ /* Find successor of [a] in original tree */
+ do
+ {
+ s = a;
+ a = s->up;
+ if (a == NULL)
+ return tt;
+ }
+ while (s != sub_left (a));
+ }
+
+ a = sub_right (a);
+ s = new_node (get_item (a), NULL, t);
+ if (s == NULL)
+ goto recover;
+ sub_right (s) = sub_right (c);
+ sub_right (c) = s;
+ s->up = c;
+ c = s;
+ rbal (c) = rbal (a);
+ }
+ /* recovery code */
+ recover:
+ while (1)
+ {
+ s = sub_right (c);
+ sub_right (c) = NULL;
+ if (s == NULL)
+ break;
+ c = s;
+ }
+ node_empty (tt);
+
+ abort:
+ (*t->dealloc) (tt);
+ AVL_SHOW_ERROR ("%s\n", "couldn't allocate node in avl_dup()");
+ return NULL;
+ }
+ }
+}
+
+avl_bool_t
+avl_isempty (avl_tree t)
+{
+#ifndef AVL_NULLCHECKS
+ return t == NULL || t->root == NULL;
+#else
+ return t->root == NULL;
+#endif
+}
+
+avl_size_t
+avl_size (avl_tree t)
+{
+#ifndef AVL_NULLCHECKS
+ return t == NULL ? 0 : t->count;
+#else
+ return t->count;
+#endif
+}
+
+static int
+depth (avl_node * a)
+{
+ int h = AVL_MIN_DEPTH;
+
+ for (; a != NULL; ++h)
+ a = a->sub[is_rskew (a)];
+ return h;
+}
+
+static avl_node *
+node_first (avl_node * a)
+{
+ while (sub_left (a) != NULL)
+ a = sub_left (a);
+ return a;
+}
+
+static avl_node *
+node_last (avl_node * a)
+{
+ while (sub_right (a) != NULL)
+ a = sub_right (a);
+ return a;
+}
+
+/* [a] : non-null */
+
+static avl_node *
+node_next (avl_node * a)
+{
+ if (sub_right (a) != NULL)
+ return node_first (sub_right (a));
+ {
+ avl_node *p;
+
+ do
+ {
+ p = a;
+ a = p->up;
+ }
+ while (a != NULL && sub_right (a) == p);
+ return a;
+ }
+}
+
+/* [a] : non-null */
+
+static avl_node *
+node_prev (avl_node * a)
+{
+ if (sub_left (a) != NULL)
+ return node_last (sub_left (a));
+ {
+ avl_node *p;
+
+ do
+ {
+ p = a;
+ a = p->up;
+ }
+ while (a != NULL && sub_left (a) == p);
+ return a;
+ }
+}
+
+static avl_node *
+node_find (const void *item, avl_tree t)
+{
+ avl_node *a = t->root;
+ avl_compare_func cmp = t->compare;
+ int c;
+
+ while (a != NULL)
+ {
+ c = Item_Compare (cmp, t, item, get_item (a));
+ CMPERR_CHECK__FIND (t->param);
+ if (c < 0)
+ a = a->sub[0];
+ else if (c)
+ a = a->sub[1];
+ else
+ break;
+ }
+ return a;
+}
+
+#if 0==1
+static avl_node **
+avl_search (const void *item, avl_tree t, int *dir)
+{
+ if (t->root == NULL)
+ return &t->root;
+ {
+ avl_node **r = &t->root;
+ avl_node *a = *r;
+ avl_compare_func cmp = t->compare;
+ int c;
+
+ while (1)
+ {
+ c = Item_Compare (cmp, t, item, get_item (a));
+ if (!c)
+ break;
+ r = &a->sub[c = c > 0];
+ if (*r == NULL)
+ {
+ *dir = c;
+ break;
+ }
+ a = *r;
+ }
+
+ return r;
+ }
+}
+#endif
+
+static avl_size_t
+get_index (avl_node * a)
+{
+ avl_size_t n = get_rank (a);
+ avl_node *p;
+
+ while ((p = a->up) != NULL)
+ {
+ if (a != sub_left (p))
+ n += get_rank (p);
+ a = p;
+ }
+ return n;
+}
+
+/* Find item by index */
+
+static avl_node *
+node_find_index (avl_size_t idx, avl_tree t)
+{
+ avl_node *a = t->root;
+ int c;
+
+ if (idx == 0 || idx > t->count)
+ return NULL;
+ if (idx == 1)
+ return node_first (a);
+ if (idx == t->count)
+ return node_last (a);
+
+ while ((c = (int)(idx - get_rank (a))) != 0)
+ {
+ if (c < 0)
+ a = sub_left (a);
+ else
+ {
+ idx = (avl_size_t)c;
+ a = sub_right (a);
+ }
+ }
+
+ return a;
+}
+
+/* Rebalance starting from node [a] where a->sub[d_]
+ * is deeper post-insertion
+ */
+
+static avl_code_t
+rebalance_ins (avl_node * a, int dir, avl_tree t)
+{
+ if (a != NULL)
+ {
+ avl_node *p;
+
+ while (1)
+ {
+ incr_rank (a, (rbal_t)(!dir));
+ if (get_bal (a))
+ break;
+ set_skew (a, dir);
+ p = a->up;
+ if (p == NULL)
+ return 2;
+ dir = a != sub_left (p);
+ a = p;
+ }
+
+ /* Now bal(a) == -1 or +1 */
+ /* Rotate if need be */
+
+ if (0 == dir)
+ {
+ if (is_rskew (a))
+ unset_rskew (a);
+
+ else
+ {
+ avl_node *u = a->up;
+ avl_node **r =
+ u != NULL ? &u->sub[a != sub_left (u)] : &t->root;
+
+ p = a;
+
+ if (is_lskew (sub_left (p)))
+ {
+ /* rotR(p) */
+ a = sub_left (p);
+ sub_left (p) = sub_right (a);
+ if (sub_right (a) != NULL)
+ sub_right (a)->up = p;
+ sub_right (a) = p;
+ unset_lskew (p);
+ rbal (p) -= rzero (a);
+ }
+ else
+ {
+ /* rotLR(p) */
+ a = sub_right (sub_left (p));
+ sub_right (sub_left (p)) = sub_left (a);
+ if (sub_left (a) != NULL)
+ sub_left (a)->up = sub_left (p);
+ sub_left (p)->up = a;
+ sub_left (a) = sub_left (p);
+ sub_left (p) = sub_right (a);
+ if (sub_right (a) != NULL)
+ sub_right (a)->up = p;
+ sub_right (a) = p;
+ switch (get_bal (a))
+ {
+ case 0: /* not skewed */
+ unset_lskew (p);
+ unset_rskew (sub_left (a));
+ break;
+ case 1: /* left skew */
+ unset_lskew (p);
+ set_rskew (p);
+ unset_rskew (sub_left (a));
+ break;
+ case 2: /* right skew */
+ unset_lskew (p);
+ unset_rskew (sub_left (a));
+ set_lskew (sub_left (a));
+ } /* switch */
+ rbal (a) += rzero (sub_left (a));
+ rbal (p) -= rzero (a);
+ } /* which rot */
+ rbal (a) &= ~3;
+ a->up = u;
+ p->up = a;
+ *r = a;
+ } /* rot or no rot ? */
+ }
+ else
+ {
+ /* direction == 1 */
+
+ if (is_lskew (a))
+ unset_lskew (a);
+
+ else
+ {
+ avl_node *u = a->up;
+ avl_node **r =
+ u != NULL ? &u->sub[a != sub_left (u)] : &t->root;
+
+ p = a;
+ if (is_rskew (sub_right (p)))
+ {
+ /* rotL(p) */
+ a = sub_right (p);
+ sub_right (p) = sub_left (a);
+ if (sub_left (a) != NULL)
+ sub_left (a)->up = p;
+ sub_left (a) = p;
+ unset_rskew (p);
+ rbal (a) += rzero (p);
+ }
+ else
+ {
+ /* rotRL(p) */
+ a = sub_left (sub_right (p));
+ sub_left (sub_right (p)) = sub_right (a);
+ if (sub_right (a) != NULL)
+ sub_right (a)->up = sub_right (p);
+ sub_right (p)->up = a;
+ sub_right (a) = sub_right (p);
+ sub_right (p) = sub_left (a);
+ if (sub_left (a) != NULL)
+ sub_left (a)->up = p;
+ sub_left (a) = p;
+ switch (get_bal (a))
+ {
+ case 0: /* not skewed */
+ unset_rskew (p);
+ unset_lskew (sub_right (a));
+ break;
+ case 1: /* left skew */
+ unset_rskew (p);
+ unset_lskew (sub_right (a));
+ set_rskew (sub_right (a));
+ break;
+ case 2: /* right skew */
+ unset_rskew (p);
+ set_lskew (p);
+ unset_lskew (sub_right (a));
+ } /* switch */
+ rbal (sub_right (a)) -= rzero (a);
+ rbal (a) += rzero (p);
+
+ } /* which rot */
+
+ rbal (a) &= ~3;
+ a->up = u;
+ p->up = a;
+ *r = a;
+ } /* rot or not rot ? */
+ } /* if 0==dir */
+
+ /* The tree rooted at 'a' is now valid */
+ /* Finish adjusting ranks */
+
+ while ((p = a->up) != NULL)
+ {
+ incr_rank (p, (rbal_t)(a == sub_left (p)));
+ a = p;
+ }
+
+ return 1;
+
+ } /* if a != 0 */
+ return 2;
+}
+
+/* detach [p] : non-null */
+
+/* only the linkage is tweaked */
+
+static avl_code_t
+rebalance_del (avl_node * p, avl_tree t, void **backup)
+{
+ avl_node **r, *a, *c;
+ rbal_t bal;
+ int dir = 0;
+
+ a = p->up;
+ if (a == NULL)
+ r = &t->root;
+ else
+ r = &a->sub[dir = p != sub_left (a)];
+
+ c = sub_right (p);
+ if (c == NULL && sub_left (p) == NULL)
+ *r = NULL;
+ else if (c == NULL || sub_left (p) == NULL)
+ {
+ *r = c != NULL ? c : sub_left (p);
+ (*r)->up = a;
+ }
+ else
+ {
+ if (sub_left (c) == NULL)
+ {
+ a = c;
+ dir = 1;
+ }
+ else
+ {
+ do
+ c = sub_left (c);
+ while (sub_left (c) != NULL);
+ a = c->up;
+ dir = 0;
+ sub_left (a) = sub_right (c);
+ if (sub_right (c) != NULL)
+ sub_right (c)->up = a;
+ sub_right (c) = sub_right (p);
+ sub_right (c)->up = c;
+ }
+ sub_left (c) = sub_left (p);
+ sub_left (c)->up = c;
+ c->up = p->up;
+ rbal (c) = rbal (p);
+ *r = c;
+ }
+
+ backup_item (backup, p->item, t);
+ detach_node (p, t, NULL);
+
+ /* Start backtracking : subtree of [a] in direction [dir] is less deep */
+
+ for (;; a = (*r)->up)
+ {
+ if (a == NULL)
+ return 2;
+
+ decr_rank (a, (rbal_t)(!dir));
+ bal = get_bal (a);
+
+ if (0 == dir)
+ {
+ if (bal == 0)
+ {
+ set_rskew (a);
+ break;
+ }
+ if (a->up == NULL)
+ r = &t->root;
+ else
+ {
+ dir = a != sub_left (a->up);
+ r = &a->up->sub[dir];
+ }
+ if (bal & 1)
+ unset_lskew (a);
+ if (get_bal (a))
+ {
+ p = a;
+ bal = get_bal (sub_right (p));
+ if (!(bal & 1))
+ {
+ /* bal = 0 or +1 */
+ /* rotL(p) */
+ a = sub_right (p);
+ sub_right (p) = sub_left (a);
+ if (sub_left (a) != NULL)
+ sub_left (a)->up = p;
+ sub_left (a) = p;
+ if (bal)
+ {
+ unset_rskew (p);
+ unset_rskew (a);
+ }
+ else
+ set_lskew (a);
+ rbal (a) += rzero (p);
+ }
+ else
+ {
+ /* rotRL(p) */
+ a = sub_left (sub_right (p));
+ sub_left (sub_right (p)) = sub_right (a);
+ if (sub_right (a) != NULL)
+ sub_right (a)->up = sub_right (p);
+ sub_right (p)->up = a;
+ sub_right (a) = sub_right (p);
+ sub_right (p) = sub_left (a);
+ if (sub_left (a) != NULL)
+ sub_left (a)->up = p;
+ sub_left (a) = p;
+ switch (get_bal (a))
+ {
+ case 0: /* not skewed */
+ unset_rskew (p);
+ unset_lskew (sub_right (a));
+ break;
+ case 1: /* left skew */
+ unset_rskew (p);
+ unset_lskew (sub_right (a));
+ set_rskew (sub_right (a));
+ break;
+ case 2: /* right skew */
+ unset_rskew (p);
+ set_lskew (p);
+ unset_lskew (sub_right (a));
+ } /* switch */
+ rbal (a) &= ~3;
+ rbal (sub_right (a)) -= rzero (a);
+ rbal (a) += rzero (p);
+
+ } /* which rot */
+
+ a->up = p->up;
+ p->up = a;
+ /* Done with rotation */
+ *r = a;
+ if (bal == 0)
+ break;
+ } /* if getbal(a) */
+ }
+ else
+ {
+ /* dir == 1 */
+
+ if (bal == 0)
+ {
+ set_lskew (a);
+ break;
+ }
+ if (a->up == NULL)
+ r = &t->root;
+ else
+ {
+ dir = a != sub_left (a->up);
+ r = &a->up->sub[dir];
+ }
+ if (bal & 2)
+ unset_rskew (a);
+ if (get_bal (a))
+ {
+ p = a;
+ bal = get_bal (sub_left (p));
+ if (!(bal & 2))
+ {
+ /* bal = 0 or -1 */
+ /* rotR(p) */
+ a = sub_left (p);
+ sub_left (p) = sub_right (a);
+ if (sub_right (a) != NULL)
+ sub_right (a)->up = p;
+ sub_right (a) = p;
+ if (bal)
+ {
+ unset_lskew (p);
+ unset_lskew (a);
+ }
+ else
+ set_rskew (a);
+ rbal (p) -= rzero (a);
+ }
+ else
+ {
+ /* rotLR(p) */
+ a = sub_right (sub_left (p));
+ sub_right (sub_left (p)) = sub_left (a);
+ if (sub_left (a) != NULL)
+ sub_left (a)->up = sub_left (p);
+ sub_left (p)->up = a;
+ sub_left (a) = sub_left (p);
+ sub_left (p) = sub_right (a);
+ if (sub_right (a) != NULL)
+ sub_right (a)->up = p;
+ sub_right (a) = p;
+ switch (get_bal (a))
+ {
+ case 0: /* not skewed */
+ unset_lskew (p);
+ unset_rskew (sub_left (a));
+ break;
+ case 1: /* left skew */
+ unset_lskew (p);
+ set_rskew (p);
+ unset_rskew (sub_left (a));
+ break;
+ case 2: /* right skew */
+ unset_lskew (p);
+ unset_rskew (sub_left (a));
+ set_lskew (sub_left (a));
+ } /* switch */
+ rbal (a) &= ~3;
+ rbal (a) += rzero (sub_left (a));
+ rbal (p) -= rzero (a);
+ } /* which rot */
+
+ a->up = p->up;
+ p->up = a;
+ /* Done with rotation */
+ *r = a;
+ if (bal == 0)
+ break;
+ } /* if getbal(a) */
+ } /* if dir==0 else 1 */
+ } /* for */
+
+ /* Finish adjusting ranks */
+ while ((p = a->up) != NULL)
+ {
+ decr_rank (p, (rbal_t)(a == sub_left (p)));
+ a = p;
+ }
+
+ return 1;
+}
+
+void *
+avl_first (avl_tree t)
+{
+#ifndef AVL_NULLCHECKS
+ if (t == NULL || t->root == NULL)
+#else
+ if (t->root == NULL)
+#endif
+ return NULL;
+ return get_item (node_first (t->root));
+}
+
+void *
+avl_last (avl_tree t)
+{
+#ifndef AVL_NULLCHECKS
+ if (t == NULL || t->root == NULL)
+#else
+ if (t->root == NULL)
+#endif
+ return NULL;
+ return get_item (node_last (t->root));
+}
+
+void *
+avl_find (const void *item, avl_tree t)
+{
+ avl_node *a;
+
+#ifndef AVL_NULLCHECKS
+ if (t == NULL)
+ return NULL;
+#endif
+ a = node_find (item, t);
+ return a != NULL ? get_item (a) : NULL;
+}
+
+/*
+ * Return smallest index i in [1:len] s.t. tree[i] matches [item],
+ * or zero if not found
+ */
+
+avl_size_t
+avl_index (const void *item, avl_tree t)
+{
+#ifndef AVL_NULLCHECKS
+ if (item == NULL || t == NULL || t->root == NULL)
+#else
+ if (t->root == NULL)
+#endif
+ return 0;
+
+ {
+ avl_compare_func cmp = t->compare;
+ avl_node *a, *p;
+ avl_size_t idx = 0, n = 0;
+ int c;
+
+ for (a = t->root;;)
+ {
+ c = Item_Compare (cmp, t, item, get_item (a));
+ CMPERR_CHECK__INDEX (t->param);
+ if (!c)
+ idx = n + get_rank (a);
+ else if (c > 0)
+ n += get_rank (a);
+ p = a->sub[c > 0];
+ if (p == NULL)
+ return idx;
+ a = p;
+ }
+ }
+}
+
+/* (lo,hi) where
+ * lo smallest index s.t. t[lo] >= lo_item, or t->count+1 and
+ * hi greatest index s.t. t[hi] <= hi_item, or 0
+ */
+avl_code_t
+avl_span (const void *lo_item,
+ const void *hi_item,
+ avl_tree t, avl_size_t * lo_idx, avl_size_t * hi_idx)
+{
+ *lo_idx = t->count + 1;
+ *hi_idx = 0;
+
+#ifndef AVL_NULLCHECKS
+ if (t == NULL || t->root == NULL)
+#else
+ if (t->root == NULL)
+#endif
+ return -1;
+
+ {
+ avl_compare_func cmp = t->compare;
+ avl_node *a;
+ avl_size_t n = 0;
+ int c;
+
+ c = Item_Compare (cmp, t, lo_item, hi_item) > 0;
+ CMPERR_CHECK__SPAN (t->param);
+ if (c > 0)
+ {
+ const void *temp = lo_item;
+
+ lo_item = hi_item;
+ hi_item = temp;
+ }
+
+ a = t->root;
+ do
+ {
+ c = Item_Compare (cmp, t, lo_item, get_item (a));
+ CMPERR_CHECK__SPAN (t->param);
+ if (c > 0)
+ {
+ n += get_rank (a);
+ a = sub_right (a);
+ }
+ else
+ {
+ *lo_idx = n + get_rank (a);
+ a = sub_left (a);
+ }
+ }
+ while (a);
+
+ a = t->root;
+ do
+ {
+ c = Item_Compare (cmp, t, hi_item, get_item (a));
+ CMPERR_CHECK__SPAN (t->param);
+ if (c < 0)
+ {
+ a = sub_left (a);
+ }
+ else
+ {
+ *hi_idx += get_rank (a);
+ a = sub_right (a);
+ }
+ }
+ while (a);
+ return 0;
+ }
+}
+
+/*
+ * Find the smallest item in tree [t] that is GEQ the passed item
+ */
+
+void *
+avl_find_atleast (const void *item, avl_tree t)
+{
+#ifndef AVL_NULLCHECKS
+ if (t == NULL || t->root == NULL)
+#else
+ if (t->root == NULL)
+#endif
+ return NULL;
+ {
+ avl_compare_func cmp = t->compare;
+ avl_node *a = t->root;
+ void *p = NULL;
+ int c;
+
+ do
+ {
+ c = Item_Compare (cmp, t, item, get_item (a));
+ CMPERR_CHECK__FIND (t->param);
+ if (c > 0)
+ {
+ a = sub_right (a);
+ }
+ else
+ {
+ p = get_item (a);
+ a = sub_left (a);
+ }
+ }
+ while (a);
+ return p;
+ }
+}
+
+/*
+ * Find the greatest item in tree [t] that is LEQ the passed item
+ */
+
+void *
+avl_find_atmost (const void *item, avl_tree t)
+{
+#ifndef AVL_NULLCHECKS
+ if (t == NULL || t->root == NULL)
+#else
+ if (t->root == NULL)
+#endif
+ return NULL;
+ {
+ avl_compare_func cmp = t->compare;
+ avl_node *a = t->root;
+ void *p = NULL;
+ int c;
+
+ do
+ {
+ c = Item_Compare (cmp, t, item, get_item (a));
+ CMPERR_CHECK__FIND (t->param);
+ if (c < 0)
+ {
+ a = sub_left (a);
+ }
+ else
+ {
+ p = get_item (a);
+ a = sub_right (a);
+ }
+ }
+ while (a);
+ return p;
+ }
+}
+
+/* Retrieve item of index [idx] in tree [t] */
+
+void *
+avl_find_index (avl_size_t idx, avl_tree t)
+{
+ avl_node *a;
+
+#ifndef AVL_NULLCHECKS
+ if (t == NULL)
+ return NULL;
+#endif
+ a = node_find_index (idx, t);
+ return a != NULL ? get_item (a) : NULL;
+}
+
+#define attach_node(ptr,up,t)\
+ ptr = new_node(item, up, t);\
+ if (ptr == NULL){\
+ AVL_SHOW_ERROR("%s\n", "couldn't allocate node");\
+ return -1;\
+ }\
+ t->count++
+
+/* Iterative insertion */
+
+avl_code_t
+avl_ins (void *item, avl_tree t, avl_bool_t allow_duplicates)
+{
+#ifndef AVL_NULLCHECKS
+ if (t == NULL)
+ return NULL;
+ {
+#endif
+ avl_compare_func cmp = t->compare;
+ avl_node **r, *a;
+ int dir = 0;
+
+ for (r = &t->root, a = NULL; *r != NULL; r = &a->sub[dir = dir > 0])
+ {
+ a = *r;
+ dir = Item_Compare (cmp, t, item, get_item (a));
+ CMPERR_CHECK__INS (t->param);
+ if (!dir && !allow_duplicates)
+ return 0;
+ }
+
+ attach_node (*r, a, t);
+
+ return rebalance_ins (a, dir, t);
+
+#ifndef AVL_NULLCHECKS
+ } /* end if non-empty tree */
+#endif
+}
+
+avl_code_t
+avl_del (void *item, avl_tree t, void **backup)
+{
+#ifndef AVL_NULLCHECKS
+ if (t == NULL || t->root == NULL)
+#else
+ if (t->root == NULL)
+#endif
+ return 0;
+ {
+ avl_node *a = node_find (item, t);
+
+ if (a == NULL)
+ return CMPERR_CHECK__DEL (t->param);
+ return rebalance_del (a, t, backup);
+ }
+}
+
+/* helper function */
+static avl_code_t
+node_del_first (avl_tree t, struct ptr_handler *h)
+{
+ avl_node *p, *a, *c;
+ rbal_t bal;
+
+ p = node_first (t->root);
+ a = p->up;
+ if (sub_right (p) != NULL)
+ sub_right (p)->up = a;
+ if (a == NULL)
+ t->root = sub_right (p);
+ else
+ sub_left (a) = sub_right (p);
+
+ detach_node (p, t, h);
+
+ /* Start backtracking : subtree of [a] in direction [0] is less deep */
+
+ for (;; a = c)
+ {
+ if (a == NULL)
+ return 2;
+
+ decr_rank (a, 1);
+ bal = get_bal (a);
+
+ if (bal == 0)
+ {
+ set_rskew (a);
+ break;
+ }
+ if (bal & 1)
+ unset_lskew (a);
+ c = a->up;
+ if (get_bal (a))
+ {
+ p = a;
+ bal = get_bal (sub_right (p));
+ if (!(bal & 1))
+ {
+ /* bal = 0 or +1 */
+ /* rotL(p) */
+ a = sub_right (p);
+ sub_right (p) = sub_left (a);
+ if (sub_left (a) != NULL)
+ sub_left (a)->up = p;
+ sub_left (a) = p;
+ if (bal)
+ {
+ unset_rskew (p);
+ unset_rskew (a);
+ }
+ else
+ set_lskew (a);
+ rbal (a) += rzero (p);
+ }
+ else
+ {
+ /* rotRL(p) */
+ a = sub_left (sub_right (p));
+ sub_left (sub_right (p)) = sub_right (a);
+ if (sub_right (a) != NULL)
+ sub_right (a)->up = sub_right (p);
+ sub_right (p)->up = a;
+ sub_right (a) = sub_right (p);
+ sub_right (p) = sub_left (a);
+ if (sub_left (a) != NULL)
+ sub_left (a)->up = p;
+ sub_left (a) = p;
+ switch (get_bal (a))
+ {
+ case 0: /* not skewed */
+ unset_rskew (p);
+ unset_lskew (sub_right (a));
+ break;
+ case 1: /* left skew */
+ unset_rskew (p);
+ unset_lskew (sub_right (a));
+ set_rskew (sub_right (a));
+ break;
+ case 2: /* right skew */
+ unset_rskew (p);
+ set_lskew (p);
+ unset_lskew (sub_right (a));
+ } /* switch */
+ rbal (a) &= ~3;
+ rbal (sub_right (a)) -= rzero (a);
+ rbal (a) += rzero (p);
+ } /* which rot */
+
+ a->up = p->up;
+ p->up = a;
+ /* Done with rotation */
+ if (c != NULL)
+ sub_left (c) = a;
+ else
+ t->root = a;
+ if (bal == 0)
+ break;
+ } /* if getbal(a) */
+ } /* for */
+
+ /* Finish adjusting ranks */
+ while ((a = a->up) != NULL)
+ {
+ decr_rank (a, 1);
+ }
+
+ return 1;
+}
+
+/* helper function */
+static avl_code_t
+node_del_last (avl_tree t, struct ptr_handler *h)
+{
+
+ avl_node *p, *a, *c;
+ rbal_t bal;
+
+ p = node_last (t->root);
+ a = p->up;
+ if (sub_left (p) != NULL)
+ sub_left (p)->up = a;
+ if (a == NULL)
+ t->root = sub_left (p);
+ else
+ sub_right (a) = sub_left (p);
+
+ detach_node (p, t, h);
+
+ /* Start backtracking : subtree of [a] in direction [1] is less deep */
+
+ for (;; a = c)
+ {
+ if (a == NULL)
+ return 2;
+
+ bal = get_bal (a);
+ if (bal == 0)
+ {
+ set_lskew (a);
+ break;
+ }
+ if (bal & 2)
+ unset_rskew (a);
+ c = a->up;
+ if (get_bal (a))
+ {
+ p = a;
+ bal = get_bal (sub_left (p));
+ if (!(bal & 2))
+ {
+ /* bal = 0 or -1 */
+ /* rotR(p) */
+ a = sub_left (p);
+ sub_left (p) = sub_right (a);
+ if (sub_right (a) != NULL)
+ sub_right (a)->up = p;
+ sub_right (a) = p;
+ if (bal)
+ {
+ unset_lskew (p);
+ unset_lskew (a);
+ }
+ else
+ set_rskew (a);
+ rbal (p) -= rzero (a);
+ }
+ else
+ {
+ /* rotLR(p) */
+ a = sub_right (sub_left (p));
+ sub_right (sub_left (p)) = sub_left (a);
+ if (sub_left (a) != NULL)
+ sub_left (a)->up = sub_left (p);
+ sub_left (p)->up = a;
+ sub_left (a) = sub_left (p);
+ sub_left (p) = sub_right (a);
+ if (sub_right (a) != NULL)
+ sub_right (a)->up = p;
+ sub_right (a) = p;
+ switch (get_bal (a))
+ {
+ case 0: /* not skewed */
+ unset_lskew (p);
+ unset_rskew (sub_left (a));
+ break;
+ case 1: /* left skew */
+ unset_lskew (p);
+ set_rskew (p);
+ unset_rskew (sub_left (a));
+ break;
+ case 2: /* right skew */
+ unset_lskew (p);
+ unset_rskew (sub_left (a));
+ set_lskew (sub_left (a));
+ } /* switch */
+ rbal (a) &= ~3;
+ rbal (a) += rzero (sub_left (a));
+ rbal (p) -= rzero (a);
+ } /* which rot */
+
+ a->up = p->up;
+ p->up = a;
+ /* Done with rotation */
+ if (c != NULL)
+ sub_right (c) = a;
+ else
+ t->root = a;
+ if (bal == 0)
+ break;
+ } /* if getbal(a) */
+ } /* for */
+
+ return 1;
+}
+
+/* [p] : juncture node (zeroed out) */
+
+/* [n] : rank of [p] in resulting tree */
+
+/* [delta] = depth_1 - depth_0 */
+
+static avl_code_t
+join_left (avl_node * p, avl_node ** r0, avl_node * r1, int delta, int n)
+{
+ avl_node *a = NULL, **r = r0;
+
+ if (r1 == NULL)
+ {
+ while (*r != NULL)
+ {
+ a = *r;
+ n -= (int)get_rank (a);
+ r = &sub_right (a);
+ }
+ }
+ else
+ {
+ while (delta < -1)
+ {
+ a = *r;
+ delta += (int)(is_lskew (a) + 1);
+ n -= (int)get_rank (a);
+ r = &sub_right (a);
+ }
+ r1->up = p;
+ if (*r != NULL)
+ (*r)->up = p;
+ if (delta)
+ set_lskew (p);
+ }
+
+ /* at this point bal(*r) = -1 or 0 */
+ sub_left (p) = *r;
+ sub_right (p) = r1;
+ p->up = a;
+ set_rank (p, n);
+ *r = p;
+
+ for (;;)
+ {
+ if (a == NULL)
+ return 2;
+ if (get_bal (a))
+ break;
+ set_rskew (a);
+ a = a->up;
+ }
+
+ /* Rotate if need be */
+ /* No (+2,0) rotation to do */
+
+ if (is_lskew (a))
+ unset_lskew (a);
+
+ else
+ {
+ avl_node *p = a;
+
+ if (is_rskew (sub_right (p)))
+ {
+ /* rotL(p) */
+ a = sub_right (p);
+ sub_right (p) = sub_left (a);
+ if (sub_left (a) != NULL)
+ sub_left (a)->up = p;
+ sub_left (a) = p;
+ unset_rskew (p);
+ rbal (a) += rzero (p);
+ }
+ else
+ {
+ /* rotRL(p) */
+ a = sub_left (sub_right (p));
+ sub_left (sub_right (p)) = sub_right (a);
+ if (sub_right (a) != NULL)
+ sub_right (a)->up = sub_right (p);
+ sub_right (p)->up = a;
+ sub_right (a) = sub_right (p);
+ sub_right (p) = sub_left (a);
+ if (sub_left (a) != NULL)
+ sub_left (a)->up = p;
+ sub_left (a) = p;
+ switch (get_bal (a))
+ {
+ case 0: /* not skewed */
+ unset_rskew (p);
+ unset_lskew (sub_right (a));
+ break;
+ case 1: /* left skew */
+ unset_rskew (p);
+ unset_lskew (sub_right (a));
+ set_rskew (sub_right (a));
+ break;
+ case 2: /* right skew */
+ unset_rskew (p);
+ set_lskew (p);
+ unset_lskew (sub_right (a));
+ } /* switch */
+ rbal (sub_right (a)) -= rzero (a);
+ rbal (a) += rzero (p);
+ } /* which rot */
+
+ rbal (a) &= ~3;
+ a->up = p->up;
+ p->up = a;
+ if (a->up != NULL)
+ sub_right (a->up) = a;
+ else
+ *r0 = a;
+ } /* rot or not rot */
+
+ return 1;
+}
+
+/* [p] : juncture node */
+
+/* [n] : rank of [p] in resulting tree */
+
+static avl_code_t
+join_right (avl_node * p, avl_node * r0, avl_node ** r1, int delta, int n)
+{
+ avl_node *a = NULL, **r = r1;
+
+ if (r0 == NULL)
+ {
+ while (*r != NULL)
+ {
+ a = *r;
+ incr_rank (a, (rbal_t)n);
+ r = &sub_left (a);
+ }
+ n = 1;
+ }
+ else
+ {
+ while (delta > +1)
+ {
+ a = *r;
+ delta -= (int)(is_rskew (a) + 1);
+ incr_rank (a, (rbal_t)n);
+ r = &sub_left (a);
+ }
+ r0->up = p;
+ if (*r != NULL)
+ (*r)->up = p;
+ if (delta)
+ set_rskew (p);
+ }
+
+ /* at this point bal(*r) = +1 or 0 */
+ sub_left (p) = r0;
+ sub_right (p) = *r;
+ set_rank (p, n);
+ p->up = a;
+ *r = p;
+
+ for (;;)
+ {
+ if (a == NULL)
+ return 2;
+ if (get_bal (a))
+ break;
+ set_lskew (a);
+ a = a->up;
+ }
+
+ /* Rotate if need be */
+ /* No (-2,0) rotation to do */
+
+ if (is_rskew (a))
+ unset_rskew (a);
+
+ else
+ {
+ avl_node *p = a;
+
+ if (is_lskew (sub_left (p)))
+ {
+ /* rotR(p) */
+ a = sub_left (p);
+ sub_left (p) = sub_right (a);
+ if (sub_right (a) != NULL)
+ sub_right (a)->up = p;
+ sub_right (a) = p;
+ unset_lskew (p);
+ rbal (p) -= rzero (a);
+ }
+ else
+ {
+ /* rotLR(p) */
+ a = sub_right (sub_left (p));
+ sub_right (sub_left (p)) = sub_left (a);
+ if (sub_left (a) != NULL)
+ sub_left (a)->up = sub_left (p);
+ sub_left (p)->up = a;
+ sub_left (a) = sub_left (p);
+ sub_left (p) = sub_right (a);
+ if (sub_right (a) != NULL)
+ sub_right (a)->up = p;
+ sub_right (a) = p;
+ switch (get_bal (a))
+ {
+ case 0: /* not skewed */
+ unset_lskew (p);
+ unset_rskew (sub_left (a));
+ break;
+ case 1: /* left skew */
+ unset_lskew (p);
+ set_rskew (p);
+ unset_rskew (sub_left (a));
+ break;
+ case 2: /* right skew */
+ unset_lskew (p);
+ unset_rskew (sub_left (a));
+ set_lskew (sub_left (a));
+ } /* end switch */
+ rbal (a) += rzero (sub_left (a));
+ rbal (p) -= rzero (a);
+ } /* end which rot */
+
+ rbal (a) &= ~3;
+ a->up = p->up;
+ p->up = a;
+ if (a->up != NULL)
+ sub_left (a->up) = a;
+ else
+ *r1 = a;
+ } /* end rot or not rot */
+
+ return 1;
+}
+
+avl_code_t
+avl_del_first (avl_tree t, void **backup)
+{
+#ifndef AVL_NULLCHECKS
+ if (t == NULL || t->root == NULL)
+#else
+ if (t->root == NULL)
+#endif
+ return 0;
+ {
+ avl_code_t rv;
+
+ if (backup == NULL)
+ {
+ rv = node_del_first (t, NULL);
+ }
+ else
+ {
+ ini_ptr_handler (h, BACKUP);
+ rv = node_del_first (t, &h);
+ *backup = h.ptr;
+ }
+ return rv;
+ }
+}
+
+avl_code_t
+avl_del_last (avl_tree t, void **backup)
+{
+#ifndef AVL_NULLCHECKS
+ if (t == NULL || t->root == NULL)
+#else
+ if (t->root == NULL)
+#endif
+ return 0;
+ {
+ avl_code_t rv;
+
+ if (backup == NULL)
+ {
+ rv = node_del_last (t, NULL);
+ }
+ else
+ {
+ ini_ptr_handler (h, BACKUP);
+ rv = node_del_last (t, &h);
+ *backup = h.ptr;
+ }
+ return rv;
+ }
+}
+
+avl_code_t
+avl_ins_index (void *item, avl_size_t idx, avl_tree t)
+{
+ avl_node *p;
+
+ if (idx == 0 || t == NULL || idx > t->count + 1)
+ return 0;
+
+ attach_node (p, NULL, t);
+ /* Note: 'attach_node' macro increments t->count */
+
+ if (idx == 1)
+ {
+ return join_right (p, (avl_node *) NULL, &t->root, /*delta= */ 0, 1);
+ }
+ else if (idx == t->count)
+ {
+ return
+ join_left (p, &t->root, (avl_node *) NULL, /*delta= */ 0, (int)t->count);
+ }
+ else
+ {
+ avl_node *a = node_find_index (idx - 1, t);
+ int dir;
+
+ if (sub_right (a) != NULL)
+ {
+ a = node_first (sub_right (a));
+ sub_left (a) = p;
+ dir = 0;
+ }
+ else
+ {
+ sub_right (a) = p;
+ dir = 1;
+ }
+
+ p->up = a;
+ return rebalance_ins (a, dir, t);
+ }
+}
+
+avl_code_t
+avl_del_index (avl_size_t idx, avl_tree t, void **backup)
+{
+#ifndef AVL_NULLCHECKS
+ if (t == NULL)
+ return 0;
+#endif
+
+ if (idx == 0 || idx > t->count)
+ return 0;
+ if (idx == 1)
+ return avl_del_first (t, backup);
+ if (idx == t->count)
+ return avl_del_last (t, backup);
+ {
+ avl_node *a = node_find_index (idx, t);
+
+ return rebalance_del (a, t, backup);
+ }
+}
+
+/*
+ * Outcome: [t0] handles the concatenation of [t0] and [t1]
+ */
+
+void
+avl_cat (avl_tree t0, avl_tree t1)
+{
+#ifndef AVL_NULLCHECKS
+ if (t0 == NULL || t1 == NULL || t1->root == NULL)
+#else
+ if (t1->root == NULL)
+#endif
+ return;
+
+ if (t0->root == NULL)
+ {
+ t0->root = t1->root;
+ t0->count = t1->count;
+ t1->root = NULL;
+ t1->count = 0;
+
+ }
+ else
+ {
+ int delta = depth (t1->root) - depth (t0->root);
+
+ ini_ptr_handler (h, DETACH);
+
+ if (delta <= 0)
+ {
+ if (node_del_first (t1, &h) == 2)
+ --delta;
+ (void) join_left ((avl_node *) h.ptr, &t0->root, t1->root, delta,
+ (int)(t0->count + 1));
+ }
+ else
+ {
+ if (node_del_last (t0, &h) == 2)
+ ++delta;
+ (void) join_right ((avl_node *) h.ptr, t0->root, &t1->root, delta,
+ (int)(t0->count + 1));
+ t0->root = t1->root;
+ }
+
+ t1->root = NULL;
+ t0->count += t1->count + 1;
+ t1->count = 0;
+ }
+}
+
+/*
+ * - [t0] and [t1] are existing handles
+ * - See Donald Knuth, TAOCP Vol.3 "Sorting and searching"
+ */
+
+avl_code_t
+avl_split (const void *item, avl_tree t, avl_tree t0, avl_tree t1)
+{
+#ifndef AVL_NULLCHECKS
+ if (t == NULL || t->root == NULL)
+#else
+ if (t->root == NULL)
+#endif /* AVL_NULLCHECKS */
+ return 0;
+
+ t0->root = NULL;
+ t1->root = NULL;
+ t0->count = 0;
+ t1->count = 0;
+
+ {
+ avl_compare_func cmp = t->compare;
+ avl_node *a, *p, *sn; /* sn: split node */
+ int d_, k, na, an[AVL_STACK_CAPACITY];
+
+ /* invariant: [na]= size of tree rooted at [a] plus one */
+
+ for (a = t->root, na = (int)(t->count + 1), k = 0;;)
+ {
+ d_ = Item_Compare (cmp, t, item, get_item (a));
+ CMPERR_CHECK__SPLIT (t->param);
+ if (!d_)
+ break;
+ p = a->sub[d_ = d_ > 0];
+ if (p == NULL)
+ return 0;
+ an[k++] = na;
+ if (d_)
+ na -= (int)get_rank (a);
+ else
+ na = (int)get_rank (a);
+ a = p;
+ }
+
+ /* record split node */
+ sn = a;
+
+ if (k == 0)
+ {
+ t0->root = sub_left (a);
+ t1->root = sub_right (a);
+ if (t0->root != NULL)
+ t0->root->up = NULL;
+ if (t1->root != NULL)
+ t1->root->up = NULL;
+ t0->count = get_rank (a) - 1;
+ t1->count = t->count - get_rank (a);
+ }
+ else
+ {
+ avl_node *r[2], *rr;
+ int h[2], ha, hh;
+ avl_size_t n[2], nn;
+
+ r[0] = sub_left (a);
+ r[1] = sub_right (a);
+ if (r[0] != NULL)
+ r[0]->up = NULL;
+ if (r[1] != NULL)
+ r[1]->up = NULL;
+ ha = depth (a);
+ h[0] = ha - (is_rskew (a) ? 2 : 1);
+ h[1] = ha - (is_lskew (a) ? 2 : 1);
+ n[0] = get_rank (a); /* size of r[0] plus one */
+ n[1] = (avl_size_t)na - n[0]; /* size of r[1] plus one */
+
+ for (p = a->up, d_ = a != sub_left (p);;)
+ {
+
+ a = p; /* a: juncture node */
+ p = a->up;
+
+ if (d_ == 0)
+ {
+ hh = h[1];
+ ha += (is_rskew (a) ? 2 : 1);
+ h[1] = ha - (is_lskew (a) ? 2 : 1);
+ nn = n[1];
+ n[1] += (avl_size_t)(an[k - 1] - (int)get_rank (a));
+ if (p != NULL)
+ d_ = a != sub_left (p);
+ rbal (a) = 0;
+
+ if (h[1] >= hh)
+ {
+ rr = r[1];
+ r[1] = sub_right (a);
+ if (r[1] != NULL)
+ r[1]->up = NULL;
+ h[1] += (2 == join_right (a, rr, r + 1, h[1] - hh, (int)nn));
+ }
+ else
+ {
+ h[1] =
+ hh + (2 ==
+ join_left (a, r + 1, sub_right (a), h[1] - hh,
+ (int)nn));
+ }
+ }
+ else
+ {
+ hh = h[0];
+ ha += (is_lskew (a) ? 2 : 1);
+ h[0] = ha - (is_rskew (a) ? 2 : 1);
+ nn = get_rank (a);
+ n[0] += nn;
+ if (p != NULL)
+ d_ = a != sub_left (p);
+ rbal (a) = 0;
+
+ if (h[0] >= hh)
+ {
+ rr = r[0];
+ r[0] = sub_left (a);
+ if (r[0] != NULL)
+ r[0]->up = NULL;
+ h[0] += (2 == join_left (a, r, rr, hh - h[0], (int)nn));
+ }
+ else
+ {
+ h[0] =
+ hh + (2 ==
+ join_right (a, sub_left (a), r, hh - h[0], (int)nn));
+ }
+ }
+
+ if (--k == 0)
+ break;
+ } /* for p */
+
+ t0->root = r[0];
+ t1->root = r[1];
+ t0->count = n[0] - 1;
+ t1->count = n[1] - 1;
+ } /* if k==0 */
+
+ /* Detach split node */
+ detach_node (sn, t, NULL);
+ t->root = NULL;
+ t->count = 0;
+
+ return 1;
+ }
+}
+
+/* Inorder traversal */
+
+void
+avl_walk (avl_tree t, avl_item_func proc, void *param)
+{
+#ifndef AVL_NULLCHECKS
+ if (t == NULL || t->root == NULL)
+#else
+ if (t->root == NULL)
+#endif
+ return;
+
+ {
+ avl_node *a = t->root, *p;
+
+ while (1)
+ {
+ while (sub_left (a) != NULL)
+ a = sub_left (a);
+
+ while (1)
+ {
+ (*proc) (get_item (a), param);
+ if (sub_right (a) != NULL)
+ break;
+ do
+ {
+ p = a;
+ a = p->up;
+ if (a == NULL)
+ return;
+ }
+ while (p != sub_left (a));
+ }
+ a = sub_right (a);
+ }
+ }
+}
+
+/* recursive helper for 'avl_slice' */
+static int
+node_slice (avl_node ** root, avl_node ** cur, avl_tree tree, avl_size_t len)
+{
+ avl_size_t mid = len / 2;
+
+ if (mid == 0)
+ {
+ if ((*root = new_node ((*cur)->item, /*parent */ NULL, tree)) == NULL)
+ return -1;
+ sub_left (*root) = NULL;
+ sub_right (*root) = NULL;
+ rbal (*root) = 4;
+ *cur = node_next (*cur);
+ return 0;
+
+ }
+ else if ((*root = new_node (NULL, /*parent */ NULL, tree)) == NULL)
+ {
+ return -1;
+ }
+ else
+ {
+ avl_node *p = *root;
+ int h0, h1 = -1;
+
+ rbal (p) = (mid + 1) << 2;
+
+ if ((h0 = node_slice (&sub_left (p), cur, tree, mid)) < 0)
+ return -1;
+
+ p->item = (*tree->copy) ((*cur)->item);
+ sub_left (p)->up = p;
+
+ *cur = node_next (*cur);
+
+ if (len -= mid + 1)
+ {
+ if ((h1 = node_slice (&sub_right (p), cur, tree, len)) < 0)
+ return -1;
+ sub_right (p)->up = p;
+ }
+
+ if (h0 > h1)
+ set_lskew (p);
+ else if (h0 < h1)
+ {
+ set_rskew (p);
+ return 1 + h1;
+ }
+ return 1 + h0;
+ }
+}
+
+/* Return a slice t[lo,hi) as a new tree */
+
+avl_tree
+avl_slice (avl_tree t, avl_size_t lo_idx, avl_size_t hi_idx, void *param)
+{
+#ifndef AVL_NULLCHECKS
+ if (t == NULL)
+ return NULL;
+#endif /* AVL_NULLCHECKS */
+
+ if (lo_idx > hi_idx || lo_idx > t->count)
+ return NULL;
+ if (lo_idx < 1)
+ lo_idx = 1;
+ if (hi_idx > t->count + 1)
+ hi_idx = t->count + 1;
+
+ {
+ avl_tree tt = avl_create (t->compare,
+ t->copy,
+ t->dispose,
+ t->alloc,
+ t->dealloc,
+ param);
+
+ if (tt == NULL)
+ {
+ AVL_SHOW_ERROR ("%s\n",
+ "couldn't allocate new handle in avl_slice()");
+ return NULL;
+ }
+
+ if (lo_idx < hi_idx)
+ {
+ avl_node *cur = node_find_index (lo_idx, t);
+
+ if (node_slice (&tt->root, &cur, t, tt->count = hi_idx - lo_idx) < 0)
+ {
+ AVL_SHOW_ERROR ("%s\n", "couldn't allocate node in avl_slice()");
+ node_empty (tt);
+ (*t->dealloc) (tt);
+ return NULL;
+ }
+ tt->root->up = NULL;
+ }
+ return tt;
+ }
+}
+
+/* recursive helper for 'avl_xload' */
+
+static int
+node_load (avl_node ** root, avl_itersource cur, void **pres, avl_tree desc,
+ avl_size_t len)
+{
+ avl_size_t mid = len / 2;
+
+ if (mid == 0)
+ {
+ if (0 != (*cur->f) (cur, pres)
+ || (*root = new_node (*pres, /*parent */ NULL, desc)) == NULL)
+ return -1;
+ sub_left (*root) = NULL;
+ sub_right (*root) = NULL;
+ rbal (*root) = 4;
+ return 0;
+
+ }
+ else if ((*root = new_node (NULL, /*parent */ NULL, desc)) == NULL)
+ {
+ return -1;
+ }
+ else
+ {
+ avl_node *p = *root;
+ int h0, h1 = -1;
+
+ rbal (p) = (mid + 1) << 2;
+
+ if ((h0 = node_load (&sub_left (p), cur, pres, desc, mid)) < 0)
+ return -1;
+
+ if (0 != (*cur->f) (cur, pres))
+ return -1;
+
+ p->item = (*desc->copy) (*pres);
+ sub_left (p)->up = p;
+
+ if (len -= mid + 1)
+ {
+ if ((h1 = node_load (&sub_right (p), cur, pres, desc, len)) < 0)
+ return -1;
+ sub_right (p)->up = p;
+ }
+
+ if (h0 > h1)
+ set_lskew (p);
+ else if (h0 < h1)
+ {
+ set_rskew (p);
+ return 1 + h1;
+ }
+ return 1 + h0;
+ }
+}
+
+/* Load 'len' items from itersource */
+
+avl_tree
+avl_xload (avl_itersource src, void **pres, avl_size_t len, avl_config conf,
+ void *tree_param)
+{
+#ifndef AVL_NULLCHECKS
+ if (src == NULL)
+ return NULL;
+ {
+#endif /* AVL_NULLCHECKS */
+
+ avl_tree tt = avl_create (conf->compare,
+ conf->copy,
+ conf->dispose,
+ conf->alloc,
+ conf->dealloc,
+ tree_param);
+
+ if (tt == NULL)
+ {
+ AVL_SHOW_ERROR ("%s\n", "couldn't allocate new handle in avl_load()");
+ return NULL;
+ }
+
+ if (len)
+ {
+ if (node_load (&tt->root, src, pres, tt, tt->count = len) < 0)
+ {
+ AVL_SHOW_ERROR ("%s\n", "couldn't allocate node in avl_load()");
+ node_empty (tt);
+ (*tt->dealloc) (tt);
+ return NULL;
+ }
+ tt->root->up = NULL;
+ }
+ return tt;
+#ifndef AVL_NULLCHECKS
+ }
+#endif
+}
+
+#ifdef HAVE_AVL_VERIFY
+
+/* Verification routine */
+typedef enum
+{
+ okay = 0,
+ bad_parent = 1,
+ bad_rank = 2,
+ out_of_balance = 3,
+ out_of_order = 4,
+ diff_mismatch = 5,
+ count_mismatch = 6
+}
+avl_verify_code;
+
+static avl_bool_t
+avl_error (avl_verify_code err)
+{
+ static char *errmess[] = {
+ "Bad parent link",
+ "Rank error",
+ "Out of balance",
+ "Out of order",
+ "Differential mismatch",
+ "Count mismatch"
+ };
+
+ AVL_SHOW_ERROR ("Invalid avl_tree: %s\n", errmess[err - 1]);
+ return avl_false;
+}
+
+static int bals[] = { 1, 0, 2 };
+
+/*
+ helper for recursive 'avl_verify' function
+ return 0 iff okay
+ */
+
+static avl_verify_code
+node_verify (avl_node * root, avl_tree tree, int *h, avl_size_t * c,
+ avl_node * up)
+{
+ avl_verify_code err = okay;
+
+ if (root == NULL)
+ *h = AVL_MIN_DEPTH, *c = 0;
+ else
+ {
+#define AVL_ASSERT(expr,n) if (expr) ; else { err = n; break; }
+#define CHECK(err) if (err) break
+
+ avl_node *left, *right;
+ avl_size_t c_[2];
+ int h_[2], delta;
+
+ left = sub_left (root);
+ right = sub_right (root);
+ do
+ {
+ AVL_ASSERT (root->up == up, bad_parent);
+ CHECK (err = node_verify (left, tree, h_, c_, root));
+ AVL_ASSERT (get_rank (root) == *c_ + 1, bad_rank);
+ CHECK (err = node_verify (right, tree, h_ + 1, c_ + 1, root));
+ delta = h_[1] - h_[0];
+ AVL_ASSERT (delta >= -1 && delta <= +1, out_of_balance);
+ AVL_ASSERT (get_bal (root) == bals[delta + 1], diff_mismatch);
+ AVL_ASSERT (left == NULL
+ || (Item_Compare (tree->compare, tree, get_item (left),
+ get_item (root)) <=
+ 0 CMPERR_CHECK__VERIFY (tree->param)),
+ out_of_order);
+ AVL_ASSERT (right == NULL
+ ||
+ (Item_Compare
+ (tree->compare, tree, get_item (root),
+ get_item (right)) <=
+ 0 CMPERR_CHECK__VERIFY (tree->param)), out_of_order);
+ *h = 1 + (h_[0] > h_[1] ? h_[0] : h_[1]);
+ *c = 1 + c_[0] + c_[1];
+ }
+ while (0);
+ }
+ return err;
+}
+
+avl_bool_t
+avl_verify (avl_tree t)
+{
+#ifndef AVL_NULLCHECKS
+ if (t == NULL)
+ return avl_false;
+#endif /* AVL_NULLCHECKS */
+ {
+ int h;
+ avl_size_t c;
+ avl_verify_code err;
+
+ err = node_verify (t->root, t, &h, &c, (avl_node *) NULL);
+ if (err)
+ return avl_error (err);
+ if (c != t->count)
+ return avl_error (count_mismatch);
+ return avl_true;
+ }
+}
+#endif /* HAVE_AVL_VERIFY */
+
+/****************
+ * *
+ * ITERATORS *
+ * *
+ ****************/
+
+typedef enum
+{
+ AVL_ITERATOR_PRE,
+ AVL_ITERATOR_POST,
+ AVL_ITERATOR_INTREE
+}
+avl_status_t;
+
+struct avl_iterator_
+{
+ avl_node *pos;
+ avl_tree tree;
+ avl_status_t status;
+};
+
+#define get_root(i) i->tree->root
+#define is_pre(i) i->status == AVL_ITERATOR_PRE
+#define is_post(i) i->status == AVL_ITERATOR_POST
+#define set_pre_iterator(i) i->status = AVL_ITERATOR_PRE
+#define set_post_iterator(i) i->status = AVL_ITERATOR_POST
+#define set_in_iterator(i) i->status = AVL_ITERATOR_INTREE
+
+/* Position existing iterator [iter] at node matching [item] in its own tree,
+ * if it exists ; otherwise do nothing
+ */
+
+void
+avl_iterator_seek (const void *item, avl_iterator iter)
+{
+ avl_node *p = node_find (item, iter->tree);
+
+ if (p != NULL)
+ {
+ set_in_iterator (iter);
+ iter->pos = p;
+ }
+}
+
+void
+avl_iterator_seek_index (avl_size_t idx, avl_iterator iter)
+{
+ avl_node *p = node_find_index (idx, iter->tree);
+
+ if (p != NULL)
+ {
+ set_in_iterator (iter);
+ iter->pos = p;
+ }
+}
+
+/* Return item pointer at current position */
+
+void *
+avl_iterator_cur (avl_iterator iter)
+{
+ return iter->pos != NULL ? get_item (iter->pos) : NULL;
+}
+
+avl_size_t
+avl_iterator_count (avl_iterator iter)
+{
+ return iter->tree->count;
+}
+
+avl_size_t
+avl_iterator_index (avl_iterator iter)
+{
+ if (iter->pos != NULL)
+ return get_index (iter->pos);
+ else if (is_pre (iter))
+ return 0;
+ else
+ return iter->tree->count + 1;
+}
+
+/* Rustic: */
+
+avl_iterator
+avl_iterator_new (avl_tree t, avl_ini_t ini, ...)
+{
+ va_list args;
+ avl_iterator iter = NULL;
+
+ va_start (args, ini);
+
+ if (t == NULL)
+ goto finish;
+
+ if ((iter = (*t->alloc) (sizeof (struct avl_iterator_))) == NULL)
+ {
+ AVL_SHOW_ERROR ("%s\n", "couldn't create iterator");
+ goto finish;
+ }
+
+ iter->pos = NULL;
+ iter->tree = t;
+
+ if (ini != AVL_ITERATOR_INI_INTREE)
+ {
+ iter->status =
+ (ini == AVL_ITERATOR_INI_PRE) ? AVL_ITERATOR_PRE : AVL_ITERATOR_POST;
+ }
+ else
+ {
+ const void *item = NULL;
+
+ item = va_arg (args, const void *);
+
+ set_pre_iterator (iter);
+
+ if (item == NULL)
+ AVL_SHOW_ERROR ("%s\n", "missing argument to avl_iterator_new()");
+ else
+ avl_iterator_seek (item, iter);
+ }
+
+finish:
+ va_end (args);
+ return iter;
+}
+
+/*
+ * The following used to write to memory after it was freed.
+ * Corrected by: David Turner <novalis@openplans.org>
+ */
+void
+avl_iterator_kill (avl_iterator iter)
+{
+ if (iter != NULL)
+ {
+ avl_dealloc_func dealloc = iter->tree->dealloc;
+ iter->pos = NULL;
+ iter->tree = NULL;
+ (*dealloc) (iter);
+ }
+}
+
+void *
+avl_iterator_next (avl_iterator iter)
+{
+ avl_node *a = iter->pos;
+
+ if (is_post (iter))
+ return NULL;
+
+ if (is_pre (iter))
+ {
+ a = get_root (iter);
+ if (a != NULL)
+ {
+ a = node_first (a);
+ set_in_iterator (iter);
+ }
+ }
+ else
+ {
+ a = node_next (a);
+ if (a == NULL)
+ set_post_iterator (iter);
+ }
+
+ iter->pos = a;
+ return a != NULL ? get_item (a) : NULL;
+}
+
+void *
+avl_iterator_prev (avl_iterator iter)
+{
+ avl_node *a = iter->pos;
+
+ if (is_pre (iter))
+ return NULL;
+
+ if (is_post (iter))
+ {
+ a = get_root (iter);
+ if (a != NULL)
+ {
+ a = node_last (a);
+ set_in_iterator (iter);
+ }
+ }
+ else
+ {
+ a = node_prev (a);
+ if (a == NULL)
+ set_pre_iterator (iter);
+ }
+
+ iter->pos = a;
+ return a != NULL ? get_item (a) : NULL;
+}
+
+/* Remove node at current position */
+
+/* Move cursor to next position */
+
+avl_code_t
+avl_iterator_del (avl_iterator iter, void **backup)
+{
+ if (iter == NULL || iter->pos == NULL)
+ return 0;
+ {
+ avl_node *a = iter->pos, *p;
+
+ p = node_next (a);
+ if (p == NULL)
+ set_post_iterator (iter);
+ iter->pos = p;
+ return rebalance_del (a, iter->tree, backup);
+ }
+}
diff --git a/Build/source/texk/web2c/mplibdir/avl.h b/Build/source/texk/web2c/mplibdir/avl.h
new file mode 100644
index 00000000000..9771c095220
--- /dev/null
+++ b/Build/source/texk/web2c/mplibdir/avl.h
@@ -0,0 +1,466 @@
+
+/*
+ pyavl -- HEADER FILE "avl.h"
+ Interface to manipulate "objects" of type 'avl_tree' and 'avl_iterator'
+*/
+
+#ifndef __AVL__
+#define __AVL__
+
+#include <stdarg.h>
+#include <stdio.h>
+#include <stdlib.h>
+
+#define avl_del mp_avl_del
+#define avl_ins mp_avl_ins
+#define avl_tree mp_avl_tree
+#define avl_entry mp_avl_entry
+#define avl_find mp_avl_find
+#define avl_create mp_avl_create
+#define avl_destroy mp_avl_destroy
+
+typedef enum
+{ avl_false, avl_true } avl_bool_t;
+
+#ifndef MPW_C
+#include <inttypes.h>
+typedef int8_t avl_code_t;
+typedef int8_t avl_bal_t;
+typedef uint32_t avl_size_t;
+#else
+#include <MacTypes.h>
+typedef SInt8 avl_code_t;
+typedef SInt8 avl_bal_t;
+typedef UInt32 avl_size_t;
+#endif
+
+typedef int (*avl_compare_func) (void *param, const void *lhs,
+ const void *rhs);
+typedef void *(*avl_item_copy_func) (const void *item);
+typedef void *(*avl_item_dispose_func) (void *item);
+typedef void (*avl_item_func) (const void *item, void *param);
+typedef void *(*avl_alloc_func) (size_t);
+typedef void (*avl_dealloc_func) (void *);
+
+#ifdef AVL_FOR_PYTHON
+#undef AVL_CMPERR
+#undef AVL_NULLCHECKS
+#define AVL_CMPERR 1
+#define AVL_NULLCHECKS 1
+#else
+#ifndef AVL_CMPERR
+#define AVL_CMPERR 0
+#endif
+#ifndef AVL_NULLCHECKS
+#define AVL_NULLCHECKS 0
+#endif
+#endif
+
+#if AVL_CMPERR != 0
+extern avl_code_t avl_errcmp_occurred(void *);
+#endif
+
+/* At minimum, shallow copy */
+
+const void *avl_default_item_copy(const void *);
+void *avl_default_item_dispose(void *);
+
+#define AVL_STACK_CAPACITY 32 /* for avl_split() function */
+
+typedef enum
+{
+ AVL_ITERATOR_INI_PRE,
+ AVL_ITERATOR_INI_POST,
+ AVL_ITERATOR_INI_INTREE
+} avl_ini_t;
+
+typedef struct avl_tree_ *avl_tree;
+typedef struct avl_iterator_ *avl_iterator;
+
+typedef struct avl_itersource_ avl_itersource_struct, *avl_itersource;
+
+struct avl_itersource_
+{
+ void *p;
+ /* return nonzero on error */
+ avl_code_t(*f) (avl_itersource from, void **to);
+};
+
+typedef struct
+{
+ avl_compare_func compare;
+ avl_item_copy_func copy;
+ avl_item_dispose_func dispose;
+ avl_alloc_func alloc;
+ avl_dealloc_func dealloc;
+} avl_config_struct, *avl_config;
+
+/* -------------------------------------------------------------------------------------------------/
+ Public Functions
+---------------------------------------------------------------------------------------------------*/
+
+/*
+ --- CREATE ---
+ Return a new tree and set its config.
+ Return NULL on allocation failure.
+ * 'alloc' defaults to malloc from stdlib
+ * 'dealloc' defaults to free from stdlib
+ * 'param' user param/refcon
+*/
+
+avl_tree avl_create(avl_compare_func compare,
+ avl_item_copy_func copy,
+ avl_item_dispose_func dispose,
+ avl_alloc_func alloc,
+ avl_dealloc_func dealloc, void *param);
+
+/*
+ --- RESET ---
+ Empty tree 't' as in 'avl_empty()' and modify its config.
+*/
+
+void
+avl_reset(avl_tree t,
+ avl_compare_func compare,
+ avl_item_copy_func copy,
+ avl_item_dispose_func dispose,
+ avl_alloc_func alloc, avl_dealloc_func dealloc);
+
+/*
+ --- EMPTY ---
+ Empty tree 't', calling its dispose_func for each item in 't'.
+ The config is untouched.
+*/
+
+void avl_empty(avl_tree t);
+
+/*
+ --- DESTROY ---
+ Empty tree 't' and free the handle.
+*/
+
+void avl_destroy(avl_tree t);
+
+/*
+ --- DUPLICATE (COPY) ---
+ Return a copy of tree 't', using its copy_func for each item in 't'.
+ Upon failure to allocate room for some item, return NULL.
+*/
+
+avl_tree avl_dup(avl_tree t, void *param);
+
+/*
+ --- EMPTYNESS ---
+ Return 'avl_true' iff tree 't' is empty (i.e. the handle is NULL or 't' contains no item).
+*/
+
+avl_bool_t avl_isempty(avl_tree t);
+
+/*
+ --- SIZE ---
+ Return number of items contained in tree 't'.
+*/
+
+avl_size_t avl_size(avl_tree t);
+
+/*
+ --- FIRST (MINIMUM) ---
+ Return first item in in-order traversal of 't'.
+ Return NULL if 't' is empty.
+*/
+
+void *avl_first(avl_tree t);
+
+/*
+ --- LAST (MAXIMUM) ---
+ Return last item in in-order traversal of 't'.
+ Return NULL if 't' is empty.
+*/
+
+void *avl_last(avl_tree t);
+
+/*
+ --- FIND MATCHING ITEM ---
+ Find item matching 'item' parameter in tree 't'.
+ Return NULL if it's not found.
+ If there are multiple matches, the first one that is encountered
+ during the search is returned; it may not be the one with lowest rank.
+*/
+
+void *avl_find(const void *item, avl_tree t);
+
+/*
+ --- INDEX (RANK) OF ITEM ---
+ Return smallest index 'i' s.t. 't[i]' matches 'item',
+ or zero if 'item' is not found.
+*/
+
+avl_size_t avl_index(const void *item, avl_tree t);
+
+/*
+ --- SPAN ITEMS ---
+ Return integers 'i,j' s.t. 't[i,j]'
+ i smallest index s.t. t[i] >= lo_item, or t->count+1 and
+ j greatest one s.t. t[j] <= hi_item, or 0.
+ If 'hi_item' is less than 'lo_item' those are swapped.
+ Return codes:
+ 0 success
+ -1 error: tree had no root
+ -2 error: compare failed
+*/
+
+avl_code_t
+avl_span(const void *lo_item,
+ const void *hi_item,
+ avl_tree t, avl_size_t * lo_idx, avl_size_t * hi_idx);
+
+/*
+ --- FIND AT LEAST ---
+ Return smallest item in 't' that is GEQ 'item', or NULL.
+*/
+
+void *avl_find_atleast(const void *item, avl_tree t);
+
+/*
+ --- FIND AT MOST ---
+ Return largest item in 't' that is LEQ 'item', or NULL.
+*/
+
+void *avl_find_atmost(const void *item, avl_tree t);
+
+/*
+ --- FIND BY INDEX (RANK) ---
+ Find item in 't' by index, that is return 't[idx]'.
+ If 'idx' is not in '[1,avl_size(t)]' then return NULL.
+ If a compare failed then return NULL.
+*/
+
+void *avl_find_index(avl_size_t idx, avl_tree t);
+
+/*
+ --- INSERTION ---
+ Insert 'item' in tree 't' with regard to its compare_func.
+ Say 'avl_ins(item,t,avl_true)' to insert 'item' in 't'
+ even if it is there already.
+ If 'item' is a duplicate and 'allow_duplicates' is avl_false,
+ nothing is done.
+ Return codes:
+ -1 error: allocation of new node failed
+ -2 error: compare failed, tree unchanged
+ 0 nothing was done, no error
+ +1 operation successful
+ +2 the same and height(t) increased by one.
+*/
+
+avl_code_t avl_ins(void *item, avl_tree t, avl_bool_t allow_duplicates);
+
+/*
+ --- DELETION ---
+ Remove 'item' from tree 't', calling its dispose_func.
+ To make a backup of 'item' involving its copy_func,
+ say 't(item,backup)' where 'backup' is some pointer to pointer to item.
+ Otherwise set it to NULL.
+ Return codes:
+ 0 item not found
+ -2 error: compare failed, tree unchanged
+ +1 operation successful
+ +2 the same and height(t) decreased by one.
+*/
+
+avl_code_t avl_del(void *item, avl_tree t, void **backup);
+
+/*
+ --- DELETE FIRST ---
+ Remove first item in in-order traversal from tree 't'.
+ Note that only one item is removed.
+ Return +1 or +2 as above.
+*/
+
+avl_code_t avl_del_first(avl_tree t, void **backup);
+
+/*
+ --- DELETE LAST ---
+ Remove last item in in-order traversal from tree 't'.
+ Note that only one item is removed.
+ Return +1 or +2 as above.
+*/
+
+avl_code_t avl_del_last(avl_tree t, void **backup);
+
+/*
+ --- INSERT IN FRONT OF INDEX ---
+ Insert 'item' in tree 't' so that afterwards,
+ 't[idx]=item' except if 'idx<=0' or 'idx>size(t)+1'.
+ To append 'item' to 't' regardless of order,
+ say 'avl_ins_index(item,size+1,t)'.
+*/
+
+avl_code_t avl_ins_index(void *item, avl_size_t idx, avl_tree t);
+
+/*
+ --- DELETE ITEM BY INDEX ---
+ Remove item of rank 'idx' from tree 't' and
+ return +1 or +2 as above except if 'idx' is not in
+ '[1,avl_size(t)]' in which case return 0.
+*/
+
+avl_code_t avl_del_index(avl_size_t idx, avl_tree t, void **backup);
+
+/*
+ --- IN-PLACE CONCATENATION ---
+ Pre-condition: 't0' and 't1' are valid avl_trees
+ Note that the code does not check whether the maximal item in 't0' is LEQ than
+ the minimal item in 't1'.
+ Post-condition: 't0' handles the concatenation of
+ 't0' and 't1' which becomes empty (but its config is untouched).
+*/
+
+void avl_cat(avl_tree t0, avl_tree t1);
+
+/*
+ --- SPLITTING ---
+ Pre-condition: 't0' and 't1' are existing handles.
+ Post-condition: items in 't0' all compare LEQ than 'item'
+ and items in 't1' all compare GEQ than 'item'.
+ This implementation removes one item.
+ Return codes:
+ 0 item not found, no-op
+ -2 compare failed, tree unchanged
+ +1 success
+*/
+
+avl_code_t avl_split(const void *item, avl_tree t, avl_tree t0, avl_tree t1);
+
+/*
+ --- IN-ORDER TRAVERSAL ---
+ Walk tree 't' in in-order, applying 'proc' at each node.
+ The 'param' pointer is passed to 'proc', like this:
+ '(*proc) (item_at_node,param)'.
+*/
+
+void avl_walk(avl_tree t, avl_item_func proc, void *param);
+
+/*
+ --- SLICE ---
+ Create a _new tree_ from the slice 't[lo_idx,hi_idx)'
+ provided 'lo_idx <= hi_idx' and these indices
+ are both in range. If a new tree can't be created
+ or if some item can't be allocated, return NULL.
+ Otherwise if the indices are inconsistent return NULL.
+*/
+
+avl_tree
+avl_slice(avl_tree t, avl_size_t lo_idx, avl_size_t hi_idx, void *param);
+
+/* ----------------------------------------------------------/
+ ITERATORS
+
+ An iterator assigned to a tree 't' is still usable after
+ any item is inserted into 't' and after any item
+ not located at this iterator's current position is
+ deleted. The 'avl_iterator_del()' function may be used
+ to remove the item at the iterator's current position.
+------------------------------------------------------------*/
+
+/*
+ --- ITERATOR --- SEEK
+ Find 'item' in this iterator's tree as in 'avl_find()'
+ and make it the current position.
+*/
+
+void avl_iterator_seek(const void *item, avl_iterator iter);
+
+/*
+ --- ITERATOR --- COUNT
+ Return size of this iterator's tree
+*/
+
+avl_size_t avl_iterator_count(avl_iterator iter);
+
+/*
+ --- ITERATOR --- SEEK BY INDEX
+ Set the current position of 'iter' to 't[idx]'
+ where 't' is the tree that is iterated over.
+*/
+
+void avl_iterator_seek_index(avl_size_t idx, avl_iterator iter);
+
+/*
+ --- ITERATOR --- CURRENT POSITION
+ Return item at current position of 'iter'.
+*/
+
+void *avl_iterator_cur(avl_iterator iter);
+
+/*
+ --- ITERATOR --- INDEX
+ Return rank of current item of 'iter' (as a result of computation)
+ except it returns 0 or size of tree plus one if 'iter' is a pre- or post- iterator.
+*/
+
+avl_size_t avl_iterator_index(avl_iterator iter);
+
+/*
+ --- ITERATOR --- CREATE
+ Return a new cursor for tree 't'.
+ If allocation of an iterator struct is impossible, return NULL.
+ Say 'avl_iterator_new(t, ini)' with 'ini==AVL_ITERATOR_INI_PRE' or 'ini==AVL_ITERATOR_INI_POST'
+ or say 'avl_iterator_new(t, AVL_ITERATOR_INI_INTREE, item_pointer)'
+ to set the iterator's current position via 'avl_iterator_seek(item_pointer,the_iterator)'.
+ In the latter case, the iterator is flagged
+ as pre-iterator if the item is not found.
+*/
+
+avl_iterator avl_iterator_new(avl_tree t, avl_ini_t ini, ...);
+
+/*
+ --- ITERATOR --- KILL
+ Cleanup: free the iterator struct.
+*/
+
+void avl_iterator_kill(avl_iterator iter);
+
+/*
+ --- ITERATOR --- SUCCESSOR
+ Get next item pointer in iterator or NULL.
+ 'iter' is flagged as post-iterator if it's in post-position.
+*/
+
+void *avl_iterator_next(avl_iterator iter);
+
+/*
+ --- ITERATOR --- PREDECESSOR
+ Get next item pointer in iterator or NULL.
+ 'iter' is flagged as pre-iterator if it's in pre-position.
+*/
+
+void *avl_iterator_prev(avl_iterator iter);
+
+/*
+ --- ITERATOR --- DELETION
+ Remove item at current position of iterator 'iter' from its tree, if there is one.
+ Current position is set to next item or iterator is flagged as post-iterator.
+*/
+
+avl_code_t avl_iterator_del(avl_iterator iter, void **backup);
+
+/*
+ --- VERIFICATION ---
+ Return avl_true iff 't' is a valid avl_tree.
+ Note that 'avl_verify(NULL)==avl_false'.
+*/
+
+#ifdef HAVE_AVL_VERIFY
+avl_bool_t avl_verify(avl_tree t);
+#endif /* HAVE_AVL_VERIFY */
+
+/*
+ --- LOAD ---
+ More general version of avl_slice
+*/
+
+avl_tree
+avl_xload(avl_itersource src,
+ void **pres, avl_size_t len, avl_config conf, void *param);
+
+#endif /* __AVL__ */
diff --git a/Build/source/texk/web2c/mplibdir/decContext.c b/Build/source/texk/web2c/mplibdir/decContext.c
new file mode 100644
index 00000000000..9f99759336e
--- /dev/null
+++ b/Build/source/texk/web2c/mplibdir/decContext.c
@@ -0,0 +1,437 @@
+/* ------------------------------------------------------------------ */
+/* Decimal Context module */
+/* ------------------------------------------------------------------ */
+/* Copyright (c) IBM Corporation, 2000, 2009. All rights reserved. */
+/* */
+/* This software is made available under the terms of the */
+/* ICU License -- ICU 1.8.1 and later. */
+/* */
+/* The description and User's Guide ("The decNumber C Library") for */
+/* this software is called decNumber.pdf. This document is */
+/* available, together with arithmetic and format specifications, */
+/* testcases, and Web links, on the General Decimal Arithmetic page. */
+/* */
+/* Please send comments, suggestions, and corrections to the author: */
+/* mfc@uk.ibm.com */
+/* Mike Cowlishaw, IBM Fellow */
+/* IBM UK, PO Box 31, Birmingham Road, Warwick CV34 5JL, UK */
+/* ------------------------------------------------------------------ */
+/* This module comprises the routines for handling arithmetic */
+/* context structures. */
+/* ------------------------------------------------------------------ */
+
+#include <string.h> // for strcmp
+#include <stdio.h> // for printf if DECCHECK
+#include "decContext.h" // context and base types
+#include "decNumberLocal.h" // decNumber local types, etc.
+
+/* compile-time endian tester [assumes sizeof(Int)>1] */
+static const Int mfcone=1; // constant 1
+static const Flag *mfctop=(const Flag *)&mfcone; // -> top byte
+#define LITEND *mfctop // named flag; 1=little-endian
+
+/* ------------------------------------------------------------------ */
+/* round-for-reround digits */
+/* ------------------------------------------------------------------ */
+const uByte DECSTICKYTAB[10]={1,1,2,3,4,6,6,7,8,9}; /* used if sticky */
+
+/* ------------------------------------------------------------------ */
+/* Powers of ten (powers[n]==10**n, 0<=n<=9) */
+/* ------------------------------------------------------------------ */
+const uInt DECPOWERS[10]={1, 10, 100, 1000, 10000, 100000, 1000000,
+ 10000000, 100000000, 1000000000};
+
+/* ------------------------------------------------------------------ */
+/* decContextClearStatus -- clear bits in current status */
+/* */
+/* context is the context structure to be queried */
+/* mask indicates the bits to be cleared (the status bit that */
+/* corresponds to each 1 bit in the mask is cleared) */
+/* returns context */
+/* */
+/* No error is possible. */
+/* ------------------------------------------------------------------ */
+decContext *decContextClearStatus(decContext *context, uInt mask) {
+ context->status&=~mask;
+ return context;
+ } // decContextClearStatus
+
+/* ------------------------------------------------------------------ */
+/* decContextDefault -- initialize a context structure */
+/* */
+/* context is the structure to be initialized */
+/* kind selects the required set of default values, one of: */
+/* DEC_INIT_BASE -- select ANSI X3-274 defaults */
+/* DEC_INIT_DECIMAL32 -- select IEEE 754 defaults, 32-bit */
+/* DEC_INIT_DECIMAL64 -- select IEEE 754 defaults, 64-bit */
+/* DEC_INIT_DECIMAL128 -- select IEEE 754 defaults, 128-bit */
+/* For any other value a valid context is returned, but with */
+/* Invalid_operation set in the status field. */
+/* returns a context structure with the appropriate initial values. */
+/* ------------------------------------------------------------------ */
+decContext * decContextDefault(decContext *context, Int kind) {
+ // set defaults...
+ context->digits=9; // 9 digits
+ context->emax=DEC_MAX_EMAX; // 9-digit exponents
+ context->emin=DEC_MIN_EMIN; // .. balanced
+ context->round=DEC_ROUND_HALF_UP; // 0.5 rises
+ context->traps=DEC_Errors; // all but informational
+ context->status=0; // cleared
+ context->clamp=0; // no clamping
+ #if DECSUBSET
+ context->extended=0; // cleared
+ #endif
+ switch (kind) {
+ case DEC_INIT_BASE:
+ // [use defaults]
+ break;
+ case DEC_INIT_DECIMAL32:
+ context->digits=7; // digits
+ context->emax=96; // Emax
+ context->emin=-95; // Emin
+ context->round=DEC_ROUND_HALF_EVEN; // 0.5 to nearest even
+ context->traps=0; // no traps set
+ context->clamp=1; // clamp exponents
+ #if DECSUBSET
+ context->extended=1; // set
+ #endif
+ break;
+ case DEC_INIT_DECIMAL64:
+ context->digits=16; // digits
+ context->emax=384; // Emax
+ context->emin=-383; // Emin
+ context->round=DEC_ROUND_HALF_EVEN; // 0.5 to nearest even
+ context->traps=0; // no traps set
+ context->clamp=1; // clamp exponents
+ #if DECSUBSET
+ context->extended=1; // set
+ #endif
+ break;
+ case DEC_INIT_DECIMAL128:
+ context->digits=34; // digits
+ context->emax=6144; // Emax
+ context->emin=-6143; // Emin
+ context->round=DEC_ROUND_HALF_EVEN; // 0.5 to nearest even
+ context->traps=0; // no traps set
+ context->clamp=1; // clamp exponents
+ #if DECSUBSET
+ context->extended=1; // set
+ #endif
+ break;
+
+ default: // invalid Kind
+ // use defaults, and ..
+ decContextSetStatus(context, DEC_Invalid_operation); // trap
+ }
+
+ return context;} // decContextDefault
+
+/* ------------------------------------------------------------------ */
+/* decContextGetRounding -- return current rounding mode */
+/* */
+/* context is the context structure to be queried */
+/* returns the rounding mode */
+/* */
+/* No error is possible. */
+/* ------------------------------------------------------------------ */
+enum rounding decContextGetRounding(decContext *context) {
+ return context->round;
+ } // decContextGetRounding
+
+/* ------------------------------------------------------------------ */
+/* decContextGetStatus -- return current status */
+/* */
+/* context is the context structure to be queried */
+/* returns status */
+/* */
+/* No error is possible. */
+/* ------------------------------------------------------------------ */
+uInt decContextGetStatus(decContext *context) {
+ return context->status;
+ } // decContextGetStatus
+
+/* ------------------------------------------------------------------ */
+/* decContextRestoreStatus -- restore bits in current status */
+/* */
+/* context is the context structure to be updated */
+/* newstatus is the source for the bits to be restored */
+/* mask indicates the bits to be restored (the status bit that */
+/* corresponds to each 1 bit in the mask is set to the value of */
+/* the correspnding bit in newstatus) */
+/* returns context */
+/* */
+/* No error is possible. */
+/* ------------------------------------------------------------------ */
+decContext *decContextRestoreStatus(decContext *context,
+ uInt newstatus, uInt mask) {
+ context->status&=~mask; // clear the selected bits
+ context->status|=(mask&newstatus); // or in the new bits
+ return context;
+ } // decContextRestoreStatus
+
+/* ------------------------------------------------------------------ */
+/* decContextSaveStatus -- save bits in current status */
+/* */
+/* context is the context structure to be queried */
+/* mask indicates the bits to be saved (the status bits that */
+/* correspond to each 1 bit in the mask are saved) */
+/* returns the AND of the mask and the current status */
+/* */
+/* No error is possible. */
+/* ------------------------------------------------------------------ */
+uInt decContextSaveStatus(decContext *context, uInt mask) {
+ return context->status&mask;
+ } // decContextSaveStatus
+
+/* ------------------------------------------------------------------ */
+/* decContextSetRounding -- set current rounding mode */
+/* */
+/* context is the context structure to be updated */
+/* newround is the value which will replace the current mode */
+/* returns context */
+/* */
+/* No error is possible. */
+/* ------------------------------------------------------------------ */
+decContext *decContextSetRounding(decContext *context,
+ enum rounding newround) {
+ context->round=newround;
+ return context;
+ } // decContextSetRounding
+
+/* ------------------------------------------------------------------ */
+/* decContextSetStatus -- set status and raise trap if appropriate */
+/* */
+/* context is the context structure to be updated */
+/* status is the DEC_ exception code */
+/* returns the context structure */
+/* */
+/* Control may never return from this routine, if there is a signal */
+/* handler and it takes a long jump. */
+/* ------------------------------------------------------------------ */
+decContext * decContextSetStatus(decContext *context, uInt status) {
+ context->status|=status;
+ if (status & context->traps) raise(SIGFPE);
+ return context;} // decContextSetStatus
+
+/* ------------------------------------------------------------------ */
+/* decContextSetStatusFromString -- set status from a string + trap */
+/* */
+/* context is the context structure to be updated */
+/* string is a string exactly equal to one that might be returned */
+/* by decContextStatusToString */
+/* */
+/* The status bit corresponding to the string is set, and a trap */
+/* is raised if appropriate. */
+/* */
+/* returns the context structure, unless the string is equal to */
+/* DEC_Condition_MU or is not recognized. In these cases NULL is */
+/* returned. */
+/* ------------------------------------------------------------------ */
+decContext * decContextSetStatusFromString(decContext *context,
+ const char *string) {
+ if (strcmp(string, DEC_Condition_CS)==0)
+ return decContextSetStatus(context, DEC_Conversion_syntax);
+ if (strcmp(string, DEC_Condition_DZ)==0)
+ return decContextSetStatus(context, DEC_Division_by_zero);
+ if (strcmp(string, DEC_Condition_DI)==0)
+ return decContextSetStatus(context, DEC_Division_impossible);
+ if (strcmp(string, DEC_Condition_DU)==0)
+ return decContextSetStatus(context, DEC_Division_undefined);
+ if (strcmp(string, DEC_Condition_IE)==0)
+ return decContextSetStatus(context, DEC_Inexact);
+ if (strcmp(string, DEC_Condition_IS)==0)
+ return decContextSetStatus(context, DEC_Insufficient_storage);
+ if (strcmp(string, DEC_Condition_IC)==0)
+ return decContextSetStatus(context, DEC_Invalid_context);
+ if (strcmp(string, DEC_Condition_IO)==0)
+ return decContextSetStatus(context, DEC_Invalid_operation);
+ #if DECSUBSET
+ if (strcmp(string, DEC_Condition_LD)==0)
+ return decContextSetStatus(context, DEC_Lost_digits);
+ #endif
+ if (strcmp(string, DEC_Condition_OV)==0)
+ return decContextSetStatus(context, DEC_Overflow);
+ if (strcmp(string, DEC_Condition_PA)==0)
+ return decContextSetStatus(context, DEC_Clamped);
+ if (strcmp(string, DEC_Condition_RO)==0)
+ return decContextSetStatus(context, DEC_Rounded);
+ if (strcmp(string, DEC_Condition_SU)==0)
+ return decContextSetStatus(context, DEC_Subnormal);
+ if (strcmp(string, DEC_Condition_UN)==0)
+ return decContextSetStatus(context, DEC_Underflow);
+ if (strcmp(string, DEC_Condition_ZE)==0)
+ return context;
+ return NULL; // Multiple status, or unknown
+ } // decContextSetStatusFromString
+
+/* ------------------------------------------------------------------ */
+/* decContextSetStatusFromStringQuiet -- set status from a string */
+/* */
+/* context is the context structure to be updated */
+/* string is a string exactly equal to one that might be returned */
+/* by decContextStatusToString */
+/* */
+/* The status bit corresponding to the string is set; no trap is */
+/* raised. */
+/* */
+/* returns the context structure, unless the string is equal to */
+/* DEC_Condition_MU or is not recognized. In these cases NULL is */
+/* returned. */
+/* ------------------------------------------------------------------ */
+decContext * decContextSetStatusFromStringQuiet(decContext *context,
+ const char *string) {
+ if (strcmp(string, DEC_Condition_CS)==0)
+ return decContextSetStatusQuiet(context, DEC_Conversion_syntax);
+ if (strcmp(string, DEC_Condition_DZ)==0)
+ return decContextSetStatusQuiet(context, DEC_Division_by_zero);
+ if (strcmp(string, DEC_Condition_DI)==0)
+ return decContextSetStatusQuiet(context, DEC_Division_impossible);
+ if (strcmp(string, DEC_Condition_DU)==0)
+ return decContextSetStatusQuiet(context, DEC_Division_undefined);
+ if (strcmp(string, DEC_Condition_IE)==0)
+ return decContextSetStatusQuiet(context, DEC_Inexact);
+ if (strcmp(string, DEC_Condition_IS)==0)
+ return decContextSetStatusQuiet(context, DEC_Insufficient_storage);
+ if (strcmp(string, DEC_Condition_IC)==0)
+ return decContextSetStatusQuiet(context, DEC_Invalid_context);
+ if (strcmp(string, DEC_Condition_IO)==0)
+ return decContextSetStatusQuiet(context, DEC_Invalid_operation);
+ #if DECSUBSET
+ if (strcmp(string, DEC_Condition_LD)==0)
+ return decContextSetStatusQuiet(context, DEC_Lost_digits);
+ #endif
+ if (strcmp(string, DEC_Condition_OV)==0)
+ return decContextSetStatusQuiet(context, DEC_Overflow);
+ if (strcmp(string, DEC_Condition_PA)==0)
+ return decContextSetStatusQuiet(context, DEC_Clamped);
+ if (strcmp(string, DEC_Condition_RO)==0)
+ return decContextSetStatusQuiet(context, DEC_Rounded);
+ if (strcmp(string, DEC_Condition_SU)==0)
+ return decContextSetStatusQuiet(context, DEC_Subnormal);
+ if (strcmp(string, DEC_Condition_UN)==0)
+ return decContextSetStatusQuiet(context, DEC_Underflow);
+ if (strcmp(string, DEC_Condition_ZE)==0)
+ return context;
+ return NULL; // Multiple status, or unknown
+ } // decContextSetStatusFromStringQuiet
+
+/* ------------------------------------------------------------------ */
+/* decContextSetStatusQuiet -- set status without trap */
+/* */
+/* context is the context structure to be updated */
+/* status is the DEC_ exception code */
+/* returns the context structure */
+/* */
+/* No error is possible. */
+/* ------------------------------------------------------------------ */
+decContext * decContextSetStatusQuiet(decContext *context, uInt status) {
+ context->status|=status;
+ return context;} // decContextSetStatusQuiet
+
+/* ------------------------------------------------------------------ */
+/* decContextStatusToString -- convert status flags to a string */
+/* */
+/* context is a context with valid status field */
+/* */
+/* returns a constant string describing the condition. If multiple */
+/* (or no) flags are set, a generic constant message is returned. */
+/* ------------------------------------------------------------------ */
+const char *decContextStatusToString(const decContext *context) {
+ Int status=context->status;
+
+ // test the five IEEE first, as some of the others are ambiguous when
+ // DECEXTFLAG=0
+ if (status==DEC_Invalid_operation ) return DEC_Condition_IO;
+ if (status==DEC_Division_by_zero ) return DEC_Condition_DZ;
+ if (status==DEC_Overflow ) return DEC_Condition_OV;
+ if (status==DEC_Underflow ) return DEC_Condition_UN;
+ if (status==DEC_Inexact ) return DEC_Condition_IE;
+
+ if (status==DEC_Division_impossible ) return DEC_Condition_DI;
+ if (status==DEC_Division_undefined ) return DEC_Condition_DU;
+ if (status==DEC_Rounded ) return DEC_Condition_RO;
+ if (status==DEC_Clamped ) return DEC_Condition_PA;
+ if (status==DEC_Subnormal ) return DEC_Condition_SU;
+ if (status==DEC_Conversion_syntax ) return DEC_Condition_CS;
+ if (status==DEC_Insufficient_storage ) return DEC_Condition_IS;
+ if (status==DEC_Invalid_context ) return DEC_Condition_IC;
+ #if DECSUBSET
+ if (status==DEC_Lost_digits ) return DEC_Condition_LD;
+ #endif
+ if (status==0 ) return DEC_Condition_ZE;
+ return DEC_Condition_MU; // Multiple errors
+ } // decContextStatusToString
+
+/* ------------------------------------------------------------------ */
+/* decContextTestEndian -- test whether DECLITEND is set correctly */
+/* */
+/* quiet is 1 to suppress message; 0 otherwise */
+/* returns 0 if DECLITEND is correct */
+/* 1 if DECLITEND is incorrect and should be 1 */
+/* -1 if DECLITEND is incorrect and should be 0 */
+/* */
+/* A message is displayed if the return value is not 0 and quiet==0. */
+/* */
+/* No error is possible. */
+/* ------------------------------------------------------------------ */
+Int decContextTestEndian(Flag quiet) {
+ Int res=0; // optimist
+ uInt dle=(uInt)DECLITEND; // unsign
+ if (dle>1) dle=1; // ensure 0 or 1
+
+ if (LITEND!=DECLITEND) {
+ if (!quiet) { // always refer to this
+ #if DECPRINT
+ const char *adj;
+ if (LITEND) adj="little";
+ else adj="big";
+ printf("Warning: DECLITEND is set to %d, but this computer appears to be %s-endian\n",
+ DECLITEND, adj);
+ #endif
+ }
+ res=(Int)LITEND-dle;
+ }
+ return res;
+ } // decContextTestEndian
+
+/* ------------------------------------------------------------------ */
+/* decContextTestSavedStatus -- test bits in saved status */
+/* */
+/* oldstatus is the status word to be tested */
+/* mask indicates the bits to be tested (the oldstatus bits that */
+/* correspond to each 1 bit in the mask are tested) */
+/* returns 1 if any of the tested bits are 1, or 0 otherwise */
+/* */
+/* No error is possible. */
+/* ------------------------------------------------------------------ */
+uInt decContextTestSavedStatus(uInt oldstatus, uInt mask) {
+ return (oldstatus&mask)!=0;
+ } // decContextTestSavedStatus
+
+/* ------------------------------------------------------------------ */
+/* decContextTestStatus -- test bits in current status */
+/* */
+/* context is the context structure to be updated */
+/* mask indicates the bits to be tested (the status bits that */
+/* correspond to each 1 bit in the mask are tested) */
+/* returns 1 if any of the tested bits are 1, or 0 otherwise */
+/* */
+/* No error is possible. */
+/* ------------------------------------------------------------------ */
+uInt decContextTestStatus(decContext *context, uInt mask) {
+ return (context->status&mask)!=0;
+ } // decContextTestStatus
+
+/* ------------------------------------------------------------------ */
+/* decContextZeroStatus -- clear all status bits */
+/* */
+/* context is the context structure to be updated */
+/* returns context */
+/* */
+/* No error is possible. */
+/* ------------------------------------------------------------------ */
+decContext *decContextZeroStatus(decContext *context) {
+ context->status=0;
+ return context;
+ } // decContextZeroStatus
+
diff --git a/Build/source/texk/web2c/mplibdir/decContext.h b/Build/source/texk/web2c/mplibdir/decContext.h
new file mode 100644
index 00000000000..82e4fcf2db3
--- /dev/null
+++ b/Build/source/texk/web2c/mplibdir/decContext.h
@@ -0,0 +1,254 @@
+/* ------------------------------------------------------------------ */
+/* Decimal Context module header */
+/* ------------------------------------------------------------------ */
+/* Copyright (c) IBM Corporation, 2000, 2010. All rights reserved. */
+/* */
+/* This software is made available under the terms of the */
+/* ICU License -- ICU 1.8.1 and later. */
+/* */
+/* The description and User's Guide ("The decNumber C Library") for */
+/* this software is called decNumber.pdf. This document is */
+/* available, together with arithmetic and format specifications, */
+/* testcases, and Web links, on the General Decimal Arithmetic page. */
+/* */
+/* Please send comments, suggestions, and corrections to the author: */
+/* mfc@uk.ibm.com */
+/* Mike Cowlishaw, IBM Fellow */
+/* IBM UK, PO Box 31, Birmingham Road, Warwick CV34 5JL, UK */
+/* ------------------------------------------------------------------ */
+/* */
+/* Context variables must always have valid values: */
+/* */
+/* status -- [any bits may be cleared, but not set, by user] */
+/* round -- must be one of the enumerated rounding modes */
+/* */
+/* The following variables are implied for fixed size formats (i.e., */
+/* they are ignored) but should still be set correctly in case used */
+/* with decNumber functions: */
+/* */
+/* clamp -- must be either 0 or 1 */
+/* digits -- must be in the range 1 through 999999999 */
+/* emax -- must be in the range 0 through 999999999 */
+/* emin -- must be in the range 0 through -999999999 */
+/* extended -- must be either 0 or 1 [present only if DECSUBSET] */
+/* traps -- only defined bits may be set */
+/* */
+/* ------------------------------------------------------------------ */
+
+#if !defined(DECCONTEXT)
+ #define DECCONTEXT
+ #define DECCNAME "decContext" /* Short name */
+ #define DECCFULLNAME "Decimal Context Descriptor" /* Verbose name */
+ #define DECCAUTHOR "Mike Cowlishaw" /* Who to blame */
+
+ #if !defined(int32_t)
+ #include <stdint.h> /* C99 standard integers */
+ #endif
+ #include <stdio.h> /* for printf, etc. */
+ #include <signal.h> /* for traps */
+
+ /* Extended flags setting -- set this to 0 to use only IEEE flags */
+ #if !defined(DECEXTFLAG)
+ #define DECEXTFLAG 1 /* 1=enable extended flags */
+ #endif
+
+ /* Conditional code flag -- set this to 0 for best performance */
+ #if !defined(DECSUBSET)
+ #define DECSUBSET 0 /* 1=enable subset arithmetic */
+ #endif
+
+ /* Context for operations, with associated constants */
+ enum rounding {
+ DEC_ROUND_CEILING, /* round towards +infinity */
+ DEC_ROUND_UP, /* round away from 0 */
+ DEC_ROUND_HALF_UP, /* 0.5 rounds up */
+ DEC_ROUND_HALF_EVEN, /* 0.5 rounds to nearest even */
+ DEC_ROUND_HALF_DOWN, /* 0.5 rounds down */
+ DEC_ROUND_DOWN, /* round towards 0 (truncate) */
+ DEC_ROUND_FLOOR, /* round towards -infinity */
+ DEC_ROUND_05UP, /* round for reround */
+ DEC_ROUND_MAX /* enum must be less than this */
+ };
+ #define DEC_ROUND_DEFAULT DEC_ROUND_HALF_EVEN;
+
+ typedef struct {
+ int32_t digits; /* working precision */
+ int32_t emax; /* maximum positive exponent */
+ int32_t emin; /* minimum negative exponent */
+ enum rounding round; /* rounding mode */
+ uint32_t traps; /* trap-enabler flags */
+ uint32_t status; /* status flags */
+ uint8_t clamp; /* flag: apply IEEE exponent clamp */
+ #if DECSUBSET
+ uint8_t extended; /* flag: special-values allowed */
+ #endif
+ } decContext;
+
+ /* Maxima and Minima for context settings */
+ #define DEC_MAX_DIGITS 999999999
+ #define DEC_MIN_DIGITS 1
+ #define DEC_MAX_EMAX 999999999
+ #define DEC_MIN_EMAX 0
+ #define DEC_MAX_EMIN 0
+ #define DEC_MIN_EMIN -999999999
+ #define DEC_MAX_MATH 999999 /* max emax, etc., for math funcs. */
+
+ /* Classifications for decimal numbers, aligned with 754 (note that */
+ /* 'normal' and 'subnormal' are meaningful only with a decContext */
+ /* or a fixed size format). */
+ enum decClass {
+ DEC_CLASS_SNAN,
+ DEC_CLASS_QNAN,
+ DEC_CLASS_NEG_INF,
+ DEC_CLASS_NEG_NORMAL,
+ DEC_CLASS_NEG_SUBNORMAL,
+ DEC_CLASS_NEG_ZERO,
+ DEC_CLASS_POS_ZERO,
+ DEC_CLASS_POS_SUBNORMAL,
+ DEC_CLASS_POS_NORMAL,
+ DEC_CLASS_POS_INF
+ };
+ /* Strings for the decClasses */
+ #define DEC_ClassString_SN "sNaN"
+ #define DEC_ClassString_QN "NaN"
+ #define DEC_ClassString_NI "-Infinity"
+ #define DEC_ClassString_NN "-Normal"
+ #define DEC_ClassString_NS "-Subnormal"
+ #define DEC_ClassString_NZ "-Zero"
+ #define DEC_ClassString_PZ "+Zero"
+ #define DEC_ClassString_PS "+Subnormal"
+ #define DEC_ClassString_PN "+Normal"
+ #define DEC_ClassString_PI "+Infinity"
+ #define DEC_ClassString_UN "Invalid"
+
+ /* Trap-enabler and Status flags (exceptional conditions), and */
+ /* their names. The top byte is reserved for internal use */
+ #if DECEXTFLAG
+ /* Extended flags */
+ #define DEC_Conversion_syntax 0x00000001
+ #define DEC_Division_by_zero 0x00000002
+ #define DEC_Division_impossible 0x00000004
+ #define DEC_Division_undefined 0x00000008
+ #define DEC_Insufficient_storage 0x00000010 /* [when malloc fails] */
+ #define DEC_Inexact 0x00000020
+ #define DEC_Invalid_context 0x00000040
+ #define DEC_Invalid_operation 0x00000080
+ #if DECSUBSET
+ #define DEC_Lost_digits 0x00000100
+ #endif
+ #define DEC_Overflow 0x00000200
+ #define DEC_Clamped 0x00000400
+ #define DEC_Rounded 0x00000800
+ #define DEC_Subnormal 0x00001000
+ #define DEC_Underflow 0x00002000
+ #else
+ /* IEEE flags only */
+ #define DEC_Conversion_syntax 0x00000010
+ #define DEC_Division_by_zero 0x00000002
+ #define DEC_Division_impossible 0x00000010
+ #define DEC_Division_undefined 0x00000010
+ #define DEC_Insufficient_storage 0x00000010 /* [when malloc fails] */
+ #define DEC_Inexact 0x00000001
+ #define DEC_Invalid_context 0x00000010
+ #define DEC_Invalid_operation 0x00000010
+ #if DECSUBSET
+ #define DEC_Lost_digits 0x00000000
+ #endif
+ #define DEC_Overflow 0x00000008
+ #define DEC_Clamped 0x00000000
+ #define DEC_Rounded 0x00000000
+ #define DEC_Subnormal 0x00000000
+ #define DEC_Underflow 0x00000004
+ #endif
+
+ /* IEEE 754 groupings for the flags */
+ /* [DEC_Clamped, DEC_Lost_digits, DEC_Rounded, and DEC_Subnormal */
+ /* are not in IEEE 754] */
+ #define DEC_IEEE_754_Division_by_zero (DEC_Division_by_zero)
+ #if DECSUBSET
+ #define DEC_IEEE_754_Inexact (DEC_Inexact | DEC_Lost_digits)
+ #else
+ #define DEC_IEEE_754_Inexact (DEC_Inexact)
+ #endif
+ #define DEC_IEEE_754_Invalid_operation (DEC_Conversion_syntax | \
+ DEC_Division_impossible | \
+ DEC_Division_undefined | \
+ DEC_Insufficient_storage | \
+ DEC_Invalid_context | \
+ DEC_Invalid_operation)
+ #define DEC_IEEE_754_Overflow (DEC_Overflow)
+ #define DEC_IEEE_754_Underflow (DEC_Underflow)
+
+ /* flags which are normally errors (result is qNaN, infinite, or 0) */
+ #define DEC_Errors (DEC_IEEE_754_Division_by_zero | \
+ DEC_IEEE_754_Invalid_operation | \
+ DEC_IEEE_754_Overflow | DEC_IEEE_754_Underflow)
+ /* flags which cause a result to become qNaN */
+ #define DEC_NaNs DEC_IEEE_754_Invalid_operation
+
+ /* flags which are normally for information only (finite results) */
+ #if DECSUBSET
+ #define DEC_Information (DEC_Clamped | DEC_Rounded | DEC_Inexact \
+ | DEC_Lost_digits)
+ #else
+ #define DEC_Information (DEC_Clamped | DEC_Rounded | DEC_Inexact)
+ #endif
+
+ /* IEEE 854 names (for compatibility with older decNumber versions) */
+ #define DEC_IEEE_854_Division_by_zero DEC_IEEE_754_Division_by_zero
+ #define DEC_IEEE_854_Inexact DEC_IEEE_754_Inexact
+ #define DEC_IEEE_854_Invalid_operation DEC_IEEE_754_Invalid_operation
+ #define DEC_IEEE_854_Overflow DEC_IEEE_754_Overflow
+ #define DEC_IEEE_854_Underflow DEC_IEEE_754_Underflow
+
+ /* Name strings for the exceptional conditions */
+ #define DEC_Condition_CS "Conversion syntax"
+ #define DEC_Condition_DZ "Division by zero"
+ #define DEC_Condition_DI "Division impossible"
+ #define DEC_Condition_DU "Division undefined"
+ #define DEC_Condition_IE "Inexact"
+ #define DEC_Condition_IS "Insufficient storage"
+ #define DEC_Condition_IC "Invalid context"
+ #define DEC_Condition_IO "Invalid operation"
+ #if DECSUBSET
+ #define DEC_Condition_LD "Lost digits"
+ #endif
+ #define DEC_Condition_OV "Overflow"
+ #define DEC_Condition_PA "Clamped"
+ #define DEC_Condition_RO "Rounded"
+ #define DEC_Condition_SU "Subnormal"
+ #define DEC_Condition_UN "Underflow"
+ #define DEC_Condition_ZE "No status"
+ #define DEC_Condition_MU "Multiple status"
+ #define DEC_Condition_Length 21 /* length of the longest string, */
+ /* including terminator */
+
+ /* Initialization descriptors, used by decContextDefault */
+ #define DEC_INIT_BASE 0
+ #define DEC_INIT_DECIMAL32 32
+ #define DEC_INIT_DECIMAL64 64
+ #define DEC_INIT_DECIMAL128 128
+ /* Synonyms */
+ #define DEC_INIT_DECSINGLE DEC_INIT_DECIMAL32
+ #define DEC_INIT_DECDOUBLE DEC_INIT_DECIMAL64
+ #define DEC_INIT_DECQUAD DEC_INIT_DECIMAL128
+
+ /* decContext routines */
+ extern decContext * decContextClearStatus(decContext *, uint32_t);
+ extern decContext * decContextDefault(decContext *, int32_t);
+ extern enum rounding decContextGetRounding(decContext *);
+ extern uint32_t decContextGetStatus(decContext *);
+ extern decContext * decContextRestoreStatus(decContext *, uint32_t, uint32_t);
+ extern uint32_t decContextSaveStatus(decContext *, uint32_t);
+ extern decContext * decContextSetRounding(decContext *, enum rounding);
+ extern decContext * decContextSetStatus(decContext *, uint32_t);
+ extern decContext * decContextSetStatusFromString(decContext *, const char *);
+ extern decContext * decContextSetStatusFromStringQuiet(decContext *, const char *);
+ extern decContext * decContextSetStatusQuiet(decContext *, uint32_t);
+ extern const char * decContextStatusToString(const decContext *);
+ extern int32_t decContextTestEndian(uint8_t);
+ extern uint32_t decContextTestSavedStatus(uint32_t, uint32_t);
+ extern uint32_t decContextTestStatus(decContext *, uint32_t);
+ extern decContext * decContextZeroStatus(decContext *);
+
+#endif
diff --git a/Build/source/texk/web2c/mplibdir/decNumber.c b/Build/source/texk/web2c/mplibdir/decNumber.c
new file mode 100644
index 00000000000..19230b89576
--- /dev/null
+++ b/Build/source/texk/web2c/mplibdir/decNumber.c
@@ -0,0 +1,8141 @@
+/* ------------------------------------------------------------------ */
+/* Decimal Number arithmetic module */
+/* ------------------------------------------------------------------ */
+/* Copyright (c) IBM Corporation, 2000, 2009. All rights reserved. */
+/* */
+/* This software is made available under the terms of the */
+/* ICU License -- ICU 1.8.1 and later. */
+/* */
+/* The description and User's Guide ("The decNumber C Library") for */
+/* this software is called decNumber.pdf. This document is */
+/* available, together with arithmetic and format specifications, */
+/* testcases, and Web links, on the General Decimal Arithmetic page. */
+/* */
+/* Please send comments, suggestions, and corrections to the author: */
+/* mfc@uk.ibm.com */
+/* Mike Cowlishaw, IBM Fellow */
+/* IBM UK, PO Box 31, Birmingham Road, Warwick CV34 5JL, UK */
+/* ------------------------------------------------------------------ */
+/* This module comprises the routines for arbitrary-precision General */
+/* Decimal Arithmetic as defined in the specification which may be */
+/* found on the General Decimal Arithmetic pages. It implements both */
+/* the full ('extended') arithmetic and the simpler ('subset') */
+/* arithmetic. */
+/* */
+/* Usage notes: */
+/* */
+/* 1. This code is ANSI C89 except: */
+/* */
+/* a) C99 line comments (double forward slash) are used. (Most C */
+/* compilers accept these. If yours does not, a simple script */
+/* can be used to convert them to ANSI C comments.) */
+/* */
+/* b) Types from C99 stdint.h are used. If you do not have this */
+/* header file, see the User's Guide section of the decNumber */
+/* documentation; this lists the necessary definitions. */
+/* */
+/* c) If DECDPUN>4 or DECUSE64=1, the C99 64-bit int64_t and */
+/* uint64_t types may be used. To avoid these, set DECUSE64=0 */
+/* and DECDPUN<=4 (see documentation). */
+/* */
+/* The code also conforms to C99 restrictions; in particular, */
+/* strict aliasing rules are observed. */
+/* */
+/* 2. The decNumber format which this library uses is optimized for */
+/* efficient processing of relatively short numbers; in particular */
+/* it allows the use of fixed sized structures and minimizes copy */
+/* and move operations. It does, however, support arbitrary */
+/* precision (up to 999,999,999 digits) and arbitrary exponent */
+/* range (Emax in the range 0 through 999,999,999 and Emin in the */
+/* range -999,999,999 through 0). Mathematical functions (for */
+/* example decNumberExp) as identified below are restricted more */
+/* tightly: digits, emax, and -emin in the context must be <= */
+/* DEC_MAX_MATH (999999), and their operand(s) must be within */
+/* these bounds. */
+/* */
+/* 3. Logical functions are further restricted; their operands must */
+/* be finite, positive, have an exponent of zero, and all digits */
+/* must be either 0 or 1. The result will only contain digits */
+/* which are 0 or 1 (and will have exponent=0 and a sign of 0). */
+/* */
+/* 4. Operands to operator functions are never modified unless they */
+/* are also specified to be the result number (which is always */
+/* permitted). Other than that case, operands must not overlap. */
+/* */
+/* 5. Error handling: the type of the error is ORed into the status */
+/* flags in the current context (decContext structure). The */
+/* SIGFPE signal is then raised if the corresponding trap-enabler */
+/* flag in the decContext is set (is 1). */
+/* */
+/* It is the responsibility of the caller to clear the status */
+/* flags as required. */
+/* */
+/* The result of any routine which returns a number will always */
+/* be a valid number (which may be a special value, such as an */
+/* Infinity or NaN). */
+/* */
+/* 6. The decNumber format is not an exchangeable concrete */
+/* representation as it comprises fields which may be machine- */
+/* dependent (packed or unpacked, or special length, for example). */
+/* Canonical conversions to and from strings are provided; other */
+/* conversions are available in separate modules. */
+/* */
+/* 7. Normally, input operands are assumed to be valid. Set DECCHECK */
+/* to 1 for extended operand checking (including NULL operands). */
+/* Results are undefined if a badly-formed structure (or a NULL */
+/* pointer to a structure) is provided, though with DECCHECK */
+/* enabled the operator routines are protected against exceptions. */
+/* (Except if the result pointer is NULL, which is unrecoverable.) */
+/* */
+/* However, the routines will never cause exceptions if they are */
+/* given well-formed operands, even if the value of the operands */
+/* is inappropriate for the operation and DECCHECK is not set. */
+/* (Except for SIGFPE, as and where documented.) */
+/* */
+/* 8. Subset arithmetic is available only if DECSUBSET is set to 1. */
+/* ------------------------------------------------------------------ */
+/* Implementation notes for maintenance of this module: */
+/* */
+/* 1. Storage leak protection: Routines which use malloc are not */
+/* permitted to use return for fastpath or error exits (i.e., */
+/* they follow strict structured programming conventions). */
+/* Instead they have a do{}while(0); construct surrounding the */
+/* code which is protected -- break may be used to exit this. */
+/* Other routines can safely use the return statement inline. */
+/* */
+/* Storage leak accounting can be enabled using DECALLOC. */
+/* */
+/* 2. All loops use the for(;;) construct. Any do construct does */
+/* not loop; it is for allocation protection as just described. */
+/* */
+/* 3. Setting status in the context must always be the very last */
+/* action in a routine, as non-0 status may raise a trap and hence */
+/* the call to set status may not return (if the handler uses long */
+/* jump). Therefore all cleanup must be done first. In general, */
+/* to achieve this status is accumulated and is only applied just */
+/* before return by calling decContextSetStatus (via decStatus). */
+/* */
+/* Routines which allocate storage cannot, in general, use the */
+/* 'top level' routines which could cause a non-returning */
+/* transfer of control. The decXxxxOp routines are safe (do not */
+/* call decStatus even if traps are set in the context) and should */
+/* be used instead (they are also a little faster). */
+/* */
+/* 4. Exponent checking is minimized by allowing the exponent to */
+/* grow outside its limits during calculations, provided that */
+/* the decFinalize function is called later. Multiplication and */
+/* division, and intermediate calculations in exponentiation, */
+/* require more careful checks because of the risk of 31-bit */
+/* overflow (the most negative valid exponent is -1999999997, for */
+/* a 999999999-digit number with adjusted exponent of -999999999). */
+/* */
+/* 5. Rounding is deferred until finalization of results, with any */
+/* 'off to the right' data being represented as a single digit */
+/* residue (in the range -1 through 9). This avoids any double- */
+/* rounding when more than one shortening takes place (for */
+/* example, when a result is subnormal). */
+/* */
+/* 6. The digits count is allowed to rise to a multiple of DECDPUN */
+/* during many operations, so whole Units are handled and exact */
+/* accounting of digits is not needed. The correct digits value */
+/* is found by decGetDigits, which accounts for leading zeros. */
+/* This must be called before any rounding if the number of digits */
+/* is not known exactly. */
+/* */
+/* 7. The multiply-by-reciprocal 'trick' is used for partitioning */
+/* numbers up to four digits, using appropriate constants. This */
+/* is not useful for longer numbers because overflow of 32 bits */
+/* would lead to 4 multiplies, which is almost as expensive as */
+/* a divide (unless a floating-point or 64-bit multiply is */
+/* assumed to be available). */
+/* */
+/* 8. Unusual abbreviations that may be used in the commentary: */
+/* lhs -- left hand side (operand, of an operation) */
+/* lsd -- least significant digit (of coefficient) */
+/* lsu -- least significant Unit (of coefficient) */
+/* msd -- most significant digit (of coefficient) */
+/* msi -- most significant item (in an array) */
+/* msu -- most significant Unit (of coefficient) */
+/* rhs -- right hand side (operand, of an operation) */
+/* +ve -- positive */
+/* -ve -- negative */
+/* ** -- raise to the power */
+/* ------------------------------------------------------------------ */
+
+#include <stdlib.h> // for malloc, free, etc.
+#include <stdio.h> // for printf [if needed]
+#include <string.h> // for strcpy
+#include <ctype.h> // for lower
+#include "decNumber.h" // base number library
+#include "decNumberLocal.h" // decNumber local types, etc.
+
+/* Constants */
+// Public lookup table used by the D2U macro
+const uByte d2utable[DECMAXD2U+1]=D2UTABLE;
+
+#define DECVERB 1 // set to 1 for verbose DECCHECK
+#define powers DECPOWERS // old internal name
+
+// Local constants
+#define DIVIDE 0x80 // Divide operators
+#define REMAINDER 0x40 // ..
+#define DIVIDEINT 0x20 // ..
+#define REMNEAR 0x10 // ..
+#define COMPARE 0x01 // Compare operators
+#define COMPMAX 0x02 // ..
+#define COMPMIN 0x03 // ..
+#define COMPTOTAL 0x04 // ..
+#define COMPNAN 0x05 // .. [NaN processing]
+#define COMPSIG 0x06 // .. [signaling COMPARE]
+#define COMPMAXMAG 0x07 // ..
+#define COMPMINMAG 0x08 // ..
+
+#define DEC_sNaN 0x40000000 // local status: sNaN signal
+#define BADINT (Int)0x80000000 // most-negative Int; error indicator
+// Next two indicate an integer >= 10**6, and its parity (bottom bit)
+#define BIGEVEN (Int)0x80000002
+#define BIGODD (Int)0x80000003
+
+static Unit uarrone[1]={1}; // Unit array of 1, used for incrementing
+
+/* Granularity-dependent code */
+#if DECDPUN<=4
+ #define eInt Int // extended integer
+ #define ueInt uInt // unsigned extended integer
+ // Constant multipliers for divide-by-power-of five using reciprocal
+ // multiply, after removing powers of 2 by shifting, and final shift
+ // of 17 [we only need up to **4]
+ static const uInt multies[]={131073, 26215, 5243, 1049, 210};
+ // QUOT10 -- macro to return the quotient of unit u divided by 10**n
+ #define QUOT10(u, n) ((((uInt)(u)>>(n))*multies[n])>>17)
+#else
+ // For DECDPUN>4 non-ANSI-89 64-bit types are needed.
+ #if !DECUSE64
+ #error decNumber.c: DECUSE64 must be 1 when DECDPUN>4
+ #endif
+ #define eInt Long // extended integer
+ #define ueInt uLong // unsigned extended integer
+#endif
+
+/* Local routines */
+static decNumber * decAddOp(decNumber *, const decNumber *, const decNumber *,
+ decContext *, uByte, uInt *);
+static Flag decBiStr(const char *, const char *, const char *);
+static uInt decCheckMath(const decNumber *, decContext *, uInt *);
+static void decApplyRound(decNumber *, decContext *, Int, uInt *);
+static Int decCompare(const decNumber *lhs, const decNumber *rhs, Flag);
+static decNumber * decCompareOp(decNumber *, const decNumber *,
+ const decNumber *, decContext *,
+ Flag, uInt *);
+static void decCopyFit(decNumber *, const decNumber *, decContext *,
+ Int *, uInt *);
+static decNumber * decDecap(decNumber *, Int);
+static decNumber * decDivideOp(decNumber *, const decNumber *,
+ const decNumber *, decContext *, Flag, uInt *);
+static decNumber * decExpOp(decNumber *, const decNumber *,
+ decContext *, uInt *);
+static void decFinalize(decNumber *, decContext *, Int *, uInt *);
+static Int decGetDigits(Unit *, Int);
+static Int decGetInt(const decNumber *);
+static decNumber * decLnOp(decNumber *, const decNumber *,
+ decContext *, uInt *);
+static decNumber * decMultiplyOp(decNumber *, const decNumber *,
+ const decNumber *, decContext *,
+ uInt *);
+static decNumber * decNaNs(decNumber *, const decNumber *,
+ const decNumber *, decContext *, uInt *);
+static decNumber * decQuantizeOp(decNumber *, const decNumber *,
+ const decNumber *, decContext *, Flag,
+ uInt *);
+static void decReverse(Unit *, Unit *);
+static void decSetCoeff(decNumber *, decContext *, const Unit *,
+ Int, Int *, uInt *);
+static void decSetMaxValue(decNumber *, decContext *);
+static void decSetOverflow(decNumber *, decContext *, uInt *);
+static void decSetSubnormal(decNumber *, decContext *, Int *, uInt *);
+static Int decShiftToLeast(Unit *, Int, Int);
+static Int decShiftToMost(Unit *, Int, Int);
+static void decStatus(decNumber *, uInt, decContext *);
+static void decToString(const decNumber *, char[], Flag);
+static decNumber * decTrim(decNumber *, decContext *, Flag, Flag, Int *);
+static Int decUnitAddSub(const Unit *, Int, const Unit *, Int, Int,
+ Unit *, Int);
+static Int decUnitCompare(const Unit *, Int, const Unit *, Int, Int);
+
+#if !DECSUBSET
+/* decFinish == decFinalize when no subset arithmetic needed */
+#define decFinish(a,b,c,d) decFinalize(a,b,c,d)
+#else
+static void decFinish(decNumber *, decContext *, Int *, uInt *);
+static decNumber * decRoundOperand(const decNumber *, decContext *, uInt *);
+#endif
+
+/* Local macros */
+// masked special-values bits
+#define SPECIALARG (rhs->bits & DECSPECIAL)
+#define SPECIALARGS ((lhs->bits | rhs->bits) & DECSPECIAL)
+
+/* Diagnostic macros, etc. */
+#if DECALLOC
+// Handle malloc/free accounting. If enabled, our accountable routines
+// are used; otherwise the code just goes straight to the system malloc
+// and free routines.
+#define malloc(a) decMalloc(a)
+#define free(a) decFree(a)
+#define DECFENCE 0x5a // corruption detector
+// 'Our' malloc and free:
+static void *decMalloc(size_t);
+static void decFree(void *);
+uInt decAllocBytes=0; // count of bytes allocated
+// Note that DECALLOC code only checks for storage buffer overflow.
+// To check for memory leaks, the decAllocBytes variable must be
+// checked to be 0 at appropriate times (e.g., after the test
+// harness completes a set of tests). This checking may be unreliable
+// if the testing is done in a multi-thread environment.
+#endif
+
+#if DECCHECK
+// Optional checking routines. Enabling these means that decNumber
+// and decContext operands to operator routines are checked for
+// correctness. This roughly doubles the execution time of the
+// fastest routines (and adds 600+ bytes), so should not normally be
+// used in 'production'.
+// decCheckInexact is used to check that inexact results have a full
+// complement of digits (where appropriate -- this is not the case
+// for Quantize, for example)
+#define DECUNRESU ((decNumber *)(void *)0xffffffff)
+#define DECUNUSED ((const decNumber *)(void *)0xffffffff)
+#define DECUNCONT ((decContext *)(void *)(0xffffffff))
+static Flag decCheckOperands(decNumber *, const decNumber *,
+ const decNumber *, decContext *);
+static Flag decCheckNumber(const decNumber *);
+static void decCheckInexact(const decNumber *, decContext *);
+#endif
+
+#if DECTRACE || DECCHECK
+// Optional trace/debugging routines (may or may not be used)
+void decNumberShow(const decNumber *); // displays the components of a number
+static void decDumpAr(char, const Unit *, Int);
+#endif
+
+/* ================================================================== */
+/* Conversions */
+/* ================================================================== */
+
+/* ------------------------------------------------------------------ */
+/* from-int32 -- conversion from Int or uInt */
+/* */
+/* dn is the decNumber to receive the integer */
+/* in or uin is the integer to be converted */
+/* returns dn */
+/* */
+/* No error is possible. */
+/* ------------------------------------------------------------------ */
+decNumber * decNumberFromInt32(decNumber *dn, Int in) {
+ uInt unsig;
+ if (in>=0) unsig=in;
+ else { // negative (possibly BADINT)
+ if (in==BADINT) unsig=(uInt)1073741824*2; // special case
+ else unsig=-in; // invert
+ }
+ // in is now positive
+ decNumberFromUInt32(dn, unsig);
+ if (in<0) dn->bits=DECNEG; // sign needed
+ return dn;
+ } // decNumberFromInt32
+
+decNumber * decNumberFromUInt32(decNumber *dn, uInt uin) {
+ Unit *up; // work pointer
+ decNumberZero(dn); // clean
+ if (uin==0) return dn; // [or decGetDigits bad call]
+ for (up=dn->lsu; uin>0; up++) {
+ *up=(Unit)(uin%(DECDPUNMAX+1));
+ uin=uin/(DECDPUNMAX+1);
+ }
+ dn->digits=decGetDigits(dn->lsu, up-dn->lsu);
+ return dn;
+ } // decNumberFromUInt32
+
+/* ------------------------------------------------------------------ */
+/* to-int32 -- conversion to Int or uInt */
+/* */
+/* dn is the decNumber to convert */
+/* set is the context for reporting errors */
+/* returns the converted decNumber, or 0 if Invalid is set */
+/* */
+/* Invalid is set if the decNumber does not have exponent==0 or if */
+/* it is a NaN, Infinite, or out-of-range. */
+/* ------------------------------------------------------------------ */
+Int decNumberToInt32(const decNumber *dn, decContext *set) {
+ #if DECCHECK
+ if (decCheckOperands(DECUNRESU, DECUNUSED, dn, set)) return 0;
+ #endif
+
+ // special or too many digits, or bad exponent
+ if (dn->bits&DECSPECIAL || dn->digits>10 || dn->exponent!=0) ; // bad
+ else { // is a finite integer with 10 or fewer digits
+ Int d; // work
+ const Unit *up; // ..
+ uInt hi=0, lo; // ..
+ up=dn->lsu; // -> lsu
+ lo=*up; // get 1 to 9 digits
+ #if DECDPUN>1 // split to higher
+ hi=lo/10;
+ lo=lo%10;
+ #endif
+ up++;
+ // collect remaining Units, if any, into hi
+ for (d=DECDPUN; d<dn->digits; up++, d+=DECDPUN) hi+=*up*powers[d-1];
+ // now low has the lsd, hi the remainder
+ if (hi>214748364 || (hi==214748364 && lo>7)) { // out of range?
+ // most-negative is a reprieve
+ if (dn->bits&DECNEG && hi==214748364 && lo==8) return 0x80000000;
+ // bad -- drop through
+ }
+ else { // in-range always
+ Int i=X10(hi)+lo;
+ if (dn->bits&DECNEG) return -i;
+ return i;
+ }
+ } // integer
+ decContextSetStatus(set, DEC_Invalid_operation); // [may not return]
+ return 0;
+ } // decNumberToInt32
+
+uInt decNumberToUInt32(const decNumber *dn, decContext *set) {
+ #if DECCHECK
+ if (decCheckOperands(DECUNRESU, DECUNUSED, dn, set)) return 0;
+ #endif
+ // special or too many digits, or bad exponent, or negative (<0)
+ if (dn->bits&DECSPECIAL || dn->digits>10 || dn->exponent!=0
+ || (dn->bits&DECNEG && !ISZERO(dn))); // bad
+ else { // is a finite integer with 10 or fewer digits
+ Int d; // work
+ const Unit *up; // ..
+ uInt hi=0, lo; // ..
+ up=dn->lsu; // -> lsu
+ lo=*up; // get 1 to 9 digits
+ #if DECDPUN>1 // split to higher
+ hi=lo/10;
+ lo=lo%10;
+ #endif
+ up++;
+ // collect remaining Units, if any, into hi
+ for (d=DECDPUN; d<dn->digits; up++, d+=DECDPUN) hi+=*up*powers[d-1];
+
+ // now low has the lsd, hi the remainder
+ if (hi>429496729 || (hi==429496729 && lo>5)) ; // no reprieve possible
+ else return X10(hi)+lo;
+ } // integer
+ decContextSetStatus(set, DEC_Invalid_operation); // [may not return]
+ return 0;
+ } // decNumberToUInt32
+
+/* ------------------------------------------------------------------ */
+/* to-scientific-string -- conversion to numeric string */
+/* to-engineering-string -- conversion to numeric string */
+/* */
+/* decNumberToString(dn, string); */
+/* decNumberToEngString(dn, string); */
+/* */
+/* dn is the decNumber to convert */
+/* string is the string where the result will be laid out */
+/* */
+/* string must be at least dn->digits+14 characters long */
+/* */
+/* No error is possible, and no status can be set. */
+/* ------------------------------------------------------------------ */
+char * decNumberToString(const decNumber *dn, char *string){
+ decToString(dn, string, 0);
+ return string;
+ } // DecNumberToString
+
+char * decNumberToEngString(const decNumber *dn, char *string){
+ decToString(dn, string, 1);
+ return string;
+ } // DecNumberToEngString
+
+/* ------------------------------------------------------------------ */
+/* to-number -- conversion from numeric string */
+/* */
+/* decNumberFromString -- convert string to decNumber */
+/* dn -- the number structure to fill */
+/* chars[] -- the string to convert ('\0' terminated) */
+/* set -- the context used for processing any error, */
+/* determining the maximum precision available */
+/* (set.digits), determining the maximum and minimum */
+/* exponent (set.emax and set.emin), determining if */
+/* extended values are allowed, and checking the */
+/* rounding mode if overflow occurs or rounding is */
+/* needed. */
+/* */
+/* The length of the coefficient and the size of the exponent are */
+/* checked by this routine, so the correct error (Underflow or */
+/* Overflow) can be reported or rounding applied, as necessary. */
+/* */
+/* If bad syntax is detected, the result will be a quiet NaN. */
+/* ------------------------------------------------------------------ */
+decNumber * decNumberFromString(decNumber *dn, const char chars[],
+ decContext *set) {
+ Int exponent=0; // working exponent [assume 0]
+ uByte bits=0; // working flags [assume +ve]
+ Unit *res; // where result will be built
+ Unit resbuff[SD2U(DECBUFFER+9)];// local buffer in case need temporary
+ // [+9 allows for ln() constants]
+ Unit *allocres=NULL; // -> allocated result, iff allocated
+ Int d=0; // count of digits found in decimal part
+ const char *dotchar=NULL; // where dot was found
+ const char *cfirst=chars; // -> first character of decimal part
+ const char *last=NULL; // -> last digit of decimal part
+ const char *c; // work
+ Unit *up; // ..
+ #if DECDPUN>1
+ Int cut, out; // ..
+ #endif
+ Int residue; // rounding residue
+ uInt status=0; // error code
+
+ #if DECCHECK
+ if (decCheckOperands(DECUNRESU, DECUNUSED, DECUNUSED, set))
+ return decNumberZero(dn);
+ #endif
+
+ do { // status & malloc protection
+ for (c=chars;; c++) { // -> input character
+ if (*c>='0' && *c<='9') { // test for Arabic digit
+ last=c;
+ d++; // count of real digits
+ continue; // still in decimal part
+ }
+ if (*c=='.' && dotchar==NULL) { // first '.'
+ dotchar=c; // record offset into decimal part
+ if (c==cfirst) cfirst++; // first digit must follow
+ continue;}
+ if (c==chars) { // first in string...
+ if (*c=='-') { // valid - sign
+ cfirst++;
+ bits=DECNEG;
+ continue;}
+ if (*c=='+') { // valid + sign
+ cfirst++;
+ continue;}
+ }
+ // *c is not a digit, or a valid +, -, or '.'
+ break;
+ } // c
+
+ if (last==NULL) { // no digits yet
+ status=DEC_Conversion_syntax;// assume the worst
+ if (*c=='\0') break; // and no more to come...
+ #if DECSUBSET
+ // if subset then infinities and NaNs are not allowed
+ if (!set->extended) break; // hopeless
+ #endif
+ // Infinities and NaNs are possible, here
+ if (dotchar!=NULL) break; // .. unless had a dot
+ decNumberZero(dn); // be optimistic
+ if (decBiStr(c, "infinity", "INFINITY")
+ || decBiStr(c, "inf", "INF")) {
+ dn->bits=bits | DECINF;
+ status=0; // is OK
+ break; // all done
+ }
+ // a NaN expected
+ // 2003.09.10 NaNs are now permitted to have a sign
+ dn->bits=bits | DECNAN; // assume simple NaN
+ if (*c=='s' || *c=='S') { // looks like an sNaN
+ c++;
+ dn->bits=bits | DECSNAN;
+ }
+ if (*c!='n' && *c!='N') break; // check caseless "NaN"
+ c++;
+ if (*c!='a' && *c!='A') break; // ..
+ c++;
+ if (*c!='n' && *c!='N') break; // ..
+ c++;
+ // now either nothing, or nnnn payload, expected
+ // -> start of integer and skip leading 0s [including plain 0]
+ for (cfirst=c; *cfirst=='0';) cfirst++;
+ if (*cfirst=='\0') { // "NaN" or "sNaN", maybe with all 0s
+ status=0; // it's good
+ break; // ..
+ }
+ // something other than 0s; setup last and d as usual [no dots]
+ for (c=cfirst;; c++, d++) {
+ if (*c<'0' || *c>'9') break; // test for Arabic digit
+ last=c;
+ }
+ if (*c!='\0') break; // not all digits
+ if (d>set->digits-1) {
+ // [NB: payload in a decNumber can be full length unless
+ // clamped, in which case can only be digits-1]
+ if (set->clamp) break;
+ if (d>set->digits) break;
+ } // too many digits?
+ // good; drop through to convert the integer to coefficient
+ status=0; // syntax is OK
+ bits=dn->bits; // for copy-back
+ } // last==NULL
+
+ else if (*c!='\0') { // more to process...
+ // had some digits; exponent is only valid sequence now
+ Flag nege; // 1=negative exponent
+ const char *firstexp; // -> first significant exponent digit
+ status=DEC_Conversion_syntax;// assume the worst
+ if (*c!='e' && *c!='E') break;
+ /* Found 'e' or 'E' -- now process explicit exponent */
+ // 1998.07.11: sign no longer required
+ nege=0;
+ c++; // to (possible) sign
+ if (*c=='-') {nege=1; c++;}
+ else if (*c=='+') c++;
+ if (*c=='\0') break;
+
+ for (; *c=='0' && *(c+1)!='\0';) c++; // strip insignificant zeros
+ firstexp=c; // save exponent digit place
+ for (; ;c++) {
+ if (*c<'0' || *c>'9') break; // not a digit
+ exponent=X10(exponent)+(Int)*c-(Int)'0';
+ } // c
+ // if not now on a '\0', *c must not be a digit
+ if (*c!='\0') break;
+
+ // (this next test must be after the syntax checks)
+ // if it was too long the exponent may have wrapped, so check
+ // carefully and set it to a certain overflow if wrap possible
+ if (c>=firstexp+9+1) {
+ if (c>firstexp+9+1 || *firstexp>'1') exponent=DECNUMMAXE*2;
+ // [up to 1999999999 is OK, for example 1E-1000000998]
+ }
+ if (nege) exponent=-exponent; // was negative
+ status=0; // is OK
+ } // stuff after digits
+
+ // Here when whole string has been inspected; syntax is good
+ // cfirst->first digit (never dot), last->last digit (ditto)
+
+ // strip leading zeros/dot [leave final 0 if all 0's]
+ if (*cfirst=='0') { // [cfirst has stepped over .]
+ for (c=cfirst; c<last; c++, cfirst++) {
+ if (*c=='.') continue; // ignore dots
+ if (*c!='0') break; // non-zero found
+ d--; // 0 stripped
+ } // c
+ #if DECSUBSET
+ // make a rapid exit for easy zeros if !extended
+ if (*cfirst=='0' && !set->extended) {
+ decNumberZero(dn); // clean result
+ break; // [could be return]
+ }
+ #endif
+ } // at least one leading 0
+
+ // Handle decimal point...
+ if (dotchar!=NULL && dotchar<last) // non-trailing '.' found?
+ exponent-=(last-dotchar); // adjust exponent
+ // [we can now ignore the .]
+
+ // OK, the digits string is good. Assemble in the decNumber, or in
+ // a temporary units array if rounding is needed
+ if (d<=set->digits) res=dn->lsu; // fits into supplied decNumber
+ else { // rounding needed
+ Int needbytes=D2U(d)*sizeof(Unit);// bytes needed
+ res=resbuff; // assume use local buffer
+ if (needbytes>(Int)sizeof(resbuff)) { // too big for local
+ allocres=(Unit *)malloc(needbytes);
+ if (allocres==NULL) {status|=DEC_Insufficient_storage; break;}
+ res=allocres;
+ }
+ }
+ // res now -> number lsu, buffer, or allocated storage for Unit array
+
+ // Place the coefficient into the selected Unit array
+ // [this is often 70% of the cost of this function when DECDPUN>1]
+ #if DECDPUN>1
+ out=0; // accumulator
+ up=res+D2U(d)-1; // -> msu
+ cut=d-(up-res)*DECDPUN; // digits in top unit
+ for (c=cfirst;; c++) { // along the digits
+ if (*c=='.') continue; // ignore '.' [don't decrement cut]
+ out=X10(out)+(Int)*c-(Int)'0';
+ if (c==last) break; // done [never get to trailing '.']
+ cut--;
+ if (cut>0) continue; // more for this unit
+ *up=(Unit)out; // write unit
+ up--; // prepare for unit below..
+ cut=DECDPUN; // ..
+ out=0; // ..
+ } // c
+ *up=(Unit)out; // write lsu
+
+ #else
+ // DECDPUN==1
+ up=res; // -> lsu
+ for (c=last; c>=cfirst; c--) { // over each character, from least
+ if (*c=='.') continue; // ignore . [don't step up]
+ *up=(Unit)((Int)*c-(Int)'0');
+ up++;
+ } // c
+ #endif
+
+ dn->bits=bits;
+ dn->exponent=exponent;
+ dn->digits=d;
+
+ // if not in number (too long) shorten into the number
+ if (d>set->digits) {
+ residue=0;
+ decSetCoeff(dn, set, res, d, &residue, &status);
+ // always check for overflow or subnormal and round as needed
+ decFinalize(dn, set, &residue, &status);
+ }
+ else { // no rounding, but may still have overflow or subnormal
+ // [these tests are just for performance; finalize repeats them]
+ if ((dn->exponent-1<set->emin-dn->digits)
+ || (dn->exponent-1>set->emax-set->digits)) {
+ residue=0;
+ decFinalize(dn, set, &residue, &status);
+ }
+ }
+ // decNumberShow(dn);
+ } while(0); // [for break]
+
+ if (allocres!=NULL) free(allocres); // drop any storage used
+ if (status!=0) decStatus(dn, status, set);
+ return dn;
+ } /* decNumberFromString */
+
+/* ================================================================== */
+/* Operators */
+/* ================================================================== */
+
+/* ------------------------------------------------------------------ */
+/* decNumberAbs -- absolute value operator */
+/* */
+/* This computes C = abs(A) */
+/* */
+/* res is C, the result. C may be A */
+/* rhs is A */
+/* set is the context */
+/* */
+/* See also decNumberCopyAbs for a quiet bitwise version of this. */
+/* C must have space for set->digits digits. */
+/* ------------------------------------------------------------------ */
+/* This has the same effect as decNumberPlus unless A is negative, */
+/* in which case it has the same effect as decNumberMinus. */
+/* ------------------------------------------------------------------ */
+decNumber * decNumberAbs(decNumber *res, const decNumber *rhs,
+ decContext *set) {
+ decNumber dzero; // for 0
+ uInt status=0; // accumulator
+
+ #if DECCHECK
+ if (decCheckOperands(res, DECUNUSED, rhs, set)) return res;
+ #endif
+
+ decNumberZero(&dzero); // set 0
+ dzero.exponent=rhs->exponent; // [no coefficient expansion]
+ decAddOp(res, &dzero, rhs, set, (uByte)(rhs->bits & DECNEG), &status);
+ if (status!=0) decStatus(res, status, set);
+ #if DECCHECK
+ decCheckInexact(res, set);
+ #endif
+ return res;
+ } // decNumberAbs
+
+/* ------------------------------------------------------------------ */
+/* decNumberAdd -- add two Numbers */
+/* */
+/* This computes C = A + B */
+/* */
+/* res is C, the result. C may be A and/or B (e.g., X=X+X) */
+/* lhs is A */
+/* rhs is B */
+/* set is the context */
+/* */
+/* C must have space for set->digits digits. */
+/* ------------------------------------------------------------------ */
+/* This just calls the routine shared with Subtract */
+decNumber * decNumberAdd(decNumber *res, const decNumber *lhs,
+ const decNumber *rhs, decContext *set) {
+ uInt status=0; // accumulator
+ decAddOp(res, lhs, rhs, set, 0, &status);
+ if (status!=0) decStatus(res, status, set);
+ #if DECCHECK
+ decCheckInexact(res, set);
+ #endif
+ return res;
+ } // decNumberAdd
+
+/* ------------------------------------------------------------------ */
+/* decNumberAnd -- AND two Numbers, digitwise */
+/* */
+/* This computes C = A & B */
+/* */
+/* res is C, the result. C may be A and/or B (e.g., X=X&X) */
+/* lhs is A */
+/* rhs is B */
+/* set is the context (used for result length and error report) */
+/* */
+/* C must have space for set->digits digits. */
+/* */
+/* Logical function restrictions apply (see above); a NaN is */
+/* returned with Invalid_operation if a restriction is violated. */
+/* ------------------------------------------------------------------ */
+decNumber * decNumberAnd(decNumber *res, const decNumber *lhs,
+ const decNumber *rhs, decContext *set) {
+ const Unit *ua, *ub; // -> operands
+ const Unit *msua, *msub; // -> operand msus
+ Unit *uc, *msuc; // -> result and its msu
+ Int msudigs; // digits in res msu
+ #if DECCHECK
+ if (decCheckOperands(res, lhs, rhs, set)) return res;
+ #endif
+
+ if (lhs->exponent!=0 || decNumberIsSpecial(lhs) || decNumberIsNegative(lhs)
+ || rhs->exponent!=0 || decNumberIsSpecial(rhs) || decNumberIsNegative(rhs)) {
+ decStatus(res, DEC_Invalid_operation, set);
+ return res;
+ }
+
+ // operands are valid
+ ua=lhs->lsu; // bottom-up
+ ub=rhs->lsu; // ..
+ uc=res->lsu; // ..
+ msua=ua+D2U(lhs->digits)-1; // -> msu of lhs
+ msub=ub+D2U(rhs->digits)-1; // -> msu of rhs
+ msuc=uc+D2U(set->digits)-1; // -> msu of result
+ msudigs=MSUDIGITS(set->digits); // [faster than remainder]
+ for (; uc<=msuc; ua++, ub++, uc++) { // Unit loop
+ Unit a, b; // extract units
+ if (ua>msua) a=0;
+ else a=*ua;
+ if (ub>msub) b=0;
+ else b=*ub;
+ *uc=0; // can now write back
+ if (a|b) { // maybe 1 bits to examine
+ Int i, j;
+ *uc=0; // can now write back
+ // This loop could be unrolled and/or use BIN2BCD tables
+ for (i=0; i<DECDPUN; i++) {
+ if (a&b&1) *uc=*uc+(Unit)powers[i]; // effect AND
+ j=a%10;
+ a=a/10;
+ j|=b%10;
+ b=b/10;
+ if (j>1) {
+ decStatus(res, DEC_Invalid_operation, set);
+ return res;
+ }
+ if (uc==msuc && i==msudigs-1) break; // just did final digit
+ } // each digit
+ } // both OK
+ } // each unit
+ // [here uc-1 is the msu of the result]
+ res->digits=decGetDigits(res->lsu, uc-res->lsu);
+ res->exponent=0; // integer
+ res->bits=0; // sign=0
+ return res; // [no status to set]
+ } // decNumberAnd
+
+/* ------------------------------------------------------------------ */
+/* decNumberCompare -- compare two Numbers */
+/* */
+/* This computes C = A ? B */
+/* */
+/* res is C, the result. C may be A and/or B (e.g., X=X?X) */
+/* lhs is A */
+/* rhs is B */
+/* set is the context */
+/* */
+/* C must have space for one digit (or NaN). */
+/* ------------------------------------------------------------------ */
+decNumber * decNumberCompare(decNumber *res, const decNumber *lhs,
+ const decNumber *rhs, decContext *set) {
+ uInt status=0; // accumulator
+ decCompareOp(res, lhs, rhs, set, COMPARE, &status);
+ if (status!=0) decStatus(res, status, set);
+ return res;
+ } // decNumberCompare
+
+/* ------------------------------------------------------------------ */
+/* decNumberCompareSignal -- compare, signalling on all NaNs */
+/* */
+/* This computes C = A ? B */
+/* */
+/* res is C, the result. C may be A and/or B (e.g., X=X?X) */
+/* lhs is A */
+/* rhs is B */
+/* set is the context */
+/* */
+/* C must have space for one digit (or NaN). */
+/* ------------------------------------------------------------------ */
+decNumber * decNumberCompareSignal(decNumber *res, const decNumber *lhs,
+ const decNumber *rhs, decContext *set) {
+ uInt status=0; // accumulator
+ decCompareOp(res, lhs, rhs, set, COMPSIG, &status);
+ if (status!=0) decStatus(res, status, set);
+ return res;
+ } // decNumberCompareSignal
+
+/* ------------------------------------------------------------------ */
+/* decNumberCompareTotal -- compare two Numbers, using total ordering */
+/* */
+/* This computes C = A ? B, under total ordering */
+/* */
+/* res is C, the result. C may be A and/or B (e.g., X=X?X) */
+/* lhs is A */
+/* rhs is B */
+/* set is the context */
+/* */
+/* C must have space for one digit; the result will always be one of */
+/* -1, 0, or 1. */
+/* ------------------------------------------------------------------ */
+decNumber * decNumberCompareTotal(decNumber *res, const decNumber *lhs,
+ const decNumber *rhs, decContext *set) {
+ uInt status=0; // accumulator
+ decCompareOp(res, lhs, rhs, set, COMPTOTAL, &status);
+ if (status!=0) decStatus(res, status, set);
+ return res;
+ } // decNumberCompareTotal
+
+/* ------------------------------------------------------------------ */
+/* decNumberCompareTotalMag -- compare, total ordering of magnitudes */
+/* */
+/* This computes C = |A| ? |B|, under total ordering */
+/* */
+/* res is C, the result. C may be A and/or B (e.g., X=X?X) */
+/* lhs is A */
+/* rhs is B */
+/* set is the context */
+/* */
+/* C must have space for one digit; the result will always be one of */
+/* -1, 0, or 1. */
+/* ------------------------------------------------------------------ */
+decNumber * decNumberCompareTotalMag(decNumber *res, const decNumber *lhs,
+ const decNumber *rhs, decContext *set) {
+ uInt status=0; // accumulator
+ uInt needbytes; // for space calculations
+ decNumber bufa[D2N(DECBUFFER+1)];// +1 in case DECBUFFER=0
+ decNumber *allocbufa=NULL; // -> allocated bufa, iff allocated
+ decNumber bufb[D2N(DECBUFFER+1)];
+ decNumber *allocbufb=NULL; // -> allocated bufb, iff allocated
+ decNumber *a, *b; // temporary pointers
+
+ #if DECCHECK
+ if (decCheckOperands(res, lhs, rhs, set)) return res;
+ #endif
+
+ do { // protect allocated storage
+ // if either is negative, take a copy and absolute
+ if (decNumberIsNegative(lhs)) { // lhs<0
+ a=bufa;
+ needbytes=sizeof(decNumber)+(D2U(lhs->digits)-1)*sizeof(Unit);
+ if (needbytes>sizeof(bufa)) { // need malloc space
+ allocbufa=(decNumber *)malloc(needbytes);
+ if (allocbufa==NULL) { // hopeless -- abandon
+ status|=DEC_Insufficient_storage;
+ break;}
+ a=allocbufa; // use the allocated space
+ }
+ decNumberCopy(a, lhs); // copy content
+ a->bits&=~DECNEG; // .. and clear the sign
+ lhs=a; // use copy from here on
+ }
+ if (decNumberIsNegative(rhs)) { // rhs<0
+ b=bufb;
+ needbytes=sizeof(decNumber)+(D2U(rhs->digits)-1)*sizeof(Unit);
+ if (needbytes>sizeof(bufb)) { // need malloc space
+ allocbufb=(decNumber *)malloc(needbytes);
+ if (allocbufb==NULL) { // hopeless -- abandon
+ status|=DEC_Insufficient_storage;
+ break;}
+ b=allocbufb; // use the allocated space
+ }
+ decNumberCopy(b, rhs); // copy content
+ b->bits&=~DECNEG; // .. and clear the sign
+ rhs=b; // use copy from here on
+ }
+ decCompareOp(res, lhs, rhs, set, COMPTOTAL, &status);
+ } while(0); // end protected
+
+ if (allocbufa!=NULL) free(allocbufa); // drop any storage used
+ if (allocbufb!=NULL) free(allocbufb); // ..
+ if (status!=0) decStatus(res, status, set);
+ return res;
+ } // decNumberCompareTotalMag
+
+/* ------------------------------------------------------------------ */
+/* decNumberDivide -- divide one number by another */
+/* */
+/* This computes C = A / B */
+/* */
+/* res is C, the result. C may be A and/or B (e.g., X=X/X) */
+/* lhs is A */
+/* rhs is B */
+/* set is the context */
+/* */
+/* C must have space for set->digits digits. */
+/* ------------------------------------------------------------------ */
+decNumber * decNumberDivide(decNumber *res, const decNumber *lhs,
+ const decNumber *rhs, decContext *set) {
+ uInt status=0; // accumulator
+ decDivideOp(res, lhs, rhs, set, DIVIDE, &status);
+ if (status!=0) decStatus(res, status, set);
+ #if DECCHECK
+ decCheckInexact(res, set);
+ #endif
+ return res;
+ } // decNumberDivide
+
+/* ------------------------------------------------------------------ */
+/* decNumberDivideInteger -- divide and return integer quotient */
+/* */
+/* This computes C = A # B, where # is the integer divide operator */
+/* */
+/* res is C, the result. C may be A and/or B (e.g., X=X#X) */
+/* lhs is A */
+/* rhs is B */
+/* set is the context */
+/* */
+/* C must have space for set->digits digits. */
+/* ------------------------------------------------------------------ */
+decNumber * decNumberDivideInteger(decNumber *res, const decNumber *lhs,
+ const decNumber *rhs, decContext *set) {
+ uInt status=0; // accumulator
+ decDivideOp(res, lhs, rhs, set, DIVIDEINT, &status);
+ if (status!=0) decStatus(res, status, set);
+ return res;
+ } // decNumberDivideInteger
+
+/* ------------------------------------------------------------------ */
+/* decNumberExp -- exponentiation */
+/* */
+/* This computes C = exp(A) */
+/* */
+/* res is C, the result. C may be A */
+/* rhs is A */
+/* set is the context; note that rounding mode has no effect */
+/* */
+/* C must have space for set->digits digits. */
+/* */
+/* Mathematical function restrictions apply (see above); a NaN is */
+/* returned with Invalid_operation if a restriction is violated. */
+/* */
+/* Finite results will always be full precision and Inexact, except */
+/* when A is a zero or -Infinity (giving 1 or 0 respectively). */
+/* */
+/* An Inexact result is rounded using DEC_ROUND_HALF_EVEN; it will */
+/* almost always be correctly rounded, but may be up to 1 ulp in */
+/* error in rare cases. */
+/* ------------------------------------------------------------------ */
+/* This is a wrapper for decExpOp which can handle the slightly wider */
+/* (double) range needed by Ln (which has to be able to calculate */
+/* exp(-a) where a can be the tiniest number (Ntiny). */
+/* ------------------------------------------------------------------ */
+decNumber * decNumberExp(decNumber *res, const decNumber *rhs,
+ decContext *set) {
+ uInt status=0; // accumulator
+ #if DECSUBSET
+ decNumber *allocrhs=NULL; // non-NULL if rounded rhs allocated
+ #endif
+
+ #if DECCHECK
+ if (decCheckOperands(res, DECUNUSED, rhs, set)) return res;
+ #endif
+
+ // Check restrictions; these restrictions ensure that if h=8 (see
+ // decExpOp) then the result will either overflow or underflow to 0.
+ // Other math functions restrict the input range, too, for inverses.
+ // If not violated then carry out the operation.
+ if (!decCheckMath(rhs, set, &status)) do { // protect allocation
+ #if DECSUBSET
+ if (!set->extended) {
+ // reduce operand and set lostDigits status, as needed
+ if (rhs->digits>set->digits) {
+ allocrhs=decRoundOperand(rhs, set, &status);
+ if (allocrhs==NULL) break;
+ rhs=allocrhs;
+ }
+ }
+ #endif
+ decExpOp(res, rhs, set, &status);
+ } while(0); // end protected
+
+ #if DECSUBSET
+ if (allocrhs !=NULL) free(allocrhs); // drop any storage used
+ #endif
+ // apply significant status
+ if (status!=0) decStatus(res, status, set);
+ #if DECCHECK
+ decCheckInexact(res, set);
+ #endif
+ return res;
+ } // decNumberExp
+
+/* ------------------------------------------------------------------ */
+/* decNumberFMA -- fused multiply add */
+/* */
+/* This computes D = (A * B) + C with only one rounding */
+/* */
+/* res is D, the result. D may be A or B or C (e.g., X=FMA(X,X,X)) */
+/* lhs is A */
+/* rhs is B */
+/* fhs is C [far hand side] */
+/* set is the context */
+/* */
+/* Mathematical function restrictions apply (see above); a NaN is */
+/* returned with Invalid_operation if a restriction is violated. */
+/* */
+/* C must have space for set->digits digits. */
+/* ------------------------------------------------------------------ */
+decNumber * decNumberFMA(decNumber *res, const decNumber *lhs,
+ const decNumber *rhs, const decNumber *fhs,
+ decContext *set) {
+ uInt status=0; // accumulator
+ decContext dcmul; // context for the multiplication
+ uInt needbytes; // for space calculations
+ decNumber bufa[D2N(DECBUFFER*2+1)];
+ decNumber *allocbufa=NULL; // -> allocated bufa, iff allocated
+ decNumber *acc; // accumulator pointer
+ decNumber dzero; // work
+
+ #if DECCHECK
+ if (decCheckOperands(res, lhs, rhs, set)) return res;
+ if (decCheckOperands(res, fhs, DECUNUSED, set)) return res;
+ #endif
+
+ do { // protect allocated storage
+ #if DECSUBSET
+ if (!set->extended) { // [undefined if subset]
+ status|=DEC_Invalid_operation;
+ break;}
+ #endif
+ // Check math restrictions [these ensure no overflow or underflow]
+ if ((!decNumberIsSpecial(lhs) && decCheckMath(lhs, set, &status))
+ || (!decNumberIsSpecial(rhs) && decCheckMath(rhs, set, &status))
+ || (!decNumberIsSpecial(fhs) && decCheckMath(fhs, set, &status))) break;
+ // set up context for multiply
+ dcmul=*set;
+ dcmul.digits=lhs->digits+rhs->digits; // just enough
+ // [The above may be an over-estimate for subset arithmetic, but that's OK]
+ dcmul.emax=DEC_MAX_EMAX; // effectively unbounded ..
+ dcmul.emin=DEC_MIN_EMIN; // [thanks to Math restrictions]
+ // set up decNumber space to receive the result of the multiply
+ acc=bufa; // may fit
+ needbytes=sizeof(decNumber)+(D2U(dcmul.digits)-1)*sizeof(Unit);
+ if (needbytes>sizeof(bufa)) { // need malloc space
+ allocbufa=(decNumber *)malloc(needbytes);
+ if (allocbufa==NULL) { // hopeless -- abandon
+ status|=DEC_Insufficient_storage;
+ break;}
+ acc=allocbufa; // use the allocated space
+ }
+ // multiply with extended range and necessary precision
+ //printf("emin=%ld\n", dcmul.emin);
+ decMultiplyOp(acc, lhs, rhs, &dcmul, &status);
+ // Only Invalid operation (from sNaN or Inf * 0) is possible in
+ // status; if either is seen than ignore fhs (in case it is
+ // another sNaN) and set acc to NaN unless we had an sNaN
+ // [decMultiplyOp leaves that to caller]
+ // Note sNaN has to go through addOp to shorten payload if
+ // necessary
+ if ((status&DEC_Invalid_operation)!=0) {
+ if (!(status&DEC_sNaN)) { // but be true invalid
+ decNumberZero(res); // acc not yet set
+ res->bits=DECNAN;
+ break;
+ }
+ decNumberZero(&dzero); // make 0 (any non-NaN would do)
+ fhs=&dzero; // use that
+ }
+ #if DECCHECK
+ else { // multiply was OK
+ if (status!=0) printf("Status=%08lx after FMA multiply\n", (LI)status);
+ }
+ #endif
+ // add the third operand and result -> res, and all is done
+ decAddOp(res, acc, fhs, set, 0, &status);
+ } while(0); // end protected
+
+ if (allocbufa!=NULL) free(allocbufa); // drop any storage used
+ if (status!=0) decStatus(res, status, set);
+ #if DECCHECK
+ decCheckInexact(res, set);
+ #endif
+ return res;
+ } // decNumberFMA
+
+/* ------------------------------------------------------------------ */
+/* decNumberInvert -- invert a Number, digitwise */
+/* */
+/* This computes C = ~A */
+/* */
+/* res is C, the result. C may be A (e.g., X=~X) */
+/* rhs is A */
+/* set is the context (used for result length and error report) */
+/* */
+/* C must have space for set->digits digits. */
+/* */
+/* Logical function restrictions apply (see above); a NaN is */
+/* returned with Invalid_operation if a restriction is violated. */
+/* ------------------------------------------------------------------ */
+decNumber * decNumberInvert(decNumber *res, const decNumber *rhs,
+ decContext *set) {
+ const Unit *ua, *msua; // -> operand and its msu
+ Unit *uc, *msuc; // -> result and its msu
+ Int msudigs; // digits in res msu
+ #if DECCHECK
+ if (decCheckOperands(res, DECUNUSED, rhs, set)) return res;
+ #endif
+
+ if (rhs->exponent!=0 || decNumberIsSpecial(rhs) || decNumberIsNegative(rhs)) {
+ decStatus(res, DEC_Invalid_operation, set);
+ return res;
+ }
+ // operand is valid
+ ua=rhs->lsu; // bottom-up
+ uc=res->lsu; // ..
+ msua=ua+D2U(rhs->digits)-1; // -> msu of rhs
+ msuc=uc+D2U(set->digits)-1; // -> msu of result
+ msudigs=MSUDIGITS(set->digits); // [faster than remainder]
+ for (; uc<=msuc; ua++, uc++) { // Unit loop
+ Unit a; // extract unit
+ Int i, j; // work
+ if (ua>msua) a=0;
+ else a=*ua;
+ *uc=0; // can now write back
+ // always need to examine all bits in rhs
+ // This loop could be unrolled and/or use BIN2BCD tables
+ for (i=0; i<DECDPUN; i++) {
+ if ((~a)&1) *uc=*uc+(Unit)powers[i]; // effect INVERT
+ j=a%10;
+ a=a/10;
+ if (j>1) {
+ decStatus(res, DEC_Invalid_operation, set);
+ return res;
+ }
+ if (uc==msuc && i==msudigs-1) break; // just did final digit
+ } // each digit
+ } // each unit
+ // [here uc-1 is the msu of the result]
+ res->digits=decGetDigits(res->lsu, uc-res->lsu);
+ res->exponent=0; // integer
+ res->bits=0; // sign=0
+ return res; // [no status to set]
+ } // decNumberInvert
+
+/* ------------------------------------------------------------------ */
+/* decNumberLn -- natural logarithm */
+/* */
+/* This computes C = ln(A) */
+/* */
+/* res is C, the result. C may be A */
+/* rhs is A */
+/* set is the context; note that rounding mode has no effect */
+/* */
+/* C must have space for set->digits digits. */
+/* */
+/* Notable cases: */
+/* A<0 -> Invalid */
+/* A=0 -> -Infinity (Exact) */
+/* A=+Infinity -> +Infinity (Exact) */
+/* A=1 exactly -> 0 (Exact) */
+/* */
+/* Mathematical function restrictions apply (see above); a NaN is */
+/* returned with Invalid_operation if a restriction is violated. */
+/* */
+/* An Inexact result is rounded using DEC_ROUND_HALF_EVEN; it will */
+/* almost always be correctly rounded, but may be up to 1 ulp in */
+/* error in rare cases. */
+/* ------------------------------------------------------------------ */
+/* This is a wrapper for decLnOp which can handle the slightly wider */
+/* (+11) range needed by Ln, Log10, etc. (which may have to be able */
+/* to calculate at p+e+2). */
+/* ------------------------------------------------------------------ */
+decNumber * decNumberLn(decNumber *res, const decNumber *rhs,
+ decContext *set) {
+ uInt status=0; // accumulator
+ #if DECSUBSET
+ decNumber *allocrhs=NULL; // non-NULL if rounded rhs allocated
+ #endif
+
+ #if DECCHECK
+ if (decCheckOperands(res, DECUNUSED, rhs, set)) return res;
+ #endif
+
+ // Check restrictions; this is a math function; if not violated
+ // then carry out the operation.
+ if (!decCheckMath(rhs, set, &status)) do { // protect allocation
+ #if DECSUBSET
+ if (!set->extended) {
+ // reduce operand and set lostDigits status, as needed
+ if (rhs->digits>set->digits) {
+ allocrhs=decRoundOperand(rhs, set, &status);
+ if (allocrhs==NULL) break;
+ rhs=allocrhs;
+ }
+ // special check in subset for rhs=0
+ if (ISZERO(rhs)) { // +/- zeros -> error
+ status|=DEC_Invalid_operation;
+ break;}
+ } // extended=0
+ #endif
+ decLnOp(res, rhs, set, &status);
+ } while(0); // end protected
+
+ #if DECSUBSET
+ if (allocrhs !=NULL) free(allocrhs); // drop any storage used
+ #endif
+ // apply significant status
+ if (status!=0) decStatus(res, status, set);
+ #if DECCHECK
+ decCheckInexact(res, set);
+ #endif
+ return res;
+ } // decNumberLn
+
+/* ------------------------------------------------------------------ */
+/* decNumberLogB - get adjusted exponent, by 754 rules */
+/* */
+/* This computes C = adjustedexponent(A) */
+/* */
+/* res is C, the result. C may be A */
+/* rhs is A */
+/* set is the context, used only for digits and status */
+/* */
+/* For an unrounded result, digits may need to be 10 (A might have */
+/* 10**9 digits and an exponent of +999999999, or one digit and an */
+/* exponent of -1999999999). */
+/* */
+/* This returns the adjusted exponent of A after (in theory) padding */
+/* with zeros on the right to set->digits digits while keeping the */
+/* same value. The exponent is not limited by emin/emax. */
+/* */
+/* Notable cases: */
+/* A<0 -> Use |A| */
+/* A=0 -> -Infinity (Division by zero) */
+/* A=Infinite -> +Infinity (Exact) */
+/* A=1 exactly -> 0 (Exact) */
+/* NaNs are propagated as usual */
+/* ------------------------------------------------------------------ */
+decNumber * decNumberLogB(decNumber *res, const decNumber *rhs,
+ decContext *set) {
+ uInt status=0; // accumulator
+
+ #if DECCHECK
+ if (decCheckOperands(res, DECUNUSED, rhs, set)) return res;
+ #endif
+
+ // NaNs as usual; Infinities return +Infinity; 0->oops
+ if (decNumberIsNaN(rhs)) decNaNs(res, rhs, NULL, set, &status);
+ else if (decNumberIsInfinite(rhs)) decNumberCopyAbs(res, rhs);
+ else if (decNumberIsZero(rhs)) {
+ decNumberZero(res); // prepare for Infinity
+ res->bits=DECNEG|DECINF; // -Infinity
+ status|=DEC_Division_by_zero; // as per 754
+ }
+ else { // finite non-zero
+ Int ae=rhs->exponent+rhs->digits-1; // adjusted exponent
+ if (set->digits>=10) decNumberFromInt32(res, ae); // lay it out
+ else {
+ decNumber buft[D2N(10)]; // temporary number
+ decNumber *t=buft; // ..
+ decNumberFromInt32(t, ae); // lay it out
+ decNumberPlus(res, t, set); // round as necessary
+ }
+ }
+
+ if (status!=0) decStatus(res, status, set);
+ return res;
+ } // decNumberLogB
+
+/* ------------------------------------------------------------------ */
+/* decNumberLog10 -- logarithm in base 10 */
+/* */
+/* This computes C = log10(A) */
+/* */
+/* res is C, the result. C may be A */
+/* rhs is A */
+/* set is the context; note that rounding mode has no effect */
+/* */
+/* C must have space for set->digits digits. */
+/* */
+/* Notable cases: */
+/* A<0 -> Invalid */
+/* A=0 -> -Infinity (Exact) */
+/* A=+Infinity -> +Infinity (Exact) */
+/* A=10**n (if n is an integer) -> n (Exact) */
+/* */
+/* Mathematical function restrictions apply (see above); a NaN is */
+/* returned with Invalid_operation if a restriction is violated. */
+/* */
+/* An Inexact result is rounded using DEC_ROUND_HALF_EVEN; it will */
+/* almost always be correctly rounded, but may be up to 1 ulp in */
+/* error in rare cases. */
+/* ------------------------------------------------------------------ */
+/* This calculates ln(A)/ln(10) using appropriate precision. For */
+/* ln(A) this is the max(p, rhs->digits + t) + 3, where p is the */
+/* requested digits and t is the number of digits in the exponent */
+/* (maximum 6). For ln(10) it is p + 3; this is often handled by the */
+/* fastpath in decLnOp. The final division is done to the requested */
+/* precision. */
+/* ------------------------------------------------------------------ */
+decNumber * decNumberLog10(decNumber *res, const decNumber *rhs,
+ decContext *set) {
+ uInt status=0, ignore=0; // status accumulators
+ uInt needbytes; // for space calculations
+ Int p; // working precision
+ Int t; // digits in exponent of A
+
+ // buffers for a and b working decimals
+ // (adjustment calculator, same size)
+ decNumber bufa[D2N(DECBUFFER+2)];
+ decNumber *allocbufa=NULL; // -> allocated bufa, iff allocated
+ decNumber *a=bufa; // temporary a
+ decNumber bufb[D2N(DECBUFFER+2)];
+ decNumber *allocbufb=NULL; // -> allocated bufb, iff allocated
+ decNumber *b=bufb; // temporary b
+ decNumber bufw[D2N(10)]; // working 2-10 digit number
+ decNumber *w=bufw; // ..
+ #if DECSUBSET
+ decNumber *allocrhs=NULL; // non-NULL if rounded rhs allocated
+ #endif
+
+ decContext aset; // working context
+
+ #if DECCHECK
+ if (decCheckOperands(res, DECUNUSED, rhs, set)) return res;
+ #endif
+
+ // Check restrictions; this is a math function; if not violated
+ // then carry out the operation.
+ if (!decCheckMath(rhs, set, &status)) do { // protect malloc
+ #if DECSUBSET
+ if (!set->extended) {
+ // reduce operand and set lostDigits status, as needed
+ if (rhs->digits>set->digits) {
+ allocrhs=decRoundOperand(rhs, set, &status);
+ if (allocrhs==NULL) break;
+ rhs=allocrhs;
+ }
+ // special check in subset for rhs=0
+ if (ISZERO(rhs)) { // +/- zeros -> error
+ status|=DEC_Invalid_operation;
+ break;}
+ } // extended=0
+ #endif
+
+ decContextDefault(&aset, DEC_INIT_DECIMAL64); // clean context
+
+ // handle exact powers of 10; only check if +ve finite
+ if (!(rhs->bits&(DECNEG|DECSPECIAL)) && !ISZERO(rhs)) {
+ Int residue=0; // (no residue)
+ uInt copystat=0; // clean status
+
+ // round to a single digit...
+ aset.digits=1;
+ decCopyFit(w, rhs, &aset, &residue, &copystat); // copy & shorten
+ // if exact and the digit is 1, rhs is a power of 10
+ if (!(copystat&DEC_Inexact) && w->lsu[0]==1) {
+ // the exponent, conveniently, is the power of 10; making
+ // this the result needs a little care as it might not fit,
+ // so first convert it into the working number, and then move
+ // to res
+ decNumberFromInt32(w, w->exponent);
+ residue=0;
+ decCopyFit(res, w, set, &residue, &status); // copy & round
+ decFinish(res, set, &residue, &status); // cleanup/set flags
+ break;
+ } // not a power of 10
+ } // not a candidate for exact
+
+ // simplify the information-content calculation to use 'total
+ // number of digits in a, including exponent' as compared to the
+ // requested digits, as increasing this will only rarely cost an
+ // iteration in ln(a) anyway
+ t=6; // it can never be >6
+
+ // allocate space when needed...
+ p=(rhs->digits+t>set->digits?rhs->digits+t:set->digits)+3;
+ needbytes=sizeof(decNumber)+(D2U(p)-1)*sizeof(Unit);
+ if (needbytes>sizeof(bufa)) { // need malloc space
+ allocbufa=(decNumber *)malloc(needbytes);
+ if (allocbufa==NULL) { // hopeless -- abandon
+ status|=DEC_Insufficient_storage;
+ break;}
+ a=allocbufa; // use the allocated space
+ }
+ aset.digits=p; // as calculated
+ aset.emax=DEC_MAX_MATH; // usual bounds
+ aset.emin=-DEC_MAX_MATH; // ..
+ aset.clamp=0; // and no concrete format
+ decLnOp(a, rhs, &aset, &status); // a=ln(rhs)
+
+ // skip the division if the result so far is infinite, NaN, or
+ // zero, or there was an error; note NaN from sNaN needs copy
+ if (status&DEC_NaNs && !(status&DEC_sNaN)) break;
+ if (a->bits&DECSPECIAL || ISZERO(a)) {
+ decNumberCopy(res, a); // [will fit]
+ break;}
+
+ // for ln(10) an extra 3 digits of precision are needed
+ p=set->digits+3;
+ needbytes=sizeof(decNumber)+(D2U(p)-1)*sizeof(Unit);
+ if (needbytes>sizeof(bufb)) { // need malloc space
+ allocbufb=(decNumber *)malloc(needbytes);
+ if (allocbufb==NULL) { // hopeless -- abandon
+ status|=DEC_Insufficient_storage;
+ break;}
+ b=allocbufb; // use the allocated space
+ }
+ decNumberZero(w); // set up 10...
+ #if DECDPUN==1
+ w->lsu[1]=1; w->lsu[0]=0; // ..
+ #else
+ w->lsu[0]=10; // ..
+ #endif
+ w->digits=2; // ..
+
+ aset.digits=p;
+ decLnOp(b, w, &aset, &ignore); // b=ln(10)
+
+ aset.digits=set->digits; // for final divide
+ decDivideOp(res, a, b, &aset, DIVIDE, &status); // into result
+ } while(0); // [for break]
+
+ if (allocbufa!=NULL) free(allocbufa); // drop any storage used
+ if (allocbufb!=NULL) free(allocbufb); // ..
+ #if DECSUBSET
+ if (allocrhs !=NULL) free(allocrhs); // ..
+ #endif
+ // apply significant status
+ if (status!=0) decStatus(res, status, set);
+ #if DECCHECK
+ decCheckInexact(res, set);
+ #endif
+ return res;
+ } // decNumberLog10
+
+/* ------------------------------------------------------------------ */
+/* decNumberMax -- compare two Numbers and return the maximum */
+/* */
+/* This computes C = A ? B, returning the maximum by 754 rules */
+/* */
+/* res is C, the result. C may be A and/or B (e.g., X=X?X) */
+/* lhs is A */
+/* rhs is B */
+/* set is the context */
+/* */
+/* C must have space for set->digits digits. */
+/* ------------------------------------------------------------------ */
+decNumber * decNumberMax(decNumber *res, const decNumber *lhs,
+ const decNumber *rhs, decContext *set) {
+ uInt status=0; // accumulator
+ decCompareOp(res, lhs, rhs, set, COMPMAX, &status);
+ if (status!=0) decStatus(res, status, set);
+ #if DECCHECK
+ decCheckInexact(res, set);
+ #endif
+ return res;
+ } // decNumberMax
+
+/* ------------------------------------------------------------------ */
+/* decNumberMaxMag -- compare and return the maximum by magnitude */
+/* */
+/* This computes C = A ? B, returning the maximum by 754 rules */
+/* */
+/* res is C, the result. C may be A and/or B (e.g., X=X?X) */
+/* lhs is A */
+/* rhs is B */
+/* set is the context */
+/* */
+/* C must have space for set->digits digits. */
+/* ------------------------------------------------------------------ */
+decNumber * decNumberMaxMag(decNumber *res, const decNumber *lhs,
+ const decNumber *rhs, decContext *set) {
+ uInt status=0; // accumulator
+ decCompareOp(res, lhs, rhs, set, COMPMAXMAG, &status);
+ if (status!=0) decStatus(res, status, set);
+ #if DECCHECK
+ decCheckInexact(res, set);
+ #endif
+ return res;
+ } // decNumberMaxMag
+
+/* ------------------------------------------------------------------ */
+/* decNumberMin -- compare two Numbers and return the minimum */
+/* */
+/* This computes C = A ? B, returning the minimum by 754 rules */
+/* */
+/* res is C, the result. C may be A and/or B (e.g., X=X?X) */
+/* lhs is A */
+/* rhs is B */
+/* set is the context */
+/* */
+/* C must have space for set->digits digits. */
+/* ------------------------------------------------------------------ */
+decNumber * decNumberMin(decNumber *res, const decNumber *lhs,
+ const decNumber *rhs, decContext *set) {
+ uInt status=0; // accumulator
+ decCompareOp(res, lhs, rhs, set, COMPMIN, &status);
+ if (status!=0) decStatus(res, status, set);
+ #if DECCHECK
+ decCheckInexact(res, set);
+ #endif
+ return res;
+ } // decNumberMin
+
+/* ------------------------------------------------------------------ */
+/* decNumberMinMag -- compare and return the minimum by magnitude */
+/* */
+/* This computes C = A ? B, returning the minimum by 754 rules */
+/* */
+/* res is C, the result. C may be A and/or B (e.g., X=X?X) */
+/* lhs is A */
+/* rhs is B */
+/* set is the context */
+/* */
+/* C must have space for set->digits digits. */
+/* ------------------------------------------------------------------ */
+decNumber * decNumberMinMag(decNumber *res, const decNumber *lhs,
+ const decNumber *rhs, decContext *set) {
+ uInt status=0; // accumulator
+ decCompareOp(res, lhs, rhs, set, COMPMINMAG, &status);
+ if (status!=0) decStatus(res, status, set);
+ #if DECCHECK
+ decCheckInexact(res, set);
+ #endif
+ return res;
+ } // decNumberMinMag
+
+/* ------------------------------------------------------------------ */
+/* decNumberMinus -- prefix minus operator */
+/* */
+/* This computes C = 0 - A */
+/* */
+/* res is C, the result. C may be A */
+/* rhs is A */
+/* set is the context */
+/* */
+/* See also decNumberCopyNegate for a quiet bitwise version of this. */
+/* C must have space for set->digits digits. */
+/* ------------------------------------------------------------------ */
+/* Simply use AddOp for the subtract, which will do the necessary. */
+/* ------------------------------------------------------------------ */
+decNumber * decNumberMinus(decNumber *res, const decNumber *rhs,
+ decContext *set) {
+ decNumber dzero;
+ uInt status=0; // accumulator
+
+ #if DECCHECK
+ if (decCheckOperands(res, DECUNUSED, rhs, set)) return res;
+ #endif
+
+ decNumberZero(&dzero); // make 0
+ dzero.exponent=rhs->exponent; // [no coefficient expansion]
+ decAddOp(res, &dzero, rhs, set, DECNEG, &status);
+ if (status!=0) decStatus(res, status, set);
+ #if DECCHECK
+ decCheckInexact(res, set);
+ #endif
+ return res;
+ } // decNumberMinus
+
+/* ------------------------------------------------------------------ */
+/* decNumberNextMinus -- next towards -Infinity */
+/* */
+/* This computes C = A - infinitesimal, rounded towards -Infinity */
+/* */
+/* res is C, the result. C may be A */
+/* rhs is A */
+/* set is the context */
+/* */
+/* This is a generalization of 754 NextDown. */
+/* ------------------------------------------------------------------ */
+decNumber * decNumberNextMinus(decNumber *res, const decNumber *rhs,
+ decContext *set) {
+ decNumber dtiny; // constant
+ decContext workset=*set; // work
+ uInt status=0; // accumulator
+ #if DECCHECK
+ if (decCheckOperands(res, DECUNUSED, rhs, set)) return res;
+ #endif
+
+ // +Infinity is the special case
+ if ((rhs->bits&(DECINF|DECNEG))==DECINF) {
+ decSetMaxValue(res, set); // is +ve
+ // there is no status to set
+ return res;
+ }
+ decNumberZero(&dtiny); // start with 0
+ dtiny.lsu[0]=1; // make number that is ..
+ dtiny.exponent=DEC_MIN_EMIN-1; // .. smaller than tiniest
+ workset.round=DEC_ROUND_FLOOR;
+ decAddOp(res, rhs, &dtiny, &workset, DECNEG, &status);
+ status&=DEC_Invalid_operation|DEC_sNaN; // only sNaN Invalid please
+ if (status!=0) decStatus(res, status, set);
+ return res;
+ } // decNumberNextMinus
+
+/* ------------------------------------------------------------------ */
+/* decNumberNextPlus -- next towards +Infinity */
+/* */
+/* This computes C = A + infinitesimal, rounded towards +Infinity */
+/* */
+/* res is C, the result. C may be A */
+/* rhs is A */
+/* set is the context */
+/* */
+/* This is a generalization of 754 NextUp. */
+/* ------------------------------------------------------------------ */
+decNumber * decNumberNextPlus(decNumber *res, const decNumber *rhs,
+ decContext *set) {
+ decNumber dtiny; // constant
+ decContext workset=*set; // work
+ uInt status=0; // accumulator
+ #if DECCHECK
+ if (decCheckOperands(res, DECUNUSED, rhs, set)) return res;
+ #endif
+
+ // -Infinity is the special case
+ if ((rhs->bits&(DECINF|DECNEG))==(DECINF|DECNEG)) {
+ decSetMaxValue(res, set);
+ res->bits=DECNEG; // negative
+ // there is no status to set
+ return res;
+ }
+ decNumberZero(&dtiny); // start with 0
+ dtiny.lsu[0]=1; // make number that is ..
+ dtiny.exponent=DEC_MIN_EMIN-1; // .. smaller than tiniest
+ workset.round=DEC_ROUND_CEILING;
+ decAddOp(res, rhs, &dtiny, &workset, 0, &status);
+ status&=DEC_Invalid_operation|DEC_sNaN; // only sNaN Invalid please
+ if (status!=0) decStatus(res, status, set);
+ return res;
+ } // decNumberNextPlus
+
+/* ------------------------------------------------------------------ */
+/* decNumberNextToward -- next towards rhs */
+/* */
+/* This computes C = A +/- infinitesimal, rounded towards */
+/* +/-Infinity in the direction of B, as per 754-1985 nextafter */
+/* modified during revision but dropped from 754-2008. */
+/* */
+/* res is C, the result. C may be A or B. */
+/* lhs is A */
+/* rhs is B */
+/* set is the context */
+/* */
+/* This is a generalization of 754-1985 NextAfter. */
+/* ------------------------------------------------------------------ */
+decNumber * decNumberNextToward(decNumber *res, const decNumber *lhs,
+ const decNumber *rhs, decContext *set) {
+ decNumber dtiny; // constant
+ decContext workset=*set; // work
+ Int result; // ..
+ uInt status=0; // accumulator
+ #if DECCHECK
+ if (decCheckOperands(res, lhs, rhs, set)) return res;
+ #endif
+
+ if (decNumberIsNaN(lhs) || decNumberIsNaN(rhs)) {
+ decNaNs(res, lhs, rhs, set, &status);
+ }
+ else { // Is numeric, so no chance of sNaN Invalid, etc.
+ result=decCompare(lhs, rhs, 0); // sign matters
+ if (result==BADINT) status|=DEC_Insufficient_storage; // rare
+ else { // valid compare
+ if (result==0) decNumberCopySign(res, lhs, rhs); // easy
+ else { // differ: need NextPlus or NextMinus
+ uByte sub; // add or subtract
+ if (result<0) { // lhs<rhs, do nextplus
+ // -Infinity is the special case
+ if ((lhs->bits&(DECINF|DECNEG))==(DECINF|DECNEG)) {
+ decSetMaxValue(res, set);
+ res->bits=DECNEG; // negative
+ return res; // there is no status to set
+ }
+ workset.round=DEC_ROUND_CEILING;
+ sub=0; // add, please
+ } // plus
+ else { // lhs>rhs, do nextminus
+ // +Infinity is the special case
+ if ((lhs->bits&(DECINF|DECNEG))==DECINF) {
+ decSetMaxValue(res, set);
+ return res; // there is no status to set
+ }
+ workset.round=DEC_ROUND_FLOOR;
+ sub=DECNEG; // subtract, please
+ } // minus
+ decNumberZero(&dtiny); // start with 0
+ dtiny.lsu[0]=1; // make number that is ..
+ dtiny.exponent=DEC_MIN_EMIN-1; // .. smaller than tiniest
+ decAddOp(res, lhs, &dtiny, &workset, sub, &status); // + or -
+ // turn off exceptions if the result is a normal number
+ // (including Nmin), otherwise let all status through
+ if (decNumberIsNormal(res, set)) status=0;
+ } // unequal
+ } // compare OK
+ } // numeric
+ if (status!=0) decStatus(res, status, set);
+ return res;
+ } // decNumberNextToward
+
+/* ------------------------------------------------------------------ */
+/* decNumberOr -- OR two Numbers, digitwise */
+/* */
+/* This computes C = A | B */
+/* */
+/* res is C, the result. C may be A and/or B (e.g., X=X|X) */
+/* lhs is A */
+/* rhs is B */
+/* set is the context (used for result length and error report) */
+/* */
+/* C must have space for set->digits digits. */
+/* */
+/* Logical function restrictions apply (see above); a NaN is */
+/* returned with Invalid_operation if a restriction is violated. */
+/* ------------------------------------------------------------------ */
+decNumber * decNumberOr(decNumber *res, const decNumber *lhs,
+ const decNumber *rhs, decContext *set) {
+ const Unit *ua, *ub; // -> operands
+ const Unit *msua, *msub; // -> operand msus
+ Unit *uc, *msuc; // -> result and its msu
+ Int msudigs; // digits in res msu
+ #if DECCHECK
+ if (decCheckOperands(res, lhs, rhs, set)) return res;
+ #endif
+
+ if (lhs->exponent!=0 || decNumberIsSpecial(lhs) || decNumberIsNegative(lhs)
+ || rhs->exponent!=0 || decNumberIsSpecial(rhs) || decNumberIsNegative(rhs)) {
+ decStatus(res, DEC_Invalid_operation, set);
+ return res;
+ }
+ // operands are valid
+ ua=lhs->lsu; // bottom-up
+ ub=rhs->lsu; // ..
+ uc=res->lsu; // ..
+ msua=ua+D2U(lhs->digits)-1; // -> msu of lhs
+ msub=ub+D2U(rhs->digits)-1; // -> msu of rhs
+ msuc=uc+D2U(set->digits)-1; // -> msu of result
+ msudigs=MSUDIGITS(set->digits); // [faster than remainder]
+ for (; uc<=msuc; ua++, ub++, uc++) { // Unit loop
+ Unit a, b; // extract units
+ if (ua>msua) a=0;
+ else a=*ua;
+ if (ub>msub) b=0;
+ else b=*ub;
+ *uc=0; // can now write back
+ if (a|b) { // maybe 1 bits to examine
+ Int i, j;
+ // This loop could be unrolled and/or use BIN2BCD tables
+ for (i=0; i<DECDPUN; i++) {
+ if ((a|b)&1) *uc=*uc+(Unit)powers[i]; // effect OR
+ j=a%10;
+ a=a/10;
+ j|=b%10;
+ b=b/10;
+ if (j>1) {
+ decStatus(res, DEC_Invalid_operation, set);
+ return res;
+ }
+ if (uc==msuc && i==msudigs-1) break; // just did final digit
+ } // each digit
+ } // non-zero
+ } // each unit
+ // [here uc-1 is the msu of the result]
+ res->digits=decGetDigits(res->lsu, uc-res->lsu);
+ res->exponent=0; // integer
+ res->bits=0; // sign=0
+ return res; // [no status to set]
+ } // decNumberOr
+
+/* ------------------------------------------------------------------ */
+/* decNumberPlus -- prefix plus operator */
+/* */
+/* This computes C = 0 + A */
+/* */
+/* res is C, the result. C may be A */
+/* rhs is A */
+/* set is the context */
+/* */
+/* See also decNumberCopy for a quiet bitwise version of this. */
+/* C must have space for set->digits digits. */
+/* ------------------------------------------------------------------ */
+/* This simply uses AddOp; Add will take fast path after preparing A. */
+/* Performance is a concern here, as this routine is often used to */
+/* check operands and apply rounding and overflow/underflow testing. */
+/* ------------------------------------------------------------------ */
+decNumber * decNumberPlus(decNumber *res, const decNumber *rhs,
+ decContext *set) {
+ decNumber dzero;
+ uInt status=0; // accumulator
+ #if DECCHECK
+ if (decCheckOperands(res, DECUNUSED, rhs, set)) return res;
+ #endif
+
+ decNumberZero(&dzero); // make 0
+ dzero.exponent=rhs->exponent; // [no coefficient expansion]
+ decAddOp(res, &dzero, rhs, set, 0, &status);
+ if (status!=0) decStatus(res, status, set);
+ #if DECCHECK
+ decCheckInexact(res, set);
+ #endif
+ return res;
+ } // decNumberPlus
+
+/* ------------------------------------------------------------------ */
+/* decNumberMultiply -- multiply two Numbers */
+/* */
+/* This computes C = A x B */
+/* */
+/* res is C, the result. C may be A and/or B (e.g., X=X+X) */
+/* lhs is A */
+/* rhs is B */
+/* set is the context */
+/* */
+/* C must have space for set->digits digits. */
+/* ------------------------------------------------------------------ */
+decNumber * decNumberMultiply(decNumber *res, const decNumber *lhs,
+ const decNumber *rhs, decContext *set) {
+ uInt status=0; // accumulator
+ decMultiplyOp(res, lhs, rhs, set, &status);
+ if (status!=0) decStatus(res, status, set);
+ #if DECCHECK
+ decCheckInexact(res, set);
+ #endif
+ return res;
+ } // decNumberMultiply
+
+/* ------------------------------------------------------------------ */
+/* decNumberPower -- raise a number to a power */
+/* */
+/* This computes C = A ** B */
+/* */
+/* res is C, the result. C may be A and/or B (e.g., X=X**X) */
+/* lhs is A */
+/* rhs is B */
+/* set is the context */
+/* */
+/* C must have space for set->digits digits. */
+/* */
+/* Mathematical function restrictions apply (see above); a NaN is */
+/* returned with Invalid_operation if a restriction is violated. */
+/* */
+/* However, if 1999999997<=B<=999999999 and B is an integer then the */
+/* restrictions on A and the context are relaxed to the usual bounds, */
+/* for compatibility with the earlier (integer power only) version */
+/* of this function. */
+/* */
+/* When B is an integer, the result may be exact, even if rounded. */
+/* */
+/* The final result is rounded according to the context; it will */
+/* almost always be correctly rounded, but may be up to 1 ulp in */
+/* error in rare cases. */
+/* ------------------------------------------------------------------ */
+decNumber * decNumberPower(decNumber *res, const decNumber *lhs,
+ const decNumber *rhs, decContext *set) {
+ #if DECSUBSET
+ decNumber *alloclhs=NULL; // non-NULL if rounded lhs allocated
+ decNumber *allocrhs=NULL; // .., rhs
+ #endif
+ decNumber *allocdac=NULL; // -> allocated acc buffer, iff used
+ decNumber *allocinv=NULL; // -> allocated 1/x buffer, iff used
+ Int reqdigits=set->digits; // requested DIGITS
+ Int n; // rhs in binary
+ Flag rhsint=0; // 1 if rhs is an integer
+ Flag useint=0; // 1 if can use integer calculation
+ Flag isoddint=0; // 1 if rhs is an integer and odd
+ Int i; // work
+ #if DECSUBSET
+ Int dropped; // ..
+ #endif
+ uInt needbytes; // buffer size needed
+ Flag seenbit; // seen a bit while powering
+ Int residue=0; // rounding residue
+ uInt status=0; // accumulators
+ uByte bits=0; // result sign if errors
+ decContext aset; // working context
+ decNumber dnOne; // work value 1...
+ // local accumulator buffer [a decNumber, with digits+elength+1 digits]
+ decNumber dacbuff[D2N(DECBUFFER+9)];
+ decNumber *dac=dacbuff; // -> result accumulator
+ // same again for possible 1/lhs calculation
+ decNumber invbuff[D2N(DECBUFFER+9)];
+
+ #if DECCHECK
+ if (decCheckOperands(res, lhs, rhs, set)) return res;
+ #endif
+
+ do { // protect allocated storage
+ #if DECSUBSET
+ if (!set->extended) { // reduce operands and set status, as needed
+ if (lhs->digits>reqdigits) {
+ alloclhs=decRoundOperand(lhs, set, &status);
+ if (alloclhs==NULL) break;
+ lhs=alloclhs;
+ }
+ if (rhs->digits>reqdigits) {
+ allocrhs=decRoundOperand(rhs, set, &status);
+ if (allocrhs==NULL) break;
+ rhs=allocrhs;
+ }
+ }
+ #endif
+ // [following code does not require input rounding]
+
+ // handle NaNs and rhs Infinity (lhs infinity is harder)
+ if (SPECIALARGS) {
+ if (decNumberIsNaN(lhs) || decNumberIsNaN(rhs)) { // NaNs
+ decNaNs(res, lhs, rhs, set, &status);
+ break;}
+ if (decNumberIsInfinite(rhs)) { // rhs Infinity
+ Flag rhsneg=rhs->bits&DECNEG; // save rhs sign
+ if (decNumberIsNegative(lhs) // lhs<0
+ && !decNumberIsZero(lhs)) // ..
+ status|=DEC_Invalid_operation;
+ else { // lhs >=0
+ decNumberZero(&dnOne); // set up 1
+ dnOne.lsu[0]=1;
+ decNumberCompare(dac, lhs, &dnOne, set); // lhs ? 1
+ decNumberZero(res); // prepare for 0/1/Infinity
+ if (decNumberIsNegative(dac)) { // lhs<1
+ if (rhsneg) res->bits|=DECINF; // +Infinity [else is +0]
+ }
+ else if (dac->lsu[0]==0) { // lhs=1
+ // 1**Infinity is inexact, so return fully-padded 1.0000
+ Int shift=set->digits-1;
+ *res->lsu=1; // was 0, make int 1
+ res->digits=decShiftToMost(res->lsu, 1, shift);
+ res->exponent=-shift; // make 1.0000...
+ status|=DEC_Inexact|DEC_Rounded; // deemed inexact
+ }
+ else { // lhs>1
+ if (!rhsneg) res->bits|=DECINF; // +Infinity [else is +0]
+ }
+ } // lhs>=0
+ break;}
+ // [lhs infinity drops through]
+ } // specials
+
+ // Original rhs may be an integer that fits and is in range
+ n=decGetInt(rhs);
+ if (n!=BADINT) { // it is an integer
+ rhsint=1; // record the fact for 1**n
+ isoddint=(Flag)n&1; // [works even if big]
+ if (n!=BIGEVEN && n!=BIGODD) // can use integer path?
+ useint=1; // looks good
+ }
+
+ if (decNumberIsNegative(lhs) // -x ..
+ && isoddint) bits=DECNEG; // .. to an odd power
+
+ // handle LHS infinity
+ if (decNumberIsInfinite(lhs)) { // [NaNs already handled]
+ uByte rbits=rhs->bits; // save
+ decNumberZero(res); // prepare
+ if (n==0) *res->lsu=1; // [-]Inf**0 => 1
+ else {
+ // -Inf**nonint -> error
+ if (!rhsint && decNumberIsNegative(lhs)) {
+ status|=DEC_Invalid_operation; // -Inf**nonint is error
+ break;}
+ if (!(rbits & DECNEG)) bits|=DECINF; // was not a **-n
+ // [otherwise will be 0 or -0]
+ res->bits=bits;
+ }
+ break;}
+
+ // similarly handle LHS zero
+ if (decNumberIsZero(lhs)) {
+ if (n==0) { // 0**0 => Error
+ #if DECSUBSET
+ if (!set->extended) { // [unless subset]
+ decNumberZero(res);
+ *res->lsu=1; // return 1
+ break;}
+ #endif
+ status|=DEC_Invalid_operation;
+ }
+ else { // 0**x
+ uByte rbits=rhs->bits; // save
+ if (rbits & DECNEG) { // was a 0**(-n)
+ #if DECSUBSET
+ if (!set->extended) { // [bad if subset]
+ status|=DEC_Invalid_operation;
+ break;}
+ #endif
+ bits|=DECINF;
+ }
+ decNumberZero(res); // prepare
+ // [otherwise will be 0 or -0]
+ res->bits=bits;
+ }
+ break;}
+
+ // here both lhs and rhs are finite; rhs==0 is handled in the
+ // integer path. Next handle the non-integer cases
+ if (!useint) { // non-integral rhs
+ // any -ve lhs is bad, as is either operand or context out of
+ // bounds
+ if (decNumberIsNegative(lhs)) {
+ status|=DEC_Invalid_operation;
+ break;}
+ if (decCheckMath(lhs, set, &status)
+ || decCheckMath(rhs, set, &status)) break; // variable status
+
+ decContextDefault(&aset, DEC_INIT_DECIMAL64); // clean context
+ aset.emax=DEC_MAX_MATH; // usual bounds
+ aset.emin=-DEC_MAX_MATH; // ..
+ aset.clamp=0; // and no concrete format
+
+ // calculate the result using exp(ln(lhs)*rhs), which can
+ // all be done into the accumulator, dac. The precision needed
+ // is enough to contain the full information in the lhs (which
+ // is the total digits, including exponent), or the requested
+ // precision, if larger, + 4; 6 is used for the exponent
+ // maximum length, and this is also used when it is shorter
+ // than the requested digits as it greatly reduces the >0.5 ulp
+ // cases at little cost (because Ln doubles digits each
+ // iteration so a few extra digits rarely causes an extra
+ // iteration)
+ aset.digits=MAXI(lhs->digits, set->digits)+6+4;
+ } // non-integer rhs
+
+ else { // rhs is in-range integer
+ if (n==0) { // x**0 = 1
+ // (0**0 was handled above)
+ decNumberZero(res); // result=1
+ *res->lsu=1; // ..
+ break;}
+ // rhs is a non-zero integer
+ if (n<0) n=-n; // use abs(n)
+
+ aset=*set; // clone the context
+ aset.round=DEC_ROUND_HALF_EVEN; // internally use balanced
+ // calculate the working DIGITS
+ aset.digits=reqdigits+(rhs->digits+rhs->exponent)+2;
+ #if DECSUBSET
+ if (!set->extended) aset.digits--; // use classic precision
+ #endif
+ // it's an error if this is more than can be handled
+ if (aset.digits>DECNUMMAXP) {status|=DEC_Invalid_operation; break;}
+ } // integer path
+
+ // aset.digits is the count of digits for the accumulator needed
+ // if accumulator is too long for local storage, then allocate
+ needbytes=sizeof(decNumber)+(D2U(aset.digits)-1)*sizeof(Unit);
+ // [needbytes also used below if 1/lhs needed]
+ if (needbytes>sizeof(dacbuff)) {
+ allocdac=(decNumber *)malloc(needbytes);
+ if (allocdac==NULL) { // hopeless -- abandon
+ status|=DEC_Insufficient_storage;
+ break;}
+ dac=allocdac; // use the allocated space
+ }
+ // here, aset is set up and accumulator is ready for use
+
+ if (!useint) { // non-integral rhs
+ // x ** y; special-case x=1 here as it will otherwise always
+ // reduce to integer 1; decLnOp has a fastpath which detects
+ // the case of x=1
+ decLnOp(dac, lhs, &aset, &status); // dac=ln(lhs)
+ // [no error possible, as lhs 0 already handled]
+ if (ISZERO(dac)) { // x==1, 1.0, etc.
+ // need to return fully-padded 1.0000 etc., but rhsint->1
+ *dac->lsu=1; // was 0, make int 1
+ if (!rhsint) { // add padding
+ Int shift=set->digits-1;
+ dac->digits=decShiftToMost(dac->lsu, 1, shift);
+ dac->exponent=-shift; // make 1.0000...
+ status|=DEC_Inexact|DEC_Rounded; // deemed inexact
+ }
+ }
+ else {
+ decMultiplyOp(dac, dac, rhs, &aset, &status); // dac=dac*rhs
+ decExpOp(dac, dac, &aset, &status); // dac=exp(dac)
+ }
+ // and drop through for final rounding
+ } // non-integer rhs
+
+ else { // carry on with integer
+ decNumberZero(dac); // acc=1
+ *dac->lsu=1; // ..
+
+ // if a negative power the constant 1 is needed, and if not subset
+ // invert the lhs now rather than inverting the result later
+ if (decNumberIsNegative(rhs)) { // was a **-n [hence digits>0]
+ decNumber *inv=invbuff; // asssume use fixed buffer
+ decNumberCopy(&dnOne, dac); // dnOne=1; [needed now or later]
+ #if DECSUBSET
+ if (set->extended) { // need to calculate 1/lhs
+ #endif
+ // divide lhs into 1, putting result in dac [dac=1/dac]
+ decDivideOp(dac, &dnOne, lhs, &aset, DIVIDE, &status);
+ // now locate or allocate space for the inverted lhs
+ if (needbytes>sizeof(invbuff)) {
+ allocinv=(decNumber *)malloc(needbytes);
+ if (allocinv==NULL) { // hopeless -- abandon
+ status|=DEC_Insufficient_storage;
+ break;}
+ inv=allocinv; // use the allocated space
+ }
+ // [inv now points to big-enough buffer or allocated storage]
+ decNumberCopy(inv, dac); // copy the 1/lhs
+ decNumberCopy(dac, &dnOne); // restore acc=1
+ lhs=inv; // .. and go forward with new lhs
+ #if DECSUBSET
+ }
+ #endif
+ }
+
+ // Raise-to-the-power loop...
+ seenbit=0; // set once a 1-bit is encountered
+ for (i=1;;i++){ // for each bit [top bit ignored]
+ // abandon if had overflow or terminal underflow
+ if (status & (DEC_Overflow|DEC_Underflow)) { // interesting?
+ if (status&DEC_Overflow || ISZERO(dac)) break;
+ }
+ // [the following two lines revealed an optimizer bug in a C++
+ // compiler, with symptom: 5**3 -> 25, when n=n+n was used]
+ n=n<<1; // move next bit to testable position
+ if (n<0) { // top bit is set
+ seenbit=1; // OK, significant bit seen
+ decMultiplyOp(dac, dac, lhs, &aset, &status); // dac=dac*x
+ }
+ if (i==31) break; // that was the last bit
+ if (!seenbit) continue; // no need to square 1
+ decMultiplyOp(dac, dac, dac, &aset, &status); // dac=dac*dac [square]
+ } /*i*/ // 32 bits
+
+ // complete internal overflow or underflow processing
+ if (status & (DEC_Overflow|DEC_Underflow)) {
+ #if DECSUBSET
+ // If subset, and power was negative, reverse the kind of -erflow
+ // [1/x not yet done]
+ if (!set->extended && decNumberIsNegative(rhs)) {
+ if (status & DEC_Overflow)
+ status^=DEC_Overflow | DEC_Underflow | DEC_Subnormal;
+ else { // trickier -- Underflow may or may not be set
+ status&=~(DEC_Underflow | DEC_Subnormal); // [one or both]
+ status|=DEC_Overflow;
+ }
+ }
+ #endif
+ dac->bits=(dac->bits & ~DECNEG) | bits; // force correct sign
+ // round subnormals [to set.digits rather than aset.digits]
+ // or set overflow result similarly as required
+ decFinalize(dac, set, &residue, &status);
+ decNumberCopy(res, dac); // copy to result (is now OK length)
+ break;
+ }
+
+ #if DECSUBSET
+ if (!set->extended && // subset math
+ decNumberIsNegative(rhs)) { // was a **-n [hence digits>0]
+ // so divide result into 1 [dac=1/dac]
+ decDivideOp(dac, &dnOne, dac, &aset, DIVIDE, &status);
+ }
+ #endif
+ } // rhs integer path
+
+ // reduce result to the requested length and copy to result
+ decCopyFit(res, dac, set, &residue, &status);
+ decFinish(res, set, &residue, &status); // final cleanup
+ #if DECSUBSET
+ if (!set->extended) decTrim(res, set, 0, 1, &dropped); // trailing zeros
+ #endif
+ } while(0); // end protected
+
+ if (allocdac!=NULL) free(allocdac); // drop any storage used
+ if (allocinv!=NULL) free(allocinv); // ..
+ #if DECSUBSET
+ if (alloclhs!=NULL) free(alloclhs); // ..
+ if (allocrhs!=NULL) free(allocrhs); // ..
+ #endif
+ if (status!=0) decStatus(res, status, set);
+ #if DECCHECK
+ decCheckInexact(res, set);
+ #endif
+ return res;
+ } // decNumberPower
+
+/* ------------------------------------------------------------------ */
+/* decNumberQuantize -- force exponent to requested value */
+/* */
+/* This computes C = op(A, B), where op adjusts the coefficient */
+/* of C (by rounding or shifting) such that the exponent (-scale) */
+/* of C has exponent of B. The numerical value of C will equal A, */
+/* except for the effects of any rounding that occurred. */
+/* */
+/* res is C, the result. C may be A or B */
+/* lhs is A, the number to adjust */
+/* rhs is B, the number with exponent to match */
+/* set is the context */
+/* */
+/* C must have space for set->digits digits. */
+/* */
+/* Unless there is an error or the result is infinite, the exponent */
+/* after the operation is guaranteed to be equal to that of B. */
+/* ------------------------------------------------------------------ */
+decNumber * decNumberQuantize(decNumber *res, const decNumber *lhs,
+ const decNumber *rhs, decContext *set) {
+ uInt status=0; // accumulator
+ decQuantizeOp(res, lhs, rhs, set, 1, &status);
+ if (status!=0) decStatus(res, status, set);
+ return res;
+ } // decNumberQuantize
+
+/* ------------------------------------------------------------------ */
+/* decNumberReduce -- remove trailing zeros */
+/* */
+/* This computes C = 0 + A, and normalizes the result */
+/* */
+/* res is C, the result. C may be A */
+/* rhs is A */
+/* set is the context */
+/* */
+/* C must have space for set->digits digits. */
+/* ------------------------------------------------------------------ */
+// Previously known as Normalize
+decNumber * decNumberNormalize(decNumber *res, const decNumber *rhs,
+ decContext *set) {
+ return decNumberReduce(res, rhs, set);
+ } // decNumberNormalize
+
+decNumber * decNumberReduce(decNumber *res, const decNumber *rhs,
+ decContext *set) {
+ #if DECSUBSET
+ decNumber *allocrhs=NULL; // non-NULL if rounded rhs allocated
+ #endif
+ uInt status=0; // as usual
+ Int residue=0; // as usual
+ Int dropped; // work
+
+ #if DECCHECK
+ if (decCheckOperands(res, DECUNUSED, rhs, set)) return res;
+ #endif
+
+ do { // protect allocated storage
+ #if DECSUBSET
+ if (!set->extended) {
+ // reduce operand and set lostDigits status, as needed
+ if (rhs->digits>set->digits) {
+ allocrhs=decRoundOperand(rhs, set, &status);
+ if (allocrhs==NULL) break;
+ rhs=allocrhs;
+ }
+ }
+ #endif
+ // [following code does not require input rounding]
+
+ // Infinities copy through; NaNs need usual treatment
+ if (decNumberIsNaN(rhs)) {
+ decNaNs(res, rhs, NULL, set, &status);
+ break;
+ }
+
+ // reduce result to the requested length and copy to result
+ decCopyFit(res, rhs, set, &residue, &status); // copy & round
+ decFinish(res, set, &residue, &status); // cleanup/set flags
+ decTrim(res, set, 1, 0, &dropped); // normalize in place
+ // [may clamp]
+ } while(0); // end protected
+
+ #if DECSUBSET
+ if (allocrhs !=NULL) free(allocrhs); // ..
+ #endif
+ if (status!=0) decStatus(res, status, set);// then report status
+ return res;
+ } // decNumberReduce
+
+/* ------------------------------------------------------------------ */
+/* decNumberRescale -- force exponent to requested value */
+/* */
+/* This computes C = op(A, B), where op adjusts the coefficient */
+/* of C (by rounding or shifting) such that the exponent (-scale) */
+/* of C has the value B. The numerical value of C will equal A, */
+/* except for the effects of any rounding that occurred. */
+/* */
+/* res is C, the result. C may be A or B */
+/* lhs is A, the number to adjust */
+/* rhs is B, the requested exponent */
+/* set is the context */
+/* */
+/* C must have space for set->digits digits. */
+/* */
+/* Unless there is an error or the result is infinite, the exponent */
+/* after the operation is guaranteed to be equal to B. */
+/* ------------------------------------------------------------------ */
+decNumber * decNumberRescale(decNumber *res, const decNumber *lhs,
+ const decNumber *rhs, decContext *set) {
+ uInt status=0; // accumulator
+ decQuantizeOp(res, lhs, rhs, set, 0, &status);
+ if (status!=0) decStatus(res, status, set);
+ return res;
+ } // decNumberRescale
+
+/* ------------------------------------------------------------------ */
+/* decNumberRemainder -- divide and return remainder */
+/* */
+/* This computes C = A % B */
+/* */
+/* res is C, the result. C may be A and/or B (e.g., X=X%X) */
+/* lhs is A */
+/* rhs is B */
+/* set is the context */
+/* */
+/* C must have space for set->digits digits. */
+/* ------------------------------------------------------------------ */
+decNumber * decNumberRemainder(decNumber *res, const decNumber *lhs,
+ const decNumber *rhs, decContext *set) {
+ uInt status=0; // accumulator
+ decDivideOp(res, lhs, rhs, set, REMAINDER, &status);
+ if (status!=0) decStatus(res, status, set);
+ #if DECCHECK
+ decCheckInexact(res, set);
+ #endif
+ return res;
+ } // decNumberRemainder
+
+/* ------------------------------------------------------------------ */
+/* decNumberRemainderNear -- divide and return remainder from nearest */
+/* */
+/* This computes C = A % B, where % is the IEEE remainder operator */
+/* */
+/* res is C, the result. C may be A and/or B (e.g., X=X%X) */
+/* lhs is A */
+/* rhs is B */
+/* set is the context */
+/* */
+/* C must have space for set->digits digits. */
+/* ------------------------------------------------------------------ */
+decNumber * decNumberRemainderNear(decNumber *res, const decNumber *lhs,
+ const decNumber *rhs, decContext *set) {
+ uInt status=0; // accumulator
+ decDivideOp(res, lhs, rhs, set, REMNEAR, &status);
+ if (status!=0) decStatus(res, status, set);
+ #if DECCHECK
+ decCheckInexact(res, set);
+ #endif
+ return res;
+ } // decNumberRemainderNear
+
+/* ------------------------------------------------------------------ */
+/* decNumberRotate -- rotate the coefficient of a Number left/right */
+/* */
+/* This computes C = A rot B (in base ten and rotating set->digits */
+/* digits). */
+/* */
+/* res is C, the result. C may be A and/or B (e.g., X=XrotX) */
+/* lhs is A */
+/* rhs is B, the number of digits to rotate (-ve to right) */
+/* set is the context */
+/* */
+/* The digits of the coefficient of A are rotated to the left (if B */
+/* is positive) or to the right (if B is negative) without adjusting */
+/* the exponent or the sign of A. If lhs->digits is less than */
+/* set->digits the coefficient is padded with zeros on the left */
+/* before the rotate. Any leading zeros in the result are removed */
+/* as usual. */
+/* */
+/* B must be an integer (q=0) and in the range -set->digits through */
+/* +set->digits. */
+/* C must have space for set->digits digits. */
+/* NaNs are propagated as usual. Infinities are unaffected (but */
+/* B must be valid). No status is set unless B is invalid or an */
+/* operand is an sNaN. */
+/* ------------------------------------------------------------------ */
+decNumber * decNumberRotate(decNumber *res, const decNumber *lhs,
+ const decNumber *rhs, decContext *set) {
+ uInt status=0; // accumulator
+ Int rotate; // rhs as an Int
+
+ #if DECCHECK
+ if (decCheckOperands(res, lhs, rhs, set)) return res;
+ #endif
+
+ // NaNs propagate as normal
+ if (decNumberIsNaN(lhs) || decNumberIsNaN(rhs))
+ decNaNs(res, lhs, rhs, set, &status);
+ // rhs must be an integer
+ else if (decNumberIsInfinite(rhs) || rhs->exponent!=0)
+ status=DEC_Invalid_operation;
+ else { // both numeric, rhs is an integer
+ rotate=decGetInt(rhs); // [cannot fail]
+ if (rotate==BADINT // something bad ..
+ || rotate==BIGODD || rotate==BIGEVEN // .. very big ..
+ || abs(rotate)>set->digits) // .. or out of range
+ status=DEC_Invalid_operation;
+ else { // rhs is OK
+ decNumberCopy(res, lhs);
+ // convert -ve rotate to equivalent positive rotation
+ if (rotate<0) rotate=set->digits+rotate;
+ if (rotate!=0 && rotate!=set->digits // zero or full rotation
+ && !decNumberIsInfinite(res)) { // lhs was infinite
+ // left-rotate to do; 0 < rotate < set->digits
+ uInt units, shift; // work
+ uInt msudigits; // digits in result msu
+ Unit *msu=res->lsu+D2U(res->digits)-1; // current msu
+ Unit *msumax=res->lsu+D2U(set->digits)-1; // rotation msu
+ for (msu++; msu<=msumax; msu++) *msu=0; // ensure high units=0
+ res->digits=set->digits; // now full-length
+ msudigits=MSUDIGITS(res->digits); // actual digits in msu
+
+ // rotation here is done in-place, in three steps
+ // 1. shift all to least up to one unit to unit-align final
+ // lsd [any digits shifted out are rotated to the left,
+ // abutted to the original msd (which may require split)]
+ //
+ // [if there are no whole units left to rotate, the
+ // rotation is now complete]
+ //
+ // 2. shift to least, from below the split point only, so that
+ // the final msd is in the right place in its Unit [any
+ // digits shifted out will fit exactly in the current msu,
+ // left aligned, no split required]
+ //
+ // 3. rotate all the units by reversing left part, right
+ // part, and then whole
+ //
+ // example: rotate right 8 digits (2 units + 2), DECDPUN=3.
+ //
+ // start: 00a bcd efg hij klm npq
+ //
+ // 1a 000 0ab cde fgh|ijk lmn [pq saved]
+ // 1b 00p qab cde fgh|ijk lmn
+ //
+ // 2a 00p qab cde fgh|00i jkl [mn saved]
+ // 2b mnp qab cde fgh|00i jkl
+ //
+ // 3a fgh cde qab mnp|00i jkl
+ // 3b fgh cde qab mnp|jkl 00i
+ // 3c 00i jkl mnp qab cde fgh
+
+ // Step 1: amount to shift is the partial right-rotate count
+ rotate=set->digits-rotate; // make it right-rotate
+ units=rotate/DECDPUN; // whole units to rotate
+ shift=rotate%DECDPUN; // left-over digits count
+ if (shift>0) { // not an exact number of units
+ uInt save=res->lsu[0]%powers[shift]; // save low digit(s)
+ decShiftToLeast(res->lsu, D2U(res->digits), shift);
+ if (shift>msudigits) { // msumax-1 needs >0 digits
+ uInt rem=save%powers[shift-msudigits];// split save
+ *msumax=(Unit)(save/powers[shift-msudigits]); // and insert
+ *(msumax-1)=*(msumax-1)
+ +(Unit)(rem*powers[DECDPUN-(shift-msudigits)]); // ..
+ }
+ else { // all fits in msumax
+ *msumax=*msumax+(Unit)(save*powers[msudigits-shift]); // [maybe *1]
+ }
+ } // digits shift needed
+
+ // If whole units to rotate...
+ if (units>0) { // some to do
+ // Step 2: the units to touch are the whole ones in rotate,
+ // if any, and the shift is DECDPUN-msudigits (which may be
+ // 0, again)
+ shift=DECDPUN-msudigits;
+ if (shift>0) { // not an exact number of units
+ uInt save=res->lsu[0]%powers[shift]; // save low digit(s)
+ decShiftToLeast(res->lsu, units, shift);
+ *msumax=*msumax+(Unit)(save*powers[msudigits]);
+ } // partial shift needed
+
+ // Step 3: rotate the units array using triple reverse
+ // (reversing is easy and fast)
+ decReverse(res->lsu+units, msumax); // left part
+ decReverse(res->lsu, res->lsu+units-1); // right part
+ decReverse(res->lsu, msumax); // whole
+ } // whole units to rotate
+ // the rotation may have left an undetermined number of zeros
+ // on the left, so true length needs to be calculated
+ res->digits=decGetDigits(res->lsu, msumax-res->lsu+1);
+ } // rotate needed
+ } // rhs OK
+ } // numerics
+ if (status!=0) decStatus(res, status, set);
+ return res;
+ } // decNumberRotate
+
+/* ------------------------------------------------------------------ */
+/* decNumberSameQuantum -- test for equal exponents */
+/* */
+/* res is the result number, which will contain either 0 or 1 */
+/* lhs is a number to test */
+/* rhs is the second (usually a pattern) */
+/* */
+/* No errors are possible and no context is needed. */
+/* ------------------------------------------------------------------ */
+decNumber * decNumberSameQuantum(decNumber *res, const decNumber *lhs,
+ const decNumber *rhs) {
+ Unit ret=0; // return value
+
+ #if DECCHECK
+ if (decCheckOperands(res, lhs, rhs, DECUNCONT)) return res;
+ #endif
+
+ if (SPECIALARGS) {
+ if (decNumberIsNaN(lhs) && decNumberIsNaN(rhs)) ret=1;
+ else if (decNumberIsInfinite(lhs) && decNumberIsInfinite(rhs)) ret=1;
+ // [anything else with a special gives 0]
+ }
+ else if (lhs->exponent==rhs->exponent) ret=1;
+
+ decNumberZero(res); // OK to overwrite an operand now
+ *res->lsu=ret;
+ return res;
+ } // decNumberSameQuantum
+
+/* ------------------------------------------------------------------ */
+/* decNumberScaleB -- multiply by a power of 10 */
+/* */
+/* This computes C = A x 10**B where B is an integer (q=0) with */
+/* maximum magnitude 2*(emax+digits) */
+/* */
+/* res is C, the result. C may be A or B */
+/* lhs is A, the number to adjust */
+/* rhs is B, the requested power of ten to use */
+/* set is the context */
+/* */
+/* C must have space for set->digits digits. */
+/* */
+/* The result may underflow or overflow. */
+/* ------------------------------------------------------------------ */
+decNumber * decNumberScaleB(decNumber *res, const decNumber *lhs,
+ const decNumber *rhs, decContext *set) {
+ Int reqexp; // requested exponent change [B]
+ uInt status=0; // accumulator
+ Int residue; // work
+
+ #if DECCHECK
+ if (decCheckOperands(res, lhs, rhs, set)) return res;
+ #endif
+
+ // Handle special values except lhs infinite
+ if (decNumberIsNaN(lhs) || decNumberIsNaN(rhs))
+ decNaNs(res, lhs, rhs, set, &status);
+ // rhs must be an integer
+ else if (decNumberIsInfinite(rhs) || rhs->exponent!=0)
+ status=DEC_Invalid_operation;
+ else {
+ // lhs is a number; rhs is a finite with q==0
+ reqexp=decGetInt(rhs); // [cannot fail]
+ // maximum range is larger than getInt can handle, so this is
+ // more restrictive than the specification
+ if (reqexp==BADINT // something bad ..
+ || reqexp==BIGODD || reqexp==BIGEVEN // it was huge
+ || (abs(reqexp)+1)/2>(set->digits+set->emax)) // .. or out of range
+ status=DEC_Invalid_operation;
+ else { // rhs is OK
+ decNumberCopy(res, lhs); // all done if infinite lhs
+ if (!decNumberIsInfinite(res)) { // prepare to scale
+ Int exp=res->exponent; // save for overflow test
+ res->exponent+=reqexp; // adjust the exponent
+ if (((exp^reqexp)>=0) // same sign ...
+ && ((exp^res->exponent)<0)) { // .. but result had different
+ // the calculation overflowed, so force right treatment
+ if (exp<0) res->exponent=DEC_MIN_EMIN-DEC_MAX_DIGITS;
+ else res->exponent=DEC_MAX_EMAX+1;
+ }
+ residue=0;
+ decFinalize(res, set, &residue, &status); // final check
+ } // finite LHS
+ } // rhs OK
+ } // rhs finite
+ if (status!=0) decStatus(res, status, set);
+ return res;
+ } // decNumberScaleB
+
+/* ------------------------------------------------------------------ */
+/* decNumberShift -- shift the coefficient of a Number left or right */
+/* */
+/* This computes C = A << B or C = A >> -B (in base ten). */
+/* */
+/* res is C, the result. C may be A and/or B (e.g., X=X<<X) */
+/* lhs is A */
+/* rhs is B, the number of digits to shift (-ve to right) */
+/* set is the context */
+/* */
+/* The digits of the coefficient of A are shifted to the left (if B */
+/* is positive) or to the right (if B is negative) without adjusting */
+/* the exponent or the sign of A. */
+/* */
+/* B must be an integer (q=0) and in the range -set->digits through */
+/* +set->digits. */
+/* C must have space for set->digits digits. */
+/* NaNs are propagated as usual. Infinities are unaffected (but */
+/* B must be valid). No status is set unless B is invalid or an */
+/* operand is an sNaN. */
+/* ------------------------------------------------------------------ */
+decNumber * decNumberShift(decNumber *res, const decNumber *lhs,
+ const decNumber *rhs, decContext *set) {
+ uInt status=0; // accumulator
+ Int shift; // rhs as an Int
+
+ #if DECCHECK
+ if (decCheckOperands(res, lhs, rhs, set)) return res;
+ #endif
+
+ // NaNs propagate as normal
+ if (decNumberIsNaN(lhs) || decNumberIsNaN(rhs))
+ decNaNs(res, lhs, rhs, set, &status);
+ // rhs must be an integer
+ else if (decNumberIsInfinite(rhs) || rhs->exponent!=0)
+ status=DEC_Invalid_operation;
+ else { // both numeric, rhs is an integer
+ shift=decGetInt(rhs); // [cannot fail]
+ if (shift==BADINT // something bad ..
+ || shift==BIGODD || shift==BIGEVEN // .. very big ..
+ || abs(shift)>set->digits) // .. or out of range
+ status=DEC_Invalid_operation;
+ else { // rhs is OK
+ decNumberCopy(res, lhs);
+ if (shift!=0 && !decNumberIsInfinite(res)) { // something to do
+ if (shift>0) { // to left
+ if (shift==set->digits) { // removing all
+ *res->lsu=0; // so place 0
+ res->digits=1; // ..
+ }
+ else { //
+ // first remove leading digits if necessary
+ if (res->digits+shift>set->digits) {
+ decDecap(res, res->digits+shift-set->digits);
+ // that updated res->digits; may have gone to 1 (for a
+ // single digit or for zero
+ }
+ if (res->digits>1 || *res->lsu) // if non-zero..
+ res->digits=decShiftToMost(res->lsu, res->digits, shift);
+ } // partial left
+ } // left
+ else { // to right
+ if (-shift>=res->digits) { // discarding all
+ *res->lsu=0; // so place 0
+ res->digits=1; // ..
+ }
+ else {
+ decShiftToLeast(res->lsu, D2U(res->digits), -shift);
+ res->digits-=(-shift);
+ }
+ } // to right
+ } // non-0 non-Inf shift
+ } // rhs OK
+ } // numerics
+ if (status!=0) decStatus(res, status, set);
+ return res;
+ } // decNumberShift
+
+/* ------------------------------------------------------------------ */
+/* decNumberSquareRoot -- square root operator */
+/* */
+/* This computes C = squareroot(A) */
+/* */
+/* res is C, the result. C may be A */
+/* rhs is A */
+/* set is the context; note that rounding mode has no effect */
+/* */
+/* C must have space for set->digits digits. */
+/* ------------------------------------------------------------------ */
+/* This uses the following varying-precision algorithm in: */
+/* */
+/* Properly Rounded Variable Precision Square Root, T. E. Hull and */
+/* A. Abrham, ACM Transactions on Mathematical Software, Vol 11 #3, */
+/* pp229-237, ACM, September 1985. */
+/* */
+/* The square-root is calculated using Newton's method, after which */
+/* a check is made to ensure the result is correctly rounded. */
+/* */
+/* % [Reformatted original Numerical Turing source code follows.] */
+/* function sqrt(x : real) : real */
+/* % sqrt(x) returns the properly rounded approximation to the square */
+/* % root of x, in the precision of the calling environment, or it */
+/* % fails if x < 0. */
+/* % t e hull and a abrham, august, 1984 */
+/* if x <= 0 then */
+/* if x < 0 then */
+/* assert false */
+/* else */
+/* result 0 */
+/* end if */
+/* end if */
+/* var f := setexp(x, 0) % fraction part of x [0.1 <= x < 1] */
+/* var e := getexp(x) % exponent part of x */
+/* var approx : real */
+/* if e mod 2 = 0 then */
+/* approx := .259 + .819 * f % approx to root of f */
+/* else */
+/* f := f/l0 % adjustments */
+/* e := e + 1 % for odd */
+/* approx := .0819 + 2.59 * f % exponent */
+/* end if */
+/* */
+/* var p:= 3 */
+/* const maxp := currentprecision + 2 */
+/* loop */
+/* p := min(2*p - 2, maxp) % p = 4,6,10, . . . , maxp */
+/* precision p */
+/* approx := .5 * (approx + f/approx) */
+/* exit when p = maxp */
+/* end loop */
+/* */
+/* % approx is now within 1 ulp of the properly rounded square root */
+/* % of f; to ensure proper rounding, compare squares of (approx - */
+/* % l/2 ulp) and (approx + l/2 ulp) with f. */
+/* p := currentprecision */
+/* begin */
+/* precision p + 2 */
+/* const approxsubhalf := approx - setexp(.5, -p) */
+/* if mulru(approxsubhalf, approxsubhalf) > f then */
+/* approx := approx - setexp(.l, -p + 1) */
+/* else */
+/* const approxaddhalf := approx + setexp(.5, -p) */
+/* if mulrd(approxaddhalf, approxaddhalf) < f then */
+/* approx := approx + setexp(.l, -p + 1) */
+/* end if */
+/* end if */
+/* end */
+/* result setexp(approx, e div 2) % fix exponent */
+/* end sqrt */
+/* ------------------------------------------------------------------ */
+decNumber * decNumberSquareRoot(decNumber *res, const decNumber *rhs,
+ decContext *set) {
+ decContext workset, approxset; // work contexts
+ decNumber dzero; // used for constant zero
+ Int maxp; // largest working precision
+ Int workp; // working precision
+ Int residue=0; // rounding residue
+ uInt status=0, ignore=0; // status accumulators
+ uInt rstatus; // ..
+ Int exp; // working exponent
+ Int ideal; // ideal (preferred) exponent
+ Int needbytes; // work
+ Int dropped; // ..
+
+ #if DECSUBSET
+ decNumber *allocrhs=NULL; // non-NULL if rounded rhs allocated
+ #endif
+ // buffer for f [needs +1 in case DECBUFFER 0]
+ decNumber buff[D2N(DECBUFFER+1)];
+ // buffer for a [needs +2 to match likely maxp]
+ decNumber bufa[D2N(DECBUFFER+2)];
+ // buffer for temporary, b [must be same size as a]
+ decNumber bufb[D2N(DECBUFFER+2)];
+ decNumber *allocbuff=NULL; // -> allocated buff, iff allocated
+ decNumber *allocbufa=NULL; // -> allocated bufa, iff allocated
+ decNumber *allocbufb=NULL; // -> allocated bufb, iff allocated
+ decNumber *f=buff; // reduced fraction
+ decNumber *a=bufa; // approximation to result
+ decNumber *b=bufb; // intermediate result
+ // buffer for temporary variable, up to 3 digits
+ decNumber buft[D2N(3)];
+ decNumber *t=buft; // up-to-3-digit constant or work
+
+ #if DECCHECK
+ if (decCheckOperands(res, DECUNUSED, rhs, set)) return res;
+ #endif
+
+ do { // protect allocated storage
+ #if DECSUBSET
+ if (!set->extended) {
+ // reduce operand and set lostDigits status, as needed
+ if (rhs->digits>set->digits) {
+ allocrhs=decRoundOperand(rhs, set, &status);
+ if (allocrhs==NULL) break;
+ // [Note: 'f' allocation below could reuse this buffer if
+ // used, but as this is rare they are kept separate for clarity.]
+ rhs=allocrhs;
+ }
+ }
+ #endif
+ // [following code does not require input rounding]
+
+ // handle infinities and NaNs
+ if (SPECIALARG) {
+ if (decNumberIsInfinite(rhs)) { // an infinity
+ if (decNumberIsNegative(rhs)) status|=DEC_Invalid_operation;
+ else decNumberCopy(res, rhs); // +Infinity
+ }
+ else decNaNs(res, rhs, NULL, set, &status); // a NaN
+ break;
+ }
+
+ // calculate the ideal (preferred) exponent [floor(exp/2)]
+ // [It would be nicer to write: ideal=rhs->exponent>>1, but this
+ // generates a compiler warning. Generated code is the same.]
+ ideal=(rhs->exponent&~1)/2; // target
+
+ // handle zeros
+ if (ISZERO(rhs)) {
+ decNumberCopy(res, rhs); // could be 0 or -0
+ res->exponent=ideal; // use the ideal [safe]
+ // use decFinish to clamp any out-of-range exponent, etc.
+ decFinish(res, set, &residue, &status);
+ break;
+ }
+
+ // any other -x is an oops
+ if (decNumberIsNegative(rhs)) {
+ status|=DEC_Invalid_operation;
+ break;
+ }
+
+ // space is needed for three working variables
+ // f -- the same precision as the RHS, reduced to 0.01->0.99...
+ // a -- Hull's approximation -- precision, when assigned, is
+ // currentprecision+1 or the input argument precision,
+ // whichever is larger (+2 for use as temporary)
+ // b -- intermediate temporary result (same size as a)
+ // if any is too long for local storage, then allocate
+ workp=MAXI(set->digits+1, rhs->digits); // actual rounding precision
+ workp=MAXI(workp, 7); // at least 7 for low cases
+ maxp=workp+2; // largest working precision
+
+ needbytes=sizeof(decNumber)+(D2U(rhs->digits)-1)*sizeof(Unit);
+ if (needbytes>(Int)sizeof(buff)) {
+ allocbuff=(decNumber *)malloc(needbytes);
+ if (allocbuff==NULL) { // hopeless -- abandon
+ status|=DEC_Insufficient_storage;
+ break;}
+ f=allocbuff; // use the allocated space
+ }
+ // a and b both need to be able to hold a maxp-length number
+ needbytes=sizeof(decNumber)+(D2U(maxp)-1)*sizeof(Unit);
+ if (needbytes>(Int)sizeof(bufa)) { // [same applies to b]
+ allocbufa=(decNumber *)malloc(needbytes);
+ allocbufb=(decNumber *)malloc(needbytes);
+ if (allocbufa==NULL || allocbufb==NULL) { // hopeless
+ status|=DEC_Insufficient_storage;
+ break;}
+ a=allocbufa; // use the allocated spaces
+ b=allocbufb; // ..
+ }
+
+ // copy rhs -> f, save exponent, and reduce so 0.1 <= f < 1
+ decNumberCopy(f, rhs);
+ exp=f->exponent+f->digits; // adjusted to Hull rules
+ f->exponent=-(f->digits); // to range
+
+ // set up working context
+ decContextDefault(&workset, DEC_INIT_DECIMAL64);
+ workset.emax=DEC_MAX_EMAX;
+ workset.emin=DEC_MIN_EMIN;
+
+ // [Until further notice, no error is possible and status bits
+ // (Rounded, etc.) should be ignored, not accumulated.]
+
+ // Calculate initial approximation, and allow for odd exponent
+ workset.digits=workp; // p for initial calculation
+ t->bits=0; t->digits=3;
+ a->bits=0; a->digits=3;
+ if ((exp & 1)==0) { // even exponent
+ // Set t=0.259, a=0.819
+ t->exponent=-3;
+ a->exponent=-3;
+ #if DECDPUN>=3
+ t->lsu[0]=259;
+ a->lsu[0]=819;
+ #elif DECDPUN==2
+ t->lsu[0]=59; t->lsu[1]=2;
+ a->lsu[0]=19; a->lsu[1]=8;
+ #else
+ t->lsu[0]=9; t->lsu[1]=5; t->lsu[2]=2;
+ a->lsu[0]=9; a->lsu[1]=1; a->lsu[2]=8;
+ #endif
+ }
+ else { // odd exponent
+ // Set t=0.0819, a=2.59
+ f->exponent--; // f=f/10
+ exp++; // e=e+1
+ t->exponent=-4;
+ a->exponent=-2;
+ #if DECDPUN>=3
+ t->lsu[0]=819;
+ a->lsu[0]=259;
+ #elif DECDPUN==2
+ t->lsu[0]=19; t->lsu[1]=8;
+ a->lsu[0]=59; a->lsu[1]=2;
+ #else
+ t->lsu[0]=9; t->lsu[1]=1; t->lsu[2]=8;
+ a->lsu[0]=9; a->lsu[1]=5; a->lsu[2]=2;
+ #endif
+ }
+
+ decMultiplyOp(a, a, f, &workset, &ignore); // a=a*f
+ decAddOp(a, a, t, &workset, 0, &ignore); // ..+t
+ // [a is now the initial approximation for sqrt(f), calculated with
+ // currentprecision, which is also a's precision.]
+
+ // the main calculation loop
+ decNumberZero(&dzero); // make 0
+ decNumberZero(t); // set t = 0.5
+ t->lsu[0]=5; // ..
+ t->exponent=-1; // ..
+ workset.digits=3; // initial p
+ for (; workset.digits<maxp;) {
+ // set p to min(2*p - 2, maxp) [hence 3; or: 4, 6, 10, ... , maxp]
+ workset.digits=MINI(workset.digits*2-2, maxp);
+ // a = 0.5 * (a + f/a)
+ // [calculated at p then rounded to currentprecision]
+ decDivideOp(b, f, a, &workset, DIVIDE, &ignore); // b=f/a
+ decAddOp(b, b, a, &workset, 0, &ignore); // b=b+a
+ decMultiplyOp(a, b, t, &workset, &ignore); // a=b*0.5
+ } // loop
+
+ // Here, 0.1 <= a < 1 [Hull], and a has maxp digits
+ // now reduce to length, etc.; this needs to be done with a
+ // having the correct exponent so as to handle subnormals
+ // correctly
+ approxset=*set; // get emin, emax, etc.
+ approxset.round=DEC_ROUND_HALF_EVEN;
+ a->exponent+=exp/2; // set correct exponent
+ rstatus=0; // clear status
+ residue=0; // .. and accumulator
+ decCopyFit(a, a, &approxset, &residue, &rstatus); // reduce (if needed)
+ decFinish(a, &approxset, &residue, &rstatus); // clean and finalize
+
+ // Overflow was possible if the input exponent was out-of-range,
+ // in which case quit
+ if (rstatus&DEC_Overflow) {
+ status=rstatus; // use the status as-is
+ decNumberCopy(res, a); // copy to result
+ break;
+ }
+
+ // Preserve status except Inexact/Rounded
+ status|=(rstatus & ~(DEC_Rounded|DEC_Inexact));
+
+ // Carry out the Hull correction
+ a->exponent-=exp/2; // back to 0.1->1
+
+ // a is now at final precision and within 1 ulp of the properly
+ // rounded square root of f; to ensure proper rounding, compare
+ // squares of (a - l/2 ulp) and (a + l/2 ulp) with f.
+ // Here workset.digits=maxp and t=0.5, and a->digits determines
+ // the ulp
+ workset.digits--; // maxp-1 is OK now
+ t->exponent=-a->digits-1; // make 0.5 ulp
+ decAddOp(b, a, t, &workset, DECNEG, &ignore); // b = a - 0.5 ulp
+ workset.round=DEC_ROUND_UP;
+ decMultiplyOp(b, b, b, &workset, &ignore); // b = mulru(b, b)
+ decCompareOp(b, f, b, &workset, COMPARE, &ignore); // b ? f, reversed
+ if (decNumberIsNegative(b)) { // f < b [i.e., b > f]
+ // this is the more common adjustment, though both are rare
+ t->exponent++; // make 1.0 ulp
+ t->lsu[0]=1; // ..
+ decAddOp(a, a, t, &workset, DECNEG, &ignore); // a = a - 1 ulp
+ // assign to approx [round to length]
+ approxset.emin-=exp/2; // adjust to match a
+ approxset.emax-=exp/2;
+ decAddOp(a, &dzero, a, &approxset, 0, &ignore);
+ }
+ else {
+ decAddOp(b, a, t, &workset, 0, &ignore); // b = a + 0.5 ulp
+ workset.round=DEC_ROUND_DOWN;
+ decMultiplyOp(b, b, b, &workset, &ignore); // b = mulrd(b, b)
+ decCompareOp(b, b, f, &workset, COMPARE, &ignore); // b ? f
+ if (decNumberIsNegative(b)) { // b < f
+ t->exponent++; // make 1.0 ulp
+ t->lsu[0]=1; // ..
+ decAddOp(a, a, t, &workset, 0, &ignore); // a = a + 1 ulp
+ // assign to approx [round to length]
+ approxset.emin-=exp/2; // adjust to match a
+ approxset.emax-=exp/2;
+ decAddOp(a, &dzero, a, &approxset, 0, &ignore);
+ }
+ }
+ // [no errors are possible in the above, and rounding/inexact during
+ // estimation are irrelevant, so status was not accumulated]
+
+ // Here, 0.1 <= a < 1 (still), so adjust back
+ a->exponent+=exp/2; // set correct exponent
+
+ // count droppable zeros [after any subnormal rounding] by
+ // trimming a copy
+ decNumberCopy(b, a);
+ decTrim(b, set, 1, 1, &dropped); // [drops trailing zeros]
+
+ // Set Inexact and Rounded. The answer can only be exact if
+ // it is short enough so that squaring it could fit in workp
+ // digits, so this is the only (relatively rare) condition that
+ // a careful check is needed
+ if (b->digits*2-1 > workp) { // cannot fit
+ status|=DEC_Inexact|DEC_Rounded;
+ }
+ else { // could be exact/unrounded
+ uInt mstatus=0; // local status
+ decMultiplyOp(b, b, b, &workset, &mstatus); // try the multiply
+ if (mstatus&DEC_Overflow) { // result just won't fit
+ status|=DEC_Inexact|DEC_Rounded;
+ }
+ else { // plausible
+ decCompareOp(t, b, rhs, &workset, COMPARE, &mstatus); // b ? rhs
+ if (!ISZERO(t)) status|=DEC_Inexact|DEC_Rounded; // not equal
+ else { // is Exact
+ // here, dropped is the count of trailing zeros in 'a'
+ // use closest exponent to ideal...
+ Int todrop=ideal-a->exponent; // most that can be dropped
+ if (todrop<0) status|=DEC_Rounded; // ideally would add 0s
+ else { // unrounded
+ // there are some to drop, but emax may not allow all
+ Int maxexp=set->emax-set->digits+1;
+ Int maxdrop=maxexp-a->exponent;
+ if (todrop>maxdrop && set->clamp) { // apply clamping
+ todrop=maxdrop;
+ status|=DEC_Clamped;
+ }
+ if (dropped<todrop) { // clamp to those available
+ todrop=dropped;
+ status|=DEC_Clamped;
+ }
+ if (todrop>0) { // have some to drop
+ decShiftToLeast(a->lsu, D2U(a->digits), todrop);
+ a->exponent+=todrop; // maintain numerical value
+ a->digits-=todrop; // new length
+ }
+ }
+ }
+ }
+ }
+
+ // double-check Underflow, as perhaps the result could not have
+ // been subnormal (initial argument too big), or it is now Exact
+ if (status&DEC_Underflow) {
+ Int ae=rhs->exponent+rhs->digits-1; // adjusted exponent
+ // check if truly subnormal
+ #if DECEXTFLAG // DEC_Subnormal too
+ if (ae>=set->emin*2) status&=~(DEC_Subnormal|DEC_Underflow);
+ #else
+ if (ae>=set->emin*2) status&=~DEC_Underflow;
+ #endif
+ // check if truly inexact
+ if (!(status&DEC_Inexact)) status&=~DEC_Underflow;
+ }
+
+ decNumberCopy(res, a); // a is now the result
+ } while(0); // end protected
+
+ if (allocbuff!=NULL) free(allocbuff); // drop any storage used
+ if (allocbufa!=NULL) free(allocbufa); // ..
+ if (allocbufb!=NULL) free(allocbufb); // ..
+ #if DECSUBSET
+ if (allocrhs !=NULL) free(allocrhs); // ..
+ #endif
+ if (status!=0) decStatus(res, status, set);// then report status
+ #if DECCHECK
+ decCheckInexact(res, set);
+ #endif
+ return res;
+ } // decNumberSquareRoot
+
+/* ------------------------------------------------------------------ */
+/* decNumberSubtract -- subtract two Numbers */
+/* */
+/* This computes C = A - B */
+/* */
+/* res is C, the result. C may be A and/or B (e.g., X=X-X) */
+/* lhs is A */
+/* rhs is B */
+/* set is the context */
+/* */
+/* C must have space for set->digits digits. */
+/* ------------------------------------------------------------------ */
+decNumber * decNumberSubtract(decNumber *res, const decNumber *lhs,
+ const decNumber *rhs, decContext *set) {
+ uInt status=0; // accumulator
+
+ decAddOp(res, lhs, rhs, set, DECNEG, &status);
+ if (status!=0) decStatus(res, status, set);
+ #if DECCHECK
+ decCheckInexact(res, set);
+ #endif
+ return res;
+ } // decNumberSubtract
+
+/* ------------------------------------------------------------------ */
+/* decNumberToIntegralExact -- round-to-integral-value with InExact */
+/* decNumberToIntegralValue -- round-to-integral-value */
+/* */
+/* res is the result */
+/* rhs is input number */
+/* set is the context */
+/* */
+/* res must have space for any value of rhs. */
+/* */
+/* This implements the IEEE special operators and therefore treats */
+/* special values as valid. For finite numbers it returns */
+/* rescale(rhs, 0) if rhs->exponent is <0. */
+/* Otherwise the result is rhs (so no error is possible, except for */
+/* sNaN). */
+/* */
+/* The context is used for rounding mode and status after sNaN, but */
+/* the digits setting is ignored. The Exact version will signal */
+/* Inexact if the result differs numerically from rhs; the other */
+/* never signals Inexact. */
+/* ------------------------------------------------------------------ */
+decNumber * decNumberToIntegralExact(decNumber *res, const decNumber *rhs,
+ decContext *set) {
+ decNumber dn;
+ decContext workset; // working context
+ uInt status=0; // accumulator
+
+ #if DECCHECK
+ if (decCheckOperands(res, DECUNUSED, rhs, set)) return res;
+ #endif
+
+ // handle infinities and NaNs
+ if (SPECIALARG) {
+ if (decNumberIsInfinite(rhs)) decNumberCopy(res, rhs); // an Infinity
+ else decNaNs(res, rhs, NULL, set, &status); // a NaN
+ }
+ else { // finite
+ // have a finite number; no error possible (res must be big enough)
+ if (rhs->exponent>=0) return decNumberCopy(res, rhs);
+ // that was easy, but if negative exponent there is work to do...
+ workset=*set; // clone rounding, etc.
+ workset.digits=rhs->digits; // no length rounding
+ workset.traps=0; // no traps
+ decNumberZero(&dn); // make a number with exponent 0
+ decNumberQuantize(res, rhs, &dn, &workset);
+ status|=workset.status;
+ }
+ if (status!=0) decStatus(res, status, set);
+ return res;
+ } // decNumberToIntegralExact
+
+decNumber * decNumberToIntegralValue(decNumber *res, const decNumber *rhs,
+ decContext *set) {
+ decContext workset=*set; // working context
+ workset.traps=0; // no traps
+ decNumberToIntegralExact(res, rhs, &workset);
+ // this never affects set, except for sNaNs; NaN will have been set
+ // or propagated already, so no need to call decStatus
+ set->status|=workset.status&DEC_Invalid_operation;
+ return res;
+ } // decNumberToIntegralValue
+
+/* ------------------------------------------------------------------ */
+/* decNumberXor -- XOR two Numbers, digitwise */
+/* */
+/* This computes C = A ^ B */
+/* */
+/* res is C, the result. C may be A and/or B (e.g., X=X^X) */
+/* lhs is A */
+/* rhs is B */
+/* set is the context (used for result length and error report) */
+/* */
+/* C must have space for set->digits digits. */
+/* */
+/* Logical function restrictions apply (see above); a NaN is */
+/* returned with Invalid_operation if a restriction is violated. */
+/* ------------------------------------------------------------------ */
+decNumber * decNumberXor(decNumber *res, const decNumber *lhs,
+ const decNumber *rhs, decContext *set) {
+ const Unit *ua, *ub; // -> operands
+ const Unit *msua, *msub; // -> operand msus
+ Unit *uc, *msuc; // -> result and its msu
+ Int msudigs; // digits in res msu
+ #if DECCHECK
+ if (decCheckOperands(res, lhs, rhs, set)) return res;
+ #endif
+
+ if (lhs->exponent!=0 || decNumberIsSpecial(lhs) || decNumberIsNegative(lhs)
+ || rhs->exponent!=0 || decNumberIsSpecial(rhs) || decNumberIsNegative(rhs)) {
+ decStatus(res, DEC_Invalid_operation, set);
+ return res;
+ }
+ // operands are valid
+ ua=lhs->lsu; // bottom-up
+ ub=rhs->lsu; // ..
+ uc=res->lsu; // ..
+ msua=ua+D2U(lhs->digits)-1; // -> msu of lhs
+ msub=ub+D2U(rhs->digits)-1; // -> msu of rhs
+ msuc=uc+D2U(set->digits)-1; // -> msu of result
+ msudigs=MSUDIGITS(set->digits); // [faster than remainder]
+ for (; uc<=msuc; ua++, ub++, uc++) { // Unit loop
+ Unit a, b; // extract units
+ if (ua>msua) a=0;
+ else a=*ua;
+ if (ub>msub) b=0;
+ else b=*ub;
+ *uc=0; // can now write back
+ if (a|b) { // maybe 1 bits to examine
+ Int i, j;
+ // This loop could be unrolled and/or use BIN2BCD tables
+ for (i=0; i<DECDPUN; i++) {
+ if ((a^b)&1) *uc=*uc+(Unit)powers[i]; // effect XOR
+ j=a%10;
+ a=a/10;
+ j|=b%10;
+ b=b/10;
+ if (j>1) {
+ decStatus(res, DEC_Invalid_operation, set);
+ return res;
+ }
+ if (uc==msuc && i==msudigs-1) break; // just did final digit
+ } // each digit
+ } // non-zero
+ } // each unit
+ // [here uc-1 is the msu of the result]
+ res->digits=decGetDigits(res->lsu, uc-res->lsu);
+ res->exponent=0; // integer
+ res->bits=0; // sign=0
+ return res; // [no status to set]
+ } // decNumberXor
+
+
+/* ================================================================== */
+/* Utility routines */
+/* ================================================================== */
+
+/* ------------------------------------------------------------------ */
+/* decNumberClass -- return the decClass of a decNumber */
+/* dn -- the decNumber to test */
+/* set -- the context to use for Emin */
+/* returns the decClass enum */
+/* ------------------------------------------------------------------ */
+enum decClass decNumberClass(const decNumber *dn, decContext *set) {
+ if (decNumberIsSpecial(dn)) {
+ if (decNumberIsQNaN(dn)) return DEC_CLASS_QNAN;
+ if (decNumberIsSNaN(dn)) return DEC_CLASS_SNAN;
+ // must be an infinity
+ if (decNumberIsNegative(dn)) return DEC_CLASS_NEG_INF;
+ return DEC_CLASS_POS_INF;
+ }
+ // is finite
+ if (decNumberIsNormal(dn, set)) { // most common
+ if (decNumberIsNegative(dn)) return DEC_CLASS_NEG_NORMAL;
+ return DEC_CLASS_POS_NORMAL;
+ }
+ // is subnormal or zero
+ if (decNumberIsZero(dn)) { // most common
+ if (decNumberIsNegative(dn)) return DEC_CLASS_NEG_ZERO;
+ return DEC_CLASS_POS_ZERO;
+ }
+ if (decNumberIsNegative(dn)) return DEC_CLASS_NEG_SUBNORMAL;
+ return DEC_CLASS_POS_SUBNORMAL;
+ } // decNumberClass
+
+/* ------------------------------------------------------------------ */
+/* decNumberClassToString -- convert decClass to a string */
+/* */
+/* eclass is a valid decClass */
+/* returns a constant string describing the class (max 13+1 chars) */
+/* ------------------------------------------------------------------ */
+const char *decNumberClassToString(enum decClass eclass) {
+ if (eclass==DEC_CLASS_POS_NORMAL) return DEC_ClassString_PN;
+ if (eclass==DEC_CLASS_NEG_NORMAL) return DEC_ClassString_NN;
+ if (eclass==DEC_CLASS_POS_ZERO) return DEC_ClassString_PZ;
+ if (eclass==DEC_CLASS_NEG_ZERO) return DEC_ClassString_NZ;
+ if (eclass==DEC_CLASS_POS_SUBNORMAL) return DEC_ClassString_PS;
+ if (eclass==DEC_CLASS_NEG_SUBNORMAL) return DEC_ClassString_NS;
+ if (eclass==DEC_CLASS_POS_INF) return DEC_ClassString_PI;
+ if (eclass==DEC_CLASS_NEG_INF) return DEC_ClassString_NI;
+ if (eclass==DEC_CLASS_QNAN) return DEC_ClassString_QN;
+ if (eclass==DEC_CLASS_SNAN) return DEC_ClassString_SN;
+ return DEC_ClassString_UN; // Unknown
+ } // decNumberClassToString
+
+/* ------------------------------------------------------------------ */
+/* decNumberCopy -- copy a number */
+/* */
+/* dest is the target decNumber */
+/* src is the source decNumber */
+/* returns dest */
+/* */
+/* (dest==src is allowed and is a no-op) */
+/* All fields are updated as required. This is a utility operation, */
+/* so special values are unchanged and no error is possible. */
+/* ------------------------------------------------------------------ */
+decNumber * decNumberCopy(decNumber *dest, const decNumber *src) {
+
+ #if DECCHECK
+ if (src==NULL) return decNumberZero(dest);
+ #endif
+
+ if (dest==src) return dest; // no copy required
+
+ // Use explicit assignments here as structure assignment could copy
+ // more than just the lsu (for small DECDPUN). This would not affect
+ // the value of the results, but could disturb test harness spill
+ // checking.
+ dest->bits=src->bits;
+ dest->exponent=src->exponent;
+ dest->digits=src->digits;
+ dest->lsu[0]=src->lsu[0];
+ if (src->digits>DECDPUN) { // more Units to come
+ const Unit *smsup, *s; // work
+ Unit *d; // ..
+ // memcpy for the remaining Units would be safe as they cannot
+ // overlap. However, this explicit loop is faster in short cases.
+ d=dest->lsu+1; // -> first destination
+ smsup=src->lsu+D2U(src->digits); // -> source msu+1
+ for (s=src->lsu+1; s<smsup; s++, d++) *d=*s;
+ }
+ return dest;
+ } // decNumberCopy
+
+/* ------------------------------------------------------------------ */
+/* decNumberCopyAbs -- quiet absolute value operator */
+/* */
+/* This sets C = abs(A) */
+/* */
+/* res is C, the result. C may be A */
+/* rhs is A */
+/* */
+/* C must have space for set->digits digits. */
+/* No exception or error can occur; this is a quiet bitwise operation.*/
+/* See also decNumberAbs for a checking version of this. */
+/* ------------------------------------------------------------------ */
+decNumber * decNumberCopyAbs(decNumber *res, const decNumber *rhs) {
+ #if DECCHECK
+ if (decCheckOperands(res, DECUNUSED, rhs, DECUNCONT)) return res;
+ #endif
+ decNumberCopy(res, rhs);
+ res->bits&=~DECNEG; // turn off sign
+ return res;
+ } // decNumberCopyAbs
+
+/* ------------------------------------------------------------------ */
+/* decNumberCopyNegate -- quiet negate value operator */
+/* */
+/* This sets C = negate(A) */
+/* */
+/* res is C, the result. C may be A */
+/* rhs is A */
+/* */
+/* C must have space for set->digits digits. */
+/* No exception or error can occur; this is a quiet bitwise operation.*/
+/* See also decNumberMinus for a checking version of this. */
+/* ------------------------------------------------------------------ */
+decNumber * decNumberCopyNegate(decNumber *res, const decNumber *rhs) {
+ #if DECCHECK
+ if (decCheckOperands(res, DECUNUSED, rhs, DECUNCONT)) return res;
+ #endif
+ decNumberCopy(res, rhs);
+ res->bits^=DECNEG; // invert the sign
+ return res;
+ } // decNumberCopyNegate
+
+/* ------------------------------------------------------------------ */
+/* decNumberCopySign -- quiet copy and set sign operator */
+/* */
+/* This sets C = A with the sign of B */
+/* */
+/* res is C, the result. C may be A */
+/* lhs is A */
+/* rhs is B */
+/* */
+/* C must have space for set->digits digits. */
+/* No exception or error can occur; this is a quiet bitwise operation.*/
+/* ------------------------------------------------------------------ */
+decNumber * decNumberCopySign(decNumber *res, const decNumber *lhs,
+ const decNumber *rhs) {
+ uByte sign; // rhs sign
+ #if DECCHECK
+ if (decCheckOperands(res, DECUNUSED, rhs, DECUNCONT)) return res;
+ #endif
+ sign=rhs->bits & DECNEG; // save sign bit
+ decNumberCopy(res, lhs);
+ res->bits&=~DECNEG; // clear the sign
+ res->bits|=sign; // set from rhs
+ return res;
+ } // decNumberCopySign
+
+/* ------------------------------------------------------------------ */
+/* decNumberGetBCD -- get the coefficient in BCD8 */
+/* dn is the source decNumber */
+/* bcd is the uInt array that will receive dn->digits BCD bytes, */
+/* most-significant at offset 0 */
+/* returns bcd */
+/* */
+/* bcd must have at least dn->digits bytes. No error is possible; if */
+/* dn is a NaN or Infinite, digits must be 1 and the coefficient 0. */
+/* ------------------------------------------------------------------ */
+uByte * decNumberGetBCD(const decNumber *dn, uByte *bcd) {
+ uByte *ub=bcd+dn->digits-1; // -> lsd
+ const Unit *up=dn->lsu; // Unit pointer, -> lsu
+
+ #if DECDPUN==1 // trivial simple copy
+ for (; ub>=bcd; ub--, up++) *ub=*up;
+ #else // chopping needed
+ uInt u=*up; // work
+ uInt cut=DECDPUN; // downcounter through unit
+ for (; ub>=bcd; ub--) {
+ *ub=(uByte)(u%10); // [*6554 trick inhibits, here]
+ u=u/10;
+ cut--;
+ if (cut>0) continue; // more in this unit
+ up++;
+ u=*up;
+ cut=DECDPUN;
+ }
+ #endif
+ return bcd;
+ } // decNumberGetBCD
+
+/* ------------------------------------------------------------------ */
+/* decNumberSetBCD -- set (replace) the coefficient from BCD8 */
+/* dn is the target decNumber */
+/* bcd is the uInt array that will source n BCD bytes, most- */
+/* significant at offset 0 */
+/* n is the number of digits in the source BCD array (bcd) */
+/* returns dn */
+/* */
+/* dn must have space for at least n digits. No error is possible; */
+/* if dn is a NaN, or Infinite, or is to become a zero, n must be 1 */
+/* and bcd[0] zero. */
+/* ------------------------------------------------------------------ */
+decNumber * decNumberSetBCD(decNumber *dn, const uByte *bcd, uInt n) {
+ Unit *up=dn->lsu+D2U(dn->digits)-1; // -> msu [target pointer]
+ const uByte *ub=bcd; // -> source msd
+
+ #if DECDPUN==1 // trivial simple copy
+ for (; ub<bcd+n; ub++, up--) *up=*ub;
+ #else // some assembly needed
+ // calculate how many digits in msu, and hence first cut
+ Int cut=MSUDIGITS(n); // [faster than remainder]
+ for (;up>=dn->lsu; up--) { // each Unit from msu
+ *up=0; // will take <=DECDPUN digits
+ for (; cut>0; ub++, cut--) *up=X10(*up)+*ub;
+ cut=DECDPUN; // next Unit has all digits
+ }
+ #endif
+ dn->digits=n; // set digit count
+ return dn;
+ } // decNumberSetBCD
+
+/* ------------------------------------------------------------------ */
+/* decNumberIsNormal -- test normality of a decNumber */
+/* dn is the decNumber to test */
+/* set is the context to use for Emin */
+/* returns 1 if |dn| is finite and >=Nmin, 0 otherwise */
+/* ------------------------------------------------------------------ */
+Int decNumberIsNormal(const decNumber *dn, decContext *set) {
+ Int ae; // adjusted exponent
+ #if DECCHECK
+ if (decCheckOperands(DECUNRESU, DECUNUSED, dn, set)) return 0;
+ #endif
+
+ if (decNumberIsSpecial(dn)) return 0; // not finite
+ if (decNumberIsZero(dn)) return 0; // not non-zero
+
+ ae=dn->exponent+dn->digits-1; // adjusted exponent
+ if (ae<set->emin) return 0; // is subnormal
+ return 1;
+ } // decNumberIsNormal
+
+/* ------------------------------------------------------------------ */
+/* decNumberIsSubnormal -- test subnormality of a decNumber */
+/* dn is the decNumber to test */
+/* set is the context to use for Emin */
+/* returns 1 if |dn| is finite, non-zero, and <Nmin, 0 otherwise */
+/* ------------------------------------------------------------------ */
+Int decNumberIsSubnormal(const decNumber *dn, decContext *set) {
+ Int ae; // adjusted exponent
+ #if DECCHECK
+ if (decCheckOperands(DECUNRESU, DECUNUSED, dn, set)) return 0;
+ #endif
+
+ if (decNumberIsSpecial(dn)) return 0; // not finite
+ if (decNumberIsZero(dn)) return 0; // not non-zero
+
+ ae=dn->exponent+dn->digits-1; // adjusted exponent
+ if (ae<set->emin) return 1; // is subnormal
+ return 0;
+ } // decNumberIsSubnormal
+
+/* ------------------------------------------------------------------ */
+/* decNumberTrim -- remove insignificant zeros */
+/* */
+/* dn is the number to trim */
+/* returns dn */
+/* */
+/* All fields are updated as required. This is a utility operation, */
+/* so special values are unchanged and no error is possible. The */
+/* zeros are removed unconditionally. */
+/* ------------------------------------------------------------------ */
+decNumber * decNumberTrim(decNumber *dn) {
+ Int dropped; // work
+ decContext set; // ..
+ #if DECCHECK
+ if (decCheckOperands(DECUNRESU, DECUNUSED, dn, DECUNCONT)) return dn;
+ #endif
+ decContextDefault(&set, DEC_INIT_BASE); // clamp=0
+ return decTrim(dn, &set, 0, 1, &dropped);
+ } // decNumberTrim
+
+/* ------------------------------------------------------------------ */
+/* decNumberVersion -- return the name and version of this module */
+/* */
+/* No error is possible. */
+/* ------------------------------------------------------------------ */
+const char * decNumberVersion(void) {
+ return DECVERSION;
+ } // decNumberVersion
+
+/* ------------------------------------------------------------------ */
+/* decNumberZero -- set a number to 0 */
+/* */
+/* dn is the number to set, with space for one digit */
+/* returns dn */
+/* */
+/* No error is possible. */
+/* ------------------------------------------------------------------ */
+// Memset is not used as it is much slower in some environments.
+decNumber * decNumberZero(decNumber *dn) {
+
+ #if DECCHECK
+ if (decCheckOperands(dn, DECUNUSED, DECUNUSED, DECUNCONT)) return dn;
+ #endif
+
+ dn->bits=0;
+ dn->exponent=0;
+ dn->digits=1;
+ dn->lsu[0]=0;
+ return dn;
+ } // decNumberZero
+
+/* ================================================================== */
+/* Local routines */
+/* ================================================================== */
+
+/* ------------------------------------------------------------------ */
+/* decToString -- lay out a number into a string */
+/* */
+/* dn is the number to lay out */
+/* string is where to lay out the number */
+/* eng is 1 if Engineering, 0 if Scientific */
+/* */
+/* string must be at least dn->digits+14 characters long */
+/* No error is possible. */
+/* */
+/* Note that this routine can generate a -0 or 0.000. These are */
+/* never generated in subset to-number or arithmetic, but can occur */
+/* in non-subset arithmetic (e.g., -1*0 or 1.234-1.234). */
+/* ------------------------------------------------------------------ */
+// If DECCHECK is enabled the string "?" is returned if a number is
+// invalid.
+static void decToString(const decNumber *dn, char *string, Flag eng) {
+ Int exp=dn->exponent; // local copy
+ Int e; // E-part value
+ Int pre; // digits before the '.'
+ Int cut; // for counting digits in a Unit
+ char *c=string; // work [output pointer]
+ const Unit *up=dn->lsu+D2U(dn->digits)-1; // -> msu [input pointer]
+ uInt u, pow; // work
+
+ #if DECCHECK
+ if (decCheckOperands(DECUNRESU, dn, DECUNUSED, DECUNCONT)) {
+ strcpy(string, "?");
+ return;}
+ #endif
+
+ if (decNumberIsNegative(dn)) { // Negatives get a minus
+ *c='-';
+ c++;
+ }
+ if (dn->bits&DECSPECIAL) { // Is a special value
+ if (decNumberIsInfinite(dn)) {
+ strcpy(c, "Inf");
+ strcpy(c+3, "inity");
+ return;}
+ // a NaN
+ if (dn->bits&DECSNAN) { // signalling NaN
+ *c='s';
+ c++;
+ }
+ strcpy(c, "NaN");
+ c+=3; // step past
+ // if not a clean non-zero coefficient, that's all there is in a
+ // NaN string
+ if (exp!=0 || (*dn->lsu==0 && dn->digits==1)) return;
+ // [drop through to add integer]
+ }
+
+ // calculate how many digits in msu, and hence first cut
+ cut=MSUDIGITS(dn->digits); // [faster than remainder]
+ cut--; // power of ten for digit
+
+ if (exp==0) { // simple integer [common fastpath]
+ for (;up>=dn->lsu; up--) { // each Unit from msu
+ u=*up; // contains DECDPUN digits to lay out
+ for (; cut>=0; c++, cut--) TODIGIT(u, cut, c, pow);
+ cut=DECDPUN-1; // next Unit has all digits
+ }
+ *c='\0'; // terminate the string
+ return;}
+
+ /* non-0 exponent -- assume plain form */
+ pre=dn->digits+exp; // digits before '.'
+ e=0; // no E
+ if ((exp>0) || (pre<-5)) { // need exponential form
+ e=exp+dn->digits-1; // calculate E value
+ pre=1; // assume one digit before '.'
+ if (eng && (e!=0)) { // engineering: may need to adjust
+ Int adj; // adjustment
+ // The C remainder operator is undefined for negative numbers, so
+ // a positive remainder calculation must be used here
+ if (e<0) {
+ adj=(-e)%3;
+ if (adj!=0) adj=3-adj;
+ }
+ else { // e>0
+ adj=e%3;
+ }
+ e=e-adj;
+ // if dealing with zero still produce an exponent which is a
+ // multiple of three, as expected, but there will only be the
+ // one zero before the E, still. Otherwise note the padding.
+ if (!ISZERO(dn)) pre+=adj;
+ else { // is zero
+ if (adj!=0) { // 0.00Esnn needed
+ e=e+3;
+ pre=-(2-adj);
+ }
+ } // zero
+ } // eng
+ } // need exponent
+
+ /* lay out the digits of the coefficient, adding 0s and . as needed */
+ u=*up;
+ if (pre>0) { // xxx.xxx or xx00 (engineering) form
+ Int n=pre;
+ for (; pre>0; pre--, c++, cut--) {
+ if (cut<0) { // need new Unit
+ if (up==dn->lsu) break; // out of input digits (pre>digits)
+ up--;
+ cut=DECDPUN-1;
+ u=*up;
+ }
+ TODIGIT(u, cut, c, pow);
+ }
+ if (n<dn->digits) { // more to come, after '.'
+ *c='.'; c++;
+ for (;; c++, cut--) {
+ if (cut<0) { // need new Unit
+ if (up==dn->lsu) break; // out of input digits
+ up--;
+ cut=DECDPUN-1;
+ u=*up;
+ }
+ TODIGIT(u, cut, c, pow);
+ }
+ }
+ else for (; pre>0; pre--, c++) *c='0'; // 0 padding (for engineering) needed
+ }
+ else { // 0.xxx or 0.000xxx form
+ *c='0'; c++;
+ *c='.'; c++;
+ for (; pre<0; pre++, c++) *c='0'; // add any 0's after '.'
+ for (; ; c++, cut--) {
+ if (cut<0) { // need new Unit
+ if (up==dn->lsu) break; // out of input digits
+ up--;
+ cut=DECDPUN-1;
+ u=*up;
+ }
+ TODIGIT(u, cut, c, pow);
+ }
+ }
+
+ /* Finally add the E-part, if needed. It will never be 0, has a
+ base maximum and minimum of +999999999 through -999999999, but
+ could range down to -1999999998 for anormal numbers */
+ if (e!=0) {
+ Flag had=0; // 1=had non-zero
+ *c='E'; c++;
+ *c='+'; c++; // assume positive
+ u=e; // ..
+ if (e<0) {
+ *(c-1)='-'; // oops, need -
+ u=-e; // uInt, please
+ }
+ // lay out the exponent [_itoa or equivalent is not ANSI C]
+ for (cut=9; cut>=0; cut--) {
+ TODIGIT(u, cut, c, pow);
+ if (*c=='0' && !had) continue; // skip leading zeros
+ had=1; // had non-0
+ c++; // step for next
+ } // cut
+ }
+ *c='\0'; // terminate the string (all paths)
+ return;
+ } // decToString
+
+/* ------------------------------------------------------------------ */
+/* decAddOp -- add/subtract operation */
+/* */
+/* This computes C = A + B */
+/* */
+/* res is C, the result. C may be A and/or B (e.g., X=X+X) */
+/* lhs is A */
+/* rhs is B */
+/* set is the context */
+/* negate is DECNEG if rhs should be negated, or 0 otherwise */
+/* status accumulates status for the caller */
+/* */
+/* C must have space for set->digits digits. */
+/* Inexact in status must be 0 for correct Exact zero sign in result */
+/* ------------------------------------------------------------------ */
+/* If possible, the coefficient is calculated directly into C. */
+/* However, if: */
+/* -- a digits+1 calculation is needed because the numbers are */
+/* unaligned and span more than set->digits digits */
+/* -- a carry to digits+1 digits looks possible */
+/* -- C is the same as A or B, and the result would destructively */
+/* overlap the A or B coefficient */
+/* then the result must be calculated into a temporary buffer. In */
+/* this case a local (stack) buffer is used if possible, and only if */
+/* too long for that does malloc become the final resort. */
+/* */
+/* Misalignment is handled as follows: */
+/* Apad: (AExp>BExp) Swap operands and proceed as for BExp>AExp. */
+/* BPad: Apply the padding by a combination of shifting (whole */
+/* units) and multiplication (part units). */
+/* */
+/* Addition, especially x=x+1, is speed-critical. */
+/* The static buffer is larger than might be expected to allow for */
+/* calls from higher-level funtions (notable exp). */
+/* ------------------------------------------------------------------ */
+static decNumber * decAddOp(decNumber *res, const decNumber *lhs,
+ const decNumber *rhs, decContext *set,
+ uByte negate, uInt *status) {
+ #if DECSUBSET
+ decNumber *alloclhs=NULL; // non-NULL if rounded lhs allocated
+ decNumber *allocrhs=NULL; // .., rhs
+ #endif
+ Int rhsshift; // working shift (in Units)
+ Int maxdigits; // longest logical length
+ Int mult; // multiplier
+ Int residue; // rounding accumulator
+ uByte bits; // result bits
+ Flag diffsign; // non-0 if arguments have different sign
+ Unit *acc; // accumulator for result
+ Unit accbuff[SD2U(DECBUFFER*2+20)]; // local buffer [*2+20 reduces many
+ // allocations when called from
+ // other operations, notable exp]
+ Unit *allocacc=NULL; // -> allocated acc buffer, iff allocated
+ Int reqdigits=set->digits; // local copy; requested DIGITS
+ Int padding; // work
+
+ #if DECCHECK
+ if (decCheckOperands(res, lhs, rhs, set)) return res;
+ #endif
+
+ do { // protect allocated storage
+ #if DECSUBSET
+ if (!set->extended) {
+ // reduce operands and set lostDigits status, as needed
+ if (lhs->digits>reqdigits) {
+ alloclhs=decRoundOperand(lhs, set, status);
+ if (alloclhs==NULL) break;
+ lhs=alloclhs;
+ }
+ if (rhs->digits>reqdigits) {
+ allocrhs=decRoundOperand(rhs, set, status);
+ if (allocrhs==NULL) break;
+ rhs=allocrhs;
+ }
+ }
+ #endif
+ // [following code does not require input rounding]
+
+ // note whether signs differ [used all paths]
+ diffsign=(Flag)((lhs->bits^rhs->bits^negate)&DECNEG);
+
+ // handle infinities and NaNs
+ if (SPECIALARGS) { // a special bit set
+ if (SPECIALARGS & (DECSNAN | DECNAN)) // a NaN
+ decNaNs(res, lhs, rhs, set, status);
+ else { // one or two infinities
+ if (decNumberIsInfinite(lhs)) { // LHS is infinity
+ // two infinities with different signs is invalid
+ if (decNumberIsInfinite(rhs) && diffsign) {
+ *status|=DEC_Invalid_operation;
+ break;
+ }
+ bits=lhs->bits & DECNEG; // get sign from LHS
+ }
+ else bits=(rhs->bits^negate) & DECNEG;// RHS must be Infinity
+ bits|=DECINF;
+ decNumberZero(res);
+ res->bits=bits; // set +/- infinity
+ } // an infinity
+ break;
+ }
+
+ // Quick exit for add 0s; return the non-0, modified as need be
+ if (ISZERO(lhs)) {
+ Int adjust; // work
+ Int lexp=lhs->exponent; // save in case LHS==RES
+ bits=lhs->bits; // ..
+ residue=0; // clear accumulator
+ decCopyFit(res, rhs, set, &residue, status); // copy (as needed)
+ res->bits^=negate; // flip if rhs was negated
+ #if DECSUBSET
+ if (set->extended) { // exponents on zeros count
+ #endif
+ // exponent will be the lower of the two
+ adjust=lexp-res->exponent; // adjustment needed [if -ve]
+ if (ISZERO(res)) { // both 0: special IEEE 754 rules
+ if (adjust<0) res->exponent=lexp; // set exponent
+ // 0-0 gives +0 unless rounding to -infinity, and -0-0 gives -0
+ if (diffsign) {
+ if (set->round!=DEC_ROUND_FLOOR) res->bits=0;
+ else res->bits=DECNEG; // preserve 0 sign
+ }
+ }
+ else { // non-0 res
+ if (adjust<0) { // 0-padding needed
+ if ((res->digits-adjust)>set->digits) {
+ adjust=res->digits-set->digits; // to fit exactly
+ *status|=DEC_Rounded; // [but exact]
+ }
+ res->digits=decShiftToMost(res->lsu, res->digits, -adjust);
+ res->exponent+=adjust; // set the exponent.
+ }
+ } // non-0 res
+ #if DECSUBSET
+ } // extended
+ #endif
+ decFinish(res, set, &residue, status); // clean and finalize
+ break;}
+
+ if (ISZERO(rhs)) { // [lhs is non-zero]
+ Int adjust; // work
+ Int rexp=rhs->exponent; // save in case RHS==RES
+ bits=rhs->bits; // be clean
+ residue=0; // clear accumulator
+ decCopyFit(res, lhs, set, &residue, status); // copy (as needed)
+ #if DECSUBSET
+ if (set->extended) { // exponents on zeros count
+ #endif
+ // exponent will be the lower of the two
+ // [0-0 case handled above]
+ adjust=rexp-res->exponent; // adjustment needed [if -ve]
+ if (adjust<0) { // 0-padding needed
+ if ((res->digits-adjust)>set->digits) {
+ adjust=res->digits-set->digits; // to fit exactly
+ *status|=DEC_Rounded; // [but exact]
+ }
+ res->digits=decShiftToMost(res->lsu, res->digits, -adjust);
+ res->exponent+=adjust; // set the exponent.
+ }
+ #if DECSUBSET
+ } // extended
+ #endif
+ decFinish(res, set, &residue, status); // clean and finalize
+ break;}
+
+ // [NB: both fastpath and mainpath code below assume these cases
+ // (notably 0-0) have already been handled]
+
+ // calculate the padding needed to align the operands
+ padding=rhs->exponent-lhs->exponent;
+
+ // Fastpath cases where the numbers are aligned and normal, the RHS
+ // is all in one unit, no operand rounding is needed, and no carry,
+ // lengthening, or borrow is needed
+ if (padding==0
+ && rhs->digits<=DECDPUN
+ && rhs->exponent>=set->emin // [some normals drop through]
+ && rhs->exponent<=set->emax-set->digits+1 // [could clamp]
+ && rhs->digits<=reqdigits
+ && lhs->digits<=reqdigits) {
+ Int partial=*lhs->lsu;
+ if (!diffsign) { // adding
+ partial+=*rhs->lsu;
+ if ((partial<=DECDPUNMAX) // result fits in unit
+ && (lhs->digits>=DECDPUN || // .. and no digits-count change
+ partial<(Int)powers[lhs->digits])) { // ..
+ if (res!=lhs) decNumberCopy(res, lhs); // not in place
+ *res->lsu=(Unit)partial; // [copy could have overwritten RHS]
+ break;
+ }
+ // else drop out for careful add
+ }
+ else { // signs differ
+ partial-=*rhs->lsu;
+ if (partial>0) { // no borrow needed, and non-0 result
+ if (res!=lhs) decNumberCopy(res, lhs); // not in place
+ *res->lsu=(Unit)partial;
+ // this could have reduced digits [but result>0]
+ res->digits=decGetDigits(res->lsu, D2U(res->digits));
+ break;
+ }
+ // else drop out for careful subtract
+ }
+ }
+
+ // Now align (pad) the lhs or rhs so they can be added or
+ // subtracted, as necessary. If one number is much larger than
+ // the other (that is, if in plain form there is a least one
+ // digit between the lowest digit of one and the highest of the
+ // other) padding with up to DIGITS-1 trailing zeros may be
+ // needed; then apply rounding (as exotic rounding modes may be
+ // affected by the residue).
+ rhsshift=0; // rhs shift to left (padding) in Units
+ bits=lhs->bits; // assume sign is that of LHS
+ mult=1; // likely multiplier
+
+ // [if padding==0 the operands are aligned; no padding is needed]
+ if (padding!=0) {
+ // some padding needed; always pad the RHS, as any required
+ // padding can then be effected by a simple combination of
+ // shifts and a multiply
+ Flag swapped=0;
+ if (padding<0) { // LHS needs the padding
+ const decNumber *t;
+ padding=-padding; // will be +ve
+ bits=(uByte)(rhs->bits^negate); // assumed sign is now that of RHS
+ t=lhs; lhs=rhs; rhs=t;
+ swapped=1;
+ }
+
+ // If, after pad, rhs would be longer than lhs by digits+1 or
+ // more then lhs cannot affect the answer, except as a residue,
+ // so only need to pad up to a length of DIGITS+1.
+ if (rhs->digits+padding > lhs->digits+reqdigits+1) {
+ // The RHS is sufficient
+ // for residue use the relative sign indication...
+ Int shift=reqdigits-rhs->digits; // left shift needed
+ residue=1; // residue for rounding
+ if (diffsign) residue=-residue; // signs differ
+ // copy, shortening if necessary
+ decCopyFit(res, rhs, set, &residue, status);
+ // if it was already shorter, then need to pad with zeros
+ if (shift>0) {
+ res->digits=decShiftToMost(res->lsu, res->digits, shift);
+ res->exponent-=shift; // adjust the exponent.
+ }
+ // flip the result sign if unswapped and rhs was negated
+ if (!swapped) res->bits^=negate;
+ decFinish(res, set, &residue, status); // done
+ break;}
+
+ // LHS digits may affect result
+ rhsshift=D2U(padding+1)-1; // this much by Unit shift ..
+ mult=powers[padding-(rhsshift*DECDPUN)]; // .. this by multiplication
+ } // padding needed
+
+ if (diffsign) mult=-mult; // signs differ
+
+ // determine the longer operand
+ maxdigits=rhs->digits+padding; // virtual length of RHS
+ if (lhs->digits>maxdigits) maxdigits=lhs->digits;
+
+ // Decide on the result buffer to use; if possible place directly
+ // into result.
+ acc=res->lsu; // assume add direct to result
+ // If destructive overlap, or the number is too long, or a carry or
+ // borrow to DIGITS+1 might be possible, a buffer must be used.
+ // [Might be worth more sophisticated tests when maxdigits==reqdigits]
+ if ((maxdigits>=reqdigits) // is, or could be, too large
+ || (res==rhs && rhsshift>0)) { // destructive overlap
+ // buffer needed, choose it; units for maxdigits digits will be
+ // needed, +1 Unit for carry or borrow
+ Int need=D2U(maxdigits)+1;
+ acc=accbuff; // assume use local buffer
+ if (need*sizeof(Unit)>sizeof(accbuff)) {
+ // printf("malloc add %ld %ld\n", need, sizeof(accbuff));
+ allocacc=(Unit *)malloc(need*sizeof(Unit));
+ if (allocacc==NULL) { // hopeless -- abandon
+ *status|=DEC_Insufficient_storage;
+ break;}
+ acc=allocacc;
+ }
+ }
+
+ res->bits=(uByte)(bits&DECNEG); // it's now safe to overwrite..
+ res->exponent=lhs->exponent; // .. operands (even if aliased)
+
+ #if DECTRACE
+ decDumpAr('A', lhs->lsu, D2U(lhs->digits));
+ decDumpAr('B', rhs->lsu, D2U(rhs->digits));
+ printf(" :h: %ld %ld\n", rhsshift, mult);
+ #endif
+
+ // add [A+B*m] or subtract [A+B*(-m)]
+ res->digits=decUnitAddSub(lhs->lsu, D2U(lhs->digits),
+ rhs->lsu, D2U(rhs->digits),
+ rhsshift, acc, mult)
+ *DECDPUN; // [units -> digits]
+ if (res->digits<0) { // borrowed...
+ res->digits=-res->digits;
+ res->bits^=DECNEG; // flip the sign
+ }
+ #if DECTRACE
+ decDumpAr('+', acc, D2U(res->digits));
+ #endif
+
+ // If a buffer was used the result must be copied back, possibly
+ // shortening. (If no buffer was used then the result must have
+ // fit, so can't need rounding and residue must be 0.)
+ residue=0; // clear accumulator
+ if (acc!=res->lsu) {
+ #if DECSUBSET
+ if (set->extended) { // round from first significant digit
+ #endif
+ // remove leading zeros that were added due to rounding up to
+ // integral Units -- before the test for rounding.
+ if (res->digits>reqdigits)
+ res->digits=decGetDigits(acc, D2U(res->digits));
+ decSetCoeff(res, set, acc, res->digits, &residue, status);
+ #if DECSUBSET
+ }
+ else { // subset arithmetic rounds from original significant digit
+ // May have an underestimate. This only occurs when both
+ // numbers fit in DECDPUN digits and are padding with a
+ // negative multiple (-10, -100...) and the top digit(s) become
+ // 0. (This only matters when using X3.274 rules where the
+ // leading zero could be included in the rounding.)
+ if (res->digits<maxdigits) {
+ *(acc+D2U(res->digits))=0; // ensure leading 0 is there
+ res->digits=maxdigits;
+ }
+ else {
+ // remove leading zeros that added due to rounding up to
+ // integral Units (but only those in excess of the original
+ // maxdigits length, unless extended) before test for rounding.
+ if (res->digits>reqdigits) {
+ res->digits=decGetDigits(acc, D2U(res->digits));
+ if (res->digits<maxdigits) res->digits=maxdigits;
+ }
+ }
+ decSetCoeff(res, set, acc, res->digits, &residue, status);
+ // Now apply rounding if needed before removing leading zeros.
+ // This is safe because subnormals are not a possibility
+ if (residue!=0) {
+ decApplyRound(res, set, residue, status);
+ residue=0; // did what needed to be done
+ }
+ } // subset
+ #endif
+ } // used buffer
+
+ // strip leading zeros [these were left on in case of subset subtract]
+ res->digits=decGetDigits(res->lsu, D2U(res->digits));
+
+ // apply checks and rounding
+ decFinish(res, set, &residue, status);
+
+ // "When the sum of two operands with opposite signs is exactly
+ // zero, the sign of that sum shall be '+' in all rounding modes
+ // except round toward -Infinity, in which mode that sign shall be
+ // '-'." [Subset zeros also never have '-', set by decFinish.]
+ if (ISZERO(res) && diffsign
+ #if DECSUBSET
+ && set->extended
+ #endif
+ && (*status&DEC_Inexact)==0) {
+ if (set->round==DEC_ROUND_FLOOR) res->bits|=DECNEG; // sign -
+ else res->bits&=~DECNEG; // sign +
+ }
+ } while(0); // end protected
+
+ if (allocacc!=NULL) free(allocacc); // drop any storage used
+ #if DECSUBSET
+ if (allocrhs!=NULL) free(allocrhs); // ..
+ if (alloclhs!=NULL) free(alloclhs); // ..
+ #endif
+ return res;
+ } // decAddOp
+
+/* ------------------------------------------------------------------ */
+/* decDivideOp -- division operation */
+/* */
+/* This routine performs the calculations for all four division */
+/* operators (divide, divideInteger, remainder, remainderNear). */
+/* */
+/* C=A op B */
+/* */
+/* res is C, the result. C may be A and/or B (e.g., X=X/X) */
+/* lhs is A */
+/* rhs is B */
+/* set is the context */
+/* op is DIVIDE, DIVIDEINT, REMAINDER, or REMNEAR respectively. */
+/* status is the usual accumulator */
+/* */
+/* C must have space for set->digits digits. */
+/* */
+/* ------------------------------------------------------------------ */
+/* The underlying algorithm of this routine is the same as in the */
+/* 1981 S/370 implementation, that is, non-restoring long division */
+/* with bi-unit (rather than bi-digit) estimation for each unit */
+/* multiplier. In this pseudocode overview, complications for the */
+/* Remainder operators and division residues for exact rounding are */
+/* omitted for clarity. */
+/* */
+/* Prepare operands and handle special values */
+/* Test for x/0 and then 0/x */
+/* Exp =Exp1 - Exp2 */
+/* Exp =Exp +len(var1) -len(var2) */
+/* Sign=Sign1 * Sign2 */
+/* Pad accumulator (Var1) to double-length with 0's (pad1) */
+/* Pad Var2 to same length as Var1 */
+/* msu2pair/plus=1st 2 or 1 units of var2, +1 to allow for round */
+/* have=0 */
+/* Do until (have=digits+1 OR residue=0) */
+/* if exp<0 then if integer divide/residue then leave */
+/* this_unit=0 */
+/* Do forever */
+/* compare numbers */
+/* if <0 then leave inner_loop */
+/* if =0 then (* quick exit without subtract *) do */
+/* this_unit=this_unit+1; output this_unit */
+/* leave outer_loop; end */
+/* Compare lengths of numbers (mantissae): */
+/* If same then tops2=msu2pair -- {units 1&2 of var2} */
+/* else tops2=msu2plus -- {0, unit 1 of var2} */
+/* tops1=first_unit_of_Var1*10**DECDPUN +second_unit_of_var1 */
+/* mult=tops1/tops2 -- Good and safe guess at divisor */
+/* if mult=0 then mult=1 */
+/* this_unit=this_unit+mult */
+/* subtract */
+/* end inner_loop */
+/* if have\=0 | this_unit\=0 then do */
+/* output this_unit */
+/* have=have+1; end */
+/* var2=var2/10 */
+/* exp=exp-1 */
+/* end outer_loop */
+/* exp=exp+1 -- set the proper exponent */
+/* if have=0 then generate answer=0 */
+/* Return (Result is defined by Var1) */
+/* */
+/* ------------------------------------------------------------------ */
+/* Two working buffers are needed during the division; one (digits+ */
+/* 1) to accumulate the result, and the other (up to 2*digits+1) for */
+/* long subtractions. These are acc and var1 respectively. */
+/* var1 is a copy of the lhs coefficient, var2 is the rhs coefficient.*/
+/* The static buffers may be larger than might be expected to allow */
+/* for calls from higher-level funtions (notable exp). */
+/* ------------------------------------------------------------------ */
+static decNumber * decDivideOp(decNumber *res,
+ const decNumber *lhs, const decNumber *rhs,
+ decContext *set, Flag op, uInt *status) {
+ #if DECSUBSET
+ decNumber *alloclhs=NULL; // non-NULL if rounded lhs allocated
+ decNumber *allocrhs=NULL; // .., rhs
+ #endif
+ Unit accbuff[SD2U(DECBUFFER+DECDPUN+10)]; // local buffer
+ Unit *acc=accbuff; // -> accumulator array for result
+ Unit *allocacc=NULL; // -> allocated buffer, iff allocated
+ Unit *accnext; // -> where next digit will go
+ Int acclength; // length of acc needed [Units]
+ Int accunits; // count of units accumulated
+ Int accdigits; // count of digits accumulated
+
+ Unit varbuff[SD2U(DECBUFFER*2+DECDPUN)]; // buffer for var1
+ Unit *var1=varbuff; // -> var1 array for long subtraction
+ Unit *varalloc=NULL; // -> allocated buffer, iff used
+ Unit *msu1; // -> msu of var1
+
+ const Unit *var2; // -> var2 array
+ const Unit *msu2; // -> msu of var2
+ Int msu2plus; // msu2 plus one [does not vary]
+ eInt msu2pair; // msu2 pair plus one [does not vary]
+
+ Int var1units, var2units; // actual lengths
+ Int var2ulen; // logical length (units)
+ Int var1initpad=0; // var1 initial padding (digits)
+ Int maxdigits; // longest LHS or required acc length
+ Int mult; // multiplier for subtraction
+ Unit thisunit; // current unit being accumulated
+ Int residue; // for rounding
+ Int reqdigits=set->digits; // requested DIGITS
+ Int exponent; // working exponent
+ Int maxexponent=0; // DIVIDE maximum exponent if unrounded
+ uByte bits; // working sign
+ Unit *target; // work
+ const Unit *source; // ..
+ uInt const *pow; // ..
+ Int shift, cut; // ..
+ #if DECSUBSET
+ Int dropped; // work
+ #endif
+
+ #if DECCHECK
+ if (decCheckOperands(res, lhs, rhs, set)) return res;
+ #endif
+
+ do { // protect allocated storage
+ #if DECSUBSET
+ if (!set->extended) {
+ // reduce operands and set lostDigits status, as needed
+ if (lhs->digits>reqdigits) {
+ alloclhs=decRoundOperand(lhs, set, status);
+ if (alloclhs==NULL) break;
+ lhs=alloclhs;
+ }
+ if (rhs->digits>reqdigits) {
+ allocrhs=decRoundOperand(rhs, set, status);
+ if (allocrhs==NULL) break;
+ rhs=allocrhs;
+ }
+ }
+ #endif
+ // [following code does not require input rounding]
+
+ bits=(lhs->bits^rhs->bits)&DECNEG; // assumed sign for divisions
+
+ // handle infinities and NaNs
+ if (SPECIALARGS) { // a special bit set
+ if (SPECIALARGS & (DECSNAN | DECNAN)) { // one or two NaNs
+ decNaNs(res, lhs, rhs, set, status);
+ break;
+ }
+ // one or two infinities
+ if (decNumberIsInfinite(lhs)) { // LHS (dividend) is infinite
+ if (decNumberIsInfinite(rhs) || // two infinities are invalid ..
+ op & (REMAINDER | REMNEAR)) { // as is remainder of infinity
+ *status|=DEC_Invalid_operation;
+ break;
+ }
+ // [Note that infinity/0 raises no exceptions]
+ decNumberZero(res);
+ res->bits=bits|DECINF; // set +/- infinity
+ break;
+ }
+ else { // RHS (divisor) is infinite
+ residue=0;
+ if (op&(REMAINDER|REMNEAR)) {
+ // result is [finished clone of] lhs
+ decCopyFit(res, lhs, set, &residue, status);
+ }
+ else { // a division
+ decNumberZero(res);
+ res->bits=bits; // set +/- zero
+ // for DIVIDEINT the exponent is always 0. For DIVIDE, result
+ // is a 0 with infinitely negative exponent, clamped to minimum
+ if (op&DIVIDE) {
+ res->exponent=set->emin-set->digits+1;
+ *status|=DEC_Clamped;
+ }
+ }
+ decFinish(res, set, &residue, status);
+ break;
+ }
+ }
+
+ // handle 0 rhs (x/0)
+ if (ISZERO(rhs)) { // x/0 is always exceptional
+ if (ISZERO(lhs)) {
+ decNumberZero(res); // [after lhs test]
+ *status|=DEC_Division_undefined;// 0/0 will become NaN
+ }
+ else {
+ decNumberZero(res);
+ if (op&(REMAINDER|REMNEAR)) *status|=DEC_Invalid_operation;
+ else {
+ *status|=DEC_Division_by_zero; // x/0
+ res->bits=bits|DECINF; // .. is +/- Infinity
+ }
+ }
+ break;}
+
+ // handle 0 lhs (0/x)
+ if (ISZERO(lhs)) { // 0/x [x!=0]
+ #if DECSUBSET
+ if (!set->extended) decNumberZero(res);
+ else {
+ #endif
+ if (op&DIVIDE) {
+ residue=0;
+ exponent=lhs->exponent-rhs->exponent; // ideal exponent
+ decNumberCopy(res, lhs); // [zeros always fit]
+ res->bits=bits; // sign as computed
+ res->exponent=exponent; // exponent, too
+ decFinalize(res, set, &residue, status); // check exponent
+ }
+ else if (op&DIVIDEINT) {
+ decNumberZero(res); // integer 0
+ res->bits=bits; // sign as computed
+ }
+ else { // a remainder
+ exponent=rhs->exponent; // [save in case overwrite]
+ decNumberCopy(res, lhs); // [zeros always fit]
+ if (exponent<res->exponent) res->exponent=exponent; // use lower
+ }
+ #if DECSUBSET
+ }
+ #endif
+ break;}
+
+ // Precalculate exponent. This starts off adjusted (and hence fits
+ // in 31 bits) and becomes the usual unadjusted exponent as the
+ // division proceeds. The order of evaluation is important, here,
+ // to avoid wrap.
+ exponent=(lhs->exponent+lhs->digits)-(rhs->exponent+rhs->digits);
+
+ // If the working exponent is -ve, then some quick exits are
+ // possible because the quotient is known to be <1
+ // [for REMNEAR, it needs to be < -1, as -0.5 could need work]
+ if (exponent<0 && !(op==DIVIDE)) {
+ if (op&DIVIDEINT) {
+ decNumberZero(res); // integer part is 0
+ #if DECSUBSET
+ if (set->extended)
+ #endif
+ res->bits=bits; // set +/- zero
+ break;}
+ // fastpath remainders so long as the lhs has the smaller
+ // (or equal) exponent
+ if (lhs->exponent<=rhs->exponent) {
+ if (op&REMAINDER || exponent<-1) {
+ // It is REMAINDER or safe REMNEAR; result is [finished
+ // clone of] lhs (r = x - 0*y)
+ residue=0;
+ decCopyFit(res, lhs, set, &residue, status);
+ decFinish(res, set, &residue, status);
+ break;
+ }
+ // [unsafe REMNEAR drops through]
+ }
+ } // fastpaths
+
+ /* Long (slow) division is needed; roll up the sleeves... */
+
+ // The accumulator will hold the quotient of the division.
+ // If it needs to be too long for stack storage, then allocate.
+ acclength=D2U(reqdigits+DECDPUN); // in Units
+ if (acclength*sizeof(Unit)>sizeof(accbuff)) {
+ // printf("malloc dvacc %ld units\n", acclength);
+ allocacc=(Unit *)malloc(acclength*sizeof(Unit));
+ if (allocacc==NULL) { // hopeless -- abandon
+ *status|=DEC_Insufficient_storage;
+ break;}
+ acc=allocacc; // use the allocated space
+ }
+
+ // var1 is the padded LHS ready for subtractions.
+ // If it needs to be too long for stack storage, then allocate.
+ // The maximum units needed for var1 (long subtraction) is:
+ // Enough for
+ // (rhs->digits+reqdigits-1) -- to allow full slide to right
+ // or (lhs->digits) -- to allow for long lhs
+ // whichever is larger
+ // +1 -- for rounding of slide to right
+ // +1 -- for leading 0s
+ // +1 -- for pre-adjust if a remainder or DIVIDEINT
+ // [Note: unused units do not participate in decUnitAddSub data]
+ maxdigits=rhs->digits+reqdigits-1;
+ if (lhs->digits>maxdigits) maxdigits=lhs->digits;
+ var1units=D2U(maxdigits)+2;
+ // allocate a guard unit above msu1 for REMAINDERNEAR
+ if (!(op&DIVIDE)) var1units++;
+ if ((var1units+1)*sizeof(Unit)>sizeof(varbuff)) {
+ // printf("malloc dvvar %ld units\n", var1units+1);
+ varalloc=(Unit *)malloc((var1units+1)*sizeof(Unit));
+ if (varalloc==NULL) { // hopeless -- abandon
+ *status|=DEC_Insufficient_storage;
+ break;}
+ var1=varalloc; // use the allocated space
+ }
+
+ // Extend the lhs and rhs to full long subtraction length. The lhs
+ // is truly extended into the var1 buffer, with 0 padding, so a
+ // subtract in place is always possible. The rhs (var2) has
+ // virtual padding (implemented by decUnitAddSub).
+ // One guard unit was allocated above msu1 for rem=rem+rem in
+ // REMAINDERNEAR.
+ msu1=var1+var1units-1; // msu of var1
+ source=lhs->lsu+D2U(lhs->digits)-1; // msu of input array
+ for (target=msu1; source>=lhs->lsu; source--, target--) *target=*source;
+ for (; target>=var1; target--) *target=0;
+
+ // rhs (var2) is left-aligned with var1 at the start
+ var2ulen=var1units; // rhs logical length (units)
+ var2units=D2U(rhs->digits); // rhs actual length (units)
+ var2=rhs->lsu; // -> rhs array
+ msu2=var2+var2units-1; // -> msu of var2 [never changes]
+ // now set up the variables which will be used for estimating the
+ // multiplication factor. If these variables are not exact, add
+ // 1 to make sure that the multiplier is never overestimated.
+ msu2plus=*msu2; // it's value ..
+ if (var2units>1) msu2plus++; // .. +1 if any more
+ msu2pair=(eInt)*msu2*(DECDPUNMAX+1);// top two pair ..
+ if (var2units>1) { // .. [else treat 2nd as 0]
+ msu2pair+=*(msu2-1); // ..
+ if (var2units>2) msu2pair++; // .. +1 if any more
+ }
+
+ // The calculation is working in units, which may have leading zeros,
+ // but the exponent was calculated on the assumption that they are
+ // both left-aligned. Adjust the exponent to compensate: add the
+ // number of leading zeros in var1 msu and subtract those in var2 msu.
+ // [This is actually done by counting the digits and negating, as
+ // lead1=DECDPUN-digits1, and similarly for lead2.]
+ for (pow=&powers[1]; *msu1>=*pow; pow++) exponent--;
+ for (pow=&powers[1]; *msu2>=*pow; pow++) exponent++;
+
+ // Now, if doing an integer divide or remainder, ensure that
+ // the result will be Unit-aligned. To do this, shift the var1
+ // accumulator towards least if need be. (It's much easier to
+ // do this now than to reassemble the residue afterwards, if
+ // doing a remainder.) Also ensure the exponent is not negative.
+ if (!(op&DIVIDE)) {
+ Unit *u; // work
+ // save the initial 'false' padding of var1, in digits
+ var1initpad=(var1units-D2U(lhs->digits))*DECDPUN;
+ // Determine the shift to do.
+ if (exponent<0) cut=-exponent;
+ else cut=DECDPUN-exponent%DECDPUN;
+ decShiftToLeast(var1, var1units, cut);
+ exponent+=cut; // maintain numerical value
+ var1initpad-=cut; // .. and reduce padding
+ // clean any most-significant units which were just emptied
+ for (u=msu1; cut>=DECDPUN; cut-=DECDPUN, u--) *u=0;
+ } // align
+ else { // is DIVIDE
+ maxexponent=lhs->exponent-rhs->exponent; // save
+ // optimization: if the first iteration will just produce 0,
+ // preadjust to skip it [valid for DIVIDE only]
+ if (*msu1<*msu2) {
+ var2ulen--; // shift down
+ exponent-=DECDPUN; // update the exponent
+ }
+ }
+
+ // ---- start the long-division loops ------------------------------
+ accunits=0; // no units accumulated yet
+ accdigits=0; // .. or digits
+ accnext=acc+acclength-1; // -> msu of acc [NB: allows digits+1]
+ for (;;) { // outer forever loop
+ thisunit=0; // current unit assumed 0
+ // find the next unit
+ for (;;) { // inner forever loop
+ // strip leading zero units [from either pre-adjust or from
+ // subtract last time around]. Leave at least one unit.
+ for (; *msu1==0 && msu1>var1; msu1--) var1units--;
+
+ if (var1units<var2ulen) break; // var1 too low for subtract
+ if (var1units==var2ulen) { // unit-by-unit compare needed
+ // compare the two numbers, from msu
+ const Unit *pv1, *pv2;
+ Unit v2; // units to compare
+ pv2=msu2; // -> msu
+ for (pv1=msu1; ; pv1--, pv2--) {
+ // v1=*pv1 -- always OK
+ v2=0; // assume in padding
+ if (pv2>=var2) v2=*pv2; // in range
+ if (*pv1!=v2) break; // no longer the same
+ if (pv1==var1) break; // done; leave pv1 as is
+ }
+ // here when all inspected or a difference seen
+ if (*pv1<v2) break; // var1 too low to subtract
+ if (*pv1==v2) { // var1 == var2
+ // reach here if var1 and var2 are identical; subtraction
+ // would increase digit by one, and the residue will be 0 so
+ // the calculation is done; leave the loop with residue=0.
+ thisunit++; // as though subtracted
+ *var1=0; // set var1 to 0
+ var1units=1; // ..
+ break; // from inner
+ } // var1 == var2
+ // *pv1>v2. Prepare for real subtraction; the lengths are equal
+ // Estimate the multiplier (there's always a msu1-1)...
+ // Bring in two units of var2 to provide a good estimate.
+ mult=(Int)(((eInt)*msu1*(DECDPUNMAX+1)+*(msu1-1))/msu2pair);
+ } // lengths the same
+ else { // var1units > var2ulen, so subtraction is safe
+ // The var2 msu is one unit towards the lsu of the var1 msu,
+ // so only one unit for var2 can be used.
+ mult=(Int)(((eInt)*msu1*(DECDPUNMAX+1)+*(msu1-1))/msu2plus);
+ }
+ if (mult==0) mult=1; // must always be at least 1
+ // subtraction needed; var1 is > var2
+ thisunit=(Unit)(thisunit+mult); // accumulate
+ // subtract var1-var2, into var1; only the overlap needs
+ // processing, as this is an in-place calculation
+ shift=var2ulen-var2units;
+ #if DECTRACE
+ decDumpAr('1', &var1[shift], var1units-shift);
+ decDumpAr('2', var2, var2units);
+ printf("m=%ld\n", -mult);
+ #endif
+ decUnitAddSub(&var1[shift], var1units-shift,
+ var2, var2units, 0,
+ &var1[shift], -mult);
+ #if DECTRACE
+ decDumpAr('#', &var1[shift], var1units-shift);
+ #endif
+ // var1 now probably has leading zeros; these are removed at the
+ // top of the inner loop.
+ } // inner loop
+
+ // The next unit has been calculated in full; unless it's a
+ // leading zero, add to acc
+ if (accunits!=0 || thisunit!=0) { // is first or non-zero
+ *accnext=thisunit; // store in accumulator
+ // account exactly for the new digits
+ if (accunits==0) {
+ accdigits++; // at least one
+ for (pow=&powers[1]; thisunit>=*pow; pow++) accdigits++;
+ }
+ else accdigits+=DECDPUN;
+ accunits++; // update count
+ accnext--; // ready for next
+ if (accdigits>reqdigits) break; // have enough digits
+ }
+
+ // if the residue is zero, the operation is done (unless divide
+ // or divideInteger and still not enough digits yet)
+ if (*var1==0 && var1units==1) { // residue is 0
+ if (op&(REMAINDER|REMNEAR)) break;
+ if ((op&DIVIDE) && (exponent<=maxexponent)) break;
+ // [drop through if divideInteger]
+ }
+ // also done enough if calculating remainder or integer
+ // divide and just did the last ('units') unit
+ if (exponent==0 && !(op&DIVIDE)) break;
+
+ // to get here, var1 is less than var2, so divide var2 by the per-
+ // Unit power of ten and go for the next digit
+ var2ulen--; // shift down
+ exponent-=DECDPUN; // update the exponent
+ } // outer loop
+
+ // ---- division is complete ---------------------------------------
+ // here: acc has at least reqdigits+1 of good results (or fewer
+ // if early stop), starting at accnext+1 (its lsu)
+ // var1 has any residue at the stopping point
+ // accunits is the number of digits collected in acc
+ if (accunits==0) { // acc is 0
+ accunits=1; // show have a unit ..
+ accdigits=1; // ..
+ *accnext=0; // .. whose value is 0
+ }
+ else accnext++; // back to last placed
+ // accnext now -> lowest unit of result
+
+ residue=0; // assume no residue
+ if (op&DIVIDE) {
+ // record the presence of any residue, for rounding
+ if (*var1!=0 || var1units>1) residue=1;
+ else { // no residue
+ // Had an exact division; clean up spurious trailing 0s.
+ // There will be at most DECDPUN-1, from the final multiply,
+ // and then only if the result is non-0 (and even) and the
+ // exponent is 'loose'.
+ #if DECDPUN>1
+ Unit lsu=*accnext;
+ if (!(lsu&0x01) && (lsu!=0)) {
+ // count the trailing zeros
+ Int drop=0;
+ for (;; drop++) { // [will terminate because lsu!=0]
+ if (exponent>=maxexponent) break; // don't chop real 0s
+ #if DECDPUN<=4
+ if ((lsu-QUOT10(lsu, drop+1)
+ *powers[drop+1])!=0) break; // found non-0 digit
+ #else
+ if (lsu%powers[drop+1]!=0) break; // found non-0 digit
+ #endif
+ exponent++;
+ }
+ if (drop>0) {
+ accunits=decShiftToLeast(accnext, accunits, drop);
+ accdigits=decGetDigits(accnext, accunits);
+ accunits=D2U(accdigits);
+ // [exponent was adjusted in the loop]
+ }
+ } // neither odd nor 0
+ #endif
+ } // exact divide
+ } // divide
+ else /* op!=DIVIDE */ {
+ // check for coefficient overflow
+ if (accdigits+exponent>reqdigits) {
+ *status|=DEC_Division_impossible;
+ break;
+ }
+ if (op & (REMAINDER|REMNEAR)) {
+ // [Here, the exponent will be 0, because var1 was adjusted
+ // appropriately.]
+ Int postshift; // work
+ Flag wasodd=0; // integer was odd
+ Unit *quotlsu; // for save
+ Int quotdigits; // ..
+
+ bits=lhs->bits; // remainder sign is always as lhs
+
+ // Fastpath when residue is truly 0 is worthwhile [and
+ // simplifies the code below]
+ if (*var1==0 && var1units==1) { // residue is 0
+ Int exp=lhs->exponent; // save min(exponents)
+ if (rhs->exponent<exp) exp=rhs->exponent;
+ decNumberZero(res); // 0 coefficient
+ #if DECSUBSET
+ if (set->extended)
+ #endif
+ res->exponent=exp; // .. with proper exponent
+ res->bits=(uByte)(bits&DECNEG); // [cleaned]
+ decFinish(res, set, &residue, status); // might clamp
+ break;
+ }
+ // note if the quotient was odd
+ if (*accnext & 0x01) wasodd=1; // acc is odd
+ quotlsu=accnext; // save in case need to reinspect
+ quotdigits=accdigits; // ..
+
+ // treat the residue, in var1, as the value to return, via acc
+ // calculate the unused zero digits. This is the smaller of:
+ // var1 initial padding (saved above)
+ // var2 residual padding, which happens to be given by:
+ postshift=var1initpad+exponent-lhs->exponent+rhs->exponent;
+ // [the 'exponent' term accounts for the shifts during divide]
+ if (var1initpad<postshift) postshift=var1initpad;
+
+ // shift var1 the requested amount, and adjust its digits
+ var1units=decShiftToLeast(var1, var1units, postshift);
+ accnext=var1;
+ accdigits=decGetDigits(var1, var1units);
+ accunits=D2U(accdigits);
+
+ exponent=lhs->exponent; // exponent is smaller of lhs & rhs
+ if (rhs->exponent<exponent) exponent=rhs->exponent;
+
+ // Now correct the result if doing remainderNear; if it
+ // (looking just at coefficients) is > rhs/2, or == rhs/2 and
+ // the integer was odd then the result should be rem-rhs.
+ if (op&REMNEAR) {
+ Int compare, tarunits; // work
+ Unit *up; // ..
+ // calculate remainder*2 into the var1 buffer (which has
+ // 'headroom' of an extra unit and hence enough space)
+ // [a dedicated 'double' loop would be faster, here]
+ tarunits=decUnitAddSub(accnext, accunits, accnext, accunits,
+ 0, accnext, 1);
+ // decDumpAr('r', accnext, tarunits);
+
+ // Here, accnext (var1) holds tarunits Units with twice the
+ // remainder's coefficient, which must now be compared to the
+ // RHS. The remainder's exponent may be smaller than the RHS's.
+ compare=decUnitCompare(accnext, tarunits, rhs->lsu, D2U(rhs->digits),
+ rhs->exponent-exponent);
+ if (compare==BADINT) { // deep trouble
+ *status|=DEC_Insufficient_storage;
+ break;}
+
+ // now restore the remainder by dividing by two; the lsu
+ // is known to be even.
+ for (up=accnext; up<accnext+tarunits; up++) {
+ Int half; // half to add to lower unit
+ half=*up & 0x01;
+ *up/=2; // [shift]
+ if (!half) continue;
+ *(up-1)+=(DECDPUNMAX+1)/2;
+ }
+ // [accunits still describes the original remainder length]
+
+ if (compare>0 || (compare==0 && wasodd)) { // adjustment needed
+ Int exp, expunits, exprem; // work
+ // This is effectively causing round-up of the quotient,
+ // so if it was the rare case where it was full and all
+ // nines, it would overflow and hence division-impossible
+ // should be raised
+ Flag allnines=0; // 1 if quotient all nines
+ if (quotdigits==reqdigits) { // could be borderline
+ for (up=quotlsu; ; up++) {
+ if (quotdigits>DECDPUN) {
+ if (*up!=DECDPUNMAX) break;// non-nines
+ }
+ else { // this is the last Unit
+ if (*up==powers[quotdigits]-1) allnines=1;
+ break;
+ }
+ quotdigits-=DECDPUN; // checked those digits
+ } // up
+ } // borderline check
+ if (allnines) {
+ *status|=DEC_Division_impossible;
+ break;}
+
+ // rem-rhs is needed; the sign will invert. Again, var1
+ // can safely be used for the working Units array.
+ exp=rhs->exponent-exponent; // RHS padding needed
+ // Calculate units and remainder from exponent.
+ expunits=exp/DECDPUN;
+ exprem=exp%DECDPUN;
+ // subtract [A+B*(-m)]; the result will always be negative
+ accunits=-decUnitAddSub(accnext, accunits,
+ rhs->lsu, D2U(rhs->digits),
+ expunits, accnext, -(Int)powers[exprem]);
+ accdigits=decGetDigits(accnext, accunits); // count digits exactly
+ accunits=D2U(accdigits); // and recalculate the units for copy
+ // [exponent is as for original remainder]
+ bits^=DECNEG; // flip the sign
+ }
+ } // REMNEAR
+ } // REMAINDER or REMNEAR
+ } // not DIVIDE
+
+ // Set exponent and bits
+ res->exponent=exponent;
+ res->bits=(uByte)(bits&DECNEG); // [cleaned]
+
+ // Now the coefficient.
+ decSetCoeff(res, set, accnext, accdigits, &residue, status);
+
+ decFinish(res, set, &residue, status); // final cleanup
+
+ #if DECSUBSET
+ // If a divide then strip trailing zeros if subset [after round]
+ if (!set->extended && (op==DIVIDE)) decTrim(res, set, 0, 1, &dropped);
+ #endif
+ } while(0); // end protected
+
+ if (varalloc!=NULL) free(varalloc); // drop any storage used
+ if (allocacc!=NULL) free(allocacc); // ..
+ #if DECSUBSET
+ if (allocrhs!=NULL) free(allocrhs); // ..
+ if (alloclhs!=NULL) free(alloclhs); // ..
+ #endif
+ return res;
+ } // decDivideOp
+
+/* ------------------------------------------------------------------ */
+/* decMultiplyOp -- multiplication operation */
+/* */
+/* This routine performs the multiplication C=A x B. */
+/* */
+/* res is C, the result. C may be A and/or B (e.g., X=X*X) */
+/* lhs is A */
+/* rhs is B */
+/* set is the context */
+/* status is the usual accumulator */
+/* */
+/* C must have space for set->digits digits. */
+/* */
+/* ------------------------------------------------------------------ */
+/* 'Classic' multiplication is used rather than Karatsuba, as the */
+/* latter would give only a minor improvement for the short numbers */
+/* expected to be handled most (and uses much more memory). */
+/* */
+/* There are two major paths here: the general-purpose ('old code') */
+/* path which handles all DECDPUN values, and a fastpath version */
+/* which is used if 64-bit ints are available, DECDPUN<=4, and more */
+/* than two calls to decUnitAddSub would be made. */
+/* */
+/* The fastpath version lumps units together into 8-digit or 9-digit */
+/* chunks, and also uses a lazy carry strategy to minimise expensive */
+/* 64-bit divisions. The chunks are then broken apart again into */
+/* units for continuing processing. Despite this overhead, the */
+/* fastpath can speed up some 16-digit operations by 10x (and much */
+/* more for higher-precision calculations). */
+/* */
+/* A buffer always has to be used for the accumulator; in the */
+/* fastpath, buffers are also always needed for the chunked copies of */
+/* of the operand coefficients. */
+/* Static buffers are larger than needed just for multiply, to allow */
+/* for calls from other operations (notably exp). */
+/* ------------------------------------------------------------------ */
+#define FASTMUL (DECUSE64 && DECDPUN<5)
+static decNumber * decMultiplyOp(decNumber *res, const decNumber *lhs,
+ const decNumber *rhs, decContext *set,
+ uInt *status) {
+ Int accunits; // Units of accumulator in use
+ Int exponent; // work
+ Int residue=0; // rounding residue
+ uByte bits; // result sign
+ Unit *acc; // -> accumulator Unit array
+ Int needbytes; // size calculator
+ void *allocacc=NULL; // -> allocated accumulator, iff allocated
+ Unit accbuff[SD2U(DECBUFFER*4+1)]; // buffer (+1 for DECBUFFER==0,
+ // *4 for calls from other operations)
+ const Unit *mer, *mermsup; // work
+ Int madlength; // Units in multiplicand
+ Int shift; // Units to shift multiplicand by
+
+ #if FASTMUL
+ // if DECDPUN is 1 or 3 work in base 10**9, otherwise
+ // (DECDPUN is 2 or 4) then work in base 10**8
+ #if DECDPUN & 1 // odd
+ #define FASTBASE 1000000000 // base
+ #define FASTDIGS 9 // digits in base
+ #define FASTLAZY 18 // carry resolution point [1->18]
+ #else
+ #define FASTBASE 100000000
+ #define FASTDIGS 8
+ #define FASTLAZY 1844 // carry resolution point [1->1844]
+ #endif
+ // three buffers are used, two for chunked copies of the operands
+ // (base 10**8 or base 10**9) and one base 2**64 accumulator with
+ // lazy carry evaluation
+ uInt zlhibuff[(DECBUFFER*2+1)/8+1]; // buffer (+1 for DECBUFFER==0)
+ uInt *zlhi=zlhibuff; // -> lhs array
+ uInt *alloclhi=NULL; // -> allocated buffer, iff allocated
+ uInt zrhibuff[(DECBUFFER*2+1)/8+1]; // buffer (+1 for DECBUFFER==0)
+ uInt *zrhi=zrhibuff; // -> rhs array
+ uInt *allocrhi=NULL; // -> allocated buffer, iff allocated
+ uLong zaccbuff[(DECBUFFER*2+1)/4+2]; // buffer (+1 for DECBUFFER==0)
+ // [allocacc is shared for both paths, as only one will run]
+ uLong *zacc=zaccbuff; // -> accumulator array for exact result
+ #if DECDPUN==1
+ Int zoff; // accumulator offset
+ #endif
+ uInt *lip, *rip; // item pointers
+ uInt *lmsi, *rmsi; // most significant items
+ Int ilhs, irhs, iacc; // item counts in the arrays
+ Int lazy; // lazy carry counter
+ uLong lcarry; // uLong carry
+ uInt carry; // carry (NB not uLong)
+ Int count; // work
+ const Unit *cup; // ..
+ Unit *up; // ..
+ uLong *lp; // ..
+ Int p; // ..
+ #endif
+
+ #if DECSUBSET
+ decNumber *alloclhs=NULL; // -> allocated buffer, iff allocated
+ decNumber *allocrhs=NULL; // -> allocated buffer, iff allocated
+ #endif
+
+ #if DECCHECK
+ if (decCheckOperands(res, lhs, rhs, set)) return res;
+ #endif
+
+ // precalculate result sign
+ bits=(uByte)((lhs->bits^rhs->bits)&DECNEG);
+
+ // handle infinities and NaNs
+ if (SPECIALARGS) { // a special bit set
+ if (SPECIALARGS & (DECSNAN | DECNAN)) { // one or two NaNs
+ decNaNs(res, lhs, rhs, set, status);
+ return res;}
+ // one or two infinities; Infinity * 0 is invalid
+ if (((lhs->bits & DECINF)==0 && ISZERO(lhs))
+ ||((rhs->bits & DECINF)==0 && ISZERO(rhs))) {
+ *status|=DEC_Invalid_operation;
+ return res;}
+ decNumberZero(res);
+ res->bits=bits|DECINF; // infinity
+ return res;}
+
+ // For best speed, as in DMSRCN [the original Rexx numerics
+ // module], use the shorter number as the multiplier (rhs) and
+ // the longer as the multiplicand (lhs) to minimise the number of
+ // adds (partial products)
+ if (lhs->digits<rhs->digits) { // swap...
+ const decNumber *hold=lhs;
+ lhs=rhs;
+ rhs=hold;
+ }
+
+ do { // protect allocated storage
+ #if DECSUBSET
+ if (!set->extended) {
+ // reduce operands and set lostDigits status, as needed
+ if (lhs->digits>set->digits) {
+ alloclhs=decRoundOperand(lhs, set, status);
+ if (alloclhs==NULL) break;
+ lhs=alloclhs;
+ }
+ if (rhs->digits>set->digits) {
+ allocrhs=decRoundOperand(rhs, set, status);
+ if (allocrhs==NULL) break;
+ rhs=allocrhs;
+ }
+ }
+ #endif
+ // [following code does not require input rounding]
+
+ #if FASTMUL // fastpath can be used
+ // use the fast path if there are enough digits in the shorter
+ // operand to make the setup and takedown worthwhile
+ #define NEEDTWO (DECDPUN*2) // within two decUnitAddSub calls
+ if (rhs->digits>NEEDTWO) { // use fastpath...
+ // calculate the number of elements in each array
+ ilhs=(lhs->digits+FASTDIGS-1)/FASTDIGS; // [ceiling]
+ irhs=(rhs->digits+FASTDIGS-1)/FASTDIGS; // ..
+ iacc=ilhs+irhs;
+
+ // allocate buffers if required, as usual
+ needbytes=ilhs*sizeof(uInt);
+ if (needbytes>(Int)sizeof(zlhibuff)) {
+ alloclhi=(uInt *)malloc(needbytes);
+ zlhi=alloclhi;}
+ needbytes=irhs*sizeof(uInt);
+ if (needbytes>(Int)sizeof(zrhibuff)) {
+ allocrhi=(uInt *)malloc(needbytes);
+ zrhi=allocrhi;}
+
+ // Allocating the accumulator space needs a special case when
+ // DECDPUN=1 because when converting the accumulator to Units
+ // after the multiplication each 8-byte item becomes 9 1-byte
+ // units. Therefore iacc extra bytes are needed at the front
+ // (rounded up to a multiple of 8 bytes), and the uLong
+ // accumulator starts offset the appropriate number of units
+ // to the right to avoid overwrite during the unchunking.
+ needbytes=iacc*sizeof(uLong);
+ #if DECDPUN==1
+ zoff=(iacc+7)/8; // items to offset by
+ needbytes+=zoff*8;
+ #endif
+ if (needbytes>(Int)sizeof(zaccbuff)) {
+ allocacc=(uLong *)malloc(needbytes);
+ zacc=(uLong *)allocacc;}
+ if (zlhi==NULL||zrhi==NULL||zacc==NULL) {
+ *status|=DEC_Insufficient_storage;
+ break;}
+
+ acc=(Unit *)zacc; // -> target Unit array
+ #if DECDPUN==1
+ zacc+=zoff; // start uLong accumulator to right
+ #endif
+
+ // assemble the chunked copies of the left and right sides
+ for (count=lhs->digits, cup=lhs->lsu, lip=zlhi; count>0; lip++)
+ for (p=0, *lip=0; p<FASTDIGS && count>0;
+ p+=DECDPUN, cup++, count-=DECDPUN)
+ *lip+=*cup*powers[p];
+ lmsi=lip-1; // save -> msi
+ for (count=rhs->digits, cup=rhs->lsu, rip=zrhi; count>0; rip++)
+ for (p=0, *rip=0; p<FASTDIGS && count>0;
+ p+=DECDPUN, cup++, count-=DECDPUN)
+ *rip+=*cup*powers[p];
+ rmsi=rip-1; // save -> msi
+
+ // zero the accumulator
+ for (lp=zacc; lp<zacc+iacc; lp++) *lp=0;
+
+ /* Start the multiplication */
+ // Resolving carries can dominate the cost of accumulating the
+ // partial products, so this is only done when necessary.
+ // Each uLong item in the accumulator can hold values up to
+ // 2**64-1, and each partial product can be as large as
+ // (10**FASTDIGS-1)**2. When FASTDIGS=9, this can be added to
+ // itself 18.4 times in a uLong without overflowing, so during
+ // the main calculation resolution is carried out every 18th
+ // add -- every 162 digits. Similarly, when FASTDIGS=8, the
+ // partial products can be added to themselves 1844.6 times in
+ // a uLong without overflowing, so intermediate carry
+ // resolution occurs only every 14752 digits. Hence for common
+ // short numbers usually only the one final carry resolution
+ // occurs.
+ // (The count is set via FASTLAZY to simplify experiments to
+ // measure the value of this approach: a 35% improvement on a
+ // [34x34] multiply.)
+ lazy=FASTLAZY; // carry delay count
+ for (rip=zrhi; rip<=rmsi; rip++) { // over each item in rhs
+ lp=zacc+(rip-zrhi); // where to add the lhs
+ for (lip=zlhi; lip<=lmsi; lip++, lp++) { // over each item in lhs
+ *lp+=(uLong)(*lip)*(*rip); // [this should in-line]
+ } // lip loop
+ lazy--;
+ if (lazy>0 && rip!=rmsi) continue;
+ lazy=FASTLAZY; // reset delay count
+ // spin up the accumulator resolving overflows
+ for (lp=zacc; lp<zacc+iacc; lp++) {
+ if (*lp<FASTBASE) continue; // it fits
+ lcarry=*lp/FASTBASE; // top part [slow divide]
+ // lcarry can exceed 2**32-1, so check again; this check
+ // and occasional extra divide (slow) is well worth it, as
+ // it allows FASTLAZY to be increased to 18 rather than 4
+ // in the FASTDIGS=9 case
+ if (lcarry<FASTBASE) carry=(uInt)lcarry; // [usual]
+ else { // two-place carry [fairly rare]
+ uInt carry2=(uInt)(lcarry/FASTBASE); // top top part
+ *(lp+2)+=carry2; // add to item+2
+ *lp-=((uLong)FASTBASE*FASTBASE*carry2); // [slow]
+ carry=(uInt)(lcarry-((uLong)FASTBASE*carry2)); // [inline]
+ }
+ *(lp+1)+=carry; // add to item above [inline]
+ *lp-=((uLong)FASTBASE*carry); // [inline]
+ } // carry resolution
+ } // rip loop
+
+ // The multiplication is complete; time to convert back into
+ // units. This can be done in-place in the accumulator and in
+ // 32-bit operations, because carries were resolved after the
+ // final add. This needs N-1 divides and multiplies for
+ // each item in the accumulator (which will become up to N
+ // units, where 2<=N<=9).
+ for (lp=zacc, up=acc; lp<zacc+iacc; lp++) {
+ uInt item=(uInt)*lp; // decapitate to uInt
+ for (p=0; p<FASTDIGS-DECDPUN; p+=DECDPUN, up++) {
+ uInt part=item/(DECDPUNMAX+1);
+ *up=(Unit)(item-(part*(DECDPUNMAX+1)));
+ item=part;
+ } // p
+ *up=(Unit)item; up++; // [final needs no division]
+ } // lp
+ accunits=up-acc; // count of units
+ }
+ else { // here to use units directly, without chunking ['old code']
+ #endif
+
+ // if accumulator will be too long for local storage, then allocate
+ acc=accbuff; // -> assume buffer for accumulator
+ needbytes=(D2U(lhs->digits)+D2U(rhs->digits))*sizeof(Unit);
+ if (needbytes>(Int)sizeof(accbuff)) {
+ allocacc=(Unit *)malloc(needbytes);
+ if (allocacc==NULL) {*status|=DEC_Insufficient_storage; break;}
+ acc=(Unit *)allocacc; // use the allocated space
+ }
+
+ /* Now the main long multiplication loop */
+ // Unlike the equivalent in the IBM Java implementation, there
+ // is no advantage in calculating from msu to lsu. So, do it
+ // by the book, as it were.
+ // Each iteration calculates ACC=ACC+MULTAND*MULT
+ accunits=1; // accumulator starts at '0'
+ *acc=0; // .. (lsu=0)
+ shift=0; // no multiplicand shift at first
+ madlength=D2U(lhs->digits); // this won't change
+ mermsup=rhs->lsu+D2U(rhs->digits); // -> msu+1 of multiplier
+
+ for (mer=rhs->lsu; mer<mermsup; mer++) {
+ // Here, *mer is the next Unit in the multiplier to use
+ // If non-zero [optimization] add it...
+ if (*mer!=0) accunits=decUnitAddSub(&acc[shift], accunits-shift,
+ lhs->lsu, madlength, 0,
+ &acc[shift], *mer)
+ + shift;
+ else { // extend acc with a 0; it will be used shortly
+ *(acc+accunits)=0; // [this avoids length of <=0 later]
+ accunits++;
+ }
+ // multiply multiplicand by 10**DECDPUN for next Unit to left
+ shift++; // add this for 'logical length'
+ } // n
+ #if FASTMUL
+ } // unchunked units
+ #endif
+ // common end-path
+ #if DECTRACE
+ decDumpAr('*', acc, accunits); // Show exact result
+ #endif
+
+ // acc now contains the exact result of the multiplication,
+ // possibly with a leading zero unit; build the decNumber from
+ // it, noting if any residue
+ res->bits=bits; // set sign
+ res->digits=decGetDigits(acc, accunits); // count digits exactly
+
+ // There can be a 31-bit wrap in calculating the exponent.
+ // This can only happen if both input exponents are negative and
+ // both their magnitudes are large. If there was a wrap, set a
+ // safe very negative exponent, from which decFinalize() will
+ // raise a hard underflow shortly.
+ exponent=lhs->exponent+rhs->exponent; // calculate exponent
+ if (lhs->exponent<0 && rhs->exponent<0 && exponent>0)
+ exponent=-2*DECNUMMAXE; // force underflow
+ res->exponent=exponent; // OK to overwrite now
+
+
+ // Set the coefficient. If any rounding, residue records
+ decSetCoeff(res, set, acc, res->digits, &residue, status);
+ decFinish(res, set, &residue, status); // final cleanup
+ } while(0); // end protected
+
+ if (allocacc!=NULL) free(allocacc); // drop any storage used
+ #if DECSUBSET
+ if (allocrhs!=NULL) free(allocrhs); // ..
+ if (alloclhs!=NULL) free(alloclhs); // ..
+ #endif
+ #if FASTMUL
+ if (allocrhi!=NULL) free(allocrhi); // ..
+ if (alloclhi!=NULL) free(alloclhi); // ..
+ #endif
+ return res;
+ } // decMultiplyOp
+
+/* ------------------------------------------------------------------ */
+/* decExpOp -- effect exponentiation */
+/* */
+/* This computes C = exp(A) */
+/* */
+/* res is C, the result. C may be A */
+/* rhs is A */
+/* set is the context; note that rounding mode has no effect */
+/* */
+/* C must have space for set->digits digits. status is updated but */
+/* not set. */
+/* */
+/* Restrictions: */
+/* */
+/* digits, emax, and -emin in the context must be less than */
+/* 2*DEC_MAX_MATH (1999998), and the rhs must be within these */
+/* bounds or a zero. This is an internal routine, so these */
+/* restrictions are contractual and not enforced. */
+/* */
+/* A finite result is rounded using DEC_ROUND_HALF_EVEN; it will */
+/* almost always be correctly rounded, but may be up to 1 ulp in */
+/* error in rare cases. */
+/* */
+/* Finite results will always be full precision and Inexact, except */
+/* when A is a zero or -Infinity (giving 1 or 0 respectively). */
+/* ------------------------------------------------------------------ */
+/* This approach used here is similar to the algorithm described in */
+/* */
+/* Variable Precision Exponential Function, T. E. Hull and */
+/* A. Abrham, ACM Transactions on Mathematical Software, Vol 12 #2, */
+/* pp79-91, ACM, June 1986. */
+/* */
+/* with the main difference being that the iterations in the series */
+/* evaluation are terminated dynamically (which does not require the */
+/* extra variable-precision variables which are expensive in this */
+/* context). */
+/* */
+/* The error analysis in Hull & Abrham's paper applies except for the */
+/* round-off error accumulation during the series evaluation. This */
+/* code does not precalculate the number of iterations and so cannot */
+/* use Horner's scheme. Instead, the accumulation is done at double- */
+/* precision, which ensures that the additions of the terms are exact */
+/* and do not accumulate round-off (and any round-off errors in the */
+/* terms themselves move 'to the right' faster than they can */
+/* accumulate). This code also extends the calculation by allowing, */
+/* in the spirit of other decNumber operators, the input to be more */
+/* precise than the result (the precision used is based on the more */
+/* precise of the input or requested result). */
+/* */
+/* Implementation notes: */
+/* */
+/* 1. This is separated out as decExpOp so it can be called from */
+/* other Mathematical functions (notably Ln) with a wider range */
+/* than normal. In particular, it can handle the slightly wider */
+/* (double) range needed by Ln (which has to be able to calculate */
+/* exp(-x) where x can be the tiniest number (Ntiny). */
+/* */
+/* 2. Normalizing x to be <=0.1 (instead of <=1) reduces loop */
+/* iterations by appoximately a third with additional (although */
+/* diminishing) returns as the range is reduced to even smaller */
+/* fractions. However, h (the power of 10 used to correct the */
+/* result at the end, see below) must be kept <=8 as otherwise */
+/* the final result cannot be computed. Hence the leverage is a */
+/* sliding value (8-h), where potentially the range is reduced */
+/* more for smaller values. */
+/* */
+/* The leverage that can be applied in this way is severely */
+/* limited by the cost of the raise-to-the power at the end, */
+/* which dominates when the number of iterations is small (less */
+/* than ten) or when rhs is short. As an example, the adjustment */
+/* x**10,000,000 needs 31 multiplications, all but one full-width. */
+/* */
+/* 3. The restrictions (especially precision) could be raised with */
+/* care, but the full decNumber range seems very hard within the */
+/* 32-bit limits. */
+/* */
+/* 4. The working precisions for the static buffers are twice the */
+/* obvious size to allow for calls from decNumberPower. */
+/* ------------------------------------------------------------------ */
+decNumber * decExpOp(decNumber *res, const decNumber *rhs,
+ decContext *set, uInt *status) {
+ uInt ignore=0; // working status
+ Int h; // adjusted exponent for 0.xxxx
+ Int p; // working precision
+ Int residue; // rounding residue
+ uInt needbytes; // for space calculations
+ const decNumber *x=rhs; // (may point to safe copy later)
+ decContext aset, tset, dset; // working contexts
+ Int comp; // work
+
+ // the argument is often copied to normalize it, so (unusually) it
+ // is treated like other buffers, using DECBUFFER, +1 in case
+ // DECBUFFER is 0
+ decNumber bufr[D2N(DECBUFFER*2+1)];
+ decNumber *allocrhs=NULL; // non-NULL if rhs buffer allocated
+
+ // the working precision will be no more than set->digits+8+1
+ // so for on-stack buffers DECBUFFER+9 is used, +1 in case DECBUFFER
+ // is 0 (and twice that for the accumulator)
+
+ // buffer for t, term (working precision plus)
+ decNumber buft[D2N(DECBUFFER*2+9+1)];
+ decNumber *allocbuft=NULL; // -> allocated buft, iff allocated
+ decNumber *t=buft; // term
+ // buffer for a, accumulator (working precision * 2), at least 9
+ decNumber bufa[D2N(DECBUFFER*4+18+1)];
+ decNumber *allocbufa=NULL; // -> allocated bufa, iff allocated
+ decNumber *a=bufa; // accumulator
+ // decNumber for the divisor term; this needs at most 9 digits
+ // and so can be fixed size [16 so can use standard context]
+ decNumber bufd[D2N(16)];
+ decNumber *d=bufd; // divisor
+ decNumber numone; // constant 1
+
+ #if DECCHECK
+ Int iterations=0; // for later sanity check
+ if (decCheckOperands(res, DECUNUSED, rhs, set)) return res;
+ #endif
+
+ do { // protect allocated storage
+ if (SPECIALARG) { // handle infinities and NaNs
+ if (decNumberIsInfinite(rhs)) { // an infinity
+ if (decNumberIsNegative(rhs)) // -Infinity -> +0
+ decNumberZero(res);
+ else decNumberCopy(res, rhs); // +Infinity -> self
+ }
+ else decNaNs(res, rhs, NULL, set, status); // a NaN
+ break;}
+
+ if (ISZERO(rhs)) { // zeros -> exact 1
+ decNumberZero(res); // make clean 1
+ *res->lsu=1; // ..
+ break;} // [no status to set]
+
+ // e**x when 0 < x < 0.66 is < 1+3x/2, hence can fast-path
+ // positive and negative tiny cases which will result in inexact
+ // 1. This also allows the later add-accumulate to always be
+ // exact (because its length will never be more than twice the
+ // working precision).
+ // The comparator (tiny) needs just one digit, so use the
+ // decNumber d for it (reused as the divisor, etc., below); its
+ // exponent is such that if x is positive it will have
+ // set->digits-1 zeros between the decimal point and the digit,
+ // which is 4, and if x is negative one more zero there as the
+ // more precise result will be of the form 0.9999999 rather than
+ // 1.0000001. Hence, tiny will be 0.0000004 if digits=7 and x>0
+ // or 0.00000004 if digits=7 and x<0. If RHS not larger than
+ // this then the result will be 1.000000
+ decNumberZero(d); // clean
+ *d->lsu=4; // set 4 ..
+ d->exponent=-set->digits; // * 10**(-d)
+ if (decNumberIsNegative(rhs)) d->exponent--; // negative case
+ comp=decCompare(d, rhs, 1); // signless compare
+ if (comp==BADINT) {
+ *status|=DEC_Insufficient_storage;
+ break;}
+ if (comp>=0) { // rhs < d
+ Int shift=set->digits-1;
+ decNumberZero(res); // set 1
+ *res->lsu=1; // ..
+ res->digits=decShiftToMost(res->lsu, 1, shift);
+ res->exponent=-shift; // make 1.0000...
+ *status|=DEC_Inexact | DEC_Rounded; // .. inexactly
+ break;} // tiny
+
+ // set up the context to be used for calculating a, as this is
+ // used on both paths below
+ decContextDefault(&aset, DEC_INIT_DECIMAL64);
+ // accumulator bounds are as requested (could underflow)
+ aset.emax=set->emax; // usual bounds
+ aset.emin=set->emin; // ..
+ aset.clamp=0; // and no concrete format
+
+ // calculate the adjusted (Hull & Abrham) exponent (where the
+ // decimal point is just to the left of the coefficient msd)
+ h=rhs->exponent+rhs->digits;
+ // if h>8 then 10**h cannot be calculated safely; however, when
+ // h=8 then exp(|rhs|) will be at least exp(1E+7) which is at
+ // least 6.59E+4342944, so (due to the restriction on Emax/Emin)
+ // overflow (or underflow to 0) is guaranteed -- so this case can
+ // be handled by simply forcing the appropriate excess
+ if (h>8) { // overflow/underflow
+ // set up here so Power call below will over or underflow to
+ // zero; set accumulator to either 2 or 0.02
+ // [stack buffer for a is always big enough for this]
+ decNumberZero(a);
+ *a->lsu=2; // not 1 but < exp(1)
+ if (decNumberIsNegative(rhs)) a->exponent=-2; // make 0.02
+ h=8; // clamp so 10**h computable
+ p=9; // set a working precision
+ }
+ else { // h<=8
+ Int maxlever=(rhs->digits>8?1:0);
+ // [could/should increase this for precisions >40 or so, too]
+
+ // if h is 8, cannot normalize to a lower upper limit because
+ // the final result will not be computable (see notes above),
+ // but leverage can be applied whenever h is less than 8.
+ // Apply as much as possible, up to a MAXLEVER digits, which
+ // sets the tradeoff against the cost of the later a**(10**h).
+ // As h is increased, the working precision below also
+ // increases to compensate for the "constant digits at the
+ // front" effect.
+ Int lever=MINI(8-h, maxlever); // leverage attainable
+ Int use=-rhs->digits-lever; // exponent to use for RHS
+ h+=lever; // apply leverage selected
+ if (h<0) { // clamp
+ use+=h; // [may end up subnormal]
+ h=0;
+ }
+ // Take a copy of RHS if it needs normalization (true whenever x>=1)
+ if (rhs->exponent!=use) {
+ decNumber *newrhs=bufr; // assume will fit on stack
+ needbytes=sizeof(decNumber)+(D2U(rhs->digits)-1)*sizeof(Unit);
+ if (needbytes>sizeof(bufr)) { // need malloc space
+ allocrhs=(decNumber *)malloc(needbytes);
+ if (allocrhs==NULL) { // hopeless -- abandon
+ *status|=DEC_Insufficient_storage;
+ break;}
+ newrhs=allocrhs; // use the allocated space
+ }
+ decNumberCopy(newrhs, rhs); // copy to safe space
+ newrhs->exponent=use; // normalize; now <1
+ x=newrhs; // ready for use
+ // decNumberShow(x);
+ }
+
+ // Now use the usual power series to evaluate exp(x). The
+ // series starts as 1 + x + x^2/2 ... so prime ready for the
+ // third term by setting the term variable t=x, the accumulator
+ // a=1, and the divisor d=2.
+
+ // First determine the working precision. From Hull & Abrham
+ // this is set->digits+h+2. However, if x is 'over-precise' we
+ // need to allow for all its digits to potentially participate
+ // (consider an x where all the excess digits are 9s) so in
+ // this case use x->digits+h+2
+ p=MAXI(x->digits, set->digits)+h+2; // [h<=8]
+
+ // a and t are variable precision, and depend on p, so space
+ // must be allocated for them if necessary
+
+ // the accumulator needs to be able to hold 2p digits so that
+ // the additions on the second and subsequent iterations are
+ // sufficiently exact.
+ needbytes=sizeof(decNumber)+(D2U(p*2)-1)*sizeof(Unit);
+ if (needbytes>sizeof(bufa)) { // need malloc space
+ allocbufa=(decNumber *)malloc(needbytes);
+ if (allocbufa==NULL) { // hopeless -- abandon
+ *status|=DEC_Insufficient_storage;
+ break;}
+ a=allocbufa; // use the allocated space
+ }
+ // the term needs to be able to hold p digits (which is
+ // guaranteed to be larger than x->digits, so the initial copy
+ // is safe); it may also be used for the raise-to-power
+ // calculation below, which needs an extra two digits
+ needbytes=sizeof(decNumber)+(D2U(p+2)-1)*sizeof(Unit);
+ if (needbytes>sizeof(buft)) { // need malloc space
+ allocbuft=(decNumber *)malloc(needbytes);
+ if (allocbuft==NULL) { // hopeless -- abandon
+ *status|=DEC_Insufficient_storage;
+ break;}
+ t=allocbuft; // use the allocated space
+ }
+
+ decNumberCopy(t, x); // term=x
+ decNumberZero(a); *a->lsu=1; // accumulator=1
+ decNumberZero(d); *d->lsu=2; // divisor=2
+ decNumberZero(&numone); *numone.lsu=1; // constant 1 for increment
+
+ // set up the contexts for calculating a, t, and d
+ decContextDefault(&tset, DEC_INIT_DECIMAL64);
+ dset=tset;
+ // accumulator bounds are set above, set precision now
+ aset.digits=p*2; // double
+ // term bounds avoid any underflow or overflow
+ tset.digits=p;
+ tset.emin=DEC_MIN_EMIN; // [emax is plenty]
+ // [dset.digits=16, etc., are sufficient]
+
+ // finally ready to roll
+ for (;;) {
+ #if DECCHECK
+ iterations++;
+ #endif
+ // only the status from the accumulation is interesting
+ // [but it should remain unchanged after first add]
+ decAddOp(a, a, t, &aset, 0, status); // a=a+t
+ decMultiplyOp(t, t, x, &tset, &ignore); // t=t*x
+ decDivideOp(t, t, d, &tset, DIVIDE, &ignore); // t=t/d
+ // the iteration ends when the term cannot affect the result,
+ // if rounded to p digits, which is when its value is smaller
+ // than the accumulator by p+1 digits. There must also be
+ // full precision in a.
+ if (((a->digits+a->exponent)>=(t->digits+t->exponent+p+1))
+ && (a->digits>=p)) break;
+ decAddOp(d, d, &numone, &dset, 0, &ignore); // d=d+1
+ } // iterate
+
+ #if DECCHECK
+ // just a sanity check; comment out test to show always
+ if (iterations>p+3)
+ printf("Exp iterations=%ld, status=%08lx, p=%ld, d=%ld\n",
+ (LI)iterations, (LI)*status, (LI)p, (LI)x->digits);
+ #endif
+ } // h<=8
+
+ // apply postconditioning: a=a**(10**h) -- this is calculated
+ // at a slightly higher precision than Hull & Abrham suggest
+ if (h>0) {
+ Int seenbit=0; // set once a 1-bit is seen
+ Int i; // counter
+ Int n=powers[h]; // always positive
+ aset.digits=p+2; // sufficient precision
+ // avoid the overhead and many extra digits of decNumberPower
+ // as all that is needed is the short 'multipliers' loop; here
+ // accumulate the answer into t
+ decNumberZero(t); *t->lsu=1; // acc=1
+ for (i=1;;i++){ // for each bit [top bit ignored]
+ // abandon if have had overflow or terminal underflow
+ if (*status & (DEC_Overflow|DEC_Underflow)) { // interesting?
+ if (*status&DEC_Overflow || ISZERO(t)) break;}
+ n=n<<1; // move next bit to testable position
+ if (n<0) { // top bit is set
+ seenbit=1; // OK, have a significant bit
+ decMultiplyOp(t, t, a, &aset, status); // acc=acc*x
+ }
+ if (i==31) break; // that was the last bit
+ if (!seenbit) continue; // no need to square 1
+ decMultiplyOp(t, t, t, &aset, status); // acc=acc*acc [square]
+ } /*i*/ // 32 bits
+ // decNumberShow(t);
+ a=t; // and carry on using t instead of a
+ }
+
+ // Copy and round the result to res
+ residue=1; // indicate dirt to right ..
+ if (ISZERO(a)) residue=0; // .. unless underflowed to 0
+ aset.digits=set->digits; // [use default rounding]
+ decCopyFit(res, a, &aset, &residue, status); // copy & shorten
+ decFinish(res, set, &residue, status); // cleanup/set flags
+ } while(0); // end protected
+
+ if (allocrhs !=NULL) free(allocrhs); // drop any storage used
+ if (allocbufa!=NULL) free(allocbufa); // ..
+ if (allocbuft!=NULL) free(allocbuft); // ..
+ // [status is handled by caller]
+ return res;
+ } // decExpOp
+
+/* ------------------------------------------------------------------ */
+/* Initial-estimate natural logarithm table */
+/* */
+/* LNnn -- 90-entry 16-bit table for values from .10 through .99. */
+/* The result is a 4-digit encode of the coefficient (c=the */
+/* top 14 bits encoding 0-9999) and a 2-digit encode of the */
+/* exponent (e=the bottom 2 bits encoding 0-3) */
+/* */
+/* The resulting value is given by: */
+/* */
+/* v = -c * 10**(-e-3) */
+/* */
+/* where e and c are extracted from entry k = LNnn[x-10] */
+/* where x is truncated (NB) into the range 10 through 99, */
+/* and then c = k>>2 and e = k&3. */
+/* ------------------------------------------------------------------ */
+const uShort LNnn[90]={9016, 8652, 8316, 8008, 7724, 7456, 7208,
+ 6972, 6748, 6540, 6340, 6148, 5968, 5792, 5628, 5464, 5312,
+ 5164, 5020, 4884, 4748, 4620, 4496, 4376, 4256, 4144, 4032,
+ 39233, 38181, 37157, 36157, 35181, 34229, 33297, 32389, 31501, 30629,
+ 29777, 28945, 28129, 27329, 26545, 25777, 25021, 24281, 23553, 22837,
+ 22137, 21445, 20769, 20101, 19445, 18801, 18165, 17541, 16925, 16321,
+ 15721, 15133, 14553, 13985, 13421, 12865, 12317, 11777, 11241, 10717,
+ 10197, 9685, 9177, 8677, 8185, 7697, 7213, 6737, 6269, 5801,
+ 5341, 4889, 4437, 39930, 35534, 31186, 26886, 22630, 18418, 14254,
+ 10130, 6046, 20055};
+
+/* ------------------------------------------------------------------ */
+/* decLnOp -- effect natural logarithm */
+/* */
+/* This computes C = ln(A) */
+/* */
+/* res is C, the result. C may be A */
+/* rhs is A */
+/* set is the context; note that rounding mode has no effect */
+/* */
+/* C must have space for set->digits digits. */
+/* */
+/* Notable cases: */
+/* A<0 -> Invalid */
+/* A=0 -> -Infinity (Exact) */
+/* A=+Infinity -> +Infinity (Exact) */
+/* A=1 exactly -> 0 (Exact) */
+/* */
+/* Restrictions (as for Exp): */
+/* */
+/* digits, emax, and -emin in the context must be less than */
+/* DEC_MAX_MATH+11 (1000010), and the rhs must be within these */
+/* bounds or a zero. This is an internal routine, so these */
+/* restrictions are contractual and not enforced. */
+/* */
+/* A finite result is rounded using DEC_ROUND_HALF_EVEN; it will */
+/* almost always be correctly rounded, but may be up to 1 ulp in */
+/* error in rare cases. */
+/* ------------------------------------------------------------------ */
+/* The result is calculated using Newton's method, with each */
+/* iteration calculating a' = a + x * exp(-a) - 1. See, for example, */
+/* Epperson 1989. */
+/* */
+/* The iteration ends when the adjustment x*exp(-a)-1 is tiny enough. */
+/* This has to be calculated at the sum of the precision of x and the */
+/* working precision. */
+/* */
+/* Implementation notes: */
+/* */
+/* 1. This is separated out as decLnOp so it can be called from */
+/* other Mathematical functions (e.g., Log 10) with a wider range */
+/* than normal. In particular, it can handle the slightly wider */
+/* (+9+2) range needed by a power function. */
+/* */
+/* 2. The speed of this function is about 10x slower than exp, as */
+/* it typically needs 4-6 iterations for short numbers, and the */
+/* extra precision needed adds a squaring effect, twice. */
+/* */
+/* 3. Fastpaths are included for ln(10) and ln(2), up to length 40, */
+/* as these are common requests. ln(10) is used by log10(x). */
+/* */
+/* 4. An iteration might be saved by widening the LNnn table, and */
+/* would certainly save at least one if it were made ten times */
+/* bigger, too (for truncated fractions 0.100 through 0.999). */
+/* However, for most practical evaluations, at least four or five */
+/* iterations will be neede -- so this would only speed up by */
+/* 20-25% and that probably does not justify increasing the table */
+/* size. */
+/* */
+/* 5. The static buffers are larger than might be expected to allow */
+/* for calls from decNumberPower. */
+/* ------------------------------------------------------------------ */
+decNumber * decLnOp(decNumber *res, const decNumber *rhs,
+ decContext *set, uInt *status) {
+ uInt ignore=0; // working status accumulator
+ uInt needbytes; // for space calculations
+ Int residue; // rounding residue
+ Int r; // rhs=f*10**r [see below]
+ Int p; // working precision
+ Int pp; // precision for iteration
+ Int t; // work
+
+ // buffers for a (accumulator, typically precision+2) and b
+ // (adjustment calculator, same size)
+ decNumber bufa[D2N(DECBUFFER+12)];
+ decNumber *allocbufa=NULL; // -> allocated bufa, iff allocated
+ decNumber *a=bufa; // accumulator/work
+ decNumber bufb[D2N(DECBUFFER*2+2)];
+ decNumber *allocbufb=NULL; // -> allocated bufa, iff allocated
+ decNumber *b=bufb; // adjustment/work
+
+ decNumber numone; // constant 1
+ decNumber cmp; // work
+ decContext aset, bset; // working contexts
+
+ #if DECCHECK
+ Int iterations=0; // for later sanity check
+ if (decCheckOperands(res, DECUNUSED, rhs, set)) return res;
+ #endif
+
+ do { // protect allocated storage
+ if (SPECIALARG) { // handle infinities and NaNs
+ if (decNumberIsInfinite(rhs)) { // an infinity
+ if (decNumberIsNegative(rhs)) // -Infinity -> error
+ *status|=DEC_Invalid_operation;
+ else decNumberCopy(res, rhs); // +Infinity -> self
+ }
+ else decNaNs(res, rhs, NULL, set, status); // a NaN
+ break;}
+
+ if (ISZERO(rhs)) { // +/- zeros -> -Infinity
+ decNumberZero(res); // make clean
+ res->bits=DECINF|DECNEG; // set - infinity
+ break;} // [no status to set]
+
+ // Non-zero negatives are bad...
+ if (decNumberIsNegative(rhs)) { // -x -> error
+ *status|=DEC_Invalid_operation;
+ break;}
+
+ // Here, rhs is positive, finite, and in range
+
+ // lookaside fastpath code for ln(2) and ln(10) at common lengths
+ if (rhs->exponent==0 && set->digits<=40) {
+ #if DECDPUN==1
+ if (rhs->lsu[0]==0 && rhs->lsu[1]==1 && rhs->digits==2) { // ln(10)
+ #else
+ if (rhs->lsu[0]==10 && rhs->digits==2) { // ln(10)
+ #endif
+ aset=*set; aset.round=DEC_ROUND_HALF_EVEN;
+ #define LN10 "2.302585092994045684017991454684364207601"
+ decNumberFromString(res, LN10, &aset);
+ *status|=(DEC_Inexact | DEC_Rounded); // is inexact
+ break;}
+ if (rhs->lsu[0]==2 && rhs->digits==1) { // ln(2)
+ aset=*set; aset.round=DEC_ROUND_HALF_EVEN;
+ #define LN2 "0.6931471805599453094172321214581765680755"
+ decNumberFromString(res, LN2, &aset);
+ *status|=(DEC_Inexact | DEC_Rounded);
+ break;}
+ } // integer and short
+
+ // Determine the working precision. This is normally the
+ // requested precision + 2, with a minimum of 9. However, if
+ // the rhs is 'over-precise' then allow for all its digits to
+ // potentially participate (consider an rhs where all the excess
+ // digits are 9s) so in this case use rhs->digits+2.
+ p=MAXI(rhs->digits, MAXI(set->digits, 7))+2;
+
+ // Allocate space for the accumulator and the high-precision
+ // adjustment calculator, if necessary. The accumulator must
+ // be able to hold p digits, and the adjustment up to
+ // rhs->digits+p digits. They are also made big enough for 16
+ // digits so that they can be used for calculating the initial
+ // estimate.
+ needbytes=sizeof(decNumber)+(D2U(MAXI(p,16))-1)*sizeof(Unit);
+ if (needbytes>sizeof(bufa)) { // need malloc space
+ allocbufa=(decNumber *)malloc(needbytes);
+ if (allocbufa==NULL) { // hopeless -- abandon
+ *status|=DEC_Insufficient_storage;
+ break;}
+ a=allocbufa; // use the allocated space
+ }
+ pp=p+rhs->digits;
+ needbytes=sizeof(decNumber)+(D2U(MAXI(pp,16))-1)*sizeof(Unit);
+ if (needbytes>sizeof(bufb)) { // need malloc space
+ allocbufb=(decNumber *)malloc(needbytes);
+ if (allocbufb==NULL) { // hopeless -- abandon
+ *status|=DEC_Insufficient_storage;
+ break;}
+ b=allocbufb; // use the allocated space
+ }
+
+ // Prepare an initial estimate in acc. Calculate this by
+ // considering the coefficient of x to be a normalized fraction,
+ // f, with the decimal point at far left and multiplied by
+ // 10**r. Then, rhs=f*10**r and 0.1<=f<1, and
+ // ln(x) = ln(f) + ln(10)*r
+ // Get the initial estimate for ln(f) from a small lookup
+ // table (see above) indexed by the first two digits of f,
+ // truncated.
+
+ decContextDefault(&aset, DEC_INIT_DECIMAL64); // 16-digit extended
+ r=rhs->exponent+rhs->digits; // 'normalised' exponent
+ decNumberFromInt32(a, r); // a=r
+ decNumberFromInt32(b, 2302585); // b=ln(10) (2.302585)
+ b->exponent=-6; // ..
+ decMultiplyOp(a, a, b, &aset, &ignore); // a=a*b
+ // now get top two digits of rhs into b by simple truncate and
+ // force to integer
+ residue=0; // (no residue)
+ aset.digits=2; aset.round=DEC_ROUND_DOWN;
+ decCopyFit(b, rhs, &aset, &residue, &ignore); // copy & shorten
+ b->exponent=0; // make integer
+ t=decGetInt(b); // [cannot fail]
+ if (t<10) t=X10(t); // adjust single-digit b
+ t=LNnn[t-10]; // look up ln(b)
+ decNumberFromInt32(b, t>>2); // b=ln(b) coefficient
+ b->exponent=-(t&3)-3; // set exponent
+ b->bits=DECNEG; // ln(0.10)->ln(0.99) always -ve
+ aset.digits=16; aset.round=DEC_ROUND_HALF_EVEN; // restore
+ decAddOp(a, a, b, &aset, 0, &ignore); // acc=a+b
+ // the initial estimate is now in a, with up to 4 digits correct.
+ // When rhs is at or near Nmax the estimate will be low, so we
+ // will approach it from below, avoiding overflow when calling exp.
+
+ decNumberZero(&numone); *numone.lsu=1; // constant 1 for adjustment
+
+ // accumulator bounds are as requested (could underflow, but
+ // cannot overflow)
+ aset.emax=set->emax;
+ aset.emin=set->emin;
+ aset.clamp=0; // no concrete format
+ // set up a context to be used for the multiply and subtract
+ bset=aset;
+ bset.emax=DEC_MAX_MATH*2; // use double bounds for the
+ bset.emin=-DEC_MAX_MATH*2; // adjustment calculation
+ // [see decExpOp call below]
+ // for each iteration double the number of digits to calculate,
+ // up to a maximum of p
+ pp=9; // initial precision
+ // [initially 9 as then the sequence starts 7+2, 16+2, and
+ // 34+2, which is ideal for standard-sized numbers]
+ aset.digits=pp; // working context
+ bset.digits=pp+rhs->digits; // wider context
+ for (;;) { // iterate
+ #if DECCHECK
+ iterations++;
+ if (iterations>24) break; // consider 9 * 2**24
+ #endif
+ // calculate the adjustment (exp(-a)*x-1) into b. This is a
+ // catastrophic subtraction but it really is the difference
+ // from 1 that is of interest.
+ // Use the internal entry point to Exp as it allows the double
+ // range for calculating exp(-a) when a is the tiniest subnormal.
+ a->bits^=DECNEG; // make -a
+ decExpOp(b, a, &bset, &ignore); // b=exp(-a)
+ a->bits^=DECNEG; // restore sign of a
+ // now multiply by rhs and subtract 1, at the wider precision
+ decMultiplyOp(b, b, rhs, &bset, &ignore); // b=b*rhs
+ decAddOp(b, b, &numone, &bset, DECNEG, &ignore); // b=b-1
+
+ // the iteration ends when the adjustment cannot affect the
+ // result by >=0.5 ulp (at the requested digits), which
+ // is when its value is smaller than the accumulator by
+ // set->digits+1 digits (or it is zero) -- this is a looser
+ // requirement than for Exp because all that happens to the
+ // accumulator after this is the final rounding (but note that
+ // there must also be full precision in a, or a=0).
+
+ if (decNumberIsZero(b) ||
+ (a->digits+a->exponent)>=(b->digits+b->exponent+set->digits+1)) {
+ if (a->digits==p) break;
+ if (decNumberIsZero(a)) {
+ decCompareOp(&cmp, rhs, &numone, &aset, COMPARE, &ignore); // rhs=1 ?
+ if (cmp.lsu[0]==0) a->exponent=0; // yes, exact 0
+ else *status|=(DEC_Inexact | DEC_Rounded); // no, inexact
+ break;
+ }
+ // force padding if adjustment has gone to 0 before full length
+ if (decNumberIsZero(b)) b->exponent=a->exponent-p;
+ }
+
+ // not done yet ...
+ decAddOp(a, a, b, &aset, 0, &ignore); // a=a+b for next estimate
+ if (pp==p) continue; // precision is at maximum
+ // lengthen the next calculation
+ pp=pp*2; // double precision
+ if (pp>p) pp=p; // clamp to maximum
+ aset.digits=pp; // working context
+ bset.digits=pp+rhs->digits; // wider context
+ } // Newton's iteration
+
+ #if DECCHECK
+ // just a sanity check; remove the test to show always
+ if (iterations>24)
+ printf("Ln iterations=%ld, status=%08lx, p=%ld, d=%ld\n",
+ (LI)iterations, (LI)*status, (LI)p, (LI)rhs->digits);
+ #endif
+
+ // Copy and round the result to res
+ residue=1; // indicate dirt to right
+ if (ISZERO(a)) residue=0; // .. unless underflowed to 0
+ aset.digits=set->digits; // [use default rounding]
+ decCopyFit(res, a, &aset, &residue, status); // copy & shorten
+ decFinish(res, set, &residue, status); // cleanup/set flags
+ } while(0); // end protected
+
+ if (allocbufa!=NULL) free(allocbufa); // drop any storage used
+ if (allocbufb!=NULL) free(allocbufb); // ..
+ // [status is handled by caller]
+ return res;
+ } // decLnOp
+
+/* ------------------------------------------------------------------ */
+/* decQuantizeOp -- force exponent to requested value */
+/* */
+/* This computes C = op(A, B), where op adjusts the coefficient */
+/* of C (by rounding or shifting) such that the exponent (-scale) */
+/* of C has the value B or matches the exponent of B. */
+/* The numerical value of C will equal A, except for the effects of */
+/* any rounding that occurred. */
+/* */
+/* res is C, the result. C may be A or B */
+/* lhs is A, the number to adjust */
+/* rhs is B, the requested exponent */
+/* set is the context */
+/* quant is 1 for quantize or 0 for rescale */
+/* status is the status accumulator (this can be called without */
+/* risk of control loss) */
+/* */
+/* C must have space for set->digits digits. */
+/* */
+/* Unless there is an error or the result is infinite, the exponent */
+/* after the operation is guaranteed to be that requested. */
+/* ------------------------------------------------------------------ */
+static decNumber * decQuantizeOp(decNumber *res, const decNumber *lhs,
+ const decNumber *rhs, decContext *set,
+ Flag quant, uInt *status) {
+ #if DECSUBSET
+ decNumber *alloclhs=NULL; // non-NULL if rounded lhs allocated
+ decNumber *allocrhs=NULL; // .., rhs
+ #endif
+ const decNumber *inrhs=rhs; // save original rhs
+ Int reqdigits=set->digits; // requested DIGITS
+ Int reqexp; // requested exponent [-scale]
+ Int residue=0; // rounding residue
+ Int etiny=set->emin-(reqdigits-1);
+
+ #if DECCHECK
+ if (decCheckOperands(res, lhs, rhs, set)) return res;
+ #endif
+
+ do { // protect allocated storage
+ #if DECSUBSET
+ if (!set->extended) {
+ // reduce operands and set lostDigits status, as needed
+ if (lhs->digits>reqdigits) {
+ alloclhs=decRoundOperand(lhs, set, status);
+ if (alloclhs==NULL) break;
+ lhs=alloclhs;
+ }
+ if (rhs->digits>reqdigits) { // [this only checks lostDigits]
+ allocrhs=decRoundOperand(rhs, set, status);
+ if (allocrhs==NULL) break;
+ rhs=allocrhs;
+ }
+ }
+ #endif
+ // [following code does not require input rounding]
+
+ // Handle special values
+ if (SPECIALARGS) {
+ // NaNs get usual processing
+ if (SPECIALARGS & (DECSNAN | DECNAN))
+ decNaNs(res, lhs, rhs, set, status);
+ // one infinity but not both is bad
+ else if ((lhs->bits ^ rhs->bits) & DECINF)
+ *status|=DEC_Invalid_operation;
+ // both infinity: return lhs
+ else decNumberCopy(res, lhs); // [nop if in place]
+ break;
+ }
+
+ // set requested exponent
+ if (quant) reqexp=inrhs->exponent; // quantize -- match exponents
+ else { // rescale -- use value of rhs
+ // Original rhs must be an integer that fits and is in range,
+ // which could be from -1999999997 to +999999999, thanks to
+ // subnormals
+ reqexp=decGetInt(inrhs); // [cannot fail]
+ }
+
+ #if DECSUBSET
+ if (!set->extended) etiny=set->emin; // no subnormals
+ #endif
+
+ if (reqexp==BADINT // bad (rescale only) or ..
+ || reqexp==BIGODD || reqexp==BIGEVEN // very big (ditto) or ..
+ || (reqexp<etiny) // < lowest
+ || (reqexp>set->emax)) { // > emax
+ *status|=DEC_Invalid_operation;
+ break;}
+
+ // the RHS has been processed, so it can be overwritten now if necessary
+ if (ISZERO(lhs)) { // zero coefficient unchanged
+ decNumberCopy(res, lhs); // [nop if in place]
+ res->exponent=reqexp; // .. just set exponent
+ #if DECSUBSET
+ if (!set->extended) res->bits=0; // subset specification; no -0
+ #endif
+ }
+ else { // non-zero lhs
+ Int adjust=reqexp-lhs->exponent; // digit adjustment needed
+ // if adjusted coefficient will definitely not fit, give up now
+ if ((lhs->digits-adjust)>reqdigits) {
+ *status|=DEC_Invalid_operation;
+ break;
+ }
+
+ if (adjust>0) { // increasing exponent
+ // this will decrease the length of the coefficient by adjust
+ // digits, and must round as it does so
+ decContext workset; // work
+ workset=*set; // clone rounding, etc.
+ workset.digits=lhs->digits-adjust; // set requested length
+ // [note that the latter can be <1, here]
+ decCopyFit(res, lhs, &workset, &residue, status); // fit to result
+ decApplyRound(res, &workset, residue, status); // .. and round
+ residue=0; // [used]
+ // If just rounded a 999s case, exponent will be off by one;
+ // adjust back (after checking space), if so.
+ if (res->exponent>reqexp) {
+ // re-check needed, e.g., for quantize(0.9999, 0.001) under
+ // set->digits==3
+ if (res->digits==reqdigits) { // cannot shift by 1
+ *status&=~(DEC_Inexact | DEC_Rounded); // [clean these]
+ *status|=DEC_Invalid_operation;
+ break;
+ }
+ res->digits=decShiftToMost(res->lsu, res->digits, 1); // shift
+ res->exponent--; // (re)adjust the exponent.
+ }
+ #if DECSUBSET
+ if (ISZERO(res) && !set->extended) res->bits=0; // subset; no -0
+ #endif
+ } // increase
+ else /* adjust<=0 */ { // decreasing or = exponent
+ // this will increase the length of the coefficient by -adjust
+ // digits, by adding zero or more trailing zeros; this is
+ // already checked for fit, above
+ decNumberCopy(res, lhs); // [it will fit]
+ // if padding needed (adjust<0), add it now...
+ if (adjust<0) {
+ res->digits=decShiftToMost(res->lsu, res->digits, -adjust);
+ res->exponent+=adjust; // adjust the exponent
+ }
+ } // decrease
+ } // non-zero
+
+ // Check for overflow [do not use Finalize in this case, as an
+ // overflow here is a "don't fit" situation]
+ if (res->exponent>set->emax-res->digits+1) { // too big
+ *status|=DEC_Invalid_operation;
+ break;
+ }
+ else {
+ decFinalize(res, set, &residue, status); // set subnormal flags
+ *status&=~DEC_Underflow; // suppress Underflow [as per 754]
+ }
+ } while(0); // end protected
+
+ #if DECSUBSET
+ if (allocrhs!=NULL) free(allocrhs); // drop any storage used
+ if (alloclhs!=NULL) free(alloclhs); // ..
+ #endif
+ return res;
+ } // decQuantizeOp
+
+/* ------------------------------------------------------------------ */
+/* decCompareOp -- compare, min, or max two Numbers */
+/* */
+/* This computes C = A ? B and carries out one of four operations: */
+/* COMPARE -- returns the signum (as a number) giving the */
+/* result of a comparison unless one or both */
+/* operands is a NaN (in which case a NaN results) */
+/* COMPSIG -- as COMPARE except that a quiet NaN raises */
+/* Invalid operation. */
+/* COMPMAX -- returns the larger of the operands, using the */
+/* 754 maxnum operation */
+/* COMPMAXMAG -- ditto, comparing absolute values */
+/* COMPMIN -- the 754 minnum operation */
+/* COMPMINMAG -- ditto, comparing absolute values */
+/* COMTOTAL -- returns the signum (as a number) giving the */
+/* result of a comparison using 754 total ordering */
+/* */
+/* res is C, the result. C may be A and/or B (e.g., X=X?X) */
+/* lhs is A */
+/* rhs is B */
+/* set is the context */
+/* op is the operation flag */
+/* status is the usual accumulator */
+/* */
+/* C must have space for one digit for COMPARE or set->digits for */
+/* COMPMAX, COMPMIN, COMPMAXMAG, or COMPMINMAG. */
+/* ------------------------------------------------------------------ */
+/* The emphasis here is on speed for common cases, and avoiding */
+/* coefficient comparison if possible. */
+/* ------------------------------------------------------------------ */
+decNumber * decCompareOp(decNumber *res, const decNumber *lhs,
+ const decNumber *rhs, decContext *set,
+ Flag op, uInt *status) {
+ #if DECSUBSET
+ decNumber *alloclhs=NULL; // non-NULL if rounded lhs allocated
+ decNumber *allocrhs=NULL; // .., rhs
+ #endif
+ Int result=0; // default result value
+ uByte merged; // work
+
+ #if DECCHECK
+ if (decCheckOperands(res, lhs, rhs, set)) return res;
+ #endif
+
+ do { // protect allocated storage
+ #if DECSUBSET
+ if (!set->extended) {
+ // reduce operands and set lostDigits status, as needed
+ if (lhs->digits>set->digits) {
+ alloclhs=decRoundOperand(lhs, set, status);
+ if (alloclhs==NULL) {result=BADINT; break;}
+ lhs=alloclhs;
+ }
+ if (rhs->digits>set->digits) {
+ allocrhs=decRoundOperand(rhs, set, status);
+ if (allocrhs==NULL) {result=BADINT; break;}
+ rhs=allocrhs;
+ }
+ }
+ #endif
+ // [following code does not require input rounding]
+
+ // If total ordering then handle differing signs 'up front'
+ if (op==COMPTOTAL) { // total ordering
+ if (decNumberIsNegative(lhs) & !decNumberIsNegative(rhs)) {
+ result=-1;
+ break;
+ }
+ if (!decNumberIsNegative(lhs) & decNumberIsNegative(rhs)) {
+ result=+1;
+ break;
+ }
+ }
+
+ // handle NaNs specially; let infinities drop through
+ // This assumes sNaN (even just one) leads to NaN.
+ merged=(lhs->bits | rhs->bits) & (DECSNAN | DECNAN);
+ if (merged) { // a NaN bit set
+ if (op==COMPARE); // result will be NaN
+ else if (op==COMPSIG) // treat qNaN as sNaN
+ *status|=DEC_Invalid_operation | DEC_sNaN;
+ else if (op==COMPTOTAL) { // total ordering, always finite
+ // signs are known to be the same; compute the ordering here
+ // as if the signs are both positive, then invert for negatives
+ if (!decNumberIsNaN(lhs)) result=-1;
+ else if (!decNumberIsNaN(rhs)) result=+1;
+ // here if both NaNs
+ else if (decNumberIsSNaN(lhs) && decNumberIsQNaN(rhs)) result=-1;
+ else if (decNumberIsQNaN(lhs) && decNumberIsSNaN(rhs)) result=+1;
+ else { // both NaN or both sNaN
+ // now it just depends on the payload
+ result=decUnitCompare(lhs->lsu, D2U(lhs->digits),
+ rhs->lsu, D2U(rhs->digits), 0);
+ // [Error not possible, as these are 'aligned']
+ } // both same NaNs
+ if (decNumberIsNegative(lhs)) result=-result;
+ break;
+ } // total order
+
+ else if (merged & DECSNAN); // sNaN -> qNaN
+ else { // here if MIN or MAX and one or two quiet NaNs
+ // min or max -- 754 rules ignore single NaN
+ if (!decNumberIsNaN(lhs) || !decNumberIsNaN(rhs)) {
+ // just one NaN; force choice to be the non-NaN operand
+ op=COMPMAX;
+ if (lhs->bits & DECNAN) result=-1; // pick rhs
+ else result=+1; // pick lhs
+ break;
+ }
+ } // max or min
+ op=COMPNAN; // use special path
+ decNaNs(res, lhs, rhs, set, status); // propagate NaN
+ break;
+ }
+ // have numbers
+ if (op==COMPMAXMAG || op==COMPMINMAG) result=decCompare(lhs, rhs, 1);
+ else result=decCompare(lhs, rhs, 0); // sign matters
+ } while(0); // end protected
+
+ if (result==BADINT) *status|=DEC_Insufficient_storage; // rare
+ else {
+ if (op==COMPARE || op==COMPSIG ||op==COMPTOTAL) { // returning signum
+ if (op==COMPTOTAL && result==0) {
+ // operands are numerically equal or same NaN (and same sign,
+ // tested first); if identical, leave result 0
+ if (lhs->exponent!=rhs->exponent) {
+ if (lhs->exponent<rhs->exponent) result=-1;
+ else result=+1;
+ if (decNumberIsNegative(lhs)) result=-result;
+ } // lexp!=rexp
+ } // total-order by exponent
+ decNumberZero(res); // [always a valid result]
+ if (result!=0) { // must be -1 or +1
+ *res->lsu=1;
+ if (result<0) res->bits=DECNEG;
+ }
+ }
+ else if (op==COMPNAN); // special, drop through
+ else { // MAX or MIN, non-NaN result
+ Int residue=0; // rounding accumulator
+ // choose the operand for the result
+ const decNumber *choice;
+ if (result==0) { // operands are numerically equal
+ // choose according to sign then exponent (see 754)
+ uByte slhs=(lhs->bits & DECNEG);
+ uByte srhs=(rhs->bits & DECNEG);
+ #if DECSUBSET
+ if (!set->extended) { // subset: force left-hand
+ op=COMPMAX;
+ result=+1;
+ }
+ else
+ #endif
+ if (slhs!=srhs) { // signs differ
+ if (slhs) result=-1; // rhs is max
+ else result=+1; // lhs is max
+ }
+ else if (slhs && srhs) { // both negative
+ if (lhs->exponent<rhs->exponent) result=+1;
+ else result=-1;
+ // [if equal, use lhs, technically identical]
+ }
+ else { // both positive
+ if (lhs->exponent>rhs->exponent) result=+1;
+ else result=-1;
+ // [ditto]
+ }
+ } // numerically equal
+ // here result will be non-0; reverse if looking for MIN
+ if (op==COMPMIN || op==COMPMINMAG) result=-result;
+ choice=(result>0 ? lhs : rhs); // choose
+ // copy chosen to result, rounding if need be
+ decCopyFit(res, choice, set, &residue, status);
+ decFinish(res, set, &residue, status);
+ }
+ }
+ #if DECSUBSET
+ if (allocrhs!=NULL) free(allocrhs); // free any storage used
+ if (alloclhs!=NULL) free(alloclhs); // ..
+ #endif
+ return res;
+ } // decCompareOp
+
+/* ------------------------------------------------------------------ */
+/* decCompare -- compare two decNumbers by numerical value */
+/* */
+/* This routine compares A ? B without altering them. */
+/* */
+/* Arg1 is A, a decNumber which is not a NaN */
+/* Arg2 is B, a decNumber which is not a NaN */
+/* Arg3 is 1 for a sign-independent compare, 0 otherwise */
+/* */
+/* returns -1, 0, or 1 for A<B, A==B, or A>B, or BADINT if failure */
+/* (the only possible failure is an allocation error) */
+/* ------------------------------------------------------------------ */
+static Int decCompare(const decNumber *lhs, const decNumber *rhs,
+ Flag abs) {
+ Int result; // result value
+ Int sigr; // rhs signum
+ Int compare; // work
+
+ result=1; // assume signum(lhs)
+ if (ISZERO(lhs)) result=0;
+ if (abs) {
+ if (ISZERO(rhs)) return result; // LHS wins or both 0
+ // RHS is non-zero
+ if (result==0) return -1; // LHS is 0; RHS wins
+ // [here, both non-zero, result=1]
+ }
+ else { // signs matter
+ if (result && decNumberIsNegative(lhs)) result=-1;
+ sigr=1; // compute signum(rhs)
+ if (ISZERO(rhs)) sigr=0;
+ else if (decNumberIsNegative(rhs)) sigr=-1;
+ if (result > sigr) return +1; // L > R, return 1
+ if (result < sigr) return -1; // L < R, return -1
+ if (result==0) return 0; // both 0
+ }
+
+ // signums are the same; both are non-zero
+ if ((lhs->bits | rhs->bits) & DECINF) { // one or more infinities
+ if (decNumberIsInfinite(rhs)) {
+ if (decNumberIsInfinite(lhs)) result=0;// both infinite
+ else result=-result; // only rhs infinite
+ }
+ return result;
+ }
+ // must compare the coefficients, allowing for exponents
+ if (lhs->exponent>rhs->exponent) { // LHS exponent larger
+ // swap sides, and sign
+ const decNumber *temp=lhs;
+ lhs=rhs;
+ rhs=temp;
+ result=-result;
+ }
+ compare=decUnitCompare(lhs->lsu, D2U(lhs->digits),
+ rhs->lsu, D2U(rhs->digits),
+ rhs->exponent-lhs->exponent);
+ if (compare!=BADINT) compare*=result; // comparison succeeded
+ return compare;
+ } // decCompare
+
+/* ------------------------------------------------------------------ */
+/* decUnitCompare -- compare two >=0 integers in Unit arrays */
+/* */
+/* This routine compares A ? B*10**E where A and B are unit arrays */
+/* A is a plain integer */
+/* B has an exponent of E (which must be non-negative) */
+/* */
+/* Arg1 is A first Unit (lsu) */
+/* Arg2 is A length in Units */
+/* Arg3 is B first Unit (lsu) */
+/* Arg4 is B length in Units */
+/* Arg5 is E (0 if the units are aligned) */
+/* */
+/* returns -1, 0, or 1 for A<B, A==B, or A>B, or BADINT if failure */
+/* (the only possible failure is an allocation error, which can */
+/* only occur if E!=0) */
+/* ------------------------------------------------------------------ */
+static Int decUnitCompare(const Unit *a, Int alength,
+ const Unit *b, Int blength, Int exp) {
+ Unit *acc; // accumulator for result
+ Unit accbuff[SD2U(DECBUFFER*2+1)]; // local buffer
+ Unit *allocacc=NULL; // -> allocated acc buffer, iff allocated
+ Int accunits, need; // units in use or needed for acc
+ const Unit *l, *r, *u; // work
+ Int expunits, exprem, result; // ..
+
+ if (exp==0) { // aligned; fastpath
+ if (alength>blength) return 1;
+ if (alength<blength) return -1;
+ // same number of units in both -- need unit-by-unit compare
+ l=a+alength-1;
+ r=b+alength-1;
+ for (;l>=a; l--, r--) {
+ if (*l>*r) return 1;
+ if (*l<*r) return -1;
+ }
+ return 0; // all units match
+ } // aligned
+
+ // Unaligned. If one is >1 unit longer than the other, padded
+ // approximately, then can return easily
+ if (alength>blength+(Int)D2U(exp)) return 1;
+ if (alength+1<blength+(Int)D2U(exp)) return -1;
+
+ // Need to do a real subtract. For this, a result buffer is needed
+ // even though only the sign is of interest. Its length needs
+ // to be the larger of alength and padded blength, +2
+ need=blength+D2U(exp); // maximum real length of B
+ if (need<alength) need=alength;
+ need+=2;
+ acc=accbuff; // assume use local buffer
+ if (need*sizeof(Unit)>sizeof(accbuff)) {
+ allocacc=(Unit *)malloc(need*sizeof(Unit));
+ if (allocacc==NULL) return BADINT; // hopeless -- abandon
+ acc=allocacc;
+ }
+ // Calculate units and remainder from exponent.
+ expunits=exp/DECDPUN;
+ exprem=exp%DECDPUN;
+ // subtract [A+B*(-m)]
+ accunits=decUnitAddSub(a, alength, b, blength, expunits, acc,
+ -(Int)powers[exprem]);
+ // [UnitAddSub result may have leading zeros, even on zero]
+ if (accunits<0) result=-1; // negative result
+ else { // non-negative result
+ // check units of the result before freeing any storage
+ for (u=acc; u<acc+accunits-1 && *u==0;) u++;
+ result=(*u==0 ? 0 : +1);
+ }
+ // clean up and return the result
+ if (allocacc!=NULL) free(allocacc); // drop any storage used
+ return result;
+ } // decUnitCompare
+
+/* ------------------------------------------------------------------ */
+/* decUnitAddSub -- add or subtract two >=0 integers in Unit arrays */
+/* */
+/* This routine performs the calculation: */
+/* */
+/* C=A+(B*M) */
+/* */
+/* Where M is in the range -DECDPUNMAX through +DECDPUNMAX. */
+/* */
+/* A may be shorter or longer than B. */
+/* */
+/* Leading zeros are not removed after a calculation. The result is */
+/* either the same length as the longer of A and B (adding any */
+/* shift), or one Unit longer than that (if a Unit carry occurred). */
+/* */
+/* A and B content are not altered unless C is also A or B. */
+/* C may be the same array as A or B, but only if no zero padding is */
+/* requested (that is, C may be B only if bshift==0). */
+/* C is filled from the lsu; only those units necessary to complete */
+/* the calculation are referenced. */
+/* */
+/* Arg1 is A first Unit (lsu) */
+/* Arg2 is A length in Units */
+/* Arg3 is B first Unit (lsu) */
+/* Arg4 is B length in Units */
+/* Arg5 is B shift in Units (>=0; pads with 0 units if positive) */
+/* Arg6 is C first Unit (lsu) */
+/* Arg7 is M, the multiplier */
+/* */
+/* returns the count of Units written to C, which will be non-zero */
+/* and negated if the result is negative. That is, the sign of the */
+/* returned Int is the sign of the result (positive for zero) and */
+/* the absolute value of the Int is the count of Units. */
+/* */
+/* It is the caller's responsibility to make sure that C size is */
+/* safe, allowing space if necessary for a one-Unit carry. */
+/* */
+/* This routine is severely performance-critical; *any* change here */
+/* must be measured (timed) to assure no performance degradation. */
+/* In particular, trickery here tends to be counter-productive, as */
+/* increased complexity of code hurts register optimizations on */
+/* register-poor architectures. Avoiding divisions is nearly */
+/* always a Good Idea, however. */
+/* */
+/* Special thanks to Rick McGuire (IBM Cambridge, MA) and Dave Clark */
+/* (IBM Warwick, UK) for some of the ideas used in this routine. */
+/* ------------------------------------------------------------------ */
+static Int decUnitAddSub(const Unit *a, Int alength,
+ const Unit *b, Int blength, Int bshift,
+ Unit *c, Int m) {
+ const Unit *alsu=a; // A lsu [need to remember it]
+ Unit *clsu=c; // C ditto
+ Unit *minC; // low water mark for C
+ Unit *maxC; // high water mark for C
+ eInt carry=0; // carry integer (could be Long)
+ Int add; // work
+ #if DECDPUN<=4 // myriadal, millenary, etc.
+ Int est; // estimated quotient
+ #endif
+
+ #if DECTRACE
+ if (alength<1 || blength<1)
+ printf("decUnitAddSub: alen blen m %ld %ld [%ld]\n", alength, blength, m);
+ #endif
+
+ maxC=c+alength; // A is usually the longer
+ minC=c+blength; // .. and B the shorter
+ if (bshift!=0) { // B is shifted; low As copy across
+ minC+=bshift;
+ // if in place [common], skip copy unless there's a gap [rare]
+ if (a==c && bshift<=alength) {
+ c+=bshift;
+ a+=bshift;
+ }
+ else for (; c<clsu+bshift; a++, c++) { // copy needed
+ if (a<alsu+alength) *c=*a;
+ else *c=0;
+ }
+ }
+ if (minC>maxC) { // swap
+ Unit *hold=minC;
+ minC=maxC;
+ maxC=hold;
+ }
+
+ // For speed, do the addition as two loops; the first where both A
+ // and B contribute, and the second (if necessary) where only one or
+ // other of the numbers contribute.
+ // Carry handling is the same (i.e., duplicated) in each case.
+ for (; c<minC; c++) {
+ carry+=*a;
+ a++;
+ carry+=((eInt)*b)*m; // [special-casing m=1/-1
+ b++; // here is not a win]
+ // here carry is new Unit of digits; it could be +ve or -ve
+ if ((ueInt)carry<=DECDPUNMAX) { // fastpath 0-DECDPUNMAX
+ *c=(Unit)carry;
+ carry=0;
+ continue;
+ }
+ #if DECDPUN==4 // use divide-by-multiply
+ if (carry>=0) {
+ est=(((ueInt)carry>>11)*53687)>>18;
+ *c=(Unit)(carry-est*(DECDPUNMAX+1)); // remainder
+ carry=est; // likely quotient [89%]
+ if (*c<DECDPUNMAX+1) continue; // estimate was correct
+ carry++;
+ *c-=DECDPUNMAX+1;
+ continue;
+ }
+ // negative case
+ carry=carry+(eInt)(DECDPUNMAX+1)*(DECDPUNMAX+1); // make positive
+ est=(((ueInt)carry>>11)*53687)>>18;
+ *c=(Unit)(carry-est*(DECDPUNMAX+1));
+ carry=est-(DECDPUNMAX+1); // correctly negative
+ if (*c<DECDPUNMAX+1) continue; // was OK
+ carry++;
+ *c-=DECDPUNMAX+1;
+ #elif DECDPUN==3
+ if (carry>=0) {
+ est=(((ueInt)carry>>3)*16777)>>21;
+ *c=(Unit)(carry-est*(DECDPUNMAX+1)); // remainder
+ carry=est; // likely quotient [99%]
+ if (*c<DECDPUNMAX+1) continue; // estimate was correct
+ carry++;
+ *c-=DECDPUNMAX+1;
+ continue;
+ }
+ // negative case
+ carry=carry+(eInt)(DECDPUNMAX+1)*(DECDPUNMAX+1); // make positive
+ est=(((ueInt)carry>>3)*16777)>>21;
+ *c=(Unit)(carry-est*(DECDPUNMAX+1));
+ carry=est-(DECDPUNMAX+1); // correctly negative
+ if (*c<DECDPUNMAX+1) continue; // was OK
+ carry++;
+ *c-=DECDPUNMAX+1;
+ #elif DECDPUN<=2
+ // Can use QUOT10 as carry <= 4 digits
+ if (carry>=0) {
+ est=QUOT10(carry, DECDPUN);
+ *c=(Unit)(carry-est*(DECDPUNMAX+1)); // remainder
+ carry=est; // quotient
+ continue;
+ }
+ // negative case
+ carry=carry+(eInt)(DECDPUNMAX+1)*(DECDPUNMAX+1); // make positive
+ est=QUOT10(carry, DECDPUN);
+ *c=(Unit)(carry-est*(DECDPUNMAX+1));
+ carry=est-(DECDPUNMAX+1); // correctly negative
+ #else
+ // remainder operator is undefined if negative, so must test
+ if ((ueInt)carry<(DECDPUNMAX+1)*2) { // fastpath carry +1
+ *c=(Unit)(carry-(DECDPUNMAX+1)); // [helps additions]
+ carry=1;
+ continue;
+ }
+ if (carry>=0) {
+ *c=(Unit)(carry%(DECDPUNMAX+1));
+ carry=carry/(DECDPUNMAX+1);
+ continue;
+ }
+ // negative case
+ carry=carry+(eInt)(DECDPUNMAX+1)*(DECDPUNMAX+1); // make positive
+ *c=(Unit)(carry%(DECDPUNMAX+1));
+ carry=carry/(DECDPUNMAX+1)-(DECDPUNMAX+1);
+ #endif
+ } // c
+
+ // now may have one or other to complete
+ // [pretest to avoid loop setup/shutdown]
+ if (c<maxC) for (; c<maxC; c++) {
+ if (a<alsu+alength) { // still in A
+ carry+=*a;
+ a++;
+ }
+ else { // inside B
+ carry+=((eInt)*b)*m;
+ b++;
+ }
+ // here carry is new Unit of digits; it could be +ve or -ve and
+ // magnitude up to DECDPUNMAX squared
+ if ((ueInt)carry<=DECDPUNMAX) { // fastpath 0-DECDPUNMAX
+ *c=(Unit)carry;
+ carry=0;
+ continue;
+ }
+ // result for this unit is negative or >DECDPUNMAX
+ #if DECDPUN==4 // use divide-by-multiply
+ if (carry>=0) {
+ est=(((ueInt)carry>>11)*53687)>>18;
+ *c=(Unit)(carry-est*(DECDPUNMAX+1)); // remainder
+ carry=est; // likely quotient [79.7%]
+ if (*c<DECDPUNMAX+1) continue; // estimate was correct
+ carry++;
+ *c-=DECDPUNMAX+1;
+ continue;
+ }
+ // negative case
+ carry=carry+(eInt)(DECDPUNMAX+1)*(DECDPUNMAX+1); // make positive
+ est=(((ueInt)carry>>11)*53687)>>18;
+ *c=(Unit)(carry-est*(DECDPUNMAX+1));
+ carry=est-(DECDPUNMAX+1); // correctly negative
+ if (*c<DECDPUNMAX+1) continue; // was OK
+ carry++;
+ *c-=DECDPUNMAX+1;
+ #elif DECDPUN==3
+ if (carry>=0) {
+ est=(((ueInt)carry>>3)*16777)>>21;
+ *c=(Unit)(carry-est*(DECDPUNMAX+1)); // remainder
+ carry=est; // likely quotient [99%]
+ if (*c<DECDPUNMAX+1) continue; // estimate was correct
+ carry++;
+ *c-=DECDPUNMAX+1;
+ continue;
+ }
+ // negative case
+ carry=carry+(eInt)(DECDPUNMAX+1)*(DECDPUNMAX+1); // make positive
+ est=(((ueInt)carry>>3)*16777)>>21;
+ *c=(Unit)(carry-est*(DECDPUNMAX+1));
+ carry=est-(DECDPUNMAX+1); // correctly negative
+ if (*c<DECDPUNMAX+1) continue; // was OK
+ carry++;
+ *c-=DECDPUNMAX+1;
+ #elif DECDPUN<=2
+ if (carry>=0) {
+ est=QUOT10(carry, DECDPUN);
+ *c=(Unit)(carry-est*(DECDPUNMAX+1)); // remainder
+ carry=est; // quotient
+ continue;
+ }
+ // negative case
+ carry=carry+(eInt)(DECDPUNMAX+1)*(DECDPUNMAX+1); // make positive
+ est=QUOT10(carry, DECDPUN);
+ *c=(Unit)(carry-est*(DECDPUNMAX+1));
+ carry=est-(DECDPUNMAX+1); // correctly negative
+ #else
+ if ((ueInt)carry<(DECDPUNMAX+1)*2){ // fastpath carry 1
+ *c=(Unit)(carry-(DECDPUNMAX+1));
+ carry=1;
+ continue;
+ }
+ // remainder operator is undefined if negative, so must test
+ if (carry>=0) {
+ *c=(Unit)(carry%(DECDPUNMAX+1));
+ carry=carry/(DECDPUNMAX+1);
+ continue;
+ }
+ // negative case
+ carry=carry+(eInt)(DECDPUNMAX+1)*(DECDPUNMAX+1); // make positive
+ *c=(Unit)(carry%(DECDPUNMAX+1));
+ carry=carry/(DECDPUNMAX+1)-(DECDPUNMAX+1);
+ #endif
+ } // c
+
+ // OK, all A and B processed; might still have carry or borrow
+ // return number of Units in the result, negated if a borrow
+ if (carry==0) return c-clsu; // no carry, so no more to do
+ if (carry>0) { // positive carry
+ *c=(Unit)carry; // place as new unit
+ c++; // ..
+ return c-clsu;
+ }
+ // -ve carry: it's a borrow; complement needed
+ add=1; // temporary carry...
+ for (c=clsu; c<maxC; c++) {
+ add=DECDPUNMAX+add-*c;
+ if (add<=DECDPUNMAX) {
+ *c=(Unit)add;
+ add=0;
+ }
+ else {
+ *c=0;
+ add=1;
+ }
+ }
+ // add an extra unit iff it would be non-zero
+ #if DECTRACE
+ printf("UAS borrow: add %ld, carry %ld\n", add, carry);
+ #endif
+ if ((add-carry-1)!=0) {
+ *c=(Unit)(add-carry-1);
+ c++; // interesting, include it
+ }
+ return clsu-c; // -ve result indicates borrowed
+ } // decUnitAddSub
+
+/* ------------------------------------------------------------------ */
+/* decTrim -- trim trailing zeros or normalize */
+/* */
+/* dn is the number to trim or normalize */
+/* set is the context to use to check for clamp */
+/* all is 1 to remove all trailing zeros, 0 for just fraction ones */
+/* noclamp is 1 to unconditional (unclamped) trim */
+/* dropped returns the number of discarded trailing zeros */
+/* returns dn */
+/* */
+/* If clamp is set in the context then the number of zeros trimmed */
+/* may be limited if the exponent is high. */
+/* All fields are updated as required. This is a utility operation, */
+/* so special values are unchanged and no error is possible. */
+/* ------------------------------------------------------------------ */
+static decNumber * decTrim(decNumber *dn, decContext *set, Flag all,
+ Flag noclamp, Int *dropped) {
+ Int d, exp; // work
+ uInt cut; // ..
+ Unit *up; // -> current Unit
+
+ #if DECCHECK
+ if (decCheckOperands(dn, DECUNUSED, DECUNUSED, DECUNCONT)) return dn;
+ #endif
+
+ *dropped=0; // assume no zeros dropped
+ if ((dn->bits & DECSPECIAL) // fast exit if special ..
+ || (*dn->lsu & 0x01)) return dn; // .. or odd
+ if (ISZERO(dn)) { // .. or 0
+ dn->exponent=0; // (sign is preserved)
+ return dn;
+ }
+
+ // have a finite number which is even
+ exp=dn->exponent;
+ cut=1; // digit (1-DECDPUN) in Unit
+ up=dn->lsu; // -> current Unit
+ for (d=0; d<dn->digits-1; d++) { // [don't strip the final digit]
+ // slice by powers
+ #if DECDPUN<=4
+ uInt quot=QUOT10(*up, cut);
+ if ((*up-quot*powers[cut])!=0) break; // found non-0 digit
+ #else
+ if (*up%powers[cut]!=0) break; // found non-0 digit
+ #endif
+ // have a trailing 0
+ if (!all) { // trimming
+ // [if exp>0 then all trailing 0s are significant for trim]
+ if (exp<=0) { // if digit might be significant
+ if (exp==0) break; // then quit
+ exp++; // next digit might be significant
+ }
+ }
+ cut++; // next power
+ if (cut>DECDPUN) { // need new Unit
+ up++;
+ cut=1;
+ }
+ } // d
+ if (d==0) return dn; // none to drop
+
+ // may need to limit drop if clamping
+ if (set->clamp && !noclamp) {
+ Int maxd=set->emax-set->digits+1-dn->exponent;
+ if (maxd<=0) return dn; // nothing possible
+ if (d>maxd) d=maxd;
+ }
+
+ // effect the drop
+ decShiftToLeast(dn->lsu, D2U(dn->digits), d);
+ dn->exponent+=d; // maintain numerical value
+ dn->digits-=d; // new length
+ *dropped=d; // report the count
+ return dn;
+ } // decTrim
+
+/* ------------------------------------------------------------------ */
+/* decReverse -- reverse a Unit array in place */
+/* */
+/* ulo is the start of the array */
+/* uhi is the end of the array (highest Unit to include) */
+/* */
+/* The units ulo through uhi are reversed in place (if the number */
+/* of units is odd, the middle one is untouched). Note that the */
+/* digit(s) in each unit are unaffected. */
+/* ------------------------------------------------------------------ */
+static void decReverse(Unit *ulo, Unit *uhi) {
+ Unit temp;
+ for (; ulo<uhi; ulo++, uhi--) {
+ temp=*ulo;
+ *ulo=*uhi;
+ *uhi=temp;
+ }
+ return;
+ } // decReverse
+
+/* ------------------------------------------------------------------ */
+/* decShiftToMost -- shift digits in array towards most significant */
+/* */
+/* uar is the array */
+/* digits is the count of digits in use in the array */
+/* shift is the number of zeros to pad with (least significant); */
+/* it must be zero or positive */
+/* */
+/* returns the new length of the integer in the array, in digits */
+/* */
+/* No overflow is permitted (that is, the uar array must be known to */
+/* be large enough to hold the result, after shifting). */
+/* ------------------------------------------------------------------ */
+static Int decShiftToMost(Unit *uar, Int digits, Int shift) {
+ Unit *target, *source, *first; // work
+ Int cut; // odd 0's to add
+ uInt next; // work
+
+ if (shift==0) return digits; // [fastpath] nothing to do
+ if ((digits+shift)<=DECDPUN) { // [fastpath] single-unit case
+ *uar=(Unit)(*uar*powers[shift]);
+ return digits+shift;
+ }
+
+ next=0; // all paths
+ source=uar+D2U(digits)-1; // where msu comes from
+ target=source+D2U(shift); // where upper part of first cut goes
+ cut=DECDPUN-MSUDIGITS(shift); // where to slice
+ if (cut==0) { // unit-boundary case
+ for (; source>=uar; source--, target--) *target=*source;
+ }
+ else {
+ first=uar+D2U(digits+shift)-1; // where msu of source will end up
+ for (; source>=uar; source--, target--) {
+ // split the source Unit and accumulate remainder for next
+ #if DECDPUN<=4
+ uInt quot=QUOT10(*source, cut);
+ uInt rem=*source-quot*powers[cut];
+ next+=quot;
+ #else
+ uInt rem=*source%powers[cut];
+ next+=*source/powers[cut];
+ #endif
+ if (target<=first) *target=(Unit)next; // write to target iff valid
+ next=rem*powers[DECDPUN-cut]; // save remainder for next Unit
+ }
+ } // shift-move
+
+ // propagate any partial unit to one below and clear the rest
+ for (; target>=uar; target--) {
+ *target=(Unit)next;
+ next=0;
+ }
+ return digits+shift;
+ } // decShiftToMost
+
+/* ------------------------------------------------------------------ */
+/* decShiftToLeast -- shift digits in array towards least significant */
+/* */
+/* uar is the array */
+/* units is length of the array, in units */
+/* shift is the number of digits to remove from the lsu end; it */
+/* must be zero or positive and <= than units*DECDPUN. */
+/* */
+/* returns the new length of the integer in the array, in units */
+/* */
+/* Removed digits are discarded (lost). Units not required to hold */
+/* the final result are unchanged. */
+/* ------------------------------------------------------------------ */
+static Int decShiftToLeast(Unit *uar, Int units, Int shift) {
+ Unit *target, *up; // work
+ Int cut, count; // work
+ Int quot, rem; // for division
+
+ if (shift==0) return units; // [fastpath] nothing to do
+ if (shift==units*DECDPUN) { // [fastpath] little to do
+ *uar=0; // all digits cleared gives zero
+ return 1; // leaves just the one
+ }
+
+ target=uar; // both paths
+ cut=MSUDIGITS(shift);
+ if (cut==DECDPUN) { // unit-boundary case; easy
+ up=uar+D2U(shift);
+ for (; up<uar+units; target++, up++) *target=*up;
+ return target-uar;
+ }
+
+ // messier
+ up=uar+D2U(shift-cut); // source; correct to whole Units
+ count=units*DECDPUN-shift; // the maximum new length
+ #if DECDPUN<=4
+ quot=QUOT10(*up, cut);
+ #else
+ quot=*up/powers[cut];
+ #endif
+ for (; ; target++) {
+ *target=(Unit)quot;
+ count-=(DECDPUN-cut);
+ if (count<=0) break;
+ up++;
+ quot=*up;
+ #if DECDPUN<=4
+ quot=QUOT10(quot, cut);
+ rem=*up-quot*powers[cut];
+ #else
+ rem=quot%powers[cut];
+ quot=quot/powers[cut];
+ #endif
+ *target=(Unit)(*target+rem*powers[DECDPUN-cut]);
+ count-=cut;
+ if (count<=0) break;
+ }
+ return target-uar+1;
+ } // decShiftToLeast
+
+#if DECSUBSET
+/* ------------------------------------------------------------------ */
+/* decRoundOperand -- round an operand [used for subset only] */
+/* */
+/* dn is the number to round (dn->digits is > set->digits) */
+/* set is the relevant context */
+/* status is the status accumulator */
+/* */
+/* returns an allocated decNumber with the rounded result. */
+/* */
+/* lostDigits and other status may be set by this. */
+/* */
+/* Since the input is an operand, it must not be modified. */
+/* Instead, return an allocated decNumber, rounded as required. */
+/* It is the caller's responsibility to free the allocated storage. */
+/* */
+/* If no storage is available then the result cannot be used, so NULL */
+/* is returned. */
+/* ------------------------------------------------------------------ */
+static decNumber *decRoundOperand(const decNumber *dn, decContext *set,
+ uInt *status) {
+ decNumber *res; // result structure
+ uInt newstatus=0; // status from round
+ Int residue=0; // rounding accumulator
+
+ // Allocate storage for the returned decNumber, big enough for the
+ // length specified by the context
+ res=(decNumber *)malloc(sizeof(decNumber)
+ +(D2U(set->digits)-1)*sizeof(Unit));
+ if (res==NULL) {
+ *status|=DEC_Insufficient_storage;
+ return NULL;
+ }
+ decCopyFit(res, dn, set, &residue, &newstatus);
+ decApplyRound(res, set, residue, &newstatus);
+
+ // If that set Inexact then "lost digits" is raised...
+ if (newstatus & DEC_Inexact) newstatus|=DEC_Lost_digits;
+ *status|=newstatus;
+ return res;
+ } // decRoundOperand
+#endif
+
+/* ------------------------------------------------------------------ */
+/* decCopyFit -- copy a number, truncating the coefficient if needed */
+/* */
+/* dest is the target decNumber */
+/* src is the source decNumber */
+/* set is the context [used for length (digits) and rounding mode] */
+/* residue is the residue accumulator */
+/* status contains the current status to be updated */
+/* */
+/* (dest==src is allowed and will be a no-op if fits) */
+/* All fields are updated as required. */
+/* ------------------------------------------------------------------ */
+static void decCopyFit(decNumber *dest, const decNumber *src,
+ decContext *set, Int *residue, uInt *status) {
+ dest->bits=src->bits;
+ dest->exponent=src->exponent;
+ decSetCoeff(dest, set, src->lsu, src->digits, residue, status);
+ } // decCopyFit
+
+/* ------------------------------------------------------------------ */
+/* decSetCoeff -- set the coefficient of a number */
+/* */
+/* dn is the number whose coefficient array is to be set. */
+/* It must have space for set->digits digits */
+/* set is the context [for size] */
+/* lsu -> lsu of the source coefficient [may be dn->lsu] */
+/* len is digits in the source coefficient [may be dn->digits] */
+/* residue is the residue accumulator. This has values as in */
+/* decApplyRound, and will be unchanged unless the */
+/* target size is less than len. In this case, the */
+/* coefficient is truncated and the residue is updated to */
+/* reflect the previous residue and the dropped digits. */
+/* status is the status accumulator, as usual */
+/* */
+/* The coefficient may already be in the number, or it can be an */
+/* external intermediate array. If it is in the number, lsu must == */
+/* dn->lsu and len must == dn->digits. */
+/* */
+/* Note that the coefficient length (len) may be < set->digits, and */
+/* in this case this merely copies the coefficient (or is a no-op */
+/* if dn->lsu==lsu). */
+/* */
+/* Note also that (only internally, from decQuantizeOp and */
+/* decSetSubnormal) the value of set->digits may be less than one, */
+/* indicating a round to left. This routine handles that case */
+/* correctly; caller ensures space. */
+/* */
+/* dn->digits, dn->lsu (and as required), and dn->exponent are */
+/* updated as necessary. dn->bits (sign) is unchanged. */
+/* */
+/* DEC_Rounded status is set if any digits are discarded. */
+/* DEC_Inexact status is set if any non-zero digits are discarded, or */
+/* incoming residue was non-0 (implies rounded) */
+/* ------------------------------------------------------------------ */
+// mapping array: maps 0-9 to canonical residues, so that a residue
+// can be adjusted in the range [-1, +1] and achieve correct rounding
+// 0 1 2 3 4 5 6 7 8 9
+static const uByte resmap[10]={0, 3, 3, 3, 3, 5, 7, 7, 7, 7};
+static void decSetCoeff(decNumber *dn, decContext *set, const Unit *lsu,
+ Int len, Int *residue, uInt *status) {
+ Int discard; // number of digits to discard
+ uInt cut; // cut point in Unit
+ const Unit *up; // work
+ Unit *target; // ..
+ Int count; // ..
+ #if DECDPUN<=4
+ uInt temp; // ..
+ #endif
+
+ discard=len-set->digits; // digits to discard
+ if (discard<=0) { // no digits are being discarded
+ if (dn->lsu!=lsu) { // copy needed
+ // copy the coefficient array to the result number; no shift needed
+ count=len; // avoids D2U
+ up=lsu;
+ for (target=dn->lsu; count>0; target++, up++, count-=DECDPUN)
+ *target=*up;
+ dn->digits=len; // set the new length
+ }
+ // dn->exponent and residue are unchanged, record any inexactitude
+ if (*residue!=0) *status|=(DEC_Inexact | DEC_Rounded);
+ return;
+ }
+
+ // some digits must be discarded ...
+ dn->exponent+=discard; // maintain numerical value
+ *status|=DEC_Rounded; // accumulate Rounded status
+ if (*residue>1) *residue=1; // previous residue now to right, so reduce
+
+ if (discard>len) { // everything, +1, is being discarded
+ // guard digit is 0
+ // residue is all the number [NB could be all 0s]
+ if (*residue<=0) { // not already positive
+ count=len; // avoids D2U
+ for (up=lsu; count>0; up++, count-=DECDPUN) if (*up!=0) { // found non-0
+ *residue=1;
+ break; // no need to check any others
+ }
+ }
+ if (*residue!=0) *status|=DEC_Inexact; // record inexactitude
+ *dn->lsu=0; // coefficient will now be 0
+ dn->digits=1; // ..
+ return;
+ } // total discard
+
+ // partial discard [most common case]
+ // here, at least the first (most significant) discarded digit exists
+
+ // spin up the number, noting residue during the spin, until get to
+ // the Unit with the first discarded digit. When reach it, extract
+ // it and remember its position
+ count=0;
+ for (up=lsu;; up++) {
+ count+=DECDPUN;
+ if (count>=discard) break; // full ones all checked
+ if (*up!=0) *residue=1;
+ } // up
+
+ // here up -> Unit with first discarded digit
+ cut=discard-(count-DECDPUN)-1;
+ if (cut==DECDPUN-1) { // unit-boundary case (fast)
+ Unit half=(Unit)powers[DECDPUN]>>1;
+ // set residue directly
+ if (*up>=half) {
+ if (*up>half) *residue=7;
+ else *residue+=5; // add sticky bit
+ }
+ else { // <half
+ if (*up!=0) *residue=3; // [else is 0, leave as sticky bit]
+ }
+ if (set->digits<=0) { // special for Quantize/Subnormal :-(
+ *dn->lsu=0; // .. result is 0
+ dn->digits=1; // ..
+ }
+ else { // shift to least
+ count=set->digits; // now digits to end up with
+ dn->digits=count; // set the new length
+ up++; // move to next
+ // on unit boundary, so shift-down copy loop is simple
+ for (target=dn->lsu; count>0; target++, up++, count-=DECDPUN)
+ *target=*up;
+ }
+ } // unit-boundary case
+
+ else { // discard digit is in low digit(s), and not top digit
+ uInt discard1; // first discarded digit
+ uInt quot, rem; // for divisions
+ if (cut==0) quot=*up; // is at bottom of unit
+ else /* cut>0 */ { // it's not at bottom of unit
+ #if DECDPUN<=4
+ quot=QUOT10(*up, cut);
+ rem=*up-quot*powers[cut];
+ #else
+ rem=*up%powers[cut];
+ quot=*up/powers[cut];
+ #endif
+ if (rem!=0) *residue=1;
+ }
+ // discard digit is now at bottom of quot
+ #if DECDPUN<=4
+ temp=(quot*6554)>>16; // fast /10
+ // Vowels algorithm here not a win (9 instructions)
+ discard1=quot-X10(temp);
+ quot=temp;
+ #else
+ discard1=quot%10;
+ quot=quot/10;
+ #endif
+ // here, discard1 is the guard digit, and residue is everything
+ // else [use mapping array to accumulate residue safely]
+ *residue+=resmap[discard1];
+ cut++; // update cut
+ // here: up -> Unit of the array with bottom digit
+ // cut is the division point for each Unit
+ // quot holds the uncut high-order digits for the current unit
+ if (set->digits<=0) { // special for Quantize/Subnormal :-(
+ *dn->lsu=0; // .. result is 0
+ dn->digits=1; // ..
+ }
+ else { // shift to least needed
+ count=set->digits; // now digits to end up with
+ dn->digits=count; // set the new length
+ // shift-copy the coefficient array to the result number
+ for (target=dn->lsu; ; target++) {
+ *target=(Unit)quot;
+ count-=(DECDPUN-cut);
+ if (count<=0) break;
+ up++;
+ quot=*up;
+ #if DECDPUN<=4
+ quot=QUOT10(quot, cut);
+ rem=*up-quot*powers[cut];
+ #else
+ rem=quot%powers[cut];
+ quot=quot/powers[cut];
+ #endif
+ *target=(Unit)(*target+rem*powers[DECDPUN-cut]);
+ count-=cut;
+ if (count<=0) break;
+ } // shift-copy loop
+ } // shift to least
+ } // not unit boundary
+
+ if (*residue!=0) *status|=DEC_Inexact; // record inexactitude
+ return;
+ } // decSetCoeff
+
+/* ------------------------------------------------------------------ */
+/* decApplyRound -- apply pending rounding to a number */
+/* */
+/* dn is the number, with space for set->digits digits */
+/* set is the context [for size and rounding mode] */
+/* residue indicates pending rounding, being any accumulated */
+/* guard and sticky information. It may be: */
+/* 6-9: rounding digit is >5 */
+/* 5: rounding digit is exactly half-way */
+/* 1-4: rounding digit is <5 and >0 */
+/* 0: the coefficient is exact */
+/* -1: as 1, but the hidden digits are subtractive, that */
+/* is, of the opposite sign to dn. In this case the */
+/* coefficient must be non-0. This case occurs when */
+/* subtracting a small number (which can be reduced to */
+/* a sticky bit); see decAddOp. */
+/* status is the status accumulator, as usual */
+/* */
+/* This routine applies rounding while keeping the length of the */
+/* coefficient constant. The exponent and status are unchanged */
+/* except if: */
+/* */
+/* -- the coefficient was increased and is all nines (in which */
+/* case Overflow could occur, and is handled directly here so */
+/* the caller does not need to re-test for overflow) */
+/* */
+/* -- the coefficient was decreased and becomes all nines (in which */
+/* case Underflow could occur, and is also handled directly). */
+/* */
+/* All fields in dn are updated as required. */
+/* */
+/* ------------------------------------------------------------------ */
+static void decApplyRound(decNumber *dn, decContext *set, Int residue,
+ uInt *status) {
+ Int bump; // 1 if coefficient needs to be incremented
+ // -1 if coefficient needs to be decremented
+
+ if (residue==0) return; // nothing to apply
+
+ bump=0; // assume a smooth ride
+
+ // now decide whether, and how, to round, depending on mode
+ switch (set->round) {
+ case DEC_ROUND_05UP: { // round zero or five up (for reround)
+ // This is the same as DEC_ROUND_DOWN unless there is a
+ // positive residue and the lsd of dn is 0 or 5, in which case
+ // it is bumped; when residue is <0, the number is therefore
+ // bumped down unless the final digit was 1 or 6 (in which
+ // case it is bumped down and then up -- a no-op)
+ Int lsd5=*dn->lsu%5; // get lsd and quintate
+ if (residue<0 && lsd5!=1) bump=-1;
+ else if (residue>0 && lsd5==0) bump=1;
+ // [bump==1 could be applied directly; use common path for clarity]
+ break;} // r-05
+
+ case DEC_ROUND_DOWN: {
+ // no change, except if negative residue
+ if (residue<0) bump=-1;
+ break;} // r-d
+
+ case DEC_ROUND_HALF_DOWN: {
+ if (residue>5) bump=1;
+ break;} // r-h-d
+
+ case DEC_ROUND_HALF_EVEN: {
+ if (residue>5) bump=1; // >0.5 goes up
+ else if (residue==5) { // exactly 0.5000...
+ // 0.5 goes up iff [new] lsd is odd
+ if (*dn->lsu & 0x01) bump=1;
+ }
+ break;} // r-h-e
+
+ case DEC_ROUND_HALF_UP: {
+ if (residue>=5) bump=1;
+ break;} // r-h-u
+
+ case DEC_ROUND_UP: {
+ if (residue>0) bump=1;
+ break;} // r-u
+
+ case DEC_ROUND_CEILING: {
+ // same as _UP for positive numbers, and as _DOWN for negatives
+ // [negative residue cannot occur on 0]
+ if (decNumberIsNegative(dn)) {
+ if (residue<0) bump=-1;
+ }
+ else {
+ if (residue>0) bump=1;
+ }
+ break;} // r-c
+
+ case DEC_ROUND_FLOOR: {
+ // same as _UP for negative numbers, and as _DOWN for positive
+ // [negative residue cannot occur on 0]
+ if (!decNumberIsNegative(dn)) {
+ if (residue<0) bump=-1;
+ }
+ else {
+ if (residue>0) bump=1;
+ }
+ break;} // r-f
+
+ default: { // e.g., DEC_ROUND_MAX
+ *status|=DEC_Invalid_context;
+ #if DECTRACE || (DECCHECK && DECVERB)
+ printf("Unknown rounding mode: %d\n", set->round);
+ #endif
+ break;}
+ } // switch
+
+ // now bump the number, up or down, if need be
+ if (bump==0) return; // no action required
+
+ // Simply use decUnitAddSub unless bumping up and the number is
+ // all nines. In this special case set to 100... explicitly
+ // and adjust the exponent by one (as otherwise could overflow
+ // the array)
+ // Similarly handle all-nines result if bumping down.
+ if (bump>0) {
+ Unit *up; // work
+ uInt count=dn->digits; // digits to be checked
+ for (up=dn->lsu; ; up++) {
+ if (count<=DECDPUN) {
+ // this is the last Unit (the msu)
+ if (*up!=powers[count]-1) break; // not still 9s
+ // here if it, too, is all nines
+ *up=(Unit)powers[count-1]; // here 999 -> 100 etc.
+ for (up=up-1; up>=dn->lsu; up--) *up=0; // others all to 0
+ dn->exponent++; // and bump exponent
+ // [which, very rarely, could cause Overflow...]
+ if ((dn->exponent+dn->digits)>set->emax+1) {
+ decSetOverflow(dn, set, status);
+ }
+ return; // done
+ }
+ // a full unit to check, with more to come
+ if (*up!=DECDPUNMAX) break; // not still 9s
+ count-=DECDPUN;
+ } // up
+ } // bump>0
+ else { // -1
+ // here checking for a pre-bump of 1000... (leading 1, all
+ // other digits zero)
+ Unit *up, *sup; // work
+ uInt count=dn->digits; // digits to be checked
+ for (up=dn->lsu; ; up++) {
+ if (count<=DECDPUN) {
+ // this is the last Unit (the msu)
+ if (*up!=powers[count-1]) break; // not 100..
+ // here if have the 1000... case
+ sup=up; // save msu pointer
+ *up=(Unit)powers[count]-1; // here 100 in msu -> 999
+ // others all to all-nines, too
+ for (up=up-1; up>=dn->lsu; up--) *up=(Unit)powers[DECDPUN]-1;
+ dn->exponent--; // and bump exponent
+
+ // iff the number was at the subnormal boundary (exponent=etiny)
+ // then the exponent is now out of range, so it will in fact get
+ // clamped to etiny and the final 9 dropped.
+ // printf(">> emin=%d exp=%d sdig=%d\n", set->emin,
+ // dn->exponent, set->digits);
+ if (dn->exponent+1==set->emin-set->digits+1) {
+ if (count==1 && dn->digits==1) *sup=0; // here 9 -> 0[.9]
+ else {
+ *sup=(Unit)powers[count-1]-1; // here 999.. in msu -> 99..
+ dn->digits--;
+ }
+ dn->exponent++;
+ *status|=DEC_Underflow | DEC_Subnormal | DEC_Inexact | DEC_Rounded;
+ }
+ return; // done
+ }
+
+ // a full unit to check, with more to come
+ if (*up!=0) break; // not still 0s
+ count-=DECDPUN;
+ } // up
+
+ } // bump<0
+
+ // Actual bump needed. Do it.
+ decUnitAddSub(dn->lsu, D2U(dn->digits), uarrone, 1, 0, dn->lsu, bump);
+ } // decApplyRound
+
+#if DECSUBSET
+/* ------------------------------------------------------------------ */
+/* decFinish -- finish processing a number */
+/* */
+/* dn is the number */
+/* set is the context */
+/* residue is the rounding accumulator (as in decApplyRound) */
+/* status is the accumulator */
+/* */
+/* This finishes off the current number by: */
+/* 1. If not extended: */
+/* a. Converting a zero result to clean '0' */
+/* b. Reducing positive exponents to 0, if would fit in digits */
+/* 2. Checking for overflow and subnormals (always) */
+/* Note this is just Finalize when no subset arithmetic. */
+/* All fields are updated as required. */
+/* ------------------------------------------------------------------ */
+static void decFinish(decNumber *dn, decContext *set, Int *residue,
+ uInt *status) {
+ if (!set->extended) {
+ if ISZERO(dn) { // value is zero
+ dn->exponent=0; // clean exponent ..
+ dn->bits=0; // .. and sign
+ return; // no error possible
+ }
+ if (dn->exponent>=0) { // non-negative exponent
+ // >0; reduce to integer if possible
+ if (set->digits >= (dn->exponent+dn->digits)) {
+ dn->digits=decShiftToMost(dn->lsu, dn->digits, dn->exponent);
+ dn->exponent=0;
+ }
+ }
+ } // !extended
+
+ decFinalize(dn, set, residue, status);
+ } // decFinish
+#endif
+
+/* ------------------------------------------------------------------ */
+/* decFinalize -- final check, clamp, and round of a number */
+/* */
+/* dn is the number */
+/* set is the context */
+/* residue is the rounding accumulator (as in decApplyRound) */
+/* status is the status accumulator */
+/* */
+/* This finishes off the current number by checking for subnormal */
+/* results, applying any pending rounding, checking for overflow, */
+/* and applying any clamping. */
+/* Underflow and overflow conditions are raised as appropriate. */
+/* All fields are updated as required. */
+/* ------------------------------------------------------------------ */
+static void decFinalize(decNumber *dn, decContext *set, Int *residue,
+ uInt *status) {
+ Int shift; // shift needed if clamping
+ Int tinyexp=set->emin-dn->digits+1; // precalculate subnormal boundary
+
+ // Must be careful, here, when checking the exponent as the
+ // adjusted exponent could overflow 31 bits [because it may already
+ // be up to twice the expected].
+
+ // First test for subnormal. This must be done before any final
+ // round as the result could be rounded to Nmin or 0.
+ if (dn->exponent<=tinyexp) { // prefilter
+ Int comp;
+ decNumber nmin;
+ // A very nasty case here is dn == Nmin and residue<0
+ if (dn->exponent<tinyexp) {
+ // Go handle subnormals; this will apply round if needed.
+ decSetSubnormal(dn, set, residue, status);
+ return;
+ }
+ // Equals case: only subnormal if dn=Nmin and negative residue
+ decNumberZero(&nmin);
+ nmin.lsu[0]=1;
+ nmin.exponent=set->emin;
+ comp=decCompare(dn, &nmin, 1); // (signless compare)
+ if (comp==BADINT) { // oops
+ *status|=DEC_Insufficient_storage; // abandon...
+ return;
+ }
+ if (*residue<0 && comp==0) { // neg residue and dn==Nmin
+ decApplyRound(dn, set, *residue, status); // might force down
+ decSetSubnormal(dn, set, residue, status);
+ return;
+ }
+ }
+
+ // now apply any pending round (this could raise overflow).
+ if (*residue!=0) decApplyRound(dn, set, *residue, status);
+
+ // Check for overflow [redundant in the 'rare' case] or clamp
+ if (dn->exponent<=set->emax-set->digits+1) return; // neither needed
+
+
+ // here when might have an overflow or clamp to do
+ if (dn->exponent>set->emax-dn->digits+1) { // too big
+ decSetOverflow(dn, set, status);
+ return;
+ }
+ // here when the result is normal but in clamp range
+ if (!set->clamp) return;
+
+ // here when need to apply the IEEE exponent clamp (fold-down)
+ shift=dn->exponent-(set->emax-set->digits+1);
+
+ // shift coefficient (if non-zero)
+ if (!ISZERO(dn)) {
+ dn->digits=decShiftToMost(dn->lsu, dn->digits, shift);
+ }
+ dn->exponent-=shift; // adjust the exponent to match
+ *status|=DEC_Clamped; // and record the dirty deed
+ return;
+ } // decFinalize
+
+/* ------------------------------------------------------------------ */
+/* decSetOverflow -- set number to proper overflow value */
+/* */
+/* dn is the number (used for sign [only] and result) */
+/* set is the context [used for the rounding mode, etc.] */
+/* status contains the current status to be updated */
+/* */
+/* This sets the sign of a number and sets its value to either */
+/* Infinity or the maximum finite value, depending on the sign of */
+/* dn and the rounding mode, following IEEE 754 rules. */
+/* ------------------------------------------------------------------ */
+static void decSetOverflow(decNumber *dn, decContext *set, uInt *status) {
+ Flag needmax=0; // result is maximum finite value
+ uByte sign=dn->bits&DECNEG; // clean and save sign bit
+
+ if (ISZERO(dn)) { // zero does not overflow magnitude
+ Int emax=set->emax; // limit value
+ if (set->clamp) emax-=set->digits-1; // lower if clamping
+ if (dn->exponent>emax) { // clamp required
+ dn->exponent=emax;
+ *status|=DEC_Clamped;
+ }
+ return;
+ }
+
+ decNumberZero(dn);
+ switch (set->round) {
+ case DEC_ROUND_DOWN: {
+ needmax=1; // never Infinity
+ break;} // r-d
+ case DEC_ROUND_05UP: {
+ needmax=1; // never Infinity
+ break;} // r-05
+ case DEC_ROUND_CEILING: {
+ if (sign) needmax=1; // Infinity if non-negative
+ break;} // r-c
+ case DEC_ROUND_FLOOR: {
+ if (!sign) needmax=1; // Infinity if negative
+ break;} // r-f
+ default: break; // Infinity in all other cases
+ }
+ if (needmax) {
+ decSetMaxValue(dn, set);
+ dn->bits=sign; // set sign
+ }
+ else dn->bits=sign|DECINF; // Value is +/-Infinity
+ *status|=DEC_Overflow | DEC_Inexact | DEC_Rounded;
+ } // decSetOverflow
+
+/* ------------------------------------------------------------------ */
+/* decSetMaxValue -- set number to +Nmax (maximum normal value) */
+/* */
+/* dn is the number to set */
+/* set is the context [used for digits and emax] */
+/* */
+/* This sets the number to the maximum positive value. */
+/* ------------------------------------------------------------------ */
+static void decSetMaxValue(decNumber *dn, decContext *set) {
+ Unit *up; // work
+ Int count=set->digits; // nines to add
+ dn->digits=count;
+ // fill in all nines to set maximum value
+ for (up=dn->lsu; ; up++) {
+ if (count>DECDPUN) *up=DECDPUNMAX; // unit full o'nines
+ else { // this is the msu
+ *up=(Unit)(powers[count]-1);
+ break;
+ }
+ count-=DECDPUN; // filled those digits
+ } // up
+ dn->bits=0; // + sign
+ dn->exponent=set->emax-set->digits+1;
+ } // decSetMaxValue
+
+/* ------------------------------------------------------------------ */
+/* decSetSubnormal -- process value whose exponent is <Emin */
+/* */
+/* dn is the number (used as input as well as output; it may have */
+/* an allowed subnormal value, which may need to be rounded) */
+/* set is the context [used for the rounding mode] */
+/* residue is any pending residue */
+/* status contains the current status to be updated */
+/* */
+/* If subset mode, set result to zero and set Underflow flags. */
+/* */
+/* Value may be zero with a low exponent; this does not set Subnormal */
+/* but the exponent will be clamped to Etiny. */
+/* */
+/* Otherwise ensure exponent is not out of range, and round as */
+/* necessary. Underflow is set if the result is Inexact. */
+/* ------------------------------------------------------------------ */
+static void decSetSubnormal(decNumber *dn, decContext *set, Int *residue,
+ uInt *status) {
+ decContext workset; // work
+ Int etiny, adjust; // ..
+
+ #if DECSUBSET
+ // simple set to zero and 'hard underflow' for subset
+ if (!set->extended) {
+ decNumberZero(dn);
+ // always full overflow
+ *status|=DEC_Underflow | DEC_Subnormal | DEC_Inexact | DEC_Rounded;
+ return;
+ }
+ #endif
+
+ // Full arithmetic -- allow subnormals, rounded to minimum exponent
+ // (Etiny) if needed
+ etiny=set->emin-(set->digits-1); // smallest allowed exponent
+
+ if ISZERO(dn) { // value is zero
+ // residue can never be non-zero here
+ #if DECCHECK
+ if (*residue!=0) {
+ printf("++ Subnormal 0 residue %ld\n", (LI)*residue);
+ *status|=DEC_Invalid_operation;
+ }
+ #endif
+ if (dn->exponent<etiny) { // clamp required
+ dn->exponent=etiny;
+ *status|=DEC_Clamped;
+ }
+ return;
+ }
+
+ *status|=DEC_Subnormal; // have a non-zero subnormal
+ adjust=etiny-dn->exponent; // calculate digits to remove
+ if (adjust<=0) { // not out of range; unrounded
+ // residue can never be non-zero here, except in the Nmin-residue
+ // case (which is a subnormal result), so can take fast-path here
+ // it may already be inexact (from setting the coefficient)
+ if (*status&DEC_Inexact) *status|=DEC_Underflow;
+ return;
+ }
+
+ // adjust>0, so need to rescale the result so exponent becomes Etiny
+ // [this code is similar to that in rescale]
+ workset=*set; // clone rounding, etc.
+ workset.digits=dn->digits-adjust; // set requested length
+ workset.emin-=adjust; // and adjust emin to match
+ // [note that the latter can be <1, here, similar to Rescale case]
+ decSetCoeff(dn, &workset, dn->lsu, dn->digits, residue, status);
+ decApplyRound(dn, &workset, *residue, status);
+
+ // Use 754 default rule: Underflow is set iff Inexact
+ // [independent of whether trapped]
+ if (*status&DEC_Inexact) *status|=DEC_Underflow;
+
+ // if rounded up a 999s case, exponent will be off by one; adjust
+ // back if so [it will fit, because it was shortened earlier]
+ if (dn->exponent>etiny) {
+ dn->digits=decShiftToMost(dn->lsu, dn->digits, 1);
+ dn->exponent--; // (re)adjust the exponent.
+ }
+
+ // if rounded to zero, it is by definition clamped...
+ if (ISZERO(dn)) *status|=DEC_Clamped;
+ } // decSetSubnormal
+
+/* ------------------------------------------------------------------ */
+/* decCheckMath - check entry conditions for a math function */
+/* */
+/* This checks the context and the operand */
+/* */
+/* rhs is the operand to check */
+/* set is the context to check */
+/* status is unchanged if both are good */
+/* */
+/* returns non-zero if status is changed, 0 otherwise */
+/* */
+/* Restrictions enforced: */
+/* */
+/* digits, emax, and -emin in the context must be less than */
+/* DEC_MAX_MATH (999999), and A must be within these bounds if */
+/* non-zero. Invalid_operation is set in the status if a */
+/* restriction is violated. */
+/* ------------------------------------------------------------------ */
+static uInt decCheckMath(const decNumber *rhs, decContext *set,
+ uInt *status) {
+ uInt save=*status; // record
+ if (set->digits>DEC_MAX_MATH
+ || set->emax>DEC_MAX_MATH
+ || -set->emin>DEC_MAX_MATH) *status|=DEC_Invalid_context;
+ else if ((rhs->digits>DEC_MAX_MATH
+ || rhs->exponent+rhs->digits>DEC_MAX_MATH+1
+ || rhs->exponent+rhs->digits<2*(1-DEC_MAX_MATH))
+ && !ISZERO(rhs)) *status|=DEC_Invalid_operation;
+ return (*status!=save);
+ } // decCheckMath
+
+/* ------------------------------------------------------------------ */
+/* decGetInt -- get integer from a number */
+/* */
+/* dn is the number [which will not be altered] */
+/* */
+/* returns one of: */
+/* BADINT if there is a non-zero fraction */
+/* the converted integer */
+/* BIGEVEN if the integer is even and magnitude > 2*10**9 */
+/* BIGODD if the integer is odd and magnitude > 2*10**9 */
+/* */
+/* This checks and gets a whole number from the input decNumber. */
+/* The sign can be determined from dn by the caller when BIGEVEN or */
+/* BIGODD is returned. */
+/* ------------------------------------------------------------------ */
+static Int decGetInt(const decNumber *dn) {
+ Int theInt; // result accumulator
+ const Unit *up; // work
+ Int got; // digits (real or not) processed
+ Int ilength=dn->digits+dn->exponent; // integral length
+ Flag neg=decNumberIsNegative(dn); // 1 if -ve
+
+ // The number must be an integer that fits in 10 digits
+ // Assert, here, that 10 is enough for any rescale Etiny
+ #if DEC_MAX_EMAX > 999999999
+ #error GetInt may need updating [for Emax]
+ #endif
+ #if DEC_MIN_EMIN < -999999999
+ #error GetInt may need updating [for Emin]
+ #endif
+ if (ISZERO(dn)) return 0; // zeros are OK, with any exponent
+
+ up=dn->lsu; // ready for lsu
+ theInt=0; // ready to accumulate
+ if (dn->exponent>=0) { // relatively easy
+ // no fractional part [usual]; allow for positive exponent
+ got=dn->exponent;
+ }
+ else { // -ve exponent; some fractional part to check and discard
+ Int count=-dn->exponent; // digits to discard
+ // spin up whole units until reach the Unit with the unit digit
+ for (; count>=DECDPUN; up++) {
+ if (*up!=0) return BADINT; // non-zero Unit to discard
+ count-=DECDPUN;
+ }
+ if (count==0) got=0; // [a multiple of DECDPUN]
+ else { // [not multiple of DECDPUN]
+ Int rem; // work
+ // slice off fraction digits and check for non-zero
+ #if DECDPUN<=4
+ theInt=QUOT10(*up, count);
+ rem=*up-theInt*powers[count];
+ #else
+ rem=*up%powers[count]; // slice off discards
+ theInt=*up/powers[count];
+ #endif
+ if (rem!=0) return BADINT; // non-zero fraction
+ // it looks good
+ got=DECDPUN-count; // number of digits so far
+ up++; // ready for next
+ }
+ }
+ // now it's known there's no fractional part
+
+ // tricky code now, to accumulate up to 9.3 digits
+ if (got==0) {theInt=*up; got+=DECDPUN; up++;} // ensure lsu is there
+
+ if (ilength<11) {
+ Int save=theInt;
+ // collect any remaining unit(s)
+ for (; got<ilength; up++) {
+ theInt+=*up*powers[got];
+ got+=DECDPUN;
+ }
+ if (ilength==10) { // need to check for wrap
+ if (theInt/(Int)powers[got-DECDPUN]!=(Int)*(up-1)) ilength=11;
+ // [that test also disallows the BADINT result case]
+ else if (neg && theInt>1999999997) ilength=11;
+ else if (!neg && theInt>999999999) ilength=11;
+ if (ilength==11) theInt=save; // restore correct low bit
+ }
+ }
+
+ if (ilength>10) { // too big
+ if (theInt&1) return BIGODD; // bottom bit 1
+ return BIGEVEN; // bottom bit 0
+ }
+
+ if (neg) theInt=-theInt; // apply sign
+ return theInt;
+ } // decGetInt
+
+/* ------------------------------------------------------------------ */
+/* decDecap -- decapitate the coefficient of a number */
+/* */
+/* dn is the number to be decapitated */
+/* drop is the number of digits to be removed from the left of dn; */
+/* this must be <= dn->digits (if equal, the coefficient is */
+/* set to 0) */
+/* */
+/* Returns dn; dn->digits will be <= the initial digits less drop */
+/* (after removing drop digits there may be leading zero digits */
+/* which will also be removed). Only dn->lsu and dn->digits change. */
+/* ------------------------------------------------------------------ */
+static decNumber *decDecap(decNumber *dn, Int drop) {
+ Unit *msu; // -> target cut point
+ Int cut; // work
+ if (drop>=dn->digits) { // losing the whole thing
+ #if DECCHECK
+ if (drop>dn->digits)
+ printf("decDecap called with drop>digits [%ld>%ld]\n",
+ (LI)drop, (LI)dn->digits);
+ #endif
+ dn->lsu[0]=0;
+ dn->digits=1;
+ return dn;
+ }
+ msu=dn->lsu+D2U(dn->digits-drop)-1; // -> likely msu
+ cut=MSUDIGITS(dn->digits-drop); // digits to be in use in msu
+ if (cut!=DECDPUN) *msu%=powers[cut]; // clear left digits
+ // that may have left leading zero digits, so do a proper count...
+ dn->digits=decGetDigits(dn->lsu, msu-dn->lsu+1);
+ return dn;
+ } // decDecap
+
+/* ------------------------------------------------------------------ */
+/* decBiStr -- compare string with pairwise options */
+/* */
+/* targ is the string to compare */
+/* str1 is one of the strings to compare against (length may be 0) */
+/* str2 is the other; it must be the same length as str1 */
+/* */
+/* returns 1 if strings compare equal, (that is, it is the same */
+/* length as str1 and str2, and each character of targ is in either */
+/* str1 or str2 in the corresponding position), or 0 otherwise */
+/* */
+/* This is used for generic caseless compare, including the awkward */
+/* case of the Turkish dotted and dotless Is. Use as (for example): */
+/* if (decBiStr(test, "mike", "MIKE")) ... */
+/* ------------------------------------------------------------------ */
+static Flag decBiStr(const char *targ, const char *str1, const char *str2) {
+ for (;;targ++, str1++, str2++) {
+ if (*targ!=*str1 && *targ!=*str2) return 0;
+ // *targ has a match in one (or both, if terminator)
+ if (*targ=='\0') break;
+ } // forever
+ return 1;
+ } // decBiStr
+
+/* ------------------------------------------------------------------ */
+/* decNaNs -- handle NaN operand or operands */
+/* */
+/* res is the result number */
+/* lhs is the first operand */
+/* rhs is the second operand, or NULL if none */
+/* context is used to limit payload length */
+/* status contains the current status */
+/* returns res in case convenient */
+/* */
+/* Called when one or both operands is a NaN, and propagates the */
+/* appropriate result to res. When an sNaN is found, it is changed */
+/* to a qNaN and Invalid operation is set. */
+/* ------------------------------------------------------------------ */
+static decNumber * decNaNs(decNumber *res, const decNumber *lhs,
+ const decNumber *rhs, decContext *set,
+ uInt *status) {
+ // This decision tree ends up with LHS being the source pointer,
+ // and status updated if need be
+ if (lhs->bits & DECSNAN)
+ *status|=DEC_Invalid_operation | DEC_sNaN;
+ else if (rhs==NULL);
+ else if (rhs->bits & DECSNAN) {
+ lhs=rhs;
+ *status|=DEC_Invalid_operation | DEC_sNaN;
+ }
+ else if (lhs->bits & DECNAN);
+ else lhs=rhs;
+
+ // propagate the payload
+ if (lhs->digits<=set->digits) decNumberCopy(res, lhs); // easy
+ else { // too long
+ const Unit *ul;
+ Unit *ur, *uresp1;
+ // copy safe number of units, then decapitate
+ res->bits=lhs->bits; // need sign etc.
+ uresp1=res->lsu+D2U(set->digits);
+ for (ur=res->lsu, ul=lhs->lsu; ur<uresp1; ur++, ul++) *ur=*ul;
+ res->digits=D2U(set->digits)*DECDPUN;
+ // maybe still too long
+ if (res->digits>set->digits) decDecap(res, res->digits-set->digits);
+ }
+
+ res->bits&=~DECSNAN; // convert any sNaN to NaN, while
+ res->bits|=DECNAN; // .. preserving sign
+ res->exponent=0; // clean exponent
+ // [coefficient was copied/decapitated]
+ return res;
+ } // decNaNs
+
+/* ------------------------------------------------------------------ */
+/* decStatus -- apply non-zero status */
+/* */
+/* dn is the number to set if error */
+/* status contains the current status (not yet in context) */
+/* set is the context */
+/* */
+/* If the status is an error status, the number is set to a NaN, */
+/* unless the error was an overflow, divide-by-zero, or underflow, */
+/* in which case the number will have already been set. */
+/* */
+/* The context status is then updated with the new status. Note that */
+/* this may raise a signal, so control may never return from this */
+/* routine (hence resources must be recovered before it is called). */
+/* ------------------------------------------------------------------ */
+static void decStatus(decNumber *dn, uInt status, decContext *set) {
+ if (status & DEC_NaNs) { // error status -> NaN
+ // if cause was an sNaN, clear and propagate [NaN is already set up]
+ if (status & DEC_sNaN) status&=~DEC_sNaN;
+ else {
+ decNumberZero(dn); // other error: clean throughout
+ dn->bits=DECNAN; // and make a quiet NaN
+ }
+ }
+ decContextSetStatus(set, status); // [may not return]
+ return;
+ } // decStatus
+
+/* ------------------------------------------------------------------ */
+/* decGetDigits -- count digits in a Units array */
+/* */
+/* uar is the Unit array holding the number (this is often an */
+/* accumulator of some sort) */
+/* len is the length of the array in units [>=1] */
+/* */
+/* returns the number of (significant) digits in the array */
+/* */
+/* All leading zeros are excluded, except the last if the array has */
+/* only zero Units. */
+/* ------------------------------------------------------------------ */
+// This may be called twice during some operations.
+static Int decGetDigits(Unit *uar, Int len) {
+ Unit *up=uar+(len-1); // -> msu
+ Int digits=(len-1)*DECDPUN+1; // possible digits excluding msu
+ #if DECDPUN>4
+ uInt const *pow; // work
+ #endif
+ // (at least 1 in final msu)
+ #if DECCHECK
+ if (len<1) printf("decGetDigits called with len<1 [%ld]\n", (LI)len);
+ #endif
+
+ for (; up>=uar; up--) {
+ if (*up==0) { // unit is all 0s
+ if (digits==1) break; // a zero has one digit
+ digits-=DECDPUN; // adjust for 0 unit
+ continue;}
+ // found the first (most significant) non-zero Unit
+ #if DECDPUN>1 // not done yet
+ if (*up<10) break; // is 1-9
+ digits++;
+ #if DECDPUN>2 // not done yet
+ if (*up<100) break; // is 10-99
+ digits++;
+ #if DECDPUN>3 // not done yet
+ if (*up<1000) break; // is 100-999
+ digits++;
+ #if DECDPUN>4 // count the rest ...
+ for (pow=&powers[4]; *up>=*pow; pow++) digits++;
+ #endif
+ #endif
+ #endif
+ #endif
+ break;
+ } // up
+ return digits;
+ } // decGetDigits
+
+#if DECTRACE | DECCHECK
+/* ------------------------------------------------------------------ */
+/* decNumberShow -- display a number [debug aid] */
+/* dn is the number to show */
+/* */
+/* Shows: sign, exponent, coefficient (msu first), digits */
+/* or: sign, special-value */
+/* ------------------------------------------------------------------ */
+// this is public so other modules can use it
+void decNumberShow(const decNumber *dn) {
+ const Unit *up; // work
+ uInt u, d; // ..
+ Int cut; // ..
+ char isign='+'; // main sign
+ if (dn==NULL) {
+ printf("NULL\n");
+ return;}
+ if (decNumberIsNegative(dn)) isign='-';
+ printf(" >> %c ", isign);
+ if (dn->bits&DECSPECIAL) { // Is a special value
+ if (decNumberIsInfinite(dn)) printf("Infinity");
+ else { // a NaN
+ if (dn->bits&DECSNAN) printf("sNaN"); // signalling NaN
+ else printf("NaN");
+ }
+ // if coefficient and exponent are 0, no more to do
+ if (dn->exponent==0 && dn->digits==1 && *dn->lsu==0) {
+ printf("\n");
+ return;}
+ // drop through to report other information
+ printf(" ");
+ }
+
+ // now carefully display the coefficient
+ up=dn->lsu+D2U(dn->digits)-1; // msu
+ printf("%ld", (LI)*up);
+ for (up=up-1; up>=dn->lsu; up--) {
+ u=*up;
+ printf(":");
+ for (cut=DECDPUN-1; cut>=0; cut--) {
+ d=u/powers[cut];
+ u-=d*powers[cut];
+ printf("%ld", (LI)d);
+ } // cut
+ } // up
+ if (dn->exponent!=0) {
+ char esign='+';
+ if (dn->exponent<0) esign='-';
+ printf(" E%c%ld", esign, (LI)abs(dn->exponent));
+ }
+ printf(" [%ld]\n", (LI)dn->digits);
+ } // decNumberShow
+#endif
+
+#if DECTRACE || DECCHECK
+/* ------------------------------------------------------------------ */
+/* decDumpAr -- display a unit array [debug/check aid] */
+/* name is a single-character tag name */
+/* ar is the array to display */
+/* len is the length of the array in Units */
+/* ------------------------------------------------------------------ */
+static void decDumpAr(char name, const Unit *ar, Int len) {
+ Int i;
+ const char *spec;
+ #if DECDPUN==9
+ spec="%09d ";
+ #elif DECDPUN==8
+ spec="%08d ";
+ #elif DECDPUN==7
+ spec="%07d ";
+ #elif DECDPUN==6
+ spec="%06d ";
+ #elif DECDPUN==5
+ spec="%05d ";
+ #elif DECDPUN==4
+ spec="%04d ";
+ #elif DECDPUN==3
+ spec="%03d ";
+ #elif DECDPUN==2
+ spec="%02d ";
+ #else
+ spec="%d ";
+ #endif
+ printf(" :%c: ", name);
+ for (i=len-1; i>=0; i--) {
+ if (i==len-1) printf("%ld ", (LI)ar[i]);
+ else printf(spec, ar[i]);
+ }
+ printf("\n");
+ return;}
+#endif
+
+#if DECCHECK
+/* ------------------------------------------------------------------ */
+/* decCheckOperands -- check operand(s) to a routine */
+/* res is the result structure (not checked; it will be set to */
+/* quiet NaN if error found (and it is not NULL)) */
+/* lhs is the first operand (may be DECUNRESU) */
+/* rhs is the second (may be DECUNUSED) */
+/* set is the context (may be DECUNCONT) */
+/* returns 0 if both operands, and the context are clean, or 1 */
+/* otherwise (in which case the context will show an error, */
+/* unless NULL). Note that res is not cleaned; caller should */
+/* handle this so res=NULL case is safe. */
+/* The caller is expected to abandon immediately if 1 is returned. */
+/* ------------------------------------------------------------------ */
+static Flag decCheckOperands(decNumber *res, const decNumber *lhs,
+ const decNumber *rhs, decContext *set) {
+ Flag bad=0;
+ if (set==NULL) { // oops; hopeless
+ #if DECTRACE || DECVERB
+ printf("Reference to context is NULL.\n");
+ #endif
+ bad=1;
+ return 1;}
+ else if (set!=DECUNCONT
+ && (set->digits<1 || set->round>=DEC_ROUND_MAX)) {
+ bad=1;
+ #if DECTRACE || DECVERB
+ printf("Bad context [digits=%ld round=%ld].\n",
+ (LI)set->digits, (LI)set->round);
+ #endif
+ }
+ else {
+ if (res==NULL) {
+ bad=1;
+ #if DECTRACE
+ // this one not DECVERB as standard tests include NULL
+ printf("Reference to result is NULL.\n");
+ #endif
+ }
+ if (!bad && lhs!=DECUNUSED) bad=(decCheckNumber(lhs));
+ if (!bad && rhs!=DECUNUSED) bad=(decCheckNumber(rhs));
+ }
+ if (bad) {
+ if (set!=DECUNCONT) decContextSetStatus(set, DEC_Invalid_operation);
+ if (res!=DECUNRESU && res!=NULL) {
+ decNumberZero(res);
+ res->bits=DECNAN; // qNaN
+ }
+ }
+ return bad;
+ } // decCheckOperands
+
+/* ------------------------------------------------------------------ */
+/* decCheckNumber -- check a number */
+/* dn is the number to check */
+/* returns 0 if the number is clean, or 1 otherwise */
+/* */
+/* The number is considered valid if it could be a result from some */
+/* operation in some valid context. */
+/* ------------------------------------------------------------------ */
+static Flag decCheckNumber(const decNumber *dn) {
+ const Unit *up; // work
+ uInt maxuint; // ..
+ Int ae, d, digits; // ..
+ Int emin, emax; // ..
+
+ if (dn==NULL) { // hopeless
+ #if DECTRACE
+ // this one not DECVERB as standard tests include NULL
+ printf("Reference to decNumber is NULL.\n");
+ #endif
+ return 1;}
+
+ // check special values
+ if (dn->bits & DECSPECIAL) {
+ if (dn->exponent!=0) {
+ #if DECTRACE || DECVERB
+ printf("Exponent %ld (not 0) for a special value [%02x].\n",
+ (LI)dn->exponent, dn->bits);
+ #endif
+ return 1;}
+
+ // 2003.09.08: NaNs may now have coefficients, so next tests Inf only
+ if (decNumberIsInfinite(dn)) {
+ if (dn->digits!=1) {
+ #if DECTRACE || DECVERB
+ printf("Digits %ld (not 1) for an infinity.\n", (LI)dn->digits);
+ #endif
+ return 1;}
+ if (*dn->lsu!=0) {
+ #if DECTRACE || DECVERB
+ printf("LSU %ld (not 0) for an infinity.\n", (LI)*dn->lsu);
+ #endif
+ decDumpAr('I', dn->lsu, D2U(dn->digits));
+ return 1;}
+ } // Inf
+ // 2002.12.26: negative NaNs can now appear through proposed IEEE
+ // concrete formats (decimal64, etc.).
+ return 0;
+ }
+
+ // check the coefficient
+ if (dn->digits<1 || dn->digits>DECNUMMAXP) {
+ #if DECTRACE || DECVERB
+ printf("Digits %ld in number.\n", (LI)dn->digits);
+ #endif
+ return 1;}
+
+ d=dn->digits;
+
+ for (up=dn->lsu; d>0; up++) {
+ if (d>DECDPUN) maxuint=DECDPUNMAX;
+ else { // reached the msu
+ maxuint=powers[d]-1;
+ if (dn->digits>1 && *up<powers[d-1]) {
+ #if DECTRACE || DECVERB
+ printf("Leading 0 in number.\n");
+ decNumberShow(dn);
+ #endif
+ return 1;}
+ }
+ if (*up>maxuint) {
+ #if DECTRACE || DECVERB
+ printf("Bad Unit [%08lx] in %ld-digit number at offset %ld [maxuint %ld].\n",
+ (LI)*up, (LI)dn->digits, (LI)(up-dn->lsu), (LI)maxuint);
+ #endif
+ return 1;}
+ d-=DECDPUN;
+ }
+
+ // check the exponent. Note that input operands can have exponents
+ // which are out of the set->emin/set->emax and set->digits range
+ // (just as they can have more digits than set->digits).
+ ae=dn->exponent+dn->digits-1; // adjusted exponent
+ emax=DECNUMMAXE;
+ emin=DECNUMMINE;
+ digits=DECNUMMAXP;
+ if (ae<emin-(digits-1)) {
+ #if DECTRACE || DECVERB
+ printf("Adjusted exponent underflow [%ld].\n", (LI)ae);
+ decNumberShow(dn);
+ #endif
+ return 1;}
+ if (ae>+emax) {
+ #if DECTRACE || DECVERB
+ printf("Adjusted exponent overflow [%ld].\n", (LI)ae);
+ decNumberShow(dn);
+ #endif
+ return 1;}
+
+ return 0; // it's OK
+ } // decCheckNumber
+
+/* ------------------------------------------------------------------ */
+/* decCheckInexact -- check a normal finite inexact result has digits */
+/* dn is the number to check */
+/* set is the context (for status and precision) */
+/* sets Invalid operation, etc., if some digits are missing */
+/* [this check is not made for DECSUBSET compilation or when */
+/* subnormal is not set] */
+/* ------------------------------------------------------------------ */
+static void decCheckInexact(const decNumber *dn, decContext *set) {
+ #if !DECSUBSET && DECEXTFLAG
+ if ((set->status & (DEC_Inexact|DEC_Subnormal))==DEC_Inexact
+ && (set->digits!=dn->digits) && !(dn->bits & DECSPECIAL)) {
+ #if DECTRACE || DECVERB
+ printf("Insufficient digits [%ld] on normal Inexact result.\n",
+ (LI)dn->digits);
+ decNumberShow(dn);
+ #endif
+ decContextSetStatus(set, DEC_Invalid_operation);
+ }
+ #else
+ // next is a noop for quiet compiler
+ if (dn!=NULL && dn->digits==0) set->status|=DEC_Invalid_operation;
+ #endif
+ return;
+ } // decCheckInexact
+#endif
+
+#if DECALLOC
+#undef malloc
+#undef free
+/* ------------------------------------------------------------------ */
+/* decMalloc -- accountable allocation routine */
+/* n is the number of bytes to allocate */
+/* */
+/* Semantics is the same as the stdlib malloc routine, but bytes */
+/* allocated are accounted for globally, and corruption fences are */
+/* added before and after the 'actual' storage. */
+/* ------------------------------------------------------------------ */
+/* This routine allocates storage with an extra twelve bytes; 8 are */
+/* at the start and hold: */
+/* 0-3 the original length requested */
+/* 4-7 buffer corruption detection fence (DECFENCE, x4) */
+/* The 4 bytes at the end also hold a corruption fence (DECFENCE, x4) */
+/* ------------------------------------------------------------------ */
+static void *decMalloc(size_t n) {
+ uInt size=n+12; // true size
+ void *alloc; // -> allocated storage
+ uByte *b, *b0; // work
+ uInt uiwork; // for macros
+
+ alloc=malloc(size); // -> allocated storage
+ if (alloc==NULL) return NULL; // out of strorage
+ b0=(uByte *)alloc; // as bytes
+ decAllocBytes+=n; // account for storage
+ UBFROMUI(alloc, n); // save n
+ // printf(" alloc ++ dAB: %ld (%ld)\n", (LI)decAllocBytes, (LI)n);
+ for (b=b0+4; b<b0+8; b++) *b=DECFENCE;
+ for (b=b0+n+8; b<b0+n+12; b++) *b=DECFENCE;
+ return b0+8; // -> play area
+ } // decMalloc
+
+/* ------------------------------------------------------------------ */
+/* decFree -- accountable free routine */
+/* alloc is the storage to free */
+/* */
+/* Semantics is the same as the stdlib malloc routine, except that */
+/* the global storage accounting is updated and the fences are */
+/* checked to ensure that no routine has written 'out of bounds'. */
+/* ------------------------------------------------------------------ */
+/* This routine first checks that the fences have not been corrupted. */
+/* It then frees the storage using the 'truw' storage address (that */
+/* is, offset by 8). */
+/* ------------------------------------------------------------------ */
+static void decFree(void *alloc) {
+ uInt n; // original length
+ uByte *b, *b0; // work
+ uInt uiwork; // for macros
+
+ if (alloc==NULL) return; // allowed; it's a nop
+ b0=(uByte *)alloc; // as bytes
+ b0-=8; // -> true start of storage
+ n=UBTOUI(b0); // lift length
+ for (b=b0+4; b<b0+8; b++) if (*b!=DECFENCE)
+ printf("=== Corrupt byte [%02x] at offset %d from %ld ===\n", *b,
+ b-b0-8, (LI)b0);
+ for (b=b0+n+8; b<b0+n+12; b++) if (*b!=DECFENCE)
+ printf("=== Corrupt byte [%02x] at offset +%d from %ld, n=%ld ===\n", *b,
+ b-b0-8, (LI)b0, (LI)n);
+ free(b0); // drop the storage
+ decAllocBytes-=n; // account for storage
+ // printf(" free -- dAB: %d (%d)\n", decAllocBytes, -n);
+ } // decFree
+#define malloc(a) decMalloc(a)
+#define free(a) decFree(a)
+#endif
diff --git a/Build/source/texk/web2c/mplibdir/decNumber.h b/Build/source/texk/web2c/mplibdir/decNumber.h
new file mode 100644
index 00000000000..6f8a5a3ee46
--- /dev/null
+++ b/Build/source/texk/web2c/mplibdir/decNumber.h
@@ -0,0 +1,182 @@
+/* ------------------------------------------------------------------ */
+/* Decimal Number arithmetic module header */
+/* ------------------------------------------------------------------ */
+/* Copyright (c) IBM Corporation, 2000, 2010. All rights reserved. */
+/* */
+/* This software is made available under the terms of the */
+/* ICU License -- ICU 1.8.1 and later. */
+/* */
+/* The description and User's Guide ("The decNumber C Library") for */
+/* this software is called decNumber.pdf. This document is */
+/* available, together with arithmetic and format specifications, */
+/* testcases, and Web links, on the General Decimal Arithmetic page. */
+/* */
+/* Please send comments, suggestions, and corrections to the author: */
+/* mfc@uk.ibm.com */
+/* Mike Cowlishaw, IBM Fellow */
+/* IBM UK, PO Box 31, Birmingham Road, Warwick CV34 5JL, UK */
+/* ------------------------------------------------------------------ */
+
+#if !defined(DECNUMBER)
+ #define DECNUMBER
+ #define DECNAME "decNumber" /* Short name */
+ #define DECFULLNAME "Decimal Number Module" /* Verbose name */
+ #define DECAUTHOR "Mike Cowlishaw" /* Who to blame */
+
+ #if !defined(DECCONTEXT)
+ #include "decContext.h"
+ #endif
+
+ /* Bit settings for decNumber.bits */
+ #define DECNEG 0x80 /* Sign; 1=negative, 0=positive or zero */
+ #define DECINF 0x40 /* 1=Infinity */
+ #define DECNAN 0x20 /* 1=NaN */
+ #define DECSNAN 0x10 /* 1=sNaN */
+ /* The remaining bits are reserved; they must be 0 */
+ #define DECSPECIAL (DECINF|DECNAN|DECSNAN) /* any special value */
+
+ /* Define the decNumber data structure. The size and shape of the */
+ /* units array in the structure is determined by the following */
+ /* constant. This must not be changed without recompiling the */
+ /* decNumber library modules. */
+
+ #define DECDPUN 3 /* DECimal Digits Per UNit [must be >0 */
+ /* and <10; 3 or powers of 2 are best]. */
+
+ /* DECNUMDIGITS is the default number of digits that can be held in */
+ /* the structure. If undefined, 1 is assumed and it is assumed */
+ /* that the structure will be immediately followed by extra space, */
+ /* as required. DECNUMDIGITS is always >0. */
+ #if !defined(DECNUMDIGITS)
+ #define DECNUMDIGITS 1
+ #endif
+
+ /* The size (integer data type) of each unit is determined by the */
+ /* number of digits it will hold. */
+ #if DECDPUN<=2
+ #define decNumberUnit uint8_t
+ #elif DECDPUN<=4
+ #define decNumberUnit uint16_t
+ #else
+ #define decNumberUnit uint32_t
+ #endif
+ /* The number of units needed is ceil(DECNUMDIGITS/DECDPUN) */
+ #define DECNUMUNITS ((DECNUMDIGITS+DECDPUN-1)/DECDPUN)
+
+ /* The data structure... */
+ typedef struct {
+ int32_t digits; /* Count of digits in the coefficient; >0 */
+ int32_t exponent; /* Unadjusted exponent, unbiased, in */
+ /* range: -1999999997 through 999999999 */
+ uint8_t bits; /* Indicator bits (see above) */
+ /* Coefficient, from least significant unit */
+ decNumberUnit lsu[DECNUMUNITS];
+ } decNumber;
+
+ /* Notes: */
+ /* 1. If digits is > DECDPUN then there will one or more */
+ /* decNumberUnits immediately following the first element of lsu.*/
+ /* These contain the remaining (more significant) digits of the */
+ /* number, and may be in the lsu array, or may be guaranteed by */
+ /* some other mechanism (such as being contained in another */
+ /* structure, or being overlaid on dynamically allocated */
+ /* storage). */
+ /* */
+ /* Each integer of the coefficient (except potentially the last) */
+ /* contains DECDPUN digits (e.g., a value in the range 0 through */
+ /* 99999999 if DECDPUN is 8, or 0 through 999 if DECDPUN is 3). */
+ /* */
+ /* 2. A decNumber converted to a string may need up to digits+14 */
+ /* characters. The worst cases (non-exponential and exponential */
+ /* formats) are -0.00000{9...}# and -9.{9...}E+999999999# */
+ /* (where # is '\0') */
+
+
+ /* ---------------------------------------------------------------- */
+ /* decNumber public functions and macros */
+ /* ---------------------------------------------------------------- */
+ /* Conversions */
+ decNumber * decNumberFromInt32(decNumber *, int32_t);
+ decNumber * decNumberFromUInt32(decNumber *, uint32_t);
+ decNumber * decNumberFromString(decNumber *, const char *, decContext *);
+ char * decNumberToString(const decNumber *, char *);
+ char * decNumberToEngString(const decNumber *, char *);
+ uint32_t decNumberToUInt32(const decNumber *, decContext *);
+ int32_t decNumberToInt32(const decNumber *, decContext *);
+ uint8_t * decNumberGetBCD(const decNumber *, uint8_t *);
+ decNumber * decNumberSetBCD(decNumber *, const uint8_t *, uint32_t);
+
+ /* Operators and elementary functions */
+ decNumber * decNumberAbs(decNumber *, const decNumber *, decContext *);
+ decNumber * decNumberAdd(decNumber *, const decNumber *, const decNumber *, decContext *);
+ decNumber * decNumberAnd(decNumber *, const decNumber *, const decNumber *, decContext *);
+ decNumber * decNumberCompare(decNumber *, const decNumber *, const decNumber *, decContext *);
+ decNumber * decNumberCompareSignal(decNumber *, const decNumber *, const decNumber *, decContext *);
+ decNumber * decNumberCompareTotal(decNumber *, const decNumber *, const decNumber *, decContext *);
+ decNumber * decNumberCompareTotalMag(decNumber *, const decNumber *, const decNumber *, decContext *);
+ decNumber * decNumberDivide(decNumber *, const decNumber *, const decNumber *, decContext *);
+ decNumber * decNumberDivideInteger(decNumber *, const decNumber *, const decNumber *, decContext *);
+ decNumber * decNumberExp(decNumber *, const decNumber *, decContext *);
+ decNumber * decNumberFMA(decNumber *, const decNumber *, const decNumber *, const decNumber *, decContext *);
+ decNumber * decNumberInvert(decNumber *, const decNumber *, decContext *);
+ decNumber * decNumberLn(decNumber *, const decNumber *, decContext *);
+ decNumber * decNumberLogB(decNumber *, const decNumber *, decContext *);
+ decNumber * decNumberLog10(decNumber *, const decNumber *, decContext *);
+ decNumber * decNumberMax(decNumber *, const decNumber *, const decNumber *, decContext *);
+ decNumber * decNumberMaxMag(decNumber *, const decNumber *, const decNumber *, decContext *);
+ decNumber * decNumberMin(decNumber *, const decNumber *, const decNumber *, decContext *);
+ decNumber * decNumberMinMag(decNumber *, const decNumber *, const decNumber *, decContext *);
+ decNumber * decNumberMinus(decNumber *, const decNumber *, decContext *);
+ decNumber * decNumberMultiply(decNumber *, const decNumber *, const decNumber *, decContext *);
+ decNumber * decNumberNormalize(decNumber *, const decNumber *, decContext *);
+ decNumber * decNumberOr(decNumber *, const decNumber *, const decNumber *, decContext *);
+ decNumber * decNumberPlus(decNumber *, const decNumber *, decContext *);
+ decNumber * decNumberPower(decNumber *, const decNumber *, const decNumber *, decContext *);
+ decNumber * decNumberQuantize(decNumber *, const decNumber *, const decNumber *, decContext *);
+ decNumber * decNumberReduce(decNumber *, const decNumber *, decContext *);
+ decNumber * decNumberRemainder(decNumber *, const decNumber *, const decNumber *, decContext *);
+ decNumber * decNumberRemainderNear(decNumber *, const decNumber *, const decNumber *, decContext *);
+ decNumber * decNumberRescale(decNumber *, const decNumber *, const decNumber *, decContext *);
+ decNumber * decNumberRotate(decNumber *, const decNumber *, const decNumber *, decContext *);
+ decNumber * decNumberSameQuantum(decNumber *, const decNumber *, const decNumber *);
+ decNumber * decNumberScaleB(decNumber *, const decNumber *, const decNumber *, decContext *);
+ decNumber * decNumberShift(decNumber *, const decNumber *, const decNumber *, decContext *);
+ decNumber * decNumberSquareRoot(decNumber *, const decNumber *, decContext *);
+ decNumber * decNumberSubtract(decNumber *, const decNumber *, const decNumber *, decContext *);
+ decNumber * decNumberToIntegralExact(decNumber *, const decNumber *, decContext *);
+ decNumber * decNumberToIntegralValue(decNumber *, const decNumber *, decContext *);
+ decNumber * decNumberXor(decNumber *, const decNumber *, const decNumber *, decContext *);
+
+ /* Utilities */
+ enum decClass decNumberClass(const decNumber *, decContext *);
+ const char * decNumberClassToString(enum decClass);
+ decNumber * decNumberCopy(decNumber *, const decNumber *);
+ decNumber * decNumberCopyAbs(decNumber *, const decNumber *);
+ decNumber * decNumberCopyNegate(decNumber *, const decNumber *);
+ decNumber * decNumberCopySign(decNumber *, const decNumber *, const decNumber *);
+ decNumber * decNumberNextMinus(decNumber *, const decNumber *, decContext *);
+ decNumber * decNumberNextPlus(decNumber *, const decNumber *, decContext *);
+ decNumber * decNumberNextToward(decNumber *, const decNumber *, const decNumber *, decContext *);
+ decNumber * decNumberTrim(decNumber *);
+ const char * decNumberVersion(void);
+ decNumber * decNumberZero(decNumber *);
+
+ /* Functions for testing decNumbers (normality depends on context) */
+ int32_t decNumberIsNormal(const decNumber *, decContext *);
+ int32_t decNumberIsSubnormal(const decNumber *, decContext *);
+
+ /* Macros for testing decNumber *dn */
+ #define decNumberIsCanonical(dn) (1) /* All decNumbers are saintly */
+ #define decNumberIsFinite(dn) (((dn)->bits&DECSPECIAL)==0)
+ #define decNumberIsInfinite(dn) (((dn)->bits&DECINF)!=0)
+ #define decNumberIsNaN(dn) (((dn)->bits&(DECNAN|DECSNAN))!=0)
+ #define decNumberIsNegative(dn) (((dn)->bits&DECNEG)!=0)
+ #define decNumberIsQNaN(dn) (((dn)->bits&(DECNAN))!=0)
+ #define decNumberIsSNaN(dn) (((dn)->bits&(DECSNAN))!=0)
+ #define decNumberIsSpecial(dn) (((dn)->bits&DECSPECIAL)!=0)
+ #define decNumberIsZero(dn) (*(dn)->lsu==0 \
+ && (dn)->digits==1 \
+ && (((dn)->bits&DECSPECIAL)==0))
+ #define decNumberRadix(dn) (10)
+
+#endif
diff --git a/Build/source/texk/web2c/mplibdir/decNumberLocal.h b/Build/source/texk/web2c/mplibdir/decNumberLocal.h
new file mode 100644
index 00000000000..5c88a5eaaff
--- /dev/null
+++ b/Build/source/texk/web2c/mplibdir/decNumberLocal.h
@@ -0,0 +1,757 @@
+/* ------------------------------------------------------------------ */
+/* decNumber package local type, tuning, and macro definitions */
+/* ------------------------------------------------------------------ */
+/* Copyright (c) IBM Corporation, 2000, 2010. All rights reserved. */
+/* */
+/* This software is made available under the terms of the */
+/* ICU License -- ICU 1.8.1 and later. */
+/* */
+/* The description and User's Guide ("The decNumber C Library") for */
+/* this software is called decNumber.pdf. This document is */
+/* available, together with arithmetic and format specifications, */
+/* testcases, and Web links, on the General Decimal Arithmetic page. */
+/* */
+/* Please send comments, suggestions, and corrections to the author: */
+/* mfc@uk.ibm.com */
+/* Mike Cowlishaw, IBM Fellow */
+/* IBM UK, PO Box 31, Birmingham Road, Warwick CV34 5JL, UK */
+/* ------------------------------------------------------------------ */
+/* This header file is included by all modules in the decNumber */
+/* library, and contains local type definitions, tuning parameters, */
+/* etc. It should not need to be used by application programs. */
+/* decNumber.h or one of decDouble (etc.) must be included first. */
+/* ------------------------------------------------------------------ */
+
+#if !defined(DECNUMBERLOC)
+ #define DECNUMBERLOC
+ #define DECVERSION "decNumber 3.68" /* Package Version [16 max.] */
+ #define DECNLAUTHOR "Mike Cowlishaw" /* Who to blame */
+
+ #include <stdlib.h> /* for abs */
+ #include <string.h> /* for memset, strcpy */
+
+ /* Conditional code flag -- set this to match hardware platform */
+ #if !defined(DECLITEND)
+ #define DECLITEND 1 /* 1=little-endian, 0=big-endian */
+ #endif
+
+ /* Conditional code flag -- set this to 1 for best performance */
+ #if !defined(DECUSE64)
+ #define DECUSE64 1 /* 1=use int64s, 0=int32 & smaller only */
+ #endif
+
+ /* Conditional code flag -- set this to 0 to exclude printf calls */
+ #if !defined(DECPRINT)
+ #define DECPRINT 1 /* 1=allow printf calls; 0=no printf */
+ #endif
+
+ /* Conditional check flags -- set these to 0 for best performance */
+ #if !defined(DECCHECK)
+ #define DECCHECK 0 /* 1 to enable robust checking */
+ #endif
+ #if !defined(DECALLOC)
+ #define DECALLOC 0 /* 1 to enable memory accounting */
+ #endif
+ #if !defined(DECTRACE)
+ #define DECTRACE 0 /* 1 to trace certain internals, etc. */
+ #endif
+
+ /* Tuning parameter for decNumber (arbitrary precision) module */
+ #if !defined(DECBUFFER)
+ #define DECBUFFER 36 /* Size basis for local buffers. This */
+ /* should be a common maximum precision */
+ /* rounded up to a multiple of 4; must */
+ /* be zero or positive. */
+ #endif
+
+
+ /* ---------------------------------------------------------------- */
+ /* Check parameter dependencies */
+ /* ---------------------------------------------------------------- */
+ #if DECCHECK & !DECPRINT
+ #error DECCHECK needs DECPRINT to be useful
+ #endif
+ #if DECALLOC & !DECPRINT
+ #error DECALLOC needs DECPRINT to be useful
+ #endif
+ #if DECTRACE & !DECPRINT
+ #error DECTRACE needs DECPRINT to be useful
+ #endif
+
+ /* ---------------------------------------------------------------- */
+ /* Definitions for all modules (general-purpose) */
+ /* ---------------------------------------------------------------- */
+
+ /* Local names for common types -- for safety, decNumber modules do */
+ /* not use int or long directly. */
+ #define Flag uint8_t
+ #define Byte int8_t
+ #define uByte uint8_t
+ #define Short int16_t
+ #define uShort uint16_t
+ #define Int int32_t
+ #define uInt uint32_t
+ #define Unit decNumberUnit
+ #if DECUSE64
+ #define Long int64_t
+ #define uLong uint64_t
+ #endif
+
+ /* Development-use definitions */
+ typedef long int LI; /* for printf arguments only */
+ #define DECNOINT 0 /* 1 to check no internal use of 'int' */
+ /* or stdint types */
+ #if DECNOINT
+ /* if these interfere with your C includes, do not set DECNOINT */
+ #define int ? /* enable to ensure that plain C 'int' */
+ #define long ?? /* .. or 'long' types are not used */
+ #endif
+
+ /* Shared lookup tables */
+ extern const uByte DECSTICKYTAB[10]; /* re-round digits if sticky */
+ extern const uInt DECPOWERS[10]; /* powers of ten table */
+ /* The following are included from decDPD.h */
+ extern const uShort DPD2BIN[1024]; /* DPD -> 0-999 */
+ extern const uShort BIN2DPD[1000]; /* 0-999 -> DPD */
+ extern const uInt DPD2BINK[1024]; /* DPD -> 0-999000 */
+ extern const uInt DPD2BINM[1024]; /* DPD -> 0-999000000 */
+ extern const uByte DPD2BCD8[4096]; /* DPD -> ddd + len */
+ extern const uByte BIN2BCD8[4000]; /* 0-999 -> ddd + len */
+ extern const uShort BCD2DPD[2458]; /* 0-0x999 -> DPD (0x999=2457)*/
+
+ /* LONGMUL32HI -- set w=(u*v)>>32, where w, u, and v are uInts */
+ /* (that is, sets w to be the high-order word of the 64-bit result; */
+ /* the low-order word is simply u*v.) */
+ /* This version is derived from Knuth via Hacker's Delight; */
+ /* it seems to optimize better than some others tried */
+ #define LONGMUL32HI(w, u, v) { \
+ uInt u0, u1, v0, v1, w0, w1, w2, t; \
+ u0=u & 0xffff; u1=u>>16; \
+ v0=v & 0xffff; v1=v>>16; \
+ w0=u0*v0; \
+ t=u1*v0 + (w0>>16); \
+ w1=t & 0xffff; w2=t>>16; \
+ w1=u0*v1 + w1; \
+ (w)=u1*v1 + w2 + (w1>>16);}
+
+ /* ROUNDUP -- round an integer up to a multiple of n */
+ #define ROUNDUP(i, n) ((((i)+(n)-1)/n)*n)
+ #define ROUNDUP4(i) (((i)+3)&~3) /* special for n=4 */
+
+ /* ROUNDDOWN -- round an integer down to a multiple of n */
+ #define ROUNDDOWN(i, n) (((i)/n)*n)
+ #define ROUNDDOWN4(i) ((i)&~3) /* special for n=4 */
+
+ /* References to multi-byte sequences under different sizes; these */
+ /* require locally declared variables, but do not violate strict */
+ /* aliasing or alignment (as did the UINTAT simple cast to uInt). */
+ /* Variables needed are uswork, uiwork, etc. [so do not use at same */
+ /* level in an expression, e.g., UBTOUI(x)==UBTOUI(y) may fail]. */
+
+ /* Return a uInt, etc., from bytes starting at a char* or uByte* */
+ #define UBTOUS(b) (memcpy((void *)&uswork, b, 2), uswork)
+ #define UBTOUI(b) (memcpy((void *)&uiwork, b, 4), uiwork)
+
+ /* Store a uInt, etc., into bytes starting at a char* or uByte*. */
+ /* Returns i, evaluated, for convenience; has to use uiwork because */
+ /* i may be an expression. */
+ #define UBFROMUS(b, i) (uswork=(i), memcpy(b, (void *)&uswork, 2), uswork)
+ #define UBFROMUI(b, i) (uiwork=(i), memcpy(b, (void *)&uiwork, 4), uiwork)
+
+ /* X10 and X100 -- multiply integer i by 10 or 100 */
+ /* [shifts are usually faster than multiply; could be conditional] */
+ #define X10(i) (((i)<<1)+((i)<<3))
+ #define X100(i) (((i)<<2)+((i)<<5)+((i)<<6))
+
+ /* MAXI and MINI -- general max & min (not in ANSI) for integers */
+ #define MAXI(x,y) ((x)<(y)?(y):(x))
+ #define MINI(x,y) ((x)>(y)?(y):(x))
+
+ /* Useful constants */
+ #define BILLION 1000000000 /* 10**9 */
+ /* CHARMASK: 0x30303030 for ASCII/UTF8; 0xF0F0F0F0 for EBCDIC */
+ #define CHARMASK ((((((((uInt)'0')<<8)+'0')<<8)+'0')<<8)+'0')
+
+
+ /* ---------------------------------------------------------------- */
+ /* Definitions for arbitary-precision modules (only valid after */
+ /* decNumber.h has been included) */
+ /* ---------------------------------------------------------------- */
+
+ /* Limits and constants */
+ #define DECNUMMAXP 999999999 /* maximum precision code can handle */
+ #define DECNUMMAXE 999999999 /* maximum adjusted exponent ditto */
+ #define DECNUMMINE -999999999 /* minimum adjusted exponent ditto */
+ #if (DECNUMMAXP != DEC_MAX_DIGITS)
+ #error Maximum digits mismatch
+ #endif
+ #if (DECNUMMAXE != DEC_MAX_EMAX)
+ #error Maximum exponent mismatch
+ #endif
+ #if (DECNUMMINE != DEC_MIN_EMIN)
+ #error Minimum exponent mismatch
+ #endif
+
+ /* Set DECDPUNMAX -- the maximum integer that fits in DECDPUN */
+ /* digits, and D2UTABLE -- the initializer for the D2U table */
+ #if DECDPUN==1
+ #define DECDPUNMAX 9
+ #define D2UTABLE {0,1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16,17, \
+ 18,19,20,21,22,23,24,25,26,27,28,29,30,31,32, \
+ 33,34,35,36,37,38,39,40,41,42,43,44,45,46,47, \
+ 48,49}
+ #elif DECDPUN==2
+ #define DECDPUNMAX 99
+ #define D2UTABLE {0,1,1,2,2,3,3,4,4,5,5,6,6,7,7,8,8,9,9,10,10, \
+ 11,11,12,12,13,13,14,14,15,15,16,16,17,17,18, \
+ 18,19,19,20,20,21,21,22,22,23,23,24,24,25}
+ #elif DECDPUN==3
+ #define DECDPUNMAX 999
+ #define D2UTABLE {0,1,1,1,2,2,2,3,3,3,4,4,4,5,5,5,6,6,6,7,7,7, \
+ 8,8,8,9,9,9,10,10,10,11,11,11,12,12,12,13,13, \
+ 13,14,14,14,15,15,15,16,16,16,17}
+ #elif DECDPUN==4
+ #define DECDPUNMAX 9999
+ #define D2UTABLE {0,1,1,1,1,2,2,2,2,3,3,3,3,4,4,4,4,5,5,5,5,6, \
+ 6,6,6,7,7,7,7,8,8,8,8,9,9,9,9,10,10,10,10,11, \
+ 11,11,11,12,12,12,12,13}
+ #elif DECDPUN==5
+ #define DECDPUNMAX 99999
+ #define D2UTABLE {0,1,1,1,1,1,2,2,2,2,2,3,3,3,3,3,4,4,4,4,4,5, \
+ 5,5,5,5,6,6,6,6,6,7,7,7,7,7,8,8,8,8,8,9,9,9, \
+ 9,9,10,10,10,10}
+ #elif DECDPUN==6
+ #define DECDPUNMAX 999999
+ #define D2UTABLE {0,1,1,1,1,1,1,2,2,2,2,2,2,3,3,3,3,3,3,4,4,4, \
+ 4,4,4,5,5,5,5,5,5,6,6,6,6,6,6,7,7,7,7,7,7,8, \
+ 8,8,8,8,8,9}
+ #elif DECDPUN==7
+ #define DECDPUNMAX 9999999
+ #define D2UTABLE {0,1,1,1,1,1,1,1,2,2,2,2,2,2,2,3,3,3,3,3,3,3, \
+ 4,4,4,4,4,4,4,5,5,5,5,5,5,5,6,6,6,6,6,6,6,7, \
+ 7,7,7,7,7,7}
+ #elif DECDPUN==8
+ #define DECDPUNMAX 99999999
+ #define D2UTABLE {0,1,1,1,1,1,1,1,1,2,2,2,2,2,2,2,2,3,3,3,3,3, \
+ 3,3,3,4,4,4,4,4,4,4,4,5,5,5,5,5,5,5,5,6,6,6, \
+ 6,6,6,6,6,7}
+ #elif DECDPUN==9
+ #define DECDPUNMAX 999999999
+ #define D2UTABLE {0,1,1,1,1,1,1,1,1,1,2,2,2,2,2,2,2,2,2,3,3,3, \
+ 3,3,3,3,3,3,4,4,4,4,4,4,4,4,4,5,5,5,5,5,5,5, \
+ 5,5,6,6,6,6}
+ #elif defined(DECDPUN)
+ #error DECDPUN must be in the range 1-9
+ #endif
+
+ /* ----- Shared data (in decNumber.c) ----- */
+ /* Public lookup table used by the D2U macro (see below) */
+ #define DECMAXD2U 49
+ extern const uByte d2utable[DECMAXD2U+1];
+
+ /* ----- Macros ----- */
+ /* ISZERO -- return true if decNumber dn is a zero */
+ /* [performance-critical in some situations] */
+ #define ISZERO(dn) decNumberIsZero(dn) /* now just a local name */
+
+ /* D2U -- return the number of Units needed to hold d digits */
+ /* (runtime version, with table lookaside for small d) */
+ #if DECDPUN==8
+ #define D2U(d) ((unsigned)((d)<=DECMAXD2U?d2utable[d]:((d)+7)>>3))
+ #elif DECDPUN==4
+ #define D2U(d) ((unsigned)((d)<=DECMAXD2U?d2utable[d]:((d)+3)>>2))
+ #else
+ #define D2U(d) ((d)<=DECMAXD2U?d2utable[d]:((d)+DECDPUN-1)/DECDPUN)
+ #endif
+ /* SD2U -- static D2U macro (for compile-time calculation) */
+ #define SD2U(d) (((d)+DECDPUN-1)/DECDPUN)
+
+ /* MSUDIGITS -- returns digits in msu, from digits, calculated */
+ /* using D2U */
+ #define MSUDIGITS(d) ((d)-(D2U(d)-1)*DECDPUN)
+
+ /* D2N -- return the number of decNumber structs that would be */
+ /* needed to contain that number of digits (and the initial */
+ /* decNumber struct) safely. Note that one Unit is included in the */
+ /* initial structure. Used for allocating space that is aligned on */
+ /* a decNumber struct boundary. */
+ #define D2N(d) \
+ ((((SD2U(d)-1)*sizeof(Unit))+sizeof(decNumber)*2-1)/sizeof(decNumber))
+
+ /* TODIGIT -- macro to remove the leading digit from the unsigned */
+ /* integer u at column cut (counting from the right, LSD=0) and */
+ /* place it as an ASCII character into the character pointed to by */
+ /* c. Note that cut must be <= 9, and the maximum value for u is */
+ /* 2,000,000,000 (as is needed for negative exponents of */
+ /* subnormals). The unsigned integer pow is used as a temporary */
+ /* variable. */
+ #define TODIGIT(u, cut, c, pow) { \
+ *(c)='0'; \
+ pow=DECPOWERS[cut]*2; \
+ if ((u)>pow) { \
+ pow*=4; \
+ if ((u)>=pow) {(u)-=pow; *(c)+=8;} \
+ pow/=2; \
+ if ((u)>=pow) {(u)-=pow; *(c)+=4;} \
+ pow/=2; \
+ } \
+ if ((u)>=pow) {(u)-=pow; *(c)+=2;} \
+ pow/=2; \
+ if ((u)>=pow) {(u)-=pow; *(c)+=1;} \
+ }
+
+ /* ---------------------------------------------------------------- */
+ /* Definitions for fixed-precision modules (only valid after */
+ /* decSingle.h, decDouble.h, or decQuad.h has been included) */
+ /* ---------------------------------------------------------------- */
+
+ /* bcdnum -- a structure describing a format-independent finite */
+ /* number, whose coefficient is a string of bcd8 uBytes */
+ typedef struct {
+ uByte *msd; /* -> most significant digit */
+ uByte *lsd; /* -> least ditto */
+ uInt sign; /* 0=positive, DECFLOAT_Sign=negative */
+ Int exponent; /* Unadjusted signed exponent (q), or */
+ /* DECFLOAT_NaN etc. for a special */
+ } bcdnum;
+
+ /* Test if exponent or bcdnum exponent must be a special, etc. */
+ #define EXPISSPECIAL(exp) ((exp)>=DECFLOAT_MinSp)
+ #define EXPISINF(exp) (exp==DECFLOAT_Inf)
+ #define EXPISNAN(exp) (exp==DECFLOAT_qNaN || exp==DECFLOAT_sNaN)
+ #define NUMISSPECIAL(num) (EXPISSPECIAL((num)->exponent))
+
+ /* Refer to a 32-bit word or byte in a decFloat (df) by big-endian */
+ /* (array) notation (the 0 word or byte contains the sign bit), */
+ /* automatically adjusting for endianness; similarly address a word */
+ /* in the next-wider format (decFloatWider, or dfw) */
+ #define DECWORDS (DECBYTES/4)
+ #define DECWWORDS (DECWBYTES/4)
+ #if DECLITEND
+ #define DFBYTE(df, off) ((df)->bytes[DECBYTES-1-(off)])
+ #define DFWORD(df, off) ((df)->words[DECWORDS-1-(off)])
+ #define DFWWORD(dfw, off) ((dfw)->words[DECWWORDS-1-(off)])
+ #else
+ #define DFBYTE(df, off) ((df)->bytes[off])
+ #define DFWORD(df, off) ((df)->words[off])
+ #define DFWWORD(dfw, off) ((dfw)->words[off])
+ #endif
+
+ /* Tests for sign or specials, directly on DECFLOATs */
+ #define DFISSIGNED(df) ((DFWORD(df, 0)&0x80000000)!=0)
+ #define DFISSPECIAL(df) ((DFWORD(df, 0)&0x78000000)==0x78000000)
+ #define DFISINF(df) ((DFWORD(df, 0)&0x7c000000)==0x78000000)
+ #define DFISNAN(df) ((DFWORD(df, 0)&0x7c000000)==0x7c000000)
+ #define DFISQNAN(df) ((DFWORD(df, 0)&0x7e000000)==0x7c000000)
+ #define DFISSNAN(df) ((DFWORD(df, 0)&0x7e000000)==0x7e000000)
+
+ /* Shared lookup tables */
+ extern const uInt DECCOMBMSD[64]; /* Combination field -> MSD */
+ extern const uInt DECCOMBFROM[48]; /* exp+msd -> Combination */
+
+ /* Private generic (utility) routine */
+ #if DECCHECK || DECTRACE
+ extern void decShowNum(const bcdnum *, const char *);
+ #endif
+
+ /* Format-dependent macros and constants */
+ #if defined(DECPMAX)
+
+ /* Useful constants */
+ #define DECPMAX9 (ROUNDUP(DECPMAX, 9)/9) /* 'Pmax' in 10**9s */
+ /* Top words for a zero */
+ #define SINGLEZERO 0x22500000
+ #define DOUBLEZERO 0x22380000
+ #define QUADZERO 0x22080000
+ /* [ZEROWORD is defined to be one of these in the DFISZERO macro] */
+
+ /* Format-dependent common tests: */
+ /* DFISZERO -- test for (any) zero */
+ /* DFISCCZERO -- test for coefficient continuation being zero */
+ /* DFISCC01 -- test for coefficient contains only 0s and 1s */
+ /* DFISINT -- test for finite and exponent q=0 */
+ /* DFISUINT01 -- test for sign=0, finite, exponent q=0, and */
+ /* MSD=0 or 1 */
+ /* ZEROWORD is also defined here. */
+ /* */
+ /* In DFISZERO the first test checks the least-significant word */
+ /* (most likely to be non-zero); the penultimate tests MSD and */
+ /* DPDs in the signword, and the final test excludes specials and */
+ /* MSD>7. DFISINT similarly has to allow for the two forms of */
+ /* MSD codes. DFISUINT01 only has to allow for one form of MSD */
+ /* code. */
+ #if DECPMAX==7
+ #define ZEROWORD SINGLEZERO
+ /* [test macros not needed except for Zero] */
+ #define DFISZERO(df) ((DFWORD(df, 0)&0x1c0fffff)==0 \
+ && (DFWORD(df, 0)&0x60000000)!=0x60000000)
+ #elif DECPMAX==16
+ #define ZEROWORD DOUBLEZERO
+ #define DFISZERO(df) ((DFWORD(df, 1)==0 \
+ && (DFWORD(df, 0)&0x1c03ffff)==0 \
+ && (DFWORD(df, 0)&0x60000000)!=0x60000000))
+ #define DFISINT(df) ((DFWORD(df, 0)&0x63fc0000)==0x22380000 \
+ ||(DFWORD(df, 0)&0x7bfc0000)==0x6a380000)
+ #define DFISUINT01(df) ((DFWORD(df, 0)&0xfbfc0000)==0x22380000)
+ #define DFISCCZERO(df) (DFWORD(df, 1)==0 \
+ && (DFWORD(df, 0)&0x0003ffff)==0)
+ #define DFISCC01(df) ((DFWORD(df, 0)&~0xfffc9124)==0 \
+ && (DFWORD(df, 1)&~0x49124491)==0)
+ #elif DECPMAX==34
+ #define ZEROWORD QUADZERO
+ #define DFISZERO(df) ((DFWORD(df, 3)==0 \
+ && DFWORD(df, 2)==0 \
+ && DFWORD(df, 1)==0 \
+ && (DFWORD(df, 0)&0x1c003fff)==0 \
+ && (DFWORD(df, 0)&0x60000000)!=0x60000000))
+ #define DFISINT(df) ((DFWORD(df, 0)&0x63ffc000)==0x22080000 \
+ ||(DFWORD(df, 0)&0x7bffc000)==0x6a080000)
+ #define DFISUINT01(df) ((DFWORD(df, 0)&0xfbffc000)==0x22080000)
+ #define DFISCCZERO(df) (DFWORD(df, 3)==0 \
+ && DFWORD(df, 2)==0 \
+ && DFWORD(df, 1)==0 \
+ && (DFWORD(df, 0)&0x00003fff)==0)
+
+ #define DFISCC01(df) ((DFWORD(df, 0)&~0xffffc912)==0 \
+ && (DFWORD(df, 1)&~0x44912449)==0 \
+ && (DFWORD(df, 2)&~0x12449124)==0 \
+ && (DFWORD(df, 3)&~0x49124491)==0)
+ #endif
+
+ /* Macros to test if a certain 10 bits of a uInt or pair of uInts */
+ /* are a canonical declet [higher or lower bits are ignored]. */
+ /* declet is at offset 0 (from the right) in a uInt: */
+ #define CANONDPD(dpd) (((dpd)&0x300)==0 || ((dpd)&0x6e)!=0x6e)
+ /* declet is at offset k (a multiple of 2) in a uInt: */
+ #define CANONDPDOFF(dpd, k) (((dpd)&(0x300<<(k)))==0 \
+ || ((dpd)&(((uInt)0x6e)<<(k)))!=(((uInt)0x6e)<<(k)))
+ /* declet is at offset k (a multiple of 2) in a pair of uInts: */
+ /* [the top 2 bits will always be in the more-significant uInt] */
+ #define CANONDPDTWO(hi, lo, k) (((hi)&(0x300>>(32-(k))))==0 \
+ || ((hi)&(0x6e>>(32-(k))))!=(0x6e>>(32-(k))) \
+ || ((lo)&(((uInt)0x6e)<<(k)))!=(((uInt)0x6e)<<(k)))
+
+ /* Macro to test whether a full-length (length DECPMAX) BCD8 */
+ /* coefficient, starting at uByte u, is all zeros */
+ /* Test just the LSWord first, then the remainder as a sequence */
+ /* of tests in order to avoid same-level use of UBTOUI */
+ #if DECPMAX==7
+ #define ISCOEFFZERO(u) ( \
+ UBTOUI((u)+DECPMAX-4)==0 \
+ && UBTOUS((u)+DECPMAX-6)==0 \
+ && *(u)==0)
+ #elif DECPMAX==16
+ #define ISCOEFFZERO(u) ( \
+ UBTOUI((u)+DECPMAX-4)==0 \
+ && UBTOUI((u)+DECPMAX-8)==0 \
+ && UBTOUI((u)+DECPMAX-12)==0 \
+ && UBTOUI(u)==0)
+ #elif DECPMAX==34
+ #define ISCOEFFZERO(u) ( \
+ UBTOUI((u)+DECPMAX-4)==0 \
+ && UBTOUI((u)+DECPMAX-8)==0 \
+ && UBTOUI((u)+DECPMAX-12)==0 \
+ && UBTOUI((u)+DECPMAX-16)==0 \
+ && UBTOUI((u)+DECPMAX-20)==0 \
+ && UBTOUI((u)+DECPMAX-24)==0 \
+ && UBTOUI((u)+DECPMAX-28)==0 \
+ && UBTOUI((u)+DECPMAX-32)==0 \
+ && UBTOUS(u)==0)
+ #endif
+
+ /* Macros and masks for the sign, exponent continuation, and MSD */
+ /* Get the sign as DECFLOAT_Sign or 0 */
+ #define GETSIGN(df) (DFWORD(df, 0)&0x80000000)
+ /* Get the exponent continuation from a decFloat *df as an Int */
+ #define GETECON(df) ((Int)((DFWORD((df), 0)&0x03ffffff)>>(32-6-DECECONL)))
+ /* Ditto, from the next-wider format */
+ #define GETWECON(df) ((Int)((DFWWORD((df), 0)&0x03ffffff)>>(32-6-DECWECONL)))
+ /* Get the biased exponent similarly */
+ #define GETEXP(df) ((Int)(DECCOMBEXP[DFWORD((df), 0)>>26]+GETECON(df)))
+ /* Get the unbiased exponent similarly */
+ #define GETEXPUN(df) ((Int)GETEXP(df)-DECBIAS)
+ /* Get the MSD similarly (as uInt) */
+ #define GETMSD(df) (DECCOMBMSD[DFWORD((df), 0)>>26])
+
+ /* Compile-time computes of the exponent continuation field masks */
+ /* full exponent continuation field: */
+ #define ECONMASK ((0x03ffffff>>(32-6-DECECONL))<<(32-6-DECECONL))
+ /* same, not including its first digit (the qNaN/sNaN selector): */
+ #define ECONNANMASK ((0x01ffffff>>(32-6-DECECONL))<<(32-6-DECECONL))
+
+ /* Macros to decode the coefficient in a finite decFloat *df into */
+ /* a BCD string (uByte *bcdin) of length DECPMAX uBytes. */
+
+ /* In-line sequence to convert least significant 10 bits of uInt */
+ /* dpd to three BCD8 digits starting at uByte u. Note that an */
+ /* extra byte is written to the right of the three digits because */
+ /* four bytes are moved at a time for speed; the alternative */
+ /* macro moves exactly three bytes (usually slower). */
+ #define dpd2bcd8(u, dpd) memcpy(u, &DPD2BCD8[((dpd)&0x3ff)*4], 4)
+ #define dpd2bcd83(u, dpd) memcpy(u, &DPD2BCD8[((dpd)&0x3ff)*4], 3)
+
+ /* Decode the declets. After extracting each one, it is decoded */
+ /* to BCD8 using a table lookup (also used for variable-length */
+ /* decode). Each DPD decode is 3 bytes BCD8 plus a one-byte */
+ /* length which is not used, here). Fixed-length 4-byte moves */
+ /* are fast, however, almost everywhere, and so are used except */
+ /* for the final three bytes (to avoid overrun). The code below */
+ /* is 36 instructions for Doubles and about 70 for Quads, even */
+ /* on IA32. */
+
+ /* Two macros are defined for each format: */
+ /* GETCOEFF extracts the coefficient of the current format */
+ /* GETWCOEFF extracts the coefficient of the next-wider format. */
+ /* The latter is a copy of the next-wider GETCOEFF using DFWWORD. */
+
+ #if DECPMAX==7
+ #define GETCOEFF(df, bcd) { \
+ uInt sourhi=DFWORD(df, 0); \
+ *(bcd)=(uByte)DECCOMBMSD[sourhi>>26]; \
+ dpd2bcd8(bcd+1, sourhi>>10); \
+ dpd2bcd83(bcd+4, sourhi);}
+ #define GETWCOEFF(df, bcd) { \
+ uInt sourhi=DFWWORD(df, 0); \
+ uInt sourlo=DFWWORD(df, 1); \
+ *(bcd)=(uByte)DECCOMBMSD[sourhi>>26]; \
+ dpd2bcd8(bcd+1, sourhi>>8); \
+ dpd2bcd8(bcd+4, (sourhi<<2) | (sourlo>>30)); \
+ dpd2bcd8(bcd+7, sourlo>>20); \
+ dpd2bcd8(bcd+10, sourlo>>10); \
+ dpd2bcd83(bcd+13, sourlo);}
+
+ #elif DECPMAX==16
+ #define GETCOEFF(df, bcd) { \
+ uInt sourhi=DFWORD(df, 0); \
+ uInt sourlo=DFWORD(df, 1); \
+ *(bcd)=(uByte)DECCOMBMSD[sourhi>>26]; \
+ dpd2bcd8(bcd+1, sourhi>>8); \
+ dpd2bcd8(bcd+4, (sourhi<<2) | (sourlo>>30)); \
+ dpd2bcd8(bcd+7, sourlo>>20); \
+ dpd2bcd8(bcd+10, sourlo>>10); \
+ dpd2bcd83(bcd+13, sourlo);}
+ #define GETWCOEFF(df, bcd) { \
+ uInt sourhi=DFWWORD(df, 0); \
+ uInt sourmh=DFWWORD(df, 1); \
+ uInt sourml=DFWWORD(df, 2); \
+ uInt sourlo=DFWWORD(df, 3); \
+ *(bcd)=(uByte)DECCOMBMSD[sourhi>>26]; \
+ dpd2bcd8(bcd+1, sourhi>>4); \
+ dpd2bcd8(bcd+4, ((sourhi)<<6) | (sourmh>>26)); \
+ dpd2bcd8(bcd+7, sourmh>>16); \
+ dpd2bcd8(bcd+10, sourmh>>6); \
+ dpd2bcd8(bcd+13, ((sourmh)<<4) | (sourml>>28)); \
+ dpd2bcd8(bcd+16, sourml>>18); \
+ dpd2bcd8(bcd+19, sourml>>8); \
+ dpd2bcd8(bcd+22, ((sourml)<<2) | (sourlo>>30)); \
+ dpd2bcd8(bcd+25, sourlo>>20); \
+ dpd2bcd8(bcd+28, sourlo>>10); \
+ dpd2bcd83(bcd+31, sourlo);}
+
+ #elif DECPMAX==34
+ #define GETCOEFF(df, bcd) { \
+ uInt sourhi=DFWORD(df, 0); \
+ uInt sourmh=DFWORD(df, 1); \
+ uInt sourml=DFWORD(df, 2); \
+ uInt sourlo=DFWORD(df, 3); \
+ *(bcd)=(uByte)DECCOMBMSD[sourhi>>26]; \
+ dpd2bcd8(bcd+1, sourhi>>4); \
+ dpd2bcd8(bcd+4, ((sourhi)<<6) | (sourmh>>26)); \
+ dpd2bcd8(bcd+7, sourmh>>16); \
+ dpd2bcd8(bcd+10, sourmh>>6); \
+ dpd2bcd8(bcd+13, ((sourmh)<<4) | (sourml>>28)); \
+ dpd2bcd8(bcd+16, sourml>>18); \
+ dpd2bcd8(bcd+19, sourml>>8); \
+ dpd2bcd8(bcd+22, ((sourml)<<2) | (sourlo>>30)); \
+ dpd2bcd8(bcd+25, sourlo>>20); \
+ dpd2bcd8(bcd+28, sourlo>>10); \
+ dpd2bcd83(bcd+31, sourlo);}
+
+ #define GETWCOEFF(df, bcd) {??} /* [should never be used] */
+ #endif
+
+ /* Macros to decode the coefficient in a finite decFloat *df into */
+ /* a base-billion uInt array, with the least-significant */
+ /* 0-999999999 'digit' at offset 0. */
+
+ /* Decode the declets. After extracting each one, it is decoded */
+ /* to binary using a table lookup. Three tables are used; one */
+ /* the usual DPD to binary, the other two pre-multiplied by 1000 */
+ /* and 1000000 to avoid multiplication during decode. These */
+ /* tables can also be used for multiplying up the MSD as the DPD */
+ /* code for 0 through 9 is the identity. */
+ #define DPD2BIN0 DPD2BIN /* for prettier code */
+
+ #if DECPMAX==7
+ #define GETCOEFFBILL(df, buf) { \
+ uInt sourhi=DFWORD(df, 0); \
+ (buf)[0]=DPD2BIN0[sourhi&0x3ff] \
+ +DPD2BINK[(sourhi>>10)&0x3ff] \
+ +DPD2BINM[DECCOMBMSD[sourhi>>26]];}
+
+ #elif DECPMAX==16
+ #define GETCOEFFBILL(df, buf) { \
+ uInt sourhi, sourlo; \
+ sourlo=DFWORD(df, 1); \
+ (buf)[0]=DPD2BIN0[sourlo&0x3ff] \
+ +DPD2BINK[(sourlo>>10)&0x3ff] \
+ +DPD2BINM[(sourlo>>20)&0x3ff]; \
+ sourhi=DFWORD(df, 0); \
+ (buf)[1]=DPD2BIN0[((sourhi<<2) | (sourlo>>30))&0x3ff] \
+ +DPD2BINK[(sourhi>>8)&0x3ff] \
+ +DPD2BINM[DECCOMBMSD[sourhi>>26]];}
+
+ #elif DECPMAX==34
+ #define GETCOEFFBILL(df, buf) { \
+ uInt sourhi, sourmh, sourml, sourlo; \
+ sourlo=DFWORD(df, 3); \
+ (buf)[0]=DPD2BIN0[sourlo&0x3ff] \
+ +DPD2BINK[(sourlo>>10)&0x3ff] \
+ +DPD2BINM[(sourlo>>20)&0x3ff]; \
+ sourml=DFWORD(df, 2); \
+ (buf)[1]=DPD2BIN0[((sourml<<2) | (sourlo>>30))&0x3ff] \
+ +DPD2BINK[(sourml>>8)&0x3ff] \
+ +DPD2BINM[(sourml>>18)&0x3ff]; \
+ sourmh=DFWORD(df, 1); \
+ (buf)[2]=DPD2BIN0[((sourmh<<4) | (sourml>>28))&0x3ff] \
+ +DPD2BINK[(sourmh>>6)&0x3ff] \
+ +DPD2BINM[(sourmh>>16)&0x3ff]; \
+ sourhi=DFWORD(df, 0); \
+ (buf)[3]=DPD2BIN0[((sourhi<<6) | (sourmh>>26))&0x3ff] \
+ +DPD2BINK[(sourhi>>4)&0x3ff] \
+ +DPD2BINM[DECCOMBMSD[sourhi>>26]];}
+
+ #endif
+
+ /* Macros to decode the coefficient in a finite decFloat *df into */
+ /* a base-thousand uInt array (of size DECLETS+1, to allow for */
+ /* the MSD), with the least-significant 0-999 'digit' at offset 0.*/
+
+ /* Decode the declets. After extracting each one, it is decoded */
+ /* to binary using a table lookup. */
+ #if DECPMAX==7
+ #define GETCOEFFTHOU(df, buf) { \
+ uInt sourhi=DFWORD(df, 0); \
+ (buf)[0]=DPD2BIN[sourhi&0x3ff]; \
+ (buf)[1]=DPD2BIN[(sourhi>>10)&0x3ff]; \
+ (buf)[2]=DECCOMBMSD[sourhi>>26];}
+
+ #elif DECPMAX==16
+ #define GETCOEFFTHOU(df, buf) { \
+ uInt sourhi, sourlo; \
+ sourlo=DFWORD(df, 1); \
+ (buf)[0]=DPD2BIN[sourlo&0x3ff]; \
+ (buf)[1]=DPD2BIN[(sourlo>>10)&0x3ff]; \
+ (buf)[2]=DPD2BIN[(sourlo>>20)&0x3ff]; \
+ sourhi=DFWORD(df, 0); \
+ (buf)[3]=DPD2BIN[((sourhi<<2) | (sourlo>>30))&0x3ff]; \
+ (buf)[4]=DPD2BIN[(sourhi>>8)&0x3ff]; \
+ (buf)[5]=DECCOMBMSD[sourhi>>26];}
+
+ #elif DECPMAX==34
+ #define GETCOEFFTHOU(df, buf) { \
+ uInt sourhi, sourmh, sourml, sourlo; \
+ sourlo=DFWORD(df, 3); \
+ (buf)[0]=DPD2BIN[sourlo&0x3ff]; \
+ (buf)[1]=DPD2BIN[(sourlo>>10)&0x3ff]; \
+ (buf)[2]=DPD2BIN[(sourlo>>20)&0x3ff]; \
+ sourml=DFWORD(df, 2); \
+ (buf)[3]=DPD2BIN[((sourml<<2) | (sourlo>>30))&0x3ff]; \
+ (buf)[4]=DPD2BIN[(sourml>>8)&0x3ff]; \
+ (buf)[5]=DPD2BIN[(sourml>>18)&0x3ff]; \
+ sourmh=DFWORD(df, 1); \
+ (buf)[6]=DPD2BIN[((sourmh<<4) | (sourml>>28))&0x3ff]; \
+ (buf)[7]=DPD2BIN[(sourmh>>6)&0x3ff]; \
+ (buf)[8]=DPD2BIN[(sourmh>>16)&0x3ff]; \
+ sourhi=DFWORD(df, 0); \
+ (buf)[9]=DPD2BIN[((sourhi<<6) | (sourmh>>26))&0x3ff]; \
+ (buf)[10]=DPD2BIN[(sourhi>>4)&0x3ff]; \
+ (buf)[11]=DECCOMBMSD[sourhi>>26];}
+ #endif
+
+
+ /* Macros to decode the coefficient in a finite decFloat *df and */
+ /* add to a base-thousand uInt array (as for GETCOEFFTHOU). */
+ /* After the addition then most significant 'digit' in the array */
+ /* might have a value larger then 10 (with a maximum of 19). */
+ #if DECPMAX==7
+ #define ADDCOEFFTHOU(df, buf) { \
+ uInt sourhi=DFWORD(df, 0); \
+ (buf)[0]+=DPD2BIN[sourhi&0x3ff]; \
+ if (buf[0]>999) {buf[0]-=1000; buf[1]++;} \
+ (buf)[1]+=DPD2BIN[(sourhi>>10)&0x3ff]; \
+ if (buf[1]>999) {buf[1]-=1000; buf[2]++;} \
+ (buf)[2]+=DECCOMBMSD[sourhi>>26];}
+
+ #elif DECPMAX==16
+ #define ADDCOEFFTHOU(df, buf) { \
+ uInt sourhi, sourlo; \
+ sourlo=DFWORD(df, 1); \
+ (buf)[0]+=DPD2BIN[sourlo&0x3ff]; \
+ if (buf[0]>999) {buf[0]-=1000; buf[1]++;} \
+ (buf)[1]+=DPD2BIN[(sourlo>>10)&0x3ff]; \
+ if (buf[1]>999) {buf[1]-=1000; buf[2]++;} \
+ (buf)[2]+=DPD2BIN[(sourlo>>20)&0x3ff]; \
+ if (buf[2]>999) {buf[2]-=1000; buf[3]++;} \
+ sourhi=DFWORD(df, 0); \
+ (buf)[3]+=DPD2BIN[((sourhi<<2) | (sourlo>>30))&0x3ff]; \
+ if (buf[3]>999) {buf[3]-=1000; buf[4]++;} \
+ (buf)[4]+=DPD2BIN[(sourhi>>8)&0x3ff]; \
+ if (buf[4]>999) {buf[4]-=1000; buf[5]++;} \
+ (buf)[5]+=DECCOMBMSD[sourhi>>26];}
+
+ #elif DECPMAX==34
+ #define ADDCOEFFTHOU(df, buf) { \
+ uInt sourhi, sourmh, sourml, sourlo; \
+ sourlo=DFWORD(df, 3); \
+ (buf)[0]+=DPD2BIN[sourlo&0x3ff]; \
+ if (buf[0]>999) {buf[0]-=1000; buf[1]++;} \
+ (buf)[1]+=DPD2BIN[(sourlo>>10)&0x3ff]; \
+ if (buf[1]>999) {buf[1]-=1000; buf[2]++;} \
+ (buf)[2]+=DPD2BIN[(sourlo>>20)&0x3ff]; \
+ if (buf[2]>999) {buf[2]-=1000; buf[3]++;} \
+ sourml=DFWORD(df, 2); \
+ (buf)[3]+=DPD2BIN[((sourml<<2) | (sourlo>>30))&0x3ff]; \
+ if (buf[3]>999) {buf[3]-=1000; buf[4]++;} \
+ (buf)[4]+=DPD2BIN[(sourml>>8)&0x3ff]; \
+ if (buf[4]>999) {buf[4]-=1000; buf[5]++;} \
+ (buf)[5]+=DPD2BIN[(sourml>>18)&0x3ff]; \
+ if (buf[5]>999) {buf[5]-=1000; buf[6]++;} \
+ sourmh=DFWORD(df, 1); \
+ (buf)[6]+=DPD2BIN[((sourmh<<4) | (sourml>>28))&0x3ff]; \
+ if (buf[6]>999) {buf[6]-=1000; buf[7]++;} \
+ (buf)[7]+=DPD2BIN[(sourmh>>6)&0x3ff]; \
+ if (buf[7]>999) {buf[7]-=1000; buf[8]++;} \
+ (buf)[8]+=DPD2BIN[(sourmh>>16)&0x3ff]; \
+ if (buf[8]>999) {buf[8]-=1000; buf[9]++;} \
+ sourhi=DFWORD(df, 0); \
+ (buf)[9]+=DPD2BIN[((sourhi<<6) | (sourmh>>26))&0x3ff]; \
+ if (buf[9]>999) {buf[9]-=1000; buf[10]++;} \
+ (buf)[10]+=DPD2BIN[(sourhi>>4)&0x3ff]; \
+ if (buf[10]>999) {buf[10]-=1000; buf[11]++;} \
+ (buf)[11]+=DECCOMBMSD[sourhi>>26];}
+ #endif
+
+
+ /* Set a decFloat to the maximum positive finite number (Nmax) */
+ #if DECPMAX==7
+ #define DFSETNMAX(df) \
+ {DFWORD(df, 0)=0x77f3fcff;}
+ #elif DECPMAX==16
+ #define DFSETNMAX(df) \
+ {DFWORD(df, 0)=0x77fcff3f; \
+ DFWORD(df, 1)=0xcff3fcff;}
+ #elif DECPMAX==34
+ #define DFSETNMAX(df) \
+ {DFWORD(df, 0)=0x77ffcff3; \
+ DFWORD(df, 1)=0xfcff3fcf; \
+ DFWORD(df, 2)=0xf3fcff3f; \
+ DFWORD(df, 3)=0xcff3fcff;}
+ #endif
+
+ /* [end of format-dependent macros and constants] */
+ #endif
+
+#else
+ #error decNumberLocal included more than once
+#endif
diff --git a/Build/source/texk/web2c/mplibdir/dvitomp.test b/Build/source/texk/web2c/mplibdir/dvitomp.test
new file mode 100755
index 00000000000..41ccb942bd5
--- /dev/null
+++ b/Build/source/texk/web2c/mplibdir/dvitomp.test
@@ -0,0 +1,21 @@
+#! /bin/sh -vx
+# Copyright 2017 Karl Berry <tex-live@tug.org>
+# Copyright 2009-2012 Peter Breitenlohner <tex-live@tug.org>
+# You may freely use, modify and/or distribute this file.
+
+test -d tests || mkdir -p tests
+
+if tfmpath=`$KPSEWHICH cmbx10.tfm`; then
+
+ TEXMFCNF=$srcdir/../kpathsea \
+ TFMFONTS=`dirname "$tfmpath"` \
+ ./mpost --dvitomp $srcdir/tests/story.dvi tests/xstory.mpx || exit 1
+
+fi
+
+TEXMFCNF=$srcdir/../kpathsea \
+ TFMFONTS=$srcdir/tests \
+ VFFONTS=$srcdir/tests: \
+ ./mpost --dvitomp $srcdir/tests/ptmr ptmr.mpx && \
+ mv ptmr.mpx tests/xptmr.mpx || exit 1
+
diff --git a/Build/source/texk/web2c/mplibdir/lmplib.c b/Build/source/texk/web2c/mplibdir/lmplib.c
new file mode 100644
index 00000000000..59b747c66dd
--- /dev/null
+++ b/Build/source/texk/web2c/mplibdir/lmplib.c
@@ -0,0 +1,2060 @@
+/* lmplib.c
+
+ Copyright 2012 Taco Hoekwater <taco@luatex.org>
+
+ This file is part of the MetaPost tarball, but belongs to LuaTeX.
+
+ LuaTeX is free software; you can redistribute it and/or modify it under
+ the terms of the GNU Lesser General Public License as published by the Free
+ Software Foundation; either version 3 of the License, or (at your
+ option) any later version.
+
+ LuaTeX is distributed in the hope that it will be useful, but WITHOUT
+ ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
+ FITNESS FOR A PARTICULAR PURPOSE. See the GNU Lesser General Public
+ License for more details.
+
+ You should have received a copy of the GNU Lesser General Public License along
+ with LuaTeX; if not, see <http://www.gnu.org/licenses/>.
+
+*/
+
+#include <w2c/config.h>
+#include <stdlib.h>
+#include <string.h>
+#ifdef HAVE_UNISTD_H
+#include <unistd.h>
+#endif
+#include <math.h>
+
+#ifndef pdfTeX
+# include <lua.h>
+# include <lauxlib.h>
+# include <lualib.h>
+#else
+# include "lua.h"
+# include "lauxlib.h"
+# include "lualib.h"
+#define luaL_reg luaL_Reg
+#define lua_objlen lua_rawlen
+#endif
+
+#ifndef luaL_reg
+#define luaL_reg luaL_Reg
+#endif
+
+#ifndef lua_objlen
+#define lua_objlen lua_rawlen
+#endif
+
+#include "mplib.h"
+#include "mplibps.h"
+#include "mplibsvg.h"
+#include "mplibpng.h"
+
+int luaopen_mplib(lua_State * L);
+
+/*tex
+
+ We need a few metatable identifiers in order to access the metatables for the
+ main object and result userdata.
+
+*/
+
+#define MPLIB_METATABLE "MPlib.meta"
+#define MPLIB_FIG_METATABLE "MPlib.fig"
+#define MPLIB_GR_METATABLE "MPlib.gr"
+
+#define is_mp(L,b) (MP *)luaL_checkudata(L,b,MPLIB_METATABLE)
+#define is_fig(L,b) (struct mp_edge_object **)luaL_checkudata(L,b,MPLIB_FIG_METATABLE)
+#define is_gr_object(L,b) (struct mp_graphic_object **)luaL_checkudata(L,b,MPLIB_GR_METATABLE)
+
+/*tex
+
+ We pre-hash the \LUA\ strings which is much faster. The approach is similar to the one
+ used at the \TEX\ end.
+
+*/
+
+#define mplib_init_S(a) do { \
+ lua_pushliteral(L,#a); \
+ mplib_##a##_ptr = lua_tostring(L,-1); \
+ mplib_##a##_index = luaL_ref (L,LUA_REGISTRYINDEX); \
+} while (0)
+
+#define mplib_push_S(a) do { \
+ lua_rawgeti(L,LUA_REGISTRYINDEX,mplib_##a##_index); \
+} while (0)
+
+#define mplib_is_S(a,i) \
+ (mplib_##a##_ptr==lua_tostring(L,i))
+
+#define mplib_make_S(a) \
+ static int mplib_##a##_index = 0; \
+ static const char *mplib_##a##_ptr = NULL
+
+/*tex In the next array entry 0 is not used */
+
+static int mplib_type_Ses[mp_special_code + 1] = { 0 };
+
+mplib_make_S(term);
+mplib_make_S(error);
+mplib_make_S(log);
+mplib_make_S(fig);
+mplib_make_S(status);
+
+mplib_make_S(memory);
+mplib_make_S(hash);
+mplib_make_S(params);
+mplib_make_S(open);
+mplib_make_S(cycle);
+
+mplib_make_S(offset);
+mplib_make_S(dashes);
+
+mplib_make_S(fill);
+mplib_make_S(outline);
+mplib_make_S(text);
+mplib_make_S(special);
+mplib_make_S(start_bounds);
+mplib_make_S(stop_bounds);
+mplib_make_S(start_clip);
+mplib_make_S(stop_clip);
+
+mplib_make_S(left_type);
+mplib_make_S(right_type);
+mplib_make_S(x_coord);
+mplib_make_S(y_coord);
+mplib_make_S(left_x);
+mplib_make_S(left_y);
+mplib_make_S(right_x);
+mplib_make_S(right_y);
+mplib_make_S(left_tension);
+mplib_make_S(right_tension);
+mplib_make_S(left_curl);
+mplib_make_S(right_curl);
+mplib_make_S(direction_x);
+mplib_make_S(direction_y);
+
+mplib_make_S(color);
+mplib_make_S(dash);
+mplib_make_S(depth);
+mplib_make_S(dsize);
+mplib_make_S(font);
+mplib_make_S(height);
+mplib_make_S(htap);
+mplib_make_S(linecap);
+mplib_make_S(linejoin);
+mplib_make_S(miterlimit);
+mplib_make_S(path);
+mplib_make_S(pen);
+mplib_make_S(postscript);
+mplib_make_S(prescript);
+mplib_make_S(transform);
+mplib_make_S(type);
+mplib_make_S(width);
+mplib_make_S(elliptical);
+
+static void mplib_init_Ses(lua_State * L)
+{
+ mplib_init_S(term);
+ mplib_init_S(error);
+ mplib_init_S(log);
+ mplib_init_S(fig);
+ mplib_init_S(status);
+
+ mplib_init_S(memory);
+ mplib_init_S(hash);
+ mplib_init_S(params);
+ mplib_init_S(open);
+ mplib_init_S(cycle);
+
+ mplib_init_S(offset);
+ mplib_init_S(dashes);
+
+ mplib_init_S(fill);
+ mplib_init_S(outline);
+ mplib_init_S(text);
+ mplib_init_S(start_bounds);
+ mplib_init_S(stop_bounds);
+ mplib_init_S(start_clip);
+ mplib_init_S(stop_clip);
+ mplib_init_S(special);
+
+ mplib_type_Ses[mp_fill_code] = mplib_fill_index;
+ mplib_type_Ses[mp_stroked_code] = mplib_outline_index;
+ mplib_type_Ses[mp_text_code] = mplib_text_index;
+ mplib_type_Ses[mp_start_bounds_code] = mplib_start_bounds_index;
+ mplib_type_Ses[mp_stop_bounds_code] = mplib_stop_bounds_index;
+ mplib_type_Ses[mp_start_clip_code] = mplib_start_clip_index;
+ mplib_type_Ses[mp_stop_clip_code] = mplib_stop_clip_index;
+ mplib_type_Ses[mp_special_code] = mplib_special_index;
+
+ mplib_init_S(left_type);
+ mplib_init_S(right_type);
+ mplib_init_S(x_coord);
+ mplib_init_S(y_coord);
+ mplib_init_S(left_x);
+ mplib_init_S(left_y);
+ mplib_init_S(right_x);
+ mplib_init_S(right_y);
+ mplib_init_S(left_tension);
+ mplib_init_S(right_tension);
+ mplib_init_S(left_curl);
+ mplib_init_S(right_curl);
+ mplib_init_S(direction_x);
+ mplib_init_S(direction_y);
+
+ mplib_init_S(color);
+ mplib_init_S(dash);
+ mplib_init_S(depth);
+ mplib_init_S(dsize);
+ mplib_init_S(font);
+ mplib_init_S(height);
+ mplib_init_S(htap);
+ mplib_init_S(linecap);
+ mplib_init_S(linejoin);
+ mplib_init_S(miterlimit);
+ mplib_init_S(path);
+ mplib_init_S(pen);
+ mplib_init_S(postscript);
+ mplib_init_S(prescript);
+ mplib_init_S(transform);
+ mplib_init_S(type);
+ mplib_init_S(width);
+ mplib_init_S(elliptical);
+}
+
+/*tex
+
+ Here are some enumeration arrays to map MPlib enums to \LUA\ strings. If needed
+ we can also predefine keys here, as we do with nodes.
+
+*/
+
+static const char *math_options[] =
+ { "scaled", "double", "binary", "decimal", NULL };
+
+static const char *interaction_options[] =
+ { "unknown", "batch", "nonstop", "scroll", "errorstop", NULL };
+
+static const char *mplib_filetype_names[] =
+ { "term", "error", "mp", "log", "ps", "png", "mem", "tfm", "map", "pfb", "enc", NULL };
+
+static const char *knot_type_enum[] =
+ { "endpoint", "explicit", "given", "curl", "open", "end_cycle" };
+
+static const char *fill_fields[] =
+ { "type", "path", "htap", "pen", "color", "linejoin", "miterlimit",
+ "prescript", "postscript", NULL };
+
+static const char *stroked_fields[] =
+ { "type", "path", "pen", "color", "linejoin", "miterlimit", "linecap",
+ "dash", "prescript", "postscript", NULL };
+
+static const char *text_fields[] =
+ { "type", "text", "dsize", "font", "color", "width", "height", "depth",
+ "transform", "prescript", "postscript", NULL };
+
+static const char *special_fields[] =
+ { "type", "prescript", NULL };
+
+static const char *start_bounds_fields[] =
+ { "type", "path", NULL };
+
+static const char *start_clip_fields[] =
+ { "type", "path", NULL };
+
+static const char *stop_bounds_fields[] =
+ { "type", NULL };
+
+static const char *stop_clip_fields[] =
+ { "type", NULL };
+
+static const char *no_fields[] =
+ { NULL };
+
+/*tex
+
+ The list of supported MPlib options (not all make sense).
+
+*/
+
+typedef enum {
+ P_ERROR_LINE,
+ P_MAX_LINE,
+ P_RANDOM_SEED,
+ P_MATH_MODE,
+ P_INTERACTION,
+ P_INI_VERSION,
+ P_MEM_NAME,
+ P_JOB_NAME,
+ P_FIND_FILE,
+ P_RUN_SCRIPT,
+ P_MAKE_TEXT,
+ P_SCRIPT_ERROR,
+ P_EXTENSIONS,
+ P_UTF8_MODE,
+ P__SENTINEL
+} mplib_parm_idx;
+
+typedef struct {
+ /*tex parameter name */
+ const char *name;
+ /*tex parameter index */
+ mplib_parm_idx idx;
+} mplib_parm_struct;
+
+static mplib_parm_struct mplib_parms[] = {
+ {"error_line", P_ERROR_LINE },
+ {"print_line", P_MAX_LINE },
+ {"random_seed", P_RANDOM_SEED },
+ {"interaction", P_INTERACTION },
+ {"job_name", P_JOB_NAME },
+ {"find_file", P_FIND_FILE },
+ {"run_script", P_RUN_SCRIPT },
+ {"make_text", P_MAKE_TEXT },
+ {"script_error", P_SCRIPT_ERROR },
+ {"extensions", P_EXTENSIONS },
+ {"math_mode", P_MATH_MODE },
+ {"utf8_mode", P_UTF8_MODE },
+ {NULL, P__SENTINEL }
+};
+
+/*tex
+
+ We start by defining the needed callback routines for the library.
+
+*/
+
+static char *mplib_find_file(MP mp, const char *fname, const char *fmode, int ftype)
+{
+ lua_State *L = (lua_State *)mp_userdata(mp);
+ lua_checkstack(L, 4);
+ lua_getfield(L, LUA_REGISTRYINDEX, "mplib.file_finder");
+ if (lua_isfunction(L, -1)) {
+ char *s = NULL;
+ const char *x = NULL;
+ lua_pushstring(L, fname);
+ lua_pushstring(L, fmode);
+ if (ftype >= mp_filetype_text) {
+ lua_pushinteger(L, (ftype - mp_filetype_text));
+ } else {
+ lua_pushstring(L, mplib_filetype_names[ftype]);
+ }
+ if (lua_pcall(L, 3, 1, 0) != 0) {
+ fprintf(stdout, "Error in mp.find_file: %s\n", lua_tostring(L, -1));
+ return NULL;
+ }
+ x = lua_tostring(L, -1);
+ if (x != NULL)
+ s = strdup(x);
+ /*tex pop the string */
+ lua_pop(L, 1);
+ return s;
+ } else {
+ lua_pop(L, 1);
+ }
+ if (fmode[0] != 'r' || (!access(fname, R_OK)) || ftype) {
+ return strdup(fname);
+ }
+ return NULL;
+}
+
+static int mplib_find_file_function(lua_State * L)
+{
+ if (!(lua_isfunction(L, -1) || lua_isnil(L, -1))) {
+ /*tex An error. */
+ return 1;
+ }
+ lua_pushstring(L, "mplib.file_finder");
+ lua_pushvalue(L, -2);
+ lua_rawset(L, LUA_REGISTRYINDEX);
+ return 0;
+}
+
+static void mplib_warning(const char *str)
+{
+ fprintf(stdout,"mplib warning: %s\n",str);
+}
+
+static void mplib_script_error(MP mp, const char *str)
+{
+ lua_State *L = (lua_State *)mp_userdata(mp);
+ lua_checkstack(L, 1);
+ lua_getfield(L, LUA_REGISTRYINDEX, "mplib.script_error");
+ if (lua_isfunction(L, -1)) {
+ lua_pushstring(L, str);
+ /*tex We assume that the function is okay. */
+ lua_pcall(L, 1, 0, 0);
+ } else {
+ mplib_warning(str);
+ lua_pop(L, 1);
+ }
+}
+
+static int mplib_script_error_function(lua_State * L)
+{
+ if (!(lua_isfunction(L, -1) || lua_isnil(L, -1))) {
+ /*tex An error. */
+ return 1;
+ }
+ lua_pushstring(L, "mplib.script_error");
+ lua_pushvalue(L, -2);
+ lua_rawset(L, LUA_REGISTRYINDEX);
+ return 0;
+}
+
+static char *mplib_run_script(MP mp, const char *str)
+{
+ lua_State *L = (lua_State *)mp_userdata(mp);
+ lua_checkstack(L, 1);
+ lua_getfield(L, LUA_REGISTRYINDEX, "mplib.run_script");
+ if (lua_isfunction(L, -1)) {
+ char *s = NULL;
+ const char *x = NULL;
+ lua_pushstring(L, str);
+ if (lua_pcall(L, 1, 1, 0) != 0) {
+ fprintf(stdout,"mplib warning: error in script: %s\n",lua_tostring(L, -1));
+ return NULL;
+ }
+ x = lua_tostring(L, -1);
+ if (x != NULL)
+ s = strdup(x);
+ /*tex Pop the string. */
+ lua_pop(L, 1);
+ return s;
+ } else {
+ lua_pop(L, 1);
+ }
+ return NULL;
+}
+
+static int mplib_run_script_function(lua_State * L)
+{
+ if (!(lua_isfunction(L, -1) || lua_isnil(L, -1))) {
+ return 1; /* error */
+ }
+ lua_pushstring(L, "mplib.run_script");
+ lua_pushvalue(L, -2);
+ lua_rawset(L, LUA_REGISTRYINDEX);
+ return 0;
+}
+
+static char *mplib_make_text(MP mp, const char *str, int mode)
+{
+ lua_State *L = (lua_State *)mp_userdata(mp);
+ lua_checkstack(L, 1);
+ lua_getfield(L, LUA_REGISTRYINDEX, "mplib.make_text");
+ if (lua_isfunction(L, -1)) {
+ char *s = NULL;
+ const char *x = NULL;
+ lua_pushstring(L, str);
+ lua_pushinteger(L, mode);
+ if (lua_pcall(L, 2, 1, 0) != 0) {
+ mplib_script_error(mp, lua_tostring(L, -1));
+ return NULL;
+ }
+ x = lua_tostring(L, -1);
+ if (x != NULL)
+ s = strdup(x);
+ /*tex Pop the string. */
+ lua_pop(L, 1);
+ return s;
+ } else {
+ lua_pop(L, 1);
+ }
+ return NULL;
+}
+
+static int mplib_make_text_function(lua_State * L)
+{
+ if (!(lua_isfunction(L, -1) || lua_isnil(L, -1))) {
+ /*tex An error. */
+ return 1;
+ }
+ lua_pushstring(L, "mplib.make_text");
+ lua_pushvalue(L, -2);
+ lua_rawset(L, LUA_REGISTRYINDEX);
+ return 0;
+}
+
+static int mplib_get_numeric(lua_State * L)
+{
+ MP *mp = is_mp(L, 1);
+ if (*mp != NULL) {
+ size_t l;
+ const char *s = lua_tolstring(L, 2, &l);
+ if (s != NULL) {
+ lua_pushnumber(L, mp_get_numeric_value(*mp,s,l));
+ return 1;
+ }
+ }
+ lua_pushnumber(L,0);
+ return 1;
+}
+
+static int mplib_get_boolean(lua_State * L)
+{
+ MP *mp = is_mp(L, 1);
+ if (*mp != NULL) {
+ size_t l;
+ const char *s = lua_tolstring(L, 2, &l);
+ if (s != NULL) {
+ lua_pushboolean(L, mp_get_boolean_value(*mp,s,l));
+ return 1;
+ }
+ }
+ lua_pushboolean(L,0);
+ return 1;
+}
+
+static int mplib_get_string(lua_State * L)
+{
+ MP *mp = is_mp(L, 1);
+ if (*mp != NULL) {
+ size_t l;
+ const char *s = lua_tolstring(L, 2, &l);
+ if (s != NULL) {
+ char *r = mp_get_string_value(*mp,s,l) ;
+ if (r != NULL) {
+ lua_pushstring(L, r);
+ return 1;
+ }
+ }
+ }
+ lua_pushstring(L,"");
+ return 1;
+}
+
+#define xfree(A) if ((A)!=NULL) { free((A)); A = NULL; }
+
+static int mplib_new(lua_State * L)
+{
+ MP *mp_ptr;
+ mp_ptr = lua_newuserdata(L, sizeof(MP *));
+ if (mp_ptr) {
+ int i;
+ struct MP_options *options = mp_options();
+ options->userdata = (void *) L;
+ /*tex Required: */
+ options->noninteractive = 1;
+ options->extensions = 0 ;
+ options->find_file = mplib_find_file;
+ options->run_script = mplib_run_script;
+ options->make_text = mplib_make_text;
+ /* options->script_error = mplib_script_error; */
+ options->print_found_names = 1;
+ options->ini_version = 1;
+ options->utf8_mode = 0;
+ if (lua_type(L, 1) == LUA_TTABLE) {
+ for (i = 0; mplib_parms[i].name != NULL; i++) {
+ lua_getfield(L, 1, mplib_parms[i].name);
+ if (lua_isnil(L, -1)) {
+ lua_pop(L, 1);
+ continue;
+ }
+ switch (mplib_parms[i].idx) {
+ case P_ERROR_LINE:
+ options->error_line = (int)lua_tointeger(L, -1);
+ if (options->error_line < 60)
+ options->error_line = 60;
+ if (options->error_line > 250)
+ options->error_line = 250;
+ options->half_error_line = (options->error_line/2)+10;
+ break;
+ case P_MAX_LINE:
+ options->max_print_line = (int)lua_tointeger(L, -1);
+ if (options->max_print_line < 60)
+ options->max_print_line = 60;
+ break;
+ case P_RANDOM_SEED:
+ options->random_seed = (int)lua_tointeger(L, -1);
+ break;
+ case P_INTERACTION:
+ options->interaction = luaL_checkoption(L, -1, "errorstopmode", interaction_options);
+ break;
+ case P_MATH_MODE:
+ options->math_mode = luaL_checkoption(L, -1, "scaled", math_options);
+ break;
+ case P_JOB_NAME:
+ options->job_name = strdup(lua_tostring(L, -1));
+ break;
+ case P_FIND_FILE:
+ if (mplib_find_file_function(L)) {
+ mplib_warning("function expected for 'find_file'");
+ }
+ break;
+ case P_RUN_SCRIPT:
+ if (mplib_run_script_function(L)) {
+ mplib_warning("function expected for 'run_script'");
+ }
+ break;
+ case P_MAKE_TEXT:
+ if (mplib_make_text_function(L)) {
+ mplib_warning("function expected for 'make_text'");
+ }
+ break;
+ case P_SCRIPT_ERROR:
+ if (mplib_script_error_function(L)) {
+ mplib_warning("function expected for 'script_error'");
+ }
+ break;
+ case P_EXTENSIONS:
+ options->extensions = (int)lua_tointeger(L, -1);
+ break;
+ case P_UTF8_MODE:
+ options->utf8_mode = (int)lua_toboolean(L, -1);
+ break;
+ default:
+ break;
+ }
+ lua_pop(L, 1);
+ }
+ }
+ *mp_ptr = mp_initialize(options);
+ xfree(options->command_line);
+ xfree(options->mem_name);
+ free(options);
+ if (*mp_ptr) {
+ luaL_getmetatable(L, MPLIB_METATABLE);
+ lua_setmetatable(L, -2);
+ return 1;
+ }
+ }
+ lua_pushnil(L);
+ return 1;
+}
+
+static int mplib_collect(lua_State * L)
+{
+ MP *mp_ptr = is_mp(L, 1);
+ if (*mp_ptr != NULL) {
+ (void)mp_finish(*mp_ptr);
+ *mp_ptr = NULL;
+ }
+ return 0;
+}
+
+static int mplib_tostring(lua_State * L)
+{
+ MP *mp_ptr = is_mp(L, 1);
+ if (*mp_ptr != NULL) {
+ (void) lua_pushfstring(L, "<MP %p>", *mp_ptr);
+ return 1;
+ }
+ return 0;
+}
+
+static int mplib_wrapresults(lua_State * L, mp_run_data *res, int status)
+{
+ lua_checkstack(L, 5);
+ lua_newtable(L);
+ if (res->term_out.used != 0) {
+ mplib_push_S(term);
+ lua_pushlstring(L, res->term_out.data, res->term_out.used);
+ lua_rawset(L,-3);
+ }
+ if (res->error_out.used != 0) {
+ mplib_push_S(error);
+ lua_pushlstring(L, res->error_out.data, res->error_out.used);
+ lua_rawset(L,-3);
+ }
+ if (res->log_out.used != 0) {
+ mplib_push_S(log);
+ lua_pushlstring(L, res->log_out.data, res->log_out.used);
+ lua_rawset(L,-3);
+ }
+ if (res->edges != NULL) {
+ struct mp_edge_object **v;
+ struct mp_edge_object *p = res->edges;
+ int i = 1;
+ mplib_push_S(fig);
+ lua_newtable(L);
+ while (p != NULL) {
+ v = lua_newuserdata(L, sizeof(struct mp_edge_object *));
+ *v = p;
+ luaL_getmetatable(L, MPLIB_FIG_METATABLE);
+ lua_setmetatable(L, -2);
+ lua_rawseti(L, -2, i);
+ i++;
+ p = p->next;
+ }
+ lua_rawset(L,-3);
+ res->edges = NULL;
+ }
+ mplib_push_S(status);
+ lua_pushinteger(L, status);
+ lua_rawset(L,-3);
+ return 1;
+}
+
+static int mplib_execute(lua_State * L)
+{
+ MP *mp_ptr;
+ if (lua_gettop(L)!=2) {
+ lua_pushnil(L);
+ return 1;
+ }
+ mp_ptr = is_mp(L, 1);
+ if (*mp_ptr != NULL && lua_isstring(L, 2)) {
+ size_t l;
+ char *s = xstrdup(lua_tolstring(L, 2, &l));
+ int h = mp_execute(*mp_ptr, s, l);
+ mp_run_data *res = mp_rundata(*mp_ptr);
+ free(s);
+ return mplib_wrapresults(L, res, h);
+ } else {
+ lua_pushnil(L);
+ }
+ return 1;
+}
+
+static int mplib_finish(lua_State * L)
+{
+ MP *mp_ptr = is_mp(L, 1);
+ if (*mp_ptr != NULL) {
+ int i;
+ int h = mp_execute(*mp_ptr,NULL,0);
+ mp_run_data *res = mp_rundata(*mp_ptr);
+ i = mplib_wrapresults(L, res, h);
+ (void)mp_finish(*mp_ptr);
+ *mp_ptr = NULL;
+ return i;
+ } else {
+ lua_pushnil(L);
+ }
+ return 1;
+}
+
+static int mplib_char_dimension(lua_State * L, int t)
+{
+ MP *mp_ptr = is_mp(L, 1);
+ if (*mp_ptr != NULL) {
+ char *fname = xstrdup(luaL_checkstring(L,2));
+ int charnum = (int)luaL_checkinteger(L,3);
+ if (charnum<0 || charnum>255) {
+ lua_pushnumber(L, (lua_Number)0);
+ } else {
+ lua_pushnumber(L,(lua_Number)mp_get_char_dimension(*mp_ptr,fname,charnum,t));
+ }
+ free(fname);
+ } else {
+ lua_pushnumber(L, (lua_Number)0);
+ }
+ return 1;
+}
+
+static int mplib_charwidth(lua_State * L)
+{
+ return mplib_char_dimension(L, 'w');
+}
+
+static int mplib_chardepth(lua_State * L)
+{
+ return mplib_char_dimension(L, 'd');
+}
+
+static int mplib_charheight(lua_State * L)
+{
+ return mplib_char_dimension(L, 'h');
+}
+
+static int mplib_version(lua_State * L)
+{
+ char *s = mp_metapost_version();
+ lua_pushstring(L, s);
+ free(s);
+ return 1;
+}
+
+static int mplib_statistics(lua_State * L)
+{
+ MP *mp_ptr = is_mp(L, 1);
+ if (*mp_ptr != NULL) {
+ lua_newtable(L);
+ mplib_push_S(memory);
+ lua_pushinteger(L, mp_memory_usage(*mp_ptr));
+ lua_rawset(L,-3);
+ mplib_push_S(hash);
+ lua_pushinteger(L, mp_hash_usage(*mp_ptr));
+ lua_rawset(L,-3);
+ mplib_push_S(params);
+ lua_pushinteger(L, mp_param_usage(*mp_ptr));
+ lua_rawset(L,-3);
+ mplib_push_S(open);
+ lua_pushinteger(L, mp_open_usage(*mp_ptr));
+ lua_rawset(L,-3);
+ } else {
+ lua_pushnil(L);
+ }
+ return 1;
+}
+
+static int set_direction (lua_State * L, MP mp, mp_knot p) {
+ double direction_x = 0, direction_y = 0;
+ direction_x = (double)lua_tonumber(L,-1);
+ lua_pop(L,1);
+ mplib_push_S(direction_y);
+ lua_rawget(L,-2);
+ if (!lua_isnumber(L,-1)) {
+ return 0;
+ }
+ direction_y = (double)lua_tonumber(L,-1);
+ lua_pop(L,1);
+ if (!mp_set_knot_direction(mp, p, direction_x, direction_y)) {
+ return 0;
+ }
+ return 1;
+}
+
+static int set_left_curl (lua_State * L, MP mp, mp_knot p) {
+ double curl = (double)lua_tonumber(L,-1);
+ lua_pop(L,1);
+ if (!mp_set_knot_left_curl(mp, p, curl)) {
+ return 0;
+ }
+ return 1;
+}
+
+static int set_left_tension (lua_State * L, MP mp, mp_knot p) {
+ double tension = (double)lua_tonumber(L,-1);
+ lua_pop(L,1);
+ if (!mp_set_knot_left_tension(mp, p, tension)) {
+ return 0;
+ }
+ return 1;
+}
+
+static int set_left_control (lua_State * L, MP mp, mp_knot p) {
+ double x, y;
+ x = (double)lua_tonumber(L,-1);
+ lua_pop(L,1);
+ mplib_push_S(left_y);
+ lua_rawget(L,-2);
+ if (!lua_isnumber(L,-1)) {
+ return 0;
+ }
+ y = (double)lua_tonumber(L,-1);
+ lua_pop(L,1);
+ if (!mp_set_knot_left_control(mp, p, x, y)) {
+ return 0;
+ }
+ return 1;
+}
+
+static int set_right_curl (lua_State * L, MP mp, mp_knot p) {
+ double curl = (double)lua_tonumber(L,-1);
+ lua_pop(L,1);
+ if (!mp_set_knot_right_curl(mp, p, curl)) {
+ return 0;
+ }
+ return 1;
+}
+
+static int set_right_tension (lua_State * L, MP mp, mp_knot p) {
+ double tension = (double)lua_tonumber(L,-1);
+ lua_pop(L,1);
+ if (!mp_set_knot_right_tension(mp, p, tension)) {
+ return 0;
+ }
+ return 1;
+}
+
+static int set_right_control (lua_State * L, MP mp, mp_knot p) {
+ double x, y;
+ x = (double)lua_tonumber(L,-1);
+ lua_pop(L,1);
+ mplib_push_S(right_y);
+ lua_rawget(L,-2);
+ if (!lua_isnumber(L,-1)) {
+ return 0;
+ }
+ y = (double)lua_tonumber(L,-1);
+ lua_pop(L,1);
+ if (!mp_set_knot_right_control(mp, p, x, y)) {
+ return 0;
+ }
+ return 1;
+}
+
+#if 0
+
+#define ROUNDED_ZERO(v) (fabs((v))<0.00001 ? 0 : (v))
+#define PI 3.1415926535897932384626433832795028841971
+#define RADIANS(a) (mp_number_as_double(mp,(a)) / 16.0) * PI/180.0
+
+void mp_dump_path (MP mp, mp_knot h) {
+ mp_knot p, q;
+ if (h == NULL)
+ return;
+ p = h;
+ do {
+ q=mp_knot_next(mp,p);
+ if ( (p==NULL)||(q==NULL) ) {
+ printf("\n???");
+ return; /* this won't happen */
+ }
+ printf ("(%g,%g)", mp_number_as_double(mp,mp_knot_x_coord(mp,p)),
+ mp_number_as_double(mp,mp_knot_y_coord(mp,p)));
+ switch (mp_knot_right_type(mp,p)) {
+ case mp_endpoint:
+ if ( mp_knot_left_type(mp,p)==mp_open )
+ printf("{open?}");
+ if ( (mp_knot_left_type(mp,q)!=mp_endpoint)||(q!=h) )
+ q=NULL; /* force an error */
+ goto DONE;
+ break;
+ case mp_explicit:
+ printf ("..controls (%g,%g)",
+ mp_number_as_double(mp,mp_knot_right_x(mp,p)),
+ mp_number_as_double(mp,mp_knot_right_y(mp,p)));
+ printf(" and ");
+ if ( mp_knot_left_type(mp,q)!=mp_explicit ) {
+ printf("??");
+ } else {
+ printf ("(%g,%g)",mp_number_as_double(mp,mp_knot_left_x(mp,q)),
+ mp_number_as_double(mp,mp_knot_left_y(mp,q)));
+ }
+ goto DONE;
+ break;
+ case mp_open:
+ if ( (mp_knot_left_type(mp,p)!=mp_explicit) &&
+ (mp_knot_left_type(mp,p)!=mp_open) ) {
+ printf("{open?}");
+ }
+ break;
+ case mp_curl:
+ case mp_given:
+ if ( mp_knot_left_type(mp,p)==mp_open )
+ printf("??");
+ if ( mp_knot_right_type(mp,p)==mp_curl ) {
+ printf("{curl %g}", mp_number_as_double(mp,mp_knot_right_curl(mp,p)));
+ } else {
+ double rad = RADIANS(mp_knot_right_curl(mp,p));
+ double n_cos = ROUNDED_ZERO(cos(rad)*4096);
+ double n_sin = ROUNDED_ZERO(sin(rad)*4096);
+ printf("{%g,%g}", n_cos, n_sin);
+ }
+ break;
+ }
+ if ( mp_knot_left_type(mp,q)<=mp_explicit ) {
+ printf("..control?"); /* can't happen */
+ } else if ((mp_number_as_double(mp,mp_knot_right_tension(mp,p))!=(1.0))||
+ (mp_number_as_double(mp,mp_knot_left_tension(mp,q)) !=(1.0))) {
+ printf("..tension ");
+ if ( mp_number_as_double(mp,mp_knot_right_tension(mp,p))<0.0 )
+ printf("atleast ");
+ printf("%g", fabs(mp_number_as_double(mp,mp_knot_right_tension(mp,p))));
+ if (mp_number_as_double(mp,mp_knot_right_tension(mp,p)) !=
+ mp_number_as_double(mp,mp_knot_left_tension(mp,q))) {
+ printf(" and ");
+ if (mp_number_as_double(mp,mp_knot_left_tension(mp,q))< 0.0)
+ printf("atleast ");
+ printf("%g", fabs(mp_number_as_double(mp,mp_knot_left_tension(mp,q))));
+ }
+ }
+ DONE:
+ p=q;
+ if ( p!=h || mp_knot_left_type(mp,h)!=mp_endpoint) {
+ printf ("\n ..");
+ if ( mp_knot_left_type(mp,p) == mp_given ) {
+ double rad = RADIANS(mp_knot_left_curl(mp,p));
+ double n_cos = ROUNDED_ZERO(cos(rad)*4096);
+ double n_sin = ROUNDED_ZERO(sin(rad)*4096);
+ printf("{%g,%g}", n_cos, n_sin);
+ } else if ( mp_knot_left_type(mp,p) ==mp_curl ){
+ printf("{curl %g}", mp_number_as_double(mp,mp_knot_left_curl(mp,p)));
+ }
+ }
+ } while (p!=h);
+ if ( mp_knot_left_type(mp,h)!=mp_endpoint )
+ printf("cycle");
+ printf (";\n");
+}
+
+#endif
+
+static int mplib_solve_path(lua_State * L)
+{
+ MP *mp_ptr;
+ MP mp = NULL;
+ int cyclic;
+ const char *errormsg = NULL;
+ mp_knot p, q, first;
+ int numpoints, i;
+ p = q = first = NULL;
+ if (lua_gettop(L) != 3) {
+ errormsg = "Wrong number of arguments";
+ goto BAD;
+ }
+ mp_ptr = is_mp(L, 1);
+ if (*mp_ptr == NULL || (!lua_istable(L,2)) || lua_objlen(L,2)<=0 || (!lua_isboolean(L,3))) {
+ errormsg = "Wrong argument types";
+ goto BAD;
+ }
+ mp = *mp_ptr;
+ cyclic = lua_toboolean(L,3);
+ lua_pop(L,1);
+ /*tex We build up the path. */
+ numpoints = lua_objlen(L,2);
+ first = p = NULL;
+ for (i=1;i<=numpoints;i++) {
+ int left_set = 0, right_set = 0;
+ double x_coord, y_coord;
+ lua_rawgeti(L,-1,i);
+ if (!lua_istable(L,-1)) {
+ errormsg = "Wrong argument types";
+ goto BAD;
+ }
+ mplib_push_S(x_coord);
+ lua_rawget(L,-2);
+ if (!lua_isnumber(L,-1)) {
+ errormsg = "Missing X coordinate";
+ goto BAD;
+ }
+ x_coord = (double)lua_tonumber(L,-1);
+ lua_pop(L,1);
+ mplib_push_S(y_coord);
+ lua_rawget(L,-2);
+ if (!lua_isnumber(L,-1)) {
+ errormsg = "Missing y coordinate";
+ goto BAD;
+ }
+ y_coord = (double)lua_tonumber(L,-1);
+ lua_pop(L,1);
+ q = p;
+ if (q!=NULL) {
+ /*tex
+
+ We have to save the right_tension because |mp_append_knot|
+ trashes it, believing that it is as yet uninitialized.
+
+ */
+ double saved_tension = mp_number_as_double(mp, mp_knot_right_tension(mp,p));
+ p = mp_append_knot(mp, p, x_coord, y_coord);
+ if ( ! p ) {
+ errormsg = "knot creation failure";
+ goto BAD;
+ }
+ (void)mp_set_knot_right_tension(mp, q, saved_tension);
+ } else {
+ p = mp_append_knot(mp, p, x_coord, y_coord);
+ if ( ! p ) {
+ errormsg = "knot creation failure";
+ goto BAD;
+ }
+ }
+ if (first == NULL)
+ first = p;
+ mplib_push_S(left_curl);
+ lua_rawget(L,-2);
+ if (lua_isnumber(L,-1)) {
+ if (!set_left_curl (L, mp, p)) {
+ errormsg = "failed to set left curl";
+ goto BAD;
+ }
+ left_set = 1;
+ } else {
+ /*tex A |nil| value. */
+ lua_pop(L,1);
+ }
+ mplib_push_S(left_tension);
+ lua_rawget(L,-2);
+ if (lua_isnumber(L,-1)) {
+ if (left_set) {
+ errormsg = "Left side already set";
+ goto BAD;
+ } else {
+ if (!set_left_tension(L, mp, p)) {
+ errormsg = "Failed to set left tension";
+ goto BAD;
+ }
+ left_set = 1;
+ }
+ } else {
+ /*tex A |nil| value. */
+ lua_pop(L,1);
+ }
+ mplib_push_S(left_x);
+ lua_rawget(L,-2);
+ if (lua_isnumber(L,-1)) {
+ if (left_set) {
+ errormsg = "Left side already set";
+ goto BAD;
+ } else {
+ if (!set_left_control(L, mp, p)) {
+ errormsg = "Failed to set left control";
+ goto BAD;
+ }
+ }
+ } else {
+ lua_pop(L,1);
+ }
+ mplib_push_S(right_curl);
+ lua_rawget(L,-2);
+ if (lua_isnumber(L,-1)) {
+ if (!set_right_curl (L, mp, p)) {
+ errormsg = "failed to set right curl";
+ goto BAD;
+ }
+ right_set = 1;
+ } else {
+ /*tex A |nil| value. */
+ lua_pop(L,1);
+ }
+ mplib_push_S(right_tension);
+ lua_rawget(L,-2);
+ if (lua_isnumber(L,-1)) {
+ if (right_set) {
+ errormsg = "Right side already set";
+ goto BAD;
+ } else {
+ if (!set_right_tension(L, mp, p)) {
+ errormsg = "Failed to set right tension";
+ goto BAD;
+ }
+ right_set = 1;
+ }
+ } else {
+ lua_pop(L,1);
+ }
+ mplib_push_S(right_x);
+ lua_rawget(L,-2);
+ if (lua_isnumber(L,-1)) {
+ if (right_set) {
+ errormsg = "Right side already set";
+ goto BAD;
+ } else {
+ if (!set_right_control(L, mp, p)) {
+ errormsg = "Failed to set right control";
+ goto BAD;
+ }
+ }
+ } else {
+ lua_pop(L,1);
+ }
+ mplib_push_S(direction_x);
+ lua_rawget(L,-2);
+ if (lua_isnumber(L,-1)) {
+ if (!set_direction (L, mp, p)) {
+ errormsg = "failed to set direction";
+ goto BAD;
+ }
+ } else {
+ /*tex A |nil| value. */
+ lua_pop(L,1);
+ }
+ /*tex Up the next item */
+ lua_pop(L,1);
+ }
+ if (cyclic) {
+ mp_close_path_cycle (mp, p, first);
+ } else {
+ mp_close_path (mp, p, first);
+ }
+#if 0
+ mp_dump_path(mp,first);
+#endif
+ /*tex We're finished reading arguments. */
+ if (!mp_solve_path(mp,first)) {
+ errormsg = "Failed to solve the path";
+ goto BAD;
+ }
+ /*tex Squeeze the new values back into the table. */
+ p = first;
+ for (i=1;i<=numpoints;i++) {
+ lua_rawgeti(L,-1, i);
+ mplib_push_S(left_x); lua_pushnumber(L, mp_number_as_double(mp, mp_knot_left_x(mp, p))); lua_rawset(L,-3);
+ mplib_push_S(left_y); lua_pushnumber(L, mp_number_as_double(mp, mp_knot_left_y(mp, p))); lua_rawset(L,-3);
+ mplib_push_S(right_x); lua_pushnumber(L, mp_number_as_double(mp, mp_knot_right_x(mp, p))); lua_rawset(L,-3);
+ mplib_push_S(right_y); lua_pushnumber(L, mp_number_as_double(mp, mp_knot_right_y(mp, p))); lua_rawset(L,-3);
+ /*tex This is a bit overkill \unknown */
+ mplib_push_S(left_tension); lua_pushnil(L); lua_rawset(L,-3);
+ mplib_push_S(right_tension); lua_pushnil(L); lua_rawset(L,-3);
+ mplib_push_S(left_curl); lua_pushnil(L); lua_rawset(L,-3);
+ mplib_push_S(right_curl); lua_pushnil(L); lua_rawset(L,-3);
+ mplib_push_S(direction_x); lua_pushnil(L); lua_rawset(L,-3);
+ mplib_push_S(direction_y); lua_pushnil(L); lua_rawset(L,-3);
+ /*tex \unknown\ till here. */
+ mplib_push_S(left_type); lua_pushstring(L, knot_type_enum[mp_knot_left_type(mp, p)]); lua_rawset(L, -3);
+ mplib_push_S(right_type); lua_pushstring(L, knot_type_enum[mp_knot_right_type(mp, p)]); lua_rawset(L, -3);
+ lua_pop(L,1);
+ p = mp_knot_next(mp,p);
+ }
+ lua_pushboolean(L, 1);
+ return 1;
+ BAD:
+ if (p != NULL) {
+ mp_close_path (mp, p, first);
+ mp_free_path (mp, p);
+ }
+ lua_pushboolean(L, 0);
+ lua_pushstring(L, errormsg);
+ return 2;
+}
+
+/*tex
+
+ The next methods are for collecting the results from |fig|.
+
+*/
+
+static int mplib_fig_collect(lua_State * L)
+{
+ struct mp_edge_object **hh = is_fig(L, 1);
+ if (*hh != NULL) {
+ mp_gr_toss_objects(*hh);
+ *hh = NULL;
+ }
+ return 0;
+}
+
+static int mplib_fig_body(lua_State * L)
+{
+ int i = 1;
+ struct mp_graphic_object **v;
+ struct mp_graphic_object *p;
+ struct mp_edge_object **hh = is_fig(L, 1);
+ lua_newtable(L);
+ p = (*hh)->body;
+ while (p != NULL) {
+ v = lua_newuserdata(L, sizeof(struct mp_graphic_object *));
+ *v = p;
+ luaL_getmetatable(L, MPLIB_GR_METATABLE);
+ lua_setmetatable(L, -2);
+ lua_rawseti(L, -2, i);
+ i++;
+ p = p->next;
+ }
+ /*tex Prevent a double free: */
+ (*hh)->body = NULL;
+ return 1;
+}
+
+static int mplib_fig_copy_body(lua_State * L)
+{
+ int i = 1;
+ struct mp_graphic_object **v;
+ struct mp_graphic_object *p;
+ struct mp_edge_object **hh = is_fig(L, 1);
+ lua_newtable(L);
+ p = (*hh)->body;
+ while (p != NULL) {
+ v = lua_newuserdata(L, sizeof(struct mp_graphic_object *));
+ *v = mp_gr_copy_object((*hh)->parent, p);
+ luaL_getmetatable(L, MPLIB_GR_METATABLE);
+ lua_setmetatable(L, -2);
+ lua_rawseti(L, -2, i);
+ i++;
+ p = p->next;
+ }
+ return 1;
+}
+
+static int mplib_fig_tostring(lua_State * L)
+{
+ struct mp_edge_object **hh = is_fig(L, 1);
+ (void)lua_pushfstring(L, "<figure %p>", *hh);
+ return 1;
+}
+
+static int mplib_fig_postscript(lua_State * L)
+{
+ mp_run_data *res;
+ struct mp_edge_object **hh = is_fig(L, 1);
+ int prologues = (int)luaL_optnumber(L, 2, (lua_Number)-1);
+ int procset = (int)luaL_optnumber(L, 3, (lua_Number)-1);
+ if (mp_ps_ship_out(*hh, prologues, procset)
+ && (res = mp_rundata((*hh)->parent))
+ && (res->ship_out.size != 0)) {
+ lua_pushstring(L, res->ship_out.data);
+ } else {
+ lua_pushnil(L);
+ }
+ return 1;
+}
+
+static int mplib_fig_svg(lua_State * L)
+{
+ mp_run_data *res;
+ struct mp_edge_object **hh = is_fig(L, 1);
+ int prologues = (int)luaL_optnumber(L, 2, (lua_Number)-1);
+ if (mp_svg_ship_out(*hh, prologues)
+ && (res = mp_rundata((*hh)->parent))
+ && (res->ship_out.size != 0)) {
+ lua_pushstring(L, res->ship_out.data);
+ } else {
+ lua_pushnil(L);
+ }
+ return 1;
+}
+
+static int mplib_fig_png(lua_State * L)
+{
+ mp_run_data *res;
+ struct mp_edge_object **hh = is_fig(L, 1);
+ const char *string = luaL_optstring(L, 2, NULL);
+ if (mp_png_ship_out(*hh, string)
+ && (res = mp_rundata((*hh)->parent))
+ && (res->ship_out.size != 0)) {
+ lua_pushlstring(L, res->ship_out.data, res->ship_out.size);
+ } else {
+ lua_pushnil(L);
+ }
+ return 1;
+}
+
+static int mplib_fig_filename(lua_State * L)
+{
+ struct mp_edge_object **hh = is_fig(L, 1);
+ if (*hh != NULL) {
+ char *s = (*hh)->filename;
+ lua_pushstring(L, s);
+ } else {
+ lua_pushnil(L);
+ }
+ return 1;
+}
+
+static int mplib_fig_width(lua_State * L)
+{
+ struct mp_edge_object **hh = is_fig(L, 1);
+ if (*hh != NULL) {
+ lua_pushnumber(L, (double) (*hh)->width);
+ } else {
+ lua_pushnil(L);
+ }
+ return 1;
+}
+
+static int mplib_fig_height(lua_State * L)
+{
+ struct mp_edge_object **hh = is_fig(L, 1);
+ if (*hh != NULL) {
+ lua_pushnumber(L, (double) (*hh)->height);
+ } else {
+ lua_pushnil(L);
+ }
+ return 1;
+}
+
+static int mplib_fig_depth(lua_State * L)
+{
+ struct mp_edge_object **hh = is_fig(L, 1);
+ if (*hh != NULL) {
+ lua_pushnumber(L, (double) (*hh)->depth);
+ } else {
+ lua_pushnil(L);
+ }
+ return 1;
+}
+
+static int mplib_fig_italcorr(lua_State * L)
+{
+ struct mp_edge_object **hh = is_fig(L, 1);
+ if (*hh != NULL) {
+ lua_pushnumber(L, (double) (*hh)->ital_corr);
+ } else {
+ lua_pushnil(L);
+ }
+ return 1;
+}
+
+static int mplib_fig_charcode(lua_State * L)
+{
+ struct mp_edge_object **hh = is_fig(L, 1);
+ if (*hh != NULL) {
+ lua_pushnumber(L, (lua_Number)(*hh)->charcode);
+ } else {
+ lua_pushnil(L);
+ }
+ return 1;
+}
+
+static int mplib_fig_bb(lua_State * L)
+{
+ struct mp_edge_object **hh = is_fig(L, 1);
+ lua_newtable(L);
+ lua_pushnumber(L, (double) (*hh)->minx);
+ lua_rawseti(L, -2, 1);
+ lua_pushnumber(L, (double) (*hh)->miny);
+ lua_rawseti(L, -2, 2);
+ lua_pushnumber(L, (double) (*hh)->maxx);
+ lua_rawseti(L, -2, 3);
+ lua_pushnumber(L, (double) (*hh)->maxy);
+ lua_rawseti(L, -2, 4);
+ return 1;
+}
+
+/*tex
+
+ The methods for the figure objects plus a few helpers.
+
+*/
+
+static int mplib_gr_collect(lua_State * L)
+{
+ struct mp_graphic_object **hh = is_gr_object(L, 1);
+ if (*hh != NULL) {
+ mp_gr_toss_object(*hh);
+ *hh = NULL;
+ }
+ return 0;
+}
+
+static int mplib_gr_tostring(lua_State * L)
+{
+ struct mp_graphic_object **hh = is_gr_object(L, 1);
+ (void)lua_pushfstring(L, "<object %p>", *hh);
+ return 1;
+}
+
+#define pyth(a,b) (sqrt((a)*(a) + (b)*(b)))
+
+#define aspect_bound (10.0/65536.0)
+#define aspect_default 1.0
+
+static double eps = 0.0001;
+
+static double coord_range_x (mp_gr_knot h, double dz) {
+ double z;
+ double zlo = 0.0, zhi = 0.0;
+ mp_gr_knot f = h;
+ while (h != NULL) {
+ z = h->x_coord;
+ if (z < zlo)
+ zlo = z;
+ else if (z > zhi)
+ zhi = z;
+ z = h->right_x;
+ if (z < zlo)
+ zlo = z;
+ else if (z > zhi)
+ zhi = z;
+ z = h->left_x;
+ if (z < zlo)
+ zlo = z;
+ else if (z > zhi)
+ zhi = z;
+ h = h->next;
+ if (h==f)
+ break;
+ }
+ return (zhi - zlo <= dz ? aspect_bound : aspect_default);
+}
+
+static double coord_range_y (mp_gr_knot h, double dz) {
+ double z;
+ double zlo = 0.0, zhi = 0.0;
+ mp_gr_knot f = h;
+ while (h != NULL) {
+ z = h->y_coord;
+ if (z < zlo)
+ zlo = z;
+ else if (z > zhi)
+ zhi = z;
+ z = h->right_y;
+ if (z < zlo)
+ zlo = z;
+ else if (z > zhi)
+ zhi = z;
+ z = h->left_y;
+ if (z < zlo)
+ zlo = z;
+ else if (z > zhi)
+ zhi = z;
+ h = h->next;
+ if (h==f)
+ break;
+ }
+ return (zhi - zlo <= dz ? aspect_bound : aspect_default);
+}
+
+static int mplib_gr_peninfo(lua_State * L) {
+ double x_coord, y_coord, left_x, left_y, right_x, right_y;
+ double wx, wy;
+ double rx = 1.0, sx = 0.0, sy = 0.0, ry = 1.0, tx = 0.0, ty = 0.0;
+ double width = 1.0;
+ mp_gr_knot p = NULL, path = NULL;
+ struct mp_graphic_object **hh = is_gr_object(L, -1);
+ if (!*hh) {
+ lua_pushnil(L);
+ return 1;
+ }
+ if ((*hh)->type == mp_fill_code) {
+ p = ((mp_fill_object *)(*hh))->pen_p;
+ path = ((mp_fill_object *)(*hh))->path_p;
+ } else if ((*hh)->type == mp_stroked_code) {
+ p = ((mp_stroked_object *)(*hh))->pen_p;
+ path = ((mp_stroked_object *)(*hh))->path_p;
+ }
+ if (p==NULL || path == NULL) {
+ lua_pushnil(L);
+ return 1;
+ }
+ x_coord = p->x_coord;
+ y_coord = p->y_coord;
+ left_x = p->left_x;
+ left_y = p->left_y;
+ right_x = p->right_x;
+ right_y = p->right_y;
+ if ((right_x == x_coord) && (left_y == y_coord)) {
+ wx = fabs(left_x - x_coord);
+ wy = fabs(right_y - y_coord);
+ } else {
+ wx = pyth(left_x - x_coord, right_x - x_coord);
+ wy = pyth(left_y - y_coord, right_y - y_coord);
+ }
+ if ((wy/coord_range_x(path, wx)) >= (wx/coord_range_y(path, wy)))
+ width = wy;
+ else
+ width = wx;
+ tx = x_coord;
+ ty = y_coord;
+ sx = left_x - tx;
+ rx = left_y - ty;
+ ry = right_x - tx;
+ sy = right_y - ty;
+ if (width !=1.0) {
+ if (width == 0.0) {
+ sx = 1.0; sy = 1.0;
+ } else {
+ rx/=width; ry/=width; sx/=width; sy/=width;
+ }
+ }
+ if (fabs(sx) < eps)
+ sx = eps;
+ if (fabs(sy) < eps)
+ sy = eps;
+ lua_newtable(L);
+ lua_pushnumber(L,width); lua_setfield(L,-2,"width");
+ lua_pushnumber(L,rx); lua_setfield(L,-2,"rx");
+ lua_pushnumber(L,sx); lua_setfield(L,-2,"sx");
+ lua_pushnumber(L,sy); lua_setfield(L,-2,"sy");
+ lua_pushnumber(L,ry); lua_setfield(L,-2,"ry");
+ lua_pushnumber(L,tx); lua_setfield(L,-2,"tx");
+ lua_pushnumber(L,ty); lua_setfield(L,-2,"ty");
+ return 1;
+}
+
+/*tex
+
+ Here is a helper that reports the valid field names of the possible
+ objects.
+
+*/
+
+static int mplib_gr_fields(lua_State * L)
+{
+ const char **fields;
+ int i;
+ struct mp_graphic_object **hh = is_gr_object(L, 1);
+ if (*hh) {
+ switch ((*hh)->type) {
+ case mp_fill_code:
+ fields = fill_fields;
+ break;
+ case mp_stroked_code:
+ fields = stroked_fields;
+ break;
+ case mp_text_code:
+ fields = text_fields;
+ break;
+ case mp_special_code:
+ fields = special_fields;
+ break;
+ case mp_start_clip_code:
+ fields = start_clip_fields;
+ break;
+ case mp_start_bounds_code:
+ fields = start_bounds_fields;
+ break;
+ case mp_stop_clip_code:
+ fields = stop_clip_fields;
+ break;
+ case mp_stop_bounds_code:
+ fields = stop_bounds_fields;
+ break;
+ default:
+ fields = no_fields;
+ }
+ lua_newtable(L);
+ for (i = 0; fields[i] != NULL; i++) {
+ lua_pushstring(L, fields[i]);
+ lua_rawseti(L, -2, (i + 1));
+ }
+ } else {
+ lua_pushnil(L);
+ }
+ return 1;
+}
+
+#define mplib_push_number(L,x) lua_pushnumber(L,(lua_Number)(x))
+
+#define MPLIB_PATH 0
+#define MPLIB_PEN 1
+
+static void mplib_push_path(lua_State * L, mp_gr_knot h, int is_pen)
+{
+ mp_gr_knot p;
+ int i = 1;
+ p = h;
+ if (p != NULL) {
+ lua_newtable(L);
+ do {
+ lua_createtable(L, 0, 6);
+ if (!is_pen) {
+ if (p->data.types.left_type != mp_explicit) {
+ mplib_push_S(left_type);
+ lua_pushstring(L, knot_type_enum[p->data.types.left_type]);
+ lua_rawset(L, -3);
+ }
+ if (p->data.types.right_type != mp_explicit) {
+ mplib_push_S(right_type);
+ lua_pushstring(L, knot_type_enum[p->data.types.right_type]);
+ lua_rawset(L, -3);
+ }
+ }
+ mplib_push_S(x_coord);
+ mplib_push_number(L, p->x_coord);
+ lua_rawset(L, -3);
+ mplib_push_S(y_coord);
+ mplib_push_number(L, p->y_coord);
+ lua_rawset(L, -3);
+ mplib_push_S(left_x);
+ mplib_push_number(L, p->left_x);
+ lua_rawset(L, -3);
+ mplib_push_S(left_y);
+ mplib_push_number(L, p->left_y);
+ lua_rawset(L, -3);
+ mplib_push_S(right_x);
+ mplib_push_number(L, p->right_x);
+ lua_rawset(L, -3);
+ mplib_push_S(right_y);
+ mplib_push_number(L, p->right_y);
+ lua_rawset(L, -3);
+ lua_rawseti(L, -2, i);
+ i++;
+ if (p->data.types.right_type == mp_endpoint) {
+ return;
+ }
+ p = p->next;
+ } while (p != h);
+ } else {
+ lua_pushnil(L);
+ }
+}
+
+static int mplib_get_path(lua_State * L)
+{
+ MP *mp = is_mp(L, 1);
+ if (*mp != NULL) {
+ size_t l;
+ const char *s = lua_tolstring(L, 2, &l);
+ if (s != NULL) {
+ mp_knot p = mp_get_path_value(*mp,s,l) ;
+ if (p != NULL) {
+ int i = 1;
+ mp_knot h = p;
+ lua_newtable(L);
+ do {
+ lua_createtable(L, 6, 1);
+ mplib_push_number(L, mp_number_as_double(*mp,p->x_coord));
+ lua_rawseti(L,-2,1);
+ mplib_push_number(L, mp_number_as_double(*mp,p->y_coord));
+ lua_rawseti(L,-2,2);
+ mplib_push_number(L, mp_number_as_double(*mp,p->left_x));
+ lua_rawseti(L,-2,3);
+ mplib_push_number(L, mp_number_as_double(*mp,p->left_y));
+ lua_rawseti(L,-2,4);
+ mplib_push_number(L, mp_number_as_double(*mp,p->right_x));
+ lua_rawseti(L,-2,5);
+ mplib_push_number(L, mp_number_as_double(*mp,p->right_y));
+ lua_rawseti(L,-2,6);
+ lua_rawseti(L,-2, i);
+ i++;
+ if (p->data.types.right_type == mp_endpoint) {
+ mplib_push_S(cycle);
+ lua_pushboolean(L,0);
+ lua_rawset(L,-3);
+ return 1;
+ }
+ p = p->next;
+ } while (p != h);
+ mplib_push_S(cycle);
+ lua_pushboolean(L,1);
+ lua_rawset(L,-3);
+ return 1;
+ }
+ }
+ }
+ return 0;
+}
+
+/*tex
+
+ This assumes that the top of the stack is a table or nil already in the case.
+*/
+
+static void mplib_push_pentype(lua_State * L, mp_gr_knot h)
+{
+ mp_gr_knot p;
+ p = h;
+ if (p == NULL) {
+ /*tex Do nothing. */
+ } else if (p == p->next) {
+ mplib_push_S(type);
+ mplib_push_S(elliptical);
+ lua_rawset(L, -3);
+ } else {
+ }
+}
+
+#define set_color_objects(pq) \
+object_color_model = pq->color_model; \
+object_color_a = pq->color.a_val; \
+object_color_b = pq->color.b_val; \
+object_color_c = pq->color.c_val; \
+object_color_d = pq->color.d_val;
+
+static void mplib_push_color(lua_State * L, struct mp_graphic_object *p)
+{
+ int object_color_model;
+ double object_color_a, object_color_b, object_color_c, object_color_d;
+ if (p != NULL) {
+ if (p->type == mp_fill_code) {
+ mp_fill_object *h = (mp_fill_object *) p;
+ set_color_objects(h);
+ } else if (p->type == mp_stroked_code) {
+ mp_stroked_object *h = (mp_stroked_object *) p;
+ set_color_objects(h);
+ } else {
+ mp_text_object *h = (mp_text_object *) p;
+ set_color_objects(h);
+ }
+ lua_newtable(L);
+ if (object_color_model >= mp_grey_model) {
+ mplib_push_number(L, object_color_a);
+ lua_rawseti(L, -2, 1);
+ if (object_color_model >= mp_rgb_model) {
+ mplib_push_number(L, object_color_b);
+ lua_rawseti(L, -2, 2);
+ mplib_push_number(L, object_color_c);
+ lua_rawseti(L, -2, 3);
+ if (object_color_model == mp_cmyk_model) {
+ mplib_push_number(L, object_color_d);
+ lua_rawseti(L, -2, 4);
+ }
+ }
+ }
+ } else {
+ lua_pushnil(L);
+ }
+}
+
+/*tex
+
+ The dash scale is not exported, the field has no external value.
+
+*/
+
+static void mplib_push_dash(lua_State * L, struct mp_stroked_object *h)
+{
+ mp_dash_object *d;
+ double ds;
+ if (h != NULL && h->dash_p != NULL) {
+ d = h->dash_p;
+ lua_newtable(L);
+ mplib_push_S(offset);
+ mplib_push_number(L, d->offset);
+ lua_rawset(L,-3);
+ if (d->array != NULL) {
+ int i = 0;
+ mplib_push_S(dashes);
+ lua_newtable(L);
+ while (*(d->array + i) != -1) {
+ ds = *(d->array + i);
+ lua_pushnumber(L, ds);
+ i++;
+ lua_rawseti(L, -2, i);
+ }
+ lua_rawset(L,-3);
+ }
+ } else {
+ lua_pushnil(L);
+ }
+}
+
+static void mplib_push_transform(lua_State * L, struct mp_text_object *h)
+{
+ int i = 1;
+ if (h != NULL) {
+ lua_createtable(L, 6, 0);
+ mplib_push_number(L, h->tx);
+ lua_rawseti(L, -2, i);
+ i++;
+ mplib_push_number(L, h->ty);
+ lua_rawseti(L, -2, i);
+ i++;
+ mplib_push_number(L, h->txx);
+ lua_rawseti(L, -2, i);
+ i++;
+ mplib_push_number(L, h->tyx);
+ lua_rawseti(L, -2, i);
+ i++;
+ mplib_push_number(L, h->txy);
+ lua_rawseti(L, -2, i);
+ i++;
+ mplib_push_number(L, h->tyy);
+ lua_rawseti(L, -2, i);
+ i++;
+ } else {
+ lua_pushnil(L);
+ }
+}
+
+#define FIELD(A) (mplib_is_S(A,2))
+
+static void mplib_fill(lua_State * L, struct mp_fill_object *h)
+{
+ if (FIELD(path)) {
+ mplib_push_path(L, h->path_p, MPLIB_PATH);
+ } else if (FIELD(htap)) {
+ mplib_push_path(L, h->htap_p, MPLIB_PATH);
+ } else if (FIELD(pen)) {
+ mplib_push_path(L, h->pen_p, MPLIB_PEN);
+ mplib_push_pentype(L, h->pen_p);
+ } else if (FIELD(color)) {
+ mplib_push_color(L, (mp_graphic_object *) h);
+ } else if (FIELD(linejoin)) {
+ lua_pushnumber(L, (lua_Number)h->ljoin);
+ } else if (FIELD(miterlimit)) {
+ mplib_push_number(L, h->miterlim);
+ } else if (FIELD(prescript)) {
+ lua_pushstring(L, h->pre_script);
+ } else if (FIELD(postscript)) {
+ lua_pushstring(L, h->post_script);
+ } else {
+ lua_pushnil(L);
+ }
+}
+
+static void mplib_stroked(lua_State * L, struct mp_stroked_object *h)
+{
+ if (FIELD(path)) {
+ mplib_push_path(L, h->path_p, MPLIB_PATH);
+ } else if (FIELD(pen)) {
+ mplib_push_path(L, h->pen_p, MPLIB_PEN);
+ mplib_push_pentype(L, h->pen_p);
+ } else if (FIELD(color)) {
+ mplib_push_color(L, (mp_graphic_object *) h);
+ } else if (FIELD(dash)) {
+ mplib_push_dash(L, h);
+ } else if (FIELD(linecap)) {
+ lua_pushnumber(L, (lua_Number)h->lcap);
+ } else if (FIELD(linejoin)) {
+ lua_pushnumber(L, (lua_Number)h->ljoin);
+ } else if (FIELD(miterlimit)) {
+ mplib_push_number(L, h->miterlim);
+ } else if (FIELD(prescript)) {
+ lua_pushstring(L, h->pre_script);
+ } else if (FIELD(postscript)) {
+ lua_pushstring(L, h->post_script);
+ } else {
+ lua_pushnil(L);
+ }
+}
+
+static void mplib_text(lua_State * L, struct mp_text_object *h)
+{
+ if (FIELD(text)) {
+ lua_pushstring(L, h->text_p);
+ } else if (FIELD(dsize)) {
+ mplib_push_number(L, (h->font_dsize / 16));
+ } else if (FIELD(font)) {
+ lua_pushstring(L, h->font_name);
+ } else if (FIELD(color)) {
+ mplib_push_color(L, (mp_graphic_object *) h);
+ } else if (FIELD(width)) {
+ mplib_push_number(L, h->width);
+ } else if (FIELD(height)) {
+ mplib_push_number(L, h->height);
+ } else if (FIELD(depth)) {
+ mplib_push_number(L, h->depth);
+ } else if (FIELD(transform)) {
+ mplib_push_transform(L, h);
+ } else if (FIELD(prescript)) {
+ lua_pushstring(L, h->pre_script);
+ } else if (FIELD(postscript)) {
+ lua_pushstring(L, h->post_script);
+ } else {
+ lua_pushnil(L);
+ }
+}
+
+static void mplib_special(lua_State * L, struct mp_special_object *h)
+{
+ if (FIELD(prescript)) {
+ lua_pushstring(L, h->pre_script);
+ } else {
+ lua_pushnil(L);
+ }
+}
+
+static void mplib_start_bounds(lua_State * L, struct mp_bounds_object *h)
+{
+ if (FIELD(path)) {
+ mplib_push_path(L, h->path_p, MPLIB_PATH);
+ } else {
+ lua_pushnil(L);
+ }
+}
+
+static void mplib_start_clip(lua_State * L, struct mp_clip_object *h)
+{
+ if (FIELD(path)) {
+ mplib_push_path(L, h->path_p, MPLIB_PATH);
+ } else {
+ lua_pushnil(L);
+ }
+}
+
+static int mplib_gr_index(lua_State * L)
+{
+ struct mp_graphic_object **hh = is_gr_object(L, 1);
+ if (*hh) {
+ struct mp_graphic_object *h = *hh;
+ if (mplib_is_S(type, 2)) {
+ lua_rawgeti(L, LUA_REGISTRYINDEX, mplib_type_Ses[h->type]);
+ } else {
+ switch (h->type) {
+ case mp_fill_code:
+ mplib_fill(L, (mp_fill_object *) h);
+ break;
+ case mp_stroked_code:
+ mplib_stroked(L, (mp_stroked_object *) h);
+ break;
+ case mp_text_code:
+ mplib_text(L, (mp_text_object *) h);
+ break;
+ case mp_special_code:
+ mplib_special(L, (mp_special_object *) h);
+ break;
+ case mp_start_clip_code:
+ mplib_start_clip(L, (mp_clip_object *) h);
+ break;
+ case mp_start_bounds_code:
+ mplib_start_bounds(L, (mp_bounds_object *) h);
+ break;
+ case mp_stop_clip_code:
+ case mp_stop_bounds_code:
+ default:
+ lua_pushnil(L);
+ }
+ }
+ } else {
+ lua_pushnil(L);
+ }
+ return 1;
+}
+
+static const struct luaL_reg mplib_meta[] = {
+ { "__gc", mplib_collect },
+ { "__tostring", mplib_tostring },
+ /*tex sentinel */
+ { NULL, NULL}
+};
+
+static const struct luaL_reg mplib_fig_meta[] = {
+ { "__gc", mplib_fig_collect },
+ { "__tostring", mplib_fig_tostring },
+ { "objects", mplib_fig_body },
+ { "copy_objects", mplib_fig_copy_body },
+ { "filename", mplib_fig_filename },
+ { "postscript", mplib_fig_postscript },
+ { "png", mplib_fig_png },
+ { "svg", mplib_fig_svg },
+ { "boundingbox", mplib_fig_bb },
+ { "width", mplib_fig_width },
+ { "height", mplib_fig_height },
+ { "depth", mplib_fig_depth },
+ { "italcorr", mplib_fig_italcorr },
+ { "charcode", mplib_fig_charcode },
+ /*tex sentinel */
+ { NULL, NULL}
+};
+
+static const struct luaL_reg mplib_gr_meta[] = {
+ { "__gc", mplib_gr_collect},
+ { "__tostring", mplib_gr_tostring},
+ { "__index", mplib_gr_index},
+ /*tex sentinel */
+ { NULL, NULL}
+};
+
+static const struct luaL_reg mplib_d[] = {
+ { "execute", mplib_execute },
+ { "finish", mplib_finish },
+ { "char_width", mplib_charwidth },
+ { "char_height", mplib_charheight },
+ { "char_depth", mplib_chardepth },
+ { "statistics", mplib_statistics },
+ { "solve_path", mplib_solve_path },
+ { "get_numeric", mplib_get_numeric },
+ { "get_number", mplib_get_numeric },
+ { "get_boolean", mplib_get_boolean },
+ { "get_string", mplib_get_string },
+ { "get_path", mplib_get_path },
+ /*tex sentinel */
+ {NULL, NULL }
+};
+
+static const struct luaL_reg mplib_m[] = {
+ { "new", mplib_new },
+ { "version", mplib_version },
+ { "fields", mplib_gr_fields },
+ /* indirect */
+ { "execute", mplib_execute },
+ { "finish", mplib_finish },
+ { "char_width", mplib_charwidth },
+ { "char_height", mplib_charheight },
+ { "char_depth", mplib_chardepth },
+ { "statistics", mplib_statistics },
+ { "solve_path", mplib_solve_path },
+ /* helpers */
+ { "pen_info", mplib_gr_peninfo },
+ { "get_numeric", mplib_get_numeric },
+ { "get_number", mplib_get_numeric },
+ { "get_boolean", mplib_get_boolean },
+ { "get_string", mplib_get_string },
+ { "get_path", mplib_get_path },
+ /*tex sentinel */
+ { NULL, NULL}
+};
+
+int luaopen_mplib(lua_State * L)
+{
+ mplib_init_Ses(L);
+
+ luaL_newmetatable(L, MPLIB_GR_METATABLE);
+ lua_pushvalue(L, -1);
+ lua_setfield(L, -2, "__index");
+ luaL_register(L, NULL, mplib_gr_meta);
+ lua_pop(L, 1);
+
+ luaL_newmetatable(L, MPLIB_FIG_METATABLE);
+ lua_pushvalue(L, -1);
+ lua_setfield(L, -2, "__index");
+ luaL_register(L, NULL, mplib_fig_meta);
+ lua_pop(L, 1);
+
+ luaL_newmetatable(L, MPLIB_METATABLE);
+ lua_pushvalue(L, -1);
+ lua_setfield(L, -2, "__index");
+ luaL_register(L, NULL, mplib_meta);
+ luaL_register(L, NULL, mplib_d);
+ luaL_register(L, "mplib", mplib_m);
+
+ return 1;
+}
diff --git a/Build/source/texk/web2c/mplibdir/mp.w b/Build/source/texk/web2c/mplibdir/mp.w
new file mode 100644
index 00000000000..dcbd01b31ea
--- /dev/null
+++ b/Build/source/texk/web2c/mplibdir/mp.w
@@ -0,0 +1,35650 @@
+% This file is part of MetaPost;
+% the MetaPost program is in the public domain.
+% See the <Show version...> code in mpost.w for more info.
+
+% Here is TeX material that gets inserted after \input webmac
+\def\hang{\hangindent 3em\noindent\ignorespaces}
+\def\textindent#1{\hangindent2.5em\noindent\hbox to2.5em{\hss#1 }\ignorespaces}
+\def\ps{PostScript}
+\def\psqrt#1{\sqrt{\mathstrut#1}}
+\def\k{_{k+1}}
+\def\pct!{{\char`\%}} % percent sign in ordinary text
+\font\tenlogo=logo10 % font used for the METAFONT logo
+\font\logos=logosl10
+\def\MF{{\tenlogo META}\-{\tenlogo FONT}}
+\def\MP{{\tenlogo META}\-{\tenlogo POST}}
+\def\<#1>{$\langle#1\rangle$}
+\def\section{\mathhexbox278}
+\let\swap=\leftrightarrow
+\def\round{\mathop{\rm round}\nolimits}
+\mathchardef\vbv="026A % synonym for `\|'
+\def\vb{\relax\ifmmode\vbv\else$\vbv$\fi}
+
+\def\(#1){} % this is used to make section names sort themselves better
+\def\9#1{} % this is used for sort keys in the index via @@:sort key}{entry@@>
+\def\title{MetaPost}
+\pdfoutput=1
+\pageno=3
+
+@* Introduction.
+
+This is \MP\ by John Hobby, a graphics-language processor based on D. E. Knuth's \MF.
+
+Much of the original Pascal version 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.
+
+The main purpose of the following program is to explain the algorithms of \MP\
+as clearly as possible. However, the program has been written so that it
+can be tuned to run efficiently in a wide variety of operating environments
+by making comparatively few changes. Such flexibility is possible because
+the documentation that follows is written in the \.{WEB} language, which is
+at a higher level than C.
+
+A large piece of software like \MP\ has inherent complexity that cannot
+be reduced below a certain level of difficulty, although each individual
+part is fairly simple by itself. The \.{WEB} language is intended to make
+the algorithms as readable as possible, by reflecting the way the
+individual program pieces fit together and by providing the
+cross-references that connect different parts. Detailed comments about
+what is going on, and about why things were done in certain ways, have
+been liberally sprinkled throughout the program. These comments explain
+features of the implementation, but they rarely attempt to explain the
+\MP\ language itself, since the reader is supposed to be familiar with
+{\sl The {\logos METAFONT\/}book} as well as the manual
+@.WEB@>
+@:METAFONTbook}{\sl The {\logos METAFONT\/}book@>
+{\sl A User's Manual for MetaPost}, Computing Science Technical Report 162,
+AT\AM T Bell Laboratories.
+
+@ The present implementation is a preliminary version, but the possibilities
+for new features are limited by the desire to remain as nearly compatible
+with \MF\ as possible.
+
+On the other hand, the \.{WEB} description can be extended without changing
+the core of the program, and it has been designed so that such
+extensions are not extremely difficult to make.
+The |banner| string defined here should be changed whenever \MP\
+undergoes any modifications, so that it will be clear which version of
+\MP\ might be the guilty party when a problem arises.
+@^extensions to \MP@>
+@^system dependencies@>
+
+@d default_banner "This is MetaPost, Version 2.00" /* printed when \MP\ starts */
+@d true 1
+@d false 0
+
+@<Metapost version header@>=
+#define metapost_version "2.00"
+
+@ The external library header for \MP\ is |mplib.h|. It contains a
+few typedefs and the header defintions for the externally used
+fuctions.
+
+The most important of the typedefs is the definition of the structure
+|MP_options|, that acts as a small, configurable front-end to the fairly
+large |MP_instance| structure.
+
+@(mplib.h@>=
+#ifndef MPLIB_H
+#define MPLIB_H 1
+#include <stdlib.h>
+#ifndef HAVE_BOOLEAN
+typedef int boolean;
+#endif
+@<Metapost version header@>
+typedef struct MP_instance *MP;
+@<Exported types@>
+typedef struct MP_options {
+ @<Option variables@>
+} MP_options;
+@<Exported function headers@>
+@<MPlib header stuff@>
+#endif
+
+@ The internal header file is much longer: it not only lists the complete
+|MP_instance|, but also a lot of functions that have to be available to
+the \ps\ backend, that is defined in a separate \.{WEB} file.
+
+The variables from |MP_options| are included inside the |MP_instance|
+wholesale.
+
+@(mpmp.h@>=
+#ifndef MPMP_H
+#define MPMP_H 1
+#include "avl.h"
+#include "mplib.h"
+#include <setjmp.h>
+typedef struct psout_data_struct *psout_data;
+typedef struct svgout_data_struct *svgout_data;
+typedef struct pngout_data_struct *pngout_data;
+#ifndef HAVE_BOOLEAN
+typedef int boolean;
+#endif
+
+#ifndef INTEGER_TYPE
+typedef int integer;
+#define MPOST_ABS abs
+#else
+/* See source/texk/web2c/w2c/config.h */
+#if INTEGER_MAX == LONG_MAX /* this should mean INTEGER_TYPE == long */
+#ifdef HAVE_LABS
+#define MPOST_ABS labs
+#else
+#define MPOST_ABS abs
+#endif
+#else
+#define MPOST_ABS abs
+#endif /* if INTEGER_TYPE == long */
+#endif /* ifndef INTEGER_TYPE */
+
+
+@<Declare helpers@>;
+@<Enumeration types@>;
+@<Types in the outer block@>;
+@<Constants in the outer block@>;
+typedef struct MP_instance {
+ @<Option variables@>
+ @<Global variables@>
+} MP_instance;
+@<Internal library declarations@>
+@<MPlib internal header stuff@>
+#endif
+
+@ @c
+/*\#define DEBUGENVELOPE */
+#ifdef DEBUGENVELOPE
+static int DEBUGENVELOPECOUNTER=0;
+#define dbg_str(A) printf("\n--[==[%03d DEBUGENVELOPE ]==] %s", DEBUGENVELOPECOUNTER++, #A)
+#define dbg_n(A) printf("\n--[==[%03d DEBUGENVELOPE ]==] ['%s']=%s, ", DEBUGENVELOPECOUNTER++, #A, number_tostring(A))
+#define dbg_in(A) printf("\n--[==[%03d DEBUGENVELOPE ]==] ['%s']=%d, ", DEBUGENVELOPECOUNTER++, #A, (int)(A))
+#define dbg_dn(A) printf("\n--[==[%03d DEBUGENVELOPE ]==] ['%s']=%.100f, ",DEBUGENVELOPECOUNTER++, #A, (double)(A))
+#define dbg_key(A) printf("\n--[==[%03d DEBUGENVELOPE ]==] ['%s']= ", DEBUGENVELOPECOUNTER++, #A)
+#define dbg_key_nval(K,V) printf("\n--[==[%03d DEBUGENVELOPE ]==] ['%s']=%s", DEBUGENVELOPECOUNTER++, #K,number_tostring(V))
+#define dbg_key_ival(K,V) printf("\n--[==[%03d DEBUGENVELOPE ]==] ['%s']=%d", DEBUGENVELOPECOUNTER++, #K,(int)(V))
+#define dbg_key_dval(K,V) printf("\n--[==[%03d DEBUGENVELOPE ]==] ['%s']=%.100f", DEBUGENVELOPECOUNTER++, #K,(double)(V))
+#define dbg_comment(A) printf("\n--[==[%03d DEBUGENVELOPE ]==] --[==[%s]==]", DEBUGENVELOPECOUNTER++, #A)
+#define dbg_sp printf("\n--[==[%03d DEBUGENVELOPE ]==] ", DEBUGENVELOPECOUNTER++)
+#define dbg_open_t printf("\n--[==[%03d DEBUGENVELOPE ]==] {", DEBUGENVELOPECOUNTER++)
+#define dbg_close_t printf("\n--[==[%03d DEBUGENVELOPE ]==] }", DEBUGENVELOPECOUNTER++)
+#define dbg_comma printf("\n--[==[%03d DEBUGENVELOPE ]==] ,", DEBUGENVELOPECOUNTER++)
+#define dbg_nl printf("\n--[==[%03d DEBUGENVELOPE ]==] \n", DEBUGENVELOPECOUNTER++)
+#define dbg_CUBIC dbg_n(p->x_coord); dbg_n(p->y_coord); \
+ dbg_n(p->right_x); dbg_n(p->right_y); \
+ dbg_n(q->left_x); dbg_n(q->left_y); \
+ dbg_n(q->x_coord); dbg_n(q->y_coord)
+#endif
+#define KPATHSEA_DEBUG_H 1
+#include <w2c/config.h>
+#include <stdio.h>
+#include <stdlib.h>
+#include <string.h>
+#include <stdarg.h>
+#include <assert.h>
+#include <math.h>
+#ifdef HAVE_UNISTD_H
+# include <unistd.h> /* for access */
+#endif
+#include <time.h> /* for struct tm \& co */
+#include <zlib.h> /* for |ZLIB_VERSION|, zlibVersion() */
+#include <png.h> /* for |PNG_LIBPNG_VER_STRING|, |png_libpng_ver| */
+/*\#include <pixman.h>*/ /* for |PIXMAN_VERSION_STRING|, |pixman_version_string()| */
+/*\#include <cairo.h>*/ /* for |CAIRO_VERSION_STRING|, |cairo_version_string()| */
+/*\#include <gmp.h>*/ /* for |gmp_version| */
+/*\#include <mpfr.h>*/ /* for |MPFR_VERSION_STRING|, |mpfr_get_version()| */
+#include "mplib.h"
+#include "mplibps.h" /* external header */
+/*\#include "mplibsvg.h" */ /* external header */
+/*\#include "mplibpng.h" */ /* external header */
+#include "mpmp.h" /* internal header */
+#include "mppsout.h" /* internal header */
+/*\#include "mpsvgout.h"*/ /* internal header */
+/*\#include "mppngout.h"*/ /* internal header */
+#include "mpmath.h" /* internal header */
+#include "mpmathdouble.h" /* internal header */
+#include "mpmathdecimal.h" /* internal header */
+/*|#include "mpmathbinary.h"|*/ /* internal header */
+#include "mpstrings.h" /* internal header */
+/* BEGIN PATCH */
+mp_number dx_ap; /* approximation of dx */
+mp_number dy_ap; /* approximation of dy */
+mp_number dxin_ap; /* approximation of dxin */
+mp_number dyin_ap; /* approximation of dyin */
+mp_number ueps_ap; /* epsilon for above approximations */
+boolean is_dxdy, is_dxindyin;
+/* END PATCH */
+
+@ We move the {\tt cairo} and {\tt pixman} libraries outside {\tt mp.w},
+to minimize dependencies.
+
+@c
+extern const char *COMPILED_CAIRO_VERSION_STRING;
+extern const char* cairo_version_string (void);
+extern const char *COMPILED_MPFR_VERSION_STRING;
+extern const char* mpfr_get_version (void);
+extern void * mp_initialize_binary_math (MP mp) ;
+extern int COMPILED__GNU_MP_VERSION;
+extern int COMPILED__GNU_MP_VERSION_MINOR;
+extern int COMPILED__GNU_MP_VERSION_PATCHLEVEL;
+extern const char * const COMPILED_gmp_version;
+extern const char *COMPILED_PIXMAN_VERSION_STRING;
+extern const char* pixman_version_string (void);
+extern void mp_png_backend_initialize (MP mp);
+extern void mp_png_backend_free (MP mp);
+extern int mp_png_gr_ship_out (void *hh, const char *options, int standalone);
+extern int mp_png_ship_out (void *hh, const char *options);
+extern void mp_svg_backend_initialize (MP mp);
+extern void mp_svg_backend_free (MP mp);
+extern int mp_svg_ship_out (mp_edge_object *hh, int prologues);
+extern int mp_svg_gr_ship_out (mp_edge_object *hh, int prologues, int standalone);
+
+@ @c
+extern font_number mp_read_font_info (MP mp, char *fname); /* tfmin.w */
+@h @<Declarations@>;
+@<Basic printing procedures@>;
+@<Error handling procedures@>
+
+@ Some debugging support for development. The trick with the variadic macros
+probably only works in gcc, as this preprocessor feature was not formalized
+until the c99 standard (and that is too new for us). Lets' hope that at least
+most compilers understand the non-debug version.
+@^system dependencies@>
+
+@<MPlib internal header stuff@>=
+/*\#define DEBUG 2*/
+#if DEBUG
+#define debug_number(A) printf("%d: %s=%.32f (%d)\n", __LINE__, #A, number_to_double(A), number_to_scaled(A))
+#else
+#define debug_number(A)
+#endif
+#if DEBUG>1
+void do_debug_printf(MP mp, const char *prefix, const char *fmt, ...);
+# define debug_printf(a1,a2,a3) do_debug_printf(mp, "", a1,a2,a3)
+# define FUNCTION_TRACE1(a1) do_debug_printf(mp, "FTRACE: ", a1)
+# define FUNCTION_TRACE2(a1,a2) do_debug_printf(mp, "FTRACE: ", a1,a2)
+# define FUNCTION_TRACE3(a1,a2,a3) do_debug_printf(mp, "FTRACE: ", a1,a2,a3)
+# define FUNCTION_TRACE3X(a1,a2,a3) (void)mp
+# define FUNCTION_TRACE4(a1,a2,a3,a4) do_debug_printf(mp, "FTRACE: ", a1,a2,a3,a4)
+#else
+# define debug_printf(a1,a2,a3)
+# define FUNCTION_TRACE1(a1) (void)mp
+# define FUNCTION_TRACE2(a1,a2) (void)mp
+# define FUNCTION_TRACE3(a1,a2,a3) (void)mp
+# define FUNCTION_TRACE3X(a1,a2,a3) (void)mp
+# define FUNCTION_TRACE4(a1,a2,a3,a4) (void)mp
+#endif
+
+@ This function occasionally crashes (if something is written after the
+log file is already closed), but that is not so important while debugging.
+
+@c
+#if DEBUG
+void do_debug_printf(MP mp, const char *prefix, const char *fmt, ...) ;
+void do_debug_printf(MP mp, const char *prefix, const char *fmt, ...) {
+ va_list ap;
+#if 0
+ va_start (ap, fmt);
+ if (mp->log_file && !ferror((FILE *)mp->log_file)) {
+ fputs(prefix, mp->log_file);
+ vfprintf(mp->log_file, fmt, ap);
+ }
+ va_end(ap);
+#endif
+ va_start (ap, fmt);
+#if 0
+ if (mp->term_out && !ferror((FILE *)mp->term_out)) {
+#else
+ if (false) {
+#endif
+ fputs(prefix, mp->term_out);
+ vfprintf(mp->term_out, fmt, ap);
+ } else {
+ fputs(prefix, stdout);
+ vfprintf(stdout, fmt, ap);
+ }
+ va_end(ap);
+}
+#endif
+
+@ Here are the functions that set up the \MP\ instance.
+
+@<Declarations@>=
+MP_options *mp_options (void);
+MP mp_initialize (MP_options * opt);
+
+@ @c
+MP_options *mp_options (void) {
+ MP_options *opt;
+ size_t l = sizeof (MP_options);
+ opt = malloc (l);
+ if (opt != NULL) {
+ memset (opt, 0, l);
+ }
+ return opt;
+}
+
+
+@ @<Internal library declarations@>=
+@<Declare subroutines for parsing file names@>
+
+
+@ The whole instance structure is initialized with zeroes,
+this greatly reduces the number of statements needed in
+the |Allocate or initialize variables| block.
+
+@d set_callback_option(A) do { mp->A = mp_##A;
+ if (opt->A!=NULL) mp->A = opt->A;
+} while (0)
+
+@c
+static MP mp_do_new (jmp_buf * buf) {
+ MP mp = malloc (sizeof (MP_instance));
+ if (mp == NULL) {
+ xfree (buf);
+ return NULL;
+ }
+ memset (mp, 0, sizeof (MP_instance));
+ mp->jump_buf = buf;
+ return mp;
+}
+
+
+@ @c
+static void mp_free (MP mp) {
+ int k; /* loop variable */
+ @<Dealloc variables@>;
+ if (mp->noninteractive) {
+ @<Finish non-interactive use@>;
+ }
+ xfree (mp->jump_buf);
+ @<Free table entries@>;
+ free_math();
+ xfree (mp);
+}
+
+
+@ @c
+static void mp_do_initialize (MP mp) {
+ @<Local variables for initialization@>;
+ @<Set initial values of key variables@>;
+}
+
+@ For the retargetable math library, we need to have a pointer, at least.
+
+@<Global variables@>=
+void *math;
+
+@ @<Exported types@>=
+typedef enum {
+ mp_nan_type = 0,
+ mp_scaled_type,
+ mp_fraction_type,
+ mp_angle_type,
+ mp_double_type,
+ mp_binary_type,
+ mp_decimal_type
+} mp_number_type;
+typedef union {
+ void *num;
+ double dval;
+ int val;
+} mp_number_store;
+typedef struct mp_number_data {
+ mp_number_store data;
+ mp_number_type type;
+} mp_number_data;
+typedef struct mp_number_data mp_number;
+#define is_number(A) ((A).type != mp_nan_type)
+
+typedef void (*convert_func) (mp_number *r);
+typedef void (*m_log_func) (MP mp, mp_number *r, mp_number a);
+typedef void (*m_exp_func) (MP mp, mp_number *r, mp_number a);
+typedef void (*m_unif_rand_func) (MP mp, mp_number *ret, mp_number x_orig);
+typedef void (*m_norm_rand_func) (MP mp, mp_number *ret);
+typedef void (*pyth_add_func) (MP mp, mp_number *r, mp_number a, mp_number b);
+typedef void (*pyth_sub_func) (MP mp, mp_number *r, mp_number a, mp_number b);
+typedef void (*n_arg_func) (MP mp, mp_number *r, mp_number a, mp_number b);
+typedef void (*velocity_func) (MP mp, mp_number *r, mp_number a, mp_number b, mp_number c, mp_number d, mp_number e);
+typedef void (*ab_vs_cd_func) (MP mp, mp_number *r, mp_number a, mp_number b, mp_number c, mp_number d);
+typedef void (*crossing_point_func) (MP mp, mp_number *r, mp_number a, mp_number b, mp_number c);
+typedef void (*number_from_int_func) (mp_number *A, int B);
+typedef void (*number_from_boolean_func) (mp_number *A, int B);
+typedef void (*number_from_scaled_func) (mp_number *A, int B);
+typedef void (*number_from_double_func) (mp_number *A, double B);
+typedef void (*number_from_addition_func) (mp_number *A, mp_number B, mp_number C);
+typedef void (*number_from_substraction_func) (mp_number *A, mp_number B, mp_number C);
+typedef void (*number_from_div_func) (mp_number *A, mp_number B, mp_number C);
+typedef void (*number_from_mul_func) (mp_number *A, mp_number B, mp_number C);
+typedef void (*number_from_int_div_func) (mp_number *A, mp_number B, int C);
+typedef void (*number_from_int_mul_func) (mp_number *A, mp_number B, int C);
+typedef void (*number_from_oftheway_func) (MP mp, mp_number *A, mp_number t, mp_number B, mp_number C);
+typedef void (*number_negate_func) (mp_number *A);
+typedef void (*number_add_func) (mp_number *A, mp_number B);
+typedef void (*number_substract_func) (mp_number *A, mp_number B);
+typedef void (*number_modulo_func) (mp_number *A, mp_number B);
+typedef void (*number_half_func) (mp_number *A);
+typedef void (*number_halfp_func) (mp_number *A);
+typedef void (*number_double_func) (mp_number *A);
+typedef void (*number_abs_func) (mp_number *A);
+typedef void (*number_clone_func) (mp_number *A, mp_number B);
+typedef void (*number_swap_func) (mp_number *A, mp_number *B);
+typedef void (*number_add_scaled_func) (mp_number *A, int b);
+typedef void (*number_multiply_int_func) (mp_number *A, int b);
+typedef void (*number_divide_int_func) (mp_number *A, int b);
+typedef int (*number_to_int_func) (mp_number A);
+typedef int (*number_to_boolean_func) (mp_number A);
+typedef int (*number_to_scaled_func) (mp_number A);
+typedef int (*number_round_func) (mp_number A);
+typedef void (*number_floor_func) (mp_number *A);
+typedef double (*number_to_double_func) (mp_number A);
+typedef int (*number_odd_func) (mp_number A);
+typedef int (*number_equal_func) (mp_number A, mp_number B);
+typedef int (*number_less_func) (mp_number A, mp_number B);
+typedef int (*number_greater_func) (mp_number A, mp_number B);
+typedef int (*number_nonequalabs_func) (mp_number A, mp_number B);
+typedef void (*make_scaled_func) (MP mp, mp_number *ret, mp_number A, mp_number B);
+typedef void (*make_fraction_func) (MP mp, mp_number *ret, mp_number A, mp_number B);
+typedef void (*take_fraction_func) (MP mp, mp_number *ret, mp_number A, mp_number B);
+typedef void (*take_scaled_func) (MP mp, mp_number *ret, mp_number A, mp_number B);
+typedef void (*sin_cos_func) (MP mp, mp_number A, mp_number *S, mp_number *C);
+typedef void (*slow_add_func) (MP mp, mp_number *A, mp_number S, mp_number C);
+typedef void (*sqrt_func) (MP mp, mp_number *ret, mp_number A);
+typedef void (*init_randoms_func) (MP mp, int seed);
+typedef void (*new_number_func) (MP mp, mp_number *A, mp_number_type t);
+typedef void (*free_number_func) (MP mp, mp_number *n);
+typedef void (*fraction_to_round_scaled_func) (mp_number *n);
+typedef void (*print_func) (MP mp, mp_number A);
+typedef char * (*tostring_func) (MP mp, mp_number A);
+typedef void (*scan_func) (MP mp, int A);
+typedef void (*mp_free_func) (MP mp);
+typedef void (*set_precision_func) (MP mp);
+
+typedef struct math_data {
+ mp_number precision_default;
+ mp_number precision_max;
+ mp_number precision_min;
+ mp_number epsilon_t;
+ mp_number inf_t;
+ mp_number one_third_inf_t;
+ mp_number zero_t;
+ mp_number unity_t;
+ mp_number two_t;
+ mp_number three_t;
+ mp_number half_unit_t;
+ mp_number three_quarter_unit_t;
+ mp_number fraction_one_t;
+ mp_number fraction_half_t;
+ mp_number fraction_three_t;
+ mp_number fraction_four_t;
+ mp_number one_eighty_deg_t;
+ mp_number three_sixty_deg_t;
+ mp_number one_k;
+ mp_number sqrt_8_e_k;
+ mp_number twelve_ln_2_k;
+ mp_number coef_bound_k;
+ mp_number coef_bound_minus_1;
+ mp_number twelvebits_3;
+ mp_number arc_tol_k;
+ mp_number twentysixbits_sqrt2_t;
+ mp_number twentyeightbits_d_t;
+ mp_number twentysevenbits_sqrt2_d_t;
+ mp_number fraction_threshold_t;
+ mp_number half_fraction_threshold_t;
+ mp_number scaled_threshold_t;
+ mp_number half_scaled_threshold_t;
+ mp_number near_zero_angle_t;
+ mp_number p_over_v_threshold_t;
+ mp_number equation_threshold_t;
+ mp_number tfm_warn_threshold_t;
+ mp_number warning_limit_t;
+ new_number_func allocate;
+ free_number_func free;
+ number_from_int_func from_int;
+ number_from_boolean_func from_boolean;
+ number_from_scaled_func from_scaled;
+ number_from_double_func from_double;
+ number_from_addition_func from_addition;
+ number_from_substraction_func from_substraction;
+ number_from_div_func from_div;
+ number_from_mul_func from_mul;
+ number_from_int_div_func from_int_div;
+ number_from_int_mul_func from_int_mul;
+ number_from_oftheway_func from_oftheway;
+ number_negate_func negate;
+ number_add_func add;
+ number_substract_func substract;
+ number_half_func half;
+ number_modulo_func modulo;
+ number_halfp_func halfp;
+ number_double_func do_double;
+ number_abs_func abs;
+ number_clone_func clone;
+ number_swap_func swap;
+ number_add_scaled_func add_scaled;
+ number_multiply_int_func multiply_int;
+ number_divide_int_func divide_int;
+ number_to_int_func to_int;
+ number_to_boolean_func to_boolean;
+ number_to_scaled_func to_scaled;
+ number_to_double_func to_double;
+ number_odd_func odd;
+ number_equal_func equal;
+ number_less_func less;
+ number_greater_func greater;
+ number_nonequalabs_func nonequalabs;
+ number_round_func round_unscaled;
+ number_floor_func floor_scaled;
+ make_scaled_func make_scaled;
+ make_fraction_func make_fraction;
+ take_fraction_func take_fraction;
+ take_scaled_func take_scaled;
+ velocity_func velocity;
+ ab_vs_cd_func ab_vs_cd;
+ crossing_point_func crossing_point;
+ n_arg_func n_arg;
+ m_log_func m_log;
+ m_exp_func m_exp;
+ m_unif_rand_func m_unif_rand;
+ m_norm_rand_func m_norm_rand;
+ pyth_add_func pyth_add;
+ pyth_sub_func pyth_sub;
+ fraction_to_round_scaled_func fraction_to_round_scaled;
+ convert_func fraction_to_scaled;
+ convert_func scaled_to_fraction;
+ convert_func scaled_to_angle;
+ convert_func angle_to_scaled;
+ init_randoms_func init_randoms;
+ sin_cos_func sin_cos;
+ sqrt_func sqrt;
+ slow_add_func slow_add;
+ print_func print;
+ tostring_func tostring;
+ scan_func scan_numeric;
+ scan_func scan_fractional;
+ mp_free_func free_math;
+ set_precision_func set_precision;
+} math_data;
+
+
+
+@ This procedure gets things started properly.
+@c
+MP mp_initialize (MP_options * opt) {
+ MP mp;
+ jmp_buf *buf = malloc (sizeof (jmp_buf));
+ if (buf == NULL || setjmp (*buf) != 0)
+ return NULL;
+ mp = mp_do_new (buf);
+ if (mp == NULL)
+ return NULL;
+ mp->userdata = opt->userdata;
+ mp->noninteractive = opt->noninteractive;
+ mp->extensions = opt->extensions;
+ set_callback_option (find_file);
+ set_callback_option (open_file);
+ set_callback_option (read_ascii_file);
+ set_callback_option (read_binary_file);
+ set_callback_option (close_file);
+ set_callback_option (eof_file);
+ set_callback_option (flush_file);
+ set_callback_option (write_ascii_file);
+ set_callback_option (write_binary_file);
+ set_callback_option (shipout_backend);
+ set_callback_option (run_script);
+ set_callback_option (make_text);
+ if (opt->banner && *(opt->banner)) {
+ mp->banner = xstrdup (opt->banner);
+ } else {
+ mp->banner = xstrdup (default_banner);
+ }
+ if (opt->command_line && *(opt->command_line))
+ mp->command_line = xstrdup (opt->command_line);
+ if (mp->noninteractive) {
+ @<Prepare function pointers for non-interactive use@>;
+ }
+ /* open the terminal for output */
+ t_open_out();
+#if DEBUG
+ setvbuf(stdout, (char *) NULL, _IONBF, 0);
+ setvbuf(mp->term_out, (char *) NULL, _IONBF, 0);
+#endif
+ if (opt->math_mode == mp_math_scaled_mode) {
+ mp->math = mp_initialize_scaled_math(mp);
+ } else if (opt->math_mode == mp_math_decimal_mode) {
+ mp->math = mp_initialize_decimal_math(mp);
+ } else if (opt->math_mode == mp_math_binary_mode) {
+ mp->math = mp_initialize_binary_math(mp);
+ } else {
+ mp->math = mp_initialize_double_math(mp);
+ }
+ @<Find and load preload file, if required@>;
+ @<Allocate or initialize variables@>;
+ mp_reallocate_paths (mp, 1000);
+ mp_reallocate_fonts (mp, 8);
+ mp->history = mp_fatal_error_stop; /* in case we quit during initialization */
+ @<Check the ``constant'' values...@>; /* consider also the raise of the bits for precision */
+ if (mp->bad > 0) {
+ char ss[256];
+ mp_snprintf (ss, 256, "Ouch---my internal constants have been clobbered!\n"
+ "---case %i", (int) mp->bad);
+ mp_fputs ((char *) ss, mp->err_out);
+@.Ouch...clobbered@>;
+ return mp;
+ }
+ mp_do_initialize (mp); /* erase preloaded mem */
+ mp_init_tab (mp); /* initialize the tables */
+ if (opt->math_mode == mp_math_scaled_mode) {
+ set_internal_string (mp_number_system, mp_intern (mp, "scaled"));
+ } else if (opt->math_mode == mp_math_decimal_mode) {
+ set_internal_string (mp_number_system, mp_intern (mp, "decimal"));
+ } else if (opt->math_mode == mp_math_binary_mode) {
+ set_internal_string (mp_number_system, mp_intern (mp, "binary"));
+ } else {
+ set_internal_string (mp_number_system, mp_intern (mp, "double"));
+ }
+ mp_init_prim (mp); /* call |primitive| for each primitive */
+ mp_fix_date_and_time (mp);
+ if (!mp->noninteractive) {
+ @<Initialize the output routines@>;
+ @<Get the first line of input and prepare to start@>;
+ @<Initializations after first line is read@>;
+ @<Fix up |mp->internal[mp_job_name]|@>;
+ } else {
+ mp->history = mp_spotless;
+ }
+ set_precision();
+ return mp;
+}
+
+
+@ @<Initializations after first line is read@>=
+mp_open_log_file (mp);
+mp_set_job_id (mp);
+mp_init_map_file (mp, mp->troff_mode);
+mp->history = mp_spotless; /* ready to go! */
+if (mp->troff_mode) {
+ number_clone (internal_value (mp_gtroffmode), unity_t);
+ number_clone (internal_value (mp_prologues), unity_t);
+}
+if (mp->start_sym != NULL) { /* insert the `\&{everyjob}' symbol */
+ set_cur_sym (mp->start_sym);
+ mp_back_input (mp);
+}
+
+@ @<Exported function headers@>=
+extern MP_options *mp_options (void);
+extern MP mp_initialize (MP_options * opt);
+extern int mp_status (MP mp);
+extern boolean mp_finished (MP mp);
+extern void *mp_userdata (MP mp);
+
+@ @c
+int mp_status (MP mp) {
+ return mp->history;
+}
+
+
+@ @c
+boolean mp_finished (MP mp) {
+ return mp->finished;
+}
+
+
+
+@ @c
+void *mp_userdata (MP mp) {
+ return mp->userdata;
+}
+
+
+@ The overall \MP\ program begins with the heading just shown, after which
+comes a bunch of procedure declarations and function declarations.
+Finally we will get to the main program, which begins with the
+comment `|start_here|'. If you want to skip down to the
+main program now, you can look up `|start_here|' in the index.
+But the author suggests that the best way to understand this program
+is to follow pretty much the order of \MP's components as they appear in the
+\.{WEB} description you are now reading, since the present ordering is
+intended to combine the advantages of the ``bottom up'' and ``top down''
+approaches to the problem of understanding a somewhat complicated system.
+
+@ Some of the code below is intended to be used only when diagnosing the
+strange behavior that sometimes occurs when \MP\ is being installed or
+when system wizards are fooling around with \MP\ without quite knowing
+what they are doing. Such code will not normally be compiled; it is
+delimited by the preprocessor test `|#ifdef DEBUG .. #endif|'.
+
+@ The following parameters can be changed at compile time to extend or
+reduce \MP's capacity.
+@^system dependencies@>
+
+@<Constants...@>=
+#define bistack_size 1500 /* size of stack for bisection algorithms;
+ should probably be left at this value */
+
+@ Like the preceding parameters, the following quantities can be changed
+to extend or reduce \MP's capacity.
+
+@ @<Glob...@>=
+int pool_size; /* maximum number of characters in strings, including all
+ error messages and help texts, and the names of all identifiers */
+int max_in_open; /* maximum number of input files and error insertions that
+ can be going on simultaneously */
+int param_size; /* maximum number of simultaneous macro parameters */
+
+@ @<Option variables@>=
+int error_line; /* width of context lines on terminal error messages */
+int half_error_line; /* width of first lines of contexts in terminal
+ error messages; should be between 30 and |error_line-15| */
+int halt_on_error; /* do we quit at the first error? */
+int max_print_line; /* width of longest text lines output; should be at least 60 */
+void *userdata; /* this allows the calling application to setup local */
+char *banner; /* the banner that is printed to the screen and log */
+int ini_version;
+int utf8_mode;
+
+@ @<Dealloc variables@>=
+xfree (mp->banner);
+
+@
+@d set_lower_limited_value(a,b,c) do { a=c; if (b>c) a=b; } while (0)
+
+@<Allocate or ...@>=
+mp->param_size = 4;
+mp->max_in_open = 0;
+mp->pool_size = 10000;
+set_lower_limited_value (mp->error_line, opt->error_line, 79);
+set_lower_limited_value (mp->half_error_line, opt->half_error_line, 50);
+if (mp->half_error_line > mp->error_line - 15)
+ mp->half_error_line = mp->error_line - 15;
+mp->max_print_line = 100;
+set_lower_limited_value (mp->max_print_line, opt->max_print_line, 79);
+mp->halt_on_error = (opt->halt_on_error ? true : false);
+mp->ini_version = (opt->ini_version ? true : false);
+mp->utf8_mode = (opt->utf8_mode ? true : false);
+
+@ In case somebody has inadvertently made bad settings of the ``constants,''
+\MP\ checks them using a global variable called |bad|.
+
+This is the second of many sections of \MP\ where global variables are
+defined.
+
+@<Glob...@>=
+integer bad; /* is some ``constant'' wrong? */
+
+@ Later on we will say `|if ( int_packets+(17+2)*int_increment>bistack_size )mp->bad=19;|',
+or something similar.
+
+In case you are wondering about the non-consequtive values of |bad|: most
+of the things that used to be WEB constants are now runtime variables
+with checking at assignment time.
+
+@<Check the ``constant'' values for consistency@>=
+mp->bad = 0;
+
+@ Here are some macros for common programming idioms.
+
+@d incr(A) (A)=(A)+1 /* increase a variable by unity */
+@d decr(A) (A)=(A)-1 /* decrease a variable by unity */
+@d negate(A) (A)=-(A) /* change the sign of a variable */
+@d double(A) (A)=(A)+(A)
+@d odd(A) (abs(A)%2==1)
+
+@* The character set.
+In order to make \MP\ readily portable to a wide variety of
+computers, all of its input text is converted to an internal eight-bit
+code that includes standard ASCII, the ``American Standard Code for
+Information Interchange.'' This conversion is done immediately when each
+character is read in. Conversely, characters are converted from ASCII to
+the user's external representation just before they are output to a
+text file.
+@^ASCII code@>
+
+Such an internal code is relevant to users of \MP\ only with respect to
+the \&{char} and \&{ASCII} operations, and the comparison of strings.
+
+@ Characters of text that have been converted to \MP's internal form
+are said to be of type |ASCII_code|, which is a subrange of the integers.
+
+@<Types...@>=
+typedef unsigned char ASCII_code; /* eight-bit numbers */
+
+@ The present specification of \MP\ has been written under the assumption
+that the character set contains at least the letters and symbols associated
+with ASCII codes 040 through 0176; all of these characters are now
+available on most computer terminals.
+
+@<Types...@>=
+typedef unsigned char text_char; /* the data type of characters in text files */
+
+@ @<Local variables for init...@>=
+integer i;
+
+@ The \MP\ processor converts between ASCII code and
+the user's external character set by means of arrays |xord| and |xchr|
+that are analogous to Pascal's |ord| and |chr| functions.
+
+@<MPlib internal header stuff@>=
+#define xchr(A) mp->xchr[(A)]
+#define xord(A) mp->xord[(A)]
+
+@ @<Glob...@>=
+ASCII_code xord[256]; /* specifies conversion of input characters */
+text_char xchr[256]; /* specifies conversion of output characters */
+
+@ The core system assumes all 8-bit is acceptable. If it is not,
+a change file has to alter the below section.
+@^system dependencies@>
+
+Additionally, people with extended character sets can
+assign codes arbitrarily, giving an |xchr| equivalent to whatever
+characters the users of \MP\ are allowed to have in their input files.
+Appropriate changes to \MP's |char_class| table should then be made.
+(Unlike \TeX, each installation of \MP\ has a fixed assignment of category
+codes, called the |char_class|.) Such changes make portability of programs
+more difficult, so they should be introduced cautiously if at all.
+@^character set dependencies@>
+@^system dependencies@>
+
+@<Set initial ...@>=
+for (i = 0; i <= 0377; i++) {
+ xchr (i) = (text_char) i;
+}
+
+
+@ The following system-independent code makes the |xord| array contain a
+suitable inverse to the information in |xchr|. Note that if |xchr[i]=xchr[j]|
+where |i<j<0177|, the value of |xord[xchr[i]]| will turn out to be
+|j| or more; hence, standard ASCII code numbers will be used instead of
+codes below 040 in case there is a coincidence.
+
+@<Set initial ...@>=
+for (i = 0; i <= 255; i++) {
+ xord (xchr (i)) = 0177;
+}
+for (i = 0200; i <= 0377; i++) {
+ xord (xchr (i)) = (ASCII_code) i;
+}
+for (i = 0; i <= 0176; i++) {
+ xord (xchr (i)) = (ASCII_code) i;
+}
+
+
+@* Input and output.
+The bane of portability is the fact that different operating systems treat
+input and output quite differently, perhaps because computer scientists
+have not given sufficient attention to this problem. People have felt somehow
+that input and output are not part of ``real'' programming. Well, it is true
+that some kinds of programming are more fun than others. With existing
+input/output conventions being so diverse and so messy, the only sources of
+joy in such parts of the code are the rare occasions when one can find a
+way to make the program a little less bad than it might have been. We have
+two choices, either to attack I/O now and get it over with, or to postpone
+I/O until near the end. Neither prospect is very attractive, so let's
+get it over with.
+
+The basic operations we need to do are (1)~inputting and outputting of
+text, to or from a file or the user's terminal; (2)~inputting and
+outputting of eight-bit bytes, to or from a file; (3)~instructing the
+operating system to initiate (``open'') or to terminate (``close'') input or
+output from a specified file; (4)~testing whether the end of an input
+file has been reached; (5)~display of bits on the user's screen.
+The bit-display operation will be discussed in a later section; we shall
+deal here only with more traditional kinds of I/O.
+
+@ Finding files happens in a slightly roundabout fashion: the \MP\
+instance object contains a field that holds a function pointer that finds a
+file, and returns its name, or NULL. For this, it receives three
+parameters: the non-qualified name |fname|, the intended |fopen|
+operation type |fmode|, and the type of the file |ftype|.
+
+The file types that are passed on in |ftype| can be used to
+differentiate file searches if a library like kpathsea is used,
+the fopen mode is passed along for the same reason.
+
+@<Types...@>=
+typedef unsigned char eight_bits; /* unsigned one-byte quantity */
+
+@ @<Exported types@>=
+enum mp_filetype {
+ mp_filetype_terminal = 0, /* the terminal */
+ mp_filetype_error, /* the terminal */
+ mp_filetype_program, /* \MP\ language input */
+ mp_filetype_log, /* the log file */
+ mp_filetype_postscript, /* the postscript output */
+ mp_filetype_bitmap, /* the bitmap output file */
+ mp_filetype_memfile, /* memory dumps, obsolete */
+ mp_filetype_metrics, /* TeX font metric files */
+ mp_filetype_fontmap, /* PostScript font mapping files */
+ mp_filetype_font, /* PostScript type1 font programs */
+ mp_filetype_encoding, /* PostScript font encoding files */
+ mp_filetype_text /* first text file for readfrom and writeto primitives */
+};
+typedef char *(*mp_file_finder) (MP, const char *, const char *, int);
+typedef char *(*mp_script_runner) (MP, const char *);
+typedef char *(*mp_text_maker) (MP, const char *, int mode);
+typedef void *(*mp_file_opener) (MP, const char *, const char *, int);
+typedef char *(*mp_file_reader) (MP, void *, size_t *);
+typedef void (*mp_binfile_reader) (MP, void *, void **, size_t *);
+typedef void (*mp_file_closer) (MP, void *);
+typedef int (*mp_file_eoftest) (MP, void *);
+typedef void (*mp_file_flush) (MP, void *);
+typedef void (*mp_file_writer) (MP, void *, const char *);
+typedef void (*mp_binfile_writer) (MP, void *, void *, size_t);
+
+@ @<Option variables@>=
+mp_file_finder find_file;
+mp_file_opener open_file;
+mp_script_runner run_script;
+mp_text_maker make_text;
+mp_file_reader read_ascii_file;
+mp_binfile_reader read_binary_file;
+mp_file_closer close_file;
+mp_file_eoftest eof_file;
+mp_file_flush flush_file;
+mp_file_writer write_ascii_file;
+mp_binfile_writer write_binary_file;
+
+@ The default function for finding files is |mp_find_file|. It is
+pretty stupid: it will only find files in the current directory.
+
+@c
+static char *mp_find_file (MP mp, const char *fname, const char *fmode,
+ int ftype) {
+ (void) mp;
+ if (fmode[0] != 'r' || (!access (fname, R_OK)) || ftype) {
+ return mp_strdup (fname);
+ }
+ return NULL;
+}
+
+@ @c
+static char *mp_run_script (MP mp, const char *str) {
+ (void) mp;
+ return mp_strdup (str);
+}
+
+@ @c
+static char *mp_make_text (MP mp, const char *str, int mode) {
+ (void) mp;
+ return mp_strdup (str);
+}
+
+@ Because |mp_find_file| is used so early, it has to be in the helpers
+section.
+
+@<Declarations@>=
+static char *mp_find_file (MP mp, const char *fname, const char *fmode,
+ int ftype);
+static void *mp_open_file (MP mp, const char *fname, const char *fmode,
+ int ftype);
+static char *mp_read_ascii_file (MP mp, void *f, size_t * size);
+static void mp_read_binary_file (MP mp, void *f, void **d, size_t * size);
+static void mp_close_file (MP mp, void *f);
+static int mp_eof_file (MP mp, void *f);
+static void mp_flush_file (MP mp, void *f);
+static void mp_write_ascii_file (MP mp, void *f, const char *s);
+static void mp_write_binary_file (MP mp, void *f, void *s, size_t t);
+static char *mp_run_script (MP mp, const char *str);
+static char *mp_make_text (MP mp, const char *str, int mode);
+
+@ The function to open files can now be very short.
+
+@c
+void *mp_open_file (MP mp, const char *fname, const char *fmode, int ftype) {
+ char realmode[3];
+ (void) mp;
+ realmode[0] = *fmode;
+ realmode[1] = 'b';
+ realmode[2] = 0;
+ if (ftype == mp_filetype_terminal) {
+ return (fmode[0] == 'r' ? stdin : stdout);
+ } else if (ftype == mp_filetype_error) {
+ return stderr;
+ } else if (fname != NULL && (fmode[0] != 'r' || (!access (fname, R_OK)))) {
+ return (void *) fopen (fname, realmode);
+ }
+ return NULL;
+}
+
+
+@ (Almost) all file names pass through |name_of_file|.
+
+@<Glob...@>=
+char *name_of_file; /* the name of a system file */
+
+@ If this parameter is true, the terminal and log will report the found
+file names for input files instead of the requested ones.
+It is off by default because it creates an extra filename lookup.
+
+@<Option variables@>=
+int print_found_names; /* configuration parameter */
+
+@ @<Allocate or initialize ...@>=
+mp->print_found_names = (opt->print_found_names > 0 ? true : false);
+
+@ The |file_line_error_style| parameter makes \MP\ use a more
+standard compiler error message format instead of the Knuthian
+exclamation mark. It needs the actual version of the current input
+file name, that will be saved by |open_in| in the |long_name|.
+
+TODO: currently these long strings cause memory leaks, because they cannot
+be safely freed as they may appear in the |input_stack| multiple times.
+In fact, the current implementation is just a quick hack in response
+to a bug report for metapost 1.205.
+
+@d long_name mp->cur_input.long_name_field /* long name of the current file */
+
+@<Option variables@>=
+int file_line_error_style; /* configuration parameter */
+
+@ @<Allocate or initialize ...@>=
+mp->file_line_error_style = (opt->file_line_error_style > 0 ? true : false);
+
+@ \MP's file-opening procedures return |false| if no file identified by
+|name_of_file| could be opened.
+
+The |do_open_file| function takes care of the |print_found_names| parameter.
+
+@c
+static boolean mp_do_open_file (MP mp, void **f, int ftype, const char *mode) {
+ if (mp->print_found_names || mp->file_line_error_style) {
+ char *s = (mp->find_file)(mp,mp->name_of_file,mode,ftype);
+ if (s!=NULL) {
+ *f = (mp->open_file)(mp,mp->name_of_file,mode, ftype);
+ if (mp->print_found_names) {
+ xfree(mp->name_of_file);
+ mp->name_of_file = xstrdup(s);
+ }
+ if ((*mode == 'r') && (ftype == mp_filetype_program)) {
+ long_name = xstrdup(s);
+ }
+ xfree(s);
+ } else {
+ *f = NULL;
+ }
+ } else {
+ *f = (mp->open_file)(mp,mp->name_of_file,mode, ftype);
+ }
+ return (*f ? true : false);
+}
+@#
+static boolean mp_open_in (MP mp, void **f, int ftype) {
+ /* open a file for input */
+ return mp_do_open_file (mp, f, ftype, "r");
+}
+@#
+static boolean mp_open_out (MP mp, void **f, int ftype) {
+ /* open a file for output */
+ return mp_do_open_file (mp, f, ftype, "w");
+}
+
+
+@ @c
+static char *mp_read_ascii_file (MP mp, void *ff, size_t * size) {
+ int c;
+ size_t len = 0, lim = 128;
+ char *s = NULL;
+ FILE *f = (FILE *) ff;
+ *size = 0;
+ (void) mp; /* for -Wunused */
+ if (f == NULL)
+ return NULL;
+ c = fgetc (f);
+ if (c == EOF)
+ return NULL;
+ s = malloc (lim);
+ if (s == NULL)
+ return NULL;
+ while (c != EOF && c != '\n' && c != '\r') {
+ if ((len + 1) == lim) {
+ s = realloc (s, (lim + (lim >> 2)));
+ if (s == NULL)
+ return NULL;
+ lim += (lim >> 2);
+ }
+ s[len++] = (char) c;
+ c = fgetc (f);
+ }
+ if (c == '\r') {
+ c = fgetc (f);
+ if (c != EOF && c != '\n')
+ ungetc (c, f);
+ }
+ s[len] = 0;
+ *size = len;
+ return s;
+}
+
+
+@ @c
+void mp_write_ascii_file (MP mp, void *f, const char *s) {
+ (void) mp;
+ if (f != NULL) {
+ fputs (s, (FILE *) f);
+ }
+}
+
+
+@ @c
+void mp_read_binary_file (MP mp, void *f, void **data, size_t * size) {
+ size_t len = 0;
+ (void) mp;
+ if (f != NULL)
+ len = fread (*data, 1, *size, (FILE *) f);
+ *size = len;
+}
+
+
+@ @c
+void mp_write_binary_file (MP mp, void *f, void *s, size_t size) {
+ (void) mp;
+ if (f != NULL)
+ (void) fwrite (s, size, 1, (FILE *) f);
+}
+
+
+@ @c
+void mp_close_file (MP mp, void *f) {
+ (void) mp;
+ if (f != NULL)
+ fclose ((FILE *) f);
+}
+
+
+@ @c
+int mp_eof_file (MP mp, void *f) {
+ (void) mp;
+ if (f != NULL)
+ return feof ((FILE *) f);
+ else
+ return 1;
+}
+
+
+@ @c
+void mp_flush_file (MP mp, void *f) {
+ (void) mp;
+ if (f != NULL)
+ fflush ((FILE *) f);
+}
+
+
+@ Input from text files is read one line at a time, using a routine called
+|input_ln|. This function is defined in terms of global variables called
+|buffer|, |first|, and |last| that will be described in detail later; for
+now, it suffices for us to know that |buffer| is an array of |ASCII_code|
+values, and that |first| and |last| are indices into this array
+representing the beginning and ending of a line of text.
+
+@<Glob...@>=
+size_t buf_size; /* maximum number of characters simultaneously present in
+ current lines of open files */
+ASCII_code *buffer; /* lines of characters being read */
+size_t first; /* the first unused position in |buffer| */
+size_t last; /* end of the line just input to |buffer| */
+size_t max_buf_stack; /* largest index used in |buffer| */
+
+@ @<Allocate or initialize ...@>=
+mp->buf_size = 200;
+mp->buffer = xmalloc ((mp->buf_size + 1), sizeof (ASCII_code));
+
+@ @<Dealloc variables@>=
+xfree (mp->buffer);
+
+@ @c
+static void mp_reallocate_buffer (MP mp, size_t l) {
+ ASCII_code *buffer;
+ if (l > max_halfword) {
+ mp_confusion (mp, "buffer size"); /* can't happen (I hope) */
+ }
+ buffer = xmalloc ((l + 1), sizeof (ASCII_code));
+ (void) memcpy (buffer, mp->buffer, (mp->buf_size + 1));
+ xfree (mp->buffer);
+ mp->buffer = buffer;
+ mp->buf_size = l;
+}
+
+
+@ The |input_ln| function brings the next line of input from the specified
+field into available positions of the buffer array and returns the value
+|true|, unless the file has already been entirely read, in which case it
+returns |false| and sets |last:=first|. In general, the |ASCII_code|
+numbers that represent the next line of the file are input into
+|buffer[first]|, |buffer[first+1]|, \dots, |buffer[last-1]|; and the
+global variable |last| is set equal to |first| plus the length of the
+line. Trailing blanks are removed from the line; thus, either |last=first|
+(in which case the line was entirely blank) or |buffer[last-1]<>" "|.
+@^inner loop@>
+
+The variable |max_buf_stack|, which is used to keep track of how large
+the |buf_size| parameter must be to accommodate the present job, is
+also kept up to date by |input_ln|.
+
+@c
+static boolean mp_input_ln (MP mp, void *f) {
+ /* inputs the next line or returns |false| */
+ char *s;
+ size_t size = 0;
+ mp->last = mp->first; /* cf.\ Matthew 19\thinspace:\thinspace30 */
+ s = (mp->read_ascii_file) (mp, f, &size);
+ if (s == NULL)
+ return false;
+ if (size > 0) {
+ mp->last = mp->first + size;
+ if (mp->last >= mp->max_buf_stack) {
+ mp->max_buf_stack = mp->last + 1;
+ while (mp->max_buf_stack > mp->buf_size) {
+ mp_reallocate_buffer (mp, (mp->buf_size + (mp->buf_size >> 2)));
+ }
+ }
+ (void) memcpy ((mp->buffer + mp->first), s, size);
+ }
+ free (s);
+ return true;
+}
+
+
+@ The user's terminal acts essentially like other files of text, except
+that it is used both for input and for output. When the terminal is
+considered an input file, the file variable is called |term_in|, and when it
+is considered an output file the file variable is |term_out|.
+@^system dependencies@>
+
+@<Glob...@>=
+void *term_in; /* the terminal as an input file */
+void *term_out; /* the terminal as an output file */
+void *err_out; /* the terminal as an output file */
+
+@ Here is how to open the terminal files. In the default configuration,
+nothing happens except that the command line (if there is one) is copied
+to the input buffer. The variable |command_line| will be filled by the
+|main| procedure.
+
+@d t_open_out() do {/* open the terminal for text output */
+ mp->term_out = (mp->open_file)(mp,"terminal", "w", mp_filetype_terminal);
+ mp->err_out = (mp->open_file)(mp,"error", "w", mp_filetype_error);
+} while (0)
+@d t_open_in() do { /* open the terminal for text input */
+ mp->term_in = (mp->open_file)(mp,"terminal", "r", mp_filetype_terminal);
+ if (mp->command_line!=NULL) {
+ mp->last = strlen(mp->command_line);
+ if (mp->last > (mp->buf_size+1)) {
+ mp_reallocate_buffer(mp,mp->last);
+ }
+ (void)memcpy((void *)mp->buffer,(void *)mp->command_line,mp->last);
+ xfree(mp->command_line);
+ } else {
+ mp->last = 0;
+ }
+} while (0)
+
+@<Option variables@>=
+char *command_line;
+
+@ Sometimes it is necessary to synchronize the input/output mixture that
+happens on the user's terminal, and three system-dependent
+procedures are used for this
+purpose. The first of these, |update_terminal|, is called when we want
+to make sure that everything we have output to the terminal so far has
+actually left the computer's internal buffers and been sent.
+The second, |clear_terminal|, is called when we wish to cancel any
+input that the user may have typed ahead (since we are about to
+issue an unexpected error message). The third, |wake_up_terminal|,
+is supposed to revive the terminal if the user has disabled it by
+some instruction to the operating system. The following macros show how
+these operations can be specified:
+@^system dependencies@>
+
+@<MPlib internal header stuff@>=
+#define update_terminal() (mp->flush_file)(mp,mp->term_out) /* empty the terminal output buffer */
+#define clear_terminal() /* clear the terminal input buffer */
+#define wake_up_terminal() (mp->flush_file)(mp,mp->term_out)
+ /* cancel the user's cancellation of output */
+
+@ We need a special routine to read the first line of \MP\ input from
+the user's terminal. This line is different because it is read before we
+have opened the transcript file; there is sort of a ``chicken and
+egg'' problem here. If the user types `\.{input cmr10}' on the first
+line, or if some macro invoked by that line does such an \.{input},
+the transcript file will be named `\.{cmr10.log}'; but if no \.{input}
+commands are performed during the first line of terminal input, the transcript
+file will acquire its default name `\.{mpout.log}'. (The transcript file
+will not contain error messages generated by the first line before the
+first \.{input} command.)
+
+The first line is even more special. It's nice to let the user start
+running a \MP\ job by typing a command line like `\.{MP cmr10}'; in
+such a case, \MP\ will operate as if the first line of input were
+`\.{cmr10}', i.e., the first line will consist of the remainder of the
+command line, after the part that invoked \MP.
+
+@ Different systems have different ways to get started. But regardless of
+what conventions are adopted, the routine that initializes the terminal
+should satisfy the following specifications:
+
+\yskip\textindent{1)}It should open file |term_in| for input from the
+ terminal. (The file |term_out| will already be open for output to the
+ terminal.)
+
+\textindent{2)}If the user has given a command line, this line should be
+ considered the first line of terminal input. Otherwise the
+ user should be prompted with `\.{**}', and the first line of input
+ should be whatever is typed in response.
+
+\textindent{3)}The first line of input, which might or might not be a
+ command line, should appear in locations |first| to |last-1| of the
+ |buffer| array.
+
+\textindent{4)}The global variable |loc| should be set so that the
+ character to be read next by \MP\ is in |buffer[loc]|. This
+ character should not be blank, and we should have |loc<last|.
+
+\yskip\noindent(It may be necessary to prompt the user several times
+before a non-blank line comes in. The prompt is `\.{**}' instead of the
+later `\.*' because the meaning is slightly different: `\.{input}' need
+not be typed immediately after~`\.{**}'.)
+
+@d loc mp->cur_input.loc_field /* location of first unread character in |buffer| */
+
+@c
+boolean mp_init_terminal (MP mp) { /* gets the terminal input started */
+ t_open_in();
+ if (mp->last != 0) {
+ loc = 0;
+ mp->first = 0;
+ return true;
+ }
+ while (1) {
+ if (!mp->noninteractive) {
+ wake_up_terminal();
+ mp_fputs ("**", mp->term_out);
+@.**@>;
+ update_terminal();
+ }
+ if (!mp_input_ln (mp, mp->term_in)) { /* this shouldn't happen */
+ mp_fputs ("\n! End of file on the terminal... why?", mp->term_out);
+@.End of file on the terminal@>;
+ return false;
+ }
+ loc = (halfword) mp->first;
+ while ((loc < (int) mp->last) && (mp->buffer[loc] == ' '))
+ incr (loc);
+ if (loc < (int) mp->last) {
+ return true; /* return unless the line was all blank */
+ }
+ if (!mp->noninteractive) {
+ mp_fputs ("Please type the name of your input file.\n", mp->term_out);
+ }
+ }
+}
+
+
+@ @<Declarations@>=
+static boolean mp_init_terminal (MP mp);
+
+@* Globals for strings.
+
+@ Symbolic token names and diagnostic messages are variable-length strings
+of eight-bit characters. Many strings \MP\ uses are simply literals
+in the compiled source, like the error messages and the names of the
+internal parameters. Other strings are used or defined from the \MP\ input
+language, and these have to be interned.
+
+\MP\ uses strings more extensively than \MF\ does, but the necessary
+operations can still be handled with a fairly simple data structure.
+The avl tree |strings| contains all of the known string structures.
+
+Each structure contains an |unsigned char| pointer containing the eight-bit
+data, a |size_t| that holds the length of that data, and an |int| that
+indicates how often this string is referenced (this will be explained below).
+Such strings are referred to by structure pointers called |mp_string|.
+
+Besides the avl tree, there is a set of three variables called |cur_string|,
+|cur_length| and |cur_string_size| that are used for strings while they are
+being built.
+
+@<Exported types...@>=
+typedef struct {
+ unsigned char *str; /* the string value */
+ size_t len; /* its length */
+ int refs; /* number of references */
+} mp_lstring;
+typedef mp_lstring *mp_string; /* for pointers to string values */
+
+@ The string handling functions are in \.{mpstrings.w}, but strings
+need a bunch of globals and those are defined here in the main file.
+
+@<Glob...@>=
+avl_tree strings; /* string avl tree */
+unsigned char *cur_string; /* current string buffer */
+size_t cur_length; /* current index in that buffer */
+size_t cur_string_size; /* malloced size of |cur_string| */
+
+@ @<Allocate or initialize ...@>=
+mp_initialize_strings(mp);
+
+@ @<Dealloc variables@>=
+mp_dealloc_strings(mp);
+
+@ The next four variables are for keeping track of string memory usage.
+
+@<Glob...@>=
+integer pool_in_use; /* total number of string bytes actually in use */
+integer max_pl_used; /* maximum |pool_in_use| so far */
+integer strs_in_use; /* total number of strings actually in use */
+integer max_strs_used; /* maximum |strs_in_use| so far */
+
+
+@* On-line and off-line printing.
+Messages that are sent to a user's terminal and to the transcript-log file
+are produced by several `|print|' procedures. These procedures will
+direct their output to a variety of places, based on the setting of
+the global variable |selector|, which has the following possible
+values:
+
+\yskip
+\hang |term_and_log|, the normal setting, prints on the terminal and on the
+ transcript file.
+
+\hang |log_only|, prints only on the transcript file.
+
+\hang |term_only|, prints only on the terminal.
+
+\hang |no_print|, doesn't print at all. This is used only in rare cases
+ before the transcript file is open.
+
+\hang |pseudo|, puts output into a cyclic buffer that is used
+ by the |show_context| routine; when we get to that routine we shall discuss
+ the reasoning behind this curious mode.
+
+\hang |new_string|, appends the output to the current string in the
+ string pool.
+
+\hang |>=write_file| prints on one of the files used for the \&{write}
+@:write_}{\&{write} primitive@>
+ command.
+
+\yskip
+\noindent The symbolic names `|term_and_log|', etc., have been assigned
+numeric codes that satisfy the convenient relations |no_print+1=term_only|,
+|no_print+2=log_only|, |term_only+2=log_only+1=term_and_log|. These
+relations are not used when |selector| could be |pseudo|, or |new_string|.
+We need not check for unprintable characters when |selector<pseudo|.
+
+Three additional global variables, |tally|, |term_offset| and |file_offset|
+record the number of characters that have been printed
+since they were most recently cleared to zero. We use |tally| to record
+the length of (possibly very long) stretches of printing; |term_offset|,
+and |file_offset|, on the other hand, keep track of how many
+characters have appeared so far on the current line that has been output
+to the terminal, the transcript file, or the \ps\ output file, respectively.
+
+@d new_string 0 /* printing is deflected to the string pool */
+@d pseudo 2 /* special |selector| setting for |show_context| */
+@d no_print 3 /* |selector| setting that makes data disappear */
+@d term_only 4 /* printing is destined for the terminal only */
+@d log_only 5 /* printing is destined for the transcript file only */
+@d term_and_log 6 /* normal |selector| setting */
+@d write_file 7 /* first write file selector */
+
+@<Glob...@>=
+void *log_file; /* transcript of \MP\ session */
+void *output_file; /* the generic font output goes here */
+unsigned int selector; /* where to print a message */
+integer tally; /* the number of characters recently printed */
+unsigned int term_offset;
+ /* the number of characters on the current terminal line */
+unsigned int file_offset;
+ /* the number of characters on the current file line */
+ASCII_code *trick_buf; /* circular buffer for pseudoprinting */
+integer trick_count; /* threshold for pseudoprinting, explained later */
+integer first_count; /* another variable for pseudoprinting */
+
+@ The first 128 strings will contain 95 standard ASCII characters, and the
+other 33 characters will be printed in three-symbol form like `\.{\^\^A}'
+unless a system-dependent change is made here. Installations that have
+an extended character set, where for example |xchr[032]=@t\.{'^^Z'}@>|,
+would like string 032 to be printed as the single character 032 instead
+of the three characters 0136, 0136, 0132 (\.{\^\^Z}). On the other hand,
+even people with an extended character set will want to represent string
+015 by \.{\^\^M}, since 015 is ASCII's ``carriage return'' code; the idea is
+to produce visible strings instead of tabs or line-feeds or carriage-returns
+or bell-rings or characters that are treated anomalously in text files.
+
+The boolean expression defined here should be |true| unless \MP\ internal
+code number~|k| corresponds to a non-troublesome visible symbol in the
+local character set.
+If character |k| cannot be printed, and |k<0200|, then character |k+0100| or
+|k-0100| must be printable; moreover, ASCII codes |[060..071, 0141..0146]|
+must be printable.
+@^character set dependencies@>
+@^system dependencies@>
+
+@<Character |k| cannot be printed@>=
+(k < ' ') || (k == 127)
+
+@ @<Allocate or initialize ...@>=
+mp->trick_buf = xmalloc ((mp->error_line + 1), sizeof (ASCII_code));
+
+@ @<Dealloc variables@>=
+xfree (mp->trick_buf);
+
+@ @<Initialize the output routines@>=
+mp->selector = term_only;
+mp->tally = 0;
+mp->term_offset = 0;
+mp->file_offset = 0;
+
+@ Macro abbreviations for output to the terminal and to the log file are
+defined here for convenience. Some systems need special conventions
+for terminal output, and it is possible to adhere to those conventions
+by changing |wterm|, |wterm_ln|, and |wterm_cr| here.
+@^system dependencies@>
+
+@<MPlib internal header stuff@>=
+#define mp_fputs(b,f) (mp->write_ascii_file)(mp,f,b)
+#define wterm(A) mp_fputs((A), mp->term_out)
+#define wterm_chr(A) { unsigned char ss[2]; ss[0]=(A); ss[1]='\0'; wterm((char *)ss);}
+#define wterm_cr mp_fputs("\n", mp->term_out)
+#define wterm_ln(A) { wterm_cr; mp_fputs((A), mp->term_out); }
+#define wlog(A) mp_fputs((A), mp->log_file)
+#define wlog_chr(A) { unsigned char ss[2]; ss[0]=(A); ss[1]='\0'; wlog((char *)ss);}
+#define wlog_cr mp_fputs("\n", mp->log_file)
+#define wlog_ln(A) { wlog_cr; mp_fputs((A), mp->log_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.
+
+@d mp_print_text(A) mp_print_str(mp,text((A)))
+
+@<Internal library ...@>=
+void mp_print (MP mp, const char *s);
+void mp_printf (MP mp, const char *ss, ...);
+void mp_print_ln (MP mp);
+void mp_print_char (MP mp, ASCII_code k);
+void mp_print_str (MP mp, mp_string s);
+void mp_print_nl (MP mp, const char *s);
+void mp_print_two (MP mp, mp_number x, mp_number y);
+
+@ @<Declarations@>=
+static void mp_print_visible_char (MP mp, ASCII_code s);
+
+@ @<Basic print...@>=
+void mp_print_ln (MP mp) { /* prints an end-of-line */
+ switch (mp->selector) {
+ case term_and_log:
+ wterm_cr;
+ wlog_cr;
+ mp->term_offset = 0;
+ mp->file_offset = 0;
+ break;
+ case log_only:
+ wlog_cr;
+ mp->file_offset = 0;
+ break;
+ case term_only:
+ wterm_cr;
+ mp->term_offset = 0;
+ break;
+ case no_print:
+ case pseudo:
+ case new_string:
+ break;
+ default:
+ mp_fputs ("\n", mp->wr_file[(mp->selector - write_file)]);
+ }
+} /* 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.
+
+@<Basic printing...@>=
+static void mp_print_visible_char (MP mp, ASCII_code s) { /* prints a single character */
+ switch (mp->selector) {
+ case term_and_log:
+ wterm_chr (xchr (s));
+ wlog_chr (xchr (s));
+ incr (mp->term_offset);
+ incr (mp->file_offset);
+ if (mp->term_offset == (unsigned) mp->max_print_line) {
+ wterm_cr;
+ mp->term_offset = 0;
+ };
+ if (mp->file_offset == (unsigned) mp->max_print_line) {
+ wlog_cr;
+ mp->file_offset = 0;
+ };
+ break;
+ case log_only:
+ wlog_chr (xchr (s));
+ incr (mp->file_offset);
+ if (mp->file_offset == (unsigned) mp->max_print_line)
+ mp_print_ln (mp);
+ break;
+ case term_only:
+ wterm_chr (xchr (s));
+ incr (mp->term_offset);
+ if (mp->term_offset == (unsigned) mp->max_print_line)
+ mp_print_ln (mp);
+ break;
+ case no_print:
+ break;
+ case pseudo:
+ if (mp->tally < mp->trick_count)
+ mp->trick_buf[mp->tally % mp->error_line] = s;
+ break;
+ case new_string:
+ append_char (s);
+ break;
+ default:
+ {
+ text_char ss[2] = {0,0};
+ ss[0] = xchr (s);
+ mp_fputs ((char *) ss, mp->wr_file[(mp->selector - write_file)]);
+ }
+ }
+ incr (mp->tally);
+}
+
+
+@ The |print_char| procedure sends one character to the desired destination.
+File names and string expressions might contain |ASCII_code| values that
+can't be printed using |print_visible_char|. These characters will be
+printed in three- or four-symbol form like `\.{\^\^A}' or `\.{\^\^e4}'.
+(This procedure assumes that it is safe to bypass all checks for unprintable
+characters when |selector| is in the range |0..max_write_files-1|.
+The user might want to write unprintable characters.
+
+@<Basic printing...@>=
+void mp_print_char (MP mp, ASCII_code k) { /* prints a single character */
+ if (mp->utf8_mode || mp->selector < pseudo || mp->selector >= write_file) {
+ mp_print_visible_char (mp, k);
+ } else if (@<Character |k| cannot be printed@>) {
+ mp_print (mp, "^^");
+ if (k < 0100) {
+ mp_print_visible_char (mp, (ASCII_code) (k + 0100));
+ } else if (k < 0200) {
+ mp_print_visible_char (mp, (ASCII_code) (k - 0100));
+ } else {
+ int l; /* small index or counter */
+ l = (k / 16);
+ mp_print_visible_char (mp, xord (l < 10 ? l + '0' : l - 10 + 'a'));
+ l = (k % 16);
+ mp_print_visible_char (mp, xord (l < 10 ? l + '0' : l - 10 + 'a'));
+ }
+ } else {
+ mp_print_visible_char (mp, k);
+ }
+}
+
+
+@ An entire string is output by calling |print|. Note that if we are outputting
+the single standard ASCII character \.c, we could call |print("c")|, since
+|"c"=99| is the number of a single-character string, as explained above. But
+|print_char("c")| is quicker, so \MP\ goes directly to the |print_char|
+routine when it knows that this is safe. (The present implementation
+assumes that it is always safe to print a visible ASCII character.)
+@^system dependencies@>
+
+@<Basic print...@>=
+static void mp_do_print (MP mp, const char *ss, size_t len) { /* prints string |s| */
+ if (len==0)
+ return;
+ if (mp->selector == new_string) {
+ str_room (len);
+ memcpy((mp->cur_string+mp->cur_length), ss, len);
+ mp->cur_length += len;
+ } else {
+ size_t j = 0;
+ while (j < len) {
+ /* this was |xord((int)ss[j])| but that doesnt work */
+ mp_print_char (mp, (ASCII_code) ss[j]);
+ j++;
+ }
+ }
+}
+
+
+@
+@<Basic print...@>=
+void mp_print (MP mp, const char *ss) {
+ assert (ss != NULL);
+ mp_do_print (mp, ss, strlen (ss));
+}
+void mp_printf (MP mp, const char *ss, ...) {
+ va_list ap;
+ char pval[256];
+ assert (ss != NULL);
+ va_start(ap, ss);
+ vsnprintf (pval, 256, ss, ap);
+ mp_do_print (mp, pval, strlen (pval));
+ va_end(ap);
+}
+
+void mp_print_str (MP mp, mp_string s) {
+ assert (s != NULL);
+ mp_do_print (mp, (const char *) s->str, s->len);
+}
+
+
+@ 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 (mp->banner);
+mp_print_ln (mp);
+update_terminal();
+
+@ The procedure |print_nl| is like |print|, but it makes sure that the
+string appears at the beginning of a new line.
+
+@<Basic print...@>=
+void mp_print_nl (MP mp, const char *s) { /* prints string |s| at beginning of line */
+ switch (mp->selector) {
+ case term_and_log:
+ if ((mp->term_offset > 0) || (mp->file_offset > 0))
+ mp_print_ln (mp);
+ break;
+ case log_only:
+ if (mp->file_offset > 0)
+ mp_print_ln (mp);
+ break;
+ case term_only:
+ if (mp->term_offset > 0)
+ mp_print_ln (mp);
+ break;
+ case no_print:
+ case pseudo:
+ case new_string:
+ break;
+ } /* there are no other cases */
+ mp_print (mp, s);
+}
+
+
+@ The following procedure, which prints out the decimal representation of a
+given integer |n|, assumes that all integers fit nicely into a |int|.
+@^system dependencies@>
+
+@<Basic print...@>=
+void mp_print_int (MP mp, integer n) { /* prints an integer in decimal form */
+ char s[12];
+ mp_snprintf (s, 12, "%d", (int) n);
+ mp_print (mp, s);
+}
+void mp_print_pointer (MP mp, void *n) { /* prints an pointer in hexadecimal form */
+ char s[12];
+ mp_snprintf (s, 12, "%p", n);
+ mp_print (mp, s);
+}
+
+@ @<Internal library ...@>=
+void mp_print_int (MP mp, integer n);
+void mp_print_pointer (MP mp, void *n);
+
+@ \MP\ also makes use of a trivial procedure to print two digits. The
+following subroutine is usually called with a parameter in the range |0<=n<=99|.
+
+@c
+static void mp_print_dd (MP mp, integer n) { /* prints two least significant digits */
+ n = MPOST_ABS (n) % 100;
+ mp_print_char (mp, xord ('0' + (n / 10)));
+ mp_print_char (mp, xord ('0' + (n % 10)));
+}
+
+
+@ @<Declarations@>=
+static void mp_print_dd (MP mp, integer n);
+
+@ Here is a procedure that asks the user to type a line of input,
+assuming that the |selector| setting is either |term_only| or |term_and_log|.
+The input is placed into locations |first| through |last-1| of the
+|buffer| array, and echoed on the transcript file if appropriate.
+
+This procedure is never called when |interaction<mp_scroll_mode|.
+
+@d prompt_input(A) do {
+ if (!mp->noninteractive) {
+ wake_up_terminal();
+ mp_print(mp, (A));
+ }
+ mp_term_input(mp);
+ } while (0) /* prints a string and gets a line of input */
+
+@c
+void mp_term_input (MP mp) { /* gets a line from the terminal */
+ size_t k; /* index into |buffer| */
+ if (mp->noninteractive) {
+ if (!mp_input_ln (mp, mp->term_in))
+ longjmp (*(mp->jump_buf), 1); /* chunk finished */
+ mp->buffer[mp->last] = xord ('%');
+ } else {
+ update_terminal(); /* Now the user sees the prompt for sure */
+ if (!mp_input_ln (mp, mp->term_in)) {
+ mp_fatal_error (mp, "End of file on the terminal!");
+@.End of file on the terminal@>
+ }
+ mp->term_offset = 0; /* the user's line ended with \<\rm return> */
+ decr (mp->selector); /* prepare to echo the input */
+ if (mp->last != mp->first) {
+ for (k = mp->first; k < mp->last; k++) {
+ mp_print_char (mp, mp->buffer[k]);
+ }
+ }
+ mp_print_ln (mp);
+ mp->buffer[mp->last] = xord ('%');
+ incr (mp->selector); /* restore previous status */
+ }
+}
+
+
+@* Reporting errors.
+
+The |print_err| procedure supplies a `\.!' before the official message,
+and makes sure that the terminal is awake if a stop is going to occur.
+The |error| procedure supplies a `\..' after the official message, then it
+shows the location of the error; and if |interaction=error_stop_mode|,
+it also enters into a dialog with the user, during which time the help
+message may be printed.
+@^system dependencies@>
+
+@ The global variable |interaction| has four settings, representing increasing
+amounts of user interaction:
+
+@<Exported types@>=
+enum mp_interaction_mode {
+ mp_unspecified_mode = 0, /* extra value for command-line switch */
+ mp_batch_mode, /* omits all stops and omits terminal output */
+ mp_nonstop_mode, /* omits all stops */
+ mp_scroll_mode, /* omits error stops */
+ mp_error_stop_mode /* stops at every opportunity to interact */
+};
+
+@ @<Option variables@>=
+int interaction; /* current level of interaction */
+int noninteractive; /* do we have a terminal? */
+int extensions;
+
+@ Set it here so it can be overwritten by the commandline
+
+@<Allocate or initialize ...@>=
+mp->interaction = opt->interaction;
+if (mp->interaction == mp_unspecified_mode
+ || mp->interaction > mp_error_stop_mode)
+ mp->interaction = mp_error_stop_mode;
+if (mp->interaction < mp_unspecified_mode)
+ mp->interaction = mp_batch_mode;
+
+@ |print_err| is not merged in |error| because it is also used in |prompt_file_name|,
+where |error| is not called at all.
+
+@<Declarations@>=
+static void mp_print_err (MP mp, const char *A);
+
+@ @c
+static void mp_print_err (MP mp, const char *A) {
+ if (mp->interaction == mp_error_stop_mode)
+ wake_up_terminal();
+ if (mp->file_line_error_style && file_state && !terminal_input) {
+ mp_print_nl (mp, "");
+ if (long_name != NULL) {
+ mp_print (mp, long_name);
+ } else {
+ mp_print (mp, mp_str (mp, name));
+ }
+ mp_print (mp, ":");
+ mp_print_int (mp, line);
+ mp_print (mp, ": ");
+ } else {
+ mp_print_nl (mp, "! ");
+ }
+ mp_print (mp, A);
+@.!\relax@>
+}
+
+
+@ \MP\ is careful not to call |error| when the print |selector| setting
+might be unusual. The only possible values of |selector| at the time of
+error messages are
+
+\yskip\hang|no_print| (when |interaction=mp_batch_mode|
+ and |log_file| not yet open);
+
+\hang|term_only| (when |interaction>mp_batch_mode| and |log_file| not yet open);
+
+\hang|log_only| (when |interaction=mp_batch_mode| and |log_file| is open);
+
+\hang|term_and_log| (when |interaction>mp_batch_mode| and |log_file| is open).
+
+@d initialize_print_selector() mp->selector = (mp->interaction == mp_batch_mode ? no_print : term_only);
+
+@ 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.
+
+@<Exported types@>=
+enum mp_history_state {
+ mp_spotless = 0, /* |history| value when nothing has been amiss yet */
+ mp_warning_issued, /* |history| value when |begin_diagnostic| has been called */
+ mp_error_message_issued, /* |history| value when |error| has been called */
+ mp_fatal_error_stop, /* |history| value when termination was premature */
+ mp_system_error_stop /* |history| value when termination was due to disaster */
+};
+
+@ @<Glob...@>=
+int history; /* has the source input been clean so far? */
+int error_count; /* the number of scrolled errors since the last statement ended */
+
+@ The value of |history| is initially |fatal_error_stop|, but it will
+be changed to |spotless| if \MP\ survives the initialization process.
+
+@ Since errors can be detected almost anywhere in \MP, we want to declare the
+error procedures near the beginning of the program. But the error procedures
+in turn use some other procedures, which need to be declared |forward|
+before we get to |error| itself.
+
+It is possible for |error| to be called recursively if some error arises
+when |get_next| is being used to delete a token, and/or if some fatal error
+occurs while \MP\ is trying to fix a non-fatal one. But such recursion
+@^recursion@>
+is never more than two levels deep.
+
+@<Declarations@>=
+static void mp_get_next (MP mp);
+static void mp_term_input (MP mp);
+static void mp_show_context (MP mp);
+static void mp_begin_file_reading (MP mp);
+static void mp_open_log_file (MP mp);
+static void mp_clear_for_error_prompt (MP mp);
+
+@ @<Internal ...@>=
+void mp_normalize_selector (MP mp);
+
+@ @<Glob...@>=
+boolean use_err_help; /* should the |err_help| string be shown? */
+mp_string err_help; /* a string set up by \&{errhelp} */
+
+@ @<Allocate or ...@>=
+mp->use_err_help = false;
+
+@ The |jump_out| procedure just cuts across all active procedure levels and
+goes to |end_of_MP|. This is the only nonlocal |goto| statement in the
+whole program. It is used when there is no recovery from a particular error.
+
+The program uses a |jump_buf| to handle this, this is initialized at three
+spots: the start of |mp_new|, the start of |mp_initialize|, and the start
+of |mp_run|. Those are the only library enty points.
+@^system dependencies@>
+
+@<Glob...@>=
+jmp_buf *jump_buf;
+
+@ If the array of internals is still |NULL| when |jump_out| is called, a
+crash occured during initialization, and it is not safe to run the normal
+cleanup routine.
+
+@<Error hand...@>=
+void mp_jump_out (MP mp) {
+ if (mp->internal != NULL && mp->history < mp_system_error_stop)
+ mp_close_files_and_terminate (mp);
+ longjmp (*(mp->jump_buf), 1);
+}
+
+@ @<Internal ...@>=
+void mp_jump_out (MP mp);
+
+@
+
+@<Error hand...@>=
+void mp_warn (MP mp, const char *msg) {
+ unsigned saved_selector = mp->selector;
+ mp_normalize_selector (mp);
+ mp_print_nl (mp, "Warning: ");
+ mp_print (mp, msg);
+ mp_print_ln (mp);
+ mp->selector = saved_selector;
+}
+
+@ Here now is the general |error| routine.
+
+The argument |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@>
+
+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.
+
+@c
+void mp_error (MP mp, const char *msg, const char **hlp, boolean deletions_allowed) {
+ ASCII_code c; /* what the user types */
+ integer s1, s2; /* used to save global variables when deleting tokens */
+ mp_sym s3; /* likewise */
+ int i = 0;
+ const char *help_line[6]; /* helps for the next |error| */
+ unsigned int help_ptr; /* the number of help lines present */
+ const char **cnt = NULL;
+ mp_print_err(mp, msg);
+ if (hlp) {
+ cnt = hlp;
+ while (*cnt) {
+ i++; cnt++;
+ }
+ cnt = hlp;
+ }
+ help_ptr=i;
+ while (i>0) {
+ help_line[--i]= *cnt++;
+ }
+ if (mp->history < mp_error_message_issued)
+ mp->history = mp_error_message_issued;
+ mp_print_char (mp, xord ('.'));
+ mp_show_context (mp);
+ if (mp->halt_on_error) {
+ mp->history = mp_fatal_error_stop;
+ mp_jump_out (mp);
+ }
+ if ((!mp->noninteractive) && (mp->interaction == mp_error_stop_mode)) {
+ @<Get user's advice and |return|@>;
+ }
+ incr (mp->error_count);
+ if (mp->error_count == 100) {
+ mp_print_nl (mp, "(That makes 100 errors; please try again.)");
+@.That makes 100 errors...@>;
+ mp->history = mp_fatal_error_stop;
+ mp_jump_out (mp);
+ }
+ @<Put help message on the transcript file@>;
+}
+
+
+@ @<Exported function ...@>=
+extern void mp_error (MP mp, const char *msg, const char **hlp, boolean deletions_allowed);
+extern void mp_warn (MP mp, const char *msg);
+
+
+@ @<Get user's advice...@>=
+while (true) {
+CONTINUE:
+ mp_clear_for_error_prompt (mp);
+ prompt_input ("? ");
+@.?\relax@>;
+ if (mp->last == mp->first)
+ return;
+ c = mp->buffer[mp->first];
+ if (c >= 'a')
+ c = (ASCII_code) (c + 'A' - 'a'); /* convert to uppercase */
+ @<Interpret code |c| and |return| if done@>;
+}
+
+
+@ It is desirable to provide an `\.E' option here that gives the user
+an easy way to return from \MP\ to the system editor, with the offending
+line ready to be edited. But such an extension requires some system
+wizardry, so the present implementation simply types out the name of the
+file that should be
+edited and the relevant line number.
+@^system dependencies@>
+
+@<Exported types@>=
+typedef void (*mp_editor_cmd) (MP, char *, int);
+
+@ @<Option variables@>=
+mp_editor_cmd run_editor;
+
+@ @<Allocate or initialize ...@>=
+set_callback_option (run_editor);
+
+@ @<Declarations@>=
+static void mp_run_editor (MP mp, char *fname, int fline);
+
+@ @c
+void mp_run_editor (MP mp, char *fname, int fline) {
+ char *s = xmalloc (256, 1);
+ mp_snprintf (s, 256, "You want to edit file %s at line %d\n", fname, fline);
+ wterm_ln (s);
+@.You want to edit file x@>
+}
+
+
+@
+
+@<Interpret code |c| and |return| if done@>=
+switch (c) {
+case '0':
+case '1':
+case '2':
+case '3':
+case '4':
+case '5':
+case '6':
+case '7':
+case '8':
+case '9':
+ if (deletions_allowed) {
+ @<Delete tokens and |continue|@>;
+ }
+ break;
+case 'E':
+ if (mp->file_ptr > 0) {
+ mp->interaction = mp_scroll_mode;
+ mp_close_files_and_terminate (mp);
+ (mp->run_editor) (mp,
+ mp_str (mp, mp->input_stack[mp->file_ptr].name_field),
+ mp_true_line (mp));
+ mp_jump_out (mp);
+ }
+ break;
+case 'H':
+ @<Print the help information and |continue|@>;
+ /* |break;| */
+case 'I':
+ @<Introduce new material from the terminal and |return|@>;
+ /* |break;| */
+case 'Q':
+case 'R':
+case 'S':
+ @<Change the interaction level and |return|@>;
+ /* |break;| */
+case 'X':
+ mp->interaction = mp_scroll_mode;
+ mp_jump_out (mp);
+ break;
+default:
+ break;
+}
+@<Print the menu of available options@>
+
+
+@ @<Print the menu...@>=
+{
+ mp_print (mp, "Type <return> to proceed, S to scroll future error messages,");
+@.Type <return> to proceed...@>;
+ mp_print_nl (mp, "R to run without stopping, Q to run quietly,");
+ mp_print_nl (mp, "I to insert something, ");
+ if (mp->file_ptr > 0)
+ mp_print (mp, "E to edit your file,");
+ if (deletions_allowed)
+ mp_print_nl (mp,
+ "1 or ... or 9 to ignore the next 1 to 9 tokens of input,");
+ mp_print_nl (mp, "H for help, X to quit.");
+}
+
+
+@ @<Change the interaction...@>=
+{
+ mp->error_count = 0;
+ mp_print (mp, "OK, entering ");
+ switch (c) {
+ case 'Q':
+ mp->interaction = mp_batch_mode;
+ mp_print (mp, "batchmode");
+ decr (mp->selector);
+ break;
+ case 'R':
+ mp->interaction = mp_nonstop_mode;
+ mp_print (mp, "nonstopmode");
+ break;
+ case 'S':
+ mp->interaction = mp_scroll_mode;
+ mp_print (mp, "scrollmode");
+ break;
+ } /* there are no other cases */
+ mp_print (mp, "...");
+ mp_print_ln (mp);
+ update_terminal();
+ return;
+}
+
+
+@ When the following code is executed, |buffer[(first+1)..(last-1)]| may
+contain the material inserted by the user; otherwise another prompt will
+be given. In order to understand this part of the program fully, you need
+to be familiar with \MP's input stacks.
+
+@<Introduce new material...@>=
+{
+ mp_begin_file_reading (mp); /* enter a new syntactic level for terminal input */
+ if (mp->last > mp->first + 1) {
+ loc = (halfword) (mp->first + 1);
+ mp->buffer[mp->first] = xord (' ');
+ } else {
+ prompt_input ("insert>");
+ loc = (halfword) mp->first;
+@.insert>@>
+ }
+ mp->first = mp->last + 1;
+ mp->cur_input.limit_field = (halfword) mp->last;
+ return;
+}
+
+
+@ We allow deletion of up to 99 tokens at a time.
+
+@<Delete tokens...@>=
+{
+ s1 = cur_cmd();
+ s2 = cur_mod();
+ s3 = cur_sym();
+ mp->OK_to_interrupt = false;
+ if ((mp->last > mp->first + 1) && (mp->buffer[mp->first + 1] >= '0')
+ && (mp->buffer[mp->first + 1] <= '9'))
+ c = xord (c * 10 + mp->buffer[mp->first + 1] - '0' * 11);
+ else
+ c = (ASCII_code) (c - '0');
+ while (c > 0) {
+ mp_get_next (mp); /* one-level recursive call of |error| is possible */
+ @<Decrease the string reference count, if the current token is a string@>;
+ c--;
+ };
+ set_cur_cmd (s1);
+ set_cur_mod (s2);
+ set_cur_sym (s3);
+ mp->OK_to_interrupt = true;
+ help_ptr = 2;
+ help_line[1] = "I have just deleted some text, as you asked.";
+ help_line[0] = "You can now delete more, or insert, or whatever.";
+ mp_show_context (mp);
+ goto CONTINUE;
+}
+
+
+@ Some wriggling with |help_line| is done here to avoid giving no
+information whatsoever, or presenting the same information twice
+in a row.
+
+@<Print the help info...@>=
+{
+ if (mp->use_err_help) {
+ @<Print the string |err_help|, possibly on several lines@>;
+ mp->use_err_help = false;
+ } else {
+ if (help_ptr == 0) {
+ help_ptr=2;
+ help_line[1] = "Sorry, I don't know how to help in this situation.";
+ help_line[0] = "Maybe you should try asking a human?";
+ }
+ do {
+ decr (help_ptr);
+ mp_print (mp, help_line[help_ptr]);
+ mp_print_ln (mp);
+ } while (help_ptr != 0);
+ };
+ help_ptr=4;
+ help_line[3] = "Sorry, I already gave what help I could...";
+ help_line[2] = "Maybe you should try asking a human?";
+ help_line[1] = "An error might have occurred before I noticed any problems.";
+ help_line[0] = "``If all else fails, read the instructions.''";
+ goto CONTINUE;
+}
+
+
+@ @<Print the string |err_help|, possibly on several lines@>=
+{
+ size_t j = 0;
+ while (j < mp->err_help->len) {
+ if (*(mp->err_help->str + j) != '%')
+ mp_print (mp, (const char *) (mp->err_help->str + j));
+ else if (j + 1 == mp->err_help->len)
+ mp_print_ln (mp);
+ else if (*(mp->err_help->str + j) != '%')
+ mp_print_ln (mp);
+ else {
+ j++;
+ mp_print_char (mp, xord ('%'));
+ };
+ j++;
+ }
+}
+
+
+@ @<Put help message on the transcript file@>=
+if (! mp->noninteractive) {
+ if (mp->interaction > mp_batch_mode) {
+ decr (mp->selector); /* avoid terminal output */
+ }
+}
+if (mp->use_err_help) {
+ mp_print_nl (mp, "");
+ @<Print the string |err_help|, possibly on several lines@>;
+} else {
+ while (help_ptr > 0) {
+ decr (help_ptr);
+ mp_print_nl (mp, help_line[help_ptr]);
+ };
+ mp_print_ln (mp);
+ if (! mp->noninteractive) {
+ if (mp->interaction > mp_batch_mode)
+ incr (mp->selector); /* re-enable terminal output */
+ }
+ mp_print_ln (mp);
+}
+
+
+@ In anomalous cases, the print selector might be in an unknown state;
+the following subroutine is called to fix things just enough to keep
+running a bit longer.
+
+@c
+void mp_normalize_selector (MP mp) {
+ if (mp->log_opened)
+ mp->selector = term_and_log;
+ else
+ mp->selector = term_only;
+ if (mp->job_name == NULL)
+ mp_open_log_file (mp);
+ if (mp->interaction == mp_batch_mode)
+ decr (mp->selector);
+}
+
+
+@ The following procedure prints \MP's last words before dying.
+
+@<Error hand...@>=
+void mp_fatal_error (MP mp, const char *s) { /* prints |s|, and that's it */
+ const char *hlp[] = {s, NULL} ;
+ mp_normalize_selector (mp);
+ if ( mp->interaction==mp_error_stop_mode )
+ mp->interaction=mp_scroll_mode; /* no more interaction */
+ if ( mp->log_opened )
+ mp_error(mp, "Emergency stop", hlp, true);
+ mp->history=mp_fatal_error_stop;
+ mp_jump_out(mp); /* irrecoverable error */
+@.Emergency stop@>
+}
+
+
+@ @<Exported function ...@>=
+extern void mp_fatal_error (MP mp, const char *s);
+
+
+@ @<Internal library declarations@>=
+void mp_overflow (MP mp, const char *s, integer n);
+
+
+@ @<Error hand...@>=
+void mp_overflow (MP mp, const char *s, integer n) { /* stop due to finiteness */
+ char msg[256];
+ const char *hlp[] = {
+ "If you really absolutely need more capacity,",
+ "you can ask a wizard to enlarge me.",
+ NULL };
+ mp_normalize_selector (mp);
+ mp_snprintf (msg, 256, "MetaPost capacity exceeded, sorry [%s=%d]", s, (int) n);
+@.MetaPost capacity exceeded ...@>;
+ if ( mp->interaction==mp_error_stop_mode )
+ mp->interaction=mp_scroll_mode; /* no more interaction */
+ if ( mp->log_opened )
+ mp_error(mp, msg, hlp, true);
+ mp->history=mp_fatal_error_stop;
+ mp_jump_out(mp); /* irrecoverable error */
+}
+
+
+@ The program might sometime run completely amok, at which point there is
+no choice but to stop. If no previous error has been detected, that's bad
+news; a message is printed that is really intended for the \MP\
+maintenance person instead of the user (unless the user has been
+particularly diabolical). The index entries for `this can't happen' may
+help to pinpoint the problem.
+@^dry rot@>
+
+@<Internal library ...@>=
+void mp_confusion (MP mp, const char *s);
+
+@ Consistency check violated; |s| tells where.
+@<Error hand...@>=
+void mp_confusion (MP mp, const char *s) {
+ char msg[256];
+ const char *hlp[] = {
+ "One of your faux pas seems to have wounded me deeply...",
+ "in fact, I'm barely conscious. Please fix it and try again.",
+ NULL };
+ mp_normalize_selector (mp);
+ if (mp->history < mp_error_message_issued) {
+ mp_snprintf (msg, 256, "This can't happen (%s)", s);
+@.This can't happen@>;
+ hlp[0] = "I'm broken. Please show this to someone who can fix can fix";
+ hlp[1] = NULL;
+ } else {
+ mp_snprintf (msg, 256, "I can\'t go on meeting you like this");
+@.I can't go on...@>;
+ }
+ if ( mp->interaction==mp_error_stop_mode )
+ mp->interaction=mp_scroll_mode; /* no more interaction */
+ if ( mp->log_opened )
+ mp_error(mp, msg, hlp, true);
+ mp->history=mp_fatal_error_stop;
+ mp_jump_out(mp); /* irrecoverable error */
+}
+
+
+@ Users occasionally want to interrupt \MP\ while it's running.
+If the runtime system allows this, one can implement
+a routine that sets the global variable |interrupt| to some nonzero value
+when such an interrupt is signaled. Otherwise there is probably at least
+a way to make |interrupt| nonzero using the C debugger.
+@^system dependencies@>
+@^debugging@>
+
+@d check_interrupt { if ( mp->interrupt!=0 )
+ mp_pause_for_instructions(mp); }
+
+@<Global...@>=
+integer interrupt; /* should \MP\ pause for instructions? */
+boolean OK_to_interrupt; /* should interrupts be observed? */
+integer run_state; /* are we processing input ? */
+boolean finished; /* set true by |close_files_and_terminate| */
+boolean reading_preload;
+
+@ @<Allocate or ...@>=
+mp->OK_to_interrupt = true;
+mp->finished = false;
+
+@ When an interrupt has been detected, the program goes into its
+highest interaction level and lets the user have the full flexibility of
+the |error| routine. \MP\ checks for interrupts only at times when it is
+safe to do this.
+
+@c
+static void mp_pause_for_instructions (MP mp) {
+ const char *hlp[] = { "You rang?",
+ "Try to insert some instructions for me (e.g.,`I show x'),",
+ "unless you just want to quit by typing `X'.",
+ NULL } ;
+ if (mp->OK_to_interrupt) {
+ mp->interaction = mp_error_stop_mode;
+ if ((mp->selector == log_only) || (mp->selector == no_print))
+ incr (mp->selector);
+@.Interruption@>;
+ mp_error (mp, "Interruption", hlp, false);
+ mp->interrupt = 0;
+ }
+}
+
+
+@* Arithmetic with scaled numbers.
+The principal computations performed by \MP\ are done entirely in terms of
+integers less than $2^{31}$ in magnitude; thus, the arithmetic specified in this
+program can be carried out in exactly the same way on a wide variety of
+computers, including some small ones.
+@^small computers@>
+
+But C does not rigidly define the |/| operation in the case of negative
+dividends; for example, the result of |(-2*n-1) / 2| is |-(n+1)| on some
+computers and |-n| on others (is this true ?). There are two principal
+types of arithmetic: ``translation-preserving,'' in which the identity
+|(a+q*b)/b=(a/b)+q| is valid; and ``negation-preserving,'' in which
+|(-a)/b=-(a/b)|. This leads to two \MP s, which can produce
+different results, although the differences should be negligible when the
+language is being used properly. The \TeX\ processor has been defined
+carefully so that both varieties of arithmetic will produce identical
+output, but it would be too inefficient to constrain \MP\ in a similar way.
+
+@d inf_t ((math_data *)mp->math)->inf_t
+
+@ A single computation might use several subroutine calls, and it is
+desirable to avoid producing multiple error messages in case of arithmetic
+overflow. So the routines below set the global variable |arith_error| to |true|
+instead of reporting errors directly to the user.
+@^overflow in arithmetic@>
+
+@<Glob...@>=
+boolean arith_error; /* has arithmetic overflow occurred recently? */
+
+@ @<Allocate or ...@>=
+mp->arith_error = false;
+
+@ At crucial points the program will say |check_arith|, to test if
+an arithmetic error has been detected.
+
+@d check_arith() do {
+ if ( mp->arith_error )
+ mp_clear_arith(mp);
+} while (0)
+
+@c
+static void mp_clear_arith (MP mp) {
+ const char *hlp[] = {
+ "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.",
+ NULL };
+ mp_error (mp, "Arithmetic overflow", hlp, true);
+@.Arithmetic overflow@>;
+ mp->arith_error = false;
+}
+
+
+@ The definitions of these are set up by the math initialization.
+
+@d arc_tol_k ((math_data *)mp->math)->arc_tol_k
+@d coef_bound_k ((math_data *)mp->math)->coef_bound_k
+@d coef_bound_minus_1 ((math_data *)mp->math)->coef_bound_minus_1
+@d sqrt_8_e_k ((math_data *)mp->math)->sqrt_8_e_k
+@d twelve_ln_2_k ((math_data *)mp->math)->twelve_ln_2_k
+@d twelvebits_3 ((math_data *)mp->math)->twelvebits_3
+@d one_k ((math_data *)mp->math)->one_k
+@d epsilon_t ((math_data *)mp->math)->epsilon_t
+@d unity_t ((math_data *)mp->math)->unity_t
+@d zero_t ((math_data *)mp->math)->zero_t
+@d two_t ((math_data *)mp->math)->two_t
+@d three_t ((math_data *)mp->math)->three_t
+@d half_unit_t ((math_data *)mp->math)->half_unit_t
+@d three_quarter_unit_t ((math_data *)mp->math)->three_quarter_unit_t
+@d twentysixbits_sqrt2_t ((math_data *)mp->math)->twentysixbits_sqrt2_t
+@d twentyeightbits_d_t ((math_data *)mp->math)->twentyeightbits_d_t
+@d twentysevenbits_sqrt2_d_t ((math_data *)mp->math)->twentysevenbits_sqrt2_d_t
+@d warning_limit_t ((math_data *)mp->math)->warning_limit_t
+@d precision_default ((math_data *)mp->math)->precision_default
+@d precision_max ((math_data *)mp->math)->precision_max
+@d precision_min ((math_data *)mp->math)->precision_min
+
+@ In fact, the two sorts of scaling discussed above aren't quite
+sufficient; \MP\ has yet another, used internally to keep track of angles.
+
+@ We often want to print two scaled quantities in parentheses,
+separated by a comma.
+
+@<Basic printing...@>=
+void mp_print_two (MP mp, mp_number x, mp_number y) { /* prints `|(x,y)|' */
+ mp_print_char (mp, xord ('('));
+ print_number (x);
+ mp_print_char (mp, xord (','));
+ print_number (y);
+ mp_print_char (mp, xord (')'));
+}
+
+
+@
+@d fraction_one_t ((math_data *)mp->math)->fraction_one_t
+@d fraction_half_t ((math_data *)mp->math)->fraction_half_t
+@d fraction_three_t ((math_data *)mp->math)->fraction_three_t
+@d fraction_four_t ((math_data *)mp->math)->fraction_four_t
+
+@d one_eighty_deg_t ((math_data *)mp->math)->one_eighty_deg_t
+@d three_sixty_deg_t ((math_data *)mp->math)->three_sixty_deg_t
+
+@ @<Local variables for initialization@>=
+integer k; /* all-purpose loop index */
+
+@ And now let's complete our collection of numeric utility routines
+by considering random number generation.
+\MP\ generates pseudo-random numbers with the additive scheme recommended
+in Section 3.6 of {\sl The Art of Computer Programming}; however, the
+results are random fractions between 0 and |fraction_one-1|, inclusive.
+
+There's an auxiliary array |randoms| that contains 55 pseudo-random
+fractions. Using the recurrence $x_n=(x_{n-55}-x_{n-31})\bmod 2^{28}$,
+we generate batches of 55 new $x_n$'s at a time by calling |new_randoms|.
+The global variable |j_random| tells which element has most recently
+been consumed.
+The global variable |random_seed| was introduced in version 0.9,
+for the sole reason of stressing the fact that the initial value of the
+random seed is system-dependant. The initialization code below will initialize
+this variable to |(internal[mp_time] div unity)+internal[mp_day]|, but this
+is not good enough on modern fast machines that are capable of running
+multiple MetaPost processes within the same second.
+@^system dependencies@>
+
+@<Glob...@>=
+mp_number randoms[55]; /* the last 55 random values generated */
+int j_random; /* the number of unused |randoms| */
+
+@ @<Option variables@>=
+int random_seed; /* the default random seed */
+
+@ @<Allocate or initialize ...@>=
+mp->random_seed = opt->random_seed;
+{
+ int i;
+ for (i=0;i<55;i++) {
+ new_fraction (mp->randoms[i]);
+ }
+}
+
+@ @<Dealloc...@>=
+{
+ int i;
+ for (i=0;i<55;i++) {
+ free_number (mp->randoms[i]);
+ }
+}
+
+@ @<Internal library ...@>=
+void mp_new_randoms (MP mp);
+
+@ @c
+void mp_new_randoms (MP mp) {
+ int k; /* index into |randoms| */
+ mp_number x; /* accumulator */
+ new_number (x);
+ for (k = 0; k <= 23; k++) {
+ set_number_from_substraction(x, mp->randoms[k], mp->randoms[k + 31]);
+ if (number_negative(x))
+ number_add (x, fraction_one_t);
+ number_clone (mp->randoms[k], x);
+ }
+ for (k = 24; k <= 54; k++) {
+ set_number_from_substraction(x, mp->randoms[k], mp->randoms[k - 24]);
+ if (number_negative(x))
+ number_add (x, fraction_one_t);
+ number_clone (mp->randoms[k], x);
+ }
+ free_number (x);
+ mp->j_random = 54;
+}
+
+@ To consume a random fraction, the program below will say `|next_random|'.
+Now each number system has its own implementation,
+true to the original as much as possibile.
+
+@c
+/* Unused.
+static void mp\_next\_random (MP mp, mp\_number *ret) {
+ if ( mp->j\_random==0 )
+ mp\_new\_randoms(mp);
+ else
+ decr(mp->j\_random);
+ number\_clone (*ret, mp->randoms[mp->j\_random]);
+}
+*/
+
+@ 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.
+This is the original one,
+that stays as reference:
+As said before, now each number system has its own implementation.
+
+
+@c
+/*Unused.
+static void mp\_unif\_rand (MP mp, mp\_number *ret, mp\_number x\_orig) {
+ mp\_number y; // trial value
+ mp\_number x, abs\_x;
+ mp\_number u;
+ new\_fraction (y);
+ new\_number (x);
+ new\_number (abs\_x);
+ new\_number (u);
+ number\_clone (x, x\_orig);
+ number\_clone (abs\_x, x);
+ number\_abs (abs\_x);
+ mp\_next\_random(mp, \&u);
+ take\_fraction (y, abs\_x, u);
+ free\_number (u);
+ if (number\_equal(y, abs\_x)) {
+ set\_number\_to\_zero(*ret);
+ } else if (number\_positive(x)) {
+ number\_clone (*ret, y);
+ } else {
+ number\_clone (*ret, y);
+ number\_negate (*ret);
+ }
+ free\_number (abs\_x);
+ free\_number (x);
+ free\_number (y);
+}
+*/
+
+@ Finally, a normal deviate with mean zero and unit standard deviation
+can readily be obtained with the ratio method (Algorithm 3.4.1R in
+{\sl The Art of Computer Programming\/}). This is the original one,
+that stays as reference:
+Now each number system has its own implementation,
+true to the original as much as possibile.
+
+
+@c
+/* Unused.
+static void mp\_norm\_rand (MP mp, mp\_number *ret) {
+ mp\_number ab\_vs\_cd;
+ mp\_number abs\_x;
+ mp\_number u;
+ mp\_number r;
+ mp\_number la, xa;
+ new\_number (ab\_vs\_cd);
+ new\_number (la);
+ new\_number (xa);
+ new\_number (abs\_x);
+ new\_number (u);
+ new\_number (r);
+ do {
+ do {
+ mp\_number v;
+ new\_number (v);
+ mp\_next\_random(mp, \&v);
+ number\_substract (v, fraction\_half\_t);
+ take\_fraction (xa, sqrt\_8\_e\_k, v);
+ free\_number (v);
+ mp\_next\_random(mp, \&u);
+ number\_clone (abs\_x, xa);
+ number\_abs (abs\_x);
+ } while (number\_greaterequal (abs\_x, u));
+ make\_fraction (r, xa, u);
+ number\_clone (xa, r);
+ m\_log (la, u);
+ set\_number\_from\_substraction(la, twelve\_ln\_2\_k, la);
+ ab\_vs\_cd (ab\_vs\_cd, one\_k, la, xa, xa);
+ } while (number\_negative(ab\_vs\_cd));
+ number\_clone (*ret, xa);
+ free\_number (ab\_vs\_cd);
+ free\_number (r);
+ free\_number (abs\_x);
+ free\_number (la);
+ free\_number (xa);
+ free\_number (u);
+}
+*/
+
+
+@* Packed data.
+
+@d max_quarterword 0x3FFF /* largest allowable value in a |quarterword| */
+@d max_halfword 0xFFFFFFF /* largest allowable value in a |halfword| */
+
+@ The macros |qi| and |qo| are used for input to and output
+from quarterwords. These are legacy macros.
+@^system dependencies@>
+
+@d qo(A) (A) /* to read eight bits from a quarterword */
+@d qi(A) (quarterword)(A) /* to store eight bits in a quarterword */
+
+@ The reader should study the following definitions closely:
+@^system dependencies@>
+
+@<Types...@>=
+typedef struct mp_value_node_data *mp_value_node;
+typedef struct mp_node_data *mp_node;
+typedef struct mp_symbol_entry *mp_sym;
+typedef short quarterword; /* 1/4 of a word */
+typedef int halfword; /* 1/2 of a word */
+typedef struct {
+ integer scale; /* only for |indep_scale|, used together with |serial| */
+ integer serial; /* only for |indep_value|, used together with |scale| */
+} mp_independent_data;
+typedef struct {
+ mp_independent_data indep;
+ mp_number n;
+ mp_string str;
+ mp_sym sym;
+ mp_node node;
+ mp_knot p;
+} mp_value_data;
+typedef struct {
+ mp_variable_type type;
+ mp_value_data data;
+} mp_value;
+typedef struct {
+ quarterword b0, b1, b2, b3;
+} four_quarters;
+typedef union {
+ integer sc;
+ four_quarters qqqq;
+} font_data;
+
+
+@ The global variable |math_mode| has four settings, representing the
+math value type that will be used in this run.
+
+the typedef for |mp_number| is here because it has to come very early.
+
+@<Exported types@>=
+typedef enum {
+ mp_math_scaled_mode = 0,
+ mp_math_double_mode = 1,
+ mp_math_binary_mode = 2,
+ mp_math_decimal_mode = 3
+} mp_math_mode;
+
+@ @<Option variables@>=
+int math_mode; /* math mode */
+
+@ @<Allocate or initialize ...@>=
+mp->math_mode = opt->math_mode;
+
+@
+@d xfree(A) do { mp_xfree(A); A=NULL; } while (0)
+@d xrealloc(P,A,B) mp_xrealloc(mp,P,(size_t)A,B)
+@d xmalloc(A,B) mp_xmalloc(mp,(size_t)A,B)
+@d xstrdup(A) mp_xstrdup(mp,A)
+@d XREALLOC(a,b,c) a = xrealloc(a,(b+1),sizeof(c));
+
+@<Declare helpers@>=
+extern void mp_xfree (void *x);
+extern void *mp_xrealloc (MP mp, void *p, size_t nmem, size_t size);
+extern void *mp_xmalloc (MP mp, size_t nmem, size_t size);
+extern void mp_do_snprintf (char *str, int size, const char *fmt, ...);
+extern void *do_alloc_node(MP mp, size_t size);
+
+@ This is an attempt to spend less time in |malloc()|:
+
+@d max_num_token_nodes 1000
+@d max_num_pair_nodes 1000
+@d max_num_knot_nodes 1000
+@d max_num_value_nodes 1000
+@d max_num_symbolic_nodes 1000
+
+@<Global ...@>=
+mp_node token_nodes;
+int num_token_nodes;
+mp_node pair_nodes;
+int num_pair_nodes;
+mp_knot knot_nodes;
+int num_knot_nodes;
+mp_node value_nodes;
+int num_value_nodes;
+mp_node symbolic_nodes;
+int num_symbolic_nodes;
+
+@ @<Allocate or initialize ...@>=
+mp->token_nodes = NULL;
+mp->num_token_nodes = 0;
+mp->pair_nodes = NULL;
+mp->num_pair_nodes = 0;
+mp->knot_nodes = NULL;
+mp->num_knot_nodes = 0;
+mp->value_nodes = NULL;
+mp->num_value_nodes = 0;
+mp->symbolic_nodes = NULL;
+mp->num_symbolic_nodes = 0;
+
+@ @<Dealloc ...@>=
+while (mp->value_nodes) {
+ mp_node p = mp->value_nodes;
+ mp->value_nodes = p->link;
+ mp_free_node(mp,p,value_node_size);
+}
+while (mp->symbolic_nodes) {
+ mp_node p = mp->symbolic_nodes;
+ mp->symbolic_nodes = p->link;
+ mp_free_node(mp,p,symbolic_node_size);
+}
+while (mp->pair_nodes) {
+ mp_node p = mp->pair_nodes;
+ mp->pair_nodes = p->link;
+ mp_free_node(mp,p,pair_node_size);
+}
+while (mp->token_nodes) {
+ mp_node p = mp->token_nodes;
+ mp->token_nodes = p->link;
+ mp_free_node(mp,p,token_node_size);
+}
+while (mp->knot_nodes) {
+ mp_knot p = mp->knot_nodes;
+ mp->knot_nodes = p->next;
+ mp_free_knot(mp,p);
+}
+
+@ This is a nicer way of allocating nodes.
+
+@d malloc_node(A) do_alloc_node(mp,(A))
+
+@
+@c
+void *do_alloc_node (MP mp, size_t size) {
+ void *p;
+ p = xmalloc(1,size);
+ add_var_used (size);
+ ((mp_node)p)->link = NULL;
+ ((mp_node)p)->has_number = 0;
+ return p;
+}
+
+
+@ The |max_size_test| guards against overflow, on the assumption that
+|size_t| is at least 31bits wide.
+
+@d max_size_test 0x7FFFFFFF
+
+@c
+void mp_xfree (void *x) {
+ if (x != NULL)
+ free (x);
+}
+void *mp_xrealloc (MP mp, void *p, size_t nmem, size_t size) {
+ void *w;
+ if ((max_size_test / size) < nmem) {
+ mp_fputs ("Memory size overflow!\n", mp->err_out);
+ mp->history = mp_fatal_error_stop;
+ mp_jump_out (mp);
+ }
+ w = realloc (p, (nmem * size));
+ if (w == NULL) {
+ mp_fputs ("Out of memory!\n", mp->err_out);
+ mp->history = mp_system_error_stop;
+ mp_jump_out (mp);
+ }
+ return w;
+}
+void *mp_xmalloc (MP mp, size_t nmem, size_t size) {
+ void *w;
+#if DEBUG
+ if ((max_size_test / size) < nmem) {
+ mp_fputs ("Memory size overflow!\n", mp->err_out);
+ mp->history = mp_fatal_error_stop;
+ mp_jump_out (mp);
+ }
+#endif
+ w = calloc(nmem, size); /* TODO: check an un-initialize use of w and replace calloc with malloc. */
+ if (w == NULL) {
+ mp_fputs ("Out of memory!\n", mp->err_out);
+ mp->history = mp_system_error_stop;
+ mp_jump_out (mp);
+ }
+ return w;
+}
+
+@ @<Internal library declarations@>=
+/* Avoid warning on format truncation */
+#define mp_snprintf(...) (snprintf(__VA_ARGS__) < 0 ? abort() : (void)0)
+
+@* 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.
+
+@d MP_VOID (mp_node)(1) /* |NULL+1|, a |NULL| pointer different from |NULL| */
+
+@d mp_link(A) (A)->link /* the |link| field of a node */
+@d set_mp_link(A,B) do {
+ mp_node d = (B);
+ /* |printf("set link of %p to %p on line %d\n", (A), d, __LINE__);| */
+ mp_link((A)) = d;
+ } while (0)
+@d mp_type(A) (A)->type /* identifies what kind of value this is */
+@d mp_name_type(A) (A)->name_type /* a clue to the name of this value */
+
+@ @<MPlib internal header stuff@>=
+#define NODE_BODY \
+ mp_variable_type type; \
+ mp_name_type_type name_type; \
+ unsigned short has_number; \
+ struct mp_node_data *link
+typedef struct mp_node_data {
+ NODE_BODY;
+ mp_value_data data;
+} mp_node_data;
+typedef struct mp_node_data *mp_symbolic_node;
+
+@ Users who wish to study the memory requirements of particular applications can
+can use the special features that keep track of current and maximum memory usage.
+\MP\ will report these statistics when |mp_tracing_stats| is positive.
+
+@d add_var_used(a) do {
+ mp->var_used+=(a);
+ if (mp->var_used>mp->var_used_max) mp->var_used_max=mp->var_used;
+} while (0)
+
+@<Glob...@>=
+size_t var_used; /* how much memory is in use */
+size_t var_used_max; /* how much memory was in use max */
+
+@ These redirect to function to aid in debugging.
+
+@c
+#if DEBUG
+#define mp_sym_info(A) get_mp_sym_info(mp,(A))
+#define set_mp_sym_info(A,B) do_set_mp_sym_info(mp,(A),(B))
+#define mp_sym_sym(A) get_mp_sym_sym(mp,(A))
+#define set_mp_sym_sym(A,B) do_set_mp_sym_sym(mp,(A),(mp_sym)(B))
+static void do_set_mp_sym_info (MP mp, mp_node p, halfword v) {
+ FUNCTION_TRACE3 ("do_set_mp_sym_info(%p,%d)\n", p, v);
+ assert (p->type == mp_symbol_node);
+ set_indep_value(p, v);
+}
+static halfword get_mp_sym_info (MP mp, mp_node p) {
+ FUNCTION_TRACE3 ("%d = get_mp_sym_info(%p)\n", indep_value (p), p);
+ assert (p->type == mp_symbol_node);
+ return indep_value(p);
+}
+static void do_set_mp_sym_sym (MP mp, mp_node p, mp_sym v) {
+ mp_symbolic_node pp = (mp_symbolic_node) p;
+ FUNCTION_TRACE3 ("do_set_mp_sym_sym(%p,%p)\n", pp, v);
+ assert (pp->type == mp_symbol_node);
+ pp->data.sym = v;
+}
+static mp_sym get_mp_sym_sym (MP mp, mp_node p) {
+ mp_symbolic_node pp = (mp_symbolic_node) p;
+ FUNCTION_TRACE3 ("%p = get_mp_sym_sym(%p)\n", pp->data.sym, pp);
+ assert (pp->type == mp_symbol_node);
+ return pp->data.sym;
+}
+#else
+#define mp_sym_info(A) indep_value(A)
+#define set_mp_sym_info(A,B) set_indep_value(A, (B))
+#define mp_sym_sym(A) (A)->data.sym
+#define set_mp_sym_sym(A,B) (A)->data.sym = (mp_sym)(B)
+#endif
+
+@ @<Declarations@>=
+#if DEBUG
+static void do_set_mp_sym_info (MP mp, mp_node A, halfword B);
+static halfword get_mp_sym_info (MP mp, mp_node p);
+static void do_set_mp_sym_sym (MP mp, mp_node A, mp_sym B);
+static mp_sym get_mp_sym_sym (MP mp, mp_node p);
+#endif
+
+@ The function |get_symbolic_node| returns a pointer to a new symbolic node whose
+|link| field is null.
+@^inner loop@>
+
+@d symbolic_node_size sizeof(mp_node_data)
+@c
+static mp_node mp_get_symbolic_node (MP mp) {
+ mp_symbolic_node p;
+ if (mp->symbolic_nodes) {
+ p = (mp_symbolic_node)mp->symbolic_nodes;
+ mp->symbolic_nodes = p->link;
+ mp->num_symbolic_nodes--;
+ p->link = NULL;
+ } else {
+ p = malloc_node (symbolic_node_size);
+ new_number(p->data.n);
+ p->has_number = 1;
+ }
+ p->type = mp_symbol_node;
+ p->name_type = mp_normal_sym;
+ FUNCTION_TRACE2 ("%p = mp_get_symbolic_node()\n", p);
+ return (mp_node) p;
+}
+
+
+@ Conversely, when some 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.
+
+A symbolic node is recycled by calling |free_symbolic_node|.
+
+@c
+void mp_free_node (MP mp, mp_node p, size_t siz) { /* node liberation */
+ FUNCTION_TRACE3 ("mp_free_node(%p,%d)\n", p, (int)siz);
+ if (!p) return;
+ mp->var_used -= siz;
+ if (mp->math_mode > mp_math_double_mode) {
+ if (p->has_number >= 1 && is_number(((mp_symbolic_node)p)->data.n)) {
+ free_number(((mp_symbolic_node)p)->data.n);
+ }
+ if (p->has_number == 2 && is_number(((mp_value_node)p)->subscript_)) {
+ free_number(((mp_value_node)p)->subscript_);
+ }
+ /* There was a quite large |switch| here first, but the |mp_dash_node|
+ case was the only one that did anything ... */
+ if (mp_type (p) == mp_dash_node_type) {
+ free_number(((mp_dash_node)p)->start_x);
+ free_number(((mp_dash_node)p)->stop_x);
+ free_number(((mp_dash_node)p)->dash_y);
+ }
+ }
+ xfree (p);
+}
+void mp_free_symbolic_node (MP mp, mp_node p) { /* node liberation */
+ FUNCTION_TRACE2 ("mp_free_symbolic_node(%p)\n", p);
+ if (!p) return;
+ if (mp->num_symbolic_nodes < max_num_symbolic_nodes) {
+ p->link = mp->symbolic_nodes;
+ mp->symbolic_nodes = p;
+ mp->num_symbolic_nodes++;
+ return;
+ }
+ mp->var_used -= symbolic_node_size;
+ xfree (p);
+}
+void mp_free_value_node (MP mp, mp_node p) { /* node liberation */
+ FUNCTION_TRACE2 ("mp_free_value_node(%p)\n", p);
+ if (!p) return;
+ if (mp->num_value_nodes < max_num_value_nodes) {
+ p->link = mp->value_nodes;
+ mp->value_nodes = p;
+ mp->num_value_nodes++;
+ return;
+ }
+ mp->var_used -= value_node_size;
+ assert(p->has_number == 2);
+ if (mp->math_mode > mp_math_double_mode) {
+ free_number(((mp_value_node)p)->data.n);
+ free_number(((mp_value_node)p)->subscript_);
+ }
+ xfree (p);
+}
+
+
+@ @<Internal library declarations@>=
+void mp_free_node (MP mp, mp_node p, size_t siz);
+void mp_free_symbolic_node (MP mp, mp_node p);
+void mp_free_value_node (MP mp, mp_node p);
+
+@* Memory layout.
+Some nodes are created statically, since static allocation is
+more efficient than dynamic allocation when we can get away with it.
+
+@<Glob...@>=
+mp_dash_node null_dash;
+mp_value_node dep_head;
+mp_node inf_val;
+mp_node zero_val;
+mp_node temp_val;
+mp_node end_attr;
+mp_node bad_vardef;
+mp_node temp_head;
+mp_node hold_head;
+mp_node spec_head;
+
+@ The following code gets the memory off to a good start.
+
+@<Initialize table entries@>=
+mp->spec_head = mp_get_symbolic_node (mp);
+mp->last_pending = mp->spec_head;
+mp->temp_head = mp_get_symbolic_node (mp);
+mp->hold_head = mp_get_symbolic_node (mp);
+
+@ @<Free table entries@>=
+mp_free_symbolic_node (mp, mp->spec_head);
+mp_free_symbolic_node (mp, mp->temp_head);
+mp_free_symbolic_node (mp, mp->hold_head);
+
+@ The procedure |flush_node_list(p)| frees an entire linked list of
+nodes that starts at a given position, until coming to a |NULL| pointer.
+@^inner loop@>
+
+@c
+static void mp_flush_node_list (MP mp, mp_node p) {
+ mp_node q; /* the node being recycled */
+ FUNCTION_TRACE2 ("mp_flush_node_list(%p)\n", p);
+ while (p != NULL) {
+ q = p;
+ p = p->link;
+ if (q->type != mp_symbol_node)
+ mp_free_token_node (mp, q);
+ else
+ mp_free_symbolic_node (mp, q);
+ }
+}
+
+
+@* 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 mp_max_command_code mp_stop
+@d mp_max_pre_command mp_mpx_break
+@d mp_min_command (mp_defined_macro+1)
+@d mp_max_statement_command mp_type_name
+@d mp_min_primary_command mp_type_name
+@d mp_min_suffix_token mp_internal_quantity
+@d mp_max_suffix_token mp_numeric_token
+@d mp_max_primary_command mp_plus_or_minus /* should also be |numeric_token+1| */
+@d mp_min_tertiary_command mp_plus_or_minus
+@d mp_max_tertiary_command mp_tertiary_binary
+@d mp_min_expression_command mp_left_brace
+@d mp_max_expression_command mp_equals
+@d mp_min_secondary_command mp_and_command
+@d mp_max_secondary_command mp_secondary_binary
+@d mp_end_of_statement (cur_cmd()>mp_comma)
+
+
+@<Enumeration types@>=
+typedef enum {
+mp_start_tex=1, /* begin \TeX\ material (\&{btex}, \&{verbatimtex}) */
+mp_etex_marker, /* end \TeX\ material (\&{etex}) */
+mp_mpx_break, /* stop reading an \.{MPX} file (\&{mpxbreak}) */
+mp_if_test, /* conditional text (\&{if}) */
+mp_fi_or_else, /* delimiters for conditionals (\&{elseif}, \&{else}, \&{fi}) */
+mp_input, /* input a source file (\&{input}, \&{endinput}) */
+mp_iteration, /* iterate (\&{for}, \&{forsuffixes}, \&{forever}, \&{endfor}) */
+mp_repeat_loop, /* special command substituted for \&{endfor} */
+mp_exit_test, /* premature exit from a loop (\&{exitif}) */
+mp_relax, /* do nothing (\.{\char`\\}) */
+mp_scan_tokens, /* put a string into the input buffer */
+mp_runscript, /* put a script result string into the input buffer */
+mp_maketext, /* put a script result string into the input buffer */
+mp_expand_after, /* look ahead one token */
+mp_defined_macro, /* a macro defined by the user */
+mp_save_command, /* save a list of tokens (\&{save}) */
+mp_interim_command, /* save an internal quantity (\&{interim}) */
+mp_let_command, /* redefine a symbolic token (\&{let}) */
+mp_new_internal, /* define a new internal quantity (\&{newinternal}) */
+mp_macro_def, /* define a macro (\&{def}, \&{vardef}, etc.) */
+mp_ship_out_command, /* output a character (\&{shipout}) */
+mp_add_to_command, /* add to edges (\&{addto}) */
+mp_bounds_command, /* add bounding path to edges (\&{setbounds}, \&{clip}) */
+mp_tfm_command, /* command for font metric info (\&{ligtable}, etc.) */
+mp_protection_command, /* set protection flag (\&{outer}, \&{inner}) */
+mp_show_command, /* diagnostic output (\&{show}, \&{showvariable}, etc.) */
+mp_mode_command, /* set interaction level (\&{batchmode}, etc.) */
+mp_random_seed, /* initialize random number generator (\&{randomseed}) */
+mp_message_command, /* communicate to user (\&{message}, \&{errmessage}) */
+mp_every_job_command, /* designate a starting token (\&{everyjob}) */
+mp_delimiters, /* define a pair of delimiters (\&{delimiters}) */
+mp_special_command, /* output special info (\&{special}) or font map info (\&{fontmapfile}, \&{fontmapline}) */
+mp_write_command, /* write text to a file (\&{write}) */
+mp_type_name, /* declare a type (\&{numeric}, \&{pair}, etc.) */
+mp_left_delimiter, /* the left delimiter of a matching pair */
+mp_begin_group, /* beginning of a group (\&{begingroup}) */
+mp_nullary, /* an operator without arguments (e.g., \&{normaldeviate}) */
+mp_unary, /* an operator with one argument (e.g., \&{sqrt}) */
+mp_str_op, /* convert a suffix to a string (\&{str}) */
+mp_void_op, /* convert a suffix to a boolean (\&{void}) */
+mp_cycle, /* close a cyclic path (\&{cycle}) */
+mp_primary_binary, /* binary operation taking `\&{of}' (e.g., \&{point}) */
+mp_capsule_token, /* a value that has been put into a token list */
+mp_string_token, /* a string constant (e.g., |"hello"|) */
+mp_internal_quantity, /* internal numeric parameter (e.g., \&{pausing}) */
+mp_tag_token, /* a symbolic token without a primitive meaning */
+mp_numeric_token, /* a numeric constant (e.g., \.{3.14159}) */
+mp_plus_or_minus, /* either `\.+' or `\.-' */
+mp_tertiary_secondary_macro, /* a macro defined by \&{secondarydef} */
+mp_tertiary_binary, /* an operator at the tertiary level (e.g., `\.{++}') */
+mp_left_brace, /* the operator `\.{\char`\{}' */
+mp_path_join, /* the operator `\.{..}' */
+mp_ampersand, /* the operator `\.\&' */
+mp_expression_tertiary_macro, /* a macro defined by \&{tertiarydef} */
+mp_expression_binary, /* an operator at the expression level (e.g., `\.<') */
+mp_equals, /* the operator `\.=' */
+mp_and_command, /* the operator `\&{and}' */
+mp_secondary_primary_macro, /* a macro defined by \&{primarydef} */
+mp_slash, /* the operator `\./' */
+mp_secondary_binary, /* an operator at the binary level (e.g., \&{shifted}) */
+mp_param_type, /* type of parameter (\&{primary}, \&{expr}, \&{suffix}, etc.) */
+mp_controls, /* specify control points explicitly (\&{controls}) */
+mp_tension, /* specify tension between knots (\&{tension}) */
+mp_at_least, /* bounded tension value (\&{atleast}) */
+mp_curl_command, /* specify curl at an end knot (\&{curl}) */
+mp_macro_special, /* special macro operators (\&{quote}, \.{\#\AT!}, etc.) */
+mp_right_delimiter, /* the right delimiter of a matching pair */
+mp_left_bracket, /* the operator `\.[' */
+mp_right_bracket, /* the operator `\.]' */
+mp_right_brace, /* the operator `\.{\char`\}}' */
+mp_with_option, /* option for filling (\&{withpen}, \&{withweight}, etc.) */
+mp_thing_to_add, /* variant of \&{addto} (\&{contour}, \&{doublepath}, \&{also}) */
+mp_of_token, /* the operator `\&{of}' */
+mp_to_token, /* the operator `\&{to}' */
+mp_step_token, /* the operator `\&{step}' */
+mp_until_token, /* the operator `\&{until}' */
+mp_within_token, /* the operator `\&{within}' */
+mp_lig_kern_token, /* the operators `\&{kern}' and `\.{=:}' and `\.{=:\char'174}', etc. */
+mp_assignment, /* the operator `\.{:=}' */
+mp_skip_to, /* the operation `\&{skipto}' */
+mp_bchar_label, /* the operator `\.{\char'174\char'174:}' */
+mp_double_colon, /* the operator `\.{::}' */
+mp_colon, /* the operator `\.:' */
+@#
+mp_comma, /* the operator `\.,', must be |colon+1| */
+mp_semicolon, /* the operator `\.;', must be |comma+1| */
+mp_end_group, /* end a group (\&{endgroup}), must be |semicolon+1| */
+mp_stop, /* end a job (\&{end}, \&{dump}), must be |end_group+1| */
+mp_outer_tag, /* protection code added to command code */
+mp_undefined_cs, /* protection code added to command code */
+} mp_command_code;
+
+@ Variables and capsules in \MP\ have a variety of ``types,''
+distinguished by the code numbers defined here. These numbers are also
+not completely arbitrary. Things that get expanded must have types
+|>mp_independent|; a type remaining after expansion is numeric if and only if
+its code number is at least |numeric_type|; objects containing numeric
+parts must have types between |transform_type| and |pair_type|;
+all other types must be smaller than |transform_type|; and among the types
+that are not unknown or vacuous, the smallest two must be |boolean_type|
+and |string_type| in that order.
+
+@d unknown_tag 1 /* this constant is added to certain type codes below */
+@d unknown_types mp_unknown_boolean: case mp_unknown_string:
+ case mp_unknown_pen: case mp_unknown_picture: case mp_unknown_path
+
+@<Enumeration types@>=
+typedef enum {
+ mp_undefined = 0, /* no type has been declared */
+ mp_vacuous, /* no expression was present */
+ mp_boolean_type, /* \&{boolean} with a known value */
+ mp_unknown_boolean,
+ mp_string_type, /* \&{string} with a known value */
+ mp_unknown_string,
+ mp_pen_type, /* \&{pen} with a known value */
+ mp_unknown_pen,
+ mp_path_type, /* \&{path} with a known value */
+ mp_unknown_path,
+ mp_picture_type, /* \&{picture} with a known value */
+ mp_unknown_picture,
+ mp_transform_type, /* \&{transform} variable or capsule */
+ mp_color_type, /* \&{color} variable or capsule */
+ mp_cmykcolor_type, /* \&{cmykcolor} variable or capsule */
+ mp_pair_type, /* \&{pair} variable or capsule */
+ mp_numeric_type, /* variable that has been declared \&{numeric} but not used */
+ mp_known, /* \&{numeric} with a known value */
+ mp_dependent, /* a linear combination with |fraction| coefficients */
+ mp_proto_dependent, /* a linear combination with |scaled| coefficients */
+ mp_independent, /* \&{numeric} with unknown value */
+ mp_token_list, /* variable name or suffix argument or text argument */
+ mp_structured, /* variable with subscripts and attributes */
+ mp_unsuffixed_macro, /* variable defined with \&{vardef} but no \.{\AT!\#} */
+ mp_suffixed_macro, /* variable defined with \&{vardef} and \.{\AT!\#} */
+/* here are some generic node types */
+ mp_symbol_node,
+ mp_token_node_type,
+ mp_value_node_type,
+ mp_attr_node_type,
+ mp_subscr_node_type,
+ mp_pair_node_type,
+ mp_transform_node_type,
+ mp_color_node_type,
+ mp_cmykcolor_node_type,
+/* it is important that the next 7 items remain in this order, for export */
+ mp_fill_node_type,
+ mp_stroked_node_type,
+ mp_text_node_type,
+ mp_start_clip_node_type,
+ mp_start_bounds_node_type,
+ mp_stop_clip_node_type,
+ mp_stop_bounds_node_type,
+ mp_dash_node_type,
+ mp_dep_node_type,
+ mp_if_node_type,
+ mp_edge_header_node_type,
+} mp_variable_type;
+
+@ @<Declarations@>=
+static void mp_print_type (MP mp, quarterword t);
+
+@ @<Basic printing procedures@>=
+static const char *mp_type_string (quarterword t) {
+ const char *s = NULL;
+ switch (t) {
+ case mp_undefined:
+ s = "undefined";
+ break;
+ case mp_vacuous:
+ s = "vacuous";
+ break;
+ case mp_boolean_type:
+ s = "boolean";
+ break;
+ case mp_unknown_boolean:
+ s = "unknown boolean";
+ break;
+ case mp_string_type:
+ s = "string";
+ break;
+ case mp_unknown_string:
+ s = "unknown string";
+ break;
+ case mp_pen_type:
+ s = "pen";
+ break;
+ case mp_unknown_pen:
+ s = "unknown pen";
+ break;
+ case mp_path_type:
+ s = "path";
+ break;
+ case mp_unknown_path:
+ s = "unknown path";
+ break;
+ case mp_picture_type:
+ s = "picture";
+ break;
+ case mp_unknown_picture:
+ s = "unknown picture";
+ break;
+ case mp_transform_type:
+ s = "transform";
+ break;
+ case mp_color_type:
+ s = "color";
+ break;
+ case mp_cmykcolor_type:
+ s = "cmykcolor";
+ break;
+ case mp_pair_type:
+ s = "pair";
+ break;
+ case mp_known:
+ s = "known numeric";
+ break;
+ case mp_dependent:
+ s = "dependent";
+ break;
+ case mp_proto_dependent:
+ s = "proto-dependent";
+ break;
+ case mp_numeric_type:
+ s = "numeric";
+ break;
+ case mp_independent:
+ s = "independent";
+ break;
+ case mp_token_list:
+ s = "token list";
+ break;
+ case mp_structured:
+ s = "mp_structured";
+ break;
+ case mp_unsuffixed_macro:
+ s = "unsuffixed macro";
+ break;
+ case mp_suffixed_macro:
+ s = "suffixed macro";
+ break;
+ case mp_symbol_node:
+ s = "symbol node";
+ break;
+ case mp_token_node_type:
+ s = "token node";
+ break;
+ case mp_value_node_type:
+ s = "value node";
+ break;
+ case mp_attr_node_type:
+ s = "attribute node";
+ break;
+ case mp_subscr_node_type:
+ s = "subscript node";
+ break;
+ case mp_pair_node_type:
+ s = "pair node";
+ break;
+ case mp_transform_node_type:
+ s = "transform node";
+ break;
+ case mp_color_node_type:
+ s = "color node";
+ break;
+ case mp_cmykcolor_node_type:
+ s = "cmykcolor node";
+ break;
+ case mp_fill_node_type:
+ s = "fill node";
+ break;
+ case mp_stroked_node_type:
+ s = "stroked node";
+ break;
+ case mp_text_node_type:
+ s = "text node";
+ break;
+ case mp_start_clip_node_type:
+ s = "start clip node";
+ break;
+ case mp_start_bounds_node_type:
+ s = "start bounds node";
+ break;
+ case mp_stop_clip_node_type:
+ s = "stop clip node";
+ break;
+ case mp_stop_bounds_node_type:
+ s = "stop bounds node";
+ break;
+ case mp_dash_node_type:
+ s = "dash node";
+ break;
+ case mp_dep_node_type:
+ s = "dependency node";
+ break;
+ case mp_if_node_type:
+ s = "if node";
+ break;
+ case mp_edge_header_node_type:
+ s = "edge header node";
+ break;
+ default:
+ {
+ char ss[256];
+ mp_snprintf (ss, 256, "<unknown type %d>", t);
+ s = strdup(ss);
+ }
+ break;
+ }
+ return s;
+}
+void mp_print_type (MP mp, quarterword t) {
+ if (t >= 0 && t <= mp_edge_header_node_type)
+ mp_print (mp, mp_type_string (t));
+ else
+ mp_print (mp, "unknown");
+}
+
+
+@ Values inside \MP\ are stored in non-symbolic 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.
+
+@<Enumeration types...@>=
+typedef enum {
+ mp_root = 0, /* |name_type| at the top level of a variable */
+ mp_saved_root, /* same, when the variable has been saved */
+ mp_structured_root, /* |name_type| where a |mp_structured| branch occurs */
+ mp_subscr, /* |name_type| in a subscript node */
+ mp_attr, /* |name_type| in an attribute node */
+ mp_x_part_sector, /* |name_type| in the \&{xpart} of a node */
+ mp_y_part_sector, /* |name_type| in the \&{ypart} of a node */
+ mp_xx_part_sector, /* |name_type| in the \&{xxpart} of a node */
+ mp_xy_part_sector, /* |name_type| in the \&{xypart} of a node */
+ mp_yx_part_sector, /* |name_type| in the \&{yxpart} of a node */
+ mp_yy_part_sector, /* |name_type| in the \&{yypart} of a node */
+ mp_red_part_sector, /* |name_type| in the \&{redpart} of a node */
+ mp_green_part_sector, /* |name_type| in the \&{greenpart} of a node */
+ mp_blue_part_sector, /* |name_type| in the \&{bluepart} of a node */
+ mp_cyan_part_sector, /* |name_type| in the \&{redpart} of a node */
+ mp_magenta_part_sector, /* |name_type| in the \&{greenpart} of a node */
+ mp_yellow_part_sector, /* |name_type| in the \&{bluepart} of a node */
+ mp_black_part_sector, /* |name_type| in the \&{greenpart} of a node */
+ mp_grey_part_sector, /* |name_type| in the \&{bluepart} of a node */
+ mp_capsule, /* |name_type| in stashed-away subexpressions */
+ mp_token, /* |name_type| in a numeric token or string token */
+ /* Symbolic nodes also have |name_type|, which is a different enumeration */
+ mp_normal_sym,
+ mp_internal_sym, /* for values of internals */
+ mp_macro_sym, /* for macro names */
+ mp_expr_sym, /* for macro parameters if type |expr| */
+ mp_suffix_sym, /* for macro parameters if type |suffix| */
+ mp_text_sym, /* for macro parameters if type |text| */
+ @<Operation codes@>
+} mp_name_type_type;
+
+@ 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 such that
+they don't overlap with the type codes; some type codes (e.g., |mp_string_type|)
+are used as operators as well as type identifications. The relative values
+are not critical, except for |true_code..false_code|, |or_op..and_op|,
+and |filled_op..bounded_op|. The restrictions are that
+|and_op-false_code=or_op-true_code|, that the ordering of
+|x_part...blue_part| must match that of |x_part_sector..mp_blue_part_sector|,
+and the ordering of |filled_op..bounded_op| must match that of the code
+values they test for.
+
+@d mp_min_of mp_substring_of
+
+@<Operation codes@>=
+mp_true_code, /* operation code for \.{true} */
+mp_false_code, /* operation code for \.{false} */
+mp_null_picture_code, /* operation code for \.{nullpicture} */
+mp_null_pen_code, /* operation code for \.{nullpen} */
+mp_read_string_op, /* operation code for \.{readstring} */
+mp_pen_circle, /* operation code for \.{pencircle} */
+mp_normal_deviate, /* operation code for \.{normaldeviate} */
+mp_read_from_op, /* operation code for \.{readfrom} */
+mp_close_from_op, /* operation code for \.{closefrom} */
+mp_odd_op, /* operation code for \.{odd} */
+mp_known_op, /* operation code for \.{known} */
+mp_unknown_op, /* operation code for \.{unknown} */
+mp_not_op, /* operation code for \.{not} */
+mp_decimal, /* operation code for \.{decimal} */
+mp_reverse, /* operation code for \.{reverse} */
+mp_make_path_op, /* operation code for \.{makepath} */
+mp_make_pen_op, /* operation code for \.{makepen} */
+mp_oct_op, /* operation code for \.{oct} */
+mp_hex_op, /* operation code for \.{hex} */
+mp_ASCII_op, /* operation code for \.{ASCII} */
+mp_char_op, /* operation code for \.{char} */
+mp_length_op, /* operation code for \.{length} */
+mp_turning_op, /* operation code for \.{turningnumber} */
+mp_color_model_part, /* operation code for \.{colormodel} */
+mp_x_part, /* operation code for \.{xpart} */
+mp_y_part, /* operation code for \.{ypart} */
+mp_xx_part, /* operation code for \.{xxpart} */
+mp_xy_part, /* operation code for \.{xypart} */
+mp_yx_part, /* operation code for \.{yxpart} */
+mp_yy_part, /* operation code for \.{yypart} */
+mp_red_part, /* operation code for \.{redpart} */
+mp_green_part, /* operation code for \.{greenpart} */
+mp_blue_part, /* operation code for \.{bluepart} */
+mp_cyan_part, /* operation code for \.{cyanpart} */
+mp_magenta_part, /* operation code for \.{magentapart} */
+mp_yellow_part, /* operation code for \.{yellowpart} */
+mp_black_part, /* operation code for \.{blackpart} */
+mp_grey_part, /* operation code for \.{greypart} */
+mp_font_part, /* operation code for \.{fontpart} */
+mp_text_part, /* operation code for \.{textpart} */
+mp_path_part, /* operation code for \.{pathpart} */
+mp_pen_part, /* operation code for \.{penpart} */
+mp_dash_part, /* operation code for \.{dashpart} */
+mp_prescript_part, /* operation code for \.{prescriptpart} */
+mp_postscript_part, /* operation code for \.{postscriptpart} */
+mp_sqrt_op, /* operation code for \.{sqrt} */
+mp_m_exp_op, /* operation code for \.{mexp} */
+mp_m_log_op, /* operation code for \.{mlog} */
+mp_sin_d_op, /* operation code for \.{sind} */
+mp_cos_d_op, /* operation code for \.{cosd} */
+mp_floor_op, /* operation code for \.{floor} */
+mp_uniform_deviate, /* operation code for \.{uniformdeviate} */
+mp_char_exists_op, /* operation code for \.{charexists} */
+mp_font_size, /* operation code for \.{fontsize} */
+mp_ll_corner_op, /* operation code for \.{llcorner} */
+mp_lr_corner_op, /* operation code for \.{lrcorner} */
+mp_ul_corner_op, /* operation code for \.{ulcorner} */
+mp_ur_corner_op, /* operation code for \.{urcorner} */
+mp_arc_length, /* operation code for \.{arclength} */
+mp_angle_op, /* operation code for \.{angle} */
+mp_cycle_op, /* operation code for \.{cycle} */
+mp_filled_op, /* operation code for \.{filled} */
+mp_stroked_op, /* operation code for \.{stroked} */
+mp_textual_op, /* operation code for \.{textual} */
+mp_clipped_op, /* operation code for \.{clipped} */
+mp_bounded_op, /* operation code for \.{bounded} */
+mp_plus, /* operation code for \.+ */
+mp_minus, /* operation code for \.- */
+mp_times, /* operation code for \.* */
+mp_over, /* operation code for \./ */
+mp_pythag_add, /* operation code for \.{++} */
+mp_pythag_sub, /* operation code for \.{+-+} */
+mp_or_op, /* operation code for \.{or} */
+mp_and_op, /* operation code for \.{and} */
+mp_less_than, /* operation code for \.< */
+mp_less_or_equal, /* operation code for \.{<=} */
+mp_greater_than, /* operation code for \.> */
+mp_greater_or_equal, /* operation code for \.{>=} */
+mp_equal_to, /* operation code for \.= */
+mp_unequal_to, /* operation code for \.{<>} */
+mp_concatenate, /* operation code for \.\& */
+mp_rotated_by, /* operation code for \.{rotated} */
+mp_slanted_by, /* operation code for \.{slanted} */
+mp_scaled_by, /* operation code for \.{scaled} */
+mp_shifted_by, /* operation code for \.{shifted} */
+mp_transformed_by, /* operation code for \.{transformed} */
+mp_x_scaled, /* operation code for \.{xscaled} */
+mp_y_scaled, /* operation code for \.{yscaled} */
+mp_z_scaled, /* operation code for \.{zscaled} */
+mp_in_font, /* operation code for \.{infont} */
+mp_intersect, /* operation code for \.{intersectiontimes} */
+mp_double_dot, /* operation code for improper \.{..} */
+mp_substring_of, /* operation code for \.{substring} */
+mp_subpath_of, /* operation code for \.{subpath} */
+mp_direction_time_of, /* operation code for \.{directiontime} */
+mp_point_of, /* operation code for \.{point} */
+mp_precontrol_of, /* operation code for \.{precontrol} */
+mp_postcontrol_of, /* operation code for \.{postcontrol} */
+mp_pen_offset_of, /* operation code for \.{penoffset} */
+mp_arc_time_of, /* operation code for \.{arctime} */
+mp_version, /* operation code for \.{mpversion} */
+mp_envelope_of, /* operation code for \.{envelope} */
+mp_boundingpath_of, /* operation code for \.{boundingpath} */
+mp_glyph_infont, /* operation code for \.{glyph} */
+mp_kern_flag /* operation code for \.{kern} */
+
+@ @c
+static void mp_print_op (MP mp, quarterword c) {
+ if (c <= mp_numeric_type) {
+ mp_print_type (mp, c);
+ } else {
+ switch (c) {
+ case mp_true_code:
+ mp_print (mp, "true");
+ break;
+ case mp_false_code:
+ mp_print (mp, "false");
+ break;
+ case mp_null_picture_code:
+ mp_print (mp, "nullpicture");
+ break;
+ case mp_null_pen_code:
+ mp_print (mp, "nullpen");
+ break;
+ case mp_read_string_op:
+ mp_print (mp, "readstring");
+ break;
+ case mp_pen_circle:
+ mp_print (mp, "pencircle");
+ break;
+ case mp_normal_deviate:
+ mp_print (mp, "normaldeviate");
+ break;
+ case mp_read_from_op:
+ mp_print (mp, "readfrom");
+ break;
+ case mp_close_from_op:
+ mp_print (mp, "closefrom");
+ break;
+ case mp_odd_op:
+ mp_print (mp, "odd");
+ break;
+ case mp_known_op:
+ mp_print (mp, "known");
+ break;
+ case mp_unknown_op:
+ mp_print (mp, "unknown");
+ break;
+ case mp_not_op:
+ mp_print (mp, "not");
+ break;
+ case mp_decimal:
+ mp_print (mp, "decimal");
+ break;
+ case mp_reverse:
+ mp_print (mp, "reverse");
+ break;
+ case mp_make_path_op:
+ mp_print (mp, "makepath");
+ break;
+ case mp_make_pen_op:
+ mp_print (mp, "makepen");
+ break;
+ case mp_oct_op:
+ mp_print (mp, "oct");
+ break;
+ case mp_hex_op:
+ mp_print (mp, "hex");
+ break;
+ case mp_ASCII_op:
+ mp_print (mp, "ASCII");
+ break;
+ case mp_char_op:
+ mp_print (mp, "char");
+ break;
+ case mp_length_op:
+ mp_print (mp, "length");
+ break;
+ case mp_turning_op:
+ mp_print (mp, "turningnumber");
+ break;
+ case mp_x_part:
+ mp_print (mp, "xpart");
+ break;
+ case mp_y_part:
+ mp_print (mp, "ypart");
+ break;
+ case mp_xx_part:
+ mp_print (mp, "xxpart");
+ break;
+ case mp_xy_part:
+ mp_print (mp, "xypart");
+ break;
+ case mp_yx_part:
+ mp_print (mp, "yxpart");
+ break;
+ case mp_yy_part:
+ mp_print (mp, "yypart");
+ break;
+ case mp_red_part:
+ mp_print (mp, "redpart");
+ break;
+ case mp_green_part:
+ mp_print (mp, "greenpart");
+ break;
+ case mp_blue_part:
+ mp_print (mp, "bluepart");
+ break;
+ case mp_cyan_part:
+ mp_print (mp, "cyanpart");
+ break;
+ case mp_magenta_part:
+ mp_print (mp, "magentapart");
+ break;
+ case mp_yellow_part:
+ mp_print (mp, "yellowpart");
+ break;
+ case mp_black_part:
+ mp_print (mp, "blackpart");
+ break;
+ case mp_grey_part:
+ mp_print (mp, "greypart");
+ break;
+ case mp_color_model_part:
+ mp_print (mp, "colormodel");
+ break;
+ case mp_font_part:
+ mp_print (mp, "fontpart");
+ break;
+ case mp_text_part:
+ mp_print (mp, "textpart");
+ break;
+ case mp_prescript_part:
+ mp_print (mp, "prescriptpart");
+ break;
+ case mp_postscript_part:
+ mp_print (mp, "postscriptpart");
+ break;
+ case mp_path_part:
+ mp_print (mp, "pathpart");
+ break;
+ case mp_pen_part:
+ mp_print (mp, "penpart");
+ break;
+ case mp_dash_part:
+ mp_print (mp, "dashpart");
+ break;
+ case mp_sqrt_op:
+ mp_print (mp, "sqrt");
+ break;
+ case mp_m_exp_op:
+ mp_print (mp, "mexp");
+ break;
+ case mp_m_log_op:
+ mp_print (mp, "mlog");
+ break;
+ case mp_sin_d_op:
+ mp_print (mp, "sind");
+ break;
+ case mp_cos_d_op:
+ mp_print (mp, "cosd");
+ break;
+ case mp_floor_op:
+ mp_print (mp, "floor");
+ break;
+ case mp_uniform_deviate:
+ mp_print (mp, "uniformdeviate");
+ break;
+ case mp_char_exists_op:
+ mp_print (mp, "charexists");
+ break;
+ case mp_font_size:
+ mp_print (mp, "fontsize");
+ break;
+ case mp_ll_corner_op:
+ mp_print (mp, "llcorner");
+ break;
+ case mp_lr_corner_op:
+ mp_print (mp, "lrcorner");
+ break;
+ case mp_ul_corner_op:
+ mp_print (mp, "ulcorner");
+ break;
+ case mp_ur_corner_op:
+ mp_print (mp, "urcorner");
+ break;
+ case mp_arc_length:
+ mp_print (mp, "arclength");
+ break;
+ case mp_angle_op:
+ mp_print (mp, "angle");
+ break;
+ case mp_cycle_op:
+ mp_print (mp, "cycle");
+ break;
+ case mp_filled_op:
+ mp_print (mp, "filled");
+ break;
+ case mp_stroked_op:
+ mp_print (mp, "stroked");
+ break;
+ case mp_textual_op:
+ mp_print (mp, "textual");
+ break;
+ case mp_clipped_op:
+ mp_print (mp, "clipped");
+ break;
+ case mp_bounded_op:
+ mp_print (mp, "bounded");
+ break;
+ case mp_plus:
+ mp_print_char (mp, xord ('+'));
+ break;
+ case mp_minus:
+ mp_print_char (mp, xord ('-'));
+ break;
+ case mp_times:
+ mp_print_char (mp, xord ('*'));
+ break;
+ case mp_over:
+ mp_print_char (mp, xord ('/'));
+ break;
+ case mp_pythag_add:
+ mp_print (mp, "++");
+ break;
+ case mp_pythag_sub:
+ mp_print (mp, "+-+");
+ break;
+ case mp_or_op:
+ mp_print (mp, "or");
+ break;
+ case mp_and_op:
+ mp_print (mp, "and");
+ break;
+ case mp_less_than:
+ mp_print_char (mp, xord ('<'));
+ break;
+ case mp_less_or_equal:
+ mp_print (mp, "<=");
+ break;
+ case mp_greater_than:
+ mp_print_char (mp, xord ('>'));
+ break;
+ case mp_greater_or_equal:
+ mp_print (mp, ">=");
+ break;
+ case mp_equal_to:
+ mp_print_char (mp, xord ('='));
+ break;
+ case mp_unequal_to:
+ mp_print (mp, "<>");
+ break;
+ case mp_concatenate:
+ mp_print (mp, "&");
+ break;
+ case mp_rotated_by:
+ mp_print (mp, "rotated");
+ break;
+ case mp_slanted_by:
+ mp_print (mp, "slanted");
+ break;
+ case mp_scaled_by:
+ mp_print (mp, "scaled");
+ break;
+ case mp_shifted_by:
+ mp_print (mp, "shifted");
+ break;
+ case mp_transformed_by:
+ mp_print (mp, "transformed");
+ break;
+ case mp_x_scaled:
+ mp_print (mp, "xscaled");
+ break;
+ case mp_y_scaled:
+ mp_print (mp, "yscaled");
+ break;
+ case mp_z_scaled:
+ mp_print (mp, "zscaled");
+ break;
+ case mp_in_font:
+ mp_print (mp, "infont");
+ break;
+ case mp_intersect:
+ mp_print (mp, "intersectiontimes");
+ break;
+ case mp_substring_of:
+ mp_print (mp, "substring");
+ break;
+ case mp_subpath_of:
+ mp_print (mp, "subpath");
+ break;
+ case mp_direction_time_of:
+ mp_print (mp, "directiontime");
+ break;
+ case mp_point_of:
+ mp_print (mp, "point");
+ break;
+ case mp_precontrol_of:
+ mp_print (mp, "precontrol");
+ break;
+ case mp_postcontrol_of:
+ mp_print (mp, "postcontrol");
+ break;
+ case mp_pen_offset_of:
+ mp_print (mp, "penoffset");
+ break;
+ case mp_arc_time_of:
+ mp_print (mp, "arctime");
+ break;
+ case mp_version:
+ mp_print (mp, "mpversion");
+ break;
+ case mp_envelope_of:
+ mp_print (mp, "envelope");
+ break;
+ case mp_boundingpath_of:
+ mp_print (mp, "boundingpath");
+ break;
+ case mp_glyph_infont:
+ mp_print (mp, "glyph");
+ break;
+ default:
+ mp_print (mp, "..");
+ break;
+ }
+ }
+}
+
+
+@ \MP\ also has a bunch of internal parameters that a user might want to
+fuss with. Every such parameter has an identifying code number, defined here.
+
+@<Types...@>=
+enum mp_given_internal {
+ mp_output_template = 1, /* a string set up by \&{outputtemplate} */
+ mp_output_filename, /* the output file name, accessible as \&{outputfilename} */
+ mp_output_format, /* the output format set up by \&{outputformat} */
+ mp_output_format_options, /* the output format options set up by \&{outputformatoptions} */
+ mp_number_system, /* the number system as set up by \&{numbersystem} */
+ mp_number_precision, /* the number system precision as set up by \&{numberprecision} */
+ mp_job_name, /* the perceived jobname, as set up from the options stucture,
+ the name of the input file, or by \&{jobname} */
+ mp_tracing_titles, /* show titles online when they appear */
+ mp_tracing_equations, /* show each variable when it becomes known */
+ mp_tracing_capsules, /* show capsules too */
+ mp_tracing_choices, /* show the control points chosen for paths */
+ mp_tracing_specs, /* show path subdivision prior to filling with polygonal a pen */
+ mp_tracing_commands, /* show commands and operations before they are performed */
+ mp_tracing_restores, /* show when a variable or internal is restored */
+ mp_tracing_macros, /* show macros before they are expanded */
+ mp_tracing_output, /* show digitized edges as they are output */
+ mp_tracing_stats, /* show memory usage at end of job */
+ mp_tracing_lost_chars, /* show characters that aren't \&{infont} */
+ mp_tracing_online, /* show long diagnostics on terminal and in the log file */
+ mp_year, /* the current year (e.g., 1984) */
+ mp_month, /* the current month (e.g., 3 $\equiv$ March) */
+ mp_day, /* the current day of the month */
+ mp_time, /* the number of minutes past midnight when this job started */
+ mp_hour, /* the number of hours past midnight when this job started */
+ mp_minute, /* the number of minutes in that hour when this job started */
+ mp_char_code, /* the number of the next character to be output */
+ mp_char_ext, /* the extension code of the next character to be output */
+ mp_char_wd, /* the width of the next character to be output */
+ mp_char_ht, /* the height of the next character to be output */
+ mp_char_dp, /* the depth of the next character to be output */
+ mp_char_ic, /* the italic correction of the next character to be output */
+ mp_design_size, /* the unit of measure used for |mp_char_wd..mp_char_ic|, in points */
+ mp_pausing, /* positive to display lines on the terminal before they are read */
+ mp_showstopping, /* positive to stop after each \&{show} command */
+ mp_fontmaking, /* positive if font metric output is to be produced */
+ mp_texscriptmode, /* controls spacing in texmode */
+ mp_linejoin, /* as in \ps: 0 for mitered, 1 for round, 2 for beveled */
+ mp_linecap, /* as in \ps: 0 for butt, 1 for round, 2 for square */
+ mp_miterlimit, /* controls miter length as in \ps */
+ mp_warning_check, /* controls error message when variable value is large */
+ mp_boundary_char, /* the right boundary character for ligatures */
+ mp_prologues, /* positive to output conforming PostScript using built-in fonts */
+ mp_true_corners, /* positive to make \&{llcorner} etc. ignore \&{setbounds} */
+ mp_default_color_model, /* the default color model for unspecified items */
+ mp_restore_clip_color,
+ mp_procset, /* wether or not create PostScript command shortcuts */
+ mp_hppp, /* horizontal pixels per point (for png output) */
+ mp_vppp, /* vertical pixels per point (for png output) */
+ mp_gtroffmode, /* whether the user specified |-troff| on the command line */
+};
+typedef struct {
+ mp_value v;
+ char *intname;
+} mp_internal;
+
+
+@ @<MPlib internal header stuff@>=
+#define internal_value(A) mp->internal[(A)].v.data.n
+#define set_internal_from_number(A,B) do { \
+ number_clone (internal_value ((A)),(B));\
+} while (0)
+#define internal_string(A) (mp_string)mp->internal[(A)].v.data.str
+#define set_internal_string(A,B) mp->internal[(A)].v.data.str=(B)
+#define internal_name(A) mp->internal[(A)].intname
+#define set_internal_name(A,B) mp->internal[(A)].intname=(B)
+#define internal_type(A) (mp_variable_type)mp->internal[(A)].v.type
+#define set_internal_type(A,B) mp->internal[(A)].v.type=(B)
+#define set_internal_from_cur_exp(A) do { \
+ if (internal_type ((A)) == mp_string_type) { \
+ add_str_ref (cur_exp_str ()); \
+ set_internal_string ((A), cur_exp_str ()); \
+ } else { \
+ set_internal_from_number ((A), cur_exp_value_number ()); \
+ } \
+} while (0)
+
+
+
+@
+
+@d max_given_internal mp_gtroffmode
+
+@<Glob...@>=
+mp_internal *internal; /* the values of internal quantities */
+int int_ptr; /* the maximum internal quantity defined so far */
+int max_internal; /* current maximum number of internal quantities */
+
+@ @<Option variables@>=
+int troff_mode;
+
+@ @<Allocate or initialize ...@>=
+mp->max_internal = 2 * max_given_internal;
+mp->internal = xmalloc ((mp->max_internal + 1), sizeof (mp_internal));
+memset (mp->internal, 0,
+ (size_t) (mp->max_internal + 1) * sizeof (mp_internal));
+{
+ int i;
+ for (i = 1; i <= mp->max_internal; i++) {
+ new_number(mp->internal[i].v.data.n);
+ }
+ for (i = 1; i <= max_given_internal; i++) {
+ set_internal_type (i, mp_known);
+ }
+}
+set_internal_type (mp_output_format, mp_string_type);
+set_internal_type (mp_output_filename, mp_string_type);
+set_internal_type (mp_output_format_options, mp_string_type);
+set_internal_type (mp_output_template, mp_string_type);
+set_internal_type (mp_number_system, mp_string_type);
+set_internal_type (mp_job_name, mp_string_type);
+mp->troff_mode = (opt->troff_mode > 0 ? true : false);
+
+@ @<Exported function ...@>=
+int mp_troff_mode (MP mp);
+
+@ @c
+int mp_troff_mode (MP mp) {
+ return mp->troff_mode;
+}
+
+
+@ @<Set initial ...@>=
+mp->int_ptr = max_given_internal;
+
+@ The symbolic names for internal quantities are put into \MP's hash table
+by using a routine called |primitive|, which will be defined later. Let us
+enter them now, so that we don't have to list all those names again
+anywhere else.
+
+@<Put each of \MP's primitives into the hash table@>=
+mp_primitive (mp, "tracingtitles", mp_internal_quantity, mp_tracing_titles);
+@:tracingtitles_}{\&{tracingtitles} primitive@>;
+mp_primitive (mp, "tracingequations", mp_internal_quantity, mp_tracing_equations);
+@:mp_tracing_equations_}{\&{tracingequations} primitive@>;
+mp_primitive (mp, "tracingcapsules", mp_internal_quantity, mp_tracing_capsules);
+@:mp_tracing_capsules_}{\&{tracingcapsules} primitive@>;
+mp_primitive (mp, "tracingchoices", mp_internal_quantity, mp_tracing_choices);
+@:mp_tracing_choices_}{\&{tracingchoices} primitive@>;
+mp_primitive (mp, "tracingspecs", mp_internal_quantity, mp_tracing_specs);
+@:mp_tracing_specs_}{\&{tracingspecs} primitive@>;
+mp_primitive (mp, "tracingcommands", mp_internal_quantity, mp_tracing_commands);
+@:mp_tracing_commands_}{\&{tracingcommands} primitive@>;
+mp_primitive (mp, "tracingrestores", mp_internal_quantity, mp_tracing_restores);
+@:mp_tracing_restores_}{\&{tracingrestores} primitive@>;
+mp_primitive (mp, "tracingmacros", mp_internal_quantity, mp_tracing_macros);
+@:mp_tracing_macros_}{\&{tracingmacros} primitive@>;
+mp_primitive (mp, "tracingoutput", mp_internal_quantity, mp_tracing_output);
+@:mp_tracing_output_}{\&{tracingoutput} primitive@>;
+mp_primitive (mp, "tracingstats", mp_internal_quantity, mp_tracing_stats);
+@:mp_tracing_stats_}{\&{tracingstats} primitive@>;
+mp_primitive (mp, "tracinglostchars", mp_internal_quantity, mp_tracing_lost_chars);
+@:mp_tracing_lost_chars_}{\&{tracinglostchars} primitive@>;
+mp_primitive (mp, "tracingonline", mp_internal_quantity, mp_tracing_online);
+@:mp_tracing_online_}{\&{tracingonline} primitive@>;
+mp_primitive (mp, "year", mp_internal_quantity, mp_year);
+@:mp_year_}{\&{year} primitive@>;
+mp_primitive (mp, "month", mp_internal_quantity, mp_month);
+@:mp_month_}{\&{month} primitive@>;
+mp_primitive (mp, "day", mp_internal_quantity, mp_day);
+@:mp_day_}{\&{day} primitive@>;
+mp_primitive (mp, "time", mp_internal_quantity, mp_time);
+@:time_}{\&{time} primitive@>;
+mp_primitive (mp, "hour", mp_internal_quantity, mp_hour);
+@:hour_}{\&{hour} primitive@>;
+mp_primitive (mp, "minute", mp_internal_quantity, mp_minute);
+@:minute_}{\&{minute} primitive@>;
+mp_primitive (mp, "charcode", mp_internal_quantity, mp_char_code);
+@:mp_char_code_}{\&{charcode} primitive@>;
+mp_primitive (mp, "charext", mp_internal_quantity, mp_char_ext);
+@:mp_char_ext_}{\&{charext} primitive@>;
+mp_primitive (mp, "charwd", mp_internal_quantity, mp_char_wd);
+@:mp_char_wd_}{\&{charwd} primitive@>;
+mp_primitive (mp, "charht", mp_internal_quantity, mp_char_ht);
+@:mp_char_ht_}{\&{charht} primitive@>;
+mp_primitive (mp, "chardp", mp_internal_quantity, mp_char_dp);
+@:mp_char_dp_}{\&{chardp} primitive@>;
+mp_primitive (mp, "charic", mp_internal_quantity, mp_char_ic);
+@:mp_char_ic_}{\&{charic} primitive@>;
+mp_primitive (mp, "designsize", mp_internal_quantity, mp_design_size);
+@:mp_design_size_}{\&{designsize} primitive@>;
+mp_primitive (mp, "pausing", mp_internal_quantity, mp_pausing);
+@:mp_pausing_}{\&{pausing} primitive@>;
+mp_primitive (mp, "showstopping", mp_internal_quantity, mp_showstopping);
+@:mp_showstopping_}{\&{showstopping} primitive@>;
+mp_primitive (mp, "fontmaking", mp_internal_quantity, mp_fontmaking);
+@:mp_fontmaking_}{\&{fontmaking} primitive@>;
+mp_primitive (mp, "texscriptmode", mp_internal_quantity, mp_texscriptmode);
+@:mp_texscriptmode_}{\&{texscriptmode} primitive@>;
+mp_primitive (mp, "linejoin", mp_internal_quantity, mp_linejoin);
+@:mp_linejoin_}{\&{linejoin} primitive@>;
+mp_primitive (mp, "linecap", mp_internal_quantity, mp_linecap);
+@:mp_linecap_}{\&{linecap} primitive@>;
+mp_primitive (mp, "miterlimit", mp_internal_quantity, mp_miterlimit);
+@:mp_miterlimit_}{\&{miterlimit} primitive@>;
+mp_primitive (mp, "warningcheck", mp_internal_quantity, mp_warning_check);
+@:mp_warning_check_}{\&{warningcheck} primitive@>;
+mp_primitive (mp, "boundarychar", mp_internal_quantity, mp_boundary_char);
+@:mp_boundary_char_}{\&{boundarychar} primitive@>;
+mp_primitive (mp, "prologues", mp_internal_quantity, mp_prologues);
+@:mp_prologues_}{\&{prologues} primitive@>;
+mp_primitive (mp, "truecorners", mp_internal_quantity, mp_true_corners);
+@:mp_true_corners_}{\&{truecorners} primitive@>;
+mp_primitive (mp, "mpprocset", mp_internal_quantity, mp_procset);
+@:mp_procset_}{\&{mpprocset} primitive@>;
+mp_primitive (mp, "troffmode", mp_internal_quantity, mp_gtroffmode);
+@:troffmode_}{\&{troffmode} primitive@>;
+mp_primitive (mp, "defaultcolormodel", mp_internal_quantity, mp_default_color_model);
+@:mp_default_color_model_}{\&{defaultcolormodel} primitive@>;
+mp_primitive (mp, "restoreclipcolor", mp_internal_quantity, mp_restore_clip_color);
+@:mp_restore_clip_color_}{\&{restoreclipcolor} primitive@>;
+mp_primitive (mp, "outputtemplate", mp_internal_quantity, mp_output_template);
+@:mp_output_template_}{\&{outputtemplate} primitive@>;
+mp_primitive (mp, "outputfilename", mp_internal_quantity, mp_output_filename);
+@:mp_output_filename_}{\&{outputfilename} primitive@>;
+mp_primitive (mp, "numbersystem", mp_internal_quantity, mp_number_system);
+@:mp_number_system_}{\&{numbersystem} primitive@>;
+mp_primitive (mp, "numberprecision", mp_internal_quantity, mp_number_precision);
+@:mp_number_precision_}{\&{numberprecision} primitive@>;
+mp_primitive (mp, "outputformat", mp_internal_quantity, mp_output_format);
+@:mp_output_format_}{\&{outputformat} primitive@>;
+mp_primitive (mp, "outputformatoptions", mp_internal_quantity, mp_output_format_options);
+@:mp_output_format_options_}{\&{outputformatoptions} primitive@>;
+mp_primitive (mp, "jobname", mp_internal_quantity, mp_job_name);
+@:mp_job_name_}{\&{jobname} primitive@>
+mp_primitive (mp, "hppp", mp_internal_quantity, mp_hppp);
+@:mp_hppp_}{\&{hppp} primitive@>;
+mp_primitive (mp, "vppp", mp_internal_quantity, mp_vppp);
+@:mp_vppp_}{\&{vppp} 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.
+
+@<MPlib header stuff@>=
+enum mp_color_model {
+ mp_no_model = 1,
+ mp_grey_model = 3,
+ mp_rgb_model = 5,
+ mp_cmyk_model = 7,
+ mp_uninitialized_model = 9
+};
+
+
+@ @<Initialize table entries@>=
+set_internal_from_number (mp_default_color_model, unity_t);
+number_multiply_int (internal_value (mp_default_color_model), mp_rgb_model);
+number_clone (internal_value (mp_restore_clip_color), unity_t);
+number_clone (internal_value (mp_hppp), unity_t);
+number_clone (internal_value (mp_vppp), unity_t);
+set_internal_string (mp_output_template, mp_intern (mp, "%j.%c"));
+set_internal_string (mp_output_filename, mp_intern (mp, ""));
+set_internal_string (mp_output_format, mp_intern (mp, "eps"));
+set_internal_string (mp_output_format_options, mp_intern (mp, ""));
+set_internal_string (mp_number_system, mp_intern (mp, "scaled"));
+set_internal_from_number (mp_number_precision, precision_default);
+set_internal_from_number (mp_texscriptmode, unity_t);
+#if DEBUG
+number_clone (internal_value (mp_tracing_titles), three_t);
+number_clone (internal_value (mp_tracing_equations), three_t);
+number_clone (internal_value (mp_tracing_capsules), three_t);
+number_clone (internal_value (mp_tracing_choices), three_t);
+number_clone (internal_value (mp_tracing_specs), three_t);
+number_clone (internal_value (mp_tracing_commands), three_t);
+number_clone (internal_value (mp_tracing_restores), three_t);
+number_clone (internal_value (mp_tracing_macros), three_t);
+number_clone (internal_value (mp_tracing_output), three_t);
+number_clone (internal_value (mp_tracing_stats), three_t);
+number_clone (internal_value (mp_tracing_lost_chars), three_t);
+number_clone (internal_value (mp_tracing_online), three_t);
+#endif
+
+@ Well, we do have to list the names one more time, for use in symbolic
+printouts.
+
+@<Initialize table...@>=
+set_internal_name (mp_tracing_titles, xstrdup ("tracingtitles"));
+set_internal_name (mp_tracing_equations, xstrdup ("tracingequations"));
+set_internal_name (mp_tracing_capsules, xstrdup ("tracingcapsules"));
+set_internal_name (mp_tracing_choices, xstrdup ("tracingchoices"));
+set_internal_name (mp_tracing_specs, xstrdup ("tracingspecs"));
+set_internal_name (mp_tracing_commands, xstrdup ("tracingcommands"));
+set_internal_name (mp_tracing_restores, xstrdup ("tracingrestores"));
+set_internal_name (mp_tracing_macros, xstrdup ("tracingmacros"));
+set_internal_name (mp_tracing_output, xstrdup ("tracingoutput"));
+set_internal_name (mp_tracing_stats, xstrdup ("tracingstats"));
+set_internal_name (mp_tracing_lost_chars, xstrdup ("tracinglostchars"));
+set_internal_name (mp_tracing_online, xstrdup ("tracingonline"));
+set_internal_name (mp_year, xstrdup ("year"));
+set_internal_name (mp_month, xstrdup ("month"));
+set_internal_name (mp_day, xstrdup ("day"));
+set_internal_name (mp_time, xstrdup ("time"));
+set_internal_name (mp_hour, xstrdup ("hour"));
+set_internal_name (mp_minute, xstrdup ("minute"));
+set_internal_name (mp_char_code, xstrdup ("charcode"));
+set_internal_name (mp_char_ext, xstrdup ("charext"));
+set_internal_name (mp_char_wd, xstrdup ("charwd"));
+set_internal_name (mp_char_ht, xstrdup ("charht"));
+set_internal_name (mp_char_dp, xstrdup ("chardp"));
+set_internal_name (mp_char_ic, xstrdup ("charic"));
+set_internal_name (mp_design_size, xstrdup ("designsize"));
+set_internal_name (mp_pausing, xstrdup ("pausing"));
+set_internal_name (mp_showstopping, xstrdup ("showstopping"));
+set_internal_name (mp_fontmaking, xstrdup ("fontmaking"));
+set_internal_name (mp_texscriptmode, xstrdup ("texscriptmode"));
+set_internal_name (mp_linejoin, xstrdup ("linejoin"));
+set_internal_name (mp_linecap, xstrdup ("linecap"));
+set_internal_name (mp_miterlimit, xstrdup ("miterlimit"));
+set_internal_name (mp_warning_check, xstrdup ("warningcheck"));
+set_internal_name (mp_boundary_char, xstrdup ("boundarychar"));
+set_internal_name (mp_prologues, xstrdup ("prologues"));
+set_internal_name (mp_true_corners, xstrdup ("truecorners"));
+set_internal_name (mp_default_color_model, xstrdup ("defaultcolormodel"));
+set_internal_name (mp_procset, xstrdup ("mpprocset"));
+set_internal_name (mp_gtroffmode, xstrdup ("troffmode"));
+set_internal_name (mp_restore_clip_color, xstrdup ("restoreclipcolor"));
+set_internal_name (mp_output_template, xstrdup ("outputtemplate"));
+set_internal_name (mp_output_filename, xstrdup ("outputfilename"));
+set_internal_name (mp_output_format, xstrdup ("outputformat"));
+set_internal_name (mp_output_format_options, xstrdup ("outputformatoptions"));
+set_internal_name (mp_job_name, xstrdup ("jobname"));
+set_internal_name (mp_number_system, xstrdup ("numbersystem"));
+set_internal_name (mp_number_precision, xstrdup ("numberprecision"));
+set_internal_name (mp_hppp, xstrdup ("hppp"));
+set_internal_name (mp_vppp, xstrdup ("vppp"));
+
+@ The following procedure, which is called just before \MP\ initializes its
+input and output, establishes the initial values of the date and time.
+@^system dependencies@>
+
+Note that the values are |scaled| integers. Hence \MP\ can no longer
+be used after the year 32767.
+
+@c
+#if defined(_MSC_VER)
+#define strtoull _strtoui64
+#endif
+static void mp_fix_date_and_time (MP mp) {
+ char *source_date_epoch;
+ time_t epoch;
+ char *endptr;
+ struct tm *tmptr;
+ source_date_epoch = getenv("SOURCE_DATE_EPOCH");
+ if (source_date_epoch) {
+ errno = 0;
+ epoch = strtoull(source_date_epoch, &endptr, 10);
+ if (*endptr != '\0' || errno != 0) {
+ FATAL1("invalid epoch-seconds-timezone value for environment variable $SOURCE_DATE_EPOCH: %s",
+ source_date_epoch);
+ }
+/* there is a limit 3001.01.01:2059 for epoch in Microsoft C */
+#if defined(_MSC_VER)
+ if (epoch > 32535291599ULL)
+ epoch = 32535291599ULL;
+#endif
+ tmptr = gmtime (&epoch);
+ } else {
+ epoch = time ((time_t *) 0);
+ tmptr = localtime (&epoch);
+ }
+ set_internal_from_number (mp_time, unity_t);
+ number_multiply_int (internal_value(mp_time), (tmptr->tm_hour * 60 + tmptr->tm_min));
+ set_internal_from_number (mp_hour, unity_t);
+ number_multiply_int (internal_value(mp_hour), (tmptr->tm_hour));
+ set_internal_from_number (mp_minute, unity_t);
+ number_multiply_int (internal_value(mp_minute), (tmptr->tm_min));
+ set_internal_from_number (mp_day, unity_t);
+ number_multiply_int (internal_value(mp_day), (tmptr->tm_mday));
+ set_internal_from_number (mp_month, unity_t);
+ number_multiply_int (internal_value(mp_month), (tmptr->tm_mon + 1));
+ set_internal_from_number (mp_year, unity_t);
+ number_multiply_int (internal_value(mp_year), (tmptr->tm_year + 1900));
+}
+
+
+@ @<Declarations@>=
+static void mp_fix_date_and_time (MP mp);
+
+@ \MP\ is occasionally supposed to print diagnostic information that
+goes only into the transcript file, unless |mp_tracing_online| is positive.
+Now that we have defined |mp_tracing_online| we can define
+two routines that adjust the destination of print commands:
+
+@<Declarations@>=
+static void mp_begin_diagnostic (MP mp);
+static void mp_end_diagnostic (MP mp, boolean blank_line);
+static void mp_print_diagnostic (MP mp, const char *s, const char *t,
+ boolean nuline);
+
+@ @<Basic printing...@>=
+void mp_begin_diagnostic (MP mp) { /* prepare to do some tracing */
+ mp->old_setting = mp->selector;
+ if (number_nonpositive(internal_value (mp_tracing_online))
+ && (mp->selector == term_and_log)) {
+ decr (mp->selector);
+ if (mp->history == mp_spotless)
+ mp->history = mp_warning_issued;
+ }
+}
+@#
+void mp_end_diagnostic (MP mp, boolean blank_line) {
+ /* restore proper conditions after tracing */
+ mp_print_nl (mp, "");
+ if (blank_line)
+ mp_print_ln (mp);
+ mp->selector = mp->old_setting;
+}
+
+
+@
+
+@<Glob...@>=
+unsigned int old_setting;
+
+@ We will occasionally use |begin_diagnostic| in connection with line-number
+printing, as follows. (The parameter |s| is typically |"Path"| or
+|"Cycle spec"|, etc.)
+
+@<Basic printing...@>=
+void mp_print_diagnostic (MP mp, const char *s, const char *t, boolean nuline) {
+ mp_begin_diagnostic (mp);
+ if (nuline)
+ mp_print_nl (mp, s);
+ else
+ mp_print (mp, s);
+ mp_print (mp, " at line ");
+ mp_print_int (mp, mp_true_line (mp));
+ mp_print (mp, t);
+ mp_print_char (mp, xord (':'));
+}
+
+
+@ The 256 |ASCII_code| characters are grouped into classes by means of
+the |char_class| table. Individual class numbers have no semantic
+or syntactic significance, except in a few instances defined here.
+There's also |max_class|, which can be used as a basis for additional
+class numbers in nonstandard extensions of \MP.
+
+@d digit_class 0 /* the class number of \.{0123456789} */
+@d period_class 1 /* the class number of `\..' */
+@d space_class 2 /* the class number of spaces and nonstandard characters */
+@d percent_class 3 /* the class number of `\.\%' */
+@d string_class 4 /* the class number of `\."' */
+@d right_paren_class 8 /* the class number of `\.)' */
+@d isolated_classes 5: case 6: case 7: case 8 /* characters that make length-one tokens only */
+@d letter_class 9 /* letters and the underline character */
+@d mp_left_bracket_class 17 /* `\.[' */
+@d mp_right_bracket_class 18 /* `\.]' */
+@d invalid_class 20 /* bad character in the input */
+@d max_class 20 /* the largest class number */
+
+@d semicolon_class 6 /* the ; */
+
+@<Glob...@>=
+#define digit_class 0 /* the class number of \.{0123456789} */
+int char_class[256]; /* the class numbers */
+
+@ If changes are made to accommodate non-ASCII character sets, they should
+follow the guidelines in Appendix~C of {\sl The {\logos METAFONT\/}book}.
+@:METAFONTbook}{\sl The {\logos METAFONT\/}book@>
+@^system dependencies@>
+
+@<Set initial ...@>=
+for (k = '0'; k <= '9'; k++)
+ mp->char_class[k] = digit_class;
+mp->char_class['.'] = period_class;
+mp->char_class[' '] = space_class;
+mp->char_class['%'] = percent_class;
+mp->char_class['"'] = string_class;
+mp->char_class[','] = 5;
+mp->char_class[';'] = 6;
+mp->char_class['('] = 7;
+mp->char_class[')'] = right_paren_class;
+for (k = 'A'; k <= 'Z'; k++)
+ mp->char_class[k] = letter_class;
+for (k = 'a'; k <= 'z'; k++)
+ mp->char_class[k] = letter_class;
+mp->char_class['_'] = letter_class;
+mp->char_class['<'] = 10;
+mp->char_class['='] = 10;
+mp->char_class['>'] = 10;
+mp->char_class[':'] = 10;
+mp->char_class['|'] = 10;
+mp->char_class['`'] = 11;
+mp->char_class['\''] = 11;
+mp->char_class['+'] = 12;
+mp->char_class['-'] = 12;
+mp->char_class['/'] = 13;
+mp->char_class['*'] = 13;
+mp->char_class['\\'] = 13;
+mp->char_class['!'] = 14;
+mp->char_class['?'] = 14;
+mp->char_class['#'] = 15;
+mp->char_class['&'] = 15;
+mp->char_class['@@'] = 15;
+mp->char_class['$'] = 15;
+mp->char_class['^'] = 16;
+mp->char_class['~'] = 16;
+mp->char_class['['] = mp_left_bracket_class;
+mp->char_class[']'] = mp_right_bracket_class;
+mp->char_class['{'] = 19;
+mp->char_class['}'] = 19;
+for (k = 0; k < ' '; k++)
+ mp->char_class[k] = invalid_class;
+mp->char_class['\t'] = space_class;
+mp->char_class['\f'] = space_class;
+for (i=127;i<=255;i++) {
+ mp->char_class[i] = mp->utf8_mode ? letter_class : invalid_class;
+}
+
+@* The hash table.
+
+Symbolic tokens are stored in and retrieved from an AVL tree. This
+is not as fast as an actual hash table, but it is easily extensible.
+
+A symbolic token contains a pointer to the |mp_string| that
+contains the string representation of the symbol, a |halfword|
+that holds the current command value of the token, and an
+|mp_value| for the associated equivalent.
+
+@d set_text(A) do {
+ FUNCTION_TRACE3 ("set_text(%p, %p)\n",(A),(B));
+ (A)->text=(B) ;
+} while (0)
+
+@d set_eq_type(A,B) do {
+ FUNCTION_TRACE3 ("set_eq_type(%p, %d)\n",(A),(B));
+ (A)->type=(B) ;
+} while (0)
+
+@d set_equiv(A,B) do {
+ FUNCTION_TRACE3 ("set_equiv(%p, %d)\n",(A),(B));
+ (A)->v.data.node=NULL ;
+ (A)->v.data.indep.serial=(B);
+} while (0)
+
+@d set_equiv_node(A,B) do {
+ FUNCTION_TRACE3 ("set_equiv_node(%p, %p)\n",(A),(B));
+ (A)->v.data.node=(B) ;
+ (A)->v.data.indep.serial=0;
+} while (0)
+
+@d set_equiv_sym(A,B) do {
+ FUNCTION_TRACE3 ("set_equiv_sym(%p, %p)\n",(A),(B));
+ (A)->v.data.node=(mp_node)(B);
+ (A)->v.data.indep.serial=0;
+} while (0)
+
+@ @c
+#if DEBUG
+#define text(A) do_get_text(mp, (A))
+#define eq_type(A) do_get_eq_type(mp, (A))
+#define equiv(A) do_get_equiv(mp, (A))
+#define equiv_node(A) do_get_equiv_node(mp, (A))
+#define equiv_sym(A) do_get_equiv_sym(mp, (A))
+static mp_string do_get_text (MP mp, mp_sym A) {
+ FUNCTION_TRACE3 ("%d = do_get_text(%p)\n",A->text,A);
+ return A->text;
+}
+static halfword do_get_eq_type (MP mp, mp_sym A) {
+ FUNCTION_TRACE3 ("%d = do_get_eq_type(%p)\n",A->type,A);
+ return A->type;
+}
+static halfword do_get_equiv (MP mp, mp_sym A) {
+ FUNCTION_TRACE3 ("%d = do_get_equiv(%p)\n",A->v.data.indep.serial,A);
+ return A->v.data.indep.serial;
+}
+static mp_node do_get_equiv_node (MP mp, mp_sym A) {
+ FUNCTION_TRACE3 ("%p = do_get_equiv_node(%p)\n",A->v.data.node,A);
+ return A->v.data.node;
+}
+static mp_sym do_get_equiv_sym (MP mp, mp_sym A) {
+ FUNCTION_TRACE3 ("%p = do_get_equiv_sym(%p)\n",A->v.data.node,A);
+ return (mp_sym)A->v.data.node;
+}
+#else
+#define text(A) (A)->text
+#define eq_type(A) (A)->type
+#define equiv(A) (A)->v.data.indep.serial
+#define equiv_node(A) (A)->v.data.node
+#define equiv_sym(A) (mp_sym)(A)->v.data.node
+#endif
+
+@ @<Declarations...@>=
+#if DEBUG
+static mp_string do_get_text (MP mp, mp_sym A);
+static halfword do_get_eq_type (MP mp, mp_sym A);
+static halfword do_get_equiv (MP mp, mp_sym A);
+static mp_node do_get_equiv_node (MP mp, mp_sym A);
+static mp_sym do_get_equiv_sym (MP mp, mp_sym A);
+#endif
+
+@ @<Types...@>=
+typedef struct mp_symbol_entry {
+ halfword type;
+ mp_value v;
+ mp_string text;
+ void *parent;
+} mp_symbol_entry;
+
+@ @<Glob...@>=
+integer st_count; /* total number of known identifiers */
+avl_tree symbols; /* avl tree of symbolic tokens */
+avl_tree frozen_symbols; /* avl tree of frozen symbolic tokens */
+mp_sym frozen_bad_vardef;
+mp_sym frozen_colon;
+mp_sym frozen_end_def;
+mp_sym frozen_end_for;
+mp_sym frozen_end_group;
+mp_sym frozen_etex;
+mp_sym frozen_fi;
+mp_sym frozen_inaccessible;
+mp_sym frozen_left_bracket;
+mp_sym frozen_mpx_break;
+mp_sym frozen_repeat_loop;
+mp_sym frozen_right_delimiter;
+mp_sym frozen_semicolon;
+mp_sym frozen_slash;
+mp_sym frozen_undefined;
+mp_sym frozen_dump;
+
+
+@ Here are the functions needed for the avl construction.
+
+@<Declarations@>=
+static int comp_symbols_entry (void *p, const void *pa, const void *pb);
+static void *copy_symbols_entry (const void *p);
+static void *delete_symbols_entry (void *p);
+
+
+@ The avl comparison function is a straightword version of |strcmp|,
+except that checks for the string lengths first.
+
+@c
+static int comp_symbols_entry (void *p, const void *pa, const void *pb) {
+ const mp_symbol_entry *a = (const mp_symbol_entry *) pa;
+ const mp_symbol_entry *b = (const mp_symbol_entry *) pb;
+ (void) p;
+ if (a->text->len != b->text->len) {
+ return (a->text->len > b->text->len ? 1 : -1);
+ }
+ return strncmp ((const char *) a->text->str, (const char *) b->text->str,
+ a->text->len);
+}
+
+
+@ Copying a symbol happens when an item is inserted into an AVL tree.
+The |text| and |mp_number| needs to be deep copied, every thing else
+can be reassigned.
+
+@c
+static void *copy_symbols_entry (const void *p) {
+ MP mp;
+ mp_sym ff;
+ const mp_symbol_entry *fp;
+ fp = (const mp_symbol_entry *) p;
+ mp = (MP)fp->parent;
+ ff = malloc (sizeof (mp_symbol_entry));
+ if (ff == NULL)
+ return NULL;
+ ff->text = copy_strings_entry (fp->text);
+ if (ff->text == NULL)
+ return NULL;
+ ff->v = fp->v;
+ ff->type = fp->type;
+ ff->parent = mp;
+ new_number(ff->v.data.n);
+ number_clone(ff->v.data.n, fp->v.data.n);
+ return ff;
+}
+
+
+@ In the current implementation, symbols are not freed until the
+end of the run.
+
+@c
+static void *delete_symbols_entry (void *p) {
+ MP mp;
+ mp_sym ff = (mp_sym) p;
+ mp = (MP)ff->parent;
+ free_number(ff->v.data.n);
+ mp_xfree (ff->text->str);
+ mp_xfree (ff->text);
+ mp_xfree (ff);
+ return NULL;
+}
+
+
+@ @<Allocate or initialize ...@>=
+mp->symbols = avl_create (comp_symbols_entry,
+ copy_symbols_entry,
+ delete_symbols_entry, malloc, free, NULL);
+mp->frozen_symbols = avl_create (comp_symbols_entry,
+ copy_symbols_entry,
+ delete_symbols_entry, malloc, free, NULL);
+
+@ @<Dealloc variables@>=
+if (mp->symbols != NULL)
+ avl_destroy (mp->symbols);
+if (mp->frozen_symbols != NULL)
+ avl_destroy (mp->frozen_symbols);
+
+@ Actually creating symbols is done by |id_lookup|, but in order to
+do so it needs a way to create a new, empty symbol structure.
+
+@<Declarations@>=
+static mp_sym new_symbols_entry (MP mp, unsigned char *nam, size_t len);
+
+@ @c
+static mp_sym new_symbols_entry (MP mp, unsigned char *nam, size_t len) {
+ mp_sym ff;
+ ff = mp_xmalloc (mp, 1, sizeof (mp_symbol_entry));
+ memset (ff, 0, sizeof (mp_symbol_entry));
+ ff->parent = mp;
+ ff->text = mp_xmalloc (mp, 1, sizeof (mp_lstring));
+ ff->text->str = nam;
+ ff->text->len = len;
+ ff->type = mp_tag_token;
+ ff->v.type = mp_known;
+ new_number(ff->v.data.n);
+ FUNCTION_TRACE4 ("%p = new_symbols_entry(\"%s\",%d)\n", ff, nam, (int)len);
+ return ff;
+}
+
+
+@ There is one global variable so that |id_lookup| does not always have to
+create a new entry just for testing. This is not freed because it creates
+a double-free thanks to the |NULL| init.
+
+@<Global ...@>=
+mp_sym id_lookup_test;
+
+@ @<Initialize table entries@>=
+mp->id_lookup_test = new_symbols_entry (mp, NULL, 0);
+
+@ Certain symbols are ``frozen'' and not redefinable, since they are
+used
+in error recovery.
+
+@<Initialize table entries@>=
+mp->st_count = 0;
+mp->frozen_bad_vardef = mp_frozen_primitive (mp, "a bad variable", mp_tag_token, 0);
+mp->frozen_right_delimiter = mp_frozen_primitive (mp, ")", mp_right_delimiter, 0);
+mp->frozen_inaccessible = mp_frozen_primitive (mp, " INACCESSIBLE", mp_tag_token, 0);
+mp->frozen_undefined = mp_frozen_primitive (mp, " UNDEFINED", mp_tag_token, 0);
+
+@ Here is the subroutine that searches the avl tree 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 if
+|insert_new| is |true|, and the corresponding symbol will be returned.
+
+There are two variations on the lookup function: one for the normal
+symbol table, and one for the table of error recovery symbols.
+
+@d mp_id_lookup(A,B,C,D) mp_do_id_lookup ((A), mp->symbols, (B), (C), (D))
+
+@c
+static mp_sym mp_do_id_lookup (MP mp, avl_tree symbols, char *j,
+ size_t l, boolean insert_new) {
+ /* search an avl tree */
+ mp_sym str;
+ mp->id_lookup_test->text->str = (unsigned char *)j;
+ mp->id_lookup_test->text->len = l;
+ str = (mp_sym) avl_find (mp->id_lookup_test, symbols);
+ if (str == NULL && insert_new) {
+ unsigned char *nam = (unsigned char *) mp_xstrldup (mp, j, l);
+ mp_sym s = new_symbols_entry (mp, nam, l);
+ mp->st_count++;
+ assert (avl_ins (s, symbols, avl_false) > 0);
+ str = (mp_sym) avl_find (s, symbols);
+ delete_symbols_entry (s);
+ }
+ return str;
+}
+static mp_sym mp_frozen_id_lookup (MP mp, char *j, size_t l,
+ boolean insert_new) {
+ /* search the error recovery symbol table */
+ return mp_do_id_lookup (mp, mp->frozen_symbols, j, l, insert_new);
+}
+
+/* see mp\_print\_sym (mp\_sym sym) */
+@ Get a numeric value from \MP\ is not easy. We have to consider
+the macro and the loops, as also the internal type (this is a
+first attempt, and more work is needed). If we are inside
+a \&{for} loop, then the global |loop_ptr| is not null and the other loops
+eventually nested are available by mean of |loop_ptr->link|.
+The current numeric value is stored in |old_value|.
+
+@c
+double mp_get_numeric_value (MP mp, const char *s, size_t l) {
+ char *ss = mp_xstrdup(mp,s);
+ if (ss) {
+ mp_sym sym = mp_id_lookup(mp,ss,l,false);
+ if (sym != NULL) {
+ if (mp->loop_ptr != NULL) {
+ mp_loop_data *s;
+ s = mp->loop_ptr;
+ while (s != NULL && sym != s->var)
+ s = s->link;
+ if (s != NULL && sym == s->var ){
+ mp_xfree (ss);
+ return number_to_double(s->old_value) ;
+ }
+ }
+ if (mp_type(sym) == mp_internal_quantity) {
+ halfword qq = equiv(sym);
+ mp_xfree (ss);
+ if (internal_type (qq) != mp_string_type)
+ return number_to_double(internal_value(qq));
+ else
+ return 0;
+ }
+ if (sym->v.data.node != NULL && mp_type(sym->v.data.node) == mp_known) {
+ mp_xfree (ss);
+ return number_to_double(sym->v.data.node->data.n) ;
+ }
+ }
+ }
+ mp_xfree (ss);
+ return 0 ;
+}
+
+int mp_get_boolean_value (MP mp, const char *s, size_t l) {
+ char *ss = mp_xstrdup(mp,s);
+ if (ss) {
+ mp_sym sym = mp_id_lookup(mp,ss,l,false);
+ if (sym != NULL) {
+ if (mp_type(sym->v.data.node) == mp_boolean_type) {
+ if (number_to_boolean (sym->v.data.node->data.n) == mp_true_code) {
+ mp_xfree(ss);
+ return 1 ;
+ }
+ }
+ }
+ }
+ mp_xfree (ss);
+ return 0;
+}
+
+char *mp_get_string_value (MP mp, const char *s, size_t l) {
+ char *ss = mp_xstrdup(mp,s);
+ if (ss) {
+ mp_sym sym = mp_id_lookup(mp,ss,l,false);
+ if (sym != NULL) {
+ if (mp_type(sym->v.data.node) == mp_string_type) {
+ mp_xfree (ss);
+ return (char *) sym->v.data.node->data.str->str;
+ }
+ }
+ }
+ mp_xfree (ss);
+ return NULL;
+}
+
+mp_knot mp_get_path_value (MP mp, const char *s, size_t l) {
+ char *ss = mp_xstrdup(mp,s);
+ if (ss) {
+ mp_sym sym = mp_id_lookup(mp,ss,l,false);
+ if (sym != NULL && sym->v.data.node != NULL) {
+ if (mp_type(sym->v.data.node) == mp_path_type) {
+ mp_xfree (ss);
+ return (mp_knot) sym->v.data.node->data.p;
+ }
+ }
+ }
+ mp_xfree (ss);
+ return NULL;
+}
+
+@ @<Exported function headers@>=
+double mp_get_numeric_value(MP mp,const char *s,size_t l);
+int mp_get_boolean_value(MP mp,const char *s,size_t l);
+char *mp_get_string_value(MP mp,const char *s,size_t l);
+mp_knot mp_get_path_value(MP mp,const char *s,size_t l);
+
+@ We need to put \MP's ``primitive'' symbolic tokens into the hash
+table, together with their command code (which will be the |eq_type|)
+and an operand (which will be the |equiv|). The |primitive| procedure
+does this, in a way that no \MP\ user can. The global value |cur_sym|
+contains the new |eqtb| pointer after |primitive| has acted.
+
+@c
+static void mp_primitive (MP mp, const char *ss, halfword c, halfword o) {
+ char *s = mp_xstrdup (mp, ss);
+ set_cur_sym (mp_id_lookup (mp, s, strlen (s), true));
+ mp_xfree (s);
+ set_eq_type (cur_sym(), c);
+ set_equiv (cur_sym(), o);
+}
+
+
+@ Some other symbolic tokens only exist for error recovery.
+
+@c
+static mp_sym mp_frozen_primitive (MP mp, const char *ss, halfword c,
+ halfword o) {
+ char *s = mp_xstrdup (mp, ss);
+ mp_sym str = mp_frozen_id_lookup (mp, s, strlen (ss), true);
+ mp_xfree (s);
+ str->type = c;
+ str->v.data.indep.serial = o;
+ return str;
+}
+
+
+@ This routine returns |true| if the argument is an un-redefinable symbol
+because it is one of the error recovery tokens (as explained elsewhere,
+|frozen_inaccessible| actuall is redefinable).
+
+@c
+static boolean mp_is_frozen (MP mp, mp_sym sym) {
+ mp_sym temp = mp_frozen_id_lookup (mp, (char *) sym->text->str, sym->text->len, false);
+ if (temp==mp->frozen_inaccessible)
+ return false;
+ return (temp == sym);
+}
+
+
+@ Many of \MP's primitives need no |equiv|, since they are identifiable
+by their |eq_type| alone. These primitives are loaded into the hash table
+as follows:
+
+@<Put each of \MP's primitives into the hash table@>=
+mp_primitive (mp, "..", mp_path_join, 0);
+@:.._}{\.{..} primitive@>;
+mp_primitive (mp, "[", mp_left_bracket, 0);
+mp->frozen_left_bracket = mp_frozen_primitive (mp, "[", mp_left_bracket, 0);
+@:[ }{\.{[} primitive@>;
+mp_primitive (mp, "]", mp_right_bracket, 0);
+@:] }{\.{]} primitive@>;
+mp_primitive (mp, "}", mp_right_brace, 0);
+@:]]}{\.{\char`\}} primitive@>;
+mp_primitive (mp, "{", mp_left_brace, 0);
+@:][}{\.{\char`\{} primitive@>;
+mp_primitive (mp, ":", mp_colon, 0);
+mp->frozen_colon = mp_frozen_primitive (mp, ":", mp_colon, 0);
+@:: }{\.{:} primitive@>;
+mp_primitive (mp, "::", mp_double_colon, 0);
+@::: }{\.{::} primitive@>;
+mp_primitive (mp, "||:", mp_bchar_label, 0);
+@:::: }{\.{\char'174\char'174:} primitive@>;
+mp_primitive (mp, ":=", mp_assignment, 0);
+@::=_}{\.{:=} primitive@>;
+mp_primitive (mp, ",", mp_comma, 0);
+@:, }{\., primitive@>;
+mp_primitive (mp, ";", mp_semicolon, 0);
+mp->frozen_semicolon = mp_frozen_primitive (mp, ";", mp_semicolon, 0);
+@:; }{\.; primitive@>;
+mp_primitive (mp, "\\", mp_relax, 0);
+@:]]\\}{\.{\char`\\} primitive@>;
+mp_primitive (mp, "addto", mp_add_to_command, 0);
+@:add_to_}{\&{addto} primitive@>;
+mp_primitive (mp, "atleast", mp_at_least, 0);
+@:at_least_}{\&{atleast} primitive@>;
+mp_primitive (mp, "begingroup", mp_begin_group, 0);
+mp->bg_loc = cur_sym();
+@:begin_group_}{\&{begingroup} primitive@>;
+mp_primitive (mp, "controls", mp_controls, 0);
+@:controls_}{\&{controls} primitive@>;
+mp_primitive (mp, "curl", mp_curl_command, 0);
+@:curl_}{\&{curl} primitive@>;
+mp_primitive (mp, "delimiters", mp_delimiters, 0);
+@:delimiters_}{\&{delimiters} primitive@>;
+mp_primitive (mp, "endgroup", mp_end_group, 0);
+mp->eg_loc = cur_sym();
+mp->frozen_end_group = mp_frozen_primitive (mp, "endgroup", mp_end_group, 0);
+@:endgroup_}{\&{endgroup} primitive@>;
+mp_primitive (mp, "everyjob", mp_every_job_command, 0);
+@:every_job_}{\&{everyjob} primitive@>;
+mp_primitive (mp, "exitif", mp_exit_test, 0);
+@:exit_if_}{\&{exitif} primitive@>;
+mp_primitive (mp, "expandafter", mp_expand_after, 0);
+@:expand_after_}{\&{expandafter} primitive@>;
+mp_primitive (mp, "interim", mp_interim_command, 0);
+@:interim_}{\&{interim} primitive@>;
+mp_primitive (mp, "let", mp_let_command, 0);
+@:let_}{\&{let} primitive@>;
+mp_primitive (mp, "newinternal", mp_new_internal, 0);
+@:new_internal_}{\&{newinternal} primitive@>;
+mp_primitive (mp, "of", mp_of_token, 0);
+@:of_}{\&{of} primitive@>;
+mp_primitive (mp, "randomseed", mp_random_seed, 0);
+@:mp_random_seed_}{\&{randomseed} primitive@>;
+mp_primitive (mp, "save", mp_save_command, 0);
+@:save_}{\&{save} primitive@>;
+mp_primitive (mp, "scantokens", mp_scan_tokens, 0);
+@:scan_tokens_}{\&{scantokens} primitive@>;
+
+mp_primitive (mp, "runscript", mp_runscript, 0);
+@:run_script_}{\&{runscript} primitive@>;
+mp_primitive (mp, "maketext", mp_maketext, 0);
+@:make_text_}{\&{maketext} primitive@>;
+
+mp_primitive (mp, "shipout", mp_ship_out_command, 0);
+@:ship_out_}{\&{shipout} primitive@>;
+mp_primitive (mp, "skipto", mp_skip_to, 0);
+@:skip_to_}{\&{skipto} primitive@>;
+mp_primitive (mp, "special", mp_special_command, 0);
+@:special}{\&{special} primitive@>;
+mp_primitive (mp, "fontmapfile", mp_special_command, 1);
+@:fontmapfile}{\&{fontmapfile} primitive@>;
+mp_primitive (mp, "fontmapline", mp_special_command, 2);
+@:fontmapline}{\&{fontmapline} primitive@>;
+mp_primitive (mp, "step", mp_step_token, 0);
+@:step_}{\&{step} primitive@>;
+mp_primitive (mp, "str", mp_str_op, 0);
+@:str_}{\&{str} primitive@>;
+mp_primitive (mp, "void", mp_void_op, 0);
+@:void_}{\&{void} primitive@>;
+mp_primitive (mp, "tension", mp_tension, 0);
+@:tension_}{\&{tension} primitive@>;
+mp_primitive (mp, "to", mp_to_token, 0);
+@:to_}{\&{to} primitive@>;
+mp_primitive (mp, "until", mp_until_token, 0);
+@:until_}{\&{until} primitive@>;
+mp_primitive (mp, "within", mp_within_token, 0);
+@:within_}{\&{within} primitive@>;
+mp_primitive (mp, "write", mp_write_command, 0);
+@:write_}{\&{write} primitive@>
+
+
+@ Each primitive has a corresponding inverse, so that it is possible to
+display the cryptic numeric contents of |eqtb| in symbolic form.
+Every call of |primitive| in this program is therefore accompanied by some
+straightforward code that forms part of the |print_cmd_mod| routine
+explained below.
+
+@<Cases of |print_cmd_mod| for symbolic printing of primitives@>=
+case mp_add_to_command:
+mp_print (mp, "addto");
+break;
+case mp_assignment:
+mp_print (mp, ":=");
+break;
+case mp_at_least:
+mp_print (mp, "atleast");
+break;
+case mp_bchar_label:
+mp_print (mp, "||:");
+break;
+case mp_begin_group:
+mp_print (mp, "begingroup");
+break;
+case mp_colon:
+mp_print (mp, ":");
+break;
+case mp_comma:
+mp_print (mp, ",");
+break;
+case mp_controls:
+mp_print (mp, "controls");
+break;
+case mp_curl_command:
+mp_print (mp, "curl");
+break;
+case mp_delimiters:
+mp_print (mp, "delimiters");
+break;
+case mp_double_colon:
+mp_print (mp, "::");
+break;
+case mp_end_group:
+mp_print (mp, "endgroup");
+break;
+case mp_every_job_command:
+mp_print (mp, "everyjob");
+break;
+case mp_exit_test:
+mp_print (mp, "exitif");
+break;
+case mp_expand_after:
+mp_print (mp, "expandafter");
+break;
+case mp_interim_command:
+mp_print (mp, "interim");
+break;
+case mp_left_brace:
+mp_print (mp, "{");
+break;
+case mp_left_bracket:
+mp_print (mp, "[");
+break;
+case mp_let_command:
+mp_print (mp, "let");
+break;
+case mp_new_internal:
+mp_print (mp, "newinternal");
+break;
+case mp_of_token:
+mp_print (mp, "of");
+break;
+case mp_path_join:
+mp_print (mp, "..");
+break;
+case mp_random_seed:
+mp_print (mp, "randomseed");
+break;
+case mp_relax:
+mp_print_char (mp, xord ('\\'));
+break;
+case mp_right_brace:
+mp_print_char (mp, xord ('}'));
+break;
+case mp_right_bracket:
+mp_print_char (mp, xord (']'));
+break;
+case mp_save_command:
+mp_print (mp, "save");
+break;
+case mp_scan_tokens:
+mp_print (mp, "scantokens");
+break;
+case mp_runscript:
+mp_print (mp, "runscript");
+break;
+case mp_maketext:
+mp_print (mp, "maketext");
+break;
+case mp_semicolon:
+mp_print_char (mp, xord (';'));
+break;
+case mp_ship_out_command:
+mp_print (mp, "shipout");
+break;
+case mp_skip_to:
+mp_print (mp, "skipto");
+break;
+case mp_special_command:
+if (m == 2)
+ mp_print (mp, "fontmapline");
+else if (m == 1)
+ mp_print (mp, "fontmapfile");
+else
+ mp_print (mp, "special");
+break;
+case mp_step_token:
+mp_print (mp, "step");
+break;
+case mp_str_op:
+mp_print (mp, "str");
+break;
+case mp_void_op:
+mp_print (mp, "void");
+break;
+case mp_tension:
+mp_print (mp, "tension");
+break;
+case mp_to_token:
+mp_print (mp, "to");
+break;
+case mp_until_token:
+mp_print (mp, "until");
+break;
+case mp_within_token:
+mp_print (mp, "within");
+break;
+case mp_write_command:
+mp_print (mp, "write");
+break;
+
+@ We will deal with the other primitives later, at some point in the program
+where their |eq_type| and |equiv| values are more meaningful. For example,
+the primitives for macro definitions will be loaded when we consider the
+routines that define macros. It is easy to find where each particular
+primitive was treated by looking in the index at the end; for example, the
+section where |"def"| entered |eqtb| is listed under `\&{def} primitive'.
+
+@* Token lists.
+
+A \MP\ token is either symbolic or numeric or a string, or it denotes a macro
+parameter or capsule or an internal; so there are six corresponding ways to
+encode it internally:
+@^token@>
+
+(1)~A symbolic token for symbol |p| is represented by the pointer |p|,
+in the |sym_sym| field of a symbolic node in~|mem|. The |type| field is |symbol_node|;
+and it has a |name_type| to differentiate various subtypes of symbolic tokens,
+which is usually |normal_sym|, but |macro_sym| for macro names.
+
+(2)~A numeric token whose |scaled| value is~|v| is
+represented in a non-symbolic node of~|mem|; the |type| field is |known|,
+the |name_type| field is |token|, and the |value| field holds~|v|.
+
+(3)~A string token is also represented in a non-symbolic node; the |type|
+field is |mp_string_type|, the |name_type| field is |token|, and the
+|value| field holds the corresponding |mp_string|.
+
+(4)~Capsules have |name_type=capsule|, and their |type| and |value| fields
+represent arbitrary values, with |type| different from |symbol_node|
+(in ways to be explained later).
+
+(5)~Macro parameters appear in |sym_info| fields of symbolic nodes. The |type|
+field is |symbol_node|; the $k$th parameter is represented by |k| in |sym_info|;
+and |expr_sym| in |name_type|, if it is of type \&{expr}, or |suffix_sym| if it
+is of type \&{suffix}, or by |text_sym| if it is of type \&{text}.
+
+(6)~The $k$th internal is also represented by |k| in |sym_info|; the |type| field is
+|symbol_node| as for the other symbolic tokens; and |internal_sym| is its |name_type|;
+
+Actual values of the parameters and internals are kept in a separate
+stack, as we will see later.
+
+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 token_node_size sizeof(mp_node_data) /* the number of words in a large token node */
+
+@d set_value_sym(A,B) do_set_value_sym(mp, (mp_token_node)(A), (B))
+@d set_value_number(A,B) do_set_value_number(mp, (mp_token_node)(A), (B))
+@d set_value_node(A,B) do_set_value_node(mp, (mp_token_node)(A), (B))
+@d set_value_str(A,B) do_set_value_str(mp, (mp_token_node)(A), (B))
+@d set_value_knot(A,B) do_set_value_knot(mp, (mp_token_node)A, (B))
+
+@d value_sym_NEW(A) (mp_sym)mp_link(A)
+@d set_value_sym_NEW(A,B) set_mp_link(A,(mp_node)B)
+
+@<MPlib internal header stuff@>=
+typedef struct mp_node_data *mp_token_node;
+
+@ @c
+#if DEBUG
+#define value_sym(A) do_get_value_sym(mp,(mp_token_node)(A))
+/* |#define value_number(A) do_get_value_number(mp,(mp_token_node)(A))| */
+#define value_number(A) ((mp_token_node)(A))->data.n
+#define value_node(A) do_get_value_node(mp,(mp_token_node)(A))
+#define value_str(A) do_get_value_str(mp,(mp_token_node)(A))
+#define value_knot(A) do_get_value_knot(mp,(mp_token_node)(A))
+#else
+#define value_sym(A) ((mp_token_node)(A))->data.sym
+#define value_number(A) ((mp_token_node)(A))->data.n
+#define value_node(A) ((mp_token_node)(A))->data.node
+#define value_str(A) ((mp_token_node)(A))->data.str
+#define value_knot(A) ((mp_token_node)(A))->data.p
+#endif
+static void do_set_value_sym(MP mp, mp_token_node A, mp_sym B) {
+ FUNCTION_TRACE3 ("set_value_sym(%p,%p)\n", (A),(B));
+ A->data.sym=(B);
+}
+static void do_set_value_number(MP mp, mp_token_node A, mp_number B) {
+ FUNCTION_TRACE3 ("set_value(%p,%s)\n", (A), number_tostring(B));
+ A->data.p = NULL;
+ A->data.str = NULL;
+ A->data.node = NULL;
+ number_clone (A->data.n, B);
+}
+static void do_set_value_str(MP mp, mp_token_node A, mp_string B) {
+ FUNCTION_TRACE3 ("set_value_str(%p,%p)\n", (A),(B));
+ assert (A->type != mp_structured);
+ A->data.p = NULL;
+ A->data.str = (B);
+ add_str_ref((B));
+ A->data.node = NULL;
+ number_clone (A->data.n, zero_t);
+}
+static void do_set_value_node(MP mp, mp_token_node A, mp_node B) {
+ /* store the value in a large token node */
+ FUNCTION_TRACE3 ("set_value_node(%p,%p)\n", A,B);
+ assert (A->type != mp_structured);
+ A->data.p = NULL;
+ A->data.str = NULL;
+ A->data.node = B;
+ number_clone (A->data.n, zero_t);
+}
+static void do_set_value_knot(MP mp, mp_token_node A, mp_knot B) {
+ FUNCTION_TRACE3 ("set_value_knot(%p,%p)\n", (A),(B));
+ assert (A->type != mp_structured);
+ A->data.p = (B);
+ A->data.str = NULL;
+ A->data.node = NULL;
+ number_clone (A->data.n, zero_t);
+}
+
+
+@ @c
+#if DEBUG
+static mp_sym do_get_value_sym (MP mp, mp_token_node A) {
+ /* |A->type| can be structured in this case */
+ FUNCTION_TRACE3 ("%p = get_value_sym(%p)\n", A->data.sym, A);
+ return A->data.sym ;
+}
+static mp_node do_get_value_node (MP mp, mp_token_node A) {
+ assert (A->type != mp_structured);
+ FUNCTION_TRACE3 ("%p = get_value_node(%p)\n", A->data.node, A);
+ return A->data.node ;
+}
+static mp_string do_get_value_str (MP mp, mp_token_node A) {
+ assert (A->type != mp_structured);
+ FUNCTION_TRACE3 ("%p = get_value_str(%p)\n", A->data.str, A);
+ return A->data.str ;
+}
+static mp_knot do_get_value_knot (MP mp, mp_token_node A) {
+ assert (A->type != mp_structured);
+ FUNCTION_TRACE3 ("%p = get_value_knot(%p)\n", A->data.p, A);
+ return A->data.p ;
+}
+static mp_number do_get_value_number (MP mp, mp_token_node A) {
+ assert (A->type != mp_structured);
+ FUNCTION_TRACE3 ("%d = get_value_number(%p)\n", A->data.n.type, A);
+ return A->data.n ;
+}
+#endif
+
+@ @<Declarations@>=
+#if DEBUG
+static mp_number do_get_value_number (MP mp, mp_token_node A);
+static mp_sym do_get_value_sym (MP mp, mp_token_node A);
+static mp_node do_get_value_node (MP mp, mp_token_node A);
+static mp_string do_get_value_str (MP mp, mp_token_node A) ;
+static mp_knot do_get_value_knot (MP mp, mp_token_node A) ;
+#endif
+static void do_set_value_sym (MP mp, mp_token_node A, mp_sym B);
+static void do_set_value_number (MP mp, mp_token_node A, mp_number B);
+static void do_set_value_node (MP mp, mp_token_node A, mp_node B);
+static void do_set_value_str (MP mp, mp_token_node A, mp_string B);
+static void do_set_value_knot (MP mp, mp_token_node A, mp_knot B);
+
+@
+@c
+static mp_node mp_get_token_node (MP mp) {
+ mp_node p;
+ if (mp->token_nodes) {
+ p = mp->token_nodes;
+ mp->token_nodes = p->link;
+ mp->num_token_nodes--;
+ p->link = NULL;
+ } else {
+ p = malloc_node (token_node_size);
+ new_number(p->data.n);
+ p->has_number = 1;
+ }
+ p->type = mp_token_node_type;
+ FUNCTION_TRACE2 ("%p = mp_get_token_node()\n", p);
+ return (mp_node) p;
+}
+
+@ @c
+static void mp_free_token_node (MP mp, mp_node p) {
+ FUNCTION_TRACE2 ("mp_free_token_node(%p)\n", p);
+ if (!p) return;
+ if (mp->num_token_nodes < max_num_token_nodes) {
+ p->link = mp->token_nodes;
+ mp->token_nodes = p;
+ mp->num_token_nodes++;
+ return;
+ }
+ mp->var_used -= token_node_size;
+ if (mp->math_mode > mp_math_double_mode) {
+ free_number(((mp_value_node)p)->data.n);
+ }
+ xfree (p);
+}
+
+@ @<Declarations@>=
+static void mp_free_token_node (MP mp, mp_node p);
+
+@ A numeric token is created by the following trivial routine.
+
+@c
+static mp_node mp_new_num_tok (MP mp, mp_number v) {
+ mp_node p; /* the new node */
+ p = mp_get_token_node (mp);
+ set_value_number (p, v);
+ p->type = mp_known;
+ p->name_type = mp_token;
+ FUNCTION_TRACE3 ("%p = mp_new_num_tok(%p)\n", p, v);
+ return p;
+}
+
+
+@ A token list is a singly linked list of nodes in |mem|, where
+each node contains a token and a link. Here's a subroutine that gets rid
+of a token list when it is no longer needed.
+
+@c
+static void mp_flush_token_list (MP mp, mp_node p) {
+ mp_node q; /* the node being recycled */
+ FUNCTION_TRACE2 ("mp_flush_token_list(%p)\n", p);
+ while (p != NULL) {
+ q = p;
+ p = mp_link (p);
+ if (mp_type (q) == mp_symbol_node) {
+ mp_free_symbolic_node (mp, q);
+ } else {
+ switch (mp_type (q)) {
+ case mp_vacuous:
+ case mp_boolean_type:
+ case mp_known:
+ break;
+ case mp_string_type:
+ delete_str_ref (value_str (q));
+ break;
+ case unknown_types:
+ case mp_pen_type:
+ case mp_path_type:
+ case mp_picture_type:
+ case mp_pair_type:
+ case mp_color_type:
+ case mp_cmykcolor_type:
+ case mp_transform_type:
+ case mp_dependent:
+ case mp_proto_dependent:
+ case mp_independent:
+ mp_recycle_value (mp, q);
+ break;
+ default:
+ mp_confusion (mp, "token");
+@:this can't happen token}{\quad token@>;
+ }
+ mp_free_token_node (mp, q);
+ }
+ }
+}
+
+
+@ 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.
+
+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}'.
+
+@<Declarations@>=
+static void mp_show_token_list (MP mp, mp_node p, mp_node q, integer l,
+ integer null_tally);
+
+@ @c
+void mp_show_token_list (MP mp, mp_node p, mp_node q, integer l,
+ integer null_tally) {
+ quarterword cclass, c; /* the |char_class| of previous and new tokens */
+ cclass = percent_class;
+ mp->tally = null_tally;
+ while ((p != NULL) && (mp->tally < l)) {
+ if (p == q) {
+ set_trick_count();
+ }
+ /* Display token |p| and set |c| to its class; but |return| if there are problems */
+ c = letter_class; /* the default */
+ if (mp_type (p) != mp_symbol_node) {
+ /* Display non-symbolic token */
+ if (mp_name_type (p) == mp_token) {
+ if (mp_type (p) == mp_known) {
+ /* Display a numeric token */
+ if (cclass == digit_class)
+ mp_print_char (mp, xord (' '));
+ if (number_negative (value_number (p))) {
+ if (cclass == mp_left_bracket_class)
+ mp_print_char (mp, xord (' '));
+ mp_print_char (mp, xord ('['));
+ print_number (value_number (p));
+ mp_print_char (mp, xord (']'));
+ c = mp_right_bracket_class;
+ } else {
+ print_number (value_number (p));
+ c = digit_class;
+ }
+
+ } else if (mp_type (p) != mp_string_type) {
+ mp_print (mp, " BAD");
+ } else {
+ mp_print_char (mp, xord ('"'));
+ mp_print_str (mp, value_str (p));
+ mp_print_char (mp, xord ('"'));
+ c = string_class;
+ }
+ } else if ((mp_name_type (p) != mp_capsule) || (mp_type (p) < mp_vacuous)
+ || (mp_type (p) > mp_independent)) {
+ mp_print (mp, " BAD");
+ } else {
+ mp_print_capsule (mp, p);
+ c = right_paren_class;
+ }
+
+ } else {
+ if (mp_name_type (p) == mp_expr_sym ||
+ mp_name_type (p) == mp_suffix_sym || mp_name_type (p) == mp_text_sym) {
+ integer r; /* temporary register */
+ r = mp_sym_info (p);
+ if (mp_name_type (p) == mp_expr_sym) {
+ mp_print (mp, "(EXPR");
+ } else if (mp_name_type (p) == mp_suffix_sym) {
+ mp_print (mp, "(SUFFIX");
+ } else {
+ mp_print (mp, "(TEXT");
+ }
+ mp_print_int (mp, r);
+ mp_print_char (mp, xord (')'));
+ c = right_paren_class;
+ } else {
+ mp_sym sr = mp_sym_sym (p);
+ if (sr == collective_subscript) {
+ /* Display a collective subscript */
+ if (cclass == mp_left_bracket_class)
+ mp_print_char (mp, xord (' '));
+ mp_print (mp, "[]");
+ c = mp_right_bracket_class;
+
+ } else {
+ mp_string rr = text (sr);
+ if (rr == NULL || rr->str == NULL) {
+ mp_print (mp, " NONEXISTENT");
+ } else {
+ /* Print string |r| as a symbolic token and set |c| to its class */
+ c = (quarterword) mp->char_class[(rr->str[0])];
+ if (c == cclass) {
+ switch (c) {
+ case letter_class:
+ mp_print_char (mp, xord ('.'));
+ break;
+ case isolated_classes:
+ break;
+ default:
+ mp_print_char (mp, xord (' '));
+ break;
+ }
+ }
+ mp_print_str (mp, rr);
+
+ }
+ }
+ }
+ }
+
+ cclass = c;
+ p = mp_link (p);
+ }
+ if (p != NULL)
+ mp_print (mp, " ETC.");
+ return;
+}
+
+
+@ @<Declarations@>=
+static void mp_print_capsule (MP mp, mp_node p);
+
+@ @<Declare miscellaneous procedures that were declared |forward|@>=
+void mp_print_capsule (MP mp, mp_node p) {
+ mp_print_char (mp, xord ('('));
+ mp_print_exp (mp, p, 0);
+ mp_print_char (mp, xord (')'));
+}
+
+
+@ Macro definitions are kept in \MP's memory in the form of token lists
+that have a few extra symbolic 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 |sym_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.
+
+/* reference count preceding a macro definition or picture header */
+@d ref_count(A) indep_value(A)
+@d set_ref_count(A,B) set_indep_value(A,B)
+@d add_mac_ref(A) set_ref_count((A),ref_count((A))+1) /* make a new reference to a macro list */
+@d decr_mac_ref(A) set_ref_count((A),ref_count((A))-1) /* remove a reference to a macro list */
+
+@<Types...@>=
+typedef enum {
+ mp_general_macro, /* preface to a macro defined with a parameter list */
+ mp_primary_macro, /* preface to a macro with a \&{primary} parameter */
+ mp_secondary_macro, /* preface to a macro with a \&{secondary} parameter */
+ mp_tertiary_macro, /* preface to a macro with a \&{tertiary} parameter */
+ mp_expr_macro, /* preface to a macro with an undelimited \&{expr} parameter */
+ mp_of_macro, /* preface to a macro with undelimited `\&{expr} |x| \&{of}~|y|' parameters */
+ mp_suffix_macro, /* preface to a macro with an undelimited \&{suffix} parameter */
+ mp_text_macro, /* preface to a macro with an undelimited \&{text} parameter */
+ mp_expr_param, /* used by \.{expr} primitive */
+ mp_suffix_param, /* used by \.{suffix} primitive */
+ mp_text_param /* used by \.{text} primitive */
+} mp_macro_info;
+
+@ @c
+static void mp_delete_mac_ref (MP mp, mp_node p) {
+ /* |p| points to the reference count of a macro list that is
+ losing one reference */
+ if (ref_count (p) == 0)
+ mp_flush_token_list (mp, p);
+ else
+ decr_mac_ref (p);
+}
+
+
+@ The following subroutine displays a macro, given a pointer to its
+reference count.
+
+@c
+static void mp_show_macro (MP mp, mp_node p, mp_node q, integer l) {
+ mp_node r; /* temporary storage */
+ p = mp_link (p); /* bypass the reference count */
+ while (mp_name_type (p) != mp_macro_sym) {
+ r = mp_link (p);
+ mp_link (p) = NULL;
+ mp_show_token_list (mp, p, NULL, l, 0);
+ mp_link (p) = r;
+ p = r;
+ if (l > 0)
+ l = l - mp->tally;
+ else
+ return;
+ } /* control printing of `\.{ETC.}' */
+@.ETC@>;
+ mp->tally = 0;
+ switch (mp_sym_info (p)) {
+ case mp_general_macro:
+ mp_print (mp, "->");
+ break;
+@.->@>
+ case mp_primary_macro:
+ case mp_secondary_macro:
+ case mp_tertiary_macro:
+ mp_print_char (mp, xord ('<'));
+ mp_print_cmd_mod (mp, mp_param_type, mp_sym_info (p));
+ mp_print (mp, ">->");
+ break;
+ case mp_expr_macro:
+ mp_print (mp, "<expr>->");
+ break;
+ case mp_of_macro:
+ mp_print (mp, "<expr>of<primary>->");
+ break;
+ case mp_suffix_macro:
+ mp_print (mp, "<suffix>->");
+ break;
+ case mp_text_macro:
+ mp_print (mp, "<text>->");
+ break;
+ } /* there are no other cases */
+ mp_show_token_list (mp, mp_link (p), q, l - mp->tally, 0);
+}
+
+
+@* 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 non-symbolic
+node called a value node, or as a non-symbolic subfield of a larger node. One
+of those two words is called the |value| field; it is an integer,
+containing either a |scaled| numeric value or the representation of some
+other type of quantity. (It might also be subdivided into halfwords, in
+which case it is referred to by other names instead of |value|.) The other
+word is broken into subfields called |type|, |name_type|, and |link|. The
+|type| field is a quarterword that specifies the variable's type, and
+|name_type| is a quarterword from which \MP\ can reconstruct the
+variable's name (sometimes by using the |link| field as well). Thus, only
+1.25 words are actually devoted to the value itself; the other
+three-quarters of a word are overhead, but they aren't wasted because they
+allow \MP\ to deal with sparse arrays and to provide meaningful diagnostics.
+
+In this section we shall be concerned only with the structural aspects of
+variables, not their values. Later parts of the program will change the
+|type| and |value| fields, but we shall treat those fields as black boxes
+whose contents should not be touched.
+
+However, if the |type| field is |mp_structured|, there is no |value| field,
+and the second word is broken into two pointer fields called |attr_head|
+and |subscr_head|. Those fields point to additional nodes that
+contain structural information, as we shall see.
+
+TH Note: DEK and JDH had a nice theoretical split between |value|,
+|attr| and |subscr| nodes, as documented above and further
+below. However, all three types had a bad habit of transmuting into
+each other in practice while pointers to them still lived on
+elsewhere, so using three different C structures is simply not
+workable. All three are now represented as a single C structure called
+|mp_value_node|.
+
+There is a potential union in this structure in the interest of space
+saving: |subscript_| and |hashloc_| are mutually exclusive.
+
+Actually, so are |attr_head_| + |subscr_head_| on one side and and
+|value_| on the other, but because of all the access macros that are
+used in the code base to get at values, those cannot be folded into a
+union (yet); this would have required creating a similar union in
+|mp_token_node| where it would only serve to confuse things.
+
+Finally, |parent_| only applies in |attr| nodes (the ones that have
+|hashloc_|), but creating an extra substructure inside the union just
+for that does not save space and the extra complication in the
+structure is not worth the minimal extra code clarification.
+
+@d attr_head(A) do_get_attr_head(mp,(mp_value_node)(A))
+@d set_attr_head(A,B) do_set_attr_head(mp,(mp_value_node)(A),(mp_node)(B))
+
+@d subscr_head(A) do_get_subscr_head(mp,(mp_value_node)(A))
+@d set_subscr_head(A,B) do_set_subscr_head(mp,(mp_value_node)(A),(mp_node)(B))
+
+@<MPlib internal header stuff@>=
+typedef struct mp_value_node_data {
+ NODE_BODY;
+ mp_value_data data;
+ mp_number subscript_;
+ mp_sym hashloc_;
+ mp_node parent_;
+ mp_node attr_head_;
+ mp_node subscr_head_;
+} mp_value_node_data;
+
+@ @c
+static mp_node do_get_attr_head (MP mp, mp_value_node A) {
+ assert (A->type == mp_structured);
+ FUNCTION_TRACE3 ("%p = get_attr_head(%p)\n", A->attr_head_, A);
+ return A->attr_head_;
+}
+static mp_node do_get_subscr_head (MP mp, mp_value_node A) {
+ assert (A->type == mp_structured);
+ FUNCTION_TRACE3 ("%p = get_subscr_head(%p)\n", A->subscr_head_, A);
+ return A->subscr_head_;
+}
+static void do_set_attr_head (MP mp, mp_value_node A, mp_node d) {
+ FUNCTION_TRACE4 ("set_attr_head(%p,%p) on line %d\n", (A), d, __LINE__);
+ assert (A->type == mp_structured);
+ A->attr_head_ = d;
+}
+static void do_set_subscr_head (MP mp, mp_value_node A, mp_node d) {
+ FUNCTION_TRACE4 ("set_subscr_head(%p,%p) on line %d\n", (A), d, __LINE__);
+ assert (A->type == mp_structured);
+ A->subscr_head_ = d;
+}
+
+@ @<Declarations@>=
+static mp_node do_get_subscr_head (MP mp, mp_value_node A);
+static mp_node do_get_attr_head (MP mp, mp_value_node A);
+static void do_set_attr_head (MP mp, mp_value_node A, mp_node d);
+static void do_set_subscr_head (MP mp, mp_value_node A, mp_node d);
+
+@ It would have been nicer to make |mp_get_value_node| return
+|mp_value_node| variables, but with |eqtb| as it stands that
+became messy: lots of typecasts. So, it returns a simple
+|mp_node| for now.
+
+@d value_node_size sizeof(struct mp_value_node_data)
+
+@c
+static mp_node mp_get_value_node (MP mp) {
+ mp_value_node p;
+ if (mp->value_nodes) {
+ p = (mp_value_node)mp->value_nodes;
+ mp->value_nodes = p->link;
+ mp->num_value_nodes--;
+ p->link = NULL;
+ } else {
+ p = malloc_node (value_node_size);
+ new_number(p->data.n);
+ new_number(p->subscript_);
+ p->has_number = 2;
+ }
+ mp_type (p) = mp_value_node_type;
+ FUNCTION_TRACE2 ("%p = mp_get_value_node()\n", p);
+ return (mp_node)p;
+}
+#if DEBUG > 1
+static void debug_dump_value_node (mp_node x) {
+ mp_value_node qq = (mp_value_node)x;
+ fprintf (stdout, "\nnode %p:\n", qq);
+ fprintf (stdout, " type=%s\n", mp_type_string(qq->type));
+ fprintf (stdout, " name_type=%d\n", qq->name_type);
+ fprintf (stdout, " link=%p\n", qq->link);
+ fprintf (stdout, " data.n=%d\n", qq->data.n.type);
+ if (is_number(qq->data.n)) {
+ fprintf (stdout, " data.n.data.val=%d\n", qq->data.n.data.val);
+ fprintf (stdout, " data.n.data.dval=%f\n", qq->data.n.data.dval);
+ }
+ fprintf (stdout, " data.str=%p\n", qq->data.str);
+ if (qq->data.str != NULL) {
+ fprintf (stdout, " data.str->len=%d\n", (int)qq->data.str->len);
+ fprintf (stdout, " data.str->str=%s\n", qq->data.str->str);
+ }
+ fprintf (stdout, " data.indep.serial=%d\n data.indep.scale=%d\n", qq->data.indep.serial,
+ qq->data.indep.scale);
+ fprintf (stdout, " data.sym=%p\n", qq->data.sym);
+ fprintf (stdout, " data.p=%p\n", qq->data.p);
+ fprintf (stdout, " data.node=%p\n", qq->data.node);
+ fprintf (stdout, " subscript=%d\n", qq->subscript_.type);
+ if (is_number(qq->subscript_)) {
+ fprintf (stdout, " subscript_.data.val=%d\n", qq->subscript_.data.val);
+ fprintf (stdout, " subscript_.data.dval=%f\n", qq->subscript_.data.dval);
+ }
+ fprintf (stdout, " hashloc=%p\n", qq->hashloc_);
+ fprintf (stdout, " parent=%p\n", qq->parent_);
+ fprintf (stdout, " attr_head=%p\n", qq->attr_head_);
+ fprintf (stdout, " subscr_head=%p\n\n", qq->subscr_head_);
+}
+#endif
+
+@ @<Declarations@>=
+static mp_node mp_get_value_node (MP mp);
+#if DEBUG > 1
+static void debug_dump_value_node (mp_node x);
+#endif
+
+@ 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 |hashloc| field, which contains the
+hash address of the token that names this attribute; and there's also a
+|parent| field, which points to the value node of |mp_structured| type at the
+next higher level (i.e., at the level to which this attribute is
+subsidiary). The |name_type| in an attribute node is `|attr|'. The
+|link| field points to the next attribute with the same parent; these are
+arranged in increasing order, so that |hashloc(mp_link(p))>hashloc(p)|. The
+final attribute node links to the constant |end_attr|, whose |hashloc|
+field is greater than any legal hash address. The |attr_head| in the
+parent points to a node whose |name_type| is |mp_structured_root|; this
+node represents the NULL attribute, i.e., the variable that is relevant
+when no attributes are attached to the parent. The |attr_head| node
+has the fields of either
+a value node, a subscript node, or an attribute node, depending on what
+the parent would be if it were not structured; but the subscript and
+attribute fields are ignored, so it effectively contains only the data of
+a value node. The |link| field in this special node points to an attribute
+node whose |hashloc| 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 non-symbolic value
+node with |mp_name_type(p)=root| and |mp_link(p)=h(x)|. We have |type(p)=mp_structured|,
+|attr_head(p)=q|, and |subscr_head(p)=r|, where |q| points to a value
+node and |r| to a subscript node. (Are you still following this? Use
+a pencil to draw a diagram.) The lone variable `\.x' is represented by
+|type(q)| and |value(q)|; furthermore
+|mp_name_type(q)=mp_structured_root| and |mp_link(q)=q1|, where |q1| points
+to an attribute node representing `\.{x[]}'. Thus |mp_name_type(q1)=attr|,
+|hashloc(q1)=collective_subscript=0|, |parent(q1)=p|,
+|type(q1)=mp_structured|, |attr_head(q1)=qq|, and |subscr_head(q1)=qq1|;
+|qq| is a three-word ``attribute-as-value'' node with |type(qq)=numeric_type|
+(assuming that \.{x5} is numeric, because |qq| represents `\.{x[]}'
+with no further attributes), |mp_name_type(qq)=structured_root|,
+|hashloc(qq)=0|, |parent(qq)=p|, and
+|mp_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 |mp_name_type(qq1)=attr|, |hashloc(qq1)=collective_subscript|,
+|parent(qq1)=q1|, and |mp_link(qq1)=qq2|. Since |qq2| represents
+`\.{x[]b}', |type(qq2)=mp_unknown_boolean|; also |hashloc(qq2)=h(b)|,
+|parent(qq2)=q1|, |mp_name_type(qq2)=attr|, |mp_link(qq2)=end_attr|.
+(Maybe colored lines will help untangle your picture.)
+ Node |r| is a subscript node with |type| and |value|
+representing `\.{x5}'; |mp_name_type(r)=subscr|, |subscript(r)=5.0|,
+and |mp_link(r)=r1| is another subscript node. To complete the picture,
+see if you can guess what |mp_link(r1)| is; give up? It's~|q1|.
+Furthermore |subscript(r1)=20.0|, |mp_name_type(r1)=subscr|,
+|type(r1)=mp_structured|, |attr_head(r1)=qqq|, |subscr_head(r1)=qqq1|,
+and we finish things off with three more nodes
+|qqq|, |qqq1|, and |qqq2| hung onto~|r1|. (Perhaps you should start again
+with a larger sheet of paper.) The value of variable \.{x20b}
+appears in node~|qqq2|, as you can well imagine.
+
+If the example in the previous paragraph doesn't make things crystal
+clear, a glance at some of the simpler subroutines below will reveal how
+things work out in practice.
+
+The only really unusual thing about these conventions is the use of
+collective subscript attributes. The idea is to avoid repeating a lot of
+type information when many elements of an array are identical macros
+(for which distinct values need not be stored) or when they don't have
+all of the possible attributes. Branches of the structure below collective
+subscript attributes do not carry actual values except for macro identifiers;
+branches of the structure below subscript nodes do not carry significant
+information in their collective subscript attributes.
+
+
+@c
+#if DEBUG
+#define hashloc(A) do_get_hashloc(mp,(mp_value_node)(A))
+#define set_hashloc(A,B) do_set_hashloc (mp,(mp_value_node)A, B)
+#define parent(A) do_get_parent(mp, A)
+#define set_parent(A,B) do_set_parent (mp,(mp_value_node)A, B)
+static mp_sym do_get_hashloc (MP mp, mp_value_node A) {
+ assert((A)->type == mp_attr_node_type || (A)->name_type == mp_attr);
+ return (A)->hashloc_;
+}
+static void do_set_hashloc (MP mp, mp_value_node A, mp_sym B) {
+ FUNCTION_TRACE4 ("set_hashloc(%p,%p) on line %d\n", (A), (B), __LINE__);
+ assert((A)->type == mp_attr_node_type || (A)->name_type == mp_attr);
+ A->hashloc_ = B;
+}
+static mp_node do_get_parent (MP mp, mp_value_node A) {
+ assert((A)->type == mp_attr_node_type || (A)->name_type == mp_attr);
+ return (A)->parent_; /* pointer to |mp_structured| variable */
+}
+static void do_set_parent (MP mp, mp_value_node A, mp_node d) {
+ assert((A)->type == mp_attr_node_type || (A)->name_type == mp_attr);
+ FUNCTION_TRACE4 ("set_parent(%p,%p) on line %d\n", (A), d, __LINE__);
+ A->parent_ = d;
+}
+#else
+#define hashloc(A) ((mp_value_node)(A))->hashloc_
+#define set_hashloc(A,B) ((mp_value_node)(A))->hashloc_ = B
+#define parent(A) ((mp_value_node)(A))->parent_
+#define set_parent(A,B) ((mp_value_node)(A))->parent_ = B
+#endif
+
+@
+@d mp_free_attr_node(a,b) do {
+ assert((b)->type == mp_attr_node_type || (b)->name_type == mp_attr);
+ mp_free_value_node(a,b);
+} while (0)
+
+@c
+static mp_value_node mp_get_attr_node (MP mp) {
+ mp_value_node p = (mp_value_node) mp_get_value_node (mp);
+ mp_type (p) = mp_attr_node_type;
+ return p;
+}
+
+
+@ Setting the |hashloc| field of |end_attr| to a value greater than
+any legal hash address is done by assigning $-1$ typecasted to
+|mp_sym|, hopefully resulting in all bits being set. On systems that
+support negative pointer values or where typecasting $-1$ does not
+result in all bits in a pointer being set, something else needs to be done.
+@^system dependencies@>
+
+@<Initialize table...@>=
+mp->end_attr = (mp_node) mp_get_attr_node (mp);
+set_hashloc (mp->end_attr, (mp_sym)-1);
+set_parent ((mp_value_node) mp->end_attr, NULL);
+
+@ @<Free table...@>=
+mp_free_attr_node (mp, mp->end_attr);
+
+@
+@d collective_subscript (void *)0 /* code for the attribute `\.{[]}' */
+@d subscript(A) ((mp_value_node)(A))->subscript_
+@d set_subscript(A,B) do_set_subscript (mp, (mp_value_node)(A), B)
+
+@c
+static void do_set_subscript (MP mp, mp_value_node A, mp_number B) {
+ FUNCTION_TRACE3("set_subscript(%p,%p)\n", (A), (B));
+ assert((A)->type == mp_subscr_node_type || (A)->name_type == mp_subscr);
+ number_clone(A->subscript_,B); /* subscript of this variable */
+}
+
+@
+@c
+static mp_value_node mp_get_subscr_node (MP mp) {
+ mp_value_node p = (mp_value_node) mp_get_value_node (mp);
+ mp_type (p) = mp_subscr_node_type;
+ return p;
+}
+
+
+@ Variables of type \&{pair} will have values that point to four-word
+nodes containing two numeric values. The first of these values has
+|name_type=mp_x_part_sector| and the second has |name_type=mp_y_part_sector|;
+the |link| in the first points back to the node whose |value| points
+to this four-word node.
+
+@d x_part(A) ((mp_pair_node)(A))->x_part_ /* where the \&{xpart} is found in a pair node */
+@d y_part(A) ((mp_pair_node)(A))->y_part_ /* where the \&{ypart} is found in a pair node */
+
+@<MPlib internal header stuff@>=
+typedef struct mp_pair_node_data {
+ NODE_BODY;
+ mp_node x_part_;
+ mp_node y_part_;
+} mp_pair_node_data;
+typedef struct mp_pair_node_data *mp_pair_node;
+
+@
+@d pair_node_size sizeof(struct mp_pair_node_data) /* the number of words in a subscript node */
+
+@c
+static mp_node mp_get_pair_node (MP mp) {
+ mp_node p;
+ if (mp->pair_nodes) {
+ p = mp->pair_nodes;
+ mp->pair_nodes = p->link;
+ mp->num_pair_nodes--;
+ p->link = NULL;
+ } else {
+ p = malloc_node (pair_node_size);
+ }
+ mp_type (p) = mp_pair_node_type;
+ FUNCTION_TRACE2("get_pair_node(): %p\n", p);
+ return (mp_node) p;
+}
+
+@ @<Declarations@>=
+void mp_free_pair_node (MP mp, mp_node p);
+
+@ @c
+void mp_free_pair_node (MP mp, mp_node p) {
+ FUNCTION_TRACE2 ("mp_free_pair_node(%p)\n", p);
+ if (!p) return;
+ if (mp->num_pair_nodes < max_num_pair_nodes) {
+ p->link = mp->pair_nodes;
+ mp->pair_nodes = p;
+ mp->num_pair_nodes++;
+ return;
+ }
+ mp->var_used -= pair_node_size;
+ xfree (p);
+}
+
+
+@ If |type(p)=mp_pair_type| or if |value(p)=NULL|, the procedure call |init_pair_node(p)| will
+allocate a pair node for~|p|. The individual parts of such nodes are initially of type
+|mp_independent|.
+
+@c
+static void mp_init_pair_node (MP mp, mp_node p) {
+ mp_node q; /* the new node */
+ mp_type (p) = mp_pair_type;
+ q = mp_get_pair_node (mp);
+ y_part (q) = mp_get_value_node (mp);
+ mp_new_indep (mp, y_part (q)); /* sets |type(q)| and |value(q)| */
+ mp_name_type (y_part (q)) = (quarterword) (mp_y_part_sector);
+ mp_link (y_part (q)) = p;
+ x_part (q) = mp_get_value_node (mp);
+ mp_new_indep (mp, x_part (q)); /* sets |type(q)| and |value(q)| */
+ mp_name_type (x_part (q)) = (quarterword) (mp_x_part_sector);
+ mp_link (x_part (q)) = p;
+ set_value_node (p, q);
+}
+
+
+@
+Variables of type \&{transform} are similar, but in this case their
+|value| points to a 12-word node containing six values, identified by
+|x_part_sector|, |y_part_sector|, |mp_xx_part_sector|, |mp_xy_part_sector|,
+|mp_yx_part_sector|, and |mp_yy_part_sector|.
+
+@d tx_part(A) ((mp_transform_node)(A))->tx_part_ /* where the \&{xpart} is found in a transform node */
+@d ty_part(A) ((mp_transform_node)(A))->ty_part_ /* where the \&{ypart} is found in a transform node */
+@d xx_part(A) ((mp_transform_node)(A))->xx_part_ /* where the \&{xxpart} is found in a transform node */
+@d xy_part(A) ((mp_transform_node)(A))->xy_part_ /* where the \&{xypart} is found in a transform node */
+@d yx_part(A) ((mp_transform_node)(A))->yx_part_ /* where the \&{yxpart} is found in a transform node */
+@d yy_part(A) ((mp_transform_node)(A))->yy_part_ /* where the \&{yypart} is found in a transform node */
+
+@<MPlib internal header stuff@>=
+typedef struct mp_transform_node_data {
+ NODE_BODY;
+ mp_node tx_part_;
+ mp_node ty_part_;
+ mp_node xx_part_;
+ mp_node yx_part_;
+ mp_node xy_part_;
+ mp_node yy_part_;
+} mp_transform_node_data;
+typedef struct mp_transform_node_data *mp_transform_node;
+
+@
+@d transform_node_size sizeof(struct mp_transform_node_data) /* the number of words in a subscript node */
+
+@c
+static mp_node mp_get_transform_node (MP mp) {
+ mp_transform_node p = (mp_transform_node) malloc_node (transform_node_size);
+ mp_type (p) = mp_transform_node_type;
+ return (mp_node) p;
+}
+
+
+@ @c
+static void mp_init_transform_node (MP mp, mp_node p) {
+ mp_node q; /* the new node */
+ mp_type (p) = mp_transform_type;
+ q = mp_get_transform_node (mp); /* big node */
+ yy_part (q) = mp_get_value_node (mp);
+ mp_new_indep (mp, yy_part (q)); /* sets |type(q)| and |value(q)| */
+ mp_name_type (yy_part (q)) = (quarterword) (mp_yy_part_sector);
+ mp_link (yy_part (q)) = p;
+ yx_part (q) = mp_get_value_node (mp);
+ mp_new_indep (mp, yx_part (q)); /* sets |type(q)| and |value(q)| */
+ mp_name_type (yx_part (q)) = (quarterword) (mp_yx_part_sector);
+ mp_link (yx_part (q)) = p;
+ xy_part (q) = mp_get_value_node (mp);
+ mp_new_indep (mp, xy_part (q)); /* sets |type(q)| and |value(q)| */
+ mp_name_type (xy_part (q)) = (quarterword) (mp_xy_part_sector);
+ mp_link (xy_part (q)) = p;
+ xx_part (q) = mp_get_value_node (mp);
+ mp_new_indep (mp, xx_part (q)); /* sets |type(q)| and |value(q)| */
+ mp_name_type (xx_part (q)) = (quarterword) (mp_xx_part_sector);
+ mp_link (xx_part (q)) = p;
+ ty_part (q) = mp_get_value_node (mp);
+ mp_new_indep (mp, ty_part (q)); /* sets |type(q)| and |value(q)| */
+ mp_name_type (ty_part (q)) = (quarterword) (mp_y_part_sector);
+ mp_link (ty_part (q)) = p;
+ tx_part (q) = mp_get_value_node (mp);
+ mp_new_indep (mp, tx_part (q)); /* sets |type(q)| and |value(q)| */
+ mp_name_type (tx_part (q)) = (quarterword) (mp_x_part_sector);
+ mp_link (tx_part (q)) = p;
+ set_value_node (p, q);
+}
+
+
+@
+Variables of type \&{color} have 3~values in 6~words identified by |mp_red_part_sector|,
+|mp_green_part_sector|, and |mp_blue_part_sector|.
+
+@d red_part(A) ((mp_color_node)(A))->red_part_ /* where the \&{redpart} is found in a color node */
+@d green_part(A) ((mp_color_node)(A))->green_part_ /* where the \&{greenpart} is found in a color node */
+@d blue_part(A) ((mp_color_node)(A))->blue_part_ /* where the \&{bluepart} is found in a color node */
+
+@d grey_part(A) red_part(A) /* where the \&{greypart} is found in a color node */
+
+@<MPlib internal header stuff@>=
+typedef struct mp_color_node_data {
+ NODE_BODY;
+ mp_node red_part_;
+ mp_node green_part_;
+ mp_node blue_part_;
+} mp_color_node_data;
+typedef struct mp_color_node_data *mp_color_node;
+
+@
+@d color_node_size sizeof(struct mp_color_node_data) /* the number of words in a subscript node */
+
+@c
+static mp_node mp_get_color_node (MP mp) {
+ mp_color_node p = (mp_color_node) malloc_node (color_node_size);
+ mp_type (p) = mp_color_node_type;
+ p->link = NULL;
+ return (mp_node) p;
+}
+
+
+@
+@c
+static void mp_init_color_node (MP mp, mp_node p) {
+ mp_node q; /* the new node */
+ mp_type (p) = mp_color_type;
+ q = mp_get_color_node (mp); /* big node */
+ blue_part (q) = mp_get_value_node (mp);
+ mp_new_indep (mp, blue_part (q)); /* sets |type(q)| and |value(q)| */
+ mp_name_type (blue_part (q)) = (quarterword) (mp_blue_part_sector);
+ mp_link (blue_part (q)) = p;
+ green_part (q) = mp_get_value_node (mp);
+ mp_new_indep (mp, green_part (q)); /* sets |type(q)| and |value(q)| */
+ mp_name_type (y_part (q)) = (quarterword) (mp_green_part_sector);
+ mp_link (green_part (q)) = p;
+ red_part (q) = mp_get_value_node (mp);
+ mp_new_indep (mp, red_part (q)); /* sets |type(q)| and |value(q)| */
+ mp_name_type (red_part (q)) = (quarterword) (mp_red_part_sector);
+ mp_link (red_part (q)) = p;
+ set_value_node (p, q);
+}
+
+
+@ Finally, variables of type |cmykcolor|.
+
+@d cyan_part(A) ((mp_cmykcolor_node)(A))->cyan_part_ /* where the \&{cyanpart} is found in a color node */
+@d magenta_part(A) ((mp_cmykcolor_node)(A))->magenta_part_ /* where the \&{magentapart} is found in a color node */
+@d yellow_part(A) ((mp_cmykcolor_node)(A))->yellow_part_ /* where the \&{yellowpart} is found in a color node */
+@d black_part(A) ((mp_cmykcolor_node)(A))->black_part_ /* where the \&{blackpart} is found in a color node */
+
+@<MPlib internal header stuff@>=
+typedef struct mp_cmykcolor_node_data {
+ NODE_BODY;
+ mp_node cyan_part_;
+ mp_node magenta_part_;
+ mp_node yellow_part_;
+ mp_node black_part_;
+} mp_cmykcolor_node_data;
+typedef struct mp_cmykcolor_node_data *mp_cmykcolor_node;
+
+@
+@d cmykcolor_node_size sizeof(struct mp_cmykcolor_node_data) /* the number of words in a subscript node */
+
+@c
+static mp_node mp_get_cmykcolor_node (MP mp) {
+ mp_cmykcolor_node p = (mp_cmykcolor_node) malloc_node (cmykcolor_node_size);
+ mp_type (p) = mp_cmykcolor_node_type;
+ p->link = NULL;
+ return (mp_node) p;
+}
+
+
+@
+@c
+static void mp_init_cmykcolor_node (MP mp, mp_node p) {
+ mp_node q; /* the new node */
+ mp_type (p) = mp_cmykcolor_type;
+ q = mp_get_cmykcolor_node (mp); /* big node */
+ black_part (q) = mp_get_value_node (mp);
+ mp_new_indep (mp, black_part (q)); /* sets |type(q)| and |value(q)| */
+ mp_name_type (black_part (q)) = (quarterword) (mp_black_part_sector);
+ mp_link (black_part (q)) = p;
+ yellow_part (q) = mp_get_value_node (mp);
+ mp_new_indep (mp, yellow_part (q)); /* sets |type(q)| and |value(q)| */
+ mp_name_type (yellow_part (q)) = (quarterword) (mp_yellow_part_sector);
+ mp_link (yellow_part (q)) = p;
+ magenta_part (q) = mp_get_value_node (mp);
+ mp_new_indep (mp, magenta_part (q)); /* sets |type(q)| and |value(q)| */
+ mp_name_type (magenta_part (q)) = (quarterword) (mp_magenta_part_sector);
+ mp_link (magenta_part (q)) = p;
+ cyan_part (q) = mp_get_value_node (mp);
+ mp_new_indep (mp, cyan_part (q)); /* sets |type(q)| and |value(q)| */
+ mp_name_type (cyan_part (q)) = (quarterword) (mp_cyan_part_sector);
+ mp_link (cyan_part (q)) = p;
+ set_value_node (p, q);
+}
+
+
+@ 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}.
+
+@ The |id_transform| function creates a capsule for the
+identity transformation.
+
+@c
+static mp_node mp_id_transform (MP mp) {
+ mp_node p, q; /* list manipulation registers */
+ p = mp_get_value_node (mp);
+ mp_name_type (p) = mp_capsule;
+ set_value_number (p, zero_t); /* todo: this was |null| */
+ mp_init_transform_node (mp, p);
+ q = value_node (p);
+ mp_type (tx_part (q)) = mp_known;
+ set_value_number (tx_part (q), zero_t);
+ mp_type (ty_part (q)) = mp_known;
+ set_value_number (ty_part (q), zero_t);
+ mp_type (xy_part (q)) = mp_known;
+ set_value_number (xy_part (q), zero_t);
+ mp_type (yx_part (q)) = mp_known;
+ set_value_number (yx_part (q), zero_t);
+ mp_type (xx_part (q)) = mp_known;
+ set_value_number (xx_part (q), unity_t);
+ mp_type (yy_part (q)) = mp_known;
+ set_value_number (yy_part (q), unity_t);
+ return p;
+}
+
+
+@ Tokens are of type |tag_token| when they first appear, but they point
+to |NULL| until they are first used as the root of a variable.
+The following subroutine establishes the root node on such grand occasions.
+
+@c
+static void mp_new_root (MP mp, mp_sym x) {
+ mp_node p; /* the new node */
+ p = mp_get_value_node (mp);
+ mp_type (p) = mp_undefined;
+ mp_name_type (p) = mp_root;
+ set_value_sym (p, x);
+ set_equiv_node (x, p);
+}
+
+
+@ These conventions for variable representation are illustrated by the
+|print_variable_name| routine, which displays the full name of a
+variable given only a pointer to its value.
+
+@<Declarations@>=
+static void mp_print_variable_name (MP mp, mp_node p);
+
+@ @c
+void mp_print_variable_name (MP mp, mp_node p) {
+ mp_node q; /* a token list that will name the variable's suffix */
+ mp_node r; /* temporary for token list creation */
+ while (mp_name_type (p) >= mp_x_part_sector) {
+ switch (mp_name_type (p)) {
+ case mp_x_part_sector: mp_print (mp, "xpart "); break;
+ case mp_y_part_sector: mp_print (mp, "ypart "); break;
+ case mp_xx_part_sector: mp_print (mp, "xxpart "); break;
+ case mp_xy_part_sector: mp_print (mp, "xypart "); break;
+ case mp_yx_part_sector: mp_print (mp, "yxpart "); break;
+ case mp_yy_part_sector: mp_print (mp, "yypart "); break;
+ case mp_red_part_sector: mp_print (mp, "redpart "); break;
+ case mp_green_part_sector: mp_print (mp, "greenpart "); break;
+ case mp_blue_part_sector: mp_print (mp, "bluepart "); break;
+ case mp_cyan_part_sector: mp_print (mp, "cyanpart "); break;
+ case mp_magenta_part_sector:mp_print (mp, "magentapart ");break;
+ case mp_yellow_part_sector: mp_print (mp, "yellowpart "); break;
+ case mp_black_part_sector: mp_print (mp, "blackpart "); break;
+ case mp_grey_part_sector: mp_print (mp, "greypart "); break;
+ case mp_capsule: mp_printf (mp, "%%CAPSULE%p",p); return; break;
+ /* this is to please the compiler: the remaining cases are operation codes */
+ default: break;
+ }
+ p = mp_link (p);
+ }
+ q = NULL;
+ while (mp_name_type (p) > mp_saved_root) {
+ /* Ascend one level, pushing a token onto list |q|
+ and replacing |p| by its parent */
+ if (mp_name_type (p) == mp_subscr) {
+ r = mp_new_num_tok (mp, subscript (p));
+ do {
+ p = mp_link (p);
+ } while (mp_name_type (p) != mp_attr);
+ } else if (mp_name_type (p) == mp_structured_root) {
+ p = mp_link (p);
+ goto FOUND;
+ } else {
+ if (mp_name_type (p) != mp_attr)
+ mp_confusion (mp, "var");
+ r = mp_get_symbolic_node (mp);
+ set_mp_sym_sym (r, hashloc (p)); /* the hash address */
+ }
+ set_mp_link (r, q);
+ q = r;
+ FOUND:
+ p = parent ((mp_value_node) p);
+
+ }
+ /* now |link(p)| is the hash address of |p|, and
+ |name_type(p)| is either |root| or |saved_root|.
+ Have to prepend a token to |q| for |show_token_list|. */
+ r = mp_get_symbolic_node (mp);
+ set_mp_sym_sym (r, value_sym (p));
+ mp_link (r) = q;
+ if (mp_name_type (p) == mp_saved_root)
+ mp_print (mp, "(SAVED)");
+ mp_show_token_list (mp, r, NULL, max_integer, mp->tally);
+ mp_flush_token_list (mp, r);
+}
+
+@ The |interesting| function returns |true| if a given variable is not
+in a capsule, or if the user wants to trace capsules.
+
+@c
+static boolean mp_interesting (MP mp, mp_node p) {
+ mp_name_type_type t; /* a |name_type| */
+ if (number_positive(internal_value (mp_tracing_capsules))) {
+ return true;
+ } else {
+ t = mp_name_type (p);
+ if (t >= mp_x_part_sector && t != mp_capsule) {
+ mp_node tt = value_node(mp_link(p));
+ switch (t) {
+ case mp_x_part_sector:
+ t = mp_name_type (x_part (tt));
+ break;
+ case mp_y_part_sector:
+ t = mp_name_type (y_part (tt));
+ break;
+ case mp_xx_part_sector:
+ t = mp_name_type (xx_part (tt));
+ break;
+ case mp_xy_part_sector:
+ t = mp_name_type (xy_part (tt));
+ break;
+ case mp_yx_part_sector:
+ t = mp_name_type (yx_part (tt));
+ break;
+ case mp_yy_part_sector:
+ t = mp_name_type (yy_part (tt));
+ break;
+ case mp_red_part_sector:
+ t = mp_name_type (red_part (tt));
+ break;
+ case mp_green_part_sector:
+ t = mp_name_type (green_part (tt));
+ break;
+ case mp_blue_part_sector:
+ t = mp_name_type (blue_part (tt));
+ break;
+ case mp_cyan_part_sector:
+ t = mp_name_type (cyan_part (tt));
+ break;
+ case mp_magenta_part_sector:
+ t = mp_name_type (magenta_part (tt));
+ break;
+ case mp_yellow_part_sector:
+ t = mp_name_type (yellow_part (tt));
+ break;
+ case mp_black_part_sector:
+ t = mp_name_type (black_part (tt));
+ break;
+ case mp_grey_part_sector:
+ t = mp_name_type (grey_part (tt));
+ break;
+ default:
+ break;
+ }
+ }
+ }
+ return (t != mp_capsule);
+}
+
+
+@ Now here is a subroutine that converts an unstructured type into an
+equivalent structured type, by inserting a |mp_structured| node that is
+capable of growing. This operation is done only when |mp_name_type(p)=root|,
+|subscr|, or |attr|.
+
+The procedure returns a pointer to the new node that has taken node~|p|'s
+place in the structure. Node~|p| itself does not move, nor are its
+|value| or |type| fields changed in any way.
+
+@c
+static mp_node mp_new_structure (MP mp, mp_node p) {
+ mp_node q, r = NULL; /* list manipulation registers */
+ mp_sym qq = NULL;
+ switch (mp_name_type (p)) {
+ case mp_root:
+ {
+ qq = value_sym (p);
+ r = mp_get_value_node (mp);
+ set_equiv_node (qq, r);
+ }
+ break;
+ case mp_subscr:
+ /* Link a new subscript node |r| in place of node |p| */
+ {
+ mp_node q_new;
+ q = p;
+ do {
+ q = mp_link (q);
+ } while (mp_name_type (q) != mp_attr);
+ q = parent ((mp_value_node) q);
+ r = mp->temp_head;
+ set_mp_link (r, subscr_head (q));
+ do {
+ q_new = r;
+ r = mp_link (r);
+ } while (r != p);
+ r = (mp_node) mp_get_subscr_node (mp);
+ if (q_new == mp->temp_head) {
+ set_subscr_head (q, r);
+ } else {
+ set_mp_link (q_new, r);
+ }
+ set_subscript (r, subscript (p));
+ }
+
+ break;
+ case mp_attr:
+ /* Link a new attribute node |r| in place of node |p| */
+ /* If the attribute is |collective_subscript|, there are two pointers to
+ node~|p|, so we must change both of them. */
+ {
+ mp_value_node rr;
+ q = parent ((mp_value_node) p);
+ r = attr_head (q);
+ do {
+ q = r;
+ r = mp_link (r);
+ } while (r != p);
+ rr = mp_get_attr_node (mp);
+ r = (mp_node) rr;
+ set_mp_link (q, (mp_node) rr);
+ set_hashloc (rr, hashloc (p));
+ set_parent (rr, parent ((mp_value_node) p));
+ if (hashloc (p) == collective_subscript) {
+ q = mp->temp_head;
+ set_mp_link (q, subscr_head (parent ((mp_value_node) p)));
+ while (mp_link (q) != p)
+ q = mp_link (q);
+ if (q == mp->temp_head)
+ set_subscr_head (parent ((mp_value_node) p), (mp_node) rr);
+ else
+ set_mp_link (q, (mp_node) rr);
+ }
+ }
+
+ break;
+ default:
+ mp_confusion (mp, "struct");
+ break;
+ }
+ set_mp_link (r, mp_link (p));
+ set_value_sym (r, value_sym (p));
+ mp_type (r) = mp_structured;
+ mp_name_type (r) = mp_name_type (p);
+ set_attr_head (r, p);
+ mp_name_type (p) = mp_structured_root;
+ {
+ mp_value_node qqr = mp_get_attr_node (mp);
+ set_mp_link (p, (mp_node) qqr);
+ set_subscr_head (r, (mp_node) qqr);
+ set_parent (qqr, r);
+ mp_type (qqr) = mp_undefined;
+ mp_name_type (qqr) = mp_attr;
+ set_mp_link (qqr, mp->end_attr);
+ set_hashloc (qqr, collective_subscript);
+ }
+ return r;
+}
+
+@ The |find_variable| routine is given a pointer~|t| to a nonempty token
+list of suffixes; it returns a pointer to the corresponding non-symbolic
+value. For example, if |t| points to token \.x followed by a numeric
+token containing the value~7, |find_variable| finds where the value of
+\.{x7} is stored in memory. This may seem a simple task, and it
+usually is, except when \.{x7} has never been referenced before.
+Indeed, \.x may never have even been subscripted before; complexities
+arise with respect to updating the collective subscript information.
+
+If a macro type is detected anywhere along path~|t|, or if the first
+item on |t| isn't a |tag_token|, the value |NULL| is returned.
+Otherwise |p| will be a non-NULL pointer to a node such that
+|undefined<type(p)<mp_structured|.
+
+@c
+static mp_node mp_find_variable (MP mp, mp_node t) {
+ mp_node p, q, r, s; /* nodes in the ``value'' line */
+ mp_sym p_sym;
+ mp_node pp, qq, rr, ss; /* nodes in the ``collective'' line */
+@^inner loop@>;
+ p_sym = mp_sym_sym (t);
+ t = mp_link (t);
+ if ((eq_type (p_sym) % mp_outer_tag) != mp_tag_token)
+ return NULL;
+ if (equiv_node (p_sym) == NULL)
+ mp_new_root (mp, p_sym);
+ p = equiv_node (p_sym);
+ pp = p;
+ while (t != NULL) {
+ /* Make sure that both nodes |p| and |pp| are of |mp_structured| type */
+ /* 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. */
+ if (mp_type (pp) != mp_structured) {
+ if (mp_type (pp) > mp_structured)
+ return NULL;
+ ss = mp_new_structure (mp, pp);
+ if (p == pp)
+ p = ss;
+ pp = ss;
+ } /* now |type(pp)=mp_structured| */
+ if (mp_type (p) != mp_structured) { /* it cannot be |>mp_structured| */
+ p = mp_new_structure (mp, p); /* now |type(p)=mp_structured| */
+ }
+
+ if (mp_type (t) != mp_symbol_node) {
+ /* Descend one level for the subscript |value(t)| */
+ /* We want this part of the program to be reasonably fast, in case there are
+ 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. */
+ mp_number nn, save_subscript; /* temporary storage */
+ new_number (nn);
+ new_number (save_subscript);
+ number_clone (nn, value_number (t));
+ pp = mp_link (attr_head (pp)); /* now |hashloc(pp)=collective_subscript| */
+ q = mp_link (attr_head (p));
+ number_clone (save_subscript, subscript (q));
+ set_number_to_inf(subscript (q));
+ s = mp->temp_head;
+ set_mp_link (s, subscr_head (p));
+ do {
+ r = s;
+ s = mp_link (s);
+ } while (number_greater (nn, subscript (s)));
+ if (number_equal(nn, subscript (s))) {
+ p = s;
+ } else {
+ mp_value_node p1 = mp_get_subscr_node (mp);
+ if (r == mp->temp_head)
+ set_subscr_head (p, (mp_node) p1);
+ else
+ set_mp_link (r, (mp_node) p1);
+ set_mp_link (p1, s);
+ number_clone (subscript (p1), nn);
+ mp_name_type (p1) = mp_subscr;
+ mp_type (p1) = mp_undefined;
+ p = (mp_node) p1;
+ }
+ number_clone (subscript (q), save_subscript);
+ free_number (save_subscript);
+ free_number (nn);
+ } else {
+ /* Descend one level for the attribute |mp_sym_info(t)| */
+ mp_sym nn1 = mp_sym_sym (t);
+ ss = attr_head (pp);
+ do {
+ rr = ss;
+ ss = mp_link (ss);
+ } while (nn1 > hashloc (ss));
+ if (nn1 < hashloc (ss)) {
+ qq = (mp_node) mp_get_attr_node (mp);
+ set_mp_link (rr, qq);
+ set_mp_link (qq, ss);
+ set_hashloc (qq, nn1);
+ mp_name_type (qq) = mp_attr;
+ mp_type (qq) = mp_undefined;
+ set_parent ((mp_value_node) qq, pp);
+ ss = qq;
+ }
+ if (p == pp) {
+ p = ss;
+ pp = ss;
+ } else {
+ pp = ss;
+ s = attr_head (p);
+ do {
+ r = s;
+ s = mp_link (s);
+ } while (nn1 > hashloc (s));
+ if (nn1 == hashloc (s)) {
+ p = s;
+ } else {
+ q = (mp_node) mp_get_attr_node (mp);
+ set_mp_link (r, q);
+ set_mp_link (q, s);
+ set_hashloc (q, nn1);
+ mp_name_type (q) = mp_attr;
+ mp_type (q) = mp_undefined;
+ set_parent ((mp_value_node) q, p);
+ p = q;
+ }
+ }
+ }
+ t = mp_link (t);
+ }
+ if (mp_type (pp) >= mp_structured) {
+ if (mp_type (pp) == mp_structured)
+ pp = attr_head (pp);
+ else
+ return NULL;
+ }
+ if (mp_type (p) == mp_structured)
+ p = attr_head (p);
+ if (mp_type (p) == mp_undefined) {
+ if (mp_type (pp) == mp_undefined) {
+ mp_type (pp) = mp_numeric_type;
+ set_value_number (pp, zero_t);
+ }
+ mp_type (p) = mp_type (pp);
+ set_value_number (p, zero_t);
+ }
+ return p;
+}
+
+
+@ 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 symbolic nodes that represent
+suffixes, with |info=collective_subscript| for subscripts.
+
+@<Declarations@>=
+void mp_flush_cur_exp (MP mp, mp_value v);
+
+@ @c
+static void mp_flush_variable (MP mp, mp_node p, mp_node t,
+ boolean discard_suffixes) {
+ mp_node q, r = NULL; /* list manipulation */
+ mp_sym n; /* attribute to match */
+ while (t != NULL) {
+ if (mp_type (p) != mp_structured) {
+ return;
+ }
+ n = mp_sym_sym (t);
+ t = mp_link (t);
+ if (n == collective_subscript) {
+ q = subscr_head (p);
+ while (mp_name_type (q) == mp_subscr) {
+ mp_flush_variable (mp, q, t, discard_suffixes);
+ if (t == NULL) {
+ if (mp_type (q) == mp_structured) {
+ r = q;
+ } else {
+ if (r==NULL)
+ set_subscr_head (p, mp_link (q));
+ else
+ set_mp_link (r, mp_link (q));
+ mp_free_value_node (mp, q);
+ }
+ } else {
+ r = q;
+ }
+ q = (r==NULL ? subscr_head (p) : mp_link (r));
+ }
+ }
+ p = attr_head (p);
+ do {
+ p = mp_link (p);
+ } while (hashloc (p) < n);
+ if (hashloc (p) != n) {
+ return;
+ }
+ }
+ if (discard_suffixes) {
+ mp_flush_below_variable (mp, p);
+ } else {
+ if (mp_type (p) == mp_structured) {
+ p = attr_head (p);
+ }
+ mp_recycle_value (mp, p);
+ }
+}
+
+
+@ The next procedure is simpler; it wipes out everything but |p| itself,
+which becomes undefined.
+
+@<Declarations@>=
+static void mp_flush_below_variable (MP mp, mp_node p);
+
+@ @c
+void mp_flush_below_variable (MP mp, mp_node p) {
+ mp_node q, r; /* list manipulation registers */
+ FUNCTION_TRACE2 ("mp_flush_below_variable(%p)\n", p);
+ if (mp_type (p) != mp_structured) {
+ mp_recycle_value (mp, p); /* this sets |type(p)=undefined| */
+ } else {
+ q = subscr_head (p);
+ while (mp_name_type (q) == mp_subscr) {
+ mp_flush_below_variable (mp, q);
+ r = q;
+ q = mp_link (q);
+ mp_free_value_node (mp, r);
+ }
+ r = attr_head (p);
+ q = mp_link (r);
+ mp_recycle_value (mp, r);
+ mp_free_value_node (mp, r);
+ do {
+ mp_flush_below_variable (mp, q);
+ r = q;
+ q = mp_link (q);
+ mp_free_value_node (mp, r);
+ } while (q != mp->end_attr);
+ mp_type (p) = mp_undefined;
+ }
+}
+
+
+@ Just before assigning a new value to a variable, we will recycle the
+old value and make the old value undefined. The |und_type| routine
+determines what type of undefined value should be given, based on
+the current type before recycling.
+
+@c
+static quarterword mp_und_type (MP mp, mp_node p) {
+ (void) mp;
+ switch (mp_type (p)) {
+ case mp_vacuous:
+ return mp_undefined;
+ case mp_boolean_type:
+ case mp_unknown_boolean:
+ return mp_unknown_boolean;
+ case mp_string_type:
+ case mp_unknown_string:
+ return mp_unknown_string;
+ case mp_pen_type:
+ case mp_unknown_pen:
+ return mp_unknown_pen;
+ case mp_path_type:
+ case mp_unknown_path:
+ return mp_unknown_path;
+ case mp_picture_type:
+ case mp_unknown_picture:
+ return mp_unknown_picture;
+ case mp_transform_type:
+ case mp_color_type:
+ case mp_cmykcolor_type:
+ case mp_pair_type:
+ case mp_numeric_type:
+ return mp_type (p);
+ case mp_known:
+ case mp_dependent:
+ case mp_proto_dependent:
+ case mp_independent:
+ return mp_numeric_type;
+ default: /* there are no other valid cases, but please the compiler */
+ return 0;
+ }
+ return 0;
+}
+
+
+@ The |clear_symbol| routine is used when we want to redefine the equivalent
+of a symbolic token. It must remove any variable structure or macro
+definition that is currently attached to that symbol. If the |saving|
+parameter is true, a subsidiary structure is saved instead of destroyed.
+
+@c
+static void mp_clear_symbol (MP mp, mp_sym p, boolean saving) {
+ mp_node q; /* |equiv(p)| */
+ FUNCTION_TRACE3 ("mp_clear_symbol(%p,%d)\n", p, saving);
+ q = equiv_node (p);
+ switch (eq_type (p) % mp_outer_tag) {
+ case mp_defined_macro:
+ case mp_secondary_primary_macro:
+ case mp_tertiary_secondary_macro:
+ case mp_expression_tertiary_macro:
+ if (!saving)
+ mp_delete_mac_ref (mp, q);
+ break;
+ case mp_tag_token:
+ if (q != NULL) {
+ if (saving) {
+ mp_name_type (q) = mp_saved_root;
+ } else {
+ mp_flush_below_variable (mp, q);
+ mp_free_value_node (mp, q);
+ }
+ }
+ break;
+ default:
+ break;
+ }
+ set_equiv (p, mp->frozen_undefined->v.data.indep.serial);
+ set_eq_type (p, mp->frozen_undefined->type);
+}
+
+
+@* 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 |type| fields. If |p| points to a saved item,
+then
+
+\smallskip\hang
+|p->type=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
+|p->type=mp_normal_sym| means that |p->value| holds the former
+contents of |eqtb[q]| (saved in the |knot| field of the value, which
+is otherwise unused for variables). Such save stack entries are generated by \&{save}
+commands.
+
+\smallskip\hang
+|p->type=mp_internal_sym| means that |p->value| is a |mp_internal|
+to be restored to internal parameter number~|q| (saved in the |serial| field of the value, which
+is otherwise unused for internals). Such entries are generated by \&{interim} commands.
+
+\smallskip\noindent
+The global variable |save_ptr| points to the top item on the save stack.
+
+@<Types...@>=
+typedef struct mp_save_data {
+ quarterword type;
+ mp_internal value;
+ struct mp_save_data *link;
+} mp_save_data;
+
+@ @<Glob...@>=
+mp_save_data *save_ptr; /* the most recently saved item */
+
+@ @<Set init...@>=
+mp->save_ptr = NULL;
+
+@ Saving a boundary item
+@c
+static void mp_save_boundary (MP mp) {
+ mp_save_data *p; /* temporary register */
+ FUNCTION_TRACE1 ("mp_save_boundary ()\n");
+ p = xmalloc (1, sizeof (mp_save_data));
+ p->type = 0;
+ p->link = mp->save_ptr;
+ mp->save_ptr = p;
+}
+
+
+@ The |save_variable| routine is given a hash address |q|; it salts this
+address in the save stack, together with its current equivalent,
+then makes token~|q| behave as though it were brand new.
+
+Nothing is stacked when |save_ptr=NULL|, however; there's no way to remove
+things from the stack when the program is not inside a group, so there's
+no point in wasting the space.
+
+@c
+static void mp_save_variable (MP mp, mp_sym q) {
+ mp_save_data *p; /* temporary register */
+ FUNCTION_TRACE2 ("mp_save_variable (%p)\n", q);
+ if (mp->save_ptr != NULL) {
+ p = xmalloc (1, sizeof (mp_save_data));
+ p->type = mp_normal_sym;
+ p->link = mp->save_ptr;
+ p->value.v.data.indep.scale = eq_type (q);
+ p->value.v.data.indep.serial = equiv(q);
+ p->value.v.data.node = equiv_node(q);
+ p->value.v.data.p = (mp_knot)q;
+ mp->save_ptr = p;
+ }
+ mp_clear_symbol (mp, q, (mp->save_ptr != NULL));
+}
+static void mp_unsave_variable (MP mp) {
+ mp_sym q = (mp_sym)mp->save_ptr->value.v.data.p;
+ if (number_positive(internal_value (mp_tracing_restores))) {
+ mp_begin_diagnostic (mp);
+ mp_print_nl (mp, "{restoring ");
+ mp_print_text (q);
+ mp_print_char (mp, xord ('}'));
+ mp_end_diagnostic (mp, false);
+ }
+ mp_clear_symbol (mp, q, false);
+ set_eq_type(q, mp->save_ptr->value.v.data.indep.scale);
+ set_equiv (q,mp->save_ptr->value.v.data.indep.serial);
+ q->v.data.node = mp->save_ptr->value.v.data.node;
+ if (eq_type (q) % mp_outer_tag == mp_tag_token) {
+ mp_node pp = q->v.data.node;
+ if (pp != NULL)
+ mp_name_type (pp) = mp_root;
+ }
+}
+
+@ Similarly, |save_internal| is given the location |q| of an internal
+quantity like |mp_tracing_pens|. It creates a save stack entry of the
+third kind.
+
+@c
+static void mp_save_internal (MP mp, halfword q) {
+ mp_save_data *p; /* new item for the save stack */
+ FUNCTION_TRACE2 ("mp_save_internal (%d)\n", q);
+ if (mp->save_ptr != NULL) {
+ p = xmalloc (1, sizeof (mp_save_data));
+ p->type = mp_internal_sym;
+ p->link = mp->save_ptr;
+ p->value = mp->internal[q];
+ p->value.v.data.indep.serial = q;
+ new_number(p->value.v.data.n);
+ number_clone(p->value.v.data.n, mp->internal[q].v.data.n);
+ mp->save_ptr = p;
+ }
+}
+
+static void mp_unsave_internal (MP mp) {
+ halfword q = mp->save_ptr->value.v.data.indep.serial;
+ mp_internal saved = mp->save_ptr->value;
+ if (number_positive(internal_value (mp_tracing_restores))) {
+ mp_begin_diagnostic (mp);
+ mp_print_nl (mp, "{restoring ");
+ mp_print (mp, internal_name (q));
+ mp_print_char (mp, xord ('='));
+ if (internal_type (q) == mp_known) {
+ print_number (saved.v.data.n);
+ } else if (internal_type (q) == mp_string_type) {
+ char *s = mp_str (mp, saved.v.data.str);
+ mp_print (mp, s);
+ } else {
+ mp_confusion (mp, "internal_restore");
+ }
+ mp_print_char (mp, xord ('}'));
+ mp_end_diagnostic (mp, false);
+ }
+ free_number (mp->internal[q].v.data.n);
+ mp->internal[q] = saved;
+}
+
+@ At the end of a group, the |unsave| routine restores all of the saved
+equivalents in reverse order. This routine will be called only when there
+is at least one boundary item on the save stack.
+
+@c
+static void mp_unsave (MP mp) {
+ mp_save_data *p; /* saved item */
+ FUNCTION_TRACE1 ("mp_unsave ()\n");
+ while (mp->save_ptr->type != 0) {
+ if (mp->save_ptr->type == mp_internal_sym) {
+ mp_unsave_internal(mp);
+ } else {
+ mp_unsave_variable(mp);
+ }
+ p = mp->save_ptr->link;
+ xfree (mp->save_ptr);
+ mp->save_ptr = p;
+ }
+ p = mp->save_ptr->link;
+ xfree (mp->save_ptr);
+ mp->save_ptr = p;
+}
+
+
+@* 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
+|mp_left_type| and |mp_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 |mp_left_type| of knot~0 and the |mp_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 mp_next_knot(A) (A)->next /* the next knot in this list */
+@d mp_left_type(A) (A)->data.types.left_type /* characterizes the path entering this knot */
+@d mp_right_type(A) (A)->data.types.right_type /* characterizes the path leaving this knot */
+@d mp_prev_knot(A) (A)->data.prev /* the previous knot in this list (only for pens) */
+@d mp_knot_info(A) (A)->data.info /* temporary info, used during splitting */
+
+@<Exported types...@>=
+typedef struct mp_knot_data *mp_knot;
+typedef struct mp_knot_data {
+ mp_number x_coord; /* the |x| coordinate of this knot */
+ mp_number y_coord; /* the |y| coordinate of this knot */
+ mp_number left_x; /* the |x| coordinate of previous control point */
+ mp_number left_y; /* the |y| coordinate of previous control point */
+ mp_number right_x; /* the |x| coordinate of next control point */
+ mp_number right_y; /* the |y| coordinate of next control point */
+ mp_knot next;
+ union {
+ struct {
+ unsigned short left_type;
+ unsigned short right_type;
+ } types;
+ mp_knot prev;
+ signed int info;
+ } data;
+ unsigned char originator;
+} mp_knot_data;
+
+
+@
+@d mp_gr_next_knot(A) (A)->next /* the next knot in this list */
+
+@<Exported types...@>=
+typedef struct mp_gr_knot_data *mp_gr_knot;
+typedef struct mp_gr_knot_data {
+ double x_coord;
+ double y_coord;
+ double left_x;
+ double left_y;
+ double right_x;
+ double right_y;
+ mp_gr_knot next;
+ union {
+ struct {
+ unsigned short left_type;
+ unsigned short right_type;
+ } types;
+ mp_gr_knot prev;
+ signed int info;
+ } data;
+ unsigned char originator;
+} mp_gr_knot_data;
+
+
+@ @<MPlib header stuff@>=
+enum mp_knot_type {
+ mp_endpoint = 0, /* |mp_left_type| at path beginning and |mp_right_type| at path end */
+ mp_explicit, /* |mp_left_type| or |mp_right_type| when control points are known */
+ mp_given, /* |mp_left_type| or |mp_right_type| when a direction is given */
+ mp_curl, /* |mp_left_type| or |mp_right_type| when a curl is desired */
+ mp_open, /* |mp_left_type| or |mp_right_type| when \MP\ should choose the direction */
+ mp_end_cycle
+};
+
+@ Before the B\'ezier control points have been calculated, the memory
+space they will ultimately occupy is taken up by information that can be
+used to compute them. There are four cases:
+
+\yskip
+\textindent{$\bullet$} If |mp_right_type=mp_open|, the curve should leave
+the knot in the same direction it entered; \MP\ will figure out a
+suitable direction.
+
+\yskip
+\textindent{$\bullet$} If |mp_right_type=mp_curl|, the curve should leave the
+knot in a direction depending on the angle at which it enters the next
+knot and on the curl parameter stored in |right_curl|.
+
+\yskip
+\textindent{$\bullet$} If |mp_right_type=mp_given|, the curve should leave the
+knot in a nonzero direction stored as an |angle| in |right_given|.
+
+\yskip
+\textindent{$\bullet$} If |mp_right_type=mp_explicit|, the B\'ezier control
+point for leaving this knot has already been computed; it is in the
+|mp_right_x| and |mp_right_y| fields.
+
+\yskip\noindent
+The rules for |mp_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
+|mp_left_type|&\\{left} info&|x_coord,y_coord|&|mp_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 |mp_right_type| of a node is |explicit| if and only if the
+|mp_left_type| of the following node is |explicit|.
+(iii)~|endpoint| types occur only at the ends, as mentioned above.
+
+@d left_curl left_x /* curl information when entering this knot */
+@d left_given left_x /* given direction when entering this knot */
+@d left_tension left_y /* tension information when entering this knot */
+@d right_curl right_x /* curl information when leaving this knot */
+@d right_given right_x /* given direction when leaving this knot */
+@d right_tension right_y /* tension information when leaving this knot */
+
+@ Knots can be user-supplied, or they can be created by program code,
+like the |split_cubic| function, or |copy_path|. The distinction is
+needed for the cleanup routine that runs after |split_cubic|, because
+it should only delete knots it has previously inserted, and never
+anything that was user-supplied. In order to be able to differentiate
+one knot from another, we will set |originator(p):=mp_metapost_user| when
+it appeared in the actual metapost program, and
+|originator(p):=mp_program_code| in all other cases.
+
+@d mp_originator(A) (A)->originator /* the creator of this knot */
+
+@<Exported types@>=
+enum mp_knot_originator {
+ mp_program_code = 0, /* not created by a user */
+ mp_metapost_user /* created by a user */
+};
+
+@ Here is a routine that prints a given knot list
+in symbolic form. It illustrates the conventions discussed above,
+and checks for anomalies that might arise while \MP\ is being debugged.
+
+@<Declarations@>=
+static void mp_pr_path (MP mp, mp_knot h);
+
+@ @c
+void mp_pr_path (MP mp, mp_knot h) {
+ mp_knot p, q; /* for list traversal */
+ p = h;
+ do {
+ q = mp_next_knot (p);
+ if ((p == NULL) || (q == NULL)) {
+ mp_print_nl (mp, "???");
+ return; /* this won't happen */
+@.???@>
+ }
+ @<Print information for adjacent knots |p| and |q|@>;
+ DONE1:
+ p = q;
+ if (p && ((p != h) || (mp_left_type (h) != mp_endpoint))) {
+ @<Print two dots, followed by |given| or |curl| if present@>;
+ }
+ } while (p != h);
+ if (mp_left_type (h) != mp_endpoint)
+ mp_print (mp, "cycle");
+}
+
+
+@ @<Print information for adjacent knots...@>=
+mp_print_two (mp, p->x_coord, p->y_coord);
+switch (mp_right_type (p)) {
+case mp_endpoint:
+ if (mp_left_type (p) == mp_open)
+ mp_print (mp, "{open?}"); /* can't happen */
+@.open?@>;
+ if ((mp_left_type (q) != mp_endpoint) || (q != h))
+ q = NULL; /* force an error */
+ goto DONE1;
+ break;
+case mp_explicit:
+ @<Print control points between |p| and |q|, then |goto done1|@>;
+ break;
+case mp_open:
+ @<Print information for a curve that begins |open|@>;
+ break;
+case mp_curl:
+case mp_given:
+ @<Print information for a curve that begins |curl| or |given|@>;
+ break;
+default:
+ mp_print (mp, "???"); /* can't happen */
+@.???@>;
+ break;
+}
+if (mp_left_type (q) <= mp_explicit) {
+ mp_print (mp, "..control?"); /* can't happen */
+@.control?@>
+} else if ((!number_equal(p->right_tension, unity_t)) || (!number_equal(q->left_tension, unity_t))) {
+ @<Print tension between |p| and |q|@>;
+}
+
+@ Since |n_sin_cos| produces |fraction| results, which we will print as if they
+were |scaled|, the magnitude of a |given| direction vector will be~4096.
+
+@<Print two dots...@>=
+{
+ mp_number n_sin, n_cos;
+ new_fraction (n_sin);
+ new_fraction (n_cos);
+ mp_print_nl (mp, " ..");
+ if (mp_left_type (p) == mp_given) {
+ n_sin_cos (p->left_given, n_cos, n_sin);
+ mp_print_char (mp, xord ('{'));
+ print_number (n_cos);
+ mp_print_char (mp, xord (','));
+ print_number (n_sin);
+ mp_print_char (mp, xord ('}'));
+ } else if (mp_left_type (p) == mp_curl) {
+ mp_print (mp, "{curl ");
+ print_number (p->left_curl);
+ mp_print_char (mp, xord ('}'));
+ }
+ free_number (n_sin);
+ free_number (n_cos);
+}
+
+
+@ @<Print tension between |p| and |q|@>=
+{
+ mp_number v1;
+ new_number (v1);
+ mp_print (mp, "..tension ");
+ if (number_negative(p->right_tension))
+ mp_print (mp, "atleast");
+ number_clone (v1, p->right_tension);
+ number_abs (v1);
+ print_number (v1);
+ if (!number_equal(p->right_tension, q->left_tension)) {
+ mp_print (mp, " and ");
+ if (number_negative(q->left_tension))
+ mp_print (mp, "atleast");
+ number_clone (v1, p->left_tension);
+ number_abs (v1);
+ print_number (v1);
+ }
+ free_number (v1);
+}
+
+
+@ @<Print control points between |p| and |q|, then |goto done1|@>=
+{
+ mp_print (mp, "..controls ");
+ mp_print_two (mp, p->right_x, p->right_y);
+ mp_print (mp, " and ");
+ if (mp_left_type (q) != mp_explicit) {
+ mp_print (mp, "??"); /* can't happen */
+@.??@>
+ } else {
+ mp_print_two (mp, q->left_x, q->left_y);
+ }
+ goto DONE1;
+}
+
+
+@ @<Print information for a curve that begins |open|@>=
+if ((mp_left_type (p) != mp_explicit) && (mp_left_type (p) != mp_open)) {
+ mp_print (mp, "{open?}"); /* can't happen */
+@.open?@>
+}
+
+@ A curl of 1 is shown explicitly, so that the user sees clearly that
+\MP's default curl is present.
+
+@<Print information for a curve that begins |curl|...@>=
+{
+ if (mp_left_type (p) == mp_open)
+ mp_print (mp, "??"); /* can't happen */
+@.??@>;
+ if (mp_right_type (p) == mp_curl) {
+ mp_print (mp, "{curl ");
+ print_number (p->right_curl);
+ } else {
+ mp_number n_sin, n_cos;
+ new_fraction (n_sin);
+ new_fraction (n_cos);
+ n_sin_cos (p->right_given, n_cos, n_sin);
+ mp_print_char (mp, xord ('{'));
+ print_number (n_cos);
+ mp_print_char (mp, xord (','));
+ print_number (n_sin);
+ free_number (n_sin);
+ free_number (n_cos);
+ }
+ mp_print_char (mp, xord ('}'));
+}
+
+
+@ It is convenient to have another version of |pr_path| that prints the path
+as a diagnostic message.
+
+@<Declarations@>=
+static void mp_print_path (MP mp, mp_knot h, const char *s, boolean nuline);
+
+@ @c
+void mp_print_path (MP mp, mp_knot h, const char *s, boolean nuline) {
+ mp_print_diagnostic (mp, "Path", s, nuline);
+ mp_print_ln (mp);
+@.Path at line...@>;
+ mp_pr_path (mp, h);
+ mp_end_diagnostic (mp, true);
+}
+
+
+@ @<Declarations@>=
+static mp_knot mp_new_knot (MP mp);
+
+@ @c
+static mp_knot mp_new_knot (MP mp) {
+ mp_knot q;
+ if (mp->knot_nodes) {
+ q = mp->knot_nodes;
+ mp->knot_nodes = q->next;
+ mp->num_knot_nodes--;
+ } else {
+ q = mp_xmalloc (mp, 1, sizeof (struct mp_knot_data));
+ }
+ memset(q,0,sizeof (struct mp_knot_data));
+ new_number(q->x_coord);
+ new_number(q->y_coord);
+ new_number(q->left_x);
+ new_number(q->left_y);
+ new_number(q->right_x);
+ new_number(q->right_y);
+ return q;
+}
+
+
+@ @<Declarations@>=
+static mp_gr_knot mp_gr_new_knot (MP mp);
+
+@ @c
+static mp_gr_knot mp_gr_new_knot (MP mp) {
+ mp_gr_knot q = mp_xmalloc (mp, 1, sizeof (struct mp_gr_knot_data));
+ return q;
+}
+
+
+@ If we want to duplicate a knot node, we can say |copy_knot|:
+
+@c
+static mp_knot mp_copy_knot (MP mp, mp_knot p) {
+ mp_knot q;
+ if (mp->knot_nodes) {
+ q = mp->knot_nodes;
+ mp->knot_nodes = q->next;
+ mp->num_knot_nodes--;
+ } else {
+ q = mp_xmalloc (mp, 1, sizeof (struct mp_knot_data));
+ }
+ memcpy (q, p, sizeof (struct mp_knot_data));
+ if (mp->math_mode > mp_math_double_mode) {
+ new_number(q->x_coord);
+ new_number(q->y_coord);
+ new_number(q->left_x);
+ new_number(q->left_y);
+ new_number(q->right_x);
+ new_number(q->right_y);
+ number_clone(q->x_coord, p->x_coord);
+ number_clone(q->y_coord, p->y_coord);
+ number_clone(q->left_x, p->left_x);
+ number_clone(q->left_y, p->left_y);
+ number_clone(q->right_x, p->right_x);
+ number_clone(q->right_y, p->right_y);
+ }
+ mp_next_knot (q) = NULL;
+ return q;
+}
+
+@ If we want to export a knot node, we can say |export_knot|:
+
+@c
+static mp_gr_knot mp_export_knot (MP mp, mp_knot p) {
+ mp_gr_knot q; /* the copy */
+ q = mp_gr_new_knot (mp);
+ q->x_coord = number_to_double(p->x_coord);
+ q->y_coord = number_to_double(p->y_coord);
+ q->left_x = number_to_double(p->left_x);
+ q->left_y = number_to_double(p->left_y);
+ q->right_x = number_to_double(p->right_x);
+ q->right_y = number_to_double(p->right_y);
+ q->data.types.left_type = mp_left_type(p);
+ q->data.types.right_type = mp_left_type(p);
+ q->data.info = mp_knot_info(p);
+ mp_gr_next_knot (q) = NULL;
+ return q;
+}
+
+
+@ The |copy_path| routine makes a clone of a given path.
+
+@c
+static mp_knot mp_copy_path (MP mp, mp_knot p) {
+ mp_knot q, pp, qq; /* for list manipulation */
+ if (p == NULL)
+ return NULL;
+ q = mp_copy_knot (mp, p);
+ qq = q;
+ pp = mp_next_knot (p);
+ while (pp != p) {
+ mp_next_knot (qq) = mp_copy_knot (mp, pp);
+ qq = mp_next_knot (qq);
+ pp = mp_next_knot (pp);
+ }
+ mp_next_knot (qq) = q;
+ return q;
+}
+
+@ The |export_path| routine makes a clone of a given path
+and converts the |value|s therein to |double|s.
+
+@c
+static mp_gr_knot mp_export_path (MP mp, mp_knot p) {
+ mp_knot pp; /* for list manipulation */
+ mp_gr_knot q, qq;
+ if (p == NULL)
+ return NULL;
+ q = mp_export_knot (mp, p);
+ qq = q;
+ pp = mp_next_knot (p);
+ while (pp != p) {
+ mp_gr_next_knot (qq) = mp_export_knot (mp, pp);
+ qq = mp_gr_next_knot (qq);
+ pp = mp_next_knot (pp);
+ }
+ mp_gr_next_knot (qq) = q;
+ return q;
+}
+
+@ If we want to import a knot node, we can say |import_knot|:
+
+@c
+static mp_knot mp_import_knot (MP mp, mp_gr_knot p) {
+ mp_knot q; /* the copy */
+ q = mp_new_knot (mp);
+ set_number_from_double(q->x_coord, p->x_coord);
+ set_number_from_double(q->y_coord, p->y_coord);
+ set_number_from_double(q->left_x, p->left_x);
+ set_number_from_double(q->left_y, p->left_y);
+ set_number_from_double(q->right_x, p->right_x);
+ set_number_from_double(q->right_y, p->right_y);
+ mp_left_type(q) = p->data.types.left_type;
+ mp_left_type(q) = p->data.types.right_type;
+ mp_knot_info(q) = p->data.info;
+ mp_next_knot (q) = NULL;
+ return q;
+}
+
+
+@ The |import_path| routine makes a clone of a given path
+and converts the |value|s therein to |scaled|s.
+
+@c
+static mp_knot mp_import_path (MP mp, mp_gr_knot p) {
+ mp_gr_knot pp; /* for list manipulation */
+ mp_knot q, qq;
+ if (p == NULL)
+ return NULL;
+ q = mp_import_knot (mp, p);
+ qq = q;
+ pp = mp_gr_next_knot (p);
+ while (pp != p) {
+ mp_next_knot (qq) = mp_import_knot (mp, pp);
+ qq = mp_next_knot (qq);
+ pp = mp_gr_next_knot (pp);
+ }
+ mp_next_knot (qq) = q;
+ return q;
+}
+
+
+@ Just before |ship_out|, knot lists are exported for printing.
+
+@ The |export_knot_list| routine therefore also makes a clone
+of a given path.
+
+@c
+static mp_gr_knot mp_export_knot_list (MP mp, mp_knot p) {
+ mp_gr_knot q; /* the exported copy */
+ if (p == NULL)
+ return NULL;
+ q = mp_export_path (mp, p);
+ return q;
+}
+static mp_knot mp_import_knot_list (MP mp, mp_gr_knot q) {
+ mp_knot p; /* the imported copy */
+ if (q == NULL)
+ return NULL;
+ p = mp_import_path (mp, q);
+ return p;
+}
+
+@ Similarly, there's a way to copy the {\sl reverse\/} of a path. This procedure
+returns a pointer to the first node of the copy, if the path is a cycle,
+but to the final node of a non-cyclic copy. The global
+variable |path_tail| will point to the final node of the original path;
+this trick makes it easier to implement `\&{doublepath}'.
+
+All node types are assumed to be |endpoint| or |explicit| only.
+
+@c
+static mp_knot mp_htap_ypoc (MP mp, mp_knot p) {
+ mp_knot q, pp, qq, rr; /* for list manipulation */
+ q = mp_new_knot (mp); /* this will correspond to |p| */
+ qq = q;
+ pp = p;
+ while (1) {
+ mp_right_type (qq) = mp_left_type (pp);
+ mp_left_type (qq) = mp_right_type (pp);
+ number_clone (qq->x_coord, pp->x_coord);
+ number_clone (qq->y_coord, pp->y_coord);
+ number_clone (qq->right_x, pp->left_x);
+ number_clone (qq->right_y, pp->left_y);
+ number_clone (qq->left_x, pp->right_x);
+ number_clone (qq->left_y, pp->right_y);
+ mp_originator (qq) = mp_originator (pp);
+ if (mp_next_knot (pp) == p) {
+ mp_next_knot (q) = qq;
+ mp->path_tail = pp;
+ return q;
+ }
+ rr = mp_new_knot (mp);
+ mp_next_knot (rr) = qq;
+ qq = rr;
+ pp = mp_next_knot (pp);
+ }
+}
+
+
+@ @<Glob...@>=
+mp_knot path_tail; /* the node that links to the beginning of a path */
+
+@ When a cyclic list of knot nodes is no longer needed, it can be recycled by
+calling the following subroutine.
+
+@<Declarations@>=
+static void mp_toss_knot_list (MP mp, mp_knot p);
+static void mp_toss_knot (MP mp, mp_knot p);
+static void mp_free_knot (MP mp, mp_knot p);
+
+@ @c
+void mp_free_knot (MP mp, mp_knot q) {
+ free_number (q->x_coord);
+ free_number (q->y_coord);
+ free_number (q->left_x);
+ free_number (q->left_y);
+ free_number (q->right_x);
+ free_number (q->right_y);
+ mp_xfree (q);
+}
+void mp_toss_knot (MP mp, mp_knot q) {
+ if (mp->num_knot_nodes < max_num_knot_nodes) {
+ q->next = mp->knot_nodes;
+ mp->knot_nodes = q;
+ mp->num_knot_nodes++;
+ return;
+ }
+ if (mp->math_mode > mp_math_double_mode) {
+ mp_free_knot(mp,q);
+ } else {
+ mp_xfree (q);
+ }
+}
+void mp_toss_knot_list (MP mp, mp_knot p) {
+ mp_knot q; /* the node being freed */
+ mp_knot r; /* the next node */
+ if (p == NULL)
+ return;
+ q = p;
+ if (mp->math_mode > mp_math_double_mode) {
+ do {
+ r = mp_next_knot (q);
+ mp_toss_knot(mp, q);
+ q = r;
+ } while (q != p);
+ } else {
+ do {
+ r = mp_next_knot (q);
+ if (mp->num_knot_nodes < max_num_knot_nodes) {
+ q->next = mp->knot_nodes;
+ mp->knot_nodes = q;
+ mp->num_knot_nodes++;
+ } else {
+ mp_xfree (q);
+ }
+ q = r;
+ } while (q != p);
+ }
+}
+
+
+@* 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 |mp_left_type| and |mp_right_type| aren't both open).
+
+@c
+void mp_make_choices (MP mp, mp_knot knots) {
+ mp_knot h; /* the first breakpoint */
+ mp_knot p, q; /* consecutive breakpoints being processed */
+ @<Other local variables for |make_choices|@>;
+ FUNCTION_TRACE1 ("make_choices()\n");
+ check_arith(); /* make sure that |arith_error=false| */
+ if (number_positive(internal_value (mp_tracing_choices)))
+ mp_print_path (mp, knots, ", before choices", true);
+ @<If consecutive knots are equal, join them explicitly@>;
+ @<Find the first breakpoint, |h|, on the path;
+ insert an artificial breakpoint if the path is an unbroken cycle@>;
+ p = h;
+ do {
+ @<Fill in the control points between |p| and the next breakpoint,
+ then advance |p| to that breakpoint@>;
+ } while (p != h);
+ if (number_positive(internal_value (mp_tracing_choices)))
+ mp_print_path (mp, knots, ", after choices", true);
+ if (mp->arith_error) {
+ @<Report an unexpected problem during the choice-making@>;
+ }
+}
+
+@ @<Internal ...@>=
+void mp_make_choices (MP mp, mp_knot knots);
+
+@ @<Report an unexpected problem during the choice...@>=
+{
+ const char *hlp[] = {
+ "The path that I just computed is out of range.",
+ "So it will probably look funny. Proceed, for a laugh.",
+ NULL };
+ mp_back_error (mp, "Some number got too big", hlp, true);
+@.Some number got too big@>;
+ mp_get_x_next (mp);
+ mp->arith_error = false;
+}
+
+
+@ Two knots in a row with the same coordinates will always be joined
+by an explicit ``curve'' whose control points are identical with the
+knots.
+
+@<If consecutive knots are equal, join them explicitly@>=
+p = knots;
+do {
+ q = mp_next_knot (p);
+ if (number_equal (p->x_coord, q->x_coord) &&
+ number_equal (p->y_coord, q->y_coord) &&
+ mp_right_type (p) > mp_explicit) {
+ mp_right_type (p) = mp_explicit;
+ if (mp_left_type (p) == mp_open) {
+ mp_left_type (p) = mp_curl;
+ set_number_to_unity(p->left_curl);
+ }
+ mp_left_type (q) = mp_explicit;
+ if (mp_right_type (q) == mp_open) {
+ mp_right_type (q) = mp_curl;
+ set_number_to_unity(q->right_curl);
+ }
+ number_clone (p->right_x, p->x_coord);
+ number_clone (q->left_x, p->x_coord);
+ number_clone (p->right_y, p->y_coord);
+ number_clone (q->left_y, p->y_coord);
+ }
+ p = q;
+} while (p != knots)
+
+@ If there are no breakpoints, it is necessary to compute the direction
+angles around an entire cycle. In this case the |mp_left_type| of the first
+node is temporarily changed to |end_cycle|.
+
+@<Find the first breakpoint, |h|, on the path...@>=
+h = knots;
+while (1) {
+ if (mp_left_type (h) != mp_open)
+ break;
+ if (mp_right_type (h) != mp_open)
+ break;
+ h = mp_next_knot (h);
+ if (h == knots) {
+ mp_left_type (h) = mp_end_cycle;
+ break;
+ }
+}
+
+
+@ If |mp_right_type(p)<given| and |q=mp_link(p)|, we must have
+|mp_right_type(p)=mp_left_type(q)=mp_explicit| or |endpoint|.
+
+@<Fill in the control points between |p| and the next breakpoint...@>=
+q = mp_next_knot (p);
+if (mp_right_type (p) >= mp_given) {
+ while ((mp_left_type (q) == mp_open) && (mp_right_type (q) == mp_open)) {
+ q = mp_next_knot (q);
+ }
+ @<Fill in the control information between consecutive breakpoints |p| and |q|@>;
+} else if (mp_right_type (p) == mp_endpoint) {
+ @<Give reasonable values for the unused control points between |p| and~|q|@>;
+}
+p = q
+
+@ This step makes it possible to transform an explicitly computed path without
+checking the |mp_left_type| and |mp_right_type| fields.
+
+@<Give reasonable values for the unused control points between |p| and~|q|@>=
+{
+ number_clone (p->right_x, p->x_coord);
+ number_clone (p->right_y, p->y_coord);
+ number_clone (q->left_x, q->x_coord);
+ number_clone (q->left_y, q->y_coord);
+}
+
+
+@ Before we can go further into the way choices are made, we need to
+consider the underlying theory. The basic ideas implemented in |make_choices|
+are due to John Hobby, who introduced the notion of ``mock curvature''
+@^Hobby, John Douglas@>
+at a knot. Angles are chosen so that they preserve mock curvature when
+a knot is passed, and this has been found to produce excellent results.
+
+It is convenient to introduce some notations that simplify the necessary
+formulas. Let $d_{k,k+1}=\vert z\k-z_k\vert$ be the (nonzero) distance
+between knots |k| and |k+1|; and let
+$${z\k-z_k\over z_k-z_{k-1}}={d_{k,k+1}\over d_{k-1,k}}e^{i\psi_k}$$
+so that a polygonal line from $z_{k-1}$ to $z_k$ to $z\k$ turns left
+through an angle of~$\psi_k$. We assume that $\vert\psi_k\vert\L180^\circ$.
+The control points for the spline from $z_k$ to $z\k$ will be denoted by
+$$\eqalign{z_k^+&=z_k+
+ \textstyle{1\over3}\rho_k e^{i\theta_k}(z\k-z_k),\cr
+ z\k^-&=z\k-
+ \textstyle{1\over3}\sigma\k e^{-i\phi\k}(z\k-z_k),\cr}$$
+where $\rho_k$ and $\sigma\k$ are nonnegative ``velocity ratios'' at the
+beginning and end of the curve, while $\theta_k$ and $\phi\k$ are the
+corresponding ``offset angles.'' These angles satisfy the condition
+$$\theta_k+\phi_k+\psi_k=0,\eqno(*)$$
+whenever the curve leaves an intermediate knot~|k| in the direction that
+it enters.
+
+@ Let $\alpha_k$ and $\beta\k$ be the reciprocals of the ``tension'' of
+the curve at its beginning and ending points. This means that
+$\rho_k=\alpha_k f(\theta_k,\phi\k)$ and $\sigma\k=\beta\k f(\phi\k,\theta_k)$,
+where $f(\theta,\phi)$ is \MP's standard velocity function defined in
+the |velocity| subroutine. The cubic spline $B(z_k^{\phantom+},z_k^+,
+z\k^-,z\k^{\phantom+};t)$
+has curvature
+@^curvature@>
+$${2\sigma\k\sin(\theta_k+\phi\k)-6\sin\theta_k\over\rho_k^2d_{k,k+1}}
+\qquad{\rm and}\qquad
+{2\rho_k\sin(\theta_k+\phi\k)-6\sin\phi\k\over\sigma\k^2d_{k,k+1}}$$
+at |t=0| and |t=1|, respectively. The mock curvature is the linear
+@^mock curvature@>
+approximation to this true curvature that arises in the limit for
+small $\theta_k$ and~$\phi\k$, if second-order terms are discarded.
+The standard velocity function satisfies
+$$f(\theta,\phi)=1+O(\theta^2+\theta\phi+\phi^2);$$
+hence the mock curvatures are respectively
+$${2\beta\k(\theta_k+\phi\k)-6\theta_k\over\alpha_k^2d_{k,k+1}}
+\qquad{\rm and}\qquad
+{2\alpha_k(\theta_k+\phi\k)-6\phi\k\over\beta\k^2d_{k,k+1}}.\eqno(**)$$
+
+@ The turning angles $\psi_k$ are given, and equation $(*)$ above
+determines $\phi_k$ when $\theta_k$ is known, so the task of
+angle selection is essentially to choose appropriate values for each
+$\theta_k$. When equation~$(*)$ is used to eliminate $\phi$~variables
+from $(**)$, we obtain a system of linear equations of the form
+$$A_k\theta_{k-1}+(B_k+C_k)\theta_k+D_k\theta\k=-B_k\psi_k-D_k\psi\k,$$
+where
+$$A_k={\alpha_{k-1}\over\beta_k^2d_{k-1,k}},
+\qquad B_k={3-\alpha_{k-1}\over\beta_k^2d_{k-1,k}},
+\qquad C_k={3-\beta\k\over\alpha_k^2d_{k,k+1}},
+\qquad D_k={\beta\k\over\alpha_k^2d_{k,k+1}}.$$
+The tensions are always $3\over4$ or more, hence each $\alpha$ and~$\beta$
+will be at most $4\over3$. It follows that $B_k\G{5\over4}A_k$ and
+$C_k\G{5\over4}D_k$; hence the equations are diagonally dominant;
+hence they have a unique solution. Moreover, in most cases the tensions
+are equal to~1, so that $B_k=2A_k$ and $C_k=2D_k$. This makes the
+solution numerically stable, and there is an exponential damping
+effect: The data at knot $k\pm j$ affects the angle at knot~$k$ by
+a factor of~$O(2^{-j})$.
+
+@ However, we still must consider the angles at the starting and ending
+knots of a non-cyclic path. These angles might be given explicitly, or
+they might be specified implicitly in terms of an amount of ``curl.''
+
+Let's assume that angles need to be determined for a non-cyclic path
+starting at $z_0$ and ending at~$z_n$. Then equations of the form
+$$A_k\theta_{k-1}+(B_k+C_k)\theta_k+D_k\theta_{k+1}=R_k$$
+have been given for $0<k<n$, and it will be convenient to introduce
+equations of the same form for $k=0$ and $k=n$, where
+$$A_0=B_0=C_n=D_n=0.$$
+If $\theta_0$ is supposed to have a given value $E_0$, we simply
+define $C_0=1$, $D_0=0$, and $R_0=E_0$. Otherwise a curl
+parameter, $\gamma_0$, has been specified at~$z_0$; this means
+that the mock curvature at $z_0$ should be $\gamma_0$ times the
+mock curvature at $z_1$; i.e.,
+$${2\beta_1(\theta_0+\phi_1)-6\theta_0\over\alpha_0^2d_{01}}
+=\gamma_0{2\alpha_0(\theta_0+\phi_1)-6\phi_1\over\beta_1^2d_{01}}.$$
+This equation simplifies to
+$$(\alpha_0\chi_0+3-\beta_1)\theta_0+
+ \bigl((3-\alpha_0)\chi_0+\beta_1\bigr)\theta_1=
+ -\bigl((3-\alpha_0)\chi_0+\beta_1\bigr)\psi_1,$$
+where $\chi_0=\alpha_0^2\gamma_0/\beta_1^2$; so we can set $C_0=
+\chi_0\alpha_0+3-\beta_1$, $D_0=(3-\alpha_0)\chi_0+\beta_1$, $R_0=-D_0\psi_1$.
+It can be shown that $C_0>0$ and $C_0B_1-A_1D_0>0$ when $\gamma_0\G0$,
+hence the linear equations remain nonsingular.
+
+Similar considerations apply at the right end, when the final angle $\phi_n$
+may or may not need to be determined. It is convenient to let $\psi_n=0$,
+hence $\theta_n=-\phi_n$. We either have an explicit equation $\theta_n=E_n$,
+or we have
+$$\bigl((3-\beta_n)\chi_n+\alpha_{n-1}\bigr)\theta_{n-1}+
+(\beta_n\chi_n+3-\alpha_{n-1})\theta_n=0,\qquad
+ \chi_n={\beta_n^2\gamma_n\over\alpha_{n-1}^2}.$$
+
+When |make_choices| chooses angles, it must compute the coefficients of
+these linear equations, then solve the equations. To compute the coefficients,
+it is necessary to compute arctangents of the given turning angles~$\psi_k$.
+When the equations are solved, the chosen directions $\theta_k$ are put
+back into the form of control points by essentially computing sines and
+cosines.
+
+@ OK, we are ready to make the hard choices of |make_choices|.
+Most of the work is relegated to an auxiliary procedure
+called |solve_choices|, which has been introduced to keep
+|make_choices| from being extremely long.
+
+@<Fill in the control information between...@>=
+@<Calculate the turning angles $\psi_k$ and the distances $d_{k,k+1}$;
+ set $n$ to the length of the path@>;
+@<Remove |open| types at the breakpoints@>;
+mp_solve_choices (mp, p, q, n)
+
+
+@ It's convenient to precompute quantities that will be needed several
+times later. The values of |delta_x[k]| and |delta_y[k]| will be the
+coordinates of $z\k-z_k$, and the magnitude of this vector will be
+|delta[k]=@t$d_{k,k+1}$@>|. The path angle $\psi_k$ between $z_k-z_{k-1}$
+and $z\k-z_k$ will be stored in |psi[k]|.
+
+@<Glob...@>=
+int path_size; /* maximum number of knots between breakpoints of a path */
+mp_number *delta_x;
+mp_number *delta_y;
+mp_number *delta; /* knot differences */
+mp_number *psi; /* turning angles */
+
+@ @<Dealloc variables@>=
+{
+ int k;
+ for (k = 0; k<mp->path_size; k++) {
+ free_number (mp->delta_x[k]);
+ free_number (mp->delta_y[k]);
+ free_number (mp->delta[k]);
+ free_number (mp->psi[k]);
+ }
+ xfree (mp->delta_x);
+ xfree (mp->delta_y);
+ xfree (mp->delta);
+ xfree (mp->psi);
+}
+
+@ @<Other local variables for |make_choices|@>=
+int k, n; /* current and final knot numbers */
+mp_knot s, t; /* registers for list traversal */
+
+@ @<Calculate the turning angles...@>=
+{
+ mp_number sine, cosine; /* trig functions of various angles */
+ new_fraction (sine);
+ new_fraction (cosine);
+RESTART:
+ k = 0;
+ s = p;
+ n = mp->path_size;
+ do {
+ t = mp_next_knot (s);
+ set_number_from_substraction(mp->delta_x[k], t->x_coord, s->x_coord);
+ set_number_from_substraction(mp->delta_y[k], t->y_coord, s->y_coord);
+ pyth_add (mp->delta[k], mp->delta_x[k], mp->delta_y[k]);
+ if (k > 0) {
+ mp_number arg1, arg2, r1, r2;
+ new_number (arg1);
+ new_number (arg2);
+ new_fraction (r1);
+ new_fraction (r2);
+ make_fraction (r1, mp->delta_y[k - 1], mp->delta[k - 1]);
+ number_clone (sine, r1);
+ make_fraction (r2, mp->delta_x[k - 1], mp->delta[k - 1]);
+ number_clone (cosine, r2);
+ take_fraction (r1, mp->delta_x[k], cosine);
+ take_fraction (r2, mp->delta_y[k], sine);
+ set_number_from_addition (arg1, r1, r2);
+ take_fraction (r1, mp->delta_y[k], cosine);
+ take_fraction (r2, mp->delta_x[k], sine);
+ set_number_from_substraction (arg2, r1, r2);
+ n_arg (mp->psi[k], arg1, arg2 );
+ free_number (r1);
+ free_number (r2);
+ free_number (arg1);
+ free_number (arg2);
+ }
+ incr (k);
+ s = t;
+ if (k == mp->path_size) {
+ mp_reallocate_paths (mp, mp->path_size + (mp->path_size / 4));
+ goto RESTART; /* retry, loop size has changed */
+ }
+ if (s == q)
+ n = k;
+ } while (!((k >= n) && (mp_left_type (s) != mp_end_cycle)));
+ if (k == n)
+ set_number_to_zero(mp->psi[k]);
+ else
+ number_clone(mp->psi[k], mp->psi[1]);
+ free_number (sine);
+ free_number (cosine);
+}
+
+
+@ When we get to this point of the code, |mp_right_type(p)| is either
+|given| or |curl| or |open|. If it is |open|, we must have
+|mp_left_type(p)=mp_end_cycle| or |mp_left_type(p)=mp_explicit|. In the latter
+case, the |open| type is converted to |given|; however, if the
+velocity coming into this knot is zero, the |open| type is
+converted to a |curl|, since we don't know the incoming direction.
+
+Similarly, |mp_left_type(q)| is either |given| or |curl| or |open| or
+|mp_end_cycle|. The |open| possibility is reduced either to |given| or to |curl|.
+
+@<Remove |open| types at the breakpoints@>=
+{
+ mp_number delx, dely; /* directions where |open| meets |explicit| */
+ new_number(delx);
+ new_number(dely);
+ if (mp_left_type (q) == mp_open) {
+ set_number_from_substraction(delx, q->right_x, q->x_coord);
+ set_number_from_substraction(dely, q->right_y, q->y_coord);
+ if (number_zero(delx) && number_zero(dely)) {
+ mp_left_type (q) = mp_curl;
+ set_number_to_unity(q->left_curl);
+ } else {
+ mp_left_type (q) = mp_given;
+ n_arg (q->left_given, delx, dely);
+ }
+ }
+ if ((mp_right_type (p) == mp_open) && (mp_left_type (p) == mp_explicit)) {
+ set_number_from_substraction(delx, p->x_coord, p->left_x);
+ set_number_from_substraction(dely, p->y_coord, p->left_y);
+ if (number_zero(delx) && number_zero(dely)) {
+ mp_right_type (p) = mp_curl;
+ set_number_to_unity(p->right_curl);
+ } else {
+ mp_right_type (p) = mp_given;
+ n_arg (p->right_given, delx, dely);
+ }
+ }
+ free_number (delx);
+ free_number (dely);
+}
+
+@ Linear equations need to be solved whenever |n>1|; and also when |n=1|
+and exactly one of the breakpoints involves a curl. The simplest case occurs
+when |n=1| and there is a curl at both breakpoints; then we simply draw
+a straight line.
+
+But before coding up the simple cases, we might as well face the general case,
+since we must deal with it sooner or later, and since the general case
+is likely to give some insight into the way simple cases can be handled best.
+
+When there is no cycle, the linear equations to be solved form a tridiagonal
+system, and we can apply the standard technique of Gaussian elimination
+to convert that system to a sequence of equations of the form
+$$\theta_0+u_0\theta_1=v_0,\quad
+\theta_1+u_1\theta_2=v_1,\quad\ldots,\quad
+\theta_{n-1}+u_{n-1}\theta_n=v_{n-1},\quad
+\theta_n=v_n.$$
+It is possible to do this diagonalization while generating the equations.
+Once $\theta_n$ is known, it is easy to determine $\theta_{n-1}$, \dots,
+$\theta_1$, $\theta_0$; thus, the equations will be solved.
+
+The procedure is slightly more complex when there is a cycle, but the
+basic idea will be nearly the same. In the cyclic case the right-hand
+sides will be $v_k+w_k\theta_0$ instead of simply $v_k$, and we will start
+the process off with $u_0=v_0=0$, $w_0=1$. The final equation will be not
+$\theta_n=v_n$ but $\theta_n+u_n\theta_1=v_n+w_n\theta_0$; an appropriate
+ending routine will take account of the fact that $\theta_n=\theta_0$ and
+eliminate the $w$'s from the system, after which the solution can be
+obtained as before.
+
+When $u_k$, $v_k$, and $w_k$ are being computed, the three pointer
+variables |r|, |s|,~|t| will point respectively to knots |k-1|, |k|,
+and~|k+1|. The $u$'s and $w$'s are scaled by $2^{28}$, i.e., they are
+of type |fraction|; the $\theta$'s and $v$'s are of type |angle|.
+
+@<Glob...@>=
+mp_number *theta; /* values of $\theta_k$ */
+mp_number *uu; /* values of $u_k$ */
+mp_number *vv; /* values of $v_k$ */
+mp_number *ww; /* values of $w_k$ */
+
+@ @<Dealloc variables@>=
+{
+ int k;
+ for (k = 0; k<mp->path_size; k++) {
+ free_number (mp->theta[k]);
+ free_number (mp->uu[k]);
+ free_number (mp->vv[k]);
+ free_number (mp->ww[k]);
+ }
+ xfree (mp->theta);
+ xfree (mp->uu);
+ xfree (mp->vv);
+ xfree (mp->ww);
+}
+
+@ @<Declarations@>=
+static void mp_reallocate_paths (MP mp, int l);
+
+@ @c
+void mp_reallocate_paths (MP mp, int l) {
+ int k;
+ XREALLOC (mp->delta_x, l, mp_number);
+ XREALLOC (mp->delta_y, l, mp_number);
+ XREALLOC (mp->delta, l, mp_number);
+ XREALLOC (mp->psi, l, mp_number);
+ XREALLOC (mp->theta, l, mp_number);
+ XREALLOC (mp->uu, l, mp_number);
+ XREALLOC (mp->vv, l, mp_number);
+ XREALLOC (mp->ww, l, mp_number);
+ for (k = mp->path_size; k<l; k++) {
+ new_number (mp->delta_x[k]);
+ new_number (mp->delta_y[k]);
+ new_number (mp->delta[k]);
+ new_angle (mp->psi[k]);
+ new_angle (mp->theta[k]);
+ new_fraction (mp->uu[k]);
+ new_angle (mp->vv[k]);
+ new_fraction (mp->ww[k]);
+ }
+ mp->path_size = l;
+}
+
+
+@ Our immediate problem is to get the ball rolling by setting up the
+first equation or by realizing that no equations are needed, and to fit
+this initialization into a framework suitable for the overall computation.
+
+@<Declarations@>=
+static void mp_solve_choices (MP mp, mp_knot p, mp_knot q, halfword n);
+
+@ @c
+void mp_solve_choices (MP mp, mp_knot p, mp_knot q, halfword n) {
+ int k; /* current knot number */
+ mp_knot r, s, t; /* registers for list traversal */
+ mp_number ff;
+ new_fraction (ff);
+ FUNCTION_TRACE2 ("solve_choices(%d)\n", n);
+ k = 0;
+ s = p;
+ r = 0;
+ while (1) {
+ t = mp_next_knot (s);
+ if (k == 0) {
+ @<Get the linear equations started; or |return|
+ with the control points in place, if linear equations
+ needn't be solved@>
+ } else {
+ switch (mp_left_type (s)) {
+ case mp_end_cycle:
+ case mp_open:
+ @<Set up equation to match mock curvatures
+ at $z_k$; then |goto found| with $\theta_n$
+ adjusted to equal $\theta_0$, if a cycle has ended@>;
+ break;
+ case mp_curl:
+ @<Set up equation for a curl at $\theta_n$
+ and |goto found|@>;
+ break;
+ case mp_given:
+ @<Calculate the given value of $\theta_n$
+ and |goto found|@>;
+ break;
+ } /* there are no other cases */
+ }
+ r = s;
+ s = t;
+ incr (k);
+ }
+FOUND:
+ @<Finish choosing angles and assigning control points@>;
+ free_number (ff);
+}
+
+
+@ On the first time through the loop, we have |k=0| and |r| is not yet
+defined. The first linear equation, if any, will have $A_0=B_0=0$.
+
+@<Get the linear equations started...@>=
+switch (mp_right_type (s)) {
+case mp_given:
+ if (mp_left_type (t) == mp_given) {
+ @<Reduce to simple case of two givens and |return|@>
+ } else {
+ @<Set up the equation for a given value of $\theta_0$@>;
+ }
+ break;
+case mp_curl:
+ if (mp_left_type (t) == mp_curl) {
+ @<Reduce to simple case of straight line and |return|@>
+ } else {
+ @<Set up the equation for a curl at $\theta_0$@>;
+ }
+ break;
+case mp_open:
+ set_number_to_zero(mp->uu[0]);
+ set_number_to_zero(mp->vv[0]);
+ number_clone(mp->ww[0], fraction_one_t);
+ /* this begins a cycle */
+ break;
+} /* there are no other cases */
+
+
+@ The general equation that specifies equality of mock curvature at $z_k$ is
+$$A_k\theta_{k-1}+(B_k+C_k)\theta_k+D_k\theta\k=-B_k\psi_k-D_k\psi\k,$$
+as derived above. We want to combine this with the already-derived equation
+$\theta_{k-1}+u_{k-1}\theta_k=v_{k-1}+w_{k-1}\theta_0$ in order to obtain
+a new equation
+$\theta_k+u_k\theta\k=v_k+w_k\theta_0$. This can be done by dividing the
+equation
+$$(B_k-u_{k-1}A_k+C_k)\theta_k+D_k\theta\k=-B_k\psi_k-D_k\psi\k-A_kv_{k-1}
+ -A_kw_{k-1}\theta_0$$
+by $B_k-u_{k-1}A_k+C_k$. The trick is to do this carefully with
+fixed-point arithmetic, avoiding the chance of overflow while retaining
+suitable precision.
+
+The calculations will be performed in several registers that
+provide temporary storage for intermediate quantities.
+
+@ @<Set up equation to match mock curvatures...@>=
+{
+ mp_number aa, bb, cc, acc; /* temporary registers */
+ mp_number dd, ee; /* likewise, but |scaled| */
+ new_fraction (aa);
+ new_fraction (bb);
+ new_fraction (cc);
+ new_fraction (acc);
+ new_number (dd);
+ new_number (ee);
+ @<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)$@>;
+ take_fraction (mp->uu[k], ff, bb);
+ @<Calculate the values of $v_k$ and $w_k$@>;
+ if (mp_left_type (s) == mp_end_cycle) {
+ @<Adjust $\theta_n$ to equal $\theta_0$ and |goto found|@>;
+ }
+ free_number(aa);
+ free_number(bb);
+ free_number(cc);
+ free_number(acc);
+ free_number(dd);
+ free_number(ee);
+}
+
+
+@ 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}=...@>=
+{
+ mp_number absval;
+ new_number (absval);
+ number_clone (absval, r->right_tension);
+ number_abs (absval);
+if (number_equal (absval, unity_t)) {
+ number_clone (aa, fraction_half_t);
+ number_clone (dd, mp->delta[k]);
+ number_double (dd);
+} else {
+ mp_number arg1, arg2, ret;
+ new_number (arg2);
+ new_number (arg1);
+ number_clone (arg2, r->right_tension);
+ number_abs (arg2);
+ number_multiply_int (arg2, 3);
+ number_substract (arg2, unity_t);
+ make_fraction (aa, unity_t, arg2);
+ number_clone (arg2, r->right_tension);
+ number_abs (arg2);
+ new_fraction (ret);
+ make_fraction (ret, unity_t, arg2);
+ set_number_from_substraction (arg1, fraction_three_t, ret);
+ take_fraction (arg2, mp->delta[k], arg1);
+ number_clone (dd, arg2);
+ free_number (ret);
+ free_number (arg1);
+ free_number (arg2);
+}
+ number_clone (absval, t->left_tension);
+ number_abs (absval);
+if (number_equal (absval, unity_t)) {
+ number_clone (bb, fraction_half_t);
+ number_clone (ee, mp->delta[k - 1]);
+ number_double (ee);
+} else {
+ mp_number arg1, arg2, ret;
+ new_number (arg1);
+ new_number (arg2);
+ number_clone (arg2, t->left_tension);
+ number_abs (arg2);
+ number_multiply_int (arg2, 3);
+ number_substract (arg2, unity_t);
+ make_fraction (bb, unity_t, arg2);
+ number_clone (arg2, t->left_tension);
+ number_abs (arg2);
+ new_fraction(ret);
+ make_fraction (ret, unity_t, arg2);
+ set_number_from_substraction (arg1,fraction_three_t, ret);
+ take_fraction (ee, mp->delta[k - 1], arg1);
+ free_number (ret);
+ free_number (arg1);
+ free_number (arg2);
+}
+free_number (absval);
+}
+{
+ mp_number r1;
+ new_number (r1);
+ take_fraction (r1, mp->uu[k - 1], aa);
+ set_number_from_substraction (cc, fraction_one_t, r1);
+ free_number (r1);
+}
+
+@ 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)$@>=
+{
+ mp_number rt, lt;
+ mp_number arg2;
+ new_number (arg2);
+ number_clone (arg2, dd);
+ take_fraction (dd, arg2, cc);
+ new_number (lt);
+ new_number (rt);
+ number_clone (lt, s->left_tension);
+ number_abs (lt);
+ number_clone (rt, s->right_tension);
+ number_abs (rt);
+ if (!number_equal(lt, rt)) { /* $\beta_k^{-1}\ne\alpha_k^{-1}$ */
+ mp_number r1;
+ new_number (r1);
+ if (number_less(lt, rt)) {
+ make_fraction (r1, lt, rt); /* $\alpha_k^2/\beta_k^2$ */
+ take_fraction (ff, r1, r1);
+ number_clone (r1, dd);
+ take_fraction (dd, r1, ff);
+ } else {
+ make_fraction (r1, rt, lt); /* $\beta_k^2/\alpha_k^2$ */
+ take_fraction (ff, r1, r1);
+ number_clone (r1, ee);
+ take_fraction (ee, r1, ff);
+ }
+ free_number (r1);
+ }
+ free_number (rt);
+ free_number (lt);
+ set_number_from_addition (arg2, dd, ee);
+ make_fraction (ff, ee, arg2);
+ free_number (arg2);
+}
+
+
+@ 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$@>=
+take_fraction (acc, mp->psi[k + 1], mp->uu[k]);
+number_negate (acc);
+if (mp_right_type (r) == mp_curl) {
+ mp_number r1, arg2;
+ new_fraction (r1);
+ new_number (arg2);
+ set_number_from_substraction (arg2, fraction_one_t, ff);
+ take_fraction (r1, mp->psi[1], arg2);
+ set_number_to_zero(mp->ww[k]);
+ set_number_from_substraction(mp->vv[k], acc, r1);
+ free_number (r1);
+ free_number (arg2);
+} else {
+ mp_number arg1, r1;
+ new_fraction (r1);
+ new_number (arg1);
+ set_number_from_substraction (arg1, fraction_one_t, ff);
+ make_fraction (ff, arg1, cc); /* this is $B_k/(C_k+B_k-u_{k-1}A_k)<5$ */
+ free_number (arg1);
+ take_fraction (r1, mp->psi[k], ff);
+ number_substract (acc, r1);
+ number_clone (r1, ff);
+ take_fraction (ff, r1, aa); /* this is $A_k/(C_k+B_k-u_{k-1}A_k)$ */
+ take_fraction (r1, mp->vv[k - 1], ff);
+ set_number_from_substraction(mp->vv[k], acc, r1 );
+ if (number_zero(mp->ww[k - 1])) {
+ set_number_to_zero(mp->ww[k]);
+ } else {
+ take_fraction (mp->ww[k], mp->ww[k - 1], ff);
+ number_negate(mp->ww[k]);
+ }
+ free_number (r1);
+}
+
+
+@ 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|@>=
+{
+ mp_number arg2, r1;
+ new_number (arg2);
+ new_number (r1);
+ set_number_to_zero (aa);
+ number_clone (bb, fraction_one_t); /* we have |k=n| */
+ do {
+ decr (k);
+ if (k == 0)
+ k = n;
+ take_fraction (r1, aa, mp->uu[k]);
+ set_number_from_substraction (aa, mp->vv[k], r1);
+ take_fraction (r1, bb, mp->uu[k]);
+ set_number_from_substraction (bb, mp->ww[k], r1);
+ } while (k != n); /* now $\theta_n=\\{aa}+\\{bb}\cdot\theta_n$ */
+ set_number_from_substraction (arg2, fraction_one_t, bb);
+ make_fraction (r1, aa, arg2);
+ number_clone (aa, r1);
+ number_clone(mp->theta[n], aa);
+ number_clone(mp->vv[0], aa);
+ for (k = 1; k < n; k++) {
+ take_fraction (r1, aa, mp->ww[k]);
+ number_add(mp->vv[k], r1);
+ }
+ free_number(arg2);
+ free_number(r1);
+ free_number(aa);
+ free_number(bb);
+ free_number(cc);
+ free_number(acc);
+ free_number(dd);
+ free_number(ee);
+ goto FOUND;
+}
+
+
+@ @c
+void mp_reduce_angle (MP mp, mp_number *a) {
+ mp_number abs_a;
+ FUNCTION_TRACE2 ("reduce_angle(%f)\n", number_to_double(*a));
+ new_number(abs_a);
+ number_clone(abs_a, *a);
+ number_abs(abs_a);
+ if ( number_greater(abs_a, one_eighty_deg_t)) {
+ if (number_positive(*a)) {
+ number_substract(*a, three_sixty_deg_t);
+ } else {
+ number_add(*a, three_sixty_deg_t);
+ }
+ }
+ free_number(abs_a);
+}
+
+@ @<Declarations@>=
+void mp_reduce_angle (MP mp, mp_number *a);
+
+
+@ @<Calculate the given value of $\theta_n$...@>=
+{
+ mp_number narg;
+ new_angle (narg);
+ n_arg (narg, mp->delta_x[n - 1], mp->delta_y[n - 1]);
+ set_number_from_substraction(mp->theta[n], s->left_given, narg);
+ free_number (narg);
+ mp_reduce_angle (mp, &mp->theta[n]);
+ goto FOUND;
+}
+
+
+@ @<Set up the equation for a given value of $\theta_0$@>=
+{
+ mp_number narg;
+ new_angle (narg);
+ n_arg (narg, mp->delta_x[0], mp->delta_y[0]);
+ set_number_from_substraction(mp->vv[0], s->right_given, narg);
+ free_number (narg);
+ mp_reduce_angle (mp, &mp->vv[0]);
+ set_number_to_zero(mp->uu[0]);
+ set_number_to_zero(mp->ww[0]);
+}
+
+
+@ @<Set up the equation for a curl at $\theta_0$@>=
+{
+ mp_number lt, rt, cc; /* tension values */
+ new_number (lt);
+ new_number (rt);
+ new_number (cc);
+ number_clone (cc, s->right_curl);
+ number_clone (lt, t->left_tension);
+ number_abs(lt);
+ number_clone (rt, s->right_tension);
+ number_abs(rt);
+ if (number_unity(rt) && number_unity(lt)) {
+ mp_number arg1, arg2;
+ new_number (arg1);
+ new_number (arg2);
+ number_clone (arg1, cc);
+ number_double (arg1);
+ number_add (arg1, unity_t);
+ number_clone (arg2, cc);
+ number_add (arg2, two_t);
+ make_fraction (mp->uu[0], arg1, arg2);
+ free_number (arg1);
+ free_number (arg2);
+ } else {
+ mp_curl_ratio (mp, &mp->uu[0], cc, rt, lt);
+ }
+ take_fraction (mp->vv[0], mp->psi[1], mp->uu[0]);
+ number_negate(mp->vv[0]);
+ set_number_to_zero(mp->ww[0]);
+ free_number (rt);
+ free_number (lt);
+ free_number (cc);
+}
+
+
+@ @<Set up equation for a curl at $\theta_n$...@>=
+{
+ mp_number lt, rt, cc; /* tension values */
+ new_number (lt);
+ new_number (rt);
+ new_number (cc);
+ number_clone (cc, s->left_curl);
+ number_clone (lt, s->left_tension);
+ number_abs(lt);
+ number_clone (rt, r->right_tension);
+ number_abs(rt);
+ if (number_unity(rt) && number_unity(lt)) {
+ mp_number arg1, arg2;
+ new_number (arg1);
+ new_number (arg2);
+ number_clone (arg1, cc);
+ number_double (arg1);
+ number_add (arg1, unity_t);
+ number_clone (arg2, cc);
+ number_add (arg2, two_t);
+ make_fraction (ff, arg1, arg2);
+ free_number (arg1);
+ free_number (arg2);
+ } else {
+ mp_curl_ratio (mp, &ff, cc, lt, rt);
+ }
+ {
+ mp_number arg1, arg2, r1;
+ new_fraction (r1);
+ new_fraction (arg1);
+ new_number (arg2);
+ take_fraction (arg1, mp->vv[n - 1], ff);
+ take_fraction (r1, ff, mp->uu[n - 1]);
+ set_number_from_substraction (arg2, fraction_one_t, r1);
+ make_fraction (mp->theta[n], arg1, arg2);
+ number_negate(mp->theta[n]);
+ free_number (r1);
+ free_number (arg1);
+ free_number (arg2);
+ }
+ free_number (rt);
+ free_number (lt);
+ free_number (cc);
+ goto FOUND;
+}
+
+
+@ The |curl_ratio| subroutine has three arguments, which our previous notation
+encourages us to call $\gamma$, $\alpha^{-1}$, and $\beta^{-1}$. It is
+a somewhat tedious program to calculate
+$${(3-\alpha)\alpha^2\gamma+\beta^3\over
+ \alpha^3\gamma+(3-\beta)\beta^2},$$
+with the result reduced to 4 if it exceeds 4. (This reduction of curl
+is necessary only if the curl and tension are both large.)
+The values of $\alpha$ and $\beta$ will be at most~4/3.
+
+@<Declarations@>=
+static void mp_curl_ratio (MP mp, mp_number *ret, mp_number gamma, mp_number a_tension,
+ mp_number b_tension);
+
+@ @c
+void mp_curl_ratio (MP mp, mp_number *ret, mp_number gamma_orig, mp_number a_tension, mp_number b_tension) {
+ mp_number alpha, beta, gamma, num, denom, ff; /* registers */
+ mp_number arg1;
+ new_number (arg1);
+ new_fraction (alpha);
+ new_fraction (beta);
+ new_fraction (gamma);
+ new_fraction (ff);
+ new_fraction (denom);
+ new_fraction (num);
+ make_fraction (alpha, unity_t, a_tension);
+ make_fraction (beta, unity_t, b_tension);
+ number_clone (gamma, gamma_orig);
+ if (number_lessequal(alpha, beta)) {
+ make_fraction (ff, alpha, beta);
+ number_clone (arg1, ff);
+ take_fraction (ff, arg1, arg1);
+ number_clone (arg1, gamma);
+ take_fraction (gamma, arg1, ff);
+ convert_fraction_to_scaled (beta);
+ take_fraction (denom, gamma, alpha);
+ number_add (denom, three_t);
+ } else {
+ make_fraction (ff, beta, alpha);
+ number_clone (arg1, ff);
+ take_fraction (ff, arg1, arg1);
+ take_fraction (arg1, beta, ff);
+ convert_fraction_to_scaled (arg1);
+ number_clone (beta, arg1);
+ take_fraction (denom, gamma, alpha);
+ set_number_from_div (arg1, ff, twelvebits_3);
+ number_add (denom, arg1);
+ }
+ number_substract (denom, beta);
+ set_number_from_substraction (arg1, fraction_three_t, alpha);
+ take_fraction (num, gamma, arg1);
+ number_add (num, beta);
+ number_clone (arg1, denom);
+ number_double (arg1);
+ number_double (arg1); /* arg1 = 4*denom */
+ if (number_greaterequal(num, arg1)) {
+ number_clone(*ret, fraction_four_t);
+ } else {
+ make_fraction (*ret, num, denom);
+ }
+ free_number (alpha);
+ free_number (beta);
+ free_number (gamma);
+ free_number (num);
+ free_number (denom);
+ free_number (ff);
+ free_number (arg1);
+}
+
+
+@ We're in the home stretch now.
+
+@<Finish choosing angles and assigning control points@>=
+{
+ mp_number r1;
+ new_number (r1);
+ for (k = n - 1; k >= 0; k--) {
+ take_fraction (r1, mp->theta[k + 1], mp->uu[k]);
+ set_number_from_substraction(mp->theta[k], mp->vv[k], r1);
+ }
+ free_number (r1);
+}
+s = p;
+k = 0;
+{
+mp_number arg;
+new_number (arg);
+do {
+ t = mp_next_knot (s);
+ n_sin_cos (mp->theta[k], mp->ct, mp->st);
+ number_clone (arg, mp->psi[k + 1]);
+ number_negate (arg);
+ number_substract (arg, mp->theta[k + 1]);
+ n_sin_cos (arg, mp->cf, mp->sf);
+ mp_set_controls (mp, s, t, k);
+ incr (k);
+ s = t;
+} while (k != n);
+free_number (arg);
+}
+
+
+@ 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...@>=
+mp_number st;
+mp_number ct;
+mp_number sf;
+mp_number cf; /* sines and cosines */
+
+@ @<Initialize table...@>=
+new_fraction (mp->st);
+new_fraction (mp->ct);
+new_fraction (mp->sf);
+new_fraction (mp->cf);
+
+@ @<Dealloc ...@>=
+free_number (mp->st);
+free_number (mp->ct);
+free_number (mp->sf);
+free_number (mp->cf);
+
+
+@ @<Declarations@>=
+static void mp_set_controls (MP mp, mp_knot p, mp_knot q, integer k);
+
+@ @c
+void mp_set_controls (MP mp, mp_knot p, mp_knot q, integer k) {
+ mp_number rr, ss; /* velocities, divided by thrice the tension */
+ mp_number lt, rt; /* tensions */
+ mp_number sine; /* $\sin(\theta+\phi)$ */
+ mp_number tmp;
+ mp_number r1, r2;
+ new_number(tmp);
+ new_number (lt);
+ new_number (rt);
+ new_number (r1);
+ new_number (r2);
+ number_clone(lt, q->left_tension);
+ number_abs(lt);
+ number_clone(rt, p->right_tension);
+ number_abs(rt);
+ new_fraction (sine);
+ new_fraction (rr);
+ new_fraction (ss);
+ velocity (rr, mp->st, mp->ct, mp->sf, mp->cf, rt);
+ velocity (ss, mp->sf, mp->cf, mp->st, mp->ct, lt);
+ if (number_negative(p->right_tension) || number_negative(q->left_tension)) {
+ @<Decrease the velocities,
+ if necessary, to stay inside the bounding triangle@>;
+ }
+ take_fraction (r1, mp->delta_x [k], mp->ct);
+ take_fraction (r2, mp->delta_y [k], mp->st);
+ number_substract (r1, r2);
+ take_fraction (tmp, r1, rr);
+ set_number_from_addition (p->right_x, p->x_coord, tmp);
+ take_fraction (r1, mp->delta_y[k], mp->ct);
+ take_fraction (r2, mp->delta_x[k], mp->st);
+ number_add (r1, r2);
+ take_fraction (tmp, r1, rr);
+ set_number_from_addition (p->right_y, p->y_coord, tmp);
+ take_fraction (r1, mp->delta_x[k], mp->cf);
+ take_fraction (r2, mp->delta_y[k], mp->sf);
+ number_add (r1, r2);
+ take_fraction (tmp, r1, ss);
+ set_number_from_substraction (q->left_x, q->x_coord, tmp);
+ take_fraction (r1, mp->delta_y[k], mp->cf);
+ take_fraction (r2, mp->delta_x[k], mp->sf);
+ number_substract (r1, r2);
+ take_fraction (tmp, r1, ss);
+ set_number_from_substraction(q->left_y, q->y_coord, tmp);
+ mp_right_type (p) = mp_explicit;
+ mp_left_type (q) = mp_explicit;
+ free_number (tmp);
+ free_number (r1);
+ free_number (r2);
+ free_number (lt);
+ free_number (rt);
+ free_number (rr);
+ free_number (ss);
+ free_number (sine);
+}
+
+
+@ 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 ((number_nonnegative(mp->st) && number_nonnegative(mp->sf)) || (number_nonpositive(mp->st) && number_nonpositive(mp->sf))) {
+ mp_number r1, r2, arg1;
+ mp_number ab_vs_cd;
+ new_number (ab_vs_cd);
+ new_fraction (r1);
+ new_fraction (r2);
+ new_number (arg1);
+ number_clone (arg1, mp->st);
+ number_abs (arg1);
+ take_fraction (r1, arg1, mp->cf);
+ number_clone (arg1, mp->sf);
+ number_abs (arg1);
+ take_fraction (r2, arg1, mp->ct);
+ set_number_from_addition (sine, r1, r2);
+ if (number_positive(sine)) {
+ set_number_from_addition (arg1, fraction_one_t, unity_t); /* safety factor */
+ number_clone (r1, sine);
+ take_fraction (sine, r1, arg1);
+ if (number_negative(p->right_tension)) {
+ number_clone (arg1, mp->sf);
+ number_abs (arg1);
+ ab_vs_cd (ab_vs_cd, arg1, fraction_one_t, rr, sine);
+ if (number_negative(ab_vs_cd)) {
+ number_clone (arg1, mp->sf);
+ number_abs (arg1);
+ make_fraction (rr, arg1, sine);
+ }
+ }
+ if (number_negative(q->left_tension)) {
+ number_clone (arg1, mp->st);
+ number_abs (arg1);
+ ab_vs_cd (ab_vs_cd, arg1, fraction_one_t, ss, sine);
+ if (number_negative(ab_vs_cd)) {
+ number_clone (arg1, mp->st);
+ number_abs (arg1);
+ make_fraction (ss, arg1, sine);
+ }
+ }
+ }
+ free_number (arg1);
+ free_number (r1);
+ free_number (r2);
+ free_number (ab_vs_cd);
+}
+
+@ Only the simple cases remain to be handled.
+
+@<Reduce to simple case of two givens and |return|@>=
+{
+ mp_number arg1;
+ mp_number narg;
+ new_angle (narg);
+ n_arg (narg, mp->delta_x[0], mp->delta_y[0]);
+ new_number (arg1);
+ set_number_from_substraction (arg1, p->right_given, narg);
+ n_sin_cos (arg1, mp->ct, mp->st);
+ set_number_from_substraction (arg1, q->left_given, narg);
+ n_sin_cos (arg1, mp->cf, mp->sf);
+ number_negate (mp->sf);
+ mp_set_controls (mp, p, q, 0);
+ free_number (narg);
+ free_number (arg1);
+ free_number (ff);
+ return;
+}
+
+
+@ @<Reduce to simple case of straight line and |return|@>=
+{
+ mp_number lt, rt; /* tension values */
+ mp_right_type (p) = mp_explicit;
+ mp_left_type (q) = mp_explicit;
+ new_number (lt);
+ new_number (rt);
+ number_clone (lt, q->left_tension);
+ number_abs(lt);
+ number_clone (rt, p->right_tension);
+ number_abs(rt);
+ if (number_unity(rt)) {
+ mp_number arg2;
+ new_number (arg2);
+ if (number_nonnegative(mp->delta_x[0])) {
+ set_number_from_addition (arg2, mp->delta_x[0], epsilon_t);
+ } else {
+ set_number_from_substraction (arg2, mp->delta_x[0], epsilon_t);
+ }
+ number_int_div (arg2, 3);
+ set_number_from_addition (p->right_x, p->x_coord, arg2);
+ if (number_nonnegative(mp->delta_y[0])) {
+ set_number_from_addition (arg2, mp->delta_y[0], epsilon_t);
+ } else {
+ set_number_from_substraction (arg2, mp->delta_y[0], epsilon_t);
+ }
+ number_int_div (arg2, 3);
+ set_number_from_addition (p->right_y, p->y_coord, arg2);
+ free_number (arg2);
+ } else {
+ mp_number arg2, r1;
+ new_fraction (r1);
+ new_number (arg2);
+ number_clone (arg2, rt);
+ number_multiply_int (arg2, 3);
+ make_fraction (ff, unity_t, arg2); /* $\alpha/3$ */
+ free_number (arg2);
+ take_fraction (r1, mp->delta_x[0], ff);
+ set_number_from_addition (p->right_x, p->x_coord, r1);
+ take_fraction (r1, mp->delta_y[0], ff);
+ set_number_from_addition (p->right_y, p->y_coord, r1);
+ }
+ if (number_unity(lt)) {
+ mp_number arg2;
+ new_number (arg2);
+ if (number_nonnegative(mp->delta_x[0])) {
+ set_number_from_addition (arg2, mp->delta_x[0], epsilon_t);
+ } else {
+ set_number_from_substraction (arg2, mp->delta_x[0], epsilon_t);
+ }
+ number_int_div (arg2, 3);
+ set_number_from_substraction (q->left_x, q->x_coord, arg2);
+ if (number_nonnegative(mp->delta_y[0])) {
+ set_number_from_addition (arg2, mp->delta_y[0], epsilon_t);
+ } else {
+ set_number_from_substraction (arg2, mp->delta_y[0], epsilon_t);
+ }
+ number_int_div (arg2, 3);
+ set_number_from_substraction (q->left_y, q->y_coord, arg2);
+ free_number (arg2);
+ } else {
+ mp_number arg2, r1;
+ new_fraction (r1);
+ new_number (arg2);
+ number_clone (arg2, lt);
+ number_multiply_int (arg2, 3);
+ make_fraction (ff, unity_t, arg2); /* $\beta/3$ */
+ free_number (arg2);
+ take_fraction (r1, mp->delta_x[0], ff);
+ set_number_from_substraction(q->left_x, q->x_coord, r1);
+ take_fraction (r1, mp->delta_y[0], ff);
+ set_number_from_substraction(q->left_y, q->y_coord, r1);
+ free_number (r1);
+ }
+ free_number (ff);
+ free_number (lt);
+ free_number (rt);
+ return;
+}
+
+@ Various subroutines that are useful for the new (1.770) exported
+api for solving path choices
+
+@c
+#define TOO_LARGE(a) (fabs((a))>4096.0)
+#define PI 3.1415926535897932384626433832795028841971
+
+static int out_of_range(MP mp, double a)
+{
+ mp_number t;
+ new_number (t);
+ set_number_from_double(t,fabs(a));
+ if (number_greaterequal(t,inf_t)) {
+ free_number (t);
+ return 1;
+ }
+ free_number (t);
+ return 0;
+}
+
+static int mp_link_knotpair (MP mp, mp_knot p, mp_knot q);
+static int mp_link_knotpair (MP mp, mp_knot p, mp_knot q)
+{
+ if (p==NULL ||q==NULL) return 0;
+ p->next = q;
+ set_number_from_double(p->right_tension, 1.0);
+ if (mp_right_type(p)==mp_endpoint) {
+ mp_right_type(p) = mp_open;
+ }
+ set_number_from_double(q->left_tension, 1.0);
+ if (mp_left_type(q) == mp_endpoint) {
+ mp_left_type(q) = mp_open;
+ }
+ return 1;
+}
+
+int mp_close_path_cycle (MP mp, mp_knot p, mp_knot q)
+{
+ return mp_link_knotpair(mp,p,q);
+}
+
+int mp_close_path (MP mp, mp_knot q, mp_knot first)
+{
+ if (q==NULL || first==NULL) return 0;
+ q->next = first;
+ mp_right_type(q) = mp_endpoint;
+ set_number_from_double(q->right_tension, 1.0);
+ mp_left_type(first) = mp_endpoint;
+ set_number_from_double(first->left_tension, 1.0);
+ return 1;
+}
+
+mp_knot mp_create_knot (MP mp)
+{
+ mp_knot q = mp_new_knot(mp);
+ mp_left_type(q) = mp_endpoint;
+ mp_right_type(q) = mp_endpoint;
+ return q;
+}
+
+int mp_set_knot (MP mp, mp_knot p, double x, double y)
+{
+ if (out_of_range(mp, x)) return 0;
+ if (out_of_range(mp, y)) return 0;
+ if (p==NULL) return 0;
+ set_number_from_double(p->x_coord, x);
+ set_number_from_double(p->y_coord, y);
+ return 1;
+}
+
+mp_knot mp_append_knot (MP mp, mp_knot p, double x, double y)
+{
+ mp_knot q = mp_create_knot(mp);
+ if (q==NULL) return NULL;
+ if (!mp_set_knot(mp, q, x, y)) {
+ free(q);
+ return NULL;
+ }
+ if (p == NULL) return q;
+ if (!mp_link_knotpair(mp, p,q)) {
+ free(q);
+ return NULL;
+ }
+ return q;
+}
+
+int mp_set_knot_curl (MP mp, mp_knot q, double value) {
+ if (q==NULL) return 0;
+ if (TOO_LARGE(value)) return 0;
+ mp_right_type(q)=mp_curl;
+ set_number_from_double(q->right_curl, value);
+ if (mp_left_type(q)==mp_open) {
+ mp_left_type(q)=mp_curl;
+ set_number_from_double(q->left_curl, value);
+ }
+ return 1;
+}
+
+int mp_set_knot_left_curl (MP mp, mp_knot q, double value) {
+ if (q==NULL) return 0;
+ if (TOO_LARGE(value)) return 0;
+ mp_left_type(q)=mp_curl;
+ set_number_from_double(q->left_curl, value);
+ if (mp_right_type(q)==mp_open) {
+ mp_right_type(q)=mp_curl;
+ set_number_from_double(q->right_curl, value);
+ }
+ return 1;
+}
+
+int mp_set_knot_right_curl (MP mp, mp_knot q, double value) {
+ if (q==NULL) return 0;
+ if (TOO_LARGE(value)) return 0;
+ mp_right_type(q)=mp_curl;
+ set_number_from_double(q->right_curl, value);
+ if (mp_left_type(q)==mp_open) {
+ mp_left_type(q)=mp_curl;
+ set_number_from_double(q->left_curl, value);
+ }
+ return 1;
+}
+
+int mp_set_knotpair_curls (MP mp, mp_knot p, mp_knot q, double t1, double t2) {
+ if (p==NULL || q==NULL) return 0;
+ if (mp_set_knot_curl(mp, p, t1))
+ return mp_set_knot_curl(mp, q, t2);
+ return 0;
+}
+
+int mp_set_knotpair_tensions (MP mp, mp_knot p, mp_knot q, double t1, double t2) {
+ if (p==NULL || q==NULL) return 0;
+ if (TOO_LARGE(t1)) return 0;
+ if (TOO_LARGE(t2)) return 0;
+ if ((fabs(t1)<0.75)) return 0;
+ if ((fabs(t2)<0.75)) return 0;
+ set_number_from_double(p->right_tension, t1);
+ set_number_from_double(q->left_tension, t2);
+ return 1;
+}
+
+int mp_set_knot_left_tension (MP mp, mp_knot p, double t1) {
+ if (p==NULL) return 0;
+ if (TOO_LARGE(t1)) return 0;
+ if ((fabs(t1)<0.75)) return 0;
+ set_number_from_double(p->left_tension, t1);
+ return 1;
+}
+
+int mp_set_knot_right_tension (MP mp, mp_knot p, double t1) {
+ if (p==NULL) return 0;
+ if (TOO_LARGE(t1)) return 0;
+ if ((fabs(t1)<0.75)) return 0;
+ set_number_from_double(p->right_tension, t1);
+ return 1;
+}
+
+int mp_set_knotpair_controls (MP mp, mp_knot p, mp_knot q, double x1, double y1, double x2, double y2) {
+ if (p==NULL || q==NULL) return 0;
+ if (out_of_range(mp, x1)) return 0;
+ if (out_of_range(mp, y1)) return 0;
+ if (out_of_range(mp, x2)) return 0;
+ if (out_of_range(mp, y2)) return 0;
+ mp_right_type(p)=mp_explicit;
+ set_number_from_double(p->right_x, x1);
+ set_number_from_double(p->right_y, y1);
+ mp_left_type(q)=mp_explicit;
+ set_number_from_double(q->left_x, x2);
+ set_number_from_double(q->left_y, y2);
+ return 1;
+}
+
+int mp_set_knot_left_control (MP mp, mp_knot p, double x1, double y1) {
+ if (p==NULL) return 0;
+ if (out_of_range(mp, x1)) return 0;
+ if (out_of_range(mp, y1)) return 0;
+ mp_left_type(p)=mp_explicit;
+ set_number_from_double(p->left_x, x1);
+ set_number_from_double(p->left_y, y1);
+ return 1;
+}
+
+int mp_set_knot_right_control (MP mp, mp_knot p, double x1, double y1) {
+ if (p==NULL) return 0;
+ if (out_of_range(mp, x1)) return 0;
+ if (out_of_range(mp, y1)) return 0;
+ mp_right_type(p)=mp_explicit;
+ set_number_from_double(p->right_x, x1);
+ set_number_from_double(p->right_y, y1);
+ return 1;
+}
+
+int mp_set_knot_direction (MP mp, mp_knot q, double x, double y) {
+ double value = 0;
+ if (q==NULL) return 0;
+ if (TOO_LARGE(x)) return 0;
+ if (TOO_LARGE(y)) return 0;
+ if (!(x==0 && y == 0))
+ value = atan2 (y, x) * (180.0 / PI) * 16.0;
+ mp_right_type(q)=mp_given;
+ set_number_from_double(q->right_curl, value);
+ if (mp_left_type(q)==mp_open) {
+ mp_left_type(q)=mp_given;
+ set_number_from_double(q->left_curl, value);
+ }
+ return 1;
+}
+
+int mp_set_knotpair_directions (MP mp, mp_knot p, mp_knot q, double x1, double y1, double x2, double y2) {
+ if (p==NULL || q==NULL) return 0;
+ if (mp_set_knot_direction(mp,p, x1, y1))
+ return mp_set_knot_direction(mp,q, x2, y2);
+ return 0;
+}
+
+@
+@c
+static int path_needs_fixing (mp_knot source);
+static int path_needs_fixing (mp_knot source) {
+ mp_knot sourcehead = source;
+ do {
+ source = source->next;
+ } while (source && source != sourcehead);
+ if (!source) {
+ return 1;
+ }
+ return 0;
+}
+
+int mp_solve_path (MP mp, mp_knot first)
+{
+ int saved_arith_error = mp->arith_error;
+ jmp_buf *saved_jump_buf = mp->jump_buf;
+ int retval = 1;
+ if (first==NULL) return 0;
+ if (path_needs_fixing(first)) return 0;
+ mp->jump_buf = malloc(sizeof(jmp_buf));
+ if (mp->jump_buf == NULL || setjmp(*(mp->jump_buf)) != 0) {
+ return 0;
+ }
+ mp->arith_error = 0;
+ mp_make_choices(mp, first);
+ if (mp->arith_error)
+ retval = 0;
+ mp->arith_error = saved_arith_error;
+ free(mp->jump_buf);
+ mp->jump_buf = saved_jump_buf;
+ return retval;
+}
+
+void mp_free_path (MP mp, mp_knot p) {
+ mp_toss_knot_list(mp, p);
+}
+
+@ @<Exported function headers@>=
+int mp_close_path_cycle (MP mp, mp_knot p, mp_knot q);
+int mp_close_path (MP mp, mp_knot q, mp_knot first);
+mp_knot mp_create_knot (MP mp);
+int mp_set_knot (MP mp, mp_knot p, double x, double y);
+mp_knot mp_append_knot (MP mp, mp_knot p, double x, double y);
+int mp_set_knot_curl (MP mp, mp_knot q, double value);
+int mp_set_knot_left_curl (MP mp, mp_knot q, double value);
+int mp_set_knot_right_curl (MP mp, mp_knot q, double value);
+int mp_set_knotpair_curls (MP mp, mp_knot p, mp_knot q, double t1, double t2) ;
+int mp_set_knotpair_tensions (MP mp, mp_knot p, mp_knot q, double t1, double t2) ;
+int mp_set_knot_left_tension (MP mp, mp_knot p, double t1);
+int mp_set_knot_right_tension (MP mp, mp_knot p, double t1);
+int mp_set_knot_left_control (MP mp, mp_knot p, double t1, double t2);
+int mp_set_knot_right_control (MP mp, mp_knot p, double t1, double t2);
+int mp_set_knotpair_controls (MP mp, mp_knot p, mp_knot q, double x1, double y1, double x2, double y2) ;
+int mp_set_knot_direction (MP mp, mp_knot q, double x, double y) ;
+int mp_set_knotpair_directions (MP mp, mp_knot p, mp_knot q, double x1, double y1, double x2, double y2) ;
+int mp_solve_path (MP mp, mp_knot first);
+void mp_free_path (MP mp, mp_knot p);
+
+@ Simple accessors for |mp_knot|.
+
+@c
+mp_number mp_knot_x_coord(MP mp, mp_knot p) { return p->x_coord; }
+mp_number mp_knot_y_coord(MP mp, mp_knot p) { return p->y_coord; }
+mp_number mp_knot_left_x (MP mp, mp_knot p) { return p->left_x; }
+mp_number mp_knot_left_y (MP mp, mp_knot p) { return p->left_y; }
+mp_number mp_knot_right_x(MP mp, mp_knot p) { return p->right_x; }
+mp_number mp_knot_right_y(MP mp, mp_knot p) { return p->right_y; }
+int mp_knot_right_type(MP mp, mp_knot p) { return mp_right_type(p);}
+int mp_knot_left_type (MP mp, mp_knot p) { return mp_left_type(p);}
+mp_knot mp_knot_next (MP mp, mp_knot p) { return p->next; }
+double mp_number_as_double(MP mp, mp_number n) {
+ return number_to_double(n);
+}
+
+@ @<Exported function headers@>=
+#define mp_knot_left_curl mp_knot_left_x
+#define mp_knot_left_given mp_knot_left_x
+#define mp_knot_left_tension mp_knot_left_y
+#define mp_knot_right_curl mp_knot_right_x
+#define mp_knot_right_given mp_knot_right_x
+#define mp_knot_right_tension mp_knot_right_y
+mp_number mp_knot_x_coord(MP mp, mp_knot p);
+mp_number mp_knot_y_coord(MP mp, mp_knot p);
+mp_number mp_knot_left_x(MP mp, mp_knot p);
+mp_number mp_knot_left_y(MP mp, mp_knot p);
+mp_number mp_knot_right_x(MP mp, mp_knot p);
+mp_number mp_knot_right_y(MP mp, mp_knot p);
+int mp_knot_right_type(MP mp, mp_knot p);
+int mp_knot_left_type(MP mp, mp_knot p);
+mp_knot mp_knot_next(MP mp, mp_knot p);
+double mp_number_as_double(MP mp, mp_number n);
+
+
+@* 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$.
+
+@ Here is a routine that computes the $x$ or $y$ coordinate of the point on
+a cubic corresponding to the |fraction| value~|t|.
+
+@c
+static void mp_eval_cubic (MP mp, mp_number *r, mp_knot p, mp_knot q, quarterword c,
+ mp_number t) {
+ mp_number x1, x2, x3; /* intermediate values */
+ new_number(x1);
+ new_number(x2);
+ new_number(x3);
+ if (c == mp_x_code) {
+ set_number_from_of_the_way(x1, t, p->x_coord, p->right_x);
+ set_number_from_of_the_way(x2, t, p->right_x, q->left_x);
+ set_number_from_of_the_way(x3, t, q->left_x, q->x_coord);
+ } else {
+ set_number_from_of_the_way(x1, t, p->y_coord, p->right_y);
+ set_number_from_of_the_way(x2, t, p->right_y, q->left_y);
+ set_number_from_of_the_way(x3, t, q->left_y, q->y_coord);
+ }
+ set_number_from_of_the_way(x1, t, x1, x2);
+ set_number_from_of_the_way(x2, t, x2, x3);
+ set_number_from_of_the_way(*r, t, x1, x2);
+ free_number (x1);
+ free_number (x2);
+ free_number (x3);
+}
+
+
+@ The actual bounding box information is stored in global variables.
+Since it is convenient to address the $x$ and $y$ information
+separately, we define arrays indexed by |x_code..y_code| and use
+macros to give them more convenient names.
+
+@<Types...@>=
+enum mp_bb_code {
+ mp_x_code = 0, /* index for |minx| and |maxx| */
+ mp_y_code /* index for |miny| and |maxy| */
+};
+
+@
+@d mp_minx mp->bbmin[mp_x_code]
+@d mp_maxx mp->bbmax[mp_x_code]
+@d mp_miny mp->bbmin[mp_y_code]
+@d mp_maxy mp->bbmax[mp_y_code]
+
+@<Glob...@>=
+mp_number bbmin[mp_y_code + 1];
+mp_number bbmax[mp_y_code + 1];
+/* the result of procedures that compute bounding box information */
+
+@ @<Initialize table ...@>=
+{
+ int i;
+ for (i=0;i<=mp_y_code;i++) {
+ new_number(mp->bbmin[i]);
+ new_number(mp->bbmax[i]);
+ }
+}
+
+@ @<Dealloc...@>=
+{
+ int i;
+ for (i=0;i<=mp_y_code;i++) {
+ free_number(mp->bbmin[i]);
+ free_number(mp->bbmax[i]);
+ }
+}
+
+
+@ Now we're ready for the key part of the bounding box computation.
+The |bound_cubic| procedure updates |bbmin[c]| and |bbmax[c]| based on
+$$B(\hbox{|knot_coord(p)|}, \hbox{|right_coord(p)|},
+ \hbox{|left_coord(q)|}, \hbox{|knot_coord(q)|};t)
+$$
+for $0<t\le1$. In other words, the procedure adjusts the bounds to
+accommodate |knot_coord(q)| and any extremes over the range $0<t<1$.
+The |c| parameter is |x_code| or |y_code|.
+
+@c
+static void mp_bound_cubic (MP mp, mp_knot p, mp_knot q, quarterword c) {
+ boolean wavy; /* whether we need to look for extremes */
+ mp_number del1, del2, del3, del, dmax; /* proportional to the control
+ points of a quadratic derived from a cubic */
+ mp_number t, tt; /* where a quadratic crosses zero */
+ mp_number x; /* a value that |bbmin[c]| and |bbmax[c]| must accommodate */
+ new_number (x);
+ new_fraction (t);
+ new_fraction (tt);
+ if (c == mp_x_code) {
+ number_clone(x, q->x_coord);
+ } else {
+ number_clone(x, q->y_coord);
+ }
+ new_number(del1);
+ new_number(del2);
+ new_number(del3);
+ new_number(del);
+ new_number(dmax);
+ @<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) {
+ if (c == mp_x_code) {
+ set_number_from_substraction(del1, p->right_x, p->x_coord);
+ set_number_from_substraction(del2, q->left_x, p->right_x);
+ set_number_from_substraction(del3, q->x_coord, q->left_x);
+ } else {
+ set_number_from_substraction(del1, p->right_y, p->y_coord);
+ set_number_from_substraction(del2, q->left_y, p->right_y);
+ set_number_from_substraction(del3, q->y_coord, q->left_y);
+ }
+ @<Scale up |del1|, |del2|, and |del3| for greater accuracy;
+ also set |del| to the first nonzero element of |(del1,del2,del3)|@>;
+ if (number_negative(del)) {
+ number_negate (del1);
+ number_negate (del2);
+ number_negate (del3);
+ }
+ crossing_point (t, del1, del2, del3);
+ if (number_less(t, fraction_one_t)) {
+ @<Test the extremes of the cubic against the bounding box@>;
+ }
+ }
+ free_number (del3);
+ free_number (del2);
+ free_number (del1);
+ free_number (del);
+ free_number (dmax);
+ free_number (x);
+ free_number (t);
+ free_number (tt);
+}
+
+
+@ @<Adjust |bbmin[c]| and |bbmax[c]| to accommodate |x|@>=
+if (number_less(x, mp->bbmin[c]))
+ number_clone(mp->bbmin[c], x);
+if (number_greater(x, mp->bbmax[c]))
+ number_clone(mp->bbmax[c], x)
+
+@ @<Check the control points against the bounding box and set...@>=
+wavy = true;
+if (c == mp_x_code) {
+ if (number_lessequal(mp->bbmin[c], p->right_x))
+ if (number_lessequal (p->right_x, mp->bbmax[c]))
+ if (number_lessequal(mp->bbmin[c], q->left_x))
+ if (number_lessequal (q->left_x, mp->bbmax[c]))
+ wavy = false;
+} else {
+ if (number_lessequal(mp->bbmin[c], p->right_y))
+ if (number_lessequal (p->right_y, mp->bbmax[c]))
+ if (number_lessequal(mp->bbmin[c], q->left_y))
+ if (number_lessequal (q->left_y, mp->bbmax[c]))
+ wavy = false;
+}
+
+
+@ If |del1=del2=del3=0|, it's impossible to obey the title of this
+section. We just set |del=0| in that case.
+
+@<Scale up |del1|, |del2|, and |del3| for greater accuracy...@>=
+if (number_nonzero(del1)) {
+ number_clone (del, del1);
+} else if (number_nonzero(del2)) {
+ number_clone (del, del2);
+} else {
+ number_clone (del, del3);
+}
+if (number_nonzero(del)) {
+ mp_number absval1;
+ new_number(absval1);
+ number_clone (dmax, del1);
+ number_abs (dmax);
+ number_clone (absval1, del2);
+ number_abs(absval1);
+ if (number_greater(absval1, dmax)) {
+ number_clone(dmax, absval1);
+ }
+ number_clone (absval1, del3);
+ number_abs(absval1);
+ if (number_greater(absval1, dmax)) {
+ number_clone(dmax, absval1);
+ }
+ while (number_less(dmax, fraction_half_t)) {
+ number_double(dmax);
+ number_double(del1);
+ number_double(del2);
+ number_double(del3);
+ }
+ free_number (absval1);
+}
+
+@ 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@>=
+{
+ mp_eval_cubic (mp, &x, p, q, c, t);
+ @<Adjust |bbmin[c]| and |bbmax[c]| to accommodate |x|@>;
+ set_number_from_of_the_way(del2, t, del2, del3);
+ /* now |0,del2,del3| represent the derivative on the remaining interval */
+ if (number_positive(del2))
+ set_number_to_zero(del2);
+ {
+ mp_number arg2, arg3;
+ new_number(arg2);
+ new_number(arg3);
+ number_clone(arg2, del2);
+ number_negate(arg2);
+ number_clone(arg3, del3);
+ number_negate(arg3);
+ crossing_point (tt, zero_t, arg2, arg3);
+ free_number (arg2);
+ free_number (arg3);
+ }
+ if (number_less(tt, fraction_one_t)) {
+ @<Test the second extreme against the bounding box@>;
+ }
+}
+
+
+@ @<Test the second extreme against the bounding box@>=
+{
+ mp_number arg;
+ new_number (arg);
+ set_number_from_of_the_way (arg, t, tt, fraction_one_t);
+ mp_eval_cubic (mp, &x, p, q, c, arg);
+ free_number (arg);
+ @<Adjust |bbmin[c]| and |bbmax[c]| to accommodate |x|@>;
+}
+
+
+@ Finding the bounding box of a path is basically a matter of applying
+|bound_cubic| twice for each pair of adjacent knots.
+
+@c
+static void mp_path_bbox (MP mp, mp_knot h) {
+ mp_knot p, q; /* a pair of adjacent knots */
+ number_clone(mp_minx, h->x_coord);
+ number_clone(mp_miny, h->y_coord);
+ number_clone (mp_maxx, mp_minx);
+ number_clone (mp_maxy, mp_miny);
+ p = h;
+ do {
+ if (mp_right_type (p) == mp_endpoint)
+ return;
+ q = mp_next_knot (p);
+ mp_bound_cubic (mp, p, q, mp_x_code);
+ mp_bound_cubic (mp, p, q, mp_y_code);
+ p = q;
+ } while (p != h);
+}
+
+
+@ Another important way to measure a path is to find its arc length. This
+is best done by using the general bisection algorithm to subdivide the path
+until obtaining ``well behaved'' subpaths whose arc lengths can be approximated
+by simple means.
+
+Since the arc length is the integral with respect to time of the magnitude of
+the velocity, it is natural to use Simpson's rule for the approximation.
+@^Simpson's rule@>
+If $\dot B(t)$ is the spline velocity, Simpson's rule gives
+$$ \vb\dot B(0)\vb + 4\vb\dot B({1\over2})\vb + \vb\dot B(1)\vb \over 6 $$
+for the arc length of a path of length~1. For a cubic spline
+$B(z_0,z_1,z_2,z_3;t)$, the time derivative $\dot B(t)$ is
+$3B(dz_0,dz_1,dz_2;t)$, where $dz_i=z_{i+1}-z_i$. Hence the arc length
+approximation is
+$$ {\vb dz_0\vb \over 2} + 2\vb dz_{02}\vb + {\vb dz_2\vb \over 2}, $$
+where
+$$ dz_{02}={1\over2}\left({dz_0+dz_1\over 2}+{dz_1+dz_2\over 2}\right)$$
+is the result of the bisection algorithm.
+
+@ The remaining problem is how to decide when a subpath is ``well behaved.''
+This could be done via the theoretical error bound for Simpson's rule,
+@^Simpson's rule@>
+but this is impractical because it requires an estimate of the fourth
+derivative of the quantity being integrated. It is much easier to just perform
+a bisection step and see how much the arc length estimate changes. Since the
+error for Simpson's rule is proportional to the fourth power of the sample
+spacing, the remaining error is typically about $1\over16$ of the amount of
+the change. We say ``typically'' because the error has a pseudo-random behavior
+that could cause the two estimates to agree when each contain large errors.
+
+To protect against disasters such as undetected cusps, the bisection process
+should always continue until all the $dz_i$ vectors belong to a single
+$90^\circ$ sector. This ensures that no point on the spline can have velocity
+less than 70\% of the minimum of $\vb dz_0\vb$, $\vb dz_1\vb$ and $\vb dz_2\vb$.
+If such a spline happens to produce an erroneous arc length estimate that
+is little changed by bisection, the amount of the error is likely to be fairly
+small. We will try to arrange things so that freak accidents of this type do
+not destroy the inverse relationship between the \&{arclength} and
+\&{arctime} operations.
+@:arclength_}{\&{arclength} primitive@>
+@:arctime_}{\&{arctime} primitive@>
+
+@ The \&{arclength} and \&{arctime} operations are both based on a recursive
+@^recursion@>
+function that finds the arc length of a cubic spline given $dz_0$, $dz_1$,
+$dz_2$. This |arc_test| routine also takes an arc length goal |a_goal| and
+returns the time when the arc length reaches |a_goal| if there is such a time.
+Thus the return value is either an arc length less than |a_goal| or, if the
+arc length would be at least |a_goal|, it returns a time value decreased by
+|two|. This allows the caller to use the sign of the result to distinguish
+between arc lengths and time values. On certain types of overflow, it is
+possible for |a_goal| and the result of |arc_test| both to be |EL_GORDO|.
+Otherwise, the result is always less than |a_goal|.
+
+Rather than halving the control point coordinates on each recursive call to
+|arc_test|, it is better to keep them proportional to velocity on the original
+curve and halve the results instead. This means that recursive calls can
+potentially use larger error tolerances in their arc length estimates. How
+much larger depends on to what extent the errors behave as though they are
+independent of each other. To save computing time, we use optimistic assumptions
+and increase the tolerance by a factor of about $\sqrt2$ for each recursive
+call.
+
+In addition to the tolerance parameter, |arc_test| should also have parameters
+for ${1\over3}\vb\dot B(0)\vb$, ${2\over3}\vb\dot B({1\over2})\vb$, and
+${1\over3}\vb\dot B(1)\vb$. These quantities are relatively expensive to compute
+and they are needed in different instances of |arc_test|.
+
+@c
+static void mp_arc_test (MP mp, mp_number *ret, mp_number dx0, mp_number dy0, mp_number dx1,
+ mp_number dy1, mp_number dx2, mp_number dy2, mp_number v0,
+ mp_number v02, mp_number v2, mp_number a_goal, mp_number tol_orig) {
+ boolean simple; /* are the control points confined to a $90^\circ$ sector? */
+ mp_number dx01, dy01, dx12, dy12, dx02, dy02; /* bisection results */
+ mp_number v002, v022; /* twice the velocity magnitudes at $t={1\over4}$ and $t={3\over4}$ */
+ mp_number arc; /* best arc length estimate before recursion */
+ mp_number arc1; /* arc length estimate for the first half */
+ mp_number simply;
+ mp_number tol;
+ new_number (arc );
+ new_number (arc1);
+ new_number (dx01);
+ new_number (dy01);
+ new_number (dx12);
+ new_number (dy12);
+ new_number (dx02);
+ new_number (dy02);
+ new_number (v002);
+ new_number (v022);
+ new_number (simply);
+ new_number (tol);
+ number_clone(tol, tol_orig);
+ @<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@>;
+
+ set_number_from_addition(simply, v0, v2);
+ number_halfp (simply);
+ number_negate (simply);
+ number_add (simply, arc);
+ number_substract (simply, v02);
+ number_abs (simply);
+
+ if (simple && number_lessequal(simply, tol)) {
+ if (number_less(arc, a_goal)){
+ number_clone(*ret, 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@>;
+ }
+DONE:
+ free_number (arc);
+ free_number (arc1);
+ free_number (dx01);
+ free_number (dy01);
+ free_number (dx12);
+ free_number (dy12);
+ free_number (dx02);
+ free_number (dy02);
+ free_number (v002);
+ free_number (v022);
+ free_number (simply);
+ free_number (tol);
+}
+
+
+@ 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@>=
+{
+ mp_number a_new, a_aux; /* the sum of these gives the |a_goal| */
+ mp_number a, b; /* results of recursive calls */
+ mp_number half_v02; /* |halfp(v02)|, a recursion argument */
+ new_number(a_new);
+ new_number(a_aux);
+ new_number(half_v02);
+ @<Set |a_new| and |a_aux| so their sum is |2*a_goal| and |a_new| is as
+ large as possible@>;
+ {
+ mp_number halfp_tol;
+ new_number(halfp_tol);
+ number_clone (halfp_tol, tol);
+ number_halfp (halfp_tol);
+ number_add(tol, halfp_tol);
+ free_number (halfp_tol);
+ }
+ number_clone(half_v02, v02);
+ number_halfp(half_v02);
+ new_number (a);
+ mp_arc_test (mp, &a, dx0, dy0, dx01, dy01, dx02, dy02,
+ v0, v002, half_v02, a_new, tol);
+ if (number_negative(a)) {
+ set_number_to_unity(*ret);
+ number_double(*ret); /* two */
+ number_substract(*ret, a); /* two - a */
+ number_halfp(*ret);
+ number_negate(*ret); /* -halfp(two - a) */
+ } else {
+ @<Update |a_new| to reduce |a_new+a_aux| by |a|@>;
+ new_number (b);
+ mp_arc_test (mp, &b, dx02, dy02, dx12, dy12, dx2, dy2,
+ half_v02, v022, v2, a_new, tol);
+ if (number_negative(b)) {
+ mp_number tmp ;
+ new_number (tmp);
+ number_clone(tmp, b);
+ number_negate(tmp);
+ number_halfp(tmp);
+ number_negate(tmp);
+ number_clone(*ret, tmp);
+ set_number_to_unity(tmp);
+ number_halfp(tmp);
+ number_substract(*ret, tmp); /* (-(halfp(-b)) - 1/2) */
+ free_number (tmp);
+ } else {
+ set_number_from_substraction(*ret, b, a);
+ number_half(*ret);
+ set_number_from_addition(*ret, a, *ret); /* (a + half(b - a)) */
+ }
+ free_number (b);
+ }
+ free_number (half_v02);
+ free_number (a_aux);
+ free_number (a_new);
+ free_number (a);
+ goto DONE;
+}
+
+
+@ @<Set |a_new| and |a_aux| so their sum is |2*a_goal| and |a_new| is...@>=
+set_number_to_inf(a_aux);
+number_substract(a_aux, a_goal);
+if (number_greater(a_goal, a_aux)) {
+ set_number_from_substraction(a_aux, a_goal, a_aux);
+ set_number_to_inf(a_new);
+} else {
+ set_number_from_addition(a_new, a_goal, a_goal);
+ set_number_to_zero(a_aux);
+}
+
+
+@ 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 (number_greater(a, a_aux)) {
+ number_substract(a_aux, a);
+ number_add(a_new, a_aux);
+}
+
+@ This code assumes all {\it dx} and {\it dy} variables have magnitude less than
+|fraction_four|. To simplify the rest of the |arc_test| routine, we strengthen
+this assumption by requiring the norm of each $({\it dx},{\it dy})$ pair to obey
+this bound. Note that recursive calls will maintain this invariant.
+
+@<Bisect the B\'ezier quadratic given by |dx0|, |dy0|, |dx1|, |dy1|,...@>=
+set_number_from_addition(dx01, dx0, dx1);
+number_half(dx01);
+set_number_from_addition(dx12, dx1, dx2);
+number_half(dx12);
+set_number_from_addition(dx02, dx01, dx12);
+number_half(dx02);
+set_number_from_addition(dy01, dy0, dy1);
+number_half(dy01);
+set_number_from_addition(dy12, dy1, dy2);
+number_half(dy12);
+set_number_from_addition(dy02, dy01, dy12);
+number_half(dy02);
+
+@ 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|;...@>=
+{
+ mp_number tmp, arg1, arg2 ;
+ new_number (tmp);
+ new_number (arg1);
+ new_number (arg2);
+ set_number_from_addition(arg1, dx0, dx02);
+ number_half(arg1);
+ number_add(arg1, dx01);
+ set_number_from_addition(arg2, dy0, dy02);
+ number_half(arg2);
+ number_add(arg2, dy01);
+ pyth_add (v002, arg1, arg2);
+
+ set_number_from_addition(arg1, dx02, dx2);
+ number_half(arg1);
+ number_add(arg1, dx12);
+ set_number_from_addition(arg2, dy02, dy2);
+ number_half(arg2);
+ number_add(arg2, dy12);
+ pyth_add (v022, arg1, arg2);
+ free_number(arg1);
+ free_number(arg2);
+
+ number_clone (tmp, v02);
+ number_add_scaled (tmp, 2);
+ number_halfp (tmp);
+
+ set_number_from_addition(arc1, v0, tmp);
+ number_halfp (arc1);
+ number_substract (arc1, v002);
+ number_half (arc1);
+ set_number_from_addition(arc1, v002, arc1);
+
+ set_number_from_addition(arc, v2, tmp);
+ number_halfp (arc);
+ number_substract (arc, v022);
+ number_half (arc);
+ set_number_from_addition(arc, v022, arc);
+
+ /* reuse |tmp| for the next |if| test: */
+ set_number_to_inf(tmp);
+ number_substract(tmp,arc1);
+ if (number_less(arc, tmp)) {
+ free_number (tmp);
+ number_add(arc, arc1);
+ } else {
+ free_number (tmp);
+ mp->arith_error = true;
+ if (number_infinite(a_goal)) {
+ set_number_to_inf(*ret);
+ } else {
+ set_number_to_unity(*ret);
+ number_double(*ret);
+ number_negate(*ret); /* -two */
+ }
+ goto DONE;
+ }
+}
+
+
+@ @<Test if the control points are confined to one quadrant or rotating...@>=
+simple = ((number_nonnegative(dx0) && number_nonnegative(dx1) && number_nonnegative(dx2)) ||
+ (number_nonpositive(dx0) && number_nonpositive(dx1) && number_nonpositive(dx2)));
+if (simple) {
+ simple = (number_nonnegative(dy0) && number_nonnegative(dy1) && number_nonnegative(dy2)) ||
+ (number_nonpositive(dy0) && number_nonpositive(dy1) && number_nonpositive(dy2));
+}
+if (!simple) {
+ simple = (number_greaterequal(dx0, dy0) && number_greaterequal(dx1, dy1) && number_greaterequal(dx2, dy2)) ||
+ (number_lessequal(dx0, dy0) && number_lessequal(dx1, dy1) && number_lessequal(dx2, dy2));
+ if (simple) {
+ mp_number neg_dx0, neg_dx1, neg_dx2;
+ new_number(neg_dx0);
+ new_number(neg_dx1);
+ new_number(neg_dx2);
+ number_clone(neg_dx0, dx0);
+ number_clone(neg_dx1, dx1);
+ number_clone(neg_dx2, dx2);
+ number_negate(neg_dx0);
+ number_negate(neg_dx1);
+ number_negate(neg_dx2);
+ simple =
+ (number_greaterequal(neg_dx0, dy0) && number_greaterequal(neg_dx1, dy1) && number_greaterequal(neg_dx2, dy2)) ||
+ (number_lessequal(neg_dx0, dy0) && number_lessequal(neg_dx1, dy1) && number_lessequal(neg_dx2, dy2));
+ free_number (neg_dx0);
+ free_number (neg_dx1);
+ free_number (neg_dx2);
+ }
+}
+
+@ 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...@>=
+{
+ mp_number tmp;
+ mp_number tmp2;
+ mp_number tmp3;
+ mp_number tmp4;
+ mp_number tmp5;
+ new_number (tmp);
+ new_number (tmp2);
+ new_number (tmp3);
+ new_number (tmp4);
+ new_number (tmp5);
+ number_clone(tmp, v02);
+ number_add_scaled(tmp, 2);
+ number_half(tmp);
+ number_half(tmp); /* (v02+2) / 4 */
+ if (number_lessequal(a_goal, arc1)) {
+ number_clone(tmp2, v0);
+ number_halfp(tmp2);
+ set_number_from_substraction(tmp3, arc1, tmp2);
+ number_substract(tmp3, tmp);
+ mp_solve_rising_cubic (mp, &tmp5, tmp2, tmp3, tmp, a_goal);
+ number_halfp (tmp5);
+ set_number_to_unity(tmp3);
+ number_substract(tmp5, tmp3);
+ number_substract(tmp5, tmp3);
+ number_clone(*ret, tmp5);
+ } else {
+ number_clone(tmp2, v2);
+ number_halfp(tmp2);
+ set_number_from_substraction(tmp3, arc, arc1);
+ number_substract(tmp3, tmp);
+ number_substract(tmp3, tmp2);
+ set_number_from_substraction(tmp4, a_goal, arc1);
+ mp_solve_rising_cubic (mp, &tmp5, tmp, tmp3, tmp2, tmp4);
+ number_halfp(tmp5);
+ set_number_to_unity(tmp2);
+ set_number_to_unity(tmp3);
+ number_half(tmp2);
+ number_substract(tmp2, tmp3);
+ number_substract(tmp2, tmp3);
+ set_number_from_addition(*ret, tmp2, tmp5);
+ }
+ free_number (tmp);
+ free_number (tmp2);
+ free_number (tmp3);
+ free_number (tmp4);
+ free_number (tmp5);
+ goto DONE;
+}
+
+
+@ 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.
+
+@<Declarations@>=
+static void mp_solve_rising_cubic (MP mp, mp_number *ret, mp_number a, mp_number b, mp_number c, mp_number x);
+
+@ @c
+void mp_solve_rising_cubic (MP mp, mp_number *ret, mp_number a_orig, mp_number b_orig, mp_number c_orig, mp_number x_orig) {
+ mp_number abc;
+ mp_number a, b, c, x; /* local versions of arguments */
+ mp_number ab, bc, ac; /* bisection results */
+ mp_number t; /* $2^k+q$ where unscaled answer is in $[q2^{-k},(q+1)2^{-k})$ */
+ mp_number xx; /* temporary for updating |x| */
+ mp_number neg_x; /* temporary for an |if| */
+ if (number_negative(a_orig) || number_negative(c_orig))
+ mp_confusion (mp, "rising?");
+@:this can't happen rising?}{\quad rising?@>;
+ new_number (t);
+ new_number (abc);
+ new_number (a);
+ new_number (b);
+ new_number (c);
+ new_number (x);
+ number_clone(a, a_orig);
+ number_clone(b, b_orig);
+ number_clone(c, c_orig);
+ number_clone(x, x_orig);
+ new_number (ab);
+ new_number (bc);
+ new_number (ac);
+ new_number (xx);
+ new_number (neg_x);
+ set_number_from_addition(abc, a, b);
+ number_add(abc, c);
+ if (number_nonpositive(x)) {
+ set_number_to_zero(*ret);
+ } else if (number_greaterequal(x, abc)) {
+ set_number_to_unity(*ret);
+ } else {
+ number_clone (t, epsilon_t);
+ @<Rescale if necessary to make sure |a|, |b|, and |c| are all less than
+ |EL_GORDO div 3|@>;
+ do {
+ number_add (t, t);
+ @<Subdivide the B\'ezier quadratic defined by |a|, |b|, |c|@>;
+ number_clone(xx,x);
+ number_substract(xx, a);
+ number_substract(xx, ab);
+ number_substract(xx, ac);
+ number_clone(neg_x, x);
+ number_negate(neg_x);
+ if (number_less(xx, neg_x)) {
+ number_double(x);
+ number_clone(b, ab);
+ number_clone(c, ac);
+ } else {
+ number_add(x, xx);
+ number_clone(a, ac);
+ number_clone(b, bc);
+ number_add (t, epsilon_t);
+ }
+ } while (number_less (t, unity_t));
+ set_number_from_substraction(*ret, t, unity_t);
+ }
+ free_number (abc);
+ free_number (t);
+ free_number (a);
+ free_number (b);
+ free_number (c);
+ free_number (ab);
+ free_number (bc);
+ free_number (ac);
+ free_number (xx);
+ free_number (x);
+ free_number (neg_x);
+}
+
+
+@ @<Subdivide the B\'ezier quadratic defined by |a|, |b|, |c|@>=
+set_number_from_addition(ab, a, b);
+number_half(ab);
+set_number_from_addition(bc, b, c);
+number_half(bc);
+set_number_from_addition(ac, ab, bc);
+number_half(ac);
+
+@ The upper bound on |a|, |b|, and |c|:
+
+@d one_third_inf_t ((math_data *)mp->math)->one_third_inf_t
+
+@<Rescale if necessary to make sure |a|, |b|, and |c| are all less than...@>=
+while (number_greater(a, one_third_inf_t) ||
+ number_greater(b, one_third_inf_t) ||
+ number_greater(c, one_third_inf_t)) {
+ number_halfp(a);
+ number_half(b);
+ number_halfp(c);
+ number_halfp(x);
+}
+
+
+@ It is convenient to have a simpler interface to |arc_test| that requires no
+unnecessary arguments and ensures that each $({\it dx},{\it dy})$ pair has
+length less than |fraction_four|.
+
+@c
+static void mp_do_arc_test (MP mp, mp_number *ret, mp_number dx0, mp_number dy0, mp_number dx1,
+ mp_number dy1, mp_number dx2, mp_number dy2, mp_number a_goal) {
+ mp_number v0, v1, v2; /* length of each $({\it dx},{\it dy})$ pair */
+ mp_number v02; /* twice the norm of the quadratic at $t={1\over2}$ */
+ new_number (v0);
+ new_number (v1);
+ new_number (v2);
+ pyth_add (v0, dx0, dy0);
+ pyth_add (v1, dx1, dy1);
+ pyth_add (v2, dx2, dy2);
+ if ((number_greaterequal(v0, fraction_four_t)) ||
+ (number_greaterequal(v1, fraction_four_t)) ||
+ (number_greaterequal(v2, fraction_four_t))) {
+ mp->arith_error = true;
+ if (number_infinite(a_goal)) {
+ set_number_to_inf(*ret);
+ } else {
+ set_number_to_unity(*ret);
+ number_double(*ret);
+ number_negate(*ret);
+ }
+ } else {
+ mp_number arg1, arg2;
+ new_number (v02);
+ new_number (arg1);
+ new_number (arg2);
+ set_number_from_addition(arg1, dx0, dx2);
+ number_half(arg1);
+ number_add(arg1, dx1);
+ set_number_from_addition(arg2, dy0, dy2);
+ number_half(arg2);
+ number_add(arg2, dy1);
+ pyth_add (v02, arg1, arg2);
+ free_number(arg1);
+ free_number(arg2);
+ mp_arc_test (mp, ret, dx0, dy0, dx1, dy1, dx2, dy2, v0, v02, v2, a_goal, arc_tol_k);
+ free_number (v02);
+ }
+ free_number (v0);
+ free_number (v1);
+ free_number (v2);
+}
+
+
+@ Now it is easy to find the arc length of an entire path.
+
+@c
+static void mp_get_arc_length (MP mp, mp_number *ret, mp_knot h) {
+ mp_knot p, q; /* for traversing the path */
+ mp_number a; /* current arc length */
+ mp_number a_tot; /* total arc length */
+ mp_number arg1, arg2, arg3, arg4, arg5, arg6;
+ mp_number arcgoal;
+ p = h;
+ new_number (a_tot);
+ new_number (arg1);
+ new_number (arg2);
+ new_number (arg3);
+ new_number (arg4);
+ new_number (arg5);
+ new_number (arg6);
+ new_number (a);
+ new_number(arcgoal);
+ set_number_to_inf(arcgoal);
+ while (mp_right_type (p) != mp_endpoint) {
+ q = mp_next_knot (p);
+ set_number_from_substraction(arg1, p->right_x, p->x_coord);
+ set_number_from_substraction(arg2, p->right_y, p->y_coord);
+ set_number_from_substraction(arg3, q->left_x, p->right_x);
+ set_number_from_substraction(arg4, q->left_y, p->right_y);
+ set_number_from_substraction(arg5, q->x_coord, q->left_x);
+ set_number_from_substraction(arg6, q->y_coord, q->left_y);
+ mp_do_arc_test (mp, &a, arg1, arg2, arg3, arg4, arg5, arg6, arcgoal);
+ slow_add (a_tot, a, a_tot);
+ if (q == h)
+ break;
+ else
+ p = q;
+ }
+ free_number (arcgoal);
+ free_number (a);
+ free_number (arg1);
+ free_number (arg2);
+ free_number (arg3);
+ free_number (arg4);
+ free_number (arg5);
+ free_number (arg6);
+ check_arith();
+ number_clone (*ret, a_tot);
+ free_number (a_tot);
+}
+
+
+@ The inverse operation of finding the time on a path~|h| when the arc length
+reaches some value |arc0| can also be accomplished via |do_arc_test|. Some care
+is required to handle very large times or negative times on cyclic paths. For
+non-cyclic paths, |arc0| values that are negative or too large cause
+|get_arc_time| to return 0 or the length of path~|h|.
+
+If |arc0| is greater than the arc length of a cyclic path~|h|, the result is a
+time value greater than the length of the path. Since it could be much greater,
+we must be prepared to compute the arc length of path~|h| and divide this into
+|arc0| to find how many multiples of the length of path~|h| to add.
+
+@c
+static void mp_get_arc_time (MP mp, mp_number *ret, mp_knot h, mp_number arc0_orig) {
+ mp_knot p, q; /* for traversing the path */
+ mp_number t_tot; /* accumulator for the result */
+ mp_number t; /* the result of |do_arc_test| */
+ mp_number arc, arc0; /* portion of |arc0| not used up so far */
+ mp_number arg1, arg2, arg3, arg4, arg5, arg6; /* |do_arc_test| arguments */
+ if (number_negative(arc0_orig)) {
+ @<Deal with a negative |arc0_orig| value and |return|@>;
+ }
+ new_number (t_tot);
+ new_number (arc0);
+ number_clone(arc0, arc0_orig);
+ if (number_infinite(arc0)) {
+ number_add_scaled (arc0, -1);
+ }
+ new_number (arc);
+ number_clone(arc, arc0);
+ p = h;
+ new_number (arg1);
+ new_number (arg2);
+ new_number (arg3);
+ new_number (arg4);
+ new_number (arg5);
+ new_number (arg6);
+ new_number (t);
+ while ((mp_right_type (p) != mp_endpoint) && number_positive(arc)) {
+ q = mp_next_knot (p);
+ set_number_from_substraction(arg1, p->right_x, p->x_coord);
+ set_number_from_substraction(arg2, p->right_y, p->y_coord);
+ set_number_from_substraction(arg3, q->left_x, p->right_x);
+ set_number_from_substraction(arg4, q->left_y, p->right_y);
+ set_number_from_substraction(arg5, q->x_coord, q->left_x);
+ set_number_from_substraction(arg6, q->y_coord, q->left_y);
+ mp_do_arc_test (mp, &t, arg1, arg2, arg3, arg4, arg5, arg6, arc);
+ @<Update |arc| and |t_tot| after |do_arc_test| has just returned |t|@>;
+ if (q == h) {
+ @<Update |t_tot| and |arc| to avoid going around the cyclic
+ path too many times but set |arith_error:=true| and |goto done| on
+ overflow@>;
+ }
+ p = q;
+ }
+ check_arith();
+ number_clone (*ret, t_tot);
+RETURN:
+ free_number (t_tot);
+ free_number (t);
+ free_number (arc);
+ free_number (arc0);
+ free_number (arg1);
+ free_number (arg2);
+ free_number (arg3);
+ free_number (arg4);
+ free_number (arg5);
+ free_number (arg6);
+}
+
+
+@ @<Update |arc| and |t_tot| after |do_arc_test| has just returned |t|@>=
+if (number_negative(t)) {
+ number_add (t_tot, t);
+ number_add (t_tot, two_t);
+ set_number_to_zero(arc);
+} else {
+ number_add (t_tot, unity_t);
+ number_substract(arc, t);
+}
+
+
+@ @<Deal with a negative |arc0_orig| value and |return|@>=
+{
+ if (mp_left_type (h) == mp_endpoint) {
+ set_number_to_zero (*ret);
+ } else {
+ mp_number neg_arc0;
+ p = mp_htap_ypoc (mp, h);
+ new_number(neg_arc0);
+ number_clone(neg_arc0, arc0_orig);
+ number_negate(neg_arc0);
+ mp_get_arc_time (mp, ret, p, neg_arc0);
+ number_negate(*ret);
+ mp_toss_knot_list (mp, p);
+ free_number (neg_arc0);
+ }
+ check_arith();
+ return;
+}
+
+
+@ @<Update |t_tot| and |arc| to avoid going around the cyclic...@>=
+if (number_positive(arc)) {
+ mp_number n, n1, d1, v1;
+ new_number (n);
+ new_number (n1);
+ new_number (d1);
+ new_number (v1);
+
+ set_number_from_substraction (d1, arc0, arc); /* d1 = arc0 - arc */
+ set_number_from_div (n1, arc, d1); /* n1 = (arc / d1) */
+ number_clone (n, n1);
+ set_number_from_mul (n1, n1, d1); /* n1 = (n1 * d1) */
+ number_substract (arc, n1); /* arc = arc - n1 */
+
+ number_clone (d1, inf_t); /* reuse d1 */
+ number_clone (v1, n); /* v1 = n */
+ number_add (v1, epsilon_t); /* v1 = n1+1 */
+ set_number_from_div (d1, d1, v1); /* |d1 = EL_GORDO / v1| */
+ if (number_greater (t_tot, d1)) {
+ mp->arith_error = true;
+ check_arith();
+ set_number_to_inf(*ret);
+ free_number (n);
+ free_number (n1);
+ free_number (d1);
+ free_number (v1);
+ goto RETURN;
+ }
+ set_number_from_mul (t_tot, t_tot, v1);
+ free_number (n);
+ free_number (n1);
+ free_number (d1);
+ free_number (v1);
+}
+
+@* 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
+|mp_left_type| or |mp_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|.
+
+@ The |make_pen| procedure turns a path into a pen by initializing
+the |prev_knot| pointers and making sure the knots form a convex polygon.
+Thus each cubic in the given path becomes a straight line and the control
+points are ignored. If the path is not cyclic, the ends are connected by a
+straight line.
+
+@d copy_pen(A) mp_make_pen(mp, mp_copy_path(mp, (A)),false)
+
+@c
+static mp_knot mp_make_pen (MP mp, mp_knot h, boolean need_hull) {
+ mp_knot p, q; /* two consecutive knots */
+ q = h;
+ do {
+ p = q;
+ q = mp_next_knot (q);
+ mp_prev_knot (q) = p;
+ } while (q != h);
+ if (need_hull) {
+ h = mp_convex_hull (mp, h);
+ @<Make sure |h| isn't confused with an elliptical pen@>;
+ }
+ return h;
+}
+
+
+@ The only information required about an elliptical pen is the overall
+transformation that has been applied to the original \&{pencircle}.
+@:pencircle_}{\&{pencircle} primitive@>
+Since it suffices to keep track of how the three points $(0,0)$, $(1,0)$,
+and $(0,1)$ are transformed, an elliptical pen can be stored in a single
+knot node and transformed as if it were a path.
+
+@d pen_is_elliptical(A) ((A)==mp_next_knot((A)))
+
+@c
+static mp_knot mp_get_pen_circle (MP mp, mp_number diam) {
+ mp_knot h; /* the knot node to return */
+ h = mp_new_knot (mp);
+ mp_next_knot (h) = h;
+ mp_prev_knot (h) = h;
+ mp_originator (h) = mp_program_code;
+ set_number_to_zero(h->x_coord);
+ set_number_to_zero(h->y_coord);
+ number_clone(h->left_x, diam);
+ set_number_to_zero(h->left_y);
+ set_number_to_zero(h->right_x);
+ number_clone(h->right_y, diam);
+ return h;
+}
+
+
+@ If the polygon being returned by |make_pen| has only one vertex, it will
+be interpreted as an elliptical pen. This is no problem since a degenerate
+polygon can equally well be thought of as a degenerate ellipse. We need only
+initialize the |left_x|, |left_y|, |right_x|, and |right_y| fields.
+
+@<Make sure |h| isn't confused with an elliptical pen@>=
+if (pen_is_elliptical (h)) {
+ number_clone(h->left_x, h->x_coord);
+ number_clone(h->left_y, h->y_coord);
+ number_clone(h->right_x, h->x_coord);
+ number_clone(h->right_y, h->y_coord);
+}
+
+@ Printing a polygonal pen is very much like printing a path
+
+@<Declarations@>=
+static void mp_pr_pen (MP mp, mp_knot h);
+
+@ @c
+void mp_pr_pen (MP mp, mp_knot h) {
+ mp_knot p, q; /* for list traversal */
+ if (pen_is_elliptical (h)) {
+ @<Print the elliptical pen |h|@>;
+ } else {
+ p = h;
+ do {
+ mp_print_two (mp, p->x_coord, p->y_coord);
+ mp_print_nl (mp, " .. ");
+ @<Advance |p| making sure the links are OK and |return| if there is
+ a problem@>;
+ } while (p != h);
+ mp_print (mp, "cycle");
+ }
+}
+
+
+@ @<Advance |p| making sure the links are OK and |return| if there is...@>=
+q = mp_next_knot (p);
+if ((q == NULL) || (mp_prev_knot (q) != p)) {
+ mp_print_nl (mp, "???");
+ return; /* this won't happen */
+@.???@>
+}
+p = q
+
+@ @<Print the elliptical pen |h|@>=
+{
+ mp_number v1;
+ new_number (v1);
+ mp_print (mp, "pencircle transformed (");
+ print_number (h->x_coord);
+ mp_print_char (mp, xord (','));
+ print_number (h->y_coord);
+ mp_print_char (mp, xord (','));
+ set_number_from_substraction (v1, h->left_x, h->x_coord);
+ print_number (v1);
+ mp_print_char (mp, xord (','));
+ set_number_from_substraction (v1, h->right_x, h->x_coord);
+ print_number (v1);
+ mp_print_char (mp, xord (','));
+ set_number_from_substraction (v1, h->left_y, h->y_coord);
+ print_number (v1);
+ mp_print_char (mp, xord (','));
+ set_number_from_substraction (v1, h->right_y, h->y_coord);
+ print_number (v1);
+ mp_print_char (mp, xord (')'));
+ free_number (v1);
+}
+
+
+@ Here us another version of |pr_pen| that prints the pen as a diagnostic
+message.
+
+@<Declarations@>=
+static void mp_print_pen (MP mp, mp_knot h, const char *s, boolean nuline);
+
+@ @c
+void mp_print_pen (MP mp, mp_knot h, const char *s, boolean nuline) {
+ mp_print_diagnostic (mp, "Pen", s, nuline);
+ mp_print_ln (mp);
+@.Pen at line...@>;
+ mp_pr_pen (mp, h);
+ mp_end_diagnostic (mp, true);
+}
+
+
+@ Making a polygonal pen into a path involves restoring the |mp_left_type| and
+|mp_right_type| fields and setting the control points so as to make a polygonal
+path.
+
+@c
+static void mp_make_path (MP mp, mp_knot h) {
+ mp_knot p; /* for traversing the knot list */
+ quarterword k; /* a loop counter */
+ @<Other local variables in |make_path|@>;
+ FUNCTION_TRACE1 ("make_path()\n");
+ if (pen_is_elliptical (h)) {
+ FUNCTION_TRACE1 ("make_path(elliptical)\n");
+ @<Make the elliptical pen |h| into a path@>;
+ } else {
+ p = h;
+ do {
+ mp_left_type (p) = mp_explicit;
+ mp_right_type (p) = mp_explicit;
+ @<copy the coordinates of knot |p| into its control points@>;
+ p = mp_next_knot (p);
+ } while (p != h);
+ }
+}
+
+
+@ @<copy the coordinates of knot |p| into its control points@>=
+number_clone (p->left_x, p->x_coord);
+number_clone (p->left_y, p->y_coord);
+number_clone (p->right_x, p->x_coord);
+number_clone (p->right_y, p->y_coord)
+
+
+@ We need an eight knot path to get a good approximation to an ellipse.
+
+@<Make the elliptical pen |h| into a path@>=
+{
+ mp_number center_x, center_y; /* translation parameters for an elliptical pen */
+ mp_number width_x, width_y; /* the effect of a unit change in $x$ */
+ mp_number height_x, height_y; /* the effect of a unit change in $y$ */
+ mp_number dx, dy; /* the vector from knot |p| to its right control point */
+ new_number (center_x);
+ new_number (center_y);
+ new_number (width_x);
+ new_number (width_y);
+ new_number (height_x);
+ new_number (height_y);
+ new_number (dx);
+ new_number (dy);
+ @<Extract the transformation parameters from the elliptical pen~|h|@>;
+ p = h;
+ for (k = 0; k <= 7; k++) {
+ @<Initialize |p| as the |k|th knot of a circle of unit diameter,
+ transforming it appropriately@>;
+ if (k == 7)
+ mp_next_knot (p) = h;
+ else
+ mp_next_knot (p) = mp_new_knot (mp);
+ p = mp_next_knot (p);
+ }
+ free_number (dx);
+ free_number (dy);
+ free_number (center_x);
+ free_number (center_y);
+ free_number (width_x);
+ free_number (width_y);
+ free_number (height_x);
+ free_number (height_y);
+}
+
+
+@ @<Extract the transformation parameters from the elliptical pen~|h|@>=
+number_clone (center_x, h->x_coord);
+number_clone (center_y, h->y_coord);
+set_number_from_substraction (width_x, h->left_x, center_x);
+set_number_from_substraction (width_y, h->left_y, center_y);
+set_number_from_substraction (height_x, h->right_x, center_x);
+set_number_from_substraction (height_y, h->right_y, center_y);
+
+@ @<Other local variables in |make_path|@>=
+integer kk;
+ /* |k| advanced $270^\circ$ around the ring (cf. $\sin\theta=\cos(\theta+270)$) */
+
+@ The only tricky thing here are the tables |half_cos| and |d_cos| used to
+find the point $k/8$ of the way around the circle and the direction vector
+to use there.
+
+@<Initialize |p| as the |k|th knot of a circle of unit diameter,...@>=
+kk = (k + 6) % 8;
+{
+ mp_number r1, r2;
+ new_fraction (r1);
+ new_fraction (r2);
+ take_fraction (r1, mp->half_cos[k], width_x);
+ take_fraction (r2, mp->half_cos[kk], height_x);
+ number_add (r1, r2);
+ set_number_from_addition (p->x_coord, center_x, r1);
+ take_fraction (r1, mp->half_cos[k], width_y);
+ take_fraction (r2, mp->half_cos[kk], height_y);
+ number_add (r1, r2);
+ set_number_from_addition (p->y_coord, center_y, r1);
+ take_fraction (r1, mp->d_cos[kk], width_x);
+ take_fraction (r2, mp->d_cos[k], height_x);
+ number_clone (dx, r1);
+ number_negate (dx);
+ number_add (dx, r2);
+ take_fraction (r1, mp->d_cos[kk], width_y);
+ take_fraction (r2, mp->d_cos[k], height_y);
+ number_clone (dy, r1);
+ number_negate (dy);
+ number_add (dy, r2);
+ set_number_from_addition (p->right_x, p->x_coord, dx);
+ set_number_from_addition (p->right_y, p->y_coord, dy);
+ set_number_from_substraction (p->left_x, p->x_coord, dx);
+ set_number_from_substraction (p->left_y, p->y_coord, dy);
+ free_number (r1);
+ free_number (r2);
+}
+mp_left_type (p) = mp_explicit;
+mp_right_type (p) = mp_explicit;
+mp_originator (p) = mp_program_code
+
+@ @<Glob...@>=
+mp_number half_cos[8]; /* ${1\over2}\cos(45k)$ */
+mp_number d_cos[8]; /* a magic constant times $\cos(45k)$ */
+
+@ The magic constant for |d_cos| is the distance between $({1\over2},0)$ and
+$({1\over4}\sqrt2,{1\over4}\sqrt2)$ times the result of the |velocity|
+function for $\theta=\phi=22.5^\circ$. This comes out to be
+$$ d = {\sqrt{2-\sqrt2}\over 3+3\cos22.5^\circ}
+ \approx 0.132608244919772.
+$$
+
+@<Set init...@>=
+for (k = 0; k <= 7; k++) {
+ new_fraction (mp->half_cos[k]);
+ new_fraction (mp->d_cos[k]);
+}
+number_clone (mp->half_cos[0], fraction_half_t);
+number_clone (mp->half_cos[1], twentysixbits_sqrt2_t);
+number_clone (mp->half_cos[2], zero_t);
+number_clone (mp->d_cos[0], twentyeightbits_d_t);
+number_clone (mp->d_cos[1], twentysevenbits_sqrt2_d_t);
+number_clone (mp->d_cos[2], zero_t);
+for (k = 3; k <= 4; k++) {
+ number_clone (mp->half_cos[k], mp->half_cos[4 - k]);
+ number_negate (mp->half_cos[k]);
+ number_clone (mp->d_cos[k], mp->d_cos[4 - k]);
+ number_negate (mp->d_cos[k]);
+}
+for (k = 5; k <= 7; k++) {
+ number_clone (mp->half_cos[k], mp->half_cos[8 - k]);
+ number_clone (mp->d_cos[k], mp->d_cos[8 - k]);
+}
+
+@ @<Dealloc...@>=
+for (k = 0; k <= 7; k++) {
+ free_number (mp->half_cos[k]);
+ free_number (mp->d_cos[k]);
+}
+
+
+@ The |convex_hull| function forces a pen polygon to be convex when it is
+returned by |make_pen| and after any subsequent transformation where rounding
+error might allow the convexity to be lost.
+The convex hull algorithm used here is described by F.~P. Preparata and
+M.~I. Shamos [{\sl Computational Geometry}, Springer-Verlag, 1985].
+
+@<Declarations@>=
+static mp_knot mp_convex_hull (MP mp, mp_knot h);
+
+@ @c
+mp_knot mp_convex_hull (MP mp, mp_knot h) { /* Make a polygonal pen convex */
+ mp_knot l, r; /* the leftmost and rightmost knots */
+ mp_knot p, q; /* knots being scanned */
+ mp_knot s; /* the starting point for an upcoming scan */
+ mp_number dx, dy; /* a temporary pointer */
+ mp_knot ret;
+ new_number (dx);
+ new_number (dy);
+ if (pen_is_elliptical (h)) {
+ ret = h;
+ } else {
+ @<Set |l| to the leftmost knot in polygon~|h|@>;
+ @<Set |r| to the rightmost knot in polygon~|h|@>;
+ if (l != r) {
+ s = mp_next_knot (r);
+ @<Find any knots on the path from |l| to |r| above the |l|-|r| line and
+ move them past~|r|@>;
+ @<Find any knots on the path from |s| to |l| below the |l|-|r| line and
+ move them past~|l|@>;
+ @<Sort the path from |l| to |r| by increasing $x$@>;
+ @<Sort the path from |r| to |l| by decreasing $x$@>;
+ }
+ if (l != mp_next_knot (l)) {
+ @<Do a Gramm scan and remove vertices where there is no left turn@>;
+ }
+ ret = l;
+ }
+ free_number (dx);
+ free_number (dy);
+ return ret;
+}
+
+
+@ All comparisons are done primarily on $x$ and secondarily on $y$.
+
+@<Set |l| to the leftmost knot in polygon~|h|@>=
+l = h;
+p = mp_next_knot (h);
+while (p != h) {
+ if (number_lessequal (p->x_coord, l->x_coord))
+ if ((number_less (p->x_coord, l->x_coord)) ||
+ (number_less (p->y_coord, l->y_coord)))
+ l = p;
+ p = mp_next_knot (p);
+}
+
+
+@ @<Set |r| to the rightmost knot in polygon~|h|@>=
+r = h;
+p = mp_next_knot (h);
+while (p != h) {
+ if (number_greaterequal(p->x_coord, r->x_coord))
+ if (number_greater (p->x_coord, r->x_coord) ||
+ number_greater (p->y_coord, r->y_coord))
+ r = p;
+ p = mp_next_knot (p);
+}
+
+
+@ @<Find any knots on the path from |l| to |r| above the |l|-|r| line...@>=
+{
+ mp_number ab_vs_cd;
+ mp_number arg1, arg2;
+ new_number (arg1);
+ new_number (arg2);
+ new_number (ab_vs_cd);
+ set_number_from_substraction (dx, r->x_coord, l->x_coord);
+ set_number_from_substraction (dy, r->y_coord, l->y_coord);
+ p = mp_next_knot (l);
+ while (p != r) {
+ q = mp_next_knot (p);
+ set_number_from_substraction (arg1, p->y_coord, l->y_coord);
+ set_number_from_substraction (arg2, p->x_coord, l->x_coord);
+ ab_vs_cd (ab_vs_cd, dx, arg1, dy, arg2);
+ if (number_positive(ab_vs_cd))
+ mp_move_knot (mp, p, r);
+ p = q;
+ }
+ free_number (ab_vs_cd);
+ free_number (arg1);
+ free_number (arg2);
+}
+
+
+@ The |move_knot| procedure removes |p| from a doubly linked list and inserts
+it after |q|.
+
+@ @<Declarations@>=
+static void mp_move_knot (MP mp, mp_knot p, mp_knot q);
+
+@ @c
+void mp_move_knot (MP mp, mp_knot p, mp_knot q) {
+ (void) mp;
+ mp_next_knot (mp_prev_knot (p)) = mp_next_knot (p);
+ mp_prev_knot (mp_next_knot (p)) = mp_prev_knot (p);
+ mp_prev_knot (p) = q;
+ mp_next_knot (p) = mp_next_knot (q);
+ mp_next_knot (q) = p;
+ mp_prev_knot (mp_next_knot (p)) = p;
+}
+
+
+@ @<Find any knots on the path from |s| to |l| below the |l|-|r| line...@>=
+{
+ mp_number ab_vs_cd;
+ mp_number arg1, arg2;
+ new_number (ab_vs_cd);
+ new_number (arg1);
+ new_number (arg2);
+ p = s;
+ while (p != l) {
+ q = mp_next_knot (p);
+ set_number_from_substraction (arg1, p->y_coord, l->y_coord);
+ set_number_from_substraction (arg2, p->x_coord, l->x_coord);
+ ab_vs_cd (ab_vs_cd, dx, arg1, dy, arg2);
+ if (number_negative(ab_vs_cd))
+ mp_move_knot (mp, p, l);
+ p = q;
+ }
+ free_number (ab_vs_cd);
+ free_number (arg1);
+ free_number (arg2);
+}
+
+
+@ 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 = mp_next_knot (l);
+while (p != r) {
+ q = mp_prev_knot (p);
+ while (number_greater(q->x_coord, p->x_coord))
+ q = mp_prev_knot (q);
+ while (number_equal(q->x_coord, p->x_coord)) {
+ if (number_greater(q->y_coord, p->y_coord))
+ q = mp_prev_knot (q);
+ else
+ break;
+ }
+ if (q == mp_prev_knot (p)) {
+ p = mp_next_knot (p);
+ } else {
+ p = mp_next_knot (p);
+ mp_move_knot (mp, mp_prev_knot (p), q);
+ }
+}
+
+
+@ @<Sort the path from |r| to |l| by decreasing $x$@>=
+p = mp_next_knot (r);
+while (p != l) {
+ q = mp_prev_knot (p);
+ while (number_less(q->x_coord, p->x_coord))
+ q = mp_prev_knot (q);
+ while (number_equal(q->x_coord, p->x_coord)) {
+ if (number_less (q->y_coord, p->y_coord))
+ q = mp_prev_knot (q);
+ else
+ break;
+ }
+ if (q == mp_prev_knot (p)) {
+ p = mp_next_knot (p);
+ } else {
+ p = mp_next_knot (p);
+ mp_move_knot (mp, mp_prev_knot (p), q);
+ }
+}
+
+
+@ The condition involving |ab_vs_cd| tests if there is not a left turn
+at knot |q|. There usually will be a left turn so we streamline the case
+where the |then| clause is not executed.
+
+@<Do a Gramm scan and remove vertices where there...@>=
+{
+ mp_number ab_vs_cd;
+ mp_number arg1, arg2;
+ new_number (arg1);
+ new_number (arg2);
+ new_number (ab_vs_cd);
+ p = l;
+ q = mp_next_knot (l);
+ while (1) {
+ set_number_from_substraction (dx, q->x_coord, p->x_coord);
+ set_number_from_substraction (dy, q->y_coord, p->y_coord);
+ p = q;
+ q = mp_next_knot (q);
+ if (p == l)
+ break;
+ if (p != r) {
+ set_number_from_substraction (arg1, q->y_coord, p->y_coord);
+ set_number_from_substraction (arg2, q->x_coord, p->x_coord);
+ ab_vs_cd (ab_vs_cd, dx, arg1, dy, arg2);
+ if (number_nonpositive(ab_vs_cd)) {
+ @<Remove knot |p| and back up |p| and |q| but don't go past |l|@>;
+ }
+ }
+ }
+ free_number (ab_vs_cd);
+ free_number (arg1);
+ free_number (arg2);
+}
+
+
+@ @<Remove knot |p| and back up |p| and |q| but don't go past |l|@>=
+{
+ s = mp_prev_knot (p);
+ mp_xfree (p);
+ mp_next_knot (s) = q;
+ mp_prev_knot (q) = s;
+ if (s == l) {
+ p = s;
+ } else {
+ p = mp_prev_knot (s);
+ q = s;
+ }
+}
+
+
+@ The |find_offset| procedure sets global variables |(cur_x,cur_y)| to the
+offset associated with the given direction |(x,y)|. If two different offsets
+apply, it chooses one of them.
+
+@c
+static void mp_find_offset (MP mp, mp_number x_orig, mp_number y_orig, mp_knot h) {
+ mp_knot p, q; /* consecutive knots */
+ if (pen_is_elliptical (h)) {
+ mp_fraction xx, yy; /* untransformed offset for an elliptical pen */
+ mp_number wx, wy, hx, hy; /* the transformation matrix for an elliptical pen */
+ mp_fraction d; /* a temporary register */
+ new_fraction(xx);
+ new_fraction(yy);
+ new_number(wx);
+ new_number(wy);
+ new_number(hx);
+ new_number(hy);
+ new_fraction(d);
+ @<Find the offset for |(x,y)| on the elliptical pen~|h|@>
+ free_number (xx);
+ free_number (yy);
+ free_number (wx);
+ free_number (wy);
+ free_number (hx);
+ free_number (hy);
+ free_number (d);
+ } else {
+ mp_number ab_vs_cd;
+ mp_number arg1, arg2;
+ new_number (arg1);
+ new_number (arg2);
+ new_number (ab_vs_cd);
+ q = h;
+ do {
+ p = q;
+ q = mp_next_knot (q);
+ set_number_from_substraction (arg1, q->x_coord, p->x_coord);
+ set_number_from_substraction (arg2, q->y_coord, p->y_coord);
+ ab_vs_cd (ab_vs_cd, arg1, y_orig, arg2, x_orig);
+ } while (number_negative(ab_vs_cd));
+ do {
+ p = q;
+ q = mp_next_knot (q);
+ set_number_from_substraction (arg1, q->x_coord, p->x_coord);
+ set_number_from_substraction (arg2, q->y_coord, p->y_coord);
+ ab_vs_cd (ab_vs_cd, arg1, y_orig, arg2, x_orig);
+ } while (number_positive(ab_vs_cd));
+ number_clone (mp->cur_x, p->x_coord);
+ number_clone (mp->cur_y, p->y_coord);
+ free_number (ab_vs_cd);
+ free_number (arg1);
+ free_number (arg2);
+ }
+}
+
+
+@ @<Glob...@>=
+mp_number cur_x;
+mp_number cur_y; /* all-purpose return value registers */
+
+@ @<Initialize table entries@>=
+new_number (mp->cur_x);
+new_number (mp->cur_y);
+
+@ @<Dealloc...@>=
+free_number (mp->cur_x);
+free_number (mp->cur_y);
+
+@ @<Find the offset for |(x,y)| on the elliptical pen~|h|@>=
+if (number_zero(x_orig) && number_zero(y_orig)) {
+ number_clone(mp->cur_x, h->x_coord);
+ number_clone(mp->cur_y, h->y_coord);
+} else {
+ mp_number x, y, abs_x, abs_y;
+ new_number(x);
+ new_number(y);
+ new_number(abs_x);
+ new_number(abs_y);
+ number_clone(x, x_orig);
+ number_clone(y, y_orig);
+ @<Find the non-constant part of the transformation for |h|@>;
+ number_clone(abs_x, x);
+ number_clone(abs_y, y);
+ number_abs(abs_x);
+ number_abs(abs_y);
+ while (number_less(abs_x, fraction_half_t) && number_less(abs_y, fraction_half_t)) {
+ number_double(x);
+ number_double(y);
+ number_clone(abs_x, x);
+ number_clone(abs_y, y);
+ number_abs(abs_x);
+ number_abs(abs_y);
+ }
+ @<Make |(xx,yy)| the offset on the untransformed \&{pencircle} for the
+ untransformed version of |(x,y)|@>;
+ {
+ mp_number r1, r2;
+ new_fraction (r1);
+ new_fraction (r2);
+ take_fraction (r1, xx, wx);
+ take_fraction (r2, yy, hx);
+ number_add(r1, r2);
+ set_number_from_addition(mp->cur_x, h->x_coord, r1);
+ take_fraction (r1, xx, wy);
+ take_fraction (r2, yy, hy);
+ number_add(r1, r2);
+ set_number_from_addition(mp->cur_y, h->y_coord, r1);
+ free_number (r1);
+ free_number (r2);
+ }
+ free_number(abs_x);
+ free_number(abs_y);
+ free_number(x);
+ free_number(y);
+}
+
+
+@ @<Find the non-constant part of the transformation for |h|@>=
+{
+ set_number_from_substraction(wx, h->left_x, h->x_coord);
+ set_number_from_substraction(wy, h->left_y, h->y_coord);
+ set_number_from_substraction(hx, h->right_x, h->x_coord);
+ set_number_from_substraction(hy, h->right_y, h->y_coord);
+}
+
+
+@ @<Make |(xx,yy)| the offset on the untransformed \&{pencircle} for the...@>=
+{
+ mp_number r1, r2, arg1;
+ new_number (arg1);
+ new_fraction (r1);
+ new_fraction (r2);
+ take_fraction (r1, x, hy);
+ number_clone (arg1, hx);
+ number_negate (arg1);
+ take_fraction (r2, y, arg1);
+ number_add (r1, r2);
+ number_negate (r1);
+ number_clone(yy, r1);
+ number_clone (arg1, wy);
+ number_negate (arg1);
+ take_fraction (r1, x, arg1);
+ take_fraction (r2, y, wx);
+ number_add (r1, r2);
+ number_clone(xx, r1);
+ free_number (arg1);
+ free_number (r1);
+ free_number (r2);
+}
+pyth_add (d, xx, yy);
+if (number_positive(d)) {
+ mp_number ret;
+ new_fraction (ret);
+ make_fraction (ret, xx, d);
+ number_half(ret);
+ number_clone(xx, ret);
+ make_fraction (ret, yy, d);
+ number_half(ret);
+ number_clone(yy, ret);
+ free_number (ret);
+}
+
+@ Finding the bounding box of a pen is easy except if the pen is elliptical.
+But we can handle that case by just calling |find_offset| twice. The answer
+is stored in the global variables |minx|, |maxx|, |miny|, and |maxy|.
+
+@c
+static void mp_pen_bbox (MP mp, mp_knot h) {
+ mp_knot p; /* for scanning the knot list */
+ if (pen_is_elliptical (h)) {
+ @<Find the bounding box of an elliptical pen@>;
+ } else {
+ number_clone (mp_minx, h->x_coord);
+ number_clone (mp_maxx, mp_minx);
+ number_clone (mp_miny, h->y_coord);
+ number_clone (mp_maxy, mp_miny);
+ p = mp_next_knot (h);
+ while (p != h) {
+ if (number_less (p->x_coord, mp_minx))
+ number_clone (mp_minx, p->x_coord);
+ if (number_less (p->y_coord, mp_miny))
+ number_clone (mp_miny, p->y_coord);
+ if (number_greater (p->x_coord, mp_maxx))
+ number_clone (mp_maxx, p->x_coord);
+ if (number_greater (p->y_coord, mp_maxy))
+ number_clone (mp_maxy, p->y_coord);
+ p = mp_next_knot (p);
+ }
+ }
+}
+
+
+@ @<Find the bounding box of an elliptical pen@>=
+{
+ mp_number arg1, arg2;
+ new_number(arg1);
+ new_fraction (arg2);
+ number_clone(arg2, fraction_one_t);
+ mp_find_offset (mp, arg1, arg2, h);
+ number_clone (mp_maxx, mp->cur_x);
+ number_clone (mp_minx, h->x_coord);
+ number_double (mp_minx);
+ number_substract (mp_minx, mp->cur_x);
+ number_negate (arg2);
+ mp_find_offset (mp, arg2, arg1, h);
+ number_clone (mp_maxy, mp->cur_y);
+ number_clone (mp_miny, h->y_coord);
+ number_double (mp_miny);
+ number_substract (mp_miny, mp->cur_y);
+ free_number(arg1);
+ free_number(arg2);
+}
+
+
+@* Numerical values.
+
+This first set goes into the header
+
+@<MPlib internal header stuff@>=
+#define mp_fraction mp_number
+#define mp_angle mp_number
+#define new_number(A) (((math_data *)(mp->math))->allocate)(mp, &(A), mp_scaled_type)
+#define new_fraction(A) (((math_data *)(mp->math))->allocate)(mp, &(A), mp_fraction_type)
+#define new_angle(A) (((math_data *)(mp->math))->allocate)(mp, &(A), mp_angle_type)
+#define free_number(A) (((math_data *)(mp->math))->free)(mp, &(A))
+
+@
+@d set_precision() (((math_data *)(mp->math))->set_precision)(mp)
+@d free_math() (((math_data *)(mp->math))->free_math)(mp)
+@d scan_numeric_token(A) (((math_data *)(mp->math))->scan_numeric)(mp, A)
+@d scan_fractional_token(A) (((math_data *)(mp->math))->scan_fractional)(mp, A)
+@d set_number_from_of_the_way(A,t,B,C) (((math_data *)(mp->math))->from_oftheway)(mp, &(A),t,B,C)
+@d set_number_from_int(A,B) (((math_data *)(mp->math))->from_int)(&(A),B)
+@d set_number_from_scaled(A,B) (((math_data *)(mp->math))->from_scaled)(&(A),B)
+@d set_number_from_boolean(A,B) (((math_data *)(mp->math))->from_boolean)(&(A),B)
+@d set_number_from_double(A,B) (((math_data *)(mp->math))->from_double)(&(A),B)
+@d set_number_from_addition(A,B,C) (((math_data *)(mp->math))->from_addition)(&(A),B,C)
+@d set_number_from_substraction(A,B,C) (((math_data *)(mp->math))->from_substraction)(&(A),B,C)
+@d set_number_from_div(A,B,C) (((math_data *)(mp->math))->from_div)(&(A),B,C)
+@d set_number_from_mul(A,B,C) (((math_data *)(mp->math))->from_mul)(&(A),B,C)
+@d number_int_div(A,C) (((math_data *)(mp->math))->from_int_div)(&(A),A,C)
+@d set_number_from_int_mul(A,B,C) (((math_data *)(mp->math))->from_int_mul)(&(A),B,C)
+@#
+@d set_number_to_unity(A) (((math_data *)(mp->math))->clone)(&(A), unity_t)
+@d set_number_to_zero(A) (((math_data *)(mp->math))->clone)(&(A), zero_t)
+@d set_number_to_inf(A) (((math_data *)(mp->math))->clone)(&(A), inf_t)
+@d set_number_to_neg_inf(A) do { set_number_to_inf(A); number_negate (A); } while (0)
+@#
+@d init_randoms(A) (((math_data *)(mp->math))->init_randoms)(mp,A)
+@d print_number(A) (((math_data *)(mp->math))->print)(mp,A)
+@d number_tostring(A) (((math_data *)(mp->math))->tostring)(mp,A)
+@d make_scaled(R,A,B) (((math_data *)(mp->math))->make_scaled)(mp,&(R),A,B)
+@d take_scaled(R,A,B) (((math_data *)(mp->math))->take_scaled)(mp,&(R),A,B)
+@d make_fraction(R,A,B) (((math_data *)(mp->math))->make_fraction)(mp,&(R),A,B)
+@d take_fraction(R,A,B) (((math_data *)(mp->math))->take_fraction)(mp,&(R),A,B)
+@d pyth_add(R,A,B) (((math_data *)(mp->math))->pyth_add)(mp,&(R),A,B)
+@d pyth_sub(R,A,B) (((math_data *)(mp->math))->pyth_sub)(mp,&(R),A,B)
+@d n_arg(R,A,B) (((math_data *)(mp->math))->n_arg)(mp,&(R),A,B)
+@d m_log(R,A) (((math_data *)(mp->math))->m_log)(mp,&(R),A)
+@d m_exp(R,A) (((math_data *)(mp->math))->m_exp)(mp,&(R),A)
+@d m_unif_rand(R,A) (((math_data *)(mp->math))->m_unif_rand)(mp,&(R),A)
+@d m_norm_rand(R) (((math_data *)(mp->math))->m_norm_rand)(mp,&(R))
+@d velocity(R,A,B,C,D,E) (((math_data *)(mp->math))->velocity)(mp,&(R),A,B,C,D,E)
+@d ab_vs_cd(R,A,B,C,D) (((math_data *)(mp->math))->ab_vs_cd)(mp,&(R),A,B,C,D)
+@d crossing_point(R,A,B,C) (((math_data *)(mp->math))->crossing_point)(mp,&(R),A,B,C)
+@d n_sin_cos(A,S,C) (((math_data *)(mp->math))->sin_cos)(mp,A,&(S),&(C))
+@d square_rt(A,S) (((math_data *)(mp->math))->sqrt)(mp,&(A),S)
+@d slow_add(R,A,B) (((math_data *)(mp->math))->slow_add)(mp,&(R),A,B)
+@d round_unscaled(A) (((math_data *)(mp->math))->round_unscaled)(A)
+@d floor_scaled(A) (((math_data *)(mp->math))->floor_scaled)(&(A))
+@d fraction_to_round_scaled(A) (((math_data *)(mp->math))->fraction_to_round_scaled)(&(A))
+@d number_to_int(A) (((math_data *)(mp->math))->to_int)(A)
+@d number_to_boolean(A) (((math_data *)(mp->math))->to_boolean)(A)
+@d number_to_scaled(A) (((math_data *)(mp->math))->to_scaled)(A)
+@d number_to_double(A) (((math_data *)(mp->math))->to_double)(A)
+@d number_negate(A) (((math_data *)(mp->math))->negate)(&(A))
+@d number_add(A,B) (((math_data *)(mp->math))->add)(&(A),B)
+@d number_substract(A,B) (((math_data *)(mp->math))->substract)(&(A),B)
+@d number_half(A) (((math_data *)(mp->math))->half)(&(A))
+@d number_halfp(A) (((math_data *)(mp->math))->halfp)(&(A))
+@d number_double(A) (((math_data *)(mp->math))->do_double)(&(A))
+@d number_add_scaled(A,B) (((math_data *)(mp->math))->add_scaled)(&(A),B)
+@d number_multiply_int(A,B) (((math_data *)(mp->math))->multiply_int)(&(A),B)
+@d number_divide_int(A,B) (((math_data *)(mp->math))->divide_int)(&(A),B)
+@d number_abs(A) (((math_data *)(mp->math))->abs)(&(A))
+@d number_modulo(A,B) (((math_data *)(mp->math))->modulo)(&(A), B)
+@d number_nonequalabs(A,B) (((math_data *)(mp->math))->nonequalabs)(A,B)
+@d number_odd(A) (((math_data *)(mp->math))->odd)(A)
+@d number_equal(A,B) (((math_data *)(mp->math))->equal)(A,B)
+@d number_greater(A,B) (((math_data *)(mp->math))->greater)(A,B)
+@d number_less(A,B) (((math_data *)(mp->math))->less)(A,B)
+@d number_clone(A,B) (((math_data *)(mp->math))->clone)(&(A),B)
+@d number_swap(A,B) (((math_data *)(mp->math))->swap)(&(A),&(B));
+@d convert_scaled_to_angle(A) (((math_data *)(mp->math))->scaled_to_angle)(&(A));
+@d convert_angle_to_scaled(A) (((math_data *)(mp->math))->angle_to_scaled)(&(A));
+@d convert_fraction_to_scaled(A) (((math_data *)(mp->math))->fraction_to_scaled)(&(A));
+@d convert_scaled_to_fraction(A) (((math_data *)(mp->math))->scaled_to_fraction)(&(A));
+@#
+@d number_zero(A) number_equal(A, zero_t)
+@d number_infinite(A) number_equal(A, inf_t)
+@d number_unity(A) number_equal(A, unity_t)
+@d number_negative(A) number_less(A, zero_t)
+@d number_nonnegative(A) (!number_negative(A))
+@d number_positive(A) number_greater(A, zero_t)
+@d number_nonpositive(A) (!number_positive(A))
+@d number_nonzero(A) (!number_zero(A))
+@d number_greaterequal(A,B) (!number_less(A,B))
+@d number_lessequal(A,B) (!number_greater(A,B))
+
+@* 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.
+
+@<MPlib header stuff@>=
+enum mp_graphical_object_code {
+ @<Graphical object codes@>
+ mp_final_graphic
+};
+
+@ Let's consider the types of graphical objects one at a time.
+First of all, a filled contour is represented by a eight-word node. The first
+word contains |type| and |link| fields, and the next six words contain a
+pointer to a cyclic path and the value to use for \ps' \&{currentrgbcolor}
+parameter. If a pen is used for filling |pen_p|, |ljoin| and |miterlim|
+give the relevant information.
+
+@d mp_path_p(A) (A)->path_p_ /* a pointer to the path that needs filling */
+@d mp_pen_p(A) (A)->pen_p_ /* a pointer to the pen to fill or stroke with */
+@d mp_color_model(A) ((mp_fill_node)(A))->color_model_ /* the color model */
+@d cyan red
+@d grey red
+@d magenta green
+@d yellow blue
+@d mp_pre_script(A) ((mp_fill_node)(A))->pre_script_
+@d mp_post_script(A) ((mp_fill_node)(A))->post_script_
+
+@<MPlib internal header stuff@>=
+typedef struct mp_fill_node_data {
+ NODE_BODY;
+ halfword color_model_;
+ mp_number red;
+ mp_number green;
+ mp_number blue;
+ mp_number black;
+ mp_string pre_script_;
+ mp_string post_script_;
+ mp_knot path_p_;
+ mp_knot pen_p_;
+ unsigned char ljoin;
+ mp_number miterlim;
+} mp_fill_node_data;
+typedef struct mp_fill_node_data *mp_fill_node;
+
+@ @<Graphical object codes@>=
+mp_fill_code = 1,
+
+@ Make a fill node for cyclic path |p| and color black.
+
+@d fill_node_size sizeof(struct mp_fill_node_data)
+
+@c
+static mp_node mp_new_fill_node (MP mp, mp_knot p) {
+ mp_fill_node t = malloc_node (fill_node_size);
+ mp_type (t) = mp_fill_node_type;
+ mp_path_p (t) = p;
+ mp_pen_p (t) = NULL; /* |NULL| means don't use a pen */
+ new_number(t->red);
+ new_number(t->green);
+ new_number(t->blue);
+ new_number(t->black);
+ new_number(t->miterlim);
+ clear_color (t);
+ mp_color_model (t) = mp_uninitialized_model;
+ mp_pre_script (t) = NULL;
+ mp_post_script (t) = NULL;
+ /* Set the |ljoin| and |miterlim| fields in object |t| */
+ if (number_greater(internal_value (mp_linejoin), unity_t))
+ t->ljoin = 2;
+ else if (number_positive(internal_value (mp_linejoin)))
+ t->ljoin = 1;
+ else
+ t->ljoin = 0;
+ if (number_less(internal_value (mp_miterlimit), unity_t)) {
+ set_number_to_unity(t->miterlim);
+ } else {
+ number_clone(t->miterlim,internal_value (mp_miterlimit));
+ }
+ return (mp_node) t;
+}
+
+@ @c
+static void mp_free_fill_node (MP mp, mp_fill_node p) {
+ mp_toss_knot_list (mp, mp_path_p (p));
+ if (mp_pen_p (p) != NULL)
+ mp_toss_knot_list (mp, mp_pen_p (p));
+ if (mp_pre_script (p) != NULL)
+ delete_str_ref (mp_pre_script (p));
+ if (mp_post_script (p) != NULL)
+ delete_str_ref (mp_post_script (p));
+ free_number(p->red);
+ free_number(p->green);
+ free_number(p->blue);
+ free_number(p->black);
+ free_number(p->miterlim);
+ mp_free_node (mp, (mp_node)p, fill_node_size);
+}
+
+
+
+@ 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 mp_dash_p(A) ((mp_stroked_node)(A))->dash_p_ /* a pointer to the edge structure that gives the dash pattern */
+
+@<MPlib internal header stuff@>=
+typedef struct mp_stroked_node_data {
+ NODE_BODY;
+ halfword color_model_;
+ mp_number red;
+ mp_number green;
+ mp_number blue;
+ mp_number black;
+ mp_string pre_script_;
+ mp_string post_script_;
+ mp_knot path_p_;
+ mp_knot pen_p_;
+ unsigned char ljoin;
+ mp_number miterlim;
+ unsigned char lcap;
+ mp_node dash_p_;
+ mp_number dash_scale;
+} mp_stroked_node_data;
+typedef struct mp_stroked_node_data *mp_stroked_node;
+
+
+@ @<Graphical object codes@>=
+mp_stroked_code = 2,
+
+@ Make a stroked node for path |p| with |mp_pen_p(p)| temporarily |NULL|.
+
+@d stroked_node_size sizeof(struct mp_stroked_node_data)
+
+@c
+static mp_node mp_new_stroked_node (MP mp, mp_knot p) {
+ mp_stroked_node t = malloc_node (stroked_node_size);
+ mp_type (t) = mp_stroked_node_type;
+ mp_path_p (t) = p;
+ mp_pen_p (t) = NULL;
+ mp_dash_p (t) = NULL;
+ new_number(t->dash_scale);
+ set_number_to_unity(t->dash_scale);
+ new_number(t->red);
+ new_number(t->green);
+ new_number(t->blue);
+ new_number(t->black);
+ new_number(t->miterlim);
+ clear_color(t);
+ mp_pre_script (t) = NULL;
+ mp_post_script (t) = NULL;
+ /* Set the |ljoin| and |miterlim| fields in object |t| */
+ if (number_greater(internal_value (mp_linejoin), unity_t))
+ t->ljoin = 2;
+ else if (number_positive(internal_value (mp_linejoin)))
+ t->ljoin = 1;
+ else
+ t->ljoin = 0;
+ if (number_less(internal_value (mp_miterlimit), unity_t)) {
+ set_number_to_unity(t->miterlim);
+ } else {
+ number_clone(t->miterlim,internal_value (mp_miterlimit));
+ }
+ if (number_greater(internal_value (mp_linecap), unity_t))
+ t->lcap = 2;
+ else if (number_positive(internal_value (mp_linecap)))
+ t->lcap = 1;
+ else
+ t->lcap = 0;
+ return (mp_node) t;
+}
+
+@ @c
+static mp_edge_header_node mp_free_stroked_node (MP mp, mp_stroked_node p) {
+ mp_edge_header_node e = NULL;
+ mp_toss_knot_list (mp, mp_path_p (p));
+ if (mp_pen_p (p) != NULL)
+ mp_toss_knot_list (mp, mp_pen_p (p));
+ if (mp_pre_script (p) != NULL)
+ delete_str_ref (mp_pre_script (p));
+ if (mp_post_script (p) != NULL)
+ delete_str_ref (mp_post_script (p));
+ e = (mp_edge_header_node)mp_dash_p (p);
+ free_number(p->dash_scale);
+ free_number(p->red);
+ free_number(p->green);
+ free_number(p->blue);
+ free_number(p->black);
+ free_number(p->miterlim);
+ mp_free_node (mp, (mp_node)p, stroked_node_size);
+ return e;
+}
+
+@ 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|.
+
+@ @c
+void mp_sqrt_det (MP mp, mp_number *ret, mp_number a_orig, mp_number b_orig, mp_number c_orig, mp_number d_orig) {
+ mp_number a,b,c,d;
+ mp_number maxabs; /* $max(|a|,|b|,|c|,|d|)$ */
+ unsigned s; /* amount by which the result of |square_rt| needs to be scaled */
+ new_number(a);
+ new_number(b);
+ new_number(c);
+ new_number(d);
+ new_number(maxabs);
+ number_clone(a, a_orig);
+ number_clone(b, b_orig);
+ number_clone(c, c_orig);
+ number_clone(d, d_orig);
+ /* Initialize |maxabs| */
+ {
+ mp_number tmp;
+ new_number (tmp);
+ number_clone(maxabs, a);
+ number_abs(maxabs);
+ number_clone(tmp, b);
+ number_abs(tmp);
+ if (number_greater(tmp, maxabs))
+ number_clone(maxabs, tmp);
+ number_clone(tmp, c);
+ number_abs(tmp);
+ if (number_greater(tmp, maxabs))
+ number_clone(maxabs, tmp);
+ number_clone(tmp, d);
+ number_abs(tmp);
+ if (number_greater(tmp, maxabs))
+ number_clone(maxabs, tmp);
+ free_number(tmp);
+ }
+
+
+ s = 64;
+ while ((number_less(maxabs, fraction_one_t)) && (s > 1)) {
+ number_double(a);
+ number_double(b);
+ number_double(c);
+ number_double(d);
+ number_double(maxabs);
+ s = s/2;
+ }
+ {
+ mp_number r1, r2;
+ new_fraction (r1);
+ new_fraction (r2);
+ take_fraction (r1, a, d);
+ take_fraction (r2, b, c);
+ number_substract (r1, r2);
+ number_abs (r1);
+ square_rt(*ret, r1);
+ number_multiply_int(*ret, s);
+ free_number (r1);
+ free_number (r2);
+ }
+ free_number(a);
+ free_number(b);
+ free_number(c);
+ free_number(d);
+ free_number(maxabs);
+}
+@#
+static void mp_get_pen_scale (MP mp, mp_number *ret, mp_knot p) {
+ if (p == NULL) {
+ set_number_to_zero(*ret);
+ } else {
+ mp_number a,b,c,d;
+ new_number(a);
+ new_number(b);
+ new_number(c);
+ new_number(d);
+ set_number_from_substraction(a, p->left_x, p->x_coord);
+ set_number_from_substraction(b, p->right_x, p->x_coord);
+ set_number_from_substraction(c, p->left_y, p->y_coord);
+ set_number_from_substraction(d, p->right_y, p->y_coord);
+ mp_sqrt_det (mp, ret, a, b, c, d);
+ free_number(a);
+ free_number(b);
+ free_number(c);
+ free_number(d);
+ }
+}
+
+
+@ @<Declarations@>=
+static void mp_sqrt_det (MP mp, mp_number *ret, mp_number a, mp_number b, mp_number c, mp_number 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 |mp_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 mp_text_p(A) ((mp_text_node)(A))->text_p_ /* a string pointer for the text to display */
+@d mp_font_n(A) ((mp_text_node)(A))->font_n_ /* the font number */
+
+@<MPlib internal header stuff@>=
+typedef struct mp_text_node_data {
+ NODE_BODY;
+ halfword color_model_;
+ mp_number red;
+ mp_number green;
+ mp_number blue;
+ mp_number black;
+ mp_string pre_script_;
+ mp_string post_script_;
+ mp_string text_p_;
+ halfword font_n_;
+ mp_number width;
+ mp_number height;
+ mp_number depth;
+ mp_number tx;
+ mp_number ty;
+ mp_number txx;
+ mp_number txy;
+ mp_number tyx;
+ mp_number tyy;
+} mp_text_node_data;
+typedef struct mp_text_node_data *mp_text_node;
+
+@ @<Graphical object codes@>=
+mp_text_code = 3,
+
+@ Make a text node for font |f| and text string |s|.
+
+@d text_node_size sizeof(struct mp_text_node_data)
+
+@c
+static mp_node mp_new_text_node (MP mp, char *f, mp_string s) {
+ mp_text_node t = malloc_node (text_node_size);
+ mp_type (t) = mp_text_node_type;
+ mp_text_p (t) = s;
+ add_str_ref(s);
+ mp_font_n (t) = (halfword) mp_find_font (mp, f); /* this identifies the font */
+ new_number(t->red);
+ new_number(t->green);
+ new_number(t->blue);
+ new_number(t->black);
+ new_number(t->width);
+ new_number(t->height);
+ new_number(t->depth);
+ clear_color (t);
+ mp_pre_script (t) = NULL;
+ mp_post_script (t) = NULL;
+ new_number(t->tx);
+ new_number(t->ty);
+ new_number(t->txx);
+ new_number(t->txy);
+ new_number(t->tyx);
+ new_number(t->tyy);
+ /* |tx_val (t) = 0; ty_val (t) = 0;| */
+ /* |txy_val (t) = 0; tyx_val (t) = 0;| */
+ set_number_to_unity(t->txx);
+ set_number_to_unity(t->tyy);
+ mp_set_text_box (mp, t); /* this finds the bounding box */
+ return (mp_node) t;
+}
+
+@ @c
+static void mp_free_text_node (MP mp, mp_text_node p) {
+ /* |delete_str_ref (mp_text_p (p));| */ /* gives errors */
+ if (mp_pre_script (p) != NULL)
+ delete_str_ref (mp_pre_script (p));
+ if (mp_post_script (p) != NULL)
+ delete_str_ref (mp_post_script (p));
+ free_number(p->red);
+ free_number(p->green);
+ free_number(p->blue);
+ free_number(p->black);
+ free_number(p->width);
+ free_number(p->height);
+ free_number(p->depth);
+ free_number(p->tx);
+ free_number(p->ty);
+ free_number(p->txx);
+ free_number(p->txy);
+ free_number(p->tyx);
+ free_number(p->tyy);
+ mp_free_node (mp, (mp_node)p, text_node_size);
+}
+
+@ 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
+node whose |path_p| gives the relevant path, then there is the list
+of objects to clip or bound followed by a closing node.
+
+@d has_color(A) (mp_type((A))<mp_start_clip_node_type)
+ /* does a graphical object have color fields? */
+@d has_pen(A) (mp_type((A))<mp_text_node_type)
+ /* does a graphical object have a |mp_pen_p| field? */
+@d is_start_or_stop(A) (mp_type((A))>=mp_start_clip_node_type)
+@d is_stop(A) (mp_type((A))>=mp_stop_clip_node_type)
+
+@<MPlib internal header stuff@>=
+typedef struct mp_start_clip_node_data {
+ NODE_BODY;
+ mp_knot path_p_;
+} mp_start_clip_node_data;
+typedef struct mp_start_clip_node_data *mp_start_clip_node;
+typedef struct mp_start_bounds_node_data {
+ NODE_BODY;
+ mp_knot path_p_;
+} mp_start_bounds_node_data;
+typedef struct mp_start_bounds_node_data *mp_start_bounds_node;
+typedef struct mp_stop_clip_node_data {
+ NODE_BODY;
+} mp_stop_clip_node_data;
+typedef struct mp_stop_clip_node_data *mp_stop_clip_node;
+typedef struct mp_stop_bounds_node_data {
+ NODE_BODY;
+} mp_stop_bounds_node_data;
+typedef struct mp_stop_bounds_node_data *mp_stop_bounds_node;
+
+
+@ @<Graphical object codes@>=
+mp_start_clip_code = 4, /* |type| of a node that starts clipping */
+ mp_start_bounds_code = 5, /* |type| of a node that gives a \&{setbounds} path */
+ mp_stop_clip_code = 6, /* |type| of a node that stops clipping */
+ mp_stop_bounds_code = 7, /* |type| of a node that stops \&{setbounds} */
+
+
+@
+
+@d start_clip_size sizeof(struct mp_start_clip_node_data)
+@d stop_clip_size sizeof(struct mp_stop_clip_node_data)
+@d start_bounds_size sizeof(struct mp_start_bounds_node_data)
+@d stop_bounds_size sizeof(struct mp_stop_bounds_node_data)
+
+@c
+static mp_node mp_new_bounds_node (MP mp, mp_knot p, quarterword c) {
+ /* make a node of type |c| where |p| is the clipping or \&{setbounds} path */
+ if (c == mp_start_clip_node_type) {
+ mp_start_clip_node t; /* the new node */
+ t = (mp_start_clip_node) malloc_node (start_clip_size);
+ t->path_p_ = p;
+ mp_type (t) = c;
+ t->link = NULL;
+ return (mp_node) t;
+ } else if (c == mp_start_bounds_node_type) {
+ mp_start_bounds_node t; /* the new node */
+ t = (mp_start_bounds_node) malloc_node (start_bounds_size);
+ t->path_p_ = p;
+ mp_type (t) = c;
+ t->link = NULL;
+ return (mp_node) t;
+ } else if (c == mp_stop_clip_node_type) {
+ mp_stop_clip_node t; /* the new node */
+ t = (mp_stop_clip_node) malloc_node (stop_clip_size);
+ mp_type (t) = c;
+ t->link = NULL;
+ return (mp_node) t;
+ } else if (c == mp_stop_bounds_node_type) {
+ mp_stop_bounds_node t; /* the new node */
+ t = (mp_stop_bounds_node) malloc_node (stop_bounds_size);
+ mp_type (t) = c;
+ t->link = NULL;
+ return (mp_node) t;
+ } else {
+ assert (0);
+ }
+ return NULL;
+}
+
+
+@ @c
+static void mp_free_start_clip_node (MP mp, mp_start_clip_node p) {
+ mp_toss_knot_list (mp, mp_path_p (p));
+ mp_free_node (mp, (mp_node)p, start_clip_size);
+}
+static void mp_free_start_bounds_node (MP mp, mp_start_bounds_node p) {
+ mp_toss_knot_list (mp, mp_path_p (p));
+ mp_free_node (mp, (mp_node)p, start_bounds_size);
+}
+static void mp_free_stop_clip_node (MP mp, mp_stop_clip_node p) {
+ mp_free_node (mp, (mp_node)p, stop_clip_size);
+}
+static void mp_free_stop_bounds_node (MP mp, mp_stop_bounds_node p) {
+ mp_free_node (mp, (mp_node)p, 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.
+
+The |dash_info| is explained below.
+
+@d dash_list(A) (mp_dash_node)(((mp_dash_node)(A))->link) /* in an edge header this points to the first dash node */
+@d set_dash_list(A,B) ((mp_dash_node)(A))->link=(mp_node)((B)) /* in an edge header this points to the first dash node */
+
+@<MPlib internal header stuff@>=
+typedef struct mp_dash_node_data {
+ NODE_BODY;
+ mp_number start_x; /* the starting $x$~coordinate in a dash node */
+ mp_number stop_x; /* the ending $x$~coordinate in a dash node */
+ mp_number dash_y; /* $y$ value for the dash list in an edge header */
+ mp_node dash_info_;
+} mp_dash_node_data;
+
+@ @<Types...@>=
+typedef struct mp_dash_node_data *mp_dash_node;
+
+@ @<Initialize table entries@>=
+mp->null_dash = mp_get_dash_node (mp);
+
+@ @<Free table entries@>=
+mp_free_node (mp, (mp_node)mp->null_dash, dash_node_size);
+
+@
+@d dash_node_size sizeof(struct mp_dash_node_data)
+
+@c
+static mp_dash_node mp_get_dash_node (MP mp) {
+ mp_dash_node p = (mp_dash_node) malloc_node (dash_node_size);
+ p->has_number = 0;
+ new_number(p->start_x);
+ new_number(p->stop_x);
+ new_number(p->dash_y);
+ mp_type (p) = mp_dash_node_type;
+ return p;
+}
+
+
+@ It is also convenient for an edge header to contain the bounding
+box information needed by the \&{llcorner} and \&{urcorner} operators
+so that this does not have to be recomputed unnecessarily. This is done by
+adding fields for the $x$~and $y$ extremes as well as a pointer that indicates
+how far the bounding box computation has gotten. Thus if the user asks for
+the bounding box and then adds some more text to the picture before asking
+for more bounding box information, the second computation need only look at
+the additional text.
+
+When the bounding box has not been computed, the |bblast| pointer points
+to a dummy link at the head of the graphical object list while the |minx_val|
+and |miny_val| fields contain |EL_GORDO| and the |maxx_val| and |maxy_val|
+fields contain |-EL_GORDO|.
+
+Since the bounding box of pictures containing objects of type
+|mp_start_bounds_node| depends on the value of \&{truecorners}, the bounding box
+@:mp_true_corners_}{\&{truecorners} primitive@>
+data might not be valid for all values of this parameter. Hence, the |bbtype|
+field is needed to keep track of this.
+
+@d bblast(A) ((mp_edge_header_node)(A))->bblast_ /* last item considered in bounding box computation */
+@d edge_list(A) ((mp_edge_header_node)(A))->list_ /* where the object list begins in an edge header */
+
+@<MPlib internal header stuff@>=
+typedef struct mp_edge_header_node_data {
+ NODE_BODY;
+ mp_number start_x;
+ mp_number stop_x;
+ mp_number dash_y;
+ mp_node dash_info_;
+ mp_number minx;
+ mp_number miny;
+ mp_number maxx;
+ mp_number maxy;
+ mp_node bblast_;
+ int bbtype; /* tells how bounding box data depends on \&{truecorners} */
+ mp_node list_;
+ mp_node obj_tail_; /* explained below */
+ halfword ref_count_; /* explained below */
+} mp_edge_header_node_data;
+typedef struct mp_edge_header_node_data *mp_edge_header_node;
+
+@
+@d no_bounds 0 /* |bbtype| value when bounding box data is valid for all \&{truecorners} values */
+@d bounds_set 1 /* |bbtype| value when bounding box data is for \&{truecorners}${}\le 0$ */
+@d bounds_unset 2 /* |bbtype| value when bounding box data is for \&{truecorners}${}>0$ */
+@c
+static void mp_init_bbox (MP mp, mp_edge_header_node h) {
+ /* Initialize the bounding box information in edge structure |h| */
+ (void) mp;
+ bblast (h) = edge_list (h);
+ h->bbtype = no_bounds;
+ set_number_to_inf(h->minx);
+ set_number_to_inf(h->miny);
+ set_number_to_neg_inf(h->maxx);
+ set_number_to_neg_inf(h->maxy);
+}
+
+
+@ The only other entries in an edge header are a reference count in the first
+word and a pointer to the tail of the object list in the last word.
+
+@d obj_tail(A) ((mp_edge_header_node)(A))->obj_tail_ /* points to the last entry in the object list */
+@d edge_ref_count(A) ((mp_edge_header_node)(A))->ref_count_
+
+@d edge_header_size sizeof(struct mp_edge_header_node_data)
+
+@c
+static mp_edge_header_node mp_get_edge_header_node (MP mp) {
+ mp_edge_header_node p = (mp_edge_header_node) malloc_node (edge_header_size);
+ mp_type (p) = mp_edge_header_node_type;
+ new_number(p->start_x);
+ new_number(p->stop_x);
+ new_number(p->dash_y);
+ new_number(p->minx);
+ new_number(p->miny);
+ new_number(p->maxx);
+ new_number(p->maxy);
+ p->list_ = mp_get_token_node (mp); /* or whatever, just a need a link handle */
+ return p;
+}
+static void mp_init_edges (MP mp, mp_edge_header_node h) {
+ /* initialize an edge header to NULL values */
+ set_dash_list (h, mp->null_dash);
+ obj_tail (h) = edge_list (h);
+ mp_link (edge_list (h)) = NULL;
+ edge_ref_count (h) = 0;
+ mp_init_bbox (mp, h);
+}
+
+
+@ Here is how edge structures are deleted. The process can be recursive because
+of the need to dereference edge structures that are used as dash patterns.
+@^recursion@>
+
+@d add_edge_ref(A) incr(edge_ref_count((A)))
+@d delete_edge_ref(A) {
+ if ( edge_ref_count((A))==0 )
+ mp_toss_edges(mp, (mp_edge_header_node)(A));
+ else
+ decr(edge_ref_count((A)));
+ }
+
+@<Declarations@>=
+static void mp_flush_dash_list (MP mp, mp_edge_header_node h);
+static mp_edge_header_node mp_toss_gr_object (MP mp, mp_node p);
+static void mp_toss_edges (MP mp, mp_edge_header_node h);
+
+@ @c
+void mp_toss_edges (MP mp, mp_edge_header_node h) {
+ mp_node p, q; /* pointers that scan the list being recycled */
+ mp_edge_header_node r; /* an edge structure that object |p| refers to */
+ mp_flush_dash_list (mp, h);
+ q = mp_link (edge_list (h));
+ while ((q != NULL)) {
+ p = q;
+ q = mp_link (q);
+ r = mp_toss_gr_object (mp, p);
+ if (r != NULL)
+ delete_edge_ref (r);
+ }
+ free_number(h->start_x);
+ free_number(h->stop_x);
+ free_number(h->dash_y);
+ free_number(h->minx);
+ free_number(h->miny);
+ free_number(h->maxx);
+ free_number(h->maxy);
+ mp_free_token_node (mp, h->list_);
+ mp_free_node (mp, (mp_node)h, edge_header_size);
+}
+void mp_flush_dash_list (MP mp, mp_edge_header_node h) {
+ mp_dash_node p, q; /* pointers that scan the list being recycled */
+ q = dash_list (h);
+ while (q != mp->null_dash) { /* todo: NULL check should not be needed */
+ p = q;
+ q = (mp_dash_node)mp_link (q);
+ mp_free_node (mp, (mp_node)p, dash_node_size);
+ }
+ set_dash_list (h,mp->null_dash);
+}
+mp_edge_header_node mp_toss_gr_object (MP mp, mp_node p) {
+ /* returns an edge structure that needs to be dereferenced */
+ mp_edge_header_node e = NULL; /* the edge structure to return */
+ switch (mp_type (p)) {
+ case mp_fill_node_type:
+ mp_free_fill_node (mp, (mp_fill_node)p);
+ break;
+ case mp_stroked_node_type:
+ e = mp_free_stroked_node (mp, (mp_stroked_node)p);
+ break;
+ case mp_text_node_type:
+ mp_free_text_node(mp, (mp_text_node)p);
+ break;
+ case mp_start_clip_node_type:
+ mp_free_start_clip_node(mp, (mp_start_clip_node)p);
+ break;
+ case mp_start_bounds_node_type:
+ mp_free_start_bounds_node(mp, (mp_start_bounds_node)p);
+ break;
+ case mp_stop_clip_node_type:
+ mp_free_stop_clip_node(mp, (mp_stop_clip_node)p);
+ break;
+ case mp_stop_bounds_node_type:
+ mp_free_stop_bounds_node(mp, (mp_stop_bounds_node)p);
+ break;
+ default: /* there are no other valid cases, but please the compiler */
+ break;
+ }
+ return e;
+}
+
+
+@ If we use |add_edge_ref| to ``copy'' edge structures, the real copying needs
+to be done before making a significant change to an edge structure. Much of
+the work is done in a separate routine |copy_objects| that copies a list of
+graphical objects into a new edge header.
+
+@c
+static mp_edge_header_node mp_private_edges (MP mp, mp_edge_header_node h) {
+ /* make a private copy of the edge structure headed by |h| */
+ mp_edge_header_node hh; /* the edge header for the new copy */
+ mp_dash_node p, pp; /* pointers for copying the dash list */
+ assert (mp_type (h) == mp_edge_header_node_type);
+ if (edge_ref_count (h) == 0) {
+ return h;
+ } else {
+ decr (edge_ref_count (h));
+ hh = (mp_edge_header_node)mp_copy_objects (mp, mp_link (edge_list (h)), NULL);
+ @<Copy the dash list from |h| to |hh|@>;
+ @<Copy the bounding box information from |h| to |hh| and make |bblast(hh)|
+ point into the new object list@>;
+ return hh;
+ }
+}
+
+
+@ Here we use the fact that |dash_list(hh)=mp_link(hh)|.
+@^data structure assumptions@>
+
+@<Copy the dash list from |h| to |hh|@>=
+pp = (mp_dash_node)hh;
+p = dash_list (h);
+while ((p != mp->null_dash)) {
+ mp_link (pp) = (mp_node)mp_get_dash_node (mp);
+ pp = (mp_dash_node)mp_link (pp);
+ number_clone(pp->start_x, p->start_x);
+ number_clone(pp->stop_x, p->stop_x);
+ p = (mp_dash_node)mp_link (p);
+}
+mp_link (pp) = (mp_node)mp->null_dash;
+number_clone(hh->dash_y, h->dash_y )
+
+
+@ |h| is an edge structure
+
+@c
+static mp_dash_object *mp_export_dashes (MP mp, mp_stroked_node q, mp_number w) {
+ mp_dash_object *d;
+ mp_dash_node p, h;
+ mp_number scf; /* scale factor */
+ mp_number dashoff;
+ double *dashes = NULL;
+ int num_dashes = 1;
+ h = (mp_dash_node)mp_dash_p (q);
+ if (h == NULL || dash_list (h) == mp->null_dash)
+ return NULL;
+ new_number (scf);
+ p = dash_list (h);
+ mp_get_pen_scale (mp, &scf, mp_pen_p (q));
+ if (number_zero(scf)) {
+ if (number_zero(w)) {
+ number_clone(scf, q->dash_scale);
+ } else {
+ free_number(scf);
+ return NULL;
+ }
+ } else {
+ mp_number ret;
+ new_number (ret);
+ make_scaled (ret, w, scf);
+ take_scaled (scf, ret, q->dash_scale);
+ free_number (ret);
+ }
+ number_clone(w, scf);
+ d = xmalloc (1, sizeof (mp_dash_object));
+ add_var_used (sizeof (mp_dash_object));
+ set_number_from_addition(mp->null_dash->start_x, p->start_x, h->dash_y);
+ {
+ mp_number ret, arg1;
+ new_number (ret);
+ new_number (arg1);
+ new_number (dashoff);
+ while (p != mp->null_dash) {
+ dashes = xrealloc (dashes, (num_dashes + 2), sizeof (double));
+ set_number_from_substraction (arg1, p->stop_x, p->start_x);
+ take_scaled (ret, arg1, scf);
+ dashes[(num_dashes - 1)] = number_to_double (ret);
+ set_number_from_substraction (arg1, ((mp_dash_node)mp_link (p))->start_x, p->stop_x);
+ take_scaled (ret, arg1, scf);
+ dashes[(num_dashes)] = number_to_double (ret);
+ dashes[(num_dashes + 1)] = -1.0; /* terminus */
+ num_dashes += 2;
+ p = (mp_dash_node)mp_link (p);
+ }
+ d->array = dashes;
+ mp_dash_offset (mp, &dashoff, h);
+ take_scaled (ret, dashoff, scf);
+ d->offset = number_to_double(ret);
+ free_number (ret);
+ free_number (arg1);
+ }
+ free_number (dashoff);
+ free_number(scf);
+ return d;
+}
+
+
+@ @<Copy the bounding box information from |h| to |hh|...@>=
+number_clone(hh->minx, h->minx);
+number_clone(hh->miny, h->miny);
+number_clone(hh->maxx, h->maxx);
+number_clone(hh->maxy, h->maxy);
+hh->bbtype = h->bbtype;
+p = (mp_dash_node)edge_list (h);
+pp = (mp_dash_node)edge_list (hh);
+while ((p != (mp_dash_node)bblast (h))) {
+ if (p == NULL)
+ mp_confusion (mp, "bblast");
+@:this can't happen bblast}{\quad bblast@>;
+ p = (mp_dash_node)mp_link (p);
+ pp = (mp_dash_node)mp_link (pp);
+}
+bblast (hh) = (mp_node)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|.
+
+@<Declarations@>=
+static mp_edge_header_node mp_copy_objects (MP mp, mp_node p, mp_node q);
+
+@ @c
+mp_edge_header_node mp_copy_objects (MP mp, mp_node p, mp_node q) {
+ mp_edge_header_node hh; /* the new edge header */
+ mp_node pp; /* the last newly copied object */
+ quarterword k = 0; /* temporary register */
+ hh = mp_get_edge_header_node (mp);
+ set_dash_list (hh, mp->null_dash);
+ edge_ref_count (hh) = 0;
+ pp = edge_list (hh);
+ while (p != q) {
+ @<Make |mp_link(pp)| point to a copy of object |p|, and update |p| and |pp|@>;
+ }
+ obj_tail (hh) = pp;
+ mp_link (pp) = NULL;
+ return hh;
+}
+
+
+@ @<Make |mp_link(pp)| point to a copy of object |p|, and update |p| and |pp|@>=
+{
+ switch (mp_type (p)) {
+ case mp_start_clip_node_type:
+ k = start_clip_size;
+ break;
+ case mp_start_bounds_node_type:
+ k = start_bounds_size;
+ break;
+ case mp_fill_node_type:
+ k = fill_node_size;
+ break;
+ case mp_stroked_node_type:
+ k = stroked_node_size;
+ break;
+ case mp_text_node_type:
+ k = text_node_size;
+ break;
+ case mp_stop_clip_node_type:
+ k = stop_clip_size;
+ break;
+ case mp_stop_bounds_node_type:
+ k = stop_bounds_size;
+ break;
+ default: /* there are no other valid cases, but please the compiler */
+ break;
+ }
+ mp_link (pp) = malloc_node ((size_t) k); /* |gr_object| */
+ pp = mp_link (pp);
+ memcpy (pp, p, (size_t) k);
+ pp->link = NULL;
+ @<Fix anything in graphical object |pp| that should differ from the
+ corresponding field in |p|@>;
+ p = mp_link (p);
+}
+
+
+@ @<Fix anything in graphical object |pp| that should differ from the...@>=
+switch (mp_type (p)) {
+case mp_start_clip_node_type:
+ {
+ mp_start_clip_node tt = (mp_start_clip_node)pp;
+ mp_start_clip_node t = (mp_start_clip_node)p;
+ mp_path_p (tt) = mp_copy_path (mp, mp_path_p (t));
+ }
+ break;
+case mp_start_bounds_node_type:
+ {
+ mp_start_bounds_node tt = (mp_start_bounds_node)pp;
+ mp_start_bounds_node t = (mp_start_bounds_node)p;
+ mp_path_p (tt) = mp_copy_path (mp, mp_path_p (t));
+ }
+ break;
+case mp_fill_node_type:
+ {
+ mp_fill_node tt = (mp_fill_node)pp;
+ mp_fill_node t = (mp_fill_node)p;
+ new_number(tt->red); number_clone(tt->red, t->red);
+ new_number(tt->green); number_clone(tt->green, t->green);
+ new_number(tt->blue); number_clone(tt->blue, t->blue);
+ new_number(tt->black); number_clone(tt->black, t->black);
+ new_number(tt->miterlim); number_clone(tt->miterlim,t->miterlim);
+ mp_path_p (tt) = mp_copy_path (mp, mp_path_p (t));
+ if (mp_pre_script (p) != NULL)
+ add_str_ref (mp_pre_script (p));
+ if (mp_post_script (p) != NULL)
+ add_str_ref (mp_post_script (p));
+ if (mp_pen_p (t) != NULL)
+ mp_pen_p (tt) = copy_pen (mp_pen_p (t));
+ }
+ break;
+case mp_stroked_node_type:
+ {
+ mp_stroked_node tt = (mp_stroked_node)pp;
+ mp_stroked_node t = (mp_stroked_node)p;
+ new_number(tt->red); number_clone(tt->red, t->red);
+ new_number(tt->green); number_clone(tt->green, t->green);
+ new_number(tt->blue); number_clone(tt->blue, t->blue);
+ new_number(tt->black); number_clone(tt->black, t->black);
+ new_number(tt->miterlim); number_clone(tt->miterlim,t->miterlim);
+ new_number(tt->dash_scale); number_clone(tt->dash_scale,t->dash_scale);
+ if (mp_pre_script (p) != NULL)
+ add_str_ref (mp_pre_script (p));
+ if (mp_post_script (p) != NULL)
+ add_str_ref (mp_post_script (p));
+ mp_path_p (tt) = mp_copy_path (mp, mp_path_p (t));
+ mp_pen_p (tt) = copy_pen (mp_pen_p (t));
+ if (mp_dash_p (p) != NULL)
+ add_edge_ref (mp_dash_p (pp));
+ }
+ break;
+case mp_text_node_type:
+ {
+ mp_text_node tt = (mp_text_node)pp;
+ mp_text_node t = (mp_text_node)p;
+ new_number(tt->red); number_clone(tt->red, t->red);
+ new_number(tt->green); number_clone(tt->green, t->green);
+ new_number(tt->blue); number_clone(tt->blue, t->blue);
+ new_number(tt->black); number_clone(tt->black, t->black);
+ new_number(tt->width); number_clone(tt->width, t->width);
+ new_number(tt->height); number_clone(tt->height, t->height);
+ new_number(tt->depth); number_clone(tt->depth, t->depth);
+ new_number(tt->tx); number_clone(tt->tx, t->tx);
+ new_number(tt->ty); number_clone(tt->ty, t->ty);
+ new_number(tt->txx); number_clone(tt->txx, t->txx);
+ new_number(tt->tyx); number_clone(tt->tyx, t->tyx);
+ new_number(tt->txy); number_clone(tt->txy, t->txy);
+ new_number(tt->tyy); number_clone(tt->tyy, t->tyy);
+ if (mp_pre_script (p) != NULL)
+ add_str_ref (mp_pre_script (p));
+ if (mp_post_script (p) != NULL)
+ add_str_ref (mp_post_script (p));
+ add_str_ref (mp_text_p (pp));
+ }
+ break;
+case mp_stop_clip_node_type:
+case mp_stop_bounds_node_type:
+ break;
+default: /* there are no other valid cases, but please the compiler */
+ break;
+}
+
+
+@ 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.
+
+@c
+static mp_node mp_skip_1component (MP mp, mp_node p) {
+ integer lev; /* current nesting level */
+ lev = 0;
+ (void) mp;
+ do {
+ if (is_start_or_stop (p)) {
+ if (is_stop (p))
+ decr (lev);
+ else
+ incr (lev);
+ }
+ p = mp_link (p);
+ } while (lev != 0);
+ return p;
+}
+
+
+@ Here is a diagnostic routine for printing an edge structure in symbolic form.
+
+@<Declarations@>=
+static void mp_print_edges (MP mp, mp_node h, const char *s, boolean nuline);
+
+@ @c
+void mp_print_edges (MP mp, mp_node h, const char *s, boolean nuline) {
+ mp_node p; /* a graphical object to be printed */
+ mp_number scf; /* a scale factor for the dash pattern */
+ boolean ok_to_dash; /* |false| for polygonal pen strokes */
+ new_number (scf);
+ mp_print_diagnostic (mp, "Edge structure", s, nuline);
+ p = edge_list (h);
+ while (mp_link (p) != NULL) {
+ p = mp_link (p);
+ mp_print_ln (mp);
+ switch (mp_type (p)) {
+ @<Cases for printing graphical object node |p|@>;
+ default:
+ mp_print (mp, "[unknown object type!]");
+ break;
+ }
+ }
+ mp_print_nl (mp, "End edges");
+ if (p != obj_tail (h))
+ mp_print (mp, "?");
+@.End edges?@>;
+ mp_end_diagnostic (mp, true);
+ free_number (scf);
+}
+
+
+@ @<Cases for printing graphical object node |p|@>=
+case mp_fill_node_type:
+mp_print (mp, "Filled contour ");
+mp_print_obj_color (mp, p);
+mp_print_char (mp, xord (':'));
+mp_print_ln (mp);
+mp_pr_path (mp, mp_path_p ((mp_fill_node) p));
+mp_print_ln (mp);
+if ((mp_pen_p ((mp_fill_node) p) != NULL)) {
+ @<Print join type for graphical object |p|@>;
+ mp_print (mp, " with pen");
+ mp_print_ln (mp);
+ mp_pr_pen (mp, mp_pen_p ((mp_fill_node) p));
+}
+break;
+
+@ @<Print join type for graphical object |p|@>=
+switch (((mp_stroked_node)p)->ljoin) {
+case 0:
+ mp_print (mp, "mitered joins limited ");
+ print_number (((mp_stroked_node)p)->miterlim);
+ break;
+case 1:
+ mp_print (mp, "round joins");
+ break;
+case 2:
+ mp_print (mp, "beveled joins");
+ break;
+default:
+ mp_print (mp, "?? joins");
+@.??@>;
+ break;
+}
+
+
+@ For stroked nodes, we need to print |lcap_val(p)| as well.
+
+@<Print join and cap types for stroked node |p|@>=
+switch (((mp_stroked_node)p)->lcap ) {
+case 0:
+ mp_print (mp, "butt");
+ break;
+case 1:
+ mp_print (mp, "round");
+ break;
+case 2:
+ mp_print (mp, "square");
+ break;
+default:
+ mp_print (mp, "??");
+ break;
+@.??@>
+}
+mp_print (mp, " ends, ");
+@<Print join type for graphical object |p|@>
+
+
+@ Here is a routine that prints the color of a graphical object if it isn't
+black (the default color).
+
+@<Declarations@>=
+static void mp_print_obj_color (MP mp, mp_node p);
+
+@ @c
+void mp_print_obj_color (MP mp, mp_node p) {
+ mp_stroked_node p0 = (mp_stroked_node) p;
+ if (mp_color_model (p) == mp_grey_model) {
+ if (number_positive(p0->grey)) {
+ mp_print (mp, "greyed ");
+ mp_print_char (mp, xord ('('));
+ print_number (p0->grey);
+ mp_print_char (mp, xord (')'));
+ };
+ } else if (mp_color_model (p) == mp_cmyk_model) {
+ if (number_positive(p0->cyan) || number_positive(p0->magenta) ||
+ number_positive(p0->yellow) || number_positive(p0->black)) {
+ mp_print (mp, "processcolored ");
+ mp_print_char (mp, xord ('('));
+ print_number (p0->cyan);
+ mp_print_char (mp, xord (','));
+ print_number (p0->magenta);
+ mp_print_char (mp, xord (','));
+ print_number (p0->yellow);
+ mp_print_char (mp, xord (','));
+ print_number (p0->black);
+ mp_print_char (mp, xord (')'));
+ };
+ } else if (mp_color_model (p) == mp_rgb_model) {
+ if (number_positive(p0->red) || number_positive(p0->green) ||
+ number_positive(p0->blue)) {
+ mp_print (mp, "colored ");
+ mp_print_char (mp, xord ('('));
+ print_number (p0->red);
+ mp_print_char (mp, xord (','));
+ print_number (p0->green);
+ mp_print_char (mp, xord (','));
+ print_number (p0->blue);
+ mp_print_char (mp, xord (')'));
+ };
+ }
+}
+
+
+@ @<Cases for printing graphical object node |p|@>=
+case mp_stroked_node_type:
+mp_print (mp, "Filled pen stroke ");
+mp_print_obj_color (mp, p);
+mp_print_char (mp, xord (':'));
+mp_print_ln (mp);
+mp_pr_path (mp, mp_path_p ((mp_stroked_node) p));
+if (mp_dash_p (p) != NULL) {
+ mp_print_nl (mp, "dashed (");
+ @<Finish printing the dash pattern that |p| refers to@>;
+}
+mp_print_ln (mp);
+@<Print join and cap types for stroked node |p|@>;
+mp_print (mp, " with pen");
+mp_print_ln (mp);
+if (mp_pen_p ((mp_stroked_node) p) == NULL) {
+ mp_print (mp, "???"); /* shouldn't happen */
+@.???@>
+} else {
+ mp_pr_pen (mp, mp_pen_p ((mp_stroked_node) p));
+}
+break;
+
+@ Normally, the |dash_list| field in an edge header is set to |null_dash|
+when it is not known to define a suitable dash pattern. This is disallowed
+here because the |mp_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@>=
+{
+mp_dash_node ppd, hhd;
+ok_to_dash = pen_is_elliptical (mp_pen_p ((mp_stroked_node) p));
+if (!ok_to_dash)
+ set_number_to_unity (scf);
+else
+ number_clone(scf, ((mp_stroked_node) p)->dash_scale);
+hhd = (mp_dash_node)mp_dash_p (p);
+ppd = dash_list (hhd);
+if ((ppd == mp->null_dash) || number_negative(hhd->dash_y)) {
+ mp_print (mp, " ??");
+} else {
+ mp_number dashoff;
+ mp_number ret, arg1;
+ new_number (ret);
+ new_number (arg1);
+ new_number (dashoff);
+ set_number_from_addition(mp->null_dash->start_x, ppd->start_x, hhd->dash_y );
+ while (ppd != mp->null_dash) {
+ mp_print (mp, "on ");
+ set_number_from_substraction (arg1, ppd->stop_x, ppd->start_x);
+ take_scaled (ret, arg1, scf);
+ print_number ( ret);
+ mp_print (mp, " off ");
+ set_number_from_substraction (arg1, ((mp_dash_node)mp_link (ppd))->start_x, ppd->stop_x);
+ take_scaled (ret, arg1, scf);
+ print_number (ret);
+ ppd = (mp_dash_node)mp_link (ppd);
+ if (ppd != mp->null_dash)
+ mp_print_char (mp, xord (' '));
+ }
+ mp_print (mp, ") shifted ");
+ mp_dash_offset (mp, &dashoff, hhd);
+ take_scaled (ret, dashoff, scf);
+ number_negate (ret);
+ print_number (ret);
+ free_number (dashoff);
+ free_number (ret);
+ free_number (arg1);
+ if (!ok_to_dash || number_zero(hhd->dash_y) )
+ mp_print (mp, " (this will be ignored)");
+}
+}
+
+@ @<Declarations@>=
+static void mp_dash_offset (MP mp, mp_number *x, mp_dash_node h);
+
+@ @c
+void mp_dash_offset (MP mp, mp_number *x, mp_dash_node h) {
+ if (dash_list (h) == mp->null_dash || number_negative(h->dash_y ))
+ mp_confusion (mp, "dash0");
+@:this can't happen dash0}{\quad dash0@>;
+ if (number_zero(h->dash_y)) {
+ set_number_to_zero(*x);
+ } else {
+ number_clone (*x, (dash_list (h))->start_x );
+ number_modulo (*x, h->dash_y);
+ number_negate (*x);
+ if (number_negative(*x))
+ number_add(*x, h->dash_y);
+ }
+}
+
+
+@ @<Cases for printing graphical object node |p|@>=
+case mp_text_node_type:
+{
+mp_text_node p0 = (mp_text_node)p;
+mp_print_char (mp, xord ('"'));
+mp_print_str (mp, mp_text_p (p));
+mp_print (mp, "\" infont \"");
+mp_print (mp, mp->font_name[mp_font_n (p)]);
+mp_print_char (mp, xord ('"'));
+mp_print_ln (mp);
+mp_print_obj_color (mp, p);
+mp_print (mp, "transformed ");
+mp_print_char (mp, xord ('('));
+print_number (p0->tx);
+mp_print_char (mp, xord (','));
+print_number (p0->ty);
+mp_print_char (mp, xord (','));
+print_number (p0->txx);
+mp_print_char (mp, xord (','));
+print_number (p0->txy);
+mp_print_char (mp, xord (','));
+print_number (p0->tyx);
+mp_print_char (mp, xord (','));
+print_number (p0->tyy);
+mp_print_char (mp, xord (')'));
+}
+break;
+
+@ @<Cases for printing graphical object node |p|@>=
+case mp_start_clip_node_type:
+mp_print (mp, "clipping path:");
+mp_print_ln (mp);
+mp_pr_path (mp, mp_path_p ((mp_start_clip_node) p));
+break;
+case mp_stop_clip_node_type:
+mp_print (mp, "stop clipping");
+break;
+
+@ @<Cases for printing graphical object node |p|@>=
+case mp_start_bounds_node_type:
+mp_print (mp, "setbounds path:");
+mp_print_ln (mp);
+mp_pr_path (mp, mp_path_p ((mp_start_bounds_node) p));
+break;
+case mp_stop_bounds_node_type:
+mp_print (mp, "end of setbounds");
+break;
+
+@ To initialize the |dash_list| field in an edge header~|h|, we need a
+subroutine that scans an edge structure and tries to interpret it as a dash
+pattern. This can only be done when there are no filled regions or clipping
+paths and all the pen strokes have the same color. The first step is to let
+$y_0$ be the initial $y$~coordinate of the first pen stroke. Then we implicitly
+project all the pen stroke paths onto the line $y=y_0$ and require that there
+be no retracing. If the resulting paths cover a range of $x$~coordinates of
+length $\Delta x$, we set |dash_y(h)| to the length of the dash pattern by
+finding the maximum of $\Delta x$ and the absolute value of~$y_0$.
+
+@c
+static mp_edge_header_node mp_make_dashes (MP mp, mp_edge_header_node h) { /* returns |h| or |NULL| */
+ mp_node p; /* this scans the stroked nodes in the object list */
+ mp_node p0; /* if not |NULL| this points to the first stroked node */
+ mp_knot pp, qq, rr; /* pointers into |mp_path_p(p)| */
+ mp_dash_node d, dd; /* pointers used to create the dash list */
+ mp_number y0;
+ @<Other local variables in |make_dashes|@>;
+ if (dash_list (h) != mp->null_dash)
+ return h;
+ new_number (y0); /* the initial $y$ coordinate */
+ p0 = NULL;
+ p = mp_link (edge_list (h));
+ while (p != NULL) {
+ if (mp_type (p) != mp_stroked_node_type) {
+ @<Compain that the edge structure contains a node of the wrong type
+ and |goto not_found|@>;
+ }
+ pp = mp_path_p ((mp_stroked_node) p);
+ if (p0 == NULL) {
+ p0 = p;
+ number_clone(y0, pp->y_coord);
+ }
+ @<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 = mp_link (p);
+ }
+ if (dash_list (h) == mp->null_dash)
+ goto NOT_FOUND; /* No error message */
+ @<Scan |dash_list(h)| and deal with any dashes that are themselves dashed@>;
+ @<Set |dash_y(h)| and merge the first and last dashes if necessary@>;
+ free_number (y0);
+ return h;
+NOT_FOUND:
+ free_number (y0);
+ @<Flush the dash list, recycle |h| and return |NULL|@>;
+}
+
+
+@ @<Compain that the edge structure contains a node of the wrong type...@>=
+{
+ const char *hlp[] = {
+ "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.",
+ NULL };
+ mp_back_error (mp, "Picture is too complicated to use as a dash pattern", hlp, true);
+ mp_get_x_next (mp);
+ goto NOT_FOUND;
+}
+
+
+@ A similar error occurs when monotonicity fails.
+
+@<Declarations@>=
+static void mp_x_retrace_error (MP mp);
+
+@ @c
+void mp_x_retrace_error (MP mp) {
+ const char *hlp[] = {
+ "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.",
+ NULL };
+ mp_back_error (mp, "Picture is too complicated to use as a dash pattern", hlp, true);
+ mp_get_x_next (mp);
+}
+
+
+@ We stash |p| in |dash_info(d)| if |mp_dash_p(p)<>0| so that subsequent processing can
+handle the case where the pen stroke |p| is itself dashed.
+
+@d dash_info(A) ((mp_dash_node)(A))->dash_info_ /* in an edge header this points to the first dash node */
+
+@<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 (mp_next_knot (pp) != pp) {
+ do {
+ qq = rr;
+ rr = mp_next_knot (rr);
+ @<Check for retracing between knots |qq| and |rr| and |goto not_found|
+ if there is a problem@>;
+ } while (mp_right_type (rr) != mp_endpoint);
+}
+d = (mp_dash_node)mp_get_dash_node (mp);
+if (mp_dash_p (p) == NULL)
+ dash_info (d) = NULL;
+else
+ dash_info (d) = p;
+if (number_less (pp->x_coord, rr->x_coord)) {
+ number_clone(d->start_x, pp->x_coord);
+ number_clone(d->stop_x, rr->x_coord);
+} else {
+ number_clone(d->start_x, rr->x_coord);
+ number_clone(d->stop_x, pp->x_coord);
+}
+
+
+@ 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|...@>=
+{
+ mp_number x0, x1, x2, x3; /* $x$ coordinates of the segment from |qq| to |rr| */
+ new_number(x0);
+ new_number(x1);
+ new_number(x2);
+ new_number(x3);
+ number_clone(x0, qq->x_coord);
+ number_clone(x1, qq->right_x);
+ number_clone(x2, rr->left_x);
+ number_clone(x3, rr->x_coord);
+ if (number_greater(x0, x1) || number_greater(x1, x2) || number_greater(x2, x3)) {
+ if (number_less(x0, x1) || number_less(x1, x2) || number_less(x2, x3)) {
+ mp_number a1, a2, a3, a4;
+ mp_number test;
+ new_number(test);
+ new_number(a1);
+ new_number(a2);
+ new_number(a3);
+ new_number(a4);
+ set_number_from_substraction(a1, x2, x1);
+ set_number_from_substraction(a2, x2, x1);
+ set_number_from_substraction(a3, x1, x0);
+ set_number_from_substraction(a4, x3, x2);
+ ab_vs_cd (test, a1, a2, a3, a4);
+ free_number(a1);
+ free_number(a2);
+ free_number(a3);
+ free_number(a4);
+ if (number_positive(test)) {
+ mp_x_retrace_error (mp);
+ free_number(x0);
+ free_number(x1);
+ free_number(x2);
+ free_number(x3);
+ free_number(test);
+ goto NOT_FOUND;
+ }
+ free_number(test);
+ }
+ }
+ if (number_greater(pp->x_coord, x0) || number_greater(x0, x3)) {
+ if (number_less (pp->x_coord, x0) || number_less(x0, x3)) {
+ mp_x_retrace_error (mp);
+ free_number(x0);
+ free_number(x1);
+ free_number(x2);
+ free_number(x3);
+ goto NOT_FOUND;
+ }
+ }
+ free_number(x0);
+ free_number(x1);
+ free_number(x2);
+ free_number(x3);
+}
+
+@ @<Make sure |p| and |p0| are the same color and |goto not_found|...@>=
+if (!number_equal(((mp_stroked_node)p)->red, ((mp_stroked_node)p0)->red) ||
+ !number_equal(((mp_stroked_node)p)->black, ((mp_stroked_node)p0)->black) ||
+ !number_equal(((mp_stroked_node)p)->green, ((mp_stroked_node)p0)->green) ||
+ !number_equal(((mp_stroked_node)p)->blue, ((mp_stroked_node)p0)->blue)
+ ) {
+ const char *hlp[] = {
+ "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.",
+ NULL };
+ mp_back_error (mp, "Picture is too complicated to use as a dash pattern", hlp, true);
+ mp_get_x_next (mp);
+ goto NOT_FOUND;
+}
+
+@ @<Insert |d| into the dash list and |goto not_found| if there is an error@>=
+number_clone(mp->null_dash->start_x, d->stop_x);
+dd = (mp_dash_node)h; /* this makes |mp_link(dd)=dash_list(h)| */
+while (number_less(((mp_dash_node)mp_link (dd))->start_x, d->stop_x ))
+ dd = (mp_dash_node)mp_link (dd);
+if (dd != (mp_dash_node)h) {
+ if (number_greater(dd->stop_x, d->start_x)) {
+ mp_x_retrace_error (mp);
+ goto NOT_FOUND;
+ };
+}
+mp_link (d) = mp_link (dd);
+mp_link (dd) = (mp_node)d
+
+@ @<Set |dash_y(h)| and merge the first and last dashes if necessary@>=
+d = dash_list (h);
+while ((mp_link (d) != (mp_node)mp->null_dash))
+ d = (mp_dash_node)mp_link (d);
+dd = dash_list (h);
+set_number_from_substraction(h->dash_y, d->stop_x, dd->start_x);
+{
+ mp_number absval;
+ new_number (absval);
+ number_clone (absval, y0);
+ number_abs (absval);
+ if (number_greater (absval, h->dash_y) ) {
+ number_clone(h->dash_y, absval);
+ } else if (d != dd) {
+ set_dash_list (h, mp_link (dd));
+ set_number_from_addition(d->stop_x, dd->stop_x, h->dash_y);
+ mp_free_node (mp, (mp_node)dd, dash_node_size);
+ }
+ free_number (absval);
+}
+@ We get here when the argument is a NULL picture or when there is an error.
+Recovering from an error involves making |dash_list(h)| empty to indicate
+that |h| is not known to be a valid dash pattern. We also dereference |h|
+since it is not being used for the return value.
+
+@<Flush the dash list, recycle |h| and return |NULL|@>=
+mp_flush_dash_list (mp, h);
+delete_edge_ref (h);
+return NULL
+
+@ Having carefully saved the dashed stroked nodes in the
+corresponding dash nodes, we must be prepared to break up these dashes into
+smaller dashes.
+
+@<Scan |dash_list(h)| and deal with any dashes that are themselves dashed@>=
+{
+mp_number hsf; /* the dash pattern from |hh| gets scaled by this */
+new_number (hsf);
+d = (mp_dash_node)h; /* now |mp_link(d)=dash_list(h)| */
+while (mp_link (d) != (mp_node)mp->null_dash) {
+ ds = dash_info (mp_link (d));
+ if (ds == NULL) {
+ d = (mp_dash_node)mp_link (d);
+ } else {
+ hh = (mp_edge_header_node)mp_dash_p (ds);
+ number_clone(hsf, ((mp_stroked_node)ds)->dash_scale);
+ if (hh == NULL)
+ mp_confusion (mp, "dash1");
+@:this can't happen dash0}{\quad dash1@>;
+ /* clang: dereference null pointer 'hh' */ assert(hh);
+ if (number_zero(((mp_dash_node)hh)->dash_y )) {
+ d = (mp_dash_node)mp_link (d);
+ } else {
+ if (dash_list (hh) == NULL)
+ mp_confusion (mp, "dash1");
+@:this can't happen dash0}{\quad dash1@>;
+ @<Replace |mp_link(d)| by a dashed version as determined by edge header
+ |hh| and scale factor |ds|@>;
+ }
+ }
+}
+free_number (hsf);
+}
+
+@ @<Other local variables in |make_dashes|@>=
+mp_dash_node dln; /* |mp_link(d)| */
+mp_edge_header_node hh; /* an edge header that tells how to break up |dln| */
+mp_node ds; /* the stroked node from which |hh| and |hsf| are derived */
+
+@ @<Replace |mp_link(d)| by a dashed version as determined by edge header...@>=
+{
+ mp_number xoff; /* added to $x$ values in |dash_list(hh)| to match |dln| */
+ mp_number dashoff;
+ mp_number r1, r2;
+ new_number (r1);
+ new_number (r2);
+ dln = (mp_dash_node)mp_link (d);
+ dd = dash_list (hh);
+ /* clang: dereference null pointer 'dd' */ assert(dd);
+ new_number (xoff);
+ new_number (dashoff);
+ mp_dash_offset (mp, &dashoff, (mp_dash_node)hh);
+ take_scaled (r1, hsf, dd->start_x);
+ take_scaled (r2, hsf, dashoff);
+ number_add (r1, r2);
+ set_number_from_substraction(xoff, dln->start_x, r1);
+ free_number (dashoff);
+ take_scaled (r1, hsf, dd->start_x);
+ take_scaled (r2, hsf, hh->dash_y);
+ set_number_from_addition(mp->null_dash->start_x, r1, r2);
+ number_clone(mp->null_dash->stop_x, mp->null_dash->start_x);
+ @<Advance |dd| until finding the first dash that overlaps |dln| when
+ offset by |xoff|@>;
+ while (number_lessequal(dln->start_x, dln->stop_x)) {
+ @<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 = (mp_dash_node)mp_link (dd);
+ take_scaled (r1, hsf, dd->start_x);
+ set_number_from_addition(dln->start_x , xoff, r1);
+ }
+ free_number(xoff);
+ free_number (r1);
+ free_number (r2);
+ mp_link (d) = mp_link (dln);
+ mp_free_node (mp, (mp_node)dln, dash_node_size);
+}
+
+
+@ The name of this module is a bit of a lie because we just find the
+first |dd| where |take_scaled (hsf, stop_x(dd))| is large enough to make an
+overlap possible. It could be that the unoffset version of dash |dln| falls
+in the gap between |dd| and its predecessor.
+
+@<Advance |dd| until finding the first dash that overlaps |dln| when...@>=
+{
+ mp_number r1;
+ new_number (r1);
+ take_scaled (r1, hsf, dd->stop_x);
+ number_add (r1, xoff);
+ while (number_less(r1, dln->start_x)) {
+ dd = (mp_dash_node)mp_link (dd);
+ take_scaled (r1, hsf, dd->stop_x);
+ number_add (r1, xoff);
+ }
+ free_number (r1);
+}
+
+@ @<If |dd| has `fallen off the end', back up to the beginning and fix...@>=
+if (dd == mp->null_dash) {
+ mp_number ret;
+ new_number (ret);
+ dd = dash_list (hh);
+ take_scaled (ret, hsf, hh->dash_y);
+ number_add(xoff, ret);
+ free_number (ret);
+}
+
+@ 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...@>=
+{
+ mp_number r1;
+ new_number (r1);
+ take_scaled (r1, hsf, dd->start_x);
+ number_add (r1, xoff);
+ if (number_lessequal(r1, dln->stop_x)) {
+ mp_link (d) = (mp_node)mp_get_dash_node (mp);
+ d = (mp_dash_node)mp_link (d);
+ mp_link (d) = (mp_node)dln;
+ take_scaled (r1, hsf, dd->start_x );
+ number_add (r1, xoff);
+ if (number_greater(dln->start_x, r1))
+ number_clone(d->start_x, dln->start_x);
+ else {
+ number_clone(d->start_x, r1);
+ }
+ take_scaled (r1, hsf, dd->stop_x);
+ number_add (r1, xoff);
+ if (number_less(dln->stop_x, r1))
+ number_clone(d->stop_x, dln->stop_x );
+ else {
+ number_clone(d->stop_x, r1);
+ }
+ }
+ free_number (r1);
+}
+
+@ The next major task is to update the bounding box information in an edge
+header~|h|. This is done via a procedure |adjust_bbox| that enlarges an edge
+header's bounding box to accommodate the box computed by |path_bbox| or
+|pen_bbox|. (This is stored in global variables |minx|, |miny|, |maxx|, and
+|maxy|.)
+
+@c
+static void mp_adjust_bbox (MP mp, mp_edge_header_node h) {
+ if (number_less (mp_minx, h->minx))
+ number_clone(h->minx, mp_minx);
+ if (number_less (mp_miny, h->miny))
+ number_clone(h->miny, mp_miny);
+ if (number_greater (mp_maxx, h->maxx))
+ number_clone(h->maxx, mp_maxx);
+ if (number_greater (mp_maxy, h->maxy))
+ number_clone(h->maxy, mp_maxy);
+}
+
+
+@ Here is a special routine for updating the bounding box information in
+edge header~|h| to account for the squared-off ends of a non-cyclic path~|p|
+that is to be stroked with the pen~|pp|.
+
+@c
+static void mp_box_ends (MP mp, mp_knot p, mp_knot pp, mp_edge_header_node h) {
+ mp_knot q; /* a knot node adjacent to knot |p| */
+ mp_fraction dx, dy; /* a unit vector in the direction out of the path at~|p| */
+ mp_number d; /* a factor for adjusting the length of |(dx,dy)| */
+ mp_number z; /* a coordinate being tested against the bounding box */
+ mp_number xx, yy; /* the extreme pen vertex in the |(dx,dy)| direction */
+ integer i; /* a loop counter */
+ new_fraction(dx);
+ new_fraction(dy);
+ new_number(xx);
+ new_number(yy);
+ new_number(z);
+ new_number(d);
+ if (mp_right_type (p) != mp_endpoint) {
+ q = mp_next_knot (p);
+ while (1) {
+ @<Make |(dx,dy)| the final direction for the path segment from
+ |q| to~|p|; set~|d|@>;
+ pyth_add (d, dx, dy);
+ if (number_positive(d)) {
+ @<Normalize the direction |(dx,dy)| and find the pen offset |(xx,yy)|@>;
+ for (i = 1; i <= 2; i++) {
+ @<Use |(dx,dy)| to generate a vertex of the square end cap and
+ update the bounding box to accommodate it@>;
+ number_negate(dx);
+ number_negate(dy);
+ }
+ }
+ if (mp_right_type (p) == mp_endpoint) {
+ goto DONE;
+ } else {
+ @<Advance |p| to the end of the path and make |q| the previous knot@>;
+ }
+ }
+ }
+DONE:
+ free_number (dx);
+ free_number (dy);
+ free_number (xx);
+ free_number (yy);
+ free_number (z);
+ free_number (d);
+}
+
+
+@ @<Make |(dx,dy)| the final direction for the path segment from...@>=
+if (q == mp_next_knot (p)) {
+ set_number_from_substraction(dx, p->x_coord, p->right_x);
+ set_number_from_substraction(dy, p->y_coord, p->right_y);
+ if (number_zero(dx) && number_zero(dy)) {
+ set_number_from_substraction(dx, p->x_coord, q->left_x);
+ set_number_from_substraction(dy, p->y_coord, q->left_y);
+ }
+} else {
+ set_number_from_substraction(dx, p->x_coord, p->left_x);
+ set_number_from_substraction(dy, p->y_coord, p->left_y);
+ if (number_zero(dx) && number_zero(dy)) {
+ set_number_from_substraction(dx, p->x_coord, q->right_x);
+ set_number_from_substraction(dy, p->y_coord, q->right_y);
+ }
+}
+set_number_from_substraction(dx, p->x_coord, q->x_coord);
+set_number_from_substraction(dy, p->y_coord, q->y_coord);
+
+
+@ @<Normalize the direction |(dx,dy)| and find the pen offset |(xx,yy)|@>=
+{
+ mp_number arg1, r;
+ new_fraction (r);
+ new_number(arg1);
+ make_fraction (r, dx, d);
+ number_clone(dx, r);
+ make_fraction (r, dy, d);
+ number_clone(dy, r);
+ free_number (r);
+ number_clone(arg1, dy);
+ number_negate(arg1);
+ mp_find_offset (mp, arg1, dx, pp);
+ free_number(arg1);
+ number_clone(xx, mp->cur_x);
+ number_clone(yy, mp->cur_y);
+}
+
+@ @<Use |(dx,dy)| to generate a vertex of the square end cap and...@>=
+{
+ mp_number r1, r2, arg1;
+ new_number (arg1);
+ new_fraction (r1);
+ new_fraction (r2);
+ mp_find_offset (mp, dx, dy, pp);
+ set_number_from_substraction (arg1, xx, mp->cur_x);
+ take_fraction (r1, arg1, dx);
+ set_number_from_substraction (arg1, yy, mp->cur_y);
+ take_fraction (r2, arg1, dy);
+ set_number_from_addition(d, r1, r2);
+ if ((number_negative(d) && (i == 1)) || (number_positive(d) && (i == 2)))
+ mp_confusion (mp, "box_ends");
+@:this can't happen box ends}{\quad\\{box\_ends}@>;
+ take_fraction (r1, d, dx);
+ set_number_from_addition(z, p->x_coord, mp->cur_x);
+ number_add (z, r1);
+ if (number_less(z, h->minx))
+ number_clone(h->minx, z);
+ if (number_greater(z, h->maxx))
+ number_clone(h->maxx, z);
+ take_fraction (r1, d, dy);
+ set_number_from_addition(z, p->y_coord, mp->cur_y);
+ number_add (z, r1);
+ if (number_less(z, h->miny))
+ number_clone(h->miny, z);
+ if (number_greater(z, h->maxy))
+ number_clone(h->maxy, z);
+ free_number (r1);
+ free_number (r2);
+ free_number (arg1);
+}
+
+@ @<Advance |p| to the end of the path and make |q| the previous knot@>=
+do {
+ q = p;
+ p = mp_next_knot (p);
+} while (mp_right_type (p) != mp_endpoint)
+
+@ The major difficulty in finding the bounding box of an edge structure is the
+effect of clipping paths. We treat them conservatively by only clipping to the
+clipping path's bounding box, but this still
+requires recursive calls to |set_bbox| in order to find the bounding box of
+@^recursion@>
+the objects to be clipped. Such calls are distinguished by the fact that the
+boolean parameter |top_level| is false.
+
+@c
+void mp_set_bbox (MP mp, mp_edge_header_node h, boolean top_level) {
+ mp_node p; /* a graphical object being considered */
+ integer lev; /* nesting level for |mp_start_bounds_node| nodes */
+ /* Wipe out any existing bounding box information if |bbtype(h)| is
+ incompatible with |internal[mp_true_corners]| */
+ switch (h->bbtype ) {
+ case no_bounds:
+ break;
+ case bounds_set:
+ if (number_positive(internal_value (mp_true_corners)))
+ mp_init_bbox (mp, h);
+ break;
+ case bounds_unset:
+ if (number_nonpositive(internal_value (mp_true_corners)))
+ mp_init_bbox (mp, h);
+ break;
+ } /* there are no other cases */
+
+ while (mp_link (bblast (h)) != NULL) {
+ p = mp_link (bblast (h));
+ bblast (h) = p;
+ switch (mp_type (p)) {
+ case mp_stop_clip_node_type:
+ if (top_level)
+ mp_confusion (mp, "bbox");
+ else
+ return;
+@:this can't happen bbox}{\quad bbox@>;
+ break;
+ @<Other cases for updating the bounding box based on the type of object |p|@>;
+ default: /* there are no other valid cases, but please the compiler */
+ break;
+ }
+ }
+ if (!top_level)
+ mp_confusion (mp, "bbox");
+}
+
+
+@ @<Declarations@>=
+static void mp_set_bbox (MP mp, mp_edge_header_node h, boolean top_level);
+
+
+@ @<Other cases for updating the bounding box...@>=
+case mp_fill_node_type:
+ mp_path_bbox (mp, mp_path_p ((mp_fill_node) p));
+ if (mp_pen_p ((mp_fill_node) p) != NULL) {
+ mp_number x0a, y0a, x1a, y1a;
+ new_number (x0a);
+ new_number (y0a);
+ new_number (x1a);
+ new_number (y1a);
+ number_clone (x0a, mp_minx);
+ number_clone (y0a, mp_miny);
+ number_clone (x1a, mp_maxx);
+ number_clone (y1a, mp_maxy);
+ mp_pen_bbox (mp, mp_pen_p ((mp_fill_node) p));
+ number_add (mp_minx, x0a);
+ number_add (mp_miny, y0a);
+ number_add (mp_maxx, x1a);
+ number_add (mp_maxy, y1a);
+ free_number (x0a);
+ free_number (y0a);
+ free_number (x1a);
+ free_number (y1a);
+ }
+ mp_adjust_bbox (mp, h);
+break;
+
+@ @<Other cases for updating the bounding box...@>=
+case mp_start_bounds_node_type:
+ if (number_positive (internal_value (mp_true_corners))) {
+ h->bbtype = bounds_unset;
+ } else {
+ h->bbtype = bounds_set;
+ mp_path_bbox (mp, mp_path_p ((mp_start_bounds_node) p));
+ mp_adjust_bbox (mp, h);
+ @<Scan to the matching |mp_stop_bounds_node| node and update |p| and
+ |bblast(h)|@>;
+ }
+ break;
+case mp_stop_bounds_node_type:
+ if (number_nonpositive (internal_value (mp_true_corners)))
+ mp_confusion (mp, "bbox2");
+@:this can't happen bbox2}{\quad bbox2@>;
+ break;
+
+@ @<Scan to the matching |mp_stop_bounds_node| node and update |p| and...@>=
+lev = 1;
+while (lev != 0) {
+ if (mp_link (p) == NULL)
+ mp_confusion (mp, "bbox2");
+@:this can't happen bbox2}{\quad bbox2@>;
+ /* clang: dereference null pointer */ assert(mp_link(p));
+ p = mp_link (p);
+ if (mp_type (p) == mp_start_bounds_node_type)
+ incr (lev);
+ else if (mp_type (p) == mp_stop_bounds_node_type)
+ decr (lev);
+}
+bblast (h) = p
+
+@ It saves a lot of grief here to be slightly conservative and not account for
+omitted parts of dashed lines. We also don't worry about the material omitted
+when using butt end caps. The basic computation is for round end caps and
+|box_ends| augments it for square end caps.
+
+@<Other cases for updating the bounding box...@>=
+case mp_stroked_node_type:
+mp_path_bbox (mp, mp_path_p ((mp_stroked_node) p));
+{
+ mp_number x0a, y0a, x1a, y1a;
+ new_number (x0a);
+ new_number (y0a);
+ new_number (x1a);
+ new_number (y1a);
+ number_clone (x0a, mp_minx);
+ number_clone (y0a, mp_miny);
+ number_clone (x1a, mp_maxx);
+ number_clone (y1a, mp_maxy);
+ mp_pen_bbox (mp, mp_pen_p ((mp_stroked_node) p));
+ number_add (mp_minx, x0a);
+ number_add (mp_miny, y0a);
+ number_add (mp_maxx, x1a);
+ number_add (mp_maxy, y1a);
+ free_number (x0a);
+ free_number (y0a);
+ free_number (x1a);
+ free_number (y1a);
+}
+mp_adjust_bbox (mp, h);
+if ((mp_left_type (mp_path_p ((mp_stroked_node) p)) == mp_endpoint)
+ && (((mp_stroked_node) p)->lcap == 2))
+ mp_box_ends (mp, mp_path_p ((mp_stroked_node) p),
+ mp_pen_p ((mp_stroked_node) p), h);
+break;
+
+@ The height width and depth information stored in a text node determines a
+rectangle that needs to be transformed according to the transformation
+parameters stored in the text node.
+
+@<Other cases for updating the bounding box...@>=
+case mp_text_node_type:
+{
+ mp_number x0a, y0a, x1a, y1a, arg1;
+ mp_text_node p0 = (mp_text_node)p;
+ new_number (x0a);
+ new_number (x1a);
+ new_number (y0a);
+ new_number (y1a);
+ new_number (arg1);
+ number_clone (arg1, p0->depth);
+ number_negate (arg1);
+ take_scaled (x1a, p0->txx, p0->width);
+ take_scaled (y0a, p0->txy, arg1);
+ take_scaled (y1a, p0->txy, p0->height);
+ number_clone (mp_minx, p0->tx);
+ number_clone (mp_maxx, mp_minx);
+ if (number_less(y0a, y1a)) {
+ number_add (mp_minx, y0a);
+ number_add (mp_maxx, y1a);
+ } else {
+ number_add (mp_minx, y1a);
+ number_add (mp_maxx, y0a);
+ }
+ if (number_negative(x1a))
+ number_add (mp_minx, x1a);
+ else
+ number_add (mp_maxx, x1a);
+ take_scaled (x1a, p0->tyx, p0->width);
+ number_clone (arg1, p0->depth);
+ number_negate (arg1);
+ take_scaled (y0a, p0->tyy, arg1);
+ take_scaled (y1a, p0->tyy, p0->height);
+ number_clone (mp_miny, p0->ty);
+ number_clone (mp_maxy, mp_miny);
+ if (number_less (y0a, y1a)) {
+ number_add (mp_miny, y0a);
+ number_add (mp_maxy, y1a);
+ } else {
+ number_add (mp_miny, y1a);
+ number_add (mp_maxy, y0a);
+ }
+ if (number_negative(x1a))
+ number_add (mp_miny, x1a);
+ else
+ number_add (mp_maxy, x1a);
+ mp_adjust_bbox (mp, h);
+ free_number (x0a);
+ free_number (y0a);
+ free_number (x1a);
+ free_number (y1a);
+ free_number (arg1);
+}
+break;
+
+@ This case involves a recursive call that advances |bblast(h)| to the node of
+type |mp_stop_clip_node| that matches |p|.
+
+@<Other cases for updating the bounding box...@>=
+case mp_start_clip_node_type:
+{
+ mp_number sminx, sminy, smaxx, smaxy;
+ /* for saving the bounding box during recursive calls */
+ mp_number x0a, y0a, x1a, y1a;
+ new_number (x0a);
+ new_number (y0a);
+ new_number (x1a);
+ new_number (y1a);
+ new_number (sminx);
+ new_number (sminy);
+ new_number (smaxx);
+ new_number (smaxy);
+mp_path_bbox (mp, mp_path_p ((mp_start_clip_node) p));
+number_clone (x0a, mp_minx);
+number_clone (y0a, mp_miny);
+number_clone (x1a, mp_maxx);
+number_clone (y1a, mp_maxy);
+number_clone (sminx, h->minx);
+number_clone (sminy, h->miny);
+number_clone (smaxx, h->maxx);
+number_clone (smaxy, h->maxy);
+@<Reinitialize the bounding box in header |h| and call |set_bbox| recursively
+ starting at |mp_link(p)|@>;
+@<Clip the bounding box in |h| to the rectangle given by |x0a|, |x1a|,
+ |y0a|, |y1a|@>;
+number_clone (mp_minx, sminx);
+number_clone (mp_miny, sminy);
+number_clone (mp_maxx, smaxx);
+number_clone (mp_maxy, smaxy);
+mp_adjust_bbox (mp, h);
+ free_number (sminx);
+ free_number (sminy);
+ free_number (smaxx);
+ free_number (smaxy);
+ free_number (x0a);
+ free_number (y0a);
+ free_number (x1a);
+ free_number (y1a);
+}
+break;
+
+@ @<Reinitialize the bounding box in header |h| and call |set_bbox|...@>=
+set_number_to_inf(h->minx);
+set_number_to_inf(h->miny);
+set_number_to_neg_inf(h->maxx);
+set_number_to_neg_inf(h->maxy);
+mp_set_bbox (mp, h, false)
+
+
+@ @<Clip the bounding box in |h| to the rectangle given by |x0a|, |x1a|,...@>=
+if (number_less(h->minx, x0a))
+ number_clone(h->minx, x0a);
+if (number_less(h->miny, y0a))
+ number_clone(h->miny, y0a);
+if (number_greater(h->maxx, x1a))
+ number_clone(h->maxx, x1a);
+if (number_greater(h->maxy, y1a))
+ number_clone(h->maxy, y1a);
+
+@* 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 |mp_info(q)=zero_off+l-k|. (The constant |zero_off| is added
+to because |l-k| could be negative.)
+
+After overwriting the type information with offset differences, we no longer
+have a true path so we refer to the knot list returned by |offset_prep| as an
+``envelope spec.''
+@^envelope spec@>
+Since an envelope spec only determines relative changes in pen offsets,
+|offset_prep| sets a global variable |spec_offset| to the relative change from
+|h| to the first offset.
+
+@d zero_off 16384 /* added to offset changes to make them positive */
+
+@<Glob...@>=
+integer spec_offset; /* number of pen edges between |h| and the initial offset */
+
+@ The next function calculates $1/3 B'(t) = (-p + (3c_1 + (-3c_2 + q)))*t^2 + (2p + (-4c_1 + 2*c_2))t + (-p + c_1)$,
+for cubic curve |B(t)| given by |p|,|c1|,|c2|,|q|
+and it's used for |t| near 0 and |t| near 1. We use double mode, otherwise we have to
+take care of overflow.
+
+
+@ @c
+static mp_knot mp_offset_prep (MP mp, mp_knot c, mp_knot h) {
+ int n; /* the number of vertices in the pen polygon */
+ mp_knot c0, p, q, q0, r, w, ww; /* for list manipulation */
+ int k_needed; /* amount to be added to |mp_info(p)| when it is computed */
+ mp_knot w0; /* a pointer to pen offset to use just before |p| */
+ mp_number dxin, dyin; /* the direction into knot |p| */
+ int turn_amt; /* change in pen offsets for the current cubic */
+ mp_number max_coef; /* used while scaling */
+ mp_number ss;
+ @<Other local variables for |offset_prep|@>;
+ new_number(max_coef);
+ new_number(dxin);
+ new_number(dyin);
+ new_number(dx0);
+ new_number(dy0);
+ new_number(x0);
+ new_number(y0);
+ new_number(x1);
+ new_number(y1);
+ new_number(x2);
+ new_number(y2);
+ new_number(du);
+ new_number(dv);
+ new_number(dx);
+ new_number(dy);
+ new_number(x0a);
+ new_number(y0a);
+ new_number(x1a);
+ new_number(y1a);
+ new_number(x2a);
+ new_number(y2a);
+ new_number(t0);
+ new_number(t1);
+ new_number(t2);
+ new_number(u0);
+ new_number(u1);
+ new_number(v0);
+ new_number(v1);
+ new_number(dx_m);
+ new_number(dy_m);
+ new_number(dxin_m);
+ new_number(dx_ap);
+ new_number(dy_ap);
+ new_number(dxin_ap);
+ new_number(dyin_ap);
+ new_number(ueps_ap);
+ new_fraction (ss);
+ new_fraction (s);
+ new_fraction (t);
+ @<Initialize the pen size~|n|@>;
+ @<Initialize the incoming direction and pen offset at |c|@>;
+ p = c;
+ c0 = c;
+ k_needed = 0;
+#ifdef DEBUGENVELOPE
+dbg_nl;dbg_str(--[==[BEGIN]==]);dbg_nl;
+dbg_str(return {);dbg_nl;
+dbg_n(w0->x_coord);
+dbg_n(w0->y_coord);
+#endif
+ do {
+ q = mp_next_knot (p);
+#ifdef DEBUGENVELOPE
+dbg_nl;dbg_open_t;dbg_str(--[==[begin loop]==]);dbg_nl;
+dbg_n(p->x_coord);dbg_n(p->y_coord);
+dbg_n(p->right_x);dbg_n(p->right_y);
+dbg_n(q->left_x);dbg_n(q->left_y);
+dbg_n(q->x_coord);dbg_n(q->y_coord);
+dbg_n(w0->x_coord);
+dbg_n(w0->y_coord);
+#endif
+ @<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@>;
+#ifdef DEBUGENVELOPE
+dbg_key(end Split the cubic between |p| and |q|);dbg_open_t;dbg_nl;
+dbg_n(w->x_coord);dbg_n(w->y_coord);
+dbg_n(w0->x_coord);dbg_n(w0->y_coord);
+dbg_close_t; dbg_comma;dbg_nl;
+#endif
+ NOT_FOUND:
+ @<Advance |p| to node |q|, removing any ``dead'' cubics that
+ might have been introduced by the splitting process@>;
+#ifdef DEBUGENVELOPE
+dbg_n(w0->x_coord);dbg_n(w0->y_coord);
+dbg_str(--[==[end loop]==]);dbg_nl; dbg_close_t;dbg_comma;dbg_nl;
+#endif
+ } while (q != c);
+#ifdef DEBUGENVELOPE
+ dbg_key(Fix the offset change);dbg_open_t;dbg_nl;
+ dbg_n(p->x_coord);dbg_n(p->y_coord);
+ dbg_key_ival(info pre,mp_knot_info(p));dbg_comma;dbg_nl;
+ dbg_n(c->x_coord);dbg_n(c->y_coord);
+ dbg_key_ival(info pre,mp_knot_info(c));dbg_close_t;dbg_comma;dbg_nl;
+#endif
+ @<Fix the offset change in |mp_knot_info(c)| and set |c| to the return value of
+ |offset_prep|@>;
+#ifdef DEBUGENVELOPE
+dbg_n(p->x_coord);dbg_n(p->y_coord);
+dbg_key_ival(info post,mp_knot_info(p));dbg_comma;dbg_nl;
+dbg_n(c->x_coord);dbg_n(c->y_coord);
+dbg_key_ival(info post,mp_knot_info(c));
+dbg_close_t;
+dbg_nl;dbg_str(--[==[END]==]);dbg_nl;
+#endif
+ free_number (ss);
+ free_number (s);
+ free_number (dxin);
+ free_number (dyin);
+ free_number (dx0);
+ free_number (dy0);
+ free_number (x0);
+ free_number (y0);
+ free_number (x1);
+ free_number (y1);
+ free_number (x2);
+ free_number (y2);
+ free_number (max_coef);
+ free_number (du);
+ free_number (dv);
+ free_number (dx);
+ free_number (dy);
+ free_number (x0a);
+ free_number (y0a);
+ free_number (x1a);
+ free_number (y1a);
+ free_number (x2a);
+ free_number (y2a);
+ free_number (t0);
+ free_number (t1);
+ free_number (t2);
+ free_number (u0);
+ free_number (u1);
+ free_number (v0);
+ free_number (v1);
+ free_number(dx_m);
+ free_number(dy_m);
+ free_number(dxin_m);
+ free_number(dx_ap);
+ free_number(dy_ap);
+ free_number(dxin_ap);
+ free_number(dyin_ap);
+ free_number(ueps_ap);
+ free_number (t);
+ return c;
+}
+
+
+@ We shall want to keep track of where certain knots on the cyclic path
+wind up in the envelope spec. It doesn't suffice just to keep pointers to
+knot nodes because some nodes are deleted while removing dead cubics. Thus
+|offset_prep| updates the following pointers
+
+@<Glob...@>=
+mp_knot spec_p1;
+mp_knot spec_p2; /* pointers to distinguished knots */
+
+@ @<Set init...@>=
+mp->spec_p1 = NULL;
+mp->spec_p2 = NULL;
+
+@ @<Initialize the pen size~|n|@>=
+n = 0;
+p = h;
+do {
+ incr (n);
+ p = mp_next_knot (p);
+} while (p != h)
+
+@ Since the true incoming direction isn't known yet, we just pick a direction
+consistent with the pen offset~|h|. If this is wrong, it can be corrected
+later.
+
+@<Initialize the incoming direction and pen offset at |c|@>=
+{
+ mp_knot hn = mp_next_knot (h);
+ mp_knot hp = mp_prev_knot (h);
+ set_number_from_substraction(dxin, hn->x_coord, hp->x_coord);
+ set_number_from_substraction(dyin, hn->y_coord, hp->y_coord);
+ if (number_zero(dxin) && number_zero(dyin)) {
+ set_number_from_substraction(dxin, hp->y_coord, h->y_coord);
+ set_number_from_substraction(dyin, h->x_coord, hp->x_coord);
+ }
+}
+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...@>=
+#ifdef DEBUGENVELOPE
+dbg_comment(Advance |p| to node |q|);dbg_nl;
+#endif
+q0 = q;
+do {
+ r = mp_next_knot (p);
+ if (number_equal (p->x_coord, p->right_x) &&
+ number_equal (p->y_coord, p->right_y) &&
+ number_equal (p->x_coord, r->left_x) &&
+ number_equal (p->y_coord, r->left_y) &&
+ number_equal (p->x_coord, r->x_coord) &&
+ number_equal (p->y_coord, r->y_coord) &&
+ r != p && r != q) {
+ @<Remove the cubic following |p| and update the data structures
+ to merge |r| into |p|@>;
+ }
+ p = r;
+} while (p != q);
+/* Check if we removed too much */
+if ((q != q0) && (q != c || c == c0))
+ q = mp_next_knot (q)
+
+
+@ @<Remove the cubic following |p| and update the data structures...@>=
+{
+ #ifdef DEBUGENVELOPE
+ dbg_key(Remove the cubic following p);dbg_open_t;dbg_nl;
+ dbg_n(p->x_coord);dbg_n(p->y_coord);
+ dbg_key_ival(pre info p,mp_knot_info(p)); dbg_close_t;dbg_comma;dbg_nl;
+ #endif
+ k_needed = mp_knot_info (p) - zero_off;
+ if (r == q) {
+ q = p;
+ } else {
+ mp_knot_info (p) = k_needed + mp_knot_info (r);
+ k_needed = 0;
+ }
+ if (r == c) {
+ mp_knot_info (p) = mp_knot_info (c);
+ c = p;
+ }
+ if (r == mp->spec_p1)
+ mp->spec_p1 = p;
+ if (r == mp->spec_p2)
+ mp->spec_p2 = p;
+ r = p;
+ mp_remove_cubic (mp, p);
+ #ifdef DEBUGENVELOPE
+ dbg_key(Remove the cubic following p);dbg_open_t;dbg_nl;
+ dbg_n(p->x_coord);dbg_n(p->y_coord);
+ dbg_key_ival(post info p,mp_knot_info (p)); dbg_close_t;dbg_comma;dbg_nl;
+ #endif
+}
+
+
+@ Not setting the |info| field of the newly created knot allows the splitting
+routine to work for paths.
+
+@<Declarations@>=
+static void mp_split_cubic (MP mp, mp_knot p, mp_number t);
+
+@ @c
+void mp_split_cubic (MP mp, mp_knot p, mp_number t) { /* splits the cubic after |p| */
+ mp_number v; /* an intermediate value */
+ mp_knot q, r; /* for list manipulation */
+ q = mp_next_knot (p);
+ r = mp_new_knot (mp);
+ mp_next_knot (p) = r;
+ mp_next_knot (r) = q;
+ mp_originator (r) = mp_program_code;
+ mp_left_type (r) = mp_explicit;
+ mp_right_type (r) = mp_explicit;
+ new_number(v);
+ set_number_from_of_the_way (v, t, p->right_x, q->left_x);
+ set_number_from_of_the_way (p->right_x, t, p->x_coord, p->right_x);
+ set_number_from_of_the_way (q->left_x, t, q->left_x, q->x_coord);
+ set_number_from_of_the_way (r->left_x, t, p->right_x, v);
+ set_number_from_of_the_way (r->right_x, t, v, q->left_x);
+ set_number_from_of_the_way (r->x_coord, t, r->left_x, r->right_x);
+ set_number_from_of_the_way (v, t, p->right_y, q->left_y);
+ set_number_from_of_the_way (p->right_y, t, p->y_coord, p->right_y);
+ set_number_from_of_the_way (q->left_y, t, q->left_y, q->y_coord);
+ set_number_from_of_the_way (r->left_y, t, p->right_y, v);
+ set_number_from_of_the_way (r->right_y, t, v, q->left_y);
+ set_number_from_of_the_way (r->y_coord, t, r->left_y, r->right_y);
+ free_number (v);
+}
+
+
+@ This does not set |mp_knot_info(p)| or |mp_right_type(p)|.
+
+@<Declarations@>=
+static void mp_remove_cubic (MP mp, mp_knot p);
+
+@ @c
+void mp_remove_cubic (MP mp, mp_knot p) { /* removes the dead cubic following~|p| */
+ mp_knot q; /* the node that disappears */
+ (void) mp;
+ q = mp_next_knot (p);
+ mp_next_knot (p) = mp_next_knot (q);
+ number_clone (p->right_x, q->right_x);
+ number_clone (p->right_y, q->right_y);
+ mp_xfree (q);
+}
+
+
+@ 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...@>=
+#ifdef DEBUGENVELOPE
+dbg_comment(Split the cubic between |p| and |q|);dbg_nl;
+dbg_key(Split the cubic);dbg_open_t;dbg_nl;
+dbg_key_ival(pre info p,mp_knot_info(p));dbg_comma;
+dbg_n(w0->x_coord);dbg_n(w0->y_coord);
+#endif
+mp_knot_info (p) = zero_off + k_needed;
+#ifdef DEBUGENVELOPE
+dbg_key_ival(post info p,mp_knot_info(p));dbg_close_t;dbg_comma; dbg_nl;
+#endif
+k_needed = 0;
+@<Prepare for derivative computations;
+ |goto not_found| if the current cubic is dead@>;
+@<Find the initial direction |(dx,dy)|@>;
+@<Update |mp_knot_info(p)| and find the offset $w_k$ such that
+ $d_{k-1}\preceq(\\{dx},\\{dy})\prec d_k$; also advance |w0| for
+ the direction change at |p|@>;
+@<Find the final direction |(dxin,dyin)|@>;
+@<Decide on the net change in pen offsets and set |turn_amt|@>;
+@<Complete the offset splitting process@>;
+w0 = mp_pen_walk (mp, w0, turn_amt)
+
+
+@ @<Declarations@>=
+static mp_knot mp_pen_walk (MP mp, mp_knot w, integer k);
+
+@ @c
+mp_knot mp_pen_walk (MP mp, mp_knot w, integer k) {
+ /* walk |k| steps around a pen from |w| */
+ (void) mp;
+ while (k > 0) {
+ w = mp_next_knot (w);
+ decr (k);
+ }
+ while (k < 0) {
+ w = mp_prev_knot (w);
+ incr (k);
+ }
+ return w;
+}
+
+
+@ The direction of a cubic $B(z_0,z_1,z_2,z_3;t)=\bigl(x(t),y(t)\bigr)$ can be
+calculated from the quadratic polynomials
+${1\over3}x'(t)=B(x_1-x_0,x_2-x_1,x_3-x_2;t)$ and
+${1\over3}y'(t)=B(y_1-y_0,y_2-y_1,y_3-y_2;t)$.
+Since we may be calculating directions from several cubics
+split from the current one, it is desirable to do these calculations
+without losing too much precision. ``Scaled up'' values of the
+derivatives, which will be less tainted by accumulated errors than
+derivatives found from the cubics themselves, are maintained in
+local variables |x0|, |x1|, and |x2|, representing $X_0=2^l(x_1-x_0)$,
+$X_1=2^l(x_2-x_1)$, and $X_2=2^l(x_3-x_2)$; similarly |y0|, |y1|, and~|y2|
+represent $Y_0=2^l(y_1-y_0)$, $Y_1=2^l(y_2-y_1)$, and $Y_2=2^l(y_3-y_2)$.
+
+@<Other local variables for |offset_prep|@>=
+mp_number x0, x1, x2, y0, y1, y2; /* representatives of derivatives */
+mp_number t0, t1, t2; /* coefficients of polynomial for slope testing */
+mp_number du, dv, dx, dy; /* for directions of the pen and the curve */
+mp_number dx0, dy0; /* initial direction for the first cubic in the curve */
+mp_number x0a, x1a, x2a, y0a, y1a, y2a; /* intermediate values */
+mp_number t; /* where the derivative passes through zero */
+mp_number s; /* a temporary value */
+mp_number dx_m; /* signal a pertubation of dx */
+mp_number dy_m; /* signal a pertubation of dx */
+mp_number dxin_m; /* signal a pertubation of dxin */
+
+
+@ @<Prepare for derivative computations...@>=
+set_number_from_substraction(x0, p->right_x, p->x_coord);
+set_number_from_substraction(x2, q->x_coord, q->left_x);
+set_number_from_substraction(x1, q->left_x, p->right_x);
+set_number_from_substraction(y0, p->right_y, p->y_coord);
+set_number_from_substraction(y2, q->y_coord, q->left_y);
+set_number_from_substraction(y1, q->left_y, p->right_y);
+#ifdef DEBUGENVELOPE
+dbg_key(Prepare for derivative computations);dbg_open_t;dbg_nl;
+dbg_n(x0);dbg_n(y0);dbg_n(x1);dbg_n(y1);dbg_n(x2);dbg_n(y2);
+dbg_close_t;dbg_comma;dbg_nl;
+#endif
+{
+ mp_number absval;
+ new_number (absval);
+ number_clone(absval, x1);
+ number_abs(absval);
+ number_clone(max_coef, x0);
+ number_abs (max_coef);
+ if (number_greater(absval, max_coef)) {
+ number_clone(max_coef, absval);
+ }
+ number_clone(absval, x2);
+ number_abs(absval);
+ if (number_greater(absval, max_coef)) {
+ number_clone(max_coef, absval);
+ }
+ number_clone(absval, y0);
+ number_abs(absval);
+ if (number_greater(absval, max_coef)) {
+ number_clone(max_coef, absval);
+ }
+ number_clone(absval, y1);
+ number_abs(absval);
+ if (number_greater(absval, max_coef)) {
+ number_clone(max_coef, absval);
+ }
+ number_clone(absval, y2);
+ number_abs(absval);
+ if (number_greater(absval, max_coef)) {
+ number_clone(max_coef, absval);
+ }
+ if (number_zero(max_coef)) {
+ goto NOT_FOUND;
+ }
+ free_number (absval);
+}
+while (number_less(max_coef, fraction_half_t)) {
+ number_double (max_coef);
+ number_double (x0);
+ number_double (x1);
+ number_double (x2);
+ number_double (y0);
+ number_double (y1);
+ number_double (y2);
+}
+
+
+@ Let us first solve a special case of the problem: Suppose we
+know an index~$k$ such that either (i)~$d(t)\succeq d_{k-1}$ for all~$t$
+and $d(0)\prec d_k$, or (ii)~$d(t)\preceq d_k$ for all~$t$ and
+$d(0)\succ d_{k-1}$.
+Then, in a sense, we're halfway done, since one of the two relations
+in $(*)$ is satisfied, and the other couldn't be satisfied for
+any other value of~|k|.
+
+Actually, the conditions can be relaxed somewhat since a relation such as
+$d(t)\succeq d_{k-1}$ restricts $d(t)$ to a half plane when all that really
+matters is whether $d(t)$ crosses the ray in the $d_{k-1}$ direction from
+the origin. The condition for case~(i) becomes $d_{k-1}\preceq d(0)\prec d_k$
+and $d(t)$ never crosses the $d_{k-1}$ ray in the clockwise direction.
+Case~(ii) is similar except $d(t)$ cannot cross the $d_k$ ray in the
+counterclockwise direction.
+
+The |fin_offset_prep| subroutine solves the stated subproblem.
+It has a parameter called |rise| that is |1| in
+case~(i), |-1| in case~(ii). Parameters |x0| through |y2| represent
+the derivative of the cubic following |p|.
+The |w| parameter should point to offset~$w_k$ and |mp_info(p)| should already
+be set properly. The |turn_amt| parameter gives the absolute value of the
+overall net change in pen offsets.
+
+@<Declarations@>=
+static void mp_fin_offset_prep (MP mp, mp_knot p, mp_knot w, mp_number
+ x0, mp_number x1, mp_number x2, mp_number y0,
+ mp_number y1, mp_number y2, integer rise,
+ integer turn_amt);
+
+@ @c
+void mp_fin_offset_prep (MP mp, mp_knot p, mp_knot w, mp_number
+ x0, mp_number x1, mp_number x2, mp_number y0, mp_number y1,
+ mp_number y2, integer rise, integer turn_amt) {
+ mp_knot ww; /* for list manipulation */
+ mp_number du, dv; /* for slope calculation */
+ mp_number t0, t1, t2; /* test coefficients */
+ mp_number t; /* place where the derivative passes a critical slope */
+ mp_number s; /* slope or reciprocal slope */
+ mp_number v; /* intermediate value for updating |x0..y2| */
+ mp_knot q; /* original |mp_next_knot(p)| */
+ q = mp_next_knot (p);
+ new_number(du);
+ new_number(dv);
+ new_number(v);
+ new_number(t0);
+ new_number(t1);
+ new_number(t2);
+ new_fraction(s);
+ new_fraction(t);
+#ifdef DEBUGENVELOPE
+dbg_key(mp_fin_offset_prep);dbg_open_t;dbg_nl;
+#endif
+ while (1) {
+ if (rise > 0)
+ ww = mp_next_knot (w); /* a pointer to $w\k$ */
+ else
+ ww = mp_prev_knot (w); /* a pointer to $w_{k-1}$ */
+#ifdef DEBUGENVELOPE
+dbg_comment(begin iteration);
+dbg_open_t;dbg_nl;
+dbg_n(w->x_coord);dbg_n(w->y_coord);
+dbg_n(ww->x_coord);dbg_n(ww->y_coord);
+dbg_n(x0);dbg_n(x1);dbg_n(x2);
+dbg_n(y0);dbg_n(y1);dbg_n(y2);
+dbg_in(rise);
+#endif
+ @<Compute test coefficients |(t0,t1,t2)|
+ for $d(t)$ versus $d_k$ or $d_{k-1}$@>;
+#ifdef DEBUGENVELOPE
+dbg_comment(crossing_point);
+#endif
+ crossing_point (t, t0, t1, t2);
+#ifdef DEBUGENVELOPE
+dbg_n(t);dbg_n(t0);dbg_n(t1);dbg_n(t2);
+dbg_in(number_greaterequal(t, fraction_one_t));
+dbg_in(turn_amt);
+dbg_close_t; dbg_comma;dbg_nl;
+#endif
+ if (number_greaterequal(t, fraction_one_t)) {
+ if (turn_amt > 0)
+ number_clone(t, fraction_one_t);
+ else
+ goto RETURN;
+ }
+#ifdef DEBUGENVELOPE
+dbg_comment(Split the cubic at $t$ and split off another cubic if the derivative crosses back);
+#endif
+ @<Split the cubic at $t$,
+ and split off another cubic if the derivative crosses back@>;
+ w = ww;
+#ifdef DEBUGENVELOPE
+dbg_comment(end iteration);
+#endif
+ }
+RETURN:
+#ifdef DEBUGENVELOPE
+dbg_comment(RETURN);
+dbg_n(t);
+#endif
+ free_number (s);
+ free_number (t);
+ free_number (du);
+ free_number (dv);
+ free_number (v);
+ free_number (t0);
+ free_number (t1);
+ free_number (t2);
+#ifdef DEBUGENVELOPE
+dbg_close_t; dbg_comma;dbg_nl;
+#endif
+}
+
+
+@ 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...@>=
+{
+ mp_number abs_du, abs_dv;
+ new_number (abs_du);
+ new_number (abs_dv);
+#ifdef DEBUGENVELOPE
+dbg_key(Compute test coefficients |(t0,t1,t2)| for $d(t)$ versus...);dbg_open_t;dbg_nl;
+#endif
+ set_number_from_substraction(du, ww->x_coord, w->x_coord);
+ set_number_from_substraction(dv, ww->y_coord, w->y_coord);
+ number_clone(abs_du, du);
+ number_abs(abs_du);
+ number_clone(abs_dv, dv);
+ number_abs(abs_dv);
+#ifdef DEBUGENVELOPE
+dbg_CUBIC;
+dbg_n(w->x_coord);dbg_n(w->y_coord);
+dbg_n(ww->x_coord);dbg_n(ww->y_coord);
+dbg_n(x0);dbg_n(x1);dbg_n(x2);
+dbg_n(y0);dbg_n(y1);dbg_n(y2);
+dbg_n(abs_du);dbg_n(abs_dv);
+dbg_n(du);dbg_n(dv);
+dbg_in(number_greaterequal(abs_du, abs_dv));
+#endif
+ if (number_greaterequal(abs_du, abs_dv)) {
+ mp_number r1;
+ new_fraction (r1);
+ make_fraction (s, dv, du);
+ take_fraction (r1, x0, s);
+ set_number_from_substraction(t0, r1, y0);
+ take_fraction (r1, x1, s);
+ set_number_from_substraction(t1, r1, y1);
+ take_fraction (r1, x2, s);
+ set_number_from_substraction(t2, r1, y2);
+ if (number_negative(du)) {
+ number_negate (t0);
+ number_negate (t1);
+ number_negate (t2);
+ }
+ free_number (r1);
+ } else {
+ mp_number r1;
+ new_fraction (r1);
+ make_fraction (s, du, dv);
+ take_fraction (r1, y0, s);
+ set_number_from_substraction(t0, x0, r1);
+ take_fraction (r1, y1, s);
+ set_number_from_substraction(t1, x1, r1);
+ take_fraction (r1, y2, s);
+ set_number_from_substraction(t2, x2, r1);
+ if (number_negative(dv)) {
+ number_negate (t0);
+ number_negate (t1);
+ number_negate (t2);
+ }
+ free_number (r1);
+ }
+ free_number (abs_du);
+ free_number (abs_dv);
+ if (number_negative(t0))
+ set_number_to_zero(t0); /* should be positive without rounding error */
+#ifdef DEBUGENVELOPE
+dbg_n(t0);dbg_n(t1);dbg_n(t2);
+dbg_close_t; dbg_comma;dbg_nl;
+#endif
+}
+
+
+@ The curve has crossed $d_k$ or $d_{k-1}$; its initial segment satisfies
+$(*)$, and it might cross again and return towards $s_{k-1}$ or $s_k$,
+respectively, yielding another solution of $(*)$.
+
+@<Split the cubic at $t$, and split off another...@>=
+{
+ mp_split_cubic (mp, p, t);
+ p = mp_next_knot (p);
+ mp_knot_info (p) = zero_off + rise;
+ decr (turn_amt);
+ set_number_from_of_the_way(v, t, x0, x1);
+ set_number_from_of_the_way(x1, t, x1, x2);
+ set_number_from_of_the_way(x0, t, v, x1);
+ set_number_from_of_the_way(v, t, y0, y1);
+ set_number_from_of_the_way(y1, t, y1, y2);
+ set_number_from_of_the_way(y0, t, v, y1);
+ if (turn_amt < 0) {
+ mp_number arg1, arg2, arg3;
+ new_number (arg1);
+ new_number (arg2);
+ new_number (arg3);
+ set_number_from_of_the_way(t1, t, t1, t2);
+ if (number_positive(t1))
+ set_number_to_zero(t1); /* without rounding error, |t1| would be |<=0| */
+ number_clone(arg2, t1);
+ number_negate(arg2);
+ number_clone(arg3, t2);
+ number_negate(arg3);
+ crossing_point (t, arg1, arg2, arg3); /* arg1 is zero */
+ free_number (arg1);
+ free_number (arg2);
+ free_number (arg3);
+ if (number_greater(t, fraction_one_t))
+ number_clone(t, fraction_one_t);
+ incr (turn_amt);
+ if (number_equal(t,fraction_one_t) && (mp_next_knot (p) != q)) {
+ mp_knot_info (mp_next_knot (p)) = mp_knot_info (mp_next_knot (p)) - rise;
+ } else {
+ mp_split_cubic (mp, p, t);
+ mp_knot_info (mp_next_knot (p)) = zero_off - rise;
+ set_number_from_of_the_way(v, t, x1, x2);
+ set_number_from_of_the_way(x1, t, x0, x1);
+ set_number_from_of_the_way(x2, t, x1, v);
+ set_number_from_of_the_way(v, t, y1, y2);
+ set_number_from_of_the_way(y1, t, y0, y1);
+ set_number_from_of_the_way(y2, t, y1, v);
+ }
+ }
+}
+
+
+@ Now we must consider the general problem of |offset_prep|, when
+nothing is known about a given cubic. We start by finding its
+direction in the vicinity of |t=0|.
+
+If $z'(t)=0$, the given cubic is numerically unstable but |offset_prep|
+has not yet introduced any more numerical errors. Thus we can compute
+the true initial direction for the given cubic, even if it is almost
+degenerate.
+
+@<Find the initial direction |(dx,dy)|@>=
+#ifdef DEBUGENVELOPE
+dbg_nl;
+dbg_comment(Find the initial direction |(dx,dy)|);dbg_nl;
+dbg_n(w0->x_coord);dbg_n(w0->y_coord);
+#endif
+number_clone(dx_m, zero_t);
+number_clone(dy_m, zero_t);
+number_clone(dx, x0);
+number_clone(dy, y0);
+if (number_zero(dx) && number_zero(dy)) {
+ number_clone(dx, x1);
+ number_clone(dy, y1);
+ if (number_zero(dx) && number_zero(dy)) {
+ number_clone(dx, x2);
+ number_clone(dy, y2);
+ }
+}
+if (p == c) {
+ number_clone(dx0, dx);
+ number_clone(dy0, dy);
+}
+/* BEGIN PATCH */
+#ifdef DEBUGENVELOPE
+dbg_nl;dbg_key(mp_dx_dy_approx_t_1);dbg_open_t;dbg_nl;
+dbg_n(ueps_ap);
+dbg_n(p->x_coord);dbg_n(p->y_coord);
+dbg_n(p->right_x);dbg_n(p->right_y);
+dbg_n(q->left_x);dbg_n(q->left_y);
+dbg_n(q->x_coord);dbg_n(q->y_coord);
+#endif
+#ifdef DEBUGENVELOPE
+dbg_n(dxin_ap);dbg_n(dyin_ap);
+dbg_close_t;dbg_comma;dbg_nl;
+#endif
+#ifdef DEBUGENVELOPE
+dbg_nl;dbg_key(mp_dx_dy_approx_t_0);dbg_open_t;dbg_nl;
+dbg_n(ueps_ap);
+dbg_n(p->x_coord);dbg_n(p->y_coord);
+dbg_n(p->right_x);dbg_n(p->right_y);
+dbg_n(q->left_x);dbg_n(q->left_y);
+dbg_n(q->x_coord);dbg_n(q->y_coord);
+#endif
+#ifdef DEBUGENVELOPE
+dbg_close_t;dbg_comma;dbg_nl;
+dbg_key(derivatives);dbg_open_t;dbg_nl;
+dbg_n(dx_m);dbg_n(dy_m);
+dbg_n(dx);dbg_n(dy);dbg_n(dx_ap);dbg_n(dy_ap);dbg_close_t;dbg_comma;dbg_nl;
+#endif
+#ifdef DEBUGENVELOPE
+dbg_key(derivatives after first patch );dbg_open_t;dbg_nl;
+dbg_n(dx_m);dbg_n(dy_m);
+dbg_n(dx);dbg_n(dy);dbg_n(dx_ap);dbg_n(dy_ap);dbg_close_t;dbg_comma;dbg_nl;
+#endif
+#ifdef DEBUGENVELOPE
+dbg_key(derivatives patched);dbg_open_t;dbg_nl;
+dbg_n(dx_m);dbg_n(dy_m);
+dbg_n(dx);dbg_n(dy);dbg_n(dx_ap);dbg_n(dy_ap);dbg_close_t;dbg_comma;dbg_nl;
+#endif
+/* END PATCH */
+
+
+@ @<Find the final direction |(dxin,dyin)|@>=
+number_clone(dxin, x2);
+number_clone(dyin, y2);
+if (number_zero(dxin) && number_zero(dyin)) {
+ number_clone(dxin, x1);
+ number_clone(dyin, y1);
+ if (number_zero(dxin) && number_zero(dyin)) {
+ number_clone(dxin, x0);
+ number_clone(dyin, y0);
+ }
+}
+#ifdef DEBUGENVELOPE
+dbg_key(dxin dyin before);dbg_open_t;dbg_nl;
+dbg_n(dxin);dbg_n(dyin);
+dbg_close_t;dbg_comma;
+#endif
+#ifdef DEBUGENVELOPE
+dbg_key(dxin dyin after);dbg_open_t;dbg_nl;
+dbg_n(dxin);dbg_n(dyin);
+dbg_close_t;dbg_comma;
+#endif
+/* BEGIN PATCH */
+#ifdef DEBUGENVELOPE
+dbg_key(dx dy dxin dyin after patch);dbg_open_t;dbg_nl;
+dbg_n(dx);dbg_n(dy);dbg_n(dx_ap);dbg_n(dy_ap);
+dbg_n(dxin);dbg_n(dyin);dbg_n(dxin_ap);dbg_n(dyin_ap);
+dbg_close_t;dbg_comma;
+#endif
+/* END PATCH ****/
+
+@ 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 |mp_knot_info(p)| and find the offset $w_k$ such that...@>=
+{
+ mp_number ab_vs_cd;
+ new_number (ab_vs_cd);
+ ab_vs_cd (ab_vs_cd, dy, dxin, dx, dyin);
+#ifdef DEBUGENVELOPE
+dbg_nl;
+dbg_comment(Update |mp_knot_info(p)|);dbg_nl;
+dbg_key(mp_get_turn_amt_dx_dy);dbg_open_t;dbg_str(--[==[call mp_get_turn_amt]==]);dbg_nl;
+dbg_n(w0->x_coord);dbg_n(w0->y_coord);dbg_n(dx);dbg_n(dy);dbg_in(number_nonnegative(ab_vs_cd));
+dbg_n(ab_vs_cd);
+#endif
+ is_dxdy=true;
+ turn_amt = mp_get_turn_amt (mp, w0, dx, dy, number_nonnegative(ab_vs_cd));
+ is_dxdy=false;
+#ifdef DEBUGENVELOPE
+dbg_dn(turn_amt);
+dbg_close_t;dbg_comma;
+dbg_nl;
+#endif
+ free_number (ab_vs_cd);
+#ifdef DEBUGENVELOPE
+dbg_key(w0 before walk);dbg_open_t;dbg_nl;
+dbg_n(w0->x_coord);dbg_n(w0->y_coord);
+dbg_dn(turn_amt);
+dbg_close_t;dbg_comma;
+#endif
+ w = mp_pen_walk (mp, w0, turn_amt);
+ w0 = w;
+#ifdef DEBUGENVELOPE
+dbg_key(w0 after walk);dbg_open_t;dbg_nl;
+dbg_n(w0->x_coord);dbg_n(w0->y_coord);
+dbg_close_t;dbg_comma;
+dbg_open_t;dbg_in(mp_knot_info(p));
+#endif
+ mp_knot_info (p) = mp_knot_info (p) + turn_amt;
+#ifdef DEBUGENVELOPE
+ dbg_in(mp_knot_info(p));dbg_close_t;dbg_comma;
+#endif
+}
+
+@ 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.
+
+@<Declarations@>=
+static integer mp_get_turn_amt (MP mp, mp_knot w, mp_number dx,
+ mp_number dy, boolean ccw);
+
+@ @c
+integer mp_get_turn_amt (MP mp, mp_knot w, mp_number dx, mp_number dy, boolean ccw) {
+ mp_knot ww; /* a neighbor of knot~|w| */
+ integer s; /* turn amount so far */
+ mp_number t; /* |ab_vs_cd| result */
+ mp_number t_ap; /* |ab_vs_cd| approx. result */
+ mp_number arg1, arg2;
+ s = 0;
+ new_number (arg1);
+ new_number (arg2);
+ new_number (t);
+ new_number (t_ap);
+ if (ccw) {
+ ww = mp_next_knot (w);
+ do {
+ set_number_from_substraction (arg1, ww->x_coord, w->x_coord);
+ set_number_from_substraction (arg2, ww->y_coord, w->y_coord);
+ ab_vs_cd (t, dy, arg1, dx, arg2);
+#ifdef DEBUGENVELOPE
+ dbg_sp;
+ dbg_open_t;dbg_str(--[==[inside mp_get_turn_amt do loop ]==]);dbg_nl;
+ dbg_n(w->x_coord);dbg_n(w->y_coord);dbg_n(ww->x_coord);dbg_n(ww->y_coord);
+ dbg_n(t);dbg_n(dy);dbg_n(arg1);dbg_n(dx);dbg_n(arg2);
+ dbg_n(t_ap);dbg_n(dy_ap);dbg_n(dx_ap);dbg_n(dyin_ap);dbg_n(dxin_ap);
+ dbg_close_t;dbg_comma;
+ dbg_in(number_zero(dx) && number_zero(arg1) && number_positive(dy) && number_positive(arg2) && is_dxdy);
+ dbg_in(is_dxdy && number_zero(dx) && number_zero(arg1) && number_negative(dy) && number_negative(arg2) && number_positive(dyin_ap));
+ dbg_in(is_dxindyin && number_zero(dx) && number_zero(arg1) && number_positive(dy) && number_positive(arg2) && number_negative(dyin_ap));
+ dbg_in(number_zero(dy) && number_zero(arg2) && number_negative(dx) && number_negative(arg1));
+ dbg_in(number_zero(dx) && number_zero(arg1) && number_negative(dy) && number_positive(arg2));
+ dbg_in(number_zero(dy) && number_zero(arg2) && number_positive(dx) && number_negative(arg1));
+ dbg_nl;
+#endif
+ if (number_negative(t))
+ break;
+ incr (s);
+ w = ww;
+ ww = mp_next_knot (ww);
+ } while (number_positive(t));
+ } else {
+ ww = mp_prev_knot (w);
+ set_number_from_substraction (arg1, w->x_coord, ww->x_coord);
+ set_number_from_substraction (arg2, w->y_coord, ww->y_coord);
+ ab_vs_cd (t, dy, arg1, dx, arg2);
+#ifdef DEBUGENVELOPE
+ dbg_sp;
+ dbg_open_t;dbg_str(--[==[outside mp_get_turn_amt do loop ]==]);dbg_nl;
+ dbg_n(w->x_coord);dbg_n(w->y_coord);dbg_n(ww->x_coord);dbg_n(ww->y_coord);
+ dbg_n(t);dbg_n(dy);dbg_n(arg1);dbg_n(dx);dbg_n(arg2);
+ dbg_n(t_ap);dbg_n(dy_ap);dbg_n(dx_ap);dbg_n(dyin_ap);dbg_n(dxin_ap);
+ dbg_close_t;dbg_comma;
+ dbg_nl;
+#endif
+ while (number_negative(t)) {
+ decr (s);
+ w = ww;
+ ww = mp_prev_knot (ww);
+ set_number_from_substraction (arg1, w->x_coord, ww->x_coord);
+ set_number_from_substraction (arg2, w->y_coord, ww->y_coord);
+ ab_vs_cd (t, dy, arg1, dx, arg2);
+#ifdef DEBUGENVELOPE
+ dbg_sp;
+ dbg_open_t;dbg_str(--[==[inside mp_get_turn_amt do loop for t<0 ]==]);dbg_nl;
+ dbg_n(w->x_coord);dbg_n(w->y_coord);dbg_n(ww->x_coord);dbg_n(ww->y_coord);
+ dbg_n(t);dbg_n(dy);dbg_n(arg1);dbg_n(dx);dbg_n(arg2);
+ dbg_n(t_ap);dbg_n(dy_ap);dbg_n(dx_ap);
+ dbg_close_t;dbg_comma;
+ dbg_nl;
+#endif
+ }
+ }
+ free_number (t);
+ free_number (t_ap);
+ free_number (arg1);
+ free_number (arg2);
+ return s;
+}
+
+
+@ When we're all done, the final offset is |w0| and the final curve direction
+is |(dxin,dyin)|. With this knowledge of the incoming direction at |c|, we
+can correct |mp_info(c)| which was erroneously based on an incoming offset
+of~|h|.
+
+@d fix_by(A) mp_knot_info(c)=mp_knot_info(c)+(A)
+
+@<Fix the offset change in |mp_knot_info(c)| and set |c| to the return value of...@>=
+mp->spec_offset = mp_knot_info (c) - zero_off;
+if (mp_next_knot (c) == c) {
+mp_knot_info (c) = zero_off + n;
+} else {
+ mp_number ab_vs_cd;
+ new_number (ab_vs_cd);
+ fix_by (k_needed);
+ while (w0 != h) {
+ fix_by (1);
+ w0 = mp_next_knot (w0);
+ }
+ while (mp_knot_info (c) <= zero_off - n)
+ fix_by (n);
+ while (mp_knot_info (c) > zero_off)
+ fix_by (-n);
+ ab_vs_cd (ab_vs_cd, dy0, dxin, dx0, dyin);
+ if ((mp_knot_info (c) != zero_off) && number_nonnegative(ab_vs_cd))
+ fix_by (n);
+ free_number (ab_vs_cd);
+}
+
+
+@ 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 = mp_prev_knot (w);
+#ifdef DEBUGENVELOPE
+dbg_key(Complete the offset splitting process);dbg_open_t;dbg_nl;
+dbg_n(w->x_coord);dbg_n(w->y_coord);
+dbg_n(ww->x_coord);dbg_n(ww->y_coord);
+dbg_close_t; dbg_comma;dbg_nl;
+#endif
+@<Compute test coeff...@>;
+#ifdef DEBUGENVELOPE
+dbg_key(after Compute test coeff);dbg_open_t;dbg_nl;
+dbg_n(w->x_coord);dbg_n(w->y_coord);
+dbg_n(ww->x_coord);dbg_n(ww->y_coord);
+dbg_close_t; dbg_comma;dbg_nl;
+#endif
+@<Find the first |t| where $d(t)$ crosses $d_{k-1}$ or set
+ |t:=fraction_one+1|@>;
+if (number_greater(t, fraction_one_t)) {
+#ifdef DEBUGENVELOPE
+dbg_key(t > fraction_one_t);dbg_open_t;dbg_nl;
+dbg_n(p->x_coord);dbg_n(p->y_coord);
+dbg_n(w->x_coord);dbg_n(w->y_coord);
+dbg_n(x0);dbg_n(x1);dbg_n(x2);
+dbg_n(y0);dbg_n(y1);dbg_n(y2);
+dbg_close_t; dbg_comma;dbg_nl;
+#endif
+ mp_fin_offset_prep (mp, p, w, x0, x1, x2, y0, y1, y2, 1, turn_amt);
+} else {
+ mp_split_cubic (mp, p, t);
+ r = mp_next_knot (p);
+ set_number_from_of_the_way(x1a, t, x0, x1);
+ set_number_from_of_the_way(x1, t, x1, x2);
+ set_number_from_of_the_way(x2a, t, x1a, x1);
+ set_number_from_of_the_way(y1a, t, y0, y1);
+ set_number_from_of_the_way(y1, t, y1, y2);
+ set_number_from_of_the_way(y2a, t, y1a, y1);
+#ifdef DEBUGENVELOPE
+dbg_key(t <= fraction_one_t);dbg_open_t;dbg_nl;
+dbg_n(p->x_coord);dbg_n(p->y_coord);
+dbg_n(t);
+dbg_n(r->x_coord);dbg_n(r->y_coord);
+dbg_n(w->x_coord);dbg_n(w->y_coord);
+dbg_n(x0);dbg_n(x1a);dbg_n(x2a);
+dbg_n(y0);dbg_n(y1a);dbg_n(y2a);
+dbg_close_t; dbg_comma;dbg_nl;
+#endif
+ mp_fin_offset_prep (mp, p, w, x0, x1a, x2a, y0, y1a, y2a, 1, 0);
+ number_clone(x0, x2a);
+ number_clone(y0, y2a);
+ mp_knot_info (r) = zero_off - 1;
+ if (turn_amt >= 0) {
+ mp_number arg1, arg2, arg3;
+ new_number(arg1);
+ new_number(arg2);
+ new_number(arg3);
+ set_number_from_of_the_way(t1, t, t1, t2);
+ if (number_positive(t1))
+ set_number_to_zero(t1);
+ number_clone(arg2, t1);
+ number_negate(arg2);
+ number_clone(arg3, t2);
+ number_negate(arg3);
+ crossing_point (t, arg1, arg2, arg3);
+ free_number (arg1);
+ free_number (arg2);
+ free_number (arg3);
+ if (number_greater(t, fraction_one_t))
+ number_clone (t, fraction_one_t);
+ @<Split off another rising cubic for |fin_offset_prep|@>;
+ mp_fin_offset_prep (mp, r, ww, x0, x1, x2, y0, y1, y2, -1, 0);
+ } else {
+ mp_fin_offset_prep (mp, r, ww, x0, x1, x2, y0, y1, y2, -1, (-1 - turn_amt));
+ }
+}
+#ifdef DEBUGENVELOPE
+dbg_key(end Complete the offset splitting process);dbg_open_t;dbg_nl;
+dbg_n(w->x_coord);dbg_n(w->y_coord);
+dbg_n(w0->x_coord);dbg_n(w0->y_coord);
+dbg_in(turn_amt);
+dbg_close_t; dbg_comma;dbg_nl;
+#endif
+
+@ @<Split off another rising cubic for |fin_offset_prep|@>=
+mp_split_cubic (mp, r, t);
+mp_knot_info (mp_next_knot (r)) = zero_off + 1;
+set_number_from_of_the_way(x1a, t, x1, x2);
+set_number_from_of_the_way(x1, t, x0, x1);
+set_number_from_of_the_way(x0a, t, x1, x1a);
+set_number_from_of_the_way(y1a, t, y1, y2);
+set_number_from_of_the_way(y1, t, y0, y1);
+set_number_from_of_the_way(y0a, t, y1, y1a);
+mp_fin_offset_prep (mp, mp_next_knot (r), w, x0a, x1a, x2, y0a, y1a, y2, 1, turn_amt);
+number_clone(x2, x0a);
+number_clone(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...@>=
+#ifdef DEBUGENVELOPE
+dbg_key(Find the first |t| where);dbg_open_t;dbg_nl;
+#endif
+crossing_point (t, t0, t1, t2);
+if (turn_amt >= 0) {
+ if (number_negative(t2)) {
+ number_clone(t, fraction_one_t);
+ number_add_scaled (t, 1);
+ } else {
+ mp_number tmp, arg1, r1;
+ new_fraction (r1);
+ new_number(tmp);
+ new_number(arg1);
+ set_number_from_of_the_way(u0, t, x0, x1);
+ set_number_from_of_the_way(u1, t, x1, x2);
+ set_number_from_of_the_way(tmp, t, u0, u1);
+ number_clone (arg1, du);
+ number_negate(arg1);
+ take_fraction (ss, arg1, tmp);
+ set_number_from_of_the_way(v0, t, y0, y1);
+ set_number_from_of_the_way(v1, t, y1, y2);
+ set_number_from_of_the_way(tmp, t, v0, v1);
+ number_clone (arg1, dv);
+ number_negate(arg1);
+ take_fraction (r1, arg1, tmp);
+ number_add (ss, r1);
+ free_number (tmp);
+ if (number_negative(ss)) {
+ number_clone(t, fraction_one_t);
+ number_add_scaled (t, 1);
+ }
+ free_number(arg1);
+ free_number(r1);
+ }
+} else if (number_greater(t, fraction_one_t)) {
+ number_clone (t, fraction_one_t);
+}
+#ifdef DEBUGENVELOPE
+dbg_n(t);
+dbg_close_t; dbg_comma;dbg_nl;
+#endif
+
+
+@ @<Other local variables for |offset_prep|@>=
+mp_number u0, u1, v0, v1; /* intermediate values for $d(t)$ calculation */
+int d_sign; /* sign of overall change in direction for this cubic */
+
+@ If the cubic almost has a cusp, it is a numerically ill-conditioned
+problem to decide which way it loops around but that's OK as long we're
+consistent. To make \&{doublepath} envelopes work properly, reversing
+the path should always change the sign of |turn_amt|.
+
+@<Decide on the net change in pen offsets and set |turn_amt|@>=
+{
+ mp_number ab_vs_cd;
+ mp_number t_ap;
+ new_number (t_ap);
+ new_number (ab_vs_cd);
+#ifdef DEBUGENVELOPE
+dbg_sp;
+dbg_key(Decide on the net change in pen offsets and set turn_amt);dbg_open_t;dbg_nl;
+#endif
+ ab_vs_cd (ab_vs_cd, dx, dyin, dxin, dy);
+#ifdef DEBUGENVELOPE
+dbg_n(ab_vs_cd);dbg_n(dx);dbg_n(dyin);dbg_n(dxin);dbg_n(dy);
+#endif
+/* BEGIN PATCH */
+#ifdef DEBUGENVELOPE
+dbg_key_nval(ab_vs_cd patched,ab_vs_cd);
+dbg_close_t;dbg_comma;dbg_nl;
+#endif
+/* END PATCH */
+ if (number_negative (ab_vs_cd))
+ d_sign = -1;
+ else if (number_zero (ab_vs_cd))
+ d_sign = 0;
+ else
+ d_sign = 1;
+ free_number (ab_vs_cd);
+ free_number (t_ap);
+}
+if (d_sign == 0) {
+ @<Check rotation direction based on node position@>
+}
+if (d_sign == 0) {
+ if (number_zero(dx)) {
+ if (number_positive(dy))
+ d_sign = 1;
+ else
+ d_sign = -1;
+ } else {
+ if (number_positive(dx))
+ d_sign = 1;
+ else
+ d_sign = -1;
+ }
+}
+@<Make |ss| negative if and only if the total change in direction is
+ more than $180^\circ$@>;
+#ifdef DEBUGENVELOPE
+dbg_nl;
+dbg_key(Make |ss| negative if and only if); dbg_open_t;dbg_nl;
+dbg_key(mp_get_turn_amt_dxin_dyin);dbg_open_t;dbg_str(--[==[call mp_get_turn_amt]==]);dbg_nl; ;
+dbg_n(w->x_coord);dbg_n(w->y_coord);dbg_n(dxin);dbg_n(dyin);dbg_in((d_sign > 0));
+#endif
+is_dxindyin=true;
+turn_amt = mp_get_turn_amt (mp, w, dxin, dyin, (d_sign > 0));
+is_dxindyin=false;
+#ifdef DEBUGENVELOPE
+dbg_key_dval(turn_amt 1,turn_amt);dbg_comma;dbg_nl;
+dbg_key_nval(ss,ss);dbg_comma;dbg_nl;
+dbg_key_ival(d_sign,d_sign);dbg_comma;dbg_nl;
+dbg_key_ival(n,n);dbg_comma;dbg_nl;
+#endif
+if (number_negative(ss))
+ turn_amt = turn_amt - d_sign * n;
+#ifdef DEBUGENVELOPE
+dbg_key_dval(turn_amt 2,turn_amt);dbg_comma;dbg_nl;
+dbg_close_t;dbg_comma;dbg_nl;
+dbg_close_t;dbg_comma;dbg_nl;
+#endif
+
+
+@ 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@>=
+{
+ mp_number ab_vs_cd1, ab_vs_cd2, t;
+ new_number (ab_vs_cd1);
+ new_number (ab_vs_cd2);
+ new_number (t);
+ set_number_from_substraction(u0, q->x_coord, p->x_coord);
+ set_number_from_substraction(u1, q->y_coord, p->y_coord);
+ ab_vs_cd (ab_vs_cd1, dx, u1, u0, dy);
+ ab_vs_cd (ab_vs_cd2, u0, dyin, dxin, u1);
+ set_number_from_addition (t, ab_vs_cd1, ab_vs_cd2);
+ number_half (t);
+ if (number_negative (t))
+ d_sign = -1;
+ else if (number_zero (t))
+ d_sign = 0;
+ else
+ d_sign = 1;
+ free_number (t);
+ free_number (ab_vs_cd1);
+ free_number (ab_vs_cd2);
+}
+
+@ 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...@>=
+{
+ mp_number r1, r2, arg1;
+ new_number (arg1);
+ new_fraction (r1);
+ new_fraction (r2);
+ take_fraction (r1, x0, y2);
+ take_fraction (r2, x2, y0);
+#ifdef DEBUGENVELOPE
+dbg_sp;
+dbg_open_t;dbg_dn(d_sign);dbg_close_t;dbg_comma;dbg_nl;
+#endif
+ number_half (r1);
+ number_half (r2);
+ set_number_from_substraction(t0, r1, r2);
+ set_number_from_addition (arg1, y0, y2);
+ take_fraction (r1, x1, arg1);
+ set_number_from_addition (arg1, x0, x2);
+ /*|take_fraction (r1, y1, arg1);|*//* The old one, is it correct ?*/
+ take_fraction (r2, y1, arg1);
+ number_half (r1);
+ number_half (r2);
+ set_number_from_substraction(t1, r1, r2);
+ free_number (arg1);
+ free_number (r1);
+ free_number (r2);
+}
+if (number_zero(t0))
+ set_number_from_scaled(t0, d_sign); /* path reversal always negates |d_sign| */
+if (number_positive(t0)) {
+ mp_number arg3;
+ new_number(arg3);
+ number_clone(arg3, t0);
+ number_negate(arg3);
+ crossing_point (t, t0, t1, arg3);
+ free_number (arg3);
+ set_number_from_of_the_way(u0, t, x0, x1);
+ set_number_from_of_the_way(u1, t, x1, x2);
+ set_number_from_of_the_way(v0, t, y0, y1);
+ set_number_from_of_the_way(v1, t, y1, y2);
+} else {
+ mp_number arg1;
+ new_number(arg1);
+ number_clone(arg1, t0);
+ number_negate(arg1);
+ crossing_point (t, arg1, t1, t0);
+ free_number (arg1);
+ set_number_from_of_the_way(u0, t, x2, x1);
+ set_number_from_of_the_way(u1, t, x1, x0);
+ set_number_from_of_the_way(v0, t, y2, y1);
+ set_number_from_of_the_way(v1, t, y1, y0);
+}
+{
+ mp_number tmp1, tmp2, r1, r2, arg1;
+ mp_number abs_ss, eps_ss;
+ new_fraction (r1);
+ new_fraction (r2);
+ new_number(arg1);
+ new_number(tmp1);
+ new_number(tmp2);
+ set_number_from_of_the_way(tmp1, t, u0, u1);
+ set_number_from_of_the_way(tmp2, t, v0, v1);
+ set_number_from_addition(arg1, x0, x2);
+ take_fraction (r1, arg1, tmp1);
+ set_number_from_addition(arg1, y0, y2);
+ take_fraction (r2, arg1, tmp2);
+ set_number_from_addition (ss, r1, r2);
+ /* BEGIN PATCH */
+#ifdef DEBUGENVELOPE
+dbg_key(patch ss before);dbg_open_t;
+dbg_n(ss);dbg_close_t;dbg_comma;
+#endif
+#ifdef DEBUGENVELOPE
+dbg_key(patch ss after);dbg_open_t;
+dbg_n(ss);dbg_close_t;dbg_comma;
+#endif
+ free_number(abs_ss);
+ free_number(eps_ss);
+ /* END PATCH */
+ free_number (arg1);
+ free_number (r1);
+ free_number (r2);
+ free_number (tmp1);
+ free_number (tmp2);
+}
+
+
+@ Here's a routine that prints an envelope spec in symbolic form. It assumes
+that the |cur_pen| has not been walked around to the first offset.
+
+@c
+static void mp_print_spec (MP mp, mp_knot cur_spec, mp_knot cur_pen,
+ const char *s) {
+ mp_knot p, q; /* list traversal */
+ mp_knot w; /* the current pen offset */
+ mp_print_diagnostic (mp, "Envelope spec", s, true);
+ p = cur_spec;
+ w = mp_pen_walk (mp, cur_pen, mp->spec_offset);
+ mp_print_ln (mp);
+ mp_print_two (mp, cur_spec->x_coord, cur_spec->y_coord);
+ mp_print (mp, " % beginning with offset ");
+ mp_print_two (mp, w->x_coord, w->y_coord);
+ do {
+ while (1) {
+ q = mp_next_knot (p);
+ @<Print the cubic between |p| and |q|@>;
+ p = q;
+ if ((p == cur_spec) || (mp_knot_info (p) != zero_off))
+ break;
+ }
+ if (mp_knot_info (p) != zero_off) {
+ @<Update |w| as indicated by |mp_knot_info(p)| and print an explanation@>;
+ }
+ } while (p != cur_spec);
+ mp_print_nl (mp, " & cycle");
+ mp_end_diagnostic (mp, true);
+}
+
+
+@ @<Update |w| as indicated by |mp_knot_info(p)| and print an explanation@>=
+{
+ w = mp_pen_walk (mp, w, (mp_knot_info (p) - zero_off));
+ mp_print (mp, " % ");
+#ifdef DEBUGENVELOPE
+ dbg_nl;dbg_open_t;dbg_str(--[==[START]==]);dbg_nl;
+ dbg_key(Printing mp_knot_info (p));dbg_open_t;dbg_nl;
+ dbg_n(p->x_coord);dbg_n(p->y_coord);
+ dbg_in(mp_knot_info(p));
+ dbg_close_t;dbg_close_t;dbg_comma;dbg_nl;
+ dbg_nl;dbg_str(--[==[STOP]==]);dbg_nl;
+#endif
+ if (mp_knot_info (p) > zero_off)
+ mp_print (mp, "counter");
+ mp_print (mp, "clockwise to offset ");
+ mp_print_two (mp, w->x_coord, w->y_coord);
+}
+
+
+@ @<Print the cubic between |p| and |q|@>=
+{
+ mp_print_nl (mp, " ..controls ");
+ mp_print_two (mp, p->right_x, p->right_y);
+ mp_print (mp, " and ");
+ mp_print_two (mp, q->left_x, q->left_y);
+ mp_print_nl (mp, " ..");
+ mp_print_two (mp, q->x_coord, q->y_coord);
+}
+
+
+@ Once we have an envelope spec, the remaining task to construct the actual
+envelope by offsetting each cubic as determined by the |info| fields in
+the knots. First we use |offset_prep| to convert the |c| into an envelope
+spec. Then we add the offsets so that |c| becomes a cyclic path that represents
+the envelope.
+
+The |ljoin| and |miterlim| parameters control the treatment of points where the
+pen offset changes, and |lcap| controls the endpoints of a \&{doublepath}.
+The endpoints are easily located because |c| is given in undoubled form
+and then doubled in this procedure. We use |spec_p1| and |spec_p2| to keep
+track of the endpoints and treat them like very sharp corners.
+Butt end caps are treated like beveled joins; round end caps are treated like
+round joins; and square end caps are achieved by setting |join_type:=3|.
+
+None of these parameters apply to inside joins where the convolution tracing
+has retrograde lines. In such cases we use a simple connect-the-endpoints
+approach that is achieved by setting |join_type:=2|.
+
+@c
+static mp_knot mp_make_envelope (MP mp, mp_knot c, mp_knot h, quarterword ljoin,
+ quarterword lcap, mp_number miterlim) {
+ mp_knot p, q, r, q0; /* for manipulating the path */
+ mp_knot w, w0; /* the pen knot for the current offset */
+ halfword k, k0; /* controls pen edge insertion */
+ mp_number qx, qy; /* unshifted coordinates of |q| */
+ mp_fraction dxin, dyin, dxout, dyout; /* directions at |q| when square or mitered */
+ int join_type = 0; /* codes |0..3| for mitered, round, beveled, or square */
+ @<Other local variables for |make_envelope|@>;
+ new_number (max_ht);
+ new_number (tmp);
+ new_fraction(dxin);
+ new_fraction(dyin);
+ new_fraction(dxout);
+ new_fraction(dyout);
+ mp->spec_p1 = NULL;
+ mp->spec_p2 = NULL;
+ new_number(qx);
+ new_number(qy);
+ @<If endpoint, double the path |c|, and set |spec_p1| and |spec_p2|@>;
+ @<Use |offset_prep| to compute the envelope spec then walk |h| around to
+ the initial offset@>;
+ w = h;
+ p = c;
+ do {
+ q = mp_next_knot (p);
+ q0 = q;
+ number_clone (qx, q->x_coord);
+ number_clone (qy, q->y_coord);
+ k = mp_knot_info (q);
+ k0 = k;
+ w0 = w;
+ if (k != zero_off) {
+ @<Set |join_type| to indicate how to handle offset changes at~|q|@>;
+ }
+ @<Add offset |w| to the cubic from |p| to |q|@>;
+ while (k != zero_off) {
+ @<Step |w| and move |k| one step closer to |zero_off|@>;
+ if ((join_type == 1) || (k == zero_off)) {
+ mp_number xtot, ytot;
+ new_number(xtot);
+ new_number(ytot);
+ set_number_from_addition (xtot, qx, w->x_coord);
+ set_number_from_addition (ytot, qy, w->y_coord);
+ q = mp_insert_knot (mp, q, xtot, ytot);
+ free_number (xtot);
+ free_number (ytot);
+ }
+ }
+ if (q != mp_next_knot (p)) {
+ @<Set |p=mp_link(p)| and add knots between |p| and |q| as
+ required by |join_type|@>;
+ }
+ p = q;
+ } while (q0 != c);
+ free_number (max_ht);
+ free_number (tmp);
+ free_number (qx);
+ free_number (qy);
+ free_number (dxin);
+ free_number (dyin);
+ free_number (dxout);
+ free_number (dyout);
+ return c;
+}
+
+
+@ @<Use |offset_prep| to compute the envelope spec then walk |h| around to...@>=
+c = mp_offset_prep (mp, c, h);
+if (number_positive(internal_value (mp_tracing_specs)))
+ mp_print_spec (mp, c, h, "");
+h = mp_pen_walk (mp, h, mp->spec_offset)
+
+
+@ Mitered and squared-off joins depend on path directions that are difficult to
+compute for degenerate cubics. The envelope spec computed by |offset_prep| can
+have degenerate cubics only if the entire cycle collapses to a single
+degenerate cubic. Setting |join_type:=2| in this case makes the computed
+envelope degenerate as well.
+
+@<Set |join_type| to indicate how to handle offset changes at~|q|@>=
+if (k < zero_off) {
+ join_type = 2;
+} else {
+ if ((q != mp->spec_p1) && (q != mp->spec_p2))
+ join_type = ljoin;
+ else if (lcap == 2)
+ join_type = 3;
+ else
+ join_type = 2 - lcap;
+ if ((join_type == 0) || (join_type == 3)) {
+ @<Set the incoming and outgoing directions at |q|; in case of
+ degeneracy set |join_type:=2|@>;
+ if (join_type == 0) {
+ @<If |miterlim| is less than the secant of half the angle at |q|
+ then set |join_type:=2|@>;
+ }
+ }
+}
+
+
+@ @<If |miterlim| is less than the secant of half the angle at |q|...@>=
+{
+ mp_number r1, r2;
+ new_fraction (r1);
+ new_fraction (r2);
+ take_fraction (r1, dxin, dxout);
+ take_fraction (r2, dyin, dyout);
+ number_add (r1, r2);
+ number_half (r1);
+ number_add (r1, fraction_half_t);
+ take_fraction (tmp, miterlim, r1);
+ if (number_less(tmp, unity_t)) {
+ mp_number ret;
+ new_number (ret);
+ take_scaled (ret, miterlim, tmp);
+ if (number_less(ret, unity_t))
+ join_type = 2;
+ free_number (ret);
+ }
+ free_number (r1);
+ free_number (r2);
+}
+
+
+@ @<Other local variables for |make_envelope|@>=
+mp_number tmp; /* a temporary value */
+
+@ The coordinates of |p| have already been shifted unless |p| is the first
+knot in which case they get shifted at the very end.
+
+@<Add offset |w| to the cubic from |p| to |q|@>=
+number_add (p->right_x, w->x_coord);
+number_add (p->right_y, w->y_coord);
+number_add (q->left_x, w->x_coord);
+number_add (q->left_y, w->y_coord);
+number_add (q->x_coord, w->x_coord);
+number_add (q->y_coord, w->y_coord);
+mp_left_type (q) = mp_explicit;
+mp_right_type (q) = mp_explicit
+
+@ @<Step |w| and move |k| one step closer to |zero_off|@>=
+if (k > zero_off) {
+ w = mp_next_knot (w);
+ decr (k);
+} else {
+ w = mp_prev_knot (w);
+ incr (k);
+}
+
+
+@ The cubic from |q| to the new knot at |(x,y)| becomes a line segment and
+the |mp_right_x| and |mp_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.''
+
+@<Declarations@>=
+static mp_knot mp_insert_knot (MP mp, mp_knot q, mp_number x, mp_number y);
+
+@ @c
+mp_knot mp_insert_knot (MP mp, mp_knot q, mp_number x, mp_number y) {
+ /* returns the inserted knot */
+ mp_knot r; /* the new knot */
+ r = mp_new_knot (mp);
+ mp_next_knot (r) = mp_next_knot (q);
+ mp_next_knot (q) = r;
+ number_clone (r->right_x, q->right_x);
+ number_clone (r->right_y, q->right_y);
+ number_clone (r->x_coord, x);
+ number_clone (r->y_coord, y);
+ number_clone (q->right_x, q->x_coord);
+ number_clone (q->right_y, q->y_coord);
+ number_clone (r->left_x, r->x_coord);
+ number_clone (r->left_y, r->y_coord);
+ mp_left_type (r) = mp_explicit;
+ mp_right_type (r) = mp_explicit;
+ mp_originator (r) = mp_program_code;
+ return r;
+}
+
+
+@ After setting |p:=mp_link(p)|, either |join_type=1| or |q=mp_link(p)|.
+
+@<Set |p=mp_link(p)| and add knots between |p| and |q| as...@>=
+{
+ p = mp_next_knot (p);
+ if ((join_type == 0) || (join_type == 3)) {
+ if (join_type == 0) {
+ @<Insert a new knot |r| between |p| and |q| as required for a mitered join@>
+ } else {
+ @<Make |r| the last of two knots inserted between |p| and |q| to form a
+ squared join@>;
+ }
+ if (r != NULL) {
+ number_clone (r->right_x, r->x_coord);
+ number_clone (r->right_y, r->y_coord);
+ }
+ }
+}
+
+
+@ For very small angles, adding a knot is unnecessary and would cause numerical
+problems, so we just set |r:=NULL| in that case.
+
+@d near_zero_angle_k ((math_data *)mp->math)->near_zero_angle_t
+
+@<Insert a new knot |r| between |p| and |q| as required for a mitered join@>=
+{
+ mp_number det; /* a determinant used for mitered join calculations */
+ mp_number absdet;
+ mp_number r1, r2;
+ new_fraction (r1);
+ new_fraction (r2);
+ new_fraction (det);
+ new_fraction (absdet);
+ take_fraction (r1, dyout, dxin);
+ take_fraction (r2, dxout, dyin);
+ set_number_from_substraction(det, r1, r2);
+ number_clone (absdet, det);
+ number_abs (absdet);
+ if (number_less (absdet, near_zero_angle_k)) {
+ r = NULL; /* sine $<10^{-4}$ */
+ } else {
+ mp_number xtot, ytot, xsub, ysub;
+ new_fraction(xsub);
+ new_fraction(ysub);
+ new_number(xtot);
+ new_number(ytot);
+ set_number_from_substraction (tmp, q->x_coord, p->x_coord);
+ take_fraction (r1, tmp, dyout);
+ set_number_from_substraction (tmp, q->y_coord, p->y_coord);
+ take_fraction (r2, tmp, dxout);
+ set_number_from_substraction (tmp, r1, r2);
+ make_fraction (r1, tmp, det);
+ number_clone (tmp, r1);
+ take_fraction (xsub, tmp, dxin);
+ take_fraction (ysub, tmp, dyin);
+ set_number_from_addition(xtot, p->x_coord, xsub);
+ set_number_from_addition(ytot, p->y_coord, ysub);
+ r = mp_insert_knot (mp, p, xtot, ytot);
+ free_number (xtot);
+ free_number (ytot);
+ free_number (xsub);
+ free_number (ysub);
+ }
+ free_number (r1);
+ free_number (r2);
+ free_number (det);
+ free_number (absdet);
+}
+
+
+@ @<Make |r| the last of two knots inserted between |p| and |q| to form a...@>=
+{
+ mp_number ht_x, ht_y; /* perpendicular to the segment from |p| to |q| */
+ mp_number ht_x_abs, ht_y_abs; /* absolutes */
+ mp_number xtot, ytot, xsub, ysub;
+ new_fraction(xsub);
+ new_fraction(ysub);
+ new_number(xtot);
+ new_number(ytot);
+ new_fraction (ht_x);
+ new_fraction (ht_y);
+ new_fraction (ht_x_abs);
+ new_fraction (ht_y_abs);
+ set_number_from_substraction(ht_x, w->y_coord, w0->y_coord);
+ set_number_from_substraction(ht_y, w0->x_coord, w->x_coord);
+ number_clone (ht_x_abs, ht_x);
+ number_clone (ht_y_abs, ht_y);
+ number_abs (ht_x_abs);
+ number_abs (ht_y_abs);
+ while (number_less(ht_x_abs, fraction_half_t) && number_less(ht_y_abs, fraction_half_t)) {
+ number_double(ht_x);
+ number_double(ht_y);
+ number_clone (ht_x_abs, ht_x);
+ number_clone (ht_y_abs, ht_y);
+ number_abs (ht_x_abs);
+ number_abs (ht_y_abs);
+ }
+ @<Scan the pen polygon between |w0| and |w| and make |max_ht| the range dot
+ product with |(ht_x,ht_y)|@>;
+ {
+ mp_number r1 ,r2;
+ new_fraction (r1);
+ new_fraction (r2);
+ take_fraction (r1, dxin, ht_x);
+ take_fraction (r2, dyin, ht_y);
+ number_add (r1, r2);
+ make_fraction (tmp, max_ht, r1);
+ free_number (r1);
+ free_number (r2);
+ }
+ take_fraction (xsub, tmp, dxin);
+ take_fraction (ysub, tmp, dyin);
+ set_number_from_addition(xtot, p->x_coord, xsub);
+ set_number_from_addition(ytot, p->y_coord, ysub);
+ r = mp_insert_knot (mp, p, xtot, ytot);
+ /* clang: value never read */ assert(r);
+ {
+ mp_number r1 ,r2;
+ new_fraction (r1);
+ new_fraction (r2);
+ take_fraction (r1, dxout, ht_x);
+ take_fraction (r2, dyout, ht_y);
+ number_add (r1, r2);
+ make_fraction (tmp, max_ht, r1);
+ free_number (r1);
+ free_number (r2);
+ }
+ take_fraction (xsub, tmp, dxout);
+ take_fraction (ysub, tmp, dyout);
+ set_number_from_addition(xtot, q->x_coord, xsub);
+ set_number_from_addition(ytot, q->y_coord, ysub);
+ r = mp_insert_knot (mp, r, xtot, ytot);
+ free_number (xsub);
+ free_number (ysub);
+ free_number (xtot);
+ free_number (ytot);
+ free_number (ht_x);
+ free_number (ht_y);
+ free_number (ht_x_abs);
+ free_number (ht_y_abs);
+}
+
+
+@ @<Other local variables for |make_envelope|@>=
+mp_number max_ht; /* maximum height of the pen polygon above the |w0|-|w| line */
+halfword kk; /* keeps track of the pen vertices being scanned */
+mp_knot ww; /* the pen vertex being tested */
+
+@ The dot product of the vector from |w0| to |ww| with |(ht_x,ht_y)| ranges
+from zero to |max_ht|.
+
+@<Scan the pen polygon between |w0| and |w| and make |max_ht| the range...@>=
+set_number_to_zero (max_ht);
+kk = zero_off;
+ww = w;
+while (1) {
+ @<Step |ww| and move |kk| one step closer to |k0|@>;
+ if (kk == k0)
+ break;
+ {
+ mp_number r1, r2;
+ new_fraction (r1);
+ new_fraction (r2);
+ set_number_from_substraction (tmp, ww->x_coord, w0->x_coord);
+ take_fraction (r1, tmp, ht_x);
+ set_number_from_substraction (tmp, ww->y_coord, w0->y_coord);
+ take_fraction (r2, tmp, ht_y);
+ set_number_from_addition (tmp, r1, r2);
+ free_number (r1);
+ free_number (r2);
+ }
+ if (number_greater(tmp, max_ht))
+ number_clone(max_ht, tmp);
+}
+
+
+@ @<Step |ww| and move |kk| one step closer to |k0|@>=
+if (kk > k0) {
+ ww = mp_next_knot (ww);
+ decr (kk);
+} else {
+ ww = mp_prev_knot (ww);
+ incr (kk);
+}
+
+
+@ @<If endpoint, double the path |c|, and set |spec_p1| and |spec_p2|@>=
+if (mp_left_type (c) == mp_endpoint) {
+ mp->spec_p1 = mp_htap_ypoc (mp, c);
+ mp->spec_p2 = mp->path_tail;
+ mp_originator (mp->spec_p1) = mp_program_code;
+ mp_next_knot (mp->spec_p2) = mp_next_knot (mp->spec_p1);
+ mp_next_knot (mp->spec_p1) = c;
+ mp_remove_cubic (mp, mp->spec_p1);
+ c = mp->spec_p1;
+ if (c != mp_next_knot (c)) {
+ mp_originator (mp->spec_p2) = mp_program_code;
+ mp_remove_cubic (mp, mp->spec_p2);
+ } else {
+ @<Make |c| look like a cycle of length one@>;
+ }
+}
+
+@ @<Make |c| look like a cycle of length one@>=
+{
+ mp_left_type (c) = mp_explicit;
+ mp_right_type (c) = mp_explicit;
+ number_clone(c->left_x, c->x_coord);
+ number_clone(c->left_y, c->y_coord);
+ number_clone(c->right_x, c->x_coord);
+ number_clone(c->right_y, c->y_coord);
+}
+
+
+@ 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...@>=
+{
+ set_number_from_substraction(dxin, q->x_coord, q->left_x);
+ set_number_from_substraction(dyin, q->y_coord, q->left_y);
+ if (number_zero(dxin) && number_zero(dyin)) {
+ set_number_from_substraction(dxin, q->x_coord, p->right_x);
+ set_number_from_substraction(dyin, q->y_coord, p->right_y);
+ if (number_zero(dxin) && number_zero(dyin)) {
+ set_number_from_substraction(dxin, q->x_coord, p->x_coord);
+ set_number_from_substraction(dyin, q->y_coord, p->y_coord);
+ if (p != c) { /* the coordinates of |p| have been offset by |w| */
+ number_add(dxin, w->x_coord);
+ number_add(dyin, w->y_coord);
+ }
+ }
+ }
+ pyth_add (tmp, dxin, dyin);
+ if (number_zero(tmp)) {
+ join_type = 2;
+ } else {
+ mp_number r1;
+ new_fraction (r1);
+ make_fraction (r1, dxin, tmp);
+ number_clone(dxin, r1);
+ make_fraction (r1, dyin, tmp);
+ number_clone(dyin, r1);
+ free_number (r1);
+ @<Set the outgoing direction at |q|@>;
+ }
+}
+
+
+@ If |q=c| then the coordinates of |r| and the control points between |q|
+and~|r| have already been offset by |h|.
+
+@<Set the outgoing direction at |q|@>=
+{
+ set_number_from_substraction(dxout, q->right_x, q->x_coord);
+ set_number_from_substraction(dyout, q->right_y, q->y_coord);
+ if (number_zero(dxout) && number_zero(dyout)) {
+ r = mp_next_knot (q);
+ set_number_from_substraction(dxout, r->left_x, q->x_coord);
+ set_number_from_substraction(dyout, r->left_y, q->y_coord);
+ if (number_zero(dxout) && number_zero(dyout)) {
+ set_number_from_substraction(dxout, r->x_coord, q->x_coord);
+ set_number_from_substraction(dyout, r->y_coord, q->y_coord);
+ }
+ }
+ if (q == c) {
+ number_substract(dxout, h->x_coord);
+ number_substract(dyout, h->y_coord);
+ }
+ pyth_add (tmp, dxout, dyout);
+ if (number_zero(tmp)) {
+ /* |mp_confusion (mp, "degenerate spec");| */
+@:this can't happen degerate spec}{\quad degenerate spec@>;
+ /* But apparently, it actually can happen. The test case is this:
+
+ path p;
+ linejoin := mitered;
+ p:= (10,0)..(0,10)..(-10,0)..(0,-10)..cycle;
+ addto currentpicture contour p withpen pensquare;
+
+ The reason for failure here is the addition of |r != q| in revision 1757
+ in ``Advance |p| to node |q|, removing any ``dead'' cubics'', which itself
+ was needed to fix a bug with disappearing knots in a path that was rotated
+ exactly 45 degrees (luatex.org bug 530).
+ */
+ } else {
+ mp_number r1;
+ new_fraction (r1);
+ make_fraction (r1, dxout, tmp);
+ number_clone(dxout, r1);
+ make_fraction (r1, dyout, tmp);
+ number_clone(dyout, r1);
+ free_number (r1);
+ }
+}
+
+
+@* Direction and intersection times.
+A path of length $n$ is defined parametrically by functions $x(t)$ and
+$y(t)$, for |0<=t<=n|; we can regard $t$ as the ``time'' at which the path
+reaches the point $\bigl(x(t),y(t)\bigr)$. In this section of the program
+we shall consider operations that determine special times associated with
+given paths: the first time that a path travels in a given direction, and
+a pair of times at which two paths cross each other.
+
+@ Let's start with the easier task. The function |find_direction_time| is
+given a direction |(x,y)| and a path starting at~|h|. If the path never
+travels in direction |(x,y)|, the direction time will be~|-1|; otherwise
+it will be nonnegative.
+
+Certain anomalous cases can arise: If |(x,y)=(0,0)|, so that the given
+direction is undefined, the direction time will be~0. If $\bigl(x'(t),
+y'(t)\bigr)=(0,0)$, so that the path direction is undefined, it will be
+assumed to match any given direction at time~|t|.
+
+The routine solves this problem in nondegenerate cases by rotating the path
+and the given direction so that |(x,y)=(1,0)|; i.e., the main task will be
+to find when a given path first travels ``due east.''
+
+@c
+static void mp_find_direction_time (MP mp, mp_number *ret, mp_number x_orig, mp_number y_orig, mp_knot h) {
+ mp_number max; /* $\max\bigl(\vert x\vert,\vert y\vert\bigr)$ */
+ mp_knot p, q; /* for list traversal */
+ mp_number n; /* the direction time at knot |p| */
+ mp_number tt; /* the direction time within a cubic */
+ mp_number x, y;
+ mp_number abs_x, abs_y;
+ /* Other local variables for |find_direction_time| */
+ mp_number x1, x2, x3, y1, y2, y3; /* multiples of rotated derivatives */
+ mp_number phi; /* angles of exit and entry at a knot */
+ mp_number t; /* temp storage */
+ mp_number ab_vs_cd;
+ new_number(max);
+ new_number(x1);
+ new_number(x2);
+ new_number(x3);
+ new_number(y1);
+ new_number(y2);
+ new_number(y3);
+ new_fraction(t);
+ new_angle(phi);
+ new_number (ab_vs_cd);
+ set_number_to_zero (*ret); /* just in case */
+ new_number (x);
+ new_number (y);
+ new_number (abs_x);
+ new_number (abs_y);
+ new_number (n);
+ new_fraction (tt);
+ number_clone (x, x_orig);
+ number_clone (y, y_orig);
+ number_clone (abs_x, x_orig);
+ number_clone (abs_y, y_orig);
+ number_abs (abs_x);
+ number_abs (abs_y);
+ /* Normalize the given direction for better accuracy;
+ but |return| with zero result if it's zero */
+ if (number_less(abs_x, abs_y)) {
+ mp_number r1;
+ new_fraction (r1);
+ make_fraction (r1, x, abs_y);
+ number_clone(x, r1);
+ free_number (r1);
+ if (number_positive(y)) {
+ number_clone(y, fraction_one_t);
+ } else {
+ number_clone(y, fraction_one_t);
+ number_negate(y);
+ }
+ } else if (number_zero(x)) {
+ goto FREE;
+ } else {
+ mp_number r1;
+ new_fraction (r1);
+ make_fraction (r1, y, abs_x);
+ number_clone(y, r1);
+ free_number (r1);
+ if (number_positive(x)) {
+ number_clone(x, fraction_one_t);
+ } else {
+ number_clone(x, fraction_one_t);
+ number_negate(x);
+ }
+ }
+
+ p = h;
+ while (1) {
+ if (mp_right_type (p) == mp_endpoint)
+ break;
+ q = mp_next_knot (p);
+ @<Rotate the cubic between |p| and |q|; then
+ |goto found| if the rotated cubic travels due east at some time |tt|;
+ but |break| if an entire cyclic path has been traversed@>;
+ p = q;
+ number_add(n, unity_t);
+ }
+ set_number_to_unity (*ret);
+ number_negate(*ret);
+ goto FREE;
+FOUND:
+ set_number_from_addition (*ret, n, tt);
+ goto FREE;
+FREE:
+ free_number (x);
+ free_number (y);
+ free_number (abs_x);
+ free_number (abs_y);
+ /* Free local variables for |find_direction_time| */
+ free_number (x1);
+ free_number (x2);
+ free_number (x3);
+ free_number (y1);
+ free_number (y2);
+ free_number (y3);
+ free_number (t);
+ free_number (phi);
+ free_number (ab_vs_cd);
+
+ free_number (n);
+ free_number (max);
+ free_number (tt);
+}
+
+
+
+@ 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 scale-d 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|.)
+
+@d we_found_it {
+ number_clone (tt, t);
+ fraction_to_round_scaled (tt);
+ goto FOUND;
+}
+
+@<Rotate the cubic between |p| and |q|; then...@>=
+set_number_to_zero(tt);
+/* Set local variables |x1,x2,x3| and |y1,y2,y3| to multiples of the control
+ points of the rotated derivatives */
+{
+ mp_number absval;
+ new_number (absval);
+ set_number_from_substraction(x1, p->right_x, p->x_coord);
+ set_number_from_substraction(x2, q->left_x, p->right_x);
+ set_number_from_substraction(x3, q->x_coord, q->left_x);
+ set_number_from_substraction(y1, p->right_y, p->y_coord);
+ set_number_from_substraction(y2, q->left_y, p->right_y);
+ set_number_from_substraction(y3, q->y_coord, q->left_y);
+ number_clone(absval, x2);
+ number_abs(absval);
+ number_clone(max, x1);
+ number_abs(max);
+ if (number_greater(absval, max)) {
+ number_clone(max, absval);
+ }
+ number_clone(absval, x3);
+ number_abs(absval);
+ if (number_greater(absval, max)) {
+ number_clone(max, absval);
+ }
+ number_clone(absval, y1);
+ number_abs(absval);
+ if (number_greater(absval, max)) {
+ number_clone(max, absval);
+ }
+ number_clone(absval, y2);
+ number_abs(absval);
+ if (number_greater(absval, max)) {
+ number_clone(max, absval);
+ }
+ number_clone(absval, y3);
+ number_abs(absval);
+ if (number_greater(absval, max)) {
+ number_clone(max, absval);
+ }
+ free_number (absval);
+ if (number_zero(max))
+ goto FOUND;
+ while (number_less (max, fraction_half_t)) {
+ number_double(max);
+ number_double(x1);
+ number_double(x2);
+ number_double(x3);
+ number_double(y1);
+ number_double(y2);
+ number_double(y3);
+ }
+ number_clone(t, x1);
+ {
+ mp_number r1, r2;
+ new_fraction (r1);
+ new_fraction (r2);
+ take_fraction (r1, x1, x);
+ take_fraction (r2, y1, y);
+ set_number_from_addition(x1, r1, r2);
+ take_fraction (r1, y1, x);
+ take_fraction (r2, t, y);
+ set_number_from_substraction(y1, r1, r2);
+ number_clone(t, x2);
+ take_fraction (r1, x2, x);
+ take_fraction (r2, y2, y);
+ set_number_from_addition(x2, r1, r2);
+ take_fraction (r1, y2, x);
+ take_fraction (r2, t, y);
+ set_number_from_substraction(y2, r1, r2);
+ number_clone(t, x3);
+ take_fraction (r1, x3 ,x);
+ take_fraction (r2, y3, y);
+ set_number_from_addition(x3, r1, r2);
+ take_fraction (r1, y3, x);
+ take_fraction (r2, t, y);
+ set_number_from_substraction(y3, r1, r2);
+ free_number (r1);
+ free_number (r2);
+ }
+}
+if (number_zero(y1))
+ if (number_zero(x1) || number_positive(x1))
+ goto FOUND;
+if (number_positive(n)) {
+ /* Exit to |found| if an eastward direction occurs at knot |p| */
+ mp_number theta;
+ mp_number tmp;
+ new_angle (theta);
+ n_arg (theta, x1, y1);
+ new_angle (tmp);
+ set_number_from_substraction (tmp, theta, one_eighty_deg_t);
+
+ if (number_nonnegative(theta) && number_nonpositive(phi) && number_greaterequal(phi, tmp)) {
+ free_number (tmp);
+ free_number (theta);
+ goto FOUND;
+ }
+ set_number_from_addition (tmp, theta, one_eighty_deg_t);
+ if (number_nonpositive(theta) && number_nonnegative(phi) && number_lessequal(phi, tmp)) {
+ free_number (tmp);
+ free_number (theta);
+ goto FOUND;
+ }
+ free_number (tmp);
+ free_number (theta);
+
+ if (p == h)
+ break;
+}
+if (number_nonzero(x3) || number_nonzero(y3)) {
+ n_arg (phi, 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|.*/
+/*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.*/
+ if (number_negative(x1))
+ if (number_negative(x2))
+ if (number_negative(x3))
+ goto DONE;
+{
+ ab_vs_cd (ab_vs_cd, y1, y3, y2, y2);
+ if (number_zero(ab_vs_cd)) {
+ /* Handle the test for eastward directions when $y_1y_3=y_2^2$;
+ either |goto found| or |goto done| */
+{
+ ab_vs_cd (ab_vs_cd, y1, y2, zero_t, zero_t);
+ if (number_negative(ab_vs_cd)) {
+ mp_number tmp, arg2;
+ new_number(tmp);
+ new_number(arg2);
+ set_number_from_substraction (arg2, y1, y2);
+ make_fraction (t, y1, arg2);
+ free_number (arg2);
+ set_number_from_of_the_way(x1, t, x1, x2);
+ set_number_from_of_the_way(x2, t, x2, x3);
+ set_number_from_of_the_way(tmp, t, x1, x2);
+ if (number_zero(tmp) || number_positive(tmp)) {
+ free_number (tmp);
+ we_found_it;
+ }
+ free_number (tmp);
+ } else if (number_zero(y3)) {
+ if (number_zero(y1)) {
+ /* Exit to |found| if the derivative $B(x_1,x_2,x_3;t)$ becomes |>=0| */
+/* 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. */
+{
+ mp_number arg1, arg2, arg3;
+ new_number (arg1);
+ new_number (arg2);
+ new_number (arg3);
+ number_clone(arg1, x1);
+ number_negate(arg1);
+ number_clone(arg2, x2);
+ number_negate(arg2);
+ number_clone(arg3, x3);
+ number_negate(arg3);
+ crossing_point (t, arg1, arg2, arg3);
+ free_number (arg1);
+ free_number (arg2);
+ free_number (arg3);
+ if (number_lessequal (t, fraction_one_t))
+ we_found_it;
+ ab_vs_cd (ab_vs_cd, x1, x3, x2, x2);
+ if (number_nonpositive(ab_vs_cd)) {
+ mp_number arg2;
+ new_number (arg2);
+ set_number_from_substraction (arg2, x1, x2);
+ make_fraction (t, x1, arg2);
+ free_number (arg2);
+ we_found_it;
+ }
+}
+
+
+
+ } else if (number_zero(x3) || number_positive(x3)) {
+ set_number_to_unity(tt);
+ goto FOUND;
+ }
+ }
+ goto DONE;
+}
+
+
+ }
+}
+if (number_zero(y1) || number_negative(y1)) {
+ if (number_negative(y1)) {
+ number_negate(y1);
+ number_negate(y2);
+ number_negate(y3);
+ } else if (number_positive(y2)) {
+ number_negate(y2);
+ number_negate(y3);
+ }
+}
+/* Check the places where $B(y_1,y_2,y_3;t)=0$ to see if
+ $B(x_1,x_2,x_3;t)\ge0$ */
+/* 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.
+
+*/
+crossing_point (t, y1, y2, y3);
+if (number_greater (t, fraction_one_t))
+ goto DONE;
+set_number_from_of_the_way(y2, t, y2, y3);
+set_number_from_of_the_way(x1, t, x1, x2);
+set_number_from_of_the_way(x2, t, x2, x3);
+set_number_from_of_the_way(x1, t, x1, x2);
+if (number_zero(x1) || number_positive(x1))
+ we_found_it;
+if (number_positive(y2))
+ set_number_to_zero(y2);
+number_clone(tt, t);
+{
+ mp_number arg1, arg2, arg3;
+ new_number (arg1);
+ new_number (arg2);
+ new_number (arg3);
+ number_clone(arg2, y2);
+ number_negate(arg2);
+ number_clone(arg3, y3);
+ number_negate(arg3);
+ crossing_point (t, arg1, arg2, arg3);
+ free_number (arg1);
+ free_number (arg2);
+ free_number (arg3);
+}
+if (number_greater (t, fraction_one_t))
+ goto DONE;
+{
+ mp_number tmp;
+ new_number(tmp);
+ set_number_from_of_the_way(x1, t, x1, x2);
+ set_number_from_of_the_way(x2, t, x2, x3);
+ set_number_from_of_the_way(tmp, t, x1, x2);
+ if (number_nonnegative(tmp)) {
+ free_number (tmp);
+ set_number_from_of_the_way (t, t, tt, fraction_one_t);
+ we_found_it;
+ }
+ free_number (tmp);
+}
+DONE:
+
+
+@ The intersection of two cubics can be found by an interesting variant
+of the general bisection scheme described in the introduction to
+|crossing_point|.\
+Given $w(t)=B(w_0,w_1,w_2,w_3;t)$ and $z(t)=B(z_0,z_1,z_2,z_3;t)$,
+we wish to find a pair of times $(t_1,t_2)$ such that $w(t_1)=z(t_2)$,
+if an intersection exists. First we find the smallest rectangle that
+encloses the points $\{w_0,w_1,w_2,w_3\}$ and check that it overlaps
+the smallest rectangle that encloses
+$\{z_0,z_1,z_2,z_3\}$; if not, the cubics certainly don't intersect.
+But if the rectangles do overlap, we bisect the intervals, getting
+new cubics $w'$ and~$w''$, $z'$~and~$z''$; the intersection routine first
+tries for an intersection between $w'$ and~$z'$, then (if unsuccessful)
+between $w'$ and~$z''$, then (if still unsuccessful) between $w''$ and~$z'$,
+finally (if thrice unsuccessful) between $w''$ and~$z''$. After $l$~successful
+levels of bisection we will have determined the intersection times $t_1$
+and~$t_2$ to $l$~bits of accuracy.
+
+\def\submin{_{\rm min}} \def\submax{_{\rm max}}
+As before, it is better to work with the numbers $W_k=2^l(w_k-w_{k-1})$
+and $Z_k=2^l(z_k-z_{k-1})$ rather than the coefficients $w_k$ and $z_k$
+themselves. We also need one other quantity, $\Delta=2^l(w_0-z_0)$,
+to determine when the enclosing rectangles overlap. Here's why:
+The $x$~coordinates of~$w(t)$ are between $u\submin$ and $u\submax$,
+and the $x$~coordinates of~$z(t)$ are between $x\submin$ and $x\submax$,
+if we write $w_k=(u_k,v_k)$ and $z_k=(x_k,y_k)$ and $u\submin=
+\min(u_0,u_1,u_2,u_3)$, etc. These intervals of $x$~coordinates
+overlap if and only if $u\submin\L x\submax$ and
+$x\submin\L u\submax$. Letting
+$$U\submin=\min(0,U_1,U_1+U_2,U_1+U_2+U_3),\;
+ U\submax=\max(0,U_1,U_1+U_2,U_1+U_2+U_3),$$
+we have $2^lu\submin=2^lu_0+U\submin$, etc.; the condition for overlap
+reduces to
+$$X\submin-U\submax\L 2^l(u_0-x_0)\L X\submax-U\submin.$$
+Thus we want to maintain the quantity $2^l(u_0-x_0)$; similarly,
+the quantity $2^l(v_0-y_0)$ accounts for the $y$~coordinates. The
+coordinates of $\Delta=2^l(w_0-z_0)$ must stay bounded as $l$ increases,
+because of the overlap condition; i.e., we know that $X\submin$,
+$X\submax$, and their relatives are bounded, hence $X\submax-
+U\submin$ and $X\submin-U\submax$ are bounded.
+
+@ Incidentally, if the given cubics intersect more than once, the process
+just sketched will not necessarily find the lexicographically smallest pair
+$(t_1,t_2)$. The solution actually obtained will be smallest in ``shuffled
+order''; i.e., if $t_1=(.a_1a_2\ldots a_{16})_2$ and
+$t_2=(.b_1b_2\ldots b_{16})_2$, then we will minimize
+$a_1b_1a_2b_2\ldots a_{16}b_{16}$, not
+$a_1a_2\ldots a_{16}b_1b_2\ldots b_{16}$.
+Shuffled order agrees with lexicographic order if all pairs of solutions
+$(t_1,t_2)$ and $(t_1',t_2')$ have the property that $t_1<t_1'$ iff
+$t_2<t_2'$; but in general, lexicographic order can be quite different,
+and the bisection algorithm would be substantially less efficient if it were
+constrained by lexicographic order.
+
+For example, suppose that an overlap has been found for $l=3$ and
+$(t_1,t_2)= (.101,.011)$ in binary, but that no overlap is produced by
+either of the alternatives $(.1010,.0110)$, $(.1010,.0111)$ at level~4.
+Then there is probably an intersection in one of the subintervals
+$(.1011,.011x)$; but lexicographic order would require us to explore
+$(.1010,.1xxx)$ and $(.1011,.00xx)$ and $(.1011,.010x)$ first. We wouldn't
+want to store all of the subdivision data for the second path, so the
+subdivisions would have to be regenerated many times. Such inefficiencies
+would be associated with every `1' in the binary representation of~$t_1$.
+
+@ The subdivision process introduces rounding errors, hence we need to
+make a more liberal test for overlap. It is not hard to show that the
+computed values of $U_i$ differ from the truth by at most~$l$, on
+level~$l$, hence $U\submin$ and $U\submax$ will be at most $3l$ in error.
+If $\beta$ is an upper bound on the absolute error in the computed
+components of $\Delta=(|delx|,|dely|)$ on level~$l$, we will replace
+the test `$X\submin-U\submax\L|delx|$' by the more liberal test
+`$X\submin-U\submax\L|delx|+|tol|$', where $|tol|=6l+\beta$.
+
+More accuracy is obtained if we try the algorithm first with |tol=0|;
+the more liberal tolerance is used only if an exact approach fails.
+It is convenient to do this double-take by letting `3' in the preceding
+paragraph be a parameter, which is first 0, then 3.
+
+@<Glob...@>=
+unsigned int tol_step; /* either 0 or 3, usually */
+
+@ We shall use an explicit stack to implement the recursive bisection
+method described above. The |bisect_stack| array will contain numerous 5-word
+packets like $(U_1,U_2,U_3,U\submin,U\submax)$, as well as 20-word packets
+comprising the 5-word packets for $U$, $V$, $X$, and~$Y$.
+
+The following macros define the allocation of stack positions to
+the quantities needed for bisection-intersection.
+
+@d stack_1(A) mp->bisect_stack[(A)] /* $U_1$, $V_1$, $X_1$, or $Y_1$ */
+@d stack_2(A) mp->bisect_stack[(A)+1] /* $U_2$, $V_2$, $X_2$, or $Y_2$ */
+@d stack_3(A) mp->bisect_stack[(A)+2] /* $U_3$, $V_3$, $X_3$, or $Y_3$ */
+@d stack_min(A) mp->bisect_stack[(A)+3]
+ /* $U\submin$, $V\submin$, $X\submin$, or $Y\submin$ */
+@d stack_max(A) mp->bisect_stack[(A)+4]
+ /* $U\submax$, $V\submax$, $X\submax$, or $Y\submax$ */
+@d int_packets 20 /* number of words to represent $U_k$, $V_k$, $X_k$, and $Y_k$ */
+@#
+@d u_packet(A) ((A)-5)
+@d v_packet(A) ((A)-10)
+@d x_packet(A) ((A)-15)
+@d y_packet(A) ((A)-20)
+@d l_packets (mp->bisect_ptr-int_packets)
+@d r_packets mp->bisect_ptr
+@d ul_packet u_packet(l_packets) /* base of $U'_k$ variables */
+@d vl_packet v_packet(l_packets) /* base of $V'_k$ variables */
+@d xl_packet x_packet(l_packets) /* base of $X'_k$ variables */
+@d yl_packet y_packet(l_packets) /* base of $Y'_k$ variables */
+@d ur_packet u_packet(r_packets) /* base of $U''_k$ variables */
+@d vr_packet v_packet(r_packets) /* base of $V''_k$ variables */
+@d xr_packet x_packet(r_packets) /* base of $X''_k$ variables */
+@d yr_packet y_packet(r_packets) /* base of $Y''_k$ variables */
+@#
+@d u1l stack_1(ul_packet) /* $U'_1$ */
+@d u2l stack_2(ul_packet) /* $U'_2$ */
+@d u3l stack_3(ul_packet) /* $U'_3$ */
+@d v1l stack_1(vl_packet) /* $V'_1$ */
+@d v2l stack_2(vl_packet) /* $V'_2$ */
+@d v3l stack_3(vl_packet) /* $V'_3$ */
+@d x1l stack_1(xl_packet) /* $X'_1$ */
+@d x2l stack_2(xl_packet) /* $X'_2$ */
+@d x3l stack_3(xl_packet) /* $X'_3$ */
+@d y1l stack_1(yl_packet) /* $Y'_1$ */
+@d y2l stack_2(yl_packet) /* $Y'_2$ */
+@d y3l stack_3(yl_packet) /* $Y'_3$ */
+@d u1r stack_1(ur_packet) /* $U''_1$ */
+@d u2r stack_2(ur_packet) /* $U''_2$ */
+@d u3r stack_3(ur_packet) /* $U''_3$ */
+@d v1r stack_1(vr_packet) /* $V''_1$ */
+@d v2r stack_2(vr_packet) /* $V''_2$ */
+@d v3r stack_3(vr_packet) /* $V''_3$ */
+@d x1r stack_1(xr_packet) /* $X''_1$ */
+@d x2r stack_2(xr_packet) /* $X''_2$ */
+@d x3r stack_3(xr_packet) /* $X''_3$ */
+@d y1r stack_1(yr_packet) /* $Y''_1$ */
+@d y2r stack_2(yr_packet) /* $Y''_2$ */
+@d y3r stack_3(yr_packet) /* $Y''_3$ */
+@#
+@d stack_dx mp->bisect_stack[mp->bisect_ptr] /* stacked value of |delx| */
+@d stack_dy mp->bisect_stack[mp->bisect_ptr+1] /* stacked value of |dely| */
+@d stack_tol mp->bisect_stack[mp->bisect_ptr+2] /* stacked value of |tol| */
+@d stack_uv mp->bisect_stack[mp->bisect_ptr+3] /* stacked value of |uv| */
+@d stack_xy mp->bisect_stack[mp->bisect_ptr+4] /* stacked value of |xy| */
+@d int_increment (int_packets+int_packets+5) /* number of stack words per level */
+
+@<Glob...@>=
+mp_number *bisect_stack;
+integer bisect_ptr;
+
+@ @<Allocate or initialize ...@>=
+mp->bisect_stack = xmalloc ((bistack_size + 1), sizeof (mp_number));
+{
+ int i;
+ for (i=0;i<bistack_size + 1;i++) {
+ new_number (mp->bisect_stack[i]);
+ }
+}
+
+@ @<Dealloc variables@>=
+{
+ int i;
+ for (i=0;i<bistack_size + 1;i++) {
+ free_number (mp->bisect_stack[i]);
+ }
+}
+xfree (mp->bisect_stack);
+
+@ @<Check the ``constant''...@>=
+if (int_packets + (17+2) * int_increment > bistack_size)
+ mp->bad = 19;
+
+@ Computation of the min and max is a tedious but fairly fast sequence of
+instructions; exactly four comparisons are made in each branch.
+
+@d set_min_max(A)
+ debug_number (stack_1(A));
+ debug_number (stack_3(A));
+ debug_number (stack_2(A));
+ debug_number (stack_min(A));
+ debug_number (stack_max(A));
+ if ( number_negative(stack_1((A))) ) {
+ if ( number_nonnegative (stack_3((A))) ) {
+ if ( number_negative (stack_2((A))) )
+ set_number_from_addition (stack_min((A)), stack_1((A)), stack_2((A)));
+ else
+ number_clone (stack_min((A)), stack_1((A)));
+ set_number_from_addition (stack_max((A)), stack_1((A)), stack_2((A)));
+ number_add (stack_max((A)), stack_3((A)));
+ if ( number_negative (stack_max((A))) )
+ set_number_to_zero (stack_max((A)));
+ } else {
+ set_number_from_addition (stack_min((A)), stack_1((A)), stack_2((A)));
+ number_add (stack_min((A)), stack_3((A)));
+ if ( number_greater (stack_min((A)), stack_1((A))))
+ number_clone (stack_min((A)), stack_1((A)));
+ set_number_from_addition (stack_max((A)), stack_1((A)), stack_2((A)));
+ if ( number_negative (stack_max((A))) )
+ set_number_to_zero (stack_max((A)));
+ }
+ } else if ( number_nonpositive (stack_3((A)))) {
+ if ( number_positive (stack_2((A))) )
+ set_number_from_addition (stack_max((A)), stack_1((A)), stack_2((A)));
+ else
+ number_clone (stack_max((A)), stack_1((A)));
+ set_number_from_addition (stack_min((A)), stack_1((A)), stack_2((A)));
+ number_add (stack_min((A)), stack_3((A)));
+ if ( number_positive (stack_min((A))) )
+ set_number_to_zero (stack_min((A)));
+ } else {
+ set_number_from_addition (stack_max((A)), stack_1((A)), stack_2((A)));
+ number_add (stack_max((A)), stack_3((A)));
+ if ( number_less (stack_max((A)), stack_1((A))))
+ number_clone (stack_max((A)), stack_1((A)));
+ set_number_from_addition (stack_min((A)), stack_1((A)), stack_2((A)));
+ if ( number_positive (stack_min((A))) )
+ set_number_to_zero (stack_min((A)));
+ }
+
+@ 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...@>=
+mp_number cur_t;
+mp_number cur_tt; /* controls and results of |cubic_intersection| */
+integer time_to_go; /* this many backtracks before giving up */
+mp_number max_t; /* maximum of $2^{l+1}$ so far achieved */
+
+@ @<Initialize table ...@>=
+new_number (mp->cur_t);
+new_number (mp->cur_tt);
+new_number (mp->max_t);
+
+@ @<Dealloc ...@>=
+free_number (mp->cur_t);
+free_number (mp->cur_tt);
+free_number (mp->max_t);
+
+@ 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,mp_link(p))|
+and |(pp,mp_link(pp))|, respectively.
+
+@d half(A) ((A)/2)
+
+@c
+static void mp_cubic_intersection (MP mp, mp_knot p, mp_knot pp) {
+ mp_knot q, qq; /* |mp_link(p)|, |mp_link(pp)| */
+ mp_number x_two_t; /* increment bit precision */
+ mp_number x_two_t_low_precision; /* check for low precision */
+ mp->time_to_go = max_patience;
+ set_number_from_scaled (mp->max_t, 2);
+ new_number (x_two_t);
+ new_number (x_two_t_low_precision);
+
+ number_clone (x_two_t,two_t);
+ number_double(x_two_t);number_double(x_two_t); /* added 2 bit of precision */
+ set_number_from_double (x_two_t_low_precision,-0.5);
+ number_add (x_two_t_low_precision,x_two_t);
+
+ @<Initialize for intersections at level zero@>;
+CONTINUE:
+ while (1) {
+ /* When we are in arbitrary precision math, low precisions can */
+ /* lead to acces locations beyond the |stack_size|: in this case */
+ /* we say that there is no intersection.*/
+ if ( ((x_packet (mp->xy))+4)>bistack_size ||
+ ((u_packet (mp->uv))+4)>bistack_size ||
+ ((y_packet (mp->xy))+4)>bistack_size ||
+ ((v_packet (mp->uv))+4)>bistack_size ){
+ set_number_from_scaled (mp->cur_t, 1);
+ set_number_from_scaled (mp->cur_tt, 1);
+ goto NOT_FOUND;
+ }
+ /* Also, low precision can lead to wrong result in comparing */
+ /* so we check that the level of bisection stay low, and later */
+ /* we will also check that the bisection level are safe from */
+ /* approximations. */
+ if (number_greater (mp->max_t, x_two_t)){
+ set_number_from_scaled (mp->cur_t, 1);
+ set_number_from_scaled (mp->cur_tt, 1);
+ goto NOT_FOUND;
+ }
+
+ if (number_to_scaled (mp->delx) - mp->tol <=
+ number_to_scaled (stack_max (x_packet (mp->xy))) - number_to_scaled (stack_min (u_packet (mp->uv))))
+ if (number_to_scaled (mp->delx) + mp->tol >=
+ number_to_scaled (stack_min (x_packet (mp->xy))) - number_to_scaled (stack_max (u_packet (mp->uv))))
+ if (number_to_scaled (mp->dely) - mp->tol <=
+ number_to_scaled (stack_max (y_packet (mp->xy))) - number_to_scaled (stack_min (v_packet (mp->uv))))
+ if (number_to_scaled (mp->dely) + mp->tol >=
+ number_to_scaled (stack_min (y_packet (mp->xy))) - number_to_scaled (stack_max (v_packet (mp->uv)))) {
+ if (number_to_scaled (mp->cur_t) >= number_to_scaled (mp->max_t)) {
+ if ( number_equal(mp->max_t, x_two_t) || number_greater(mp->max_t,x_two_t_low_precision)) { /* we've done 17+2 bisections */
+ number_divide_int(mp->cur_t,1<<2);number_divide_int(mp->cur_tt,1<<2); /* restore values due bit precision */
+ set_number_from_scaled (mp->cur_t, ((number_to_scaled (mp->cur_t) + 1)/2));
+ set_number_from_scaled (mp->cur_tt, ((number_to_scaled (mp->cur_tt) + 1)/2));
+ return;
+ }
+ number_double(mp->max_t);
+ number_clone (mp->appr_t, mp->cur_t);
+ number_clone (mp->appr_tt, mp->cur_tt);
+ }
+ @<Subdivide for a new level of intersection@>;
+ goto CONTINUE;
+ }
+ if (mp->time_to_go > 0) {
+ decr (mp->time_to_go);
+ } else {
+ /* we have added 2 bit of precision */
+ number_divide_int(mp->appr_t,1<<2);number_divide_int(mp->appr_tt,1<<2);
+ while (number_less (mp->appr_t, unity_t)) {
+ number_double(mp->appr_t);
+ number_double(mp->appr_tt);
+ }
+ number_clone (mp->cur_t, mp->appr_t);
+ number_clone (mp->cur_tt, mp->appr_tt);
+ return;
+ }
+ NOT_FOUND:
+ /* Advance to the next pair |(cur_t,cur_tt)| */
+ if (odd (number_to_scaled (mp->cur_tt))) {
+ if (odd (number_to_scaled (mp->cur_t))) {
+ /* Descend to the previous level and |goto not_found| */
+ {
+ set_number_from_scaled (mp->cur_t, half (number_to_scaled (mp->cur_t)));
+ set_number_from_scaled (mp->cur_tt, half (number_to_scaled (mp->cur_tt)));
+ if (number_to_scaled (mp->cur_t) == 0)
+ return;
+ mp->bisect_ptr -= int_increment;
+ mp->three_l -= (integer) mp->tol_step;
+ number_clone (mp->delx, stack_dx);
+ number_clone (mp->dely, stack_dy);
+ mp->tol = number_to_scaled (stack_tol);
+ mp->uv = number_to_scaled (stack_uv);
+ mp->xy = number_to_scaled (stack_xy);
+ goto NOT_FOUND;
+ }
+
+ } else {
+ set_number_from_scaled (mp->cur_t, number_to_scaled (mp->cur_t) + 1);
+ number_add (mp->delx, stack_1 (u_packet (mp->uv)));
+ number_add (mp->delx, stack_2 (u_packet (mp->uv)));
+ number_add (mp->delx, stack_3 (u_packet (mp->uv)));
+ number_add (mp->dely, stack_1 (v_packet (mp->uv)));
+ number_add (mp->dely, stack_2 (v_packet (mp->uv)));
+ number_add (mp->dely, stack_3 (v_packet (mp->uv)));
+ mp->uv = mp->uv + int_packets; /* switch from |l_packets| to |r_packets| */
+ set_number_from_scaled (mp->cur_tt, number_to_scaled (mp->cur_tt) - 1);
+ mp->xy = mp->xy - int_packets;
+ number_add (mp->delx, stack_1 (x_packet (mp->xy)));
+ number_add (mp->delx, stack_2 (x_packet (mp->xy)));
+ number_add (mp->delx, stack_3 (x_packet (mp->xy)));
+ number_add (mp->dely, stack_1 (y_packet (mp->xy)));
+ number_add (mp->dely, stack_2 (y_packet (mp->xy)));
+ number_add (mp->dely, stack_3 (y_packet (mp->xy)));
+ }
+ } else {
+ set_number_from_scaled (mp->cur_tt, number_to_scaled (mp->cur_tt) + 1);
+ mp->tol = mp->tol + mp->three_l;
+ number_substract (mp->delx, stack_1 (x_packet (mp->xy)));
+ number_substract (mp->delx, stack_2 (x_packet (mp->xy)));
+ number_substract (mp->delx, stack_3 (x_packet (mp->xy)));
+ number_substract (mp->dely, stack_1 (y_packet (mp->xy)));
+ number_substract (mp->dely, stack_2 (y_packet (mp->xy)));
+ number_substract (mp->dely, stack_3 (y_packet (mp->xy)));
+ mp->xy = mp->xy + int_packets; /* switch from |l_packets| to |r_packets| */
+ }
+ }
+}
+
+
+@ 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...@>=
+mp_number delx;
+mp_number dely; /* the components of $\Delta=2^l(w_0-z_0)$ */
+integer tol; /* bound on the uncertainty in the overlap test */
+integer uv;
+integer xy; /* pointers to the current packets of interest */
+integer three_l; /* |tol_step| times the bisection level */
+mp_number appr_t;
+mp_number appr_tt; /* best approximations known to the answers */
+
+@ @<Initialize table ...@>=
+new_number (mp->delx);
+new_number (mp->dely);
+new_number (mp->appr_t);
+new_number (mp->appr_tt);
+
+@ @<Dealloc...@>=
+free_number (mp->delx);
+free_number (mp->dely);
+free_number (mp->appr_t);
+free_number (mp->appr_tt);
+
+@ 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 = mp_next_knot (p);
+qq = mp_next_knot (pp);
+mp->bisect_ptr = int_packets;
+set_number_from_substraction (u1r, p->right_x, p->x_coord);
+set_number_from_substraction (u2r, q->left_x, p->right_x);
+set_number_from_substraction (u3r, q->x_coord, q->left_x);
+set_min_max (ur_packet);
+set_number_from_substraction (v1r, p->right_y, p->y_coord );
+set_number_from_substraction (v2r, q->left_y, p->right_y);
+set_number_from_substraction (v3r, q->y_coord, q->left_y );
+set_min_max (vr_packet);
+set_number_from_substraction (x1r, pp->right_x, pp->x_coord );
+set_number_from_substraction (x2r, qq->left_x, pp->right_x );
+set_number_from_substraction (x3r, qq->x_coord, qq->left_x );
+set_min_max (xr_packet);
+set_number_from_substraction (y1r, pp->right_y, pp->y_coord );
+set_number_from_substraction (y2r, qq->left_y, pp->right_y);
+set_number_from_substraction (y3r, qq->y_coord, qq->left_y);
+set_min_max (yr_packet);
+set_number_from_substraction (mp->delx, p->x_coord, pp->x_coord );
+set_number_from_substraction (mp->dely, p->y_coord, pp->y_coord );
+mp->tol = 0;
+mp->uv = r_packets;
+mp->xy = r_packets;
+mp->three_l = 0;
+set_number_from_scaled (mp->cur_t, 1);
+set_number_from_scaled (mp->cur_tt, 1)
+
+@
+
+@<Subdivide for a new level of intersection@>=
+number_clone (stack_dx, mp->delx);
+number_clone (stack_dy, mp->dely);
+set_number_from_scaled (stack_tol, mp->tol);
+set_number_from_scaled (stack_uv, mp->uv);
+set_number_from_scaled (stack_xy, mp->xy);
+mp->bisect_ptr = mp->bisect_ptr + int_increment;
+number_double (mp->cur_t);
+number_double (mp->cur_tt);
+number_clone (u1l, stack_1 (u_packet (mp->uv)));
+number_clone (u3r, stack_3 (u_packet (mp->uv)));
+set_number_from_addition (u2l, u1l, stack_2 (u_packet (mp->uv))); number_half (u2l);
+set_number_from_addition (u2r, u3r, stack_2 (u_packet (mp->uv))); number_half (u2r);
+set_number_from_addition (u3l, u2l, u2r); number_half (u3l);
+number_clone (u1r, u3l);
+set_min_max (ul_packet);
+set_min_max (ur_packet);
+number_clone (v1l, stack_1 (v_packet (mp->uv)));
+number_clone (v3r, stack_3 (v_packet (mp->uv)));
+set_number_from_addition (v2l, v1l, stack_2 (v_packet (mp->uv))); number_half(v2l);
+set_number_from_addition (v2r, v3r, stack_2 (v_packet (mp->uv))); number_half(v2r);
+set_number_from_addition (v3l, v2l, v2r); number_half(v3l);
+number_clone (v1r, v3l);
+set_min_max (vl_packet);
+set_min_max (vr_packet);
+number_clone (x1l, stack_1 (x_packet (mp->xy)));
+number_clone (x3r, stack_3 (x_packet (mp->xy)));
+set_number_from_addition (x2l, x1l, stack_2 (x_packet (mp->xy))); number_half(x2l);
+set_number_from_addition (x2r, x3r, stack_2 (x_packet (mp->xy))); number_half(x2r);
+set_number_from_addition (x3l, x2l, x2r); number_half(x3l);
+number_clone (x1r, x3l);
+set_min_max (xl_packet);
+set_min_max (xr_packet);
+number_clone (y1l, stack_1 (y_packet (mp->xy)));
+number_clone (y3r, stack_3 (y_packet (mp->xy)));
+set_number_from_addition (y2l, y1l, stack_2 (y_packet (mp->xy))); number_half (y2l);
+set_number_from_addition (y2r, y3r, stack_2 (y_packet (mp->xy))); number_half (y2r);
+set_number_from_addition (y3l, y2l, y2r); number_half (y3l);
+number_clone (y1r, y3l);
+set_min_max (yl_packet);
+set_min_max (yr_packet);
+mp->uv = l_packets;
+mp->xy = l_packets;
+number_double(mp->delx);
+number_double(mp->dely);
+mp->tol = mp->tol - mp->three_l + (integer) mp->tol_step;
+mp->tol += mp->tol;
+mp->three_l = mp->three_l + (integer) mp->tol_step
+
+@ The |path_intersection| procedure is much simpler.
+It invokes |cubic_intersection| in lexicographic order until finding a
+pair of cubics that intersect. The final intersection times are placed in
+|cur_t| and~|cur_tt|.
+
+@c
+static void mp_path_intersection (MP mp, mp_knot h, mp_knot hh) {
+ mp_knot p, pp; /* link registers that traverse the given paths */
+ mp_number n, nn; /* integer parts of intersection times, minus |unity| */
+ @<Change one-point paths into dead cycles@>;
+ new_number (n);
+ new_number (nn);
+ mp->tol_step = 0;
+ do {
+ set_number_to_unity(n);
+ number_negate (n);
+ p = h;
+ do {
+ if (mp_right_type (p) != mp_endpoint) {
+ set_number_to_unity(nn);
+ number_negate (nn);
+ pp = hh;
+ do {
+ if (mp_right_type (pp) != mp_endpoint) {
+ mp_cubic_intersection (mp, p, pp);
+ if (number_positive (mp->cur_t)) {
+ number_add (mp->cur_t, n);
+ number_add (mp->cur_tt, nn);
+ goto DONE;
+ }
+ }
+ number_add(nn, unity_t);
+ pp = mp_next_knot (pp);
+ } while (pp != hh);
+ }
+ number_add(n, unity_t);
+ p = mp_next_knot (p);
+ } while (p != h);
+ mp->tol_step = mp->tol_step + 3;
+ } while (mp->tol_step <= 3);
+ number_clone (mp->cur_t, unity_t);
+ number_negate (mp->cur_t);
+ number_clone (mp->cur_tt, unity_t);
+ number_negate (mp->cur_tt);
+DONE:
+ free_number (n);
+ free_number (nn);
+}
+
+
+@ @<Change one-point paths...@>=
+if (mp_right_type (h) == mp_endpoint) {
+ number_clone (h->right_x, h->x_coord);
+ number_clone (h->left_x, h->x_coord);
+ number_clone (h->right_y, h->y_coord);
+ number_clone (h->left_y, h->y_coord);
+ mp_right_type (h) = mp_explicit;
+}
+if (mp_right_type (hh) == mp_endpoint) {
+ number_clone (hh->right_x, hh->x_coord);
+ number_clone (hh->left_x, hh->x_coord);
+ number_clone (hh->right_y, hh->y_coord);
+ number_clone (hh->left_y, hh->y_coord);
+ mp_right_type (hh) = mp_explicit;
+}
+
+@* Dynamic linear equations.
+\MP\ users define variables implicitly by stating equations that should be
+satisfied; the computer is supposed to be smart enough to solve those equations.
+And indeed, the computer tries valiantly to do so, by distinguishing five
+different types of numeric values:
+
+\smallskip\hang
+|type(p)=mp_known| is the nice case, when |value(p)| is the |scaled| value
+of the variable whose address is~|p|.
+
+\smallskip\hang
+|type(p)=mp_dependent| means that |value(p)| is not present, but |dep_list(p)|
+points to a {\sl dependency list\/} that expresses the value of variable~|p|
+as a |scaled| number plus a sum of independent variables with |fraction|
+coefficients.
+
+\smallskip\hang
+|type(p)=mp_independent| means that |indep_value(p)=s|, where |s>0| is a ``serial
+number'' reflecting the time this variable was first used in an equation;
+and there is an extra field |indep_scale(p)=m|, with |0<=m<64|, each dependent
+variable that refers to this one is actually referring to the future value of
+this variable times~$2^m$. (Usually |m=0|, but higher degrees of
+scaling are sometimes needed to keep the coefficients in dependency lists
+from getting too large. The value of~|m| will always be even.)
+
+\smallskip\hang
+|type(p)=mp_numeric_type| means that variable |p| hasn't appeared in an
+equation before, but it has been explicitly declared to be numeric.
+
+\smallskip\hang
+|type(p)=undefined| means that variable |p| hasn't appeared before.
+
+\smallskip\noindent
+We have actually discussed these five types in the reverse order of their
+history during a computation: Once |known|, a variable never again
+becomes |dependent|; once |dependent|, it almost never again becomes
+|mp_independent|; once |mp_independent|, it never again becomes |mp_numeric_type|;
+and once |mp_numeric_type|, it never again becomes |undefined| (except
+of course when the user specifically decides to scrap the old value
+and start again). A backward step may, however, take place: Sometimes
+a |dependent| variable becomes |mp_independent| again, when one of the
+independent variables it depends on is reverting to |undefined|.
+
+@d indep_scale(A) ((mp_value_node)(A))->data.indep.scale
+@d set_indep_scale(A,B) ((mp_value_node)(A))->data.indep.scale=(B)
+@d indep_value(A) ((mp_value_node)(A))->data.indep.serial
+@d set_indep_value(A,B) ((mp_value_node)(A))->data.indep.serial=(B)
+
+
+@c
+void mp_new_indep(MP mp, mp_node p) { /* create a new independent variable */
+ if ( mp->serial_no>=max_integer ) {
+ mp_fatal_error(mp, "variable instance identifiers exhausted");
+ }
+ mp_type(p)=mp_independent;
+ mp->serial_no=mp->serial_no+1;
+ set_indep_scale(p,0);
+ set_indep_value(p,mp->serial_no);
+}
+
+@ @<Declarations@>=
+void mp_new_indep(MP mp, mp_node p);
+
+
+@ @<Glob...@>=
+integer serial_no; /* the most recent serial number */
+
+@ 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 |dep_value(q)=
+@t$\alpha_1$@>| (which is a |fraction|); |dep_info(q)| points to the location
+of $\alpha_1$; and |mp_link(p)| points to the dependency list
+$\alpha_2v_2+\cdots+\alpha_kv_k+\beta$. On the other hand if |k=0|,
+then |dep_value(q)=@t$\beta$@>| (which is |scaled|) and |dep_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
+|mp_link(dep_head)=dep_head| and |prev_dep(dep_head)=dep_head|;
+otherwise |mp_link(dep_head)| points to the first dependent variable, say~|p|,
+and |prev_dep(p)=dep_head|. We have |type(p)=mp_dependent|, and |dep_list(p)|
+points to its dependency list. If the final link of that dependency list
+occurs in location~|q|, then |mp_link(q)| points to the next dependent
+variable (say~|r|); and we have |prev_dep(r)=q|, etc.
+
+Dependency nodes sometimes mutate into value nodes and vice versa, so their
+structures have to match.
+
+@d dep_value(A) ((mp_value_node)(A))->data.n
+@d set_dep_value(A,B) do_set_dep_value(mp,(A),(B))
+@d dep_info(A) get_dep_info(mp, (A))
+@d set_dep_info(A,B) do {
+ mp_value_node d = (mp_value_node)(B);
+ FUNCTION_TRACE4("set_dep_info(%p,%p) on %d\n",(A),d,__LINE__);
+ ((mp_value_node)(A))->parent_ = (mp_node)d;
+} while (0)
+@d dep_list(A) ((mp_value_node)(A))->attr_head_ /* half of the |value| field in a |dependent| variable */
+@d set_dep_list(A,B) do {
+ mp_value_node d = (mp_value_node)(B);
+ FUNCTION_TRACE4("set_dep_list(%p,%p) on %d\n",(A),d,__LINE__);
+ dep_list((A)) = (mp_node)d;
+} while (0)
+@d prev_dep(A) ((mp_value_node)(A))->subscr_head_ /* the other half; makes a doubly linked list */
+@d set_prev_dep(A,B) do {
+ mp_value_node d = (mp_value_node)(B);
+ FUNCTION_TRACE4("set_prev_dep(%p,%p) on %d\n",(A),d,__LINE__);
+ prev_dep((A)) = (mp_node)d;
+} while (0)
+
+@c
+static mp_node get_dep_info (MP mp, mp_value_node p) {
+ mp_node d;
+ d = p->parent_; /* half of the |value| field in a |dependent| variable */
+ FUNCTION_TRACE3 ("%p = dep_info(%p)\n", d, p);
+ return d;
+}
+static void do_set_dep_value (MP mp, mp_value_node p, mp_number q) {
+ number_clone (p->data.n, q); /* half of the |value| field in a |dependent| variable */
+ FUNCTION_TRACE3("set_dep_value(%p,%d)\n", p, q);
+ p->attr_head_ = NULL;
+ p->subscr_head_ = NULL;
+}
+
+@ @<Declarations...@>=
+static mp_node get_dep_info (MP mp, mp_value_node p);
+
+@
+
+@c
+static mp_value_node mp_get_dep_node (MP mp) {
+ mp_value_node p = (mp_value_node) mp_get_value_node (mp);
+ mp_type (p) = mp_dep_node_type;
+ return p;
+}
+static void mp_free_dep_node (MP mp, mp_value_node p) {
+ mp_free_value_node (mp, (mp_node) p);
+}
+
+
+@ @<Declarations...@>=
+static void mp_free_dep_node (MP mp, mp_value_node p);
+
+@ @<Initialize table entries@>=
+mp->serial_no = 0;
+mp->dep_head = mp_get_dep_node (mp);
+set_mp_link (mp->dep_head, (mp_node) mp->dep_head);
+set_prev_dep (mp->dep_head, (mp_node) mp->dep_head);
+set_dep_info (mp->dep_head, NULL);
+set_dep_list (mp->dep_head, NULL);
+
+@ @<Free table entries@>=
+mp_free_dep_node (mp, mp->dep_head);
+
+@ Actually the description above contains a little white lie. There's
+another kind of variable called |mp_proto_dependent|, which is
+just like a |dependent| one except that the $\alpha$ coefficients
+in its dependency list are |scaled| instead of being fractions.
+Proto-dependency lists are mixed with dependency lists in the
+nodes reachable from |dep_head|.
+
+@ Here is a procedure that prints a dependency list in symbolic form.
+The second parameter should be either |dependent| or |mp_proto_dependent|,
+to indicate the scaling of the coefficients.
+
+@<Declarations@>=
+static void mp_print_dependency (MP mp, mp_value_node p, quarterword t);
+
+@ @c
+void mp_print_dependency (MP mp, mp_value_node p, quarterword t) {
+ mp_number v; /* a coefficient */
+ mp_value_node pp; /* for list manipulation */
+ mp_node q;
+ pp = p;
+ new_number (v);
+ while (true) {
+ number_clone (v, dep_value (p));
+ number_abs (v);
+ q = dep_info (p);
+ if (q == NULL) { /* the constant term */
+ if (number_nonzero(v) || (p == pp)) {
+ if (number_positive(dep_value (p)))
+ if (p != pp)
+ mp_print_char (mp, xord ('+'));
+ print_number (dep_value (p));
+ }
+ return;
+ }
+ /* Print the coefficient, unless it's $\pm1.0$ */
+ if (number_negative(dep_value (p)))
+ mp_print_char (mp, xord ('-'));
+ else if (p != pp)
+ mp_print_char (mp, xord ('+'));
+ if (t == mp_dependent) {
+ fraction_to_round_scaled (v);
+ }
+ if (!number_equal (v, unity_t))
+ print_number (v);
+
+ if (mp_type (q) != mp_independent)
+ mp_confusion (mp, "dep");
+ mp_print_variable_name (mp, q);
+ set_number_from_scaled (v, indep_scale(q));
+ while (number_positive (v)) {
+ mp_print (mp, "*4");
+ number_add_scaled (v, -2);
+ }
+ p = (mp_value_node) mp_link (p);
+ }
+}
+
+
+
+@ The maximum absolute value of a coefficient in a given dependency list
+is returned by the following simple function.
+
+@c
+static void mp_max_coef (MP mp, mp_number *x, mp_value_node p) {
+ mp_number (absv);
+ new_number (absv);
+ set_number_to_zero (*x);
+ while (dep_info (p) != NULL) {
+ number_clone (absv, dep_value (p));
+ number_abs (absv);
+ if (number_greater (absv, *x)) {
+ number_clone (*x, absv);
+ }
+ p = (mp_value_node) mp_link (p);
+ }
+ free_number (absv);
+}
+
+
+@ 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 independent_needing_fix 0
+
+@<Glob...@>=
+boolean fix_needed; /* does at least one |independent| variable need scaling? */
+boolean watch_coefs; /* should we scale coefficients that exceed |coef_bound|? */
+mp_value_node dep_final; /* location of the constant term and final link */
+
+@ @<Set init...@>=
+mp->fix_needed = false;
+mp->watch_coefs = true;
+
+@ The |p_plus_fq| procedure has a fourth parameter, |t|, that should be
+set to |mp_proto_dependent| if |p| is a proto-dependency list. In this
+case |f| will be |scaled|, not a |fraction|. Similarly, the fifth parameter~|tt|
+should be |mp_proto_dependent| if |q| is a proto-dependency list.
+
+List |q| is unchanged by the operation; but list |p| is totally destroyed.
+
+The final link of the dependency list or proto-dependency list returned
+by |p_plus_fq| is the same as the original final link of~|p|. Indeed, the
+constant term of the result will be located in the same |mem| location
+as the original constant term of~|p|.
+
+Coefficients of the result are assumed to be zero if they are less than
+a certain threshold. This compensates for inevitable rounding errors,
+and tends to make more variables `|known|'. The threshold is approximately
+$10^{-5}$ in the case of normal dependency lists, $10^{-4}$ for
+proto-dependencies.
+
+@d fraction_threshold_k ((math_data *)mp->math)->fraction_threshold_t
+@d half_fraction_threshold_k ((math_data *)mp->math)->half_fraction_threshold_t
+@d scaled_threshold_k ((math_data *)mp->math)->scaled_threshold_t
+@d half_scaled_threshold_k ((math_data *)mp->math)->half_scaled_threshold_t
+
+@<Declarations@>=
+static mp_value_node mp_p_plus_fq (MP mp, mp_value_node p, mp_number f,
+ mp_value_node q, mp_variable_type t,
+ mp_variable_type tt);
+
+@ @c
+static mp_value_node mp_p_plus_fq (MP mp, mp_value_node p, mp_number f,
+ mp_value_node q, mp_variable_type t,
+ mp_variable_type tt) {
+ mp_node pp, qq; /* |dep_info(p)| and |dep_info(q)|, respectively */
+ mp_value_node r, s; /* for list manipulation */
+ mp_number threshold, half_threshold; /* defines a neighborhood of zero */
+ mp_number v, vv; /* temporary registers */
+ new_number (v);
+ new_number (vv);
+ new_number (threshold);
+ new_number (half_threshold);
+ if (t == mp_dependent) {
+ number_clone (threshold, fraction_threshold_k);
+ number_clone (half_threshold, half_fraction_threshold_k);
+ } else {
+ number_clone (threshold, scaled_threshold_k);
+ number_clone (half_threshold, half_scaled_threshold_k);
+ }
+ r = (mp_value_node) mp->temp_head;
+ pp = dep_info (p);
+ qq = dep_info (q);
+ while (1) {
+ if (pp == qq) {
+ if (pp == NULL) {
+ break;
+ } else {
+ /* Contribute a term from |p|, plus |f| times the
+ corresponding term from |q| */
+ mp_number r1;
+ mp_number absv;
+ new_fraction (r1);
+ new_number (absv);
+ if (tt == mp_dependent) {
+ take_fraction (r1, f, dep_value (q));
+ } else {
+ take_scaled (r1, f, dep_value (q));
+ }
+ set_number_from_addition (v, dep_value (p), r1);
+ free_number (r1);
+ set_dep_value (p, v);
+ s = p;
+ p = (mp_value_node) mp_link (p);
+ number_clone (absv, v);
+ number_abs(absv);
+ if (number_less (absv, threshold)) {
+ mp_free_dep_node (mp, s);
+ } else {
+ if (number_greaterequal (absv, coef_bound_k) && mp->watch_coefs) {
+ mp_type (qq) = independent_needing_fix;
+ /* If we set this , then we can drop |(mp_type(pp) == independent_needing_fix && mp->fix_needed)| later */
+ /* |set_number_from_scaled (value_number (qq), indep_value(qq));| */
+ mp->fix_needed = true;
+ }
+ set_mp_link (r, (mp_node) s);
+ r = s;
+ }
+ free_number (absv);
+ pp = dep_info (p);
+ q = (mp_value_node) mp_link (q);
+ qq = dep_info (q);
+ }
+
+ } else {
+ if (pp == NULL)
+ set_number_to_neg_inf(v);
+ else if (mp_type(pp) == mp_independent || (mp_type(pp) == independent_needing_fix && mp->fix_needed))
+ set_number_from_scaled(v, indep_value(pp));
+ else
+ number_clone (v, value_number (pp));
+ if (qq == NULL)
+ set_number_to_neg_inf(vv);
+ else if (mp_type(qq) == mp_independent || (mp_type(qq) == independent_needing_fix && mp->fix_needed))
+ set_number_from_scaled(vv, indep_value(qq));
+ else
+ number_clone (vv, value_number (qq));
+ if (number_less (v, vv)) {
+ /* Contribute a term from |q|, multiplied by~|f| */
+ mp_number absv;
+ new_number (absv);
+ {
+ mp_number r1;
+ mp_number arg1, arg2;
+ new_fraction (r1);
+ new_number (arg1);
+ new_number (arg2);
+ number_clone (arg1, f);
+ number_clone (arg2, dep_value (q));
+ if (tt == mp_dependent) {
+ take_fraction (r1, arg1, arg2);
+ } else {
+ take_scaled (r1, arg1, arg2);
+ }
+ number_clone (v, r1);
+ free_number (r1);
+ free_number (arg1);
+ free_number (arg2);
+ }
+ number_clone (absv, v);
+ number_abs(absv);
+ if (number_greater (absv, half_threshold)) {
+ s = mp_get_dep_node (mp);
+ set_dep_info (s, qq);
+ set_dep_value (s, v);
+ if (number_greaterequal(absv, coef_bound_k) && mp->watch_coefs) {
+ /* clang: dereference of a null pointer ('qq') */ assert(qq);
+ mp_type (qq) = independent_needing_fix;
+ mp->fix_needed = true;
+ }
+ set_mp_link (r, (mp_node) s);
+ r = s;
+ }
+ q = (mp_value_node) mp_link (q);
+ qq = dep_info (q);
+ free_number (absv);
+
+ } else {
+ set_mp_link (r, (mp_node) p);
+ r = p;
+ p = (mp_value_node) mp_link (p);
+ pp = dep_info (p);
+ }
+ }
+ }
+ {
+ mp_number r1;
+ mp_number arg1, arg2;
+ new_fraction (r1);
+ new_number (arg1);
+ new_number (arg2);
+ number_clone (arg1, dep_value (q));
+ number_clone (arg2, f);
+ if (t == mp_dependent) {
+ take_fraction (r1, arg1, arg2);
+ } else {
+ take_scaled (r1, arg1, arg2);
+ }
+ slow_add (arg1, dep_value (p), r1);
+ set_dep_value (p, arg1);
+ free_number (r1);
+ free_number (arg1);
+ free_number (arg2);
+ }
+ set_mp_link (r, (mp_node) p);
+ mp->dep_final = p;
+ free_number (threshold);
+ free_number (half_threshold);
+ free_number (v);
+ free_number (vv);
+ return (mp_value_node) mp_link (mp->temp_head);
+}
+
+
+@ It is convenient to have another subroutine for the special case
+of |p_plus_fq| when |f=1.0|. In this routine lists |p| and |q| are
+both of the same type~|t| (either |dependent| or |mp_proto_dependent|).
+
+@c
+static mp_value_node mp_p_plus_q (MP mp, mp_value_node p, mp_value_node q,
+ mp_variable_type t) {
+ mp_node pp, qq; /* |dep_info(p)| and |dep_info(q)|, respectively */
+ mp_value_node s; /* for list manipulation */
+ mp_value_node r; /* for list manipulation */
+ mp_number threshold; /* defines a neighborhood of zero */
+ mp_number v, vv; /* temporary register */
+ new_number (v);
+ new_number (vv);
+ new_number (threshold);
+ if (t == mp_dependent)
+ number_clone (threshold, fraction_threshold_k);
+ else
+ number_clone (threshold, scaled_threshold_k);
+ r = (mp_value_node) mp->temp_head;
+ pp = dep_info (p);
+ qq = dep_info (q);
+ while (1) {
+ if (pp == qq) {
+ if (pp == NULL) {
+ break;
+ } else {
+ /* Contribute a term from |p|, plus the corresponding term from |q| */
+ mp_number test;
+ new_number (test);
+ set_number_from_addition (v, dep_value (p), dep_value (q));
+ set_dep_value (p, v);
+ s = p;
+ p = (mp_value_node) mp_link (p);
+ pp = dep_info (p);
+ number_clone (test, v);
+ number_abs(test);
+ if (number_less (test, threshold)) {
+ mp_free_dep_node (mp, s);
+ } else {
+ if (number_greaterequal(test, coef_bound_k) && mp->watch_coefs) {
+ mp_type (qq) = independent_needing_fix;
+ /* If we set this , then we can drop |(mp_type(pp) == independent_needing_fix && mp->fix_needed)| later */
+ /* |set_number_from_scaled (value_number (qq), indep_value(qq));| */
+ mp->fix_needed = true;
+ }
+ set_mp_link (r, (mp_node) s);
+ r = s;
+ }
+ free_number (test);
+ q = (mp_value_node) mp_link (q);
+ qq = dep_info (q);
+ }
+
+ } else {
+ if (pp == NULL)
+ set_number_to_zero (v);
+ else if (mp_type(pp) == mp_independent || (mp_type(pp) == independent_needing_fix && mp->fix_needed))
+ set_number_from_scaled (v, indep_value(pp));
+ else
+ number_clone (v, value_number (pp));
+ if (qq == NULL)
+ set_number_to_zero (vv);
+ else if (mp_type(qq) == mp_independent || (mp_type(qq) == independent_needing_fix && mp->fix_needed))
+ set_number_from_scaled (vv, indep_value(qq));
+ else
+ number_clone (vv, value_number (qq));
+ if (number_less (v, vv)) {
+ s = mp_get_dep_node (mp);
+ set_dep_info (s, qq);
+ set_dep_value (s, dep_value (q));
+ q = (mp_value_node) mp_link (q);
+ qq = dep_info (q);
+ set_mp_link (r, (mp_node) s);
+ r = s;
+ } else {
+ set_mp_link (r, (mp_node) p);
+ r = p;
+ p = (mp_value_node) mp_link (p);
+ pp = dep_info (p);
+ }
+ }
+ }
+ {
+ mp_number r1;
+ new_number (r1);
+ slow_add (r1, dep_value (p), dep_value (q));
+ set_dep_value (p, r1);
+ free_number (r1);
+ }
+ set_mp_link (r, (mp_node) p);
+ mp->dep_final = p;
+ free_number (v);
+ free_number (vv);
+ free_number (threshold);
+ return (mp_value_node) mp_link (mp->temp_head);
+}
+
+@ A somewhat simpler routine will multiply a dependency list
+by a given constant~|v|. The constant is either a |fraction| less than
+|fraction_one|, or it is |scaled|. In the latter case we might be forced to
+convert a dependency list to a proto-dependency list.
+Parameters |t0| and |t1| are the list types before and after;
+they should agree unless |t0=mp_dependent| and |t1=mp_proto_dependent|
+and |v_is_scaled=true|.
+
+@c
+static mp_value_node mp_p_times_v (MP mp, mp_value_node p, mp_number v,
+ quarterword t0, quarterword t1,
+ boolean v_is_scaled) {
+ mp_value_node r, s; /* for list manipulation */
+ mp_number w; /* tentative coefficient */
+ mp_number threshold;
+ boolean scaling_down;
+ new_number (threshold);
+ new_number (w);
+ if (t0 != t1)
+ scaling_down = true;
+ else
+ scaling_down = (!v_is_scaled);
+ if (t1 == mp_dependent)
+ number_clone (threshold, half_fraction_threshold_k);
+ else
+ number_clone (threshold, half_scaled_threshold_k);
+ r = (mp_value_node) mp->temp_head;
+ while (dep_info (p) != NULL) {
+ mp_number test;
+ new_number (test);
+ if (scaling_down) {
+ take_fraction (w, v, dep_value (p));
+ } else {
+ take_scaled (w, v, dep_value (p));
+ }
+ number_clone (test, w);
+ number_abs(test);
+ if (number_lessequal (test, threshold)) {
+ s = (mp_value_node) mp_link (p);
+ mp_free_dep_node (mp, p);
+ p = s;
+ } else {
+ if (number_greaterequal(test, coef_bound_k)) {
+ mp->fix_needed = true;
+ mp_type (dep_info (p)) = independent_needing_fix;
+ }
+ set_mp_link (r, (mp_node) p);
+ r = p;
+ set_dep_value (p, w);
+ p = (mp_value_node) mp_link (p);
+ }
+ free_number (test);
+ }
+ set_mp_link (r, (mp_node) p);
+ {
+ mp_number r1;
+ new_number (r1);
+ if (v_is_scaled) {
+ take_scaled (r1, dep_value (p), v);
+ } else {
+ take_fraction (r1, dep_value (p), v);
+ }
+ set_dep_value (p, r1);
+ free_number (r1);
+ }
+ free_number (w);
+ free_number (threshold);
+ return (mp_value_node) mp_link (mp->temp_head);
+}
+
+
+@ Similarly, we sometimes need to divide a dependency list
+by a given |scaled| constant.
+
+@<Declarations@>=
+static mp_value_node mp_p_over_v (MP mp, mp_value_node p, mp_number v, quarterword
+ t0, quarterword t1);
+
+@
+@d p_over_v_threshold_k ((math_data *)mp->math)->p_over_v_threshold_t
+
+@c
+mp_value_node mp_p_over_v (MP mp, mp_value_node p, mp_number v_orig, quarterword
+ t0, quarterword t1) {
+ mp_value_node r, s; /* for list manipulation */
+ mp_number w; /* tentative coefficient */
+ mp_number threshold;
+ mp_number v;
+ boolean scaling_down;
+ new_number (v);
+ new_number (w);
+ new_number (threshold);
+ number_clone (v, v_orig);
+ if (t0 != t1)
+ scaling_down = true;
+ else
+ scaling_down = false;
+ if (t1 == mp_dependent)
+ number_clone (threshold, half_fraction_threshold_k);
+ else
+ number_clone (threshold, half_scaled_threshold_k);
+ r = (mp_value_node) mp->temp_head;
+ while (dep_info (p) != NULL) {
+ if (scaling_down) {
+ mp_number x, absv;
+ new_number (x);
+ new_number (absv);
+ number_clone (absv, v);
+ number_abs (absv);
+ if (number_less (absv, p_over_v_threshold_k)) {
+ number_clone (x, v);
+ convert_scaled_to_fraction (x);
+ make_scaled (w, dep_value (p), x);
+ } else {
+ number_clone (x, dep_value (p));
+ fraction_to_round_scaled (x);
+ make_scaled (w, x, v);
+ }
+ free_number (x);
+ free_number (absv);
+ } else {
+ make_scaled (w, dep_value (p), v);
+ }
+ {
+ mp_number test;
+ new_number (test);
+ number_clone (test, w);
+ number_abs(test);
+ if (number_lessequal (test, threshold)) {
+ s = (mp_value_node) mp_link (p);
+ mp_free_dep_node (mp, p);
+ p = s;
+ } else {
+ if (number_greaterequal (test, coef_bound_k)) {
+ mp->fix_needed = true;
+ mp_type (dep_info (p)) = independent_needing_fix;
+ }
+ set_mp_link (r, (mp_node) p);
+ r = p;
+ set_dep_value (p, w);
+ p = (mp_value_node) mp_link (p);
+ }
+ free_number (test);
+ }
+ }
+ set_mp_link (r, (mp_node) p);
+ {
+ mp_number ret;
+ new_number (ret);
+ make_scaled (ret, dep_value (p), v);
+ set_dep_value (p, ret);
+ free_number (ret);
+ }
+ free_number (v);
+ free_number (w);
+ free_number (threshold);
+ return (mp_value_node) mp_link (mp->temp_head);
+}
+
+
+@ Here's another utility routine for dependency lists. When an independent
+variable becomes dependent, we want to remove it from all existing
+dependencies. The |p_with_x_becoming_q| function computes the
+dependency list of~|p| after variable~|x| has been replaced by~|q|.
+
+This procedure has basically the same calling conventions as |p_plus_fq|:
+List~|q| is unchanged; list~|p| is destroyed; the constant node and the
+final link are inherited from~|p|; and the fourth parameter tells whether
+or not |p| is |mp_proto_dependent|. However, the global variable |dep_final|
+is not altered if |x| does not occur in list~|p|.
+
+@c
+static mp_value_node mp_p_with_x_becoming_q (MP mp, mp_value_node p,
+ mp_node x, mp_node q,
+ quarterword t) {
+ mp_value_node r, s; /* for list manipulation */
+ integer sx; /* serial number of |x| */
+ s = p;
+ r = (mp_value_node) mp->temp_head;
+ sx = indep_value (x);
+ while (dep_info (s) != NULL && indep_value (dep_info (s)) > sx) {
+ r = s;
+ s = (mp_value_node) mp_link (s);
+ }
+ if (dep_info (s) == NULL || dep_info (s) != x) {
+ return p;
+ } else {
+ mp_value_node ret;
+ mp_number v1;
+ new_number (v1);
+ set_mp_link (mp->temp_head, (mp_node) p);
+ set_mp_link (r, mp_link (s));
+ number_clone (v1, dep_value (s));
+ mp_free_dep_node (mp, s);
+ ret = mp_p_plus_fq (mp, (mp_value_node) mp_link (mp->temp_head), v1,
+ (mp_value_node) q, t, mp_dependent);
+ free_number (v1);
+ return ret;
+ }
+}
+
+
+@ 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.
+
+@<Declarations@>=
+static void mp_val_too_big (MP mp, mp_number x);
+
+@ @c
+static void mp_val_too_big (MP mp, mp_number x) {
+ if (number_positive (internal_value (mp_warning_check))) {
+ char msg[256];
+ const char *hlp[] = {
+ "The equation I just processed has given some variable a",
+ "value outside of the safetyp range. Continue and I'll try",
+ "to cope with that big value; but it might be dangerous.",
+ "(Set warningcheck:=0 to suppress this message.)",
+ NULL };
+ mp_snprintf (msg, 256, "Value is too large (%s)", number_tostring(x));
+ mp_error (mp, msg, hlp, true);
+ }
+}
+
+@ 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).
+
+@<Declarations@>=
+static void mp_make_known (MP mp, mp_value_node p, mp_value_node q);
+
+@ @c
+void mp_make_known (MP mp, mp_value_node p, mp_value_node q) {
+ mp_variable_type t; /* the previous type */
+ mp_number absp;
+ new_number (absp);
+ set_prev_dep (mp_link (q), prev_dep (p));
+ set_mp_link (prev_dep (p), mp_link (q));
+ t = mp_type (p);
+ mp_type (p) = mp_known;
+ set_value_number (p, dep_value (q));
+ mp_free_dep_node (mp, q);
+ number_clone (absp, value_number (p));
+ number_abs (absp);
+ if (number_greaterequal (absp, warning_limit_t))
+ mp_val_too_big (mp, value_number (p));
+ if ((number_positive(internal_value (mp_tracing_equations)))
+ && mp_interesting (mp, (mp_node) p)) {
+ mp_begin_diagnostic (mp);
+ mp_print_nl (mp, "#### ");
+ mp_print_variable_name (mp, (mp_node) p);
+ mp_print_char (mp, xord ('='));
+ print_number (value_number (p));
+ mp_end_diagnostic (mp, false);
+ }
+ if (cur_exp_node () == (mp_node) p && mp->cur_exp.type == t) {
+ mp->cur_exp.type = mp_known;
+ set_cur_exp_value_number (value_number (p));
+ mp_free_value_node (mp, (mp_node) p);
+ }
+ free_number (absp);
+}
+
+
+@ 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.
+
+@<Declarations@>=
+static void mp_fix_dependencies (MP mp);
+
+@
+@d independent_being_fixed 1 /* this variable already appears in |s| */
+@c
+static void mp_fix_dependencies (MP mp) {
+ mp_value_node p, q, r, s, t; /* list manipulation registers */
+ mp_node x; /* an independent variable */
+ r = (mp_value_node) mp_link (mp->dep_head);
+ s = NULL;
+ while (r != mp->dep_head) {
+ t = r;
+ /* Run through the dependency list for variable |t|, fixing
+ all nodes, and ending with final link~|q| */
+ while (1) {
+ if (t==r) {
+ q = (mp_value_node) dep_list(t);
+ } else {
+ q = (mp_value_node) mp_link (r);
+ }
+ x = dep_info (q);
+ if (x == NULL)
+ break;
+ if (mp_type (x) <= independent_being_fixed) {
+ if (mp_type (x) < independent_being_fixed) {
+ p = mp_get_dep_node (mp);
+ set_mp_link (p, (mp_node) s);
+ s = p;
+ set_dep_info (s, x);
+ mp_type (x) = independent_being_fixed;
+ }
+ set_dep_value (q, dep_value (q));
+ number_divide_int (dep_value (q), 4);
+ if (number_zero(dep_value (q))) {
+ set_mp_link (r, mp_link (q));
+ mp_free_dep_node (mp, q);
+ q = r;
+ }
+ }
+ r = q;
+ }
+
+ r = (mp_value_node) mp_link (q);
+ if (q == (mp_value_node) dep_list (t))
+ mp_make_known (mp, t, q);
+ }
+ while (s != NULL) {
+ p = (mp_value_node) mp_link (s);
+ x = dep_info (s);
+ mp_free_dep_node (mp, s);
+ s = p;
+ mp_type (x) = mp_independent;
+ set_indep_scale (x, indep_scale (x) + 2);
+ }
+ mp->fix_needed = false;
+}
+
+
+@ The |new_dep| routine installs a dependency list~|p| based on the value node~|q|,
+linking it into the list of all known dependencies. It replaces |q| with the new
+dependency node. We assume that |dep_final| points to the final node of list~|p|.
+
+@c
+static void mp_new_dep (MP mp, mp_node q, mp_variable_type newtype,
+ mp_value_node p) {
+ mp_node r; /* what used to be the first dependency */
+ FUNCTION_TRACE4 ("mp_new_dep(%p,%d,%p)\n", q, newtype, p);
+ mp_type (q) = newtype;
+ set_dep_list (q, p);
+ set_prev_dep (q, (mp_node) mp->dep_head);
+ r = mp_link (mp->dep_head);
+ set_mp_link (mp->dep_final, r);
+ set_prev_dep (r, (mp_node) mp->dep_final);
+ set_mp_link (mp->dep_head, q);
+}
+
+
+@ Here is one of the ways a dependency list gets started.
+The |const_dependency| routine produces a list that has nothing but
+a constant term.
+
+@c
+static mp_value_node mp_const_dependency (MP mp, mp_number v) {
+ mp->dep_final = mp_get_dep_node (mp);
+ set_dep_value (mp->dep_final, v);
+ set_dep_info (mp->dep_final, NULL);
+ FUNCTION_TRACE3 ("%p = mp_const_dependency(%d)\n", mp->dep_final, number_to_scaled (v));
+ return mp->dep_final;
+}
+
+
+@ And here's a more interesting way to start a dependency list from scratch:
+The parameter to |single_dependency| is the location of an
+independent variable~|x|, and the result is the simple dependency list
+`|x+0|'.
+
+In the unlikely event that the given independent variable has been doubled so
+often that we can't refer to it with a nonzero coefficient,
+|single_dependency| returns the simple list `0'. This case can be
+recognized by testing that the returned list pointer is equal to
+|dep_final|.
+
+@d two_to_the(A) (1<<(unsigned)(A))
+
+@c
+static mp_value_node mp_single_dependency (MP mp, mp_node p) {
+ mp_value_node q, rr; /* the new dependency list */
+ integer m; /* the number of doublings */
+ m = indep_scale (p);
+ if (m > 28) {
+ q = mp_const_dependency (mp, zero_t);
+ } else {
+ q = mp_get_dep_node (mp);
+ set_dep_value (q, zero_t);
+ set_number_from_scaled (dep_value (q), (integer) two_to_the (28 - m));
+ set_dep_info (q, p);
+ rr = mp_const_dependency (mp, zero_t);
+ set_mp_link (q, (mp_node) rr);
+ }
+ FUNCTION_TRACE3 ("%p = mp_single_dependency(%p)\n", q, p);
+ return q;
+}
+
+
+@ We sometimes need to make an exact copy of a dependency list.
+
+@c
+static mp_value_node mp_copy_dep_list (MP mp, mp_value_node p) {
+ mp_value_node q; /* the new dependency list */
+ FUNCTION_TRACE2 ("mp_copy_dep_list(%p)\n", p);
+ q = mp_get_dep_node (mp);
+ mp->dep_final = q;
+ while (1) {
+ set_dep_info (mp->dep_final, dep_info (p));
+ set_dep_value (mp->dep_final, dep_value (p));
+ if (dep_info (mp->dep_final) == NULL)
+ break;
+ set_mp_link (mp->dep_final, (mp_node) mp_get_dep_node (mp));
+ mp->dep_final = (mp_value_node) mp_link (mp->dep_final);
+ p = (mp_value_node) mp_link (p);
+ }
+ return q;
+}
+
+
+@ But how do variables normally become known? Ah, now we get to the heart of the
+equation-solving mechanism. The |linear_eq| procedure is given a |dependent|
+or |mp_proto_dependent| list,~|p|, in which at least one independent variable
+appears. It equates this list to zero, by choosing an independent variable
+with the largest coefficient and making it dependent on the others. The
+newly dependent variable is eliminated from all current dependencies,
+thereby possibly making other dependent variables known.
+
+The given list |p| is, of course, totally destroyed by all this processing.
+
+@c
+static mp_value_node find_node_with_largest_coefficient(MP mp, mp_value_node p, mp_number *v);
+static void display_new_dependency (MP mp, mp_value_node p, mp_node x, integer n);
+static void change_to_known (MP mp, mp_value_node p, mp_node x, mp_value_node final_node, integer n);
+static mp_value_node divide_p_by_minusv_removing_q (MP mp, mp_value_node p, mp_value_node q,
+ mp_value_node *final_node, mp_number v, quarterword t);
+static mp_value_node divide_p_by_2_n (MP mp, mp_value_node p, integer n);
+static void mp_linear_eq (MP mp, mp_value_node p, quarterword t) {
+ mp_value_node r; /* for link manipulation */
+ mp_node x; /* the variable that loses its independence */
+ integer n; /* the number of times |x| had been halved */
+ mp_number v; /* the coefficient of |x| in list |p| */
+ mp_value_node prev_r; /* lags one step behind |r| */
+ mp_value_node final_node; /* the constant term of the new dependency list */
+ mp_value_node qq;
+ new_number (v);
+ FUNCTION_TRACE3 ("mp_linear_eq(%p,%d)\n", p, t);
+ qq = find_node_with_largest_coefficient(mp, p, &v);
+ x = dep_info (qq);
+ n = indep_scale (x);
+ p = divide_p_by_minusv_removing_q(mp, p, qq, &final_node, v, t);
+ if (number_positive (internal_value (mp_tracing_equations))) {
+ display_new_dependency(mp,p,(mp_node)x,n);
+ }
+ prev_r = (mp_value_node) mp->dep_head;
+ r = (mp_value_node) mp_link (mp->dep_head);
+ while (r != mp->dep_head) {
+ mp_value_node s = (mp_value_node) dep_list (r);
+ mp_value_node q = mp_p_with_x_becoming_q (mp, s, x, (mp_node) p, mp_type (r));
+ if (dep_info (q) == NULL) {
+ mp_make_known (mp, r, q);
+ } else {
+ set_dep_list (r, q);
+ do {
+ q = (mp_value_node) mp_link (q);
+ } while (dep_info (q) != NULL);
+ prev_r = q;
+ }
+ r = (mp_value_node) mp_link (prev_r);
+ }
+ if (n > 0) {
+ p = divide_p_by_2_n(mp, p, n);
+ }
+ change_to_known(mp,p,(mp_node)x,final_node,n);
+ if (mp->fix_needed)
+ mp_fix_dependencies (mp);
+ free_number (v);
+}
+
+
+@
+@c
+static mp_value_node find_node_with_largest_coefficient(MP mp, mp_value_node p, mp_number *v) {
+ mp_number vabs; /* its absolute value of v*/
+ mp_number rabs; /* the absolute value of |dep_value(r)| */
+ mp_value_node q = p;
+ mp_value_node r = (mp_value_node) mp_link (p);
+ new_number (vabs);
+ new_number (rabs);
+ number_clone (*v, dep_value (q));
+ while (dep_info (r) != NULL) {
+ number_clone (vabs, *v);
+ number_abs (vabs);
+ number_clone (rabs, dep_value (r));
+ number_abs (rabs);
+ if (number_greater (rabs, vabs)) {
+ q = r;
+ number_clone (*v, dep_value (r));
+ }
+ r = (mp_value_node) mp_link (r);
+ }
+ free_number (vabs);
+ free_number (rabs);
+ return q;
+}
+
+
+@ Here we want to change the coefficients from |scaled| to |fraction|,
+except in the constant term. In the common case of a trivial equation
+like `\.{x=3.14}', we will have |v=-fraction_one|, |q=p|, and |t=mp_dependent|.
+
+@c
+static mp_value_node divide_p_by_minusv_removing_q (MP mp, mp_value_node p, mp_value_node q,
+ mp_value_node *final_node, mp_number v, quarterword t) {
+ mp_value_node r; /* for link manipulation */
+ mp_value_node s;
+ s = (mp_value_node) mp->temp_head;
+ set_mp_link (s, (mp_node) p);
+ r = p;
+ do {
+ if (r == q) {
+ set_mp_link (s, mp_link (r));
+ mp_free_dep_node (mp, r);
+ } else {
+ mp_number w; /* a tentative coefficient */
+ mp_number absw;
+ new_number (w);
+ new_number (absw);
+ make_fraction (w, dep_value (r), v);
+ number_clone (absw, w);
+ number_abs (absw);
+ if (number_lessequal (absw, half_fraction_threshold_k)) {
+ set_mp_link (s, mp_link (r));
+ mp_free_dep_node (mp, r);
+ } else {
+ number_negate (w);
+ set_dep_value (r, w);
+ s = r;
+ }
+ free_number(w);
+ free_number (absw);
+ }
+ r = (mp_value_node) mp_link (s);
+ } while (dep_info (r) != NULL);
+
+ if (t == mp_proto_dependent) {
+ mp_number ret;
+ new_number (ret);
+ make_scaled (ret, dep_value (r), v);
+ number_negate (ret);
+ set_dep_value (r, ret);
+ free_number (ret);
+ } else if (number_to_scaled (v) != -number_to_scaled (fraction_one_t)) {
+ mp_number ret;
+ new_fraction (ret);
+ make_fraction (ret, dep_value (r), v);
+ number_negate (ret);
+ set_dep_value (r, ret);
+ free_number (ret);
+ }
+ *final_node = r;
+ return (mp_value_node) mp_link (mp->temp_head);
+}
+
+
+@
+@c
+static void display_new_dependency (MP mp, mp_value_node p, mp_node x, integer n) {
+ if (mp_interesting (mp, x)) {
+ int w0;
+ mp_begin_diagnostic (mp);
+ mp_print_nl (mp, "## ");
+ mp_print_variable_name (mp, x);
+ w0 = n;
+ while (w0 > 0) {
+ mp_print (mp, "*4");
+ w0 = w0 - 2;
+ }
+ mp_print_char (mp, xord ('='));
+ mp_print_dependency (mp, p, mp_dependent);
+ mp_end_diagnostic (mp, false);
+ }
+}
+
+@ The |n > 0| test is repeated here because it is of vital importance to the
+function's functioning.
+
+@c
+static mp_value_node divide_p_by_2_n (MP mp, mp_value_node p, integer n) {
+ mp_value_node pp = NULL;
+ if (n > 0) {
+ /* Divide list |p| by $2^n$ */
+ mp_value_node r;
+ mp_value_node s;
+ mp_number absw;
+ mp_number w; /* a tentative coefficient */
+ new_number (w);
+ new_number (absw);
+ s = (mp_value_node) mp->temp_head;
+ set_mp_link (mp->temp_head, (mp_node) p);
+ r = p;
+ do {
+ if (n > 30) {
+ set_number_to_zero (w);
+ } else {
+ number_clone (w, dep_value (r));
+ number_divide_int (w, two_to_the (n));
+ }
+ number_clone (absw, w);
+ number_abs (absw);
+ if (number_lessequal(absw, half_fraction_threshold_k) && (dep_info (r) != NULL)) {
+ set_mp_link (s, mp_link (r));
+ mp_free_dep_node (mp, r);
+ } else {
+ set_dep_value (r, w);
+ s = r;
+ }
+ r = (mp_value_node) mp_link (s);
+ } while (dep_info (s) != NULL);
+ pp = (mp_value_node) mp_link (mp->temp_head);
+ free_number (absw);
+ free_number (w);
+ }
+ return pp;
+}
+
+@
+@c
+static void change_to_known (MP mp, mp_value_node p, mp_node x, mp_value_node final_node, integer n) {
+ if (dep_info (p) == NULL) {
+ mp_number absx;
+ new_number (absx);
+ mp_type (x) = mp_known;
+ set_value_number (x, dep_value (p));
+ number_clone (absx, value_number (x));
+ number_abs (absx);
+ if (number_greaterequal (absx, warning_limit_t))
+ mp_val_too_big (mp, value_number (x));
+ free_number (absx);
+ mp_free_dep_node (mp, p);
+ if (cur_exp_node () == x && mp->cur_exp.type == mp_independent) {
+ set_cur_exp_value_number (value_number (x));
+ mp->cur_exp.type = mp_known;
+ mp_free_value_node (mp, x);
+ }
+ } else {
+ mp->dep_final = final_node;
+ mp_new_dep (mp, x, mp_dependent, p);
+ if (cur_exp_node () == x && mp->cur_exp.type == mp_independent) {
+ mp->cur_exp.type = mp_dependent;
+ }
+ }
+}
+
+@* Dynamic nonlinear equations.
+Variables of numeric type are maintained by the general scheme of
+independent, dependent, and known values that we have just studied;
+and the components of pair and transform variables are handled in the
+same way. But \MP\ also has five other types of values: \&{boolean},
+\&{string}, \&{pen}, \&{path}, and \&{picture}; what about them?
+
+Equations are allowed between nonlinear quantities, but only in a
+simple form. Two variables that haven't yet been assigned values are
+either equal to each other, or they're not.
+
+Before a boolean variable has received a value, its type is |mp_unknown_boolean|;
+similarly, there are variables whose type is |mp_unknown_string|, |mp_unknown_pen|,
+|mp_unknown_path|, and |mp_unknown_picture|. In such cases the value is either
+|NULL| (which means that no other variables are equivalent to this one), or
+it points to another variable of the same undefined type. The pointers in the
+latter case form a cycle of nodes, which we shall call a ``ring.''
+Rings of undefined variables may include capsules, which arise as
+intermediate results within expressions or as \&{expr} parameters to macros.
+
+When one member of a ring receives a value, the same value is given to
+all the other members. In the case of paths and pictures, this implies
+making separate copies of a potentially large data structure; users should
+restrain their enthusiasm for such generality, unless they have lots and
+lots of memory space.
+
+@ The following procedure is called when a capsule node is being
+added to a ring (e.g., when an unknown variable is mentioned in an expression).
+
+@c
+static mp_node mp_new_ring_entry (MP mp, mp_node p) {
+ mp_node q; /* the new capsule node */
+ q = mp_get_value_node (mp);
+ mp_name_type (q) = mp_capsule;
+ mp_type (q) = mp_type (p);
+ if (value_node (p) == NULL)
+ set_value_node (q, p);
+ else
+ set_value_node (q, value_node (p));
+ set_value_node (p, q);
+ return q;
+}
+
+
+@ Conversely, we might delete a capsule or a variable before it becomes known.
+The following procedure simply detaches a quantity from its ring,
+without recycling the storage.
+
+@<Declarations@>=
+static void mp_ring_delete (MP mp, mp_node p);
+
+@ @c
+void mp_ring_delete (MP mp, mp_node p) {
+ mp_node q;
+ (void) mp;
+ q = value_node (p);
+ if (q != NULL && q != p) {
+ while (value_node (q) != p)
+ q = value_node (q);
+ set_value_node (q, value_node (p));
+ }
+}
+
+
+@ Eventually there might be an equation that assigns values to all of the
+variables in a ring. The |nonlinear_eq| subroutine does the necessary
+propagation of values.
+
+If the parameter |flush_p| is |true|, node |p| itself needn't receive a
+value, it will soon be recycled.
+
+@c
+static void mp_nonlinear_eq (MP mp, mp_value v, mp_node p, boolean flush_p) {
+ mp_variable_type t; /* the type of ring |p| */
+ mp_node q, r; /* link manipulation registers */
+ t = (mp_type (p) - unknown_tag);
+ q = value_node (p);
+ if (flush_p)
+ mp_type (p) = mp_vacuous;
+ else
+ p = q;
+ do {
+ r = value_node (q);
+ mp_type (q) = t;
+ switch (t) {
+ case mp_boolean_type:
+ set_value_number (q, v.data.n);
+ break;
+ case mp_string_type:
+ set_value_str (q, v.data.str);
+ add_str_ref (v.data.str);
+ break;
+ case mp_pen_type:
+ set_value_knot (q, copy_pen (v.data.p));
+ break;
+ case mp_path_type:
+ set_value_knot (q, mp_copy_path (mp, v.data.p));
+ break;
+ case mp_picture_type:
+ set_value_node (q, v.data.node);
+ add_edge_ref (v.data.node);
+ break;
+ default:
+ break;
+ } /* there ain't no more cases */
+ q = r;
+ } while (q != p);
+}
+
+
+@ If two members of rings are equated, and if they have the same type,
+the |ring_merge| procedure is called on to make them equivalent.
+
+@c
+static void mp_ring_merge (MP mp, mp_node p, mp_node q) {
+ mp_node r; /* traverses one list */
+ r = value_node (p);
+ while (r != p) {
+ if (r == q) {
+ exclaim_redundant_equation(mp);
+ return;
+ };
+ r = value_node (r);
+ }
+ r = value_node (p);
+ set_value_node (p, value_node (q));
+ set_value_node (q, r);
+}
+
+
+@ @c
+static void exclaim_redundant_equation (MP mp) {
+ const char *hlp[] = {
+ "I already knew that this equation was true.",
+ "But perhaps no harm has been done; let's continue.",
+ NULL };
+ mp_back_error (mp, "Redundant equation", hlp, true);
+ mp_get_x_next (mp);
+}
+
+@ @<Declarations@>=
+static void exclaim_redundant_equation (MP mp);
+
+@* 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 or operand 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.
+
+@d cur_cmd() (unsigned)(mp->cur_mod_->type)
+@d set_cur_cmd(A) mp->cur_mod_->type=(A)
+@d cur_mod_int() number_to_int (mp->cur_mod_->data.n) /* operand of current command */
+@d cur_mod() number_to_scaled (mp->cur_mod_->data.n) /* operand of current command */
+@d cur_mod_number() mp->cur_mod_->data.n /* operand of current command */
+@d set_cur_mod(A) set_number_from_scaled (mp->cur_mod_->data.n, (A))
+@d set_cur_mod_number(A) number_clone (mp->cur_mod_->data.n, (A))
+@d cur_mod_node() mp->cur_mod_->data.node
+@d set_cur_mod_node(A) mp->cur_mod_->data.node=(A)
+@d cur_mod_str() mp->cur_mod_->data.str
+@d set_cur_mod_str(A) mp->cur_mod_->data.str=(A)
+@d cur_sym() mp->cur_mod_->data.sym
+@d set_cur_sym(A) mp->cur_mod_->data.sym=(A)
+@d cur_sym_mod() mp->cur_mod_->name_type
+@d set_cur_sym_mod(A) mp->cur_mod_->name_type=(A)
+
+@<Glob...@>=
+mp_node cur_mod_; /* current command, symbol, and its operands */
+
+@ @<Initialize table...@>=
+mp->cur_mod_ = mp_get_symbolic_node(mp);
+
+@ @<Free table...@>=
+mp_free_symbolic_node(mp, mp->cur_mod_);
+
+@ 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.
+
+@<Declarations@>=
+static void mp_print_cmd_mod (MP mp, integer c, integer m);
+
+@ @c
+void mp_print_cmd_mod (MP mp, integer c, integer m) {
+ switch (c) {
+ @<Cases of |print_cmd_mod| for symbolic printing of primitives@>
+ default:
+ mp_print (mp, "[unknown command code!]");
+ break;
+ }
+}
+
+
+@ Here is a procedure that displays a given command in braces, in the
+user's transcript file.
+
+@d show_cur_cmd_mod mp_show_cmd_mod(mp, cur_cmd(),cur_mod())
+
+@c
+static void mp_show_cmd_mod (MP mp, integer c, integer m) {
+ mp_begin_diagnostic (mp);
+ mp_print_nl (mp, "{");
+ mp_print_cmd_mod (mp, c, m);
+ mp_print_char (mp, xord ('}'));
+ mp_end_diagnostic (mp, false);
+}
+
+
+@* Input stacks and states.
+The state of \MP's input mechanism appears in the input stack, whose
+entries are records with five fields, called |index|, |start|, |loc|,
+|limit|, and |name|. The top element of this stack is maintained in a
+global variable for which no subscripting needs to be done; the other
+elements of the stack appear in an array. Hence the stack is declared thus:
+
+@<Types...@>=
+typedef struct {
+ char *long_name_field;
+ halfword start_field, loc_field, limit_field;
+ mp_node nstart_field, nloc_field;
+ mp_string name_field;
+ quarterword index_field;
+} in_state_record;
+
+@ @<Glob...@>=
+in_state_record *input_stack;
+integer input_ptr; /* first unused location of |input_stack| */
+integer max_in_stack; /* largest value of |input_ptr| when pushing */
+in_state_record cur_input; /* the ``top'' input state */
+int stack_size; /* maximum number of simultaneous input sources */
+
+@ @<Allocate or initialize ...@>=
+mp->stack_size = 16;
+mp->input_stack = xmalloc ((mp->stack_size + 1), sizeof (in_state_record));
+
+@ @<Dealloc variables@>=
+xfree (mp->input_stack);
+
+@ We've already defined the special variable |loc==cur_input.loc_field|
+in our discussion of basic input-output routines. The other components of
+|cur_input| are defined in the same way:
+
+@d iindex mp->cur_input.index_field /* reference for buffer information */
+@d start mp->cur_input.start_field /* starting position in |buffer| */
+@d limit mp->cur_input.limit_field /* end of current line in |buffer| */
+@d name mp->cur_input.name_field /* name of the current file */
+
+@ Let's look more closely now at the five control variables
+(|index|,~|start|,~|loc|,~|limit|,~|name|),
+assuming that \MP\ is reading a line of characters that have been input
+from some file or from the user's terminal. There is an array called
+|buffer| that acts as a stack of all lines of characters that are
+currently being read from files, including all lines on subsidiary
+levels of the input stack that are not yet completed. \MP\ will return to
+the other lines when it is finished with the present input file.
+
+(Incidentally, on a machine with byte-oriented addressing, it would be
+appropriate to combine |buffer| with the |str_pool| array,
+letting the buffer entries grow downward from the top of the string pool
+and checking that these two tables don't bump into each other.)
+
+The line we are currently working on begins in position |start| of the
+buffer; the next character we are about to read is |buffer[loc]|; and
+|limit| is the location of the last character present. We always have
+|loc<=limit|. For convenience, |buffer[limit]| has been set to |"%"|, so
+that the end of a line is easily sensed.
+
+The |name| variable is a string number that designates the name of
+the current file, if we are reading an ordinary text file. Special codes
+|is_term..max_spec_src| indicate other sources of input text.
+
+@d is_term (mp_string)0 /* |name| value when reading from the terminal for normal input */
+@d is_read (mp_string)1 /* |name| value when executing a \&{readstring} or \&{readfrom} */
+@d is_scantok (mp_string)2 /* |name| value when reading text generated by \&{scantokens} */
+@d max_spec_src is_scantok
+
+@ Additional information about the current line is available via the
+|index| variable, which counts how many lines of characters are present
+in the buffer below the current level. We have |index=0| when reading
+from the terminal and prompting the user for each line; then if the user types,
+e.g., `\.{input figs}', we will have |index=1| while reading
+the file \.{figs.mp}. However, it does not follow that |index| is the
+same as the input stack pointer, since many of the levels on the input
+stack may come from token lists and some |index| values may correspond
+to \.{MPX} files that are not currently on the stack.
+
+The global variable |in_open| is equal to the highest |index| value counting
+\.{MPX} files but excluding token-list input levels. Thus, the number of
+partially read lines in the buffer is |in_open+1| and we have |in_open>=index|
+when we are not reading a token list.
+
+If we are not currently reading from the terminal,
+we are reading from the file variable |input_file[index]|. We use
+the notation |terminal_input| as a convenient abbreviation for |name=is_term|,
+and |cur_file| as an abbreviation for |input_file[index]|.
+
+When \MP\ is not reading from the terminal, the global variable |line| contains
+the line number in the current file, for use in error messages. More precisely,
+|line| is a macro for |line_stack[index]| and the |line_stack| array gives
+the line number for each file in the |input_file| array.
+
+When an \.{MPX} file is opened the file name is stored in the |mpx_name|
+array so that the name doesn't get lost when the file is temporarily removed
+from the input stack.
+Thus when |input_file[k]| is an \.{MPX} file, its name is |mpx_name[k]|
+and it contains translated \TeX\ pictures for |input_file[k-1]|.
+Since this is not an \.{MPX} file, we have
+$$ \hbox{|mpx_name[k-1]<=absent|}. $$
+This |name| field is set to |finished| when |input_file[k]| is completely
+read.
+
+If more information about the input state is needed, it can be
+included in small arrays like those shown here. For example,
+the current page or segment number in the input file might be put
+into a variable |page|, that is really a macro for the current entry
+in `\ignorespaces|page_stack:array[0..max_in_open] of integer|\unskip'
+by analogy with |line_stack|.
+@^system dependencies@>
+
+@d terminal_input (name==is_term) /* are we reading from the terminal? */
+@d cur_file mp->input_file[iindex] /* the current |void *| variable */
+@d line mp->line_stack[iindex] /* current line number in the current source file */
+@d in_ext mp->inext_stack[iindex] /* a string used to construct \.{MPX} file names */
+@d in_name mp->iname_stack[iindex] /* a string used to construct \.{MPX} file names */
+@d in_area mp->iarea_stack[iindex] /* another string for naming \.{MPX} files */
+@d absent (mp_string)1 /* |name_field| value for unused |mpx_in_stack| entries */
+@d mpx_reading (mp->mpx_name[iindex]>absent)
+ /* when reading a file, is it an \.{MPX} file? */
+@d mpx_finished 0
+ /* |name_field| value when the corresponding \.{MPX} file is finished */
+
+@<Glob...@>=
+integer in_open; /* the number of lines in the buffer, less one */
+integer in_open_max; /* highest value of |in_open| ever seen */
+unsigned int open_parens; /* the number of open text files */
+void **input_file;
+integer *line_stack; /* the line number for each file */
+char **inext_stack; /* used for naming \.{MPX} files */
+char **iname_stack; /* used for naming \.{MPX} files */
+char **iarea_stack; /* used for naming \.{MPX} files */
+mp_string *mpx_name;
+
+@ @<Declarations@>=
+static void mp_reallocate_input_stack (MP mp, int newsize);
+
+@ @c
+static void mp_reallocate_input_stack (MP mp, int newsize) {
+ int k;
+ int n = newsize +1;
+ XREALLOC (mp->input_file, n, void *);
+ XREALLOC (mp->line_stack, n, integer);
+ XREALLOC (mp->inext_stack, n, char *);
+ XREALLOC (mp->iname_stack, n, char *);
+ XREALLOC (mp->iarea_stack, n, char *);
+ XREALLOC (mp->mpx_name, n, mp_string);
+ for (k = mp->max_in_open; k <= n; k++) {
+ mp->input_file[k] = NULL;
+ mp->line_stack[k] = 0;
+ mp->inext_stack[k] = NULL;
+ mp->iname_stack[k] = NULL;
+ mp->iarea_stack[k] = NULL;
+ mp->mpx_name[k] = NULL;
+ }
+ mp->max_in_open = newsize;
+}
+
+
+@ This has to be more than |file_bottom|, so:
+@<Allocate or ...@>=
+mp_reallocate_input_stack (mp, file_bottom+4);
+
+@ @<Dealloc variables@>=
+{
+ int l;
+ for (l = 0; l <= mp->max_in_open; l++) {
+ xfree (mp->inext_stack[l]);
+ xfree (mp->iname_stack[l]);
+ xfree (mp->iarea_stack[l]);
+ }
+}
+xfree (mp->input_file);
+xfree (mp->line_stack);
+xfree (mp->inext_stack);
+xfree (mp->iname_stack);
+xfree (mp->iarea_stack);
+xfree (mp->mpx_name);
+
+
+@ However, all this discussion about input state really applies only to the
+case that we are inputting from a file. There is another important case,
+namely when we are currently getting input from a token list. In this case
+|iindex>max_in_open|, and the conventions about the other state variables
+are different:
+
+\yskip\hang|nloc| is a pointer to the current node in the token list, i.e.,
+the node that will be read next. If |nloc=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 |iindex| 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 nloc mp->cur_input.nloc_field /* location of next node node */
+@d nstart mp->cur_input.nstart_field /* location of next node node */
+
+@d token_type iindex /* type of current token list */
+@d token_state (iindex<=macro) /* are we scanning a token list? */
+@d file_state (iindex>macro) /* are we scanning a file line? */
+@d param_start limit /* base of macro parameters in |param_stack| */
+@d forever_text 0 /* |token_type| code for loop texts */
+@d loop_text 1 /* |token_type| code for loop texts */
+@d parameter 2 /* |token_type| code for parameter texts */
+@d backed_up 3 /* |token_type| code for texts to be reread */
+@d inserted 4 /* |token_type| code for inserted texts */
+@d macro 5 /* |token_type| code for macro replacement texts */
+@d file_bottom 6 /* lowest file code */
+
+@ 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, and is dynamically reallocated
+when needed.
+
+@<Glob...@>=
+mp_node *param_stack; /* token list pointers for parameters */
+integer param_ptr; /* first unused entry in |param_stack| */
+integer max_param_stack; /* largest value of |param_ptr| */
+
+@ @<Allocate or initialize ...@>=
+mp->param_stack = xmalloc ((mp->param_size + 1), sizeof (mp_node));
+
+@ @c
+static void mp_check_param_size (MP mp, int k) {
+ while (k >= mp->param_size) {
+ XREALLOC (mp->param_stack, (k + k / 4), mp_node);
+ mp->param_size = k + k / 4;
+ }
+}
+
+
+@ @<Dealloc variables@>=
+xfree (mp->param_stack);
+
+@ Notice that the |line| isn't valid when |token_state| is true because it
+depends on |iindex|. If we really need to know the line number for the
+topmost file in the iindex 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@>
+
+@<Declarations@>=
+static integer mp_true_line (MP mp);
+
+@ @c
+integer mp_true_line (MP mp) {
+ int k; /* an index into the input stack */
+ if (file_state && (name > max_spec_src)) {
+ return line;
+ } else {
+ k = mp->input_ptr;
+ while ((k > 0) &&
+ ((mp->input_stack[(k - 1)].index_field < file_bottom) ||
+ (mp->input_stack[(k - 1)].name_field <= max_spec_src))) {
+ decr (k);
+ }
+ return (k > 0 ? mp->line_stack[(k - 1) + file_bottom] : 0);
+ }
+}
+
+
+@ Thus, the ``current input state'' can be very complicated indeed; there
+can be many levels and each level can arise in a variety of ways. The
+|show_context| procedure, which is used by \MP's error-reporting routine to
+print out the current input state on all levels down to the most recent
+line of characters from an input file, illustrates most of these conventions.
+The global variable |file_ptr| contains the lowest level that was
+displayed by this procedure.
+
+@<Glob...@>=
+integer file_ptr; /* shallowest level shown by |show_context| */
+
+@ The status at each level is indicated by printing two lines, where the first
+line indicates what was read so far and the second line shows what remains
+to be read. The context is cropped, if necessary, so that the first line
+contains at most |half_error_line| characters, and the second contains
+at most |error_line|. Non-current input levels whose |token_type| is
+`|backed_up|' are shown only if they have not been fully read.
+
+@c
+void mp_show_context (MP mp) { /* prints where the scanner is */
+ unsigned old_setting; /* saved |selector| setting */
+ @<Local variables for formatting calculations@>;
+ mp->file_ptr = mp->input_ptr;
+ mp->input_stack[mp->file_ptr] = mp->cur_input;
+ /* store current state */
+ while (1) {
+ mp->cur_input = mp->input_stack[mp->file_ptr]; /* enter into the context */
+ @<Display the current context@>;
+ if (file_state)
+ if ((name > max_spec_src) || (mp->file_ptr == 0))
+ break;
+ decr (mp->file_ptr);
+ }
+ mp->cur_input = mp->input_stack[mp->input_ptr]; /* restore original state */
+}
+
+
+@ @<Display the current context@>=
+if ((mp->file_ptr == mp->input_ptr) || file_state ||
+ (token_type != backed_up) || (nloc != NULL)) {
+ /* we omit backed-up token lists that have already been read */
+ mp->tally = 0; /* get ready to count characters */
+ old_setting = mp->selector;
+ if (file_state) {
+ @<Print location of current line@>;
+ @<Pseudoprint the line@>;
+ } else {
+ @<Print type of token list@>;
+ @<Pseudoprint the token list@>;
+ }
+ mp->selector = old_setting; /* stop pseudoprinting */
+ @<Print two lines using the tricky pseudoprinted information@>;
+}
+
+@ This routine should be changed, if necessary, to give the best possible
+indication of where the current line resides in the input file.
+For example, on some systems it is best to print both a page and line number.
+@^system dependencies@>
+
+@<Print location of current line@>=
+if (name > max_spec_src) {
+ mp_print_nl (mp, "l.");
+ mp_print_int (mp, mp_true_line (mp));
+} else if (terminal_input) {
+ if (mp->file_ptr == 0)
+ mp_print_nl (mp, "<*>");
+ else
+ mp_print_nl (mp, "<insert>");
+} else if (name == is_scantok) {
+ mp_print_nl (mp, "<scantokens>");
+} else {
+ mp_print_nl (mp, "<read>");
+}
+mp_print_char (mp, xord (' '))
+
+
+@ Can't use case statement here because the |token_type| is not
+a constant expression.
+
+@<Print type of token list@>=
+{
+ if (token_type == forever_text) {
+ mp_print_nl (mp, "<forever> ");
+ } else if (token_type == loop_text) {
+ @<Print the current loop value@>;
+ } else if (token_type == parameter) {
+ mp_print_nl (mp, "<argument> ");
+ } else if (token_type == backed_up) {
+ if (nloc == NULL)
+ mp_print_nl (mp, "<recently read> ");
+ else
+ mp_print_nl (mp, "<to be read again> ");
+ } else if (token_type == inserted) {
+ mp_print_nl (mp, "<inserted text> ");
+ } else if (token_type == macro) {
+ mp_print_ln (mp);
+ if (name != NULL)
+ mp_print_str (mp, name);
+ else
+ @<Print the name of a \&{vardef}'d macro@>;
+ mp_print (mp, "->");
+ } else {
+ mp_print_nl (mp, "?"); /* this should never happen */
+@.?\relax@>
+ }
+}
+
+
+@ The parameter that corresponds to a loop text is either a token list
+(in the case of \&{forsuffixes}) or a ``capsule'' (in the case of \&{for}).
+We'll discuss capsules later; for now, all we need to know is that
+the |link| field in a capsule parameter is |void| and that
+|print_exp(p,0)| displays the value of capsule~|p| in abbreviated form.
+
+@<Print the current loop value@>=
+{
+ mp_node pp;
+ mp_print_nl (mp, "<for(");
+ pp = mp->param_stack[param_start];
+ if (pp != NULL) {
+ if (mp_link (pp) == MP_VOID)
+ mp_print_exp (mp, pp, 0); /* we're in a \&{for} loop */
+ else
+ mp_show_token_list (mp, pp, NULL, 20, mp->tally);
+ }
+ mp_print (mp, ")> ");
+}
+
+
+@ The first two parameters of a macro defined by \&{vardef} will be token
+lists representing the macro's prefix and ``at point.'' By putting these
+together, we get the macro's full name.
+
+@<Print the name of a \&{vardef}'d macro@>=
+{
+ mp_node pp = mp->param_stack[param_start];
+ if (pp == NULL) {
+ mp_show_token_list (mp, mp->param_stack[param_start + 1], NULL, 20,
+ mp->tally);
+ } else {
+ mp_node qq = pp;
+ while (mp_link (qq) != NULL)
+ qq = mp_link (qq);
+ mp_link (qq) = mp->param_stack[param_start + 1];
+ mp_show_token_list (mp, pp, NULL, 20, mp->tally);
+ mp_link (qq) = NULL;
+ }
+}
+
+
+@ Now it is necessary to explain a little trick. We don't want to store a long
+string that corresponds to a token list, because that string might take up
+lots of memory; and we are printing during a time when an error message is
+being given, so we dare not do anything that might overflow one of \MP's
+tables. So `pseudoprinting' is the answer: We enter a mode of printing
+that stores characters into a buffer of length |error_line|, where character
+$k+1$ is placed into \hbox{|trick_buf[k mod error_line]|} if
+|k<trick_count|, otherwise character |k| is dropped. Initially we set
+|tally:=0| and |trick_count:=1000000|; then when we reach the
+point where transition from line 1 to line 2 should occur, we
+set |first_count:=tally| and |trick_count:=@tmax@>(error_line,
+tally+1+error_line-half_error_line)|. At the end of the
+pseudoprinting, the values of |first_count|, |tally|, and
+|trick_count| give us all the information we need to print the two lines,
+and all of the necessary text is in |trick_buf|.
+
+Namely, let |l| be the length of the descriptive information that appears
+on the first line. The length of the context information gathered for that
+line is |k=first_count|, and the length of the context information
+gathered for line~2 is $m=\min(|tally|, |trick_count|)-k$. If |l+k<=h|,
+where |h=half_error_line|, we print |trick_buf[0..k-1]| after the
+descriptive information on line~1, and set |n:=l+k|; here |n| is the
+length of line~1. If $l+k>h$, some cropping is necessary, so we set |n:=h|
+and print `\.{...}' followed by
+$$\hbox{|trick_buf[(l+k-h+3)..k-1]|,}$$
+where subscripts of |trick_buf| are circular modulo |error_line|. The
+second line consists of |n|~spaces followed by |trick_buf[k..(k+m-1)]|,
+unless |n+m>error_line|; in the latter case, further cropping is done.
+This is easier to program than to explain.
+
+@<Local variables for formatting...@>=
+int i; /* index into |buffer| */
+integer l; /* length of descriptive information on line 1 */
+integer m; /* context information gathered for line 2 */
+int n; /* length of line 1 */
+integer p; /* starting or ending place in |trick_buf| */
+integer q; /* temporary index */
+
+@ The following code tells the print routines to gather
+the desired information.
+
+@d begin_pseudoprint {
+ l=mp->tally; mp->tally=0; mp->selector=pseudo;
+ mp->trick_count=1000000;
+}
+@d set_trick_count() {
+ mp->first_count=mp->tally;
+ mp->trick_count=mp->tally+1+mp->error_line-mp->half_error_line;
+ if ( mp->trick_count<mp->error_line ) mp->trick_count=mp->error_line;
+}
+
+@ And the following code uses the information after it has been gathered.
+
+@<Print two lines using the tricky pseudoprinted information@>=
+if (mp->trick_count == 1000000)
+ set_trick_count();
+ /* |set_trick_count| must be performed */
+if (mp->tally < mp->trick_count)
+ m = mp->tally - mp->first_count;
+else
+ m = mp->trick_count - mp->first_count; /* context on line 2 */
+if (l + mp->first_count <= mp->half_error_line) {
+ p = 0;
+ n = l + mp->first_count;
+} else {
+ mp_print (mp, "...");
+ p = l + mp->first_count - mp->half_error_line + 3;
+ n = mp->half_error_line;
+}
+for (q = p; q <= mp->first_count - 1; q++) {
+ mp_print_char (mp, mp->trick_buf[q % mp->error_line]);
+}
+mp_print_ln (mp);
+for (q = 1; q <= n; q++) {
+ mp_print_char (mp, xord (' ')); /* print |n| spaces to begin line~2 */
+}
+if (m + n <= mp->error_line)
+ p = mp->first_count + m;
+else
+ p = mp->first_count + (mp->error_line - n - 3);
+for (q = mp->first_count; q <= p - 1; q++) {
+ mp_print_char (mp, mp->trick_buf[q % mp->error_line]);
+}
+if (m + n > mp->error_line)
+ mp_print (mp, "...")
+
+
+@ But the trick is distracting us from our current goal, which is to
+understand the input state. So let's concentrate on the data structures that
+are being pseudoprinted as we finish up the |show_context| procedure.
+
+@<Pseudoprint the line@>=
+begin_pseudoprint;
+if (limit > 0) {
+ for (i = start; i <= limit - 1; i++) {
+ if (i == loc)
+ set_trick_count();
+ mp_print_char (mp, mp->buffer[i]);
+ }
+}
+
+@ @<Pseudoprint the token list@>=
+begin_pseudoprint;
+if (token_type != macro)
+ mp_show_token_list (mp, nstart, nloc, 100000, 0);
+else
+ mp_show_macro (mp, nstart, nloc, 100000)
+
+
+@* Maintaining the input stacks.
+The following subroutines change the input status in commonly needed ways.
+
+First comes |push_input|, which stores the current state and creates a
+new level (having, initially, the same properties as the old).
+
+@d push_input { /* enter a new input level, save the old */
+ if ( mp->input_ptr>mp->max_in_stack ) {
+ mp->max_in_stack=mp->input_ptr;
+ if ( mp->input_ptr==mp->stack_size ) {
+ int l = (mp->stack_size+(mp->stack_size/4));
+ XREALLOC(mp->input_stack, l, in_state_record);
+ mp->stack_size = l;
+ }
+ }
+ mp->input_stack[mp->input_ptr]=mp->cur_input; /* stack the record */
+ incr(mp->input_ptr);
+}
+
+@ And of course what goes up must come down.
+
+@d pop_input { /* leave an input level, re-enter the old */
+ decr(mp->input_ptr); mp->cur_input=mp->input_stack[mp->input_ptr];
+ }
+
+@ Here is a procedure that starts a new level of token-list input, given
+a token list |p| and its type |t|. If |t=macro|, the calling routine should
+set |name|, reset~|loc|, and increase the macro's reference count.
+
+@d back_list(A) mp_begin_token_list(mp, (A), (quarterword)backed_up) /* backs up a simple token list */
+
+@c
+static void mp_begin_token_list (MP mp, mp_node p, quarterword t) {
+ push_input;
+ nstart = p;
+ token_type = t;
+ param_start = mp->param_ptr;
+ nloc = p;
+}
+
+
+@ When a token list has been fully scanned, the following computations
+should be done as we leave that level of input.
+@^inner loop@>
+
+@c
+static void mp_end_token_list (MP mp) { /* leave a token-list input level */
+ mp_node p; /* temporary register */
+ if (token_type >= backed_up) { /* token list to be deleted */
+ if (token_type <= inserted) {
+ mp_flush_token_list (mp, nstart);
+ goto DONE;
+ } else {
+ mp_delete_mac_ref (mp, nstart); /* update reference count */
+ }
+ }
+ while (mp->param_ptr > param_start) { /* parameters must be flushed */
+ decr (mp->param_ptr);
+ p = mp->param_stack[mp->param_ptr];
+ if (p != NULL) {
+ if (mp_link (p) == MP_VOID) { /* it's an \&{expr} parameter */
+ mp_recycle_value (mp, p);
+ mp_free_value_node (mp, p);
+ } else {
+ mp_flush_token_list (mp, p); /* it's a \&{suffix} or \&{text} parameter */
+ }
+ }
+ }
+DONE:
+ pop_input;
+ check_interrupt;
+}
+
+
+@ The contents of |cur_cmd,cur_mod,cur_sym| are placed into an equivalent
+token by the |cur_tok| routine.
+@^inner loop@>
+
+@c
+@<Declare the procedure called |make_exp_copy|@>;
+static mp_node mp_cur_tok (MP mp) {
+ mp_node p; /* a new token node */
+ if (cur_sym() == NULL && (cur_sym_mod() == 0 || cur_sym_mod() == mp_normal_sym)) {
+ if (cur_cmd() == mp_capsule_token) {
+ mp_number save_exp_num; /* possible |cur_exp| numerical to be restored */
+ mp_value save_exp = mp->cur_exp; /* |cur_exp| to be restored */
+ new_number (save_exp_num);
+ number_clone (save_exp_num, cur_exp_value_number());
+ mp_make_exp_copy (mp, cur_mod_node());
+ p = mp_stash_cur_exp (mp);
+ mp_link (p) = NULL;
+ mp->cur_exp = save_exp;
+ number_clone (mp->cur_exp.data.n, save_exp_num);
+ free_number (save_exp_num);
+ } else {
+ p = mp_get_token_node (mp);
+ mp_name_type (p) = mp_token;
+ if (cur_cmd() == mp_numeric_token) {
+ set_value_number (p, cur_mod_number());
+ mp_type (p) = mp_known;
+ } else {
+ set_value_str (p, cur_mod_str());
+ mp_type (p) = mp_string_type;
+ }
+ }
+ } else {
+ p = mp_get_symbolic_node (mp);
+ set_mp_sym_sym (p, cur_sym());
+ mp_name_type (p) = cur_sym_mod();
+ }
+ return p;
+}
+
+
+@ Sometimes \MP\ has read too far and wants to ``unscan'' what it has
+seen. The |back_input| procedure takes care of this by putting the token
+just scanned back into the input stream, ready to be read again.
+If |cur_sym<>0|, the values of |cur_cmd| and |cur_mod| are irrelevant.
+
+@<Declarations@>=
+static void mp_back_input (MP mp);
+
+@ @c
+void mp_back_input (MP mp) { /* undoes one token of input */
+ mp_node p; /* a token list of length one */
+ p = mp_cur_tok (mp);
+ while (token_state && (nloc == NULL))
+ mp_end_token_list (mp); /* conserve stack space */
+ back_list (p);
+}
+
+
+@ The |back_error| routine is used when we want to restore or replace an
+offending token just before issuing an error message. We disable interrupts
+during the call of |back_input| so that the help message won't be lost.
+
+@<Declarations@>=
+static void mp_back_error (MP mp, const char *msg, const char **hlp, boolean deletions_allowed) ;
+
+@ @c
+static void mp_back_error (MP mp, const char *msg, const char **hlp, boolean deletions_allowed) {
+ /* back up one token and call |error| */
+ mp->OK_to_interrupt = false;
+ mp_back_input (mp);
+ mp->OK_to_interrupt = true;
+ mp_error (mp, msg, hlp, deletions_allowed);
+}
+static void mp_ins_error (MP mp, const char *msg, const char **hlp, boolean deletions_allowed) {
+ /* back up one inserted token and call |error| */
+ mp->OK_to_interrupt = false;
+ mp_back_input (mp);
+ token_type = (quarterword) inserted;
+ mp->OK_to_interrupt = true;
+ mp_error (mp, msg, hlp, deletions_allowed);
+}
+
+
+@ The |begin_file_reading| procedure starts a new level of input for lines
+of characters to be read from a file, or as an insertion from the
+terminal. It does not take care of opening the file, nor does it set |loc|
+or |limit| or |line|.
+@^system dependencies@>
+
+@c
+void mp_begin_file_reading (MP mp) {
+ if (mp->in_open == (mp->max_in_open-1))
+ mp_reallocate_input_stack (mp, (mp->max_in_open + mp->max_in_open / 4));
+ if (mp->first == mp->buf_size)
+ mp_reallocate_buffer (mp, (mp->buf_size + mp->buf_size / 4));
+ mp->in_open++;
+ push_input;
+ iindex = (quarterword) mp->in_open;
+ if (mp->in_open_max < mp->in_open)
+ mp->in_open_max = mp->in_open;
+ mp->mpx_name[iindex] = absent;
+ start = (halfword) mp->first;
+ name = is_term; /* |terminal_input| is now |true| */
+}
+
+
+@ Conversely, the variables must be downdated when such a level of input
+is finished. Any associated \.{MPX} file must also be closed and popped
+off the file stack. While finishing preloading, it is possible that the file
+does not actually end with 'dump', so we capture that case here as well.
+
+@c
+static void mp_end_file_reading (MP mp) {
+ if (mp->reading_preload && mp->input_ptr == 0) {
+ set_cur_sym(mp->frozen_dump);
+ mp_back_input (mp);
+ return;
+ }
+ if (mp->in_open > iindex) {
+ if ((mp->mpx_name[mp->in_open] == absent) || (name <= max_spec_src)) {
+ mp_confusion (mp, "endinput");
+@:this can't happen endinput}{\quad endinput@>;
+ } else {
+ (mp->close_file) (mp, mp->input_file[mp->in_open]); /* close an \.{MPX} file */
+ delete_str_ref (mp->mpx_name[mp->in_open]);
+ decr (mp->in_open);
+ }
+ }
+ mp->first = (size_t) start;
+ if (iindex != mp->in_open)
+ mp_confusion (mp, "endinput");
+ if (name > max_spec_src) {
+ (mp->close_file) (mp, cur_file);
+ xfree (in_ext);
+ xfree (in_name);
+ xfree (in_area);
+ }
+ pop_input;
+ decr (mp->in_open);
+}
+
+
+@ Here is a function that tries to resume input from an \.{MPX} file already
+associated with the current input file. It returns |false| if this doesn't
+work.
+
+@c
+static boolean mp_begin_mpx_reading (MP mp) {
+ if (mp->in_open != iindex + 1) {
+ return false;
+ } else {
+ if (mp->mpx_name[mp->in_open] <= absent)
+ mp_confusion (mp, "mpx");
+ if (mp->first == mp->buf_size)
+ mp_reallocate_buffer (mp, (mp->buf_size + (mp->buf_size / 4)));
+ push_input;
+ iindex = (quarterword) mp->in_open;
+ start = (halfword) mp->first;
+ name = mp->mpx_name[mp->in_open];
+ add_str_ref (name);
+ /* Put an empty line in the input buffer */
+ /* We want to make it look as though we have just read a blank line
+ without really doing so. */
+ mp->last = mp->first;
+ limit = (halfword) mp->last;
+ /* simulate |input_ln| and |firm_up_the_line| */
+ mp->buffer[limit] = xord ('%');
+ mp->first = (size_t) (limit + 1);
+ loc = start;
+ return true;
+ }
+}
+
+
+@ This procedure temporarily stops reading an \.{MPX} file.
+
+@c
+static void mp_end_mpx_reading (MP mp) {
+ if (mp->in_open != iindex)
+ mp_confusion (mp, "mpx");
+@:this can't happen mpx}{\quad mpx@>;
+ if (loc < limit) {
+ /* Complain that we are not at the end of a line in the \.{MPX} file */
+ /* 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}. */
+ const char *hlp[] = {
+ "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.",
+ NULL };
+ mp_error (mp, "`mpxbreak' must be at the end of a line", hlp, true);
+ }
+ mp->first = (size_t) start;
+ pop_input;
+}
+
+@ In order to keep the stack from overflowing during a long sequence of
+inserted `\.{show}' commands, the following routine removes completed
+error-inserted lines from memory.
+
+@c
+void mp_clear_for_error_prompt (MP mp) {
+ while (file_state && terminal_input && (mp->input_ptr > 0) && (loc == limit))
+ mp_end_file_reading (mp);
+ mp_print_ln (mp);
+ clear_terminal();
+}
+
+
+@ To get \MP's whole input mechanism going, we perform the following
+actions.
+
+@<Initialize the input routines@>=
+{
+ mp->input_ptr = 0;
+ mp->max_in_stack = file_bottom;
+ mp->in_open = file_bottom;
+ mp->open_parens = 0;
+ mp->max_buf_stack = 0;
+ mp->param_ptr = 0;
+ mp->max_param_stack = 0;
+ mp->first = 0;
+ start = 0;
+ iindex = file_bottom;
+ line = 0;
+ name = is_term;
+ mp->mpx_name[file_bottom] = absent;
+ mp->force_eof = false;
+ if (!mp_init_terminal (mp))
+ mp_jump_out (mp);
+ limit = (halfword) mp->last;
+ mp->first = mp->last + 1;
+ /* |init_terminal| has set |loc| and |last| */
+}
+
+
+@* 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 */
+
+@<Glob...@>=
+#define tex_flushing 7 /* |scanner_status| when skipping \TeX\ material */
+integer scanner_status; /* are we scanning at high speed? */
+mp_sym warning_info; /* if so, what else do we need to know,
+ in case an error occurs? */
+integer warning_line;
+mp_node warning_info_node;
+
+@ @<Initialize the input routines@>=
+mp->scanner_status = normal;
+
+@ The following subroutine
+is called when an `\&{outer}' symbolic token has been scanned or
+when the end of a file has been reached. These two cases are distinguished
+by |cur_sym|, which is zero at the end of a file.
+
+@c
+static boolean mp_check_outer_validity (MP mp) {
+ mp_node p; /* points to inserted token list */
+ if (mp->scanner_status == normal) {
+ return true;
+ } else if (mp->scanner_status == tex_flushing) {
+ @<Check if the file has ended while flushing \TeX\ material and set the
+ result value for |check_outer_validity|@>;
+ } else {
+ @<Back up an outer symbolic token so that it can be reread@>;
+ if (mp->scanner_status > skipping) {
+ @<Tell the user what has run away and try to recover@>;
+ } else {
+ char msg[256];
+ const char *hlp[] = {
+ "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.",
+ NULL };
+ mp_snprintf(msg, 256, "Incomplete if; all text was ignored after line %d", (int)mp->warning_line);
+@.Incomplete if...@>;
+ if (cur_sym() == NULL) {
+ hlp[0] = "The file ended while I was skipping conditional text.";
+ }
+ set_cur_sym (mp->frozen_fi);
+ mp_ins_error (mp, msg, hlp, false);
+ }
+ return false;
+ }
+}
+
+
+@ @<Check if the file has ended while flushing \TeX\ material and set...@>=
+if (cur_sym() != NULL) {
+ return true;
+} else {
+ char msg[256];
+ const char *hlp[] = {
+ "The file ended while I was looking for the `etex' to",
+ "finish this TeX material. I've inserted `etex' now.",
+ NULL };
+ mp_snprintf(msg, 256, "TeX mode didn't end; all text was ignored after line %d", (int)mp->warning_line);
+ set_cur_sym(mp->frozen_etex);
+ mp_ins_error (mp, msg, hlp, false);
+ return false;
+}
+
+
+@ @<Back up an outer symbolic token so that it can be reread@>=
+if (cur_sym() != NULL) {
+ p = mp_get_symbolic_node (mp);
+ set_mp_sym_sym (p, cur_sym());
+ mp_name_type (p) = cur_sym_mod();
+ back_list (p); /* prepare to read the symbolic token again */
+}
+
+@ @<Tell the user what has run away...@>=
+{
+ char msg[256];
+ const char *msg_start = NULL;
+ const char *hlp[] = {
+ "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.",
+ NULL };
+ mp_runaway (mp); /* print the definition-so-far */
+ if (cur_sym() == NULL) {
+ msg_start = "File ended while scanning";
+@.File ended while scanning...@>
+ } else {
+ msg_start = "Forbidden token found while scanning";
+@.Forbidden token found...@>
+ }
+ switch (mp->scanner_status) {
+ @<Complete the error message,
+ and set |cur_sym| to a token that might help recover from the error@>
+ } /* there are no other cases */
+ mp_ins_error (mp, msg, hlp, true);
+}
+
+
+@ As we consider various kinds of errors, it is also appropriate to
+change the first line of the help message just given; |help_line[3]|
+points to the string that might be changed.
+
+@<Complete the error message,...@>=
+case flushing:
+ mp_snprintf (msg, 256, "%s to the end of the statement", msg_start);
+ hlp[0] = "A previous error seems to have propagated,";
+ set_cur_sym(mp->frozen_semicolon);
+ break;
+case absorbing:
+ mp_snprintf (msg, 256, "%s a text argument", msg_start);
+ hlp[0] = "It seems that a right delimiter was left out,";
+ if (mp->warning_info == NULL) {
+ set_cur_sym(mp->frozen_end_group);
+ } else {
+ set_cur_sym(mp->frozen_right_delimiter);
+ /* the next line makes sure that the inserted delimiter will
+ match the delimiter that already was read. */
+ set_equiv_sym (cur_sym(), mp->warning_info);
+ }
+ break;
+case var_defining:
+ {
+ mp_string s;
+ int old_setting = mp->selector;
+ mp->selector = new_string;
+ mp_print_variable_name (mp, mp->warning_info_node);
+ s = mp_make_string (mp);
+ mp->selector = old_setting;
+ mp_snprintf (msg, 256, "%s the definition of %s", msg_start, s->str);
+ delete_str_ref(s);
+ }
+ set_cur_sym(mp->frozen_end_def);
+ break;
+case op_defining:
+ {
+ char *s = mp_str(mp, text(mp->warning_info));
+ mp_snprintf (msg, 256, "%s the definition of %s", msg_start, s);
+ }
+ set_cur_sym(mp->frozen_end_def);
+ break;
+case loop_defining:
+ {
+ char *s = mp_str(mp, text(mp->warning_info));
+ mp_snprintf (msg, 256, "%s the text of a %s loop", msg_start, s);
+ }
+ hlp[0] = "I suspect you have forgotten an `endfor',";
+ set_cur_sym(mp->frozen_end_for);
+break;
+
+@ The |runaway| procedure displays the first part of the text that occurred
+when \MP\ began its special |scanner_status|, if that text has been saved.
+
+@<Declarations@>=
+static void mp_runaway (MP mp);
+
+@ @c
+void mp_runaway (MP mp) {
+ if (mp->scanner_status > flushing) {
+ mp_print_nl (mp, "Runaway ");
+ switch (mp->scanner_status) {
+ case absorbing:
+ mp_print (mp, "text?");
+ break;
+ case var_defining:
+ case op_defining:
+ mp_print (mp, "definition?");
+ break;
+ case loop_defining:
+ mp_print (mp, "loop?");
+ break;
+ } /* there are no other cases */
+ mp_print_ln (mp);
+ mp_show_token_list (mp, mp_link (mp->hold_head), NULL, mp->error_line - 10,
+ 0);
+ }
+}
+
+
+@ We need to mention a procedure that may be called by |get_next|.
+
+@<Declarations@>=
+static void mp_firm_up_the_line (MP mp);
+
+@ And now we're ready to take the plunge into |get_next| itself.
+Note that the behavior depends on the |scanner_status| because percent signs
+and double quotes need to be passed over when skipping TeX material.
+
+@c
+void mp_get_next (MP mp) {
+ /* sets |cur_cmd|, |cur_mod|, |cur_sym| to next token */
+ mp_sym cur_sym_; /* speed up access */
+RESTART:
+ set_cur_sym(NULL);
+ set_cur_sym_mod(0);
+ if (file_state) {
+ int k; /* an index into |buffer| */
+ ASCII_code c; /* the current character in the buffer */
+ int cclass; /* its class number */
+ /* Input from external file; |goto restart| if no input found,
+ or |return| if a non-symbolic token is found */
+ /* A percent sign appears in |buffer[limit]|; this makes it unnecessary
+ to have a special test for end-of-line. */
+ SWITCH:
+ c = mp->buffer[loc];
+ incr (loc);
+ cclass = mp->char_class[c];
+ switch (cclass) {
+ case digit_class:
+ scan_numeric_token((c - '0'));
+ return;
+ break;
+ case period_class:
+ cclass = mp->char_class[mp->buffer[loc]];
+ if (cclass > period_class) {
+ goto SWITCH;
+ } else if (cclass < period_class) { /* |class=digit_class| */
+ scan_fractional_token(0);
+ return;
+ }
+ break;
+ case space_class:
+ goto SWITCH;
+ break;
+ case percent_class:
+ if (mp->scanner_status == tex_flushing) {
+ if (loc < limit)
+ goto SWITCH;
+ }
+ /* Move to next line of file, or |goto restart| if there is no next line */
+ switch (move_to_next_line(mp)) {
+ case 1: goto RESTART; break;
+ case 2: goto COMMON_ENDING; break;
+ default: break;
+ }
+ check_interrupt;
+ goto SWITCH;
+ break;
+ case string_class:
+ if (mp->scanner_status == tex_flushing) {
+ goto SWITCH;
+ } else {
+ if (mp->buffer[loc] == '"') {
+ set_cur_mod_str(mp_rts(mp,""));
+ } else {
+ k = loc;
+ mp->buffer[limit + 1] = xord ('"');
+ do {
+ incr (loc);
+ } while (mp->buffer[loc] != '"');
+ if (loc > limit) {
+ /* Decry the missing string delimiter and |goto restart| */
+ /* 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. */
+ const char *hlp[] = {
+ "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\"'.",
+ NULL };
+ loc = limit; /* the next character to be read on this line will be |"%"| */
+ mp_error (mp, "Incomplete string token has been flushed", hlp, false);
+ goto RESTART;
+ }
+ str_room ((size_t) (loc - k));
+ do {
+ append_char (mp->buffer[k]);
+ incr (k);
+ } while (k != loc);
+ set_cur_mod_str(mp_make_string (mp));
+ }
+ incr (loc);
+ set_cur_cmd((mp_variable_type)mp_string_token);
+ return;
+ }
+ break;
+ case isolated_classes:
+ k = loc - 1;
+ goto FOUND;
+ break;
+ case invalid_class:
+ if (mp->scanner_status == tex_flushing) {
+ goto SWITCH;
+ } else {
+ /* Decry the invalid character and |goto restart| */
+ /* 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|). */
+ const char *hlp[] = {
+ "A funny symbol that I can\'t read has just been input.",
+ "Continue, and I'll forget that it ever happened.",
+ NULL };
+ mp_error(mp, "Text line contains an invalid character", hlp, false);
+ goto RESTART;
+ }
+ break;
+ default:
+ break; /* letters, etc. */
+ }
+ k = loc - 1;
+ while (mp->char_class[mp->buffer[loc]] == cclass)
+ incr (loc);
+ FOUND:
+ set_cur_sym(mp_id_lookup (mp, (char *) (mp->buffer + k), (size_t) (loc - k), true));
+
+ } 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 */
+ if (nloc != NULL && mp_type (nloc) == mp_symbol_node) { /* symbolic token */
+ int cur_sym_mod_ = mp_name_type (nloc);
+ halfword cur_info = mp_sym_info (nloc);
+ set_cur_sym(mp_sym_sym (nloc));
+ set_cur_sym_mod(cur_sym_mod_);
+ nloc = mp_link (nloc); /* move to next */
+ if (cur_sym_mod_ == mp_expr_sym) {
+ set_cur_cmd((mp_variable_type)mp_capsule_token);
+ set_cur_mod_node(mp->param_stack[param_start + cur_info]);
+ set_cur_sym_mod(0);
+ set_cur_sym(NULL);
+ return;
+ } else if (cur_sym_mod_ == mp_suffix_sym || cur_sym_mod_ == mp_text_sym) {
+ mp_begin_token_list (mp,
+ mp->param_stack[param_start + cur_info],
+ (quarterword) parameter);
+ goto RESTART;
+ }
+ } else if (nloc != NULL) {
+ /* Get a stored numeric or string or capsule token and |return| */
+ if (mp_name_type (nloc) == mp_token) {
+ if (mp_type (nloc) == mp_known) {
+ set_cur_mod_number(value_number (nloc));
+ set_cur_cmd((mp_variable_type)mp_numeric_token);
+ } else {
+ set_cur_mod_str(value_str (nloc));
+ set_cur_cmd((mp_variable_type)mp_string_token);
+ add_str_ref (cur_mod_str());
+ }
+ } else {
+ set_cur_mod_node(nloc);
+ set_cur_cmd((mp_variable_type)mp_capsule_token);
+ }
+ nloc = mp_link (nloc);
+ return;
+ } else { /* we are done with this token list */
+ mp_end_token_list (mp);
+ goto RESTART; /* resume previous level */
+ }
+ }
+COMMON_ENDING:
+ /* When a symbolic token is declared to be `\&{outer}', its command code
+ is increased by |outer_tag|. */
+ cur_sym_ = cur_sym();
+ set_cur_cmd(eq_type (cur_sym_));
+ set_cur_mod(equiv (cur_sym_));
+ set_cur_mod_node(equiv_node (cur_sym_));
+ if (cur_cmd() >= mp_outer_tag) {
+ if (mp_check_outer_validity (mp))
+ set_cur_cmd(cur_cmd() - mp_outer_tag);
+ else
+ goto RESTART;
+ }
+}
+
+@ The global variable |force_eof| is normally |false|; it is set |true|
+by an \&{endinput} command.
+
+@<Glob...@>=
+boolean force_eof; /* should the next \&{input} be aborted early? */
+
+@ @<Declarations@>=
+static int move_to_next_line (MP mp);
+
+@ @c
+static int move_to_next_line (MP mp) {
+ if (name > max_spec_src) {
+ /* Read next line of file into |buffer|, or return 1
+ (|goto restart|) if the file has ended */
+ /* 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|. */
+ {
+ incr (line);
+ mp->first = (size_t) start;
+ if (!mp->force_eof) {
+ if (mp_input_ln (mp, cur_file)) /* not end of file */
+ mp_firm_up_the_line (mp); /* this sets |limit| */
+ else
+ mp->force_eof = true;
+ };
+ if (mp->force_eof) {
+ mp->force_eof = false;
+ decr (loc);
+ if (mpx_reading) {
+ /* Complain that the \.{MPX} file ended unexpectly; then set
+ |cur_sym:=mp->frozen_mpx_break| and |goto comon_ending| */
+ /* 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. */
+ const char *hlp[] = {"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.",
+ NULL };
+ mp->mpx_name[iindex] = mpx_finished;
+ mp_error (mp, "mpx file ended unexpectedly", hlp, false);
+ set_cur_sym(mp->frozen_mpx_break);
+ return 2;
+ } else {
+ mp_print_char (mp, xord (')'));
+ decr (mp->open_parens);
+ update_terminal(); /* show user that file has been read */
+ mp_end_file_reading (mp); /* resume previous level */
+ if (mp_check_outer_validity (mp))
+ return 1;
+ else
+ return 1;
+ }
+ }
+ mp->buffer[limit] = xord ('%');
+ mp->first = (size_t) (limit + 1);
+ loc = start; /* ready to read */
+ }
+
+
+ } else {
+ if (mp->input_ptr > 0) {
+ /* text was inserted during error recovery or by \&{scantokens} */
+ mp_end_file_reading (mp);
+ /* goto RESTART */
+ return 1; /* resume previous level */
+ }
+ if (mp->job_name == NULL
+ && (mp->selector < log_only || mp->selector >= write_file))
+ mp_open_log_file (mp);
+ if (mp->interaction > mp_nonstop_mode) {
+ if (limit == start) /* previous line was empty */
+ mp_print_nl (mp, "(Please type a command or say `end')");
+ mp_print_ln (mp);
+ mp->first = (size_t) start;
+ prompt_input ("*"); /* input on-line into |buffer| */
+ limit = (halfword) mp->last;
+ mp->buffer[limit] = xord ('%');
+ mp->first = (size_t) (limit + 1);
+ loc = start;
+ } else {
+ mp_fatal_error (mp, "*** (job aborted, no legal end found)");
+ /* nonstop mode, which is intended for overnight batch processing,
+ never waits for on-line input */
+ }
+ }
+ return 0;
+}
+
+
+@ If the user has set the |mp_pausing| parameter to some positive value,
+and if nonstop mode has not been selected, each line of input is displayed
+on the terminal and the transcript file, followed by `\.{=>}'.
+\MP\ waits for a response. If the response is NULL (i.e., if nothing is
+typed except perhaps a few blank spaces), the original
+line is accepted as it stands; otherwise the line typed is
+used instead of the line in the file.
+
+@c
+void mp_firm_up_the_line (MP mp) {
+ size_t k; /* an index into |buffer| */
+ limit = (halfword) mp->last;
+ if ((!mp->noninteractive)
+ && (number_positive (internal_value (mp_pausing)))
+ && (mp->interaction > mp_nonstop_mode)) {
+ wake_up_terminal();
+ mp_print_ln (mp);
+ if (start < limit) {
+ for (k = (size_t) start; k < (size_t) limit; k++) {
+ mp_print_char (mp, mp->buffer[k]);
+ }
+ }
+ mp->first = (size_t) limit;
+ prompt_input ("=>"); /* wait for user response */
+@.=>@>;
+ if (mp->last > mp->first) {
+ for (k = mp->first; k < mp->last; k++) { /* move line down in buffer */
+ mp->buffer[k + (size_t) start - mp->first] = mp->buffer[k];
+ }
+ limit = (halfword) ((size_t) start + mp->last - mp->first);
+ }
+ }
+}
+
+
+@* Dealing with \TeX\ material.
+The \&{btex}$\,\ldots\,$\&{etex} and \&{verbatimtex}$\,\ldots\,$\&{etex}
+features need to be implemented at a low level in the scanning process
+so that \MP\ can stay in synch with the a preprocessor that treats
+blocks of \TeX\ material as they occur in the input file without trying
+to expand \MP\ macros. Thus we need a special version of |get_next|
+that does not expand macros and such but does handle \&{btex},
+\&{verbatimtex}, etc.
+
+The special version of |get_next| is called |get_t_next|. It works by flushing
+\&{btex}$\,\ldots\,$\&{etex} and \&{verbatimtex}\allowbreak
+$\,\ldots\,$\&{etex} blocks, switching to the \.{MPX} file when it sees
+\&{btex}, and switching back when it sees \&{mpxbreak}.
+
+@d btex_code 0
+@d verbatim_code 1
+
+@ @<Put each...@>=
+mp_primitive (mp, "btex", mp_start_tex, btex_code);
+@:btex_}{\&{btex} primitive@>;
+mp_primitive (mp, "verbatimtex", mp_start_tex, verbatim_code);
+@:verbatimtex_}{\&{verbatimtex} primitive@>;
+mp_primitive (mp, "etex", mp_etex_marker, 0);
+mp->frozen_etex = mp_frozen_primitive (mp, "etex", mp_etex_marker, 0);
+@:etex_}{\&{etex} primitive@>;
+mp_primitive (mp, "mpxbreak", mp_mpx_break, 0);
+mp->frozen_mpx_break = mp_frozen_primitive (mp, "mpxbreak", mp_mpx_break, 0);
+@:mpx_break_}{\&{mpxbreak} primitive@>
+
+
+@ @<Cases of |print_cmd...@>=
+case mp_start_tex:
+if (m == btex_code)
+ mp_print (mp, "btex");
+else
+ mp_print (mp, "verbatimtex");
+break;
+case mp_etex_marker:
+mp_print (mp, "etex");
+break;
+case mp_mpx_break:
+mp_print (mp, "mpxbreak");
+break;
+
+@ Actually, |get_t_next| is a macro that avoids procedure overhead except
+in the unusual case where \&{btex}, \&{verbatimtex}, \&{etex}, or \&{mpxbreak}
+is encountered.
+
+@d get_t_next(a) do {
+ mp_get_next (mp);
+ if (cur_cmd() <= mp_max_pre_command)
+ mp_t_next (mp);
+} while (0)
+
+@c
+@ @<Declarations@>=
+static void mp_t_next (MP mp);
+static void mp_start_mpx_input (MP mp);
+
+@ @c
+static void mp_t_next (MP mp) {
+ int old_status; /* saves the |scanner_status| */
+ integer old_info; /* saves the |warning_info| */
+
+if ((mp->extensions == 1) && (cur_cmd() == mp_start_tex)) {
+ @<Pass btex ... etex to script@>;
+} else {
+
+ while (cur_cmd() <= mp_max_pre_command) {
+ if (cur_cmd() == mp_mpx_break) {
+ if (!file_state || (mp->mpx_name[iindex] == absent)) {
+ @<Complain about a misplaced \&{mpxbreak}@>;
+ } else {
+ mp_end_mpx_reading (mp);
+ goto TEX_FLUSH;
+ }
+ } else if (cur_cmd() == mp_start_tex) {
+ if (token_state || (name <= max_spec_src)) {
+ @<Complain that we are not reading a file@>;
+ } else if (mpx_reading) {
+ @<Complain that \.{MPX} files cannot contain \TeX\ material@>;
+ } else if ((cur_mod() != verbatim_code) &&
+ (mp->mpx_name[iindex] != mpx_finished)) {
+ if (!mp_begin_mpx_reading (mp))
+ mp_start_mpx_input (mp);
+ } else {
+ goto TEX_FLUSH;
+ }
+ } else {
+ @<Complain about a misplaced \&{etex}@>;
+ }
+ goto COMMON_ENDING;
+ TEX_FLUSH:
+ @<Flush the \TeX\ material@>;
+ COMMON_ENDING:
+ mp_get_next (mp);
+ }
+}
+}
+
+
+@ We could be in the middle of an operation such as skipping false conditional
+text when \TeX\ material is encountered, so we must be careful to save the
+|scanner_status|.
+
+@<Flush the \TeX\ material@>=
+old_status = mp->scanner_status;
+old_info = mp->warning_line;
+mp->scanner_status = tex_flushing;
+mp->warning_line = line;
+do {
+ mp_get_next (mp);
+} while (cur_cmd() != mp_etex_marker);
+mp->scanner_status = old_status;
+mp->warning_line = old_info
+
+@ @<Complain that \.{MPX} files cannot contain \TeX\ material@>=
+{
+ const char *hlp[] = {
+ "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.",
+ NULL };
+ mp_error (mp, "An mpx file cannot contain btex or verbatimtex blocks", hlp, true);
+}
+
+
+@ @<Complain that we are not reading a file@>=
+{
+ const char *hlp[] = {
+ "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`.",
+ NULL };
+ mp_error (mp, "You can only use `btex' or `verbatimtex' in a file", hlp, true);
+}
+
+
+@ @<Complain about a misplaced \&{mpxbreak}@>=
+{
+ const char *hlp[] = {
+ "I'll ignore this preprocessor command because it",
+ "doesn't belong here",
+ NULL };
+ mp_error (mp, "Misplaced mpxbreak", hlp, true);
+}
+
+
+@ @<Complain about a misplaced \&{etex}@>=
+{
+ const char *hlp[] = {
+ "There is no btex or verbatimtex for this to match",
+ NULL };
+ mp_error (mp, "Extra etex will be ignored", hlp, true);
+}
+
+
+@* 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 start_for 2 /* command modifier for \&{forever} */
+@d start_forsuffixes 3 /* command modifier for \&{forever} */
+@d end_for 0 /* command modifier for \&{endfor} */
+
+@<Put each...@>=
+mp_primitive (mp, "def", mp_macro_def, start_def);
+@:def_}{\&{def} primitive@>;
+mp_primitive (mp, "vardef", mp_macro_def, var_def);
+@:var_def_}{\&{vardef} primitive@>;
+mp_primitive (mp, "primarydef", mp_macro_def, mp_secondary_primary_macro);
+@:primary_def_}{\&{primarydef} primitive@>;
+mp_primitive (mp, "secondarydef", mp_macro_def, mp_tertiary_secondary_macro);
+@:secondary_def_}{\&{secondarydef} primitive@>;
+mp_primitive (mp, "tertiarydef", mp_macro_def, mp_expression_tertiary_macro);
+@:tertiary_def_}{\&{tertiarydef} primitive@>;
+mp_primitive (mp, "enddef", mp_macro_def, end_def);
+mp->frozen_end_def = mp_frozen_primitive (mp, "enddef", mp_macro_def, end_def);
+@:end_def_}{\&{enddef} primitive@>;
+mp_primitive (mp, "for", mp_iteration, start_for);
+@:for_}{\&{for} primitive@>;
+mp_primitive (mp, "forsuffixes", mp_iteration, start_forsuffixes);
+@:for_suffixes_}{\&{forsuffixes} primitive@>;
+mp_primitive (mp, "forever", mp_iteration, start_forever);
+@:forever_}{\&{forever} primitive@>;
+mp_primitive (mp, "endfor", mp_iteration, end_for);
+mp->frozen_end_for = mp_frozen_primitive (mp, "endfor", mp_iteration, end_for);
+@:end_for_}{\&{endfor} primitive@>
+
+
+@ @<Cases of |print_cmd...@>=
+case mp_macro_def:
+if (m <= var_def) {
+ if (m == start_def)
+ mp_print (mp, "def");
+ else if (m < start_def)
+ mp_print (mp, "enddef");
+ else
+ mp_print (mp, "vardef");
+} else if (m == mp_secondary_primary_macro) {
+ mp_print (mp, "primarydef");
+} else if (m == mp_tertiary_secondary_macro) {
+ mp_print (mp, "secondarydef");
+} else {
+ mp_print (mp, "tertiarydef");
+}
+break;
+case mp_iteration:
+if (m == start_forever)
+ mp_print (mp, "forever");
+else if (m == end_for)
+ mp_print (mp, "endfor");
+else if (m == start_for)
+ mp_print (mp, "for");
+else
+ mp_print (mp, "forsuffixes");
+break;
+
+@ Different macro-absorbing operations have different syntaxes, but they
+also have a lot in common. There is a list of special symbols that are to
+be replaced by parameter tokens; there is a special command code that
+ends the definition; the quotation conventions are identical. Therefore
+it makes sense to have most of the work done by a single subroutine. That
+subroutine is called |scan_toks|.
+
+The first parameter to |scan_toks| is the command code that will
+terminate scanning (either |macro_def| or |iteration|).
+
+The second parameter, |subst_list|, points to a (possibly empty) list
+of non-symbolic 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)}.
+
+@<Types...@>=
+typedef struct mp_subst_list_item {
+ mp_name_type_type info_mod;
+ quarterword value_mod;
+ mp_sym info;
+ halfword value_data;
+ struct mp_subst_list_item *link;
+} mp_subst_list_item;
+
+@
+@c
+static mp_node mp_scan_toks (MP mp, mp_command_code terminator,
+ mp_subst_list_item * subst_list, mp_node tail_end,
+ quarterword suffix_count) {
+ mp_node p; /* tail of the token list being built */
+ mp_subst_list_item *q = NULL; /* temporary for link management */
+ integer balance; /* left delimiters minus right delimiters */
+ halfword cur_data;
+ quarterword cur_data_mod = 0;
+ p = mp->hold_head;
+ balance = 1;
+ mp_link (mp->hold_head) = NULL;
+ while (1) {
+ get_t_next (mp);
+ cur_data = -1;
+ if (cur_sym() != NULL) {
+ @<Substitute for |cur_sym|, if it's on the |subst_list|@>;
+ if (cur_cmd() == terminator) {
+ @<Adjust the balance; |break| if it's zero@>;
+ } else if (cur_cmd() == mp_macro_special) {
+ /* Handle quoted symbols, \.{\#\AT!}, \.{\AT!}, or \.{\AT!\#} */
+ if (cur_mod() == quote) {
+ get_t_next (mp);
+ } else if (cur_mod() <= suffix_count) {
+ cur_data = cur_mod() - 1;
+ cur_data_mod = mp_suffix_sym;
+ }
+ }
+ }
+ if (cur_data != -1) {
+ mp_node pp = mp_get_symbolic_node (mp);
+ set_mp_sym_info (pp, cur_data);
+ mp_name_type (pp) = cur_data_mod;
+ mp_link (p) = pp;
+ } else {
+ mp_link (p) = mp_cur_tok (mp);
+ }
+ p = mp_link (p);
+ }
+ mp_link (p) = tail_end;
+ while (subst_list) {
+ q = subst_list->link;
+ xfree (subst_list);
+ subst_list = q;
+ }
+ return mp_link (mp->hold_head);
+}
+
+@
+@c
+void mp_print_sym (mp_sym sym) {
+ printf("{type = %d, v = {type = %d, data = {indep = {scale = %d, serial = %d}, n = %d, str = %p, sym = %p, node = %p, p = %p}}, text = %p}\n", sym->type, sym->v.type, (int)sym->v.data.indep.scale, (int)sym->v.data.indep.serial,
+ sym->v.data.n.type, sym->v.data.str, sym->v.data.sym, sym->v.data.node, sym->v.data.p, sym->text);
+ if (is_number(sym->v.data.n)) {
+ mp_number n = sym->v.data.n;
+ printf("{data = {dval = %f, val = %d}, type = %d}\n", n.data.dval, n.data.val, n.type);
+ }
+ if (sym->text != NULL) {
+ mp_string t = sym->text;
+ printf ("{str = %p \"%s\", len = %d, refs = %d}\n", t->str, t->str, (int)t->len, t->refs);
+ }
+}
+
+@
+@<Declarations@>=
+void mp_print_sym (mp_sym sym) ;
+
+@ @<Substitute for |cur_sym|...@>=
+{
+ q = subst_list;
+ while (q != NULL) {
+ if (q->info == cur_sym() && q->info_mod == cur_sym_mod()) {
+ cur_data = q->value_data;
+ cur_data_mod = q->value_mod;
+ set_cur_cmd((mp_variable_type)mp_relax);
+ break;
+ }
+ q = q->link;
+ }
+}
+
+
+@ @<Adjust the balance; |break| if it's zero@>=
+if (cur_mod() > 0) {
+ incr (balance);
+} else {
+ decr (balance);
+ if (balance == 0)
+ break;
+}
+
+
+@ Four commands are intended to be used only within macro texts: \&{quote},
+\.{\#\AT!}, \.{\AT!}, and \.{\AT!\#}. They are variants of a single command
+code called |macro_special|.
+
+@d quote 0 /* |macro_special| modifier for \&{quote} */
+@d macro_prefix 1 /* |macro_special| modifier for \.{\#\AT!} */
+@d macro_at 2 /* |macro_special| modifier for \.{\AT!} */
+@d macro_suffix 3 /* |macro_special| modifier for \.{\AT!\#} */
+
+@<Put each...@>=
+mp_primitive (mp, "quote", mp_macro_special, quote);
+@:quote_}{\&{quote} primitive@>;
+mp_primitive (mp, "#@@", mp_macro_special, macro_prefix);
+@:]]]\#\AT!_}{\.{\#\AT!} primitive@>;
+mp_primitive (mp, "@@", mp_macro_special, macro_at);
+@:]]]\AT!_}{\.{\AT!} primitive@>;
+mp_primitive (mp, "@@#", mp_macro_special, macro_suffix);
+@:]]]\AT!\#_}{\.{\AT!\#} primitive@>
+
+
+@ @<Cases of |print_cmd...@>=
+case mp_macro_special:
+switch (m) {
+case macro_prefix:
+ mp_print (mp, "#@@");
+ break;
+case macro_at:
+ mp_print_char (mp, xord ('@@'));
+ break;
+case macro_suffix:
+ mp_print (mp, "@@#");
+ break;
+default:
+ mp_print (mp, "quote");
+ break;
+}
+break;
+
+@ Here is a routine that's used whenever a token will be redefined. If
+the user's token is unredefinable, the `|mp->frozen_inaccessible|' token is
+substituted; the latter is redefinable but essentially impossible to use,
+hence \MP's tables won't get fouled up.
+
+@c
+static void mp_get_symbol (MP mp) { /* sets |cur_sym| to a safe symbol */
+RESTART:
+ get_t_next (mp);
+ if ((cur_sym() == NULL) || mp_is_frozen(mp, cur_sym())) {
+ const char *hlp[] = {
+ "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.",
+ NULL };
+ if (cur_sym() != NULL)
+ hlp[0] = "Sorry: You can\'t redefine my error-recovery tokens.";
+ else if (cur_cmd() == mp_string_token)
+ delete_str_ref (cur_mod_str());
+ set_cur_sym(mp->frozen_inaccessible);
+ mp_ins_error (mp, "Missing symbolic token inserted", hlp, true);
+@.Missing symbolic token...@>;
+ goto RESTART;
+ }
+}
+
+
+@ Before we actually redefine a symbolic token, we need to clear away its
+former value, if it was a variable. The following stronger version of
+|get_symbol| does that.
+
+@c
+static void mp_get_clear_symbol (MP mp) {
+ mp_get_symbol (mp);
+ mp_clear_symbol (mp, cur_sym(), false);
+}
+
+
+@ Here's another little subroutine; it checks that an equals sign
+or assignment sign comes along at the proper place in a macro definition.
+
+@c
+static void mp_check_equals (MP mp) {
+ if (cur_cmd() != mp_equals)
+ if (cur_cmd() != mp_assignment) {
+ const char *hlp[] = {
+ "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.",
+ NULL };
+ mp_back_error (mp, "Missing `=' has been inserted", hlp, true);
+@.Missing `='@>;
+ }
+}
+
+
+@ 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}.
+
+@c
+static void mp_make_op_def (MP mp) {
+ mp_command_code m; /* the type of definition */
+ mp_node q, r; /* for list manipulation */
+ mp_subst_list_item *qm = NULL, *qn = NULL;
+ m = cur_mod();
+ mp_get_symbol (mp);
+ qm = xmalloc (1, sizeof (mp_subst_list_item));
+ qm->link = NULL;
+ qm->info = cur_sym();
+ qm->info_mod = cur_sym_mod();
+ qm->value_data = 0;
+ qm->value_mod = mp_expr_sym;
+ mp_get_clear_symbol (mp);
+ mp->warning_info = cur_sym();
+ mp_get_symbol (mp);
+ qn = xmalloc (1, sizeof (mp_subst_list_item));
+ qn->link = qm;
+ qn->info = cur_sym();
+ qn->info_mod = cur_sym_mod();
+ qn->value_data = 1;
+ qn->value_mod = mp_expr_sym;
+ get_t_next (mp);
+ mp_check_equals (mp);
+ mp->scanner_status = op_defining;
+ q = mp_get_symbolic_node (mp);
+ set_ref_count (q, 0);
+ r = mp_get_symbolic_node (mp);
+ mp_link (q) = r;
+ set_mp_sym_info (r, mp_general_macro);
+ mp_name_type (r) = mp_macro_sym;
+ mp_link (r) = mp_scan_toks (mp, mp_macro_def, qn, NULL, 0);
+ mp->scanner_status = normal;
+ set_eq_type (mp->warning_info, m);
+ set_equiv_node (mp->warning_info, q);
+ mp_get_x_next (mp);
+}
+
+
+@ Parameters to macros are introduced by the keywords \&{expr},
+\&{suffix}, \&{text}, \&{primary}, \&{secondary}, and \&{tertiary}.
+
+@<Put each...@>=
+mp_primitive (mp, "expr", mp_param_type, mp_expr_param);
+@:expr_}{\&{expr} primitive@>;
+mp_primitive (mp, "suffix", mp_param_type, mp_suffix_param);
+@:suffix_}{\&{suffix} primitive@>;
+mp_primitive (mp, "text", mp_param_type, mp_text_param);
+@:text_}{\&{text} primitive@>;
+mp_primitive (mp, "primary", mp_param_type, mp_primary_macro);
+@:primary_}{\&{primary} primitive@>;
+mp_primitive (mp, "secondary", mp_param_type, mp_secondary_macro);
+@:secondary_}{\&{secondary} primitive@>;
+mp_primitive (mp, "tertiary", mp_param_type, mp_tertiary_macro);
+@:tertiary_}{\&{tertiary} primitive@>
+
+
+@ @<Cases of |print_cmd...@>=
+case mp_param_type:
+if (m == mp_expr_param)
+ mp_print (mp, "expr");
+else if (m == mp_suffix_param)
+ mp_print (mp, "suffix");
+else if (m == mp_text_param)
+ mp_print (mp, "text");
+else if (m == mp_primary_macro)
+ mp_print (mp, "primary");
+else if (m == mp_secondary_macro)
+ mp_print (mp, "secondary");
+else
+ mp_print (mp, "tertiary");
+break;
+
+@ Let's turn next to the more complex processing associated with \&{def}
+and \&{vardef}. When the following procedure is called, |cur_mod|
+should be either |start_def| or |var_def|.
+
+Note that although the macro scanner allows |def = := enddef| and
+|def := = enddef|; |def = = enddef| and |def := := enddef| will generate
+an error because by the time the second of the two identical tokens is
+seen, its meaning has already become undefined.
+
+@c
+static void mp_scan_def (MP mp) {
+ int m; /* the type of definition */
+ int n; /* the number of special suffix parameters */
+ int k; /* the total number of parameters */
+ int c; /* the kind of macro we're defining */
+ mp_subst_list_item *r = NULL, *rp = NULL; /* parameter-substitution list */
+ mp_node q; /* tail of the macro token list */
+ mp_node p; /* temporary storage */
+ quarterword sym_type; /* |expr_sym|, |suffix_sym|, or |text_sym| */
+ mp_sym l_delim, r_delim; /* matching delimiters */
+ m = cur_mod();
+ c = mp_general_macro;
+ mp_link (mp->hold_head) = NULL;
+ q = mp_get_symbolic_node (mp);
+ set_ref_count (q, 0);
+ r = NULL;
+ /* Scan the token or variable to be defined;
+ set |n|, |scanner_status|, and |warning_info| */
+ if (m == start_def) {
+ mp_get_clear_symbol (mp);
+ mp->warning_info = cur_sym();
+ get_t_next (mp);
+ mp->scanner_status = op_defining;
+ n = 0;
+ set_eq_type (mp->warning_info, mp_defined_macro);
+ set_equiv_node (mp->warning_info, q);
+ } else { /* |var_def| */
+ p = mp_scan_declared_variable (mp);
+ mp_flush_variable (mp, equiv_node (mp_sym_sym (p)), mp_link (p), true);
+ mp->warning_info_node = mp_find_variable (mp, p);
+ mp_flush_node_list (mp, p);
+ if (mp->warning_info_node == NULL) {
+ /* Change to `\.{a bad variable}' */
+ const char *hlp[] = {
+ "After `vardef a' you can\'t say `vardef a.b'.",
+ "So I'll have to discard this definition.",
+ NULL };
+ mp_error (mp, "This variable already starts with a macro", hlp, true);
+ mp->warning_info_node = mp->bad_vardef;
+ }
+ mp->scanner_status = var_defining;
+ n = 2;
+ if (cur_cmd() == mp_macro_special && cur_mod() == macro_suffix) { /* \.{\AT!\#} */
+ n = 3;
+ get_t_next (mp);
+ }
+ mp_type (mp->warning_info_node) = (quarterword) (mp_unsuffixed_macro - 2 + n);
+ /* |mp_suffixed_macro=mp_unsuffixed_macro+1| */
+ set_value_node (mp->warning_info_node, q);
+ }
+
+ k = n;
+ if (cur_cmd() == mp_left_delimiter) {
+ /* Absorb delimited parameters, putting them into lists |q| and |r| */
+ do {
+ l_delim = cur_sym();
+ r_delim = equiv_sym (cur_sym());
+ get_t_next (mp);
+ if ((cur_cmd() == mp_param_type) && (cur_mod() == mp_expr_param)) {
+ sym_type = mp_expr_sym;
+ } else if ((cur_cmd() == mp_param_type) && (cur_mod() == mp_suffix_param)) {
+ sym_type = mp_suffix_sym;
+ } else if ((cur_cmd() == mp_param_type) && (cur_mod() == mp_text_param)) {
+ sym_type = mp_text_sym;
+ } else {
+ const char *hlp[] = { "You should've had `expr' or `suffix' or `text' here.", NULL };
+ mp_back_error (mp, "Missing parameter type; `expr' will be assumed", hlp, true);
+ sym_type = mp_expr_sym;
+ }
+ /* Absorb parameter tokens for type |sym_type| */
+ do {
+ mp_link (q) = mp_get_symbolic_node (mp);
+ q = mp_link (q);
+ mp_name_type (q) = sym_type;
+ set_mp_sym_info (q, k);
+ mp_get_symbol (mp);
+ rp = xmalloc (1, sizeof (mp_subst_list_item));
+ rp->link = NULL;
+ rp->value_data = k;
+ rp->value_mod = sym_type;
+ rp->info = cur_sym();
+ rp->info_mod = cur_sym_mod();
+ mp_check_param_size (mp, k);
+ incr (k);
+ rp->link = r;
+ r = rp;
+ get_t_next (mp);
+ } while (cur_cmd() == mp_comma);
+
+ mp_check_delimiter (mp, l_delim, r_delim);
+ get_t_next (mp);
+ } while (cur_cmd() == mp_left_delimiter);
+
+ }
+ if (cur_cmd() == mp_param_type) {
+ /* Absorb undelimited parameters, putting them into list |r| */
+ rp = xmalloc (1, sizeof (mp_subst_list_item));
+ rp->link = NULL;
+ rp->value_data = k;
+ if (cur_mod() == mp_expr_param) {
+ rp->value_mod = mp_expr_sym;
+ c = mp_expr_macro;
+ } else if (cur_mod() == mp_suffix_param) {
+ rp->value_mod = mp_suffix_sym;
+ c = mp_suffix_macro;
+ } else if (cur_mod() == mp_text_param) {
+ rp->value_mod = mp_text_sym;
+ c = mp_text_macro;
+ } else {
+ c = cur_mod();
+ rp->value_mod = mp_expr_sym;
+ }
+ mp_check_param_size (mp, k);
+ incr (k);
+ mp_get_symbol (mp);
+ rp->info = cur_sym();
+ rp->info_mod = cur_sym_mod();
+ rp->link = r;
+ r = rp;
+ get_t_next (mp);
+ if (c == mp_expr_macro) {
+ if (cur_cmd() == mp_of_token) {
+ c = mp_of_macro;
+ rp = xmalloc (1, sizeof (mp_subst_list_item));
+ rp->link = NULL;
+ mp_check_param_size (mp, k);
+ rp->value_data = k;
+ rp->value_mod = mp_expr_sym;
+ mp_get_symbol (mp);
+ rp->info = cur_sym();
+ rp->info_mod = cur_sym_mod();
+ rp->link = r;
+ r = rp;
+ get_t_next (mp);
+ }
+ }
+ }
+ mp_check_equals (mp);
+ p = mp_get_symbolic_node (mp);
+ set_mp_sym_info (p, c);
+ mp_name_type (p) = mp_macro_sym;
+ mp_link (q) = p;
+ /* Attach the replacement text to the tail of node |p| */
+ /* We don't put `|mp->frozen_end_group|' into the replacement text of
+ a \&{vardef}, because the user may want to redefine `\.{endgroup}'. */
+ if (m == start_def) {
+ mp_link (p) = mp_scan_toks (mp, mp_macro_def, r, NULL, (quarterword) n);
+ } else {
+ mp_node qq = mp_get_symbolic_node (mp);
+ set_mp_sym_sym (qq, mp->bg_loc);
+ mp_link (p) = qq;
+ p = mp_get_symbolic_node (mp);
+ set_mp_sym_sym (p, mp->eg_loc);
+ mp_link (qq) = mp_scan_toks (mp, mp_macro_def, r, p, (quarterword) n);
+ }
+ if (mp->warning_info_node == mp->bad_vardef)
+ mp_flush_token_list (mp, value_node (mp->bad_vardef));
+ mp->scanner_status = normal;
+ mp_get_x_next (mp);
+}
+
+@ @<Glob...@>=
+mp_sym bg_loc;
+mp_sym eg_loc; /* hash addresses of `\.{begingroup}' and `\.{endgroup}' */
+
+@ @<Initialize table entries@>=
+mp->bad_vardef = mp_get_value_node (mp);
+mp_name_type (mp->bad_vardef) = mp_root;
+set_value_sym (mp->bad_vardef, mp->frozen_bad_vardef);
+
+@ @<Free table entries@>=
+mp_free_value_node (mp, mp->bad_vardef);
+
+
+@* 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|, |run_script|, |expand_after|, and |defined_macro|.
+
+\MP\ usually gets the next token of input by saying |get_x_next|. This is
+like |get_t_next| except that it keeps getting more tokens until
+finding |cur_cmd>=min_command|. In other words, |get_x_next| expands
+macros and removes conditionals or iterations or input instructions that
+might be present.
+
+It follows that |get_x_next| might invoke itself recursively. In fact,
+there is massive recursion, since macro expansion can involve the
+scanning of arbitrarily complex expressions, which in turn involve
+macro expansion and conditionals, etc.
+@^recursion@>
+
+Therefore it's necessary to declare a whole bunch of |forward|
+procedures at this point, and to insert some other procedures
+that will be invoked by |get_x_next|.
+
+@<Declarations@>=
+static void mp_scan_primary (MP mp);
+static void mp_scan_secondary (MP mp);
+static void mp_scan_tertiary (MP mp);
+static void mp_scan_expression (MP mp);
+static void mp_scan_suffix (MP mp);
+static void mp_pass_text (MP mp);
+static void mp_conditional (MP mp);
+static void mp_start_input (MP mp);
+static void mp_begin_iteration (MP mp);
+static void mp_resume_iteration (MP mp);
+static void mp_stop_iteration (MP mp);
+
+@ A recursion depth counter is used to discover infinite recursions.
+(Near) infinite recursion is a problem because it translates into
+C function calls that eat up the available call stack. A better solution
+would be to depend on signal trapping, but that is problematic when
+Metapost is used as a library.
+
+@<Global...@>=
+int expand_depth_count; /* current expansion depth */
+int expand_depth; /* current expansion depth */
+
+@ The limit is set at |10000|, which should be enough to allow
+normal usages of metapost while preventing the most obvious
+crashes on most all operating systems, but the value can be
+raised if the runtime system allows a larger C stack.
+@^system dependencies@>
+
+@<Set initial...@>=
+mp->expand_depth = 10000;
+
+@ Even better would be if the system allows discovery of the amount of
+space available on the call stack.
+@^system dependencies@>
+
+In any case, when the limit is crossed, that is a fatal error.
+
+@d check_expansion_depth() if (++mp->expand_depth_count >= mp->expand_depth)
+ mp_expansion_depth_error(mp)
+
+@c
+static void mp_expansion_depth_error (MP mp) {
+ const char *hlp[] = {
+ "Recursive macro expansion cannot be unlimited because of runtime",
+ "stack constraints. The limit is 10000 recursion levels in total.",
+ NULL };
+ if ( mp->interaction==mp_error_stop_mode )
+ mp->interaction=mp_scroll_mode; /* no more interaction */
+ if ( mp->log_opened )
+ mp_error(mp, "Maximum expansion depth reached", hlp, true);
+ mp->history=mp_fatal_error_stop;
+ mp_jump_out(mp);
+}
+
+
+@ An auxiliary subroutine called |expand| is used by |get_x_next|
+when it has to do exotic expansion commands.
+
+@c
+static void mp_expand (MP mp) {
+ size_t k; /* something that we hope is |<=buf_size| */
+ size_t j; /* index into |str_pool| */
+ check_expansion_depth();
+ if (number_greater (internal_value (mp_tracing_commands), unity_t))
+ if (cur_cmd() != mp_defined_macro)
+ show_cur_cmd_mod;
+ switch (cur_cmd()) {
+ case mp_if_test:
+ mp_conditional (mp); /* this procedure is discussed in Part 36 below */
+ break;
+ case mp_fi_or_else:
+ @<Terminate the current conditional and skip to \&{fi}@>;
+ break;
+ case mp_input:
+ @<Initiate or terminate input from a file@>;
+ break;
+ case mp_iteration:
+ if (cur_mod() == end_for) {
+ @<Scold the user for having an extra \&{endfor}@>;
+ } else {
+ mp_begin_iteration (mp); /* this procedure is discussed in Part 37 below */
+ }
+ break;
+ case mp_repeat_loop:
+ @<Repeat a loop@>;
+ break;
+ case mp_exit_test:
+ @<Exit a loop if the proper time has come@>;
+ break;
+ case mp_relax:
+ break;
+ case mp_expand_after:
+ @<Expand the token after the next token@>;
+ break;
+ case mp_scan_tokens:
+ @<Put a string into the input buffer@>;
+ break;
+ case mp_runscript:
+ @<Put a script result string into the input buffer@>;
+ break;
+ case mp_maketext:
+ @<Put a maketext result string into the input buffer@>;
+ break;
+ case mp_defined_macro:
+ mp_macro_call (mp, cur_mod_node(), NULL, cur_sym());
+ break;
+ default:
+ break; /* make the compiler happy */
+ }; /* there are no other cases */
+ mp->expand_depth_count--;
+}
+
+
+@ @<Scold the user...@>=
+{
+ const char *hlp[] = {
+ "I'm not currently working on a for loop,",
+ "so I had better not try to end anything.",
+ NULL };
+ mp_error (mp, "Extra `endfor'", hlp, true);
+@.Extra `endfor'@>;
+}
+
+
+@ The processing of \&{input} involves the |start_input| subroutine,
+which will be declared later; the processing of \&{endinput} is trivial.
+
+@<Put each...@>=
+mp_primitive (mp, "input", mp_input, 0);
+@:input_}{\&{input} primitive@>;
+mp_primitive (mp, "endinput", mp_input, 1);
+@:end_input_}{\&{endinput} primitive@>
+
+
+@ @<Cases of |print_cmd_mod|...@>=
+case mp_input:
+if (m == 0)
+ mp_print (mp, "input");
+else
+ mp_print (mp, "endinput");
+break;
+
+@ @<Initiate or terminate input...@>=
+if (cur_mod() > 0)
+ mp->force_eof = true;
+else
+ mp_start_input (mp)
+
+
+@ We'll discuss the complicated parts of loop operations later. For now
+it suffices to know that there's a global variable called |loop_ptr|
+that will be |NULL| if no loop is in progress.
+
+@<Repeat a loop@>=
+{
+ while (token_state && (nloc == NULL))
+ mp_end_token_list (mp); /* conserve stack space */
+ if (mp->loop_ptr == NULL) {
+ const char *hlp[] = {
+ "I'm confused; after exiting from a loop, I still seem",
+ "to want to repeat it. I'll try to forget the problem.",
+ NULL };
+ mp_error (mp, "Lost loop", hlp, true);
+@.Lost loop@>;
+ } else {
+ mp_resume_iteration (mp); /* this procedure is in Part 37 below */
+ }
+}
+
+
+@ @<Exit a loop if the proper time has come@>=
+{
+ mp_get_boolean (mp);
+ if (number_greater (internal_value (mp_tracing_commands), unity_t))
+ mp_show_cmd_mod (mp, mp_nullary, cur_exp_value_boolean ());
+ if (cur_exp_value_boolean () == mp_true_code) {
+ if (mp->loop_ptr == NULL) {
+ const char *hlp[] = {
+ "Why say `exitif' when there's nothing to exit from?",
+ NULL };
+ if (cur_cmd() == mp_semicolon)
+ mp_error (mp, "No loop is in progress", hlp, true);
+ else
+ mp_back_error (mp, "No loop is in progress", hlp, true);
+@.No loop is in progress@>;
+ } else {
+ @<Exit prematurely from an iteration@>;
+ }
+ } else if (cur_cmd() != mp_semicolon) {
+ const char *hlp[] = {
+ "After `exitif <boolean exp>' I expect to see a semicolon.",
+ "I shall pretend that one was there.",
+ NULL };
+ mp_back_error (mp, "Missing `;' has been inserted", hlp, true);
+@.Missing `;'@>;
+ }
+}
+
+
+@ Here we use the fact that |forever_text| is the only |token_type| that
+is less than |loop_text|.
+
+@<Exit prematurely...@>=
+{
+ mp_node p = NULL;
+ do {
+ if (file_state) {
+ mp_end_file_reading (mp);
+ } else {
+ if (token_type <= loop_text)
+ p = nstart;
+ mp_end_token_list (mp);
+ }
+ } while (p == NULL);
+ if (p != mp->loop_ptr->info)
+ mp_fatal_error (mp, "*** (loop confusion)");
+@.loop confusion@>;
+ mp_stop_iteration (mp); /* this procedure is in Part 34 below */
+}
+
+
+@ @<Expand the token after the next token@>=
+{
+ mp_node p;
+ get_t_next (mp);
+ p = mp_cur_tok (mp);
+ get_t_next (mp);
+ if (cur_cmd() < mp_min_command)
+ mp_expand (mp);
+ else
+ mp_back_input (mp);
+ back_list (p);
+}
+
+
+@ @<Put a string into the input buffer@>=
+{
+ mp_get_x_next (mp);
+ mp_scan_primary (mp);
+ if (mp->cur_exp.type != mp_string_type) {
+ mp_value new_expr;
+ const char *hlp[] = {
+ "I'm going to flush this expression, since",
+ "scantokens should be followed by a known string.",
+ NULL };
+ memset(&new_expr,0,sizeof(mp_value));
+ new_number(new_expr.data.n);
+ mp_disp_err (mp, NULL);
+ mp_back_error (mp, "Not a string", hlp, true);
+@.Not a string@>;
+ mp_get_x_next (mp);
+ mp_flush_cur_exp (mp, new_expr);
+ } else {
+ mp_back_input (mp);
+ if (cur_exp_str ()->len > 0)
+ @<Pretend we're reading a new one-line file@>;
+ }
+}
+
+@ @<Run a script@>=
+if (s != NULL) {
+ int k ;
+ mp_value new_expr;
+ size_t size = strlen(s);
+ memset(&new_expr,0,sizeof(mp_value));
+ new_number(new_expr.data.n);
+ mp_begin_file_reading (mp);
+ name = is_scantok;
+ mp->last = mp->first;
+ k = mp->first + size;
+ if (k >= mp->max_buf_stack) {
+ while (k >= mp->buf_size) {
+ mp_reallocate_buffer (mp, (mp->buf_size + (mp->buf_size / 4)));
+ }
+ mp->max_buf_stack = k + 1;
+ }
+ limit = (halfword) k;
+ (void) memcpy ((mp->buffer + mp->first), s, size);
+ mp->buffer[limit] = xord ('%');
+ mp->first = (size_t) (limit + 1);
+ loc = start;
+ mp_flush_cur_exp (mp, new_expr);
+}
+
+@ @<Put a script result string into the input buffer@>=
+{
+
+ if (mp->extensions == 0) {
+ return ;
+ }
+ mp_get_x_next (mp);
+ mp_scan_primary (mp);
+ if (mp->cur_exp.type != mp_string_type) {
+ mp_value new_expr;
+ const char *hlp[] = {
+ "I'm going to flush this expression, since",
+ "runscript should be followed by a known string.",
+ NULL };
+ memset(&new_expr,0,sizeof(mp_value));
+ new_number(new_expr.data.n);
+ mp_disp_err (mp, NULL);
+ mp_back_error (mp, "Not a string", hlp, true);
+ @.Not a string@>;
+ mp_get_x_next (mp);
+ mp_flush_cur_exp (mp, new_expr);
+ } else {
+ mp_back_input (mp);
+ if (cur_exp_str ()->len > 0) {
+ char *s = mp->run_script(mp,(const char*) cur_exp_str()->str) ;
+ @<Run a script@>
+ free(s);
+ }
+ }
+}
+
+@ The |texscriptmode| parameter controls how spaces and newlines get honoured in
+|btex| or |verbatimtex| ... |etex|. The default value is~1. Possible values are:
+0: no newlines, 1: newlines in |verbatimtex|, 2: newlines in |verbatimtex| and
+|etex|, 3: no leading and trailing strip in |verbatimtex|, 4: no leading and
+trailing strip in |verbatimtex| and |btex|. That way the Lua handler can do what
+it likes. An |etex| has to be followed by a space or |;| or be at the end of a
+line and preceded by a space or at the beginning of a line.
+
+@<Pass btex ... etex to script@>=
+{
+ char *txt = NULL;
+ char *ptr = NULL;
+ int slin = line;
+ int size = 0;
+ int done = 0;
+ int mode = round_unscaled(internal_value(mp_texscriptmode)) ; /* default: 1 */
+ int verb = cur_mod() == verbatim_code;
+ int first;
+ /* we had a (mandate) trailing space */
+ if (loc <= limit && mp->char_class[mp->buffer[loc]] == space_class) {
+ incr(loc);
+ } else {
+ /* maybe issue an error message and quit */
+ }
+ /* we loop over lines */
+ first = loc;
+ while (1) {
+ /* we don't need to check when we have less than 4 characters left */
+ if (loc < limit - 4) {
+ if (mp->buffer[loc] == 'e') {
+ incr(loc);
+ if (mp->buffer[loc] == 't') {
+ incr(loc) ;
+ if (mp->buffer[loc] == 'e') {
+ incr(loc) ;
+ if (mp->buffer[loc] == 'x') {
+ /* let's see if we have the right boundary */
+ if (first == (loc - 3)) {
+ /* when we're at the start of a line no leading space is required */
+ done = 1;
+ } else if (mp->char_class[mp->buffer[loc - 4]] == space_class) {
+ /* when we're beyond the start of a line a leading space is required */
+ done = 2;
+ }
+ if (done) {
+ if ((loc + 1) <= limit) {
+ quarterword c = mp->char_class[mp->buffer[loc + 1]] ;
+ if (c != letter_class) {
+ incr(loc) ;
+ /* we're past the 'x' */
+ break;
+ } else {
+ /* this is no valid etex */
+ done = 0;
+ }
+ } else {
+ /* when we're at the end of a line we're ok */
+ incr(loc) ;
+ /* we're past the 'x' */
+ break;
+ }
+ }
+ }
+ }
+ }
+ }
+ }
+ /* no etex seen (yet) */
+ if (loc >= limit) {
+ if (size) {
+ txt = realloc(txt, size + limit - first + 1);
+ } else {
+ txt = malloc(limit - first + 1);
+ }
+ (void) memcpy (txt + size, mp->buffer + first, limit - first);
+ size += limit - first + 1;
+ if (mode <= 0) {
+ txt[size - 1] = ' ';
+ } else if (verb) {
+ /* modes $\geq 1$ permit a newline in verbatimtex */
+ txt[size - 1] = '\n';
+ } else if (mode >= 2) {
+ /* modes $\geq 2$ permit a newline in btex */
+ txt[size - 1] = '\n';
+ } else {
+ txt[size - 1] = ' ';
+ }
+ if (move_to_next_line(mp)) {
+ /* we abort the scanning */
+ goto FATAL_ERROR;
+ }
+ first = loc;
+ } else {
+ incr(loc);
+ }
+ }
+ if (done) {
+ /* we're past the 'x' */
+ int l = loc - 5 ; // 4
+ int n = l - first + 1 ;
+ /* we're before the 'etex' */
+ if (done == 2) {
+ /* we had ' etex' */
+ l -= 1;
+ n -= 1;
+ /* we're before the ' etex' */
+ }
+ if (size) {
+ txt = realloc(txt, size + n + 1);
+ } else {
+ txt = malloc(n + 1);
+ }
+ (void) memcpy (txt + size, mp->buffer + first, n); /* 0 */
+ size += n;
+ if (verb && mode >= 3) {
+ /* don't strip verbatimtex */
+ txt[size] = '\0';
+ ptr = txt;
+ } else if (mode >= 4) {
+ /* don't strip btex */
+ txt[size] = '\0';
+ ptr = txt;
+ } else {
+ /* strip trailing whitespace, we have a |'\0'| so we are off by one */
+ /* |while ((size > 1) && (mp->char_class[(ASCII_code) txt[size-2]] == space_class| $\vbv\vbv$ |txt[size-2] == '\n')) | */
+ while ((size > 1) && (mp->char_class[(ASCII_code) txt[size-1]] == space_class || txt[size-1] == '\n')) {
+ decr(size);
+ }
+ /* prune the string */
+ txt[size] = '\0';
+ /* strip leading whitespace */
+ ptr = txt;
+ while ((size > 1) && (mp->char_class[(ASCII_code) ptr[0]] == space_class || ptr[0] == '\n')) {
+ incr(ptr);
+ decr(size);
+ }
+ }
+ /* action */
+ {
+ char *s = mp->make_text(mp,ptr,verb) ;
+ @<Run a script@>
+ free(s);
+ }
+ free(txt);
+ /* really needed */
+ mp_get_next(mp);
+ return;
+ }
+ /*
+ we don't recover because in practice the graphic will be broken anyway and
+ we're not really interacting in mplib .. just fix the input
+ */
+ FATAL_ERROR:
+ {
+ /* line numbers are not always meaningfull so we can get a 0 reported */
+ char msg[256];
+ const char *hlp[] = { "An 'etex' is missing at this input level, nothing gets done.", NULL };
+ if (slin > 0) {
+ mp_snprintf(msg, 256, "No matching 'etex' for '%stex'.", verb ? "verbatim" : "b");
+ } else {
+ mp_snprintf(msg, 256, "No matching 'etex' for '%stex' in line %d.", verb ? "verbatim" : "b",slin);
+ }
+ mp_error (mp, msg, hlp, false);
+ free(txt);
+ }
+}
+
+@ @<Put a maketext result string into the input buffer@>=
+{
+ if (mp->extensions == 0) {
+ return ;
+ }
+ mp_get_x_next (mp);
+ mp_scan_primary (mp);
+ if (mp->cur_exp.type != mp_string_type) {
+ mp_value new_expr;
+ const char *hlp[] = {
+ "I'm going to flush this expression, since",
+ "maketext should be followed by a known string.",
+ NULL };
+ memset(&new_expr,0,sizeof(mp_value));
+ new_number(new_expr.data.n);
+ mp_disp_err (mp, NULL);
+ mp_back_error (mp, "Not a string", hlp, true);
+ @.Not a string@>;
+ mp_get_x_next (mp);
+ mp_flush_cur_exp (mp, new_expr);
+ } else {
+ mp_back_input (mp);
+ if (cur_exp_str ()->len > 0) {
+ char *s = mp->make_text(mp,(const char*) cur_exp_str()->str,0) ;
+ @<Run a script@>
+ free(s);
+ }
+ }
+}
+
+@ @<Pretend we're reading a new one-line file@>=
+{
+ mp_value new_expr;
+ memset(&new_expr,0,sizeof(mp_value));
+ new_number(new_expr.data.n);
+ mp_begin_file_reading (mp);
+ name = is_scantok;
+ k = mp->first + (size_t) cur_exp_str ()->len;
+ if (k >= mp->max_buf_stack) {
+ while (k >= mp->buf_size) {
+ mp_reallocate_buffer (mp, (mp->buf_size + (mp->buf_size / 4)));
+ }
+ mp->max_buf_stack = k + 1;
+ }
+ j = 0;
+ limit = (halfword) k;
+ while (mp->first < (size_t) limit) {
+ mp->buffer[mp->first] = *(cur_exp_str ()->str + j);
+ j++;
+ incr (mp->first);
+ }
+ mp->buffer[limit] = xord ('%');
+ mp->first = (size_t) (limit + 1);
+ loc = start;
+ mp_flush_cur_exp (mp, new_expr);
+}
+
+
+@ Here finally is |get_x_next|.
+
+The expression scanning routines to be considered later
+communicate via the global quantities |cur_type| and |cur_exp|;
+we must be very careful to save and restore these quantities while
+macros are being expanded.
+@^inner loop@>
+
+@<Declarations@>=
+static void mp_get_x_next (MP mp);
+
+@ @c
+void mp_get_x_next (MP mp) {
+ mp_node save_exp; /* a capsule to save |cur_type| and |cur_exp| */
+ get_t_next (mp);
+ if (cur_cmd() < mp_min_command) {
+ save_exp = mp_stash_cur_exp (mp);
+ do {
+ if (cur_cmd() == mp_defined_macro)
+ mp_macro_call (mp, cur_mod_node(), NULL, cur_sym());
+ else
+ mp_expand (mp);
+ get_t_next (mp);
+ } while (cur_cmd() < mp_min_command);
+ mp_unstash_cur_exp (mp, save_exp); /* that restores |cur_type| and |cur_exp| */
+ }
+}
+
+
+@ Now let's consider the |macro_call| procedure, which is used to start up
+all user-defined macros. Since the arguments to a macro might be expressions,
+|macro_call| is recursive.
+@^recursion@>
+
+The first parameter to |macro_call| points to the reference count of the
+token list that defines the macro. The second parameter contains any
+arguments that have already been parsed (see below). The third parameter
+points to the symbolic token that names the macro. If the third parameter
+is |NULL|, the macro was defined by \&{vardef}, so its name can be
+reconstructed from the prefix and ``at'' arguments found within the
+second parameter.
+
+What is this second parameter? It's simply a linked list of symbolic items,
+whose |info| fields point to the arguments. In other words, if |arg_list=NULL|,
+no arguments have been scanned yet; otherwise |mp_info(arg_list)| points to
+the first scanned argument, and |mp_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.
+
+@<Declarations@>=
+static void mp_macro_call (MP mp, mp_node def_ref, mp_node arg_list,
+ mp_sym macro_name);
+
+@ @c
+void mp_macro_call (MP mp, mp_node def_ref, mp_node arg_list, mp_sym macro_name) {
+ /* invokes a user-defined control sequence */
+ mp_node r; /* current node in the macro's token list */
+ mp_node p, q; /* for list manipulation */
+ integer n; /* the number of arguments */
+ mp_node tail = 0; /* tail of the argument list */
+ mp_sym l_delim = NULL, r_delim = NULL; /* a delimiter pair */
+ r = mp_link (def_ref);
+ add_mac_ref (def_ref);
+ if (arg_list == NULL) {
+ n = 0;
+ } else {
+ @<Determine the number |n| of arguments already supplied,
+ and set |tail| to the tail of |arg_list|@>;
+ }
+ if (number_positive (internal_value (mp_tracing_macros))) {
+ @<Show the text of the macro being expanded, and the existing arguments@>;
+ }
+ @<Scan the remaining arguments, if any; set |r| to the first token
+ of the replacement text@>;
+ @<Feed the arguments and replacement text to the scanner@>;
+}
+
+
+@ @<Show the text of the macro...@>=
+mp_begin_diagnostic (mp);
+mp_print_ln (mp);
+mp_print_macro_name (mp, arg_list, macro_name);
+if (n == 3)
+ mp_print (mp, "@@#"); /* indicate a suffixed macro */
+mp_show_macro (mp, def_ref, NULL, 100000);
+if (arg_list != NULL) {
+ n = 0;
+ p = arg_list;
+ do {
+ q = (mp_node)mp_sym_sym (p);
+ mp_print_arg (mp, q, n, 0, 0);
+ incr (n);
+ p = mp_link (p);
+ } while (p != NULL);
+}
+mp_end_diagnostic (mp, false)
+
+
+@ @<Declarations@>=
+static void mp_print_macro_name (MP mp, mp_node a, mp_sym n);
+
+@ @c
+void mp_print_macro_name (MP mp, mp_node a, mp_sym n) {
+ mp_node p, q; /* they traverse the first part of |a| */
+ if (n != NULL) {
+ mp_print_text (n);
+ } else {
+ p = (mp_node)mp_sym_sym (a);
+ if (p == NULL) {
+ mp_print_text (mp_sym_sym ((mp_node)mp_sym_sym (mp_link (a))));
+ } else {
+ q = p;
+ while (mp_link (q) != NULL)
+ q = mp_link (q);
+ mp_link (q) = (mp_node)mp_sym_sym (mp_link (a));
+ mp_show_token_list (mp, p, NULL, 1000, 0);
+ mp_link (q) = NULL;
+ }
+ }
+}
+
+
+@ @<Declarations@>=
+static void mp_print_arg (MP mp, mp_node q, integer n, halfword b,
+ quarterword bb);
+
+@ @c
+void mp_print_arg (MP mp, mp_node q, integer n, halfword b, quarterword bb) {
+ if (q && mp_link (q) == MP_VOID) {
+ mp_print_nl (mp, "(EXPR");
+ } else {
+ if ((bb < mp_text_sym) && (b != mp_text_macro))
+ mp_print_nl (mp, "(SUFFIX");
+ else
+ mp_print_nl (mp, "(TEXT");
+ }
+ mp_print_int (mp, n);
+ mp_print (mp, ")<-");
+ if (q && mp_link (q) == MP_VOID)
+ mp_print_exp (mp, q, 1);
+ else
+ mp_show_token_list (mp, q, NULL, 1000, 0);
+}
+
+
+@ @<Determine the number |n| of arguments already supplied...@>=
+{
+ n = 1;
+ tail = arg_list;
+ while (mp_link (tail) != NULL) {
+ incr (n);
+ tail = mp_link (tail);
+ }
+}
+
+
+@ @<Scan the remaining arguments, if any; set |r|...@>=
+set_cur_cmd(mp_comma + 1); /* anything |<>comma| will do */
+while (mp_name_type (r) == mp_expr_sym ||
+ mp_name_type (r) == mp_suffix_sym || mp_name_type (r) == mp_text_sym) {
+ @<Scan the delimited argument represented by |mp_sym_info(r)|@>;
+ r = mp_link (r);
+}
+if (cur_cmd() == mp_comma) {
+ char msg[256];
+ const char *hlp[] = {
+ "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.",
+ NULL };
+ mp_string rname;
+ int old_setting = mp->selector;
+ mp->selector = new_string;
+ mp_print_macro_name (mp, arg_list, macro_name);
+ rname = mp_make_string(mp);
+ mp->selector = old_setting;
+ mp_snprintf (msg, 256, "Too many arguments to %s; Missing `%s' has been inserted",
+ mp_str(mp, rname), mp_str(mp, text(r_delim)));
+ delete_str_ref(rname);
+@.Too many arguments...@>;
+@.Missing `)'...@>;
+ mp_error (mp, msg, hlp, true);
+}
+if (mp_sym_info (r) != mp_general_macro) {
+ @<Scan undelimited argument(s)@>;
+}
+r = mp_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 |mp_sym_info(r)|@>=
+if (cur_cmd() != mp_comma) {
+ mp_get_x_next (mp);
+ if (cur_cmd() != mp_left_delimiter) {
+ char msg[256];
+ const char *hlp[] = {
+ "That macro has more parameters than you thought.",
+ "I'll continue by pretending that each missing argument",
+ "is either zero or null.",
+ NULL };
+ mp_string sname;
+ int old_setting = mp->selector;
+ mp->selector = new_string;
+ mp_print_macro_name (mp, arg_list, macro_name);
+ sname = mp_make_string(mp);
+ mp->selector = old_setting;
+ mp_snprintf (msg, 256, "Missing argument to %s", mp_str(mp, sname));
+@.Missing argument...@>;
+ delete_str_ref(sname);
+ if (mp_name_type (r) == mp_suffix_sym || mp_name_type (r) == mp_text_sym) {
+ set_cur_exp_value_number (zero_t); /* todo: this was |null| */
+ mp->cur_exp.type = mp_token_list;
+ } else {
+ set_cur_exp_value_number (zero_t);
+ mp->cur_exp.type = mp_known;
+ }
+ mp_back_error (mp, msg, hlp, true);
+ set_cur_cmd((mp_variable_type)mp_right_delimiter);
+ goto FOUND;
+ }
+ l_delim = cur_sym();
+ r_delim = equiv_sym (cur_sym());
+}
+@<Scan the argument represented by |mp_sym_info(r)|@>;
+if (cur_cmd() != mp_comma)
+ @<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() != mp_right_delimiter) || (equiv_sym (cur_sym()) != l_delim)) {
+ if (mp_name_type (mp_link (r)) == mp_expr_sym ||
+ mp_name_type (mp_link (r)) == mp_suffix_sym ||
+ mp_name_type (mp_link (r)) == mp_text_sym) {
+ const char *hlp[] = {
+ "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.",
+ NULL };
+ mp_back_error (mp, "Missing `,' has been inserted", hlp, true);
+@.Missing `,'@>;
+ set_cur_cmd((mp_variable_type)mp_comma);
+ } else {
+ char msg[256];
+ const char *hlp[] = {
+ "I've gotten to the end of the macro parameter list.",
+ "You might want to delete some tokens before continuing.",
+ NULL };
+ mp_snprintf(msg, 256, "Missing `%s' has been inserted", mp_str(mp, text(r_delim)));
+@.Missing `)'@>;
+ mp_back_error (mp, msg, hlp, true);
+ }
+}
+
+@ A \&{suffix} or \&{text} parameter will have been scanned as
+a token list pointed to by |cur_exp|, in which case we will have
+|cur_type=token_list|.
+
+@<Append the current expression to |arg_list|@>=
+{
+ p = mp_get_symbolic_node (mp);
+ if (mp->cur_exp.type == mp_token_list)
+ set_mp_sym_sym (p, mp->cur_exp.data.node);
+ else
+ set_mp_sym_sym (p, mp_stash_cur_exp (mp));
+ if (number_positive (internal_value (mp_tracing_macros))) {
+ mp_begin_diagnostic (mp);
+ mp_print_arg (mp, (mp_node)mp_sym_sym (p), n, mp_sym_info (r), mp_name_type (r));
+ mp_end_diagnostic (mp, false);
+ }
+ if (arg_list == NULL) {
+ arg_list = p;
+ } else {
+ mp_link (tail) = p;
+ }
+ tail = p;
+ incr (n);
+}
+
+
+@ @<Scan the argument represented by |mp_sym_info(r)|@>=
+if (mp_name_type (r) == mp_text_sym) {
+ mp_scan_text_arg (mp, l_delim, r_delim);
+} else {
+ mp_get_x_next (mp);
+ if (mp_name_type (r) == mp_suffix_sym)
+ mp_scan_suffix (mp);
+ else
+ mp_scan_expression (mp);
+}
+
+
+@ The parameters to |scan_text_arg| are either a pair of delimiters
+or zero; the latter case is for undelimited text arguments, which
+end with the first semicolon or \&{endgroup} or \&{end} that is not
+contained in a group.
+
+@<Declarations@>=
+static void mp_scan_text_arg (MP mp, mp_sym l_delim, mp_sym r_delim);
+
+@ @c
+void mp_scan_text_arg (MP mp, mp_sym l_delim, mp_sym r_delim) {
+ integer balance; /* excess of |l_delim| over |r_delim| */
+ mp_node p; /* list tail */
+ mp->warning_info = l_delim;
+ mp->scanner_status = absorbing;
+ p = mp->hold_head;
+ balance = 1;
+ mp_link (mp->hold_head) = NULL;
+ while (1) {
+ get_t_next (mp);
+ if (l_delim == NULL) {
+ @<Adjust the balance for an undelimited argument; |break| if done@>;
+ } else {
+ @<Adjust the balance for a delimited argument; |break| if done@>;
+ }
+ mp_link (p) = mp_cur_tok (mp);
+ p = mp_link (p);
+ }
+ set_cur_exp_node (mp_link (mp->hold_head));
+ mp->cur_exp.type = mp_token_list;
+ mp->scanner_status = normal;
+}
+
+
+@ @<Adjust the balance for a delimited argument...@>=
+if (cur_cmd() == mp_right_delimiter) {
+ if (equiv_sym (cur_sym()) == l_delim) {
+ decr (balance);
+ if (balance == 0)
+ break;
+ }
+} else if (cur_cmd() == mp_left_delimiter) {
+ if (equiv_sym (cur_sym()) == r_delim)
+ incr (balance);
+}
+
+@ @<Adjust the balance for an undelimited...@>=
+if (mp_end_of_statement) { /* |cur_cmd=semicolon|, |end_group|, or |stop| */
+ if (balance == 1) {
+ break;
+ } else {
+ if (cur_cmd() == mp_end_group)
+ decr (balance);
+ }
+} else if (cur_cmd() == mp_begin_group) {
+ incr (balance);
+}
+
+@ @<Scan undelimited argument(s)@>=
+{
+ if (mp_sym_info (r) < mp_text_macro) {
+ mp_get_x_next (mp);
+ if (mp_sym_info (r) != mp_suffix_macro) {
+ if ((cur_cmd() == mp_equals) || (cur_cmd() == mp_assignment))
+ mp_get_x_next (mp);
+ }
+ }
+ switch (mp_sym_info (r)) {
+ case mp_primary_macro:
+ mp_scan_primary (mp);
+ break;
+ case mp_secondary_macro:
+ mp_scan_secondary (mp);
+ break;
+ case mp_tertiary_macro:
+ mp_scan_tertiary (mp);
+ break;
+ case mp_expr_macro:
+ mp_scan_expression (mp);
+ break;
+ case mp_of_macro:
+ @<Scan an expression followed by `\&{of} $\langle$primary$\rangle$'@>;
+ break;
+ case mp_suffix_macro:
+ @<Scan a suffix with optional delimiters@>;
+ break;
+ case mp_text_macro:
+ mp_scan_text_arg (mp, NULL, NULL);
+ break;
+ } /* there are no other cases */
+ mp_back_input (mp);
+ @<Append the current expression to |arg_list|@>;
+}
+
+
+@ @<Scan an expression followed by `\&{of} $\langle$primary$\rangle$'@>=
+{
+ mp_scan_expression (mp);
+ p = mp_get_symbolic_node (mp);
+ set_mp_sym_sym (p, mp_stash_cur_exp (mp));
+ if (number_positive (internal_value (mp_tracing_macros))) {
+ mp_begin_diagnostic (mp);
+ mp_print_arg (mp, (mp_node)mp_sym_sym (p), n, 0, 0);
+ mp_end_diagnostic (mp, false);
+ }
+ if (arg_list == NULL)
+ arg_list = p;
+ else
+ mp_link (tail) = p;
+ tail = p;
+ incr (n);
+ if (cur_cmd() != mp_of_token) {
+ char msg[256];
+ mp_string sname;
+ const char *hlp[] = {
+ "I've got the first argument; will look now for the other.",
+ NULL };
+ int old_setting = mp->selector;
+ mp->selector = new_string;
+ mp_print_macro_name (mp, arg_list, macro_name);
+ sname = mp_make_string(mp);
+ mp->selector = old_setting;
+ mp_snprintf (msg, 256, "Missing `of' has been inserted for %s", mp_str(mp, sname));
+ delete_str_ref(sname);
+@.Missing `of'@>;
+ mp_back_error (mp, msg, hlp, true);
+ }
+ mp_get_x_next (mp);
+ mp_scan_primary (mp);
+}
+
+
+@ @<Scan a suffix with optional delimiters@>=
+{
+ if (cur_cmd() != mp_left_delimiter) {
+ l_delim = NULL;
+ } else {
+ l_delim = cur_sym();
+ r_delim = equiv_sym (cur_sym());
+ mp_get_x_next (mp);
+ }
+ mp_scan_suffix (mp);
+ if (l_delim != NULL) {
+ if ((cur_cmd() != mp_right_delimiter) || (equiv_sym (cur_sym()) != l_delim)) {
+ char msg[256];
+ const char *hlp[] = {
+ "I've gotten to the end of the macro parameter list.",
+ "You might want to delete some tokens before continuing.",
+ NULL };
+ mp_snprintf(msg, 256, "Missing `%s' has been inserted", mp_str (mp, text (r_delim)));
+@.Missing `)'@>;
+ mp_back_error (mp, msg, hlp, true);
+ }
+ mp_get_x_next (mp);
+ }
+}
+
+
+@ Before we put a new token list on the input stack, it is wise to clean off
+all token lists that have recently been depleted. Then a user macro that ends
+with a call to itself will not require unbounded stack space.
+
+@<Feed the arguments and replacement text to the scanner@>=
+while (token_state && (nloc == NULL))
+ mp_end_token_list (mp); /* conserve stack space */
+if (mp->param_ptr + n > mp->max_param_stack) {
+ mp->max_param_stack = mp->param_ptr + n;
+ mp_check_param_size (mp, mp->max_param_stack);
+@:MetaPost capacity exceeded parameter stack size}{\quad parameter stack size@>
+}
+mp_begin_token_list (mp, def_ref, (quarterword) macro);
+if (macro_name)
+ name = text (macro_name);
+else
+ name = NULL;
+nloc = r;
+if (n > 0) {
+ p = arg_list;
+ do {
+ mp->param_stack[mp->param_ptr] = (mp_node)mp_sym_sym (p);
+ incr (mp->param_ptr);
+ p = mp_link (p);
+ } while (p != NULL);
+ mp_flush_node_list (mp, arg_list);
+}
+
+@ It's sometimes necessary to put a single argument onto |param_stack|.
+The |stack_argument| subroutine does this.
+
+@c
+static void mp_stack_argument (MP mp, mp_node p) {
+ if (mp->param_ptr == mp->max_param_stack) {
+ incr (mp->max_param_stack);
+ mp_check_param_size (mp, mp->max_param_stack);
+ }
+ mp->param_stack[mp->param_ptr] = p;
+ incr (mp->param_ptr);
+}
+
+
+@* 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 non-symbolic 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_line_field(A) ((mp_if_node)(A))->if_line_field_
+@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} */
+
+@<MPlib internal header stuff@>=
+typedef struct mp_if_node_data {
+ NODE_BODY;
+ int if_line_field_;
+} mp_if_node_data;
+typedef struct mp_if_node_data *mp_if_node;
+
+@
+@d if_node_size sizeof(struct mp_if_node_data) /* number of words in stack entry for conditionals */
+
+@c
+static mp_node mp_get_if_node (MP mp) {
+ mp_if_node p = (mp_if_node) malloc_node (if_node_size);
+ mp_type (p) = mp_if_node_type;
+ return (mp_node) p;
+}
+
+
+@ @<Glob...@>=
+mp_node cond_ptr; /* top of the condition stack */
+integer if_limit; /* upper bound on |fi_or_else| codes */
+quarterword cur_if; /* type of conditional being worked on */
+integer if_line; /* line where that conditional began */
+
+@ @<Set init...@>=
+mp->cond_ptr = NULL;
+mp->if_limit = normal;
+mp->cur_if = 0;
+mp->if_line = 0;
+
+@ @<Put each...@>=
+mp_primitive (mp, "if", mp_if_test, if_code);
+@:if_}{\&{if} primitive@>;
+mp_primitive (mp, "fi", mp_fi_or_else, fi_code);
+mp->frozen_fi = mp_frozen_primitive (mp, "fi", mp_fi_or_else, fi_code);
+@:fi_}{\&{fi} primitive@>;
+mp_primitive (mp, "else", mp_fi_or_else, else_code);
+@:else_}{\&{else} primitive@>;
+mp_primitive (mp, "elseif", mp_fi_or_else, else_if_code);
+@:else_if_}{\&{elseif} primitive@>
+
+
+@ @<Cases of |print_cmd_mod|...@>=
+case mp_if_test:
+case mp_fi_or_else:
+switch (m) {
+case if_code:
+ mp_print (mp, "if");
+ break;
+case fi_code:
+ mp_print (mp, "fi");
+ break;
+case else_code:
+ mp_print (mp, "else");
+ break;
+default:
+ mp_print (mp, "elseif");
+ break;
+}
+break;
+
+@ Here is a procedure that ignores text until coming to an \&{elseif},
+\&{else}, or \&{fi} at level zero of $\&{if}\ldots\&{fi}$
+nesting. After it has acted, |cur_mod| will indicate the token that
+was found.
+
+\MP's smallest two command codes are |if_test| and |fi_or_else|; this
+makes the skipping process a bit simpler.
+
+@c
+void mp_pass_text (MP mp) {
+ integer l = 0;
+ mp->scanner_status = skipping;
+ mp->warning_line = mp_true_line (mp);
+ while (1) {
+ get_t_next (mp);
+ if (cur_cmd() <= mp_fi_or_else) {
+ if (cur_cmd() < mp_fi_or_else) {
+ incr (l);
+ } else {
+ if (l == 0)
+ break;
+ if (cur_mod() == fi_code)
+ decr (l);
+ }
+ } else {
+ @<Decrease the string reference count,
+ if the current token is a string@>;
+ }
+ }
+ mp->scanner_status = normal;
+}
+
+
+@ @<Decrease the string reference count...@>=
+if (cur_cmd() == mp_string_token) {
+ delete_str_ref (cur_mod_str());
+}
+
+@ When we begin to process a new \&{if}, we set |if_limit:=if_code|; then
+if \&{elseif} or \&{else} or \&{fi} occurs before the current \&{if}
+condition has been evaluated, a colon will be inserted.
+A construction like `\.{if fi}' would otherwise get \MP\ confused.
+
+@<Push the condition stack@>=
+{
+ p = mp_get_if_node (mp);
+ mp_link (p) = mp->cond_ptr;
+ mp_type (p) = (quarterword) mp->if_limit;
+ mp_name_type (p) = mp->cur_if;
+ if_line_field (p) = mp->if_line;
+ mp->cond_ptr = p;
+ mp->if_limit = if_code;
+ mp->if_line = mp_true_line (mp);
+ mp->cur_if = if_code;
+}
+
+
+@ @<Pop the condition stack@>=
+{
+ mp_node p = mp->cond_ptr;
+ mp->if_line = if_line_field (p);
+ mp->cur_if = mp_name_type (p);
+ mp->if_limit = mp_type (p);
+ mp->cond_ptr = mp_link (p);
+ mp_free_node (mp, p, if_node_size);
+}
+
+
+@ Here's a procedure that changes the |if_limit| code corresponding to
+a given value of |cond_ptr|.
+
+@c
+static void mp_change_if_limit (MP mp, quarterword l, mp_node p) {
+ mp_node q;
+ if (p == mp->cond_ptr) {
+ mp->if_limit = l; /* that's the easy case */
+ } else {
+ q = mp->cond_ptr;
+ while (1) {
+ if (q == NULL)
+ mp_confusion (mp, "if");
+@:this can't happen if}{\quad if@>;
+ /* clang: dereference of null pointer */ assert(q);
+ if (mp_link (q) == p) {
+ mp_type (q) = l;
+ return;
+ }
+ q = mp_link (q);
+ }
+ }
+}
+
+
+@ The user is supposed to put colons into the proper parts of conditional
+statements. Therefore, \MP\ has to check for their presence.
+
+@c
+static void mp_check_colon (MP mp) {
+ if (cur_cmd() != mp_colon) {
+ const char *hlp[] = {
+ "There should've been a colon after the condition.",
+ "I shall pretend that one was there.",
+ NULL };
+ mp_back_error (mp, "Missing `:' has been inserted", hlp, true);
+@.Missing `:'@>;
+ }
+}
+
+
+@ A condition is started when the |get_x_next| procedure encounters
+an |if_test| command; in that case |get_x_next| calls |conditional|,
+which is a recursive procedure.
+@^recursion@>
+
+@c
+void mp_conditional (MP mp) {
+ mp_node save_cond_ptr; /* |cond_ptr| corresponding to this conditional */
+ int new_if_limit; /* future value of |if_limit| */
+ mp_node p; /* temporary register */
+ @<Push the condition stack@>;
+ save_cond_ptr = mp->cond_ptr;
+RESWITCH:
+ mp_get_boolean (mp);
+ new_if_limit = else_if_code;
+ if (number_greater (internal_value (mp_tracing_commands), unity_t)) {
+ @<Display the boolean value of |cur_exp|@>;
+ }
+FOUND:
+ mp_check_colon (mp);
+ if (cur_exp_value_boolean () == mp_true_code) {
+ mp_change_if_limit (mp, (quarterword) new_if_limit, save_cond_ptr);
+ return; /* wait for \&{elseif}, \&{else}, or \&{fi} */
+ };
+ @<Skip to \&{elseif} or \&{else} or \&{fi}, then |goto done|@>;
+DONE:
+ mp->cur_if = (quarterword) cur_mod();
+ mp->if_line = mp_true_line (mp);
+ if (cur_mod() == fi_code) {
+ @<Pop the condition stack@>
+ } else if (cur_mod() == else_if_code) {
+ goto RESWITCH;
+ } else {
+ set_cur_exp_value_boolean (mp_true_code);
+ new_if_limit = fi_code;
+ mp_get_x_next (mp);
+ goto FOUND;
+ }
+}
+
+
+@ In a construction like `\&{if} \&{if} \&{true}: $0=1$: \\{foo}
+\&{else}: \\{bar} \&{fi}', the first \&{else}
+that we come to after learning that the \&{if} is false is not the
+\&{else} we're looking for. Hence the following curious logic is needed.
+
+@<Skip to \&{elseif}...@>=
+while (1) {
+ mp_pass_text (mp);
+ if (mp->cond_ptr == save_cond_ptr)
+ goto DONE;
+ else if (cur_mod() == fi_code)
+ @<Pop the condition stack@>;
+}
+
+
+@ @<Display the boolean value...@>=
+{
+ mp_begin_diagnostic (mp);
+ if (cur_exp_value_boolean () == mp_true_code)
+ mp_print (mp, "{true}");
+ else
+ mp_print (mp, "{false}");
+ mp_end_diagnostic (mp, false);
+}
+
+
+@ The processing of conditionals is complete except for the following
+code, which is actually part of |get_x_next|. It comes into play when
+\&{elseif}, \&{else}, or \&{fi} is scanned.
+
+@<Terminate the current conditional and skip to \&{fi}@>=
+if (cur_mod() > mp->if_limit) {
+ if (mp->if_limit == if_code) { /* condition not yet evaluated */
+ const char *hlp[] = { "Something was missing here", NULL };
+ mp_back_input (mp);
+ set_cur_sym(mp->frozen_colon);
+ mp_ins_error (mp, "Missing `:' has been inserted", hlp, true);
+@.Missing `:'@>;
+ } else {
+ const char *hlp[] = {"I'm ignoring this; it doesn't match any if.", NULL};
+ if (cur_mod() == fi_code) {
+ mp_error(mp, "Extra fi", hlp, true);
+@.Extra fi@>;
+ } else if (cur_mod() == else_code) {
+ mp_error(mp, "Extra else", hlp, true);
+@.Extra else@>
+ } else {
+ mp_error(mp, "Extra elseif", hlp, true);
+@.Extra elseif@>
+ }
+ }
+} else {
+ while (cur_mod() != fi_code)
+ mp_pass_text (mp); /* skip to \&{fi} */
+ @<Pop the condition stack@>;
+}
+
+
+@* 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 |loop_ptr.info| points to the iterative text of the current
+(innermost) loop, and |loop_ptr.link| points to the data for any other
+loops that enclose the current one.
+
+A loop-control node also has two other fields, called |type| and
+|list|, whose contents depend on the type of loop:
+
+\yskip\indent|loop_ptr.type=NULL| means that the link of |loop_ptr.list|
+points to a list of symbolic nodes whose |info| fields point to the
+remaining argument values of a suffix list and expression list.
+In this case, an extra field |loop_ptr.start_list| is needed to
+make sure that |resume_operation| skips ahead.
+
+\yskip\indent|loop_ptr.type=MP_VOID| means that the current loop is
+`\&{forever}'.
+
+\yskip\indent|loop_ptr.type=PROGRESSION_FLAG| means that
+|loop_ptr.value|, |loop_ptr.step_size|, and |loop_ptr.final_value|
+contain the data for an arithmetic progression.
+
+\yskip\indent|loop_ptr.type=p>PROGRESSION_FLAG| means that |p| points to an edge
+header and |loop_ptr.list| points into the graphical object list for
+that edge header.
+
+@d PROGRESSION_FLAG (mp_node)(2) /* |NULL+2| */
+ /* |loop_type| value when |loop_list| points to a progression node */
+
+@<Types...@>=
+typedef struct mp_loop_data {
+ mp_sym var ; /* the var of the loop */
+ mp_node info; /* iterative text of this loop */
+ mp_node type; /* the special type of this loop, or a pointer into
+ mem */
+ mp_node list; /* the remaining list elements */
+ mp_node list_start; /* head fo the list of elements */
+ mp_number old_value; /* previous value of current arithmetic value */
+ mp_number value; /* current arithmetic value */
+ mp_number step_size; /* arithmetic step size */
+ mp_number final_value; /* end arithmetic value */
+ struct mp_loop_data *link; /* the enclosing loop, if any */
+} mp_loop_data;
+
+@ @<Glob...@>=
+mp_loop_data *loop_ptr; /* top of the loop-control-node stack */
+
+@ @<Set init...@>=
+mp->loop_ptr = NULL;
+
+@ If the expressions that define an arithmetic progression in a
+\&{for} loop don't have known numeric values, the |bad_for| subroutine
+screams at the user.
+
+@c
+static void mp_bad_for (MP mp, const char *s) {
+ char msg[256];
+ mp_value new_expr;
+ const char *hlp[] = {"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.",
+ NULL };
+ memset(&new_expr,0,sizeof(mp_value));
+ new_number(new_expr.data.n);
+ mp_disp_err (mp, NULL);
+ /* show the bad expression above the message */
+ mp_snprintf(msg, 256, "Improper %s has been replaced by 0", s);
+@.Improper...replaced by 0@>;
+ mp_back_error (mp, msg, hlp, true);
+ mp_get_x_next (mp);
+ mp_flush_cur_exp (mp, new_expr);
+}
+
+
+@ Here's what \MP\ does when \&{for}, \&{forsuffixes}, or \&{forever}
+has just been scanned. (This code requires slight familiarity with
+expression-parsing routines that we have not yet discussed; but it
+seems to belong in the present part of the program, even though the
+original author didn't write it until later. The reader may wish to
+come back to it.)
+
+@c
+void mp_begin_iteration (MP mp) {
+ halfword m; /* |start_for| (\&{for}) or |start_forsuffixes|
+ (\&{forsuffixes}) */
+ mp_sym n; /* hash address of the current symbol */
+ mp_loop_data *s; /* the new loop-control node */
+ mp_subst_list_item *p = NULL; /* substitution list for |scan_toks|
+ */
+ mp_node q; /* link manipulation register */
+ m = cur_mod();
+ n = cur_sym();
+ s = xmalloc (1, sizeof (mp_loop_data));
+ s->type = s->list = s->info = s->list_start = NULL;
+ s->link = NULL; s->var = NULL;
+ new_number (s->value);new_number (s->old_value);
+ new_number (s->step_size);
+ new_number (s->final_value);
+ if (m == start_forever) {
+ s->type = MP_VOID;
+ p = NULL;
+ mp_get_x_next (mp);
+ } else {
+ mp_get_symbol (mp);
+ p = xmalloc (1, sizeof (mp_subst_list_item));
+ p->link = NULL;
+ p->info = cur_sym();
+ s->var = cur_sym();
+ p->info_mod = cur_sym_mod();
+ p->value_data = 0;
+ if (m == start_for) {
+ p->value_mod = mp_expr_sym;
+ } else { /* |start_forsuffixes| */
+ p->value_mod = mp_suffix_sym;
+ }
+ mp_get_x_next (mp);
+ if (cur_cmd() == mp_within_token) {
+ @<Set up a picture iteration@>;
+ } else {
+ @<Check for the assignment in a loop header@>;
+ @<Scan the values to be used in the loop@>;
+ }
+ }
+ @<Check for the presence of a colon@>;
+ @<Scan the loop text and put it on the loop control stack@>;
+ mp_resume_iteration (mp);
+}
+
+
+@ @<Check for the assignment in a loop header@>=
+if ((cur_cmd() != mp_equals) && (cur_cmd() != mp_assignment)) {
+ const char *hlp[] = {
+ "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.",
+ NULL };
+ mp_back_error (mp, "Missing `=' has been inserted", hlp, true);
+@.Missing `='@>;
+}
+
+@ @<Check for the presence of a colon@>=
+if (cur_cmd() != mp_colon) {
+ const char *hlp[] = {
+ "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.",
+ NULL };
+ mp_back_error (mp, "Missing `:' has been inserted", hlp, true);
+@.Missing `:'@>;
+}
+
+@ We append a special |mp->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
+|mp->frozen_repeat_loop| is an \&{outer} token, so it won't be lost
+accidentally.)
+
+@ @<Scan the loop text...@>=
+q = mp_get_symbolic_node (mp);
+set_mp_sym_sym (q, mp->frozen_repeat_loop);
+mp->scanner_status = loop_defining;
+mp->warning_info = n;
+s->info = mp_scan_toks (mp, mp_iteration, p, q, 0);
+mp->scanner_status = normal;
+s->link = mp->loop_ptr;
+mp->loop_ptr = s
+
+@ @<Initialize table...@>=
+mp->frozen_repeat_loop =
+mp_frozen_primitive (mp, " ENDFOR", mp_repeat_loop + mp_outer_tag, 0);
+
+@ The loop text is inserted into \MP's scanning apparatus by the
+|resume_iteration| routine.
+
+@c
+void mp_resume_iteration (MP mp) {
+ mp_node p, q; /* link registers */
+ p = mp->loop_ptr->type;
+ if (p == PROGRESSION_FLAG) {
+ set_cur_exp_value_number (mp->loop_ptr->value);
+ if (@<The arithmetic progression has ended@>) {
+ mp_stop_iteration (mp);
+ return;
+ }
+ mp->cur_exp.type = mp_known;
+ q = mp_stash_cur_exp (mp); /* make |q| an \&{expr} argument */
+ number_clone (mp->loop_ptr->old_value, cur_exp_value_number ());
+ set_number_from_addition (mp->loop_ptr->value, cur_exp_value_number (), mp->loop_ptr->step_size);
+ /* set |value(p)| for the next iteration */
+ /* detect numeric overflow */
+ if (number_positive(mp->loop_ptr->step_size) &&
+ number_less(mp->loop_ptr->value, cur_exp_value_number ())) {
+ if (number_positive(mp->loop_ptr->final_value)) {
+ number_clone (mp->loop_ptr->value, mp->loop_ptr->final_value);
+ number_add_scaled (mp->loop_ptr->final_value, -1);
+ } else {
+ number_clone (mp->loop_ptr->value, mp->loop_ptr->final_value);
+ number_add_scaled (mp->loop_ptr->value, 1);
+ }
+ } else if (number_negative(mp->loop_ptr->step_size) &&
+ number_greater (mp->loop_ptr->value, cur_exp_value_number ())) {
+ if (number_negative (mp->loop_ptr->final_value)) {
+ number_clone (mp->loop_ptr->value, mp->loop_ptr->final_value);
+ number_add_scaled (mp->loop_ptr->final_value, 1);
+ } else {
+ number_clone (mp->loop_ptr->value, mp->loop_ptr->final_value);
+ number_add_scaled (mp->loop_ptr->value, -1);
+ }
+ }
+ } else if (p == NULL) {
+ p = mp->loop_ptr->list;
+ if (p != NULL && p == mp->loop_ptr->list_start) {
+ q = p;
+ p = mp_link (p);
+ mp_free_symbolic_node (mp, q);
+ mp->loop_ptr->list = p;
+ }
+ if (p == NULL) {
+ mp_stop_iteration (mp);
+ return;
+ }
+ mp->loop_ptr->list = mp_link (p);
+ q = (mp_node)mp_sym_sym (p);
+ if (q)
+ number_clone (mp->loop_ptr->old_value, q->data.n);
+ mp_free_symbolic_node (mp, p);
+ } else if (p == MP_VOID) {
+ mp_begin_token_list (mp, mp->loop_ptr->info, (quarterword) forever_text);
+ return;
+ } else {
+ @<Make |q| a capsule containing the next picture component from
+ |loop_list(loop_ptr)| or |goto not_found|@>;
+ }
+ mp_begin_token_list (mp, mp->loop_ptr->info, (quarterword) loop_text);
+ mp_stack_argument (mp, q);
+ if (number_greater (internal_value (mp_tracing_commands), unity_t)) {
+ @<Trace the start of a loop@>;
+ }
+ return;
+NOT_FOUND:
+ mp_stop_iteration (mp);
+}
+
+
+@ @<The arithmetic progression has ended@>=
+(number_positive(mp->loop_ptr->step_size) && number_greater(cur_exp_value_number (), mp->loop_ptr->final_value))
+||
+(number_negative(mp->loop_ptr->step_size) && number_less(cur_exp_value_number (), mp->loop_ptr->final_value))
+
+
+@ @<Trace the start of a loop@>=
+{
+ mp_begin_diagnostic (mp);
+ mp_print_nl (mp, "{loop value=");
+@.loop value=n@>;
+ if ((q != NULL) && (mp_link (q) == MP_VOID))
+ mp_print_exp (mp, q, 1);
+ else
+ mp_show_token_list (mp, q, NULL, 50, 0);
+ mp_print_char (mp, xord ('}'));
+ mp_end_diagnostic (mp, false);
+}
+
+
+@ @<Make |q| a capsule containing the next picture component
+from...@>=
+{
+ q = mp->loop_ptr->list;
+ if (q == NULL)
+ goto NOT_FOUND;
+ if ( ! is_start_or_stop(q) )
+ q=mp_link(q);
+ else if ( ! is_stop(q) )
+ q=mp_skip_1component(mp, q);
+ else
+ goto NOT_FOUND;
+
+ set_cur_exp_node ((mp_node)mp_copy_objects (mp, mp->loop_ptr->list, q));
+ mp_init_bbox (mp, (mp_edge_header_node)cur_exp_node ());
+ mp->cur_exp.type = mp_picture_type;
+ mp->loop_ptr->list = q;
+ q = mp_stash_cur_exp (mp);
+}
+
+
+@ A level of loop control disappears when |resume_iteration| has
+decided not to resume, or when an \&{exitif} construction has removed
+the loop text from the input stack.
+
+@c
+void mp_stop_iteration (MP mp) {
+ mp_node p, q; /* the usual */
+ mp_loop_data *tmp; /* for free() */
+ p = mp->loop_ptr->type;
+ if (p == PROGRESSION_FLAG) {
+ mp_free_symbolic_node (mp, mp->loop_ptr->list);
+ } else if (p == NULL) {
+ q = mp->loop_ptr->list;
+ while (q != NULL) {
+ p = (mp_node)mp_sym_sym (q);
+ if (p != NULL) {
+ if (mp_link (p) == MP_VOID) { /* it's an \&{expr} parameter */
+ mp_recycle_value (mp, p);
+ mp_free_value_node (mp, p);
+ } else {
+ mp_flush_token_list (mp, p); /* it's a \&{suffix} or \&{text}
+ parameter */
+ }
+ }
+ p = q;
+ q = mp_link (q);
+ mp_free_symbolic_node (mp, p);
+ }
+ } else if (p > PROGRESSION_FLAG) {
+ delete_edge_ref (p);
+ }
+ tmp = mp->loop_ptr;
+ mp->loop_ptr = tmp->link;
+ mp_flush_token_list (mp, tmp->info);
+ free_number (tmp->value);
+ free_number (tmp->step_size);
+ free_number (tmp->final_value);
+ xfree (tmp);
+}
+
+
+@ 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=start_for|) or a \&{forsuffixes}
+construction (if |m=start_forsuffixes|).
+
+@<Scan the values to be used in the loop@>=
+s->type = NULL;
+s->list = mp_get_symbolic_node (mp);
+s->list_start = s->list;
+q = s->list;
+do {
+ mp_get_x_next (mp);
+ if (m != start_for) {
+ mp_scan_suffix (mp);
+ } else {
+ if (cur_cmd() >= mp_colon)
+ if (cur_cmd() <= mp_comma)
+ goto CONTINUE;
+ mp_scan_expression (mp);
+ if (cur_cmd() == mp_step_token)
+ if (q == s->list) {
+ @<Prepare for step-until construction and |break|@>;
+ }
+ set_cur_exp_node (mp_stash_cur_exp (mp));
+ }
+ mp_link (q) = mp_get_symbolic_node (mp);
+ q = mp_link (q);
+ set_mp_sym_sym (q, mp->cur_exp.data.node);
+ if (m == start_for)
+ mp_name_type (q) = mp_expr_sym;
+ else if (m == start_forsuffixes)
+ mp_name_type (q) = mp_suffix_sym;
+ mp->cur_exp.type = mp_vacuous;
+CONTINUE:
+ ;
+} while (cur_cmd() == mp_comma)
+
+@ @<Prepare for step-until construction and |break|@>=
+{
+ if (mp->cur_exp.type != mp_known)
+ mp_bad_for (mp, "initial value");
+ number_clone (s->value, cur_exp_value_number ());
+ number_clone (s->old_value, cur_exp_value_number ());
+ mp_get_x_next (mp);
+ mp_scan_expression (mp);
+ if (mp->cur_exp.type != mp_known)
+ mp_bad_for (mp, "step size");
+ number_clone (s->step_size, cur_exp_value_number ());
+ if (cur_cmd() != mp_until_token) {
+ const char *hlp[] = {
+ "I assume you meant to say `until' after `step'.",
+ "So I'll look for the final value and colon next.",
+ NULL };
+ mp_back_error (mp, "Missing `until' has been inserted", hlp, true);
+@.Missing `until'@>;
+ }
+ mp_get_x_next (mp);
+ mp_scan_expression (mp);
+ if (mp->cur_exp.type != mp_known)
+ mp_bad_for (mp, "final value");
+ number_clone (s->final_value, cur_exp_value_number ());
+ s->type = PROGRESSION_FLAG;
+ break;
+}
+
+
+@ The last case is when we have just seen ``\&{within}'', and we need to
+parse a picture expression and prepare to iterate over it.
+
+@<Set up a picture iteration@>=
+{
+ mp_get_x_next (mp);
+ mp_scan_expression (mp);
+ @<Make sure the current expression is a known picture@>;
+ s->type = mp->cur_exp.data.node;
+ mp->cur_exp.type = mp_vacuous;
+ q = mp_link (edge_list (mp->cur_exp.data.node));
+ if (q != NULL)
+ if (is_start_or_stop (q))
+ if (mp_skip_1component (mp, q) == NULL)
+ q = mp_link (q);
+ s->list = q;
+}
+
+
+@ @<Make sure the current expression is a known picture@>=
+if (mp->cur_exp.type != mp_picture_type) {
+ mp_value new_expr;
+ const char *hlp[] = { "When you say `for x in p', p must be a known picture.", NULL };
+ memset(&new_expr,0,sizeof(mp_value));
+ new_number(new_expr.data.n);
+ new_expr.data.node = (mp_node)mp_get_edge_header_node (mp);
+ mp_disp_err (mp, NULL);
+ mp_back_error (mp,"Improper iteration spec has been replaced by nullpicture", hlp, true);
+ mp_get_x_next (mp);
+ mp_flush_cur_exp (mp, new_expr);
+ mp_init_edges (mp, (mp_edge_header_node)mp->cur_exp.data.node);
+ mp->cur_exp.type = mp_picture_type;
+}
+
+@* 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.
+The file area can be arbitrary on input files, but files are usually
+output to the user's current area. If an input file cannot be
+found on the specified area, \MP\ will look for it on a special system
+area; this special area is intended for commonly used input files.
+
+Simple uses of \MP\ refer only to file names that have no explicit
+extension or area. For example, a person usually says `\.{input} \.{cmr10}'
+instead of `\.{input} \.{cmr10.new}'. Simple file
+names are best, because they make the \MP\ source files portable;
+whenever a file name consists entirely of letters and digits, it should be
+treated in the same way by all implementations of \MP. However, users
+need the ability to refer to other files in their environment, especially
+when responding to error messages concerning unopenable files; therefore
+we want to let them use the syntax that appears in their favorite
+operating system.
+
+@ \MP\ uses the same conventions that have proved to be satisfactory for
+\TeX\ and \MF. In order to isolate the system-dependent aspects of file names,
+@^system dependencies@>
+the system-independent parts of \MP\ are expressed in terms
+of three system-dependent
+procedures called |begin_name|, |more_name|, and |end_name|. In
+essence, if the user-specified characters of the file name are $c_1\ldots c_n$,
+the system-independent driver program does the operations
+$$|begin_name|;\,|more_name|(c_1);\,\ldots\,;\,|more_name|(c_n);
+\,|end_name|.$$
+These three procedures communicate with each other via global variables.
+Afterwards the file name will appear in the string pool as three strings
+called |cur_name|\penalty10000\hskip-.05em,
+|cur_area|, and |cur_ext|; the latter two are NULL (i.e.,
+|""|), unless they were explicitly specified by the user.
+
+Actually the situation is slightly more complicated, because \MP\ needs
+to know when the file name ends. The |more_name| routine is a function
+(with side effects) that returns |true| on the calls |more_name|$(c_1)$,
+\dots, |more_name|$(c_{n-1})$. The final call |more_name|$(c_n)$
+returns |false|; or, it returns |true| and $c_n$ is the last character
+on the current input line. In other words,
+|more_name| is supposed to return |true| unless it is sure that the
+file name has been completely scanned; and |end_name| is supposed to be able
+to finish the assembly of |cur_name|, |cur_area|, and |cur_ext| regardless of
+whether $|more_name|(c_n)$ returned |true| or |false|.
+
+@<Glob...@>=
+char *cur_name; /* name of file just scanned */
+char *cur_area; /* file area just scanned, or \.{""} */
+char *cur_ext; /* file extension just scanned, or \.{""} */
+
+@ It is easier to maintain reference counts if we assign initial values.
+
+@<Set init...@>=
+mp->cur_name = xstrdup ("");
+mp->cur_area = xstrdup ("");
+mp->cur_ext = xstrdup ("");
+
+@ @<Dealloc variables@>=
+xfree (mp->cur_area);
+xfree (mp->cur_name);
+xfree (mp->cur_ext);
+
+@ The file names we shall deal with for illustrative purposes have the
+following structure: If the name contains `\.>' or `\.:', the file area
+consists of all characters up to and including the final such character;
+otherwise the file area is null. If the remaining file name contains
+`\..', the file extension consists of all such characters from the first
+remaining `\..' to the end, otherwise the file extension is null.
+@^system dependencies@>
+
+We can scan such file names easily by using two global variables that keep track
+of the occurrences of area and extension delimiters.
+
+@<Glob...@>=
+integer area_delimiter;
+ /* most recent `\.>' or `\.:' relative to |str_start[str_ptr]| */
+integer ext_delimiter; /* the relevant `\..', if any */
+boolean quoted_filename; /* whether the filename is wrapped in " markers */
+
+@ Here now is the first of the system-dependent routines for file name scanning.
+@^system dependencies@>
+
+@<Declarations@>=
+static void mp_begin_name (MP mp);
+static boolean mp_more_name (MP mp, ASCII_code c);
+static void mp_end_name (MP mp);
+
+@ @c
+void mp_begin_name (MP mp) {
+ xfree (mp->cur_name);
+ xfree (mp->cur_area);
+ xfree (mp->cur_ext);
+ mp->area_delimiter = -1;
+ mp->ext_delimiter = -1;
+ mp->quoted_filename = false;
+}
+
+
+@ And here's the second.
+@^system dependencies@>
+
+@c
+#ifndef IS_DIR_SEP
+#define IS_DIR_SEP(c) (c=='/' || c=='\\')
+#endif
+boolean mp_more_name (MP mp, ASCII_code c) {
+ if (c == '"') {
+ mp->quoted_filename = !mp->quoted_filename;
+ } else if ((c == ' ' || c == '\t') && (mp->quoted_filename == false)) {
+ return false;
+ } else {
+ if (IS_DIR_SEP (c)) {
+ mp->area_delimiter = (integer) mp->cur_length;
+ mp->ext_delimiter = -1;
+ } else if (c == '.') {
+ mp->ext_delimiter = (integer) mp->cur_length;
+ }
+ append_char (c); /* contribute |c| to the current string */
+ }
+ return true;
+}
+
+
+@ The third.
+@^system dependencies@>
+
+@d copy_pool_segment(A,B,C) {
+ A = xmalloc(C+1,sizeof(char));
+ (void)memcpy(A,(char *)(mp->cur_string+B),C);
+ A[C] = 0;}
+
+@c
+void mp_end_name (MP mp) {
+ size_t s = 0; /* length of area, name, and extension */
+ size_t len;
+ /* "my/w.mp" */
+ if (mp->area_delimiter < 0) {
+ mp->cur_area = xstrdup ("");
+ } else {
+ len = (size_t) mp->area_delimiter - s + 1;
+ copy_pool_segment (mp->cur_area, s, len);
+ s += len;
+ }
+ if (mp->ext_delimiter < 0) {
+ mp->cur_ext = xstrdup ("");
+ len = (unsigned) (mp->cur_length - s);
+ } else {
+ copy_pool_segment (mp->cur_ext, mp->ext_delimiter,
+ (mp->cur_length - (size_t) mp->ext_delimiter));
+ len = (size_t) mp->ext_delimiter - s;
+ }
+ copy_pool_segment (mp->cur_name, s, len);
+ mp_reset_cur_string (mp);
+}
+
+
+@ 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...@>=
+static void mp_print_file_name (MP mp, char *n, char *a, char *e) {
+ boolean must_quote = false;
+ if (((a != NULL) && (strchr (a, ' ') != NULL)) ||
+ ((n != NULL) && (strchr (n, ' ') != NULL)) ||
+ ((e != NULL) && (strchr (e, ' ') != NULL)))
+ must_quote = true;
+ if (must_quote)
+ mp_print_char (mp, (ASCII_code) '"');
+ mp_print (mp, a);
+ mp_print (mp, n);
+ mp_print (mp, e);
+ if (must_quote)
+ mp_print_char (mp, (ASCII_code) '"');
+}
+
+
+@ Another system-dependent routine is needed to convert three internal
+\MP\ strings
+to the |name_of_file| value that is used to open files. The present code
+allows both lowercase and uppercase letters in the file name.
+@^system dependencies@>
+
+@d append_to_name(A) { mp->name_of_file[k++]=(char)xchr(xord((ASCII_code)(A))); }
+
+@ @c
+void mp_pack_file_name (MP mp, const char *n, const char *a, const char *e) {
+ integer k; /* number of positions filled in |name_of_file| */
+ const char *j; /* a character index */
+ size_t slen;
+ k = 0;
+ assert (n != NULL);
+ xfree (mp->name_of_file);
+ slen = strlen (n) + 1;
+ if (a != NULL)
+ slen += strlen (a);
+ if (e != NULL)
+ slen += strlen (e);
+ mp->name_of_file = xmalloc (slen, 1);
+ if (a != NULL) {
+ for (j = a; *j != '\0'; j++) {
+ append_to_name (*j);
+ }
+ }
+ for (j = n; *j != '\0'; j++) {
+ append_to_name (*j);
+ }
+ if (e != NULL) {
+ for (j = e; *j != '\0'; j++) {
+ append_to_name (*j);
+ }
+ }
+ mp->name_of_file[k] = 0;
+}
+
+
+@ @<Internal library declarations@>=
+void mp_pack_file_name (MP mp, const char *n, const char *a, const char *e);
+
+@ @<Option variables@>=
+char *mem_name; /* for commandline */
+
+@ Stripping a |.mem| extension here is for backward compatibility.
+
+@<Find and load preload file, if required@>=
+if (!opt->ini_version) {
+ mp->mem_name = xstrdup (opt->mem_name);
+ if (mp->mem_name) {
+ size_t l = strlen (mp->mem_name);
+ if (l > 4) {
+ char *test = strstr (mp->mem_name, ".mem");
+ if (test == mp->mem_name + l - 4) {
+ *test = 0;
+ }
+ }
+ }
+ if (mp->mem_name != NULL) {
+ if (!mp_open_mem_file (mp)) {
+ mp->history = mp_fatal_error_stop;
+ mp_jump_out (mp);
+ }
+ }
+}
+
+
+
+@ @<Dealloc variables@>=
+xfree (mp->mem_name);
+
+@ This part of the program becomes active when a ``virgin'' \MP\ is
+trying to get going, just after the preliminary initialization.
+The buffer contains the first line of input in |buffer[loc..(last-1)]|,
+where |loc<last| and |buffer[loc]<>""|.
+
+@<Declarations@>=
+static boolean mp_open_mem_name (MP mp);
+static boolean mp_open_mem_file (MP mp);
+
+@ @c
+boolean mp_open_mem_name (MP mp) {
+ if (mp->mem_name != NULL) {
+ size_t l = strlen (mp->mem_name);
+ char *s = xstrdup (mp->mem_name);
+ if (l > 4) {
+ char *test = strstr (s, ".mp");
+ if (test == NULL || test != s + l - 4) {
+ s = xrealloc (s, l + 5, 1);
+ strcat (s, ".mp");
+ }
+ } else {
+ s = xrealloc (s, l + 5, 1);
+ strcat (s, ".mp");
+ }
+ s = (mp->find_file) (mp, s, "r", mp_filetype_program);
+ xfree(mp->name_of_file);
+ if (s == NULL)
+ return false;
+ mp->name_of_file = xstrdup(s);
+ mp->mem_file = (mp->open_file) (mp, s, "r", mp_filetype_program);
+ free (s);
+ if (mp->mem_file)
+ return true;
+ }
+ return false;
+}
+boolean mp_open_mem_file (MP mp) {
+ if (mp->mem_file != NULL)
+ return true;
+ if (mp_open_mem_name (mp))
+ return true;
+ if (mp_xstrcmp (mp->mem_name, "plain")) {
+ wake_up_terminal();
+ wterm ("Sorry, I can\'t find the '");
+ wterm (mp->mem_name);
+ wterm ("' preload file; will try 'plain'.");
+ wterm_cr;
+@.Sorry, I can't find...@>;
+ update_terminal();
+ /* now pull out all the stops: try for the system \.{plain} file */
+ xfree (mp->mem_name);
+ mp->mem_name = xstrdup ("plain");
+ if (mp_open_mem_name (mp))
+ return true;
+ }
+ wake_up_terminal();
+ wterm_ln ("I can't find the 'plain' preload file!\n");
+@.I can't find PLAIN...@>
+@.plain@>;
+ return false;
+}
+
+
+@ Operating systems often make it possible to determine the exact name (and
+possible version number) of a file that has been opened. The following routine,
+which simply makes a \MP\ string from the value of |name_of_file|, should
+ideally be changed to deduce the full name of file~|f|, which is the file
+most recently opened, if it is possible to do this.
+@^system dependencies@>
+
+@ @c
+static mp_string mp_make_name_string (MP mp) {
+ int k; /* index into |name_of_file| */
+ int name_length = (int) strlen (mp->name_of_file);
+ str_room (name_length);
+ for (k = 0; k < name_length; k++) {
+ append_char (xord ((ASCII_code) mp->name_of_file[k]));
+ }
+ return mp_make_string (mp);
+}
+
+
+@ Now let's consider the ``driver''
+routines by which \MP\ deals with file names
+in a system-independent manner. First comes a procedure that looks for a
+file name in the input by taking the information from the input buffer.
+(We can't use |get_next|, because the conversion to tokens would
+destroy necessary information.)
+
+This procedure doesn't allow semicolons or percent signs to be part of
+file names, because of other conventions of \MP.
+{\sl The {\logos METAFONT\/}book} doesn't
+use semicolons or percents immediately after file names, but some users
+no doubt will find it natural to do so; therefore system-dependent
+changes to allow such characters in file names should probably
+be made with reluctance, and only when an entire file name that
+includes special characters is ``quoted'' somehow.
+@^system dependencies@>
+
+@c
+static void mp_scan_file_name (MP mp) {
+ mp_begin_name (mp);
+ while (mp->buffer[loc] == ' ')
+ incr (loc);
+ while (1) {
+ if ((mp->buffer[loc] == ';') || (mp->buffer[loc] == '%'))
+ break;
+ if (!mp_more_name (mp, mp->buffer[loc]))
+ break;
+ incr (loc);
+ }
+ mp_end_name (mp);
+}
+
+
+@ Here is another version that takes its input from a string.
+
+@<Declare subroutines for parsing file names@>=
+void mp_str_scan_file (MP mp, mp_string s);
+
+@ @c
+void mp_str_scan_file (MP mp, mp_string s) {
+ size_t p, q; /* current position and stopping point */
+ mp_begin_name (mp);
+ p = 0;
+ q = s->len;
+ while (p < q) {
+ if (!mp_more_name (mp, *(s->str + p)))
+ break;
+ incr (p);
+ }
+ mp_end_name (mp);
+}
+
+
+@ And one that reads from a |char*|.
+
+@<Declare subroutines for parsing file names@>=
+extern void mp_ptr_scan_file (MP mp, char *s);
+
+@ @c
+void mp_ptr_scan_file (MP mp, char *s) {
+ char *p, *q; /* current position and stopping point */
+ mp_begin_name (mp);
+ p = s;
+ q = p + strlen (s);
+ while (p < q) {
+ if (!mp_more_name (mp, (ASCII_code) (*p)))
+ break;
+ p++;
+ }
+ mp_end_name (mp);
+}
+
+
+@ The option variable |job_name| contains the file name that was first
+\&{input} by the user. This name is used to initialize the |job_name| global
+as well as the |mp_job_name| internal, and is extended by `\.{.log}' and
+`\.{ps}' and `\.{.mem}' and `\.{.tfm}' in order to make the names of \MP's
+output files.
+
+@<Glob...@>=
+boolean log_opened; /* has the transcript file been opened? */
+char *log_name; /* full name of the log file */
+
+@ @<Option variables@>=
+char *job_name; /* principal file name */
+
+@ Initially |job_name=NULL|; it becomes nonzero as soon as the true name is known.
+We have |job_name=NULL| if and only if the `\.{log}' file has not been opened,
+except of course for a short time just after |job_name| has become nonzero.
+
+@<Allocate or ...@>=
+mp->job_name = mp_xstrdup (mp, opt->job_name);
+/*|
+if (mp->job_name != NULL) {
+ char *s = mp->job_name + strlen (mp->job_name);
+ while (s > mp->job_name) {
+ if (*s == '.') {
+ *s = '\0';
+ }
+ s--;
+ }
+}
+|*/
+if (opt->noninteractive) {
+ if (mp->job_name == NULL)
+ mp->job_name = mp_xstrdup (mp, mp->mem_name);
+}
+mp->log_opened = false;
+
+@ Cannot do this earlier because at the |<Allocate or ...>|, the string
+pool is not yet initialized.
+
+@<Fix up |mp->internal[mp_job_name]|@>=
+if (mp->job_name != NULL) {
+ if (internal_string (mp_job_name) != 0)
+ delete_str_ref (internal_string (mp_job_name));
+ set_internal_string (mp_job_name, mp_rts (mp, mp->job_name));
+}
+
+@ @<Dealloc variables@>=
+xfree (mp->job_name);
+
+@ Here is a routine that manufactures the output file names, assuming that
+|job_name<>0|. It ignores and changes the current settings of |cur_area|
+and |cur_ext|.
+
+@d pack_cur_name mp_pack_file_name(mp, mp->cur_name,mp->cur_area,mp->cur_ext)
+
+@<Internal library ...@>=
+void mp_pack_job_name (MP mp, const char *s);
+
+@ @c
+void mp_pack_job_name (MP mp, const char *s) { /* |s = ".log"|, |".mem"|, |".ps"|, or .\\{nnn} */
+ xfree (mp->cur_name);
+ mp->cur_name = xstrdup (mp->job_name);
+ xfree (mp->cur_area);
+ mp->cur_area = xstrdup ("");
+ xfree (mp->cur_ext);
+ mp->cur_ext = xstrdup (s);
+ pack_cur_name;
+}
+
+
+@ If some trouble arises when \MP\ tries to open a file, the following
+routine calls upon the user to supply another file name. Parameter~|s|
+is used in the error message to identify the type of file; parameter~|e|
+is the default extension if none is given. Upon exit from the routine,
+variables |cur_name|, |cur_area|, |cur_ext|, and |name_of_file| are
+ready for another attempt at file opening.
+
+@<Internal library ...@>=
+void mp_prompt_file_name (MP mp, const char *s, const char *e);
+
+@ @c
+void mp_prompt_file_name (MP mp, const char *s, const char *e) {
+ size_t k; /* index into |buffer| */
+ char *saved_cur_name;
+ if (mp->interaction == mp_scroll_mode)
+ wake_up_terminal();
+ if (strcmp (s, "input file name") == 0) {
+ mp_print_err (mp, "I can\'t open file `");
+@.I can't find file x@>
+ } else {
+ mp_print_err (mp, "I can\'t write on file `");
+@.I can't write on file x@>
+ }
+ if (strcmp (s, "file name for output") == 0) {
+ mp_print (mp, mp->name_of_file);
+ } else {
+ mp_print_file_name (mp, mp->cur_name, mp->cur_area, mp->cur_ext);
+ }
+ mp_print (mp, "'.");
+ if (strcmp (e, "") == 0)
+ mp_show_context (mp);
+ mp_print_nl (mp, "Please type another ");
+ mp_print (mp, s);
+@.Please type...@>;
+ if (mp->noninteractive || mp->interaction < mp_scroll_mode)
+ mp_fatal_error (mp, "*** (job aborted, file error in nonstop mode)");
+@.job aborted, file error...@>;
+ saved_cur_name = xstrdup (mp->cur_name);
+ clear_terminal();
+ prompt_input (": ");
+ @<Scan file name in the buffer@>;
+ if (strcmp (mp->cur_ext, "") == 0)
+ mp->cur_ext = xstrdup (e);
+ if (strlen (mp->cur_name) == 0) {
+ mp->cur_name = saved_cur_name;
+ } else {
+ xfree (saved_cur_name);
+ }
+ pack_cur_name;
+}
+
+
+@ @<Scan file name in the buffer@>=
+{
+ mp_begin_name (mp);
+ k = mp->first;
+ while ((mp->buffer[k] == ' ') && (k < mp->last))
+ incr (k);
+ while (1) {
+ if (k == mp->last)
+ break;
+ if (!mp_more_name (mp, mp->buffer[k]))
+ break;
+ incr (k);
+ }
+ mp_end_name (mp);
+}
+
+
+@ The |open_log_file| routine is used to open the transcript file and to help
+it catch up to what has previously been printed on the terminal.
+
+@c
+void mp_open_log_file (MP mp) {
+ unsigned old_setting; /* previous |selector| setting */
+ int k; /* index into |months| and |buffer| */
+ int l; /* end of first input line */
+ integer m; /* the current month */
+ const char *months = "JANFEBMARAPRMAYJUNJULAUGSEPOCTNOVDEC";
+ /* abbreviations of month names */
+ if (mp->log_opened)
+ return;
+ old_setting = mp->selector;
+ if (mp->job_name == NULL) {
+ mp->job_name = xstrdup ("mpout");
+ @<Fix up |mp->internal[mp_job_name]|@>;
+ }
+ mp_pack_job_name (mp, ".log");
+ while (!mp_open_out (mp, &mp->log_file, mp_filetype_log)) {
+ @<Try to get a different log file name@>;
+ }
+ mp->log_name = xstrdup (mp->name_of_file);
+ mp->selector = log_only;
+ mp->log_opened = true;
+ @<Print the banner line, including the date and time@>;
+ mp->input_stack[mp->input_ptr] = mp->cur_input;
+ /* make sure bottom level is in memory */
+ if (!mp->noninteractive) {
+ mp_print_nl (mp, "**");
+@.**@>;
+ l = mp->input_stack[0].limit_field - 1; /* last position of first line */
+ for (k = 0; k <= l; k++)
+ mp_print_char (mp, mp->buffer[k]);
+ mp_print_ln (mp); /* now the transcript file contains the first line of input */
+ }
+ mp->selector = old_setting + 2; /* |log_only| or |term_and_log| */
+}
+
+
+@ @<Dealloc variables@>=
+xfree (mp->log_name);
+
+@ Sometimes |open_log_file| is called at awkward moments when \MP\ is
+unable to print error messages or even to |show_context|.
+The |prompt_file_name| routine can result in a |fatal_error|, but the |error|
+routine will not be invoked because |log_opened| will be false.
+
+The normal idea of |mp_batch_mode| is that nothing at all should be written
+on the terminal. However, in the unusual case that
+no log file could be opened, we make an exception and allow
+an explanatory message to be seen.
+
+Incidentally, the program always refers to the log file as a `\.{transcript
+file}', because some systems cannot use the extension `\.{.log}' for
+this file.
+
+@<Try to get a different log file name@>=
+{
+ mp->selector = term_only;
+ mp_prompt_file_name (mp, "transcript file name", ".log");
+}
+
+
+@ @<Print the banner...@>=
+{
+ wlog (mp->banner);
+ mp_print (mp, " ");
+ mp_print_int (mp, round_unscaled (internal_value (mp_day)));
+ mp_print_char (mp, xord (' '));
+ m = round_unscaled (internal_value (mp_month));
+ for (k = 3 * m - 3; k < 3 * m; k++) {
+ wlog_chr ((unsigned char) months[k]);
+ }
+ mp_print_char (mp, xord (' '));
+ mp_print_int (mp, round_unscaled (internal_value (mp_year)));
+ mp_print_char (mp, xord (' '));
+ mp_print_dd (mp, round_unscaled (internal_value (mp_hour)));
+ mp_print_char (mp, xord (':'));
+ mp_print_dd (mp, round_unscaled (internal_value (mp_minute)));
+}
+
+
+@ The |try_extension| function tries to open an input file determined by
+|cur_name|, |cur_area|, and the argument |ext|. It returns |false| if it
+can't find the file in |cur_area| or the appropriate system area.
+
+@c
+static boolean mp_try_extension (MP mp, const char *ext) {
+ mp_pack_file_name (mp, mp->cur_name, mp->cur_area, ext);
+ in_name = xstrdup (mp->cur_name);
+ in_area = xstrdup (mp->cur_area);
+ in_ext = xstrdup (ext);
+ if (mp_open_in (mp, &cur_file, mp_filetype_program)) {
+ return true;
+ } else {
+ mp_pack_file_name (mp, mp->cur_name, NULL, ext);
+ return mp_open_in (mp, &cur_file, mp_filetype_program);
+ }
+}
+
+
+@ Let's turn now to the procedure that is used to initiate file reading
+when an `\.{input}' command is being processed.
+
+@c
+void mp_start_input (MP mp) { /* \MP\ will \.{input} something */
+ char *fname = NULL;
+ @<Put the desired file name in |(cur_name,cur_ext,cur_area)|@>;
+ while (1) {
+ mp_begin_file_reading (mp); /* set up |cur_file| and new level of input */
+ if (strlen (mp->cur_ext) == 0) {
+ if (mp_try_extension (mp, ".mp"))
+ break;
+ else if (mp_try_extension (mp, ""))
+ break;
+ else if (mp_try_extension (mp, ".mf"))
+ break;
+ } else if (mp_try_extension (mp, mp->cur_ext)) {
+ break;
+ }
+ mp_end_file_reading (mp); /* remove the level that didn't work */
+ mp_prompt_file_name (mp, "input file name", "");
+ }
+ name = mp_make_name_string (mp);
+ fname = xstrdup (mp->name_of_file);
+ if (mp->job_name == NULL) {
+ mp->job_name = xstrdup (mp->cur_name);
+ @<Fix up |mp->internal[mp_job_name]|@>;
+ }
+ if (!mp->log_opened) {
+ mp_open_log_file (mp);
+ } /* |open_log_file| doesn't |show_context|, so |limit|
+ and |loc| needn't be set to meaningful values yet */
+ if (((int) mp->term_offset + (int) strlen (fname)) > (mp->max_print_line - 2))
+ mp_print_ln (mp);
+ else if ((mp->term_offset > 0) || (mp->file_offset > 0))
+ mp_print_char (mp, xord (' '));
+ mp_print_char (mp, xord ('('));
+ incr (mp->open_parens);
+ mp_print (mp, fname);
+ xfree (fname);
+ update_terminal();
+ @<Flush |name| and replace it with |cur_name| if it won't be needed@>;
+ @<Read the first line of the new file@>;
+}
+
+
+@ This code should be omitted if |make_name_string| returns something other
+than just a copy of its argument and the full file name is needed for opening
+\.{MPX} files or implementing the switch-to-editor option.
+@^system dependencies@>
+
+@<Flush |name| and replace it with |cur_name| if it won't be needed@>=
+mp_flush_string (mp, name);
+name = mp_rts (mp, mp->cur_name);
+xfree (mp->cur_name)
+
+
+@ If the file is empty, it is considered to contain a single blank line,
+so there is no need to test the return value.
+
+@<Read the first line...@>=
+{
+ line = 1;
+ (void) mp_input_ln (mp, cur_file);
+ mp_firm_up_the_line (mp);
+ mp->buffer[limit] = xord ('%');
+ mp->first = (size_t) (limit + 1);
+ loc = start;
+}
+
+
+@ @<Put the desired file name in |(cur_name,cur_ext,cur_area)|@>=
+while (token_state && (nloc == NULL))
+ mp_end_token_list (mp);
+if (token_state) {
+ const char *hlp[] = {
+ "Sorry...I've converted what follows to tokens,",
+ "possibly garbaging the name you gave.",
+ "Please delete the tokens and insert the name again.",
+ NULL };
+ mp_error (mp, "File names can't appear within macros", hlp, true);
+@.File names can't...@>;
+}
+if (file_state) {
+ mp_scan_file_name (mp);
+} else {
+ xfree (mp->cur_name);
+ mp->cur_name = xstrdup ("");
+ xfree (mp->cur_ext);
+ mp->cur_ext = xstrdup ("");
+ xfree (mp->cur_area);
+ mp->cur_area = xstrdup ("");
+}
+
+
+@ The following simple routine starts reading the \.{MPX} file associated
+with the current input file.
+
+@c
+void mp_start_mpx_input (MP mp) {
+ char *origname = NULL; /* a copy of nameoffile */
+ mp_pack_file_name (mp, in_name, in_area, in_ext);
+ origname = xstrdup (mp->name_of_file);
+ mp_pack_file_name (mp, in_name, in_area, ".mpx");
+ if (!(mp->run_make_mpx) (mp, origname, mp->name_of_file))
+ goto NOT_FOUND;
+ mp_begin_file_reading (mp);
+ if (!mp_open_in (mp, &cur_file, mp_filetype_program)) {
+ mp_end_file_reading (mp);
+ goto NOT_FOUND;
+ }
+ name = mp_make_name_string (mp);
+ mp->mpx_name[iindex] = name;
+ add_str_ref (name);
+ @<Read the first line of the new file@>;
+ xfree (origname);
+ return;
+NOT_FOUND:
+ @<Explain that the \.{MPX} file can't be read and |succumb|@>;
+ xfree (origname);
+}
+
+
+@ This should ideally be changed to do whatever is necessary to create the
+\.{MPX} file given by |name_of_file| if it does not exist or if it is out
+of date. This requires invoking \.{MPtoTeX} on the |origname| and passing
+the results through \TeX\ and \.{DVItoMP}. (It is possible to use a
+completely different typesetting program if suitable postprocessor is
+available to perform the function of \.{DVItoMP}.)
+@^system dependencies@>
+
+@ @<Exported types@>=
+typedef int (*mp_makempx_cmd) (MP mp, char *origname, char *mtxname);
+
+@ @<Option variables@>=
+mp_makempx_cmd run_make_mpx;
+
+@ @<Allocate or initialize ...@>=
+set_callback_option (run_make_mpx);
+
+@ @<Declarations@>=
+static int mp_run_make_mpx (MP mp, char *origname, char *mtxname);
+
+@ The default does nothing.
+@c
+int mp_run_make_mpx (MP mp, char *origname, char *mtxname) {
+ (void) mp;
+ (void) origname;
+ (void) mtxname;
+ return false;
+}
+
+
+@ @<Explain that the \.{MPX} file can't be read and |succumb|@>=
+{
+ const char *hlp[] = {
+ "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",
+ NULL };
+ if (mp->interaction == mp_error_stop_mode)
+ wake_up_terminal();
+ mp_print_nl (mp, ">> ");
+ mp_print (mp, origname);
+ mp_print_nl (mp, ">> ");
+ mp_print (mp, mp->name_of_file);
+ xfree (origname);
+ if ( mp->interaction==mp_error_stop_mode )
+ mp->interaction=mp_scroll_mode; /* no more interaction */
+ if ( mp->log_opened )
+ mp_error(mp, "! Unable to read mpx file", hlp, true);
+ mp->history=mp_fatal_error_stop;
+ mp_jump_out(mp); /* irrecoverable error */
+}
+
+@ The last file-opening commands are for files accessed via the \&{readfrom}
+@:read_from_}{\&{readfrom} primitive@>
+operator and the \&{write} command. Such files are stored in separate arrays.
+@:write_}{\&{write} primitive@>
+
+@<Types in the outer block@>=
+typedef unsigned int readf_index; /* |0..max_read_files| */
+typedef unsigned int write_index; /* |0..max_write_files| */
+
+@ @<Glob...@>=
+readf_index max_read_files; /* maximum number of simultaneously open \&{readfrom} files */
+void **rd_file; /* \&{readfrom} files */
+char **rd_fname; /* corresponding file name or 0 if file not open */
+readf_index read_files; /* number of valid entries in the above arrays */
+write_index max_write_files; /* maximum number of simultaneously open \&{write} */
+void **wr_file; /* \&{write} files */
+char **wr_fname; /* corresponding file name or 0 if file not open */
+write_index write_files; /* number of valid entries in the above arrays */
+
+@ @<Allocate or initialize ...@>=
+mp->max_read_files = 8;
+mp->rd_file = xmalloc ((mp->max_read_files + 1), sizeof (void *));
+mp->rd_fname = xmalloc ((mp->max_read_files + 1), sizeof (char *));
+memset (mp->rd_fname, 0, sizeof (char *) * (mp->max_read_files + 1));
+mp->max_write_files = 8;
+mp->wr_file = xmalloc ((mp->max_write_files + 1), sizeof (void *));
+mp->wr_fname = xmalloc ((mp->max_write_files + 1), sizeof (char *));
+memset (mp->wr_fname, 0, sizeof (char *) * (mp->max_write_files + 1));
+
+
+@ This routine starts reading the file named by string~|s| without setting
+|loc|, |limit|, or |name|. It returns |false| if the file is empty or cannot
+be opened. Otherwise it updates |rd_file[n]| and |rd_fname[n]|.
+
+@c
+static boolean mp_start_read_input (MP mp, char *s, readf_index n) {
+ mp_ptr_scan_file (mp, s);
+ pack_cur_name;
+ mp_begin_file_reading (mp);
+ if (!mp_open_in (mp, &mp->rd_file[n], (int) (mp_filetype_text + n)))
+ goto NOT_FOUND;
+ if (!mp_input_ln (mp, mp->rd_file[n])) {
+ (mp->close_file) (mp, mp->rd_file[n]);
+ goto NOT_FOUND;
+ }
+ mp->rd_fname[n] = xstrdup (s);
+ return true;
+NOT_FOUND:
+ mp_end_file_reading (mp);
+ return false;
+}
+
+
+@ Open |wr_file[n]| using file name~|s| and update |wr_fname[n]|.
+
+@<Declarations@>=
+static void mp_open_write_file (MP mp, char *s, readf_index n);
+
+@ @c
+void mp_open_write_file (MP mp, char *s, readf_index n) {
+ mp_ptr_scan_file (mp, s);
+ pack_cur_name;
+ while (!mp_open_out (mp, &mp->wr_file[n], (int) (mp_filetype_text + n)))
+ mp_prompt_file_name (mp, "file name for write output", "");
+ mp->wr_fname[n] = xstrdup (s);
+}
+
+
+@* 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.
+
+@d cur_exp_value_boolean() number_to_int (mp->cur_exp.data.n)
+@d cur_exp_value_number() mp->cur_exp.data.n
+@d cur_exp_node() mp->cur_exp.data.node
+@d cur_exp_str() mp->cur_exp.data.str
+@d cur_exp_knot() mp->cur_exp.data.p
+
+@d set_cur_exp_value_scaled(A) do {
+ if (cur_exp_str()) {
+ delete_str_ref(cur_exp_str());
+ }
+ set_number_from_scaled (mp->cur_exp.data.n, (A));
+ cur_exp_node() = NULL;
+ cur_exp_str() = NULL;
+ cur_exp_knot() = NULL;
+ } while (0)
+@d set_cur_exp_value_boolean(A) do {
+ if (cur_exp_str()) {
+ delete_str_ref(cur_exp_str());
+ }
+ set_number_from_int (mp->cur_exp.data.n, (A));
+ cur_exp_node() = NULL;
+ cur_exp_str() = NULL;
+ cur_exp_knot() = NULL;
+ } while (0)
+@d set_cur_exp_value_number(A) do {
+ if (cur_exp_str()) {
+ delete_str_ref(cur_exp_str());
+ }
+ number_clone (mp->cur_exp.data.n, (A));
+ cur_exp_node() = NULL;
+ cur_exp_str() = NULL;
+ cur_exp_knot() = NULL;
+ } while (0)
+@d set_cur_exp_node(A) do {
+ if (cur_exp_str()) {
+ delete_str_ref(cur_exp_str());
+ }
+ cur_exp_node() = A;
+ cur_exp_str() = NULL;
+ cur_exp_knot() = NULL;
+ set_number_to_zero (mp->cur_exp.data.n);
+ } while (0)
+@d set_cur_exp_str(A) do {
+ if (cur_exp_str()) {
+ delete_str_ref(cur_exp_str());
+ }
+ cur_exp_str() = A;
+ add_str_ref(cur_exp_str());
+ cur_exp_node() = NULL;
+ cur_exp_knot() = NULL;
+ set_number_to_zero (mp->cur_exp.data.n);
+ } while (0)
+@d set_cur_exp_knot(A) do {
+ if (cur_exp_str()) {
+ delete_str_ref(cur_exp_str());
+ }
+ cur_exp_knot() = A;
+ cur_exp_node() = NULL;
+ cur_exp_str() = NULL;
+ set_number_to_zero (mp->cur_exp.data.n);
+ } while (0)
+
+
+@ @<Glob...@>=
+mp_value cur_exp; /* the value of the expression just found */
+
+@ @<Set init...@>=
+memset (&mp->cur_exp.data, 0, sizeof (mp_value));
+new_number(mp->cur_exp.data.n);
+
+@ @<Free table ...@>=
+free_number(mp->cur_exp.data.n);
+
+@ Many different kinds of expressions are possible, so it is wise to have
+precise descriptions of what |cur_type| and |cur_exp| mean in all cases:
+
+\smallskip\hang
+|cur_type=mp_vacuous| means that this expression didn't turn out to have a
+value at all, because it arose from a \&{begingroup}$\,\ldots\,$\&{endgroup}
+construction in which there was no expression before the \&{endgroup}.
+In this case |cur_exp| has some irrelevant value.
+
+\smallskip\hang
+|cur_type=mp_boolean_type| means that |cur_exp| is either |true_code|
+or |false_code|.
+
+\smallskip\hang
+|cur_type=mp_unknown_boolean| means that |cur_exp| points to a capsule
+node that is in
+a ring of equivalent booleans whose value has not yet been defined.
+
+\smallskip\hang
+|cur_type=mp_string_type| means that |cur_exp| is a string number (i.e., an
+integer in the range |0<=cur_exp<str_ptr|). That string's reference count
+includes this particular reference.
+
+\smallskip\hang
+|cur_type=mp_unknown_string| means that |cur_exp| points to a capsule
+node that is in
+a ring of equivalent strings whose value has not yet been defined.
+
+\smallskip\hang
+|cur_type=mp_pen_type| means that |cur_exp| points to a node in a pen. Nobody
+else points to any of the nodes in this pen. The pen may be polygonal or
+elliptical.
+
+\smallskip\hang
+|cur_type=mp_unknown_pen| means that |cur_exp| points to a capsule
+node that is in
+a ring of equivalent pens whose value has not yet been defined.
+
+\smallskip\hang
+|cur_type=mp_path_type| means that |cur_exp| points to a the first node of
+a path; nobody else points to this particular path. The control points of
+the path will have been chosen.
+
+\smallskip\hang
+|cur_type=mp_unknown_path| means that |cur_exp| points to a capsule
+node that is in
+a ring of equivalent paths whose value has not yet been defined.
+
+\smallskip\hang
+|cur_type=mp_picture_type| means that |cur_exp| points to an edge header node.
+There may be other pointers to this particular set of edges. The header node
+contains a reference count that includes this particular reference.
+
+\smallskip\hang
+|cur_type=mp_unknown_picture| means that |cur_exp| points to a capsule
+node that is in
+a ring of equivalent pictures whose value has not yet been defined.
+
+\smallskip\hang
+|cur_type=mp_transform_type| means that |cur_exp| points to a |mp_transform_type|
+capsule node. The |value| part of this capsule
+points to a transform node that contains six numeric values,
+each of which is |independent|, |dependent|, |mp_proto_dependent|, or |known|.
+
+\smallskip\hang
+|cur_type=mp_color_type| means that |cur_exp| points to a |color_type|
+capsule node. The |value| part of this capsule
+points to a color node that contains three numeric values,
+each of which is |independent|, |dependent|, |mp_proto_dependent|, or |known|.
+
+\smallskip\hang
+|cur_type=mp_cmykcolor_type| means that |cur_exp| points to a |mp_cmykcolor_type|
+capsule node. The |value| part of this capsule
+points to a color node that contains four numeric values,
+each of which is |independent|, |dependent|, |mp_proto_dependent|, or |known|.
+
+\smallskip\hang
+|cur_type=mp_pair_type| means that |cur_exp| points to a capsule
+node whose type is |mp_pair_type|. The |value| part of this capsule
+points to a pair node that contains two numeric values,
+each of which is |independent|, |dependent|, |mp_proto_dependent|, or |known|.
+
+\smallskip\hang
+|cur_type=mp_known| means that |cur_exp| is a |scaled| value.
+
+\smallskip\hang
+|cur_type=mp_dependent| means that |cur_exp| points to a capsule node whose type
+is |dependent|. The |dep_list| field in this capsule points to the associated
+dependency list.
+
+\smallskip\hang
+|cur_type=mp_proto_dependent| means that |cur_exp| points to a |mp_proto_dependent|
+capsule node. The |dep_list| field in this capsule
+points to the associated dependency list.
+
+\smallskip\hang
+|cur_type=independent| means that |cur_exp| points to a capsule node
+whose type is |independent|. This somewhat unusual case can arise, for
+example, in the expression
+`$x+\&{begingroup}\penalty0\,\&{string}\,x; 0\,\&{endgroup}$'.
+
+\smallskip\hang
+|cur_type=mp_token_list| means that |cur_exp| points to a linked list of
+tokens.
+
+\smallskip\noindent
+The possible settings of |cur_type| have been listed here in increasing
+numerical order. Notice that |cur_type| will never be |mp_numeric_type| or
+|suffixed_macro| or |mp_unsuffixed_macro|, although variables of those types
+are allowed. Conversely, \MP\ has no variables of type |mp_vacuous| or
+|token_list|.
+
+@ Capsules are non-symbolic nodes that have a similar meaning
+to |cur_type| and |cur_exp|. Such nodes have |name_type=capsule|,
+and their |type| field is one of the possibilities for |cur_type| listed above.
+Also |link<=void| in capsules that aren't part of a token list.
+
+The |value| field of a capsule is, in most cases, the value that
+corresponds to its |type|, as |cur_exp| corresponds to |cur_type|.
+However, when |cur_exp| would point to a capsule,
+no extra layer of indirection is present; the |value|
+field is what would have been called |value(cur_exp)| if it had not been
+encapsulated. Furthermore, if the type is |dependent| or
+|mp_proto_dependent|, the |value| field of a capsule is replaced by
+|dep_list| and |prev_dep| fields, since dependency lists in capsules are
+always part of the general |dep_list| structure.
+
+The |get_x_next| routine is careful not to change the values of |cur_type|
+and |cur_exp| when it gets an expanded token. However, |get_x_next| might
+call a macro, which might parse an expression, which might execute lots of
+commands in a group; hence it's possible that |cur_type| might change
+from, say, |mp_unknown_boolean| to |mp_boolean_type|, or from |dependent| to
+|known| or |independent|, during the time |get_x_next| is called. The
+programs below are careful to stash sensitive intermediate results in
+capsules, so that \MP's generality doesn't cause trouble.
+
+Here's a procedure that illustrates these conventions. It takes
+the contents of $(|cur_type|\kern-.3pt,|cur_exp|\kern-.3pt)$
+and stashes them away in a
+capsule. It is not used when |cur_type=mp_token_list|.
+After the operation, |cur_type=mp_vacuous|; hence there is no need to
+copy path lists or to update reference counts, etc.
+
+The special link |MP_VOID| is put on the capsule returned by
+|stash_cur_exp|, because this procedure is used to store macro parameters
+that must be easily distinguishable from token lists.
+
+@<Declare the stashing/unstashing routines@>=
+static mp_node mp_stash_cur_exp (MP mp) {
+ mp_node p; /* the capsule that will be returned */
+ mp_variable_type exp_type = mp->cur_exp.type;
+ switch (exp_type) {
+ case unknown_types:
+ case mp_transform_type:
+ case mp_color_type:
+ case mp_pair_type:
+ case mp_dependent:
+ case mp_proto_dependent:
+ case mp_independent:
+ case mp_cmykcolor_type:
+ p = cur_exp_node ();
+ break;
+ /* |case mp_path_type: case mp_pen_type: case mp_string_type:| */
+ default:
+ p = mp_get_value_node (mp);
+ mp_name_type (p) = mp_capsule;
+ mp_type (p) = mp->cur_exp.type;
+ set_value_number (p, cur_exp_value_number ()); /* this also resets the rest to 0/NULL */
+ if (cur_exp_str ()) {
+ set_value_str (p, cur_exp_str ());
+ } else if (cur_exp_knot ()) {
+ set_value_knot (p, cur_exp_knot ());
+ } else if (cur_exp_node ()) {
+ set_value_node (p, cur_exp_node ());
+ }
+ break;
+ }
+ mp->cur_exp.type = mp_vacuous;
+ mp_link (p) = MP_VOID;
+ return p;
+}
+
+
+@ The inverse of |stash_cur_exp| is the following procedure, which
+deletes an unnecessary capsule and puts its contents into |cur_type|
+and |cur_exp|.
+
+The program steps of \MP\ can be divided into two categories: those in
+which |cur_type| and |cur_exp| are ``alive'' and those in which they are
+``dead,'' in the sense that |cur_type| and |cur_exp| contain relevant
+information or not. It's important not to ignore them when they're alive,
+and it's important not to pay attention to them when they're dead.
+
+There's also an intermediate category: If |cur_type=mp_vacuous|, then
+|cur_exp| is irrelevant, hence we can proceed without caring if |cur_type|
+and |cur_exp| are alive or dead. In such cases we say that |cur_type|
+and |cur_exp| are {\sl dormant}. It is permissible to call |get_x_next|
+only when they are alive or dormant.
+
+The \\{stash} procedure above assumes that |cur_type| and |cur_exp|
+are alive or dormant. The \\{unstash} procedure assumes that they are
+dead or dormant; it resuscitates them.
+
+@<Declare the stashing/unstashing...@>=
+static void mp_unstash_cur_exp (MP mp, mp_node p);
+
+@ @c
+void mp_unstash_cur_exp (MP mp, mp_node p) {
+ mp->cur_exp.type = mp_type (p);
+ switch (mp->cur_exp.type) {
+ case unknown_types:
+ case mp_transform_type:
+ case mp_color_type:
+ case mp_pair_type:
+ case mp_dependent:
+ case mp_proto_dependent:
+ case mp_independent:
+ case mp_cmykcolor_type:
+ set_cur_exp_node (p);
+ break;
+ case mp_token_list: /* this is how symbols are stashed */
+ set_cur_exp_node (value_node(p));
+ mp_free_value_node (mp, p);
+ break;
+ case mp_path_type:
+ case mp_pen_type:
+ set_cur_exp_knot (value_knot (p));
+ mp_free_value_node (mp, p);
+ break;
+ case mp_string_type:
+ set_cur_exp_str (value_str (p));
+ mp_free_value_node (mp, p);
+ break;
+ case mp_picture_type:
+ set_cur_exp_node (value_node (p));
+ mp_free_value_node (mp, p);
+ break;
+ case mp_boolean_type:
+ case mp_known:
+ set_cur_exp_value_number (value_number (p));
+ mp_free_value_node (mp, p);
+ break;
+ default:
+ set_cur_exp_value_number (value_number (p));
+ if (value_knot(p)) {
+ set_cur_exp_knot (value_knot (p));
+ } else if (value_node(p)) {
+ set_cur_exp_node (value_node (p));
+ } else if (value_str(p)) {
+ set_cur_exp_str (value_str (p));
+ }
+ mp_free_value_node (mp, p);
+ break;
+ }
+}
+
+
+@ The following procedure prints the values of expressions in an
+abbreviated format. If its first parameter |p| is NULL, the value of
+|(cur_type,cur_exp)| is displayed; otherwise |p| should be a capsule
+containing the desired value. The second parameter controls the amount of
+output. If it is~0, dependency lists will be abbreviated to
+`\.{linearform}' unless they consist of a single term. If it is greater
+than~1, complicated structures (pens, pictures, and paths) will be displayed
+in full.
+@.linearform@>
+
+@<Declarations@>=
+@<Declare the procedure called |print_dp|@>;
+@<Declare the stashing/unstashing routines@>;
+static void mp_print_exp (MP mp, mp_node p, quarterword verbosity);
+
+@ @c
+void mp_print_exp (MP mp, mp_node p, quarterword verbosity) {
+ boolean restore_cur_exp; /* should |cur_exp| be restored? */
+ mp_variable_type t; /* the type of the expression */
+ mp_number vv; /* the value of the expression */
+ mp_node v = NULL;
+ new_number (vv);
+ if (p != NULL) {
+ restore_cur_exp = false;
+ } else {
+ p = mp_stash_cur_exp (mp);
+ restore_cur_exp = true;
+ }
+ t = mp_type (p);
+ if (t < mp_dependent) { /* no dep list, could be a capsule */
+ if (t != mp_vacuous && t != mp_known && value_node (p) != NULL)
+ v = value_node (p);
+ else
+ number_clone (vv, value_number (p));
+ } else if (t < mp_independent) {
+ v = (mp_node) dep_list ((mp_value_node) p);
+ }
+ @<Print an abbreviated value of |v| or |vv| with format depending on |t|@>;
+ if (restore_cur_exp)
+ mp_unstash_cur_exp (mp, p);
+ free_number (vv);
+}
+
+
+@ @<Print an abbreviated value of |v| or |vv| with format depending on |t|@>=
+switch (t) {
+case mp_vacuous:
+ mp_print (mp, "vacuous");
+ break;
+case mp_boolean_type:
+ if (number_to_boolean (vv) == mp_true_code)
+ mp_print (mp, "true");
+ else
+ mp_print (mp, "false");
+ break;
+case unknown_types:
+case mp_numeric_type:
+ @<Display a variable that's been declared but not defined@>;
+ break;
+case mp_string_type:
+ mp_print_char (mp, xord ('"'));
+ mp_print_str (mp, value_str (p));
+ mp_print_char (mp, xord ('"'));
+ break;
+case mp_pen_type:
+case mp_path_type:
+case mp_picture_type:
+ @<Display a complex type@>;
+ break;
+case mp_transform_type:
+ if (number_zero (vv) && v == NULL)
+ mp_print_type (mp, t);
+ else
+ @<Display a transform node@>;
+ break;
+case mp_color_type:
+ if (number_zero (vv) && v == NULL)
+ mp_print_type (mp, t);
+ else
+ @<Display a color node@>;
+ break;
+case mp_pair_type:
+ if (number_zero (vv) && v == NULL)
+ mp_print_type (mp, t);
+ else
+ @<Display a pair node@>;
+ break;
+case mp_cmykcolor_type:
+ if (number_zero (vv) && v == NULL)
+ mp_print_type (mp, t);
+ else
+ @<Display a cmykcolor node@>;
+ break;
+case mp_known:
+ print_number (vv);
+ break;
+case mp_dependent:
+case mp_proto_dependent:
+ mp_print_dp (mp, t, (mp_value_node) v, verbosity);
+ break;
+case mp_independent:
+ mp_print_variable_name (mp, p);
+ break;
+default:
+ mp_confusion (mp, "exp");
+ break;
+@:this can't happen exp}{\quad exp@>
+}
+
+
+@ @<Display big node item |v|@>=
+{
+ if (mp_type (v) == mp_known)
+ print_number (value_number (v));
+ else if (mp_type (v) == mp_independent)
+ mp_print_variable_name (mp, v);
+ else
+ mp_print_dp (mp, mp_type (v), (mp_value_node) dep_list ((mp_value_node) v),
+ verbosity);
+}
+
+
+@ In these cases, |v| starts as the big node.
+
+@<Display a pair node@>=
+{
+ mp_node vvv = v;
+ mp_print_char (mp, xord ('('));
+ /* clang: dereference of null pointer */ assert(vvv);
+ v = x_part (vvv);
+ @<Display big node item |v|@>;
+ mp_print_char (mp, xord (','));
+ v = y_part (vvv);
+ @<Display big node item |v|@>;
+ mp_print_char (mp, xord (')'));
+}
+
+
+@ @<Display a transform node@>=
+{
+ mp_node vvv = v;
+ mp_print_char (mp, xord ('('));
+ /* clang: dereference of null pointer */ assert(vvv);
+ v = tx_part (vvv);
+ @<Display big node item |v|@>;
+ mp_print_char (mp, xord (','));
+ v = ty_part (vvv);
+ @<Display big node item |v|@>;
+ mp_print_char (mp, xord (','));
+ v = xx_part (vvv);
+ @<Display big node item |v|@>;
+ mp_print_char (mp, xord (','));
+ v = xy_part (vvv);
+ @<Display big node item |v|@>;
+ mp_print_char (mp, xord (','));
+ v = yx_part (vvv);
+ @<Display big node item |v|@>;
+ mp_print_char (mp, xord (','));
+ v = yy_part (vvv);
+ @<Display big node item |v|@>;
+ mp_print_char (mp, xord (')'));
+}
+
+
+@ @<Display a color node@>=
+{
+ mp_node vvv = v;
+ mp_print_char (mp, xord ('('));
+ /* clang: dereference of null pointer */ assert(vvv);
+ v = red_part (vvv);
+ @<Display big node item |v|@>;
+ mp_print_char (mp, xord (','));
+ v = green_part (vvv);
+ @<Display big node item |v|@>;
+ mp_print_char (mp, xord (','));
+ v = blue_part (vvv);
+ @<Display big node item |v|@>;
+ mp_print_char (mp, xord (')'));
+}
+
+
+@ @<Display a cmykcolor node@>=
+{
+ mp_node vvv = v;
+ mp_print_char (mp, xord ('('));
+ /* clang: dereference of null pointer */ assert(vvv);
+ v = cyan_part (vvv);
+ @<Display big node item |v|@>;
+ mp_print_char (mp, xord (','));
+ v = magenta_part (vvv);
+ @<Display big node item |v|@>;
+ mp_print_char (mp, xord (','));
+ v = yellow_part (vvv);
+ @<Display big node item |v|@>;
+ mp_print_char (mp, xord (','));
+ v = black_part (vvv);
+ @<Display big node item |v|@>;
+ mp_print_char (mp, xord (')'));
+}
+
+
+@ Values of type \&{picture}, \&{path}, and \&{pen} are displayed verbosely
+in the log file only, unless the user has given a positive value to
+\\{tracingonline}.
+
+@<Display a complex type@>=
+if (verbosity <= 1) {
+ mp_print_type (mp, t);
+} else {
+ if (mp->selector == term_and_log)
+ if (number_nonpositive (internal_value (mp_tracing_online))) {
+ mp->selector = term_only;
+ mp_print_type (mp, t);
+ mp_print (mp, " (see the transcript file)");
+ mp->selector = term_and_log;
+ };
+ switch (t) {
+ case mp_pen_type:
+ mp_print_pen (mp, value_knot (p), "", false);
+ break;
+ case mp_path_type:
+ mp_print_path (mp, value_knot (p), "", false);
+ break;
+ case mp_picture_type:
+ mp_print_edges (mp, v, "", false);
+ break;
+ default:
+ break;
+ }
+}
+
+
+@ @<Declare the procedure called |print_dp|@>=
+static void mp_print_dp (MP mp, quarterword t, mp_value_node p,
+ quarterword verbosity) {
+ mp_value_node q; /* the node following |p| */
+ q = (mp_value_node) mp_link (p);
+ if ((dep_info (q) == NULL) || (verbosity > 0))
+ mp_print_dependency (mp, p, t);
+ else
+ mp_print (mp, "linearform");
+}
+
+
+@ The displayed name of a variable in a ring will not be a capsule unless
+the ring consists entirely of capsules.
+
+@<Display a variable that's been declared but not defined@>=
+{
+ mp_print_type (mp, t);
+ if (v != NULL) {
+ mp_print_char (mp, xord (' '));
+ while ((mp_name_type (v) == mp_capsule) && (v != p))
+ v = value_node (v);
+ mp_print_variable_name (mp, v);
+ };
+}
+
+
+@ When errors are detected during parsing, it is often helpful to
+display an expression just above the error message, using |disp_err|
+just before |mp_error|.
+
+@<Declarations@>=
+static void mp_disp_err (MP mp, mp_node p);
+
+@ @c
+void mp_disp_err (MP mp, mp_node p) {
+ if (mp->interaction == mp_error_stop_mode)
+ wake_up_terminal();
+ mp_print_nl (mp, ">> ");
+@.>>@>;
+ mp_print_exp (mp, p, 1); /* ``medium verbose'' printing of the expression */
+}
+
+
+@ If |cur_type| and |cur_exp| contain relevant information that should
+be recycled, we will use the following procedure, which changes |cur_type|
+to |known| and stores a given value in |cur_exp|. We can think of |cur_type|
+and |cur_exp| as either alive or dormant after this has been done,
+because |cur_exp| will not contain a pointer value.
+
+@ @c
+void mp_flush_cur_exp (MP mp, mp_value v) {
+ if (is_number(mp->cur_exp.data.n)) {
+ free_number(mp->cur_exp.data.n);
+ }
+ switch (mp->cur_exp.type) {
+ case unknown_types:
+ case mp_transform_type:
+ case mp_color_type:
+ case mp_pair_type:
+ case mp_dependent:
+ case mp_proto_dependent:
+ case mp_independent:
+ case mp_cmykcolor_type:
+ mp_recycle_value (mp, cur_exp_node ());
+ mp_free_value_node (mp, cur_exp_node ());
+ break;
+ case mp_string_type:
+ delete_str_ref (cur_exp_str ());
+ break;
+ case mp_pen_type:
+ case mp_path_type:
+ mp_toss_knot_list (mp, cur_exp_knot ());
+ break;
+ case mp_picture_type:
+ delete_edge_ref (cur_exp_node ());
+ break;
+ default:
+ break;
+ }
+ mp->cur_exp = v;
+ mp->cur_exp.type = mp_known;
+}
+
+
+@ There's a much more general procedure that is capable of releasing
+the storage associated with any non-symbolic value packet.
+
+@<Declarations@>=
+static void mp_recycle_value (MP mp, mp_node p);
+
+@ @c
+static void mp_recycle_value (MP mp, mp_node p) {
+ mp_variable_type t; /* a type code */
+ FUNCTION_TRACE2 ("mp_recycle_value(%p)\n", p);
+ if (p==NULL || p==MP_VOID)
+ return;
+ t = mp_type (p);
+ switch (t) {
+ case mp_vacuous:
+ case mp_boolean_type:
+ case mp_known:
+ case mp_numeric_type:
+ break;
+ case unknown_types:
+ mp_ring_delete (mp, p);
+ break;
+ case mp_string_type:
+ delete_str_ref (value_str (p));
+ break;
+ case mp_path_type:
+ case mp_pen_type:
+ mp_toss_knot_list (mp, value_knot (p));
+ break;
+ case mp_picture_type:
+ delete_edge_ref (value_node (p));
+ break;
+ case mp_cmykcolor_type:
+ if (value_node (p) != NULL) {
+ mp_recycle_value (mp, cyan_part (value_node (p)));
+ mp_recycle_value (mp, magenta_part (value_node (p)));
+ mp_recycle_value (mp, yellow_part (value_node (p)));
+ mp_recycle_value (mp, black_part (value_node (p)));
+ mp_free_value_node (mp, cyan_part (value_node (p)));
+ mp_free_value_node (mp, magenta_part (value_node (p)));
+ mp_free_value_node (mp, black_part (value_node (p)));
+ mp_free_value_node (mp, yellow_part (value_node (p)));
+ mp_free_node (mp, value_node (p), cmykcolor_node_size);
+ }
+ break;
+ case mp_pair_type:
+ if (value_node (p) != NULL) {
+ mp_recycle_value (mp, x_part (value_node (p)));
+ mp_recycle_value (mp, y_part (value_node (p)));
+ mp_free_value_node (mp, x_part (value_node (p)));
+ mp_free_value_node (mp, y_part (value_node (p)));
+ mp_free_pair_node (mp, value_node (p));
+ }
+ break;
+ case mp_color_type:
+ if (value_node (p) != NULL) {
+ mp_recycle_value (mp, red_part (value_node (p)));
+ mp_recycle_value (mp, green_part (value_node (p)));
+ mp_recycle_value (mp, blue_part (value_node (p)));
+ mp_free_value_node (mp, red_part (value_node (p)));
+ mp_free_value_node (mp, green_part (value_node (p)));
+ mp_free_value_node (mp, blue_part (value_node (p)));
+ mp_free_node (mp, value_node (p), color_node_size);
+ }
+ break;
+ case mp_transform_type:
+ if (value_node (p) != NULL) {
+ mp_recycle_value (mp, tx_part (value_node (p)));
+ mp_recycle_value (mp, ty_part (value_node (p)));
+ mp_recycle_value (mp, xx_part (value_node (p)));
+ mp_recycle_value (mp, xy_part (value_node (p)));
+ mp_recycle_value (mp, yx_part (value_node (p)));
+ mp_recycle_value (mp, yy_part (value_node (p)));
+ mp_free_value_node (mp, tx_part (value_node (p)));
+ mp_free_value_node (mp, ty_part (value_node (p)));
+ mp_free_value_node (mp, xx_part (value_node (p)));
+ mp_free_value_node (mp, xy_part (value_node (p)));
+ mp_free_value_node (mp, yx_part (value_node (p)));
+ mp_free_value_node (mp, yy_part (value_node (p)));
+ mp_free_node (mp, value_node (p), transform_node_size);
+ }
+ break;
+ case mp_dependent:
+ case mp_proto_dependent:
+ /* Recycle a dependency list */
+ {
+ mp_value_node qq = (mp_value_node) dep_list ((mp_value_node) p);
+ while (dep_info (qq) != NULL)
+ qq = (mp_value_node) mp_link (qq);
+ set_mp_link (prev_dep ((mp_value_node) p), mp_link (qq));
+ set_prev_dep (mp_link (qq), prev_dep ((mp_value_node) p));
+ set_mp_link (qq, NULL);
+ mp_flush_node_list (mp, (mp_node) dep_list ((mp_value_node) p));
+ }
+ break;
+ case mp_independent:
+ @<Recycle an independent variable@>;
+ break;
+ case mp_token_list:
+ case mp_structured:
+ mp_confusion (mp, "recycle");
+ break;
+ case mp_unsuffixed_macro:
+ case mp_suffixed_macro:
+ mp_delete_mac_ref (mp, value_node (p));
+ break;
+ default: /* there are no other valid cases, but please the compiler */
+ break;
+ }
+ mp_type (p) = mp_undefined;
+}
+
+@ 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.n->data. thesis (Stanford University, December 1982).
+@^Zabala Salelles, Ignacio Andr\'es@>
+
+For example, suppose that variable $x$ is being recycled, and that the
+only variables depending on~$x$ are $y=2x+a$ and $z=x+b$. In this case
+we want to make $y$ independent and $z=.5y-.5a+b$; no other variables
+will depend on~$y$. If $\\{tracingequations}>0$ in this situation,
+we will print `\.{\#\#\# -2x=-y+a}'.
+
+There's a slight complication, however: An independent variable $x$
+can occur both in dependency lists and in proto-dependency lists.
+This makes it necessary to be careful when deciding which coefficient
+is maximal.
+
+Furthermore, this complication is not so slight when
+a proto-dependent variable is chosen to become independent. For example,
+suppose that $y=2x+100a$ is proto-dependent while $z=x+b$ is dependent;
+then we must change $z=.5y-50a+b$ to a proto-dependency, because of the
+large coefficient `50'.
+
+In order to deal with these complications without wasting too much time,
+we shall link together the occurrences of~$x$ among all the linear
+dependencies, maintaining separate lists for the dependent and
+proto-dependent cases.
+
+@<Recycle an independent variable@>=
+{
+ mp_value_node q, r, s;
+ mp_node pp; /* link manipulation register */
+ mp_number v ; /* a value */
+ mp_number test; /* a temporary value */
+ new_number (test);
+ new_number (v);
+ if (t < mp_dependent)
+ number_clone (v, value_number (p));
+ set_number_to_zero(mp->max_c[mp_dependent]);
+ set_number_to_zero(mp->max_c[mp_proto_dependent]);
+ mp->max_link[mp_dependent] = NULL;
+ mp->max_link[mp_proto_dependent] = NULL;
+ q = (mp_value_node) mp_link (mp->dep_head);
+ while (q != mp->dep_head) {
+ s = (mp_value_node) mp->temp_head;
+ set_mp_link (s, dep_list (q));
+ while (1) {
+ r = (mp_value_node) mp_link (s);
+ if (dep_info (r) == NULL)
+ break;
+ if (dep_info (r) != p) {
+ s = r;
+ } else {
+ t = mp_type (q);
+ if (mp_link (s) == dep_list (q)) { /* reset the |dep_list| */
+ set_dep_list (q, mp_link (r));
+ }
+ set_mp_link (s, mp_link (r));
+ set_dep_info (r, (mp_node) q);
+ number_clone (test, dep_value (r));
+ number_abs (test);
+ if (number_greater (test, mp->max_c[t])) {
+ /* Record a new maximum coefficient of type |t| */
+ if (number_positive(mp->max_c[t])) {
+ set_mp_link (mp->max_ptr[t], (mp_node) mp->max_link[t]);
+ mp->max_link[t] = mp->max_ptr[t];
+ }
+ number_clone (mp->max_c[t], test);
+ mp->max_ptr[t] = r;
+ } else {
+ set_mp_link (r, (mp_node) mp->max_link[t]);
+ mp->max_link[t] = r;
+ }
+ }
+ }
+ q = (mp_value_node) mp_link (r);
+ }
+ if (number_positive(mp->max_c[mp_dependent]) || number_positive(mp->max_c[mp_proto_dependent])) {
+ /* Choose a dependent variable to take the place of the disappearing
+ independent variable, and change all remaining dependencies
+ accordingly */
+ mp_number test, ret; /* temporary use */
+ new_number (ret);
+ new_number (test);
+ number_clone (test, mp->max_c[mp_dependent]);
+ number_divide_int (test, 4096);
+ if (number_greaterequal(test, mp->max_c[mp_proto_dependent]))
+ t = mp_dependent;
+ else
+ t = mp_proto_dependent;
+
+ /* Let |s=max_ptr[t]|. At this point we have $|value|(s)=\pm|max_c|[t]$,
+ and |dep_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 dependency list |s| to substitute for the independent
+ variable~|p| */
+
+ s = mp->max_ptr[t];
+ pp = (mp_node) dep_info (s);
+ number_clone (v, dep_value (s));
+ if (t == mp_dependent) {
+ set_dep_value (s, fraction_one_t);
+ } else {
+ set_dep_value (s, unity_t);
+ }
+ number_negate(dep_value(s));
+ r = (mp_value_node) dep_list ((mp_value_node) pp);
+ set_mp_link (s, (mp_node) r);
+ while (dep_info (r) != NULL)
+ r = (mp_value_node) mp_link (r);
+ q = (mp_value_node) mp_link (r);
+ set_mp_link (r, NULL);
+ set_prev_dep (q, prev_dep ((mp_value_node) pp));
+ set_mp_link (prev_dep ((mp_value_node) pp), (mp_node) q);
+ mp_new_indep (mp, pp);
+ if (cur_exp_node () == pp && mp->cur_exp.type == t)
+ mp->cur_exp.type = mp_independent;
+ if (number_positive (internal_value (mp_tracing_equations))) {
+ /* Show the transformed dependency */
+ if (mp_interesting (mp, p)) {
+ mp_begin_diagnostic (mp);
+ mp_show_transformed_dependency(mp, v, t, p);
+ mp_print_dependency (mp, s, t);
+ mp_end_diagnostic (mp, false);
+ }
+ }
+
+ t = (quarterword) (mp_dependent + mp_proto_dependent - t); /* complement |t| */
+ if (number_positive(mp->max_c[t])) {
+ /* we need to pick up an unchosen dependency */
+ set_mp_link (mp->max_ptr[t], (mp_node) mp->max_link[t]);
+ mp->max_link[t] = mp->max_ptr[t];
+ }
+ /* Finally, there are dependent and proto-dependent variables whose
+ dependency lists must be brought up to date. */
+ if (t != mp_dependent) {
+ /* Substitute new dependencies in place of |p| */
+ for (t = mp_dependent; t <= mp_proto_dependent; t=t+1) {
+ r = mp->max_link[t];
+ while (r != NULL) {
+ q = (mp_value_node) dep_info (r);
+ number_clone (test, v);
+ number_negate (test);
+ make_fraction (ret, dep_value (r), test);
+ set_dep_list (q, mp_p_plus_fq (mp, (mp_value_node) dep_list (q), ret, s, t, mp_dependent));
+ if (dep_list (q) == (mp_node) mp->dep_final)
+ mp_make_known (mp, q, mp->dep_final);
+ q = r;
+ r = (mp_value_node) mp_link (r);
+ mp_free_dep_node (mp, q);
+ }
+ }
+ } else {
+ /* Substitute new proto-dependencies in place of |p| */
+ for (t = mp_dependent; t <= mp_proto_dependent; t=t+1) {
+ r = mp->max_link[t];
+ while (r != NULL) {
+ q = (mp_value_node) dep_info (r);
+ if (t == mp_dependent) { /* for safety's sake, we change |q| to |mp_proto_dependent| */
+ if (cur_exp_node () == (mp_node) q && mp->cur_exp.type == mp_dependent)
+ mp->cur_exp.type = mp_proto_dependent;
+ set_dep_list (q, mp_p_over_v (mp, (mp_value_node) dep_list (q),
+ unity_t, mp_dependent,
+ mp_proto_dependent));
+ mp_type (q) = mp_proto_dependent;
+ fraction_to_round_scaled (dep_value (r));
+ }
+ number_clone (test, v);
+ number_negate (test);
+ make_scaled (ret, dep_value (r), test);
+ set_dep_list (q, mp_p_plus_fq (mp, (mp_value_node) dep_list (q),
+ ret, s,
+ mp_proto_dependent,
+ mp_proto_dependent));
+ if (dep_list (q) == (mp_node) mp->dep_final)
+ mp_make_known (mp, q, mp->dep_final);
+ q = r;
+ r = (mp_value_node) mp_link (r);
+ mp_free_dep_node (mp, q);
+ }
+ }
+ }
+ mp_flush_node_list (mp, (mp_node) s);
+ if (mp->fix_needed)
+ mp_fix_dependencies (mp);
+ check_arith();
+ free_number (ret);
+ }
+ free_number (v);
+ free_number(test);
+}
+
+@ @<Declarations@>=
+static void mp_show_transformed_dependency(MP mp, mp_number v, mp_variable_type t, mp_node p);
+
+@ @c
+static void mp_show_transformed_dependency(MP mp, mp_number v, mp_variable_type t, mp_node p)
+{
+ mp_number vv; /* for temp use */
+ new_number (vv);
+ mp_print_nl (mp, "### ");
+ if (number_positive(v))
+ mp_print_char (mp, xord ('-'));
+ if (t == mp_dependent) {
+ number_clone (vv, mp->max_c[mp_dependent]);
+ fraction_to_round_scaled (vv);
+ } else {
+ number_clone (vv, mp->max_c[mp_proto_dependent]);
+ }
+ if (!number_equal(vv, unity_t)) {
+ print_number (vv);
+ }
+ mp_print_variable_name (mp, p);
+ while (indep_scale (p) > 0) {
+ mp_print (mp, "*4");
+ set_indep_scale(p, indep_scale(p)-2);
+ }
+ if (t == mp_dependent)
+ mp_print_char (mp, xord ('='));
+ else
+ mp_print (mp, " = ");
+ free_number (vv);
+}
+
+
+@ The code for independency removal makes use of three non-symbolic arrays.
+
+@<Glob...@>=
+mp_number max_c[mp_proto_dependent + 1]; /* max coefficient magnitude */
+mp_value_node max_ptr[mp_proto_dependent + 1]; /* where |p| occurs with |max_c| */
+mp_value_node max_link[mp_proto_dependent + 1]; /* other occurrences of |p| */
+
+
+@ @<Initialize table ... @>=
+{
+ int i;
+ for (i=0;i<mp_proto_dependent + 1;i++) {
+ new_number (mp->max_c[i]);
+ }
+}
+
+@ @<Dealloc...@>=
+{
+ int i;
+ for (i=0;i<mp_proto_dependent + 1;i++) {
+ free_number (mp->max_c[i]);
+ }
+}
+
+@ A global variable |var_flag| is set to a special command code
+just before \MP\ calls |scan_expression|, if the expression should be
+treated as a variable when this command code immediately follows. For
+example, |var_flag| is set to |assignment| at the beginning of a
+statement, because we want to know the {\sl location\/} of a variable at
+the left of `\.{:=}', not the {\sl value\/} of that variable.
+
+The |scan_expression| subroutine calls |scan_tertiary|,
+which calls |scan_secondary|, which calls |scan_primary|, which sets
+|var_flag:=0|. In this way each of the scanning routines ``knows''
+when it has been called with a special |var_flag|, but |var_flag| is
+usually zero.
+
+A variable preceding a command that equals |var_flag| is converted to a
+token list rather than a value. Furthermore, an `\.{=}' sign following an
+expression with |var_flag=assignment| is not considered to be a relation
+that produces boolean expressions.
+
+
+@<Glob...@>=
+int var_flag; /* command that wants a variable */
+
+@ @<Set init...@>=
+mp->var_flag = 0;
+
+@* 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.
+
+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.
+
+@<Declare the basic parsing subroutines@>=
+static void check_for_mediation (MP mp);
+void mp_scan_primary (MP mp) {
+ mp_command_code my_var_flag; /* initial value of |my_var_flag| */
+ my_var_flag = mp->var_flag;
+ mp->var_flag = 0;
+RESTART:
+ check_arith();
+ /* Supply diagnostic information, if requested */
+ if (mp->interrupt != 0) {
+ if (mp->OK_to_interrupt) {
+ mp_back_input (mp);
+ check_interrupt;
+ mp_get_x_next (mp);
+ }
+ }
+ switch (cur_cmd()) {
+ case mp_left_delimiter:
+ {
+ /* Scan a delimited primary */
+ mp_node p, q, r; /* for list manipulation */
+ mp_sym l_delim, r_delim; /* hash addresses of a delimiter pair */
+ l_delim = cur_sym();
+ r_delim = equiv_sym (cur_sym());
+ mp_get_x_next (mp);
+ mp_scan_expression (mp);
+ if ((cur_cmd() == mp_comma) && (mp->cur_exp.type >= mp_known)) {
+ /* Scan the rest of a delimited set of numerics */
+ /* This code uses the fact that |red_part| and |green_part|
+ are synonymous with |x_part| and |y_part|. */
+ p = mp_stash_cur_exp (mp);
+ mp_get_x_next (mp);
+ mp_scan_expression (mp);
+ /* Make sure the second part of a pair or color has a numeric type */
+ if (mp->cur_exp.type < mp_known) {
+ const char *hlp[] = {
+ "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.)",
+ NULL };
+ mp_value new_expr;
+ memset(&new_expr,0,sizeof(mp_value));
+ mp_disp_err(mp, NULL);
+ new_number(new_expr.data.n);
+ set_number_to_zero(new_expr.data.n);
+ mp_back_error (mp,"Nonnumeric ypart has been replaced by 0", hlp, true);
+ mp_get_x_next (mp);
+ mp_flush_cur_exp (mp, new_expr);
+ }
+
+ q = mp_get_value_node (mp);
+ mp_name_type (q) = mp_capsule;
+ if (cur_cmd() == mp_comma) {
+ mp_init_color_node (mp, q);
+ r = value_node (q);
+ mp_stash_in (mp, y_part (r));
+ mp_unstash_cur_exp (mp, p);
+ mp_stash_in (mp, x_part (r));
+ /* Scan the last of a triplet of numerics */
+ mp_get_x_next (mp);
+ mp_scan_expression (mp);
+ if (mp->cur_exp.type < mp_known) {
+ mp_value new_expr;
+ const char *hlp[] = {
+ "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.)",
+ NULL };
+ memset(&new_expr,0,sizeof(mp_value));
+ mp_disp_err(mp, NULL);
+ new_number(new_expr.data.n);
+ set_number_to_zero(new_expr.data.n);
+ mp_back_error (mp,"Nonnumeric third part has been replaced by 0", hlp, true);
+ mp_get_x_next (mp);
+ mp_flush_cur_exp (mp, new_expr);
+ }
+ mp_stash_in (mp, blue_part (r));
+
+ if (cur_cmd() == mp_comma) {
+ mp_node t; /* a token */
+ mp_init_cmykcolor_node (mp, q);
+ t = value_node (q);
+ mp_type (cyan_part (t)) = mp_type (red_part (r));
+ set_value_number (cyan_part (t), value_number (red_part (r)));
+ mp_type (magenta_part (t)) = mp_type (green_part (r));
+ set_value_number (magenta_part (t), value_number (green_part (r)));
+ mp_type (yellow_part (t)) = mp_type (blue_part (r));
+ set_value_number (yellow_part (t), value_number (blue_part (r)));
+ /*see |mp_stash_in| */
+ if ( ((mp_type (cyan_part (t))) != mp_independent) && ((mp_type (cyan_part (t))) != mp_known) ) {
+ /* Copy the dep list */
+ set_dep_list (cyan_part(t),dep_list ((mp_value_node) red_part(r)));
+ set_prev_dep (cyan_part(t),prev_dep ((mp_value_node) red_part(r)));
+ set_mp_link (prev_dep (cyan_part(t)), (mp_node) cyan_part(t));
+ }
+ if ( ((mp_type (magenta_part (t))) != mp_independent) && ((mp_type (magenta_part (t))) != mp_known) ) {
+ /* Copy the dep list */
+ set_dep_list (magenta_part(t),dep_list ((mp_value_node) green_part(r)));
+ set_prev_dep (magenta_part(t),prev_dep ((mp_value_node) green_part(r)));
+ set_mp_link (prev_dep (magenta_part(t)), (mp_node) magenta_part(t));
+ }
+ if ( ((mp_type (yellow_part (t))) != mp_independent) && ((mp_type (yellow_part (t))) != mp_known)) {
+ /* Copy the dep list */
+ set_dep_list (yellow_part(t),dep_list ((mp_value_node) blue_part(r)));
+ set_prev_dep (yellow_part(t),prev_dep ((mp_value_node) blue_part(r)));
+ set_mp_link (prev_dep (yellow_part(t)), (mp_node) yellow_part(t));
+ }
+ mp_recycle_value (mp, r);
+ r = t;
+ /* Scan the last of a quartet of numerics */
+ mp_get_x_next (mp);
+ mp_scan_expression (mp);
+ if (mp->cur_exp.type < mp_known) {
+ const char *hlp[] = {
+ "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.)",
+ NULL };
+ mp_value new_expr;
+ memset(&new_expr,0,sizeof(mp_value));
+ new_number(new_expr.data.n);
+ mp_disp_err(mp, NULL);
+ set_number_to_zero(new_expr.data.n);
+ mp_back_error (mp,"Nonnumeric blackpart has been replaced by 0", hlp, true);
+ mp_get_x_next (mp);
+ mp_flush_cur_exp (mp, new_expr);
+ }
+ mp_stash_in (mp, black_part (r));
+ }
+ } else {
+ mp_init_pair_node (mp, q);
+ r = value_node (q);
+ mp_stash_in (mp, y_part (r));
+ mp_unstash_cur_exp (mp, p);
+ mp_stash_in (mp, x_part (r));
+ }
+ mp_check_delimiter (mp, l_delim, r_delim);
+ mp->cur_exp.type = mp_type (q);
+ set_cur_exp_node (q);
+
+ } else {
+ mp_check_delimiter (mp, l_delim, r_delim);
+ }
+ }
+ break;
+ case mp_begin_group:
+ /* Scan a grouped primary */
+ /* 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. */
+ {
+ integer group_line; /* where a group began */
+ group_line = mp_true_line (mp);
+ if (number_positive (internal_value (mp_tracing_commands)))
+ show_cur_cmd_mod;
+ mp_save_boundary (mp);
+ do {
+ mp_do_statement (mp); /* ends with |cur_cmd>=semicolon| */
+ } while (cur_cmd() == mp_semicolon);
+ if (cur_cmd() != mp_end_group) {
+ char msg[256];
+ const char *hlp[] = {
+ "I saw a `begingroup' back there that hasn't been matched",
+ "by `endgroup'. So I've inserted `endgroup' now.",
+ NULL };
+ mp_snprintf(msg, 256, "A group begun on line %d never ended", (int)group_line);
+ mp_back_error (mp, msg, hlp, true);
+ set_cur_cmd((mp_variable_type)mp_end_group);
+ }
+ mp_unsave (mp);
+ /* this might change |cur_type|, if independent variables are recycled */
+ if (number_positive (internal_value (mp_tracing_commands)))
+ show_cur_cmd_mod;
+ }
+ break;
+ case mp_string_token:
+ /* Scan a string constant */
+ mp->cur_exp.type = mp_string_type;
+ set_cur_exp_str (cur_mod_str());
+ break;
+ case mp_numeric_token:
+ {
+ /* Scan a primary that starts with a numeric token */
+ /* 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. */
+ mp_number num, denom; /* for primaries that are fractions, like `1/2' */
+ new_number (num);
+ new_number (denom);
+ set_cur_exp_value_number (cur_mod_number());
+ mp->cur_exp.type = mp_known;
+ mp_get_x_next (mp);
+ if (cur_cmd() != mp_slash) {
+ set_number_to_zero(num);
+ set_number_to_zero(denom);
+ } else {
+ mp_get_x_next (mp);
+ if (cur_cmd() != mp_numeric_token) {
+ mp_back_input (mp);
+ set_cur_cmd((mp_variable_type)mp_slash);
+ set_cur_mod(mp_over);
+ set_cur_sym(mp->frozen_slash);
+ free_number (num);
+ free_number (denom);
+ goto DONE;
+ }
+ number_clone (num, cur_exp_value_number ());
+ number_clone (denom, cur_mod_number());
+ if (number_zero(denom)) {
+ /* Protest division by zero */
+ const char *hlp[] = { "I'll pretend that you meant to divide by 1.", NULL };
+ mp_error (mp, "Division by zero", hlp, true);
+ } else {
+ mp_number ret;
+ new_number (ret);
+ make_scaled (ret, num, denom);
+ set_cur_exp_value_number (ret);
+ free_number (ret);
+ }
+ check_arith();
+ mp_get_x_next (mp);
+ }
+ if (cur_cmd() >= mp_min_primary_command) {
+ if (cur_cmd() < mp_numeric_token) { /* in particular, |cur_cmd<>plus_or_minus| */
+ mp_node p; /* for list manipulation */
+ mp_number absnum, absdenom;
+ new_number (absnum);
+ new_number (absdenom);
+ p = mp_stash_cur_exp (mp);
+ mp_scan_primary (mp);
+ number_clone (absnum, num);
+ number_abs (absnum);
+ number_clone (absdenom, denom);
+ number_abs (absdenom);
+ if (number_greaterequal(absnum, absdenom) || (mp->cur_exp.type < mp_color_type)) {
+ mp_do_binary (mp, p, mp_times);
+ } else {
+ mp_frac_mult (mp, num, denom);
+ mp_free_value_node (mp, p);
+ }
+ free_number (absnum);
+ free_number (absdenom);
+ }
+ }
+ free_number (num);
+ free_number (denom);
+ goto DONE;
+ }
+ break;
+ case mp_nullary:
+ /* Scan a nullary operation */
+ mp_do_nullary (mp, (quarterword) cur_mod());
+ break;
+ case mp_unary:
+ case mp_type_name:
+ case mp_cycle:
+ case mp_plus_or_minus:
+ {
+ /* Scan a unary operation */
+ quarterword c; /* a primitive operation code */
+ c = (quarterword) cur_mod();
+ mp_get_x_next (mp);
+ mp_scan_primary (mp);
+ mp_do_unary (mp, c);
+ goto DONE;
+ }
+ break;
+ case mp_primary_binary:
+ {
+ /* Scan a binary operation with `\&{of}' between its operands */
+ mp_node p; /* for list manipulation */
+ quarterword c; /* a primitive operation code */
+ c = (quarterword) cur_mod();
+ mp_get_x_next (mp);
+ mp_scan_expression (mp);
+ if (cur_cmd() != mp_of_token) {
+ char msg[256];
+ mp_string sname;
+ const char *hlp[] = {
+ "I've got the first argument; will look now for the other.",
+ NULL };
+ int old_setting = mp->selector;
+ mp->selector = new_string;
+ mp_print_cmd_mod (mp, mp_primary_binary, c);
+ mp->selector = old_setting;
+ sname = mp_make_string(mp);
+ mp_snprintf (msg, 256, "Missing `of' has been inserted for %s", mp_str(mp, sname));
+ delete_str_ref(sname);
+ mp_back_error (mp, msg, hlp, true);
+ }
+ p = mp_stash_cur_exp (mp);
+ mp_get_x_next (mp);
+ mp_scan_primary (mp);
+ mp_do_binary (mp, p, c);
+ goto DONE;
+ }
+ break;
+ case mp_str_op:
+ /* Convert a suffix to a string */
+ mp_get_x_next (mp);
+ mp_scan_suffix (mp);
+ mp->old_setting = mp->selector;
+ mp->selector = new_string;
+ mp_show_token_list (mp, cur_exp_node (), NULL, 100000, 0);
+ mp_flush_token_list (mp, cur_exp_node ());
+ set_cur_exp_str (mp_make_string (mp));
+ mp->selector = mp->old_setting;
+ mp->cur_exp.type = mp_string_type;
+ goto DONE;
+ break;
+ case mp_void_op:
+ {
+ /* Convert a suffix to a boolean */
+ mp_value new_expr;
+ memset(&new_expr,0,sizeof(mp_value));
+ new_number(new_expr.data.n);
+ mp_get_x_next (mp);
+ mp_scan_suffix (mp);
+ if (cur_exp_node() == NULL) {
+ set_number_from_boolean (new_expr.data.n, mp_true_code);
+ } else {
+ set_number_from_boolean (new_expr.data.n, mp_false_code);
+ }
+ mp_flush_cur_exp (mp, new_expr);
+ cur_exp_node() = NULL; /* !! do not replace with |set_cur_exp_node()| !! */
+ mp->cur_exp.type = mp_boolean_type;
+ goto DONE;
+ }
+ break;
+ case mp_internal_quantity:
+ /* Scan an internal numeric quantity */
+ /* 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, with |name_type| equal to |mp_internal_sym|.
+ (This accords with the conventions of the save stack, as described earlier.) */
+ {
+ halfword qq = cur_mod();
+ if (my_var_flag == mp_assignment) {
+ mp_get_x_next (mp);
+ if (cur_cmd() == mp_assignment) {
+ set_cur_exp_node (mp_get_symbolic_node (mp));
+ set_mp_sym_info (cur_exp_node (), qq);
+ mp_name_type (cur_exp_node ()) = mp_internal_sym;
+ mp->cur_exp.type = mp_token_list;
+ goto DONE;
+ }
+ mp_back_input (mp);
+ }
+ if (internal_type (qq) == mp_string_type) {
+ set_cur_exp_str (internal_string (qq));
+ } else {
+ set_cur_exp_value_number (internal_value (qq));
+ }
+ mp->cur_exp.type = internal_type (qq);
+ }
+ break;
+ case mp_capsule_token:
+ mp_make_exp_copy (mp, cur_mod_node());
+ break;
+ case mp_tag_token:
+ @<Scan a variable primary; |goto restart| if it turns out to be a macro@>;
+ break;
+ default:
+ mp_bad_exp (mp, "A primary");
+ goto RESTART;
+ break;
+ }
+ mp_get_x_next (mp); /* the routines |goto done| if they don't want this */
+DONE:
+ check_for_mediation (mp);
+}
+
+@ 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.
+
+@<Declare the basic parsing subroutines@>=
+static void check_for_mediation (MP mp) {
+ mp_node p, q, r; /* for list manipulation */
+ if (cur_cmd() == mp_left_bracket) {
+ if (mp->cur_exp.type >= mp_known) {
+ /* Scan a mediation construction */
+ p = mp_stash_cur_exp (mp);
+ mp_get_x_next (mp);
+ mp_scan_expression (mp);
+ if (cur_cmd() != mp_comma) {
+ /* Put the left bracket and the expression back to be rescanned */
+ /* 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. */
+ mp_back_input (mp); /* that was the token following the current expression */
+ mp_back_expr (mp);
+ set_cur_cmd((mp_variable_type)mp_left_bracket);
+ set_cur_mod_number(zero_t);
+ set_cur_sym(mp->frozen_left_bracket);
+ mp_unstash_cur_exp (mp, p);
+ } else {
+ q = mp_stash_cur_exp (mp);
+ mp_get_x_next (mp);
+ mp_scan_expression (mp);
+ if (cur_cmd() != mp_right_bracket) {
+ const char *hlp[] = {
+ "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.",
+ NULL };
+ mp_back_error (mp, "Missing `]' has been inserted", hlp, true);
+ }
+ r = mp_stash_cur_exp (mp);
+ mp_make_exp_copy (mp, q);
+ mp_do_binary (mp, r, mp_minus);
+ mp_do_binary (mp, p, mp_times);
+ mp_do_binary (mp, q, mp_plus);
+ mp_get_x_next (mp);
+ }
+ }
+ }
+}
+
+
+@ Errors at the beginning of expressions are flagged by |bad_exp|.
+
+@c
+static void mp_bad_exp (MP mp, const char *s) {
+ char msg[256];
+ int save_flag;
+ const char *hlp[] = {
+ "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.",
+ NULL };
+@:METAFONTbook}{\sl The {\logos METAFONT\/}book@>;
+ {
+ mp_string cm;
+ int old_selector = mp->selector;
+ mp->selector = new_string;
+ mp_print_cmd_mod (mp, cur_cmd(), cur_mod());
+ mp->selector = old_selector;
+ cm = mp_make_string(mp);
+ mp_snprintf(msg, 256, "%s expression can't begin with `%s'", s, mp_str(mp, cm));
+ delete_str_ref(cm);
+ }
+ mp_back_input (mp);
+ set_cur_sym(NULL);
+ set_cur_cmd((mp_variable_type)mp_numeric_token);
+ set_cur_mod_number (zero_t);
+ mp_ins_error (mp, msg, hlp, true);
+ save_flag = mp->var_flag;
+ mp->var_flag = 0;
+ mp_get_x_next (mp);
+ mp->var_flag = save_flag;
+}
+
+
+@ The |stash_in| subroutine puts the current (numeric) expression into a field
+within a ``big node.''
+
+@c
+static void mp_stash_in (MP mp, mp_node p) {
+ mp_value_node q; /* temporary register */
+ mp_type (p) = mp->cur_exp.type;
+ if (mp->cur_exp.type == mp_known) {
+ set_value_number (p, cur_exp_value_number ());
+ } else {
+ if (mp->cur_exp.type == mp_independent) {
+ /* Stash an independent |cur_exp| into a big node */
+ /* 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. */
+ q = mp_single_dependency (mp, cur_exp_node ());
+ if (q == mp->dep_final) {
+ mp_type (p) = mp_known;
+ set_value_number (p, zero_t);
+ mp_free_dep_node (mp, q);
+ } else {
+ mp_new_dep (mp, p, mp_dependent, q);
+ }
+ mp_recycle_value (mp, cur_exp_node ());
+ mp_free_value_node (mp, cur_exp_node ());
+ } else {
+ set_dep_list ((mp_value_node) p,
+ dep_list ((mp_value_node) cur_exp_node ()));
+ set_prev_dep ((mp_value_node) p,
+ prev_dep ((mp_value_node) cur_exp_node ()));
+ set_mp_link (prev_dep ((mp_value_node) p), p);
+ mp_free_dep_node (mp, (mp_value_node) cur_exp_node ());
+ }
+ }
+ mp->cur_exp.type = mp_vacuous;
+}
+
+@ The most difficult part of |scan_primary| has been saved for last, since
+it was necessary to build up some confidence first. We can now face the task
+of scanning a variable.
+
+As we scan a variable, we build a token list containing the relevant
+names and subscript values, simultaneously following along in the
+``collective'' structure to see if we are actually dealing with a macro
+instead of a value.
+
+The local variables |pre_head| and |post_head| will point to the beginning
+of the prefix and suffix lists; |tail| will point to the end of the list
+that is currently growing.
+
+Another local variable, |tt|, contains partial information about the
+declared type of the variable-so-far. If |tt>=mp_unsuffixed_macro|, the
+relation |tt=mp_type(q)| will always hold. If |tt=undefined|, the routine
+doesn't bother to update its information about type. And if
+|undefined<tt<mp_unsuffixed_macro|, the precise value of |tt| isn't critical.
+
+@ @<Scan a variable primary...@>=
+{
+ mp_node p, q; /* for list manipulation */
+ mp_node t; /* a token */
+ mp_node pre_head, post_head, tail; /* prefix and suffix list variables */
+ quarterword tt; /* approximation to the type of the variable-so-far */
+ mp_node macro_ref = 0; /* reference count for a suffixed macro */
+ pre_head = mp_get_symbolic_node (mp);
+ tail = pre_head;
+ post_head = NULL;
+ tt = mp_vacuous;
+ while (1) {
+ t = mp_cur_tok (mp);
+ mp_link (tail) = t;
+ if (tt != mp_undefined) {
+ /* Find the approximate type |tt| and corresponding~|q| */
+ /* 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. */
+ mp_sym qq;
+ p = mp_link (pre_head);
+ qq = mp_sym_sym (p);
+ tt = mp_undefined;
+ if (eq_type (qq) % mp_outer_tag == mp_tag_token) {
+ q = equiv_node (qq);
+ if (q == NULL)
+ goto DONE2;
+ while (1) {
+ p = mp_link (p);
+ if (p == NULL) {
+ tt = mp_type (q);
+ goto DONE2;
+ }
+ if (mp_type (q) != mp_structured)
+ goto DONE2;
+ q = mp_link (attr_head (q)); /* the |collective_subscript| attribute */
+ if (mp_type (p) == mp_symbol_node) { /* it's not a subscript */
+ do {
+ q = mp_link (q);
+ } while (!(hashloc (q) >= mp_sym_sym (p)));
+ if (hashloc (q) > mp_sym_sym (p))
+ goto DONE2;
+ }
+ }
+ }
+ DONE2:
+
+ if (tt >= mp_unsuffixed_macro) {
+ /* Either begin an unsuffixed macro call or
+ prepare for a suffixed one */
+ mp_link (tail) = NULL;
+ if (tt > mp_unsuffixed_macro) { /* |tt=mp_suffixed_macro| */
+ post_head = mp_get_symbolic_node (mp);
+ tail = post_head;
+ mp_link (tail) = t;
+ tt = mp_undefined;
+ macro_ref = value_node (q);
+ add_mac_ref (macro_ref);
+ } else {
+ /* Set up unsuffixed macro call and |goto restart| */
+ /* The only complication associated with macro calling is that the prefix
+ and ``at'' parameters must be packaged in an appropriate list of lists. */
+ p = mp_get_symbolic_node (mp);
+ set_mp_sym_sym (pre_head, mp_link (pre_head));
+ mp_link (pre_head) = p;
+ set_mp_sym_sym (p, t);
+ mp_macro_call (mp, value_node (q), pre_head, NULL);
+ mp_get_x_next (mp);
+ goto RESTART;
+ }
+ }
+ }
+ mp_get_x_next (mp);
+ tail = t;
+ if (cur_cmd() == mp_left_bracket) {
+ /* Scan for a subscript; replace |cur_cmd| by |numeric_token| if found */
+ mp_get_x_next (mp);
+ mp_scan_expression (mp);
+ if (cur_cmd() != mp_right_bracket) {
+ /* Put the left bracket and the expression back to be rescanned */
+ /* 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. */
+ mp_back_input (mp); /* that was the token following the current expression */
+ mp_back_expr (mp);
+ set_cur_cmd((mp_variable_type)mp_left_bracket);
+ set_cur_mod_number(zero_t);
+ set_cur_sym(mp->frozen_left_bracket);
+
+ } else {
+ if (mp->cur_exp.type != mp_known)
+ mp_bad_subscript (mp);
+ set_cur_cmd((mp_variable_type)mp_numeric_token);
+ set_cur_mod_number(cur_exp_value_number ());
+ set_cur_sym(NULL);
+ }
+ }
+ if (cur_cmd() > mp_max_suffix_token)
+ break;
+ if (cur_cmd() < mp_min_suffix_token)
+ break;
+ } /* now |cur_cmd| is |internal_quantity|, |tag_token|, or |numeric_token| */
+ /* Handle unusual cases that masquerade as variables, and |goto restart| or
+ |goto done| if appropriate; otherwise make a copy of the variable and |goto done| */
+ /* 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. */
+ if (post_head != NULL) {
+ /* Set up suffixed macro call and |goto restart| */
+ /* If the ``variable'' that turned out to be a suffixed macro no longer exists,
+ we don't care, because we have reserved a pointer (|macro_ref|) to its
+ token list. */
+ mp_back_input (mp);
+ p = mp_get_symbolic_node (mp);
+ q = mp_link (post_head);
+ set_mp_sym_sym (pre_head, mp_link (pre_head));
+ mp_link (pre_head) = post_head;
+ set_mp_sym_sym (post_head, q);
+ mp_link (post_head) = p;
+ set_mp_sym_sym (p, mp_link (q));
+ mp_link (q) = NULL;
+ mp_macro_call (mp, macro_ref, pre_head, NULL);
+ decr_mac_ref (macro_ref);
+ mp_get_x_next (mp);
+ goto RESTART;
+ }
+ q = mp_link (pre_head);
+ mp_free_symbolic_node (mp, pre_head);
+ if (cur_cmd() == my_var_flag) {
+ mp->cur_exp.type = mp_token_list;
+ set_cur_exp_node (q);
+ goto DONE;
+ }
+ p = mp_find_variable (mp, q);
+ if (p != NULL) {
+ mp_make_exp_copy (mp, p);
+ } else {
+ mp_value new_expr;
+ const char *hlp[] = {
+ "While I was evaluating the suffix of this variable,",
+ "something was redefined, and it's no longer a variable!",
+ "In order to get back on my feet, I've inserted `0' instead.",
+ NULL };
+ char *msg = mp_obliterated (mp, q);
+ memset(&new_expr,0,sizeof(mp_value));
+ new_number(new_expr.data.n);
+ set_number_to_zero(new_expr.data.n);
+ mp_back_error (mp, msg, hlp, true);
+ free(msg);
+ mp_get_x_next (mp);
+ mp_flush_cur_exp (mp, new_expr);
+ }
+ mp_flush_node_list (mp, q);
+ goto DONE;
+}
+
+
+@ Here's a routine that puts the current expression back to be read again.
+
+@c
+static void mp_back_expr (MP mp) {
+ mp_node p; /* capsule token */
+ p = mp_stash_cur_exp (mp);
+ mp_link (p) = NULL;
+ back_list (p);
+}
+
+
+@ Unknown subscripts lead to the following error message.
+
+@c
+static void mp_bad_subscript (MP mp) {
+ mp_value new_expr;
+ const char *hlp[] = {
+ "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.",
+ NULL };
+ memset(&new_expr,0,sizeof(mp_value));
+ new_number(new_expr.data.n);
+ mp_disp_err(mp, NULL);
+ mp_error (mp, "Improper subscript has been replaced by zero", hlp, true);
+@.Improper subscript...@>;
+ mp_flush_cur_exp (mp, new_expr);
+}
+
+
+@ 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 |mp_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 creates an error message for when a variable
+unexpectedly disappears.
+
+@c
+static char *mp_obliterated (MP mp, mp_node q) {
+ char msg[256];
+ mp_string sname;
+ int old_setting = mp->selector;
+ mp->selector = new_string;
+ mp_show_token_list (mp, q, NULL, 1000, 0);
+ sname = mp_make_string(mp);
+ mp->selector = old_setting;
+ mp_snprintf(msg, 256, "Variable %s has been obliterated", mp_str(mp, sname));
+@.Variable...obliterated@>;
+ delete_str_ref(sname);
+ return xstrdup(msg);
+}
+
+
+@ Our remaining job is simply to make a copy of the value that has been
+found. Some cases are harder than others, but complexity arises solely
+because of the multiplicity of possible cases.
+
+@<Declare the procedure called |make_exp_copy|@>=
+@<Declare subroutines needed by |make_exp_copy|@>;
+static void mp_make_exp_copy (MP mp, mp_node p) {
+ mp_node t; /* register(s) for list manipulation */
+ mp_value_node q;
+RESTART:
+ mp->cur_exp.type = mp_type (p);
+ switch (mp->cur_exp.type) {
+ case mp_vacuous:
+ case mp_boolean_type:
+ case mp_known:
+ set_cur_exp_value_number (value_number (p));
+ break;
+ case unknown_types:
+ t = mp_new_ring_entry (mp, p);
+ set_cur_exp_node (t);
+ break;
+ case mp_string_type:
+ set_cur_exp_str (value_str (p));
+ break;
+ case mp_picture_type:
+ set_cur_exp_node (value_node (p));
+ add_edge_ref (cur_exp_node ());
+ break;
+ case mp_pen_type:
+ set_cur_exp_knot (copy_pen (value_knot (p)));
+ break;
+ case mp_path_type:
+ set_cur_exp_knot (mp_copy_path (mp, value_knot (p)));
+ break;
+ case mp_transform_type:
+ case mp_color_type:
+ case mp_cmykcolor_type:
+ case mp_pair_type:
+ /* Copy the big node |p| */
+ /* The most tedious case arises when the user refers to a
+ \&{pair}, \&{color}, or \&{transform} variable; we must copy several fields,
+ each of which can be |independent|, |dependent|, |mp_proto_dependent|,
+ or |known|. */
+ if (value_node (p) == NULL) {
+ switch (mp_type (p)) {
+ case mp_pair_type:
+ mp_init_pair_node (mp, p);
+ break;
+ case mp_color_type:
+ mp_init_color_node (mp, p);
+ break;
+ case mp_cmykcolor_type:
+ mp_init_cmykcolor_node (mp, p);
+ break;
+ case mp_transform_type:
+ mp_init_transform_node (mp, p);
+ break;
+ default: /* there are no other valid cases, but please the compiler */
+ break;
+ }
+ }
+ t = mp_get_value_node (mp);
+ mp_name_type (t) = mp_capsule;
+ q = (mp_value_node)value_node (p);
+ switch (mp->cur_exp.type) {
+ case mp_pair_type:
+ mp_init_pair_node (mp, t);
+ mp_install (mp, y_part (value_node (t)), y_part (q));
+ mp_install (mp, x_part (value_node (t)), x_part (q));
+ break;
+ case mp_color_type:
+ mp_init_color_node (mp, t);
+ mp_install (mp, blue_part (value_node (t)), blue_part (q));
+ mp_install (mp, green_part (value_node (t)), green_part (q));
+ mp_install (mp, red_part (value_node (t)), red_part (q));
+ break;
+ case mp_cmykcolor_type:
+ mp_init_cmykcolor_node (mp, t);
+ mp_install (mp, black_part (value_node (t)), black_part (q));
+ mp_install (mp, yellow_part (value_node (t)), yellow_part (q));
+ mp_install (mp, magenta_part (value_node (t)), magenta_part (q));
+ mp_install (mp, cyan_part (value_node (t)), cyan_part (q));
+ break;
+ case mp_transform_type:
+ mp_init_transform_node (mp, t);
+ mp_install (mp, yy_part (value_node (t)), yy_part (q));
+ mp_install (mp, yx_part (value_node (t)), yx_part (q));
+ mp_install (mp, xy_part (value_node (t)), xy_part (q));
+ mp_install (mp, xx_part (value_node (t)), xx_part (q));
+ mp_install (mp, ty_part (value_node (t)), ty_part (q));
+ mp_install (mp, tx_part (value_node (t)), tx_part (q));
+ break;
+ default: /* there are no other valid cases, but please the compiler */
+ break;
+ }
+ set_cur_exp_node (t);
+ break;
+ case mp_dependent:
+ case mp_proto_dependent:
+ mp_encapsulate (mp,
+ mp_copy_dep_list (mp,
+ (mp_value_node) dep_list ((mp_value_node)
+ p)));
+ break;
+ case mp_numeric_type:
+ mp_new_indep (mp, p);
+ goto RESTART;
+ break;
+ case mp_independent:
+ q = mp_single_dependency (mp, p);
+ if (q == mp->dep_final) {
+ mp->cur_exp.type = mp_known;
+ set_cur_exp_value_number (zero_t);
+ mp_free_dep_node (mp, q);
+ } else {
+ mp->cur_exp.type = mp_dependent;
+ mp_encapsulate (mp, q);
+ }
+ break;
+ default:
+ mp_confusion (mp, "copy");
+@:this can't happen copy}{\quad copy@>;
+ break;
+ }
+}
+
+
+@ The |encapsulate| subroutine assumes that |dep_final| is the
+tail of dependency list~|p|.
+
+@<Declare subroutines needed by |make_exp_copy|@>=
+static void mp_encapsulate (MP mp, mp_value_node p) {
+ mp_node q = mp_get_value_node (mp);
+ FUNCTION_TRACE2 ("mp_encapsulate(%p)\n", p);
+ mp_name_type (q) = mp_capsule;
+ mp_new_dep (mp, q, mp->cur_exp.type, p);
+ set_cur_exp_node (q);
+}
+
+@ 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|@>=
+static void mp_install (MP mp, mp_node r, mp_node q) {
+ mp_value_node p; /* temporary register */
+ if (mp_type (q) == mp_known) {
+ mp_type (r) = mp_known;
+ set_value_number (r, value_number (q));
+ } else if (mp_type (q) == mp_independent) {
+ p = mp_single_dependency (mp, q);
+ if (p == mp->dep_final) {
+ mp_type (r) = mp_known;
+ set_value_number (r, zero_t);
+ mp_free_dep_node (mp, p);
+ } else {
+ mp_new_dep (mp, r, mp_dependent, p);
+ }
+ } else {
+ mp_new_dep (mp, r, mp_type (q),
+ mp_copy_dep_list (mp, (mp_value_node) dep_list ((mp_value_node)
+ q)));
+ }
+}
+
+
+@ Here is a comparatively simple routine that is used to scan the
+\&{suffix} parameters of a macro.
+
+@<Declare the basic parsing subroutines@>=
+static void mp_scan_suffix (MP mp) {
+ mp_node h, t; /* head and tail of the list being built */
+ mp_node p; /* temporary register */
+ h = mp_get_symbolic_node (mp);
+ t = h;
+ while (1) {
+ if (cur_cmd() == mp_left_bracket) {
+ /* Scan a bracketed subscript and set |cur_cmd:=numeric_token| */
+ mp_get_x_next (mp);
+ mp_scan_expression (mp);
+ if (mp->cur_exp.type != mp_known)
+ mp_bad_subscript (mp);
+ if (cur_cmd() != mp_right_bracket) {
+ const char *hlp[] = {
+ "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.",
+ NULL };
+ mp_back_error (mp, "Missing `]' has been inserted", hlp, true);
+ }
+ set_cur_cmd((mp_variable_type)mp_numeric_token);
+ set_cur_mod_number(cur_exp_value_number ());
+
+ }
+ if (cur_cmd() == mp_numeric_token) {
+ mp_number arg1;
+ new_number (arg1);
+ number_clone (arg1, cur_mod_number());
+ p = mp_new_num_tok (mp, arg1);
+ free_number (arg1);
+ } else if ((cur_cmd() == mp_tag_token) || (cur_cmd() == mp_internal_quantity)) {
+ p = mp_get_symbolic_node (mp);
+ set_mp_sym_sym (p, cur_sym());
+ mp_name_type (p) = cur_sym_mod();
+ } else {
+ break;
+ }
+ mp_link (t) = p;
+ t = p;
+ mp_get_x_next (mp);
+ }
+ set_cur_exp_node (mp_link (h));
+ mp_free_symbolic_node (mp, h);
+ mp->cur_exp.type = mp_token_list;
+}
+
+@* 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@>=
+static void mp_scan_secondary (MP mp) {
+ mp_node p; /* for list manipulation */
+ halfword c, d; /* operation codes or modifiers */
+ mp_node cc = NULL;
+ mp_sym mac_name = NULL; /* token defined with \&{primarydef} */
+RESTART:
+ if ((cur_cmd() < mp_min_primary_command) ||
+ (cur_cmd() > mp_max_primary_command))
+ mp_bad_exp (mp, "A secondary");
+@.A secondary expression...@>;
+ mp_scan_primary (mp);
+CONTINUE:
+ if (cur_cmd() <= mp_max_secondary_command &&
+ cur_cmd() >= mp_min_secondary_command) {
+ p = mp_stash_cur_exp (mp);
+ d = cur_cmd();
+ c = cur_mod();
+ if (d == mp_secondary_primary_macro) {
+ cc = cur_mod_node();
+ mac_name = cur_sym();
+ add_mac_ref (cc);
+ }
+ mp_get_x_next (mp);
+ mp_scan_primary (mp);
+ if (d != mp_secondary_primary_macro) {
+ mp_do_binary (mp, p, c);
+ } else {
+ mp_back_input (mp);
+ mp_binary_mac (mp, p, cc, mac_name);
+ decr_mac_ref (cc);
+ mp_get_x_next (mp);
+ goto RESTART;
+ }
+ goto CONTINUE;
+ }
+}
+
+
+@ The following procedure calls a macro that has two parameters,
+|p| and |cur_exp|.
+
+@c
+static void mp_binary_mac (MP mp, mp_node p, mp_node c, mp_sym n) {
+ mp_node q, r; /* nodes in the parameter list */
+ q = mp_get_symbolic_node (mp);
+ r = mp_get_symbolic_node (mp);
+ mp_link (q) = r;
+ set_mp_sym_sym (q, p);
+ set_mp_sym_sym (r, mp_stash_cur_exp (mp));
+ mp_macro_call (mp, c, q, n);
+}
+
+
+@ The next procedure, |scan_tertiary|, is pretty much the same deal.
+
+@<Declare the basic parsing subroutines@>=
+static void mp_scan_tertiary (MP mp) {
+ mp_node p; /* for list manipulation */
+ halfword c, d; /* operation codes or modifiers */
+ mp_node cc = NULL;
+ mp_sym mac_name = NULL; /* token defined with \&{secondarydef} */
+RESTART:
+ if ((cur_cmd() < mp_min_primary_command) ||
+ (cur_cmd() > mp_max_primary_command))
+ mp_bad_exp (mp, "A tertiary");
+@.A tertiary expression...@>;
+ mp_scan_secondary (mp);
+CONTINUE:
+ if (cur_cmd() <= mp_max_tertiary_command) {
+ if (cur_cmd() >= mp_min_tertiary_command) {
+ p = mp_stash_cur_exp (mp);
+ c = cur_mod();
+ d = cur_cmd();
+ if (d == mp_tertiary_secondary_macro) {
+ cc = cur_mod_node();
+ mac_name = cur_sym();
+ add_mac_ref (cc);
+ }
+ mp_get_x_next (mp);
+ mp_scan_secondary (mp);
+ if (d != mp_tertiary_secondary_macro) {
+ mp_do_binary (mp, p, c);
+ } else {
+ mp_back_input (mp);
+ mp_binary_mac (mp, p, cc, mac_name);
+ decr_mac_ref (cc);
+ mp_get_x_next (mp);
+ goto RESTART;
+ }
+ goto CONTINUE;
+ }
+ }
+}
+
+
+@ Finally we reach the deepest level in our quartet of parsing routines.
+This one is much like the others; but it has an extra complication from
+paths, which materialize here.
+
+@<Declare the basic parsing subroutines@>=
+static int mp_scan_path (MP mp);
+static void mp_scan_expression (MP mp) {
+ int my_var_flag; /* initial value of |var_flag| */
+ my_var_flag = mp->var_flag;
+ check_expansion_depth();
+RESTART:
+ if ((cur_cmd() < mp_min_primary_command) ||
+ (cur_cmd() > mp_max_primary_command))
+ mp_bad_exp (mp, "An");
+@.An expression...@>;
+ mp_scan_tertiary (mp);
+CONTINUE:
+ if (cur_cmd() <= mp_max_expression_command) {
+ if (cur_cmd() >= mp_min_expression_command) {
+ if ((cur_cmd() != mp_equals) || (my_var_flag != mp_assignment)) {
+ mp_node p; /* for list manipulation */
+ mp_node cc = NULL;
+ halfword c;
+ halfword d; /* operation codes or modifiers */
+ mp_sym mac_name; /* token defined with \&{tertiarydef} */
+ mac_name = NULL;
+ p = mp_stash_cur_exp (mp);
+ d = cur_cmd();
+ c = cur_mod();
+ if (d == mp_expression_tertiary_macro) {
+ cc = cur_mod_node();
+ mac_name = cur_sym();
+ add_mac_ref (cc);
+ }
+ if ((d < mp_ampersand) || ((d == mp_ampersand) &&
+ ((mp_type (p) == mp_pair_type)
+ || (mp_type (p) == mp_path_type)))) {
+ /* Scan a path construction operation; but |return| if |p| has the wrong type */
+
+ mp_unstash_cur_exp (mp, p);
+ if (!mp_scan_path(mp)) {
+ mp->expand_depth_count--;
+ return;
+ }
+ } else {
+ mp_get_x_next (mp);
+ mp_scan_tertiary (mp);
+ if (d != mp_expression_tertiary_macro) {
+ mp_do_binary (mp, p, c);
+ } else {
+ mp_back_input (mp);
+ mp_binary_mac (mp, p, cc, mac_name);
+ decr_mac_ref (cc);
+ mp_get_x_next (mp);
+ goto RESTART;
+ }
+ }
+ goto CONTINUE;
+ }
+ }
+ }
+ mp->expand_depth_count--;
+}
+
+
+@ The reader should review the data structure conventions for paths before
+hoping to understand the next part of this code.
+
+@d min_tension three_quarter_unit_t
+
+@<Declare the basic parsing subroutines@>=
+static void force_valid_tension_setting(MP mp) {
+ if ((mp->cur_exp.type != mp_known) || number_less(cur_exp_value_number (), min_tension)) {
+ mp_value new_expr;
+ const char *hlp[] = {
+ "The expression above should have been a number >=3/4.",
+ NULL };
+ memset(&new_expr,0,sizeof(mp_value));
+ new_number(new_expr.data.n);
+ mp_disp_err(mp, NULL);
+ number_clone(new_expr.data.n, unity_t);
+ mp_back_error (mp, "Improper tension has been set to 1", hlp, true);
+ mp_get_x_next (mp);
+ mp_flush_cur_exp (mp, new_expr);
+ }
+}
+static int mp_scan_path (MP mp) {
+ mp_knot path_p, path_q, r;
+ mp_knot pp, qq;
+ halfword d; /* operation code or modifier */
+ boolean cycle_hit; /* did a path expression just end with `\&{cycle}'? */
+ mp_number x, y; /* explicit coordinates or tension at a path join */
+ int t; /* knot type following a path join */
+ t = 0;
+ 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 */
+ if (mp->cur_exp.type == mp_pair_type)
+ path_p = mp_pair_to_knot (mp);
+ else if (mp->cur_exp.type == mp_path_type)
+ path_p = cur_exp_knot ();
+ else
+ return 0;
+ path_q = path_p;
+ while (mp_next_knot (path_q) != path_p)
+ path_q = mp_next_knot (path_q);
+ if (mp_left_type (path_p) != mp_endpoint) { /* open up a cycle */
+ r = mp_copy_knot (mp, path_p);
+ mp_next_knot (path_q) = r;
+ path_q = r;
+ }
+ mp_left_type (path_p) = mp_open;
+ mp_right_type (path_q) = mp_open;
+
+ new_number (y);
+ new_number (x);
+
+CONTINUE_PATH:
+ /* Determine the path join parameters;
+ but |goto finish_path| if there's only a direction specifier */
+ /* At this point |cur_cmd| is either |ampersand|, |left_brace|, or |path_join|. */
+
+ if (cur_cmd() == mp_left_brace) {
+ /* Put the pre-join direction information into node |q| */
+ /* At this point |mp_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 |mp_right_type(q)| in cases such as
+ `\.{..\{curl2\}z\{0,0\}..}'. */
+ t = mp_scan_direction (mp);
+ if (t != mp_open) {
+ mp_right_type (path_q) = (unsigned short) t;
+ number_clone(path_q->right_given, cur_exp_value_number ());
+ if (mp_left_type (path_q) == mp_open) {
+ mp_left_type (path_q) = (unsigned short) t;
+ number_clone(path_q->left_given, cur_exp_value_number ());
+ } /* note that |left_given(q)=left_curl(q)| */
+ }
+ }
+ d = cur_cmd();
+ if (d == mp_path_join) {
+ /* Determine the tension and/or control points */
+ mp_get_x_next (mp);
+ if (cur_cmd() == mp_tension) {
+ /* Set explicit tensions */
+ mp_get_x_next (mp);
+ set_number_from_scaled (y, cur_cmd());
+ if (cur_cmd() == mp_at_least)
+ mp_get_x_next (mp);
+ mp_scan_primary (mp);
+ force_valid_tension_setting(mp);
+ if (number_to_scaled (y) == mp_at_least) {
+ if (is_number(cur_exp_value_number()))
+ number_negate (cur_exp_value_number());
+ }
+ number_clone(path_q->right_tension, cur_exp_value_number ());
+ if (cur_cmd() == mp_and_command) {
+ mp_get_x_next (mp);
+ set_number_from_scaled (y, cur_cmd());
+ if (cur_cmd() == mp_at_least)
+ mp_get_x_next (mp);
+ mp_scan_primary (mp);
+ force_valid_tension_setting(mp);
+ if (number_to_scaled (y) == mp_at_least) {
+ if (is_number(cur_exp_value_number()))
+ number_negate (cur_exp_value_number());
+ }
+ }
+ number_clone (y, cur_exp_value_number ());
+
+ } else if (cur_cmd() == mp_controls) {
+ /* Set explicit control points */
+ mp_right_type (path_q) = mp_explicit;
+ t = mp_explicit;
+ mp_get_x_next (mp);
+ mp_scan_primary (mp);
+ mp_known_pair (mp);
+ number_clone (path_q->right_x, mp->cur_x);
+ number_clone (path_q->right_y, mp->cur_y);
+ if (cur_cmd() != mp_and_command) {
+ number_clone (x, path_q->right_x);
+ number_clone (y, path_q->right_y);
+ } else {
+ mp_get_x_next (mp);
+ mp_scan_primary (mp);
+ mp_known_pair (mp);
+ number_clone (x, mp->cur_x);
+ number_clone (y, mp->cur_y);
+ }
+
+ } else {
+ set_number_to_unity(path_q->right_tension);
+ set_number_to_unity(y);
+ mp_back_input (mp); /* default tension */
+ goto DONE;
+ };
+ if (cur_cmd() != mp_path_join) {
+ const char *hlp[] = { "A path join command should end with two dots.", NULL};
+ mp_back_error (mp, "Missing `..' has been inserted", hlp, true);
+ }
+ DONE:
+ ;
+ } else if (d != mp_ampersand) {
+ goto FINISH_PATH;
+ }
+ mp_get_x_next (mp);
+ if (cur_cmd() == mp_left_brace) {
+ /* Put the post-join direction information into |x| and |t| */
+ /* Since |left_tension| and |mp_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. */
+ t = mp_scan_direction (mp);
+ if (mp_right_type (path_q) != mp_explicit)
+ number_clone (x, cur_exp_value_number ());
+ else
+ t = mp_explicit; /* the direction information is superfluous */
+
+ } else if (mp_right_type (path_q) != mp_explicit) {
+ t = mp_open;
+ set_number_to_zero(x);
+ }
+
+ if (cur_cmd() == mp_cycle) {
+ /* Get ready to close a cycle */
+ /* 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. */
+ cycle_hit = true;
+ mp_get_x_next (mp);
+ pp = path_p;
+ qq = path_p;
+ if (d == mp_ampersand) {
+ if (path_p == path_q) {
+ d = mp_path_join;
+ set_number_to_unity(path_q->right_tension);
+ set_number_to_unity(y);
+ }
+ }
+ } else {
+ mp_scan_tertiary (mp);
+ /* Convert the right operand, |cur_exp|,
+ into a partial path from |pp| to~|qq| */
+ if (mp->cur_exp.type != mp_path_type)
+ pp = mp_pair_to_knot (mp);
+ else
+ pp = cur_exp_knot ();
+ qq = pp;
+ while (mp_next_knot (qq) != pp)
+ qq = mp_next_knot (qq);
+ if (mp_left_type (pp) != mp_endpoint) { /* open up a cycle */
+ r = mp_copy_knot (mp, pp);
+ mp_next_knot (qq) = r;
+ qq = r;
+ }
+ mp_left_type (pp) = mp_open;
+ mp_right_type (qq) = mp_open;
+ }
+ /* Join the partial paths and reset |p| and |q| to the head and tail
+ of the result */
+ if (d == mp_ampersand) {
+ if (!(number_equal (path_q->x_coord, pp->x_coord)) ||
+ !(number_equal (path_q->y_coord, pp->y_coord))) {
+ const char *hlp[] = {
+ "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.",
+ NULL };
+ mp_back_error (mp, "Paths don't touch; `&' will be changed to `..'", hlp, true);
+@.Paths don't touch@>;
+ mp_get_x_next (mp);
+ d = mp_path_join;
+ set_number_to_unity (path_q->right_tension);
+ set_number_to_unity (y);
+ }
+ }
+ /* Plug an opening in |mp_right_type(pp)|, if possible */
+ if (mp_right_type (pp) == mp_open) {
+ if ((t == mp_curl) || (t == mp_given)) {
+ mp_right_type (pp) = (unsigned short) t;
+ number_clone (pp->right_given, x);
+ }
+ }
+ if (d == mp_ampersand) {
+ /* Splice independent paths together */
+ if (mp_left_type (path_q) == mp_open)
+ if (mp_right_type (path_q) == mp_open) {
+ mp_left_type (path_q) = mp_curl;
+ set_number_to_unity(path_q->left_curl);
+ }
+ if (mp_right_type (pp) == mp_open)
+ if (t == mp_open) {
+ mp_right_type (pp) = mp_curl;
+ set_number_to_unity(pp->right_curl);
+ }
+ mp_right_type (path_q) = mp_right_type (pp);
+ mp_next_knot (path_q) = mp_next_knot (pp);
+ number_clone (path_q->right_x, pp->right_x);
+ number_clone (path_q->right_y, pp->right_y);
+ mp_xfree (pp);
+ if (qq == pp)
+ qq = path_q;
+
+ } else {
+ /* Plug an opening in |mp_right_type(q)|, if possible */
+ if (mp_right_type (path_q) == mp_open) {
+ if ((mp_left_type (path_q) == mp_curl) || (mp_left_type (path_q) == mp_given)) {
+ mp_right_type (path_q) = mp_left_type (path_q);
+ number_clone(path_q->right_given, path_q->left_given);
+ }
+ }
+
+ mp_next_knot (path_q) = pp;
+ number_clone (pp->left_y, y);
+ if (t != mp_open) {
+ number_clone (pp->left_x, x);
+ mp_left_type (pp) = (unsigned short) t;
+ };
+ }
+ path_q = qq;
+
+ if (cur_cmd() >= mp_min_expression_command)
+ if (cur_cmd() <= mp_ampersand)
+ if (!cycle_hit)
+ goto CONTINUE_PATH;
+FINISH_PATH:
+ /* Choose control points for the path and put the result into |cur_exp| */
+ if (cycle_hit) {
+ if (d == mp_ampersand)
+ path_p = path_q;
+ } else {
+ mp_left_type (path_p) = mp_endpoint;
+ if (mp_right_type (path_p) == mp_open) {
+ mp_right_type (path_p) = mp_curl;
+ set_number_to_unity(path_p->right_curl);
+ }
+ mp_right_type (path_q) = mp_endpoint;
+ if (mp_left_type (path_q) == mp_open) {
+ mp_left_type (path_q) = mp_curl;
+ set_number_to_unity(path_q->left_curl);
+ }
+ mp_next_knot (path_q) = path_p;
+ }
+ mp_make_choices (mp, path_p);
+ mp->cur_exp.type = mp_path_type;
+ set_cur_exp_knot (path_p);
+
+ free_number (x);
+ free_number (y);
+ return 1;
+}
+
+
+@ A pair of numeric values is changed into a knot node for a one-point path
+when \MP\ discovers that the pair is part of a path.
+
+@c
+static mp_knot mp_pair_to_knot (MP mp) { /* convert a pair to a knot with two endpoints */
+ mp_knot q; /* the new node */
+ q = mp_new_knot(mp);
+ mp_left_type (q) = mp_endpoint;
+ mp_right_type (q) = mp_endpoint;
+ mp_originator (q) = mp_metapost_user;
+ mp_next_knot (q) = q;
+ mp_known_pair (mp);
+ number_clone (q->x_coord, mp->cur_x);
+ number_clone (q->y_coord, mp->cur_y);
+ return q;
+}
+
+
+@ The |known_pair| subroutine sets |cur_x| and |cur_y| to the components
+of the current expression, assuming that the current expression is a
+pair of known numerics. Unknown components are zeroed, and the
+current expression is flushed.
+
+@<Declarations@>=
+static void mp_known_pair (MP mp);
+
+@ @c
+void mp_known_pair (MP mp) {
+ mp_value new_expr;
+ mp_node p; /* the pair node */
+ memset(&new_expr,0,sizeof(mp_value));
+ new_number(new_expr.data.n);
+ if (mp->cur_exp.type != mp_pair_type) {
+ const char *hlp[] = {
+ "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",
+ "you might want to type `I ??" "?' now.)",
+ NULL };
+ mp_disp_err(mp, NULL);
+ mp_back_error (mp, "Undefined coordinates have been replaced by (0,0)", hlp, true);
+ mp_get_x_next (mp);
+ mp_flush_cur_exp (mp, new_expr);
+ set_number_to_zero(mp->cur_x);
+ set_number_to_zero(mp->cur_y);
+ } else {
+ p = value_node (cur_exp_node ());
+ /* Make sure that both |x| and |y| parts of |p| are known;
+ copy them into |cur_x| and |cur_y| */
+ if (mp_type (x_part (p)) == mp_known) {
+ number_clone(mp->cur_x, value_number (x_part (p)));
+ } else {
+ const char *hlp[] = {
+ "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",
+ "you might want to type `I ??" "?' now.)",
+ NULL };
+ mp_disp_err (mp, x_part (p));
+ mp_back_error (mp, "Undefined x coordinate has been replaced by 0", hlp, true);
+ mp_get_x_next (mp);
+ mp_recycle_value (mp, x_part (p));
+ set_number_to_zero(mp->cur_x);
+ }
+ if (mp_type (y_part (p)) == mp_known) {
+ number_clone(mp->cur_y, value_number (y_part (p)));
+ } else {
+ const char *hlp[] = {
+ "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.)",
+ NULL };
+ mp_disp_err (mp, y_part (p));
+ mp_back_error (mp, "Undefined y coordinate has been replaced by 0", hlp, true);
+ mp_get_x_next (mp);
+ mp_recycle_value (mp, y_part (p));
+ set_number_to_zero(mp->cur_y);
+ }
+ mp_flush_cur_exp (mp, new_expr);
+ }
+}
+
+@ The |scan_direction| subroutine looks at the directional information
+that is enclosed in braces, and also scans ahead to the following character.
+A type code is returned, either |open| (if the direction was $(0,0)$),
+or |curl| (if the direction was a curl of known value |cur_exp|), or
+|given| (if the direction is given by the |angle| value that now
+appears in |cur_exp|).
+
+There's nothing difficult about this subroutine, but the program is rather
+lengthy because a variety of potential errors need to be nipped in the bud.
+
+@c
+static quarterword mp_scan_direction (MP mp) {
+ int t; /* the type of information found */
+ mp_get_x_next (mp);
+ if (cur_cmd() == mp_curl_command) {
+ /* Scan a curl specification */
+ mp_get_x_next (mp);
+ mp_scan_expression (mp);
+ if ((mp->cur_exp.type != mp_known) || (number_negative(cur_exp_value_number ()))) {
+ mp_value new_expr;
+ const char *hlp[] = { "A curl must be a known, nonnegative number.", NULL };
+ memset(&new_expr,0,sizeof(mp_value));
+ new_number(new_expr.data.n);
+ set_number_to_unity(new_expr.data.n);
+ mp_disp_err(mp, NULL);
+ mp_back_error (mp, "Improper curl has been replaced by 1", hlp, true);
+ mp_get_x_next (mp);
+ mp_flush_cur_exp (mp, new_expr);
+ }
+ t = mp_curl;
+
+ } else {
+ /* Scan a given direction */
+ mp_scan_expression (mp);
+ if (mp->cur_exp.type > mp_pair_type) {
+ /* Get given directions separated by commas */
+ mp_number xx;
+ new_number(xx);
+ if (mp->cur_exp.type != mp_known) {
+ mp_value new_expr;
+ const char *hlp[] = {
+ "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",
+ "you might want to type `I ??" "?' now.)",
+ NULL };
+ memset(&new_expr,0,sizeof(mp_value));
+ new_number(new_expr.data.n);
+ set_number_to_zero(new_expr.data.n);
+ mp_disp_err(mp, NULL);
+ mp_back_error (mp, "Undefined x coordinate has been replaced by 0", hlp, true);
+ mp_get_x_next (mp);
+ mp_flush_cur_exp (mp, new_expr);
+ }
+ number_clone(xx, cur_exp_value_number ());
+ if (cur_cmd() != mp_comma) {
+ const char *hlp[] = {
+ "I've got the x coordinate of a path direction;",
+ "will look for the y coordinate next.",
+ NULL };
+ mp_back_error (mp, "Missing `,' has been inserted", hlp, true);
+ }
+ mp_get_x_next (mp);
+ mp_scan_expression (mp);
+ if (mp->cur_exp.type != mp_known) {
+ mp_value new_expr;
+ const char *hlp[] = {
+ "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.)",
+ NULL };
+ memset(&new_expr,0,sizeof(mp_value));
+ new_number(new_expr.data.n);
+ set_number_to_zero(new_expr.data.n);
+ mp_disp_err(mp, NULL);
+ mp_back_error (mp, "Undefined y coordinate has been replaced by 0", hlp, true);
+ mp_get_x_next (mp);
+ mp_flush_cur_exp (mp, new_expr);
+ }
+ number_clone(mp->cur_y, cur_exp_value_number ());
+ number_clone(mp->cur_x, xx);
+ free_number(xx);
+
+ } else {
+ mp_known_pair (mp);
+ }
+ if (number_zero(mp->cur_x) && number_zero(mp->cur_y))
+ t = mp_open;
+ else {
+ mp_number narg;
+ new_angle (narg);
+ n_arg (narg, mp->cur_x, mp->cur_y);
+ t = mp_given;
+ set_cur_exp_value_number (narg);
+ free_number (narg);
+ }
+ }
+ if (cur_cmd() != mp_right_brace) {
+ const char *hlp[] = {
+ "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.",
+ NULL };
+ mp_back_error (mp, "Missing `}' has been inserted", hlp, true);
+ }
+ mp_get_x_next (mp);
+ return (quarterword) t;
+}
+
+
+@ Finally, we sometimes need to scan an expression whose value is
+supposed to be either |true_code| or |false_code|.
+
+@d mp_get_boolean(mp) do {
+ mp_get_x_next (mp);
+ mp_scan_expression (mp);
+ if (mp->cur_exp.type != mp_boolean_type) {
+ do_boolean_error(mp);
+ }
+} while (0)
+
+@<Declare the basic parsing subroutines@>=
+static void do_boolean_error (MP mp) {
+ mp_value new_expr;
+ const char *hlp[] = {
+ "The expression shown above should have had a definite",
+ "true-or-false value. I'm changing it to `false'.",
+ NULL };
+ memset(&new_expr,0,sizeof(mp_value));
+ new_number(new_expr.data.n);
+ mp_disp_err(mp, NULL);
+ set_number_from_boolean (new_expr.data.n, mp_false_code);
+ mp_back_error (mp, "Undefined condition will be treated as `false'", hlp, true);
+ mp_get_x_next (mp);
+ mp_flush_cur_exp (mp, new_expr);
+ mp->cur_exp.type = mp_boolean_type;
+}
+
+@ @<Declarations@>=
+static void do_boolean_error (MP mp);
+
+@* Doing the operations.
+The purpose of parsing is primarily to permit people to avoid piles of
+parentheses. But the real work is done after the structure of an expression
+has been recognized; that's when new expressions are generated. We
+turn now to the guts of \MP, which handles individual operators that
+have come through the parsing mechanism.
+
+We'll start with the easy ones that take no operands, then work our way
+up to operators with one and ultimately two arguments. In other words,
+we will write the three procedures |do_nullary|, |do_unary|, and |do_binary|
+that are invoked periodically by the expression scanners.
+
+First let's make sure that all of the primitive operators are in the
+hash table. Although |scan_primary| and its relatives made use of the
+\\{cmd} code for these operators, the \\{do} routines base everything
+on the \\{mod} code. For example, |do_binary| doesn't care whether the
+operation it performs is a |primary_binary| or |secondary_binary|, etc.
+
+@<Put each...@>=
+mp_primitive (mp, "true", mp_nullary, mp_true_code);
+@:true_}{\&{true} primitive@>;
+mp_primitive (mp, "false", mp_nullary, mp_false_code);
+@:false_}{\&{false} primitive@>;
+mp_primitive (mp, "nullpicture", mp_nullary, mp_null_picture_code);
+@:null_picture_}{\&{nullpicture} primitive@>;
+mp_primitive (mp, "nullpen", mp_nullary, mp_null_pen_code);
+@:null_pen_}{\&{nullpen} primitive@>;
+mp_primitive (mp, "readstring", mp_nullary, mp_read_string_op);
+@:read_string_}{\&{readstring} primitive@>;
+mp_primitive (mp, "pencircle", mp_nullary, mp_pen_circle);
+@:pen_circle_}{\&{pencircle} primitive@>;
+mp_primitive (mp, "normaldeviate", mp_nullary, mp_normal_deviate);
+@:normal_deviate_}{\&{normaldeviate} primitive@>;
+mp_primitive (mp, "readfrom", mp_unary, mp_read_from_op);
+@:read_from_}{\&{readfrom} primitive@>;
+mp_primitive (mp, "closefrom", mp_unary, mp_close_from_op);
+@:close_from_}{\&{closefrom} primitive@>;
+mp_primitive (mp, "odd", mp_unary, mp_odd_op);
+@:odd_}{\&{odd} primitive@>;
+mp_primitive (mp, "known", mp_unary, mp_known_op);
+@:known_}{\&{known} primitive@>;
+mp_primitive (mp, "unknown", mp_unary, mp_unknown_op);
+@:unknown_}{\&{unknown} primitive@>;
+mp_primitive (mp, "not", mp_unary, mp_not_op);
+@:not_}{\&{not} primitive@>;
+mp_primitive (mp, "decimal", mp_unary, mp_decimal);
+@:decimal_}{\&{decimal} primitive@>;
+mp_primitive (mp, "reverse", mp_unary, mp_reverse);
+@:reverse_}{\&{reverse} primitive@>;
+mp_primitive (mp, "makepath", mp_unary, mp_make_path_op);
+@:make_path_}{\&{makepath} primitive@>;
+mp_primitive (mp, "makepen", mp_unary, mp_make_pen_op);
+@:make_pen_}{\&{makepen} primitive@>;
+mp_primitive (mp, "oct", mp_unary, mp_oct_op);
+@:oct_}{\&{oct} primitive@>;
+mp_primitive (mp, "hex", mp_unary, mp_hex_op);
+@:hex_}{\&{hex} primitive@>;
+mp_primitive (mp, "ASCII", mp_unary, mp_ASCII_op);
+@:ASCII_}{\&{ASCII} primitive@>;
+mp_primitive (mp, "char", mp_unary, mp_char_op);
+@:char_}{\&{char} primitive@>;
+mp_primitive (mp, "length", mp_unary, mp_length_op);
+@:length_}{\&{length} primitive@>;
+mp_primitive (mp, "turningnumber", mp_unary, mp_turning_op);
+@:turning_number_}{\&{turningnumber} primitive@>;
+mp_primitive (mp, "xpart", mp_unary, mp_x_part);
+@:x_part_}{\&{xpart} primitive@>;
+mp_primitive (mp, "ypart", mp_unary, mp_y_part);
+@:y_part_}{\&{ypart} primitive@>;
+mp_primitive (mp, "xxpart", mp_unary, mp_xx_part);
+@:xx_part_}{\&{xxpart} primitive@>;
+mp_primitive (mp, "xypart", mp_unary, mp_xy_part);
+@:xy_part_}{\&{xypart} primitive@>;
+mp_primitive (mp, "yxpart", mp_unary, mp_yx_part);
+@:yx_part_}{\&{yxpart} primitive@>;
+mp_primitive (mp, "yypart", mp_unary, mp_yy_part);
+@:yy_part_}{\&{yypart} primitive@>;
+mp_primitive (mp, "redpart", mp_unary, mp_red_part);
+@:red_part_}{\&{redpart} primitive@>;
+mp_primitive (mp, "greenpart", mp_unary, mp_green_part);
+@:green_part_}{\&{greenpart} primitive@>;
+mp_primitive (mp, "bluepart", mp_unary, mp_blue_part);
+@:blue_part_}{\&{bluepart} primitive@>;
+mp_primitive (mp, "cyanpart", mp_unary, mp_cyan_part);
+@:cyan_part_}{\&{cyanpart} primitive@>;
+mp_primitive (mp, "magentapart", mp_unary, mp_magenta_part);
+@:magenta_part_}{\&{magentapart} primitive@>;
+mp_primitive (mp, "yellowpart", mp_unary, mp_yellow_part);
+@:yellow_part_}{\&{yellowpart} primitive@>;
+mp_primitive (mp, "blackpart", mp_unary, mp_black_part);
+@:black_part_}{\&{blackpart} primitive@>;
+mp_primitive (mp, "greypart", mp_unary, mp_grey_part);
+@:grey_part_}{\&{greypart} primitive@>;
+mp_primitive (mp, "colormodel", mp_unary, mp_color_model_part);
+@:color_model_part_}{\&{colormodel} primitive@>;
+mp_primitive (mp, "fontpart", mp_unary, mp_font_part);
+@:font_part_}{\&{fontpart} primitive@>;
+mp_primitive (mp, "textpart", mp_unary, mp_text_part);
+@:text_part_}{\&{textpart} primitive@>;
+mp_primitive (mp, "prescriptpart", mp_unary, mp_prescript_part);
+@:prescript_part_}{\&{prescriptpart} primitive@>;
+mp_primitive (mp, "postscriptpart", mp_unary, mp_postscript_part);
+@:postscript_part_}{\&{postscriptpart} primitive@>;
+mp_primitive (mp, "pathpart", mp_unary, mp_path_part);
+@:path_part_}{\&{pathpart} primitive@>;
+mp_primitive (mp, "penpart", mp_unary, mp_pen_part);
+@:pen_part_}{\&{penpart} primitive@>;
+mp_primitive (mp, "dashpart", mp_unary, mp_dash_part);
+@:dash_part_}{\&{dashpart} primitive@>;
+mp_primitive (mp, "sqrt", mp_unary, mp_sqrt_op);
+@:sqrt_}{\&{sqrt} primitive@>;
+mp_primitive (mp, "mexp", mp_unary, mp_m_exp_op);
+@:m_exp_}{\&{mexp} primitive@>;
+mp_primitive (mp, "mlog", mp_unary, mp_m_log_op);
+@:m_log_}{\&{mlog} primitive@>;
+mp_primitive (mp, "sind", mp_unary, mp_sin_d_op);
+@:sin_d_}{\&{sind} primitive@>;
+mp_primitive (mp, "cosd", mp_unary, mp_cos_d_op);
+@:cos_d_}{\&{cosd} primitive@>;
+mp_primitive (mp, "floor", mp_unary, mp_floor_op);
+@:floor_}{\&{floor} primitive@>;
+mp_primitive (mp, "uniformdeviate", mp_unary, mp_uniform_deviate);
+@:uniform_deviate_}{\&{uniformdeviate} primitive@>;
+mp_primitive (mp, "charexists", mp_unary, mp_char_exists_op);
+@:char_exists_}{\&{charexists} primitive@>;
+mp_primitive (mp, "fontsize", mp_unary, mp_font_size);
+@:font_size_}{\&{fontsize} primitive@>;
+mp_primitive (mp, "llcorner", mp_unary, mp_ll_corner_op);
+@:ll_corner_}{\&{llcorner} primitive@>;
+mp_primitive (mp, "lrcorner", mp_unary, mp_lr_corner_op);
+@:lr_corner_}{\&{lrcorner} primitive@>;
+mp_primitive (mp, "ulcorner", mp_unary, mp_ul_corner_op);
+@:ul_corner_}{\&{ulcorner} primitive@>;
+mp_primitive (mp, "urcorner", mp_unary, mp_ur_corner_op);
+@:ur_corner_}{\&{urcorner} primitive@>;
+mp_primitive (mp, "arclength", mp_unary, mp_arc_length);
+@:arc_length_}{\&{arclength} primitive@>;
+mp_primitive (mp, "angle", mp_unary, mp_angle_op);
+@:angle_}{\&{angle} primitive@>;
+mp_primitive (mp, "cycle", mp_cycle, mp_cycle_op);
+@:cycle_}{\&{cycle} primitive@>;
+mp_primitive (mp, "stroked", mp_unary, mp_stroked_op);
+@:stroked_}{\&{stroked} primitive@>;
+mp_primitive (mp, "filled", mp_unary, mp_filled_op);
+@:filled_}{\&{filled} primitive@>;
+mp_primitive (mp, "textual", mp_unary, mp_textual_op);
+@:textual_}{\&{textual} primitive@>;
+mp_primitive (mp, "clipped", mp_unary, mp_clipped_op);
+@:clipped_}{\&{clipped} primitive@>;
+mp_primitive (mp, "bounded", mp_unary, mp_bounded_op);
+@:bounded_}{\&{bounded} primitive@>;
+mp_primitive (mp, "+", mp_plus_or_minus, mp_plus);
+@:+ }{\.{+} primitive@>;
+mp_primitive (mp, "-", mp_plus_or_minus, mp_minus);
+@:- }{\.{-} primitive@>;
+mp_primitive (mp, "*", mp_secondary_binary, mp_times);
+@:* }{\.{*} primitive@>;
+mp_primitive (mp, "/", mp_slash, mp_over);
+mp->frozen_slash = mp_frozen_primitive (mp, "/", mp_slash, mp_over);
+@:/ }{\.{/} primitive@>;
+mp_primitive (mp, "++", mp_tertiary_binary, mp_pythag_add);
+@:++_}{\.{++} primitive@>;
+mp_primitive (mp, "+-+", mp_tertiary_binary, mp_pythag_sub);
+@:+-+_}{\.{+-+} primitive@>;
+mp_primitive (mp, "or", mp_tertiary_binary, mp_or_op);
+@:or_}{\&{or} primitive@>;
+mp_primitive (mp, "and", mp_and_command, mp_and_op);
+@:and_}{\&{and} primitive@>;
+mp_primitive (mp, "<", mp_expression_binary, mp_less_than);
+@:< }{\.{<} primitive@>;
+mp_primitive (mp, "<=", mp_expression_binary, mp_less_or_equal);
+@:<=_}{\.{<=} primitive@>;
+mp_primitive (mp, ">", mp_expression_binary, mp_greater_than);
+@:> }{\.{>} primitive@>;
+mp_primitive (mp, ">=", mp_expression_binary, mp_greater_or_equal);
+@:>=_}{\.{>=} primitive@>;
+mp_primitive (mp, "=", mp_equals, mp_equal_to);
+@:= }{\.{=} primitive@>;
+mp_primitive (mp, "<>", mp_expression_binary, mp_unequal_to);
+@:<>_}{\.{<>} primitive@>;
+mp_primitive (mp, "substring", mp_primary_binary, mp_substring_of);
+@:substring_}{\&{substring} primitive@>;
+mp_primitive (mp, "subpath", mp_primary_binary, mp_subpath_of);
+@:subpath_}{\&{subpath} primitive@>;
+mp_primitive (mp, "directiontime", mp_primary_binary, mp_direction_time_of);
+@:direction_time_}{\&{directiontime} primitive@>;
+mp_primitive (mp, "point", mp_primary_binary, mp_point_of);
+@:point_}{\&{point} primitive@>;
+mp_primitive (mp, "precontrol", mp_primary_binary, mp_precontrol_of);
+@:precontrol_}{\&{precontrol} primitive@>;
+mp_primitive (mp, "postcontrol", mp_primary_binary, mp_postcontrol_of);
+@:postcontrol_}{\&{postcontrol} primitive@>;
+mp_primitive (mp, "penoffset", mp_primary_binary, mp_pen_offset_of);
+@:pen_offset_}{\&{penoffset} primitive@>;
+mp_primitive (mp, "arctime", mp_primary_binary, mp_arc_time_of);
+@:arc_time_of_}{\&{arctime} primitive@>;
+mp_primitive (mp, "mpversion", mp_nullary, mp_version);
+@:mp_verison_}{\&{mpversion} primitive@>;
+mp_primitive (mp, "&", mp_ampersand, mp_concatenate);
+@:!!!}{\.{\&} primitive@>;
+mp_primitive (mp, "rotated", mp_secondary_binary, mp_rotated_by);
+@:rotated_}{\&{rotated} primitive@>;
+mp_primitive (mp, "slanted", mp_secondary_binary, mp_slanted_by);
+@:slanted_}{\&{slanted} primitive@>;
+mp_primitive (mp, "scaled", mp_secondary_binary, mp_scaled_by);
+@:scaled_}{\&{scaled} primitive@>;
+mp_primitive (mp, "shifted", mp_secondary_binary, mp_shifted_by);
+@:shifted_}{\&{shifted} primitive@>;
+mp_primitive (mp, "transformed", mp_secondary_binary, mp_transformed_by);
+@:transformed_}{\&{transformed} primitive@>;
+mp_primitive (mp, "xscaled", mp_secondary_binary, mp_x_scaled);
+@:x_scaled_}{\&{xscaled} primitive@>;
+mp_primitive (mp, "yscaled", mp_secondary_binary, mp_y_scaled);
+@:y_scaled_}{\&{yscaled} primitive@>;
+mp_primitive (mp, "zscaled", mp_secondary_binary, mp_z_scaled);
+@:z_scaled_}{\&{zscaled} primitive@>;
+mp_primitive (mp, "infont", mp_secondary_binary, mp_in_font);
+@:in_font_}{\&{infont} primitive@>;
+mp_primitive (mp, "intersectiontimes", mp_tertiary_binary, mp_intersect);
+@:intersection_times_}{\&{intersectiontimes} primitive@>;
+mp_primitive (mp, "envelope", mp_primary_binary, mp_envelope_of);
+@:envelope_}{\&{envelope} primitive@>;
+mp_primitive (mp, "boundingpath", mp_primary_binary, mp_boundingpath_of);
+@:boundingpath_}{\&{boundingpath} primitive@>;
+mp_primitive (mp, "glyph", mp_primary_binary, mp_glyph_infont);
+@:glyph_infont_}{\&{glyph} primitive@>
+
+
+@ @<Cases of |print_cmd...@>=
+case mp_nullary:
+case mp_unary:
+case mp_primary_binary:
+case mp_secondary_binary:
+case mp_tertiary_binary:
+case mp_expression_binary:
+case mp_cycle:
+case mp_plus_or_minus:
+case mp_slash:
+case mp_ampersand:
+case mp_equals:
+case mp_and_command:
+mp_print_op (mp, (quarterword) m);
+break;
+
+@ OK, let's look at the simplest \\{do} procedure first.
+
+@c
+@<Declare nullary action procedure@>;
+static void mp_do_nullary (MP mp, quarterword c) {
+ check_arith();
+ if (number_greater (internal_value (mp_tracing_commands), two_t))
+ mp_show_cmd_mod (mp, mp_nullary, c);
+ switch (c) {
+ case mp_true_code:
+ case mp_false_code:
+ mp->cur_exp.type = mp_boolean_type;
+ set_cur_exp_value_boolean (c);
+ break;
+ case mp_null_picture_code:
+ mp->cur_exp.type = mp_picture_type;
+ set_cur_exp_node ((mp_node)mp_get_edge_header_node (mp));
+ mp_init_edges (mp, (mp_edge_header_node)cur_exp_node ());
+ break;
+ case mp_null_pen_code:
+ mp->cur_exp.type = mp_pen_type;
+ set_cur_exp_knot (mp_get_pen_circle (mp, zero_t));
+ break;
+ case mp_normal_deviate:
+ {
+ mp_number r;
+ new_number (r);
+ /*|mp_norm_rand (mp, &r)|;*/
+ m_norm_rand (r);
+ mp->cur_exp.type = mp_known;
+ set_cur_exp_value_number (r);
+ free_number (r);
+ }
+ break;
+ case mp_pen_circle:
+ mp->cur_exp.type = mp_pen_type;
+ set_cur_exp_knot (mp_get_pen_circle (mp, unity_t));
+ break;
+ case mp_version:
+ mp->cur_exp.type = mp_string_type;
+ set_cur_exp_str (mp_intern (mp, metapost_version));
+ break;
+ case mp_read_string_op:
+ /* Read a string from the terminal */
+ if (mp->noninteractive || mp->interaction <= mp_nonstop_mode)
+ mp_fatal_error (mp, "*** (cannot readstring in nonstop modes)");
+ mp_begin_file_reading (mp);
+ name = is_read;
+ limit = start;
+ prompt_input ("");
+ mp_finish_read (mp);
+ break;
+ } /* there are no other cases */
+ check_arith();
+}
+
+
+@ @<Declare nullary action procedure@>=
+static void mp_finish_read (MP mp) { /* copy |buffer| line to |cur_exp| */
+ size_t k;
+ str_room (((int) mp->last - (int) start));
+ for (k = (size_t) start; k < mp->last; k++) {
+ append_char (mp->buffer[k]);
+ }
+ mp_end_file_reading (mp);
+ mp->cur_exp.type = mp_string_type;
+ set_cur_exp_str (mp_make_string (mp));
+}
+
+
+@ Things get a bit more interesting when there's an operand. The
+operand to |do_unary| appears in |cur_type| and |cur_exp|.
+
+This complicated if test makes sure that any |bounds| or |clip|
+picture objects that get passed into \&{within} do not raise an
+error when queried using the color part primitives (this is needed
+for backward compatibility) .
+
+@d cur_pic_item mp_link(edge_list(cur_exp_node()))
+@d pict_color_type(A) ((cur_pic_item!=NULL) &&
+ ((!has_color(cur_pic_item))
+ ||
+ (((mp_color_model(cur_pic_item)==A)
+ ||
+ ((mp_color_model(cur_pic_item)==mp_uninitialized_model) &&
+ (number_to_scaled (internal_value(mp_default_color_model))/number_to_scaled (unity_t))==(A))))))
+
+@d boolean_reset(A) if ( (A) ) set_cur_exp_value_boolean(mp_true_code); else set_cur_exp_value_boolean(mp_false_code)
+
+@d type_range(A,B) {
+ if ( (mp->cur_exp.type>=(A)) && (mp->cur_exp.type<=(B)) )
+ set_number_from_boolean (new_expr.data.n, mp_true_code);
+ else
+ set_number_from_boolean (new_expr.data.n, mp_false_code);
+ mp_flush_cur_exp(mp, new_expr);
+ mp->cur_exp.type=mp_boolean_type;
+ }
+@d type_test(A) {
+ if ( mp->cur_exp.type==(mp_variable_type)(A) )
+ set_number_from_boolean (new_expr.data.n, mp_true_code);
+ else
+ set_number_from_boolean (new_expr.data.n, mp_false_code);
+ mp_flush_cur_exp(mp, new_expr);
+ mp->cur_exp.type=mp_boolean_type;
+ }
+
+
+@c
+@<Declare unary action procedures@>;
+static void mp_do_unary (MP mp, quarterword c) {
+ mp_node p; /* for list manipulation */
+ mp_value new_expr;
+ check_arith();
+ if (number_greater (internal_value (mp_tracing_commands), two_t)) {
+ /* Trace the current unary operation */
+ mp_begin_diagnostic (mp);
+ mp_print_nl (mp, "{");
+ mp_print_op (mp, c);
+ mp_print_char (mp, xord ('('));
+ mp_print_exp (mp, NULL, 0); /* show the operand, but not verbosely */
+ mp_print (mp, ")}");
+ mp_end_diagnostic (mp, false);
+ }
+ switch (c) {
+ case mp_plus:
+ if (mp->cur_exp.type < mp_color_type)
+ mp_bad_unary (mp, mp_plus);
+ break;
+ case mp_minus:
+ negate_cur_expr(mp);
+ break;
+ case mp_not_op:
+ if (mp->cur_exp.type != mp_boolean_type) {
+ mp_bad_unary (mp, mp_not_op);
+ } else {
+ halfword bb;
+ if (cur_exp_value_boolean () == mp_true_code)
+ bb = mp_false_code;
+ else
+ bb = mp_true_code;
+ set_cur_exp_value_boolean (bb);
+ }
+ break;
+ case mp_sqrt_op:
+ case mp_m_exp_op:
+ case mp_m_log_op:
+ case mp_sin_d_op:
+ case mp_cos_d_op:
+ case mp_floor_op:
+ case mp_uniform_deviate:
+ case mp_odd_op:
+ case mp_char_exists_op:
+ if (mp->cur_exp.type != mp_known) {
+ mp_bad_unary (mp, c);
+ } else {
+ switch (c) {
+ case mp_sqrt_op:
+ {
+ mp_number r1;
+ new_number (r1);
+ square_rt (r1, cur_exp_value_number ());
+ set_cur_exp_value_number (r1);
+ free_number (r1);
+ }
+ break;
+ case mp_m_exp_op:
+ {
+ mp_number r1;
+ new_number (r1);
+ m_exp (r1, cur_exp_value_number ());
+ set_cur_exp_value_number (r1);
+ free_number (r1);
+ }
+ break;
+ case mp_m_log_op:
+ {
+ mp_number r1;
+ new_number (r1);
+ m_log (r1, cur_exp_value_number ());
+ set_cur_exp_value_number (r1);
+ free_number (r1);
+ }
+ break;
+ case mp_sin_d_op:
+ case mp_cos_d_op:
+ {
+ mp_number n_sin, n_cos, arg1, arg2;
+ new_number (arg1);
+ new_number (arg2);
+ new_fraction (n_sin);
+ new_fraction (n_cos); /* results computed by |n_sin_cos| */
+ number_clone (arg1, cur_exp_value_number());
+ number_clone (arg2, unity_t);
+ number_multiply_int (arg2, 360);
+ number_modulo (arg1, arg2);
+ convert_scaled_to_angle (arg1);
+ n_sin_cos (arg1, n_cos, n_sin);
+ if (c == mp_sin_d_op) {
+ fraction_to_round_scaled (n_sin);
+ set_cur_exp_value_number (n_sin);
+ } else {
+ fraction_to_round_scaled (n_cos);
+ set_cur_exp_value_number (n_cos);
+ }
+ free_number (arg1);
+ free_number (arg2);
+ free_number (n_sin);
+ free_number (n_cos);
+ }
+ break;
+ case mp_floor_op:
+ {
+ mp_number vvx;
+ new_number (vvx);
+ number_clone (vvx, cur_exp_value_number ());
+ floor_scaled (vvx);
+ set_cur_exp_value_number (vvx);
+ free_number (vvx);
+ }
+ break;
+ case mp_uniform_deviate:
+ {
+ mp_number vvx;
+ new_number (vvx);
+ /*|mp_unif_rand (mp, &vvx, cur_exp_value_number ());|*/
+ m_unif_rand (vvx, cur_exp_value_number ());
+ set_cur_exp_value_number (vvx);
+ free_number (vvx);
+ }
+ break;
+ case mp_odd_op:
+ {
+ integer vvx = odd (round_unscaled (cur_exp_value_number ()));
+ boolean_reset (vvx);
+ mp->cur_exp.type = mp_boolean_type;
+ }
+ break;
+ case mp_char_exists_op:
+ /* Determine if a character has been shipped out */
+ set_cur_exp_value_scaled (round_unscaled (cur_exp_value_number ()) % 256);
+ if (number_negative(cur_exp_value_number ())) {
+ halfword vv = number_to_scaled(cur_exp_value_number ());
+ set_cur_exp_value_scaled (vv + 256);
+ }
+ boolean_reset (mp->char_exists[number_to_scaled(cur_exp_value_number ())]);
+ mp->cur_exp.type = mp_boolean_type;
+ break;
+ } /* there are no other cases */
+ }
+ break;
+ case mp_angle_op:
+ if (mp_nice_pair (mp, cur_exp_node (), mp->cur_exp.type)) {
+ mp_number narg;
+ memset(&new_expr,0,sizeof(mp_value));
+ new_number(new_expr.data.n);
+ new_angle (narg);
+ p = value_node (cur_exp_node ());
+ n_arg (narg, value_number (x_part (p)), value_number (y_part (p)));
+ number_clone (new_expr.data.n, narg);
+ convert_angle_to_scaled (new_expr.data.n);
+ free_number (narg);
+ mp_flush_cur_exp (mp, new_expr);
+ } else {
+ mp_bad_unary (mp, mp_angle_op);
+ }
+ break;
+ case mp_x_part:
+ case mp_y_part:
+ if ((mp->cur_exp.type == mp_pair_type)
+ || (mp->cur_exp.type == mp_transform_type))
+ mp_take_part (mp, c);
+ else if (mp->cur_exp.type == mp_picture_type)
+ mp_take_pict_part (mp, c);
+ else
+ mp_bad_unary (mp, c);
+ break;
+ case mp_xx_part:
+ case mp_xy_part:
+ case mp_yx_part:
+ case mp_yy_part:
+ if (mp->cur_exp.type == mp_transform_type)
+ mp_take_part (mp, c);
+ else if (mp->cur_exp.type == mp_picture_type)
+ mp_take_pict_part (mp, c);
+ else
+ mp_bad_unary (mp, c);
+ break;
+ case mp_red_part:
+ case mp_green_part:
+ case mp_blue_part:
+ if (mp->cur_exp.type == mp_color_type)
+ mp_take_part (mp, c);
+ else if (mp->cur_exp.type == mp_picture_type) {
+ if pict_color_type
+ (mp_rgb_model) mp_take_pict_part (mp, c);
+ else
+ mp_bad_color_part (mp, c);
+ } else
+ mp_bad_unary (mp, c);
+ break;
+ case mp_cyan_part:
+ case mp_magenta_part:
+ case mp_yellow_part:
+ case mp_black_part:
+ if (mp->cur_exp.type == mp_cmykcolor_type)
+ mp_take_part (mp, c);
+ else if (mp->cur_exp.type == mp_picture_type) {
+ if pict_color_type
+ (mp_cmyk_model) mp_take_pict_part (mp, c);
+ else
+ mp_bad_color_part (mp, c);
+ } else
+ mp_bad_unary (mp, c);
+ break;
+ case mp_grey_part:
+ if (mp->cur_exp.type == mp_known);
+ else if (mp->cur_exp.type == mp_picture_type) {
+ if pict_color_type
+ (mp_grey_model) mp_take_pict_part (mp, c);
+ else
+ mp_bad_color_part (mp, c);
+ } else
+ mp_bad_unary (mp, c);
+ break;
+ case mp_color_model_part:
+ if (mp->cur_exp.type == mp_picture_type)
+ mp_take_pict_part (mp, c);
+ else
+ mp_bad_unary (mp, c);
+ break;
+ case mp_font_part:
+ case mp_text_part:
+ case mp_path_part:
+ case mp_pen_part:
+ case mp_dash_part:
+ case mp_prescript_part:
+ case mp_postscript_part:
+ if (mp->cur_exp.type == mp_picture_type)
+ mp_take_pict_part (mp, c);
+ else
+ mp_bad_unary (mp, c);
+ break;
+ case mp_char_op:
+ if (mp->cur_exp.type != mp_known) {
+ mp_bad_unary (mp, mp_char_op);
+ } else {
+ int vv = round_unscaled (cur_exp_value_number ()) % 256;
+ set_cur_exp_value_scaled (vv);
+ mp->cur_exp.type = mp_string_type;
+ if (number_negative(cur_exp_value_number ())) {
+ vv = number_to_scaled(cur_exp_value_number ()) + 256;
+ set_cur_exp_value_scaled (vv);
+ }
+ {
+ unsigned char ss[2];
+ ss[0] = (unsigned char) number_to_scaled(cur_exp_value_number ());
+ ss[1] = '\0';
+ set_cur_exp_str (mp_rtsl (mp, (char *) ss, 1));
+ }
+ }
+ break;
+ case mp_decimal:
+ if (mp->cur_exp.type != mp_known) {
+ mp_bad_unary (mp, mp_decimal);
+ } else {
+ mp->old_setting = mp->selector;
+ mp->selector = new_string;
+ print_number (cur_exp_value_number ());
+ set_cur_exp_str (mp_make_string (mp));
+ mp->selector = mp->old_setting;
+ mp->cur_exp.type = mp_string_type;
+ }
+ break;
+ case mp_oct_op:
+ case mp_hex_op:
+ case mp_ASCII_op:
+ if (mp->cur_exp.type != mp_string_type)
+ mp_bad_unary (mp, c);
+ else
+ mp_str_to_num (mp, c);
+ break;
+ case mp_font_size:
+ if (mp->cur_exp.type != mp_string_type) {
+ mp_bad_unary (mp, mp_font_size);
+ } else {
+ /* Find the design size of the font whose name is |cur_exp| */
+ /* One simple application of |find_font| is the implementation of the |font_size|
+ operator that gets the design size for a given font name. */
+ memset(&new_expr,0,sizeof(mp_value));
+ new_number(new_expr.data.n);
+ set_number_from_scaled (new_expr.data.n,
+ (mp->font_dsize[mp_find_font (mp, mp_str (mp, cur_exp_str ()))] + 8) / 16);
+ mp_flush_cur_exp (mp, new_expr);
+ }
+ break;
+ case mp_length_op:
+ /* The length operation is somewhat unusual in that it applies to a variety
+ of different types of operands. */
+ switch (mp->cur_exp.type) {
+ case mp_string_type:
+ memset(&new_expr,0,sizeof(mp_value));
+ new_number(new_expr.data.n);
+ number_clone (new_expr.data.n, unity_t);
+ number_multiply_int(new_expr.data.n, cur_exp_str ()->len);
+ mp_flush_cur_exp (mp, new_expr);
+ break;
+ case mp_path_type:
+ memset(&new_expr,0,sizeof(mp_value));
+ new_number(new_expr.data.n);
+ mp_path_length (mp, &new_expr.data.n);
+ mp_flush_cur_exp (mp, new_expr);
+ break;
+ case mp_known:
+ set_cur_exp_value_number (cur_exp_value_number ());
+ number_abs (cur_exp_value_number ());
+ break;
+ case mp_picture_type:
+ memset(&new_expr,0,sizeof(mp_value));
+ new_number(new_expr.data.n);
+ mp_pict_length (mp, &new_expr.data.n);
+ mp_flush_cur_exp (mp, new_expr);
+ break;
+ default:
+ if (mp_nice_pair (mp, cur_exp_node (), mp->cur_exp.type)) {
+ memset(&new_expr,0,sizeof(mp_value));
+ new_number(new_expr.data.n);
+ pyth_add (new_expr.data.n, value_number (x_part (value_node (cur_exp_node ()))),
+ value_number (y_part (value_node (cur_exp_node ()))));
+ mp_flush_cur_exp (mp, new_expr);
+ } else
+ mp_bad_unary (mp, c);
+ break;
+ }
+ break;
+ case mp_turning_op:
+ if (mp->cur_exp.type == mp_pair_type) {
+ memset(&new_expr,0,sizeof(mp_value));
+ new_number(new_expr.data.n);
+ set_number_to_zero(new_expr.data.n);
+ mp_flush_cur_exp (mp, new_expr);
+ } else if (mp->cur_exp.type != mp_path_type) {
+ mp_bad_unary (mp, mp_turning_op);
+ } else if (mp_left_type (cur_exp_knot ()) == mp_endpoint) {
+ memset(&new_expr,0,sizeof(mp_value));
+ new_number(new_expr.data.n);
+ new_expr.data.p = NULL;
+ mp_flush_cur_exp (mp, new_expr); /* not a cyclic path */
+ } else {
+ memset(&new_expr,0,sizeof(mp_value));
+ new_number(new_expr.data.n);
+ mp_turn_cycles_wrapper (mp, &new_expr.data.n, cur_exp_knot ());
+ mp_flush_cur_exp (mp, new_expr);
+ }
+ break;
+ case mp_boolean_type:
+ memset(&new_expr,0,sizeof(mp_value));
+ new_number(new_expr.data.n);
+ type_range (mp_boolean_type, mp_unknown_boolean);
+ break;
+ case mp_string_type:
+ memset(&new_expr,0,sizeof(mp_value));
+ new_number(new_expr.data.n);
+ type_range (mp_string_type, mp_unknown_string);
+ break;
+ case mp_pen_type:
+ memset(&new_expr,0,sizeof(mp_value));
+ new_number(new_expr.data.n);
+ type_range (mp_pen_type, mp_unknown_pen);
+ break;
+ case mp_path_type:
+ memset(&new_expr,0,sizeof(mp_value));
+ new_number(new_expr.data.n);
+ type_range (mp_path_type, mp_unknown_path);
+ break;
+ case mp_picture_type:
+ memset(&new_expr,0,sizeof(mp_value));
+ new_number(new_expr.data.n);
+ type_range (mp_picture_type, mp_unknown_picture);
+ break;
+ case mp_transform_type:
+ case mp_color_type:
+ case mp_cmykcolor_type:
+ case mp_pair_type:
+ memset(&new_expr,0,sizeof(mp_value));
+ new_number(new_expr.data.n);
+ type_test (c);
+ break;
+ case mp_numeric_type:
+ memset(&new_expr,0,sizeof(mp_value));
+ new_number(new_expr.data.n);
+ type_range (mp_known, mp_independent);
+ break;
+ case mp_known_op:
+ case mp_unknown_op:
+ mp_test_known (mp, c);
+ break;
+ case mp_cycle_op:
+ memset(&new_expr,0,sizeof(mp_value));
+ new_number(new_expr.data.n);
+ if (mp->cur_exp.type != mp_path_type)
+ set_number_from_boolean (new_expr.data.n, mp_false_code);
+ else if (mp_left_type (cur_exp_knot ()) != mp_endpoint)
+ set_number_from_boolean (new_expr.data.n, mp_true_code);
+ else
+ set_number_from_boolean (new_expr.data.n, mp_false_code);
+ mp_flush_cur_exp (mp, new_expr);
+ mp->cur_exp.type = mp_boolean_type;
+ break;
+ case mp_arc_length:
+ if (mp->cur_exp.type == mp_pair_type)
+ mp_pair_to_path (mp);
+ if (mp->cur_exp.type != mp_path_type) {
+ mp_bad_unary (mp, mp_arc_length);
+ } else {
+ memset(&new_expr,0,sizeof(mp_value));
+ new_number(new_expr.data.n);
+ mp_get_arc_length (mp, &new_expr.data.n, cur_exp_knot ());
+ mp_flush_cur_exp (mp, new_expr);
+ }
+ break;
+ case mp_filled_op:
+ case mp_stroked_op:
+ case mp_textual_op:
+ case mp_clipped_op:
+ case mp_bounded_op:
+ /* Here we use the fact that |c-filled_op+fill_code| is the desired graphical
+ object |type|. */
+@^data structure assumptions@>
+ memset(&new_expr,0,sizeof(mp_value));
+ new_number(new_expr.data.n);
+ if (mp->cur_exp.type != mp_picture_type) {
+ set_number_from_boolean (new_expr.data.n, mp_false_code);
+ } else if (mp_link (edge_list (cur_exp_node ())) == NULL) {
+ set_number_from_boolean (new_expr.data.n, mp_false_code);
+ } else if (mp_type (mp_link (edge_list (cur_exp_node ()))) ==
+ (mp_variable_type) (c + mp_fill_node_type - mp_filled_op)) {
+ set_number_from_boolean (new_expr.data.n, mp_true_code);
+ } else {
+ set_number_from_boolean (new_expr.data.n, mp_false_code);
+ }
+ mp_flush_cur_exp (mp, new_expr);
+ mp->cur_exp.type = mp_boolean_type;
+ break;
+ case mp_make_pen_op:
+ if (mp->cur_exp.type == mp_pair_type)
+ mp_pair_to_path (mp);
+ if (mp->cur_exp.type != mp_path_type)
+ mp_bad_unary (mp, mp_make_pen_op);
+ else {
+ mp->cur_exp.type = mp_pen_type;
+ set_cur_exp_knot (mp_make_pen (mp, cur_exp_knot (), true));
+ }
+ break;
+ case mp_make_path_op:
+ if (mp->cur_exp.type != mp_pen_type) {
+ mp_bad_unary (mp, mp_make_path_op);
+ } else {
+ mp->cur_exp.type = mp_path_type;
+ mp_make_path (mp, cur_exp_knot ());
+ }
+ break;
+ case mp_reverse:
+ if (mp->cur_exp.type == mp_path_type) {
+ mp_knot pk = mp_htap_ypoc (mp, cur_exp_knot ());
+ if (mp_right_type (pk) == mp_endpoint)
+ pk = mp_next_knot (pk);
+ mp_toss_knot_list (mp, cur_exp_knot ());
+ set_cur_exp_knot (pk);
+ } else if (mp->cur_exp.type == mp_pair_type) {
+ mp_pair_to_path (mp);
+ } else {
+ mp_bad_unary (mp, mp_reverse);
+ }
+ break;
+ case mp_ll_corner_op:
+ if (!mp_get_cur_bbox (mp))
+ mp_bad_unary (mp, mp_ll_corner_op);
+ else
+ mp_pair_value (mp, mp_minx, mp_miny);
+ break;
+ case mp_lr_corner_op:
+ if (!mp_get_cur_bbox (mp))
+ mp_bad_unary (mp, mp_lr_corner_op);
+ else
+ mp_pair_value (mp, mp_maxx, mp_miny);
+ break;
+ case mp_ul_corner_op:
+ if (!mp_get_cur_bbox (mp))
+ mp_bad_unary (mp, mp_ul_corner_op);
+ else
+ mp_pair_value (mp, mp_minx, mp_maxy);
+ break;
+ case mp_ur_corner_op:
+ if (!mp_get_cur_bbox (mp))
+ mp_bad_unary (mp, mp_ur_corner_op);
+ else
+ mp_pair_value (mp, mp_maxx, mp_maxy);
+ break;
+ case mp_read_from_op:
+ case mp_close_from_op:
+ if (mp->cur_exp.type != mp_string_type)
+ mp_bad_unary (mp, c);
+ else
+ mp_do_read_or_close (mp, c);
+ break;
+
+ } /* there are no other cases */
+ check_arith();
+}
+
+
+@ The |nice_pair| function returns |true| if both components of a pair
+are known.
+
+@<Declare unary action procedures@>=
+static boolean mp_nice_pair (MP mp, mp_node p, quarterword t) {
+ (void) mp;
+ if (t == mp_pair_type) {
+ p = value_node (p);
+ if (mp_type (x_part (p)) == mp_known)
+ if (mp_type (y_part (p)) == mp_known)
+ return true;
+ }
+ return false;
+}
+
+
+@ The |nice_color_or_pair| function is analogous except that it also accepts
+fully known colors.
+
+@<Declare unary action procedures@>=
+static boolean mp_nice_color_or_pair (MP mp, mp_node p, quarterword t) {
+ mp_node q;
+ (void) mp;
+ switch (t) {
+ case mp_pair_type:
+ q = value_node (p);
+ if (mp_type (x_part (q)) == mp_known)
+ if (mp_type (y_part (q)) == mp_known)
+ return true;
+ break;
+ case mp_color_type:
+ q = value_node (p);
+ if (mp_type (red_part (q)) == mp_known)
+ if (mp_type (green_part (q)) == mp_known)
+ if (mp_type (blue_part (q)) == mp_known)
+ return true;
+ break;
+ case mp_cmykcolor_type:
+ q = value_node (p);
+ if (mp_type (cyan_part (q)) == mp_known)
+ if (mp_type (magenta_part (q)) == mp_known)
+ if (mp_type (yellow_part (q)) == mp_known)
+ if (mp_type (black_part (q)) == mp_known)
+ return true;
+ break;
+ }
+ return false;
+}
+
+
+@ @<Declare unary action...@>=
+static void mp_print_known_or_unknown_type (MP mp, quarterword t, mp_node v) {
+ mp_print_char (mp, xord ('('));
+ if (t > mp_known)
+ mp_print (mp, "unknown numeric");
+ else {
+ if ((t == mp_pair_type) || (t == mp_color_type) || (t == mp_cmykcolor_type))
+ if (!mp_nice_color_or_pair (mp, v, t))
+ mp_print (mp, "unknown ");
+ mp_print_type (mp, t);
+ }
+ mp_print_char (mp, xord (')'));
+}
+
+
+@ @<Declare unary action...@>=
+static void mp_bad_unary (MP mp, quarterword c) {
+ char msg[256];
+ mp_string sname;
+ int old_setting = mp->selector;
+ const char *hlp[] = {
+ "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.",
+ NULL };
+ mp->selector = new_string;
+ mp_print_op (mp, c);
+ mp_print_known_or_unknown_type (mp, mp->cur_exp.type, cur_exp_node ());
+ sname = mp_make_string(mp);
+ mp->selector = old_setting;
+ mp_snprintf (msg, 256, "Not implemented: %s", mp_str(mp, sname));
+ delete_str_ref(sname);
+ mp_disp_err(mp, NULL);
+ mp_back_error (mp, msg, hlp, true);
+@.Not implemented...@>;
+ mp_get_x_next (mp);
+}
+
+
+
+@ Negation is easy except when the current expression
+is of type |independent|, or when it is a pair with one or more
+|independent| components.
+
+@<Declare unary action...@>=
+static void mp_negate_dep_list (MP mp, mp_value_node p) {
+ (void) mp;
+ while (1) {
+ number_negate (dep_value (p));
+ if (dep_info (p) == NULL)
+ return;
+ p = (mp_value_node) mp_link (p);
+ }
+}
+
+
+@ 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).
+
+@d negate_value(A) if (mp_type (A) == mp_known) {
+ set_value_number(A, (value_number (A))); /* to clear the rest */
+ number_negate (value_number (A));
+ } else {
+ mp_negate_dep_list (mp, (mp_value_node) dep_list ((mp_value_node) A));
+ }
+
+@<Declare unary action...@>=
+static void negate_cur_expr(MP mp) {
+ mp_node p, q, r; /* for list manipulation */
+ switch (mp->cur_exp.type) {
+ case mp_color_type:
+ case mp_cmykcolor_type:
+ case mp_pair_type:
+ case mp_independent:
+ q = cur_exp_node ();
+ mp_make_exp_copy (mp, q);
+ if (mp->cur_exp.type == mp_dependent) {
+ mp_negate_dep_list (mp, (mp_value_node) dep_list ((mp_value_node)
+ cur_exp_node ()));
+ } else if (mp->cur_exp.type <= mp_pair_type) {
+ /* |mp_color_type| |mp_cmykcolor_type|, or |mp_pair_type| */
+ p = value_node (cur_exp_node ());
+ switch (mp->cur_exp.type) {
+ case mp_pair_type:
+ r = x_part (p);
+ negate_value (r);
+ r = y_part (p);
+ negate_value (r);
+ break;
+ case mp_color_type:
+ r = red_part (p);
+ negate_value (r);
+ r = green_part (p);
+ negate_value (r);
+ r = blue_part (p);
+ negate_value (r);
+ break;
+ case mp_cmykcolor_type:
+ r = cyan_part (p);
+ negate_value (r);
+ r = magenta_part (p);
+ negate_value (r);
+ r = yellow_part (p);
+ negate_value (r);
+ r = black_part (p);
+ negate_value (r);
+ break;
+ default: /* there are no other valid cases, but please the compiler */
+ break;
+ }
+ } /* if |cur_type=mp_known| then |cur_exp=0| */
+ mp_recycle_value (mp, q);
+ mp_free_value_node (mp, q);
+ break;
+ case mp_dependent:
+ case mp_proto_dependent:
+ mp_negate_dep_list (mp, (mp_value_node) dep_list ((mp_value_node)
+ cur_exp_node ()));
+ break;
+ case mp_known:
+ if (is_number(cur_exp_value_number()))
+ number_negate (cur_exp_value_number());
+ break;
+ default:
+ mp_bad_unary (mp, mp_minus);
+ break;
+ }
+}
+
+@ If the current expression is a pair, but the context wants it to
+be a path, we call |pair_to_path|.
+
+@<Declare unary action...@>=
+static void mp_pair_to_path (MP mp) {
+ set_cur_exp_knot (mp_pair_to_knot (mp));
+ mp->cur_exp.type = mp_path_type;
+}
+
+
+
+@ @<Declarations@>=
+static void mp_bad_color_part (MP mp, quarterword c);
+
+@ @c
+static void mp_bad_color_part (MP mp, quarterword c) {
+ mp_node p; /* the big node */
+ mp_value new_expr;
+ char msg[256];
+ int old_setting;
+ mp_string sname;
+ const char *hlp[] = {
+ "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.",
+ NULL };
+ memset(&new_expr,0,sizeof(mp_value));
+ new_number(new_expr.data.n);
+ p = mp_link (edge_list (cur_exp_node ()));
+ mp_disp_err(mp, NULL);
+ old_setting = mp->selector;
+ mp->selector = new_string;
+ mp_print_op (mp, c);
+ sname = mp_make_string(mp);
+ mp->selector = old_setting;
+@.Wrong picture color model...@>;
+ if (mp_color_model (p) == mp_grey_model)
+ mp_snprintf (msg, 256, "Wrong picture color model: %s of grey object", mp_str(mp, sname));
+ else if (mp_color_model (p) == mp_cmyk_model)
+ mp_snprintf (msg, 256, "Wrong picture color model: %s of cmyk object", mp_str(mp, sname));
+ else if (mp_color_model (p) == mp_rgb_model)
+ mp_snprintf (msg, 256, "Wrong picture color model: %s of rgb object", mp_str(mp, sname));
+ else if (mp_color_model (p) == mp_no_model)
+ mp_snprintf (msg, 256, "Wrong picture color model: %s of marking object", mp_str(mp, sname));
+ else
+ mp_snprintf (msg, 256, "Wrong picture color model: %s of defaulted object", mp_str(mp, sname));
+ delete_str_ref(sname);
+ mp_error (mp, msg, hlp, true);
+ if (c == mp_black_part)
+ number_clone (new_expr.data.n, unity_t);
+ else
+ set_number_to_zero(new_expr.data.n);
+ mp_flush_cur_exp (mp, new_expr);
+}
+
+
+@ 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...@>=
+static void mp_take_part (MP mp, quarterword c) {
+ mp_node p; /* the big node */
+ p = value_node (cur_exp_node ());
+ set_value_node (mp->temp_val, p);
+ mp_type (mp->temp_val) = mp->cur_exp.type;
+ mp_link (p) = mp->temp_val;
+ mp_free_value_node (mp, cur_exp_node ());
+ switch (c) {
+ case mp_x_part:
+ if (mp->cur_exp.type == mp_pair_type)
+ mp_make_exp_copy (mp, x_part (p));
+ else
+ mp_make_exp_copy (mp, tx_part (p));
+ break;
+ case mp_y_part:
+ if (mp->cur_exp.type == mp_pair_type)
+ mp_make_exp_copy (mp, y_part (p));
+ else
+ mp_make_exp_copy (mp, ty_part (p));
+ break;
+ case mp_xx_part:
+ mp_make_exp_copy (mp, xx_part (p));
+ break;
+ case mp_xy_part:
+ mp_make_exp_copy (mp, xy_part (p));
+ break;
+ case mp_yx_part:
+ mp_make_exp_copy (mp, yx_part (p));
+ break;
+ case mp_yy_part:
+ mp_make_exp_copy (mp, yy_part (p));
+ break;
+ case mp_red_part:
+ mp_make_exp_copy (mp, red_part (p));
+ break;
+ case mp_green_part:
+ mp_make_exp_copy (mp, green_part (p));
+ break;
+ case mp_blue_part:
+ mp_make_exp_copy (mp, blue_part (p));
+ break;
+ case mp_cyan_part:
+ mp_make_exp_copy (mp, cyan_part (p));
+ break;
+ case mp_magenta_part:
+ mp_make_exp_copy (mp, magenta_part (p));
+ break;
+ case mp_yellow_part:
+ mp_make_exp_copy (mp, yellow_part (p));
+ break;
+ case mp_black_part:
+ mp_make_exp_copy (mp, black_part (p));
+ break;
+ }
+ mp_recycle_value (mp, mp->temp_val);
+}
+
+
+@ @<Initialize table entries@>=
+mp->temp_val = mp_get_value_node (mp);
+mp_name_type (mp->temp_val) = mp_capsule;
+
+@ @<Free table entries@>=
+mp_free_value_node (mp, mp->temp_val);
+
+
+@ @<Declarations@>=
+static mp_edge_header_node mp_scale_edges (MP mp, mp_number se_sf, mp_edge_header_node se_pic);
+
+@ @<Declare unary action...@>=
+static void mp_take_pict_part (MP mp, quarterword c) {
+ mp_node p; /* first graphical object in |cur_exp| */
+ mp_value new_expr;
+ memset(&new_expr,0,sizeof(mp_value));
+ new_number(new_expr.data.n);
+ p = mp_link (edge_list (cur_exp_node ()));
+ if (p != NULL) {
+ switch (c) {
+ case mp_x_part:
+ case mp_y_part:
+ case mp_xx_part:
+ case mp_xy_part:
+ case mp_yx_part:
+ case mp_yy_part:
+ if (mp_type (p) == mp_text_node_type) {
+ mp_text_node p0 = (mp_text_node)p;
+ switch (c) {
+ case mp_x_part:
+ number_clone(new_expr.data.n, p0->tx);
+ break;
+ case mp_y_part:
+ number_clone(new_expr.data.n, p0->ty);
+ break;
+ case mp_xx_part:
+ number_clone(new_expr.data.n, p0->txx);
+ break;
+ case mp_xy_part:
+ number_clone(new_expr.data.n, p0->txy);
+ break;
+ case mp_yx_part:
+ number_clone(new_expr.data.n, p0->tyx);
+ break;
+ case mp_yy_part:
+ number_clone(new_expr.data.n, p0->tyy);
+ break;
+ }
+ mp_flush_cur_exp (mp, new_expr);
+ } else
+ goto NOT_FOUND;
+ break;
+ case mp_red_part:
+ case mp_green_part:
+ case mp_blue_part:
+ if (has_color (p)) {
+ switch (c) {
+ case mp_red_part:
+ number_clone(new_expr.data.n,((mp_stroked_node)p)->red);
+ break;
+ case mp_green_part:
+ number_clone(new_expr.data.n,((mp_stroked_node)p)->green);
+ break;
+ case mp_blue_part:
+ number_clone(new_expr.data.n,((mp_stroked_node)p)->blue);
+ break;
+ }
+ mp_flush_cur_exp (mp, new_expr);
+ } else
+ goto NOT_FOUND;
+ break;
+ case mp_cyan_part:
+ case mp_magenta_part:
+ case mp_yellow_part:
+ case mp_black_part:
+ if (has_color (p)) {
+ if (mp_color_model (p) == mp_uninitialized_model && c == mp_black_part) {
+ set_number_to_unity(new_expr.data.n);
+ } else {
+ switch (c) {
+ case mp_cyan_part:
+ number_clone(new_expr.data.n,((mp_stroked_node)p)->cyan);
+ break;
+ case mp_magenta_part:
+ number_clone(new_expr.data.n,((mp_stroked_node)p)->magenta);
+ break;
+ case mp_yellow_part:
+ number_clone(new_expr.data.n,((mp_stroked_node)p)->yellow);
+ break;
+ case mp_black_part:
+ number_clone(new_expr.data.n,((mp_stroked_node)p)->black);
+ break;
+ }
+ }
+ mp_flush_cur_exp (mp, new_expr);
+ } else
+ goto NOT_FOUND;
+ break;
+ case mp_grey_part:
+ if (has_color (p)) {
+ number_clone(new_expr.data.n,((mp_stroked_node)p)->grey);
+ mp_flush_cur_exp (mp, new_expr);
+ } else
+ goto NOT_FOUND;
+ break;
+ case mp_color_model_part:
+ if (has_color (p)) {
+ if (mp_color_model (p) == mp_uninitialized_model) {
+ number_clone (new_expr.data.n, internal_value (mp_default_color_model));
+ } else {
+ number_clone (new_expr.data.n, unity_t);
+ number_multiply_int (new_expr.data.n, mp_color_model (p));
+ }
+ mp_flush_cur_exp (mp, new_expr);
+ } else
+ goto NOT_FOUND;
+ break;
+ case mp_text_part:
+ if (mp_type (p) != mp_text_node_type)
+ goto NOT_FOUND;
+ else {
+ new_expr.data.str = mp_text_p (p);
+ add_str_ref (new_expr.data.str);
+ mp_flush_cur_exp (mp, new_expr);
+ mp->cur_exp.type = mp_string_type;
+ };
+ break;
+ case mp_prescript_part:
+ if (!has_color (p)) {
+ goto NOT_FOUND;
+ } else {
+ if (mp_pre_script(p)) {
+ new_expr.data.str = mp_pre_script(p);
+ add_str_ref (new_expr.data.str);
+ } else {
+ new_expr.data.str = mp_rts(mp,"");
+ }
+ mp_flush_cur_exp (mp, new_expr);
+ mp->cur_exp.type = mp_string_type;
+ };
+ break;
+ case mp_postscript_part:
+ if (!has_color (p)) {
+ goto NOT_FOUND;
+ } else {
+ if (mp_post_script(p)) {
+ new_expr.data.str = mp_post_script(p);
+ add_str_ref (new_expr.data.str);
+ } else {
+ new_expr.data.str = mp_rts(mp,"");
+ }
+ mp_flush_cur_exp (mp, new_expr);
+ mp->cur_exp.type = mp_string_type;
+ };
+ break;
+ case mp_font_part:
+ if (mp_type (p) != mp_text_node_type)
+ goto NOT_FOUND;
+ else {
+ new_expr.data.str = mp_rts (mp, mp->font_name[mp_font_n (p)]);
+ add_str_ref (new_expr.data.str);
+ mp_flush_cur_exp (mp, new_expr);
+ mp->cur_exp.type = mp_string_type;
+ };
+ break;
+ case mp_path_part:
+ if (mp_type (p) == mp_text_node_type) {
+ goto NOT_FOUND;
+ } else if (is_stop (p)) {
+ mp_confusion (mp, "pict");
+ } else {
+ new_expr.data.node = NULL;
+ switch (mp_type (p)) {
+ case mp_fill_node_type:
+ new_expr.data.p = mp_copy_path (mp, mp_path_p ((mp_fill_node) p));
+ break;
+ case mp_stroked_node_type:
+ new_expr.data.p = mp_copy_path (mp, mp_path_p ((mp_stroked_node) p));
+ break;
+ case mp_start_bounds_node_type:
+ new_expr.data.p = mp_copy_path (mp, mp_path_p ((mp_start_bounds_node) p));
+ break;
+ case mp_start_clip_node_type:
+ new_expr.data.p = mp_copy_path (mp, mp_path_p ((mp_start_clip_node) p));
+ break;
+ default:
+ assert (0);
+ break;
+ }
+ mp_flush_cur_exp (mp, new_expr);
+ mp->cur_exp.type = mp_path_type;
+ }
+ break;
+ case mp_pen_part:
+ if (!has_pen (p)) {
+ goto NOT_FOUND;
+ } else {
+ switch (mp_type (p)) {
+ case mp_fill_node_type:
+ if (mp_pen_p ((mp_fill_node) p) == NULL)
+ goto NOT_FOUND;
+ else {
+ new_expr.data.p = copy_pen (mp_pen_p ((mp_fill_node) p));
+ mp_flush_cur_exp (mp, new_expr);
+ mp->cur_exp.type = mp_pen_type;
+ }
+ break;
+ case mp_stroked_node_type:
+ if (mp_pen_p ((mp_stroked_node) p) == NULL)
+ goto NOT_FOUND;
+ else {
+ new_expr.data.p = copy_pen (mp_pen_p ((mp_stroked_node) p));
+ mp_flush_cur_exp (mp, new_expr);
+ mp->cur_exp.type = mp_pen_type;
+ }
+ break;
+ default:
+ assert (0);
+ break;
+ }
+ }
+ break;
+ case mp_dash_part:
+ if (mp_type (p) != mp_stroked_node_type) {
+ goto NOT_FOUND;
+ } else {
+ if (mp_dash_p (p) == NULL) {
+ goto NOT_FOUND;
+ } else {
+ add_edge_ref (mp_dash_p (p));
+ new_expr.data.node = (mp_node)mp_scale_edges (mp, ((mp_stroked_node)p)->dash_scale,
+ (mp_edge_header_node)mp_dash_p (p));
+ mp_flush_cur_exp (mp, new_expr);
+ mp->cur_exp.type = mp_picture_type;
+ }
+ }
+ break;
+ } /* all cases have been enumerated */
+ return;
+ };
+NOT_FOUND:
+ /* Convert the current expression to a NULL value appropriate for |c| */
+ switch (c) {
+ case mp_text_part:
+ case mp_font_part:
+ case mp_prescript_part:
+ case mp_postscript_part:
+ new_expr.data.str = mp_rts(mp,"");
+ mp_flush_cur_exp (mp, new_expr);
+ mp->cur_exp.type = mp_string_type;
+ break;
+ case mp_path_part:
+ new_expr.data.p = mp_new_knot (mp);
+ mp_flush_cur_exp (mp, new_expr);
+ mp_left_type (cur_exp_knot ()) = mp_endpoint;
+ mp_right_type (cur_exp_knot ()) = mp_endpoint;
+ mp_next_knot (cur_exp_knot ()) = cur_exp_knot ();
+ set_number_to_zero(cur_exp_knot ()->x_coord);
+ set_number_to_zero(cur_exp_knot ()->y_coord);
+ mp_originator (cur_exp_knot ()) = mp_metapost_user;
+ mp->cur_exp.type = mp_path_type;
+ break;
+ case mp_pen_part:
+ new_expr.data.p = mp_get_pen_circle (mp, zero_t);
+ mp_flush_cur_exp (mp, new_expr);
+ mp->cur_exp.type = mp_pen_type;
+ break;
+ case mp_dash_part:
+ new_expr.data.node = (mp_node)mp_get_edge_header_node (mp);
+ mp_flush_cur_exp (mp, new_expr);
+ mp_init_edges (mp, (mp_edge_header_node)cur_exp_node ());
+ mp->cur_exp.type = mp_picture_type;
+ break;
+ default:
+ set_number_to_zero(new_expr.data.n);
+ mp_flush_cur_exp (mp, new_expr);
+ break;
+ }
+}
+
+@ @<Declare unary action...@>=
+static void mp_str_to_num (MP mp, quarterword c) { /* converts a string to a number */
+ integer n; /* accumulator */
+ ASCII_code m; /* current character */
+ unsigned k; /* index into |str_pool| */
+ int b; /* radix of conversion */
+ boolean bad_char; /* did the string contain an invalid digit? */
+ mp_value new_expr;
+ memset(&new_expr,0,sizeof(mp_value));
+ new_number(new_expr.data.n);
+ if (c == mp_ASCII_op) {
+ if (cur_exp_str ()->len == 0)
+ n = -1;
+ else
+ n = cur_exp_str ()->str[0];
+ } else {
+ if (c == mp_oct_op)
+ b = 8;
+ else
+ b = 16;
+ n = 0;
+ bad_char = false;
+ for (k = 0; k < cur_exp_str ()->len; k++) {
+ m = (ASCII_code) (*(cur_exp_str ()->str + k));
+ if ((m >= '0') && (m <= '9'))
+ m = (ASCII_code) (m - '0');
+ else if ((m >= 'A') && (m <= 'F'))
+ m = (ASCII_code) (m - 'A' + 10);
+ else if ((m >= 'a') && (m <= 'f'))
+ m = (ASCII_code) (m - 'a' + 10);
+ else {
+ bad_char = true;
+ m = 0;
+ };
+ if ((int) m >= b) {
+ bad_char = true;
+ m = 0;
+ };
+ if (n < 32768 / b)
+ n = n * b + m;
+ else
+ n = 32767;
+ }
+ /* Give error messages if |bad_char| or |n>=4096| */
+ if (bad_char) {
+ const char *hlp[] = {"I zeroed out characters that weren't hex digits.", NULL};
+ if (c == mp_oct_op) {
+ hlp[0] = "I zeroed out characters that weren't in the range 0..7.";
+ }
+ mp_disp_err(mp, NULL);
+ mp_back_error (mp, "String contains illegal digits", hlp, true);
+ mp_get_x_next (mp);
+ }
+ if ((n > 4095)) { /* todo, this is scaled specific */
+ if (number_positive (internal_value (mp_warning_check))) {
+ char msg[256];
+ const char *hlp[] = {
+ "I have trouble with numbers greater than 4095; watch out.",
+ "(Set warningcheck:=0 to suppress this message.)",
+ NULL };
+ mp_snprintf (msg, 256,"Number too large (%d)", (int)n);
+ mp_back_error (mp, msg, hlp, true);
+ mp_get_x_next (mp);
+ }
+ }
+ }
+ number_clone (new_expr.data.n, unity_t);
+ number_multiply_int(new_expr.data.n, n);
+ mp_flush_cur_exp (mp, new_expr);
+}
+
+@ @<Declare unary action...@>=
+static void mp_path_length (MP mp, mp_number *n) { /* computes the length of the current path */
+ mp_knot p; /* traverser */
+ set_number_to_zero (*n);
+ p = cur_exp_knot ();
+ if (mp_left_type (p) == mp_endpoint) {
+ number_substract(*n, unity_t); /* -unity */
+ }
+ do {
+ p = mp_next_knot (p);
+ number_add(*n, unity_t);
+ } while (p != cur_exp_knot ());
+}
+
+
+@ @<Declare unary action...@>=
+static void mp_pict_length (MP mp, mp_number *n) {
+ /* counts interior components in picture |cur_exp| */
+ mp_node p; /* traverser */
+ set_number_to_zero (*n);
+ p = mp_link (edge_list (cur_exp_node ()));
+ if (p != NULL) {
+ if (is_start_or_stop (p))
+ if (mp_skip_1component (mp, p) == NULL)
+ p = mp_link (p);
+ while (p != NULL) {
+ if ( ! is_start_or_stop(p) )
+ p = mp_link(p);
+ else if ( ! is_stop(p))
+ p = mp_skip_1component(mp, p);
+ else
+ return;
+ number_add(*n, unity_t);
+ }
+ }
+}
+
+
+@ The function |an_angle| returns the value of the |angle| primitive, or $0$ if the
+argument is |origin|.
+
+@<Declare unary action...@>=
+static void mp_an_angle (MP mp, mp_number *ret, mp_number xpar, mp_number ypar) {
+ set_number_to_zero (*ret);
+ if ((!(number_zero(xpar) && number_zero(ypar)))) {
+ n_arg (*ret, xpar, ypar);
+ }
+}
+
+
+@ 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 mp_floor(a) ((a)>=0 ? (int)(a) : -(int)(-(a)))
+@d bezier_error (720*(256*256*16))+1
+@d mp_sign(v) ((v)>0 ? 1 : ((v)<0 ? -1 : 0 ))
+@d mp_out(A) (double)((A)/16)
+
+@<Declare unary action...@>=
+static void mp_bezier_slope (MP mp, mp_number *ret, mp_number AX, mp_number AY, mp_number BX,
+ mp_number BY, mp_number CX, mp_number CY, mp_number DX,
+ mp_number DY);
+
+@ @c
+static void mp_bezier_slope (MP mp, mp_number *ret, mp_number AX, mp_number AY, mp_number BX,
+ mp_number BY, mp_number CX, mp_number CY, mp_number DX,
+ mp_number DY) {
+ double a, b, c;
+ mp_number deltax, deltay;
+ double ax, ay, bx, by, cx, cy, dx, dy;
+ mp_number xi, xo, xm;
+ double res = 0;
+ ax = number_to_double (AX);
+ ay = number_to_double (AY);
+ bx = number_to_double (BX);
+ by = number_to_double (BY);
+ cx = number_to_double (CX);
+ cy = number_to_double (CY);
+ dx = number_to_double (DX);
+ dy = number_to_double (DY);
+ new_number (deltax);
+ new_number (deltay);
+ set_number_from_substraction(deltax, BX, AX);
+ set_number_from_substraction(deltay, BY, AY);
+ if (number_zero(deltax) && number_zero(deltay)) {
+ set_number_from_substraction(deltax, CX, AX);
+ set_number_from_substraction(deltay, CY, AY);
+ }
+ if (number_zero(deltax) && number_zero(deltay)) {
+ set_number_from_substraction(deltax, DX, AX);
+ set_number_from_substraction(deltay, DY, AY);
+ }
+ new_number (xi);
+ new_number (xm);
+ new_number (xo);
+ mp_an_angle (mp, &xi, deltax, deltay);
+ set_number_from_substraction(deltax, CX, BX);
+ set_number_from_substraction(deltay, CY, BY);
+ mp_an_angle (mp, &xm, deltax, deltay); /* !!! never used? */
+ set_number_from_substraction(deltax, DX, CX);
+ set_number_from_substraction(deltay, DY, CY);
+ if (number_zero(deltax) && number_zero(deltay)) {
+ set_number_from_substraction(deltax, DX, BX);
+ set_number_from_substraction(deltay, DY, BY);
+ }
+ if (number_zero(deltax) && number_zero(deltay)) {
+ set_number_from_substraction(deltax, DX, AX);
+ set_number_from_substraction(deltay, DY, AY);
+ }
+ mp_an_angle (mp, &xo, deltax, deltay);
+ a = (bx - ax) * (cy - by) - (cx - bx) * (by - ay); /* a = (bp-ap)x(cp-bp); */
+ b = (bx - ax) * (dy - cy) - (by - ay) * (dx - cx);; /* b = (bp-ap)x(dp-cp); */
+ c = (cx - bx) * (dy - cy) - (dx - cx) * (cy - by); /* c = (cp-bp)x(dp-cp); */
+ if ((a == 0) && (c == 0)) {
+ res = (b == 0 ? 0 : (mp_out (number_to_double(xo)) - mp_out (number_to_double(xi))));
+ } else if ((a == 0) || (c == 0)) {
+ if ((mp_sign (b) == mp_sign (a)) || (mp_sign (b) == mp_sign (c))) {
+ res = mp_out (number_to_double(xo)) - mp_out (number_to_double(xi)); /* ? */
+ if (res < -180.0)
+ res += 360.0;
+ else if (res > 180.0)
+ res -= 360.0;
+ } else {
+ res = mp_out (number_to_double(xo)) - mp_out (number_to_double(xi)); /* ? */
+ }
+ } else if ((mp_sign (a) * mp_sign (c)) < 0) {
+ res = mp_out (number_to_double(xo)) - mp_out (number_to_double(xi)); /* ? */
+ if (res < -180.0)
+ res += 360.0;
+ else if (res > 180.0)
+ res -= 360.0;
+ } else {
+ if (mp_sign (a) == mp_sign (b)) {
+ res = mp_out (number_to_double(xo)) - mp_out (number_to_double(xi)); /* ? */
+ if (res < -180.0)
+ res += 360.0;
+ else if (res > 180.0)
+ res -= 360.0;
+ } else {
+ if ((b * b) == (4 * a * c)) {
+ res = (double) bezier_error;
+ } else if ((b * b) < (4 * a * c)) {
+ res = mp_out (number_to_double(xo)) - mp_out (number_to_double(xi)); /* ? */
+ if (res <= 0.0 && res > -180.0)
+ res += 360.0;
+ else if (res >= 0.0 && res < 180.0)
+ res -= 360.0;
+ } else {
+ res = mp_out (number_to_double(xo)) - mp_out (number_to_double(xi));
+ if (res < -180.0)
+ res += 360.0;
+ else if (res > 180.0)
+ res -= 360.0;
+ }
+ }
+ }
+ free_number (deltax);
+ free_number (deltay);
+ free_number (xi);
+ free_number (xo);
+ free_number (xm);
+ set_number_from_double(*ret, res);
+ convert_scaled_to_angle (*ret);
+}
+
+
+@
+@d p_nextnext mp_next_knot(mp_next_knot(p))
+@d p_next mp_next_knot(p)
+
+@<Declare unary action...@>=
+static void mp_turn_cycles (MP mp, mp_number *turns, mp_knot c) {
+ mp_angle res, ang; /* the angles of intermediate results */
+ mp_knot p; /* for running around the path */
+ mp_number xp, yp; /* coordinates of next point */
+ mp_number x, y; /* helper coordinates */
+ mp_number arg1, arg2;
+ mp_angle in_angle, out_angle; /* helper angles */
+ mp_angle seven_twenty_deg_t, neg_one_eighty_deg_t;
+ unsigned old_setting; /* saved |selector| setting */
+ set_number_to_zero(*turns);
+ new_number(arg1);
+ new_number(arg2);
+ new_number(xp);
+ new_number(yp);
+ new_number(x);
+ new_number(y);
+ new_angle(in_angle);
+ new_angle(out_angle);
+ new_angle(ang);
+ new_angle(res);
+ new_angle(seven_twenty_deg_t);
+ new_angle(neg_one_eighty_deg_t);
+ number_clone(seven_twenty_deg_t, three_sixty_deg_t);
+ number_double(seven_twenty_deg_t);
+ number_clone(neg_one_eighty_deg_t, one_eighty_deg_t);
+ number_negate(neg_one_eighty_deg_t);
+ p = c;
+ old_setting = mp->selector;
+ mp->selector = term_only;
+ if (number_greater (internal_value (mp_tracing_commands), unity_t)) {
+ mp_begin_diagnostic (mp);
+ mp_print_nl (mp, "");
+ mp_end_diagnostic (mp, false);
+ }
+ do {
+ number_clone (xp, p_next->x_coord);
+ number_clone (yp, p_next->y_coord);
+ mp_bezier_slope (mp, &ang, p->x_coord, p->y_coord, p->right_x, p->right_y,
+ p_next->left_x, p_next->left_y, xp, yp);
+ if (number_greater(ang, seven_twenty_deg_t)) {
+ mp_error (mp, "Strange path", NULL, true);
+ mp->selector = old_setting;
+ set_number_to_zero(*turns);
+ goto DONE;
+ }
+ number_add(res, ang);
+ if (number_greater(res, one_eighty_deg_t)) {
+ number_substract(res, three_sixty_deg_t);
+ number_add(*turns, unity_t);
+ }
+ if (number_lessequal(res, neg_one_eighty_deg_t)) {
+ number_add(res, three_sixty_deg_t);
+ number_substract(*turns, unity_t);
+ }
+ /* incoming angle at next point */
+ number_clone (x, p_next->left_x);
+ number_clone (y, p_next->left_y);
+ if (number_equal(xp, x) && number_equal(yp, y)) {
+ number_clone (x, p->right_x);
+ number_clone (y, p->right_y);
+ }
+ if (number_equal(xp, x) && number_equal(yp, y)) {
+ number_clone (x, p->x_coord);
+ number_clone (y, p->y_coord);
+ }
+ set_number_from_substraction(arg1, xp, x);
+ set_number_from_substraction(arg2, yp, y);
+ mp_an_angle (mp, &in_angle, arg1, arg2);
+ /* outgoing angle at next point */
+ number_clone (x, p_next->right_x);
+ number_clone (y, p_next->right_y);
+ if (number_equal(xp, x) && number_equal(yp, y)) {
+ number_clone (x, p_nextnext->left_x);
+ number_clone (y, p_nextnext->left_y);
+ }
+ if (number_equal(xp, x) && number_equal(yp, y)) {
+ number_clone (x, p_nextnext->x_coord);
+ number_clone (y, p_nextnext->y_coord);
+ }
+ set_number_from_substraction(arg1, x, xp);
+ set_number_from_substraction(arg2, y, yp);
+ mp_an_angle (mp, &out_angle, arg1, arg2);
+ set_number_from_substraction(ang, out_angle, in_angle);
+ mp_reduce_angle (mp, &ang);
+ if (number_nonzero(ang)) {
+ number_add(res, ang);
+ if (number_greaterequal(res, one_eighty_deg_t)) {
+ number_substract(res, three_sixty_deg_t);
+ number_add(*turns, unity_t);
+ }
+ if (number_lessequal(res, neg_one_eighty_deg_t)) {
+ number_add(res, three_sixty_deg_t);
+ number_substract(*turns, unity_t);
+ }
+ }
+ p = mp_next_knot (p);
+ } while (p != c);
+ mp->selector = old_setting;
+DONE:
+ free_number(xp);
+ free_number(yp);
+ free_number(x);
+ free_number(y);
+ free_number(seven_twenty_deg_t);
+ free_number(neg_one_eighty_deg_t);
+ free_number(in_angle);
+ free_number(out_angle);
+ free_number(ang);
+ free_number(res);
+ free_number(arg1);
+ free_number(arg2);
+}
+
+@ @<Declare unary action...@>=
+static void mp_turn_cycles_wrapper (MP mp, mp_number *ret, mp_knot c) {
+ if (mp_next_knot (c) == c) {
+ /* one-knot paths always have a turning number of 1 */
+ set_number_to_unity(*ret);
+ } else {
+ mp_turn_cycles (mp, ret, c);
+ }
+}
+
+@ @<Declare unary action procedures@>=
+static void mp_test_known (MP mp, quarterword c) {
+ int b; /* is the current expression known? */
+ mp_node p; /* location in a big node */
+ mp_value new_expr;
+ memset(&new_expr,0,sizeof(mp_value));
+ new_number(new_expr.data.n);
+ b = mp_false_code;
+ switch (mp->cur_exp.type) {
+ case mp_vacuous:
+ case mp_boolean_type:
+ case mp_string_type:
+ case mp_pen_type:
+ case mp_path_type:
+ case mp_picture_type:
+ case mp_known:
+ b = mp_true_code;
+ break;
+ case mp_transform_type:
+ p = value_node (cur_exp_node ());
+ if (mp_type (tx_part (p)) != mp_known)
+ break;
+ if (mp_type (ty_part (p)) != mp_known)
+ break;
+ if (mp_type (xx_part (p)) != mp_known)
+ break;
+ if (mp_type (xy_part (p)) != mp_known)
+ break;
+ if (mp_type (yx_part (p)) != mp_known)
+ break;
+ if (mp_type (yy_part (p)) != mp_known)
+ break;
+ b = mp_true_code;
+ break;
+ case mp_color_type:
+ p = value_node (cur_exp_node ());
+ if (mp_type (red_part (p)) != mp_known)
+ break;
+ if (mp_type (green_part (p)) != mp_known)
+ break;
+ if (mp_type (blue_part (p)) != mp_known)
+ break;
+ b = mp_true_code;
+ break;
+ case mp_cmykcolor_type:
+ p = value_node (cur_exp_node ());
+ if (mp_type (cyan_part (p)) != mp_known)
+ break;
+ if (mp_type (magenta_part (p)) != mp_known)
+ break;
+ if (mp_type (yellow_part (p)) != mp_known)
+ break;
+ if (mp_type (black_part (p)) != mp_known)
+ break;
+ b = mp_true_code;
+ break;
+ case mp_pair_type:
+ p = value_node (cur_exp_node ());
+ if (mp_type (x_part (p)) != mp_known)
+ break;
+ if (mp_type (y_part (p)) != mp_known)
+ break;
+ b = mp_true_code;
+ break;
+ default:
+ break;
+ }
+ if (c == mp_known_op) {
+ set_number_from_boolean (new_expr.data.n, b);
+ } else {
+ if (b==mp_true_code) {
+ set_number_from_boolean (new_expr.data.n, mp_false_code);
+ } else {
+ set_number_from_boolean (new_expr.data.n, mp_true_code);
+ }
+ }
+ mp_flush_cur_exp (mp, new_expr);
+ cur_exp_node() = NULL; /* !! do not replace with |set_cur_exp_node()| !! */
+ mp->cur_exp.type = mp_boolean_type;
+}
+
+@ The |pair_value| routine changes the current expression to a
+given ordered pair of values.
+
+@<Declare unary action procedures@>=
+static void mp_pair_value (MP mp, mp_number x, mp_number y) {
+ mp_node p; /* a pair node */
+ mp_value new_expr;
+ mp_number x1, y1;
+ new_number(x1);
+ new_number(y1);
+ number_clone (x1, x);
+ number_clone (y1, y);
+ memset(&new_expr,0,sizeof(mp_value));
+ new_number(new_expr.data.n);
+ p = mp_get_value_node (mp);
+ new_expr.type = mp_type (p);
+ new_expr.data.node = p;
+ mp_flush_cur_exp (mp, new_expr);
+ mp->cur_exp.type = mp_pair_type;
+ mp_name_type (p) = mp_capsule;
+ mp_init_pair_node (mp, p);
+ p = value_node (p);
+ mp_type (x_part (p)) = mp_known;
+ set_value_number (x_part (p), x1);
+ mp_type (y_part (p)) = mp_known;
+ set_value_number (y_part (p), y1);
+ free_number(x1);
+ free_number(y1);
+}
+
+
+@ 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@>=
+static boolean mp_get_cur_bbox (MP mp) {
+ switch (mp->cur_exp.type) {
+ case mp_picture_type:
+ {
+ mp_edge_header_node p0 = (mp_edge_header_node)cur_exp_node ();
+ mp_set_bbox (mp, p0, true);
+ if (number_greater(p0->minx, p0->maxx)) {
+ set_number_to_zero(mp_minx);
+ set_number_to_zero(mp_maxx);
+ set_number_to_zero(mp_miny);
+ set_number_to_zero(mp_maxy);
+ } else {
+ number_clone (mp_minx, p0->minx);
+ number_clone (mp_maxx, p0->maxx);
+ number_clone (mp_miny, p0->miny);
+ number_clone (mp_maxy, p0->maxy);
+ }
+ }
+ break;
+ case mp_path_type:
+ mp_path_bbox (mp, cur_exp_knot ());
+ break;
+ case mp_pen_type:
+ mp_pen_bbox (mp, cur_exp_knot ());
+ break;
+ default:
+ return false;
+ }
+ return true;
+}
+
+
+@ Here is a routine that interprets |cur_exp| as a file name and tries to read
+a line from the file or to close the file.
+
+@<Declare unary action procedures@>=
+static void mp_do_read_or_close (MP mp, quarterword c) {
+ mp_value new_expr;
+ readf_index n, n0; /* indices for searching |rd_fname| */
+ memset(&new_expr,0,sizeof(mp_value));
+ new_number(new_expr.data.n);
+ /* 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| */
+ /* Free slots in the |rd_file| and |rd_fname| arrays are marked with NULL's in
+ |rd_fname|. */
+ {
+ char *fn;
+ n = mp->read_files;
+ n0 = mp->read_files;
+ fn = mp_xstrdup (mp, mp_str (mp, cur_exp_str ()));
+ while (mp_xstrcmp (fn, mp->rd_fname[n]) != 0) {
+ if (n > 0) {
+ decr (n);
+ } else if (c == mp_close_from_op) {
+ goto CLOSE_FILE;
+ } else {
+ if (n0 == mp->read_files) {
+ if (mp->read_files < mp->max_read_files) {
+ incr (mp->read_files);
+ } else {
+ void **rd_file;
+ char **rd_fname;
+ readf_index l, k;
+ l = mp->max_read_files + (mp->max_read_files / 4);
+ rd_file = xmalloc ((l + 1), sizeof (void *));
+ rd_fname = xmalloc ((l + 1), sizeof (char *));
+ for (k = 0; k <= l; k++) {
+ if (k <= mp->max_read_files) {
+ rd_file[k] = mp->rd_file[k];
+ rd_fname[k] = mp->rd_fname[k];
+ } else {
+ rd_file[k] = 0;
+ rd_fname[k] = NULL;
+ }
+ }
+ xfree (mp->rd_file);
+ xfree (mp->rd_fname);
+ mp->max_read_files = l;
+ mp->rd_file = rd_file;
+ mp->rd_fname = rd_fname;
+ }
+ }
+ n = n0;
+ if (mp_start_read_input (mp, fn, n))
+ goto FOUND;
+ else
+ goto NOT_FOUND;
+ }
+ if (mp->rd_fname[n] == NULL) {
+ n0 = n;
+ }
+ }
+ if (c == mp_close_from_op) {
+ (mp->close_file) (mp, mp->rd_file[n]);
+ goto NOT_FOUND;
+ }
+ }
+ mp_begin_file_reading (mp);
+ name = is_read;
+ if (mp_input_ln (mp, mp->rd_file[n]))
+ goto FOUND;
+ mp_end_file_reading (mp);
+NOT_FOUND:
+ /* Record the end of file and set |cur_exp| to a dummy value */
+ xfree (mp->rd_fname[n]);
+ mp->rd_fname[n] = NULL;
+ if (n == mp->read_files - 1)
+ mp->read_files = n;
+ if (c == mp_close_from_op)
+ goto CLOSE_FILE;
+ new_expr.data.str = mp->eof_line;
+ add_str_ref (new_expr.data.str);
+ mp_flush_cur_exp (mp, new_expr);
+ mp->cur_exp.type = mp_string_type;
+ return;
+CLOSE_FILE:
+ mp_flush_cur_exp (mp, new_expr);
+ mp->cur_exp.type = mp_vacuous;
+ return;
+FOUND:
+ mp_flush_cur_exp (mp, new_expr);
+ mp_finish_read (mp);
+}
+
+@ The string denoting end-of-file is a one-byte string at position zero, by definition.
+I have to cheat a little here because
+
+@<Glob...@>=
+mp_string eof_line;
+
+@ @<Set init...@>=
+mp->eof_line = mp_rtsl (mp, "\0", 1);
+mp->eof_line->refs = MAX_STR_REF;
+
+@ Finally, we have the operations that combine a capsule~|p|
+with the current expression.
+
+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.
+
+@d binary_return { mp_finish_binary(mp, old_p, old_exp); return; }
+
+@c
+@<Declare binary action procedures@>;
+static void mp_finish_binary (MP mp, mp_node old_p, mp_node old_exp) {
+ check_arith();
+ /* Recycle any sidestepped |independent| capsules */
+ if (old_p != NULL) {
+ mp_recycle_value (mp, old_p);
+ mp_free_value_node (mp, old_p);
+ }
+ if (old_exp != NULL) {
+ mp_recycle_value (mp, old_exp);
+ mp_free_value_node (mp, old_exp);
+ }
+}
+static void mp_do_binary (MP mp, mp_node p, integer c) {
+ mp_node q, r, rr; /* for list manipulation */
+ mp_node old_p, old_exp; /* capsules to recycle */
+ mp_value new_expr;
+ check_arith();
+ if (number_greater (internal_value (mp_tracing_commands), two_t)) {
+ /* Trace the current binary operation */
+ mp_begin_diagnostic (mp);
+ mp_print_nl (mp, "{(");
+ mp_print_exp (mp, p, 0); /* show the operand, but not verbosely */
+ mp_print_char (mp, xord (')'));
+ mp_print_op (mp, (quarterword) c);
+ mp_print_char (mp, xord ('('));
+ mp_print_exp (mp, NULL, 0);
+ mp_print (mp, ")}");
+ mp_end_diagnostic (mp, false);
+ }
+ /* Sidestep |independent| cases in capsule |p| */
+ /* 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. */
+ switch (mp_type (p)) {
+ case mp_transform_type:
+ case mp_color_type:
+ case mp_cmykcolor_type:
+ case mp_pair_type:
+ old_p = mp_tarnished (mp, p);
+ break;
+ case mp_independent:
+ old_p = MP_VOID;
+ break;
+ default:
+ old_p = NULL;
+ break;
+ }
+ if (old_p != NULL) {
+ q = mp_stash_cur_exp (mp);
+ old_p = p;
+ mp_make_exp_copy (mp, old_p);
+ p = mp_stash_cur_exp (mp);
+ mp_unstash_cur_exp (mp, q);
+ }
+
+ /* Sidestep |independent| cases in the current expression */
+ switch (mp->cur_exp.type) {
+ case mp_transform_type:
+ case mp_color_type:
+ case mp_cmykcolor_type:
+ case mp_pair_type:
+ old_exp = mp_tarnished (mp, cur_exp_node ());
+ break;
+ case mp_independent:
+ old_exp = MP_VOID;
+ break;
+ default:
+ old_exp = NULL;
+ break;
+ }
+ if (old_exp != NULL) {
+ old_exp = cur_exp_node ();
+ mp_make_exp_copy (mp, old_exp);
+ }
+
+ switch (c) {
+ case mp_plus:
+ case mp_minus:
+ /* Add or subtract the current expression from |p| */
+ if ((mp->cur_exp.type < mp_color_type) || (mp_type (p) < mp_color_type)) {
+ mp_bad_binary (mp, p, (quarterword) c);
+ } else {
+ quarterword cc = (quarterword)c;
+ if ((mp->cur_exp.type > mp_pair_type) && (mp_type (p) > mp_pair_type)) {
+ mp_add_or_subtract (mp, p, NULL, cc);
+ } else {
+ if (mp->cur_exp.type != mp_type (p)) {
+ mp_bad_binary (mp, p, cc);
+ } else {
+ q = value_node (p);
+ r = value_node (cur_exp_node ());
+ switch (mp->cur_exp.type) {
+ case mp_pair_type:
+ mp_add_or_subtract (mp, x_part (q), x_part (r),cc);
+ mp_add_or_subtract (mp, y_part (q), y_part (r),cc);
+ break;
+ case mp_color_type:
+ mp_add_or_subtract (mp, red_part (q), red_part (r),cc);
+ mp_add_or_subtract (mp, green_part (q), green_part (r),cc);
+ mp_add_or_subtract (mp, blue_part (q), blue_part (r),cc);
+ break;
+ case mp_cmykcolor_type:
+ mp_add_or_subtract (mp, cyan_part (q), cyan_part (r),cc);
+ mp_add_or_subtract (mp, magenta_part (q), magenta_part (r),cc);
+ mp_add_or_subtract (mp, yellow_part (q), yellow_part (r),cc);
+ mp_add_or_subtract (mp, black_part (q), black_part (r),cc);
+ break;
+ case mp_transform_type:
+ mp_add_or_subtract (mp, tx_part (q), tx_part (r),cc);
+ mp_add_or_subtract (mp, ty_part (q), ty_part (r),cc);
+ mp_add_or_subtract (mp, xx_part (q), xx_part (r),cc);
+ mp_add_or_subtract (mp, xy_part (q), xy_part (r),cc);
+ mp_add_or_subtract (mp, yx_part (q), yx_part (r),cc);
+ mp_add_or_subtract (mp, yy_part (q), yy_part (r),cc);
+ break;
+ default: /* there are no other valid cases, but please the compiler */
+ break;
+ }
+ }
+ }
+ }
+ break;
+ case mp_less_than:
+ case mp_less_or_equal:
+ case mp_greater_than:
+ case mp_greater_or_equal:
+ case mp_equal_to:
+ case mp_unequal_to:
+ check_arith(); /* at this point |arith_error| should be |false|? */
+ if ((mp->cur_exp.type > mp_pair_type) && (mp_type (p) > mp_pair_type)) {
+ mp_add_or_subtract (mp, p, NULL, mp_minus); /* |cur_exp:=(p)-cur_exp| */
+ } else if (mp->cur_exp.type != mp_type (p)) {
+ mp_bad_binary (mp, p, (quarterword) c);
+ goto DONE;
+ } else if (mp->cur_exp.type == mp_string_type) {
+ memset(&new_expr,0,sizeof(mp_value));
+ new_number(new_expr.data.n);
+ set_number_from_scaled (new_expr.data.n, mp_str_vs_str (mp, value_str (p), cur_exp_str ()));
+ mp_flush_cur_exp (mp, new_expr);
+ } else if ((mp->cur_exp.type == mp_unknown_string) ||
+ (mp->cur_exp.type == mp_unknown_boolean)) {
+ /* Check if unknowns have been equated */
+ /* 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. */
+ q = value_node (cur_exp_node ());
+ while ((q != cur_exp_node ()) && (q != p))
+ q = value_node (q);
+ if (q == p) {
+ memset(&new_expr,0,sizeof(mp_value));
+ new_number(new_expr.data.n);
+ set_cur_exp_node (NULL);
+ mp_flush_cur_exp (mp, new_expr);
+ }
+
+ } else if ((mp->cur_exp.type <= mp_pair_type)
+ && (mp->cur_exp.type >= mp_transform_type)) {
+ /* Reduce comparison of big nodes to comparison of scalars */
+ /* In the following, the |while| loops exist just so that |break| can be used,
+ each loop runs exactly once. */
+ quarterword part_type;
+ q = value_node (p);
+ r = value_node (cur_exp_node ());
+ part_type = 0;
+ switch (mp->cur_exp.type) {
+ case mp_pair_type:
+ while (part_type==0) {
+ rr = x_part (r);
+ part_type = mp_x_part;
+ mp_add_or_subtract (mp, x_part (q), rr, mp_minus);
+ if (mp_type (rr) != mp_known || ! number_zero(value_number (rr)))
+ break;
+ rr = y_part (r);
+ part_type = mp_y_part;
+ mp_add_or_subtract (mp, y_part (q), rr, mp_minus);
+ if (mp_type (rr) != mp_known || !number_zero(value_number (rr)))
+ break;
+ }
+ mp_take_part (mp, part_type);
+ break;
+ case mp_color_type:
+ while (part_type==0) {
+ rr = red_part (r);
+ part_type = mp_red_part;
+ mp_add_or_subtract (mp, red_part (q), rr, mp_minus);
+ if (mp_type (rr) != mp_known || ! number_zero(value_number (rr)))
+ break;
+ rr = green_part (r);
+ part_type = mp_green_part;
+ mp_add_or_subtract (mp, green_part (q), rr, mp_minus);
+ if (mp_type (rr) != mp_known || !number_zero(value_number (rr)))
+ break;
+ rr = blue_part (r);
+ part_type = mp_blue_part;
+ mp_add_or_subtract (mp, blue_part (q), rr, mp_minus);
+ if (mp_type (rr) != mp_known || !number_zero(value_number (rr)))
+ break;
+ }
+ mp_take_part (mp, part_type);
+ break;
+ case mp_cmykcolor_type:
+ while (part_type==0) {
+ rr = cyan_part (r);
+ part_type = mp_cyan_part;
+ mp_add_or_subtract (mp, cyan_part (q), rr, mp_minus);
+ if (mp_type (rr) != mp_known || !number_zero(value_number (rr)))
+ break;
+ rr = magenta_part (r);
+ part_type = mp_magenta_part;
+ mp_add_or_subtract (mp, magenta_part (q), rr, mp_minus);
+ if (mp_type (rr) != mp_known || !number_zero(value_number (rr)))
+ break;
+ rr = yellow_part (r);
+ part_type = mp_yellow_part;
+ mp_add_or_subtract (mp, yellow_part (q), rr, mp_minus);
+ if (mp_type (rr) != mp_known || !number_zero(value_number (rr)))
+ break;
+ rr = black_part (r);
+ part_type = mp_black_part;
+ mp_add_or_subtract (mp, black_part (q), rr, mp_minus);
+ if (mp_type (rr) != mp_known || !number_zero(value_number (rr)))
+ break;
+ }
+ mp_take_part (mp, part_type);
+ break;
+ case mp_transform_type:
+ while (part_type==0) {
+ rr = tx_part (r);
+ part_type = mp_x_part;
+ mp_add_or_subtract (mp, tx_part (q), rr, mp_minus);
+ if (mp_type (rr) != mp_known || !number_zero(value_number (rr)))
+ break;
+ rr = ty_part (r);
+ part_type = mp_y_part;
+ mp_add_or_subtract (mp, ty_part (q), rr, mp_minus);
+ if (mp_type (rr) != mp_known || !number_zero(value_number (rr)))
+ break;
+ rr = xx_part (r);
+ part_type = mp_xx_part;
+ mp_add_or_subtract (mp, xx_part (q), rr, mp_minus);
+ if (mp_type (rr) != mp_known || !number_zero(value_number (rr)))
+ break;
+ rr = xy_part (r);
+ part_type = mp_xy_part;
+ mp_add_or_subtract (mp, xy_part (q), rr, mp_minus);
+ if (mp_type (rr) != mp_known || !number_zero(value_number (rr)))
+ break;
+ rr = yx_part (r);
+ part_type = mp_yx_part;
+ mp_add_or_subtract (mp, yx_part (q), rr, mp_minus);
+ if (mp_type (rr) != mp_known || !number_zero(value_number (rr)))
+ break;
+ rr = yy_part (r);
+ part_type = mp_yy_part;
+ mp_add_or_subtract (mp, yy_part (q), rr, mp_minus);
+ if (mp_type (rr) != mp_known || !number_zero(value_number (rr)))
+ break;
+ }
+ mp_take_part (mp, part_type);
+ break;
+ default:
+ assert (0); /* todo: |mp->cur_exp.type>mp_transform_node_type| ? */
+ break;
+ }
+
+ } else if (mp->cur_exp.type == mp_boolean_type) {
+ memset(&new_expr,0,sizeof(mp_value));
+ new_number(new_expr.data.n);
+ set_number_from_boolean (new_expr.data.n, number_to_scaled(cur_exp_value_number ()) -
+ number_to_scaled (value_number (p)));
+ mp_flush_cur_exp (mp, new_expr);
+ } else {
+ mp_bad_binary (mp, p, (quarterword) c);
+ goto DONE;
+ }
+ /* Compare the current expression with zero */
+ if (mp->cur_exp.type != mp_known) {
+ const char *hlp[] = {
+ "Oh dear. I can\'t decide if the expression above is positive,",
+ "negative, or zero. So this comparison test won't be `true'.",
+ NULL };
+ if (mp->cur_exp.type < mp_known) {
+ mp_disp_err (mp, p);
+ hlp[0] = "The quantities shown above have not been equated.";
+ hlp[1] = NULL;
+ }
+ mp_disp_err(mp, NULL);
+ memset(&new_expr,0,sizeof(mp_value));
+ new_number(new_expr.data.n);
+ set_number_from_boolean (new_expr.data.n, mp_false_code);
+ mp_back_error (mp,"Unknown relation will be considered false", hlp, true);
+ @.Unknown relation...@>;
+ mp_get_x_next (mp);
+ mp_flush_cur_exp (mp, new_expr);
+ } else {
+ switch (c) {
+ case mp_less_than:
+ boolean_reset (number_negative(cur_exp_value_number ()));
+ break;
+ case mp_less_or_equal:
+ boolean_reset (number_nonpositive(cur_exp_value_number ()));
+ break;
+ case mp_greater_than:
+ boolean_reset (number_positive(cur_exp_value_number ()));
+ break;
+ case mp_greater_or_equal:
+ boolean_reset (number_nonnegative(cur_exp_value_number ()));
+ break;
+ case mp_equal_to:
+ boolean_reset (number_zero(cur_exp_value_number ()));
+ break;
+ case mp_unequal_to:
+ boolean_reset (number_nonzero(cur_exp_value_number ()));
+ break;
+ }; /* there are no other cases */
+ }
+ mp->cur_exp.type = mp_boolean_type;
+ DONE:
+ mp->arith_error = false; /* ignore overflow in comparisons */
+ break;
+ case mp_and_op:
+ case mp_or_op:
+ /* Here we use the sneaky fact that |and_op-false_code=or_op-true_code| */
+ if ((mp_type (p) != mp_boolean_type) || (mp->cur_exp.type != mp_boolean_type))
+ mp_bad_binary (mp, p, (quarterword) c);
+ else if (number_to_boolean (p->data.n) == c + mp_false_code - mp_and_op) {
+ set_cur_exp_value_boolean (number_to_boolean (p->data.n));
+ }
+ break;
+ case mp_times:
+ if ((mp->cur_exp.type < mp_color_type) || (mp_type (p) < mp_color_type)) {
+ mp_bad_binary (mp, p, mp_times);
+ } else if ((mp->cur_exp.type == mp_known) || (mp_type (p) == mp_known)) {
+ /* Multiply when at least one operand is known */
+ mp_number vv;
+ new_fraction (vv);
+ if (mp_type (p) == mp_known) {
+ number_clone(vv, value_number (p));
+ mp_free_value_node (mp, p);
+ } else {
+ number_clone(vv, cur_exp_value_number ());
+ mp_unstash_cur_exp (mp, p);
+ }
+ if (mp->cur_exp.type == mp_known) {
+ mp_number ret;
+ new_number (ret);
+ take_scaled (ret, cur_exp_value_number (), vv);
+ set_cur_exp_value_number (ret);
+ free_number (ret);
+ } else if (mp->cur_exp.type == mp_pair_type) {
+ mp_dep_mult (mp, (mp_value_node) x_part (value_node (cur_exp_node ())), vv, true);
+ mp_dep_mult (mp, (mp_value_node) y_part (value_node (cur_exp_node ())), vv, true);
+ } else if (mp->cur_exp.type == mp_color_type) {
+ mp_dep_mult (mp, (mp_value_node) red_part (value_node (cur_exp_node ())), vv, true);
+ mp_dep_mult (mp, (mp_value_node) green_part (value_node (cur_exp_node ())), vv, true);
+ mp_dep_mult (mp, (mp_value_node) blue_part (value_node (cur_exp_node ())), vv, true);
+ } else if (mp->cur_exp.type == mp_cmykcolor_type) {
+ mp_dep_mult (mp, (mp_value_node) cyan_part (value_node (cur_exp_node ())), vv, true);
+ mp_dep_mult (mp, (mp_value_node) magenta_part (value_node (cur_exp_node ())), vv, true);
+ mp_dep_mult (mp, (mp_value_node) yellow_part (value_node (cur_exp_node ())), vv, true);
+ mp_dep_mult (mp, (mp_value_node) black_part (value_node (cur_exp_node ())), vv, true);
+ } else {
+ mp_dep_mult (mp, NULL, vv, true);
+ }
+ free_number (vv);
+ binary_return;
+
+ } else if ((mp_nice_color_or_pair (mp, p, mp_type (p))
+ && (mp->cur_exp.type > mp_pair_type))
+ || (mp_nice_color_or_pair (mp, cur_exp_node (), mp->cur_exp.type)
+ && (mp_type (p) > mp_pair_type))) {
+ mp_hard_times (mp, p);
+ binary_return;
+ } else {
+ mp_bad_binary (mp, p, mp_times);
+ }
+ break;
+ case mp_over:
+ if ((mp->cur_exp.type != mp_known) || (mp_type (p) < mp_color_type)) {
+ mp_bad_binary (mp, p, mp_over);
+ } else {
+ mp_number v_n;
+ new_number (v_n);
+ number_clone (v_n, cur_exp_value_number ());
+ mp_unstash_cur_exp (mp, p);
+ if (number_zero(v_n)) {
+ /* Squeal about division by zero */
+ const char *hlp[] = {
+ "You're trying to divide the quantity shown above the error",
+ "message by zero. I'm going to divide it by one instead.",
+ NULL };
+ mp_disp_err(mp, NULL);
+ mp_back_error (mp, "Division by zero", hlp, true);
+ mp_get_x_next (mp);
+
+ } else {
+ if (mp->cur_exp.type == mp_known) {
+ mp_number ret;
+ new_number (ret);
+ make_scaled (ret, cur_exp_value_number (), v_n);
+ set_cur_exp_value_number (ret);
+ free_number (ret);
+ } else if (mp->cur_exp.type == mp_pair_type) {
+ mp_dep_div (mp, (mp_value_node) x_part (value_node (cur_exp_node ())),
+ v_n);
+ mp_dep_div (mp, (mp_value_node) y_part (value_node (cur_exp_node ())),
+ v_n);
+ } else if (mp->cur_exp.type == mp_color_type) {
+ mp_dep_div (mp,
+ (mp_value_node) red_part (value_node (cur_exp_node ())),
+ v_n);
+ mp_dep_div (mp,
+ (mp_value_node) green_part (value_node (cur_exp_node ())),
+ v_n);
+ mp_dep_div (mp,
+ (mp_value_node) blue_part (value_node (cur_exp_node ())),
+ v_n);
+ } else if (mp->cur_exp.type == mp_cmykcolor_type) {
+ mp_dep_div (mp,
+ (mp_value_node) cyan_part (value_node (cur_exp_node ())),
+ v_n);
+ mp_dep_div (mp, (mp_value_node)
+ magenta_part (value_node (cur_exp_node ())), v_n);
+ mp_dep_div (mp, (mp_value_node)
+ yellow_part (value_node (cur_exp_node ())), v_n);
+ mp_dep_div (mp,
+ (mp_value_node) black_part (value_node (cur_exp_node ())),
+ v_n);
+ } else {
+ mp_dep_div (mp, NULL, v_n);
+ }
+ }
+ free_number(v_n);
+ binary_return;
+ }
+ break;
+ case mp_pythag_add:
+ case mp_pythag_sub:
+ if ((mp->cur_exp.type == mp_known) && (mp_type (p) == mp_known)) {
+ mp_number r;
+ new_number (r);
+ if (c == mp_pythag_add) {
+ pyth_add (r, value_number (p), cur_exp_value_number ());
+ } else {
+ pyth_sub (r, value_number (p), cur_exp_value_number ());
+ }
+ set_cur_exp_value_number (r);
+ free_number (r);
+ } else
+ mp_bad_binary (mp, p, (quarterword) c);
+ break;
+ case mp_rotated_by:
+ case mp_slanted_by:
+ case mp_scaled_by:
+ case mp_shifted_by:
+ case mp_transformed_by:
+ case mp_x_scaled:
+ case mp_y_scaled:
+ case mp_z_scaled:
+ /* The next few sections of the program deal with affine transformations
+ of coordinate data. */
+ if (mp_type (p) == mp_path_type) {
+ path_trans ((quarterword) c, p);
+ binary_return;
+ } else if (mp_type (p) == mp_pen_type) {
+ pen_trans ((quarterword) c, p);
+ set_cur_exp_knot (mp_convex_hull (mp, cur_exp_knot ()));
+ /* rounding error could destroy convexity */
+ binary_return;
+ } else if ((mp_type (p) == mp_pair_type) || (mp_type (p) == mp_transform_type)) {
+ mp_big_trans (mp, p, (quarterword) c);
+ } else if (mp_type (p) == mp_picture_type) {
+ mp_do_edges_trans (mp, p, (quarterword) c);
+ binary_return;
+ } else {
+ mp_bad_binary (mp, p, (quarterword) c);
+ }
+ break;
+ case mp_concatenate:
+ if ((mp->cur_exp.type == mp_string_type) && (mp_type (p) == mp_string_type)) {
+ mp_string str = mp_cat (mp, value_str (p), cur_exp_str());
+ delete_str_ref (cur_exp_str ()) ;
+ set_cur_exp_str (str);
+ } else
+ mp_bad_binary (mp, p, mp_concatenate);
+ break;
+ case mp_substring_of:
+ if (mp_nice_pair (mp, p, mp_type (p)) && (mp->cur_exp.type == mp_string_type)) {
+ mp_string str = mp_chop_string (mp,
+ cur_exp_str (),
+ round_unscaled (value_number (x_part (value_node(p)))),
+ round_unscaled (value_number (y_part (value_node(p)))));
+ delete_str_ref (cur_exp_str ()) ;
+ set_cur_exp_str (str);
+ } else
+ mp_bad_binary (mp, p, mp_substring_of);
+ break;
+ case mp_subpath_of:
+ if (mp->cur_exp.type == mp_pair_type)
+ mp_pair_to_path (mp);
+ if (mp_nice_pair (mp, p, mp_type (p)) && (mp->cur_exp.type == mp_path_type))
+ mp_chop_path (mp, value_node (p));
+ else
+ mp_bad_binary (mp, p, mp_subpath_of);
+ break;
+ case mp_point_of:
+ case mp_precontrol_of:
+ case mp_postcontrol_of:
+ if (mp->cur_exp.type == mp_pair_type)
+ mp_pair_to_path (mp);
+ if ((mp->cur_exp.type == mp_path_type) && (mp_type (p) == mp_known))
+ mp_find_point (mp, value_number (p), (quarterword) c);
+ else
+ mp_bad_binary (mp, p, (quarterword) c);
+ break;
+ case mp_pen_offset_of:
+ if ((mp->cur_exp.type == mp_pen_type) && mp_nice_pair (mp, p, mp_type (p)))
+ mp_set_up_offset (mp, value_node (p));
+ else
+ mp_bad_binary (mp, p, mp_pen_offset_of);
+ break;
+ case mp_direction_time_of:
+ if (mp->cur_exp.type == mp_pair_type)
+ mp_pair_to_path (mp);
+ if ((mp->cur_exp.type == mp_path_type) && mp_nice_pair (mp, p, mp_type (p)))
+ mp_set_up_direction_time (mp, value_node (p));
+ else
+ mp_bad_binary (mp, p, mp_direction_time_of);
+ break;
+ case mp_envelope_of:
+ if ((mp_type (p) != mp_pen_type) || (mp->cur_exp.type != mp_path_type))
+ mp_bad_binary (mp, p, mp_envelope_of);
+ else
+ mp_set_up_envelope (mp, p);
+ break;
+ case mp_boundingpath_of:
+ if ((mp_type (p) != mp_pen_type) || (mp->cur_exp.type != mp_path_type))
+ mp_bad_binary (mp, p, mp_boundingpath_of);
+ else
+ mp_set_up_boundingpath (mp, p);
+ break;
+ case mp_glyph_infont:
+ if ((mp_type (p) != mp_string_type &&
+ mp_type (p) != mp_known) || (mp->cur_exp.type != mp_string_type))
+ mp_bad_binary (mp, p, mp_glyph_infont);
+ else
+ mp_set_up_glyph_infont (mp, p);
+ break;
+ case mp_arc_time_of:
+ if (mp->cur_exp.type == mp_pair_type)
+ mp_pair_to_path (mp);
+ if ((mp->cur_exp.type == mp_path_type) && (mp_type (p) == mp_known)) {
+ memset(&new_expr,0,sizeof(mp_value));
+ new_number(new_expr.data.n);
+ mp_get_arc_time (mp, &new_expr.data.n, cur_exp_knot (), value_number (p));
+ mp_flush_cur_exp (mp, new_expr);
+ } else {
+ mp_bad_binary (mp, p, (quarterword) c);
+ }
+ break;
+ case mp_intersect:
+ if (mp_type (p) == mp_pair_type) {
+ q = mp_stash_cur_exp (mp);
+ mp_unstash_cur_exp (mp, p);
+ mp_pair_to_path (mp);
+ p = mp_stash_cur_exp (mp);
+ mp_unstash_cur_exp (mp, q);
+ }
+ if (mp->cur_exp.type == mp_pair_type)
+ mp_pair_to_path (mp);
+ if ((mp->cur_exp.type == mp_path_type) && (mp_type (p) == mp_path_type)) {
+ mp_number arg1, arg2;
+ new_number (arg1);
+ new_number (arg2);
+ mp_path_intersection (mp, value_knot (p), cur_exp_knot ());
+ number_clone (arg1, mp->cur_t);
+ number_clone (arg2, mp->cur_tt);
+ mp_pair_value (mp, arg1, arg2);
+ free_number (arg1);
+ free_number (arg2);
+ } else {
+ mp_bad_binary (mp, p, mp_intersect);
+ }
+ break;
+ case mp_in_font:
+ if ((mp->cur_exp.type != mp_string_type) || mp_type (p) != mp_string_type) {
+ mp_bad_binary (mp, p, mp_in_font);
+ } else {
+ mp_do_infont (mp, p);
+ binary_return;
+ }
+ break;
+ } /* there are no other cases */
+ mp_recycle_value (mp, p);
+ mp_free_value_node (mp, p); /* |return| to avoid this */
+ mp_finish_binary (mp, old_p, old_exp);
+}
+
+
+@ @<Declare binary action...@>=
+static void mp_bad_binary (MP mp, mp_node p, quarterword c) {
+ char msg[256];
+ mp_string sname;
+ int old_setting = mp->selector;
+ const char *hlp[] = {
+ "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.",
+ NULL };
+ mp->selector = new_string;
+ if (c >= mp_min_of)
+ mp_print_op (mp, c);
+ mp_print_known_or_unknown_type (mp, mp_type (p), p);
+ if (c >= mp_min_of)
+ mp_print (mp, "of");
+ else
+ mp_print_op (mp, c);
+ mp_print_known_or_unknown_type (mp, mp->cur_exp.type, cur_exp_node ());
+ sname = mp_make_string(mp);
+ mp->selector = old_setting;
+ mp_snprintf (msg, 256, "Not implemented: %s", mp_str(mp, sname));
+@.Not implemented...@>;
+ delete_str_ref(sname);
+ mp_disp_err (mp, p);
+ mp_disp_err (mp, NULL);
+ mp_back_error (mp, msg, hlp, true);
+ mp_get_x_next (mp);
+}
+static void mp_bad_envelope_pen (MP mp) {
+ const char *hlp[] = {
+ "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.",
+ NULL };
+ mp_disp_err (mp, NULL);
+ mp_disp_err (mp, NULL);
+ mp_back_error (mp, "Not implemented: envelope(elliptical pen)of(path)", hlp, true);
+@.Not implemented...@>;
+ mp_get_x_next (mp);
+}
+
+@ @<Declare binary action...@>=
+static mp_node mp_tarnished (MP mp, mp_node p) {
+ mp_node q; /* beginning of the big node */
+ mp_node r; /* moving value node pointer */
+ (void) mp;
+ q = value_node (p);
+ switch (mp_type (p)) {
+ case mp_pair_type:
+ r = x_part (q);
+ if (mp_type (r) == mp_independent)
+ return MP_VOID;
+ r = y_part (q);
+ if (mp_type (r) == mp_independent)
+ return MP_VOID;
+ break;
+ case mp_color_type:
+ r = red_part (q);
+ if (mp_type (r) == mp_independent)
+ return MP_VOID;
+ r = green_part (q);
+ if (mp_type (r) == mp_independent)
+ return MP_VOID;
+ r = blue_part (q);
+ if (mp_type (r) == mp_independent)
+ return MP_VOID;
+ break;
+ case mp_cmykcolor_type:
+ r = cyan_part (q);
+ if (mp_type (r) == mp_independent)
+ return MP_VOID;
+ r = magenta_part (q);
+ if (mp_type (r) == mp_independent)
+ return MP_VOID;
+ r = yellow_part (q);
+ if (mp_type (r) == mp_independent)
+ return MP_VOID;
+ r = black_part (q);
+ if (mp_type (r) == mp_independent)
+ return MP_VOID;
+ break;
+ case mp_transform_type:
+ r = tx_part (q);
+ if (mp_type (r) == mp_independent)
+ return MP_VOID;
+ r = ty_part (q);
+ if (mp_type (r) == mp_independent)
+ return MP_VOID;
+ r = xx_part (q);
+ if (mp_type (r) == mp_independent)
+ return MP_VOID;
+ r = xy_part (q);
+ if (mp_type (r) == mp_independent)
+ return MP_VOID;
+ r = yx_part (q);
+ if (mp_type (r) == mp_independent)
+ return MP_VOID;
+ r = yy_part (q);
+ if (mp_type (r) == mp_independent)
+ return MP_VOID;
+ break;
+ default: /* there are no other valid cases, but please the compiler */
+ break;
+ }
+ return NULL;
+}
+
+@ The first argument to |add_or_subtract| is the location of a value node
+in a capsule or pair node that will soon be recycled. The second argument
+is either a location within a pair or transform node of |cur_exp|,
+or it is NULL (which means that |cur_exp| itself should be the second
+argument). The third argument is either |plus| or |minus|.
+
+The sum or difference of the numeric quantities will replace the second
+operand. Arithmetic overflow may go undetected; users aren't supposed to
+be monkeying around with really big values.
+@^overflow in arithmetic@>
+
+@<Declare binary action...@>=
+@<Declare the procedure called |dep_finish|@>;
+static void mp_add_or_subtract (MP mp, mp_node p, mp_node q, quarterword c) {
+ mp_variable_type s, t; /* operand types */
+ mp_value_node r; /* dependency list traverser */
+ mp_value_node v = NULL; /* second operand value for dep lists */
+ mp_number vv; /* second operand value for known values */
+ new_number (vv);
+ if (q == NULL) {
+ t = mp->cur_exp.type;
+ if (t < mp_dependent)
+ number_clone (vv, cur_exp_value_number ());
+ else
+ v = (mp_value_node) dep_list ((mp_value_node) cur_exp_node ());
+ } else {
+ t = mp_type (q);
+ if (t < mp_dependent)
+ number_clone (vv, value_number (q));
+ else
+ v = (mp_value_node) dep_list ((mp_value_node) q);
+ }
+ if (t == mp_known) {
+ mp_value_node qq = (mp_value_node) q;
+ if (c == mp_minus)
+ number_negate (vv);
+ if (mp_type (p) == mp_known) {
+ slow_add (vv, value_number (p), vv);
+ if (q == NULL)
+ set_cur_exp_value_number (vv);
+ else
+ set_value_number (q, vv);
+ free_number (vv);
+ return;
+ }
+ /* Add a known value to the constant term of |dep_list(p)| */
+ r = (mp_value_node) dep_list ((mp_value_node) p);
+ while (dep_info (r) != NULL)
+ r = (mp_value_node) mp_link (r);
+ slow_add (vv, dep_value (r), vv);
+ set_dep_value (r, vv);
+ if (qq == NULL) {
+ qq = mp_get_dep_node (mp);
+ set_cur_exp_node ((mp_node) qq);
+ mp->cur_exp.type = mp_type (p);
+ mp_name_type (qq) = mp_capsule;
+ /* clang: never read: |q = (mp_node) qq;| */
+ }
+ set_dep_list (qq, dep_list ((mp_value_node) p));
+ mp_type (qq) = mp_type (p);
+ set_prev_dep (qq, prev_dep ((mp_value_node) p));
+ mp_link (prev_dep ((mp_value_node) p)) = (mp_node) qq;
+ mp_type (p) = mp_known; /* this will keep the recycler from collecting non-garbage */
+ } else {
+ if (c == mp_minus)
+ mp_negate_dep_list (mp, v);
+ /* Add operand |p| to the dependency list |v| */
+ /* We prefer |dependent| lists to |mp_proto_dependent| ones, because it is
+ nice to retain the extra accuracy of |fraction| coefficients.
+ But we have to handle both kinds, and mixtures too. */
+ if (mp_type (p) == mp_known) {
+ /* Add the known |value(p)| to the constant term of |v| */
+ while (dep_info (v) != NULL) {
+ v = (mp_value_node) mp_link (v);
+ }
+ slow_add (vv, value_number (p), dep_value (v));
+ set_dep_value (v, vv);
+ } else {
+ s = mp_type (p);
+ r = (mp_value_node) dep_list ((mp_value_node) p);
+ if (t == mp_dependent) {
+ if (s == mp_dependent) {
+ mp_number ret1, ret2;
+ new_fraction (ret1);
+ new_fraction (ret2);
+ mp_max_coef (mp, &ret1, r);
+ mp_max_coef (mp, &ret2, v);
+ number_add (ret1, ret2);
+ free_number (ret2);
+ if (number_less (ret1, coef_bound_k)) {
+ v = mp_p_plus_q (mp, v, r, mp_dependent);
+ free_number (ret1);
+ goto DONE;
+ }
+ free_number (ret1);
+ } /* |fix_needed| will necessarily be false */
+ t = mp_proto_dependent;
+ v = mp_p_over_v (mp, v, unity_t, mp_dependent, mp_proto_dependent);
+ }
+ if (s == mp_proto_dependent)
+ v = mp_p_plus_q (mp, v, r, mp_proto_dependent);
+ else
+ v = mp_p_plus_fq (mp, v, unity_t, r, mp_proto_dependent, mp_dependent);
+ DONE:
+ /* Output the answer, |v| (which might have become |known|) */
+ if (q != NULL) {
+ mp_dep_finish (mp, v, (mp_value_node) q, t);
+ } else {
+ mp->cur_exp.type = t;
+ mp_dep_finish (mp, v, NULL, t);
+ }
+ }
+ }
+ free_number (vv);
+}
+
+
+@ 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|@>=
+static void mp_dep_finish (MP mp, mp_value_node v, mp_value_node q,
+ quarterword t) {
+ mp_value_node p; /* the destination */
+ if (q == NULL)
+ p = (mp_value_node) cur_exp_node ();
+ else
+ p = q;
+ set_dep_list (p, v);
+ mp_type (p) = t;
+ if (dep_info (v) == NULL) {
+ mp_number vv; /* the value, if it is |known| */
+ new_number (vv);
+ number_clone (vv, value_number (v));
+ if (q == NULL) {
+ mp_value new_expr;
+ memset(&new_expr,0,sizeof(mp_value));
+ new_number(new_expr.data.n);
+ number_clone (new_expr.data.n, vv);
+ mp_flush_cur_exp (mp, new_expr);
+ } else {
+ mp_recycle_value (mp, (mp_node) p);
+ mp_type (q) = mp_known;
+ set_value_number (q, vv);
+ }
+ free_number (vv);
+ } else if (q == NULL) {
+ mp->cur_exp.type = t;
+ }
+ if (mp->fix_needed)
+ mp_fix_dependencies (mp);
+}
+
+@ @<Declare binary action...@>=
+static void mp_dep_mult (MP mp, mp_value_node p, mp_number v, boolean v_is_scaled) {
+ mp_value_node q; /* the dependency list being multiplied by |v| */
+ quarterword s, t; /* its type, before and after */
+ if (p == NULL) {
+ q = (mp_value_node) cur_exp_node ();
+ } else if (mp_type (p) != mp_known) {
+ q = p;
+ } else {
+ {
+ mp_number r1, arg1;
+ new_number (arg1);
+ number_clone (arg1, dep_value (p));
+ if (v_is_scaled) {
+ new_number (r1);
+ take_scaled (r1, arg1, v);
+ } else {
+ new_fraction (r1);
+ take_fraction (r1, arg1, v);
+ }
+ set_dep_value (p, r1);
+ free_number (r1);
+ free_number (arg1);
+ }
+ return;
+ }
+ t = mp_type (q);
+ q = (mp_value_node) dep_list (q);
+ s = t;
+ if (t == mp_dependent) {
+ if (v_is_scaled) {
+ mp_number ab_vs_cd;
+ mp_number arg1, arg2;
+ new_number (ab_vs_cd);
+ new_number (arg2);
+ new_fraction (arg1);
+ mp_max_coef (mp, &arg1, q);
+ number_clone (arg2, v);
+ number_abs (arg2);
+ ab_vs_cd (ab_vs_cd, arg1, arg2, coef_bound_minus_1, unity_t);
+ free_number (arg1);
+ free_number (arg2);
+ if (number_nonnegative(ab_vs_cd)) {
+ t = mp_proto_dependent;
+ }
+ free_number (ab_vs_cd);
+ }
+ }
+ q = mp_p_times_v (mp, q, v, s, t, v_is_scaled);
+ mp_dep_finish (mp, q, p, t);
+}
+
+
+@ Here is a routine that is similar to |times|; but it is invoked only
+internally, when |v| is a |fraction| whose magnitude is at most~1,
+and when |cur_type>=mp_color_type|.
+
+@c
+static void mp_frac_mult (MP mp, mp_number n, mp_number d) {
+ /* multiplies |cur_exp| by |n/d| */
+ mp_node old_exp; /* a capsule to recycle */
+ mp_number v; /* |n/d| */
+ new_fraction (v);
+ if (number_greater (internal_value (mp_tracing_commands), two_t)) {
+ @<Trace the fraction multiplication@>;
+ }
+ switch (mp->cur_exp.type) {
+ case mp_transform_type:
+ case mp_color_type:
+ case mp_cmykcolor_type:
+ case mp_pair_type:
+ old_exp = mp_tarnished (mp, cur_exp_node ());
+ break;
+ case mp_independent:
+ old_exp = MP_VOID;
+ break;
+ default:
+ old_exp = NULL;
+ break;
+ }
+ if (old_exp != NULL) {
+ old_exp = cur_exp_node ();
+ mp_make_exp_copy (mp, old_exp);
+ }
+ make_fraction (v, n, d);
+ if (mp->cur_exp.type == mp_known) {
+ mp_number r1, arg1;
+ new_fraction (r1);
+ new_number (arg1);
+ number_clone (arg1, cur_exp_value_number ());
+ take_fraction (r1, arg1, v);
+ set_cur_exp_value_number (r1);
+ free_number (r1);
+ free_number (arg1);
+ } else if (mp->cur_exp.type == mp_pair_type) {
+ mp_dep_mult (mp, (mp_value_node) x_part (value_node (cur_exp_node ())), v, false);
+ mp_dep_mult (mp, (mp_value_node) y_part (value_node (cur_exp_node ())), v, false);
+ } else if (mp->cur_exp.type == mp_color_type) {
+ mp_dep_mult (mp, (mp_value_node) red_part (value_node (cur_exp_node ())), v, false);
+ mp_dep_mult (mp, (mp_value_node) green_part (value_node (cur_exp_node ())), v, false);
+ mp_dep_mult (mp, (mp_value_node) blue_part (value_node (cur_exp_node ())), v, false);
+ } else if (mp->cur_exp.type == mp_cmykcolor_type) {
+ mp_dep_mult (mp, (mp_value_node) cyan_part (value_node (cur_exp_node ())), v, false);
+ mp_dep_mult (mp, (mp_value_node) magenta_part (value_node (cur_exp_node ())), v, false);
+ mp_dep_mult (mp, (mp_value_node) yellow_part (value_node (cur_exp_node ())), v, false);
+ mp_dep_mult (mp, (mp_value_node) black_part (value_node (cur_exp_node ())), v, false);
+ } else {
+ mp_dep_mult (mp, NULL, v, false);
+ }
+ if (old_exp != NULL) {
+ mp_recycle_value (mp, old_exp);
+ mp_free_value_node (mp, old_exp);
+ }
+ free_number (v);
+}
+
+
+@ @<Trace the fraction multiplication@>=
+{
+ mp_begin_diagnostic (mp);
+ mp_print_nl (mp, "{(");
+ print_number (n);
+ mp_print_char (mp, xord ('/'));
+ print_number (d);
+ mp_print (mp, ")*(");
+ mp_print_exp (mp, NULL, 0);
+ mp_print (mp, ")}");
+ mp_end_diagnostic (mp, false);
+}
+
+
+@ The |hard_times| routine multiplies a nice color or pair by a dependency list.
+
+@<Declare binary action procedures@>=
+static void mp_hard_times (MP mp, mp_node p) {
+ mp_value_node q; /* a copy of the dependent variable |p| */
+ mp_value_node pp; /* for typecasting p */
+ mp_node r; /* a component of the big node for the nice color or pair */
+ mp_number v; /* the known value for |r| */
+ new_number (v);
+ if (mp_type (p) <= mp_pair_type) {
+ q = (mp_value_node) mp_stash_cur_exp (mp);
+ mp_unstash_cur_exp (mp, p);
+ p = (mp_node) q;
+ } /* now |cur_type=mp_pair_type| or |cur_type=mp_color_type| or |cur_type=mp_cmykcolor_type| */
+ pp = (mp_value_node) p;
+ if (mp->cur_exp.type == mp_pair_type) {
+ r = x_part (value_node (cur_exp_node ()));
+ number_clone(v, value_number (r));
+ mp_new_dep (mp, r, mp_type (pp),
+ mp_copy_dep_list (mp, (mp_value_node) dep_list (pp)));
+ mp_dep_mult (mp, (mp_value_node) r, v, true);
+ r = y_part (value_node (cur_exp_node ()));
+ number_clone(v, value_number (r));
+ mp_new_dep (mp, r, mp_type (pp),
+ mp_copy_dep_list (mp, (mp_value_node) dep_list (pp)));
+ mp_dep_mult (mp, (mp_value_node) r, v, true);
+ } else if (mp->cur_exp.type == mp_color_type) {
+ r = red_part (value_node (cur_exp_node ()));
+ number_clone(v, value_number (r));
+ mp_new_dep (mp, r, mp_type (pp),
+ mp_copy_dep_list (mp, (mp_value_node) dep_list (pp)));
+ mp_dep_mult (mp, (mp_value_node) r, v, true);
+ r = green_part (value_node (cur_exp_node ()));
+ number_clone(v, value_number (r));
+ mp_new_dep (mp, r, mp_type (pp),
+ mp_copy_dep_list (mp, (mp_value_node) dep_list (pp)));
+ mp_dep_mult (mp, (mp_value_node) r, v, true);
+ r = blue_part (value_node (cur_exp_node ()));
+ number_clone(v, value_number (r));
+ mp_new_dep (mp, r, mp_type (pp),
+ mp_copy_dep_list (mp, (mp_value_node) dep_list (pp)));
+ mp_dep_mult (mp, (mp_value_node) r, v, true);
+ } else if (mp->cur_exp.type == mp_cmykcolor_type) {
+ r = cyan_part (value_node (cur_exp_node ()));
+ number_clone(v, value_number (r));
+ mp_new_dep (mp, r, mp_type (pp),
+ mp_copy_dep_list (mp, (mp_value_node) dep_list (pp)));
+ mp_dep_mult (mp, (mp_value_node) r, v, true);
+ r = yellow_part (value_node (cur_exp_node ()));
+ number_clone(v, value_number (r));
+ mp_new_dep (mp, r, mp_type (pp),
+ mp_copy_dep_list (mp, (mp_value_node) dep_list (pp)));
+ mp_dep_mult (mp, (mp_value_node) r, v, true);
+ r = magenta_part (value_node (cur_exp_node ()));
+ number_clone(v, value_number (r));
+ mp_new_dep (mp, r, mp_type (pp),
+ mp_copy_dep_list (mp, (mp_value_node) dep_list (pp)));
+ mp_dep_mult (mp, (mp_value_node) r, v, true);
+ r = black_part (value_node (cur_exp_node ()));
+ number_clone(v, value_number (r));
+ mp_new_dep (mp, r, mp_type (pp),
+ mp_copy_dep_list (mp, (mp_value_node) dep_list (pp)));
+ mp_dep_mult (mp, (mp_value_node) r, v, true);
+ }
+ free_number (v);
+}
+
+@ @<Declare binary action...@>=
+static void mp_dep_div (MP mp, mp_value_node p, mp_number v) {
+ mp_value_node q; /* the dependency list being divided by |v| */
+ quarterword s, t; /* its type, before and after */
+ if (p == NULL)
+ q = (mp_value_node) cur_exp_node ();
+ else if (mp_type (p) != mp_known)
+ q = p;
+ else {
+ mp_number ret;
+ new_number (ret);
+ make_scaled (ret, value_number (p), v);
+ set_value_number (p, ret);
+ free_number (ret);
+ return;
+ }
+ t = mp_type (q);
+ q = (mp_value_node) dep_list (q);
+ s = t;
+ if (t == mp_dependent) {
+ mp_number ab_vs_cd;
+ mp_number arg1, arg2;
+ new_number (ab_vs_cd);
+ new_number (arg2);
+ new_fraction (arg1);
+ mp_max_coef (mp, &arg1, q);
+ number_clone (arg2, v);
+ number_abs (arg2);
+ ab_vs_cd (ab_vs_cd, arg1, unity_t, coef_bound_minus_1, arg2);
+ free_number (arg1);
+ free_number (arg2);
+ if (number_nonnegative(ab_vs_cd)) {
+ t = mp_proto_dependent;
+ }
+ free_number (ab_vs_cd);
+ }
+ q = mp_p_over_v (mp, q, v, s, t);
+ mp_dep_finish (mp, q, p, t);
+}
+
+@ 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...@>=
+static void mp_set_up_trans (MP mp, quarterword c) {
+ mp_node p, q, r; /* list manipulation registers */
+ mp_value new_expr;
+ memset(&new_expr,0,sizeof(mp_value));
+ if ((c != mp_transformed_by) || (mp->cur_exp.type != mp_transform_type)) {
+ /* Put the current transform into |cur_exp| */
+ const char *hlp[] = {
+ "The expression shown above has the wrong type,",
+ "so I can\'t transform anything using it.",
+ "Proceed, and I'll omit the transformation.",
+ NULL };
+ p = mp_stash_cur_exp (mp);
+ set_cur_exp_node (mp_id_transform (mp));
+ mp->cur_exp.type = mp_transform_type;
+ q = value_node (cur_exp_node ());
+ switch (c) {
+ @<For each of the eight cases, change the relevant fields of |cur_exp|
+ and |goto done|;
+ but do nothing if capsule |p| doesn't have the appropriate type@>;
+ }; /* there are no other cases */
+ mp_disp_err (mp, p);
+ mp_back_error (mp, "Improper transformation argument", hlp, true);
+ mp_get_x_next (mp);
+ DONE:
+ mp_recycle_value (mp, p);
+ mp_free_value_node (mp, p);
+
+ }
+ /* If the current transform is entirely known, stash it in global variables;
+ otherwise |return| */
+ q = value_node (cur_exp_node ());
+ if (mp_type (tx_part (q)) != mp_known)
+ return;
+ if (mp_type (ty_part (q)) != mp_known)
+ return;
+ if (mp_type (xx_part (q)) != mp_known)
+ return;
+ if (mp_type (xy_part (q)) != mp_known)
+ return;
+ if (mp_type (yx_part (q)) != mp_known)
+ return;
+ if (mp_type (yy_part (q)) != mp_known)
+ return;
+ number_clone(mp->txx, value_number (xx_part (q)));
+ number_clone(mp->txy, value_number (xy_part (q)));
+ number_clone(mp->tyx, value_number (yx_part (q)));
+ number_clone(mp->tyy, value_number (yy_part (q)));
+ number_clone(mp->tx, value_number (tx_part (q)));
+ number_clone(mp->ty, value_number (ty_part (q)));
+ new_number(new_expr.data.n);
+ set_number_to_zero (new_expr.data.n);
+ mp_flush_cur_exp (mp, new_expr);
+}
+
+
+@ @<Glob...@>=
+mp_number txx;
+mp_number txy;
+mp_number tyx;
+mp_number tyy;
+mp_number tx;
+mp_number ty; /* current transform coefficients */
+
+@ @<Initialize table...@>=
+new_number(mp->txx);
+new_number(mp->txy);
+new_number(mp->tyx);
+new_number(mp->tyy);
+new_number(mp->tx);
+new_number(mp->ty);
+
+@ @<Free table...@>=
+free_number(mp->txx);
+free_number(mp->txy);
+free_number(mp->tyx);
+free_number(mp->tyy);
+free_number(mp->tx);
+free_number(mp->ty);
+
+
+@ @<For each of the eight cases...@>=
+case mp_rotated_by:
+if (mp_type (p) == mp_known)
+ @<Install sines and cosines, then |goto done|@>;
+break;
+case mp_slanted_by:
+if (mp_type (p) > mp_pair_type) {
+ mp_install (mp, xy_part (q), p);
+ goto DONE;
+}
+break;
+case mp_scaled_by:
+if (mp_type (p) > mp_pair_type) {
+ mp_install (mp, xx_part (q), p);
+ mp_install (mp, yy_part (q), p);
+ goto DONE;
+}
+break;
+case mp_shifted_by:
+if (mp_type (p) == mp_pair_type) {
+ r = value_node (p);
+ mp_install (mp, tx_part (q), x_part (r));
+ mp_install (mp, ty_part (q), y_part (r));
+ goto DONE;
+}
+break;
+case mp_x_scaled:
+if (mp_type (p) > mp_pair_type) {
+ mp_install (mp, xx_part (q), p);
+ goto DONE;
+}
+break;
+case mp_y_scaled:
+if (mp_type (p) > mp_pair_type) {
+ mp_install (mp, yy_part (q), p);
+ goto DONE;
+}
+break;
+case mp_z_scaled:
+if (mp_type (p) == mp_pair_type)
+ @<Install a complex multiplier, then |goto done|@>;
+break;
+case mp_transformed_by:
+break;
+
+
+@ @<Install sines and cosines, then |goto done|@>=
+{
+ mp_number n_sin, n_cos, arg1, arg2;
+ new_number (arg1);
+ new_number (arg2);
+ new_fraction (n_sin);
+ new_fraction (n_cos); /* results computed by |n_sin_cos| */
+ number_clone (arg2, unity_t);
+ number_clone (arg1, value_number (p));
+ number_multiply_int (arg2, 360);
+ number_modulo (arg1, arg2);
+ convert_scaled_to_angle (arg1);
+ n_sin_cos (arg1, n_cos, n_sin);
+ fraction_to_round_scaled (n_sin);
+ fraction_to_round_scaled (n_cos);
+ set_value_number (xx_part (q), n_cos);
+ set_value_number (yx_part (q), n_sin);
+ set_value_number (xy_part (q), value_number (yx_part (q)));
+ number_negate (value_number (xy_part (q)));
+ set_value_number (yy_part (q), value_number (xx_part (q)));
+ free_number (arg1);
+ free_number (arg2);
+ free_number (n_sin);
+ free_number (n_cos);
+ goto DONE;
+}
+
+
+@ @<Install a complex multiplier, then |goto done|@>=
+{
+ r = value_node (p);
+ mp_install (mp, xx_part (q), x_part (r));
+ mp_install (mp, yy_part (q), x_part (r));
+ mp_install (mp, yx_part (q), y_part (r));
+ if (mp_type (y_part (r)) == mp_known) {
+ set_value_number (y_part (r), value_number (y_part (r)));
+ number_negate (value_number (y_part (r)));
+ } else {
+ mp_negate_dep_list (mp, (mp_value_node) dep_list ((mp_value_node)
+ y_part (r)));
+ }
+ mp_install (mp, xy_part (q), y_part (r));
+ goto DONE;
+}
+
+
+@ Procedure |set_up_known_trans| is like |set_up_trans|, but it
+insists that the transformation be entirely known.
+
+@<Declare binary action...@>=
+static void mp_set_up_known_trans (MP mp, quarterword c) {
+ mp_set_up_trans (mp, c);
+ if (mp->cur_exp.type != mp_known) {
+ mp_value new_expr;
+ const char *hlp[] = {
+ "I'm unable to apply a partially specified transformation",
+ "except to a fully known pair or transform.",
+ "Proceed, and I'll omit the transformation.",
+ NULL };
+ memset(&new_expr,0,sizeof(mp_value));
+ new_number(new_expr.data.n);
+ mp_disp_err(mp, NULL);
+ set_number_to_zero (new_expr.data.n);
+ mp_back_error (mp,"Transform components aren't all known", hlp, true);
+ mp_get_x_next (mp);
+ mp_flush_cur_exp (mp, new_expr);
+ set_number_to_unity(mp->txx);
+ set_number_to_zero(mp->txy);
+ set_number_to_zero(mp->tyx);
+ set_number_to_unity(mp->tyy);
+ set_number_to_zero(mp->tx);
+ set_number_to_zero(mp->ty);
+ }
+}
+
+
+@ Here's a procedure that applies the transform |txx..ty| to a pair of
+coordinates in locations |p| and~|q|.
+
+@<Declare binary action...@>=
+static void mp_number_trans (MP mp, mp_number *p, mp_number *q) {
+ mp_number r1, r2, v;
+ new_number (r1);
+ new_number (r2);
+ new_number (v);
+ take_scaled (r1, *p, mp->txx);
+ take_scaled (r2, *q, mp->txy);
+ number_add (r1, r2);
+ set_number_from_addition(v, r1, mp->tx);
+ take_scaled (r1, *p, mp->tyx);
+ take_scaled (r2, *q, mp->tyy);
+ number_add (r1, r2);
+ set_number_from_addition(*q, r1, mp->ty);
+ number_clone(*p,v);
+ free_number (r1);
+ free_number (r2);
+ free_number(v);
+}
+
+
+@ The simplest transformation procedure applies a transform to all
+coordinates of a path. The |path_trans(c)(p)| macro applies
+a transformation defined by |cur_exp| and the transform operator |c|
+to the path~|p|.
+
+@d path_trans(A,B) { mp_set_up_known_trans(mp, (A));
+ mp_unstash_cur_exp(mp, (B));
+ mp_do_path_trans(mp, cur_exp_knot()); }
+
+@<Declare binary action...@>=
+static void mp_do_path_trans (MP mp, mp_knot p) {
+ mp_knot q; /* list traverser */
+ q = p;
+ do {
+ if (mp_left_type (q) != mp_endpoint)
+ mp_number_trans (mp, &q->left_x, &q->left_y);
+ mp_number_trans (mp, &q->x_coord, &q->y_coord);
+ if (mp_right_type (q) != mp_endpoint)
+ mp_number_trans (mp, &q->right_x, &q->right_y);
+ q = mp_next_knot (q);
+ } while (q != p);
+}
+
+
+@ Transforming a pen is very similar, except that there are no |mp_left_type|
+and |mp_right_type| fields.
+
+@d pen_trans(A,B) { mp_set_up_known_trans(mp, (A));
+ mp_unstash_cur_exp(mp, (B));
+ mp_do_pen_trans(mp, cur_exp_knot()); }
+
+@<Declare binary action...@>=
+static void mp_do_pen_trans (MP mp, mp_knot p) {
+ mp_knot q; /* list traverser */
+ if (pen_is_elliptical (p)) {
+ mp_number_trans (mp, &p->left_x, &p->left_y);
+ mp_number_trans (mp, &p->right_x, &p->right_y);
+ }
+ q = p;
+ do {
+ mp_number_trans (mp, &q->x_coord, &q->y_coord);
+ q = mp_next_knot (q);
+ } while (q != p);
+}
+
+
+@ The next transformation procedure applies to edge structures. It will do
+any transformation, but the results may be substandard if the picture contains
+text that uses downloaded bitmap fonts. The binary action procedure is
+|do_edges_trans|, but we also need a function that just scales a picture.
+That routine is |scale_edges|. Both it and the underlying routine |edges_trans|
+should be thought of as procedures that update an edge structure |h|, except
+that they have to return a (possibly new) structure because of the need to call
+|private_edges|.
+
+@<Declare binary action...@>=
+static mp_edge_header_node mp_edges_trans (MP mp, mp_edge_header_node h) {
+ mp_node q; /* the object being transformed */
+ mp_dash_node r, s; /* for list manipulation */
+ mp_number sx, sy; /* saved transformation parameters */
+ mp_number sqdet; /* square root of determinant for |dash_scale| */
+ mp_number sgndet; /* sign of the determinant */
+ h = mp_private_edges (mp, h);
+ new_number(sx);
+ new_number(sy);
+ new_number(sqdet);
+ new_number(sgndet);
+ mp_sqrt_det (mp, &sqdet, mp->txx, mp->txy, mp->tyx, mp->tyy);
+ ab_vs_cd (sgndet, mp->txx, mp->tyy, mp->txy, mp->tyx);
+ if (dash_list (h) != mp->null_dash) {
+ @<Try to transform the dash list of |h|@>;
+ }
+ @<Make the bounding box of |h| unknown if it can't be updated properly
+ without scanning the whole structure@>;
+ q = mp_link (edge_list (h));
+ while (q != NULL) {
+ @<Transform graphical object |q|@>;
+ q = mp_link (q);
+ }
+ free_number (sx);
+ free_number (sy);
+ free_number (sqdet);
+ free_number(sgndet);
+ return h;
+}
+static void mp_do_edges_trans (MP mp, mp_node p, quarterword c) {
+ mp_set_up_known_trans (mp, c);
+ set_value_node (p, (mp_node)mp_edges_trans (mp, (mp_edge_header_node)value_node (p)));
+ mp_unstash_cur_exp (mp, p);
+}
+static mp_edge_header_node mp_scale_edges (MP mp, mp_number se_sf, mp_edge_header_node se_pic) {
+ number_clone(mp->txx, se_sf);
+ number_clone(mp->tyy, se_sf);
+ set_number_to_zero(mp->txy);
+ set_number_to_zero(mp->tyx);
+ set_number_to_zero(mp->tx);
+ set_number_to_zero(mp->ty);
+ return mp_edges_trans (mp, se_pic);
+}
+
+
+@ @<Try to transform the dash list of |h|@>=
+if (number_nonzero(mp->txy) || number_nonzero(mp->tyx) ||
+ number_nonzero(mp->ty) || number_nonequalabs (mp->txx, mp->tyy)) {
+ mp_flush_dash_list (mp, h);
+} else {
+ mp_number abs_tyy, ret;
+ new_number (abs_tyy);
+ if (number_negative(mp->txx)) {
+ @<Reverse the dash list of |h|@>;
+ }
+ @<Scale the dash list by |txx| and shift it by |tx|@>;
+ number_clone(abs_tyy, mp->tyy);
+ number_abs (abs_tyy);
+ new_number (ret);
+ take_scaled (ret, h->dash_y, abs_tyy);
+ number_clone(h->dash_y, ret);
+ free_number (ret);
+ free_number (abs_tyy);
+}
+
+
+@ @<Reverse the dash list of |h|@>=
+{
+ r = dash_list (h);
+ set_dash_list (h, mp->null_dash);
+ while (r != mp->null_dash) {
+ s = r;
+ r = (mp_dash_node)mp_link (r);
+ number_swap(s->start_x, s->stop_x );
+ mp_link (s) = (mp_node)dash_list (h);
+ set_dash_list (h, s);
+ }
+}
+
+
+@ @<Scale the dash list by |txx| and shift it by |tx|@>=
+r = dash_list (h);
+{
+ mp_number arg1;
+ new_number (arg1);
+ while (r != mp->null_dash) {
+ take_scaled (arg1, r->start_x, mp->txx);
+ set_number_from_addition(r->start_x, arg1, mp->tx);
+ take_scaled (arg1, r->stop_x, mp->txx);
+ set_number_from_addition(r->stop_x, arg1, mp->tx);
+ r = (mp_dash_node)mp_link (r);
+ }
+ free_number (arg1);
+}
+
+
+@ @<Make the bounding box of |h| unknown if it can't be updated properly...@>=
+if (number_zero(mp->txx) && number_zero(mp->tyy)) {
+ @<Swap the $x$ and $y$ parameters in the bounding box of |h|@>;
+} else if (number_nonzero(mp->txy) || number_nonzero(mp->tyx)) {
+ mp_init_bbox (mp, h);
+ goto DONE1;
+}
+if (number_lessequal (h->minx, h->maxx)) {
+ @<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|@>=
+{
+ number_swap(h->minx, h->miny);
+ number_swap(h->maxx, h->maxy);
+}
+
+
+@ 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...@>=
+{
+ mp_number tot, ret;
+ new_number(tot);
+ new_number (ret);
+ set_number_from_addition(tot,mp->txx,mp->txy);
+ take_scaled (ret, h->minx, tot);
+ set_number_from_addition(h->minx,ret, mp->tx);
+ take_scaled (ret, h->maxx, tot);
+ set_number_from_addition(h->maxx,ret, mp->tx);
+
+ set_number_from_addition(tot,mp->tyx,mp->tyy);
+ take_scaled (ret, h->miny, tot);
+ set_number_from_addition(h->miny, ret, mp->ty);
+ take_scaled (ret, h->maxy, tot);
+ set_number_from_addition(h->maxy, ret, mp->ty);
+
+ set_number_from_addition(tot, mp->txx, mp->txy);
+ if (number_negative(tot)) {
+ number_swap(h->minx, h->maxx);
+ }
+ set_number_from_addition(tot, mp->tyx, mp->tyy);
+ if (number_negative(tot)) {
+ number_swap(h->miny, h->maxy);
+ }
+ free_number (ret);
+ free_number (tot);
+}
+
+
+@ Now we ready for the main task of transforming the graphical objects in edge
+structure~|h|.
+
+@<Transform graphical object |q|@>=
+switch (mp_type (q)) {
+case mp_fill_node_type:
+ {
+ mp_fill_node qq = (mp_fill_node) q;
+ mp_do_path_trans (mp, mp_path_p (qq));
+ @<Transform |mp_pen_p(qq)|, making sure polygonal pens stay counter-clockwise@>;
+ }
+ break;
+case mp_stroked_node_type:
+ {
+ mp_stroked_node qq = (mp_stroked_node) q;
+ mp_do_path_trans (mp, mp_path_p (qq));
+ @<Transform |mp_pen_p(qq)|, making sure polygonal pens stay counter-clockwise@>;
+ }
+ break;
+case mp_start_clip_node_type:
+ mp_do_path_trans (mp, mp_path_p ((mp_start_clip_node) q));
+ break;
+case mp_start_bounds_node_type:
+ mp_do_path_trans (mp, mp_path_p ((mp_start_bounds_node) q));
+ break;
+case mp_text_node_type:
+ @<Transform the compact transformation@>;
+ break;
+case mp_stop_clip_node_type:
+case mp_stop_bounds_node_type:
+ break;
+default: /* there are no other valid cases, but please the compiler */
+ break;
+}
+
+
+@ 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 |mp_dash_p(q)|
+since the \ps\ output procedures will try to compensate for the transformation
+we are applying to |mp_pen_p(q)|. Since this compensation is based on the square
+root of the determinant, |sqdet| is the appropriate factor.
+
+We pass the mptrap test only if |dash_scale| is not adjusted, nowadays
+(backend is changed?)
+
+@<Transform |mp_pen_p(qq)|, making sure...@>=
+if (mp_pen_p (qq) != NULL) {
+ number_clone(sx, mp->tx);
+ number_clone(sy, mp->ty);
+ set_number_to_zero(mp->tx);
+ set_number_to_zero(mp->ty);
+ mp_do_pen_trans (mp, mp_pen_p (qq));
+ if (number_nonzero(sqdet)
+ && ((mp_type (q) == mp_stroked_node_type) && (mp_dash_p (q) != NULL))) {
+ mp_number ret;
+ new_number (ret);
+ take_scaled (ret, ((mp_stroked_node)q)->dash_scale, sqdet);
+ number_clone(((mp_stroked_node)q)->dash_scale, ret);
+ free_number (ret);
+ }
+ if (!pen_is_elliptical (mp_pen_p (qq)))
+ if (number_negative(sgndet))
+ mp_pen_p (qq) = mp_make_pen (mp, mp_copy_path (mp, mp_pen_p (qq)), true);
+ /* this unreverses the pen */
+ number_clone(mp->tx, sx);
+ number_clone(mp->ty, sy);
+}
+
+@ @<Transform the compact transformation@>=
+mp_number_trans (mp, &((mp_text_node)q)->tx, &((mp_text_node)q)->ty);
+number_clone(sx, mp->tx);
+number_clone(sy, mp->ty);
+set_number_to_zero(mp->tx);
+set_number_to_zero(mp->ty);
+mp_number_trans (mp, &((mp_text_node)q)->txx, &((mp_text_node)q)->tyx);
+mp_number_trans (mp, &((mp_text_node)q)->txy, &((mp_text_node)q)->tyy);
+number_clone(mp->tx, sx);
+number_clone(mp->ty, sy)
+
+@ The hard cases of transformation occur when big nodes are involved,
+and when some of their components are unknown.
+
+@<Declare binary action...@>=
+@<Declare subroutines needed by |big_trans|@>;
+static void mp_big_trans (MP mp, mp_node p, quarterword c) {
+ mp_node q, r, pp, qq; /* list manipulation registers */
+ q = value_node (p);
+ if (mp_type (q) == mp_pair_node_type) {
+ if (mp_type (x_part (q)) != mp_known ||
+ mp_type (y_part (q)) != mp_known) {
+ @<Transform an unknown big node and |return|@>;
+ }
+ } else { /* |mp_transform_type| */
+ if (mp_type (tx_part (q)) != mp_known ||
+ mp_type (ty_part (q)) != mp_known ||
+ mp_type (xx_part (q)) != mp_known ||
+ mp_type (xy_part (q)) != mp_known ||
+ mp_type (yx_part (q)) != mp_known ||
+ mp_type (yy_part (q)) != mp_known) {
+ @<Transform an unknown big node and |return|@>;
+ }
+ }
+ @<Transform a known big node@>;
+} /* node |p| will now be recycled by |do_binary| */
+
+
+@ @<Transform an unknown big node and |return|@>=
+{
+ mp_set_up_known_trans (mp, c);
+ mp_make_exp_copy (mp, p);
+ r = value_node (cur_exp_node ());
+ if (mp->cur_exp.type == mp_transform_type) {
+ mp_bilin1 (mp, yy_part (r), mp->tyy, xy_part (q), mp->tyx, zero_t);
+ mp_bilin1 (mp, yx_part (r), mp->tyy, xx_part (q), mp->tyx, zero_t);
+ mp_bilin1 (mp, xy_part (r), mp->txx, yy_part (q), mp->txy, zero_t);
+ mp_bilin1 (mp, xx_part (r), mp->txx, yx_part (q), mp->txy, zero_t);
+ }
+ mp_bilin1 (mp, y_part (r), mp->tyy, x_part (q), mp->tyx, mp->ty);
+ mp_bilin1 (mp, x_part (r), mp->txx, y_part (q), mp->txy, mp->tx);
+ return;
+}
+
+
+@ Let |p| point to a 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|@>=
+static void mp_bilin1 (MP mp, mp_node p, mp_number t, mp_node q,
+ mp_number u, mp_number delta_orig) {
+ mp_number delta;
+ new_number (delta);
+ number_clone (delta, delta_orig);
+ if (!number_equal(t, unity_t)) {
+ mp_dep_mult (mp, (mp_value_node) p, t, true);
+ }
+ if (number_nonzero(u)) {
+ if (mp_type (q) == mp_known) {
+ mp_number tmp;
+ new_number (tmp);
+ take_scaled (tmp, value_number (q), u);
+ number_add (delta, tmp);
+ free_number (tmp);
+ } else {
+ /* Ensure that |type(p)=mp_proto_dependent| */
+ if (mp_type (p) != mp_proto_dependent) {
+ if (mp_type (p) == mp_known) {
+ mp_new_dep (mp, p, mp_type (p), mp_const_dependency (mp, value_number (p)));
+ } else {
+ set_dep_list ((mp_value_node) p,
+ mp_p_times_v (mp,
+ (mp_value_node) dep_list ((mp_value_node)
+ p), unity_t,
+ mp_dependent, mp_proto_dependent, true));
+ }
+ mp_type (p) = mp_proto_dependent;
+ }
+ set_dep_list ((mp_value_node) p,
+ mp_p_plus_fq (mp,
+ (mp_value_node) dep_list ((mp_value_node) p), u,
+ (mp_value_node) dep_list ((mp_value_node) q),
+ mp_proto_dependent, mp_type (q)));
+ }
+ }
+ if (mp_type (p) == mp_known) {
+ set_value_number (p, value_number (p));
+ number_add (value_number (p), delta);
+ } else {
+ mp_number tmp;
+ mp_value_node r; /* list traverser */
+ new_number (tmp);
+ r = (mp_value_node) dep_list ((mp_value_node) p);
+ while (dep_info (r) != NULL)
+ r = (mp_value_node) mp_link (r);
+ number_clone (tmp, value_number(r));
+ number_add (delta, tmp);
+ if (r != (mp_value_node) dep_list ((mp_value_node) p))
+ set_value_number (r, delta);
+ else {
+ mp_recycle_value (mp, p);
+ mp_type (p) = mp_known;
+ set_value_number (p, delta);
+ }
+ free_number (tmp);
+ }
+ if (mp->fix_needed)
+ mp_fix_dependencies (mp);
+ free_number (delta);
+}
+
+
+@ @<Transform a known big node@>=
+mp_set_up_trans (mp, c);
+if (mp->cur_exp.type == mp_known) {
+ @<Transform known by known@>;
+} else {
+ pp = mp_stash_cur_exp (mp);
+ qq = value_node (pp);
+ mp_make_exp_copy (mp, p);
+ r = value_node (cur_exp_node ());
+ if (mp->cur_exp.type == mp_transform_type) {
+ mp_bilin2 (mp, yy_part (r), yy_part (qq), value_number (xy_part (q)),
+ yx_part (qq), NULL);
+ mp_bilin2 (mp, yx_part (r), yy_part (qq), value_number (xx_part (q)),
+ yx_part (qq), NULL);
+ mp_bilin2 (mp, xy_part (r), xx_part (qq), value_number (yy_part (q)),
+ xy_part (qq), NULL);
+ mp_bilin2 (mp, xx_part (r), xx_part (qq), value_number (yx_part (q)),
+ xy_part (qq), NULL);
+ }
+ mp_bilin2 (mp, y_part (r), yy_part (qq), value_number (x_part (q)),
+ yx_part (qq), y_part (qq));
+ mp_bilin2 (mp, x_part (r), xx_part (qq), value_number (y_part (q)),
+ xy_part (qq), x_part (qq));
+ mp_recycle_value (mp, pp);
+ mp_free_value_node (mp, pp);
+}
+
+
+@ Let |p| be a |mp_proto_dependent| value whose dependency list ends
+at |dep_final|. The following procedure adds |v| times another
+numeric quantity to~|p|.
+
+@<Declare subroutines needed by |big_trans|@>=
+static void mp_add_mult_dep (MP mp, mp_value_node p, mp_number v, mp_node r) {
+ if (mp_type (r) == mp_known) {
+ mp_number ret;
+ new_number (ret);
+ take_scaled (ret, value_number (r), v);
+ set_dep_value (mp->dep_final, dep_value (mp->dep_final));
+ number_add (dep_value (mp->dep_final), ret);
+ free_number (ret);
+ } else {
+ set_dep_list (p,
+ mp_p_plus_fq (mp, (mp_value_node) dep_list (p), v,
+ (mp_value_node) dep_list ((mp_value_node) r),
+ mp_proto_dependent, mp_type (r)));
+ if (mp->fix_needed)
+ mp_fix_dependencies (mp);
+ }
+}
+
+
+@ The |bilin2| procedure is something like |bilin1|, but with known
+and unknown quantities reversed. Parameter |p| points to a value field
+within the big node for |cur_exp|; and |type(p)=mp_known|. Parameters
+|t| and~|u| point to value fields elsewhere; so does parameter~|q|,
+unless it is |NULL| (which stands for zero). Location~|p| will be
+replaced by $p\cdot t+v\cdot u+q$.
+
+@<Declare subroutines needed by |big_trans|@>=
+static void mp_bilin2 (MP mp, mp_node p, mp_node t, mp_number v,
+ mp_node u, mp_node q) {
+ mp_number vv; /* temporary storage for |value(p)| */
+ new_number (vv);
+ number_clone (vv, value_number (p));
+ mp_new_dep (mp, p, mp_proto_dependent, mp_const_dependency (mp, zero_t)); /* this sets |dep_final| */
+ if (number_nonzero(vv)) {
+ mp_add_mult_dep (mp, (mp_value_node) p, vv, t); /* |dep_final| doesn't change */
+ }
+ if (number_nonzero(v)) {
+ mp_number arg1;
+ new_number (arg1);
+ number_clone (arg1, v);
+ mp_add_mult_dep (mp, (mp_value_node) p, arg1, u);
+ free_number (arg1);
+ }
+ if (q != NULL)
+ mp_add_mult_dep (mp, (mp_value_node) p, unity_t, q);
+ if (dep_list ((mp_value_node) p) == (mp_node) mp->dep_final) {
+ number_clone (vv, dep_value (mp->dep_final));
+ mp_recycle_value (mp, p);
+ mp_type (p) = mp_known;
+ set_value_number (p, vv);
+ }
+ free_number (vv);
+}
+
+
+@ @<Transform known by known@>=
+{
+ mp_make_exp_copy (mp, p);
+ r = value_node (cur_exp_node ());
+ if (mp->cur_exp.type == mp_transform_type) {
+ mp_bilin3 (mp, yy_part (r), mp->tyy, value_number (xy_part (q)), mp->tyx, zero_t);
+ mp_bilin3 (mp, yx_part (r), mp->tyy, value_number (xx_part (q)), mp->tyx, zero_t);
+ mp_bilin3 (mp, xy_part (r), mp->txx, value_number (yy_part (q)), mp->txy, zero_t);
+ mp_bilin3 (mp, xx_part (r), mp->txx, value_number (yx_part (q)), mp->txy, zero_t);
+ }
+ mp_bilin3 (mp, y_part (r), mp->tyy, value_number (x_part (q)), mp->tyx, mp->ty);
+ mp_bilin3 (mp, x_part (r), mp->txx, value_number (y_part (q)), mp->txy, mp->tx);
+}
+
+
+@ Finally, in |bilin3| everything is |known|.
+
+@<Declare subroutines needed by |big_trans|@>=
+static void mp_bilin3 (MP mp, mp_node p, mp_number t,
+ mp_number v, mp_number u, mp_number delta_orig) {
+ mp_number delta;
+ mp_number tmp;
+ new_number (tmp);
+ new_number (delta);
+ number_clone (delta, delta_orig);
+ if (!number_equal(t, unity_t)) {
+ take_scaled (tmp, value_number (p), t);
+ } else {
+ number_clone (tmp, value_number (p));
+ }
+ number_add (delta, tmp);
+ if (number_nonzero(u)) {
+ mp_number ret;
+ new_number (ret);
+ take_scaled (ret, v, u);
+ set_value_number (p, delta);
+ number_add (value_number (p), ret);
+ free_number (ret);
+ } else
+ set_value_number (p, delta);
+ free_number (tmp);
+ free_number (delta);
+}
+
+
+@ @<Declare binary action...@>=
+static void mp_chop_path (MP mp, mp_node p) {
+ mp_knot q; /* a knot in the original path */
+ mp_knot pp, qq, rr, ss; /* link variables for copies of path nodes */
+ mp_number a, b; /* indices for chopping */
+ mp_number l;
+ boolean reversed; /* was |a>b|? */
+ new_number (a);
+ new_number (b);
+ new_number (l);
+ mp_path_length (mp, &l);
+ number_clone (a, value_number (x_part (p)));
+ number_clone (b, value_number (y_part (p)));
+ if (number_lessequal(a, b)) {
+ reversed = false;
+ } else {
+ reversed = true;
+ number_swap (a, b);
+ }
+ /* Dispense with the cases |a<0| and/or |b>l| */
+ if (number_negative(a)) {
+ if (mp_left_type (cur_exp_knot ()) == mp_endpoint) {
+ set_number_to_zero(a);
+ if (number_negative(b))
+ set_number_to_zero(b);
+ } else {
+ do {
+ number_add (a, l);
+ number_add (b, l);
+ } while (number_negative(a)); /* a cycle always has length |l>0| */
+ }
+ }
+ if (number_greater (b, l)) {
+ if (mp_left_type (cur_exp_knot ()) == mp_endpoint) {
+ number_clone (b, l);
+ if (number_greater (a, l))
+ number_clone(a, l);
+ } else {
+ while (number_greaterequal (a, l)) {
+ number_substract (a, l);
+ number_substract (b, l);
+ }
+ }
+ }
+
+ q = cur_exp_knot ();
+ while (number_greaterequal(a, unity_t)) {
+ q = mp_next_knot (q);
+ number_substract(a, unity_t);
+ number_substract(b, unity_t);
+ }
+ if (number_equal(b, a)) {
+ /* Construct a path from |pp| to |qq| of length zero */
+ if (number_positive (a)) {
+ mp_number arg1;
+ new_number (arg1);
+ number_clone (arg1, a);
+ convert_scaled_to_fraction (arg1);
+ mp_split_cubic (mp, q, arg1);
+ free_number (arg1);
+ q = mp_next_knot (q);
+ }
+ pp = mp_copy_knot (mp, q);
+ qq = pp;
+
+ } else {
+ /* Construct a path from |pp| to |qq| of length $\lceil b\rceil$ */
+ pp = mp_copy_knot (mp, q);
+ qq = pp;
+ do {
+ q = mp_next_knot (q);
+ rr = qq;
+ qq = mp_copy_knot (mp, q);
+ mp_next_knot (rr) = qq;
+ number_substract (b, unity_t);
+ } while (number_positive (b));
+ if (number_positive (a)) {
+ mp_number arg1;
+ new_number (arg1);
+ ss = pp;
+ number_clone (arg1, a);
+ convert_scaled_to_fraction (arg1);
+ mp_split_cubic (mp, ss, arg1);
+ free_number (arg1);
+ pp = mp_next_knot (ss);
+ mp_toss_knot (mp, ss);
+ if (rr == ss) {
+ mp_number arg1, arg2;
+ new_number (arg1);
+ new_number (arg2);
+ set_number_from_substraction (arg1, unity_t, a);
+ number_clone (arg2, b);
+ make_scaled (b, arg2, arg1);
+ free_number (arg1);
+ free_number (arg2);
+ rr = pp;
+ }
+ }
+ if (number_negative (b)) {
+ mp_number arg1;
+ new_number (arg1);
+ set_number_from_addition (arg1, b, unity_t);
+ convert_scaled_to_fraction (arg1);
+ mp_split_cubic (mp, rr, arg1);
+ free_number (arg1);
+ mp_toss_knot (mp, qq);
+ qq = mp_next_knot (rr);
+ }
+
+ }
+ mp_left_type (pp) = mp_endpoint;
+ mp_right_type (qq) = mp_endpoint;
+ mp_next_knot (qq) = pp;
+ mp_toss_knot_list (mp, cur_exp_knot ());
+ if (reversed) {
+ set_cur_exp_knot (mp_next_knot (mp_htap_ypoc (mp, pp)));
+ mp_toss_knot_list (mp, pp);
+ } else {
+ set_cur_exp_knot (pp);
+ }
+ free_number (l);
+ free_number (a);
+ free_number (b);
+}
+
+
+@ @<Declare binary action...@>=
+static void mp_set_up_offset (MP mp, mp_node p) {
+ mp_find_offset (mp, value_number (x_part (p)), value_number (y_part (p)),
+ cur_exp_knot ());
+ mp_pair_value (mp, mp->cur_x, mp->cur_y);
+}
+static void mp_set_up_direction_time (MP mp, mp_node p) {
+ mp_value new_expr;
+ memset(&new_expr,0,sizeof(mp_value));
+ new_number (new_expr.data.n);
+ mp_find_direction_time (mp, &new_expr.data.n, value_number (x_part (p)),
+ value_number (y_part (p)),
+ cur_exp_knot ());
+ mp_flush_cur_exp (mp, new_expr);
+}
+static void mp_set_up_envelope (MP mp, mp_node p) {
+ unsigned char ljoin, lcap;
+ mp_number miterlim;
+ mp_knot q = mp_copy_path (mp, cur_exp_knot ()); /* the original path */
+ new_number(miterlim);
+ /* TODO: accept elliptical pens for straight paths */
+ if (pen_is_elliptical (value_knot (p))) {
+ mp_bad_envelope_pen (mp);
+ set_cur_exp_knot (q);
+ mp->cur_exp.type = mp_path_type;
+ return;
+ }
+ if (number_greater (internal_value (mp_linejoin), unity_t))
+ ljoin = 2;
+ else if (number_positive (internal_value (mp_linejoin)))
+ ljoin = 1;
+ else
+ ljoin = 0;
+ if (number_greater (internal_value (mp_linecap), unity_t))
+ lcap = 2;
+ else if (number_positive (internal_value (mp_linecap)))
+ lcap = 1;
+ else
+ lcap = 0;
+ if (number_less (internal_value (mp_miterlimit), unity_t))
+ set_number_to_unity(miterlim);
+ else
+ number_clone(miterlim, internal_value (mp_miterlimit));
+ set_cur_exp_knot (mp_make_envelope
+ (mp, q, value_knot (p), ljoin, lcap, miterlim));
+ mp->cur_exp.type = mp_path_type;
+}
+static void mp_set_up_boundingpath (MP mp, mp_node p) {
+ unsigned char ljoin, lcap;
+ mp_number miterlim;
+ mp_knot q = mp_copy_path (mp, cur_exp_knot ()); /* the original path */
+ mp_knot pen;
+ mp_knot qq;
+
+ new_number(miterlim);
+ pen = (value_knot (p));
+ /* accept elliptical pens for s paths */
+ /* using |mp_make_path| to convert an elliptical pen to a polygonal one. */
+ /* The approximation of 8 knots should be good enough. */
+ if (pen_is_elliptical (value_knot (p))) {
+ mp_knot kp,kq;
+ pen = copy_pen (value_knot (p));
+ mp_make_path(mp, pen);
+ kq=pen;
+ do {
+ kp = kq;
+ kq = mp_next_knot (kq);
+ mp_prev_knot (kq) = kp;
+ } while (kq != pen);
+ mp_close_path_cycle (mp, kp, pen);
+ }
+ if (number_greater (internal_value (mp_linejoin), unity_t))
+ ljoin = 2;
+ else if (number_positive (internal_value (mp_linejoin)))
+ ljoin = 1;
+ else
+ ljoin = 0;
+ if (number_greater (internal_value (mp_linecap), unity_t))
+ lcap = 2;
+ else if (number_positive (internal_value (mp_linecap)))
+ lcap = 1;
+ else
+ lcap = 0;
+ if (number_less (internal_value (mp_miterlimit), unity_t))
+ set_number_to_unity(miterlim);
+ else
+ number_clone(miterlim, internal_value (mp_miterlimit));
+ qq = mp_make_envelope(mp, q, pen, ljoin, lcap, miterlim);
+ set_cur_exp_knot (qq);
+ mp->cur_exp.type = mp_path_type;
+ if (!mp_get_cur_bbox (mp)) {
+ mp_bad_binary (mp, p, mp_boundingpath_of);
+ set_cur_exp_knot (q);
+ mp->cur_exp.type = mp_path_type;
+ return;
+ }
+ else {
+ mp_knot ll,lr,ur,ul;
+ ll = mp_new_knot (mp);
+ lr = mp_new_knot (mp);
+ ur = mp_new_knot (mp);
+ ul = mp_new_knot (mp);
+ if (ll==NULL || lr==NULL || ur==NULL || ul==NULL){
+ mp_bad_binary (mp, p, mp_boundingpath_of);
+ set_cur_exp_knot (q);
+ mp->cur_exp.type = mp_path_type;
+ return;
+ }
+ mp_left_type (ll) = mp_endpoint;
+ mp_right_type (ll) = mp_endpoint;
+ mp_originator (ll) = mp_program_code;
+ number_clone(ll->x_coord,mp_minx);
+ number_clone(ll->y_coord,mp_miny);
+
+ mp_originator (lr) = mp_program_code;
+ number_clone(lr->x_coord,mp_maxx);
+ number_clone(lr->y_coord,mp_miny);
+
+ mp_originator (ur) = mp_program_code;
+ number_clone(ur->x_coord,mp_maxx);
+ number_clone(ur->y_coord,mp_maxy);
+
+ mp_originator (ul) = mp_program_code;
+ number_clone(ul->x_coord,mp_minx);
+ number_clone(ul->y_coord,mp_maxy);
+
+ mp_next_knot (ll) = lr;
+ mp_next_knot (lr) = ur;
+ mp_next_knot (ur) = ul;
+
+ mp_close_path_cycle (mp, ul, ll);
+ mp_make_path(mp,ll);
+ mp->cur_exp.type = mp_path_type;
+ set_cur_exp_knot(ll);
+ mp_free_path(mp,qq);
+
+ }
+}
+
+
+
+
+@ This is pretty straightfoward. The one silly thing is that
+the output of |mp_ps_do_font_charstring| has to be un-exported.
+
+@<Declare binary action...@>=
+static void mp_set_up_glyph_infont (MP mp, mp_node p) {
+ mp_edge_object *h = NULL;
+ mp_ps_font *f = NULL;
+ char *n = mp_str (mp, cur_exp_str ());
+ f = mp_ps_font_parse (mp, (int) mp_find_font (mp, n));
+ if (f != NULL) {
+ if (mp_type (p) == mp_known) {
+ int v = round_unscaled (value_number (p));
+ if (v < 0 || v > 255) {
+ char msg[256];
+ mp_snprintf (msg, 256, "glyph index too high (%d)", v);
+ mp_error (mp, msg, NULL, true);
+ } else {
+ h = mp_ps_font_charstring (mp, f, v);
+ }
+ } else {
+ n = mp_str (mp, value_str (p));
+ h = mp_ps_do_font_charstring (mp, f, n);
+ }
+ mp_ps_font_free (mp, f);
+ }
+ if (h != NULL) {
+ set_cur_exp_node ((mp_node)mp_gr_import (mp, h));
+ } else {
+ set_cur_exp_node ((mp_node)mp_get_edge_header_node (mp));
+ mp_init_edges (mp, (mp_edge_header_node)cur_exp_node ());
+ }
+ mp->cur_exp.type = mp_picture_type;
+}
+
+
+@ @<Declare binary action...@>=
+static void mp_find_point (MP mp, mp_number v_orig, quarterword c) {
+ mp_knot p; /* the path */
+ mp_number n; /* its length */
+ mp_number v;
+ new_number (v);
+ new_number (n);
+ number_clone (v, v_orig);
+ p = cur_exp_knot ();
+ if (mp_left_type (p) == mp_endpoint) {
+ set_number_to_unity (n);
+ number_negate (n);
+ } else {
+ set_number_to_zero (n);
+ }
+ do {
+ p = mp_next_knot (p);
+ number_add (n, unity_t);
+ } while (p != cur_exp_knot ());
+ if (number_zero (n)) {
+ set_number_to_zero(v);
+ } else if (number_negative(v)) {
+ if (mp_left_type (p) == mp_endpoint) {
+ set_number_to_zero(v);
+ } else {
+ /* |v = n - 1 - ((-v - 1) % n)
+ == - ((-v - 1) % n) - 1 + n| */
+ number_negate (v);
+ number_add_scaled (v, -1);
+ number_modulo (v, n);
+ number_negate (v);
+ number_add_scaled (v, -1);
+ number_add (v, n);
+ }
+ } else if (number_greater(v, n)) {
+ if (mp_left_type (p) == mp_endpoint)
+ number_clone (v, n);
+ else
+ number_modulo (v, n);
+ }
+ p = cur_exp_knot ();
+ while (number_greaterequal(v, unity_t)) {
+ p = mp_next_knot (p);
+ number_substract (v, unity_t);
+ }
+ if (number_nonzero(v)) {
+ /* Insert a fractional node by splitting the cubic */
+ convert_scaled_to_fraction (v);
+ mp_split_cubic (mp, p, v);
+ p = mp_next_knot (p);
+ }
+ /* Set the current expression to the desired path coordinates */
+ switch (c) {
+ case mp_point_of:
+ mp_pair_value (mp, p->x_coord, p->y_coord);
+ break;
+ case mp_precontrol_of:
+ if (mp_left_type (p) == mp_endpoint)
+ mp_pair_value (mp, p->x_coord, p->y_coord);
+ else
+ mp_pair_value (mp, p->left_x, p->left_y);
+ break;
+ case mp_postcontrol_of:
+ if (mp_right_type (p) == mp_endpoint)
+ mp_pair_value (mp, p->x_coord, p->y_coord);
+ else
+ mp_pair_value (mp, p->right_x, p->right_y);
+ break;
+ } /* there are no other cases */
+ free_number (v);
+ free_number (n);
+}
+
+@ 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...@>=
+static void mp_do_infont (MP mp, mp_node p) {
+ mp_edge_header_node q;
+ mp_value new_expr;
+ memset(&new_expr,0,sizeof(mp_value));
+ new_number(new_expr.data.n);
+ q = mp_get_edge_header_node (mp);
+ mp_init_edges (mp, q);
+ add_str_ref (cur_exp_str());
+ mp_link (obj_tail (q)) =
+ mp_new_text_node (mp, mp_str (mp, cur_exp_str ()), value_str (p));
+ obj_tail (q) = mp_link (obj_tail (q));
+ mp_free_value_node (mp, p);
+ new_expr.data.node = (mp_node)q;
+ mp_flush_cur_exp (mp, new_expr);
+ mp->cur_exp.type = mp_picture_type;
+}
+
+
+@* Statements and commands.
+The chief executive of \MP\ is the |do_statement| routine, which
+contains the master switch that causes all the various pieces of \MP\
+to do their things, in the right order.
+
+In a sense, this is the grand climax of the program: It applies all the
+tools that we have worked so hard to construct. In another sense, this is
+the messiest part of the program: It necessarily refers to other pieces
+of code all over the place, so that a person can't fully understand what is
+going on without paging back and forth to be reminded of conventions that
+are defined elsewhere. We are now at the hub of the web.
+
+The structure of |do_statement| itself is quite simple. The first token
+of the statement is fetched using |get_x_next|. If it can be the first
+token of an expression, we look for an equation, an assignment, or a
+title. Otherwise we use a \&{case} construction to branch at high speed to
+the appropriate routine for various and sundry other types of commands,
+each of which has an ``action procedure'' that does the necessary work.
+
+The program uses the fact that
+$$\hbox{|min_primary_command=max_statement_command=type_name|}$$
+to interpret a statement that starts with, e.g., `\&{string}',
+as a type declaration rather than a boolean expression.
+
+@c
+static void worry_about_bad_statement (MP mp);
+static void flush_unparsable_junk_after_statement (MP mp);
+void mp_do_statement (MP mp) { /* governs \MP's activities */
+ mp->cur_exp.type = mp_vacuous;
+ mp_get_x_next (mp);
+ if (cur_cmd() > mp_max_primary_command) {
+ worry_about_bad_statement (mp);
+ } else if (cur_cmd() > mp_max_statement_command) {
+ /* Do an equation, assignment, title, or
+ `$\langle\,$expression$\,\rangle\,$\&{endgroup}'; */
+ /* The most important statements begin with expressions */
+ mp_value new_expr;
+ mp->var_flag = mp_assignment;
+ mp_scan_expression (mp);
+ if (cur_cmd() < mp_end_group) {
+ if (cur_cmd() == mp_equals)
+ mp_do_equation (mp);
+ else if (cur_cmd() == mp_assignment)
+ mp_do_assignment (mp);
+ else if (mp->cur_exp.type == mp_string_type) {
+ /* Do a title */
+ if (number_positive (internal_value (mp_tracing_titles))) {
+ mp_print_nl (mp, "");
+ mp_print_str (mp, cur_exp_str ());
+ update_terminal();
+ }
+ } else if (mp->cur_exp.type != mp_vacuous) {
+ const char *hlp[] = {
+ "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.",
+ NULL };
+ mp_disp_err(mp, NULL);
+ mp_back_error (mp, "Isolated expression", hlp, true);
+ mp_get_x_next (mp);
+ }
+ memset(&new_expr,0,sizeof(mp_value));
+ new_number(new_expr.data.n);
+ set_number_to_zero (new_expr.data.n);
+ mp_flush_cur_exp (mp, new_expr);
+ mp->cur_exp.type = mp_vacuous;
+ }
+ } else {
+ /* Do a statement that doesn't begin with an expression */
+ /* If |do_statement| ends with |cur_cmd=end_group|, we should have
+ |cur_type=mp_vacuous| unless the statement was simply an expression;
+ in the latter case, |cur_type| and |cur_exp| should represent that
+ expression. */
+ if (number_positive (internal_value (mp_tracing_commands)))
+ show_cur_cmd_mod;
+ switch (cur_cmd()) {
+ case mp_type_name:
+ mp_do_type_declaration (mp);
+ break;
+ case mp_macro_def:
+ if (cur_mod() > var_def)
+ mp_make_op_def (mp);
+ else if (cur_mod() > end_def)
+ mp_scan_def (mp);
+ break;
+ case mp_random_seed:
+ mp_do_random_seed (mp);
+ break;
+ case mp_mode_command:
+ mp_print_ln (mp);
+ mp->interaction = cur_mod();
+ initialize_print_selector();
+ if (mp->log_opened)
+ mp->selector = mp->selector + 2;
+ mp_get_x_next (mp);
+ break;
+ case mp_protection_command:
+ mp_do_protection (mp);
+ break;
+ case mp_delimiters:
+ mp_def_delims (mp);
+ break;
+ case mp_save_command:
+ do {
+ mp_get_symbol (mp);
+ mp_save_variable (mp, cur_sym());
+ mp_get_x_next (mp);
+ } while (cur_cmd() == mp_comma);
+ break;
+ case mp_interim_command:
+ mp_do_interim (mp);
+ break;
+ case mp_let_command:
+ mp_do_let (mp);
+ break;
+ case mp_new_internal:
+ mp_do_new_internal (mp);
+ break;
+ case mp_show_command:
+ mp_do_show_whatever (mp);
+ break;
+ case mp_add_to_command:
+ mp_do_add_to (mp);
+ break;
+ case mp_bounds_command:
+ mp_do_bounds (mp);
+ break;
+ case mp_ship_out_command:
+ mp_do_ship_out (mp);
+ break;
+ case mp_every_job_command:
+ mp_get_symbol (mp);
+ mp->start_sym = cur_sym();
+ mp_get_x_next (mp);
+ break;
+ case mp_message_command:
+ mp_do_message (mp);
+ break;
+ case mp_write_command:
+ mp_do_write (mp);
+ break;
+ case mp_tfm_command:
+ mp_do_tfm_command (mp);
+ break;
+ case mp_special_command:
+ if (cur_mod() == 0)
+ mp_do_special (mp);
+ else if (cur_mod() == 1)
+ mp_do_mapfile (mp);
+ else
+ mp_do_mapline (mp);
+ break;
+ default:
+ break; /* make the compiler happy */
+ }
+ mp->cur_exp.type = mp_vacuous;
+ }
+ if (cur_cmd() < mp_semicolon)
+ flush_unparsable_junk_after_statement(mp);
+ mp->error_count = 0;
+}
+
+
+@ @<Declarations@>=
+@<Declare action procedures for use by |do_statement|@>
+
+
+@ The only command codes |>max_primary_command| that can be present
+at the beginning of a statement are |semicolon| and higher; these
+occur when the statement is null.
+
+@c
+static void worry_about_bad_statement (MP mp) {
+ if (cur_cmd() < mp_semicolon) {
+ char msg[256];
+ mp_string sname;
+ int old_setting = mp->selector;
+ const char *hlp[] = {
+ "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.)",
+ NULL };
+ mp->selector = new_string;
+ mp_print_cmd_mod (mp, cur_cmd(), cur_mod());
+ sname = mp_make_string(mp);
+ mp->selector = old_setting;
+ mp_snprintf (msg, 256, "A statement can't begin with `%s'", mp_str(mp, sname));
+ delete_str_ref(sname);
+ mp_back_error (mp, msg, hlp, true);
+ mp_get_x_next (mp);
+ }
+}
+
+
+@ The help message printed here says that everything is flushed up to
+a semicolon, but actually the commands |end_group| and |stop| will
+also terminate a statement.
+
+@c
+static void flush_unparsable_junk_after_statement (MP mp)
+{
+ const char *hlp[] = {
+ "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.)",
+ NULL };
+ mp_back_error (mp, "Extra tokens will be flushed", hlp, true);
+ mp->scanner_status = flushing;
+ do {
+ get_t_next (mp);
+ if (cur_cmd() == mp_string_token) {
+ delete_str_ref (cur_mod_str());
+ }
+ } while (!mp_end_of_statement); /* |cur_cmd=semicolon|, |end_group|, or |stop| */
+ mp->scanner_status = normal;
+}
+
+
+
+@ 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).
+
+@<Declarations@>=
+@<Declare the procedure called |make_eq|@>;
+static void mp_do_equation (MP mp);
+
+@ @c
+static void trace_equation (MP mp, mp_node lhs) {
+ mp_begin_diagnostic (mp);
+ mp_print_nl (mp, "{(");
+ mp_print_exp (mp, lhs, 0);
+ mp_print (mp, ")=(");
+ mp_print_exp (mp, NULL, 0);
+ mp_print (mp, ")}");
+ mp_end_diagnostic (mp, false);
+}
+void mp_do_equation (MP mp) {
+ mp_node lhs; /* capsule for the left-hand side */
+ lhs = mp_stash_cur_exp (mp);
+ mp_get_x_next (mp);
+ mp->var_flag = mp_assignment;
+ mp_scan_expression (mp);
+ if (cur_cmd() == mp_equals)
+ mp_do_equation (mp);
+ else if (cur_cmd() == mp_assignment)
+ mp_do_assignment (mp);
+ if (number_greater (internal_value (mp_tracing_commands), two_t)) {
+ trace_equation(mp, lhs);
+ }
+ if (mp->cur_exp.type == mp_unknown_path) {
+ if (mp_type (lhs) == mp_pair_type) {
+ mp_node p; /* temporary register */
+ p = mp_stash_cur_exp (mp);
+ mp_unstash_cur_exp (mp, lhs);
+ lhs = p;
+ } /* in this case |make_eq| will change the pair to a path */
+ }
+ mp_make_eq (mp, lhs); /* equate |lhs| to |(cur_type,cur_exp)| */
+}
+
+
+@ And |do_assignment| is similar to |do_equation|:
+
+@<Declarations@>=
+static void mp_do_assignment (MP mp);
+
+@ @c
+static void bad_lhs (MP mp) {
+ const char *hlp[] = {
+ "I didn't find a variable name at the left of the `:=',",
+ "so I'm going to pretend that you said `=' instead.",
+ NULL };
+ mp_disp_err(mp, NULL);
+ mp_error (mp, "Improper `:=' will be changed to `='", hlp, true);
+ mp_do_equation (mp);
+}
+static void bad_internal_assignment (MP mp, mp_node lhs) {
+ char msg[256];
+ const char *hlp[] = {
+ "I can\'t set this internal quantity to anything but a known",
+ "numeric value, so I'll have to ignore this assignment.",
+ NULL };
+ mp_disp_err(mp, NULL);
+ if (internal_type (mp_sym_info (lhs)) == mp_known) {
+ mp_snprintf (msg, 256, "Internal quantity `%s' must receive a known numeric value",
+ internal_name (mp_sym_info (lhs)));
+ } else {
+ mp_snprintf (msg, 256, "Internal quantity `%s' must receive a known string",
+ internal_name (mp_sym_info (lhs)));
+ hlp[1] = "string, so I'll have to ignore this assignment.";
+ }
+ mp_back_error (mp, msg, hlp, true);
+ mp_get_x_next (mp);
+}
+static void forbidden_internal_assignment (MP mp, mp_node lhs) {
+ char msg[256];
+ const char *hlp[] = {
+ "I can\'t set this internal quantity to anything just yet",
+ "(it is read-only), so I'll have to ignore this assignment.",
+ NULL };
+ mp_snprintf (msg, 256, "Internal quantity `%s' is read-only",
+ internal_name (mp_sym_info (lhs)));
+ mp_back_error (mp, msg, hlp, true);
+ mp_get_x_next (mp);
+}
+static void bad_internal_assignment_precision (MP mp, mp_node lhs, mp_number min, mp_number max) {
+ char msg[256];
+ char s[256];
+ const char *hlp[] = {
+ "Precision values are limited by the current numbersystem.",
+ NULL,
+ NULL } ;
+ mp_snprintf (msg, 256, "Bad '%s' has been ignored", internal_name (mp_sym_info (lhs)));
+ mp_snprintf (s, 256, "Currently I am using '%s'; the allowed precision range is [%s,%s].",
+ mp_str (mp, internal_string (mp_number_system)), number_tostring(min), number_tostring(max));
+ hlp[1] = s;
+ mp_back_error (mp, msg, hlp, true);
+ mp_get_x_next (mp);
+}
+static void bad_expression_assignment (MP mp, mp_node lhs) {
+ const char *hlp[] = {
+ "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.",
+ NULL };
+ char *msg = mp_obliterated (mp, lhs);
+ mp_back_error (mp, msg, hlp, true);
+ free(msg);
+ mp_get_x_next (mp);
+}
+static void trace_assignment (MP mp, mp_node lhs) {
+ mp_begin_diagnostic (mp);
+ mp_print_nl (mp, "{");
+ if (mp_name_type (lhs) == mp_internal_sym)
+ mp_print (mp, internal_name (mp_sym_info (lhs)));
+ else
+ mp_show_token_list (mp, lhs, NULL, 1000, 0);
+ mp_print (mp, ":=");
+ mp_print_exp (mp, NULL, 0);
+ mp_print_char (mp, xord ('}'));
+ mp_end_diagnostic (mp, false);
+}
+void mp_do_assignment (MP mp) {
+ if (mp->cur_exp.type != mp_token_list) {
+ bad_lhs(mp);
+ } else {
+ mp_node lhs; /* token list for the left-hand side */
+ lhs = cur_exp_node ();
+ mp->cur_exp.type = mp_vacuous;
+ mp_get_x_next (mp);
+ mp->var_flag = mp_assignment;
+ mp_scan_expression (mp);
+ if (cur_cmd() == mp_equals)
+ mp_do_equation (mp);
+ else if (cur_cmd() == mp_assignment)
+ mp_do_assignment (mp);
+ if (number_greater (internal_value (mp_tracing_commands), two_t)) {
+ trace_assignment (mp, lhs);
+ }
+ if (mp_name_type (lhs) == mp_internal_sym) {
+ /* Assign the current expression to an internal variable */
+ if ((mp->cur_exp.type == mp_known || mp->cur_exp.type == mp_string_type)
+ && (internal_type (mp_sym_info (lhs)) == mp->cur_exp.type)) {
+ if(mp_sym_info (lhs) == mp_number_system) {
+ forbidden_internal_assignment (mp, lhs);
+ } else if (mp_sym_info (lhs) == mp_number_precision) {
+ if (!(mp->cur_exp.type == mp_known &&
+ (!number_less(cur_exp_value_number(), precision_min)) &&
+ (!number_greater(cur_exp_value_number(), precision_max))
+ )) {
+ bad_internal_assignment_precision(mp, lhs, precision_min, precision_max);
+ } else {
+ set_internal_from_cur_exp(mp_sym_info (lhs));
+ set_precision();
+ }
+ } else {
+ set_internal_from_cur_exp(mp_sym_info (lhs));
+ }
+ } else {
+ bad_internal_assignment (mp, lhs);
+ }
+ } else {
+ /* Assign the current expression to the variable |lhs| */
+ mp_node p; /* where the left-hand value is stored */
+ mp_node q; /* temporary capsule for the right-hand value */
+ p = mp_find_variable (mp, lhs);
+ if (p != NULL) {
+ q = mp_stash_cur_exp (mp);
+ mp->cur_exp.type = mp_und_type (mp, p);
+ mp_recycle_value (mp, p);
+ mp_type (p) = mp->cur_exp.type;
+ set_value_number (p, zero_t);
+ mp_make_exp_copy (mp, p);
+ p = mp_stash_cur_exp (mp);
+ mp_unstash_cur_exp (mp, q);
+ mp_make_eq (mp, p);
+ } else {
+ bad_expression_assignment(mp, lhs);
+ }
+ }
+ mp_flush_node_list (mp, lhs);
+ }
+}
+
+
+@ 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|@>=
+static void mp_make_eq (MP mp, mp_node lhs);
+
+@
+@c
+static void announce_bad_equation (MP mp, mp_node lhs) {
+ char msg[256];
+ const char *hlp[] = {
+ "I'm sorry, but I don't know how to make such things equal.",
+ "(See the two expressions just above the error message.)",
+ NULL };
+ mp_snprintf(msg, 256, "Equation cannot be performed (%s=%s)",
+ (mp_type (lhs) <= mp_pair_type ? mp_type_string (mp_type (lhs)) : "numeric"),
+ (mp->cur_exp.type <= mp_pair_type ? mp_type_string (mp->cur_exp.type) : "numeric"));
+ mp_disp_err (mp, lhs);
+ mp_disp_err(mp, NULL);
+ mp_back_error (mp, msg, hlp, true);
+ mp_get_x_next (mp);
+}
+static void exclaim_inconsistent_equation (MP mp) {
+ const char *hlp[] = {
+ "The equation I just read contradicts what was said before.",
+ "But don't worry; continue and I'll just ignore it.",
+ NULL };
+ mp_back_error (mp,"Inconsistent equation", hlp, true);
+ mp_get_x_next (mp);
+}
+static void exclaim_redundant_or_inconsistent_equation (MP mp) {
+ const char *hlp[] = {
+ "An equation between already-known quantities can't help.",
+ "But don't worry; continue and I'll just ignore it.",
+ NULL };
+ mp_back_error (mp, "Redundant or inconsistent equation", hlp, true);
+ mp_get_x_next (mp);
+}
+static void report_redundant_or_inconsistent_equation (MP mp, mp_node lhs, mp_number v) {
+ if (mp->cur_exp.type <= mp_string_type) {
+ if (mp->cur_exp.type == mp_string_type) {
+ if (mp_str_vs_str (mp, value_str (lhs), cur_exp_str ()) != 0) {
+ exclaim_inconsistent_equation(mp);
+ } else {
+ exclaim_redundant_equation(mp);
+ }
+ } else if (!number_equal (v, cur_exp_value_number ())) {
+ exclaim_inconsistent_equation(mp);
+ } else {
+ exclaim_redundant_equation(mp);
+ }
+ } else {
+ exclaim_redundant_or_inconsistent_equation (mp);
+ }
+}
+
+void mp_make_eq (MP mp, mp_node lhs) {
+ mp_value new_expr;
+ mp_variable_type t; /* type of the left-hand side */
+ mp_number v; /* value of the left-hand side */
+ memset(&new_expr,0,sizeof(mp_value));
+ new_number (v);
+RESTART:
+ t = mp_type (lhs);
+ if (t <= mp_pair_type)
+ number_clone (v, value_number (lhs));
+ /* For each type |t|, make an equation or complain if |cur_type|
+ is incompatible with~|t| */
+ switch (t) {
+ case mp_boolean_type:
+ case mp_string_type:
+ case mp_pen_type:
+ case mp_path_type:
+ case mp_picture_type:
+ if (mp->cur_exp.type == t + unknown_tag) {
+ new_number(new_expr.data.n);
+ if (t==mp_boolean_type) {
+ number_clone (new_expr.data.n, v);
+ } else if (t==mp_string_type) {
+ new_expr.data.str = value_str(lhs);
+ } else if (t==mp_picture_type) {
+ new_expr.data.node = value_node(lhs);
+ } else { /* pen or path */
+ new_expr.data.p = value_knot(lhs);
+ }
+ mp_nonlinear_eq (mp, new_expr, cur_exp_node (), false);
+ mp_unstash_cur_exp (mp, cur_exp_node ());
+ } else if (mp->cur_exp.type == t) {
+ report_redundant_or_inconsistent_equation(mp, lhs, v);
+ } else {
+ announce_bad_equation(mp, lhs);
+ }
+ break;
+ case unknown_types:
+ if (mp->cur_exp.type == t - unknown_tag) {
+ mp_nonlinear_eq (mp, mp->cur_exp, lhs, true);
+ } else if (mp->cur_exp.type == t) {
+ mp_ring_merge (mp, lhs, cur_exp_node ());
+ } else if (mp->cur_exp.type == mp_pair_type) {
+ if (t == mp_unknown_path) {
+ mp_pair_to_path (mp);
+ goto RESTART;
+ }
+ } else {
+ announce_bad_equation(mp, lhs);
+ }
+ break;
+ case mp_transform_type:
+ case mp_color_type:
+ case mp_cmykcolor_type:
+ case mp_pair_type:
+ if (mp->cur_exp.type == t) {
+ /* Do multiple equations */
+ mp_node q = value_node (cur_exp_node ());
+ mp_node p = value_node (lhs);
+ switch (t) {
+ case mp_transform_type:
+ mp_try_eq (mp, yy_part (p), yy_part (q));
+ mp_try_eq (mp, yx_part (p), yx_part (q));
+ mp_try_eq (mp, xy_part (p), xy_part (q));
+ mp_try_eq (mp, xx_part (p), xx_part (q));
+ mp_try_eq (mp, ty_part (p), ty_part (q));
+ mp_try_eq (mp, tx_part (p), tx_part (q));
+ break;
+ case mp_color_type:
+ mp_try_eq (mp, blue_part (p), blue_part (q));
+ mp_try_eq (mp, green_part (p), green_part (q));
+ mp_try_eq (mp, red_part (p), red_part (q));
+ break;
+ case mp_cmykcolor_type:
+ mp_try_eq (mp, black_part (p), black_part (q));
+ mp_try_eq (mp, yellow_part (p), yellow_part (q));
+ mp_try_eq (mp, magenta_part (p), magenta_part (q));
+ mp_try_eq (mp, cyan_part (p), cyan_part (q));
+ break;
+ case mp_pair_type:
+ mp_try_eq (mp, y_part (p), y_part (q));
+ mp_try_eq (mp, x_part (p), x_part (q));
+ break;
+ default: /* there are no other valid cases, but please the compiler */
+ break;
+ }
+ } else {
+ announce_bad_equation(mp, lhs);
+ }
+ break;
+ case mp_known:
+ case mp_dependent:
+ case mp_proto_dependent:
+ case mp_independent:
+ if (mp->cur_exp.type >= mp_known) {
+ mp_try_eq (mp, lhs, NULL);
+ } else {
+ announce_bad_equation(mp, lhs);
+ }
+ break;
+ case mp_vacuous:
+ announce_bad_equation(mp, lhs);
+ break;
+ default: /* there are no other valid cases, but please the compiler */
+ announce_bad_equation(mp, lhs);
+ break;
+ }
+ check_arith();
+ mp_recycle_value (mp, lhs);
+ free_number (v);
+ mp_free_value_node (mp, lhs);
+}
+
+@ 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.
+
+@<Declarations@>=
+static void mp_try_eq (MP mp, mp_node l, mp_node r);
+
+@
+@d equation_threshold_k ((math_data *)mp->math)->equation_threshold_t
+
+@c
+static void deal_with_redundant_or_inconsistent_equation(MP mp, mp_value_node p, mp_node r) {
+ mp_number absp;
+ new_number (absp);
+ number_clone (absp, value_number (p));
+ number_abs (absp);
+ if (number_greater (absp, equation_threshold_k)) { /* off by .001 or more */
+ char msg[256];
+ const char *hlp[] = {
+ "The equation I just read contradicts what was said before.",
+ "But don't worry; continue and I'll just ignore it.",
+ NULL };
+ mp_snprintf (msg, 256, "Inconsistent equation (off by %s)", number_tostring (value_number (p)));
+ mp_back_error (mp, msg, hlp, true);
+ mp_get_x_next (mp);
+ } else if (r == NULL) {
+ exclaim_redundant_equation(mp);
+ }
+ free_number (absp);
+ mp_free_dep_node (mp, p);
+}
+
+void mp_try_eq (MP mp, mp_node l, mp_node r) {
+ mp_value_node p; /* dependency list for right operand minus left operand */
+ mp_variable_type t; /* the type of list |p| */
+ mp_value_node q; /* the constant term of |p| is here */
+ mp_value_node pp; /* dependency list for right operand */
+ mp_variable_type tt; /* the type of list |pp| */
+ boolean copied; /* have we copied a list that ought to be recycled? */
+ /* Remove the left operand from its container, negate it, and
+ put it into dependency list~|p| with constant term~|q| */
+ t = mp_type (l);
+ if (t == mp_known) {
+ mp_number arg1;
+ new_number (arg1);
+ number_clone (arg1, value_number(l));
+ number_negate (arg1);
+ t = mp_dependent;
+ p = mp_const_dependency (mp, arg1);
+ q = p;
+ free_number (arg1);
+ } else if (t == mp_independent) {
+ t = mp_dependent;
+ p = mp_single_dependency (mp, l);
+ number_negate(dep_value (p));
+ q = mp->dep_final;
+ } else {
+ mp_value_node ll = (mp_value_node) l;
+ p = (mp_value_node) dep_list (ll);
+ q = p;
+ while (1) {
+ number_negate(dep_value (q));
+ if (dep_info (q) == NULL)
+ break;
+ q = (mp_value_node) mp_link (q);
+ }
+ mp_link (prev_dep (ll)) = mp_link (q);
+ set_prev_dep ((mp_value_node) mp_link (q), prev_dep (ll));
+ mp_type (ll) = mp_known;
+ }
+
+ /* Add the right operand to list |p| */
+ if (r == NULL) {
+ if (mp->cur_exp.type == mp_known) {
+ number_add (value_number (q), cur_exp_value_number ());
+ goto DONE1;
+ } else {
+ tt = mp->cur_exp.type;
+ if (tt == mp_independent)
+ pp = mp_single_dependency (mp, cur_exp_node ());
+ else
+ pp = (mp_value_node) dep_list ((mp_value_node) cur_exp_node ());
+ }
+ } else {
+ if (mp_type (r) == mp_known) {
+ number_add (dep_value (q), value_number (r));
+ goto DONE1;
+ } else {
+ tt = mp_type (r);
+ if (tt == mp_independent)
+ pp = mp_single_dependency (mp, r);
+ else
+ pp = (mp_value_node) dep_list ((mp_value_node) r);
+ }
+ }
+ if (tt != mp_independent) {
+ copied = false;
+ } else {
+ copied = true;
+ tt = mp_dependent;
+ }
+ /* Add dependency list |pp| of type |tt| to dependency list~|p| of type~|t| */
+ mp->watch_coefs = false;
+ if (t == tt) {
+ p = mp_p_plus_q (mp, p, pp, (quarterword) t);
+ } else if (t == mp_proto_dependent) {
+ p = mp_p_plus_fq (mp, p, unity_t, pp, mp_proto_dependent, mp_dependent);
+ } else {
+ mp_number x;
+ new_number (x);
+ q = p;
+ while (dep_info (q) != NULL) {
+ number_clone (x, dep_value (q));
+ fraction_to_round_scaled (x);
+ set_dep_value (q, x);
+ q = (mp_value_node) mp_link (q);
+ }
+ free_number (x);
+ t = mp_proto_dependent;
+ p = mp_p_plus_q (mp, p, pp, (quarterword) t);
+ }
+ mp->watch_coefs = true;
+
+ if (copied)
+ mp_flush_node_list (mp, (mp_node) pp);
+ DONE1:
+
+ if (dep_info (p) == NULL) {
+ deal_with_redundant_or_inconsistent_equation(mp, p, r);
+ } else {
+ mp_linear_eq (mp, p, (quarterword) t);
+ if (r == NULL && mp->cur_exp.type != mp_known) {
+ if (mp_type (cur_exp_node ()) == mp_known) {
+ mp_node pp = cur_exp_node ();
+ set_cur_exp_value_number (value_number (pp));
+ mp->cur_exp.type = mp_known;
+ mp_free_value_node (mp, pp);
+ }
+ }
+ }
+}
+
+@ 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|.
+
+@<Declarations@>=
+static mp_node mp_scan_declared_variable (MP mp);
+
+@ @c
+mp_node mp_scan_declared_variable (MP mp) {
+ mp_sym x; /* hash address of the variable's root */
+ mp_node h, t; /* head and tail of the token list to be returned */
+ mp_get_symbol (mp);
+ x = cur_sym();
+ if (cur_cmd() != mp_tag_token)
+ mp_clear_symbol (mp, x, false);
+ h = mp_get_symbolic_node (mp);
+ set_mp_sym_sym (h, x);
+ t = h;
+ while (1) {
+ mp_get_x_next (mp);
+ if (cur_sym() == NULL)
+ break;
+ if (cur_cmd() != mp_tag_token) {
+ if (cur_cmd() != mp_internal_quantity) {
+ if (cur_cmd() == mp_left_bracket) {
+ /* Descend past a collective subscript */
+ /* If the subscript isn't collective, we don't accept it as part of the
+ declared variable. */
+ mp_sym ll = cur_sym(); /* hash address of left bracket */
+ mp_get_x_next (mp);
+ if (cur_cmd() == mp_right_bracket) {
+ set_cur_sym(collective_subscript);
+ } else {
+ mp_back_input (mp);
+ set_cur_sym(ll);
+ set_cur_cmd((mp_variable_type)mp_left_bracket);
+ break;
+ }
+ } else {
+ break;
+ }
+ }
+ }
+ mp_link (t) = mp_get_symbolic_node (mp);
+ t = mp_link (t);
+ set_mp_sym_sym (t, cur_sym());
+ mp_name_type (t) = cur_sym_mod();
+ }
+ if ((eq_type (x) % mp_outer_tag) != mp_tag_token)
+ mp_clear_symbol (mp, x, false);
+ if (equiv_node (x) == NULL)
+ mp_new_root (mp, x);
+ return h;
+}
+
+
+@ Type declarations are introduced by the following primitive operations.
+
+@<Put each...@>=
+mp_primitive (mp, "numeric", mp_type_name, mp_numeric_type);
+@:numeric_}{\&{numeric} primitive@>;
+mp_primitive (mp, "string", mp_type_name, mp_string_type);
+@:string_}{\&{string} primitive@>;
+mp_primitive (mp, "boolean", mp_type_name, mp_boolean_type);
+@:boolean_}{\&{boolean} primitive@>;
+mp_primitive (mp, "path", mp_type_name, mp_path_type);
+@:path_}{\&{path} primitive@>;
+mp_primitive (mp, "pen", mp_type_name, mp_pen_type);
+@:pen_}{\&{pen} primitive@>;
+mp_primitive (mp, "picture", mp_type_name, mp_picture_type);
+@:picture_}{\&{picture} primitive@>;
+mp_primitive (mp, "transform", mp_type_name, mp_transform_type);
+@:transform_}{\&{transform} primitive@>;
+mp_primitive (mp, "color", mp_type_name, mp_color_type);
+@:color_}{\&{color} primitive@>;
+mp_primitive (mp, "rgbcolor", mp_type_name, mp_color_type);
+@:color_}{\&{rgbcolor} primitive@>;
+mp_primitive (mp, "cmykcolor", mp_type_name, mp_cmykcolor_type);
+@:color_}{\&{cmykcolor} primitive@>;
+mp_primitive (mp, "pair", mp_type_name, mp_pair_type);
+@:pair_}{\&{pair} primitive@>
+
+
+@ @<Cases of |print_cmd...@>=
+case mp_type_name:
+mp_print_type (mp, (quarterword) m);
+break;
+
+@ Now we are ready to handle type declarations, assuming that a
+|type_name| has just been scanned.
+
+@<Declare action procedures for use by |do_statement|@>=
+static void mp_do_type_declaration (MP mp);
+
+@ @c
+static void flush_spurious_symbols_after_declared_variable(MP mp);
+void mp_do_type_declaration (MP mp) {
+ integer t; /* the type being declared */
+ mp_node p; /* token list for a declared variable */
+ mp_node q; /* value node for the variable */
+ if (cur_mod() >= mp_transform_type)
+ t = (quarterword) cur_mod();
+ else
+ t = (quarterword) (cur_mod() + unknown_tag);
+ do {
+ p = mp_scan_declared_variable (mp);
+ mp_flush_variable (mp, equiv_node (mp_sym_sym (p)), mp_link (p), false);
+ q = mp_find_variable (mp, p);
+ if (q != NULL) {
+ mp_type (q) = t;
+ set_value_number (q, zero_t); /* todo: this was |null| */
+ } else {
+ const char *hlp[] = {
+ "You can't use, e.g., `numeric foo[]' after `vardef foo'.",
+ "Proceed, and I'll ignore the illegal redeclaration.",
+ NULL };
+ mp_back_error (mp, "Declared variable conflicts with previous vardef", hlp, true);
+ mp_get_x_next (mp);
+ }
+ mp_flush_node_list (mp, p);
+ if (cur_cmd() < mp_comma) {
+ flush_spurious_symbols_after_declared_variable(mp);
+ }
+ } while (!mp_end_of_statement);
+}
+
+
+@
+@c
+static void flush_spurious_symbols_after_declared_variable (MP mp)
+{
+ const char *hlp[] = {
+ "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.",
+ NULL };
+ if (cur_cmd() == mp_numeric_token)
+ hlp[2] = "Explicit subscripts like `x15a' aren't permitted.";
+ mp_back_error (mp, "Illegal suffix of declared variable will be flushed", hlp, true);
+ mp_get_x_next (mp);
+ mp->scanner_status = flushing;
+ do {
+ get_t_next (mp);
+ @<Decrease the string reference count...@>;
+ } while (cur_cmd() < mp_comma); /* break on either |end_of_statement| or |comma| */
+ mp->scanner_status = normal;
+}
+
+
+@ \MP's |main_control| procedure just calls |do_statement| repeatedly
+until coming to the end of the user's program.
+Each execution of |do_statement| concludes with
+|cur_cmd=semicolon|, |end_group|, or |stop|.
+
+@c
+static void mp_main_control (MP mp) {
+ do {
+ mp_do_statement (mp);
+ if (cur_cmd() == mp_end_group) {
+ mp_value new_expr;
+ const char *hlp[] = {
+ "I'm not currently working on a `begingroup',",
+ "so I had better not try to end anything.",
+ NULL };
+ memset(&new_expr,0,sizeof(mp_value));
+ new_number(new_expr.data.n);
+ mp_error (mp, "Extra `endgroup'", hlp, true);
+ mp_flush_cur_exp (mp, new_expr);
+ }
+ } while (cur_cmd() != mp_stop);
+}
+int mp_run (MP mp) {
+ if (mp->history < mp_fatal_error_stop) {
+ xfree (mp->jump_buf);
+ mp->jump_buf = malloc (sizeof (jmp_buf));
+ if (mp->jump_buf == NULL || setjmp (*(mp->jump_buf)) != 0)
+ return mp->history;
+ mp_main_control (mp); /* come to life */
+ mp_final_cleanup (mp); /* prepare for death */
+ mp_close_files_and_terminate (mp);
+ }
+ return mp->history;
+}
+
+
+@ This function allows setting of internals from an external
+source (like the command line or a controlling application).
+
+It accepts two |char *|'s, even for numeric assignments when
+it calls |atoi| to get an integer from the start of the string.
+
+@c
+void mp_set_internal (MP mp, char *n, char *v, int isstring) {
+ size_t l = strlen (n);
+ char err[256];
+ const char *errid = NULL;
+ if (l > 0) {
+ mp_sym p = mp_id_lookup (mp, n, l, false);
+ if (p == NULL) {
+ errid = "variable does not exist";
+ } else {
+ if (eq_type (p) == mp_internal_quantity) {
+ if ((internal_type (equiv (p)) == mp_string_type) && (isstring)) {
+ set_internal_string (equiv (p), mp_rts (mp, v));
+ } else if ((internal_type (equiv (p)) == mp_known) && (!isstring)) {
+ int test = atoi (v);
+ if (test > 16383 && mp->math_mode==mp_math_scaled_mode) {
+ errid = "value is too large";
+ } else if (test < -16383 && mp->math_mode==mp_math_scaled_mode) {
+ errid = "value is too small";
+ } else {
+ set_internal_from_number (equiv (p), unity_t);
+ number_multiply_int (internal_value(equiv (p)), test);
+ }
+ } else {
+ errid = "value has the wrong type";
+ }
+ } else {
+ errid = "variable is not an internal";
+ }
+ }
+ }
+ if (errid != NULL) {
+ if (isstring) {
+ mp_snprintf (err, 256, "%s=\"%s\": %s, assignment ignored.", n, v, errid);
+ } else {
+ mp_snprintf (err, 256, "%s=%d: %s, assignment ignored.", n, atoi (v),
+ errid);
+ }
+ mp_warn (mp, err);
+ }
+}
+
+
+@ @<Exported function headers@>=
+void mp_set_internal (MP mp, char *n, char *v, int isstring);
+
+@ For |mp_execute|, we need to define a structure to store the
+redirected input and output. This structure holds the five relevant
+streams: the three informational output streams, the PostScript
+generation stream, and the input stream. These streams have many
+things in common, so it makes sense to give them their own structure
+definition.
+
+\item{fptr} is a virtual file pointer
+\item{data} is the data this stream holds
+\item{cur} is a cursor pointing into |data|
+\item{size} is the allocated length of the data stream
+\item{used} is the actual length of the data stream
+
+There are small differences between input and output: |term_in| never
+uses |used|, whereas the other four never use |cur|.
+
+The file |luatexdir/tex/texfileio.h| defines |term_in| as |stdin| and
+|term_out| as |stdout|. Moreover |stdio.h| for MinGW defines |stdin| as
+|(&_iob[0])| and |stdout| as |(&_iob[1])|. We must avoid all that.
+
+@<Exported types@>=
+#undef term_in
+#undef term_out
+
+typedef struct {
+ void *fptr;
+ char *data;
+ char *cur;
+ size_t size;
+ size_t used;
+} mp_stream;
+typedef struct {
+ mp_stream term_out;
+ mp_stream error_out;
+ mp_stream log_out;
+ mp_stream ship_out;
+ mp_stream term_in;
+ struct mp_edge_object *edges;
+} mp_run_data;
+
+@ We need a function to clear an output stream, this is called at the
+beginning of |mp_execute|. We also need one for destroying an output
+stream, this is called just before a stream is (re)opened.
+
+@c
+static void mp_reset_stream (mp_stream * str) {
+ xfree (str->data);
+ str->cur = NULL;
+ str->size = 0;
+ str->used = 0;
+}
+static void mp_free_stream (mp_stream * str) {
+ xfree (str->fptr);
+ mp_reset_stream (str);
+}
+
+
+@ @<Declarations@>=
+static void mp_reset_stream (mp_stream * str);
+static void mp_free_stream (mp_stream * str);
+
+@ The global instance contains a pointer instead of the actual structure
+even though it is essentially static, because that makes it is easier to move
+the object around.
+
+@<Global ...@>=
+mp_run_data run_data;
+
+@ Another type is needed: the indirection will overload some of the
+file pointer objects in the instance (but not all). For clarity, an
+indirect object is used that wraps a |FILE *|.
+
+@<Types ... @>=
+typedef struct File {
+ FILE *f;
+} File;
+
+@ Here are all of the functions that need to be overloaded for |mp_execute|.
+
+@<Declarations@>=
+static void *mplib_open_file (MP mp, const char *fname, const char *fmode,
+ int ftype);
+static int mplib_get_char (void *f, mp_run_data * mplib_data);
+static void mplib_unget_char (void *f, mp_run_data * mplib_data, int c);
+static char *mplib_read_ascii_file (MP mp, void *ff, size_t * size);
+static void mplib_write_ascii_file (MP mp, void *ff, const char *s);
+static void mplib_read_binary_file (MP mp, void *ff, void **data,
+ size_t * size);
+static void mplib_write_binary_file (MP mp, void *ff, void *s, size_t size);
+static void mplib_close_file (MP mp, void *ff);
+static int mplib_eof_file (MP mp, void *ff);
+static void mplib_flush_file (MP mp, void *ff);
+static void mplib_shipout_backend (MP mp, void *h);
+
+@ The |xmalloc(1,1)| calls make sure the stored indirection values are unique.
+
+@d reset_stream(a) do {
+ mp_reset_stream(&(a));
+ if (!ff->f) {
+ ff->f = xmalloc(1,1);
+ (a).fptr = ff->f;
+ } } while (0)
+
+@c
+static void *mplib_open_file (MP mp, const char *fname, const char *fmode,
+ int ftype) {
+ File *ff = xmalloc (1, sizeof (File));
+ mp_run_data *run = mp_rundata (mp);
+ ff->f = NULL;
+ if (ftype == mp_filetype_terminal) {
+ if (fmode[0] == 'r') {
+ if (!ff->f) {
+ ff->f = xmalloc (1, 1);
+ run->term_in.fptr = ff->f;
+ }
+ } else {
+ reset_stream (run->term_out);
+ }
+ } else if (ftype == mp_filetype_error) {
+ reset_stream (run->error_out);
+ } else if (ftype == mp_filetype_log) {
+ reset_stream (run->log_out);
+ } else if (ftype == mp_filetype_postscript) {
+ mp_free_stream (&(run->ship_out));
+ ff->f = xmalloc (1, 1);
+ run->ship_out.fptr = ff->f;
+ } else if (ftype == mp_filetype_bitmap) {
+ mp_free_stream (&(run->ship_out));
+ ff->f = xmalloc (1, 1);
+ run->ship_out.fptr = ff->f;
+ } else {
+ char realmode[3];
+ char *f = (mp->find_file) (mp, fname, fmode, ftype);
+ if (f == NULL)
+ return NULL;
+ realmode[0] = *fmode;
+ realmode[1] = 'b';
+ realmode[2] = 0;
+ ff->f = fopen (f, realmode);
+ free (f);
+ if ((fmode[0] == 'r') && (ff->f == NULL)) {
+ free (ff);
+ return NULL;
+ }
+ }
+ return ff;
+}
+static int mplib_get_char (void *f, mp_run_data * run) {
+ int c;
+ if (f == run->term_in.fptr && run->term_in.data != NULL) {
+ if (run->term_in.size == 0) {
+ if (run->term_in.cur != NULL) {
+ run->term_in.cur = NULL;
+ } else {
+ xfree (run->term_in.data);
+ }
+ c = EOF;
+ } else {
+ run->term_in.size--;
+ c = *(run->term_in.cur)++;
+ }
+ } else {
+ c = fgetc (f);
+ }
+ return c;
+}
+static void mplib_unget_char (void *f, mp_run_data * run, int c) {
+ if (f == run->term_in.fptr && run->term_in.cur != NULL) {
+ run->term_in.size++;
+ run->term_in.cur--;
+ } else {
+ ungetc (c, f);
+ }
+}
+static char *mplib_read_ascii_file (MP mp, void *ff, size_t * size) {
+ char *s = NULL;
+ if (ff != NULL) {
+ int c;
+ size_t len = 0, lim = 128;
+ mp_run_data *run = mp_rundata (mp);
+ FILE *f = ((File *) ff)->f;
+ if (f == NULL)
+ return NULL;
+ *size = 0;
+ c = mplib_get_char (f, run);
+ if (c == EOF)
+ return NULL;
+ s = malloc (lim);
+ if (s == NULL)
+ return NULL;
+ while (c != EOF && c != '\n' && c != '\r') {
+ if (len >= (lim - 1)) {
+ s = xrealloc (s, (lim + (lim >> 2)), 1);
+ if (s == NULL)
+ return NULL;
+ lim += (lim >> 2);
+ }
+ s[len++] = (char) c;
+ c = mplib_get_char (f, run);
+ }
+ if (c == '\r') {
+ c = mplib_get_char (f, run);
+ if (c != EOF && c != '\n')
+ mplib_unget_char (f, run, c);
+ }
+ s[len] = 0;
+ *size = len;
+ }
+ return s;
+}
+static void mp_append_string (MP mp, mp_stream * a, const char *b) {
+ size_t l = strlen (b) + 1; /* don't forget the trailing |'\0'| */
+ if ((a->used + l) >= a->size) {
+ a->size += 256 + (a->size) / 5 + l;
+ a->data = xrealloc (a->data, a->size, 1);
+ }
+ memcpy (a->data + a->used, b, l);
+ a->used += (l-1);
+}
+static void mp_append_data (MP mp, mp_stream * a, void *b, size_t l) {
+ if ((a->used + l) >= a->size) {
+ a->size += 256 + (a->size) / 5 + l;
+ a->data = xrealloc (a->data, a->size, 1);
+ }
+ memcpy (a->data + a->used, b, l);
+ a->used += l;
+}
+static void mplib_write_ascii_file (MP mp, void *ff, const char *s) {
+ if (ff != NULL) {
+ void *f = ((File *) ff)->f;
+ mp_run_data *run = mp_rundata (mp);
+ if (f != NULL) {
+ if (f == run->term_out.fptr) {
+ mp_append_string (mp, &(run->term_out), s);
+ } else if (f == run->error_out.fptr) {
+ mp_append_string (mp, &(run->error_out), s);
+ } else if (f == run->log_out.fptr) {
+ mp_append_string (mp, &(run->log_out), s);
+ } else if (f == run->ship_out.fptr) {
+ mp_append_string (mp, &(run->ship_out), s);
+ } else {
+ fprintf ((FILE *) f, "%s", s);
+ }
+ }
+ }
+}
+static void mplib_read_binary_file (MP mp, void *ff, void **data, size_t * size) {
+ (void) mp;
+ if (ff != NULL) {
+ size_t len = 0;
+ FILE *f = ((File *) ff)->f;
+ if (f != NULL)
+ len = fread (*data, 1, *size, f);
+ *size = len;
+ }
+}
+static void mplib_write_binary_file (MP mp, void *ff, void *s, size_t size) {
+ (void) mp;
+ if (ff != NULL) {
+ void *f = ((File *) ff)->f;
+ mp_run_data *run = mp_rundata (mp);
+ if (f != NULL) {
+ if (f == run->ship_out.fptr) {
+ mp_append_data (mp, &(run->ship_out), s, size);
+ } else {
+ (void) fwrite (s, size, 1, f);
+ }
+ }
+ }
+}
+static void mplib_close_file (MP mp, void *ff) {
+ if (ff != NULL) {
+ mp_run_data *run = mp_rundata (mp);
+ void *f = ((File *) ff)->f;
+ if (f != NULL) {
+ if (f != run->term_out.fptr
+ && f != run->error_out.fptr
+ && f != run->log_out.fptr
+ && f != run->ship_out.fptr && f != run->term_in.fptr) {
+ fclose (f);
+ }
+ }
+ free (ff);
+ }
+}
+static int mplib_eof_file (MP mp, void *ff) {
+ if (ff != NULL) {
+ mp_run_data *run = mp_rundata (mp);
+ FILE *f = ((File *) ff)->f;
+ if (f == NULL)
+ return 1;
+ if (f == run->term_in.fptr && run->term_in.data != NULL) {
+ return (run->term_in.size == 0);
+ }
+ return feof (f);
+ }
+ return 1;
+}
+static void mplib_flush_file (MP mp, void *ff) {
+ (void) mp;
+ (void) ff;
+ return;
+}
+static void mplib_shipout_backend (MP mp, void *voidh) {
+ mp_edge_header_node h = (mp_edge_header_node) voidh;
+ mp_edge_object *hh = mp_gr_export (mp, h);
+ if (hh) {
+ mp_run_data *run = mp_rundata (mp);
+ if (run->edges == NULL) {
+ run->edges = hh;
+ } else {
+ mp_edge_object *p = run->edges;
+ while (p->next != NULL) {
+ p = p->next;
+ }
+ p->next = hh;
+ }
+ }
+}
+
+
+@ This is where we fill them all in.
+@<Prepare function pointers for non-interactive use@>=
+{
+ mp->open_file = mplib_open_file;
+ mp->close_file = mplib_close_file;
+ mp->eof_file = mplib_eof_file;
+ mp->flush_file = mplib_flush_file;
+ mp->write_ascii_file = mplib_write_ascii_file;
+ mp->read_ascii_file = mplib_read_ascii_file;
+ mp->write_binary_file = mplib_write_binary_file;
+ mp->read_binary_file = mplib_read_binary_file;
+ mp->shipout_backend = mplib_shipout_backend;
+}
+
+
+@ Perhaps this is the most important API function in the library.
+
+@<Exported function ...@>=
+extern mp_run_data *mp_rundata (MP mp);
+
+@ @c
+mp_run_data *mp_rundata (MP mp) {
+ return &(mp->run_data);
+}
+
+
+@ @<Dealloc ...@>=
+mp_free_stream (&(mp->run_data.term_in));
+mp_free_stream (&(mp->run_data.term_out));
+mp_free_stream (&(mp->run_data.log_out));
+mp_free_stream (&(mp->run_data.error_out));
+mp_free_stream (&(mp->run_data.ship_out));
+
+@ @<Finish non-interactive use@>=
+xfree (mp->term_out);
+xfree (mp->term_in);
+xfree (mp->err_out);
+
+@ @<Start non-interactive work@>=
+@<Initialize the output routines@>;
+mp->input_ptr = 0;
+mp->max_in_stack = file_bottom;
+mp->in_open = file_bottom;
+mp->open_parens = 0;
+mp->max_buf_stack = 0;
+mp->param_ptr = 0;
+mp->max_param_stack = 0;
+start = loc = 0;
+iindex = file_bottom;
+nloc = nstart = NULL;
+mp->first = 0;
+line = 0;
+name = is_term;
+mp->mpx_name[file_bottom] = absent;
+mp->force_eof = false;
+t_open_in();
+mp->scanner_status = normal;
+if (!mp->ini_version) {
+ if (!mp_load_preload_file (mp)) {
+ mp->history = mp_fatal_error_stop;
+ return mp->history;
+ }
+}
+mp_fix_date_and_time (mp);
+if (mp->random_seed == 0)
+ mp->random_seed =
+ (number_to_scaled (internal_value (mp_time)) / number_to_scaled (unity_t)) + number_to_scaled (internal_value (mp_day));
+init_randoms (mp->random_seed);
+initialize_print_selector();
+mp_open_log_file (mp);
+mp_set_job_id (mp);
+mp_init_map_file (mp, mp->troff_mode);
+mp->history = mp_spotless; /* ready to go! */
+if (mp->troff_mode) {
+ number_clone (internal_value(mp_gtroffmode), unity_t);
+ number_clone (internal_value(mp_prologues), unity_t);
+}
+@<Fix up |mp->internal[mp_job_name]|@>;
+if (mp->start_sym != NULL) { /* insert the `\&{everyjob}' symbol */
+ set_cur_sym(mp->start_sym);
+ mp_back_input (mp);
+}
+
+@ @c
+int mp_execute (MP mp, char *s, size_t l) {
+ mp_reset_stream (&(mp->run_data.term_out));
+ mp_reset_stream (&(mp->run_data.log_out));
+ mp_reset_stream (&(mp->run_data.error_out));
+ mp_reset_stream (&(mp->run_data.ship_out));
+ if (mp->finished) {
+ return mp->history;
+ } else if (!mp->noninteractive) {
+ mp->history = mp_fatal_error_stop;
+ return mp->history;
+ }
+ if (mp->history < mp_fatal_error_stop) {
+ xfree (mp->jump_buf);
+ mp->jump_buf = malloc (sizeof (jmp_buf));
+ if (mp->jump_buf == NULL || setjmp (*(mp->jump_buf)) != 0) {
+ return mp->history;
+ }
+ if (s == NULL) { /* this signals EOF */
+ mp_final_cleanup (mp); /* prepare for death */
+ mp_close_files_and_terminate (mp);
+ return mp->history;
+ }
+ mp->tally = 0;
+ mp->term_offset = 0;
+ mp->file_offset = 0;
+ /* Perhaps some sort of warning here when |data| is not
+ * yet exhausted would be nice ... this happens after errors
+ */
+ if (mp->run_data.term_in.data)
+ xfree (mp->run_data.term_in.data);
+ mp->run_data.term_in.data = xstrdup (s);
+ mp->run_data.term_in.cur = mp->run_data.term_in.data;
+ mp->run_data.term_in.size = l;
+ if (mp->run_state == 0) {
+ mp->selector = term_only;
+ @<Start non-interactive work@>;
+ }
+ mp->run_state = 1;
+ (void) mp_input_ln (mp, mp->term_in);
+ mp_firm_up_the_line (mp);
+ mp->buffer[limit] = xord ('%');
+ mp->first = (size_t) (limit + 1);
+ loc = start;
+ do {
+ mp_do_statement (mp);
+ } while (cur_cmd() != mp_stop);
+ mp_final_cleanup (mp);
+ mp_close_files_and_terminate (mp);
+ }
+ return mp->history;
+}
+
+
+@ This function cleans up
+@c
+int mp_finish (MP mp) {
+ int history = 0;
+ if (mp->finished || mp->history >= mp_fatal_error_stop) {
+ history = mp->history;
+ mp_free (mp);
+ return history;
+ }
+ xfree (mp->jump_buf);
+ mp->jump_buf = malloc (sizeof (jmp_buf));
+ if (mp->jump_buf == NULL || setjmp (*(mp->jump_buf)) != 0) {
+ history = mp->history;
+ } else {
+ history = mp->history;
+ mp_final_cleanup (mp); /* prepare for death */
+ }
+ mp_close_files_and_terminate (mp);
+ mp_free (mp);
+ return history;
+}
+
+
+@ People may want to know the library version
+@c
+char *mp_metapost_version (void) {
+ return mp_strdup (metapost_version);
+}
+void mp_show_library_versions (void) {
+ fprintf(stdout, "Compiled with cairo %s; using %s\n", COMPILED_CAIRO_VERSION_STRING, cairo_version_string());
+ fprintf(stdout, "Compiled with pixman %s; using %s\n",COMPILED_PIXMAN_VERSION_STRING, pixman_version_string());
+ fprintf(stdout, "Compiled with libpng %s; using %s\n", PNG_LIBPNG_VER_STRING, png_libpng_ver);
+ fprintf(stdout, "Compiled with zlib %s; using %s\n", ZLIB_VERSION, zlibVersion());
+ fprintf(stdout, "Compiled with mpfr %s; using %s\n", COMPILED_MPFR_VERSION_STRING, mpfr_get_version());
+ fprintf(stdout, "Compiled with gmp %d.%d.%d; using %s\n\n", COMPILED__GNU_MP_VERSION, COMPILED__GNU_MP_VERSION_MINOR, COMPILED__GNU_MP_VERSION_PATCHLEVEL, COMPILED_gmp_version);
+}
+
+@ @<Exported function headers@>=
+int mp_run (MP mp);
+int mp_execute (MP mp, char *s, size_t l);
+int mp_finish (MP mp);
+char *mp_metapost_version (void);void mp_show_library_versions (void);
+
+@ @<Put each...@>=
+mp_primitive (mp, "end", mp_stop, 0);
+@:end_}{\&{end} primitive@>;
+mp_primitive (mp, "dump", mp_stop, 1);
+mp->frozen_dump = mp_frozen_primitive (mp, "dump", mp_stop, 1);
+@:dump_}{\&{dump} primitive@>
+
+
+@ @<Cases of |print_cmd...@>=
+case mp_stop:
+if (cur_mod() == 0)
+ mp_print (mp, "end");
+else
+ mp_print (mp, "dump");
+break;
+
+@* 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:
+
+@ @<Declare action procedures for use by |do_statement|@>=
+static void mp_do_random_seed (MP mp);
+@ @c
+void mp_do_random_seed (MP mp) {
+ mp_value new_expr;
+ memset(&new_expr,0,sizeof(mp_value));
+ new_number(new_expr.data.n);
+ mp_get_x_next (mp);
+ if (cur_cmd() != mp_assignment) {
+ const char *hlp[] = { "Always say `randomseed:=<numeric expression>'.", NULL };
+ mp_back_error (mp, "Missing `:=' has been inserted", hlp, true);
+@.Missing `:='@>;
+ };
+ mp_get_x_next (mp);
+ mp_scan_expression (mp);
+ if (mp->cur_exp.type != mp_known) {
+ const char *hlp[] = {
+ "Your expression was too random for me to handle,",
+ "so I won't change the random seed just now.",
+ NULL };
+ mp_disp_err(mp, NULL);
+ mp_back_error (mp, "Unknown value will be ignored", hlp, true);
+@.Unknown value...ignored@>;
+ mp_get_x_next (mp);
+ mp_flush_cur_exp (mp, new_expr);
+ } else {
+ @<Initialize the random seed to |cur_exp|@>;
+ }
+}
+
+
+@ @<Initialize the random seed to |cur_exp|@>=
+{
+ init_randoms (number_to_scaled(cur_exp_value_number ()));
+ if (mp->selector >= log_only && mp->selector < write_file) {
+ mp->old_setting = mp->selector;
+ mp->selector = log_only;
+ mp_print_nl (mp, "{randomseed:=");
+ print_number (cur_exp_value_number ());
+ mp_print_char (mp, xord ('}'));
+ mp_print_nl (mp, "");
+ mp->selector = mp->old_setting;
+ }
+}
+
+
+@ And here's another simple one (somewhat different in flavor):
+
+@ @<Put each...@>=
+mp_primitive (mp, "batchmode", mp_mode_command, mp_batch_mode);
+@:mp_batch_mode_}{\&{batchmode} primitive@>;
+mp_primitive (mp, "nonstopmode", mp_mode_command, mp_nonstop_mode);
+@:mp_nonstop_mode_}{\&{nonstopmode} primitive@>;
+mp_primitive (mp, "scrollmode", mp_mode_command, mp_scroll_mode);
+@:mp_scroll_mode_}{\&{scrollmode} primitive@>;
+mp_primitive (mp, "errorstopmode", mp_mode_command, mp_error_stop_mode);
+@:mp_error_stop_mode_}{\&{errorstopmode} primitive@>
+
+
+@ @<Cases of |print_cmd_mod|...@>=
+case mp_mode_command:
+switch (m) {
+case mp_batch_mode:
+ mp_print (mp, "batchmode");
+ break;
+case mp_nonstop_mode:
+ mp_print (mp, "nonstopmode");
+ break;
+case mp_scroll_mode:
+ mp_print (mp, "scrollmode");
+ break;
+default:
+ mp_print (mp, "errorstopmode");
+ break;
+}
+break;
+
+@ The `\&{inner}' and `\&{outer}' commands are only slightly harder.
+
+@ @<Put each...@>=
+mp_primitive (mp, "inner", mp_protection_command, 0);
+@:inner_}{\&{inner} primitive@>;
+mp_primitive (mp, "outer", mp_protection_command, 1);
+@:outer_}{\&{outer} primitive@>
+
+
+@ @<Cases of |print_cmd...@>=
+case mp_protection_command:
+if (m == 0)
+ mp_print (mp, "inner");
+else
+ mp_print (mp, "outer");
+break;
+
+@ @<Declare action procedures for use by |do_statement|@>=
+static void mp_do_protection (MP mp);
+
+@ @c
+void mp_do_protection (MP mp) {
+ int m; /* 0 to unprotect, 1 to protect */
+ halfword t; /* the |eq_type| before we change it */
+ m = cur_mod();
+ do {
+ mp_get_symbol (mp);
+ t = eq_type (cur_sym());
+ if (m == 0) {
+ if (t >= mp_outer_tag)
+ set_eq_type (cur_sym(), (t - mp_outer_tag));
+ } else if (t < mp_outer_tag) {
+ set_eq_type (cur_sym(), (t + mp_outer_tag));
+ }
+ mp_get_x_next (mp);
+ } while (cur_cmd() == mp_comma);
+}
+
+
+@ \MP\ never defines the tokens `\.(' and `\.)' to be primitives, but
+plain \MP\ begins with the declaration `\&{delimiters} \.{()}'. Such a
+declaration assigns the command code |left_delimiter| to `\.{(}' and
+|right_delimiter| to `\.{)}'; the |equiv| of each delimiter is the
+hash address of its mate.
+
+@ @<Declare action procedures for use by |do_statement|@>=
+static void mp_def_delims (MP mp);
+
+@ @c
+void mp_def_delims (MP mp) {
+ mp_sym l_delim, r_delim; /* the new delimiter pair */
+ mp_get_clear_symbol (mp);
+ l_delim = cur_sym();
+ mp_get_clear_symbol (mp);
+ r_delim = cur_sym();
+ set_eq_type (l_delim, mp_left_delimiter);
+ set_equiv_sym (l_delim, r_delim);
+ set_eq_type (r_delim, mp_right_delimiter);
+ set_equiv_sym (r_delim, l_delim);
+ mp_get_x_next (mp);
+}
+
+
+@ Here is a procedure that is called when \MP\ has reached a point
+where some right delimiter is mandatory.
+
+@<Declarations@>=
+static void mp_check_delimiter (MP mp, mp_sym l_delim, mp_sym r_delim);
+
+@ @c
+void mp_check_delimiter (MP mp, mp_sym l_delim, mp_sym r_delim) {
+ if (cur_cmd() == mp_right_delimiter)
+ if (equiv_sym (cur_sym()) == l_delim)
+ return;
+ if (cur_sym() != r_delim) {
+ char msg[256];
+ const char *hlp[] = {
+ "I found no right delimiter to match a left one. So I've",
+ "put one in, behind the scenes; this may fix the problem.",
+ NULL };
+ mp_snprintf(msg, 256, "Missing `%s' has been inserted", mp_str (mp, text (r_delim)));
+@.Missing `)'@>;
+ mp_back_error (mp, msg, hlp, true);
+ } else {
+ char msg[256];
+ const char *hlp[] = {
+ "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.",
+ NULL };
+ mp_snprintf(msg, 256, "The token `%s' is no longer a right delimiter", mp_str(mp, text (r_delim)));
+@.The token...delimiter@>;
+ mp_error (mp, msg, hlp, true);
+ }
+}
+
+
+@ The next four commands save or change the values associated with tokens.
+
+@ @<Declare action procedures for use by |do_statement|@>=
+static void mp_do_statement (MP mp);
+static void mp_do_interim (MP mp);
+
+@ @c
+void mp_do_interim (MP mp) {
+ mp_get_x_next (mp);
+ if (cur_cmd() != mp_internal_quantity) {
+ char msg[256];
+ const char *hlp[] = {
+ "Something like `tracingonline' should follow `interim'.",
+ NULL };
+ mp_snprintf(msg, 256, "The token `%s' isn't an internal quantity",
+ (cur_sym() == NULL ? "(%CAPSULE)" : mp_str(mp, text (cur_sym()))));
+@.The token...quantity@>;
+ mp_back_error (mp, msg, hlp, true);
+ } else {
+ mp_save_internal (mp, cur_mod());
+ mp_back_input (mp);
+ }
+ mp_do_statement (mp);
+}
+
+
+@ The following procedure is careful not to undefine the left-hand symbol
+too soon, lest commands like `{\tt let x=x}' have a surprising effect.
+
+@<Declare action procedures for use by |do_statement|@>=
+static void mp_do_let (MP mp);
+
+@ @c
+void mp_do_let (MP mp) {
+ mp_sym l; /* hash location of the left-hand symbol */
+ mp_get_symbol (mp);
+ l = cur_sym();
+ mp_get_x_next (mp);
+ if (cur_cmd() != mp_equals && cur_cmd() != mp_assignment) {
+ const char *hlp[] = {
+ "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'.",
+ NULL };
+ mp_back_error (mp, "Missing `=' has been inserted", hlp, true);
+@.Missing `='@>;
+ }
+ mp_get_symbol (mp);
+ switch (cur_cmd()) {
+ case mp_defined_macro:
+ case mp_secondary_primary_macro:
+ case mp_tertiary_secondary_macro:
+ case mp_expression_tertiary_macro:
+ add_mac_ref (cur_mod_node());
+ break;
+ default:
+ break;
+ }
+ mp_clear_symbol (mp, l, false);
+ set_eq_type (l, cur_cmd());
+ if (cur_cmd() == mp_tag_token)
+ set_equiv (l, 0); /* todo: this was |null| */
+ else if (cur_cmd() == mp_defined_macro ||
+ cur_cmd() == mp_secondary_primary_macro ||
+ cur_cmd() == mp_tertiary_secondary_macro ||
+ cur_cmd() == mp_expression_tertiary_macro)
+ set_equiv_node (l, cur_mod_node());
+ else if (cur_cmd() == mp_left_delimiter ||
+ cur_cmd() == mp_right_delimiter)
+ set_equiv_sym (l, equiv_sym (cur_sym()));
+ else
+ set_equiv (l, cur_mod());
+ mp_get_x_next (mp);
+}
+
+
+@ @<Declarations@>=
+static void mp_do_new_internal (MP mp);
+
+@ @<Internal library ...@>=
+void mp_grow_internals (MP mp, int l);
+
+@ @c
+void mp_grow_internals (MP mp, int l) {
+ mp_internal *internal;
+ int k;
+ if (l > max_halfword) {
+ mp_confusion (mp, "out of memory space"); /* can't be reached */
+ }
+ internal = xmalloc ((l + 1), sizeof (mp_internal));
+ for (k = 0; k <= l; k++) {
+ if (k <= mp->max_internal) {
+ memcpy (internal + k, mp->internal + k, sizeof (mp_internal));
+ } else {
+ memset (internal + k, 0, sizeof (mp_internal));
+ new_number(((mp_internal *)(internal + k))->v.data.n);
+ }
+ }
+ xfree (mp->internal);
+ mp->internal = internal;
+ mp->max_internal = l;
+}
+void mp_do_new_internal (MP mp) {
+ int the_type = mp_known;
+ mp_get_x_next (mp);
+ if (cur_cmd() == mp_type_name && cur_mod() == mp_string_type) {
+ the_type = mp_string_type;
+ } else {
+ if (!(cur_cmd() == mp_type_name && cur_mod() == mp_numeric_type)) {
+ mp_back_input (mp);
+ }
+ }
+ do {
+ if (mp->int_ptr == mp->max_internal) {
+ mp_grow_internals (mp, (mp->max_internal + (mp->max_internal / 4)));
+ }
+ mp_get_clear_symbol (mp);
+ incr (mp->int_ptr);
+ set_eq_type (cur_sym(), mp_internal_quantity);
+ set_equiv (cur_sym(), mp->int_ptr);
+ if (internal_name (mp->int_ptr) != NULL)
+ xfree (internal_name (mp->int_ptr));
+ set_internal_name (mp->int_ptr,
+ mp_xstrdup (mp, mp_str (mp, text (cur_sym()))));
+ if (the_type == mp_string_type) {
+ set_internal_string (mp->int_ptr, mp_rts(mp,""));
+ } else {
+ set_number_to_zero (internal_value (mp->int_ptr));
+ }
+ set_internal_type (mp->int_ptr, the_type);
+ mp_get_x_next (mp);
+ } while (cur_cmd() == mp_comma);
+}
+
+
+@ @<Dealloc variables@>=
+for (k = 0; k <= mp->max_internal; k++) {
+ free_number(mp->internal[k].v.data.n);
+ xfree (internal_name (k));
+}
+xfree (mp->internal);
+
+
+@ The various `\&{show}' commands are distinguished by modifier fields
+in the usual way.
+
+@d show_token_code 0 /* show the meaning of a single token */
+@d show_stats_code 1 /* show current memory and string usage */
+@d show_code 2 /* show a list of expressions */
+@d show_var_code 3 /* show a variable and its descendents */
+@d show_dependencies_code 4 /* show dependent variables in terms of independents */
+
+@<Put each...@>=
+mp_primitive (mp, "showtoken", mp_show_command, show_token_code);
+@:show_token_}{\&{showtoken} primitive@>;
+mp_primitive (mp, "showstats", mp_show_command, show_stats_code);
+@:show_stats_}{\&{showstats} primitive@>;
+mp_primitive (mp, "show", mp_show_command, show_code);
+@:show_}{\&{show} primitive@>;
+mp_primitive (mp, "showvariable", mp_show_command, show_var_code);
+@:show_var_}{\&{showvariable} primitive@>;
+mp_primitive (mp, "showdependencies", mp_show_command, show_dependencies_code);
+@:show_dependencies_}{\&{showdependencies} primitive@>
+
+
+@ @<Cases of |print_cmd...@>=
+case mp_show_command:
+switch (m) {
+case show_token_code:
+ mp_print (mp, "showtoken");
+ break;
+case show_stats_code:
+ mp_print (mp, "showstats");
+ break;
+case show_code:
+ mp_print (mp, "show");
+ break;
+case show_var_code:
+ mp_print (mp, "showvariable");
+ break;
+default:
+ mp_print (mp, "showdependencies");
+ break;
+}
+break;
+
+@ 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|@>=
+static void mp_do_show (MP mp);
+
+@ @c
+void mp_do_show (MP mp) {
+ mp_value new_expr;
+ do {
+ memset(&new_expr,0,sizeof(mp_value));
+ new_number(new_expr.data.n);
+ mp_get_x_next (mp);
+ mp_scan_expression (mp);
+ mp_print_nl (mp, ">> ");
+@.>>@>;
+ mp_print_exp (mp, NULL, 2);
+ mp_flush_cur_exp (mp, new_expr);
+ } while (cur_cmd() == mp_comma);
+}
+
+
+@ @<Declare action procedures for use by |do_statement|@>=
+static void mp_disp_token (MP mp);
+
+@ @c
+void mp_disp_token (MP mp) {
+ mp_print_nl (mp, "> ");
+@.>\relax@>;
+ if (cur_sym() == NULL) {
+ @<Show a numeric or string or capsule token@>;
+ } else {
+ mp_print_text (cur_sym());
+ mp_print_char (mp, xord ('='));
+ if (eq_type (cur_sym()) >= mp_outer_tag)
+ mp_print (mp, "(outer) ");
+ mp_print_cmd_mod (mp, cur_cmd(), cur_mod());
+ if (cur_cmd() == mp_defined_macro) {
+ mp_print_ln (mp);
+ mp_show_macro (mp, cur_mod_node(), NULL, 100000);
+ } /* this avoids recursion between |show_macro| and |print_cmd_mod| */
+@^recursion@>
+ }
+}
+
+
+@ @<Show a numeric or string or capsule token@>=
+{
+ if (cur_cmd() == mp_numeric_token) {
+ print_number (cur_mod_number());
+ } else if (cur_cmd() == mp_capsule_token) {
+ mp_print_capsule (mp, cur_mod_node());
+ } else {
+ mp_print_char (mp, xord ('"'));
+ mp_print_str (mp, cur_mod_str());
+ mp_print_char (mp, xord ('"'));
+ delete_str_ref (cur_mod_str());
+ }
+}
+
+
+@ The following cases of |print_cmd_mod| might arise in connection
+with |disp_token|, although they don't necessarily correspond to
+primitive tokens.
+
+@<Cases of |print_cmd_...@>=
+case mp_left_delimiter:
+case mp_right_delimiter:
+if (c == mp_left_delimiter)
+ mp_print (mp, "left");
+else
+ mp_print (mp, "right");
+#if 0
+mp_print (mp, " delimiter that matches ");
+mp_print_text (m);
+#else
+mp_print (mp, " delimiter");
+#endif
+break;
+case mp_tag_token:
+if (m == 0) /* todo: this was |null| */
+ mp_print (mp, "tag");
+else
+ mp_print (mp, "variable");
+break;
+case mp_defined_macro:
+mp_print (mp, "macro:");
+break;
+case mp_secondary_primary_macro:
+case mp_tertiary_secondary_macro:
+case mp_expression_tertiary_macro:
+ mp_print_cmd_mod(mp, mp_macro_def,c);
+ mp_print(mp, "'d macro:");
+ mp_print_ln(mp);
+ mp_show_token_list(mp, mp_link(mp_link(cur_mod_node())),0,1000,0);
+ break;
+case mp_repeat_loop:
+mp_print (mp, "[repeat the loop]");
+break;
+case mp_internal_quantity:
+mp_print (mp, internal_name (m));
+break;
+
+
+@ @<Declare action procedures for use by |do_statement|@>=
+static void mp_do_show_token (MP mp);
+
+@ @c
+void mp_do_show_token (MP mp) {
+ do {
+ get_t_next (mp);
+ mp_disp_token (mp);
+ mp_get_x_next (mp);
+ } while (cur_cmd() == mp_comma);
+}
+
+
+@ @<Declare action procedures for use by |do_statement|@>=
+static void mp_do_show_stats (MP mp);
+
+@ @c
+void mp_do_show_stats (MP mp) {
+ mp_print_nl (mp, "Memory usage ");
+@.Memory usage...@>;
+ mp_print_int (mp, (integer) mp->var_used);
+ mp_print_ln (mp);
+ mp_print_nl (mp, "String usage ");
+ mp_print_int (mp, (int) mp->strs_in_use);
+ mp_print_char (mp, xord ('&'));
+ mp_print_int (mp, (int) mp->pool_in_use);
+ mp_print_ln (mp);
+ mp_get_x_next (mp);
+}
+
+
+@ Here's a recursive procedure that gives an abbreviated account
+of a variable, for use by |do_show_var|.
+
+@<Declare action procedures for use by |do_statement|@>=
+static void mp_disp_var (MP mp, mp_node p);
+
+@ @c
+void mp_disp_var (MP mp, mp_node p) {
+ mp_node q; /* traverses attributes and subscripts */
+ int n; /* amount of macro text to show */
+ if (mp_type (p) == mp_structured) {
+ @<Descend the structure@>;
+ } else if (mp_type (p) >= mp_unsuffixed_macro) {
+ @<Display a variable macro@>;
+ } else if (mp_type (p) != mp_undefined) {
+ mp_print_nl (mp, "");
+ mp_print_variable_name (mp, p);
+ mp_print_char (mp, xord ('='));
+ mp_print_exp (mp, p, 0);
+ }
+}
+
+
+@ @<Descend the structure@>=
+{
+ q = attr_head (p);
+ do {
+ mp_disp_var (mp, q);
+ q = mp_link (q);
+ } while (q != mp->end_attr);
+ q = subscr_head (p);
+ while (mp_name_type (q) == mp_subscr) {
+ mp_disp_var (mp, q);
+ q = mp_link (q);
+ }
+}
+
+
+@ @<Display a variable macro@>=
+{
+ mp_print_nl (mp, "");
+ mp_print_variable_name (mp, p);
+ if (mp_type (p) > mp_unsuffixed_macro)
+ mp_print (mp, "@@#"); /* |suffixed_macro| */
+ mp_print (mp, "=macro:");
+ if ((int) mp->file_offset >= mp->max_print_line - 20)
+ n = 5;
+ else
+ n = mp->max_print_line - (int) mp->file_offset - 15;
+ mp_show_macro (mp, value_node (p), NULL, n);
+}
+
+
+@ @<Declare action procedures for use by |do_statement|@>=
+static void mp_do_show_var (MP mp);
+
+@ @c
+void mp_do_show_var (MP mp) {
+ do {
+ get_t_next (mp);
+ if (cur_sym() != NULL)
+ if (cur_sym_mod() == 0)
+ if (cur_cmd() == mp_tag_token)
+ if (cur_mod() != 0 || cur_mod_node()!=NULL) {
+ mp_disp_var (mp, cur_mod_node());
+ goto DONE;
+ }
+ mp_disp_token (mp);
+ DONE:
+ mp_get_x_next (mp);
+ } while (cur_cmd() == mp_comma);
+}
+
+
+@ @<Declare action procedures for use by |do_statement|@>=
+static void mp_do_show_dependencies (MP mp);
+
+@ @c
+void mp_do_show_dependencies (MP mp) {
+ mp_value_node p; /* link that runs through all dependencies */
+ p = (mp_value_node) mp_link (mp->dep_head);
+ while (p != mp->dep_head) {
+ if (mp_interesting (mp, (mp_node) p)) {
+ mp_print_nl (mp, "");
+ mp_print_variable_name (mp, (mp_node) p);
+ if (mp_type (p) == mp_dependent)
+ mp_print_char (mp, xord ('='));
+ else
+ mp_print (mp, " = "); /* extra spaces imply proto-dependency */
+ mp_print_dependency (mp, (mp_value_node) dep_list (p), mp_type (p));
+ }
+ p = (mp_value_node) dep_list (p);
+ while (dep_info (p) != NULL)
+ p = (mp_value_node) mp_link (p);
+ p = (mp_value_node) mp_link (p);
+ }
+ mp_get_x_next (mp);
+}
+
+
+@ Finally we are ready for the procedure that governs all of the
+show commands.
+
+@<Declare action procedures for use by |do_statement|@>=
+static void mp_do_show_whatever (MP mp);
+
+@ @c
+void mp_do_show_whatever (MP mp) {
+ if (mp->interaction == mp_error_stop_mode)
+ wake_up_terminal();
+ switch (cur_mod()) {
+ case show_token_code:
+ mp_do_show_token (mp);
+ break;
+ case show_stats_code:
+ mp_do_show_stats (mp);
+ break;
+ case show_code:
+ mp_do_show (mp);
+ break;
+ case show_var_code:
+ mp_do_show_var (mp);
+ break;
+ case show_dependencies_code:
+ mp_do_show_dependencies (mp);
+ break;
+ } /* there are no other cases */
+ if (number_positive (internal_value (mp_showstopping))) {
+ const char *hlp[] = {
+ "This isn't an error message; I'm just showing something.",
+ NULL };
+ if (mp->interaction < mp_error_stop_mode) {
+ hlp[0] = NULL;
+ decr (mp->error_count);
+ }
+ if (cur_cmd() == mp_semicolon) {
+ mp_error (mp, "OK", hlp, true);
+ } else {
+ mp_back_error (mp, "OK", hlp, true);
+ mp_get_x_next (mp);
+ }
+@.OK@>;
+ }
+}
+
+
+@ 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_mp_pre_script 11
+@d with_mp_post_script 13
+
+@<Put each...@>=
+mp_primitive (mp, "doublepath", mp_thing_to_add, double_path_code);
+@:double_path_}{\&{doublepath} primitive@>;
+mp_primitive (mp, "contour", mp_thing_to_add, contour_code);
+@:contour_}{\&{contour} primitive@>;
+mp_primitive (mp, "also", mp_thing_to_add, also_code);
+@:also_}{\&{also} primitive@>;
+mp_primitive (mp, "withpen", mp_with_option, mp_pen_type);
+@:with_pen_}{\&{withpen} primitive@>;
+mp_primitive (mp, "dashed", mp_with_option, mp_picture_type);
+@:dashed_}{\&{dashed} primitive@>;
+mp_primitive (mp, "withprescript", mp_with_option, with_mp_pre_script);
+@:with_mp_pre_script_}{\&{withprescript} primitive@>;
+mp_primitive (mp, "withpostscript", mp_with_option, with_mp_post_script);
+@:with_mp_post_script_}{\&{withpostscript} primitive@>;
+mp_primitive (mp, "withoutcolor", mp_with_option, mp_no_model);
+@:with_color_}{\&{withoutcolor} primitive@>;
+mp_primitive (mp, "withgreyscale", mp_with_option, mp_grey_model);
+@:with_color_}{\&{withgreyscale} primitive@>;
+mp_primitive (mp, "withcolor", mp_with_option, mp_uninitialized_model);
+@:with_color_}{\&{withcolor} primitive@>
+/* \&{withrgbcolor} is an alias for \&{withcolor} */
+ mp_primitive (mp, "withrgbcolor", mp_with_option, mp_rgb_model);
+@:with_color_}{\&{withrgbcolor} primitive@>;
+mp_primitive (mp, "withcmykcolor", mp_with_option, mp_cmyk_model);
+@:with_color_}{\&{withcmykcolor} primitive@>
+
+
+@ @<Cases of |print_cmd...@>=
+case mp_thing_to_add:
+if (m == contour_code)
+ mp_print (mp, "contour");
+else if (m == double_path_code)
+ mp_print (mp, "doublepath");
+else
+ mp_print (mp, "also");
+break;
+case mp_with_option:
+if (m == mp_pen_type)
+ mp_print (mp, "withpen");
+else if (m == with_mp_pre_script)
+ mp_print (mp, "withprescript");
+else if (m == with_mp_post_script)
+ mp_print (mp, "withpostscript");
+else if (m == mp_no_model)
+ mp_print (mp, "withoutcolor");
+else if (m == mp_rgb_model)
+ mp_print (mp, "withrgbcolor");
+else if (m == mp_uninitialized_model)
+ mp_print (mp, "withcolor");
+else if (m == mp_cmyk_model)
+ mp_print (mp, "withcmykcolor");
+else if (m == mp_grey_model)
+ mp_print (mp, "withgreyscale");
+else
+ mp_print (mp, "dashed");
+break;
+
+@ The |scan_with_list| procedure parses a $\langle$with list$\rangle$ and
+updates the list of graphical objects starting at |p|. Each $\langle$with
+clause$\rangle$ updates all graphical objects whose |type| is compatible.
+Other objects are ignored.
+
+@<Declare action procedures for use by |do_statement|@>=
+static void mp_scan_with_list (MP mp, mp_node p);
+
+@ 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.
+
+@d make_cp_a_colored_object() do {
+ cp = p;
+ while (cp != NULL) {
+ if (has_color (cp))
+ break;
+ cp = mp_link (cp);
+ }
+} while (0)
+
+@d clear_color(A) do {
+ set_number_to_zero(((mp_stroked_node)(A))->cyan);
+ set_number_to_zero(((mp_stroked_node)(A))->magenta);
+ set_number_to_zero(((mp_stroked_node)(A))->yellow);
+ set_number_to_zero(((mp_stroked_node)(A))->black);
+ mp_color_model ((A)) = mp_uninitialized_model;
+} while (0)
+
+@d set_color_val(A,B) do {
+ number_clone(A, (B));
+ if (number_negative(A))
+ set_number_to_zero(A);
+ if (number_greater(A,unity_t))
+ set_number_to_unity(A);
+} while (0)
+
+@c
+static int is_invalid_with_list (MP mp, mp_variable_type t) {
+ return ((t == with_mp_pre_script) && (mp->cur_exp.type != mp_string_type)) ||
+ ((t == with_mp_post_script) && (mp->cur_exp.type != mp_string_type)) ||
+ ((t == (mp_variable_type) mp_uninitialized_model) &&
+ ((mp->cur_exp.type != mp_cmykcolor_type)
+ && (mp->cur_exp.type != mp_color_type)
+ && (mp->cur_exp.type != mp_known)
+ && (mp->cur_exp.type != mp_boolean_type))) || ((t == (mp_variable_type) mp_cmyk_model)
+ && (mp->cur_exp.type !=
+ mp_cmykcolor_type))
+ || ((t == (mp_variable_type) mp_rgb_model) && (mp->cur_exp.type != mp_color_type))
+ || ((t == (mp_variable_type) mp_grey_model) && (mp->cur_exp.type != mp_known))
+ || ((t == (mp_variable_type) mp_pen_type) && (mp->cur_exp.type != t))
+ || ((t == (mp_variable_type) mp_picture_type) && (mp->cur_exp.type != t));
+}
+static void complain_invalid_with_list (MP mp, mp_variable_type t) {
+ /* Complain about improper type */
+ mp_value new_expr;
+ const char *hlp[] = {
+ "Next time say `withpen <known pen expression>';",
+ "I'll ignore the bad `with' clause and look for another.",
+ NULL };
+ memset(&new_expr,0,sizeof(mp_value));
+ new_number(new_expr.data.n);
+ mp_disp_err(mp, NULL);
+ if (t == with_mp_pre_script)
+ hlp[0] = "Next time say `withprescript <known string expression>';";
+ else if (t == with_mp_post_script)
+ hlp[0] = "Next time say `withpostscript <known string expression>';";
+ else if (t == mp_picture_type)
+ hlp[0] = "Next time say `dashed <known picture expression>';";
+ else if (t == (mp_variable_type) mp_uninitialized_model)
+ hlp[0] = "Next time say `withcolor <known color expression>';";
+ else if (t == (mp_variable_type) mp_rgb_model)
+ hlp[0] = "Next time say `withrgbcolor <known color expression>';";
+ else if (t == (mp_variable_type) mp_cmyk_model)
+ hlp[0] = "Next time say `withcmykcolor <known cmykcolor expression>';";
+ else if (t == (mp_variable_type) mp_grey_model)
+ hlp[0] = "Next time say `withgreyscale <known numeric expression>';";;
+ mp_back_error (mp, "Improper type", hlp, true);
+ mp_get_x_next (mp);
+ mp_flush_cur_exp (mp, new_expr);
+}
+
+void mp_scan_with_list (MP mp, mp_node p) {
+ mp_variable_type t; /* |cur_mod| of the |with_option| (should match |cur_type|) */
+ mp_node q; /* for list manipulation */
+ mp_node cp, pp, dp, ap, bp;
+ /* objects being updated; |void| initially; |NULL| to suppress update */
+ cp = MP_VOID;
+ pp = MP_VOID;
+ dp = MP_VOID;
+ ap = MP_VOID;
+ bp = MP_VOID;
+ while (cur_cmd() == mp_with_option) {
+ /* todo this is not very nice: the color models have their own enumeration */
+ t = (mp_variable_type) cur_mod();
+ mp_get_x_next (mp);
+ if (t != (mp_variable_type) mp_no_model)
+ mp_scan_expression (mp);
+ if (is_invalid_with_list(mp, t)) {
+ complain_invalid_with_list (mp, t);
+ continue;
+ }
+ if (t == (mp_variable_type) mp_uninitialized_model) {
+ mp_value new_expr;
+ memset(&new_expr,0,sizeof(mp_value));
+ new_number(new_expr.data.n);
+ if (cp == MP_VOID)
+ make_cp_a_colored_object();
+ if (cp != NULL) {
+ /* Transfer a color from the current expression to object~|cp| */
+ if (mp->cur_exp.type == mp_color_type) {
+ /* Transfer a rgbcolor from the current expression to object~|cp| */
+ mp_stroked_node cp0 = (mp_stroked_node)cp;
+ q = value_node (cur_exp_node ());
+ clear_color(cp0);
+ mp_color_model (cp) = mp_rgb_model;
+ set_color_val (cp0->red, value_number (red_part (q)));
+ set_color_val (cp0->green, value_number (green_part (q)));
+ set_color_val (cp0->blue, value_number (blue_part (q)));
+ } else if (mp->cur_exp.type == mp_cmykcolor_type) {
+ /* Transfer a cmykcolor from the current expression to object~|cp| */
+ mp_stroked_node cp0 = (mp_stroked_node)cp;
+ q = value_node (cur_exp_node ());
+ set_color_val (cp0->cyan, value_number (cyan_part (q)));
+ set_color_val (cp0->magenta, value_number (magenta_part (q)));
+ set_color_val (cp0->yellow, value_number (yellow_part (q)));
+ set_color_val (cp0->black, value_number (black_part (q)));
+ mp_color_model (cp) = mp_cmyk_model;
+ } else if (mp->cur_exp.type == mp_known) {
+ /* Transfer a greyscale from the current expression to object~|cp| */
+ mp_number qq;
+ mp_stroked_node cp0 = (mp_stroked_node)cp;
+ new_number (qq);
+ number_clone (qq, cur_exp_value_number ());
+ clear_color (cp);
+ mp_color_model (cp) = mp_grey_model;
+ set_color_val (cp0->grey, qq);
+ free_number (qq);
+ } else if (cur_exp_value_boolean () == mp_false_code) {
+ /* Transfer a noncolor from the current expression to object~|cp| */
+ clear_color (cp);
+ mp_color_model (cp) = mp_no_model;
+ } else if (cur_exp_value_boolean () == mp_true_code) {
+ /* Transfer no color from the current expression to object~|cp| */
+ clear_color (cp);
+ mp_color_model (cp) = mp_uninitialized_model;
+ }
+ }
+ mp_flush_cur_exp (mp, new_expr);
+ } else if (t == (mp_variable_type) mp_rgb_model) {
+ mp_value new_expr;
+ memset(&new_expr,0,sizeof(mp_value));
+ new_number(new_expr.data.n);
+ if (cp == MP_VOID)
+ make_cp_a_colored_object();
+ if (cp != NULL) {
+ /* Transfer a rgbcolor from the current expression to object~|cp| */
+ mp_stroked_node cp0 = (mp_stroked_node)cp;
+ q = value_node (cur_exp_node ());
+ clear_color(cp0);
+ mp_color_model (cp) = mp_rgb_model;
+ set_color_val (cp0->red, value_number (red_part (q)));
+ set_color_val (cp0->green, value_number (green_part (q)));
+ set_color_val (cp0->blue, value_number (blue_part (q)));
+ }
+ mp_flush_cur_exp (mp, new_expr);
+ } else if (t == (mp_variable_type) mp_cmyk_model) {
+ mp_value new_expr;
+ memset(&new_expr,0,sizeof(mp_value));
+ new_number(new_expr.data.n);
+ if (cp == MP_VOID)
+ make_cp_a_colored_object();
+ if (cp != NULL) {
+ /* Transfer a cmykcolor from the current expression to object~|cp| */
+ mp_stroked_node cp0 = (mp_stroked_node)cp;
+ q = value_node (cur_exp_node ());
+ set_color_val (cp0->cyan, value_number (cyan_part (q)));
+ set_color_val (cp0->magenta, value_number (magenta_part (q)));
+ set_color_val (cp0->yellow, value_number (yellow_part (q)));
+ set_color_val (cp0->black, value_number (black_part (q)));
+ mp_color_model (cp) = mp_cmyk_model;
+ }
+ mp_flush_cur_exp (mp, new_expr);
+ } else if (t == (mp_variable_type) mp_grey_model) {
+ mp_value new_expr;
+ memset(&new_expr,0,sizeof(mp_value));
+ new_number(new_expr.data.n);
+ if (cp == MP_VOID)
+ make_cp_a_colored_object();
+ if (cp != NULL) {
+ /* Transfer a greyscale from the current expression to object~|cp| */
+ mp_number qq;
+ mp_stroked_node cp0 = (mp_stroked_node)cp;
+ new_number (qq);
+ number_clone (qq, cur_exp_value_number ());
+ clear_color (cp);
+ mp_color_model (cp) = mp_grey_model;
+ set_color_val (cp0->grey, qq);
+ free_number (qq);
+ }
+ mp_flush_cur_exp (mp, new_expr);
+ } else if (t == (mp_variable_type) mp_no_model) {
+ if (cp == MP_VOID)
+ make_cp_a_colored_object();
+ if (cp != NULL) {
+ /* Transfer a noncolor from the current expression to object~|cp| */
+ clear_color (cp);
+ mp_color_model (cp) = mp_no_model;
+ }
+ } else if (t == mp_pen_type) {
+ if (pp == MP_VOID) {
+ /* Make |pp| an object in list~|p| that needs a pen */
+ pp = p;
+ while (pp != NULL) {
+ if (has_pen (pp))
+ break;
+ pp = mp_link (pp);
+ }
+ }
+
+ if (pp != NULL) {
+ switch (mp_type (pp)) {
+ case mp_fill_node_type:
+ if (mp_pen_p ((mp_fill_node) pp) != NULL)
+ mp_toss_knot_list (mp, mp_pen_p ((mp_fill_node) pp));
+ mp_pen_p ((mp_fill_node) pp) = cur_exp_knot ();
+ break;
+ case mp_stroked_node_type:
+ if (mp_pen_p ((mp_stroked_node) pp) != NULL)
+ mp_toss_knot_list (mp, mp_pen_p ((mp_stroked_node) pp));
+ mp_pen_p ((mp_stroked_node) pp) = cur_exp_knot ();
+ break;
+ default:
+ assert (0);
+ break;
+ }
+ mp->cur_exp.type = mp_vacuous;
+ }
+ } else if (t == with_mp_pre_script) {
+ if (cur_exp_str ()->len) {
+ if (ap == MP_VOID)
+ ap = p;
+ while ((ap != NULL) && (!has_color (ap)))
+ ap = mp_link (ap);
+ if (ap != NULL) {
+ if (mp_pre_script (ap) != NULL) { /* build a new,combined string */
+ unsigned old_setting; /* saved |selector| setting */
+ mp_string s; /* for string cleanup after combining */
+ s = mp_pre_script (ap);
+ old_setting = mp->selector;
+ mp->selector = new_string;
+ str_room (mp_pre_script (ap)->len + cur_exp_str ()->len + 2);
+ mp_print_str (mp, cur_exp_str ());
+ append_char (13); /* a forced \ps\ newline */
+ mp_print_str (mp, mp_pre_script (ap));
+ mp_pre_script (ap) = mp_make_string (mp);
+ delete_str_ref (s);
+ mp->selector = old_setting;
+ } else {
+ mp_pre_script (ap) = cur_exp_str ();
+ }
+ add_str_ref (mp_pre_script (ap));
+ mp->cur_exp.type = mp_vacuous;
+ }
+ }
+ } else if (t == with_mp_post_script) {
+ if (cur_exp_str ()->len) {
+ if (bp == MP_VOID)
+ bp = p;
+ while ((bp != NULL) && (!has_color (bp)))
+ bp = mp_link (bp);
+ if (bp != NULL) {
+ if (mp_post_script (bp) != NULL) {
+ unsigned old_setting; /* saved |selector| setting */
+ mp_string s; /* for string cleanup after combining */
+ s = mp_post_script (bp);
+ old_setting = mp->selector;
+ mp->selector = new_string;
+ str_room (mp_post_script (bp)->len + cur_exp_str ()->len + 2);
+ mp_print_str (mp, mp_post_script (bp));
+ append_char (13); /* a forced \ps\ newline */
+ mp_print_str (mp, cur_exp_str ());
+ mp_post_script (bp) = mp_make_string (mp);
+ delete_str_ref (s);
+ mp->selector = old_setting;
+ } else {
+ mp_post_script (bp) = cur_exp_str ();
+ }
+ add_str_ref (mp_post_script (bp));
+ mp->cur_exp.type = mp_vacuous;
+ }
+ }
+ } else {
+ if (dp == MP_VOID) {
+ /* Make |dp| a stroked node in list~|p| */
+ dp = p;
+ while (dp != NULL) {
+ if (mp_type (dp) == mp_stroked_node_type)
+ break;
+ dp = mp_link (dp);
+ }
+ }
+ if (dp != NULL) {
+ if (mp_dash_p (dp) != NULL)
+ delete_edge_ref (mp_dash_p (dp));
+ mp_dash_p (dp) = (mp_node)mp_make_dashes (mp, (mp_edge_header_node)cur_exp_node ());
+ set_number_to_unity(((mp_stroked_node)dp)->dash_scale);
+ mp->cur_exp.type = mp_vacuous;
+ }
+ }
+ }
+ /* Copy the information from objects |cp|, |pp|, and |dp| into the rest
+ of the list */
+ if (cp > MP_VOID) {
+ /* Copy |cp|'s color into the colored objects linked to~|cp| */
+ q = mp_link (cp);
+ while (q != NULL) {
+ if (has_color (q)) {
+ mp_stroked_node q0 = (mp_stroked_node)q;
+ mp_stroked_node cp0 = (mp_stroked_node)cp;
+ number_clone(q0->red, cp0->red);
+ number_clone(q0->green, cp0->green);
+ number_clone(q0->blue, cp0->blue);
+ number_clone(q0->black, cp0->black);
+ mp_color_model (q) = mp_color_model (cp);
+ }
+ q = mp_link (q);
+ }
+ }
+ if (pp > MP_VOID) {
+ /* Copy |mp_pen_p(pp)| into stroked and filled nodes linked to |pp| */
+ q = mp_link (pp);
+ while (q != NULL) {
+ if (has_pen (q)) {
+ switch (mp_type (q)) {
+ case mp_fill_node_type:
+ if (mp_pen_p ((mp_fill_node) q) != NULL)
+ mp_toss_knot_list (mp, mp_pen_p ((mp_fill_node) q));
+ mp_pen_p ((mp_fill_node) q) = copy_pen (mp_pen_p ((mp_fill_node) pp));
+ break;
+ case mp_stroked_node_type:
+ if (mp_pen_p ((mp_stroked_node) q) != NULL)
+ mp_toss_knot_list (mp, mp_pen_p ((mp_stroked_node) q));
+ mp_pen_p ((mp_stroked_node) q) =
+ copy_pen (mp_pen_p ((mp_stroked_node) pp));
+ break;
+ default:
+ assert (0);
+ break;
+ }
+ }
+ q = mp_link (q);
+ }
+ }
+ if (dp > MP_VOID) {
+ /* Make stroked nodes linked to |dp| refer to |mp_dash_p(dp)| */
+ q = mp_link (dp);
+ while (q != NULL) {
+ if (mp_type (q) == mp_stroked_node_type) {
+ if (mp_dash_p (q) != NULL)
+ delete_edge_ref (mp_dash_p (q));
+ mp_dash_p (q) = mp_dash_p (dp);
+ set_number_to_unity(((mp_stroked_node)q)->dash_scale);
+ if (mp_dash_p (q) != NULL)
+ add_edge_ref (mp_dash_p (q));
+ }
+ q = mp_link (q);
+ }
+ }
+}
+
+
+@ One of the things we need to do when we've parsed an \&{addto} or
+similar command is find the header of a supposed \&{picture} variable, given
+a token list for that variable. Since the edge structure is about to be
+updated, we use |private_edges| to make sure that this is possible.
+
+@<Declare action procedures for use by |do_statement|@>=
+static mp_edge_header_node mp_find_edges_var (MP mp, mp_node t);
+
+@ @c
+mp_edge_header_node mp_find_edges_var (MP mp, mp_node t) {
+ mp_node p;
+ mp_edge_header_node cur_edges; /* the return value */
+ p = mp_find_variable (mp, t);
+ cur_edges = NULL;
+ if (p == NULL) {
+ const char *hlp[] = {
+ "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.",
+ NULL };
+ char *msg = mp_obliterated (mp, t);
+ mp_back_error (mp, msg, hlp, true);
+ free(msg);
+ mp_get_x_next (mp);
+ } else if (mp_type (p) != mp_picture_type) {
+ char msg[256];
+ mp_string sname;
+ int old_setting = mp->selector;
+ const char *hlp[] = {
+ "I was looking for a \"known\" picture variable.",
+ "So I'll not change anything just now.",
+ NULL };
+ mp->selector = new_string;
+ mp_show_token_list (mp, t, NULL, 1000, 0);
+ sname = mp_make_string(mp);
+ mp->selector = old_setting;
+ mp_snprintf (msg, 256, "Variable %s is the wrong type(%s)",
+ mp_str(mp, sname), mp_type_string(mp_type (p)));
+@.Variable x is the wrong type@>;
+ delete_str_ref(sname);
+ mp_back_error (mp, msg, hlp, true);
+ mp_get_x_next (mp);
+ } else {
+ set_value_node (p, (mp_node)mp_private_edges (mp, (mp_edge_header_node)value_node (p)));
+ cur_edges = (mp_edge_header_node)value_node (p);
+ }
+ mp_flush_node_list (mp, t);
+ return cur_edges;
+}
+
+
+@ @<Put each...@>=
+mp_primitive (mp, "clip", mp_bounds_command, mp_start_clip_node_type);
+@:clip_}{\&{clip} primitive@>;
+mp_primitive (mp, "setbounds", mp_bounds_command, mp_start_bounds_node_type);
+@:set_bounds_}{\&{setbounds} primitive@>
+
+
+@ @<Cases of |print_cmd...@>=
+case mp_bounds_command:
+if (m == mp_start_clip_node_type)
+ mp_print (mp, "clip");
+else
+ mp_print (mp, "setbounds");
+break;
+
+@ The following function parses the beginning of an \&{addto} or \&{clip}
+command: it expects a variable name followed by a token with |cur_cmd=sep|
+and then an expression. The function returns the token list for the variable
+and stores the command modifier for the separator token in the global variable
+|last_add_type|. We must be careful because this variable might get overwritten
+any time we call |get_x_next|.
+
+@<Glob...@>=
+quarterword last_add_type;
+ /* command modifier that identifies the last \&{addto} command */
+
+@ @<Declare action procedures for use by |do_statement|@>=
+static mp_node mp_start_draw_cmd (MP mp, quarterword sep);
+
+@ @c
+mp_node mp_start_draw_cmd (MP mp, quarterword sep) {
+ mp_node lhv; /* variable to add to left */
+ quarterword add_type = 0; /* value to be returned in |last_add_type| */
+ lhv = NULL;
+ mp_get_x_next (mp);
+ mp->var_flag = sep;
+ mp_scan_primary (mp);
+ if (mp->cur_exp.type != mp_token_list) {
+ /* Abandon edges command because there's no variable */
+ mp_value new_expr;
+ const char *hlp[] = {
+ "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.",
+ NULL };
+ memset(&new_expr,0,sizeof(mp_value));
+ new_number(new_expr.data.n);
+ mp_disp_err(mp, NULL);
+ set_number_to_zero (new_expr.data.n);
+ mp_back_error (mp, "Not a suitable variable", hlp, true);
+ mp_get_x_next (mp);
+ mp_flush_cur_exp (mp, new_expr);
+ } else {
+ lhv = cur_exp_node ();
+ add_type = (quarterword) cur_mod();
+ mp->cur_exp.type = mp_vacuous;
+ mp_get_x_next (mp);
+ mp_scan_expression (mp);
+ }
+ mp->last_add_type = add_type;
+ return lhv;
+}
+
+@ Here is an example of how to use |start_draw_cmd|.
+
+@<Declare action procedures for use by |do_statement|@>=
+static void mp_do_bounds (MP mp);
+
+@ @c
+void mp_do_bounds (MP mp) {
+ mp_node lhv; /* variable on left, the corresponding edge structure */
+ mp_edge_header_node lhe;
+ mp_node p; /* for list manipulation */
+ integer m; /* initial value of |cur_mod| */
+ m = cur_mod();
+ lhv = mp_start_draw_cmd (mp, mp_to_token);
+ if (lhv != NULL) {
+ mp_value new_expr;
+ memset(&new_expr,0,sizeof(mp_value));
+ lhe = mp_find_edges_var (mp, lhv);
+ if (lhe == NULL) {
+ new_number(new_expr.data.n);
+ set_number_to_zero (new_expr.data.n);
+ mp_flush_cur_exp (mp, new_expr);
+ } else if (mp->cur_exp.type != mp_path_type) {
+ const char *hlp[] ={
+ "This expression should have specified a known path.",
+ "So I'll not change anything just now.",
+ NULL };
+ mp_disp_err(mp, NULL);
+ new_number(new_expr.data.n);
+ set_number_to_zero (new_expr.data.n);
+ mp_back_error (mp, "Improper `clip'", hlp, true);
+ mp_get_x_next (mp);
+ mp_flush_cur_exp (mp, new_expr);
+ } else if (mp_left_type (cur_exp_knot ()) == mp_endpoint) {
+ /* Complain about a non-cycle */
+ const char *hlp[] = {
+ "That contour should have ended with `..cycle' or `&cycle'.",
+ "So I'll not change anything just now.",
+ NULL };
+ mp_back_error (mp, "Not a cycle" , hlp, true);
+ mp_get_x_next (mp);
+ } else {
+ /* Make |cur_exp| into a \&{setbounds} or clipping path and add it to |lhe| */
+ p = mp_new_bounds_node (mp, cur_exp_knot (), (quarterword) m);
+ mp_link (p) = mp_link (edge_list (lhe));
+ mp_link (edge_list (lhe)) = p;
+ if (obj_tail (lhe) == edge_list (lhe))
+ obj_tail (lhe) = p;
+ if (m == mp_start_clip_node_type) {
+ p = mp_new_bounds_node (mp, NULL, mp_stop_clip_node_type);
+ } else if (m == mp_start_bounds_node_type) {
+ p = mp_new_bounds_node (mp, NULL, mp_stop_bounds_node_type);
+ }
+ mp_link (obj_tail (lhe)) = p;
+ obj_tail (lhe) = p;
+ mp_init_bbox (mp, lhe);
+ }
+ }
+}
+
+
+@ The |do_add_to| procedure is a little like |do_clip| but there are a lot more
+cases to deal with.
+
+@<Declare action procedures for use by |do_statement|@>=
+static void mp_do_add_to (MP mp);
+
+@ @c
+void mp_do_add_to (MP mp) {
+ mp_node lhv;
+ mp_edge_header_node lhe; /* variable on left, the corresponding edge structure */
+ mp_node p; /* the graphical object or list for |scan_with_list| to update */
+ mp_edge_header_node e; /* an edge structure to be merged */
+ quarterword add_type; /* |also_code|, |contour_code|, or |double_path_code| */
+ lhv = mp_start_draw_cmd (mp, mp_thing_to_add);
+ add_type = mp->last_add_type;
+ if (lhv != NULL) {
+ if (add_type == also_code) {
+ /* Make sure the current expression is a suitable picture and set |e| and |p|
+ appropriately */
+ /* Setting |p:=NULL| causes the $\langle$with list$\rangle$ to be ignored;
+ setting |e:=NULL| prevents anything from being added to |lhe|. */
+ p = NULL;
+ e = NULL;
+ if (mp->cur_exp.type != mp_picture_type) {
+ mp_value new_expr;
+ const char *hlp[]= {
+ "This expression should have specified a known picture.",
+ "So I'll not change anything just now.",
+ NULL };
+ memset(&new_expr,0,sizeof(mp_value));
+ new_number(new_expr.data.n);
+ mp_disp_err(mp, NULL);
+ set_number_to_zero (new_expr.data.n);
+ mp_back_error (mp, "Improper `addto'", hlp, true);
+ mp_get_x_next (mp);
+ mp_flush_cur_exp (mp, new_expr);
+ } else {
+ e = mp_private_edges (mp, (mp_edge_header_node)cur_exp_node ());
+ mp->cur_exp.type = mp_vacuous;
+ p = mp_link (edge_list (e));
+ }
+
+ } else {
+ /* Create a graphical object |p| based on |add_type| and the current
+ expression */
+ /* In this case |add_type<>also_code| so setting |p:=NULL| suppresses future
+ attempts to add to the edge structure. */
+ e = NULL;
+ p = NULL;
+ if (mp->cur_exp.type == mp_pair_type)
+ mp_pair_to_path (mp);
+ if (mp->cur_exp.type != mp_path_type) {
+ mp_value new_expr;
+ const char *hlp[] = {
+ "This expression should have specified a known path.",
+ "So I'll not change anything just now.",
+ NULL };
+ memset(&new_expr,0,sizeof(mp_value));
+ new_number(new_expr.data.n);
+ mp_disp_err(mp, NULL);
+ set_number_to_zero (new_expr.data.n);
+ mp_back_error (mp, "Improper `addto'", hlp, true);
+ mp_get_x_next (mp);
+ mp_flush_cur_exp (mp, new_expr);
+ } else if (add_type == contour_code) {
+ if (mp_left_type (cur_exp_knot ()) == mp_endpoint) {
+ /* Complain about a non-cycle */
+ const char *hlp[] = {
+ "That contour should have ended with `..cycle' or `&cycle'.",
+ "So I'll not change anything just now.",
+ NULL };
+ mp_back_error (mp, "Not a cycle" , hlp, true);
+ mp_get_x_next (mp);
+
+ } else {
+ p = mp_new_fill_node (mp, cur_exp_knot ());
+ mp->cur_exp.type = mp_vacuous;
+ }
+ } else {
+ p = mp_new_stroked_node (mp, cur_exp_knot ());
+ mp->cur_exp.type = mp_vacuous;
+ }
+
+ }
+ mp_scan_with_list (mp, p);
+ /* Use |p|, |e|, and |add_type| to augment |lhv| as requested */
+ lhe = mp_find_edges_var (mp, lhv);
+ if (lhe == NULL) {
+ if ((e == NULL) && (p != NULL))
+ e = mp_toss_gr_object (mp, p);
+ if (e != NULL)
+ delete_edge_ref (e);
+ } else if (add_type == also_code) {
+ if (e != NULL) {
+ /* Merge |e| into |lhe| and delete |e| */
+ if (mp_link (edge_list (e)) != NULL) {
+ mp_link (obj_tail (lhe)) = mp_link (edge_list (e));
+ obj_tail (lhe) = obj_tail (e);
+ obj_tail (e) = edge_list (e);
+ mp_link (edge_list (e)) = NULL;
+ mp_flush_dash_list (mp, lhe);
+ }
+ mp_toss_edges (mp, e);
+ }
+ } else if (p != NULL) {
+ mp_link (obj_tail (lhe)) = p;
+ obj_tail (lhe) = p;
+ if (add_type == double_path_code) {
+ if (mp_pen_p ((mp_stroked_node) p) == NULL) {
+ mp_pen_p ((mp_stroked_node) p) = mp_get_pen_circle (mp, zero_t);
+ }
+ }
+ }
+ }
+}
+
+@ @<Declare action procedures for use by |do_statement|@>=
+@<Declare the \ps\ output procedures@>;
+static void mp_do_ship_out (MP mp);
+
+@ @c
+void mp_do_ship_out (MP mp) {
+ integer c; /* the character code */
+ mp_value new_expr;
+ memset(&new_expr,0,sizeof(mp_value));
+ new_number(new_expr.data.n);
+ mp_get_x_next (mp);
+ mp_scan_expression (mp);
+ if (mp->cur_exp.type != mp_picture_type) {
+ @<Complain that it's not a known picture@>;
+ } else {
+ c = round_unscaled (internal_value (mp_char_code)) % 256;
+ if (c < 0)
+ c = c + 256;
+ @<Store the width information for character code~|c|@>;
+ mp_ship_out (mp, cur_exp_node ());
+ set_number_to_zero (new_expr.data.n);
+ mp_flush_cur_exp (mp, new_expr);
+ }
+}
+
+
+@ @<Complain that it's not a known picture@>=
+{
+ const char *hlp[] = { "I can only output known pictures.", NULL };
+ mp_disp_err(mp, NULL);
+ set_number_to_zero (new_expr.data.n);
+ mp_back_error (mp, "Not a known picture", hlp, true);
+ mp_get_x_next (mp);
+ mp_flush_cur_exp (mp, new_expr);
+}
+
+
+@ The \&{everyjob} command simply assigns a nonzero value to the global variable
+|start_sym|.
+
+
+@ @<Glob...@>=
+mp_sym start_sym; /* a symbolic token to insert at beginning of job */
+
+@ @<Set init...@>=
+mp->start_sym = NULL;
+
+@ Finally, we have only the ``message'' commands remaining.
+
+@d message_code 0
+@d err_message_code 1
+@d err_help_code 2
+@d filename_template_code 3
+@d print_with_leading_zeroes(A,B) do {
+ size_t g = mp->cur_length;
+ size_t f = (size_t)(B);
+ mp_print_int(mp, (A));
+ g = mp->cur_length - g;
+ if ( f>g ) {
+ mp->cur_length = mp->cur_length - g;
+ while ( f>g ) {
+ mp_print_char(mp, xord('0'));
+ decr(f);
+ };
+ mp_print_int(mp, (A));
+ };
+ f = 0;
+ } while (0)
+
+@<Put each...@>=
+mp_primitive (mp, "message", mp_message_command, message_code);
+@:message_}{\&{message} primitive@>;
+mp_primitive (mp, "errmessage", mp_message_command, err_message_code);
+@:err_message_}{\&{errmessage} primitive@>;
+mp_primitive (mp, "errhelp", mp_message_command, err_help_code);
+@:err_help_}{\&{errhelp} primitive@>;
+mp_primitive (mp, "filenametemplate", mp_message_command, filename_template_code);
+@:filename_template_}{\&{filenametemplate} primitive@>
+
+
+@ @<Cases of |print_cmd...@>=
+case mp_message_command:
+if (m < err_message_code)
+ mp_print (mp, "message");
+else if (m == err_message_code)
+ mp_print (mp, "errmessage");
+else if (m == filename_template_code)
+ mp_print (mp, "filenametemplate");
+else
+ mp_print (mp, "errhelp");
+break;
+
+@ @<Declare action procedures for use by |do_statement|@>=
+@<Declare a procedure called |no_string_err|@>;
+static void mp_do_message (MP mp);
+
+@
+@c
+void mp_do_message (MP mp) {
+ int m; /* the type of message */
+ mp_value new_expr;
+ m = cur_mod();
+ memset(&new_expr,0,sizeof(mp_value));
+ new_number(new_expr.data.n);
+ mp_get_x_next (mp);
+ mp_scan_expression (mp);
+ if (mp->cur_exp.type != mp_string_type)
+ mp_no_string_err (mp, "A message should be a known string expression.");
+ else {
+ switch (m) {
+ case message_code:
+ mp_print_nl (mp, "");
+ mp_print_str (mp, cur_exp_str ());
+ break;
+ case err_message_code:
+ @<Print string |cur_exp| as an error message@>;
+ break;
+ case err_help_code:
+ @<Save string |cur_exp| as the |err_help|@>;
+ break;
+ case filename_template_code:
+ @<Save the filename template@>;
+ break;
+ } /* there are no other cases */
+ }
+ set_number_to_zero (new_expr.data.n);
+ mp_flush_cur_exp (mp, new_expr);
+}
+
+
+@ @<Save the filename template@>=
+{
+ delete_str_ref (internal_string (mp_output_template));
+ if (cur_exp_str ()->len == 0) {
+ set_internal_string (mp_output_template, mp_rts (mp, "%j.%c"));
+ } else {
+ set_internal_string (mp_output_template, cur_exp_str ());
+ add_str_ref (internal_string (mp_output_template));
+ }
+}
+
+
+@ @<Declare a procedure called |no_string_err|@>=
+static void mp_no_string_err (MP mp, const char *s) {
+ const char *hlp[] = {s, NULL};
+ mp_disp_err(mp, NULL);
+ mp_back_error (mp, "Not a string", hlp, true);
+@.Not a string@>;
+ mp_get_x_next (mp);
+}
+
+
+@ The global variable |err_help| is zero when the user has most recently
+given an empty help string, or if none has ever been given.
+
+@<Save string |cur_exp| as the |err_help|@>=
+{
+ if (mp->err_help != NULL)
+ delete_str_ref (mp->err_help);
+ if (cur_exp_str ()->len == 0)
+ mp->err_help = NULL;
+ else {
+ mp->err_help = cur_exp_str ();
+ add_str_ref (mp->err_help);
+ }
+}
+
+
+@ If \&{errmessage} occurs often in |mp_scroll_mode|, without user-defined
+\&{errhelp}, we don't want to give a long help message each time. So we
+give a verbose explanation only once.
+
+@<Glob...@>=
+boolean long_help_seen; /* has the long \.{\\errmessage} help been used? */
+
+@ @<Set init...@>=
+mp->long_help_seen = false;
+
+@ @<Print string |cur_exp| as an error message@>=
+{
+ char msg[256];
+ mp_snprintf(msg, 256, "%s", mp_str(mp, cur_exp_str ()));
+ if (mp->err_help != NULL) {
+ mp->use_err_help = true;
+ mp_back_error (mp, msg, NULL, true);
+ } else if (mp->long_help_seen) {
+ const char *hlp[] = { "(That was another `errmessage'.)", NULL };
+ mp_back_error (mp, msg, hlp, true);
+ } else {
+ const char *hlp[] = {
+ "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,",
+ "and deduce the truth by inspired guesses.",
+ NULL };
+@^Marple, Jane@>
+ if (mp->interaction < mp_error_stop_mode)
+ mp->long_help_seen = true;
+ mp_back_error (mp, msg, hlp, true);
+ }
+ mp_get_x_next (mp);
+ mp->use_err_help = false;
+}
+
+
+@ @<Declare action procedures for use by |do_statement|@>=
+static void mp_do_write (MP mp);
+
+@ @c
+void mp_do_write (MP mp) {
+ mp_string t; /* the line of text to be written */
+ write_index n, n0; /* for searching |wr_fname| and |wr_file| arrays */
+ unsigned old_setting; /* for saving |selector| during output */
+ mp_value new_expr;
+ memset(&new_expr,0,sizeof(mp_value));
+ new_number(new_expr.data.n);
+ mp_get_x_next (mp);
+ mp_scan_expression (mp);
+ if (mp->cur_exp.type != mp_string_type) {
+ mp_no_string_err (mp,
+ "The text to be written should be a known string expression");
+ } else if (cur_cmd() != mp_to_token) {
+ const char *hlp[] = { "A write command should end with `to <filename>'", NULL };
+ mp_back_error (mp, "Missing `to' clause", hlp, true);
+ mp_get_x_next (mp);
+ } else {
+ t = cur_exp_str ();
+ mp->cur_exp.type = mp_vacuous;
+ mp_get_x_next (mp);
+ mp_scan_expression (mp);
+ if (mp->cur_exp.type != mp_string_type)
+ mp_no_string_err (mp,
+ "I can\'t write to that file name. It isn't a known string");
+ else {
+ @<Write |t| to the file named by |cur_exp|@>;
+ }
+ /* |delete_str_ref(t);| *//* todo: is this right? */
+ }
+ set_number_to_zero (new_expr.data.n);
+ mp_flush_cur_exp (mp, new_expr);
+}
+
+
+@ @<Write |t| to the file named by |cur_exp|@>=
+{
+ @<Find |n| where |wr_fname[n]=cur_exp| and call |open_write_file| if
+ |cur_exp| must be inserted@>;
+ if (mp_str_vs_str (mp, t, mp->eof_line) == 0) {
+ @<Record the end of file on |wr_file[n]|@>;
+ } else {
+ old_setting = mp->selector;
+ mp->selector = n + write_file;
+ mp_print_str (mp, t);
+ mp_print_ln (mp);
+ mp->selector = old_setting;
+ }
+}
+
+
+@ @<Find |n| where |wr_fname[n]=cur_exp| and call |open_write_file| if...@>=
+{
+ char *fn = mp_str (mp, cur_exp_str ());
+ n = mp->write_files;
+ n0 = mp->write_files;
+ while (mp_xstrcmp (fn, mp->wr_fname[n]) != 0) {
+ if (n == 0) { /* bottom reached */
+ if (n0 == mp->write_files) {
+ if (mp->write_files < mp->max_write_files) {
+ incr (mp->write_files);
+ } else {
+ void **wr_file;
+ char **wr_fname;
+ write_index l, k;
+ l = mp->max_write_files + (mp->max_write_files / 4);
+ wr_file = xmalloc ((l + 1), sizeof (void *));
+ wr_fname = xmalloc ((l + 1), sizeof (char *));
+ for (k = 0; k <= l; k++) {
+ if (k <= mp->max_write_files) {
+ wr_file[k] = mp->wr_file[k];
+ wr_fname[k] = mp->wr_fname[k];
+ } else {
+ wr_file[k] = 0;
+ wr_fname[k] = NULL;
+ }
+ }
+ xfree (mp->wr_file);
+ xfree (mp->wr_fname);
+ mp->max_write_files = l;
+ mp->wr_file = wr_file;
+ mp->wr_fname = wr_fname;
+ }
+ }
+ n = n0;
+ mp_open_write_file (mp, fn, n);
+ } else {
+ decr (n);
+ if (mp->wr_fname[n] == NULL)
+ n0 = n;
+ }
+ }
+}
+
+
+@ @<Record the end of file on |wr_file[n]|@>=
+{
+ (mp->close_file) (mp, mp->wr_file[n]);
+ xfree (mp->wr_fname[n]);
+ if (n == mp->write_files - 1)
+ mp->write_files = n;
+}
+
+
+@* Writing font metric data.
+\TeX\ gets its knowledge about fonts from font metric files, also called
+\.{TFM} files; the `\.T' in `\.{TFM}' stands for \TeX,
+but other programs know about them too. One of \MP's duties is to
+write \.{TFM} files so that the user's fonts can readily be
+applied to typesetting.
+@:TFM files}{\.{TFM} files@>
+@^font metric files@>
+
+The information in a \.{TFM} file appears in a sequence of 8-bit bytes.
+Since the number of bytes is always a multiple of~4, we could
+also regard the file as a sequence of 32-bit words, but \MP\ uses the
+byte interpretation. The format of \.{TFM} files was designed by
+Lyle Ramshaw in 1980. The intent is to convey a lot of different kinds
+@^Ramshaw, Lyle Harold@>
+of information in a compact but useful form.
+
+@<Glob...@>=
+void *tfm_file; /* the font metric output goes here */
+char *metric_file_name; /* full name of the font metric file */
+
+@ The first 24 bytes (6 words) of a \.{TFM} file contain twelve 16-bit
+integers that give the lengths of the various subsequent portions
+of the file. These twelve integers are, in order:
+$$\vbox{\halign{\hfil#&$\null=\null$#\hfil\cr
+|lf|&length of the entire file, in words;\cr
+|lh|&length of the header data, in words;\cr
+|bc|&smallest character code in the font;\cr
+|ec|&largest character code in the font;\cr
+|nw|&number of words in the width table;\cr
+|nh|&number of words in the height table;\cr
+|nd|&number of words in the depth table;\cr
+|ni|&number of words in the italic correction table;\cr
+|nl|&number of words in the lig/kern table;\cr
+|nk|&number of words in the kern table;\cr
+|ne|&number of words in the extensible character table;\cr
+|np|&number of font parameter words.\cr}}$$
+They are all nonnegative and less than $2^{15}$. We must have |bc-1<=ec<=255|,
+|ne<=256|, and
+$$\hbox{|lf=6+lh+(ec-bc+1)+nw+nh+nd+ni+nl+nk+ne+np|.}$$
+Note that a font may contain as many as 256 characters (if |bc=0| and |ec=255|),
+and as few as 0 characters (if |bc=ec+1|).
+
+Incidentally, when two or more 8-bit bytes are combined to form an integer of
+16 or more bits, the most significant bytes appear first in the file.
+This is called BigEndian order.
+@^BigEndian order@>
+
+@ The rest of the \.{TFM} file may be regarded as a sequence of ten data
+arrays.
+
+The most important data type used here is a |fix_word|, which is
+a 32-bit representation of a binary fraction. A |fix_word| is a signed
+quantity, with the two's complement of the entire word used to represent
+negation. Of the 32 bits in a |fix_word|, exactly 12 are to the left of the
+binary point; thus, the largest |fix_word| value is $2048-2^{-20}$, and
+the smallest is $-2048$. We will see below, however, that all but two of
+the |fix_word| values must lie between $-16$ and $+16$.
+
+@ The first data array is a block of header information, which contains
+general facts about the font. The header must contain at least two words,
+|header[0]| and |header[1]|, whose meaning is explained below. Additional
+header information of use to other software routines might also be
+included, and \MP\ will generate it if the \.{headerbyte} command occurs.
+For example, 16 more words of header information are in use at the Xerox
+Palo Alto Research Center; the first ten specify the character coding
+scheme used (e.g., `\.{XEROX TEXT}' or `\.{TEX MATHSY}'), the next five
+give the font family name (e.g., `\.{HELVETICA}' or `\.{CMSY}'), and the
+last gives the ``face byte.''
+
+\yskip\hang|header[0]| is a 32-bit check sum that \MP\ will copy into
+the \.{GF} output file. This helps ensure consistency between files,
+since \TeX\ records the check sums from the \.{TFM}'s it reads, and these
+should match the check sums on actual fonts that are used. The actual
+relation between this check sum and the rest of the \.{TFM} file is not
+important; the check sum is simply an identification number with the
+property that incompatible fonts almost always have distinct check sums.
+@^check sum@>
+
+\yskip\hang|header[1]| is a |fix_word| containing the design size of the
+font, in units of \TeX\ points. This number must be at least 1.0; it is
+fairly arbitrary, but usually the design size is 10.0 for a ``10 point''
+font, i.e., a font that was designed to look best at a 10-point size,
+whatever that really means. When a \TeX\ user asks for a font `\.{at}
+$\delta$ \.{pt}', the effect is to override the design size and replace it
+by $\delta$, and to multiply the $x$ and~$y$ coordinates of the points in
+the font image by a factor of $\delta$ divided by the design size. {\sl
+All other dimensions in the\/ \.{TFM} file are |fix_word|\kern-1pt\
+numbers in design-size units.} Thus, for example, the value of |param[6]|,
+which defines the \.{em} unit, is often the |fix_word| value $2^{20}=1.0$,
+since many fonts have a design size equal to one em. The other dimensions
+must be less than 16 design-size units in absolute value; thus,
+|header[1]| and |param[1]| are the only |fix_word| entries in the whole
+\.{TFM} file whose first byte might be something besides 0 or 255.
+@^design size@>
+
+@ Next comes the |char_info| array, which contains one |char_info_word|
+per character. Each word in this part of the file contains six fields
+packed into four bytes as follows.
+
+\yskip\hang first byte: |width_index| (8 bits)\par
+\hang second byte: |height_index| (4 bits) times 16, plus |depth_index|
+ (4~bits)\par
+\hang third byte: |italic_index| (6 bits) times 4, plus |tag|
+ (2~bits)\par
+\hang fourth byte: |remainder| (8 bits)\par
+\yskip\noindent
+The actual width of a character is \\{width}|[width_index]|, in design-size
+units; this is a device for compressing information, since many characters
+have the same width. Since it is quite common for many characters
+to have the same height, depth, or italic correction, the \.{TFM} format
+imposes a limit of 16 different heights, 16 different depths, and
+64 different italic corrections.
+
+Incidentally, the relation $\\{width}[0]=\\{height}[0]=\\{depth}[0]=
+\\{italic}[0]=0$ should always hold, so that an index of zero implies a
+value of zero. The |width_index| should never be zero unless the
+character does not exist in the font, since a character is valid if and
+only if it lies between |bc| and |ec| and has a nonzero |width_index|.
+
+@ The |tag| field in a |char_info_word| has four values that explain how to
+interpret the |remainder| field.
+
+\yskip\hang|tag=0| (|no_tag|) means that |remainder| is unused.\par
+\hang|tag=1| (|lig_tag|) means that this character has a ligature/kerning
+program starting at location |remainder| in the |lig_kern| array.\par
+\hang|tag=2| (|list_tag|) means that this character is part of a chain of
+characters of ascending sizes, and not the largest in the chain. The
+|remainder| field gives the character code of the next larger character.\par
+\hang|tag=3| (|ext_tag|) means that this character code represents an
+extensible character, i.e., a character that is built up of smaller pieces
+so that it can be made arbitrarily large. The pieces are specified in
+|exten[remainder]|.\par
+\yskip\noindent
+Characters with |tag=2| and |tag=3| are treated as characters with |tag=0|
+unless they are used in special circumstances in math formulas. For example,
+\TeX's \.{\\sum} operation looks for a |list_tag|, and the \.{\\left}
+operation looks for both |list_tag| and |ext_tag|.
+
+@d no_tag 0 /* vanilla character */
+@d lig_tag 1 /* character has a ligature/kerning program */
+@d list_tag 2 /* character has a successor in a charlist */
+@d ext_tag 3 /* character is extensible */
+
+@ The |lig_kern| array contains instructions in a simple programming language
+that explains what to do for special letter pairs. Each word in this array is a
+|lig_kern_command| of four bytes.
+
+\yskip\hang first byte: |skip_byte|, indicates that this is the final program
+ step if the byte is 128 or more, otherwise the next step is obtained by
+ skipping this number of intervening steps.\par
+\hang second byte: |next_char|, ``if |next_char| follows the current character,
+ then perform the operation and stop, otherwise continue.''\par
+\hang third byte: |op_byte|, indicates a ligature step if less than~128,
+ a kern step otherwise.\par
+\hang fourth byte: |remainder|.\par
+\yskip\noindent
+In a kern step, an
+additional space equal to |kern[256*(op_byte-128)+remainder]| is inserted
+between the current character and |next_char|. This amount is
+often negative, so that the characters are brought closer together
+by kerning; but it might be positive.
+
+There are eight kinds of ligature steps, having |op_byte| codes $4a+2b+c$ where
+$0\le a\le b+c$ and $0\le b,c\le1$. The character whose code is
+|remainder| is inserted between the current character and |next_char|;
+then the current character is deleted if $b=0$, and |next_char| is
+deleted if $c=0$; then we pass over $a$~characters to reach the next
+current character (which may have a ligature/kerning program of its own).
+
+If the very first instruction of the |lig_kern| array has |skip_byte=255|,
+the |next_char| byte is the so-called right boundary character of this font;
+the value of |next_char| need not lie between |bc| and~|ec|.
+If the very last instruction of the |lig_kern| array has |skip_byte=255|,
+there is a special ligature/kerning program for a left boundary character,
+beginning at location |256*op_byte+remainder|.
+The interpretation is that \TeX\ puts implicit boundary characters
+before and after each consecutive string of characters from the same font.
+These implicit characters do not appear in the output, but they can affect
+ligatures and kerning.
+
+If the very first instruction of a character's |lig_kern| program has
+|skip_byte>128|, the program actually begins in location
+|256*op_byte+remainder|. This feature allows access to large |lig_kern|
+arrays, because the first instruction must otherwise
+appear in a location |<=255|.
+
+Any instruction with |skip_byte>128| in the |lig_kern| array must satisfy
+the condition
+$$\hbox{|256*op_byte+remainder<nl|.}$$
+If such an instruction is encountered during
+normal program execution, it denotes an unconditional halt; no ligature
+command is performed.
+
+@d stop_flag (128)
+ /* value indicating `\.{STOP}' in a lig/kern program */
+@d kern_flag (128) /* op code for a kern step */
+@d skip_byte(A) mp->lig_kern[(A)].b0
+@d next_char(A) mp->lig_kern[(A)].b1
+@d op_byte(A) mp->lig_kern[(A)].b2
+@d rem_byte(A) mp->lig_kern[(A)].b3
+
+@ Extensible characters are specified by an |extensible_recipe|, which
+consists of four bytes called |top|, |mid|, |bot|, and |rep| (in this
+order). These bytes are the character codes of individual pieces used to
+build up a large symbol. If |top|, |mid|, or |bot| are zero, they are not
+present in the built-up result. For example, an extensible vertical line is
+like an extensible bracket, except that the top and bottom pieces are missing.
+
+Let $T$, $M$, $B$, and $R$ denote the respective pieces, or an empty box
+if the piece isn't present. Then the extensible characters have the form
+$TR^kMR^kB$ from top to bottom, for some |k>=0|, unless $M$ is absent;
+in the latter case we can have $TR^kB$ for both even and odd values of~|k|.
+The width of the extensible character is the width of $R$; and the
+height-plus-depth is the sum of the individual height-plus-depths of the
+components used, since the pieces are butted together in a vertical list.
+
+@d ext_top(A) mp->exten[(A)].b0 /* |top| piece in a recipe */
+@d ext_mid(A) mp->exten[(A)].b1 /* |mid| piece in a recipe */
+@d ext_bot(A) mp->exten[(A)].b2 /* |bot| piece in a recipe */
+@d ext_rep(A) mp->exten[(A)].b3 /* |rep| piece in a recipe */
+
+@ The final portion of a \.{TFM} file is the |param| array, which is another
+sequence of |fix_word| values.
+
+\yskip\hang|param[1]=slant| is the amount of italic slant, which is used
+to help position accents. For example, |slant=.25| means that when you go
+up one unit, you also go .25 units to the right. The |slant| is a pure
+number; it is the only |fix_word| other than the design size itself that is
+not scaled by the design size.
+@^design size@>
+
+\hang|param[2]=space| is the normal spacing between words in text.
+Note that character 040 in the font need not have anything to do with
+blank spaces.
+
+\hang|param[3]=space_stretch| is the amount of glue stretching between words.
+
+\hang|param[4]=space_shrink| is the amount of glue shrinking between words.
+
+\hang|param[5]=x_height| is the size of one ex in the font; it is also
+the height of letters for which accents don't have to be raised or lowered.
+
+\hang|param[6]=quad| is the size of one em in the font.
+
+\hang|param[7]=extra_space| is the amount added to |param[2]| at the
+ends of sentences.
+
+\yskip\noindent
+If fewer than seven parameters are present, \TeX\ sets the missing parameters
+to zero.
+
+@d slant_code 1
+@d space_code 2
+@d space_stretch_code 3
+@d space_shrink_code 4
+@d x_height_code 5
+@d quad_code 6
+@d extra_space_code 7
+
+@ So that is what \.{TFM} files hold. One of \MP's duties is to output such
+information, and it does this all at once at the end of a job.
+In order to prepare for such frenetic activity, it squirrels away the
+necessary facts in various arrays as information becomes available.
+
+Character dimensions (\&{charwd}, \&{charht}, \&{chardp}, and \&{charic})
+are stored respectively in |tfm_width|, |tfm_height|, |tfm_depth|, and
+|tfm_ital_corr|. Other information about a character (e.g., about
+its ligatures or successors) is accessible via the |char_tag| and
+|char_remainder| arrays. Other information about the font as a whole
+is kept in additional arrays called |header_byte|, |lig_kern|,
+|kern|, |exten|, and |param|.
+
+@d max_tfm_int 32510
+@d undefined_label max_tfm_int /* an undefined local label */
+
+@<Glob...@>=
+#define TFM_ITEMS 257
+eight_bits bc;
+eight_bits ec; /* smallest and largest character codes shipped out */
+mp_node tfm_width[TFM_ITEMS]; /* \&{charwd} values */
+mp_node tfm_height[TFM_ITEMS]; /* \&{charht} values */
+mp_node tfm_depth[TFM_ITEMS]; /* \&{chardp} values */
+mp_node tfm_ital_corr[TFM_ITEMS]; /* \&{charic} values */
+boolean char_exists[TFM_ITEMS]; /* has this code been shipped out? */
+int char_tag[TFM_ITEMS]; /* |remainder| category */
+int char_remainder[TFM_ITEMS]; /* the |remainder| byte */
+char *header_byte; /* bytes of the \.{TFM} header */
+int header_last; /* last initialized \.{TFM} header byte */
+int header_size; /* size of the \.{TFM} header */
+four_quarters *lig_kern; /* the ligature/kern table */
+short nl; /* the number of ligature/kern steps so far */
+mp_number *kern; /* distinct kerning amounts */
+short nk; /* the number of distinct kerns so far */
+four_quarters exten[TFM_ITEMS]; /* extensible character recipes */
+short ne; /* the number of extensible characters so far */
+mp_number *param; /* \&{fontinfo} parameters */
+short np; /* the largest \&{fontinfo} parameter specified so far */
+short nw;
+short nh;
+short nd;
+short ni; /* sizes of \.{TFM} subtables */
+short skip_table[TFM_ITEMS]; /* local label status */
+boolean lk_started; /* has there been a lig/kern step in this command yet? */
+integer bchar; /* right boundary character */
+short bch_label; /* left boundary starting location */
+short ll;
+short lll; /* registers used for lig/kern processing */
+short label_loc[257]; /* lig/kern starting addresses */
+eight_bits label_char[257]; /* characters for |label_loc| */
+short label_ptr; /* highest position occupied in |label_loc| */
+
+@ @<Allocate or initialize ...@>=
+mp->header_last = 7;
+mp->header_size = 128; /* just for init */
+mp->header_byte = xmalloc (mp->header_size, sizeof (char));
+
+@ @<Dealloc variables@>=
+xfree (mp->header_byte);
+xfree (mp->lig_kern);
+if (mp->kern) {
+ int i;
+ for (i=0;i<(max_tfm_int + 1);i++) {
+ free_number(mp->kern[i]);
+ }
+ xfree (mp->kern);
+}
+if (mp->param) {
+ int i;
+ for (i=0;i<(max_tfm_int + 1);i++) {
+ free_number(mp->param[i]);
+ }
+ xfree (mp->param);
+}
+
+@ @<Set init...@>=
+for (k = 0; k <= 255; k++) {
+ mp->tfm_width[k] = 0;
+ mp->tfm_height[k] = 0;
+ mp->tfm_depth[k] = 0;
+ mp->tfm_ital_corr[k] = 0;
+ mp->char_exists[k] = false;
+ mp->char_tag[k] = no_tag;
+ mp->char_remainder[k] = 0;
+ mp->skip_table[k] = undefined_label;
+}
+memset (mp->header_byte, 0, (size_t) mp->header_size);
+mp->bc = 255;
+mp->ec = 0;
+mp->nl = 0;
+mp->nk = 0;
+mp->ne = 0;
+mp->np = 0;
+set_internal_from_number (mp_boundary_char, unity_t);
+number_negate (internal_value (mp_boundary_char));
+mp->bch_label = undefined_label;
+mp->label_loc[0] = -1;
+mp->label_ptr = 0;
+
+@ @<Declarations@>=
+static mp_node mp_tfm_check (MP mp, quarterword m);
+
+@ @c
+static mp_node mp_tfm_check (MP mp, quarterword m) {
+ mp_number absm;
+ mp_node p = mp_get_value_node (mp);
+ new_number (absm);
+ number_clone (absm, internal_value (m));
+ number_abs (absm);
+ if (number_greaterequal (absm, fraction_half_t)) {
+ char msg[256];
+ const char *hlp[] = {
+ "Font metric dimensions must be less than 2048pt.",
+ NULL } ;
+ mp_snprintf (msg, 256, "Enormous %s has been reduced", internal_name (m));
+@.Enormous charwd...@>
+@.Enormous chardp...@>
+@.Enormous charht...@>
+@.Enormous charic...@>
+@.Enormous designsize...@>;
+ mp_back_error (mp, msg, hlp, true);
+ mp_get_x_next (mp);
+ if (number_positive (internal_value (m))) {
+ set_value_number (p, fraction_half_t);
+ number_add_scaled (value_number (p), -1);
+ } else {
+ set_value_number (p, fraction_half_t);
+ number_negate (value_number (p));
+ number_add_scaled (value_number (p), 1);
+ }
+ } else {
+ set_value_number (p, internal_value (m));
+ }
+ free_number (absm);
+ return p;
+}
+
+@ @<Store the width information for character code~|c|@>=
+if (c < mp->bc)
+ mp->bc = (eight_bits) c;
+if (c > mp->ec)
+ mp->ec = (eight_bits) c;
+mp->char_exists[c] = true;
+mp_free_value_node (mp, mp->tfm_width[c]);
+mp->tfm_width[c] = mp_tfm_check (mp, mp_char_wd);
+mp_free_value_node (mp, mp->tfm_height[c]);
+mp->tfm_height[c] = mp_tfm_check (mp, mp_char_ht);
+mp_free_value_node (mp, mp->tfm_depth[c]);
+mp->tfm_depth[c] = mp_tfm_check (mp, mp_char_dp);
+mp_free_value_node (mp, mp->tfm_ital_corr[c]);
+mp->tfm_ital_corr[c] = mp_tfm_check (mp, mp_char_ic)
+
+
+@ Now let's consider \MP's special \.{TFM}-oriented commands.
+
+
+@ @d char_list_code 0
+@d lig_table_code 1
+@d extensible_code 2
+@d header_byte_code 3
+@d font_dimen_code 4
+
+@<Put each...@>=
+mp_primitive (mp, "charlist", mp_tfm_command, char_list_code);
+@:char_list_}{\&{charlist} primitive@>;
+mp_primitive (mp, "ligtable", mp_tfm_command, lig_table_code);
+@:lig_table_}{\&{ligtable} primitive@>;
+mp_primitive (mp, "extensible", mp_tfm_command, extensible_code);
+@:extensible_}{\&{extensible} primitive@>;
+mp_primitive (mp, "headerbyte", mp_tfm_command, header_byte_code);
+@:header_byte_}{\&{headerbyte} primitive@>;
+mp_primitive (mp, "fontdimen", mp_tfm_command, font_dimen_code);
+@:font_dimen_}{\&{fontdimen} primitive@>
+
+
+@ @<Cases of |print_cmd...@>=
+case mp_tfm_command:
+switch (m) {
+case char_list_code:
+ mp_print (mp, "charlist");
+ break;
+case lig_table_code:
+ mp_print (mp, "ligtable");
+ break;
+case extensible_code:
+ mp_print (mp, "extensible");
+ break;
+case header_byte_code:
+ mp_print (mp, "headerbyte");
+ break;
+default:
+ mp_print (mp, "fontdimen");
+ break;
+}
+break;
+
+@ @<Declare action procedures for use by |do_statement|@>=
+static eight_bits mp_get_code (MP mp);
+
+@ @c
+eight_bits mp_get_code (MP mp) { /* scans a character code value */
+ integer c; /* the code value found */
+ mp_value new_expr;
+ const char *hlp[] = {
+ "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.",
+ NULL };
+ memset(&new_expr,0,sizeof(mp_value));
+ new_number(new_expr.data.n);
+ mp_get_x_next (mp);
+ mp_scan_expression (mp);
+ if (mp->cur_exp.type == mp_known) {
+ c = round_unscaled (cur_exp_value_number ());
+ if (c >= 0)
+ if (c < 256)
+ return (eight_bits) c;
+ } else if (mp->cur_exp.type == mp_string_type) {
+ if (cur_exp_str ()->len == 1) {
+ c = (integer) (*(cur_exp_str ()->str));
+ return (eight_bits) c;
+ }
+ }
+ mp_disp_err(mp, NULL);
+ set_number_to_zero (new_expr.data.n);
+ mp_back_error (mp, "Invalid code has been replaced by 0", hlp, true);
+@.Invalid code...@>;
+ mp_get_x_next (mp);
+ mp_flush_cur_exp (mp, new_expr);
+ c = 0;
+ return (eight_bits) c;
+}
+
+
+@ @<Declare action procedures for use by |do_statement|@>=
+static void mp_set_tag (MP mp, halfword c, quarterword t, halfword r);
+
+@ @c
+void mp_set_tag (MP mp, halfword c, quarterword t, halfword r) {
+ if (mp->char_tag[c] == no_tag) {
+ mp->char_tag[c] = t;
+ mp->char_remainder[c] = r;
+ if (t == lig_tag) {
+ mp->label_ptr++;
+ mp->label_loc[mp->label_ptr] = (short) r;
+ mp->label_char[mp->label_ptr] = (eight_bits) c;
+ }
+ } else {
+ @<Complain about a character tag conflict@>;
+ }
+}
+
+
+@ @<Complain about a character tag conflict@>=
+{
+ const char *xtra = NULL;
+ char msg[256];
+ const char *hlp[] = {
+ "It's not legal to label a character more than once.",
+ "So I'll not change anything just now.",
+ NULL };
+ switch (mp->char_tag[c]) {
+ case lig_tag: xtra = "in a ligtable"; break;
+ case list_tag: xtra = "in a charlist"; break;
+ case ext_tag: xtra = "extensible"; break;
+ default: xtra = ""; break;
+ }
+ if ((c > ' ') && (c < 127)) {
+ mp_snprintf(msg, 256, "Character %c is already %s", xord(c), xtra);
+ } else if (c == 256) {
+ mp_snprintf(msg, 256, "Character || is already %s", xtra);
+ } else {
+ mp_snprintf(msg, 256, "Character code %d is already %s", c, xtra);
+ }
+@.Character c is already...@>;
+ mp_back_error (mp, msg, hlp, true);
+ mp_get_x_next (mp);
+}
+
+
+@ @<Declare action procedures for use by |do_statement|@>=
+static void mp_do_tfm_command (MP mp);
+
+@ @c
+void mp_do_tfm_command (MP mp) {
+ int c, cc; /* character codes */
+ int k; /* index into the |kern| array */
+ int j; /* index into |header_byte| or |param| */
+ mp_value new_expr;
+ memset(&new_expr,0,sizeof(mp_value));
+ new_number(new_expr.data.n);
+ switch (cur_mod()) {
+ case char_list_code:
+ c = mp_get_code (mp);
+ /* we will store a list of character successors */
+ while (cur_cmd() == mp_colon) {
+ cc = mp_get_code (mp);
+ mp_set_tag (mp, c, list_tag, cc);
+ c = cc;
+ };
+ break;
+ case lig_table_code:
+ if (mp->lig_kern == NULL)
+ mp->lig_kern = xmalloc ((max_tfm_int + 1), sizeof (four_quarters));
+ if (mp->kern == NULL) {
+ int i;
+ mp->kern = xmalloc ((max_tfm_int + 1), sizeof (mp_number));
+ for (i=0;i<(max_tfm_int + 1);i++)
+ new_number (mp->kern[i]);
+ }
+ @<Store a list of ligature/kern steps@>;
+ break;
+ case extensible_code:
+ @<Define an extensible recipe@>;
+ break;
+ case header_byte_code:
+ case font_dimen_code:
+ c = cur_mod();
+ mp_get_x_next (mp);
+ mp_scan_expression (mp);
+ if ((mp->cur_exp.type != mp_known) || number_less(cur_exp_value_number (), half_unit_t)) {
+ const char *hlp[] = {
+ "I was looking for a known, positive number.",
+ "For safety's sake I'll ignore the present command.",
+ NULL };
+ mp_disp_err(mp, NULL);
+ mp_back_error (mp, "Improper location", hlp, true);
+@.Improper location@>;
+ mp_get_x_next (mp);
+ } else {
+ j = round_unscaled (cur_exp_value_number ());
+ if (cur_cmd() != mp_colon) {
+ const char *hlp[] = {
+ "A colon should follow a headerbyte or fontinfo location.",
+ NULL };
+ mp_back_error (mp, "Missing `:' has been inserted", hlp, true);
+@.Missing `:'@>;
+ }
+ if (c == header_byte_code) {
+ @<Store a list of header bytes@>;
+ } else {
+ if (mp->param == NULL) {
+ int i;
+ mp->param = xmalloc ((max_tfm_int + 1), sizeof (mp_number));
+ for (i=0;i<(max_tfm_int + 1);i++)
+ new_number (mp->param[i]);
+ }
+ @<Store a list of font dimensions@>;
+ }
+ }
+ break;
+ } /* there are no other cases */
+}
+
+
+@ @<Store a list of ligature/kern steps@>=
+{
+ mp->lk_started = false;
+CONTINUE:
+ mp_get_x_next (mp);
+ if ((cur_cmd() == mp_skip_to) && mp->lk_started)
+ @<Process a |skip_to| command and |goto done|@>;
+ if (cur_cmd() == mp_bchar_label) {
+ c = 256;
+ set_cur_cmd((mp_variable_type)mp_colon);
+ } else {
+ mp_back_input (mp);
+ c = mp_get_code (mp);
+ };
+ if ((cur_cmd() == mp_colon) || (cur_cmd() == mp_double_colon)) {
+ @<Record a label in a lig/kern subprogram and |goto continue|@>;
+ }
+ if (cur_cmd() == mp_lig_kern_token) {
+ @<Compile a ligature/kern command@>;
+ } else {
+ const char *hlp[] = { "I was looking for `=:' or `kern' here.", NULL };
+ mp_back_error (mp, "Illegal ligtable step", hlp, true);
+@.Illegal ligtable step@>;
+ next_char (mp->nl) = qi (0);
+ op_byte (mp->nl) = qi (0);
+ rem_byte (mp->nl) = qi (0);
+ skip_byte (mp->nl) = stop_flag + 1; /* this specifies an unconditional stop */
+ }
+ if (mp->nl == max_tfm_int)
+ mp_fatal_error (mp, "ligtable too large");
+ mp->nl++;
+ if (cur_cmd() == mp_comma)
+ goto CONTINUE;
+ if (skip_byte (mp->nl - 1) < stop_flag)
+ skip_byte (mp->nl - 1) = stop_flag;
+}
+DONE:
+
+@ @<Put each...@>=
+mp_primitive (mp, "=:", mp_lig_kern_token, 0);
+@:=:_}{\.{=:} primitive@>;
+mp_primitive (mp, "=:|", mp_lig_kern_token, 1);
+@:=:/_}{\.{=:\char'174} primitive@>;
+mp_primitive (mp, "=:|>", mp_lig_kern_token, 5);
+@:=:/>_}{\.{=:\char'174>} primitive@>;
+mp_primitive (mp, "|=:", mp_lig_kern_token, 2);
+@:=:/_}{\.{\char'174=:} primitive@>;
+mp_primitive (mp, "|=:>", mp_lig_kern_token, 6);
+@:=:/>_}{\.{\char'174=:>} primitive@>;
+mp_primitive (mp, "|=:|", mp_lig_kern_token, 3);
+@:=:/_}{\.{\char'174=:\char'174} primitive@>;
+mp_primitive (mp, "|=:|>", mp_lig_kern_token, 7);
+@:=:/>_}{\.{\char'174=:\char'174>} primitive@>;
+mp_primitive (mp, "|=:|>>", mp_lig_kern_token, 11);
+@:=:/>_}{\.{\char'174=:\char'174>>} primitive@>;
+mp_primitive (mp, "kern", mp_lig_kern_token, mp_kern_flag);
+@:kern_}{\&{kern} primitive@>
+
+
+@ @<Cases of |print_cmd...@>=
+case mp_lig_kern_token:
+switch (m) {
+case 0:
+ mp_print (mp, "=:");
+ break;
+case 1:
+ mp_print (mp, "=:|");
+ break;
+case 2:
+ mp_print (mp, "|=:");
+ break;
+case 3:
+ mp_print (mp, "|=:|");
+ break;
+case 5:
+ mp_print (mp, "=:|>");
+ break;
+case 6:
+ mp_print (mp, "|=:>");
+ break;
+case 7:
+ mp_print (mp, "|=:|>");
+ break;
+case 11:
+ mp_print (mp, "|=:|>>");
+ break;
+default:
+ mp_print (mp, "kern");
+ break;
+}
+break;
+
+@ Local labels are implemented by maintaining the |skip_table| array,
+where |skip_table[c]| is either |undefined_label| or the address of the
+most recent lig/kern instruction that skips to local label~|c|. In the
+latter case, the |skip_byte| in that instruction will (temporarily)
+be zero if there were no prior skips to this label, or it will be the
+distance to the prior skip.
+
+We may need to cancel skips that span more than 127 lig/kern steps.
+
+@d cancel_skips(A) mp->ll=(A);
+ do {
+ mp->lll=qo(skip_byte(mp->ll));
+ skip_byte(mp->ll)=stop_flag; mp->ll=(short)(mp->ll-mp->lll);
+ } while (mp->lll!=0)
+
+@d skip_error(A) {
+ const char *hlp[] = { "At most 127 lig/kern steps can separate skipto1 from 1::.", NULL};
+ mp_error(mp, "Too far to skip", hlp, true);
+@.Too far to skip@>
+ cancel_skips((A));
+}
+
+@<Process a |skip_to| command and |goto done|@>=
+{
+ c = mp_get_code (mp);
+ if (mp->nl - mp->skip_table[c] > 128) {
+ skip_error (mp->skip_table[c]);
+ mp->skip_table[c] = (short) undefined_label;
+ }
+ if (mp->skip_table[c] == undefined_label)
+ skip_byte (mp->nl - 1) = qi (0);
+ else
+ skip_byte (mp->nl - 1) = qi (mp->nl - mp->skip_table[c] - 1);
+ mp->skip_table[c] = (short) (mp->nl - 1);
+ goto DONE;
+}
+
+
+@ @<Record a label in a lig/kern subprogram and |goto continue|@>=
+{
+ if (cur_cmd() == mp_colon) {
+ if (c == 256)
+ mp->bch_label = mp->nl;
+ else
+ mp_set_tag (mp, c, lig_tag, mp->nl);
+ } else if (mp->skip_table[c] < undefined_label) {
+ mp->ll = mp->skip_table[c];
+ mp->skip_table[c] = undefined_label;
+ do {
+ mp->lll = qo (skip_byte (mp->ll));
+ if (mp->nl - mp->ll > 128) {
+ skip_error (mp->ll);
+ goto CONTINUE;
+ }
+ skip_byte (mp->ll) = qi (mp->nl - mp->ll - 1);
+ mp->ll = (short) (mp->ll - mp->lll);
+ } while (mp->lll != 0);
+ }
+ goto CONTINUE;
+}
+
+
+@ @<Compile a ligature/kern...@>=
+{
+ next_char (mp->nl) = qi (c);
+ skip_byte (mp->nl) = qi (0);
+ if (cur_mod() < 128) { /* ligature op */
+ op_byte (mp->nl) = qi (cur_mod());
+ rem_byte (mp->nl) = qi (mp_get_code (mp));
+ } else {
+ mp_get_x_next (mp);
+ mp_scan_expression (mp);
+ if (mp->cur_exp.type != mp_known) {
+ const char *hlp[] = {
+ "The amount of kern should be a known numeric value.",
+ "I'm zeroing this one. Proceed, with fingers crossed.",
+ NULL };
+ mp_disp_err(mp, NULL);
+ set_number_to_zero (new_expr.data.n);
+ mp_back_error (mp, "Improper kern", hlp, true);
+@.Improper kern@>;
+ mp_get_x_next (mp);
+ mp_flush_cur_exp (mp, new_expr);
+ }
+ number_clone (mp->kern[mp->nk], cur_exp_value_number ());
+ k = 0;
+ while (!number_equal (mp->kern[k], cur_exp_value_number ()))
+ incr (k);
+ if (k == mp->nk) {
+ if (mp->nk == max_tfm_int)
+ mp_fatal_error (mp, "too many TFM kerns");
+ mp->nk++;
+ }
+ op_byte (mp->nl) = qi (kern_flag + (k / 256));
+ rem_byte (mp->nl) = qi ((k % 256));
+ }
+ mp->lk_started = true;
+}
+
+
+@ @d missing_extensible_punctuation(A)
+ {
+ char msg[256];
+ const char *hlp[] = { "I'm processing `extensible c: t,m,b,r'.", NULL };
+ mp_snprintf(msg, 256, "Missing %s has been inserted", (A));
+ mp_back_error(mp, msg, hlp, true);
+@.Missing `\char`\#'@>
+ }
+
+@<Define an extensible recipe@>=
+{
+ if (mp->ne == 256)
+ mp_fatal_error (mp, "too many extensible recipies");
+ c = mp_get_code (mp);
+ mp_set_tag (mp, c, ext_tag, mp->ne);
+ if (cur_cmd() != mp_colon)
+ missing_extensible_punctuation (":");
+ ext_top (mp->ne) = qi (mp_get_code (mp));
+ if (cur_cmd() != mp_comma)
+ missing_extensible_punctuation (",");
+ ext_mid (mp->ne) = qi (mp_get_code (mp));
+ if (cur_cmd() != mp_comma)
+ missing_extensible_punctuation (",");
+ ext_bot (mp->ne) = qi (mp_get_code (mp));
+ if (cur_cmd() != mp_comma)
+ missing_extensible_punctuation (",");
+ ext_rep (mp->ne) = qi (mp_get_code (mp));
+ mp->ne++;
+}
+
+
+@ The header could contain ASCII zeroes, so can't use |strdup|.
+The index |j| can be beyond the index |header_last|, hence we
+have to sure to update the end of stream marker to reflect the
+actual position.
+
+@<Store a list of header bytes@>=
+j--;
+if (mp->header_last<j){
+ mp->header_last=j;
+}
+do {
+ if (j >= mp->header_size) {
+ size_t l = (size_t) (mp->header_size + (mp->header_size / 4));
+ char *t = xmalloc (l, 1);
+ memset (t, 0, l);
+ (void) memcpy (t, mp->header_byte, (size_t) mp->header_size);
+ xfree (mp->header_byte);
+ mp->header_byte = t;
+ mp->header_size = (int) l;
+ }
+ mp->header_byte[j] = (char) mp_get_code (mp);
+ if (mp->header_last<j){
+ incr (mp->header_last);
+ }
+ incr (j);
+} while (cur_cmd() == mp_comma)
+
+@ @<Store a list of font dimensions@>=
+do {
+ if (j > max_tfm_int)
+ mp_fatal_error (mp, "too many fontdimens");
+ while (j > mp->np) {
+ mp->np++;
+ set_number_to_zero(mp->param[mp->np]);
+ };
+ mp_get_x_next (mp);
+ mp_scan_expression (mp);
+ if (mp->cur_exp.type != mp_known) {
+ const char *hlp[] = { "I'm zeroing this one. Proceed, with fingers crossed.", NULL };
+ mp_disp_err(mp, NULL);
+ set_number_to_zero (new_expr.data.n);
+ mp_back_error (mp, "Improper font parameter", hlp, true);
+@.Improper font parameter@>;
+ mp_get_x_next (mp);
+ mp_flush_cur_exp (mp, new_expr);
+ }
+ number_clone (mp->param[j], cur_exp_value_number ());
+ incr (j);
+} while (cur_cmd() == mp_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@>=
+mp->inf_val = mp_get_value_node (mp);
+set_value_number (mp->inf_val, fraction_four_t);
+
+@ @<Free table entries@>=
+mp_free_value_node (mp, mp->inf_val);
+
+@ 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 |mp_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 mp_link(mp->temp_head)=mp->inf_val
+
+@c
+static mp_node mp_sort_in (MP mp, mp_number v) {
+ mp_node p, q, r; /* list manipulation registers */
+ p = mp->temp_head;
+ while (1) {
+ q = mp_link (p);
+ if (number_lessequal(v, value_number (q)))
+ break;
+ p = q;
+ }
+ if (number_less (v, value_number (q))) {
+ r = mp_get_value_node (mp);
+ set_value_number (r, v);
+ mp_link (r) = q;
+ mp_link (p) = r;
+ }
+ return mp_link (p);
+}
+
+
+@ Now we come to the interesting part, where we reduce the list if necessary
+until it has the required size. The |min_cover| routine is basic to this
+process; it computes the minimum number~|m| such that the values of the
+current sorted list can be covered by |m|~intervals of width~|d|. It
+also sets the global value |perturbation| to the smallest value $d'>d$
+such that the covering found by this algorithm would be different.
+
+In particular, |min_cover(0)| returns the number of distinct values in the
+current list and sets |perturbation| to the minimum distance between
+adjacent values.
+
+@c
+static integer mp_min_cover (MP mp, mp_number d) {
+ mp_node p; /* runs through the current list */
+ mp_number l; /* the least element covered by the current interval */
+ mp_number test;
+ integer m; /* lower bound on the size of the minimum cover */
+ m = 0;
+ new_number (l);
+ new_number (test);
+ p = mp_link (mp->temp_head);
+ set_number_to_inf(mp->perturbation);
+ while (p != mp->inf_val) {
+ incr (m);
+ number_clone (l, value_number (p));
+ do {
+ p = mp_link (p);
+ set_number_from_addition(test, l, d);
+ } while (number_lessequal(value_number (p), test));
+
+ set_number_from_substraction(test, value_number (p), l);
+ if (number_less (test, mp->perturbation)) {
+ number_clone (mp->perturbation, test);
+ }
+ }
+ free_number (test);
+ free_number (l);
+ return m;
+}
+
+
+@ @<Glob...@>=
+mp_number perturbation; /* quantity related to \.{TFM} rounding */
+integer excess; /* the list is this much too long */
+
+@ @<Initialize table...@>=
+new_number (mp->perturbation);
+
+@ @<Dealloc...@>=
+free_number (mp->perturbation);
+
+@ The smallest |d| such that a given list can be covered with |m| intervals
+is determined by the |threshold| routine, which is sort of an inverse
+to |min_cover|. The idea is to increase the interval size rapidly until
+finding the range, then to go sequentially until the exact borderline has
+been discovered.
+
+@c
+static void mp_threshold (MP mp, mp_number *ret, integer m) {
+ mp_number d, arg1; /* lower bound on the smallest interval size */
+ new_number (d);
+ new_number (arg1);
+ mp->excess = mp_min_cover (mp, zero_t) - m;
+ if (mp->excess <= 0) {
+ number_clone (*ret, zero_t);
+ } else {
+ do {
+ number_clone (d, mp->perturbation);
+ set_number_from_addition(arg1, d, d);
+ } while (mp_min_cover (mp, arg1) > m);
+ while (mp_min_cover (mp, d) > m) {
+ number_clone (d, mp->perturbation);
+ }
+ number_clone (*ret, d);
+ }
+ free_number (d);
+ free_number (arg1);
+}
+
+
+@ The |skimp| procedure reduces the current list to at most |m| entries,
+by changing values if necessary. It also sets |indep_value(p):=k| if |value(p)|
+is the |k|th distinct value on the resulting list, and it sets
+|perturbation| to the maximum amount by which a |value| field has
+been changed. The size of the resulting list is returned as the
+value of |skimp|.
+
+@c
+static integer mp_skimp (MP mp, integer m) {
+ mp_number d; /* the size of intervals being coalesced */
+ mp_node p, q, r; /* list manipulation registers */
+ mp_number l; /* the least value in the current interval */
+ mp_number v; /* a compromise value */
+ mp_number l_d;
+ new_number (d);
+ mp_threshold (mp, &d, m);
+ new_number (l);
+ new_number (l_d);
+ new_number (v);
+ set_number_to_zero (mp->perturbation);
+ q = mp->temp_head;
+ m = 0;
+ p = mp_link (mp->temp_head);
+ while (p != mp->inf_val) {
+ incr (m);
+ number_clone (l, value_number (p));
+ set_indep_value (p,m);
+ set_number_from_addition (l_d, l, d);
+ if (number_lessequal (value_number (mp_link (p)), l_d)) {
+ @<Replace an interval of values by its midpoint@>;
+ }
+ q = p;
+ p = mp_link (p);
+ }
+ free_number (l_d);
+ free_number (d);
+ free_number (l);
+ free_number (v);
+ return m;
+}
+
+
+@ @<Replace an interval...@>=
+{
+ mp_number test;
+ new_number (test);
+ do {
+ p = mp_link (p);
+ set_indep_value (p, m);
+ decr (mp->excess);
+ if (mp->excess == 0) {
+ number_clone (l_d, l);
+ set_number_to_zero (d);
+ }
+ } while (number_lessequal(value_number (mp_link (p)), l_d));
+ set_number_from_substraction (test, value_number (p), l);
+ number_halfp(test);
+ set_number_from_addition (v, l, test);
+ set_number_from_substraction (test, value_number (p), v);
+ if (number_greater (test, mp->perturbation))
+ number_clone (mp->perturbation, test);
+ r = q;
+ do {
+ r = mp_link (r);
+ set_value_number (r, v);
+ } while (r != p);
+ mp_link (q) = p; /* remove duplicate values from the current list */
+ free_number (test);
+}
+
+
+@ A warning message is issued whenever something is perturbed by
+more than 1/16\thinspace pt.
+
+@c
+static void mp_tfm_warning (MP mp, quarterword m) {
+ mp_print_nl (mp, "(some ");
+ mp_print (mp, internal_name (m));
+@.some charwds...@>
+@.some chardps...@>
+@.some charhts...@>
+@.some charics...@>;
+ mp_print (mp, " values had to be adjusted by as much as ");
+ print_number (mp->perturbation);
+ mp_print (mp, "pt)");
+}
+
+
+@ Here's an example of how we use these routines.
+The width data needs to be perturbed only if there are 256 distinct
+widths, but \MP\ must check for this case even though it is
+highly unusual.
+
+An integer variable |k| will be defined when we use this code.
+The |dimen_head| array will contain pointers to the sorted
+lists of dimensions.
+
+@d tfm_warn_threshold_k ((math_data *)mp->math)->tfm_warn_threshold_t
+
+@<Massage the \.{TFM} widths@>=
+clear_the_list;
+for (k = mp->bc; k <= mp->ec; k++) {
+ if (mp->char_exists[k])
+ mp->tfm_width[k] = mp_sort_in (mp, value_number (mp->tfm_width[k]));
+}
+mp->nw = (short) (mp_skimp (mp, 255) + 1);
+mp->dimen_head[1] = mp_link (mp->temp_head);
+if (number_greaterequal (mp->perturbation, tfm_warn_threshold_k))
+ mp_tfm_warning (mp, mp_char_wd)
+
+
+@ @<Glob...@>=
+mp_node dimen_head[5]; /* lists of \.{TFM} dimensions */
+
+@ Heights, depths, and italic corrections are different from widths
+not only because their list length is more severely restricted, but
+also because zero values do not need to be put into the lists.
+
+@<Massage the \.{TFM} heights, depths, and italic corrections@>=
+clear_the_list;
+for (k = mp->bc; k <= mp->ec; k++) {
+ if (mp->char_exists[k]) {
+ if (number_zero(value_number (mp->tfm_height[k])))
+ mp->tfm_height[k] = mp->zero_val;
+ else
+ mp->tfm_height[k] = mp_sort_in (mp, value_number (mp->tfm_height[k]));
+ }
+}
+mp->nh = (short) (mp_skimp (mp, 15) + 1);
+mp->dimen_head[2] = mp_link (mp->temp_head);
+if (number_greaterequal (mp->perturbation, tfm_warn_threshold_k))
+ mp_tfm_warning (mp, mp_char_ht);
+clear_the_list;
+for (k = mp->bc; k <= mp->ec; k++) {
+ if (mp->char_exists[k]) {
+ if (number_zero(value_number (mp->tfm_depth[k])))
+ mp->tfm_depth[k] = mp->zero_val;
+ else
+ mp->tfm_depth[k] = mp_sort_in (mp, value_number (mp->tfm_depth[k]));
+ }
+}
+mp->nd = (short) (mp_skimp (mp, 15) + 1);
+mp->dimen_head[3] = mp_link (mp->temp_head);
+if (number_greaterequal (mp->perturbation, tfm_warn_threshold_k))
+ mp_tfm_warning (mp, mp_char_dp);
+clear_the_list;
+for (k = mp->bc; k <= mp->ec; k++) {
+ if (mp->char_exists[k]) {
+ if (number_zero(value_number (mp->tfm_ital_corr[k])))
+ mp->tfm_ital_corr[k] = mp->zero_val;
+ else
+ mp->tfm_ital_corr[k] = mp_sort_in (mp, value_number (mp->tfm_ital_corr[k]));
+ }
+}
+mp->ni = (short) (mp_skimp (mp, 63) + 1);
+mp->dimen_head[4] = mp_link (mp->temp_head);
+if (number_greaterequal (mp->perturbation, tfm_warn_threshold_k))
+ mp_tfm_warning (mp, mp_char_ic)
+
+
+@ @<Initialize table entries@>=
+mp->zero_val = mp_get_value_node (mp);
+set_value_number (mp->zero_val, zero_t);
+
+@ @<Free table entries@>=
+mp_free_value_node (mp, mp->zero_val);
+
+@ 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_value(mp_design_size))|}
+ < \\{three\_bytes}.$$
+
+@d three_bytes 0100000000 /* $2^{24}$ */
+
+@c
+static void mp_fix_design_size (MP mp) {
+ mp_number d; /* the design size */
+ new_number (d);
+ number_clone (d, internal_value (mp_design_size));
+ if (number_less(d, unity_t) || number_greaterequal(d, fraction_half_t)) {
+ if (!number_zero (d))
+ mp_print_nl (mp, "(illegal design size has been changed to 128pt)");
+@.illegal design size...@>;
+ set_number_from_scaled (d, 040000000);
+ number_clone (internal_value (mp_design_size), d);
+ }
+ if (mp->header_byte[4] == 0 && mp->header_byte[5] == 0 &&
+ mp->header_byte[6] == 0 && mp->header_byte[7] == 0) {
+ integer dd = number_to_scaled (d);
+ mp->header_byte[4] = (char) (dd / 04000000);
+ mp->header_byte[5] = (char) ((dd / 4096) % 256);
+ mp->header_byte[6] = (char) ((dd / 16) % 256);
+ mp->header_byte[7] = (char) ((dd % 16) * 16);
+ }
+ /* |mp->max_tfm_dimen = 16 * internal_value (mp_design_size) - 1 - internal_value (mp_design_size) / 010000000| */
+ {
+ mp_number secondpart;
+ new_number (secondpart);
+ number_clone (secondpart, internal_value (mp_design_size));
+ number_clone (mp->max_tfm_dimen, secondpart);
+ number_divide_int (secondpart, 010000000);
+ number_multiply_int (mp->max_tfm_dimen, 16);
+ number_add_scaled (mp->max_tfm_dimen, -1);
+ number_substract (mp->max_tfm_dimen, secondpart);
+ free_number (secondpart);
+ }
+ if (number_greaterequal (mp->max_tfm_dimen, fraction_half_t)) {
+ number_clone (mp->max_tfm_dimen, fraction_half_t);
+ number_add_scaled (mp->max_tfm_dimen, -1);
+ }
+ free_number (d);
+}
+
+
+@ The |dimen_out| procedure computes a |fix_word| relative to the
+design size. If the data was out of range, it is corrected and the
+global variable |tfm_changed| is increased by~one.
+
+@c
+static integer mp_dimen_out (MP mp, mp_number x_orig) {
+ integer ret;
+ mp_number abs_x;
+ mp_number x;
+ new_number (abs_x);
+ new_number (x);
+ number_clone (x, x_orig);
+ number_clone (abs_x, x_orig);
+ number_abs (abs_x);
+ if (number_greater (abs_x, mp->max_tfm_dimen)) {
+ incr (mp->tfm_changed);
+ if (number_positive(x))
+ number_clone (x, mp->max_tfm_dimen);
+ else {
+ number_clone (x, mp->max_tfm_dimen);
+ number_negate (x);
+ }
+ }
+ {
+ mp_number arg1;
+ new_number (arg1);
+ number_clone (arg1, x);
+ number_multiply_int (arg1, 16);
+ make_scaled (x, arg1, internal_value (mp_design_size));
+ free_number (arg1);
+ }
+ free_number (abs_x);
+ ret = number_to_scaled (x);
+ free_number (x);
+ return ret;
+}
+
+
+@ @<Glob...@>=
+mp_number max_tfm_dimen; /* bound on widths, heights, kerns, etc. */
+integer tfm_changed; /* the number of data entries that were out of bounds */
+
+@ @<Initialize table...@>=
+new_number (mp->max_tfm_dimen);
+
+@ @<Dealloc...@>=
+free_number (mp->max_tfm_dimen);
+
+
+@ If the user has not specified any of the first four header bytes,
+the |fix_check_sum| procedure replaces them by a ``check sum'' computed
+from the |tfm_width| data relative to the design size.
+@^check sum@>
+
+@c
+static void mp_fix_check_sum (MP mp) {
+ eight_bits k; /* runs through character codes */
+ eight_bits B1, B2, B3, B4; /* bytes of the check sum */
+ integer x; /* hash value used in check sum computation */
+ if (mp->header_byte[0] == 0 && mp->header_byte[1] == 0 &&
+ mp->header_byte[2] == 0 && mp->header_byte[3] == 0) {
+ @<Compute a check sum in |(b1,b2,b3,b4)|@>;
+ mp->header_byte[0] = (char) B1;
+ mp->header_byte[1] = (char) B2;
+ mp->header_byte[2] = (char) B3;
+ mp->header_byte[3] = (char) B4;
+ return;
+ }
+}
+
+
+@ @<Compute a check sum in |(b1,b2,b3,b4)|@>=
+B1 = mp->bc;
+B2 = mp->ec;
+B3 = mp->bc;
+B4 = mp->ec;
+mp->tfm_changed = 0;
+for (k = mp->bc; k <= mp->ec; k++) {
+ if (mp->char_exists[k]) {
+ x = mp_dimen_out (mp, value_number (mp->tfm_width[k])) + (k + 4) * 020000000; /* this is positive */
+ B1 = (eight_bits) ((B1 + B1 + x) % 255);
+ B2 = (eight_bits) ((B2 + B2 + x) % 253);
+ B3 = (eight_bits) ((B3 + B3 + x) % 251);
+ B4 = (eight_bits) ((B4 + B4 + x) % 247);
+ }
+ if (k == mp->ec)
+ break;
+}
+
+
+@ Finally we're ready to actually write the \.{TFM} information.
+Here are some utility routines for this purpose.
+
+@d tfm_out(A) do { /* output one byte to |tfm_file| */
+ unsigned char s=(unsigned char)(A);
+ (mp->write_binary_file)(mp,mp->tfm_file,(void *)&s,1);
+ } while (0)
+
+@c
+static void mp_tfm_two (MP mp, integer x) { /* output two bytes to |tfm_file| */
+ tfm_out (x / 256);
+ tfm_out (x % 256);
+}
+static void mp_tfm_four (MP mp, integer x) { /* output four bytes to |tfm_file| */
+ if (x >= 0)
+ tfm_out (x / three_bytes);
+ else {
+ x = x + 010000000000; /* use two's complement for negative values */
+ x = x + 010000000000;
+ tfm_out ((x / three_bytes) + 128);
+ };
+ x = x % three_bytes;
+ tfm_out (x / number_to_scaled (unity_t));
+ x = x % number_to_scaled (unity_t);
+ tfm_out (x / 0400);
+ tfm_out (x % 0400);
+}
+static void mp_tfm_qqqq (MP mp, four_quarters x) { /* output four quarterwords to |tfm_file| */
+ tfm_out (qo (x.b0));
+ tfm_out (qo (x.b1));
+ tfm_out (qo (x.b2));
+ tfm_out (qo (x.b3));
+}
+
+
+@ @<Finish the \.{TFM} file@>=
+if (mp->job_name == NULL)
+ mp_open_log_file (mp);
+mp_pack_job_name (mp, ".tfm");
+while (!mp_open_out (mp, &mp->tfm_file, mp_filetype_metrics))
+ mp_prompt_file_name (mp, "file name for font metrics", ".tfm");
+mp->metric_file_name = xstrdup (mp->name_of_file);
+@<Output the subfile sizes and header bytes@>;
+@<Output the character information bytes, then
+ output the dimensions themselves@>;
+@<Output the ligature/kern program@>;
+@<Output the extensible character recipes and the font metric parameters@>;
+if (number_positive (internal_value (mp_tracing_stats)))
+ @<Log the subfile sizes of the \.{TFM} file@>;
+mp_print_nl (mp, "Font metrics written on ");
+mp_print (mp, mp->metric_file_name);
+mp_print_char (mp, xord ('.'));
+@.Font metrics written...@>;
+(mp->close_file) (mp, mp->tfm_file)
+
+
+@ Integer variables |lh|, |k|, and |lk_offset| will be defined when we use
+this code.
+
+@<Output the subfile sizes and header bytes@>=
+k = mp->header_last;
+LH = (k + 4) / 4; /* this is the number of header words */
+if (mp->bc > mp->ec)
+ mp->bc = 1; /* if there are no characters, |ec=0| and |bc=1| */
+@<Compute the ligature/kern program offset and implant the
+ left boundary label@>;
+mp_tfm_two (mp,
+ 6 + LH + (mp->ec - mp->bc + 1) + mp->nw + mp->nh + mp->nd + mp->ni +
+ mp->nl + lk_offset + mp->nk + mp->ne + mp->np);
+ /* this is the total number of file words that will be output */
+mp_tfm_two (mp, LH);
+mp_tfm_two (mp, mp->bc);
+mp_tfm_two (mp, mp->ec);
+mp_tfm_two (mp, mp->nw);
+mp_tfm_two (mp, mp->nh);
+mp_tfm_two (mp, mp->nd);
+mp_tfm_two (mp, mp->ni);
+mp_tfm_two (mp, mp->nl + lk_offset);
+mp_tfm_two (mp, mp->nk);
+mp_tfm_two (mp, mp->ne);
+mp_tfm_two (mp, mp->np);
+for (k = 0; k < 4 * LH; k++) {
+ tfm_out (mp->header_byte[k]);
+}
+
+
+@ @<Output the character information bytes...@>=
+for (k = mp->bc; k <= mp->ec; k++) {
+ if (!mp->char_exists[k]) {
+ mp_tfm_four (mp, 0);
+ } else {
+ tfm_out (indep_value (mp->tfm_width[k])); /* the width index */
+ tfm_out ((indep_value (mp->tfm_height[k])) * 16 + indep_value (mp->tfm_depth[k]));
+ tfm_out ((indep_value (mp->tfm_ital_corr[k])) * 4 + mp->char_tag[k]);
+ tfm_out (mp->char_remainder[k]);
+ };
+}
+mp->tfm_changed = 0;
+for (k = 1; k <= 4; k++) {
+ mp_tfm_four (mp, 0);
+ p = mp->dimen_head[k];
+ while (p != mp->inf_val) {
+ mp_tfm_four (mp, mp_dimen_out (mp, value_number (p)));
+ p = mp_link (p);
+ }
+}
+
+
+@ We need to output special instructions at the beginning of the
+|lig_kern| array in order to specify the right boundary character
+and/or to handle starting addresses that exceed 255. The |label_loc|
+and |label_char| arrays have been set up to record all the
+starting addresses; we have $-1=|label_loc|[0]<|label_loc|[1]\le\cdots
+\le|label_loc|[|label_ptr]|$.
+
+@<Compute the ligature/kern program offset...@>=
+mp->bchar = round_unscaled (internal_value (mp_boundary_char));
+if ((mp->bchar < 0) || (mp->bchar > 255)) {
+ mp->bchar = -1;
+ mp->lk_started = false;
+ lk_offset = 0;
+} else {
+ mp->lk_started = true;
+ lk_offset = 1;
+}
+@<Find the minimum |lk_offset| and adjust all remainders@>;
+if (mp->bch_label < undefined_label) {
+ skip_byte (mp->nl) = qi (255);
+ next_char (mp->nl) = qi (0);
+ op_byte (mp->nl) = qi (((mp->bch_label + lk_offset) / 256));
+ rem_byte (mp->nl) = qi (((mp->bch_label + lk_offset) % 256));
+ mp->nl++; /* possibly |nl=lig_table_size+1| */
+}
+
+@ @<Find the minimum |lk_offset|...@>=
+k = mp->label_ptr; /* pointer to the largest unallocated label */
+if (mp->label_loc[k] + lk_offset > 255) {
+ lk_offset = 0;
+ mp->lk_started = false; /* location 0 can do double duty */
+ do {
+ mp->char_remainder[mp->label_char[k]] = lk_offset;
+ while (mp->label_loc[k - 1] == mp->label_loc[k]) {
+ decr (k);
+ mp->char_remainder[mp->label_char[k]] = lk_offset;
+ }
+ incr (lk_offset);
+ decr (k);
+ } while (!(lk_offset + mp->label_loc[k] < 256));
+ /* N.B.: |lk_offset=256| satisfies this when |k=0| */
+}
+if (lk_offset > 0) {
+ while (k > 0) {
+ mp->char_remainder[mp->label_char[k]]
+ = mp->char_remainder[mp->label_char[k]] + lk_offset;
+ decr (k);
+ }
+}
+
+@ @<Output the ligature/kern program@>=
+for (k = 0; k <= 255; k++) {
+ if (mp->skip_table[k] < undefined_label) {
+ mp_print_nl (mp, "(local label ");
+ mp_print_int (mp, k);
+ mp_print (mp, ":: was missing)");
+@.local label l:: was missing@>;
+ cancel_skips (mp->skip_table[k]);
+ }
+}
+if (mp->lk_started) { /* |lk_offset=1| for the special |bchar| */
+ tfm_out (255);
+ tfm_out (mp->bchar);
+ mp_tfm_two (mp, 0);
+} else {
+ for (k = 1; k <= lk_offset; k++) { /* output the redirection specs */
+ mp->ll = mp->label_loc[mp->label_ptr];
+ if (mp->bchar < 0) {
+ tfm_out (254);
+ tfm_out (0);
+ } else {
+ tfm_out (255);
+ tfm_out (mp->bchar);
+ };
+ mp_tfm_two (mp, mp->ll + lk_offset);
+ do {
+ mp->label_ptr--;
+ } while (!(mp->label_loc[mp->label_ptr] < mp->ll));
+ }
+}
+for (k = 0; k < mp->nl; k++)
+ mp_tfm_qqqq (mp, mp->lig_kern[k]);
+{
+ mp_number arg;
+ new_number (arg);
+ for (k = 0; k < mp->nk; k++) {
+ number_clone (arg, mp->kern[k]);
+ mp_tfm_four (mp, mp_dimen_out (mp, arg));
+ }
+ free_number (arg);
+}
+
+@ @<Output the extensible character recipes...@>=
+for (k = 0; k < mp->ne; k++)
+ mp_tfm_qqqq (mp, mp->exten[k]);
+{
+mp_number arg;
+new_number (arg);
+for (k = 1; k <= mp->np; k++) {
+ if (k == 1) {
+ number_clone (arg, mp->param[1]);
+ number_abs (arg);
+ if (number_less(arg, fraction_half_t)) {
+ mp_tfm_four (mp, number_to_scaled (mp->param[1]) * 16);
+ } else {
+ incr (mp->tfm_changed);
+ if (number_positive(mp->param[1]))
+ mp_tfm_four (mp, max_integer);
+ else
+ mp_tfm_four (mp, -max_integer);
+ }
+ } else {
+ number_clone (arg, mp->param[k]);
+ mp_tfm_four (mp, mp_dimen_out (mp, arg));
+ }
+}
+free_number (arg);
+}
+if (mp->tfm_changed > 0) {
+ if (mp->tfm_changed == 1) {
+ mp_print_nl (mp, "(a font metric dimension");
+@.a font metric dimension...@>
+ } else {
+ mp_print_nl (mp, "(");
+ mp_print_int (mp, mp->tfm_changed);
+@.font metric dimensions...@>;
+ mp_print (mp, " font metric dimensions");
+ }
+ mp_print (mp, " had to be decreased)");
+}
+
+@ @<Log the subfile sizes of the \.{TFM} file@>=
+{
+ char s[200];
+ wlog_ln (" ");
+ if (mp->bch_label < undefined_label)
+ mp->nl--;
+ mp_snprintf (s, 128,
+ "(You used %iw,%ih,%id,%ii,%il,%ik,%ie,%ip metric file positions)",
+ mp->nw, mp->nh, mp->nd, mp->ni, mp->nl, mp->nk, mp->ne, mp->np);
+ wlog_ln (s);
+}
+
+
+@* Reading font metric data.
+
+\MP\ isn't a typesetting program but it does need to find the bounding box
+of a sequence of typeset characters. Thus it needs to read \.{TFM} files as
+well as write them.
+
+@<Glob...@>=
+void *tfm_infile;
+
+@ All the width, height, and depth information is stored in an array called
+|font_info|. This array is allocated sequentially and each font is stored
+as a series of |char_info| words followed by the width, height, and depth
+tables. Since |font_name| entries are permanent, their |str_ref| values are
+set to |MAX_STR_REF|.
+
+@<Types...@>=
+typedef unsigned int font_number; /* |0..font_max| */
+
+@ The |font_info| array is indexed via a group directory arrays.
+For example, the |char_info| data for character~|c| in font~|f| will be
+in |font_info[char_base[f]+c].qqqq|.
+
+@<Glob...@>=
+font_number font_max; /* maximum font number for included text fonts */
+size_t font_mem_size; /* number of words for \.{TFM} information for text fonts */
+font_data *font_info; /* height, width, and depth data */
+char **font_enc_name; /* encoding names, if any */
+boolean *font_ps_name_fixed; /* are the postscript names fixed already? */
+size_t next_fmem; /* next unused entry in |font_info| */
+font_number last_fnum; /* last font number used so far */
+integer *font_dsize; /* 16 times the ``design'' size in \ps\ points */
+char **font_name; /* name as specified in the \&{infont} command */
+char **font_ps_name; /* PostScript name for use when |internal[mp_prologues]>0| */
+font_number last_ps_fnum; /* last valid |font_ps_name| index */
+eight_bits *font_bc;
+eight_bits *font_ec; /* first and last character code */
+int *char_base; /* base address for |char_info| */
+int *width_base; /* index for zeroth character width */
+int *height_base; /* index for zeroth character height */
+int *depth_base; /* index for zeroth character depth */
+mp_node *font_sizes;
+
+@ @<Allocate or initialize ...@>=
+mp->font_mem_size = 10000;
+mp->font_info = xmalloc ((mp->font_mem_size + 1), sizeof (font_data));
+memset (mp->font_info, 0, sizeof (font_data) * (mp->font_mem_size + 1));
+mp->last_fnum = null_font;
+
+@ @<Dealloc variables@>=
+for (k = 1; k <= (int) mp->last_fnum; k++) {
+ xfree (mp->font_enc_name[k]);
+ xfree (mp->font_name[k]);
+ xfree (mp->font_ps_name[k]);
+}
+for (k = 0; k <= 255; k++) {
+/* These are disabled for now following a bug-report about double free
+ errors. TO BE FIXED, bug tracker id 831 */
+/*|
+ mp_free_value_node (mp, mp->tfm_width[k]);
+ mp_free_value_node (mp, mp->tfm_height[k]);
+ mp_free_value_node (mp, mp->tfm_depth[k]);
+ mp_free_value_node (mp, mp->tfm_ital_corr[k]);
+|*/
+}
+
+xfree (mp->font_info);
+xfree (mp->font_enc_name);
+xfree (mp->font_ps_name_fixed);
+xfree (mp->font_dsize);
+xfree (mp->font_name);
+xfree (mp->font_ps_name);
+xfree (mp->font_bc);
+xfree (mp->font_ec);
+xfree (mp->char_base);
+xfree (mp->width_base);
+xfree (mp->height_base);
+xfree (mp->depth_base);
+xfree (mp->font_sizes);
+
+@
+@c
+void mp_reallocate_fonts (MP mp, font_number l) {
+ font_number f;
+ XREALLOC (mp->font_enc_name, l, char *);
+ XREALLOC (mp->font_ps_name_fixed, l, boolean);
+ XREALLOC (mp->font_dsize, l, integer);
+ XREALLOC (mp->font_name, l, char *);
+ XREALLOC (mp->font_ps_name, l, char *);
+ XREALLOC (mp->font_bc, l, eight_bits);
+ XREALLOC (mp->font_ec, l, eight_bits);
+ XREALLOC (mp->char_base, l, int);
+ XREALLOC (mp->width_base, l, int);
+ XREALLOC (mp->height_base, l, int);
+ XREALLOC (mp->depth_base, l, int);
+ XREALLOC (mp->font_sizes, l, mp_node);
+ for (f = (mp->last_fnum + 1); f <= l; f++) {
+ mp->font_enc_name[f] = NULL;
+ mp->font_ps_name_fixed[f] = false;
+ mp->font_name[f] = NULL;
+ mp->font_ps_name[f] = NULL;
+ mp->font_sizes[f] = NULL;
+ }
+ mp->font_max = l;
+}
+
+
+@ @<Internal library declarations@>=
+void mp_reallocate_fonts (MP mp, font_number l);
+
+
+@ A |null_font| containing no characters is useful for error recovery. Its
+|font_name| entry starts out empty but is reset each time an erroneous font is
+found. This helps to cut down on the number of duplicate error messages without
+wasting a lot of space.
+
+@d null_font 0 /* the |font_number| for an empty font */
+
+@<Set initial...@>=
+mp->font_dsize[null_font] = 0;
+mp->font_bc[null_font] = 1;
+mp->font_ec[null_font] = 0;
+mp->char_base[null_font] = 0;
+mp->width_base[null_font] = 0;
+mp->height_base[null_font] = 0;
+mp->depth_base[null_font] = 0;
+mp->next_fmem = 0;
+mp->last_fnum = null_font;
+mp->last_ps_fnum = null_font;
+{
+ static char nullfont_name[] = "nullfont";
+ static char nullfont_psname[] = "";
+ mp->font_name[null_font] = nullfont_name;
+ mp->font_ps_name[null_font] = nullfont_psname;
+}
+mp->font_ps_name_fixed[null_font] = false;
+mp->font_enc_name[null_font] = NULL;
+mp->font_sizes[null_font] = NULL;
+
+@ Each |char_info| word is of type |four_quarters|. The |b0| field contains
+the |width index|; the |b1| field contains the height
+index; the |b2| fields contains the depth index, and the |b3| field used only
+for temporary storage. (It is used to keep track of which characters occur in
+an edge structure that is being shipped out.)
+The corresponding words in the width, height, and depth tables are stored as
+|scaled| values in units of \ps\ points.
+
+With the macros below, the |char_info| word for character~|c| in font~|f| is
+|char_mp_info(f,c)| and the width is
+$$\hbox{|char_width(f,char_mp_info(f,c)).sc|.}$$
+
+@d char_mp_info(A,B) mp->font_info[mp->char_base[(A)]+(B)].qqqq
+@d char_width(A,B) mp->font_info[mp->width_base[(A)]+(B).b0].sc
+@d char_height(A,B) mp->font_info[mp->height_base[(A)]+(B).b1].sc
+@d char_depth(A,B) mp->font_info[mp->depth_base[(A)]+(B).b2].sc
+@d ichar_exists(A) ((A).b0>0)
+
+@ 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|.
+
+@<Declarations@>=
+static font_number mp_find_font (MP mp, char *f);
+
+@ @c
+font_number mp_find_font (MP mp, char *f) {
+ font_number n;
+ for (n = 0; n <= mp->last_fnum; n++) {
+ if (mp_xstrcmp (f, mp->font_name[n]) == 0) {
+ return n;
+ }
+ }
+ n = mp_read_font_info (mp, f);
+ return n;
+}
+
+
+@ This is an interface function for getting the width of character,
+as a double in ps units
+
+@c
+double mp_get_char_dimension (MP mp, char *fname, int c, int t) {
+ unsigned n;
+ four_quarters cc;
+ font_number f = 0;
+ double w = -1.0;
+ for (n = 0; n <= mp->last_fnum; n++) {
+ if (mp_xstrcmp (fname, mp->font_name[n]) == 0) {
+ f = n;
+ break;
+ }
+ }
+ if (f == 0)
+ return 0.0;
+ cc = char_mp_info (f, c);
+ if (!ichar_exists (cc))
+ return 0.0;
+ if (t == 'w')
+ w = (double) char_width (f, cc);
+ else if (t == 'h')
+ w = (double) char_height (f, cc);
+ else if (t == 'd')
+ w = (double) char_depth (f, cc);
+ return w / 655.35 * (72.27 / 72);
+}
+
+
+@ @<Exported function ...@>=
+double mp_get_char_dimension (MP mp, char *fname, int n, int t);
+
+
+@ 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.
+
+@<Declarations@>=
+static void mp_lost_warning (MP mp, font_number f, int k);
+
+@ @c
+void mp_lost_warning (MP mp, font_number f, int k) {
+ if (number_positive (internal_value (mp_tracing_lost_chars))) {
+ mp_begin_diagnostic (mp);
+ if (mp->selector == log_only)
+ incr (mp->selector);
+ mp_print_nl (mp, "Missing character: There is no ");
+@.Missing character@>;
+ mp_print_int (mp, k);
+ mp_print (mp, " in font ");
+ mp_print (mp, mp->font_name[f]);
+ mp_print_char (mp, xord ('!'));
+ mp_end_diagnostic (mp, false);
+ }
+}
+
+
+@ The whole purpose of saving the height, width, and depth information is to be
+able to find the bounding box of an item of text in an edge structure. The
+|set_text_box| procedure takes a text node and adds this information.
+
+@<Declarations@>=
+static void mp_set_text_box (MP mp, mp_text_node p);
+
+@ @c
+void mp_set_text_box (MP mp, mp_text_node p) {
+ font_number f; /* |mp_font_n(p)| */
+ ASCII_code bc, ec; /* range of valid characters for font |f| */
+ size_t k, kk; /* current character and character to stop at */
+ four_quarters cc; /* the |char_info| for the current character */
+ mp_number h, d; /* dimensions of the current character */
+ mp_number minus_inf_t; /* check the -inf of height and depth */
+ new_number(h);
+ new_number(d);
+ new_number(minus_inf_t);
+ number_clone(minus_inf_t, inf_t);
+ number_negate(minus_inf_t);
+ set_number_to_zero(p->width);
+ set_number_to_neg_inf(p->height);
+ set_number_to_neg_inf(p->depth);
+ f = (font_number) mp_font_n (p);
+ bc = mp->font_bc[f];
+ ec = mp->font_ec[f];
+ kk = mp_text_p (p)->len;
+ k = 0;
+ while (k < kk) {
+ @<Adjust |p|'s bounding box to contain |str_pool[k]|; advance |k|@>;
+ }
+ @<Set the height and depth to zero if the bounding box is empty@>;
+ free_number (h);
+ free_number (d);
+ free_number (minus_inf_t);
+}
+
+
+@ @<Adjust |p|'s bounding box to contain |str_pool[k]|; advance |k|@>=
+{
+ if ((*(mp_text_p (p)->str + k) < bc) || (*(mp_text_p (p)->str + k) > ec)) {
+ mp_lost_warning (mp, f, *(mp_text_p (p)->str + k));
+ } else {
+ cc = char_mp_info (f, *(mp_text_p (p)->str + k));
+ if (!ichar_exists (cc)) {
+ mp_lost_warning (mp, f, *(mp_text_p (p)->str + k));
+ } else {
+ set_number_from_scaled(p->width, number_to_scaled(p->width) + char_width (f, cc));
+ set_number_from_scaled(h, char_height (f, cc));
+ set_number_from_scaled(d, char_depth (f, cc));
+ if (number_greater(h, p->height))
+ number_clone(p->height, h);
+ if (number_greater(d, p->depth))
+ number_clone(p->depth, d);
+ }
+ }
+ incr (k);
+}
+
+
+@ Let's hope modern compilers do comparisons correctly when the difference would
+overflow.
+
+@<Set the height and depth to zero if the bounding box is empty@>=
+if (number_equal(p->height,p->depth) && number_equal(p->height,minus_inf_t)) {
+ set_number_to_zero(p->height);
+ set_number_to_zero(p->depth);
+} else if (number_to_scaled(p->height) < -number_to_scaled(p->depth)) {
+ set_number_to_zero(p->height);
+ set_number_to_zero(p->depth);
+}
+
+@ The new primitives fontmapfile and fontmapline.
+
+@<Declare action procedures for use by |do_statement|@>=
+static void mp_do_mapfile (MP mp);
+static void mp_do_mapline (MP mp);
+
+@ @c
+static void mp_do_mapfile (MP mp) {
+ mp_get_x_next (mp);
+ mp_scan_expression (mp);
+ if (mp->cur_exp.type != mp_string_type) {
+ @<Complain about improper map operation@>;
+ } else {
+ mp_map_file (mp, cur_exp_str ());
+ }
+}
+static void mp_do_mapline (MP mp) {
+ mp_get_x_next (mp);
+ mp_scan_expression (mp);
+ if (mp->cur_exp.type != mp_string_type) {
+ @<Complain about improper map operation@>;
+ } else {
+ mp_map_line (mp, cur_exp_str ());
+ }
+}
+
+
+@ @<Complain about improper map operation@>=
+{
+ const char *hlp[] = { "Only known strings can be map files or map lines.", NULL };
+ mp_disp_err(mp, NULL);
+ mp_back_error (mp, "Unsuitable expression", hlp, true);
+ mp_get_x_next (mp);
+}
+
+
+@ To print |scaled| value to PDF output we need some subroutines to ensure
+accurary.
+
+@d max_integer 0x7FFFFFFF /* $2^{31}-1$ */
+
+@<Glob...@>=
+integer ten_pow[10]; /* $10^0..10^9$ */
+integer scaled_out; /* amount of |scaled| that was taken out in |divide_scaled| */
+
+@ @<Set init...@>=
+mp->ten_pow[0] = 1;
+for (i = 1; i <= 9; i++) {
+ mp->ten_pow[i] = 10 * mp->ten_pow[i - 1];
+}
+
+
+@* Shipping pictures out.
+The |ship_out| procedure, to be described below, is given a pointer to
+an edge structure. Its mission is to output a file containing the \ps\
+description of an edge structure.
+
+@ Each time an edge structure is shipped out we write a new \ps\ output
+file named according to the current \&{charcode}.
+@:char_code_}{\&{charcode} primitive@>
+
+This is the only backend function that remains in the main |mpost.w| file.
+There are just too many variable accesses needed for status reporting
+etcetera to make it worthwile to move the code to |psout.w|.
+
+@<Internal library declarations@>=
+void mp_open_output_file (MP mp);
+char *mp_get_output_file_name (MP mp);
+char *mp_set_output_file_name (MP mp, integer c);
+
+@ @c
+static void mp_append_to_template (MP mp, integer ff, integer c, boolean rounding) {
+ if (internal_type (c) == mp_string_type) {
+ char *ss = mp_str (mp, internal_string (c));
+ mp_print (mp, ss);
+ } else if (internal_type (c) == mp_known) {
+ if (rounding) {
+ int cc = round_unscaled (internal_value (c));
+ print_with_leading_zeroes (cc, ff);
+ } else {
+ print_number (internal_value (c));
+ }
+ }
+}
+char *mp_set_output_file_name (MP mp, integer c) {
+ char *ss = NULL; /* filename extension proposal */
+ char *nn = NULL; /* temp string for str() */
+ unsigned old_setting; /* previous |selector| setting */
+ size_t i; /* indexes into |filename_template| */
+ integer f; /* field width */
+ str_room (1024);
+ if (mp->job_name == NULL)
+ mp_open_log_file (mp);
+ if (internal_string (mp_output_template) == NULL) {
+ char *s; /* a file extension derived from |c| */
+ if (c < 0)
+ s = xstrdup (".ps");
+ else
+ @<Use |c| to compute the file extension |s|@>;
+ mp_pack_job_name (mp, s);
+ free (s);
+ ss = xstrdup (mp->name_of_file);
+ } else { /* initializations */
+ mp_string s, n, ftemplate; /* a file extension derived from |c| */
+ mp_number saved_char_code;
+ new_number (saved_char_code);
+ number_clone (saved_char_code, internal_value (mp_char_code));
+ set_internal_from_number (mp_char_code, unity_t);
+ number_multiply_int (internal_value (mp_char_code), c);
+ if (internal_string (mp_job_name) == NULL) {
+ if (mp->job_name == NULL) {
+ mp->job_name = xstrdup ("mpout");
+ }
+ @<Fix up |mp->internal[mp_job_name]|@>;
+ }
+ old_setting = mp->selector;
+ mp->selector = new_string;
+ i = 0;
+ n = mp_rts(mp,""); /* initialize */
+ ftemplate = internal_string (mp_output_template);
+ while (i < ftemplate->len) {
+ f = 0;
+ if (*(ftemplate->str + i) == '%') {
+ CONTINUE:
+ incr (i);
+ if (i < ftemplate->len) {
+ switch (*(ftemplate->str + i)) {
+ case 'j':
+ mp_append_to_template (mp, f, mp_job_name, true);
+ break;
+ case 'c':
+ if (number_negative (internal_value (mp_char_code))) {
+ mp_print (mp, "ps");
+ } else {
+ mp_append_to_template (mp, f, mp_char_code, true);
+ }
+ break;
+ case 'o':
+ mp_append_to_template (mp, f, mp_output_format, true);
+ break;
+ case 'd':
+ mp_append_to_template (mp, f, mp_day, true);
+ break;
+ case 'm':
+ mp_append_to_template (mp, f, mp_month, true);
+ break;
+ case 'y':
+ mp_append_to_template (mp, f, mp_year, true);
+ break;
+ case 'H':
+ mp_append_to_template (mp, f, mp_hour, true);
+ break;
+ case 'M':
+ mp_append_to_template (mp, f, mp_minute, true);
+ break;
+ case '{':
+ {
+ /* look up a name */
+ size_t l = 0;
+ size_t frst = i + 1;
+ while (i < ftemplate->len) {
+ i++;
+ if (*(ftemplate->str + i) == '}')
+ break;
+ l++;
+ }
+ if (l > 0) {
+ mp_sym p =
+ mp_id_lookup (mp, (char *) (ftemplate->str + frst), l, false);
+ char *id = xmalloc ((l + 1), 1);
+ (void) memcpy (id, (char *) (ftemplate->str + frst), (size_t) l);
+ *(id + l) = '\0';
+ if (p == NULL) {
+ char err[256];
+ mp_snprintf (err, 256,
+ "requested identifier (%s) in outputtemplate not found.",
+ id);
+ mp_warn (mp, err);
+ } else {
+ if (eq_type (p) == mp_internal_quantity) {
+ if (equiv (p) == mp_output_template) {
+ char err[256];
+ mp_snprintf (err, 256,
+ "The appearance of outputtemplate inside outputtemplate is ignored.");
+ mp_warn (mp, err);
+ } else {
+ mp_append_to_template (mp, f, equiv (p), false);
+ }
+ } else {
+ char err[256];
+ mp_snprintf (err, 256,
+ "requested identifier (%s) in outputtemplate is not an internal.",
+ id);
+ mp_warn (mp, err);
+ }
+ }
+ free (id);
+ }
+ }
+ break;
+ case '0':
+ case '1':
+ case '2':
+ case '3':
+ case '4':
+ case '5':
+ case '6':
+ case '7':
+ case '8':
+ case '9':
+ if ((f < 10))
+ f = (f * 10) + ftemplate->str[i] - '0';
+ goto CONTINUE;
+ break;
+ case '%':
+ mp_print_char (mp, '%');
+ break;
+ default:
+ {
+ char err[256];
+ mp_snprintf (err, 256,
+ "requested format (%c) in outputtemplate is unknown.",
+ *(ftemplate->str + i));
+ mp_warn (mp, err);
+ }
+ mp_print_char (mp, *(ftemplate->str + i));
+ }
+ }
+ } else {
+ if (*(ftemplate->str + i) == '.')
+ if (n->len == 0)
+ n = mp_make_string (mp);
+ mp_print_char (mp, *(ftemplate->str + i));
+ };
+ incr (i);
+ }
+ s = mp_make_string (mp);
+ number_clone (internal_value (mp_char_code), saved_char_code);
+ free_number (saved_char_code);
+ mp->selector = old_setting;
+ if (n->len == 0) {
+ n = s;
+ s = mp_rts(mp,"");
+ }
+ ss = mp_str (mp, s);
+ nn = mp_str (mp, n);
+ mp_pack_file_name (mp, nn, "", ss);
+ delete_str_ref (n);
+ delete_str_ref (s);
+ }
+ return ss;
+}
+char *mp_get_output_file_name (MP mp) {
+ char *f;
+ char *saved_name; /* saved |name_of_file| */
+ saved_name = xstrdup (mp->name_of_file);
+ (void) mp_set_output_file_name (mp, round_unscaled (internal_value(mp_char_code)));
+ f = xstrdup (mp->name_of_file);
+ mp_pack_file_name (mp, saved_name, NULL, NULL);
+ free (saved_name);
+ return f;
+}
+void mp_open_output_file (MP mp) {
+ char *ss; /* filename extension proposal */
+ int c; /* \&{charcode} rounded to the nearest integer */
+ c = round_unscaled (internal_value (mp_char_code));
+ ss = mp_set_output_file_name (mp, c);
+ while (!mp_open_out (mp, (void *) &mp->output_file, mp_filetype_postscript))
+ mp_prompt_file_name (mp, "file name for output", ss);
+ mp_store_true_output_filename (mp, c);
+}
+
+
+@ The file extension created here could be up to five characters long in
+extreme cases so it may have to be shortened on some systems.
+@^system dependencies@>
+
+@<Use |c| to compute the file extension |s|@>=
+{
+ s = xmalloc (12, 1);
+ mp_snprintf (s, 12, ".%i", (int) c);
+ s[7]='\0';
+}
+
+
+@ 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@>
+
+@<Internal library ...@>=
+void mp_store_true_output_filename (MP mp, int c);
+
+@ @c
+void mp_store_true_output_filename (MP mp, int c)
+{
+ if ((c < mp->first_output_code) && (mp->first_output_code >= 0)) {
+ mp->first_output_code = c;
+ xfree (mp->first_file_name);
+ mp->first_file_name = xstrdup (mp->name_of_file);
+ }
+ if (c >= mp->last_output_code) {
+ mp->last_output_code = c;
+ xfree (mp->last_file_name);
+ mp->last_file_name = xstrdup (mp->name_of_file);
+ }
+ set_internal_string (mp_output_filename, mp_rts (mp, mp->name_of_file));
+}
+
+@ @<Glob...@>=
+char *first_file_name;
+char *last_file_name; /* full file names */
+integer first_output_code;
+integer last_output_code; /* rounded \&{charcode} values */
+@:char_code_}{\&{charcode} primitive@>
+integer total_shipped; /* total number of |ship_out| operations completed */
+
+@ @<Set init...@>=
+mp->first_file_name = xstrdup ("");
+mp->last_file_name = xstrdup ("");
+mp->first_output_code = 32768;
+mp->last_output_code = -32768;
+mp->total_shipped = 0;
+
+@ @<Dealloc variables@>=
+xfree (mp->first_file_name);
+xfree (mp->last_file_name);
+
+@ @<Begin the progress report for the output of picture~|c|@>=
+if ((int) mp->term_offset > mp->max_print_line - 6)
+ mp_print_ln (mp);
+else if ((mp->term_offset > 0) || (mp->file_offset > 0))
+ mp_print_char (mp, xord (' '));
+mp_print_char (mp, xord ('['));
+if (c >= 0)
+ mp_print_int (mp, c)
+
+
+@ @<End progress report@>=
+mp_print_char (mp, xord (']'));
+update_terminal();
+incr (mp->total_shipped)
+
+
+@ @<Explain what output files were written@>=
+if (mp->total_shipped > 0) {
+ mp_print_nl (mp, "");
+ mp_print_int (mp, mp->total_shipped);
+ if (mp->noninteractive) {
+ mp_print (mp, " figure");
+ if (mp->total_shipped > 1)
+ mp_print_char (mp, xord ('s'));
+ mp_print (mp, " created.");
+ } else {
+ mp_print (mp, " output file");
+ if (mp->total_shipped > 1)
+ mp_print_char (mp, xord ('s'));
+ mp_print (mp, " written: ");
+ mp_print (mp, mp->first_file_name);
+ if (mp->total_shipped > 1) {
+ if (31 + strlen (mp->first_file_name) +
+ strlen (mp->last_file_name) > (unsigned) mp->max_print_line)
+ mp_print_ln (mp);
+ mp_print (mp, " .. ");
+ mp_print (mp, mp->last_file_name);
+ }
+ mp_print_nl (mp, "");
+ }
+}
+
+@ @<Internal library declarations@>=
+boolean mp_has_font_size (MP mp, font_number f);
+
+@ @c
+boolean mp_has_font_size (MP mp, font_number f) {
+ return (mp->font_sizes[f] != NULL);
+}
+
+
+@ The \&{special} command saves up lines of text to be printed during the next
+|ship_out| operation. The saved items are stored as a list of capsule tokens.
+
+@<Glob...@>=
+mp_node last_pending; /* the last token in a list of pending specials */
+
+
+@ @<Declare action procedures for use by |do_statement|@>=
+static void mp_do_special (MP mp);
+
+@ @c
+void mp_do_special (MP mp) {
+ mp_get_x_next (mp);
+ mp_scan_expression (mp);
+ if (mp->cur_exp.type != mp_string_type) {
+ @<Complain about improper special operation@>;
+ } else {
+ mp_link (mp->last_pending) = mp_stash_cur_exp (mp);
+ mp->last_pending = mp_link (mp->last_pending);
+ mp_link (mp->last_pending) = NULL;
+ }
+}
+
+
+@ @<Complain about improper special operation@>=
+{
+ const char *hlp[] = { "Only known strings are allowed for output as specials.", NULL };
+ mp_disp_err(mp, NULL);
+ mp_back_error (mp, "Unsuitable expression", hlp, true);
+ mp_get_x_next (mp);
+}
+
+
+@ On the export side, we need an extra object type for special strings.
+
+@<Graphical object codes@>=
+mp_special_code = 8,
+
+@ @<Export pending specials@>=
+p = mp_link (mp->spec_head);
+while (p != NULL) {
+ mp_special_object *tp;
+ tp = (mp_special_object *) mp_new_graphic_object (mp, mp_special_code);
+ gr_pre_script (tp) = mp_xstrdup(mp,mp_str (mp, value_str (p)));
+ if (hh->body == NULL)
+ hh->body = (mp_graphic_object *) tp;
+ else
+ gr_link (hp) = (mp_graphic_object *) tp;
+ hp = (mp_graphic_object *) tp;
+ p = mp_link (p);
+}
+mp_flush_token_list (mp, mp_link (mp->spec_head));
+mp_link (mp->spec_head) = NULL;
+mp->last_pending = mp->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@>=
+static void mp_ship_out (MP mp, mp_node h);
+
+@ Once again, the |gr_XXXX| macros are defined in |mppsout.h|
+
+@d export_color(q,p)
+ if ( mp_color_model(p)==mp_uninitialized_model ) {
+ gr_color_model(q) = (unsigned char)(number_to_scaled (internal_value(mp_default_color_model))/65536);
+ gr_cyan_val(q) = 0;
+ gr_magenta_val(q) = 0;
+ gr_yellow_val(q) = 0;
+ gr_black_val(q) = ((gr_color_model(q)==mp_cmyk_model ? number_to_scaled (unity_t) : 0) / 65536.0);
+ } else {
+ gr_color_model(q) = (unsigned char)mp_color_model(p);
+ gr_cyan_val(q) = number_to_double(p->cyan);
+ gr_magenta_val(q) = number_to_double(p->magenta);
+ gr_yellow_val(q) = number_to_double(p->yellow);
+ gr_black_val(q) = number_to_double(p->black);
+ }
+
+@d export_scripts(q,p)
+ if (mp_pre_script(p)!=NULL) gr_pre_script(q) = mp_xstrdup(mp, mp_str(mp,mp_pre_script(p)));
+ if (mp_post_script(p)!=NULL) gr_post_script(q) = mp_xstrdup(mp, mp_str(mp,mp_post_script(p)));
+
+@c
+struct mp_edge_object *mp_gr_export (MP mp, mp_edge_header_node h) {
+ mp_node p; /* the current graphical object */
+ integer t; /* a temporary value */
+ integer c; /* a rounded charcode */
+ mp_number d_width; /* the current pen width */
+ mp_edge_object *hh; /* the first graphical object */
+ mp_graphic_object *hq; /* something |hp| points to */
+ mp_text_object *tt;
+ mp_fill_object *tf;
+ mp_stroked_object *ts;
+ mp_clip_object *tc;
+ mp_bounds_object *tb;
+ mp_graphic_object *hp = NULL; /* the current graphical object */
+ mp_set_bbox (mp, h, true);
+ hh = xmalloc (1, sizeof (mp_edge_object));
+ hh->body = NULL;
+ hh->next = NULL;
+ hh->parent = mp;
+ hh->minx = number_to_double(h->minx);
+ hh->minx = (fabs(hh->minx)<0.00001 ? 0 : hh->minx);
+ hh->miny = number_to_double(h->miny);
+ hh->miny = (fabs(hh->miny)<0.00001 ? 0 : hh->miny);
+ hh->maxx = number_to_double(h->maxx);
+ hh->maxx = (fabs(hh->maxx)<0.00001 ? 0 : hh->maxx);
+ hh->maxy = number_to_double(h->maxy);
+ hh->maxy = (fabs(hh->maxy)<0.00001 ? 0 : hh->maxy);
+ hh->filename = mp_get_output_file_name (mp);
+ c = round_unscaled (internal_value (mp_char_code));
+ hh->charcode = c;
+ hh->width = number_to_double (internal_value (mp_char_wd));
+ hh->height = number_to_double (internal_value (mp_char_ht));
+ hh->depth = number_to_double (internal_value (mp_char_dp));
+ hh->ital_corr = number_to_double (internal_value (mp_char_ic));
+ @<Export pending specials@>;
+ p = mp_link (edge_list (h));
+ while (p != NULL) {
+ hq = mp_new_graphic_object (mp, (int) ((mp_type (p) - mp_fill_node_type) + 1));
+ switch (mp_type (p)) {
+ case mp_fill_node_type:
+ {
+ mp_fill_node p0 = (mp_fill_node)p;
+ tf = (mp_fill_object *) hq;
+ gr_pen_p (tf) = mp_export_knot_list (mp, mp_pen_p (p0));
+ new_number (d_width);
+ mp_get_pen_scale (mp, &d_width, mp_pen_p (p0)); /* whats the point ? */
+ free_number (d_width);
+ if ((mp_pen_p (p0) == NULL) || pen_is_elliptical (mp_pen_p (p0))) {
+ gr_path_p (tf) = mp_export_knot_list (mp, mp_path_p (p0));
+ } else {
+ mp_knot pc, pp;
+ pc = mp_copy_path (mp, mp_path_p (p0));
+ pp = mp_make_envelope (mp, pc, mp_pen_p (p0), p0->ljoin, 0, p0->miterlim);
+ gr_path_p (tf) = mp_export_knot_list (mp, pp);
+ mp_toss_knot_list (mp, pp);
+ pc = mp_htap_ypoc (mp, mp_path_p (p0));
+ pp = mp_make_envelope (mp, pc, mp_pen_p ((mp_fill_node) p), p0->ljoin, 0, p0->miterlim);
+ gr_htap_p (tf) = mp_export_knot_list (mp, pp);
+ mp_toss_knot_list (mp, pp);
+ }
+ export_color (tf, p0);
+ export_scripts (tf, p);
+ gr_ljoin_val (tf) = p0->ljoin;
+ gr_miterlim_val (tf) = number_to_double(p0->miterlim);
+ }
+ break;
+ case mp_stroked_node_type:
+ {
+ mp_stroked_node p0 = (mp_stroked_node)p;
+ ts = (mp_stroked_object *) hq;
+ gr_pen_p (ts) = mp_export_knot_list (mp, mp_pen_p (p0));
+ new_number (d_width);
+ mp_get_pen_scale (mp, &d_width, mp_pen_p (p0));
+ if (pen_is_elliptical (mp_pen_p (p0))) {
+ gr_path_p (ts) = mp_export_knot_list (mp, mp_path_p (p0));
+ } else {
+ mp_knot pc;
+ pc = mp_copy_path (mp, mp_path_p (p0));
+ t = p0->lcap;
+ if (mp_left_type (pc) != mp_endpoint) {
+ mp_left_type (mp_insert_knot (mp, pc, pc->x_coord, pc->y_coord)) = mp_endpoint;
+ mp_right_type (pc) = mp_endpoint;
+ pc = mp_next_knot (pc);
+ t = 1;
+ }
+ pc =
+ mp_make_envelope (mp, pc, mp_pen_p (p0),
+ p0->ljoin, (quarterword) t,
+ p0->miterlim);
+ gr_path_p (ts) = mp_export_knot_list (mp, pc);
+ mp_toss_knot_list (mp, pc);
+ }
+ export_color (ts, p0);
+ export_scripts (ts, p);
+ gr_ljoin_val (ts) = p0->ljoin;
+ gr_miterlim_val (ts) = number_to_double(p0->miterlim);
+ gr_lcap_val (ts) = p0->lcap;
+ gr_dash_p (ts) = mp_export_dashes (mp, p0, d_width);
+ free_number (d_width);
+ }
+ break;
+ case mp_text_node_type:
+ {
+ mp_text_node p0 = (mp_text_node)p;
+ tt = (mp_text_object *) hq;
+ gr_text_p (tt) = mp_xstrldup (mp, mp_str (mp, mp_text_p (p)),mp_text_p (p)->len);
+ gr_text_l (tt) = (size_t) mp_text_p (p)->len;
+ gr_font_n (tt) = (unsigned int) mp_font_n (p);
+ gr_font_name (tt) = mp_xstrdup (mp, mp->font_name[mp_font_n (p)]);
+ gr_font_dsize (tt) = mp->font_dsize[mp_font_n (p)] / 65536.0;
+ export_color (tt, p0);
+ export_scripts (tt, p);
+ gr_width_val (tt) = number_to_double(p0->width);
+ gr_height_val (tt) = number_to_double(p0->height);
+ gr_depth_val (tt) = number_to_double(p0->depth);
+ gr_tx_val (tt) = number_to_double(p0->tx);
+ gr_ty_val (tt) = number_to_double(p0->ty);
+ gr_txx_val (tt) = number_to_double(p0->txx);
+ gr_txy_val (tt) = number_to_double(p0->txy);
+ gr_tyx_val (tt) = number_to_double(p0->tyx);
+ gr_tyy_val (tt) = number_to_double(p0->tyy);
+ }
+ break;
+ case mp_start_clip_node_type:
+ tc = (mp_clip_object *) hq;
+ gr_path_p (tc) =
+ mp_export_knot_list (mp, mp_path_p ((mp_start_clip_node) p));
+ break;
+ case mp_start_bounds_node_type:
+ tb = (mp_bounds_object *) hq;
+ gr_path_p (tb) =
+ mp_export_knot_list (mp, mp_path_p ((mp_start_bounds_node) p));
+ break;
+ case mp_stop_clip_node_type:
+ case mp_stop_bounds_node_type:
+ /* nothing to do here */
+ break;
+ default: /* there are no other valid cases, but please the compiler */
+ break;
+ }
+ if (hh->body == NULL)
+ hh->body = hq;
+ else
+ gr_link (hp) = hq;
+ hp = hq;
+ p = mp_link (p);
+ }
+ return hh;
+}
+
+
+@ This function is only used for the |glyph| operator, so
+it takes quite a few shortcuts for cases that cannot appear
+in the output of |mp_ps_font_charstring|.
+
+@c
+mp_edge_header_node mp_gr_import (MP mp, struct mp_edge_object *hh) {
+ mp_edge_header_node h; /* the edge object */
+ mp_node ph, pn, pt; /* for adding items */
+ mp_graphic_object *p; /* the current graphical object */
+ h = mp_get_edge_header_node (mp);
+ mp_init_edges (mp, h);
+ ph = edge_list (h);
+ pt = ph;
+ p = hh->body;
+ set_number_from_double(h->minx, hh->minx);
+ set_number_from_double(h->miny, hh->miny);
+ set_number_from_double(h->maxx, hh->maxx);
+ set_number_from_double(h->maxy, hh->maxy);
+ while (p != NULL) {
+ switch (gr_type (p)) {
+ case mp_fill_code:
+ if (gr_pen_p ((mp_fill_object *) p) == NULL) {
+ mp_number turns;
+ new_number (turns);
+ pn = mp_new_fill_node (mp, NULL);
+ mp_path_p ((mp_fill_node) pn) =
+ mp_import_knot_list (mp, gr_path_p ((mp_fill_object *) p));
+ mp_color_model (pn) = mp_grey_model;
+ mp_turn_cycles (mp, &turns, mp_path_p ((mp_fill_node) pn));
+ if (number_negative(turns)) {
+ set_number_to_unity(((mp_fill_node) pn)->grey);
+ mp_link (pt) = pn;
+ pt = mp_link (pt);
+ } else {
+ set_number_to_zero(((mp_fill_node) pn)->grey);
+ mp_link (pn) = mp_link (ph);
+ mp_link (ph) = pn;
+ if (ph == pt)
+ pt = pn;
+ }
+ free_number (turns);
+ }
+ break;
+ case mp_stroked_code:
+ case mp_text_code:
+ case mp_start_clip_code:
+ case mp_stop_clip_code:
+ case mp_start_bounds_code:
+ case mp_stop_bounds_code:
+ case mp_special_code:
+ break;
+ } /* all cases are enumerated */
+ p = p->next;
+ }
+ mp_gr_toss_objects (hh);
+ return h;
+}
+
+
+@ @<Declarations@>=
+struct mp_edge_object *mp_gr_export (MP mp, mp_edge_header_node h);
+mp_edge_header_node mp_gr_import (MP mp, struct mp_edge_object *h);
+
+@ This function is now nearly trivial.
+
+@c
+void mp_ship_out (MP mp, mp_node h) { /* output edge structure |h| */
+ int c; /* \&{charcode} rounded to the nearest integer */
+ c = round_unscaled (internal_value (mp_char_code));
+ @<Begin the progress report for the output of picture~|c|@>;
+ (mp->shipout_backend) (mp, h);
+ @<End progress report@>;
+ if (number_positive (internal_value (mp_tracing_output)))
+ mp_print_edges (mp, h, " (just shipped out)", true);
+}
+
+
+@ @<Declarations@>=
+static void mp_shipout_backend (MP mp, void *h);
+
+@
+@c
+void mp_shipout_backend (MP mp, void *voidh) {
+ char *s;
+ mp_edge_object *hh; /* the first graphical object */
+ mp_edge_header_node h = (mp_edge_header_node) voidh;
+ hh = mp_gr_export (mp, h);
+ s = NULL;
+ if (internal_string (mp_output_format) != NULL)
+ s = mp_str (mp, internal_string (mp_output_format));
+ if (s && strcmp (s, "svg") == 0) {
+ (void) mp_svg_gr_ship_out (hh,
+ (number_to_scaled (internal_value (mp_prologues)) / 65536), false);
+ } else if (s && strcmp (s, "png") == 0) {
+ (void) mp_png_gr_ship_out (hh, (const char *)((internal_string (mp_output_format_options))->str), false);
+ } else {
+ (void) mp_gr_ship_out (hh,
+ (number_to_scaled (internal_value (mp_prologues)) / 65536),
+ (number_to_scaled (internal_value (mp_procset)) / 65536), false);
+ }
+ mp_gr_toss_objects (hh);
+}
+
+
+@ @<Exported types@>=
+typedef void (*mp_backend_writer) (MP, void *);
+
+@ @<Option variables@>=
+mp_backend_writer shipout_backend;
+
+@ Now that we've finished |ship_out|, let's look at the other commands
+by which a user can send things to the \.{GF} file.
+
+@ @<Glob...@>=
+psout_data ps;
+svgout_data svg;
+pngout_data png;
+
+@ @<Allocate or initialize ...@>=
+mp_ps_backend_initialize (mp);
+mp_svg_backend_initialize (mp);
+mp_png_backend_initialize (mp);
+
+@ @<Dealloc...@>=
+mp_ps_backend_free (mp);
+mp_svg_backend_free (mp);
+mp_png_backend_free (mp);
+
+
+@* Dumping and undumping the tables.
+
+When \.{MP} is started, it is possible to preload a macro file
+containing definitions that will be usable in the main input
+file. This action even takes place automatically, based on the
+name of the executable (\.{mpost} will attempt to preload the
+macros in the file \.{mpost.mp}). If such a preload is not
+desired, the option variable |ini_version| has to be set |true|.
+
+The variable |mem_file| holds the open file pointer.
+
+@<Glob...@>=
+void *mem_file; /* file for input or preloaded macros */
+
+@ @<Declarations@>=
+extern boolean mp_load_preload_file (MP mp);
+
+@ Preloading a file is a lot like |mp_run| itself, except that
+\MP\ should not exit and that a bit of trickery is needed with
+the input buffer to make sure that the preloading does not
+interfere with the actual job.
+
+@c
+boolean mp_load_preload_file (MP mp) {
+ size_t k;
+ in_state_record old_state;
+ integer old_in_open = mp->in_open;
+ void *old_cur_file = cur_file;
+ char *fname = xstrdup (mp->name_of_file);
+ size_t l = strlen (fname);
+ old_state = mp->cur_input;
+ str_room (l);
+ for (k = 0; k < l; k++) {
+ append_char (*(fname + k));
+ }
+ name = mp_make_string (mp);
+ if (!mp->log_opened) {
+ mp_open_log_file (mp);
+ } /* |open_log_file| doesn't |show_context|, so |limit|
+ and |loc| needn't be set to meaningful values yet */
+ if (((int) mp->term_offset + (int) strlen (fname)) > (mp->max_print_line - 2))
+ mp_print_ln (mp);
+ else if ((mp->term_offset > 0) || (mp->file_offset > 0))
+ mp_print_char (mp, xord (' '));
+ mp_print_char (mp, xord ('('));
+ incr (mp->open_parens);
+ mp_print (mp, fname);
+ update_terminal();
+ {
+ line = 1;
+ start = loc = limit + (mp->noninteractive ? 0 : 1);
+ cur_file = mp->mem_file;
+ (void) mp_input_ln (mp, cur_file);
+ mp_firm_up_the_line (mp);
+ mp->buffer[limit] = xord ('%');
+ mp->first = (size_t) (limit + 1);
+ loc = start;
+ }
+ mp->reading_preload = true;
+ do {
+ mp_do_statement (mp);
+ } while (!(cur_cmd() == mp_stop)); /* "dump" or EOF */
+ mp->reading_preload = false;
+ mp_primitive (mp, "dump", mp_relax, 0); /* reset |dump| */
+ while (mp->input_ptr > 0) {
+ if (token_state)
+ mp_end_token_list (mp);
+ else
+ mp_end_file_reading (mp);
+ }
+ while (mp->loop_ptr != NULL)
+ mp_stop_iteration (mp);
+ while (mp->open_parens > 0) {
+ mp_print (mp, " )");
+ decr (mp->open_parens);
+ };
+ while (mp->cond_ptr != NULL) {
+ mp_print_nl (mp, "(dump occurred when ");
+@.dump occurred...@>;
+ mp_print_cmd_mod (mp, mp_fi_or_else, mp->cur_if);
+ /* `\.{if}' or `\.{elseif}' or `\.{else}' */
+ if (mp->if_line != 0) {
+ mp_print (mp, " on line ");
+ mp_print_int (mp, mp->if_line);
+ }
+ mp_print (mp, " was incomplete)");
+ mp->if_line = if_line_field (mp->cond_ptr);
+ mp->cur_if = mp_name_type (mp->cond_ptr);
+ mp->cond_ptr = mp_link (mp->cond_ptr);
+ }
+
+/* |(mp->close_file) (mp, mp->mem_file);| */
+ cur_file = old_cur_file;
+ mp->cur_input = old_state;
+ mp->in_open = old_in_open;
+ return true;
+}
+
+
+@* The main program.
+This is it: the part of \MP\ that executes all those procedures we have
+written.
+
+Well---almost. We haven't put the parsing subroutines into the
+program yet; and we'd better leave space for a few more routines that may
+have been forgotten.
+
+@c
+@<Declare the basic parsing subroutines@>;
+@<Declare miscellaneous procedures that were declared |forward|@>
+
+
+@ 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@>
+
+@ @c
+void mp_close_files_and_terminate (MP mp) {
+ integer k; /* all-purpose index */
+ integer LH; /* the length of the \.{TFM} header, in words */
+ int lk_offset; /* extra words inserted at beginning of |lig_kern| array */
+ mp_node p; /* runs through a list of \.{TFM} dimensions */
+ if (mp->finished)
+ return;
+ @<Close all open files in the |rd_file| and |wr_file| arrays@>;
+ if (number_positive (internal_value (mp_tracing_stats)))
+ @<Output statistics about this job@>;
+ wake_up_terminal();
+ @<Do all the finishing work on the \.{TFM} file@>;
+ @<Explain what output files were written@>;
+ if (mp->log_opened && !mp->noninteractive) {
+ wlog_cr;
+ (mp->close_file) (mp, mp->log_file);
+ mp->selector = mp->selector - 2;
+ if (mp->selector == term_only) {
+ mp_print_nl (mp, "Transcript written on ");
+@.Transcript written...@>;
+ mp_print (mp, mp->log_name);
+ mp_print_char (mp, xord ('.'));
+ }
+ }
+ mp_print_ln (mp);
+ mp->finished = true;
+}
+
+
+@ @<Declarations@>=
+static void mp_close_files_and_terminate (MP mp);
+
+@ @<Close all open files in the |rd_file| and |wr_file| arrays@>=
+if (mp->rd_fname != NULL) {
+ for (k = 0; k < (int) mp->read_files; k++) {
+ if (mp->rd_fname[k] != NULL) {
+ (mp->close_file) (mp, mp->rd_file[k]);
+ xfree (mp->rd_fname[k]);
+ }
+ }
+}
+if (mp->wr_fname != NULL) {
+ for (k = 0; k < (int) mp->write_files; k++) {
+ if (mp->wr_fname[k] != NULL) {
+ (mp->close_file) (mp, mp->wr_file[k]);
+ xfree (mp->wr_fname[k]);
+ }
+ }
+}
+
+@ @<Dealloc ...@>=
+for (k = 0; k < (int) mp->max_read_files; k++) {
+ if (mp->rd_fname[k] != NULL) {
+ (mp->close_file) (mp, mp->rd_file[k]);
+ xfree (mp->rd_fname[k]);
+ }
+}
+xfree (mp->rd_file);
+xfree (mp->rd_fname);
+for (k = 0; k < (int) mp->max_write_files; k++) {
+ if (mp->wr_fname[k] != NULL) {
+ (mp->close_file) (mp, mp->wr_file[k]);
+ xfree (mp->wr_fname[k]);
+ }
+}
+xfree (mp->wr_file);
+xfree (mp->wr_fname);
+
+
+@ We want to produce a \.{TFM} file if and only if |mp_fontmaking| is positive.
+
+We reclaim all of the variable-size memory at this point, so that
+there is no chance of another memory overflow after the memory capacity
+has already been exceeded.
+
+@<Do all the finishing work on the \.{TFM} file@>=
+if (number_positive (internal_value (mp_fontmaking))) {
+ @<Massage the \.{TFM} widths@>;
+ mp_fix_design_size (mp);
+ mp_fix_check_sum (mp);
+ @<Massage the \.{TFM} heights, depths, and italic corrections@>;
+ set_number_to_zero (internal_value (mp_fontmaking)); /* avoid loop in case of fatal error */
+ @<Finish the \.{TFM} file@>;
+}
+
+@ The present section goes directly to the log file instead of using
+|print| commands, because there's no need for these strings to take
+up |str_pool| memory when a non-{\bf stat} version of \MP\ is being used.
+
+@<Output statistics...@>=
+if (mp->log_opened) {
+ char s[128];
+ wlog_ln (" ");
+ wlog_ln ("Here is how much of MetaPost's memory you used:");
+@.Here is how much...@>;
+ mp_snprintf (s, 128, " %i string%s using %i character%s",
+ (int) mp->max_strs_used, (mp->max_strs_used != 1 ? "s" : ""),
+ (int) mp->max_pl_used, (mp->max_pl_used != 1 ? "s" : ""));
+ wlog_ln (s);
+ mp_snprintf (s, 128, " %i bytes of node memory", (int) mp->var_used_max);
+ wlog_ln (s);
+ mp_snprintf (s, 128, " %i symbolic tokens", (int) mp->st_count);
+ wlog_ln (s);
+ mp_snprintf (s, 128,
+ " %ii,%in,%ip,%ib,%if stack positions out of %ii,%in,%ip,%ib,%if",
+ (int) mp->max_in_stack, (int) mp->int_ptr,
+ (int) mp->max_param_stack, (int) mp->max_buf_stack + 1,
+ (int) mp->in_open_max - file_bottom, (int) mp->stack_size,
+ (int) mp->max_internal, (int) mp->param_size, (int) mp->buf_size,
+ (int) mp->max_in_open - file_bottom);
+ wlog_ln (s);
+}
+
+@ It is nice to have have some of the stats available from the API.
+
+@<Exported function ...@>=
+int mp_memory_usage (MP mp);
+int mp_hash_usage (MP mp);
+int mp_param_usage (MP mp);
+int mp_open_usage (MP mp);
+
+@ @c
+int mp_memory_usage (MP mp) {
+ return (int) mp->var_used;
+}
+int mp_hash_usage (MP mp) {
+ return (int) mp->st_count;
+}
+int mp_param_usage (MP mp) {
+ return (int) mp->max_param_stack;
+}
+int mp_open_usage (MP mp) {
+ return (int) mp->max_in_stack;
+}
+
+
+@ We get to the |final_cleanup| routine when \&{end} or \&{dump} has
+been scanned.
+
+@c
+void mp_final_cleanup (MP mp) {
+ /* -Wunused: integer c; */ /* 0 for \&{end}, 1 for \&{dump} */
+ /* clang: never read: |c = cur_mod();| */
+ if (mp->job_name == NULL)
+ mp_open_log_file (mp);
+ while (mp->input_ptr > 0) {
+ if (token_state)
+ mp_end_token_list (mp);
+ else
+ mp_end_file_reading (mp);
+ }
+ while (mp->loop_ptr != NULL)
+ mp_stop_iteration (mp);
+ while (mp->open_parens > 0) {
+ mp_print (mp, " )");
+ decr (mp->open_parens);
+ };
+ while (mp->cond_ptr != NULL) {
+ mp_print_nl (mp, "(end occurred when ");
+@.end occurred...@>;
+ mp_print_cmd_mod (mp, mp_fi_or_else, mp->cur_if);
+ /* `\.{if}' or `\.{elseif}' or `\.{else}' */
+ if (mp->if_line != 0) {
+ mp_print (mp, " on line ");
+ mp_print_int (mp, mp->if_line);
+ }
+ mp_print (mp, " was incomplete)");
+ mp->if_line = if_line_field (mp->cond_ptr);
+ mp->cur_if = mp_name_type (mp->cond_ptr);
+ mp->cond_ptr = mp_link (mp->cond_ptr);
+ }
+ if (mp->history != mp_spotless)
+ if (((mp->history == mp_warning_issued)
+ || (mp->interaction < mp_error_stop_mode)))
+ if (mp->selector == term_and_log) {
+ mp->selector = term_only;
+ mp_print_nl (mp,
+ "(see the transcript file for additional information)");
+@.see the transcript file...@>;
+ mp->selector = term_and_log;
+ }
+}
+
+
+@ @<Declarations@>=
+static void mp_final_cleanup (MP mp);
+static void mp_init_prim (MP mp);
+static void mp_init_tab (MP mp);
+
+@ @c
+void mp_init_prim (MP mp) { /* initialize all the primitives */
+ @<Put each...@>;
+}
+@#
+void mp_init_tab (MP mp) { /* initialize other tables */
+ @<Initialize table entries@>;
+}
+
+
+@ When we begin the following code, \MP's tables may still contain garbage;
+thus we must proceed cautiously to get bootstrapped in.
+
+But when we finish this part of the program, \MP\ is ready to call on the
+|main_control| routine to do its work.
+
+@<Get the first line...@>=
+{
+ @<Initialize the input routines@>;
+ if (!mp->ini_version) {
+ if (!mp_load_preload_file (mp)) {
+ mp->history = mp_fatal_error_stop;
+ return mp;
+ }
+ }
+ @<Initializations following first line@>;
+}
+
+
+@ @<Initializations following first line@>=
+mp->buffer[limit] = (ASCII_code) '%';
+mp_fix_date_and_time (mp);
+if (mp->random_seed == 0)
+ mp->random_seed = (number_to_scaled (internal_value (mp_time)) / number_to_scaled (unity_t)) + number_to_scaled (internal_value (mp_day));
+init_randoms (mp->random_seed);
+initialize_print_selector();
+mp_normalize_selector (mp);
+if (loc < limit)
+ if (mp->buffer[loc] != '\\')
+ mp_start_input (mp); /* \&{input} assumed */
+
+@* Debugging.
+
+
+@* 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@>
+
+@* 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/mpmath.w b/Build/source/texk/web2c/mplibdir/mpmath.w
new file mode 100644
index 00000000000..6c0ee6d00a6
--- /dev/null
+++ b/Build/source/texk/web2c/mplibdir/mpmath.w
@@ -0,0 +1,1925 @@
+% $Id: mpmath.w 2118 2017-02-15 17:49:54Z luigi $
+%
+% This file is part of MetaPost;
+% the MetaPost program is in the public domain.
+% See the <Show version...> code in mpost.w for more info.
+
+% Here is TeX material that gets inserted after \input webmac
+
+\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\pct!{{\char`\%}} % percent sign in ordinary text
+\def\psqrt#1{\sqrt{\mathstrut#1}}
+
+\def\title{Math support functions for 32-bit integer math}
+\pdfoutput=1
+
+@ Introduction.
+
+@c
+#include <w2c/config.h>
+#include <stdio.h>
+#include <stdlib.h>
+#include <string.h>
+#include <math.h>
+#include "mpmath.h" /* internal header */
+@h
+
+@ @c
+@<Declarations@>;
+
+@ @(mpmath.h@>=
+#ifndef MPMATH_H
+#define MPMATH_H 1
+#include "mplib.h"
+#include "mpmp.h" /* internal header */
+@<Internal library declarations@>;
+#endif
+
+@* Math initialization.
+
+@ Here are the functions that are static as they are not used elsewhere
+
+@<Declarations@>=
+static void mp_scan_fractional_token (MP mp, int n);
+static void mp_scan_numeric_token (MP mp, int n);
+static void mp_ab_vs_cd (MP mp, mp_number *ret, mp_number a, mp_number b, mp_number c, mp_number d);
+static void mp_crossing_point (MP mp, mp_number *ret, mp_number a, mp_number b, mp_number c);
+static void mp_number_modulo (mp_number *a, mp_number b);
+static void mp_print_number (MP mp, mp_number n);
+static char * mp_number_tostring (MP mp, mp_number n);
+static void mp_slow_add (MP mp, mp_number *ret, mp_number x_orig, mp_number y_orig);
+static void mp_square_rt (MP mp, mp_number *ret, mp_number x_orig);
+static void mp_n_sin_cos (MP mp, mp_number z_orig, mp_number *n_cos, mp_number *n_sin);
+static void mp_init_randoms (MP mp, int seed);
+static void mp_number_angle_to_scaled (mp_number *A);
+static void mp_number_fraction_to_scaled (mp_number *A);
+static void mp_number_scaled_to_fraction (mp_number *A);
+static void mp_number_scaled_to_angle (mp_number *A);
+static void mp_m_unif_rand (MP mp, mp_number *ret, mp_number x_orig);
+static void mp_m_norm_rand (MP mp, mp_number *ret);
+static void mp_m_exp (MP mp, mp_number *ret, mp_number x_orig);
+static void mp_m_log (MP mp, mp_number *ret, mp_number x_orig);
+static void mp_pyth_sub (MP mp, mp_number *r, mp_number a, mp_number b);
+static void mp_n_arg (MP mp, mp_number *ret, mp_number x, mp_number y);
+static void mp_velocity (MP mp, mp_number *ret, mp_number st, mp_number ct, mp_number sf, mp_number cf, mp_number t);
+static void mp_set_number_from_int(mp_number *A, int B);
+static void mp_set_number_from_boolean(mp_number *A, int B);
+static void mp_set_number_from_scaled(mp_number *A, int B);
+static void mp_set_number_from_boolean(mp_number *A, int B);
+static void mp_set_number_from_addition(mp_number *A, mp_number B, mp_number C);
+static void mp_set_number_from_substraction (mp_number *A, mp_number B, mp_number C);
+static void mp_set_number_from_div(mp_number *A, mp_number B, mp_number C);
+static void mp_set_number_from_mul(mp_number *A, mp_number B, mp_number C);
+static void mp_set_number_from_int_div(mp_number *A, mp_number B, int C);
+static void mp_set_number_from_int_mul(mp_number *A, mp_number B, int C);
+static void mp_set_number_from_of_the_way(MP mp, mp_number *A, mp_number t, mp_number B, mp_number C);
+static void mp_number_negate(mp_number *A);
+static void mp_number_add(mp_number *A, mp_number B);
+static void mp_number_substract(mp_number *A, mp_number B);
+static void mp_number_half(mp_number *A);
+static void mp_number_halfp(mp_number *A);
+static void mp_number_double(mp_number *A);
+static void mp_number_add_scaled(mp_number *A, int B); /* also for negative B */
+static void mp_number_multiply_int(mp_number *A, int B);
+static void mp_number_divide_int(mp_number *A, int B);
+static void mp_number_abs(mp_number *A);
+static void mp_number_clone(mp_number *A, mp_number B);
+static void mp_number_swap(mp_number *A, mp_number *B);
+static int mp_round_unscaled(mp_number x_orig);
+static int mp_number_to_scaled(mp_number A);
+static int mp_number_to_boolean(mp_number A);
+static int mp_number_to_int(mp_number A);
+static int mp_number_odd(mp_number A);
+static int mp_number_equal(mp_number A, mp_number B);
+static int mp_number_greater(mp_number A, mp_number B);
+static int mp_number_less(mp_number A, mp_number B);
+static int mp_number_nonequalabs(mp_number A, mp_number B);
+static void mp_number_floor (mp_number *i);
+static void mp_fraction_to_round_scaled (mp_number *x);
+static void mp_number_make_scaled (MP mp, mp_number *r, mp_number p, mp_number q);
+static void mp_number_make_fraction (MP mp, mp_number *r, mp_number p, mp_number q);
+static void mp_number_take_fraction (MP mp, mp_number *r, mp_number p, mp_number q);
+static void mp_number_take_scaled (MP mp, mp_number *r, mp_number p, mp_number q);
+static void mp_new_number (MP mp, mp_number *n, mp_number_type t) ;
+static void mp_free_number (MP mp, mp_number *n) ;
+static void mp_free_scaled_math (MP mp);
+static void mp_scaled_set_precision (MP mp);
+
+@ And these are the ones that {\it are} used elsewhere
+
+@<Internal library declarations@>=
+void * mp_initialize_scaled_math (MP mp);
+void mp_set_number_from_double(mp_number *A, double B);
+void mp_pyth_add (MP mp, mp_number *r, mp_number a, mp_number b);
+double mp_number_to_double(mp_number A);
+
+@
+
+@d coef_bound 04525252525 /* |fraction| approximation to 7/3 */
+@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| */
+@d near_zero_angle 26844
+@d p_over_v_threshold 0x80000
+@d equation_threshold 64
+@d tfm_warn_threshold 4096
+
+
+@c
+void * mp_initialize_scaled_math (MP mp) {
+ math_data *math = (math_data *)mp_xmalloc(mp,1,sizeof(math_data));
+ /* alloc */
+ math->allocate = mp_new_number;
+ math->free = mp_free_number;
+ mp_new_number (mp, &math->precision_default, mp_scaled_type);
+ math->precision_default.data.val = unity * 10;
+ mp_new_number (mp, &math->precision_max, mp_scaled_type);
+ math->precision_max.data.val = unity * 10;
+ mp_new_number (mp, &math->precision_min, mp_scaled_type);
+ math->precision_min.data.val = unity * 10;
+ /* here are the constants for |scaled| objects */
+ mp_new_number (mp, &math->epsilon_t, mp_scaled_type);
+ math->epsilon_t.data.val = 1;
+ mp_new_number (mp, &math->inf_t, mp_scaled_type);
+ math->inf_t.data.val = EL_GORDO;
+ mp_new_number (mp, &math->warning_limit_t, mp_scaled_type);
+ math->warning_limit_t.data.val = fraction_one;
+ mp_new_number (mp, &math->one_third_inf_t, mp_scaled_type);
+ math->one_third_inf_t.data.val = one_third_EL_GORDO;
+ mp_new_number (mp, &math->unity_t, mp_scaled_type);
+ math->unity_t.data.val = unity;
+ mp_new_number (mp, &math->two_t, mp_scaled_type);
+ math->two_t.data.val = two;
+ mp_new_number (mp, &math->three_t, mp_scaled_type);
+ math->three_t.data.val = three;
+ mp_new_number (mp, &math->half_unit_t, mp_scaled_type);
+ math->half_unit_t.data.val = half_unit;
+ mp_new_number (mp, &math->three_quarter_unit_t, mp_scaled_type);
+ math->three_quarter_unit_t.data.val = three_quarter_unit;
+ mp_new_number (mp, &math->zero_t, mp_scaled_type);
+ /* |fractions| */
+ mp_new_number (mp, &math->arc_tol_k, mp_fraction_type);
+ math->arc_tol_k.data.val = (unity/4096); /* quit when change in arc length estimate reaches this */
+ mp_new_number (mp, &math->fraction_one_t, mp_fraction_type);
+ math->fraction_one_t.data.val = fraction_one;
+ mp_new_number (mp, &math->fraction_half_t, mp_fraction_type);
+ math->fraction_half_t.data.val = fraction_half;
+ mp_new_number (mp, &math->fraction_three_t, mp_fraction_type);
+ math->fraction_three_t.data.val = fraction_three;
+ mp_new_number (mp, &math->fraction_four_t, mp_fraction_type);
+ math->fraction_four_t.data.val = fraction_four;
+ /* |angles| */
+ mp_new_number (mp, &math->three_sixty_deg_t, mp_angle_type);
+ math->three_sixty_deg_t.data.val = three_sixty_deg;
+ mp_new_number (mp, &math->one_eighty_deg_t, mp_angle_type);
+ math->one_eighty_deg_t.data.val = one_eighty_deg;
+ /* various approximations */
+ mp_new_number (mp, &math->one_k, mp_scaled_type);
+ math->one_k.data.val = 1024;
+ mp_new_number (mp, &math->sqrt_8_e_k, mp_scaled_type);
+ math->sqrt_8_e_k.data.val = 112429; /* $2^{16}\sqrt{8/e}\approx 112428.82793$ */
+ mp_new_number (mp, &math->twelve_ln_2_k, mp_fraction_type);
+ math->twelve_ln_2_k.data.val = 139548960; /* $2^{24}\cdot12\ln2\approx139548959.6165$ */
+ mp_new_number (mp, &math->coef_bound_k, mp_fraction_type);
+ math->coef_bound_k.data.val = coef_bound;
+ mp_new_number (mp, &math->coef_bound_minus_1, mp_fraction_type);
+ math->coef_bound_minus_1.data.val = coef_bound - 1;
+ mp_new_number (mp, &math->twelvebits_3, mp_scaled_type);
+ math->twelvebits_3.data.val = 1365; /* $1365\approx 2^{12}/3$ */
+ mp_new_number (mp, &math->twentysixbits_sqrt2_t, mp_fraction_type);
+ math->twentysixbits_sqrt2_t.data.val = 94906266; /* $2^{26}\sqrt2\approx94906265.62$ */
+ mp_new_number (mp, &math->twentyeightbits_d_t, mp_fraction_type);
+ math->twentyeightbits_d_t.data.val = 35596755; /* $2^{28}d\approx35596754.69$ */
+ mp_new_number (mp, &math->twentysevenbits_sqrt2_d_t, mp_fraction_type);
+ math->twentysevenbits_sqrt2_d_t.data.val = 25170707; /* $2^{27}\sqrt2\,d\approx25170706.63$ */
+ /* thresholds */
+ mp_new_number (mp, &math->fraction_threshold_t, mp_fraction_type);
+ math->fraction_threshold_t.data.val = fraction_threshold;
+ mp_new_number (mp, &math->half_fraction_threshold_t, mp_fraction_type);
+ math->half_fraction_threshold_t.data.val = half_fraction_threshold;
+ mp_new_number (mp, &math->scaled_threshold_t, mp_scaled_type);
+ math->scaled_threshold_t.data.val = scaled_threshold;
+ mp_new_number (mp, &math->half_scaled_threshold_t, mp_scaled_type);
+ math->half_scaled_threshold_t.data.val = half_scaled_threshold;
+ mp_new_number (mp, &math->near_zero_angle_t, mp_angle_type);
+ math->near_zero_angle_t.data.val = near_zero_angle;
+ mp_new_number (mp, &math->p_over_v_threshold_t, mp_fraction_type);
+ math->p_over_v_threshold_t.data.val = p_over_v_threshold;
+ mp_new_number (mp, &math->equation_threshold_t, mp_scaled_type);
+ math->equation_threshold_t.data.val = equation_threshold;
+ mp_new_number (mp, &math->tfm_warn_threshold_t, mp_scaled_type);
+ math->tfm_warn_threshold_t.data.val = tfm_warn_threshold;
+ /* functions */
+ math->from_int = mp_set_number_from_int;
+ math->from_boolean = mp_set_number_from_boolean;
+ math->from_scaled = mp_set_number_from_scaled;
+ math->from_double = mp_set_number_from_double;
+ math->from_addition = mp_set_number_from_addition;
+ math->from_substraction = mp_set_number_from_substraction;
+ math->from_oftheway = mp_set_number_from_of_the_way;
+ math->from_div = mp_set_number_from_div;
+ math->from_mul = mp_set_number_from_mul;
+ math->from_int_div = mp_set_number_from_int_div;
+ math->from_int_mul = mp_set_number_from_int_mul;
+ math->negate = mp_number_negate;
+ math->add = mp_number_add;
+ math->substract = mp_number_substract;
+ math->half = mp_number_half;
+ math->halfp = mp_number_halfp;
+ math->do_double = mp_number_double;
+ math->abs = mp_number_abs;
+ math->clone = mp_number_clone;
+ math->swap = mp_number_swap;
+ math->add_scaled = mp_number_add_scaled;
+ math->multiply_int = mp_number_multiply_int;
+ math->divide_int = mp_number_divide_int;
+ math->to_int = mp_number_to_int;
+ math->to_boolean = mp_number_to_boolean;
+ math->to_scaled = mp_number_to_scaled;
+ math->to_double = mp_number_to_double;
+ math->odd = mp_number_odd;
+ math->equal = mp_number_equal;
+ math->less = mp_number_less;
+ math->greater = mp_number_greater;
+ math->nonequalabs = mp_number_nonequalabs;
+ math->round_unscaled = mp_round_unscaled;
+ math->floor_scaled = mp_number_floor;
+ math->fraction_to_round_scaled = mp_fraction_to_round_scaled;
+ math->make_scaled = mp_number_make_scaled;
+ math->make_fraction = mp_number_make_fraction;
+ math->take_fraction = mp_number_take_fraction;
+ math->take_scaled = mp_number_take_scaled;
+ math->velocity = mp_velocity;
+ math->n_arg = mp_n_arg;
+ math->m_log = mp_m_log;
+ math->m_exp = mp_m_exp;
+ math->m_unif_rand = mp_m_unif_rand;
+ math->m_norm_rand = mp_m_norm_rand;
+ math->pyth_add = mp_pyth_add;
+ math->pyth_sub = mp_pyth_sub;
+ math->fraction_to_scaled = mp_number_fraction_to_scaled;
+ math->scaled_to_fraction = mp_number_scaled_to_fraction;
+ math->scaled_to_angle = mp_number_scaled_to_angle;
+ math->angle_to_scaled = mp_number_angle_to_scaled;
+ math->init_randoms = mp_init_randoms;
+ math->sin_cos = mp_n_sin_cos;
+ math->slow_add = mp_slow_add;
+ math->sqrt = mp_square_rt;
+ math->print = mp_print_number;
+ math->tostring = mp_number_tostring;
+ math->modulo = mp_number_modulo;
+ math->ab_vs_cd = mp_ab_vs_cd;
+ math->crossing_point = mp_crossing_point;
+ math->scan_numeric = mp_scan_numeric_token;
+ math->scan_fractional = mp_scan_fractional_token;
+ math->free_math = mp_free_scaled_math;
+ math->set_precision = mp_scaled_set_precision;
+ return (void *)math;
+}
+
+void mp_scaled_set_precision (MP mp) {
+}
+
+void mp_free_scaled_math (MP mp) {
+ free_number (((math_data *)mp->math)->epsilon_t);
+ free_number (((math_data *)mp->math)->inf_t);
+ free_number (((math_data *)mp->math)->arc_tol_k);
+ free_number (((math_data *)mp->math)->three_sixty_deg_t);
+ free_number (((math_data *)mp->math)->one_eighty_deg_t);
+ free_number (((math_data *)mp->math)->fraction_one_t);
+ free_number (((math_data *)mp->math)->fraction_half_t);
+ free_number (((math_data *)mp->math)->fraction_three_t);
+ free_number (((math_data *)mp->math)->fraction_four_t);
+ free_number (((math_data *)mp->math)->zero_t);
+ free_number (((math_data *)mp->math)->half_unit_t);
+ free_number (((math_data *)mp->math)->three_quarter_unit_t);
+ free_number (((math_data *)mp->math)->unity_t);
+ free_number (((math_data *)mp->math)->two_t);
+ free_number (((math_data *)mp->math)->three_t);
+ free_number (((math_data *)mp->math)->one_third_inf_t);
+ free_number (((math_data *)mp->math)->warning_limit_t);
+ free_number (((math_data *)mp->math)->one_k);
+ free_number (((math_data *)mp->math)->sqrt_8_e_k);
+ free_number (((math_data *)mp->math)->twelve_ln_2_k);
+ free_number (((math_data *)mp->math)->coef_bound_k);
+ free_number (((math_data *)mp->math)->coef_bound_minus_1);
+ free_number (((math_data *)mp->math)->twelvebits_3);
+ free_number (((math_data *)mp->math)->twentysixbits_sqrt2_t);
+ free_number (((math_data *)mp->math)->twentyeightbits_d_t);
+ free_number (((math_data *)mp->math)->twentysevenbits_sqrt2_d_t);
+ free_number (((math_data *)mp->math)->fraction_threshold_t);
+ free_number (((math_data *)mp->math)->half_fraction_threshold_t);
+ free_number (((math_data *)mp->math)->scaled_threshold_t);
+ free_number (((math_data *)mp->math)->half_scaled_threshold_t);
+ free_number (((math_data *)mp->math)->near_zero_angle_t);
+ free_number (((math_data *)mp->math)->p_over_v_threshold_t);
+ free_number (((math_data *)mp->math)->equation_threshold_t);
+ free_number (((math_data *)mp->math)->tfm_warn_threshold_t);
+ free(mp->math);
+}
+
+@ Creating an destroying |mp_number| objects
+
+@ @c
+void mp_new_number (MP mp, mp_number *n, mp_number_type t) {
+ (void)mp;
+ n->data.val = 0;
+ n->type = t;
+}
+
+@
+@c
+void mp_free_number (MP mp, mp_number *n) {
+ (void)mp;
+ n->type = mp_nan_type;
+}
+
+@ Here are the low-level functions on |mp_number| items, setters first.
+
+@c
+void mp_set_number_from_int(mp_number *A, int B) {
+ A->data.val = B;
+}
+void mp_set_number_from_boolean(mp_number *A, int B) {
+ A->data.val = B;
+}
+void mp_set_number_from_scaled(mp_number *A, int B) {
+ A->data.val = B;
+}
+void mp_set_number_from_double(mp_number *A, double B) {
+ A->data.val = (int)(B*65536.0);
+}
+void mp_set_number_from_addition(mp_number *A, mp_number B, mp_number C) {
+ A->data.val = B.data.val+C.data.val;
+}
+void mp_set_number_from_substraction (mp_number *A, mp_number B, mp_number C) {
+ A->data.val = B.data.val-C.data.val;
+}
+void mp_set_number_from_div(mp_number *A, mp_number B, mp_number C) {
+ A->data.val = B.data.val / C.data.val;
+}
+void mp_set_number_from_mul(mp_number *A, mp_number B, mp_number C) {
+ A->data.val = B.data.val * C.data.val;
+}
+void mp_set_number_from_int_div(mp_number *A, mp_number B, int C) {
+ A->data.val = B.data.val / C;
+}
+void mp_set_number_from_int_mul(mp_number *A, mp_number B, int C) {
+ A->data.val = B.data.val * C;
+}
+void mp_set_number_from_of_the_way(MP mp, mp_number *A, mp_number t, mp_number B, mp_number C) {
+ A->data.val = B.data.val - mp_take_fraction(mp, (B.data.val - C.data.val), t.data.val);
+}
+void mp_number_negate(mp_number *A) {
+ A->data.val = -A->data.val;
+}
+void mp_number_add(mp_number *A, mp_number B) {
+ A->data.val = A->data.val + B.data.val;
+}
+void mp_number_substract(mp_number *A, mp_number B) {
+ A->data.val = A->data.val - B.data.val;
+}
+void mp_number_half(mp_number *A) {
+ A->data.val = A->data.val/2;
+}
+void mp_number_halfp(mp_number *A) {
+ A->data.val = (A->data.val>>1);
+}
+void mp_number_double(mp_number *A) {
+ A->data.val = A->data.val + A->data.val;
+}
+void mp_number_add_scaled(mp_number *A, int B) { /* also for negative B */
+ A->data.val = A->data.val + B;
+}
+void mp_number_multiply_int(mp_number *A, int B) {
+ A->data.val = B * A->data.val;
+}
+void mp_number_divide_int(mp_number *A, int B) {
+ A->data.val = A->data.val / B;
+}
+void mp_number_abs(mp_number *A) {
+ A->data.val = abs(A->data.val);
+}
+void mp_number_clone(mp_number *A, mp_number B) {
+ A->data.val = B.data.val;
+}
+void mp_number_swap(mp_number *A, mp_number *B) {
+ int swap_tmp = A->data.val;
+ A->data.val = B->data.val;
+ B->data.val = swap_tmp;
+}
+void mp_number_fraction_to_scaled (mp_number *A) {
+ A->type = mp_scaled_type;
+ A->data.val = A->data.val / 4096;
+}
+void mp_number_angle_to_scaled (mp_number *A) {
+ A->type = mp_scaled_type;
+ if (A->data.val >= 0) {
+ A->data.val = (A->data.val + 8) / 16;
+ } else {
+ A->data.val = -((-A->data.val + 8) / 16);
+ }
+}
+void mp_number_scaled_to_fraction (mp_number *A) {
+ A->type = mp_fraction_type;
+ A->data.val = A->data.val * 4096;
+}
+void mp_number_scaled_to_angle (mp_number *A) {
+ A->type = mp_angle_type;
+ A->data.val = A->data.val * 16;
+}
+
+
+@ Query functions
+
+@c
+int mp_number_to_int(mp_number A) {
+ return A.data.val;
+}
+int mp_number_to_scaled(mp_number A) {
+ return A.data.val;
+}
+int mp_number_to_boolean(mp_number A) {
+ return A.data.val;
+}
+double mp_number_to_double(mp_number A) {
+ return (A.data.val/65536.0);
+}
+int mp_number_odd(mp_number A) {
+ return odd(A.data.val);
+}
+int mp_number_equal(mp_number A, mp_number B) {
+ return (A.data.val==B.data.val);
+}
+int mp_number_greater(mp_number A, mp_number B) {
+ return (A.data.val>B.data.val);
+}
+int mp_number_less(mp_number A, mp_number B) {
+ return (A.data.val<B.data.val);
+}
+int mp_number_nonequalabs(mp_number A, mp_number B) {
+ return (!(abs(A.data.val)==abs(B.data.val)));
+}
+
+@ Fixed-point arithmetic is done on {\sl scaled integers\/} that are multiples
+of $2^{-16}$. In other words, a binary point is assumed to be sixteen bit
+positions from the right end of a binary computer word.
+
+@d unity 0x10000 /* $2^{16}$, represents 1.00000 */
+@d two (2*unity) /* $2^{17}$, represents 2.00000 */
+@d three (3*unity) /* $2^{17}+2^{16}$, represents 3.00000 */
+@d half_unit (unity/2) /* $2^{15}$, represents 0.50000 */
+@d three_quarter_unit (3*(unity/4)) /* $3\cdot2^{14}$, represents 0.75000 */
+
+@d EL_GORDO 0x7fffffff /* $2^{31}-1$, the largest value that \MP\ likes */
+@d one_third_EL_GORDO 05252525252
+
+@ One of \MP's most common operations is the calculation of
+$\lfloor{a+b\over2}\rfloor$,
+the midpoint of two given integers |a| and~|b|. The most decent way to do
+this is to write `|(a+b)/2|'; but on many machines it is more efficient
+to calculate `|(a+b)>>1|'.
+
+Therefore the midpoint operation will always be denoted by `|half(a+b)|'
+in this program. If \MP\ is being implemented with languages that permit
+binary shifting, the |half| macro should be changed to make this operation
+as efficient as possible. Since some systems have shift operators that can
+only be trusted to work on positive numbers, there is also a macro |halfp|
+that is used only when the quantity being halved is known to be positive
+or zero.
+
+@d halfp(A) (integer)((unsigned)(A) >> 1)
+
+@ 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.
+
+@<Declarations@>=
+static void mp_print_scaled (MP mp, int s); /* scaled */
+static char *mp_string_scaled (MP mp, int s);
+
+@ @c
+static void mp_print_scaled (MP mp, int s) { /* s=scaled prints scaled real, rounded to five digits */
+ int delta; /* amount of allowable inaccuracy, scaled */
+ if (s < 0) {
+ mp_print_char (mp, xord ('-'));
+ s = -s; /* print the sign, if negative */
+ }
+ mp_print_int (mp, s / unity); /* print the integer part */
+ s = 10 * (s % unity) + 5;
+ if (s != 5) {
+ delta = 10;
+ mp_print_char (mp, xord ('.'));
+ do {
+ if (delta > unity)
+ s = s + 0100000 - (delta / 2); /* round the final digit */
+ mp_print_char (mp, xord ('0' + (s / unity)));
+ s = 10 * (s % unity);
+ delta = delta * 10;
+ } while (s > delta);
+ }
+}
+
+static char *mp_string_scaled (MP mp, int s) { /* s=scaled prints scaled real, rounded to five digits */
+ static char scaled_string[32];
+ int delta; /* amount of allowable inaccuracy, scaled */
+ int i = 0;
+ if (s < 0) {
+ scaled_string[i++] = xord ('-');
+ s = -s; /* print the sign, if negative */
+ }
+ /* print the integer part */
+ mp_snprintf ((scaled_string+i), 12, "%d", (int) (s / unity));
+ while (*(scaled_string+i)) i++;
+
+ s = 10 * (s % unity) + 5;
+ if (s != 5) {
+ delta = 10;
+ scaled_string[i++] = xord ('.');
+ do {
+ if (delta > unity)
+ s = s + 0100000 - (delta / 2); /* round the final digit */
+ scaled_string[i++] = xord ('0' + (s / unity));
+ s = 10 * (s % unity);
+ delta = delta * 10;
+ } while (s > delta);
+ }
+ scaled_string[i] = '\0';
+ return scaled_string;
+}
+
+@ Addition is not always checked to make sure that it doesn't overflow,
+but in places where overflow isn't too unlikely the |slow_add| routine
+is used.
+
+@c
+void mp_slow_add (MP mp, mp_number *ret, mp_number x_orig, mp_number y_orig) {
+ integer x, y;
+ x = x_orig.data.val;
+ y = y_orig.data.val;
+ if (x >= 0) {
+ if (y <= EL_GORDO - x) {
+ ret->data.val = x + y;
+ } else {
+ mp->arith_error = true;
+ ret->data.val = EL_GORDO;
+ }
+ } else if (-y <= EL_GORDO + x) {
+ ret->data.val = x + y;
+ } else {
+ mp->arith_error = true;
+ ret->data.val = -EL_GORDO;
+ }
+}
+
+@ The |make_fraction| routine produces the |fraction| equivalent of
+|p/q|, given integers |p| and~|q|; it computes the integer
+$f=\lfloor2^{28}p/q+{1\over2}\rfloor$, when $p$ and $q$ are
+positive. If |p| and |q| are both of the same scaled type |t|,
+the ``type relation'' |make_fraction(t,t)=fraction| is valid;
+and it's also possible to use the subroutine ``backwards,'' using
+the relation |make_fraction(t,fraction)=t| between scaled types.
+
+If the result would have magnitude $2^{31}$ or more, |make_fraction|
+sets |arith_error:=true|. Most of \MP's internal computations have
+been designed to avoid this sort of error.
+
+If this subroutine were programmed in assembly language on a typical
+machine, we could simply compute |(@t$2^{28}$@>*p)div q|, since a
+double-precision product can often be input to a fixed-point division
+instruction. But when we are restricted to int-eger arithmetic it
+is necessary either to resort to multiple-precision maneuvering
+or to use a simple but slow iteration. The multiple-precision technique
+would be about three times faster than the code adopted here, but it
+would be comparatively long and tricky, involving about sixteen
+additional multiplications and divisions.
+
+This operation is part of \MP's ``inner loop''; indeed, it will
+consume nearly 10\pct! of the running time (exclusive of input and output)
+if the code below is left unchanged. A machine-dependent recoding
+will therefore make \MP\ run faster. The present implementation
+is highly portable, but slow; it avoids multiplication and division
+except in the initial stage. System wizards should be careful to
+replace it with a routine that is guaranteed to produce identical
+results in all cases.
+@^system dependencies@>
+
+As noted below, a few more routines should also be replaced by machine-dependent
+code, for efficiency. But when a procedure is not part of the ``inner loop,''
+such changes aren't advisable; simplicity and robustness are
+preferable to trickery, unless the cost is too high.
+@^inner loop@>
+
+@ We need these preprocessor values
+
+@d TWEXP31 2147483648.0
+@d TWEXP28 268435456.0
+@d TWEXP16 65536.0
+@d TWEXP_16 (1.0/65536.0)
+@d TWEXP_28 (1.0/268435456.0)
+
+
+@c
+static integer mp_make_fraction (MP mp, integer p, integer q) {
+ integer i;
+ if (q == 0)
+ mp_confusion (mp, "/");
+@:this can't happen /}{\quad \./@>
+ {
+ register double d;
+ d = TWEXP28 * (double) p / (double) q;
+ if ((p ^ q) >= 0) {
+ d += 0.5;
+ if (d >= TWEXP31) {
+ mp->arith_error = true;
+ i = EL_GORDO;
+ goto RETURN;
+ }
+ i = (integer) d;
+ if (d == (double) i && (((q > 0 ? -q : q) & 077777)
+ * (((i & 037777) << 1) - 1) & 04000) != 0)
+ --i;
+ } else {
+ d -= 0.5;
+ if (d <= -TWEXP31) {
+ mp->arith_error = true;
+ i = -EL_GORDO;
+ goto RETURN;
+ }
+ i = (integer) d;
+ if (d == (double) i && (((q > 0 ? q : -q) & 077777)
+ * (((i & 037777) << 1) + 1) & 04000) != 0)
+ ++i;
+ }
+ }
+RETURN:
+ return i;
+}
+void mp_number_make_fraction (MP mp, mp_number *ret, mp_number p, mp_number q) {
+ ret->data.val = mp_make_fraction (mp, p.data.val, q.data.val);
+}
+
+
+@ 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@>
+
+@<Internal library declarations@>=
+/* still in use by tfmin.w */
+integer mp_take_fraction (MP mp, integer q, int f);
+
+@ @c
+integer mp_take_fraction (MP mp, integer p, int q) { /* q = fraction */
+ register double d;
+ register integer i;
+ d = (double) p *(double) q *TWEXP_28;
+ if ((p ^ q) >= 0) {
+ d += 0.5;
+ if (d >= TWEXP31) {
+ if (d != TWEXP31 || (((p & 077777) * (q & 077777)) & 040000) == 0)
+ mp->arith_error = true;
+ return EL_GORDO;
+ }
+ i = (integer) d;
+ if (d == (double) i && (((p & 077777) * (q & 077777)) & 040000) != 0)
+ --i;
+ } else {
+ d -= 0.5;
+ if (d <= -TWEXP31) {
+ if (d != -TWEXP31 || ((-(p & 077777) * (q & 077777)) & 040000) == 0)
+ mp->arith_error = true;
+ return -EL_GORDO;
+ }
+ i = (integer) d;
+ if (d == (double) i && ((-(p & 077777) * (q & 077777)) & 040000) != 0)
+ ++i;
+ }
+ return i;
+}
+void mp_number_take_fraction (MP mp, mp_number *ret, mp_number p_orig, mp_number q_orig) {
+ ret->data.val = mp_take_fraction (mp, p_orig.data.val, q_orig.data.val);
+}
+
+
+@ 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@>
+
+@<Declarations@>=
+static integer mp_take_scaled (MP mp, integer q, int f);
+
+@ @c
+static integer mp_take_scaled (MP mp, integer p, int q) { /* q = scaled */
+ register double d;
+ register integer i;
+ d = (double) p *(double) q *TWEXP_16;
+ if ((p ^ q) >= 0) {
+ d += 0.5;
+ if (d >= TWEXP31) {
+ if (d != TWEXP31 || (((p & 077777) * (q & 077777)) & 040000) == 0)
+ mp->arith_error = true;
+ return EL_GORDO;
+ }
+ i = (integer) d;
+ if (d == (double) i && (((p & 077777) * (q & 077777)) & 040000) != 0)
+ --i;
+ } else {
+ d -= 0.5;
+ if (d <= -TWEXP31) {
+ if (d != -TWEXP31 || ((-(p & 077777) * (q & 077777)) & 040000) == 0)
+ mp->arith_error = true;
+ return -EL_GORDO;
+ }
+ i = (integer) d;
+ if (d == (double) i && ((-(p & 077777) * (q & 077777)) & 040000) != 0)
+ ++i;
+ }
+ return i;
+}
+void mp_number_take_scaled (MP mp, mp_number *ret, mp_number p_orig, mp_number q_orig) {
+ ret->data.val = mp_take_scaled (mp, p_orig.data.val, q_orig.data.val);
+}
+
+
+@ For completeness, there's also |make_scaled|, which computes a
+quotient as a |scaled| number instead of as a |fraction|.
+In other words, the result is $\lfloor2^{16}p/q+{1\over2}\rfloor$, if the
+operands are positive. \ (This procedure is not used especially often,
+so it is not part of \MP's inner loop.)
+
+@<Internal library ...@>=
+/* still in use by svgout.w */
+int mp_make_scaled (MP mp, integer p, integer q);
+
+@ @c
+int mp_make_scaled (MP mp, integer p, integer q) { /* return scaled */
+ register integer i;
+ if (q == 0)
+ mp_confusion (mp, "/");
+@:this can't happen /}{\quad \./@> {
+ register double d;
+ d = TWEXP16 * (double) p / (double) q;
+ if ((p ^ q) >= 0) {
+ d += 0.5;
+ if (d >= TWEXP31) {
+ mp->arith_error = true;
+ return EL_GORDO;
+ }
+ i = (integer) d;
+ if (d == (double) i && (((q > 0 ? -q : q) & 077777)
+ * (((i & 037777) << 1) - 1) & 04000) != 0)
+ --i;
+ } else {
+ d -= 0.5;
+ if (d <= -TWEXP31) {
+ mp->arith_error = true;
+ return -EL_GORDO;
+ }
+ i = (integer) d;
+ if (d == (double) i && (((q > 0 ? q : -q) & 077777)
+ * (((i & 037777) << 1) + 1) & 04000) != 0)
+ ++i;
+ }
+ }
+ return i;
+}
+void mp_number_make_scaled (MP mp, mp_number *ret, mp_number p_orig, mp_number q_orig) {
+ ret->data.val = mp_make_scaled (mp, p_orig.data.val, q_orig.data.val);
+}
+
+@ 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|.
+
+@<Declarations@>=
+static int mp_round_decimals (MP mp, unsigned char *b, quarterword k);
+
+@ @c
+static int mp_round_decimals (MP mp, unsigned char *b, quarterword k) { /* return: scaled */
+ /* converts a decimal fraction */
+ unsigned a = 0; /* the accumulator */
+ int l = 0;
+ (void)mp; /* Will be needed later */
+ for ( l = k-1; l >= 0; l-- ) {
+ if (l<16) /* digits for |k>=17| cannot affect the result */
+ a = (a + (unsigned) (*(b+l) - '0') * two) / 10;
+ }
+ return (int) halfp (a + 1);
+}
+
+@* Scanning numbers in the input.
+
+The definitions below are temporarily here.
+
+@d set_cur_cmd(A) mp->cur_mod_->type=(A)
+@d set_cur_mod(A) mp->cur_mod_->data.n.data.val=(A)
+
+@<Declarations...@>=
+static void mp_wrapup_numeric_token(MP mp, int n, int f);
+
+@ @c
+static void mp_wrapup_numeric_token(MP mp, int n, int f) { /* n,f: scaled */
+ int mod ; /* scaled */
+ if (n < 32768) {
+ mod = (n * unity + f);
+ set_cur_mod(mod);
+ if (mod >= fraction_one) {
+ if (internal_value (mp_warning_check).data.val > 0 &&
+ (mp->scanner_status != tex_flushing)) {
+ char msg[256];
+ const char *hlp[] = {"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.)",
+ NULL };
+ mp_snprintf (msg, 256, "Number is too large (%s)", mp_string_scaled(mp,mod));
+@.Number is too large@>;
+ mp_error (mp, msg, hlp, true);
+ }
+ }
+ } else if (mp->scanner_status != tex_flushing) {
+ const char *hlp[] = {"I can\'t handle numbers bigger than 32767.99998;",
+ "so I've changed your constant to that maximum amount.",
+ NULL };
+ mp_error (mp, "Enormous number has been reduced", hlp, false);
+@.Enormous number...@>;
+ set_cur_mod(EL_GORDO);
+ }
+ set_cur_cmd((mp_variable_type)mp_numeric_token);
+}
+
+@ @c
+void mp_scan_fractional_token (MP mp, int n) { /* n: scaled */
+ int f; /* scaled */
+ int k = 0;
+ do {
+ k++;
+ mp->cur_input.loc_field++;
+ } while (mp->char_class[mp->buffer[mp->cur_input.loc_field]] == digit_class);
+ f = mp_round_decimals (mp, (unsigned char *)(mp->buffer+mp->cur_input.loc_field-k), (quarterword) k);
+ if (f == unity) {
+ n++;
+ f = 0;
+ }
+ mp_wrapup_numeric_token(mp, n, f);
+}
+
+
+@ @c
+void mp_scan_numeric_token (MP mp, int n) { /* n: scaled */
+ while (mp->char_class[mp->buffer[mp->cur_input.loc_field]] == digit_class) {
+ if (n < 32768)
+ n = 10 * n + mp->buffer[mp->cur_input.loc_field] - '0';
+ mp->cur_input.loc_field++;
+ }
+ if (!(mp->buffer[mp->cur_input.loc_field] == '.' &&
+ mp->char_class[mp->buffer[mp->cur_input.loc_field + 1]] == digit_class)) {
+ mp_wrapup_numeric_token(mp, n, 0);
+ } else {
+ mp->cur_input.loc_field++;
+ mp_scan_fractional_token(mp, n);
+ }
+}
+
+@ The |scaled| quantities in \MP\ programs are generally supposed to be
+less than $2^{12}$ in absolute value, so \MP\ does much of its internal
+arithmetic with 28~significant bits of precision. A |fraction| denotes
+a scaled integer whose binary point is assumed to be 28 bit positions
+from the right.
+
+@d fraction_half 01000000000 /* $2^{27}$, represents 0.50000000 */
+@d fraction_one 02000000000 /* $2^{28}$, represents 1.00000000 */
+@d fraction_two 04000000000 /* $2^{29}$, represents 2.00000000 */
+@d fraction_three 06000000000 /* $3\cdot2^{28}$, represents 3.00000000 */
+@d fraction_four 010000000000 /* $2^{30}$, represents 4.00000000 */
+
+@ Here is a typical example of how the routines above can be used.
+It computes the function
+$${1\over3\tau}f(\theta,\phi)=
+{\tau^{-1}\bigl(2+\sqrt2\,(\sin\theta-{1\over16}\sin\phi)
+ (\sin\phi-{1\over16}\sin\theta)(\cos\theta-\cos\phi)\bigr)\over
+3\,\bigl(1+{1\over2}(\sqrt5-1)\cos\theta+{1\over2}(3-\sqrt5\,)\cos\phi\bigr)},$$
+where $\tau$ is a |scaled| ``tension'' parameter. This is \MP's magic
+fudge factor for placing the first control point of a curve that starts
+at an angle $\theta$ and ends at an angle $\phi$ from the straight path.
+(Actually, if the stated quantity exceeds 4, \MP\ reduces it to~4.)
+
+The trigonometric quantity to be multiplied by $\sqrt2$ is less than $\sqrt2$.
+(It's a sum of eight terms whose absolute values can be bounded using
+relations such as $\sin\theta\cos\theta\L{1\over2}$.) Thus the numerator
+is positive; and since the tension $\tau$ is constrained to be at least
+$3\over4$, the numerator is less than $16\over3$. The denominator is
+nonnegative and at most~6. Hence the fixed-point calculations below
+are guaranteed to stay within the bounds of a 32-bit computer word.
+
+The angles $\theta$ and $\phi$ are given implicitly in terms of |fraction|
+arguments |st|, |ct|, |sf|, and |cf|, representing $\sin\theta$, $\cos\theta$,
+$\sin\phi$, and $\cos\phi$, respectively.
+
+@c
+void mp_velocity (MP mp, mp_number *ret, mp_number st, mp_number ct, mp_number sf,
+ mp_number cf, mp_number t) {
+ integer acc, num, denom; /* registers for intermediate calculations */
+ acc = mp_take_fraction (mp, st.data.val - (sf.data.val / 16), sf.data.val - (st.data.val / 16));
+ acc = mp_take_fraction (mp, acc, ct.data.val - cf.data.val);
+ num = fraction_two + mp_take_fraction (mp, acc, 379625062);
+ /* $2^{28}\sqrt2\approx379625062.497$ */
+ denom =
+ fraction_three + mp_take_fraction (mp, ct.data.val,
+ 497706707) + mp_take_fraction (mp, cf.data.val,
+ 307599661);
+ /* $3\cdot2^{27}\cdot(\sqrt5-1)\approx497706706.78$ and
+ $3\cdot2^{27}\cdot(3-\sqrt5\,)\approx307599661.22$ */
+ if (t.data.val != unity)
+ num = mp_make_scaled (mp, num, t.data.val); /* |make_scaled(fraction,scaled)=fraction| */
+ if (num / 4 >= denom) {
+ ret->data.val = fraction_four;
+ } else {
+ ret->data.val = mp_make_fraction (mp, num, denom);
+ }
+/* |printf ("num,denom=%f,%f -=> %f\n", num/65536.0, denom/65536.0, ret.data.val/65536.0);|*/
+}
+
+
+@ 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.
+
+@c
+static void mp_ab_vs_cd (MP mp, mp_number *ret, mp_number a_orig, mp_number b_orig, mp_number c_orig, mp_number d_orig) {
+ integer q, r; /* temporary registers */
+ integer a, b, c, d;
+ (void)mp;
+ a = a_orig.data.val;
+ b = b_orig.data.val;
+ c = c_orig.data.val;
+ d = d_orig.data.val;
+ @<Reduce to the case that |a,c>=0|, |b,d>0|@>;
+ while (1) {
+ q = a / d;
+ r = c / b;
+ if (q != r) {
+ ret->data.val = (q > r ? 1 : -1);
+ return;
+ }
+ q = a % d;
+ r = c % b;
+ if (r == 0) {
+ ret->data.val = (q ? 1 : 0);
+ return;
+ }
+ if (q == 0) {
+ ret->data.val = -1;
+ return;
+ }
+ a = b;
+ b = q;
+ c = d;
+ d = r;
+ } /* now |a>d>0| and |c>b>0| */
+}
+
+
+@ @<Reduce to the case that |a...@>=
+if (a < 0) {
+ a = -a;
+ b = -b;
+}
+if (c < 0) {
+ c = -c;
+ d = -d;
+}
+if (d <= 0) {
+ if (b >= 0) {
+ if ((a == 0 || b == 0) && (c == 0 || d == 0))
+ ret->data.val = 0;
+ else
+ ret->data.val = 1;
+ return;
+ }
+ if (d == 0) {
+ ret->data.val = (a == 0 ? 0 : -1);
+ return;
+ }
+ q = a;
+ a = c;
+ c = q;
+ q = -b;
+ b = -d;
+ d = q;
+} else if (b <= 0) {
+ if (b < 0 && a > 0) {
+ ret->data.val = -1;
+ return;
+ }
+ ret->data.val = (c == 0 ? 0 : -1);
+ return;
+}
+
+@ 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.
+
+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}$.
+
+@d no_crossing { ret->data.val = fraction_one + 1; return; }
+@d one_crossing { ret->data.val = fraction_one; return; }
+@d zero_crossing { ret->data.val = 0; return; }
+
+@c
+static void mp_crossing_point (MP mp, mp_number *ret, mp_number aa, mp_number bb, mp_number cc) {
+ integer a,b,c;
+ integer d; /* recursive counter */
+ integer x, xx, x0, x1, x2; /* temporary registers for bisection */
+ a = aa.data.val;
+ b = bb.data.val;
+ c = cc.data.val;
+ if (a < 0)
+ zero_crossing;
+ if (c >= 0) {
+ if (b >= 0) {
+ if (c > 0) {
+ no_crossing;
+ } else if ((a == 0) && (b == 0)) {
+ no_crossing;
+ } else {
+ one_crossing;
+ }
+ }
+ if (a == 0)
+ zero_crossing;
+ } else if (a == 0) {
+ if (b <= 0)
+ zero_crossing;
+ }
+
+ /* Use bisection to find the crossing point... */
+ d = 1;
+ x0 = a;
+ x1 = a - b;
+ x2 = b - c;
+ do {
+ x = (x1 + x2) / 2;
+ if (x1 - x0 > x0) {
+ x2 = x;
+ x0 += x0;
+ d += d;
+ } else {
+ xx = x1 + x - x0;
+ if (xx > x0) {
+ x2 = x;
+ x0 += x0;
+ d += d;
+ } else {
+ x0 = x0 - xx;
+ if (x <= x0) {
+ if (x + x2 <= x0)
+ no_crossing;
+ }
+ x1 = x;
+ d = d + d + 1;
+ }
+ }
+ } while (d < fraction_one);
+ ret->data.val = (d - fraction_one);
+}
+
+
+@ We conclude this set of elementary routines with some simple rounding
+and truncation operations.
+
+
+@ |round_unscaled| rounds a |scaled| and converts it to |int|
+@c
+int mp_round_unscaled(mp_number x_orig) {
+ int x = x_orig.data.val;
+ if (x >= 32768) {
+ return 1+((x-32768) / 65536);
+ } else if ( x>=-32768) {
+ return 0;
+ } else {
+ return -(1+((-(x+1)-32768) / 65536));
+ }
+}
+
+@ |number_floor| floors a |scaled|
+
+@c
+void mp_number_floor (mp_number *i) {
+ i->data.val = i->data.val&-65536;
+}
+
+@ |fraction_to_scaled| rounds a |fraction| and converts it to |scaled|
+@c
+void mp_fraction_to_round_scaled (mp_number *x_orig) {
+ int x = x_orig->data.val;
+ x_orig->type = mp_scaled_type;
+ x_orig->data.val = (x>=2048 ? 1+((x-2048) / 4096) : ( x>=-2048 ? 0 : -(1+((-(x+1)-2048) / 4096))));
+}
+
+
+
+@* 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.
+
+@c
+void mp_square_rt (MP mp, mp_number *ret, mp_number x_orig) { /* return, x: scaled */
+ integer x;
+ quarterword k; /* iteration control counter */
+ integer y; /* register for intermediate calculations */
+ integer q; /* register for intermediate calculations */
+ x = x_orig.data.val;
+ if (x <= 0) {
+ @<Handle square root of zero or negative argument@>;
+ } else {
+ k = 23;
+ q = 2;
+ while (x < fraction_two) { /* i.e., |while x<@t$2^{29}$@>|\unskip */
+ k--;
+ x = x + x + x + x;
+ }
+ if (x < fraction_four)
+ y = 0;
+ else {
+ x = x - fraction_four;
+ y = 1;
+ }
+ do {
+ @<Decrease |k| by 1, maintaining the invariant
+ relations between |x|, |y|, and~|q|@>;
+ } while (k != 0);
+ ret->data.val = (int) (halfp (q));
+ }
+}
+
+
+@ @<Handle square root of zero...@>=
+{
+ if (x < 0) {
+ char msg[256];
+ const char *hlp[] = {
+ "Since I don't take square roots of negative numbers,",
+ "I'm zeroing this one. Proceed, with fingers crossed.",
+ NULL };
+ mp_snprintf(msg, 256, "Square root of %s has been replaced by 0", mp_string_scaled (mp, x));
+@.Square root...replaced by 0@>;
+ mp_error (mp, msg, hlp, true);
+ }
+ ret->data.val = 0;
+ return;
+}
+
+
+@ @<Decrease |k| by 1, maintaining...@>=
+x += x;
+y += y;
+if (x >= fraction_four) { /* note that |fraction_four=@t$2^{30}$@>| */
+ x = x - fraction_four;
+ y++;
+};
+x += x;
+y = y + y - q;
+q += q;
+if (x >= fraction_four) {
+ x = x - fraction_four;
+ y++;
+};
+if (y > (int) q) {
+ y -= q;
+ q += 2;
+} else if (y <= 0) {
+ q -= 2;
+ y += q;
+};
+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.
+
+@c
+void mp_pyth_add (MP mp, mp_number *ret, mp_number a_orig, mp_number b_orig) {
+ int a, b; /* a,b : scaled */
+ int r; /* register used to transform |a| and |b|, fraction */
+ boolean big; /* is the result dangerously near $2^{31}$? */
+ a = abs (a_orig.data.val);
+ b = abs (b_orig.data.val);
+ if (a < b) {
+ r = b;
+ b = a;
+ a = r;
+ }; /* now |0<=b<=a| */
+ if (b > 0) {
+ if (a < fraction_two) {
+ big = false;
+ } else {
+ a = a / 4;
+ b = b / 4;
+ big = true;
+ }; /* we reduced the precision to avoid arithmetic overflow */
+ @<Replace |a| by an approximation to $\psqrt{a^2+b^2}$@>;
+ if (big) {
+ if (a < fraction_two) {
+ a = a + a + a + a;
+ } else {
+ mp->arith_error = true;
+ a = EL_GORDO;
+ };
+ }
+ }
+ ret->data.val = a;
+}
+
+
+@ The key idea here is to reflect the vector $(a,b)$ about the
+line through $(a,b/2)$.
+
+@<Replace |a| by an approximation to $\psqrt{a^2+b^2}$@>=
+while (1) {
+ r = mp_make_fraction (mp, b, a);
+ r = mp_take_fraction (mp, r, r); /* now $r\approx b^2/a^2$ */
+ if (r == 0)
+ break;
+ r = mp_make_fraction (mp, r, fraction_four + r);
+ a = a + mp_take_fraction (mp, a + a, r);
+ b = mp_take_fraction (mp, b, r);
+}
+
+
+@ Here is a similar algorithm for $\psqrt{a^2-b^2}$.
+It converges slowly when $b$ is near $a$, but otherwise it works fine.
+
+@c
+void mp_pyth_sub (MP mp, mp_number *ret, mp_number a_orig, mp_number b_orig) {
+ int a, b; /* a,b: scaled */
+ int r; /* register used to transform |a| and |b|, fraction */
+ boolean big; /* is the result dangerously near $2^{31}$? */
+ a = abs (a_orig.data.val);
+ b = abs (b_orig.data.val);
+ if (a <= b) {
+ @<Handle erroneous |pyth_sub| and set |a:=0|@>;
+ } else {
+ if (a < fraction_four) {
+ big = false;
+ } else {
+ a = (integer) halfp (a);
+ b = (integer) halfp (b);
+ big = true;
+ }
+ @<Replace |a| by an approximation to $\psqrt{a^2-b^2}$@>;
+ if (big)
+ a *= 2;
+ }
+ ret->data.val = a;
+}
+
+
+@ @<Replace |a| by an approximation to $\psqrt{a^2-b^2}$@>=
+while (1) {
+ r = mp_make_fraction (mp, b, a);
+ r = mp_take_fraction (mp, r, r); /* now $r\approx b^2/a^2$ */
+ if (r == 0)
+ break;
+ r = mp_make_fraction (mp, r, fraction_four - r);
+ a = a - mp_take_fraction (mp, a + a, r);
+ b = mp_take_fraction (mp, b, r);
+}
+
+
+@ @<Handle erroneous |pyth_sub| and set |a:=0|@>=
+{
+ if (a < b) {
+ char msg[256];
+ const char *hlp[] = {
+ "Since I don't take square roots of negative numbers,",
+ "I'm zeroing this one. Proceed, with fingers crossed.",
+ NULL };
+ char *astr = strdup(mp_string_scaled (mp, a));
+ assert (astr);
+ mp_snprintf (msg, 256, "Pythagorean subtraction %s+-+%s has been replaced by 0", astr, mp_string_scaled (mp, b));
+ free(astr);
+@.Pythagorean...@>;
+ mp_error (mp, msg, hlp, true);
+ }
+ a = 0;
+}
+
+
+@ The subroutines for logarithm and exponential involve two tables.
+The first is simple: |two_to_the[k]| equals $2^k$. The second involves
+a bit more calculation, which the author claims to have done correctly:
+|spec_log[k]| is $2^{27}$ times $\ln\bigl(1/(1-2^{-k})\bigr)=
+2^{-k}+{1\over2}2^{-2k}+{1\over3}2^{-3k}+\cdots\,$, rounded to the
+nearest integer.
+
+@d two_to_the(A) (1<<(unsigned)(A))
+
+@<Declarations@>=
+static const integer spec_log[29] = { 0, /* special logarithms */
+ 93032640, 38612034, 17922280, 8662214, 4261238, 2113709,
+ 1052693, 525315, 262400, 131136, 65552, 32772, 16385,
+ 8192, 4096, 2048, 1024, 512, 256, 128, 64, 32, 16, 8, 4, 2, 1, 1
+};
+
+
+@ Here is the routine that calculates $2^8$ times the natural logarithm
+of a |scaled| quantity; it is an integer approximation to $2^{24}\ln(x/2^{16})$,
+when |x| is a given positive integer.
+
+The method is based on exercise 1.2.2--25 in {\sl The Art of Computer
+Programming\/}: During the main iteration we have $1\L 2^{-30}x<1/(1-2^{1-k})$,
+and the logarithm of $2^{30}x$ remains to be added to an accumulator
+register called~$y$. Three auxiliary bits of accuracy are retained in~$y$
+during the calculation, and sixteen auxiliary bits to extend |y| are
+kept in~|z| during the initial argument reduction. (We add
+$100\cdot2^{16}=6553600$ to~|z| and subtract 100 from~|y| so that |z| will
+not become negative; also, the actual amount subtracted from~|y| is~96,
+not~100, because we want to add~4 for rounding before the final division by~8.)
+
+@c
+void mp_m_log (MP mp, mp_number *ret, mp_number x_orig) { /* return, x: scaled */
+ int x;
+ integer y, z; /* auxiliary registers */
+ integer k; /* iteration counter */
+ x = x_orig.data.val;
+ if (x <= 0) {
+ @<Handle non-positive logarithm@>;
+ } else {
+ y = 1302456956 + 4 - 100; /* $14\times2^{27}\ln2\approx1302456956.421063$ */
+ z = 27595 + 6553600; /* and $2^{16}\times .421063\approx 27595$ */
+ while (x < fraction_four) {
+ x = 2*x;
+ y -= 93032639;
+ z -= 48782;
+ } /* $2^{27}\ln2\approx 93032639.74436163$ and $2^{16}\times.74436163\approx 48782$ */
+ y = y + (z / unity);
+ k = 2;
+ while (x > fraction_four + 4) {
+ @<Increase |k| until |x| can be multiplied by a
+ factor of $2^{-k}$, and adjust $y$ accordingly@>;
+ }
+ ret->data.val = (y / 8);
+ }
+}
+
+
+@ @<Increase |k| until |x| can...@>=
+{
+ z = ((x - 1) / two_to_the (k)) + 1; /* $z=\lceil x/2^k\rceil$ */
+ while (x < fraction_four + z) {
+ z = halfp (z + 1);
+ k++;
+ };
+ y += spec_log[k];
+ x -= z;
+}
+
+
+@ @<Handle non-positive logarithm@>=
+{
+ char msg[256];
+ const char *hlp[] = {
+ "Since I don't take logs of non-positive numbers,",
+ "I'm zeroing this one. Proceed, with fingers crossed.",
+ NULL };
+ mp_snprintf (msg, 256, "Logarithm of %s has been replaced by 0", mp_string_scaled (mp, x));
+@.Logarithm...replaced by 0@>;
+ mp_error (mp, msg, hlp, true);
+ ret->data.val = 0;
+}
+
+
+@ Conversely, the exponential routine calculates $\exp(x/2^8)$,
+when |x| is |scaled|. The result is an integer approximation to
+$2^{16}\exp(x/2^{24})$, when |x| is regarded as an integer.
+
+@c
+void mp_m_exp (MP mp, mp_number *ret, mp_number x_orig) {
+ quarterword k; /* loop control index */
+ integer y, z; /* auxiliary registers */
+ int x;
+ x = x_orig.data.val;
+ if (x > 174436200) {
+ /* $2^{24}\ln((2^{31}-1)/2^{16})\approx 174436199.51$ */
+ mp->arith_error = true;
+ ret->data.val = EL_GORDO;
+ } else if (x < -197694359) {
+ /* $2^{24}\ln(2^{-1}/2^{16})\approx-197694359.45$ */
+ ret->data.val = 0;
+ } else {
+ if (x <= 0) {
+ z = -8 * x;
+ y = 04000000; /* $y=2^{20}$ */
+ } else {
+ if (x <= 127919879) {
+ z = 1023359037 - 8 * x;
+ /* $2^{27}\ln((2^{31}-1)/2^{20})\approx 1023359037.125$ */
+ } else {
+ z = 8 * (174436200 - x); /* |z| is always nonnegative */
+ }
+ y = EL_GORDO;
+ }
+ @<Multiply |y| by $\exp(-z/2^{27})$@>;
+ if (x <= 127919879)
+ ret->data.val = ((y + 8) / 16);
+ else
+ ret->data.val = y;
+ }
+}
+
+
+@ The idea here is that subtracting |spec_log[k]| from |z| corresponds
+to multiplying |y| by $1-2^{-k}$.
+
+A subtle point (which had to be checked) was that if $x=127919879$, the
+value of~|y| will decrease so that |y+8| doesn't overflow. In fact,
+$z$ will be 5 in this case, and |y| will decrease by~64 when |k=25|
+and by~16 when |k=27|.
+
+@<Multiply |y| by...@>=
+k = 1;
+while (z > 0) {
+ while (z >= spec_log[k]) {
+ z -= spec_log[k];
+ y = y - 1 - ((y - two_to_the (k - 1)) / two_to_the (k));
+ }
+ k++;
+}
+
+@ The trigonometric subroutines use an auxiliary table such that
+|spec_atan[k]| contains an approximation to the |angle| whose tangent
+is~$1/2^k$. $\arctan2^{-k}$ times $2^{20}\cdot180/\pi$
+
+@<Declarations@>=
+static const int spec_atan[27] = { 0, 27855475, 14718068, 7471121, 3750058,
+ 1876857, 938658, 469357, 234682, 117342, 58671, 29335, 14668, 7334, 3667,
+ 1833, 917, 458, 229, 115, 57, 29, 14, 7, 4, 2, 1
+};
+
+
+@ Given integers |x| and |y|, not both zero, the |n_arg| function
+returns the |angle| whose tangent points in the direction $(x,y)$.
+This subroutine first determines the correct octant, then solves the
+problem for |0<=y<=x|, then converts the result appropriately to
+return an answer in the range |-one_eighty_deg<=@t$\theta$@><=one_eighty_deg|.
+(The answer is |+one_eighty_deg| if |y=0| and |x<0|, but an answer of
+|-one_eighty_deg| is possible if, for example, |y=-1| and $x=-2^{30}$.)
+
+The octants are represented in a ``Gray code,'' since that turns out
+to be computationally simplest.
+
+@d negate_x 1
+@d negate_y 2
+@d switch_x_and_y 4
+@d first_octant 1
+@d second_octant (first_octant+switch_x_and_y)
+@d third_octant (first_octant+switch_x_and_y+negate_x)
+@d fourth_octant (first_octant+negate_x)
+@d fifth_octant (first_octant+negate_x+negate_y)
+@d sixth_octant (first_octant+switch_x_and_y+negate_x+negate_y)
+@d seventh_octant (first_octant+switch_x_and_y+negate_y)
+@d eighth_octant (first_octant+negate_y)
+
+@c
+void mp_n_arg (MP mp, mp_number *ret, mp_number x_orig, mp_number y_orig) {
+ integer z; /* auxiliary register */
+ integer t; /* temporary storage */
+ quarterword k; /* loop counter */
+ int octant; /* octant code */
+ integer x, y;
+ x = x_orig.data.val;
+ y = y_orig.data.val;
+ if (x >= 0) {
+ octant = first_octant;
+ } else {
+ x = -x;
+ octant = first_octant + negate_x;
+ }
+ if (y < 0) {
+ y = -y;
+ octant = octant + negate_y;
+ }
+ if (x < y) {
+ t = y;
+ y = x;
+ x = t;
+ octant = octant + switch_x_and_y;
+ }
+ if (x == 0) {
+ @<Handle undefined arg@>;
+ } else {
+ ret->type = mp_angle_type;
+ @<Set variable |z| to the arg of $(x,y)$@>;
+ @<Return an appropriate answer based on |z| and |octant|@>;
+ }
+}
+
+
+@ @<Handle undefined arg@>=
+{
+ const char *hlp[] = {
+ "The `angle' between two identical points is undefined.",
+ "I'm zeroing this one. Proceed, with fingers crossed.",
+ NULL };
+ mp_error (mp, "angle(0,0) is taken as zero", hlp, true);
+@.angle(0,0)...zero@>;
+ ret->data.val = 0;
+}
+
+
+@ @<Return an appropriate answer...@>=
+switch (octant) {
+case first_octant:
+ ret->data.val = z;
+ break;
+case second_octant:
+ ret->data.val = (ninety_deg - z);
+ break;
+case third_octant:
+ ret->data.val = (ninety_deg + z);
+ break;
+case fourth_octant:
+ ret->data.val = (one_eighty_deg - z);
+ break;
+case fifth_octant:
+ ret->data.val = (z - one_eighty_deg);
+ break;
+case sixth_octant:
+ ret->data.val = (-z - ninety_deg);
+ break;
+case seventh_octant:
+ ret->data.val = (z - ninety_deg);
+ break;
+case eighth_octant:
+ ret->data.val = (-z);
+ break;
+} /* there are no other cases */
+
+
+@ At this point we have |x>=y>=0|, and |x>0|. The numbers are scaled up
+or down until $2^{28}\L x<2^{29}$, so that accurate fixed-point calculations
+will be made.
+
+@<Set variable |z| to the arg...@>=
+while (x >= fraction_two) {
+ x = halfp (x);
+ y = halfp (y);
+}
+z = 0;
+if (y > 0) {
+ while (x < fraction_one) {
+ x += x;
+ y += y;
+ };
+ @<Increase |z| to the arg of $(x,y)$@>;
+}
+
+@ During the calculations of this section, variables |x| and~|y|
+represent actual coordinates $(x,2^{-k}y)$. We will maintain the
+condition |x>=y|, so that the tangent will be at most $2^{-k}$.
+If $x<2y$, the tangent is greater than $2^{-k-1}$. The transformation
+$(a,b)\mapsto(a+b\tan\phi,b-a\tan\phi)$ replaces $(a,b)$ by
+coordinates whose angle has decreased by~$\phi$; in the special case
+$a=x$, $b=2^{-k}y$, and $\tan\phi=2^{-k-1}$, this operation reduces
+to the particularly simple iteration shown here. [Cf.~John E. Meggitt,
+@^Meggitt, John E.@>
+{\sl IBM Journal of Research and Development\/ \bf6} (1962), 210--226.]
+
+The initial value of |x| will be multiplied by at most
+$(1+{1\over2})(1+{1\over8})(1+{1\over32})\cdots\approx 1.7584$; hence
+there is no chance of integer overflow.
+
+@<Increase |z|...@>=
+k = 0;
+do {
+ y += y;
+ k++;
+ if (y > x) {
+ z = z + spec_atan[k];
+ t = x;
+ x = x + (y / two_to_the (k + k));
+ y = y - t;
+ };
+} while (k != 15);
+do {
+ y += y;
+ k++;
+ if (y > x) {
+ z = z + spec_atan[k];
+ y = y - x;
+ };
+} while (k != 26)
+
+@ Conversely, the |n_sin_cos| routine takes an |angle| and produces the sine
+and cosine of that angle. The results of this routine are
+stored in global integer variables |n_sin| and |n_cos|.
+
+@ 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|.
+
+@d forty_five_deg 0264000000 /* $45\cdot2^{20}$, represents $45^\circ$ */
+@d ninety_deg 0550000000 /* $90\cdot2^{20}$, represents $90^\circ$ */
+@d one_eighty_deg 01320000000 /* $180\cdot2^{20}$, represents $180^\circ$ */
+@d three_sixty_deg 02640000000 /* $360\cdot2^{20}$, represents $360^\circ$ */
+
+@d odd(A) (abs(A)%2==1)
+
+@ Compute a multiple of the sine and cosine
+
+@c
+void mp_n_sin_cos (MP mp, mp_number z_orig, mp_number *n_cos, mp_number *n_sin) {
+ quarterword k; /* loop control variable */
+ int q; /* specifies the quadrant */
+ integer x, y, t; /* temporary registers */
+ int z; /* scaled */
+ mp_number x_n, y_n, ret;
+ new_number (ret);
+ new_number (x_n);
+ new_number (y_n);
+ z = z_orig.data.val;
+ while (z < 0)
+ z = z + three_sixty_deg;
+ z = z % three_sixty_deg; /* now |0<=z<three_sixty_deg| */
+ q = z / forty_five_deg;
+ z = z % forty_five_deg;
+ x = fraction_one;
+ y = x;
+ if (!odd (q))
+ z = forty_five_deg - z;
+ @<Subtract angle |z| from |(x,y)|@>;
+ @<Convert |(x,y)| to the octant determined by~|q|@>;
+ x_n.data.val = x;
+ y_n.data.val = y;
+ mp_pyth_add (mp, &ret, x_n, y_n);
+ n_cos->data.val = mp_make_fraction (mp, x, ret.data.val);
+ n_sin->data.val = mp_make_fraction (mp, y, ret.data.val);
+ free_number(ret);
+ free_number(x_n);
+ free_number(y_n);
+}
+
+
+@ In this case the octants are numbered sequentially.
+
+@<Convert |(x,...@>=
+switch (q) {
+case 0:
+ break;
+case 1:
+ t = x;
+ x = y;
+ y = t;
+ break;
+case 2:
+ t = x;
+ x = -y;
+ y = t;
+ break;
+case 3:
+ x = -x;
+ break;
+case 4:
+ x = -x;
+ y = -y;
+ break;
+case 5:
+ t = x;
+ x = -y;
+ y = -t;
+ break;
+case 6:
+ t = x;
+ x = y;
+ y = -t;
+ break;
+case 7:
+ y = -y;
+ break;
+} /* there are no other cases */
+
+
+@ The main iteration of |n_sin_cos| is similar to that of |n_arg| but
+applied in reverse. The values of |spec_atan[k]| decrease slowly enough
+that this loop is guaranteed to terminate before the (nonexistent) value
+|spec_atan[27]| would be required.
+
+@<Subtract angle |z|...@>=
+k = 1;
+while (z > 0) {
+ if (z >= spec_atan[k]) {
+ z = z - spec_atan[k];
+ t = x;
+ x = t + y / two_to_the (k);
+ y = y - t / two_to_the (k);
+ }
+ k++;
+}
+if (y < 0)
+ y = 0 /* this precaution may never be needed */
+
+
+@ To initialize the |randoms| table, we call the following routine.
+
+@c
+void mp_init_randoms (MP mp, int seed) {
+ int j, jj, k; /* more or less random integers */
+ int i; /* index into |randoms| */
+ j = abs (seed);
+ while (j >= fraction_one) {
+ j = j/2;
+ }
+ k = 1;
+ for (i = 0; i <= 54; i++) {
+ jj = k;
+ k = j - k;
+ j = jj;
+ if (k<0)
+ k += fraction_one;
+ mp->randoms[(i * 21) % 55].data.val = j;
+ }
+ mp_new_randoms (mp);
+ mp_new_randoms (mp);
+ mp_new_randoms (mp); /* ``warm up'' the array */
+}
+
+
+@ @c
+void mp_print_number (MP mp, mp_number n) {
+ mp_print_scaled (mp, n.data.val);
+}
+
+
+@ @c
+char * mp_number_tostring (MP mp, mp_number n) {
+ return mp_string_scaled(mp, n.data.val);
+}
+
+@ @c
+void mp_number_modulo (mp_number *a, mp_number b) {
+ a->data.val = a->data.val % b.data.val;
+}
+
+
+
+
+
+@ To consume a random fraction, the program below will say `|next_random|'.
+
+@c
+static void mp_next_random (MP mp, mp_number *ret) {
+ if ( mp->j_random==0 )
+ mp_new_randoms(mp);
+ else
+ mp->j_random = mp->j_random-1;
+ mp_number_clone (ret, mp->randoms[mp->j_random]);
+}
+
+
+@ To produce a uniform random number in the range |0<=u<x| or |0>=u>x|
+or |0=u=x|, given a |scaled| value~|x|, we proceed as shown here.
+
+Note that the call of |take_fraction| will produce the values 0 and~|x|
+with about half the probability that it will produce any other particular
+values between 0 and~|x|, because it rounds its answers.
+
+@c
+static void mp_m_unif_rand (MP mp, mp_number *ret, mp_number x_orig) {
+ mp_number y; /* trial value */
+ mp_number x, abs_x;
+ mp_number u;
+ new_fraction (y);
+ new_number (x);
+ new_number (abs_x);
+ new_number (u);
+ mp_number_clone (&x, x_orig);
+ mp_number_clone (&abs_x, x);
+ mp_number_abs (&abs_x);
+ mp_next_random(mp, &u);
+ /*|take_fraction (y, abs_x, u);|*/
+ mp_number_take_fraction (mp,&y, abs_x,u);
+ free_number (u);
+ if (mp_number_equal(y, abs_x)) {
+ /*|set_number_to_zero(*ret);|*/
+ mp_number_clone (ret, ((math_data *)mp->math)->zero_t);
+ } else if (mp_number_greater(x, ((math_data *)mp->math)->zero_t)) {
+ mp_number_clone (ret, y);
+ } else {
+ mp_number_clone (ret, y);
+ mp_number_negate (ret);
+ }
+ free_number (abs_x);
+ free_number (x);
+ free_number (y);
+}
+
+
+
+
+@ Finally, a normal deviate with mean zero and unit standard deviation
+can readily be obtained with the ratio method (Algorithm 3.4.1R in
+{\sl The Art of Computer Programming\/}).
+
+@c
+static void mp_m_norm_rand (MP mp, mp_number *ret) {
+ mp_number ab_vs_cd;
+ mp_number abs_x;
+ mp_number u;
+ mp_number r;
+ mp_number la, xa;
+ new_number (ab_vs_cd);
+ new_number (la);
+ new_number (xa);
+ new_number (abs_x);
+ new_number (u);
+ new_number (r);
+ do {
+ do {
+ mp_number v;
+ new_number (v);
+ mp_next_random(mp, &v);
+ mp_number_substract (&v, ((math_data *)mp->math)->fraction_half_t);
+ mp_number_take_fraction (mp,&xa, ((math_data *)mp->math)->sqrt_8_e_k, v);
+ free_number (v);
+ mp_next_random(mp, &u);
+ mp_number_clone (&abs_x, xa);
+ mp_number_abs (&abs_x);
+ } while (!mp_number_less(abs_x, u));
+ mp_number_make_fraction (mp, &r, xa, u);
+ mp_number_clone (&xa, r);
+ mp_m_log (mp,&la, u);
+ mp_set_number_from_substraction(&la, ((math_data *)mp->math)->twelve_ln_2_k, la);
+ mp_ab_vs_cd (mp,&ab_vs_cd, ((math_data *)mp->math)->one_k, la, xa, xa);
+ } while (mp_number_less(ab_vs_cd,((math_data *)mp->math)->zero_t));
+ mp_number_clone (ret, xa);
+ free_number (ab_vs_cd);
+ free_number (r);
+ free_number (abs_x);
+ free_number (la);
+ free_number (xa);
+ free_number (u);
+}
diff --git a/Build/source/texk/web2c/mplibdir/mpmathbinary.w b/Build/source/texk/web2c/mplibdir/mpmathbinary.w
new file mode 100644
index 00000000000..159fae019af
--- /dev/null
+++ b/Build/source/texk/web2c/mplibdir/mpmathbinary.w
@@ -0,0 +1,1838 @@
+% $Id$
+%
+% This file is part of MetaPost;
+% the MetaPost program is in the public domain.
+% See the <Show version...> code in mpost.w for more info.
+
+% Here is TeX material that gets inserted after \input webmac
+
+\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\pct!{{\char`\%}} % percent sign in ordinary text
+\def\psqrt#1{\sqrt{\mathstrut#1}}
+
+
+\def\title{Math support functions for MPFR based math}
+\pdfoutput=1
+
+@ Introduction.
+
+@c
+#include <w2c/config.h>
+#include <stdio.h>
+#include <stdlib.h>
+#include <string.h>
+#include <math.h>
+#include "mpmathbinary.h" /* internal header */
+#define ROUND(a) floor((a)+0.5)
+@h
+
+@ @c
+@<Declarations@>;
+
+@ @(mpmathbinary.h@>=
+#ifndef MPMATHBINARY_H
+#define MPMATHBINARY_H 1
+#include "mplib.h"
+#include "mpmp.h" /* internal header */
+#include <gmp.h>
+#include <mpfr.h>
+
+#ifdef HAVE_CONFIG_H
+#define MP_STR_HELPER(x) #x
+#define MP_STR(x) MP_STR_HELPER(x)
+const char * const COMPILED_gmp_version = MP_STR(__GNU_MP_VERSION) "." MP_STR( __GNU_MP_VERSION_MINOR) "." MP_STR(__GNU_MP_VERSION_PATCHLEVEL);
+#else
+const char * const COMPILED_gmp_version = "unknown";
+#endif
+
+const char *COMPILED_MPFR_VERSION_STRING = MPFR_VERSION_STRING;
+int COMPILED__GNU_MP_VERSION = __GNU_MP_VERSION ;
+int COMPILED__GNU_MP_VERSION_MINOR = __GNU_MP_VERSION_MINOR ;
+int COMPILED__GNU_MP_VERSION_PATCHLEVEL = __GNU_MP_VERSION_PATCHLEVEL ;
+
+@<Internal library declarations@>;
+#endif
+
+@* Math initialization.
+
+First, here are some very important constants.
+
+@d ROUNDING MPFR_RNDN
+@d E_STRING "2.7182818284590452353602874713526624977572470936999595749669676277240766303535"
+@d PI_STRING "3.1415926535897932384626433832795028841971693993751058209749445923078164062862"
+@d fraction_multiplier 4096
+@d angle_multiplier 16
+
+@ Here are the functions that are static as they are not used elsewhere
+
+@<Declarations@>=
+#define DEBUG 0
+static void mp_binary_scan_fractional_token (MP mp, int n);
+static void mp_binary_scan_numeric_token (MP mp, int n);
+static void mp_binary_ab_vs_cd (MP mp, mp_number *ret, mp_number a, mp_number b, mp_number c, mp_number d);
+static void mp_ab_vs_cd (MP mp, mp_number *ret, mp_number a, mp_number b, mp_number c, mp_number d);
+static void mp_binary_crossing_point (MP mp, mp_number *ret, mp_number a, mp_number b, mp_number c);
+static void mp_binary_number_modulo (mp_number *a, mp_number b);
+static void mp_binary_print_number (MP mp, mp_number n);
+static char * mp_binary_number_tostring (MP mp, mp_number n);
+static void mp_binary_slow_add (MP mp, mp_number *ret, mp_number x_orig, mp_number y_orig);
+static void mp_binary_square_rt (MP mp, mp_number *ret, mp_number x_orig);
+static void mp_binary_sin_cos (MP mp, mp_number z_orig, mp_number *n_cos, mp_number *n_sin);
+static void mp_init_randoms (MP mp, int seed);
+static void mp_number_angle_to_scaled (mp_number *A);
+static void mp_number_fraction_to_scaled (mp_number *A);
+static void mp_number_scaled_to_fraction (mp_number *A);
+static void mp_number_scaled_to_angle (mp_number *A);
+static void mp_binary_m_unif_rand (MP mp, mp_number *ret, mp_number x_orig);
+static void mp_binary_m_norm_rand (MP mp, mp_number *ret);
+static void mp_binary_m_exp (MP mp, mp_number *ret, mp_number x_orig);
+static void mp_binary_m_log (MP mp, mp_number *ret, mp_number x_orig);
+static void mp_binary_pyth_sub (MP mp, mp_number *r, mp_number a, mp_number b);
+static void mp_binary_pyth_add (MP mp, mp_number *r, mp_number a, mp_number b);
+static void mp_binary_n_arg (MP mp, mp_number *ret, mp_number x, mp_number y);
+static void mp_binary_velocity (MP mp, mp_number *ret, mp_number st, mp_number ct, mp_number sf, mp_number cf, mp_number t);
+static void mp_set_binary_from_int(mp_number *A, int B);
+static void mp_set_binary_from_boolean(mp_number *A, int B);
+static void mp_set_binary_from_scaled(mp_number *A, int B);
+static void mp_set_binary_from_addition(mp_number *A, mp_number B, mp_number C);
+static void mp_set_binary_from_substraction (mp_number *A, mp_number B, mp_number C);
+static void mp_set_binary_from_div(mp_number *A, mp_number B, mp_number C);
+static void mp_set_binary_from_mul(mp_number *A, mp_number B, mp_number C);
+static void mp_set_binary_from_int_div(mp_number *A, mp_number B, int C);
+static void mp_set_binary_from_int_mul(mp_number *A, mp_number B, int C);
+static void mp_set_binary_from_of_the_way(MP mp, mp_number *A, mp_number t, mp_number B, mp_number C);
+static void mp_number_negate(mp_number *A);
+static void mp_number_add(mp_number *A, mp_number B);
+static void mp_number_substract(mp_number *A, mp_number B);
+static void mp_number_half(mp_number *A);
+static void mp_number_halfp(mp_number *A);
+static void mp_number_double(mp_number *A);
+static void mp_number_add_scaled(mp_number *A, int B); /* also for negative B */
+static void mp_number_multiply_int(mp_number *A, int B);
+static void mp_number_divide_int(mp_number *A, int B);
+static void mp_binary_abs(mp_number *A);
+static void mp_number_clone(mp_number *A, mp_number B);
+static void mp_number_swap(mp_number *A, mp_number *B);
+static int mp_round_unscaled(mp_number x_orig);
+static int mp_number_to_int(mp_number A);
+static int mp_number_to_scaled(mp_number A);
+static int mp_number_to_boolean(mp_number A);
+static double mp_number_to_double(mp_number A);
+static int mp_number_odd(mp_number A);
+static int mp_number_equal(mp_number A, mp_number B);
+static int mp_number_greater(mp_number A, mp_number B);
+static int mp_number_less(mp_number A, mp_number B);
+static int mp_number_nonequalabs(mp_number A, mp_number B);
+static void mp_number_floor (mp_number *i);
+static void mp_binary_fraction_to_round_scaled (mp_number *x);
+static void mp_binary_number_make_scaled (MP mp, mp_number *r, mp_number p, mp_number q);
+static void mp_binary_number_make_fraction (MP mp, mp_number *r, mp_number p, mp_number q);
+static void mp_binary_number_take_fraction (MP mp, mp_number *r, mp_number p, mp_number q);
+static void mp_binary_number_take_scaled (MP mp, mp_number *r, mp_number p, mp_number q);
+static void mp_new_number (MP mp, mp_number *n, mp_number_type t) ;
+static void mp_free_number (MP mp, mp_number *n) ;
+static void mp_set_binary_from_double(mp_number *A, double B);
+static void mp_free_binary_math (MP mp);
+static void mp_binary_set_precision (MP mp);
+static void mp_check_mpfr_t (MP mp, mpfr_t dec);
+static int binary_number_check (mpfr_t dec);
+static char * mp_binnumber_tostring (mpfr_t n);
+static void init_binary_constants (void);
+static void free_binary_constants (void);
+static mpfr_prec_t precision_digits_to_bits(double i);
+static double precision_bits_to_digits (mpfr_prec_t i);
+
+@ We do not want special numbers as return values for functions, so:
+
+@d mpfr_negative_p(a) (mpfr_sgn((a))<0)
+@d mpfr_positive_p(a) (mpfr_sgn((a))>0)
+@d checkZero(dec) if (mpfr_zero_p(dec) && mpfr_negative_p(dec)) {
+ mpfr_set_zero(dec,1);
+ }
+
+@c
+int binary_number_check (mpfr_t dec)
+{
+ int test = false;
+ if (!mpfr_number_p(dec)) {
+ test = true;
+ if (mpfr_inf_p(dec)) {
+ mpfr_set(dec, EL_GORDO_mpfr_t, ROUNDING);
+ if (mpfr_negative_p(dec)) {
+ mpfr_neg(dec, dec, ROUNDING);
+ }
+ } else { // Nan
+ mpfr_set_zero(dec,1); /* 1 == positive */
+ }
+ }
+ checkZero(dec);
+ return test;
+}
+void mp_check_mpfr_t (MP mp, mpfr_t dec)
+{
+ mp->arith_error = binary_number_check (dec);
+}
+
+
+
+
+@ Precision IO uses |double| because |MPFR_PREC_MAX| overflows int.
+
+@c
+static double precision_bits;
+mpfr_prec_t precision_digits_to_bits (double i)
+{
+ return i/log10(2);
+}
+double precision_bits_to_digits (mpfr_prec_t d)
+{
+ return d*log10(2);
+}
+
+
+@ And these are the ones that {\it are} used elsewhere
+
+@<Internal library declarations@>=
+void * mp_initialize_binary_math (MP mp);
+
+@
+
+@d unity 1
+@d two 2
+@d three 3
+@d four 4
+@d half_unit 0.5
+@d three_quarter_unit 0.75
+@d coef_bound ((7.0/3.0)*fraction_multiplier) /* |fraction| approximation to 7/3 */
+@d fraction_threshold 0.04096 /* a |fraction| coefficient less than this is zeroed */
+@d half_fraction_threshold (fraction_threshold/2) /* half of |fraction_threshold| */
+@d scaled_threshold 0.000122 /* a |scaled| coefficient less than this is zeroed */
+@d half_scaled_threshold (scaled_threshold/2) /* half of |scaled_threshold| */
+@d near_zero_angle (0.0256*angle_multiplier) /* an angle of about 0.0256 */
+@d p_over_v_threshold 0x80000 /* TODO */
+@d equation_threshold 0.001
+@d tfm_warn_threshold 0.0625
+@d warning_limit pow(2.0,52.0) /* this is a large value that can just be expressed without loss of precision */
+@d epsilon pow(2.0,-173.0) /* almost "1E-52" */
+@d epsilonf pow(2.0,-52.0)
+@d EL_GORDO "1E1000000" /* the largest value that \MP\ likes. */
+@d one_third_EL_GORDO (EL_GORDO/3.0)
+
+@<Declarations@>=
+static mpfr_t zero;
+static mpfr_t one;
+static mpfr_t minusone;
+static mpfr_t two_mpfr_t;
+static mpfr_t three_mpfr_t;
+static mpfr_t four_mpfr_t;
+static mpfr_t fraction_multiplier_mpfr_t;
+static mpfr_t angle_multiplier_mpfr_t;
+static mpfr_t fraction_one_mpfr_t;
+static mpfr_t fraction_one_plus_mpfr_t;
+static mpfr_t PI_mpfr_t;
+static mpfr_t epsilon_mpfr_t;
+static mpfr_t EL_GORDO_mpfr_t;
+static boolean initialized = false;
+
+
+@ @c
+void init_binary_constants (void) {
+ if (!initialized) {
+ mpfr_inits2 (precision_bits, one, minusone, zero, two_mpfr_t, three_mpfr_t, four_mpfr_t, fraction_multiplier_mpfr_t,
+ fraction_one_mpfr_t, fraction_one_plus_mpfr_t, angle_multiplier_mpfr_t, PI_mpfr_t,
+ epsilon_mpfr_t, EL_GORDO_mpfr_t, (mpfr_ptr) 0);
+ mpfr_set_si (one, 1, ROUNDING);
+ mpfr_set_si (minusone, -1, ROUNDING);
+ mpfr_set_si (zero, 0, ROUNDING);
+ mpfr_set_si (two_mpfr_t, two, ROUNDING);
+ mpfr_set_si (three_mpfr_t, three, ROUNDING);
+ mpfr_set_si (four_mpfr_t, four, ROUNDING);
+ mpfr_set_si (fraction_multiplier_mpfr_t, fraction_multiplier, ROUNDING);
+ mpfr_set_si (fraction_one_mpfr_t, fraction_one, ROUNDING);
+ mpfr_set_si (fraction_one_plus_mpfr_t, (fraction_one+1), ROUNDING);
+ mpfr_set_si (angle_multiplier_mpfr_t, angle_multiplier, ROUNDING);
+ mpfr_set_str (PI_mpfr_t, PI_STRING, 10, ROUNDING);
+ mpfr_set_d(epsilon_mpfr_t, epsilon , ROUNDING);
+ mpfr_set_str (EL_GORDO_mpfr_t, EL_GORDO, 10, ROUNDING);
+ initialized = true;
+ }
+}
+void free_binary_constants (void) {
+ /* For sake of speed, we accept this memory leak. */
+ /*mpfr_clears (one, minusone, zero, two_mpfr_t, three_mpfr_t, four_mpfr_t, fraction_multiplier_mpfr_t,*/
+ /* fraction_one_mpfr_t, fraction_one_plus_mpfr_t, angle_multiplier_mpfr_t, PI_mpfr_t, */
+ /* epsilon_mpfr_t, EL_GORDO_mpfr_t, (mpfr_ptr) 0); */
+ /*mpfr_free_cache ();*/
+}
+
+@ |precision_max| is limited to 1000, because the precision of already initialized
+|mpfr_t| numbers cannot be raised, only lowered. The value of 1000.0 is a tradeoff
+between precision and allocation size / processing speed.
+
+@d MAX_PRECISION 1000.0
+@d DEF_PRECISION 34.0
+
+@c
+void * mp_initialize_binary_math (MP mp) {
+ math_data *math = (math_data *)mp_xmalloc(mp,1,sizeof(math_data));
+ precision_bits = precision_digits_to_bits(MAX_PRECISION);
+ init_binary_constants();
+ /* alloc */
+ math->allocate = mp_new_number;
+ math->free = mp_free_number;
+ mp_new_number (mp, &math->precision_default, mp_scaled_type);
+ mpfr_set_d(math->precision_default.data.num, DEF_PRECISION, ROUNDING);
+ mp_new_number (mp, &math->precision_max, mp_scaled_type);
+ mpfr_set_d(math->precision_max.data.num, MAX_PRECISION, ROUNDING);
+ mp_new_number (mp, &math->precision_min, mp_scaled_type);
+ /* really should be |precision_bits_to_digits(MPFR_PREC_MIN)| but that produces a horrible number */
+ mpfr_set_d(math->precision_min.data.num, 2.0 , ROUNDING);
+ /* here are the constants for |scaled| objects */
+ mp_new_number (mp, &math->epsilon_t, mp_scaled_type);
+ mpfr_set (math->epsilon_t.data.num, epsilon_mpfr_t, ROUNDING);
+ mp_new_number (mp, &math->inf_t, mp_scaled_type);
+ mpfr_set (math->inf_t.data.num, EL_GORDO_mpfr_t, ROUNDING);
+ mp_new_number (mp, &math->warning_limit_t, mp_scaled_type);
+ mpfr_set_d (math->warning_limit_t.data.num, warning_limit, ROUNDING);
+ mp_new_number (mp, &math->one_third_inf_t, mp_scaled_type);
+ mpfr_div (math->one_third_inf_t.data.num, math->inf_t.data.num, three_mpfr_t, ROUNDING);
+ mp_new_number (mp, &math->unity_t, mp_scaled_type);
+ mpfr_set (math->unity_t.data.num, one, ROUNDING);
+ mp_new_number (mp, &math->two_t, mp_scaled_type);
+ mpfr_set_si(math->two_t.data.num, two, ROUNDING);
+ mp_new_number (mp, &math->three_t, mp_scaled_type);
+ mpfr_set_si(math->three_t.data.num, three, ROUNDING);
+ mp_new_number (mp, &math->half_unit_t, mp_scaled_type);
+ mpfr_set_d(math->half_unit_t.data.num, half_unit, ROUNDING);
+ mp_new_number (mp, &math->three_quarter_unit_t, mp_scaled_type);
+ mpfr_set_d (math->three_quarter_unit_t.data.num, three_quarter_unit, ROUNDING);
+ mp_new_number (mp, &math->zero_t, mp_scaled_type);
+ mpfr_set_zero (math->zero_t.data.num, 1);
+ /* |fractions| */
+ mp_new_number (mp, &math->arc_tol_k, mp_fraction_type);
+ {
+ mpfr_div_si (math->arc_tol_k.data.num, one, 4096, ROUNDING);
+ /* quit when change in arc length estimate reaches this */
+ }
+ mp_new_number (mp, &math->fraction_one_t, mp_fraction_type);
+ mpfr_set_si(math->fraction_one_t.data.num, fraction_one, ROUNDING);
+ mp_new_number (mp, &math->fraction_half_t, mp_fraction_type);
+ mpfr_set_si(math->fraction_half_t.data.num, fraction_half, ROUNDING);
+ mp_new_number (mp, &math->fraction_three_t, mp_fraction_type);
+ mpfr_set_si(math->fraction_three_t.data.num, fraction_three, ROUNDING);
+ mp_new_number (mp, &math->fraction_four_t, mp_fraction_type);
+ mpfr_set_si(math->fraction_four_t.data.num, fraction_four, ROUNDING);
+ /* |angles| */
+ mp_new_number (mp, &math->three_sixty_deg_t, mp_angle_type);
+ mpfr_set_si(math->three_sixty_deg_t.data.num, 360 * angle_multiplier, ROUNDING);
+ mp_new_number (mp, &math->one_eighty_deg_t, mp_angle_type);
+ mpfr_set_si(math->one_eighty_deg_t.data.num, 180 * angle_multiplier, ROUNDING);
+ /* various approximations */
+ mp_new_number (mp, &math->one_k, mp_scaled_type);
+ mpfr_set_d(math->one_k.data.num, 1.0/64, ROUNDING);
+ mp_new_number (mp, &math->sqrt_8_e_k, mp_scaled_type);
+ {
+ mpfr_set_d(math->sqrt_8_e_k.data.num, 112428.82793 / 65536.0, ROUNDING);
+ /* $2^{16}\sqrt{8/e}\approx 112428.82793$ */
+ }
+ mp_new_number (mp, &math->twelve_ln_2_k, mp_fraction_type);
+ {
+ mpfr_set_d(math->twelve_ln_2_k.data.num, 139548959.6165 / 65536.0, ROUNDING);
+ /* $2^{24}\cdot12\ln2\approx139548959.6165$ */
+ }
+ mp_new_number (mp, &math->coef_bound_k, mp_fraction_type);
+ mpfr_set_d(math->coef_bound_k.data.num,coef_bound, ROUNDING);
+ mp_new_number (mp, &math->coef_bound_minus_1, mp_fraction_type);
+ mpfr_set_d(math->coef_bound_minus_1.data.num,coef_bound - 1 / 65536.0, ROUNDING);
+ mp_new_number (mp, &math->twelvebits_3, mp_scaled_type);
+ {
+ mpfr_set_d(math->twelvebits_3.data.num, 1365 / 65536.0, ROUNDING);
+ /* $1365\approx 2^{12}/3$ */
+ }
+ mp_new_number (mp, &math->twentysixbits_sqrt2_t, mp_fraction_type);
+ {
+ mpfr_set_d(math->twentysixbits_sqrt2_t.data.num, 94906265.62 / 65536.0, ROUNDING);
+ /* $2^{26}\sqrt2\approx94906265.62$ */
+ }
+ mp_new_number (mp, &math->twentyeightbits_d_t, mp_fraction_type);
+ {
+ mpfr_set_d(math->twentyeightbits_d_t.data.num, 35596754.69 / 65536.0, ROUNDING);
+ /* $2^{28}d\approx35596754.69$ */
+ }
+ mp_new_number (mp, &math->twentysevenbits_sqrt2_d_t, mp_fraction_type);
+ {
+ mpfr_set_d(math->twentysevenbits_sqrt2_d_t.data.num, 25170706.63 / 65536.0, ROUNDING);
+ /* $2^{27}\sqrt2\,d\approx25170706.63$ */
+ }
+ /* thresholds */
+ mp_new_number (mp, &math->fraction_threshold_t, mp_fraction_type);
+ mpfr_set_d(math->fraction_threshold_t.data.num, fraction_threshold, ROUNDING);
+ mp_new_number (mp, &math->half_fraction_threshold_t, mp_fraction_type);
+ mpfr_set_d(math->half_fraction_threshold_t.data.num, half_fraction_threshold, ROUNDING);
+ mp_new_number (mp, &math->scaled_threshold_t, mp_scaled_type);
+ mpfr_set_d(math->scaled_threshold_t.data.num, scaled_threshold, ROUNDING);
+ mp_new_number (mp, &math->half_scaled_threshold_t, mp_scaled_type);
+ mpfr_set_d(math->half_scaled_threshold_t.data.num, half_scaled_threshold, ROUNDING);
+ mp_new_number (mp, &math->near_zero_angle_t, mp_angle_type);
+ mpfr_set_d(math->near_zero_angle_t.data.num, near_zero_angle, ROUNDING);
+ mp_new_number (mp, &math->p_over_v_threshold_t, mp_fraction_type);
+ mpfr_set_d(math->p_over_v_threshold_t.data.num, p_over_v_threshold, ROUNDING);
+ mp_new_number (mp, &math->equation_threshold_t, mp_scaled_type);
+ mpfr_set_d(math->equation_threshold_t.data.num, equation_threshold, ROUNDING);
+ mp_new_number (mp, &math->tfm_warn_threshold_t, mp_scaled_type);
+ mpfr_set_d(math->tfm_warn_threshold_t.data.num, tfm_warn_threshold, ROUNDING);
+ /* functions */
+ math->from_int = mp_set_binary_from_int;
+ math->from_boolean = mp_set_binary_from_boolean;
+ math->from_scaled = mp_set_binary_from_scaled;
+ math->from_double = mp_set_binary_from_double;
+ math->from_addition = mp_set_binary_from_addition;
+ math->from_substraction = mp_set_binary_from_substraction;
+ math->from_oftheway = mp_set_binary_from_of_the_way;
+ math->from_div = mp_set_binary_from_div;
+ math->from_mul = mp_set_binary_from_mul;
+ math->from_int_div = mp_set_binary_from_int_div;
+ math->from_int_mul = mp_set_binary_from_int_mul;
+ math->negate = mp_number_negate;
+ math->add = mp_number_add;
+ math->substract = mp_number_substract;
+ math->half = mp_number_half;
+ math->halfp = mp_number_halfp;
+ math->do_double = mp_number_double;
+ math->abs = mp_binary_abs;
+ math->clone = mp_number_clone;
+ math->swap = mp_number_swap;
+ math->add_scaled = mp_number_add_scaled;
+ math->multiply_int = mp_number_multiply_int;
+ math->divide_int = mp_number_divide_int;
+ math->to_boolean = mp_number_to_boolean;
+ math->to_scaled = mp_number_to_scaled;
+ math->to_double = mp_number_to_double;
+ math->to_int = mp_number_to_int;
+ math->odd = mp_number_odd;
+ math->equal = mp_number_equal;
+ math->less = mp_number_less;
+ math->greater = mp_number_greater;
+ math->nonequalabs = mp_number_nonequalabs;
+ math->round_unscaled = mp_round_unscaled;
+ math->floor_scaled = mp_number_floor;
+ math->fraction_to_round_scaled = mp_binary_fraction_to_round_scaled;
+ math->make_scaled = mp_binary_number_make_scaled;
+ math->make_fraction = mp_binary_number_make_fraction;
+ math->take_fraction = mp_binary_number_take_fraction;
+ math->take_scaled = mp_binary_number_take_scaled;
+ math->velocity = mp_binary_velocity;
+ math->n_arg = mp_binary_n_arg;
+ math->m_log = mp_binary_m_log;
+ math->m_exp = mp_binary_m_exp;
+ math->m_unif_rand = mp_binary_m_unif_rand;
+ math->m_norm_rand = mp_binary_m_norm_rand;
+ math->pyth_add = mp_binary_pyth_add;
+ math->pyth_sub = mp_binary_pyth_sub;
+ math->fraction_to_scaled = mp_number_fraction_to_scaled;
+ math->scaled_to_fraction = mp_number_scaled_to_fraction;
+ math->scaled_to_angle = mp_number_scaled_to_angle;
+ math->angle_to_scaled = mp_number_angle_to_scaled;
+ math->init_randoms = mp_init_randoms;
+ math->sin_cos = mp_binary_sin_cos;
+ math->slow_add = mp_binary_slow_add;
+ math->sqrt = mp_binary_square_rt;
+ math->print = mp_binary_print_number;
+ math->tostring = mp_binary_number_tostring;
+ math->modulo = mp_binary_number_modulo;
+ math->ab_vs_cd = mp_ab_vs_cd;
+ math->crossing_point = mp_binary_crossing_point;
+ math->scan_numeric = mp_binary_scan_numeric_token;
+ math->scan_fractional = mp_binary_scan_fractional_token;
+ math->free_math = mp_free_binary_math;
+ math->set_precision = mp_binary_set_precision;
+ return (void *)math;
+}
+
+void mp_binary_set_precision (MP mp) {
+ double d = mpfr_get_d(internal_value (mp_number_precision).data.num, ROUNDING);
+ precision_bits = precision_digits_to_bits(d);
+}
+
+void mp_free_binary_math (MP mp) {
+ free_number (((math_data *)mp->math)->three_sixty_deg_t);
+ free_number (((math_data *)mp->math)->one_eighty_deg_t);
+ free_number (((math_data *)mp->math)->fraction_one_t);
+ free_number (((math_data *)mp->math)->zero_t);
+ free_number (((math_data *)mp->math)->half_unit_t);
+ free_number (((math_data *)mp->math)->three_quarter_unit_t);
+ free_number (((math_data *)mp->math)->unity_t);
+ free_number (((math_data *)mp->math)->two_t);
+ free_number (((math_data *)mp->math)->three_t);
+ free_number (((math_data *)mp->math)->one_third_inf_t);
+ free_number (((math_data *)mp->math)->inf_t);
+ free_number (((math_data *)mp->math)->warning_limit_t);
+ free_number (((math_data *)mp->math)->one_k);
+ free_number (((math_data *)mp->math)->sqrt_8_e_k);
+ free_number (((math_data *)mp->math)->twelve_ln_2_k);
+ free_number (((math_data *)mp->math)->coef_bound_k);
+ free_number (((math_data *)mp->math)->coef_bound_minus_1);
+ free_number (((math_data *)mp->math)->fraction_threshold_t);
+ free_number (((math_data *)mp->math)->half_fraction_threshold_t);
+ free_number (((math_data *)mp->math)->scaled_threshold_t);
+ free_number (((math_data *)mp->math)->half_scaled_threshold_t);
+ free_number (((math_data *)mp->math)->near_zero_angle_t);
+ free_number (((math_data *)mp->math)->p_over_v_threshold_t);
+ free_number (((math_data *)mp->math)->equation_threshold_t);
+ free_number (((math_data *)mp->math)->tfm_warn_threshold_t);
+ free_binary_constants();
+ free(mp->math);
+}
+
+@ Creating an destroying |mp_number| objects
+
+@ @c
+void mp_new_number (MP mp, mp_number *n, mp_number_type t) {
+ (void)mp;
+ n->data.num = mp_xmalloc(mp,1,sizeof(mpfr_t));
+ mpfr_init2 ((mpfr_ptr)(n->data.num), precision_bits);
+ mpfr_set_zero((mpfr_ptr)(n->data.num),1); /* 1 == positive */
+ n->type = t;
+}
+
+@
+
+@c
+void mp_free_number (MP mp, mp_number *n) {
+ (void)mp;
+ if (n->data.num) {
+ mpfr_clear (n->data.num);
+ n->data.num = NULL;
+ }
+ n->type = mp_nan_type;
+}
+
+@ Here are the low-level functions on |mp_number| items, setters first.
+
+@c
+void mp_set_binary_from_int(mp_number *A, int B) {
+ mpfr_set_si(A->data.num,B, ROUNDING);
+}
+void mp_set_binary_from_boolean(mp_number *A, int B) {
+ mpfr_set_si(A->data.num,B, ROUNDING);
+}
+void mp_set_binary_from_scaled(mp_number *A, int B) {
+ mpfr_set_si(A->data.num, B, ROUNDING);
+ mpfr_div_si(A->data.num, A->data.num, 65536, ROUNDING);
+}
+void mp_set_binary_from_double(mp_number *A, double B) {
+ mpfr_set_d(A->data.num, B, ROUNDING);
+}
+void mp_set_binary_from_addition(mp_number *A, mp_number B, mp_number C) {
+ mpfr_add(A->data.num,B.data.num,C.data.num, ROUNDING);
+}
+void mp_set_binary_from_substraction (mp_number *A, mp_number B, mp_number C) {
+ mpfr_sub(A->data.num,B.data.num,C.data.num, ROUNDING);
+}
+void mp_set_binary_from_div(mp_number *A, mp_number B, mp_number C) {
+ mpfr_div(A->data.num,B.data.num,C.data.num, ROUNDING);
+}
+void mp_set_binary_from_mul(mp_number *A, mp_number B, mp_number C) {
+ mpfr_mul(A->data.num,B.data.num,C.data.num, ROUNDING);
+}
+void mp_set_binary_from_int_div(mp_number *A, mp_number B, int C) {
+ mpfr_div_si(A->data.num,B.data.num,C, ROUNDING);
+}
+void mp_set_binary_from_int_mul(mp_number *A, mp_number B, int C) {
+ mpfr_mul_si(A->data.num,B.data.num, C, ROUNDING);
+}
+void mp_set_binary_from_of_the_way(MP mp, mp_number *A, mp_number t, mp_number B, mp_number C) {
+ mpfr_t c, r1;
+ mpfr_init2(c, precision_bits);
+ mpfr_init2(r1, precision_bits);
+ mpfr_sub (c,B.data.num, C.data.num, ROUNDING);
+ mp_binary_take_fraction(mp, r1, c, t.data.num);
+ mpfr_sub (A->data.num, B.data.num, r1, ROUNDING);
+ mpfr_clear(c);
+ mpfr_clear(r1);
+ mp_check_mpfr_t(mp, A->data.num);
+}
+void mp_number_negate(mp_number *A) {
+ mpfr_neg (A->data.num, A->data.num, ROUNDING);
+ checkZero((mpfr_ptr)A->data.num);
+}
+void mp_number_add(mp_number *A, mp_number B) {
+ mpfr_add (A->data.num,A->data.num,B.data.num, ROUNDING);
+}
+void mp_number_substract(mp_number *A, mp_number B) {
+ mpfr_sub (A->data.num,A->data.num,B.data.num, ROUNDING);
+}
+void mp_number_half(mp_number *A) {
+ mpfr_div_si(A->data.num, A->data.num, 2, ROUNDING);
+}
+void mp_number_halfp(mp_number *A) {
+ mpfr_div_si(A->data.num,A->data.num, 2, ROUNDING);
+}
+void mp_number_double(mp_number *A) {
+ mpfr_mul_si(A->data.num,A->data.num, 2, ROUNDING);
+}
+void mp_number_add_scaled(mp_number *A, int B) { /* also for negative B */
+ mpfr_add_d (A->data.num,A->data.num, B/65536.0, ROUNDING);
+}
+void mp_number_multiply_int(mp_number *A, int B) {
+ mpfr_mul_si(A->data.num,A->data.num, B, ROUNDING);
+}
+void mp_number_divide_int(mp_number *A, int B) {
+ mpfr_div_si(A->data.num,A->data.num, B, ROUNDING);
+}
+void mp_binary_abs(mp_number *A) {
+ mpfr_abs(A->data.num, A->data.num, ROUNDING);
+}
+void mp_number_clone(mp_number *A, mp_number B) {
+ mpfr_prec_round (A->data.num, precision_bits, ROUNDING);
+ mpfr_set(A->data.num, (mpfr_ptr)B.data.num, ROUNDING);
+}
+void mp_number_swap(mp_number *A, mp_number *B) {
+ mpfr_swap(A->data.num, B->data.num);
+}
+void mp_number_fraction_to_scaled (mp_number *A) {
+ A->type = mp_scaled_type;
+ mpfr_div (A->data.num, A->data.num, fraction_multiplier_mpfr_t, ROUNDING);
+}
+void mp_number_angle_to_scaled (mp_number *A) {
+ A->type = mp_scaled_type;
+ mpfr_div (A->data.num, A->data.num, angle_multiplier_mpfr_t, ROUNDING);
+}
+void mp_number_scaled_to_fraction (mp_number *A) {
+ A->type = mp_fraction_type;
+ mpfr_mul (A->data.num, A->data.num, fraction_multiplier_mpfr_t, ROUNDING);
+}
+void mp_number_scaled_to_angle (mp_number *A) {
+ A->type = mp_angle_type;
+ mpfr_mul(A->data.num, A->data.num, angle_multiplier_mpfr_t, ROUNDING);
+}
+
+
+@* Query functions.
+
+@ Convert a number to a scaled value. |decNumberToInt32| is not
+able to make this conversion properly, so instead we are using
+|decNumberToDouble| and a typecast. Bad!
+
+@c
+int mp_number_to_scaled(mp_number A) {
+ double v = mpfr_get_d (A.data.num, ROUNDING);
+ return (int)(v * 65536.0);
+}
+
+@
+
+@d odd(A) (abs(A)%2==1)
+
+@c
+int mp_number_to_int(mp_number A) {
+ int32_t result = 0;
+ if (mpfr_fits_sint_p(A.data.num, ROUNDING)) {
+ result = mpfr_get_si(A.data.num, ROUNDING);
+ }
+ return result;
+}
+int mp_number_to_boolean(mp_number A) {
+ int32_t result = 0;
+ if (mpfr_fits_sint_p(A.data.num, ROUNDING)) {
+ result = mpfr_get_si(A.data.num, ROUNDING);
+ }
+ return result;
+}
+double mp_number_to_double(mp_number A) {
+ double res = 0.0;
+ if (mpfr_number_p (A.data.num)) {
+ res = mpfr_get_d(A.data.num, ROUNDING);
+ }
+ return res;
+}
+int mp_number_odd(mp_number A) {
+ return odd(mp_number_to_int(A));
+}
+int mp_number_equal(mp_number A, mp_number B) {
+ return mpfr_equal_p(A.data.num,B.data.num);
+}
+int mp_number_greater(mp_number A, mp_number B) {
+ return mpfr_greater_p(A.data.num,B.data.num);
+}
+int mp_number_less(mp_number A, mp_number B) {
+ return mpfr_less_p(A.data.num,B.data.num);
+}
+int mp_number_nonequalabs(mp_number A, mp_number B) {
+ return !(mpfr_cmpabs(A.data.num, B.data.num)==0);
+}
+
+@ 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.
+
+@ One of \MP's most common operations is the calculation of
+$\lfloor{a+b\over2}\rfloor$,
+the midpoint of two given integers |a| and~|b|. The most decent way to do
+this is to write `|(a+b)/2|'; but on many machines it is more efficient
+to calculate `|(a+b)>>1|'.
+
+Therefore the midpoint operation will always be denoted by `|half(a+b)|'
+in this program. If \MP\ is being implemented with languages that permit
+binary shifting, the |half| macro should be changed to make this operation
+as efficient as possible. Since some systems have shift operators that can
+only be trusted to work on positive numbers, there is also a macro |halfp|
+that is used only when the quantity being halved is known to be positive
+or zero.
+
+@ Here is a procedure analogous to |print_int|. The current version
+is fairly stupid, and it is not round-trip safe, but this is good
+enough for a beta test.
+
+@c
+char * mp_binnumber_tostring (mpfr_t n) {
+ char *str = NULL, *buffer = NULL;
+ mpfr_exp_t exp = 0;
+ int neg = 0;
+ if ((str = mpfr_get_str (NULL, &exp, 10, 0, n, ROUNDING))>0) {
+ int numprecdigits = precision_bits_to_digits(precision_bits);
+ if (*str == '-') {
+ neg = 1;
+ }
+ while (strlen(str)>0 && *(str+strlen(str)-1) == '0' ) {
+ *(str+strlen(str)-1) = '\0'; /* get rid of trailing zeroes */
+ }
+ buffer = malloc(strlen(str)+13+numprecdigits+1);
+ /* the buffer should also fit at least strlen("E+\%d", exp) or (numprecdigits-2) worth of zeroes,
+ * because with numprecdigits == 33, the str for "1E32" will be "1", and needing 32 extra zeroes,
+ * and the decimal dot. To avoid miscalculations by myself, it is safer to add these
+ * three together.
+ */
+ if (buffer) {
+ int i = 0, j = 0;
+ if (neg) {
+ buffer[i++] = '-';
+ j = 1;
+ }
+ if (strlen(str+j) == 0) {
+ buffer[i++] = '0';
+ } else {
+ /* non-zero */
+ if (exp<=numprecdigits && exp > -6) {
+ if (exp>0) {
+ buffer[i++] = str[j++];
+ while (--exp>0) {
+ buffer[i++] = (str[j] ? str[j++] : '0');
+ }
+ if (str[j]) {
+ buffer[i++] = '.';
+ while (str[j]) {
+ buffer[i++] = str[j++];
+ }
+ }
+ } else {
+ int absexp;
+ buffer[i++] = '0';
+ buffer[i++] = '.';
+ absexp = -exp;
+ while (absexp-- > 0) {
+ buffer[i++] = '0';
+ }
+ while (str[j]) {
+ buffer[i++] = str[j++];
+ }
+ }
+ } else {
+ buffer[i++] = str[j++];
+ if (str[j]) {
+ buffer[i++] = '.';
+ while (str[j]) {
+ buffer[i++] = str[j++];
+ }
+ }
+ {
+ char msg[256];
+ int k = 0;
+ mp_snprintf (msg, 256, "%s%d", (exp>0?"+":""), (int)(exp>0 ? (exp-1) : (exp-1)));
+ buffer[i++] = 'E';
+ while (msg[k]) {
+ buffer[i++] = msg[k++];
+ }
+ }
+ }
+ }
+ buffer[i++] = '\0';
+ }
+ mpfr_free_str(str);
+ }
+ return buffer;
+}
+char * mp_binary_number_tostring (MP mp, mp_number n) {
+ return mp_binnumber_tostring(n.data.num);
+}
+
+
+@ @c
+void mp_binary_print_number (MP mp, mp_number n) {
+ char *str = mp_binary_number_tostring(mp, n);
+ mp_print (mp, str);
+ free (str);
+}
+
+
+
+
+@ Addition is not always checked to make sure that it doesn't overflow,
+but in places where overflow isn't too unlikely the |slow_add| routine
+is used.
+
+@c
+void mp_binary_slow_add (MP mp, mp_number *ret, mp_number A, mp_number B) {
+ mpfr_add(ret->data.num,A.data.num,B.data.num, ROUNDING);
+}
+
+@ The |make_fraction| routine produces the |fraction| equivalent of
+|p/q|, given integers |p| and~|q|; it computes the integer
+$f=\lfloor2^{28}p/q+{1\over2}\rfloor$, when $p$ and $q$ are
+positive. If |p| and |q| are both of the same scaled type |t|,
+the ``type relation'' |make_fraction(t,t)=fraction| is valid;
+and it's also possible to use the subroutine ``backwards,'' using
+the relation |make_fraction(t,fraction)=t| between scaled types.
+
+If the result would have magnitude $2^{31}$ or more, |make_fraction|
+sets |arith_error:=true|. Most of \MP's internal computations have
+been designed to avoid this sort of error.
+
+If this subroutine were programmed in assembly language on a typical
+machine, we could simply compute |(@t$2^{28}$@>*p)div q|, since a
+double-precision product can often be input to a fixed-point division
+instruction. But when we are restricted to int-eger arithmetic it
+is necessary either to resort to multiple-precision maneuvering
+or to use a simple but slow iteration. The multiple-precision technique
+would be about three times faster than the code adopted here, but it
+would be comparatively long and tricky, involving about sixteen
+additional multiplications and divisions.
+
+This operation is part of \MP's ``inner loop''; indeed, it will
+consume nearly 10\pct! of the running time (exclusive of input and output)
+if the code below is left unchanged. A machine-dependent recoding
+will therefore make \MP\ run faster. The present implementation
+is highly portable, but slow; it avoids multiplication and division
+except in the initial stage. System wizards should be careful to
+replace it with a routine that is guaranteed to produce identical
+results in all cases.
+@^system dependencies@>
+
+As noted below, a few more routines should also be replaced by machine-dependent
+code, for efficiency. But when a procedure is not part of the ``inner loop,''
+such changes aren't advisable; simplicity and robustness are
+preferable to trickery, unless the cost is too high.
+@^inner loop@>
+
+@c
+void mp_binary_make_fraction (MP mp, mpfr_t ret, mpfr_t p, mpfr_t q) {
+ mpfr_div (ret, p, q, ROUNDING);
+ mp_check_mpfr_t(mp, ret);
+ mpfr_mul (ret, ret, fraction_multiplier_mpfr_t, ROUNDING);
+}
+void mp_binary_number_make_fraction (MP mp, mp_number *ret, mp_number p, mp_number q) {
+ mp_binary_make_fraction (mp, ret->data.num, p.data.num, q.data.num);
+}
+
+@ @<Declarations@>=
+void mp_binary_make_fraction (MP mp, mpfr_t ret, mpfr_t p, mpfr_t q);
+
+@ 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@>
+
+@c
+void mp_binary_take_fraction (MP mp, mpfr_t ret, mpfr_t p, mpfr_t q) {
+ mpfr_mul(ret, p, q, ROUNDING);
+ mpfr_div(ret, ret, fraction_multiplier_mpfr_t, ROUNDING);
+}
+void mp_binary_number_take_fraction (MP mp, mp_number *ret, mp_number p, mp_number q) {
+ mp_binary_take_fraction (mp, ret->data.num, p.data.num, q.data.num);
+}
+
+@ @<Declarations@>=
+void mp_binary_take_fraction (MP mp, mpfr_t ret, mpfr_t p, mpfr_t q);
+
+@ When we want to multiply something by a |scaled| quantity, we use a scheme
+analogous to |take_fraction| but with a different scaling.
+Given positive operands, |take_scaled|
+computes the quantity $p=\lfloor qf/2^{16}+{1\over2}\rfloor$.
+
+Once again it is a good idea to use a machine-language replacement if
+possible; otherwise |take_scaled| will use more than 2\pct! of the running time
+when the Computer Modern fonts are being generated.
+@^inner loop@>
+
+@c
+void mp_binary_number_take_scaled (MP mp, mp_number *ret, mp_number p_orig, mp_number q_orig) {
+ mpfr_mul(ret->data.num, p_orig.data.num, q_orig.data.num, ROUNDING);
+}
+
+
+@ 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.)
+
+@c
+void mp_binary_number_make_scaled (MP mp, mp_number *ret, mp_number p_orig, mp_number q_orig) {
+ mpfr_div(ret->data.num, p_orig.data.num, q_orig.data.num, ROUNDING);
+ mp_check_mpfr_t(mp, ret->data.num);
+}
+
+@
+@d halfp(A) (integer)((unsigned)(A) >> 1)
+
+@* Scanning numbers in the input.
+
+The definitions below are temporarily here.
+
+@d set_cur_cmd(A) mp->cur_mod_->type=(A)
+@d set_cur_mod(A) mpfr_set((mpfr_ptr)(mp->cur_mod_->data.n.data.num),A, ROUNDING)
+
+@<Declarations...@>=
+static void mp_wrapup_numeric_token(MP mp, unsigned char *start, unsigned char *stop);
+
+@ The check of the precision is based on the article "27 Bits are not enough for 8-Digit accuracy"
+@ by Bennet Goldberg which roughly says that
+@ given $p$ digits in base 10 and $q$ digits in base 2,
+@ conversion from base 10 round-trip through base 2 if and only if $10^p < 2^{q-1}$.
+@ In our case $p/\log_{10}2 + 1 < q$, or $q\geq a$
+@ where $q$ is the current precision in bits and $a=\left\lceil p/\log_{10}2 + 1\right\rceil$.
+@ Therefore if $a>q$ the required precision could be too high and we emit a warning.
+@d too_precise(a) (a>precision_bits)
+@c
+void mp_wrapup_numeric_token(MP mp, unsigned char *start, unsigned char *stop) {
+ int invalid = 0;
+ mpfr_t result;
+ size_t l = stop-start+1;
+ unsigned long lp, lpbit;
+ char *buf = mp_xmalloc(mp, l+1, 1);
+ char *bufp = buf;
+ buf[l] = '\0';
+ mpfr_init2(result, precision_bits);
+ (void)strncpy(buf,(const char *)start, l);
+ invalid = mpfr_set_str(result,buf, 10, ROUNDING);
+ /*|fprintf(stdout,"scan of [%s] produced %s, ", buf, mp_binnumber_tostring(result));|*/
+ lp = (unsigned long) l;
+ /* strip leading - or + or 0 or .*/
+ if ( (*bufp=='-') || (*bufp=='+') || (*bufp=='0') || (*bufp=='.') ) { lp--; bufp++;}
+ /* strip also . */
+ lp = strchr(bufp,'.') ? lp-1: lp;
+ /* strip also trailing 0s */
+ bufp = buf+l-1;
+ while(*bufp == '0') {bufp--; lp=( ((lp==0)||(lp==1))?1:lp-1);}
+ /* at least one digit, even if the number is 0 */
+ lp = lp>0? lp: 1;
+ /* bits needed for buf */
+ lpbit = (unsigned long)ceil(lp/log10(2)+1);
+ free(buf);
+ bufp = NULL;
+ if (invalid == 0) {
+ set_cur_mod(result);
+ /* |fprintf(stdout,"mod=%s\n", mp_binary_number_tostring(mp,mp->cur_mod_->data.n));|*/
+ if (too_precise(lpbit)) {
+ if (mpfr_positive_p((mpfr_ptr)(internal_value (mp_warning_check).data.num)) &&
+ (mp->scanner_status != tex_flushing)) {
+ char msg[256];
+ const char *hlp[] = {"Continue and I'll try to cope",
+ "with that value; but it might be dangerous.",
+ "(Set warningcheck:=0 to suppress this message.)",
+ NULL };
+ mp_snprintf (msg, 256, "Required precision is too high (%d vs. numberprecision = %f, required precision=%d bits vs internal precision=%f bits)", (unsigned int)lp,mpfr_get_d(internal_value (mp_number_precision).data.num, ROUNDING),(int)lpbit,precision_bits);
+@.Number is too large@>;
+ mp_error (mp, msg, hlp, true);
+ }
+ }
+ } else if (mp->scanner_status != tex_flushing) {
+ const char *hlp[] = {"I could not handle this number specification",
+ "probably because it is out of range. Error:",
+ "",
+ NULL };
+ hlp[2] = strerror(errno);
+ mp_error (mp, "Enormous number has been reduced.", hlp, false);
+@.Enormous number...@>;
+ set_cur_mod((mpfr_ptr)(((math_data *)(mp->math))->inf_t.data.num));
+ }
+ set_cur_cmd((mp_variable_type)mp_numeric_token);
+ mpfr_clear(result);
+}
+
+@ @c
+static void find_exponent (MP mp) {
+ if (mp->buffer[mp->cur_input.loc_field] == 'e' ||
+ mp->buffer[mp->cur_input.loc_field] == 'E') {
+ mp->cur_input.loc_field++;
+ if (!(mp->buffer[mp->cur_input.loc_field] == '+' ||
+ mp->buffer[mp->cur_input.loc_field] == '-' ||
+ mp->char_class[mp->buffer[mp->cur_input.loc_field]] == digit_class)) {
+ mp->cur_input.loc_field--;
+ return;
+ }
+ if (mp->buffer[mp->cur_input.loc_field] == '+' ||
+ mp->buffer[mp->cur_input.loc_field] == '-') {
+ mp->cur_input.loc_field++;
+ }
+ while (mp->char_class[mp->buffer[mp->cur_input.loc_field]] == digit_class) {
+ mp->cur_input.loc_field++;
+ }
+ }
+}
+void mp_binary_scan_fractional_token (MP mp, int n) { /* n: scaled */
+ unsigned char *start = &mp->buffer[mp->cur_input.loc_field -1];
+ unsigned char *stop;
+ while (mp->char_class[mp->buffer[mp->cur_input.loc_field]] == digit_class) {
+ mp->cur_input.loc_field++;
+ }
+ find_exponent(mp);
+ stop = &mp->buffer[mp->cur_input.loc_field-1];
+ mp_wrapup_numeric_token (mp, start, stop);
+}
+
+
+@ We just have to collect bytes.
+
+@c
+void mp_binary_scan_numeric_token (MP mp, int n) { /* n: scaled */
+ unsigned char *start = &mp->buffer[mp->cur_input.loc_field -1];
+ unsigned char *stop;
+ while (mp->char_class[mp->buffer[mp->cur_input.loc_field]] == digit_class) {
+ mp->cur_input.loc_field++;
+ }
+ if (mp->buffer[mp->cur_input.loc_field] == '.' &&
+ mp->buffer[mp->cur_input.loc_field+1] != '.') {
+ mp->cur_input.loc_field++;
+ while (mp->char_class[mp->buffer[mp->cur_input.loc_field]] == digit_class) {
+ mp->cur_input.loc_field++;
+ }
+ }
+ find_exponent(mp);
+ stop = &mp->buffer[mp->cur_input.loc_field-1];
+ mp_wrapup_numeric_token (mp, start, stop);
+}
+
+@ 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 (fraction_multiplier/2)
+@d fraction_one (1*fraction_multiplier)
+@d fraction_two (2*fraction_multiplier)
+@d fraction_three (3*fraction_multiplier)
+@d fraction_four (4*fraction_multiplier)
+
+@ 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.
+
+The angles $\theta$ and $\phi$ are given implicitly in terms of |fraction|
+arguments |st|, |ct|, |sf|, and |cf|, representing $\sin\theta$, $\cos\theta$,
+$\sin\phi$, and $\cos\phi$, respectively.
+
+@c
+void mp_binary_velocity (MP mp, mp_number *ret, mp_number st, mp_number ct, mp_number sf,
+ mp_number cf, mp_number t) {
+ mpfr_t acc, num, denom; /* registers for intermediate calculations */
+ mpfr_t r1, r2;
+ mpfr_t arg1, arg2;
+ mpfr_t i16, fone, fhalf, ftwo, sqrtfive;
+ mpfr_inits2 (precision_bits, acc, num, denom, r1, r2, arg1, arg2, i16, fone, fhalf, ftwo, sqrtfive, (mpfr_ptr)0);
+ mpfr_set_si(i16, 16, ROUNDING);
+ mpfr_set_si(fone, fraction_one, ROUNDING);
+ mpfr_set_si(fhalf, fraction_half, ROUNDING);
+ mpfr_set_si(ftwo, fraction_two, ROUNDING);
+ mpfr_set_si(sqrtfive, 5, ROUNDING);
+ mpfr_sqrt (sqrtfive, sqrtfive, ROUNDING);
+ mpfr_div (arg1,sf.data.num, i16, ROUNDING); // arg1 = sf / 16
+ mpfr_sub (arg1,st.data.num, arg1, ROUNDING); // arg1 = st - arg1
+ mpfr_div (arg2,st.data.num, i16, ROUNDING); // arg2 = st / 16
+ mpfr_sub (arg2,sf.data.num, arg2, ROUNDING); // arg2 = sf - arg2
+ mp_binary_take_fraction (mp, acc, arg1, arg2); // acc = (arg1 * arg2) / fmul
+
+ mpfr_set (arg1, acc, ROUNDING);
+ mpfr_sub (arg2, ct.data.num, cf.data.num, ROUNDING); // arg2 = ct - cf
+ mp_binary_take_fraction (mp, acc, arg1, arg2); // acc = (arg1 * arg2 ) / fmul
+
+ mpfr_sqrt(arg1, two_mpfr_t, ROUNDING); // arg1 = sqrt(2)
+ mpfr_mul(arg1, arg1, fone, ROUNDING); // arg1 = arg1 * fmul
+ mp_binary_take_fraction (mp, r1, acc, arg1); // r1 = (acc * arg1) / fmul
+ mpfr_add(num, ftwo, r1, ROUNDING); // num = ftwo + r1
+
+ mpfr_sub(arg1,sqrtfive, one, ROUNDING); // arg1 = sqrt(5) - 1
+ mpfr_mul(arg1,arg1,fhalf, ROUNDING); // arg1 = arg1 * fmul/2
+ mpfr_mul(arg1,arg1,three_mpfr_t, ROUNDING); // arg1 = arg1 * 3
+
+ mpfr_sub(arg2,three_mpfr_t, sqrtfive, ROUNDING); // arg2 = 3 - sqrt(5)
+ mpfr_mul(arg2,arg2,fhalf, ROUNDING); // arg2 = arg2 * fmul/2
+ mpfr_mul(arg2,arg2,three_mpfr_t, ROUNDING); // arg2 = arg2 * 3
+ mp_binary_take_fraction (mp, r1, ct.data.num, arg1) ; // r1 = (ct * arg1) / fmul
+ mp_binary_take_fraction (mp, r2, cf.data.num, arg2); // r2 = (cf * arg2) / fmul
+
+ mpfr_set_si(denom, fraction_three, ROUNDING); // denom = 3fmul
+ mpfr_add(denom, denom, r1, ROUNDING); // denom = denom + r1
+ mpfr_add(denom, denom, r2, ROUNDING); // denom = denom + r2
+
+ if (!mpfr_equal_p(t.data.num, one)) { // t != 1
+ mpfr_div(num, num, t.data.num, ROUNDING); // num = num / t
+ }
+ mpfr_set(r2, num, ROUNDING); // r2 = num / 4
+ mpfr_div(r2, r2, four_mpfr_t, ROUNDING);
+ if (mpfr_less_p(denom,r2)) { // num/4 >= denom => denom < num/4
+ mpfr_set_si(ret->data.num,fraction_four, ROUNDING);
+ } else {
+ mp_binary_make_fraction (mp, ret->data.num, num, denom);
+ }
+ mpfr_clears (acc, num, denom, r1, r2, arg1, arg2, i16, fone, fhalf, ftwo, sqrtfive, (mpfr_ptr)0);
+ mp_check_mpfr_t(mp, ret->data.num);
+}
+
+
+@ 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.
+
+@c
+void mp_ab_vs_cd (MP mp, mp_number *ret, mp_number a_orig, mp_number b_orig, mp_number c_orig, mp_number d_orig) {
+ mpfr_t q, r, test; /* temporary registers */
+ mpfr_t a, b, c, d;
+ int cmp = 0;
+ (void)mp;
+ mpfr_inits2(precision_bits, q,r,test,a,b,c,d,(mpfr_ptr)0);
+ mpfr_set(a, (mpfr_ptr)a_orig.data.num, ROUNDING);
+ mpfr_set(b, (mpfr_ptr )b_orig.data.num, ROUNDING);
+ mpfr_set(c, (mpfr_ptr )c_orig.data.num, ROUNDING);
+ mpfr_set(d, (mpfr_ptr )d_orig.data.num, ROUNDING);
+
+ mpfr_mul(q,a,b,ROUNDING);
+ mpfr_mul(r,c,d,ROUNDING);
+ cmp = mpfr_cmp(q,r);
+ if (cmp==0) {
+ mpfr_set(ret->data.num, zero, ROUNDING);
+ goto RETURN;
+ }
+ if (cmp>0) {
+ mpfr_set(ret->data.num, one, ROUNDING);
+ goto RETURN;
+ }
+ if (cmp<0) {
+ mpfr_set(ret->data.num, minusone, ROUNDING);
+ goto RETURN;
+ }
+
+ /*TODO: remove this part of the code until RETURN */
+ @<Reduce to the case that |a,c>=0|, |b,d>0|@>;
+ while (1) {
+ mpfr_div(q,a,d, ROUNDING);
+ mpfr_div(r,c,b, ROUNDING);
+ cmp = mpfr_cmp(q,r);
+ if (cmp) {
+ if (cmp>1) {
+ mpfr_set(ret->data.num, one, ROUNDING);
+ } else {
+ mpfr_set(ret->data.num, minusone, ROUNDING);
+ }
+ goto RETURN;
+ }
+ mpfr_remainder(q,a,d, ROUNDING);
+ mpfr_remainder(r,c,b, ROUNDING);
+ if (mpfr_zero_p(r)) {
+ if (mpfr_zero_p(q)) {
+ mpfr_set(ret->data.num, zero, ROUNDING);
+ } else {
+ mpfr_set(ret->data.num, one, ROUNDING);
+ }
+ goto RETURN;
+ }
+ if (mpfr_zero_p(q)) {
+ mpfr_set(ret->data.num, minusone, ROUNDING);
+ goto RETURN;
+ }
+ mpfr_set(a,b, ROUNDING);
+ mpfr_set(b,q, ROUNDING);
+ mpfr_set(c,d, ROUNDING);
+ mpfr_set(d,r, ROUNDING);
+ } /* now |a>d>0| and |c>b>0| */
+RETURN:
+#if DEBUG
+ fprintf(stdout, "\n%f = ab_vs_cd(%f,%f,%f,%f)", mp_number_to_double(*ret),
+mp_number_to_double(a_orig),mp_number_to_double(b_orig),
+mp_number_to_double(c_orig),mp_number_to_double(d_orig));
+#endif
+ mp_check_mpfr_t(mp, ret->data.num);
+ mpfr_clears(q,r,test,a,b,c,d,(mpfr_ptr)0);
+ return;
+}
+
+
+@ @<Reduce to the case that |a...@>=
+if (mpfr_negative_p(a)) {
+ mpfr_neg(a, a, ROUNDING);
+ mpfr_neg(b, b, ROUNDING);
+}
+if (mpfr_negative_p(c)) {
+ mpfr_neg(c, c, ROUNDING);
+ mpfr_neg(d, d, ROUNDING);
+}
+if (!mpfr_positive_p(d)) {
+ if (!mpfr_negative_p(b)) {
+ if ((mpfr_zero_p(a) || mpfr_zero_p(b)) && (mpfr_zero_p(c) || mpfr_zero_p(d)))
+ mpfr_set(ret->data.num, zero, ROUNDING);
+ else
+ mpfr_set(ret->data.num, one, ROUNDING);
+ goto RETURN;
+ }
+ if (mpfr_zero_p(d)) {
+ if (mpfr_zero_p(a))
+ mpfr_set(ret->data.num, zero, ROUNDING);
+ else
+ mpfr_set(ret->data.num, minusone, ROUNDING);
+ goto RETURN;
+ }
+ mpfr_set(q, a, ROUNDING);
+ mpfr_set(a, c, ROUNDING);
+ mpfr_set(c, q, ROUNDING);
+ mpfr_neg(q, b, ROUNDING);
+ mpfr_neg(b, d, ROUNDING);
+ mpfr_set(d, q, ROUNDING);
+} else if (!mpfr_positive_p(b)) {
+ if (mpfr_negative_p(b) && mpfr_positive_p(a)) {
+ mpfr_set(ret->data.num, minusone, ROUNDING);
+ goto RETURN;
+ }
+ if (mpfr_zero_p(c))
+ mpfr_set(ret->data.num, zero, ROUNDING);
+ else
+ mpfr_set(ret->data.num, minusone, ROUNDING);
+ goto RETURN;
+}
+
+@ 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.
+
+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}$.
+
+@d no_crossing { mpfr_set(ret->data.num, fraction_one_plus_mpfr_t, ROUNDING); goto RETURN; }
+@d one_crossing { mpfr_set(ret->data.num, fraction_one_mpfr_t, ROUNDING); goto RETURN; }
+@d zero_crossing { mpfr_set(ret->data.num, zero, ROUNDING); goto RETURN; }
+
+@c
+static void mp_binary_crossing_point (MP mp, mp_number *ret, mp_number aa, mp_number bb, mp_number cc) {
+ mpfr_t a,b,c;
+ double d; /* recursive counter */
+ mpfr_t x, xx, x0, x1, x2; /* temporary registers for bisection */
+ mpfr_t scratch;
+ mpfr_inits2 (precision_bits, a,b,c, x,xx,x0,x1,x2, scratch,(mpfr_ptr)0);
+ mpfr_set(a, (mpfr_ptr )aa.data.num, ROUNDING);
+ mpfr_set(b, (mpfr_ptr )bb.data.num, ROUNDING);
+ mpfr_set(c, (mpfr_ptr )cc.data.num, ROUNDING);
+ if (mpfr_negative_p(a))
+ zero_crossing;
+ if (!mpfr_negative_p(c)) {
+ if (!mpfr_negative_p(b)) {
+ if (mpfr_positive_p(c)) {
+ no_crossing;
+ } else if (mpfr_zero_p(a) && mpfr_zero_p(b)) {
+ no_crossing;
+ } else {
+ one_crossing;
+ }
+ }
+ if (mpfr_zero_p(a))
+ zero_crossing;
+ } else if (mpfr_zero_p(a)) {
+ if (!mpfr_positive_p(b))
+ zero_crossing;
+ }
+
+ /* Use bisection to find the crossing point... */
+ d = epsilonf;
+ mpfr_set(x0, a, ROUNDING);
+ mpfr_sub(x1,a, b, ROUNDING);
+ mpfr_sub(x2,b, c, ROUNDING);
+ do {
+ /* not sure why the error correction has to be >= 1E-12 */
+ mpfr_add(x, x1, x2, ROUNDING);
+ mpfr_div(x, x, two_mpfr_t, ROUNDING);
+ mpfr_add_d (x, x, 1E-12, ROUNDING);
+ mpfr_sub(scratch, x1, x0, ROUNDING);
+ if (mpfr_greater_p(scratch, x0)) {
+ mpfr_set(x2, x, ROUNDING);
+ mpfr_add(x0, x0, x0, ROUNDING);
+ d += d;
+ } else {
+ mpfr_add(xx, scratch, x, ROUNDING);
+ if (mpfr_greater_p(xx,x0)) {
+ mpfr_set(x2,x, ROUNDING);
+ mpfr_add(x0, x0, x0, ROUNDING);
+ d += d;
+ } else {
+ mpfr_sub(x0, x0, xx, ROUNDING);
+ if (!mpfr_greater_p(x,x0)) {
+ mpfr_add(scratch, x, x2, ROUNDING);
+ if (!mpfr_greater_p(scratch, x0))
+ no_crossing;
+ }
+ mpfr_set(x1,x, ROUNDING);
+ d = d + d + epsilonf;
+ }
+ }
+ } while (d < fraction_one);
+ mpfr_set_d(scratch, d, ROUNDING);
+ mpfr_sub(ret->data.num,scratch, fraction_one_mpfr_t, ROUNDING);
+RETURN:
+#if DEBUG
+ fprintf(stdout, "\n%f = crossing_point(%f,%f,%f)", mp_number_to_double(*ret),
+mp_number_to_double(aa),mp_number_to_double(bb),mp_number_to_double(cc));
+#endif
+ mpfr_clears (a,b,c, x,xx,x0,x1,x2, scratch, (mpfr_ptr)0);
+ mp_check_mpfr_t(mp, ret->data.num);
+ return;
+}
+
+
+@ We conclude this set of elementary routines with some simple rounding
+and truncation operations.
+
+
+@ |round_unscaled| rounds a |scaled| and converts it to |int|
+@c
+int mp_round_unscaled(mp_number x_orig) {
+ double xx = mp_number_to_double(x_orig);
+ int x = (int)ROUND(xx);
+ return x;
+}
+
+@ |number_floor| floors a number
+
+@c
+void mp_number_floor (mp_number *i) {
+ mpfr_rint_floor(i->data.num, i->data.num, MPFR_RNDD);
+}
+
+@ |fraction_to_scaled| rounds a |fraction| and converts it to |scaled|
+@c
+void mp_binary_fraction_to_round_scaled (mp_number *x_orig) {
+ x_orig->type = mp_scaled_type;
+ mpfr_div(x_orig->data.num, x_orig->data.num, fraction_multiplier_mpfr_t, ROUNDING);
+}
+
+
+
+@* 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.
+
+@
+
+@c
+void mp_binary_square_rt (MP mp, mp_number *ret, mp_number x_orig) { /* return, x: scaled */
+ if (!mpfr_positive_p((mpfr_ptr)x_orig.data.num)) {
+ @<Handle square root of zero or negative argument@>;
+ } else {
+ mpfr_sqrt(ret->data.num, x_orig.data.num, ROUNDING);
+ }
+ mp_check_mpfr_t(mp, ret->data.num);
+}
+
+
+@ @<Handle square root of zero...@>=
+{
+ if (mpfr_negative_p((mpfr_ptr)x_orig.data.num)) {
+ char msg[256];
+ const char *hlp[] = {
+ "Since I don't take square roots of negative numbers,",
+ "I'm zeroing this one. Proceed, with fingers crossed.",
+ NULL };
+ char *xstr = mp_binary_number_tostring (mp, x_orig);
+ mp_snprintf(msg, 256, "Square root of %s has been replaced by 0", xstr);
+ free(xstr);
+@.Square root...replaced by 0@>;
+ mp_error (mp, msg, hlp, true);
+ }
+ mpfr_set_zero(ret->data.num,1); /* 1 == positive */
+ return;
+}
+
+
+@ Pythagorean addition $\psqrt{a^2+b^2}$ is implemented by a quick hack
+
+@c
+void mp_binary_pyth_add (MP mp, mp_number *ret, mp_number a_orig, mp_number b_orig) {
+ mpfr_t a, b, asq, bsq;
+ mpfr_inits2(precision_bits, a,b, asq, bsq, (mpfr_ptr)0);
+ mpfr_set(a, (mpfr_ptr)a_orig.data.num, ROUNDING);
+ mpfr_set(b, (mpfr_ptr)b_orig.data.num, ROUNDING);
+ mpfr_mul(asq, a, a, ROUNDING);
+ mpfr_mul(bsq, b, b, ROUNDING);
+ mpfr_add(a, asq, bsq, ROUNDING);
+ mpfr_sqrt(ret->data.num, a, ROUNDING);
+ mp_check_mpfr_t(mp, ret->data.num);
+ mpfr_clears(a,b, asq, bsq, (mpfr_ptr)0);
+}
+
+@ Here is a similar algorithm for $\psqrt{a^2-b^2}$. Same quick hack, also.
+
+@c
+void mp_binary_pyth_sub (MP mp, mp_number *ret, mp_number a_orig, mp_number b_orig) {
+ mpfr_t a, b, asq, bsq;
+ mpfr_inits2(precision_bits, a,b, asq, bsq, (mpfr_ptr)0);
+ mpfr_set(a, (mpfr_ptr)a_orig.data.num, ROUNDING);
+ mpfr_set(b, (mpfr_ptr)b_orig.data.num, ROUNDING);
+ if (!mpfr_greater_p(a,b)) {
+ @<Handle erroneous |pyth_sub| and set |a:=0|@>;
+ } else {
+ mpfr_mul(asq, a, a, ROUNDING);
+ mpfr_mul(bsq, b, b, ROUNDING);
+ mpfr_sub(a, asq, bsq, ROUNDING);
+ mpfr_sqrt(a, a, ROUNDING);
+ }
+ mpfr_set(ret->data.num, a, ROUNDING);
+ mp_check_mpfr_t(mp, ret->data.num);
+}
+
+
+@ @<Handle erroneous |pyth_sub| and set |a:=0|@>=
+{
+ if (mpfr_less_p(a, b)) {
+ char msg[256];
+ const char *hlp[] = {
+ "Since I don't take square roots of negative numbers,",
+ "I'm zeroing this one. Proceed, with fingers crossed.",
+ NULL };
+ char *astr = mp_binary_number_tostring (mp, a_orig);
+ char *bstr = mp_binary_number_tostring (mp, b_orig);
+ mp_snprintf (msg, 256, "Pythagorean subtraction %s+-+%s has been replaced by 0", astr, bstr);
+ free(astr);
+ free(bstr);
+@.Pythagorean...@>;
+ mp_error (mp, msg, hlp, true);
+ }
+ mpfr_set_zero(a,1); /* 1 == positive */
+}
+
+
+@ Here is the routine that calculates $2^8$ times the natural logarithm
+of a |scaled| quantity;
+
+@c
+void mp_binary_m_log (MP mp, mp_number *ret, mp_number x_orig) {
+ if (!mpfr_positive_p((mpfr_ptr)x_orig.data.num)) {
+ @<Handle non-positive logarithm@>;
+ } else {
+ mpfr_log(ret->data.num, x_orig.data.num, ROUNDING);
+ mp_check_mpfr_t(mp, ret->data.num);
+ mpfr_mul_si(ret->data.num, ret->data.num, 256, ROUNDING);
+ }
+ mp_check_mpfr_t(mp, ret->data.num);
+}
+
+@ @<Handle non-positive logarithm@>=
+{
+ char msg[256];
+ const char *hlp[] = {
+ "Since I don't take logs of non-positive numbers,",
+ "I'm zeroing this one. Proceed, with fingers crossed.",
+ NULL };
+ char *xstr = mp_binary_number_tostring (mp, x_orig);
+ mp_snprintf (msg, 256, "Logarithm of %s has been replaced by 0", xstr);
+ free (xstr);
+@.Logarithm...replaced by 0@>;
+ mp_error (mp, msg, hlp, true);
+ mpfr_set_zero(ret->data.num,1); /* 1 == positive */
+}
+
+
+@ Conversely, the exponential routine calculates $\exp(x/2^8)$,
+when |x| is |scaled|.
+
+@c
+void mp_binary_m_exp (MP mp, mp_number *ret, mp_number x_orig) {
+ mpfr_t temp;
+ mpfr_init2(temp, precision_bits);
+ mpfr_div_si(temp, x_orig.data.num, 256, ROUNDING);
+ mpfr_exp(ret->data.num, temp, ROUNDING);
+ mp_check_mpfr_t(mp, ret->data.num);
+ mpfr_clear (temp);
+}
+
+
+@ Given integers |x| and |y|, not both zero, the |n_arg| function
+returns the |angle| whose tangent points in the direction $(x,y)$.
+
+@c
+void mp_binary_n_arg (MP mp, mp_number *ret, mp_number x_orig, mp_number y_orig) {
+ if (mpfr_zero_p((mpfr_ptr )x_orig.data.num) && mpfr_zero_p((mpfr_ptr )y_orig.data.num)) {
+ @<Handle undefined arg@>;
+ } else {
+ mpfr_t atan2val, oneeighty_angle;
+ mpfr_init2(atan2val, precision_bits);
+ mpfr_init2(oneeighty_angle, precision_bits);
+ ret->type = mp_angle_type;
+ mpfr_set_si(oneeighty_angle, 180 * angle_multiplier, ROUNDING);
+ mpfr_div(oneeighty_angle, oneeighty_angle, PI_mpfr_t, ROUNDING);
+ checkZero((mpfr_ptr)y_orig.data.num);
+ checkZero((mpfr_ptr)x_orig.data.num);
+ mpfr_atan2(atan2val, y_orig.data.num, x_orig.data.num, ROUNDING);
+ mpfr_mul(ret->data.num, atan2val, oneeighty_angle, ROUNDING);
+ checkZero((mpfr_ptr)ret->data.num);
+ mpfr_clear(atan2val);
+ mpfr_clear(oneeighty_angle);
+ }
+ mp_check_mpfr_t(mp, ret->data.num);
+}
+
+
+@ @<Handle undefined arg@>=
+{
+ const char *hlp[] = {
+ "The `angle' between two identical points is undefined.",
+ "I'm zeroing this one. Proceed, with fingers crossed.",
+ NULL };
+ mp_error (mp, "angle(0,0) is taken as zero", hlp, true);
+@.angle(0,0)...zero@>;
+ mpfr_set_zero(ret->data.num,1); /* 1 == positive */
+}
+
+
+@ 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|.
+
+@ Calculate sines and cosines.
+
+@c
+void mp_binary_sin_cos (MP mp, mp_number z_orig, mp_number *n_cos, mp_number *n_sin) {
+ mpfr_t rad;
+ mpfr_t one_eighty;
+ mpfr_init2(rad, precision_bits);
+ mpfr_init2(one_eighty, precision_bits);
+ mpfr_set_si(one_eighty, 180 * 16, ROUNDING);
+ mpfr_mul (rad, z_orig.data.num, PI_mpfr_t, ROUNDING);
+ mpfr_div (rad, rad, one_eighty, ROUNDING);
+
+ mpfr_sin (n_sin->data.num, rad, ROUNDING);
+ mpfr_cos (n_cos->data.num, rad, ROUNDING);
+
+ mpfr_mul (n_cos->data.num,n_cos->data.num, fraction_multiplier_mpfr_t, ROUNDING);
+ mpfr_mul (n_sin->data.num,n_sin->data.num, fraction_multiplier_mpfr_t, ROUNDING);
+ mp_check_mpfr_t(mp, n_cos->data.num);
+ mp_check_mpfr_t(mp, n_sin->data.num);
+ mpfr_clear (rad);
+ mpfr_clear (one_eighty);
+}
+
+@ This is the http://www-cs-faculty.stanford.edu/~uno/programs/rng.c
+with small cosmetic modifications.
+
+@c
+#define KK 100 /* the long lag */
+#define LL 37 /* the short lag */
+#define MM (1L<<30) /* the modulus */
+#define mod_diff(x,y) (((x)-(y))&(MM-1)) /* subtraction mod MM */
+/* */
+static long ran_x[KK]; /* the generator state */
+/* */
+static void ran_array(long aa[],int n) /* put n new random numbers in aa */
+ /* long aa[] destination */
+ /* int n array length (must be at least KK) */
+{
+ register int i,j;
+ for (j=0;j<KK;j++) aa[j]=ran_x[j];
+ for (;j<n;j++) aa[j]=mod_diff(aa[j-KK],aa[j-LL]);
+ for (i=0;i<LL;i++,j++) ran_x[i]=mod_diff(aa[j-KK],aa[j-LL]);
+ for (;i<KK;i++,j++) ran_x[i]=mod_diff(aa[j-KK],ran_x[i-LL]);
+}
+/* */
+/* the following routines are from exercise 3.6--15 */
+/* after calling |ran_start|, get new randoms by, e.g., |x=ran_arr_next()| */
+/* */
+#define QUALITY 1009 /* recommended quality level for high-res use */
+static long ran_arr_buf[QUALITY];
+static long ran_arr_dummy=-1, ran_arr_started=-1;
+static long *ran_arr_ptr=&ran_arr_dummy; /* the next random number, or -1 */
+/* */
+#define TT 70 /* guaranteed separation between streams */
+#define is_odd(x) ((x)&1) /* units bit of x */
+/* */
+static void ran_start(long seed) /* do this before using |ran_array| */
+ /* long seed selector for different streams */
+{
+ register int t,j;
+ long x[KK+KK-1]; /* the preparation buffer */
+ register long ss=(seed+2)&(MM-2);
+ for (j=0;j<KK;j++) {
+ x[j]=ss; /* bootstrap the buffer */
+ ss<<=1; if (ss>=MM) ss-=MM-2; /* cyclic shift 29 bits */
+ }
+ x[1]++; /* make x[1] (and only x[1]) odd */
+ for (ss=seed&(MM-1),t=TT-1; t; ) {
+ for (j=KK-1;j>0;j--) x[j+j]=x[j], x[j+j-1]=0; /* "square" */
+ for (j=KK+KK-2;j>=KK;j--)
+ x[j-(KK-LL)]=mod_diff(x[j-(KK-LL)],x[j]),
+ x[j-KK]=mod_diff(x[j-KK],x[j]);
+ if (is_odd(ss)) { /* "multiply by z" */
+ for (j=KK;j>0;j--) x[j]=x[j-1];
+ x[0]=x[KK]; /* shift the buffer cyclically */
+ x[LL]=mod_diff(x[LL],x[KK]);
+ }
+ if (ss) ss>>=1; else t--;
+ }
+ for (j=0;j<LL;j++) ran_x[j+KK-LL]=x[j];
+ for (;j<KK;j++) ran_x[j-LL]=x[j];
+ for (j=0;j<10;j++) ran_array(x,KK+KK-1); /* warm things up */
+ ran_arr_ptr=&ran_arr_started;
+}
+/* */
+#define ran_arr_next() (*ran_arr_ptr>=0? *ran_arr_ptr++: ran_arr_cycle())
+static long ran_arr_cycle(void)
+{
+ if (ran_arr_ptr==&ran_arr_dummy)
+ ran_start(314159L); /* the user forgot to initialize */
+ ran_array(ran_arr_buf,QUALITY);
+ ran_arr_buf[KK]=-1;
+ ran_arr_ptr=ran_arr_buf+1;
+ return ran_arr_buf[0];
+}
+
+
+
+
+@ To initialize the |randoms| table, we call the following routine.
+
+@c
+void mp_init_randoms (MP mp, int seed) {
+ int j, jj, k; /* more or less random integers */
+ int i; /* index into |randoms| */
+ j = abs (seed);
+ while (j >= fraction_one) {
+ j = j/2;
+ }
+ k = 1;
+ for (i = 0; i <= 54; i++) {
+ jj = k;
+ k = j - k;
+ j = jj;
+ if (k<0)
+ k += fraction_one;
+ mpfr_set_si(mp->randoms[(i * 21) % 55].data.num, j, ROUNDING);
+ }
+ mp_new_randoms (mp);
+ mp_new_randoms (mp);
+ mp_new_randoms (mp); /* ``warm up'' the array */
+
+ ran_start ((unsigned long)seed);
+
+}
+
+@ @c
+void mp_binary_number_modulo (mp_number *a, mp_number b) {
+ mpfr_remainder (a->data.num, a->data.num, b.data.num, ROUNDING);
+}
+
+@ To consume a random integer for the uniform generator, the program below will say `|next_unif_random|'.
+
+@c
+static void mp_next_unif_random (MP mp, mp_number *ret) {
+ mp_number rop;
+ unsigned long int op;
+ float flt_op ;
+ (void)mp;
+ mp_new_number (mp, &rop, mp_scaled_type);
+ op = (unsigned)ran_arr_next();
+ flt_op = op/(MM*1.0);
+ mpfr_set_d ((mpfr_ptr)(rop.data.num), flt_op,ROUNDING);
+ mp_number_clone (ret, rop);
+ free_number (rop);
+}
+
+
+
+@ To consume a random fraction, the program below will say `|next_random|'.
+
+@c
+static void mp_next_random (MP mp, mp_number *ret) {
+ if ( mp->j_random==0 )
+ mp_new_randoms(mp);
+ else
+ mp->j_random = mp->j_random-1;
+ mp_number_clone (ret, mp->randoms[mp->j_random]);
+}
+
+@ To produce a uniform random number in the range |0<=u<x| or |0>=u>x|
+or |0=u=x|, given a |scaled| value~|x|, we proceed as shown here.
+
+Note that the call of |take_fraction| will produce the values 0 and~|x|
+with about half the probability that it will produce any other particular
+values between 0 and~|x|, because it rounds its answers.
+
+@c
+static void mp_binary_m_unif_rand (MP mp, mp_number *ret, mp_number x_orig) {
+ mp_number y; /* trial value */
+ mp_number x, abs_x;
+ mp_number u;
+ char *r ;mpfr_exp_t e;
+ new_fraction (y);
+ new_number (x);
+ new_number (abs_x);
+ new_number (u);
+ mp_number_clone (&x, x_orig);
+ mp_number_clone (&abs_x, x);
+ mp_binary_abs (&abs_x);
+ mp_next_unif_random(mp, &u);
+ mpfr_mul (y.data.num, abs_x.data.num, u.data.num, ROUNDING);
+ free_number (u);
+ if (mp_number_equal(y, abs_x)) {
+ mp_number_clone (ret, ((math_data *)mp->math)->zero_t);
+ } else if (mp_number_greater(x, ((math_data *)mp->math)->zero_t)) {
+ mp_number_clone (ret, y);
+ } else {
+ mp_number_clone (ret, y);
+ mp_number_negate (ret);
+ }
+ r = mpfr_get_str(NULL, /* |char *str|, */
+ &e, /* |mpfr_exp_t *expptr|,*/
+ 10, /* |int b|, */
+ 0, /* |size_t n|, */
+ ret->data.num, /* |mpfr_t op|, */
+ ROUNDING /* |mpfr_rnd_t rnd|*/
+ );
+ mpfr_free_str(r);
+ free_number (abs_x);
+ free_number (x);
+ free_number (y);
+}
+
+
+
+@ Finally, a normal deviate with mean zero and unit standard deviation
+can readily be obtained with the ratio method (Algorithm 3.4.1R in
+{\sl The Art of Computer Programming\/}).
+
+@c
+static void mp_binary_m_norm_rand (MP mp, mp_number *ret) {
+ mp_number ab_vs_cd;
+ mp_number abs_x;
+ mp_number u;
+ mp_number r;
+ mp_number la, xa;
+ new_number (ab_vs_cd);
+ new_number (la);
+ new_number (xa);
+ new_number (abs_x);
+ new_number (u);
+ new_number (r);
+
+ do {
+ do {
+ mp_number v;
+ new_number (v);
+ mp_next_random(mp, &v);
+ mp_number_substract (&v, ((math_data *)mp->math)->fraction_half_t);
+ mp_binary_number_take_fraction (mp,&xa, ((math_data *)mp->math)->sqrt_8_e_k, v);
+ free_number (v);
+ mp_next_random(mp, &u);
+ mp_number_clone (&abs_x, xa);
+ mp_binary_abs (&abs_x);
+ } while (!mp_number_less(abs_x, u));
+ mp_binary_number_make_fraction (mp, &r, xa, u);
+ mp_number_clone (&xa, r);
+ mp_binary_m_log (mp,&la, u);
+ mp_set_binary_from_substraction(&la, ((math_data *)mp->math)->twelve_ln_2_k, la);
+ mp_binary_ab_vs_cd (mp,&ab_vs_cd, ((math_data *)mp->math)->one_k, la, xa, xa);
+ } while (mp_number_less(ab_vs_cd,((math_data *)mp->math)->zero_t));
+ mp_number_clone (ret, xa);
+ free_number (ab_vs_cd);
+ free_number (r);
+ free_number (abs_x);
+ free_number (la);
+ free_number (xa);
+ free_number (u);
+}
+
+
+
+@ The following subroutine is used only in |norm_rand| and tests if $ab$ is
+greater than, equal to, or less than~$cd$.
+The result is $+1$, 0, or~$-1$ in the three respective cases.
+
+@c
+static void mp_binary_ab_vs_cd (MP mp, mp_number *ret, mp_number a_orig, mp_number b_orig, mp_number c_orig, mp_number d_orig) {
+ mpfr_t a, b, c, d;
+ mpfr_t ab, cd;
+
+ int cmp = 0;
+ (void)mp;
+ mpfr_inits2(precision_bits, a,b,c,d,ab,cd,(mpfr_ptr)0);
+ mpfr_set(a, (mpfr_ptr )a_orig.data.num, ROUNDING);
+ mpfr_set(b, (mpfr_ptr )b_orig.data.num, ROUNDING);
+ mpfr_set(c, (mpfr_ptr )c_orig.data.num, ROUNDING);
+ mpfr_set(d, (mpfr_ptr )d_orig.data.num, ROUNDING);
+
+ mpfr_mul(ab,a,b, ROUNDING);
+ mpfr_mul(cd,c,d, ROUNDING);
+
+ mpfr_set(ret->data.num, zero, ROUNDING);
+ cmp = mpfr_cmp(ab,cd);
+ if (cmp) {
+ if (cmp>0)
+ mpfr_set(ret->data.num, one, ROUNDING);
+ else
+ mpfr_set(ret->data.num, minusone, ROUNDING);
+ }
+ mp_check_mpfr_t(mp, ret->data.num);
+ mpfr_clears(a,b,c,d,ab,cd,(mpfr_ptr)0);
+ return;
+}
+
+
diff --git a/Build/source/texk/web2c/mplibdir/mpmathdecimal.w b/Build/source/texk/web2c/mplibdir/mpmathdecimal.w
new file mode 100644
index 00000000000..5c2a8fe624e
--- /dev/null
+++ b/Build/source/texk/web2c/mplibdir/mpmathdecimal.w
@@ -0,0 +1,2011 @@
+% $Id$
+%
+% This file is part of MetaPost;
+% the MetaPost program is in the public domain.
+% See the <Show version...> code in mpost.w for more info.
+
+% Here is TeX material that gets inserted after \input webmac
+
+\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\pct!{{\char`\%}} % percent sign in ordinary text
+\def\psqrt#1{\sqrt{\mathstrut#1}}
+
+
+\def\title{Math support functions for decNumber based math}
+\pdfoutput=1
+
+@ Introduction.
+
+@c
+#include <w2c/config.h>
+#include <stdio.h>
+#include <stdlib.h>
+#include <string.h>
+#include <math.h>
+#include "mpmathdecimal.h" /* internal header */
+#define ROUND(a) floor((a)+0.5)
+@h
+
+@ @c
+@<Declarations@>;
+
+@ @(mpmathdecimal.h@>=
+#ifndef MPMATHDECIMAL_H
+#define MPMATHDECIMAL_H 1
+#include "mplib.h"
+#include "mpmp.h" /* internal header */
+#define DECNUMDIGITS 1000
+#include "decNumber.h"
+@<Internal library declarations@>;
+#endif
+
+@* Math initialization.
+
+First, here are some very important constants.
+
+@d E_STRING "2.7182818284590452353602874713526624977572470936999595749669676277240766303535"
+@d PI_STRING "3.1415926535897932384626433832795028841971693993751058209749445923078164062862"
+@d fraction_multiplier 4096
+@d angle_multiplier 16
+
+@ Here are the functions that are static as they are not used elsewhere
+
+@<Declarations@>=
+#define DEBUG 0
+static void mp_decimal_scan_fractional_token (MP mp, int n);
+static void mp_decimal_scan_numeric_token (MP mp, int n);
+static void mp_ab_vs_cd (MP mp, mp_number *ret, mp_number a, mp_number b, mp_number c, mp_number d);
+/*|static void mp_decimal_ab_vs_cd (MP mp, mp_number *ret, mp_number a, mp_number b, mp_number c, mp_number d);|*/
+static void mp_decimal_crossing_point (MP mp, mp_number *ret, mp_number a, mp_number b, mp_number c);
+static void mp_decimal_number_modulo (mp_number *a, mp_number b);
+static void mp_decimal_print_number (MP mp, mp_number n);
+static char * mp_decimal_number_tostring (MP mp, mp_number n);
+static void mp_decimal_slow_add (MP mp, mp_number *ret, mp_number x_orig, mp_number y_orig);
+static void mp_decimal_square_rt (MP mp, mp_number *ret, mp_number x_orig);
+static void mp_decimal_sin_cos (MP mp, mp_number z_orig, mp_number *n_cos, mp_number *n_sin);
+static void mp_init_randoms (MP mp, int seed);
+static void mp_number_angle_to_scaled (mp_number *A);
+static void mp_number_fraction_to_scaled (mp_number *A);
+static void mp_number_scaled_to_fraction (mp_number *A);
+static void mp_number_scaled_to_angle (mp_number *A);
+static void mp_decimal_m_unif_rand (MP mp, mp_number *ret, mp_number x_orig);
+static void mp_decimal_m_norm_rand (MP mp, mp_number *ret);
+static void mp_decimal_m_exp (MP mp, mp_number *ret, mp_number x_orig);
+static void mp_decimal_m_log (MP mp, mp_number *ret, mp_number x_orig);
+static void mp_decimal_pyth_sub (MP mp, mp_number *r, mp_number a, mp_number b);
+static void mp_decimal_pyth_add (MP mp, mp_number *r, mp_number a, mp_number b);
+static void mp_decimal_n_arg (MP mp, mp_number *ret, mp_number x, mp_number y);
+static void mp_decimal_velocity (MP mp, mp_number *ret, mp_number st, mp_number ct, mp_number sf, mp_number cf, mp_number t);
+static void mp_set_decimal_from_int(mp_number *A, int B);
+static void mp_set_decimal_from_boolean(mp_number *A, int B);
+static void mp_set_decimal_from_scaled(mp_number *A, int B);
+static void mp_set_decimal_from_addition(mp_number *A, mp_number B, mp_number C);
+static void mp_set_decimal_from_substraction (mp_number *A, mp_number B, mp_number C);
+static void mp_set_decimal_from_div(mp_number *A, mp_number B, mp_number C);
+static void mp_set_decimal_from_mul(mp_number *A, mp_number B, mp_number C);
+static void mp_set_decimal_from_int_div(mp_number *A, mp_number B, int C);
+static void mp_set_decimal_from_int_mul(mp_number *A, mp_number B, int C);
+static void mp_set_decimal_from_of_the_way(MP mp, mp_number *A, mp_number t, mp_number B, mp_number C);
+static void mp_number_negate(mp_number *A);
+static void mp_number_add(mp_number *A, mp_number B);
+static void mp_number_substract(mp_number *A, mp_number B);
+static void mp_number_half(mp_number *A);
+static void mp_number_halfp(mp_number *A);
+static void mp_number_double(mp_number *A);
+static void mp_number_add_scaled(mp_number *A, int B); /* also for negative B */
+static void mp_number_multiply_int(mp_number *A, int B);
+static void mp_number_divide_int(mp_number *A, int B);
+static void mp_decimal_abs(mp_number *A);
+static void mp_number_clone(mp_number *A, mp_number B);
+static void mp_number_swap(mp_number *A, mp_number *B);
+static int mp_round_unscaled(mp_number x_orig);
+static int mp_number_to_int(mp_number A);
+static int mp_number_to_scaled(mp_number A);
+static int mp_number_to_boolean(mp_number A);
+static double mp_number_to_double(mp_number A);
+static int mp_number_odd(mp_number A);
+static int mp_number_equal(mp_number A, mp_number B);
+static int mp_number_greater(mp_number A, mp_number B);
+static int mp_number_less(mp_number A, mp_number B);
+static int mp_number_nonequalabs(mp_number A, mp_number B);
+static void mp_number_floor (mp_number *i);
+static void mp_decimal_fraction_to_round_scaled (mp_number *x);
+static void mp_decimal_number_make_scaled (MP mp, mp_number *r, mp_number p, mp_number q);
+static void mp_decimal_number_make_fraction (MP mp, mp_number *r, mp_number p, mp_number q);
+static void mp_decimal_number_take_fraction (MP mp, mp_number *r, mp_number p, mp_number q);
+static void mp_decimal_number_take_scaled (MP mp, mp_number *r, mp_number p, mp_number q);
+static void mp_new_number (MP mp, mp_number *n, mp_number_type t) ;
+static void mp_free_number (MP mp, mp_number *n) ;
+static void mp_set_decimal_from_double(mp_number *A, double B);
+static void mp_free_decimal_math (MP mp);
+static void mp_decimal_set_precision (MP mp);
+static void mp_check_decNumber (MP mp, decNumber *dec, decContext *context);
+static int decNumber_check (decNumber *dec, decContext *context);
+static char * mp_decnumber_tostring (decNumber *n);
+
+@ We do not want special numbers as return values for functions, so:
+
+
+@c
+int decNumber_check (decNumber *dec, decContext *context)
+{
+ int test = false;
+ if (context->status & DEC_Overflow) {
+ test = true;
+ context->status &= ~DEC_Overflow;
+ }
+ if (context->status & DEC_Underflow) {
+ test = true;
+ context->status &= ~DEC_Underflow;
+ }
+ if (context->status & DEC_Errors) {
+/*|fprintf(stdout, "DEC_ERROR %x (%s)\n", context->status, decContextStatusToString(context));|*/
+ test = true;
+ decNumberZero(dec);
+ }
+ context->status = 0;
+ if (decNumberIsSpecial(dec)) {
+ test = true;
+ if (decNumberIsInfinite(dec)) {
+ if (decNumberIsNegative(dec)) {
+ decNumberCopyNegate(dec, &EL_GORDO_decNumber);
+ } else {
+ decNumberCopy(dec, &EL_GORDO_decNumber);
+ }
+ } else { /* Nan */
+ decNumberZero(dec);
+ }
+ }
+ if (decNumberIsZero(dec) && decNumberIsNegative(dec)) {
+ decNumberZero(dec);
+ }
+ return test;
+}
+void mp_check_decNumber (MP mp, decNumber *dec, decContext *context)
+{
+ mp->arith_error = decNumber_check (dec, context);
+}
+
+
+
+
+@ There are a few short decNumber functions that do not exist, but
+make life easier for us:
+
+@d decNumberIsPositive(A) !(decNumberIsZero(A) || decNumberIsNegative(A))
+
+@c
+static decContext set;
+static decContext limitedset;
+static void checkZero (decNumber *ret) {
+ if (decNumberIsZero(ret) && decNumberIsNegative(ret))
+ decNumberZero(ret);
+}
+static int decNumberLess(decNumber *a, decNumber *b) {
+ decNumber comp;
+ decNumberCompare(&comp, a, b, &set);
+ return decNumberIsNegative(&comp);
+}
+static int decNumberGreater(decNumber *a, decNumber *b) {
+ decNumber comp;
+ decNumberCompare(&comp, a, b, &set);
+ return decNumberIsPositive(&comp);
+}
+static void decNumberFromDouble(decNumber *A, double B) {
+ char buf[1000];
+ char *c;
+ snprintf(buf,1000,"%-650.325lf",B);
+ c = buf;
+ while (*c++) {
+ if (*c == ' ') {
+ *c = '\0';
+ break;
+ }
+ }
+ decNumberFromString(A, buf, &set);
+}
+static double decNumberToDouble(decNumber *A) {
+ char *buffer = malloc(A->digits + 14);
+ double res = 0.0;
+ assert (buffer);
+ decNumberToString(A, buffer);
+ if (sscanf(buffer, "%lf", &res)) {
+ free(buffer);
+ return res;
+ } else {
+ free(buffer);
+ /*|mp->arith_error = 1;|*/
+ return 0.0; /* whatever*/
+ }
+}
+@ Borrowed code from libdfp:
+
+% x^3 x^5 x^7
+%arctan(x) = x - --- + --- - --- + ...
+% 3 5 7
+$$ \arctan(x) = x - {x^3\over3} + {x^5\over5} - {x^7\over7} + \ldots$$
+
+
+This power series works well, if $x$ is close to zero ($|x|<0.5$).
+If x is larger, the series converges too slowly,
+so in order to get a smaller x, we apply the identity
+
+% sqrt(1+x^2) - 1
+%arctan(x) = 2*arctan ---------------
+% x
+$$ \arctan(x) = 2\,\arctan{{\sqrt{1+x^2}-1}\over x}$$
+
+twice. The first application gives us a new $x$ with $x < 1$.
+The second application gives us a new x with $x < 0.4142136$.
+For that $x$, we use the power series and multiply the result by four.
+
+
+
+@c
+static void decNumberAtan (decNumber *result, decNumber *x_orig, decContext *set)
+{
+ decNumber x, f, g, mx2, term;
+ int i;
+ decNumberCopy(&x, x_orig);
+ if (decNumberIsZero (&x)) {
+ decNumberCopy (result, &x);
+ return;
+ }
+ for (i=0; i<2; i++) {
+ decNumber y;
+ decNumberMultiply (&y, &x, &x, set); /* $y = x^2$ */
+ decNumberAdd (&y, &y, &one, set); /* $y = y+1$*/
+ decNumberSquareRoot (&y, &y, set); /* $y = sqrt(y)$ */
+ decNumberSubtract (&y, &y, &one, set); /* $y = y-1$ */
+ decNumberDivide (&x, &y, &x, set); /* $x = y/x$ */
+ if (decNumberIsZero (&x)) {
+ decNumberCopy (result, &x);
+ return;
+ }
+ }
+ decNumberCopy (&f, &x); /* $f(0) = x$ */
+ decNumberCopy (&g, &one); /*$ g(0) = 1$*/
+ decNumberCopy (&term, &x); /*$ term = x$*/
+ decNumberCopy (result, &x); /*$ sum = x $*/
+ decNumberMultiply (&mx2, &x, &x, set); /*$ mx2 = x^2$*/
+ decNumberMinus (&mx2, &mx2, set); /*$ mx2 = -x^2 $*/
+ for (i=0; i<2*set->digits; i++) {
+ decNumberMultiply (&f, &f, &mx2, set);
+ decNumberAdd (&g, &g, &two_decNumber, set);
+ decNumberDivide (&term, &f, &g, set);
+ decNumberAdd (result, result, &term, set);
+ }
+ decNumberAdd (result, result, result, set);
+ decNumberAdd (result, result, result, set);
+ return;
+}
+static void decNumberAtan2 (decNumber *result, decNumber *y, decNumber *x, decContext *set)
+{
+ decNumber temp;
+ if (!decNumberIsInfinite (x) && !decNumberIsZero (y)
+ && !decNumberIsInfinite (y) && !decNumberIsZero (x)) {
+ decNumberDivide (&temp, y, x, set);
+ decNumberAtan (result, &temp, set);
+ /* decNumberAtan doesn't quite return the values in the ranges we
+ * want for x < 0. So we need to do some correction */
+ if (decNumberIsNegative (x)) {
+ if (decNumberIsNegative (y)) {
+ decNumberSubtract(result, result, &PI_decNumber, set);
+ } else {
+ decNumberAdd(result, result, &PI_decNumber, set);
+ }
+ }
+ return;
+ }
+ if (decNumberIsInfinite (y) && decNumberIsInfinite (x)) {
+ /* If x and y are both inf, the result depends on the sign of x */
+ decNumberDivide(result, &PI_decNumber, &four_decNumber, set);
+ if (decNumberIsNegative (x) ) {
+ decNumber a;
+ decNumberFromDouble(&a, 3.0);
+ decNumberMultiply(result, result, &a, set);
+ }
+ } else if (!decNumberIsZero (y) && !decNumberIsInfinite (x) ) {
+ /* If y is non-zero and x is non-inf, the result is +-pi/2 */
+ decNumberDivide(result, &PI_decNumber, &two_decNumber, set);
+ } else { /* Otherwise it is +0 if x is positive, +pi if x is neg */
+ if (decNumberIsNegative (x)) {
+ decNumberCopy(result, &PI_decNumber);
+ } else {
+ decNumberZero(result);
+ }
+ }
+ /* Atan2 will be negative if y<0 */
+ if (decNumberIsNegative (y)) {
+ decNumberMinus(result, result, set);
+ }
+}
+
+@ And these are the ones that {\it are} used elsewhere
+
+@<Internal library declarations@>=
+void * mp_initialize_decimal_math (MP mp);
+
+@
+
+@d unity 1
+@d two 2
+@d three 3
+@d four 4
+@d half_unit 0.5
+@d three_quarter_unit 0.75
+@d coef_bound ((7.0/3.0)*fraction_multiplier) /* |fraction| approximation to 7/3 */
+@d fraction_threshold 0.04096 /* a |fraction| coefficient less than this is zeroed */
+@d half_fraction_threshold (fraction_threshold/2) /* half of |fraction_threshold| */
+@d scaled_threshold 0.000122 /* a |scaled| coefficient less than this is zeroed */
+@d half_scaled_threshold (scaled_threshold/2) /* half of |scaled_threshold| */
+@d near_zero_angle (0.0256*angle_multiplier) /* an angle of about 0.0256 */
+@d p_over_v_threshold 0x80000 /* TODO */
+@d equation_threshold 0.001
+@d tfm_warn_threshold 0.0625
+@d epsilon pow(2.0,-173.0) /* almost "1E-52" */
+@d epsilonf pow(2.0,-52.0)
+@d EL_GORDO "1E1000000" /* the largest value that \MP\ likes. */
+@d warning_limit "1E1000000" /* this is a large value that can just be expressed without loss of precision */
+@d DECPRECISION_DEFAULT 34
+
+@<Declarations@>=
+static decNumber zero;
+static decNumber one;
+static decNumber minusone;
+static decNumber two_decNumber;
+static decNumber three_decNumber;
+static decNumber four_decNumber;
+static decNumber fraction_multiplier_decNumber;
+static decNumber angle_multiplier_decNumber;
+static decNumber fraction_one_decNumber;
+static decNumber fraction_one_plus_decNumber;
+static decNumber PI_decNumber;
+static decNumber epsilon_decNumber;
+static decNumber EL_GORDO_decNumber;
+static decNumber **factorials = NULL;
+static int last_cached_factorial = 0;
+static boolean initialized = false ;
+@ @c
+void * mp_initialize_decimal_math (MP mp) {
+ math_data *math = (math_data *)mp_xmalloc(mp,1,sizeof(math_data));
+ /* various decNumber initializations */
+ decContextDefault(&set, DEC_INIT_BASE); /* initialize */
+ set.traps=0; /* no traps, thank you */
+ decContextDefault(&limitedset, DEC_INIT_BASE); /* initialize */
+ limitedset.traps=0; /* no traps, thank you */
+ limitedset.emax = 999999;
+ limitedset.emin = -999999;
+ set.digits = DECPRECISION_DEFAULT;
+ limitedset.digits = DECPRECISION_DEFAULT;
+ if (!initialized) {
+ initialized = true ;
+ decNumberFromInt32(&one, 1);
+ decNumberFromInt32(&minusone, -1);
+ decNumberFromInt32(&zero, 0);
+ decNumberFromInt32(&two_decNumber, two);
+ decNumberFromInt32(&three_decNumber, three);
+ decNumberFromInt32(&four_decNumber, four);
+ decNumberFromInt32(&fraction_multiplier_decNumber, fraction_multiplier);
+ decNumberFromInt32(&fraction_one_decNumber, fraction_one);
+ decNumberFromInt32(&fraction_one_plus_decNumber, (fraction_one+1));
+ decNumberFromInt32(&angle_multiplier_decNumber, angle_multiplier);
+ decNumberFromString(&PI_decNumber, PI_STRING, &set);
+ decNumberFromDouble(&epsilon_decNumber, epsilon);
+ decNumberFromString(&EL_GORDO_decNumber, EL_GORDO, &set);
+ factorials = (decNumber **)mp_xmalloc(mp,PRECALC_FACTORIALS_CACHESIZE,sizeof(decNumber *));
+ factorials[0] = (decNumber *)mp_xmalloc(mp,1,sizeof(decNumber));
+ decNumberCopy(factorials[0], &one);
+ }
+
+ /* alloc */
+ math->allocate = mp_new_number;
+ math->free = mp_free_number;
+ mp_new_number (mp, &math->precision_default, mp_scaled_type);
+ decNumberFromInt32(math->precision_default.data.num, DECPRECISION_DEFAULT);
+ mp_new_number (mp, &math->precision_max, mp_scaled_type);
+ decNumberFromInt32(math->precision_max.data.num, DECNUMDIGITS);
+ mp_new_number (mp, &math->precision_min, mp_scaled_type);
+ decNumberFromInt32(math->precision_min.data.num, 2);
+ /* here are the constants for |scaled| objects */
+ mp_new_number (mp, &math->epsilon_t, mp_scaled_type);
+ decNumberCopy(math->epsilon_t.data.num, &epsilon_decNumber);
+ mp_new_number (mp, &math->inf_t, mp_scaled_type);
+ decNumberCopy(math->inf_t.data.num, &EL_GORDO_decNumber);
+ mp_new_number (mp, &math->warning_limit_t, mp_scaled_type);
+ decNumberFromString(math->warning_limit_t.data.num, warning_limit, &set);
+ mp_new_number (mp, &math->one_third_inf_t, mp_scaled_type);
+ decNumberDivide(math->one_third_inf_t.data.num, math->inf_t.data.num, &three_decNumber, &set);
+ mp_new_number (mp, &math->unity_t, mp_scaled_type);
+ decNumberCopy(math->unity_t.data.num, &one);
+ mp_new_number (mp, &math->two_t, mp_scaled_type);
+ decNumberFromInt32(math->two_t.data.num, two);
+ mp_new_number (mp, &math->three_t, mp_scaled_type);
+ decNumberFromInt32(math->three_t.data.num, three);
+ mp_new_number (mp, &math->half_unit_t, mp_scaled_type);
+ decNumberFromString(math->half_unit_t.data.num, "0.5", &set);
+ mp_new_number (mp, &math->three_quarter_unit_t, mp_scaled_type);
+ decNumberFromString(math->three_quarter_unit_t.data.num, "0.75", &set);
+ mp_new_number (mp, &math->zero_t, mp_scaled_type);
+ decNumberZero(math->zero_t.data.num);
+ /* |fractions| */
+ mp_new_number (mp, &math->arc_tol_k, mp_fraction_type);
+ {
+ decNumber fourzeroninesix;
+ decNumberFromInt32(&fourzeroninesix, 4096);
+ decNumberDivide(math->arc_tol_k.data.num, &one, &fourzeroninesix, &set);
+ /* quit when change in arc length estimate reaches this */
+ }
+ mp_new_number (mp, &math->fraction_one_t, mp_fraction_type);
+ decNumberFromInt32(math->fraction_one_t.data.num, fraction_one);
+ mp_new_number (mp, &math->fraction_half_t, mp_fraction_type);
+ decNumberFromInt32(math->fraction_half_t.data.num, fraction_half);
+ mp_new_number (mp, &math->fraction_three_t, mp_fraction_type);
+ decNumberFromInt32(math->fraction_three_t.data.num, fraction_three);
+ mp_new_number (mp, &math->fraction_four_t, mp_fraction_type);
+ decNumberFromInt32(math->fraction_four_t.data.num, fraction_four);
+ /* |angles| */
+ mp_new_number (mp, &math->three_sixty_deg_t, mp_angle_type);
+ decNumberFromInt32(math->three_sixty_deg_t.data.num, 360 * angle_multiplier);
+ mp_new_number (mp, &math->one_eighty_deg_t, mp_angle_type);
+ decNumberFromInt32(math->one_eighty_deg_t.data.num, 180 * angle_multiplier);
+ /* various approximations */
+ mp_new_number (mp, &math->one_k, mp_scaled_type);
+ decNumberFromDouble(math->one_k.data.num, 1.0/64);
+ mp_new_number (mp, &math->sqrt_8_e_k, mp_scaled_type);
+ {
+ decNumberFromDouble(math->sqrt_8_e_k.data.num, 112428.82793 / 65536.0);
+ /* $2^{16}\sqrt{8/e}\approx 112428.82793$ */
+ }
+ mp_new_number (mp, &math->twelve_ln_2_k, mp_fraction_type);
+ {
+ decNumberFromDouble(math->twelve_ln_2_k.data.num, 139548959.6165 / 65536.0);
+ /* $2^{24}\cdot12\ln2\approx139548959.6165$ */
+ }
+ mp_new_number (mp, &math->coef_bound_k, mp_fraction_type);
+ decNumberFromDouble(math->coef_bound_k.data.num,coef_bound);
+ mp_new_number (mp, &math->coef_bound_minus_1, mp_fraction_type);
+ decNumberFromDouble(math->coef_bound_minus_1.data.num,coef_bound - 1 / 65536.0);
+ mp_new_number (mp, &math->twelvebits_3, mp_scaled_type);
+ {
+ decNumberFromDouble(math->twelvebits_3.data.num, 1365 / 65536.0);
+ /* $1365\approx 2^{12}/3$ */
+ }
+ mp_new_number (mp, &math->twentysixbits_sqrt2_t, mp_fraction_type);
+ {
+ decNumberFromDouble(math->twentysixbits_sqrt2_t.data.num, 94906265.62 / 65536.0);
+ /* $2^{26}\sqrt2\approx94906265.62$ */
+ }
+ mp_new_number (mp, &math->twentyeightbits_d_t, mp_fraction_type);
+ {
+ decNumberFromDouble(math->twentyeightbits_d_t.data.num, 35596754.69 / 65536.0);
+ /* $2^{28}d\approx35596754.69$ */
+ }
+ mp_new_number (mp, &math->twentysevenbits_sqrt2_d_t, mp_fraction_type);
+ {
+ decNumberFromDouble(math->twentysevenbits_sqrt2_d_t.data.num, 25170706.63 / 65536.0);
+ /* $2^{27}\sqrt2\,d\approx25170706.63$ */
+ }
+ /* thresholds */
+ mp_new_number (mp, &math->fraction_threshold_t, mp_fraction_type);
+ decNumberFromDouble(math->fraction_threshold_t.data.num, fraction_threshold);
+ mp_new_number (mp, &math->half_fraction_threshold_t, mp_fraction_type);
+ decNumberFromDouble(math->half_fraction_threshold_t.data.num, half_fraction_threshold);
+ mp_new_number (mp, &math->scaled_threshold_t, mp_scaled_type);
+ decNumberFromDouble(math->scaled_threshold_t.data.num, scaled_threshold);
+ mp_new_number (mp, &math->half_scaled_threshold_t, mp_scaled_type);
+ decNumberFromDouble(math->half_scaled_threshold_t.data.num, half_scaled_threshold);
+ mp_new_number (mp, &math->near_zero_angle_t, mp_angle_type);
+ decNumberFromDouble(math->near_zero_angle_t.data.num, near_zero_angle);
+ mp_new_number (mp, &math->p_over_v_threshold_t, mp_fraction_type);
+ decNumberFromDouble(math->p_over_v_threshold_t.data.num, p_over_v_threshold);
+ mp_new_number (mp, &math->equation_threshold_t, mp_scaled_type);
+ decNumberFromDouble(math->equation_threshold_t.data.num, equation_threshold);
+ mp_new_number (mp, &math->tfm_warn_threshold_t, mp_scaled_type);
+ decNumberFromDouble(math->tfm_warn_threshold_t.data.num, tfm_warn_threshold);
+ /* functions */
+ math->from_int = mp_set_decimal_from_int;
+ math->from_boolean = mp_set_decimal_from_boolean;
+ math->from_scaled = mp_set_decimal_from_scaled;
+ math->from_double = mp_set_decimal_from_double;
+ math->from_addition = mp_set_decimal_from_addition;
+ math->from_substraction = mp_set_decimal_from_substraction;
+ math->from_oftheway = mp_set_decimal_from_of_the_way;
+ math->from_div = mp_set_decimal_from_div;
+ math->from_mul = mp_set_decimal_from_mul;
+ math->from_int_div = mp_set_decimal_from_int_div;
+ math->from_int_mul = mp_set_decimal_from_int_mul;
+ math->negate = mp_number_negate;
+ math->add = mp_number_add;
+ math->substract = mp_number_substract;
+ math->half = mp_number_half;
+ math->halfp = mp_number_halfp;
+ math->do_double = mp_number_double;
+ math->abs = mp_decimal_abs;
+ math->clone = mp_number_clone;
+ math->swap = mp_number_swap;
+ math->add_scaled = mp_number_add_scaled;
+ math->multiply_int = mp_number_multiply_int;
+ math->divide_int = mp_number_divide_int;
+ math->to_boolean = mp_number_to_boolean;
+ math->to_scaled = mp_number_to_scaled;
+ math->to_double = mp_number_to_double;
+ math->to_int = mp_number_to_int;
+ math->odd = mp_number_odd;
+ math->equal = mp_number_equal;
+ math->less = mp_number_less;
+ math->greater = mp_number_greater;
+ math->nonequalabs = mp_number_nonequalabs;
+ math->round_unscaled = mp_round_unscaled;
+ math->floor_scaled = mp_number_floor;
+ math->fraction_to_round_scaled = mp_decimal_fraction_to_round_scaled;
+ math->make_scaled = mp_decimal_number_make_scaled;
+ math->make_fraction = mp_decimal_number_make_fraction;
+ math->take_fraction = mp_decimal_number_take_fraction;
+ math->take_scaled = mp_decimal_number_take_scaled;
+ math->velocity = mp_decimal_velocity;
+ math->n_arg = mp_decimal_n_arg;
+ math->m_log = mp_decimal_m_log;
+ math->m_exp = mp_decimal_m_exp;
+ math->m_unif_rand = mp_decimal_m_unif_rand;
+ math->m_norm_rand = mp_decimal_m_norm_rand;
+ math->pyth_add = mp_decimal_pyth_add;
+ math->pyth_sub = mp_decimal_pyth_sub;
+ math->fraction_to_scaled = mp_number_fraction_to_scaled;
+ math->scaled_to_fraction = mp_number_scaled_to_fraction;
+ math->scaled_to_angle = mp_number_scaled_to_angle;
+ math->angle_to_scaled = mp_number_angle_to_scaled;
+ math->init_randoms = mp_init_randoms;
+ math->sin_cos = mp_decimal_sin_cos;
+ math->slow_add = mp_decimal_slow_add;
+ math->sqrt = mp_decimal_square_rt;
+ math->print = mp_decimal_print_number;
+ math->tostring = mp_decimal_number_tostring;
+ math->modulo = mp_decimal_number_modulo;
+ math->ab_vs_cd = mp_ab_vs_cd;
+ math->crossing_point = mp_decimal_crossing_point;
+ math->scan_numeric = mp_decimal_scan_numeric_token;
+ math->scan_fractional = mp_decimal_scan_fractional_token;
+ math->free_math = mp_free_decimal_math;
+ math->set_precision = mp_decimal_set_precision;
+ return (void *)math;
+}
+
+void mp_decimal_set_precision (MP mp) {
+ int i;
+ i = decNumberToInt32((decNumber *)internal_value (mp_number_precision).data.num, &set);
+ set.digits = i;
+ limitedset.digits = i;
+}
+
+void mp_free_decimal_math (MP mp) {
+ free_number (((math_data *)mp->math)->three_sixty_deg_t);
+ free_number (((math_data *)mp->math)->one_eighty_deg_t);
+ free_number (((math_data *)mp->math)->fraction_one_t);
+ free_number (((math_data *)mp->math)->zero_t);
+ free_number (((math_data *)mp->math)->half_unit_t);
+ free_number (((math_data *)mp->math)->three_quarter_unit_t);
+ free_number (((math_data *)mp->math)->unity_t);
+ free_number (((math_data *)mp->math)->two_t);
+ free_number (((math_data *)mp->math)->three_t);
+ free_number (((math_data *)mp->math)->one_third_inf_t);
+ free_number (((math_data *)mp->math)->inf_t);
+ free_number (((math_data *)mp->math)->warning_limit_t);
+ free_number (((math_data *)mp->math)->one_k);
+ free_number (((math_data *)mp->math)->sqrt_8_e_k);
+ free_number (((math_data *)mp->math)->twelve_ln_2_k);
+ free_number (((math_data *)mp->math)->coef_bound_k);
+ free_number (((math_data *)mp->math)->coef_bound_minus_1);
+ free_number (((math_data *)mp->math)->fraction_threshold_t);
+ free_number (((math_data *)mp->math)->half_fraction_threshold_t);
+ free_number (((math_data *)mp->math)->scaled_threshold_t);
+ free_number (((math_data *)mp->math)->half_scaled_threshold_t);
+ free_number (((math_data *)mp->math)->near_zero_angle_t);
+ free_number (((math_data *)mp->math)->p_over_v_threshold_t);
+ free_number (((math_data *)mp->math)->equation_threshold_t);
+ free_number (((math_data *)mp->math)->tfm_warn_threshold_t);
+ /* For sake of speed, we accept this memory leak. */
+ /* for (i = 0; i <= last_cached_factorial; i++) {*/
+ /* free(factorials[i]);*/
+ /* }*/
+ /* free(factorials); */
+ free(mp->math);
+}
+
+@ Creating an destroying |mp_number| objects
+
+@ @c
+void mp_new_number (MP mp, mp_number *n, mp_number_type t) {
+ (void)mp;
+ n->data.num = mp_xmalloc(mp,1,sizeof(decNumber));
+ decNumberZero(n->data.num);
+ n->type = t;
+}
+
+@
+
+@c
+void mp_free_number (MP mp, mp_number *n) {
+ (void)mp;
+ free(n->data.num);
+ n->data.num = NULL;
+ n->type = mp_nan_type;
+}
+
+@ Here are the low-level functions on |mp_number| items, setters first.
+
+@c
+void mp_set_decimal_from_int(mp_number *A, int B) {
+ decNumberFromInt32(A->data.num,B);
+}
+void mp_set_decimal_from_boolean(mp_number *A, int B) {
+ decNumberFromInt32(A->data.num,B);
+}
+void mp_set_decimal_from_scaled(mp_number *A, int B) {
+ decNumber c;
+ decNumberFromInt32(&c, 65536);
+ decNumberFromInt32(A->data.num,B);
+ decNumberDivide(A->data.num,A->data.num,&c, &set);
+}
+void mp_set_decimal_from_double(mp_number *A, double B) {
+ decNumberFromDouble(A->data.num, B);
+}
+void mp_set_decimal_from_addition(mp_number *A, mp_number B, mp_number C) {
+ decNumberAdd(A->data.num,B.data.num,C.data.num, &set);
+}
+void mp_set_decimal_from_substraction (mp_number *A, mp_number B, mp_number C) {
+ decNumberSubtract(A->data.num,B.data.num,C.data.num, &set);
+}
+void mp_set_decimal_from_div(mp_number *A, mp_number B, mp_number C) {
+ decNumberDivide(A->data.num,B.data.num,C.data.num, &set);
+}
+void mp_set_decimal_from_mul(mp_number *A, mp_number B, mp_number C) {
+ decNumberMultiply(A->data.num,B.data.num,C.data.num, &set);
+}
+void mp_set_decimal_from_int_div(mp_number *A, mp_number B, int C) {
+ decNumber c;
+ decNumberFromInt32(&c, C);
+ decNumberDivide(A->data.num,B.data.num,&c, &set);
+}
+void mp_set_decimal_from_int_mul(mp_number *A, mp_number B, int C) {
+ decNumber c;
+ decNumberFromInt32(&c, C);
+ decNumberMultiply(A->data.num,B.data.num,&c, &set);
+}
+void mp_set_decimal_from_of_the_way(MP mp, mp_number *A, mp_number t, mp_number B, mp_number C) {
+ decNumber c;
+ decNumber r1;
+ decNumberSubtract(&c,B.data.num, C.data.num, &set);
+ mp_decimal_take_fraction(mp, &r1, &c, t.data.num);
+ decNumberSubtract(A->data.num, B.data.num, &r1, &set);
+ mp_check_decNumber(mp, A->data.num, &set);
+}
+void mp_number_negate(mp_number *A) {
+ decNumberCopyNegate(A->data.num, A->data.num);
+ checkZero(A->data.num);
+}
+void mp_number_add(mp_number *A, mp_number B) {
+ decNumberAdd(A->data.num,A->data.num,B.data.num, &set);
+}
+void mp_number_substract(mp_number *A, mp_number B) {
+ decNumberSubtract(A->data.num,A->data.num,B.data.num, &set);
+}
+void mp_number_half(mp_number *A) {
+ decNumber c;
+ decNumberFromInt32(&c, 2);
+ decNumberDivide(A->data.num,A->data.num, &c, &set);
+}
+void mp_number_halfp(mp_number *A) {
+ decNumber c;
+ decNumberFromInt32(&c, 2);
+ decNumberDivide(A->data.num,A->data.num, &c, &set);
+}
+void mp_number_double(mp_number *A) {
+ decNumber c;
+ decNumberFromInt32(&c, 2);
+ decNumberMultiply(A->data.num,A->data.num, &c, &set);
+}
+void mp_number_add_scaled(mp_number *A, int B) { /* also for negative B */
+ decNumber b,c;
+ decNumberFromInt32(&c, 65536);
+ decNumberFromInt32(&b, B);
+ decNumberDivide(&b,&b, &c, &set);
+ decNumberAdd(A->data.num,A->data.num, &b, &set);
+}
+void mp_number_multiply_int(mp_number *A, int B) {
+ decNumber b;
+ decNumberFromInt32(&b, B);
+ decNumberMultiply(A->data.num,A->data.num, &b, &set);
+}
+void mp_number_divide_int(mp_number *A, int B) {
+ decNumber b;
+ decNumberFromInt32(&b, B);
+ decNumberDivide(A->data.num,A->data.num,&b, &set);
+}
+void mp_decimal_abs(mp_number *A) {
+ decNumberAbs(A->data.num, A->data.num, &set);
+}
+void mp_number_clone(mp_number *A, mp_number B) {
+ decNumberCopy(A->data.num, B.data.num);
+}
+void mp_number_swap(mp_number *A, mp_number *B) {
+ decNumber swap_tmp;
+ decNumberCopy(&swap_tmp, A->data.num);
+ decNumberCopy(A->data.num, B->data.num);
+ decNumberCopy(B->data.num, &swap_tmp);
+}
+void mp_number_fraction_to_scaled (mp_number *A) {
+ A->type = mp_scaled_type;
+ decNumberDivide(A->data.num, A->data.num, &fraction_multiplier_decNumber, &set);
+}
+void mp_number_angle_to_scaled (mp_number *A) {
+ A->type = mp_scaled_type;
+ decNumberDivide(A->data.num, A->data.num, &angle_multiplier_decNumber, &set);
+}
+void mp_number_scaled_to_fraction (mp_number *A) {
+ A->type = mp_fraction_type;
+ decNumberMultiply(A->data.num, A->data.num, &fraction_multiplier_decNumber, &set);
+}
+void mp_number_scaled_to_angle (mp_number *A) {
+ A->type = mp_angle_type;
+ decNumberMultiply(A->data.num, A->data.num, &angle_multiplier_decNumber, &set);
+}
+
+
+@* Query functions.
+
+@ Convert a number to a scaled value. |decNumberToInt32| is not
+able to make this conversion properly, so instead we are using
+|decNumberToDouble| and a typecast. Bad!
+
+@c
+int mp_number_to_scaled(mp_number A) {
+ int32_t result;
+ decNumber corrected;
+ decNumberFromInt32(&corrected, 65536);
+ decNumberMultiply(&corrected,&corrected,A.data.num, &set);
+ decNumberReduce(&corrected, &corrected, &set);
+ result = (int)floor(decNumberToDouble(&corrected)+0.5);
+ return result;
+}
+
+@
+
+@d odd(A) (abs(A)%2==1)
+
+@c
+int mp_number_to_int(mp_number A) {
+ int32_t result;
+ set.status = 0;
+ result = decNumberToInt32(A.data.num, &set);
+ if (set.status == DEC_Invalid_operation) {
+ set.status = 0;
+ /* |mp->arith_error = 1;| */
+ return 0; /* whatever */
+ } else {
+ return result;
+ }
+}
+int mp_number_to_boolean(mp_number A) {
+ uint32_t result;
+ set.status = 0;
+ result = decNumberToUInt32(A.data.num, &set);
+ if (set.status == DEC_Invalid_operation) {
+ set.status = 0;
+ /* |mp->arith_error = 1;| */
+ return mp_false_code; /* whatever */
+ } else {
+ return result ;
+ }
+}
+double mp_number_to_double(mp_number A) {
+ char *buffer = malloc(((decNumber *)A.data.num)->digits + 14);
+ double res = 0.0;
+ assert (buffer);
+ decNumberToString(A.data.num, buffer);
+ if (sscanf(buffer, "%lf", &res)) {
+ free(buffer);
+ return res;
+ } else {
+ free(buffer);
+ /* |mp->arith_error = 1;| */
+ return 0.0; /* whatever */
+ }
+}
+int mp_number_odd(mp_number A) {
+ return odd(mp_number_to_int(A));
+}
+int mp_number_equal(mp_number A, mp_number B) {
+ decNumber res;
+ decNumberCompare(&res,A.data.num,B.data.num, &set);
+ return decNumberIsZero(&res);
+}
+int mp_number_greater(mp_number A, mp_number B) {
+ decNumber res;
+ decNumberCompare(&res,A.data.num,B.data.num, &set);
+ return decNumberIsPositive(&res);
+}
+int mp_number_less(mp_number A, mp_number B) {
+ decNumber res;
+ decNumberCompare(&res,A.data.num,B.data.num, &set);
+ return decNumberIsNegative(&res);
+}
+int mp_number_nonequalabs(mp_number A, mp_number B) {
+ decNumber res, a, b;
+ decNumberCopyAbs(&a, A.data.num);
+ decNumberCopyAbs(&b, B.data.num);
+ decNumberCompare(&res, &a, &b, &set);
+ return !decNumberIsZero(&res);
+}
+
+@ 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.
+
+@ One of \MP's most common operations is the calculation of
+$\lfloor{a+b\over2}\rfloor$,
+the midpoint of two given integers |a| and~|b|. The most decent way to do
+this is to write `|(a+b)/2|'; but on many machines it is more efficient
+to calculate `|(a+b)>>1|'.
+
+Therefore the midpoint operation will always be denoted by `|half(a+b)|'
+in this program. If \MP\ is being implemented with languages that permit
+binary shifting, the |half| macro should be changed to make this operation
+as efficient as possible. Since some systems have shift operators that can
+only be trusted to work on positive numbers, there is also a macro |halfp|
+that is used only when the quantity being halved is known to be positive
+or zero.
+
+@ Here is a procedure analogous to |print_int|. The current version
+is fairly stupid, and it is not round-trip safe, but this is good
+enough for a beta test.
+
+@c
+char * mp_decnumber_tostring (decNumber *n) {
+ decNumber corrected;
+ char *buffer = malloc(((decNumber *)n)->digits + 14);
+ assert (buffer);
+ decNumberCopy(&corrected,n);
+ decNumberTrim(&corrected);
+ decNumberToString(&corrected, buffer);
+ return buffer;
+}
+char * mp_decimal_number_tostring (MP mp, mp_number n) {
+ return mp_decnumber_tostring(n.data.num);
+}
+
+
+@ @c
+void mp_decimal_print_number (MP mp, mp_number n) {
+ char *str = mp_decimal_number_tostring(mp, n);
+ mp_print (mp, str);
+ free (str);
+}
+
+
+
+
+@ Addition is not always checked to make sure that it doesn't overflow,
+but in places where overflow isn't too unlikely the |slow_add| routine
+is used.
+
+@c
+void mp_decimal_slow_add (MP mp, mp_number *ret, mp_number A, mp_number B) {
+ decNumberAdd(ret->data.num,A.data.num,B.data.num, &set);
+}
+
+@ The |make_fraction| routine produces the |fraction| equivalent of
+|p/q|, given integers |p| and~|q|; it computes the integer
+$f=\lfloor2^{28}p/q+{1\over2}\rfloor$, when $p$ and $q$ are
+positive. If |p| and |q| are both of the same scaled type |t|,
+the ``type relation'' |make_fraction(t,t)=fraction| is valid;
+and it's also possible to use the subroutine ``backwards,'' using
+the relation |make_fraction(t,fraction)=t| between scaled types.
+
+If the result would have magnitude $2^{31}$ or more, |make_fraction|
+sets |arith_error:=true|. Most of \MP's internal computations have
+been designed to avoid this sort of error.
+
+If this subroutine were programmed in assembly language on a typical
+machine, we could simply compute |(@t$2^{28}$@>*p)div q|, since a
+double-precision product can often be input to a fixed-point division
+instruction. But when we are restricted to int-eger arithmetic it
+is necessary either to resort to multiple-precision maneuvering
+or to use a simple but slow iteration. The multiple-precision technique
+would be about three times faster than the code adopted here, but it
+would be comparatively long and tricky, involving about sixteen
+additional multiplications and divisions.
+
+This operation is part of \MP's ``inner loop''; indeed, it will
+consume nearly 10\pct! of the running time (exclusive of input and output)
+if the code below is left unchanged. A machine-dependent recoding
+will therefore make \MP\ run faster. The present implementation
+is highly portable, but slow; it avoids multiplication and division
+except in the initial stage. System wizards should be careful to
+replace it with a routine that is guaranteed to produce identical
+results in all cases.
+@^system dependencies@>
+
+As noted below, a few more routines should also be replaced by machine-dependent
+code, for efficiency. But when a procedure is not part of the ``inner loop,''
+such changes aren't advisable; simplicity and robustness are
+preferable to trickery, unless the cost is too high.
+@^inner loop@>
+
+@c
+void mp_decimal_make_fraction (MP mp, decNumber *ret, decNumber *p, decNumber *q) {
+ decNumberDivide(ret, p, q, &set);
+ mp_check_decNumber(mp, ret, &set);
+ decNumberMultiply(ret, ret, &fraction_multiplier_decNumber, &set);
+}
+void mp_decimal_number_make_fraction (MP mp, mp_number *ret, mp_number p, mp_number q) {
+ mp_decimal_make_fraction (mp, ret->data.num, p.data.num, q.data.num);
+}
+
+@ @<Declarations@>=
+void mp_decimal_make_fraction (MP mp, decNumber *ret, decNumber *p, decNumber *q);
+
+@ 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@>
+
+@c
+void mp_decimal_take_fraction (MP mp, decNumber *ret, decNumber *p, decNumber *q) {
+ decNumberMultiply(ret, p, q, &set);
+ decNumberDivide(ret, ret, &fraction_multiplier_decNumber, &set);
+}
+void mp_decimal_number_take_fraction (MP mp, mp_number *ret, mp_number p, mp_number q) {
+ mp_decimal_take_fraction (mp, ret->data.num, p.data.num, q.data.num);
+}
+
+@ @<Declarations@>=
+void mp_decimal_take_fraction (MP mp, decNumber *ret, decNumber *p, decNumber *q);
+
+@ When we want to multiply something by a |scaled| quantity, we use a scheme
+analogous to |take_fraction| but with a different scaling.
+Given positive operands, |take_scaled|
+computes the quantity $p=\lfloor qf/2^{16}+{1\over2}\rfloor$.
+
+Once again it is a good idea to use a machine-language replacement if
+possible; otherwise |take_scaled| will use more than 2\pct! of the running time
+when the Computer Modern fonts are being generated.
+@^inner loop@>
+
+@c
+void mp_decimal_number_take_scaled (MP mp, mp_number *ret, mp_number p_orig, mp_number q_orig) {
+ decNumberMultiply(ret->data.num, p_orig.data.num, q_orig.data.num, &set);
+}
+
+
+@ 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.)
+
+@c
+void mp_decimal_number_make_scaled (MP mp, mp_number *ret, mp_number p_orig, mp_number q_orig) {
+ decNumberDivide(ret->data.num, p_orig.data.num, q_orig.data.num, &set);
+ mp_check_decNumber(mp, ret->data.num, &set);
+}
+
+@
+@d halfp(A) (integer)((unsigned)(A) >> 1)
+
+@* Scanning numbers in the input.
+
+The definitions below are temporarily here
+
+@d set_cur_cmd(A) mp->cur_mod_->type=(A)
+@d set_cur_mod(A) decNumberCopy((decNumber *)(mp->cur_mod_->data.n.data.num),&A)
+
+@<Declarations...@>=
+static void mp_wrapup_numeric_token(MP mp, unsigned char *start, unsigned char *stop);
+
+@
+@d too_precise(a) (a == (DEC_Inexact+DEC_Rounded))
+@d too_large(a) (a & DEC_Overflow)
+@c
+void mp_wrapup_numeric_token(MP mp, unsigned char *start, unsigned char *stop) {
+ decNumber result;
+ size_t l = stop-start+1;
+ char *buf = mp_xmalloc(mp, l+1, 1);
+ buf[l] = '\0';
+ (void)strncpy(buf,(const char *)start, l);
+ set.status = 0;
+ decNumberFromString(&result,buf, &set);
+ free(buf);
+ if (set.status == 0) {
+ set_cur_mod(result);
+ } else if (mp->scanner_status != tex_flushing) {
+ if (too_large(set.status)) {
+ const char *hlp[] = {"I could not handle this number specification",
+ "because it is out of range.",
+ NULL };
+ decNumber_check (&result, &set);
+ set_cur_mod(result);
+ mp_error (mp, "Enormous number has been reduced", hlp, false);
+ } else if (too_precise(set.status)) {
+ set_cur_mod(result);
+ if (decNumberIsPositive((decNumber *)internal_value (mp_warning_check).data.num) &&
+ (mp->scanner_status != tex_flushing)) {
+ char msg[256];
+ const char *hlp[] = {"Continue and I'll round the value until it fits the current numberprecision",
+ "(Set warningcheck:=0 to suppress this message.)",
+ NULL };
+ mp_snprintf (msg, 256, "Number is too precise (numberprecision = %d)", set.digits);
+ mp_error (mp, msg, hlp, true);
+ }
+ } else { /* this also captures underflow */
+ const char *hlp[] = {"I could not handle this number specification",
+ "Error:",
+ "",
+ NULL };
+ hlp[2] = decContextStatusToString(&set);
+ mp_error (mp, "Erroneous number specification changed to zero", hlp, false);
+ decNumberZero(&result);
+ set_cur_mod(result);
+ }
+ }
+ set_cur_cmd((mp_variable_type)mp_numeric_token);
+}
+
+@ @c
+static void find_exponent (MP mp) {
+ if (mp->buffer[mp->cur_input.loc_field] == 'e' ||
+ mp->buffer[mp->cur_input.loc_field] == 'E') {
+ mp->cur_input.loc_field++;
+ if (!(mp->buffer[mp->cur_input.loc_field] == '+' ||
+ mp->buffer[mp->cur_input.loc_field] == '-' ||
+ mp->char_class[mp->buffer[mp->cur_input.loc_field]] == digit_class)) {
+ mp->cur_input.loc_field--;
+ return;
+ }
+ if (mp->buffer[mp->cur_input.loc_field] == '+' ||
+ mp->buffer[mp->cur_input.loc_field] == '-') {
+ mp->cur_input.loc_field++;
+ }
+ while (mp->char_class[mp->buffer[mp->cur_input.loc_field]] == digit_class) {
+ mp->cur_input.loc_field++;
+ }
+ }
+}
+void mp_decimal_scan_fractional_token (MP mp, int n) { /* n: scaled */
+ unsigned char *start = &mp->buffer[mp->cur_input.loc_field -1];
+ unsigned char *stop;
+ while (mp->char_class[mp->buffer[mp->cur_input.loc_field]] == digit_class) {
+ mp->cur_input.loc_field++;
+ }
+ find_exponent(mp);
+ stop = &mp->buffer[mp->cur_input.loc_field-1];
+ mp_wrapup_numeric_token (mp, start, stop);
+}
+
+
+@ We just have to collect bytes.
+
+@c
+void mp_decimal_scan_numeric_token (MP mp, int n) { /* n: scaled */
+ unsigned char *start = &mp->buffer[mp->cur_input.loc_field -1];
+ unsigned char *stop;
+ while (mp->char_class[mp->buffer[mp->cur_input.loc_field]] == digit_class) {
+ mp->cur_input.loc_field++;
+ }
+ if (mp->buffer[mp->cur_input.loc_field] == '.' &&
+ mp->buffer[mp->cur_input.loc_field+1] != '.') {
+ mp->cur_input.loc_field++;
+ while (mp->char_class[mp->buffer[mp->cur_input.loc_field]] == digit_class) {
+ mp->cur_input.loc_field++;
+ }
+ }
+ find_exponent(mp);
+ stop = &mp->buffer[mp->cur_input.loc_field-1];
+ mp_wrapup_numeric_token (mp, start, stop);
+}
+
+@ 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 (fraction_multiplier/2)
+@d fraction_one (1*fraction_multiplier)
+@d fraction_two (2*fraction_multiplier)
+@d fraction_three (3*fraction_multiplier)
+@d fraction_four (4*fraction_multiplier)
+
+@ 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.
+
+The angles $\theta$ and $\phi$ are given implicitly in terms of |fraction|
+arguments |st|, |ct|, |sf|, and |cf|, representing $\sin\theta$, $\cos\theta$,
+$\sin\phi$, and $\cos\phi$, respectively.
+
+@c
+void mp_decimal_velocity (MP mp, mp_number *ret, mp_number st, mp_number ct, mp_number sf,
+ mp_number cf, mp_number t) {
+ decNumber acc, num, denom; /* registers for intermediate calculations */
+ decNumber r1, r2;
+ decNumber arg1, arg2;
+ decNumber i16, fone, fhalf, ftwo, sqrtfive;
+ decNumberFromInt32(&i16, 16);
+ decNumberFromInt32(&fone, fraction_one);
+ decNumberFromInt32(&fhalf, fraction_half);
+ decNumberFromInt32(&ftwo, fraction_two);
+ decNumberFromInt32(&sqrtfive, 5); /*$\sqrt{5}$*/
+ decNumberSquareRoot(&sqrtfive, &sqrtfive, &set);
+
+
+ decNumberDivide(&arg1,sf.data.num, &i16, &set); /* arg1 = sf / 16*/
+ decNumberSubtract(&arg1,st.data.num,&arg1, &set); /* arg1 = st - arg1*/
+ decNumberDivide(&arg2,st.data.num, &i16, &set); /* arg2 = st / 16*/
+ decNumberSubtract(&arg2,sf.data.num,&arg2, &set); /* arg2 = sf - arg2*/
+ mp_decimal_take_fraction (mp, &acc, &arg1, &arg2); /* acc = (arg1 * arg2) / fmul*/
+
+ decNumberCopy(&arg1, &acc);
+ decNumberSubtract(&arg2, ct.data.num, cf.data.num, &set); /* arg2 = ct - cf*/
+ mp_decimal_take_fraction (mp, &acc, &arg1, &arg2); /* acc = (arg1 * arg2 ) / fmul*/
+
+ decNumberSquareRoot(&arg1, &two_decNumber, &set); /* arg1 = $\sqrt{2}$*/
+ decNumberMultiply(&arg1, &arg1, &fone, &set); /* arg1 = arg1 * fmul*/
+ mp_decimal_take_fraction (mp, &r1, &acc, &arg1); /* r1 = (acc * arg1) / fmul*/
+ decNumberAdd(&num, &ftwo, &r1, &set); /* num = ftwo + r1*/
+
+ decNumberSubtract(&arg1,&sqrtfive, &one, &set); /* arg1 = $\sqrt{5}$ - 1*/
+ decNumberMultiply(&arg1,&arg1,&fhalf, &set); /* arg1 = arg1 * fmul/2*/
+ decNumberMultiply(&arg1,&arg1,&three_decNumber, &set); /* arg1 = arg1 * 3*/
+
+ decNumberSubtract(&arg2,&three_decNumber, &sqrtfive, &set); /* arg2 = 3 - $\sqrt{5}$*/
+ decNumberMultiply(&arg2,&arg2,&fhalf, &set); /* arg2 = arg2 * fmul/2*/
+ decNumberMultiply(&arg2,&arg2,&three_decNumber, &set); /* arg2 = arg2 * 3*/
+ mp_decimal_take_fraction (mp, &r1, ct.data.num, &arg1) ; /* r1 = (ct * arg1) / fmul*/
+ mp_decimal_take_fraction (mp, &r2, cf.data.num, &arg2); /* r2 = (cf * arg2) / fmul*/
+
+ decNumberFromInt32(&denom, fraction_three); /* denom = 3fmul*/
+ decNumberAdd(&denom, &denom, &r1, &set); /* denom = denom + r1*/
+ decNumberAdd(&denom, &denom, &r2, &set); /* denom = denom + r1*/
+
+ decNumberCompare(&arg1, t.data.num, &one, &set);
+ if (!decNumberIsZero(&arg1)) { /* t != r1*/
+ decNumberDivide(&num, &num, t.data.num, &set); /* num = num / t*/
+ }
+ decNumberCopy(&r2, &num); /* r2 = num / 4*/
+ decNumberDivide(&r2, &r2, &four_decNumber, &set);
+ if (decNumberLess(&denom,&r2)) { /* num/4 >= denom => denom < num/4*/
+ decNumberFromInt32(ret->data.num,fraction_four);
+ } else {
+ mp_decimal_make_fraction (mp, ret->data.num, &num, &denom);
+ }
+#if DEBUG
+ fprintf(stdout, "\n%f = velocity(%f,%f,%f,%f,%f)", mp_number_to_double(*ret),
+mp_number_to_double(st),mp_number_to_double(ct),
+mp_number_to_double(sf),mp_number_to_double(cf),
+mp_number_to_double(t));
+#endif
+ mp_check_decNumber(mp, ret->data.num, &set);
+}
+
+
+@ 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.
+
+@c
+void mp_ab_vs_cd (MP mp, mp_number *ret, mp_number a_orig, mp_number b_orig, mp_number c_orig, mp_number d_orig) {
+ decNumber q, r, test; /* temporary registers */
+ decNumber a, b, c, d;
+ decNumber ab, cd;
+ (void)mp;
+ decNumberCopy(&a, (decNumber *)a_orig.data.num);
+ decNumberCopy(&b, (decNumber *)b_orig.data.num);
+ decNumberCopy(&c, (decNumber *)c_orig.data.num);
+ decNumberCopy(&d, (decNumber *)d_orig.data.num);
+
+ decNumberMultiply (&ab, (decNumber *)a_orig.data.num, (decNumber *)b_orig.data.num, &set);
+ decNumberMultiply (&cd, (decNumber *)c_orig.data.num, (decNumber *)d_orig.data.num, &set);
+ decNumberCompare(ret->data.num, &ab, &cd, &set);
+ mp_check_decNumber(mp, ret->data.num, &set);
+ if (1>0)
+ return;
+
+
+ @<Reduce to the case that |a,c>=0|, |b,d>0|@>;
+ while (1) {
+ decNumberDivide(&q,&a,&d, &set);
+ decNumberDivide(&r,&c,&b, &set);
+ decNumberCompare(&test,&q,&r, &set);
+ if (!decNumberIsZero(&test)) {
+ if (decNumberIsPositive(&test)) {
+ decNumberCopy(ret->data.num, &one);
+ } else {
+ decNumberCopy(ret->data.num, &minusone);
+ }
+ goto RETURN;
+ }
+ decNumberRemainder(&q,&a,&d, &set);
+ decNumberRemainder(&r,&c,&b, &set);
+ if (decNumberIsZero(&r)) {
+ if (decNumberIsZero(&q)) {
+ decNumberCopy(ret->data.num, &zero);
+ } else {
+ decNumberCopy(ret->data.num, &one);
+ }
+ goto RETURN;
+ }
+ if (decNumberIsZero(&q)) {
+ decNumberCopy(ret->data.num, &minusone);
+ goto RETURN;
+ }
+ decNumberCopy(&a,&b);
+ decNumberCopy(&b,&q);
+ decNumberCopy(&c,&d);
+ decNumberCopy(&d,&r);
+ } /* now |a>d>0| and |c>b>0| */
+RETURN:
+#if DEBUG
+ fprintf(stdout, "\n%f = ab_vs_cd(%f,%f,%f,%f)", mp_number_to_double(*ret),
+mp_number_to_double(a_orig),mp_number_to_double(b_orig),
+mp_number_to_double(c_orig),mp_number_to_double(d_orig));
+#endif
+ mp_check_decNumber(mp, ret->data.num, &set);
+ return;
+}
+
+
+@ @<Reduce to the case that |a...@>=
+if (decNumberIsNegative(&a)) {
+ decNumberCopyNegate(&a, &a);
+ decNumberCopyNegate(&b, &b);
+}
+if (decNumberIsNegative(&c)) {
+ decNumberCopyNegate(&c, &c);
+ decNumberCopyNegate(&d, &d);
+}
+if (!decNumberIsPositive(&d)) {
+ if (!decNumberIsNegative(&b)) {
+ if ((decNumberIsZero(&a) || decNumberIsZero(&b)) && (decNumberIsZero(&c) || decNumberIsZero(&d)))
+ decNumberCopy(ret->data.num, &zero);
+ else
+ decNumberCopy(ret->data.num, &one);
+ goto RETURN;
+ }
+ if (decNumberIsZero(&d)) {
+ if (decNumberIsZero(&a))
+ decNumberCopy(ret->data.num, &zero);
+ else
+ decNumberCopy(ret->data.num, &minusone);
+ goto RETURN;
+ }
+ decNumberCopy(&q, &a);
+ decNumberCopy(&a, &c);
+ decNumberCopy(&c, &q);
+ decNumberCopyNegate(&q, &b);
+ decNumberCopyNegate(&b, &d);
+ decNumberCopy(&d, &q);
+} else if (!decNumberIsPositive(&b)) {
+ if (decNumberIsNegative(&b) && decNumberIsPositive(&a)) {
+ decNumberCopy(ret->data.num, &minusone);
+ goto RETURN;
+ }
+ if (decNumberIsZero(&c))
+ decNumberCopy(ret->data.num, &zero);
+ else
+ decNumberCopy(ret->data.num, &minusone);
+ goto RETURN;
+}
+
+@ 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.
+
+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}$.
+
+@d no_crossing { decNumberCopy(ret->data.num, &fraction_one_plus_decNumber); goto RETURN; }
+@d one_crossing { decNumberCopy(ret->data.num, &fraction_one_decNumber); goto RETURN; }
+@d zero_crossing { decNumberCopy(ret->data.num, &zero); goto RETURN; }
+
+@c
+static void mp_decimal_crossing_point (MP mp, mp_number *ret, mp_number aa, mp_number bb, mp_number cc) {
+ decNumber a,b,c;
+ double d; /* recursive counter */
+ decNumber x, xx, x0, x1, x2; /* temporary registers for bisection */
+ decNumber scratch, scratch2;
+ decNumberCopy(&a, (decNumber *)aa.data.num);
+ decNumberCopy(&b, (decNumber *)bb.data.num);
+ decNumberCopy(&c, (decNumber *)cc.data.num);
+ if (decNumberIsNegative(&a))
+ zero_crossing;
+ if (!decNumberIsNegative(&c)) {
+ if (!decNumberIsNegative(&b)) {
+ if (decNumberIsPositive(&c)) {
+ no_crossing;
+ } else if (decNumberIsZero(&a) && decNumberIsZero(&b)) {
+ no_crossing;
+ } else {
+ one_crossing;
+ }
+ }
+ if (decNumberIsZero(&a))
+ zero_crossing;
+ } else if (decNumberIsZero(&a)) {
+ if (!decNumberIsPositive(&b))
+ zero_crossing;
+ }
+
+ /* Use bisection to find the crossing point... */
+ d = epsilonf;
+ decNumberCopy(&x0, &a);
+ decNumberSubtract(&x1,&a, &b, &set);
+ decNumberSubtract(&x2,&b, &c, &set);
+ /* not sure why the error correction has to be >= 1E-12 */
+ decNumberFromDouble(&scratch2, 1E-12);
+ do {
+ decNumberAdd(&x, &x1, &x2, &set);
+ decNumberDivide(&x, &x, &two_decNumber, &set);
+ decNumberAdd(&x, &x, &scratch2, &set);
+ decNumberSubtract(&scratch, &x1, &x0, &set);
+ if (decNumberGreater(&scratch, &x0)) {
+ decNumberCopy(&x2, &x);
+ decNumberAdd(&x0, &x0, &x0, &set);
+ d += d;
+ } else {
+ decNumberAdd(&xx, &scratch, &x, &set);
+ if (decNumberGreater(&xx,&x0)) {
+ decNumberCopy(&x2,&x);
+ decNumberAdd(&x0, &x0, &x0, &set);
+ d += d;
+ } else {
+ decNumberSubtract(&x0, &x0, &xx, &set);
+ if (!decNumberGreater(&x,&x0)) {
+ decNumberAdd(&scratch, &x, &x2, &set);
+ if (!decNumberGreater(&scratch, &x0))
+ no_crossing;
+ }
+ decNumberCopy(&x1,&x);
+ d = d + d + epsilonf;
+ }
+ }
+ } while (d < fraction_one);
+ decNumberFromDouble(&scratch, d);
+ decNumberSubtract(ret->data.num,&scratch, &fraction_one_decNumber, &set);
+RETURN:
+#if DEBUG
+ fprintf(stdout, "\n%f = crossing_point(%f,%f,%f)", mp_number_to_double(*ret),
+mp_number_to_double(aa),mp_number_to_double(bb),mp_number_to_double(cc));
+#endif
+ mp_check_decNumber(mp, ret->data.num, &set);
+ return;
+}
+
+
+@ We conclude this set of elementary routines with some simple rounding
+and truncation operations.
+
+
+@ |round_unscaled| rounds a |scaled| and converts it to |int|
+@c
+int mp_round_unscaled(mp_number x_orig) {
+ double xx = mp_number_to_double(x_orig);
+ int x = (int)ROUND(xx);
+ return x;
+}
+
+@ |number_floor| floors a number
+
+@c
+void mp_number_floor (mp_number *i) {
+ int round = set.round;
+ set.round = DEC_ROUND_FLOOR;
+ decNumberToIntegralValue(i->data.num, i->data.num, &set);
+ set.round = round;
+}
+
+@ |fraction_to_scaled| rounds a |fraction| and converts it to |scaled|
+@c
+void mp_decimal_fraction_to_round_scaled (mp_number *x_orig) {
+ x_orig->type = mp_scaled_type;
+ decNumberDivide(x_orig->data.num, x_orig->data.num, &fraction_multiplier_decNumber, &set);
+}
+
+
+
+@* 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.
+
+@
+
+@c
+void mp_decimal_square_rt (MP mp, mp_number *ret, mp_number x_orig) { /* return, x: scaled */
+ decNumber x;
+ decNumberCopy(&x, x_orig.data.num);
+ if (!decNumberIsPositive(&x)) {
+ @<Handle square root of zero or negative argument@>;
+ } else {
+ decNumberSquareRoot(ret->data.num, &x, &set);
+ }
+ mp_check_decNumber(mp, ret->data.num, &set);
+}
+
+
+@ @<Handle square root of zero...@>=
+{
+ if (decNumberIsNegative(&x)) {
+ char msg[256];
+ const char *hlp[] = {
+ "Since I don't take square roots of negative numbers,",
+ "I'm zeroing this one. Proceed, with fingers crossed.",
+ NULL };
+ char *xstr = mp_decimal_number_tostring (mp, x_orig);
+ mp_snprintf(msg, 256, "Square root of %s has been replaced by 0", xstr);
+ free(xstr);
+@.Square root...replaced by 0@>;
+ mp_error (mp, msg, hlp, true);
+ }
+ decNumberZero(ret->data.num);
+ return;
+}
+
+
+@ Pythagorean addition $\psqrt{a^2+b^2}$ is implemented by a quick hack
+
+@c
+void mp_decimal_pyth_add (MP mp, mp_number *ret, mp_number a_orig, mp_number b_orig) {
+ decNumber a, b;
+ decNumber asq, bsq;
+ decNumberCopyAbs(&a, a_orig.data.num);
+ decNumberCopyAbs(&b, b_orig.data.num);
+ decNumberMultiply(&asq, &a, &a, &set);
+ decNumberMultiply(&bsq, &b, &b, &set);
+ decNumberAdd(&a, &asq, &bsq, &set);
+ decNumberSquareRoot(ret->data.num, &a, &set);
+ /*|if (set.status != 0) {|*/
+ /*| mp->arith_error = true;|*/
+ /*| decNumberCopy(ret->data.num, &EL_GORDO_decNumber);|*/
+ /*|}|*/
+ mp_check_decNumber(mp, ret->data.num, &set);
+}
+
+@ Here is a similar algorithm for $\psqrt{a^2-b^2}$. Same quick hack, also.
+
+@c
+void mp_decimal_pyth_sub (MP mp, mp_number *ret, mp_number a_orig, mp_number b_orig) {
+ decNumber a, b;
+ decNumberCopyAbs(&a, a_orig.data.num);
+ decNumberCopyAbs(&b, b_orig.data.num);
+ if (!decNumberGreater(&a,&b)) {
+ @<Handle erroneous |pyth_sub| and set |a:=0|@>;
+ } else {
+ decNumber asq, bsq;
+ decNumberMultiply(&asq, &a, &a, &set);
+ decNumberMultiply(&bsq, &b, &b, &set);
+ decNumberSubtract(&a, &asq, &bsq, &set);
+ decNumberSquareRoot(&a, &a, &set);
+ }
+ decNumberCopy(ret->data.num, &a);
+ mp_check_decNumber(mp, ret->data.num, &set);
+}
+
+
+@ @<Handle erroneous |pyth_sub| and set |a:=0|@>=
+{
+ if (decNumberLess(&a, &b)) {
+ char msg[256];
+ const char *hlp[] = {
+ "Since I don't take square roots of negative numbers,",
+ "I'm zeroing this one. Proceed, with fingers crossed.",
+ NULL };
+ char *astr = mp_decimal_number_tostring (mp, a_orig);
+ char *bstr = mp_decimal_number_tostring (mp, b_orig);
+ mp_snprintf (msg, 256, "Pythagorean subtraction %s+-+%s has been replaced by 0", astr, bstr);
+ free(astr);
+ free(bstr);
+@.Pythagorean...@>;
+ mp_error (mp, msg, hlp, true);
+ }
+ decNumberZero(&a);
+}
+
+
+@ Here is the routine that calculates $2^8$ times the natural logarithm
+of a |scaled| quantity;
+
+@c
+void mp_decimal_m_log (MP mp, mp_number *ret, mp_number x_orig) {
+ if (!decNumberIsPositive((decNumber *)x_orig.data.num)) {
+ @<Handle non-positive logarithm@>;
+ } else {
+ decNumber twofivesix;
+ decNumberFromInt32(&twofivesix, 256);
+ decNumberLn(ret->data.num, x_orig.data.num, &limitedset);
+ mp_check_decNumber(mp, ret->data.num, &limitedset);
+ decNumberMultiply(ret->data.num, ret->data.num, &twofivesix, &set);
+ }
+ mp_check_decNumber(mp, ret->data.num, &set);
+}
+
+@ @<Handle non-positive logarithm@>=
+{
+ char msg[256];
+ const char *hlp[] = {
+ "Since I don't take logs of non-positive numbers,",
+ "I'm zeroing this one. Proceed, with fingers crossed.",
+ NULL };
+ char *xstr = mp_decimal_number_tostring (mp, x_orig);
+ mp_snprintf (msg, 256, "Logarithm of %s has been replaced by 0", xstr);
+ free (xstr);
+@.Logarithm...replaced by 0@>;
+ mp_error (mp, msg, hlp, true);
+ decNumberZero(ret->data.num);
+}
+
+
+@ Conversely, the exponential routine calculates $\exp(x/2^8)$,
+when |x| is |scaled|.
+
+@c
+void mp_decimal_m_exp (MP mp, mp_number *ret, mp_number x_orig) {
+ decNumber temp, twofivesix;
+ decNumberFromInt32(&twofivesix, 256);
+ decNumberDivide(&temp, x_orig.data.num, &twofivesix, &set);
+ limitedset.status = 0;
+ decNumberExp(ret->data.num, &temp, &limitedset);
+ if (limitedset.status & DEC_Clamped) {
+ if (decNumberIsPositive((decNumber *)x_orig.data.num)) {
+ mp->arith_error = true;
+ decNumberCopy(ret->data.num, &EL_GORDO_decNumber);
+ } else {
+ decNumberZero(ret->data.num);
+ }
+ }
+ mp_check_decNumber(mp, ret->data.num, &limitedset);
+ limitedset.status = 0;
+}
+
+
+@ Given integers |x| and |y|, not both zero, the |n_arg| function
+returns the |angle| whose tangent points in the direction $(x,y)$.
+
+@c
+void mp_decimal_n_arg (MP mp, mp_number *ret, mp_number x_orig, mp_number y_orig) {
+ if (decNumberIsZero((decNumber *)x_orig.data.num) && decNumberIsZero((decNumber *)y_orig.data.num)) {
+ @<Handle undefined arg@>;
+ } else {
+ decNumber atan2val, oneeighty_angle;
+ ret->type = mp_angle_type;
+ decNumberFromInt32(&oneeighty_angle, 180 * angle_multiplier);
+ decNumberDivide(&oneeighty_angle, &oneeighty_angle, &PI_decNumber, &set);
+ checkZero(y_orig.data.num);
+ checkZero(x_orig.data.num);
+ decNumberAtan2(&atan2val, y_orig.data.num, x_orig.data.num, &set);
+#if DEBUG
+ fprintf(stdout, "\n%g = atan2(%g,%g)", decNumberToDouble(&atan2val),mp_number_to_double(x_orig),mp_number_to_double(y_orig));
+#endif
+ decNumberMultiply(ret->data.num,&atan2val, &oneeighty_angle, &set);
+ checkZero(ret->data.num);
+#if DEBUG
+ fprintf(stdout, "\nn_arg(%g,%g,%g)", mp_number_to_double(*ret),
+ mp_number_to_double(x_orig),mp_number_to_double(y_orig));
+#endif
+ }
+ mp_check_decNumber(mp, ret->data.num, &set);
+}
+
+
+@ @<Handle undefined arg@>=
+{
+ const char *hlp[] = {
+ "The `angle' between two identical points is undefined.",
+ "I'm zeroing this one. Proceed, with fingers crossed.",
+ NULL };
+ mp_error (mp, "angle(0,0) is taken as zero", hlp, true);
+@.angle(0,0)...zero@>;
+ decNumberZero(ret->data.num);
+}
+
+
+@ 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|.
+
+First, we need a decNumber function that calculates sines and cosines
+using the Taylor series. This function is fairly optimized.
+
+@d PRECALC_FACTORIALS_CACHESIZE 50
+
+@c
+static void sinecosine(decNumber *theangle, decNumber *c, decNumber *s)
+{
+ int n, i, prec;
+ decNumber p, pxa, fac, cc;
+ decNumber n1, n2, p1;
+ decNumberZero(c);
+ decNumberZero(s);
+ prec = (set.digits/2);
+ if (prec < DECPRECISION_DEFAULT) prec = DECPRECISION_DEFAULT;
+ for (n=0;n<prec;n++)
+ {
+ decNumberFromInt32(&p1, n);
+ decNumberFromInt32(&n1, 2*n);
+ decNumberPower(&p, &minusone, &p1, &limitedset);
+ if (n==0) {
+ decNumberCopy(&pxa, &one);
+ } else {
+ decNumberPower(&pxa, theangle, &n1, &limitedset);
+ }
+
+ if (2*n<last_cached_factorial) {
+ decNumberCopy(&fac,factorials[2*n]);
+ } else {
+ decNumberCopy(&fac,factorials[last_cached_factorial]);
+ for (i = last_cached_factorial+1; i <= 2*n; i++) {
+ decNumberFromInt32(&cc, i);
+ decNumberMultiply (&fac, &fac, &cc, &set);
+ if (i<PRECALC_FACTORIALS_CACHESIZE) {
+ factorials[i] = malloc(sizeof(decNumber));
+ decNumberCopy(factorials[i],&fac);
+ last_cached_factorial = i;
+ }
+ }
+ }
+
+ decNumberDivide (&pxa, &pxa, &fac, &set);
+ decNumberMultiply (&pxa, &pxa, &p, &set);
+ decNumberAdd (s, s, &pxa, &set);
+
+ decNumberFromInt32(&n2, 2*n+1);
+ decNumberMultiply (&fac, &fac, &n2, &set); /* fac = fac * (2*n+1)*/
+ decNumberPower(&pxa, theangle, &n2, &limitedset);
+ decNumberDivide (&pxa, &pxa, &fac, &set);
+ decNumberMultiply (&pxa, &pxa, &p, &set);
+ decNumberAdd (c, c, &pxa, &set);
+ /* |printf("\niteration %2d: %-42s %-42s",n,tostring(c), tostring(s));|*/
+ }
+}
+
+@ Calculate sines and cosines.
+@c
+void mp_decimal_sin_cos (MP mp, mp_number z_orig, mp_number *n_cos, mp_number *n_sin) {
+ decNumber rad;
+ double tmp;
+ decNumber one_eighty;
+ tmp = mp_number_to_double(z_orig)/16.0;
+
+#if DEBUG
+ fprintf(stdout, "\nsin_cos(%f)", mp_number_to_double(z_orig));
+#endif
+#if 0
+ if (decNumberIsNegative(&rad)) {
+ while (decNumberLess(&rad,&PI_decNumber))
+ decNumberAdd(&rad, &rad, &PI_decNumber, &set);
+ } else {
+ while (decNumberGreater(&rad,&PI_decNumber))
+ decNumberSubtract(&rad, &rad, &PI_decNumber, &set);
+ }
+#endif
+ if ((tmp == 90.0)||(tmp == -270)){
+ decNumberZero(n_cos->data.num);
+ decNumberCopy(n_sin->data.num,&fraction_multiplier_decNumber);
+ } else if ((tmp == -90.0)||(tmp == 270.0)) {
+ decNumberZero(n_cos->data.num);
+ decNumberCopyNegate(n_sin->data.num,&fraction_multiplier_decNumber);
+ } else if ((tmp == 180.0) || (tmp == -180.0)) {
+ decNumberCopyNegate(n_cos->data.num,&fraction_multiplier_decNumber);
+ decNumberZero(n_sin->data.num);
+ } else {
+ decNumberFromInt32(&one_eighty, 180 * 16);
+ decNumberMultiply(&rad, z_orig.data.num, &PI_decNumber, &set);
+ decNumberDivide(&rad, &rad, &one_eighty, &set);
+ sinecosine(&rad, n_sin->data.num, n_cos->data.num);
+ decNumberMultiply(n_cos->data.num,n_cos->data.num,&fraction_multiplier_decNumber, &set);
+ decNumberMultiply(n_sin->data.num,n_sin->data.num,&fraction_multiplier_decNumber, &set);
+ }
+#if DEBUG
+ fprintf(stdout, "\nsin_cos(%f,%f,%f)", decNumberToDouble(&rad),
+mp_number_to_double(*n_cos), mp_number_to_double(*n_sin));
+#endif
+ mp_check_decNumber(mp, n_cos->data.num, &set);
+ mp_check_decNumber(mp, n_sin->data.num, &set);
+}
+
+@ This is the {\tt http://www-cs-faculty.stanford.edu/~uno/programs/rng.c}
+with small cosmetic modifications.
+
+@c
+#define KK 100 /* the long lag */
+#define LL 37 /* the short lag */
+#define MM (1L<<30) /* the modulus */
+#define mod_diff(x,y) (((x)-(y))&(MM-1)) /* subtraction mod MM */
+/* */
+static long ran_x[KK]; /* the generator state */
+/* */
+static void ran_array(long aa[],int n) /* put n new random numbers in aa */
+ /* long aa[] destination */
+ /* int n array length (must be at least KK) */
+{
+ register int i,j;
+ for (j=0;j<KK;j++) aa[j]=ran_x[j];
+ for (;j<n;j++) aa[j]=mod_diff(aa[j-KK],aa[j-LL]);
+ for (i=0;i<LL;i++,j++) ran_x[i]=mod_diff(aa[j-KK],aa[j-LL]);
+ for (;i<KK;i++,j++) ran_x[i]=mod_diff(aa[j-KK],ran_x[i-LL]);
+}
+/* */
+/* the following routines are from exercise 3.6--15 */
+/* after calling |ran_start|, get new randoms by, e.g., "|x=ran_arr_next()|" */
+/* */
+#define QUALITY 1009 /* recommended quality level for high-res use */
+static long ran_arr_buf[QUALITY];
+static long ran_arr_dummy=-1, ran_arr_started=-1;
+static long *ran_arr_ptr=&ran_arr_dummy; /* the next random number, or -1 */
+/* */
+#define TT 70 /* guaranteed separation between streams */
+#define is_odd(x) ((x)&1) /* units bit of x */
+/* */
+static void ran_start(long seed) /* do this before using |ran_array| */
+ /* |long seed| selector for different streams */
+{
+ register int t,j;
+ long x[KK+KK-1]; /* the preparation buffer */
+ register long ss=(seed+2)&(MM-2);
+ for (j=0;j<KK;j++) {
+ x[j]=ss; /* bootstrap the buffer */
+ ss<<=1; if (ss>=MM) ss-=MM-2; /* cyclic shift 29 bits */
+ }
+ x[1]++; /* make x[1] (and only x[1]) odd */
+ for (ss=seed&(MM-1),t=TT-1; t; ) {
+ for (j=KK-1;j>0;j--) x[j+j]=x[j], x[j+j-1]=0; /* "square" */
+ for (j=KK+KK-2;j>=KK;j--)
+ x[j-(KK-LL)]=mod_diff(x[j-(KK-LL)],x[j]),
+ x[j-KK]=mod_diff(x[j-KK],x[j]);
+ if (is_odd(ss)) { /* "multiply by z" */
+ for (j=KK;j>0;j--) x[j]=x[j-1];
+ x[0]=x[KK]; /* shift the buffer cyclically */
+ x[LL]=mod_diff(x[LL],x[KK]);
+ }
+ if (ss) ss>>=1; else t--;
+ }
+ for (j=0;j<LL;j++) ran_x[j+KK-LL]=x[j];
+ for (;j<KK;j++) ran_x[j-LL]=x[j];
+ for (j=0;j<10;j++) ran_array(x,KK+KK-1); /* warm things up */
+ ran_arr_ptr=&ran_arr_started;
+}
+/* */
+#define ran_arr_next() (*ran_arr_ptr>=0? *ran_arr_ptr++: ran_arr_cycle())
+static long ran_arr_cycle(void)
+{
+ if (ran_arr_ptr==&ran_arr_dummy)
+ ran_start(314159L); /* the user forgot to initialize */
+ ran_array(ran_arr_buf,QUALITY);
+ ran_arr_buf[KK]=-1;
+ ran_arr_ptr=ran_arr_buf+1;
+ return ran_arr_buf[0];
+}
+
+
+
+@ To initialize the |randoms| table, we call the following routine.
+
+@c
+void mp_init_randoms (MP mp, int seed) {
+ int j, jj, k; /* more or less random integers */
+ int i; /* index into |randoms| */
+ j = abs (seed);
+ while (j >= fraction_one) {
+ j = j/2;
+ }
+ k = 1;
+ for (i = 0; i <= 54; i++) {
+ jj = k;
+ k = j - k;
+ j = jj;
+ if (k<0)
+ k += fraction_one;
+ decNumberFromInt32(mp->randoms[(i * 21) % 55].data.num, j);
+ }
+ mp_new_randoms (mp);
+ mp_new_randoms (mp);
+ mp_new_randoms (mp); /* ``warm up'' the array */
+
+ ran_start((unsigned long) seed);
+
+}
+
+@ @c
+void mp_decimal_number_modulo (mp_number *a, mp_number b) {
+ decNumberRemainder(a->data.num, a->data.num, b.data.num, &set);
+}
+
+
+@ To consume a random integer for the uniform generator, the program below will say `|next_unif_random|'.
+
+@c
+static void mp_next_unif_random (MP mp, mp_number *ret) {
+ decNumber a;
+ decNumber b;
+ unsigned long int op;
+ (void)mp;
+ op = (unsigned)ran_arr_next();
+ decNumberFromInt32(&a, op);
+ decNumberFromInt32(&b, MM);
+ decNumberDivide (&a, &a, &b, &set); /* a = a/b */
+ decNumberCopy(ret->data.num, &a);
+ mp_check_decNumber(mp, ret->data.num, &set);
+}
+
+
+@ To consume a random fraction, the program below will say `|next_random|'.
+
+@c
+static void mp_next_random (MP mp, mp_number *ret) {
+ if ( mp->j_random==0 )
+ mp_new_randoms(mp);
+ else
+ mp->j_random = mp->j_random-1;
+ mp_number_clone (ret, mp->randoms[mp->j_random]);
+}
+
+
+@ To produce a uniform random number in the range |0<=u<x| or |0>=u>x|
+or |0=u=x|, given a |scaled| value~|x|, we proceed as shown here.
+
+Note that the call of |take_fraction| will produce the values 0 and~|x|
+with about half the probability that it will produce any other particular
+values between 0 and~|x|, because it rounds its answers.
+
+@c
+static void mp_decimal_m_unif_rand (MP mp, mp_number *ret, mp_number x_orig) {
+ mp_number y; /* trial value */
+ mp_number x, abs_x;
+ mp_number u;
+ new_fraction (y);
+ new_number (x);
+ new_number (abs_x);
+ new_number (u);
+ mp_number_clone (&x, x_orig);
+ mp_number_clone (&abs_x, x);
+ mp_decimal_abs (&abs_x);
+ mp_next_unif_random(mp, &u);
+ decNumberMultiply (y.data.num, abs_x.data.num, u.data.num, &set);
+ free_number (u);
+ if (mp_number_equal(y, abs_x)) {
+ mp_number_clone (ret, ((math_data *)mp->math)->zero_t);
+ } else if (mp_number_greater(x, ((math_data *)mp->math)->zero_t)) {
+ mp_number_clone (ret, y);
+ } else {
+ mp_number_clone (ret, y);
+ mp_number_negate (ret);
+ }
+ free_number (abs_x);
+ free_number (x);
+ free_number (y);
+}
+
+
+
+@ Finally, a normal deviate with mean zero and unit standard deviation
+can readily be obtained with the ratio method (Algorithm 3.4.1R in
+{\sl The Art of Computer Programming\/}).
+
+@c
+static void mp_decimal_m_norm_rand (MP mp, mp_number *ret) {
+ mp_number ab_vs_cd;
+ mp_number abs_x;
+ mp_number u;
+ mp_number r;
+ mp_number la, xa;
+ new_number (ab_vs_cd);
+ new_number (la);
+ new_number (xa);
+ new_number (abs_x);
+ new_number (u);
+ new_number (r);
+
+ do {
+ do {
+ mp_number v;
+ new_number (v);
+ mp_next_random(mp, &v);
+ mp_number_substract (&v, ((math_data *)mp->math)->fraction_half_t);
+ mp_decimal_number_take_fraction (mp,&xa, ((math_data *)mp->math)->sqrt_8_e_k, v);
+ free_number (v);
+ mp_next_random(mp, &u);
+ mp_number_clone (&abs_x, xa);
+ mp_decimal_abs (&abs_x);
+ } while (!mp_number_less(abs_x, u));
+ mp_decimal_number_make_fraction (mp, &r, xa, u);
+ mp_number_clone (&xa, r);
+ mp_decimal_m_log (mp,&la, u);
+ mp_set_decimal_from_substraction(&la, ((math_data *)mp->math)->twelve_ln_2_k, la);
+ mp_ab_vs_cd (mp,&ab_vs_cd, ((math_data *)mp->math)->one_k, la, xa, xa);
+ } while (mp_number_less(ab_vs_cd,((math_data *)mp->math)->zero_t));
+ mp_number_clone (ret, xa);
+ free_number (ab_vs_cd);
+ free_number (r);
+ free_number (abs_x);
+ free_number (la);
+ free_number (xa);
+ free_number (u);
+}
+
+
+
+
+@ The following subroutine could be used in |norm_rand| and tests if $ab$ is
+greater than, equal to, or less than~$cd$.
+The result is $+1$, 0, or~$-1$ in the three respective cases.
+This is not necessary, even if it's shorter than the current |ab_vs_cd|
+and looks as a native implementation.
+
+@c
+/*
+|void mp_decimal_ab_vs_cd (MP mp, mp_number *ret, mp_number a_orig, mp_number b_orig, mp_number c_orig, mp_number d_orig) {|
+| decNumber a, b, c, d;|
+| decNumber ab, cd;|
+| (void)mp;|
+||
+| decNumberCopy(&a, (decNumber *)a_orig.data.num);|
+| decNumberCopy(&b, (decNumber *)b_orig.data.num);|
+| decNumberCopy(&c, (decNumber *)c_orig.data.num);|
+| decNumberCopy(&d, (decNumber *)d_orig.data.num);|
+||
+||
+| decNumberMultiply (&ab, (decNumber *)a_orig.data.num, (decNumber *)b_orig.data.num, &set);|
+| decNumberMultiply (&cd, (decNumber *)c_orig.data.num, (decNumber *)d_orig.data.num, &set);|
+| decNumberCompare(ret->data.num, &ab, &cd, &set);|
+| mp_check_decNumber(mp, ret->data.num, &set);|
+| return;|
+||
+|}|
+*/
+
+
+
diff --git a/Build/source/texk/web2c/mplibdir/mpmathdouble.w b/Build/source/texk/web2c/mplibdir/mpmathdouble.w
new file mode 100644
index 00000000000..cb14969365f
--- /dev/null
+++ b/Build/source/texk/web2c/mplibdir/mpmathdouble.w
@@ -0,0 +1,1487 @@
+% $Id: mpmathdouble.w 2118 2017-02-15 17:49:54Z luigi $
+%
+% This file is part of MetaPost;
+% the MetaPost program is in the public domain.
+% See the <Show version...> code in mpost.w for more info.
+
+% Here is TeX material that gets inserted after \input webmac
+
+\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\pct!{{\char`\%}} % percent sign in ordinary text
+\def\psqrt#1{\sqrt{\mathstrut#1}}
+
+
+\def\title{Math support functions for IEEE double based math}
+\pdfoutput=1
+
+@ Introduction.
+
+@c
+#include <w2c/config.h>
+#include <stdio.h>
+#include <stdlib.h>
+#include <string.h>
+#include <math.h>
+#include "mpmathdouble.h" /* internal header */
+#define ROUND(a) floor((a)+0.5)
+@h
+
+@ @c
+@<Declarations@>;
+
+@ @(mpmathdouble.h@>=
+#ifndef MPMATHDOUBLE_H
+#define MPMATHDOUBLE_H 1
+#include "mplib.h"
+#include "mpmp.h" /* internal header */
+@<Internal library declarations@>;
+#endif
+
+@* Math initialization.
+
+First, here are some very important constants.
+
+@d PI 3.1415926535897932384626433832795028841971
+@d fraction_multiplier 4096.0
+@d angle_multiplier 16.0
+
+@ Here are the functions that are static as they are not used elsewhere
+
+@<Declarations@>=
+static void mp_double_scan_fractional_token (MP mp, int n);
+static void mp_double_scan_numeric_token (MP mp, int n);
+static void mp_ab_vs_cd (MP mp, mp_number *ret, mp_number a, mp_number b, mp_number c, mp_number d);
+static void mp_double_ab_vs_cd (MP mp, mp_number *ret, mp_number a, mp_number b, mp_number c, mp_number d);
+static void mp_double_crossing_point (MP mp, mp_number *ret, mp_number a, mp_number b, mp_number c);
+static void mp_number_modulo (mp_number *a, mp_number b);
+static void mp_double_print_number (MP mp, mp_number n);
+static char * mp_double_number_tostring (MP mp, mp_number n);
+static void mp_double_slow_add (MP mp, mp_number *ret, mp_number x_orig, mp_number y_orig);
+static void mp_double_square_rt (MP mp, mp_number *ret, mp_number x_orig);
+static void mp_double_sin_cos (MP mp, mp_number z_orig, mp_number *n_cos, mp_number *n_sin);
+static void mp_init_randoms (MP mp, int seed);
+static void mp_number_angle_to_scaled (mp_number *A);
+static void mp_number_fraction_to_scaled (mp_number *A);
+static void mp_number_scaled_to_fraction (mp_number *A);
+static void mp_number_scaled_to_angle (mp_number *A);
+static void mp_double_m_unif_rand (MP mp, mp_number *ret, mp_number x_orig);
+static void mp_double_m_norm_rand (MP mp, mp_number *ret);
+static void mp_double_m_exp (MP mp, mp_number *ret, mp_number x_orig);
+static void mp_double_m_log (MP mp, mp_number *ret, mp_number x_orig);
+static void mp_double_pyth_sub (MP mp, mp_number *r, mp_number a, mp_number b);
+static void mp_double_pyth_add (MP mp, mp_number *r, mp_number a, mp_number b);
+static void mp_double_n_arg (MP mp, mp_number *ret, mp_number x, mp_number y);
+static void mp_double_velocity (MP mp, mp_number *ret, mp_number st, mp_number ct, mp_number sf, mp_number cf, mp_number t);
+static void mp_set_double_from_int(mp_number *A, int B);
+static void mp_set_double_from_boolean(mp_number *A, int B);
+static void mp_set_double_from_scaled(mp_number *A, int B);
+static void mp_set_double_from_addition(mp_number *A, mp_number B, mp_number C);
+static void mp_set_double_from_substraction (mp_number *A, mp_number B, mp_number C);
+static void mp_set_double_from_div(mp_number *A, mp_number B, mp_number C);
+static void mp_set_double_from_mul(mp_number *A, mp_number B, mp_number C);
+static void mp_set_double_from_int_div(mp_number *A, mp_number B, int C);
+static void mp_set_double_from_int_mul(mp_number *A, mp_number B, int C);
+static void mp_set_double_from_of_the_way(MP mp, mp_number *A, mp_number t, mp_number B, mp_number C);
+static void mp_number_negate(mp_number *A);
+static void mp_number_add(mp_number *A, mp_number B);
+static void mp_number_substract(mp_number *A, mp_number B);
+static void mp_number_half(mp_number *A);
+static void mp_number_halfp(mp_number *A);
+static void mp_number_double(mp_number *A);
+static void mp_number_add_scaled(mp_number *A, int B); /* also for negative B */
+static void mp_number_multiply_int(mp_number *A, int B);
+static void mp_number_divide_int(mp_number *A, int B);
+static void mp_double_abs(mp_number *A);
+static void mp_number_clone(mp_number *A, mp_number B);
+static void mp_number_swap(mp_number *A, mp_number *B);
+static int mp_round_unscaled(mp_number x_orig);
+static int mp_number_to_int(mp_number A);
+static int mp_number_to_scaled(mp_number A);
+static int mp_number_to_boolean(mp_number A);
+static double mp_number_to_double(mp_number A);
+static int mp_number_odd(mp_number A);
+static int mp_number_equal(mp_number A, mp_number B);
+static int mp_number_greater(mp_number A, mp_number B);
+static int mp_number_less(mp_number A, mp_number B);
+static int mp_number_nonequalabs(mp_number A, mp_number B);
+static void mp_number_floor (mp_number *i);
+static void mp_double_fraction_to_round_scaled (mp_number *x);
+static void mp_double_number_make_scaled (MP mp, mp_number *r, mp_number p, mp_number q);
+static void mp_double_number_make_fraction (MP mp, mp_number *r, mp_number p, mp_number q);
+static void mp_double_number_take_fraction (MP mp, mp_number *r, mp_number p, mp_number q);
+static void mp_double_number_take_scaled (MP mp, mp_number *r, mp_number p, mp_number q);
+static void mp_new_number (MP mp, mp_number *n, mp_number_type t) ;
+static void mp_free_number (MP mp, mp_number *n) ;
+static void mp_set_double_from_double(mp_number *A, double B);
+static void mp_free_double_math (MP mp);
+static void mp_double_set_precision (MP mp);
+
+@ And these are the ones that {\it are} used elsewhere
+
+@<Internal library declarations@>=
+void * mp_initialize_double_math (MP mp);
+
+@
+
+@d coef_bound ((7.0/3.0)*fraction_multiplier) /* |fraction| approximation to 7/3 */
+@d fraction_threshold 0.04096 /* a |fraction| coefficient less than this is zeroed */
+@d half_fraction_threshold (fraction_threshold/2) /* half of |fraction_threshold| */
+@d scaled_threshold 0.000122 /* a |scaled| coefficient less than this is zeroed */
+@d half_scaled_threshold (scaled_threshold/2) /* half of |scaled_threshold| */
+@d near_zero_angle (0.0256*angle_multiplier) /* an angle of about 0.0256 */
+@d p_over_v_threshold 0x80000 /* TODO */
+@d equation_threshold 0.001
+@d tfm_warn_threshold 0.0625
+@d warning_limit pow(2.0,52.0) /* this is a large value that can just be expressed without loss of precision */
+@d epsilon pow(2.0,-52.0)
+
+@c
+void * mp_initialize_double_math (MP mp) {
+ math_data *math = (math_data *)mp_xmalloc(mp,1,sizeof(math_data));
+ /* alloc */
+ math->allocate = mp_new_number;
+ math->free = mp_free_number;
+ mp_new_number (mp, &math->precision_default, mp_scaled_type);
+ math->precision_default.data.dval = 16 * unity;
+ mp_new_number (mp, &math->precision_max, mp_scaled_type);
+ math->precision_max.data.dval = 16 * unity;
+ mp_new_number (mp, &math->precision_min, mp_scaled_type);
+ math->precision_min.data.dval = 16 * unity;
+ /* here are the constants for |scaled| objects */
+ mp_new_number (mp, &math->epsilon_t, mp_scaled_type);
+ math->epsilon_t.data.dval = epsilon;
+ mp_new_number (mp, &math->inf_t, mp_scaled_type);
+ math->inf_t.data.dval = EL_GORDO;
+ mp_new_number (mp, &math->warning_limit_t, mp_scaled_type);
+ math->warning_limit_t.data.dval = warning_limit;
+ mp_new_number (mp, &math->one_third_inf_t, mp_scaled_type);
+ math->one_third_inf_t.data.dval = one_third_EL_GORDO;
+ mp_new_number (mp, &math->unity_t, mp_scaled_type);
+ math->unity_t.data.dval = unity;
+ mp_new_number (mp, &math->two_t, mp_scaled_type);
+ math->two_t.data.dval = two;
+ mp_new_number (mp, &math->three_t, mp_scaled_type);
+ math->three_t.data.dval = three;
+ mp_new_number (mp, &math->half_unit_t, mp_scaled_type);
+ math->half_unit_t.data.dval = half_unit;
+ mp_new_number (mp, &math->three_quarter_unit_t, mp_scaled_type);
+ math->three_quarter_unit_t.data.dval = three_quarter_unit;
+ mp_new_number (mp, &math->zero_t, mp_scaled_type);
+ /* |fractions| */
+ mp_new_number (mp, &math->arc_tol_k, mp_fraction_type);
+ math->arc_tol_k.data.dval = (unity/4096); /* quit when change in arc length estimate reaches this */
+ mp_new_number (mp, &math->fraction_one_t, mp_fraction_type);
+ math->fraction_one_t.data.dval = fraction_one;
+ mp_new_number (mp, &math->fraction_half_t, mp_fraction_type);
+ math->fraction_half_t.data.dval = fraction_half;
+ mp_new_number (mp, &math->fraction_three_t, mp_fraction_type);
+ math->fraction_three_t.data.dval = fraction_three;
+ mp_new_number (mp, &math->fraction_four_t, mp_fraction_type);
+ math->fraction_four_t.data.dval = fraction_four;
+ /* |angles| */
+ mp_new_number (mp, &math->three_sixty_deg_t, mp_angle_type);
+ math->three_sixty_deg_t.data.dval = three_sixty_deg;
+ mp_new_number (mp, &math->one_eighty_deg_t, mp_angle_type);
+ math->one_eighty_deg_t.data.dval = one_eighty_deg;
+ /* various approximations */
+ mp_new_number (mp, &math->one_k, mp_scaled_type);
+ math->one_k.data.dval = 1.0/64 ;
+ mp_new_number (mp, &math->sqrt_8_e_k, mp_scaled_type);
+ math->sqrt_8_e_k.data.dval = 1.71552776992141359295 ; /* $2^{16}\sqrt{8/e}\approx 112428.82793$ */
+ mp_new_number (mp, &math->twelve_ln_2_k, mp_fraction_type);
+ math->twelve_ln_2_k.data.dval = 8.31776616671934371292 *256; /* $2^{24}\cdot12\ln2\approx139548959.6165$ */
+ mp_new_number (mp, &math->coef_bound_k, mp_fraction_type);
+ math->coef_bound_k.data.dval = coef_bound;
+ mp_new_number (mp, &math->coef_bound_minus_1, mp_fraction_type);
+ math->coef_bound_minus_1.data.dval = coef_bound - 1/65536.0;
+ mp_new_number (mp, &math->twelvebits_3, mp_scaled_type);
+ math->twelvebits_3.data.dval = 1365 / 65536.0; /* $1365\approx 2^{12}/3$ */
+ mp_new_number (mp, &math->twentysixbits_sqrt2_t, mp_fraction_type);
+ math->twentysixbits_sqrt2_t.data.dval = 94906266 / 65536.0; /* $2^{26}\sqrt2\approx94906265.62$ */
+ mp_new_number (mp, &math->twentyeightbits_d_t, mp_fraction_type);
+ math->twentyeightbits_d_t.data.dval = 35596755 / 65536.0; /* $2^{28}d\approx35596754.69$ */
+ mp_new_number (mp, &math->twentysevenbits_sqrt2_d_t, mp_fraction_type);
+ math->twentysevenbits_sqrt2_d_t.data.dval = 25170707 / 65536.0; /* $2^{27}\sqrt2\,d\approx25170706.63$ */
+ /* thresholds */
+ mp_new_number (mp, &math->fraction_threshold_t, mp_fraction_type);
+ math->fraction_threshold_t.data.dval = fraction_threshold;
+ mp_new_number (mp, &math->half_fraction_threshold_t, mp_fraction_type);
+ math->half_fraction_threshold_t.data.dval = half_fraction_threshold;
+ mp_new_number (mp, &math->scaled_threshold_t, mp_scaled_type);
+ math->scaled_threshold_t.data.dval = scaled_threshold;
+ mp_new_number (mp, &math->half_scaled_threshold_t, mp_scaled_type);
+ math->half_scaled_threshold_t.data.dval = half_scaled_threshold;
+ mp_new_number (mp, &math->near_zero_angle_t, mp_angle_type);
+ math->near_zero_angle_t.data.dval = near_zero_angle;
+ mp_new_number (mp, &math->p_over_v_threshold_t, mp_fraction_type);
+ math->p_over_v_threshold_t.data.dval = p_over_v_threshold;
+ mp_new_number (mp, &math->equation_threshold_t, mp_scaled_type);
+ math->equation_threshold_t.data.dval = equation_threshold;
+ mp_new_number (mp, &math->tfm_warn_threshold_t, mp_scaled_type);
+ math->tfm_warn_threshold_t.data.dval = tfm_warn_threshold;
+ /* functions */
+ math->from_int = mp_set_double_from_int;
+ math->from_boolean = mp_set_double_from_boolean;
+ math->from_scaled = mp_set_double_from_scaled;
+ math->from_double = mp_set_double_from_double;
+ math->from_addition = mp_set_double_from_addition;
+ math->from_substraction = mp_set_double_from_substraction;
+ math->from_oftheway = mp_set_double_from_of_the_way;
+ math->from_div = mp_set_double_from_div;
+ math->from_mul = mp_set_double_from_mul;
+ math->from_int_div = mp_set_double_from_int_div;
+ math->from_int_mul = mp_set_double_from_int_mul;
+ math->negate = mp_number_negate;
+ math->add = mp_number_add;
+ math->substract = mp_number_substract;
+ math->half = mp_number_half;
+ math->halfp = mp_number_halfp;
+ math->do_double = mp_number_double;
+ math->abs = mp_double_abs;
+ math->clone = mp_number_clone;
+ math->swap = mp_number_swap;
+ math->add_scaled = mp_number_add_scaled;
+ math->multiply_int = mp_number_multiply_int;
+ math->divide_int = mp_number_divide_int;
+ math->to_boolean = mp_number_to_boolean;
+ math->to_scaled = mp_number_to_scaled;
+ math->to_double = mp_number_to_double;
+ math->to_int = mp_number_to_int;
+ math->odd = mp_number_odd;
+ math->equal = mp_number_equal;
+ math->less = mp_number_less;
+ math->greater = mp_number_greater;
+ math->nonequalabs = mp_number_nonequalabs;
+ math->round_unscaled = mp_round_unscaled;
+ math->floor_scaled = mp_number_floor;
+ math->fraction_to_round_scaled = mp_double_fraction_to_round_scaled;
+ math->make_scaled = mp_double_number_make_scaled;
+ math->make_fraction = mp_double_number_make_fraction;
+ math->take_fraction = mp_double_number_take_fraction;
+ math->take_scaled = mp_double_number_take_scaled;
+ math->velocity = mp_double_velocity;
+ math->n_arg = mp_double_n_arg;
+ math->m_log = mp_double_m_log;
+ math->m_exp = mp_double_m_exp;
+ math->m_unif_rand = mp_double_m_unif_rand;
+ math->m_norm_rand = mp_double_m_norm_rand;
+ math->pyth_add = mp_double_pyth_add;
+ math->pyth_sub = mp_double_pyth_sub;
+ math->fraction_to_scaled = mp_number_fraction_to_scaled;
+ math->scaled_to_fraction = mp_number_scaled_to_fraction;
+ math->scaled_to_angle = mp_number_scaled_to_angle;
+ math->angle_to_scaled = mp_number_angle_to_scaled;
+ math->init_randoms = mp_init_randoms;
+ math->sin_cos = mp_double_sin_cos;
+ math->slow_add = mp_double_slow_add;
+ math->sqrt = mp_double_square_rt;
+ math->print = mp_double_print_number;
+ math->tostring = mp_double_number_tostring;
+ math->modulo = mp_number_modulo;
+ math->ab_vs_cd = mp_ab_vs_cd;
+ math->crossing_point = mp_double_crossing_point;
+ math->scan_numeric = mp_double_scan_numeric_token;
+ math->scan_fractional = mp_double_scan_fractional_token;
+ math->free_math = mp_free_double_math;
+ math->set_precision = mp_double_set_precision;
+ return (void *)math;
+}
+
+void mp_double_set_precision (MP mp) {
+}
+
+void mp_free_double_math (MP mp) {
+ free_number (((math_data *)mp->math)->three_sixty_deg_t);
+ free_number (((math_data *)mp->math)->one_eighty_deg_t);
+ free_number (((math_data *)mp->math)->fraction_one_t);
+ free_number (((math_data *)mp->math)->zero_t);
+ free_number (((math_data *)mp->math)->half_unit_t);
+ free_number (((math_data *)mp->math)->three_quarter_unit_t);
+ free_number (((math_data *)mp->math)->unity_t);
+ free_number (((math_data *)mp->math)->two_t);
+ free_number (((math_data *)mp->math)->three_t);
+ free_number (((math_data *)mp->math)->one_third_inf_t);
+ free_number (((math_data *)mp->math)->inf_t);
+ free_number (((math_data *)mp->math)->warning_limit_t);
+ free_number (((math_data *)mp->math)->one_k);
+ free_number (((math_data *)mp->math)->sqrt_8_e_k);
+ free_number (((math_data *)mp->math)->twelve_ln_2_k);
+ free_number (((math_data *)mp->math)->coef_bound_k);
+ free_number (((math_data *)mp->math)->coef_bound_minus_1);
+ free_number (((math_data *)mp->math)->fraction_threshold_t);
+ free_number (((math_data *)mp->math)->half_fraction_threshold_t);
+ free_number (((math_data *)mp->math)->scaled_threshold_t);
+ free_number (((math_data *)mp->math)->half_scaled_threshold_t);
+ free_number (((math_data *)mp->math)->near_zero_angle_t);
+ free_number (((math_data *)mp->math)->p_over_v_threshold_t);
+ free_number (((math_data *)mp->math)->equation_threshold_t);
+ free_number (((math_data *)mp->math)->tfm_warn_threshold_t);
+ free(mp->math);
+}
+
+@ Creating an destroying |mp_number| objects
+
+@ @c
+void mp_new_number (MP mp, mp_number *n, mp_number_type t) {
+ (void)mp;
+ n->data.dval = 0.0;
+ n->type = t;
+}
+
+@
+
+@c
+void mp_free_number (MP mp, mp_number *n) {
+ (void)mp;
+ n->type = mp_nan_type;
+}
+
+@ Here are the low-level functions on |mp_number| items, setters first.
+
+@c
+void mp_set_double_from_int(mp_number *A, int B) {
+ A->data.dval = B;
+}
+void mp_set_double_from_boolean(mp_number *A, int B) {
+ A->data.dval = B;
+}
+void mp_set_double_from_scaled(mp_number *A, int B) {
+ A->data.dval = B / 65536.0;
+}
+void mp_set_double_from_double(mp_number *A, double B) {
+ A->data.dval = B;
+}
+void mp_set_double_from_addition(mp_number *A, mp_number B, mp_number C) {
+ A->data.dval = B.data.dval+C.data.dval;
+}
+void mp_set_double_from_substraction (mp_number *A, mp_number B, mp_number C) {
+ A->data.dval = B.data.dval-C.data.dval;
+}
+void mp_set_double_from_div(mp_number *A, mp_number B, mp_number C) {
+ A->data.dval = B.data.dval / C.data.dval;
+}
+void mp_set_double_from_mul(mp_number *A, mp_number B, mp_number C) {
+ A->data.dval = B.data.dval * C.data.dval;
+}
+void mp_set_double_from_int_div(mp_number *A, mp_number B, int C) {
+ A->data.dval = B.data.dval / C;
+}
+void mp_set_double_from_int_mul(mp_number *A, mp_number B, int C) {
+ A->data.dval = B.data.dval * C;
+}
+void mp_set_double_from_of_the_way(MP mp, mp_number *A, mp_number t, mp_number B, mp_number C) {
+ A->data.dval = B.data.dval - mp_double_take_fraction(mp, (B.data.dval - C.data.dval), t.data.dval);
+}
+void mp_number_negate(mp_number *A) {
+ A->data.dval = -A->data.dval;
+ if (A->data.dval == -0.0)
+ A->data.dval = 0.0;
+}
+void mp_number_add(mp_number *A, mp_number B) {
+ A->data.dval = A->data.dval + B.data.dval;
+}
+void mp_number_substract(mp_number *A, mp_number B) {
+ A->data.dval = A->data.dval - B.data.dval;
+}
+void mp_number_half(mp_number *A) {
+ A->data.dval = A->data.dval/2.0;
+}
+void mp_number_halfp(mp_number *A) {
+ A->data.dval = (A->data.dval/2.0);
+}
+void mp_number_double(mp_number *A) {
+ A->data.dval = A->data.dval * 2.0;
+}
+void mp_number_add_scaled(mp_number *A, int B) { /* also for negative B */
+ A->data.dval = A->data.dval + (B/65536.0);
+}
+void mp_number_multiply_int(mp_number *A, int B) {
+ A->data.dval = (double)(A->data.dval * B);
+}
+void mp_number_divide_int(mp_number *A, int B) {
+ A->data.dval = A->data.dval / (double)B;
+}
+void mp_double_abs(mp_number *A) {
+ A->data.dval = fabs(A->data.dval);
+}
+void mp_number_clone(mp_number *A, mp_number B) {
+ A->data.dval = B.data.dval;
+}
+void mp_number_swap(mp_number *A, mp_number *B) {
+ double swap_tmp = A->data.dval;
+ A->data.dval = B->data.dval;
+ B->data.dval = swap_tmp;
+}
+void mp_number_fraction_to_scaled (mp_number *A) {
+ A->type = mp_scaled_type;
+ A->data.dval = A->data.dval / fraction_multiplier;
+}
+void mp_number_angle_to_scaled (mp_number *A) {
+ A->type = mp_scaled_type;
+ A->data.dval = A->data.dval / angle_multiplier;
+}
+void mp_number_scaled_to_fraction (mp_number *A) {
+ A->type = mp_fraction_type;
+ A->data.dval = A->data.dval * fraction_multiplier;
+}
+void mp_number_scaled_to_angle (mp_number *A) {
+ A->type = mp_angle_type;
+ A->data.dval = A->data.dval * angle_multiplier;
+}
+
+
+@ Query functions
+
+@c
+int mp_number_to_scaled(mp_number A) {
+ return (int)ROUND(A.data.dval * 65536.0);
+}
+int mp_number_to_int(mp_number A) {
+ return (int)(A.data.dval);
+}
+int mp_number_to_boolean(mp_number A) {
+ return (int)(A.data.dval);
+}
+double mp_number_to_double(mp_number A) {
+ return A.data.dval;
+}
+int mp_number_odd(mp_number A) {
+ return odd((int)ROUND(A.data.dval * 65536.0));
+}
+int mp_number_equal(mp_number A, mp_number B) {
+ return (A.data.dval==B.data.dval);
+}
+int mp_number_greater(mp_number A, mp_number B) {
+ return (A.data.dval>B.data.dval);
+}
+int mp_number_less(mp_number A, mp_number B) {
+ return (A.data.dval<B.data.dval);
+}
+int mp_number_nonequalabs(mp_number A, mp_number B) {
+ return (!(fabs(A.data.dval)==fabs(B.data.dval)));
+}
+
+@ Fixed-point arithmetic is done on {\sl scaled integers\/} that are multiples
+of $2^{-16}$. In other words, a binary point is assumed to be sixteen bit
+positions from the right end of a binary computer word.
+
+@d unity 1.0
+@d two 2.0
+@d three 3.0
+@d half_unit 0.5
+@d three_quarter_unit 0.75
+
+@d EL_GORDO (DBL_MAX/2.0-1.0) /* the largest value that \MP\ likes. */
+@d one_third_EL_GORDO (EL_GORDO/3.0)
+
+@ One of \MP's most common operations is the calculation of
+$\lfloor{a+b\over2}\rfloor$,
+the midpoint of two given integers |a| and~|b|. The most decent way to do
+this is to write `|(a+b)/2|'; but on many machines it is more efficient
+to calculate `|(a+b)>>1|'.
+
+Therefore the midpoint operation will always be denoted by `|half(a+b)|'
+in this program. If \MP\ is being implemented with languages that permit
+binary shifting, the |half| macro should be changed to make this operation
+as efficient as possible. Since some systems have shift operators that can
+only be trusted to work on positive numbers, there is also a macro |halfp|
+that is used only when the quantity being halved is known to be positive
+or zero.
+
+@ Here is a procedure analogous to |print_int|. The current version
+is fairly stupid, and it is not round-trip safe, but this is good
+enough for a beta test.
+
+@c
+char * mp_double_number_tostring (MP mp, mp_number n) {
+ static char set[64];
+ int l = 0;
+ char *ret = mp_xmalloc(mp, 64, 1);
+ snprintf(set, 64, "%.17g", n.data.dval);
+ while (set[l] == ' ') l++;
+ strcpy(ret, set+l);
+ return ret;
+}
+
+
+@ @c
+void mp_double_print_number (MP mp, mp_number n) {
+ char *str = mp_double_number_tostring(mp, n);
+ mp_print (mp, str);
+ free (str);
+}
+
+
+
+
+@ Addition is not always checked to make sure that it doesn't overflow,
+but in places where overflow isn't too unlikely the |slow_add| routine
+is used.
+
+@c
+void mp_double_slow_add (MP mp, mp_number *ret, mp_number x_orig, mp_number y_orig) {
+ double x, y;
+ x = x_orig.data.dval;
+ y = y_orig.data.dval;
+ if (x >= 0) {
+ if (y <= EL_GORDO - x) {
+ ret->data.dval = x + y;
+ } else {
+ mp->arith_error = true;
+ ret->data.dval = EL_GORDO;
+ }
+ } else if (-y <= EL_GORDO + x) {
+ ret->data.dval = x + y;
+ } else {
+ mp->arith_error = true;
+ ret->data.dval = -EL_GORDO;
+ }
+}
+
+@ The |make_fraction| routine produces the |fraction| equivalent of
+|p/q|, given integers |p| and~|q|; it computes the integer
+$f=\lfloor2^{28}p/q+{1\over2}\rfloor$, when $p$ and $q$ are
+positive. If |p| and |q| are both of the same scaled type |t|,
+the ``type relation'' |make_fraction(t,t)=fraction| is valid;
+and it's also possible to use the subroutine ``backwards,'' using
+the relation |make_fraction(t,fraction)=t| between scaled types.
+
+If the result would have magnitude $2^{31}$ or more, |make_fraction|
+sets |arith_error:=true|. Most of \MP's internal computations have
+been designed to avoid this sort of error.
+
+If this subroutine were programmed in assembly language on a typical
+machine, we could simply compute |(@t$2^{28}$@>*p)div q|, since a
+double-precision product can often be input to a fixed-point division
+instruction. But when we are restricted to int-eger arithmetic it
+is necessary either to resort to multiple-precision maneuvering
+or to use a simple but slow iteration. The multiple-precision technique
+would be about three times faster than the code adopted here, but it
+would be comparatively long and tricky, involving about sixteen
+additional multiplications and divisions.
+
+This operation is part of \MP's ``inner loop''; indeed, it will
+consume nearly 10\pct! of the running time (exclusive of input and output)
+if the code below is left unchanged. A machine-dependent recoding
+will therefore make \MP\ run faster. The present implementation
+is highly portable, but slow; it avoids multiplication and division
+except in the initial stage. System wizards should be careful to
+replace it with a routine that is guaranteed to produce identical
+results in all cases.
+@^system dependencies@>
+
+As noted below, a few more routines should also be replaced by machine-dependent
+code, for efficiency. But when a procedure is not part of the ``inner loop,''
+such changes aren't advisable; simplicity and robustness are
+preferable to trickery, unless the cost is too high.
+@^inner loop@>
+
+@c
+double mp_double_make_fraction (MP mp, double p, double q) {
+ return ((p / q) * fraction_multiplier);
+}
+void mp_double_number_make_fraction (MP mp, mp_number *ret, mp_number p, mp_number q) {
+ ret->data.dval = mp_double_make_fraction (mp, p.data.dval, q.data.dval);
+}
+
+@ @<Declarations@>=
+double mp_double_make_fraction (MP mp, double p, double q);
+
+@ 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@>
+
+@c
+double mp_double_take_fraction (MP mp, double p, double q) {
+ return ((p * q) / fraction_multiplier);
+}
+void mp_double_number_take_fraction (MP mp, mp_number *ret, mp_number p, mp_number q) {
+ ret->data.dval = mp_double_take_fraction (mp, p.data.dval, q.data.dval);
+}
+
+@ @<Declarations@>=
+double mp_double_take_fraction (MP mp, double p, double q);
+
+@ When we want to multiply something by a |scaled| quantity, we use a scheme
+analogous to |take_fraction| but with a different scaling.
+Given positive operands, |take_scaled|
+computes the quantity $p=\lfloor qf/2^{16}+{1\over2}\rfloor$.
+
+Once again it is a good idea to use a machine-language replacement if
+possible; otherwise |take_scaled| will use more than 2\pct! of the running time
+when the Computer Modern fonts are being generated.
+@^inner loop@>
+
+@c
+void mp_double_number_take_scaled (MP mp, mp_number *ret, mp_number p_orig, mp_number q_orig) {
+ ret->data.dval = p_orig.data.dval * q_orig.data.dval;
+}
+
+
+@ 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.)
+
+@c
+double mp_double_make_scaled (MP mp, double p, double q) {
+ return p / q;
+}
+void mp_double_number_make_scaled (MP mp, mp_number *ret, mp_number p_orig, mp_number q_orig) {
+ ret->data.dval = p_orig.data.dval / q_orig.data.dval;
+}
+
+@ @<Declarations@>=
+double mp_double_make_scaled (MP mp, double p, double q);
+
+
+@
+@d halfp(A) (integer)((unsigned)(A) >> 1)
+
+@* Scanning numbers in the input.
+
+The definitions below are temporarily here
+
+@d set_cur_cmd(A) mp->cur_mod_->type=(A)
+@d set_cur_mod(A) mp->cur_mod_->data.n.data.dval=(A)
+
+@<Declarations...@>=
+static void mp_wrapup_numeric_token(MP mp, unsigned char *start, unsigned char *stop);
+
+@ @c
+void mp_wrapup_numeric_token(MP mp, unsigned char *start, unsigned char *stop) {
+ double result;
+ char *end = (char *)stop;
+ errno = 0;
+ result = strtod ((char *)start, &end);
+ if (errno == 0) {
+ set_cur_mod(result);
+ if (result >= warning_limit) {
+ if (internal_value (mp_warning_check).data.dval > 0 &&
+ (mp->scanner_status != tex_flushing)) {
+ char msg[256];
+ const char *hlp[] = {"Continue and I'll try to cope",
+ "with that big value; but it might be dangerous.",
+ "(Set warningcheck:=0 to suppress this message.)",
+ NULL };
+ mp_snprintf (msg, 256, "Number is too large (%g)", result);
+@.Number is too large@>;
+ mp_error (mp, msg, hlp, true);
+ }
+ }
+ } else if (mp->scanner_status != tex_flushing) {
+ const char *hlp[] = {"I could not handle this number specification",
+ "probably because it is out of range. Error:",
+ "",
+ NULL };
+ hlp[2] = strerror(errno);
+ mp_error (mp, "Enormous number has been reduced.", hlp, false);
+@.Enormous number...@>;
+ set_cur_mod(EL_GORDO);
+ }
+ set_cur_cmd((mp_variable_type)mp_numeric_token);
+}
+
+@ @c
+static void find_exponent (MP mp) {
+ if (mp->buffer[mp->cur_input.loc_field] == 'e' ||
+ mp->buffer[mp->cur_input.loc_field] == 'E') {
+ mp->cur_input.loc_field++;
+ if (!(mp->buffer[mp->cur_input.loc_field] == '+' ||
+ mp->buffer[mp->cur_input.loc_field] == '-' ||
+ mp->char_class[mp->buffer[mp->cur_input.loc_field]] == digit_class)) {
+ mp->cur_input.loc_field--;
+ return;
+ }
+ if (mp->buffer[mp->cur_input.loc_field] == '+' ||
+ mp->buffer[mp->cur_input.loc_field] == '-') {
+ mp->cur_input.loc_field++;
+ }
+ while (mp->char_class[mp->buffer[mp->cur_input.loc_field]] == digit_class) {
+ mp->cur_input.loc_field++;
+ }
+ }
+}
+void mp_double_scan_fractional_token (MP mp, int n) { /* n: scaled */
+ unsigned char *start = &mp->buffer[mp->cur_input.loc_field -1];
+ unsigned char *stop;
+ while (mp->char_class[mp->buffer[mp->cur_input.loc_field]] == digit_class) {
+ mp->cur_input.loc_field++;
+ }
+ find_exponent(mp);
+ stop = &mp->buffer[mp->cur_input.loc_field-1];
+ mp_wrapup_numeric_token (mp, start, stop);
+}
+
+
+@ Input format is the same as for the C language, so we just collect valid
+bytes in the buffer, then call |strtod()|
+
+@c
+void mp_double_scan_numeric_token (MP mp, int n) { /* n: scaled */
+ unsigned char *start = &mp->buffer[mp->cur_input.loc_field -1];
+ unsigned char *stop;
+ while (mp->char_class[mp->buffer[mp->cur_input.loc_field]] == digit_class) {
+ mp->cur_input.loc_field++;
+ }
+ if (mp->buffer[mp->cur_input.loc_field] == '.' &&
+ mp->buffer[mp->cur_input.loc_field+1] != '.') {
+ mp->cur_input.loc_field++;
+ while (mp->char_class[mp->buffer[mp->cur_input.loc_field]] == digit_class) {
+ mp->cur_input.loc_field++;
+ }
+ }
+ find_exponent(mp);
+ stop = &mp->buffer[mp->cur_input.loc_field-1];
+ mp_wrapup_numeric_token (mp, start, stop);
+}
+
+@ 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 (0.5*fraction_multiplier)
+@d fraction_one (1.0*fraction_multiplier)
+@d fraction_two (2.0*fraction_multiplier)
+@d fraction_three (3.0*fraction_multiplier)
+@d fraction_four (4.0*fraction_multiplier)
+
+@ 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.
+
+The angles $\theta$ and $\phi$ are given implicitly in terms of |fraction|
+arguments |st|, |ct|, |sf|, and |cf|, representing $\sin\theta$, $\cos\theta$,
+$\sin\phi$, and $\cos\phi$, respectively.
+
+@c
+void mp_double_velocity (MP mp, mp_number *ret, mp_number st, mp_number ct, mp_number sf,
+ mp_number cf, mp_number t) {
+ double acc, num, denom; /* registers for intermediate calculations */
+ acc = mp_double_take_fraction (mp, st.data.dval - (sf.data.dval / 16.0),
+ sf.data.dval - (st.data.dval / 16.0));
+ acc = mp_double_take_fraction (mp, acc, ct.data.dval - cf.data.dval);
+ num = fraction_two + mp_double_take_fraction (mp, acc, sqrt(2)*fraction_one);
+ denom =
+ fraction_three + mp_double_take_fraction (mp, ct.data.dval, 3*fraction_half*(sqrt(5.0)-1.0))
+ + mp_double_take_fraction (mp, cf.data.dval, 3*fraction_half*(3.0-sqrt(5.0)));
+ if (t.data.dval != unity)
+ num = mp_double_make_scaled (mp, num, t.data.dval);
+ if (num / 4 >= denom) {
+ ret->data.dval = fraction_four;
+ } else {
+ ret->data.dval = mp_double_make_fraction (mp, num, denom);
+ }
+#if DEBUG
+ fprintf(stdout, "\n%f = velocity(%f,%f,%f,%f,%f)", mp_number_to_double(*ret),
+mp_number_to_double(st),mp_number_to_double(ct),
+mp_number_to_double(sf),mp_number_to_double(cf),
+mp_number_to_double(t));
+#endif
+}
+
+
+@ 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.
+
+@c
+void mp_ab_vs_cd (MP mp, mp_number *ret, mp_number a_orig, mp_number b_orig, mp_number c_orig, mp_number d_orig) {
+ integer q, r; /* temporary registers */
+ integer a, b, c, d;
+ (void)mp;
+
+ mp_double_ab_vs_cd(mp,ret, a_orig, b_orig, c_orig, d_orig);
+ if (1>0)
+ return ;
+ /* TODO: remove this code until the end */
+ a = a_orig.data.dval;
+ b = b_orig.data.dval;
+ c = c_orig.data.dval;
+ d = d_orig.data.dval;
+ @<Reduce to the case that |a,c>=0|, |b,d>0|@>;
+ while (1) {
+ q = a / d;
+ r = c / b;
+ if (q != r) {
+ ret->data.dval = (q > r ? 1 : -1);
+ goto RETURN;
+ }
+ q = a % d;
+ r = c % b;
+ if (r == 0) {
+ ret->data.dval = (q ? 1 : 0);
+ goto RETURN;
+ }
+ if (q == 0) {
+ ret->data.dval = -1;
+ goto RETURN;
+ }
+ a = b;
+ b = q;
+ c = d;
+ d = r;
+ } /* now |a>d>0| and |c>b>0| */
+RETURN:
+#if DEBUG
+ fprintf(stdout, "\n%f = ab_vs_cd(%f,%f,%f,%f)", mp_number_to_double(*ret),
+mp_number_to_double(a_orig),mp_number_to_double(b_orig),
+mp_number_to_double(c_orig),mp_number_to_double(d_orig));
+#endif
+ return;
+}
+
+
+@ @<Reduce to the case that |a...@>=
+if (a < 0) {
+ a = -a;
+ b = -b;
+}
+if (c < 0) {
+ c = -c;
+ d = -d;
+}
+if (d <= 0) {
+ if (b >= 0) {
+ if ((a == 0 || b == 0) && (c == 0 || d == 0))
+ ret->data.dval = 0;
+ else
+ ret->data.dval = 1;
+ goto RETURN;
+ }
+ if (d == 0) {
+ ret->data.dval = (a == 0 ? 0 : -1);
+ goto RETURN;
+ }
+ q = a;
+ a = c;
+ c = q;
+ q = -b;
+ b = -d;
+ d = q;
+} else if (b <= 0) {
+ if (b < 0 && a > 0) {
+ ret->data.dval = -1;
+ return;
+ }
+ ret->data.dval = (c == 0 ? 0 : -1);
+ goto RETURN;
+}
+
+@ 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.
+
+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}$.
+
+@d no_crossing { ret->data.dval = fraction_one + 1; goto RETURN; }
+@d one_crossing { ret->data.dval = fraction_one; goto RETURN; }
+@d zero_crossing { ret->data.dval = 0; goto RETURN; }
+
+@c
+static void mp_double_crossing_point (MP mp, mp_number *ret, mp_number aa, mp_number bb, mp_number cc) {
+ double a,b,c;
+ double d; /* recursive counter */
+ double x, xx, x0, x1, x2; /* temporary registers for bisection */
+ a = aa.data.dval;
+ b = bb.data.dval;
+ c = cc.data.dval;
+ if (a < 0)
+ zero_crossing;
+ if (c >= 0) {
+ if (b >= 0) {
+ if (c > 0) {
+ no_crossing;
+ } else if ((a == 0) && (b == 0)) {
+ no_crossing;
+ } else {
+ one_crossing;
+ }
+ }
+ if (a == 0)
+ zero_crossing;
+ } else if (a == 0) {
+ if (b <= 0)
+ zero_crossing;
+ }
+
+ /* Use bisection to find the crossing point... */
+ d = epsilon;
+ x0 = a;
+ x1 = a - b;
+ x2 = b - c;
+ do {
+ /* not sure why the error correction has to be >= 1E-12 */
+ x = (x1 + x2) / 2 + 1E-12;
+ if (x1 - x0 > x0) {
+ x2 = x;
+ x0 += x0;
+ d += d;
+ } else {
+ xx = x1 + x - x0;
+ if (xx > x0) {
+ x2 = x;
+ x0 += x0;
+ d += d;
+ } else {
+ x0 = x0 - xx;
+ if (x <= x0) {
+ if (x + x2 <= x0)
+ no_crossing;
+ }
+ x1 = x;
+ d = d + d + epsilon;
+ }
+ }
+ } while (d < fraction_one);
+ ret->data.dval = (d - fraction_one);
+RETURN:
+#if DEBUG
+ fprintf(stdout, "\n%f = crossing_point(%f,%f,%f)", mp_number_to_double(*ret),
+mp_number_to_double(aa),mp_number_to_double(bb),mp_number_to_double(cc));
+#endif
+ return;
+}
+
+
+@ We conclude this set of elementary routines with some simple rounding
+and truncation operations.
+
+
+@ |round_unscaled| rounds a |scaled| and converts it to |int|
+@c
+int mp_round_unscaled(mp_number x_orig) {
+ int x = (int)ROUND(x_orig.data.dval);
+ return x;
+}
+
+@ |number_floor| floors a number
+
+@c
+void mp_number_floor (mp_number *i) {
+ i->data.dval = floor(i->data.dval);
+}
+
+@ |fraction_to_scaled| rounds a |fraction| and converts it to |scaled|
+@c
+void mp_double_fraction_to_round_scaled (mp_number *x_orig) {
+ double x = x_orig->data.dval;
+ x_orig->type = mp_scaled_type;
+ x_orig->data.dval = x/fraction_multiplier;
+}
+
+
+
+@* 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.
+
+@
+
+@c
+void mp_double_square_rt (MP mp, mp_number *ret, mp_number x_orig) { /* return, x: scaled */
+ double x;
+ x = x_orig.data.dval;
+ if (x <= 0) {
+ @<Handle square root of zero or negative argument@>;
+ } else {
+ ret->data.dval = sqrt(x);
+ }
+}
+
+
+@ @<Handle square root of zero...@>=
+{
+ if (x < 0) {
+ char msg[256];
+ const char *hlp[] = {
+ "Since I don't take square roots of negative numbers,",
+ "I'm zeroing this one. Proceed, with fingers crossed.",
+ NULL };
+ char *xstr = mp_double_number_tostring (mp, x_orig);
+ mp_snprintf(msg, 256, "Square root of %s has been replaced by 0", xstr);
+ free(xstr);
+@.Square root...replaced by 0@>;
+ mp_error (mp, msg, hlp, true);
+ }
+ ret->data.dval = 0;
+ return;
+}
+
+
+@ Pythagorean addition $\psqrt{a^2+b^2}$ is implemented by a quick hack
+
+@c
+void mp_double_pyth_add (MP mp, mp_number *ret, mp_number a_orig, mp_number b_orig) {
+ double a, b; /* a,b : scaled */
+ a = fabs (a_orig.data.dval);
+ b = fabs (b_orig.data.dval);
+ errno = 0;
+ ret->data.dval = sqrt(a*a + b*b);
+ if (errno) {
+ mp->arith_error = true;
+ ret->data.dval = EL_GORDO;
+ }
+}
+
+
+@ Here is a similar algorithm for $\psqrt{a^2-b^2}$. Same quick hack, also.
+
+@c
+void mp_double_pyth_sub (MP mp, mp_number *ret, mp_number a_orig, mp_number b_orig) {
+ double a, b;
+ a = fabs (a_orig.data.dval);
+ b = fabs (b_orig.data.dval);
+ if (a <= b) {
+ @<Handle erroneous |pyth_sub| and set |a:=0|@>;
+ } else {
+ a = sqrt(a*a - b*b);
+ }
+ ret->data.dval = a;
+}
+
+
+@ @<Handle erroneous |pyth_sub| and set |a:=0|@>=
+{
+ if (a < b) {
+ char msg[256];
+ const char *hlp[] = {
+ "Since I don't take square roots of negative numbers,",
+ "I'm zeroing this one. Proceed, with fingers crossed.",
+ NULL };
+ char *astr = mp_double_number_tostring (mp, a_orig);
+ char *bstr = mp_double_number_tostring (mp, b_orig);
+ mp_snprintf (msg, 256, "Pythagorean subtraction %s+-+%s has been replaced by 0", astr, bstr);
+ free(astr);
+ free(bstr);
+@.Pythagorean...@>;
+ mp_error (mp, msg, hlp, true);
+ }
+ a = 0;
+}
+
+
+@ The subroutines for logarithm and exponential involve two tables.
+The first is simple: |two_to_the[k]| equals $2^k$.
+
+@d two_to_the(A) (1<<(unsigned)(A))
+
+@ 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.
+
+@c
+void mp_double_m_log (MP mp, mp_number *ret, mp_number x_orig) {
+ if (x_orig.data.dval <= 0) {
+ @<Handle non-positive logarithm@>;
+ } else {
+ ret->data.dval = log (x_orig.data.dval)*256.0;
+ }
+}
+
+@ @<Handle non-positive logarithm@>=
+{
+ char msg[256];
+ const char *hlp[] = {
+ "Since I don't take logs of non-positive numbers,",
+ "I'm zeroing this one. Proceed, with fingers crossed.",
+ NULL };
+ char *xstr = mp_double_number_tostring (mp, x_orig);
+ mp_snprintf (msg, 256, "Logarithm of %s has been replaced by 0", xstr);
+ free (xstr);
+@.Logarithm...replaced by 0@>;
+ mp_error (mp, msg, hlp, true);
+ ret->data.dval = 0;
+}
+
+
+@ Conversely, the exponential routine calculates $\exp(x/2^8)$,
+when |x| is |scaled|.
+
+@c
+void mp_double_m_exp (MP mp, mp_number *ret, mp_number x_orig) {
+ errno = 0;
+ ret->data.dval = exp(x_orig.data.dval/256.0);
+ if (errno) {
+ if (x_orig.data.dval > 0) {
+ mp->arith_error = true;
+ ret->data.dval = EL_GORDO;
+ } else {
+ ret->data.dval = 0;
+ }
+ }
+}
+
+
+@ Given integers |x| and |y|, not both zero, the |n_arg| function
+returns the |angle| whose tangent points in the direction $(x,y)$.
+
+@c
+void mp_double_n_arg (MP mp, mp_number *ret, mp_number x_orig, mp_number y_orig) {
+ if (x_orig.data.dval == 0.0 && y_orig.data.dval == 0.0) {
+ @<Handle undefined arg@>;
+ } else {
+ ret->type = mp_angle_type;
+ ret->data.dval = atan2 (y_orig.data.dval, x_orig.data.dval) * (180.0 / PI) * angle_multiplier;
+ if (ret->data.dval == -0.0)
+ ret->data.dval = 0.0;
+#if DEBUG
+ fprintf(stdout, "\nn_arg(%g,%g,%g)", mp_number_to_double(*ret),
+ mp_number_to_double(x_orig),mp_number_to_double(y_orig));
+#endif
+ }
+}
+
+
+@ @<Handle undefined arg@>=
+{
+ const char *hlp[] = {
+ "The `angle' between two identical points is undefined.",
+ "I'm zeroing this one. Proceed, with fingers crossed.",
+ NULL };
+ mp_error (mp, "angle(0,0) is taken as zero", hlp, true);
+@.angle(0,0)...zero@>;
+ ret->data.dval = 0;
+}
+
+
+@ 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|.
+
+@ 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|.
+
+@d one_eighty_deg (180.0*angle_multiplier)
+@d three_sixty_deg (360.0*angle_multiplier)
+
+@d odd(A) (abs(A)%2==1)
+
+@ Compute a multiple of the sine and cosine
+
+@c
+void mp_double_sin_cos (MP mp, mp_number z_orig, mp_number *n_cos, mp_number *n_sin) {
+ double rad;
+ rad = (z_orig.data.dval / angle_multiplier); /* still degrees */
+ if ((rad == 90.0)||(rad == -270)){
+ n_cos->data.dval = 0.0;
+ n_sin->data.dval = fraction_multiplier;
+ } else if ((rad == -90.0)||(rad == 270.0)) {
+ n_cos->data.dval = 0.0;
+ n_sin->data.dval = -fraction_multiplier;
+ } else if ((rad == 180.0) || (rad == -180.0)) {
+ n_cos->data.dval = -fraction_multiplier;
+ n_sin->data.dval = 0.0;
+ } else {
+ rad = rad * PI/180.0;
+ n_cos->data.dval = cos(rad) * fraction_multiplier;
+ n_sin->data.dval = sin(rad) * fraction_multiplier;
+ }
+#if DEBUG
+ fprintf(stdout, "\nsin_cos(%f,%f,%f)", mp_number_to_double(z_orig),
+mp_number_to_double(*n_cos), mp_number_to_double(*n_sin));
+#endif
+}
+
+@ This is the http://www-cs-faculty.stanford.edu/~uno/programs/rng.c
+with small cosmetic modifications.
+
+@c
+#define KK 100 /* the long lag */
+#define LL 37 /* the short lag */
+#define MM (1L<<30) /* the modulus */
+#define mod_diff(x,y) (((x)-(y))&(MM-1)) /* subtraction mod MM */
+/* */
+static long ran_x[KK]; /* the generator state */
+/* */
+static void ran_array(long aa[],int n) /* put n new random numbers in aa */
+ /* long aa[] destination */
+ /* int n array length (must be at least KK) */
+{
+ register int i,j;
+ for (j=0;j<KK;j++) aa[j]=ran_x[j];
+ for (;j<n;j++) aa[j]=mod_diff(aa[j-KK],aa[j-LL]);
+ for (i=0;i<LL;i++,j++) ran_x[i]=mod_diff(aa[j-KK],aa[j-LL]);
+ for (;i<KK;i++,j++) ran_x[i]=mod_diff(aa[j-KK],ran_x[i-LL]);
+}
+/* */
+/* the following routines are from exercise 3.6--15 */
+/* after calling |ran_start|, get new randoms by, e.g., |x=ran_arr_next()| */
+/* */
+#define QUALITY 1009 /* recommended quality level for high-res use */
+static long ran_arr_buf[QUALITY];
+static long ran_arr_dummy=-1, ran_arr_started=-1;
+static long *ran_arr_ptr=&ran_arr_dummy; /* the next random number, or -1 */
+/* */
+#define TT 70 /* guaranteed separation between streams */
+#define is_odd(x) ((x)&1) /* units bit of x */
+/* */
+static void ran_start(long seed) /* do this before using |ran_array| */
+ /* long seed selector for different streams */
+{
+ register int t,j;
+ long x[KK+KK-1]; /* the preparation buffer */
+ register long ss=(seed+2)&(MM-2);
+ for (j=0;j<KK;j++) {
+ x[j]=ss; /* bootstrap the buffer */
+ ss<<=1; if (ss>=MM) ss-=MM-2; /* cyclic shift 29 bits */
+ }
+ x[1]++; /* make x[1] (and only x[1]) odd */
+ for (ss=seed&(MM-1),t=TT-1; t; ) {
+ for (j=KK-1;j>0;j--) x[j+j]=x[j], x[j+j-1]=0; /* "square" */
+ for (j=KK+KK-2;j>=KK;j--)
+ x[j-(KK-LL)]=mod_diff(x[j-(KK-LL)],x[j]),
+ x[j-KK]=mod_diff(x[j-KK],x[j]);
+ if (is_odd(ss)) { /* "multiply by z" */
+ for (j=KK;j>0;j--) x[j]=x[j-1];
+ x[0]=x[KK]; /* shift the buffer cyclically */
+ x[LL]=mod_diff(x[LL],x[KK]);
+ }
+ if (ss) ss>>=1; else t--;
+ }
+ for (j=0;j<LL;j++) ran_x[j+KK-LL]=x[j];
+ for (;j<KK;j++) ran_x[j-LL]=x[j];
+ for (j=0;j<10;j++) ran_array(x,KK+KK-1); /* warm things up */
+ ran_arr_ptr=&ran_arr_started;
+}
+/* */
+#define ran_arr_next() (*ran_arr_ptr>=0? *ran_arr_ptr++: ran_arr_cycle())
+static long ran_arr_cycle(void)
+{
+ if (ran_arr_ptr==&ran_arr_dummy)
+ ran_start(314159L); /* the user forgot to initialize */
+ ran_array(ran_arr_buf,QUALITY);
+ ran_arr_buf[KK]=-1;
+ ran_arr_ptr=ran_arr_buf+1;
+ return ran_arr_buf[0];
+}
+
+
+
+@ To initialize the |randoms| table, we call the following routine.
+
+@c
+void mp_init_randoms (MP mp, int seed) {
+ int j, jj, k; /* more or less random integers */
+ int i; /* index into |randoms| */
+ j = abs (seed);
+ while (j >= fraction_one) {
+ j = j/2;
+ }
+ k = 1;
+ for (i = 0; i <= 54; i++) {
+ jj = k;
+ k = j - k;
+ j = jj;
+ if (k<0)
+ k += fraction_one;
+ mp->randoms[(i * 21) % 55].data.dval = j;
+ }
+ mp_new_randoms (mp);
+ mp_new_randoms (mp);
+ mp_new_randoms (mp); /* ``warm up'' the array */
+
+ ran_start((unsigned long) seed);
+
+
+}
+
+@ @c
+static double modulus(double left, double right);
+double modulus(double left, double right) {
+ double quota = left / right;
+ double frac,tmp;
+ frac = modf(quota,&tmp);
+ /* frac contains what's beyond the '.' */
+ frac *= right;
+ return frac;
+}
+void mp_number_modulo (mp_number *a, mp_number b) {
+ a->data.dval = modulus (a->data.dval, b.data.dval);
+}
+
+
+
+@ To consume a random integer for the uniform generator, the program below will say `|next_unif_random|'.
+
+@c
+static void mp_next_unif_random (MP mp, mp_number *ret) {
+ double a;
+ unsigned long int op;
+ (void)mp;
+ op = (unsigned)ran_arr_next();
+ a = op/(MM*1.0);
+ ret->data.dval = a;
+}
+
+
+
+@ To consume a random fraction, the program below will say `|next_random|'.
+
+@c
+static void mp_next_random (MP mp, mp_number *ret) {
+ if ( mp->j_random==0 )
+ mp_new_randoms(mp);
+ else
+ mp->j_random = mp->j_random-1;
+ mp_number_clone (ret, mp->randoms[mp->j_random]);
+}
+
+
+@ To produce a uniform random number in the range |0<=u<x| or |0>=u>x|
+or |0=u=x|, given a |scaled| value~|x|, we proceed as shown here.
+
+Note that the call of |take_fraction| will produce the values 0 and~|x|
+with about half the probability that it will produce any other particular
+values between 0 and~|x|, because it rounds its answers.
+
+@c
+static void mp_double_m_unif_rand (MP mp, mp_number *ret, mp_number x_orig) {
+ mp_number y; /* trial value */
+ mp_number x, abs_x;
+ mp_number u;
+ new_fraction (y);
+ new_number (x);
+ new_number (abs_x);
+ new_number (u);
+ mp_number_clone (&x, x_orig);
+ mp_number_clone (&abs_x, x);
+ mp_double_abs (&abs_x);
+ mp_next_unif_random(mp, &u);
+ y.data.dval = abs_x.data.dval * u.data.dval;
+ free_number (u);
+ if (mp_number_equal(y, abs_x)) {
+ mp_number_clone (ret, ((math_data *)mp->math)->zero_t);
+ } else if (mp_number_greater(x, ((math_data *)mp->math)->zero_t)) {
+ mp_number_clone (ret, y);
+ } else {
+ mp_number_clone (ret, y);
+ mp_number_negate (ret);
+ }
+ free_number (abs_x);
+ free_number (x);
+ free_number (y);
+}
+
+
+
+@ Finally, a normal deviate with mean zero and unit standard deviation
+can readily be obtained with the ratio method (Algorithm 3.4.1R in
+{\sl The Art of Computer Programming\/}).
+
+@c
+static void mp_double_m_norm_rand (MP mp, mp_number *ret) {
+ mp_number ab_vs_cd;
+ mp_number abs_x;
+ mp_number u;
+ mp_number r;
+ mp_number la, xa;
+ new_number (ab_vs_cd);
+ new_number (la);
+ new_number (xa);
+ new_number (abs_x);
+ new_number (u);
+ new_number (r);
+
+ do {
+ do {
+ mp_number v;
+ new_number (v);
+ mp_next_random(mp, &v);
+ mp_number_substract (&v, ((math_data *)mp->math)->fraction_half_t);
+ mp_double_number_take_fraction (mp,&xa, ((math_data *)mp->math)->sqrt_8_e_k, v);
+ free_number (v);
+ mp_next_random(mp, &u);
+ mp_number_clone (&abs_x, xa);
+ mp_double_abs (&abs_x);
+ } while (!mp_number_less(abs_x, u));
+ mp_double_number_make_fraction (mp, &r, xa, u);
+ mp_number_clone (&xa, r);
+ mp_double_m_log (mp,&la, u);
+ mp_set_double_from_substraction(&la, ((math_data *)mp->math)->twelve_ln_2_k, la);
+ mp_double_ab_vs_cd (mp,&ab_vs_cd, ((math_data *)mp->math)->one_k, la, xa, xa);
+ } while (mp_number_less(ab_vs_cd,((math_data *)mp->math)->zero_t));
+ mp_number_clone (ret, xa);
+ free_number (ab_vs_cd);
+ free_number (r);
+ free_number (abs_x);
+ free_number (la);
+ free_number (xa);
+ free_number (u);
+}
+
+
+
+
+@ The following subroutine is used only in |norm_rand| and tests if $ab$ is
+greater than, equal to, or less than~$cd$.
+The result is $+1$, 0, or~$-1$ in the three respective cases.
+
+@c
+void mp_double_ab_vs_cd (MP mp, mp_number *ret, mp_number a_orig, mp_number b_orig, mp_number c_orig, mp_number d_orig) {
+ double ab, cd;
+ (void)mp;
+ ret->data.dval = 0 ;
+ ab = a_orig.data.dval*b_orig.data.dval;
+ cd = c_orig.data.dval*d_orig.data.dval;
+ if (ab > cd )
+ ret->data.dval = 1 ;
+ else if (ab < cd )
+ ret->data.dval = -1 ;
+ return ;
+}
+
diff --git a/Build/source/texk/web2c/mplibdir/mpost.w b/Build/source/texk/web2c/mplibdir/mpost.w
new file mode 100644
index 00000000000..5e447270678
--- /dev/null
+++ b/Build/source/texk/web2c/mplibdir/mpost.w
@@ -0,0 +1,1492 @@
+% This file is part of MetaPost;
+% the MetaPost program is in the public domain.
+% See the <Show version...> code below for more info.
+
+\font\tenlogo=logo10 % font used for the METAFONT logo
+\def\MP{{\tenlogo META}\-{\tenlogo POST}}
+\def\MF{{\tenlogo META}\-{\tenlogo FONT}}
+\def\MP{{\tenlogo META}\-{\tenlogo POST}}
+\def\pct!{{\char`\%}} % percent sign in ordinary text
+\def\psqrt#1{\sqrt{\mathstrut#1}}
+
+
+\def\title{MetaPost executable}
+\def\[#1]{#1.}
+\pdfoutput=1
+
+@s line normal
+
+@s MP int
+@s MPX int
+@s MP_options int
+@s boolean int
+@s const_string int
+@s mpx_options int
+@s option int
+@s string int
+@s timeb int
+@s timeval int
+
+@*\MP\ executable.
+
+Now that all of \MP\ is a library, a separate program is needed to
+have our customary command-line interface.
+
+@ First, here are the \CEE/ includes.
+
+@d true 1
+@d false 0
+
+@c
+#include <w2c/config.h>
+#include <stdio.h>
+#include <stdlib.h>
+#include <string.h>
+#if defined (HAVE_SYS_TIME_H)
+#include <sys/time.h>
+#elif defined (HAVE_SYS_TIMEB_H)
+#include <sys/timeb.h>
+#endif
+#include <time.h> /* For `|struct tm|'. Moved here for Visual Studio 2005. */
+#if HAVE_SYS_STAT_H
+#include <sys/stat.h>
+#endif
+#include <mplib.h>
+#include <mpxout.h>
+#include <kpathsea/kpathsea.h>
+@= /*@@null@@*/ @> static char *mpost_tex_program = NULL;
+static int debug = 0; /* debugging for \.{makempx} */
+static int nokpse = 0;
+static boolean recorder_enabled = false;
+static string recorder_name = NULL;
+static FILE *recorder_file = NULL;
+static char *job_name = NULL;
+static char *job_area = NULL;
+static int dvitomp_only = 0;
+static int ini_version_test = false;
+string output_directory; /* Defaults to |NULL|. */
+static boolean restricted_mode = false;
+
+@<Structures for |getopt|@>@;
+@<Declarations@>@;
+
+@ Allocating a bit of memory, with error detection:
+
+@d mpost_xfree(A) do { if (A!=NULL) free(A); A=NULL; } while (0)
+
+@c
+@= /*@@only@@*/ /*@@out@@*/ @> static void *mpost_xmalloc (size_t bytes) {
+ void *w = malloc (bytes);
+ if (w==NULL) {
+ fprintf(stderr,"Out of memory!\n");
+ exit(EXIT_FAILURE);
+ }
+ return w;
+}
+@= /*@@only@@*/ @> static char *mpost_xstrdup(const char *s) {
+ char *w;
+ w = strdup(s);
+ if (w==NULL) {
+ fprintf(stderr,"Out of memory!\n");
+ exit(EXIT_FAILURE);
+ }
+ return w;
+}
+static char *mpost_itoa (int i) {
+ char res[32] ;
+ unsigned idx = 30;
+ unsigned v = (unsigned)abs(i);
+ memset(res,0,32*sizeof(char));
+ while (v>=10) {
+ char d = (char)(v % 10);
+ v = v / 10;
+ res[idx--] = d + '0';
+ }
+ res[idx--] = (char)v + '0';
+ if (i<0) {
+ res[idx--] = '-';
+ }
+ return mpost_xstrdup(res+idx+1);
+}
+
+
+@ @c
+#ifdef WIN32
+static int
+Isspace (char c)
+{
+ return (c == ' ' || c == '\t');
+}
+#endif
+static void mpost_run_editor (MP mp, char *fname, int fline) {
+ char *temp, *command, *fullcmd, *edit_value;
+ char c;
+ boolean sdone, ddone;
+
+#ifdef WIN32
+ char *fp, *ffp, *env, editorname[256], buffer[256];
+ int cnt = 0;
+ int dontchange = 0;
+#endif
+
+ if (restricted_mode)
+ return;
+
+ sdone = ddone = false;
+ edit_value = kpse_var_value ("MPEDIT");
+ if (edit_value == NULL)
+ edit_value = getenv("EDITOR");
+ if (edit_value == NULL) {
+ fprintf (stderr,"call_edit: can't find a suitable MPEDIT or EDITOR variable\n");
+ exit(mp_status(mp));
+ }
+ command = (string) mpost_xmalloc (strlen (edit_value) + strlen(fname) + 11 + 3);
+ temp = command;
+
+#ifdef WIN32
+ fp = editorname;
+ if ((isalpha(*edit_value) && *(edit_value + 1) == ':'
+ && IS_DIR_SEP (*(edit_value + 2)))
+ || (*edit_value == '"' && isalpha(*(edit_value + 1))
+ && *(edit_value + 2) == ':'
+ && IS_DIR_SEP (*(edit_value + 3)))
+ )
+ dontchange = 1;
+#endif
+
+ while ((c = *edit_value++) != (char)0) {
+ if (c == '%') {
+ switch (c = *edit_value++) {
+ case 'd':
+ if (ddone) {
+ fprintf (stderr,"call_edit: `%%d' appears twice in editor command\n");
+ exit(EXIT_FAILURE);
+ } else {
+ char *s = mpost_itoa(fline);
+ char *ss = s;
+ if (s != NULL) {
+ while (*s != '\0')
+ *temp++ = *s++;
+ free(ss);
+ }
+ ddone = true;
+ }
+ break;
+ case 's':
+ if (sdone) {
+ fprintf (stderr,"call_edit: `%%s' appears twice in editor command\n");
+ exit(EXIT_FAILURE);
+ } else {
+ while (*fname != '\0')
+ *temp++ = *fname++;
+ *temp++ = '.';
+ *temp++ = 'm';
+ *temp++ = 'p';
+ sdone = true;
+ }
+ break;
+ case '\0':
+ *temp++ = '%';
+ /* Back up to the |NULL| to force termination. */
+ edit_value--;
+ break;
+ default:
+ *temp++ = '%';
+ *temp++ = c;
+ break;
+ }
+ } else {
+#ifdef WIN32
+ if (dontchange)
+ *temp++ = c;
+ else { if(Isspace(c) && cnt == 0) {
+ cnt++;
+ temp = command;
+ *temp++ = c;
+ *fp = '\0';
+ } else if(!Isspace(c) && cnt == 0) {
+ *fp++ = c;
+ } else {
+ *temp++ = c;
+ }
+ }
+#else
+ *temp++ = c;
+#endif
+ }
+ }
+ *temp = '\0';
+
+#ifdef WIN32
+ if (dontchange == 0) {
+ if(editorname[0] == '.' ||
+ editorname[0] == '/' ||
+ editorname[0] == '\\') {
+ fprintf(stderr, "%s is not allowed to execute.\n", editorname);
+ exit(EXIT_FAILURE);
+ }
+ env = (char *)getenv("PATH");
+ if(SearchPath(env, editorname, ".exe", 256, buffer, &ffp)==0) {
+ if(SearchPath(env, editorname, ".bat", 256, buffer, &ffp)==0) {
+ fprintf(stderr, "I cannot find %s in the PATH.\n", editorname);
+ exit(EXIT_FAILURE);
+ }
+ }
+ fullcmd = mpost_xmalloc(strlen(buffer)+strlen(command)+5);
+ strcpy(fullcmd, "\"");
+ strcat(fullcmd, buffer);
+ strcat(fullcmd, "\"");
+ strcat(fullcmd, command);
+ } else
+#endif
+ fullcmd = command;
+
+ if (system (fullcmd) != 0)
+ fprintf (stderr, "! Trouble executing `%s'.\n", command);
+ exit(EXIT_FAILURE);
+}
+
+@
+@<Register the callback routines@>=
+options->run_editor = mpost_run_editor;
+
+@
+@c
+static string normalize_quotes (const char *name, const char *mesg) {
+ boolean quoted = false;
+ boolean must_quote = (strchr(name, ' ') != NULL);
+ /* Leave room for quotes and |NULL|. */
+ string ret = (string)mpost_xmalloc(strlen(name)+3);
+ string p;
+ const_string q;
+ p = ret;
+ if (must_quote)
+ *p++ = '"';
+ for (q = name; *q != '\0'; q++) {
+ if (*q == '"')
+ quoted = !quoted;
+ else
+ *p++ = *q;
+ }
+ if (must_quote)
+ *p++ = '"';
+ *p = '\0';
+ if (quoted) {
+ fprintf(stderr, "! Unbalanced quotes in %s %s\n", mesg, name);
+ exit(EXIT_FAILURE);
+ }
+ return ret;
+}
+
+@ Helpers for the filename recorder.
+
+@<Declarations@>=
+void recorder_start(char *jobname);
+
+@ @c
+void recorder_start(char *jobname) {
+ char cwd[1024];
+ if (jobname==NULL) {
+ recorder_name = mpost_xstrdup("mpout.fls");
+ } else {
+ recorder_name = (string)xmalloc((unsigned int)(strlen(jobname)+5));
+ strcpy(recorder_name, jobname);
+ strcat(recorder_name, ".fls");
+ }
+ recorder_file = xfopen(recorder_name, FOPEN_W_MODE);
+
+ if(getcwd(cwd,1020) != NULL) {
+#ifdef WIN32
+ char *p;
+ for (p = cwd; *p; p++) {
+ if (*p == '\\')
+ *p = '/';
+ else if (IS_KANJI(p))
+ p++;
+ }
+#endif
+ fprintf(recorder_file, "PWD %s\n", cwd);
+ } else {
+ fprintf(recorder_file, "PWD <unknown>\n");
+ }
+}
+
+
+@ @c
+@= /*@@null@@*/ @> static char *makempx_find_file (MPX mpx, const char *nam,
+ const char *mode, int ftype) {
+ int fmt;
+ boolean req;
+ (void) mpx;
+ if ((mode[0]=='r' && !kpse_in_name_ok(nam)) ||
+ (mode[0]=='w' && !kpse_out_name_ok(nam)))
+ return NULL; /* disallowed filename */
+ if (mode[0] != 'r') {
+ return strdup(nam);
+ }
+ req = true; fmt = -1;
+ switch(ftype) {
+ case mpx_tfm_format: fmt = kpse_tfm_format; break;
+ case mpx_vf_format: fmt = kpse_vf_format; req = false; break;
+ case mpx_trfontmap_format: fmt = kpse_mpsupport_format; break;
+ case mpx_trcharadj_format: fmt = kpse_mpsupport_format; break;
+ case mpx_desc_format: fmt = kpse_troff_font_format; break;
+ case mpx_fontdesc_format: fmt = kpse_troff_font_format; break;
+ case mpx_specchar_format: fmt = kpse_mpsupport_format; break;
+ }
+ if (fmt<0) return NULL;
+ return kpse_find_file (nam, fmt, req);
+}
+
+@ Invoke \.{makempx} (or \.{troffmpx}) to make sure there is an
+ up-to-date \.{.mpx} file for a given \.{.mp} file. (Original
+ from John Hobby 3/14/90)
+
+@d default_args " --parse-first-line --interaction=nonstopmode"
+@d TEX "tex"
+@d TROFF "soelim | eqn -Tps -d$$ | troff -Tps"
+
+@c
+#ifndef MPXCOMMAND
+#define MPXCOMMAND "makempx"
+#endif
+static int mpost_run_make_mpx (MP mp, char *mpname, char *mpxname) {
+ int ret;
+ char *cnf_cmd = kpse_var_value ("MPXCOMMAND");
+ if (restricted_mode) {
+ /* In the restricted mode, just return success */
+ return 0;
+ }
+ if (cnf_cmd != NULL && (strcmp (cnf_cmd, "0")==0)) {
+ /* If they turned off this feature, just return success. */
+ ret = 0;
+ } else {
+ /* We will invoke something. Compile-time default if nothing else. */
+ char *cmd, *tmp, *qmpname, *qmpxname;
+ if (job_area != NULL) {
+ char *l = mpost_xmalloc(strlen(mpname)+strlen(job_area)+1);
+ strcpy(l, job_area);
+ strcat(l, mpname);
+ tmp = normalize_quotes(l, "mpname");
+ mpost_xfree(l);
+ } else {
+ tmp = normalize_quotes(mpname, "mpname");
+ }
+ if (!kpse_in_name_ok(tmp))
+ return 0; /* disallowed filename */
+ qmpname = kpse_find_file (tmp,kpse_mp_format, true);
+ mpost_xfree(tmp);
+ if (qmpname != NULL && job_area != NULL) {
+ /* if there is a usable mpx file in the source path already,
+ simply use that and return true */
+ char *l = mpost_xmalloc(strlen(qmpname)+2);
+ strcpy(l, qmpname);
+ strcat(l, "x");
+ qmpxname = l;
+ if (qmpxname) {
+#if HAVE_SYS_STAT_H
+ struct stat source_stat, target_stat;
+ int nothingtodo = 0;
+ if ((stat(qmpxname, &target_stat) >= 0) &&
+ (stat(qmpname, &source_stat) >= 0)) {
+#if HAVE_ST_MTIM
+ if (source_stat.st_mtim.tv_sec < target_stat.st_mtim.tv_sec ||
+ (source_stat.st_mtim.tv_sec == target_stat.st_mtim.tv_sec &&
+ source_stat.st_mtim.tv_nsec < target_stat.st_mtim.tv_nsec))
+ nothingtodo = 1;
+#else
+ if (source_stat.st_mtime < target_stat.st_mtime)
+ nothingtodo = 1;
+#endif
+ }
+ if (nothingtodo == 1)
+ return 1; /* success ! */
+#endif
+ }
+ }
+ qmpxname = normalize_quotes(mpxname, "mpxname");
+ if (cnf_cmd!=NULL && (strcmp (cnf_cmd, "1")!=0)) {
+ if (mp_troff_mode(mp)!=0)
+ cmd = concatn (cnf_cmd, " -troff ",
+ qmpname, " ", qmpxname, NULL);
+ else if (mpost_tex_program!=NULL && *mpost_tex_program != '\0')
+ cmd = concatn (cnf_cmd, " -tex=", mpost_tex_program, " ",
+ qmpname, " ", qmpxname, NULL);
+ else
+ cmd = concatn (cnf_cmd, " -tex ", qmpname, " ", qmpxname, NULL);
+
+ /* Run it. */
+ ret = system (cmd);
+ free (cmd);
+ mpost_xfree(qmpname);
+ mpost_xfree(qmpxname);
+ } else {
+ mpx_options * mpxopt;
+ char *s = NULL;
+ char *maincmd = NULL;
+ int mpxmode = mp_troff_mode(mp);
+ char *mpversion = mp_metapost_version () ;
+ mpxopt = mpost_xmalloc(sizeof(mpx_options));
+ if (mpost_tex_program != NULL && *mpost_tex_program != '\0') {
+ maincmd = mpost_xstrdup(mpost_tex_program);
+ } else {
+ if (mpxmode == mpx_tex_mode) {
+ s = kpse_var_value("TEX");
+ if (s==NULL) s = kpse_var_value("MPXMAINCMD");
+ if (s==NULL) s = mpost_xstrdup (TEX);
+ maincmd = (char *)mpost_xmalloc (strlen(s)+strlen(default_args)+1);
+ strcpy(maincmd,s);
+ strcat(maincmd,default_args);
+ free(s);
+ } else {
+ s = kpse_var_value("TROFF");
+ if (s==NULL) s = kpse_var_value("MPXMAINCMD");
+ if (s==NULL) s = mpost_xstrdup (TROFF);
+ maincmd = s;
+ }
+ }
+ mpxopt->mode = mpxmode;
+ mpxopt->cmd = maincmd;
+ mpxopt->mptexpre = kpse_var_value("MPTEXPRE");
+ mpxopt->debug = debug;
+ mpxopt->mpname = qmpname;
+ mpxopt->mpxname = qmpxname;
+ mpxopt->find_file = makempx_find_file;
+ {
+ const char *banner = "% Written by metapost version ";
+ mpxopt->banner = mpost_xmalloc(strlen(mpversion)+strlen(banner)+1);
+ strcpy (mpxopt->banner, banner);
+ strcat (mpxopt->banner, mpversion);
+ }
+ ret = mpx_makempx(mpxopt);
+ mpost_xfree(mpxopt->cmd);
+ mpost_xfree(mpxopt->mptexpre);
+ mpost_xfree(mpxopt->banner);
+ mpost_xfree(mpxopt->mpname);
+ mpost_xfree(mpxopt->mpxname);
+ mpost_xfree(mpxopt);
+ mpost_xfree(mpversion);
+ }
+ }
+
+ mpost_xfree (cnf_cmd);
+ return (int)(ret == 0);
+}
+
+static int mpost_run_dvitomp (char *dviname, char *mpxname) {
+ int ret;
+ size_t i;
+ char *m, *d;
+ mpx_options * mpxopt;
+ char *mpversion = mp_metapost_version () ;
+ mpxopt = mpost_xmalloc(sizeof(mpx_options));
+ memset(mpxopt,0,sizeof(mpx_options));
+ mpxopt->mode = mpx_tex_mode;
+ if (dviname == NULL)
+ return EXIT_FAILURE;
+ i = strlen(dviname);
+ if (mpxname==NULL) {
+ m = mpost_xstrdup(dviname);
+ if (i>4 && *(m+i-4)=='.'
+ && *(m+i-3)=='d' && *(m+i-2)=='v' && *(m+i-1)=='i')
+ *(m+i-4)='\0' ;
+ } else {
+ m = mpost_xstrdup(mpxname);
+ }
+ d = mpost_xstrdup(dviname);
+ if (!(i>4 && *(d+i-4)=='.'
+ && *(d+i-3)=='d' && *(d+i-2)=='v' && *(d+i-1)=='i')) {
+ char *s = malloc (i+5);
+ memset(s,0,i+5);
+ s = strcat(s, d);
+ (void)strcat(s+i-1, ".dvi");
+ mpost_xfree (d);
+ d = s ;
+ }
+
+ i = strlen(m);
+ if (i>4 && *(m+i-4)=='.'
+ && *(m+i-3)=='m' && *(m+i-2)=='p' && *(m+i-1)=='x') {
+ } else {
+ char *s = malloc (i+5);
+ memset(s,0,i+5);
+ s = strcat(s, m);
+ (void)strcat(s+i-1, ".mpx");
+ mpost_xfree (m);
+ m = s ;
+ }
+ if (!(kpse_in_name_ok(d) && kpse_out_name_ok(m)))
+ return EXIT_FAILURE; /* disallowed filename */
+ mpxopt->mpname = d;
+ mpxopt->mpxname = m;
+
+ mpxopt->find_file = makempx_find_file;
+ {
+ const char *banner = "% Written by dvitomp version ";
+ mpxopt->banner = mpost_xmalloc(strlen(mpversion)+strlen(banner)+1);
+ strcpy (mpxopt->banner, banner);
+ strcat (mpxopt->banner, mpversion);
+ }
+ ret = mpx_run_dvitomp(mpxopt);
+ mpost_xfree(mpxopt->banner);
+ mpost_xfree(mpxopt);
+ mpost_xfree(mpversion);
+ puts(""); /* nicer in case of error */
+ return ret;
+}
+
+
+@
+@<Register the callback routines@>=
+if (!nokpse)
+ options->run_make_mpx = mpost_run_make_mpx;
+
+
+@ @c
+static int get_random_seed (void) {
+ int ret = 0;
+#if defined (HAVE_GETTIMEOFDAY)
+ struct timeval tv;
+ gettimeofday(&tv, NULL);
+ ret = (int)(tv.tv_usec + 1000000 * tv.tv_usec);
+#elif defined (HAVE_FTIME)
+ struct timeb tb;
+ ftime(&tb);
+ ret = (tb.millitm + 1000 * tb.time);
+#else
+ time_t clock = time ((time_t*)NULL);
+ struct tm *tmptr = localtime(&clock);
+ if (tmptr!=NULL)
+ ret = (tmptr->tm_sec + 60*(tmptr->tm_min + 60*tmptr->tm_hour));
+#endif
+ return ret;
+}
+
+@ @<Register the callback routines@>=
+options->random_seed = get_random_seed();
+
+
+@ Handle -output-directory.
+
+@c
+static char *mpost_find_in_output_directory(const char *s,const char *fmode)
+{
+ if (output_directory && !kpse_absolute_p(s, false)) {
+ char *ftemp = concat3(output_directory, DIR_SEP_STRING, s);
+ return ftemp;
+ }
+ return NULL;
+}
+
+
+
+@ @c
+static char *mpost_find_file(MP mp, const char *fname, const char *fmode, int ftype) {
+ size_t l ;
+ char *s;
+ char *ofname;
+ (void)mp;
+ s = NULL;
+ ofname = NULL ;
+
+
+ if (fname == NULL || (fmode[0]=='r' && !kpse_in_name_ok(fname)) )
+ return NULL; /* disallowed filename */
+
+
+ if (fmode[0]=='w') {
+ if (output_directory) {
+ ofname = mpost_find_in_output_directory(fname,fmode);
+ if (ofname == NULL || (fmode[0]=='w' && !kpse_out_name_ok(ofname))) {
+ mpost_xfree(ofname);
+ return NULL; /* disallowed filename */
+ }
+ } else {
+ if (!kpse_out_name_ok(fname))
+ return NULL; /* disallowed filename */
+ }
+ }
+
+
+ if (fmode[0]=='r') {
+ if ((job_area != NULL) &&
+ (ftype>=mp_filetype_text || ftype==mp_filetype_program )) {
+ char *f = mpost_xmalloc(strlen(job_area)+strlen(fname)+1);
+ strcpy(f,job_area);
+ strcat(f,fname);
+ if (ftype>=mp_filetype_text) {
+ s = kpse_find_file (f, kpse_mp_format, 0);
+ } else {
+ l = strlen(f);
+ if (l>3 && strcmp(f+l-3,".mf")==0) {
+ s = kpse_find_file (f,kpse_mf_format, 0);
+#if HAVE_SYS_STAT_H
+ } else if (l>4 && strcmp(f+l-4,".mpx")==0) {
+ struct stat source_stat, target_stat;
+ char *mpname = mpost_xstrdup(f);
+ *(mpname + strlen(mpname) -1 ) = '\0';
+ if ((stat(f, &target_stat) >= 0) &&
+ (stat(mpname, &source_stat) >= 0)) {
+#if HAVE_ST_MTIM
+ if (source_stat.st_mtim.tv_sec <= target_stat.st_mtim.tv_sec ||
+ (source_stat.st_mtim.tv_sec == target_stat.st_mtim.tv_sec &&
+ source_stat.st_mtim.tv_nsec <= target_stat.st_mtim.tv_nsec))
+ s = mpost_xstrdup(f);
+#else
+ if (source_stat.st_mtime <= target_stat.st_mtime)
+ s = mpost_xstrdup(f);
+#endif
+ }
+ mpost_xfree(mpname);
+#endif
+ } else {
+ s = kpse_find_file (f,kpse_mp_format, 0);
+ }
+ }
+ mpost_xfree(f);
+ if (s!=NULL) {
+ return s;
+ }
+ }
+ if (ftype>=mp_filetype_text) {
+ s = kpse_find_file (fname, kpse_mp_format, 0);
+ } else {
+ switch(ftype) {
+ case mp_filetype_program:
+ l = strlen(fname);
+ if (l>3 && strcmp(fname+l-3,".mf")==0) {
+ s = kpse_find_file (fname, kpse_mf_format, 0);
+ } else {
+ s = kpse_find_file (fname, kpse_mp_format, 0);
+ }
+ break;
+ case mp_filetype_memfile:
+ s = kpse_find_file (fname, kpse_mem_format, 1);
+ break;
+ case mp_filetype_metrics:
+ s = kpse_find_file (fname, kpse_tfm_format, 0);
+ break;
+ case mp_filetype_fontmap:
+ s = kpse_find_file (fname, kpse_fontmap_format, 0);
+ break;
+ case mp_filetype_font:
+ s = kpse_find_file (fname, kpse_type1_format, 0);
+ break;
+ case mp_filetype_encoding:
+ s = kpse_find_file (fname, kpse_enc_format, 0);
+ break;
+ }
+ }
+ } else {
+ /* when writing */
+ if (ofname) {
+ s = mpost_xstrdup(ofname);
+ mpost_xfree(ofname);
+ } else {
+ s = mpost_xstrdup(fname);
+ }
+
+ }
+ return s;
+}
+
+@ @<Register the callback routines@>=
+if (!nokpse)
+ options->find_file = mpost_find_file;
+
+@ The |mpost| program supports setting of internal values
+via a \.{-s} commandline switch. Since this switch is repeatable,
+a structure is needed to store the found values in, which is a
+simple linked list.
+
+@c
+typedef struct set_list_item {
+ int isstring;
+ char *name;
+ char *value;
+ struct set_list_item *next;
+} set_list_item ;
+
+@ Here is the global value that is the head of the list of \.{-s} options.
+@c
+struct set_list_item *set_list = NULL;
+
+@ And |internal_set_option| is the routine that fills in the linked
+list. The argument it receives starts at the first letter of the
+internal, and should contain an internal name, an equals sign,
+and the value (possibly in quotes) without any intervening spaces.
+
+Double quotes around the right hand side are needed to make sure that
+the right hand side is treated as a string assignment by MPlib later.
+These outer double quote characters are stripped, but no other string
+processing takes place.
+
+As a special hidden feature, a missing right hand side is treated as if it
+was the integer value |1|.
+
+@<Declarations@>=
+void internal_set_option(const char *opt);
+
+@ @c
+void internal_set_option(const char *opt) {
+ struct set_list_item *itm;
+ char *s, *v;
+ int isstring = 0;
+ s = mpost_xstrdup(opt) ;
+ v = strstr(s,"=") ;
+ if (v==NULL) {
+ v = xstrdup("1");
+ } else {
+ *v='\0'; /* terminates |s| */
+ v++;
+ if (*v && *v=='"') {
+ isstring=1;
+ v++;
+ *(v+strlen(v)-1)= '\0';
+ }
+ }
+ if (s && v && strlen(s)>0) {
+ if (set_list == NULL) {
+ set_list = xmalloc(sizeof(struct set_list_item));
+ itm = set_list;
+ } else {
+ itm = set_list;
+ while (itm->next != NULL)
+ itm = itm->next;
+ itm->next = xmalloc(sizeof(struct set_list_item));
+ itm = itm->next;
+ }
+ itm->name = s;
+ itm->value = v;
+ itm->isstring = isstring;
+ itm->next = NULL;
+ }
+}
+
+@ After the initialization stage is done, the next function
+runs through the list of options and feeds them to the MPlib
+function |mp_set_internal|.
+
+@<Declarations@>=
+void run_set_list (MP mp);
+
+@ @c
+void run_set_list (MP mp) {
+ struct set_list_item *itm;
+ itm = set_list;
+ while (itm!=NULL) {
+ mp_set_internal(mp,itm->name,itm->value, itm->isstring);
+ itm = itm->next;
+ }
+}
+
+
+
+@ @c
+static void *mpost_open_file(MP mp, const char *fname, const char *fmode, int ftype) {
+ char realmode[3];
+ char *s;
+ if (ftype==mp_filetype_terminal) {
+ return (fmode[0] == 'r' ? stdin : stdout);
+ } else if (ftype==mp_filetype_error) {
+ return stderr;
+ } else {
+ s = mpost_find_file (mp, fname, fmode, ftype);
+ if (s!=NULL) {
+ void *ret = NULL;
+ realmode[0] = *fmode;
+ realmode[1] = 'b';
+ realmode[2] = '\0';
+ ret = (void *)fopen(s,realmode);
+ if (recorder_enabled) {
+ if (!recorder_file)
+ recorder_start(job_name);
+ if (*fmode == 'r')
+ fprintf(recorder_file, "INPUT %s\n", s);
+ else
+ fprintf(recorder_file, "OUTPUT %s\n", s);
+ }
+ free(s);
+ return ret;
+ }
+ }
+ return NULL;
+}
+
+@ @<Register the callback routines@>=
+if (!nokpse)
+ options->open_file = mpost_open_file;
+
+@ @d ARGUMENT_IS(a) STREQ (mpost_options[optionid].name, a)
+@<Structures for |getopt|@>=
+
+/* SunOS cc can't initialize automatic structs, so make this static. */
+static struct option mpost_options[]
+ = { { "mem", 1, 0, 0 },
+ { "help", 0, 0, 0 },
+ { "debug", 0, &debug, 1 },
+ { "no-kpathsea", 0, &nokpse, 1 },
+ { "dvitomp", 0, &dvitomp_only, 1 },
+ { "ini", 0, &ini_version_test, 1 },
+ { "interaction", 1, 0, 0 },
+ { "math", 1, 0, 0 },
+ { "numbersystem", 1, 0, 0 },
+ { "halt-on-error", 0, 0, 0 },
+ { "kpathsea-debug", 1, 0, 0 },
+ { "progname", 1, 0, 0 },
+ { "version", 0, 0, 0 },
+ { "recorder", 0, &recorder_enabled, 1 },
+ { "restricted", 0, 0, 0 },
+ { "file-line-error-style", 0, 0, 0 },
+ { "no-file-line-error-style", 0, 0, 0 },
+ { "file-line-error", 0, 0, 0 },
+ { "no-file-line-error", 0, 0, 0 },
+ { "jobname", 1, 0, 0 },
+ { "output-directory", 1, 0, 0 },
+ { "s", 1, 0, 0 },
+ { "parse-first-line", 0, 0, 0 },
+ { "no-parse-first-line", 0, 0, 0 },
+ { "8bit", 0, 0, 0 },
+ { "T", 0, 0, 0 },
+ { "troff", 0, 0, 0 },
+ { "tex", 1, 0, 0 },
+ { 0, 0, 0, 0 } };
+
+
+
+@ Parsing the commandline options.
+
+@<Read and set command line options@>=
+{
+ int g; /* `|getopt|' return code. */
+ int optionid;
+ for (;;) {
+ g = getopt_long_only (argc, argv, "+", mpost_options, &optionid);
+
+ if (g == -1) /* End of arguments, exit the loop. */
+ break;
+
+ if (g == '?') { /* Unknown option. */
+ exit(EXIT_FAILURE);
+ }
+
+ if (ARGUMENT_IS ("kpathsea-debug")) {
+ kpathsea_debug |= (unsigned)atoi (optarg);
+
+ } else if (ARGUMENT_IS("jobname")) {
+ if (optarg!=NULL) {
+ mpost_xfree(options->job_name);
+ options->job_name = mpost_xstrdup(optarg);
+ }
+
+ } else if (ARGUMENT_IS ("progname")) {
+ user_progname = optarg;
+
+ } else if (ARGUMENT_IS ("mem")) {
+ if (optarg!=NULL) {
+ mpost_xfree(options->mem_name);
+ options->mem_name = mpost_xstrdup(optarg);
+ if (user_progname == NULL)
+ user_progname = optarg;
+ }
+
+ } else if (ARGUMENT_IS ("interaction")) {
+ if (STREQ (optarg, "batchmode")) {
+ options->interaction = mp_batch_mode;
+ } else if (STREQ (optarg, "nonstopmode")) {
+ options->interaction = mp_nonstop_mode;
+ } else if (STREQ (optarg, "scrollmode")) {
+ options->interaction = mp_scroll_mode;
+ } else if (STREQ (optarg, "errorstopmode")) {
+ options->interaction = mp_error_stop_mode;
+ } else {
+ fprintf(stdout,"Ignoring unknown argument `%s' to --interaction\n", optarg);
+ }
+ } else if (ARGUMENT_IS ("math") || ARGUMENT_IS ("numbersystem")) {
+ if (STREQ (optarg, "scaled")) {
+ options->math_mode = mp_math_scaled_mode;
+ internal_set_option("numbersystem=\"scaled\"");
+ } else if (STREQ (optarg, "double")) {
+ options->math_mode = mp_math_double_mode;
+ internal_set_option("numbersystem=\"double\"");
+ } else if (STREQ (optarg, "decimal")) {
+ options->math_mode = mp_math_decimal_mode;
+ internal_set_option("numbersystem=\"decimal\"");
+ } else if (STREQ (optarg, "binary")) {
+ options->math_mode = mp_math_binary_mode;
+ internal_set_option("numbersystem=\"binary\"");
+ } else {
+ fprintf(stdout,"Ignoring unknown argument `%s' to --numbersystem\n", optarg);
+ }
+ } else if (ARGUMENT_IS ("restricted")) {
+ restricted_mode = true;
+ mpost_tex_program = NULL;
+ } else if (ARGUMENT_IS("troff") ||
+ ARGUMENT_IS("T")) {
+ options->troff_mode = (int)true;
+ } else if (ARGUMENT_IS ("tex")) {
+ if (!restricted_mode)
+ mpost_tex_program = optarg;
+ } else if (ARGUMENT_IS("file-line-error") ||
+ ARGUMENT_IS("file-line-error-style")) {
+ options->file_line_error_style=true;
+ } else if (ARGUMENT_IS("no-file-line-error") ||
+ ARGUMENT_IS("no-file-line-error-style")) {
+ options->file_line_error_style=false;
+ } else if (ARGUMENT_IS("help")) {
+ if (dvitomp_only) {
+ @<Show short help and exit@>;
+ } else {
+ @<Show help and exit@>;
+ }
+ } else if (ARGUMENT_IS("version")) {
+ @<Show version and exit@>;
+ } else if (ARGUMENT_IS("s")) {
+ if (strchr(optarg,'=')==NULL) {
+ fprintf(stdout,"fatal error: %s: missing -s argument\n", argv[0]);
+ exit (EXIT_FAILURE);
+ } else {
+ internal_set_option(optarg);
+ }
+ } else if (ARGUMENT_IS("halt-on-error")) {
+ options->halt_on_error = true;
+ } else if (ARGUMENT_IS("output-directory")) {
+ output_directory = optarg ;
+ } else if (ARGUMENT_IS("8bit") ||
+ ARGUMENT_IS("parse-first-line")) {
+ /* do nothing, these are always on */
+ } else if (ARGUMENT_IS("translate-file") ||
+ ARGUMENT_IS("no-parse-first-line")) {
+ fprintf(stdout,"warning: %s: unimplemented option %s\n", argv[0], argv[optind]);
+ }
+ }
+ options->ini_version = (int)ini_version_test;
+}
+
+@ @d option_is(a) STREQ (dvitomp_options[optionid].name, a)
+@<Structures for |getopt|@>=
+
+/* SunOS cc can't initialize automatic structs, so make this static. */
+static struct option dvitomp_options[]
+ = { { "help", 0, 0, 0 },
+ { "no-kpathsea", 0, &nokpse, 1 },
+ { "kpathsea-debug", 1, 0, 0 },
+ { "progname", 1, 0, 0 },
+ { "version", 0, 0, 0 },
+ { 0, 0, 0, 0 } };
+
+
+
+@
+@<Read and set \.{dvitomp} command line options@>=
+{
+ int g; /* `|getopt|' return code. */
+ int optionid;
+ for (;;) {
+ g = getopt_long_only (argc, argv, "+", dvitomp_options, &optionid);
+
+ if (g == -1) /* End of arguments, exit the loop. */
+ break;
+
+ if (g == '?') { /* Unknown option. */
+ fprintf(stdout,"fatal error: %s: unknown option %s\n", argv[0], argv[optind]);
+ exit(EXIT_FAILURE);
+ }
+ if (option_is ("kpathsea-debug")) {
+ if (optarg!=NULL)
+ kpathsea_debug |= (unsigned)atoi (optarg);
+ } else if (option_is ("progname")) {
+ user_progname = optarg;
+ } else if (option_is("help")) {
+ @<Show short help and exit@>;
+ } else if (option_is("version")) {
+ @<Show version and exit@>;
+ }
+ }
+}
+
+@
+@<Show help...@>=
+{
+char *s = mp_metapost_version();
+if (dvitomp_only)
+ fprintf(stdout, "This is dvitomp %s" WEB2CVERSION " (%s)\n", s, kpathsea_version_string);
+else
+ fprintf(stdout, "This is MetaPost %s" WEB2CVERSION " (%s)\n", s, kpathsea_version_string);
+mpost_xfree(s);
+fprintf(stdout,
+"\n"
+"Usage: mpost [OPTION] [&MEMNAME] [MPNAME[.mp]] [COMMANDS]\n"
+" mpost --dvitomp DVINAME[.dvi] [MPXNAME[.mpx]]\n"
+"\n"
+" Run MetaPost on MPNAME, usually creating MPNAME.NNN (and perhaps\n"
+" MPNAME.tfm), where NNN are the character numbers generated.\n"
+" Any remaining COMMANDS are processed as MetaPost input,\n"
+" after MPNAME is read.\n\n"
+" With a --dvitomp argument, MetaPost acts as DVI-to-MPX converter only.\n"
+" Call MetaPost with --dvitomp --help for option explanations.\n\n");
+fprintf(stdout,
+" -ini be inimpost, for dumping mem files\n"
+" -interaction=STRING set interaction mode (STRING=batchmode/nonstopmode/\n"
+" scrollmode/errorstopmode)\n"
+" -numbersystem=STRING set number system mode (STRING=scaled/double/binary/decimal)\n"
+" -jobname=STRING set the job name to STRING\n"
+" -progname=STRING set program (and mem) name to STRING\n"
+" -tex=TEXPROGRAM use TEXPROGRAM for text labels\n"
+" [-no]-file-line-error disable/enable file:line:error style messages\n"
+);
+fprintf(stdout,
+" -debug print debugging info and leave temporary files in place\n"
+" -kpathsea-debug=NUMBER set path searching debugging flags according to\n"
+" the bits of NUMBER\n"
+" -mem=MEMNAME or &MEMNAME use MEMNAME instead of program name or a %%& line\n"
+" -recorder enable filename recorder\n"
+" -restricted be secure: disable tex, makempx and editor commands\n"
+" -troff set prologues:=1 and assume TEXPROGRAM is really troff\n"
+" -T same as -troff\n"
+" -s INTERNAL=\"STRING\" set internal INTERNAL to the string value STRING\n"
+" -s INTERNAL=NUMBER set internal INTERNAL to the integer value NUMBER\n"
+" -help display this help and exit\n"
+" -version output version information and exit\n"
+"\n"
+"Email bug reports to mp-implementors@@tug.org.\n"
+"\n");
+ exit(EXIT_SUCCESS);
+}
+
+@
+@<Show short help...@>=
+{
+char *s = mp_metapost_version();
+if (dvitomp_only)
+ fprintf(stdout, "This is dvitomp %s" WEB2CVERSION " (%s)\n", s, kpathsea_version_string);
+else
+ fprintf(stdout, "This is MetaPost %s" WEB2CVERSION " (%s)\n", s, kpathsea_version_string);
+mpost_xfree(s);
+fprintf(stdout,
+"\n"
+"Usage: dvitomp DVINAME[.dvi] [MPXNAME[.mpx]]\n"
+" mpost --dvitomp DVINAME[.dvi] [MPXNAME[.mpx]]\n"
+"\n"
+" Convert a TeX DVI file to a MetaPost MPX file.\n\n");
+fprintf(stdout,
+" -progname=STRING set program name to STRING\n"
+" -kpathsea-debug=NUMBER set path searching debugging flags according to\n"
+" the bits of NUMBER\n"
+" -help display this help and exit\n"
+" -version output version information and exit\n"
+"\n"
+"Email bug reports to mp-implementors@@tug.org.\n"
+"\n");
+ exit(EXIT_SUCCESS);
+}
+
+@
+@<Show version...@>=
+{
+ char *s = mp_metapost_version();
+if (dvitomp_only)
+ fprintf(stdout, "dvitomp (MetaPost) %s" WEB2CVERSION " (%s)\n", s, kpathsea_version_string);
+else
+ fprintf(stdout, "MetaPost %s" WEB2CVERSION " (%s)\n", s, kpathsea_version_string);
+fprintf(stdout,
+"The MetaPost source code in the public domain.\n"
+"MetaPost also uses code available under the\n"
+"GNU Lesser General Public License (version 3 or later);\n"
+"therefore MetaPost executables are covered by the LGPL.\n"
+"There is NO warranty.\n"
+"For more information about these matters, see the file\n"
+"COPYING.LESSER or <http://gnu.org/licenses/lgpl.html>.\n"
+"Original author of MetaPost: John Hobby.\n"
+"Author of the CWEB MetaPost: Taco Hoekwater.\n"
+"Current maintainer of MetaPost: Luigi Scarso.\n\n"
+);
+ mpost_xfree(s);
+ if (!dvitomp_only) {
+ mp_show_library_versions();
+ }
+ exit(EXIT_SUCCESS);
+}
+
+@ The final part of the command line, after option processing, is
+stored in the \MP\ instance, this will be taken as the first line of
+input.
+
+@d command_line_size 256
+@d max_command_line_size 0xFFFFFFF /* should be the same of |max_halfword| (see |mp_reallocate_buffer|) */
+
+@<Copy the rest of the command line@>=
+{
+ mpost_xfree(options->command_line);
+ options->command_line = mpost_xmalloc(command_line_size);
+ strcpy(options->command_line,"");
+ if (optind<argc) {
+ int optind_aux = optind;
+ size_t buflen = 0;
+ for(;optind_aux<argc;optind_aux++) {
+ buflen +=(strlen(argv[optind_aux])+1); /* reserve space for |' '| as separator */
+ }
+ /* Last char is |' '|, no need to reserve space for final |'\0'| */
+ if (buflen > max_command_line_size) {
+ fprintf(stderr,"length of command line too long!\n");
+ exit(EXIT_FAILURE);
+ }
+ mpost_xfree(options->command_line);
+ options->command_line = mpost_xmalloc(buflen);
+ k=0;
+ for(;optind<argc;optind++) {
+ char *c = argv[optind];
+ while (*c != '\0') {
+ options->command_line[k++] = *c;
+ c++;
+ }
+ options->command_line[k++] = ' ';
+ }
+ while (k>0) {
+ if (options->command_line[(k-1)] == ' ')
+ k--;
+ else
+ break;
+ }
+ options->command_line[k] = '\0';
+ }
+}
+
+@ A simple function to get numerical \.{texmf.cnf} values
+@c
+static int setup_var (int def, const char *var_name, boolean nokpse) {
+ if (!nokpse) {
+ char * expansion = kpse_var_value (var_name);
+ if (expansion) {
+ int conf_val = atoi (expansion);
+ free (expansion);
+ if (conf_val > 0) {
+ return conf_val;
+ }
+ }
+ }
+ return def;
+}
+
+@ @<Set up the banner line@>=
+{
+ char * mpversion = mp_metapost_version () ;
+ const char * banner = "This is MetaPost, version ";
+ const char * kpsebanner_start = " (";
+ const char * kpsebanner_stop = ")";
+ mpost_xfree(options->banner);
+ options->banner = mpost_xmalloc(strlen(banner)+
+ strlen(mpversion)+
+ strlen(WEB2CVERSION)+
+ strlen(kpsebanner_start)+
+ strlen(kpathsea_version_string)+
+ strlen(kpsebanner_stop)+1);
+ strcpy (options->banner, banner);
+ strcat (options->banner, mpversion);
+ strcat (options->banner, WEB2CVERSION);
+ strcat (options->banner, kpsebanner_start);
+ strcat (options->banner, kpathsea_version_string);
+ strcat (options->banner, kpsebanner_stop);
+ mpost_xfree(mpversion);
+}
+
+@ Precedence order is:
+
+\item {} \.{-mem=MEMNAME} on the command line
+\item {} \.{\&MEMNAME} on the command line
+\item {} \.{\%\&MEM} as first line inside input file
+\item {} \.{argv[0]} if all else fails
+
+@<Discover the mem name@>=
+{
+ char *m = NULL; /* head of potential |mem_name| */
+ char *n = NULL; /* a moving pointer */
+ if (options->command_line != NULL && *(options->command_line) == '&'){
+ m = mpost_xstrdup(options->command_line+1);
+ n = m;
+ while (*n != '\0' && *n != ' ') n++;
+ while (*n == ' ') n++;
+ if (*n != '\0') { /* more command line to follow */
+ char *s = mpost_xstrdup(n);
+ if (n>m) n--;
+ while (*n == ' ' && n>m) n--;
+ n++;
+ *n ='\0'; /* this terminates |m| */
+ mpost_xfree(options->command_line);
+ options->command_line = s;
+ } else { /* only \.{\&MEMNAME} on command line */
+ if (n>m) n--;
+ while (*n == ' ' && n>m) n--;
+ n++;
+ *n ='\0'; /* this terminates |m| */
+ mpost_xfree(options->command_line);
+ }
+ if ( options->mem_name == NULL && *m != '\0') {
+ mpost_xfree(options->mem_name); /* for lint only */
+ options->mem_name = m;
+ } else {
+ mpost_xfree(m);
+ }
+ }
+}
+if ( options->mem_name == NULL ) {
+ char *m = NULL; /* head of potential |job_name| */
+ char *n = NULL; /* a moving pointer */
+ if (options->command_line != NULL && *(options->command_line) != '\\'){
+ m = mpost_xstrdup(options->command_line);
+ n = m;
+ while (*n != '\0' && *n != ' ') n++;
+ if (n>m) {
+ char *fname;
+ *n='\0';
+ fname = m;
+ if (!nokpse)
+ fname = kpse_find_file(m,kpse_mp_format,true);
+ if (fname == NULL) {
+ mpost_xfree(m);
+ } else {
+ FILE *F = fopen(fname,"r");
+ if (F==NULL) {
+ mpost_xfree(fname);
+ } else {
+ char *line = mpost_xmalloc(256);
+ if (fgets(line,255,F) == NULL) {
+ (void)fclose(F);
+ mpost_xfree(fname);
+ mpost_xfree(line);
+ } else {
+ (void)fclose(F);
+ while (*line != '\0' && *line == ' ') line++;
+ if (*line == '%') {
+ n = m = line+1;
+ while (*n != '\0' && *n == ' ') n++;
+ if (*n == '&') {
+ m = n+1;
+ while (*n != '\0' && *n != ' ') n++;
+ if (n>(m+1)) {
+ n--;
+ while (*n == ' ' && n>m) n--;
+ *n ='\0'; /* this terminates |m| */
+ options->mem_name = mpost_xstrdup(m);
+ mpost_xfree(fname);
+ } else {
+ mpost_xfree(fname);
+ mpost_xfree(line);
+ }
+ }
+ }
+ }
+ }
+ }
+ } else {
+ mpost_xfree(m);
+ }
+ }
+}
+if ( options->mem_name == NULL )
+ if (kpse_program_name!=NULL)
+ options->mem_name = mpost_xstrdup(kpse_program_name);
+
+
+@ The job name needs to be known for the recorder to work,
+so we have to fix up |job_name| and |job_area|. If there
+was a \.{--jobname} on the command line, we have to reset
+the options structure as well.
+
+@<Discover the job name@>=
+{
+char *tmp_job = NULL;
+if (options->job_name != NULL) {
+ tmp_job = mpost_xstrdup(options->job_name);
+ mpost_xfree(options->job_name);
+ options->job_name = NULL;
+} else {
+ char *m = NULL; /* head of potential |job_name| */
+ char *n = NULL; /* a moving pointer */
+ if (options->command_line != NULL){
+ m = mpost_xstrdup(options->command_line);
+ n = m;
+ if (*(options->command_line) != '\\') { /* this is the simple case */
+ while (*n != '\0' && *n != ' ') n++;
+ if (n>m) {
+ *n='\0';
+ tmp_job = mpost_xstrdup(m);
+ }
+ } else { /* this is still not perfect, but better */
+ char *mm = strstr(m,"input ");
+ if (mm != NULL) {
+ mm += 6;
+ n = mm;
+ while (*n != '\0' && *n != ' ' && *n!=';') n++;
+ if (n>mm) {
+ *n='\0';
+ tmp_job = mpost_xstrdup(mm);
+ }
+ }
+ }
+ free(m);
+ }
+ if (tmp_job == NULL) {
+ if (options->ini_version == 1 &&
+ options->mem_name != NULL) {
+ tmp_job = mpost_xstrdup(options->mem_name);
+ }
+ }
+ if (tmp_job == NULL) {
+ tmp_job = mpost_xstrdup("mpout");
+ } else {
+ char *ext = strrchr(tmp_job,'.');
+ if (ext != NULL)
+ *ext = '\0';
+ }
+}
+/* now split |tmp_job| into |job_area| and |job_name| */
+{
+ char *s = tmp_job + strlen(tmp_job);
+ if (!IS_DIR_SEP(*s)) { /* just in case */
+ while (s>tmp_job) {
+ if (IS_DIR_SEP(*s)) {
+ break;
+ }
+ s--;
+ }
+ if (s>tmp_job) {
+ /* there was a directory part */
+ if (strlen(s)>1) {
+ job_name = mpost_xstrdup((s+1));
+ *(s+1) = '\0';
+ job_area = tmp_job;
+ }
+ } else {
+ job_name = tmp_job;
+ /* |job_area| stays |NULL| */
+ }
+ }
+}
+}
+options->job_name = job_name;
+
+@ We |
+#define DLLPROC dllmpostmain
+| in order to build \MP\ as DLL for W32\TeX.
+
+@<Declarations@>=
+#define DLLPROC dllmpostmain
+#if defined(WIN32) && !defined(__MINGW32__) && defined(DLLPROC)
+extern __declspec(dllexport) int DLLPROC (int argc, char **argv);
+#else
+#undef DLLPROC
+#endif
+
+@ Now this is really it: \MP\ starts and ends here.
+
+@c
+static char *cleaned_invocation_name(char *arg)
+{
+ char *ret, *dot;
+ const char *start = xbasename(arg);
+ ret = xstrdup(start);
+ dot = strrchr(ret, '.');
+ if (dot != NULL) {
+ *dot = 0; /* chop */
+ }
+ return ret;
+}
+int
+#if defined(DLLPROC)
+DLLPROC (int argc, char **argv)
+#else
+main (int argc, char **argv)
+#endif
+@;
+{ @t\1@> /* |start_here| */
+ int k; /* index into buffer */
+ int history; /* the exit status */
+ MP mp; /* a metapost instance */
+ struct MP_options * options; /* instance options */
+ char *user_progname = NULL; /* If the user overrides |argv[0]| with \.{-progname}. */
+ options = mp_options();
+ options->ini_version = (int)false;
+ options->print_found_names = (int)true;
+ {
+ const char *base = cleaned_invocation_name(argv[0]);
+ if (FILESTRCASEEQ(base, "rmpost")){
+ base++;
+ restricted_mode = true;
+ } else if (FILESTRCASEEQ(base, "r-mpost")){
+ base += 2;
+ restricted_mode = true;
+ }
+ if (FILESTRCASEEQ(base, "dvitomp"))
+ dvitomp_only=1;
+ }
+ if (dvitomp_only) {
+ @<Read and set \.{dvitomp} command line options@>;
+ } else {
+ @<Read and set command line options@>;
+ }
+ if (dvitomp_only) {
+ char *mpx = NULL, *dvi = NULL;
+ if (optind>=argc) {
+ /* error ? */
+ } else {
+ dvi = argv[optind++];
+ if (optind<argc) {
+ mpx = argv[optind++];
+ }
+ }
+ if (dvi == NULL) {
+ @<Show short help and exit@>;
+ } else {
+ if (!nokpse)
+ kpse_set_program_name(argv[0],
+ user_progname ? user_progname : "dvitomp");
+ exit (mpost_run_dvitomp(dvi, mpx));
+ }
+ }
+
+ @= /*@@-nullpass@@*/ @>
+ if (!nokpse) {
+ kpse_set_program_enabled (kpse_mem_format, MAKE_TEX_FMT_BY_DEFAULT,
+ kpse_src_compile);
+ kpse_set_program_name(argv[0], user_progname);
+ if (FILESTRCASEEQ(kpse_program_name, "rmpost"))
+ kpse_program_name++;
+ else if (FILESTRCASEEQ(kpse_program_name, "r-mpost"))
+ kpse_program_name += 2;
+ }
+ @= /*@@=nullpass@@*/ @>
+ if(putenv(xstrdup("engine=metapost")))
+ fprintf(stdout,"warning: could not set up $engine\n");
+ options->error_line = setup_var (79,"error_line",nokpse);
+ options->half_error_line = setup_var (50,"half_error_line",nokpse);
+ options->max_print_line = setup_var (100,"max_print_line",nokpse);
+ @<Set up the banner line@>;
+ @<Copy the rest of the command line@>;
+ @<Discover the mem name@>;
+ @<Discover the job name@>;
+ @<Register the callback routines@>;
+ mp = mp_initialize(options);
+ mpost_xfree(options->command_line);
+ mpost_xfree(options->mem_name);
+ mpost_xfree(options->job_name);
+ mpost_xfree(options->banner);
+ free(options);
+ if (mp==NULL)
+ exit(EXIT_FAILURE);
+ history = mp_status(mp);
+ if (history!=0 && history!=mp_warning_issued)
+ exit(history);
+ if (set_list!=NULL) {
+ run_set_list(mp);
+ }
+ history = mp_run(mp);
+ (void)mp_finish(mp);
+ if (history!=0 && history!=mp_warning_issued)
+ exit(history);
+ else
+ exit(0);
+@t\8@>
+}
+
+@* Index.
diff --git a/Build/source/texk/web2c/mplibdir/mpstrings.w b/Build/source/texk/web2c/mplibdir/mpstrings.w
new file mode 100644
index 00000000000..25dcf91b182
--- /dev/null
+++ b/Build/source/texk/web2c/mplibdir/mpstrings.w
@@ -0,0 +1,447 @@
+% This file is part of MetaPost;
+% the MetaPost program is in the public domain.
+% See the <Show version...> code in mpost.w for more info.
+
+\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\pct!{{\char`\%}} % percent sign in ordinary text
+\def\psqrt#1{\sqrt{\mathstrut#1}}
+
+
+@* String handling.
+
+
+@ First, we will need some stuff from other files.
+@c
+#include <w2c/config.h>
+#include <stdio.h>
+#include <stdlib.h>
+#include <string.h>
+#include <stdarg.h>
+#include <assert.h>
+#ifdef HAVE_UNISTD_H
+# include <unistd.h> /* for access */
+#endif
+#include <time.h> /* for struct tm \& co */
+#include "mpstrings.h" /* internal header */
+
+@ Then there is some stuff we need to prepare ourselves.
+
+@(mpstrings.h@>=
+#ifndef MPSTRINGS_H
+#define MPSTRINGS_H 1
+#include "mplib.h"
+#include "mplibps.h" /* external header */
+#include "mplibsvg.h" /* external header */
+#include "mpmp.h" /* internal header */
+#include "mppsout.h" /* internal header */
+#include "mpsvgout.h" /* internal header */
+#include "mpmath.h" /* internal header */
+@<Definitions@>;
+#endif
+
+@ Here are the functions needed for the avl construction.
+
+@<Definitions@>=
+void *copy_strings_entry (const void *p);
+
+@ An earlier version of this function used |strncmp|, but that produces
+wrong results in some cases.
+@c
+#define STRCMP_RESULT(a) ((a)<0 ? -1 : ((a)>0 ? 1 : 0))
+static int comp_strings_entry (void *p, const void *pa, const void *pb) {
+ const mp_lstring *a = (const mp_lstring *) pa;
+ const mp_lstring *b = (const mp_lstring *) pb;
+ size_t l;
+ unsigned char *s,*t;
+ (void) p;
+ s = a->str;
+ t = b->str;
+ l = (a->len<=b->len ? a->len : b->len);
+ while ( l-->0 ) {
+ if ( *s!=*t)
+ return STRCMP_RESULT(*s-*t);
+ s++; t++;
+ }
+ return STRCMP_RESULT((int)(a->len-b->len));
+}
+void *copy_strings_entry (const void *p) {
+ mp_string ff;
+ const mp_lstring *fp;
+ fp = (const mp_lstring *) p;
+ ff = malloc (sizeof (mp_lstring));
+ if (ff == NULL)
+ return NULL;
+ ff->str = malloc (fp->len + 1);
+ if (ff->str == NULL) {
+ return NULL;
+ }
+ memcpy ((char *) ff->str, (char *) fp->str, fp->len + 1);
+ ff->len = fp->len;
+ ff->refs = 0;
+ return ff;
+}
+static void *delete_strings_entry (void *p) {
+ mp_string ff = (mp_string) p;
+ mp_xfree (ff->str);
+ mp_xfree (ff);
+ return NULL;
+}
+
+@ Actually creating strings is done by |make_string|, but in order to
+do so it needs a way to create a new, empty string structure.
+
+@ @c
+static mp_string new_strings_entry (MP mp) {
+ mp_string ff;
+ ff = mp_xmalloc (mp, 1, sizeof (mp_lstring));
+ ff->str = NULL;
+ ff->len = 0;
+ ff->refs = 0;
+ return ff;
+}
+
+
+@ Some even more low-level functions are these:
+
+@<Definitions@>=
+extern int mp_xstrcmp (const char *a, const char *b);
+extern char *mp_xstrdup (MP mp, const char *s);
+extern char *mp_xstrldup (MP mp, const char *s, size_t l);
+extern char *mp_strdup (const char *p);
+extern char *mp_strldup (const char *p, size_t l);
+
+@ @c
+char *mp_strldup (const char *p, size_t l) {
+ char *r, *s;
+ if (p == NULL)
+ return NULL;
+ r = malloc ((size_t) (l * sizeof (char) + 1));
+ if (r == NULL)
+ return NULL;
+ s = memcpy (r, p, (size_t) (l));
+ *(s + l) = '\0';
+ return s;
+}
+char *mp_strdup (const char *p) {
+ if (p == NULL)
+ return NULL;
+ return mp_strldup (p, strlen (p));
+}
+
+@ @c
+int mp_xstrcmp (const char *a, const char *b) {
+ if (a == NULL && b == NULL)
+ return 0;
+ if (a == NULL)
+ return -1;
+ if (b == NULL)
+ return 1;
+ return strcmp (a, b);
+}
+char *mp_xstrldup (MP mp, const char *s, size_t l) {
+ char *w;
+ if (s == NULL)
+ return NULL;
+ w = mp_strldup (s, l);
+ if (w == NULL) {
+ mp_fputs ("Out of memory!\n", mp->err_out);
+ mp->history = mp_system_error_stop;
+ mp_jump_out (mp);
+ }
+ return w;
+}
+char *mp_xstrdup (MP mp, const char *s) {
+ if (s == NULL)
+ return NULL;
+ return mp_xstrldup (mp, s, strlen (s));
+}
+
+
+@ @c
+void mp_initialize_strings (MP mp) {
+ mp->strings = avl_create (comp_strings_entry,
+ copy_strings_entry,
+ delete_strings_entry, malloc, free, NULL);
+ mp->cur_string = NULL;
+ mp->cur_length = 0;
+ mp->cur_string_size = 0;
+}
+
+@ @c
+void mp_dealloc_strings (MP mp) {
+ if (mp->strings != NULL)
+ avl_destroy (mp->strings);
+ mp->strings = NULL;
+ mp_xfree (mp->cur_string);
+ mp->cur_string = NULL;
+ mp->cur_length = 0;
+ mp->cur_string_size = 0;
+}
+
+@ Here are the definitions:
+@<Definitions@>=
+extern void mp_initialize_strings (MP mp);
+extern void mp_dealloc_strings (MP mp);
+
+@ Most printing is done from |char *|s, but sometimes not. Here are
+functions that convert an internal string into a |char *| for use
+by the printing routines, and vice versa.
+
+@<Definitions@>=
+char *mp_str (MP mp, mp_string s);
+mp_string mp_rtsl (MP mp, const char *s, size_t l);
+mp_string mp_rts (MP mp, const char *s);
+mp_string mp_make_string (MP mp);
+
+@ @c
+char *mp_str (MP mp, mp_string ss) {
+ (void) mp;
+ return (char *) ss->str;
+}
+
+@ @c
+mp_string mp_rtsl (MP mp, const char *s, size_t l) {
+ mp_string str, nstr;
+ str = new_strings_entry (mp);
+ str->str = (unsigned char *)mp_xstrldup (mp, s, l);
+ str->len = l;
+ nstr = (mp_string) avl_find (str, mp->strings);
+ if (nstr == NULL) { /* not yet known */
+ assert (avl_ins (str, mp->strings, avl_false) > 0);
+ nstr = (mp_string) avl_find (str, mp->strings);
+ }
+ (void)delete_strings_entry(str);
+ add_str_ref(nstr);
+ return nstr;
+}
+
+@ @c
+mp_string mp_rts (MP mp, const char *s) {
+ return mp_rtsl (mp, s, strlen (s));
+}
+
+
+@ Strings are created by appending character codes to |cur_string|.
+The |append_char| macro, defined here, does not check to see if the
+buffer overflows; this test is supposed to be
+made before |append_char| is used.
+
+To test if there is room to append |l| more characters to |cur_string|,
+we shall write |str_room(l)|, which tries to make sure there is enough room
+in the |cur_string|.
+
+@<Definitions@>=
+#define EXTRA_STRING 500
+#define append_char(A) do { \
+ str_room(1); \
+ *(mp->cur_string+mp->cur_length)=(unsigned char)(A); \
+ mp->cur_length++; \
+} while (0)
+#define str_room(wsize) do { \
+ size_t nsize; \
+ if ((mp->cur_length+(size_t)wsize) > mp->cur_string_size) { \
+ nsize = mp->cur_string_size + mp->cur_string_size / 5 + EXTRA_STRING; \
+ if (nsize < (size_t)(wsize)) { \
+ nsize = (size_t)wsize + EXTRA_STRING; \
+ } \
+ mp->cur_string = (unsigned char *) mp_xrealloc(mp, mp->cur_string, (unsigned)nsize, sizeof(unsigned char)); \
+ memset (mp->cur_string+mp->cur_length,0,(nsize-mp->cur_length)); \
+ mp->cur_string_size = nsize; \
+ } \
+} while (0)
+
+
+@ At the very start of the metapost run and each time after
+|make_string| has stored a new string in the avl tree, the
+|cur_string| variable has to be prepared so that it will be ready to
+start creating a new string. The initial size is fairly arbitrary, but
+setting it a little higher than expected helps prevent |reallocs|.
+
+@<Definitions@>=
+void mp_reset_cur_string (MP mp);
+
+@ @c
+void mp_reset_cur_string (MP mp) {
+ mp_xfree (mp->cur_string);
+ mp->cur_length = 0;
+ mp->cur_string_size = 63;
+ mp->cur_string = (unsigned char *) mp_xmalloc (mp, 64, sizeof (unsigned char));
+ memset (mp->cur_string, 0, 64);
+}
+
+
+@ \MP's string expressions are implemented in a brute-force way: Every
+new string or substring that is needed is simply stored into the string pool.
+Space is eventually reclaimed using the aid of a simple system system
+of reference counts.
+@^reference counts@>
+
+The number of references to string number |s| will be |s->refs|. The
+special value |s->refs=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.
+
+@<Definitions@>=
+#define MAX_STR_REF 127 /* ``infinite'' number of references */
+#define add_str_ref(A) { if ( (A)->refs < MAX_STR_REF ) ((A)->refs)++; }
+
+@ Here's what we do when a string reference disappears:
+
+@<Definitions@>=
+#define delete_str_ref(A) do { \
+ if ( (A)->refs < MAX_STR_REF ) { \
+ if ( (A)->refs > 1 ) ((A)->refs)--; \
+ else mp_flush_string(mp, (A)); \
+ } \
+ } while (0)
+
+@ @<Definitions@>=
+void mp_flush_string (MP mp, mp_string s);
+
+@ @c
+void mp_flush_string (MP mp, mp_string s) {
+ if (s->refs == 0) {
+ mp->strs_in_use--;
+ mp->pool_in_use = mp->pool_in_use - (integer) s->len;
+ (void) avl_del (s, mp->strings, NULL);
+ }
+}
+
+
+@ Some C literals that are used as values cannot be simply added,
+their reference count has to be set such that they can not be flushed.
+
+@c
+mp_string mp_intern (MP mp, const char *s) {
+ mp_string r;
+ r = mp_rts (mp, s);
+ r->refs = MAX_STR_REF;
+ return r;
+}
+
+@ @<Definitions@>=
+mp_string mp_intern (MP mp, const char *s);
+
+
+@ Once a sequence of characters has been appended to |cur_string|, it
+officially becomes a string when the function |make_string| is called.
+This function returns a pointer to the new string as its value.
+
+@<Definitions@>=
+mp_string mp_make_string (MP mp);
+
+@ @c
+mp_string mp_make_string (MP mp) { /* current string enters the pool */
+ mp_string str;
+ mp_lstring tmp;
+ tmp.str = mp->cur_string;
+ tmp.len = mp->cur_length;
+ str = (mp_string) avl_find (&tmp, mp->strings);
+ if (str == NULL) { /* not yet known */
+ str = mp_xmalloc (mp, 1, sizeof (mp_lstring));
+ str->str = mp->cur_string;
+ str->len = tmp.len;
+ assert (avl_ins (str, mp->strings, avl_false) > 0);
+ str = (mp_string) avl_find (&tmp, mp->strings);
+ mp->pool_in_use = mp->pool_in_use + (integer) str->len;
+ if (mp->pool_in_use > mp->max_pl_used)
+ mp->max_pl_used = mp->pool_in_use;
+ mp->strs_in_use++;
+ if (mp->strs_in_use > mp->max_strs_used)
+ mp->max_strs_used = mp->strs_in_use;
+ }
+ add_str_ref(str);
+ mp_reset_cur_string (mp);
+ return str;
+}
+
+
+@ Here is a routine that 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.
+
+@<Definitions@>=
+integer mp_str_vs_str (MP mp, mp_string s, mp_string t);
+
+@ @c
+integer mp_str_vs_str (MP mp, mp_string s, mp_string t) {
+ (void) mp;
+ return comp_strings_entry (NULL, (const void *) s, (const void *) t);
+}
+
+
+
+@ @<Definitions@>=
+mp_string mp_cat (MP mp, mp_string a, mp_string b);
+
+@ @c
+mp_string mp_cat (MP mp, mp_string a, mp_string b) {
+ mp_string str;
+ size_t needed;
+ size_t saved_cur_length = mp->cur_length;
+ unsigned char *saved_cur_string = mp->cur_string;
+ size_t saved_cur_string_size = mp->cur_string_size;
+ needed = a->len + b->len;
+ mp->cur_length = 0;
+ /*| mp->cur_string = NULL;| */ /* needs malloc, spotted by clang */
+ mp->cur_string = (unsigned char *) mp_xmalloc (mp, needed+1, sizeof (unsigned char));
+ mp->cur_string_size = 0;
+ str_room (needed+1);
+ (void) memcpy (mp->cur_string, a->str, a->len);
+ (void) memcpy (mp->cur_string + a->len, b->str, b->len);
+ mp->cur_length = needed;
+ mp->cur_string[needed] = '\0';
+ str = mp_make_string (mp);
+ mp_xfree(mp->cur_string); /* created by |mp_make_string| */
+ mp->cur_length = saved_cur_length;
+ mp->cur_string = saved_cur_string;
+ mp->cur_string_size = saved_cur_string_size;
+ return str;
+}
+
+
+@ @<Definitions@>=
+mp_string mp_chop_string (MP mp, mp_string s, integer a, integer b);
+
+@ @c
+mp_string mp_chop_string (MP mp, mp_string s, integer a, integer b) {
+ integer l; /* length of the original string */
+ integer k; /* runs from |a| to |b| */
+ boolean reversed; /* was |a>b|? */
+ if (a <= b)
+ reversed = false;
+ else {
+ reversed = true;
+ k = a;
+ a = b;
+ b = k;
+ }
+ l = (integer) s->len;
+ if (a < 0) {
+ a = 0;
+ if (b < 0)
+ b = 0;
+ }
+ if (b > l) {
+ b = l;
+ if (a > l)
+ a = l;
+ }
+ str_room ((size_t) (b - a));
+ if (reversed) {
+ for (k = b - 1; k >= a; k--) {
+ append_char (*(s->str + k));
+ }
+ } else {
+ for (k = a; k < b; k++) {
+ append_char (*(s->str + k));
+ }
+ }
+ return mp_make_string (mp);
+}
+
diff --git a/Build/source/texk/web2c/mplibdir/mptraptest.test b/Build/source/texk/web2c/mplibdir/mptraptest.test
new file mode 100755
index 00000000000..9cbc68ad4e6
--- /dev/null
+++ b/Build/source/texk/web2c/mplibdir/mptraptest.test
@@ -0,0 +1,40 @@
+#! /bin/sh -vx
+# Public domain.
+
+testdir=$abs_srcdir/triptrap
+
+TEXMFCNF=$testdir; export TEXMFCNF
+
+rm -rf mptrapdir
+mkdir mptrapdir
+cd mptrapdir
+
+dvitype_args="-output-level=2 -dpi=72.27 -page-start='*.*.*.*.*.*.*.*.*.*'"
+
+echo ">>> Running MPTRAP test for MetaPost." >&2
+echo ">>> See $testdir/mptrap.diffs for example of acceptable diffs." >&2
+
+set -x
+
+../pltotf $testdir/trapf.pl trapf.tfm
+
+# get same filename in log
+$LN_S $testdir/mtrap.mp . || exit 1
+
+../mpost --ini mtrap
+diff $testdir/mtrap.log mtrap.log
+diff $testdir/mtrap.0 mtrap.0
+diff $testdir/mtrap.1 mtrap.1
+diff $testdir/writeo writeo
+diff $testdir/writeo.2 writeo.2
+
+$LN_S $testdir/trap.mp . || exit 1
+$LN_S $testdir/trap.mpx . || exit 1
+
+## Why is --jobname required? And why --ini?
+../mpost --ini --jobname=trap <$testdir/mptrap1.in >mptrapin.fot
+mv trap.log mptrapin.log || exit 1
+diff $testdir/mptrapin.log mptrapin.log
+
+exit 0
+
diff --git a/Build/source/texk/web2c/mplibdir/mpxout.w b/Build/source/texk/web2c/mplibdir/mpxout.w
new file mode 100644
index 00000000000..f08645a28f0
--- /dev/null
+++ b/Build/source/texk/web2c/mplibdir/mpxout.w
@@ -0,0 +1,4380 @@
+% This file is part of MetaPost;
+% the MetaPost program is in the public domain.
+% See the <Show version...> code in mpost.w for more info.
+
+\def\title{Creating mpx files}
+\def\hang{\hangindent 3em\indent\ignorespaces}
+\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\(#1){} % this is used to make section names sort themselves better
+\def\9#1{} % this is used for sort keys in the index
+\def\[#1]{#1.}
+
+\pdfoutput=1
+
+@* \[1] Makempx overview.
+
+This source file implements the makempx functionality for the new \MP.
+It includes all of the functional code from the old standalone programs
+
+\item{}mpto
+\item{}dmp
+\item{}dvitomp
+\item{}makempx
+
+combined into one, with many changes to make all of the code cooperate
+nicely.
+
+@ Header files
+
+The local C preprocessor definitions have to come after the C includes
+in order to prevent name clashes.
+
+@c
+#include <w2c/config.h>
+#include <stdio.h>
+#include <stdlib.h>
+#include <string.h>
+#include <stdarg.h>
+#include <assert.h>
+#include <setjmp.h>
+#include <errno.h> /* TODO autoconf ? */
+/* unistd.h is needed for every non-Win32 platform, and we assume
+ * that implies that sys/types.h is also present
+ */
+#ifndef WIN32
+#include <sys/types.h>
+#include <unistd.h>
+#endif
+/* processes */
+#ifdef WIN32
+#include <io.h>
+#include <process.h>
+#else
+#if HAVE_SYS_WAIT_H
+# include <sys/wait.h>
+#endif
+#ifndef WEXITSTATUS
+# define WEXITSTATUS(stat_val) ((unsigned)(stat_val) >> 8)
+#endif
+#ifndef WIFEXITED
+# define WIFEXITED(stat_val) (((stat_val) & 255) == 0)
+#endif
+#endif
+/* directories */
+#ifdef WIN32
+#include <direct.h>
+#else
+#if HAVE_DIRENT_H
+# include <dirent.h>
+#else
+# define dirent direct
+# if HAVE_SYS_NDIR_H
+# include <sys/ndir.h>
+# endif
+# if HAVE_SYS_DIR_H
+# include <sys/dir.h>
+# endif
+# if HAVE_NDIR_H
+# include <ndir.h>
+# endif
+#endif
+#endif
+#if HAVE_SYS_STAT_H
+#include <sys/stat.h>
+#endif
+#include <ctype.h>
+#include <time.h>
+#include <math.h>
+#define trunc(x) ((integer) (x))
+#define fabs(x) ((x)<0?(-(x)):(x))
+#define floor(x) ((integer) (fabs(x)))
+#ifndef PI
+#define PI 3.14159265358979323846
+#endif
+#include "avl.h"
+#include "mpxout.h"
+@h
+
+@ Data types
+
+From the Pascal code of DVItoMP two implicit types are inherited: |web_boolean| and
+|web_integer|.
+
+The more complex datatypes are defined in the following sections.
+
+@d true 1
+@d false 0
+
+@c
+typedef signed int web_integer;
+typedef signed int web_boolean;
+@<C Data Types@>
+@<Declarations@>
+
+@ The single most important data structure is the structure
+|mpx_data|. It contains all of the global state for a specific
+|makempx| run. A pointer to it is passed as the first argument to just
+about every function call.
+
+One of the fields is a bit special because it is so important: |mode|
+is the decider between running \TeX\ or Troff as the typesetting
+engine.
+
+@(mpxout.h@>=
+#ifndef MPXOUT_H
+#define MPXOUT_H 1
+typedef enum {
+ mpx_tex_mode=0,
+ mpx_troff_mode=1
+} mpx_modes;
+typedef struct mpx_data * MPX;
+@<Makempx header information@>
+#endif
+
+@ @<C Data Types@>=
+@<Types in the outer block@>
+typedef struct mpx_data {
+ int mode;
+ @<Globals@>
+} mpx_data ;
+
+@ Here are some macros for common programming idioms.
+
+@d MAXINT 0x7FFFFF /* somewhat arbitrary */
+
+@d incr(A) (A)=(A)+1 /* increase a variable by unity */
+@d decr(A) (A)=(A)-1 /* decrease a variable by unity */
+
+@ Once an MPX object is allocated, the memory it occupies needs to be
+initialized to a usable state. This procedure gets things started
+properly.
+
+This function is not allowed to run |mpx_abort| because at this
+point the jump buffer is not yet initialized, so it should only
+be used for things that cannot go wrong!
+
+@c
+static void mpx_initialize (MPX mpx) {
+ memset(mpx,0,sizeof(struct mpx_data));
+ @<Set initial values@>@/
+}
+
+@ 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.
+
+@<Types...@>=
+enum mpx_history_states {
+ mpx_spotless=0, /* |history| value when no problems have been found */
+ mpx_cksum_trouble, /* |history| value there have been font checksum mismatches */
+ mpx_warning_given, /* |history| value after a recoverable error */
+ mpx_fatal_error /* |history| value if processing had to be aborted */
+};
+
+
+@ @<Glob...@>=
+int history;
+
+@ @<Set init...@>=
+mpx->history=mpx_spotless;
+
+@ The structure has room for the names and the |FILE *| for the
+input and output files. The most important ones are listed here,
+the variables for the intermediate files are declared where they
+are needed.
+
+@<Globals@>=
+char *banner;
+char *mpname;
+FILE *mpfile;
+char *mpxname;
+FILE *mpxfile;
+FILE *errfile;
+int lnno ; /* current line number */
+
+@ A set of basic reporting functions.
+
+@c
+static void mpx_printf(MPX mpx, const char *header, const char *msg, va_list ap) {
+ fprintf(mpx->errfile, "makempx %s: %s:", header, mpx->mpname);
+ if (mpx->lnno!=0)
+ fprintf(mpx->errfile, "%d:", mpx->lnno);
+ fprintf(mpx->errfile, " ");
+ (void)vfprintf(mpx->errfile, msg, ap);
+ fprintf(mpx->errfile, "\n");
+}
+
+@ @c
+static void mpx_report(MPX mpx, const char *msg, ...) {
+ va_list ap;
+ if (mpx->debug==0) return;
+ va_start(ap, msg);
+ mpx_printf(mpx, "debug", msg, ap);
+ va_end(ap);
+ if ( mpx->history < mpx_warning_given )
+ mpx->history=mpx_cksum_trouble;
+}
+
+@ @c
+static void mpx_warn(MPX mpx, const char *msg, ...) {
+ va_list ap;
+ va_start(ap, msg);
+ mpx_printf(mpx, "warning", msg, ap);
+ va_end(ap);
+ if ( mpx->history < mpx_warning_given )
+ mpx->history=mpx_cksum_trouble;
+}
+
+@ @c
+static void mpx_error(MPX mpx, const char *msg, ...) {
+ va_list ap;
+ va_start(ap, msg);
+ mpx_printf(mpx, "error", msg, ap);
+ va_end(ap);
+ mpx->history=mpx_warning_given;
+}
+
+@ The program uses a |jump_buf| to handle non-local returns,
+this is initialized at a single spot: the start of |mp_makempx|.
+
+@d mpx_jump_out longjmp(mpx->jump_buf,1)
+
+@<Glob...@>=
+jmp_buf jump_buf;
+
+@
+@c
+static void mpx_abort(MPX mpx, const char *msg, ...) {
+ va_list ap;
+ va_start(ap, msg);
+ fprintf(stderr, "fatal: ");
+ (void)vfprintf(stderr, msg, ap);
+ va_end(ap);
+ va_start(ap, msg);
+ mpx_printf(mpx, "fatal", msg, ap);
+ va_end(ap);
+ mpx->history=mpx_fatal_error;
+ mpx_erasetmp(mpx);
+ mpx_jump_out;
+}
+
+@ @<Install and test the non-local jump buffer@>=
+if (setjmp(mpx->jump_buf) != 0) {
+ int h = mpx->history;
+ xfree(mpx->buf);
+ xfree(mpx->maincmd);
+ xfree(mpx->mpname);
+ xfree(mpx->mpxname);
+ xfree(mpx);
+ return h;
+}
+
+@ @c
+static FILE *mpx_xfopen (MPX mpx, const char *fname, const char *fmode) {
+ FILE *f = fopen(fname,fmode);
+ if (f == NULL)
+ mpx_abort(mpx,"File open error for %s in mode %s", fname, fmode);
+ return f;
+}
+static void mpx_fclose (MPX mpx, FILE *file) {
+ (void)mpx;
+ (void)fclose(file);
+}
+
+@
+@d xfree(A) do { mpx_xfree(A); A=NULL; } while (0)
+@d xrealloc(P,A,B) mpx_xrealloc(mpx,P,A,B)
+@d xmalloc(A,B) mpx_xmalloc(mpx,A,B)
+@d xstrdup(A) mpx_xstrdup(mpx,A)
+
+@<Declarations@>=
+static void mpx_xfree (void *x);
+static void *mpx_xrealloc (MPX mpx, void *p, size_t nmem, size_t size) ;
+static void *mpx_xmalloc (MPX mpx, size_t nmem, size_t size) ;
+static char *mpx_xstrdup(MPX mpX, const char *s);
+
+
+@ The |max_size_test| guards against overflow, on the assumption that
+|size_t| is at least 31bits wide.
+
+@d max_size_test 0x7FFFFFFF
+
+@c
+static void mpx_xfree (void *x) {
+ if (x!=NULL) free(x);
+}
+static void *mpx_xrealloc (MPX mpx, void *p, size_t nmem, size_t size) {
+ void *w ;
+ if ((max_size_test/size)<nmem) {
+ mpx_abort(mpx,"Memory size overflow");
+ }
+ w = realloc (p,(nmem*size));
+ if (w==NULL) mpx_abort(mpx,"Out of Memory");
+ return w;
+}
+static void *mpx_xmalloc (MPX mpx, size_t nmem, size_t size) {
+ void *w;
+ if ((max_size_test/size)<nmem) {
+ mpx_abort(mpx,"Memory size overflow");
+ }
+ w = malloc (nmem*size);
+ if (w==NULL) mpx_abort(mpx,"Out of Memory");
+ return w;
+}
+static char *mpx_xstrdup(MPX mpx, const char *s) {
+ char *w;
+ if (s==NULL)
+ return NULL;
+ w = strdup(s);
+ if (w==NULL) mpx_abort(mpx,"Out of Memory");
+ return w;
+}
+@* The command 'newer' became a function.
+
+We may have high-res timers in struct stat. If we do, use them.
+
+@c
+static int mpx_newer(char *source, char *target) {
+ struct stat source_stat, target_stat;
+#if HAVE_SYS_STAT_H
+ if (stat(target, &target_stat) < 0) return 0; /* true */
+ if (stat(source, &source_stat) < 0) return 1; /* false */
+#if HAVE_STRUCT_STAT_ST_MTIM
+ if (source_stat.st_mtim.tv_sec > target_stat.st_mtim.tv_sec ||
+ (source_stat.st_mtim.tv_sec == target_stat.st_mtim.tv_sec &&
+ source_stat.st_mtim.tv_nsec >= target_stat.st_mtim.tv_nsec))
+ return 0;
+#else
+ if (source_stat.st_mtime >= target_stat.st_mtime)
+ return 0;
+#endif
+#endif
+ return 1;
+}
+
+
+
+@* Extracting data from \MP\ input.
+
+This part of the program transforms a \MP\ input file into a \TeX\ or
+troff input file by stripping out \.{btex}$\ldots$\.{etex} and
+\.{verbatimtex}$\ldots$\.{etex} sections.
+Leading and trailing spaces and tabs are removed from the
+extracted material and it is surrounded by the preceding and following
+strings defined immediately below. The input file should be given as
+argument 1 and the resulting \TeX\ or troff file is written on standard
+output.
+
+John Hobby wrote the original version, which has since been
+extensively altered. The current implementation is a bit trickier
+than I would like, but changing it will take careful study and
+will likely make it run slower, so I've left it as-is for now.
+
+@<Globals@>=
+int texcnt ; /* btex..etex blocks so far */
+int verbcnt ; /* verbatimtex..etex blocks so far */
+char *bb, *tt, *aa; /* start of before, token, and after strings */
+char *buf; /* the input line */
+unsigned bufsize;
+
+@ @<Set initial values@>=
+mpx->bufsize = 1000;
+
+@ This function returns NULL on EOF, otherwise it returns |buf|.
+
+@c
+static char *mpx_getline(MPX mpx, FILE *mpfile) {
+ int c;
+ unsigned loc = 0;
+ if (feof(mpfile))
+ return NULL;
+ if (mpx->buf==NULL)
+ mpx->buf = xmalloc(mpx->bufsize,1);
+ while ((c = getc(mpfile)) != EOF && c != '\n' && c != '\r') {
+ mpx->buf[loc++] = (char)c;
+ if (loc == mpx->bufsize) {
+ char *temp = mpx->buf;
+ unsigned n = mpx->bufsize + (mpx->bufsize>>4);
+ if (n>MAXINT)
+ mpx_abort(mpx,"Line is too long");
+ mpx->buf = xmalloc(n,1);
+ memcpy(mpx->buf,temp,mpx->bufsize);
+ free(temp);
+ mpx->bufsize = n;
+ }
+ }
+ mpx->buf[loc] = 0;
+ if (c == '\r') {
+ c = getc(mpfile);
+ if (c != '\n')
+ ungetc(c, mpfile);
+ }
+ mpx->lnno++;
+ return mpx->buf;
+}
+
+
+@ Return nonzero if a prefix of string $s$ matches the null-terminated string $t$
+and the next character is not a letter or an underscore.
+
+@c
+static int mpx_match_str(const char *s, const char *t) {
+ while (*t != 0) {
+ if (*s != *t)
+ return 0;
+ s++;
+ t++;
+ }
+ if ((*s>= 'a' && *s<='z') || (*s>= 'A' && *s<='Z') || *s == '_')
+ return 0;
+ return 1;
+}
+
+
+@ This function tries to express $s$ as the concatenation of three
+strings $b$, $t$, $a$, with the global pointers $bb$, $tt$, and $aa$ set to the
+start of the corresponding strings. String $t$ is either a quote mark,
+a percent sign, or an alphabetic token \.{btex}, \.{etex}, or
+\.{verbatimtex}. (An alphabetic token is a maximal sequence of letters
+and underscores.) If there are several possible substrings $t$, we
+choose the leftmost one. If there is no such $t$, we set $b=s$ and return 0.
+
+Various values are defined, so that |mpx_copy_mpto| can distinguish between
+\.{verbatimtex} ... \.{etex} and \.{btex} ... \.{etex} (the former has no
+whitespace corrections applied).
+
+@d VERBATIM_TEX 1
+@d B_TEX 2
+@d FIRST_VERBATIM_TEX 3
+
+@c
+static int mpx_getbta(MPX mpx, char *s) {
+ int ok = 1; /* zero if last character was |a-z|, |A-Z|, or |_| */
+ mpx->bb = s;
+ if (s==NULL) {
+ mpx->tt = NULL;
+ mpx->aa = NULL;
+ return 0;
+ }
+ for (mpx->tt = mpx->bb; *(mpx->tt) != 0; mpx->tt++) {
+ switch (*(mpx->tt)) {
+ case '"':
+ case '%':
+ mpx->aa = mpx->tt + 1;
+ return 1;
+ case 'b':
+ if (ok && mpx_match_str(mpx->tt, "btex")) {
+ mpx->aa = mpx->tt + 4;
+ return 1;
+ } else {
+ ok = 0;
+ }
+ break;
+ case 'e':
+ if (ok && mpx_match_str(mpx->tt, "etex")) {
+ mpx->aa = mpx->tt + 4;
+ return 1;
+ } else {
+ ok = 0;
+ }
+ break;
+ case 'v':
+ if (ok && mpx_match_str(mpx->tt, "verbatimtex")) {
+ mpx->aa = mpx->tt + 11;
+ return 1;
+ } else {
+ ok = 0;
+ }
+ break;
+ default:
+ if ((*(mpx->tt) >= 'a' && *(mpx->tt) <= 'z') ||
+ (*(mpx->tt) >= 'A' && *(mpx->tt) <= 'Z') ||
+ (*(mpx->tt) == '_'))
+ ok = 0;
+ else
+ ok = 1;
+ }
+ }
+ mpx->aa = mpx->tt;
+ return 0;
+}
+
+@ @c
+static void mpx_copy_mpto (MPX mpx, FILE *outfile, int textype) {
+ char *s; /* where a string to print stops */
+ char *t; /* for finding start of last line */
+ char c;
+ char *res = NULL;
+ t = NULL;
+ do {
+ if (mpx->aa == NULL || *mpx->aa == 0) {
+ if ((mpx->aa = mpx_getline(mpx,mpx->mpfile)) == NULL) {
+ mpx_error(mpx,"btex section does not end");
+ return;
+ }
+ }
+ if (mpx_getbta(mpx, mpx->aa) && *(mpx->tt) == 'e') {
+ s = mpx->tt;
+ } else {
+ if (mpx->tt == NULL) {
+ mpx_error(mpx,"btex section does not end");
+ return;
+ } else if (*(mpx->tt) == 'b') {
+ mpx_error(mpx,"btex in TeX mode");
+ return;
+ } else if (*(mpx->tt) == 'v') {
+ mpx_error(mpx,"verbatimtex in TeX mode");
+ return;
+ }
+ s = mpx->aa;
+ }
+ c = *s;
+ *s = 0;
+ if (res==NULL) {
+ res = xmalloc(strlen(mpx->bb)+2,1);
+ res = strncpy(res,mpx->bb,(strlen(mpx->bb)+1));
+ } else {
+ res = xrealloc(res,strlen(res)+strlen(mpx->bb)+2,1);
+ res = strncat(res,mpx->bb, strlen(mpx->bb));
+ }
+ if (c == '\0')
+ res = strncat(res, "\n", 1);
+ *s = c;
+ } while (*(mpx->tt) != 'e');
+ s = res;
+ if (textype == B_TEX) {
+ /* whitespace at the end */
+ for (s = res + strlen(res) - 1;
+ s >= res && (*s == ' ' || *s == '\t' || *s == '\r' || *s == '\n'); s--);
+ t = s;
+ *(++s) = '\0';
+ } else {
+ t =s;
+ }
+ if (textype == B_TEX || textype == FIRST_VERBATIM_TEX) {
+ /* whitespace at the start */
+ for (s = res;
+ s < (res + strlen(res)) && (*s == ' ' || *s == '\t' || *s == '\r'
+ || *s == '\n'); s++);
+ for (; *t != '\n' && t > s; t--);
+ }
+ fprintf(outfile,"%s", s);
+ if (textype == B_TEX) {
+ /* put no |%| at end if it's only 1 line total, starting with |%|;
+ * this covers the special case |%&format| in a single line. */
+ if (t != s && *t != '%')
+ fprintf(outfile,"%%");
+ }
+ free(res);
+}
+
+
+@ Static strings for mpto
+
+@c
+static const char *mpx_predoc[] = {"", ".po 0\n"};
+static const char *mpx_postdoc[] = { "\\end{document}\n", ""};
+static const char *mpx_pretex1[] = {
+ "\\gdef\\mpxshipout{\\shipout\\hbox\\bgroup%\n"
+ " \\setbox0=\\hbox\\bgroup}%\n"
+ "\\gdef\\stopmpxshipout{\\egroup"
+ " \\dimen0=\\ht0 \\advance\\dimen0\\dp0\n"
+ " \\dimen1=\\ht0 \\dimen2=\\dp0\n"
+ " \\setbox0=\\hbox\\bgroup\n"
+ " \\box0\n"
+ " \\ifnum\\dimen0>0 \\vrule width1sp height\\dimen1 depth\\dimen2 \n"
+ " \\else \\vrule width1sp height1sp depth0sp\\relax\n"
+ " \\fi\\egroup\n"
+ " \\ht0=0pt \\dp0=0pt \\box0 \\egroup}\n"
+ "\\mpxshipout%% line %d %s\n", ".lf %d %s\n" };
+static const char *mpx_pretex[] = { "\\mpxshipout%% line %d %s\n", ".bp\n.lf %d %s\n" };
+static const char *mpx_posttex[] = { "\n\\stopmpxshipout\n", "\n" };
+static const char *mpx_preverb1[] = {"", ".lf %d %s\n" }; /* if very first instance */
+static const char *mpx_preverb[] = { "%% line %d %s\n", ".lf %d %s\n"}; /* all other instances */
+static const char *mpx_postverb[] = { "\n", "\n" } ;
+
+@ @c
+static void mpx_mpto(MPX mpx, char *tmpname, char *mptexpre) {
+ FILE *outfile;
+ int verbatim_written = 0;
+ int mode = mpx->mode;
+ char *mpname = mpx->mpname;
+ if (mode==mpx_tex_mode) {
+ TMPNAME_EXT(mpx->tex,".tex");
+ } else {
+ TMPNAME_EXT(mpx->tex,".i");
+ }
+ outfile = mpx_xfopen(mpx,mpx->tex, "wb");
+ if (mode==mpx_tex_mode) {
+ FILE *fr;
+ if ((fr = fopen(mptexpre, "r"))!= NULL) {
+ size_t i;
+ char buf[512];
+ while ((i=fread((void *)buf, 1, 512 , fr))>0) {
+ fwrite((void *)buf,1, i, outfile);
+ }
+ mpx_fclose(mpx,fr);
+ }
+ }
+ mpx->mpfile = mpx_xfopen(mpx,mpname, "r");
+ fprintf(outfile,"%s", mpx_predoc[mode]);
+ while (mpx_getline(mpx, mpx->mpfile) != NULL)
+ @<Do a line@>;
+ fprintf(outfile,"%s", mpx_postdoc[mode]);
+ mpx_fclose(mpx,mpx->mpfile);
+ mpx_fclose(mpx,outfile);
+ mpx->lnno = 0;
+}
+
+@
+@<Do a line@>=
+{
+ mpx->aa = mpx->buf;
+ while (mpx_getbta(mpx, mpx->aa)) {
+ if (*(mpx->tt) == '%') {
+ break;
+ } else if (*(mpx->tt) == '"') {
+ do {
+ if (!mpx_getbta(mpx, mpx->aa))
+ mpx_error(mpx,"string does not end");
+ } while (*(mpx->tt) != '"');
+ } else if (*(mpx->tt) == 'b') {
+ if (mpx->texcnt++ == 0)
+ fprintf(outfile,mpx_pretex1[mode], mpx->lnno, mpname);
+ else
+ fprintf(outfile,mpx_pretex[mode], mpx->lnno, mpname);
+ mpx_copy_mpto(mpx, outfile, B_TEX);
+ fprintf(outfile,"%s", mpx_posttex[mode]);
+ } else if (*(mpx->tt) == 'v') {
+ if (mpx->verbcnt++ == 0 && mpx->texcnt == 0)
+ fprintf(outfile,mpx_preverb1[mode], mpx->lnno, mpname);
+ else
+ fprintf(outfile,mpx_preverb[mode], mpx->lnno, mpname);
+ if (!verbatim_written)
+ mpx_copy_mpto(mpx, outfile, FIRST_VERBATIM_TEX);
+ else
+ mpx_copy_mpto(mpx, outfile, VERBATIM_TEX);
+ fprintf(outfile,"%s", mpx_postverb[mode]);
+ } else {
+ mpx_error(mpx,"unmatched etex");
+ }
+ verbatim_written = 1;
+ }
+}
+
+@ @<Run |mpto| on the mp file@>=
+mpx_mpto(mpx, tmpname, mpxopt->mptexpre)
+
+@* DVItoMP Processing.
+
+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 the extraction process that is defined above.
+Such a \.{DVI} file will contain one page for every \.{btex}$\ldots$\.{etex}
+block in the original input. Processing 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 following parameters can be changed at compile time to extend or
+reduce \.{DVItoMP}'s capacity.
+
+TODO: dynamic reallocation
+
+@d virtual_space 1000000 /* maximum total bytes of typesetting commands for virtual fonts */
+@d max_fonts 1000 /* maximum number of distinct fonts per \.{DVI} file */
+@d max_fnums 3000 /* maximum number of fonts plus fonts local to virtual fonts */
+@d max_widths (256*max_fonts) /* maximum number of different characters among all fonts */
+@d line_length 79 /* maximum output line length (must be at least 60) */
+@d stack_size 100 /* \.{DVI} files shouldn't |push| beyond this depth */
+@d font_tolerance 0.00001
+ /* font sizes should match to within this multiple of $2^{20}$ \.{DVI} units */
+
+@ 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.
+
+@d bad_dvi(A) mpx_abort(mpx,"Bad DVI file: " A "!")
+@d bad_dvi_two(A,B) mpx_abort(mpx,"Bad DVI file: " A "!", B)
+@.Bad DVI file@>
+
+@* The character set.
+
+Like all programs written with the \.{WEB} system, \.{DVItoMP} can be
+used with any character set. It an identify transfrom 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.
+
+In the conversion from Pascal to C, the |xchr| array has been removed.
+Because some systems may still want to change the input--output character
+set, the accesses to |xchr| and |printable| are replaced by macro calls.
+
+@d printable(c) (isprint(c) && c < 128 && c!='"')
+@d xchr(A) (A)
+
+@ @c
+static void mpx_open_mpxfile (MPX mpx) { /* prepares to write text on |mpxfile| */
+ mpx->mpxfile = mpx_xfopen (mpx,mpx->mpxname, "wb");
+}
+
+@* 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: case 251: case 252: case 253: case 254: case 255
+
+@* Input from binary files.
+
+@ 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...@>=
+FILE * dvi_file; /* the input file */
+FILE * tfm_file; /* a font metric file */
+FILE * vf_file; /* a virtual font file */
+
+@ Prepares to read packed bytes in |dvi_file|
+@c
+static void mpx_open_dvi_file (MPX mpx) {
+ mpx->dvi_file = fopen(mpx->dviname,"rb");
+ if (mpx->dvi_file==NULL)
+ mpx_abort(mpx,"DVI generation failed");
+}
+
+@ Prepares to read packed bytes in |tfm_file|
+@c
+static web_boolean mpx_open_tfm_file (MPX mpx) {
+ mpx->tfm_file = mpx_fsearch(mpx, mpx->cur_name, mpx_tfm_format);
+ if (mpx->tfm_file == NULL)
+ mpx_abort(mpx,"Cannot find TFM %s", mpx->cur_name);
+ free (mpx->cur_name); /* We |xmalloc|'d this before we got called. */
+ return true; /* If we get here, we succeeded. */
+}
+
+@ Prepares to read packed bytes in |vf_file|.
+It's ok if the \.{VF} file doesn't exist.
+
+@c
+static web_boolean mpx_open_vf_file (MPX mpx) {
+ mpx->vf_file = mpx_fsearch(mpx, mpx->cur_name, mpx_vf_format);
+ if (mpx->vf_file) {
+ free (mpx->cur_name);
+ return true;
+ }
+ return false;
+}
+
+@ 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| or |open_vf_file|
+is called.
+
+@<Glob...@>=
+char *cur_name; /* external name */
+
+@ 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...@>=
+int b0, b1, b2, b3; /* four bytes input at once */
+
+@ The |read_tfm_word| procedure sets |b0| through |b3| to the next
+four bytes in the current \.{TFM} file.
+
+@c
+static void mpx_read_tfm_word (MPX mpx) {
+ mpx->b0 = getc(mpx->tfm_file);
+ mpx->b1 = getc(mpx->tfm_file);
+ mpx->b2 = getc(mpx->tfm_file);
+ mpx->b3 = getc(mpx->tfm_file);
+}
+
+@ 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...@>=
+web_boolean vf_reading; /* should input come from |vf_file|? */
+unsigned char cmd_buf[(virtual_space+1)]; /* commands for virtual characters */
+unsigned int buf_ptr; /* |cmd_buf| index for the next byte */
+
+@ @<Set init...@>=
+mpx->vf_reading=false;
+mpx->buf_ptr=virtual_space;
+
+@ 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.
+
+@c
+static web_integer mpx_get_byte (MPX mpx) { /* returns the next byte, unsigned */
+ unsigned char b;
+ @<Read one byte into |b|@>;
+ return b;
+}
+
+static web_integer mpx_signed_byte (MPX mpx) { /* returns the next byte, signed */
+ unsigned char b;
+ @<Read one byte into |b|@>;
+ return ( b<128 ? b : (b-256));
+}
+
+static web_integer mpx_get_two_bytes (MPX mpx) { /* returns the next two bytes, unsigned */
+ unsigned char a,b;
+ a=0; b=0; /* for compiler warnings */
+ @<Read two bytes into |a| and |b|@>;
+ return (a*(int)(256)+b);
+}
+
+static web_integer mpx_signed_pair (MPX mpx) { /* returns the next two bytes, signed */
+ unsigned char a,b;
+ a=0; b=0; /* for compiler warnings */
+ @<Read two bytes into |a| and |b|@>;
+ if ( a<128 ) return (a*256+b);
+ else return ((a-256)*256+b);
+}
+
+static web_integer mpx_get_three_bytes (MPX mpx) { /* returns the next three bytes, unsigned */
+ unsigned char a,b,c;
+ a=0; b=0; c=0; /* for compiler warnings */
+ @<Read three bytes into |a|, |b|, and~|c|@>;
+ return ((a*(int)(256)+b)*256+c);
+}
+
+static web_integer mpx_signed_trio (MPX mpx) { /* returns the next three bytes, signed */
+ unsigned char a,b,c;
+ a=0; b=0; c=0; /* for compiler warnings */
+ @<Read three bytes into |a|, |b|, and~|c|@>;
+ if ( a<128 ) return ((a*(int)(256)+b)*256+c);
+ else return (((a-(int)(256))*256+b)*256+c);
+}
+
+static web_integer mpx_signed_quad (MPX mpx) { /* returns the next four bytes, signed */
+ unsigned char a,b,c,d;
+ a=0; b=0; c=0; d=0; /* for compiler warnings */
+ @<Read four bytes into |a|, |b|, |c|, and~|d|@>;
+ if ( a<128 ) return (((a*(int)(256)+b)*256+c)*256+d);
+ else return ((((a-256)*(int)(256)+b)*256+c)*256+d);
+}
+
+@ @<Read one byte into |b|@>=
+if ( mpx->vf_reading ) {
+ b = (unsigned char)getc(mpx->vf_file);
+} else if ( mpx->buf_ptr==virtual_space ) {
+ b = (unsigned char)getc(mpx->dvi_file);
+} else {
+ b=mpx->cmd_buf[mpx->buf_ptr];
+ incr(mpx->buf_ptr);
+}
+
+@ @<Read two bytes into |a| and |b|@>=
+if ( mpx->vf_reading ) {
+ a = (unsigned char)getc(mpx->vf_file);
+ b = (unsigned char)getc(mpx->vf_file);
+} else if ( mpx->buf_ptr==virtual_space ) {
+ a = (unsigned char)getc(mpx->dvi_file);
+ b = (unsigned char)getc(mpx->dvi_file);
+} else if ( mpx->buf_ptr+2>mpx->n_cmds ) {
+ mpx_abort(mpx,"Error detected while interpreting a virtual font");
+@.Error detected while...@>
+} else {
+ a=mpx->cmd_buf[mpx->buf_ptr];
+ b=mpx->cmd_buf[mpx->buf_ptr+1];
+ mpx->buf_ptr+=2;
+}
+
+@ @<Read three bytes into |a|, |b|, and~|c|@>=
+if ( mpx->vf_reading ) {
+ a = (unsigned char)getc(mpx->vf_file);
+ b = (unsigned char)getc(mpx->vf_file);
+ c = (unsigned char)getc(mpx->vf_file);
+} else if ( mpx->buf_ptr==virtual_space ) {
+ a = (unsigned char)getc(mpx->dvi_file);
+ b = (unsigned char)getc(mpx->dvi_file);
+ c = (unsigned char)getc(mpx->dvi_file);
+} else if ( mpx->buf_ptr+3>mpx->n_cmds ) {
+ mpx_abort(mpx,"Error detected while interpreting a virtual font");
+@.Error detected while...@>
+} else {
+ a=mpx->cmd_buf[mpx->buf_ptr];
+ b=mpx->cmd_buf[mpx->buf_ptr+1];
+ c=mpx->cmd_buf[mpx->buf_ptr+2];
+ mpx->buf_ptr+=3;
+}
+
+@ @<Read four bytes into |a|, |b|, |c|, and~|d|@>=
+if ( mpx->vf_reading ) {
+ a = (unsigned char)getc(mpx->vf_file);
+ b = (unsigned char)getc(mpx->vf_file);
+ c = (unsigned char)getc(mpx->vf_file);
+ d = (unsigned char)getc(mpx->vf_file);
+} else if ( mpx->buf_ptr==virtual_space ) {
+ a = (unsigned char)getc(mpx->dvi_file);
+ b = (unsigned char)getc(mpx->dvi_file);
+ c = (unsigned char)getc(mpx->dvi_file);
+ d = (unsigned char)getc(mpx->dvi_file);
+} else if ( mpx->buf_ptr+4>mpx->n_cmds ) {
+ mpx_abort(mpx,"Error detected while interpreting a virtual font");
+@.Error detected while...@>
+} else {
+ a=mpx->cmd_buf[mpx->buf_ptr];
+ b=mpx->cmd_buf[mpx->buf_ptr+1];
+ c=mpx->cmd_buf[mpx->buf_ptr+2];
+ d=mpx->cmd_buf[mpx->buf_ptr+3];
+ mpx->buf_ptr+=4;
+}
+
+@* 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 |font_name[f]|.
+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(A,B) mpx->width[mpx->info_base[(A)]+(B)]
+@d start_cmd(A,B) mpx->cmd_ptr[mpx->info_base[(A)]+(B)]
+
+@<Glob...@>=
+web_integer font_num[(max_fnums+1)]; /* external font numbers */
+web_integer internal_num[(max_fnums+1)]; /* internal font numbers */
+web_boolean local_only[(max_fnums+1)]; /* |font_num| meaningless? */
+char *font_name[(max_fonts+1)]; /* starting positions of external font names */
+double font_scaled_size[(max_fonts+1)]; /* scale factors over $2^{20}$ */
+double font_design_size[(max_fonts+1)]; /* design sizes over $2^{20}$ */
+web_integer font_check_sum[(max_fonts+1)]; /* check sum from the |font_def| */
+web_integer font_bc[(max_fonts+1)]; /* beginning characters in fonts */
+web_integer font_ec[(max_fonts+1)]; /* ending characters in fonts */
+web_integer info_base[(max_fonts+1)]; /* index into |width| and |cmd_ptr| tables */
+web_integer width[(max_widths+1)];
+ /* character widths, in units $2^{-20}$ of design size */
+web_integer fbase[(max_fonts+1)]; /* index into |font_num| for local fonts */
+web_integer ftop[(max_fonts+1)]; /* |font_num| index where local fonts stop */
+web_integer cmd_ptr[(max_widths+1)]; /* starting positions in |cmd_buf| */
+unsigned int nfonts; /* the number of known fonts */
+unsigned int vf_ptr; /* next |font_num| entry for virtual font font tables */
+unsigned int info_ptr; /* allocation pointer for |width| and |cmd_ptr| tables */
+unsigned int n_cmds; /* number of occupied cells in |cmd_buf| */
+unsigned int cur_fbase, cur_ftop;
+ /* currently applicable part of the |font_num| table */
+
+@ @<Set init...@>=
+mpx->nfonts=0; mpx->info_ptr=0; mpx->font_name[0]=0;
+mpx->vf_ptr=max_fnums;
+mpx->cur_fbase=0; mpx->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.
+
+@c @<Declare subroutines for printing strings@>@;
+static void mpx_print_font (MPX mpx, web_integer f) { /* |f| is an internal font number */
+ if ( (f<0)||(f>=(int)mpx->nfonts) ) {
+ bad_dvi("Undefined font");
+ } else {
+ char *s = mpx->font_name[f];
+ while (*s) {
+ mpx_print_char(mpx,(unsigned char)*s);
+ s++;
+ }
+ }
+}
+
+@ Sometimes a font name is needed as part of an error message.
+
+@d font_warn(A,B) mpx_warn (mpx,"%s %s",A,mpx->font_name[(B)])
+@d font_error(A,B) mpx_error(mpx,"%s %s",A,mpx->font_name[(B)])
+@d font_abort(A,B) mpx_abort(mpx,"%s %s",A,mpx->font_name[(B)])
+
+
+@ 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|.
+
+@c @<Declare a function called |match_font|@>@;
+static void mpx_define_font (MPX mpx, web_integer e) { /* |e| is an external font number */
+ unsigned i; /* index into |font_num| and |internal_num| */
+ web_integer n; /* length of the font name and area */
+ web_integer k; /* general purpose loop counter */
+ web_integer x; /* a temporary value for scaled size computation */
+ if ( mpx->nfonts==max_fonts )
+ mpx_abort(mpx,"DVItoMP capacity exceeded (max fonts=%d)!", max_fonts);
+@.DVItoMP capacity exceeded...@>
+ @<Allocate an index |i| into the |font_num| and |internal_num| tables@>;
+ @<Read the font parameters into position for font |nf|@>;
+ mpx->internal_num[i]=mpx_match_font(mpx, mpx->nfonts,true);
+ if ( mpx->internal_num[i]==(int)mpx->nfonts ) {
+ mpx->info_base[mpx->nfonts]=max_widths; /* indicate that the info isn't loaded yet */
+ mpx->local_only[mpx->nfonts]=mpx->vf_reading; incr(mpx->nfonts);
+ }
+}
+
+@ @<Allocate an index |i| into the |font_num| and |internal_num| tables@>=
+if ( mpx->vf_ptr==mpx->nfonts )
+ mpx_abort(mpx,"DVItoMP capacity exceeded (max font numbers=%d)", max_fnums);
+@.DVItoMP capacity exceeded...@>
+if ( mpx->vf_reading ) {
+ mpx->font_num[mpx->nfonts]=0; i=mpx->vf_ptr; decr(mpx->vf_ptr);
+} else {
+ i=mpx->nfonts;
+}
+mpx->font_num[i]=e
+
+@ @<Read the font parameters into position for font |nf|@>=
+mpx->font_check_sum[mpx->nfonts]=mpx_signed_quad(mpx);
+@<Read |font_scaled_size[nf]| and |font_design_size[nf]|@>;
+n=mpx_get_byte(mpx); /* that is the area */
+n=n+mpx_get_byte(mpx);
+mpx->font_name[mpx->nfonts]=xmalloc((size_t)(n+1),1);
+for (k=0;k<n;k++)
+ mpx->font_name[mpx->nfonts][k]=(char)mpx_get_byte(mpx);
+mpx->font_name[mpx->nfonts][k]=0
+
+@ 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=mpx_signed_quad(mpx);
+k=1;
+while ( mpx->x>040000000 ) {
+ x= x / 2; k=k+k;
+}
+mpx->font_scaled_size[mpx->nfonts]=x*k/1048576.0;
+if ( mpx->vf_reading )
+ mpx->font_design_size[mpx->nfonts]=mpx_signed_quad(mpx)*mpx->dvi_per_fix/1048576.0;
+else mpx->font_design_size[mpx->nfonts]=mpx_signed_quad(mpx)/1048576.0;
+
+@ @<Glob...@>=
+double dvi_per_fix; /* 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|@>=
+static web_integer mpx_match_font (MPX mpx, unsigned ff, web_boolean exact) {
+ unsigned f; /* font number being tested */
+ for (f=0; f<mpx->nfonts ; f++) {
+ if ( f!=ff ) {
+ @<Compare the names of fonts |f| and |ff|; |continue| if they differ@>;
+ if ( exact ) {
+ if ( fabs(mpx->font_scaled_size[f]-mpx->font_scaled_size[ff])<= font_tolerance ) {
+ if ( ! mpx->vf_reading ) {
+ if ( mpx->local_only[f] ) {
+ mpx->font_num[f]=mpx->font_num[ff]; mpx->local_only[f]=false;
+ } else if ( mpx->font_num[f]!=mpx->font_num[ff] ) {
+ continue;
+ }
+ }
+ break;
+ }
+ } else if ( mpx->info_base[f]!=max_widths ) {
+ break;
+ }
+ }
+ }
+ if ( f<mpx->nfonts ) {
+ @<Make sure fonts |f| and |ff| have matching design sizes and checksums@>;
+ }
+ return (web_integer)f;
+}
+
+@ @<Compare the names of fonts |f| and |ff|; |continue| if they differ@>=
+if (strcmp(mpx->font_name[f],mpx->font_name[ff]))
+ continue
+
+@ @<Make sure fonts |f| and |ff| have matching design sizes and checksums@>=
+if ( fabs(mpx->font_design_size[f]-mpx->font_design_size[ff]) > font_tolerance ) {
+ font_error("Inconsistent design sizes given for ",ff);
+@.Inconsistent design sizes@>
+} else if ( mpx->font_check_sum[f]!=mpx->font_check_sum[ff] ) {
+ 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...@>=
+web_integer in_width[256]; /* \.{TFM} width data in \.{DVI} units */
+web_integer tfm_check_sum; /* 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.
+
+@c
+static void mpx_in_TFM (MPX mpx,web_integer f) {
+ /* input \.{TFM} data for font |f| or abort */
+ web_integer k; /* index for loops */
+ int lh; /* length of the header data, in four-byte words */
+ int nw; /* number of words in the width table */
+ unsigned int wp; /* new value of |info_ptr| after successful input */
+ @<Read past the header data; |abort| 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|@>;
+ mpx->fbase[f]=0; mpx->ftop[f]=0;
+ mpx->info_ptr=wp;
+ mpx_fclose(mpx,mpx->tfm_file);
+ return;
+}
+
+@ @<Read past the header...@>=
+mpx_read_tfm_word(mpx); lh=mpx->b2*(int)(256)+mpx->b3;
+mpx_read_tfm_word(mpx);
+mpx->font_bc[f]=mpx->b0*(int)(256)+mpx->b1;
+mpx->font_ec[f]=mpx->b2*(int)(256)+mpx->b3;
+if ( mpx->font_ec[f]<mpx->font_bc[f] ) mpx->font_bc[f]=mpx->font_ec[f]+1;
+if ( mpx->info_ptr+(unsigned int)mpx->font_ec[f]-(unsigned int)mpx->font_bc[f]+1>max_widths )
+ mpx_abort(mpx,"DVItoMP capacity exceeded (width table size=%d)!",max_widths);
+@.DVItoMP capacity exceeded...@>
+wp=mpx->info_ptr+(unsigned int)mpx->font_ec[f]-(unsigned int)mpx->font_bc[f]+1;
+mpx_read_tfm_word(mpx); nw=mpx->b0*256+mpx->b1;
+if ( (nw==0)||(nw>256) )
+ font_abort("Bad TFM file for ",f);
+@.Bad TFM file@>
+for (k=1;k<=3+lh;k++) {
+ if ( feof(mpx->tfm_file) )
+ font_abort("Bad TFM file for ",f);
+@.Bad TFM file@>
+ mpx_read_tfm_word(mpx);
+ if ( k==4 ) {
+ if ( mpx->b0<128 )
+ mpx->tfm_check_sum=((mpx->b0*(int)(256)+mpx->b1)*256+mpx->b2)*256+mpx->b3;
+ else
+ mpx->tfm_check_sum=(((mpx->b0-256)*(int)(256)+mpx->b1)*256+mpx->b2)*256+mpx->b3;
+ }
+ if ( k==5 ) {
+ if (mpx->mode == mpx_troff_mode) {
+ mpx->font_design_size[f]=(((mpx->b0*(int)(256)+mpx->b1)*256+mpx->b2)*256+mpx->b3)/(65536.0*16);
+ }
+ }
+}
+
+@ @<Store character-width indices...@>=
+if ( wp>0 ) {
+ for (k=(int)mpx->info_ptr;k<=(int)wp-1;k++ ) {
+ mpx_read_tfm_word(mpx);
+ if ( mpx->b0>nw )
+ font_abort("Bad TFM file for ",f);
+@.Bad TFM file@>
+ mpx->width[k]=mpx->b0;
+ }
+}
+
+@ 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;k<=nw-1;k++) {
+ mpx_read_tfm_word(mpx);
+ if ( mpx->b0>127 ) mpx->b0=mpx->b0-256;
+ mpx->in_width[k]=((mpx->b0*0400+mpx->b1)*0400+mpx->b2)*0400+mpx->b3;
+}
+
+@ 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|@>=
+floor(mpx->dvi_scale*mpx->font_scaled_size[f]*char_width(f,c))
+
+@ @<Width of character |p| in font |cur_font|@>=
+floor(mpx->dvi_scale*mpx->font_scaled_size[cur_font]*char_width(cur_font,p))
+
+@ @<Move the widths from |in_width| to |width|@>=
+if ( mpx->in_width[0]!=0 )
+ font_abort("Bad TFM file for ",f); /* the first width should be zero */
+@.Bad TFM file@>
+mpx->info_base[f]=(int)(mpx->info_ptr-(unsigned int)mpx->font_bc[f]);
+if ( wp>0 ) {
+ for (k=(int)mpx->info_ptr;k<=(int)wp-1;k++) {
+ mpx->width[k]=mpx->in_width[mpx->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.
+
+@c
+@<Declare a function called |first_par|@>@;
+static void mpx_in_VF (MPX mpx, web_integer f) {
+ /* read \.{VF} data for font |f| or abort */
+ web_integer p; /* a byte from the \.{VF} file */
+ boolean was_vf_reading; /* old value of |vf_reading| */
+ web_integer c; /* the current character code */
+ web_integer limit; /* space limitations force character codes to be less than this */
+ web_integer w; /* a \.{TFM} width being read */
+ was_vf_reading=mpx->vf_reading; mpx->vf_reading=true;
+ @<Start reading the preamble from a \.{VF} file@>;@/
+ @<Initialize the data structures for the virtual font@>;@/
+ p=mpx_get_byte(mpx);
+ while ( p>=fnt_def1 ) {
+ if ( p>fnt_def1+3 )
+ font_abort("Bad VF file for ",f);
+ mpx_define_font(mpx, mpx_first_par(mpx, (unsigned int)p));
+ p=mpx_get_byte(mpx);
+ }
+ while ( p<=242 ) {
+ if ( feof(mpx->vf_file) )
+ font_abort("Bad VF file for ",f);
+ @<Read the packet length, character code, and \.{TFM} width@>;
+ @<Store the character packet in |cmd_buf|@>;
+ p=mpx_get_byte(mpx);
+ }
+ if ( p==post ) {
+ @<Finish setting up the data structures for the new virtual font@>;
+ mpx->vf_reading=was_vf_reading;
+ return;
+ }
+}
+
+@ @<Start reading the preamble from a \.{VF} file@>=
+p=mpx_get_byte(mpx);
+if ( p!=pre )
+ font_abort("Bad VF file for ",f);
+p=mpx_get_byte(mpx); /* fetch the identification byte */
+if ( p!=202 )
+ font_abort("Bad VF file for ",f);
+p=mpx_get_byte(mpx); /* fetch the length of the introductory comment */
+while ( p-->0 )
+ (void)mpx_get_byte(mpx);
+mpx->tfm_check_sum=mpx_signed_quad(mpx);
+(void)mpx_signed_quad(mpx); /* skip over the design size */
+
+@ @<Initialize the data structures for the virtual font@>=
+mpx->ftop[f]=(web_integer)mpx->vf_ptr;
+if ( mpx->vf_ptr==mpx->nfonts )
+ mpx_abort(mpx,"DVItoMP capacity exceeded (max font numbers=%d)", max_fnums);
+@.DVItoMP capacity exceeded...@>
+decr(mpx->vf_ptr);
+mpx->info_base[f]=(web_integer)mpx->info_ptr;
+limit=max_widths-mpx->info_base[f];@/
+mpx->font_bc[f]=limit; mpx->font_ec[f]=0
+
+@ @<Read the packet length, character code, and \.{TFM} width@>=
+if ( p==242 ) {
+ p=mpx_signed_quad(mpx); c=mpx_signed_quad(mpx); w=mpx_signed_quad(mpx);
+ if ( c<0 )
+ font_abort("Bad VF file for ",f);
+} else {
+ c=mpx_get_byte(mpx); w=mpx_get_three_bytes(mpx);
+}
+if ( c>=limit )
+ mpx_abort(mpx,"DVItoMP capacity exceeded (max widths=%d)", max_widths);
+@.DVItoMP capacity exceeded...@>
+if ( c<mpx->font_bc[f] ) mpx->font_bc[f]=c;
+if ( c>mpx->font_ec[f] ) mpx->font_ec[f]=c;
+char_width(f,c)=w
+
+@ @<Store the character packet in |cmd_buf|@>=
+if ( mpx->n_cmds+(unsigned int)p>=virtual_space )
+ mpx_abort(mpx,"DVItoMP capacity exceeded (virtual font space=%d)",virtual_space);
+@.DVItoMP capacity exceeded...@>
+start_cmd(f,c)=(web_integer)mpx->n_cmds;
+while ( p>0 ) {
+ mpx->cmd_buf[mpx->n_cmds]=(unsigned char)mpx_get_byte(mpx);
+ incr(mpx->n_cmds); decr(p);
+}
+mpx->cmd_buf[mpx->n_cmds]=eop; /* add the end-of-packet marker */
+incr(mpx->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@>=
+mpx->fbase[f]=(web_integer)(mpx->vf_ptr+1);
+mpx->info_ptr=(unsigned int)(mpx->info_base[f]+mpx->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.
+
+@c
+static web_integer mpx_select_font (MPX mpx, web_integer e) {
+ int f; /* the internal font number */
+ int ff; /* internal font number for an existing version */
+ web_integer k; /* general purpose loop counter */
+ @<Set |f| to the internal font number that corresponds to |e|,
+ or |abort| if there is none@>;
+ if ( mpx->info_base[f]==max_widths ) {
+ ff=mpx_match_font(mpx, (unsigned)f,false);
+ if ( ff<(int)mpx->nfonts ) {
+ @<Make font |f| refer to the width information from font |ff|@>;
+ } else {
+ @<Move the \.{VF} file name into the |cur_name| string@>;
+ if ( mpx_open_vf_file(mpx) ) {
+ mpx_in_VF(mpx, f);
+ } else {
+ if ( ! mpx_open_tfm_file(mpx) )
+ font_abort("No TFM file found for ",f);
+@.no TFM file found@>
+ mpx_in_TFM(mpx, f);
+ }
+ @<Make sure the checksum in the font file matches the one given in the
+ |font_def| for font |f|@>;
+ }
+ @<Do any other initialization required for the new font |f|@>;
+ }
+ return f;
+}
+
+@ @<Set |f| to the internal font number that corresponds to |e|,...@>=
+if ( mpx->cur_ftop<=mpx->nfonts )
+ mpx->cur_ftop=mpx->nfonts;
+mpx->font_num[mpx->cur_ftop]=e;
+k=(web_integer)mpx->cur_fbase;
+while ((mpx->font_num[k]!=e)|| mpx->local_only[k] ) incr(k);
+if ( k==(int)mpx->cur_ftop )
+ mpx_abort(mpx,"Undefined font selected");
+f=mpx->internal_num[k]
+
+@ @<Make font |f| refer to the width information from font |ff|@>=
+{
+ mpx->font_bc[f]=mpx->font_bc[ff];
+ mpx->font_ec[f]=mpx->font_ec[ff];
+ mpx->info_base[f]=mpx->info_base[ff];
+ mpx->fbase[f]=mpx->fbase[ff];
+ mpx->ftop[f]=mpx->ftop[ff];
+}
+
+@ The string |cur_name| is supposed to be set to the external name of the
+\.{VF} file for the current font.
+@^system dependencies@>
+
+@<Move the \.{VF} file name into the |cur_name| string@>=
+mpx->cur_name = xstrdup (mpx->font_name[f])
+
+@ @<Make sure the checksum in the font file matches the one given in the...@>=
+{
+ if ( (mpx->font_check_sum[f]!=0)&&(mpx->tfm_check_sum!=0)&&@|
+ (mpx->font_check_sum[f]!=mpx->tfm_check_sum) ) {
+ font_warn("Checksum mismatch for ",f);
+@.Checksum mismatch@>
+ }
+}
+
+@* 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...@>=
+int state; /* controls the process of printing a string */
+int print_col; /* there are at most this many characters on the current line */
+
+@ @<Set initial values@>=
+mpx->state = initial;
+mpx->print_col = 0; /* 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@>=
+static void mpx_print_char (MPX mpx, unsigned char c) {
+ web_integer l; /* number of characters to print |c| or the \.{char} expression */
+ if ( printable(c) ) l=1;
+ else if ( c<10 ) l=5;
+ else if ( c<100 ) l=6;
+ else l=7;
+ if ( mpx->print_col+l>line_length-2 ) {
+ if ( mpx->state==normal ) {
+ fprintf(mpx->mpxfile,"\""); mpx->state=special;
+ }
+ fprintf(mpx->mpxfile,"\n");
+ mpx->print_col=0;
+ }
+ @<Print |c| and update |state| and |print_col|@>;
+}
+
+@ @<Print |c| and update |state| and |print_col|@>=
+if ( mpx->state==normal ) {
+ if ( printable(c) ) {
+ fprintf(mpx->mpxfile,"%c",xchr(c));
+ } else {
+ fprintf(mpx->mpxfile,"\"&char%d",c);
+ mpx->print_col +=2;
+ }
+} else {
+ if ( mpx->state==special ) {
+ fprintf(mpx->mpxfile,"&");
+ incr(mpx->print_col);
+ }
+ if ( printable(c) ) {
+ fprintf(mpx->mpxfile,"\"%c",xchr(c));
+ incr(mpx->print_col);
+ } else {
+ fprintf(mpx->mpxfile,"char%d",c);
+ }
+}
+mpx->print_col += l;
+if ( printable(c) )
+ mpx->state=normal;
+else
+ mpx->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@>=
+static void mpx_end_char_string (MPX mpx,web_integer l) {
+ while ( mpx->state>special ){
+ fprintf(mpx->mpxfile,"\"");
+ incr(mpx->print_col);
+ decr(mpx->state);
+ }
+ if ( mpx->print_col+l>line_length ) {
+ fprintf(mpx->mpxfile,"\n "); mpx->print_col=0;
+ }
+ mpx->state=initial; /* get ready to print the next string */
+}
+
+@ Since |end_char_string| resets |state:=initial|, all we have to do is set
+|state:=initial| once at the beginning.
+
+@<Set init...@>=
+mpx->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...@>=
+web_integer h;
+web_integer v; /* the current position in \.{DVI} units */
+double conv; /* converts \.{DVI} units to \MP\ points */
+double mag; /* magnification factor times 1000 */
+
+@ @c @<Declare a procedure called |finish_last_char|@>@;
+static void mpx_do_set_char (MPX mpx,web_integer f, web_integer c) {
+ if ( (c<mpx->font_bc[f])||(c>mpx->font_ec[f]) )
+ mpx_abort(mpx,"attempt to typeset invalid character %d",c);
+@.attempt to typeset...@>
+ if ((mpx->h!=mpx->str_h2)||(mpx->v!=mpx->str_v)||
+ (f!=mpx->str_f)||(mpx->dvi_scale!=mpx->str_scale) ) {
+ if ( mpx->str_f>=0 ) {
+ mpx_finish_last_char(mpx);
+ } else if ( ! mpx->fonts_used ) {
+ @<Prepare to output the first character on a page@>;
+ }
+ if ( ! mpx->font_used[f] )
+ @<Prepare to use font |f| for the first time on a page@>;
+ fprintf(mpx->mpxfile,"_s("); mpx->print_col=3;@/
+ mpx->str_scale=mpx->dvi_scale; mpx->str_f=f;
+ mpx->str_v=mpx->v; mpx->str_h1=mpx->h;
+ }
+ mpx_print_char(mpx, (unsigned char)c);
+ mpx->str_h2=(web_integer)(mpx->h+@<Width of character |c| in font |f|@>);
+}
+
+@ @<Glob...@>=
+boolean font_used[(max_fonts+1)]; /* has this font been used on this page? */
+boolean fonts_used; /* has any font been used on this page? */
+boolean rules_used; /* has any rules been set on this page? */
+web_integer str_h1;
+web_integer str_v; /* starting position for current output string */
+web_integer str_h2; /* where the current output string ends */
+web_integer str_f; /* internal font number for the current output string */
+double str_scale; /* value of |dvi_scale| for the current output string */
+
+
+@ Before using any fonts we need to define a MetaPost macro for
+typesetting character strings. The |font_used| array is not
+initialized until it is actually time to output a character.
+
+@<Declarations@>=
+static void mpx_prepare_font_use(MPX mpx);
+
+@ @c
+static void mpx_prepare_font_use(MPX mpx) {
+ unsigned k;
+ for (k=0; k<mpx->nfonts;k++ )
+ mpx->font_used[k]=false;
+ mpx->fonts_used=true;
+ fprintf(mpx->mpxfile,"string _n[];\n");
+ fprintf(mpx->mpxfile,"vardef _s(expr _t,_f,_m,_x,_y)(text _c)=\n");
+ fprintf(mpx->mpxfile,
+ " addto _p also _t infont _f scaled _m shifted (_x,_y) _c; enddef;\n");
+}
+
+@ @<Prepare to output the first character on a page@>=
+mpx_prepare_font_use(mpx)
+
+
+@ @<Do any other initialization required for the new font |f|@>=
+mpx->font_used[f]=false;
+
+@ Do what is necessary when the font with internal number f is used for the
+first time on a page.
+
+@<Declarations@>=
+static void mpx_first_use(MPX mpx, int f) ;
+
+@ @c
+static void mpx_first_use(MPX mpx, int f) {
+ mpx->font_used[f]=true;
+ fprintf(mpx->mpxfile,"_n%d=",f);
+ mpx->print_col=6;
+ mpx_print_font(mpx, f);
+ mpx_end_char_string(mpx, 1);
+ fprintf(mpx->mpxfile,";\n");
+}
+
+@ @<Prepare to use font |f| for the first time on a page@>=
+mpx_first_use(mpx,f);
+
+@ We maintain the invariant that |str_f=-1| when there is no output string
+under construction.
+
+@<Declare a procedure called |finish_last_char|@>=
+static void mpx_finish_last_char (MPX mpx) {
+ double m,x,y;
+ /* font scale factor and \MP\ coordinates of reference point */
+ if ( mpx->str_f>=0 ) {
+ if (mpx->mode==mpx_tex_mode) {
+ m=mpx->str_scale*mpx->font_scaled_size[mpx->str_f]*
+ mpx->mag/mpx->font_design_size[mpx->str_f];
+ x=mpx->conv*mpx->str_h1;
+ y=mpx->conv*(-mpx->str_v);
+ if ( (fabs(x)>=4096.0)||(fabs(y)>=4096.0)||(m>=4096.0)||(m<0) ) {
+ mpx_warn(mpx,"text is out of range");
+ mpx_end_char_string(mpx, 60);
+ } else {
+ mpx_end_char_string(mpx, 40);
+ }
+ fprintf(mpx->mpxfile,",_n%d,%1.5f,%1.4f,%1.4f,",mpx->str_f,m,x,y);
+ @<Print a \.{withcolor} specifier if appropriate@>@/
+ fprintf(mpx->mpxfile,");\n");
+ } else {
+ m = mpx->str_size / mpx->font_design_size[mpx->str_f];
+ x = mpx->dmp_str_h1 * mpx->unit;
+ y = YCORR - mpx->dmp_str_v * mpx->unit;
+ if (fabs(x) >= 4096.0 || fabs(y) >= 4096.0 || m >= 4096.0 || m < 0) {
+ mpx_warn(mpx,"text out of range ignored");
+ mpx_end_char_string(mpx,67);
+ } else {
+ mpx_end_char_string(mpx,47);
+ }
+ fprintf(mpx->mpxfile, "), _n%d", mpx->str_f);
+ fprintf(mpx->mpxfile, ",%.5f,%.4f,%.4f)", (m*1.00375), (x/100.0), y);
+ mpx_slant_and_ht(mpx);
+ fprintf(mpx->mpxfile, ";\n");
+ }
+ mpx->str_f=-1;
+ }
+}
+
+@ Setting rules is fairly simple.
+
+@c
+static void mpx_do_set_rule (MPX mpx,web_integer ht, web_integer wd) {
+ double xx1,yy1,xx2,yy2,ww;
+ /* \MP\ coordinates of lower-left and upper-right corners */
+ if ( wd==1 ) {
+ @<Handle a special rule that determines the box size@>
+ } else if ( (ht>0)||(wd>0) ) {
+ if ( mpx->str_f>=0 )
+ mpx_finish_last_char(mpx);
+ if ( ! mpx->rules_used ) {
+ mpx->rules_used=true;
+ fprintf(mpx->mpxfile,
+ "interim linecap:=0;\n"
+ "vardef _r(expr _a,_w)(text _t) =\n"
+ " addto _p doublepath _a withpen pencircle scaled _w _t enddef;");
+ }
+ @<Make |(xx1,yy1)| and |(xx2,yy2)| then ends of the desired penstroke
+ and |ww| the desired stroke width@>;
+ if ( (fabs(xx1)>=4096.0)||(fabs(yy1)>=4096.0)||@|
+ (fabs(xx2)>=4096.0)||(fabs(yy2)>=4096.0)||(ww>=4096.0) )
+ mpx_warn(mpx,"hrule or vrule is out of range");
+ fprintf(mpx->mpxfile,"_r((%1.4f,%1.4f)..(%1.4f,%1.4f), %1.4f,",xx1,yy1,xx2,yy2,ww);
+ @<Print a \.{withcolor} specifier if appropriate@>@/
+ fprintf(mpx->mpxfile,");\n");
+ }
+}
+
+@ @<Make |(xx1,yy1)| and |(xx2,yy2)| then ends of the desired penstroke...@>=
+xx1=mpx->conv*mpx->h;
+yy1=mpx->conv*(-mpx->v);
+if ( wd>ht ){
+ xx2=xx1+mpx->conv*wd;
+ ww=mpx->conv*ht;
+ yy1=yy1+0.5*ww;
+ yy2=yy1;
+} else {
+ yy2=yy1+mpx->conv*ht;
+ ww=mpx->conv*wd;
+ xx1=xx1+0.5*ww;
+ xx2=xx1;
+}
+
+@ 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@>=
+{
+ mpx->pic_wd=mpx->h; mpx->pic_dp=mpx->v; mpx->pic_ht=ht-mpx->v;
+}
+
+@ @<Glob...@>=
+web_integer pic_dp; web_integer pic_ht; web_integer pic_wd; /* 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.
+
+@c
+static void mpx_start_picture (MPX mpx) {
+ mpx->fonts_used=false;
+ mpx->rules_used=false;
+ mpx->graphics_used=false;
+ mpx->str_f=-1;
+ mpx->str_v=0;
+ mpx->str_h2=0;
+ mpx->str_scale=1.0; /* values don't matter */
+ mpx->dmp_str_v = 0.0;
+ mpx->dmp_str_h2 = 0.0;
+ mpx->str_size = 0.0;
+ fprintf(mpx->mpxfile,
+ "begingroup save %s_p,_r,_s,_n; picture _p; _p=nullpicture;\n",
+ (mpx->mode == mpx_tex_mode ? "" : "_C,_D,"));
+}
+
+static void mpx_stop_picture (MPX mpx) {
+ double w,h,dd; /* width, height, negative depth in PostScript points */
+ if ( mpx->str_f>=0 )
+ mpx_finish_last_char(mpx);
+ if (mpx->mode==mpx_tex_mode) {
+ @<Print a \&{setbounds} command based on picture dimensions@>;
+ }
+ fprintf(mpx->mpxfile,"_p endgroup\n");
+}
+
+@ @<Print a \&{setbounds} command based on picture dimensions@>=
+dd=-mpx->pic_dp*mpx->conv;
+w=mpx->conv*mpx->pic_wd;
+h=mpx->conv*mpx->pic_ht;
+fprintf(mpx->mpxfile,
+ "setbounds _p to (0,%1.4f)--(%1.4f,%1.4f)--\n"
+ " (%1.4f,%1.4f)--(0,%1.4f)--cycle;\n",dd,w,dd,w,h,h)
+
+@* 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 |web_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...@>=
+web_integer w;web_integer x;web_integer y;web_integer z;
+ /* current state values (|h| and |v| have already been declared) */
+web_integer hstack[(stack_size+1)];
+web_integer vstack[(stack_size+1)];
+web_integer wstack[(stack_size+1)];
+web_integer xstack[(stack_size+1)];
+web_integer ystack[(stack_size+1)];
+web_integer zstack[(stack_size+1)]; /* pushed down values in \.{DVI} units */
+web_integer stk_siz; /* the current stack size */
+double dvi_scale; /* converts units of current input source to \.{DVI} units */
+
+@ @<Do initialization required before starting a new page@>=
+mpx->dvi_scale=1.0;
+mpx->stk_siz=0;
+mpx->h=0; mpx->v=0;
+mpx->Xslant = 0.0; mpx->Xheight = 0.0
+
+@ Next, we need procedures to handle |push| and |pop| commands.
+
+@c @<Declare procedures to handle color commands@>
+static void mpx_do_push (MPX mpx) {
+ if ( mpx->stk_siz==stack_size )
+ mpx_abort(mpx,"DVItoMP capacity exceeded (stack size=%d)",stack_size);
+@.DVItoMP capacity exceeded...@>
+ mpx->hstack[mpx->stk_siz]=mpx->h;
+ mpx->vstack[mpx->stk_siz]=mpx->v; mpx->wstack[mpx->stk_siz]=mpx->w;
+ mpx->xstack[mpx->stk_siz]=mpx->x;
+ mpx->ystack[mpx->stk_siz]=mpx->y; mpx->zstack[mpx->stk_siz]=mpx->z;
+ incr(mpx->stk_siz);
+}
+
+static void mpx_do_pop (MPX mpx) {
+ if ( mpx->stk_siz==0 )
+ bad_dvi("attempt to pop empty stack");
+ else {
+ decr(mpx->stk_siz);
+ mpx->h=mpx->hstack[mpx->stk_siz];
+ mpx->v=mpx->vstack[mpx->stk_siz]; mpx->w=mpx->wstack[mpx->stk_siz];
+ mpx->x=mpx->xstack[mpx->stk_siz];
+ mpx->y=mpx->ystack[mpx->stk_siz]; mpx->z=mpx->zstack[mpx->stk_siz];
+ }
+}
+
+@ The |set_virtual_char| procedure 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.
+
+@c
+static void mpx_do_dvi_commands (MPX mpx);
+static void mpx_set_virtual_char (MPX mpx,web_integer f, web_integer c) {
+ double old_scale; /* original value of |dvi_scale| */
+ unsigned old_buf_ptr; /* original value of the input pointer |buf_ptr| */
+ unsigned old_fbase,old_ftop; /* originally applicable part of the |font_num| table */
+ if ( mpx->fbase[f]==0 )
+ mpx_do_set_char(mpx, f,c);
+ else {
+ old_fbase=mpx->cur_fbase; old_ftop=mpx->cur_ftop;
+ mpx->cur_fbase=(unsigned int)mpx->fbase[f];
+ mpx->cur_ftop=(unsigned int)mpx->ftop[f];
+ old_scale=mpx->dvi_scale;
+ mpx->dvi_scale=mpx->dvi_scale*mpx->font_scaled_size[f];
+ old_buf_ptr=mpx->buf_ptr;
+ mpx->buf_ptr=(unsigned int)start_cmd(f,c);
+ mpx_do_push(mpx);
+ mpx_do_dvi_commands(mpx);
+ mpx_do_pop(mpx);@/
+ mpx->buf_ptr=old_buf_ptr;
+ mpx->dvi_scale=old_scale;
+ mpx->cur_fbase=old_fbase;
+ mpx->cur_ftop=old_ftop;
+ }
+}
+
+@ 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(A) (A): case (A)+1: case (A)+2: case (A)+3
+@d eight_cases(A) four_cases((A)): case four_cases((A)+4)
+@d sixteen_cases(A) eight_cases((A)): case eight_cases((A)+8)
+@d thirty_two_cases(A) sixteen_cases((A)): case sixteen_cases((A)+16)
+@d sixty_four_cases(A) thirty_two_cases((A)): case thirty_two_cases((A)+32)
+
+@<Declare a function called |first_par|@>=
+static web_integer mpx_first_par (MPX mpx, unsigned int o) {
+ switch (o) {
+ case sixty_four_cases(set_char_0):
+ case sixty_four_cases(set_char_0+64):
+ return (web_integer)(o-set_char_0);
+ break;
+ case set1: case put1: case fnt1: case xxx1: case fnt_def1:
+ return mpx_get_byte(mpx);
+ break;
+ case set1+1: case put1+1: case fnt1+1: case xxx1+1: case fnt_def1+1:
+ return mpx_get_two_bytes(mpx);
+ break;
+ case set1+2: case put1+2: case fnt1+2: case xxx1+2: case fnt_def1+2:
+ return mpx_get_three_bytes(mpx);
+ break;
+ case right1: case w1: case x1: case down1: case y1: case z1:
+ return mpx_signed_byte(mpx);
+ break;
+ case right1+1: case w1+1: case x1+1: case down1+1: case y1+1: case z1+1:
+ return mpx_signed_pair(mpx);
+ break;
+ case right1+2: case w1+2: case x1+2: case down1+2: case y1+2: case z1+2:
+ return mpx_signed_trio(mpx);
+ break;
+ case set1+3: case set_rule: case put1+3: case put_rule:
+ case right1+3: case w1+3: case x1+3: case down1+3: case y1+3: case z1+3:
+ case fnt1+3: case xxx1+3: case fnt_def1+3:
+ return mpx_signed_quad(mpx);
+ break;
+ case nop: case bop: case eop: case push: case pop: case pre: case post:
+ case post_post: case undefined_commands:
+ return 0;
+ break;
+ case w0: return mpx->w; break;
+ case x0: return mpx->x; break;
+ case y0: return mpx->y; break;
+ case z0: return mpx->z; break;
+ case sixty_four_cases(fnt_num_0):
+ return (web_integer)(o-fnt_num_0);
+ break;
+ }
+ return 0; /* compiler warning */
+}
+
+@ Here is the |do_dvi_commands| procedure.
+
+@c
+static void mpx_do_dvi_commands (MPX mpx) {
+ unsigned int o; /* operation code of the current command */
+ web_integer p,q; /* parameters of the current command */
+ web_integer cur_font; /* current internal font number */
+ if ( (mpx->cur_fbase<mpx->cur_ftop) && (mpx->buf_ptr<virtual_space) )
+ cur_font=mpx_select_font(mpx, mpx->font_num[mpx->cur_ftop-1]); /* select first local font */
+ else
+ cur_font=max_fnums+1; /* current font is undefined */
+ mpx->w=0; mpx->x=0; mpx->y=0; mpx->z=0; /* initialize the state variables */
+ while ( true ) {
+ @<Translate the next command in the \.{DVI} file; |return| if it was |eop|@>;
+ }
+}
+
+@ 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...@>=
+{
+ o=(unsigned int)mpx_get_byte(mpx);
+ p=mpx_first_par(mpx, o);
+ if ( feof(mpx->dvi_file) )
+ bad_dvi("the DVI file ended prematurely");
+@.the DVI file ended prematurely@>
+ if ( o<set1+4 ) { /* |set_char_0| through |set_char_127|, |set1| through |set4| */
+ if ( cur_font>max_fnums ) {
+ if ( mpx->vf_reading )
+ mpx_abort(mpx,"no font selected for character %d in virtual font", p);
+ else
+ bad_dvi_two("no font selected for character %d",p);
+ }
+@.no font selected@>
+ mpx_set_virtual_char(mpx, cur_font,p);
+ mpx->h += @<Width of character |p| in font |cur_font|@>;
+ } else {
+ switch(o) {
+ case four_cases(put1):
+ mpx_set_virtual_char(mpx, cur_font, p);
+ break;
+ case set_rule:
+ q=(web_integer)trunc(mpx_signed_quad(mpx)*mpx->dvi_scale);
+ mpx_do_set_rule(mpx, (web_integer)trunc(p*mpx->dvi_scale),q);
+ mpx->h += q;
+ break;
+ case put_rule:
+ q=(web_integer)trunc(mpx_signed_quad(mpx)*mpx->dvi_scale);
+ mpx_do_set_rule(mpx, (web_integer)trunc(p*mpx->dvi_scale),q);
+ break;
+ @<Additional cases for translating \.{DVI} command |o| with
+ first parameter |p|@>@;
+ case undefined_commands:
+ bad_dvi_two("undefined command %d",o);
+@.undefined command@>
+ break;
+ } /* all cases have been enumerated */
+ }
+}
+
+@ @<Additional cases for translating \.{DVI} command |o|...@>=
+case four_cases(xxx1):
+ mpx_do_xxx(mpx, p);
+ break;
+case pre: case post: case post_post:
+ bad_dvi("preamble or postamble within a page!");
+@.preamble or postamble within a page@>
+ break;
+
+@ @<Additional cases for translating \.{DVI} command |o|...@>=
+case nop:
+ break;
+case bop:
+ bad_dvi("bop occurred before eop");
+@.bop occurred before eop@>
+ break;
+case eop:
+ return;
+ break;
+case push:
+ mpx_do_push(mpx);
+ break;
+case pop:
+ mpx_do_pop(mpx);
+ break;
+
+@ @<Additional cases for translating \.{DVI} command |o|...@>=
+case four_cases(right1):
+ mpx->h += trunc(p*mpx->dvi_scale);
+ break;
+case w0: case four_cases(w1):
+ mpx->w = (web_integer)trunc(p*mpx->dvi_scale); mpx->h += mpx->w;
+ break;
+case x0: case four_cases(x1):
+ mpx->x = (web_integer)trunc(p*mpx->dvi_scale); mpx->h += mpx->x;
+ break;
+case four_cases(down1):
+ mpx->v += trunc(p*mpx->dvi_scale);
+ break;
+case y0: case four_cases(y1):
+ mpx->y = (web_integer)trunc(p*mpx->dvi_scale); mpx->v += mpx->y;
+ break;
+case z0: case four_cases(z1):
+ mpx->z = (web_integer)trunc(p*mpx->dvi_scale); mpx->v += mpx->z;
+ break;
+
+@ @<Additional cases for translating \.{DVI} command |o|...@>=
+case sixty_four_cases(fnt_num_0): case four_cases(fnt1):
+ cur_font = mpx_select_font(mpx, p);
+ break;
+case four_cases(fnt_def1):
+ mpx_define_font(mpx, p);
+ break;
+
+@* The main program.
+Now we are ready to put it all together. This is where \.{DVItoMP} starts,
+and where it ends.
+
+@c
+static int mpx_dvitomp (MPX mpx, char *dviname) {
+ int k;
+ mpx->dviname = dviname;
+ mpx_open_dvi_file(mpx);
+ @<Process the preamble@>;
+ mpx_open_mpxfile(mpx);
+ if (mpx->banner!=NULL)
+ fprintf (mpx->mpxfile,"%s\n",mpx->banner);
+ while ( true ) {
+ @<Advance to the next |bop| command@>;
+ for (k=0;k<=10;k++)
+ (void)mpx_signed_quad(mpx);
+ @<Do initialization required before starting a new page@>;
+ mpx_start_picture(mpx);
+ mpx_do_dvi_commands(mpx);
+ if ( mpx->stk_siz!=0 )
+ bad_dvi("stack not empty at end of page");
+@.stack not empty...@>
+ mpx_stop_picture(mpx);
+ fprintf(mpx->mpxfile,"mpxbreak\n");
+ }
+ if(mpx->dvi_file)
+ mpx_fclose(mpx,mpx->dvi_file);
+ if ( mpx->history<=mpx_cksum_trouble )
+ return 0;
+ else
+ return mpx->history;
+}
+
+@ The main program needs a few global variables in order to do its work.
+
+@<Glob...@>=
+web_integer k;web_integer p; /* general purpose registers */
+web_integer numerator;web_integer denominator; /* stated conversion ratio */
+
+@ @<Process the preamble@>=
+{
+ int p;
+ p=mpx_get_byte(mpx); /* fetch the first byte */
+ if ( p!=pre )
+ bad_dvi("First byte isn""t start of preamble!");
+@.First byte isn't...@>
+ p=mpx_get_byte(mpx); /* fetch the identification byte */
+ if ( p!=id_byte )
+ mpx_warn(mpx,"identification in byte 1 should be %d!", id_byte);
+@.identification...should be n@>
+ @<Compute the conversion factor@>;
+ p=mpx_get_byte(mpx); /* fetch the length of the introductory comment */
+ while (p>0 ){
+ decr(p);
+ (void)mpx_get_byte(mpx);
+ }
+}
+
+@ 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@>=
+mpx->numerator=mpx_signed_quad(mpx); mpx->denominator=mpx_signed_quad(mpx);
+if ( (mpx->numerator<=0)||(mpx->denominator<=0) )
+ bad_dvi("bad scale ratio in preamble");
+@.bad scale ratio@>
+mpx->mag=mpx_signed_quad(mpx)/1000.0;
+if ( mpx->mag<=0.0 )
+ bad_dvi("magnification isn't positive");
+@.magnification isn't positive@>
+mpx->conv=(mpx->numerator/254000.0)*(72.0/mpx->denominator)*mpx->mag;
+mpx->dvi_per_fix=(254000.0/mpx->numerator)*(mpx->denominator/72.27)/1048576.0;
+
+@ @<Advance to the next |bop| command@>=
+do {
+ int p;
+ k=mpx_get_byte(mpx);
+ if ( (k>=fnt_def1)&&(k<fnt_def1+4) ){
+ p=mpx_first_par(mpx, (unsigned int)k);
+ mpx_define_font(mpx, p); k=nop;
+ }
+} while (k==nop);
+if ( k==post )
+ break;
+if ( k!=bop )
+ bad_dvi("missing bop");
+@.missing bop@>
+
+
+@ Global filenames.
+
+@<Global...@>=
+char *dviname;
+
+@* 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.
+
+@d max_named_colors 100 /* maximum number of distinct named colors */
+
+@ Then we declare a record for color types.
+
+@<Types...@>=
+typedef struct named_color_record {
+ const char *name; /* color name */
+ const char *value; /* text to pass to MetaPost */
+} named_color_record;
+
+@ Declare the named-color array itself.
+
+@<Globals@>=
+named_color_record named_colors[(max_named_colors+1)];
+ /* stores information about named colors, in sorted order by name */
+web_integer num_named_colors; /* number of elements of |named_colors| that are valid */
+
+@ This function, used only during initialization, defines a named color.
+
+@c
+static void mpx_def_named_color (MPX mpx, const char *n, const char *v) {
+ mpx->num_named_colors++;
+ assert(mpx->num_named_colors<max_named_colors);
+ mpx->named_colors[mpx->num_named_colors].name = n;
+ mpx->named_colors[mpx->num_named_colors].value = v;
+}
+
+@ @<Declarations@>=
+static void mpx_def_named_color (MPX mpx, const char *n, const char *v);
+
+@ During the initialization phase, we define values for all the named
+colors defined in \.{colordvi.tex}. CMYK-to-RGB conversion by GhostScript.
+
+This list has to be sorted alphabetically!
+
+@<Set initial values@>=
+mpx->num_named_colors = 0;
+mpx_def_named_color(mpx, "Apricot", "(1.0, 0.680006, 0.480006)");
+mpx_def_named_color(mpx, "Aquamarine", "(0.180006, 1.0, 0.7)");
+mpx_def_named_color(mpx, "Bittersweet", "(0.760012, 0.0100122, 0.0)");
+mpx_def_named_color(mpx, "Black", "(0.0, 0.0, 0.0)");
+mpx_def_named_color(mpx, "Blue", "(0.0, 0.0, 1.0)");
+mpx_def_named_color(mpx, "BlueGreen", "(0.15, 1.0, 0.669994)");
+mpx_def_named_color(mpx, "BlueViolet", "(0.1, 0.05, 0.960012)");
+mpx_def_named_color(mpx, "BrickRed", "(0.719994, 0.0, 0.0)");
+mpx_def_named_color(mpx, "Brown", "(0.4, 0.0, 0.0)");
+mpx_def_named_color(mpx, "BurntOrange", "(1.0, 0.489988, 0.0)");
+mpx_def_named_color(mpx, "CadetBlue", "(0.380006, 0.430006, 0.769994)");
+mpx_def_named_color(mpx, "CarnationPink", "(1.0, 0.369994, 1.0)");
+mpx_def_named_color(mpx, "Cerulean", "(0.0600122, 0.889988, 1.0)");
+mpx_def_named_color(mpx, "CornflowerBlue", "(0.35, 0.869994, 1.0)");
+mpx_def_named_color(mpx, "Cyan", "(0.0, 1.0, 1.0)");
+mpx_def_named_color(mpx, "Dandelion", "(1.0, 0.710012, 0.160012)");
+mpx_def_named_color(mpx, "DarkOrchid", "(0.6, 0.2, 0.8)");
+mpx_def_named_color(mpx, "Emerald", "(0.0, 1.0, 0.5)");
+mpx_def_named_color(mpx, "ForestGreen", "(0.0, 0.880006, 0.0)");
+mpx_def_named_color(mpx, "Fuchsia", "(0.45, 0.00998169, 0.919994)");
+mpx_def_named_color(mpx, "Goldenrod", "(1.0, 0.9, 0.160012)");
+mpx_def_named_color(mpx, "Gray", "(0.5, 0.5, 0.5)");
+mpx_def_named_color(mpx, "Green", "(0.0, 1.0, 0.0)");
+mpx_def_named_color(mpx, "GreenYellow", "(0.85, 1.0, 0.310012)");
+mpx_def_named_color(mpx, "JungleGreen", "(0.0100122, 1.0, 0.480006)");
+mpx_def_named_color(mpx, "Lavender", "(1.0, 0.519994, 1.0)");
+mpx_def_named_color(mpx, "LimeGreen", "(0.5, 1.0, 0.0)");
+mpx_def_named_color(mpx, "Magenta", "(1.0, 0.0, 1.0)");
+mpx_def_named_color(mpx, "Mahogany", "(0.65, 0.0, 0.0)");
+mpx_def_named_color(mpx, "Maroon", "(0.680006, 0.0, 0.0)");
+mpx_def_named_color(mpx, "Melon", "(1.0, 0.539988, 0.5)");
+mpx_def_named_color(mpx, "MidnightBlue", "(0.0, 0.439988, 0.569994)");
+mpx_def_named_color(mpx, "Mulberry", "(0.640018, 0.0800061, 0.980006)");
+mpx_def_named_color(mpx, "NavyBlue", "(0.0600122, 0.460012, 1.0)");
+mpx_def_named_color(mpx, "OliveGreen", "(0.0, 0.6, 0.0)");
+mpx_def_named_color(mpx, "Orange", "(1.0, 0.389988, 0.130006)");
+mpx_def_named_color(mpx, "OrangeRed", "(1.0, 0.0, 0.5)");
+mpx_def_named_color(mpx, "Orchid", "(0.680006, 0.360012, 1.0)");
+mpx_def_named_color(mpx, "Peach", "(1.0, 0.5, 0.3)");
+mpx_def_named_color(mpx, "Periwinkle", "(0.430006, 0.45, 1.0)");
+mpx_def_named_color(mpx, "PineGreen", "(0.0, 0.75, 0.160012)");
+mpx_def_named_color(mpx, "Plum", "(0.5, 0.0, 1.0)");
+mpx_def_named_color(mpx, "ProcessBlue", "(0.0399878, 1.0, 1.0)");
+mpx_def_named_color(mpx, "Purple", "(0.55, 0.139988, 1.0)");
+mpx_def_named_color(mpx, "RawSienna", "(0.55, 0.0, 0.0)");
+mpx_def_named_color(mpx, "Red", "(1.0, 0.0, 0.0)");
+mpx_def_named_color(mpx, "RedOrange", "(1.0, 0.230006, 0.130006)");
+mpx_def_named_color(mpx, "RedViolet", "(0.590018, 0.0, 0.660012)");
+mpx_def_named_color(mpx, "Rhodamine", "(1.0, 0.180006, 1.0)");
+mpx_def_named_color(mpx, "RoyalBlue", "(0.0, 0.5, 1.0)");
+mpx_def_named_color(mpx, "RoyalPurple", "(0.25, 0.1, 1.0)");
+mpx_def_named_color(mpx, "RubineRed", "(1.0, 0.0, 0.869994)");
+mpx_def_named_color(mpx, "Salmon", "(1.0, 0.469994, 0.619994)");
+mpx_def_named_color(mpx, "SeaGreen", "(0.310012, 1.0, 0.5)");
+mpx_def_named_color(mpx, "Sepia", "(0.3, 0.0, 0.0)");
+mpx_def_named_color(mpx, "SkyBlue", "(0.380006, 1.0, 0.880006)");
+mpx_def_named_color(mpx, "SpringGreen", "(0.739988, 1.0, 0.239988)");
+mpx_def_named_color(mpx, "Tan", "(0.860012, 0.580006, 0.439988)");
+mpx_def_named_color(mpx, "TealBlue", "(0.119994, 0.980006, 0.640018)");
+mpx_def_named_color(mpx, "Thistle", "(0.880006, 0.410012, 1.0)");
+mpx_def_named_color(mpx, "Turquoise", "(0.15, 1.0, 0.8)");
+mpx_def_named_color(mpx, "Violet", "(0.210012, 0.119994, 1.0)");
+mpx_def_named_color(mpx, "VioletRed", "(1.0, 0.189988, 1.0)");
+mpx_def_named_color(mpx, "White", "(1.0, 1.0, 1.0)");
+mpx_def_named_color(mpx, "WildStrawberry", "(1.0, 0.0399878, 0.610012)");
+mpx_def_named_color(mpx, "Yellow", "(1.0, 1.0, 0.0)");
+mpx_def_named_color(mpx, "YellowGreen", "(0.560012, 1.0, 0.260012)");
+mpx_def_named_color(mpx, "YellowOrange", "(1.0, 0.580006, 0.0)");
+
+@ Color commands get a separate warning procedure. |warn| sets |history :=
+mpx_warning_given|, which causes a nonzero exit status; but color errors are
+trivial and should leave the exit status zero.
+
+@d color_warn(A) mpx_warn(mpx,A)
+@d color_warn_two(A,B) mpx_warn(mpx,"%s%s",A,B)
+
+@ The |do_xxx| procedure handles DVI specials (defined with the |xxx1...xxx4| commands).
+
+@d XXX_BUF 256
+
+@<Declare procedures to handle color commands@>=
+static void mpx_do_xxx (MPX mpx, web_integer p)
+{
+ unsigned char buf[(XXX_BUF+1)]; /* FIXME: Fixed size buffer. */
+ web_integer l, r, m, k, len;
+ boolean found;
+ int bufsiz = XXX_BUF;
+ len = 0;
+ while ( ( p > 0) && (len < bufsiz) ) {
+ buf[len] = (unsigned char)mpx_get_byte(mpx);
+ decr(p); incr(len);
+ }
+ @<Check whether |buf| contains a color command; if not, |goto XXXX|@>
+ if ( p > 0 ) {
+ color_warn("long \"color\" special ignored");
+ goto XXXX;
+ }
+ if ( @<|buf| contains a color pop command@> ) {
+ @<Handle a color pop command@>
+ } else if ( @<|buf| contains a color push command@> ) {
+ @<Handle a color push command@>
+ } else {
+ color_warn("unknown \"color\" special ignored");
+ goto XXXX;
+ }
+XXXX:
+ for (k = 1;k<=p;k++) (void)mpx_get_byte(mpx);
+}
+
+@
+
+@<Check whether |buf| contains a color command; if not, |goto XXXX|@>=
+if ( (len <= 5)
+ || (buf[0] != 'c')
+ || (buf[1] != 'o')
+ || (buf[2] != 'l')
+ || (buf[3] != 'o')
+ || (buf[4] != 'r')
+ || (buf[5] != ' ')
+ ) goto XXXX;
+
+@ @<|buf| contains a color push command@>=
+(len >= 11) &&
+ (buf[6] == 'p') &&
+ (buf[7] == 'u') &&
+ (buf[8] == 's') &&
+ (buf[9] == 'h') &&
+ (buf[10] == ' ')
+
+@ @<|buf| contains a color pop command@>=
+(len == 9) &&
+(buf[6] == 'p') &&
+(buf[7] == 'o') &&
+(buf[8] == 'p')
+
+@ The \.{color push} and \.{pop} commands imply a color stack, so we need a
+global variable to hold that stack.
+
+@d max_color_stack_depth 10 /* maximum depth of saved color stack */
+
+@ Here's the actual stack variables.
+
+@<Globals@>=
+web_integer color_stack_depth; /* current depth of saved color stack */
+char *color_stack[(max_color_stack_depth+1)]; /* saved color stack */
+
+@ Initialize the stack to empty.
+
+@<Set initial values@>=
+mpx->color_stack_depth = 0;
+
+@ \.{color pop} just pops the stack.
+
+@<Handle a color pop command@>=
+mpx_finish_last_char(mpx);
+if (mpx->color_stack_depth > 0 ) {
+ free(mpx->color_stack[mpx->color_stack_depth]);
+ decr(mpx->color_stack_depth);
+} else {
+ color_warn("color stack underflow");
+}
+
+@ \.{color push} pushes a color onto the stack.
+
+@<Handle a color push command@>=
+mpx_finish_last_char(mpx);
+if ( mpx->color_stack_depth >= max_color_stack_depth )
+ mpx_abort(mpx,"color stack overflow");
+incr(mpx->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) && (buf[l] == ' ') ) incr(l);
+if ( @<|buf[l]| contains an rgb command@> ) {
+ @<Handle a color push rgb command@>
+} else if ( @<|buf[l]| contains a cmyk command@> ) {
+ @<Handle a color push cmyk command@>
+} else if ( @<|buf[l]| contains a gray command@> ) {
+ @<Handle a color push gray command@>
+} else {
+ @<Handle a named color push command@>
+}
+
+@ @<|buf[l]| contains an rgb command@>=
+(l + 4 < len)
+&& (buf[l] == 'r')
+&& (buf[l+1] == 'g')
+&& (buf[l+2] == 'b')
+&& (buf[l+3] == ' ')
+
+@ @<Handle a color push rgb command@>=
+l = l + 4;
+while ( (l < len) && (buf[l] == ' ') ) incr(l); /* Remove spaces at end of buf */
+while ( (len > l) && (buf[len - 1] == ' ') ) decr(len);
+mpx->color_stack[mpx->color_stack_depth]=xmalloc((size_t)(len-l+3),1);
+k = 0;
+@<Copy |buf[l]| to |color_stack[color_stack_depth][k]| in tuple form@>
+
+@ @<|buf[l]| contains a gray command@>=
+(l + 5 < len)
+&& (buf[l] == 'g')
+&& (buf[l+1] == 'r')
+&& (buf[l+2] == 'a')
+&& (buf[l+3] == 'y')
+&& (buf[l+4] == ' ')
+
+@ @<Handle a color push gray command@>=
+l = l + 5;
+while ( (l < len) && (buf[l] == ' ') ) incr(l); /* Remove spaces at end of buf */
+while ( (len > l) && (buf[len - 1] == ' ') ) decr(len);
+mpx->color_stack[mpx->color_stack_depth]=xmalloc((size_t)(len-l+9),1);
+strcpy(mpx->color_stack[mpx->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)
+&& (buf[l] == 'c')
+&& (buf[l+1] == 'm')
+&& (buf[l+2] == 'y')
+&& (buf[l+3] == 'k')
+&& (buf[l+4] == ' ')
+
+@ @<Handle a color push cmyk command@>=
+l = l + 5;
+while ( (l < len) && (buf[l] == ' ') ) incr(l);
+/* Remove spaces at end of buf */
+while ( (len > l) && (buf[len - 1] == ' ') ) decr(len);
+mpx->color_stack[mpx->color_stack_depth]=xmalloc((size_t)(len-l+7),1);
+strcpy(mpx->color_stack[mpx->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@>=
+mpx->color_stack[mpx->color_stack_depth][k] = '(';
+incr(k);
+while ( l < len ) {
+ if ( buf[l] == ' ' ) {
+ mpx->color_stack[mpx->color_stack_depth][k] = ',';
+ while ( (l < len) && (buf[l] == ' ') ) incr(l);
+ incr(k);
+ } else {
+ mpx->color_stack[mpx->color_stack_depth][k] = (char)buf[l];
+ incr(l);
+ incr(k);
+ }
+}
+mpx->color_stack[mpx->color_stack_depth][k] = ')';
+mpx->color_stack[mpx->color_stack_depth][k+1] = 0;
+
+@ Binary-search the |named_colors| array, then push the found color onto
+the stack.
+
+@<Handle a named color push command@>=
+for (k = l;k<=len - 1;k++) {
+ buf[k - l] = xchr(buf[k]);
+}
+buf[len - l] = 0;
+/* clang: never read: len = len - l; */
+l = 1; r = mpx->num_named_colors;
+found = false;
+while ( (l <= r) && ! found ) {
+ m = (l + r) / 2; k = strcmp((char *)(buf), mpx->named_colors[m].name);
+ if ( k == 0 ) {
+ mpx->color_stack[mpx->color_stack_depth]=xstrdup(mpx->named_colors[m].value);
+ found = true;
+ } else if ( k < 0 ) {
+ r = m - 1;
+ } else {
+ l = m + 1;
+ }
+}
+if (! found ) {
+ color_warn_two("non-hardcoded color \"%s\" in \"color push\" command", buf);
+ mpx->color_stack[mpx->color_stack_depth]=xstrdup((char *)(buf));
+}
+
+@ 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 ( mpx->color_stack_depth > 0 ) {
+ fprintf(mpx->mpxfile," withcolor %s\n",mpx->color_stack[mpx->color_stack_depth]);
+}
+
+
+@* \[4] Dmp.
+
+This program reads device-independent troff output files,
+and converts them into a symbolic form understood by MetaPost. Some
+of the code was borrowed from DVItoMP. It understands all the D? graphics
+functions that dpost does but it ignores `x X' device control functions
+such as `x X SetColor:...', `x X BeginPath:', and `x X DrawPath:...'.
+
+The output file is a sequence of MetaPost picture expressions, one for every
+page in the input file. It makes no difference where the input file comes
+from, but it is intended to process the result of running eqn and troff on
+the output of MPtoTR. Such a file contains one page for every btex...etex
+block in the original input. This program then creates a corresponding
+sequence of MetaPost picture expressions for use as an auxiliary input file.
+Since MetaPost expects such files to have the extension .mpx, the output
+is sometimes called an `mpx' file.
+
+@d SHIFTS 100 /* maximum number of characters with special shifts */
+@d MAXCHARS 256 /* character codes fall in the range 0..MAXCHARS-1 */
+
+@d is_specchar(c) (!mpx->gflag && (c)<=2) /* does charcode c identify a special char? */
+@d LWscale 0.03 /* line width for graphics as a fraction of pointsize */
+@d YCORR 12.0 /* V coordinate of reference point in (big) points */
+
+@<Globals@>=
+int next_specfnt[(max_fnums+1)]; /* used to link special fonts together */
+int shiftchar[SHIFTS]; /* charcode of character to shift, else -1 */
+float shifth[SHIFTS];
+float shiftv[SHIFTS]; /* shift vals/fontsize (y is upward) */
+int shiftptr; /* number of entries in shift tables */
+int shiftbase[(max_fnums+1)]; /* initial index into shifth,shiftv,shiftchar */
+int specfnt; /* int. num. of first special font (or FCOUNT) */
+int *specf_tail ; /* tail of specfnt list |(*specf_tail==FCOUNT)| */
+float cursize; /* current type size in (big) points */
+unsigned int curfont; /* internal number for current font */
+float Xslant; /* degrees additional slant for all fonts */
+float Xheight; /* yscale fonts to this height if nonzero */
+float sizescale; /* groff font size scaling factor */
+int gflag; /* non-zero if using groff fonts */
+float unit; /* (big) points per troff unit (0 when unset) */
+
+@ @<Set initial...@>=
+mpx->shiftptr = 0;
+mpx->specfnt = (max_fnums+1);
+mpx->specf_tail = &(mpx->specfnt);
+mpx->unit = 0.0;
+mpx->lnno = 0; /* this is a reset */
+mpx->gflag = 0;
+mpx->h = 0; mpx->v = 0;
+
+@ @<Makempx header information@>=
+typedef char *(*mpx_file_finder)(MPX, const char *, const char *, int);
+enum mpx_filetype {
+ mpx_tfm_format, /* |kpse_tfm_format| */
+ mpx_vf_format, /* |kpse_vf_format| */
+ mpx_trfontmap_format, /* |kpse_mpsupport_format| */
+ mpx_trcharadj_format, /* |kpse_mpsupport_format| */
+ mpx_desc_format, /* |kpse_troff_font_format| */
+ mpx_fontdesc_format, /* |kpse_troff_font_format| */
+ mpx_specchar_format /* |kpse_mpsupport_format| */
+};
+
+@ @<Globals@>=
+mpx_file_finder find_file;
+
+@ @<Declarations@>=
+static char *mpx_find_file (MPX mpx, const char *nam, const char *mode, int ftype);
+
+@ @c
+static char *mpx_find_file (MPX mpx, const char *nam, const char *mode, int ftype) {
+ (void) mpx;
+ if (mode[0] != 'r' || (! access (nam,R_OK)) || ftype) {
+ return strdup(nam);
+ }
+ return NULL;
+}
+
+@ @<Set initial...@>=
+mpx->find_file = mpx_find_file;
+
+@ @<Declarations@>=
+static FILE *mpx_fsearch(MPX mpx, const char *nam, int format);
+
+@ @c
+static FILE *mpx_fsearch(MPX mpx, const char *nam, int format) {
+ FILE *f = NULL;
+ char *fname = (mpx->find_file)(mpx, nam, "r", format);
+ if (fname) {
+ f = fopen(fname, "rb");
+ mpx_report(mpx,"%p = fopen(%s,\"rb\")",f, fname);
+ }
+ return f;
+}
+
+@ Hash tables (or rather: AVL lists)
+
+@ @<Types...@>=
+typedef struct {
+ char *name;
+ int num;
+} avl_entry;
+
+@ @c
+static int mpx_comp_name (void *p, const void *pa, const void *pb) {
+ (void)p;
+ return strcmp (((const avl_entry *) pa)->name,
+ ((const avl_entry *) pb)->name);
+}
+static void *destroy_avl_entry (void *pa) {
+ avl_entry *p;
+ p = (avl_entry *) pa;
+ free (p->name);
+ free (p);
+ return NULL;
+}
+static void *copy_avl_entry (const void *pa) { /* never used */
+ const avl_entry *p;
+ avl_entry *q;
+ p = (const avl_entry *) pa;
+ q = malloc(sizeof(avl_entry));
+ if (q!=NULL) {
+ q->name = strdup(p->name);
+ q->num = p->num;
+ }
+ return (void *)q;
+}
+
+
+@ @c
+static avl_tree mpx_avl_create (MPX mpx) {
+ avl_tree t;
+ t = avl_create(mpx_comp_name,
+ copy_avl_entry,
+ destroy_avl_entry,
+ malloc, free, NULL);
+ if (t==NULL)
+ mpx_abort(mpx, "Memory allocation failure");
+ return t;
+}
+
+@ The only two operations on AVL lists are finding already existing
+items, or interning new items. Finding is handled by explicit |avl_find|
+calls where needed, but it is wise to have a wrapper around |avl_probe|
+to check for memory errors.
+
+@c
+static void mpx_avl_probe(MPX mpx, avl_tree tab, avl_entry *p) {
+ avl_entry *r = (avl_entry *)avl_find(p, tab);
+ if (r==NULL) {
+ if (avl_ins (p, tab, avl_false)<0)
+ mpx_abort(mpx,"Memory allocation failure");
+ }
+}
+
+
+@ Scanning Numbers
+
+The standard functions atoi(), atof(), and sscanf() provide ways of reading
+numbers from strings but they give no indication of how much of the string
+is consumed. These homemade versions don't parse scientific notation.
+
+@<Globals@>=
+char *arg_tail; /* char after the number just gotten; NULL on failure */
+
+@ @c
+static int mpx_get_int(MPX mpx, char *s) {
+ register int i, d, neg;
+ if (s == NULL)
+ goto BAD;
+ for (neg = 0;; s++) {
+ if (*s == '-')
+ neg = !neg;
+ else if (*s != ' ' && *s != '\t')
+ break;
+ }
+ if (i = *s - '0', 0 > i || i > 9)
+ goto BAD;
+ while (d = *++s - '0', 0 <= d && d <= 9)
+ i = 10 * i + d;
+ mpx->arg_tail = s;
+ return neg ? -i : i;
+ BAD:
+ mpx->arg_tail = NULL;
+ return 0;
+}
+
+@ GROFF font description files use octal character codes
+|groff_font(5)|: The code can be any |web_integer|. If it starts with
+a 0 it will be interpreted as octal; if it starts with 0x
+or 0X it will be intepreted as hexadecimal.
+
+@c
+static int mpx_get_int_map(MPX mpx, char *s) {
+ register int i;
+ if (s == NULL)
+ goto BAD;
+ i = (int)strtol(s, &(mpx->arg_tail), 0);
+ if (s == mpx->arg_tail)
+ goto BAD;
+ return i;
+BAD:
+ mpx->arg_tail = NULL;
+ return 0;
+}
+
+@ Troff output files contain few if any non-|web_integers|, but this program is
+prepared to read floats whenever they seem reasonable; i.e., when the
+number is not being used for character positioning. (For non-PostScript
+applications h and v are usually in pixels and should be |web_integers|.)
+
+@c
+static float mpx_get_float(MPX mpx, char *s) {
+ register int d, neg, digits;
+ register float x, y;
+ digits = 0;
+ neg = 0; x=0.0;
+ if (s != NULL) {
+ for (neg = 0;; s++) {
+ if (*s == '-')
+ neg = !neg;
+ else if (*s != ' ' && *s != '\t')
+ break;
+ }
+ x = 0.0;
+ while (d = *s - '0', 0 <= d && d <= 9) {
+ x = (float)10.0 * x + (float)d;
+ digits++;
+ s++;
+ }
+ if (*s == '.') {
+ y = 1.0;
+ while (d = *++s - '0', 0 <= d && d <= 9) {
+ y /= (float)10.0;
+ x += y * (float)d;
+ digits++;
+ }
+ }
+ }
+ if (digits == 0) {
+ mpx->arg_tail = NULL;
+ return 0.0;
+ }
+ mpx->arg_tail = s;
+ return neg ? -x : x;
+}
+
+@ GROFF font description files have metrics field
+of comma-separated |web_integers|. Traditional troff
+have a float in this position. The value is not
+used anyway - thus just skip the value,
+ eat all non-space chars.
+
+@c
+static float mpx_get_float_map(MPX mpx, char *s) {
+ if (s != NULL) {
+ while (isspace((unsigned char)*s))
+ s++;
+ while (!isspace((unsigned char)*s) && *s)
+ s++;
+ }
+ mpx->arg_tail = s;
+ return 0;
+}
+
+
+@ Reading Initialization Files
+
+Read the database file, reserve internal font numbers and set
+the |font_name| entries. Each line in the database file contains
+|<troff-name>\t,PostScript-name>\t<TeX-name>|
+or just
+|<troff-name>\t,PostScript-name>|
+if the \TeX\ name matches the PostScript name. (|\t| means one or more tabs.)
+
+@<Globals@>=
+avl_tree trfonts;
+
+@ @c
+static void mpx_read_fmap(MPX mpx, const char *dbase) {
+ FILE *fin;
+ avl_entry *tmp;
+ char *nam; /* a font name being read */
+ char *buf;
+ mpx->nfonts = 0;
+ fin = mpx_fsearch(mpx,dbase, mpx_trfontmap_format);
+ if (fin==NULL)
+ mpx_abort(mpx,"Cannot find %s", dbase);
+
+ mpx->trfonts = mpx_avl_create (mpx);
+ while ((buf = mpx_getline(mpx,fin)) != NULL) {
+ if (mpx->nfonts == (max_fnums+1))
+ mpx_abort(mpx,"Need to increase max_fnums");
+ nam = buf;
+ while (*buf && *buf != '\t')
+ buf++;
+ if (nam==buf)
+ continue;
+ tmp = xmalloc(sizeof(avl_entry),1);
+ tmp->name = xmalloc (1,(size_t)(buf-nam)+1);
+ strncpy(tmp->name,nam,(unsigned int)(buf-nam));
+ tmp->name[(buf-nam)] = '\0';
+ tmp->num = (int)mpx->nfonts++;
+ assert(avl_ins (tmp, mpx->trfonts, avl_false) > 0);
+ if (*buf) {
+ buf++;
+ while (*buf == '\t') buf++;
+ while (*buf && *buf != '\t') buf++; /* skip over psname */
+ while (*buf == '\t') buf++;
+ if (*buf)
+ nam = buf;
+ while (*buf) buf++;
+ }
+ mpx->font_name[tmp->num] = xstrdup(nam);
+ mpx->font_num[tmp->num] = -1; /* indicate font is not mounted */
+ }
+ mpx_fclose(mpx,fin);
+}
+
+
+@ Some characters need their coordinates shifted in order to agree with
+troff's view of the world. Logically, this information belongs in the
+font description files but it actually resides in a PostScript prolog
+that the troff output processor dpost reads. Since that file is in
+PostScript and subject to change, we read the same information from
+a small auxiliary file that gives shift amounts relative to the font
+size with y upward.
+
+GROFF NOTE:
+The PostScript prologue in GNU groff's font directory does not
+contain any character shift information, so the following function
+becomes redundant. Simply keeping an empty "trchars.adj" file
+around will do fine without requiring any changes to this program.
+
+@c
+static void mpx_read_char_adj(MPX mpx, const char *adjfile) {
+ FILE *fin;
+ char buf[200];
+ avl_entry tmp, *p;
+ unsigned int i;
+
+ fin = mpx_fsearch(mpx,adjfile, mpx_trcharadj_format);
+ if (fin==NULL)
+ mpx_abort(mpx,"Cannot find %s", adjfile);
+
+ for (i = 0; i < mpx->nfonts; i++)
+ mpx->shiftbase[i] = 0;
+ while (fgets(buf, 200, fin) != NULL) {
+ if (mpx->shiftptr == SHIFTS - 1)
+ mpx_abort(mpx,"Need to increase SHIFTS");
+ if (buf[0] != ' ' && buf[0] != '\t') {
+ for (i = 0; buf[i] != '\0'; i++)
+ if (buf[i] == '\n')
+ buf[i] = '\0';
+ mpx->shiftchar[mpx->shiftptr++] = -1;
+ tmp.name = buf;
+ p = (avl_entry *)avl_find (&tmp, mpx->trfonts);
+ if (p==NULL)
+ mpx_abort(mpx,"%s refers to unknown font %s", adjfile, buf);
+ /* clang: dereference null pointer 'p' */ assert(p);
+ mpx->shiftbase[p->num] = mpx->shiftptr;
+
+ } else {
+ mpx->shiftchar[mpx->shiftptr] = mpx_get_int(mpx,buf);
+ mpx->shifth[mpx->shiftptr] = mpx_get_float(mpx,mpx->arg_tail);
+ mpx->shiftv[mpx->shiftptr] = -mpx_get_float(mpx,mpx->arg_tail);
+ if (mpx->arg_tail == NULL)
+ mpx_abort(mpx,"Bad shift entry : \"%s\"", buf);
+ mpx->shiftptr++;
+ }
+ }
+ mpx->shiftchar[mpx->shiftptr++] = -1;
+ mpx_fclose(mpx,fin);
+}
+
+@ Read the DESC file of the troff device to gather information
+ about sizescale and whether running under groff.
+
+Ignore all commands not specially handled. This relieves
+of collecting commands without arguments here and also
+makes the program more robust in case of future DESC
+extensions.
+
+@c
+static void mpx_read_desc(MPX mpx) {
+ const char *const k1[] = {
+ "res", "hor", "vert", "unitwidth", "paperwidth",
+ "paperlength", "biggestfont", "spare2", "encoding",
+ NULL
+ };
+ const char *const g1[] = {
+ "family", "paperheight", "postpro", "prepro",
+ "print", "image_generator", "broken",
+ NULL
+ };
+ char cmd[200];
+ FILE *fp;
+ int i, n;
+
+ fp = mpx_fsearch(mpx,"DESC", mpx_desc_format);
+ if (fp==NULL)
+ mpx_abort(mpx,"Cannot find DESC");
+ while (fscanf(fp, "%199s", cmd) != EOF) {
+ if (*cmd == '#') {
+ while ((i = getc(fp)) != EOF && i != '\n');
+ continue;
+ }
+ if (strcmp(cmd, "fonts") == 0) {
+ if (fscanf(fp, "%d", &n) != 1)
+ return;
+ for (i = 0; i < n; i++)
+ if (fscanf(fp, "%*s") == EOF)
+ return;
+ } else if (strcmp(cmd, "sizes") == 0) {
+ while (fscanf(fp, "%d", &n) == 1 && n != 0);
+ } else if (strcmp(cmd, "styles") == 0 ||
+ strcmp(cmd, "papersize") == 0) {
+ mpx->gflag++;
+ while ((i = getc(fp)) != EOF && i != '\n');
+ } else if (strcmp(cmd, "sizescale") == 0) {
+ if (fscanf(fp, "%d", &n) == 1)
+ mpx->sizescale = (float)n;
+ mpx->gflag++;
+ } else if (strcmp(cmd, "charset") == 0) {
+ return;
+ } else {
+ for (i = 0; k1[i]; i++)
+ if (strcmp(cmd, k1[i]) == 0) {
+ if (fscanf(fp, "%*s") == EOF)
+ return;
+ break;
+ }
+ if (k1[i] == 0)
+ for (i = 0; g1[i]; i++)
+ if (strcmp(cmd, g1[i]) == 0) {
+ if (fscanf(fp, "%*s") == EOF)
+ return;
+ mpx->gflag = 1;
+ break;
+ }
+ }
+ }
+}
+
+
+@ Given one line from the character description file for the font with
+internal number f, save the appropriate data in the charcodes[f] table.
+A return value of zero indicates a syntax error.
+
+GROFF:
+GNU groff uses an extended font description file format documented
+in |groff_font(5)|. In order to allow parsing of groff's font files,
+this function needs to be rewritten as follows:
+
+\item{1.}The `metrics' field parsed by |mpx_get_float(lin);| may include
+ a comma-separated list of up to six decimal |web_integers| rather
+ than just a single floating-point number.
+
+\item{2.}The `charcode' field parsed by |lastcode = mpx_get_int(arg_tail);|
+ may be given either in decimal, octal, or hexadecimal format.
+
+@ @<Globals@>=
+avl_tree charcodes[(max_fnums+1)]; /* hash tables for translating char names */
+
+@ @c
+static int mpx_scan_desc_line(MPX mpx, int f, char *lin) {
+ static int lastcode;
+ avl_entry *tmp;
+ char *s, *t;
+ t = lin;
+ while (*lin != ' ' && *lin != '\t' && *lin != '\0')
+ lin++;
+ if (lin==t)
+ return 1;
+ s = xmalloc((size_t)(lin-t+1),1);
+ strncpy(s,t,(size_t)(lin-t));
+ *(s+(lin-t)) = '\0';
+ while (*lin == ' ' || *lin == '\t')
+ lin++;
+ if (*lin == '"') {
+ if (lastcode < MAXCHARS) {
+ tmp = xmalloc(sizeof(avl_entry),1);
+ tmp->name = s ;
+ tmp->num = lastcode;
+ mpx_avl_probe (mpx, mpx->charcodes[f],tmp);
+ }
+ } else {
+ (void) mpx_get_float_map(mpx,lin);
+ (void) mpx_get_int(mpx,mpx->arg_tail);
+ lastcode = mpx_get_int_map(mpx,mpx->arg_tail);
+ if (mpx->arg_tail == NULL)
+ return 0;
+ if (lastcode < MAXCHARS) {
+ tmp = xmalloc(sizeof(avl_entry),1);
+ tmp->name = s ;
+ tmp->num = lastcode;
+ mpx_avl_probe (mpx, mpx->charcodes[f],tmp);
+ }
+ }
+ return 1;
+}
+
+@ Read the font description file for the font with the given troff name
+and update the data structures. The result is the internal font number.
+
+@c
+static int mpx_read_fontdesc(MPX mpx, char *nam) { /* troff name */
+ char buf[200];
+ avl_entry tmp, *p;
+ FILE *fin; /* input file */
+ int f; /* internal font number */
+
+ if (mpx->unit == 0.0)
+ mpx_abort(mpx, "Resolution is not set soon enough");
+ tmp.name = nam;
+ p = (avl_entry *)avl_find (&tmp,mpx->trfonts);
+ if (p == NULL)
+ mpx_abort(mpx, "Font was not in map file");
+ /* clang: dereference null pointer 'p' */ assert(p);
+ f = p->num;
+ fin = mpx_fsearch(mpx, nam, mpx_fontdesc_format);
+ if (fin==NULL)
+ mpx_abort(mpx,"Cannot find %s", nam);
+ for (;;) {
+ if (fgets(buf, 200, fin) == NULL)
+ mpx_abort(mpx, "Description file for %s ends unexpectedly", nam);
+ if (strncmp(buf, "special", 7) == 0) {
+ *(mpx->specf_tail) = f;
+ mpx->next_specfnt[f] = (max_fnums+1);
+ mpx->specf_tail = &(mpx->next_specfnt[f]);
+ } else if (strncmp(buf, "charset", 7) == 0)
+ break;
+ }
+ mpx->charcodes[f] = mpx_avl_create (mpx);
+ while (fgets(buf, 200, fin) != NULL)
+ if (mpx_scan_desc_line(mpx, f, buf) == 0)
+ mpx_abort(mpx, "%s has a bad line in its description file: %s", nam, buf);
+ mpx_fclose(mpx,fin);
+ return f;
+}
+
+@ Page and Character Output
+
+@<Globals@>=
+boolean graphics_used; /* nonzero if any graphics seen on this page */
+float dmp_str_h1;
+float dmp_str_v; /* corrected start pos for current out string */
+float dmp_str_h2; /* where the current output string ends */
+float str_size; /* point size for this text string */
+
+
+@ Print any transformations required by the current Xslant and Xheight settings.
+
+@<Declarations@>=
+static void mpx_slant_and_ht(MPX mpx);
+
+@ @c
+static void mpx_slant_and_ht(MPX mpx) {
+ int i = 0;
+ fprintf(mpx->mpxfile, "(");
+ if (mpx->Xslant != 0.0) {
+ fprintf(mpx->mpxfile, " slanted%.5f", mpx->Xslant);
+ i++;
+ }
+ if (mpx->Xheight != mpx->cursize && mpx->Xheight != 0.0 && mpx->cursize != 0.0) {
+ fprintf(mpx->mpxfile, " yscaled%.4f", mpx->Xheight / mpx->cursize);
+ i++;
+ }
+ fprintf(mpx->mpxfile, ")");
+}
+
+
+@ Output character number c in the font with internal number f.
+
+@c
+static void mpx_set_num_char(MPX mpx, int f, int c) {
+ float hh, vv; /* corrected versions of h, v */
+ int i;
+
+ hh = (float)mpx->h;
+ vv = (float)mpx->v;
+ for (i = mpx->shiftbase[f]; mpx->shiftchar[i] >= 0 && i < SHIFTS; i++)
+ if (mpx->shiftchar[i] == c) {
+ hh += (mpx->cursize / mpx->unit) * mpx->shifth[i];
+ vv += (mpx->cursize / mpx->unit) * mpx->shiftv[i];
+ break;
+ }
+ if (hh - mpx->dmp_str_h2 >= 1.0 || mpx->dmp_str_h2 - hh >= 1.0 ||
+ vv - mpx->dmp_str_v >= 1.0 || mpx->dmp_str_v - vv >= 1.0 ||
+ f != mpx->str_f || mpx->cursize != mpx->str_size) {
+ if (mpx->str_f >= 0)
+ mpx_finish_last_char(mpx);
+ else if (!mpx->fonts_used)
+ mpx_prepare_font_use(mpx); /* first font usage on this page */
+ if (!mpx->font_used[f])
+ mpx_first_use(mpx,f); /* first use of font f on this page */
+ fprintf(mpx->mpxfile, "_s((");
+ mpx->print_col = 3;
+ mpx->str_f = f;
+ mpx->dmp_str_v = vv;
+ mpx->dmp_str_h1 = hh;
+ mpx->str_size = mpx->cursize;
+ }
+ mpx_print_char(mpx, (unsigned char)c);
+ mpx->dmp_str_h2 = hh + (float)char_width(f,c);
+}
+
+@ Output a string.
+
+@c
+static void mpx_set_string(MPX mpx, char *cname) {
+ float hh; /* corrected version of h, current horisontal position */
+
+ if (!*cname)
+ return;
+ hh = (float)mpx->h;
+ mpx_set_num_char(mpx,(int)mpx->curfont, *cname);
+ hh += (float)char_width(mpx->curfont,(int)*cname);
+ while (*++cname) {
+ mpx_print_char(mpx,(unsigned char)*cname);
+ hh += (float)char_width(mpx->curfont,(int)*cname);
+ }
+ mpx->h = (web_integer)floor(hh+0.5);
+ mpx_finish_last_char(mpx);
+}
+
+@ Special Characters
+
+Given the troff name of a special character, this routine finds its
+definition and copies it to the MPX file. It also finds the name of
+the vardef macro and returns that name. The name should be C.<something>.
+
+@
+TH: A bit of trickery is added here for case-insensitive
+file systems. This aliasing allows the CHARLIB directory
+to exist on DVDs, for example.
+It is a hack, I know. I've stuck to names on TeXLive.
+
+@d test_redo_search do {
+ if (deff==NULL)
+ deff = mpx_fsearch(mpx, cname, mpx_specchar_format);
+ } while (0)
+
+@c
+static char *mpx_copy_spec_char(MPX mpx, char *cname) {
+ FILE *deff;
+ int c;
+ char *s, *t;
+ char specintro[] = "vardef "; /* MetaPost name follows this */
+ unsigned k = 0; /* how much of specintro so far */
+ if (strcmp(cname, "ao") == 0) {
+ deff = mpx_fsearch(mpx, "ao.x", mpx_specchar_format);
+ test_redo_search;
+ } else if (strcmp(cname, "lh") == 0) {
+ deff = mpx_fsearch(mpx, "lh.x", mpx_specchar_format);
+ test_redo_search;
+ } else if (strcmp(cname, "~=") == 0) {
+ deff = mpx_fsearch(mpx, "twiddle", mpx_specchar_format);
+ test_redo_search;
+ } else {
+ deff = mpx_fsearch(mpx, cname, mpx_specchar_format);
+ }
+ if (deff==NULL)
+ mpx_abort(mpx, "No vardef in charlib/%s", cname);
+
+ while (k < (unsigned)strlen(specintro)) {
+ if ((c = getc(deff)) == EOF)
+ mpx_abort(mpx, "No vardef in charlib/%s", cname);
+ putc(c, mpx->mpxfile);
+ if (c == specintro[k])
+ k++;
+ else
+ k = 0;
+ }
+ s = xmalloc(mpx->bufsize,1);
+ t = s ;
+ while ((c = getc(deff)) != '(') {
+ if (c == EOF)
+ mpx_abort(mpx, "vardef in charlib/%s has no arguments", cname);
+ putc(c, mpx->mpxfile);
+ *t++ = (char)c;
+ }
+ putc(c, mpx->mpxfile);
+ *t++ = '\0';
+ while ((c = getc(deff)) != EOF);
+ putc(c, mpx->mpxfile);
+ return s;
+}
+
+
+@ When given a character name instead of a number, we need to check if
+it is a special character and download the definition if necessary.
+If the character is not in the current font we have to search the special
+fonts.
+
+@<Globals@>=
+avl_tree spec_tab;
+
+@ The |spec_tab| avl table combines character names with macro names.
+
+@<Types...@>=
+typedef struct {
+ char *name;
+ char *mac;
+} spec_entry;
+
+@ @c
+static void mpx_set_char(MPX mpx, char *cname) {
+ int f, c;
+ avl_entry tmp, *p;
+ spec_entry *sp;
+
+ if (*cname == ' ' || *cname == '\t')
+ return;
+ f = (int)mpx->curfont;
+ tmp.name = cname;
+ p = avl_find(&tmp, mpx->charcodes[f]);
+ if (p==NULL) {
+ for (f = mpx->specfnt; f != (max_fnums+1); f = mpx->next_specfnt[f]) {
+ p = avl_find(&tmp, mpx->charcodes[f]);
+ if (p!=NULL)
+ goto OUT_LABEL;
+ }
+ mpx_abort(mpx, "There is no character %s", cname);
+ }
+OUT_LABEL:
+ /* clang: dereference null pointer 'p' */ assert(p);
+ c = p->num;
+ if (!is_specchar(c)) {
+ mpx_set_num_char(mpx, f, c);
+ } else {
+ if (mpx->str_f >= 0)
+ mpx_finish_last_char(mpx);
+ if (!mpx->fonts_used)
+ mpx_prepare_font_use(mpx);
+ if (!mpx->font_used[f])
+ mpx_first_use(mpx, f);
+ if (mpx->spec_tab)
+ mpx->spec_tab = mpx_avl_create (mpx);
+ sp = xmalloc(sizeof(spec_entry),1);
+ sp->name = cname;
+ sp->mac = NULL;
+ {
+ spec_entry *r = (spec_entry *)avl_find(sp, mpx->spec_tab);
+ if (r==NULL) {
+ if (avl_ins (sp, mpx->spec_tab, avl_false)<0)
+ mpx_abort(mpx,"Memory allocation failure");
+ }
+ }
+ if (sp->mac == NULL) {
+ sp->mac = mpx_copy_spec_char(mpx, cname); /* this won't be NULL */
+ }
+ fprintf(mpx->mpxfile, "_s(%s(_n%d)", sp->mac,f);
+ fprintf(mpx->mpxfile, ",%.5f,%.4f,%.4f)",
+ (mpx->cursize/mpx->font_design_size[f])*1.00375,
+ (double)(((float)mpx->h*mpx->unit)/100.0), YCORR-(float)mpx->v*mpx->unit);
+ mpx_slant_and_ht(mpx);
+ fprintf(mpx->mpxfile, ";\n");
+ }
+}
+
+@ Font Definitions
+
+Mount the font with troff name nam at external font number n and read any
+necessary font files.
+
+@c
+static void mpx_do_font_def(MPX mpx, int n, char *nam) {
+ int f;
+ unsigned k;
+ avl_entry tmp, *p;
+ tmp.name = nam;
+ p = (avl_entry *) avl_find (&tmp, mpx->trfonts);
+ if (p==NULL)
+ mpx_abort(mpx, "Font %s was not in map file", nam);
+ /* clang: dereference null pointer 'p' */ assert(p);
+ f = p->num;
+ if ( mpx->charcodes[f] == NULL) {
+ mpx_read_fontdesc(mpx, nam);
+ mpx->cur_name = xstrdup(mpx->font_name[f]);
+ if (! mpx_open_tfm_file(mpx) )
+ font_abort("No TFM file found for ",f);
+@.no TFM file found@>
+ mpx_in_TFM(mpx, f);
+ }
+ for (k = 0; k < mpx->nfonts; k++)
+ if (mpx->font_num[k] == n)
+ mpx->font_num[k] = -1;
+ mpx->font_num[f] = n;
+ @<Do any other initialization required for the new font |f|@>;
+}
+
+
+
+@ Time on `makepath pencircle'
+
+Given the control points of a cubic Bernstein polynomial, evaluate it at t.
+
+@d Speed ((float) (PI/4.0))
+
+@c
+static float mpx_b_eval(const float *xx, float t) {
+ float zz[4];
+ register int i, j;
+ for (i = 0; i <= 3; i++)
+ zz[i] = xx[i];
+ for (i = 3; i > 0; i--)
+ for (j = 0; j < i; j++)
+ zz[j] += t * (zz[j + 1] - zz[j]);
+ return zz[0];
+}
+
+
+@ Find the direction angle at time t on the path `makepath pencircle'.
+The tables below give the Bezier control points for MetaPost's cubic
+approximation to the first octant of a unit circle.
+
+@c
+static const float xx[] = { 1.0, 1.0, (float)0.8946431597, (float)0.7071067812 };
+static const float yy[] = { 0.0, (float)0.2652164899, (float)0.5195704026, (float)0.7071067812 };
+
+@ @c
+static float mpx_circangle(float t) {
+ float ti;
+ ti = (float)floor(t);
+ t -= ti;
+ return (float) atan(mpx_b_eval(yy, t) /
+ mpx_b_eval(xx, t)) + ti * Speed;
+}
+
+
+@ Find the spline parameter where `makepath pencircle' comes closest to
+ (cos(a)/2,sin(a)/2).
+
+@c
+static float mpx_circtime(float a) {
+ int i;
+ float t;
+ t = a / Speed;
+ for (i = 2; --i >= 0;)
+ t += (a - mpx_circangle(t)) / Speed;
+ return t;
+}
+
+
+
+@ Troff Graphics
+
+@<Globals@>=
+float gx;
+float gy; /* current point for graphics (init. (h,YCORR/mpx->unit-v) */
+
+@ @c
+static void mpx_prepare_graphics(MPX mpx) {
+
+ fprintf(mpx->mpxfile, "vardef _D(expr _d)expr _q =\n");
+ fprintf(mpx->mpxfile,
+ " addto _p doublepath _q withpen pencircle scaled _d; enddef;\n");
+ mpx->graphics_used = true;
+}
+
+
+@ This function prints the current position (gx,gy). Then if it can read dh dv
+from string s, it increments (gx,gy) and prints "--". By returning the rest
+of the string s or NULL if nothing could be read from s, it provides the
+argument for the next iteration.
+
+@c
+static char *mpx_do_line(MPX mpx, char *s) {
+ float dh, dv;
+
+ fprintf(mpx->mpxfile, "(%.3f,%.3f)", mpx->gx * mpx->unit, mpx->gy * mpx->unit);
+ dh = mpx_get_float(mpx, s);
+ dv = mpx_get_float(mpx, mpx->arg_tail);
+ if (mpx->arg_tail == NULL)
+ return NULL;
+ mpx->gx += dh;
+ mpx->gy -= dv;
+ fprintf(mpx->mpxfile, "--\n");
+ return mpx->arg_tail;
+}
+
+
+@ Function |spline_seg()| reads two pairs of (dh,dv) increments and prints the
+corresponding quadratic B-spline segment, leaving the ending point to be
+printed next time. The return value is the string with the first (dh,dv)
+pair lopped off. If only one pair of increments is found, we prepare to
+terminate the iteration by printing last time's ending point and returning
+NULL.
+
+@c
+static char * mpx_spline_seg(MPX mpx, char *s) {
+ float dh1, dv1, dh2, dv2;
+
+ dh1 = mpx_get_float(mpx, s);
+ dv1 = mpx_get_float(mpx, mpx->arg_tail);
+ if (mpx->arg_tail == NULL)
+ mpx_abort(mpx, "Missing spline increments");
+ s = mpx->arg_tail;
+ fprintf(mpx->mpxfile, "(%.3f,%.3f)", (mpx->gx + .5 * dh1) * mpx->unit,
+ (mpx->gy - .5 * dv1) * mpx->unit);
+ mpx->gx += dh1;
+ mpx->gy -= dv1;
+ dh2 = mpx_get_float(mpx, s);
+ dv2 = mpx_get_float(mpx, mpx->arg_tail);
+ if (mpx->arg_tail == NULL)
+ return NULL;
+ fprintf(mpx->mpxfile, "..\ncontrols (%.3f,%.3f) and (%.3f,%.3f)..\n",
+ (mpx->gx - dh1 / 6.0) * mpx->unit, (mpx->gy + dv1 / 6.0) * mpx->unit,
+ (mpx->gx + dh2 / 6.0) * mpx->unit, (mpx->gy - dv2 / 6.0) * mpx->unit);
+ return s;
+}
+
+
+@ Draw an ellipse with the given major and minor axes.
+
+@c
+static void mpx_do_ellipse(MPX mpx, float a, float b) {
+
+ fprintf(mpx->mpxfile, "makepath(pencircle xscaled %.3f\n yscaled %.3f",
+ a * mpx->unit, b * mpx->unit);
+ fprintf(mpx->mpxfile, " shifted (%.3f,%.3f));\n", (mpx->gx + .5 * a) * mpx->unit,
+ mpx->gy * mpx->unit);
+ mpx->gx += a;
+}
+
+
+@ Draw a counter-clockwise arc centered at (cx,cy) with initial and final radii
+ (ax,ay) and (bx,by) respectively.
+
+@c
+static
+void mpx_do_arc(MPX mpx, float cx, float cy, float ax, float ay, float bx, float by) {
+ float t1, t2;
+
+ t1 = mpx_circtime((float)atan2(ay, ax));
+ t2 = mpx_circtime((float)atan2(by, bx));
+ if (t2 < t1)
+ t2 += (float)8.0;
+ fprintf(mpx->mpxfile, "subpath (%.5f,%.5f) of\n", t1, t2);
+ fprintf(mpx->mpxfile,
+ " makepath(pencircle scaled %.3f shifted (%.3f,%.3f));\n",
+ 2.0 * sqrt(ax * ax + ay * ay) * mpx->unit, cx * mpx->unit, cy * mpx->unit);
+ mpx->gx = cx + bx;
+ mpx->gy = cy + by;
+}
+
+
+
+@ String s is everything following the initial `D' in a troff graphics command.
+
+@c
+static void mpx_do_graphic(MPX mpx, char *s) {
+ float h1, v1, h2, v2;
+
+ mpx_finish_last_char(mpx);
+ /* GROFF uses Fd to set fill color for solid drawing objects to the
+ default, so just ignore that.
+ */
+ if (s[0] == 'F' && s[1] == 'd')
+ return;
+ mpx->gx = (float) mpx->h;
+ mpx->gy = (float)YCORR / mpx->unit - ((float) mpx->v);
+ if (!mpx->graphics_used)
+ mpx_prepare_graphics(mpx);
+ fprintf(mpx->mpxfile, "D(%.4f) ", LWscale * mpx->cursize);
+ switch (*s++) {
+ case 'c':
+ h1 = mpx_get_float(mpx,s);
+ if (mpx->arg_tail == NULL)
+ mpx_abort(mpx,"Bad argument in %s", s-2);
+ mpx_do_ellipse(mpx,h1, h1);
+ break;
+ case 'e':
+ h1 = mpx_get_float(mpx,s);
+ v1 = mpx_get_float(mpx,mpx->arg_tail);
+ if (mpx->arg_tail == NULL)
+ mpx_abort(mpx,"Bad argument in %s", s - 2);
+ mpx_do_ellipse(mpx,h1, v1);
+ break;
+ case 'A':
+ fprintf(mpx->mpxfile, "reverse ");
+ /* fall through */
+ case 'a':
+ h1 = mpx_get_float(mpx,s);
+ v1 = mpx_get_float(mpx,mpx->arg_tail);
+ h2 = mpx_get_float(mpx,mpx->arg_tail);
+ v2 = mpx_get_float(mpx,mpx->arg_tail);
+ if (mpx->arg_tail == NULL)
+ mpx_abort(mpx,"Bad argument in %s", s - 2);
+ mpx_do_arc(mpx,mpx->gx + h1, mpx->gy - v1, -h1, v1, h2, -v2);
+ break;
+ case 'l':
+ case 'p':
+ while (s != NULL)
+ s = mpx_do_line(mpx,s);
+ fprintf(mpx->mpxfile, ";\n");
+ break;
+ case 'q':
+ do
+ s = mpx_spline_seg(mpx,s);
+ while (s != NULL);
+ fprintf(mpx->mpxfile, ";\n");
+ break;
+ case '~':
+ fprintf(mpx->mpxfile, "(%.3f,%.3f)--", mpx->gx * mpx->unit, mpx->gy * mpx->unit);
+ do
+ s = mpx_spline_seg(mpx,s);
+ while (s != NULL);
+ fprintf(mpx->mpxfile, "--(%.3f,%.3f);\n", mpx->gx * mpx->unit, mpx->gy * mpx->unit);
+ break;
+ default:
+ mpx_abort(mpx,"Unknown drawing function %s", s - 2);
+ }
+ mpx->h = (int) floor(mpx->gx + .5);
+ mpx->v = (int) floor(YCORR / mpx->unit + .5 - mpx->gy);
+}
+
+
+
+@ Interpreting Troff Output
+
+@c
+static void mpx_change_font(MPX mpx, int f) {
+ for (mpx->curfont = 0; mpx->curfont < mpx->nfonts; mpx->curfont++)
+ if (mpx->font_num[mpx->curfont] == f)
+ return;
+ mpx_abort(mpx,"Bad font setting");
+}
+
+
+@ String s0 is everything following the initial `x' in a troff device control
+ command. A zero result indicates a stop command.
+
+@c
+static int mpx_do_x_cmd(MPX mpx, char *s0)
+{
+ float x;
+ int n;
+ char *s;
+
+ s = s0;
+ while (*s == ' ' || *s == '\t')
+ s++;
+ switch (*s++) {
+ case 'r':
+ if (mpx->unit != 0.0)
+ mpx_abort(mpx,"Attempt to reset resolution");
+ while (*s != ' ' && *s != '\t')
+ s++;
+ mpx->unit = mpx_get_float(mpx,s);
+ if (mpx->unit <= 0.0)
+ mpx_abort(mpx,"Bad resolution: x %s", s0);
+ mpx->unit = (float)72.0 / mpx->unit;
+ break;
+ case 'f':
+ while (*s != ' ' && *s != '\t')
+ s++;
+ n = mpx_get_int(mpx,s);
+ if (mpx->arg_tail == NULL)
+ mpx_abort(mpx,"Bad font def: x %s", s0);
+ s = mpx->arg_tail;
+ while (*s == ' ' || *s == '\t')
+ s++;
+ mpx_do_font_def(mpx,n, s);
+ break;
+ case 's':
+ return 0;
+ case 'H':
+ while (*s != ' ' && *s != '\t')
+ s++;
+ mpx->Xheight = mpx_get_float(mpx,s);
+ /* GROFF troff output is scaled |groff_out(5)|:
+ The argument to the s command is in scaled
+ points (units of points/n, where n is the argument
+ to the sizescale command in the DESC file.) The
+ argument to the x Height command is also in scaled points.
+ sizescale for groff devps is 1000
+ */
+ if (mpx->sizescale != 0.0) {
+ if (mpx->unit != 0.0)
+ mpx->Xheight *= mpx->unit; /* ??? */
+ else
+ mpx->Xheight /= mpx->sizescale;
+ }
+ if (mpx->Xheight == mpx->cursize)
+ mpx->Xheight = 0.0;
+ break;
+ case 'S':
+ while (*s != ' ' && *s != '\t')
+ s++;
+ mpx->Xslant = mpx_get_float(mpx,s) * ((float)PI / (float)180.0);
+ x = (float)cos(mpx->Xslant);
+ if (-1e-4 < x && x < 1e-4)
+ mpx_abort(mpx,"Excessive slant");
+ mpx->Xslant = (float)sin(mpx->Xslant) / x;
+ break;
+ default:
+ /* do nothing */ ;
+ }
+ return 1;
+}
+
+
+@ This routine reads commands from the troff output file up to and including
+the next `p' or `x s' command. It also calls |set_num_char()| and |set_char()|
+to generate output when appropriate. A zero result indicates that there
+are no more pages to do.
+
+GROFF:
+GNU groff uses an extended device-independent output file format
+documented in |groff_out(5)|. In order to allow parsing of groff's
+output files, this function either needs to be extended to support
+the new command codes, or else the use of the "t" and "u" commands
+must be disabled by removing the line "tcommand" from the DESC file
+in the \$(prefix)/lib/groff/devps directory.
+
+@c
+static int mpx_do_page (MPX mpx, FILE *trf) {
+ char *buf;
+ char a, *c, *cc;
+
+ mpx->h = mpx->v = 0;
+ while ((buf = mpx_getline(mpx, trf)) != NULL) {
+ mpx->lnno++;
+ c = buf;
+ while (*c != '\0') {
+ switch (*c) {
+ case ' ':
+ case '\t':
+ case 'w':
+ c++;
+ break;
+ case 's':
+ mpx->cursize = mpx_get_float(mpx,c + 1);
+ /* GROFF troff output is scaled
+ |groff_out(5)|: The argument to the s command is in scaled
+ points (units of points/n, where n is the argument
+ to the sizescale command in the DESC file.) The
+ argument to the x Height command is also in scaled
+ points.
+ sizescale for groff devps is 1000
+ */
+ if (mpx->sizescale != 0.0) {
+ if (mpx->unit != 0.0)
+ mpx->cursize *= mpx->unit; /* ??? */
+ else
+ mpx->cursize /= mpx->sizescale;
+ }
+ goto iarg;
+ case 'f':
+ mpx_change_font(mpx, mpx_get_int(mpx,c + 1));
+ goto iarg;
+ case 'c':
+ if (c[1] == '\0')
+ mpx_abort(mpx, "Bad c command in troff output");
+ cc = c + 2;
+ goto set;
+ case 'C':
+ cc = c;
+ do
+ cc++;
+ while (*cc != ' ' && *cc != '\t' && *cc != '\0');
+ goto set;
+ case 'N':
+ mpx_set_num_char(mpx, (int)mpx->curfont, mpx_get_int(mpx,c + 1));
+ goto iarg;
+ case 'H':
+ mpx->h = mpx_get_int(mpx, c + 1);
+ goto iarg;
+ case 'V':
+ mpx->v = mpx_get_int(mpx, c + 1);
+ goto iarg;
+ case 'h':
+ mpx->h += mpx_get_int(mpx, c + 1);
+ goto iarg;
+ case 'v':
+ mpx->v += mpx_get_int(mpx, c + 1);
+ goto iarg;
+ case '0':
+ case '1':
+ case '2':
+ case '3':
+ case '4':
+ case '5':
+ case '6':
+ case '7':
+ case '8':
+ case '9':
+ if (c[1] < '0' || c[1] > '9' || c[2] == '\0')
+ mpx_abort(mpx, "Bad nnc command in troff output");
+ mpx->h += 10 * (c[0] - '0') + c[1] - '0';
+ c++;
+ cc = c + 2;
+ goto set;
+ case 'p':
+ return 1;
+ case 'n':
+ (void) mpx_get_int(mpx, c + 1);
+ (void) mpx_get_int(mpx, mpx->arg_tail);
+ goto iarg;
+ case 'D':
+ mpx_do_graphic(mpx, c + 1);
+ goto eoln;
+ case 'x':
+ if (!mpx_do_x_cmd(mpx, c + 1))
+ return 0;
+ goto eoln;
+ case '#':
+ goto eoln;
+ case 'F':
+ /* GROFF uses this command to report filename */
+ goto eoln;
+ case 'm':
+ /* GROFF uses this command to control color */
+ goto eoln;
+ case 'u':
+ /* GROFF uses this command to output a word with additional
+ white space between characters, not implemented
+ */
+ mpx_abort(mpx, "Bad command in troff output\n"
+ "change the DESC file for your GROFF PostScript device, remove tcommand");
+ case 't':
+ /* GROFF uses this command to output a word */
+ cc = c;
+ do
+ cc++;
+ while (*cc != ' ' && *cc != '\t' && *cc != '\0');
+ a = *cc;
+ *cc = '\0';
+ mpx_set_string(mpx, ++c);
+ c = cc;
+ *c = a;
+ continue;
+ default:
+ mpx_abort(mpx, "Bad command in troff output");
+ }
+ continue;
+ set:
+ a = *cc;
+ *cc = '\0';
+ mpx_set_char(mpx, ++c);
+ c = cc;
+ *c = a;
+ continue;
+ iarg:
+ c = mpx->arg_tail;
+ }
+ eoln: /* do nothing */ ;
+ }
+ return 0;
+}
+
+
+@ Main Dmp Program
+
+@d dbname "trfonts.map" /* file for table of troff \& TFM font names */
+@d adjname "trchars.adj" /* file for character shift amounts */
+
+@c
+static int mpx_dmp(MPX mpx, char *infile) {
+ int more;
+ FILE *trf = mpx_xfopen(mpx,infile, "r");
+ mpx_read_desc(mpx);
+ mpx_read_fmap(mpx,dbname);
+ if (!mpx->gflag)
+ mpx_read_char_adj(mpx,adjname);
+ mpx_open_mpxfile(mpx);
+ if (mpx->banner != NULL)
+ fprintf (mpx->mpxfile,"%s\n",mpx->banner);
+ if (mpx_do_page(mpx, trf)) {
+ do {
+ @<Do initialization required before starting a new page@>;
+ mpx_start_picture(mpx);
+ more = mpx_do_page(mpx,trf);
+ mpx_stop_picture(mpx);
+ fprintf(mpx->mpxfile, "mpxbreak\n");
+ } while (more);
+ }
+ mpx_fclose(mpx,trf);
+ if ( mpx->history<=mpx_cksum_trouble )
+ return 0;
+ else
+ return mpx->history;
+}
+
+
+@* \[5] Makempx.
+
+
+Make an MPX file from the labels in a MetaPost source file,
+using mpto and either dvitomp (TeX) or dmp (troff).
+
+Started from a shell script initially based on John Hobby's original
+version, that was then translated to C by Akira Kakuto (Aug 1997,
+Aug 2001), and updated and largely rewritten by Taco Hoekwater (Nov 2006).
+
+
+Differences between the script and this C version:
+
+The script trapped HUP, INT, QUIT and TERM for cleaning up
+temporary files. This is a refinement, and not portable.
+
+The script put its own directory in front of the
+executable search PATH. This is not portable either, and
+it seems a safe bet that normal users do not have 'mpto',
+'dvitomp', or 'dmp' commands in their path.
+
+The command-line '-troff' now also accepts an optional argument.
+
+The troff infile for error diagnostics is renamed "mpxerr.i",
+not plain "mpxerr".
+
+The original script deleted mpx*.* in the cleanup process.
+
+That is a bit harder in C, because it requires reading the contents
+of the current directory. The current program assumes that
+opendir(), readdir() and closedir() are known everywhere where
+the function getcwd() exists (except on WIN32, where it uses
+|_findfirst| \& co).
+
+If this assumption is false, you can define |NO_GETCWD|, and makempx
+will revert to trying to delete only a few known extensions
+
+There is a -debug switch, preventing the removal of tmp files
+
+@d TMPNAME_EXT(a,b) { strcpy(a,tmpname); strcat(a,b); }
+
+@c
+
+#define TEXERR "mpxerr.tex"
+#define DVIERR "mpxerr.dvi"
+#define TROFF_INERR "mpxerr.i"
+#define TROFF_OUTERR "mpxerr.t"
+
+@ @c
+static void mpx_rename (MPX mpx, const char *a, const char *b) {
+ mpx_report(mpx,"renaming %s to %s",a,b);
+ rename(a,b);
+}
+
+@ @<Globals@>=
+char tex[15] ;
+int debug ;
+const char *progname;
+
+@ Cleaning up
+@c
+static void mpx_default_erasetmp(MPX mpx) {
+ char *wrk;
+ char *p;
+ if (mpx->mode==mpx_tex_mode) {
+ wrk = xstrdup(mpx->tex);
+ p = strrchr(wrk, '.');
+ *p = '\0'; strcat(wrk, ".aux"); remove(wrk);
+ *p = '\0'; strcat(wrk, ".pdf"); remove(wrk);
+ *p = '\0'; strcat(wrk, ".toc"); remove(wrk);
+ *p = '\0'; strcat(wrk, ".idx"); remove(wrk);
+ *p = '\0'; strcat(wrk, ".ent"); remove(wrk);
+ *p = '\0'; strcat(wrk, ".out"); remove(wrk);
+ *p = '\0'; strcat(wrk, ".nav"); remove(wrk);
+ *p = '\0'; strcat(wrk, ".snm"); remove(wrk);
+ *p = '\0'; strcat(wrk, ".tui"); remove(wrk);
+ free(wrk);
+ }
+}
+
+@ @<Declarations@>=
+static void mpx_erasetmp(MPX mpx);
+
+@ @c
+static void mpx_cleandir(MPX mpx, char *cur_path) {
+ char *wrk, *p;
+#ifdef _WIN32
+ struct _finddata_t c_file;
+ long hFile;
+#else
+ struct dirent *entry;
+ DIR *d;
+#endif
+ wrk = xstrdup(mpx->tex);
+ p = strrchr(wrk, '.');
+ *p = '\0'; /* now wrk is identical to tmpname */
+
+#ifdef _WIN32
+ strcat(cur_path,"/*");
+ if ((hFile = _findfirst (cur_path, &c_file)) == -1L) {
+ mpx_default_erasetmp(mpx);
+ } else {
+ if (strstr(c_file.name,wrk)==c_file.name)
+ remove(c_file.name);
+ while (_findnext (hFile, &c_file) != -1L) {
+ if (strstr(c_file.name,wrk)==c_file.name)
+ remove(c_file.name);
+ }
+ _findclose (hFile); /* no more entries => close directory */
+ }
+#else
+ if ((d = opendir(cur_path)) == NULL) {
+ mpx_default_erasetmp(mpx);
+ } else {
+ while ((entry = readdir (d)) != NULL) {
+ if (strstr(entry->d_name,wrk)==entry->d_name)
+ remove(entry->d_name);
+ }
+ closedir(d);
+ }
+#endif
+ free(wrk);
+}
+
+
+@ It is important that |mpx_erasetmp| remains silent.
+If it find trouble, it should just ignore it.
+
+The string |cur_path| is a little bit larger than needed, because that
+allows the win32 code in |cleandir| to add the slash and asterisk for
+globbing without having to reallocate the variable first.
+
+@c
+#ifdef WIN32
+#define GETCWD _getcwd
+#else
+#define GETCWD getcwd
+#endif
+static void mpx_erasetmp(MPX mpx) {
+ char cur_path[1024];
+ if (mpx->debug)
+ return;
+ if (mpx->tex[0] != '\0') {
+ remove(mpx->tex);
+ if(GETCWD(cur_path,1020) == NULL) {
+ mpx_default_erasetmp(mpx); /* don't know where we are */
+ } else {
+ mpx_cleandir(mpx,cur_path);
+ }
+ }
+}
+
+
+@* Running the external typesetters.
+
+First, here is a helper for messaging.
+
+@c
+static char *mpx_print_command (MPX mpx, int cmdlength, char **cmdline) {
+ char *s, *t;
+ int i;
+ size_t l;
+ (void)mpx;
+ l = 0;
+ for (i = 0; i < cmdlength ; i++) {
+ l += strlen(cmdline[i])+1;
+ }
+ s = xmalloc((size_t)l,1); t=s;
+ for (i = 0; i < cmdlength ; i++) {
+ if (i>0) *t++ = ' ';
+ t = strcpy(t,cmdline[i]);
+ t += strlen(cmdline[i]);
+ }
+ return s;
+}
+
+@ This function unifies the external program calling across Posix-like and Win32
+systems.
+
+@c
+static int do_spawn (MPX mpx, char *icmd, char **options) {
+#ifndef WIN32
+ pid_t child;
+#endif
+ int retcode = -1;
+ char * cmd = xmalloc(strlen(icmd)+1,1);
+ if (icmd[0] != '"') {
+ strcpy(cmd,icmd);
+ } else {
+ strncpy(cmd,icmd+1,strlen(icmd)-2);
+ cmd[strlen(icmd)-2] = 0;
+ }
+#ifndef WIN32
+ child = fork();
+ if (child < 0)
+ mpx_abort(mpx, "fork failed: %s", strerror(errno));
+ if (child == 0) {
+ if(execvp(cmd, options))
+ mpx_abort(mpx, "exec failed: %s", strerror(errno));
+ } else {
+ if (wait(&retcode)==child) {
+ retcode = (WIFEXITED(retcode) ? WEXITSTATUS(retcode) : -1);
+ } else {
+ mpx_abort(mpx, "wait failed: %s", strerror(errno));
+ }
+ }
+#else
+ retcode = _spawnvp(_P_WAIT, cmd, (const char* const*)options);
+#endif
+ xfree(cmd);
+ return retcode;
+}
+
+@ @c
+#ifdef WIN32
+#define nuldev "nul"
+#else
+#define nuldev "/dev/null"
+#endif
+static int mpx_run_command(MPX mpx, char *inname, char *outname, int count, char **cmdl) {
+ char *s;
+ int retcode;
+ int sav_o, sav_i; /* for I/O redirection */
+ FILE *fr, *fw; /* read and write streams for the command */
+
+ if (count < 1 || cmdl == NULL || cmdl[0] == NULL)
+ return -1; /* return non-zero by default, signalling an error */
+
+ s = mpx_print_command(mpx,count, cmdl);
+ mpx_report(mpx,"running command %s", s);
+ free(s);
+
+ fr = mpx_xfopen(mpx,(inname ? inname : nuldev), "r");
+ fw = mpx_xfopen(mpx,(outname ? outname : nuldev), "wb");
+ @<Save and redirect the standard I/O@>;
+ retcode = do_spawn(mpx,cmdl[0], cmdl);
+ @<Restore the standard I/O@>;
+ mpx_fclose(mpx,fr);
+ mpx_fclose(mpx,fw);
+ return retcode;
+}
+
+@ @ Running Troff is more likely than not a series of pipes that
+feed input to each other. Makempx does all of this itself by using
+temporary files inbetween. That means we have to juggle about with
+|stdin| and |stdout|.
+
+This is the only non-ansi C bit of makempx.
+@^system dependencies@>
+
+@<Save and redirect the standard I/O@>=
+#ifdef WIN32
+#define DUP _dup
+#define DUPP _dup2
+#else
+#define DUP dup
+#define DUPP dup2
+#endif
+sav_i = DUP(fileno(stdin));
+sav_o = DUP(fileno(stdout));
+DUPP(fileno(fr), fileno(stdin));
+DUPP(fileno(fw), fileno(stdout))
+
+@ @<Restore the standard I/O@>=
+DUPP(sav_i, fileno(stdin));
+close(sav_i);
+DUPP(sav_o, fileno(stdout));
+close(sav_o)
+
+@ The allocation of the array pointed to by |cmdline_addr| is of
+course much larger than is really needed, but it will still only be a
+few hunderd bytes at the most, and this ensures that the separate
+parts of the |maincmd| will all fit.
+
+@d split_command(a,b) mpx_do_split_command(mpx,a,&b,' ')
+@d split_pipes(a,b) mpx_do_split_command(mpx,a,&b,'|')
+
+@c
+static int
+mpx_do_split_command(MPX mpx, char *maincmd, char ***cmdline_addr, char target) {
+ char *piece;
+ char *cmd;
+ char **cmdline;
+ size_t i;
+ int ret = 0;
+ int in_string = 0;
+ if (strlen(maincmd) == 0)
+ return 0;
+ i = sizeof(char *)*(strlen(maincmd)+1);
+ cmdline = xmalloc(i,1);
+ memset(cmdline,0,i);
+ *cmdline_addr = cmdline;
+
+ i = 0;
+ while (maincmd[i] == ' ')
+ i++;
+ cmd = xstrdup(maincmd);
+ piece = cmd;
+ for (; i <= strlen(maincmd); i++) {
+ if (in_string == 1) {
+ if (cmd[i] == '"') {
+ in_string = 0;
+ }
+ } else if (in_string == 2) {
+ if (cmd[i] == '\'') {
+ in_string = 0;
+ }
+ } else {
+ if (cmd[i] == '"') {
+ in_string = 1;
+ } else if (cmd[i] == '\'') {
+ in_string = 2;
+ } else if (cmd[i] == target) {
+ cmd[i] = 0;
+ cmdline[ret++] = piece;
+ while (i < strlen(maincmd) && cmd[(i + 1)] == ' ')
+ i++;
+ piece = cmd + i + 1;
+ }
+ }
+ }
+ if (*piece) {
+ cmdline[ret++] = piece;
+ }
+ return ret;
+}
+
+@ @<Globals@>=
+char *maincmd; /* TeX command name */
+
+@ @c
+static void mpx_command_cleanup (MPX mpx, char **cmdline) {
+ (void)mpx;
+ xfree(cmdline[0]);
+ xfree(cmdline);
+}
+
+
+
+@ @c
+static void mpx_command_error (MPX mpx, int cmdlength, char **cmdline) {
+ char *s = mpx_print_command(mpx, cmdlength, cmdline);
+ mpx_command_cleanup(mpx, cmdline);
+ mpx_abort(mpx, "Command failed: %s; see mpxerr.log", s);
+}
+
+
+
+@ @<Makempx header information@>=
+typedef struct mpx_options {
+ int mode;
+ char *cmd;
+ char *mptexpre;
+ char *mpname;
+ char *mpxname;
+ char *banner;
+ int debug;
+ mpx_file_finder find_file;
+} mpx_options;
+int mpx_makempx (mpx_options *mpxopt) ;
+int mpx_run_dvitomp (mpx_options *mpxopt) ;
+
+
+@
+
+@d ERRLOG "mpxerr.log"
+@d MPXLOG "makempx.log"
+
+@c
+int mpx_makempx (mpx_options *mpxopt) {
+ MPX mpx;
+ char **cmdline, **cmdbits;
+ char infile[15];
+ int retcode, i ;
+ char tmpname[] = "mpXXXXXX";
+ int cmdlength = 1;
+ int cmdbitlength = 1;
+ if (!mpxopt->debug) {
+ @<Check if mp file is newer than mpxfile, exit if not@>;
+ }
+ mpx = malloc(sizeof(struct mpx_data));
+ if (mpx==NULL || mpxopt->cmd==NULL || mpxopt->mpname==NULL || mpxopt->mpxname==NULL)
+ return mpx_fatal_error;
+ mpx_initialize(mpx);
+ if (mpxopt->banner!=NULL)
+ mpx->banner = mpxopt->banner;
+ mpx->mode = mpxopt->mode;
+ mpx->debug = mpxopt->debug;
+ if (mpxopt->find_file!=NULL)
+ mpx->find_file = mpxopt->find_file;
+ if (mpxopt->cmd!=NULL)
+ mpx->maincmd = xstrdup(mpxopt->cmd); /* valgrind says this leaks */
+ mpx->mpname = xstrdup(mpxopt->mpname);
+ mpx->mpxname = xstrdup(mpxopt->mpxname);
+ @<Install and test the non-local jump buffer@>;
+
+ if (mpx->debug) {
+ mpx->errfile = stderr;
+ } else {
+ mpx->errfile = mpx_xfopen(mpx,MPXLOG, "wb");
+ }
+ mpx->progname = "makempx";
+ @<Initialize the |tmpname| variable@>;
+ if (mpxopt->mptexpre == NULL)
+ mpxopt->mptexpre = xstrdup("mptexpre.tex");
+ @<Run |mpto| on the mp file@>;
+ if (mpxopt->cmd==NULL)
+ goto DONE;
+ if (mpx->mode == mpx_tex_mode) {
+ @<Run |TeX| and set up |infile| or abort@>;
+ if (mpx_dvitomp(mpx, infile)) {
+ mpx_rename(mpx, infile,DVIERR);
+ if (!mpx->debug)
+ remove(mpx->mpxname);
+ mpx_abort(mpx, "Dvi conversion failed: %s %s\n",
+ DVIERR, mpx->mpxname);
+ }
+ } else if (mpx->mode == mpx_troff_mode) {
+ @<Run |Troff| and set up |infile| or abort@>;
+ if (mpx_dmp(mpx, infile)) {
+ mpx_rename(mpx,infile, TROFF_OUTERR);
+ mpx_rename(mpx,mpx->tex, TROFF_INERR);
+ if (!mpx->debug)
+ remove(mpx->mpxname);
+ mpx_abort(mpx, "Troff conversion failed: %s %s\n",
+ TROFF_OUTERR, mpx->mpxname);
+ }
+ }
+ mpx_fclose(mpx,mpx->mpxfile);
+ if (!mpx->debug)
+ mpx_fclose(mpx,mpx->errfile);
+ if (!mpx->debug) {
+ remove(MPXLOG);
+ remove(ERRLOG);
+ remove(infile);
+ }
+ mpx_erasetmp(mpx);
+ DONE:
+ retcode = mpx->history;
+ mpx_xfree(mpx->buf);
+ mpx_xfree(mpx->maincmd);
+ for (i = 0; i < (int)mpx->nfonts; i++)
+ mpx_xfree(mpx->font_name[i]);
+ free(mpx);
+ if (retcode == mpx_cksum_trouble)
+ retcode = 0;
+ return retcode;
+}
+int mpx_run_dvitomp (mpx_options *mpxopt) {
+ MPX mpx;
+ int retcode, i ;
+ mpx = malloc(sizeof(struct mpx_data));
+ if (mpx==NULL || mpxopt->mpname==NULL || mpxopt->mpxname==NULL)
+ return mpx_fatal_error;
+ mpx_initialize(mpx);
+ if (mpxopt->banner!=NULL)
+ mpx->banner = mpxopt->banner;
+ mpx->mode = mpxopt->mode;
+ mpx->debug = mpxopt->debug;
+ if (mpxopt->find_file!=NULL)
+ mpx->find_file = mpxopt->find_file;
+ mpx->mpname = xstrdup(mpxopt->mpname);
+ mpx->mpxname = xstrdup(mpxopt->mpxname);
+ @<Install and test the non-local jump buffer@>;
+ if (mpx->debug) {
+ mpx->errfile = stderr;
+ } else {
+ mpx->errfile = mpx_xfopen(mpx,MPXLOG, "wb");
+ }
+ mpx->progname = "dvitomp";
+ if (mpx_dvitomp(mpx, mpx->mpname)) {
+ if (!mpx->debug)
+ remove(mpx->mpxname);
+ mpx_abort(mpx, "Dvi conversion failed: %s %s\n",
+ DVIERR, mpx->mpxname);
+ }
+ mpx_fclose(mpx,mpx->mpxfile);
+ if (!mpx->debug)
+ mpx_fclose(mpx,mpx->errfile);
+ if (!mpx->debug) {
+ remove(MPXLOG);
+ remove(ERRLOG);
+ }
+ mpx_erasetmp(mpx);
+ retcode = mpx->history;
+ mpx_xfree(mpx->buf);
+ for (i = 0; i < (int)mpx->nfonts; i++)
+ mpx_xfree(mpx->font_name[i]);
+ free(mpx);
+ if (retcode == mpx_cksum_trouble)
+ retcode = 0;
+ return retcode;
+}
+
+
+@ \TeX\ has to operate on an actual input file, so we have to append
+that to the command line.
+
+@<Run |TeX| and set ...@>=
+{
+ char log[15];
+ mpx->maincmd = xrealloc(mpx->maincmd,strlen(mpx->maincmd)+strlen(mpx->tex)+2,1);
+ strcat(mpx->maincmd, " ");
+ strcat(mpx->maincmd, mpx->tex);
+ cmdlength = split_command(mpx->maincmd, cmdline);
+
+ retcode = mpx_run_command(mpx, NULL, NULL, cmdlength, cmdline);
+
+ TMPNAME_EXT(log, ".log");
+ if (!retcode) {
+ TMPNAME_EXT(infile, ".dvi");
+ remove(log);
+ } else {
+ mpx_rename(mpx,mpx->tex, TEXERR);
+ mpx_rename(mpx,log, ERRLOG);
+ mpx_command_error(mpx, cmdlength, cmdline);
+ }
+ mpx_command_cleanup(mpx, cmdline);
+}
+
+@ @<Run |Troff| and set ...@>=
+{
+ char *cur_in, *cur_out;
+ char tmp_a[15], tmp_b[15];
+ TMPNAME_EXT(tmp_a, ".t");
+ TMPNAME_EXT(tmp_b, ".tmp");
+ cur_in = mpx->tex;
+ cur_out = tmp_a;
+
+ /* split the command in bits */
+ cmdbitlength = split_pipes(mpx->maincmd, cmdbits);
+ cmdline = NULL;
+
+ for (i = 0; i < cmdbitlength; i++) {
+ if (cmdline!=NULL) free(cmdline);
+ cmdlength = split_command(cmdbits[i], cmdline);
+ retcode = mpx_run_command(mpx, cur_in, cur_out, cmdlength, cmdline);
+
+ if (retcode) {
+ mpx_rename(mpx,mpx->tex, TROFF_INERR);
+ mpx_command_error(mpx, cmdlength, cmdline);
+ }
+ if (i < cmdbitlength - 1) {
+ if (i % 2 == 0) {
+ cur_in = tmp_a;
+ cur_out = tmp_b;
+ } else {
+ cur_in = tmp_b;
+ cur_out = tmp_a;
+ }
+ }
+ }
+ if (tmp_a!=cur_out) { remove(tmp_a); }
+ if (tmp_b!=cur_out) { remove(tmp_b); }
+ strcpy(infile,cur_out);
+}
+
+@ If MPX file is up-to-date or if MP file does not exist, do nothing.
+
+@<Check if mp file is newer than mpxfile, exit if not@>=
+if (mpx_newer(mpxopt->mpname, mpxopt->mpxname))
+ return 0
+
+
+@ The splint comment is here because this use of |sprintf()| is definately safe
+
+@<Initialize the |tmpname| variable@>=
+@= /*@@-bufferoverflowhigh@@*/ @>
+#ifdef HAVE_MKSTEMP
+ i = mkstemp(tmpname);
+ if (i == -1) {
+ sprintf(tmpname, "mp%06d", (int)(time(NULL) % 1000000));
+ } else {
+ close(i);
+ remove(tmpname);
+ }
+#else
+#ifdef HAVE_MKTEMP
+ {
+ char *tmpstring = mktemp(tmpname);
+ if ((tmpstring == NULL) || strlen(tmpname) == 0) {
+ sprintf(tmpname, "mp%06d", (int)(time(NULL) % 1000000));
+ } else {
+ /* this should not really be needed, but better
+ safe than sorry. */
+ if (tmpstring != tmpname) {
+ i = strlen(tmpstring);
+ if (i > 8) i = 8;
+ strncpy(tmpname, tmpstring, i);
+ }
+ }
+ }
+#else
+ sprintf(tmpname, "mp%06d", (int)(time(NULL) % 1000000));
+#endif
+#endif
+@= /*@@+bufferoverflowhigh@@*/ @>
diff --git a/Build/source/texk/web2c/mplibdir/pngout.w b/Build/source/texk/web2c/mplibdir/pngout.w
new file mode 100644
index 00000000000..742522c2ff7
--- /dev/null
+++ b/Build/source/texk/web2c/mplibdir/pngout.w
@@ -0,0 +1,911 @@
+% Copyright 2012 Taco Hoekwater.
+%
+% This program is free software: you can redistribute it and/or modify
+% it under the terms of the GNU Lesser General Public License as published by
+% the Free Software Foundation, either version 3 of the License, or
+% (at your option) any later version.
+%
+% This program is distributed in the hope that it will be useful,
+% but WITHOUT ANY WARRANTY; without even the implied warranty of
+% MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+% GNU Lesser General Public License for more details.
+%
+% You should have received a copy of the GNU Lesser General Public License
+% along with this program. If not, see <http://www.gnu.org/licenses/>.
+%
+% 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
+
+\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}
+\def\[#1]{} % from pascal web
+\def\(#1){} % this is used to make section names sort themselves better
+\def\9#1{} % this is used for sort keys in the index via @@:sort key}{entry@@>
+
+\def\title{MetaPost PNG output}
+\def\topofcontents{\hsize 5.5in
+ \vglue -30pt plus 1fil minus 1.5in
+ \def\?##1]{\hbox to 1in{\hfil##1.\ }}
+ }
+\def\botofcontents{\vskip 0pt plus 1fil minus 1.5in}
+\pdfoutput=1
+\pageno=3
+
+@
+@d zero_t ((math_data *)mp->math)->zero_t
+@d number_zero(A) (((math_data *)(mp->math))->equal)(A,zero_t)
+@d number_greater(A,B) (((math_data *)(mp->math))->greater)(A,B)
+@d number_positive(A) number_greater(A, zero_t)
+@d number_to_scaled(A) (((math_data *)(mp->math))->to_scaled)(A)
+@d round_unscaled(A) (((math_data *)(mp->math))->round_unscaled)(A)
+@d true 1
+@d false 0
+@d null_font 0
+@d null 0
+@d unity 1.0
+@d incr(A) (A)=(A)+1 /* increase a variable by unity */
+@d decr(A) (A)=(A)-1 /* decrease a variable by unity */
+@d negate(A) (A)=-(A) /* change the sign of a variable */
+
+@c
+#include <w2c/config.h>
+#include <stdio.h>
+#include <stdlib.h>
+#include <string.h>
+#include <math.h>
+#include "mplib.h"
+#include "mplibps.h" /* external header */
+#include "mplibpng.h" /* external header */
+#include "mpmp.h" /* internal header */
+#include "mppsout.h" /* internal header */
+#include "mppngout.h" /* internal header */
+#include "mpmath.h" /* internal header */
+@h
+@<Types in the outer block@>
+@<Declarations@>
+
+@ There is a small bit of code from the backend that bleads through
+to the frontend because I do not know how to set up the includes
+properly. That is |typedef struct pngout_data_struct * pngout_data|.
+
+@ @(mppngout.h@>=
+#ifndef MPPNGOUT_H
+#define MPPNGOUT_H 1
+#include "cairo.h"
+const char *COMPILED_CAIRO_VERSION_STRING = CAIRO_VERSION_STRING;
+#include "pixman.h"
+const char *COMPILED_PIXMAN_VERSION_STRING = PIXMAN_VERSION_STRING;
+#define PNG_SKIP_SETJMP_CHECK 1
+#include "png.h"
+#include "mplib.h"
+#include "mpmp.h"
+#include "mplibps.h"
+typedef struct pngout_data_struct {
+ @<Globals@>
+} pngout_data_struct ;
+@<Exported function headers@>
+#endif
+
+@ @<Exported function headers@>=
+void mp_png_backend_initialize (MP mp) ;
+void mp_png_backend_free (MP mp) ;
+
+@ @c
+void mp_png_backend_initialize (MP mp) {
+ mp->png = mp_xmalloc(mp,1,sizeof(pngout_data_struct));
+ memset(mp->png,0,sizeof(pngout_data_struct));
+}
+void mp_png_backend_free (MP mp) {
+ mp_xfree(mp->png);
+ mp->png = NULL;
+}
+
+@ Writing to PNG files
+
+@<Globals@>=
+cairo_surface_t *surface;
+cairo_t *cr;
+
+@ We often need to print a pair of coordinates, and these need to
+offset so that all coordinates are positive.
+
+@<Globals@>=
+integer dx;
+integer dy;
+
+@
+@<Declarations@>=
+static void mp_png_start(MP mp,mp_edge_object *hh, double hppp, double vppp, int colormodel, int antialias);
+
+@
+@c
+void mp_png_start(MP mp,mp_edge_object *hh, double hppp, double vppp, int colormodel, int antialias) {
+ double w, h;
+ if ( hh->minx>hh->maxx) {
+ w = 1;
+ h = 1;
+ mp->png->dx = 0;
+ mp->png->dy = 0;
+ } else {
+ w = (ceil(hh->maxx) - floor(hh->minx)) / hppp;
+ h = (ceil(hh->maxy) - floor(hh->miny)) / vppp;
+ mp->png->dx = -floor(hh->minx);
+ mp->png->dy = -floor(hh->miny);
+ }
+ mp->png->surface = cairo_image_surface_create (CAIRO_FORMAT_ARGB32, w, h);
+ mp->png->cr = cairo_create (mp->png->surface);
+ /* if there is no alpha channel, a white background is needed */
+ if (colormodel == PNG_COLOR_TYPE_RGB ||
+ colormodel == PNG_COLOR_TYPE_GRAY) {
+ cairo_save(mp->png->cr);
+ cairo_set_source_rgb(mp->png->cr, 1.0, 1.0, 1.0);
+ cairo_rectangle(mp->png->cr, 0, 0, w, h);
+ cairo_fill(mp->png->cr);
+ cairo_restore(mp->png->cr);
+ }
+ cairo_scale(mp->png->cr, 1/hppp, -1/vppp);
+ cairo_translate(mp->png->cr, 0, -(h*vppp));
+ cairo_translate(mp->png->cr, mp->png->dx, mp->png->dy);
+ cairo_set_antialias(mp->png->cr, antialias);
+}
+
+@ Outputting a color specification.
+
+@d set_color_objects(pq)
+ object_color_model = pq->color_model;
+ object_color_a = pq->color.a_val;
+ object_color_b = pq->color.b_val;
+ object_color_c = pq->color.c_val;
+ object_color_d = pq->color.d_val;
+
+@c
+static void mp_png_color_out (MP mp, mp_graphic_object *p) {
+ int object_color_model;
+ double object_color_a, object_color_b, object_color_c, object_color_d ;
+ if (gr_type(p) == mp_fill_code) {
+ mp_fill_object *pq = (mp_fill_object *)p;
+ set_color_objects(pq);
+ } else if (gr_type(p) == mp_stroked_code) {
+ mp_stroked_object *pq = (mp_stroked_object *)p;
+ set_color_objects(pq);
+ } else {
+ mp_text_object *pq = (mp_text_object *)p;
+ set_color_objects(pq);
+ }
+ if ( object_color_model==mp_no_model ) {
+ cairo_set_source_rgb (mp->png->cr, 0, 0, 0);
+ } else {
+ if ( object_color_model==mp_grey_model ) {
+ object_color_b = object_color_a;
+ object_color_c = object_color_a;
+ } else if ( object_color_model==mp_cmyk_model) {
+ int c,m,y,k;
+ c = object_color_a;
+ m = object_color_b;
+ y = object_color_c;
+ k = object_color_d;
+ object_color_a = unity - (c+k>unity ? unity : c+k);
+ object_color_b = unity - (m+k>unity ? unity : m+k);
+ object_color_c = unity - (y+k>unity ? unity : y+k);
+ }
+ cairo_set_source_rgb (mp->png->cr, object_color_a, object_color_b, object_color_c);
+ }
+}
+
+@ @<Declarations@>=
+static void mp_png_color_out (MP mp, mp_graphic_object *p);
+
+@ This is the information that comes from a pen
+
+@<Types...@>=
+typedef struct mp_pen_info {
+ double tx, ty;
+ double sx, rx, ry, sy;
+ double ww;
+} mp_pen_info;
+
+
+@ (Re)discover the characteristics of an elliptical pen
+
+@<Declarations@>=
+mp_pen_info *mp_png_pen_info(MP mp, mp_gr_knot pp, mp_gr_knot p);
+
+@ The next two constants come from the original web source.
+Together with the two helper functions, they will tell whether
+the |x| or the |y| direction of the path is the most important
+
+@d aspect_bound (10/65536.0)
+@d aspect_default 1
+
+@c
+static double coord_range_x (mp_gr_knot h, double dz) {
+ double z;
+ double zlo = 0, zhi = 0;
+ mp_gr_knot f = h;
+ while (h != NULL) {
+ z = gr_x_coord(h);
+ if (z < zlo) zlo = z; else if (z > zhi) zhi = z;
+ z = gr_right_x(h);
+ if (z < zlo) zlo = z; else if (z > zhi) zhi = z;
+ z = gr_left_x(h);
+ if (z < zlo) zlo = z; else if (z > zhi) zhi = z;
+ h = gr_next_knot(h);
+ if (h==f)
+ break;
+ }
+ return (zhi - zlo <= dz ? aspect_bound : aspect_default);
+}
+static double coord_range_y (mp_gr_knot h, double dz) {
+ double z;
+ double zlo = 0, zhi = 0;
+ mp_gr_knot f = h;
+ while (h != NULL) {
+ z = gr_y_coord(h);
+ if (z < zlo) zlo = z; else if (z > zhi) zhi = z;
+ z = gr_right_y(h);
+ if (z < zlo) zlo = z; else if (z > zhi) zhi = z;
+ z = gr_left_y(h);
+ if (z < zlo) zlo = z; else if (z > zhi) zhi = z;
+ h = gr_next_knot(h);
+ if (h==f)
+ break;
+ }
+ return (zhi - zlo <= dz ? aspect_bound : aspect_default);
+}
+
+@
+@c
+mp_pen_info *mp_png_pen_info(MP mp, mp_gr_knot pp, mp_gr_knot p) {
+ double wx, wy; /* temporary pen widths, in either direction */
+ struct mp_pen_info *pen; /* return structure */
+ if (p == NULL)
+ return NULL;
+ pen = mp_xmalloc(mp, 1, sizeof(mp_pen_info));
+ pen->rx = unity;
+ pen->ry = unity;
+ pen->ww = unity;
+ if ((gr_right_x(p) == gr_x_coord(p))
+ &&
+ (gr_left_y(p) == gr_y_coord(p))) {
+ wx = fabs(gr_left_x(p) - gr_x_coord(p));
+ wy = fabs(gr_right_y(p) - gr_y_coord(p));
+ } else {
+ double arg1, arg2;
+ arg1 = gr_left_x(p)-gr_x_coord(p);
+ arg2 = gr_right_x(p)-gr_x_coord(p);
+ wx = sqrt(arg1*arg1 + arg2*arg2);
+ arg1 = gr_left_y(p)-gr_y_coord(p);
+ arg2 = gr_right_y(p)-gr_y_coord(p);
+ wy = sqrt(arg1*arg1 + arg2*arg2);
+ }
+ if ((wy/coord_range_x(pp, wx)) >= (wx/coord_range_y(pp, wy)))
+ pen->ww = wy;
+ else
+ pen->ww = wx;
+ pen->tx = gr_x_coord(p);
+ pen->ty = gr_y_coord(p);
+ pen->sx = gr_left_x(p) - pen->tx;
+ pen->rx = gr_left_y(p) - pen->ty;
+ pen->ry = gr_right_x(p) - pen->tx;
+ pen->sy = gr_right_y(p) - pen->ty;
+ if (pen->ww != unity) {
+ if (pen->ww == 0) {
+ pen->sx = unity;
+ pen->sy = unity;
+ } else {
+ pen->rx = pen->rx / pen->ww;
+ pen->ry = pen->ry / pen->ww;
+ pen->sx = pen->sx / pen->ww;
+ pen->sy = pen->sy / pen->ww;
+ }
+ }
+ return pen;
+}
+
+@ 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|.
+
+@<Declarations@>=
+static boolean mp_is_curved(mp_gr_knot p, mp_gr_knot q) ;
+
+
+@
+@d bend_tolerance (131/65536.0) /* allow rounding error of $2\cdot10^{-3}$ */
+
+@c
+boolean mp_is_curved(mp_gr_knot p, mp_gr_knot q) {
+ double d; /* a temporary value */
+ if ( gr_right_x(p)==gr_x_coord(p) )
+ if ( gr_right_y(p)==gr_y_coord(p) )
+ if ( gr_left_x(q)==gr_x_coord(q) )
+ if ( gr_left_y(q)==gr_y_coord(q) )
+ return false;
+ d=gr_left_x(q)-gr_right_x(p);
+ if ( fabs(gr_right_x(p)-gr_x_coord(p)-d)<=bend_tolerance )
+ if ( fabs(gr_x_coord(q)-gr_left_x(q)-d)<=bend_tolerance ) {
+ d=gr_left_y(q)-gr_right_y(p);
+ if ( fabs(gr_right_y(p)-gr_y_coord(p)-d)<=bend_tolerance )
+ if ( fabs(gr_y_coord(q)-gr_left_y(q)-d)<=bend_tolerance )
+ return false;
+ }
+ return true;
+}
+
+
+@ Cairo does not want to draw a path that consists of only a moveto,
+so make sure there is some kind of line even for single-pair paths.
+@c
+static void mp_png_path_out (MP mp, mp_gr_knot h) {
+ mp_gr_knot p, q; /* for scanning the path */
+ int steps = 0;
+ cairo_move_to (mp->png->cr, gr_x_coord(h),gr_y_coord(h));
+ p=h;
+ do {
+ if ( gr_right_type(p)==mp_endpoint ) {
+ if (steps==0) {
+ cairo_line_to (mp->png->cr, gr_x_coord(p),gr_y_coord(p));
+ }
+ return;
+ }
+ q=gr_next_knot(p);
+ if (mp_is_curved(p, q)){
+ cairo_curve_to (mp->png->cr, gr_right_x(p),gr_right_y(p),
+ gr_left_x(q),gr_left_y(q),
+ gr_x_coord(q),gr_y_coord(q));
+ } else {
+ cairo_line_to (mp->png->cr, gr_x_coord(q),gr_y_coord(q));
+ }
+ p=q;
+ steps++;
+ } while (p!=h);
+ if ((gr_x_coord(p) == gr_x_coord(h)) && (gr_y_coord(p) == gr_y_coord(h)) &&
+ gr_right_type(p)!=mp_endpoint) {
+ cairo_close_path(mp->png->cr);
+ }
+}
+
+@ Now for outputting the actual graphic objects.
+
+@<Declarations@>=
+static double mp_png_choose_scale (MP mp, mp_graphic_object *p) ;
+
+@ @c double mp_png_choose_scale (MP mp, mp_graphic_object *p) {
+ /* |p| should point to a text node */
+ double a,b,c,d,ad,bc; /* temporary values */
+ double ret1, ret2;
+ a=gr_txx_val(p);
+ b=gr_txy_val(p);
+ c=gr_tyx_val(p);
+ d=gr_tyy_val(p);
+ if ( a<0 ) negate(a);
+ if ( b<0 ) negate(b);
+ if ( c<0 ) negate(c);
+ if ( d<0 ) negate(d);
+ ad=(a-d)/2.0;
+ bc=(b-c)/2.0;
+ ret1 = sqrt((d+ad)*(d+ad) + ad*ad);
+ ret2 = sqrt((c+bc)*(c+bc) + bc*bc);
+ return sqrt(ret1*ret1 + ret2*ret2);
+}
+
+@
+@d xrealloc(P,A,B) mp_xrealloc(mp,P,(size_t)A,B)
+@d XREALLOC(a,b,c) a = xrealloc(a,(b+1),sizeof(c));
+
+@c
+void mp_reallocate_psfonts (MP mp, int l) {
+ if (l>=mp->png->font_max) {
+ int f;
+ mp->png->last_fnum = mp->png->font_max;
+ XREALLOC (mp->png->psfonts, l, mp_edge_object *);
+ for (f = (mp->png->last_fnum + 1); f <= l; f++) {
+ mp->png->psfonts[f] = NULL;
+ }
+ mp->png->font_max = l;
+ }
+}
+
+@ @<Declarations@>=
+void mp_reallocate_psfonts (MP mp, int l);
+
+@ @<Globals@>=
+mp_edge_object **psfonts;
+int font_max;
+int last_fnum;
+
+@ @<Declarations@>=
+static void mp_png_text_out (MP mp, mp_text_object *p) ;
+
+@ @c
+void mp_png_text_out (MP mp, mp_text_object *p) {
+ double ds; /* design size and scale factor for a text node */
+ unsigned char *s = (unsigned char *)gr_text_p(p);
+ size_t l = gr_text_l(p); /* string length */
+ boolean transformed= (gr_txx_val(p)!=unity)||(gr_tyy_val(p)!=unity)||
+ (gr_txy_val(p)!=0)||(gr_tyx_val(p)!=0);
+ int fn = gr_font_n(p);
+ mp_ps_font *f;
+ double scf;
+ ds =(mp->font_dsize[fn]+8) / (16*65536.0);
+ scf = mp_png_choose_scale (mp,(mp_graphic_object *)p);
+ cairo_save(mp->png->cr);
+ if ( transformed ) {
+ cairo_matrix_t matrix = {0,0,0,0,0,0};
+ cairo_matrix_init(&matrix, (gr_txx_val(p)/scf), (gr_tyx_val(p)/scf),
+ (gr_txy_val(p)/scf), (gr_tyy_val(p)/scf),
+ gr_tx_val(p),gr_ty_val(p));
+ cairo_transform (mp->png->cr, &matrix);
+ cairo_move_to(mp->png->cr, 0, 0);
+ } else {
+ cairo_translate (mp->png->cr,gr_tx_val(p),gr_ty_val(p));
+ }
+ cairo_scale(mp->png->cr, ((ds/1000.0)*scf), ((ds/1000.0)*scf));
+ mp_png_color_out(mp,(mp_graphic_object *)p);
+ while (l-->0) {
+ mp_edge_object *ch;
+ int k = (int)*s++;
+ double wd = 0.0; /* this is in PS design units */
+ mp_reallocate_psfonts(mp, ((fn+1) * 256));
+ ch = mp->png->psfonts[(fn*256)+k];
+ if (ch == NULL) {
+ f = mp_ps_font_parse(mp, fn);
+ if (f == NULL) return;
+ ch = mp_ps_font_charstring(mp,f,k);
+ mp->png->psfonts[(fn*256)+k] = ch;
+ }
+ if (ch != NULL) {
+ mp_graphic_object *pp = ch->body;
+ while (pp!=NULL) {
+ mp_png_path_out(mp, gr_path_p((mp_fill_object *)pp));
+ pp=pp->next;
+ }
+ cairo_fill(mp->png->cr);
+ }
+ wd = mp_get_char_dimension (mp, mp->font_name[fn], k, 'w');
+/* $wd/100$ is the size in PS point , i.e, $wd =100\cdot real\_wd$
+ but without considering scaling.
+ We have a scale factor of
+ $(ds/1000.0)\cdot scf$
+ so to match the scale wd should be
+ $1000\cdot real_wd\cdot scf /(ds\cdot scf)$
+ i.e. $wd = 10\cdot wd/ds$.
+*/
+ wd *= 10.0/ds;
+ cairo_translate(mp->png->cr,wd,0);
+ }
+ cairo_restore(mp->png->cr);
+}
+
+@ 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 $$\&{\<g>}\ldots\&{\</g>}$$
+block. Any translation component must be applied to the path being stroked
+while the rest of the transformation must apply only to the pen.
+If |fill_also=true|, the path is to be filled as well as stroked so we must
+insert commands to do this after giving the path.
+
+@<Declarations@>=
+static void mp_png_stroke_out (MP mp, mp_graphic_object *h,
+ mp_pen_info *pen, boolean fill_also) ;
+
+
+@ @c
+void mp_png_stroke_out (MP mp, mp_graphic_object *h,
+ mp_pen_info *pen, boolean fill_also) {
+ boolean transformed = false;
+ if (fill_also) {
+ cairo_save(mp->png->cr);
+ mp_png_path_out(mp, gr_path_p((mp_stroked_object *)h));
+ cairo_close_path (mp->png->cr);
+ cairo_fill (mp->png->cr);
+ cairo_restore(mp->png->cr);
+ }
+ cairo_save(mp->png->cr);
+ if (pen != NULL) {
+ transformed = true;
+ if ((pen->sx==unity) &&
+ (pen->rx==0) &&
+ (pen->ry==0) &&
+ (pen->sy==unity) &&
+ (pen->tx==0) &&
+ (pen->ty==0)) {
+ transformed = false;
+ }
+ }
+ if (pen != NULL) {
+ cairo_set_line_width(mp->png->cr, pen->ww);
+ } else {
+ cairo_set_line_width(mp->png->cr, 0);
+ }
+ if (gr_lcap_val(h)!=0) {
+ switch (gr_lcap_val(h)) {
+ case 1: cairo_set_line_cap(mp->png->cr,CAIRO_LINE_CAP_ROUND); break;
+ case 2: cairo_set_line_cap(mp->png->cr,CAIRO_LINE_CAP_SQUARE); break;
+ default:cairo_set_line_cap(mp->png->cr,CAIRO_LINE_CAP_BUTT); break;
+ }
+ }
+ if (gr_type(h)!=mp_fill_code) {
+ mp_dash_object *hh= gr_dash_p(h);
+ if (hh != NULL && hh->array != NULL) {
+ int i;
+ for (i=0; *(hh->array+i) != -1;i++)
+ ;
+ cairo_set_dash (mp->png->cr, hh->array, i, hh->offset);
+ }
+ }
+ if (gr_ljoin_val((mp_stroked_object *)h)!=0) {
+ switch (gr_ljoin_val((mp_stroked_object *)h)) {
+ case 1: cairo_set_line_join(mp->png->cr,CAIRO_LINE_JOIN_ROUND); break;
+ case 2: cairo_set_line_join(mp->png->cr,CAIRO_LINE_JOIN_BEVEL); break;
+ default: cairo_set_line_join(mp->png->cr,CAIRO_LINE_JOIN_MITER); break;
+ }
+ }
+ cairo_set_miter_limit(mp->png->cr,gr_miterlim_val((mp_stroked_object *)h));
+ mp_png_path_out(mp, gr_path_p((mp_stroked_object *)h));
+ if (transformed) {
+ cairo_matrix_t matrix = {0,0,0,0,0,0};
+ cairo_save(mp->png->cr);
+ cairo_matrix_init(&matrix, pen->sx, pen->rx, pen->ry, pen->sy, pen->tx, pen->ty);
+ cairo_transform (mp->png->cr, &matrix);
+ cairo_stroke (mp->png->cr);
+ cairo_restore(mp->png->cr);
+ } else {
+ cairo_stroke (mp->png->cr);
+ }
+ cairo_restore(mp->png->cr);
+}
+
+@ Here is a simple routine that just fills a cycle.
+
+@<Declarations@>=
+static void mp_png_fill_out (MP mp, mp_gr_knot p, mp_graphic_object *h);
+
+@ @c
+void mp_png_fill_out (MP mp, mp_gr_knot p, mp_graphic_object *h) {
+ cairo_save(mp->png->cr);
+ mp_png_path_out(mp, p);
+ cairo_close_path (mp->png->cr);
+ cairo_fill (mp->png->cr);
+ cairo_restore(mp->png->cr);
+}
+
+@ The main output function
+
+@d pen_is_elliptical(A) ((A)==gr_next_knot((A)))
+@d gr_has_color(A) (gr_type((A))<mp_start_clip_code)
+
+@<Exported function ...@>=
+int mp_png_gr_ship_out (mp_edge_object *hh, const char *options, int standalone) ;
+
+@ This is a structure to ship data from cairo to our png writer. |width| and
+|height| could have been stored in our private |mp| instance, but this is just
+as easy.
+
+@<Types...@>=
+typedef struct {
+ unsigned char * data;
+ int height;
+ int width;
+} bitmap_t;
+
+@ This is a small structure that is needed so that the png writer callbacks
+can actually access the |mp| object instance.
+
+@<Types...@>=
+typedef struct {
+ void *fp;
+ MP mp;
+} mp_png_io;
+
+@ Output a png chunk: the libpng callbacks
+@c
+static void mp_write_png_data(png_structp png_ptr, png_bytep data, png_size_t length)
+{
+ mp_png_io *ioptr = (mp_png_io *)png_get_io_ptr(png_ptr);
+ MP mp = ioptr->mp;
+ (mp->write_binary_file)(mp,ioptr->fp, (void *)data, (size_t)length);
+}
+static void mp_write_png_flush(png_structp png_ptr)
+{
+ /* nothing to do */
+}
+
+
+@ Write |bitmap| to a PNG file specified by |path|; returns 0 on
+success, non-zero on error. The original of this function was
+borrowed from an internet post, and extended as needed.
+
+@<Declarations@>=
+int mp_png_save_to_file (MP mp, const bitmap_t * bitmap, const char *path, int colormodel);
+
+@ @c
+int mp_png_save_to_file (MP mp, const bitmap_t * bitmap, const char *path, int colormodel)
+{
+ mp_png_io io;
+ png_structp png_ptr = NULL;
+ png_infop info_ptr = NULL;
+ size_t y;
+ png_byte ** row_pointers = NULL;
+ int status = -1;
+ int depth = 8;
+ int dpi = 72;
+ int ppm_x;
+ int ppm_y; /* pixels per metre */
+
+ io.mp = mp;
+ io.fp = (mp->open_file)(mp, path, "wb", mp_filetype_bitmap);
+ if (!io.fp) {
+ goto fopen_failed;
+ }
+
+ png_ptr = png_create_write_struct (PNG_LIBPNG_VER_STRING, NULL, NULL, NULL);
+ if (png_ptr == NULL) {
+ goto png_create_write_struct_failed;
+ }
+
+ info_ptr = png_create_info_struct (png_ptr);
+ if (info_ptr == NULL) {
+ goto png_create_info_struct_failed;
+ }
+
+ /* Set up error handling. */
+
+ if (setjmp (png_jmpbuf (png_ptr))) {
+ goto png_failure;
+ }
+
+ /* Set image attributes. */
+
+ png_set_IHDR (png_ptr,
+ info_ptr,
+ bitmap->width,
+ bitmap->height,
+ depth,
+ colormodel,
+ PNG_INTERLACE_NONE,
+ PNG_COMPRESSION_TYPE_DEFAULT,
+ PNG_FILTER_TYPE_DEFAULT);
+
+ /* Compression level |3| appears the best tradeoff between
+ disk size and compression speed */
+ png_set_compression_level(png_ptr, 3);
+ png_set_filter(png_ptr,0,PNG_FILTER_NONE);
+ /* setup some information */
+ if (1) {
+ png_text text[2];
+ char *a, *b, *c, *d; /* to get rid of a typecast warning */
+ a = xstrdup("Title");
+ b = xstrdup(path);
+ c = xstrdup("Software");
+ d = xstrdup("Generated by Metapost version " metapost_version);
+
+ text[0].compression = PNG_TEXT_COMPRESSION_NONE;
+ text[0].key = a;
+ text[0].text = b;
+ text[1].compression = PNG_TEXT_COMPRESSION_NONE;
+ text[1].key = c;
+ text[1].text = d;
+ png_set_text(png_ptr, info_ptr, text, 2);
+
+ free(a);
+ free(b);
+ free(c);
+ free(d);
+ }
+
+ /* The original plan was to add |hppp| and |vppp| values in here,
+ but that seems to have negative effects on various bits of
+ software. Better keep the DPI at 72 */
+ ppm_x = dpi / 0.0254;
+ ppm_y = dpi / 0.0254;
+ png_set_pHYs(png_ptr, info_ptr, ppm_x, ppm_y, PNG_RESOLUTION_METER);
+
+ /* Initialize rows of PNG. */
+
+ row_pointers = malloc (bitmap->height * sizeof (png_byte *));
+ for (y = 0; y < bitmap->height; ++y) {
+ if (colormodel == PNG_COLOR_TYPE_GRAY) {
+ row_pointers[y] = bitmap->data + bitmap->width * y;
+ } else if (colormodel == PNG_COLOR_TYPE_GRAY_ALPHA) {
+ row_pointers[y] = bitmap->data + bitmap->width * 2 * y;
+ } else {
+ row_pointers[y] = bitmap->data + bitmap->width * 4 * y;
+ }
+ }
+
+ /* Write the image data to |io| */
+ png_set_write_fn(png_ptr, &io, mp_write_png_data, mp_write_png_flush);
+
+ png_set_rows (png_ptr, info_ptr, row_pointers);
+ if (colormodel == PNG_COLOR_TYPE_RGB) {
+ /* Unfortunately, |png_write_png| does not have enough |PNG_TRANSFORM| options
+ to do this properly, so we have to modify the bitmap data */
+ int i;
+ for (i = 0; i < bitmap->width*bitmap->height*4; i+=4) {
+ unsigned char b = bitmap->data[i];
+ unsigned char g = bitmap->data[i+1];
+ bitmap->data[i] = bitmap->data[i+3];
+ bitmap->data[i+1] = bitmap->data[i+2];
+ bitmap->data[i+2] = g;
+ bitmap->data[i+3] = b;
+ }
+ png_write_png (png_ptr, info_ptr, PNG_TRANSFORM_STRIP_FILLER, NULL);
+ } else if (colormodel == PNG_COLOR_TYPE_RGB_ALPHA) {
+ png_write_png (png_ptr, info_ptr, PNG_TRANSFORM_BGR, NULL);
+ } else if (colormodel == PNG_COLOR_TYPE_GRAY ||
+ colormodel == PNG_COLOR_TYPE_GRAY_ALPHA) {
+ int i, j;
+ j = 0;
+ for (i = 0; i < bitmap->width*bitmap->height*4; i+=4) {
+ unsigned char b = bitmap->data[i];
+ unsigned char g = bitmap->data[i+1];
+ unsigned char r = bitmap->data[i+2];
+ bitmap->data[j++] = ((r==g && r==b) ? r : 0.2126*r + 0.7152*g + 0.0722*b);
+ if (colormodel == PNG_COLOR_TYPE_GRAY_ALPHA)
+ bitmap->data[j++] = bitmap->data[i+3];
+ }
+ png_write_png (png_ptr, info_ptr, PNG_TRANSFORM_IDENTITY, NULL);
+ }
+ status = 0;
+
+ free (row_pointers);
+
+ png_failure:
+ png_create_info_struct_failed:
+ png_destroy_write_struct (&png_ptr, &info_ptr);
+ png_create_write_struct_failed:
+ (mp->close_file)(mp, io.fp);
+ fopen_failed:
+ return status;
+}
+
+
+@
+@d number_to_double(A) (((math_data *)(mp->math))->to_double)(A)
+
+@c
+int mp_png_gr_ship_out (mp_edge_object *hh, const char *options, int standalone) {
+ char *ss;
+ mp_graphic_object *p;
+ mp_pen_info *pen = NULL;
+ MP mp = hh->parent;
+ bitmap_t bitmap;
+ const char *currentoption = options;
+ int colormodel = PNG_COLOR_TYPE_RGB_ALPHA;
+ int antialias = CAIRO_ANTIALIAS_FAST;
+ int c;
+ while (currentoption && *currentoption) {
+ if (strncmp(currentoption,"format=",7)==0) {
+ currentoption += 7;
+ if (strncmp(currentoption,"rgba",4)==0) {
+ colormodel = PNG_COLOR_TYPE_RGB_ALPHA;
+ currentoption += 4;
+ } else if (strncmp(currentoption,"rgb",3)==0) {
+ colormodel = PNG_COLOR_TYPE_RGB;
+ currentoption += 3;
+ } else if (strncmp(currentoption,"graya",5)==0) {
+ colormodel = PNG_COLOR_TYPE_GRAY_ALPHA;
+ currentoption += 5;
+ } else if (strncmp(currentoption,"gray",4)==0) {
+ colormodel = PNG_COLOR_TYPE_GRAY;
+ currentoption += 4;
+ }
+ } else if (strncmp(currentoption,"antialias=",10)==0) {
+ currentoption += 10;
+ if (strncmp(currentoption,"none",4)==0) {
+ antialias = CAIRO_ANTIALIAS_NONE;
+ currentoption += 4;
+ } else if (strncmp(currentoption,"fast",4)==0) {
+ antialias = CAIRO_ANTIALIAS_FAST;
+ currentoption += 4;
+ } else if (strncmp(currentoption,"good",4)==0) {
+ antialias = CAIRO_ANTIALIAS_GOOD;
+ currentoption += 4;
+ } else if (strncmp(currentoption,"best",4)==0) {
+ antialias = CAIRO_ANTIALIAS_BEST;
+ currentoption += 4;
+ }
+ }
+ currentoption = strchr(currentoption,' ');
+ if (currentoption) {
+ while (*currentoption == ' ')
+ currentoption++;
+ }
+ }
+ c = round_unscaled(internal_value (mp_char_code));
+ if (standalone) {
+ mp->jump_buf = malloc(sizeof(jmp_buf));
+ if (mp->jump_buf == NULL || setjmp(*(mp->jump_buf)))
+ return 0;
+ }
+ if (mp->history >= mp_fatal_error_stop ) return 1;
+ mp_png_start(mp, hh, number_to_double(internal_value(mp_hppp)), number_to_double(internal_value(mp_vppp)),
+ colormodel, antialias);
+ p = hh->body;
+ while ( p!=NULL ) {
+ if (gr_has_color (p))
+ mp_png_color_out (mp, p);
+ switch (gr_type(p)) {
+ case mp_fill_code:
+ {
+ mp_fill_object *ph = (mp_fill_object *)p;
+ if ( gr_pen_p(ph)==NULL ) {
+ mp_png_fill_out(mp, gr_path_p(ph), p);
+ } else if ( pen_is_elliptical(gr_pen_p(ph)) ) {
+ pen = mp_png_pen_info(mp, gr_path_p(ph), gr_pen_p(ph));
+ mp_png_stroke_out(mp, p, pen, true);
+ mp_xfree(pen);
+ } else {
+ mp_png_fill_out(mp, gr_path_p(ph), p);
+ mp_png_fill_out(mp, gr_htap_p(ph), p);
+ }
+ }
+ break;
+ case mp_stroked_code:
+ {
+ mp_stroked_object *ph = (mp_stroked_object *)p;
+ if ( pen_is_elliptical(gr_pen_p(ph))) {
+ pen = mp_png_pen_info(mp, gr_path_p(ph), gr_pen_p(ph));
+ mp_png_stroke_out(mp, p, pen, false);
+ mp_xfree(pen);
+ } else {
+ mp_png_fill_out(mp, gr_path_p(ph), p);
+ }
+ }
+ break;
+ case mp_text_code:
+ if ( (gr_font_n(p)!=null_font) && (gr_text_l(p)>0) ) {
+ mp_png_text_out(mp, (mp_text_object *)p);
+ }
+ break;
+ case mp_start_clip_code:
+ cairo_save(mp->png->cr);
+ mp_png_path_out(mp, gr_path_p((mp_clip_object *)p));
+ cairo_clip(mp->png->cr);
+ cairo_new_path(mp->png->cr);
+ break;
+ case mp_stop_clip_code:
+ cairo_restore(mp->png->cr);
+ break;
+ case mp_start_bounds_code:
+ case mp_stop_bounds_code:
+ break;
+ case mp_special_code:
+ break;
+ } /* all cases are enumerated */
+ p=gr_link(p);
+ }
+ (void)mp_set_output_file_name (mp, c);
+ mp_store_true_output_filename (mp, c);
+ ss = xstrdup(mp->name_of_file);
+ cairo_surface_flush (mp->png->surface);
+ cairo_destroy (mp->png->cr);
+ bitmap.data = cairo_image_surface_get_data (mp->png->surface);
+ bitmap.width = cairo_image_surface_get_width (mp->png->surface);
+ bitmap.height = cairo_image_surface_get_height (mp->png->surface);
+ mp_png_save_to_file (mp, &bitmap, ss, colormodel);
+ cairo_surface_destroy (mp->png->surface);
+ free(ss);
+ return 1;
+}
+
+@ @(mplibpng.h@>=
+#ifndef MPLIBPNG_H
+#define MPLIBPNG_H 1
+int mp_png_ship_out (mp_edge_object *hh, const char *options) ;
+#endif
+
+@ @c
+int mp_png_ship_out (mp_edge_object *hh, const char *options) {
+ return mp_png_gr_ship_out (hh, options, (int)true);
+}
+
diff --git a/Build/source/texk/web2c/mplibdir/psout.w b/Build/source/texk/web2c/mplibdir/psout.w
new file mode 100644
index 00000000000..3c46d31879c
--- /dev/null
+++ b/Build/source/texk/web2c/mplibdir/psout.w
@@ -0,0 +1,6502 @@
+% This file is part of MetaPost;
+% the MetaPost program is in the public domain.
+% See the <Show version...> code in mpost.w for more info.
+
+% 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\vbv="026A % synonym for `\|'
+\def\vb{\relax\ifmmode\vbv\else$\vbv$\fi}
+\def\[#1]{} % from pascal web
+\def\(#1){} % this is used to make section names sort themselves better
+\def\9#1{} % this is used for sort keys in the index via @@:sort key}{entry@@>
+
+\let\?=\relax % we want to be able to \write a \?
+
+\def\title{MetaPost \ps\ output}
+\def\topofcontents{\hsize 5.5in
+ \vglue -30pt plus 1fil minus 1.5in
+ \def\?##1]{\hbox to 1in{\hfil##1.\ }}
+ }
+\def\botofcontents{\vskip 0pt plus 1fil minus 1.5in}
+\pdfoutput=1
+\pageno=3
+
+@
+@d zero_t ((math_data *)mp->math)->zero_t
+@d number_zero(A) (((math_data *)(mp->math))->equal)(A,zero_t)
+@d number_greater(A,B) (((math_data *)(mp->math))->greater)(A,B)
+@d number_positive(A) number_greater(A, zero_t)
+@d number_to_scaled(A) (((math_data *)(mp->math))->to_scaled)(A)
+@d round_unscaled(A) (((math_data *)(mp->math))->round_unscaled)(A)
+@d true 1
+@d false 0
+@d null_font 0
+@d null 0
+@d unity 1.0 /* $2^{16}$, represents 1.00000 */
+@d incr(A) (A)=(A)+1 /* increase a variable by unity */
+@d decr(A) (A)=(A)-1 /* decrease a variable by unity */
+@d negate(A) (A)=-(A) /* change the sign of a variable */
+@d odd(A) (abs(A)%2==1)
+@d max_quarterword 0x3FFF /* largest allowable value in a |quarterword| */
+
+@c
+#include <w2c/config.h>
+#include <stdio.h>
+#include <stdlib.h>
+#include <string.h>
+#include <stdarg.h>
+#include <assert.h>
+#include <math.h>
+#include "avl.h"
+#include "mplib.h"
+#include "mplibps.h" /* external header */
+#include "mpmp.h" /* internal header */
+#include "mppsout.h" /* internal header */
+#include "mpmath.h" /* internal header */
+#include "mpstrings.h" /* internal header */
+@h
+@<Declarations@>
+@<Static variables in the outer block@>
+
+@ There is a small bit of code from the backend that bleads through
+to the frontend because I do not know how to set up the includes
+properly. That is the |typedef struct psout_data_struct * psout_data|.
+
+@ @(mppsout.h@>=
+#ifndef MPPSOUT_H
+#define MPPSOUT_H 1
+#include "avl.h"
+#include "mplib.h"
+#include "mpmp.h"
+#include "mplibps.h"
+@<Types...@>
+typedef struct psout_data_struct {
+ @<Globals@>
+} psout_data_struct ;
+@<Exported function headers@>
+#endif
+
+@ @c
+static boolean mp_isdigit (int a) {
+ return (a>='0'&&a<='9');
+}
+static int mp_tolower (int a) {
+ if (a>='A' && a <='Z')
+ return a - 'A' + 'a';
+ return a;
+}
+static int mp_strcasecmp (const char *s1, const char *s2) {
+ int r;
+ char *ss1, *ss2, *c;
+ ss1 = mp_strdup(s1);
+ c = ss1;
+ while (*c != '\0') {
+ *c = (char)mp_tolower(*c); c++;
+ }
+ ss2 = mp_strdup(s2);
+ c = ss2;
+ while (*c != '\0') {
+ *c = (char)mp_tolower(*c); c++;
+ }
+ r = strcmp(ss1,ss2);
+ free (ss1); free(ss2);
+ return r;
+}
+
+@ @<Exported function headers@>=
+void mp_ps_backend_initialize (MP mp) ;
+void mp_ps_backend_free (MP mp) ;
+
+@
+@c void mp_ps_backend_initialize (MP mp) {
+ mp->ps = mp_xmalloc(mp,1,sizeof(psout_data_struct));
+ memset(mp->ps,0,sizeof(psout_data_struct));
+ @<Set initial values@>;
+}
+void mp_ps_backend_free (MP mp) {
+ @<Dealloc variables@>;
+ enc_free(mp);
+ t1_free(mp);
+ fm_free(mp);
+ mp_xfree(mp->ps);
+ mp->ps = NULL;
+}
+
+@ Writing to ps files
+
+@<Globals@>=
+integer ps_offset;
+ /* the number of characters on the current \ps\ file line */
+
+@ @<Set initial values@>=
+mp->ps->ps_offset = 0;
+
+@
+
+@d wps(A) (mp->write_ascii_file)(mp,mp->output_file,(A))
+@d wps_chr(A) do {
+ char ss[2];
+ ss[0]=(char)(A); ss[1]=0;
+ (mp->write_ascii_file)(mp,mp->output_file,(char *)ss);
+} while (0)
+@d wps_cr (mp->write_ascii_file)(mp,mp->output_file,"\n")
+@d wps_ln(A) { wterm_cr; (mp->write_ascii_file)(mp,mp->output_file,(A)); }
+
+@c
+static void mp_ps_print_ln (MP mp) { /* prints an end-of-line */
+ wps_cr;
+ mp->ps->ps_offset=0;
+}
+
+@ @c
+static void mp_ps_print_char (MP mp, int s) { /* prints a single character */
+ if ( s==13 ) {
+ wps_cr; mp->ps->ps_offset=0;
+ } else {
+ wps_chr(s); incr(mp->ps->ps_offset);
+ }
+}
+
+@ @c
+static void mp_ps_do_print (MP mp, const char *ss, size_t len) { /* prints string |s| */
+ size_t j = 0;
+ if (len>255) {
+ while ( j<len ){
+ mp_ps_print_char(mp, ss[j]); incr(j);
+ }
+ } else {
+ static char outbuf[256];
+ strncpy(outbuf, ss, len+1);
+ while ( j<len ){
+ if ( *(outbuf+j) == 13 ) {
+ *(outbuf+j) = '\n';
+ mp->ps->ps_offset=0;
+ } else {
+ mp->ps->ps_offset++;
+ }
+ j++;
+ }
+ (mp->write_ascii_file)(mp,mp->output_file,outbuf);
+ }
+}
+
+@ Deciding where to break the ps output line.
+
+@d ps_room(A) if (mp->ps->ps_offset>0 && (mp->ps->ps_offset+(int)(A))>mp->max_print_line ) {
+ mp_ps_print_ln(mp); /* optional line break */
+}
+
+@c
+static void mp_ps_print (MP mp, const char *ss) {
+ ps_room(strlen(ss));
+ mp_ps_do_print(mp, ss, strlen(ss));
+}
+static void mp_ps_dsc_print (MP mp, const char *dsc, const char *ss) {
+ ps_room(strlen(ss));
+ if (mp->ps->ps_offset==0) {
+ mp_ps_do_print(mp, "%%+ ", 4);
+ mp_ps_do_print(mp, dsc, strlen(dsc));
+ mp_ps_print_char(mp, ' ');
+ }
+ mp_ps_do_print(mp, ss, strlen(ss));
+}
+
+@ The procedure |print_nl| is like |print|, but it makes sure that the
+string appears at the beginning of a new line.
+
+@c
+static void mp_ps_print_nl (MP mp, const char *s) { /* prints string |s| at beginning of line */
+ if ( mp->ps->ps_offset>0 ) mp_ps_print_ln(mp);
+ mp_ps_print(mp, s);
+}
+
+@ The following procedure, which prints out the decimal representation of a
+given integer |n|, has been written carefully so that it works properly
+if |n=0| or if |(-n)| would cause overflow. It does not apply |mod| or |div|
+to negative arguments, since such operations are not implemented consistently
+by all \PASCAL\ compilers.
+
+@c
+static void mp_ps_print_int (MP mp,integer n) { /* prints an integer in decimal form */
+ integer m; /* used to negate |n| in possibly dangerous cases */
+ char outbuf [24]; /* dig[23], plus terminating |\0| */
+ unsigned char dig[23]; /* digits in a number, for rounding */
+ int k = 0; /* index to current digit; we assume that $|n|<10^{23}$ */
+ int l = 0;
+ if ( n<0 ) {
+ mp_ps_print_char(mp, '-');
+ if ( n>-100000000 ) {
+ negate(n);
+ } else {
+ m=-1-n; n=m / 10; m=(m % 10)+1; k=1;
+ if ( m<10 ) {
+ dig[0]=(unsigned char)m;
+ } else {
+ dig[0]=0; incr(n);
+ }
+ }
+ }
+ do {
+ dig[k]=(unsigned char)(n % 10); n=n / 10; incr(k);
+ } while (n!=0);
+ /* print the digits */
+ while ( k-->0 ){
+ outbuf[l++] = (char)('0'+dig[k]);
+ }
+ outbuf[l] = '\0';
+ (mp->write_ascii_file)(mp,mp->output_file,outbuf);
+}
+
+@ \MP\ also makes use of a trivial procedure to print two digits. The
+following subroutine is usually called with a parameter in the range |0<=n<=99|.
+
+@c
+static void mp_ps_print_dd (MP mp,integer n) { /* prints two least significant digits */
+ n= MPOST_ABS(n) % 100;
+ mp_ps_print_char(mp, '0'+(n / 10));
+ mp_ps_print_char(mp, '0'+(n % 10));
+}
+
+@ Conversely, here is a procedure analogous to |print_int|.
+
+There are two versions of this function: |ps_print_double_scaled| is used
+if metapost runs in scaled (backward compatibility) mode, because that
+version produces results that are much closer to the old version that exported
+figures with scaled fields instead of double fields. It is not always the
+same because a little bit of precision has gone in the scaled to double
+conversion, but still quite a bit closer than |%.6f| in the 'double' case.
+
+@d unityold 65536
+@c
+static void mp_ps_print_double_new (MP mp, double s) {
+ char *value, *c;
+ int i;
+ value = mp_xmalloc(mp,1,32);
+ memset(value,0,32);
+ mp_snprintf(value,32,"%.6f", s);
+ for (i=31;i>=0;i--) {
+ if (value[i]) {
+ if (value[i] == '0')
+ value[i] = '\0';
+ else
+ break;
+ }
+ }
+ if (value[i] == '.')
+ value[i] = '\0';
+ c = value;
+ while (*c) {
+ mp_ps_print_char(mp, *c);
+ c++;
+ }
+ free(value);
+}
+
+static void mp_ps_print_double_scaled (MP mp, double ss) {
+ int delta; /* amount of allowable inaccuracy */
+ int s = ss * unityold;
+ if ( s<0 ) {
+ mp_ps_print_char(mp, '-');
+ negate(s); /* print the sign, if negative */
+ }
+ mp_ps_print_int(mp, s / unityold); /* print the integer part */
+ s=10*(s % unityold)+5;
+ if ( s!=5 ) {
+ delta=10;
+ mp_ps_print_char(mp, '.');
+ do {
+ if ( delta>unityold )
+ s=s+0100000-(delta / 2); /* round the final digit */
+ mp_ps_print_char(mp, '0'+(s / unityold));
+ s=10*(s % unityold);
+ delta=delta*10;
+ } while (s>delta);
+ }
+}
+static void mp_ps_print_double (MP mp, double s) {
+ if (mp->math_mode == mp_math_scaled_mode) {
+ mp_ps_print_double_scaled (mp, s);
+ } else {
+ mp_ps_print_double_new (mp, s);
+ }
+}
+
+
+@* \[44a] Dealing with font encodings.
+
+First, here are a few helpers for parsing files
+
+@d check_buf(size, buf_size)
+ if ((unsigned)(size) > (unsigned)(buf_size)) {
+ char S[128];
+ mp_snprintf(S,128,"buffer overflow: (%u,%u) at file %s, line %d",
+ (unsigned)(size),(unsigned)(buf_size), __FILE__, __LINE__ );
+ mp_fatal_error(mp,S);
+ }
+
+@d append_char_to_buf(c, p, buf, buf_size) do {
+ if (c == 9)
+ c = 32;
+ if (c == 13 || c == EOF)
+ c = 10;
+ if (c != ' ' || (p > buf && p[-1] != 32)) {
+ check_buf(p - buf + 1, (buf_size));
+ *p++ = (char)c;
+ }
+} while (0)
+
+@d append_eol(p, buf, buf_size) do {
+ check_buf(p - buf + 2, (buf_size));
+ if (p - buf > 1 && p[-1] != 10)
+ *p++ = 10;
+ if (p - buf > 2 && p[-2] == 32) {
+ p[-2] = 10;
+ p--;
+ }
+ *p = 0;
+} while (0)
+
+@d remove_eol(p, buf) do {
+ p = strend(buf) - 1;
+ if (*p == 10)
+ *p = 0;
+} while (0)
+
+@d skip(p, c) if (*p == c) p++
+@d strend(s) strchr(s, 0)
+@d str_prefix(s1, s2) (strncmp((s1), (s2), strlen(s2)) == 0)
+
+
+@ @<Types...@>=
+typedef struct {
+ boolean loaded; /* the encoding has been loaded? */
+ char *file_name; /* encoding file name */
+ char *enc_name; /* encoding true name */
+ integer objnum; /* object number */
+ char **glyph_names;
+ integer tounicode; /* object number of associated ToUnicode entry */
+} enc_entry;
+
+
+@
+
+@d ENC_STANDARD 0
+@d ENC_BUILTIN 1
+
+@<Glob...@>=
+#define ENC_BUF_SIZE 0x1000
+char enc_line[ENC_BUF_SIZE];
+void * enc_file;
+
+@
+@d enc_eof() (mp->eof_file)(mp,mp->ps->enc_file)
+@d enc_close() (mp->close_file)(mp,mp->ps->enc_file)
+
+@c
+static int enc_getchar(MP mp) {
+ size_t len = 1;
+ unsigned char abyte=0;
+ void *byte_ptr = &abyte;
+ (mp->read_binary_file)(mp,mp->ps->enc_file,&byte_ptr,&len);
+ return abyte;
+}
+
+@ @c
+static boolean mp_enc_open (MP mp, char *n) {
+ mp->ps->enc_file=(mp->open_file)(mp,n, "r", mp_filetype_encoding);
+ if (mp->ps->enc_file!=NULL)
+ return true;
+ else
+ return false;
+}
+static void mp_enc_getline (MP mp) {
+ char *p;
+ int c;
+RESTART:
+ if (enc_eof ()) {
+ mp_error(mp, "unexpected end of file", NULL, true);
+ }
+ p = mp->ps->enc_line;
+ do {
+ c = enc_getchar (mp);
+ append_char_to_buf (c, p, mp->ps->enc_line, ENC_BUF_SIZE);
+ } while (c && c != 10);
+ append_eol (p, mp->ps->enc_line, ENC_BUF_SIZE);
+ if (p - mp->ps->enc_line < 2 || *mp->ps->enc_line == '%')
+ goto RESTART;
+}
+static void mp_load_enc (MP mp, char *enc_name,
+ char **enc_encname, char **glyph_names){
+ char buf[ENC_BUF_SIZE], *p, *r;
+ int names_count;
+ char *myname;
+ unsigned save_selector = mp->selector;
+ if (!mp_enc_open (mp,enc_name)) {
+ char err [256];
+ mp_snprintf(err,255, "cannot open encoding file %s for reading", enc_name);
+ mp_print (mp,err);
+ return;
+ }
+ mp_normalize_selector(mp);
+ mp_print (mp,"{");
+ mp_print (mp, enc_name);
+ mp_enc_getline (mp);
+ if (*mp->ps->enc_line != '/' || (r = strchr (mp->ps->enc_line, '[')) == NULL) {
+ char msg[256];
+ remove_eol (r, mp->ps->enc_line);
+ mp_snprintf (msg, 256, "invalid encoding vector (a name or `[' missing): `%s'", mp->ps->enc_line);
+ mp_error(mp, msg, NULL, true);
+ }
+ while (*(r-1)==' ') r--; /* strip trailing spaces from encoding name */
+ myname = mp_xmalloc(mp,(size_t)(r-mp->ps->enc_line),1);
+ memcpy(myname,(mp->ps->enc_line+1),(size_t)((r-mp->ps->enc_line)-1));
+ *(myname+(r-mp->ps->enc_line-1))=0;
+ *enc_encname = myname;
+ while (*r!='[') r++;
+ r++; /* skip '[' */
+ names_count = 0;
+ skip (r, ' ');
+ for (;;) {
+ while (*r == '/') {
+ for (p = buf, r++;
+ *r != ' ' && *r != 10 && *r != ']' && *r != '/'; *p++ = *r++);
+ *p = 0;
+ skip (r, ' ');
+ if (names_count > 256) {
+ mp_error(mp, "encoding vector contains more than 256 names", NULL, true);
+ }
+ if (mp_xstrcmp (buf, notdef) != 0)
+ glyph_names[names_count] = mp_xstrdup (mp,buf);
+ names_count++;
+ }
+ if (*r != 10 && *r != '%') {
+ if (str_prefix (r, "] def"))
+ goto DONE;
+ else {
+ char msg[256];
+ remove_eol (r, mp->ps->enc_line);
+ mp_snprintf(msg, 256,"invalid encoding vector: a name or `] def' expected: `%s'", mp->ps->enc_line);
+ mp_error(mp, msg, NULL, true);
+ }
+ }
+ mp_enc_getline (mp);
+ r = mp->ps->enc_line;
+ }
+DONE:
+ enc_close ();
+ mp_print (mp,"}");
+ mp->selector = save_selector;
+}
+static void mp_read_enc (MP mp, enc_entry * e) {
+ if (e->loaded)
+ return;
+ mp_xfree(e->enc_name);
+ e->enc_name = NULL;
+ mp_load_enc (mp,e->file_name, &e->enc_name, e->glyph_names);
+ e->loaded = true;
+}
+
+@ |write_enc| is used to write either external encoding (given in map file) or
+ internal encoding (read from the font file);
+ the 2nd argument is a pointer to the encoding entry;
+
+@c
+static void mp_write_enc (MP mp, enc_entry * e) {
+ int i;
+ size_t s, foffset;
+ char **g;
+ if (e->objnum != 0) /* the encoding has been written already */
+ return;
+ e->objnum = 1;
+ g = e->glyph_names;
+
+ mp_ps_print(mp,"\n%%%%BeginResource: encoding ");
+ mp_ps_print(mp, e->enc_name);
+ mp_ps_print_nl(mp, "/");
+ mp_ps_print(mp, e->enc_name);
+ mp_ps_print(mp, " [ ");
+ mp_ps_print_ln (mp);
+ foffset = strlen(e->file_name)+3;
+ for (i = 0; i < 256; i++) {
+ s = strlen(g[i]);
+ if (s+1+foffset>=80) {
+ mp_ps_print_ln (mp);
+ foffset = 0;
+ }
+ foffset += s+2;
+ mp_ps_print_char(mp,'/');
+ mp_ps_print(mp, g[i]);
+ mp_ps_print_char(mp,' ');
+ }
+ if (foffset>75)
+ mp_ps_print_ln (mp);
+ mp_ps_print_nl (mp,"] def\n");
+ mp_ps_print(mp,"%%%%EndResource");
+}
+
+
+@ All encoding entries go into AVL tree for fast search by name.
+
+@<Glob...@>=
+avl_tree enc_tree;
+
+@
+
+@<Static variables in the outer block@>=
+static char notdef[] = ".notdef";
+
+
+@ @<Set initial...@>=
+mp->ps->enc_tree = NULL;
+
+@ @c
+static int comp_enc_entry (void *p, const void *pa, const void *pb) {
+ (void)p;
+ return strcmp (((const enc_entry *) pa)->file_name,
+ ((const enc_entry *) pb)->file_name);
+}
+static void *destroy_enc_entry (void *pa) {
+ enc_entry *p;
+ int i;
+ p = (enc_entry *) pa;
+ mp_xfree (p->file_name);
+ if (p->glyph_names != NULL)
+ for (i = 0; i < 256; i++)
+ if (p->glyph_names[i] != notdef)
+ mp_xfree (p->glyph_names[i]);
+ mp_xfree (p->enc_name);
+ mp_xfree (p->glyph_names);
+ mp_xfree (p);
+ return NULL;
+}
+
+@ Not having an |mp| instance here means that lots of |malloc| and
+|strdup| checks are needed. Spotted by Peter Breitenlohner.
+
+@c
+static void *copy_enc_entry (const void *pa) {
+ const enc_entry *p;
+ enc_entry *q;
+ int i;
+ p = (const enc_entry *) pa;
+ q = malloc (sizeof (enc_entry));
+ if (q!=NULL) {
+ memset(q,0,sizeof(enc_entry));
+ if (p->enc_name!=NULL) {
+ q->enc_name = strdup (p->enc_name);
+ if (q->enc_name == NULL)
+ return NULL;
+ }
+ q->loaded = p->loaded;
+ if (p->file_name != NULL) {
+ q->file_name = strdup (p->file_name);
+ if (q->file_name == NULL)
+ return NULL;
+ }
+ q->objnum = p->objnum;
+ q->tounicode = p->tounicode;
+ q->glyph_names = malloc (256 * sizeof (char *));
+ if (p->glyph_names == NULL)
+ return NULL;
+ for (i = 0; i < 256; i++) {
+ if (p->glyph_names[i] != NULL) {
+ q->glyph_names[i] = strdup(p->glyph_names[i]);
+ if (q->glyph_names[i] == NULL)
+ return NULL;
+ }
+ }
+ }
+ return (void *)q;
+}
+
+static enc_entry * mp_add_enc (MP mp, char *s) {
+ int i;
+ enc_entry tmp, *p;
+
+ if (mp->ps->enc_tree == NULL) {
+ mp->ps->enc_tree = avl_create (comp_enc_entry,
+ copy_enc_entry,
+ destroy_enc_entry,
+ malloc, free, NULL);
+ }
+ tmp.file_name = s;
+ p = (enc_entry *) avl_find (&tmp, mp->ps->enc_tree);
+ if (p != NULL) /* encoding already registered */
+ return p;
+ p = mp_xmalloc (mp,1,sizeof (enc_entry));
+ memset(p,0,sizeof(enc_entry));
+ p->loaded = false;
+ p->file_name = mp_xstrdup (mp,s);
+ p->objnum = 0;
+ p->tounicode = 0;
+ p->glyph_names = mp_xmalloc (mp,256,sizeof (char *));
+ for (i = 0; i < 256; i++) {
+ p->glyph_names[i] = mp_xstrdup(mp, notdef);
+ }
+ assert (avl_ins (p, mp->ps->enc_tree, avl_false)>0);
+ destroy_enc_entry(p);
+ return avl_find (&tmp, mp->ps->enc_tree);
+}
+
+@ cleaning up...
+
+
+@ @<Declarations@>=
+static void enc_free (MP mp);
+
+@ @c static void enc_free (MP mp) {
+ if (mp->ps->enc_tree != NULL)
+ avl_destroy (mp->ps->enc_tree);
+}
+
+@ @<Declarations@>=
+static void mp_reload_encodings (MP mp) ;
+static void mp_font_encodings (MP mp, font_number lastfnum, boolean encodings_only) ;
+
+@ @c void mp_reload_encodings (MP mp) {
+ font_number f;
+ enc_entry *e;
+ fm_entry *fm_cur;
+ font_number lastfnum = mp->last_fnum;
+ for (f=null_font+1;f<=lastfnum;f++) {
+ if (mp->font_enc_name[f]!=NULL ) {
+ mp_xfree(mp->font_enc_name[f]);
+ mp->font_enc_name[f]=NULL;
+ }
+ if (mp_has_fm_entry (mp,f,&fm_cur)) {
+ if (fm_cur != NULL && fm_cur->ps_name != NULL &&is_reencoded (fm_cur)) {
+ e = fm_cur->encoding;
+ mp_read_enc (mp,e);
+ }
+ }
+ }
+}
+static void mp_font_encodings (MP mp, font_number lastfnum, boolean encodings_only) {
+ font_number f;
+ enc_entry *e;
+ fm_entry *fm;
+ for (f=null_font+1;f<=lastfnum;f++) {
+ if (mp_has_font_size(mp,f) && mp_has_fm_entry (mp,f, &fm)) {
+ if (fm != NULL && (fm->ps_name != NULL)) {
+ if (is_reencoded (fm)) {
+ if (encodings_only || (!is_subsetted (fm))) {
+ e = fm->encoding;
+ mp_write_enc (mp, e);
+ /* clear for next run */
+ e->objnum = 0;
+ }
+ }
+ }
+ }
+ }
+}
+
+@* \[44b] Parsing font map files.
+
+@d FM_BUF_SIZE 1024
+
+@<Glob...@>=
+void * fm_file;
+size_t fm_byte_waiting;
+size_t fm_byte_length;
+unsigned char *fm_bytes;
+
+@ This is comparable to t1 font loading (see below) but because the first
+thing done is not calling |fm_getchar()| but |fm_eof()|, the initial value
+of length has to be one more than waiting.
+
+@<Set initial ...@>=
+mp->ps->fm_byte_waiting=0;
+mp->ps->fm_byte_length=1;
+mp->ps->fm_bytes=NULL;
+
+@
+@d fm_eof() (mp->ps->fm_byte_waiting>=mp->ps->fm_byte_length)
+@d fm_close() do {
+ (mp->close_file)(mp,mp->ps->fm_file);
+ mp_xfree(mp->ps->fm_bytes);
+ mp->ps->fm_bytes = NULL;
+ mp->ps->fm_byte_waiting=0;
+ mp->ps->fm_byte_length=1;
+} while (0)
+@d valid_code(c) (c >= 0 && c < 256)
+@d unwrap_file(ff) ( mp->noninteractive ? ((File *) ff)->f : ff)
+
+
+@c
+static int fm_getchar (MP mp) {
+ if (mp->ps->fm_bytes == NULL) {
+ void *byte_ptr ;
+ (void)fseek( unwrap_file(mp->ps->fm_file), 0,SEEK_END);
+ mp->ps->fm_byte_length = (size_t)ftell( unwrap_file(mp->ps->fm_file) );
+ (void)fseek( unwrap_file(mp->ps->fm_file), 0,SEEK_SET);
+ if (mp->ps->fm_byte_length==0)
+ return EOF;
+ mp->ps->fm_bytes = mp_xmalloc(mp, mp->ps->fm_byte_length, 1);
+ byte_ptr = (void *)mp->ps->fm_bytes;
+ (mp->read_binary_file)(mp, mp->ps->fm_file, &byte_ptr,&mp->ps->fm_byte_length);
+ }
+ if(mp->ps->fm_byte_waiting >= mp->ps->fm_byte_length)
+ return 10;
+ return *(mp->ps->fm_bytes+mp->ps->fm_byte_waiting++);
+}
+
+@ @<Types...@>=
+enum _mode { FM_DUPIGNORE, FM_REPLACE, FM_DELETE };
+enum _ltype { MAPFILE, MAPLINE };
+enum _tfmavail { TFM_UNCHECKED, TFM_FOUND, TFM_NOTFOUND };
+typedef struct mitem {
+ int mode; /* |FM_DUPIGNORE| or |FM_REPLACE| or |FM_DELETE| */
+ int type; /* map file or map line */
+ char *map_line; /* pointer to map file name or map line */
+ int lineno; /* line number in map file */
+} mapitem;
+
+@ @<Glob...@>=
+mapitem *mitem;
+fm_entry *fm_cur;
+fm_entry *loaded_tfm_found;
+fm_entry *avail_tfm_found;
+fm_entry *non_tfm_found;
+fm_entry *not_avail_tfm_found;
+
+@ @<Set initial...@>=
+mp->ps->mitem = NULL;
+
+@ @<Declarations@>=
+static const char nontfm[] = "<nontfm>";
+
+@
+@d read_field(r, q, buf) do {
+ q = buf;
+ while (*r != ' ' && *r != '\0')
+ *q++ = *r++;
+ *q = '\0';
+ skip (r, ' ');
+} while (0)
+
+@d set_field(F) do {
+ if (q > buf)
+ fm->F = mp_xstrdup(mp,buf);
+ if (*r == '\0')
+ goto DONE;
+} while (0)
+
+@d cmp_return(a, b)
+ if (a > b)
+ return 1;
+ if (a < b)
+ return -1
+
+@d do_strdup(a) (a==NULL ? NULL : strdup(a))
+
+@c
+static fm_entry *new_fm_entry (MP mp) {
+ fm_entry *fm;
+ fm = mp_xmalloc (mp,1,sizeof(fm_entry));
+ fm->tfm_name = NULL;
+ fm->ps_name = NULL;
+ fm->flags = 4;
+ fm->ff_name = NULL;
+ fm->subset_tag = NULL;
+ fm->encoding = NULL;
+ fm->tfm_num = null_font;
+ fm->tfm_avail = TFM_UNCHECKED;
+ fm->type = 0;
+ fm->slant = 0;
+ fm->extend = 0;
+ fm->ff_objnum = 0;
+ fm->fn_objnum = 0;
+ fm->fd_objnum = 0;
+ fm->charset = NULL;
+ fm->all_glyphs = false;
+ fm->links = 0;
+ fm->pid = -1;
+ fm->eid = -1;
+ return fm;
+}
+
+static void *copy_fm_entry (const void *p) {
+ fm_entry *fm;
+ const fm_entry *fp;
+ fp = (const fm_entry *)p;
+ fm = malloc (sizeof(fm_entry));
+ if (fm==NULL)
+ return NULL;
+ memcpy(fm, fp, sizeof(fm_entry));
+ fm->tfm_name = do_strdup(fp->tfm_name);
+ fm->ps_name = do_strdup(fp->ps_name);
+ fm->ff_name = do_strdup(fp->ff_name);
+ fm->subset_tag = do_strdup(fp->subset_tag);
+ fm->charset = do_strdup(fp->charset);
+ return (void *)fm;
+}
+
+
+static void * delete_fm_entry (void *p) {
+ fm_entry *fm = (fm_entry *)p;
+ mp_xfree (fm->tfm_name);
+ mp_xfree (fm->ps_name);
+ mp_xfree (fm->ff_name);
+ mp_xfree (fm->subset_tag);
+ mp_xfree (fm->charset);
+ mp_xfree (fm);
+ return NULL;
+}
+
+static ff_entry *new_ff_entry (MP mp) {
+ ff_entry *ff;
+ ff = mp_xmalloc (mp,1,sizeof(ff_entry));
+ ff->ff_name = NULL;
+ ff->ff_path = NULL;
+ return ff;
+}
+
+static void *copy_ff_entry (const void *p) {
+ ff_entry *ff;
+ const ff_entry *fp;
+ fp = (const ff_entry *)p;
+ ff = (ff_entry *)malloc (sizeof(ff_entry));
+ if (ff == NULL)
+ return NULL;
+ ff->ff_name = do_strdup(fp->ff_name);
+ ff->ff_path = do_strdup(fp->ff_path);
+ return ff;
+}
+
+static void * delete_ff_entry (void *p) {
+ ff_entry *ff = (ff_entry *)p;
+ mp_xfree (ff->ff_name);
+ mp_xfree (ff->ff_path);
+ mp_xfree (ff);
+ return NULL;
+}
+
+static char *mk_base_tfm (MP mp, char *tfmname, int *i) {
+ static char buf[SMALL_BUF_SIZE];
+ char *p = tfmname, *r = strend (p) - 1, *q = r;
+ while (q > p && mp_isdigit (*q))
+ --q;
+ if (!(q > p) || q == r || (*q != '+' && *q != '-'))
+ return NULL;
+ check_buf (q - p + 1, SMALL_BUF_SIZE);
+ strncpy (buf, p, (size_t) (q - p));
+ buf[q - p] = '\0';
+ *i = atoi (q);
+ return buf;
+}
+
+@ @<Declarations@>=
+static boolean mp_has_fm_entry (MP mp,font_number f, fm_entry **fm);
+
+@ @c
+boolean mp_has_fm_entry (MP mp,font_number f, fm_entry **fm) {
+ fm_entry *res = NULL;
+ res = mp_fm_lookup (mp, f);
+ if (fm != NULL) {
+ *fm =res;
+ }
+ return (res != NULL);
+}
+
+@ @<Glob...@>=
+avl_tree tfm_tree;
+avl_tree ps_tree;
+avl_tree ff_tree;
+
+@ @<Set initial...@>=
+mp->ps->tfm_tree = NULL;
+mp->ps->ps_tree = NULL;
+mp->ps->ff_tree = NULL;
+
+@ AVL sort |fm_entry| into |tfm_tree| by |tfm_name |
+
+@c
+static int comp_fm_entry_tfm (void *p, const void *pa, const void *pb) {
+ (void)p;
+ return strcmp (((const fm_entry *) pa)->tfm_name,
+ ((const fm_entry *) pb)->tfm_name);
+}
+
+@ AVL sort |fm_entry| into |ps_tree| by |ps_name|, |slant|, and |extend|
+
+@c static int comp_fm_entry_ps (void *p, const void *pa, const void *pb) {
+ int i;
+ const fm_entry *p1 = (const fm_entry *) pa;
+ const fm_entry *p2 = (const fm_entry *) pb;
+ (void)p;
+ assert (p1->ps_name != NULL && p2->ps_name != NULL);
+ if ((i = strcmp (p1->ps_name, p2->ps_name)))
+ return i;
+ cmp_return (p1->slant, p2->slant);
+ cmp_return (p1->extend, p2->extend);
+ if (p1->tfm_name != NULL && p2->tfm_name != NULL &&
+ (i = strcmp (p1->tfm_name, p2->tfm_name)))
+ return i;
+ return 0;
+}
+
+@ AVL sort |ff_entry| into |ff_tree| by |ff_name|
+
+@c static int comp_ff_entry (void *p, const void *pa, const void *pb) {
+ (void)p;
+ return strcmp (((const ff_entry *) pa)->ff_name,
+ ((const ff_entry *) pb)->ff_name);
+}
+
+@ @c static void create_avl_trees (MP mp) {
+ if (mp->ps->tfm_tree == NULL) {
+ mp->ps->tfm_tree = avl_create (comp_fm_entry_tfm,
+ copy_fm_entry,
+ delete_fm_entry,
+ malloc, free, NULL);
+ assert (mp->ps->tfm_tree != NULL);
+ }
+ if (mp->ps->ps_tree == NULL) {
+ mp->ps->ps_tree = avl_create (comp_fm_entry_ps,
+ copy_fm_entry,
+ delete_fm_entry,
+ malloc, free, NULL);
+ assert (mp->ps->ps_tree != NULL);
+ }
+ if (mp->ps->ff_tree == NULL) {
+ mp->ps->ff_tree = avl_create (comp_ff_entry,
+ copy_ff_entry,
+ delete_ff_entry,
+ malloc, free, NULL);
+ assert (mp->ps->ff_tree != NULL);
+ }
+}
+
+@ The function |avl_do_entry| is not completely symmetrical with regards
+to |tfm_name| and |ps_name handling|, e. g. a duplicate |tfm_name| gives a
+|goto exit|, and no |ps_name| link is tried. This is to keep it compatible
+with the original version.
+
+@d LINK_TFM 0x01
+@d LINK_PS 0x02
+@d set_tfmlink(fm) ((fm)->links |= LINK_TFM)
+@d set_pslink(fm) ((fm)->links |= LINK_PS)
+@d has_tfmlink(fm) ((fm)->links & LINK_TFM)
+@d has_pslink(fm) ((fm)->links & LINK_PS)
+
+@c
+static int avl_do_entry (MP mp, fm_entry * fp, int mode) {
+ fm_entry *p;
+ char s[128];
+ /* handle |tfm_name| link */
+
+ if (strcmp (fp->tfm_name, nontfm)) {
+ p = (fm_entry *) avl_find (fp, mp->ps->tfm_tree);
+ if (p != NULL) {
+ if (mode == FM_DUPIGNORE) {
+ mp_snprintf(s,128,"fontmap entry for `%s' already exists, duplicates ignored",
+ fp->tfm_name);
+ mp_warn(mp,s);
+ goto exit;
+ } else { /* mode == |FM_REPLACE| / |FM_DELETE| */
+ if (mp_has_font_size(mp,p->tfm_num)) {
+ mp_snprintf(s,128,
+ "fontmap entry for `%s' has been used, replace/delete not allowed",
+ fp->tfm_name);
+ mp_warn(mp,s);
+ goto exit;
+ }
+ (void) avl_del (p,mp->ps->tfm_tree,NULL);
+ p = NULL;
+ }
+ }
+ if (mode != FM_DELETE) {
+ if (p==NULL) {
+ assert (avl_ins(fp, mp->ps->tfm_tree, avl_false)>0);
+ }
+ set_tfmlink (fp);
+ }
+ }
+
+ /* handle |ps_name| link */
+
+ if (fp->ps_name != NULL) {
+ assert (fp->tfm_name != NULL);
+ p = (fm_entry *) avl_find (fp, mp->ps->ps_tree);
+ if (p != NULL) {
+ if (mode == FM_DUPIGNORE) {
+ mp_snprintf(s,128,
+ "ps_name entry for `%s' already exists, duplicates ignored",
+ fp->ps_name);
+ mp_warn(mp,s);
+ goto exit;
+ } else { /* mode == |FM_REPLACE| / |FM_DELETE| */
+ if (mp_has_font_size(mp,p->tfm_num)) {
+ /* REPLACE/DELETE not allowed */
+ mp_snprintf(s,128,
+ "fontmap entry for `%s' has been used, replace/delete not allowed",
+ p->tfm_name);
+ mp_warn(mp,s);
+ goto exit;
+ }
+ (void)avl_del (p,mp->ps->ps_tree,NULL);
+ p= NULL;
+ }
+ }
+ if (mode != FM_DELETE) {
+ if (p==NULL) {
+ assert (avl_ins(fp, mp->ps->ps_tree, avl_false)>0);
+ }
+ set_pslink (fp);
+ }
+ }
+ exit:
+ if (!has_tfmlink (fp) && !has_pslink (fp)) /* e. g. after |FM_DELETE| */
+ return 1; /* deallocation of |fm_entry| structure required */
+ else
+ return 0;
+}
+
+@ consistency check for map entry, with warn flag
+
+@c
+static int check_fm_entry (MP mp, fm_entry * fm, boolean warn) {
+ int a = 0;
+ char s[128];
+ assert (fm != NULL);
+ if (fm->ps_name != NULL) {
+ if (is_basefont (fm)) {
+ if (is_fontfile (fm) && !is_included (fm)) {
+ if (warn) {
+ mp_snprintf(s,128, "invalid entry for `%s': "
+ "font file must be included or omitted for base fonts",
+ fm->tfm_name);
+ mp_warn(mp,s);
+ }
+ a += 1;
+ }
+ } else { /* not a base font */
+ /* if no font file given, drop this entry */
+ /* |if (!is_fontfile (fm)) {
+ if (warn) {
+ mp_snprintf(s,128,
+ "invalid entry for `%s': font file missing",
+ fm->tfm_name);
+ mp_warn(mp,s);
+ }
+ a += 2;
+ }|
+ */
+ }
+ }
+ if (is_truetype (fm) && is_reencoded (fm) && !is_subsetted (fm)) {
+ if (warn) {
+ mp_snprintf(s,128,
+ "invalid entry for `%s': only subsetted TrueType font can be reencoded",
+ fm->tfm_name);
+ mp_warn(mp,s);
+ }
+ a += 4;
+ }
+ if ((fm->slant != 0 || fm->extend != 0) &&
+ (is_truetype (fm))) {
+ if (warn) {
+ mp_snprintf(s,128,
+ "invalid entry for `%s': "
+ "SlantFont/ExtendFont can be used only with embedded T1 fonts",
+ fm->tfm_name);
+ mp_warn(mp,s);
+ }
+ a += 8;
+ }
+ if (abs (fm->slant) > 1000) {
+ if (warn) {
+ mp_snprintf(s,128,
+ "invalid entry for `%s': too big value of SlantFont (%d/1000.0)",
+ fm->tfm_name, (int)fm->slant);
+ mp_warn(mp,s);
+ }
+ a += 16;
+ }
+ if (abs (fm->extend) > 2000) {
+ if (warn) {
+ mp_snprintf(s,128,
+ "invalid entry for `%s': too big value of ExtendFont (%d/1000.0)",
+ fm->tfm_name, (int)fm->extend);
+ mp_warn(mp,s);
+ }
+ a += 32;
+ }
+ if (fm->pid != -1 &&
+ !(is_truetype (fm) && is_included (fm) &&
+ is_subsetted (fm) && !is_reencoded (fm))) {
+ if (warn) {
+ mp_snprintf(s,128,
+ "invalid entry for `%s': "
+ "PidEid can be used only with subsetted non-reencoded TrueType fonts",
+ fm->tfm_name);
+ mp_warn(mp,s);
+ }
+ a += 64;
+ }
+ return a;
+}
+
+@ returns true if s is one of the 14 std. font names; speed-trimmed.
+
+@c static boolean check_basefont (char *s) {
+ static const char *basefont_names[] = {
+ "Courier", /* 0:7 */
+ "Courier-Bold", /* 1:12 */
+ "Courier-Oblique", /* 2:15 */
+ "Courier-BoldOblique", /* 3:19 */
+ "Helvetica", /* 4:9 */
+ "Helvetica-Bold", /* 5:14 */
+ "Helvetica-Oblique", /* 6:17 */
+ "Helvetica-BoldOblique", /* 7:21 */
+ "Symbol", /* 8:6 */
+ "Times-Roman", /* 9:11 */
+ "Times-Bold", /* 10:10 */
+ "Times-Italic", /* 11:12 */
+ "Times-BoldItalic", /* 12:16 */
+ "ZapfDingbats" /* 13:12 */
+ };
+ static const int Index[] =
+ { -1, -1, -1, -1, -1, -1, 8, 0, -1, 4, 10, 9, -1, -1, 5, 2, 12, 6,
+ -1, 3, -1, 7
+ };
+ const size_t n = strlen (s);
+ int k = -1;
+ if (n > 21)
+ return false;
+ if (n == 12) { /* three names have length 12 */
+ switch (*s) {
+ case 'C':
+ k = 1; /* Courier-Bold */
+ break;
+ case 'T':
+ k = 11; /* Times-Italic */
+ break;
+ case 'Z':
+ k = 13; /* ZapfDingbats */
+ break;
+ default:
+ return false;
+ }
+ } else
+ k = Index[n];
+ if (k > -1 && !strcmp (basefont_names[k], s))
+ return true;
+ return false;
+}
+
+@
+@d is_cfg_comment(c) (c == 10 || c == '*' || c == '#' || c == ';' || c == '%')
+
+@c static void fm_scan_line (MP mp) {
+ int a, b, c, j, u = 0, v = 0;
+ float d;
+ fm_entry *fm;
+ char fm_line[FM_BUF_SIZE], buf[FM_BUF_SIZE];
+ char *p, *q, *s;
+ char warn_s[128];
+ char *r = NULL;
+ switch (mp->ps->mitem->type) {
+ case MAPFILE:
+ p = fm_line;
+ do {
+ c = fm_getchar (mp);
+ append_char_to_buf (c, p, fm_line, FM_BUF_SIZE);
+ } while (c != 10);
+ *(--p) = '\0';
+ r = fm_line;
+ break;
+ case MAPLINE:
+ r = mp->ps->mitem->map_line;
+ break;
+ default:
+ assert (0);
+ }
+ if (*r == '\0' || is_cfg_comment (*r))
+ return;
+ fm = new_fm_entry (mp);
+ read_field (r, q, buf);
+ set_field (tfm_name);
+ p = r;
+ read_field (r, q, buf);
+ if (*buf != '<' && *buf != '"')
+ set_field (ps_name);
+ else
+ r = p; /* unget the field */
+ if (mp_isdigit (*r)) { /* font flags given */
+ fm->flags = atoi (r);
+ while (mp_isdigit (*r))
+ r++;
+ }
+ if(fm->ps_name == NULL)
+ fm->ps_name = xstrdup(fm->tfm_name);
+ while (1) { /* loop through "specials", encoding, font file */
+ skip (r, ' ');
+ switch (*r) {
+ case '\0':
+ goto DONE;
+ case '"': /* opening quote */
+ r++;
+ u = v = 0;
+ do {
+ skip (r, ' ');
+ if (sscanf (r, "%f %n", &d, &j) > 0) {
+ s = r + j; /* jump behind number, eat also blanks, if any */
+ if (*(s - 1) == 'E' || *(s - 1) == 'e')
+ s--; /* e. g. 0.5ExtendFont: \%f = 0.5E */
+ if (str_prefix (s, "SlantFont")) {
+ d *= (float)1000.0; /* correct rounding also for neg. numbers */
+ fm->slant = (short int) (d > 0 ? d + 0.5 : d - 0.5);
+ r = s + strlen ("SlantFont");
+ } else if (str_prefix (s, "ExtendFont")) {
+ d *= (float)1000.0;
+ fm->extend = (short int) (d > 0 ? d + 0.5 : d - 0.5);
+ if (fm->extend == 1000)
+ fm->extend = 0;
+ r = s + strlen ("ExtendFont");
+ } else { /* unknown name */
+ for (r = s;
+ *r != ' ' && *r != '"' && *r != '\0';
+ r++); /* jump over name */
+ c = *r; /* remember char for temporary end of string */
+ *r = '\0';
+ mp_snprintf(warn_s,128,
+ "invalid entry for `%s': unknown name `%s' ignored",
+ fm->tfm_name, s);
+ mp_warn(mp,warn_s);
+ *r = (char)c;
+ }
+ } else
+ for (; *r != ' ' && *r != '"' && *r != '\0'; r++);
+ }
+ while (*r == ' ');
+ if (*r == '"') /* closing quote */
+ r++;
+ else {
+ mp_snprintf(warn_s,128,
+ "invalid entry for `%s': closing quote missing",
+ fm->tfm_name);
+ mp_warn(mp,warn_s);
+ goto bad_line;
+ }
+ break;
+ case 'P': /* handle cases for subfonts like 'PidEid=3,1' */
+ if (sscanf (r, "PidEid=%i, %i %n", &a, &b, &c) >= 2) {
+ fm->pid = (short int)a;
+ fm->eid = (short int)b;
+ r += c;
+ break;
+ } /* fallthrough */
+ default: /* encoding or font file specification */
+ a = b = 0;
+ if (*r == '<') {
+ a = *r++;
+ if (*r == '<' || *r == '[')
+ b = *r++;
+ }
+ read_field (r, q, buf);
+ /* encoding, formats: '8r.enc' or '<8r.enc' or '<[8r.enc' */
+ if (strlen (buf) > 4 && mp_strcasecmp (strend (buf) - 4, ".enc") == 0) {
+ fm->encoding = mp_add_enc (mp, buf);
+ u = v = 0; /* u, v used if intervening blank: "<< foo" */
+ } else if (strlen (buf) > 0) { /* file name given */
+ /* font file, formats:
+ * subsetting: '<cmr10.pfa'
+ * no subsetting: '<<cmr10.pfa'
+ * no embedding: 'cmr10.pfa'
+ */
+ if (a == '<' || u == '<') {
+ set_included (fm);
+ if ((a == '<' && b == 0) || (a == 0 && v == 0))
+ set_subsetted (fm);
+ /* otherwise b == '<' (or '[') => no subsetting */
+ }
+ set_field (ff_name);
+ u = v = 0;
+ } else {
+ u = a;
+ v = b;
+ }
+ }
+ }
+ DONE:
+ if (fm->ps_name != NULL && check_basefont (fm->ps_name))
+ set_basefont (fm);
+ if (is_fontfile (fm)
+ && mp_strcasecmp (strend (fm_fontfile (fm)) - 4, ".ttf") == 0)
+ set_truetype (fm);
+ if (check_fm_entry (mp,fm, true) != 0)
+ goto bad_line;
+ /*
+ Until here the map line has been completely scanned without errors;
+ fm points to a valid, freshly filled-out |fm_entry| structure.
+ Now follows the actual work of registering/deleting.
+ */
+ if (avl_do_entry (mp, fm, mp->ps->mitem->mode) == 0) { /* if success */
+ delete_fm_entry (fm);
+ return;
+ }
+ bad_line:
+ delete_fm_entry (fm);
+}
+
+@
+@c static void fm_read_info (MP mp) {
+ char *n;
+ char s[256];
+ if (mp->ps->tfm_tree == NULL)
+ create_avl_trees (mp);
+ if (mp->ps->mitem->map_line == NULL) /* nothing to do */
+ return;
+ mp->ps->mitem->lineno = 1;
+ switch (mp->ps->mitem->type) {
+ case MAPFILE:
+ n = mp->ps->mitem->map_line;
+ mp->ps->fm_file = (mp->open_file)(mp, n, "r", mp_filetype_fontmap);
+ if (!mp->ps->fm_file) {
+ mp_snprintf(s,256,"cannot open font map file %s",n);
+ mp_warn(mp,s);
+ } else {
+ unsigned save_selector = mp->selector;
+ mp_normalize_selector(mp);
+ mp_print (mp, "{");
+ mp_print (mp, n);
+ while (!fm_eof ()) {
+ fm_scan_line (mp);
+ mp->ps->mitem->lineno++;
+ }
+ fm_close ();
+ mp_print (mp,"}");
+ mp->selector = save_selector;
+ mp->ps->fm_file = NULL;
+ }
+ /* |mp_xfree(n);| */
+ break;
+ case MAPLINE:
+ fm_scan_line (mp);
+ break;
+ default:
+ assert (0);
+ }
+ mp->ps->mitem->map_line = NULL; /* done with this line */
+ return;
+}
+
+@ @c static void init_fm (fm_entry * fm, font_number f) {
+ if (fm->tfm_num == null_font ) {
+ fm->tfm_num = f;
+ fm->tfm_avail = TFM_FOUND;
+ }
+}
+
+@ @<Exported function ...@>=
+fm_entry * mp_fm_lookup (MP mp, font_number f);
+
+@ @c
+fm_entry * mp_fm_lookup (MP mp, font_number f) {
+ char *tfm;
+ fm_entry *fm;
+ fm_entry tmp;
+ int e;
+ if (mp->ps->tfm_tree == NULL)
+ mp_read_psname_table (mp); /* only to read default map file */
+ tfm = mp->font_name[f];
+ assert (strcmp (tfm, nontfm));
+ /* Look up for full <tfmname>[+-]<expand> */
+ tmp.tfm_name = tfm;
+ fm = (fm_entry *) avl_find (&tmp, mp->ps->tfm_tree);
+ if (fm != NULL) {
+ init_fm (fm, f);
+ return (fm_entry *) fm;
+ }
+ tfm = mk_base_tfm (mp, mp->font_name[f], &e);
+ if (tfm == NULL) /* not an expanded font, nothing to do */
+ return NULL;
+
+ tmp.tfm_name = tfm;
+ fm = (fm_entry *) avl_find (&tmp, mp->ps->tfm_tree);
+ if (fm != NULL) { /* found an entry with the base tfm name, e.g. cmr10 */
+ return (fm_entry *) fm; /* font expansion uses the base font */
+ }
+ return NULL;
+}
+
+@ Early check whether a font file exists. Used e. g. for replacing fonts
+ of embedded PDF files: Without font file, the font within the embedded
+ PDF-file is used. Search tree |ff_tree| is used in 1st instance, as it
+ may be faster than the |kpse_find_file()|, and |kpse_find_file()| is called
+ only once per font file name + expansion parameter. This might help
+ keeping speed, if many PDF pages with same fonts are to be embedded.
+
+ The |ff_tree| contains only font files, which are actually needed,
+ so this tree typically is much smaller than the |tfm_tree| or |ps_tree|.
+
+@c
+static ff_entry *check_ff_exist (MP mp, fm_entry * fm) {
+ ff_entry *ff;
+ ff_entry tmp;
+
+ assert (fm->ff_name != NULL);
+ tmp.ff_name = fm->ff_name;
+ ff = (ff_entry *) avl_find (&tmp, mp->ps->ff_tree);
+ if (ff == NULL) { /* not yet in database */
+ ff = new_ff_entry (mp);
+ ff->ff_name = mp_xstrdup (mp,fm->ff_name);
+ ff->ff_path = mp_xstrdup (mp,fm->ff_name);
+ assert(avl_ins (ff, mp->ps->ff_tree, avl_false)>0);
+ delete_ff_entry(ff);
+ ff = (ff_entry *) avl_find (&tmp, mp->ps->ff_tree);
+ }
+ return ff;
+}
+
+@ Process map file given by its name or map line contents. Items not
+beginning with [+-=] flush default map file, if it has not yet been
+read. Leading blanks and blanks immediately following [+-=] are ignored.
+
+
+@c static void mp_process_map_item (MP mp, char *s, int type) {
+ char *p;
+ int mode;
+ if (*s == ' ')
+ s++; /* ignore leading blank */
+ switch (*s) {
+ case '+': /* +mapfile.map, +mapline */
+ mode = FM_DUPIGNORE; /* insert entry, if it is not duplicate */
+ s++;
+ break;
+ case '=': /* =mapfile.map, =mapline */
+ mode = FM_REPLACE; /* try to replace earlier entry */
+ s++;
+ break;
+ case '-': /* -mapfile.map, -mapline */
+ mode = FM_DELETE; /* try to delete entry */
+ s++;
+ break;
+ default:
+ mode = FM_DUPIGNORE; /* like +, but also: */
+ mp_xfree(mp->ps->mitem->map_line);
+ mp->ps->mitem->map_line = NULL; /* flush default map file name */
+ }
+ if (*s == ' ')
+ s++; /* ignore blank after [+-=] */
+ p = s; /* map item starts here */
+ switch (type) {
+ case MAPFILE: /* remove blank at end */
+ while (*p != '\0' && *p != ' ')
+ p++;
+ *p = '\0';
+ break;
+ case MAPLINE: /* blank at end allowed */
+ break;
+ default:
+ assert (0);
+ }
+ if (mp->ps->mitem->map_line != NULL) /* read default map file first */
+ fm_read_info (mp);
+ if (*s != '\0') { /* only if real item to process */
+ mp->ps->mitem->mode = mode;
+ mp->ps->mitem->type = type;
+ mp->ps->mitem->map_line = s;
+ fm_read_info (mp);
+ }
+}
+
+@ @<Exported function headers@>=
+void mp_map_file (MP mp, mp_string t);
+void mp_map_line (MP mp, mp_string t);
+void mp_init_map_file (MP mp, int is_troff);
+
+@ @c
+void mp_map_file (MP mp, mp_string t) {
+ char *ss = mp_str (mp,t);
+ char *s = mp_xstrdup(mp, ss);
+ mp_process_map_item (mp, s, MAPFILE);
+}
+void mp_map_line (MP mp, mp_string t) {
+ char *ss = mp_str (mp,t);
+ char *s = mp_xstrdup(mp,ss);
+ mp_process_map_item (mp, s, MAPLINE);
+ mp_xfree(s);
+}
+
+@
+@c void mp_init_map_file (MP mp, int is_troff) {
+ char *r;
+ mp->ps->mitem = mp_xmalloc (mp,1,sizeof(mapitem));
+ mp->ps->mitem->mode = FM_DUPIGNORE;
+ mp->ps->mitem->type = MAPFILE;
+ mp->ps->mitem->map_line = NULL;
+ r = (mp->find_file)(mp,"mpost.map", "r", mp_filetype_fontmap);
+ if (r != NULL) {
+ mp_xfree(r);
+ mp->ps->mitem->map_line = mp_xstrdup (mp,"mpost.map");
+ } else {
+ if (is_troff) {
+ mp->ps->mitem->map_line = mp_xstrdup (mp,"troff.map");
+ } else {
+ mp->ps->mitem->map_line = mp_xstrdup (mp,"pdftex.map");
+ }
+ }
+}
+
+@ @<Dealloc variables@>=
+if (mp->ps->mitem!=NULL) {
+ mp_xfree(mp->ps->mitem->map_line);
+ mp_xfree(mp->ps->mitem);
+}
+
+@ @<Declarations@>=
+static void fm_free (MP mp);
+
+@ @c
+static void fm_free (MP mp) {
+ if (mp->ps->tfm_tree != NULL)
+ avl_destroy (mp->ps->tfm_tree);
+ if (mp->ps->ps_tree != NULL)
+ avl_destroy (mp->ps->ps_tree);
+ if (mp->ps->ff_tree != NULL)
+ avl_destroy (mp->ps->ff_tree);
+}
+
+@ The file |ps_tab_file| gives a table of \TeX\ font names and corresponding
+PostScript names for fonts that do not have to be downloaded, i.e., fonts that
+can be used when |internal[prologues]>0|. Each line consists of a \TeX\ name,
+one or more spaces, a PostScript name, and possibly a space and some other junk.
+This routine reads the table, updates |font_ps_name| entries starting after
+|last_ps_fnum|, and sets |last_ps_fnum:=last_fnum|.
+
+@d ps_tab_name "psfonts.map" /* locates font name translation table */
+
+@<Exported function ...@>=
+void mp_read_psname_table (MP mp) ;
+
+@ @c
+void mp_read_psname_table (MP mp) {
+ font_number k;
+ char *s;
+ static int isread = 0;
+ if (mp->ps->mitem == NULL) {
+ mp->ps->mitem = mp_xmalloc (mp,1,sizeof(mapitem));
+ mp->ps->mitem->mode = FM_DUPIGNORE;
+ mp->ps->mitem->type = MAPFILE;
+ mp->ps->mitem->map_line = NULL;
+ }
+ s = mp_xstrdup (mp,ps_tab_name);
+ mp->ps->mitem->map_line = s;
+ if (isread == 0) {
+ isread++;
+ fm_read_info (mp);
+ }
+ for (k=mp->last_ps_fnum+1;k<=mp->last_fnum;k++) {
+ if (mp_has_fm_entry(mp, k, NULL)) {
+ mp_xfree(mp->font_ps_name[k]);
+ mp->font_ps_name[k] = mp_fm_font_name(mp,k);
+ }
+ }
+ mp->last_ps_fnum=mp->last_fnum;
+}
+
+
+@ The traditional function is a lot shorter now.
+
+
+
+@* \[44c] Helper functions for Type1 fonts.
+
+Avoid to redefine |Byte| and |Bytef| from |<zlib.h>|.
+
+@<Types...@>=
+typedef char char_entry;
+#ifndef ZCONF_H
+typedef unsigned char Byte;
+typedef Byte Bytef;
+#endif
+
+@ @<Glob...@>=
+char_entry *char_ptr, *char_array;
+size_t char_limit;
+char *job_id_string;
+
+@ @<Set initial...@>=
+mp->ps->char_array = NULL;
+mp->ps->job_id_string = NULL;
+
+@
+@d SMALL_ARRAY_SIZE 256
+@d Z_NULL 0
+
+@c
+void mp_set_job_id (MP mp) {
+ char *name_string, *s;
+ size_t slen;
+ if (mp->ps->job_id_string != NULL)
+ return;
+ if ( mp->job_name==NULL )
+ mp->job_name = mp_xstrdup(mp,"mpout");
+ name_string = mp_xstrdup (mp,mp->job_name);
+ slen = SMALL_BUF_SIZE +
+ strlen (name_string) ;
+ s = mp_xmalloc (mp,slen, sizeof (char));
+ @= /*@@-bufferoverflowhigh@@*/ @>
+ sprintf (s,"%.4u/%.2u/%.2u %.2u:%.2u %s",
+ ((unsigned)number_to_scaled (internal_value(mp_year))>>16),
+ ((unsigned)number_to_scaled (internal_value(mp_month))>>16),
+ ((unsigned)number_to_scaled (internal_value(mp_day))>>16),
+ ((unsigned)number_to_scaled (internal_value(mp_time))>>16) / 60,
+ ((unsigned)number_to_scaled (internal_value(mp_time))>>16) % 60,
+ name_string);
+ @= /*@@=bufferoverflowhigh@@*/ @>
+ mp->ps->job_id_string = mp_xstrdup (mp,s);
+ mp_xfree (s);
+ mp_xfree (name_string);
+}
+static void fnstr_append (MP mp, const char *ss) {
+ size_t n = strlen (ss) + 1;
+ alloc_array (char, n, SMALL_ARRAY_SIZE);
+ strcat (mp->ps->char_ptr, ss);
+ mp->ps->char_ptr = strend (mp->ps->char_ptr);
+}
+
+@ @<Exported function headers@>=
+void mp_set_job_id (MP mp) ;
+
+@ @<Dealloc variables@>=
+mp_xfree(mp->ps->job_id_string);
+
+@ this is not really a true crc32, but it should be just enough to keep
+ subsets prefixes somewhat disjunct
+
+@c
+static unsigned long crc32 (unsigned long oldcrc, const Byte *buf, size_t len) {
+ unsigned long ret = 0;
+ size_t i;
+ if (oldcrc==0)
+ ret = (unsigned long)((23<<24)+(45<<16)+(67<<8)+89);
+ else
+ for (i=0;i<len;i++)
+ ret = (ret<<2)+buf[i];
+ return ret;
+}
+static boolean mp_char_marked (MP mp,font_number f, eight_bits c) {
+ integer b; /* |char_base[f]| */
+ b=mp->char_base[f];
+ if ( (c>=mp->font_bc[f])&&(c<=mp->font_ec[f])&&(mp->font_info[b+c].qqqq.b3!=0) )
+ return true;
+ else
+ return false;
+}
+
+static void make_subset_tag (MP mp, fm_entry * fm_cur, char **glyph_names, font_number tex_font)
+{
+ char tag[7];
+ unsigned long crc;
+ int i;
+ size_t l ;
+ if (mp->ps->job_id_string ==NULL)
+ mp_fatal_error(mp, "no job id!");
+ l = strlen (mp->ps->job_id_string) + 1;
+
+ alloc_array (char, l, SMALL_ARRAY_SIZE);
+ strcpy (mp->ps->char_array, mp->ps->job_id_string);
+ mp->ps->char_ptr = strend (mp->ps->char_array);
+ if (fm_cur->tfm_name != NULL) {
+ fnstr_append (mp," TFM name: ");
+ fnstr_append (mp,fm_cur->tfm_name);
+ }
+ fnstr_append (mp," PS name: ");
+ if (fm_cur->ps_name != NULL)
+ fnstr_append (mp,fm_cur->ps_name);
+ fnstr_append (mp," Encoding: ");
+ if (fm_cur->encoding != NULL && (fm_cur->encoding)->file_name != NULL)
+ fnstr_append (mp,(fm_cur->encoding)->file_name);
+ else
+ fnstr_append (mp,"built-in");
+ fnstr_append (mp," CharSet: ");
+ for (i = 0; i < 256; i++)
+ if (mp_char_marked (mp,tex_font, (eight_bits)i) &&
+ glyph_names[i] != notdef &&
+ strcmp(glyph_names[i],notdef) != 0) {
+ if (glyph_names[i]!=NULL) {
+ fnstr_append (mp,"/");
+ fnstr_append (mp,glyph_names[i]);
+ }
+ }
+ if (fm_cur->charset != NULL) {
+ fnstr_append (mp," Extra CharSet: ");
+ fnstr_append (mp, fm_cur->charset);
+ }
+ crc = crc32 (0L, Z_NULL, 0);
+ crc = crc32 (crc, (Bytef *) mp->ps->char_array, strlen (mp->ps->char_array));
+ /* we need to fit a 32-bit number into a string of 6 uppercase chars long;
+ * there are 26 uppercase chars ==> each char represents a number in range
+ * |0..25|. The maximal number that can be represented by the tag is
+ * $26^6 - 1$, which is a number between $2^28$ and $2^29$. Thus the bits |29..31|
+ * of the CRC must be dropped out.
+ */
+ for (i = 0; i < 6; i++) {
+ tag[i] = (char)('A' + crc % 26);
+ crc /= 26;
+ }
+ tag[6] = 0;
+ mp_xfree(fm_cur->subset_tag);
+ fm_cur->subset_tag = mp_xstrdup (mp,tag);
+}
+
+
+
+@
+@d external_enc() (fm_cur->encoding)->glyph_names
+@d is_used_char(c) mp_char_marked (mp, tex_font, (eight_bits)c)
+@d end_last_eexec_line()
+ mp->ps->hexline_length = HEXLINE_WIDTH;
+ end_hexline(mp);
+ mp->ps->t1_eexec_encrypt = false
+@d t1_log(s) mp_print(mp,s)
+@d t1_putchar(c) wps_chr(c)
+@d embed_all_glyphs(tex_font) false
+@d t1_char(c) c
+@d extra_charset() mp->ps->dvips_extra_charset
+@d update_subset_tag()
+@d fixedcontent true
+
+@<Glob...@>=
+#define PRINTF_BUF_SIZE 1024
+char *dvips_extra_charset;
+char *cur_enc_name;
+unsigned char *grid;
+char *ext_glyph_names[256];
+char print_buf[PRINTF_BUF_SIZE];
+size_t t1_byte_waiting;
+size_t t1_byte_length;
+unsigned char *t1_bytes;
+
+@ @<Set initial ...@>=
+mp->ps->dvips_extra_charset=NULL;
+mp->ps->t1_byte_waiting=0;
+mp->ps->t1_byte_length=0;
+mp->ps->t1_bytes=NULL;
+
+@
+@d t1_ungetchar() mp->ps->t1_byte_waiting--
+@d t1_eof() (mp->ps->t1_byte_waiting>=mp->ps->t1_byte_length)
+@d t1_close() do {
+ (mp->close_file)(mp,mp->ps->t1_file);
+ mp_xfree(mp->ps->t1_bytes);
+ mp->ps->t1_bytes = NULL;
+ mp->ps->t1_byte_waiting=0;
+ mp->ps->t1_byte_length=0;
+} while (0)
+@d valid_code(c) (c >= 0 && c < 256)
+
+@c
+static int t1_getchar (MP mp) {
+ if (mp->ps->t1_bytes == NULL) {
+ void *byte_ptr ;
+ (void)fseek( unwrap_file(mp->ps->t1_file), 0,SEEK_END);
+ mp->ps->t1_byte_length = (size_t)ftell( unwrap_file(mp->ps->t1_file) );
+ (void)fseek( unwrap_file(mp->ps->t1_file), 0,SEEK_SET);
+ mp->ps->t1_bytes = mp_xmalloc(mp, mp->ps->t1_byte_length, 1);
+ byte_ptr = (void *)mp->ps->t1_bytes;
+ (mp->read_binary_file)(mp,mp->ps->t1_file,&byte_ptr,&mp->ps->t1_byte_length);
+ }
+ return *(mp->ps->t1_bytes+mp->ps->t1_byte_waiting++);
+}
+
+@ @<Static variables in the outer block@>=
+static const char *standard_glyph_names[256] =
+ { notdef, notdef, notdef, notdef, notdef, notdef, notdef, notdef,
+ notdef, notdef, notdef, notdef, notdef, notdef, notdef, notdef, notdef,
+ notdef, notdef, notdef, notdef, notdef, notdef,
+ notdef, notdef, notdef, notdef, notdef, notdef, notdef, notdef, notdef,
+ "space", "exclam", "quotedbl", "numbersign",
+ "dollar", "percent", "ampersand", "quoteright", "parenleft",
+ "parenright", "asterisk", "plus", "comma", "hyphen", "period",
+ "slash", "zero", "one", "two", "three", "four", "five", "six", "seven",
+ "eight", "nine", "colon", "semicolon", "less",
+ "equal", "greater", "question", "at", "A", "B", "C", "D", "E", "F",
+ "G", "H", "I", "J", "K", "L", "M", "N", "O", "P", "Q",
+ "R", "S", "T", "U", "V", "W", "X", "Y", "Z", "bracketleft",
+ "backslash", "bracketright", "asciicircum", "underscore",
+ "quoteleft", "a", "b", "c", "d", "e", "f", "g", "h", "i", "j", "k",
+ "l", "m", "n", "o", "p", "q", "r", "s", "t", "u", "v",
+ "w", "x", "y", "z", "braceleft", "bar", "braceright", "asciitilde",
+ notdef, notdef, notdef, notdef, notdef, notdef, notdef,
+ notdef, notdef, notdef, notdef, notdef, notdef, notdef, notdef, notdef,
+ notdef, notdef, notdef, notdef, notdef, notdef,
+ notdef, notdef, notdef, notdef, notdef, notdef, notdef, notdef, notdef,
+ notdef, notdef, notdef, "exclamdown", "cent",
+ "sterling", "fraction", "yen", "florin", "section", "currency",
+ "quotesingle", "quotedblleft", "guillemotleft",
+ "guilsinglleft", "guilsinglright", "fi", "fl", notdef, "endash",
+ "dagger", "daggerdbl", "periodcentered", notdef,
+ "paragraph", "bullet", "quotesinglbase", "quotedblbase",
+ "quotedblright", "guillemotright", "ellipsis", "perthousand",
+ notdef, "questiondown", notdef, "grave", "acute", "circumflex",
+ "tilde", "macron", "breve", "dotaccent", "dieresis", notdef,
+ "ring", "cedilla", notdef, "hungarumlaut", "ogonek", "caron", "emdash",
+ notdef, notdef, notdef, notdef, notdef, notdef,
+ notdef, notdef, notdef, notdef, notdef, notdef, notdef, notdef, notdef,
+ notdef, "AE", notdef, "ordfeminine", notdef, notdef,
+ notdef, notdef, "Lslash", "Oslash", "OE", "ordmasculine", notdef,
+ notdef, notdef, notdef, notdef, "ae", notdef, notdef,
+ notdef, "dotlessi", notdef, notdef, "lslash", "oslash", "oe",
+ "germandbls", notdef, notdef, notdef, notdef };
+static const char charstringname[] = "/CharStrings";
+
+@ @<Glob...@>=
+char **t1_glyph_names;
+char *t1_builtin_glyph_names[256];
+char charsetstr[0x4000];
+boolean read_encoding_only;
+int t1_encoding;
+
+@ @c
+#define T1_BUF_SIZE 0x100
+
+#define CS_HSTEM 1
+#define CS_VSTEM 3
+#define CS_VMOVETO 4
+#define CS_RLINETO 5
+#define CS_HLINETO 6
+#define CS_VLINETO 7
+#define CS_RRCURVETO 8
+#define CS_CLOSEPATH 9
+#define CS_CALLSUBR 10
+#define CS_RETURN 11
+#define CS_ESCAPE 12
+#define CS_HSBW 13
+#define CS_ENDCHAR 14
+#define CS_RMOVETO 21
+#define CS_HMOVETO 22
+#define CS_VHCURVETO 30
+#define CS_HVCURVETO 31
+#define CS_1BYTE_MAX (CS_HVCURVETO + 1)
+
+#define CS_DOTSECTION CS_1BYTE_MAX + 0
+#define CS_VSTEM3 CS_1BYTE_MAX + 1
+#define CS_HSTEM3 CS_1BYTE_MAX + 2
+#define CS_SEAC CS_1BYTE_MAX + 6
+#define CS_SBW CS_1BYTE_MAX + 7
+#define CS_DIV CS_1BYTE_MAX + 12
+#define CS_CALLOTHERSUBR CS_1BYTE_MAX + 16
+#define CS_POP CS_1BYTE_MAX + 17
+#define CS_SETCURRENTPOINT CS_1BYTE_MAX + 33
+#define CS_2BYTE_MAX (CS_SETCURRENTPOINT + 1)
+#define CS_MAX CS_2BYTE_MAX
+
+@ @<Types...@>=
+typedef unsigned char byte;
+typedef struct {
+ byte nargs; /* number of arguments */
+ boolean bottom; /* take arguments from bottom of stack? */
+ boolean clear; /* clear stack? */
+ boolean valid;
+} cc_entry; /* CharString Command */
+typedef struct {
+ char *glyph_name; /* glyph name (or notdef for Subrs entry) */
+ byte *data;
+ unsigned short len; /* length of the whole string */
+ unsigned short cslen; /* length of the encoded part of the string */
+ boolean is_used;
+ boolean valid;
+} cs_entry;
+
+@
+@d t1_c1 52845
+@d t1_c2 22719
+
+@<Glob...@>=
+unsigned short t1_dr, t1_er;
+unsigned short t1_cslen;
+short t1_lenIV;
+
+@ @<Types...@>=
+typedef char t1_line_entry;
+typedef char t1_buf_entry;
+
+@ @<Glob...@>=
+t1_line_entry *t1_line_ptr, *t1_line_array;
+size_t t1_line_limit;
+t1_buf_entry *t1_buf_ptr, *t1_buf_array;
+size_t t1_buf_limit;
+int cs_start;
+cs_entry *cs_tab, *cs_ptr, *cs_notdef;
+char *cs_dict_start, *cs_dict_end;
+int cs_count, cs_size, cs_size_pos;
+cs_entry *subr_tab;
+char *subr_array_start, *subr_array_end;
+int subr_max, subr_size, subr_size_pos;
+
+@ @<Set initial...@>=
+mp->ps->t1_line_array = NULL;
+mp->ps->t1_buf_array = NULL;
+
+@
+ This list contains the begin/end tokens commonly used in the
+ /Subrs array of a Type 1 font.
+
+@<Static variables in the outer block@>=
+static const char *cs_token_pairs_list[][2] = {
+ {" RD", "NP"},
+ {" -|", "|"},
+ {" RD", "noaccess put"},
+ {" -|", "noaccess put"},
+ {NULL, NULL}
+};
+
+@ @<Glob...@>=
+const char **cs_token_pair;
+boolean t1_pfa, t1_cs, t1_scan, t1_eexec_encrypt, t1_synthetic;
+int t1_in_eexec; /* 0 before eexec-encrypted, 1 during, 2 after */
+int t1_block_length;
+int last_hexbyte;
+void *t1_file;
+int hexline_length;
+
+@
+@d HEXLINE_WIDTH 64
+
+@<Set initial ...@>=
+mp->ps->hexline_length = 0;
+
+@
+@d t1_prefix(s) str_prefix(mp->ps->t1_line_array, s)
+@d t1_buf_prefix(s) str_prefix(mp->ps->t1_buf_array, s)
+@d t1_suffix(s) str_suffix(mp->ps->t1_line_array, mp->ps->t1_line_ptr, s)
+@d t1_buf_suffix(s) str_suffix(mp->ps->t1_buf_array, mp->ps->t1_buf_ptr, s)
+@d t1_charstrings() strstr(mp->ps->t1_line_array, charstringname)
+@d t1_subrs() t1_prefix("/Subrs")
+@d t1_end_eexec() t1_suffix("mark currentfile closefile")
+@d t1_cleartomark() t1_prefix("cleartomark")
+
+@c
+static void end_hexline (MP mp) {
+ if (mp->ps->hexline_length >= HEXLINE_WIDTH) {
+ wps_cr;
+ mp->ps->hexline_length = 0;
+ }
+}
+static void t1_check_pfa (MP mp) {
+ const int c = t1_getchar (mp);
+ mp->ps->t1_pfa = (c != 128) ? true : false;
+ t1_ungetchar ();
+}
+static int t1_getbyte (MP mp)
+{
+ int c = t1_getchar (mp);
+ if (mp->ps->t1_pfa)
+ return c;
+ if (mp->ps->t1_block_length == 0) {
+ if (c != 128)
+ mp_fatal_error (mp, "invalid marker");
+ c = t1_getchar (mp);
+ if (c == 3) {
+ while (!t1_eof ())
+ (void)t1_getchar (mp);
+ return EOF;
+ }
+ mp->ps->t1_block_length = t1_getchar (mp) & 0xff;
+ mp->ps->t1_block_length |= (int)(((unsigned)t1_getchar (mp) & 0xff) << 8);
+ mp->ps->t1_block_length |= (int)(((unsigned)t1_getchar (mp) & 0xff) << 16);
+ mp->ps->t1_block_length |= (int)(((unsigned)t1_getchar (mp) & 0xff) << 24);
+ c = t1_getchar (mp);
+ }
+ mp->ps->t1_block_length--;
+ return c;
+}
+static int hexval (int c) {
+ if (c >= 'A' && c <= 'F')
+ return c - 'A' + 10;
+ else if (c >= 'a' && c <= 'f')
+ return c - 'a' + 10;
+ else if (c >= '0' && c <= '9')
+ return c - '0';
+ else
+ return -1;
+}
+static byte edecrypt (MP mp, byte cipher) {
+ byte plain;
+ if (mp->ps->t1_pfa) {
+ while (cipher == 10 || cipher == 13)
+ cipher = (byte)t1_getbyte (mp);
+ mp->ps->last_hexbyte = cipher = (byte)(((byte)hexval (cipher) << 4) +
+ hexval (t1_getbyte (mp)));
+ }
+ plain = (byte)(cipher ^ (mp->ps->t1_dr >> 8));
+ mp->ps->t1_dr = (unsigned short)((cipher + mp->ps->t1_dr) * t1_c1 + t1_c2);
+ return plain;
+}
+static byte cdecrypt (byte cipher, unsigned short *cr)
+{
+ const byte plain = (byte)(cipher ^ (*cr >> 8));
+ *cr = (unsigned short)((cipher + *cr) * t1_c1 + t1_c2);
+ return plain;
+}
+static byte eencrypt (MP mp, byte plain)
+{
+ const byte cipher = (byte)(plain ^ (mp->ps->t1_er >> 8));
+ mp->ps->t1_er = (unsigned short)((cipher + mp->ps->t1_er) * t1_c1 + t1_c2);
+ return cipher;
+}
+
+static byte cencrypt (byte plain, unsigned short *cr)
+{
+ const byte cipher = (byte)(plain ^ (*cr >> 8));
+ *cr = (unsigned short)((cipher + *cr) * t1_c1 + t1_c2);
+ return cipher;
+}
+
+static char *eol (char *s) {
+ char *p = strend (s);
+ if (p!=NULL && p - s > 1 && p[-1] != 10) {
+ *p++ = 10;
+ *p = 0;
+ }
+ return p;
+}
+static float t1_scan_num (MP mp, char *p, char **r)
+{
+ float f;
+ char s[128];
+ skip (p, ' ');
+ if (sscanf (p, "%g", &f) != 1) {
+ remove_eol (p, mp->ps->t1_line_array);
+ mp_snprintf(s,128, "a number expected: `%s'", mp->ps->t1_line_array);
+ mp_fatal_error(mp,s);
+ }
+ if (r != NULL) {
+ for (; mp_isdigit (*p) || *p == '.' ||
+ *p == 'e' || *p == 'E' || *p == '+' || *p == '-'; p++);
+ *r = p;
+ }
+ return f;
+}
+
+static boolean str_suffix (const char *begin_buf, const char *end_buf,
+ const char *s)
+{
+ const char *s1 = end_buf - 1, *s2 = strend (s) - 1;
+ if (*s1 == 10)
+ s1--;
+ while (s1 >= begin_buf && s2 >= s) {
+ if (*s1-- != *s2--)
+ return false;
+ }
+ return s2 < s;
+}
+
+@
+
+@d alloc_array(T, n, s) do {
+ size_t nn = (size_t)n;
+ if (mp->ps->T##_array == NULL) {
+ mp->ps->T##_limit = s;
+ if (nn > mp->ps->T##_limit)
+ mp->ps->T##_limit = nn;
+ mp->ps->T##_array = mp_xmalloc (mp,mp->ps->T##_limit,sizeof(T##_entry));
+ mp->ps->T##_ptr = mp->ps->T##_array;
+ }
+ else if ((size_t)(mp->ps->T##_ptr - mp->ps->T##_array) + nn > mp->ps->T##_limit) {
+ size_t last_ptr_index;
+ last_ptr_index = (size_t)(mp->ps->T##_ptr - mp->ps->T##_array);
+ mp->ps->T##_limit *= 2;
+ mp->ps->T##_limit += s;
+ if ((size_t)(mp->ps->T##_ptr - mp->ps->T##_array) + nn > mp->ps->T##_limit)
+ mp->ps->T##_limit = (size_t)(mp->ps->T##_ptr - mp->ps->T##_array) + nn;
+ mp->ps->T##_array = mp_xrealloc(mp,mp->ps->T##_array,mp->ps->T##_limit, sizeof(T##_entry));
+ mp->ps->T##_ptr = mp->ps->T##_array + last_ptr_index;
+ }
+} while (0)
+
+@c
+static void t1_getline (MP mp) {
+ int c, l, eexec_scan;
+ char *p;
+ static const char eexec_str[] = "currentfile eexec";
+ static int eexec_len = 17; /* |strlen(eexec_str)| */
+ RESTART:
+ if (t1_eof ())
+ mp_fatal_error (mp,"unexpected end of file");
+ mp->ps->t1_line_ptr = mp->ps->t1_line_array;
+ alloc_array (t1_line, 1, T1_BUF_SIZE);
+ mp->ps->t1_cslen = 0;
+ eexec_scan = 0;
+ c = t1_getbyte (mp);
+ if (c == EOF)
+ goto EXIT;
+ while (!t1_eof ()) {
+ if (mp->ps->t1_in_eexec == 1)
+ c = edecrypt (mp,(byte)c);
+ alloc_array (t1_line, 1, T1_BUF_SIZE);
+ append_char_to_buf (c, mp->ps->t1_line_ptr, mp->ps->t1_line_array, mp->ps->t1_line_limit);
+ if (mp->ps->t1_in_eexec == 0 && eexec_scan >= 0 && eexec_scan < eexec_len) {
+ if (mp->ps->t1_line_array[eexec_scan] == eexec_str[eexec_scan])
+ eexec_scan++;
+ else
+ eexec_scan = -1;
+ }
+ if (c == 10 || (mp->ps->t1_pfa && eexec_scan == eexec_len && c == 32))
+ break;
+ if (mp->ps->t1_cs && mp->ps->t1_cslen == 0 &&
+ (mp->ps->t1_line_ptr - mp->ps->t1_line_array > 4) &&
+ (t1_suffix (" RD ") || t1_suffix (" -| "))) {
+ p = mp->ps->t1_line_ptr - 5;
+ while (*p != ' ')
+ p--;
+ l = (int)t1_scan_num (mp, p + 1, 0);
+ mp->ps->t1_cslen = (unsigned short)l;
+ mp->ps->cs_start = (int)(mp->ps->t1_line_ptr - mp->ps->t1_line_array);
+ /* |mp->ps->cs_start| is an index now */
+ alloc_array (t1_line, l, T1_BUF_SIZE);
+ while (l-- > 0) {
+ *mp->ps->t1_line_ptr = (t1_line_entry)edecrypt (mp,(byte)t1_getbyte (mp));
+ mp->ps->t1_line_ptr++;
+ }
+ }
+ c = t1_getbyte (mp);
+ }
+ alloc_array (t1_line, 2, T1_BUF_SIZE); /* |append_eol| can append 2 chars */
+ append_eol (mp->ps->t1_line_ptr, mp->ps->t1_line_array, mp->ps->t1_line_limit);
+ if (mp->ps->t1_line_ptr - mp->ps->t1_line_array < 2)
+ goto RESTART;
+ if (eexec_scan == eexec_len)
+ mp->ps->t1_in_eexec = 1;
+ EXIT:
+ /* ensure that |mp->ps->t1_buf_array| has as much room as |t1_line_array| */
+ mp->ps->t1_buf_ptr = mp->ps->t1_buf_array;
+ alloc_array (t1_buf, mp->ps->t1_line_limit, mp->ps->t1_line_limit);
+}
+
+static void t1_putline (MP mp)
+{
+ char ss[256];
+ int ss_cur = 0;
+ static const char *hexdigits = "0123456789ABCDEF";
+ char *p = mp->ps->t1_line_array;
+ if (mp->ps->t1_line_ptr - mp->ps->t1_line_array <= 1)
+ return;
+ if (mp->ps->t1_eexec_encrypt) {
+ while (p < mp->ps->t1_line_ptr) {
+ byte b = eencrypt (mp,(byte)*p++);
+ if (ss_cur>=253) {
+ ss[ss_cur] = '\0';
+ (mp->write_ascii_file)(mp,mp->output_file,(char *)ss);
+ ss_cur = 0;
+ }
+ ss[ss_cur++] = hexdigits[b / 16];
+ ss[ss_cur++] = hexdigits[b % 16];
+ mp->ps->hexline_length += 2;
+ if (mp->ps->hexline_length >= HEXLINE_WIDTH) {
+ ss[ss_cur++] = '\n';
+ mp->ps->hexline_length = 0;
+ }
+ }
+ } else {
+ while (p < mp->ps->t1_line_ptr) {
+ if (ss_cur>=255) {
+ ss[ss_cur] = '\0';
+ (mp->write_ascii_file)(mp,mp->output_file,(char *)ss);
+ ss_cur = 0;
+ }
+ ss[ss_cur++] = (char)(*p++);
+ }
+ }
+ ss[ss_cur] = '\0';
+ (mp->write_ascii_file)(mp,mp->output_file,(char *)ss);
+}
+
+static void t1_puts (MP mp, const char *s)
+{
+ if (s != mp->ps->t1_line_array)
+ strcpy (mp->ps->t1_line_array, s);
+ mp->ps->t1_line_ptr = strend (mp->ps->t1_line_array);
+ t1_putline (mp);
+}
+
+static void t1_init_params (MP mp, const char *open_name_prefix,
+ char *cur_file_name) {
+ if ((open_name_prefix != NULL) && strlen(open_name_prefix)) {
+ t1_log (open_name_prefix);
+ t1_log (cur_file_name);
+ }
+ mp->ps->t1_lenIV = 4;
+ mp->ps->t1_dr = 55665;
+ mp->ps->t1_er = 55665;
+ mp->ps->t1_in_eexec = 0;
+ mp->ps->t1_cs = false;
+ mp->ps->t1_scan = true;
+ mp->ps->t1_synthetic = false;
+ mp->ps->t1_eexec_encrypt = false;
+ mp->ps->t1_block_length = 0;
+ t1_check_pfa (mp);
+}
+static void t1_close_font_file (MP mp, const char *close_name_suffix) {
+ if ((close_name_suffix != NULL) && strlen(close_name_suffix)) {
+ t1_log (close_name_suffix);
+ }
+ t1_close ();
+}
+
+static void t1_check_block_len (MP mp, boolean decrypt) {
+ int l, c;
+ char s[128];
+ if (mp->ps->t1_block_length == 0)
+ return;
+ c = t1_getbyte (mp);
+ if (decrypt)
+ c = edecrypt (mp,(byte)c);
+ l = mp->ps->t1_block_length;
+ if (!(l == 0 && (c == 10 || c == 13))) {
+ mp_snprintf(s,128,"%i bytes more than expected were ignored", l+ 1);
+ mp_warn(mp,s);
+ while (l-- > 0)
+ (void)t1_getbyte (mp);
+ }
+}
+static void t1_start_eexec (MP mp, fm_entry *fm_cur) {
+ int i;
+ if (!mp->ps->t1_pfa)
+ t1_check_block_len (mp, false);
+ for (mp->ps->t1_line_ptr = mp->ps->t1_line_array, i = 0; i < 4; i++) {
+ (void)edecrypt (mp, (byte)t1_getbyte (mp));
+ *mp->ps->t1_line_ptr++ = 0;
+ }
+ mp->ps->t1_eexec_encrypt = true;
+ if (!mp->ps->read_encoding_only)
+ if (is_included (fm_cur))
+ t1_putline (mp); /* to put the first four bytes */
+}
+static void t1_stop_eexec (MP mp) {
+ int c;
+ end_last_eexec_line ();
+ if (!mp->ps->t1_pfa)
+ t1_check_block_len (mp,true);
+ else {
+ c = edecrypt (mp, (byte)t1_getbyte (mp));
+ if (!(c == 10 || c == 13)) {
+ if (mp->ps->last_hexbyte == 0)
+ t1_puts (mp,"00");
+ else
+ mp_warn (mp,"unexpected data after eexec");
+ }
+ }
+ mp->ps->t1_cs = false;
+ mp->ps->t1_in_eexec = 2;
+}
+static void t1_modify_fm (MP mp) {
+ mp->ps->t1_line_ptr = eol (mp->ps->t1_line_array);
+}
+
+static void t1_modify_italic (MP mp) {
+ mp->ps->t1_line_ptr = eol (mp->ps->t1_line_array);
+}
+
+@ @<Types...@>=
+typedef struct {
+ const char *pdfname;
+ const char *t1name;
+ float value;
+ boolean valid;
+} key_entry;
+
+@
+@d FONT_KEYS_NUM 11
+
+@<Declarations@>=
+static key_entry font_keys[FONT_KEYS_NUM] = {
+ {"Ascent", "Ascender", 0, false},
+ {"CapHeight", "CapHeight", 0, false},
+ {"Descent", "Descender", 0, false},
+ {"FontName", "FontName", 0, false},
+ {"ItalicAngle", "ItalicAngle", 0, false},
+ {"StemV", "StdVW", 0, false},
+ {"XHeight", "XHeight", 0, false},
+ {"FontBBox", "FontBBox", 0, false},
+ {"", "", 0, false},
+ {"", "", 0, false},
+ {"", "", 0, false}
+};
+
+
+@
+@d ASCENT_CODE 0
+@d CAPHEIGHT_CODE 1
+@d DESCENT_CODE 2
+@d FONTNAME_CODE 3
+@d ITALIC_ANGLE_CODE 4
+@d STEMV_CODE 5
+@d XHEIGHT_CODE 6
+@d FONTBBOX1_CODE 7
+@d FONTBBOX2_CODE 8
+@d FONTBBOX3_CODE 9
+@d FONTBBOX4_CODE 10
+@d MAX_KEY_CODE (FONTBBOX1_CODE + 1)
+
+@c
+static void t1_scan_keys (MP mp, font_number tex_font,fm_entry *fm_cur) {
+ int i, k;
+ char *p, *r;
+ key_entry *key;
+ if (fm_extend (fm_cur) != 0 || fm_slant (fm_cur) != 0) {
+ if (t1_prefix ("/FontMatrix")) {
+ t1_modify_fm (mp);
+ return;
+ }
+ if (t1_prefix ("/ItalicAngle")) {
+ t1_modify_italic (mp);
+ return;
+ }
+ }
+ if (t1_prefix ("/FontType")) {
+ p = mp->ps->t1_line_array + strlen ("FontType") + 1;
+ if ((i = (int)t1_scan_num (mp,p, 0)) != 1) {
+ char s[128];
+ mp_snprintf(s,125,"Type%d fonts unsupported by metapost", i);
+ mp_fatal_error(mp,s);
+ }
+ return;
+ }
+ for (key = font_keys; key - font_keys < MAX_KEY_CODE; key++)
+ if (str_prefix (mp->ps->t1_line_array + 1, key->t1name))
+ break;
+ if (key - font_keys == MAX_KEY_CODE)
+ return;
+ key->valid = true;
+ p = mp->ps->t1_line_array + strlen (key->t1name) + 1;
+ skip (p, ' ');
+ if ((k = (int)(key - font_keys)) == FONTNAME_CODE) {
+ if (*p != '/') {
+ char s[128];
+ remove_eol (p, mp->ps->t1_line_array);
+ mp_snprintf(s,128,"a name expected: `%s'", mp->ps->t1_line_array);
+ mp_fatal_error(mp,s);
+ }
+ r = ++p; /* skip the slash */
+ if (is_included (fm_cur)) {
+ /* save the fontname */
+ strncpy (mp->ps->fontname_buf, p, FONTNAME_BUF_SIZE);
+ for (i=0; mp->ps->fontname_buf[i] != 10; i++);
+ mp->ps->fontname_buf[i]=0;
+
+ if(is_subsetted (fm_cur)) {
+ if (fm_cur->encoding!=NULL && fm_cur->encoding->glyph_names!=NULL)
+ make_subset_tag (mp,fm_cur, fm_cur->encoding->glyph_names, tex_font);
+ else
+ make_subset_tag (mp,fm_cur, mp->ps->t1_builtin_glyph_names, tex_font);
+
+ alloc_array (t1_line, (size_t)(r-mp->ps->t1_line_array)+6+1+strlen(mp->ps->fontname_buf)+1,
+ T1_BUF_SIZE);
+ strncpy (r, fm_cur->subset_tag , 6);
+ *(r+6) = '-';
+ strncpy (r+7, mp->ps->fontname_buf, strlen(mp->ps->fontname_buf)+1);
+ mp->ps->t1_line_ptr = eol (r);
+ } else {
+ /* |for (q = p; *q != ' ' && *q != 10; *q++);|*/
+ /*|*q = 0;|*/
+ mp->ps->t1_line_ptr = eol (r);
+ }
+ }
+ return;
+ }
+ if ((k == STEMV_CODE || k == FONTBBOX1_CODE)
+ && (*p == '[' || *p == '{'))
+ p++;
+ if (k == FONTBBOX1_CODE) {
+ for (i = 0; i < 4; i++) {
+ key[i].value = t1_scan_num (mp, p, &r);
+ p = r;
+ }
+ return;
+ }
+ key->value = t1_scan_num (mp, p, 0);
+}
+static void t1_scan_param (MP mp, font_number tex_font,fm_entry *fm_cur)
+{
+ static const char *lenIV = "/lenIV";
+ if (!mp->ps->t1_scan || *mp->ps->t1_line_array != '/')
+ return;
+ if (t1_prefix (lenIV)) {
+ mp->ps->t1_lenIV = (short int)t1_scan_num (mp,mp->ps->t1_line_array + strlen (lenIV), 0);
+ return;
+ }
+ t1_scan_keys (mp, tex_font,fm_cur);
+}
+static void copy_glyph_names (MP mp, char **glyph_names, int a, int b) {
+ if (glyph_names[b] != notdef)
+ mp_xfree (glyph_names[b]);
+ glyph_names[b] = mp_xstrdup (mp,glyph_names[a]);
+}
+static void t1_builtin_enc (MP mp) {
+ int i, a, b, c, counter = 0;
+ char *r, *p;
+ /*
+ * At this moment "/Encoding" is the prefix of |mp->ps->t1_line_array|
+ */
+ if (t1_suffix ("def")) { /* predefined encoding */
+ (void)sscanf (mp->ps->t1_line_array + strlen ("/Encoding"), "%255s", mp->ps->t1_buf_array);
+ if (strcmp (mp->ps->t1_buf_array, "StandardEncoding") == 0) {
+ for (i = 0; i < 256; i++) {
+ if (mp->ps->t1_builtin_glyph_names[i] != notdef)
+ mp_xfree(mp->ps->t1_builtin_glyph_names[i]);
+ mp->ps->t1_builtin_glyph_names[i] =
+ mp_xstrdup (mp,standard_glyph_names[i]);
+ }
+ mp->ps->t1_encoding = ENC_STANDARD;
+ } else {
+ char s[128];
+ mp_snprintf(s,128, "cannot subset font (unknown predefined encoding `%s')",
+ mp->ps->t1_buf_array);
+ mp_fatal_error(mp,s);
+ }
+ return;
+ } else
+ mp->ps->t1_encoding = ENC_BUILTIN;
+ /*
+ * At this moment "/Encoding" is the prefix of |mp->ps->t1_line_array|, and the encoding is
+ * not a predefined encoding
+ *
+ * We have two possible forms of Encoding vector. The first case is
+ *
+ * /Encoding [/a /b /c...] readonly def
+ *
+ * and the second case can look like
+ *
+ * /Encoding 256 array 0 1 255 {1 index exch /.notdef put} for
+ * dup 0 /x put
+ * dup 1 /y put
+ * ...
+ * readonly def
+ */
+ for (i = 0; i < 256; i++) {
+ if (mp->ps->t1_builtin_glyph_names[i] != notdef) {
+ mp_xfree(mp->ps->t1_builtin_glyph_names[i]);
+ mp->ps->t1_builtin_glyph_names[i] = mp_xstrdup(mp, notdef);
+ }
+ }
+ if (t1_prefix ("/Encoding [") || t1_prefix ("/Encoding[")) { /* the first case */
+ r = strchr (mp->ps->t1_line_array, '[') + 1;
+ skip (r, ' ');
+ for (;;) {
+ while (*r == '/') {
+ for (p = mp->ps->t1_buf_array, r++;
+ *r != 32 && *r != 10 && *r != ']' && *r != '/';
+ *p++ = *r++);
+ *p = 0;
+ skip (r, ' ');
+ if (counter > 255) {
+ mp_fatal_error
+ (mp, "encoding vector contains more than 256 names");
+ }
+ if (strcmp (mp->ps->t1_buf_array, notdef) != 0) {
+ if (mp->ps->t1_builtin_glyph_names[counter] != notdef)
+ mp_xfree(mp->ps->t1_builtin_glyph_names[counter]);
+ mp->ps->t1_builtin_glyph_names[counter] = mp_xstrdup (mp,mp->ps->t1_buf_array);
+ }
+ counter++;
+ }
+ if (*r != 10 && *r != '%') {
+ if (str_prefix (r, "] def")
+ || str_prefix (r, "] readonly def"))
+ break;
+ else {
+ char s[128];
+ remove_eol (r, mp->ps->t1_line_array);
+ mp_snprintf(s,128,"a name or `] def' or `] readonly def' expected: `%s'",
+ mp->ps->t1_line_array);
+ mp_fatal_error(mp,s);
+ }
+ }
+ t1_getline (mp);
+ r = mp->ps->t1_line_array;
+ }
+ } else { /* the second case */
+ p = strchr (mp->ps->t1_line_array, 10);
+ for (;p!=NULL;) {
+ if (*p == 10) {
+ t1_getline (mp);
+ p = mp->ps->t1_line_array;
+ }
+ /*
+ check for `dup <index> <glyph> put'
+ */
+ if (sscanf (p, "dup %i%255s put", &i, mp->ps->t1_buf_array) == 2 &&
+ *mp->ps->t1_buf_array == '/' && valid_code (i)) {
+ if (strcmp (mp->ps->t1_buf_array + 1, notdef) != 0) {
+ if (mp->ps->t1_builtin_glyph_names[i] != notdef)
+ mp_xfree(mp->ps->t1_builtin_glyph_names[i]);
+ mp->ps->t1_builtin_glyph_names[i] =
+ mp_xstrdup (mp,mp->ps->t1_buf_array + 1);
+ }
+ p = strstr (p, " put") + strlen (" put");
+ skip (p, ' ');
+ }
+ /*
+ check for `dup dup <to> exch <from> get put'
+ */
+ else if (sscanf (p, "dup dup %i exch %i get put", &b, &a) == 2
+ && valid_code (a) && valid_code (b)) {
+ copy_glyph_names (mp,mp->ps->t1_builtin_glyph_names, a, b);
+ p = strstr (p, " get put") + strlen (" get put");
+ skip (p, ' ');
+ }
+ /*
+ check for `dup dup <from> <size> getinterval <to> exch putinterval'
+ */
+ else if (sscanf
+ (p, "dup dup %i %i getinterval %i exch putinterval",
+ &a, &c, &b) == 3 && valid_code (a) && valid_code (b)
+ && valid_code (c)) {
+ for (i = 0; i < c; i++)
+ copy_glyph_names (mp,mp->ps->t1_builtin_glyph_names, a + i, b + i);
+ p = strstr (p, " putinterval") + strlen (" putinterval");
+ skip (p, ' ');
+ }
+ /*
+ check for `def' or `readonly def'
+ */
+ else if ((p == mp->ps->t1_line_array || (p > mp->ps->t1_line_array && p[-1] == ' '))
+ && strcmp (p, "def\n") == 0)
+ return;
+ /*
+ skip an unrecognizable word
+ */
+ else {
+ while (*p != ' ' && *p != 10)
+ p++;
+ skip (p, ' ');
+ }
+ }
+ }
+}
+
+static void t1_check_end (MP mp) {
+ if (t1_eof ())
+ return;
+ t1_getline (mp);
+ if (t1_prefix ("{restore}"))
+ t1_putline (mp);
+}
+
+@ @<Set initial values...@>=
+{
+ int i;
+ for (i = 0; i < 256; i++) {
+ mp->ps->t1_builtin_glyph_names[i] = strdup(notdef);
+ assert(mp->ps->t1_builtin_glyph_names[i]);
+ }
+}
+
+@ @<Types...@>=
+typedef struct {
+ char *ff_name; /* base name of font file */
+ char *ff_path; /* full path to font file */
+} ff_entry;
+
+@ @c
+static boolean t1_open_fontfile (MP mp, fm_entry *fm_cur,const char *open_name_prefix) {
+ ff_entry *ff;
+ ff = check_ff_exist (mp, fm_cur);
+ mp->ps->t1_file = NULL;
+ if (ff->ff_path != NULL) {
+ mp->ps->t1_file = (mp->open_file)(mp,ff->ff_path, "r", mp_filetype_font);
+ }
+ if (mp->ps->t1_file == NULL) {
+ char err [256];
+ mp_snprintf(err, 255, "cannot open Type 1 font file %s for reading", ff->ff_path);
+ mp_warn (mp,err);
+ return false;
+ }
+ t1_init_params (mp,open_name_prefix,fm_cur->ff_name);
+ mp->ps->fontfile_found = true;
+ return true;
+}
+
+static void t1_scan_only (MP mp, font_number tex_font, fm_entry *fm_cur) {
+ do {
+ t1_getline (mp);
+ t1_scan_param (mp,tex_font, fm_cur);
+ }
+ while (mp->ps->t1_in_eexec == 0);
+ t1_start_eexec (mp,fm_cur);
+ do {
+ t1_getline (mp);
+ t1_scan_param (mp,tex_font, fm_cur);
+ }
+ while (!(t1_charstrings () || t1_subrs ()));
+}
+
+static void t1_include (MP mp, font_number tex_font, fm_entry *fm_cur) {
+ do {
+ t1_getline (mp);
+ t1_scan_param (mp,tex_font, fm_cur);
+ t1_putline (mp);
+ }
+ while (mp->ps->t1_in_eexec == 0);
+ t1_start_eexec (mp,fm_cur);
+ do {
+ t1_getline (mp);
+ t1_scan_param (mp,tex_font, fm_cur);
+ t1_putline (mp);
+ }
+ while (!(t1_charstrings () || t1_subrs ()));
+ mp->ps->t1_cs = true;
+ do {
+ t1_getline (mp);
+ t1_putline (mp);
+ }
+ while (!t1_end_eexec ());
+ t1_stop_eexec (mp);
+ if (fixedcontent) { /* copy 512 zeros (not needed for PDF) */
+ do {
+ t1_getline (mp);
+ t1_putline (mp);
+ }
+ while (!t1_cleartomark ());
+ t1_check_end (mp); /* write "{restore}if" if found */
+ }
+}
+
+@
+@d check_subr(SUBR) if (SUBR >= mp->ps->subr_size || SUBR < 0) {
+ char s[128];
+ mp_snprintf(s,128,"Subrs array: entry index out of range (%i)",SUBR);
+ mp_fatal_error(mp,s);
+ }
+
+@c
+static const char **check_cs_token_pair (MP mp) {
+ const char **p = (const char **) cs_token_pairs_list;
+ for (; p[0] != NULL; ++p)
+ if (t1_buf_prefix (p[0]) && t1_buf_suffix (p[1]))
+ return p;
+ return NULL;
+}
+
+static void cs_store (MP mp, boolean is_subr) {
+ char *p;
+ cs_entry *ptr;
+ int subr;
+ for (p = mp->ps->t1_line_array, mp->ps->t1_buf_ptr = mp->ps->t1_buf_array; *p != ' ';
+ *mp->ps->t1_buf_ptr++ = *p++);
+ *mp->ps->t1_buf_ptr = 0;
+ if (is_subr) {
+ subr = (int)t1_scan_num (mp, p + 1, 0);
+ check_subr (subr);
+ ptr = mp->ps->subr_tab + subr;
+ } else {
+ ptr = mp->ps->cs_ptr++;
+ if (mp->ps->cs_ptr - mp->ps->cs_tab > mp->ps->cs_size) {
+ char s[128];
+ mp_snprintf(s,128,"CharStrings dict: more entries than dict size (%i)",mp->ps->cs_size);
+ mp_fatal_error(mp,s);
+ }
+ ptr->glyph_name = mp_xstrdup (mp,mp->ps->t1_buf_array + 1);
+ }
+ /* copy " RD " + cs data to |mp->ps->t1_buf_array| */
+ memcpy (mp->ps->t1_buf_array, mp->ps->t1_line_array + mp->ps->cs_start - 4,
+ (size_t) (mp->ps->t1_cslen + 4));
+ /* copy the end of cs data to |mp->ps->t1_buf_array| */
+ for (p = mp->ps->t1_line_array + mp->ps->cs_start + mp->ps->t1_cslen, mp->ps->t1_buf_ptr =
+ mp->ps->t1_buf_array + mp->ps->t1_cslen + 4; *p != 10; *mp->ps->t1_buf_ptr++ = *p++);
+ *mp->ps->t1_buf_ptr++ = 10;
+ if (is_subr && mp->ps->cs_token_pair == NULL)
+ mp->ps->cs_token_pair = check_cs_token_pair (mp);
+ ptr->len = (unsigned short)(mp->ps->t1_buf_ptr - mp->ps->t1_buf_array);
+ ptr->cslen = mp->ps->t1_cslen;
+ ptr->data = mp_xmalloc (mp, (size_t)ptr->len , sizeof (byte));
+ memcpy (ptr->data, mp->ps->t1_buf_array, (size_t)ptr->len);
+ ptr->valid = true;
+}
+
+#define store_subr(mp) cs_store(mp,true)
+#define store_cs(mp) cs_store(mp,false)
+
+#define CC_STACK_SIZE 24
+
+static double cc_stack[CC_STACK_SIZE], *stack_ptr = cc_stack;
+static cc_entry cc_tab[CS_MAX];
+static boolean is_cc_init = false;
+
+
+#define cc_pop(N) \
+ if (stack_ptr - cc_stack < (N)) \
+ stack_error(N); \
+ stack_ptr -= N
+
+#define stack_error(N) { \
+ char s[256]; \
+ mp_snprintf(s,255,"CharString: invalid access (%i) to stack (%i entries)", \
+ (int) N, (int)(stack_ptr - cc_stack)); \
+ mp_warn(mp,s); \
+ goto cs_error; \
+}
+
+
+#define cc_get(N) ((N) < 0 ? *(stack_ptr + (N)) : *(cc_stack + (N)))
+
+#define cc_push(V) *stack_ptr++ = (double)(V)
+#define cc_clear() stack_ptr = cc_stack
+
+#define set_cc(N, B, A, C) \
+ cc_tab[N].nargs = A; \
+ cc_tab[N].bottom = B; \
+ cc_tab[N].clear = C; \
+ cc_tab[N].valid = true
+
+static void cc_init (void) {
+ int i;
+ if (is_cc_init)
+ return;
+ for (i = 0; i < CS_MAX; i++)
+ cc_tab[i].valid = false;
+ set_cc (CS_HSTEM, true, 2, true);
+ set_cc (CS_VSTEM, true, 2, true);
+ set_cc (CS_VMOVETO, true, 1, true);
+ set_cc (CS_RLINETO, true, 2, true);
+ set_cc (CS_HLINETO, true, 1, true);
+ set_cc (CS_VLINETO, true, 1, true);
+ set_cc (CS_RRCURVETO, true, 6, true);
+ set_cc (CS_CLOSEPATH, false, 0, true);
+ set_cc (CS_CALLSUBR, false, 1, false);
+ set_cc (CS_RETURN, false, 0, false);
+ /*
+ |set_cc(CS_ESCAPE, false, 0, false);|
+ */
+ set_cc (CS_HSBW, true, 2, true);
+ set_cc (CS_ENDCHAR, false, 0, true);
+ set_cc (CS_RMOVETO, true, 2, true);
+ set_cc (CS_HMOVETO, true, 1, true);
+ set_cc (CS_VHCURVETO, true, 4, true);
+ set_cc (CS_HVCURVETO, true, 4, true);
+ set_cc (CS_DOTSECTION, false, 0, true);
+ set_cc (CS_VSTEM3, true, 6, true);
+ set_cc (CS_HSTEM3, true, 6, true);
+ set_cc (CS_SEAC, true, 5, true);
+ set_cc (CS_SBW, true, 4, true);
+ set_cc (CS_DIV, false, 2, false);
+ set_cc (CS_CALLOTHERSUBR, false, 0, false);
+ set_cc (CS_POP, false, 0, false);
+ set_cc (CS_SETCURRENTPOINT, true, 2, true);
+ is_cc_init = true;
+}
+
+@
+
+@d cs_getchar(mp) cdecrypt(*data++, &cr)
+
+@d mark_subr(mp,n) cs_mark(mp,0, n)
+@d mark_cs(mp,s) cs_mark(mp,s, 0)
+@d SMALL_BUF_SIZE 256
+
+@c
+static void cs_warn (MP mp, const char *cs_name, int subr, const char *fmt, ...) {
+ char buf[SMALL_BUF_SIZE];
+ char s[300];
+ va_list args;
+ va_start (args, fmt);
+ @= /*@@-bufferoverflowhigh@@*/ @>
+ (void)vsprintf (buf, fmt, args);
+ @= /*@@=bufferoverflowhigh@@*/ @>
+ va_end (args);
+ if (cs_name == NULL) {
+ mp_snprintf(s,299,"Subr (%i): %s", (int) subr, buf);
+ } else {
+ mp_snprintf(s,299,"CharString (/%s): %s", cs_name, buf);
+ }
+ mp_warn(mp,s);
+}
+
+static void cs_mark (MP mp, const char *cs_name, int subr)
+{
+ byte *data;
+ int i, b, cs_len;
+ integer a, a1, a2;
+ unsigned short cr;
+ static integer lastargOtherSubr3 = 3; /* the argument of last call to
+ OtherSubrs[3] */
+ cs_entry *ptr;
+ cc_entry *cc;
+ if (cs_name == NULL) {
+ check_subr (subr);
+ ptr = mp->ps->subr_tab + subr;
+ if (!ptr->valid)
+ return;
+ } else {
+ if (mp->ps->cs_notdef != NULL &&
+ (cs_name == notdef || strcmp (cs_name, notdef) == 0))
+ ptr = mp->ps->cs_notdef;
+ else {
+ for (ptr = mp->ps->cs_tab; ptr < mp->ps->cs_ptr; ptr++)
+ if (strcmp (ptr->glyph_name, cs_name) == 0)
+ break;
+ if (ptr == mp->ps->cs_ptr) {
+ char s[128];
+ mp_snprintf (s,128,"glyph `%s' undefined", cs_name);
+ mp_warn(mp,s);
+ return;
+ }
+ if (ptr->glyph_name == notdef)
+ mp->ps->cs_notdef = ptr;
+ }
+ }
+ /* only marked CharString entries and invalid entries can be skipped;
+ valid marked subrs must be parsed to keep the stack in sync */
+ if (!ptr->valid || (ptr->is_used && cs_name != NULL))
+ return;
+ ptr->is_used = true;
+ cr = 4330;
+ cs_len = (int)ptr->cslen;
+ data = ptr->data + 4;
+ for (i = 0; i < mp->ps->t1_lenIV; i++, cs_len--)
+ (void)cs_getchar (mp);
+ while (cs_len > 0) {
+ --cs_len;
+ b = cs_getchar (mp);
+ if (b >= 32) {
+ if (b <= 246)
+ a = b - 139;
+ else if (b <= 250) {
+ --cs_len;
+ a = (int)((unsigned)(b - 247) << 8) + 108 + cs_getchar (mp);
+ } else if (b <= 254) {
+ --cs_len;
+ a = -(int)((unsigned)(b - 251) << 8) - 108 - cs_getchar (mp);
+ } else {
+ cs_len -= 4;
+ a = (cs_getchar (mp) & 0xff) << 24;
+ a |= (cs_getchar (mp) & 0xff) << 16;
+ a |= (cs_getchar (mp) & 0xff) << 8;
+ a |= (cs_getchar (mp) & 0xff) << 0;
+ if (sizeof (integer) > 4 && (a & 0x80000000))
+ a |= ~0x7FFFFFFF;
+ }
+ cc_push (a);
+ } else {
+ if (b == CS_ESCAPE) {
+ b = cs_getchar (mp) + CS_1BYTE_MAX;
+ cs_len--;
+ }
+ if (b >= CS_MAX) {
+ cs_warn (mp,cs_name, subr, "command value out of range: %i",
+ (int) b);
+ goto cs_error;
+ }
+ cc = cc_tab + b;
+ if (!cc->valid) {
+ cs_warn (mp,cs_name, subr, "command not valid: %i", (int) b);
+ goto cs_error;
+ }
+ if (cc->bottom) {
+ if (stack_ptr - cc_stack < cc->nargs)
+ cs_warn (mp,cs_name, subr,
+ "less arguments on stack (%i) than required (%i)",
+ (int) (stack_ptr - cc_stack), (int) cc->nargs);
+ else if (stack_ptr - cc_stack > cc->nargs)
+ cs_warn (mp,cs_name, subr,
+ "more arguments on stack (%i) than required (%i)",
+ (int) (stack_ptr - cc_stack), (int) cc->nargs);
+ }
+ switch (cc - cc_tab) {
+ case CS_CALLSUBR:
+ a1 = (integer)cc_get (-1);
+ cc_pop (1);
+ mark_subr (mp,a1);
+ if (!mp->ps->subr_tab[a1].valid) {
+ cs_warn (mp,cs_name, subr, "cannot call subr (%i)", (int) a1);
+ goto cs_error;
+ }
+ break;
+ case CS_DIV:
+ cc_pop (2);
+ cc_push (0);
+ break;
+ case CS_CALLOTHERSUBR:
+ a1 = (integer)cc_get (-1);
+ if (a1 == 3)
+ lastargOtherSubr3 = (integer)cc_get (-3);
+ a1 = (integer)cc_get (-2) + 2;
+ cc_pop (a1);
+ break;
+ case CS_POP:
+ cc_push (lastargOtherSubr3);
+ /* the only case when we care about the value being pushed onto
+ stack is when POP follows CALLOTHERSUBR (changing hints by
+ OtherSubrs[3])
+ */
+ break;
+ case CS_SEAC:
+ a1 = (integer)cc_get (3);
+ a2 = (integer)cc_get (4);
+ cc_clear ();
+ mark_cs (mp,standard_glyph_names[a1]);
+ mark_cs (mp,standard_glyph_names[a2]);
+ break;
+ default:
+ if (cc->clear)
+ cc_clear ();
+ }
+ }
+ }
+ return;
+ cs_error: /* an error occured during parsing */
+ cc_clear ();
+ ptr->valid = false;
+ ptr->is_used = false;
+}
+
+static void t1_subset_ascii_part (MP mp, font_number tex_font, fm_entry *fm_cur)
+{
+ int i, j;
+ t1_getline (mp);
+ while (!t1_prefix ("/Encoding")) {
+ t1_scan_param (mp,tex_font, fm_cur);
+ /* Patch the initial font directory cacheing mechanism found in some
+ * pfb fonts.
+ *
+ * Even though the T1 spec does not explicitly state that 'FontDirectory'
+ * should appear at the start of a line, luckily this is standard practise.
+ */
+ if (t1_prefix ("FontDirectory")) {
+ char *endloc, *p;
+ char new_line[T1_BUF_SIZE] = {0};
+ p = mp->ps->t1_line_array;
+ while ((endloc = strstr(p,fm_cur->ps_name)) != NULL) {
+ int n = (endloc-mp->ps->t1_line_array) + strlen(fm_cur->subset_tag) + 2 + strlen(fm_cur->ps_name);
+ if (n >= T1_BUF_SIZE) {
+ mp_fatal_error (mp, "t1_subset_ascii_part: buffer overrun detected.");
+ }
+ strncat(new_line,p,(endloc-p));
+ strcat(new_line,fm_cur->subset_tag);
+ strcat(new_line,"-");
+ strcat(new_line,fm_cur->ps_name);
+ p = endloc + strlen(fm_cur->ps_name);
+ }
+ if (strlen(new_line) + strlen(p) + 1 >= T1_BUF_SIZE ) {
+ mp_fatal_error (mp, "t1_subset_ascii_part: buffer overrun detected.");
+ }
+ strcat(new_line, p);
+ strcpy(mp->ps->t1_line_array,new_line);
+ mp->ps->t1_line_ptr = mp->ps->t1_line_array + strlen(mp->ps->t1_line_array);
+ t1_putline (mp);
+ } else {
+ t1_putline (mp);
+ }
+ t1_getline (mp);
+ }
+ t1_builtin_enc (mp);
+ if (is_reencoded (fm_cur))
+ mp->ps->t1_glyph_names = external_enc ();
+ else
+ mp->ps->t1_glyph_names = mp->ps->t1_builtin_glyph_names;
+ if ((!is_subsetted (fm_cur)) && mp->ps->t1_encoding == ENC_STANDARD)
+ t1_puts (mp,"/Encoding StandardEncoding def\n");
+ else {
+ t1_puts
+ (mp,"/Encoding 256 array\n0 1 255 {1 index exch /.notdef put} for\n");
+ for (i = 0, j = 0; i < 256; i++) {
+ if (is_used_char (i) && mp->ps->t1_glyph_names[i] != notdef &&
+ strcmp(mp->ps->t1_glyph_names[i],notdef) != 0) {
+ j++;
+ mp_snprintf (mp->ps->t1_line_array, (int)mp->ps->t1_line_limit,
+ "dup %i /%s put\n", (int) t1_char (i),
+ mp->ps->t1_glyph_names[i]);
+ t1_puts(mp,mp->ps->t1_line_array);
+ }
+ }
+ /* We didn't mark anything for the Encoding array. */
+ /* We add "dup 0 /.notdef put" for compatibility */
+ /* with Acrobat 5.0. */
+ if (j == 0)
+ t1_puts (mp,"dup 0 /.notdef put\n");
+ t1_puts (mp,"readonly def\n");
+ }
+ do {
+ t1_getline (mp);
+ t1_scan_param (mp,tex_font, fm_cur);
+ if (!t1_prefix ("/UniqueID")) /* ignore UniqueID for subsetted fonts */
+ t1_putline (mp);
+ }
+ while (mp->ps->t1_in_eexec == 0);
+}
+
+#define t1_subr_flush(mp) t1_flush_cs(mp,true)
+#define t1_cs_flush(mp) t1_flush_cs(mp,false)
+
+static void cs_init (MP mp) {
+ mp->ps->cs_ptr = mp->ps->cs_tab = NULL;
+ mp->ps->cs_dict_start = mp->ps->cs_dict_end = NULL;
+ mp->ps->cs_count = mp->ps->cs_size = mp->ps->cs_size_pos = 0;
+ mp->ps->cs_token_pair = NULL;
+ mp->ps->subr_tab = NULL;
+ mp->ps->subr_array_start = mp->ps->subr_array_end = NULL;
+ mp->ps->subr_max = mp->ps->subr_size = mp->ps->subr_size_pos = 0;
+}
+
+static void init_cs_entry ( cs_entry * cs) {
+ cs->data = NULL;
+ cs->glyph_name = NULL;
+ cs->len = 0;
+ cs->cslen = 0;
+ cs->is_used = false;
+ cs->valid = false;
+}
+
+static void t1_mark_glyphs (MP mp, font_number tex_font);
+
+static void t1_read_subrs (MP mp, font_number tex_font, fm_entry *fm_cur, int read_only)
+{
+ int i, s;
+ cs_entry *ptr;
+ t1_getline (mp);
+ while (!(t1_charstrings () || t1_subrs ())) {
+ t1_scan_param (mp,tex_font, fm_cur);
+ if (!read_only)
+ t1_putline (mp);
+ t1_getline (mp);
+ }
+ FOUND:
+ mp->ps->t1_cs = true;
+ mp->ps->t1_scan = false;
+ if (!t1_subrs ())
+ return;
+ mp->ps->subr_size_pos = (int)(strlen ("/Subrs") + 1);
+ /* |subr_size_pos| points to the number indicating dict size after "/Subrs" */
+ mp->ps->subr_size = (int)t1_scan_num (mp,mp->ps->t1_line_array + mp->ps->subr_size_pos, 0);
+ if (mp->ps->subr_size == 0) {
+ while (!t1_charstrings ())
+ t1_getline (mp);
+ return;
+ }
+ /* |subr_tab = xtalloc (subr_size, cs_entry);| */
+ mp->ps->subr_tab = (cs_entry *)mp_xmalloc (mp,(size_t)mp->ps->subr_size, sizeof (cs_entry));
+ for (ptr = mp->ps->subr_tab; ptr - mp->ps->subr_tab < mp->ps->subr_size; ptr++)
+ init_cs_entry (ptr);
+ mp->ps->subr_array_start = mp_xstrdup (mp,mp->ps->t1_line_array);
+ t1_getline (mp);
+ while (mp->ps->t1_cslen) {
+ store_subr (mp);
+ t1_getline (mp);
+ }
+ /* mark the first four entries without parsing */
+ for (i = 0; i < mp->ps->subr_size && i < 4; i++)
+ mp->ps->subr_tab[i].is_used = true;
+ /* the end of the Subrs array might have more than one line so we need to
+ concatnate them to |subr_array_end|. Unfortunately some fonts don't have
+ the Subrs array followed by the CharStrings dict immediately (synthetic
+ fonts). If we cannot find CharStrings in next |POST_SUBRS_SCAN| lines then
+ we will treat the font as synthetic and ignore everything until next
+ Subrs is found
+ */
+#define POST_SUBRS_SCAN 5
+ s = 0;
+ *mp->ps->t1_buf_array = 0;
+ for (i = 0; i < POST_SUBRS_SCAN; i++) {
+ if (t1_charstrings ())
+ break;
+ s += (int)(mp->ps->t1_line_ptr - mp->ps->t1_line_array);
+ alloc_array (t1_buf, s, T1_BUF_SIZE);
+ strcat (mp->ps->t1_buf_array, mp->ps->t1_line_array);
+ t1_getline (mp);
+ }
+ mp->ps->subr_array_end = mp_xstrdup (mp,mp->ps->t1_buf_array);
+ if (i == POST_SUBRS_SCAN) { /* CharStrings not found;
+ suppose synthetic font */
+ for (ptr = mp->ps->subr_tab; ptr - mp->ps->subr_tab < mp->ps->subr_size; ptr++)
+ if (ptr->valid)
+ mp_xfree (ptr->data);
+ mp_xfree (mp->ps->subr_tab);
+ mp_xfree (mp->ps->subr_array_start);
+ mp_xfree (mp->ps->subr_array_end);
+ cs_init (mp);
+ mp->ps->t1_cs = false;
+ mp->ps->t1_synthetic = true;
+ while (!(t1_charstrings () || t1_subrs ()))
+ t1_getline (mp);
+ goto FOUND;
+ }
+}
+
+@ @c
+static void t1_flush_cs (MP mp, boolean is_subr)
+{
+ char *p;
+ byte *r, *return_cs = NULL;
+ cs_entry *tab, *end_tab, *ptr;
+ char *start_line, *line_end;
+ int count, size_pos;
+ unsigned short cr, cs_len = 0; /* to avoid warning about uninitialized use of |cs_len| */
+ if (is_subr) {
+ start_line = mp->ps->subr_array_start;
+ line_end = mp->ps->subr_array_end;
+ size_pos = mp->ps->subr_size_pos;
+ tab = mp->ps->subr_tab;
+ count = mp->ps->subr_max + 1;
+ end_tab = mp->ps->subr_tab + count;
+ } else {
+ start_line = mp->ps->cs_dict_start;
+ line_end = mp->ps->cs_dict_end;
+ size_pos = mp->ps->cs_size_pos;
+ tab = mp->ps->cs_tab;
+ end_tab = mp->ps->cs_ptr;
+ count = mp->ps->cs_count;
+ }
+ mp->ps->t1_line_ptr = mp->ps->t1_line_array;
+ for (p = start_line; p - start_line < size_pos;)
+ *mp->ps->t1_line_ptr++ = *p++;
+ while (mp_isdigit (*p))
+ p++;
+ mp_snprintf (mp->ps->t1_line_ptr, (int)mp->ps->t1_line_limit, "%u", (unsigned)count);
+ strcat (mp->ps->t1_line_ptr, p);
+ mp->ps->t1_line_ptr = eol (mp->ps->t1_line_array);
+ t1_putline (mp);
+
+ /* create |return_cs| to replace unsused subr's */
+ if (is_subr) {
+ cr = 4330;
+ cs_len = 0;
+ return_cs = mp_xmalloc (mp, (size_t)(mp->ps->t1_lenIV + 1) , sizeof(byte));
+ if ( mp->ps->t1_lenIV >= 0) {
+ for (cs_len = 0, r = return_cs;
+ cs_len<(unsigned short)mp->ps->t1_lenIV; cs_len++, r++)
+ *r = cencrypt (0x00, &cr);
+ *r = cencrypt (CS_RETURN, &cr);
+ } else {
+ *return_cs = CS_RETURN;
+ }
+ cs_len++;
+ }
+
+ for (ptr = tab; ptr < end_tab; ptr++) {
+ if (ptr->is_used) {
+ if (is_subr)
+ mp_snprintf (mp->ps->t1_line_array, (int)mp->ps->t1_line_limit,
+ "dup %i %u", (int) (ptr - tab), ptr->cslen);
+ else
+ mp_snprintf (mp->ps->t1_line_array, (int)mp->ps->t1_line_limit,
+ "/%s %u", ptr->glyph_name, ptr->cslen);
+ p = strend (mp->ps->t1_line_array);
+ memcpy (p, ptr->data, (size_t)ptr->len);
+ mp->ps->t1_line_ptr = p + ptr->len;
+ t1_putline (mp);
+ } else {
+ /* replace unsused subr's by |return_cs| */
+ if (is_subr) {
+ mp_snprintf (mp->ps->t1_line_array, (int)mp->ps->t1_line_limit,
+ "dup %i %u%s ", (int) (ptr - tab),
+ cs_len, mp->ps->cs_token_pair[0]);
+ p = strend (mp->ps->t1_line_array);
+ memcpy (p, return_cs, (size_t)cs_len);
+ mp->ps->t1_line_ptr = p + cs_len;
+ t1_putline (mp);
+ mp_snprintf (mp->ps->t1_line_array, (int)mp->ps->t1_line_limit,
+ " %s", mp->ps->cs_token_pair[1]);
+ mp->ps->t1_line_ptr = eol (mp->ps->t1_line_array);
+ t1_putline (mp);
+ }
+ }
+ mp_xfree (ptr->data);
+ if (ptr->glyph_name != notdef)
+ mp_xfree (ptr->glyph_name);
+ }
+ mp_snprintf (mp->ps->t1_line_array, (int)mp->ps->t1_line_limit, "%s", line_end);
+ mp->ps->t1_line_ptr = eol (mp->ps->t1_line_array);
+ t1_putline (mp);
+ if (is_subr)
+ mp_xfree (return_cs);
+ mp_xfree (tab);
+ mp_xfree (start_line);
+ mp_xfree (line_end);
+ if (is_subr) {
+ mp->ps->subr_array_start = NULL;
+ mp->ps->subr_array_end = NULL;
+ mp->ps->subr_tab = NULL;
+ } else {
+ mp->ps->cs_dict_start = NULL;
+ mp->ps->cs_dict_end = NULL;
+ mp->ps->cs_tab = NULL;
+ }
+}
+
+static void t1_mark_glyphs (MP mp, font_number tex_font)
+{
+ int i;
+ char *charset = extra_charset ();
+ char *g, *s, *r;
+ cs_entry *ptr;
+ if (mp->ps->t1_synthetic || embed_all_glyphs (tex_font)) { /* mark everything */
+ if (mp->ps->cs_tab != NULL)
+ for (ptr = mp->ps->cs_tab; ptr < mp->ps->cs_ptr; ptr++)
+ if (ptr->valid)
+ ptr->is_used = true;
+ if (mp->ps->subr_tab != NULL) {
+ for (ptr = mp->ps->subr_tab; ptr - mp->ps->subr_tab < mp->ps->subr_size; ptr++)
+ if (ptr->valid)
+ ptr->is_used = true;
+ mp->ps->subr_max = mp->ps->subr_size - 1;
+ }
+ return;
+ }
+ mark_cs (mp,notdef);
+ for (i = 0; i < 256; i++)
+ if (is_used_char (i)) {
+ if (mp->ps->t1_glyph_names[i] == notdef ||
+ strcmp(mp->ps->t1_glyph_names[i],notdef)==0) {
+ char S[128];
+ mp_snprintf(S,128, "character %i is mapped to %s", i, notdef);
+ mp_warn(mp,S);
+ } else
+ mark_cs (mp,mp->ps->t1_glyph_names[i]);
+ }
+ if (charset == NULL)
+ goto SET_SUBR_MAX;
+ g = s = charset + 1; /* skip the first '/' */
+ r = strend (g);
+ while (g < r) {
+ while (*s != '/' && s < r)
+ s++;
+ *s = 0; /* terminate g by rewriting '/' to 0 */
+ mark_cs (mp,g);
+ g = s + 1;
+ }
+ SET_SUBR_MAX:
+ if (mp->ps->subr_tab != NULL)
+ for (mp->ps->subr_max = -1, ptr = mp->ps->subr_tab;
+ ptr - mp->ps->subr_tab < mp->ps->subr_size;
+ ptr++)
+ if (ptr->is_used && ptr - mp->ps->subr_tab > mp->ps->subr_max)
+ mp->ps->subr_max = (int)(ptr - mp->ps->subr_tab);
+}
+
+static void t1_do_subset_charstrings (MP mp, font_number tex_font)
+{
+ cs_entry *ptr;
+ mp->ps->cs_size_pos = (int)(
+ strstr (mp->ps->t1_line_array, charstringname) + strlen (charstringname)
+ - mp->ps->t1_line_array + 1);
+ /* |cs_size_pos| points to the number indicating
+ dict size after "/CharStrings" */
+ mp->ps->cs_size = (int)t1_scan_num (mp,mp->ps->t1_line_array + mp->ps->cs_size_pos, 0);
+ mp->ps->cs_ptr = mp->ps->cs_tab = mp_xmalloc (mp,(size_t)mp->ps->cs_size, sizeof(cs_entry));
+ for (ptr = mp->ps->cs_tab; ptr - mp->ps->cs_tab < mp->ps->cs_size; ptr++)
+ init_cs_entry (ptr);
+ mp->ps->cs_notdef = NULL;
+ mp->ps->cs_dict_start = mp_xstrdup (mp,mp->ps->t1_line_array);
+ t1_getline (mp);
+ while (mp->ps->t1_cslen) {
+ store_cs (mp);
+ t1_getline (mp);
+ }
+ mp->ps->cs_dict_end = mp_xstrdup (mp,mp->ps->t1_line_array);
+ t1_mark_glyphs (mp,tex_font);
+}
+
+static void t1_subset_charstrings (MP mp, font_number tex_font)
+{
+ cs_entry *ptr;
+ t1_do_subset_charstrings (mp, tex_font);
+ if (mp->ps->subr_tab != NULL) {
+ if (mp->ps->cs_token_pair == NULL)
+ mp_fatal_error
+ (mp, "This Type 1 font uses mismatched subroutine begin/end token pairs.");
+ t1_subr_flush (mp);
+ }
+ for (mp->ps->cs_count = 0, ptr = mp->ps->cs_tab; ptr < mp->ps->cs_ptr; ptr++)
+ if (ptr->is_used)
+ mp->ps->cs_count++;
+ t1_cs_flush (mp);
+}
+
+static void t1_subset_end (MP mp)
+{
+ if (mp->ps->t1_synthetic) { /* copy to "dup /FontName get exch definefont pop" */
+ while (!strstr (mp->ps->t1_line_array, "definefont")) {
+ t1_getline (mp);
+ t1_putline (mp);
+ }
+ while (!t1_end_eexec ())
+ t1_getline (mp); /* ignore the rest */
+ t1_putline (mp); /* write "mark currentfile closefile" */
+ } else
+ while (!t1_end_eexec ()) { /* copy to "mark currentfile closefile" */
+ t1_getline (mp);
+ t1_putline (mp);
+ }
+ t1_stop_eexec (mp);
+ if (fixedcontent) { /* copy 512 zeros (not needed for PDF) */
+ while (!t1_cleartomark ()) {
+ t1_getline (mp);
+ t1_putline (mp);
+ }
+ if (!mp->ps->t1_synthetic) /* don't check "{restore}if" for synthetic fonts */
+ t1_check_end (mp); /* write "{restore}if" if found */
+ }
+}
+
+static int t1_updatefm (MP mp, font_number f, fm_entry *fm)
+{
+ char *s, *p;
+ mp->ps->read_encoding_only = true;
+ if (!t1_open_fontfile (mp,fm,NULL)) {
+ return 0;
+ }
+ t1_scan_only (mp,f, fm);
+ s = mp_xstrdup(mp,mp->ps->fontname_buf);
+ p = s;
+ while (*p != ' ' && *p != 0)
+ p++;
+ *p=0;
+ mp_xfree(fm->ps_name);
+ fm->ps_name = s;
+ t1_close_font_file (mp,"");
+ return 1;
+}
+
+
+static void writet1 (MP mp, font_number tex_font, fm_entry *fm_cur) {
+ unsigned save_selector = mp->selector;
+ mp_normalize_selector(mp);
+ mp->ps->read_encoding_only = false;
+ if (!is_included (fm_cur)) { /* scan parameters from font file */
+ if (!t1_open_fontfile (mp,fm_cur,"{"))
+ return;
+ t1_scan_only (mp,tex_font, fm_cur);
+ t1_close_font_file (mp,"}");
+ return;
+ }
+ if (!is_subsetted (fm_cur)) { /* include entire font */
+ if (!t1_open_fontfile (mp,fm_cur,"<<"))
+ return;
+ t1_include (mp,tex_font,fm_cur);
+ t1_close_font_file (mp,">>");
+ return;
+ }
+ /* partial downloading */
+ if (!t1_open_fontfile (mp,fm_cur,"<"))
+ return;
+ t1_subset_ascii_part (mp,tex_font,fm_cur);
+ t1_start_eexec (mp,fm_cur);
+ cc_init ();
+ cs_init (mp);
+ t1_read_subrs (mp,tex_font, fm_cur, false);
+ t1_subset_charstrings (mp,tex_font);
+ t1_subset_end (mp);
+ t1_close_font_file (mp,">");
+ mp->selector = save_selector;
+}
+
+@ @<Declarations@>=
+static void t1_free (MP mp);
+
+@ @c
+static void t1_free (MP mp) {
+ int k;
+
+ mp_xfree (mp->ps->subr_array_start);
+ mp_xfree (mp->ps->subr_array_end);
+ mp_xfree (mp->ps->cs_dict_start);
+ mp_xfree (mp->ps->cs_dict_end);
+ cs_init(mp);
+
+ mp_xfree (mp->ps->t1_line_array);
+ mp_xfree (mp->ps->char_array);
+ mp->ps->char_array=NULL;
+
+ mp->ps->t1_line_array = mp->ps->t1_line_ptr = NULL;
+ mp->ps->t1_line_limit = 0;
+ mp_xfree (mp->ps->t1_buf_array);
+ mp->ps->t1_buf_array = mp->ps->t1_buf_ptr = NULL;
+ mp->ps->t1_buf_limit = 0;
+
+ for (k=0;k<=255;k++) {
+ if (mp->ps->t1_builtin_glyph_names[k] != notdef)
+ mp_xfree(mp->ps->t1_builtin_glyph_names[k]);
+ mp->ps->t1_builtin_glyph_names[k] = notdef;
+ }
+}
+
+@* Embedding Charstrings.
+
+The SVG backend uses some routines that use an ascii representation of
+a type1 font. First, here is the type associated with it:
+
+@<Types ...@>=
+typedef struct mp_ps_font {
+ int font_num; /* just to put something in */
+ char **t1_glyph_names;
+ cs_entry *cs_tab;
+ cs_entry *cs_ptr;
+ cs_entry *subr_tab;
+ int subr_size;
+ int t1_lenIV;
+ int slant;
+ int extend;
+ @<Variables for the charstring parser@>
+} mp_ps_font;
+
+@ The parser creates a structure and fills it.
+
+@c
+
+mp_ps_font *mp_ps_font_parse (MP mp, int tex_font) {
+ mp_ps_font *f;
+ fm_entry *fm_cur;
+ char msg[128];
+ (void)mp_has_fm_entry (mp, (font_number)tex_font, &fm_cur);
+ if (fm_cur == NULL) {
+ mp_snprintf(msg,128,"fontmap entry for `%s' not found", mp->font_name[tex_font]);
+ mp_warn(mp,msg);
+ return NULL;
+ }
+ if (is_truetype(fm_cur) ||
+ (fm_cur->ps_name == NULL && fm_cur->ff_name == NULL) ||
+ (!is_included(fm_cur))) {
+ mp_snprintf(msg,128,"font `%s' cannot be embedded", mp->font_name[tex_font]);
+ mp_warn(mp,msg);
+ return NULL;
+ }
+ if (!t1_open_fontfile (mp,fm_cur,"<")) { /* message handled there */
+ return NULL;
+ }
+ f = mp_xmalloc(mp, 1, sizeof(struct mp_ps_font));
+ f->font_num = tex_font;
+ f->t1_glyph_names = NULL;
+ f->cs_tab = NULL;
+ f->cs_ptr = NULL;
+ f->subr_tab = NULL;
+ f->orig_x = f->orig_y = 0.0;
+ f->slant = (int)fm_cur->slant;
+ f->extend = (int)fm_cur->extend;
+ t1_getline (mp);
+ while (!t1_prefix ("/Encoding")) {
+ t1_scan_param (mp, (font_number)tex_font, fm_cur);
+ t1_getline (mp);
+ }
+ t1_builtin_enc (mp);
+ if (is_reencoded (fm_cur)) {
+ mp_read_enc (mp, fm_cur->encoding);;
+ f->t1_glyph_names = external_enc ();
+ } else {
+ f->t1_glyph_names = mp->ps->t1_builtin_glyph_names;
+ }
+ do {
+ t1_getline (mp);
+ t1_scan_param (mp, (font_number)tex_font, fm_cur);
+ } while (mp->ps->t1_in_eexec == 0);
+
+ /* |t1_start_eexec (mp,fm_cur);| */
+ cc_init ();
+ cs_init (mp);
+ /* the boolean is needed to make sure that |t1_read_subrs|
+ doesn't output stuff */
+ t1_read_subrs (mp, (font_number)tex_font, fm_cur, true);
+ mp->ps->t1_synthetic = true ;
+ t1_do_subset_charstrings (mp, (font_number)tex_font);
+ f->cs_tab = mp->ps->cs_tab;
+ mp->ps->cs_tab = NULL;
+ f->cs_ptr = mp->ps->cs_ptr;
+ mp->ps->cs_ptr = NULL;
+ f->subr_tab = mp->ps->subr_tab;
+ mp->ps->subr_tab = NULL;
+ f->subr_size = mp->ps->subr_size;
+ mp->ps->subr_size = mp->ps->subr_size_pos = 0;
+ f->t1_lenIV = mp->ps->t1_lenIV;
+ t1_close_font_file (mp,">");
+ return f;
+}
+
+@ @<Exported function headers@>=
+mp_ps_font *mp_ps_font_parse (MP mp, int tex_font);
+
+@ Freeing the structure
+
+@c
+void mp_ps_font_free (MP mp, mp_ps_font *f) {
+ cs_entry *ptr;
+ for (ptr = f->cs_tab; ptr < f->cs_ptr; ptr++) {
+ if (ptr->glyph_name != notdef)
+ mp_xfree (ptr->glyph_name);
+ mp_xfree(ptr->data);
+ }
+ mp_xfree(f->cs_tab);
+ f->cs_tab = NULL;
+ for (ptr = f->subr_tab; ptr - f->subr_tab < f->subr_size; ptr++) {
+ if (ptr->glyph_name != notdef)
+ mp_xfree (ptr->glyph_name);
+ mp_xfree(ptr->data);
+ }
+ mp_xfree(f->subr_tab);
+ f->subr_tab = NULL;
+ t1_free(mp);
+ mp_xfree(f);
+}
+
+@ @<Exported function headers@>=
+void mp_ps_font_free (MP mp, mp_ps_font *f);
+
+
+@ Parsing Charstrings.
+
+@<Variables for the charstring parser@>=
+double flex_hint_data[14]; /* store temp. coordinates of flex hints */
+unsigned int flex_hint_index ; /* index for |flex_hint_data| */
+boolean ignore_flex_hint; /* skip hint for flex */
+double cur_x, cur_y; /* current point */
+double orig_x, orig_y; /* origin (for seac) */
+mp_edge_object *h; /* the whole picture */
+mp_graphic_object *p; /* the current subpath in the picture */
+mp_gr_knot pp; /* the last known knot in the subpath */
+
+
+@ @c
+mp_edge_object *mp_ps_do_font_charstring (MP mp, mp_ps_font *f, char *nam) {
+ mp_edge_object *h = NULL;
+ f->h = NULL; f->p = NULL; f->pp = NULL; f->ignore_flex_hint=0; f->flex_hint_index=0 ;/* just in case */
+ f->cur_x = f->cur_y = 0.0;
+ f->orig_x = f->orig_y = 0.0;
+ if (nam==NULL) {
+ mp_warn(mp,"nonexistant glyph requested");
+ return h;
+ }
+ if (cs_parse(mp,f,nam, 0)) {
+ h = f->h;
+ } else {
+ char err[256];
+ mp_snprintf(err,255,"Glyph interpreter failed (missing glyph '%s'?)", nam);
+ mp_warn(mp,err);
+ if (f->h != NULL) {
+ finish_subpath(mp, f);
+ mp_gr_toss_objects(f->h);
+ }
+ }
+ f->h = NULL; f->p = NULL; f->pp = NULL;
+ return h;
+}
+
+mp_edge_object *mp_ps_font_charstring (MP mp, mp_ps_font *f, int c) {
+ char *s = NULL;
+ if (f != NULL && f->t1_glyph_names != NULL && c>=0 && c<256)
+ s = f->t1_glyph_names[c];
+ return mp_ps_do_font_charstring(mp,f,s);
+}
+
+
+
+@ @<Exported function headers@>=
+mp_edge_object *mp_ps_font_charstring (MP mp, mp_ps_font *f, int c);
+mp_edge_object *mp_ps_do_font_charstring (MP mp, mp_ps_font *f, char *n);
+
+
+@
+@<Declarations@>=
+boolean cs_parse (MP mp, mp_ps_font *f, const char *cs_name, int subr);
+
+@
+@c
+static void start_subpath(MP mp, mp_ps_font *f, double dx, double dy)
+{
+ assert(f->pp == NULL);
+ assert(f->p == NULL);
+ f->pp = mp_xmalloc(mp, 1, sizeof (struct mp_gr_knot_data));
+ f->pp->data.types.left_type = mp_explicit;
+ f->pp->data.types.right_type = mp_explicit;
+ f->pp->x_coord = (f->cur_x + dx);
+ f->pp->y_coord = (f->cur_y + dy);
+ f->pp->left_x = f->pp->right_x = f->pp->x_coord;
+ f->pp->left_y = f->pp->right_y = f->pp->y_coord;
+ f->pp->next = NULL;
+ f->cur_x += dx;
+ f->cur_y += dy;
+ f->p = mp_new_graphic_object(mp,mp_fill_code);
+ gr_path_p((mp_fill_object *)f->p) = f->pp;
+}
+
+static void add_line_segment(MP mp, mp_ps_font *f, double dx, double dy)
+{
+ mp_gr_knot n;
+ assert(f->pp != NULL);
+ n = mp_xmalloc(mp,1, sizeof (struct mp_gr_knot_data));
+ n->data.types.left_type = mp_explicit;
+ n->data.types.right_type = mp_explicit;
+ n->next = gr_path_p((mp_fill_object *)f->p); /* loop */
+ n->x_coord = (f->cur_x + dx);
+ n->y_coord = (f->cur_y + dy);
+ n->right_x = n->x_coord;
+ n->right_y = n->y_coord;
+ n->left_x = n->x_coord;
+ n->left_y = n->y_coord;
+ f->pp->next = n;
+ f->pp = n;
+ f->cur_x += dx;
+ f->cur_y += dy;
+}
+
+static void add_curve_segment(MP mp, mp_ps_font *f, double dx1, double dy1, double dx2,
+ double dy2, double dx3, double dy3)
+{
+ mp_gr_knot n;
+ n = mp_xmalloc(mp, 1, sizeof (struct mp_gr_knot_data));
+ n->data.types.left_type = mp_explicit;
+ n->data.types.right_type = mp_explicit;
+ n->next = gr_path_p((mp_fill_object *)f->p); /* loop */
+ n->x_coord = (f->cur_x + dx1 + dx2 + dx3);
+ n->y_coord = (f->cur_y + dy1 + dy2 + dy3);
+ n->right_x = n->x_coord;
+ n->right_y = n->y_coord;
+ n->left_x = (f->cur_x + dx1 + dx2);
+ n->left_y = (f->cur_y + dy1 + dy2);
+ f->pp->right_x = (f->cur_x + dx1);
+ f->pp->right_y = (f->cur_y + dy1);
+ f->pp->next = n;
+ f->pp = n;
+ f->cur_x += dx1 + dx2 + dx3;
+ f->cur_y += dy1 + dy2 + dy3;
+}
+
+static void finish_subpath(MP mp, mp_ps_font *f)
+{
+ if (f->p != NULL) {
+ if (f->h->body == NULL) {
+ f->h->body = f->p;
+ } else {
+ mp_graphic_object *q = f->h->body;
+ while (gr_link(q) != NULL)
+ q = gr_link(q);
+ q->next = f->p;
+ }
+ }
+ if (f->p!=NULL) {
+ mp_gr_knot r, rr;
+ assert(f->pp != NULL);
+ r = gr_path_p((mp_fill_object *)f->p);
+ rr = r;
+ if (r) {
+ if (r == f->pp ) {
+ r->next = r;
+ } else if ( r->x_coord == f->pp->x_coord && r->y_coord == f->pp->y_coord ) {
+ while (rr->next != f->pp)
+ rr = rr->next;
+ rr->next = r;
+ r->left_x = f->pp->left_x;
+ r->left_y = f->pp->left_y;
+ mp_xfree(f->pp);
+ }
+ }
+ }
+ f->p = NULL;
+ f->pp = NULL;
+}
+
+@
+@d cs_no_debug(A) cs_do_debug(mp,f,A,#A)
+@d cs_debug(A)
+
+@<Declarations@>=
+void cs_do_debug (MP mp, mp_ps_font *f, int i, char *s);
+static void finish_subpath(MP mp, mp_ps_font *f);
+static void add_curve_segment(MP mp, mp_ps_font *f, double dx1, double dy1, double dx2,
+ double dy2, double dx3, double dy3);
+static void add_line_segment(MP mp, mp_ps_font *f, double dx, double dy);
+static void start_subpath(MP mp, mp_ps_font *f, double dx, double dy);
+
+@ @c
+void cs_do_debug (MP mp, mp_ps_font *f, int i, char *s) {
+ int n = cc_tab[i].nargs;
+ (void)mp; /* for -Wall */
+ (void)f; /* for -Wall */
+ while (n>0) {
+ fprintf (stdout,"%d ", (int)cc_get((-n)));
+ n--;
+ }
+ fprintf (stdout,"%s\n", s);
+}
+
+boolean cs_parse (MP mp, mp_ps_font *f, const char *cs_name, int subr)
+{
+ byte *data;
+ int i, b, cs_len;
+ integer a, a1, a2;
+ unsigned short cr;
+ static integer lastargOtherSubr3 = 3;
+
+ cs_entry *ptr;
+ cc_entry *cc;
+
+ if (cs_name == NULL) {
+ ptr = f->subr_tab + subr;
+ } else {
+ i = 0;
+ for (ptr = f->cs_tab; ptr < f->cs_ptr; ptr++, i++) {
+ if (strcmp (ptr->glyph_name, cs_name) == 0)
+ break;
+ }
+ ptr = f->cs_tab+i; /* this is the right charstring */
+ }
+ if (ptr==f->cs_ptr)
+ return false;
+ data = ptr->data + 4;
+ cr = 4330;
+ cs_len = (int)ptr->cslen;
+ for (i = 0; i < f->t1_lenIV; i++, cs_len--)
+ (void)cs_getchar (mp);
+
+ while (cs_len > 0) {
+ --cs_len;
+ b = cs_getchar(mp);
+ if (b >= 32) {
+ if (b <= 246)
+ a = b - 139;
+ else if (b <= 250) {
+ --cs_len;
+ a = (int)((unsigned)(b - 247) << 8) + 108 + cs_getchar (mp);
+ } else if (b <= 254) {
+ --cs_len;
+ a = -(int)((unsigned)(b - 251) << 8) - 108 - cs_getchar (mp);
+ } else {
+ cs_len -= 4;
+ a = (cs_getchar (mp) & 0xff) << 24;
+ a |= (cs_getchar (mp) & 0xff) << 16;
+ a |= (cs_getchar (mp) & 0xff) << 8;
+ a |= (cs_getchar (mp) & 0xff) << 0;
+ if (sizeof (integer) > 4 && (a & 0x80000000))
+ a |= ~0x7FFFFFFF;
+ }
+ cc_push (a);
+ } else {
+ if (b == CS_ESCAPE) {
+ b = cs_getchar (mp) + CS_1BYTE_MAX;
+ cs_len--;
+ }
+ if (b >= CS_MAX) {
+ cs_warn (mp,cs_name, subr, "command value out of range: %i",
+ (int) b);
+ goto cs_error;
+ }
+ cc = cc_tab + b;
+ if (!cc->valid) {
+ cs_warn (mp,cs_name, subr, "command not valid: %i", (int) b);
+ goto cs_error;
+ }
+ if (cc->bottom) {
+ if (stack_ptr - cc_stack < cc->nargs)
+ cs_warn (mp,cs_name, subr,
+ "less arguments on stack (%i) than required (%i)",
+ (int) (stack_ptr - cc_stack), (int) cc->nargs);
+ else if (stack_ptr - cc_stack > cc->nargs)
+ cs_warn (mp,cs_name, subr,
+ "more arguments on stack (%i) than required (%i)",
+ (int) (stack_ptr - cc_stack), (int) cc->nargs);
+ }
+ switch (cc - cc_tab) {
+ case CS_CLOSEPATH: /* |- CLOSEPATH |- */
+ cs_debug(CS_CLOSEPATH);
+ finish_subpath(mp, f);
+ cc_clear ();
+ break;
+ case CS_HLINETO: /* |- dx HLINETO |- */
+ cs_debug(CS_HLINETO);
+ add_line_segment(mp,f,cc_get(-1),0);
+ cc_clear ();
+ break;
+ case CS_HVCURVETO: /* |- dx1 dx2 dy2 dy3 HVCURVETO |- */
+ cs_debug(CS_HVCURVETO);
+ add_curve_segment(mp,f,cc_get(-4),0,cc_get(-3),cc_get(-2),0,cc_get(-1));
+ cc_clear ();
+ break;
+ case CS_RLINETO: /* |- dx dy RLINETO |- */
+ cs_debug(CS_RLINETO);
+ add_line_segment(mp,f,cc_get(-2),cc_get(-1));
+ cc_clear ();
+ break;
+ case CS_RRCURVETO: /* |- dx1 dy1 dx2 dy2 dx3 dy3 RRCURVETO |- */
+ cs_debug(CS_RRCURVETO);
+ add_curve_segment(mp,f,cc_get(-6),cc_get(-5),cc_get(-4),cc_get(-3),cc_get(-2),cc_get(-1));
+ cc_clear ();
+ break;
+ case CS_VHCURVETO: /* |- dy1 dx2 dy2 dx3 VHCURVETO |- */
+ cs_debug(CS_VHCURVETO);
+ add_curve_segment(mp,f,0, cc_get(-4),cc_get(-3),cc_get(-2),cc_get(-1),0);
+ cc_clear ();
+ break;
+ case CS_VLINETO: /* |- dy VLINETO |- */
+ cs_debug(CS_VLINETO);
+ add_line_segment(mp,f,0,cc_get(-1));
+ cc_clear ();
+ break;
+ case CS_HMOVETO: /* |- dx HMOVETO |- */
+ cs_debug(CS_HMOVETO);
+ /* treating in-line moves as 'line segments' work better than attempting
+ to split the path up in two separate sections, at least for now. */
+ if (f->pp == NULL) { /* this is the first */
+ start_subpath(mp,f,cc_get(-1),0);
+ } else {
+ add_line_segment(mp,f,cc_get(-1),0);
+ }
+ cc_clear ();
+ break;
+ case CS_RMOVETO: /* |- dx dy RMOVETO |- */
+ cs_debug(CS_RMOVETO);
+ if (f->ignore_flex_hint == 1) {
+ f->flex_hint_data[f->flex_hint_index++] = cc_get(-2);
+ f->flex_hint_data[f->flex_hint_index++] = cc_get(-1);
+ } else {
+ if (f->pp == NULL) { /* this is the first */
+ start_subpath(mp,f,cc_get(-2),cc_get(-1));
+ } else {
+ add_line_segment(mp,f,cc_get(-2),cc_get(-1));
+ }
+ }
+ cc_clear ();
+ break;
+ case CS_VMOVETO: /* |- dy VMOVETO |- */
+ cs_debug(CS_VMOVETO);
+ if (f->pp == NULL) { /* this is the first */
+ start_subpath(mp,f,0,cc_get(-1));
+ } else {
+ add_line_segment(mp,f,0,cc_get(-1));
+ }
+ cc_clear ();
+ break;
+ /* hinting commands */
+ case CS_DOTSECTION: /* |- DOTSECTION |- */
+ cs_debug(CS_DOTSECTION);
+ cc_clear ();
+ break;
+ case CS_HSTEM: /* |- y dy HSTEM |- */
+ cs_debug(CS_HSTEM);
+ cc_clear ();
+ break;
+ case CS_HSTEM3: /* |- y0 dy0 y1 dy1 y2 dy2 HSTEM3 |- */
+ cs_debug(CS_HSTEM3);
+ cc_clear ();
+ break;
+ case CS_VSTEM: /* |- x dx VSTEM |- */
+ cs_debug(CS_VSTEM);
+ cc_clear ();
+ break;
+ case CS_VSTEM3: /* |- x0 dx0 x1 dx1 x2 dx2 VSTEM3 |- */
+ cs_debug(CS_VSTEM3);
+ cc_clear ();
+ break;
+ /* start and close commands */
+ case CS_SEAC: /* |- asb adx ady bchar achar SEAC |- */
+ cs_debug(CS_SEAC);
+ { double adx, ady, asb;
+ asb = cc_get (0);
+ adx = cc_get (1);
+ ady = cc_get (2);
+ a1 = (integer)cc_get (3);
+ a2 = (integer)cc_get (4);
+ cc_clear ();
+ (void)cs_parse(mp,f,standard_glyph_names[a1],0); /* base */
+ f->orig_x += (adx - asb);
+ f->orig_y += ady;
+ (void)cs_parse(mp,f,standard_glyph_names[a2],0);
+ }
+ break;
+ case CS_ENDCHAR: /* |- ENDCHAR |- */
+ cs_debug(CS_ENDCHAR);
+ cc_clear ();
+ return true;
+ break;
+ case CS_HSBW: /* |- sbx wx HSBW |- */
+ cs_debug(CS_HSBW);
+ if (!f->h) {
+ f->h = mp_xmalloc(mp, 1,sizeof(mp_edge_object));
+ f->h->body = NULL; f->h->next = NULL;
+ f->h->parent = mp;
+ f->h->filename = NULL;
+ f->h->minx = f->h->miny = f->h->maxx = f->h->maxy = 0.0;
+ }
+ f->cur_x = cc_get(-2) + f->orig_x;
+ f->cur_y = 0.0 + f->orig_y;
+ f->orig_x = f->cur_x;
+ f->orig_y = f->cur_y;
+ cc_clear ();
+ break;
+ case CS_SBW: /* |- sbx sby wx wy SBW |- */
+ cs_debug(CS_SBW);
+ if (!f->h) {
+ f->h = mp_xmalloc(mp, 1,sizeof(mp_edge_object));
+ f->h->body = NULL; f->h->next = NULL;
+ f->h->parent = mp;
+ f->h->filename = NULL;
+ f->h->minx = f->h->miny = f->h->maxx = f->h->maxy = 0.0;
+ }
+ f->cur_x = cc_get(-4) + f->orig_x;
+ f->cur_y = cc_get(-3) + f->orig_y;
+ f->orig_x = f->cur_x;
+ f->orig_y = f->cur_y;
+ cc_clear ();
+ break;
+ /* arithmetic */
+ case CS_DIV: /* num1 num2 DIV quotient */
+ cs_debug(CS_DIV);
+ { double num,den,res;
+ num = cc_get (-2);
+ den = cc_get (-1);
+ res = num/den;
+ cc_pop (2);
+ cc_push (res);
+ break;
+ }
+ /* subrs */
+ case CS_CALLSUBR: /* subr CALLSUBR - */
+ cs_debug(CS_CALLSUBR);
+ a1 = (integer)cc_get (-1);
+ if (a1==1)
+ f->ignore_flex_hint = 1;
+ if (a1==0) {
+ /*| double first_x,first_y,first_r_x,first_r_y; |*/
+ /*| double join_x,join_y,join_l_x,join_l_y,join_r_x,join_r_y; |*/
+ /*| double last_x,last_y,last_l_x,last_l_y; |*/
+ /*| |// a := glyph "q" of "cmti12";| |*/
+ /*| first_x = 206.0; first_y = -194.0; |*/
+ /*| double ref_x,ref_y ; |*/
+ /*| ref_x = first_x+f->flex_hint_data[0]; |*/
+ /*| ref_y = first_y+f->flex_hint_data[1]; |*/
+ /*| printf("1:(%f, %f) 2:(%f,%f) 3:(%f,%f) 4:(%f,%f) 5:(%f,%f) 6:(%f,%f) 7:(%f,%f)\n", |*/
+ /*| f->flex_hint_data[0],f->flex_hint_data[1], |*/
+ /*| f->flex_hint_data[2],f->flex_hint_data[3], |*/
+ /*| f->flex_hint_data[4],f->flex_hint_data[5], |*/
+ /*| f->flex_hint_data[6],f->flex_hint_data[7], |*/
+ /*| f->flex_hint_data[8],f->flex_hint_data[9], |*/
+ /*| f->flex_hint_data[10],f->flex_hint_data[11], |*/
+ /*| f->flex_hint_data[12],f->flex_hint_data[13]); |*/
+ /*| printf("Reference=(%f,%f)\n",ref_x,ref_y); |*/
+ /*| first_r_x = ref_x + f->flex_hint_data[2]; first_r_y = ref_y + f->flex_hint_data[3]; |*/
+ /*| join_l_x = first_r_x + f->flex_hint_data[4]; join_l_y = first_r_y + f->flex_hint_data[5]; |*/
+ /*| join_x = join_l_x + f->flex_hint_data[6]; join_y = join_l_y + f->flex_hint_data[7]; |*/
+ /*| join_r_x = join_x + f->flex_hint_data[8]; join_r_y = join_y + f->flex_hint_data[9]; |*/
+ /*| last_l_x = join_r_x + f->flex_hint_data[10]; last_l_y = join_r_y + f->flex_hint_data[11]; |*/
+ /*| last_x = last_l_x + f->flex_hint_data[12]; last_y = last_l_y + f->flex_hint_data[13]; |*/
+ /*| printf("(%f,%f) .. (%f,%f) and (%f,%f) .. (%f,%f) .. (%f,%f) and (%f,%f) .. (%f,%f)\n", |*/
+ /*| first_x,first_y,first_r_x,first_r_y, join_l_x,join_l_y, join_x,join_y, join_r_x,join_r_y, |*/
+ /*| last_l_x,last_l_y,last_x,last_y); |*/
+
+ f->ignore_flex_hint = 0;
+ f->flex_hint_index = 0;
+ add_curve_segment(mp,f,f->flex_hint_data[0]+ f->flex_hint_data[2],f->flex_hint_data[1]+ f->flex_hint_data[3],
+ f->flex_hint_data[4],f->flex_hint_data[5],
+ f->flex_hint_data[6],f->flex_hint_data[7]);
+ add_curve_segment(mp,f,f->flex_hint_data[8],f->flex_hint_data[9],
+ f->flex_hint_data[10],f->flex_hint_data[11],
+ f->flex_hint_data[12],f->flex_hint_data[13]);
+ }
+ cc_pop (1);
+ (void)cs_parse(mp,f,NULL,a1);
+ break;
+ case CS_RETURN: /* - RETURN - */
+ cs_debug(CS_RETURN);
+ return true;
+ break;
+ case CS_CALLOTHERSUBR: /* arg1 ... argn n othersubr CALLOTHERSUBR - */
+ cs_debug(CS_CALLOTHERSUBR);
+ a1 = (integer)cc_get (-1);
+ if (a1 == 3)
+ lastargOtherSubr3 = (integer)cc_get (-3);
+ a1 = (integer)cc_get(-2) + 2;
+ cc_pop (a1);
+ break;
+ case CS_POP: /* - POP number */
+ cc_push (lastargOtherSubr3);
+ break;
+ case CS_SETCURRENTPOINT: /* |- x y SETCURRENTPOINT |- */
+ cs_debug(CS_SETCURRENTPOINT) ;
+ /* totally ignoring setcurrentpoint actually works better for most fonts ? */
+ cc_clear ();
+ break;
+ default:
+ if (cc->clear)
+ cc_clear ();
+ }
+ }
+ }
+ return true;
+cs_error: /* an error occured during parsing */
+ cc_clear ();
+ ptr->valid = false;
+ ptr->is_used = false;
+ return false;
+}
+
+@* \[44d] Embedding fonts.
+
+@ The |tfm_num| is officially of type |font_number|, but that
+type does not exist yet at this point in the output order.
+
+@<Types...@>=
+typedef struct {
+ char *tfm_name; /* TFM file name */
+ char *ps_name; /* PostScript name */
+ integer flags; /* font flags */
+ char *ff_name; /* font file name */
+ char *subset_tag; /* pseudoUniqueTag for subsetted font */
+ enc_entry *encoding; /* pointer to corresponding encoding */
+ unsigned int tfm_num; /* number of the TFM refering this entry */
+ unsigned short type; /* font type (T1/TTF/...) */
+ short slant; /* SlantFont */
+ short extend; /* ExtendFont */
+ integer ff_objnum; /* FontFile object number */
+ integer fn_objnum; /* FontName/BaseName object number */
+ integer fd_objnum; /* FontDescriptor object number */
+ char *charset; /* string containing used glyphs */
+ boolean all_glyphs; /* embed all glyphs? */
+ unsigned short links; /* link flags from |tfm_tree| and |ps_tree| */
+ short tfm_avail; /* flags whether a tfm is available */
+ short pid; /* Pid for truetype fonts */
+ short eid; /* Eid for truetype fonts */
+} fm_entry;
+
+
+@
+@<Glob...@>=
+#define FONTNAME_BUF_SIZE 128
+boolean fontfile_found;
+boolean is_otf_font;
+char fontname_buf[FONTNAME_BUF_SIZE];
+
+@
+@d F_INCLUDED 0x01
+@d F_SUBSETTED 0x02
+@d F_TRUETYPE 0x04
+@d F_BASEFONT 0x08
+
+@d set_included(fm) ((fm)->type |= F_INCLUDED)
+@d set_subsetted(fm) ((fm)->type |= F_SUBSETTED)
+@d set_truetype(fm) ((fm)->type |= F_TRUETYPE)
+@d set_basefont(fm) ((fm)->type |= F_BASEFONT)
+
+@d is_included(fm) ((fm)->type & F_INCLUDED)
+@d is_subsetted(fm) ((fm)->type & F_SUBSETTED)
+@d is_truetype(fm) ((fm)->type & F_TRUETYPE)
+@d is_basefont(fm) ((fm)->type & F_BASEFONT)
+@d is_reencoded(fm) ((fm)->encoding != NULL)
+@d is_fontfile(fm) (fm_fontfile(fm) != NULL)
+@d is_t1fontfile(fm) (is_fontfile(fm) && !is_truetype(fm))
+
+@d fm_slant(fm) (fm)->slant
+@d fm_extend(fm) (fm)->extend
+@d fm_fontfile(fm) (fm)->ff_name
+
+@<Declarations@>=
+static boolean mp_font_is_reencoded (MP mp, font_number f);
+static boolean mp_font_is_included (MP mp, font_number f);
+static boolean mp_font_is_subsetted (MP mp, font_number f);
+
+@ @c
+boolean mp_font_is_reencoded (MP mp, font_number f) {
+ fm_entry *fm;
+ if (mp_has_font_size(mp,f) && mp_has_fm_entry (mp, f, &fm)) {
+ if (fm != NULL
+ && (fm->ps_name != NULL)
+ && is_reencoded (fm))
+ return true;
+ }
+ return false;
+}
+boolean mp_font_is_included (MP mp, font_number f) {
+ fm_entry *fm;
+ if (mp_has_font_size(mp,f) && mp_has_fm_entry (mp, f, &fm)) {
+ if (fm != NULL
+ && (fm->ps_name != NULL && fm->ff_name != NULL)
+ && is_included (fm))
+ return true;
+ }
+ return false;
+}
+boolean mp_font_is_subsetted (MP mp, font_number f) {
+ fm_entry *fm;
+ if (mp_has_font_size(mp,f) && mp_has_fm_entry (mp, f,&fm)) {
+ if (fm != NULL
+ && (fm->ps_name != NULL && fm->ff_name != NULL)
+ && is_included (fm) && is_subsetted (fm))
+ return true;
+ }
+ return false;
+}
+
+@ @<Declarations@>=
+static char * mp_fm_encoding_name (MP mp, font_number f);
+static char * mp_fm_font_name (MP mp, font_number f);
+static char * mp_fm_font_subset_name (MP mp, font_number f);
+
+@
+@c char * mp_fm_encoding_name (MP mp, font_number f) {
+ enc_entry *e;
+ fm_entry *fm;
+ if (mp_has_fm_entry (mp, f, &fm)) {
+ if (fm != NULL && (fm->ps_name != NULL)) {
+ if (is_reencoded (fm)) {
+ e = fm->encoding;
+ if (e->enc_name!=NULL)
+ return mp_xstrdup(mp,e->enc_name);
+ } else {
+ return NULL;
+ }
+ }
+ }
+ {
+ char msg[256];
+ mp_snprintf (msg, 256, "fontmap encoding problems for font %s", mp->font_name[f]);
+ mp_error(mp, msg, NULL, true);
+ }
+ return NULL;
+}
+char * mp_fm_font_name (MP mp, font_number f) {
+ fm_entry *fm;
+ if (mp_has_fm_entry (mp, f,&fm)) {
+ if (fm != NULL && (fm->ps_name != NULL)) {
+ if (mp_font_is_included(mp, f) && !mp->font_ps_name_fixed[f]) {
+ /* find the real fontname, and update |ps_name| and |subset_tag| if needed */
+ if (t1_updatefm(mp,f,fm)) {
+ mp->font_ps_name_fixed[f] = true;
+ } else {
+ char msg[256];
+ mp_snprintf (msg, 256, "font loading problems for font %s", mp->font_name[f]);
+ mp_error(mp, msg, NULL, true);
+ }
+ }
+ return mp_xstrdup(mp,fm->ps_name);
+ }
+ }
+ {
+ char msg[256];
+ mp_snprintf (msg, 256, "fontmap name problems for font %s", mp->font_name[f]);
+ mp_error(mp, msg, NULL, true);
+ }
+ return NULL;
+}
+
+static char * mp_fm_font_subset_name (MP mp, font_number f) {
+ fm_entry *fm;
+ if (mp_has_fm_entry (mp, f, &fm)) {
+ if (fm != NULL && (fm->ps_name != NULL)) {
+ if (is_subsetted(fm)) {
+ char *s = mp_xmalloc(mp,strlen(fm->ps_name)+8,1);
+ mp_snprintf(s,(int)strlen(fm->ps_name)+8,"%s-%s",fm->subset_tag,fm->ps_name);
+ return s;
+ } else {
+ return mp_xstrdup(mp,fm->ps_name);
+ }
+ }
+ }
+ {
+ char msg[256];
+ mp_snprintf (msg, 256, "fontmap name problems for font %s", mp->font_name[f]);
+ mp_error(mp, msg, NULL, true);
+ }
+ return NULL;
+}
+
+@ @<Declarations@>=
+static integer mp_fm_font_slant (MP mp, font_number f);
+static integer mp_fm_font_extend (MP mp, font_number f);
+
+@
+@c static integer mp_fm_font_slant (MP mp, font_number f) {
+ fm_entry *fm;
+ if (mp_has_fm_entry (mp, f, &fm)) {
+ if (fm != NULL && (fm->ps_name != NULL)) {
+ return fm->slant;
+ }
+ }
+ return 0;
+}
+static integer mp_fm_font_extend (MP mp, font_number f) {
+ fm_entry *fm;
+ if (mp_has_fm_entry (mp, f, &fm)) {
+ if (fm != NULL && (fm->ps_name != NULL)) {
+ return fm->extend;
+ }
+ }
+ return 0;
+}
+
+@ @<Declarations@>=
+static boolean mp_do_ps_font (MP mp, font_number f);
+
+@ @c static boolean mp_do_ps_font (MP mp, font_number f) {
+ fm_entry *fm_cur;
+ (void)mp_has_fm_entry (mp, f, &fm_cur); /* for side effects */
+ if (fm_cur == NULL)
+ return true;
+ if (is_truetype(fm_cur) ||
+ (fm_cur->ps_name == NULL && fm_cur->ff_name == NULL)) {
+ return false;
+ }
+ if (is_included(fm_cur)) {
+ mp_ps_print_nl(mp,"%%BeginResource: font ");
+ if (is_subsetted(fm_cur)) {
+ mp_ps_print(mp, fm_cur->subset_tag);
+ mp_ps_print_char(mp,'-');
+ }
+ mp_ps_print(mp, fm_cur->ps_name);
+ mp_ps_print_ln(mp);
+ writet1 (mp,f,fm_cur);
+ mp_ps_print_nl(mp,"%%EndResource");
+ mp_ps_print_ln(mp);
+ }
+ return true;
+}
+
+@ Included subset fonts do not need and encoding vector, make
+sure we skip that case.
+
+@<Declarations@>=
+static void mp_list_used_resources (MP mp, int prologues, int procset);
+
+@ @c static void mp_list_used_resources (MP mp, int prologues, int procset) {
+ font_number f; /* fonts used in a text node or as loop counters */
+ int ff; /* a loop counter */
+ int ldf; /* the last \.{DocumentFont} listed (otherwise |null_font|) */
+ boolean firstitem;
+ if ( procset>0 )
+ mp_ps_print_nl(mp, "%%DocumentResources: procset mpost");
+ else
+ mp_ps_print_nl(mp, "%%DocumentResources: procset mpost-minimal");
+ ldf=null_font;
+ firstitem=true;
+ for (f=null_font+1;f<=mp->last_fnum;f++) {
+ if ( (mp_has_font_size(mp,f))&&(mp_font_is_reencoded(mp,f)) ) {
+ for (ff=ldf;ff>=null_font;ff--) {
+ if ( mp_has_font_size(mp,(font_number)ff) )
+ if ( mp_xstrcmp(mp->font_enc_name[f],mp->font_enc_name[ff])==0 )
+ goto FOUND;
+ }
+ if ( mp_font_is_subsetted(mp,f) )
+ goto FOUND;
+ if ( (size_t)mp->ps->ps_offset+1+strlen(mp->font_enc_name[f])>
+ (size_t)mp->max_print_line )
+ mp_ps_print_nl(mp, "%%+ encoding");
+ if ( firstitem ) {
+ firstitem=false;
+ mp_ps_print_nl(mp, "%%+ encoding");
+ }
+ mp_ps_print_char(mp, ' ');
+ mp_ps_dsc_print(mp, "encoding", mp->font_enc_name[f]);
+ ldf=(int)f;
+ }
+ FOUND:
+ ;
+ }
+ ldf=null_font;
+ firstitem=true;
+ for (f=null_font+1;f<=mp->last_fnum;f++) {
+ if ( mp_has_font_size(mp,f) ) {
+ for (ff=ldf;ff>=null_font;ff--) {
+ if ( mp_has_font_size(mp,(font_number)ff) )
+ if ( mp_xstrcmp(mp->font_name[f],mp->font_name[ff])==0 )
+ goto FOUND2;
+ }
+ if ( (size_t)mp->ps->ps_offset+1+strlen(mp->font_ps_name[f])>
+ (size_t)mp->max_print_line )
+ mp_ps_print_nl(mp, "%%+ font");
+ if ( firstitem ) {
+ firstitem=false;
+ mp_ps_print_nl(mp, "%%+ font");
+ }
+ mp_ps_print_char(mp, ' ');
+ if ( (prologues==3)&& (mp_font_is_subsetted(mp,f)) ) {
+ char *s = mp_fm_font_subset_name(mp,f);
+ mp_ps_dsc_print(mp, "font", s);
+ mp_xfree(s);
+ } else {
+ mp_ps_dsc_print(mp, "font", mp->font_ps_name[f]);
+ }
+ ldf=(int)f;
+ }
+ FOUND2:
+ ;
+ }
+ mp_ps_print_ln(mp);
+}
+
+@ @<Declarations@>=
+static void mp_list_supplied_resources (MP mp, int prologues, int procset);
+
+@ @c static void mp_list_supplied_resources (MP mp, int prologues, int procset) {
+ font_number f; /* fonts used in a text node or as loop counters */
+ int ff; /* a loop counter */
+ int ldf; /* the last \.{DocumentFont} listed (otherwise |null_font|) */
+ boolean firstitem;
+ if ( procset>0 )
+ mp_ps_print_nl(mp, "%%DocumentSuppliedResources: procset mpost");
+ else
+ mp_ps_print_nl(mp, "%%DocumentSuppliedResources: procset mpost-minimal");
+ ldf=null_font;
+ firstitem=true;
+ for (f=null_font+1;f<=mp->last_fnum;f++) {
+ if ( (mp_has_font_size(mp,f))&&(mp_font_is_reencoded(mp,f)) ) {
+ for (ff=ldf;ff>= null_font;ff++) {
+ if ( mp_has_font_size(mp,(font_number)ff) )
+ if ( mp_xstrcmp(mp->font_enc_name[f],mp->font_enc_name[ff])==0 )
+ goto FOUND;
+ }
+ if ( (prologues==3)&&(mp_font_is_subsetted(mp,f)))
+ goto FOUND;
+ if ( (size_t)mp->ps->ps_offset+1+strlen(mp->font_enc_name[f])>(size_t)mp->max_print_line )
+ mp_ps_print_nl(mp, "%%+ encoding");
+ if ( firstitem ) {
+ firstitem=false;
+ mp_ps_print_nl(mp, "%%+ encoding");
+ }
+ mp_ps_print_char(mp, ' ');
+ mp_ps_dsc_print(mp, "encoding", mp->font_enc_name[f]);
+ ldf=(int)f;
+ }
+ FOUND:
+ ;
+ }
+ ldf=null_font;
+ firstitem=true;
+ if (prologues==3) {
+ for (f=null_font+1;f<=mp->last_fnum;f++) {
+ if ( mp_has_font_size(mp,f) ) {
+ for (ff=ldf;ff>= null_font;ff--) {
+ if ( mp_has_font_size(mp,(font_number)ff) )
+ if ( mp_xstrcmp(mp->font_name[f],mp->font_name[ff])==0 )
+ goto FOUND2;
+ }
+ if ( ! mp_font_is_included(mp,f) )
+ goto FOUND2;
+ if ( (size_t)mp->ps->ps_offset+1+strlen(mp->font_ps_name[f])>(size_t)mp->max_print_line )
+ mp_ps_print_nl(mp, "%%+ font");
+ if ( firstitem ) {
+ firstitem=false;
+ mp_ps_print_nl(mp, "%%+ font");
+ }
+ mp_ps_print_char(mp, ' ');
+ if ( mp_font_is_subsetted(mp,f) ) {
+ char *s = mp_fm_font_subset_name(mp,f);
+ mp_ps_dsc_print(mp, "font", s);
+ mp_xfree(s);
+ } else {
+ mp_ps_dsc_print(mp, "font", mp->font_ps_name[f]);
+ }
+ ldf=(int)f;
+ }
+ FOUND2:
+ ;
+ }
+ mp_ps_print_ln(mp);
+ }
+}
+
+@ @<Declarations...@>=
+static void mp_list_needed_resources (MP mp, int prologues);
+
+@ @c static void mp_list_needed_resources (MP mp, int prologues) {
+ font_number f; /* fonts used in a text node or as loop counters */
+ int ff; /* a loop counter */
+ int ldf; /* the last \.{DocumentFont} listed (otherwise |null_font|) */
+ boolean firstitem;
+ ldf=null_font;
+ firstitem=true;
+ for (f=null_font+1;f<=mp->last_fnum;f++ ) {
+ if ( mp_has_font_size(mp,f)) {
+ for (ff=ldf;ff>=null_font;ff--) {
+ if ( mp_has_font_size(mp,(font_number)ff) )
+ if ( mp_xstrcmp(mp->font_name[f],mp->font_name[ff])==0 )
+ goto FOUND;
+ };
+ if ((prologues==3)&&(mp_font_is_included(mp,f)) )
+ goto FOUND;
+ if ( (size_t)mp->ps->ps_offset+1+strlen(mp->font_ps_name[f])>(size_t)mp->max_print_line )
+ mp_ps_print_nl(mp, "%%+ font");
+ if ( firstitem ) {
+ firstitem=false;
+ mp_ps_print_nl(mp, "%%DocumentNeededResources: font");
+ }
+ mp_ps_print_char(mp, ' ');
+ mp_ps_dsc_print(mp, "font", mp->font_ps_name[f]);
+ ldf=(int)f;
+ }
+ FOUND:
+ ;
+ }
+ if ( ! firstitem ) {
+ mp_ps_print_ln(mp);
+ ldf=null_font;
+ /* clang: never read: firstitem=true; */
+ for (f=null_font+1;f<= mp->last_fnum;f++) {
+ if ( mp_has_font_size(mp,f) ) {
+ for (ff=ldf;ff>=null_font;ff-- ) {
+ if ( mp_has_font_size(mp,(font_number)ff) )
+ if ( mp_xstrcmp(mp->font_name[f],mp->font_name[ff])==0 )
+ goto FOUND2;
+ }
+ if ((prologues==3)&&(mp_font_is_included(mp,f)) )
+ goto FOUND2;
+ mp_ps_print(mp, "%%IncludeResource: font ");
+ mp_ps_print(mp, mp->font_ps_name[f]);
+ mp_ps_print_ln(mp);
+ ldf=(int)f;
+ }
+ FOUND2:
+ ;
+ }
+ }
+}
+
+@ @<Declarations@>=
+static void mp_write_font_definition (MP mp, font_number f, int prologues);
+
+@
+
+@d applied_reencoding(A) ((mp_font_is_reencoded(mp,(A)))&&
+ ((! mp_font_is_subsetted(mp,(A)))||(prologues==2)))
+
+@c static void mp_write_font_definition(MP mp, font_number f, int prologues) {
+ if ( (applied_reencoding(f))||(mp_fm_font_slant(mp,f)!=0)||
+ (mp_fm_font_extend(mp,f)!=0)||
+ (mp_xstrcmp(mp->font_name[f],"psyrgo")==0)||
+ (mp_xstrcmp(mp->font_name[f],"zpzdr-reversed")==0) ) {
+ if ( (mp_font_is_subsetted(mp,f))&&
+ (mp_font_is_included(mp,f))&&(prologues==3)) {
+ char *s = mp_fm_font_subset_name(mp,f);
+ mp_ps_name_out(mp, s,true);
+ mp_xfree(s);
+ } else {
+ mp_ps_name_out(mp, mp->font_ps_name[f],true);
+ }
+ mp_ps_print(mp, " fcp");
+ mp_ps_print_ln(mp);
+ if ( applied_reencoding(f) ) {
+ mp_ps_print(mp, "/Encoding ");
+ mp_ps_print(mp, mp->font_enc_name[f]);
+ mp_ps_print(mp, " def ");
+ };
+ if ( mp_fm_font_slant(mp,f)!=0 ) {
+ mp_ps_print_int(mp, mp_fm_font_slant(mp,f));
+ mp_ps_print(mp, " SlantFont ");
+ };
+ if ( mp_fm_font_extend(mp,f)!=0 ) {
+ mp_ps_print_int(mp, mp_fm_font_extend(mp,f));
+ mp_ps_print(mp, " ExtendFont ");
+ };
+ if ( mp_xstrcmp(mp->font_name[f],"psyrgo")==0 ) {
+ mp_ps_print(mp, " 890 ScaleFont ");
+ mp_ps_print(mp, " 277 SlantFont ");
+ };
+ if ( mp_xstrcmp(mp->font_name[f],"zpzdr-reversed")==0 ) {
+ mp_ps_print(mp, " FontMatrix [-1 0 0 1 0 0] matrix concatmatrix /FontMatrix exch def ");
+ mp_ps_print(mp, "/Metrics 2 dict dup begin ");
+ mp_ps_print(mp, "/space[0 -278]def ");
+ mp_ps_print(mp, "/a12[-904 -939]def ");
+ mp_ps_print(mp, "end def ");
+ };
+ mp_ps_print(mp, "currentdict end");
+ mp_ps_print_ln(mp);
+ mp_ps_print_defined_name(mp,f,prologues);
+ mp_ps_print(mp, " exch definefont pop");
+ mp_ps_print_ln(mp);
+ }
+}
+
+@ @<Declarations@>=
+static void mp_ps_print_defined_name (MP mp, font_number f, int prologues);
+
+@
+@c static void mp_ps_print_defined_name(MP mp, font_number f, int prologues) {
+ mp_ps_print(mp, " /");
+ if ((mp_font_is_subsetted(mp,f))&&
+ (mp_font_is_included(mp,f))&&(prologues==3)) {
+ char *s = mp_fm_font_subset_name(mp,f);
+ mp_ps_print(mp, s);
+ mp_xfree(s);
+ } else {
+ mp_ps_print(mp, mp->font_ps_name[f]);
+ }
+ if ( mp_xstrcmp(mp->font_name[f],"psyrgo")==0 )
+ mp_ps_print(mp, "-Slanted");
+ if ( mp_xstrcmp(mp->font_name[f],"zpzdr-reversed")==0 )
+ mp_ps_print(mp, "-Reverse");
+ if ( applied_reencoding(f) ) {
+ mp_ps_print(mp, "-");
+ mp_ps_print(mp, mp->font_enc_name[f]);
+ }
+ if ( mp_fm_font_slant(mp,f)!=0 ) {
+ mp_ps_print(mp, "-Slant_"); mp_ps_print_int(mp, mp_fm_font_slant(mp,f)) ;
+ }
+ if ( mp_fm_font_extend(mp,f)!=0 ) {
+ mp_ps_print(mp, "-Extend_"); mp_ps_print_int(mp, mp_fm_font_extend(mp,f));
+ }
+}
+
+@ @<Include encodings and fonts for edge structure~|h|@>=
+mp_font_encodings(mp,mp->last_fnum,(prologues==2));
+@<Embed fonts that are available@>
+
+@ @<Embed fonts that are available@>=
+{
+next_size=0;
+@<Make |cur_fsize| a copy of the |font_sizes| array@>;
+do {
+ done_fonts=true;
+ for (f=null_font+1;f<=mp->last_fnum;f++) {
+ if ( cur_fsize[f]!=null ) {
+ if (prologues==3 ) {
+ if ( ! mp_do_ps_font(mp,f) ) {
+ if ( mp_has_fm_entry(mp,f, NULL) ) {
+ mp_error(mp, "Font embedding failed", NULL, true);
+ }
+ }
+ }
+ if (cur_fsize[f]==mp_void)
+ cur_fsize[f]=null;
+ else
+ cur_fsize[f]=mp_link(cur_fsize[f]);
+ if ( cur_fsize[f]!=null ) { mp_unmark_font(mp, f); done_fonts=false; }
+ }
+ }
+ if ( ! done_fonts )
+ @<Increment |next_size| and apply |mark_string_chars| to all text nodes with
+ that size index@>;
+} while (! done_fonts);
+}
+
+@ @<Increment |next_size| and apply |mark_string_chars| to all text nodes...@>=
+{
+ next_size++;
+ mp_apply_mark_string_chars(mp, h, next_size);
+}
+
+@ We also need to keep track of which characters are used in text nodes
+in the edge structure that is being shipped out. This is done by procedures
+that use the left-over |b3| field in the |char_info| words; i.e.,
+|char_info(f)(c).b3| gives the status of character |c| in font |f|.
+
+@<Types...@>=
+enum mp_char_mark_state {mp_unused=0, mp_used};
+
+@ @<Declarations@>=
+static void mp_mark_string_chars (MP mp,font_number f, char *s, size_t l) ;
+
+@ @c
+void mp_mark_string_chars (MP mp,font_number f, char *s, size_t l) {
+ integer b; /* |char_base[f]| */
+ int bc,ec; /* only characters between these bounds are marked */
+ unsigned char *k; /* an index into string |s| */
+ b=mp->char_base[f];
+ bc=(int)mp->font_bc[f];
+ ec=(int)mp->font_ec[f];
+ k=(unsigned char *)s;
+ while (l-->0){
+ if ( (*k>=bc)&&(*k<=ec) )
+ mp->font_info[b+*k].qqqq.b3=mp_used;
+ k++;
+ }
+}
+
+
+@ @<Declarations@>=
+static void mp_unmark_font (MP mp,font_number f) ;
+
+@ @c
+void mp_unmark_font (MP mp,font_number f) {
+ int k; /* an index into |font_info| */
+ for (k= mp->char_base[f]+mp->font_bc[f];
+ k<=mp->char_base[f]+mp->font_ec[f];
+ k++)
+ mp->font_info[k].qqqq.b3=mp_unused;
+}
+
+
+@ @<Declarations@>=
+static void mp_print_improved_prologue (MP mp, mp_edge_object *h, int p1, int procset) ;
+
+@ @c
+void mp_print_improved_prologue (MP mp, mp_edge_object *h, int prologues, int procset) {
+ quarterword next_size; /* the size index for fonts being listed */
+ mp_node *cur_fsize; /* current positions in |font_sizes| */
+ boolean done_fonts; /* have we finished listing the fonts in the header? */
+ font_number f; /* a font number for loops */
+ cur_fsize = mp_xmalloc(mp,(size_t)(mp->font_max+1),sizeof(mp_node));
+ mp_list_used_resources(mp, prologues, procset);
+ mp_list_supplied_resources(mp, prologues, procset);
+ mp_list_needed_resources(mp, prologues);
+ mp_ps_print_nl(mp, "%%EndComments");
+ mp_ps_print_nl(mp, "%%BeginProlog");
+ if ( procset>0 )
+ mp_ps_print_nl(mp, "%%BeginResource: procset mpost");
+ else
+ mp_ps_print_nl(mp, "%%BeginResource: procset mpost-minimal");
+ mp_ps_print_nl(mp, "/bd{bind def}bind def"
+ "/fshow {exch findfont exch scalefont setfont show}bd");
+ if ( procset>0 ) @<Print the procset@>;
+ mp_ps_print_nl(mp, "/fcp{findfont dup length dict begin"
+ "{1 index/FID ne{def}{pop pop}ifelse}forall}bd");
+ mp_ps_print_nl(mp, "/fmc{FontMatrix dup length array copy dup dup}bd"
+ "/fmd{/FontMatrix exch def}bd");
+ mp_ps_print_nl(mp, "/Amul{4 -1 roll exch mul 1000 div}bd"
+ "/ExtendFont{fmc 0 get Amul 0 exch put fmd}bd");
+ mp_ps_print_nl(mp, "/ScaleFont{dup fmc 0 get"
+ " Amul 0 exch put dup dup 3 get Amul 3 exch put fmd}bd");
+ mp_ps_print_nl(mp, "/SlantFont{fmc 2 get dup 0 eq{pop 1}if"
+ " Amul FontMatrix 0 get mul 2 exch put fmd}bd");
+ mp_ps_print_nl(mp, "%%EndResource");
+ @<Include encodings and fonts for edge structure~|h|@>;
+ mp_ps_print_nl(mp, "%%EndProlog");
+ mp_ps_print_nl(mp, "%%BeginSetup");
+ mp_ps_print_ln(mp);
+ for (f=null_font+1;f<=mp->last_fnum;f++) {
+ if ( mp_has_font_size(mp,f) ) {
+ if ( mp_has_fm_entry(mp,f,NULL) ) {
+ mp_write_font_definition(mp,f, prologues);
+ mp_ps_name_out(mp, mp->font_name[f],true);
+ mp_ps_print_defined_name(mp,f, prologues);
+ mp_ps_print(mp, " def");
+ } else {
+ char s[256];
+ mp_snprintf(s,256,"font %s cannot be found in any fontmapfile!", mp->font_name[f]);
+ mp_warn(mp,s);
+ mp_ps_name_out(mp, mp->font_name[f],true);
+ mp_ps_name_out(mp, mp->font_name[f],true);
+ mp_ps_print(mp, " def");
+ }
+ mp_ps_print_ln(mp);
+ }
+ }
+ mp_ps_print_nl(mp, "%%EndSetup");
+ mp_ps_print_nl(mp, "%%Page: 1 1");
+ mp_ps_print_ln(mp);
+ mp_xfree(cur_fsize);
+}
+
+@ @<Declarations@>=
+static font_number mp_print_font_comments (MP mp , mp_edge_object *h, int prologues);
+
+
+@
+@c
+static font_number mp_print_font_comments (MP mp , mp_edge_object *h, int prologues) {
+ quarterword next_size; /* the size index for fonts being listed */
+ mp_node *cur_fsize; /* current positions in |font_sizes| */
+ int ff; /* a loop counter */
+ boolean done_fonts; /* have we finished listing the fonts in the header? */
+ font_number f; /* a font number for loops */
+ int ds; /* design size and scale factor for a text node, scaled */
+ int ldf=0; /* the last \.{DocumentFont} listed (otherwise |null_font|) */
+ cur_fsize = mp_xmalloc(mp,(size_t)(mp->font_max+1),sizeof(mp_node));
+ if ( prologues>0 ) {
+ @<Give a \.{DocumentFonts} comment listing all fonts with non-null
+ |font_sizes| and eliminate duplicates@>;
+ } else {
+ next_size=0;
+ @<Make |cur_fsize| a copy of the |font_sizes| array@>;
+ do { done_fonts=true;
+ for (f=null_font+1;f<=mp->last_fnum;f++) {
+ if ( cur_fsize[f]!=null ) {
+ @<Print the \.{\%*Font} comment for font |f| and advance |cur_fsize[f]|@>;
+ }
+ if ( cur_fsize[f]!=null ) { mp_unmark_font(mp, f); done_fonts=false; };
+ }
+ if ( ! done_fonts ) {
+ @<Increment |next_size| and apply |mark_string_chars| to all text nodes with
+ that size index@>;
+ }
+ } while (! done_fonts);
+ }
+ mp_xfree(cur_fsize);
+ return (font_number)ldf;
+}
+
+@ @<Make |cur_fsize| a copy of the |font_sizes| array@>=
+for (f=null_font+1;f<= mp->last_fnum;f++)
+ cur_fsize[f]=mp->font_sizes[f]
+
+@ It's not a good idea to make any assumptions about the |font_ps_name| entries,
+so we carefully remove duplicates. There is no harm in using a slow, brute-force
+search.
+
+@<Give a \.{DocumentFonts} comment listing all fonts with non-null...@>=
+{
+ ldf=null_font;
+ for (f=null_font+1;f<= mp->last_fnum;f++) {
+ if ( mp->font_sizes[f]!=null ) {
+ if ( ldf==null_font )
+ mp_ps_print_nl(mp, "%%DocumentFonts:");
+ for (ff=ldf;ff>=null_font;ff--) {
+ if ( mp->font_sizes[ff]!=null )
+ if ( mp_xstrcmp(mp->font_ps_name[f],mp->font_ps_name[ff])==0 )
+ goto FOUND;
+ }
+ if ( (size_t)mp->ps->ps_offset+1+strlen(mp->font_ps_name[f])>(size_t)mp->max_print_line )
+ mp_ps_print_nl(mp, "%%+");
+ mp_ps_print_char(mp, ' ');
+ mp_ps_print(mp, mp->font_ps_name[f]);
+ ldf=(int)f;
+ FOUND:
+ ;
+ }
+ }
+}
+
+@ @c
+static void mp_hex_digit_out (MP mp,quarterword d) {
+ if ( d<10 ) mp_ps_print_char(mp, d+'0');
+ else mp_ps_print_char(mp, d+'a'-10);
+}
+
+@ We output the marks as a hexadecimal bit string starting at
+|font_bc[f]|.
+
+@<Declarations@>=
+static halfword mp_ps_marks_out (MP mp,font_number f);
+
+@
+
+@c
+static halfword mp_ps_marks_out (MP mp,font_number f) {
+ eight_bits bc,ec; /* only encode characters between these bounds */
+ int p; /* |font_info| index for the current character */
+ int d; /* used to construct a hexadecimal digit */
+ unsigned b; /* used to construct a hexadecimal digit */
+ bc=mp->font_bc[f];
+ ec=mp->font_ec[f];
+ @<Restrict the range |bc..ec| so that it contains no unused characters
+ at either end@>;
+ @<Print the initial label indicating that the bitmap starts at |bc|@>;
+ @<Print a hexadecimal encoding of the marks for characters |bc..ec|@>;
+ while ( (ec<mp->font_ec[f])&&(mp->font_info[p].qqqq.b3==mp_unused) ) {
+ p++; ec++;
+ }
+ return (ec+1);
+}
+
+@ We could save time by setting the return value before the loop that
+decrements |ec|, but there is no point in being so tricky.
+
+@<Restrict the range |bc..ec| so that it contains no unused characters...@>=
+p=mp->char_base[f]+bc;
+while ( (mp->font_info[p].qqqq.b3==mp_unused)&&(bc<ec) ) {
+ p++; bc++;
+}
+p=mp->char_base[f]+ec;
+while ( (mp->font_info[p].qqqq.b3==mp_unused)&&(bc<ec) ) {
+ p--; ec--;
+}
+
+@ @<Print the initial label indicating that the bitmap starts at |bc|@>=
+mp_ps_print_char(mp, ' ');
+mp_hex_digit_out(mp, (quarterword)(bc / 16));
+mp_hex_digit_out(mp, (quarterword)(bc % 16));
+mp_ps_print_char(mp, ':')
+
+@
+
+@<Print a hexadecimal encoding of the marks for characters |bc..ec|@>=
+b=8; d=0;
+for (p=mp->char_base[f]+bc;p<=mp->char_base[f]+ec;p++) {
+ if ( b==0 ) {
+ mp_hex_digit_out(mp, (quarterword)d);
+ d=0; b=8;
+ }
+ if ( mp->font_info[p].qqqq.b3!=mp_unused )
+ d+=(int)b;
+ b=b>>1;
+}
+mp_hex_digit_out(mp, (quarterword)d)
+
+
+@ Here is a simple function that determines whether there are any marked
+characters in font~|f|.
+
+@<Declarations@>=
+static boolean mp_check_ps_marks (MP mp,font_number f) ;
+
+@ @c
+static boolean mp_check_ps_marks (MP mp,font_number f) {
+ int p; /* |font_info| index for the current character */
+ for (p=mp->char_base[f];p<=mp->char_base[f]+mp->font_ec[f];p++) {
+ if ( mp->font_info[p].qqqq.b3==mp_used )
+ return true;
+ }
+ return false;
+}
+
+
+@ There used to be a check against |emergency_line_length| here, because
+it was believed that processing programs might not know how to deal with
+long lines. Nowadays (1.204), we trust backends to do the right thing.
+
+@d mp_link(A) (A)->link /* the |link| field of a memory word */
+@d sc_factor(A) ((mp_font_size_node)(A))->sc_factor_ /* the scale factor stored in a font size node */
+
+@<Print the \.{\%*Font} comment for font |f| and advance |cur_fsize[f]|@>=
+{
+ if ( mp_check_ps_marks(mp, f ) ) {
+ double dds;
+ mp_ps_print_nl(mp, "%*Font: ");
+ mp_ps_print(mp, mp->font_name[f]);
+ mp_ps_print_char(mp, ' ');
+ ds=(mp->font_dsize[f] + 8) / 16.0;
+ dds = (double)ds / 65536.0;
+ mp_ps_print_double(mp, mp_take_double(mp, dds, sc_factor(cur_fsize[f])));
+ mp_ps_print_char(mp, ' ');
+ mp_ps_print_double(mp, dds);
+ mp_ps_marks_out(mp, f );
+ }
+ cur_fsize[f]=mp_link(cur_fsize[f]);
+}
+
+@ @<Print the procset@>=
+{
+ mp_ps_print_nl(mp, "/hlw{0 dtransform exch truncate exch idtransform pop setlinewidth}bd");
+ mp_ps_print_nl(mp, "/vlw{0 exch dtransform truncate idtransform setlinewidth pop}bd");
+ mp_ps_print_nl(mp, "/l{lineto}bd/r{rlineto}bd/c{curveto}bd/m{moveto}bd"
+ "/p{closepath}bd/n{newpath}bd");
+ mp_ps_print_nl(mp, "/C{setcmykcolor}bd/G{setgray}bd/R{setrgbcolor}bd"
+ "/lj{setlinejoin}bd/ml{setmiterlimit}bd");
+ mp_ps_print_nl(mp, "/lc{setlinecap}bd/S{stroke}bd/F{fill}bd/q{gsave}bd"
+ "/Q{grestore}bd/s{scale}bd/t{concat}bd");
+ mp_ps_print_nl(mp, "/sd{setdash}bd/rd{[] 0 setdash}bd/P{showpage}bd/B{q F Q}bd/W{clip}bd");
+}
+
+
+@ The prologue defines \.{fshow} and corrects for the fact that \.{fshow}
+arguments use |font_name| instead of |font_ps_name|. Downloaded bitmap fonts
+might not have reasonable |font_ps_name| entries, but we just charge ahead
+anyway. The user should not make \&{prologues} positive if this will cause
+trouble.
+@:prologues_}{\&{prologues} primitive@>
+
+@<Declarations@>=
+static void mp_print_prologue (MP mp, mp_edge_object *h, int prologues, int procset);
+
+@ @c
+void mp_print_prologue (MP mp, mp_edge_object *h, int prologues, int procset) {
+ font_number f;
+ font_number ldf ;
+ ldf = mp_print_font_comments (mp, h, prologues);
+ mp_ps_print_ln(mp);
+ if ( (prologues==1) && (mp->last_ps_fnum==0) )
+ mp_read_psname_table(mp);
+ mp_ps_print(mp, "%%BeginProlog"); mp_ps_print_ln(mp);
+ if ( (prologues>0)||(procset>0) ) {
+ if ( ldf!=null_font ) {
+ if ( prologues>0 ) {
+ for (f=null_font+1;f<=mp->last_fnum;f++) {
+ if ( mp_has_font_size(mp,f) ) {
+ mp_ps_name_out(mp, mp->font_name[f],true);
+ mp_ps_name_out(mp, mp->font_ps_name[f],true);
+ mp_ps_print(mp, " def");
+ mp_ps_print_ln(mp);
+ }
+ }
+ if ( procset==0 ) {
+ mp_ps_print(mp, "/fshow {exch findfont exch scalefont setfont show}bind def");
+ mp_ps_print_ln(mp);
+ }
+ }
+ }
+ if (procset>0 ) {
+ mp_ps_print_nl(mp, "%%BeginResource: procset mpost");
+ if ( (prologues>0)&&(ldf!=null_font) )
+ mp_ps_print_nl(mp,
+ "/bd{bind def}bind def/fshow {exch findfont exch scalefont setfont show}bd");
+ else
+ mp_ps_print_nl(mp, "/bd{bind def}bind def");
+ @<Print the procset@>;
+ mp_ps_print_nl(mp, "%%EndResource");
+ mp_ps_print_ln(mp);
+ }
+ }
+ mp_ps_print(mp, "%%EndProlog");
+ mp_ps_print_nl(mp, "%%Page: 1 1"); mp_ps_print_ln(mp);
+}
+
+@ \MP\ used to have one single routine to print to both `write' files
+and the PostScript output. Web2c redefines ``Character |k| cannot be
+printed'', and that resulted in some bugs where 8-bit characters were
+written to the PostScript file (reported by Wlodek Bzyl).
+
+Also, Hans Hagen requested spaces to be output as "\\040" instead of
+a plain space, since that makes it easier to parse the result file
+for postprocessing.
+
+@<Character |k| is not allowed in PostScript output@>=
+ (k<=' ')||(k>'~')
+
+@ We often need to print a pair of coordinates.
+
+@c
+void mp_ps_pair_out (MP mp, double x, double y) {
+ ps_room(26);
+ mp_ps_print_double(mp, x); mp_ps_print_char(mp, ' ');
+ mp_ps_print_double(mp, y); mp_ps_print_char(mp, ' ');
+}
+
+@ @<Declarations@>=
+static void mp_ps_pair_out (MP mp, double x, double y) ;
+
+@ @c
+void mp_ps_print_cmd (MP mp, const char *l, const char *s) {
+ if ( number_positive (internal_value(mp_procset))) { ps_room(strlen(s)); mp_ps_print(mp,s); }
+ else { ps_room(strlen(l)); mp_ps_print(mp, l); };
+}
+
+@ @<Declarations@>=
+static void mp_ps_print_cmd (MP mp, const char *l, const char *s) ;
+
+@ @c
+void mp_ps_string_out (MP mp, const char *s, size_t l) {
+ ASCII_code k; /* bits to be converted to octal */
+ mp_ps_print(mp, "(");
+ while (l-->0) {
+ k=(ASCII_code)*s++;
+ if ( mp->ps->ps_offset+5>mp->max_print_line ) {
+ mp_ps_print_char(mp, '\\');
+ mp_ps_print_ln(mp);
+ }
+ if ( (@<Character |k| is not allowed in PostScript output@>) ) {
+ mp_ps_print_char(mp, '\\');
+ mp_ps_print_char(mp, '0'+(k / 64));
+ mp_ps_print_char(mp, '0'+((k / 8) % 8));
+ mp_ps_print_char(mp, '0'+(k % 8));
+ } else {
+ if ( (k=='(')||(k==')')||(k=='\\') )
+ mp_ps_print_char(mp, '\\');
+ mp_ps_print_char(mp, k);
+ }
+ }
+ mp_ps_print_char(mp, ')');
+}
+
+@ @<Declarations@>=
+static void mp_ps_string_out (MP mp, const char *s, size_t l) ;
+
+@ This is a define because the function does not use its |mp| argument.
+
+@d mp_is_ps_name(M,A) mp_do_is_ps_name(A)
+
+@c
+static boolean mp_do_is_ps_name (char *s) {
+ ASCII_code k; /* the character being checked */
+ while ((k=(ASCII_code)*s++)) {
+ if ( (k<=' ')||(k>'~') ) return false;
+ if ( (k=='(')||(k==')')||(k=='<')||(k=='>')||
+ (k=='{')||(k=='}')||(k=='/')||(k=='%') ) return false;
+ }
+ return true;
+}
+
+@ @<Declarations@>=
+static void mp_ps_name_out (MP mp, char *s, boolean lit) ;
+
+@ @c
+void mp_ps_name_out (MP mp, char *s, boolean lit) {
+ ps_room(strlen(s)+2);
+ mp_ps_print_char(mp, ' ');
+ if ( mp_is_ps_name(mp, s) ) {
+ if ( lit ) mp_ps_print_char(mp, '/');
+ mp_ps_print(mp, s);
+ } else {
+ mp_ps_string_out(mp, s, strlen(s));
+ if ( ! lit ) mp_ps_print(mp, "cvx ");
+ mp_ps_print(mp, "cvn");
+ }
+}
+
+
+@ These special comments described in the {\sl PostScript Language Reference
+Manual}, 2nd.~edition are understood by some \ps-reading programs.
+We can't normally output ``conforming'' \ps\ because
+the structuring conventions don't allow us to say ``Please make sure the
+following characters are downloaded and define the \.{fshow} macro to access
+them.''
+
+The exact bounding box is written out if |mp_prologues<0|, although this
+is not standard \ps, since it allows \TeX\ to calculate the box dimensions
+accurately. (Overfull boxes are avoided if an illustration is made to
+match a given \.{\char`\\hsize}.)
+
+@<Declarations@>=
+static void mp_print_initial_comment(MP mp,mp_edge_object *hh, int prologues);
+
+@ @c
+void mp_print_initial_comment(MP mp,mp_edge_object *hh, int prologues) {
+ int t; /* scaled */
+ char *s;
+ mp_ps_print(mp, "%!PS");
+ if ( prologues>0 )
+ mp_ps_print(mp, "-Adobe-3.0 EPSF-3.0");
+ mp_ps_print_nl(mp, "%%BoundingBox: ");
+ if ( hh->minx>hh->maxx) {
+ mp_ps_print(mp, "0 0 0 0");
+ } else if ( prologues<0 ) {
+ mp_ps_pair_out(mp, hh->minx,hh->miny);
+ mp_ps_pair_out(mp, hh->maxx,hh->maxy);
+ } else {
+ mp_ps_pair_out(mp, floor(hh->minx),floor(hh->miny));
+ mp_ps_pair_out(mp, -floor(-hh->maxx),-floor(-hh->maxy));
+ }
+ mp_ps_print_nl(mp, "%%HiResBoundingBox: ");
+ if ( hh->minx>hh->maxx ) {
+ mp_ps_print(mp, "0 0 0 0");
+ } else {
+ mp_ps_pair_out(mp, hh->minx,hh->miny);
+ mp_ps_pair_out(mp, hh->maxx,hh->maxy);
+ }
+ mp_ps_print_nl(mp, "%%Creator: MetaPost ");
+ s = mp_metapost_version();
+ mp_ps_print(mp, s);
+ mp_xfree(s);
+ mp_ps_print_nl(mp, "%%CreationDate: ");
+ mp_ps_print_int(mp, round_unscaled(internal_value(mp_year)));
+ mp_ps_print_char(mp, '.');
+ mp_ps_print_dd(mp, round_unscaled(internal_value(mp_month)));
+ mp_ps_print_char(mp, '.');
+ mp_ps_print_dd(mp, round_unscaled(internal_value(mp_day)));
+ mp_ps_print_char(mp, ':');
+ t = round_unscaled(internal_value(mp_time));
+ mp_ps_print_dd(mp, t / 60);
+ mp_ps_print_dd(mp, t % 60);
+ mp_ps_print_nl(mp, "%%Pages: 1");
+}
+
+@ The most important output procedure is the one that gives the \ps\ version of
+a \MP\ path.
+
+@(mplibps.h@>=
+#ifndef MPLIBPS_H
+#define MPLIBPS_H 1
+#include "mplib.h"
+@<Internal Postscript header information@>
+#endif
+
+
+@ @<Types...@>=
+#define gr_left_type(A) (A)->data.types.left_type
+#define gr_right_type(A) (A)->data.types.right_type
+#define gr_x_coord(A) (A)->x_coord
+#define gr_y_coord(A) (A)->y_coord
+#define gr_left_x(A) (A)->left_x
+#define gr_left_y(A) (A)->left_y
+#define gr_right_x(A) (A)->right_x
+#define gr_right_y(A) (A)->right_y
+#define gr_next_knot(A) (A)->next
+#define gr_originator(A) (A)->originator
+
+@ If we want to duplicate a knot node, we can say |copy_knot|:
+
+@c
+static mp_gr_knot mp_gr_copy_knot (MP mp, mp_gr_knot p) {
+ mp_gr_knot q; /* the copy */
+ q = mp_xmalloc(mp, 1, sizeof (struct mp_gr_knot_data));
+ memcpy(q,p,sizeof (struct mp_gr_knot_data));
+ gr_next_knot(q)=NULL;
+ return q;
+}
+
+@ The |copy_path| routine makes a clone of a given path.
+
+@c
+static mp_gr_knot mp_gr_copy_path (MP mp, mp_gr_knot p) {
+ mp_gr_knot q, pp, qq; /* for list manipulation */
+ if (p==NULL)
+ return NULL;
+ q=mp_gr_copy_knot(mp, p);
+ qq=q;
+ pp=gr_next_knot(p);
+ while ( pp!=p ) {
+ gr_next_knot(qq)=mp_gr_copy_knot(mp, pp);
+ qq=gr_next_knot(qq);
+ pp=gr_next_knot(pp);
+ }
+ gr_next_knot(qq)=q;
+ return q;
+}
+
+@ When a cyclic list of knot nodes is no longer needed, it can be recycled by
+calling the following subroutine.
+
+@<Declarations@>=
+void mp_do_gr_toss_knot_list (mp_gr_knot p) ;
+
+@
+@d mp_gr_toss_knot_list(B,A) mp_do_gr_toss_knot_list(A)
+
+@c
+void mp_do_gr_toss_knot_list (mp_gr_knot p) {
+ mp_gr_knot q; /* the node being freed */
+ mp_gr_knot r; /* the next node */
+ if (p==NULL)
+ return;
+ q=p;
+ do {
+ r=gr_next_knot(q);
+ mp_xfree(q); q=r;
+ } while (q!=p);
+}
+
+
+
+@ @c
+static void mp_gr_ps_path_out (MP mp, mp_gr_knot h) {
+ mp_gr_knot p, q; /* for scanning the path */
+ double d; /* a temporary value */
+ boolean curved; /* |true| unless the cubic is almost straight */
+ ps_room(40);
+ mp_ps_print_cmd(mp, "newpath ","n ");
+ mp_ps_pair_out(mp, gr_x_coord(h),gr_y_coord(h));
+ mp_ps_print_cmd(mp, "moveto","m");
+ p=h;
+ do {
+ if ( gr_right_type(p)==mp_endpoint ) {
+ if ( p==h ) mp_ps_print_cmd(mp, " 0 0 rlineto"," 0 0 r");
+ return;
+ }
+ q=gr_next_knot(p);
+ @<Start a new line and print the \ps\ commands for the curve from
+ |p| to~|q|@>;
+ p=q;
+ } while (p!=h);
+ mp_ps_print_cmd(mp, " closepath"," p");
+}
+
+@ @<Start a new line and print the \ps\ commands for the curve from...@>=
+curved=true;
+@<Set |curved:=false| if the cubic from |p| to |q| is almost straight@>;
+mp_ps_print_ln(mp);
+if ( curved ){
+ mp_ps_pair_out(mp, gr_right_x(p),gr_right_y(p));
+ mp_ps_pair_out(mp, gr_left_x(q),gr_left_y(q));
+ mp_ps_pair_out(mp, gr_x_coord(q),gr_y_coord(q));
+ mp_ps_print_cmd(mp, "curveto","c");
+} else if ( q!=h ){
+ mp_ps_pair_out(mp, gr_x_coord(q),gr_y_coord(q));
+ mp_ps_print_cmd(mp, "lineto","l");
+}
+
+@ Two types of straight lines come up often in \MP\ paths:
+cubics with zero initial and final velocity as created by |make_path| or
+|make_envelope|, and cubics with control points uniformly spaced on a line
+as created by |make_choices|.
+
+@d bend_tolerance (131/65536.0) /* allow rounding error of $2\cdot10^{-3}$ */
+
+@<Set |curved:=false| if the cubic from |p| to |q| is almost straight@>=
+if ( gr_right_x(p)==gr_x_coord(p) )
+ if ( gr_right_y(p)==gr_y_coord(p) )
+ if ( gr_left_x(q)==gr_x_coord(q) )
+ if ( gr_left_y(q)==gr_y_coord(q) ) curved=false;
+d=gr_left_x(q)-gr_right_x(p);
+if ( fabs(gr_right_x(p)-gr_x_coord(p)-d)<=bend_tolerance )
+ if ( fabs(gr_x_coord(q)-gr_left_x(q)-d)<=bend_tolerance )
+ { d=gr_left_y(q)-gr_right_y(p);
+ if ( fabs(gr_right_y(p)-gr_y_coord(p)-d)<=bend_tolerance )
+ if ( fabs(gr_y_coord(q)-gr_left_y(q)-d)<=bend_tolerance ) curved=false;
+ }
+
+@ The colored objects use a struct with anonymous fields to express the color parts:
+
+@<Internal Postscript header information@>=
+typedef struct {
+ double a_val, b_val, c_val, d_val;
+} mp_color;
+
+@ The exported form of a dash pattern is simpler than the internal
+format, it is closely modelled to the PostScript model. The array of
+dashes is ended by a single negative value, because this is not
+allowed in PostScript.
+
+@<Internal Postscript header information@>=
+typedef struct {
+ double offset;
+ double *array;
+} mp_dash_object ;
+
+
+@
+@d mp_gr_toss_dashes(A,B) mp_do_gr_toss_dashes(B)
+
+@<Declarations@>=
+static void mp_do_gr_toss_dashes(mp_dash_object *dl);
+
+@ @c
+void mp_do_gr_toss_dashes(mp_dash_object *dl) {
+ if (dl==NULL)
+ return;
+ mp_xfree(dl->array);
+ mp_xfree(dl);
+}
+
+
+@ @c
+static mp_dash_object *mp_gr_copy_dashes(MP mp, mp_dash_object *dl) {
+ mp_dash_object *q = NULL;
+ (void)mp;
+ if (dl==NULL)
+ return NULL;
+ q = mp_xmalloc(mp, 1, sizeof (mp_dash_object));
+ memcpy (q,dl,sizeof(mp_dash_object));
+ if (dl->array != NULL) {
+ size_t i = 0;
+ while (*(dl->array+i) != -1) i++;
+ q->array = mp_xmalloc(mp, i, sizeof (double));
+ memcpy(q->array,dl->array, (i*sizeof(double)));
+ }
+ return q;
+}
+
+
+@ Now for outputting the actual graphic objects. First, set up some
+structures and access macros.
+
+@d gr_has_color(A) (gr_type((A))<mp_start_clip_code)
+
+@<Types...@>=
+#define gr_type(A) (A)->type
+#define gr_link(A) (A)->next
+#define gr_color_model(A) (A)->color_model
+#define gr_red_val(A) (A)->color.a_val
+#define gr_green_val(A) (A)->color.b_val
+#define gr_blue_val(A) (A)->color.c_val
+#define gr_cyan_val(A) (A)->color.a_val
+#define gr_magenta_val(A) (A)->color.b_val
+#define gr_yellow_val(A) (A)->color.c_val
+#define gr_black_val(A) (A)->color.d_val
+#define gr_grey_val(A) (A)->color.a_val
+#define gr_path_p(A) (A)->path_p
+#define gr_htap_p(A) ((mp_fill_object *)A)->htap_p
+#define gr_pen_p(A) (A)->pen_p
+#define gr_ljoin_val(A) (A)->ljoin
+#define gr_lcap_val(A) ((mp_stroked_object *)A)->lcap
+#define gr_miterlim_val(A) (A)->miterlim
+#define gr_pre_script(A) (A)->pre_script
+#define gr_post_script(A) (A)->post_script
+#define gr_dash_p(A) ((mp_stroked_object *)A)->dash_p
+#define gr_size_index(A) ((mp_text_object *)A)->size_index
+#define gr_text_p(A) ((mp_text_object *)A)->text_p
+#define gr_text_l(A) ((mp_text_object *)A)->text_l
+#define gr_font_n(A) ((mp_text_object *)A)->font_n
+#define gr_font_name(A) ((mp_text_object *)A)->font_name
+#define gr_font_dsize(A) ((mp_text_object *)A)->font_dsize
+#define gr_width_val(A) ((mp_text_object *)A)->width
+#define gr_height_val(A) ((mp_text_object *)A)->height
+#define gr_depth_val(A) ((mp_text_object *)A)->depth
+#define gr_tx_val(A) ((mp_text_object *)A)->tx
+#define gr_ty_val(A) ((mp_text_object *)A)->ty
+#define gr_txx_val(A) ((mp_text_object *)A)->txx
+#define gr_txy_val(A) ((mp_text_object *)A)->txy
+#define gr_tyx_val(A) ((mp_text_object *)A)->tyx
+#define gr_tyy_val(A) ((mp_text_object *)A)->tyy
+
+@ @<Internal Postscript header information@>=
+#define GRAPHIC_BODY \
+ int type; \
+ struct mp_graphic_object * next
+
+typedef struct mp_graphic_object {
+ GRAPHIC_BODY;
+} mp_graphic_object;
+
+typedef struct mp_text_object {
+ GRAPHIC_BODY;
+ char *pre_script;
+ char *post_script;
+ mp_color color;
+ unsigned char color_model;
+ unsigned char size_index;
+ char *text_p;
+ size_t text_l;
+ char *font_name ;
+ double font_dsize ;
+ unsigned int font_n ;
+ double width ;
+ double height ;
+ double depth ;
+ double tx ;
+ double ty ;
+ double txx ;
+ double txy ;
+ double tyx ;
+ double tyy ;
+} mp_text_object;
+
+typedef struct mp_fill_object {
+ GRAPHIC_BODY;
+ char *pre_script;
+ char *post_script;
+ mp_color color;
+ unsigned char color_model;
+ unsigned char ljoin ;
+ mp_gr_knot path_p;
+ mp_gr_knot htap_p;
+ mp_gr_knot pen_p;
+ double miterlim ;
+} mp_fill_object;
+
+typedef struct mp_stroked_object {
+ GRAPHIC_BODY;
+ char *pre_script;
+ char *post_script;
+ mp_color color;
+ unsigned char color_model;
+ unsigned char ljoin ;
+ unsigned char lcap ;
+ mp_gr_knot path_p;
+ mp_gr_knot pen_p;
+ double miterlim ;
+ mp_dash_object *dash_p;
+} mp_stroked_object;
+
+typedef struct mp_clip_object {
+ GRAPHIC_BODY;
+ mp_gr_knot path_p;
+} mp_clip_object;
+
+typedef struct mp_bounds_object {
+ GRAPHIC_BODY;
+ mp_gr_knot path_p;
+} mp_bounds_object;
+
+typedef struct mp_special_object {
+ GRAPHIC_BODY;
+ char *pre_script;
+} mp_special_object ;
+
+typedef struct mp_edge_object {
+ struct mp_graphic_object * body;
+ struct mp_edge_object * next;
+ char * filename;
+ MP parent;
+ double minx, miny, maxx, maxy;
+ double width, height, depth, ital_corr;
+ int charcode;
+} mp_edge_object;
+
+@ @<Exported function headers@>=
+mp_graphic_object *mp_new_graphic_object(MP mp, int type);
+
+@ @c
+mp_graphic_object *mp_new_graphic_object (MP mp, int type) {
+ mp_graphic_object *p;
+ size_t size ;
+ switch (type) {
+ case mp_fill_code: size = sizeof(mp_fill_object); break;
+ case mp_stroked_code: size = sizeof(mp_stroked_object); break;
+ case mp_text_code: size = sizeof(mp_text_object); break;
+ case mp_start_clip_code: size = sizeof(mp_clip_object); break;
+ case mp_start_bounds_code: size = sizeof(mp_bounds_object); break;
+ case mp_special_code: size = sizeof(mp_special_object); break;
+ default: size = sizeof(mp_graphic_object); break;
+ }
+ p = (mp_graphic_object *)mp_xmalloc(mp,1,size);
+ memset(p,0,size);
+ gr_type(p) = type;
+ return p;
+}
+
+@ We need to keep track of several parameters from the \ps\ graphics state.
+@^graphics state@>
+This allows us to be sure that \ps\ has the correct values when they are
+needed without wasting time and space setting them unnecessarily.
+
+@d gs_red mp->ps->gs_state->red_field
+@d gs_green mp->ps->gs_state->green_field
+@d gs_blue mp->ps->gs_state->blue_field
+@d gs_black mp->ps->gs_state->black_field
+@d gs_colormodel mp->ps->gs_state->colormodel_field
+@d gs_ljoin mp->ps->gs_state->ljoin_field
+@d gs_lcap mp->ps->gs_state->lcap_field
+@d gs_adj_wx mp->ps->gs_state->adj_wx_field
+@d gs_miterlim mp->ps->gs_state->miterlim_field
+@d gs_dash_p mp->ps->gs_state->dash_p_field
+@d gs_dash_init_done mp->ps->gs_state->dash_done_field
+@d gs_previous mp->ps->gs_state->previous_field
+@d gs_width mp->ps->gs_state->width_field
+
+@<Types...@>=
+typedef struct _gs_state {
+ double red_field ;
+ double green_field ;
+ double blue_field ;
+ double black_field ;
+ /* color from the last \&{setcmykcolor} or \&{setrgbcolor} or \&{setgray} command */
+ quarterword colormodel_field ;
+ /* the current colormodel */
+ quarterword ljoin_field ;
+ quarterword lcap_field ;
+ /* values from the last \&{setlinejoin} and \&{setlinecap} commands */
+ quarterword adj_wx_field ;
+ /* what resolution-dependent adjustment applies to the width */
+ double miterlim_field ;
+ /* the value from the last \&{setmiterlimit} command */
+ mp_dash_object * dash_p_field ;
+ /* edge structure for last \&{setdash} command */
+ boolean dash_done_field ; /* to test for initial \&{setdash} */
+ struct _gs_state * previous_field ;
+ /* backlink to the previous |_gs_state| structure */
+ double width_field ;
+ /* width setting or $-1$ if no \&{setlinewidth} command so far */
+} _gs_state;
+
+
+@ @<Glob...@>=
+struct _gs_state * gs_state;
+
+@ @<Set init...@>=
+mp->ps->gs_state=NULL;
+
+@ @<Dealloc variables@>=
+mp_xfree(mp->ps->gs_state);
+
+@ To avoid making undue assumptions about the initial graphics state, these
+parameters are given special values that are guaranteed not to match anything
+in the edge structure being shipped out. On the other hand, the initial color
+should be black so that the translation of an all-black picture will have no
+\&{setcolor} commands. (These would be undesirable in a font application.)
+Hence we use |c=0| when initializing the graphics state and we use |c<0|
+to recover from a situation where we have lost track of the graphics state.
+
+@d mp_void (mp_node)(null+1) /* a null pointer different from |null| */
+
+@c static void mp_gs_unknown_graphics_state (MP mp, int c) {
+ struct _gs_state *p; /* to shift graphic states around */
+ if ( (c==0)||(c==-1) ) {
+ if ( mp->ps->gs_state==NULL ) {
+ mp->ps->gs_state = mp_xmalloc(mp,1,sizeof(struct _gs_state));
+ gs_previous=NULL;
+ } else {
+ while ( gs_previous!=NULL ) {
+ p = gs_previous;
+ mp_xfree(mp->ps->gs_state);
+ mp->ps->gs_state=p;
+ }
+ }
+ gs_red=c; gs_green=c; gs_blue=c; gs_black=c;
+ gs_colormodel=mp_uninitialized_model;
+ gs_ljoin=3;
+ gs_lcap=3;
+ gs_miterlim=0.0;
+ gs_dash_p=NULL;
+ gs_dash_init_done=false;
+ gs_width=-1.0;
+ } else if ( c==1 ) {
+ p= mp->ps->gs_state;
+ mp->ps->gs_state = mp_xmalloc(mp,1,sizeof(struct _gs_state));
+ memcpy(mp->ps->gs_state,p,sizeof(struct _gs_state));
+ gs_previous = p;
+ } else if ( c==2 ) {
+ p = gs_previous;
+ mp_xfree(mp->ps->gs_state);
+ mp->ps->gs_state=p;
+ }
+}
+
+
+@ When it is time to output a graphical object, |fix_graphics_state| ensures
+that \ps's idea of the graphics state agrees with what is stored in the object.
+
+@<Declarations@>=
+static void mp_gr_fix_graphics_state (MP mp, mp_graphic_object *p) ;
+
+@ @c
+void mp_gr_fix_graphics_state (MP mp, mp_graphic_object *p) {
+ /* get ready to output graphical object |p| */
+ mp_gr_knot pp, path_p; /* for list manipulation */
+ mp_dash_object *hh;
+ double wx,wy,ww; /* dimensions of pen bounding box */
+ quarterword adj_wx; /* whether pixel rounding should be based on |wx| or |wy| */
+ double tx,ty; /* temporaries for computing |adj_wx| */
+ if ( gr_has_color(p) )
+ @<Make sure \ps\ will use the right color for object~|p|@>;
+ if ( (gr_type(p)==mp_fill_code)||(gr_type(p)==mp_stroked_code) ) {
+ if (gr_type(p)==mp_fill_code) {
+ pp = gr_pen_p((mp_fill_object *)p);
+ path_p = gr_path_p((mp_fill_object *)p);
+ } else {
+ pp = gr_pen_p((mp_stroked_object *)p);
+ path_p = gr_path_p((mp_stroked_object *)p);
+ }
+ if ( pp!=NULL )
+ if ( pen_is_elliptical(pp) ) {
+ @<Generate \ps\ code that sets the stroke width to the
+ appropriate rounded value@>;
+ @<Make sure \ps\ will use the right dash pattern for |dash_p(p)|@>;
+ @<Decide whether the line cap parameter matters and set it if necessary@>;
+ @<Set the other numeric parameters as needed for object~|p|@>;
+ }
+ }
+ if ( mp->ps->ps_offset>0 ) mp_ps_print_ln(mp);
+}
+
+@ @<Decide whether the line cap parameter matters and set it if necessary@>=
+if ( gr_type(p)==mp_stroked_code ) {
+ mp_stroked_object *ts = (mp_stroked_object *)p;
+ if ( (gr_left_type(gr_path_p(ts))==mp_endpoint)||(gr_dash_p(ts)!=NULL) )
+ if ( gs_lcap!=(quarterword)gr_lcap_val(ts) ) {
+ ps_room(13);
+ mp_ps_print_char(mp, ' ');
+ mp_ps_print_char(mp, '0'+gr_lcap_val(ts));
+ mp_ps_print_cmd(mp, " setlinecap"," lc");
+ gs_lcap=(quarterword)gr_lcap_val(ts);
+ }
+}
+
+@
+@d set_ljoin_miterlim(p)
+ if ( gs_ljoin!=(quarterword)gr_ljoin_val(p) ) {
+ ps_room(14);
+ mp_ps_print_char(mp, ' ');
+ mp_ps_print_char(mp, '0'+gr_ljoin_val(p));
+ mp_ps_print_cmd(mp, " setlinejoin"," lj");
+ gs_ljoin=(quarterword)gr_ljoin_val(p);
+ }
+ if ( gs_miterlim!=gr_miterlim_val(p) ) {
+ ps_room(27);
+ mp_ps_print_char(mp, ' ');
+ mp_ps_print_double(mp, gr_miterlim_val(p));
+ mp_ps_print_cmd(mp, " setmiterlimit"," ml");
+ gs_miterlim=gr_miterlim_val(p);
+ }
+
+@<Set the other numeric parameters as needed for object~|p|@>=
+if ( gr_type(p)==mp_stroked_code ) {
+ mp_stroked_object *ts = (mp_stroked_object *)p;
+ set_ljoin_miterlim(ts);
+} else {
+ mp_fill_object *ts = (mp_fill_object *)p;
+ set_ljoin_miterlim(ts);
+}
+
+@
+@d set_color_objects(pq)
+ object_color_model = pq->color_model;
+ object_color_a = pq->color.a_val;
+ object_color_b = pq->color.b_val;
+ object_color_c = pq->color.c_val;
+ object_color_d = pq->color.d_val;
+
+@<Make sure \ps\ will use the right color for object~|p|@>=
+{
+ int object_color_model;
+ double object_color_a, object_color_b, object_color_c, object_color_d ;
+ if (gr_type(p) == mp_fill_code) {
+ mp_fill_object *pq = (mp_fill_object *)p;
+ set_color_objects(pq);
+ } else if (gr_type(p) == mp_stroked_code) {
+ mp_stroked_object *pq = (mp_stroked_object *)p;
+ set_color_objects(pq);
+ } else {
+ mp_text_object *pq = (mp_text_object *)p;
+ set_color_objects(pq);
+ }
+
+ if ( object_color_model==mp_rgb_model) {
+ if ( (gs_colormodel!=mp_rgb_model)||(gs_red!=object_color_a)||
+ (gs_green!=object_color_b)||(gs_blue!=object_color_c) ) {
+ gs_red = object_color_a;
+ gs_green = object_color_b;
+ gs_blue = object_color_c;
+ gs_black = -1.0;
+ gs_colormodel=mp_rgb_model;
+ { ps_room(36);
+ mp_ps_print_char(mp, ' ');
+ mp_ps_print_double(mp, gs_red); mp_ps_print_char(mp, ' ');
+ mp_ps_print_double(mp, gs_green); mp_ps_print_char(mp, ' ');
+ mp_ps_print_double(mp, gs_blue);
+ mp_ps_print_cmd(mp, " setrgbcolor", " R");
+ }
+ }
+ } else if ( object_color_model==mp_cmyk_model) {
+ if ( (gs_red!=object_color_a)||(gs_green!=object_color_b)||
+ (gs_blue!=object_color_c)||(gs_black!=object_color_d)||
+ (gs_colormodel!=mp_cmyk_model) ) {
+ gs_red = object_color_a;
+ gs_green = object_color_b;
+ gs_blue = object_color_c;
+ gs_black = object_color_d;
+ gs_colormodel=mp_cmyk_model;
+ { ps_room(45);
+ mp_ps_print_char(mp, ' ');
+ mp_ps_print_double(mp, gs_red);
+ mp_ps_print_char(mp, ' ');
+ mp_ps_print_double(mp, gs_green);
+ mp_ps_print_char(mp, ' ');
+ mp_ps_print_double(mp, gs_blue);
+ mp_ps_print_char(mp, ' ');
+ mp_ps_print_double(mp, gs_black);
+ mp_ps_print_cmd(mp, " setcmykcolor"," C");
+ }
+ }
+ } else if ( object_color_model==mp_grey_model ) {
+ if ( (gs_red!=object_color_a)||(gs_colormodel!=mp_grey_model) ) {
+ gs_red = object_color_a;
+ gs_green = -1.0;
+ gs_blue = -1.0;
+ gs_black = -1.0;
+ gs_colormodel=mp_grey_model;
+ { ps_room(16);
+ mp_ps_print_char(mp, ' ');
+ mp_ps_print_double(mp, gs_red);
+ mp_ps_print_cmd(mp, " setgray"," G");
+ }
+ }
+ } else if ( object_color_model==mp_no_model ) {
+ gs_colormodel=mp_no_model;
+ }
+}
+
+@ In order to get consistent widths for horizontal and vertical pen strokes, we
+want \ps\ to use an integer number of pixels for the \&{setwidth} parameter.
+@:setwidth}{\&{setwidth}command@>
+We set |gs_width| to the ideal horizontal or vertical stroke width and then
+generate \ps\ code that computes the rounded value. For non-circular pens, the
+pen shape will be rescaled so that horizontal or vertical parts of the stroke
+have the computed width.
+
+Rounding the width to whole pixels is not likely to improve the appearance of
+diagonal or curved strokes, but we do it anyway for consistency. The
+\&{truncate} command generated here tends to make all the strokes a little
+@:truncate}{\&{truncate} command@>
+thinner, but this is appropriate for \ps's scan-conversion rules. Even with
+truncation, an ideal with of $w$~pixels gets mapped into $\lfloor w\rfloor+1$.
+It would be better to have $\lceil w\rceil$ but that is ridiculously expensive
+to compute in \ps.
+
+@<Generate \ps\ code that sets the stroke width...@>=
+@<Set |wx| and |wy| to the width and height of the bounding box for
+ |pen_p(p)|@>;
+@<Use |pen_p(p)| and |path_p(p)| to decide whether |wx| or |wy| is more
+ important and set |adj_wx| and |ww| accordingly@>;
+if ( (ww!=gs_width) || (adj_wx!=gs_adj_wx) ) {
+ if ( adj_wx != 0 ) {
+ ps_room(13);
+ mp_ps_print_char(mp, ' '); mp_ps_print_double(mp, ww);
+ mp_ps_print_cmd(mp,
+ " 0 dtransform exch truncate exch idtransform pop setlinewidth"," hlw");
+ } else {
+ if (number_positive (internal_value(mp_procset)) ) {
+ ps_room(13);
+ mp_ps_print_char(mp, ' ');
+ mp_ps_print_double(mp, ww);
+ mp_ps_print(mp, " vlw");
+ } else {
+ ps_room(15);
+ mp_ps_print(mp, " 0 "); mp_ps_print_double(mp, ww);
+ mp_ps_print(mp, " dtransform truncate idtransform setlinewidth pop");
+ }
+ }
+ gs_width = ww;
+ gs_adj_wx = adj_wx;
+}
+
+@ @<Set |wx| and |wy| to the width and height of the bounding box for...@>=
+if ( (gr_right_x(pp)==gr_x_coord(pp)) && (gr_left_y(pp)==gr_y_coord(pp)) ) {
+ wx = fabs(gr_left_x(pp) - gr_x_coord(pp));
+ wy = fabs(gr_right_y(pp) - gr_y_coord(pp));
+} else {
+ double a, b;
+ a = gr_left_x(pp)-gr_x_coord(pp);
+ b = gr_right_x(pp)-gr_x_coord(pp);
+ wx = sqrt(a*a + b*b);
+ a = gr_left_y(pp)-gr_y_coord(pp);
+ b = gr_right_y(pp)-gr_y_coord(pp);
+ wy = sqrt(a*a + b*b);
+}
+
+@ 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.0/65536.0 /* ``less important'' of |wx|, |wy| cannot exceed the other by
+ more than this factor */
+
+@d do_x_loc 1
+@d do_y_loc 2
+
+@<Use |pen_p(p)| and |path_p(p)| to decide whether |wx| or |wy| is more...@>=
+tx=1.0/65536.0; ty=1.0/65536.0;
+if ( mp_gr_coord_rangeOK(path_p, do_y_loc, wy) ) tx=aspect_bound;
+else if ( mp_gr_coord_rangeOK(path_p, do_x_loc, wx) ) ty=aspect_bound;
+if ( wy / ty>=wx / tx ) { ww=wy; adj_wx=0; }
+else { ww=wx; adj_wx=1; }
+
+@ This routine quickly tests if path |h| is ``essentially horizontal'' or
+``essentially vertical,'' where |zoff| is |x_loc(0)| or |y_loc(0)| and |dz| is
+allowable range for $x$ or~$y$. We do not need and cannot afford a full
+bounding-box computation.
+
+@<Declarations@>=
+static boolean mp_gr_coord_rangeOK (mp_gr_knot h,
+ quarterword zoff, double dz);
+
+@ @c
+boolean mp_gr_coord_rangeOK (mp_gr_knot h,
+ quarterword zoff, double dz) {
+ mp_gr_knot p; /* for scanning the path form |h| */
+ double zlo,zhi; /* coordinate range so far */
+ double z; /* coordinate currently being tested */
+ if (zoff==do_x_loc) {
+ zlo=gr_x_coord(h);
+ zhi=zlo;
+ p=h;
+ while ( gr_right_type(p)!=mp_endpoint ) {
+ z=gr_right_x(p);
+ @<Make |zlo..zhi| include |z| and |return false| if |zhi-zlo>dz|@>;
+ p=gr_next_knot(p); z=gr_left_x(p);
+ @<Make |zlo..zhi| include |z| and |return false| if |zhi-zlo>dz|@>;
+ z=gr_x_coord(p);
+ @<Make |zlo..zhi| include |z| and |return false| if |zhi-zlo>dz|@>;
+ if ( p==h ) break;
+ }
+ } else {
+ zlo=gr_y_coord(h);
+ zhi=zlo;
+ p=h;
+ while ( gr_right_type(p)!=mp_endpoint ) {
+ z=gr_right_y(p);
+ @<Make |zlo..zhi| include |z| and |return false| if |zhi-zlo>dz|@>;
+ p=gr_next_knot(p); z=gr_left_y(p);
+ @<Make |zlo..zhi| include |z| and |return false| if |zhi-zlo>dz|@>;
+ z=gr_y_coord(p);
+ @<Make |zlo..zhi| include |z| and |return false| if |zhi-zlo>dz|@>;
+ if ( p==h ) break;
+ }
+ }
+ return true;
+}
+
+@ @<Make |zlo..zhi| include |z| and |return false| if |zhi-zlo>dz|@>=
+if ( z<zlo ) zlo=z;
+else if ( z>zhi ) zhi=z;
+if ( zhi-zlo>dz ) return false
+
+@ Filling with an elliptical pen is implemented via a combination of \&{stroke}
+and \&{fill} commands and a nontrivial dash pattern would interfere with this.
+@:stroke}{\&{stroke} command@>
+@:fill}{\&{fill} command@>
+Note that we don't use |delete_edge_ref| because |gs_dash_p| is not counted as
+a reference.
+
+@<Make sure \ps\ will use the right dash pattern for |dash_p(p)|@>=
+if ( gr_type(p)==mp_fill_code || gr_dash_p(p) == NULL) {
+ hh=NULL;
+} else {
+ hh=gr_dash_p(p);
+}
+if ( hh==NULL ) {
+ if ( gs_dash_p!=NULL || gs_dash_init_done == false) {
+ mp_ps_print_cmd(mp, " [] 0 setdash"," rd");
+ gs_dash_p=NULL;
+ gs_dash_init_done=true;
+ }
+} else if ( ! mp_gr_same_dashes(gs_dash_p,hh) ) {
+ @<Set the dash pattern from |dash_list(hh)| scaled by |scf|@>;
+}
+
+@ The original code had a check here to ensure that the result from
+|mp_take_scaled| did not go out of bounds.
+
+@<Set the dash pattern from |dash_list(hh)| scaled by |scf|@>=
+{ gs_dash_p=hh;
+ if ( (gr_dash_p(p)==NULL) || (hh==NULL) || (hh->array==NULL)) {
+ mp_ps_print_cmd(mp, " [] 0 setdash"," rd");
+ } else {
+ int i;
+ ps_room(28);
+ mp_ps_print(mp, " [");
+ for (i=0; *(hh->array+i) != -1;i++) {
+ ps_room(13);
+ mp_ps_print_double(mp, *(hh->array+i));
+ mp_ps_print_char(mp, ' ') ;
+ }
+ ps_room(22);
+ mp_ps_print(mp, "] ");
+ mp_ps_print_double(mp, hh->offset);
+ mp_ps_print_cmd(mp, " setdash"," sd");
+ }
+}
+
+@ @<Declarations@>=
+static boolean mp_gr_same_dashes (mp_dash_object *h, mp_dash_object *hh) ;
+
+@ This function test if |h| and |hh| represent the same dash pattern.
+
+@c
+boolean mp_gr_same_dashes (mp_dash_object *h, mp_dash_object *hh) {
+ boolean ret=false;
+ int i = 0;
+ if ( h==hh ) ret=true;
+ else if ( (h==NULL)||(hh==NULL) ) ret=false;
+ else if ( h->offset!=hh->offset ) ret=false;
+ else if ( h->array == hh->array ) ret=true;
+ else if ( h->array == NULL || hh->array == NULL) ret=false;
+ else { @<Compare |dash_list(h)| and |dash_list(hh)|@>; }
+ return ret;
+}
+
+@ @<Compare |dash_list(h)| and |dash_list(hh)|@>=
+{
+ while (*(h->array+i)!=-1 &&
+ *(hh->array+i)!=-1 &&
+ *(h->array+i) == *(hh->array+i)) i++;
+ if (i>0) {
+ if (*(h->array+i)==-1 && *(hh->array+i) == -1)
+ ret=true;
+ }
+}
+
+@ When stroking a path with an elliptical pen, it is necessary to transform
+the coordinate system so that a unit circular pen will have the desired shape.
+To keep this transformation local, we enclose it in a
+$$\&{gsave}\ldots\&{grestore}$$
+block. Any translation component must be applied to the path being stroked
+while the rest of the transformation must apply only to the pen.
+If |fill_also=true|, the path is to be filled as well as stroked so we must
+insert commands to do this after giving the path.
+
+@<Declarations@>=
+static void mp_gr_stroke_ellipse (MP mp, mp_graphic_object *h, boolean fill_also) ;
+
+@
+@c void mp_gr_stroke_ellipse (MP mp, mp_graphic_object *h, boolean fill_also) {
+ /* generate an elliptical pen stroke from object |h| */
+ double txx,txy,tyx,tyy; /* transformation parameters */
+ mp_gr_knot p; /* the pen to stroke with */
+ double d1,det; /* for tweaking transformation parameters */
+ double s; /* also for tweaking transformation paramters */
+ boolean transformed; /* keeps track of whether gsave/grestore are needed */
+ transformed=false;
+ @<Use |pen_p(h)| to set the transformation parameters and give the initial
+ translation@>;
+ @<Tweak the transformation parameters so the transformation is nonsingular@>;
+ if (gr_type(h)==mp_fill_code) {
+ mp_gr_ps_path_out(mp, gr_path_p((mp_fill_object *)h));
+ } else {
+ mp_gr_ps_path_out(mp, gr_path_p((mp_stroked_object *)h));
+ }
+ if ( number_zero (internal_value(mp_procset))) {
+ if ( fill_also ) mp_ps_print_nl(mp, "gsave fill grestore");
+ @<Issue \ps\ commands to transform the coordinate system@>;
+ mp_ps_print(mp, " stroke");
+ if ( transformed ) mp_ps_print(mp, " grestore");
+ } else {
+ if ( fill_also ) mp_ps_print_nl(mp, "B"); else mp_ps_print_ln(mp);
+ if ( (txy!=0.0)||(tyx!=0.0) ) {
+ mp_ps_print(mp, " [");
+ mp_ps_pair_out(mp, txx,tyx);
+ mp_ps_pair_out(mp, txy,tyy);
+ mp_ps_print(mp, "0 0] t");
+ } else if ((txx!=unity)||(tyy!=unity) ) {
+ mp_ps_print(mp, " ");
+ mp_ps_pair_out(mp,txx,tyy);
+ mp_ps_print(mp, " s");
+ };
+ mp_ps_print(mp, " S");
+ if ( transformed ) mp_ps_print(mp, " Q");
+ }
+ mp_ps_print_ln(mp);
+}
+
+@ @<Use |pen_p(h)| to set the transformation parameters and give the...@>=
+if (gr_type(h)==mp_fill_code) {
+ p=gr_pen_p((mp_fill_object *)h);
+} else {
+ p=gr_pen_p((mp_stroked_object *)h);
+}
+txx=gr_left_x(p);
+tyx=gr_left_y(p);
+txy=gr_right_x(p);
+tyy=gr_right_y(p);
+if ( (gr_x_coord(p)!=0.0)||(gr_y_coord(p)!=0.0) ) {
+ mp_ps_print_nl(mp, "");
+ mp_ps_print_cmd(mp, "gsave ","q ");
+ mp_ps_pair_out(mp, gr_x_coord(p), gr_y_coord(p));
+ mp_ps_print(mp, "translate ");
+ txx-=gr_x_coord(p);
+ tyx-=gr_y_coord(p);
+ txy-=gr_x_coord(p);
+ tyy-=gr_y_coord(p);
+ transformed=true;
+} else {
+ mp_ps_print_nl(mp, "");
+}
+@<Adjust the transformation to account for |gs_width| and output the
+ initial \&{gsave} if |transformed| should be |true|@>
+
+@
+
+@d mp_make_double(A,B,C) ((B)/(C))
+@d mp_take_double(A,B,C) ((B)*(C))
+
+@<Adjust the transformation to account for |gs_width| and output the...@>=
+if ( gs_width!=unity ) {
+ if ( gs_width==0.0 ) {
+ txx=unity; tyy=unity;
+ } else {
+ txx=mp_make_double(mp, txx,gs_width);
+ txy=mp_make_double(mp, txy,gs_width);
+ tyx=mp_make_double(mp, tyx,gs_width);
+ tyy=mp_make_double(mp, tyy,gs_width);
+ }
+}
+if ( (txy!=0.0)||(tyx!=0.0)||(txx!=unity)||(tyy!=unity) ) {
+ if ( (! transformed) ){
+ mp_ps_print_cmd(mp, "gsave ","q ");
+ transformed=true;
+ }
+}
+
+@ @<Issue \ps\ commands to transform the coordinate system@>=
+if ( (txy!=0.0)||(tyx!=0.0) ){
+ mp_ps_print_ln(mp);
+ mp_ps_print_char(mp, '[');
+ mp_ps_pair_out(mp, txx,tyx);
+ mp_ps_pair_out(mp, txy,tyy);
+ mp_ps_print(mp, "0 0] concat");
+} else if ( (txx!=unity)||(tyy!=unity) ){
+ mp_ps_print_ln(mp);
+ mp_ps_pair_out(mp, txx,tyy);
+ mp_ps_print(mp, "scale");
+}
+
+@ The \ps\ interpreter will probably abort if it encounters a singular
+transformation matrix. The determinant must be large enough to ensure that
+the printed representation will be nonsingular. Since the printed
+representation is always within $2^{-17}$ of the internal |scaled| value, the
+total error is at most $4T_{\rm max}2^{-17}$, where $T_{\rm max}$ is a bound on
+the magnitudes of |txx/65536|, |txy/65536|, etc.
+
+The |aspect_bound*(gs_width+1)| bound on the components of the pen
+transformation allows $T_{\rm max}$ to be at most |2*aspect_bound|.
+
+@<Tweak the transformation parameters so the transformation is nonsingular@>=
+det=mp_take_double(mp, txx,tyy) - mp_take_double(mp, txy,tyx);
+d1=4*(aspect_bound+1/65536.0);
+if ( fabs(det)<d1 ) {
+ if ( det>=0 ) { d1=d1-det; s=1; }
+ else { d1=-d1-det; s=-1; };
+ d1=d1*unity;
+ if ( fabs(txx)+fabs(tyy)>=fabs(txy)+fabs(tyy) ) {
+ if ( fabs(txx)>fabs(tyy) ) tyy=tyy+(d1+s*fabs(txx)) / txx;
+ else txx=txx+(d1+s*fabs(tyy)) / tyy;
+ } else {
+ if ( fabs(txy)>fabs(tyx) ) tyx=tyx+(d1+s*fabs(txy)) / txy;
+ else txy=txy+(d1+s*fabs(tyx)) / tyx;
+ }
+}
+
+@ Here is a simple routine that just fills a cycle.
+
+@<Declarations@>=
+static void mp_gr_ps_fill_out (MP mp, mp_gr_knot p);
+
+@ @c
+void mp_gr_ps_fill_out (MP mp, mp_gr_knot p) { /* fill cyclic path~|p| */
+ mp_gr_ps_path_out(mp, p);
+ mp_ps_print_cmd(mp, " fill"," F");
+ mp_ps_print_ln(mp);
+}
+
+@ A text node may specify an arbitrary transformation but the usual case
+involves only shifting, scaling, and occasionally rotation. The purpose
+of |choose_scale| is to select a scale factor so that the remaining
+transformation is as ``nice'' as possible. The definition of ``nice''
+is somewhat arbitrary but shifting and $90^\circ$ rotation are especially
+nice because they work out well for bitmap fonts. The code here selects
+a scale factor equal to $1/\sqrt2$ times the Frobenius norm of the
+non-shifting part of the transformation matrix. It is careful to avoid
+additions that might cause undetected overflow.
+
+@<Declarations@>=
+static double mp_gr_choose_scale (MP mp, mp_graphic_object *p) ;
+
+@ @c double mp_gr_choose_scale (MP mp, mp_graphic_object *p) {
+ /* |p| should point to a text node */
+ double a,b,c,d,ad,bc; /* temporary values */
+ double r;
+ a=gr_txx_val(p);
+ b=gr_txy_val(p);
+ c=gr_tyx_val(p);
+ d=gr_tyy_val(p);
+ if ( a<0 ) negate(a);
+ if ( b<0 ) negate(b);
+ if ( c<0 ) negate(c);
+ if ( d<0 ) negate(d);
+ ad=(a-d)/2.0;
+ bc=(b-c)/2.0;
+ a = (d+ad);
+ b = ad;
+ d = sqrt(a*a + b*b);
+ a = (c+bc);
+ b = bc;
+ c = sqrt(a*a + b*b);
+ r = sqrt(c*c + d*d);
+ return r;
+}
+
+@ The potential overflow here is caused by the fact the returned value
+has to fit in a |name_type|, which is a quarterword.
+
+@d fscale_tolerance (65/65536.0) /* that's $.001\times2^{16}$ */
+
+@<Declarations@>=
+static quarterword mp_size_index (MP mp, font_number f, double s) ;
+
+@ @c
+quarterword mp_size_index (MP mp, font_number f, double s) {
+ mp_node p,q; /* the previous and current font size nodes */
+ int i; /* the size index for |q| */
+ p=NULL;
+ q=mp->font_sizes[f];
+ i=0;
+ while ( q!=null ) {
+ if ( fabs(s-sc_factor(q))<=fscale_tolerance )
+ return (quarterword)i;
+ else
+ { p=q; q=mp_link(q); incr(i); };
+ if ( i==max_quarterword )
+ mp_overflow(mp, "sizes per font",max_quarterword);
+@:MetaPost capacity exceeded sizes per font}{\quad sizes per font@>
+ }
+ q=(mp_node)mp_xmalloc(mp, 1, font_size_size);
+ mp_link(q) = NULL;
+ sc_factor(q)=s;
+ if ( i==0 ) mp->font_sizes[f]=q; else mp_link(p)=q;
+ return (quarterword)i;
+}
+
+@ @<Declarations@>=
+static double mp_indexed_size (MP mp,font_number f, quarterword j);
+
+@ @c
+double mp_indexed_size (MP mp,font_number f, quarterword j) { /* return scaled */
+ mp_node p; /* a font size node */
+ int i; /* the size index for |p| */
+ p=mp->font_sizes[f];
+ i=0;
+ if ( p==null ) mp_confusion(mp, "size");
+ while ( (i!=j) ) {
+ incr(i);
+ /* clang: dereference null pointer 'p' */ assert(p);
+ p=mp_link(p);
+ if ( p==null ) mp_confusion(mp, "size");
+ }
+ /* clang: dereference null pointer 'p' */ assert(p);
+ return sc_factor(p);
+}
+
+@ @<Declarations@>=
+static void mp_clear_sizes (MP mp) ;
+
+@ @c void mp_clear_sizes (MP mp) {
+ font_number f; /* the font whose size list is being cleared */
+ mp_node p; /* current font size nodes */
+ for (f=null_font+1;f<=mp->last_fnum;f++) {
+ while ( mp->font_sizes[f]!=null ) {
+ p=mp->font_sizes[f];
+ mp->font_sizes[f]=mp_link(p);
+ mp_xfree(p);
+ }
+ }
+}
+
+@ There may be many sizes of one font and we need to keep track of the
+characters used for each size. This is done by keeping a linked list of
+sizes for each font with a counter in each text node giving the appropriate
+position in the size list for its font.
+
+@d font_size_size sizeof(struct mp_font_size_node_data) /* size of a font size node */
+
+@<Types...@>=
+typedef struct mp_font_size_node_data {
+ NODE_BODY;
+ double sc_factor_; /* scaled */
+} mp_font_size_node_data;
+typedef struct mp_font_size_node_data* mp_font_size_node;
+
+
+@ @<Declarations@>=
+static void mp_apply_mark_string_chars(MP mp, mp_edge_object *h, int next_size);
+
+@ @c
+void mp_apply_mark_string_chars(MP mp, mp_edge_object *h, int next_size) {
+ mp_graphic_object * p;
+ p=h->body;
+ while ( p!= NULL ) {
+ if ( gr_type(p)==mp_text_code ) {
+ if ( gr_font_n(p)!=null_font ) {
+ if ( gr_size_index(p)==(unsigned char)next_size )
+ mp_mark_string_chars(mp, gr_font_n(p),gr_text_p(p),gr_text_l(p));
+ }
+ }
+ p=gr_link(p);
+ }
+}
+
+@ @<Unmark all marked characters@>=
+for (f=null_font+1;f<=mp->last_fnum;f++) {
+ if ( mp->font_sizes[f]!=null ) {
+ mp_unmark_font(mp, f);
+ mp->font_sizes[f]=null;
+ }
+}
+
+@ @<Scan all the text nodes and mark the used ...@>=
+p=hh->body;
+while ( p!=null ) {
+ if ( gr_type(p)==mp_text_code ) {
+ f = gr_font_n(p);
+ if (f!=null_font ) {
+ switch (prologues) {
+ case 2:
+ case 3:
+ mp->font_sizes[f] = mp_void;
+ mp_mark_string_chars(mp, f, gr_text_p(p),gr_text_l(p));
+ if (mp_has_fm_entry(mp,f,NULL) ) {
+ if (mp->font_enc_name[f]==NULL )
+ mp->font_enc_name[f] = mp_fm_encoding_name(mp,f);
+ mp_xfree(mp->font_ps_name[f]);
+ mp->font_ps_name[f] = mp_fm_font_name(mp,f);
+ }
+ break;
+ case 1:
+ mp->font_sizes[f]=mp_void;
+ break;
+ default:
+ gr_size_index(p)=(unsigned char)mp_size_index(mp, f,mp_gr_choose_scale(mp, p));
+ if ( gr_size_index(p)==0 )
+ mp_mark_string_chars(mp, f, gr_text_p(p),gr_text_l(p));
+ }
+ }
+ }
+ p=gr_link(p);
+}
+
+
+@
+@d pen_is_elliptical(A) ((A)==gr_next_knot((A)))
+
+@<Exported function ...@>=
+int mp_gr_ship_out (mp_edge_object *hh, int prologues, int procset, int standalone) ;
+
+@ @c
+int mp_gr_ship_out (mp_edge_object *hh, int qprologues, int qprocset,int standalone) {
+ mp_graphic_object *p;
+ double ds,scf; /* design size and scale factor for a text node */
+ font_number f; /* for loops over fonts while (un)marking characters */
+ boolean transformed; /* is the coordinate system being transformed? */
+ int prologues, procset;
+ MP mp = hh->parent;
+ if (standalone) {
+ mp->jump_buf = malloc(sizeof(jmp_buf));
+ if (mp->jump_buf == NULL || setjmp(*(mp->jump_buf)))
+ return 0;
+ }
+ if (mp->history >= mp_fatal_error_stop ) return 1;
+ if (qprologues<0)
+ prologues = (int)((unsigned)number_to_scaled (internal_value(mp_prologues))>>16);
+ else
+ prologues=qprologues;
+ if (qprocset<0)
+ procset = (int)((unsigned)number_to_scaled (internal_value(mp_procset))>>16);
+ else
+ procset=qprocset;
+ mp_open_output_file(mp);
+ mp_print_initial_comment(mp, hh, prologues);
+ /* clang: never read: p = hh->body; */
+ @<Unmark all marked characters@>;
+ if ( prologues==2 || prologues==3 ) {
+ mp_reload_encodings(mp);
+ }
+ @<Scan all the text nodes and mark the used characters@>;
+ if ( prologues==2 || prologues==3 ) {
+ mp_print_improved_prologue(mp, hh, prologues, procset);
+ } else {
+ mp_print_prologue(mp, hh, prologues, procset);
+ }
+ mp_gs_unknown_graphics_state(mp, 0);
+ p = hh->body;
+ while ( p!=NULL ) {
+ if ( gr_has_color(p) ) {
+ @<Write |pre_script| of |p|@>;
+ }
+ mp_gr_fix_graphics_state(mp, p);
+ switch (gr_type(p)) {
+ case mp_fill_code:
+ if ( gr_pen_p((mp_fill_object *)p)==NULL ) {
+ mp_gr_ps_fill_out(mp, gr_path_p((mp_fill_object *)p));
+ } else if ( pen_is_elliptical(gr_pen_p((mp_fill_object *)p)) ) {
+ mp_gr_stroke_ellipse(mp, p,true);
+ } else {
+ mp_gr_ps_fill_out(mp, gr_path_p((mp_fill_object *)p));
+ mp_gr_ps_fill_out(mp, gr_htap_p(p));
+ }
+ if ( gr_post_script((mp_fill_object *)p)!=NULL ) {
+ mp_ps_print_nl (mp, gr_post_script((mp_fill_object *)p));
+ mp_ps_print_ln(mp);
+ }
+ break;
+ case mp_stroked_code:
+ if ( pen_is_elliptical(gr_pen_p((mp_stroked_object *)p)) )
+ mp_gr_stroke_ellipse(mp, p,false);
+ else {
+ mp_gr_ps_fill_out(mp, gr_path_p((mp_stroked_object *)p));
+ }
+ if ( gr_post_script((mp_stroked_object *)p)!=NULL ) {
+ mp_ps_print_nl (mp, gr_post_script((mp_stroked_object *)p));
+ mp_ps_print_ln(mp);
+ }
+ break;
+ case mp_text_code:
+ if ( (gr_font_n(p)!=null_font) && (gr_text_l(p)>0) ) {
+ if ( prologues>0 )
+ scf=mp_gr_choose_scale(mp, p);
+ else
+ scf=mp_indexed_size(mp, gr_font_n(p), (quarterword)gr_size_index(p));
+ @<Shift or transform as necessary before outputting text node~|p| at scale
+ factor~|scf|; set |transformed:=true| if the original transformation must
+ be restored@>;
+ mp_ps_string_out(mp, gr_text_p(p),gr_text_l(p));
+ mp_ps_name_out(mp, mp->font_name[gr_font_n(p)],false);
+ @<Print the size information and \ps\ commands for text node~|p|@>;
+ mp_ps_print_ln(mp);
+ }
+ if ( gr_post_script((mp_text_object *)p)!=NULL ) {
+ mp_ps_print_nl (mp, gr_post_script((mp_text_object *)p)); mp_ps_print_ln(mp);
+ }
+ break;
+ case mp_start_clip_code:
+ mp_ps_print_nl(mp, ""); mp_ps_print_cmd(mp, "gsave ","q ");
+ mp_gr_ps_path_out(mp, gr_path_p((mp_clip_object *)p));
+ mp_ps_print_cmd(mp, " clip"," W");
+ mp_ps_print_ln(mp);
+ if ( number_positive (internal_value(mp_restore_clip_color)) )
+ mp_gs_unknown_graphics_state(mp, 1);
+ break;
+ case mp_stop_clip_code:
+ mp_ps_print_nl(mp, ""); mp_ps_print_cmd(mp, "grestore","Q");
+ mp_ps_print_ln(mp);
+ if ( number_positive (internal_value(mp_restore_clip_color)) )
+ mp_gs_unknown_graphics_state(mp, 2);
+ else
+ mp_gs_unknown_graphics_state(mp, -1);
+ break;
+ case mp_start_bounds_code:
+ case mp_stop_bounds_code:
+ break;
+ case mp_special_code:
+ {
+ mp_special_object *ps = (mp_special_object *)p;
+ mp_ps_print_nl (mp, gr_pre_script(ps));
+ mp_ps_print_ln (mp);
+ }
+ break;
+ } /* all cases are enumerated */
+ p=gr_link(p);
+ }
+ mp_ps_print_cmd(mp, "showpage","P"); mp_ps_print_ln(mp);
+ mp_ps_print(mp, "%%EOF"); mp_ps_print_ln(mp);
+ (mp->close_file)(mp,mp->output_file);
+ if ( prologues<=0 )
+ mp_clear_sizes(mp);
+ return 1;
+}
+
+@ @<Internal Postscript header information@>=
+int mp_ps_ship_out (mp_edge_object *hh, int prologues, int procset) ;
+
+@ @c
+int mp_ps_ship_out (mp_edge_object *hh, int prologues, int procset) {
+ return mp_gr_ship_out (hh, prologues, procset, (int)true);
+}
+
+
+
+
+
+@
+@d do_write_prescript(a,b) {
+ if ( (gr_pre_script((b *)a))!=NULL ) {
+ mp_ps_print_nl (mp, gr_pre_script((b *)a));
+ mp_ps_print_ln(mp);
+ }
+}
+
+@<Write |pre_script| of |p|@>=
+{
+ if (gr_type(p)==mp_fill_code) { do_write_prescript(p,mp_fill_object); }
+ else if (gr_type(p)==mp_stroked_code) { do_write_prescript(p,mp_stroked_object); }
+ else if (gr_type(p)==mp_text_code) { do_write_prescript(p,mp_text_object); }
+}
+
+@ @<Print the size information and \ps\ commands for text node~|p|@>=
+ps_room(18);
+mp_ps_print_char(mp, ' ');
+ds=(mp->font_dsize[gr_font_n(p)]+8) / 16;
+mp_ps_print_double(mp, (mp_take_double(mp, ds,scf)/65536.0));
+mp_ps_print(mp, " fshow");
+if ( transformed )
+ mp_ps_print_cmd(mp, " grestore"," Q")
+
+
+
+@ @<Shift or transform as necessary before outputting text node~|p| at...@>=
+transformed=(gr_txx_val(p)!=scf)||(gr_tyy_val(p)!=scf)||
+ (gr_txy_val(p)!=0)||(gr_tyx_val(p)!=0);
+if ( transformed ) {
+ mp_ps_print_cmd(mp, "gsave [", "q [");
+ mp_ps_pair_out(mp, mp_make_double(mp, gr_txx_val(p),scf),
+ mp_make_double(mp, gr_tyx_val(p),scf));
+ mp_ps_pair_out(mp, mp_make_double(mp, gr_txy_val(p),scf),
+ mp_make_double(mp, gr_tyy_val(p),scf));
+ mp_ps_pair_out(mp, gr_tx_val(p),gr_ty_val(p));
+ mp_ps_print_cmd(mp, "] concat 0 0 moveto","] t 0 0 m");
+} else {
+ mp_ps_pair_out(mp, gr_tx_val(p),gr_ty_val(p));
+ mp_ps_print_cmd(mp, "moveto","m");
+}
+mp_ps_print_ln(mp)
+
+@ @<Internal Postscript header information@>=
+void mp_gr_toss_objects ( mp_edge_object *hh) ;
+void mp_gr_toss_object (mp_graphic_object *p) ;
+
+@ @c
+void mp_gr_toss_object (mp_graphic_object *p) {
+ mp_fill_object *tf;
+ mp_stroked_object *ts;
+ mp_text_object *tt;
+ switch (gr_type(p)) {
+ case mp_fill_code:
+ tf = (mp_fill_object *)p;
+ mp_xfree(gr_pre_script(tf));
+ mp_xfree(gr_post_script(tf));
+ mp_gr_toss_knot_list(mp,gr_pen_p(tf));
+ mp_gr_toss_knot_list(mp,gr_path_p(tf));
+ mp_gr_toss_knot_list(mp,gr_htap_p(p));
+ break;
+ case mp_stroked_code:
+ ts = (mp_stroked_object *)p;
+ mp_xfree(gr_pre_script(ts));
+ mp_xfree(gr_post_script(ts));
+ mp_gr_toss_knot_list(mp,gr_pen_p(ts));
+ mp_gr_toss_knot_list(mp,gr_path_p(ts));
+ if (gr_dash_p(p)!=NULL)
+ mp_gr_toss_dashes (mp,gr_dash_p(p));
+ break;
+ case mp_text_code:
+ tt = (mp_text_object *)p;
+ mp_xfree(gr_pre_script(tt));
+ mp_xfree(gr_post_script(tt));
+ mp_xfree(gr_text_p(p));
+ mp_xfree(gr_font_name(p));
+ break;
+ case mp_start_clip_code:
+ mp_gr_toss_knot_list(mp,gr_path_p((mp_clip_object *)p));
+ break;
+ case mp_start_bounds_code:
+ mp_gr_toss_knot_list(mp,gr_path_p((mp_bounds_object *)p));
+ break;
+ case mp_stop_clip_code:
+ case mp_stop_bounds_code:
+ break;
+ case mp_special_code:
+ mp_xfree(gr_pre_script((mp_special_object *)p));
+ break;
+ } /* all cases are enumerated */
+ mp_xfree(p);
+}
+
+
+@ @c
+void mp_gr_toss_objects (mp_edge_object *hh) {
+ mp_graphic_object *p, *q;
+ p = hh->body;
+ while ( p!=NULL ) {
+ q = gr_link(p);
+ mp_gr_toss_object(p);
+ p=q;
+ }
+ mp_xfree(hh->filename);
+ mp_xfree(hh);
+}
+
+@ @<Internal Postscript header information@>=
+mp_graphic_object *mp_gr_copy_object (MP mp, mp_graphic_object *p) ;
+
+@ @c
+mp_graphic_object *
+mp_gr_copy_object (MP mp, mp_graphic_object *p) {
+ mp_fill_object *tf;
+ mp_stroked_object *ts;
+ mp_text_object *tt;
+ mp_clip_object *tc;
+ mp_bounds_object *tb;
+ mp_special_object *tp;
+ mp_graphic_object *q = NULL;
+ switch (gr_type(p)) {
+ case mp_fill_code:
+ tf = (mp_fill_object *)mp_new_graphic_object(mp, mp_fill_code);
+ gr_pre_script(tf) = mp_xstrdup(mp, gr_pre_script((mp_fill_object *)p));
+ gr_post_script(tf) = mp_xstrdup(mp, gr_post_script((mp_fill_object *)p));
+ gr_path_p(tf) = mp_gr_copy_path(mp,gr_path_p((mp_fill_object *)p));
+ gr_htap_p(tf) = mp_gr_copy_path(mp,gr_htap_p(p));
+ gr_pen_p(tf) = mp_gr_copy_path(mp,gr_pen_p((mp_fill_object *)p));
+ q = (mp_graphic_object *)tf;
+ break;
+ case mp_stroked_code:
+ ts = (mp_stroked_object *)mp_new_graphic_object(mp, mp_stroked_code);
+ gr_pre_script(ts) = mp_xstrdup(mp, gr_pre_script((mp_stroked_object *)p));
+ gr_post_script(ts) = mp_xstrdup(mp, gr_post_script((mp_stroked_object *)p));
+ gr_path_p(ts) = mp_gr_copy_path(mp,gr_path_p((mp_stroked_object *)p));
+ gr_pen_p(ts) = mp_gr_copy_path(mp,gr_pen_p((mp_stroked_object *)p));
+ gr_dash_p(ts) = mp_gr_copy_dashes(mp,gr_dash_p(p));
+ q = (mp_graphic_object *)ts;
+ break;
+ case mp_text_code:
+ tt = (mp_text_object *)mp_new_graphic_object(mp, mp_text_code);
+ gr_pre_script(tt) = mp_xstrdup(mp, gr_pre_script((mp_text_object *)p));
+ gr_post_script(tt) = mp_xstrdup(mp, gr_post_script((mp_text_object *)p));
+ gr_text_p(tt) = mp_xstrldup(mp, gr_text_p(p), gr_text_l(p));
+ gr_text_l(tt) = gr_text_l(p);
+ gr_font_name(tt) = mp_xstrdup(mp, gr_font_name(p));
+ q = (mp_graphic_object *)tt;
+ break;
+ case mp_start_clip_code:
+ tc = (mp_clip_object *)mp_new_graphic_object(mp, mp_start_clip_code);
+ gr_path_p(tc) = mp_gr_copy_path(mp,gr_path_p((mp_clip_object *)p));
+ q = (mp_graphic_object *)tc;
+ break;
+ case mp_start_bounds_code:
+ tb = (mp_bounds_object *)mp_new_graphic_object(mp, mp_start_bounds_code);
+ gr_path_p(tb) = mp_gr_copy_path(mp,gr_path_p((mp_bounds_object *)p));
+ q = (mp_graphic_object *)tb;
+ break;
+ case mp_special_code:
+ tp = (mp_special_object *)mp_new_graphic_object(mp, mp_special_code);
+ gr_pre_script(tp) = mp_xstrdup(mp, gr_pre_script((mp_special_object *)p));
+ q = (mp_graphic_object *)tp;
+ break;
+ case mp_stop_clip_code:
+ q = mp_new_graphic_object(mp, mp_stop_clip_code);
+ break;
+ case mp_stop_bounds_code:
+ q = mp_new_graphic_object(mp, mp_stop_bounds_code);
+ break;
+ } /* all cases are enumerated */
+ return q;
+}
+
diff --git a/Build/source/texk/web2c/mplibdir/svgout.w b/Build/source/texk/web2c/mplibdir/svgout.w
new file mode 100644
index 00000000000..94801da5205
--- /dev/null
+++ b/Build/source/texk/web2c/mplibdir/svgout.w
@@ -0,0 +1,1343 @@
+% Copyright 2008-2009 Taco Hoekwater.
+%
+% This program is free software: you can redistribute it and/or modify
+% it under the terms of the GNU Lesser General Public License as published by
+% the Free Software Foundation, either version 3 of the License, or
+% (at your option) any later version.
+%
+% This program is distributed in the hope that it will be useful,
+% but WITHOUT ANY WARRANTY; without even the implied warranty of
+% MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+% GNU Lesser General Public License for more details.
+%
+% You should have received a copy of the GNU Lesser General Public License
+% along with this program. If not, see <http://www.gnu.org/licenses/>.
+%
+% 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
+
+\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}
+\def\[#1]{} % from pascal web
+\def\(#1){} % this is used to make section names sort themselves better
+\def\9#1{} % this is used for sort keys in the index via @@:sort key}{entry@@>
+
+\def\title{MetaPost SVG output}
+\def\topofcontents{\hsize 5.5in
+ \vglue -30pt plus 1fil minus 1.5in
+ \def\?##1]{\hbox to 1in{\hfil##1.\ }}
+ }
+\def\botofcontents{\vskip 0pt plus 1fil minus 1.5in}
+\pdfoutput=1
+\pageno=3
+
+@
+@d zero_t ((math_data *)mp->math)->zero_t
+@d number_zero(A) (((math_data *)(mp->math))->equal)(A,zero_t)
+@d number_greater(A,B) (((math_data *)(mp->math))->greater)(A,B)
+@d number_positive(A) number_greater(A, zero_t)
+@d number_to_scaled(A) (((math_data *)(mp->math))->to_scaled)(A)
+@d round_unscaled(A) (((math_data *)(mp->math))->round_unscaled)(A)
+@d true 1
+@d false 0
+@d null_font 0
+@d null 0
+@d unity 1.0
+@d incr(A) (A)=(A)+1 /* increase a variable by unity */
+@d decr(A) (A)=(A)-1 /* decrease a variable by unity */
+@d negate(A) (A)=-(A) /* change the sign of a variable */
+
+@c
+#include <w2c/config.h>
+#include <stdio.h>
+#include <stdlib.h>
+#include <string.h>
+#include <math.h>
+#include "mplib.h"
+#include "mplibps.h" /* external header */
+#include "mplibsvg.h" /* external header */
+#include "mpmp.h" /* internal header */
+#include "mppsout.h" /* internal header */
+#include "mpsvgout.h" /* internal header */
+#include "mpmath.h" /* internal header */
+@h
+@<Types in the outer block@>
+@<Declarations@>
+
+@ There is a small bit of code from the backend that bleads through
+to the frontend because I do not know how to set up the includes
+properly. That is |typedef struct svgout_data_struct * svgout_data|.
+
+@ @(mpsvgout.h@>=
+#ifndef MPSVGOUT_H
+#define MPSVGOUT_H 1
+#include "mplib.h"
+#include "mpmp.h"
+#include "mplibps.h"
+typedef struct svgout_data_struct {
+ @<Globals@>
+} svgout_data_struct ;
+@<Exported function headers@>
+#endif
+
+@ @<Exported function headers@>=
+void mp_svg_backend_initialize (MP mp) ;
+void mp_svg_backend_free (MP mp) ;
+
+@ @c
+void mp_svg_backend_initialize (MP mp) {
+ mp->svg = mp_xmalloc(mp,1,sizeof(svgout_data_struct));
+ @<Set initial values@>;
+}
+void mp_svg_backend_free (MP mp) {
+ mp_xfree(mp->svg->buf);
+ mp_xfree(mp->svg);
+ mp->svg = NULL;
+}
+
+@ Writing to SVG files
+
+This variable holds the number of characters on the current SVG file
+line. It could also be a boolean because right now the only interesting
+thing it does is keep track of whether or not we are start-of-line.
+
+@<Globals@>=
+size_t file_offset;
+
+@ @<Set initial values@>=
+mp->svg->file_offset = 0;
+
+@ Print a newline.
+
+@c
+static void mp_svg_print_ln (MP mp) {
+ (mp->write_ascii_file)(mp,mp->output_file,"\n");
+ mp->svg->file_offset=0;
+}
+
+@ Print a single character.
+
+@c
+static void mp_svg_print_char (MP mp, int s) {
+ char ss[2];
+ ss[0]=(char)s; ss[1]=0;
+ (mp->write_ascii_file)(mp,mp->output_file,(char *)ss);
+ mp->svg->file_offset ++;
+}
+
+@ Print a string.
+
+In PostScript, this used to be done in terms of |mp_svg_print_char|,
+but that is very expensive (in other words: slow). It should be ok
+to print whole strings here because line length of an XML file should
+not be an issue to any respectable XML processing tool.
+
+@c
+static void mp_svg_print (MP mp, const char *ss) {
+ (mp->write_ascii_file)(mp,mp->output_file,ss);
+ mp->svg->file_offset += strlen(ss);
+}
+
+
+@ The procedure |print_nl| is like |print|, but it makes sure that the
+string appears at the beginning of a new line.
+
+@c
+static void mp_svg_print_nl (MP mp, const char *s) {
+ if ( mp->svg->file_offset>0 )
+ mp_svg_print_ln(mp);
+ mp_svg_print(mp, s);
+}
+
+
+@ Many of the printing routines use a print buffer to store partial
+strings in before feeding the attribute value to |mp_svg_attribute|.
+
+@<Globals...@>=
+char *buf;
+unsigned loc;
+unsigned bufsize;
+
+@ Start with a modest size of 256. the buffer will grow automatically
+when needed.
+
+@<Set initial values@>=
+mp->svg->loc = 0;
+mp->svg->bufsize = 256;
+mp->svg->buf = mp_xmalloc(mp,mp->svg->bufsize,1);
+memset(mp->svg->buf,0,256);
+
+
+@ How to append a character or a string of characters to
+the end of the buffer.
+
+@d append_char(A) do {
+ if (mp->svg->loc==(mp->svg->bufsize-1)) {
+ char *buffer;
+ unsigned l;
+ l = (unsigned)(mp->svg->bufsize+(mp->svg->bufsize>>4));
+ if (l>(0x3FFFFFF)) {
+ mp_confusion(mp,"svg buffer size");
+ }
+ buffer = mp_xmalloc(mp,l,1);
+ memset (buffer,0,l);
+ memcpy(buffer,mp->svg->buf,(size_t)mp->svg->bufsize);
+ mp_xfree(mp->svg->buf);
+ mp->svg->buf = buffer ;
+ mp->svg->bufsize = l;
+ }
+ mp->svg->buf[mp->svg->loc++] = (A);
+} while (0)
+
+@d append_string(A) do {
+ const char *ss = (A);
+ while (*ss != '\0') { append_char(*ss); ss++ ;}
+} while (0)
+
+@ This function resets the buffer in preparation of the next string.
+The |memset| is an easy way to make sure that the old string is
+forgotten completely and that the new string will be zero-terminated.
+
+@c
+static void mp_svg_reset_buf(MP mp) {
+ mp->svg->loc = 0;
+ memset (mp->svg->buf,0,mp->svg->bufsize);
+}
+
+@ Printing the buffer is a matter of printing its string, then
+it is reset.
+
+@c
+static void mp_svg_print_buf (MP mp) {
+ mp_svg_print(mp, (char *)mp->svg->buf);
+ mp_svg_reset_buf(mp);
+}
+
+@ The following procedure, which stores the decimal representation of
+a given integer |n| in the buffer, has been written carefully so that
+it works properly if |n=0| or if |(-n)| would cause overflow.
+
+@c
+static void mp_svg_store_int (MP mp, integer n) {
+ unsigned char dig[23]; /* digits in a number, for rounding */
+ integer m; /* used to negate |n| in possibly dangerous cases */
+ int k = 0; /* index to current digit; we assume that $|n|<10^{23}$ */
+ if ( n<0 ) {
+ append_char('-');
+ if ( n>-100000000 ) {
+ negate(n);
+ } else {
+ m=-1-n; n=m / 10; m=(m % 10)+1; k=1;
+ if ( m<10 ) {
+ dig[0]=(unsigned char)m;
+ } else {
+ dig[0]=0; incr(n);
+ }
+ }
+ }
+ do {
+ dig[k]=(unsigned char)(n % 10); n=n / 10; incr(k);
+ } while (n!=0);
+ /* print the digits */
+ while ( k-->0 ){
+ append_char((char)('0'+dig[k]));
+ }
+}
+
+@ \MP\ also makes use of a trivial procedure to output two digits. The
+following subroutine is usually called with a parameter in the range |0<=n<=99|,
+but the assignments makes sure that only the two least significant digits
+are printed, just in case.
+
+@c
+static void mp_svg_store_dd (MP mp,integer n) {
+ char nn=(char)abs(n) % 100;
+ append_char((char)('0'+(nn / 10)));
+ append_char((char)('0'+(nn % 10)));
+}
+
+@ Conversely, here is a procedure analogous to |mp_svg_store_int|.
+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 \&{do while} loop is that a sequence of
+decimal digits yet to be printed will yield the original number if and only if
+they form a fraction~$f$ in the range $s-\delta\L10\cdot2^{16}f<s$.
+We can stop if and only if $f=0$ satisfies this condition; the loop will
+terminate before $s$ can possibly become zero.
+
+@c
+static void mp_svg_store_double (MP mp, double s) {
+ char *value, *c;
+ value = mp_xmalloc(mp,1,32);
+ mp_snprintf(value,32,"%f", s);
+ c = value;
+ while (*c) {
+ append_char(*c);
+ c++;
+ }
+ free(value);
+}
+
+
+@ Output XML tags.
+
+In order to create a nicely indented output file, the current tag
+nesting level needs to be remembered.
+
+@<Globals...@>=
+int level;
+
+@ @<Set initial values@>=
+mp->svg->level = 0;
+
+@ Output an XML start tag.
+
+Because start tags may carry attributes, this happens in two steps.
+The close function is trivial of course, but it looks nicer in the source.
+
+@d mp_svg_starttag(A,B) { mp_svg_open_starttag (A,B); mp_svg_close_starttag(A); }
+
+@c
+static void mp_svg_open_starttag (MP mp, const char *s) {
+ int l = mp->svg->level * 2;
+ mp_svg_print_ln(mp);
+ while (l-->0) {
+ append_char(' ');
+ }
+ append_char('<');
+ append_string(s);
+ mp_svg_print_buf(mp);
+ mp->svg->level++;
+}
+static void mp_svg_close_starttag (MP mp) {
+ mp_svg_print_char(mp,'>');
+}
+
+@ Output an XML end tag.
+
+If the |indent| is true, then the end tag will appear on the next line
+of the SVG file, correctly indented for the current XML nesting
+level. If it is false, the end tag will appear immediatelu after the
+preceding output.
+
+@c
+static void mp_svg_endtag (MP mp, const char *s, boolean indent) {
+ mp->svg->level--;
+ if (indent) {
+ int l = mp->svg->level * 2;
+ mp_svg_print_ln(mp);
+ while (l-->0) {
+ append_char(' ');
+ }
+ }
+ append_string("</");
+ append_string(s);
+ append_char('>');
+ mp_svg_print_buf(mp);
+}
+
+@ Attribute. Can't play with the buffer here becase it is likely
+that that is the |v| argument.
+
+@c
+static void mp_svg_attribute (MP mp, const char *s, const char *v) {
+ mp_svg_print_char(mp, ' ');
+ mp_svg_print(mp, s);
+ mp_svg_print(mp,"=\"");
+ mp_svg_print(mp, v);
+ mp_svg_print_char(mp,'"');
+}
+
+@ This is a test to filter out characters that are illegal in XML.
+
+@<Character |k| is illegal in SVG output@>=
+ (k<=0x8)||(k==0xB)||(k==0xC)||(k>=0xE && k<=0x1F)||
+ (k>=0x7F && k<=0x84)||(k>=0x86 && k<=0x9F)
+
+
+@ This is test is used to switch between direct representation of characters
+and character references. Just in case the input string is UTF-8, allow everything
+except the characters that have to be quoted for XML well-formedness.
+
+@<Character |k| is not allowed in SVG output@>=
+ (k=='&')||(k=='>')||(k=='<')
+
+@ We often need to print a pair of coordinates.
+
+Because of bugs in svg rendering software, it is necessary to
+change the point coordinates so that there are all in the "positive"
+quadrant of the SVG field. This means an shift and a vertical flip.
+
+The two correction values are calculated by the function that writes
+the initial |<svg>| tag, and are stored in two globals:
+
+@<Globals@>=
+integer dx;
+integer dy;
+
+@ @c
+void mp_svg_pair_out (MP mp,double x, double y) {
+ mp_svg_store_double(mp, (x+mp->svg->dx));
+ append_char(' ');
+ mp_svg_store_double(mp, (-(y+mp->svg->dy)));
+}
+
+@ @<Declarations@>=
+void mp_svg_font_pair_out (MP mp,double x, double y) ;
+
+@ @c
+void mp_svg_font_pair_out (MP mp,double x, double y) {
+ mp_svg_store_double(mp, (x));
+ append_char(' ');
+ mp_svg_store_double(mp, -(y));
+}
+
+@ When stroking a path with an elliptical pen, it is necessary to distort
+the path such that a circular pen can be used to stroke the path. The path
+itself is wrapped in another transformation to restore the points to their
+correct location (but now with a modified pen stroke).
+
+Because all the points in the path need fixing, it makes sense to
+have a specific helper to write such distorted pairs of coordinates out.
+
+@<Declarations@>=
+void mp_svg_trans_pair_out (MP mp, mp_pen_info *pen, double x, double y) ;
+
+@ @c
+void mp_svg_trans_pair_out (MP mp, mp_pen_info *pen, double x, double y) {
+ double sx,sy, rx,ry, px, py, retval, divider;
+ sx = (pen->sx);
+ sy = (pen->sy);
+ rx = (pen->rx);
+ ry = (pen->ry);
+ px = ((x+mp->svg->dx));
+ py = ((-(y+mp->svg->dy)));
+ divider = (sx*sy - rx*ry);
+ retval = (sy*px-ry*py)/divider;
+ mp_svg_store_double(mp, (retval));
+ append_char(' ');
+ retval = (sx*py-rx*px)/divider;
+ mp_svg_store_double(mp, (retval));
+}
+
+
+
+@ @<Declarations@>=
+static void mp_svg_pair_out (MP mp,double x, double y) ;
+
+@
+@<Declarations@>=
+static void mp_svg_print_initial_comment(MP mp,mp_edge_object *hh);
+
+@ @c
+void mp_svg_print_initial_comment(MP mp,mp_edge_object *hh) {
+ double tx, ty;
+ @<Print the MetaPost version and time @>;
+ mp_svg_open_starttag(mp,"svg");
+ mp_svg_attribute(mp,"version", "1.1");
+ mp_svg_attribute(mp,"xmlns", "http://www.w3.org/2000/svg");
+ mp_svg_attribute(mp, "xmlns:xlink", "http://www.w3.org/1999/xlink");
+ if ( hh->minx>hh->maxx) {
+ tx = 0;
+ ty = 0;
+ mp->svg->dx = 0;
+ mp->svg->dy = 0;
+ } else {
+ tx = (hh->minx<0 ? -hh->minx : 0) + hh->maxx;
+ ty = (hh->miny<0 ? -hh->miny : 0) + hh->maxy;
+ mp->svg->dx = (hh->minx<0 ? -hh->minx : 0);
+ mp->svg->dy = (hh->miny<0 ? -hh->miny : 0) - ty;
+ }
+ mp_svg_store_double(mp, tx);
+ mp_svg_attribute(mp,"width", mp->svg->buf);
+ mp_svg_reset_buf(mp);
+ mp_svg_store_double(mp, ty);
+ mp_svg_attribute(mp,"height", mp->svg->buf);
+ mp_svg_reset_buf(mp);
+ append_string("0 0 "); mp_svg_store_double(mp,tx);
+ append_char(' '); mp_svg_store_double(mp,ty);
+ mp_svg_attribute(mp,"viewBox", mp->svg->buf);
+ mp_svg_reset_buf(mp);
+ mp_svg_close_starttag(mp);
+ mp_svg_print_nl(mp,"<!-- Original BoundingBox: ");
+ mp_svg_store_double(mp, hh->minx); append_char(' ');
+ mp_svg_store_double(mp, hh->miny); append_char(' ');
+ mp_svg_store_double(mp, hh->maxx); append_char(' ');
+ mp_svg_store_double(mp, hh->maxy);
+ mp_svg_print_buf(mp);
+ mp_svg_print(mp," -->");
+}
+
+@ @<Print the MetaPost version and time @>=
+{
+ char *s;
+ int tt; /* scaled */
+ mp_svg_print_nl(mp, "<!-- Created by MetaPost ");
+ s = mp_metapost_version();
+ mp_svg_print(mp, s);
+ mp_xfree(s);
+ mp_svg_print(mp, " on ");
+ mp_svg_store_int(mp, round_unscaled(internal_value(mp_year)));
+ append_char('.');
+ mp_svg_store_dd(mp, round_unscaled(internal_value(mp_month)));
+ append_char('.');
+ mp_svg_store_dd(mp, round_unscaled(internal_value(mp_day)));
+ append_char(':');
+ tt=round_unscaled(internal_value(mp_time));
+ mp_svg_store_dd(mp, tt / 60);
+ mp_svg_store_dd(mp, tt % 60);
+ mp_svg_print_buf(mp);
+ mp_svg_print(mp, " -->");
+}
+
+
+@ Outputting a color specification.
+
+@d set_color_objects(pq)
+ object_color_model = pq->color_model;
+ object_color_a = pq->color.a_val;
+ object_color_b = pq->color.b_val;
+ object_color_c = pq->color.c_val;
+ object_color_d = pq->color.d_val;
+
+@c
+static void mp_svg_color_out (MP mp, mp_graphic_object *p) {
+ int object_color_model;
+ double object_color_a, object_color_b, object_color_c, object_color_d ;
+ if (gr_type(p) == mp_fill_code) {
+ mp_fill_object *pq = (mp_fill_object *)p;
+ set_color_objects(pq);
+ } else if (gr_type(p) == mp_stroked_code) {
+ mp_stroked_object *pq = (mp_stroked_object *)p;
+ set_color_objects(pq);
+ } else {
+ mp_text_object *pq = (mp_text_object *)p;
+ set_color_objects(pq);
+ }
+ if ( object_color_model==mp_no_model ) {
+ append_string("black");
+ } else {
+ if ( object_color_model==mp_grey_model ) {
+ object_color_b = object_color_a;
+ object_color_c = object_color_a;
+ } else if ( object_color_model==mp_cmyk_model) {
+ int c,m,y,k;
+ c = object_color_a;
+ m = object_color_b;
+ y = object_color_c;
+ k = object_color_d;
+ object_color_a = unity - (c+k>unity ? unity : c+k);
+ object_color_b = unity - (m+k>unity ? unity : m+k);
+ object_color_c = unity - (y+k>unity ? unity : y+k);
+ }
+ append_string("rgb(");
+ mp_svg_store_double(mp, (object_color_a * 100));
+ append_char('%');
+ append_char(',');
+ mp_svg_store_double(mp, (object_color_b * 100));
+ append_char('%');
+ append_char(',');
+ mp_svg_store_double(mp, (object_color_c * 100));
+ append_char('%');
+ append_char(')');
+ }
+}
+
+@ @<Declarations@>=
+static void mp_svg_color_out (MP mp, mp_graphic_object *p);
+
+@ This is the information that comes from a pen
+
+@<Types...@>=
+typedef struct mp_pen_info {
+ double tx, ty;
+ double sx, rx, ry, sy;
+ double ww;
+} mp_pen_info;
+
+
+@ (Re)discover the characteristics of an elliptical pen
+
+@<Declarations@>=
+mp_pen_info *mp_svg_pen_info(MP mp, mp_gr_knot pp, mp_gr_knot p);
+
+@ The next two constants come from the original web source.
+Together with the two helper functions, they will tell whether
+the |x| or the |y| direction of the path is the most important
+
+@d aspect_bound (10/65536.0)
+@d aspect_default 1
+
+@c
+static double coord_range_x (mp_gr_knot h, double dz) {
+ double z;
+ double zlo = 0, zhi = 0;
+ mp_gr_knot f = h;
+ while (h != NULL) {
+ z = gr_x_coord(h);
+ if (z < zlo) zlo = z; else if (z > zhi) zhi = z;
+ z = gr_right_x(h);
+ if (z < zlo) zlo = z; else if (z > zhi) zhi = z;
+ z = gr_left_x(h);
+ if (z < zlo) zlo = z; else if (z > zhi) zhi = z;
+ h = gr_next_knot(h);
+ if (h==f)
+ break;
+ }
+ return (zhi - zlo <= dz ? aspect_bound : aspect_default);
+}
+static double coord_range_y (mp_gr_knot h, double dz) {
+ double z;
+ double zlo = 0, zhi = 0;
+ mp_gr_knot f = h;
+ while (h != NULL) {
+ z = gr_y_coord(h);
+ if (z < zlo) zlo = z; else if (z > zhi) zhi = z;
+ z = gr_right_y(h);
+ if (z < zlo) zlo = z; else if (z > zhi) zhi = z;
+ z = gr_left_y(h);
+ if (z < zlo) zlo = z; else if (z > zhi) zhi = z;
+ h = gr_next_knot(h);
+ if (h==f)
+ break;
+ }
+ return (zhi - zlo <= dz ? aspect_bound : aspect_default);
+}
+
+@
+@c
+mp_pen_info *mp_svg_pen_info(MP mp, mp_gr_knot pp, mp_gr_knot p) {
+ double wx, wy; /* temporary pen widths, in either direction */
+ struct mp_pen_info *pen; /* return structure */
+ if (p == NULL)
+ return NULL;
+ pen = mp_xmalloc(mp, 1, sizeof(mp_pen_info));
+ pen->rx = unity;
+ pen->ry = unity;
+ pen->ww = unity;
+ if ((gr_right_x(p) == gr_x_coord(p))
+ &&
+ (gr_left_y(p) == gr_y_coord(p))) {
+ wx = fabs(gr_left_x(p) - gr_x_coord(p));
+ wy = fabs(gr_right_y(p) - gr_y_coord(p));
+ } else {
+ double a,b;
+ a = gr_left_x(p)-gr_x_coord(p);
+ b = gr_right_x(p)-gr_x_coord(p);
+ wx = sqrt(a*a + b*b);
+ a = gr_left_y(p)-gr_y_coord(p);
+ b = gr_right_y(p)-gr_y_coord(p);
+ wy = sqrt(a*a + b*b);
+ }
+ if ((wy/coord_range_x(pp, wx)) >= (wx/coord_range_y(pp, wy)))
+ pen->ww = wy;
+ else
+ pen->ww = wx;
+ pen->tx = gr_x_coord(p);
+ pen->ty = gr_y_coord(p);
+ pen->sx = gr_left_x(p) - pen->tx;
+ pen->rx = gr_left_y(p) - pen->ty;
+ pen->ry = gr_right_x(p) - pen->tx;
+ pen->sy = gr_right_y(p) - pen->ty;
+ if (pen->ww != unity) {
+ if (pen->ww == 0) {
+ pen->sx = unity;
+ pen->sy = unity;
+ } else {
+ /* this negation is needed because the svg coordinate system differs
+ from postscript's. */
+ pen->rx = -(pen->rx / pen->ww);
+ pen->ry = -(pen->ry / pen->ww);
+ pen->sx = pen->sx / pen->ww;
+ pen->sy = pen->sy / pen->ww;
+ }
+ }
+ return pen;
+}
+
+@ 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|.
+
+@<Declarations@>=
+static boolean mp_is_curved(mp_gr_knot p, mp_gr_knot q) ;
+
+
+@
+@d bend_tolerance (131/65536.0) /* allow rounding error of $2\cdot10^{-3}$ */
+
+@c
+boolean mp_is_curved(mp_gr_knot p, mp_gr_knot q) {
+ double d; /* a temporary value */
+ if ( gr_right_x(p)==gr_x_coord(p) )
+ if ( gr_right_y(p)==gr_y_coord(p) )
+ if ( gr_left_x(q)==gr_x_coord(q) )
+ if ( gr_left_y(q)==gr_y_coord(q) )
+ return false;
+ d=gr_left_x(q)-gr_right_x(p);
+ if ( fabs(gr_right_x(p)-gr_x_coord(p)-d)<=bend_tolerance )
+ if ( fabs(gr_x_coord(q)-gr_left_x(q)-d)<=bend_tolerance ) {
+ d=gr_left_y(q)-gr_right_y(p);
+ if ( fabs(gr_right_y(p)-gr_y_coord(p)-d)<=bend_tolerance )
+ if ( fabs(gr_y_coord(q)-gr_left_y(q)-d)<=bend_tolerance )
+ return false;
+ }
+ return true;
+}
+
+
+@ @c
+static void mp_svg_path_out (MP mp, mp_gr_knot h) {
+ mp_gr_knot p, q; /* for scanning the path */
+ append_char('M');
+ mp_svg_pair_out(mp, gr_x_coord(h),gr_y_coord(h));
+ p=h;
+ do {
+ if ( gr_right_type(p)==mp_endpoint ) {
+ if ( p==h ) {
+ append_string("l0 0");
+ }
+ return;
+ }
+ q=gr_next_knot(p);
+ if (mp_is_curved(p, q)){
+ append_char('C');
+ mp_svg_pair_out(mp, gr_right_x(p),gr_right_y(p));
+ append_char(',');
+ mp_svg_pair_out(mp, gr_left_x(q),gr_left_y(q));
+ append_char(',');
+ mp_svg_pair_out(mp, gr_x_coord(q),gr_y_coord(q));
+ } else if ( q!=h ){
+ append_char('L');
+ mp_svg_pair_out(mp, gr_x_coord(q),gr_y_coord(q));
+ }
+ p=q;
+ } while (p!=h);
+ append_char('Z');
+ append_char(0);
+}
+
+@ @c
+static void mp_svg_path_trans_out (MP mp, mp_gr_knot h, mp_pen_info *pen) {
+ mp_gr_knot p, q; /* for scanning the path */
+ append_char('M');
+ mp_svg_trans_pair_out(mp, pen, gr_x_coord(h),gr_y_coord(h));
+ p=h;
+ do {
+ if ( gr_right_type(p)==mp_endpoint ) {
+ if ( p==h ) {
+ append_string("l0 0");
+ }
+ return;
+ }
+ q=gr_next_knot(p);
+ if (mp_is_curved(p, q)){
+ append_char('C');
+ mp_svg_trans_pair_out(mp, pen, gr_right_x(p),gr_right_y(p));
+ append_char(',');
+ mp_svg_trans_pair_out(mp, pen,gr_left_x(q),gr_left_y(q));
+ append_char(',');
+ mp_svg_trans_pair_out(mp, pen,gr_x_coord(q),gr_y_coord(q));
+ } else if ( q!=h ){
+ append_char('L');
+ mp_svg_trans_pair_out(mp, pen,gr_x_coord(q),gr_y_coord(q));
+ }
+ p=q;
+ } while (p!=h);
+ append_char('Z');
+ append_char(0);
+}
+
+
+@ @c
+static void mp_svg_font_path_out (MP mp, mp_gr_knot h) {
+ mp_gr_knot p, q; /* for scanning the path */
+ append_char('M');
+ mp_svg_font_pair_out(mp, gr_x_coord(h),gr_y_coord(h));
+ p=h;
+ do {
+ if ( gr_right_type(p)==mp_endpoint ) {
+ if ( p==h ) {
+ append_char('l');
+ mp_svg_font_pair_out(mp, 0, 0);
+ }
+ return;
+ }
+ q=gr_next_knot(p);
+ if (mp_is_curved(p, q)){
+ append_char('C');
+ mp_svg_font_pair_out(mp, gr_right_x(p),gr_right_y(p));
+ append_char(',');
+ mp_svg_font_pair_out(mp, gr_left_x(q),gr_left_y(q));
+ append_char(',');
+ mp_svg_font_pair_out(mp, gr_x_coord(q),gr_y_coord(q));
+ } else if ( q!=h ){
+ append_char('L');
+ mp_svg_font_pair_out(mp, gr_x_coord(q),gr_y_coord(q));
+ }
+ p=q;
+ } while (p!=h);
+ append_char(0);
+}
+
+@ If |prologues:=3|, any glyphs in labels will be converted into paths.
+
+@d do_mark(A,B) do {
+ if (mp_chars == NULL) {
+ mp_chars = mp_xmalloc(mp, mp->font_max+1, sizeof(int *));
+ memset(mp_chars, 0, ((mp->font_max+1) * sizeof(int *)));
+ }
+ if (mp_chars[(A)] == NULL) {
+ int *glfs = mp_xmalloc(mp, 256, sizeof(int));
+ memset(glfs, 0, (256 * sizeof(int)));
+ mp_chars[(A)] = glfs;
+ }
+ mp_chars[(A)][(int)(B)] = 1;
+} while (0)
+
+@<Declarations@>=
+void mp_svg_print_glyph_defs (MP mp, mp_edge_object *h);
+
+@ @c
+void mp_svg_print_glyph_defs (MP mp, mp_edge_object *h) {
+ mp_graphic_object *p; /* object index */
+ int k; /* general purpose index */
+ size_t l; /* a string length */
+ int **mp_chars = NULL; /* a twodimensional array of used glyphs */
+ mp_ps_font *f = NULL;
+ mp_edge_object *ch;
+ p = h->body;
+ while ( p!=NULL ) {
+ if ((gr_type(p) == mp_text_code) &&
+ (gr_font_n(p)!=null_font) &&
+ ((l = gr_text_l(p))>0) ) {
+ unsigned char *s = (unsigned char *)gr_text_p(p);
+ while (l-->0) {
+ do_mark(gr_font_n(p), *s);
+ s++;
+ }
+ }
+ p=gr_link(p);
+ }
+ if (mp_chars != NULL) {
+ mp_svg_starttag(mp,"defs");
+ for (k=0;k<=(int)mp->font_max;k++) {
+ if (mp_chars[k] != NULL ) {
+ double scale; /* the next gives rounding errors */
+ double ds,dx,sk;
+ ds =(mp->font_dsize[k]+8) / 16;
+ scale = (1/1000.0) * (ds);
+ ds = (scale);
+ dx = ds;
+ sk = 0;
+ for (l=0;l<256;l++) {
+ if (mp_chars[k][l] == 1) {
+ if (f == NULL) {
+ f = mp_ps_font_parse(mp, k);
+ if (f == NULL) continue;
+ if (f->extend != 0) {
+ dx = (((double)f->extend / 1000.0) * scale);
+ }
+ if (f->slant != 0) {
+ sk = (((double)f->slant / 1000.0) * 90);
+ }
+ }
+ mp_svg_open_starttag(mp,"g");
+ append_string("scale(");
+ mp_svg_store_double(mp,dx/65536);
+ append_char(',');
+ mp_svg_store_double(mp,ds/65536);
+ append_char(')');
+ if (sk!=0) {
+ append_string(" skewX(");
+ mp_svg_store_double(mp,-sk);
+ append_char(')');
+ }
+ mp_svg_attribute(mp, "transform", mp->svg->buf);
+ mp_svg_reset_buf(mp);
+
+ append_string("GLYPH");
+ append_string(mp->font_name[k]);
+ append_char('_');
+ mp_svg_store_int(mp, (int)l);
+ mp_svg_attribute(mp, "id", mp->svg->buf);
+ mp_svg_reset_buf(mp);
+ mp_svg_close_starttag(mp);
+ if (f != NULL) {
+ ch = mp_ps_font_charstring(mp,f,(int)l);
+ if (ch != NULL) {
+ p = ch->body;
+ mp_svg_open_starttag(mp,"path");
+ mp_svg_attribute(mp, "style", "fill-rule: evenodd;");
+ while (p!=NULL) {
+ if (mp->svg->loc>0) mp->svg->loc--; /* drop a '\\0' */
+ mp_svg_font_path_out(mp, gr_path_p((mp_fill_object *)p));
+ p=p->next;
+ }
+ mp_svg_attribute(mp, "d", mp->svg->buf);
+ mp_svg_reset_buf(mp);
+ mp_svg_close_starttag(mp);
+ mp_svg_endtag(mp,"path",false);
+ }
+ mp_gr_toss_objects(ch);
+ }
+ mp_svg_endtag(mp,"g",true);
+ }
+ }
+ if (f!=NULL) { mp_ps_font_free(mp, f); f = NULL; }
+ }
+ }
+ mp_svg_endtag(mp,"defs", true);
+
+ /* cleanup */
+ for (k=0;k<(int)mp->font_max;k++) {
+ mp_xfree(mp_chars[k]);
+ }
+ mp_xfree(mp_chars);
+ }
+}
+
+
+@ Now for outputting the actual graphic objects.
+
+@<Declarations@>=
+static void mp_svg_text_out (MP mp, mp_text_object *p, int prologues) ;
+
+@ @c
+void mp_svg_text_out (MP mp, mp_text_object *p, int prologues) {
+ /* -Wunused: char *fname; */
+ unsigned char *s;
+ int k; /* a character */
+ size_t l; /* string length */
+ boolean transformed ;
+ double ds; /* design size and scale factor for a text node */
+ /* clang: never read: |fname = mp->font_ps_name[gr_font_n(p)];| */
+ s = (unsigned char *)gr_text_p(p);
+ l = gr_text_l(p);
+ transformed=(gr_txx_val(p)!=unity)||(gr_tyy_val(p)!=unity)||
+ (gr_txy_val(p)!=0)||(gr_tyx_val(p)!=0);
+ mp_svg_open_starttag(mp, "g");
+ if ( transformed ) {
+ append_string("matrix(");
+ mp_svg_store_double(mp,gr_txx_val(p)); append_char(',');
+ mp_svg_store_double(mp,-gr_tyx_val(p)); append_char(',');
+ mp_svg_store_double(mp,-gr_txy_val(p)); append_char(',');
+ mp_svg_store_double(mp,gr_tyy_val(p)); append_char(',');
+ } else {
+ append_string("translate(");
+ }
+ mp_svg_pair_out(mp,gr_tx_val(p),gr_ty_val(p));
+ append_char(')');
+
+ mp_svg_attribute(mp, "transform", mp->svg->buf);
+ mp_svg_reset_buf(mp);
+
+ append_string("fill: ");
+ mp_svg_color_out(mp,(mp_graphic_object *)p);
+ append_char(';');
+ mp_svg_attribute(mp, "style", mp->svg->buf);
+ mp_svg_reset_buf(mp);
+
+ mp_svg_close_starttag(mp);
+
+ if (prologues == 3 ) {
+
+ double charwd;
+ double wd = 0.0; /* this is in PS design units */
+ while (l-->0) {
+ k=(int)*s++;
+ mp_svg_open_starttag(mp, "use");
+ append_string("#GLYPH");
+ append_string(mp->font_name[gr_font_n(p)]);
+ append_char('_');
+ mp_svg_store_int(mp,k);
+ mp_svg_attribute(mp,"xlink:href", mp->svg->buf);
+ mp_svg_reset_buf(mp);
+ charwd = ((wd/100));
+ if (charwd!=0) {
+ mp_svg_store_double(mp,charwd);
+ mp_svg_attribute(mp,"x", mp->svg->buf);
+ mp_svg_reset_buf(mp);
+ }
+ wd += mp_get_char_dimension (mp, mp->font_name[gr_font_n(p)], k, 'w');
+ mp_svg_close_starttag(mp);
+ mp_svg_endtag(mp, "use", false);
+ }
+ } else {
+ mp_svg_open_starttag(mp, "text");
+ ds=(mp->font_dsize[gr_font_n(p)]+8) / 16 / 65536.0;
+ mp_svg_store_double(mp,ds);
+ mp_svg_attribute(mp, "font-size", mp->svg->buf);
+ mp_svg_reset_buf(mp);
+ mp_svg_close_starttag(mp);
+
+ while (l-->0) {
+ k=(int)*s++;
+ if (@<Character |k| is illegal in SVG output@>) {
+ char S[100];
+ mp_snprintf(S,99,"The character %d cannot be output in SVG "
+ "unless prologues:=3;",k);
+ mp_warn(mp,S);
+ } else if ( (@<Character |k| is not allowed in SVG output@>) ) {
+ append_string("&#");
+ mp_svg_store_int(mp,k);
+ append_char(';');
+ } else {
+ append_char((char)k);
+ }
+ }
+ mp_svg_print_buf(mp);
+ mp_svg_endtag(mp, "text", false);
+ }
+ mp_svg_endtag(mp, "g", true);
+}
+
+@ When stroking a path with an elliptical pen, it is necessary to transform
+the coordinate system so that a unit circular pen will have the desired shape.
+To keep this transformation local, we enclose it in a $$\&{<g>}\ldots\&{</g>}$$
+block. Any translation component must be applied to the path being stroked
+while the rest of the transformation must apply only to the pen.
+If |fill_also=true|, the path is to be filled as well as stroked so we must
+insert commands to do this after giving the path.
+
+@<Declarations@>=
+static void mp_svg_stroke_out (MP mp, mp_graphic_object *h,
+ mp_pen_info *pen, boolean fill_also) ;
+
+
+@ @c
+void mp_svg_stroke_out (MP mp, mp_graphic_object *h,
+ mp_pen_info *pen, boolean fill_also) {
+ boolean transformed = false;
+ if (pen != NULL) {
+ transformed = true;
+ if ((pen->sx==unity) &&
+ (pen->rx==0) &&
+ (pen->ry==0) &&
+ (pen->sy==unity) &&
+ (pen->tx==0) &&
+ (pen->ty==0)) {
+ transformed = false;
+ }
+ }
+ if (transformed) {
+ mp_svg_open_starttag(mp, "g");
+ append_string("matrix(");
+ mp_svg_store_double(mp,pen->sx); append_char(',');
+ mp_svg_store_double(mp,pen->rx); append_char(',');
+ mp_svg_store_double(mp,pen->ry); append_char(',');
+ mp_svg_store_double(mp,pen->sy); append_char(',');
+ mp_svg_store_double(mp,pen->tx); append_char(',');
+ mp_svg_store_double(mp,pen->ty);
+ append_char(')');
+ mp_svg_attribute(mp, "transform", mp->svg->buf);
+ mp_svg_reset_buf(mp);
+ mp_svg_close_starttag(mp);
+ }
+ mp_svg_open_starttag(mp, "path");
+
+ if (false) {
+ if (transformed)
+ mp_svg_path_trans_out(mp, gr_path_p((mp_fill_object *)h), pen);
+ else
+ mp_svg_path_out(mp, gr_path_p((mp_fill_object *)h));
+ mp_svg_attribute(mp, "d", mp->svg->buf);
+ mp_svg_reset_buf(mp);
+ append_string("fill: ");
+ mp_svg_color_out(mp,h);
+ append_string("; stroke: none;");
+ mp_svg_attribute(mp, "style", mp->svg->buf);
+ mp_svg_reset_buf(mp);
+ } else {
+ if (transformed)
+ mp_svg_path_trans_out(mp, gr_path_p((mp_stroked_object *)h), pen);
+ else
+ mp_svg_path_out(mp, gr_path_p((mp_stroked_object *)h));
+ mp_svg_attribute(mp, "d", mp->svg->buf);
+ mp_svg_reset_buf(mp);
+ append_string("stroke:");
+ mp_svg_color_out(mp,h);
+ append_string("; stroke-width: ");
+ if (pen != NULL) {
+ mp_svg_store_double(mp, pen->ww);
+ } else {
+ append_char('0');
+ }
+ append_char(';');
+ if (gr_lcap_val(h)!=0) {
+ append_string("stroke-linecap: ");
+ switch (gr_lcap_val(h)) {
+ case 1: append_string("round"); break;
+ case 2: append_string("square"); break;
+ default: append_string("butt"); break;
+ }
+ append_char(';');
+ }
+ if (gr_type(h)!=mp_fill_code) {
+ mp_dash_object *hh;
+ hh =gr_dash_p(h);
+ if (hh != NULL && hh->array != NULL) {
+ int i;
+ append_string("stroke-dasharray: ");
+ /* svg doesn't accept offsets */
+ for (i=0; *(hh->array+i) != -1;i++) {
+ mp_svg_store_double(mp, *(hh->array+i));
+ append_char(' ') ;
+ }
+ append_char(';');
+ }
+
+ if (gr_ljoin_val((mp_stroked_object *)h)!=0) {
+ append_string ("stroke-linejoin: ");
+ switch (gr_ljoin_val((mp_stroked_object *)h)) {
+ case 1: append_string("round"); break;
+ case 2: append_string("bevel"); break;
+ default: append_string("miter"); break;
+ }
+ append_char(';');
+ }
+
+ if (gr_miterlim_val((mp_stroked_object *)h) != 4*unity) {
+ append_string("stroke-miterlimit: ");
+ mp_svg_store_double(mp, gr_miterlim_val((mp_stroked_object *)h));
+ append_char(';');
+ }
+ }
+
+ append_string("fill: ");
+ if (fill_also) {
+ mp_svg_color_out(mp,h);
+ } else {
+ append_string("none");
+ }
+ append_char(';');
+ mp_svg_attribute(mp, "style", mp->svg->buf);
+ mp_svg_reset_buf(mp);
+ }
+ mp_svg_close_starttag(mp);
+ mp_svg_endtag(mp, "path", false);
+ if (transformed) {
+ mp_svg_endtag(mp, "g", true);
+ }
+}
+
+@ Here is a simple routine that just fills a cycle.
+
+@<Declarations@>=
+static void mp_svg_fill_out (MP mp, mp_gr_knot p, mp_graphic_object *h);
+
+@ @c
+void mp_svg_fill_out (MP mp, mp_gr_knot p, mp_graphic_object *h) {
+ mp_svg_open_starttag(mp, "path");
+ mp_svg_path_out(mp, p);
+ mp_svg_attribute(mp, "d", mp->svg->buf);
+ mp_svg_reset_buf(mp);
+ append_string("fill: ");
+ mp_svg_color_out(mp,h);
+ append_string(";stroke: none;");
+ mp_svg_attribute(mp, "style", mp->svg->buf);
+ mp_svg_reset_buf(mp);
+ mp_svg_close_starttag(mp); /* path */
+ mp_svg_endtag(mp, "path", false);
+}
+
+@ Clipping paths use IDs, so an extra global is needed:
+
+@<Globals...@>=
+int clipid;
+
+@
+@<Set initial values@>=
+mp->svg->clipid = 0;
+
+@ @<Declarations@>=
+static void mp_svg_clip_out (MP mp, mp_clip_object *p);
+
+@ @c
+void mp_svg_clip_out (MP mp, mp_clip_object *p) {
+ mp->svg->clipid++;
+ mp_svg_starttag(mp, "g");
+ mp_svg_starttag(mp, "defs");
+ mp_svg_open_starttag(mp, "clipPath");
+
+ append_string("CLIP");
+ mp_svg_store_int(mp, mp->svg->clipid);
+ mp_svg_attribute(mp, "id", mp->svg->buf);
+ mp_svg_reset_buf(mp);
+
+ mp_svg_close_starttag(mp);
+ mp_svg_open_starttag(mp, "path");
+ mp_svg_path_out(mp, gr_path_p(p));
+ mp_svg_attribute(mp,"d", mp->svg->buf);
+ mp_svg_reset_buf(mp);
+ mp_svg_attribute(mp, "style", "fill: black; stroke: none;");
+ mp_svg_close_starttag(mp); /* path */
+ mp_svg_endtag(mp, "path", false);
+ mp_svg_endtag(mp, "clipPath", true);
+ mp_svg_endtag(mp, "defs", true);
+ mp_svg_open_starttag(mp, "g");
+
+ append_string("url(#CLIP");
+ mp_svg_store_int(mp, mp->svg->clipid);
+ append_string(");");
+ mp_svg_attribute(mp, "clip-path", mp->svg->buf);
+ mp_svg_reset_buf(mp);
+
+ mp_svg_close_starttag(mp);
+}
+
+
+
+@ The main output function
+
+@d gr_has_scripts(A) (gr_type((A))<mp_start_clip_code)
+@d pen_is_elliptical(A) ((A)==gr_next_knot((A)))
+
+@<Exported function ...@>=
+int mp_svg_gr_ship_out (mp_edge_object *hh, int prologues, int standalone) ;
+
+@ @c
+int mp_svg_gr_ship_out (mp_edge_object *hh, int qprologues, int standalone) {
+ mp_graphic_object *p;
+ mp_pen_info *pen = NULL;
+ MP mp = hh->parent;
+ if (standalone) {
+ mp->jump_buf = malloc(sizeof(jmp_buf));
+ if (mp->jump_buf == NULL || setjmp(*(mp->jump_buf)))
+ return 0;
+ }
+ if (mp->history >= mp_fatal_error_stop ) return 1;
+ mp_open_output_file(mp);
+ if ( (qprologues>=1) && (mp->last_ps_fnum==0) && mp->last_fnum>0)
+ mp_read_psname_table(mp);
+ /* The next seems counterintuitive, but calls from |mp_svg_ship_out|
+ * set standalone to true, and because embedded use is likely, it is
+ * better not to output the XML declaration in that case.
+ */
+ if (!standalone)
+ mp_svg_print(mp, "<?xml version=\"1.0\"?>");
+ mp_svg_print_initial_comment(mp, hh);
+ if (qprologues == 3) {
+ mp_svg_print_glyph_defs(mp, hh);
+ }
+ p = hh->body;
+ while ( p!=NULL ) {
+ if ( gr_has_scripts(p) ) {
+ @<Write |pre_script| of |p|@>;
+ }
+ switch (gr_type(p)) {
+ case mp_fill_code:
+ {
+ mp_fill_object *ph = (mp_fill_object *)p;
+ if ( gr_pen_p(ph)==NULL ) {
+ mp_svg_fill_out(mp, gr_path_p(ph), p);
+ } else if ( pen_is_elliptical(gr_pen_p(ph)) ) {
+ pen = mp_svg_pen_info(mp, gr_path_p(ph), gr_pen_p(ph));
+ mp_svg_stroke_out(mp, p, pen, true);
+ mp_xfree(pen);
+ } else {
+ mp_svg_fill_out(mp, gr_path_p(ph), p);
+ mp_svg_fill_out(mp, gr_htap_p(ph), p);
+ }
+ }
+ break;
+ case mp_stroked_code:
+ {
+ mp_stroked_object *ph = (mp_stroked_object *)p;
+ if ( pen_is_elliptical(gr_pen_p(ph))) {
+ pen = mp_svg_pen_info(mp, gr_path_p(ph), gr_pen_p(ph));
+ mp_svg_stroke_out(mp, p, pen, false);
+ mp_xfree(pen);
+ } else {
+ mp_svg_fill_out(mp, gr_path_p(ph), p);
+ }
+ }
+ break;
+ case mp_text_code:
+ if ( (gr_font_n(p)!=null_font) && (gr_text_l(p)>0) ) {
+ mp_svg_text_out(mp, (mp_text_object *)p, qprologues);
+ }
+ break;
+ case mp_start_clip_code:
+ mp_svg_clip_out(mp, (mp_clip_object *)p);
+ break;
+ case mp_stop_clip_code:
+ mp_svg_endtag(mp, "g", true);
+ mp_svg_endtag(mp, "g", true);
+ break;
+ case mp_start_bounds_code:
+ case mp_stop_bounds_code:
+ break;
+ case mp_special_code:
+ {
+ mp_special_object *ps = (mp_special_object *)p;
+ mp_svg_print_nl (mp, gr_pre_script(ps));
+ mp_svg_print_ln (mp);
+ }
+ break;
+ } /* all cases are enumerated */
+ if ( gr_has_scripts(p) ) {
+ @<Write |post_script| of |p|@>;
+ }
+ p=gr_link(p);
+ }
+ mp_svg_endtag(mp, "svg", true);
+ mp_svg_print_ln(mp);
+ (mp->close_file)(mp,mp->output_file);
+ return 1;
+}
+
+@ @(mplibsvg.h@>=
+#ifndef MPLIBSVG_H
+#define MPLIBSVG_H 1
+#include "mplibps.h"
+int mp_svg_ship_out (mp_edge_object *hh, int prologues) ;
+#endif
+
+@ @c
+int mp_svg_ship_out (mp_edge_object *hh, int prologues) {
+ return mp_svg_gr_ship_out (hh, prologues, (int)true);
+}
+
+@
+@d do_write_prescript(a,b) {
+ if ( (gr_pre_script((b *)a))!=NULL ) {
+ mp_svg_print_nl (mp, gr_pre_script((b *)a));
+ mp_svg_print_ln(mp);
+ }
+}
+
+@<Write |pre_script| of |p|@>=
+{
+ if (gr_type(p)==mp_fill_code) { do_write_prescript(p,mp_fill_object); }
+ else if (gr_type(p)==mp_stroked_code) { do_write_prescript(p,mp_stroked_object); }
+ else if (gr_type(p)==mp_text_code) { do_write_prescript(p,mp_text_object); }
+}
+
+
+@
+@d do_write_postscript(a,b) {
+ if ( (gr_post_script((b *)a))!=NULL ) {
+ mp_svg_print_nl (mp, gr_post_script((b *)a));
+ mp_svg_print_ln(mp);
+ }
+}
+
+@<Write |post_script| of |p|@>=
+{
+ if (gr_type(p)==mp_fill_code) { do_write_postscript(p,mp_fill_object); }
+ else if (gr_type(p)==mp_stroked_code) { do_write_postscript(p,mp_stroked_object); }
+ else if (gr_type(p)==mp_text_code) { do_write_postscript(p,mp_text_object); }
+}
+
diff --git a/Build/source/texk/web2c/mplibdir/tfmin.w b/Build/source/texk/web2c/mplibdir/tfmin.w
new file mode 100644
index 00000000000..142824258c6
--- /dev/null
+++ b/Build/source/texk/web2c/mplibdir/tfmin.w
@@ -0,0 +1,253 @@
+% Copyright 2008-2009 Taco Hoekwater.
+%
+% This program is free software: you can redistribute it and/or modify
+% it under the terms of the GNU Lesser General Public License as published by
+% the Free Software Foundation, either version 3 of the License, or
+% (at your option) any later version.
+%
+% This program is distributed in the hope that it will be useful,
+% but WITHOUT ANY WARRANTY; without even the implied warranty of
+% MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+% GNU Lesser General Public License for more details.
+%
+% You should have received a copy of the GNU Lesser General Public License
+% along with this program. If not, see <http://www.gnu.org/licenses/>.
+%
+% 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
+
+\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\title{Reading TEX metrics files}
+\pdfoutput=1
+
+@ Introduction.
+
+@ Needed headers and macros
+
+@d qi(A) (quarterword)(A) /* to store eight bits in a quarterword */
+@d null_font 0 /* the |font_number| for an empty font */
+@d false 0
+@d true 1
+@d hlp1(A) mp->help_line[0]=A; }
+@d hlp2(A,B) mp->help_line[1]=A; hlp1(B)
+@d hlp3(A,B,C) mp->help_line[2]=A; hlp2(B,C)
+@d help3 { mp->help_ptr=3; hlp3 /* use this with three help lines */
+
+@c
+#include <w2c/config.h>
+#include <stdio.h>
+#include <stdlib.h>
+#include <string.h>
+#include "mplib.h"
+#include "mpmp.h" /* internal header */
+#include "mpmath.h" /* internal header */
+#include "mpstrings.h" /* internal header */
+@<Declarations@>;
+@h
+
+@ 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.
+
+@<Declarations@>=
+font_number mp_read_font_info (MP mp, char *fname);
+
+@ @c
+font_number mp_read_font_info (MP mp, char *fname) {
+ boolean file_opened; /* has |tfm_infile| been opened? */
+ font_number n; /* the number to return */
+ halfword lf,tfm_lh,bc,ec,nw,nh,nd; /* subfile size parameters */
+ size_t whd_size; /* words needed for heights, widths, and depths */
+ int i,ii; /* |font_info| indices */
+ int jj; /* counts bytes to be ignored */
+ int z; /* used to compute the design size */
+ int d; /* height, width, or depth as a fraction of design size times $2^{-8}$ */
+ int h_and_d; /* height and depth indices being unpacked */
+ int tfbyte = 0; /* a byte read from the file */
+ n=null_font;
+ @<Open |tfm_infile| for input@>;
+ @<Read data from |tfm_infile|; if there is no room, say so and |goto done|;
+ otherwise |goto bad_tfm| or |goto done| as appropriate@>;
+BAD_TFM:
+ @<Complain that the \.{TFM} file is bad@>;
+DONE:
+ if ( file_opened ) (mp->close_file)(mp,mp->tfm_infile);
+ if ( n!=null_font ) {
+ mp->font_ps_name[n]=mp_xstrdup(mp,fname);
+ mp->font_name[n]=mp_xstrdup(mp,fname);
+ }
+ return n;
+}
+
+@ \MP\ doesn't bother to check the entire \.{TFM} file for errors or explain
+precisely what is wrong if it does find a problem. Programs called \.{TFtoPL}
+@.TFtoPL@> @.PLtoTF@>
+and \.{PLtoTF} can be used to debug \.{TFM} files.
+
+@<Complain that the \.{TFM} file is bad@>=
+{
+ char msg[256];
+ const char *hlp[] = {
+ "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",
+ NULL };
+ if ( file_opened )
+ hlp[2]="is right, try asking an expert to fix the TFM file";
+ mp_snprintf(msg, 256, "Font %s not usable: TFM file %s", fname,
+ ( file_opened ? "is bad" : "not found"));
+ mp_error(mp, msg, hlp, true);
+}
+
+@ @<Read data from |tfm_infile|; if there is no room, say so...@>=
+@<Read the \.{TFM} size fields@>;
+@<Use the size fields to allocate space in |font_info|@>;
+@<Read the \.{TFM} header@>;
+@<Read the character data and the width, height, and depth tables and
+ |goto done|@>
+
+@ A bad \.{TFM} file can be shorter than it claims to be. The code given here
+might try to read past the end of the file if this happens. Changes will be
+needed if it causes a system error to refer to |tfm_infile^| or call
+|get_tfm_infile| when |eof(tfm_infile)| is true. For example, the definition
+@^system dependencies@>
+of |tfget| could be changed to
+``|begin get(tfm_infile); if eof(tfm_infile) then goto bad_tfm; end|.''
+
+@d tfget do {
+ size_t wanted=1;
+ unsigned char abyte=0;
+ void *tfbyte_ptr = &abyte;
+ (mp->read_binary_file)(mp,mp->tfm_infile, &tfbyte_ptr,&wanted);
+ if (wanted==0) goto BAD_TFM;
+ tfbyte = (int)abyte;
+} while (0)
+@d read_two(A) { (A)=tfbyte;
+ if ( (A)>127 ) goto BAD_TFM;
+ tfget; (A)=(A)*0400+tfbyte;
+}
+@d tf_ignore(A) { for (jj=(A);jj>=1;jj--) tfget; }
+
+@<Read the \.{TFM} size fields@>=
+tfget; read_two(lf);
+tfget; read_two(tfm_lh);
+tfget; read_two(bc);
+tfget; read_two(ec);
+if ( (bc>1+ec)||(ec>255) ) goto BAD_TFM;
+tfget; read_two(nw);
+tfget; read_two(nh);
+tfget; read_two(nd);
+whd_size=(size_t)((ec+1-bc)+nw+nh+nd);
+if ( lf<(int)(6+(size_t)tfm_lh+whd_size) ) goto BAD_TFM;
+tf_ignore(10)
+
+@ Offsets are added to |char_base[n]| and |width_base[n]| so that is not
+necessary to apply the |so| and |qo| macros when looking up the width of a
+character in the string pool. In order to ensure nonnegative |char_base|
+values when |bc>0|, it may be necessary to reserve a few unused |font_info|
+elements.
+
+@<Use the size fields to allocate space in |font_info|@>=
+if ( mp->next_fmem<(size_t)bc)
+ mp->next_fmem=(size_t)bc; /* ensure nonnegative |char_base| */
+if (mp->last_fnum==mp->font_max)
+ mp_reallocate_fonts(mp,(mp->font_max+(mp->font_max/4)));
+while (mp->next_fmem+whd_size>=mp->font_mem_size) {
+ size_t l = mp->font_mem_size+(mp->font_mem_size/4);
+ font_data *font_info;
+ font_info = mp_xmalloc (mp,(l+1),sizeof(font_data));
+ memset (font_info,0,sizeof(font_data)*(l+1));
+ memcpy (font_info,mp->font_info,sizeof(font_data)*(mp->font_mem_size+1));
+ mp_xfree(mp->font_info);
+ mp->font_info = font_info;
+ mp->font_mem_size = l;
+}
+mp->last_fnum++;
+n=mp->last_fnum;
+mp->font_bc[n]=(eight_bits)bc;
+mp->font_ec[n]=(eight_bits)ec;
+mp->char_base[n]=(int)(mp->next_fmem-(size_t)bc);
+mp->width_base[n]=(int)(mp->next_fmem+(size_t)(ec-bc)+1);
+mp->height_base[n]=mp->width_base[n]+nw;
+mp->depth_base[n]=mp->height_base[n]+nh;
+mp->next_fmem=mp->next_fmem+whd_size;
+
+
+@ This macro is a bit odd, but it works.
+
+@d integer_as_fraction(A) (int)(A)
+
+@<Read the \.{TFM} header@>=
+if ( tfm_lh<2 ) goto BAD_TFM;
+tf_ignore(4);
+tfget; read_two(z);
+tfget; z=z*0400+tfbyte;
+tfget; z=z*0400+tfbyte; /* now |z| is 16 times the design size */
+mp->font_dsize[n]=mp_take_fraction(mp, z,integer_as_fraction(267432584));
+ /* times ${72\over72.27}2^{28}$ to convert from \TeX\ points */
+tf_ignore(4*(tfm_lh-2))
+
+@ @<Read the character data and the width, height, and depth tables...@>=
+ii=mp->width_base[n];
+i=mp->char_base[n]+bc;
+while ( i<ii ) {
+ tfget; mp->font_info[i].qqqq.b0=qi(tfbyte);
+ tfget; h_and_d=tfbyte;
+ mp->font_info[i].qqqq.b1=qi(h_and_d / 16);
+ mp->font_info[i].qqqq.b2=qi(h_and_d % 16);
+ tfget; tfget;
+ i++;
+}
+while ( i<(int)mp->next_fmem ) {
+ @<Read a four byte dimension, scale it by the design size, store it in
+ |font_info[i]|, and increment |i|@>;
+}
+goto DONE
+
+@ The raw dimension read into |d| should have magnitude at most $2^{24}$ when
+interpreted as an integer, and this includes a scale factor of $2^{20}$. Thus
+we can multiply it by sixteen and think of it as a |fraction| that has been
+divided by sixteen. This cancels the extra scale factor contained in
+|font_dsize[n|.
+
+@<Read a four byte dimension, scale it by the design size, store it in...@>=
+{
+tfget; d=tfbyte;
+if ( d>=0200 ) d=d-0400;
+tfget; d=d*0400+tfbyte;
+tfget; d=d*0400+tfbyte;
+tfget; d=d*0400+tfbyte;
+mp->font_info[i].sc=mp_take_fraction(mp, d*16,integer_as_fraction(mp->font_dsize[n]));
+i++;
+}
+
+@ This function does no longer use the file name parser, because |fname| is
+a C string already.
+
+@<Open |tfm_infile| for input@>=
+file_opened=false;
+mp_ptr_scan_file(mp, fname);
+if ( strlen(mp->cur_area)==0 ) { mp_xfree(mp->cur_area); mp->cur_area=NULL; }
+if ( strlen(mp->cur_ext)==0 ) {
+ mp_xfree(mp->cur_ext);
+ mp->cur_ext=mp_xstrdup(mp,".tfm");
+}
+mp_pack_file_name(mp, mp->cur_name,mp->cur_area,mp->cur_ext);
+mp->tfm_infile = (mp->open_file)(mp, mp->name_of_file, "r",mp_filetype_metrics);
+if ( !mp->tfm_infile ) goto BAD_TFM;
+file_opened=true
+
+
+
+
+
+
+
+