diff options
| author | Denis Bitouzé <dbitouze@wanadoo.fr> | 2021-02-25 18:23:07 +0000 |
|---|---|---|
| committer | Denis Bitouzé <dbitouze@wanadoo.fr> | 2021-02-25 18:23:07 +0000 |
| commit | c6101f91d071883b48b1b4b51e5eba0f36d9a78d (patch) | |
| tree | 1bf7f5a881d7a4f5c5bf59d0b2821943dd822372 /Build/source/texk/web2c/mplibdir | |
| parent | 07ee7222e389b0777456b427a55c22d0e6ffd267 (diff) | |
French translation for tlmgr updated
git-svn-id: svn://tug.org/texlive/trunk@57912 c570f23f-e606-0410-a88d-b1316a301751
Diffstat (limited to 'Build/source/texk/web2c/mplibdir')
26 files changed, 0 insertions, 74020 deletions
diff --git a/Build/source/texk/web2c/mplibdir/ChangeLog b/Build/source/texk/web2c/mplibdir/ChangeLog deleted file mode 100644 index 87b2fa9be65..00000000000 --- a/Build/source/texk/web2c/mplibdir/ChangeLog +++ /dev/null @@ -1,575 +0,0 @@ -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 deleted file mode 100644 index 4b0fc7fd59f..00000000000 --- a/Build/source/texk/web2c/mplibdir/am/libmplib.am +++ /dev/null @@ -1,103 +0,0 @@ -## 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 deleted file mode 100644 index 09ace983a0b..00000000000 --- a/Build/source/texk/web2c/mplibdir/am/libmputil.am +++ /dev/null @@ -1,15 +0,0 @@ -## 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 deleted file mode 100644 index a8b0da6ee26..00000000000 --- a/Build/source/texk/web2c/mplibdir/am/mplib.am +++ /dev/null @@ -1,92 +0,0 @@ -## 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 deleted file mode 100644 index de3c63322ad..00000000000 --- a/Build/source/texk/web2c/mplibdir/avl.c +++ /dev/null @@ -1,2638 +0,0 @@ - -/* 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 deleted file mode 100644 index 9771c095220..00000000000 --- a/Build/source/texk/web2c/mplibdir/avl.h +++ /dev/null @@ -1,466 +0,0 @@ - -/* - 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 deleted file mode 100644 index 9f99759336e..00000000000 --- a/Build/source/texk/web2c/mplibdir/decContext.c +++ /dev/null @@ -1,437 +0,0 @@ -/* ------------------------------------------------------------------ */
-/* 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 deleted file mode 100644 index 82e4fcf2db3..00000000000 --- a/Build/source/texk/web2c/mplibdir/decContext.h +++ /dev/null @@ -1,254 +0,0 @@ -/* ------------------------------------------------------------------ */
-/* 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 deleted file mode 100644 index 19230b89576..00000000000 --- a/Build/source/texk/web2c/mplibdir/decNumber.c +++ /dev/null @@ -1,8141 +0,0 @@ -/* ------------------------------------------------------------------ */
-/* 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, ©stat); // 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 deleted file mode 100644 index 6f8a5a3ee46..00000000000 --- a/Build/source/texk/web2c/mplibdir/decNumber.h +++ /dev/null @@ -1,182 +0,0 @@ -/* ------------------------------------------------------------------ */
-/* 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 deleted file mode 100644 index 5c88a5eaaff..00000000000 --- a/Build/source/texk/web2c/mplibdir/decNumberLocal.h +++ /dev/null @@ -1,757 +0,0 @@ -/* ------------------------------------------------------------------ */
-/* 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 deleted file mode 100755 index 41ccb942bd5..00000000000 --- a/Build/source/texk/web2c/mplibdir/dvitomp.test +++ /dev/null @@ -1,21 +0,0 @@ -#! /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 deleted file mode 100644 index 59b747c66dd..00000000000 --- a/Build/source/texk/web2c/mplibdir/lmplib.c +++ /dev/null @@ -1,2060 +0,0 @@ -/* 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 deleted file mode 100644 index dcbd01b31ea..00000000000 --- a/Build/source/texk/web2c/mplibdir/mp.w +++ /dev/null @@ -1,35650 +0,0 @@ -% 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 deleted file mode 100644 index 6c0ee6d00a6..00000000000 --- a/Build/source/texk/web2c/mplibdir/mpmath.w +++ /dev/null @@ -1,1925 +0,0 @@ -% $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 deleted file mode 100644 index 159fae019af..00000000000 --- a/Build/source/texk/web2c/mplibdir/mpmathbinary.w +++ /dev/null @@ -1,1838 +0,0 @@ -% $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 deleted file mode 100644 index 5c2a8fe624e..00000000000 --- a/Build/source/texk/web2c/mplibdir/mpmathdecimal.w +++ /dev/null @@ -1,2011 +0,0 @@ -% $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 deleted file mode 100644 index cb14969365f..00000000000 --- a/Build/source/texk/web2c/mplibdir/mpmathdouble.w +++ /dev/null @@ -1,1487 +0,0 @@ -% $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 deleted file mode 100644 index 5e447270678..00000000000 --- a/Build/source/texk/web2c/mplibdir/mpost.w +++ /dev/null @@ -1,1492 +0,0 @@ -% 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 deleted file mode 100644 index 25dcf91b182..00000000000 --- a/Build/source/texk/web2c/mplibdir/mpstrings.w +++ /dev/null @@ -1,447 +0,0 @@ -% 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 deleted file mode 100755 index 9cbc68ad4e6..00000000000 --- a/Build/source/texk/web2c/mplibdir/mptraptest.test +++ /dev/null @@ -1,40 +0,0 @@ -#! /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 deleted file mode 100644 index f08645a28f0..00000000000 --- a/Build/source/texk/web2c/mplibdir/mpxout.w +++ /dev/null @@ -1,4380 +0,0 @@ -% 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 deleted file mode 100644 index 742522c2ff7..00000000000 --- a/Build/source/texk/web2c/mplibdir/pngout.w +++ /dev/null @@ -1,911 +0,0 @@ -% 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 deleted file mode 100644 index 3c46d31879c..00000000000 --- a/Build/source/texk/web2c/mplibdir/psout.w +++ /dev/null @@ -1,6502 +0,0 @@ -% 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 deleted file mode 100644 index 94801da5205..00000000000 --- a/Build/source/texk/web2c/mplibdir/svgout.w +++ /dev/null @@ -1,1343 +0,0 @@ -% 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 deleted file mode 100644 index 142824258c6..00000000000 --- a/Build/source/texk/web2c/mplibdir/tfmin.w +++ /dev/null @@ -1,253 +0,0 @@ -% 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 - - - - - - - - |