diff options
Diffstat (limited to 'Build/source/texk')
| -rw-r--r-- | Build/source/texk/web2c/mplibdir/am/mplib.am | 52 | ||||
| -rw-r--r-- | Build/source/texk/web2c/mplibdir/avl.c | 2636 | ||||
| -rw-r--r-- | Build/source/texk/web2c/mplibdir/avl.h | 467 | ||||
| -rw-r--r-- | Build/source/texk/web2c/mplibdir/lmplib.c | 1238 | ||||
| -rw-r--r-- | Build/source/texk/web2c/mplibdir/memio.w | 405 | ||||
| -rw-r--r-- | Build/source/texk/web2c/mplibdir/mp.w | 26427 | ||||
| -rw-r--r-- | Build/source/texk/web2c/mplibdir/mpost.w | 939 | ||||
| -rw-r--r-- | Build/source/texk/web2c/mplibdir/mpxout.w | 4312 | ||||
| -rw-r--r-- | Build/source/texk/web2c/mplibdir/psout.w | 6246 | ||||
| -rw-r--r-- | Build/source/texk/web2c/mplibdir/svgout.w | 1314 | ||||
| -rw-r--r-- | Build/source/texk/web2c/mplibdir/tfmin.w | 242 |
11 files changed, 44278 insertions, 0 deletions
diff --git a/Build/source/texk/web2c/mplibdir/am/mplib.am b/Build/source/texk/web2c/mplibdir/am/mplib.am index 12f7dc33e13..c979b25f7d8 100644 --- a/Build/source/texk/web2c/mplibdir/am/mplib.am +++ b/Build/source/texk/web2c/mplibdir/am/mplib.am @@ -1,2 +1,54 @@ ## texk/web2c/mplibdir/am/mplib.am: Makefile fragment for MetaPost. +## metapost +## +bin_PROGRAMS += newmpost + +EXTRA_PROGRAMS += newmpost + +EXTRA_LIBRARIES += libmplib.a + +newmpost_c_h = mpost.c mpxout.c +newmpost_web = mplibdir/mpost.w mplibdir/mpxout.w + +newmpost_CPPFLAGS = -I. -I$(srcdir)/mplibdir +newmpost_DEPENDENCIES = libmplib.a +newmpost_LDADD = libmplib.a $(KPATHSEA_LIBS) -lm +newmpost_SOURCES = $(newmpost_c_h) + +$(newmpost_c_h): mpost-ctangle libmplib.a +mpost-ctangle: ctangle$(EXEEXT) $(newmpost_web) + CWEBINPUTS=$(srcdir)/mplibdir $(ctangle) mpost.w + CWEBINPUTS=$(srcdir)/mplibdir $(ctangle) mpxout.w + echo timestamp >$@ + touch $(newmpost_c_h) + +DISTCLEANFILES += $(newmpost_c_h) mpost-ctangle + +## These files are mutually dependent +libmplib_c_h = mp.c mplib.h mpmp.h mppsout.h psout.c mplibps.h svgout.c memio.c tfmin.c +libmplib_true_c = mplibdir/avl.h mplibdir/avl.c +libmplib_web = $(libmplib_true_c) mplibdir/mp.w mplibdir/psout.w +libmplib_web += mplibdir/svgout.w mplibdir/memio.w mplibdir/tfmin.w + +libmplib_a_CPPFLAGS = -I. -I$(srcdir)/mplibdir +libmplib_a_SOURCES = $(libmplib_c_h) $(libmplib_true_c) + +$(libmplib_c_h): mplib-ctangle $(libmplib_true_c) +mplib-ctangle: ctangle$(EXEEXT) $(libmplib_web) + CWEBINPUTS=$(srcdir)/mplibdir $(ctangle) mp.w + CWEBINPUTS=$(srcdir)/mplibdir $(ctangle) psout.w + CWEBINPUTS=$(srcdir)/mplibdir $(ctangle) svgout.w + CWEBINPUTS=$(srcdir)/mplibdir $(ctangle) tfmin.w + CWEBINPUTS=$(srcdir)/mplibdir $(ctangle) memio.w + echo timestamp >$@ + touch $(libmplib_c_h) + +EXTRA_DIST += $(libmplib_web) + +DISTCLEANFILES += $(libmplib_c_h) mplib-ctangle + +# only used by luatex, perhaps should not be mentioned here +EXTRA_DIST += mplibdir/lmplib.c + + diff --git a/Build/source/texk/web2c/mplibdir/avl.c b/Build/source/texk/web2c/mplibdir/avl.c new file mode 100644 index 00000000000..a8421d4c93d --- /dev/null +++ b/Build/source/texk/web2c/mplibdir/avl.c @@ -0,0 +1,2636 @@ + +/* 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 + +void * +avl_default_item_copy (const void *item) +{ + return (void *) item; +} + +void * +avl_default_item_dispose (void *item) +{ + 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 = idx - get_rank (a)) != 0) + { + if (c < 0) + a = sub_left (a); + else + { + idx = 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, !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, (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; + int dir, bal; + + 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, !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, (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; + + 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; + int 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; + int 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 -= get_rank (a); + r = &sub_right (a); + } + } + else + { + while (delta < -1) + { + a = *r; + delta += is_lskew (a) + 1; + n -= 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, n); + r = &sub_left (a); + } + n = 1; + } + else + { + while (delta > +1) + { + a = *r; + delta -= is_rskew (a) + 1; + incr_rank (a, 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, 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, + t0->count + 1); + } + else + { + if (node_del_last (t0, &h) == 2) + ++delta; + (void) join_right ((avl_node *) h.ptr, t0->root, &t1->root, delta, + 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 = 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 -= get_rank (a); + else + na = 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] = 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] += an[k - 1] - 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, nn)); + } + else + { + h[1] = + hh + (2 == + join_left (a, r + 1, sub_right (a), h[1] - hh, + 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], nn)); + } + else + { + h[0] = + hh + (2 == + join_right (a, sub_left (a), r, hh - h[0], nn)); + } + } + + if (--k == 0) + break; + } /* for p */ + + t0->root = r[0]; + t1->root = r[1]; + t0->count = n[0] - 1; + t1->count = n[1] - 1; + } /* if k==0 */ + + /* Detach split node */ + detach_node (sn, t, NULL); + t->root = NULL; + t->count = 0; + + return 1; + } +} + +/* Inorder traversal */ + +void +avl_walk (avl_tree t, avl_item_func proc, void *param) +{ +#ifndef AVL_NULLCHECKS + if (t == NULL || t->root == NULL) +#else + if (t->root == NULL) +#endif + return; + + { + avl_node *a = t->root, *p; + + while (1) + { + while (sub_left (a) != NULL) + a = sub_left (a); + + while (1) + { + (*proc) (get_item (a), param); + if (sub_right (a) != NULL) + break; + do + { + p = a; + a = p->up; + if (a == NULL) + return; + } + while (p != sub_left (a)); + } + a = sub_right (a); + } + } +} + +/* recursive helper for 'avl_slice' */ +static int +node_slice (avl_node ** root, avl_node ** cur, avl_tree tree, avl_size_t len) +{ + avl_size_t mid = len / 2; + + if (mid == 0) + { + if ((*root = new_node ((*cur)->item, /*parent */ NULL, tree)) == NULL) + return -1; + sub_left (*root) = NULL; + sub_right (*root) = NULL; + rbal (*root) = 4; + *cur = node_next (*cur); + return 0; + + } + else if ((*root = new_node (NULL, /*parent */ NULL, tree)) == NULL) + { + return -1; + } + else + { + avl_node *p = *root; + int h0, h1 = -1; + + rbal (p) = (mid + 1) << 2; + + if ((h0 = node_slice (&sub_left (p), cur, tree, mid)) < 0) + return -1; + + p->item = (*tree->copy) ((*cur)->item); + sub_left (p)->up = p; + + *cur = node_next (*cur); + + if (len -= mid + 1) + { + if ((h1 = node_slice (&sub_right (p), cur, tree, len)) < 0) + return -1; + sub_right (p)->up = p; + } + + if (h0 > h1) + set_lskew (p); + else if (h0 < h1) + { + set_rskew (p); + return 1 + h1; + } + return 1 + h0; + } +} + +/* Return a slice t[lo,hi) as a new tree */ + +avl_tree +avl_slice (avl_tree t, avl_size_t lo_idx, avl_size_t hi_idx, void *param) +{ +#ifndef AVL_NULLCHECKS + if (t == NULL) + return NULL; +#endif /* AVL_NULLCHECKS */ + + if (lo_idx > hi_idx || lo_idx > t->count) + return NULL; + if (lo_idx < 1) + lo_idx = 1; + if (hi_idx > t->count + 1) + hi_idx = t->count + 1; + + { + avl_tree tt = avl_create (t->compare, + t->copy, + t->dispose, + t->alloc, + t->dealloc, + param); + + if (tt == NULL) + { + AVL_SHOW_ERROR ("%s\n", + "couldn't allocate new handle in avl_slice()"); + return NULL; + } + + if (lo_idx < hi_idx) + { + avl_node *cur = node_find_index (lo_idx, t); + + if (node_slice (&tt->root, &cur, t, tt->count = hi_idx - lo_idx) < 0) + { + AVL_SHOW_ERROR ("%s\n", "couldn't allocate node in avl_slice()"); + node_empty (tt); + (*t->dealloc) (tt); + return NULL; + } + tt->root->up = NULL; + } + return tt; + } +} + +/* recursive helper for 'avl_xload' */ + +static int +node_load (avl_node ** root, avl_itersource cur, void **pres, avl_tree desc, + avl_size_t len) +{ + avl_size_t mid = len / 2; + + if (mid == 0) + { + if (0 != (*cur->f) (cur, pres) + || (*root = new_node (*pres, /*parent */ NULL, desc)) == NULL) + return -1; + sub_left (*root) = NULL; + sub_right (*root) = NULL; + rbal (*root) = 4; + return 0; + + } + else if ((*root = new_node (NULL, /*parent */ NULL, desc)) == NULL) + { + return -1; + } + else + { + avl_node *p = *root; + int h0, h1 = -1; + + rbal (p) = (mid + 1) << 2; + + if ((h0 = node_load (&sub_left (p), cur, pres, desc, mid)) < 0) + return -1; + + if (0 != (*cur->f) (cur, pres)) + return -1; + + p->item = (*desc->copy) (*pres); + sub_left (p)->up = p; + + if (len -= mid + 1) + { + if ((h1 = node_load (&sub_right (p), cur, pres, desc, len)) < 0) + return -1; + sub_right (p)->up = p; + } + + if (h0 > h1) + set_lskew (p); + else if (h0 < h1) + { + set_rskew (p); + return 1 + h1; + } + return 1 + h0; + } +} + +/* Load 'len' items from itersource */ + +avl_tree +avl_xload (avl_itersource src, void **pres, avl_size_t len, avl_config conf, + void *tree_param) +{ +#ifndef AVL_NULLCHECKS + if (src == NULL) + return NULL; + { +#endif /* AVL_NULLCHECKS */ + + avl_tree tt = avl_create (conf->compare, + conf->copy, + conf->dispose, + conf->alloc, + conf->dealloc, + tree_param); + + if (tt == NULL) + { + AVL_SHOW_ERROR ("%s\n", "couldn't allocate new handle in avl_load()"); + return NULL; + } + + if (len) + { + if (node_load (&tt->root, src, pres, tt, tt->count = len) < 0) + { + AVL_SHOW_ERROR ("%s\n", "couldn't allocate node in avl_load()"); + node_empty (tt); + (*tt->dealloc) (tt); + return NULL; + } + tt->root->up = NULL; + } + return tt; +#ifndef AVL_NULLCHECKS + } +#endif +} + +#ifdef HAVE_AVL_VERIFY + +/* Verification routine */ +typedef enum +{ + okay = 0, + bad_parent = 1, + bad_rank = 2, + out_of_balance = 3, + out_of_order = 4, + diff_mismatch = 5, + count_mismatch = 6 +} +avl_verify_code; + +static avl_bool_t +avl_error (avl_verify_code err) +{ + static char *errmess[] = { + "Bad parent link", + "Rank error", + "Out of balance", + "Out of order", + "Differential mismatch", + "Count mismatch" + }; + + AVL_SHOW_ERROR ("Invalid avl_tree: %s\n", errmess[err - 1]); + return avl_false; +} + +static int bals[] = { 1, 0, 2 }; + +/* + helper for recursive 'avl_verify' function + return 0 iff okay + */ + +static avl_verify_code +node_verify (avl_node * root, avl_tree tree, int *h, avl_size_t * c, + avl_node * up) +{ + avl_verify_code err = okay; + + if (root == NULL) + *h = AVL_MIN_DEPTH, *c = 0; + else + { +#define AVL_ASSERT(expr,n) if (expr) ; else { err = n; break; } +#define CHECK(err) if (err) break + + avl_node *left, *right; + avl_size_t c_[2]; + int h_[2], delta; + + left = sub_left (root); + right = sub_right (root); + do + { + AVL_ASSERT (root->up == up, bad_parent); + CHECK (err = node_verify (left, tree, h_, c_, root)); + AVL_ASSERT (get_rank (root) == *c_ + 1, bad_rank); + CHECK (err = node_verify (right, tree, h_ + 1, c_ + 1, root)); + delta = h_[1] - h_[0]; + AVL_ASSERT (delta >= -1 && delta <= +1, out_of_balance); + AVL_ASSERT (get_bal (root) == bals[delta + 1], diff_mismatch); + AVL_ASSERT (left == NULL + || (Item_Compare (tree->compare, tree, get_item (left), + get_item (root)) <= + 0 CMPERR_CHECK__VERIFY (tree->param)), + out_of_order); + AVL_ASSERT (right == NULL + || + (Item_Compare + (tree->compare, tree, get_item (root), + get_item (right)) <= + 0 CMPERR_CHECK__VERIFY (tree->param)), out_of_order); + *h = 1 + (h_[0] > h_[1] ? h_[0] : h_[1]); + *c = 1 + c_[0] + c_[1]; + } + while (0); + } + return err; +} + +avl_bool_t +avl_verify (avl_tree t) +{ +#ifndef AVL_NULLCHECKS + if (t == NULL) + return avl_false; +#endif /* AVL_NULLCHECKS */ + { + int h; + avl_size_t c; + avl_verify_code err; + + err = node_verify (t->root, t, &h, &c, (avl_node *) NULL); + if (err) + return avl_error (err); + if (c != t->count) + return avl_error (count_mismatch); + return avl_true; + } +} +#endif /* HAVE_AVL_VERIFY */ + +/**************** + * * + * ITERATORS * + * * + ****************/ + +typedef enum +{ + AVL_ITERATOR_PRE, + AVL_ITERATOR_POST, + AVL_ITERATOR_INTREE +} +avl_status_t; + +struct avl_iterator_ +{ + avl_node *pos; + avl_tree tree; + avl_status_t status; +}; + +#define get_root(i) i->tree->root +#define is_pre(i) i->status == AVL_ITERATOR_PRE +#define is_post(i) i->status == AVL_ITERATOR_POST +#define set_pre_iterator(i) i->status = AVL_ITERATOR_PRE +#define set_post_iterator(i) i->status = AVL_ITERATOR_POST +#define set_in_iterator(i) i->status = AVL_ITERATOR_INTREE + +/* Position existing iterator [iter] at node matching [item] in its own tree, + * if it exists ; otherwise do nothing + */ + +void +avl_iterator_seek (const void *item, avl_iterator iter) +{ + avl_node *p = node_find (item, iter->tree); + + if (p != NULL) + { + set_in_iterator (iter); + iter->pos = p; + } +} + +void +avl_iterator_seek_index (avl_size_t idx, avl_iterator iter) +{ + avl_node *p = node_find_index (idx, iter->tree); + + if (p != NULL) + { + set_in_iterator (iter); + iter->pos = p; + } +} + +/* Return item pointer at current position */ + +void * +avl_iterator_cur (avl_iterator iter) +{ + return iter->pos != NULL ? get_item (iter->pos) : NULL; +} + +avl_size_t +avl_iterator_count (avl_iterator iter) +{ + return iter->tree->count; +} + +avl_size_t +avl_iterator_index (avl_iterator iter) +{ + if (iter->pos != NULL) + return get_index (iter->pos); + else if (is_pre (iter)) + return 0; + else + return iter->tree->count + 1; +} + +/* Rustic: */ + +avl_iterator +avl_iterator_new (avl_tree t, avl_ini_t ini, ...) +{ + va_list args; + avl_iterator iter = NULL; + + va_start (args, ini); + + if (t == NULL) + goto finish; + + if ((iter = (*t->alloc) (sizeof (struct avl_iterator_))) == NULL) + { + AVL_SHOW_ERROR ("%s\n", "couldn't create iterator"); + goto finish; + } + + iter->pos = NULL; + iter->tree = t; + + if (ini != AVL_ITERATOR_INI_INTREE) + { + iter->status = + (ini == AVL_ITERATOR_INI_PRE) ? AVL_ITERATOR_PRE : AVL_ITERATOR_POST; + } + else + { + const void *item = NULL; + + item = va_arg (args, const void *); + + set_pre_iterator (iter); + + if (item == NULL) + AVL_SHOW_ERROR ("%s\n", "missing argument to avl_iterator_new()"); + else + avl_iterator_seek (item, iter); + } + +finish: + va_end (args); + return iter; +} + +/* + * The following used to write to memory after it was freed. + * Corrected by: David Turner <novalis@openplans.org> + */ +void +avl_iterator_kill (avl_iterator iter) +{ + if (iter != NULL) + { + avl_dealloc_func dealloc = iter->tree->dealloc; + iter->pos = NULL; + iter->tree = NULL; + (*dealloc) (iter); + } +} + +void * +avl_iterator_next (avl_iterator iter) +{ + avl_node *a = iter->pos; + + if (is_post (iter)) + return NULL; + + if (is_pre (iter)) + { + a = get_root (iter); + if (a != NULL) + { + a = node_first (a); + set_in_iterator (iter); + } + } + else + { + a = node_next (a); + if (a == NULL) + set_post_iterator (iter); + } + + iter->pos = a; + return a != NULL ? get_item (a) : NULL; +} + +void * +avl_iterator_prev (avl_iterator iter) +{ + avl_node *a = iter->pos; + + if (is_pre (iter)) + return NULL; + + if (is_post (iter)) + { + a = get_root (iter); + if (a != NULL) + { + a = node_last (a); + set_in_iterator (iter); + } + } + else + { + a = node_prev (a); + if (a == NULL) + set_pre_iterator (iter); + } + + iter->pos = a; + return a != NULL ? get_item (a) : NULL; +} + +/* Remove node at current position */ + +/* Move cursor to next position */ + +avl_code_t +avl_iterator_del (avl_iterator iter, void **backup) +{ + if (iter == NULL || iter->pos == NULL) + return 0; + { + avl_node *a = iter->pos, *p; + + p = node_next (a); + if (p == NULL) + set_post_iterator (iter); + iter->pos = p; + return rebalance_del (a, iter->tree, backup); + } +} diff --git a/Build/source/texk/web2c/mplibdir/avl.h b/Build/source/texk/web2c/mplibdir/avl.h new file mode 100644 index 00000000000..a78d50b91cf --- /dev/null +++ b/Build/source/texk/web2c/mplibdir/avl.h @@ -0,0 +1,467 @@ + +/* + 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_probe mp_avl_probe +#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 */ + +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/lmplib.c b/Build/source/texk/web2c/mplibdir/lmplib.c new file mode 100644 index 00000000000..8e0823ece06 --- /dev/null +++ b/Build/source/texk/web2c/mplibdir/lmplib.c @@ -0,0 +1,1238 @@ +/* lmplib.c + + Copyright 2006-2008 Taco Hoekwater <taco@luatex.org> + + This file is part of LuaTeX. + + LuaTeX is free software; you can redistribute it and/or modify it under + the terms of the GNU 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 "config.h" +#include <stdlib.h> +#include <string.h> +#include <unistd.h> +#include <math.h> /* temporary */ + +#ifndef pdfTeX +# include <lua.h> +# include <lauxlib.h> +# include <lualib.h> +#else +# include <../lua51/lua.h> +# include <../lua51/lauxlib.h> +# include <../lua51/lualib.h> +#endif + +#include "mplib.h" +#include "mplibps.h" + + /*@unused@*/ static const char _svn_version[] = + "$Id: lmplib.c 1364 2008-07-04 16:09:46Z taco $ $URL: http://scm.foundry.supelec.fr/svn/luatex/trunk/src/texk/web2c/luatexdir/lua/lmplib.c $"; + +/* metatable identifiers and tests */ + +#define MPLIB_METATABLE "MPlib" +#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) + +/* Lua string pre-hashing */ + +#define mplib_init_S(a) do { \ + lua_pushliteral(L,#a); \ + mplib_##a##_ptr = (char *)lua_tostring(L,-1); \ + mplib_##a##_index = luaL_ref (L,LUA_REGISTRYINDEX); \ + } while (0) + +#define mplib_push_S(a) do { \ + lua_rawgeti(L,LUA_REGISTRYINDEX,mplib_##a##_index); \ + } while (0) + +#define mplib_is_S(a,i) (mplib_##a##_ptr==(char *)lua_tostring(L,i)) + +#define mplib_make_S(a) \ + static int mplib_##a##_index = 0; \ + static char *mplib_##a##_ptr = NULL + +static int mplib_type_Ses[mp_special_code + 1] = { 0 }; /* [0] is not used */ + +mplib_make_S(fill); +mplib_make_S(outline); +mplib_make_S(text); +mplib_make_S(special); +mplib_make_S(start_bounds); +mplib_make_S(stop_bounds); +mplib_make_S(start_clip); +mplib_make_S(stop_clip); + +mplib_make_S(left_type); +mplib_make_S(right_type); +mplib_make_S(x_coord); +mplib_make_S(y_coord); +mplib_make_S(left_x); +mplib_make_S(left_y); +mplib_make_S(right_x); +mplib_make_S(right_y); + +mplib_make_S(color); +mplib_make_S(dash); +mplib_make_S(depth); +mplib_make_S(dsize); +mplib_make_S(font); +mplib_make_S(height); +mplib_make_S(htap); +mplib_make_S(linecap); +mplib_make_S(linejoin); +mplib_make_S(miterlimit); +mplib_make_S(path); +mplib_make_S(pen); +mplib_make_S(postscript); +mplib_make_S(prescript); +mplib_make_S(transform); +mplib_make_S(type); +mplib_make_S(width); + +static void mplib_init_Ses(lua_State * L) +{ + mplib_init_S(fill); + mplib_init_S(outline); + mplib_init_S(text); + mplib_init_S(start_bounds); + mplib_init_S(stop_bounds); + mplib_init_S(start_clip); + mplib_init_S(stop_clip); + mplib_init_S(special); + + mplib_type_Ses[mp_fill_code] = mplib_fill_index; + mplib_type_Ses[mp_stroked_code] = mplib_outline_index; + mplib_type_Ses[mp_text_code] = mplib_text_index; + mplib_type_Ses[mp_start_bounds_code] = mplib_start_bounds_index; + mplib_type_Ses[mp_stop_bounds_code] = mplib_stop_bounds_index; + mplib_type_Ses[mp_start_clip_code] = mplib_start_clip_index; + mplib_type_Ses[mp_stop_clip_code] = mplib_stop_clip_index; + mplib_type_Ses[mp_special_code] = mplib_special_index; + + mplib_init_S(left_type); + mplib_init_S(right_type); + mplib_init_S(x_coord); + mplib_init_S(y_coord); + mplib_init_S(left_x); + mplib_init_S(left_y); + mplib_init_S(right_x); + mplib_init_S(right_y); + + mplib_init_S(color); + mplib_init_S(dash); + mplib_init_S(depth); + mplib_init_S(dsize); + mplib_init_S(font); + mplib_init_S(height); + mplib_init_S(htap); + mplib_init_S(linecap); + mplib_init_S(linejoin); + mplib_init_S(miterlimit); + mplib_init_S(path); + mplib_init_S(pen); + mplib_init_S(postscript); + mplib_init_S(prescript); + mplib_init_S(transform); + mplib_init_S(type); + mplib_init_S(width); +} + + +/* Enumeration arrays to map MPlib enums to Lua strings */ + +static const char *interaction_options[] = + { "unknown", "batch", "nonstop", "scroll", "errorstop", NULL }; + +static const char *mplib_filetype_names[] = + { "term", "error", "mp", "log", "ps", "mem", "tfm", "map", "pfb", "enc", NULL }; + +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 }; + + +/* The list of supported MPlib options (not all make sense) */ + +typedef enum { + P_ERROR_LINE, P_MAX_LINE, + P_MAIN_MEMORY, P_HASH_SIZE, P_PARAM_SIZE, P_IN_OPEN, P_RANDOM_SEED, + P_INTERACTION, P_INI_VERSION, P_MEM_NAME, P_JOB_NAME, P_FIND_FILE, + P__SENTINEL } mplib_parm_idx; + +typedef struct { + const char *name; /* parameter name */ + mplib_parm_idx idx; /* parameter index */ +} mplib_parm_struct; + +static mplib_parm_struct mplib_parms[] = { + {"error_line", P_ERROR_LINE }, + {"print_line", P_MAX_LINE }, + {"main_memory", P_MAIN_MEMORY }, + {"hash_size", P_HASH_SIZE }, + {"param_size", P_PARAM_SIZE }, + {"max_in_open", P_IN_OPEN }, + {"random_seed", P_RANDOM_SEED }, + {"interaction", P_INTERACTION }, + {"ini_version", P_INI_VERSION }, + {"mem_name", P_MEM_NAME }, + {"job_name", P_JOB_NAME }, + {"find_file", P_FIND_FILE }, + {NULL, P__SENTINEL } +}; + + +/* 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, *x = NULL; + lua_pushstring(L, fname); + lua_pushstring(L, fmode); + if (ftype >= mp_filetype_text) { + lua_pushnumber(L, (lua_Number)(ftype - mp_filetype_text)); + } else { + lua_pushstring(L, mplib_filetype_names[ftype]); + } + if (lua_pcall(L, 3, 1, 0) != 0) { + fprintf(stdout, "Error in mp.find_file: %s\n", + (char *) lua_tostring(L, -1)); + return NULL; + } + x = (char *) lua_tostring(L, -1); + if (x != NULL) + s = strdup(x); + lua_pop(L, 1); /* pop the string */ + return s; + } else { + lua_pop(L, 1); + } + if (fmode[0] != 'r' || (!access(fname, R_OK)) || ftype) { + return strdup(fname); + } + return NULL; +} + +static int mplib_find_file_function(lua_State * L) +{ + if (!(lua_isfunction(L, -1) || lua_isnil(L, -1))) { + return 1; /* error */ + } + lua_pushstring(L, "mplib_file_finder"); + lua_pushvalue(L, -2); + lua_rawset(L, LUA_REGISTRYINDEX); + return 0; +} + +#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; + options->noninteractive = 1; /* required ! */ + options->find_file = mplib_find_file; + options->print_found_names = 1; + if (lua_type(L, 1) == LUA_TTABLE) { + for (i = 0; mplib_parms[i].name != NULL; i++) { + lua_getfield(L, 1, mplib_parms[i].name); + if (lua_isnil(L, -1)) { + lua_pop(L, 1); + continue; /* skip unset */ + } + switch (mplib_parms[i].idx) { + case P_ERROR_LINE: + options->error_line = (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_MAIN_MEMORY: + options->main_memory = (int)lua_tointeger(L, -1); + break; + case P_HASH_SIZE: + options->hash_size = (unsigned)lua_tointeger(L, -1); + break; + case P_PARAM_SIZE: + options->param_size = (int)lua_tointeger(L, -1); + break; + case P_IN_OPEN: + options->max_in_open = (int)lua_tointeger(L, -1); + 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_INI_VERSION: + options->ini_version = lua_toboolean(L, -1); + break; + case P_MEM_NAME: + options->mem_name = strdup((char *) lua_tostring(L, -1)); + break; + case P_JOB_NAME: + options->job_name = strdup((char *) lua_tostring(L, -1)); + break; + case P_FIND_FILE: + if (mplib_find_file_function(L)) { /* error here */ + fprintf(stdout, + "Invalid arguments to mp.new({find_file=...})\n"); + } + break; + default: + break; + } + lua_pop(L, 1); + } + } + *mp_ptr = mp_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.size != 0) { + lua_pushstring(L, res->term_out.data); + lua_setfield(L, -2, "term"); + } + if (res->error_out.size != 0) { + lua_pushstring(L, res->error_out.data); + lua_setfield(L, -2, "error"); + } + if (res->log_out.size != 0) { + lua_pushstring(L, res->log_out.data); + lua_setfield(L, -2, "log"); + } + if (res->edges != NULL) { + struct mp_edge_object **v; + struct mp_edge_object *p = res->edges; + int i = 1; + lua_newtable(L); + while (p != NULL) { + v = lua_newuserdata(L, sizeof(struct mp_edge_object *)); + *v = p; + luaL_getmetatable(L, MPLIB_FIG_METATABLE); + lua_setmetatable(L, -2); + lua_rawseti(L, -2, i); + i++; + p = p->next; + } + lua_setfield(L, -2, "fig"); + res->edges = NULL; + } + lua_pushnumber(L, (lua_Number)status); + lua_setfield(L, -2, "status"); + return 1; +} + +static int mplib_execute(lua_State * L) +{ + MP *mp_ptr = is_mp(L, 1); + if (*mp_ptr != NULL && lua_isstring(L, 2)) { + size_t l; + char *s = (char *) lua_tolstring(L, 2, &l); + int h = mp_execute(*mp_ptr, s, l); + mp_run_data *res = mp_rundata(*mp_ptr); + 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 = (char *)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)); + } + } 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); + lua_pushnumber(L, (lua_Number)mp_memory_usage(*mp_ptr)); + lua_setfield(L, -2, "main_memory"); + lua_pushnumber(L, (lua_Number)mp_hash_usage(*mp_ptr)); + lua_setfield(L, -2, "hash_size"); + lua_pushnumber(L, (lua_Number)mp_param_usage(*mp_ptr)); + lua_setfield(L, -2, "param_size"); + lua_pushnumber(L, (lua_Number)mp_open_usage(*mp_ptr)); + lua_setfield(L, -2, "max_in_open"); + } else { + lua_pushnil(L); + } + return 1; +} + + +/* figure methods */ + +static int mplib_fig_collect(lua_State * L) +{ + struct mp_edge_object **hh = is_fig(L, 1); + if (*hh != NULL) { + mp_gr_toss_objects(*hh); + *hh = NULL; + } + return 0; +} + +static int mplib_fig_body(lua_State * L) +{ + int i = 1; + struct mp_graphic_object **v; + struct mp_graphic_object *p; + struct mp_edge_object **hh = is_fig(L, 1); + lua_newtable(L); + p = (*hh)->body; + while (p != NULL) { + v = lua_newuserdata(L, sizeof(struct mp_graphic_object *)); + *v = p; + luaL_getmetatable(L, MPLIB_GR_METATABLE); + lua_setmetatable(L, -2); + lua_rawseti(L, -2, i); + i++; + p = p->next; + } + (*hh)->body = NULL; /* prevent double free */ + return 1; +} + +static int mplib_fig_copy_body(lua_State * L) +{ + int i = 1; + struct mp_graphic_object **v; + struct mp_graphic_object *p; + struct mp_edge_object **hh = is_fig(L, 1); + lua_newtable(L); + p = (*hh)->body; + while (p != NULL) { + v = lua_newuserdata(L, sizeof(struct mp_graphic_object *)); + *v = mp_gr_copy_object((*hh)->parent, p); + luaL_getmetatable(L, MPLIB_GR_METATABLE); + lua_setmetatable(L, -2); + lua_rawseti(L, -2, i); + i++; + p = p->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->ps_out.size != 0)) { + lua_pushstring(L, res->ps_out.data); + } 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 / 65536.0); + } 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 / 65536.0); + } 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 / 65536.0); + } 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 / 65536.0); + } 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 / 65536.0); + lua_rawseti(L, -2, 1); + lua_pushnumber(L, (double) (*hh)->miny / 65536.0); + lua_rawseti(L, -2, 2); + lua_pushnumber(L, (double) (*hh)->maxx / 65536.0); + lua_rawseti(L, -2, 3); + lua_pushnumber(L, (double) (*hh)->maxy / 65536.0); + lua_rawseti(L, -2, 4); + return 1; +} + +/* object methods */ + +static int mplib_gr_collect(lua_State * L) +{ + struct mp_graphic_object **hh = is_gr_object(L, 1); + if (*hh != NULL) { + mp_gr_toss_object(*hh); + *hh = NULL; + } + return 0; +} + +static int mplib_gr_tostring(lua_State * L) +{ + struct mp_graphic_object **hh = is_gr_object(L, 1); + (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/65536.0) + +static double eps = 0.0001; + +static double coord_range_x (mp_knot *h, double dz) { + double z; + double zlo = 0.0, zhi = 0.0; + mp_knot *f = h; + while (h != NULL) { + z = (double)h->x_coord; + if (z < zlo) zlo = z; else if (z > zhi) zhi = z; + z = (double)h->right_x; + if (z < zlo) zlo = z; else if (z > zhi) zhi = z; + z = (double)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_knot *h, double dz) { + double z; + double zlo = 0.0, zhi = 0.0; + mp_knot *f = h; + while (h != NULL) { + z = (double)h->y_coord; + if (z < zlo) zlo = z; else if (z > zhi) zhi = z; + z = (double)h->right_y; + if (z < zlo) zlo = z; else if (z > zhi) zhi = z; + z = (double)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 divider = 1.0; + double width = 1.0; + mp_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/65536.0; + y_coord = p->y_coord/65536.0; + left_x = p->left_x/65536.0; + left_y = p->left_y/65536.0; + right_x = p->right_x/65536.0; + right_y = p->right_y/65536.0; + 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; + divider = sx*sy - rx*ry; + 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; +} + + +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)/65536.0) + +#define MPLIB_PATH 0 +#define MPLIB_PEN 1 + +static void mplib_push_path(lua_State * L, struct mp_knot *h, int is_pen) +{ + struct mp_knot *p; /* for scanning the path */ + int i = 1; + p = h; + if (p != NULL) { + lua_newtable(L); + do { + lua_createtable(L, 0, 6); + if (!is_pen) { + if (p->left_type != mp_explicit) { + mplib_push_S(left_type); + lua_pushstring(L, knot_type_enum[p->left_type]); + lua_rawset(L, -3); + } + if (p->right_type != mp_explicit) { + mplib_push_S(right_type); + lua_pushstring(L, knot_type_enum[p->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->right_type == mp_endpoint) { + return; + } + p = p->next; + } while (p != h); + } else { + lua_pushnil(L); + } +} + +/* 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, struct mp_knot *h) +{ + struct mp_knot *p; /* for scanning the path */ + p = h; + if (p == NULL) { + /* do nothing */ + } else if (p == p->next) { + mplib_push_S(type); + lua_pushstring(L, "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; + int 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); + } +} + +/* 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_number(L, d->offset); + lua_setfield(L, -2, "offset"); + if (d->array != NULL) { + int i = 0; + lua_newtable(L); + while (*(d->array + i) != -1) { + ds = *(d->array + i) / 65536.0; + lua_pushnumber(L, ds); + i++; + lua_rawseti(L, -2, i); + } + lua_setfield(L, -2, "dashes"); + } + } else { + lua_pushnil(L); + } +} + +static void mplib_push_transform(lua_State * L, struct mp_text_object *h) +{ + int i = 1; + if (h != NULL) { + lua_createtable(L, 6, 0); + mplib_push_number(L, h->tx); + 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}, + {NULL, NULL} /* sentinel */ +}; + +static const struct luaL_reg mplib_fig_meta[] = { + {"__gc", mplib_fig_collect}, + {"__tostring", mplib_fig_tostring}, + {"objects", mplib_fig_body}, + {"copy_objects", mplib_fig_copy_body}, + {"filename", mplib_fig_filename}, + {"postscript", mplib_fig_postscript}, + {"boundingbox", mplib_fig_bb}, + {"width", mplib_fig_width}, + {"height", mplib_fig_height}, + {"depth", mplib_fig_depth}, + {"italcorr", mplib_fig_italcorr}, + {"charcode", mplib_fig_charcode}, + {NULL, NULL} /* sentinel */ +}; + +static const struct luaL_reg mplib_gr_meta[] = { + {"__gc", mplib_gr_collect}, + {"__tostring", mplib_gr_tostring}, + {"__index", mplib_gr_index}, + {NULL, NULL} /* sentinel */ +}; + +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}, + {NULL, NULL} /* sentinel */ +}; + + +static const struct luaL_reg mplib_m[] = { + {"new", mplib_new}, + {"version", mplib_version}, + {"fields", mplib_gr_fields}, + {"pen_info", mplib_gr_peninfo}, + {NULL, NULL} /* sentinel */ +}; + + +int luaopen_mplib(lua_State * L) +{ + mplib_init_Ses(L); + + luaL_newmetatable(L, MPLIB_GR_METATABLE); + lua_pushvalue(L, -1); /* push metatable */ + lua_setfield(L, -2, "__index"); /* metatable.__index = metatable */ + luaL_register(L, NULL, mplib_gr_meta); /* object meta methods */ + lua_pop(L, 1); + + luaL_newmetatable(L, MPLIB_FIG_METATABLE); + lua_pushvalue(L, -1); /* push metatable */ + lua_setfield(L, -2, "__index"); /* metatable.__index = metatable */ + luaL_register(L, NULL, mplib_fig_meta); /* figure meta methods */ + lua_pop(L, 1); + + luaL_newmetatable(L, MPLIB_METATABLE); + lua_pushvalue(L, -1); /* push metatable */ + lua_setfield(L, -2, "__index"); /* metatable.__index = metatable */ + luaL_register(L, NULL, mplib_meta); /* meta methods */ + luaL_register(L, NULL, mplib_d); /* dict methods */ + luaL_register(L, "mplib", mplib_m); /* module functions */ + return 1; +} diff --git a/Build/source/texk/web2c/mplibdir/memio.w b/Build/source/texk/web2c/mplibdir/memio.w new file mode 100644 index 00000000000..d2393d0fb96 --- /dev/null +++ b/Build/source/texk/web2c/mplibdir/memio.w @@ -0,0 +1,405 @@ +% $Id: psout.w 616 2008-07-09 14:05:55Z taco $ +% +% Copyright 2008 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 +\def\MP{{\tenlogo META}\-{\tenlogo POST}} +\def\title{MetaPost MEM reading and writing} +\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 + +@ As usual, need true and false. + +@d true 1 +@d false 0 +@d null 0 /* the null pointer */ +@d incr(A) (A)=(A)+1 /* increase a variable by unity */ +@d decr(A) (A)=(A)-1 /* decrease a variable by unity */ +@d qo(A) (A) /* to read eight bits from a quarterword */ +@d qi(A) (quarterword)(A) /* to store eight bits in a quarterword */ +@d max_quarterword 0x3FFF /* largest allowable value in a |quarterword| */ +@d max_halfword 0xFFFFFFF /* largest allowable value in a |halfword| */ +@d max_str_ref 127 /* ``infinite'' number of references */ + + +@c +#include "config.h" +#include <stdio.h> +#include <stdlib.h> +#include <string.h> +#include "mplib.h" +#include "mpmp.h" + +@ @c void mp_store_mem_file (MP mp) { + integer k; /* all-purpose index */ + pointer p,q; /* all-purpose pointers */ + integer x; /* something to dump */ + four_quarters w; /* four ASCII codes */ + memory_word WW; + @<Create the |mem_ident|, open the mem file, + and inform the user that dumping has begun@>; + @<Dump constants for consistency check@>; + @<Dump the string pool@>; + @<Dump the dynamic memory@>; + @<Dump the table of equivalents and the hash table@>; + @<Dump a few more things and the closing check word@>; + @<Close the mem file@>; +} + +@ Corresponding to the procedure that dumps a mem file, we also have a function +that reads~one~in. The function returns |false| if the dumped mem is +incompatible with the present \MP\ table sizes, etc. + +@d too_small(A) { wake_up_terminal; + wterm_ln("---! Must increase the "); wterm((A)); +@.Must increase the x@> + goto OFF_BASE; + } + +@c +boolean mp_load_mem_file (MP mp) { + integer k; /* all-purpose index */ + pointer p,q; /* all-purpose pointers */ + integer x; /* something undumped */ + str_number s; /* some temporary string */ + four_quarters w; /* four ASCII codes */ + memory_word WW; + @<Undump the string pool@>; + @<Undump the dynamic memory@>; + @<Undump the table of equivalents and the hash table@>; + @<Undump a few more things and the closing check word@>; + return true; /* it worked! */ +OFF_BASE: + wake_up_terminal; + wterm_ln("(Fatal mem file error; I'm stymied)\n"); +@.Fatal mem file error@> + return false; +} + +@ Mem files consist of |memory_word| items, and we use the following +macros to dump words of different types: + +@d dump_wd(A) { WW=(A); (mp->write_binary_file)(mp,mp->mem_file,&WW,sizeof(WW)); } +@d dump_int(A) { int cint=(A); (mp->write_binary_file)(mp,mp->mem_file,&cint,sizeof(cint)); } +@d dump_hh(A) { WW.hh=(A); (mp->write_binary_file)(mp,mp->mem_file,&WW,sizeof(WW)); } +@d dump_qqqq(A) { WW.qqqq=(A); (mp->write_binary_file)(mp,mp->mem_file,&WW,sizeof(WW)); } +@d dump_string(A) { dump_int((int)(strlen(A)+1)); + (mp->write_binary_file)(mp,mp->mem_file,A,strlen(A)+1); } + +@ The inverse macros are slightly more complicated, since we need to check +the range of the values we are reading in. We say `|undump(a)(b)(x)|' to +read an integer value |x| that is supposed to be in the range |a<=x<=b|. + +@d mgeti(A) do { + size_t wanted = sizeof(A); + void *A_ptr = &A; + (mp->read_binary_file)(mp, mp->mem_file,&A_ptr,&wanted); + if (wanted!=sizeof(A)) goto OFF_BASE; +} while (0) + +@d mgetw(A) do { + size_t wanted = sizeof(A); + void *A_ptr = &A; + (mp->read_binary_file)(mp, mp->mem_file,&A_ptr,&wanted); + if (wanted!=sizeof(A)) goto OFF_BASE; +} while (0) + +@d undump_wd(A) { mgetw(WW); A=WW; } +@d undump_int(A) { int cint; mgeti(cint); A=cint; } +@d undump_hh(A) { mgetw(WW); A=WW.hh; } +@d undump_qqqq(A) { mgetw(WW); A=WW.qqqq; } +@d undump_strings(A,B,C) { + undump_int(x); if ( (x<(A)) || (x>(B)) ) goto OFF_BASE; else C=str(x); } +@d undump(A,B,C) { undump_int(x); + if ( (x<(A)) || (x>(int)(B)) ) goto OFF_BASE; else C=x; } +@d undump_size(A,B,C,D) { undump_int(x); + if (x<(A)) goto OFF_BASE; + if (x>(B)) too_small((C)); else D=x; } +@d undump_string(A) { + size_t the_wanted; + void *the_string; + integer XX=0; + undump_int(XX); + the_wanted = (size_t)XX; + the_string = mp_xmalloc(mp,(size_t)XX,1); + (mp->read_binary_file)(mp,mp->mem_file,&the_string,&the_wanted); + A = (char *)the_string; + if (the_wanted!=(size_t)XX) goto OFF_BASE; +} + +@ The next few sections of the program should make it clear how we use the +dump/undump macros. + +@<Dump constants for consistency check@>= +x = metapost_magic; dump_int(x); +dump_int(mp->mem_top); +dump_int((integer)mp->hash_size); +dump_int(mp->hash_prime) +dump_int(mp->param_size); +dump_int(mp->max_in_open); + +@ Sections of a \.{WEB} program that are ``commented out'' still contribute +strings to the string pool; therefore \.{INIMP} and \MP\ will have +the same strings. (And it is, of course, a good thing that they do.) +@.WEB@> +@^string pool@> + +@ @c +int mp_undump_constants (MP mp) { + integer x; + undump_int(x); + if (x!=metapost_magic) return x; + undump_int(x); mp->mem_top = x; + undump_int(x); mp->hash_size = (unsigned)x; + undump_int(x); mp->hash_prime = x; + undump_int(x); mp->param_size = x; + undump_int(x); mp->max_in_open = x; + return metapost_magic; + OFF_BASE: + return -1; +} + +@ We do string pool compaction to avoid dumping unused strings. + +@d dump_four_ASCII + w.b0=qi(mp->str_pool[k]); w.b1=qi(mp->str_pool[k+1]); + w.b2=qi(mp->str_pool[k+2]); w.b3=qi(mp->str_pool[k+3]); + dump_qqqq(w) + +@<Dump the string pool@>= +mp_do_compaction(mp, mp->pool_size); +dump_int(mp->pool_ptr); +dump_int(mp->max_str_ptr); +dump_int(mp->str_ptr); +k=0; +while ( (mp->next_str[k]==k+1) && (k<=mp->max_str_ptr) ) + k++; +dump_int(k); +while ( k<=mp->max_str_ptr ) { + dump_int(mp->next_str[k]); incr(k); +} +k=0; +while (1) { + dump_int(mp->str_start[k]); /* TODO: valgrind warning here */ + if ( k==mp->str_ptr ) { + break; + } else { + k=mp->next_str[k]; + } +} +k=0; +while (k+4<mp->pool_ptr ) { + dump_four_ASCII; k=k+4; +} +k=mp->pool_ptr-4; dump_four_ASCII; +mp_print_ln(mp); mp_print(mp, "at most "); mp_print_int(mp, mp->max_str_ptr); +mp_print(mp, " strings of total length "); +mp_print_int(mp, mp->pool_ptr) + +@ @d undump_four_ASCII + undump_qqqq(w); + mp->str_pool[k]=(ASCII_code)qo(w.b0); mp->str_pool[k+1]=(ASCII_code)qo(w.b1); + mp->str_pool[k+2]=(ASCII_code)qo(w.b2); mp->str_pool[k+3]=(ASCII_code)qo(w.b3) + +@<Undump the string pool@>= +undump_int(mp->pool_ptr); +mp_reallocate_pool(mp, mp->pool_ptr) ; +undump_int(mp->max_str_ptr); +mp_reallocate_strings (mp,mp->max_str_ptr) ; +undump(0,mp->max_str_ptr,mp->str_ptr); +undump(0,mp->max_str_ptr+1,s); +for (k=0;k<=s-1;k++) + mp->next_str[k]=k+1; +for (k=s;k<=mp->max_str_ptr;k++) + undump(s+1,mp->max_str_ptr+1,mp->next_str[k]); +mp->fixed_str_use=0; +k=0; +while (1) { + undump(0,mp->pool_ptr,mp->str_start[k]); + if ( k==mp->str_ptr ) break; + mp->str_ref[k]=max_str_ref; + incr(mp->fixed_str_use); + mp->last_fixed_str=k; k=mp->next_str[k]; +} +k=0; +while ( k+4<mp->pool_ptr ) { + undump_four_ASCII; k=k+4; +} +k=mp->pool_ptr-4; undump_four_ASCII; +mp->init_str_use=mp->fixed_str_use; mp->init_pool_ptr=mp->pool_ptr; +mp->max_pool_ptr=mp->pool_ptr; +mp->strs_used_up=mp->fixed_str_use; +mp->pool_in_use=mp->str_start[mp->str_ptr]; mp->strs_in_use=mp->fixed_str_use; +mp->max_pl_used=mp->pool_in_use; mp->max_strs_used=mp->strs_in_use; +mp->pact_count=0; mp->pact_chars=0; mp->pact_strs=0; + +@ By sorting the list of available spaces in the variable-size portion of +|mem|, we are usually able to get by without having to dump very much +of the dynamic memory. + +We recompute |var_used| and |dyn_used|, so that \.{INIMP} dumps valid +information even when it has not been gathering statistics. + +@<Dump the dynamic memory@>= +mp_sort_avail(mp); mp->var_used=0; +dump_int(mp->lo_mem_max); dump_int(mp->rover); +p=0; q=mp->rover; x=0; +do { + for (k=p;k<= q+1;k++) + dump_wd(mp->mem[k]); + x=x+q+2-p; mp->var_used=mp->var_used+q-p; + p=q+node_size(q); q=rmp_link(q); +} while (q!=mp->rover); +mp->var_used=mp->var_used+mp->lo_mem_max-p; +mp->dyn_used=mp->mem_end+1-mp->hi_mem_min; +for (k=p;k<= mp->lo_mem_max;k++ ) + dump_wd(mp->mem[k]); +x=x+mp->lo_mem_max+1-p; +dump_int(mp->hi_mem_min); dump_int(mp->avail); +for (k=mp->hi_mem_min;k<=mp->mem_end;k++ ) + dump_wd(mp->mem[k]); +x=x+mp->mem_end+1-mp->hi_mem_min; +p=mp->avail; +while ( p!=null ) { + decr(mp->dyn_used); p=mp_link(p); +} +dump_int(mp->var_used); dump_int(mp->dyn_used); +mp_print_ln(mp); mp_print_int(mp, x); +mp_print(mp, " memory locations dumped; current usage is "); +mp_print_int(mp, mp->var_used); mp_print_char(mp, xord('&')); mp_print_int(mp, mp->dyn_used) + +@ @<Undump the dynamic memory@>= +undump(lo_mem_stat_max+1000,hi_mem_stat_min-1,mp->lo_mem_max); +undump(lo_mem_stat_max+1,mp->lo_mem_max,mp->rover); +p=0; q=mp->rover; +do { + for (k=p;k<= q+1; k++) + undump_wd(mp->mem[k]); + p=q+node_size(q); + if ( (p>mp->lo_mem_max)||((q>=rmp_link(q))&&(rmp_link(q)!=mp->rover)) ) + goto OFF_BASE; + q=rmp_link(q); +} while (q!=mp->rover); +for (k=p;k<=mp->lo_mem_max;k++ ) + undump_wd(mp->mem[k]); +undump(mp->lo_mem_max+1,hi_mem_stat_min,mp->hi_mem_min); +undump(null,mp->mem_top,mp->avail); mp->mem_end=mp->mem_top; +mp->last_pending=spec_head; +for (k=mp->hi_mem_min;k<= mp->mem_end;k++) + undump_wd(mp->mem[k]); +undump_int(mp->var_used); undump_int(mp->dyn_used) + +@ A different scheme is used to compress the hash table, since its lower region +is usually sparse. When |text(p)<>0| for |p<=hash_used|, we output three +words: |p|, |hash[p]|, and |eqtb[p]|. The hash table is, of course, densely +packed for |p>=hash_used|, so the remaining entries are output in~a~block. + +@<Dump the table of equivalents and the hash table@>= +dump_int(mp->hash_used); +mp->st_count=frozen_inaccessible-1-mp->hash_used; +for (p=1;p<=mp->hash_used;p++) { + if ( text(p)!=0 ) { + dump_int(p); dump_hh(mp->hash[p]); dump_hh(mp->eqtb[p]); incr(mp->st_count); + } +} +for (p=mp->hash_used+1;p<=(int)hash_end;p++) { + dump_hh(mp->hash[p]); dump_hh(mp->eqtb[p]); +} +dump_int(mp->st_count); +mp_print_ln(mp); mp_print_int(mp, mp->st_count); mp_print(mp, " symbolic tokens") + +@ @<Undump the table of equivalents and the hash table@>= +undump(1,frozen_inaccessible,mp->hash_used); +p=0; +do { + undump(p+1,mp->hash_used,p); + undump_hh(mp->hash[p]); undump_hh(mp->eqtb[p]); +} while (p!=mp->hash_used); +for (p=mp->hash_used+1;p<=(int)hash_end;p++ ) { + undump_hh(mp->hash[p]); undump_hh(mp->eqtb[p]); +} +undump_int(mp->st_count) + +@ We have already printed a lot of statistics, so we set |mp_tracing_stats:=0| +to prevent them appearing again. + +@<Dump a few more things and the closing check word@>= +dump_int(mp->max_internal); +dump_int(mp->int_ptr); +for (k=1;k<= mp->int_ptr;k++ ) { + dump_int(mp->internal[k]); + dump_string(mp->int_name[k]); +} +dump_int(mp->start_sym); +dump_int(mp->interaction); +dump_string(mp->mem_ident); +dump_int(mp->bg_loc); dump_int(mp->eg_loc); dump_int(mp->serial_no); dump_int(69073); +mp->internal[mp_tracing_stats]=0 + +@ @<Undump a few more things and the closing check word@>= +undump_int(x); +if (x>mp->max_internal) mp_grow_internals(mp,x); +undump_int(mp->int_ptr); +for (k=1;k<= mp->int_ptr;k++) { + undump_int(mp->internal[k]); + undump_string(mp->int_name[k]); +} +undump(0,frozen_inaccessible,mp->start_sym); +if (mp->interaction==mp_unspecified_mode) { + undump(mp_unspecified_mode,mp_error_stop_mode,mp->interaction); +} else { + undump(mp_unspecified_mode,mp_error_stop_mode,x); +} +undump_string(mp->mem_ident); +undump(1,hash_end,mp->bg_loc); +undump(1,hash_end,mp->eg_loc); +undump_int(mp->serial_no); +undump_int(x); +if (x!=69073) goto OFF_BASE + +@ @<Create the |mem_ident|...@>= +{ + char *tmp = mp_xmalloc(mp,11,1); + mp_xfree(mp->mem_ident); + mp->mem_ident = mp_xmalloc(mp,256,1); + mp_snprintf(tmp,11,"%04d.%02d.%02d", + (int)mp_round_unscaled(mp, mp->internal[mp_year]), + (int)mp_round_unscaled(mp, mp->internal[mp_month]), + (int)mp_round_unscaled(mp, mp->internal[mp_day])); + mp_snprintf(mp->mem_ident,256," (mem=%s %s)",mp->job_name, tmp); + mp_xfree(tmp); + mp_pack_job_name(mp, ".mem"); + while (! mp_w_open_out(mp, &mp->mem_file) ) + mp_prompt_file_name(mp, "mem file name", ".mem"); + mp_print_nl(mp, "Beginning to dump on file "); +@.Beginning to dump...@> + mp_print(mp, mp->name_of_file); + mp_print_nl(mp, mp->mem_ident); +} + +@ @<Close the mem file@>= +(mp->close_file)(mp,mp->mem_file) diff --git a/Build/source/texk/web2c/mplibdir/mp.w b/Build/source/texk/web2c/mplibdir/mp.w new file mode 100644 index 00000000000..1303cf6f9e4 --- /dev/null +++ b/Build/source/texk/web2c/mplibdir/mp.w @@ -0,0 +1,26427 @@ +% $Id: mp.w 873 2009-03-19 07:44:11Z taco $ +% +% Copyright 2008 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 +\def\hang{\hangindent 3em\noindent\ignorespaces} +\def\textindent#1{\hangindent2.5em\noindent\hbox to2.5em{\hss#1 }\ignorespaces} +\def\ps{PostScript} +\def\psqrt#1{\sqrt{\mathstrut#1}} +\def\k{_{k+1}} +\def\pct!{{\char`\%}} % percent sign in ordinary text +\font\tenlogo=logo10 % font used for the METAFONT logo +\font\logos=logosl10 +\def\MF{{\tenlogo META}\-{\tenlogo FONT}} +\def\MP{{\tenlogo META}\-{\tenlogo POST}} +\def\[#1]{\ignorespaces} % left over from pascal web +\def\<#1>{$\langle#1\rangle$} +\def\section{\mathhexbox278} +\let\swap=\leftrightarrow +\def\round{\mathop{\rm round}\nolimits} +\mathchardef\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 + +@* \[1] 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 1.110" /* printed when \MP\ starts */ +@d true 1 +@d false 0 + +@(mpmp.h@>= +#define metapost_version "1.110" +#define metapost_magic (('M'*256) + 'P')*65536 + 1110 +#define metapost_old_magic (('M'*256) + 'P')*65536 + 1080 + +@ The external library header for \MP\ is |mplib.h|. It contains a +few typedefs and the header defintions for the externally used +fuctions. + +The most important of the typedefs is the definition of the structure +|MP_options|, that acts as a small, configurable front-end to the fairly +large |MP_instance| structure. + +@(mplib.h@>= +typedef struct MP_instance * MP; +@<Exported types@> +typedef struct MP_options { + @<Option variables@> +} MP_options; +@<Exported function headers@> + +@ The internal header file is much longer: it not only lists the complete +|MP_instance|, but also a lot of functions that have to be available to +the \ps\ backend, that is defined in a separate \.{WEB} file. + +The variables from |MP_options| are included inside the |MP_instance| +wholesale. + +@(mpmp.h@>= +#include <setjmp.h> +typedef struct psout_data_struct * psout_data; +typedef struct svgout_data_struct * svgout_data; +#ifndef HAVE_BOOLEAN +typedef int boolean; +#endif +#ifndef INTEGER_TYPE +typedef int integer; +#endif +@<Declare helpers@> +@<Types in the outer block@> +@<Constants in the outer block@> +typedef struct MP_instance { + @<Option variables@> + @<Global variables@> +} MP_instance; +@<Internal library declarations@> + +@ @c +#include "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 "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 */ +extern font_number mp_read_font_info (MP mp, char *fname); /* tfmin.w */ +@h +@<Declarations@> +@<Basic printing procedures@> +@<Error handling procedures@> + +@ 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); + opt->ini_version = true; + } + 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); + xfree(mp); +} + +@ @c +static void mp_do_initialize ( MP mp) { + @<Local variables for initialization@> + @<Set initial values of key variables@> +} + +@ 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; + @<Set |ini_version|@>; + mp->noninteractive=opt->noninteractive; + 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); + 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; + @<Find constant sizes@>; + @<Allocate or initialize variables@> + mp_reallocate_memory(mp,mp->mem_max); + 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...@>; + if ( mp->bad>0 ) { + char ss[256]; + mp_snprintf(ss,256,"Ouch---my internal constants have been clobbered!\n" + "---case %i",(int)mp->bad); + do_fprintf(mp->err_out,(char *)ss); +@.Ouch...clobbered@> + return mp; + } + mp_do_initialize(mp); /* erase preloaded mem */ + if (mp->ini_version) { + @<Run inimpost commands@>; + } + if (!mp->noninteractive) { + @<Initialize the output routines@>; + @<Get the first line of input and prepare to start@>; + @<Initializations after first line is read@>; + } else { + mp->history=mp_spotless; + } + 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) { + mp->internal[mp_gtroffmode]=unity; + mp->internal[mp_prologues]=unity; +} +if ( mp->start_sym>0 ) { /* insert the `\&{everyjob}' symbol */ + mp->cur_sym=mp->start_sym; mp_back_input(mp); +} + +@ @<Exported function headers@>= +extern MP_options *mp_options (void); +extern MP mp_initialize (MP_options *opt) ; +extern int mp_status(MP mp); +extern void *mp_userdata(MP mp); + +@ @c +int mp_status(MP mp) { return mp->history; } + +@ @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|'. + +@ This program has two important variations: (1) There is a long and slow +version called \.{INIMP}, which does the extra calculations needed to +@.INIMP@> +initialize \MP's internal tables; and (2)~there is a shorter and faster +production version, which cuts the initialization to a bare minimum. + +Which is which is decided at runtime. + +@ The following parameters can be changed at compile time to extend or +reduce \MP's capacity. They may have different values in \.{INIMP} and +in production versions of \MP. +@.INIMP@> +@^system dependencies@> + +@<Constants...@>= +#define file_name_size 255 /* file names shouldn't be longer than this */ +#define bistack_size 1500 /* size of stack for bisection algorithms; + should probably be left at this value */ + +@ Like the preceding parameters, the following quantities can be changed +to extend or reduce \MP's capacity. But if they are changed, +it is necessary to rerun the initialization program \.{INIMP} +@.INIMP@> +to generate new tables for the production \MP\ program. +One can't simply make helter-skelter changes to the following constants, +since certain rather complex initialization +numbers are computed from them. + +@ @<Glob...@>= +int max_strings; /* maximum number of strings; must not exceed |max_halfword| */ +int pool_size; /* maximum number of characters in strings, including all + error messages and help texts, and the names of all identifiers */ +int old_pool_size; /* a helper used by |mp_cat| */ +int mem_max; /* greatest index in \MP's internal |mem| array; + must be strictly less than |max_halfword|; + must be equal to |mem_top| in \.{INIMP}, otherwise |>=mem_top| */ +int mem_top; /* largest index in the |mem| array dumped by \.{INIMP}; + must not be greater than |mem_max| */ +int hash_prime; /* a prime number equal to about 85\pct! of |hash_size| */ + +@ @<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 */ +unsigned hash_size; /* maximum number of symbolic tokens, + must be less than |max_halfword-3*param_size| */ +int param_size; /* maximum number of simultaneous macro parameters */ +int max_in_open; /* maximum number of input files and error insertions that + can be going on simultaneously */ +int main_memory; /* only for options, to set up |mem_max| and |mem_top| */ +void *userdata; /* this allows the calling application to setup local */ +char *banner; /* the banner that is printed to the screen and log */ + +@ @<Dealloc variables@>= +xfree(mp->banner); + +@ +@d set_value(a,b,c) do { a=c; if (b>c) a=b; } while (0) + +@<Allocate or ...@>= +mp->max_strings=500; +mp->pool_size=10000; +mp->old_pool_size=10000; +set_value(mp->error_line,opt->error_line,79); +set_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_value(mp->max_print_line,opt->max_print_line,79); +mp->halt_on_error = (opt->halt_on_error ? 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 `\ignorespaces|if (mem_max>=max_halfword) bad=10;|', +or something similar. (We can't do that until |max_halfword| has been defined.) + +In case you are wondering about the non-consequtive values of |bad|: some +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; +if ( mp->mem_top<=1100 ) mp->bad=4; + +@ Some |goto| labels are used by the following definitions. The label +`|restart|' is occasionally used at the very beginning of a procedure; and +the label `|reswitch|' is occasionally used just prior to a |case| +statement in which some cases change the conditions and we wish to branch +to the newly applicable case. Loops that are set up with the |loop| +construction defined below are commonly exited by going to `|done|' or to +`|found|' or to `|not_found|', and they are sometimes repeated by going to +`|continue|'. If two or more parts of a subroutine start differently but +end up the same, the shared code may be gathered together at +`|common_ending|'. + +@ Here are some macros for common programming idioms. + +@d incr(A) (A)=(A)+1 /* increase a variable by unity */ +@d decr(A) (A)=(A)-1 /* decrease a variable by unity */ +@d negate(A) (A)=-(A) /* change the sign of a variable */ +@d double(A) (A)=(A)+(A) +@d odd(A) ((A)%2==1) +@d do_nothing /* empty statement */ + +@* \[2] The character set. +In order to make \MP\ readily portable to a wide variety of +computers, all of its input text is converted to an internal eight-bit +code that includes standard ASCII, the ``American Standard Code for +Information Interchange.'' This conversion is done immediately when each +character is read in. Conversely, characters are converted from ASCII to +the user's external representation just before they are output to a +text file. +@^ASCII code@> + +Such an internal code is relevant to users of \MP\ only with respect to +the \&{char} and \&{ASCII} operations, and the comparison of strings. + +@ Characters of text that have been converted to \MP's internal form +are said to be of type |ASCII_code|, which is a subrange of the integers. + +@<Types...@>= +typedef unsigned char ASCII_code; /* eight-bit numbers */ + +@ The present specification of \MP\ has been written under the assumption +that the character set contains at least the letters and symbols associated +with ASCII codes 040 through 0176; all of these characters are now +available on most computer terminals. + +@<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. + +@(mpmp.h@>= +#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;} + +@* \[3] Input and output. +The bane of portability is the fact that different operating systems treat +input and output quite differently, perhaps because computer scientists +have not given sufficient attention to this problem. People have felt somehow +that input and output are not part of ``real'' programming. Well, it is true +that some kinds of programming are more fun than others. With existing +input/output conventions being so diverse and so messy, the only sources of +joy in such parts of the code are the rare occasions when one can find a +way to make the program a little less bad than it might have been. We have +two choices, either to attack I/O now and get it over with, or to postpone +I/O until near the end. Neither prospect is very attractive, so let's +get it over with. + +The basic operations we need to do are (1)~inputting and outputting of +text, to or from a file or the user's terminal; (2)~inputting and +outputting of eight-bit bytes, to or from a file; (3)~instructing the +operating system to initiate (``open'') or to terminate (``close'') input or +output from a specified file; (4)~testing whether the end of an input +file has been reached; (5)~display of bits on the user's screen. +The bit-display operation will be discussed in a later section; we shall +deal here only with more traditional kinds of I/O. + +@ Finding files happens in a slightly roundabout fashion: the \MP\ +instance object contains a field that holds a function pointer that finds a +file, and returns its name, or NULL. For this, it receives three +parameters: the non-qualified name |fname|, the intended |fopen| +operation type |fmode|, and the type of the file |ftype|. + +The file types that are passed on in |ftype| can be used to +differentiate file searches if a library like kpathsea is used, +the fopen mode is passed along for the same reason. + +@<Types...@>= +typedef unsigned char eight_bits ; /* unsigned one-byte quantity */ + +@ @<Exported types@>= +enum mp_filetype { + mp_filetype_terminal = 0, /* the terminal */ + mp_filetype_error, /* the terminal */ + mp_filetype_program , /* \MP\ language input */ + mp_filetype_log, /* the log file */ + mp_filetype_postscript, /* the postscript output */ + mp_filetype_memfile, /* memory dumps */ + mp_filetype_metrics, /* TeX font metric files */ + mp_filetype_fontmap, /* PostScript font mapping files */ + mp_filetype_font, /* PostScript type1 font programs */ + mp_filetype_encoding, /* PostScript font encoding files */ + mp_filetype_text /* first text file for readfrom and writeto primitives */ +}; +typedef char *(*mp_file_finder)(MP, const char *, const char *, int); +typedef void *(*mp_file_opener)(MP, const char *, const char *, int); +typedef char *(*mp_file_reader)(MP, void *, size_t *); +typedef void (*mp_binfile_reader)(MP, void *, void **, size_t *); +typedef void (*mp_file_closer)(MP, void *); +typedef int (*mp_file_eoftest)(MP, void *); +typedef void (*mp_file_flush)(MP, void *); +typedef void (*mp_file_writer)(MP, void *, const char *); +typedef void (*mp_binfile_writer)(MP, void *, void *, size_t); + +@ @<Option variables@>= +mp_file_finder find_file; +mp_file_opener open_file; +mp_file_reader read_ascii_file; +mp_binfile_reader read_binary_file; +mp_file_closer close_file; +mp_file_eoftest eof_file; +mp_file_flush flush_file; +mp_file_writer write_ascii_file; +mp_binfile_writer write_binary_file; + +@ The default function for finding files is |mp_find_file|. It is +pretty stupid: it will only find files in the current directory. + +This function may disappear altogether, it is currently only +used for the default font map file. + +@c +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; +} + +@ 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) ; + +@ 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; +} + +@ This is a legacy interface: (almost) all file names pass through |name_of_file|. + +@<Glob...@>= +char name_of_file[file_name_size+1]; /* the name of a system file */ +int name_length;/* this many characters are actually + relevant in |name_of_file| (the rest are blank) */ + +@ 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 |a_open_in| in the global +|mp->long_name|. + +@<Glob...@>= +char *long_name; + +@ @<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->long_name = NULL; + +@ \MP's file-opening procedures return |false| if no file identified by +|name_of_file| could be opened. + +The |OPEN_FILE| macro takes care of the |print_found_names| parameter. +It is not used for opening a mem file for read, because that file name +is never printed. + +@d OPEN_FILE(A) do { + if (mp->print_found_names || mp->file_line_error_style) { + char *s = (mp->find_file)(mp,mp->name_of_file,A,ftype); + if (s!=NULL) { + *f = (mp->open_file)(mp,mp->name_of_file,A, ftype); + if (mp->print_found_names) { + strncpy(mp->name_of_file,s,file_name_size); + } + if ((*(A) == 'r') && (ftype == mp_filetype_program)) { + xfree(mp->long_name); + mp->long_name = xstrdup(s); + } + xfree(s); + } else { + *f = NULL; + } + } else { + *f = (mp->open_file)(mp,mp->name_of_file,A, ftype); + } +} while (0); +return (*f ? true : false) + +@c +static boolean mp_a_open_in (MP mp, void **f, int ftype) { + /* open a text file for input */ + OPEN_FILE("r"); +} +@# +boolean mp_w_open_in (MP mp, void **f) { + /* open a word file for input */ + *f = (mp->open_file)(mp,mp->name_of_file,"r",mp_filetype_memfile); + return (*f ? true : false); +} +@# +static boolean mp_a_open_out (MP mp, void **f, int ftype) { + /* open a text file for output */ + OPEN_FILE("w"); +} +@# +static boolean mp_b_open_out (MP mp, void **f, int ftype) { + /* open a binary file for output */ + OPEN_FILE("w"); +} +@# +boolean mp_w_open_out (MP mp, void **f) { + /* open a word file for output */ + int ftype = mp_filetype_memfile; + OPEN_FILE("w"); +} + +@ @<Internal library ...@>= +boolean mp_w_open_out (MP mp, void **f); + +@ @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++] = 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)); + 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))); + } + } + memcpy((mp->buffer+mp->first),s,size); + /* while ( mp->buffer[mp->last]==' ' ) mp->last--; */ + } + free(s); + return true; +} + +@ The user's terminal acts essentially like other files of text, except +that it is used both for input and for output. When the terminal is +considered an input file, the file variable is called |term_in|, and when it +is considered an output file the file variable is |term_out|. +@^system dependencies@> + +@<Glob...@>= +void * term_in; /* the terminal as an input file */ +void * term_out; /* the terminal as an output file */ +void * err_out; /* the terminal as an output file */ + +@ Here is how to open the terminal files. In the default configuration, +nothing happens except that the command line (if there is one) is copied +to the input buffer. The variable |command_line| will be filled by the +|main| procedure. The copying can not be done earlier in the program +logic because in the |INI| version, the |buffer| is also used for primitive +initialization. + +@d t_open_out do {/* open the terminal for text output */ + mp->term_out = (mp->open_file)(mp,"terminal", "w", mp_filetype_terminal); + mp->err_out = (mp->open_file)(mp,"error", "w", mp_filetype_error); +} while (0) +@d t_open_in do { /* open the terminal for text input */ + mp->term_in = (mp->open_file)(mp,"terminal", "r", mp_filetype_terminal); + if (mp->command_line!=NULL) { + mp->last = strlen(mp->command_line); + strncpy((char *)mp->buffer,mp->command_line,mp->last); + xfree(mp->command_line); + } else { + mp->last = 0; + } +} while (0) + +@<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@> + +@(mpmp.h@>= +#define update_terminal (mp->flush_file)(mp,mp->term_out) /* empty the terminal output buffer */ +#define clear_terminal do_nothing /* 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; do_fprintf(mp->term_out,"**"); update_terminal; +@.**@> + } + if ( ! mp_input_ln(mp, mp->term_in ) ) { /* this shouldn't happen */ + do_fprintf(mp->term_out,"\n! End of file on the terminal... why?"); +@.End of file on the terminal@> + return false; + } + loc=(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) { + do_fprintf(mp->term_out,"Please type the name of your input file.\n"); + } + } +} + +@ @<Declarations@>= +static boolean mp_init_terminal (MP mp) ; + + +@* \[4] String handling. +Symbolic token names and diagnostic messages are variable-length strings +of eight-bit characters. Many strings \MP\ uses are simply literals +in the compiled source, like the error messages and the names of the +internal parameters. Other strings are used or defined from the \MP\ input +language, and these have to be interned. + +\MP\ uses strings more extensively than \MF\ does, but the necessary +operations can still be handled with a fairly simple data structure. +The array |str_pool| contains all of the (eight-bit) ASCII codes in all +of the strings, and the array |str_start| contains indices of the starting +points of each string. Strings are referred to by integer numbers, so that +string number |s| comprises the characters |str_pool[j]| for +|str_start[s]<=j<str_start[ss]| where |ss=next_str[s]|. The string pool +is allocated sequentially and |str_pool[pool_ptr]| is the next unused +location. The first string number not currently in use is |str_ptr| +and |next_str[str_ptr]| begins a list of free string numbers. String +pool entries |str_start[str_ptr]| up to |pool_ptr| are reserved for a +string currently being constructed. + +String numbers 0 to 255 are reserved for strings that correspond to single +ASCII characters. This is in accordance with the conventions of \.{WEB}, +@.WEB@> +which converts single-character strings into the ASCII code number of the +single character involved, while it converts other strings into integers +and builds a string pool file. Thus, when the string constant \.{"."} appears +in the program below, \.{WEB} converts it into the integer 46, which is the +ASCII code for a period, while \.{WEB} will convert a string like \.{"hello"} +into some integer greater than~255. String number 46 will presumably be the +single character `\..'\thinspace; but some ASCII codes have no standard visible +representation, and \MP\ may need to be able to print an arbitrary +ASCII character, so the first 256 strings are used to specify exactly what +should be printed for each of the 256 possibilities. + +@<Types...@>= +typedef int pool_pointer; /* for variables that point into |str_pool| */ +typedef int str_number; /* for variables that point into |str_start| */ + +@ @<Glob...@>= +ASCII_code *str_pool; /* the characters */ +pool_pointer *str_start; /* the starting pointers */ +str_number *next_str; /* for linking strings in order */ +pool_pointer pool_ptr; /* first unused position in |str_pool| */ +str_number str_ptr; /* number of the current string being created */ +pool_pointer init_pool_ptr; /* the starting value of |pool_ptr| */ +str_number init_str_use; /* the initial number of strings in use */ +pool_pointer max_pool_ptr; /* the maximum so far of |pool_ptr| */ +str_number max_str_ptr; /* the maximum so far of |str_ptr| */ + +@ @<Allocate or initialize ...@>= +mp->str_pool = xmalloc ((mp->pool_size +1),sizeof(ASCII_code)); +mp->str_start = xmalloc ((mp->max_strings+1),sizeof(pool_pointer)); +mp->next_str = xmalloc ((mp->max_strings+1),sizeof(str_number)); + +@ @<Dealloc variables@>= +xfree(mp->str_pool); +xfree(mp->str_start); +xfree(mp->next_str); + +@ Most printing is done from |char *|s, but sometimes not. Here are +functions that convert an internal string into a |char *| for use +by the printing routines, and vice versa. + +@d str(A) mp_str(mp,A) +@d rts(A) mp_rts(mp,A) +@d null_str rts("") + +@<Internal ...@>= +int mp_xstrcmp (const char *a, const char *b); +char * mp_str (MP mp, str_number s); + +@ @<Declarations@>= +static str_number mp_rts (MP mp, const char *s); +static str_number mp_make_string (MP mp); + +@ @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); +} + +@ The attempt to catch interrupted strings that is in |mp_rts|, is not +very good: it does not handle nesting over more than one level. + +@c +char * mp_str (MP mp, str_number ss) { + char *s; + size_t len; + if (ss==mp->str_ptr) { + return NULL; + } else { + len = (size_t)length(ss); + s = xmalloc(len+1,sizeof(char)); + strncpy(s,(char *)(mp->str_pool+(mp->str_start[ss])),len); + s[len] = 0; + return (char *)s; + } +} +str_number mp_rts (MP mp, const char *s) { + int r; /* the new string */ + int old; /* a possible string in progress */ + int i=0; + if (strlen(s)==0) { + return 256; + } else if (strlen(s)==1) { + return s[0]; + } else { + old=0; + str_room((integer)strlen(s)); + if (mp->str_start[mp->str_ptr]<mp->pool_ptr) + old = mp_make_string(mp); + while (*s) { + append_char(*s); + s++; + } + r = mp_make_string(mp); + if (old!=0) { + str_room(length(old)); + while (i<length(old)) { + append_char((mp->str_start[old]+i)); + } + mp_flush_string(mp,old); + } + return r; + } +} + +@ Except for |strs_used_up|, the following string statistics are only +maintained when code between |stat| $\ldots$ |tats| delimiters is not +commented out: + +@<Glob...@>= +integer strs_used_up; /* strings in use or unused but not reclaimed */ +integer pool_in_use; /* total number of cells of |str_pool| actually in use */ +integer strs_in_use; /* total number of strings actually in use */ +integer max_pl_used; /* maximum |pool_in_use| so far */ +integer max_strs_used; /* maximum |strs_in_use| so far */ + +@ Several of the elementary string operations are performed using \.{WEB} +macros instead of functions, because many of the +operations are done quite frequently and we want to avoid the +overhead of procedure calls. For example, here is +a simple macro that computes the length of a string. +@.WEB@> + +@d str_stop(A) mp->str_start[mp->next_str[(A)]] /* one cell past the end of string \# */ +@d length(A) (str_stop((A))-mp->str_start[(A)]) /* the number of characters in string \# */ + +@ The length of the current string is called |cur_length|. If we decide that +the current string is not needed, |flush_cur_string| resets |pool_ptr| so that +|cur_length| becomes zero. + +@d cur_length (mp->pool_ptr - mp->str_start[mp->str_ptr]) +@d flush_cur_string mp->pool_ptr=mp->str_start[mp->str_ptr] + +@ Strings are created by appending character codes to |str_pool|. +The |append_char| macro, defined here, does not check to see if the +value of |pool_ptr| has gotten too high; this test is supposed to be +made before |append_char| is used. + +To test if there is room to append |l| more characters to |str_pool|, +we shall write |str_room(l)|, which tries to make sure there is enough room +by compacting the string pool if necessary. If this does not work, +|do_compaction| aborts \MP\ and gives an apologetic error message. + +@d append_char(A) /* put |ASCII_code| \# at the end of |str_pool| */ +{ mp->str_pool[mp->pool_ptr]=(ASCII_code)(A); incr(mp->pool_ptr); +} +@d str_room(A) /* make sure that the pool hasn't overflowed */ + { if ( mp->pool_ptr+(A) > mp->max_pool_ptr ) { + if ( mp->pool_ptr+(A) > mp->pool_size ) mp_do_compaction(mp, (A)); + else mp->max_pool_ptr=mp->pool_ptr+(A); } + } + +@ The following routine is similar to |str_room(1)| but it uses the +argument |mp->pool_size| to prevent |do_compaction| from aborting when +string space is exhausted. + +@<Declarations@>= +static void mp_unit_str_room (MP mp); + +@ @c +void mp_unit_str_room (MP mp) { + if ( mp->pool_ptr>=mp->pool_size ) mp_do_compaction(mp, mp->pool_size); + if ( mp->pool_ptr>=mp->max_pool_ptr ) mp->max_pool_ptr=mp->pool_ptr+1; +} + +@ \MP's string expressions are implemented in a brute-force way: Every +new string or substring that is needed is simply copied into the string pool. +Space is eventually reclaimed by a procedure called |do_compaction| with +the aid of a simple system system of reference counts. +@^reference counts@> + +The number of references to string number |s| will be |str_ref[s]|. The +special value |str_ref[s]=max_str_ref=127| is used to denote an unknown +positive number of references; such strings will never be recycled. If +a string is ever referred to more than 126 times, simultaneously, we +put it in this category. Hence a single byte suffices to store each |str_ref|. + +@d max_str_ref 127 /* ``infinite'' number of references */ +@d add_str_ref(A) { if ( mp->str_ref[(A)]<max_str_ref ) incr(mp->str_ref[(A)]); } + +@<Glob...@>= +int *str_ref; + +@ @<Allocate or initialize ...@>= +mp->str_ref = xmalloc ((mp->max_strings+1),sizeof(int)); + +@ @<Dealloc variables@>= +xfree(mp->str_ref); + +@ Here's what we do when a string reference disappears: + +@d delete_str_ref(A) { + if ( mp->str_ref[(A)]<max_str_ref ) { + if ( mp->str_ref[(A)]>1 ) decr(mp->str_ref[(A)]); + else mp_flush_string(mp, (A)); + } + } + +@<Declarations@>= +static void mp_flush_string (MP mp,str_number s) ; + +@ We can't flush the first set of static strings at all, so there +is no point in trying + +@c +void mp_flush_string (MP mp,str_number s) { + if (length(s)>1) { + mp->pool_in_use=mp->pool_in_use-length(s); + decr(mp->strs_in_use); + if ( mp->next_str[s]!=mp->str_ptr ) { + mp->str_ref[s]=0; + } else { + mp->str_ptr=s; + decr(mp->strs_used_up); + } + mp->pool_ptr=mp->str_start[mp->str_ptr]; + } +} + +@ C literals cannot be simply added, they need to be set so they can't +be flushed. + +@d intern(A) mp_intern(mp,(A)) + +@c +str_number mp_intern (MP mp, const char *s) { + str_number r ; + r = rts(s); + mp->str_ref[r] = max_str_ref; + return r; +} + +@ @<Declarations@>= +static str_number mp_intern (MP mp, const char *s); + + +@ Once a sequence of characters has been appended to |str_pool|, it +officially becomes a string when the function |make_string| is called. +This function returns the identification number of the new string as its +value. + +When getting the next unused string number from the linked list, we pretend +that +$$ \hbox{|max_str_ptr+1|, |max_str_ptr+2|, $\ldots$, |mp->max_strings|} $$ +are linked sequentially even though the |next_str| entries have not been +initialized yet. We never allow |str_ptr| to reach |mp->max_strings|; +|do_compaction| is responsible for making sure of this. + +@<Declarations@>= +static str_number mp_make_string (MP mp); + +@ @c +str_number mp_make_string (MP mp) { /* current string enters the pool */ + str_number s; /* the new string */ +RESTART: + s=mp->str_ptr; + mp->str_ptr=mp->next_str[s]; + if ( mp->str_ptr>mp->max_str_ptr ) { + if ( mp->str_ptr==mp->max_strings ) { + mp->str_ptr=s; + mp_do_compaction(mp, 0); + goto RESTART; + } else { + mp->max_str_ptr=mp->str_ptr; + mp->next_str[mp->str_ptr]=mp->max_str_ptr+1; + } + } + mp->str_ref[s]=1; + mp->str_start[mp->str_ptr]=mp->pool_ptr; + incr(mp->strs_used_up); + incr(mp->strs_in_use); + mp->pool_in_use=mp->pool_in_use+length(s); + if ( mp->pool_in_use>mp->max_pl_used ) + mp->max_pl_used=mp->pool_in_use; + if ( mp->strs_in_use>mp->max_strs_used ) + mp->max_strs_used=mp->strs_in_use; + return s; +} + +@ The most interesting string operation is string pool compaction. The idea +is to recover unused space in the |str_pool| array by recopying the strings +to close the gaps created when some strings become unused. All string +numbers~$k$ where |str_ref[k]=0| are to be linked into the list of free string +numbers after |str_ptr|. If this fails to free enough pool space we issue an +|overflow| error unless |needed=mp->pool_size|. Calling |do_compaction| +with |needed=mp->pool_size| supresses all overflow tests. + +The compaction process starts with |last_fixed_str| because all lower numbered +strings are permanently allocated with |max_str_ref| in their |str_ref| entries. + +@<Glob...@>= +str_number last_fixed_str; /* last permanently allocated string */ +str_number fixed_str_use; /* number of permanently allocated strings */ + +@ @<Internal library ...@>= +void mp_do_compaction (MP mp, pool_pointer needed) ; + +@ @c +void mp_do_compaction (MP mp, pool_pointer needed) { + str_number str_use; /* a count of strings in use */ + str_number r,s,t; /* strings being manipulated */ + pool_pointer p,q; /* destination and source for copying string characters */ + @<Advance |last_fixed_str| as far as possible and set |str_use|@>; + r=mp->last_fixed_str; + s=mp->next_str[r]; + p=mp->str_start[s]; + while ( s!=mp->str_ptr ) { + while ( mp->str_ref[s]==0 ) { + @<Advance |s| and add the old |s| to the list of free string numbers; + then |break| if |s=str_ptr|@>; + } + r=s; s=mp->next_str[s]; + incr(str_use); + @<Move string |r| back so that |str_start[r]=p|; make |p| the location + after the end of the string@>; + } +DONE: + @<Move the current string back so that it starts at |p|@>; + if ( needed<mp->pool_size ) { + @<Make sure that there is room for another string with |needed| characters@>; + } + @<Account for the compaction and make sure the statistics agree with the + global versions@>; + mp->strs_used_up=str_use; +} + +@ @<Advance |last_fixed_str| as far as possible and set |str_use|@>= +t=mp->next_str[mp->last_fixed_str]; +while (t!=mp->str_ptr && mp->str_ref[t]==max_str_ref) { + incr(mp->fixed_str_use); + mp->last_fixed_str=t; + t=mp->next_str[t]; +} +str_use=mp->fixed_str_use + +@ Because of the way |flush_string| has been written, it should never be +necessary to |break| here. The extra line of code seems worthwhile to +preserve the generality of |do_compaction|. + +@<Advance |s| and add the old |s| to the list of free string numbers;...@>= +{ +t=s; +s=mp->next_str[s]; +mp->next_str[r]=s; +mp->next_str[t]=mp->next_str[mp->str_ptr]; +mp->next_str[mp->str_ptr]=t; +if ( s==mp->str_ptr ) goto DONE; +} + +@ The string currently starts at |str_start[r]| and ends just before +|str_start[s]|. We don't change |str_start[s]| because it might be needed +to locate the next string. + +@<Move string |r| back so that |str_start[r]=p|; make |p| the location...@>= +q=mp->str_start[r]; +mp->str_start[r]=p; +while ( q<mp->str_start[s] ) { + mp->str_pool[p]=mp->str_pool[q]; + incr(p); incr(q); +} + +@ Pointers |str_start[str_ptr]| and |pool_ptr| have not been updated. When +we do this, anything between them should be moved. + +@ @<Move the current string back so that it starts at |p|@>= +q=mp->str_start[mp->str_ptr]; +mp->str_start[mp->str_ptr]=p; +while ( q<mp->pool_ptr ) { + mp->str_pool[p]=mp->str_pool[q]; + incr(p); incr(q); +} +mp->pool_ptr=p + +@ We must remember that |str_ptr| is not allowed to reach |mp->max_strings|. + +@<Make sure that there is room for another string with |needed| char...@>= +if ( str_use>=mp->max_strings-1 ) + mp_reallocate_strings (mp,str_use); +if ( mp->pool_ptr+needed>mp->max_pool_ptr ) { + mp_reallocate_pool(mp, mp->pool_ptr+needed); + mp->max_pool_ptr=mp->pool_ptr+needed; +} + +@ @<Internal library ...@>= +void mp_reallocate_strings (MP mp, str_number str_use) ; +void mp_reallocate_pool(MP mp, pool_pointer needed) ; + +@ @c +void mp_reallocate_strings (MP mp, str_number str_use) { + while ( str_use>=mp->max_strings-1 ) { + int l = mp->max_strings + (mp->max_strings/4); + XREALLOC (mp->str_ref, l, int); + XREALLOC (mp->str_start, l, pool_pointer); + XREALLOC (mp->next_str, l, str_number); + mp->max_strings = l; + } +} +void mp_reallocate_pool(MP mp, pool_pointer needed) { + while ( needed>mp->pool_size ) { + int l = mp->pool_size + (mp->pool_size/4); + XREALLOC (mp->str_pool, l, ASCII_code); + mp->pool_size = l; + } +} + +@ @<Account for the compaction and make sure the statistics agree with...@>= +if ( (mp->str_start[mp->str_ptr]!=mp->pool_in_use)||(str_use!=mp->strs_in_use) ) + mp_confusion(mp, "string"); +@:this can't happen string}{\quad string@> +incr(mp->pact_count); +mp->pact_chars=mp->pact_chars+mp->pool_ptr-str_stop(mp->last_fixed_str); +mp->pact_strs=mp->pact_strs+str_use-mp->fixed_str_use; + +@ A few more global variables are needed to keep track of statistics when +|stat| $\ldots$ |tats| blocks are not commented out. + +@<Glob...@>= +integer pact_count; /* number of string pool compactions so far */ +integer pact_chars; /* total number of characters moved during compactions */ +integer pact_strs; /* total number of strings moved during compactions */ + +@ @<Initialize compaction statistics@>= +mp->pact_count=0; +mp->pact_chars=0; +mp->pact_strs=0; + +@ The following subroutine compares string |s| with another string of the +same length that appears in |buffer| starting at position |k|; +the result is |true| if and only if the strings are equal. + +@c +static boolean mp_str_eq_buf (MP mp,str_number s, integer k) { + /* test equality of strings */ + pool_pointer j; /* running index */ + j=mp->str_start[s]; + while ( j<str_stop(s) ) { + if ( mp->str_pool[j++]!=mp->buffer[k++] ) + return false; + } + return true; +} + +@ Here is a similar routine, but it compares two strings in the string pool, +and it does not assume that they have the same length. If the first string +is lexicographically greater than, less than, or equal to the second, +the result is respectively positive, negative, or zero. + +@c +static integer mp_str_vs_str (MP mp, str_number s, str_number t) { + /* test equality of strings */ + pool_pointer j,k; /* running indices */ + integer ls,lt; /* lengths */ + integer l; /* length remaining to test */ + ls=length(s); lt=length(t); + if ( ls<=lt ) l=ls; else l=lt; + j=mp->str_start[s]; k=mp->str_start[t]; + while ( l-->0 ) { + if ( mp->str_pool[j]!=mp->str_pool[k] ) { + return (mp->str_pool[j]-mp->str_pool[k]); + } + j++; k++; + } + return (ls-lt); +} + +@ The initial values of |str_pool|, |str_start|, |pool_ptr|, +and |str_ptr| are computed by the \.{INIMP} program, based in part +on the information that \.{WEB} has output while processing \MP. +@.INIMP@> +@^string pool@> + +@c +void mp_get_strings_started (MP mp) { + /* initializes the string pool, + but returns |false| if something goes wrong */ + int k; /* small indices or counters */ + str_number g; /* a new string */ + mp->pool_ptr=0; mp->str_ptr=0; mp->max_pool_ptr=0; mp->max_str_ptr=0; + mp->str_start[0]=0; + mp->next_str[0]=1; + mp->pool_in_use=0; mp->strs_in_use=0; + mp->max_pl_used=0; mp->max_strs_used=0; + @<Initialize compaction statistics@>; + mp->strs_used_up=0; + @<Make the first 256 strings@>; + g=mp_make_string(mp); /* string 256 == "" */ + mp->str_ref[g]=max_str_ref; + mp->last_fixed_str=mp->str_ptr-1; + mp->fixed_str_use=mp->str_ptr; + return; +} + +@ @<Declarations@>= +static void mp_get_strings_started (MP mp); + +@ The first 256 strings will consist of a single character only. + +@<Make the first 256...@>= +for (k=0;k<=255;k++) { + append_char(k); + g=mp_make_string(mp); + mp->str_ref[g]=max_str_ref; +} + +@ The first 128 strings will contain 95 standard ASCII characters, and the +other 33 characters will be printed in three-symbol form like `\.{\^\^A}' +unless a system-dependent change is made here. Installations that have +an extended character set, where for example |xchr[032]=@t\.{'^^Z'}@>|, +would like string 032 to be printed as the single character 032 instead +of the three characters 0136, 0136, 0132 (\.{\^\^Z}). On the other hand, +even people with an extended character set will want to represent string +015 by \.{\^\^M}, since 015 is ASCII's ``carriage return'' code; the idea is +to produce visible strings instead of tabs or line-feeds or carriage-returns +or bell-rings or characters that are treated anomalously in text files. + +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) + +@* \[5] On-line and off-line printing. +Messages that are sent to a user's terminal and to the transcript-log file +are produced by several `|print|' procedures. These procedures will +direct their output to a variety of places, based on the setting of +the global variable |selector|, which has the following possible +values: + +\yskip +\hang |term_and_log|, the normal setting, prints on the terminal and on the + transcript file. + +\hang |log_only|, prints only on the transcript file. + +\hang |term_only|, prints only on the terminal. + +\hang |no_print|, doesn't print at all. This is used only in rare cases + before the transcript file is open. + +\hang |pseudo|, puts output into a cyclic buffer that is used + by the |show_context| routine; when we get to that routine we shall discuss + the reasoning behind this curious mode. + +\hang |new_string|, appends the output to the current string in the + string pool. + +\hang |>=write_file| prints on one of the files used for the \&{write} +@:write_}{\&{write} primitive@> + command. + +\yskip +\noindent The symbolic names `|term_and_log|', etc., have been assigned +numeric codes that satisfy the convenient relations |no_print+1=term_only|, +|no_print+2=log_only|, |term_only+2=log_only+1=term_and_log|. These +relations are not used when |selector| could be |pseudo|, or |new_string|. +We need not check for unprintable characters when |selector<pseudo|. + +Three additional global variables, |tally|, |term_offset| and |file_offset| +record the number of characters that have been printed +since they were most recently cleared to zero. We use |tally| to record +the length of (possibly very long) stretches of printing; |term_offset|, +and |file_offset|, on the other hand, keep track of how many +characters have appeared so far on the current line that has been output +to the terminal, the transcript file, or the \ps\ output file, respectively. + +@d new_string 0 /* printing is deflected to the string pool */ +@d pseudo 2 /* special |selector| setting for |show_context| */ +@d no_print 3 /* |selector| setting that makes data disappear */ +@d term_only 4 /* printing is destined for the terminal only */ +@d log_only 5 /* printing is destined for the transcript file only */ +@d term_and_log 6 /* normal |selector| setting */ +@d write_file 7 /* first write file selector */ + +@<Glob...@>= +void * log_file; /* transcript of \MP\ session */ +void * output_file; /* the generic font output goes here */ +unsigned int selector; /* where to print a message */ +unsigned char dig[23]; /* digits in a number, for rounding */ +integer tally; /* the number of characters recently printed */ +unsigned int term_offset; + /* the number of characters on the current terminal line */ +unsigned int file_offset; + /* the number of characters on the current file line */ +ASCII_code *trick_buf; /* circular buffer for pseudoprinting */ +integer trick_count; /* threshold for pseudoprinting, explained later */ +integer first_count; /* another variable for pseudoprinting */ + +@ @<Allocate or initialize ...@>= +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@> + +@(mpmp.h@>= +#define do_fprintf(f,b) (mp->write_ascii_file)(mp,f,b) +#define wterm(A) do_fprintf(mp->term_out,(A)) +#define wterm_chr(A) { unsigned char ss[2]; ss[0]=(A); ss[1]='\0'; wterm((char *)ss);} +#define wterm_cr do_fprintf(mp->term_out,"\n") +#define wterm_ln(A) { wterm_cr; do_fprintf(mp->term_out,(A)); } +#define wlog(A) do_fprintf(mp->log_file,(A)) +#define wlog_chr(A) { unsigned char ss[2]; ss[0]=(A); ss[1]='\0'; wlog((char *)ss);} +#define wlog_cr do_fprintf(mp->log_file, "\n") +#define wlog_ln(A) { wlog_cr; do_fprintf(mp->log_file,(A)); } + + +@ To end a line of text output, we call |print_ln|. Cases |0..max_write_files| +use an array |wr_file| that will be declared later. + +@d mp_print_text(A) mp_print_str(mp,text((A))) + +@<Internal library ...@>= +void mp_print (MP mp, const char *s); +void mp_print_ln (MP mp); +void mp_print_visible_char (MP mp, ASCII_code s); +void mp_print_char (MP mp, ASCII_code k); +void mp_print_str (MP mp, str_number s); +void mp_print_nl (MP mp, const char *s); +void mp_print_two (MP mp,scaled x, scaled y) ; +void mp_print_scaled (MP mp,scaled s); + +@ @<Basic print...@>= +void mp_print_ln (MP mp) { /* prints an end-of-line */ + switch (mp->selector) { + case term_and_log: + wterm_cr; wlog_cr; + mp->term_offset=0; mp->file_offset=0; + break; + case log_only: + wlog_cr; mp->file_offset=0; + break; + case term_only: + wterm_cr; mp->term_offset=0; + break; + case no_print: + case pseudo: + case new_string: + break; + default: + do_fprintf(mp->wr_file[(mp->selector-write_file)],"\n"); + } +} /* note that |tally| is not affected */ + +@ The |print_visible_char| procedure sends one character to the desired +destination, using the |xchr| array to map it into an external character +compatible with |input_ln|. (It assumes that it is always called with +a visible ASCII character.) All printing comes through |print_ln| or +|print_char|, which ultimately calls |print_visible_char|, hence these +routines are the ones that limit lines to at most |max_print_line| characters. +But we must make an exception for the \ps\ output file since it is not safe +to cut up lines arbitrarily in \ps. + +Procedure |unit_str_room| needs to be declared |forward| here because it calls +|do_compaction| and |do_compaction| can call the error routines. Actually, +|unit_str_room| avoids |overflow| errors but it can call |confusion|. + +@<Basic printing...@>= +void mp_print_visible_char (MP mp, ASCII_code s) { /* prints a single character */ + switch (mp->selector) { + case term_and_log: + wterm_chr(xchr(s)); wlog_chr(xchr(s)); + incr(mp->term_offset); incr(mp->file_offset); + if ( mp->term_offset==(unsigned)mp->max_print_line ) { + wterm_cr; mp->term_offset=0; + }; + if ( mp->file_offset==(unsigned)mp->max_print_line ) { + wlog_cr; mp->file_offset=0; + }; + break; + case log_only: + wlog_chr(xchr(s)); incr(mp->file_offset); + if ( mp->file_offset==(unsigned)mp->max_print_line ) mp_print_ln(mp); + break; + case term_only: + wterm_chr(xchr(s)); incr(mp->term_offset); + if ( mp->term_offset==(unsigned)mp->max_print_line ) mp_print_ln(mp); + break; + case no_print: + break; + case pseudo: + if ( mp->tally<mp->trick_count ) + mp->trick_buf[mp->tally % mp->error_line]=s; + break; + case new_string: + if (mp->pool_ptr>=mp->pool_size || mp->pool_ptr>=mp->max_pool_ptr ) { + mp_unit_str_room(mp); + if ( mp->pool_ptr>=mp->pool_size ) + goto DONE; /* drop characters if string space is full */ + }; + append_char(s); + break; + default: + { text_char ss[2]; ss[0] = xchr(s); ss[1]=0; + do_fprintf(mp->wr_file[(mp->selector-write_file)],(char *)ss); + } + } +DONE: + incr(mp->tally); +} + +@ The |print_char| procedure sends one character to the desired destination. +File names and string expressions might contain |ASCII_code| values that +can't be printed using |print_visible_char|. These characters will be +printed in three- or four-symbol form like `\.{\^\^A}' or `\.{\^\^e4}'. +(This procedure assumes that it is safe to bypass all checks for unprintable +characters when |selector| is in the range |0..max_write_files-1|. +The user might want to write unprintable characters. + +@<Basic printing...@>= +void mp_print_char (MP mp, ASCII_code k) { /* prints a single character */ + if ( mp->selector<pseudo || mp->selector>=write_file) { + mp_print_visible_char(mp, k); + } else if ( @<Character |k| cannot be printed@> ) { + mp_print(mp, "^^"); + if ( k<0100 ) { + mp_print_visible_char(mp, k+0100); + } else if ( k<0200 ) { + mp_print_visible_char(mp, k-0100); + } else { + 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| */ + size_t j = 0; + if (mp->selector == new_string) { + str_room((integer)(len*4)); + } + 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) { + if (ss==NULL) return; + mp_do_print(mp, ss,strlen(ss)); +} +void mp_print_str (MP mp, str_number s) { + pool_pointer j; /* current character code position */ + if ( (s<0)||(s>mp->max_str_ptr) ) { + mp_do_print(mp,"???",3); /* this can't happen */ +@.???@> + } + j=mp->str_start[s]; + mp_do_print(mp, (char *)(mp->str_pool+j), (size_t)(str_stop(s)-j)); +} + + +@ Here is the very first thing that \MP\ prints: a headline that identifies +the version number and base name. The |term_offset| variable is temporarily +incorrect, but the discrepancy is not serious since we assume that the banner +and mem identifier together will occupy at most |max_print_line| +character positions. + +@<Initialize the output...@>= +wterm (mp->banner); +if (mp->mem_ident!=NULL) + mp_print(mp,mp->mem_ident); +mp_print_ln(mp); +update_terminal; + +@ The procedure |print_nl| is like |print|, but it makes sure that the +string appears at the beginning of a new line. + +@<Basic print...@>= +void mp_print_nl (MP mp, const char *s) { /* prints string |s| at beginning of line */ + switch(mp->selector) { + case term_and_log: + if ( (mp->term_offset>0)||(mp->file_offset>0) ) mp_print_ln(mp); + break; + case log_only: + if ( mp->file_offset>0 ) mp_print_ln(mp); + break; + case term_only: + if ( mp->term_offset>0 ) mp_print_ln(mp); + break; + case no_print: + case pseudo: + case new_string: + break; + } /* there are no other cases */ + mp_print(mp, s); +} + +@ 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); +} + +@ @<Internal library ...@>= +void mp_print_int (MP mp,integer n); + +@ \MP\ also makes use of a trivial procedure to print two digits. The +following subroutine is usually called with a parameter in the range |0<=n<=99|. + +@c +static void mp_print_dd (MP mp,integer n) { /* prints two least significant digits */ + n=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 */ + } +} + +@* \[6] Reporting errors. +When something anomalous is detected, \MP\ typically does something like this: +$$\vbox{\halign{#\hfil\cr +|print_err("Something anomalous has been detected");|\cr +|help3("This is the first line of my offer to help.")|\cr +|("This is the second line. I'm trying to")|\cr +|("explain the best way for you to proceed.");|\cr +|error;|\cr}}$$ +A two-line help message would be given using |help2|, etc.; these informal +helps should use simple vocabulary that complements the words used in the +official error message that was printed. (Outside the U.S.A., the help +messages should preferably be translated into the local vernacular. Each +line of help is at most 60 characters long, in the present implementation, +so that |max_print_line| will not be exceeded.) + +The |print_err| procedure supplies a `\.!' before the official message, +and makes sure that the terminal is awake if a stop is going to occur. +The |error| procedure supplies a `\..' after the official message, then it +shows the location of the error; and if |interaction=error_stop_mode|, +it also enters into a dialog with the user, during which time the help +message may be printed. +@^system dependencies@> + +@ The global variable |interaction| has four settings, representing increasing +amounts of user interaction: + +@<Exported types@>= +enum mp_interaction_mode { + mp_unspecified_mode=0, /* extra value for command-line switch */ + mp_batch_mode, /* omits all stops and omits terminal output */ + mp_nonstop_mode, /* omits all stops */ + mp_scroll_mode, /* omits error stops */ + mp_error_stop_mode /* stops at every opportunity to interact */ +}; + +@ @<Option variables@>= +int interaction; /* current level of interaction */ +int noninteractive; /* do we have a terminal? */ + +@ Set it here so it can be overwritten by the commandline + +@<Allocate or initialize ...@>= +mp->interaction=opt->interaction; +if (mp->interaction==mp_unspecified_mode || mp->interaction>mp_error_stop_mode) + mp->interaction=mp_error_stop_mode; +if (mp->interaction<mp_unspecified_mode) + mp->interaction=mp_batch_mode; + +@ + +@d print_err(A) mp_print_err(mp,(A)) + +@<Internal ...@>= +void mp_print_err(MP mp, const char * A); + +@ @c +void mp_print_err(MP mp, const char * A) { + if ( mp->interaction==mp_error_stop_mode ) + wake_up_terminal; + if (mp->file_line_error_style && file_state && !terminal_input) { + mp_print_nl(mp, ""); + if (mp->long_name != NULL) { + mp_print(mp, 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). + +@<Initialize the print |selector| based on |interaction|@>= +if ( mp->interaction==mp_batch_mode ) mp->selector=no_print; else mp->selector=term_only + +@ A global variable |deletions_allowed| is set |false| if the |get_next| +routine is active when |error| is called; this ensures that |get_next| +will never be called recursively. +@^recursion@> + +The global variable |history| records the worst level of error that +has been detected. It has four possible values: |spotless|, |warning_issued|, +|error_message_issued|, and |fatal_error_stop|. + +Another global variable, |error_count|, is increased by one when an +|error| occurs without an interactive dialog, and it is reset to zero at +the end of every statement. If |error_count| reaches 100, \MP\ decides +that there is no point in continuing further. + +@<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...@>= +boolean deletions_allowed; /* is it safe for |error| to call |get_next|? */ +int history; /* has the source input been clean so far? */ +int error_count; /* the number of scrolled errors since the last statement ended */ + +@ The value of |history| is initially |fatal_error_stop|, but it will +be changed to |spotless| if \MP\ survives the initialization process. + +@<Allocate or ...@>= +mp->deletions_allowed=true; /* |history| is initialized elsewhere */ + +@ Since errors can be detected almost anywhere in \MP, we want to declare the +error procedures near the beginning of the program. But the error procedures +in turn use some other procedures, which need to be declared |forward| +before we get to |error| itself. + +It is possible for |error| to be called recursively if some error arises +when |get_next| is being used to delete a token, and/or if some fatal error +occurs while \MP\ is trying to fix a non-fatal one. But such recursion +@^recursion@> +is never more than two levels deep. + +@<Declarations@>= +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); + +@ Individual lines of help are recorded in the array |help_line|, which +contains entries in positions |0..(help_ptr-1)|. They should be printed +in reverse order, i.e., with |help_line[0]| appearing last. + +@d hlp1(A) mp->help_line[0]=A; } +@d hlp2(A,B) mp->help_line[1]=A; hlp1(B) +@d hlp3(A,B,C) mp->help_line[2]=A; hlp2(B,C) +@d hlp4(A,B,C,D) mp->help_line[3]=A; hlp3(B,C,D) +@d hlp5(A,B,C,D,E) mp->help_line[4]=A; hlp4(B,C,D,E) +@d hlp6(A,B,C,D,E,F) mp->help_line[5]=A; hlp5(B,C,D,E,F) +@d help0 mp->help_ptr=0 /* sometimes there might be no help */ +@d help1 { mp->help_ptr=1; hlp1 /* use this with one help line */ +@d help2 { mp->help_ptr=2; hlp2 /* use this with two help lines */ +@d help3 { mp->help_ptr=3; hlp3 /* use this with three help lines */ +@d help4 { mp->help_ptr=4; hlp4 /* use this with four help lines */ +@d help5 { mp->help_ptr=5; hlp5 /* use this with five help lines */ +@d help6 { mp->help_ptr=6; hlp6 /* use this with six help lines */ + +@<Glob...@>= +const char * help_line[6]; /* helps for the next |error| */ +unsigned int help_ptr; /* the number of help lines present */ +boolean use_err_help; /* should the |err_help| string be shown? */ +str_number err_help; /* a string set up by \&{errhelp} */ + +@ @<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...@>= +static 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); +} + +@ Here now is the general |error| routine. + +@<Error hand...@>= +void mp_error (MP mp) { /* completes the job of error reporting */ + ASCII_code c; /* what the user types */ + integer s1,s2,s3; /* used to save global variables when deleting tokens */ + pool_pointer j; /* character position being printed */ + if ( mp->history<mp_error_message_issued ) + mp->history=mp_error_message_issued; + mp_print_char(mp, 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@>; +} +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; +} + +@ @<Exported function ...@>= +extern void mp_error (MP mp); +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=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@> +} + +@ +There is a secret `\.D' option available when the debugging routines haven't +been commented~out. +@^debugging@> + +@<Interpret code |c| and |return| if done@>= +switch (c) { +case '0': case '1': case '2': case '3': case '4': +case '5': case '6': case '7': case '8': case '9': + if ( mp->deletions_allowed ) { + @<Delete |c-"0"| tokens and |continue|@>; + } + break; +case 'E': + if ( mp->file_ptr>0 ){ + mp->interaction=mp_scroll_mode; + mp_close_files_and_terminate(mp); + (mp->run_editor)(mp, + str(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 ( mp->deletions_allowed ) + mp_print_nl(mp, "1 or ... or 9 to ignore the next 1 to 9 tokens of input,"); + mp_print_nl(mp, "H for help, X to quit."); +} + +@ Here the author of \MP\ apologizes for making use of the numerical +relation between |"Q"|, |"R"|, |"S"|, and the desired interaction settings +|mp_batch_mode|, |mp_nonstop_mode|, |mp_scroll_mode|. +@^Knuth, Donald Ervin@> + +@<Change the interaction...@>= +{ + mp->error_count=0; mp->interaction=mp_batch_mode+c-'Q'; + mp_print(mp, "OK, entering "); + switch (c) { + case 'Q': mp_print(mp, "batchmode"); decr(mp->selector); break; + case 'R': mp_print(mp, "nonstopmode"); break; + case 'S': mp_print(mp, "scrollmode"); break; + } /* there are no other cases */ + mp_print(mp, "..."); mp_print_ln(mp); update_terminal; return; +} + +@ When the following code is executed, |buffer[(first+1)..(last-1)]| may +contain the material inserted by the user; otherwise another prompt will +be given. In order to understand this part of the program fully, you need +to be familiar with \MP's input stacks. + +@<Introduce new material...@>= +{ + mp_begin_file_reading(mp); /* enter a new syntactic level for terminal input */ + if ( mp->last>mp->first+1 ) { + loc=(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 |c-"0"| tokens...@>= +{ + s1=mp->cur_cmd; s2=mp->cur_mod; s3=mp->cur_sym; mp->OK_to_interrupt=false; + if ( (mp->last>mp->first+1) && (mp->buffer[mp->first+1]>='0')&&(mp->buffer[mp->first+1]<='9') ) + c=xord(c*10+mp->buffer[mp->first+1]-'0'*11); + else + c=c-'0'; + while ( c>0 ) { + mp_get_next(mp); /* one-level recursive call of |error| is possible */ + @<Decrease the string reference count, if the current token is a string@>; + decr(c); + }; + mp->cur_cmd=s1; mp->cur_mod=s2; mp->cur_sym=s3; mp->OK_to_interrupt=true; + help2("I have just deleted some text, as you asked.", + "You can now delete more, or insert, or whatever."); + mp_show_context(mp); + goto CONTINUE; +} + +@ @<Print the help info...@>= +{ + if ( mp->use_err_help ) { + @<Print the string |err_help|, possibly on several lines@>; + mp->use_err_help=false; + } else { + if ( mp->help_ptr==0 ) { + help2("Sorry, I don't know how to help in this situation.", + "Maybe you should try asking a human?"); + } + do { + decr(mp->help_ptr); mp_print(mp, mp->help_line[mp->help_ptr]); mp_print_ln(mp); + } while (mp->help_ptr!=0); + }; + help4("Sorry, I already gave what help I could...", + "Maybe you should try asking a human?", + "An error might have occurred before I noticed any problems.", + "``If all else fails, read the instructions.''"); + goto CONTINUE; +} + +@ @<Print the string |err_help|, possibly on several lines@>= +j=mp->str_start[mp->err_help]; +while ( j<str_stop(mp->err_help) ) { + if ( mp->str_pool[j]!='%' ) mp_print_str(mp, mp->str_pool[j]); + else if ( j+1==str_stop(mp->err_help) ) mp_print_ln(mp); + else if ( mp->str_pool[j+1]!='%' ) mp_print_ln(mp); + else { j++; mp_print_char(mp, xord('%')); }; + j++; +} + +@ @<Put help message on the transcript file@>= +if ( mp->interaction>mp_batch_mode ) decr(mp->selector); /* avoid terminal output */ +if ( mp->use_err_help ) { + mp_print_nl(mp, ""); + @<Print the string |err_help|, possibly on several lines@>; +} else { + while ( mp->help_ptr>0 ){ + decr(mp->help_ptr); mp_print_nl(mp, mp->help_line[mp->help_ptr]); + }; +} +mp_print_ln(mp); +if ( mp->interaction>mp_batch_mode ) incr(mp->selector); /* re-enable terminal output */ +mp_print_ln(mp) + +@ In anomalous cases, the print selector might be in an unknown state; +the following subroutine is called to fix things just enough to keep +running a bit longer. + +@c +void mp_normalize_selector (MP mp) { + if ( mp->log_opened ) mp->selector=term_and_log; + else mp->selector=term_only; + if ( mp->job_name==NULL) mp_open_log_file(mp); + if ( mp->interaction==mp_batch_mode ) decr(mp->selector); +} + +@ The following procedure prints \MP's last words before dying. + +@d succumb { if ( mp->interaction==mp_error_stop_mode ) + mp->interaction=mp_scroll_mode; /* no more interaction */ + if ( mp->log_opened ) mp_error(mp); + mp->history=mp_fatal_error_stop; mp_jump_out(mp); /* irrecoverable error */ + } + +@<Error hand...@>= +void mp_fatal_error (MP mp, const char *s) { /* prints |s|, and that's it */ + mp_normalize_selector(mp); + print_err("Emergency stop"); help1(s); succumb; +@.Emergency stop@> +} + +@ @<Exported function ...@>= +extern void mp_fatal_error (MP mp, const char *s); + + +@ Here is the most dreaded error message. + +@<Error hand...@>= +void mp_overflow (MP mp, const char *s, integer n) { /* stop due to finiteness */ + char msg[256]; + mp_normalize_selector(mp); + mp_snprintf(msg, 256, "MetaPost capacity exceeded, sorry [%s=%d]",s,(int)n); +@.MetaPost capacity exceeded ...@> + print_err(msg); + help2("If you really absolutely need more capacity,", + "you can ask a wizard to enlarge me."); + succumb; +} + +@ @<Internal library declarations@>= +void mp_overflow (MP mp, const char *s, integer n); + +@ The program might sometime run completely amok, at which point there is +no choice but to stop. If no previous error has been detected, that's bad +news; a message is printed that is really intended for the \MP\ +maintenance person instead of the user (unless the user has been +particularly diabolical). The index entries for `this can't happen' may +help to pinpoint the problem. +@^dry rot@> + +@<Internal library ...@>= +void mp_confusion (MP mp, const char *s); + +@ Consistency check violated; |s| tells where. +@<Error hand...@>= +void mp_confusion (MP mp, const char *s) { + char msg[256]; + 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@> + print_err(msg); + help1("I'm broken. Please show this to someone who can fix can fix"); + } else { + print_err("I can\'t go on meeting you like this"); +@.I can't go on...@> + help2("One of your faux pas seems to have wounded me deeply...", + "in fact, I'm barely conscious. Please fix it and try again."); + } + succumb; +} + +@ Users occasionally want to interrupt \MP\ while it's running. +If the runtime system allows this, one can implement +a routine that sets the global variable |interrupt| to some nonzero value +when such an interrupt is signaled. Otherwise there is probably at least +a way to make |interrupt| nonzero using the C debugger. +@^system dependencies@> +@^debugging@> + +@d check_interrupt { if ( mp->interrupt!=0 ) + mp_pause_for_instructions(mp); } + +@<Global...@>= +integer interrupt; /* should \MP\ pause for instructions? */ +boolean OK_to_interrupt; /* should interrupts be observed? */ +integer run_state; /* are we processing input ?*/ +boolean finished; /* set true by |close_files_and_terminate| */ + +@ @<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) { + if ( mp->OK_to_interrupt ) { + mp->interaction=mp_error_stop_mode; + if ( (mp->selector==log_only)||(mp->selector==no_print) ) + incr(mp->selector); + print_err("Interruption"); +@.Interruption@> + help3("You rang?", + "Try to insert some instructions for me (e.g.,`I show x'),", + "unless you just want to quit by typing `X'."); + mp->deletions_allowed=false; mp_error(mp); mp->deletions_allowed=true; + mp->interrupt=0; + } +} + +@ Many of \MP's error messages state that a missing token has been +inserted behind the scenes. We can save string space and program space +by putting this common code into a subroutine. + +@c +static void mp_missing_err (MP mp, const char *s) { + char msg[256]; + mp_snprintf(msg, 256, "Missing `%s' has been inserted", s); +@.Missing...inserted@> + print_err(msg); +} + +@* \[7] Arithmetic with scaled numbers. +The principal computations performed by \MP\ are done entirely in terms of +integers less than $2^{31}$ in magnitude; thus, the arithmetic specified in this +program can be carried out in exactly the same way on a wide variety of +computers, including some small ones. +@^small computers@> + +But C does not rigidly define the |/| operation in the case of negative +dividends; for example, the result of |(-2*n-1) / 2| is |-(n+1)| on some +computers and |-n| on others (is this true ?). There are two principal +types of arithmetic: ``translation-preserving,'' in which the identity +|(a+q*b)/b=(a/b)+q| is valid; and ``negation-preserving,'' in which +|(-a)/b=-(a/b)|. This leads to two \MP s, which can produce +different results, although the differences should be negligible when the +language is being used properly. The \TeX\ processor has been defined +carefully so that both varieties of arithmetic will produce identical +output, but it would be too inefficient to constrain \MP\ in a similar way. + +@d el_gordo 0x7fffffff /* $2^{31}-1$, the largest value that \MP\ likes */ + + +@ One of \MP's most common operations is the calculation of +$\lfloor{a+b\over2}\rfloor$, +the midpoint of two given integers |a| and~|b|. The most decent way to do +this is to write `|(a+b)/2|'; but on many machines it is more efficient +to calculate `|(a+b)>>1|'. + +Therefore the midpoint operation will always be denoted by `|half(a+b)|' +in this program. If \MP\ is being implemented with languages that permit +binary shifting, the |half| macro should be changed to make this operation +as efficient as possible. Since some systems have shift operators that can +only be trusted to work on positive numbers, there is also a macro |halfp| +that is used only when the quantity being halved is known to be positive +or zero. + +@d half(A) ((A) / 2) +@d halfp(A) (integer)((unsigned)(A) >> 1) + +@ A single computation might use several subroutine calls, and it is +desirable to avoid producing multiple error messages in case of arithmetic +overflow. So the routines below set the global variable |arith_error| to |true| +instead of reporting errors directly to the user. +@^overflow in arithmetic@> + +@<Glob...@>= +boolean arith_error; /* has arithmetic overflow occurred recently? */ + +@ @<Allocate or ...@>= +mp->arith_error=false; + +@ At crucial points the program will say |check_arith|, to test if +an arithmetic error has been detected. + +@d check_arith { if ( mp->arith_error ) mp_clear_arith(mp); } + +@c +static void mp_clear_arith (MP mp) { + print_err("Arithmetic overflow"); +@.Arithmetic overflow@> + help4("Uh, oh. A little while ago one of the quantities that I was", + "computing got too large, so I'm afraid your answers will be", + "somewhat askew. You'll probably have to adopt different", + "tactics next time. But I shall try to carry on anyway."); + mp_error(mp); + mp->arith_error=false; +} + +@ Addition is not always checked to make sure that it doesn't overflow, +but in places where overflow isn't too unlikely the |slow_add| routine +is used. + +@c static integer mp_slow_add (MP mp,integer x, integer y) { + if ( x>=0 ) { + if ( y<=el_gordo-x ) { + return x+y; + } else { + mp->arith_error=true; + return el_gordo; + } + } else if ( -y<=el_gordo+x ) { + return x+y; + } else { + mp->arith_error=true; + return -el_gordo; + } +} + +@ Fixed-point arithmetic is done on {\sl scaled integers\/} that are multiples +of $2^{-16}$. In other words, a binary point is assumed to be sixteen bit +positions from the right end of a binary computer word. + +@d quarter_unit 040000 /* $2^{14}$, represents 0.250000 */ +@d half_unit 0100000 /* $2^{15}$, represents 0.50000 */ +@d three_quarter_unit 0140000 /* $3\cdot2^{14}$, represents 0.75000 */ +@d unity 0200000 /* $2^{16}$, represents 1.00000 */ +@d two 0400000 /* $2^{17}$, represents 2.00000 */ +@d three 0600000 /* $2^{17}+2^{16}$, represents 3.00000 */ + +@<Types...@>= +typedef integer scaled; /* this type is used for scaled integers */ + +@ The following function is used to create a scaled integer from a given decimal +fraction $(.d_0d_1\ldots d_{k-1})$, where |0<=k<=17|. The digit $d_i$ is +given in |dig[i]|, and the calculation produces a correctly rounded result. + +@c +static scaled mp_round_decimals (MP mp,quarterword k) { + /* converts a decimal fraction */ + unsigned a = 0; /* the accumulator */ + while ( k-->0 ) { + a=(a+mp->dig[k]*two) / 10; + } + return (scaled)halfp(a+1); +} + +@ Conversely, here is a procedure analogous to |print_int|. If the output +of this procedure is subsequently read by \MP\ and converted by the +|round_decimals| routine above, it turns out that the original value will +be reproduced exactly. A decimal point is printed only if the value is +not an integer. If there is more than one way to print the result with +the optimum number of digits following the decimal point, the closest +possible value is given. + +The invariant relation in the \&{repeat} loop is that a sequence of +decimal digits yet to be printed will yield the original number if and only if +they form a fraction~$f$ in the range $s-\delta\L10\cdot2^{16}f<s$. +We can stop if and only if $f=0$ satisfies this condition; the loop will +terminate before $s$ can possibly become zero. + +@<Basic printing...@>= +void mp_print_scaled (MP mp,scaled s) { /* prints scaled real, rounded to five digits */ + scaled delta; /* amount of allowable inaccuracy */ + if ( s<0 ) { + mp_print_char(mp, xord('-')); + negate(s); /* print the sign, if negative */ + } + mp_print_int(mp, s / unity); /* print the integer part */ + s=10*(s % unity)+5; + if ( s!=5 ) { + delta=10; + mp_print_char(mp, 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); + } +} + +@ We often want to print two scaled quantities in parentheses, +separated by a comma. + +@<Basic printing...@>= +void mp_print_two (MP mp,scaled x, scaled y) { /* prints `|(x,y)|' */ + mp_print_char(mp, xord('(')); + mp_print_scaled(mp, x); + mp_print_char(mp, xord(',')); + mp_print_scaled(mp, y); + mp_print_char(mp, xord(')')); +} + +@ The |scaled| quantities in \MP\ programs are generally supposed to be +less than $2^{12}$ in absolute value, so \MP\ does much of its internal +arithmetic with 28~significant bits of precision. A |fraction| denotes +a scaled integer whose binary point is assumed to be 28 bit positions +from the right. + +@d fraction_half 01000000000 /* $2^{27}$, represents 0.50000000 */ +@d fraction_one 02000000000 /* $2^{28}$, represents 1.00000000 */ +@d fraction_two 04000000000 /* $2^{29}$, represents 2.00000000 */ +@d fraction_three 06000000000 /* $3\cdot2^{28}$, represents 3.00000000 */ +@d fraction_four 010000000000 /* $2^{30}$, represents 4.00000000 */ + +@<Types...@>= +typedef integer fraction; /* this type is used for scaled fractions */ + +@ In fact, the two sorts of scaling discussed above aren't quite +sufficient; \MP\ has yet another, used internally to keep track of angles +in units of $2^{-20}$ degrees. + +@d forty_five_deg 0264000000 /* $45\cdot2^{20}$, represents $45^\circ$ */ +@d ninety_deg 0550000000 /* $90\cdot2^{20}$, represents $90^\circ$ */ +@d one_eighty_deg 01320000000 /* $180\cdot2^{20}$, represents $180^\circ$ */ +@d three_sixty_deg 02640000000 /* $360\cdot2^{20}$, represents $360^\circ$ */ + +@<Types...@>= +typedef integer angle; /* this type is used for scaled angles */ + +@ The |make_fraction| routine produces the |fraction| equivalent of +|p/q|, given integers |p| and~|q|; it computes the integer +$f=\lfloor2^{28}p/q+{1\over2}\rfloor$, when $p$ and $q$ are +positive. If |p| and |q| are both of the same scaled type |t|, +the ``type relation'' |make_fraction(t,t)=fraction| is valid; +and it's also possible to use the subroutine ``backwards,'' using +the relation |make_fraction(t,fraction)=t| between scaled types. + +If the result would have magnitude $2^{31}$ or more, |make_fraction| +sets |arith_error:=true|. Most of \MP's internal computations have +been designed to avoid this sort of error. + +If this subroutine were programmed in assembly language on a typical +machine, we could simply compute |(@t$2^{28}$@>*p)div q|, since a +double-precision product can often be input to a fixed-point division +instruction. But when we are restricted to int-eger arithmetic it +is necessary either to resort to multiple-precision maneuvering +or to use a simple but slow iteration. The multiple-precision technique +would be about three times faster than the code adopted here, but it +would be comparatively long and tricky, involving about sixteen +additional multiplications and divisions. + +This operation is part of \MP's ``inner loop''; indeed, it will +consume nearly 10\pct! of the running time (exclusive of input and output) +if the code below is left unchanged. A machine-dependent recoding +will therefore make \MP\ run faster. The present implementation +is highly portable, but slow; it avoids multiplication and division +except in the initial stage. System wizards should be careful to +replace it with a routine that is guaranteed to produce identical +results in all cases. +@^system dependencies@> + +As noted below, a few more routines should also be replaced by machine-dependent +code, for efficiency. But when a procedure is not part of the ``inner loop,'' +such changes aren't advisable; simplicity and robustness are +preferable to trickery, unless the cost is too high. +@^inner loop@> + +@<Internal library declarations@>= +integer mp_take_scaled (MP mp,integer q, scaled f) ; + +@ @<Declarations@>= +static fraction mp_make_fraction (MP mp,integer p, integer q); + +@ If FIXPT is not defined, 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 +fraction mp_make_fraction (MP mp,integer p, integer q) { + fraction i; + if ( q==0 ) mp_confusion(mp, "/"); +@:this can't happen /}{\quad \./@> +#ifdef FIXPT +{ + integer f; /* the fraction bits, with a leading 1 bit */ + integer n; /* the integer part of $\vert p/q\vert$ */ + boolean negative = false; /* should the result be negated? */ + if ( p<0 ) { + negate(p); negative=true; + } + if ( q<0 ) { + negate(q); negative = ! negative; + } + n=p / q; p=p % q; + if ( n>=8 ){ + mp->arith_error=true; + i= ( negative ? -el_gordo : el_gordo); + } else { + n=(n-1)*fraction_one; + @<Compute $f=\lfloor 2^{28}(1+p/q)+{1\over2}\rfloor$@>; + i = (negative ? (-(f+n)) : (f+n)); + } +} +#else /* FIXPT */ + { + register double d; + d = TWEXP28 * (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; + } + } +#endif /* FIXPT */ + return i; +} + +@ The |repeat| loop here preserves the following invariant relations +between |f|, |p|, and~|q|: +(i)~|0<=p<q|; (ii)~$fq+p=2^k(q+p_0)$, where $k$ is an integer and +$p_0$ is the original value of~$p$. + +Notice that the computation specifies +|(p-q)+p| instead of |(p+p)-q|, because the latter could overflow. +Let us hope that optimizing compilers do not miss this point; a +special variable |be_careful| is used to emphasize the necessary +order of computation. Optimizing compilers should keep |be_careful| +in a register, not store it in memory. +@^inner loop@> + +@<Compute $f=\lfloor 2^{28}(1+p/q)+{1\over2}\rfloor$@>= +{ + integer be_careful; /* disables certain compiler optimizations */ + f=1; + do { + be_careful=p-q; p=be_careful+p; + if ( p>=0 ) { + f=f+f+1; + } else { + f+=f; p=p+q; + } + } while (f<fraction_one); + be_careful=p-q; + if ( be_careful+p>=0 ) incr(f); +} + +@ The dual of |make_fraction| is |take_fraction|, which multiplies a +given integer~|q| by a fraction~|f|. When the operands are positive, it +computes $p=\lfloor qf/2^{28}+{1\over2}\rfloor$, a symmetric function +of |q| and~|f|. + +This routine is even more ``inner loopy'' than |make_fraction|; +the present implementation consumes almost 20\pct! of \MP's computation +time during typical jobs, so a machine-language substitute is advisable. +@^inner loop@> @^system dependencies@> + +@<Internal library declarations@>= +integer mp_take_fraction (MP mp,integer q, fraction f) ; + +@ @c +#ifdef FIXPT +integer mp_take_fraction (MP mp,integer q, fraction f) { + integer p; /* the fraction so far */ + boolean negative; /* should the result be negated? */ + integer n; /* additional multiple of $q$ */ + integer be_careful; /* disables certain compiler optimizations */ + @<Reduce to the case that |f>=0| and |q>=0|@>; + if ( f<fraction_one ) { + n=0; + } else { + n=f / fraction_one; f=f % fraction_one; + if ( q<=el_gordo / n ) { + n=n*q ; + } else { + mp->arith_error=true; n=el_gordo; + } + } + f=f+fraction_one; + @<Compute $p=\lfloor qf/2^{28}+{1\over2}\rfloor-q$@>; + be_careful=n-el_gordo; + if ( be_careful+p>0 ){ + mp->arith_error=true; n=el_gordo-p; + } + if ( negative ) + return (-(n+p)); + else + return (n+p); +#else /* FIXPT */ +integer mp_take_fraction (MP mp,integer p, fraction q) { + register double d; + register integer i; + d = (double)p * (double)q * TWEXP_28; + if ((p^q) >= 0) { + d += 0.5; + if (d>=TWEXP31) { + if (d!=TWEXP31 || (((p&077777)*(q&077777))&040000)==0) + mp->arith_error = true; + return 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; +#endif /* FIXPT */ +} + +@ @<Reduce to the case that |f>=0| and |q>=0|@>= +if ( f>=0 ) { + negative=false; +} else { + negate( f); negative=true; +} +if ( q<0 ) { + negate(q); negative=! negative; +} + +@ The invariant relations in this case are (i)~$\lfloor(qf+p)/2^k\rfloor +=\lfloor qf_0/2^{28}+{1\over2}\rfloor$, where $k$ is an integer and +$f_0$ is the original value of~$f$; (ii)~$2^k\L f<2^{k+1}$. +@^inner loop@> + +@<Compute $p=\lfloor qf/2^{28}+{1\over2}\rfloor-q$@>= +p=fraction_half; /* that's $2^{27}$; the invariants hold now with $k=28$ */ +if ( q<fraction_four ) { + do { + if ( odd(f) ) p=halfp(p+q); else p=halfp(p); + f=halfp(f); + } while (f!=1); +} else { + do { + if ( odd(f) ) p=p+halfp(q-p); else p=halfp(p); + f=halfp(f); + } while (f!=1); +} + + +@ When we want to multiply something by a |scaled| quantity, we use a scheme +analogous to |take_fraction| but with a different scaling. +Given positive operands, |take_scaled| +computes the quantity $p=\lfloor qf/2^{16}+{1\over2}\rfloor$. + +Once again it is a good idea to use a machine-language replacement if +possible; otherwise |take_scaled| will use more than 2\pct! of the running time +when the Computer Modern fonts are being generated. +@^inner loop@> + +@c +#ifdef FIXPT +integer mp_take_scaled (MP mp,integer q, scaled f) { + integer p; /* the fraction so far */ + boolean negative; /* should the result be negated? */ + integer n; /* additional multiple of $q$ */ + integer be_careful; /* disables certain compiler optimizations */ + @<Reduce to the case that |f>=0| and |q>=0|@>; + if ( f<unity ) { + n=0; + } else { + n=f / unity; f=f % unity; + if ( q<=el_gordo / n ) { + n=n*q; + } else { + mp->arith_error=true; n=el_gordo; + } + } + f=f+unity; + @<Compute $p=\lfloor qf/2^{16}+{1\over2}\rfloor-q$@>; + be_careful=n-el_gordo; + if ( be_careful+p>0 ) { + mp->arith_error=true; n=el_gordo-p; + } + return ( negative ?(-(n+p)) :(n+p)); +#else /* FIXPT */ +integer mp_take_scaled (MP mp,integer p, scaled q) { + register double d; + register integer i; + d = (double)p * (double)q * TWEXP_16; + if ((p^q) >= 0) { + d += 0.5; + if (d>=TWEXP31) { + if (d!=TWEXP31 || (((p&077777)*(q&077777))&040000)==0) + mp->arith_error = true; + return 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; +#endif /* FIXPT */ +} + +@ @<Compute $p=\lfloor qf/2^{16}+{1\over2}\rfloor-q$@>= +p=half_unit; /* that's $2^{15}$; the invariants hold now with $k=16$ */ +@^inner loop@> +if ( q<fraction_four ) { + do { + p = (odd(f) ? halfp(p+q) : halfp(p)); + f=halfp(f); + } while (f!=1); +} else { + do { + p = (odd(f) ? p+halfp(q-p) : halfp(p)); + f=halfp(f); + } while (f!=1); +} + +@ For completeness, there's also |make_scaled|, which computes a +quotient as a |scaled| number instead of as a |fraction|. +In other words, the result is $\lfloor2^{16}p/q+{1\over2}\rfloor$, if the +operands are positive. \ (This procedure is not used especially often, +so it is not part of \MP's inner loop.) + +@<Internal library ...@>= +scaled mp_make_scaled (MP mp,integer p, integer q) ; + +@ @c +scaled mp_make_scaled (MP mp,integer p, integer q) { + register integer i; + if ( q==0 ) mp_confusion(mp, "/"); +@:this can't happen /}{\quad \./@> + { +#ifdef FIXPT + integer f; /* the fraction bits, with a leading 1 bit */ + integer n; /* the integer part of $\vert p/q\vert$ */ + boolean negative; /* should the result be negated? */ + integer be_careful; /* disables certain compiler optimizations */ + if ( p>=0 ) negative=false; + else { negate(p); negative=true; }; + if ( q<0 ) { + negate(q); negative=! negative; + } + n=p / q; p=p % q; + if ( n>=0100000 ) { + mp->arith_error=true; + return (negative ? (-el_gordo) : el_gordo); + } else { + n=(n-1)*unity; + @<Compute $f=\lfloor 2^{16}(1+p/q)+{1\over2}\rfloor$@>; + i = (negative ? (-(f+n)) :(f+n)); + } +#else /* FIXPT */ + 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; + } +#endif /* FIXPT */ + } + return i; +} + +@ @<Compute $f=\lfloor 2^{16}(1+p/q)+{1\over2}\rfloor$@>= +f=1; +do { + be_careful=p-q; p=be_careful+p; + if ( p>=0 ) f=f+f+1; + else { f+=f; p=p+q; }; +} while (f<unity); +be_careful=p-q; +if ( be_careful+p>=0 ) incr(f) + +@ Here is a typical example of how the routines above can be used. +It computes the function +$${1\over3\tau}f(\theta,\phi)= +{\tau^{-1}\bigl(2+\sqrt2\,(\sin\theta-{1\over16}\sin\phi) + (\sin\phi-{1\over16}\sin\theta)(\cos\theta-\cos\phi)\bigr)\over +3\,\bigl(1+{1\over2}(\sqrt5-1)\cos\theta+{1\over2}(3-\sqrt5\,)\cos\phi\bigr)},$$ +where $\tau$ is a |scaled| ``tension'' parameter. This is \MP's magic +fudge factor for placing the first control point of a curve that starts +at an angle $\theta$ and ends at an angle $\phi$ from the straight path. +(Actually, if the stated quantity exceeds 4, \MP\ reduces it to~4.) + +The trigonometric quantity to be multiplied by $\sqrt2$ is less than $\sqrt2$. +(It's a sum of eight terms whose absolute values can be bounded using +relations such as $\sin\theta\cos\theta\L{1\over2}$.) Thus the numerator +is positive; and since the tension $\tau$ is constrained to be at least +$3\over4$, the numerator is less than $16\over3$. The denominator is +nonnegative and at most~6. Hence the fixed-point calculations below +are guaranteed to stay within the bounds of a 32-bit computer word. + +The angles $\theta$ and $\phi$ are given implicitly in terms of |fraction| +arguments |st|, |ct|, |sf|, and |cf|, representing $\sin\theta$, $\cos\theta$, +$\sin\phi$, and $\cos\phi$, respectively. + +@c +static fraction mp_velocity (MP mp,fraction st, fraction ct, fraction sf, + fraction cf, scaled t) { + integer acc,num,denom; /* registers for intermediate calculations */ + acc=mp_take_fraction(mp, st-(sf / 16), sf-(st / 16)); + acc=mp_take_fraction(mp, acc,ct-cf); + num=fraction_two+mp_take_fraction(mp, acc,379625062); + /* $2^{28}\sqrt2\approx379625062.497$ */ + denom=fraction_three+mp_take_fraction(mp, ct,497706707)+mp_take_fraction(mp, cf,307599661); + /* $3\cdot2^{27}\cdot(\sqrt5-1)\approx497706706.78$ and + $3\cdot2^{27}\cdot(3-\sqrt5\,)\approx307599661.22$ */ + if ( t!=unity ) num=mp_make_scaled(mp, num,t); + /* |make_scaled(fraction,scaled)=fraction| */ + if ( num / 4>=denom ) + return fraction_four; + else + return mp_make_fraction(mp, num, denom); +} + +@ The following somewhat different subroutine tests rigorously if $ab$ is +greater than, equal to, or less than~$cd$, +given integers $(a,b,c,d)$. In most cases a quick decision is reached. +The result is $+1$, 0, or~$-1$ in the three respective cases. + +@d mp_ab_vs_cd(M,A,B,C,D) mp_do_ab_vs_cd(A,B,C,D) + +@c +static integer mp_do_ab_vs_cd (integer a,integer b, integer c, integer d) { + integer q,r; /* temporary registers */ + @<Reduce to the case that |a,c>=0|, |b,d>0|@>; + while (1) { + q = a / d; r = c / b; + if ( q!=r ) + return ( q>r ? 1 : -1); + q = a % d; r = c % b; + if ( r==0 ) + return (q ? 1 : 0); + if ( q==0 ) return -1; + a=b; b=q; c=d; d=r; + } /* now |a>d>0| and |c>b>0| */ +} + +@ @<Reduce to the case that |a...@>= +if ( a<0 ) { negate(a); negate(b); }; +if ( c<0 ) { negate(c); negate(d); }; +if ( d<=0 ) { + if ( b>=0 ) { + if ( (a==0||b==0)&&(c==0||d==0) ) return 0; + else return 1; + } + if ( d==0 ) + return ( a==0 ? 0 : -1); + q=a; a=c; c=q; q=-b; b=-d; d=q; +} else if ( b<=0 ) { + if ( b<0 ) if ( a>0 ) return -1; + return (c==0 ? 0 : -1); +} + +@ We conclude this set of elementary routines with some simple rounding +and truncation operations. + +@<Internal library declarations@>= +#define mp_floor_scaled(M,i) ((i)&(-65536)) +#define mp_round_unscaled(M,i) (i>0 ? (((i/32768)+1)/2) : (((i/32768)-1)/2)) +#define mp_round_fraction(M,i) (i>0 ? (((i/2048)+1)/2) : (((i/2048)-1)/2)) + + +@* \[8] Algebraic and transcendental functions. +\MP\ computes all of the necessary special functions from scratch, without +relying on |real| arithmetic or system subroutines for sines, cosines, etc. + +@ To get the square root of a |scaled| number |x|, we want to calculate +$s=\lfloor 2^8\!\sqrt x +{1\over2}\rfloor$. If $x>0$, this is the unique +integer such that $2^{16}x-s\L s^2<2^{16}x+s$. The following subroutine +determines $s$ by an iterative method that maintains the invariant +relations $x=2^{46-2k}x_0\bmod 2^{30}$, $0<y=\lfloor 2^{16-2k}x_0\rfloor +-s^2+s\L q=2s$, where $x_0$ is the initial value of $x$. The value of~$y$ +might, however, be zero at the start of the first iteration. + +@<Declarations@>= +static scaled mp_square_rt (MP mp,scaled x) ; + +@ @c +scaled mp_square_rt (MP mp,scaled x) { + quarterword k; /* iteration control counter */ + integer y; /* register for intermediate calculations */ + unsigned q; /* register for intermediate calculations */ + if ( x<=0 ) { + @<Handle square root of zero or negative argument@>; + } else { + k=23; q=2; + while ( x<fraction_two ) { /* i.e., |while x<@t$2^{29}$@>|\unskip */ + decr(k); x=x+x+x+x; + } + if ( x<fraction_four ) y=0; + else { x=x-fraction_four; y=1; }; + do { + @<Decrease |k| by 1, maintaining the invariant + relations between |x|, |y|, and~|q|@>; + } while (k!=0); + return (scaled)(halfp(q)); + } +} + +@ @<Handle square root of zero...@>= +{ + if ( x<0 ) { + print_err("Square root of "); +@.Square root...replaced by 0@> + mp_print_scaled(mp, x); mp_print(mp, " has been replaced by 0"); + help2("Since I don't take square roots of negative numbers,", + "I'm zeroing this one. Proceed, with fingers crossed."); + mp_error(mp); + }; + return 0; +} + +@ @<Decrease |k| by 1, maintaining...@>= +x+=x; y+=y; +if ( x>=fraction_four ) { /* note that |fraction_four=@t$2^{30}$@>| */ + x=x-fraction_four; y++; +}; +x+=x; y=y+y-q; q+=q; +if ( x>=fraction_four ) { x=x-fraction_four; y++; }; +if ( y>(int)q ){ y=y-q; q=q+2; } +else if ( y<=0 ) { q=q-2; y=y+q; }; +decr(k) + +@ Pythagorean addition $\psqrt{a^2+b^2}$ is implemented by an elegant +iterative scheme due to Cleve Moler and Donald Morrison [{\sl IBM Journal +@^Moler, Cleve Barry@> +@^Morrison, Donald Ross@> +of Research and Development\/ \bf27} (1983), 577--581]. It modifies |a| and~|b| +in such a way that their Pythagorean sum remains invariant, while the +smaller argument decreases. + +@<Internal library ...@>= +integer mp_pyth_add (MP mp,integer a, integer b); + + +@ @c +integer mp_pyth_add (MP mp,integer a, integer b) { + fraction r; /* register used to transform |a| and |b| */ + boolean big; /* is the result dangerously near $2^{31}$? */ + a=abs(a); b=abs(b); + if ( a<b ) { r=b; b=a; a=r; }; /* now |0<=b<=a| */ + if ( b>0 ) { + if ( a<fraction_two ) { + big=false; + } else { + a=a / 4; b=b / 4; big=true; + }; /* we reduced the precision to avoid arithmetic overflow */ + @<Replace |a| by an approximation to $\psqrt{a^2+b^2}$@>; + if ( big ) { + if ( a<fraction_two ) { + a=a+a+a+a; + } else { + mp->arith_error=true; a=el_gordo; + }; + } + } + return a; +} + +@ The key idea here is to reflect the vector $(a,b)$ about the +line through $(a,b/2)$. + +@<Replace |a| by an approximation to $\psqrt{a^2+b^2}$@>= +while (1) { + r=mp_make_fraction(mp, b,a); + r=mp_take_fraction(mp, r,r); /* now $r\approx b^2/a^2$ */ + if ( r==0 ) break; + r=mp_make_fraction(mp, r,fraction_four+r); + a=a+mp_take_fraction(mp, a+a,r); b=mp_take_fraction(mp, b,r); +} + + +@ Here is a similar algorithm for $\psqrt{a^2-b^2}$. +It converges slowly when $b$ is near $a$, but otherwise it works fine. + +@c +static integer mp_pyth_sub (MP mp,integer a, integer b) { + fraction r; /* register used to transform |a| and |b| */ + boolean big; /* is the input dangerously near $2^{31}$? */ + a=abs(a); b=abs(b); + if ( a<=b ) { + @<Handle erroneous |pyth_sub| and set |a:=0|@>; + } else { + if ( a<fraction_four ) { + big=false; + } else { + a=(integer)halfp(a); b=(integer)halfp(b); big=true; + } + @<Replace |a| by an approximation to $\psqrt{a^2-b^2}$@>; + if ( big ) double(a); + } + return a; +} + +@ @<Replace |a| by an approximation to $\psqrt{a^2-b^2}$@>= +while (1) { + r=mp_make_fraction(mp, b,a); + r=mp_take_fraction(mp, r,r); /* now $r\approx b^2/a^2$ */ + if ( r==0 ) break; + r=mp_make_fraction(mp, r,fraction_four-r); + a=a-mp_take_fraction(mp, a+a,r); b=mp_take_fraction(mp, b,r); +} + +@ @<Handle erroneous |pyth_sub| and set |a:=0|@>= +{ + if ( a<b ){ + print_err("Pythagorean subtraction "); mp_print_scaled(mp, a); + mp_print(mp, "+-+"); mp_print_scaled(mp, b); + mp_print(mp, " has been replaced by 0"); +@.Pythagorean...@> + help2("Since I don't take square roots of negative numbers,", + "I'm zeroing this one. Proceed, with fingers crossed."); + mp_error(mp); + } + a=0; +} + +@ The subroutines for logarithm and exponential involve two tables. +The first is simple: |two_to_the[k]| equals $2^k$. The second involves +a bit more calculation, which the author claims to have done correctly: +|spec_log[k]| is $2^{27}$ times $\ln\bigl(1/(1-2^{-k})\bigr)= +2^{-k}+{1\over2}2^{-2k}+{1\over3}2^{-3k}+\cdots\,$, rounded to the +nearest integer. + +@d two_to_the(A) (1<<(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 }; + +@ @<Local variables for initialization@>= +integer k; /* all-purpose loop index */ + + +@ Here is the routine that calculates $2^8$ times the natural logarithm +of a |scaled| quantity; it is an integer approximation to $2^{24}\ln(x/2^{16})$, +when |x| is a given positive integer. + +The method is based on exercise 1.2.2--25 in {\sl The Art of Computer +Programming\/}: During the main iteration we have $1\L 2^{-30}x<1/(1-2^{1-k})$, +and the logarithm of $2^{30}x$ remains to be added to an accumulator +register called~$y$. Three auxiliary bits of accuracy are retained in~$y$ +during the calculation, and sixteen auxiliary bits to extend |y| are +kept in~|z| during the initial argument reduction. (We add +$100\cdot2^{16}=6553600$ to~|z| and subtract 100 from~|y| so that |z| will +not become negative; also, the actual amount subtracted from~|y| is~96, +not~100, because we want to add~4 for rounding before the final division by~8.) + +@c +static scaled mp_m_log (MP mp,scaled x) { + integer y,z; /* auxiliary registers */ + integer k; /* iteration counter */ + if ( x<=0 ) { + @<Handle non-positive logarithm@>; + } else { + y=1302456956+4-100; /* $14\times2^{27}\ln2\approx1302456956.421063$ */ + z=27595+6553600; /* and $2^{16}\times .421063\approx 27595$ */ + while ( x<fraction_four ) { + double(x); y-=93032639; z-=48782; + } /* $2^{27}\ln2\approx 93032639.74436163$ and $2^{16}\times.74436163\approx 48782$ */ + y=y+(z / unity); k=2; + while ( x>fraction_four+4 ) { + @<Increase |k| until |x| can be multiplied by a + factor of $2^{-k}$, and adjust $y$ accordingly@>; + } + return (y / 8); + } +} + +@ @<Increase |k| until |x| can...@>= +{ + z=((x-1) / two_to_the(k))+1; /* $z=\lceil x/2^k\rceil$ */ + while ( x<fraction_four+z ) { z=halfp(z+1); k++; }; + y+=spec_log[k]; x-=z; +} + +@ @<Handle non-positive logarithm@>= +{ + print_err("Logarithm of "); +@.Logarithm...replaced by 0@> + mp_print_scaled(mp, x); mp_print(mp, " has been replaced by 0"); + help2("Since I don't take logs of non-positive numbers,", + "I'm zeroing this one. Proceed, with fingers crossed."); + mp_error(mp); + return 0; +} + +@ Conversely, the exponential routine calculates $\exp(x/2^8)$, +when |x| is |scaled|. The result is an integer approximation to +$2^{16}\exp(x/2^{24})$, when |x| is regarded as an integer. + +@c +static scaled mp_m_exp (MP mp,scaled x) { + quarterword k; /* loop control index */ + integer y,z; /* auxiliary registers */ + if ( x>174436200 ) { + /* $2^{24}\ln((2^{31}-1)/2^{16})\approx 174436199.51$ */ + mp->arith_error=true; + return el_gordo; + } else if ( x<-197694359 ) { + /* $2^{24}\ln(2^{-1}/2^{16})\approx-197694359.45$ */ + return 0; + } else { + if ( x<=0 ) { + z=-8*x; y=04000000; /* $y=2^{20}$ */ + } else { + if ( x<=127919879 ) { + z=1023359037-8*x; + /* $2^{27}\ln((2^{31}-1)/2^{20})\approx 1023359037.125$ */ + } else { + z=8*(174436200-x); /* |z| is always nonnegative */ + } + y=el_gordo; + }; + @<Multiply |y| by $\exp(-z/2^{27})$@>; + if ( x<=127919879 ) + return ((y+8) / 16); + else + return y; + } +} + +@ The idea here is that subtracting |spec_log[k]| from |z| corresponds +to multiplying |y| by $1-2^{-k}$. + +A subtle point (which had to be checked) was that if $x=127919879$, the +value of~|y| will decrease so that |y+8| doesn't overflow. In fact, +$z$ will be 5 in this case, and |y| will decrease by~64 when |k=25| +and by~16 when |k=27|. + +@<Multiply |y| by...@>= +k=1; +while ( z>0 ) { + while ( z>=spec_log[k] ) { + z-=spec_log[k]; + y=y-1-((y-two_to_the(k-1)) / two_to_the(k)); + } + 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 angle spec_atan[27] = { 0, 27855475, 14718068, 7471121, 3750058, +1876857, 938658, 469357, 234682, 117342, 58671, 29335, 14668, 7334, 3667, +1833, 917, 458, 229, 115, 57, 29, 14, 7, 4, 2, 1 }; + +@ Given integers |x| and |y|, not both zero, the |n_arg| function +returns the |angle| whose tangent points in the direction $(x,y)$. +This subroutine first determines the correct octant, then solves the +problem for |0<=y<=x|, then converts the result appropriately to +return an answer in the range |-one_eighty_deg<=@t$\theta$@><=one_eighty_deg|. +(The answer is |+one_eighty_deg| if |y=0| and |x<0|, but an answer of +|-one_eighty_deg| is possible if, for example, |y=-1| and $x=-2^{30}$.) + +The octants are represented in a ``Gray code,'' since that turns out +to be computationally simplest. + +@d negate_x 1 +@d negate_y 2 +@d switch_x_and_y 4 +@d first_octant 1 +@d second_octant (first_octant+switch_x_and_y) +@d third_octant (first_octant+switch_x_and_y+negate_x) +@d fourth_octant (first_octant+negate_x) +@d fifth_octant (first_octant+negate_x+negate_y) +@d sixth_octant (first_octant+switch_x_and_y+negate_x+negate_y) +@d seventh_octant (first_octant+switch_x_and_y+negate_y) +@d eighth_octant (first_octant+negate_y) + +@c +static angle mp_n_arg (MP mp,integer x, integer y) { + angle z; /* auxiliary register */ + integer t; /* temporary storage */ + quarterword k; /* loop counter */ + int octant; /* octant code */ + if ( x>=0 ) { + octant=first_octant; + } else { + negate(x); octant=first_octant+negate_x; + } + if ( y<0 ) { + negate(y); octant=octant+negate_y; + } + if ( x<y ) { + t=y; y=x; x=t; octant=octant+switch_x_and_y; + } + if ( x==0 ) { + @<Handle undefined arg@>; + } else { + @<Set variable |z| to the arg of $(x,y)$@>; + @<Return an appropriate answer based on |z| and |octant|@>; + } +} + +@ @<Handle undefined arg@>= +{ + print_err("angle(0,0) is taken as zero"); +@.angle(0,0)...zero@> + help2("The `angle' between two identical points is undefined.", + "I'm zeroing this one. Proceed, with fingers crossed."); + mp_error(mp); + return 0; +} + +@ @<Return an appropriate answer...@>= +switch (octant) { +case first_octant: return z; +case second_octant: return (ninety_deg-z); +case third_octant: return (ninety_deg+z); +case fourth_octant: return (one_eighty_deg-z); +case fifth_octant: return (z-one_eighty_deg); +case sixth_octant: return (-z-ninety_deg); +case seventh_octant: return (z-ninety_deg); +case eighth_octant: return (-z); +}; /* there are no other cases */ +return 0 + +@ At this point we have |x>=y>=0|, and |x>0|. The numbers are scaled up +or down until $2^{28}\L x<2^{29}$, so that accurate fixed-point calculations +will be made. + +@<Set variable |z| to the arg...@>= +while ( x>=fraction_two ) { + x=halfp(x); y=halfp(y); +} +z=0; +if ( y>0 ) { + while ( x<fraction_one ) { + x+=x; y+=y; + }; + @<Increase |z| to the arg of $(x,y)$@>; +} + +@ During the calculations of this section, variables |x| and~|y| +represent actual coordinates $(x,2^{-k}y)$. We will maintain the +condition |x>=y|, so that the tangent will be at most $2^{-k}$. +If $x<2y$, the tangent is greater than $2^{-k-1}$. The transformation +$(a,b)\mapsto(a+b\tan\phi,b-a\tan\phi)$ replaces $(a,b)$ by +coordinates whose angle has decreased by~$\phi$; in the special case +$a=x$, $b=2^{-k}y$, and $\tan\phi=2^{-k-1}$, this operation reduces +to the particularly simple iteration shown here. [Cf.~John E. Meggitt, +@^Meggitt, John E.@> +{\sl IBM Journal of Research and Development\/ \bf6} (1962), 210--226.] + +The initial value of |x| will be multiplied by at most +$(1+{1\over2})(1+{1\over8})(1+{1\over32})\cdots\approx 1.7584$; hence +there is no chance of integer overflow. + +@<Increase |z|...@>= +k=0; +do { + y+=y; 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|. + +@<Glob...@>= +fraction n_sin;fraction n_cos; /* results computed by |n_sin_cos| */ + +@ Given an integer |z| that is $2^{20}$ times an angle $\theta$ in degrees, +the purpose of |n_sin_cos(z)| is to set +|x=@t$r\cos\theta$@>| and |y=@t$r\sin\theta$@>| (approximately), +for some rather large number~|r|. The maximum of |x| and |y| +will be between $2^{28}$ and $2^{30}$, so that there will be hardly +any loss of accuracy. Then |x| and~|y| are divided by~|r|. + +@c +static void mp_n_sin_cos (MP mp,angle z) { /* computes a multiple of the sine + and cosine */ + quarterword k; /* loop control variable */ + int q; /* specifies the quadrant */ + fraction r; /* magnitude of |(x,y)| */ + integer x,y,t; /* temporary registers */ + while ( z<0 ) z=z+three_sixty_deg; + z=z % three_sixty_deg; /* now |0<=z<three_sixty_deg| */ + q=z / forty_five_deg; z=z % forty_five_deg; + x=fraction_one; y=x; + if ( ! odd(q) ) z=forty_five_deg-z; + @<Subtract angle |z| from |(x,y)|@>; + @<Convert |(x,y)| to the octant determined by~|q|@>; + r=mp_pyth_add(mp, x,y); + mp->n_cos=mp_make_fraction(mp, x,r); + mp->n_sin=mp_make_fraction(mp, y,r); +} + +@ In this case the octants are numbered sequentially. + +@<Convert |(x,...@>= +switch (q) { +case 0: break; +case 1: t=x; x=y; y=t; break; +case 2: t=x; x=-y; y=t; break; +case 3: negate(x); break; +case 4: negate(x); negate(y); break; +case 5: t=x; x=-y; y=-t; break; +case 6: t=x; x=y; y=-t; break; +case 7: negate(y); break; +} /* there are no other cases */ + +@ The main iteration of |n_sin_cos| is similar to that of |n_arg| but +applied in reverse. The values of |spec_atan[k]| decrease slowly enough +that this loop is guaranteed to terminate before the (nonexistent) value +|spec_atan[27]| would be required. + +@<Subtract angle |z|...@>= +k=1; +while ( z>0 ){ + if ( z>=spec_atan[k] ) { + z=z-spec_atan[k]; t=x; + x=t+y / two_to_the(k); + y=y-t / two_to_the(k); + } + k++; +} +if ( y<0 ) y=0 /* this precaution may never be needed */ + +@ And now let's complete our collection of numeric utility routines +by considering random number generation. +\MP\ generates pseudo-random numbers with the additive scheme recommended +in Section 3.6 of {\sl The Art of Computer Programming}; however, the +results are random fractions between 0 and |fraction_one-1|, inclusive. + +There's an auxiliary array |randoms| that contains 55 pseudo-random +fractions. Using the recurrence $x_n=(x_{n-55}-x_{n-31})\bmod 2^{28}$, +we generate batches of 55 new $x_n$'s at a time by calling |new_randoms|. +The global variable |j_random| tells which element has most recently +been consumed. +The global variable |random_seed| was introduced in version 0.9, +for the sole reason of stressing the fact that the initial value of the +random seed is system-dependant. The initialization code below will initialize +this variable to |(internal[mp_time] div unity)+internal[mp_day]|, but this +is not good enough on modern fast machines that are capable of running +multiple MetaPost processes within the same second. +@^system dependencies@> + +@<Glob...@>= +fraction randoms[55]; /* the last 55 random values generated */ +int j_random; /* the number of unused |randoms| */ + +@ @<Option variables@>= +int random_seed; /* the default random seed */ + +@ @<Allocate or initialize ...@>= +mp->random_seed = (scaled)opt->random_seed; + +@ To consume a random fraction, the program below will say `|next_random|' +and then it will fetch |randoms[j_random]|. + +@d next_random { if ( mp->j_random==0 ) mp_new_randoms(mp); + else decr(mp->j_random); } + +@c +static void mp_new_randoms (MP mp) { + int k; /* index into |randoms| */ + fraction x; /* accumulator */ + for (k=0;k<=23;k++) { + x=mp->randoms[k]-mp->randoms[k+31]; + if ( x<0 ) x=x+fraction_one; + mp->randoms[k]=x; + } + for (k=24;k<= 54;k++){ + x=mp->randoms[k]-mp->randoms[k-24]; + if ( x<0 ) x=x+fraction_one; + mp->randoms[k]=x; + } + mp->j_random=54; +} + +@ @<Declarations@>= +static void mp_init_randoms (MP mp,scaled seed); + +@ To initialize the |randoms| table, we call the following routine. + +@c +void mp_init_randoms (MP mp,scaled seed) { + fraction j,jj,k; /* more or less random integers */ + int i; /* index into |randoms| */ + j=abs(seed); + while ( j>=fraction_one ) j=halfp(j); + k=1; + for (i=0;i<=54;i++ ){ + jj=k; k=j-k; j=jj; + if ( k<0 ) k=k+fraction_one; + mp->randoms[(i*21)% 55]=j; + } + mp_new_randoms(mp); + mp_new_randoms(mp); + mp_new_randoms(mp); /* ``warm up'' the array */ +} + +@ To produce a uniform random number in the range |0<=u<x| or |0>=u>x| +or |0=u=x|, given a |scaled| value~|x|, we proceed as shown here. + +Note that the call of |take_fraction| will produce the values 0 and~|x| +with about half the probability that it will produce any other particular +values between 0 and~|x|, because it rounds its answers. + +@c +static scaled mp_unif_rand (MP mp,scaled x) { + scaled y; /* trial value */ + next_random; y=mp_take_fraction(mp, abs(x),mp->randoms[mp->j_random]); + if ( y==abs(x) ) return 0; + else if ( x>0 ) return y; + else return (-y); +} + +@ Finally, a normal deviate with mean zero and unit standard deviation +can readily be obtained with the ratio method (Algorithm 3.4.1R in +{\sl The Art of Computer Programming\/}). + +@c +static scaled mp_norm_rand (MP mp) { + integer x,u,l; /* what the book would call $2^{16}X$, $2^{28}U$, and $-2^{24}\ln U$ */ + do { + do { + next_random; + x=mp_take_fraction(mp, 112429,mp->randoms[mp->j_random]-fraction_half); + /* $2^{16}\sqrt{8/e}\approx 112428.82793$ */ + next_random; u=mp->randoms[mp->j_random]; + } while (abs(x)>=u); + x=mp_make_fraction(mp, x,u); + l=139548960-mp_m_log(mp, u); /* $2^{24}\cdot12\ln2\approx139548959.6165$ */ + } while (mp_ab_vs_cd(mp, 1024,l,x,x)<0); + return x; +} + +@* \[9] Packed data. +In order to make efficient use of storage space, \MP\ bases its major data +structures on a |memory_word|, which contains either a (signed) integer, +possibly scaled, or a small number of fields that are one half or one +quarter of the size used for storing integers. + +If |x| is a variable of type |memory_word|, it contains up to four +fields that can be referred to as follows: +$$\vbox{\halign{\hfil#&#\hfil&#\hfil\cr +|x|&.|int|&(an |integer|)\cr +|x|&.|sc|\qquad&(a |scaled| integer)\cr +|x.hh.lh|, |x.hh|&.|rh|&(two halfword fields)\cr +|x.hh.b0|, |x.hh.b1|, |x.hh|&.|rh|&(two quarterword fields, one halfword + field)\cr +|x.qqqq.b0|, |x.qqqq.b1|, |x.qqqq|&.|b2|, |x.qqqq.b3|\hskip-100pt + &\qquad\qquad\qquad(four quarterword fields)\cr}}$$ +This is somewhat cumbersome to write, and not very readable either, but +macros will be used to make the notation shorter and more transparent. +The code below gives a formal definition of |memory_word| and +its subsidiary types, using packed variant records. \MP\ makes no +assumptions about the relative positions of the fields within a word. + +@d max_quarterword 0x3FFF /* largest allowable value in a |quarterword| */ +@d max_halfword 0xFFFFFFF /* largest allowable value in a |halfword| */ + +@ Here are the inequalities that the quarterword and halfword values +must satisfy (or rather, the inequalities that they mustn't satisfy): + +@<Check the ``constant''...@>= +if (mp->ini_version) { + if ( mp->mem_max!=mp->mem_top ) mp->bad=8; +} else { + if ( mp->mem_max<mp->mem_top ) mp->bad=8; +} +if ( mp->mem_max>=max_halfword ) mp->bad=12; +if ( mp->max_strings>max_halfword ) mp->bad=13; + +@ The macros |qi| and |qo| are used for input to and output +from quarterwords. These are legacy macros. +@^system dependencies@> + +@d qo(A) (A) /* to read eight bits from a quarterword */ +@d qi(A) (quarterword)(A) /* to store eight bits in a quarterword */ + +@ The reader should study the following definitions closely: +@^system dependencies@> + +@d sc cint /* |scaled| data is equivalent to |integer| */ + +@<Types...@>= +typedef short quarterword; /* 1/4 of a word */ +typedef int halfword; /* 1/2 of a word */ +typedef union { + struct { + halfword RH, LH; + } v; + struct { /* Make B0,B1 overlap the most significant bytes of LH. */ + halfword junk; + quarterword B0, B1; + } u; +} two_halves; +typedef struct { + struct { + quarterword B2, B3, B0, B1; + } u; +} four_quarters; +typedef union { + two_halves hh; + integer cint; + four_quarters qqqq; +} memory_word; +#define b0 u.B0 +#define b1 u.B1 +#define b2 u.B2 +#define b3 u.B3 +#define rh v.RH +#define lh v.LH + +@ When debugging, we may want to print a |memory_word| without knowing +what type it is; so we print it in all modes. +@^debugging@> + +@c +void mp_print_word (MP mp,memory_word w) { + /* prints |w| in all ways */ + mp_print_int(mp, w.cint); mp_print_char(mp, xord(' ')); + mp_print_scaled(mp, w.sc); mp_print_char(mp, xord(' ')); + mp_print_scaled(mp, w.sc / 010000); mp_print_ln(mp); + mp_print_int(mp, w.hh.lh); mp_print_char(mp, xord('=')); + mp_print_int(mp, w.hh.b0); mp_print_char(mp, xord(':')); + mp_print_int(mp, w.hh.b1); mp_print_char(mp, xord(';')); + mp_print_int(mp, w.hh.rh); mp_print_char(mp, xord(' ')); + mp_print_int(mp, w.qqqq.b0); mp_print_char(mp, xord(':')); + mp_print_int(mp, w.qqqq.b1); mp_print_char(mp, xord(':')); + mp_print_int(mp, w.qqqq.b2); mp_print_char(mp, xord(':')); + mp_print_int(mp, w.qqqq.b3); +} + + +@* \[10] Dynamic memory allocation. + +The \MP\ system does nearly all of its own memory allocation, so that it +can readily be transported into environments that do not have automatic +facilities for strings, garbage collection, etc., and so that it can be in +control of what error messages the user receives. The dynamic storage +requirements of \MP\ are handled by providing a large array |mem| in +which consecutive blocks of words are used as nodes by the \MP\ routines. + +Pointer variables are indices into this array, or into another array +called |eqtb| that will be explained later. A pointer variable might +also be a special flag that lies outside the bounds of |mem|, so we +allow pointers to assume any |halfword| value. The minimum memory +index represents a null pointer. + +@d null 0 /* the null pointer */ +@d mp_void (null+1) /* a null pointer different from |null| */ + + +@<Types...@>= +typedef halfword pointer; /* a flag or a location in |mem| or |eqtb| */ + +@ The |mem| array is divided into two regions that are allocated separately, +but the dividing line between these two regions is not fixed; they grow +together until finding their ``natural'' size in a particular job. +Locations less than or equal to |lo_mem_max| are used for storing +variable-length records consisting of two or more words each. This region +is maintained using an algorithm similar to the one described in exercise +2.5--19 of {\sl The Art of Computer Programming}. However, no size field +appears in the allocated nodes; the program is responsible for knowing the +relevant size when a node is freed. Locations greater than or equal to +|hi_mem_min| are used for storing one-word records; a conventional +\.{AVAIL} stack is used for allocation in this region. + +Locations of |mem| between |0| and |mem_top| may be dumped as part +of preloaded mem files, by the \.{INIMP} preprocessor. +@.INIMP@> +Production versions of \MP\ may extend the memory at the top end in order to +provide more space; these locations, between |mem_top| and |mem_max|, +are always used for single-word nodes. + +The key pointers that govern |mem| allocation have a prescribed order: +$$\hbox{|null=0<lo_mem_max<hi_mem_min<mem_top<=mem_end<=mem_max|.}$$ + +@<Glob...@>= +memory_word *mem; /* the big dynamic storage area */ +pointer lo_mem_max; /* the largest location of variable-size memory in use */ +pointer hi_mem_min; /* the smallest location of one-word memory in use */ + + +@ +@d xfree(A) do { mp_xfree(A); A=NULL; } while (0) +@d xrealloc(P,A,B) mp_xrealloc(mp,P,(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 char *mp_strdup(const char *p) ; +extern char *mp_strldup(const char *p, size_t l) ; +extern void mp_xfree ( @= /*@@only@@*/ /*@@out@@*/ /*@@null@@*/ @> void *x); +extern @= /*@@only@@*/ @> void *mp_xrealloc (MP mp, void *p, size_t nmem, size_t size) ; +extern @= /*@@only@@*/ @> void *mp_xmalloc (MP mp, size_t nmem, size_t size) ; +extern @= /*@@only@@*/ @> char *mp_xstrdup(MP mp, const char *s); +extern @= /*@@only@@*/ @> char *mp_xstrldup(MP mp, const char *s, size_t l); +extern void mp_do_snprintf(char *str, int size, const char *fmt, ...); + +@ The |max_size_test| guards against overflow, on the assumption that +|size_t| is at least 31bits wide. + +@d max_size_test 0x7FFFFFFF + +@c +char *mp_strldup(const char *p, size_t l) { + char *r; + if (p==NULL) return NULL; + r = malloc ((size_t)(l*sizeof(char)+1)); + if (r==NULL) + return NULL; + return memcpy (r,p,(size_t)(l+1)); +} +char *mp_strdup(const char *p) { + if (p==NULL) return NULL; + return mp_strldup(p, strlen(p)); +} +void mp_xfree (void *x) { + if (x!=NULL) free(x); +} +void *mp_xrealloc (MP mp, void *p, size_t nmem, size_t size) { + void *w ; + if ((max_size_test/size)<nmem) { + do_fprintf(mp->err_out,"Memory size overflow!\n"); + mp->history =mp_fatal_error_stop; mp_jump_out(mp); + } + w = realloc (p,(nmem*size)); + if (w==NULL) { + do_fprintf(mp->err_out,"Out of memory!\n"); + mp->history =mp_system_error_stop; mp_jump_out(mp); + } + return w; +} +void *mp_xmalloc (MP mp, size_t nmem, size_t size) { + void *w; + if ((max_size_test/size)<nmem) { + do_fprintf(mp->err_out,"Memory size overflow!\n"); + mp->history =mp_fatal_error_stop; mp_jump_out(mp); + } + w = malloc (nmem*size); + if (w==NULL) { + do_fprintf(mp->err_out,"Out of memory!\n"); + mp->history =mp_system_error_stop; mp_jump_out(mp); + } + return w; +} +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) { + do_fprintf(mp->err_out,"Out of memory!\n"); + 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)); +} + + +@ @<Internal library declarations@>= +#ifdef HAVE_SNPRINTF +#define mp_snprintf (void)snprintf +#else +#define mp_snprintf mp_do_snprintf +#endif + +@ This internal version is rather stupid, but good enough for its purpose. + +@c +static char *mp_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--] = (char)d + '0'; + } + res[idx--] = (char)v + '0'; + if (i<0) { + res[idx--] = '-'; + } + return mp_strdup((res+idx+1)); +} +static char *mp_utoa (unsigned v) { + char res[32] ; + unsigned idx = 30; + 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'; + return mp_strdup((res+idx+1)); +} +void mp_do_snprintf (char *str, int size, const char *format, ...) { + const char *fmt; + char *res; + int fw, pad; + va_list ap; + va_start(ap, format); + res = str; + for (fmt=format;*fmt!='\0';fmt++) { + if (*fmt=='%') { + fw=0; + pad=0; + fmt++; + switch(*fmt) { + case '0': + pad=1; + break; + case '1': + case '2': + case '3': + case '4': + case '5': + case '6': + case '7': + case '8': + case '9': + assert(fw==0); + fw = *fmt-'0'; + break; + case 's': + { + char *s = va_arg(ap, char *); + while (*s) { + *res = *s++; + if (size-->0) res++; + } + } + break; + case 'i': + case 'd': + { + char *s = mp_itoa(va_arg(ap, int)); + if (fw) { + int ffw = fw-strlen(s); + while (ffw-->0) { + *res = (pad ? '0' : ' '); + if (size-->0) res++; + } + } + if (s != NULL) { + while (*s) { + *res = *s++; + if (size-->0) res++; + } + } + } + break; + case 'u': + { + char *s = mp_utoa(va_arg(ap, unsigned)); + if (fw) { + int ffw = fw-strlen(s); + while (ffw-->0) { + *res = (pad ? '0' : ' '); + if (size-->0) res++; + } + } + if (s != NULL) { + while (*s) { + *res = *s++; + if (size-->0) res++; + } + } + } + break; + case '%': + *res = '%'; + if (size-->0) res++; + break; + default: + *res = '%'; + if (size-->0) res++; + *res = *fmt; + if (size-->0) res++; + break; + } + } else { + *res = *fmt; + if (size-->0) res++; + } + } + *res = '\0'; + va_end(ap); +} + +@ +@<Allocate or initialize ...@>= +mp->mem = xmalloc ((mp->mem_max+1),sizeof (memory_word)); +memset(mp->mem,0,(mp->mem_max+1)*sizeof (memory_word)); + +@ @<Dealloc variables@>= +xfree(mp->mem); + +@ Users who wish to study the memory requirements of particular applications can +can use optional special features that keep track of current and +maximum memory usage. When code between the delimiters |stat| $\ldots$ +|tats| is not ``commented out,'' \MP\ will run a bit slower but it will +report these statistics when |mp_tracing_stats| is positive. + +@<Glob...@>= +integer var_used; integer dyn_used; /* how much memory is in use */ + +@ Let's consider the one-word memory region first, since it's the +simplest. The pointer variable |mem_end| holds the highest-numbered location +of |mem| that has ever been used. The free locations of |mem| that +occur between |hi_mem_min| and |mem_end|, inclusive, are of type +|two_halves|, and we write |info(p)| and |mp_link(p)| for the |lh| +and |rh| fields of |mem[p]| when it is of this type. The single-word +free locations form a linked list +$$|avail|,\;\hbox{|mp_link(avail)|},\;\hbox{|mp_link(mp_link(avail))|},\;\ldots$$ +terminated by |null|. + +@(mpmp.h@>= +#define mp_link(A) mp->mem[(A)].hh.rh /* the |link| field of a memory word */ +#define mp_info(A) mp->mem[(A)].hh.lh /* the |info| field of a memory word */ + +@ @<Glob...@>= +pointer avail; /* head of the list of available one-word nodes */ +pointer mem_end; /* the last one-word node used in |mem| */ + +@ If one-word memory is exhausted, it might mean that the user has forgotten +a token like `\&{enddef}' or `\&{endfor}'. We will define some procedures +later that try to help pinpoint the trouble. + +@ The function |get_avail| returns a pointer to a new one-word node whose +|link| field is null. However, \MP\ will halt if there is no more room left. +@^inner loop@> + +@c +static pointer mp_get_avail (MP mp) { /* single-word node allocation */ + pointer p; /* the new node being got */ + p=mp->avail; /* get top location in the |avail| stack */ + if ( p!=null ) { + mp->avail=mp_link(mp->avail); /* and pop it off */ + } else if ( mp->mem_end<mp->mem_max ) { /* or go into virgin territory */ + incr(mp->mem_end); p=mp->mem_end; + } else { + decr(mp->hi_mem_min); p=mp->hi_mem_min; + if ( mp->hi_mem_min<=mp->lo_mem_max ) { + mp_runaway(mp); /* if memory is exhausted, display possible runaway text */ + mp_overflow(mp, "main memory size",mp->mem_max); + /* quit; all one-word nodes are busy */ +@:MetaPost capacity exceeded main memory size}{\quad main memory size@> + } + } + mp_link(p)=null; /* provide an oft-desired initialization of the new node */ + incr(mp->dyn_used);/* maintain statistics */ + return p; +} + +@ Conversely, a one-word node is recycled by calling |free_avail|. + +@d free_avail(A) /* single-word node liberation */ + { mp_link((A))=mp->avail; mp->avail=(A); decr(mp->dyn_used); } + +@ There's also a |fast_get_avail| routine, which saves the procedure-call +overhead at the expense of extra programming. This macro is used in +the places that would otherwise account for the most calls of |get_avail|. +@^inner loop@> + +@d fast_get_avail(A) { + (A)=mp->avail; /* avoid |get_avail| if possible, to save time */ + if ( (A)==null ) { (A)=mp_get_avail(mp); } + else { mp->avail=mp_link((A)); mp_link((A))=null; incr(mp->dyn_used); } + } + +@ The available-space list that keeps track of the variable-size portion +of |mem| is a nonempty, doubly-linked circular list of empty nodes, +pointed to by the roving pointer |rover|. + +Each empty node has size 2 or more; the first word contains the special +value |max_halfword| in its |link| field and the size in its |info| field; +the second word contains the two pointers for double linking. + +Each nonempty node also has size 2 or more. Its first word is of type +|two_halves|\kern-1pt, and its |link| field is never equal to |max_halfword|. +Otherwise there is complete flexibility with respect to the contents +of its other fields and its other words. + +(We require |mem_max<max_halfword| because terrible things can happen +when |max_halfword| appears in the |link| field of a nonempty node.) + +@d empty_flag max_halfword /* the |link| of an empty variable-size node */ +@d is_empty(A) (mp_link((A))==empty_flag) /* tests for empty node */ + +@(mpmp.h@>= +#define node_size mp_info /* the size field in empty variable-size nodes */ +#define lmp_link(A) mp_info((A)+1) /* left link in doubly-linked list of empty nodes */ +#define rmp_link(A) mp_link((A)+1) /* right link in doubly-linked list of empty nodes */ + +@ @<Glob...@>= +pointer rover; /* points to some node in the list of empties */ + +@ A call to |get_node| with argument |s| returns a pointer to a new node +of size~|s|, which must be 2~or more. The |link| field of the first word +of this new node is set to null. An overflow stop occurs if no suitable +space exists. + +If |get_node| is called with $s=2^{30}$, it simply merges adjacent free +areas and returns the value |max_halfword|. + +@<Internal library declarations@>= +pointer mp_get_node (MP mp,integer s) ; + +@ @c +pointer mp_get_node (MP mp,integer s) { /* variable-size node allocation */ + pointer p; /* the node currently under inspection */ + pointer q; /* the node physically after node |p| */ + integer r; /* the newly allocated node, or a candidate for this honor */ + integer t,tt; /* temporary registers */ +@^inner loop@> + RESTART: + p=mp->rover; /* start at some free node in the ring */ + do { + @<Try to allocate within node |p| and its physical successors, + and |goto found| if allocation was possible@>; + if (rmp_link(p)==null || (rmp_link(p)==p && p!=mp->rover)) { + print_err("Free list garbled"); + help3("I found an entry in the list of free nodes that links", + "badly. I will try to ignore the broken link, but something", + "is seriously amiss. It is wise to warn the maintainers.") + mp_error(mp); + rmp_link(p)=mp->rover; + } + p=rmp_link(p); /* move to the next node in the ring */ + } while (p!=mp->rover); /* repeat until the whole list has been traversed */ + if ( s==010000000000 ) { + return max_halfword; + }; + if ( mp->lo_mem_max+2<mp->hi_mem_min ) { + if ( mp->lo_mem_max+2<=max_halfword ) { + @<Grow more variable-size memory and |goto restart|@>; + } + } + mp_overflow(mp, "main memory size",mp->mem_max); + /* sorry, nothing satisfactory is left */ +@:MetaPost capacity exceeded main memory size}{\quad main memory size@> +FOUND: + mp_link(r)=null; /* this node is now nonempty */ + mp->var_used+=s; /* maintain usage statistics */ + return r; +} + +@ The lower part of |mem| grows by 1000 words at a time, unless +we are very close to going under. When it grows, we simply link +a new node into the available-space list. This method of controlled +growth helps to keep the |mem| usage consecutive when \MP\ is +implemented on ``virtual memory'' systems. +@^virtual memory@> + +@<Grow more variable-size memory and |goto restart|@>= +{ + if ( mp->hi_mem_min-mp->lo_mem_max>=1998 ) { + t=mp->lo_mem_max+1000; + } else { + t=mp->lo_mem_max+1+(mp->hi_mem_min-mp->lo_mem_max) / 2; + /* |lo_mem_max+2<=t<hi_mem_min| */ + } + if ( t>max_halfword ) t=max_halfword; + p=lmp_link(mp->rover); q=mp->lo_mem_max; rmp_link(p)=q; lmp_link(mp->rover)=q; + rmp_link(q)=mp->rover; lmp_link(q)=p; mp_link(q)=empty_flag; + node_size(q)=t-mp->lo_mem_max; + mp->lo_mem_max=t; mp_link(mp->lo_mem_max)=null; mp_info(mp->lo_mem_max)=null; + mp->rover=q; + goto RESTART; +} + +@ @<Try to allocate...@>= +q=p+node_size(p); /* find the physical successor */ +while ( is_empty(q) ) { /* merge node |p| with node |q| */ + t=rmp_link(q); tt=lmp_link(q); +@^inner loop@> + if ( q==mp->rover ) mp->rover=t; + lmp_link(t)=tt; rmp_link(tt)=t; + q=q+node_size(q); +} +r=q-s; +if ( r>p+1 ) { + @<Allocate from the top of node |p| and |goto found|@>; +} +if ( r==p ) { + if ( rmp_link(p)!=p ) { + @<Allocate entire node |p| and |goto found|@>; + } +} +node_size(p)=q-p /* reset the size in case it grew */ + +@ @<Allocate from the top...@>= +{ + node_size(p)=r-p; /* store the remaining size */ + mp->rover=p; /* start searching here next time */ + goto FOUND; +} + +@ Here we delete node |p| from the ring, and let |rover| rove around. + +@<Allocate entire...@>= +{ + mp->rover=rmp_link(p); t=lmp_link(p); + lmp_link(mp->rover)=t; rmp_link(t)=mp->rover; + goto FOUND; +} + +@ Conversely, when some variable-size node |p| of size |s| is no longer needed, +the operation |free_node(p,s)| will make its words available, by inserting +|p| as a new empty node just before where |rover| now points. + +@<Internal library declarations@>= +void mp_free_node (MP mp, pointer p, halfword s) ; + +@ @c +void mp_free_node (MP mp, pointer p, halfword s) { /* variable-size node + liberation */ + pointer q; /* |lmp_link(rover)| */ + node_size(p)=s; mp_link(p)=empty_flag; +@^inner loop@> + q=lmp_link(mp->rover); lmp_link(p)=q; rmp_link(p)=mp->rover; /* set both links */ + lmp_link(mp->rover)=p; rmp_link(q)=p; /* insert |p| into the ring */ + mp->var_used-=s; /* maintain statistics */ +} + +@* \[11] Memory layout. +Some areas of |mem| are dedicated to fixed usage, since static allocation is +more efficient than dynamic allocation when we can get away with it. For +example, locations |0| to |1| are always used to store a +two-word dummy token whose second word is zero. +The following macro definitions accomplish the static allocation by giving +symbolic names to the fixed positions. Static variable-size nodes appear +in locations |0| through |lo_mem_stat_max|, and static single-word nodes +appear in locations |hi_mem_stat_min| through |mem_top|, inclusive. + +@d sentinel mp->mem_top /* end of sorted lists */ +@d temp_head (mp->mem_top-1) /* head of a temporary list of some kind */ +@d hold_head (mp->mem_top-2) /* head of a temporary list of another kind */ + +@(mpmp.h@>= +#define spec_head (mp->mem_top-3) /* head of a list of unprocessed \&{special} items */ +#define null_dash (2) /* the first two words are reserved for a null value */ +#define dep_head (null_dash+3) /* we will define |dash_node_size=3| */ +#define zero_val (dep_head+2) /* two words for a permanently zero value */ +#define temp_val (zero_val+2) /* two words for a temporary value node */ +#define end_attr temp_val /* we use |end_attr+2| only */ +#define inf_val (end_attr+2) /* and |inf_val+1| only */ +#define bad_vardef (inf_val+2) /* two words for \&{vardef} error recovery */ +#define lo_mem_stat_max (bad_vardef+1) /* largest statically + allocated word in the variable-size |mem| */ +#define hi_mem_stat_min (mp->mem_top-3) /* smallest statically allocated word in + the one-word |mem| */ + +@ The following code gets the dynamic part of |mem| off to a good start, +when \MP\ is initializing itself the slow way. + +@<Initialize table entries (done by \.{INIMP} only)@>= +mp->rover=lo_mem_stat_max+1; /* initialize the dynamic memory */ +mp_link(mp->rover)=empty_flag; +node_size(mp->rover)=1000; /* which is a 1000-word available node */ +lmp_link(mp->rover)=mp->rover; rmp_link(mp->rover)=mp->rover; +mp->lo_mem_max=mp->rover+1000; +mp_link(mp->lo_mem_max)=null; mp_info(mp->lo_mem_max)=null; +for (k=hi_mem_stat_min;k<=(int)mp->mem_top;k++) { + mp->mem[k]=mp->mem[mp->lo_mem_max]; /* clear list heads */ +} +mp->avail=null; mp->mem_end=mp->mem_top; +mp->hi_mem_min=hi_mem_stat_min; /* initialize the one-word memory */ +mp->var_used=lo_mem_stat_max+1; +mp->dyn_used=mp->mem_top+1-(hi_mem_stat_min); /* initialize statistics */ + +@ The procedure |flush_list(p)| frees an entire linked list of one-word +nodes that starts at a given position, until coming to |sentinel| or a +pointer that is not in the one-word region. Another procedure, +|flush_node_list|, frees an entire linked list of one-word and two-word +nodes, until coming to a |null| pointer. +@^inner loop@> + +@c +static void mp_flush_list (MP mp,pointer p) { /* makes list of single-word nodes available */ + pointer q,r; /* list traversers */ + if ( p>=mp->hi_mem_min ) if ( p!=sentinel ) { + r=p; + do { + q=r; r=mp_link(r); + decr(mp->dyn_used); + if ( r<mp->hi_mem_min ) break; + } while (r!=sentinel); + /* now |q| is the last node on the list */ + mp_link(q)=mp->avail; mp->avail=p; + } +} +@# +static void mp_flush_node_list (MP mp,pointer p) { + pointer q; /* the node being recycled */ + while ( p!=null ){ + q=p; p=mp_link(p); + if ( q<mp->hi_mem_min ) + mp_free_node(mp, q,2); + else + free_avail(q); + } +} + +@ If \MP\ is extended improperly, the |mem| array might get screwed up. +For example, some pointers might be wrong, or some ``dead'' nodes might not +have been freed when the last reference to them disappeared. Procedures +|check_mem| and |search_mem| are available to help diagnose such +problems. These procedures make use of two arrays called |free| and +|was_free| that are present only if \MP's debugging routines have +been included. (You may want to decrease the size of |mem| while you +@^debugging@> +are debugging.) + +Because |boolean|s are typedef-d as ints, it is better to use +unsigned chars here. + +@<Glob...@>= +unsigned char *free; /* free cells */ +unsigned char *was_free; /* previously free cells */ +pointer was_mem_end; pointer was_lo_max; pointer was_hi_min; + /* previous |mem_end|, |lo_mem_max|,and |hi_mem_min| */ +boolean panicking; /* do we want to check memory constantly? */ + +@ @<Allocate or initialize ...@>= +mp->free = xmalloc ((mp->mem_max+1),sizeof (unsigned char)); +mp->was_free = xmalloc ((mp->mem_max+1), sizeof (unsigned char)); + +@ @<Dealloc variables@>= +xfree(mp->free); +xfree(mp->was_free); + +@ @<Allocate or ...@>= +mp->was_hi_min=mp->mem_max; +mp->panicking=false; + +@ @<Declarations@>= +static void mp_reallocate_memory(MP mp, int l) ; + +@ @c +static void mp_reallocate_memory(MP mp, int l) { + XREALLOC(mp->free, l, unsigned char); + XREALLOC(mp->was_free, l, unsigned char); + if (mp->mem) { + int newarea = l-mp->mem_max; + XREALLOC(mp->mem, l, memory_word); + memset (mp->mem+(mp->mem_max+1),0,sizeof(memory_word)*(newarea)); + } else { + XREALLOC(mp->mem, l, memory_word); + memset(mp->mem,0,sizeof(memory_word)*(l+1)); + } + mp->mem_max = l; + if (mp->ini_version) + mp->mem_top = l; +} + + + +@ Procedure |check_mem| makes sure that the available space lists of +|mem| are well formed, and it optionally prints out all locations +that are reserved now but were free the last time this procedure was called. + +@c +void mp_check_mem (MP mp,boolean print_locs ) { + pointer p,q,r; /* current locations of interest in |mem| */ + boolean clobbered; /* is something amiss? */ + for (p=0;p<=mp->lo_mem_max;p++) { + mp->free[p]=false; /* you can probably do this faster */ + } + for (p=mp->hi_mem_min;p<= mp->mem_end;p++) { + mp->free[p]=false; /* ditto */ + } + @<Check single-word |avail| list@>; + @<Check variable-size |avail| list@>; + @<Check flags of unavailable nodes@>; + @<Check the list of linear dependencies@>; + if ( print_locs ) { + @<Print newly busy locations@>; + } + memcpy(mp->was_free,mp->free, sizeof(char)*(mp->mem_end+1)); + mp->was_mem_end=mp->mem_end; + mp->was_lo_max=mp->lo_mem_max; + mp->was_hi_min=mp->hi_mem_min; +} + +@ @<Check single-word...@>= +p=mp->avail; q=null; clobbered=false; +while ( p!=null ) { + if ( (p>mp->mem_end)||(p<mp->hi_mem_min) ) clobbered=true; + else if ( mp->free[p] ) clobbered=true; + if ( clobbered ) { + mp_print_nl(mp, "AVAIL list clobbered at "); +@.AVAIL list clobbered...@> + mp_print_int(mp, q); break; + } + mp->free[p]=true; q=p; p=mp_link(q); +} + +@ @<Check variable-size...@>= +p=mp->rover; q=null; clobbered=false; +do { + if ( (p>=mp->lo_mem_max)||(p<0) ) clobbered=true; + else if ( (rmp_link(p)>=mp->lo_mem_max)||(rmp_link(p)<0) ) clobbered=true; + else if ( !(is_empty(p))||(node_size(p)<2)|| + (p+node_size(p)>mp->lo_mem_max)|| (lmp_link(rmp_link(p))!=p) ) clobbered=true; + if ( clobbered ) { + mp_print_nl(mp, "Double-AVAIL list clobbered at "); +@.Double-AVAIL list clobbered...@> + mp_print_int(mp, q); break; + } + for (q=p;q<=p+node_size(p)-1;q++) { /* mark all locations free */ + if ( mp->free[q] ) { + mp_print_nl(mp, "Doubly free location at "); +@.Doubly free location...@> + mp_print_int(mp, q); break; + } + mp->free[q]=true; + } + q=p; p=rmp_link(p); +} while (p!=mp->rover) + + +@ @<Check flags...@>= +p=0; +while ( p<=mp->lo_mem_max ) { /* node |p| should not be empty */ + if ( is_empty(p) ) { + mp_print_nl(mp, "Bad flag at "); mp_print_int(mp, p); +@.Bad flag...@> + } + while ( (p<=mp->lo_mem_max) && ! mp->free[p] ) p++; + while ( (p<=mp->lo_mem_max) && mp->free[p] ) p++; +} + +@ @<Print newly busy...@>= +{ + @<Do intialization required before printing new busy locations@>; + mp_print_nl(mp, "New busy locs:"); +@.New busy locs@> + for (p=0;p<= mp->lo_mem_max;p++ ) { + if ( ! mp->free[p] && ((p>mp->was_lo_max) || mp->was_free[p]) ) { + @<Indicate that |p| is a new busy location@>; + } + } + for (p=mp->hi_mem_min;p<=mp->mem_end;p++ ) { + if ( ! mp->free[p] && + ((p<mp->was_hi_min) || (p>mp->was_mem_end) || mp->was_free[p]) ) { + @<Indicate that |p| is a new busy location@>; + } + } + @<Finish printing new busy locations@>; +} + +@ There might be many new busy locations so we are careful to print contiguous +blocks compactly. During this operation |q| is the last new busy location and +|r| is the start of the block containing |q|. + +@<Indicate that |p| is a new busy location@>= +{ + if ( p>q+1 ) { + if ( q>r ) { + mp_print(mp, ".."); mp_print_int(mp, q); + } + mp_print_char(mp, xord(' ')); mp_print_int(mp, p); + r=p; + } + q=p; +} + +@ @<Do intialization required before printing new busy locations@>= +q=mp->mem_max; r=mp->mem_max + +@ @<Finish printing new busy locations@>= +if ( q>r ) { + mp_print(mp, ".."); mp_print_int(mp, q); +} + +@ The |search_mem| procedure attempts to answer the question ``Who points +to node~|p|?'' In doing so, it fetches |link| and |info| fields of |mem| +that might not be of type |two_halves|. Strictly speaking, this is +undefined, and it can lead to ``false drops'' (words that seem to +point to |p| purely by coincidence). But for debugging purposes, we want +to rule out the places that do {\sl not\/} point to |p|, so a few false +drops are tolerable. + +@c +void mp_search_mem (MP mp, pointer p) { /* look for pointers to |p| */ + integer q; /* current position being searched */ + for (q=0;q<=mp->lo_mem_max;q++) { + if ( mp_link(q)==p ){ + mp_print_nl(mp, "LINK("); mp_print_int(mp, q); mp_print_char(mp, xord(')')); + } + if ( mp_info(q)==p ) { + mp_print_nl(mp, "INFO("); mp_print_int(mp, q); mp_print_char(mp, xord(')')); + } + } + for (q=mp->hi_mem_min;q<=mp->mem_end;q++) { + if ( mp_link(q)==p ) { + mp_print_nl(mp, "LINK("); mp_print_int(mp, q); mp_print_char(mp, xord(')')); + } + if ( mp_info(q)==p ) { + mp_print_nl(mp, "INFO("); mp_print_int(mp, q); mp_print_char(mp, xord(')')); + } + } + @<Search |eqtb| for equivalents equal to |p|@>; +} + +@ Just before \.{INIMP} writes out the memory, it sorts the doubly linked +available space list. The list is probably very short at such times, so a +simple insertion sort is used. The smallest available location will be +pointed to by |rover|, the next-smallest by |rmp_link(rover)|, etc. + +@<Internal library ...@>= +void mp_sort_avail (MP mp); + +@ @c +void mp_sort_avail (MP mp) { /* sorts the available variable-size nodes + by location */ + pointer p,q,r; /* indices into |mem| */ + pointer old_rover; /* initial |rover| setting */ + p=mp_get_node(mp, 010000000000); /* merge adjacent free areas */ + p=rmp_link(mp->rover); rmp_link(mp->rover)=max_halfword; old_rover=mp->rover; + while ( p!=old_rover ) { + @<Sort |p| into the list starting at |rover| + and advance |p| to |rmp_link(p)|@>; + } + p=mp->rover; + while ( rmp_link(p)!=max_halfword ) { + lmp_link(rmp_link(p))=p; p=rmp_link(p); + }; + rmp_link(p)=mp->rover; lmp_link(mp->rover)=p; +} + +@ The following |while| loop is guaranteed to +terminate, since the list that starts at +|rover| ends with |max_halfword| during the sorting procedure. + +@<Sort |p|...@>= +if ( p<mp->rover ) { + q=p; p=rmp_link(q); rmp_link(q)=mp->rover; mp->rover=q; +} else { + q=mp->rover; + while ( rmp_link(q)<p ) q=rmp_link(q); + r=rmp_link(p); rmp_link(p)=rmp_link(q); rmp_link(q)=p; p=r; +} + + +@* \[12] The command codes. +Before we can go much further, we need to define symbolic names for the internal +code numbers that represent the various commands obeyed by \MP. These codes +are somewhat arbitrary, but not completely so. For example, +some codes have been made adjacent so that |case| statements in the +program need not consider cases that are widely spaced, or so that |case| +statements can be replaced by |if| statements. A command can begin an +expression if and only if its code lies between |min_primary_command| and +|max_primary_command|, inclusive. The first token of a statement that doesn't +begin with an expression has a command code between |min_command| and +|max_statement_command|, inclusive. Anything less than |min_command| is +eliminated during macro expansions, and anything no more than |max_pre_command| +is eliminated when expanding \TeX\ material. Ranges such as +|min_secondary_command..max_secondary_command| are used when parsing +expressions, but the relative ordering within such a range is generally not +critical. + +The ordering of the highest-numbered commands +(|comma<semicolon<end_group<stop|) is crucial for the parsing and +error-recovery methods of this program as is the ordering |if_test<fi_or_else| +for the smallest two commands. The ordering is also important in the ranges +|numeric_token..plus_or_minus| and |left_brace..ampersand|. + +At any rate, here is the list, for future reference. + +@d start_tex 1 /* begin \TeX\ material (\&{btex}, \&{verbatimtex}) */ +@d etex_marker 2 /* end \TeX\ material (\&{etex}) */ +@d mpx_break 3 /* stop reading an \.{MPX} file (\&{mpxbreak}) */ +@d max_pre_command mpx_break +@d if_test 4 /* conditional text (\&{if}) */ +@d fi_or_else 5 /* delimiters for conditionals (\&{elseif}, \&{else}, \&{fi}) */ +@d input 6 /* input a source file (\&{input}, \&{endinput}) */ +@d iteration 7 /* iterate (\&{for}, \&{forsuffixes}, \&{forever}, \&{endfor}) */ +@d repeat_loop 8 /* special command substituted for \&{endfor} */ +@d exit_test 9 /* premature exit from a loop (\&{exitif}) */ +@d relax 10 /* do nothing (\.{\char`\\}) */ +@d scan_tokens 11 /* put a string into the input buffer */ +@d expand_after 12 /* look ahead one token */ +@d defined_macro 13 /* a macro defined by the user */ +@d min_command (defined_macro+1) +@d save_command 14 /* save a list of tokens (\&{save}) */ +@d interim_command 15 /* save an internal quantity (\&{interim}) */ +@d let_command 16 /* redefine a symbolic token (\&{let}) */ +@d new_internal 17 /* define a new internal quantity (\&{newinternal}) */ +@d macro_def 18 /* define a macro (\&{def}, \&{vardef}, etc.) */ +@d ship_out_command 19 /* output a character (\&{shipout}) */ +@d add_to_command 20 /* add to edges (\&{addto}) */ +@d bounds_command 21 /* add bounding path to edges (\&{setbounds}, \&{clip}) */ +@d tfm_command 22 /* command for font metric info (\&{ligtable}, etc.) */ +@d protection_command 23 /* set protection flag (\&{outer}, \&{inner}) */ +@d show_command 24 /* diagnostic output (\&{show}, \&{showvariable}, etc.) */ +@d mode_command 25 /* set interaction level (\&{batchmode}, etc.) */ +@d mp_random_seed 26 /* initialize random number generator (\&{randomseed}) */ +@d message_command 27 /* communicate to user (\&{message}, \&{errmessage}) */ +@d every_job_command 28 /* designate a starting token (\&{everyjob}) */ +@d delimiters 29 /* define a pair of delimiters (\&{delimiters}) */ +@d special_command 30 /* output special info (\&{special}) + or font map info (\&{fontmapfile}, \&{fontmapline}) */ +@d write_command 31 /* write text to a file (\&{write}) */ +@d type_name 32 /* declare a type (\&{numeric}, \&{pair}, etc.) */ +@d max_statement_command type_name +@d min_primary_command type_name +@d left_delimiter 33 /* the left delimiter of a matching pair */ +@d begin_group 34 /* beginning of a group (\&{begingroup}) */ +@d nullary 35 /* an operator without arguments (e.g., \&{normaldeviate}) */ +@d unary 36 /* an operator with one argument (e.g., \&{sqrt}) */ +@d str_op 37 /* convert a suffix to a string (\&{str}) */ +@d cycle 38 /* close a cyclic path (\&{cycle}) */ +@d primary_binary 39 /* binary operation taking `\&{of}' (e.g., \&{point}) */ +@d capsule_token 40 /* a value that has been put into a token list */ +@d string_token 41 /* a string constant (e.g., |"hello"|) */ +@d internal_quantity 42 /* internal numeric parameter (e.g., \&{pausing}) */ +@d min_suffix_token internal_quantity +@d tag_token 43 /* a symbolic token without a primitive meaning */ +@d numeric_token 44 /* a numeric constant (e.g., \.{3.14159}) */ +@d max_suffix_token numeric_token +@d plus_or_minus 45 /* either `\.+' or `\.-' */ +@d max_primary_command plus_or_minus /* should also be |numeric_token+1| */ +@d min_tertiary_command plus_or_minus +@d tertiary_secondary_macro 46 /* a macro defined by \&{secondarydef} */ +@d tertiary_binary 47 /* an operator at the tertiary level (e.g., `\.{++}') */ +@d max_tertiary_command tertiary_binary +@d left_brace 48 /* the operator `\.{\char`\{}' */ +@d min_expression_command left_brace +@d path_join 49 /* the operator `\.{..}' */ +@d ampersand 50 /* the operator `\.\&' */ +@d expression_tertiary_macro 51 /* a macro defined by \&{tertiarydef} */ +@d expression_binary 52 /* an operator at the expression level (e.g., `\.<') */ +@d equals 53 /* the operator `\.=' */ +@d max_expression_command equals +@d and_command 54 /* the operator `\&{and}' */ +@d min_secondary_command and_command +@d secondary_primary_macro 55 /* a macro defined by \&{primarydef} */ +@d slash 56 /* the operator `\./' */ +@d secondary_binary 57 /* an operator at the binary level (e.g., \&{shifted}) */ +@d max_secondary_command secondary_binary +@d param_type 58 /* type of parameter (\&{primary}, \&{expr}, \&{suffix}, etc.) */ +@d controls 59 /* specify control points explicitly (\&{controls}) */ +@d tension 60 /* specify tension between knots (\&{tension}) */ +@d at_least 61 /* bounded tension value (\&{atleast}) */ +@d curl_command 62 /* specify curl at an end knot (\&{curl}) */ +@d macro_special 63 /* special macro operators (\&{quote}, \.{\#\AT!}, etc.) */ +@d right_delimiter 64 /* the right delimiter of a matching pair */ +@d left_bracket 65 /* the operator `\.[' */ +@d right_bracket 66 /* the operator `\.]' */ +@d right_brace 67 /* the operator `\.{\char`\}}' */ +@d with_option 68 /* option for filling (\&{withpen}, \&{withweight}, etc.) */ +@d thing_to_add 69 + /* variant of \&{addto} (\&{contour}, \&{doublepath}, \&{also}) */ +@d of_token 70 /* the operator `\&{of}' */ +@d to_token 71 /* the operator `\&{to}' */ +@d step_token 72 /* the operator `\&{step}' */ +@d until_token 73 /* the operator `\&{until}' */ +@d within_token 74 /* the operator `\&{within}' */ +@d lig_kern_token 75 + /* the operators `\&{kern}' and `\.{=:}' and `\.{=:\char'174}', etc. */ +@d assignment 76 /* the operator `\.{:=}' */ +@d skip_to 77 /* the operation `\&{skipto}' */ +@d bchar_label 78 /* the operator `\.{\char'174\char'174:}' */ +@d double_colon 79 /* the operator `\.{::}' */ +@d colon 80 /* the operator `\.:' */ +@# +@d comma 81 /* the operator `\.,', must be |colon+1| */ +@d end_of_statement (mp->cur_cmd>comma) +@d semicolon 82 /* the operator `\.;', must be |comma+1| */ +@d end_group 83 /* end a group (\&{endgroup}), must be |semicolon+1| */ +@d stop 84 /* end a job (\&{end}, \&{dump}), must be |end_group+1| */ +@d max_command_code stop +@d outer_tag (max_command_code+1) /* protection code added to command code */ + +@<Types...@>= +typedef int command_code; + +@ Variables and capsules in \MP\ have a variety of ``types,'' +distinguished by the code numbers defined here. These numbers are also +not completely arbitrary. Things that get expanded must have types +|>mp_independent|; a type remaining after expansion is numeric if and only if +its code number is at least |numeric_type|; objects containing numeric +parts must have types between |transform_type| and |pair_type|; +all other types must be smaller than |transform_type|; and among the types +that are not unknown or vacuous, the smallest two must be |boolean_type| +and |string_type| in that order. + +@d undefined 0 /* no type has been declared */ +@d unknown_tag 1 /* this constant is added to certain type codes below */ +@d unknown_types mp_unknown_boolean: case mp_unknown_string: + case mp_unknown_pen: case mp_unknown_picture: case mp_unknown_path + +@<Types...@>= +enum mp_variable_type { +mp_vacuous=1, /* no expression was present */ +mp_boolean_type, /* \&{boolean} with a known value */ +mp_unknown_boolean, +mp_string_type, /* \&{string} with a known value */ +mp_unknown_string, +mp_pen_type, /* \&{pen} with a known value */ +mp_unknown_pen, +mp_path_type, /* \&{path} with a known value */ +mp_unknown_path, +mp_picture_type, /* \&{picture} with a known value */ +mp_unknown_picture, +mp_transform_type, /* \&{transform} variable or capsule */ +mp_color_type, /* \&{color} variable or capsule */ +mp_cmykcolor_type, /* \&{cmykcolor} variable or capsule */ +mp_pair_type, /* \&{pair} variable or capsule */ +mp_numeric_type, /* variable that has been declared \&{numeric} but not used */ +mp_known, /* \&{numeric} with a known value */ +mp_dependent, /* a linear combination with |fraction| coefficients */ +mp_proto_dependent, /* a linear combination with |scaled| coefficients */ +mp_independent, /* \&{numeric} with unknown value */ +mp_token_list, /* variable name or suffix argument or text argument */ +mp_structured, /* variable with subscripts and attributes */ +mp_unsuffixed_macro, /* variable defined with \&{vardef} but no \.{\AT!\#} */ +mp_suffixed_macro /* variable defined with \&{vardef} and \.{\AT!\#} */ +} ; + +@ @<Declarations@>= +static void mp_print_type (MP mp,quarterword t) ; + +@ @<Basic printing procedures@>= +void mp_print_type (MP mp,quarterword t) { + switch (t) { + case mp_vacuous:mp_print(mp, "mp_vacuous"); break; + case mp_boolean_type:mp_print(mp, "boolean"); break; + case mp_unknown_boolean:mp_print(mp, "unknown boolean"); break; + case mp_string_type:mp_print(mp, "string"); break; + case mp_unknown_string:mp_print(mp, "unknown string"); break; + case mp_pen_type:mp_print(mp, "pen"); break; + case mp_unknown_pen:mp_print(mp, "unknown pen"); break; + case mp_path_type:mp_print(mp, "path"); break; + case mp_unknown_path:mp_print(mp, "unknown path"); break; + case mp_picture_type:mp_print(mp, "picture"); break; + case mp_unknown_picture:mp_print(mp, "unknown picture"); break; + case mp_transform_type:mp_print(mp, "transform"); break; + case mp_color_type:mp_print(mp, "color"); break; + case mp_cmykcolor_type:mp_print(mp, "cmykcolor"); break; + case mp_pair_type:mp_print(mp, "pair"); break; + case mp_known:mp_print(mp, "known numeric"); break; + case mp_dependent:mp_print(mp, "dependent"); break; + case mp_proto_dependent:mp_print(mp, "proto-dependent"); break; + case mp_numeric_type:mp_print(mp, "numeric"); break; + case mp_independent:mp_print(mp, "independent"); break; + case mp_token_list:mp_print(mp, "token list"); break; + case mp_structured:mp_print(mp, "mp_structured"); break; + case mp_unsuffixed_macro:mp_print(mp, "unsuffixed macro"); break; + case mp_suffixed_macro:mp_print(mp, "suffixed macro"); break; + default: mp_print(mp, "undefined"); break; + } +} + +@ Values inside \MP\ are stored in two-word nodes that have a |name_type| +as well as a |type|. The possibilities for |name_type| are defined +here; they will be explained in more detail later. + +@<Types...@>= +enum mp_name_types { + mp_root=0, /* |name_type| at the top level of a variable */ + mp_saved_root, /* same, when the variable has been saved */ + mp_structured_root, /* |name_type| where a |mp_structured| branch occurs */ + mp_subscr, /* |name_type| in a subscript node */ + mp_attr, /* |name_type| in an attribute node */ + mp_x_part_sector, /* |name_type| in the \&{xpart} of a node */ + mp_y_part_sector, /* |name_type| in the \&{ypart} of a node */ + mp_xx_part_sector, /* |name_type| in the \&{xxpart} of a node */ + mp_xy_part_sector, /* |name_type| in the \&{xypart} of a node */ + mp_yx_part_sector, /* |name_type| in the \&{yxpart} of a node */ + mp_yy_part_sector, /* |name_type| in the \&{yypart} of a node */ + mp_red_part_sector, /* |name_type| in the \&{redpart} of a node */ + mp_green_part_sector, /* |name_type| in the \&{greenpart} of a node */ + mp_blue_part_sector, /* |name_type| in the \&{bluepart} of a node */ + mp_cyan_part_sector, /* |name_type| in the \&{redpart} of a node */ + mp_magenta_part_sector, /* |name_type| in the \&{greenpart} of a node */ + mp_yellow_part_sector, /* |name_type| in the \&{bluepart} of a node */ + mp_black_part_sector, /* |name_type| in the \&{greenpart} of a node */ + mp_grey_part_sector, /* |name_type| in the \&{bluepart} of a node */ + mp_capsule, /* |name_type| in stashed-away subexpressions */ + mp_token /* |name_type| in a numeric token or string token */ +}; + +@ Primitive operations that produce values have a secondary identification +code in addition to their command code; it's something like genera and species. +For example, `\.*' has the command code |primary_binary|, and its +secondary identification is |times|. The secondary codes start at 30 so that +they don't overlap with the type codes; some type codes (e.g., |mp_string_type|) +are used as operators as well as type identifications. The relative values +are not critical, except for |true_code..false_code|, |or_op..and_op|, +and |filled_op..bounded_op|. The restrictions are that +|and_op-false_code=or_op-true_code|, that the ordering of +|x_part...blue_part| must match that of |x_part_sector..mp_blue_part_sector|, +and the ordering of |filled_op..bounded_op| must match that of the code +values they test for. + +@d true_code 30 /* operation code for \.{true} */ +@d false_code 31 /* operation code for \.{false} */ +@d null_picture_code 32 /* operation code for \.{nullpicture} */ +@d null_pen_code 33 /* operation code for \.{nullpen} */ +@d job_name_op 34 /* operation code for \.{jobname} */ +@d read_string_op 35 /* operation code for \.{readstring} */ +@d pen_circle 36 /* operation code for \.{pencircle} */ +@d normal_deviate 37 /* operation code for \.{normaldeviate} */ +@d read_from_op 38 /* operation code for \.{readfrom} */ +@d close_from_op 39 /* operation code for \.{closefrom} */ +@d odd_op 40 /* operation code for \.{odd} */ +@d known_op 41 /* operation code for \.{known} */ +@d unknown_op 42 /* operation code for \.{unknown} */ +@d not_op 43 /* operation code for \.{not} */ +@d decimal 44 /* operation code for \.{decimal} */ +@d reverse 45 /* operation code for \.{reverse} */ +@d make_path_op 46 /* operation code for \.{makepath} */ +@d make_pen_op 47 /* operation code for \.{makepen} */ +@d oct_op 48 /* operation code for \.{oct} */ +@d hex_op 49 /* operation code for \.{hex} */ +@d ASCII_op 50 /* operation code for \.{ASCII} */ +@d char_op 51 /* operation code for \.{char} */ +@d length_op 52 /* operation code for \.{length} */ +@d turning_op 53 /* operation code for \.{turningnumber} */ +@d color_model_part 54 /* operation code for \.{colormodel} */ +@d x_part 55 /* operation code for \.{xpart} */ +@d y_part 56 /* operation code for \.{ypart} */ +@d xx_part 57 /* operation code for \.{xxpart} */ +@d xy_part 58 /* operation code for \.{xypart} */ +@d yx_part 59 /* operation code for \.{yxpart} */ +@d yy_part 60 /* operation code for \.{yypart} */ +@d red_part 61 /* operation code for \.{redpart} */ +@d green_part 62 /* operation code for \.{greenpart} */ +@d blue_part 63 /* operation code for \.{bluepart} */ +@d cyan_part 64 /* operation code for \.{cyanpart} */ +@d magenta_part 65 /* operation code for \.{magentapart} */ +@d yellow_part 66 /* operation code for \.{yellowpart} */ +@d black_part 67 /* operation code for \.{blackpart} */ +@d grey_part 68 /* operation code for \.{greypart} */ +@d font_part 69 /* operation code for \.{fontpart} */ +@d text_part 70 /* operation code for \.{textpart} */ +@d path_part 71 /* operation code for \.{pathpart} */ +@d pen_part 72 /* operation code for \.{penpart} */ +@d dash_part 73 /* operation code for \.{dashpart} */ +@d sqrt_op 74 /* operation code for \.{sqrt} */ +@d mp_m_exp_op 75 /* operation code for \.{mexp} */ +@d mp_m_log_op 76 /* operation code for \.{mlog} */ +@d sin_d_op 77 /* operation code for \.{sind} */ +@d cos_d_op 78 /* operation code for \.{cosd} */ +@d floor_op 79 /* operation code for \.{floor} */ +@d uniform_deviate 80 /* operation code for \.{uniformdeviate} */ +@d char_exists_op 81 /* operation code for \.{charexists} */ +@d font_size 82 /* operation code for \.{fontsize} */ +@d ll_corner_op 83 /* operation code for \.{llcorner} */ +@d lr_corner_op 84 /* operation code for \.{lrcorner} */ +@d ul_corner_op 85 /* operation code for \.{ulcorner} */ +@d ur_corner_op 86 /* operation code for \.{urcorner} */ +@d arc_length 87 /* operation code for \.{arclength} */ +@d angle_op 88 /* operation code for \.{angle} */ +@d cycle_op 89 /* operation code for \.{cycle} */ +@d filled_op 90 /* operation code for \.{filled} */ +@d stroked_op 91 /* operation code for \.{stroked} */ +@d textual_op 92 /* operation code for \.{textual} */ +@d clipped_op 93 /* operation code for \.{clipped} */ +@d bounded_op 94 /* operation code for \.{bounded} */ +@d plus 95 /* operation code for \.+ */ +@d minus 96 /* operation code for \.- */ +@d times 97 /* operation code for \.* */ +@d over 98 /* operation code for \./ */ +@d pythag_add 99 /* operation code for \.{++} */ +@d pythag_sub 100 /* operation code for \.{+-+} */ +@d or_op 101 /* operation code for \.{or} */ +@d and_op 102 /* operation code for \.{and} */ +@d less_than 103 /* operation code for \.< */ +@d less_or_equal 104 /* operation code for \.{<=} */ +@d greater_than 105 /* operation code for \.> */ +@d greater_or_equal 106 /* operation code for \.{>=} */ +@d equal_to 107 /* operation code for \.= */ +@d unequal_to 108 /* operation code for \.{<>} */ +@d concatenate 109 /* operation code for \.\& */ +@d rotated_by 110 /* operation code for \.{rotated} */ +@d slanted_by 111 /* operation code for \.{slanted} */ +@d scaled_by 112 /* operation code for \.{scaled} */ +@d shifted_by 113 /* operation code for \.{shifted} */ +@d transformed_by 114 /* operation code for \.{transformed} */ +@d x_scaled 115 /* operation code for \.{xscaled} */ +@d y_scaled 116 /* operation code for \.{yscaled} */ +@d z_scaled 117 /* operation code for \.{zscaled} */ +@d in_font 118 /* operation code for \.{infont} */ +@d intersect 119 /* operation code for \.{intersectiontimes} */ +@d double_dot 120 /* operation code for improper \.{..} */ +@d substring_of 121 /* operation code for \.{substring} */ +@d min_of substring_of +@d subpath_of 122 /* operation code for \.{subpath} */ +@d direction_time_of 123 /* operation code for \.{directiontime} */ +@d point_of 124 /* operation code for \.{point} */ +@d precontrol_of 125 /* operation code for \.{precontrol} */ +@d postcontrol_of 126 /* operation code for \.{postcontrol} */ +@d pen_offset_of 127 /* operation code for \.{penoffset} */ +@d arc_time_of 128 /* operation code for \.{arctime} */ +@d mp_version 129 /* operation code for \.{mpversion} */ +@d envelope_of 130 /* operation code for \.{envelope} */ + +@c static void mp_print_op (MP mp,quarterword c) { + if (c<=mp_numeric_type ) { + mp_print_type(mp, c); + } else { + switch (c) { + case true_code:mp_print(mp, "true"); break; + case false_code:mp_print(mp, "false"); break; + case null_picture_code:mp_print(mp, "nullpicture"); break; + case null_pen_code:mp_print(mp, "nullpen"); break; + case job_name_op:mp_print(mp, "jobname"); break; + case read_string_op:mp_print(mp, "readstring"); break; + case pen_circle:mp_print(mp, "pencircle"); break; + case normal_deviate:mp_print(mp, "normaldeviate"); break; + case read_from_op:mp_print(mp, "readfrom"); break; + case close_from_op:mp_print(mp, "closefrom"); break; + case odd_op:mp_print(mp, "odd"); break; + case known_op:mp_print(mp, "known"); break; + case unknown_op:mp_print(mp, "unknown"); break; + case not_op:mp_print(mp, "not"); break; + case decimal:mp_print(mp, "decimal"); break; + case reverse:mp_print(mp, "reverse"); break; + case make_path_op:mp_print(mp, "makepath"); break; + case make_pen_op:mp_print(mp, "makepen"); break; + case oct_op:mp_print(mp, "oct"); break; + case hex_op:mp_print(mp, "hex"); break; + case ASCII_op:mp_print(mp, "ASCII"); break; + case char_op:mp_print(mp, "char"); break; + case length_op:mp_print(mp, "length"); break; + case turning_op:mp_print(mp, "turningnumber"); break; + case x_part:mp_print(mp, "xpart"); break; + case y_part:mp_print(mp, "ypart"); break; + case xx_part:mp_print(mp, "xxpart"); break; + case xy_part:mp_print(mp, "xypart"); break; + case yx_part:mp_print(mp, "yxpart"); break; + case yy_part:mp_print(mp, "yypart"); break; + case red_part:mp_print(mp, "redpart"); break; + case green_part:mp_print(mp, "greenpart"); break; + case blue_part:mp_print(mp, "bluepart"); break; + case cyan_part:mp_print(mp, "cyanpart"); break; + case magenta_part:mp_print(mp, "magentapart"); break; + case yellow_part:mp_print(mp, "yellowpart"); break; + case black_part:mp_print(mp, "blackpart"); break; + case grey_part:mp_print(mp, "greypart"); break; + case color_model_part:mp_print(mp, "colormodel"); break; + case font_part:mp_print(mp, "fontpart"); break; + case text_part:mp_print(mp, "textpart"); break; + case path_part:mp_print(mp, "pathpart"); break; + case pen_part:mp_print(mp, "penpart"); break; + case dash_part:mp_print(mp, "dashpart"); break; + case sqrt_op:mp_print(mp, "sqrt"); break; + case mp_m_exp_op:mp_print(mp, "mexp"); break; + case mp_m_log_op:mp_print(mp, "mlog"); break; + case sin_d_op:mp_print(mp, "sind"); break; + case cos_d_op:mp_print(mp, "cosd"); break; + case floor_op:mp_print(mp, "floor"); break; + case uniform_deviate:mp_print(mp, "uniformdeviate"); break; + case char_exists_op:mp_print(mp, "charexists"); break; + case font_size:mp_print(mp, "fontsize"); break; + case ll_corner_op:mp_print(mp, "llcorner"); break; + case lr_corner_op:mp_print(mp, "lrcorner"); break; + case ul_corner_op:mp_print(mp, "ulcorner"); break; + case ur_corner_op:mp_print(mp, "urcorner"); break; + case arc_length:mp_print(mp, "arclength"); break; + case angle_op:mp_print(mp, "angle"); break; + case cycle_op:mp_print(mp, "cycle"); break; + case filled_op:mp_print(mp, "filled"); break; + case stroked_op:mp_print(mp, "stroked"); break; + case textual_op:mp_print(mp, "textual"); break; + case clipped_op:mp_print(mp, "clipped"); break; + case bounded_op:mp_print(mp, "bounded"); break; + case plus:mp_print_char(mp, xord('+')); break; + case minus:mp_print_char(mp, xord('-')); break; + case times:mp_print_char(mp, xord('*')); break; + case over:mp_print_char(mp, xord('/')); break; + case pythag_add:mp_print(mp, "++"); break; + case pythag_sub:mp_print(mp, "+-+"); break; + case or_op:mp_print(mp, "or"); break; + case and_op:mp_print(mp, "and"); break; + case less_than:mp_print_char(mp, xord('<')); break; + case less_or_equal:mp_print(mp, "<="); break; + case greater_than:mp_print_char(mp, xord('>')); break; + case greater_or_equal:mp_print(mp, ">="); break; + case equal_to:mp_print_char(mp, xord('=')); break; + case unequal_to:mp_print(mp, "<>"); break; + case concatenate:mp_print(mp, "&"); break; + case rotated_by:mp_print(mp, "rotated"); break; + case slanted_by:mp_print(mp, "slanted"); break; + case scaled_by:mp_print(mp, "scaled"); break; + case shifted_by:mp_print(mp, "shifted"); break; + case transformed_by:mp_print(mp, "transformed"); break; + case x_scaled:mp_print(mp, "xscaled"); break; + case y_scaled:mp_print(mp, "yscaled"); break; + case z_scaled:mp_print(mp, "zscaled"); break; + case in_font:mp_print(mp, "infont"); break; + case intersect:mp_print(mp, "intersectiontimes"); break; + case substring_of:mp_print(mp, "substring"); break; + case subpath_of:mp_print(mp, "subpath"); break; + case direction_time_of:mp_print(mp, "directiontime"); break; + case point_of:mp_print(mp, "point"); break; + case precontrol_of:mp_print(mp, "precontrol"); break; + case postcontrol_of:mp_print(mp, "postcontrol"); break; + case pen_offset_of:mp_print(mp, "penoffset"); break; + case arc_time_of:mp_print(mp, "arctime"); break; + case mp_version:mp_print(mp, "mpversion"); break; + case envelope_of:mp_print(mp, "envelope"); break; + default: mp_print(mp, ".."); break; + } + } +} + +@ \MP\ also has a bunch of internal parameters that a user might want to +fuss with. Every such parameter has an identifying code number, defined here. + +@<Types...@>= +enum mp_given_internal { + mp_output_template=1, /* a string set up by \&{outputtemplate} */ + mp_output_format, /* the output format set up by \&{outputformat} */ + 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_char_code, /* the number of the next character to be output */ + mp_char_ext, /* the extension code of the next character to be output */ + mp_char_wd, /* the width of the next character to be output */ + mp_char_ht, /* the height of the next character to be output */ + mp_char_dp, /* the depth of the next character to be output */ + mp_char_ic, /* the italic correction of the next character to be output */ + mp_design_size, /* the unit of measure used for |mp_char_wd..mp_char_ic|, in points */ + mp_pausing, /* positive to display lines on the terminal before they are read */ + mp_showstopping, /* positive to stop after each \&{show} command */ + mp_fontmaking, /* positive if font metric output is to be produced */ + mp_linejoin, /* as in \ps: 0 for mitered, 1 for round, 2 for beveled */ + mp_linecap, /* as in \ps: 0 for butt, 1 for round, 2 for square */ + mp_miterlimit, /* controls miter length as in \ps */ + mp_warning_check, /* controls error message when variable value is large */ + mp_boundary_char, /* the right boundary character for ligatures */ + mp_prologues, /* positive to output conforming PostScript using built-in fonts */ + mp_true_corners, /* positive to make \&{llcorner} etc. ignore \&{setbounds} */ + mp_default_color_model, /* the default color model for unspecified items */ + mp_restore_clip_color, + mp_procset, /* wether or not create PostScript command shortcuts */ + mp_gtroffmode /* whether the user specified |-troff| on the command line */ +}; + +@ + +@d max_given_internal mp_gtroffmode + +@<Glob...@>= +scaled *internal; /* the values of internal quantities */ +char **int_name; /* their names */ +int int_ptr; /* the maximum internal quantity defined so far */ +int max_internal; /* current maximum number of internal quantities */ + +@ @<Option variables@>= +int troff_mode; + +@ @<Allocate or initialize ...@>= +mp->max_internal=2*max_given_internal; +mp->internal = xmalloc ((mp->max_internal+1), sizeof(scaled)); +memset(mp->internal,0,(mp->max_internal+1)* sizeof(scaled)); +mp->int_name = xmalloc ((mp->max_internal+1), sizeof(char *)); +memset(mp->int_name,0,(mp->max_internal+1) * sizeof(char *)); +mp->troff_mode=(opt->troff_mode>0 ? true : false); + +@ @<Exported function ...@>= +int mp_troff_mode(MP mp); + +@ @c +int mp_troff_mode(MP mp) { return mp->troff_mode; } + +@ @<Set initial ...@>= +mp->int_ptr=max_given_internal; + +@ The symbolic names for internal quantities are put into \MP's hash table +by using a routine called |primitive|, which will be defined later. Let us +enter them now, so that we don't have to list all those names again +anywhere else. + +@<Put each of \MP's primitives into the hash table@>= +mp_primitive(mp, "tracingtitles",internal_quantity,mp_tracing_titles); +@:tracingtitles_}{\&{tracingtitles} primitive@> +mp_primitive(mp, "tracingequations",internal_quantity,mp_tracing_equations); +@:mp_tracing_equations_}{\&{tracingequations} primitive@> +mp_primitive(mp, "tracingcapsules",internal_quantity,mp_tracing_capsules); +@:mp_tracing_capsules_}{\&{tracingcapsules} primitive@> +mp_primitive(mp, "tracingchoices",internal_quantity,mp_tracing_choices); +@:mp_tracing_choices_}{\&{tracingchoices} primitive@> +mp_primitive(mp, "tracingspecs",internal_quantity,mp_tracing_specs); +@:mp_tracing_specs_}{\&{tracingspecs} primitive@> +mp_primitive(mp, "tracingcommands",internal_quantity,mp_tracing_commands); +@:mp_tracing_commands_}{\&{tracingcommands} primitive@> +mp_primitive(mp, "tracingrestores",internal_quantity,mp_tracing_restores); +@:mp_tracing_restores_}{\&{tracingrestores} primitive@> +mp_primitive(mp, "tracingmacros",internal_quantity,mp_tracing_macros); +@:mp_tracing_macros_}{\&{tracingmacros} primitive@> +mp_primitive(mp, "tracingoutput",internal_quantity,mp_tracing_output); +@:mp_tracing_output_}{\&{tracingoutput} primitive@> +mp_primitive(mp, "tracingstats",internal_quantity,mp_tracing_stats); +@:mp_tracing_stats_}{\&{tracingstats} primitive@> +mp_primitive(mp, "tracinglostchars",internal_quantity,mp_tracing_lost_chars); +@:mp_tracing_lost_chars_}{\&{tracinglostchars} primitive@> +mp_primitive(mp, "tracingonline",internal_quantity,mp_tracing_online); +@:mp_tracing_online_}{\&{tracingonline} primitive@> +mp_primitive(mp, "year",internal_quantity,mp_year); +@:mp_year_}{\&{year} primitive@> +mp_primitive(mp, "month",internal_quantity,mp_month); +@:mp_month_}{\&{month} primitive@> +mp_primitive(mp, "day",internal_quantity,mp_day); +@:mp_day_}{\&{day} primitive@> +mp_primitive(mp, "time",internal_quantity,mp_time); +@:time_}{\&{time} primitive@> +mp_primitive(mp, "charcode",internal_quantity,mp_char_code); +@:mp_char_code_}{\&{charcode} primitive@> +mp_primitive(mp, "charext",internal_quantity,mp_char_ext); +@:mp_char_ext_}{\&{charext} primitive@> +mp_primitive(mp, "charwd",internal_quantity,mp_char_wd); +@:mp_char_wd_}{\&{charwd} primitive@> +mp_primitive(mp, "charht",internal_quantity,mp_char_ht); +@:mp_char_ht_}{\&{charht} primitive@> +mp_primitive(mp, "chardp",internal_quantity,mp_char_dp); +@:mp_char_dp_}{\&{chardp} primitive@> +mp_primitive(mp, "charic",internal_quantity,mp_char_ic); +@:mp_char_ic_}{\&{charic} primitive@> +mp_primitive(mp, "designsize",internal_quantity,mp_design_size); +@:mp_design_size_}{\&{designsize} primitive@> +mp_primitive(mp, "pausing",internal_quantity,mp_pausing); +@:mp_pausing_}{\&{pausing} primitive@> +mp_primitive(mp, "showstopping",internal_quantity,mp_showstopping); +@:mp_showstopping_}{\&{showstopping} primitive@> +mp_primitive(mp, "fontmaking",internal_quantity,mp_fontmaking); +@:mp_fontmaking_}{\&{fontmaking} primitive@> +mp_primitive(mp, "linejoin",internal_quantity,mp_linejoin); +@:mp_linejoin_}{\&{linejoin} primitive@> +mp_primitive(mp, "linecap",internal_quantity,mp_linecap); +@:mp_linecap_}{\&{linecap} primitive@> +mp_primitive(mp, "miterlimit",internal_quantity,mp_miterlimit); +@:mp_miterlimit_}{\&{miterlimit} primitive@> +mp_primitive(mp, "warningcheck",internal_quantity,mp_warning_check); +@:mp_warning_check_}{\&{warningcheck} primitive@> +mp_primitive(mp, "boundarychar",internal_quantity,mp_boundary_char); +@:mp_boundary_char_}{\&{boundarychar} primitive@> +mp_primitive(mp, "prologues",internal_quantity,mp_prologues); +@:mp_prologues_}{\&{prologues} primitive@> +mp_primitive(mp, "truecorners",internal_quantity,mp_true_corners); +@:mp_true_corners_}{\&{truecorners} primitive@> +mp_primitive(mp, "mpprocset",internal_quantity,mp_procset); +@:mp_procset_}{\&{mpprocset} primitive@> +mp_primitive(mp, "troffmode",internal_quantity,mp_gtroffmode); +@:troffmode_}{\&{troffmode} primitive@> +mp_primitive(mp, "defaultcolormodel",internal_quantity,mp_default_color_model); +@:mp_default_color_model_}{\&{defaultcolormodel} primitive@> +mp_primitive(mp, "restoreclipcolor",internal_quantity,mp_restore_clip_color); +@:mp_restore_clip_color_}{\&{restoreclipcolor} primitive@> +mp_primitive(mp, "outputtemplate",internal_quantity,mp_output_template); +@:mp_output_template_}{\&{outputtemplate} primitive@> +mp_primitive(mp, "outputformat",internal_quantity,mp_output_format); +@:mp_output_format_}{\&{outputformat} 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.h@>= +enum mp_color_model { + mp_no_model=1, + mp_grey_model=3, + mp_rgb_model=5, + mp_cmyk_model=7, + mp_uninitialized_model=9 +}; + + +@ @<Initialize table entries (done by \.{INIMP} only)@>= +mp->internal[mp_default_color_model]=(mp_rgb_model*unity); +mp->internal[mp_restore_clip_color]=unity; +mp->internal[mp_output_template]=intern("%j.%c"); +mp->internal[mp_output_format]=intern("eps"); + +@ Well, we do have to list the names one more time, for use in symbolic +printouts. + +@<Initialize table...@>= +mp->int_name[mp_tracing_titles]=xstrdup("tracingtitles"); +mp->int_name[mp_tracing_equations]=xstrdup("tracingequations"); +mp->int_name[mp_tracing_capsules]=xstrdup("tracingcapsules"); +mp->int_name[mp_tracing_choices]=xstrdup("tracingchoices"); +mp->int_name[mp_tracing_specs]=xstrdup("tracingspecs"); +mp->int_name[mp_tracing_commands]=xstrdup("tracingcommands"); +mp->int_name[mp_tracing_restores]=xstrdup("tracingrestores"); +mp->int_name[mp_tracing_macros]=xstrdup("tracingmacros"); +mp->int_name[mp_tracing_output]=xstrdup("tracingoutput"); +mp->int_name[mp_tracing_stats]=xstrdup("tracingstats"); +mp->int_name[mp_tracing_lost_chars]=xstrdup("tracinglostchars"); +mp->int_name[mp_tracing_online]=xstrdup("tracingonline"); +mp->int_name[mp_year]=xstrdup("year"); +mp->int_name[mp_month]=xstrdup("month"); +mp->int_name[mp_day]=xstrdup("day"); +mp->int_name[mp_time]=xstrdup("time"); +mp->int_name[mp_char_code]=xstrdup("charcode"); +mp->int_name[mp_char_ext]=xstrdup("charext"); +mp->int_name[mp_char_wd]=xstrdup("charwd"); +mp->int_name[mp_char_ht]=xstrdup("charht"); +mp->int_name[mp_char_dp]=xstrdup("chardp"); +mp->int_name[mp_char_ic]=xstrdup("charic"); +mp->int_name[mp_design_size]=xstrdup("designsize"); +mp->int_name[mp_pausing]=xstrdup("pausing"); +mp->int_name[mp_showstopping]=xstrdup("showstopping"); +mp->int_name[mp_fontmaking]=xstrdup("fontmaking"); +mp->int_name[mp_linejoin]=xstrdup("linejoin"); +mp->int_name[mp_linecap]=xstrdup("linecap"); +mp->int_name[mp_miterlimit]=xstrdup("miterlimit"); +mp->int_name[mp_warning_check]=xstrdup("warningcheck"); +mp->int_name[mp_boundary_char]=xstrdup("boundarychar"); +mp->int_name[mp_prologues]=xstrdup("prologues"); +mp->int_name[mp_true_corners]=xstrdup("truecorners"); +mp->int_name[mp_default_color_model]=xstrdup("defaultcolormodel"); +mp->int_name[mp_procset]=xstrdup("mpprocset"); +mp->int_name[mp_gtroffmode]=xstrdup("troffmode"); +mp->int_name[mp_restore_clip_color]=xstrdup("restoreclipcolor"); +mp->int_name[mp_output_template]=xstrdup("outputtemplate"); +mp->int_name[mp_output_format]=xstrdup("outputformat"); + +@ 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 +static void mp_fix_date_and_time (MP mp) { + time_t aclock = time ((time_t *) 0); + struct tm *tmptr = localtime (&aclock); + mp->internal[mp_time]= + (tmptr->tm_hour*60+tmptr->tm_min)*unity; /* minutes since midnight */ + mp->internal[mp_day]=(tmptr->tm_mday)*unity; /* fourth day of the month */ + mp->internal[mp_month]=(tmptr->tm_mon+1)*unity; /* seventh month of the year */ + mp->internal[mp_year]=(tmptr->tm_year+1900)*unity; /* Anno Domini */ +} + +@ @<Declarations@>= +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 ((mp->internal[mp_tracing_online]<=0)&&(mp->selector==term_and_log)){ + decr(mp->selector); + if ( mp->history==mp_spotless ) mp->history=mp_warning_issued; + } +} +@# +void mp_end_diagnostic (MP mp,boolean blank_line) { + /* restore proper conditions after tracing */ + mp_print_nl(mp, ""); + if ( blank_line ) mp_print_ln(mp); + mp->selector=mp->old_setting; +} + +@ + +@<Glob...@>= +unsigned int old_setting; + +@ We will occasionally use |begin_diagnostic| in connection with line-number +printing, as follows. (The parameter |s| is typically |"Path"| or +|"Cycle spec"|, etc.) + +@<Basic printing...@>= +void mp_print_diagnostic (MP mp, const char *s, const char *t, boolean nuline) { + mp_begin_diagnostic(mp); + if ( nuline ) mp_print_nl(mp, s); else mp_print(mp, s); + mp_print(mp, " at line "); + mp_print_int(mp, mp_true_line(mp)); + mp_print(mp, t); mp_print_char(mp, 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 left_bracket_class 17 /* `\.[' */ +@d right_bracket_class 18 /* `\.]' */ +@d invalid_class 20 /* bad character in the input */ +@d max_class 20 /* the largest class number */ + +@<Glob...@>= +int char_class[256]; /* the class numbers */ + +@ If changes are made to accommodate non-ASCII character sets, they should +follow the guidelines in Appendix~C of {\sl The {\logos METAFONT\/}book}. +@:METAFONTbook}{\sl The {\logos METAFONT\/}book@> +@^system dependencies@> + +@<Set initial ...@>= +for (k='0';k<='9';k++) + mp->char_class[k]=digit_class; +mp->char_class['.']=period_class; +mp->char_class[' ']=space_class; +mp->char_class['%']=percent_class; +mp->char_class['"']=string_class; +mp->char_class[',']=5; +mp->char_class[';']=6; +mp->char_class['(']=7; +mp->char_class[')']=right_paren_class; +for (k='A';k<= 'Z';k++ ) + mp->char_class[k]=letter_class; +for (k='a';k<='z';k++) + mp->char_class[k]=letter_class; +mp->char_class['_']=letter_class; +mp->char_class['<']=10; +mp->char_class['=']=10; +mp->char_class['>']=10; +mp->char_class[':']=10; +mp->char_class['|']=10; +mp->char_class['`']=11; +mp->char_class['\'']=11; +mp->char_class['+']=12; +mp->char_class['-']=12; +mp->char_class['/']=13; +mp->char_class['*']=13; +mp->char_class['\\']=13; +mp->char_class['!']=14; +mp->char_class['?']=14; +mp->char_class['#']=15; +mp->char_class['&']=15; +mp->char_class['@@']=15; +mp->char_class['$']=15; +mp->char_class['^']=16; +mp->char_class['~']=16; +mp->char_class['[']=left_bracket_class; +mp->char_class[']']=right_bracket_class; +mp->char_class['{']=19; +mp->char_class['}']=19; +for (k=0;k<' ';k++) + mp->char_class[k]=invalid_class; +mp->char_class['\t']=space_class; +mp->char_class['\f']=space_class; +for (k=127;k<=255;k++) + mp->char_class[k]=invalid_class; + +@* \[13] The hash table. +Symbolic tokens are stored and retrieved by means of a fairly standard hash +table algorithm called the method of ``coalescing lists'' (cf.\ Algorithm 6.4C +in {\sl The Art of Computer Programming\/}). Once a symbolic token enters the +table, it is never removed. + +The actual sequence of characters forming a symbolic token is +stored in the |str_pool| array together with all the other strings. An +auxiliary array |hash| consists of items with two halfword fields per +word. The first of these, called |mp_next(p)|, points to the next identifier +belonging to the same coalesced list as the identifier corresponding to~|p|; +and the other, called |text(p)|, points to the |str_start| entry for +|p|'s identifier. If position~|p| of the hash table is empty, we have +|text(p)=0|; if position |p| is either empty or the end of a coalesced +hash list, we have |mp_next(p)=0|. + +An auxiliary pointer variable called |hash_used| is maintained in such a +way that all locations |p>=hash_used| are nonempty. The global variable +|st_count| tells how many symbolic tokens have been defined, if statistics +are being kept. + +The first 256 locations of |hash| are reserved for symbols of length one. + +There's a parallel array called |eqtb| that contains the current equivalent +values of each symbolic token. The entries of this array consist of +two halfwords called |eq_type| (a command code) and |equiv| (a secondary +piece of information that qualifies the |eq_type|). + +@d eq_type(A) mp->eqtb[(A)].lh /* the current ``meaning'' of a symbolic token */ +@d equiv(A) mp->eqtb[(A)].rh /* parametric part of a token's meaning */ +@d hash_is_full (mp->hash_used==hash_base) /* are all positions occupied? */ + +@(mpmp.h@>= +#define mp_next(A) mp->hash[(A)].lh /* link for coalesced lists */ +#define text(A) mp->hash[(A)].rh /* string number for symbolic token name */ +#define hash_base 257 /* hashing actually starts here */ + +@ @<Glob...@>= +pointer hash_used; /* allocation pointer for |hash| */ +integer st_count; /* total number of known identifiers */ + +@ Certain entries in the hash table are ``frozen'' and not redefinable, +since they are used in error recovery. + +@(mpmp.h@>= +#define hash_top (integer)(hash_base+mp->hash_size) /* the first location of the frozen area */ +#define frozen_inaccessible hash_top /* |hash| location to protect the frozen area */ +#define frozen_repeat_loop (hash_top+1) /* |hash| location of a loop-repeat token */ +#define frozen_right_delimiter (hash_top+2) /* |hash| location of a permanent `\.)' */ +#define frozen_left_bracket (hash_top+3) /* |hash| location of a permanent `\.[' */ +#define frozen_slash (hash_top+4) /* |hash| location of a permanent `\./' */ +#define frozen_colon (hash_top+5) /* |hash| location of a permanent `\.:' */ +#define frozen_semicolon (hash_top+6) /* |hash| location of a permanent `\.;' */ +#define frozen_end_for (hash_top+7) /* |hash| location of a permanent \&{endfor} */ +#define frozen_end_def (hash_top+8) /* |hash| location of a permanent \&{enddef} */ +#define frozen_fi (hash_top+9) /* |hash| location of a permanent \&{fi} */ +#define frozen_end_group (hash_top+10) /* |hash| location of a permanent `\.{endgroup}' */ +#define frozen_etex (hash_top+11) /* |hash| location of a permanent \&{etex} */ +#define frozen_mpx_break (hash_top+12) /* |hash| location of a permanent \&{mpxbreak} */ +#define frozen_bad_vardef (hash_top+13) /* |hash| location of `\.{a bad variable}' */ +#define frozen_undefined (hash_top+14) /* |hash| location that never gets defined */ +#define hash_end (integer)(hash_top+14) /* the actual size of the |hash| and |eqtb| arrays */ + + +@ @<Glob...@>= +two_halves *hash; /* the hash table */ +two_halves *eqtb; /* the equivalents */ + +@ @<Allocate or initialize ...@>= +mp->hash = xmalloc((hash_end+1),sizeof(two_halves)); +mp->eqtb = xmalloc((hash_end+1),sizeof(two_halves)); + +@ @<Dealloc variables@>= +xfree(mp->hash); +xfree(mp->eqtb); + +@ @<Set init...@>= +mp_next(1)=0; text(1)=0; eq_type(1)=tag_token; equiv(1)=null; +for (k=2;k<=hash_end;k++) { + mp->hash[k]=mp->hash[1]; mp->eqtb[k]=mp->eqtb[1]; +} + +@ @<Initialize table entries...@>= +mp->hash_used=frozen_inaccessible; /* nothing is used */ +mp->st_count=0; +text(frozen_bad_vardef)=intern("a bad variable"); +text(frozen_etex)=intern("etex"); +text(frozen_mpx_break)=intern("mpxbreak"); +text(frozen_fi)=intern("fi"); +text(frozen_end_group)=intern("endgroup"); +text(frozen_end_def)=intern("enddef"); +text(frozen_end_for)=intern("endfor"); +text(frozen_semicolon)=intern(";"); +text(frozen_colon)=intern(":"); +text(frozen_slash)=intern("/"); +text(frozen_left_bracket)=intern("["); +text(frozen_right_delimiter)=intern(")"); +text(frozen_inaccessible)=intern(" INACCESSIBLE"); +eq_type(frozen_right_delimiter)=right_delimiter; + +@ @<Check the ``constant'' values...@>= +if ( hash_end+mp->max_internal>max_halfword ) mp->bad=17; + +@ Here is the subroutine that searches the hash table for an identifier +that matches a given string of length~|l| appearing in |buffer[j.. +(j+l-1)]|. If the identifier is not found, it is inserted; hence it +will always be found, and the corresponding hash table address +will be returned. + +@c +static pointer mp_id_lookup (MP mp,integer j, integer l) { /* search the hash table */ + integer h; /* hash code */ + pointer p; /* index in |hash| array */ + pointer k; /* index in |buffer| array */ + if (l==1) { + @<Treat special case of length 1 and |break|@>; + } + @<Compute the hash code |h|@>; + p=h+hash_base; /* we start searching here; note that |0<=h<hash_prime| */ + while (true) { + if (text(p)>0 && length(text(p))==l && mp_str_eq_buf(mp, text(p),j)) + break; + if ( mp_next(p)==0 ) { + @<Insert a new symbolic token after |p|, then + make |p| point to it and |break|@>; + } + p=mp_next(p); + } + return p; +} + +@ @<Treat special case of length 1...@>= + p=mp->buffer[j]+1; text(p)=p-1; return p; + + +@ @<Insert a new symbolic...@>= +{ +if ( text(p)>0 ) { + do { + if ( hash_is_full ) + mp_overflow(mp, "hash size",(integer)mp->hash_size); +@:MetaPost capacity exceeded hash size}{\quad hash size@> + decr(mp->hash_used); + } while (text(mp->hash_used)!=0); /* search for an empty location in |hash| */ + mp_next(p)=mp->hash_used; + p=mp->hash_used; +} +str_room(l); +for (k=j;k<j+l;k++) { + append_char(mp->buffer[k]); +} +text(p)=mp_make_string(mp); +mp->str_ref[text(p)]=max_str_ref; +incr(mp->st_count); +break; +} + + +@ The value of |hash_prime| should be roughly 85\pct! of |hash_size|, and it +should be a prime number. The theory of hashing tells us to expect fewer +than two table probes, on the average, when the search is successful. +[See J.~S. Vitter, {\sl Journal of the ACM\/ \bf30} (1983), 231--258.] +@^Vitter, Jeffrey Scott@> + +@<Compute the hash code |h|@>= +h=mp->buffer[j]; +for (k=j+1;k<j+l;k++){ + h=h+h+mp->buffer[k]; + while ( h>=mp->hash_prime ) h=h-mp->hash_prime; +} + +@ @<Search |eqtb| for equivalents equal to |p|@>= +for (q=1;q<=hash_end;q++) { + if ( equiv(q)==p ) { + mp_print_nl(mp, "EQUIV("); + mp_print_int(mp, q); + mp_print_char(mp, xord(')')); + } +} + +@ 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) { + pool_pointer k; /* index into |str_pool| */ + quarterword j; /* index into |buffer| */ + quarterword l; /* length of the string */ + str_number s; + s = intern(ss); + k=mp->str_start[s]; l=str_stop(s)-k; + /* we will move |s| into the (empty) |buffer| */ + for (j=0;j<=l-1;j++) { + mp->buffer[j]=mp->str_pool[k+j]; + } + mp->cur_sym=mp_id_lookup(mp, 0,l); + if ( s>=256 ) { /* we don't want to have the string twice */ + mp_flush_string(mp, text(mp->cur_sym)); text(mp->cur_sym)=s; + }; + eq_type(mp->cur_sym)=c; + equiv(mp->cur_sym)=o; +} + + +@ Many of \MP's primitives need no |equiv|, since they are identifiable +by their |eq_type| alone. These primitives are loaded into the hash table +as follows: + +@<Put each of \MP's primitives into the hash table@>= +mp_primitive(mp, "..",path_join,0); +@:.._}{\.{..} primitive@> +mp_primitive(mp, "[",left_bracket,0); mp->eqtb[frozen_left_bracket]=mp->eqtb[mp->cur_sym]; +@:[ }{\.{[} primitive@> +mp_primitive(mp, "]",right_bracket,0); +@:] }{\.{]} primitive@> +mp_primitive(mp, "}",right_brace,0); +@:]]}{\.{\char`\}} primitive@> +mp_primitive(mp, "{",left_brace,0); +@:][}{\.{\char`\{} primitive@> +mp_primitive(mp, ":",colon,0); mp->eqtb[frozen_colon]=mp->eqtb[mp->cur_sym]; +@:: }{\.{:} primitive@> +mp_primitive(mp, "::",double_colon,0); +@::: }{\.{::} primitive@> +mp_primitive(mp, "||:",bchar_label,0); +@:::: }{\.{\char'174\char'174:} primitive@> +mp_primitive(mp, ":=",assignment,0); +@::=_}{\.{:=} primitive@> +mp_primitive(mp, ",",comma,0); +@:, }{\., primitive@> +mp_primitive(mp, ";",semicolon,0); mp->eqtb[frozen_semicolon]=mp->eqtb[mp->cur_sym]; +@:; }{\.; primitive@> +mp_primitive(mp, "\\",relax,0); +@:]]\\}{\.{\char`\\} primitive@> +@# +mp_primitive(mp, "addto",add_to_command,0); +@:add_to_}{\&{addto} primitive@> +mp_primitive(mp, "atleast",at_least,0); +@:at_least_}{\&{atleast} primitive@> +mp_primitive(mp, "begingroup",begin_group,0); mp->bg_loc=mp->cur_sym; +@:begin_group_}{\&{begingroup} primitive@> +mp_primitive(mp, "controls",controls,0); +@:controls_}{\&{controls} primitive@> +mp_primitive(mp, "curl",curl_command,0); +@:curl_}{\&{curl} primitive@> +mp_primitive(mp, "delimiters",delimiters,0); +@:delimiters_}{\&{delimiters} primitive@> +mp_primitive(mp, "endgroup",end_group,0); + mp->eqtb[frozen_end_group]=mp->eqtb[mp->cur_sym]; mp->eg_loc=mp->cur_sym; +@:endgroup_}{\&{endgroup} primitive@> +mp_primitive(mp, "everyjob",every_job_command,0); +@:every_job_}{\&{everyjob} primitive@> +mp_primitive(mp, "exitif",exit_test,0); +@:exit_if_}{\&{exitif} primitive@> +mp_primitive(mp, "expandafter",expand_after,0); +@:expand_after_}{\&{expandafter} primitive@> +mp_primitive(mp, "interim",interim_command,0); +@:interim_}{\&{interim} primitive@> +mp_primitive(mp, "let",let_command,0); +@:let_}{\&{let} primitive@> +mp_primitive(mp, "newinternal",new_internal,0); +@:new_internal_}{\&{newinternal} primitive@> +mp_primitive(mp, "of",of_token,0); +@:of_}{\&{of} primitive@> +mp_primitive(mp, "randomseed",mp_random_seed,0); +@:mp_random_seed_}{\&{randomseed} primitive@> +mp_primitive(mp, "save",save_command,0); +@:save_}{\&{save} primitive@> +mp_primitive(mp, "scantokens",scan_tokens,0); +@:scan_tokens_}{\&{scantokens} primitive@> +mp_primitive(mp, "shipout",ship_out_command,0); +@:ship_out_}{\&{shipout} primitive@> +mp_primitive(mp, "skipto",skip_to,0); +@:skip_to_}{\&{skipto} primitive@> +mp_primitive(mp, "special",special_command,0); +@:special}{\&{special} primitive@> +mp_primitive(mp, "fontmapfile",special_command,1); +@:fontmapfile}{\&{fontmapfile} primitive@> +mp_primitive(mp, "fontmapline",special_command,2); +@:fontmapline}{\&{fontmapline} primitive@> +mp_primitive(mp, "step",step_token,0); +@:step_}{\&{step} primitive@> +mp_primitive(mp, "str",str_op,0); +@:str_}{\&{str} primitive@> +mp_primitive(mp, "tension",tension,0); +@:tension_}{\&{tension} primitive@> +mp_primitive(mp, "to",to_token,0); +@:to_}{\&{to} primitive@> +mp_primitive(mp, "until",until_token,0); +@:until_}{\&{until} primitive@> +mp_primitive(mp, "within",within_token,0); +@:within_}{\&{within} primitive@> +mp_primitive(mp, "write",write_command,0); +@:write_}{\&{write} primitive@> + +@ Each primitive has a corresponding inverse, so that it is possible to +display the cryptic numeric contents of |eqtb| in symbolic form. +Every call of |primitive| in this program is therefore accompanied by some +straightforward code that forms part of the |print_cmd_mod| routine +explained below. + +@<Cases of |print_cmd_mod| for symbolic printing of primitives@>= +case add_to_command:mp_print(mp, "addto"); break; +case assignment:mp_print(mp, ":="); break; +case at_least:mp_print(mp, "atleast"); break; +case bchar_label:mp_print(mp, "||:"); break; +case begin_group:mp_print(mp, "begingroup"); break; +case colon:mp_print(mp, ":"); break; +case comma:mp_print(mp, ","); break; +case controls:mp_print(mp, "controls"); break; +case curl_command:mp_print(mp, "curl"); break; +case delimiters:mp_print(mp, "delimiters"); break; +case double_colon:mp_print(mp, "::"); break; +case end_group:mp_print(mp, "endgroup"); break; +case every_job_command:mp_print(mp, "everyjob"); break; +case exit_test:mp_print(mp, "exitif"); break; +case expand_after:mp_print(mp, "expandafter"); break; +case interim_command:mp_print(mp, "interim"); break; +case left_brace:mp_print(mp, "{"); break; +case left_bracket:mp_print(mp, "["); break; +case let_command:mp_print(mp, "let"); break; +case new_internal:mp_print(mp, "newinternal"); break; +case of_token:mp_print(mp, "of"); break; +case path_join:mp_print(mp, ".."); break; +case mp_random_seed:mp_print(mp, "randomseed"); break; +case relax:mp_print_char(mp, xord('\\')); break; +case right_brace:mp_print_char(mp, xord('}')); break; +case right_bracket:mp_print_char(mp, xord(']')); break; +case save_command:mp_print(mp, "save"); break; +case scan_tokens:mp_print(mp, "scantokens"); break; +case semicolon:mp_print_char(mp, xord(';')); break; +case ship_out_command:mp_print(mp, "shipout"); break; +case skip_to:mp_print(mp, "skipto"); break; +case special_command: if ( m==2 ) mp_print(mp, "fontmapline"); else + if ( m==1 ) mp_print(mp, "fontmapfile"); else + mp_print(mp, "special"); break; +case step_token:mp_print(mp, "step"); break; +case str_op:mp_print(mp, "str"); break; +case tension:mp_print(mp, "tension"); break; +case to_token:mp_print(mp, "to"); break; +case until_token:mp_print(mp, "until"); break; +case within_token:mp_print(mp, "within"); break; +case write_command:mp_print(mp, "write"); break; + +@ We will deal with the other primitives later, at some point in the program +where their |eq_type| and |equiv| values are more meaningful. For example, +the primitives for macro definitions will be loaded when we consider the +routines that define macros. +It is easy to find where each particular +primitive was treated by looking in the index at the end; for example, the +section where |"def"| entered |eqtb| is listed under `\&{def} primitive'. + +@* \[14] Token lists. +A \MP\ token is either symbolic or numeric or a string, or it denotes +a macro parameter or capsule; so there are five corresponding ways to encode it +@^token@> +internally: (1)~A symbolic token whose hash code is~|p| +is represented by the number |p|, in the |info| field of a single-word +node in~|mem|. (2)~A numeric token whose |scaled| value is~|v| is +represented in a two-word node of~|mem|; the |type| field is |known|, +the |name_type| field is |token|, and the |value| field holds~|v|. +The fact that this token appears in a two-word node rather than a +one-word node is, of course, clear from the node address. +(3)~A string token is also represented in a two-word node; the |type| +field is |mp_string_type|, the |name_type| field is |token|, and the +|value| field holds the corresponding |str_number|. (4)~Capsules have +|name_type=capsule|, and their |type| and |value| fields represent +arbitrary values (in ways to be explained later). (5)~Macro parameters +are like symbolic tokens in that they appear in |info| fields of +one-word nodes. The $k$th parameter is represented by |expr_base+k| if it +is of type \&{expr}, or by |suffix_base+k| if it is of type \&{suffix}, or +by |text_base+k| if it is of type \&{text}. (Here |0<=k<param_size|.) +Actual values of these parameters are kept in a separate stack, as we will +see later. The constants |expr_base|, |suffix_base|, and |text_base| are, +of course, chosen so that there will be no confusion between symbolic +tokens and parameters of various types. + +Note that +the `\\{type}' field of a node has nothing to do with ``type'' in a +printer's sense. It's curious that the same word is used in such different ways. + +@d mp_type(A) mp->mem[(A)].hh.b0 /* identifies what kind of value this is */ +@d mp_name_type(A) mp->mem[(A)].hh.b1 /* a clue to the name of this value */ +@d token_node_size 2 /* the number of words in a large token node */ +@d value_loc(A) ((A)+1) /* the word that contains the |value| field */ +@d value(A) mp->mem[value_loc((A))].cint /* the value stored in a large token node */ +@d expr_base (hash_end+1) /* code for the zeroth \&{expr} parameter */ +@d suffix_base (expr_base+mp->param_size) /* code for the zeroth \&{suffix} parameter */ +@d text_base (suffix_base+mp->param_size) /* code for the zeroth \&{text} parameter */ + +@<Check the ``constant''...@>= +if ( text_base+mp->param_size>max_halfword ) mp->bad=18; + +@ We have set aside a two word node beginning at |null| so that we can have +|value(null)=0|. We will make use of this coincidence later. + +@<Initialize table entries...@>= +mp_link(null)=null; value(null)=0; + +@ A numeric token is created by the following trivial routine. + +@c +static pointer mp_new_num_tok (MP mp,scaled v) { + pointer p; /* the new node */ + p=mp_get_node(mp, token_node_size); value(p)=v; + mp_type(p)=mp_known; mp_name_type(p)=mp_token; + return p; +} + +@ A token list is a singly linked list of nodes in |mem|, where +each node contains a token and a link. Here's a subroutine that gets rid +of a token list when it is no longer needed. + +@c static void mp_flush_token_list (MP mp,pointer p) { + pointer q; /* the node being recycled */ + while ( p!=null ) { + q=p; p=mp_link(p); + if ( q>=mp->hi_mem_min ) { + free_avail(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(q)); + break; + case unknown_types: case mp_pen_type: case mp_path_type: + case mp_picture_type: case mp_pair_type: case mp_color_type: + case mp_cmykcolor_type: case mp_transform_type: case mp_dependent: + case mp_proto_dependent: case mp_independent: + mp_recycle_value(mp,q); + break; + default: mp_confusion(mp, "token"); +@:this can't happen token}{\quad token@> + } + mp_free_node(mp, q,token_node_size); + } + } +} + +@ The procedure |show_token_list|, which prints a symbolic form of +the token list that starts at a given node |p|, illustrates these +conventions. The token list being displayed should not begin with a reference +count. However, the procedure is intended to be fairly robust, so that if the +memory links are awry or if |p| is not really a pointer to a token list, +almost nothing catastrophic can happen. + +An additional parameter |q| is also given; this parameter is either null +or it points to a node in the token list where a certain magic computation +takes place that will be explained later. (Basically, |q| is non-null when +we are printing the two-line context information at the time of an error +message; |q| marks the place corresponding to where the second line +should begin.) + +The generation will stop, and `\.{\char`\ ETC.}' will be printed, if the length +of printing exceeds a given limit~|l|; the length of printing upon entry is +assumed to be a given amount called |null_tally|. (Note that +|show_token_list| sometimes uses itself recursively to print +variable names within a capsule.) +@^recursion@> + +Unusual entries are printed in the form of all-caps tokens +preceded by a space, e.g., `\.{\char`\ BAD}'. + +@<Declarations@>= +static void mp_show_token_list (MP mp, integer p, integer q, integer l, + integer null_tally) ; + +@ @c +void mp_show_token_list (MP mp, integer p, integer q, integer l, + integer null_tally) { + quarterword class,c; /* the |char_class| of previous and new tokens */ + integer r,v; /* temporary registers */ + class=percent_class; + mp->tally=null_tally; + while ( (p!=null) && (mp->tally<l) ) { + if ( p==q ) + @<Do magic computation@>; + @<Display token |p| and set |c| to its class; + but |return| if there are problems@>; + class=c; p=mp_link(p); + } + if ( p!=null ) + mp_print(mp, " ETC."); +@.ETC@> + return; +} + +@ @<Display token |p| and set |c| to its class...@>= +c=letter_class; /* the default */ +if ( (p<0)||(p>mp->mem_end) ) { + mp_print(mp, " CLOBBERED"); return; +@.CLOBBERED@> +} +if ( p<mp->hi_mem_min ) { + @<Display two-word token@>; +} else { + r=mp_info(p); + if ( r>=expr_base ) { + @<Display a parameter token@>; + } else { + if ( r<1 ) { + if ( r==0 ) { + @<Display a collective subscript@> + } else { + mp_print(mp, " IMPOSSIBLE"); +@.IMPOSSIBLE@> + } + } else { + r=text(r); + if ( (r<0)||(r>mp->max_str_ptr) ) { + mp_print(mp, " NONEXISTENT"); +@.NONEXISTENT@> + } else { + @<Print string |r| as a symbolic token + and set |c| to its class@>; + } + } + } +} + +@ @<Display two-word token@>= +if ( mp_name_type(p)==mp_token ) { + if ( mp_type(p)==mp_known ) { + @<Display a numeric token@>; + } else if ( mp_type(p)!=mp_string_type ) { + mp_print(mp, " BAD"); +@.BAD@> + } else { + mp_print_char(mp, xord('"')); mp_print_str(mp, value(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; +} + +@ @<Display a numeric token@>= +if ( class==digit_class ) + mp_print_char(mp, xord(' ')); +v=value(p); +if ( v<0 ){ + if ( class==left_bracket_class ) + mp_print_char(mp, xord(' ')); + mp_print_char(mp, xord('[')); mp_print_scaled(mp, v); mp_print_char(mp, xord(']')); + c=right_bracket_class; +} else { + mp_print_scaled(mp, v); c=digit_class; +} + + +@ Strictly speaking, a genuine token will never have |mp_info(p)=0|. +But we will see later (in the |print_variable_name| routine) that +it is convenient to let |mp_info(p)=0| stand for `\.{[]}'. + +@<Display a collective subscript@>= +{ +if ( class==left_bracket_class ) + mp_print_char(mp, xord(' ')); +mp_print(mp, "[]"); c=right_bracket_class; +} + +@ @<Display a parameter token@>= +{ +if ( r<suffix_base ) { + mp_print(mp, "(EXPR"); r=r-(expr_base); +@.EXPR@> +} else if ( r<text_base ) { + mp_print(mp, "(SUFFIX"); r=r-(suffix_base); +@.SUFFIX@> +} else { + mp_print(mp, "(TEXT"); r=r-(text_base); +@.TEXT@> +} +mp_print_int(mp, r); mp_print_char(mp, xord(')')); c=right_paren_class; +} + + +@ @<Print string |r| as a symbolic token...@>= +{ +c=mp->char_class[mp->str_pool[mp->str_start[r]]]; +if ( c==class ) { + switch (c) { + case letter_class:mp_print_char(mp, xord('.')); break; + case isolated_classes: break; + default: mp_print_char(mp, xord(' ')); break; + } +} +mp_print_str(mp, r); +} + +@ @<Declarations@>= +static void mp_print_capsule (MP mp, pointer p); + +@ @<Declare miscellaneous procedures that were declared |forward|@>= +void mp_print_capsule (MP mp, pointer p) { + mp_print_char(mp, 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 one-word nodes at the beginning. + +The first node contains a reference count that is used to tell when the +list is no longer needed. To emphasize the fact that a reference count is +present, we shall refer to the |info| field of this special node as the +|ref_count| field. +@^reference counts@> + +The next node or nodes after the reference count serve to describe the +formal parameters. They consist of zero or more parameter tokens followed +by a code for the type of macro. + +@d ref_count mp_info + /* reference count preceding a macro definition or picture header */ +@d add_mac_ref(A) incr(ref_count((A))) /* make a new reference to a macro list */ +@d general_macro 0 /* preface to a macro defined with a parameter list */ +@d primary_macro 1 /* preface to a macro with a \&{primary} parameter */ +@d secondary_macro 2 /* preface to a macro with a \&{secondary} parameter */ +@d tertiary_macro 3 /* preface to a macro with a \&{tertiary} parameter */ +@d expr_macro 4 /* preface to a macro with an undelimited \&{expr} parameter */ +@d of_macro 5 /* preface to a macro with + undelimited `\&{expr} |x| \&{of}~|y|' parameters */ +@d suffix_macro 6 /* preface to a macro with an undelimited \&{suffix} parameter */ +@d text_macro 7 /* preface to a macro with an undelimited \&{text} parameter */ + +@c +static void mp_delete_mac_ref (MP mp,pointer p) { + /* |p| points to the reference count of a macro list that is + losing one reference */ + if ( ref_count(p)==null ) mp_flush_token_list(mp, p); + else decr(ref_count(p)); +} + +@ The following subroutine displays a macro, given a pointer to its +reference count. + +@c +static void mp_show_macro (MP mp, pointer p, integer q, integer l) { + pointer r; /* temporary storage */ + p=mp_link(p); /* bypass the reference count */ + while ( mp_info(p)>text_macro ){ + 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_info(p)) { + case general_macro:mp_print(mp, "->"); break; +@.->@> + case primary_macro: case secondary_macro: case tertiary_macro: + mp_print_char(mp, xord('<')); + mp_print_cmd_mod(mp, param_type,mp_info(p)); + mp_print(mp, ">->"); + break; + case expr_macro:mp_print(mp, "<expr>->"); break; + case of_macro:mp_print(mp, "<expr>of<primary>->"); break; + case suffix_macro:mp_print(mp, "<suffix>->"); break; + case text_macro:mp_print(mp, "<text>->"); break; + } /* there are no other cases */ + mp_show_token_list(mp, mp_link(p),q,l-mp->tally,0); +} + +@* \[15] Data structures for variables. +The variables of \MP\ programs can be simple, like `\.x', or they can +combine the structural properties of arrays and records, like `\.{x20a.b}'. +A \MP\ user assigns a type to a variable like \.{x20a.b} by saying, for +example, `\.{boolean} \.{x[]a.b}'. It's time for us to study how such +things are represented inside of the computer. + +Each variable value occupies two consecutive words, either in a two-word +node called a value node, or as a two-word subfield of a larger node. One +of those two words is called the |value| field; it is an integer, +containing either a |scaled| numeric value or the representation of some +other type of quantity. (It might also be subdivided into halfwords, in +which case it is referred to by other names instead of |value|.) The other +word is broken into subfields called |type|, |name_type|, and |link|. The +|type| field is a quarterword that specifies the variable's type, and +|name_type| is a quarterword from which \MP\ can reconstruct the +variable's name (sometimes by using the |link| field as well). Thus, only +1.25 words are actually devoted to the value itself; the other +three-quarters of a word are overhead, but they aren't wasted because they +allow \MP\ to deal with sparse arrays and to provide meaningful diagnostics. + +In this section we shall be concerned only with the structural aspects of +variables, not their values. Later parts of the program will change the +|type| and |value| fields, but we shall treat those fields as black boxes +whose contents should not be touched. + +However, if the |type| field is |mp_structured|, there is no |value| field, +and the second word is broken into two pointer fields called |attr_head| +and |subscr_head|. Those fields point to additional nodes that +contain structural information, as we shall see. + +@d subscr_head_loc(A) (A)+1 /* where |value|, |subscr_head| and |attr_head| are */ +@d attr_head(A) mp_info(subscr_head_loc((A))) /* pointer to attribute info */ +@d subscr_head(A) mp_link(subscr_head_loc((A))) /* pointer to subscript info */ +@d value_node_size 2 /* the number of words in a value node */ + +@ An attribute node is three words long. Two of these words contain |type| +and |value| fields as described above, and the third word contains +additional information: There is an |attr_loc| field, which contains the +hash address of the token that names this attribute; and there's also a +|parent| field, which points to the value node of |mp_structured| type at the +next higher level (i.e., at the level to which this attribute is +subsidiary). The |name_type| in an attribute node is `|attr|'. The +|link| field points to the next attribute with the same parent; these are +arranged in increasing order, so that |attr_loc(mp_link(p))>attr_loc(p)|. The +final attribute node links to the constant |end_attr|, whose |attr_loc| +field is greater than any legal hash address. The |attr_head| in the +parent points to a node whose |name_type| is |mp_structured_root|; this +node represents the null attribute, i.e., the variable that is relevant +when no attributes are attached to the parent. The |attr_head| node +has the fields of either +a value node, a subscript node, or an attribute node, depending on what +the parent would be if it were not structured; but the subscript and +attribute fields are ignored, so it effectively contains only the data of +a value node. The |link| field in this special node points to an attribute +node whose |attr_loc| field is zero; the latter node represents a collective +subscript `\.{[]}' attached to the parent, and its |link| field points to +the first non-special attribute node (or to |end_attr| if there are none). + +A subscript node likewise occupies three words, with |type| and |value| fields +plus extra information; its |name_type| is |subscr|. In this case the +third word is called the |subscript| field, which is a |scaled| integer. +The |link| field points to the subscript node with the next larger +subscript, if any; otherwise the |link| points to the attribute node +for collective subscripts at this level. We have seen that the latter node +contains an upward pointer, so that the parent can be deduced. + +The |name_type| in a parent-less value node is |root|, and the |link| +is the hash address of the token that names this value. + +In other words, variables have a hierarchical structure that includes +enough threads running around so that the program is able to move easily +between siblings, parents, and children. An example should be helpful: +(The reader is advised to draw a picture while reading the following +description, since that will help to firm up the ideas.) +Suppose that `\.x' and `\.{x.a}' and `\.{x[]b}' and `\.{x5}' +and `\.{x20b}' have been mentioned in a user's program, where +\.{x[]b} has been declared to be of \&{boolean} type. Let |h(x)|, |h(a)|, +and |h(b)| be the hash addresses of \.x, \.a, and~\.b. Then +|eq_type(h(x))=name| and |equiv(h(x))=p|, where |p|~is a two-word value +node with |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|, +|attr_loc(q1)=collective_subscript=0|, |parent(q1)=p|, +|type(q1)=mp_structured|, |attr_head(q1)=qq|, and |subscr_head(q1)=qq1|; +|qq| is a three-word ``attribute-as-value'' node with |type(qq)=numeric_type| +(assuming that \.{x5} is numeric, because |qq| represents `\.{x[]}' +with no further attributes), |mp_name_type(qq)=structured_root|, +|attr_loc(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|, |attr_loc(qq1)=collective_subscript|, +|parent(qq1)=q1|, and |mp_link(qq1)=qq2|. Since |qq2| represents +`\.{x[]b}', |type(qq2)=mp_unknown_boolean|; also |attr_loc(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. + +@d attr_loc_loc(A) ((A)+2) /* where the |attr_loc| and |parent| fields are */ +@d attr_loc(A) mp_info(attr_loc_loc((A))) /* hash address of this attribute */ +@d parent(A) mp_link(attr_loc_loc((A))) /* pointer to |mp_structured| variable */ +@d subscript_loc(A) ((A)+2) /* where the |subscript| field lives */ +@d subscript(A) mp->mem[subscript_loc((A))].sc /* subscript of this variable */ +@d attr_node_size 3 /* the number of words in an attribute node */ +@d subscr_node_size 3 /* the number of words in a subscript node */ +@d collective_subscript 0 /* code for the attribute `\.{[]}' */ + +@<Initialize table...@>= +attr_loc(end_attr)=hash_end+1; parent(end_attr)=null; + +@ Variables of type \&{pair} will have values that point to four-word +nodes containing two numeric values. The first of these values has +|name_type=mp_x_part_sector| and the second has |name_type=mp_y_part_sector|; +the |link| in the first points back to the node whose |value| points +to this four-word node. + +Variables of type \&{transform} are similar, but in this case their +|value| points to a 12-word node containing six values, identified by +|x_part_sector|, |y_part_sector|, |mp_xx_part_sector|, |mp_xy_part_sector|, +|mp_yx_part_sector|, and |mp_yy_part_sector|. +Finally, variables of type \&{color} have 3~values in 6~words +identified by |mp_red_part_sector|, |mp_green_part_sector|, and |mp_blue_part_sector|. + +When an entire structured variable is saved, the |root| indication +is temporarily replaced by |saved_root|. + +Some variables have no name; they just are used for temporary storage +while expressions are being evaluated. We call them {\sl capsules}. + +@d x_part_loc(A) (A) /* where the \&{xpart} is found in a pair or transform node */ +@d y_part_loc(A) ((A)+2) /* where the \&{ypart} is found in a pair or transform node */ +@d xx_part_loc(A) ((A)+4) /* where the \&{xxpart} is found in a transform node */ +@d xy_part_loc(A) ((A)+6) /* where the \&{xypart} is found in a transform node */ +@d yx_part_loc(A) ((A)+8) /* where the \&{yxpart} is found in a transform node */ +@d yy_part_loc(A) ((A)+10) /* where the \&{yypart} is found in a transform node */ +@d red_part_loc(A) (A) /* where the \&{redpart} is found in a color node */ +@d green_part_loc(A) ((A)+2) /* where the \&{greenpart} is found in a color node */ +@d blue_part_loc(A) ((A)+4) /* where the \&{bluepart} is found in a color node */ +@d cyan_part_loc(A) (A) /* where the \&{cyanpart} is found in a color node */ +@d magenta_part_loc(A) ((A)+2) /* where the \&{magentapart} is found in a color node */ +@d yellow_part_loc(A) ((A)+4) /* where the \&{yellowpart} is found in a color node */ +@d black_part_loc(A) ((A)+6) /* where the \&{blackpart} is found in a color node */ +@d grey_part_loc(A) (A) /* where the \&{greypart} is found in a color node */ +@# +@d pair_node_size 4 /* the number of words in a pair node */ +@d transform_node_size 12 /* the number of words in a transform node */ +@d color_node_size 6 /* the number of words in a color node */ +@d cmykcolor_node_size 8 /* the number of words in a color node */ + +@<Glob...@>= +quarterword big_node_size[mp_pair_type+1]; +quarterword sector0[mp_pair_type+1]; +quarterword sector_offset[mp_black_part_sector+1]; + +@ The |sector0| array gives for each big node type, |name_type| values +for its first subfield; the |sector_offset| array gives for each +|name_type| value, the offset from the first subfield in words; +and the |big_node_size| array gives the size in words for each type of +big node. + +@<Set init...@>= +mp->big_node_size[mp_transform_type]=transform_node_size; +mp->big_node_size[mp_pair_type]=pair_node_size; +mp->big_node_size[mp_color_type]=color_node_size; +mp->big_node_size[mp_cmykcolor_type]=cmykcolor_node_size; +mp->sector0[mp_transform_type]=mp_x_part_sector; +mp->sector0[mp_pair_type]=mp_x_part_sector; +mp->sector0[mp_color_type]=mp_red_part_sector; +mp->sector0[mp_cmykcolor_type]=mp_cyan_part_sector; +for (k=mp_x_part_sector;k<= mp_yy_part_sector;k++ ) { + mp->sector_offset[k]=2*(k-mp_x_part_sector); +} +for (k=mp_red_part_sector;k<= mp_blue_part_sector ; k++) { + mp->sector_offset[k]=2*(k-mp_red_part_sector); +} +for (k=mp_cyan_part_sector;k<= mp_black_part_sector;k++ ) { + mp->sector_offset[k]=2*(k-mp_cyan_part_sector); +} + +@ If |type(p)=mp_pair_type| or |mp_transform_type| and if |value(p)=null|, the +procedure call |init_big_node(p)| will allocate a pair or transform node +for~|p|. The individual parts of such nodes are initially of type +|mp_independent|. + +@c +static void mp_init_big_node (MP mp,pointer p) { + pointer q; /* the new node */ + quarterword s; /* its size */ + s=mp->big_node_size[mp_type(p)]; q=mp_get_node(mp, s); + do { + s=s-2; + @<Make variable |q+s| newly independent@>; + mp_name_type(q+s)=halfp(s)+mp->sector0[mp_type(p)]; + mp_link(q+s)=null; + } while (s!=0); + mp_link(q)=p; value(p)=q; +} + +@ The |id_transform| function creates a capsule for the +identity transformation. + +@c +static pointer mp_id_transform (MP mp) { + pointer p,q,r; /* list manipulation registers */ + p=mp_get_node(mp, value_node_size); mp_type(p)=mp_transform_type; + mp_name_type(p)=mp_capsule; value(p)=null; mp_init_big_node(mp, p); q=value(p); + r=q+transform_node_size; + do { + r=r-2; + mp_type(r)=mp_known; value(r)=0; + } while (r!=q); + value(xx_part_loc(q))=unity; + value(yy_part_loc(q))=unity; + return p; +} + +@ Tokens are of type |tag_token| when they first appear, but they point +to |null| until they are first used as the root of a variable. +The following subroutine establishes the root node on such grand occasions. + +@c +static void mp_new_root (MP mp,pointer x) { + pointer p; /* the new node */ + p=mp_get_node(mp, value_node_size); mp_type(p)=undefined; mp_name_type(p)=mp_root; + mp_link(p)=x; equiv(x)=p; +} + +@ These conventions for variable representation are illustrated by the +|print_variable_name| routine, which displays the full name of a +variable given only a pointer to its two-word value packet. + +@<Declarations@>= +static void mp_print_variable_name (MP mp, pointer p); + +@ @c +void mp_print_variable_name (MP mp, pointer p) { + pointer q; /* a token list that will name the variable's suffix */ + pointer r; /* temporary for token list creation */ + while ( mp_name_type(p)>=mp_x_part_sector ) { + @<Preface the output with a part specifier; |return| in the + case of a capsule@>; + } + 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@>; + } + r=mp_get_avail(mp); mp_info(r)=mp_link(p); mp_link(r)=q; + if ( mp_name_type(p)==mp_saved_root ) mp_print(mp, "(SAVED)"); +@.SAVED@> + mp_show_token_list(mp, r,null,el_gordo,mp->tally); + mp_flush_token_list(mp, r); +} + +@ @<Ascend one level, pushing a token onto list |q|...@>= +{ + if ( 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"); +@:this can't happen var}{\quad var@> + r=mp_get_avail(mp); mp_info(r)=attr_loc(p); + } + mp_link(r)=q; q=r; +FOUND: + p=parent(p); +} + +@ @<Preface the output with a part specifier...@>= +{ switch (mp_name_type(p)) { + case mp_x_part_sector: mp_print_char(mp, xord('x')); break; + case mp_y_part_sector: mp_print_char(mp, xord('y')); break; + case mp_xx_part_sector: mp_print(mp, "xx"); break; + case mp_xy_part_sector: mp_print(mp, "xy"); break; + case mp_yx_part_sector: mp_print(mp, "yx"); break; + case mp_yy_part_sector: mp_print(mp, "yy"); break; + case mp_red_part_sector: mp_print(mp, "red"); break; + case mp_green_part_sector: mp_print(mp, "green"); break; + case mp_blue_part_sector: mp_print(mp, "blue"); break; + case mp_cyan_part_sector: mp_print(mp, "cyan"); break; + case mp_magenta_part_sector: mp_print(mp, "magenta"); break; + case mp_yellow_part_sector: mp_print(mp, "yellow"); break; + case mp_black_part_sector: mp_print(mp, "black"); break; + case mp_grey_part_sector: mp_print(mp, "grey"); break; + case mp_capsule: + mp_print(mp, "%CAPSULE"); mp_print_int(mp, p-null); return; + break; +@.CAPSULE@> + } /* there are no other cases */ + mp_print(mp, "part "); + p=mp_link(p-mp->sector_offset[mp_name_type(p)]); +} + +@ The |interesting| function returns |true| if a given variable is not +in a capsule, or if the user wants to trace capsules. + +@c +static boolean mp_interesting (MP mp,pointer p) { + quarterword t; /* a |name_type| */ + if ( mp->internal[mp_tracing_capsules]>0 ) { + return true; + } else { + t=mp_name_type(p); + if ( t>=mp_x_part_sector ) if ( t!=mp_capsule ) + t=mp_name_type(mp_link(p-mp->sector_offset[t])); + return (t!=mp_capsule); + } +} + +@ Now here is a subroutine that converts an unstructured type into an +equivalent structured type, by inserting a |mp_structured| node that is +capable of growing. This operation is done only when |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 pointer mp_new_structure (MP mp,pointer p) { + pointer q,r=0; /* list manipulation registers */ + switch (mp_name_type(p)) { + case mp_root: + q=mp_link(p); r=mp_get_node(mp, value_node_size); equiv(q)=r; + break; + case mp_subscr: + @<Link a new subscript node |r| in place of node |p|@>; + break; + case mp_attr: + @<Link a new attribute node |r| in place of node |p|@>; + break; + default: + mp_confusion(mp, "struct"); +@:this can't happen struct}{\quad struct@> + break; + } + mp_link(r)=mp_link(p); mp_type(r)=mp_structured; mp_name_type(r)=mp_name_type(p); + attr_head(r)=p; mp_name_type(p)=mp_structured_root; + q=mp_get_node(mp, attr_node_size); mp_link(p)=q; subscr_head(r)=q; + parent(q)=r; mp_type(q)=undefined; mp_name_type(q)=mp_attr; mp_link(q)=end_attr; + attr_loc(q)=collective_subscript; + return r; +} + +@ @<Link a new subscript node |r| in place of node |p|@>= +{ + q=p; + do { + q=mp_link(q); + } while (mp_name_type(q)!=mp_attr); + q=parent(q); r=subscr_head_loc(q); /* |mp_link(r)=subscr_head(q)| */ + do { + q=r; r=mp_link(r); + } while (r!=p); + r=mp_get_node(mp, subscr_node_size); + mp_link(q)=r; subscript(r)=subscript(p); +} + +@ If the attribute is |collective_subscript|, there are two pointers to +node~|p|, so we must change both of them. + +@<Link a new attribute node |r| in place of node |p|@>= +{ + q=parent(p); r=attr_head(q); + do { + q=r; r=mp_link(r); + } while (r!=p); + r=mp_get_node(mp, attr_node_size); mp_link(q)=r; + mp->mem[attr_loc_loc(r)]=mp->mem[attr_loc_loc(p)]; /* copy |attr_loc| and |parent| */ + if ( attr_loc(p)==collective_subscript ) { + q=subscr_head_loc(parent(p)); + while ( mp_link(q)!=p ) q=mp_link(q); + mp_link(q)=r; + } +} + +@ The |find_variable| routine is given a pointer~|t| to a nonempty token +list of suffixes; it returns a pointer to the corresponding two-word +value. For example, if |t| points to token \.x followed by a numeric +token containing the value~7, |find_variable| finds where the value of +\.{x7} is stored in memory. This may seem a simple task, and it +usually is, except when \.{x7} has never been referenced before. +Indeed, \.x may never have even been subscripted before; complexities +arise with respect to updating the collective subscript information. + +If a macro type is detected anywhere along path~|t|, or if the first +item on |t| isn't a |tag_token|, the value |null| is returned. +Otherwise |p| will be a non-null pointer to a node such that +|undefined<type(p)<mp_structured|. + +@d abort_find { return null; } + +@c +static pointer mp_find_variable (MP mp,pointer t) { + pointer p,q,r,s; /* nodes in the ``value'' line */ + pointer pp,qq,rr,ss; /* nodes in the ``collective'' line */ + integer n; /* subscript or attribute */ + memory_word save_word; /* temporary storage for a word of |mem| */ +@^inner loop@> + p=mp_info(t); t=mp_link(t); + if ( (eq_type(p) % outer_tag) != tag_token ) abort_find; + if ( equiv(p)==null ) mp_new_root(mp, p); + p=equiv(p); pp=p; + while ( t!=null ) { + @<Make sure that both nodes |p| and |pp| are of |mp_structured| type@>; + if ( t<mp->hi_mem_min ) { + @<Descend one level for the subscript |value(t)|@> + } else { + @<Descend one level for the attribute |mp_info(t)|@>; + } + t=mp_link(t); + } + if ( mp_type(pp)>=mp_structured ) { + if ( mp_type(pp)==mp_structured ) pp=attr_head(pp); else abort_find; + } + if ( mp_type(p)==mp_structured ) p=attr_head(p); + if ( mp_type(p)==undefined ) { + if ( mp_type(pp)==undefined ) { mp_type(pp)=mp_numeric_type; value(pp)=null; }; + mp_type(p)=mp_type(pp); value(p)=null; + }; + return p; +} + +@ Although |pp| and |p| begin together, they diverge when a subscript occurs; +|pp|~stays in the collective line while |p|~goes through actual subscript +values. + +@<Make sure that both nodes |p| and |pp|...@>= +if ( mp_type(pp)!=mp_structured ) { + if ( mp_type(pp)>mp_structured ) abort_find; + ss=mp_new_structure(mp, pp); + if ( p==pp ) p=ss; + pp=ss; +}; /* now |type(pp)=mp_structured| */ +if ( mp_type(p)!=mp_structured ) /* it cannot be |>mp_structured| */ + p=mp_new_structure(mp, p) /* now |type(p)=mp_structured| */ + +@ We want this part of the program to be reasonably fast, in case there are +@^inner loop@> +lots of subscripts at the same level of the data structure. Therefore +we store an ``infinite'' value in the word that appears at the end of the +subscript list, even though that word isn't part of a subscript node. + +@<Descend one level for the subscript |value(t)|@>= +{ + n=value(t); + pp=mp_link(attr_head(pp)); /* now |attr_loc(pp)=collective_subscript| */ + q=mp_link(attr_head(p)); save_word=mp->mem[subscript_loc(q)]; + subscript(q)=el_gordo; s=subscr_head_loc(p); /* |mp_link(s)=subscr_head(p)| */ + do { + r=s; s=mp_link(s); + } while (n>subscript(s)); + if ( n==subscript(s) ) { + p=s; + } else { + p=mp_get_node(mp, subscr_node_size); mp_link(r)=p; mp_link(p)=s; + subscript(p)=n; mp_name_type(p)=mp_subscr; mp_type(p)=undefined; + } + mp->mem[subscript_loc(q)]=save_word; +} + +@ @<Descend one level for the attribute |mp_info(t)|@>= +{ + n=mp_info(t); + ss=attr_head(pp); + do { + rr=ss; ss=mp_link(ss); + } while (n>attr_loc(ss)); + if ( n<attr_loc(ss) ) { + qq=mp_get_node(mp, attr_node_size); mp_link(rr)=qq; mp_link(qq)=ss; + attr_loc(qq)=n; mp_name_type(qq)=mp_attr; mp_type(qq)=undefined; + parent(qq)=pp; ss=qq; + } + if ( p==pp ) { + p=ss; pp=ss; + } else { + pp=ss; s=attr_head(p); + do { + r=s; s=mp_link(s); + } while (n>attr_loc(s)); + if ( n==attr_loc(s) ) { + p=s; + } else { + q=mp_get_node(mp, attr_node_size); mp_link(r)=q; mp_link(q)=s; + attr_loc(q)=n; mp_name_type(q)=mp_attr; mp_type(q)=undefined; + parent(q)=p; p=q; + } + } +} + +@ Variables lose their former values when they appear in a type declaration, +or when they are defined to be macros or \&{let} equal to something else. +A subroutine will be defined later that recycles the storage associated +with any particular |type| or |value|; our goal now is to study a higher +level process called |flush_variable|, which selectively frees parts of a +variable structure. + +This routine has some complexity because of examples such as +`\hbox{\tt numeric x[]a[]b}' +which recycles all variables of the form \.{x[i]a[j]b} (and no others), while +`\hbox{\tt vardef x[]a[]=...}' +discards all variables of the form \.{x[i]a[j]} followed by an arbitrary +suffix, except for the collective node \.{x[]a[]} itself. The obvious way +to handle such examples is to use recursion; so that's what we~do. +@^recursion@> + +Parameter |p| points to the root information of the variable; +parameter |t| points to a list of one-word nodes that represent +suffixes, with |info=collective_subscript| for subscripts. + +@<Declarations@>= +static void mp_flush_cur_exp (MP mp,scaled v) ; + +@ @c +static void mp_flush_variable (MP mp,pointer p, pointer t, boolean discard_suffixes) { + pointer q,r; /* list manipulation */ + halfword n; /* attribute to match */ + while ( t!=null ) { + if ( mp_type(p)!=mp_structured ) return; + n=mp_info(t); t=mp_link(t); + if ( n==collective_subscript ) { + r=subscr_head_loc(p); q=mp_link(r); /* |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 { mp_link(r)=mp_link(q); mp_free_node(mp, q,subscr_node_size); } + } else { + r=q; + } + q=mp_link(r); + } + } + p=attr_head(p); + do { + r=p; p=mp_link(p); + } while (attr_loc(p)<n); + if ( attr_loc(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, pointer p); + +@ @c +void mp_flush_below_variable (MP mp,pointer p) { + pointer q,r; /* list manipulation registers */ + 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_node(mp, r,subscr_node_size); + } + r=attr_head(p); q=mp_link(r); mp_recycle_value(mp, r); + if ( mp_name_type(p)<=mp_saved_root ) mp_free_node(mp, r,value_node_size); + else mp_free_node(mp, r,subscr_node_size); + /* we assume that |subscr_node_size=attr_node_size| */ + do { + mp_flush_below_variable(mp, q); r=q; q=mp_link(q); mp_free_node(mp, r,attr_node_size); + } while (q!=end_attr); + mp_type(p)=undefined; + } +} + +@ Just before assigning a new value to a variable, we will recycle the +old value and make the old value undefined. The |und_type| routine +determines what type of undefined value should be given, based on +the current type before recycling. + +@c +static quarterword mp_und_type (MP mp,pointer p) { + switch (mp_type(p)) { + case undefined: case mp_vacuous: + return undefined; + case mp_boolean_type: case mp_unknown_boolean: + return mp_unknown_boolean; + case mp_string_type: case mp_unknown_string: + return mp_unknown_string; + case mp_pen_type: case mp_unknown_pen: + return mp_unknown_pen; + case mp_path_type: case mp_unknown_path: + return mp_unknown_path; + case mp_picture_type: case mp_unknown_picture: + return mp_unknown_picture; + case mp_transform_type: case mp_color_type: case mp_cmykcolor_type: + case mp_pair_type: case mp_numeric_type: + return mp_type(p); + case mp_known: case mp_dependent: case mp_proto_dependent: case mp_independent: + return mp_numeric_type; + } /* there are no other cases */ + return 0; +} + +@ The |clear_symbol| routine is used when we want to redefine the equivalent +of a symbolic token. It must remove any variable structure or macro +definition that is currently attached to that symbol. If the |saving| +parameter is true, a subsidiary structure is saved instead of destroyed. + +@c +static void mp_clear_symbol (MP mp,pointer p, boolean saving) { + pointer q; /* |equiv(p)| */ + q=equiv(p); + switch (eq_type(p) % outer_tag) { + case defined_macro: + case secondary_primary_macro: + case tertiary_secondary_macro: + case expression_tertiary_macro: + if ( ! saving ) mp_delete_mac_ref(mp, q); + break; + case tag_token: + if ( q!=null ) { + if ( saving ) { + mp_name_type(q)=mp_saved_root; + } else { + mp_flush_below_variable(mp, q); + mp_free_node(mp,q,value_node_size); + } + } + break; + default: + break; + } + mp->eqtb[p]=mp->eqtb[frozen_undefined]; +} + +@* \[16] Saving and restoring equivalents. +The nested structure given by \&{begingroup} and \&{endgroup} +allows |eqtb| entries to be saved and restored, so that temporary changes +can be made without difficulty. When the user requests a current value to +be saved, \MP\ puts that value into its ``save stack.'' An appearance of +\&{endgroup} ultimately causes the old values to be removed from the save +stack and put back in their former places. + +The save stack is a linked list containing three kinds of entries, +distinguished by their |info| fields. If |p| points to a saved item, +then + +\smallskip\hang +|mp_info(p)=0| stands for a group boundary; each \&{begingroup} contributes +such an item to the save stack and each \&{endgroup} cuts back the stack +until the most recent such entry has been removed. + +\smallskip\hang +|mp_info(p)=q|, where |1<=q<=hash_end|, means that |mem[p+1]| holds the former +contents of |eqtb[q]|. Such save stack entries are generated by \&{save} +commands. + +\smallskip\hang +|mp_info(p)=hash_end+q|, where |q>0|, means that |value(p)| is a |scaled| +integer to be restored to internal parameter number~|q|. Such entries +are generated by \&{interim} commands. + +\smallskip\noindent +The global variable |save_ptr| points to the top item on the save stack. + +@d save_node_size 2 /* number of words per non-boundary save-stack node */ +@d saved_equiv(A) mp->mem[(A)+1].hh /* where an |eqtb| entry gets saved */ +@d save_boundary_item(A) { (A)=mp_get_avail(mp); mp_info((A))=0; + mp_link((A))=mp->save_ptr; mp->save_ptr=(A); + } + +@<Glob...@>= +pointer save_ptr; /* the most recently saved item */ + +@ @<Set init...@>=mp->save_ptr=null; + +@ The |save_variable| routine is given a hash address |q|; it salts this +address in the save stack, together with its current equivalent, +then makes token~|q| behave as though it were brand new. + +Nothing is stacked when |save_ptr=null|, however; there's no way to remove +things from the stack when the program is not inside a group, so there's +no point in wasting the space. + +@c +static void mp_save_variable (MP mp,pointer q) { + pointer p; /* temporary register */ + if ( mp->save_ptr!=null ){ + p=mp_get_node(mp, save_node_size); mp_info(p)=q; mp_link(p)=mp->save_ptr; + saved_equiv(p)=mp->eqtb[q]; mp->save_ptr=p; + } + mp_clear_symbol(mp, q,(mp->save_ptr!=null)); +} + +@ Similarly, |save_internal| is given the location |q| of an internal +quantity like |mp_tracing_pens|. It creates a save stack entry of the +third kind. + +@c +static void mp_save_internal (MP mp,halfword q) { + pointer p; /* new item for the save stack */ + if ( mp->save_ptr!=null ){ + p=mp_get_node(mp, save_node_size); mp_info(p)=hash_end+q; + mp_link(p)=mp->save_ptr; value(p)=mp->internal[q]; mp->save_ptr=p; + } +} + +@ At the end of a group, the |unsave| routine restores all of the saved +equivalents in reverse order. This routine will be called only when there +is at least one boundary item on the save stack. + +@c +static void mp_unsave (MP mp) { + pointer q; /* index to saved item */ + pointer p; /* temporary register */ + while ( mp_info(mp->save_ptr)!=0 ) { + q=mp_info(mp->save_ptr); + if ( q>hash_end ) { + if ( mp->internal[mp_tracing_restores]>0 ) { + mp_begin_diagnostic(mp); mp_print_nl(mp, "{restoring "); + mp_print(mp, mp->int_name[q-(hash_end)]); mp_print_char(mp, xord('=')); + mp_print_scaled(mp, value(mp->save_ptr)); mp_print_char(mp, xord('}')); + mp_end_diagnostic(mp, false); + } + mp->internal[q-(hash_end)]=value(mp->save_ptr); + } else { + if ( mp->internal[mp_tracing_restores]>0 ) { + mp_begin_diagnostic(mp); mp_print_nl(mp, "{restoring "); + mp_print_text(q); mp_print_char(mp, xord('}')); + mp_end_diagnostic(mp, false); + } + mp_clear_symbol(mp, q,false); + mp->eqtb[q]=saved_equiv(mp->save_ptr); + if ( eq_type(q) % outer_tag==tag_token ) { + p=equiv(q); + if ( p!=null ) mp_name_type(p)=mp_root; + } + } + p=mp_link(mp->save_ptr); + mp_free_node(mp, mp->save_ptr,save_node_size); mp->save_ptr=p; + } + p=mp_link(mp->save_ptr); free_avail(mp->save_ptr); mp->save_ptr=p; +} + +@* \[17] Data structures for paths. +When a \MP\ user specifies a path, \MP\ will create a list of knots +and control points for the associated cubic spline curves. If the +knots are $z_0$, $z_1$, \dots, $z_n$, there are control points +$z_k^+$ and $z_{k+1}^-$ such that the cubic splines between knots +$z_k$ and $z_{k+1}$ are defined by B\'ezier's formula +@:Bezier}{B\'ezier, Pierre Etienne@> +$$\eqalign{z(t)&=B(z_k,z_k^+,z_{k+1}^-,z_{k+1};t)\cr +&=(1-t)^3z_k+3(1-t)^2tz_k^++3(1-t)t^2z_{k+1}^-+t^3z_{k+1}\cr}$$ +for |0<=t<=1|. + +There is a 8-word node for each knot $z_k$, containing one word of +control information and six words for the |x| and |y| coordinates of +$z_k^-$ and $z_k$ and~$z_k^+$. The control information appears in the +|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_left_type(A) mp->mem[(A)].hh.b0 /* characterizes the path entering this knot */ +@d mp_right_type(A) mp->mem[(A)].hh.b1 /* characterizes the path leaving this knot */ +@d mp_x_coord(A) mp->mem[(A)+1].sc /* the |x| coordinate of this knot */ +@d mp_y_coord(A) mp->mem[(A)+2].sc /* the |y| coordinate of this knot */ +@d mp_left_x(A) mp->mem[(A)+3].sc /* the |x| coordinate of previous control point */ +@d mp_left_y(A) mp->mem[(A)+4].sc /* the |y| coordinate of previous control point */ +@d mp_right_x(A) mp->mem[(A)+5].sc /* the |x| coordinate of next control point */ +@d mp_right_y(A) mp->mem[(A)+6].sc /* the |y| coordinate of next control point */ +@d x_loc(A) ((A)+1) /* where the |x| coordinate is stored in a knot */ +@d y_loc(A) ((A)+2) /* where the |y| coordinate is stored in a knot */ +@d knot_coord(A) mp->mem[(A)].sc /* |x| or |y| coordinate given |x_loc| or |y_loc| */ +@d left_coord(A) mp->mem[(A)+2].sc + /* coordinate of previous control point given |x_loc| or |y_loc| */ +@d right_coord(A) mp->mem[(A)+4].sc + /* coordinate of next control point given |x_loc| or |y_loc| */ +@d knot_node_size 8 /* number of words in a knot node */ + +@(mplib.h@>= +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&|mp_x_coord,mp_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 mp_left_x /* curl information when entering this knot */ +@d left_given mp_left_x /* given direction when entering this knot */ +@d left_tension mp_left_y /* tension information when entering this knot */ +@d right_curl mp_right_x /* curl information when leaving this knot */ +@d right_given mp_right_x /* given direction when leaving this knot */ +@d right_tension mp_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) mp->mem[(A)+7].hh.b0 /* 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,pointer h); + +@ @c +void mp_pr_path (MP mp,pointer h) { + pointer p,q; /* for list traversal */ + p=h; + do { + q=mp_link(p); + if ( (p==null)||(q==null) ) { + mp_print_nl(mp, "???"); return; /* this won't happen */ +@.???@> + } + @<Print information for adjacent knots |p| and |q|@>; + DONE1: + p=q; + if ( (p!=h)||(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, mp_x_coord(p),mp_y_coord(p)); +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 ( (right_tension(p)!=unity)||(left_tension(q)!=unity) ) { + @<Print tension between |p| and |q|@>; +} + +@ Since |n_sin_cos| produces |fraction| results, which we will print as if they +were |scaled|, the magnitude of a |given| direction vector will be~4096. + +@<Print two dots...@>= +{ + mp_print_nl(mp, " .."); + if ( mp_left_type(p)==mp_given ) { + mp_n_sin_cos(mp, left_given(p)); mp_print_char(mp, xord('{')); + mp_print_scaled(mp, mp->n_cos); mp_print_char(mp, xord(',')); + mp_print_scaled(mp, mp->n_sin); mp_print_char(mp, xord('}')); + } else if ( mp_left_type(p)==mp_curl ){ + mp_print(mp, "{curl "); + mp_print_scaled(mp, left_curl(p)); mp_print_char(mp, xord('}')); + } +} + +@ @<Print tension between |p| and |q|@>= +{ + mp_print(mp, "..tension "); + if ( right_tension(p)<0 ) mp_print(mp, "atleast"); + mp_print_scaled(mp, abs(right_tension(p))); + if ( right_tension(p)!=left_tension(q) ){ + mp_print(mp, " and "); + if ( left_tension(q)<0 ) mp_print(mp, "atleast"); + mp_print_scaled(mp, abs(left_tension(q))); + } +} + +@ @<Print control points between |p| and |q|, then |goto done1|@>= +{ + mp_print(mp, "..controls "); + mp_print_two(mp, mp_right_x(p),mp_right_y(p)); + mp_print(mp, " and "); + if ( mp_left_type(q)!=mp_explicit ) { + mp_print(mp, "??"); /* can't happen */ +@.??@> + } else { + mp_print_two(mp, mp_left_x(q),mp_left_y(q)); + } + 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 "); mp_print_scaled(mp, right_curl(p)); + } else { + mp_n_sin_cos(mp, right_given(p)); mp_print_char(mp, xord('{')); + mp_print_scaled(mp, mp->n_cos); mp_print_char(mp, xord(',')); + mp_print_scaled(mp, mp->n_sin); + } + 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,pointer h, const char *s, boolean nuline) ; + +@ @c +void mp_print_path (MP mp,pointer h, const char *s, boolean nuline) { + mp_print_diagnostic(mp, "Path", s, nuline); mp_print_ln(mp); +@.Path at line...@> + mp_pr_path(mp, h); + mp_end_diagnostic(mp, true); +} + +@ If we want to duplicate a knot node, we can say |copy_knot|: + +@c +static pointer mp_copy_knot (MP mp,pointer p) { + pointer q; /* the copy */ + int k; /* runs through the words of a knot node */ + q=mp_get_node(mp, knot_node_size); + for (k=0;k<knot_node_size;k++) { + mp->mem[q+k]=mp->mem[p+k]; + } + mp_originator(q)=mp_originator(p); + return q; +} + +@ The |copy_path| routine makes a clone of a given path. + +@c +static pointer mp_copy_path (MP mp, pointer p) { + pointer q,pp,qq; /* for list manipulation */ + q=mp_copy_knot(mp, p); + qq=q; pp=mp_link(p); + while ( pp!=p ) { + mp_link(qq)=mp_copy_knot(mp, pp); + qq=mp_link(qq); + pp=mp_link(pp); + } + mp_link(qq)=q; + return q; +} + + +@ Just before |ship_out|, knot lists are exported for printing. + +The |gr_XXXX| macros are defined in |mppsout.h|. + +@c +static mp_knot *mp_export_knot (MP mp,pointer p) { + mp_knot *q; /* the copy */ + if (p==null) + return NULL; + q = xmalloc(1, sizeof (mp_knot)); + memset(q,0,sizeof (mp_knot)); + gr_left_type(q) = (unsigned short)mp_left_type(p); + gr_right_type(q) = (unsigned short)mp_right_type(p); + gr_x_coord(q) = mp_x_coord(p); + gr_y_coord(q) = mp_y_coord(p); + gr_left_x(q) = mp_left_x(p); + gr_left_y(q) = mp_left_y(p); + gr_right_x(q) = mp_right_x(p); + gr_right_y(q) = mp_right_y(p); + gr_originator(q) = (unsigned char)mp_originator(p); + return q; +} + +@ The |export_knot_list| routine therefore also makes a clone +of a given path. + +@c +static mp_knot *mp_export_knot_list (MP mp, pointer p) { + mp_knot *q, *qq; /* for list manipulation */ + pointer pp; /* for list manipulation */ + if (p==null) + return NULL; + q=mp_export_knot(mp, p); + qq=q; pp=mp_link(p); + while ( pp!=p ) { + gr_next_knot(qq)=mp_export_knot(mp, pp); + qq=gr_next_knot(qq); + pp=mp_link(pp); + } + gr_next_knot(qq)=q; + return q; +} + + +@ Similarly, there's a way to copy the {\sl reverse\/} of a path. This procedure +returns a pointer to the first node of the copy, if the path is a cycle, +but to the final node of a non-cyclic copy. The global +variable |path_tail| will point to the final node of the original path; +this trick makes it easier to implement `\&{doublepath}'. + +All node types are assumed to be |endpoint| or |explicit| only. + +@c +static pointer mp_htap_ypoc (MP mp,pointer p) { + pointer q,pp,qq,rr; /* for list manipulation */ + q=mp_get_node(mp, knot_node_size); /* this will correspond to |p| */ + qq=q; pp=p; + while (1) { + mp_right_type(qq)=mp_left_type(pp); mp_left_type(qq)=mp_right_type(pp); + mp_x_coord(qq)=mp_x_coord(pp); mp_y_coord(qq)=mp_y_coord(pp); + mp_right_x(qq)=mp_left_x(pp); mp_right_y(qq)=mp_left_y(pp); + mp_left_x(qq)=mp_right_x(pp); mp_left_y(qq)=mp_right_y(pp); + mp_originator(qq)=mp_originator(pp); + if ( mp_link(pp)==p ) { + mp_link(q)=qq; mp->path_tail=pp; return q; + } + rr=mp_get_node(mp, knot_node_size); mp_link(rr)=qq; qq=rr; pp=mp_link(pp); + } +} + +@ @<Glob...@>= +pointer path_tail; /* the node that links to the beginning of a path */ + +@ When a cyclic list of knot nodes is no longer needed, it can be recycled by +calling the following subroutine. + +@<Declarations@>= +static void mp_toss_knot_list (MP mp,pointer p) ; + +@ @c +void mp_toss_knot_list (MP mp,pointer p) { + pointer q; /* the node being freed */ + pointer r; /* the next node */ + q=p; + do { + r=mp_link(q); + mp_free_node(mp, q,knot_node_size); q=r; + } while (q!=p); +} + +@* \[18] Choosing control points. +Now we must actually delve into one of \MP's more difficult routines, +the |make_choices| procedure that chooses angles and control points for +the splines of a curve when the user has not specified them explicitly. +The parameter to |make_choices| points to a list of knots and +path information, as described above. + +A path decomposes into independent segments at ``breakpoint'' knots, +which are knots whose left and right angles are both prespecified in +some way (i.e., their |mp_left_type| and |mp_right_type| aren't both open). + +@c +static void mp_make_choices (MP mp,pointer knots) { + pointer h; /* the first breakpoint */ + pointer p,q; /* consecutive breakpoints being processed */ + @<Other local variables for |make_choices|@>; + check_arith; /* make sure that |arith_error=false| */ + if ( mp->internal[mp_tracing_choices]>0 ) + mp_print_path(mp, knots,", before choices",true); + @<If consecutive knots are equal, join them explicitly@>; + @<Find the first breakpoint, |h|, on the path; + insert an artificial breakpoint if the path is an unbroken cycle@>; + p=h; + do { + @<Fill in the control points between |p| and the next breakpoint, + then advance |p| to that breakpoint@>; + } while (p!=h); + if ( mp->internal[mp_tracing_choices]>0 ) + mp_print_path(mp, knots,", after choices",true); + if ( mp->arith_error ) { + @<Report an unexpected problem during the choice-making@>; + } +} + +@ @<Report an unexpected problem during the choice...@>= +{ + print_err("Some number got too big"); +@.Some number got too big@> + help2("The path that I just computed is out of range.", + "So it will probably look funny. Proceed, for a laugh."); + mp_put_get_error(mp); mp->arith_error=false; +} + +@ Two knots in a row with the same coordinates will always be joined +by an explicit ``curve'' whose control points are identical with the +knots. + +@<If consecutive knots are equal, join them explicitly@>= +p=knots; +do { + q=mp_link(p); + if ( mp_x_coord(p)==mp_x_coord(q) && + mp_y_coord(p)==mp_y_coord(q) && 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; left_curl(p)=unity; + } + mp_left_type(q)=mp_explicit; + if ( mp_right_type(q)==mp_open ) { + mp_right_type(q)=mp_curl; right_curl(q)=unity; + } + mp_right_x(p)=mp_x_coord(p); mp_left_x(q)=mp_x_coord(p); + mp_right_y(p)=mp_y_coord(p); mp_left_y(q)=mp_y_coord(p); + } + p=q; +} while (p!=knots) + +@ If there are no breakpoints, it is necessary to compute the direction +angles around an entire cycle. In this case the |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_link(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_link(p); +if ( mp_right_type(p)>=mp_given ) { + while ( (mp_left_type(q)==mp_open)&&(mp_right_type(q)==mp_open) ) q=mp_link(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|@>= +{ + mp_right_x(p)=mp_x_coord(p); mp_right_y(p)=mp_y_coord(p); + mp_left_x(q)=mp_x_coord(q); mp_left_y(q)=mp_y_coord(q); +} + +@ Before we can go further into the way choices are made, we need to +consider the underlying theory. The basic ideas implemented in |make_choices| +are due to John Hobby, who introduced the notion of ``mock curvature'' +@^Hobby, John Douglas@> +at a knot. Angles are chosen so that they preserve mock curvature when +a knot is passed, and this has been found to produce excellent results. + +It is convenient to introduce some notations that simplify the necessary +formulas. Let $d_{k,k+1}=\vert z\k-z_k\vert$ be the (nonzero) distance +between knots |k| and |k+1|; and let +$${z\k-z_k\over z_k-z_{k-1}}={d_{k,k+1}\over d_{k-1,k}}e^{i\psi_k}$$ +so that a polygonal line from $z_{k-1}$ to $z_k$ to $z\k$ turns left +through an angle of~$\psi_k$. We assume that $\vert\psi_k\vert\L180^\circ$. +The control points for the spline from $z_k$ to $z\k$ will be denoted by +$$\eqalign{z_k^+&=z_k+ + \textstyle{1\over3}\rho_k e^{i\theta_k}(z\k-z_k),\cr + z\k^-&=z\k- + \textstyle{1\over3}\sigma\k e^{-i\phi\k}(z\k-z_k),\cr}$$ +where $\rho_k$ and $\sigma\k$ are nonnegative ``velocity ratios'' at the +beginning and end of the curve, while $\theta_k$ and $\phi\k$ are the +corresponding ``offset angles.'' These angles satisfy the condition +$$\theta_k+\phi_k+\psi_k=0,\eqno(*)$$ +whenever the curve leaves an intermediate knot~|k| in the direction that +it enters. + +@ Let $\alpha_k$ and $\beta\k$ be the reciprocals of the ``tension'' of +the curve at its beginning and ending points. This means that +$\rho_k=\alpha_k f(\theta_k,\phi\k)$ and $\sigma\k=\beta\k f(\phi\k,\theta_k)$, +where $f(\theta,\phi)$ is \MP's standard velocity function defined in +the |velocity| subroutine. The cubic spline $B(z_k^{\phantom+},z_k^+, +z\k^-,z\k^{\phantom+};t)$ +has curvature +@^curvature@> +$${2\sigma\k\sin(\theta_k+\phi\k)-6\sin\theta_k\over\rho_k^2d_{k,k+1}} +\qquad{\rm and}\qquad +{2\rho_k\sin(\theta_k+\phi\k)-6\sin\phi\k\over\sigma\k^2d_{k,k+1}}$$ +at |t=0| and |t=1|, respectively. The mock curvature is the linear +@^mock curvature@> +approximation to this true curvature that arises in the limit for +small $\theta_k$ and~$\phi\k$, if second-order terms are discarded. +The standard velocity function satisfies +$$f(\theta,\phi)=1+O(\theta^2+\theta\phi+\phi^2);$$ +hence the mock curvatures are respectively +$${2\beta\k(\theta_k+\phi\k)-6\theta_k\over\alpha_k^2d_{k,k+1}} +\qquad{\rm and}\qquad +{2\alpha_k(\theta_k+\phi\k)-6\phi\k\over\beta\k^2d_{k,k+1}}.\eqno(**)$$ + +@ The turning angles $\psi_k$ are given, and equation $(*)$ above +determines $\phi_k$ when $\theta_k$ is known, so the task of +angle selection is essentially to choose appropriate values for each +$\theta_k$. When equation~$(*)$ is used to eliminate $\phi$~variables +from $(**)$, we obtain a system of linear equations of the form +$$A_k\theta_{k-1}+(B_k+C_k)\theta_k+D_k\theta\k=-B_k\psi_k-D_k\psi\k,$$ +where +$$A_k={\alpha_{k-1}\over\beta_k^2d_{k-1,k}}, +\qquad B_k={3-\alpha_{k-1}\over\beta_k^2d_{k-1,k}}, +\qquad C_k={3-\beta\k\over\alpha_k^2d_{k,k+1}}, +\qquad D_k={\beta\k\over\alpha_k^2d_{k,k+1}}.$$ +The tensions are always $3\over4$ or more, hence each $\alpha$ and~$\beta$ +will be at most $4\over3$. It follows that $B_k\G{5\over4}A_k$ and +$C_k\G{5\over4}D_k$; hence the equations are diagonally dominant; +hence they have a unique solution. Moreover, in most cases the tensions +are equal to~1, so that $B_k=2A_k$ and $C_k=2D_k$. This makes the +solution numerically stable, and there is an exponential damping +effect: The data at knot $k\pm j$ affects the angle at knot~$k$ by +a factor of~$O(2^{-j})$. + +@ However, we still must consider the angles at the starting and ending +knots of a non-cyclic path. These angles might be given explicitly, or +they might be specified implicitly in terms of an amount of ``curl.'' + +Let's assume that angles need to be determined for a non-cyclic path +starting at $z_0$ and ending at~$z_n$. Then equations of the form +$$A_k\theta_{k-1}+(B_k+C_k)\theta_k+D_k\theta_{k+1}=R_k$$ +have been given for $0<k<n$, and it will be convenient to introduce +equations of the same form for $k=0$ and $k=n$, where +$$A_0=B_0=C_n=D_n=0.$$ +If $\theta_0$ is supposed to have a given value $E_0$, we simply +define $C_0=1$, $D_0=0$, and $R_0=E_0$. Otherwise a curl +parameter, $\gamma_0$, has been specified at~$z_0$; this means +that the mock curvature at $z_0$ should be $\gamma_0$ times the +mock curvature at $z_1$; i.e., +$${2\beta_1(\theta_0+\phi_1)-6\theta_0\over\alpha_0^2d_{01}} +=\gamma_0{2\alpha_0(\theta_0+\phi_1)-6\phi_1\over\beta_1^2d_{01}}.$$ +This equation simplifies to +$$(\alpha_0\chi_0+3-\beta_1)\theta_0+ + \bigl((3-\alpha_0)\chi_0+\beta_1\bigr)\theta_1= + -\bigl((3-\alpha_0)\chi_0+\beta_1\bigr)\psi_1,$$ +where $\chi_0=\alpha_0^2\gamma_0/\beta_1^2$; so we can set $C_0= +\chi_0\alpha_0+3-\beta_1$, $D_0=(3-\alpha_0)\chi_0+\beta_1$, $R_0=-D_0\psi_1$. +It can be shown that $C_0>0$ and $C_0B_1-A_1D_0>0$ when $\gamma_0\G0$, +hence the linear equations remain nonsingular. + +Similar considerations apply at the right end, when the final angle $\phi_n$ +may or may not need to be determined. It is convenient to let $\psi_n=0$, +hence $\theta_n=-\phi_n$. We either have an explicit equation $\theta_n=E_n$, +or we have +$$\bigl((3-\beta_n)\chi_n+\alpha_{n-1}\bigr)\theta_{n-1}+ +(\beta_n\chi_n+3-\alpha_{n-1})\theta_n=0,\qquad + \chi_n={\beta_n^2\gamma_n\over\alpha_{n-1}^2}.$$ + +When |make_choices| chooses angles, it must compute the coefficients of +these linear equations, then solve the equations. To compute the coefficients, +it is necessary to compute arctangents of the given turning angles~$\psi_k$. +When the equations are solved, the chosen directions $\theta_k$ are put +back into the form of control points by essentially computing sines and +cosines. + +@ OK, we are ready to make the hard choices of |make_choices|. +Most of the work is relegated to an auxiliary procedure +called |solve_choices|, which has been introduced to keep +|make_choices| from being extremely long. + +@<Fill in the control information between...@>= +@<Calculate the turning angles $\psi_k$ and the distances $d_{k,k+1}$; + set $n$ to the length of the path@>; +@<Remove |open| types at the breakpoints@>; +mp_solve_choices(mp, p,q,n) + +@ It's convenient to precompute quantities that will be needed several +times later. The values of |delta_x[k]| and |delta_y[k]| will be the +coordinates of $z\k-z_k$, and the magnitude of this vector will be +|delta[k]=@t$d_{k,k+1}$@>|. The path angle $\psi_k$ between $z_k-z_{k-1}$ +and $z\k-z_k$ will be stored in |psi[k]|. + +@<Glob...@>= +int path_size; /* maximum number of knots between breakpoints of a path */ +scaled *delta_x; +scaled *delta_y; +scaled *delta; /* knot differences */ +angle *psi; /* turning angles */ + +@ @<Dealloc variables@>= +xfree(mp->delta_x); +xfree(mp->delta_y); +xfree(mp->delta); +xfree(mp->psi); + +@ @<Other local variables for |make_choices|@>= + int k,n; /* current and final knot numbers */ + pointer s,t; /* registers for list traversal */ + scaled delx,dely; /* directions where |open| meets |explicit| */ + fraction sine,cosine; /* trig functions of various angles */ + +@ @<Calculate the turning angles...@>= +{ +RESTART: + k=0; s=p; n=mp->path_size; + do { + t=mp_link(s); + mp->delta_x[k]=mp_x_coord(t)-mp_x_coord(s); + mp->delta_y[k]=mp_y_coord(t)-mp_y_coord(s); + mp->delta[k]=mp_pyth_add(mp, mp->delta_x[k],mp->delta_y[k]); + if ( k>0 ) { + sine=mp_make_fraction(mp, mp->delta_y[k-1],mp->delta[k-1]); + cosine=mp_make_fraction(mp, mp->delta_x[k-1],mp->delta[k-1]); + mp->psi[k]=mp_n_arg(mp, mp_take_fraction(mp, mp->delta_x[k],cosine)+ + mp_take_fraction(mp, mp->delta_y[k],sine), + mp_take_fraction(mp, mp->delta_y[k],cosine)- + mp_take_fraction(mp, mp->delta_x[k],sine)); + } + incr(k); s=t; + if ( k==mp->path_size ) { + mp_reallocate_paths(mp, mp->path_size+(mp->path_size/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 ) mp->psi[n]=0; else mp->psi[k]=mp->psi[1]; +} + +@ 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@>= +if ( mp_left_type(q)==mp_open ) { + delx=mp_right_x(q)-mp_x_coord(q); dely=mp_right_y(q)-mp_y_coord(q); + if ( (delx==0)&&(dely==0) ) { + mp_left_type(q)=mp_curl; left_curl(q)=unity; + } else { + mp_left_type(q)=mp_given; left_given(q)=mp_n_arg(mp, delx,dely); + } +} +if ( (mp_right_type(p)==mp_open)&&(mp_left_type(p)==mp_explicit) ) { + delx=mp_x_coord(p)-mp_left_x(p); dely=mp_y_coord(p)-mp_left_y(p); + if ( (delx==0)&&(dely==0) ) { + mp_right_type(p)=mp_curl; right_curl(p)=unity; + } else { + mp_right_type(p)=mp_given; right_given(p)=mp_n_arg(mp, delx,dely); + } +} + +@ Linear equations need to be solved whenever |n>1|; and also when |n=1| +and exactly one of the breakpoints involves a curl. The simplest case occurs +when |n=1| and there is a curl at both breakpoints; then we simply draw +a straight line. + +But before coding up the simple cases, we might as well face the general case, +since we must deal with it sooner or later, and since the general case +is likely to give some insight into the way simple cases can be handled best. + +When there is no cycle, the linear equations to be solved form a tridiagonal +system, and we can apply the standard technique of Gaussian elimination +to convert that system to a sequence of equations of the form +$$\theta_0+u_0\theta_1=v_0,\quad +\theta_1+u_1\theta_2=v_1,\quad\ldots,\quad +\theta_{n-1}+u_{n-1}\theta_n=v_{n-1},\quad +\theta_n=v_n.$$ +It is possible to do this diagonalization while generating the equations. +Once $\theta_n$ is known, it is easy to determine $\theta_{n-1}$, \dots, +$\theta_1$, $\theta_0$; thus, the equations will be solved. + +The procedure is slightly more complex when there is a cycle, but the +basic idea will be nearly the same. In the cyclic case the right-hand +sides will be $v_k+w_k\theta_0$ instead of simply $v_k$, and we will start +the process off with $u_0=v_0=0$, $w_0=1$. The final equation will be not +$\theta_n=v_n$ but $\theta_n+u_n\theta_1=v_n+w_n\theta_0$; an appropriate +ending routine will take account of the fact that $\theta_n=\theta_0$ and +eliminate the $w$'s from the system, after which the solution can be +obtained as before. + +When $u_k$, $v_k$, and $w_k$ are being computed, the three pointer +variables |r|, |s|,~|t| will point respectively to knots |k-1|, |k|, +and~|k+1|. The $u$'s and $w$'s are scaled by $2^{28}$, i.e., they are +of type |fraction|; the $\theta$'s and $v$'s are of type |angle|. + +@<Glob...@>= +angle *theta; /* values of $\theta_k$ */ +fraction *uu; /* values of $u_k$ */ +angle *vv; /* values of $v_k$ */ +fraction *ww; /* values of $w_k$ */ + +@ @<Dealloc variables@>= +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) { + XREALLOC (mp->delta_x, l, scaled); + XREALLOC (mp->delta_y, l, scaled); + XREALLOC (mp->delta, l, scaled); + XREALLOC (mp->psi, l, angle); + XREALLOC (mp->theta, l, angle); + XREALLOC (mp->uu, l, fraction); + XREALLOC (mp->vv, l, angle); + XREALLOC (mp->ww, l, fraction); + mp->path_size = l; +} + +@ Our immediate problem is to get the ball rolling by setting up the +first equation or by realizing that no equations are needed, and to fit +this initialization into a framework suitable for the overall computation. + +@<Declarations@>= +static void mp_solve_choices (MP mp,pointer p, pointer q, halfword n) ; + +@ @c +void mp_solve_choices (MP mp,pointer p, pointer q, halfword n) { + int k; /* current knot number */ + pointer r,s,t; /* registers for list traversal */ + @<Other local variables for |solve_choices|@>; + k=0; s=p; r=0; + while (1) { + t=mp_link(s); + if ( k==0 ) { + @<Get the linear equations started; or |return| + with the control points in place, if linear equations + needn't be solved@> + } else { + switch (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@>; +} + +@ 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: + mp->uu[0]=0; mp->vv[0]=0; mp->ww[0]=fraction_one; + /* this begins a cycle */ + break; +} /* there are no other cases */ + +@ The general equation that specifies equality of mock curvature at $z_k$ is +$$A_k\theta_{k-1}+(B_k+C_k)\theta_k+D_k\theta\k=-B_k\psi_k-D_k\psi\k,$$ +as derived above. We want to combine this with the already-derived equation +$\theta_{k-1}+u_{k-1}\theta_k=v_{k-1}+w_{k-1}\theta_0$ in order to obtain +a new equation +$\theta_k+u_k\theta\k=v_k+w_k\theta_0$. This can be done by dividing the +equation +$$(B_k-u_{k-1}A_k+C_k)\theta_k+D_k\theta\k=-B_k\psi_k-D_k\psi\k-A_kv_{k-1} + -A_kw_{k-1}\theta_0$$ +by $B_k-u_{k-1}A_k+C_k$. The trick is to do this carefully with +fixed-point arithmetic, avoiding the chance of overflow while retaining +suitable precision. + +The calculations will be performed in several registers that +provide temporary storage for intermediate quantities. + +@<Other local variables for |solve_choices|@>= +fraction aa,bb,cc,ff,acc; /* temporary registers */ +scaled dd,ee; /* likewise, but |scaled| */ +scaled lt,rt; /* tension values */ + +@ @<Set up equation to match mock curvatures...@>= +{ @<Calculate the values $\\{aa}=A_k/B_k$, $\\{bb}=D_k/C_k$, + $\\{dd}=(3-\alpha_{k-1})d_{k,k+1}$, $\\{ee}=(3-\beta\k)d_{k-1,k}$, + and $\\{cc}=(B_k-u_{k-1}A_k)/B_k$@>; + @<Calculate the ratio $\\{ff}=C_k/(C_k+B_k-u_{k-1}A_k)$@>; + mp->uu[k]=mp_take_fraction(mp, ff,bb); + @<Calculate the values of $v_k$ and $w_k$@>; + if ( mp_left_type(s)==mp_end_cycle ) { + @<Adjust $\theta_n$ to equal $\theta_0$ and |goto found|@>; + } +} + +@ Since tension values are never less than 3/4, the values |aa| and +|bb| computed here are never more than 4/5. + +@<Calculate the values $\\{aa}=...@>= +if ( abs(right_tension(r))==unity) { + aa=fraction_half; dd=2*mp->delta[k]; +} else { + aa=mp_make_fraction(mp, unity,3*abs(right_tension(r))-unity); + dd=mp_take_fraction(mp, mp->delta[k], + fraction_three-mp_make_fraction(mp, unity,abs(right_tension(r)))); +} +if ( abs(left_tension(t))==unity ){ + bb=fraction_half; ee=2*mp->delta[k-1]; +} else { + bb=mp_make_fraction(mp, unity,3*abs(left_tension(t))-unity); + ee=mp_take_fraction(mp, mp->delta[k-1], + fraction_three-mp_make_fraction(mp, unity,abs(left_tension(t)))); +} +cc=fraction_one-mp_take_fraction(mp, mp->uu[k-1],aa) + +@ The ratio to be calculated in this step can be written in the form +$$\beta_k^2\cdot\\{ee}\over\beta_k^2\cdot\\{ee}+\alpha_k^2\cdot + \\{cc}\cdot\\{dd},$$ +because of the quantities just calculated. The values of |dd| and |ee| +will not be needed after this step has been performed. + +@<Calculate the ratio $\\{ff}=C_k/(C_k+B_k-u_{k-1}A_k)$@>= +dd=mp_take_fraction(mp, dd,cc); lt=abs(left_tension(s)); rt=abs(right_tension(s)); +if ( lt!=rt ) { /* $\beta_k^{-1}\ne\alpha_k^{-1}$ */ + if ( lt<rt ) { + ff=mp_make_fraction(mp, lt,rt); + ff=mp_take_fraction(mp, ff,ff); /* $\alpha_k^2/\beta_k^2$ */ + dd=mp_take_fraction(mp, dd,ff); + } else { + ff=mp_make_fraction(mp, rt,lt); + ff=mp_take_fraction(mp, ff,ff); /* $\beta_k^2/\alpha_k^2$ */ + ee=mp_take_fraction(mp, ee,ff); + } +} +ff=mp_make_fraction(mp, ee,ee+dd) + +@ The value of $u_{k-1}$ will be |<=1| except when $k=1$ and the previous +equation was specified by a curl. In that case we must use a special +method of computation to prevent overflow. + +Fortunately, the calculations turn out to be even simpler in this ``hard'' +case. The curl equation makes $w_0=0$ and $v_0=-u_0\psi_1$, hence +$-B_1\psi_1-A_1v_0=-(B_1-u_0A_1)\psi_1=-\\{cc}\cdot B_1\psi_1$. + +@<Calculate the values of $v_k$ and $w_k$@>= +acc=-mp_take_fraction(mp, mp->psi[k+1],mp->uu[k]); +if ( mp_right_type(r)==mp_curl ) { + mp->ww[k]=0; + mp->vv[k]=acc-mp_take_fraction(mp, mp->psi[1],fraction_one-ff); +} else { + ff=mp_make_fraction(mp, fraction_one-ff,cc); /* this is + $B_k/(C_k+B_k-u_{k-1}A_k)<5$ */ + acc=acc-mp_take_fraction(mp, mp->psi[k],ff); + ff=mp_take_fraction(mp, ff,aa); /* this is $A_k/(C_k+B_k-u_{k-1}A_k)$ */ + mp->vv[k]=acc-mp_take_fraction(mp, mp->vv[k-1],ff); + if ( mp->ww[k-1]==0 ) mp->ww[k]=0; + else mp->ww[k]=-mp_take_fraction(mp, mp->ww[k-1],ff); +} + +@ When a complete cycle has been traversed, we have $\theta_k+u_k\theta\k= +v_k+w_k\theta_0$, for |1<=k<=n|. We would like to determine the value of +$\theta_n$ and reduce the system to the form $\theta_k+u_k\theta\k=v_k$ +for |0<=k<n|, so that the cyclic case can be finished up just as if there +were no cycle. + +The idea in the following code is to observe that +$$\eqalign{\theta_n&=v_n+w_n\theta_0-u_n\theta_1=\cdots\cr +&=v_n+w_n\theta_0-u_n\bigl(v_1+w_1\theta_0-u_1(v_2+\cdots + -u_{n-2}(v_{n-1}+w_{n-1}\theta_0-u_{n-1}\theta_0))\bigr),\cr}$$ +so we can solve for $\theta_n=\theta_0$. + +@<Adjust $\theta_n$ to equal $\theta_0$ and |goto found|@>= +{ +aa=0; bb=fraction_one; /* we have |k=n| */ +do { decr(k); +if ( k==0 ) k=n; + aa=mp->vv[k]-mp_take_fraction(mp, aa,mp->uu[k]); + bb=mp->ww[k]-mp_take_fraction(mp, bb,mp->uu[k]); +} while (k!=n); /* now $\theta_n=\\{aa}+\\{bb}\cdot\theta_n$ */ +aa=mp_make_fraction(mp, aa,fraction_one-bb); +mp->theta[n]=aa; mp->vv[0]=aa; +for (k=1;k<n;k++) { + mp->vv[k]=mp->vv[k]+mp_take_fraction(mp, aa,mp->ww[k]); +} +goto FOUND; +} + +@ @d reduce_angle(A) if ( abs((A))>one_eighty_deg ) { + if ( (A)>0 ) (A)=(A)-three_sixty_deg; else (A)=(A)+three_sixty_deg; } + +@<Calculate the given value of $\theta_n$...@>= +{ + mp->theta[n]=left_given(s)-mp_n_arg(mp, mp->delta_x[n-1],mp->delta_y[n-1]); + reduce_angle(mp->theta[n]); + goto FOUND; +} + +@ @<Set up the equation for a given value of $\theta_0$@>= +{ + mp->vv[0]=right_given(s)-mp_n_arg(mp, mp->delta_x[0],mp->delta_y[0]); + reduce_angle(mp->vv[0]); + mp->uu[0]=0; mp->ww[0]=0; +} + +@ @<Set up the equation for a curl at $\theta_0$@>= +{ cc=right_curl(s); lt=abs(left_tension(t)); rt=abs(right_tension(s)); + if ( (rt==unity)&&(lt==unity) ) + mp->uu[0]=mp_make_fraction(mp, cc+cc+unity,cc+two); + else + mp->uu[0]=mp_curl_ratio(mp, cc,rt,lt); + mp->vv[0]=-mp_take_fraction(mp, mp->psi[1],mp->uu[0]); mp->ww[0]=0; +} + +@ @<Set up equation for a curl at $\theta_n$...@>= +{ cc=left_curl(s); lt=abs(left_tension(s)); rt=abs(right_tension(r)); + if ( (rt==unity)&&(lt==unity) ) + ff=mp_make_fraction(mp, cc+cc+unity,cc+two); + else + ff=mp_curl_ratio(mp, cc,lt,rt); + mp->theta[n]=-mp_make_fraction(mp, mp_take_fraction(mp, mp->vv[n-1],ff), + fraction_one-mp_take_fraction(mp, ff,mp->uu[n-1])); + goto FOUND; +} + +@ The |curl_ratio| subroutine has three arguments, which our previous notation +encourages us to call $\gamma$, $\alpha^{-1}$, and $\beta^{-1}$. It is +a somewhat tedious program to calculate +$${(3-\alpha)\alpha^2\gamma+\beta^3\over + \alpha^3\gamma+(3-\beta)\beta^2},$$ +with the result reduced to 4 if it exceeds 4. (This reduction of curl +is necessary only if the curl and tension are both large.) +The values of $\alpha$ and $\beta$ will be at most~4/3. + +@<Declarations@>= +static fraction mp_curl_ratio (MP mp,scaled gamma, scaled a_tension, + scaled b_tension) ; + +@ @c +fraction mp_curl_ratio (MP mp,scaled gamma, scaled a_tension, + scaled b_tension) { + fraction alpha,beta,num,denom,ff; /* registers */ + alpha=mp_make_fraction(mp, unity,a_tension); + beta=mp_make_fraction(mp, unity,b_tension); + if ( alpha<=beta ) { + ff=mp_make_fraction(mp, alpha,beta); ff=mp_take_fraction(mp, ff,ff); + gamma=mp_take_fraction(mp, gamma,ff); + beta=beta / 010000; /* convert |fraction| to |scaled| */ + denom=mp_take_fraction(mp, gamma,alpha)+three-beta; + num=mp_take_fraction(mp, gamma,fraction_three-alpha)+beta; + } else { + ff=mp_make_fraction(mp, beta,alpha); ff=mp_take_fraction(mp, ff,ff); + beta=mp_take_fraction(mp, beta,ff) / 010000; /* convert |fraction| to |scaled| */ + denom=mp_take_fraction(mp, gamma,alpha)+(ff / 1365)-beta; + /* $1365\approx 2^{12}/3$ */ + num=mp_take_fraction(mp, gamma,fraction_three-alpha)+beta; + } + if ( num>=denom+denom+denom+denom ) return fraction_four; + else return mp_make_fraction(mp, num,denom); +} + +@ We're in the home stretch now. + +@<Finish choosing angles and assigning control points@>= +for (k=n-1;k>=0;k--) { + mp->theta[k]=mp->vv[k]-mp_take_fraction(mp,mp->theta[k+1],mp->uu[k]); +} +s=p; k=0; +do { + t=mp_link(s); + mp_n_sin_cos(mp, mp->theta[k]); mp->st=mp->n_sin; mp->ct=mp->n_cos; + mp_n_sin_cos(mp, -mp->psi[k+1]-mp->theta[k+1]); mp->sf=mp->n_sin; mp->cf=mp->n_cos; + mp_set_controls(mp, s,t,k); + incr(k); s=t; +} while (k!=n) + +@ The |set_controls| routine actually puts the control points into +a pair of consecutive nodes |p| and~|q|. Global variables are used to +record the values of $\sin\theta$, $\cos\theta$, $\sin\phi$, and +$\cos\phi$ needed in this calculation. + +@<Glob...@>= +fraction st; +fraction ct; +fraction sf; +fraction cf; /* sines and cosines */ + +@ @<Declarations@>= +static void mp_set_controls (MP mp,pointer p, pointer q, integer k); + +@ @c +void mp_set_controls (MP mp,pointer p, pointer q, integer k) { + fraction rr,ss; /* velocities, divided by thrice the tension */ + scaled lt,rt; /* tensions */ + fraction sine; /* $\sin(\theta+\phi)$ */ + lt=abs(left_tension(q)); rt=abs(right_tension(p)); + rr=mp_velocity(mp, mp->st,mp->ct,mp->sf,mp->cf,rt); + ss=mp_velocity(mp, mp->sf,mp->cf,mp->st,mp->ct,lt); + if ( (right_tension(p)<0)||(left_tension(q)<0) ) { + @<Decrease the velocities, + if necessary, to stay inside the bounding triangle@>; + } + mp_right_x(p)=mp_x_coord(p)+mp_take_fraction(mp, + mp_take_fraction(mp, mp->delta_x[k],mp->ct)- + mp_take_fraction(mp, mp->delta_y[k],mp->st),rr); + mp_right_y(p)=mp_y_coord(p)+mp_take_fraction(mp, + mp_take_fraction(mp, mp->delta_y[k],mp->ct)+ + mp_take_fraction(mp, mp->delta_x[k],mp->st),rr); + mp_left_x(q)=mp_x_coord(q)-mp_take_fraction(mp, + mp_take_fraction(mp, mp->delta_x[k],mp->cf)+ + mp_take_fraction(mp, mp->delta_y[k],mp->sf),ss); + mp_left_y(q)=mp_y_coord(q)-mp_take_fraction(mp, + mp_take_fraction(mp, mp->delta_y[k],mp->cf)- + mp_take_fraction(mp, mp->delta_x[k],mp->sf),ss); + mp_right_type(p)=mp_explicit; mp_left_type(q)=mp_explicit; +} + +@ The boundedness conditions $\\{rr}\L\sin\phi\,/\sin(\theta+\phi)$ and +$\\{ss}\L\sin\theta\,/\sin(\theta+\phi)$ are to be enforced if $\sin\theta$, +$\sin\phi$, and $\sin(\theta+\phi)$ all have the same sign. Otherwise +there is no ``bounding triangle.'' + +@<Decrease the velocities, if necessary...@>= +if (((mp->st>=0)&&(mp->sf>=0))||((mp->st<=0)&&(mp->sf<=0)) ) { + sine=mp_take_fraction(mp, abs(mp->st),mp->cf)+ + mp_take_fraction(mp, abs(mp->sf),mp->ct); + if ( sine>0 ) { + sine=mp_take_fraction(mp, sine,fraction_one+unity); /* safety factor */ + if ( right_tension(p)<0 ) + if ( mp_ab_vs_cd(mp, abs(mp->sf),fraction_one,rr,sine)<0 ) + rr=mp_make_fraction(mp, abs(mp->sf),sine); + if ( left_tension(q)<0 ) + if ( mp_ab_vs_cd(mp, abs(mp->st),fraction_one,ss,sine)<0 ) + ss=mp_make_fraction(mp, abs(mp->st),sine); + } +} + +@ Only the simple cases remain to be handled. + +@<Reduce to simple case of two givens and |return|@>= +{ + aa=mp_n_arg(mp, mp->delta_x[0],mp->delta_y[0]); + mp_n_sin_cos(mp, right_given(p)-aa); mp->ct=mp->n_cos; mp->st=mp->n_sin; + mp_n_sin_cos(mp, left_given(q)-aa); mp->cf=mp->n_cos; mp->sf=-mp->n_sin; + mp_set_controls(mp, p,q,0); return; +} + +@ @<Reduce to simple case of straight line and |return|@>= +{ + mp_right_type(p)=mp_explicit; mp_left_type(q)=mp_explicit; + lt=abs(left_tension(q)); rt=abs(right_tension(p)); + if ( rt==unity ) { + if ( mp->delta_x[0]>=0 ) mp_right_x(p)=mp_x_coord(p)+((mp->delta_x[0]+1) / 3); + else mp_right_x(p)=mp_x_coord(p)+((mp->delta_x[0]-1) / 3); + if ( mp->delta_y[0]>=0 ) mp_right_y(p)=mp_y_coord(p)+((mp->delta_y[0]+1) / 3); + else mp_right_y(p)=mp_y_coord(p)+((mp->delta_y[0]-1) / 3); + } else { + ff=mp_make_fraction(mp, unity,3*rt); /* $\alpha/3$ */ + mp_right_x(p)=mp_x_coord(p)+mp_take_fraction(mp, mp->delta_x[0],ff); + mp_right_y(p)=mp_y_coord(p)+mp_take_fraction(mp, mp->delta_y[0],ff); + } + if ( lt==unity ) { + if ( mp->delta_x[0]>=0 ) mp_left_x(q)=mp_x_coord(q)-((mp->delta_x[0]+1) / 3); + else mp_left_x(q)=mp_x_coord(q)-((mp->delta_x[0]-1) / 3); + if ( mp->delta_y[0]>=0 ) mp_left_y(q)=mp_y_coord(q)-((mp->delta_y[0]+1) / 3); + else mp_left_y(q)=mp_y_coord(q)-((mp->delta_y[0]-1) / 3); + } else { + ff=mp_make_fraction(mp, unity,3*lt); /* $\beta/3$ */ + mp_left_x(q)=mp_x_coord(q)-mp_take_fraction(mp, mp->delta_x[0],ff); + mp_left_y(q)=mp_y_coord(q)-mp_take_fraction(mp, mp->delta_y[0],ff); + } + return; +} + +@* \[19] Measuring paths. +\MP's \&{llcorner}, \&{lrcorner}, \&{ulcorner}, and \&{urcorner} operators +allow the user to measure the bounding box of anything that can go into a +picture. It's easy to get rough bounds on the $x$ and $y$ extent of a path +by just finding the bounding box of the knots and the control points. We +need a more accurate version of the bounding box, but we can still use the +easy estimate to save time by focusing on the interesting parts of the path. + +@ Computing an accurate bounding box involves a theme that will come up again +and again. Given a Bernshte{\u\i}n polynomial +@^Bernshte{\u\i}n, Serge{\u\i} Natanovich@> +$$B(z_0,z_1,\ldots,z_n;t)=\sum_k{n\choose k}t^k(1-t)^{n-k}z_k,$$ +we can conveniently bisect its range as follows: + +\smallskip +\textindent{1)} Let $z_k^{(0)}=z_k$, for |0<=k<=n|. + +\smallskip +\textindent{2)} Let $z_k^{(j+1)}={1\over2}(z_k^{(j)}+z\k^{(j)})$, for +|0<=k<n-j|, for |0<=j<n|. + +\smallskip\noindent +Then +$$B(z_0,z_1,\ldots,z_n;t)=B(z_0^{(0)},z_0^{(1)},\ldots,z_0^{(n)};2t) + =B(z_0^{(n)},z_1^{(n-1)},\ldots,z_n^{(0)};2t-1).$$ +This formula gives us the coefficients of polynomials to use over the ranges +$0\L t\L{1\over2}$ and ${1\over2}\L t\L1$. + +@ Now here's a subroutine that's handy for all sorts of path computations: +Given a quadratic polynomial $B(a,b,c;t)$, the |crossing_point| function +returns the unique |fraction| value |t| between 0 and~1 at which +$B(a,b,c;t)$ changes from positive to negative, or returns +|t=fraction_one+1| if no such value exists. If |a<0| (so that $B(a,b,c;t)$ +is already negative at |t=0|), |crossing_point| returns the value zero. + +@d no_crossing { return (fraction_one+1); } +@d one_crossing { return fraction_one; } +@d zero_crossing { return 0; } +@d mp_crossing_point(M,A,B,C) mp_do_crossing_point(A,B,C) + +@c static fraction mp_do_crossing_point (integer a, integer b, integer c) { + integer d; /* recursive counter */ + integer x,xx,x0,x1,x2; /* temporary registers for bisection */ + if ( a<0 ) zero_crossing; + if ( c>=0 ) { + if ( b>=0 ) { + if ( c>0 ) { no_crossing; } + else if ( (a==0)&&(b==0) ) { no_crossing;} + else { one_crossing; } + } + if ( a==0 ) zero_crossing; + } else if ( a==0 ) { + if ( b<=0 ) zero_crossing; + } + @<Use bisection to find the crossing point, if one exists@>; +} + +@ The general bisection method is quite simple when $n=2$, hence +|crossing_point| does not take much time. At each stage in the +recursion we have a subinterval defined by |l| and~|j| such that +$B(a,b,c;2^{-l}(j+t))=B(x_0,x_1,x_2;t)$, and we want to ``zero in'' on +the subinterval where $x_0\G0$ and $\min(x_1,x_2)<0$. + +It is convenient for purposes of calculation to combine the values +of |l| and~|j| in a single variable $d=2^l+j$, because the operation +of bisection then corresponds simply to doubling $d$ and possibly +adding~1. Furthermore it proves to be convenient to modify +our previous conventions for bisection slightly, maintaining the +variables $X_0=2^lx_0$, $X_1=2^l(x_0-x_1)$, and $X_2=2^l(x_1-x_2)$. +With these variables the conditions $x_0\ge0$ and $\min(x_1,x_2)<0$ are +equivalent to $\max(X_1,X_1+X_2)>X_0\ge0$. + +The following code maintains the invariant relations +$0\L|x0|<\max(|x1|,|x1|+|x2|)$, +$\vert|x1|\vert<2^{30}$, $\vert|x2|\vert<2^{30}$; +it has been constructed in such a way that no arithmetic overflow +will occur if the inputs satisfy +$a<2^{30}$, $\vert a-b\vert<2^{30}$, and $\vert b-c\vert<2^{30}$. + +@<Use bisection to find the crossing point...@>= +d=1; x0=a; x1=a-b; x2=b-c; +do { + x=half(x1+x2); + if ( x1-x0>x0 ) { + x2=x; x0+=x0; d+=d; + } else { + xx=x1+x-x0; + if ( xx>x0 ) { + x2=x; x0+=x0; d+=d; + } else { + x0=x0-xx; + if ( x<=x0 ) { if ( x+x2<=x0 ) no_crossing; } + x1=x; d=d+d+1; + } + } +} while (d<fraction_one); +return (d-fraction_one) + +@ Here is a routine that computes the $x$ or $y$ coordinate of the point on +a cubic corresponding to the |fraction| value~|t|. + +It is convenient to define a \.{WEB} macro |t_of_the_way| such that +|t_of_the_way(a,b)| expands to |a-(a-b)*t|, i.e., to |t[a,b]|. + +@d t_of_the_way(A,B) ((A)-mp_take_fraction(mp,((A)-(B)),t)) + +@c static scaled mp_eval_cubic (MP mp,pointer p, pointer q, fraction t) { + scaled x1,x2,x3; /* intermediate values */ + x1=t_of_the_way(knot_coord(p),right_coord(p)); + x2=t_of_the_way(right_coord(p),left_coord(q)); + x3=t_of_the_way(left_coord(q),knot_coord(q)); + x1=t_of_the_way(x1,x2); + x2=t_of_the_way(x2,x3); + return t_of_the_way(x1,x2); +} + +@ The actual bounding box information is stored in global variables. +Since it is convenient to address the $x$ and $y$ information +separately, we define arrays indexed by |x_code..y_code| and use +macros to give them more convenient names. + +@<Types...@>= +enum mp_bb_code { + mp_x_code=0, /* index for |minx| and |maxx| */ + mp_y_code /* index for |miny| and |maxy| */ +} ; + +@ +@d 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...@>= +scaled bbmin[mp_y_code+1]; +scaled bbmax[mp_y_code+1]; +/* the result of procedures that compute bounding box information */ + +@ Now we're ready for the key part of the bounding box computation. +The |bound_cubic| procedure updates |bbmin[c]| and |bbmax[c]| based on +$$B(\hbox{|knot_coord(p)|}, \hbox{|right_coord(p)|}, + \hbox{|left_coord(q)|}, \hbox{|knot_coord(q)|};t) +$$ +for $0<t\le1$. In other words, the procedure adjusts the bounds to +accommodate |knot_coord(q)| and any extremes over the range $0<t<1$. +The |c| parameter is |x_code| or |y_code|. + +@c static void mp_bound_cubic (MP mp,pointer p, pointer q, quarterword c) { + boolean wavy; /* whether we need to look for extremes */ + scaled del1,del2,del3,del,dmax; /* proportional to the control + points of a quadratic derived from a cubic */ + fraction t,tt; /* where a quadratic crosses zero */ + scaled x; /* a value that |bbmin[c]| and |bbmax[c]| must accommodate */ + x=knot_coord(q); + @<Adjust |bbmin[c]| and |bbmax[c]| to accommodate |x|@>; + @<Check the control points against the bounding box and set |wavy:=true| + if any of them lie outside@>; + if ( wavy ) { + del1=right_coord(p)-knot_coord(p); + del2=left_coord(q)-right_coord(p); + del3=knot_coord(q)-left_coord(q); + @<Scale up |del1|, |del2|, and |del3| for greater accuracy; + also set |del| to the first nonzero element of |(del1,del2,del3)|@>; + if ( del<0 ) { + negate(del1); negate(del2); negate(del3); + }; + t=mp_crossing_point(mp, del1,del2,del3); + if ( t<fraction_one ) { + @<Test the extremes of the cubic against the bounding box@>; + } + } +} + +@ @<Adjust |bbmin[c]| and |bbmax[c]| to accommodate |x|@>= +if ( x<mp->bbmin[c] ) mp->bbmin[c]=x; +if ( x>mp->bbmax[c] ) mp->bbmax[c]=x + +@ @<Check the control points against the bounding box and set...@>= +wavy=true; +if ( mp->bbmin[c]<=right_coord(p) ) + if ( right_coord(p)<=mp->bbmax[c] ) + if ( mp->bbmin[c]<=left_coord(q) ) + if ( left_coord(q)<=mp->bbmax[c] ) + wavy=false + +@ If |del1=del2=del3=0|, it's impossible to obey the title of this +section. We just set |del=0| in that case. + +@<Scale up |del1|, |del2|, and |del3| for greater accuracy...@>= +if ( del1!=0 ) del=del1; +else if ( del2!=0 ) del=del2; +else del=del3; +if ( del!=0 ) { + dmax=abs(del1); + if ( abs(del2)>dmax ) dmax=abs(del2); + if ( abs(del3)>dmax ) dmax=abs(del3); + while ( dmax<fraction_half ) { + dmax+=dmax; del1+=del1; del2+=del2; del3+=del3; + } +} + +@ Since |crossing_point| has tried to choose |t| so that +$B(|del1|,|del2|,|del3|;\tau)$ crosses zero at $\tau=|t|$ with negative +slope, the value of |del2| computed below should not be positive. +But rounding error could make it slightly positive in which case we +must cut it to zero to avoid confusion. + +@<Test the extremes of the cubic against the bounding box@>= +{ + x=mp_eval_cubic(mp, p,q,t); + @<Adjust |bbmin[c]| and |bbmax[c]| to accommodate |x|@>; + del2=t_of_the_way(del2,del3); + /* now |0,del2,del3| represent the derivative on the remaining interval */ + if ( del2>0 ) del2=0; + tt=mp_crossing_point(mp, 0,-del2,-del3); + if ( tt<fraction_one ) { + @<Test the second extreme against the bounding box@>; + } +} + +@ @<Test the second extreme against the bounding box@>= +{ + x=mp_eval_cubic(mp, p,q,t_of_the_way(tt,fraction_one)); + @<Adjust |bbmin[c]| and |bbmax[c]| to accommodate |x|@>; +} + +@ Finding the bounding box of a path is basically a matter of applying +|bound_cubic| twice for each pair of adjacent knots. + +@c static void mp_path_bbox (MP mp,pointer h) { + pointer p,q; /* a pair of adjacent knots */ + mp_minx=mp_x_coord(h); mp_miny=mp_y_coord(h); + mp_maxx=mp_minx; mp_maxy=mp_miny; + p=h; + do { + if ( mp_right_type(p)==mp_endpoint ) return; + q=mp_link(p); + mp_bound_cubic(mp, x_loc(p),x_loc(q),mp_x_code); + mp_bound_cubic(mp, y_loc(p),y_loc(q),mp_y_code); + p=q; + } while (p!=h); +} + +@ Another important way to measure a path is to find its arc length. This +is best done by using the general bisection algorithm to subdivide the path +until obtaining ``well behaved'' subpaths whose arc lengths can be approximated +by simple means. + +Since the arc length is the integral with respect to time of the magnitude of +the velocity, it is natural to use Simpson's rule for the approximation. +@^Simpson's rule@> +If $\dot B(t)$ is the spline velocity, Simpson's rule gives +$$ \vb\dot B(0)\vb + 4\vb\dot B({1\over2})\vb + \vb\dot B(1)\vb \over 6 $$ +for the arc length of a path of length~1. For a cubic spline +$B(z_0,z_1,z_2,z_3;t)$, the time derivative $\dot B(t)$ is +$3B(dz_0,dz_1,dz_2;t)$, where $dz_i=z_{i+1}-z_i$. Hence the arc length +approximation is +$$ {\vb dz_0\vb \over 2} + 2\vb dz_{02}\vb + {\vb dz_2\vb \over 2}, $$ +where +$$ dz_{02}={1\over2}\left({dz_0+dz_1\over 2}+{dz_1+dz_2\over 2}\right)$$ +is the result of the bisection algorithm. + +@ The remaining problem is how to decide when a subpath is ``well behaved.'' +This could be done via the theoretical error bound for Simpson's rule, +@^Simpson's rule@> +but this is impractical because it requires an estimate of the fourth +derivative of the quantity being integrated. It is much easier to just perform +a bisection step and see how much the arc length estimate changes. Since the +error for Simpson's rule is proportional to the fourth power of the sample +spacing, the remaining error is typically about $1\over16$ of the amount of +the change. We say ``typically'' because the error has a pseudo-random behavior +that could cause the two estimates to agree when each contain large errors. + +To protect against disasters such as undetected cusps, the bisection process +should always continue until all the $dz_i$ vectors belong to a single +$90^\circ$ sector. This ensures that no point on the spline can have velocity +less than 70\% of the minimum of $\vb dz_0\vb$, $\vb dz_1\vb$ and $\vb dz_2\vb$. +If such a spline happens to produce an erroneous arc length estimate that +is little changed by bisection, the amount of the error is likely to be fairly +small. We will try to arrange things so that freak accidents of this type do +not destroy the inverse relationship between the \&{arclength} and +\&{arctime} operations. +@:arclength_}{\&{arclength} primitive@> +@:arctime_}{\&{arctime} primitive@> + +@ The \&{arclength} and \&{arctime} operations are both based on a recursive +@^recursion@> +function that finds the arc length of a cubic spline given $dz_0$, $dz_1$, +$dz_2$. This |arc_test| routine also takes an arc length goal |a_goal| and +returns the time when the arc length reaches |a_goal| if there is such a time. +Thus the return value is either an arc length less than |a_goal| or, if the +arc length would be at least |a_goal|, it returns a time value decreased by +|two|. This allows the caller to use the sign of the result to distinguish +between arc lengths and time values. On certain types of overflow, it is +possible for |a_goal| and the result of |arc_test| both to be |el_gordo|. +Otherwise, the result is always less than |a_goal|. + +Rather than halving the control point coordinates on each recursive call to +|arc_test|, it is better to keep them proportional to velocity on the original +curve and halve the results instead. This means that recursive calls can +potentially use larger error tolerances in their arc length estimates. How +much larger depends on to what extent the errors behave as though they are +independent of each other. To save computing time, we use optimistic assumptions +and increase the tolerance by a factor of about $\sqrt2$ for each recursive +call. + +In addition to the tolerance parameter, |arc_test| should also have parameters +for ${1\over3}\vb\dot B(0)\vb$, ${2\over3}\vb\dot B({1\over2})\vb$, and +${1\over3}\vb\dot B(1)\vb$. These quantities are relatively expensive to compute +and they are needed in different instances of |arc_test|. + +@c +static scaled mp_arc_test (MP mp, scaled dx0, scaled dy0, scaled dx1, scaled dy1, + scaled dx2, scaled dy2, scaled v0, scaled v02, + scaled v2, scaled a_goal, scaled tol) { + boolean simple; /* are the control points confined to a $90^\circ$ sector? */ + scaled dx01, dy01, dx12, dy12, dx02, dy02; /* bisection results */ + scaled v002, v022; + /* twice the velocity magnitudes at $t={1\over4}$ and $t={3\over4}$ */ + scaled arc; /* best arc length estimate before recursion */ + @<Other local variables in |arc_test|@>; + @<Bisect the B\'ezier quadratic given by |dx0|, |dy0|, |dx1|, |dy1|, + |dx2|, |dy2|@>; + @<Initialize |v002|, |v022|, and the arc length estimate |arc|; if it overflows + set |arc_test| and |return|@>; + @<Test if the control points are confined to one quadrant or rotating them + $45^\circ$ would put them in one quadrant. Then set |simple| appropriately@>; + if ( simple && (abs(arc-v02-halfp(v0+v2)) <= tol) ) { + if ( arc < a_goal ) { + return arc; + } else { + @<Estimate when the arc length reaches |a_goal| and set |arc_test| to + that time minus |two|@>; + } + } else { + @<Use one or two recursive calls to compute the |arc_test| function@>; + } +} + +@ The |tol| value should by multiplied by $\sqrt 2$ before making recursive +calls, but $1.5$ is an adequate approximation. It is best to avoid using +|make_fraction| in this inner loop. +@^inner loop@> + +@<Use one or two recursive calls to compute the |arc_test| function@>= +{ + @<Set |a_new| and |a_aux| so their sum is |2*a_goal| and |a_new| is as + large as possible@>; + tol = tol + halfp(tol); + a = mp_arc_test(mp, dx0,dy0, dx01,dy01, dx02,dy02, v0, v002, + halfp(v02), a_new, tol); + if ( a<0 ) { + return (-halfp(two-a)); + } else { + @<Update |a_new| to reduce |a_new+a_aux| by |a|@>; + b = mp_arc_test(mp, dx02,dy02, dx12,dy12, dx2,dy2, + halfp(v02), v022, v2, a_new, tol); + if ( b<0 ) + return (-halfp(-b) - half_unit); + else + return (a + half(b-a)); + } +} + +@ @<Other local variables in |arc_test|@>= +scaled a,b; /* results of recursive calls */ +scaled a_new,a_aux; /* the sum of these gives the |a_goal| */ + +@ @<Set |a_new| and |a_aux| so their sum is |2*a_goal| and |a_new| is...@>= +a_aux = el_gordo - a_goal; +if ( a_goal > a_aux ) { + a_aux = a_goal - a_aux; + a_new = el_gordo; +} else { + a_new = a_goal + a_goal; + a_aux = 0; +} + +@ There is no need to maintain |a_aux| at this point so we use it as a temporary +to force the additions and subtractions to be done in an order that avoids +overflow. + +@<Update |a_new| to reduce |a_new+a_aux| by |a|@>= +if ( a > a_aux ) { + a_aux = a_aux - a; + a_new = a_new + a_aux; +} + +@ This code assumes all {\it dx} and {\it dy} variables have magnitude less than +|fraction_four|. To simplify the rest of the |arc_test| routine, we strengthen +this assumption by requiring the norm of each $({\it dx},{\it dy})$ pair to obey +this bound. Note that recursive calls will maintain this invariant. + +@<Bisect the B\'ezier quadratic given by |dx0|, |dy0|, |dx1|, |dy1|,...@>= +dx01 = half(dx0 + dx1); +dx12 = half(dx1 + dx2); +dx02 = half(dx01 + dx12); +dy01 = half(dy0 + dy1); +dy12 = half(dy1 + dy2); +dy02 = half(dy01 + dy12) + +@ We should be careful to keep |arc<el_gordo| so that calling |arc_test| with +|a_goal=el_gordo| is guaranteed to yield the arc length. + +@<Initialize |v002|, |v022|, and the arc length estimate |arc|;...@>= +v002 = mp_pyth_add(mp, dx01+half(dx0+dx02), dy01+half(dy0+dy02)); +v022 = mp_pyth_add(mp, dx12+half(dx02+dx2), dy12+half(dy02+dy2)); +tmp = halfp(v02+2); +arc1 = v002 + half(halfp(v0+tmp) - v002); +arc = v022 + half(halfp(v2+tmp) - v022); +if ( (arc < el_gordo-arc1) ) { + arc = arc+arc1; +} else { + mp->arith_error = true; + if ( a_goal==el_gordo ) return (el_gordo); + else return (-two); +} + +@ @<Other local variables in |arc_test|@>= +scaled tmp, tmp2; /* all purpose temporary registers */ +scaled arc1; /* arc length estimate for the first half */ + +@ @<Test if the control points are confined to one quadrant or rotating...@>= +simple = ((dx0>=0) && (dx1>=0) && (dx2>=0)) || + ((dx0<=0) && (dx1<=0) && (dx2<=0)); +if ( simple ) + simple = ((dy0>=0) && (dy1>=0) && (dy2>=0)) || + ((dy0<=0) && (dy1<=0) && (dy2<=0)); +if ( ! simple ) { + simple = ((dx0>=dy0) && (dx1>=dy1) && (dx2>=dy2)) || + ((dx0<=dy0) && (dx1<=dy1) && (dx2<=dy2)); + if ( simple ) + simple = ((-dx0>=dy0) && (-dx1>=dy1) && (-dx2>=dy2)) || + ((-dx0<=dy0) && (-dx1<=dy1) && (-dx2<=dy2)); +} + +@ Since Simpson's rule is based on approximating the integrand by a parabola, +@^Simpson's rule@> +it is appropriate to use the same approximation to decide when the integral +reaches the intermediate value |a_goal|. At this point +$$\eqalign{ + {\vb\dot B(0)\vb\over 3} &= \hbox{|v0|}, \qquad + {\vb\dot B({1\over4})\vb\over 3} = {\hbox{|v002|}\over 2}, \qquad + {\vb\dot B({1\over2})\vb\over 3} = {\hbox{|v02|}\over 2}, \cr + {\vb\dot B({3\over4})\vb\over 3} &= {\hbox{|v022|}\over 2}, \qquad + {\vb\dot B(1)\vb\over 3} = \hbox{|v2|} \cr +} +$$ +and +$$ {\vb\dot B(t)\vb\over 3} \approx + \cases{B\left(\hbox{|v0|}, + \hbox{|v002|}-{1\over 2}\hbox{|v0|}-{1\over 4}\hbox{|v02|}, + {1\over 2}\hbox{|v02|}; 2t \right)& + if $t\le{1\over 2}$\cr + B\left({1\over 2}\hbox{|v02|}, + \hbox{|v022|}-{1\over 4}\hbox{|v02|}-{1\over 2}\hbox{|v2|}, + \hbox{|v2|}; 2t-1 \right)& + if $t\ge{1\over 2}$.\cr} + \eqno (*) +$$ +We can integrate $\vb\dot B(t)\vb$ by using +$$\int 3B(a,b,c;\tau)\,dt = + {B(0,a,a+b,a+b+c;\tau) + {\rm constant} \over {d\tau\over dt}}. +$$ + +This construction allows us to find the time when the arc length reaches +|a_goal| by solving a cubic equation of the form +$$ B(0,a,a+b,a+b+c;\tau) = x, $$ +where $\tau$ is $2t$ or $2t+1$, $x$ is |a_goal| or |a_goal-arc1|, and $a$, $b$, +and $c$ are the Bernshte{\u\i}n coefficients from $(*)$ divided by +@^Bernshte{\u\i}n, Serge{\u\i} Natanovich@> +$d\tau\over dt$. We shall define a function |solve_rising_cubic| that finds +$\tau$ given $a$, $b$, $c$, and $x$. + +@<Estimate when the arc length reaches |a_goal| and set |arc_test| to...@>= +{ + tmp = (v02 + 2) / 4; + if ( a_goal<=arc1 ) { + tmp2 = halfp(v0); + return + (halfp(mp_solve_rising_cubic(mp, tmp2, arc1-tmp2-tmp, tmp, a_goal))- two); + } else { + tmp2 = halfp(v2); + return ((half_unit - two) + + halfp(mp_solve_rising_cubic(mp, tmp, arc-arc1-tmp-tmp2, tmp2, a_goal-arc1))); + } +} + +@ Here is the |solve_rising_cubic| routine that finds the time~$t$ when +$$ B(0, a, a+b, a+b+c; t) = x. $$ +This routine is based on |crossing_point| but is simplified by the +assumptions that $B(a,b,c;t)\ge0$ for $0\le t\le1$ and that |0<=x<=a+b+c|. +If rounding error causes this condition to be violated slightly, we just ignore +it and proceed with binary search. This finds a time when the function value +reaches |x| and the slope is positive. + +@<Declarations@>= +static scaled mp_solve_rising_cubic (MP mp,scaled a, scaled b, scaled c, scaled x) ; + +@ @c +scaled mp_solve_rising_cubic (MP mp,scaled a, scaled b, scaled c, scaled x) { + scaled ab, bc, ac; /* bisection results */ + integer t; /* $2^k+q$ where unscaled answer is in $[q2^{-k},(q+1)2^{-k})$ */ + integer xx; /* temporary for updating |x| */ + if ( (a<0) || (c<0) ) mp_confusion(mp, "rising?"); +@:this can't happen rising?}{\quad rising?@> + if ( x<=0 ) { + return 0; + } else if ( x >= a+b+c ) { + return unity; + } else { + t = 1; + @<Rescale if necessary to make sure |a|, |b|, and |c| are all less than + |el_gordo div 3|@>; + do { + t+=t; + @<Subdivide the B\'ezier quadratic defined by |a|, |b|, |c|@>; + xx = x - a - ab - ac; + if ( xx < -x ) { x+=x; b=ab; c=ac; } + else { x = x + xx; a=ac; b=bc; t = t+1; }; + } while (t < unity); + return (t - unity); + } +} + +@ @<Subdivide the B\'ezier quadratic defined by |a|, |b|, |c|@>= +ab = half(a+b); +bc = half(b+c); +ac = half(ab+bc) + +@ @d one_third_el_gordo 05252525252 /* upper bound on |a|, |b|, and |c| */ + +@<Rescale if necessary to make sure |a|, |b|, and |c| are all less than...@>= +while ((a>one_third_el_gordo)||(b>one_third_el_gordo)||(c>one_third_el_gordo)) { + a = halfp(a); + b = half(b); + c = halfp(c); + x = halfp(x); +} + +@ It is convenient to have a simpler interface to |arc_test| that requires no +unnecessary arguments and ensures that each $({\it dx},{\it dy})$ pair has +length less than |fraction_four|. + +@d arc_tol 16 /* quit when change in arc length estimate reaches this */ + +@c static scaled mp_do_arc_test (MP mp,scaled dx0, scaled dy0, scaled dx1, + scaled dy1, scaled dx2, scaled dy2, scaled a_goal) { + scaled v0,v1,v2; /* length of each $({\it dx},{\it dy})$ pair */ + scaled v02; /* twice the norm of the quadratic at $t={1\over2}$ */ + v0 = mp_pyth_add(mp, dx0,dy0); + v1 = mp_pyth_add(mp, dx1,dy1); + v2 = mp_pyth_add(mp, dx2,dy2); + if ( (v0>=fraction_four) || (v1>=fraction_four) || (v2>=fraction_four) ) { + mp->arith_error = true; + if ( a_goal==el_gordo ) return el_gordo; + else return (-two); + } else { + v02 = mp_pyth_add(mp, dx1+half(dx0+dx2), dy1+half(dy0+dy2)); + return (mp_arc_test(mp, dx0,dy0, dx1,dy1, dx2,dy2, + v0, v02, v2, a_goal, arc_tol)); + } +} + +@ Now it is easy to find the arc length of an entire path. + +@c static scaled mp_get_arc_length (MP mp,pointer h) { + pointer p,q; /* for traversing the path */ + scaled a,a_tot; /* current and total arc lengths */ + a_tot = 0; + p = h; + while ( mp_right_type(p)!=mp_endpoint ){ + q = mp_link(p); + a = mp_do_arc_test(mp, mp_right_x(p)-mp_x_coord(p), mp_right_y(p)-mp_y_coord(p), + mp_left_x(q)-mp_right_x(p), mp_left_y(q)-mp_right_y(p), + mp_x_coord(q)-mp_left_x(q), mp_y_coord(q)-mp_left_y(q), el_gordo); + a_tot = mp_slow_add(mp, a, a_tot); + if ( q==h ) break; else p=q; + } + check_arith; + return a_tot; +} + +@ The inverse operation of finding the time on a path~|h| when the arc length +reaches some value |arc0| can also be accomplished via |do_arc_test|. Some care +is required to handle very large times or negative times on cyclic paths. For +non-cyclic paths, |arc0| values that are negative or too large cause +|get_arc_time| to return 0 or the length of path~|h|. + +If |arc0| is greater than the arc length of a cyclic path~|h|, the result is a +time value greater than the length of the path. Since it could be much greater, +we must be prepared to compute the arc length of path~|h| and divide this into +|arc0| to find how many multiples of the length of path~|h| to add. + +@c static scaled mp_get_arc_time (MP mp,pointer h, scaled arc0) { + pointer p,q; /* for traversing the path */ + scaled t_tot; /* accumulator for the result */ + scaled t; /* the result of |do_arc_test| */ + scaled arc; /* portion of |arc0| not used up so far */ + integer n; /* number of extra times to go around the cycle */ + if ( arc0<0 ) { + @<Deal with a negative |arc0| value and |return|@>; + } + if ( arc0==el_gordo ) decr(arc0); + t_tot = 0; + arc = arc0; + p = h; + while ( (mp_right_type(p)!=mp_endpoint) && (arc>0) ) { + q = mp_link(p); + t = mp_do_arc_test(mp, mp_right_x(p)-mp_x_coord(p), mp_right_y(p)-mp_y_coord(p), + mp_left_x(q)-mp_right_x(p), mp_left_y(q)-mp_right_y(p), + mp_x_coord(q)-mp_left_x(q), mp_y_coord(q)-mp_left_y(q), arc); + @<Update |arc| and |t_tot| after |do_arc_test| has just returned |t|@>; + if ( q==h ) { + @<Update |t_tot| and |arc| to avoid going around the cyclic + path too many times but set |arith_error:=true| and |goto done| on + overflow@>; + } + p = q; + } + check_arith; + return t_tot; +} + +@ @<Update |arc| and |t_tot| after |do_arc_test| has just returned |t|@>= +if ( t<0 ) { t_tot = t_tot + t + two; arc = 0; } +else { t_tot = t_tot + unity; arc = arc - t; } + +@ @<Deal with a negative |arc0| value and |return|@>= +{ + if ( mp_left_type(h)==mp_endpoint ) { + t_tot=0; + } else { + p = mp_htap_ypoc(mp, h); + t_tot = -mp_get_arc_time(mp, p, -arc0); + mp_toss_knot_list(mp, p); + } + check_arith; + return t_tot; +} + +@ @<Update |t_tot| and |arc| to avoid going around the cyclic...@>= +if ( arc>0 ) { + n = arc / (arc0 - arc); + arc = arc - n*(arc0 - arc); + if ( t_tot > (el_gordo / (n+1)) ) { + return el_gordo; + } + t_tot = (n + 1)*t_tot; +} + +@* \[20] Data structures for pens. +A Pen in \MP\ can be either elliptical or polygonal. Elliptical pens result +in \ps\ \&{stroke} commands, while anything drawn with a polygonal pen is +@:stroke}{\&{stroke} command@> +converted into an area fill as described in the next part of this program. +The mathematics behind this process is based on simple aspects of the theory +of tracings developed by Leo Guibas, Lyle Ramshaw, and Jorge Stolfi +[``A kinematic framework for computational geometry,'' Proc.\ IEEE Symp.\ +Foundations of Computer Science {\bf 24} (1983), 100--111]. + +Polygonal pens are created from paths via \MP's \&{makepen} primitive. +@:makepen_}{\&{makepen} primitive@> +This path representation is almost sufficient for our purposes except that +a pen path should always be a convex polygon with the vertices in +counter-clockwise order. +Since we will need to scan pen polygons both forward and backward, a pen +should be represented as a doubly linked ring of knot nodes. There is +room for the extra back pointer because we do not need the +|mp_left_type| or |mp_right_type| fields. In fact, we don't need the |mp_left_x|, +|mp_left_y|, |mp_right_x|, or |mp_right_y| fields either but we leave these alone +so that certain procedures can operate on both pens and paths. In particular, +pens can be copied using |copy_path| and recycled using |toss_knot_list|. + +@d knil mp_info + /* this replaces the |mp_left_type| and |mp_right_type| fields in a pen knot */ + +@ The |make_pen| procedure turns a path into a pen by initializing +the |knil| pointers and making sure the knots form a convex polygon. +Thus each cubic in the given path becomes a straight line and the control +points are ignored. If the path is not cyclic, the ends are connected by a +straight line. + +@d copy_pen(A) mp_make_pen(mp, mp_copy_path(mp, (A)),false) + +@c +static pointer mp_make_pen (MP mp,pointer h, boolean need_hull) { + pointer p,q; /* two consecutive knots */ + q=h; + do { + p=q; q=mp_link(q); + knil(q)=p; + } while (q!=h); + if ( need_hull ){ + h=mp_convex_hull(mp, h); + @<Make sure |h| isn't confused with an elliptical pen@>; + } + return h; +} + +@ The only information required about an elliptical pen is the overall +transformation that has been applied to the original \&{pencircle}. +@:pencircle_}{\&{pencircle} primitive@> +Since it suffices to keep track of how the three points $(0,0)$, $(1,0)$, +and $(0,1)$ are transformed, an elliptical pen can be stored in a single +knot node and transformed as if it were a path. + +@d pen_is_elliptical(A) ((A)==mp_link((A))) + +@c +static pointer mp_get_pen_circle (MP mp,scaled diam) { + pointer h; /* the knot node to return */ + h=mp_get_node(mp, knot_node_size); + mp_link(h)=h; knil(h)=h; + mp_originator(h)=mp_program_code; + mp_x_coord(h)=0; mp_y_coord(h)=0; + mp_left_x(h)=diam; mp_left_y(h)=0; + mp_right_x(h)=0; mp_right_y(h)=diam; + return h; +} + +@ If the polygon being returned by |make_pen| has only one vertex, it will +be interpreted as an elliptical pen. This is no problem since a degenerate +polygon can equally well be thought of as a degenerate ellipse. We need only +initialize the |mp_left_x|, |mp_left_y|, |mp_right_x|, and |mp_right_y| fields. + +@<Make sure |h| isn't confused with an elliptical pen@>= +if ( pen_is_elliptical( h) ){ + mp_left_x(h)=mp_x_coord(h); mp_left_y(h)=mp_y_coord(h); + mp_right_x(h)=mp_x_coord(h); mp_right_y(h)=mp_y_coord(h); +} + +@ Printing a polygonal pen is very much like printing a path + +@<Declarations@>= +static void mp_pr_pen (MP mp,pointer h) ; + +@ @c +void mp_pr_pen (MP mp,pointer h) { + pointer p,q; /* for list traversal */ + if ( pen_is_elliptical(h) ) { + @<Print the elliptical pen |h|@>; + } else { + p=h; + do { + mp_print_two(mp, mp_x_coord(p),mp_y_coord(p)); + mp_print_nl(mp, " .. "); + @<Advance |p| making sure the links are OK and |return| if there is + a problem@>; + } while (p!=h); + mp_print(mp, "cycle"); + } +} + +@ @<Advance |p| making sure the links are OK and |return| if there is...@>= +q=mp_link(p); +if ( (q==null) || (knil(q)!=p) ) { + mp_print_nl(mp, "???"); return; /* this won't happen */ +@.???@> +} +p=q + +@ @<Print the elliptical pen |h|@>= +{ +mp_print(mp, "pencircle transformed ("); +mp_print_scaled(mp, mp_x_coord(h)); +mp_print_char(mp, xord(',')); +mp_print_scaled(mp, mp_y_coord(h)); +mp_print_char(mp, xord(',')); +mp_print_scaled(mp, mp_left_x(h)-mp_x_coord(h)); +mp_print_char(mp, xord(',')); +mp_print_scaled(mp, mp_right_x(h)-mp_x_coord(h)); +mp_print_char(mp, xord(',')); +mp_print_scaled(mp, mp_left_y(h)-mp_y_coord(h)); +mp_print_char(mp, xord(',')); +mp_print_scaled(mp, mp_right_y(h)-mp_y_coord(h)); +mp_print_char(mp, xord(')')); +} + +@ Here us another version of |pr_pen| that prints the pen as a diagnostic +message. + +@<Declarations@>= +static void mp_print_pen (MP mp,pointer h, const char *s, boolean nuline) ; + +@ @c +void mp_print_pen (MP mp,pointer h, const char *s, boolean nuline) { + mp_print_diagnostic(mp, "Pen",s,nuline); mp_print_ln(mp); +@.Pen at line...@> + mp_pr_pen(mp, h); + mp_end_diagnostic(mp, true); +} + +@ Making a polygonal pen into a path involves restoring the |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,pointer h) { + pointer p; /* for traversing the knot list */ + quarterword k; /* a loop counter */ + @<Other local variables in |make_path|@>; + if ( pen_is_elliptical(h) ) { + @<Make the elliptical pen |h| into a path@>; + } else { + p=h; + do { + mp_left_type(p)=mp_explicit; + mp_right_type(p)=mp_explicit; + @<copy the coordinates of knot |p| into its control points@>; + p=mp_link(p); + } while (p!=h); + } +} + +@ @<copy the coordinates of knot |p| into its control points@>= +mp_left_x(p)=mp_x_coord(p); +mp_left_y(p)=mp_y_coord(p); +mp_right_x(p)=mp_x_coord(p); +mp_right_y(p)=mp_y_coord(p) + +@ We need an eight knot path to get a good approximation to an ellipse. + +@<Make the elliptical pen |h| into a path@>= +{ + @<Extract the transformation parameters from the elliptical pen~|h|@>; + p=h; + for (k=0;k<=7;k++ ) { + @<Initialize |p| as the |k|th knot of a circle of unit diameter, + transforming it appropriately@>; + if ( k==7 ) mp_link(p)=h; else mp_link(p)=mp_get_node(mp, knot_node_size); + p=mp_link(p); + } +} + +@ @<Extract the transformation parameters from the elliptical pen~|h|@>= +center_x=mp_x_coord(h); +center_y=mp_y_coord(h); +width_x=mp_left_x(h)-center_x; +width_y=mp_left_y(h)-center_y; +height_x=mp_right_x(h)-center_x; +height_y=mp_right_y(h)-center_y + +@ @<Other local variables in |make_path|@>= +scaled center_x,center_y; /* translation parameters for an elliptical pen */ +scaled width_x,width_y; /* the effect of a unit change in $x$ */ +scaled height_x,height_y; /* the effect of a unit change in $y$ */ +scaled dx,dy; /* the vector from knot |p| to its right control point */ +integer kk; + /* |k| advanced $270^\circ$ around the ring (cf. $\sin\theta=\cos(\theta+270)$) */ + +@ The only tricky thing here are the tables |half_cos| and |d_cos| used to +find the point $k/8$ of the way around the circle and the direction vector +to use there. + +@<Initialize |p| as the |k|th knot of a circle of unit diameter,...@>= +kk=(k+6)% 8; +mp_x_coord(p)=center_x+mp_take_fraction(mp, mp->half_cos[k],width_x) + +mp_take_fraction(mp, mp->half_cos[kk],height_x); +mp_y_coord(p)=center_y+mp_take_fraction(mp, mp->half_cos[k],width_y) + +mp_take_fraction(mp, mp->half_cos[kk],height_y); +dx=-mp_take_fraction(mp, mp->d_cos[kk],width_x) + +mp_take_fraction(mp, mp->d_cos[k],height_x); +dy=-mp_take_fraction(mp, mp->d_cos[kk],width_y) + +mp_take_fraction(mp, mp->d_cos[k],height_y); +mp_right_x(p)=mp_x_coord(p)+dx; +mp_right_y(p)=mp_y_coord(p)+dy; +mp_left_x(p)=mp_x_coord(p)-dx; +mp_left_y(p)=mp_y_coord(p)-dy; +mp_left_type(p)=mp_explicit; +mp_right_type(p)=mp_explicit; +mp_originator(p)=mp_program_code + +@ @<Glob...@>= +fraction half_cos[8]; /* ${1\over2}\cos(45k)$ */ +fraction d_cos[8]; /* a magic constant times $\cos(45k)$ */ + +@ The magic constant for |d_cos| is the distance between $({1\over2},0)$ and +$({1\over4}\sqrt2,{1\over4}\sqrt2)$ times the result of the |velocity| +function for $\theta=\phi=22.5^\circ$. This comes out to be +$$ d = {\sqrt{2-\sqrt2}\over 3+3\cos22.5^\circ} + \approx 0.132608244919772. +$$ + +@<Set init...@>= +mp->half_cos[0]=fraction_half; +mp->half_cos[1]=94906266; /* $2^{26}\sqrt2\approx94906265.62$ */ +mp->half_cos[2]=0; +mp->d_cos[0]=35596755; /* $2^{28}d\approx35596754.69$ */ +mp->d_cos[1]=25170707; /* $2^{27}\sqrt2\,d\approx25170706.63$ */ +mp->d_cos[2]=0; +for (k=3;k<= 4;k++ ) { + mp->half_cos[k]=-mp->half_cos[4-k]; + mp->d_cos[k]=-mp->d_cos[4-k]; +} +for (k=5;k<= 7;k++ ) { + mp->half_cos[k]=mp->half_cos[8-k]; + mp->d_cos[k]=mp->d_cos[8-k]; +} + +@ The |convex_hull| function forces a pen polygon to be convex when it is +returned by |make_pen| and after any subsequent transformation where rounding +error might allow the convexity to be lost. +The convex hull algorithm used here is described by F.~P. Preparata and +M.~I. Shamos [{\sl Computational Geometry}, Springer-Verlag, 1985]. + +@<Declarations@>= +static pointer mp_convex_hull (MP mp,pointer h); + +@ @c +pointer mp_convex_hull (MP mp,pointer h) { /* Make a polygonal pen convex */ + pointer l,r; /* the leftmost and rightmost knots */ + pointer p,q; /* knots being scanned */ + pointer s; /* the starting point for an upcoming scan */ + scaled dx,dy; /* a temporary pointer */ + if ( pen_is_elliptical(h) ) { + return h; + } else { + @<Set |l| to the leftmost knot in polygon~|h|@>; + @<Set |r| to the rightmost knot in polygon~|h|@>; + if ( l!=r ) { + s=mp_link(r); + @<Find any knots on the path from |l| to |r| above the |l|-|r| line and + move them past~|r|@>; + @<Find any knots on the path from |s| to |l| below the |l|-|r| line and + move them past~|l|@>; + @<Sort the path from |l| to |r| by increasing $x$@>; + @<Sort the path from |r| to |l| by decreasing $x$@>; + } + if ( l!=mp_link(l) ) { + @<Do a Gramm scan and remove vertices where there is no left turn@>; + } + return l; + } +} + +@ All comparisons are done primarily on $x$ and secondarily on $y$. + +@<Set |l| to the leftmost knot in polygon~|h|@>= +l=h; +p=mp_link(h); +while ( p!=h ) { + if ( mp_x_coord(p)<=mp_x_coord(l) ) + if ( (mp_x_coord(p)<mp_x_coord(l)) || (mp_y_coord(p)<mp_y_coord(l)) ) + l=p; + p=mp_link(p); +} + +@ @<Set |r| to the rightmost knot in polygon~|h|@>= +r=h; +p=mp_link(h); +while ( p!=h ) { + if ( mp_x_coord(p)>=mp_x_coord(r) ) + if ( (mp_x_coord(p)>mp_x_coord(r)) || (mp_y_coord(p)>mp_y_coord(r)) ) + r=p; + p=mp_link(p); +} + +@ @<Find any knots on the path from |l| to |r| above the |l|-|r| line...@>= +dx=mp_x_coord(r)-mp_x_coord(l); +dy=mp_y_coord(r)-mp_y_coord(l); +p=mp_link(l); +while ( p!=r ) { + q=mp_link(p); + if ( mp_ab_vs_cd(mp, dx,mp_y_coord(p)-mp_y_coord(l),dy,mp_x_coord(p)-mp_x_coord(l))>0 ) + mp_move_knot(mp, p, r); + p=q; +} + +@ The |move_knot| procedure removes |p| from a doubly linked list and inserts +it after |q|. + +@ @<Declarations@>= +static void mp_move_knot (MP mp,pointer p, pointer q) ; + +@ @c +void mp_move_knot (MP mp,pointer p, pointer q) { + mp_link(knil(p))=mp_link(p); + knil(mp_link(p))=knil(p); + knil(p)=q; + mp_link(p)=mp_link(q); + mp_link(q)=p; + knil(mp_link(p))=p; +} + +@ @<Find any knots on the path from |s| to |l| below the |l|-|r| line...@>= +p=s; +while ( p!=l ) { + q=mp_link(p); + if ( mp_ab_vs_cd(mp, dx,mp_y_coord(p)-mp_y_coord(l),dy,mp_x_coord(p)-mp_x_coord(l))<0 ) + mp_move_knot(mp, p,l); + p=q; +} + +@ The list is likely to be in order already so we just do linear insertions. +Secondary comparisons on $y$ ensure that the sort is consistent with the +choice of |l| and |r|. + +@<Sort the path from |l| to |r| by increasing $x$@>= +p=mp_link(l); +while ( p!=r ) { + q=knil(p); + while ( mp_x_coord(q)>mp_x_coord(p) ) q=knil(q); + while ( mp_x_coord(q)==mp_x_coord(p) ) { + if ( mp_y_coord(q)>mp_y_coord(p) ) q=knil(q); else break; + } + if ( q==knil(p) ) p=mp_link(p); + else { p=mp_link(p); mp_move_knot(mp, knil(p),q); }; +} + +@ @<Sort the path from |r| to |l| by decreasing $x$@>= +p=mp_link(r); +while ( p!=l ){ + q=knil(p); + while ( mp_x_coord(q)<mp_x_coord(p) ) q=knil(q); + while ( mp_x_coord(q)==mp_x_coord(p) ) { + if ( mp_y_coord(q)<mp_y_coord(p) ) q=knil(q); else break; + } + if ( q==knil(p) ) p=mp_link(p); + else { p=mp_link(p); mp_move_knot(mp, knil(p),q); }; +} + +@ The condition involving |ab_vs_cd| tests if there is not a left turn +at knot |q|. There usually will be a left turn so we streamline the case +where the |then| clause is not executed. + +@<Do a Gramm scan and remove vertices where there...@>= +{ +p=l; q=mp_link(l); +while (1) { + dx=mp_x_coord(q)-mp_x_coord(p); + dy=mp_y_coord(q)-mp_y_coord(p); + p=q; q=mp_link(q); + if ( p==l ) break; + if ( p!=r ) + if ( mp_ab_vs_cd(mp, dx,mp_y_coord(q)-mp_y_coord(p),dy,mp_x_coord(q)-mp_x_coord(p))<=0 ) { + @<Remove knot |p| and back up |p| and |q| but don't go past |l|@>; + } + } +} + +@ @<Remove knot |p| and back up |p| and |q| but don't go past |l|@>= +{ +s=knil(p); +mp_free_node(mp, p,knot_node_size); +mp_link(s)=q; knil(q)=s; +if ( s==l ) p=s; +else { p=knil(s); q=s; }; +} + +@ The |find_offset| procedure sets global variables |(cur_x,cur_y)| to the +offset associated with the given direction |(x,y)|. If two different offsets +apply, it chooses one of them. + +@c +static void mp_find_offset (MP mp,scaled x, scaled y, pointer h) { + pointer p,q; /* consecutive knots */ + scaled wx,wy,hx,hy; + /* the transformation matrix for an elliptical pen */ + fraction xx,yy; /* untransformed offset for an elliptical pen */ + fraction d; /* a temporary register */ + if ( pen_is_elliptical(h) ) { + @<Find the offset for |(x,y)| on the elliptical pen~|h|@> + } else { + q=h; + do { + p=q; q=mp_link(q); + } while (!(mp_ab_vs_cd(mp, mp_x_coord(q)-mp_x_coord(p),y, mp_y_coord(q)-mp_y_coord(p),x)>=0)); + do { + p=q; q=mp_link(q); + } while (!(mp_ab_vs_cd(mp, mp_x_coord(q)-mp_x_coord(p),y, mp_y_coord(q)-mp_y_coord(p),x)<=0)); + mp->cur_x=mp_x_coord(p); + mp->cur_y=mp_y_coord(p); + } +} + +@ @<Glob...@>= +scaled cur_x; +scaled cur_y; /* all-purpose return value registers */ + +@ @<Find the offset for |(x,y)| on the elliptical pen~|h|@>= +if ( (x==0) && (y==0) ) { + mp->cur_x=mp_x_coord(h); mp->cur_y=mp_y_coord(h); +} else { + @<Find the non-constant part of the transformation for |h|@>; + while ( (abs(x)<fraction_half) && (abs(y)<fraction_half) ){ + x+=x; y+=y; + }; + @<Make |(xx,yy)| the offset on the untransformed \&{pencircle} for the + untransformed version of |(x,y)|@>; + mp->cur_x=mp_x_coord(h)+mp_take_fraction(mp, xx,wx)+mp_take_fraction(mp, yy,hx); + mp->cur_y=mp_y_coord(h)+mp_take_fraction(mp, xx,wy)+mp_take_fraction(mp, yy,hy); +} + +@ @<Find the non-constant part of the transformation for |h|@>= +wx=mp_left_x(h)-mp_x_coord(h); +wy=mp_left_y(h)-mp_y_coord(h); +hx=mp_right_x(h)-mp_x_coord(h); +hy=mp_right_y(h)-mp_y_coord(h) + +@ @<Make |(xx,yy)| the offset on the untransformed \&{pencircle} for the...@>= +yy=-(mp_take_fraction(mp, x,hy)+mp_take_fraction(mp, y,-hx)); +xx=mp_take_fraction(mp, x,-wy)+mp_take_fraction(mp, y,wx); +d=mp_pyth_add(mp, xx,yy); +if ( d>0 ) { + xx=half(mp_make_fraction(mp, xx,d)); + yy=half(mp_make_fraction(mp, yy,d)); +} + +@ Finding the bounding box of a pen is easy except if the pen is elliptical. +But we can handle that case by just calling |find_offset| twice. The answer +is stored in the global variables |minx|, |maxx|, |miny|, and |maxy|. + +@c +static void mp_pen_bbox (MP mp,pointer h) { + pointer p; /* for scanning the knot list */ + if ( pen_is_elliptical(h) ) { + @<Find the bounding box of an elliptical pen@>; + } else { + mp_minx=mp_x_coord(h); mp_maxx=mp_minx; + mp_miny=mp_y_coord(h); mp_maxy=mp_miny; + p=mp_link(h); + while ( p!=h ) { + if ( mp_x_coord(p)<mp_minx ) mp_minx=mp_x_coord(p); + if ( mp_y_coord(p)<mp_miny ) mp_miny=mp_y_coord(p); + if ( mp_x_coord(p)>mp_maxx ) mp_maxx=mp_x_coord(p); + if ( mp_y_coord(p)>mp_maxy ) mp_maxy=mp_y_coord(p); + p=mp_link(p); + } + } +} + +@ @<Find the bounding box of an elliptical pen@>= +{ +mp_find_offset(mp, 0,fraction_one,h); +mp_maxx=mp->cur_x; +mp_minx=2*mp_x_coord(h)-mp->cur_x; +mp_find_offset(mp, -fraction_one,0,h); +mp_maxy=mp->cur_y; +mp_miny=2*mp_y_coord(h)-mp->cur_y; +} + +@* \[21] Edge structures. +Now we come to \MP's internal scheme for representing pictures. +The representation is very different from \MF's edge structures +because \MP\ pictures contain \ps\ graphics objects instead of pixel +images. However, the basic idea is somewhat similar in that shapes +are represented via their boundaries. + +The main purpose of edge structures is to keep track of graphical objects +until it is time to translate them into \ps. Since \MP\ does not need to +know anything about an edge structure other than how to translate it into +\ps\ and how to find its bounding box, edge structures can be just linked +lists of graphical objects. \MP\ has no easy way to determine whether +two such objects overlap, but it suffices to draw the first one first and +let the second one overwrite it if necessary. + +@(mplib.h@>= +enum mp_graphical_object_code { + @<Graphical object codes@> + mp_final_graphic +}; + +@ Let's consider the types of graphical objects one at a time. +First of all, a filled contour is represented by a eight-word node. The first +word contains |type| and |link| fields, and the next six words contain a +pointer to a cyclic path and the value to use for \ps' \&{currentrgbcolor} +parameter. If a pen is used for filling |pen_p|, |ljoin_val| and |miterlim_val| +give the relevant information. + +@d mp_path_p(A) mp_link((A)+1) + /* a pointer to the path that needs filling */ +@d mp_pen_p(A) mp_info((A)+1) + /* a pointer to the pen to fill or stroke with */ +@d mp_color_model(A) mp_type((A)+2) /* the color model */ +@d obj_red_loc(A) ((A)+3) /* the first of three locations for the color */ +@d obj_cyan_loc obj_red_loc /* the first of four locations for the color */ +@d obj_grey_loc obj_red_loc /* the location for the color */ +@d red_val(A) mp->mem[(A)+3].sc + /* the red component of the color in the range $0\ldots1$ */ +@d cyan_val red_val +@d grey_val red_val +@d green_val(A) mp->mem[(A)+4].sc + /* the green component of the color in the range $0\ldots1$ */ +@d magenta_val green_val +@d blue_val(A) mp->mem[(A)+5].sc + /* the blue component of the color in the range $0\ldots1$ */ +@d yellow_val blue_val +@d black_val(A) mp->mem[(A)+6].sc + /* the blue component of the color in the range $0\ldots1$ */ +@d ljoin_val(A) mp_name_type((A)) /* the value of \&{linejoin} */ +@:mp_linejoin_}{\&{linejoin} primitive@> +@d miterlim_val(A) mp->mem[(A)+7].sc /* the value of \&{miterlimit} */ +@:mp_miterlimit_}{\&{miterlimit} primitive@> +@d obj_color_part(A) mp->mem[(A)+3-red_part].sc + /* interpret an object pointer that has been offset by |red_part..blue_part| */ +@d mp_pre_script(A) mp->mem[(A)+8].hh.lh +@d mp_post_script(A) mp->mem[(A)+8].hh.rh +@d fill_node_size 9 + +@ @<Graphical object codes@>= +mp_fill_code=1, + +@ @c +static pointer mp_new_fill_node (MP mp,pointer p) { + /* make a fill node for cyclic path |p| and color black */ + pointer t; /* the new node */ + t=mp_get_node(mp, fill_node_size); + mp_type(t)=mp_fill_code; + mp_path_p(t)=p; + mp_pen_p(t)=null; /* |null| means don't use a pen */ + red_val(t)=0; + green_val(t)=0; + blue_val(t)=0; + black_val(t)=0; + mp_color_model(t)=mp_uninitialized_model; + mp_pre_script(t)=null; + mp_post_script(t)=null; + @<Set the |ljoin_val| and |miterlim_val| fields in object |t|@>; + return t; +} + +@ @<Set the |ljoin_val| and |miterlim_val| fields in object |t|@>= +if ( mp->internal[mp_linejoin]>unity ) ljoin_val(t)=2; +else if ( mp->internal[mp_linejoin]>0 ) ljoin_val(t)=1; +else ljoin_val(t)=0; +if ( mp->internal[mp_miterlimit]<unity ) + miterlim_val(t)=unity; +else + miterlim_val(t)=mp->internal[mp_miterlimit] + +@ A stroked path is represented by an eight-word node that is like a filled +contour node except that it contains the current \&{linecap} value, a scale +factor for the dash pattern, and a pointer that is non-null if the stroke +is to be dashed. The purpose of the scale factor is to allow a picture to +be transformed without touching the picture that |dash_p| points to. + +@d mp_dash_p(A) mp_link((A)+9) + /* a pointer to the edge structure that gives the dash pattern */ +@d lcap_val(A) mp_type((A)+9) + /* the value of \&{linecap} */ +@:mp_linecap_}{\&{linecap} primitive@> +@d dash_scale(A) mp->mem[(A)+10].sc /* dash lengths are scaled by this factor */ +@d stroked_node_size 11 + +@ @<Graphical object codes@>= +mp_stroked_code=2, + +@ @c +static pointer mp_new_stroked_node (MP mp,pointer p) { + /* make a stroked node for path |p| with |mp_pen_p(p)| temporarily |null| */ + pointer t; /* the new node */ + t=mp_get_node(mp, stroked_node_size); + mp_type(t)=mp_stroked_code; + mp_path_p(t)=p; mp_pen_p(t)=null; + mp_dash_p(t)=null; + dash_scale(t)=unity; + red_val(t)=0; + green_val(t)=0; + blue_val(t)=0; + black_val(t)=0; + mp_color_model(t)=mp_uninitialized_model; + mp_pre_script(t)=null; + mp_post_script(t)=null; + @<Set the |ljoin_val| and |miterlim_val| fields in object |t|@>; + if ( mp->internal[mp_linecap]>unity ) lcap_val(t)=2; + else if ( mp->internal[mp_linecap]>0 ) lcap_val(t)=1; + else lcap_val(t)=0; + return t; +} + +@ When a dashed line is computed in a transformed coordinate system, the dash +lengths get scaled like the pen shape and we need to compensate for this. Since +there is no unique scale factor for an arbitrary transformation, we use the +the square root of the determinant. The properties of the determinant make it +easier to maintain the |dash_scale|. The computation is fairly straight-forward +except for the initialization of the scale factor |s|. The factor of 64 is +needed because |square_rt| scales its result by $2^8$ while we need $2^{14}$ +to counteract the effect of |take_fraction|. + +@ @c +scaled mp_sqrt_det (MP mp,scaled a, scaled b, scaled c, scaled d) { + scaled maxabs; /* $max(|a|,|b|,|c|,|d|)$ */ + unsigned s; /* amount by which the result of |square_rt| needs to be scaled */ + @<Initialize |maxabs|@>; + s=64; + while ( (maxabs<fraction_one) && (s>1) ){ + a+=a; b+=b; c+=c; d+=d; + maxabs+=maxabs; s=(unsigned)(halfp(s)); + } + return (scaled)(s*mp_square_rt(mp, abs(mp_take_fraction(mp, a,d)-mp_take_fraction(mp, b,c)))); +} +@# +static scaled mp_get_pen_scale (MP mp,pointer p) { + return mp_sqrt_det(mp, + mp_left_x(p)-mp_x_coord(p), mp_right_x(p)-mp_x_coord(p), + mp_left_y(p)-mp_y_coord(p), mp_right_y(p)-mp_y_coord(p)); +} + +@ @<Declarations@>= +static scaled mp_sqrt_det (MP mp,scaled a, scaled b, scaled c, scaled d) ; + + +@ @<Initialize |maxabs|@>= +maxabs=abs(a); +if ( abs(b)>maxabs ) maxabs=abs(b); +if ( abs(c)>maxabs ) maxabs=abs(c); +if ( abs(d)>maxabs ) maxabs=abs(d) + +@ When a picture contains text, this is represented by a fourteen-word node +where the color information and |type| and |link| fields are augmented by +additional fields that describe the text and how it is transformed. +The |path_p| and |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_link((A)+1) /* a string pointer for the text to display */ +@d mp_font_n(A) mp_info((A)+1) /* the font number */ +@d width_val(A) mp->mem[(A)+7].sc /* unscaled width of the text */ +@d height_val(A) mp->mem[(A)+9].sc /* unscaled height of the text */ +@d depth_val(A) mp->mem[(A)+10].sc /* unscaled depth of the text */ +@d text_tx_loc(A) ((A)+11) + /* the first of six locations for transformation parameters */ +@d tx_val(A) mp->mem[(A)+11].sc /* $x$ shift amount */ +@d ty_val(A) mp->mem[(A)+12].sc /* $y$ shift amount */ +@d txx_val(A) mp->mem[(A)+13].sc /* |txx| transformation parameter */ +@d txy_val(A) mp->mem[(A)+14].sc /* |txy| transformation parameter */ +@d tyx_val(A) mp->mem[(A)+15].sc /* |tyx| transformation parameter */ +@d tyy_val(A) mp->mem[(A)+16].sc /* |tyy| transformation parameter */ +@d text_trans_part(A) mp->mem[(A)+11-x_part].sc + /* interpret a text node pointer that has been offset by |x_part..yy_part| */ +@d text_node_size 17 + +@ @<Graphical object codes@>= +mp_text_code=3, + +@ @c +static pointer mp_new_text_node (MP mp,char *f,str_number s) { + /* make a text node for font |f| and text string |s| */ + pointer t; /* the new node */ + t=mp_get_node(mp, text_node_size); + mp_type(t)=mp_text_code; + mp_text_p(t)=s; + mp_font_n(t)=(halfword)mp_find_font(mp, f); /* this identifies the font */ + red_val(t)=0; + green_val(t)=0; + blue_val(t)=0; + black_val(t)=0; + mp_color_model(t)=mp_uninitialized_model; + mp_pre_script(t)=null; + mp_post_script(t)=null; + tx_val(t)=0; ty_val(t)=0; + txx_val(t)=unity; txy_val(t)=0; + tyx_val(t)=0; tyy_val(t)=unity; + mp_set_text_box(mp, t); /* this finds the bounding box */ + return t; +} + +@ The last two types of graphical objects that can occur in an edge structure +are clipping paths and \&{setbounds} paths. These are slightly more difficult +@:set_bounds_}{\&{setbounds} primitive@> +to implement because we must keep track of exactly what is being clipped or +bounded when pictures get merged together. For this reason, each clipping or +\&{setbounds} operation is represented by a pair of nodes: first comes a +two-word node whose |path_p| gives the relevant path, then there is the list +of objects to clip or bound followed by a two-word node whose second word is +unused. + +Using at least two words for each graphical object node allows them all to be +allocated and deallocated similarly with a global array |gr_object_size| to +give the size in words for each object type. + +@d start_clip_size 2 +@d start_bounds_size 2 +@d stop_clip_size 2 /* the second word is not used here */ +@d stop_bounds_size 2 /* the second word is not used here */ +@# +@d stop_type(A) ((A)+2) + /* matching |type| for |start_clip_code| or |start_bounds_code| */ +@d has_color(A) (mp_type((A))<mp_start_clip_code) + /* does a graphical object have color fields? */ +@d has_pen(A) (mp_type((A))<mp_text_code) + /* does a graphical object have a |mp_pen_p| field? */ +@d is_start_or_stop(A) (mp_type((A))>=mp_start_clip_code) +@d is_stop(A) (mp_type((A))>=mp_stop_clip_code) + +@ @<Graphical object codes@>= +mp_start_clip_code=4, /* |type| of a node that starts clipping */ +mp_start_bounds_code=5, /* |type| of a node that gives a \&{setbounds} path */ +mp_stop_clip_code=6, /* |type| of a node that stops clipping */ +mp_stop_bounds_code=7, /* |type| of a node that stops \&{setbounds} */ + +@ @c +static pointer mp_new_bounds_node (MP mp,pointer p, quarterword c) { + /* make a node of type |c| where |p| is the clipping or \&{setbounds} path */ + pointer t; /* the new node */ + t=mp_get_node(mp, mp->gr_object_size[c]); + mp_type(t)=c; + mp_path_p(t)=p; + return t; +} + +@ We need an array to keep track of the sizes of graphical objects. + +@<Glob...@>= +quarterword gr_object_size[mp_stop_bounds_code+1]; + +@ @<Set init...@>= +mp->gr_object_size[mp_fill_code]=fill_node_size; +mp->gr_object_size[mp_stroked_code]=stroked_node_size; +mp->gr_object_size[mp_text_code]=text_node_size; +mp->gr_object_size[mp_start_clip_code]=start_clip_size; +mp->gr_object_size[mp_stop_clip_code]=stop_clip_size; +mp->gr_object_size[mp_start_bounds_code]=start_bounds_size; +mp->gr_object_size[mp_stop_bounds_code]=stop_bounds_size; + +@ All the essential information in an edge structure is encoded as a linked list +of graphical objects as we have just seen, but it is helpful to add some +redundant information. A single edge structure might be used as a dash pattern +many times, and it would be nice to avoid scanning the same structure +repeatedly. Thus, an edge structure known to be a suitable dash pattern +has a header that gives a list of dashes in a sorted order designed for rapid +translation into \ps. + +Each dash is represented by a three-word node containing the initial and final +$x$~coordinates as well as the usual |link| field. The |link| fields points to +the dash node with the next higher $x$-coordinates and the final link points +to a special location called |null_dash|. (There should be no overlap between +dashes). Since the $y$~coordinate of the dash pattern is needed to determine +the period of repetition, this needs to be stored in the edge header along +with a pointer to the list of dash nodes. + +@d start_x(A) mp->mem[(A)+1].sc /* the starting $x$~coordinate in a dash node */ +@d stop_x(A) mp->mem[(A)+2].sc /* the ending $x$~coordinate in a dash node */ +@d dash_node_size 3 +@d dash_list mp_link + /* in an edge header this points to the first dash node */ +@d dash_y(A) mp->mem[(A)+1].sc /* $y$ value for the dash list in an edge header */ + +@ It is also convenient for an edge header to contain the bounding +box information needed by the \&{llcorner} and \&{urcorner} operators +so that this does not have to be recomputed unnecessarily. This is done by +adding fields for the $x$~and $y$ extremes as well as a pointer that indicates +how far the bounding box computation has gotten. Thus if the user asks for +the bounding box and then adds some more text to the picture before asking +for more bounding box information, the second computation need only look at +the additional text. + +When the bounding box has not been computed, the |bblast| pointer points +to a dummy link at the head of the graphical object list while the |minx_val| +and |miny_val| fields contain |el_gordo| and the |maxx_val| and |maxy_val| +fields contain |-el_gordo|. + +Since the bounding box of pictures containing objects of type +|mp_start_bounds_code| depends on the value of \&{truecorners}, the bounding box +@:mp_true_corners_}{\&{truecorners} primitive@> +data might not be valid for all values of this parameter. Hence, the |bbtype| +field is needed to keep track of this. + +@d minx_val(A) mp->mem[(A)+2].sc +@d miny_val(A) mp->mem[(A)+3].sc +@d maxx_val(A) mp->mem[(A)+4].sc +@d maxy_val(A) mp->mem[(A)+5].sc +@d bblast(A) mp_link((A)+6) /* last item considered in bounding box computation */ +@d bbtype(A) mp_info((A)+6) /* tells how bounding box data depends on \&{truecorners} */ +@d dummy_loc(A) ((A)+7) /* where the object list begins in an edge header */ +@d no_bounds 0 + /* |bbtype| value when bounding box data is valid for all \&{truecorners} values */ +@d bounds_set 1 + /* |bbtype| value when bounding box data is for \&{truecorners}${}\le 0$ */ +@d bounds_unset 2 + /* |bbtype| value when bounding box data is for \&{truecorners}${}>0$ */ + +@c +static void mp_init_bbox (MP mp,pointer h) { + /* Initialize the bounding box information in edge structure |h| */ + bblast(h)=dummy_loc(h); + bbtype(h)=no_bounds; + minx_val(h)=el_gordo; + miny_val(h)=el_gordo; + maxx_val(h)=-el_gordo; + maxy_val(h)=-el_gordo; +} + +@ The only other entries in an edge header are a reference count in the first +word and a pointer to the tail of the object list in the last word. + +@d obj_tail(A) mp_info((A)+7) /* points to the last entry in the object list */ +@d edge_header_size 8 + +@c +static void mp_init_edges (MP mp,pointer h) { + /* initialize an edge header to null values */ + dash_list(h)=null_dash; + obj_tail(h)=dummy_loc(h); + mp_link(dummy_loc(h))=null; + ref_count(h)=null; + mp_init_bbox(mp, h); +} + +@ Here is how edge structures are deleted. The process can be recursive because +of the need to dereference edge structures that are used as dash patterns. +@^recursion@> + +@d add_edge_ref(A) incr(ref_count(A)) +@d delete_edge_ref(A) { + if ( ref_count((A))==null ) + mp_toss_edges(mp, A); + else + decr(ref_count(A)); + } + +@<Declarations@>= +static void mp_flush_dash_list (MP mp,pointer h); +static pointer mp_toss_gr_object (MP mp,pointer p) ; +static void mp_toss_edges (MP mp,pointer h) ; + +@ @c void mp_toss_edges (MP mp,pointer h) { + pointer p,q; /* pointers that scan the list being recycled */ + pointer r; /* an edge structure that object |p| refers to */ + mp_flush_dash_list(mp, h); + q=mp_link(dummy_loc(h)); + while ( (q!=null) ) { + p=q; q=mp_link(q); + r=mp_toss_gr_object(mp, p); + if ( r!=null ) delete_edge_ref(r); + } + mp_free_node(mp, h,edge_header_size); +} +void mp_flush_dash_list (MP mp,pointer h) { + pointer p,q; /* pointers that scan the list being recycled */ + q=dash_list(h); + while ( q!=null_dash ) { + p=q; q=mp_link(q); + mp_free_node(mp, p,dash_node_size); + } + dash_list(h)=null_dash; +} +pointer mp_toss_gr_object (MP mp,pointer p) { + /* returns an edge structure that needs to be dereferenced */ + pointer e; /* the edge structure to return */ + e=null; + @<Prepare to recycle graphical object |p|@>; + mp_free_node(mp, p,mp->gr_object_size[mp_type(p)]); + return e; +} + +@ @<Prepare to recycle graphical object |p|@>= +switch (mp_type(p)) { +case mp_fill_code: + 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)); + break; +case mp_stroked_code: + 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_dash_p(p); + break; +case mp_text_code: + delete_str_ref(mp_text_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)); + break; +case mp_start_clip_code: +case mp_start_bounds_code: + mp_toss_knot_list(mp, mp_path_p(p)); + break; +case mp_stop_clip_code: +case mp_stop_bounds_code: + break; +} /* there are no other cases */ + +@ If we use |add_edge_ref| to ``copy'' edge structures, the real copying needs +to be done before making a significant change to an edge structure. Much of +the work is done in a separate routine |copy_objects| that copies a list of +graphical objects into a new edge header. + +@c +static pointer mp_private_edges (MP mp,pointer h) { + /* make a private copy of the edge structure headed by |h| */ + pointer hh; /* the edge header for the new copy */ + pointer p,pp; /* pointers for copying the dash list */ + if ( ref_count(h)==null ) { + return h; + } else { + decr(ref_count(h)); + hh=mp_copy_objects(mp, mp_link(dummy_loc(h)),null); + @<Copy the dash list from |h| to |hh|@>; + @<Copy the bounding box information from |h| to |hh| and make |bblast(hh)| + point into the new object list@>; + return hh; + } +} + +@ Here we use the fact that |dash_list(hh)=mp_link(hh)|. +@^data structure assumptions@> + +@<Copy the dash list from |h| to |hh|@>= +pp=hh; p=dash_list(h); +while ( (p!=null_dash) ) { + mp_link(pp)=mp_get_node(mp, dash_node_size); + pp=mp_link(pp); + start_x(pp)=start_x(p); + stop_x(pp)=stop_x(p); + p=mp_link(p); +} +mp_link(pp)=null_dash; +dash_y(hh)=dash_y(h) + + +@ |h| is an edge structure + +@c +static mp_dash_object *mp_export_dashes (MP mp, pointer q, scaled *w) { + mp_dash_object *d; + pointer p, h; + scaled scf; /* scale factor */ + int *dashes = NULL; + int num_dashes = 1; + h = mp_dash_p(q); + if (h==null || dash_list(h)==null_dash) + return NULL; + p = dash_list(h); + scf=mp_get_pen_scale(mp, mp_pen_p(q)); + if (scf==0) { + if (*w==0) scf = dash_scale(q); else return NULL; + } else { + scf=mp_make_scaled(mp, *w,scf); + scf=mp_take_scaled(mp, scf,dash_scale(q)); + } + *w = scf; + d = xmalloc(1,sizeof(mp_dash_object)); + start_x(null_dash)=start_x(p)+dash_y(h); + while (p != null_dash) { + dashes = xrealloc(dashes, (num_dashes+2), sizeof(scaled)); + dashes[(num_dashes-1)] = + mp_take_scaled(mp,(stop_x(p)-start_x(p)),scf); + dashes[(num_dashes)] = + mp_take_scaled(mp,(start_x(mp_link(p))-stop_x(p)),scf); + dashes[(num_dashes+1)] = -1; /* terminus */ + num_dashes+=2; + p=mp_link(p); + } + d->array = dashes; + d->offset = mp_take_scaled(mp,mp_dash_offset(mp, h),scf); + return d; +} + + + +@ @<Copy the bounding box information from |h| to |hh|...@>= +minx_val(hh)=minx_val(h); +miny_val(hh)=miny_val(h); +maxx_val(hh)=maxx_val(h); +maxy_val(hh)=maxy_val(h); +bbtype(hh)=bbtype(h); +p=dummy_loc(h); pp=dummy_loc(hh); +while ((p!=bblast(h)) ) { + if ( p==null ) mp_confusion(mp, "bblast"); +@:this can't happen bblast}{\quad bblast@> + p=mp_link(p); pp=mp_link(pp); +} +bblast(hh)=pp + +@ Here is the promised routine for copying graphical objects into a new edge +structure. It starts copying at object~|p| and stops just before object~|q|. +If |q| is null, it copies the entire sublist headed at |p|. The resulting edge +structure requires further initialization by |init_bbox|. + +@<Declarations@>= +static pointer mp_copy_objects (MP mp, pointer p, pointer q); + +@ @c +pointer mp_copy_objects (MP mp, pointer p, pointer q) { + pointer hh; /* the new edge header */ + pointer pp; /* the last newly copied object */ + quarterword k; /* temporary register */ + hh=mp_get_node(mp, edge_header_size); + dash_list(hh)=null_dash; + ref_count(hh)=null; + pp=dummy_loc(hh); + while ( (p!=q) ) { + @<Make |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|@>= +{ k=mp->gr_object_size[mp_type(p)]; + mp_link(pp)=mp_get_node(mp, k); + pp=mp_link(pp); + while ( (k>0) ) { decr(k); mp->mem[pp+k]=mp->mem[p+k]; }; + @<Fix anything in graphical object |pp| that should differ from the + corresponding field in |p|@>; + p=mp_link(p); +} + +@ @<Fix anything in graphical object |pp| that should differ from the...@>= +switch (mp_type(p)) { +case mp_start_clip_code: +case mp_start_bounds_code: + mp_path_p(pp)=mp_copy_path(mp, mp_path_p(p)); + break; +case mp_fill_code: + mp_path_p(pp)=mp_copy_path(mp, mp_path_p(p)); + 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(p)!=null ) mp_pen_p(pp)=copy_pen(mp_pen_p(p)); + break; +case mp_stroked_code: + 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(pp)=mp_copy_path(mp, mp_path_p(p)); + mp_pen_p(pp)=copy_pen(mp_pen_p(p)); + if ( mp_dash_p(p)!=null ) add_edge_ref(mp_dash_p(pp)); + break; +case mp_text_code: + 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_code: +case mp_stop_bounds_code: + break; +} /* there are no other cases */ + +@ Here is one way to find an acceptable value for the second argument to +|copy_objects|. Given a non-null graphical object list, |skip_1component| +skips past one picture component, where a ``picture component'' is a single +graphical object, or a start bounds or start clip object and everything up +through the matching stop bounds or stop clip object. The macro version avoids +procedure call overhead and error handling: |skip_component(p)(e)| advances |p| +unless |p| points to a stop bounds or stop clip node, in which case it executes +|e| instead. + +@d skip_component(A) + if ( ! is_start_or_stop((A)) ) (A)=mp_link((A)); + else if ( ! is_stop((A)) ) (A)=mp_skip_1component(mp, (A)); + else + +@c +static pointer mp_skip_1component (MP mp,pointer p) { + integer lev; /* current nesting level */ + lev=0; + do { + if ( is_start_or_stop(p) ) { + if ( is_stop(p) ) decr(lev); else incr(lev); + } + p=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,pointer h, const char *s, boolean nuline) ; + +@ @c +void mp_print_edges (MP mp,pointer h, const char *s, boolean nuline) { + pointer p; /* a graphical object to be printed */ + pointer hh,pp; /* temporary pointers */ + scaled scf; /* a scale factor for the dash pattern */ + boolean ok_to_dash; /* |false| for polygonal pen strokes */ + mp_print_diagnostic(mp, "Edge structure",s,nuline); + p=dummy_loc(h); + while ( 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); +} + +@ @<Cases for printing graphical object node |p|@>= +case mp_fill_code: + mp_print(mp, "Filled contour "); + mp_print_obj_color(mp, p); + mp_print_char(mp, xord(':')); mp_print_ln(mp); + mp_pr_path(mp, mp_path_p(p)); mp_print_ln(mp); + if ( (mp_pen_p(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(p)); + } + break; + +@ @<Print join type for graphical object |p|@>= +switch (ljoin_val(p)) { +case 0: + mp_print(mp, "mitered joins limited "); + mp_print_scaled(mp, miterlim_val(p)); + break; +case 1: + mp_print(mp, "round joins"); + break; +case 2: + mp_print(mp, "beveled joins"); + break; +default: + mp_print(mp, "?? joins"); +@.??@> + break; +} + +@ For stroked nodes, we need to print |lcap_val(p)| as well. + +@<Print join and cap types for stroked node |p|@>= +switch (lcap_val(p)) { +case 0:mp_print(mp, "butt"); break; +case 1:mp_print(mp, "round"); break; +case 2:mp_print(mp, "square"); break; +default: mp_print(mp, "??"); break; +@.??@> +} +mp_print(mp, " ends, "); +@<Print join type for graphical object |p|@> + +@ Here is a routine that prints the color of a graphical object if it isn't +black (the default color). + +@<Declarations@>= +static void mp_print_obj_color (MP mp,pointer p) ; + +@ @c +void mp_print_obj_color (MP mp,pointer p) { + if ( mp_color_model(p)==mp_grey_model ) { + if ( grey_val(p)>0 ) { + mp_print(mp, "greyed "); + mp_print_compact_node(mp, obj_grey_loc(p),1); + }; + } else if ( mp_color_model(p)==mp_cmyk_model ) { + if ( (cyan_val(p)>0) || (magenta_val(p)>0) || + (yellow_val(p)>0) || (black_val(p)>0) ) { + mp_print(mp, "processcolored "); + mp_print_compact_node(mp, obj_cyan_loc(p),4); + }; + } else if ( mp_color_model(p)==mp_rgb_model ) { + if ( (red_val(p)>0) || (green_val(p)>0) || (blue_val(p)>0) ) { + mp_print(mp, "colored "); + mp_print_compact_node(mp, obj_red_loc(p),3); + }; + } +} + +@ We also need a procedure for printing consecutive scaled values as if they +were a known big node. + +@<Declarations@>= +static void mp_print_compact_node (MP mp,pointer p, quarterword k) ; + +@ @c +void mp_print_compact_node (MP mp,pointer p, quarterword k) { + pointer q; /* last location to print */ + q=p+k-1; + mp_print_char(mp, xord('(')); + while ( p<=q ){ + mp_print_scaled(mp, mp->mem[p].sc); + if ( p<q ) mp_print_char(mp, xord(',')); + incr(p); + } + mp_print_char(mp, xord(')')); +} + +@ @<Cases for printing graphical object node |p|@>= +case mp_stroked_code: + mp_print(mp, "Filled pen stroke "); + mp_print_obj_color(mp, p); + mp_print_char(mp, xord(':')); mp_print_ln(mp); + mp_pr_path(mp, mp_path_p(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(p)==null ) mp_print(mp, "???"); /* shouldn't happen */ +@.???@> + else mp_pr_pen(mp, mp_pen_p(p)); + break; + +@ Normally, the |dash_list| field in an edge header is set to |null_dash| +when it is not known to define a suitable dash pattern. This is disallowed +here because the |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@>= +ok_to_dash=pen_is_elliptical(mp_pen_p(p)); +if ( ! ok_to_dash ) scf=unity; else scf=dash_scale(p); +hh=mp_dash_p(p); +pp=dash_list(hh); +if ( (pp==null_dash) || (dash_y(hh)<0) ) { + mp_print(mp, " ??"); +} else { start_x(null_dash)=start_x(pp)+dash_y(hh); + while ( pp!=null_dash ) { + mp_print(mp, "on "); + mp_print_scaled(mp, mp_take_scaled(mp, stop_x(pp)-start_x(pp),scf)); + mp_print(mp, " off "); + mp_print_scaled(mp, mp_take_scaled(mp, start_x(mp_link(pp))-stop_x(pp),scf)); + pp = mp_link(pp); + if ( pp!=null_dash ) mp_print_char(mp, xord(' ')); + } + mp_print(mp, ") shifted "); + mp_print_scaled(mp, -mp_take_scaled(mp, mp_dash_offset(mp, hh),scf)); + if ( ! ok_to_dash || (dash_y(hh)==0) ) mp_print(mp, " (this will be ignored)"); +} + +@ @<Declarations@>= +static scaled mp_dash_offset (MP mp,pointer h) ; + +@ @c +scaled mp_dash_offset (MP mp,pointer h) { + scaled x; /* the answer */ + if (dash_list(h)==null_dash || dash_y(h)<0) mp_confusion(mp, "dash0"); +@:this can't happen dash0}{\quad dash0@> + if ( dash_y(h)==0 ) { + x=0; + } else { + x=-(start_x(dash_list(h)) % dash_y(h)); + if ( x<0 ) x=x+dash_y(h); + } + return x; +} + +@ @<Cases for printing graphical object node |p|@>= +case mp_text_code: + mp_print_char(mp, 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_compact_node(mp, text_tx_loc(p),6); + break; + +@ @<Cases for printing graphical object node |p|@>= +case mp_start_clip_code: + mp_print(mp, "clipping path:"); + mp_print_ln(mp); + mp_pr_path(mp, mp_path_p(p)); + break; +case mp_stop_clip_code: + mp_print(mp, "stop clipping"); + break; + +@ @<Cases for printing graphical object node |p|@>= +case mp_start_bounds_code: + mp_print(mp, "setbounds path:"); + mp_print_ln(mp); + mp_pr_path(mp, mp_path_p(p)); + break; +case mp_stop_bounds_code: + mp_print(mp, "end of setbounds"); + break; + +@ To initialize the |dash_list| field in an edge header~|h|, we need a +subroutine that scans an edge structure and tries to interpret it as a dash +pattern. This can only be done when there are no filled regions or clipping +paths and all the pen strokes have the same color. The first step is to let +$y_0$ be the initial $y$~coordinate of the first pen stroke. Then we implicitly +project all the pen stroke paths onto the line $y=y_0$ and require that there +be no retracing. If the resulting paths cover a range of $x$~coordinates of +length $\Delta x$, we set |dash_y(h)| to the length of the dash pattern by +finding the maximum of $\Delta x$ and the absolute value of~$y_0$. + +@c +static pointer mp_make_dashes (MP mp,pointer h) { /* returns |h| or |null| */ + pointer p; /* this scans the stroked nodes in the object list */ + pointer p0; /* if not |null| this points to the first stroked node */ + pointer pp,qq,rr; /* pointers into |mp_path_p(p)| */ + pointer d,dd; /* pointers used to create the dash list */ + scaled y0; + @<Other local variables in |make_dashes|@>; + y0=0; /* the initial $y$ coordinate */ + if ( dash_list(h)!=null_dash ) + return h; + p0=null; + p=mp_link(dummy_loc(h)); + while ( p!=null ) { + if ( mp_type(p)!=mp_stroked_code ) { + @<Compain that the edge structure contains a node of the wrong type + and |goto not_found|@>; + } + pp=mp_path_p(p); + if ( p0==null ){ p0=p; y0=mp_y_coord(pp); }; + @<Make |d| point to a new dash node created from stroke |p| and path |pp| + or |goto not_found| if there is an error@>; + @<Insert |d| into the dash list and |goto not_found| if there is an error@>; + p=mp_link(p); + } + if ( dash_list(h)==null_dash ) + goto NOT_FOUND; /* No error message */ + @<Scan |dash_list(h)| and deal with any dashes that are themselves dashed@>; + @<Set |dash_y(h)| and merge the first and last dashes if necessary@>; + return h; +NOT_FOUND: + @<Flush the dash list, recycle |h| and return |null|@>; +} + +@ @<Compain that the edge structure contains a node of the wrong type...@>= +{ +print_err("Picture is too complicated to use as a dash pattern"); +help3("When you say `dashed p', picture p should not contain any", + "text, filled regions, or clipping paths. This time it did", + "so I'll just make it a solid line instead."); +mp_put_get_error(mp); +goto NOT_FOUND; +} + +@ A similar error occurs when monotonicity fails. + +@<Declarations@>= +static void mp_x_retrace_error (MP mp) ; + +@ @c +void mp_x_retrace_error (MP mp) { +print_err("Picture is too complicated to use as a dash pattern"); +help3("When you say `dashed p', every path in p should be monotone", + "in x and there must be no overlapping. This failed", + "so I'll just make it a solid line instead."); +mp_put_get_error(mp); +} + +@ We stash |p| in |mp_info(d)| if |mp_dash_p(p)<>0| so that subsequent processing can +handle the case where the pen stroke |p| is itself dashed. + +@<Make |d| point to a new dash node created from stroke |p| and path...@>= +@<Make sure |p| and |p0| are the same color and |goto not_found| if there is + an error@>; +rr=pp; +if ( mp_link(pp)!=pp ) { + do { + qq=rr; rr=mp_link(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_get_node(mp, dash_node_size); +if ( mp_dash_p(p)==0 ) mp_info(d)=0; else mp_info(d)=p; +if ( mp_x_coord(pp)<mp_x_coord(rr) ) { + start_x(d)=mp_x_coord(pp); + stop_x(d)=mp_x_coord(rr); +} else { + start_x(d)=mp_x_coord(rr); + stop_x(d)=mp_x_coord(pp); +} + +@ We also need to check for the case where the segment from |qq| to |rr| is +monotone in $x$ but is reversed relative to the path from |pp| to |qq|. + +@<Check for retracing between knots |qq| and |rr| and |goto not_found|...@>= +x0=mp_x_coord(qq); +x1=mp_right_x(qq); +x2=mp_left_x(rr); +x3=mp_x_coord(rr); +if ( (x0>x1) || (x1>x2) || (x2>x3) ) { + if ( (x0<x1) || (x1<x2) || (x2<x3) ) { + if ( mp_ab_vs_cd(mp, x2-x1,x2-x1,x1-x0,x3-x2)>0 ) { + mp_x_retrace_error(mp); goto NOT_FOUND; + } + } +} +if ( (mp_x_coord(pp)>x0) || (x0>x3) ) { + if ( (mp_x_coord(pp)<x0) || (x0<x3) ) { + mp_x_retrace_error(mp); goto NOT_FOUND; + } +} + +@ @<Other local variables in |make_dashes|@>= + scaled x0,x1,x2,x3; /* $x$ coordinates of the segment from |qq| to |rr| */ + +@ @<Make sure |p| and |p0| are the same color and |goto not_found|...@>= +if ( (red_val(p)!=red_val(p0)) || (black_val(p)!=black_val(p0)) || + (green_val(p)!=green_val(p0)) || (blue_val(p)!=blue_val(p0)) ) { + print_err("Picture is too complicated to use as a dash pattern"); + help3("When you say `dashed p', everything in picture p should", + "be the same color. I can\'t handle your color changes", + "so I'll just make it a solid line instead."); + mp_put_get_error(mp); + goto NOT_FOUND; +} + +@ @<Insert |d| into the dash list and |goto not_found| if there is an error@>= +start_x(null_dash)=stop_x(d); +dd=h; /* this makes |mp_link(dd)=dash_list(h)| */ +while ( start_x(mp_link(dd))<stop_x(d) ) + dd=mp_link(dd); +if ( dd!=h ) { + if ( (stop_x(dd)>start_x(d)) ) + { mp_x_retrace_error(mp); goto NOT_FOUND; }; +} +mp_link(d)=mp_link(dd); +mp_link(dd)=d + +@ @<Set |dash_y(h)| and merge the first and last dashes if necessary@>= +d=dash_list(h); +while ( (mp_link(d)!=null_dash) ) + d=mp_link(d); +dd=dash_list(h); +dash_y(h)=stop_x(d)-start_x(dd); +if ( abs(y0)>dash_y(h) ) { + dash_y(h)=abs(y0); +} else if ( d!=dd ) { + dash_list(h)=mp_link(dd); + stop_x(d)=stop_x(dd)+dash_y(h); + mp_free_node(mp, dd,dash_node_size); +} + +@ We get here when the argument is a null picture or when there is an error. +Recovering from an error involves making |dash_list(h)| empty to indicate +that |h| is not known to be a valid dash pattern. We also dereference |h| +since it is not being used for the return value. + +@<Flush the dash list, recycle |h| and return |null|@>= +mp_flush_dash_list(mp, h); +delete_edge_ref(h); +return null + +@ Having carefully saved the dashed stroked nodes in the +corresponding dash nodes, we must be prepared to break up these dashes into +smaller dashes. + +@<Scan |dash_list(h)| and deal with any dashes that are themselves dashed@>= +d=h; /* now |mp_link(d)=dash_list(h)| */ +while ( mp_link(d)!=null_dash ) { + ds=mp_info(mp_link(d)); + if ( ds==null ) { + d=mp_link(d); + } else { + hh=mp_dash_p(ds); + hsf=dash_scale(ds); + if ( (hh==null) ) mp_confusion(mp, "dash1"); +@:this can't happen dash0}{\quad dash1@> + if ( dash_y(hh)==0 ) { + d=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|@>; + } + } +} + +@ @<Other local variables in |make_dashes|@>= +pointer dln; /* |mp_link(d)| */ +pointer hh; /* an edge header that tells how to break up |dln| */ +scaled hsf; /* the dash pattern from |hh| gets scaled by this */ +pointer ds; /* the stroked node from which |hh| and |hsf| are derived */ +scaled xoff; /* added to $x$ values in |dash_list(hh)| to match |dln| */ + +@ @<Replace |mp_link(d)| by a dashed version as determined by edge header...@>= +dln=mp_link(d); +dd=dash_list(hh); +xoff=start_x(dln)-mp_take_scaled(mp, hsf,start_x(dd))- + mp_take_scaled(mp, hsf,mp_dash_offset(mp, hh)); +start_x(null_dash)=mp_take_scaled(mp, hsf,start_x(dd)) + +mp_take_scaled(mp, hsf,dash_y(hh)); +stop_x(null_dash)=start_x(null_dash); +@<Advance |dd| until finding the first dash that overlaps |dln| when + offset by |xoff|@>; +while ( start_x(dln)<=stop_x(dln) ) { + @<If |dd| has `fallen off the end', back up to the beginning and fix |xoff|@>; + @<Insert a dash between |d| and |dln| for the overlap with the offset version + of |dd|@>; + dd=mp_link(dd); + start_x(dln)=xoff+mp_take_scaled(mp, hsf,start_x(dd)); +} +mp_link(d)=mp_link(dln); +mp_free_node(mp, dln,dash_node_size) + +@ The name of this module is a bit of a lie because we just find the +first |dd| where |take_scaled (hsf, stop_x(dd))| is large enough to make an +overlap possible. It could be that the unoffset version of dash |dln| falls +in the gap between |dd| and its predecessor. + +@<Advance |dd| until finding the first dash that overlaps |dln| when...@>= +while ( xoff+mp_take_scaled(mp, hsf,stop_x(dd))<start_x(dln) ) { + dd=mp_link(dd); +} + +@ @<If |dd| has `fallen off the end', back up to the beginning and fix...@>= +if ( dd==null_dash ) { + dd=dash_list(hh); + xoff=xoff+mp_take_scaled(mp, hsf,dash_y(hh)); +} + +@ At this point we already know that +|start_x(dln)<=xoff+take_scaled(hsf,stop_x(dd))|. + +@<Insert a dash between |d| and |dln| for the overlap with the offset...@>= +if ( (xoff+mp_take_scaled(mp, hsf,start_x(dd)))<=stop_x(dln) ) { + mp_link(d)=mp_get_node(mp, dash_node_size); + d=mp_link(d); + mp_link(d)=dln; + if ( start_x(dln)>(xoff+mp_take_scaled(mp, hsf,start_x(dd)))) + start_x(d)=start_x(dln); + else + start_x(d)=xoff+mp_take_scaled(mp, hsf,start_x(dd)); + if ( stop_x(dln)<(xoff+mp_take_scaled(mp, hsf,stop_x(dd)))) + stop_x(d)=stop_x(dln); + else + stop_x(d)=xoff+mp_take_scaled(mp, hsf,stop_x(dd)); +} + +@ The next major task is to update the bounding box information in an edge +header~|h|. This is done via a procedure |adjust_bbox| that enlarges an edge +header's bounding box to accommodate the box computed by |path_bbox| or +|pen_bbox|. (This is stored in global variables |minx|, |miny|, |maxx|, and +|maxy|.) + +@c static void mp_adjust_bbox (MP mp,pointer h) { + if ( mp_minx<minx_val(h) ) minx_val(h)=mp_minx; + if ( mp_miny<miny_val(h) ) miny_val(h)=mp_miny; + if ( mp_maxx>maxx_val(h) ) maxx_val(h)=mp_maxx; + if ( mp_maxy>maxy_val(h) ) maxy_val(h)=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, pointer p, pointer pp, pointer h) { + pointer q; /* a knot node adjacent to knot |p| */ + fraction dx,dy; /* a unit vector in the direction out of the path at~|p| */ + scaled d; /* a factor for adjusting the length of |(dx,dy)| */ + scaled z; /* a coordinate being tested against the bounding box */ + scaled xx,yy; /* the extreme pen vertex in the |(dx,dy)| direction */ + integer i; /* a loop counter */ + if ( mp_right_type(p)!=mp_endpoint ) { + q=mp_link(p); + while (1) { + @<Make |(dx,dy)| the final direction for the path segment from + |q| to~|p|; set~|d|@>; + d=mp_pyth_add(mp, dx,dy); + if ( d>0 ) { + @<Normalize the direction |(dx,dy)| and find the pen offset |(xx,yy)|@>; + for (i=1;i<= 2;i++) { + @<Use |(dx,dy)| to generate a vertex of the square end cap and + update the bounding box to accommodate it@>; + dx=-dx; dy=-dy; + } + } + if ( mp_right_type(p)==mp_endpoint ) { + return; + } else { + @<Advance |p| to the end of the path and make |q| the previous knot@>; + } + } + } +} + +@ @<Make |(dx,dy)| the final direction for the path segment from...@>= +if ( q==mp_link(p) ) { + dx=mp_x_coord(p)-mp_right_x(p); + dy=mp_y_coord(p)-mp_right_y(p); + if ( (dx==0)&&(dy==0) ) { + dx=mp_x_coord(p)-mp_left_x(q); + dy=mp_y_coord(p)-mp_left_y(q); + } +} else { + dx=mp_x_coord(p)-mp_left_x(p); + dy=mp_y_coord(p)-mp_left_y(p); + if ( (dx==0)&&(dy==0) ) { + dx=mp_x_coord(p)-mp_right_x(q); + dy=mp_y_coord(p)-mp_right_y(q); + } +} +dx=mp_x_coord(p)-mp_x_coord(q); +dy=mp_y_coord(p)-mp_y_coord(q) + +@ @<Normalize the direction |(dx,dy)| and find the pen offset |(xx,yy)|@>= +dx=mp_make_fraction(mp, dx,d); +dy=mp_make_fraction(mp, dy,d); +mp_find_offset(mp, -dy,dx,pp); +xx=mp->cur_x; yy=mp->cur_y + +@ @<Use |(dx,dy)| to generate a vertex of the square end cap and...@>= +mp_find_offset(mp, dx,dy,pp); +d=mp_take_fraction(mp, xx-mp->cur_x,dx)+mp_take_fraction(mp, yy-mp->cur_y,dy); +if ( ((d<0)&&(i==1)) || ((d>0)&&(i==2))) + mp_confusion(mp, "box_ends"); +@:this can't happen box ends}{\quad\\{box\_ends}@> +z=mp_x_coord(p)+mp->cur_x+mp_take_fraction(mp, d,dx); +if ( z<minx_val(h) ) minx_val(h)=z; +if ( z>maxx_val(h) ) maxx_val(h)=z; +z=mp_y_coord(p)+mp->cur_y+mp_take_fraction(mp, d,dy); +if ( z<miny_val(h) ) miny_val(h)=z; +if ( z>maxy_val(h) ) maxy_val(h)=z + +@ @<Advance |p| to the end of the path and make |q| the previous knot@>= +do { + q=p; + p=mp_link(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,pointer h, boolean top_level) { + pointer p; /* a graphical object being considered */ + scaled sminx,sminy,smaxx,smaxy; + /* for saving the bounding box during recursive calls */ + scaled x0,x1,y0,y1; /* temporary registers */ + integer lev; /* nesting level for |mp_start_bounds_code| nodes */ + @<Wipe out any existing bounding box information if |bbtype(h)| is + incompatible with |internal[mp_true_corners]|@>; + while ( mp_link(bblast(h))!=null ) { + p=mp_link(bblast(h)); + bblast(h)=p; + switch (mp_type(p)) { + case mp_stop_clip_code: + if ( top_level ) mp_confusion(mp, "bbox"); else return; +@:this can't happen bbox}{\quad bbox@> + break; + @<Other cases for updating the bounding box based on the type of object |p|@>; + } /* all cases are enumerated above */ + } + if ( ! top_level ) mp_confusion(mp, "bbox"); +} + +@ @<Declarations@>= +static void mp_set_bbox (MP mp,pointer h, boolean top_level); + +@ @<Wipe out any existing bounding box information if |bbtype(h)| is...@>= +switch (bbtype(h)) { +case no_bounds: + break; +case bounds_set: + if ( mp->internal[mp_true_corners]>0 ) mp_init_bbox(mp, h); + break; +case bounds_unset: + if ( mp->internal[mp_true_corners]<=0 ) mp_init_bbox(mp, h); + break; +} /* there are no other cases */ + +@ @<Other cases for updating the bounding box...@>= +case mp_fill_code: + mp_path_bbox(mp, mp_path_p(p)); + if ( mp_pen_p(p)!=null ) { + x0=mp_minx; y0=mp_miny; + x1=mp_maxx; y1=mp_maxy; + mp_pen_bbox(mp, mp_pen_p(p)); + mp_minx=mp_minx+x0; + mp_miny=mp_miny+y0; + mp_maxx=mp_maxx+x1; + mp_maxy=mp_maxy+y1; + } + mp_adjust_bbox(mp, h); + break; + +@ @<Other cases for updating the bounding box...@>= +case mp_start_bounds_code: + if ( mp->internal[mp_true_corners]>0 ) { + bbtype(h)=bounds_unset; + } else { + bbtype(h)=bounds_set; + mp_path_bbox(mp, mp_path_p(p)); + mp_adjust_bbox(mp, h); + @<Scan to the matching |mp_stop_bounds_code| node and update |p| and + |bblast(h)|@>; + } + break; +case mp_stop_bounds_code: + if ( mp->internal[mp_true_corners]<=0 ) mp_confusion(mp, "bbox2"); +@:this can't happen bbox2}{\quad bbox2@> + break; + +@ @<Scan to the matching |mp_stop_bounds_code| node and update |p| and...@>= +lev=1; +while ( lev!=0 ) { + if ( mp_link(p)==null ) mp_confusion(mp, "bbox2"); +@:this can't happen bbox2}{\quad bbox2@> + p=mp_link(p); + if ( mp_type(p)==mp_start_bounds_code ) incr(lev); + else if ( mp_type(p)==mp_stop_bounds_code ) decr(lev); +} +bblast(h)=p + +@ It saves a lot of grief here to be slightly conservative and not account for +omitted parts of dashed lines. We also don't worry about the material omitted +when using butt end caps. The basic computation is for round end caps and +|box_ends| augments it for square end caps. + +@<Other cases for updating the bounding box...@>= +case mp_stroked_code: + mp_path_bbox(mp, mp_path_p(p)); + x0=mp_minx; y0=mp_miny; + x1=mp_maxx; y1=mp_maxy; + mp_pen_bbox(mp, mp_pen_p(p)); + mp_minx=mp_minx+x0; + mp_miny=mp_miny+y0; + mp_maxx=mp_maxx+x1; + mp_maxy=mp_maxy+y1; + mp_adjust_bbox(mp, h); + if ( (mp_left_type(mp_path_p(p))==mp_endpoint)&&(lcap_val(p)==2) ) + mp_box_ends(mp, mp_path_p(p), mp_pen_p(p), h); + break; + +@ The height width and depth information stored in a text node determines a +rectangle that needs to be transformed according to the transformation +parameters stored in the text node. + +@<Other cases for updating the bounding box...@>= +case mp_text_code: + x1=mp_take_scaled(mp, txx_val(p),width_val(p)); + y0=mp_take_scaled(mp, txy_val(p),-depth_val(p)); + y1=mp_take_scaled(mp, txy_val(p),height_val(p)); + mp_minx=tx_val(p); + mp_maxx=mp_minx; + if ( y0<y1 ) { mp_minx=mp_minx+y0; mp_maxx=mp_maxx+y1; } + else { mp_minx=mp_minx+y1; mp_maxx=mp_maxx+y0; } + if ( x1<0 ) mp_minx=mp_minx+x1; else mp_maxx=mp_maxx+x1; + x1=mp_take_scaled(mp, tyx_val(p),width_val(p)); + y0=mp_take_scaled(mp, tyy_val(p),-depth_val(p)); + y1=mp_take_scaled(mp, tyy_val(p),height_val(p)); + mp_miny=ty_val(p); + mp_maxy=mp_miny; + if ( y0<y1 ) { mp_miny=mp_miny+y0; mp_maxy=mp_maxy+y1; } + else { mp_miny=mp_miny+y1; mp_maxy=mp_maxy+y0; } + if ( x1<0 ) mp_miny=mp_miny+x1; else mp_maxy=mp_maxy+x1; + mp_adjust_bbox(mp, h); + break; + +@ This case involves a recursive call that advances |bblast(h)| to the node of +type |mp_stop_clip_code| that matches |p|. + +@<Other cases for updating the bounding box...@>= +case mp_start_clip_code: + mp_path_bbox(mp, mp_path_p(p)); + x0=mp_minx; y0=mp_miny; + x1=mp_maxx; y1=mp_maxy; + sminx=minx_val(h); sminy=miny_val(h); + smaxx=maxx_val(h); smaxy=maxy_val(h); + @<Reinitialize the bounding box in header |h| and call |set_bbox| recursively + starting at |mp_link(p)|@>; + @<Clip the bounding box in |h| to the rectangle given by |x0|, |x1|, + |y0|, |y1|@>; + mp_minx=sminx; mp_miny=sminy; + mp_maxx=smaxx; mp_maxy=smaxy; + mp_adjust_bbox(mp, h); + break; + +@ @<Reinitialize the bounding box in header |h| and call |set_bbox|...@>= +minx_val(h)=el_gordo; +miny_val(h)=el_gordo; +maxx_val(h)=-el_gordo; +maxy_val(h)=-el_gordo; +mp_set_bbox(mp, h,false) + +@ @<Clip the bounding box in |h| to the rectangle given by |x0|, |x1|,...@>= +if ( minx_val(h)<x0 ) minx_val(h)=x0; +if ( miny_val(h)<y0 ) miny_val(h)=y0; +if ( maxx_val(h)>x1 ) maxx_val(h)=x1; +if ( maxy_val(h)>y1 ) maxy_val(h)=y1 + +@* \[22] Finding an envelope. +When \MP\ has a path and a polygonal pen, it needs to express the desired +shape in terms of things \ps\ can understand. The present task is to compute +a new path that describes the region to be filled. It is convenient to +define this as a two step process where the first step is determining what +offset to use for each segment of the path. + +@ Given a pointer |c| to a cyclic path, +and a pointer~|h| to the first knot of a pen polygon, +the |offset_prep| routine changes the path into cubics that are +associated with particular pen offsets. Thus if the cubic between |p| +and~|q| is associated with the |k|th offset and the cubic between |q| and~|r| +has offset |l| then |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 */ + +@ @c +static pointer mp_offset_prep (MP mp,pointer c, pointer h) { + halfword n; /* the number of vertices in the pen polygon */ + pointer c0,p,q,q0,r,w, ww; /* for list manipulation */ + integer k_needed; /* amount to be added to |mp_info(p)| when it is computed */ + pointer w0; /* a pointer to pen offset to use just before |p| */ + scaled dxin,dyin; /* the direction into knot |p| */ + integer turn_amt; /* change in pen offsets for the current cubic */ + @<Other local variables for |offset_prep|@>; + dx0=0; dy0=0; + @<Initialize the pen size~|n|@>; + @<Initialize the incoming direction and pen offset at |c|@>; + p=c; c0=c; k_needed=0; + do { + q=mp_link(p); + @<Split the cubic between |p| and |q|, if necessary, into cubics + associated with single offsets, after which |q| should + point to the end of the final such cubic@>; + NOT_FOUND: + @<Advance |p| to node |q|, removing any ``dead'' cubics that + might have been introduced by the splitting process@>; + } while (q!=c); + @<Fix the offset change in |mp_info(c)| and set |c| to the return value of + |offset_prep|@>; + return c; +} + +@ We shall want to keep track of where certain knots on the cyclic path +wind up in the envelope spec. It doesn't suffice just to keep pointers to +knot nodes because some nodes are deleted while removing dead cubics. Thus +|offset_prep| updates the following pointers + +@<Glob...@>= +pointer spec_p1; +pointer spec_p2; /* pointers to distinguished knots */ + +@ @<Set init...@>= +mp->spec_p1=null; mp->spec_p2=null; + +@ @<Initialize the pen size~|n|@>= +n=0; p=h; +do { + incr(n); + p=mp_link(p); +} while (p!=h) + +@ Since the true incoming direction isn't known yet, we just pick a direction +consistent with the pen offset~|h|. If this is wrong, it can be corrected +later. + +@<Initialize the incoming direction and pen offset at |c|@>= +dxin=mp_x_coord(mp_link(h))-mp_x_coord(knil(h)); +dyin=mp_y_coord(mp_link(h))-mp_y_coord(knil(h)); +if ( (dxin==0)&&(dyin==0) ) { + dxin=mp_y_coord(knil(h))-mp_y_coord(h); + dyin=mp_x_coord(h)-mp_x_coord(knil(h)); +} +w0=h + +@ We must be careful not to remove the only cubic in a cycle. + +But we must also be careful for another reason. If the user-supplied +path starts with a set of degenerate cubics, the target node |q| can +be collapsed to the initial node |p| which might be the same as the +initial node |c| of the curve. This would cause the |offset_prep| routine +to bail out too early, causing distress later on. (See for example +the testcase reported by Bogus\l{}aw Jackowski in tracker id 267, case 52c +on Sarovar.) + +@<Advance |p| to node |q|, removing any ``dead'' cubics...@>= +q0=q; +do { + r=mp_link(p); + if ( mp_x_coord(p)==mp_right_x(p) && mp_y_coord(p)==mp_right_y(p) && + mp_x_coord(p)==mp_left_x(r) && mp_y_coord(p)==mp_left_y(r) && + mp_x_coord(p)==mp_x_coord(r) && mp_y_coord(p)==mp_y_coord(r) && + r!=p ) { + @<Remove the cubic following |p| and update the data structures + to merge |r| into |p|@>; + } + p=r; +} while (p!=q); +/* Check if we removed too much */ +if ((q!=q0)&&(q!=c||c==c0)) + q = mp_link(q) + +@ @<Remove the cubic following |p| and update the data structures...@>= +{ k_needed=mp_info(p)-zero_off; + if ( r==q ) { + q=p; + } else { + mp_info(p)=k_needed+mp_info(r); + k_needed=0; + }; + if ( r==c ) { mp_info(p)=mp_info(c); c=p; }; + if ( r==mp->spec_p1 ) mp->spec_p1=p; + if ( r==mp->spec_p2 ) mp->spec_p2=p; + r=p; mp_remove_cubic(mp, p); +} + +@ Not setting the |info| field of the newly created knot allows the splitting +routine to work for paths. + +@<Declarations@>= +static void mp_split_cubic (MP mp,pointer p, fraction t) ; + +@ @c +void mp_split_cubic (MP mp,pointer p, fraction t) { /* splits the cubic after |p| */ + scaled v; /* an intermediate value */ + pointer q,r; /* for list manipulation */ + q=mp_link(p); r=mp_get_node(mp, knot_node_size); mp_link(p)=r; mp_link(r)=q; + mp_originator(r)=mp_program_code; + mp_left_type(r)=mp_explicit; mp_right_type(r)=mp_explicit; + v=t_of_the_way(mp_right_x(p),mp_left_x(q)); + mp_right_x(p)=t_of_the_way(mp_x_coord(p),mp_right_x(p)); + mp_left_x(q)=t_of_the_way(mp_left_x(q),mp_x_coord(q)); + mp_left_x(r)=t_of_the_way(mp_right_x(p),v); + mp_right_x(r)=t_of_the_way(v,mp_left_x(q)); + mp_x_coord(r)=t_of_the_way(mp_left_x(r),mp_right_x(r)); + v=t_of_the_way(mp_right_y(p),mp_left_y(q)); + mp_right_y(p)=t_of_the_way(mp_y_coord(p),mp_right_y(p)); + mp_left_y(q)=t_of_the_way(mp_left_y(q),mp_y_coord(q)); + mp_left_y(r)=t_of_the_way(mp_right_y(p),v); + mp_right_y(r)=t_of_the_way(v,mp_left_y(q)); + mp_y_coord(r)=t_of_the_way(mp_left_y(r),mp_right_y(r)); +} + +@ This does not set |mp_info(p)| or |mp_right_type(p)|. + +@<Declarations@>= +static void mp_remove_cubic (MP mp,pointer p) ; + +@ @c +void mp_remove_cubic (MP mp,pointer p) { /* removes the dead cubic following~|p| */ + pointer q; /* the node that disappears */ + q=mp_link(p); mp_link(p)=mp_link(q); + mp_right_x(p)=mp_right_x(q); mp_right_y(p)=mp_right_y(q); + mp_free_node(mp, q,knot_node_size); +} + +@ Let $d\prec d'$ mean that the counter-clockwise angle from $d$ to~$d'$ is +strictly between zero and $180^\circ$. Then we can define $d\preceq d'$ to +mean that the angle could be zero or $180^\circ$. If $w_k=(u_k,v_k)$ is the +$k$th pen offset, the $k$th pen edge direction is defined by the formula +$$d_k=(u\k-u_k,\,v\k-v_k).$$ +When listed by increasing $k$, these directions occur in counter-clockwise +order so that $d_k\preceq d\k$ for all~$k$. +The goal of |offset_prep| is to find an offset index~|k| to associate with +each cubic, such that the direction $d(t)$ of the cubic satisfies +$$d_{k-1}\preceq d(t)\preceq d_k\qquad\hbox{for $0\le t\le 1$.}\eqno(*)$$ +We may have to split a cubic into many pieces before each +piece corresponds to a unique offset. + +@<Split the cubic between |p| and |q|, if necessary, into cubics...@>= +mp_info(p)=zero_off+k_needed; +k_needed=0; +@<Prepare for derivative computations; + |goto not_found| if the current cubic is dead@>; +@<Find the initial direction |(dx,dy)|@>; +@<Update |mp_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 pointer mp_pen_walk (MP mp,pointer w, integer k) ; + +@ @c +pointer mp_pen_walk (MP mp,pointer w, integer k) { + /* walk |k| steps around a pen from |w| */ + while ( k>0 ) { w=mp_link(w); decr(k); }; + while ( k<0 ) { w=knil(w); incr(k); }; + return w; +} + +@ The direction of a cubic $B(z_0,z_1,z_2,z_3;t)=\bigl(x(t),y(t)\bigr)$ can be +calculated from the quadratic polynomials +${1\over3}x'(t)=B(x_1-x_0,x_2-x_1,x_3-x_2;t)$ and +${1\over3}y'(t)=B(y_1-y_0,y_2-y_1,y_3-y_2;t)$. +Since we may be calculating directions from several cubics +split from the current one, it is desirable to do these calculations +without losing too much precision. ``Scaled up'' values of the +derivatives, which will be less tainted by accumulated errors than +derivatives found from the cubics themselves, are maintained in +local variables |x0|, |x1|, and |x2|, representing $X_0=2^l(x_1-x_0)$, +$X_1=2^l(x_2-x_1)$, and $X_2=2^l(x_3-x_2)$; similarly |y0|, |y1|, and~|y2| +represent $Y_0=2^l(y_1-y_0)$, $Y_1=2^l(y_2-y_1)$, and $Y_2=2^l(y_3-y_2)$. + +@<Other local variables for |offset_prep|@>= +integer x0,x1,x2,y0,y1,y2; /* representatives of derivatives */ +integer t0,t1,t2; /* coefficients of polynomial for slope testing */ +integer du,dv,dx,dy; /* for directions of the pen and the curve */ +integer dx0,dy0; /* initial direction for the first cubic in the curve */ +integer max_coef; /* used while scaling */ +integer x0a,x1a,x2a,y0a,y1a,y2a; /* intermediate values */ +fraction t; /* where the derivative passes through zero */ +fraction s; /* a temporary value */ + +@ @<Prepare for derivative computations...@>= +x0=mp_right_x(p)-mp_x_coord(p); +x2=mp_x_coord(q)-mp_left_x(q); +x1=mp_left_x(q)-mp_right_x(p); +y0=mp_right_y(p)-mp_y_coord(p); y2=mp_y_coord(q)-mp_left_y(q); +y1=mp_left_y(q)-mp_right_y(p); +max_coef=abs(x0); +if ( abs(x1)>max_coef ) max_coef=abs(x1); +if ( abs(x2)>max_coef ) max_coef=abs(x2); +if ( abs(y0)>max_coef ) max_coef=abs(y0); +if ( abs(y1)>max_coef ) max_coef=abs(y1); +if ( abs(y2)>max_coef ) max_coef=abs(y2); +if ( max_coef==0 ) goto NOT_FOUND; +while ( max_coef<fraction_half ) { + double(max_coef); + double(x0); double(x1); double(x2); + double(y0); double(y1); double(y2); +} + +@ Let us first solve a special case of the problem: Suppose we +know an index~$k$ such that either (i)~$d(t)\succeq d_{k-1}$ for all~$t$ +and $d(0)\prec d_k$, or (ii)~$d(t)\preceq d_k$ for all~$t$ and +$d(0)\succ d_{k-1}$. +Then, in a sense, we're halfway done, since one of the two relations +in $(*)$ is satisfied, and the other couldn't be satisfied for +any other value of~|k|. + +Actually, the conditions can be relaxed somewhat since a relation such as +$d(t)\succeq d_{k-1}$ restricts $d(t)$ to a half plane when all that really +matters is whether $d(t)$ crosses the ray in the $d_{k-1}$ direction from +the origin. The condition for case~(i) becomes $d_{k-1}\preceq d(0)\prec d_k$ +and $d(t)$ never crosses the $d_{k-1}$ ray in the clockwise direction. +Case~(ii) is similar except $d(t)$ cannot cross the $d_k$ ray in the +counterclockwise direction. + +The |fin_offset_prep| subroutine solves the stated subproblem. +It has a parameter called |rise| that is |1| in +case~(i), |-1| in case~(ii). Parameters |x0| through |y2| represent +the derivative of the cubic following |p|. +The |w| parameter should point to offset~$w_k$ and |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,pointer p, pointer w, integer + x0,integer x1, integer x2, integer y0, integer y1, integer y2, + integer rise, integer turn_amt) ; + +@ @c +void mp_fin_offset_prep (MP mp,pointer p, pointer w, integer + x0,integer x1, integer x2, integer y0, integer y1, integer y2, + integer rise, integer turn_amt) { + pointer ww; /* for list manipulation */ + scaled du,dv; /* for slope calculation */ + integer t0,t1,t2; /* test coefficients */ + fraction t; /* place where the derivative passes a critical slope */ + fraction s; /* slope or reciprocal slope */ + integer v; /* intermediate value for updating |x0..y2| */ + pointer q; /* original |mp_link(p)| */ + q=mp_link(p); + while (1) { + if ( rise>0 ) ww=mp_link(w); /* a pointer to $w\k$ */ + else ww=knil(w); /* a pointer to $w_{k-1}$ */ + @<Compute test coefficients |(t0,t1,t2)| + for $d(t)$ versus $d_k$ or $d_{k-1}$@>; + t=mp_crossing_point(mp, t0,t1,t2); + if ( t>=fraction_one ) { + if ( turn_amt>0 ) t=fraction_one; else return; + } + @<Split the cubic at $t$, + and split off another cubic if the derivative crosses back@>; + w=ww; + } +} + +@ We want $B(\\{t0},\\{t1},\\{t2};t)$ to be the dot product of $d(t)$ with a +$-90^\circ$ rotation of the vector from |w| to |ww|. This makes the resulting +function cross from positive to negative when $d_{k-1}\preceq d(t)\preceq d_k$ +begins to fail. + +@<Compute test coefficients |(t0,t1,t2)| for $d(t)$ versus...@>= +du=mp_x_coord(ww)-mp_x_coord(w); dv=mp_y_coord(ww)-mp_y_coord(w); +if ( abs(du)>=abs(dv) ) { + s=mp_make_fraction(mp, dv,du); + t0=mp_take_fraction(mp, x0,s)-y0; + t1=mp_take_fraction(mp, x1,s)-y1; + t2=mp_take_fraction(mp, x2,s)-y2; + if ( du<0 ) { negate(t0); negate(t1); negate(t2); } +} else { + s=mp_make_fraction(mp, du,dv); + t0=x0-mp_take_fraction(mp, y0,s); + t1=x1-mp_take_fraction(mp, y1,s); + t2=x2-mp_take_fraction(mp, y2,s); + if ( dv<0 ) { negate(t0); negate(t1); negate(t2); } +} +if ( t0<0 ) t0=0 /* should be positive without rounding error */ + +@ The curve has crossed $d_k$ or $d_{k-1}$; its initial segment satisfies +$(*)$, and it might cross again and return towards $s_{k-1}$ or $s_k$, +respectively, yielding another solution of $(*)$. + +@<Split the cubic at $t$, and split off another...@>= +{ +mp_split_cubic(mp, p,t); p=mp_link(p); mp_info(p)=zero_off+rise; +decr(turn_amt); +v=t_of_the_way(x0,x1); x1=t_of_the_way(x1,x2); +x0=t_of_the_way(v,x1); +v=t_of_the_way(y0,y1); y1=t_of_the_way(y1,y2); +y0=t_of_the_way(v,y1); +if ( turn_amt<0 ) { + t1=t_of_the_way(t1,t2); + if ( t1>0 ) t1=0; /* without rounding error, |t1| would be |<=0| */ + t=mp_crossing_point(mp, 0,-t1,-t2); + if ( t>fraction_one ) t=fraction_one; + incr(turn_amt); + if ( (t==fraction_one)&&(mp_link(p)!=q) ) { + mp_info(mp_link(p))=mp_info(mp_link(p))-rise; + } else { + mp_split_cubic(mp, p,t); mp_info(mp_link(p))=zero_off-rise; + v=t_of_the_way(x1,x2); x1=t_of_the_way(x0,x1); + x2=t_of_the_way(x1,v); + v=t_of_the_way(y1,y2); y1=t_of_the_way(y0,y1); + y2=t_of_the_way(y1,v); + } +} +} + +@ Now we must consider the general problem of |offset_prep|, when +nothing is known about a given cubic. We start by finding its +direction in the vicinity of |t=0|. + +If $z'(t)=0$, the given cubic is numerically unstable but |offset_prep| +has not yet introduced any more numerical errors. Thus we can compute +the true initial direction for the given cubic, even if it is almost +degenerate. + +@<Find the initial direction |(dx,dy)|@>= +dx=x0; dy=y0; +if ( dx==0 && dy==0 ) { + dx=x1; dy=y1; + if ( dx==0 && dy==0 ) { + dx=x2; dy=y2; + } +} +if ( p==c ) { dx0=dx; dy0=dy; } + +@ @<Find the final direction |(dxin,dyin)|@>= +dxin=x2; dyin=y2; +if ( dxin==0 && dyin==0 ) { + dxin=x1; dyin=y1; + if ( dxin==0 && dyin==0 ) { + dxin=x0; dyin=y0; + } +} + +@ The next step is to bracket the initial direction between consecutive +edges of the pen polygon. We must be careful to turn clockwise only if +this makes the turn less than $180^\circ$. (A $180^\circ$ turn must be +counter-clockwise in order to make \&{doublepath} envelopes come out +@:double_path_}{\&{doublepath} primitive@> +right.) This code depends on |w0| being the offset for |(dxin,dyin)|. + +@<Update |mp_info(p)| and find the offset $w_k$ such that...@>= +turn_amt=mp_get_turn_amt(mp,w0,dx,dy,(mp_ab_vs_cd(mp, dy,dxin,dx,dyin)>=0)); +w=mp_pen_walk(mp, w0, turn_amt); +w0=w; +mp_info(p)=mp_info(p)+turn_amt + +@ Decide how many pen offsets to go away from |w| in order to find the offset +for |(dx,dy)|, going counterclockwise if |ccw| is |true|. This assumes that +|w| is the offset for some direction $(x',y')$ from which the angle to |(dx,dy)| +in the sense determined by |ccw| is less than or equal to $180^\circ$. + +If the pen polygon has only two edges, they could both be parallel +to |(dx,dy)|. In this case, we must be careful to stop after crossing the first +such edge in order to avoid an infinite loop. + +@<Declarations@>= +static integer mp_get_turn_amt (MP mp,pointer w, scaled dx, + scaled dy, boolean ccw); + +@ @c +integer mp_get_turn_amt (MP mp,pointer w, scaled dx, + scaled dy, boolean ccw) { + pointer ww; /* a neighbor of knot~|w| */ + integer s; /* turn amount so far */ + integer t; /* |ab_vs_cd| result */ + s=0; + if ( ccw ) { + ww=mp_link(w); + do { + t=mp_ab_vs_cd(mp, dy,(mp_x_coord(ww)-mp_x_coord(w)), + dx,(mp_y_coord(ww)-mp_y_coord(w))); + if ( t<0 ) break; + incr(s); + w=ww; ww=mp_link(ww); + } while (t>0); + } else { + ww=knil(w); + while ( mp_ab_vs_cd(mp, dy,(mp_x_coord(w)-mp_x_coord(ww)), + dx,(mp_y_coord(w)-mp_y_coord(ww))) < 0) { + decr(s); + w=ww; ww=knil(ww); + } + } + return s; +} + +@ When we're all done, the final offset is |w0| and the final curve direction +is |(dxin,dyin)|. With this knowledge of the incoming direction at |c|, we +can correct |mp_info(c)| which was erroneously based on an incoming offset +of~|h|. + +@d fix_by(A) mp_info(c)=mp_info(c)+(A) + +@<Fix the offset change in |mp_info(c)| and set |c| to the return value of...@>= +mp->spec_offset=mp_info(c)-zero_off; +if ( mp_link(c)==c ) { + mp_info(c)=zero_off+n; +} else { + fix_by(k_needed); + while ( w0!=h ) { fix_by(1); w0=mp_link(w0); }; + while ( mp_info(c)<=zero_off-n ) fix_by(n); + while ( mp_info(c)>zero_off ) fix_by(-n); + if ( (mp_info(c)!=zero_off)&&(mp_ab_vs_cd(mp, dy0,dxin,dx0,dyin)>=0) ) fix_by(n); +} + +@ Finally we want to reduce the general problem to situations that +|fin_offset_prep| can handle. We split the cubic into at most three parts +with respect to $d_{k-1}$, and apply |fin_offset_prep| to each part. + +@<Complete the offset splitting process@>= +ww=knil(w); +@<Compute test coeff...@>; +@<Find the first |t| where $d(t)$ crosses $d_{k-1}$ or set + |t:=fraction_one+1|@>; +if ( t>fraction_one ) { + mp_fin_offset_prep(mp, p,w,x0,x1,x2,y0,y1,y2,1,turn_amt); +} else { + mp_split_cubic(mp, p,t); r=mp_link(p); + x1a=t_of_the_way(x0,x1); x1=t_of_the_way(x1,x2); + x2a=t_of_the_way(x1a,x1); + y1a=t_of_the_way(y0,y1); y1=t_of_the_way(y1,y2); + y2a=t_of_the_way(y1a,y1); + mp_fin_offset_prep(mp, p,w,x0,x1a,x2a,y0,y1a,y2a,1,0); x0=x2a; y0=y2a; + mp_info(r)=zero_off-1; + if ( turn_amt>=0 ) { + t1=t_of_the_way(t1,t2); + if ( t1>0 ) t1=0; + t=mp_crossing_point(mp, 0,-t1,-t2); + if ( t>fraction_one ) t=fraction_one; + @<Split off another rising cubic for |fin_offset_prep|@>; + mp_fin_offset_prep(mp, r,ww,x0,x1,x2,y0,y1,y2,-1,0); + } else { + mp_fin_offset_prep(mp, r,ww,x0,x1,x2,y0,y1,y2,-1,(-1-turn_amt)); + } +} + +@ @<Split off another rising cubic for |fin_offset_prep|@>= +mp_split_cubic(mp, r,t); mp_info(mp_link(r))=zero_off+1; +x1a=t_of_the_way(x1,x2); x1=t_of_the_way(x0,x1); +x0a=t_of_the_way(x1,x1a); +y1a=t_of_the_way(y1,y2); y1=t_of_the_way(y0,y1); +y0a=t_of_the_way(y1,y1a); +mp_fin_offset_prep(mp, mp_link(r),w,x0a,x1a,x2,y0a,y1a,y2,1,turn_amt); +x2=x0a; y2=y0a + +@ At this point, the direction of the incoming pen edge is |(-du,-dv)|. +When the component of $d(t)$ perpendicular to |(-du,-dv)| crosses zero, we +need to decide whether the directions are parallel or antiparallel. We +can test this by finding the dot product of $d(t)$ and |(-du,-dv)|, but this +should be avoided when the value of |turn_amt| already determines the +answer. If |t2<0|, there is one crossing and it is antiparallel only if +|turn_amt>=0|. If |turn_amt<0|, there should always be at least one +crossing and the first crossing cannot be antiparallel. + +@<Find the first |t| where $d(t)$ crosses $d_{k-1}$ or set...@>= +t=mp_crossing_point(mp, t0,t1,t2); +if ( turn_amt>=0 ) { + if ( t2<0 ) { + t=fraction_one+1; + } else { + u0=t_of_the_way(x0,x1); + u1=t_of_the_way(x1,x2); + ss=mp_take_fraction(mp, -du,t_of_the_way(u0,u1)); + v0=t_of_the_way(y0,y1); + v1=t_of_the_way(y1,y2); + ss=ss+mp_take_fraction(mp, -dv,t_of_the_way(v0,v1)); + if ( ss<0 ) t=fraction_one+1; + } +} else if ( t>fraction_one ) { + t=fraction_one; +} + +@ @<Other local variables for |offset_prep|@>= +integer u0,u1,v0,v1; /* intermediate values for $d(t)$ calculation */ +integer ss = 0; /* the part of the dot product computed so far */ +int d_sign; /* sign of overall change in direction for this cubic */ + +@ If the cubic almost has a cusp, it is a numerically ill-conditioned +problem to decide which way it loops around but that's OK as long we're +consistent. To make \&{doublepath} envelopes work properly, reversing +the path should always change the sign of |turn_amt|. + +@<Decide on the net change in pen offsets and set |turn_amt|@>= +d_sign=mp_ab_vs_cd(mp, dx,dyin, dxin,dy); +if ( d_sign==0 ) { + @<Check rotation direction based on node position@> +} +if ( d_sign==0 ) { + if ( dx==0 ) { + if ( dy>0 ) d_sign=1; else d_sign=-1; + } else { + if ( dx>0 ) d_sign=1; else d_sign=-1; + } +} +@<Make |ss| negative if and only if the total change in direction is + more than $180^\circ$@>; +turn_amt=mp_get_turn_amt(mp, w, dxin, dyin, (d_sign>0)); +if ( ss<0 ) turn_amt=turn_amt-d_sign*n + +@ We check rotation direction by looking at the vector connecting the current +node with the next. If its angle with incoming and outgoing tangents has the +same sign, we pick this as |d_sign|, since it means we have a flex, not a cusp. +Otherwise we proceed to the cusp code. + +@<Check rotation direction based on node position@>= +u0=mp_x_coord(q)-mp_x_coord(p); +u1=mp_y_coord(q)-mp_y_coord(p); +d_sign = half(mp_ab_vs_cd(mp, dx, u1, u0, dy)+ + mp_ab_vs_cd(mp, u0, dyin, dxin, u1)); + +@ In order to be invariant under path reversal, the result of this computation +should not change when |x0|, |y0|, $\ldots$ are all negated and |(x0,y0)| is +then swapped with |(x2,y2)|. We make use of the identities +|take_fraction(-a,-b)=take_fraction(a,b)| and +|t_of_the_way(-a,-b)=-(t_of_the_way(a,b))|. + +@<Make |ss| negative if and only if the total change in direction is...@>= +t0=half(mp_take_fraction(mp, x0,y2))-half(mp_take_fraction(mp, x2,y0)); +t1=half(mp_take_fraction(mp, x1,(y0+y2)))-half(mp_take_fraction(mp, y1,(x0+x2))); +if ( t0==0 ) t0=d_sign; /* path reversal always negates |d_sign| */ +if ( t0>0 ) { + t=mp_crossing_point(mp, t0,t1,-t0); + u0=t_of_the_way(x0,x1); + u1=t_of_the_way(x1,x2); + v0=t_of_the_way(y0,y1); + v1=t_of_the_way(y1,y2); +} else { + t=mp_crossing_point(mp, -t0,t1,t0); + u0=t_of_the_way(x2,x1); + u1=t_of_the_way(x1,x0); + v0=t_of_the_way(y2,y1); + v1=t_of_the_way(y1,y0); +} +ss=mp_take_fraction(mp, (x0+x2),t_of_the_way(u0,u1))+ + mp_take_fraction(mp, (y0+y2),t_of_the_way(v0,v1)) + +@ Here's a routine that prints an envelope spec in symbolic form. It assumes +that the |cur_pen| has not been walked around to the first offset. + +@c +static void mp_print_spec (MP mp,pointer cur_spec, pointer cur_pen, const char *s) { + pointer p,q; /* list traversal */ + pointer w; /* the current pen offset */ + mp_print_diagnostic(mp, "Envelope spec",s,true); + p=cur_spec; w=mp_pen_walk(mp, cur_pen,mp->spec_offset); + mp_print_ln(mp); + mp_print_two(mp, mp_x_coord(cur_spec),mp_y_coord(cur_spec)); + mp_print(mp, " % beginning with offset "); + mp_print_two(mp, mp_x_coord(w),mp_y_coord(w)); + do { + while (1) { + q=mp_link(p); + @<Print the cubic between |p| and |q|@>; + p=q; + if ((p==cur_spec) || (mp_info(p)!=zero_off)) + break; + } + if ( mp_info(p)!=zero_off ) { + @<Update |w| as indicated by |mp_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_info(p)| and print an explanation@>= +{ + w=mp_pen_walk(mp, w, (mp_info(p)-zero_off)); + mp_print(mp, " % "); + if ( mp_info(p)>zero_off ) mp_print(mp, "counter"); + mp_print(mp, "clockwise to offset "); + mp_print_two(mp, mp_x_coord(w),mp_y_coord(w)); +} + +@ @<Print the cubic between |p| and |q|@>= +{ + mp_print_nl(mp, " ..controls "); + mp_print_two(mp, mp_right_x(p),mp_right_y(p)); + mp_print(mp, " and "); + mp_print_two(mp, mp_left_x(q),mp_left_y(q)); + mp_print_nl(mp, " .."); + mp_print_two(mp, mp_x_coord(q),mp_y_coord(q)); +} + +@ Once we have an envelope spec, the remaining task to construct the actual +envelope by offsetting each cubic as determined by the |info| fields in +the knots. First we use |offset_prep| to convert the |c| into an envelope +spec. Then we add the offsets so that |c| becomes a cyclic path that represents +the envelope. + +The |ljoin| and |miterlim| parameters control the treatment of points where the +pen offset changes, and |lcap| controls the endpoints of a \&{doublepath}. +The endpoints are easily located because |c| is given in undoubled form +and then doubled in this procedure. We use |spec_p1| and |spec_p2| to keep +track of the endpoints and treat them like very sharp corners. +Butt end caps are treated like beveled joins; round end caps are treated like +round joins; and square end caps are achieved by setting |join_type:=3|. + +None of these parameters apply to inside joins where the convolution tracing +has retrograde lines. In such cases we use a simple connect-the-endpoints +approach that is achieved by setting |join_type:=2|. + +@c +static pointer mp_make_envelope (MP mp,pointer c, pointer h, quarterword ljoin, + quarterword lcap, scaled miterlim) { + pointer p,q,r,q0; /* for manipulating the path */ + int join_type=0; /* codes |0..3| for mitered, round, beveled, or square */ + pointer w,w0; /* the pen knot for the current offset */ + scaled qx,qy; /* unshifted coordinates of |q| */ + halfword k,k0; /* controls pen edge insertion */ + @<Other local variables for |make_envelope|@>; + dxin=0; dyin=0; dxout=0; dyout=0; + mp->spec_p1=null; mp->spec_p2=null; + @<If endpoint, double the path |c|, and set |spec_p1| and |spec_p2|@>; + @<Use |offset_prep| to compute the envelope spec then walk |h| around to + the initial offset@>; + w=h; + p=c; + do { + q=mp_link(p); q0=q; + qx=mp_x_coord(q); qy=mp_y_coord(q); + k=mp_info(q); + k0=k; w0=w; + if ( k!=zero_off ) { + @<Set |join_type| to indicate how to handle offset changes at~|q|@>; + } + @<Add offset |w| to the cubic from |p| to |q|@>; + while ( k!=zero_off ) { + @<Step |w| and move |k| one step closer to |zero_off|@>; + if ( (join_type==1)||(k==zero_off) ) + q=mp_insert_knot(mp, q,qx+mp_x_coord(w),qy+mp_y_coord(w)); + }; + if ( q!=mp_link(p) ) { + @<Set |p=mp_link(p)| and add knots between |p| and |q| as + required by |join_type|@>; + } + p=q; + } while (q0!=c); + return c; +} + +@ @<Use |offset_prep| to compute the envelope spec then walk |h| around to...@>= +c=mp_offset_prep(mp, c,h); +if ( mp->internal[mp_tracing_specs]>0 ) + mp_print_spec(mp, c,h,""); +h=mp_pen_walk(mp, h,mp->spec_offset) + +@ Mitered and squared-off joins depend on path directions that are difficult to +compute for degenerate cubics. The envelope spec computed by |offset_prep| can +have degenerate cubics only if the entire cycle collapses to a single +degenerate cubic. Setting |join_type:=2| in this case makes the computed +envelope degenerate as well. + +@<Set |join_type| to indicate how to handle offset changes at~|q|@>= +if ( k<zero_off ) { + join_type=2; +} else { + if ( (q!=mp->spec_p1)&&(q!=mp->spec_p2) ) join_type=ljoin; + else if ( lcap==2 ) join_type=3; + else join_type=2-lcap; + if ( (join_type==0)||(join_type==3) ) { + @<Set the incoming and outgoing directions at |q|; in case of + degeneracy set |join_type:=2|@>; + if ( join_type==0 ) { + @<If |miterlim| is less than the secant of half the angle at |q| + then set |join_type:=2|@>; + } + } +} + +@ @<If |miterlim| is less than the secant of half the angle at |q|...@>= +{ + tmp=mp_take_fraction(mp, miterlim,fraction_half+ + half(mp_take_fraction(mp, dxin,dxout)+mp_take_fraction(mp, dyin,dyout))); + if ( tmp<unity ) + if ( mp_take_scaled(mp, miterlim,tmp)<unity ) join_type=2; +} + +@ @<Other local variables for |make_envelope|@>= +fraction dxin,dyin,dxout,dyout; /* directions at |q| when square or mitered */ +scaled tmp; /* a temporary value */ + +@ The coordinates of |p| have already been shifted unless |p| is the first +knot in which case they get shifted at the very end. + +@<Add offset |w| to the cubic from |p| to |q|@>= +mp_right_x(p)=mp_right_x(p)+mp_x_coord(w); +mp_right_y(p)=mp_right_y(p)+mp_y_coord(w); +mp_left_x(q)=mp_left_x(q)+mp_x_coord(w); +mp_left_y(q)=mp_left_y(q)+mp_y_coord(w); +mp_x_coord(q)=mp_x_coord(q)+mp_x_coord(w); +mp_y_coord(q)=mp_y_coord(q)+mp_y_coord(w); +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_link(w); decr(k); } +else { w=knil(w); incr(k); } + +@ The cubic from |q| to the new knot at |(x,y)| becomes a line segment and +the |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 pointer mp_insert_knot (MP mp,pointer q, scaled x, scaled y); + +@ @c +pointer mp_insert_knot (MP mp,pointer q, scaled x, scaled y) { + /* returns the inserted knot */ + pointer r; /* the new knot */ + r=mp_get_node(mp, knot_node_size); + mp_link(r)=mp_link(q); mp_link(q)=r; + mp_right_x(r)=mp_right_x(q); + mp_right_y(r)=mp_right_y(q); + mp_x_coord(r)=x; + mp_y_coord(r)=y; + mp_right_x(q)=mp_x_coord(q); + mp_right_y(q)=mp_y_coord(q); + mp_left_x(r)=mp_x_coord(r); + mp_left_y(r)=mp_y_coord(r); + 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_link(p); + if ( (join_type==0)||(join_type==3) ) { + if ( join_type==0 ) { + @<Insert a new knot |r| between |p| and |q| as required for a mitered join@> + } else { + @<Make |r| the last of two knots inserted between |p| and |q| to form a + squared join@>; + } + if ( r!=null ) { + mp_right_x(r)=mp_x_coord(r); + mp_right_y(r)=mp_y_coord(r); + } + } +} + +@ For very small angles, adding a knot is unnecessary and would cause numerical +problems, so we just set |r:=null| in that case. + +@<Insert a new knot |r| between |p| and |q| as required for a mitered join@>= +{ + det=mp_take_fraction(mp, dyout,dxin)-mp_take_fraction(mp, dxout,dyin); + if ( abs(det)<26844 ) { + r=null; /* sine $<10^{-4}$ */ + } else { + tmp=mp_take_fraction(mp, mp_x_coord(q)-mp_x_coord(p),dyout)- + mp_take_fraction(mp, mp_y_coord(q)-mp_y_coord(p),dxout); + tmp=mp_make_fraction(mp, tmp,det); + r=mp_insert_knot(mp, p,mp_x_coord(p)+mp_take_fraction(mp, tmp,dxin), + mp_y_coord(p)+mp_take_fraction(mp, tmp,dyin)); + } +} + +@ @<Other local variables for |make_envelope|@>= +fraction det; /* a determinant used for mitered join calculations */ + +@ @<Make |r| the last of two knots inserted between |p| and |q| to form a...@>= +{ + ht_x=mp_y_coord(w)-mp_y_coord(w0); + ht_y=mp_x_coord(w0)-mp_x_coord(w); + while ( (abs(ht_x)<fraction_half)&&(abs(ht_y)<fraction_half) ) { + ht_x+=ht_x; ht_y+=ht_y; + } + @<Scan the pen polygon between |w0| and |w| and make |max_ht| the range dot + product with |(ht_x,ht_y)|@>; + tmp=mp_make_fraction(mp, max_ht,mp_take_fraction(mp, dxin,ht_x)+ + mp_take_fraction(mp, dyin,ht_y)); + r=mp_insert_knot(mp, p,mp_x_coord(p)+mp_take_fraction(mp, tmp,dxin), + mp_y_coord(p)+mp_take_fraction(mp, tmp,dyin)); + tmp=mp_make_fraction(mp, max_ht,mp_take_fraction(mp, dxout,ht_x)+ + mp_take_fraction(mp, dyout,ht_y)); + r=mp_insert_knot(mp, r,mp_x_coord(q)+mp_take_fraction(mp, tmp,dxout), + mp_y_coord(q)+mp_take_fraction(mp, tmp,dyout)); +} + +@ @<Other local variables for |make_envelope|@>= +fraction ht_x,ht_y; /* perpendicular to the segment from |p| to |q| */ +scaled max_ht; /* maximum height of the pen polygon above the |w0|-|w| line */ +halfword kk; /* keeps track of the pen vertices being scanned */ +pointer ww; /* the pen vertex being tested */ + +@ The dot product of the vector from |w0| to |ww| with |(ht_x,ht_y)| ranges +from zero to |max_ht|. + +@<Scan the pen polygon between |w0| and |w| and make |max_ht| the range...@>= +max_ht=0; +kk=zero_off; +ww=w; +while (1) { + @<Step |ww| and move |kk| one step closer to |k0|@>; + if ( kk==k0 ) break; + tmp=mp_take_fraction(mp, (mp_x_coord(ww)-mp_x_coord(w0)),ht_x)+ + mp_take_fraction(mp, (mp_y_coord(ww)-mp_y_coord(w0)),ht_y); + if ( tmp>max_ht ) max_ht=tmp; +} + + +@ @<Step |ww| and move |kk| one step closer to |k0|@>= +if ( kk>k0 ) { ww=mp_link(ww); decr(kk); } +else { ww=knil(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_link(mp->spec_p2)=mp_link(mp->spec_p1); + mp_link(mp->spec_p1)=c; + mp_remove_cubic(mp, mp->spec_p1); + c=mp->spec_p1; + if ( c!=mp_link(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; + mp_left_x(c)=mp_x_coord(c); mp_left_y(c)=mp_y_coord(c); + mp_right_x(c)=mp_x_coord(c); mp_right_y(c)=mp_y_coord(c); +} + +@ In degenerate situations we might have to look at the knot preceding~|q|. +That knot is |p| but if |p<>c|, its coordinates have already been offset by |w|. + +@<Set the incoming and outgoing directions at |q|; in case of...@>= +dxin=mp_x_coord(q)-mp_left_x(q); +dyin=mp_y_coord(q)-mp_left_y(q); +if ( (dxin==0)&&(dyin==0) ) { + dxin=mp_x_coord(q)-mp_right_x(p); + dyin=mp_y_coord(q)-mp_right_y(p); + if ( (dxin==0)&&(dyin==0) ) { + dxin=mp_x_coord(q)-mp_x_coord(p); + dyin=mp_y_coord(q)-mp_y_coord(p); + if ( p!=c ) { /* the coordinates of |p| have been offset by |w| */ + dxin=dxin+mp_x_coord(w); + dyin=dyin+mp_y_coord(w); + } + } +} +tmp=mp_pyth_add(mp, dxin,dyin); +if ( tmp==0 ) { + join_type=2; +} else { + dxin=mp_make_fraction(mp, dxin,tmp); + dyin=mp_make_fraction(mp, dyin,tmp); + @<Set the outgoing direction at |q|@>; +} + +@ If |q=c| then the coordinates of |r| and the control points between |q| +and~|r| have already been offset by |h|. + +@<Set the outgoing direction at |q|@>= +dxout=mp_right_x(q)-mp_x_coord(q); +dyout=mp_right_y(q)-mp_y_coord(q); +if ( (dxout==0)&&(dyout==0) ) { + r=mp_link(q); + dxout=mp_left_x(r)-mp_x_coord(q); + dyout=mp_left_y(r)-mp_y_coord(q); + if ( (dxout==0)&&(dyout==0) ) { + dxout=mp_x_coord(r)-mp_x_coord(q); + dyout=mp_y_coord(r)-mp_y_coord(q); + } +} +if ( q==c ) { + dxout=dxout-mp_x_coord(h); + dyout=dyout-mp_y_coord(h); +} +tmp=mp_pyth_add(mp, dxout,dyout); +if ( tmp==0 ) mp_confusion(mp, "degenerate spec"); +@:this can't happen degerate spec}{\quad degenerate spec@> +dxout=mp_make_fraction(mp, dxout,tmp); +dyout=mp_make_fraction(mp, dyout,tmp) + +@* \[23] Direction and intersection times. +A path of length $n$ is defined parametrically by functions $x(t)$ and +$y(t)$, for |0<=t<=n|; we can regard $t$ as the ``time'' at which the path +reaches the point $\bigl(x(t),y(t)\bigr)$. In this section of the program +we shall consider operations that determine special times associated with +given paths: the first time that a path travels in a given direction, and +a pair of times at which two paths cross each other. + +@ Let's start with the easier task. The function |find_direction_time| is +given a direction |(x,y)| and a path starting at~|h|. If the path never +travels in direction |(x,y)|, the direction time will be~|-1|; otherwise +it will be nonnegative. + +Certain anomalous cases can arise: If |(x,y)=(0,0)|, so that the given +direction is undefined, the direction time will be~0. If $\bigl(x'(t), +y'(t)\bigr)=(0,0)$, so that the path direction is undefined, it will be +assumed to match any given direction at time~|t|. + +The routine solves this problem in nondegenerate cases by rotating the path +and the given direction so that |(x,y)=(1,0)|; i.e., the main task will be +to find when a given path first travels ``due east.'' + +@c +static scaled mp_find_direction_time (MP mp,scaled x, scaled y, pointer h) { + scaled max; /* $\max\bigl(\vert x\vert,\vert y\vert\bigr)$ */ + pointer p,q; /* for list traversal */ + scaled n; /* the direction time at knot |p| */ + scaled tt; /* the direction time within a cubic */ + @<Other local variables for |find_direction_time|@>; + @<Normalize the given direction for better accuracy; + but |return| with zero result if it's zero@>; + n=0; p=h; phi=0; + while (1) { + if ( mp_right_type(p)==mp_endpoint ) break; + q=mp_link(p); + @<Rotate the cubic between |p| and |q|; then + |goto found| if the rotated cubic travels due east at some time |tt|; + but |break| if an entire cyclic path has been traversed@>; + p=q; n=n+unity; + } + return (-unity); +FOUND: + return (n+tt); +} + +@ @<Normalize the given direction for better accuracy...@>= +if ( abs(x)<abs(y) ) { + x=mp_make_fraction(mp, x,abs(y)); + if ( y>0 ) y=fraction_one; else y=-fraction_one; +} else if ( x==0 ) { + return 0; +} else { + y=mp_make_fraction(mp, y,abs(x)); + if ( x>0 ) x=fraction_one; else x=-fraction_one; +} + +@ Since we're interested in the tangent directions, we work with the +derivative $${1\over3}B'(x_0,x_1,x_2,x_3;t)= +B(x_1-x_0,x_2-x_1,x_3-x_2;t)$$ instead of +$B(x_0,x_1,x_2,x_3;t)$ itself. The derived coefficients are also scaled up +in order to achieve better accuracy. + +The given path may turn abruptly at a knot, and it might pass the critical +tangent direction at such a time. Therefore we remember the direction |phi| +in which the previous rotated cubic was traveling. (The value of |phi| will be +undefined on the first cubic, i.e., when |n=0|.) + +@<Rotate the cubic between |p| and |q|; then...@>= +tt=0; +@<Set local variables |x1,x2,x3| and |y1,y2,y3| to multiples of the control + points of the rotated derivatives@>; +if ( y1==0 ) if ( x1>=0 ) goto FOUND; +if ( n>0 ) { + @<Exit to |found| if an eastward direction occurs at knot |p|@>; + if ( p==h ) break; + }; +if ( (x3!=0)||(y3!=0) ) phi=mp_n_arg(mp, x3,y3); +@<Exit to |found| if the curve whose derivatives are specified by + |x1,x2,x3,y1,y2,y3| travels eastward at some time~|tt|@> + +@ @<Other local variables for |find_direction_time|@>= +scaled x1,x2,x3,y1,y2,y3; /* multiples of rotated derivatives */ +angle theta,phi; /* angles of exit and entry at a knot */ +fraction t; /* temp storage */ + +@ @<Set local variables |x1,x2,x3| and |y1,y2,y3| to multiples...@>= +x1=mp_right_x(p)-mp_x_coord(p); x2=mp_left_x(q)-mp_right_x(p); +x3=mp_x_coord(q)-mp_left_x(q); +y1=mp_right_y(p)-mp_y_coord(p); y2=mp_left_y(q)-mp_right_y(p); +y3=mp_y_coord(q)-mp_left_y(q); +max=abs(x1); +if ( abs(x2)>max ) max=abs(x2); +if ( abs(x3)>max ) max=abs(x3); +if ( abs(y1)>max ) max=abs(y1); +if ( abs(y2)>max ) max=abs(y2); +if ( abs(y3)>max ) max=abs(y3); +if ( max==0 ) goto FOUND; +while ( max<fraction_half ){ + max+=max; x1+=x1; x2+=x2; x3+=x3; + y1+=y1; y2+=y2; y3+=y3; +} +t=x1; x1=mp_take_fraction(mp, x1,x)+mp_take_fraction(mp, y1,y); +y1=mp_take_fraction(mp, y1,x)-mp_take_fraction(mp, t,y); +t=x2; x2=mp_take_fraction(mp, x2,x)+mp_take_fraction(mp, y2,y); +y2=mp_take_fraction(mp, y2,x)-mp_take_fraction(mp, t,y); +t=x3; x3=mp_take_fraction(mp, x3,x)+mp_take_fraction(mp, y3,y); +y3=mp_take_fraction(mp, y3,x)-mp_take_fraction(mp, t,y) + +@ @<Exit to |found| if an eastward direction occurs at knot |p|@>= +theta=mp_n_arg(mp, x1,y1); +if ( theta>=0 ) if ( phi<=0 ) if ( phi>=theta-one_eighty_deg ) goto FOUND; +if ( theta<=0 ) if ( phi>=0 ) if ( phi<=theta+one_eighty_deg ) goto FOUND + +@ In this step we want to use the |crossing_point| routine to find the +roots of the quadratic equation $B(y_1,y_2,y_3;t)=0$. +Several complications arise: If the quadratic equation has a double root, +the curve never crosses zero, and |crossing_point| will find nothing; +this case occurs iff $y_1y_3=y_2^2$ and $y_1y_2<0$. If the quadratic +equation has simple roots, or only one root, we may have to negate it +so that $B(y_1,y_2,y_3;t)$ crosses from positive to negative at its first root. +And finally, we need to do special things if $B(y_1,y_2,y_3;t)$ is +identically zero. + +@ @<Exit to |found| if the curve whose derivatives are specified by...@>= +if ( x1<0 ) if ( x2<0 ) if ( x3<0 ) goto DONE; +if ( mp_ab_vs_cd(mp, y1,y3,y2,y2)==0 ) { + @<Handle the test for eastward directions when $y_1y_3=y_2^2$; + either |goto found| or |goto done|@>; +} +if ( y1<=0 ) { + if ( y1<0 ) { y1=-y1; y2=-y2; y3=-y3; } + else if ( y2>0 ){ y2=-y2; y3=-y3; }; +} +@<Check the places where $B(y_1,y_2,y_3;t)=0$ to see if + $B(x_1,x_2,x_3;t)\ge0$@>; +DONE: + +@ The quadratic polynomial $B(y_1,y_2,y_3;t)$ begins |>=0| and has at most +two roots, because we know that it isn't identically zero. + +It must be admitted that the |crossing_point| routine is not perfectly accurate; +rounding errors might cause it to find a root when $y_1y_3>y_2^2$, or to +miss the roots when $y_1y_3<y_2^2$. The rotation process is itself +subject to rounding errors. Yet this code optimistically tries to +do the right thing. + +@d we_found_it { tt=(t+04000) / 010000; goto FOUND; } + +@<Check the places where $B(y_1,y_2,y_3;t)=0$...@>= +t=mp_crossing_point(mp, y1,y2,y3); +if ( t>fraction_one ) goto DONE; +y2=t_of_the_way(y2,y3); +x1=t_of_the_way(x1,x2); +x2=t_of_the_way(x2,x3); +x1=t_of_the_way(x1,x2); +if ( x1>=0 ) we_found_it; +if ( y2>0 ) y2=0; +tt=t; t=mp_crossing_point(mp, 0,-y2,-y3); +if ( t>fraction_one ) goto DONE; +x1=t_of_the_way(x1,x2); +x2=t_of_the_way(x2,x3); +if ( t_of_the_way(x1,x2)>=0 ) { + t=t_of_the_way(tt,fraction_one); we_found_it; +} + +@ @<Handle the test for eastward directions when $y_1y_3=y_2^2$; + either |goto found| or |goto done|@>= +{ + if ( mp_ab_vs_cd(mp, y1,y2,0,0)<0 ) { + t=mp_make_fraction(mp, y1,y1-y2); + x1=t_of_the_way(x1,x2); + x2=t_of_the_way(x2,x3); + if ( t_of_the_way(x1,x2)>=0 ) we_found_it; + } else if ( y3==0 ) { + if ( y1==0 ) { + @<Exit to |found| if the derivative $B(x_1,x_2,x_3;t)$ becomes |>=0|@>; + } else if ( x3>=0 ) { + tt=unity; goto FOUND; + } + } + goto DONE; +} + +@ At this point we know that the derivative of |y(t)| is identically zero, +and that |x1<0|; but either |x2>=0| or |x3>=0|, so there's some hope of +traveling east. + +@<Exit to |found| if the derivative $B(x_1,x_2,x_3;t)$ becomes |>=0|...@>= +{ + t=mp_crossing_point(mp, -x1,-x2,-x3); + if ( t<=fraction_one ) we_found_it; + if ( mp_ab_vs_cd(mp, x1,x3,x2,x2)<=0 ) { + t=mp_make_fraction(mp, x1,x1-x2); we_found_it; + } +} + +@ The intersection of two cubics can be found by an interesting variant +of the general bisection scheme described in the introduction to +|crossing_point|.\ +Given $w(t)=B(w_0,w_1,w_2,w_3;t)$ and $z(t)=B(z_0,z_1,z_2,z_3;t)$, +we wish to find a pair of times $(t_1,t_2)$ such that $w(t_1)=z(t_2)$, +if an intersection exists. First we find the smallest rectangle that +encloses the points $\{w_0,w_1,w_2,w_3\}$ and check that it overlaps +the smallest rectangle that encloses +$\{z_0,z_1,z_2,z_3\}$; if not, the cubics certainly don't intersect. +But if the rectangles do overlap, we bisect the intervals, getting +new cubics $w'$ and~$w''$, $z'$~and~$z''$; the intersection routine first +tries for an intersection between $w'$ and~$z'$, then (if unsuccessful) +between $w'$ and~$z''$, then (if still unsuccessful) between $w''$ and~$z'$, +finally (if thrice unsuccessful) between $w''$ and~$z''$. After $l$~successful +levels of bisection we will have determined the intersection times $t_1$ +and~$t_2$ to $l$~bits of accuracy. + +\def\submin{_{\rm min}} \def\submax{_{\rm max}} +As before, it is better to work with the numbers $W_k=2^l(w_k-w_{k-1})$ +and $Z_k=2^l(z_k-z_{k-1})$ rather than the coefficients $w_k$ and $z_k$ +themselves. We also need one other quantity, $\Delta=2^l(w_0-z_0)$, +to determine when the enclosing rectangles overlap. Here's why: +The $x$~coordinates of~$w(t)$ are between $u\submin$ and $u\submax$, +and the $x$~coordinates of~$z(t)$ are between $x\submin$ and $x\submax$, +if we write $w_k=(u_k,v_k)$ and $z_k=(x_k,y_k)$ and $u\submin= +\min(u_0,u_1,u_2,u_3)$, etc. These intervals of $x$~coordinates +overlap if and only if $u\submin\L x\submax$ and +$x\submin\L u\submax$. Letting +$$U\submin=\min(0,U_1,U_1+U_2,U_1+U_2+U_3),\; + U\submax=\max(0,U_1,U_1+U_2,U_1+U_2+U_3),$$ +we have $2^lu\submin=2^lu_0+U\submin$, etc.; the condition for overlap +reduces to +$$X\submin-U\submax\L 2^l(u_0-x_0)\L X\submax-U\submin.$$ +Thus we want to maintain the quantity $2^l(u_0-x_0)$; similarly, +the quantity $2^l(v_0-y_0)$ accounts for the $y$~coordinates. The +coordinates of $\Delta=2^l(w_0-z_0)$ must stay bounded as $l$ increases, +because of the overlap condition; i.e., we know that $X\submin$, +$X\submax$, and their relatives are bounded, hence $X\submax- +U\submin$ and $X\submin-U\submax$ are bounded. + +@ Incidentally, if the given cubics intersect more than once, the process +just sketched will not necessarily find the lexicographically smallest pair +$(t_1,t_2)$. The solution actually obtained will be smallest in ``shuffled +order''; i.e., if $t_1=(.a_1a_2\ldots a_{16})_2$ and +$t_2=(.b_1b_2\ldots b_{16})_2$, then we will minimize +$a_1b_1a_2b_2\ldots a_{16}b_{16}$, not +$a_1a_2\ldots a_{16}b_1b_2\ldots b_{16}$. +Shuffled order agrees with lexicographic order if all pairs of solutions +$(t_1,t_2)$ and $(t_1',t_2')$ have the property that $t_1<t_1'$ iff +$t_2<t_2'$; but in general, lexicographic order can be quite different, +and the bisection algorithm would be substantially less efficient if it were +constrained by lexicographic order. + +For example, suppose that an overlap has been found for $l=3$ and +$(t_1,t_2)= (.101,.011)$ in binary, but that no overlap is produced by +either of the alternatives $(.1010,.0110)$, $(.1010,.0111)$ at level~4. +Then there is probably an intersection in one of the subintervals +$(.1011,.011x)$; but lexicographic order would require us to explore +$(.1010,.1xxx)$ and $(.1011,.00xx)$ and $(.1011,.010x)$ first. We wouldn't +want to store all of the subdivision data for the second path, so the +subdivisions would have to be regenerated many times. Such inefficiencies +would be associated with every `1' in the binary representation of~$t_1$. + +@ The subdivision process introduces rounding errors, hence we need to +make a more liberal test for overlap. It is not hard to show that the +computed values of $U_i$ differ from the truth by at most~$l$, on +level~$l$, hence $U\submin$ and $U\submax$ will be at most $3l$ in error. +If $\beta$ is an upper bound on the absolute error in the computed +components of $\Delta=(|delx|,|dely|)$ on level~$l$, we will replace +the test `$X\submin-U\submax\L|delx|$' by the more liberal test +`$X\submin-U\submax\L|delx|+|tol|$', where $|tol|=6l+\beta$. + +More accuracy is obtained if we try the algorithm first with |tol=0|; +the more liberal tolerance is used only if an exact approach fails. +It is convenient to do this double-take by letting `3' in the preceding +paragraph be a parameter, which is first 0, then 3. + +@<Glob...@>= +unsigned int tol_step; /* either 0 or 3, usually */ + +@ We shall use an explicit stack to implement the recursive bisection +method described above. The |bisect_stack| array will contain numerous 5-word +packets like $(U_1,U_2,U_3,U\submin,U\submax)$, as well as 20-word packets +comprising the 5-word packets for $U$, $V$, $X$, and~$Y$. + +The following macros define the allocation of stack positions to +the quantities needed for bisection-intersection. + +@d stack_1(A) mp->bisect_stack[(A)] /* $U_1$, $V_1$, $X_1$, or $Y_1$ */ +@d stack_2(A) mp->bisect_stack[(A)+1] /* $U_2$, $V_2$, $X_2$, or $Y_2$ */ +@d stack_3(A) mp->bisect_stack[(A)+2] /* $U_3$, $V_3$, $X_3$, or $Y_3$ */ +@d stack_min(A) mp->bisect_stack[(A)+3] + /* $U\submin$, $V\submin$, $X\submin$, or $Y\submin$ */ +@d stack_max(A) mp->bisect_stack[(A)+4] + /* $U\submax$, $V\submax$, $X\submax$, or $Y\submax$ */ +@d int_packets 20 /* number of words to represent $U_k$, $V_k$, $X_k$, and $Y_k$ */ +@# +@d u_packet(A) ((A)-5) +@d v_packet(A) ((A)-10) +@d x_packet(A) ((A)-15) +@d y_packet(A) ((A)-20) +@d l_packets (mp->bisect_ptr-int_packets) +@d r_packets mp->bisect_ptr +@d ul_packet u_packet(l_packets) /* base of $U'_k$ variables */ +@d vl_packet v_packet(l_packets) /* base of $V'_k$ variables */ +@d xl_packet x_packet(l_packets) /* base of $X'_k$ variables */ +@d yl_packet y_packet(l_packets) /* base of $Y'_k$ variables */ +@d ur_packet u_packet(r_packets) /* base of $U''_k$ variables */ +@d vr_packet v_packet(r_packets) /* base of $V''_k$ variables */ +@d xr_packet x_packet(r_packets) /* base of $X''_k$ variables */ +@d yr_packet y_packet(r_packets) /* base of $Y''_k$ variables */ +@# +@d u1l stack_1(ul_packet) /* $U'_1$ */ +@d u2l stack_2(ul_packet) /* $U'_2$ */ +@d u3l stack_3(ul_packet) /* $U'_3$ */ +@d v1l stack_1(vl_packet) /* $V'_1$ */ +@d v2l stack_2(vl_packet) /* $V'_2$ */ +@d v3l stack_3(vl_packet) /* $V'_3$ */ +@d x1l stack_1(xl_packet) /* $X'_1$ */ +@d x2l stack_2(xl_packet) /* $X'_2$ */ +@d x3l stack_3(xl_packet) /* $X'_3$ */ +@d y1l stack_1(yl_packet) /* $Y'_1$ */ +@d y2l stack_2(yl_packet) /* $Y'_2$ */ +@d y3l stack_3(yl_packet) /* $Y'_3$ */ +@d u1r stack_1(ur_packet) /* $U''_1$ */ +@d u2r stack_2(ur_packet) /* $U''_2$ */ +@d u3r stack_3(ur_packet) /* $U''_3$ */ +@d v1r stack_1(vr_packet) /* $V''_1$ */ +@d v2r stack_2(vr_packet) /* $V''_2$ */ +@d v3r stack_3(vr_packet) /* $V''_3$ */ +@d x1r stack_1(xr_packet) /* $X''_1$ */ +@d x2r stack_2(xr_packet) /* $X''_2$ */ +@d x3r stack_3(xr_packet) /* $X''_3$ */ +@d y1r stack_1(yr_packet) /* $Y''_1$ */ +@d y2r stack_2(yr_packet) /* $Y''_2$ */ +@d y3r stack_3(yr_packet) /* $Y''_3$ */ +@# +@d stack_dx mp->bisect_stack[mp->bisect_ptr] /* stacked value of |delx| */ +@d stack_dy mp->bisect_stack[mp->bisect_ptr+1] /* stacked value of |dely| */ +@d stack_tol mp->bisect_stack[mp->bisect_ptr+2] /* stacked value of |tol| */ +@d stack_uv mp->bisect_stack[mp->bisect_ptr+3] /* stacked value of |uv| */ +@d stack_xy mp->bisect_stack[mp->bisect_ptr+4] /* stacked value of |xy| */ +@d int_increment (int_packets+int_packets+5) /* number of stack words per level */ + +@<Glob...@>= +integer *bisect_stack; +integer bisect_ptr; + +@ @<Allocate or initialize ...@>= +mp->bisect_stack = xmalloc((bistack_size+1),sizeof(integer)); + +@ @<Dealloc variables@>= +xfree(mp->bisect_stack); + +@ @<Check the ``constant''...@>= +if ( int_packets+17*int_increment>bistack_size ) mp->bad=19; + +@ Computation of the min and max is a tedious but fairly fast sequence of +instructions; exactly four comparisons are made in each branch. + +@d set_min_max(A) + if ( stack_1((A))<0 ) { + if ( stack_3((A))>=0 ) { + if ( stack_2((A))<0 ) stack_min((A))=stack_1((A))+stack_2((A)); + else stack_min((A))=stack_1((A)); + stack_max((A))=stack_1((A))+stack_2((A))+stack_3((A)); + if ( stack_max((A))<0 ) stack_max((A))=0; + } else { + stack_min((A))=stack_1((A))+stack_2((A))+stack_3((A)); + if ( stack_min((A))>stack_1((A)) ) stack_min((A))=stack_1((A)); + stack_max((A))=stack_1((A))+stack_2((A)); + if ( stack_max((A))<0 ) stack_max((A))=0; + } + } else if ( stack_3((A))<=0 ) { + if ( stack_2((A))>0 ) stack_max((A))=stack_1((A))+stack_2((A)); + else stack_max((A))=stack_1((A)); + stack_min((A))=stack_1((A))+stack_2((A))+stack_3((A)); + if ( stack_min((A))>0 ) stack_min((A))=0; + } else { + stack_max((A))=stack_1((A))+stack_2((A))+stack_3((A)); + if ( stack_max((A))<stack_1((A)) ) stack_max((A))=stack_1((A)); + stack_min((A))=stack_1((A))+stack_2((A)); + if ( stack_min((A))>0 ) stack_min((A))=0; + } + +@ It's convenient to keep the current values of $l$, $t_1$, and $t_2$ in +the integer form $2^l+2^lt_1$ and $2^l+2^lt_2$. The |cubic_intersection| +routine uses global variables |cur_t| and |cur_tt| for this purpose; +after successful completion, |cur_t| and |cur_tt| will contain |unity| +plus the |scaled| values of $t_1$ and~$t_2$. + +The values of |cur_t| and |cur_tt| will be set to zero if |cubic_intersection| +finds no intersection. The routine gives up and gives an approximate answer +if it has backtracked +more than 5000 times (otherwise there are cases where several minutes +of fruitless computation would be possible). + +@d max_patience 5000 + +@<Glob...@>= +integer cur_t;integer cur_tt; /* controls and results of |cubic_intersection| */ +integer time_to_go; /* this many backtracks before giving up */ +integer max_t; /* maximum of $2^{l+1}$ so far achieved */ + +@ The given cubics $B(w_0,w_1,w_2,w_3;t)$ and +$B(z_0,z_1,z_2,z_3;t)$ are specified in adjacent knot nodes |(p,mp_link(p))| +and |(pp,mp_link(pp))|, respectively. + +@c +static void mp_cubic_intersection (MP mp,pointer p, pointer pp) { + pointer q,qq; /* |mp_link(p)|, |mp_link(pp)| */ + mp->time_to_go=max_patience; mp->max_t=2; + @<Initialize for intersections at level zero@>; +CONTINUE: + while (1) { + if ( mp->delx-mp->tol<=stack_max(x_packet(mp->xy))-stack_min(u_packet(mp->uv))) + if ( mp->delx+mp->tol>=stack_min(x_packet(mp->xy))-stack_max(u_packet(mp->uv))) + if ( mp->dely-mp->tol<=stack_max(y_packet(mp->xy))-stack_min(v_packet(mp->uv))) + if ( mp->dely+mp->tol>=stack_min(y_packet(mp->xy))-stack_max(v_packet(mp->uv))) + { + if ( mp->cur_t>=mp->max_t ){ + if ( mp->max_t==two ) { /* we've done 17 bisections */ + mp->cur_t=halfp(mp->cur_t+1); + mp->cur_tt=halfp(mp->cur_tt+1); + return; + } + mp->max_t+=mp->max_t; mp->appr_t=mp->cur_t; mp->appr_tt=mp->cur_tt; + } + @<Subdivide for a new level of intersection@>; + goto CONTINUE; + } + if ( mp->time_to_go>0 ) { + decr(mp->time_to_go); + } else { + while ( mp->appr_t<unity ) { + mp->appr_t+=mp->appr_t; mp->appr_tt+=mp->appr_tt; + } + mp->cur_t=mp->appr_t; mp->cur_tt=mp->appr_tt; return; + } + @<Advance to the next pair |(cur_t,cur_tt)|@>; + } +} + +@ The following variables are global, although they are used only by +|cubic_intersection|, because it is necessary on some machines to +split |cubic_intersection| up into two procedures. + +@<Glob...@>= +integer delx;integer dely; /* the components of $\Delta=2^l(w_0-z_0)$ */ +integer tol; /* bound on the uncertainty in the overlap test */ +integer uv; +integer xy; /* pointers to the current packets of interest */ +integer three_l; /* |tol_step| times the bisection level */ +integer appr_t;integer appr_tt; /* best approximations known to the answers */ + +@ We shall assume that the coordinates are sufficiently non-extreme that +integer overflow will not occur. +@^overflow in arithmetic@> + +@<Initialize for intersections at level zero@>= +q=mp_link(p); qq=mp_link(pp); mp->bisect_ptr=int_packets; +u1r=mp_right_x(p)-mp_x_coord(p); u2r=mp_left_x(q)-mp_right_x(p); +u3r=mp_x_coord(q)-mp_left_x(q); set_min_max(ur_packet); +v1r=mp_right_y(p)-mp_y_coord(p); v2r=mp_left_y(q)-mp_right_y(p); +v3r=mp_y_coord(q)-mp_left_y(q); set_min_max(vr_packet); +x1r=mp_right_x(pp)-mp_x_coord(pp); x2r=mp_left_x(qq)-mp_right_x(pp); +x3r=mp_x_coord(qq)-mp_left_x(qq); set_min_max(xr_packet); +y1r=mp_right_y(pp)-mp_y_coord(pp); y2r=mp_left_y(qq)-mp_right_y(pp); +y3r=mp_y_coord(qq)-mp_left_y(qq); set_min_max(yr_packet); +mp->delx=mp_x_coord(p)-mp_x_coord(pp); mp->dely=mp_y_coord(p)-mp_y_coord(pp); +mp->tol=0; mp->uv=r_packets; mp->xy=r_packets; +mp->three_l=0; mp->cur_t=1; mp->cur_tt=1 + +@ @<Subdivide for a new level of intersection@>= +stack_dx=mp->delx; stack_dy=mp->dely; stack_tol=mp->tol; +stack_uv=mp->uv; stack_xy=mp->xy; +mp->bisect_ptr=mp->bisect_ptr+int_increment; +mp->cur_t+=mp->cur_t; mp->cur_tt+=mp->cur_tt; +u1l=stack_1(u_packet(mp->uv)); u3r=stack_3(u_packet(mp->uv)); +u2l=half(u1l+stack_2(u_packet(mp->uv))); +u2r=half(u3r+stack_2(u_packet(mp->uv))); +u3l=half(u2l+u2r); u1r=u3l; +set_min_max(ul_packet); set_min_max(ur_packet); +v1l=stack_1(v_packet(mp->uv)); v3r=stack_3(v_packet(mp->uv)); +v2l=half(v1l+stack_2(v_packet(mp->uv))); +v2r=half(v3r+stack_2(v_packet(mp->uv))); +v3l=half(v2l+v2r); v1r=v3l; +set_min_max(vl_packet); set_min_max(vr_packet); +x1l=stack_1(x_packet(mp->xy)); x3r=stack_3(x_packet(mp->xy)); +x2l=half(x1l+stack_2(x_packet(mp->xy))); +x2r=half(x3r+stack_2(x_packet(mp->xy))); +x3l=half(x2l+x2r); x1r=x3l; +set_min_max(xl_packet); set_min_max(xr_packet); +y1l=stack_1(y_packet(mp->xy)); y3r=stack_3(y_packet(mp->xy)); +y2l=half(y1l+stack_2(y_packet(mp->xy))); +y2r=half(y3r+stack_2(y_packet(mp->xy))); +y3l=half(y2l+y2r); y1r=y3l; +set_min_max(yl_packet); set_min_max(yr_packet); +mp->uv=l_packets; mp->xy=l_packets; +mp->delx+=mp->delx; mp->dely+=mp->dely; +mp->tol=mp->tol-mp->three_l+mp->tol_step; +mp->tol+=mp->tol; mp->three_l=mp->three_l+mp->tol_step + +@ @<Advance to the next pair |(cur_t,cur_tt)|@>= +NOT_FOUND: +if ( odd(mp->cur_tt) ) { + if ( odd(mp->cur_t) ) { + @<Descend to the previous level and |goto not_found|@>; + } else { + incr(mp->cur_t); + mp->delx=mp->delx+stack_1(u_packet(mp->uv))+stack_2(u_packet(mp->uv)) + +stack_3(u_packet(mp->uv)); + mp->dely=mp->dely+stack_1(v_packet(mp->uv))+stack_2(v_packet(mp->uv)) + +stack_3(v_packet(mp->uv)); + mp->uv=mp->uv+int_packets; /* switch from |l_packets| to |r_packets| */ + decr(mp->cur_tt); mp->xy=mp->xy-int_packets; + /* switch from |r_packets| to |l_packets| */ + mp->delx=mp->delx+stack_1(x_packet(mp->xy))+stack_2(x_packet(mp->xy)) + +stack_3(x_packet(mp->xy)); + mp->dely=mp->dely+stack_1(y_packet(mp->xy))+stack_2(y_packet(mp->xy)) + +stack_3(y_packet(mp->xy)); + } +} else { + incr(mp->cur_tt); mp->tol=mp->tol+mp->three_l; + mp->delx=mp->delx-stack_1(x_packet(mp->xy))-stack_2(x_packet(mp->xy)) + -stack_3(x_packet(mp->xy)); + mp->dely=mp->dely-stack_1(y_packet(mp->xy))-stack_2(y_packet(mp->xy)) + -stack_3(y_packet(mp->xy)); + mp->xy=mp->xy+int_packets; /* switch from |l_packets| to |r_packets| */ +} + +@ @<Descend to the previous level...@>= +{ + mp->cur_t=halfp(mp->cur_t); mp->cur_tt=halfp(mp->cur_tt); + if ( mp->cur_t==0 ) return; + mp->bisect_ptr=mp->bisect_ptr-int_increment; + mp->three_l=mp->three_l-mp->tol_step; + mp->delx=stack_dx; mp->dely=stack_dy; mp->tol=stack_tol; + mp->uv=stack_uv; mp->xy=stack_xy; + goto NOT_FOUND; +} + +@ The |path_intersection| procedure is much simpler. +It invokes |cubic_intersection| in lexicographic order until finding a +pair of cubics that intersect. The final intersection times are placed in +|cur_t| and~|cur_tt|. + +@c +static void mp_path_intersection (MP mp,pointer h, pointer hh) { + pointer p,pp; /* link registers that traverse the given paths */ + integer n,nn; /* integer parts of intersection times, minus |unity| */ + @<Change one-point paths into dead cycles@>; + mp->tol_step=0; + do { + n=-unity; p=h; + do { + if ( mp_right_type(p)!=mp_endpoint ) { + nn=-unity; pp=hh; + do { + if ( mp_right_type(pp)!=mp_endpoint ) { + mp_cubic_intersection(mp, p,pp); + if ( mp->cur_t>0 ) { + mp->cur_t=mp->cur_t+n; mp->cur_tt=mp->cur_tt+nn; + return; + } + } + nn=nn+unity; pp=mp_link(pp); + } while (pp!=hh); + } + n=n+unity; p=mp_link(p); + } while (p!=h); + mp->tol_step=mp->tol_step+3; + } while (mp->tol_step<=3); + mp->cur_t=-unity; mp->cur_tt=-unity; +} + +@ @<Change one-point paths...@>= +if ( mp_right_type(h)==mp_endpoint ) { + mp_right_x(h)=mp_x_coord(h); mp_left_x(h)=mp_x_coord(h); + mp_right_y(h)=mp_y_coord(h); mp_left_y(h)=mp_y_coord(h); mp_right_type(h)=mp_explicit; +} +if ( mp_right_type(hh)==mp_endpoint ) { + mp_right_x(hh)=mp_x_coord(hh); mp_left_x(hh)=mp_x_coord(hh); + mp_right_y(hh)=mp_y_coord(hh); mp_left_y(hh)=mp_y_coord(hh); mp_right_type(hh)=mp_explicit; +} + +@* \[24] Dynamic linear equations. +\MP\ users define variables implicitly by stating equations that should be +satisfied; the computer is supposed to be smart enough to solve those equations. +And indeed, the computer tries valiantly to do so, by distinguishing five +different types of numeric values: + +\smallskip\hang +|type(p)=mp_known| is the nice case, when |value(p)| is the |scaled| value +of the variable whose address is~|p|. + +\smallskip\hang +|type(p)=mp_dependent| means that |value(p)| is not present, but |dep_list(p)| +points to a {\sl dependency list\/} that expresses the value of variable~|p| +as a |scaled| number plus a sum of independent variables with |fraction| +coefficients. + +\smallskip\hang +|type(p)=mp_independent| means that |value(p)=64s+m|, where |s>0| is a ``serial +number'' reflecting the time this variable was first used in an equation; +also |0<=m<64|, and each dependent variable +that refers to this one is actually referring to the future value of +this variable times~$2^m$. (Usually |m=0|, but higher degrees of +scaling are sometimes needed to keep the coefficients in dependency lists +from getting too large. The value of~|m| will always be even.) + +\smallskip\hang +|type(p)=mp_numeric_type| means that variable |p| hasn't appeared in an +equation before, but it has been explicitly declared to be numeric. + +\smallskip\hang +|type(p)=undefined| means that variable |p| hasn't appeared before. + +\smallskip\noindent +We have actually discussed these five types in the reverse order of their +history during a computation: Once |known|, a variable never again +becomes |dependent|; once |dependent|, it almost never again becomes +|mp_independent|; once |mp_independent|, it never again becomes |mp_numeric_type|; +and once |mp_numeric_type|, it never again becomes |undefined| (except +of course when the user specifically decides to scrap the old value +and start again). A backward step may, however, take place: Sometimes +a |dependent| variable becomes |mp_independent| again, when one of the +independent variables it depends on is reverting to |undefined|. + + +The next patch detects overflow of independent-variable serial +numbers. Diagnosed and patched by Thorsten Dahlheimer. + +@d s_scale 64 /* the serial numbers are multiplied by this factor */ +@d new_indep(A) /* create a new independent variable */ + { if ( mp->serial_no>el_gordo-s_scale ) + mp_fatal_error(mp, "variable instance identifiers exhausted"); + mp_type((A))=mp_independent; mp->serial_no=mp->serial_no+s_scale; + value((A))=mp->serial_no; + } + +@<Glob...@>= +integer serial_no; /* the most recent serial number, times |s_scale| */ + +@ @<Make variable |q+s| newly independent@>=new_indep(q+s) + +@ But how are dependency lists represented? It's simple: The linear combination +$\alpha_1v_1+\cdots+\alpha_kv_k+\beta$ appears in |k+1| value nodes. If +|q=dep_list(p)| points to this list, and if |k>0|, then |value(q)= +@t$\alpha_1$@>| (which is a |fraction|); |mp_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 |value(q)=@t$\beta$@>| (which is |scaled|) and |mp_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. + +@d dep_list(A) mp_link(value_loc((A))) + /* half of the |value| field in a |dependent| variable */ +@d prev_dep(A) mp_info(value_loc((A))) + /* the other half; makes a doubly linked list */ +@d dep_node_size 2 /* the number of words per dependency node */ + +@<Initialize table entries...@>= mp->serial_no=0; +mp_link(dep_head)=dep_head; prev_dep(dep_head)=dep_head; +mp_info(dep_head)=null; dep_list(dep_head)=null; + +@ Actually the description above contains a little white lie. There's +another kind of variable called |mp_proto_dependent|, which is +just like a |dependent| one except that the $\alpha$ coefficients +in its dependency list are |scaled| instead of being fractions. +Proto-dependency lists are mixed with dependency lists in the +nodes reachable from |dep_head|. + +@ Here is a procedure that prints a dependency list in symbolic form. +The second parameter should be either |dependent| or |mp_proto_dependent|, +to indicate the scaling of the coefficients. + +@<Declarations@>= +static void mp_print_dependency (MP mp,pointer p, quarterword t); + +@ @c +void mp_print_dependency (MP mp,pointer p, quarterword t) { + integer v; /* a coefficient */ + pointer pp,q; /* for list manipulation */ + pp=p; + while (true) { + v=abs(value(p)); q=mp_info(p); + if ( q==null ) { /* the constant term */ + if ( (v!=0)||(p==pp) ) { + if ( value(p)>0 ) if ( p!=pp ) mp_print_char(mp, xord('+')); + mp_print_scaled(mp, value(p)); + } + return; + } + @<Print the coefficient, unless it's $\pm1.0$@>; + if ( mp_type(q)!=mp_independent ) mp_confusion(mp, "dep"); +@:this can't happen dep}{\quad dep@> + mp_print_variable_name(mp, q); v=value(q) % s_scale; + while ( v>0 ) { mp_print(mp, "*4"); v=v-2; } + p=mp_link(p); + } +} + +@ @<Print the coefficient, unless it's $\pm1.0$@>= +if ( value(p)<0 ) mp_print_char(mp, xord('-')); +else if ( p!=pp ) mp_print_char(mp, xord('+')); +if ( t==mp_dependent ) v=mp_round_fraction(mp, v); +if ( v!=unity ) mp_print_scaled(mp, v) + +@ The maximum absolute value of a coefficient in a given dependency list +is returned by the following simple function. + +@c +static fraction mp_max_coef (MP mp,pointer p) { + fraction x; /* the maximum so far */ + x=0; + while ( mp_info(p)!=null ) { + if ( abs(value(p))>x ) x=abs(value(p)); + p=mp_link(p); + } + return x; +} + +@ One of the main operations needed on dependency lists is to add a multiple +of one list to the other; we call this |p_plus_fq|, where |p| and~|q| point +to dependency lists and |f| is a fraction. + +If the coefficient of any independent variable becomes |coef_bound| or +more, in absolute value, this procedure changes the type of that variable +to `|independent_needing_fix|', and sets the global variable |fix_needed| +to~|true|. The value of $|coef_bound|=\mu$ is chosen so that +$\mu^2+\mu<8$; this means that the numbers we deal with won't +get too large. (Instead of the ``optimum'' $\mu=(\sqrt{33}-1)/2\approx +2.3723$, the safer value 7/3 is taken as the threshold.) + +The changes mentioned in the preceding paragraph are actually done only if +the global variable |watch_coefs| is |true|. But it usually is; in fact, +it is |false| only when \MP\ is making a dependency list that will soon +be equated to zero. + +Several procedures that act on dependency lists, including |p_plus_fq|, +set the global variable |dep_final| to the final (constant term) node of +the dependency list that they produce. + +@d coef_bound 04525252525 /* |fraction| approximation to 7/3 */ +@d independent_needing_fix 0 + +@<Glob...@>= +boolean fix_needed; /* does at least one |independent| variable need scaling? */ +boolean watch_coefs; /* should we scale coefficients that exceed |coef_bound|? */ +pointer dep_final; /* location of the constant term and final link */ + +@ @<Set init...@>= +mp->fix_needed=false; mp->watch_coefs=true; + +@ The |p_plus_fq| procedure has a fourth parameter, |t|, that should be +set to |mp_proto_dependent| if |p| is a proto-dependency list. In this +case |f| will be |scaled|, not a |fraction|. Similarly, the fifth parameter~|tt| +should be |mp_proto_dependent| if |q| is a proto-dependency list. + +List |q| is unchanged by the operation; but list |p| is totally destroyed. + +The final link of the dependency list or proto-dependency list returned +by |p_plus_fq| is the same as the original final link of~|p|. Indeed, the +constant term of the result will be located in the same |mem| location +as the original constant term of~|p|. + +Coefficients of the result are assumed to be zero if they are less than +a certain threshold. This compensates for inevitable rounding errors, +and tends to make more variables `|known|'. The threshold is approximately +$10^{-5}$ in the case of normal dependency lists, $10^{-4}$ for +proto-dependencies. + +@d fraction_threshold 2685 /* a |fraction| coefficient less than this is zeroed */ +@d half_fraction_threshold 1342 /* half of |fraction_threshold| */ +@d scaled_threshold 8 /* a |scaled| coefficient less than this is zeroed */ +@d half_scaled_threshold 4 /* half of |scaled_threshold| */ + +@<Declarations@>= +static pointer mp_p_plus_fq ( MP mp, pointer p, integer f, + pointer q, quarterword t, quarterword tt) ; + +@ @c +pointer mp_p_plus_fq ( MP mp, pointer p, integer f, + pointer q, quarterword t, quarterword tt) { + pointer pp,qq; /* |mp_info(p)| and |mp_info(q)|, respectively */ + pointer r,s; /* for list manipulation */ + integer threshold; /* defines a neighborhood of zero */ + integer v; /* temporary register */ + if ( t==mp_dependent ) threshold=fraction_threshold; + else threshold=scaled_threshold; + r=temp_head; pp=mp_info(p); qq=mp_info(q); + while (1) { + if ( pp==qq ) { + if ( pp==null ) { + break; + } else { + @<Contribute a term from |p|, plus |f| times the + corresponding term from |q|@> + } + } else if ( value(pp)<value(qq) ) { + @<Contribute a term from |q|, multiplied by~|f|@> + } else { + mp_link(r)=p; r=p; p=mp_link(p); pp=mp_info(p); + } + } + if ( t==mp_dependent ) + value(p)=mp_slow_add(mp, value(p),mp_take_fraction(mp, value(q),f)); + else + value(p)=mp_slow_add(mp, value(p),mp_take_scaled(mp, value(q),f)); + mp_link(r)=p; mp->dep_final=p; + return mp_link(temp_head); +} + +@ @<Contribute a term from |p|, plus |f|...@>= +{ + if ( tt==mp_dependent ) v=value(p)+mp_take_fraction(mp, f,value(q)); + else v=value(p)+mp_take_scaled(mp, f,value(q)); + value(p)=v; s=p; p=mp_link(p); + if ( abs(v)<threshold ) { + mp_free_node(mp, s,dep_node_size); + } else { + if ( (abs(v)>=coef_bound) && mp->watch_coefs ) { + mp_type(qq)=independent_needing_fix; mp->fix_needed=true; + } + mp_link(r)=s; r=s; + }; + pp=mp_info(p); q=mp_link(q); qq=mp_info(q); +} + +@ @<Contribute a term from |q|, multiplied by~|f|@>= +{ + if ( tt==mp_dependent ) v=mp_take_fraction(mp, f,value(q)); + else v=mp_take_scaled(mp, f,value(q)); + if ( abs(v)>halfp(threshold) ) { + s=mp_get_node(mp, dep_node_size); mp_info(s)=qq; value(s)=v; + if ( (abs(v)>=coef_bound) && mp->watch_coefs ) { + mp_type(qq)=independent_needing_fix; mp->fix_needed=true; + } + mp_link(r)=s; r=s; + } + q=mp_link(q); qq=mp_info(q); +} + +@ It is convenient to have another subroutine for the special case +of |p_plus_fq| when |f=1.0|. In this routine lists |p| and |q| are +both of the same type~|t| (either |dependent| or |mp_proto_dependent|). + +@c +static pointer mp_p_plus_q (MP mp,pointer p, pointer q, quarterword t) { + pointer pp,qq; /* |mp_info(p)| and |mp_info(q)|, respectively */ + pointer r,s; /* for list manipulation */ + integer threshold; /* defines a neighborhood of zero */ + integer v; /* temporary register */ + if ( t==mp_dependent ) threshold=fraction_threshold; + else threshold=scaled_threshold; + r=temp_head; pp=mp_info(p); qq=mp_info(q); + while (1) { + if ( pp==qq ) { + if ( pp==null ) { + break; + } else { + @<Contribute a term from |p|, plus the + corresponding term from |q|@> + } + } else { + if ( value(pp)<value(qq) ) { + s=mp_get_node(mp, dep_node_size); mp_info(s)=qq; value(s)=value(q); + q=mp_link(q); qq=mp_info(q); mp_link(r)=s; r=s; + } else { + mp_link(r)=p; r=p; p=mp_link(p); pp=mp_info(p); + } + } + } + value(p)=mp_slow_add(mp, value(p),value(q)); + mp_link(r)=p; mp->dep_final=p; + return mp_link(temp_head); +} + +@ @<Contribute a term from |p|, plus the...@>= +{ + v=value(p)+value(q); + value(p)=v; s=p; p=mp_link(p); pp=mp_info(p); + if ( abs(v)<threshold ) { + mp_free_node(mp, s,dep_node_size); + } else { + if ( (abs(v)>=coef_bound ) && mp->watch_coefs ) { + mp_type(qq)=independent_needing_fix; mp->fix_needed=true; + } + mp_link(r)=s; r=s; + } + q=mp_link(q); qq=mp_info(q); +} + +@ A somewhat simpler routine will multiply a dependency list +by a given constant~|v|. The constant is either a |fraction| less than +|fraction_one|, or it is |scaled|. In the latter case we might be forced to +convert a dependency list to a proto-dependency list. +Parameters |t0| and |t1| are the list types before and after; +they should agree unless |t0=mp_dependent| and |t1=mp_proto_dependent| +and |v_is_scaled=true|. + +@c +static pointer mp_p_times_v (MP mp,pointer p, integer v, quarterword t0, + quarterword t1, boolean v_is_scaled) { + pointer r,s; /* for list manipulation */ + integer w; /* tentative coefficient */ + integer threshold; + boolean scaling_down; + if ( t0!=t1 ) scaling_down=true; else scaling_down=(!v_is_scaled); + if ( t1==mp_dependent ) threshold=half_fraction_threshold; + else threshold=half_scaled_threshold; + r=temp_head; + while ( mp_info(p)!=null ) { + if ( scaling_down ) w=mp_take_fraction(mp, v,value(p)); + else w=mp_take_scaled(mp, v,value(p)); + if ( abs(w)<=threshold ) { + s=mp_link(p); mp_free_node(mp, p,dep_node_size); p=s; + } else { + if ( abs(w)>=coef_bound ) { + mp->fix_needed=true; mp_type(mp_info(p))=independent_needing_fix; + } + mp_link(r)=p; r=p; value(p)=w; p=mp_link(p); + } + } + mp_link(r)=p; + if ( v_is_scaled ) value(p)=mp_take_scaled(mp, value(p),v); + else value(p)=mp_take_fraction(mp, value(p),v); + return mp_link(temp_head); +} + +@ Similarly, we sometimes need to divide a dependency list +by a given |scaled| constant. + +@<Declarations@>= +static pointer mp_p_over_v (MP mp,pointer p, scaled v, quarterword + t0, quarterword t1) ; + +@ @c +pointer mp_p_over_v (MP mp,pointer p, scaled v, quarterword + t0, quarterword t1) { + pointer r,s; /* for list manipulation */ + integer w; /* tentative coefficient */ + integer threshold; + boolean scaling_down; + if ( t0!=t1 ) scaling_down=true; else scaling_down=false; + if ( t1==mp_dependent ) threshold=half_fraction_threshold; + else threshold=half_scaled_threshold; + r=temp_head; + while ( mp_info( p)!=null ) { + if ( scaling_down ) { + if ( abs(v)<02000000 ) w=mp_make_scaled(mp, value(p),v*010000); + else w=mp_make_scaled(mp, mp_round_fraction(mp, value(p)),v); + } else { + w=mp_make_scaled(mp, value(p),v); + } + if ( abs(w)<=threshold ) { + s=mp_link(p); mp_free_node(mp, p,dep_node_size); p=s; + } else { + if ( abs(w)>=coef_bound ) { + mp->fix_needed=true; mp_type(mp_info(p))=independent_needing_fix; + } + mp_link(r)=p; r=p; value(p)=w; p=mp_link(p); + } + } + mp_link(r)=p; value(p)=mp_make_scaled(mp, value(p),v); + return mp_link(temp_head); +} + +@ Here's another utility routine for dependency lists. When an independent +variable becomes dependent, we want to remove it from all existing +dependencies. The |p_with_x_becoming_q| function computes the +dependency list of~|p| after variable~|x| has been replaced by~|q|. + +This procedure has basically the same calling conventions as |p_plus_fq|: +List~|q| is unchanged; list~|p| is destroyed; the constant node and the +final link are inherited from~|p|; and the fourth parameter tells whether +or not |p| is |mp_proto_dependent|. However, the global variable |dep_final| +is not altered if |x| does not occur in list~|p|. + +@c +static pointer mp_p_with_x_becoming_q (MP mp,pointer p, + pointer x, pointer q, quarterword t) { + pointer r,s; /* for list manipulation */ + integer v; /* coefficient of |x| */ + integer sx; /* serial number of |x| */ + s=p; r=temp_head; sx=value(x); + while ( value(mp_info(s))>sx ) { r=s; s=mp_link(s); }; + if ( mp_info(s)!=x ) { + return p; + } else { + mp_link(temp_head)=p; mp_link(r)=mp_link(s); v=value(s); + mp_free_node(mp, s,dep_node_size); + return mp_p_plus_fq(mp, mp_link(temp_head),v,q,t,mp_dependent); + } +} + +@ Here's a simple procedure that reports an error when a variable +has just received a known value that's out of the required range. + +@<Declarations@>= +static void mp_val_too_big (MP mp,scaled x) ; + +@ @c void mp_val_too_big (MP mp,scaled x) { + if ( mp->internal[mp_warning_check]>0 ) { + print_err("Value is too large ("); mp_print_scaled(mp, x); mp_print_char(mp, xord(')')); +@.Value is too large@> + help4("The equation I just processed has given some variable", + "a value of 4096 or more. Continue and I'll try to cope", + "with that big value; but it might be dangerous.", + "(Set warningcheck:=0 to suppress this message.)"); + mp_error(mp); + } +} + +@ When a dependent variable becomes known, the following routine +removes its dependency list. Here |p| points to the variable, and +|q| points to the dependency list (which is one node long). + +@<Declarations@>= +static void mp_make_known (MP mp,pointer p, pointer q) ; + +@ @c void mp_make_known (MP mp,pointer p, pointer q) { + int t; /* the previous type */ + prev_dep(mp_link(q))=prev_dep(p); + mp_link(prev_dep(p))=mp_link(q); t=mp_type(p); + mp_type(p)=mp_known; value(p)=value(q); mp_free_node(mp, q,dep_node_size); + if ( abs(value(p))>=fraction_one ) mp_val_too_big(mp, value(p)); + if (( mp->internal[mp_tracing_equations]>0) && mp_interesting(mp, p) ) { + mp_begin_diagnostic(mp); mp_print_nl(mp, "#### "); +@:]]]\#\#\#\#_}{\.{\#\#\#\#}@> + mp_print_variable_name(mp, p); + mp_print_char(mp, xord('=')); mp_print_scaled(mp, value(p)); + mp_end_diagnostic(mp, false); + } + if (( mp->cur_exp==p ) && mp->cur_type==t ) { + mp->cur_type=mp_known; mp->cur_exp=value(p); + mp_free_node(mp, p,value_node_size); + } +} + +@ The |fix_dependencies| routine is called into action when |fix_needed| +has been triggered. The program keeps a list~|s| of independent variables +whose coefficients must be divided by~4. + +In unusual cases, this fixup process might reduce one or more coefficients +to zero, so that a variable will become known more or less by default. + +@<Declarations@>= +static void mp_fix_dependencies (MP mp); + +@ @c +static void mp_fix_dependencies (MP mp) { + pointer p,q,r,s,t; /* list manipulation registers */ + pointer x; /* an independent variable */ + r=mp_link(dep_head); s=null; + while ( r!=dep_head ){ + t=r; + @<Run through the dependency list for variable |t|, fixing + all nodes, and ending with final link~|q|@>; + r=mp_link(q); + if ( q==dep_list(t) ) mp_make_known(mp, t,q); + } + while ( s!=null ) { + p=mp_link(s); x=mp_info(s); free_avail(s); s=p; + mp_type(x)=mp_independent; value(x)=value(x)+2; + } + mp->fix_needed=false; +} + +@ @d independent_being_fixed 1 /* this variable already appears in |s| */ + +@<Run through the dependency list for variable |t|...@>= +r=value_loc(t); /* |mp_link(r)=dep_list(t)| */ +while (1) { + q=mp_link(r); x=mp_info(q); + if ( x==null ) break; + if ( mp_type(x)<=independent_being_fixed ) { + if ( mp_type(x)<independent_being_fixed ) { + p=mp_get_avail(mp); mp_link(p)=s; s=p; + mp_info(s)=x; mp_type(x)=independent_being_fixed; + } + value(q)=value(q) / 4; + if ( value(q)==0 ) { + mp_link(r)=mp_link(q); mp_free_node(mp, q,dep_node_size); q=r; + } + } + r=q; +} + + +@ The |new_dep| routine installs a dependency list~|p| into the value node~|q|, +linking it into the list of all known dependencies. We assume that +|dep_final| points to the final node of list~|p|. + +@c +static void mp_new_dep (MP mp,pointer q, pointer p) { + pointer r; /* what used to be the first dependency */ + dep_list(q)=p; prev_dep(q)=dep_head; + r=mp_link(dep_head); mp_link(mp->dep_final)=r; prev_dep(r)=mp->dep_final; + mp_link(dep_head)=q; +} + +@ Here is one of the ways a dependency list gets started. +The |const_dependency| routine produces a list that has nothing but +a constant term. + +@c static pointer mp_const_dependency (MP mp, scaled v) { + mp->dep_final=mp_get_node(mp, dep_node_size); + value(mp->dep_final)=v; mp_info(mp->dep_final)=null; + return mp->dep_final; +} + +@ And here's a more interesting way to start a dependency list from scratch: +The parameter to |single_dependency| is the location of an +independent variable~|x|, and the result is the simple dependency list +`|x+0|'. + +In the unlikely event that the given independent variable has been doubled so +often that we can't refer to it with a nonzero coefficient, +|single_dependency| returns the simple list `0'. This case can be +recognized by testing that the returned list pointer is equal to +|dep_final|. + +@c +static pointer mp_single_dependency (MP mp,pointer p) { + pointer q; /* the new dependency list */ + integer m; /* the number of doublings */ + m=value(p) % s_scale; + if ( m>28 ) { + return mp_const_dependency(mp, 0); + } else { + q=mp_get_node(mp, dep_node_size); + value(q)=(integer)two_to_the(28-m); mp_info(q)=p; + mp_link(q)=mp_const_dependency(mp, 0); + return q; + } +} + +@ We sometimes need to make an exact copy of a dependency list. + +@c +static pointer mp_copy_dep_list (MP mp,pointer p) { + pointer q; /* the new dependency list */ + q=mp_get_node(mp, dep_node_size); mp->dep_final=q; + while (1) { + mp_info(mp->dep_final)=mp_info(p); value(mp->dep_final)=value(p); + if ( mp_info(mp->dep_final)==null ) break; + mp_link(mp->dep_final)=mp_get_node(mp, dep_node_size); + mp->dep_final=mp_link(mp->dep_final); p=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 void mp_linear_eq (MP mp, pointer p, quarterword t) { + pointer q,r,s; /* for link manipulation */ + pointer x; /* the variable that loses its independence */ + integer n; /* the number of times |x| had been halved */ + integer v; /* the coefficient of |x| in list |p| */ + pointer prev_r; /* lags one step behind |r| */ + pointer final_node; /* the constant term of the new dependency list */ + integer w; /* a tentative coefficient */ + @<Find a node |q| in list |p| whose coefficient |v| is largest@>; + x=mp_info(q); n=value(x) % s_scale; + @<Divide list |p| by |-v|, removing node |q|@>; + if ( mp->internal[mp_tracing_equations]>0 ) { + @<Display the new dependency@>; + } + @<Simplify all existing dependencies by substituting for |x|@>; + @<Change variable |x| from |independent| to |dependent| or |known|@>; + if ( mp->fix_needed ) mp_fix_dependencies(mp); +} + +@ @<Find a node |q| in list |p| whose coefficient |v| is largest@>= +q=p; r=mp_link(p); v=value(q); +while ( mp_info(r)!=null ) { + if ( abs(value(r))>abs(v) ) { q=r; v=value(r); }; + r=mp_link(r); +} + +@ Here we want to change the coefficients from |scaled| to |fraction|, +except in the constant term. In the common case of a trivial equation +like `\.{x=3.14}', we will have |v=-fraction_one|, |q=p|, and |t=mp_dependent|. + +@<Divide list |p| by |-v|, removing node |q|@>= +s=temp_head; mp_link(s)=p; r=p; +do { + if ( r==q ) { + mp_link(s)=mp_link(r); mp_free_node(mp, r,dep_node_size); + } else { + w=mp_make_fraction(mp, value(r),v); + if ( abs(w)<=half_fraction_threshold ) { + mp_link(s)=mp_link(r); mp_free_node(mp, r,dep_node_size); + } else { + value(r)=-w; s=r; + } + } + r=mp_link(s); +} while (mp_info(r)!=null); +if ( t==mp_proto_dependent ) { + value(r)=-mp_make_scaled(mp, value(r),v); +} else if ( v!=-fraction_one ) { + value(r)=-mp_make_fraction(mp, value(r),v); +} +final_node=r; p=mp_link(temp_head) + +@ @<Display the new dependency@>= +if ( mp_interesting(mp, x) ) { + mp_begin_diagnostic(mp); mp_print_nl(mp, "## "); + mp_print_variable_name(mp, x); +@:]]]\#\#_}{\.{\#\#}@> + w=n; + while ( w>0 ) { mp_print(mp, "*4"); w=w-2; }; + mp_print_char(mp, xord('=')); mp_print_dependency(mp, p,mp_dependent); + mp_end_diagnostic(mp, false); +} + +@ @<Simplify all existing dependencies by substituting for |x|@>= +prev_r=dep_head; r=mp_link(dep_head); +while ( r!=dep_head ) { + s=dep_list(r); q=mp_p_with_x_becoming_q(mp, s,x,p,mp_type(r)); + if ( mp_info(q)==null ) { + mp_make_known(mp, r,q); + } else { + dep_list(r)=q; + do { q=mp_link(q); } while (mp_info(q)!=null); + prev_r=q; + } + r=mp_link(prev_r); +} + +@ @<Change variable |x| from |independent| to |dependent| or |known|@>= +if ( n>0 ) @<Divide list |p| by $2^n$@>; +if ( mp_info(p)==null ) { + mp_type(x)=mp_known; + value(x)=value(p); + if ( abs(value(x))>=fraction_one ) mp_val_too_big(mp, value(x)); + mp_free_node(mp, p,dep_node_size); + if ( mp->cur_exp==x ) if ( mp->cur_type==mp_independent ) { + mp->cur_exp=value(x); mp->cur_type=mp_known; + mp_free_node(mp, x,value_node_size); + } +} else { + mp_type(x)=mp_dependent; mp->dep_final=final_node; mp_new_dep(mp, x,p); + if ( mp->cur_exp==x ) if ( mp->cur_type==mp_independent ) mp->cur_type=mp_dependent; +} + +@ @<Divide list |p| by $2^n$@>= +{ + s=temp_head; mp_link(temp_head)=p; r=p; + do { + if ( n>30 ) w=0; + else w=value(r) / two_to_the(n); + if ( (abs(w)<=half_fraction_threshold)&&(mp_info(r)!=null) ) { + mp_link(s)=mp_link(r); + mp_free_node(mp, r,dep_node_size); + } else { + value(r)=w; s=r; + } + r=mp_link(s); + } while (mp_info(s)!=null); + p=mp_link(temp_head); +} + +@ The |check_mem| procedure, which is used only when \MP\ is being +debugged, makes sure that the current dependency lists are well formed. + +@<Check the list of linear dependencies@>= +q=dep_head; p=mp_link(q); +while ( p!=dep_head ) { + if ( prev_dep(p)!=q ) { + mp_print_nl(mp, "Bad PREVDEP at "); mp_print_int(mp, p); +@.Bad PREVDEP...@> + } + p=dep_list(p); + while (1) { + r=mp_info(p); q=p; p=mp_link(q); + if ( r==null ) break; + if ( value(mp_info(p))>=value(r) ) { + mp_print_nl(mp, "Out of order at "); mp_print_int(mp, p); +@.Out of order...@> + } + } +} + +@* \[25] Dynamic nonlinear equations. +Variables of numeric type are maintained by the general scheme of +independent, dependent, and known values that we have just studied; +and the components of pair and transform variables are handled in the +same way. But \MP\ also has five other types of values: \&{boolean}, +\&{string}, \&{pen}, \&{path}, and \&{picture}; what about them? + +Equations are allowed between nonlinear quantities, but only in a +simple form. Two variables that haven't yet been assigned values are +either equal to each other, or they're not. + +Before a boolean variable has received a value, its type is |mp_unknown_boolean|; +similarly, there are variables whose type is |mp_unknown_string|, |mp_unknown_pen|, +|mp_unknown_path|, and |mp_unknown_picture|. In such cases the value is either +|null| (which means that no other variables are equivalent to this one), or +it points to another variable of the same undefined type. The pointers in the +latter case form a cycle of nodes, which we shall call a ``ring.'' +Rings of undefined variables may include capsules, which arise as +intermediate results within expressions or as \&{expr} parameters to macros. + +When one member of a ring receives a value, the same value is given to +all the other members. In the case of paths and pictures, this implies +making separate copies of a potentially large data structure; users should +restrain their enthusiasm for such generality, unless they have lots and +lots of memory space. + +@ The following procedure is called when a capsule node is being +added to a ring (e.g., when an unknown variable is mentioned in an expression). + +@c +static pointer mp_new_ring_entry (MP mp,pointer p) { + pointer q; /* the new capsule node */ + q=mp_get_node(mp, value_node_size); mp_name_type(q)=mp_capsule; + mp_type(q)=mp_type(p); + if ( value(p)==null ) value(q)=p; else value(q)=value(p); + value(p)=q; + return q; +} + +@ Conversely, we might delete a capsule or a variable before it becomes known. +The following procedure simply detaches a quantity from its ring, +without recycling the storage. + +@<Declarations@>= +static void mp_ring_delete (MP mp,pointer p); + +@ @c +void mp_ring_delete (MP mp,pointer p) { + pointer q; + q=value(p); + if ( q!=null ) if ( q!=p ){ + while ( value(q)!=p ) q=value(q); + value(q)=value(p); + } +} + +@ Eventually there might be an equation that assigns values to all of the +variables in a ring. The |nonlinear_eq| subroutine does the necessary +propagation of values. + +If the parameter |flush_p| is |true|, node |p| itself needn't receive a +value, it will soon be recycled. + +@c +static void mp_nonlinear_eq (MP mp,integer v, pointer p, boolean flush_p) { + quarterword t; /* the type of ring |p| */ + pointer q,r; /* link manipulation registers */ + t=mp_type(p)-unknown_tag; q=value(p); + if ( flush_p ) mp_type(p)=mp_vacuous; else p=q; + do { + r=value(q); mp_type(q)=t; + switch (t) { + case mp_boolean_type: value(q)=v; break; + case mp_string_type: value(q)=v; add_str_ref(v); break; + case mp_pen_type: value(q)=copy_pen(v); break; + case mp_path_type: value(q)=mp_copy_path(mp, v); break; + case mp_picture_type: value(q)=v; add_edge_ref(v); break; + } /* there ain't no more cases */ + q=r; + } while (q!=p); +} + +@ If two members of rings are equated, and if they have the same type, +the |ring_merge| procedure is called on to make them equivalent. + +@c +static void mp_ring_merge (MP mp,pointer p, pointer q) { + pointer r; /* traverses one list */ + r=value(p); + while ( r!=p ) { + if ( r==q ) { + @<Exclaim about a redundant equation@>; + return; + }; + r=value(r); + } + r=value(p); value(p)=value(q); value(q)=r; +} + +@ @<Exclaim about a redundant equation@>= +{ + print_err("Redundant equation"); +@.Redundant equation@> + help2("I already knew that this equation was true.", + "But perhaps no harm has been done; let's continue."); + mp_put_get_error(mp); +} + +@* \[26] Introduction to the syntactic routines. +Let's pause a moment now and try to look at the Big Picture. +The \MP\ program consists of three main parts: syntactic routines, +semantic routines, and output routines. The chief purpose of the +syntactic routines is to deliver the user's input to the semantic routines, +while parsing expressions and locating operators and operands. The +semantic routines act as an interpreter responding to these operators, +which may be regarded as commands. And the output routines are +periodically called on to produce compact font descriptions that can be +used for typesetting or for making interim proof drawings. We have +discussed the basic data structures and many of the details of semantic +operations, so we are good and ready to plunge into the part of \MP\ that +actually controls the activities. + +Our current goal is to come to grips with the |get_next| procedure, +which is the keystone of \MP's input mechanism. Each call of |get_next| +sets the value of three variables |cur_cmd|, |cur_mod|, and |cur_sym|, +representing the next input token. +$$\vbox{\halign{#\hfil\cr + \hbox{|cur_cmd| denotes a command code from the long list of codes + given earlier;}\cr + \hbox{|cur_mod| denotes a modifier of the command code;}\cr + \hbox{|cur_sym| is the hash address of the symbolic token that was + just scanned,}\cr + \hbox{\qquad or zero in the case of a numeric or string + or capsule token.}\cr}}$$ +Underlying this external behavior of |get_next| is all the machinery +necessary to convert from character files to tokens. At a given time we +may be only partially finished with the reading of several files (for +which \&{input} was specified), and partially finished with the expansion +of some user-defined macros and/or some macro parameters, and partially +finished reading some text that the user has inserted online, +and so on. When reading a character file, the characters must be +converted to tokens; comments and blank spaces must +be removed, numeric and string tokens must be evaluated. + +To handle these situations, which might all be present simultaneously, +\MP\ uses various stacks that hold information about the incomplete +activities, and there is a finite state control for each level of the +input mechanism. These stacks record the current state of an implicitly +recursive process, but the |get_next| procedure is not recursive. + +@<Glob...@>= +integer cur_cmd; /* current command set by |get_next| */ +integer cur_mod; /* operand of current command */ +halfword cur_sym; /* hash address of current symbol */ + +@ The |print_cmd_mod| routine prints a symbolic interpretation of a +command code and its modifier. +It consists of a rather tedious sequence of print +commands, and most of it is essentially an inverse to the |primitive| +routine that enters a \MP\ primitive into |hash| and |eqtb|. Therefore almost +all of this procedure appears elsewhere in the program, together with the +corresponding |primitive| calls. + +@<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, mp->cur_cmd,mp->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); +} + +@* \[27] Input stacks and states. +The state of \MP's input mechanism appears in the input stack, whose +entries are records with five fields, called |index|, |start|, |loc|, +|limit|, and |name|. The top element of this stack is maintained in a +global variable for which no subscripting needs to be done; the other +elements of the stack appear in an array. Hence the stack is declared thus: + +@<Types...@>= +typedef struct { + quarterword index_field; + halfword start_field, loc_field, limit_field, name_field; +} in_state_record; + +@ @<Glob...@>= +in_state_record *input_stack; +integer input_ptr; /* first unused location of |input_stack| */ +integer max_in_stack; /* largest value of |input_ptr| when pushing */ +in_state_record cur_input; /* the ``top'' input state */ +int stack_size; /* maximum number of simultaneous input sources */ + +@ @<Allocate or initialize ...@>= +mp->stack_size = 300; +mp->input_stack = xmalloc((mp->stack_size+1),sizeof(in_state_record)); + +@ @<Dealloc variables@>= +xfree(mp->input_stack); + +@ We've already defined the special variable |loc==cur_input.loc_field| +in our discussion of basic input-output routines. The other components of +|cur_input| are defined in the same way: + +@d 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 0 /* |name| value when reading from the terminal for normal input */ +@d is_read 1 /* |name| value when executing a \&{readstring} or \&{readfrom} */ +@d is_scantok 2 /* |name| value when reading text generated by \&{scantokens} */ +@d max_spec_src is_scantok + +@ Additional information about the current line is available via the +|index| variable, which counts how many lines of characters are present +in the buffer below the current level. We have |index=0| when reading +from the terminal and prompting the user for each line; then if the user types, +e.g., `\.{input figs}', we will have |index=1| while reading +the file \.{figs.mp}. However, it does not follow that |index| is the +same as the input stack pointer, since many of the levels on the input +stack may come from token lists and some |index| values may correspond +to \.{MPX} files that are not currently on the stack. + +The global variable |in_open| is equal to the highest |index| value counting +\.{MPX} files but excluding token-list input levels. Thus, the number of +partially read lines in the buffer is |in_open+1| and we have |in_open>=index| +when we are not reading a token list. + +If we are not currently reading from the terminal, +we are reading from the file variable |input_file[index]|. We use +the notation |terminal_input| as a convenient abbreviation for |name=is_term|, +and |cur_file| as an abbreviation for |input_file[index]|. + +When \MP\ is not reading from the terminal, the global variable |line| contains +the line number in the current file, for use in error messages. More precisely, +|line| is a macro for |line_stack[index]| and the |line_stack| array gives +the line number for each file in the |input_file| array. + +When an \.{MPX} file is opened the file name is stored in the |mpx_name| +array so that the name doesn't get lost when the file is temporarily removed +from the input stack. +Thus when |input_file[k]| is an \.{MPX} file, its name is |mpx_name[k]| +and it contains translated \TeX\ pictures for |input_file[k-1]|. +Since this is not an \.{MPX} file, we have +$$ \hbox{|mpx_name[k-1]<=absent|}. $$ +This |name| field is set to |finished| when |input_file[k]| is completely +read. + +If more information about the input state is needed, it can be +included in small arrays like those shown here. For example, +the current page or segment number in the input file might be put +into a variable |page|, that is really a macro for the current entry +in `\ignorespaces|page_stack:array[0..max_in_open] of integer|\unskip' +by analogy with |line_stack|. +@^system dependencies@> + +@d terminal_input (name==is_term) /* are we reading from the terminal? */ +@d cur_file mp->input_file[iindex] /* the current |void *| variable */ +@d line mp->line_stack[iindex] /* current line number in the current source file */ +@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 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 * *iname_stack; /* used for naming \.{MPX} files */ +char * *iarea_stack; /* used for naming \.{MPX} files */ +halfword*mpx_name ; + +@ @<Allocate or ...@>= +mp->input_file = xmalloc((mp->max_in_open+1),sizeof(void *)); +mp->line_stack = xmalloc((mp->max_in_open+1),sizeof(integer)); +mp->iname_stack = xmalloc((mp->max_in_open+1),sizeof(char *)); +mp->iarea_stack = xmalloc((mp->max_in_open+1),sizeof(char *)); +mp->mpx_name = xmalloc((mp->max_in_open+1),sizeof(halfword)); +{ + int k; + for (k=0;k<=mp->max_in_open;k++) { + mp->iname_stack[k] =NULL; + mp->iarea_stack[k] =NULL; + } +} + +@ @<Dealloc variables@>= +{ + int l; + for (l=0;l<=mp->max_in_open;l++) { + xfree(mp->iname_stack[l]); + xfree(mp->iarea_stack[l]); + } +} +xfree(mp->input_file); +xfree(mp->line_stack); +xfree(mp->iname_stack); +xfree(mp->iarea_stack); +xfree(mp->mpx_name); + + +@ However, all this discussion about input state really applies only to the +case that we are inputting from a file. There is another important case, +namely when we are currently getting input from a token list. In this case +|iindex>max_in_open|, and the conventions about the other state variables +are different: + +\yskip\hang|loc| is a pointer to the current node in the token list, i.e., +the node that will be read next. If |loc=null|, the token list has been +fully read. + +\yskip\hang|start| points to the first node of the token list; this node +may or may not contain a reference count, depending on the type of token +list involved. + +\yskip\hang|token_type|, which takes the place of |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 token_type iindex /* type of current token list */ +@d token_state (iindex>(int)mp->max_in_open) /* are we scanning a token list? */ +@d file_state (iindex<=(int)mp->max_in_open) /* are we scanning a file line? */ +@d param_start limit /* base of macro parameters in |param_stack| */ +@d forever_text (mp->max_in_open+1) /* |token_type| code for loop texts */ +@d loop_text (mp->max_in_open+2) /* |token_type| code for loop texts */ +@d parameter (mp->max_in_open+3) /* |token_type| code for parameter texts */ +@d backed_up (mp->max_in_open+4) /* |token_type| code for texts to be reread */ +@d inserted (mp->max_in_open+5) /* |token_type| code for inserted texts */ +@d macro (mp->max_in_open+6) /* |token_type| code for macro replacement texts */ + +@ The |param_stack| is an auxiliary array used to hold pointers to the token +lists for parameters at the current level and subsidiary levels of input. +This stack grows at a different rate from the others. + +@<Glob...@>= +pointer *param_stack; /* token list pointers for parameters */ +integer param_ptr; /* first unused entry in |param_stack| */ +integer max_param_stack; /* largest value of |param_ptr| */ + +@ @<Allocate or initialize ...@>= +mp->param_stack = xmalloc((mp->param_size+1),sizeof(pointer)); + +@ @<Dealloc variables@>= +xfree(mp->param_stack); + +@ Notice that the |line| isn't valid when |token_state| is true because it +depends on |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>mp->max_in_open)|| + (mp->input_stack[(k-1)].name_field<=max_spec_src))) { + decr(k); + } + return (k>0 ? mp->line_stack[(k-1)] : 0 ); + } +} + +@ Thus, the ``current input state'' can be very complicated indeed; there +can be many levels and each level can arise in a variety of ways. The +|show_context| procedure, which is used by \MP's error-reporting routine to +print out the current input state on all levels down to the most recent +line of characters from an input file, illustrates most of these conventions. +The global variable |file_ptr| contains the lowest level that was +displayed by this procedure. + +@<Glob...@>= +integer file_ptr; /* shallowest level shown by |show_context| */ + +@ The status at each level is indicated by printing two lines, where the first +line indicates what was read so far and the second line shows what remains +to be read. The context is cropped, if necessary, so that the first line +contains at most |half_error_line| characters, and the second contains +at most |error_line|. Non-current input levels whose |token_type| is +`|backed_up|' are shown only if they have not been fully read. + +@c void mp_show_context (MP mp) { /* prints where the scanner is */ + 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) || (loc!=null) ) { + /* we omit backed-up token lists that have already been read */ + mp->tally=0; /* get ready to count characters */ + old_setting=mp->selector; + if ( file_state ) { + @<Print location of current line@>; + @<Pseudoprint the line@>; + } else { + @<Print type of token list@>; + @<Pseudoprint the token list@>; + } + mp->selector=old_setting; /* stop pseudoprinting */ + @<Print two lines using the tricky pseudoprinted information@>; +} + +@ This routine should be changed, if necessary, to give the best possible +indication of where the current line resides in the input file. +For example, on some systems it is best to print both a page and line number. +@^system dependencies@> + +@<Print location of current line@>= +if ( name>max_spec_src ) { + mp_print_nl(mp, "l."); mp_print_int(mp, mp_true_line(mp)); +} else if ( terminal_input ) { + if ( mp->file_ptr==0 ) mp_print_nl(mp, "<*>"); + else mp_print_nl(mp, "<insert>"); +} else if ( name==is_scantok ) { + mp_print_nl(mp, "<scantokens>"); +} else { + mp_print_nl(mp, "<read>"); +} +mp_print_char(mp, 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 ( loc==null ) mp_print_nl(mp, "<recently read> "); + else mp_print_nl(mp, "<to be read again> "); + } else if (token_type==inserted) { + mp_print_nl(mp, "<inserted text> "); + } else if (token_type==macro) { + mp_print_ln(mp); + if ( name!=null ) mp_print_text(name); + else @<Print the name of a \&{vardef}'d macro@>; + mp_print(mp, "->"); + } else { + mp_print_nl(mp, "?");/* this should never happen */ +@.?\relax@> + } +} + +@ The parameter that corresponds to a loop text is either a token list +(in the case of \&{forsuffixes}) or a ``capsule'' (in the case of \&{for}). +We'll discuss capsules later; for now, all we need to know is that +the |link| field in a capsule parameter is |void| and that +|print_exp(p,0)| displays the value of capsule~|p| in abbreviated form. + +@<Print the current loop value@>= +{ mp_print_nl(mp, "<for("); p=mp->param_stack[param_start]; + if ( p!=null ) { + if ( mp_link(p)==mp_void ) mp_print_exp(mp, p,0); /* we're in a \&{for} loop */ + else mp_show_token_list(mp, p,null,20,mp->tally); + } + mp_print(mp, ")> "); +} + +@ The first two parameters of a macro defined by \&{vardef} will be token +lists representing the macro's prefix and ``at point.'' By putting these +together, we get the macro's full name. + +@<Print the name of a \&{vardef}'d macro@>= +{ p=mp->param_stack[param_start]; + if ( p==null ) { + mp_show_token_list(mp, mp->param_stack[param_start+1],null,20,mp->tally); + } else { + q=p; + while ( mp_link(q)!=null ) q=mp_link(q); + mp_link(q)=mp->param_stack[param_start+1]; + mp_show_token_list(mp, p,null,20,mp->tally); + mp_link(q)=null; + } +} + +@ Now it is necessary to explain a little trick. We don't want to store a long +string that corresponds to a token list, because that string might take up +lots of memory; and we are printing during a time when an error message is +being given, so we dare not do anything that might overflow one of \MP's +tables. So `pseudoprinting' is the answer: We enter a mode of printing +that stores characters into a buffer of length |error_line|, where character +$k+1$ is placed into \hbox{|trick_buf[k mod error_line]|} if +|k<trick_count|, otherwise character |k| is dropped. Initially we set +|tally:=0| and |trick_count:=1000000|; then when we reach the +point where transition from line 1 to line 2 should occur, we +set |first_count:=tally| and |trick_count:=@tmax@>(error_line, +tally+1+error_line-half_error_line)|. At the end of the +pseudoprinting, the values of |first_count|, |tally|, and +|trick_count| give us all the information we need to print the two lines, +and all of the necessary text is in |trick_buf|. + +Namely, let |l| be the length of the descriptive information that appears +on the first line. The length of the context information gathered for that +line is |k=first_count|, and the length of the context information +gathered for line~2 is $m=\min(|tally|, |trick_count|)-k$. If |l+k<=h|, +where |h=half_error_line|, we print |trick_buf[0..k-1]| after the +descriptive information on line~1, and set |n:=l+k|; here |n| is the +length of line~1. If $l+k>h$, some cropping is necessary, so we set |n:=h| +and print `\.{...}' followed by +$$\hbox{|trick_buf[(l+k-h+3)..k-1]|,}$$ +where subscripts of |trick_buf| are circular modulo |error_line|. The +second line consists of |n|~spaces followed by |trick_buf[k..(k+m-1)]|, +unless |n+m>error_line|; in the latter case, further cropping is done. +This is easier to program than to explain. + +@<Local variables for formatting...@>= +int i; /* index into |buffer| */ +integer l; /* length of descriptive information on line 1 */ +integer m; /* context information gathered for line 2 */ +int n; /* length of line 1 */ +integer p; /* starting or ending place in |trick_buf| */ +integer q; /* temporary index */ + +@ The following code tells the print routines to gather +the desired information. + +@d begin_pseudoprint { + l=mp->tally; mp->tally=0; mp->selector=pseudo; + mp->trick_count=1000000; +} +@d set_trick_count { + mp->first_count=mp->tally; + mp->trick_count=mp->tally+1+mp->error_line-mp->half_error_line; + if ( mp->trick_count<mp->error_line ) mp->trick_count=mp->error_line; +} + +@ And the following code uses the information after it has been gathered. + +@<Print two lines using the tricky pseudoprinted information@>= +if ( mp->trick_count==1000000 ) set_trick_count; + /* |set_trick_count| must be performed */ +if ( mp->tally<mp->trick_count ) m=mp->tally-mp->first_count; +else m=mp->trick_count-mp->first_count; /* context on line 2 */ +if ( l+mp->first_count<=mp->half_error_line ) { + p=0; n=l+mp->first_count; +} else { + mp_print(mp, "..."); p=l+mp->first_count-mp->half_error_line+3; + n=mp->half_error_line; +} +for (q=p;q<=mp->first_count-1;q++) { + mp_print_char(mp, mp->trick_buf[q % mp->error_line]); +} +mp_print_ln(mp); +for (q=1;q<=n;q++) { + mp_print_char(mp, 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_str(mp, mp->buffer[i]); + } +} + +@ @<Pseudoprint the token list@>= +begin_pseudoprint; +if ( token_type!=macro ) mp_show_token_list(mp, start,loc,100000,0); +else mp_show_macro(mp, start,loc,100000) + +@ Here is the missing piece of |show_token_list| that is activated when the +token beginning line~2 is about to be shown: + +@<Do magic computation@>=set_trick_count + +@* \[28] Maintaining the input stacks. +The following subroutines change the input status in commonly needed ways. + +First comes |push_input|, which stores the current state and creates a +new level (having, initially, the same properties as the old). + +@d push_input { /* enter a new input level, save the old */ + if ( mp->input_ptr>mp->max_in_stack ) { + mp->max_in_stack=mp->input_ptr; + if ( mp->input_ptr==mp->stack_size ) { + int l = (mp->stack_size+(mp->stack_size/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),backed_up) /* backs up a simple token list */ + +@c +static void mp_begin_token_list (MP mp,pointer p, quarterword t) { + push_input; start=p; token_type=t; + param_start=mp->param_ptr; loc=p; +} + +@ When a token list has been fully scanned, the following computations +should be done as we leave that level of input. +@^inner loop@> + +@c +static void mp_end_token_list (MP mp) { /* leave a token-list input level */ + pointer p; /* temporary register */ + if ( token_type>=backed_up ) { /* token list to be deleted */ + if ( token_type<=inserted ) { + mp_flush_token_list(mp, start); goto DONE; + } else { + mp_delete_mac_ref(mp, start); /* update reference count */ + } + } + while ( mp->param_ptr>param_start ) { /* parameters must be flushed */ + decr(mp->param_ptr); + p=mp->param_stack[mp->param_ptr]; + if ( p!=null ) { + if ( mp_link(p)==mp_void ) { /* it's an \&{expr} parameter */ + mp_recycle_value(mp, p); mp_free_node(mp, p,value_node_size); + } else { + mp_flush_token_list(mp, p); /* it's a \&{suffix} or \&{text} parameter */ + } + } + } +DONE: + pop_input; check_interrupt; +} + +@ The contents of |cur_cmd,cur_mod,cur_sym| are placed into an equivalent +token by the |cur_tok| routine. +@^inner loop@> + +@c @<Declare the procedure called |make_exp_copy|@> +static pointer mp_cur_tok (MP mp) { + pointer p; /* a new token node */ + quarterword save_type; /* |cur_type| to be restored */ + integer save_exp; /* |cur_exp| to be restored */ + if ( mp->cur_sym==0 ) { + if ( mp->cur_cmd==capsule_token ) { + save_type=mp->cur_type; save_exp=mp->cur_exp; + mp_make_exp_copy(mp, mp->cur_mod); p=mp_stash_cur_exp(mp); mp_link(p)=null; + mp->cur_type=save_type; mp->cur_exp=save_exp; + } else { + p=mp_get_node(mp, token_node_size); + value(p)=mp->cur_mod; mp_name_type(p)=mp_token; + if ( mp->cur_cmd==numeric_token ) mp_type(p)=mp_known; + else mp_type(p)=mp_string_type; + } + } else { + fast_get_avail(p); mp_info(p)=mp->cur_sym; + } + return p; +} + +@ Sometimes \MP\ has read too far and wants to ``unscan'' what it has +seen. The |back_input| procedure takes care of this by putting the token +just scanned back into the input stream, ready to be read again. +If |cur_sym<>0|, the values of |cur_cmd| and |cur_mod| are irrelevant. + +@<Declarations@>= +static void mp_back_input (MP mp); + +@ @c void mp_back_input (MP mp) {/* undoes one token of input */ + pointer p; /* a token list of length one */ + p=mp_cur_tok(mp); + while ( token_state &&(loc==null) ) + mp_end_token_list(mp); /* conserve stack space */ + back_list(p); +} + +@ The |back_error| routine is used when we want to restore or replace an +offending token just before issuing an error message. We disable interrupts +during the call of |back_input| so that the help message won't be lost. + +@ @c static void mp_back_error (MP mp) { /* back up one token and call |error| */ + mp->OK_to_interrupt=false; + mp_back_input(mp); + mp->OK_to_interrupt=true; mp_error(mp); +} +static void mp_ins_error (MP mp) { /* back up one inserted token and call |error| */ + mp->OK_to_interrupt=false; + mp_back_input(mp); token_type=inserted; + mp->OK_to_interrupt=true; mp_error(mp); +} + +@ The |begin_file_reading| procedure starts a new level of input for lines +of characters to be read from a file, or as an insertion from the +terminal. It does not take care of opening the file, nor does it set |loc| +or |limit| or |line|. +@^system dependencies@> + +@c void mp_begin_file_reading (MP mp) { + if ( mp->in_open==mp->max_in_open ) + mp_overflow(mp, "text input levels",mp->max_in_open); +@:MetaPost capacity exceeded text input levels}{\quad text input levels@> + if ( mp->first==mp->buf_size ) + mp_reallocate_buffer(mp,(mp->buf_size+(mp->buf_size/4))); + incr(mp->in_open); push_input; iindex=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. + +@c static void mp_end_file_reading (MP mp) { + 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); + delete_str_ref(name); + xfree(in_name); + xfree(in_area); + } + pop_input; decr(mp->in_open); +} + +@ Here is a function that tries to resume input from an \.{MPX} file already +associated with the current input file. It returns |false| if this doesn't +work. + +@c 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"); +@:this can't happen mpx}{\quad mpx@> + if ( mp->first==mp->buf_size ) + mp_reallocate_buffer(mp,(mp->buf_size+(mp->buf_size/4))); + push_input; iindex=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@>; + 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@>; + } + mp->first=(size_t)start; + pop_input; +} + +@ Here we enforce a restriction that simplifies the input stacks considerably. +This should not inconvenience the user because \.{MPX} files are generated +by an auxiliary program called \.{DVItoMP}. + +@ @<Complain that we are not at the end of a line in the \.{MPX} file@>= +{ +print_err("`mpxbreak' must be at the end of a line"); +help4("This file contains picture expressions for btex...etex", + "blocks. Such files are normally generated automatically", + "but this one seems to be messed up. I'm going to ignore", + "the rest of this line."); +mp_error(mp); +} + +@ In order to keep the stack from overflowing during a long sequence of +inserted `\.{show}' commands, the following routine removes completed +error-inserted lines from memory. + +@c void mp_clear_for_error_prompt (MP mp) { + while ( file_state && terminal_input && + (mp->input_ptr>0)&&(loc==limit) ) mp_end_file_reading(mp); + mp_print_ln(mp); clear_terminal; +} + +@ To get \MP's whole input mechanism going, we perform the following +actions. + +@<Initialize the input routines@>= +{ mp->input_ptr=0; mp->max_in_stack=0; + mp->in_open=0; mp->open_parens=0; mp->max_buf_stack=0; + mp->param_ptr=0; mp->max_param_stack=0; + mp->first=1; + start=1; iindex=0; line=0; name=is_term; + mp->mpx_name[0]=absent; + mp->force_eof=false; + if ( ! mp_init_terminal(mp) ) mp_jump_out(mp); + limit=(halfword)mp->last; mp->first=mp->last+1; + /* |init_terminal| has set |loc| and |last| */ +} + +@* \[29] Getting the next token. +The heart of \MP's input mechanism is the |get_next| procedure, which +we shall develop in the next few sections of the program. Perhaps we +shouldn't actually call it the ``heart,'' however; it really acts as \MP's +eyes and mouth, reading the source files and gobbling them up. And it also +helps \MP\ to regurgitate stored token lists that are to be processed again. + +The main duty of |get_next| is to input one token and to set |cur_cmd| +and |cur_mod| to that token's command code and modifier. Furthermore, if +the input token is a symbolic token, that token's |hash| address +is stored in |cur_sym|; otherwise |cur_sym| is set to zero. + +Underlying this simple description is a certain amount of complexity +because of all the cases that need to be handled. +However, the inner loop of |get_next| is reasonably short and fast. + +@ Before getting into |get_next|, we need to consider a mechanism by which +\MP\ helps keep errors from propagating too far. Whenever the program goes +into a mode where it keeps calling |get_next| repeatedly until a certain +condition is met, it sets |scanner_status| to some value other than |normal|. +Then if an input file ends, or if an `\&{outer}' symbol appears, +an appropriate error recovery will be possible. + +The global variable |warning_info| helps in this error recovery by providing +additional information. For example, |warning_info| might indicate the +name of a macro whose replacement text is being scanned. + +@d normal 0 /* |scanner_status| at ``quiet times'' */ +@d skipping 1 /* |scanner_status| when false conditional text is being skipped */ +@d flushing 2 /* |scanner_status| when junk after a statement is being ignored */ +@d absorbing 3 /* |scanner_status| when a \&{text} parameter is being scanned */ +@d var_defining 4 /* |scanner_status| when a \&{vardef} is being scanned */ +@d op_defining 5 /* |scanner_status| when a macro \&{def} is being scanned */ +@d loop_defining 6 /* |scanner_status| when a \&{for} loop is being scanned */ +@d tex_flushing 7 /* |scanner_status| when skipping \TeX\ material */ + +@<Glob...@>= +integer scanner_status; /* are we scanning at high speed? */ +integer warning_info; /* if so, what else do we need to know, + in case an error occurs? */ + +@ @<Initialize the input routines@>= +mp->scanner_status=normal; + +@ The following subroutine +is called when an `\&{outer}' symbolic token has been scanned or +when the end of a file has been reached. These two cases are distinguished +by |cur_sym|, which is zero at the end of a file. + +@c +static boolean mp_check_outer_validity (MP mp) { + pointer p; /* points to inserted token list */ + if ( mp->scanner_status==normal ) { + return true; + } else if ( mp->scanner_status==tex_flushing ) { + @<Check if the file has ended while flushing \TeX\ material and set the + result value for |check_outer_validity|@>; + } else { + mp->deletions_allowed=false; + @<Back up an outer symbolic token so that it can be reread@>; + if ( mp->scanner_status>skipping ) { + @<Tell the user what has run away and try to recover@>; + } else { + print_err("Incomplete if; all text was ignored after line "); +@.Incomplete if...@> + mp_print_int(mp, mp->warning_info); + help3("A forbidden `outer' token occurred in skipped text.", + "This kind of error happens when you say `if...' and forget", + "the matching `fi'. I've inserted a `fi'; this might work."); + if ( mp->cur_sym==0 ) + mp->help_line[2]="The file ended while I was skipping conditional text."; + mp->cur_sym=frozen_fi; mp_ins_error(mp); + } + mp->deletions_allowed=true; + return false; + } +} + +@ @<Check if the file has ended while flushing \TeX\ material and set...@>= +if ( mp->cur_sym!=0 ) { + return true; +} else { + mp->deletions_allowed=false; + print_err("TeX mode didn't end; all text was ignored after line "); + mp_print_int(mp, mp->warning_info); + help2("The file ended while I was looking for the `etex' to", + "finish this TeX material. I've inserted `etex' now."); + mp->cur_sym = frozen_etex; + mp_ins_error(mp); + mp->deletions_allowed=true; + return false; +} + +@ @<Back up an outer symbolic token so that it can be reread@>= +if ( mp->cur_sym!=0 ) { + p=mp_get_avail(mp); mp_info(p)=mp->cur_sym; + back_list(p); /* prepare to read the symbolic token again */ +} + +@ @<Tell the user what has run away...@>= +{ + mp_runaway(mp); /* print the definition-so-far */ + if ( mp->cur_sym==0 ) { + print_err("File ended"); +@.File ended while scanning...@> + } else { + print_err("Forbidden token found"); +@.Forbidden token found...@> + } + mp_print(mp, " while scanning "); + help4("I suspect you have forgotten an `enddef',", + "causing me to read past where you wanted me to stop.", + "I'll try to recover; but if the error is serious,", + "you'd better type `E' or `X' now and fix your file."); + switch (mp->scanner_status) { + @<Complete the error message, + and set |cur_sym| to a token that might help recover from the error@> + } /* there are no other cases */ + mp_ins_error(mp); +} + +@ As we consider various kinds of errors, it is also appropriate to +change the first line of the help message just given; |help_line[3]| +points to the string that might be changed. + +@<Complete the error message,...@>= +case flushing: + mp_print(mp, "to the end of the statement"); + mp->help_line[3]="A previous error seems to have propagated,"; + mp->cur_sym=frozen_semicolon; + break; +case absorbing: + mp_print(mp, "a text argument"); + mp->help_line[3]="It seems that a right delimiter was left out,"; + if ( mp->warning_info==0 ) { + mp->cur_sym=frozen_end_group; + } else { + mp->cur_sym=frozen_right_delimiter; + equiv(frozen_right_delimiter)=mp->warning_info; + } + break; +case var_defining: +case op_defining: + mp_print(mp, "the definition of "); + if ( mp->scanner_status==op_defining ) + mp_print_text(mp->warning_info); + else + mp_print_variable_name(mp, mp->warning_info); + mp->cur_sym=frozen_end_def; + break; +case loop_defining: + mp_print(mp, "the text of a "); + mp_print_text(mp->warning_info); + mp_print(mp, " loop"); + mp->help_line[3]="I suspect you have forgotten an `endfor',"; + mp->cur_sym=frozen_end_for; + break; + +@ The |runaway| procedure displays the first part of the text that occurred +when \MP\ began its special |scanner_status|, if that text has been saved. + +@<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(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 */ +@^inner loop@> + /*restart*/ /* go here to get the next input token */ + /*exit*/ /* go here when the next input token has been got */ + /*|common_ending|*/ /* go here to finish getting a symbolic token */ + /*found*/ /* go here when the end of a symbolic token has been found */ + /*switch*/ /* go here to branch on the class of an input character */ + /*|start_numeric_token|,|start_decimal_token|,|fin_numeric_token|,|done|*/ + /* go here at crucial stages when scanning a number */ + int k; /* an index into |buffer| */ + ASCII_code c; /* the current character in the buffer */ + int class; /* its class number */ + integer n,f; /* registers for decimal-to-binary conversion */ +RESTART: + mp->cur_sym=0; + if ( file_state ) { + @<Input from external file; |goto restart| if no input found, + or |return| if a non-symbolic token is found@>; + } else { + @<Input from token list; |goto restart| if end of list or + if a parameter needs to be expanded, + or |return| if a non-symbolic token is found@>; + } +COMMON_ENDING: + @<Finish getting the symbolic token in |cur_sym|; + |goto restart| if it is illegal@>; +} + +@ When a symbolic token is declared to be `\&{outer}', its command code +is increased by |outer_tag|. +@^inner loop@> + +@<Finish getting the symbolic token in |cur_sym|...@>= +mp->cur_cmd=eq_type(mp->cur_sym); mp->cur_mod=equiv(mp->cur_sym); +if ( mp->cur_cmd>=outer_tag ) { + if ( mp_check_outer_validity(mp) ) + mp->cur_cmd=mp->cur_cmd-outer_tag; + else + goto RESTART; +} + +@ A percent sign appears in |buffer[limit]|; this makes it unnecessary +to have a special test for end-of-line. +@^inner loop@> + +@<Input from external file;...@>= +{ +SWITCH: + c=mp->buffer[loc]; incr(loc); class=mp->char_class[c]; + switch (class) { + case digit_class: goto START_NUMERIC_TOKEN; break; + case period_class: + class=mp->char_class[mp->buffer[loc]]; + if ( class>period_class ) { + goto SWITCH; + } else if ( class<period_class ) { /* |class=digit_class| */ + n=0; goto START_DECIMAL_TOKEN; + } +@:. }{\..\ token@> + break; + case space_class: goto SWITCH; break; + case percent_class: + if ( mp->scanner_status==tex_flushing ) { + if ( loc<limit ) goto SWITCH; + } + @<Move to next line of file, or |goto restart| if there is no next line@>; + check_interrupt; + goto SWITCH; + break; + case string_class: + if ( mp->scanner_status==tex_flushing ) goto SWITCH; + else @<Get a string token and |return|@>; + break; + case isolated_classes: + k=loc-1; goto FOUND; break; + case invalid_class: + if ( mp->scanner_status==tex_flushing ) goto SWITCH; + else @<Decry the invalid character and |goto restart|@>; + break; + default: break; /* letters, etc. */ + } + k=loc-1; + while ( mp->char_class[mp->buffer[loc]]==class ) incr(loc); + goto FOUND; +START_NUMERIC_TOKEN: + @<Get the integer part |n| of a numeric token; + set |f:=0| and |goto fin_numeric_token| if there is no decimal point@>; +START_DECIMAL_TOKEN: + @<Get the fraction part |f| of a numeric token@>; +FIN_NUMERIC_TOKEN: + @<Pack the numeric and fraction parts of a numeric token + and |return|@>; +FOUND: + mp->cur_sym=mp_id_lookup(mp, k,loc-k); +} + +@ We go to |restart| instead of to |SWITCH|, because we might enter +|token_state| after the error has been dealt with +(cf.\ |clear_for_error_prompt|). + +@<Decry the invalid...@>= +{ + print_err("Text line contains an invalid character"); +@.Text line contains...@> + help2("A funny symbol that I can\'t read has just been input.", + "Continue, and I'll forget that it ever happened."); + mp->deletions_allowed=false; mp_error(mp); mp->deletions_allowed=true; + goto RESTART; +} + +@ @<Get a string token and |return|@>= +{ + if ( mp->buffer[loc]=='"' ) { + mp->cur_mod=null_str; + } 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|@>; + } + if ( loc==k+1 ) { + mp->cur_mod=mp->buffer[k]; + } else { + str_room(loc-k); + do { + append_char(mp->buffer[k]); incr(k); + } while (k!=loc); + mp->cur_mod=mp_make_string(mp); + } + } + incr(loc); mp->cur_cmd=string_token; + return; +} + +@ We go to |restart| after this error message, not to |SWITCH|, +because the |clear_for_error_prompt| routine might have reinstated +|token_state| after |error| has finished. + +@<Decry the missing string delimiter and |goto restart|@>= +{ + loc=limit; /* the next character to be read on this line will be |"%"| */ + print_err("Incomplete string token has been flushed"); +@.Incomplete string token...@> + help3("Strings should finish on the same line as they began.", + "I've deleted the partial string; you might want to", + "insert another by typing, e.g., `I\"new string\"'."); + mp->deletions_allowed=false; mp_error(mp); + mp->deletions_allowed=true; + goto RESTART; +} + +@ @<Get the integer part |n| of a numeric token...@>= +n=c-'0'; +while ( mp->char_class[mp->buffer[loc]]==digit_class ) { + if ( n<32768 ) n=10*n+mp->buffer[loc]-'0'; + incr(loc); +} +if ( mp->buffer[loc]=='.' ) + if ( mp->char_class[mp->buffer[loc+1]]==digit_class ) + goto DONE; +f=0; +goto FIN_NUMERIC_TOKEN; +DONE: incr(loc) + +@ @<Get the fraction part |f| of a numeric token@>= +k=0; +do { + if ( k<17 ) { /* digits for |k>=17| cannot affect the result */ + mp->dig[k]=mp->buffer[loc]-'0'; incr(k); + } + incr(loc); +} while (mp->char_class[mp->buffer[loc]]==digit_class); +f=mp_round_decimals(mp, k); +if ( f==unity ) { + incr(n); f=0; +} + +@ @<Pack the numeric and fraction parts of a numeric token and |return|@>= +if ( n<32768 ) { + @<Set |cur_mod:=n*unity+f| and check if it is uncomfortably large@>; +} else if ( mp->scanner_status!=tex_flushing ) { + print_err("Enormous number has been reduced"); +@.Enormous number...@> + help2("I can\'t handle numbers bigger than 32767.99998;", + "so I've changed your constant to that maximum amount."); + mp->deletions_allowed=false; mp_error(mp); mp->deletions_allowed=true; + mp->cur_mod=el_gordo; +} +mp->cur_cmd=numeric_token; return + +@ @<Set |cur_mod:=n*unity+f| and check if it is uncomfortably large@>= +{ + mp->cur_mod=n*unity+f; + if ( mp->cur_mod>=fraction_one ) { + if ( (mp->internal[mp_warning_check]>0) && + (mp->scanner_status!=tex_flushing) ) { + print_err("Number is too large ("); + mp_print_scaled(mp, mp->cur_mod); + mp_print_char(mp, xord(')')); + help3("It is at least 4096. Continue and I'll try to cope", + "with that big value; but it might be dangerous.", + "(Set warningcheck:=0 to suppress this message.)"); + mp_error(mp); + } + } +} + +@ Let's consider now what happens when |get_next| is looking at a token list. +@^inner loop@> + +@<Input from token list;...@>= +if ( loc>=mp->hi_mem_min ) { /* one-word token */ + mp->cur_sym=mp_info(loc); loc=mp_link(loc); /* move to next */ + if ( mp->cur_sym>=expr_base ) { + if ( mp->cur_sym>=suffix_base ) { + @<Insert a suffix or text parameter and |goto restart|@>; + } else { + mp->cur_cmd=capsule_token; + mp->cur_mod=mp->param_stack[param_start+mp->cur_sym-(expr_base)]; + mp->cur_sym=0; return; + } + } +} else if ( loc>null ) { + @<Get a stored numeric or string or capsule token and |return|@> +} else { /* we are done with this token list */ + mp_end_token_list(mp); goto RESTART; /* resume previous level */ +} + +@ @<Insert a suffix or text parameter...@>= +{ + if ( mp->cur_sym>=text_base ) mp->cur_sym=mp->cur_sym-mp->param_size; + /* |param_size=text_base-suffix_base| */ + mp_begin_token_list(mp, + mp->param_stack[param_start+mp->cur_sym-(suffix_base)], + parameter); + goto RESTART; +} + +@ @<Get a stored numeric or string or capsule token...@>= +{ + if ( mp_name_type(loc)==mp_token ) { + mp->cur_mod=value(loc); + if ( mp_type(loc)==mp_known ) { + mp->cur_cmd=numeric_token; + } else { + mp->cur_cmd=string_token; add_str_ref(mp->cur_mod); + } + } else { + mp->cur_mod=loc; mp->cur_cmd=capsule_token; + }; + loc=mp_link(loc); return; +} + +@ All of the easy branches of |get_next| have now been taken care of. +There is one more branch. + +@<Move to next line of file, or |goto restart|...@>= +if ( name>max_spec_src) { + @<Read next line of file into |buffer|, or + |goto restart| if the file has ended@>; +} else { + if ( mp->input_ptr>0 ) { + /* text was inserted during error recovery or by \&{scantokens} */ + mp_end_file_reading(mp); goto RESTART; /* resume previous level */ + } + if (mp->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')"); +@.Please type...@> + mp_print_ln(mp); mp->first=(size_t)start; + prompt_input("*"); /* input on-line into |buffer| */ +@.*\relax@> + 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)"); +@.job aborted@> + /* nonstop mode, which is intended for overnight batch processing, + never waits for on-line input */ + } +} + +@ The global variable |force_eof| is normally |false|; it is set |true| +by an \&{endinput} command. + +@<Glob...@>= +boolean force_eof; /* should the next \&{input} be aborted early? */ + +@ We must decrement |loc| in order to leave the buffer in a valid state +when an error condition causes us to |goto restart| without calling +|end_file_reading|. + +@<Read next line of file into |buffer|, or + |goto restart| if the file has ended@>= +{ + incr(line); mp->first=(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:=frozen_mpx_break| and |goto comon_ending|@>; + } 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) ) goto RESTART; + else goto RESTART; + } + } + mp->buffer[limit]=xord('%'); mp->first=(size_t)(limit+1); loc=start; /* ready to read */ +} + +@ We should never actually come to the end of an \.{MPX} file because such +files should have an \&{mpxbreak} after the translation of the last +\&{btex}$\,\ldots\,$\&{etex} block. + +@<Complain that the \.{MPX} file ended unexpectly; then set...@>= +{ + mp->mpx_name[iindex]=mpx_finished; + print_err("mpx file ended unexpectedly"); + help4("The file had too few picture expressions for btex...etex", + "blocks. Such files are normally generated automatically", + "but this one got messed up. You might want to insert a", + "picture expression now."); + mp->deletions_allowed=false; mp_error(mp); mp->deletions_allowed=true; + mp->cur_sym=frozen_mpx_break; goto COMMON_ENDING; +} + +@ Sometimes we want to make it look as though we have just read a blank line +without really doing so. + +@<Put an empty line in the input buffer@>= +mp->last=mp->first; limit=(halfword)mp->last; + /* simulate |input_ln| and |firm_up_the_line| */ +mp->buffer[limit]=xord('%'); mp->first=(size_t)(limit+1); loc=start + +@ If the user has set the |mp_pausing| parameter to some positive value, +and if nonstop mode has not been selected, each line of input is displayed +on the terminal and the transcript file, followed by `\.{=>}'. +\MP\ waits for a response. If the response is null (i.e., if nothing is +typed except perhaps a few blank spaces), the original +line is accepted as it stands; otherwise the line typed is +used instead of the line in the file. + +@c void mp_firm_up_the_line (MP mp) { + size_t k; /* an index into |buffer| */ + limit=(halfword)mp->last; + if ((!mp->noninteractive) + && (mp->internal[mp_pausing]>0 ) + && (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_str(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+start-mp->first]=mp->buffer[k]; + } + limit=(halfword)(start+mp->last-mp->first); + } + } +} + +@* \[30] Dealing with \TeX\ material. +The \&{btex}$\,\ldots\,$\&{etex} and \&{verbatimtex}$\,\ldots\,$\&{etex} +features need to be implemented at a low level in the scanning process +so that \MP\ can stay in synch with the a preprocessor that treats +blocks of \TeX\ material as they occur in the input file without trying +to expand \MP\ macros. Thus we need a special version of |get_next| +that does not expand macros and such but does handle \&{btex}, +\&{verbatimtex}, etc. + +The special version of |get_next| is called |get_t_next|. It works by flushing +\&{btex}$\,\ldots\,$\&{etex} and \&{verbatimtex}\allowbreak +$\,\ldots\,$\&{etex} blocks, switching to the \.{MPX} file when it sees +\&{btex}, and switching back when it sees \&{mpxbreak}. + +@d btex_code 0 +@d verbatim_code 1 + +@ @<Put each...@>= +mp_primitive(mp, "btex",start_tex,btex_code); +@:btex_}{\&{btex} primitive@> +mp_primitive(mp, "verbatimtex",start_tex,verbatim_code); +@:verbatimtex_}{\&{verbatimtex} primitive@> +mp_primitive(mp, "etex",etex_marker,0); mp->eqtb[frozen_etex]=mp->eqtb[mp->cur_sym]; +@:etex_}{\&{etex} primitive@> +mp_primitive(mp, "mpxbreak",mpx_break,0); mp->eqtb[frozen_mpx_break]=mp->eqtb[mp->cur_sym]; +@:mpx_break_}{\&{mpxbreak} primitive@> + +@ @<Cases of |print_cmd...@>= +case start_tex: if ( m==btex_code ) mp_print(mp, "btex"); + else mp_print(mp, "verbatimtex"); break; +case etex_marker: mp_print(mp, "etex"); break; +case mpx_break: mp_print(mp, "mpxbreak"); break; + +@ Actually, |get_t_next| is a macro that avoids procedure overhead except +in the unusual case where \&{btex}, \&{verbatimtex}, \&{etex}, or \&{mpxbreak} +is encountered. + +@d get_t_next {mp_get_next(mp); if ( mp->cur_cmd<=max_pre_command ) mp_t_next(mp); } + +@<Declarations@>= +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| */ + while ( mp->cur_cmd<=max_pre_command ) { + if ( mp->cur_cmd==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 ( mp->cur_cmd==start_tex ) { + if ( token_state || (name<=max_spec_src) ) { + @<Complain that we are not reading a file@>; + } else if ( mpx_reading ) { + @<Complain that \.{MPX} files cannot contain \TeX\ material@>; + } else if ( (mp->cur_mod!=verbatim_code)&& + (mp->mpx_name[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_info; +mp->scanner_status=tex_flushing; +mp->warning_info=line; +do { mp_get_next(mp); } while (mp->cur_cmd!=etex_marker); +mp->scanner_status=old_status; +mp->warning_info=old_info + +@ @<Complain that \.{MPX} files cannot contain \TeX\ material@>= +{ print_err("An mpx file cannot contain btex or verbatimtex blocks"); +help4("This file contains picture expressions for btex...etex", + "blocks. Such files are normally generated automatically", + "but this one seems to be messed up. I'll just keep going", + "and hope for the best."); +mp_error(mp); +} + +@ @<Complain that we are not reading a file@>= +{ print_err("You can only use `btex' or `verbatimtex' in a file"); +help3("I'll have to ignore this preprocessor command because it", + "only works when there is a file to preprocess. You might", + "want to delete everything up to the next `etex`."); +mp_error(mp); +} + +@ @<Complain about a misplaced \&{mpxbreak}@>= +{ print_err("Misplaced mpxbreak"); +help2("I'll ignore this preprocessor command because it", + "doesn't belong here"); +mp_error(mp); +} + +@ @<Complain about a misplaced \&{etex}@>= +{ print_err("Extra etex will be ignored"); +help1("There is no btex or verbatimtex for this to match"); +mp_error(mp); +} + +@* \[31] Scanning macro definitions. +\MP\ has a variety of ways to tuck tokens away into token lists for later +use: Macros can be defined with \&{def}, \&{vardef}, \&{primarydef}, etc.; +repeatable code can be defined with \&{for}, \&{forever}, \&{forsuffixes}. +All such operations are handled by the routines in this part of the program. + +The modifier part of each command code is zero for the ``ending delimiters'' +like \&{enddef} and \&{endfor}. + +@d start_def 1 /* command modifier for \&{def} */ +@d var_def 2 /* command modifier for \&{vardef} */ +@d end_def 0 /* command modifier for \&{enddef} */ +@d start_forever 1 /* command modifier for \&{forever} */ +@d end_for 0 /* command modifier for \&{endfor} */ + +@<Put each...@>= +mp_primitive(mp, "def",macro_def,start_def); +@:def_}{\&{def} primitive@> +mp_primitive(mp, "vardef",macro_def,var_def); +@:var_def_}{\&{vardef} primitive@> +mp_primitive(mp, "primarydef",macro_def,secondary_primary_macro); +@:primary_def_}{\&{primarydef} primitive@> +mp_primitive(mp, "secondarydef",macro_def,tertiary_secondary_macro); +@:secondary_def_}{\&{secondarydef} primitive@> +mp_primitive(mp, "tertiarydef",macro_def,expression_tertiary_macro); +@:tertiary_def_}{\&{tertiarydef} primitive@> +mp_primitive(mp, "enddef",macro_def,end_def); mp->eqtb[frozen_end_def]=mp->eqtb[mp->cur_sym]; +@:end_def_}{\&{enddef} primitive@> +@# +mp_primitive(mp, "for",iteration,expr_base); +@:for_}{\&{for} primitive@> +mp_primitive(mp, "forsuffixes",iteration,suffix_base); +@:for_suffixes_}{\&{forsuffixes} primitive@> +mp_primitive(mp, "forever",iteration,start_forever); +@:forever_}{\&{forever} primitive@> +mp_primitive(mp, "endfor",iteration,end_for); mp->eqtb[frozen_end_for]=mp->eqtb[mp->cur_sym]; +@:end_for_}{\&{endfor} primitive@> + +@ @<Cases of |print_cmd...@>= +case macro_def: + if ( m<=var_def ) { + if ( m==start_def ) mp_print(mp, "def"); + else if ( m<start_def ) mp_print(mp, "enddef"); + else mp_print(mp, "vardef"); + } else if ( m==secondary_primary_macro ) { + mp_print(mp, "primarydef"); + } else if ( m==tertiary_secondary_macro ) { + mp_print(mp, "secondarydef"); + } else { + mp_print(mp, "tertiarydef"); + } + break; +case iteration: + if ( m<=start_forever ) { + if ( m==start_forever ) mp_print(mp, "forever"); + else mp_print(mp, "endfor"); + } else if ( m==expr_base ) { + mp_print(mp, "for"); + } else { + mp_print(mp, "forsuffixes"); + } + break; + +@ Different macro-absorbing operations have different syntaxes, but they +also have a lot in common. There is a list of special symbols that are to +be replaced by parameter tokens; there is a special command code that +ends the definition; the quotation conventions are identical. Therefore +it makes sense to have most of the work done by a single subroutine. That +subroutine is called |scan_toks|. + +The first parameter to |scan_toks| is the command code that will +terminate scanning (either |macro_def| or |iteration|). + +The second parameter, |subst_list|, points to a (possibly empty) list +of two-word nodes whose |info| and |value| fields specify symbol tokens +before and after replacement. The list will be returned to free storage +by |scan_toks|. + +The third parameter is simply appended to the token list that is built. +And the final parameter tells how many of the special operations +\.{\#\AT!}, \.{\AT!}, and \.{\AT!\#} are to be replaced by suffix parameters. +When such parameters are present, they are called \.{(SUFFIX0)}, +\.{(SUFFIX1)}, and \.{(SUFFIX2)}. + +@c static pointer mp_scan_toks (MP mp,command_code terminator, pointer + subst_list, pointer tail_end, quarterword suffix_count) { + pointer p; /* tail of the token list being built */ + pointer q; /* temporary for link management */ + integer balance; /* left delimiters minus right delimiters */ + p=hold_head; balance=1; mp_link(hold_head)=null; + while (1) { + get_t_next; + if ( mp->cur_sym>0 ) { + @<Substitute for |cur_sym|, if it's on the |subst_list|@>; + if ( mp->cur_cmd==terminator ) { + @<Adjust the balance; |break| if it's zero@>; + } else if ( mp->cur_cmd==macro_special ) { + @<Handle quoted symbols, \.{\#\AT!}, \.{\AT!}, or \.{\AT!\#}@>; + } + } + mp_link(p)=mp_cur_tok(mp); p=mp_link(p); + } + mp_link(p)=tail_end; mp_flush_node_list(mp, subst_list); + return mp_link(hold_head); +} + +@ @<Substitute for |cur_sym|...@>= +{ + q=subst_list; + while ( q!=null ) { + if ( mp_info(q)==mp->cur_sym ) { + mp->cur_sym=value(q); mp->cur_cmd=relax; break; + } + q=mp_link(q); + } +} + +@ @<Adjust the balance; |break| if it's zero@>= +if ( mp->cur_mod>0 ) { + incr(balance); +} else { + decr(balance); + if ( balance==0 ) + break; +} + +@ Four commands are intended to be used only within macro texts: \&{quote}, +\.{\#\AT!}, \.{\AT!}, and \.{\AT!\#}. They are variants of a single command +code called |macro_special|. + +@d quote 0 /* |macro_special| modifier for \&{quote} */ +@d macro_prefix 1 /* |macro_special| modifier for \.{\#\AT!} */ +@d macro_at 2 /* |macro_special| modifier for \.{\AT!} */ +@d macro_suffix 3 /* |macro_special| modifier for \.{\AT!\#} */ + +@<Put each...@>= +mp_primitive(mp, "quote",macro_special,quote); +@:quote_}{\&{quote} primitive@> +mp_primitive(mp, "#@@",macro_special,macro_prefix); +@:]]]\#\AT!_}{\.{\#\AT!} primitive@> +mp_primitive(mp, "@@",macro_special,macro_at); +@:]]]\AT!_}{\.{\AT!} primitive@> +mp_primitive(mp, "@@#",macro_special,macro_suffix); +@:]]]\AT!\#_}{\.{\AT!\#} primitive@> + +@ @<Cases of |print_cmd...@>= +case macro_special: + switch (m) { + case macro_prefix: mp_print(mp, "#@@"); break; + case macro_at: mp_print_char(mp, xord('@@')); break; + case macro_suffix: mp_print(mp, "@@#"); break; + default: mp_print(mp, "quote"); break; + } + break; + +@ @<Handle quoted...@>= +{ + if ( mp->cur_mod==quote ) { get_t_next; } + else if ( mp->cur_mod<=suffix_count ) + mp->cur_sym=suffix_base-1+mp->cur_mod; +} + +@ Here is a routine that's used whenever a token will be redefined. If +the user's token is unredefinable, the `|frozen_inaccessible|' token is +substituted; the latter is redefinable but essentially impossible to use, +hence \MP's tables won't get fouled up. + +@c static void mp_get_symbol (MP mp) { /* sets |cur_sym| to a safe symbol */ +RESTART: + get_t_next; + if ( (mp->cur_sym==0)||(mp->cur_sym>(integer)frozen_inaccessible) ) { + print_err("Missing symbolic token inserted"); +@.Missing symbolic token...@> + help3("Sorry: You can\'t redefine a number, string, or expr.", + "I've inserted an inaccessible symbol so that your", + "definition will be completed without mixing me up too badly."); + if ( mp->cur_sym>0 ) + mp->help_line[2]="Sorry: You can\'t redefine my error-recovery tokens."; + else if ( mp->cur_cmd==string_token ) + delete_str_ref(mp->cur_mod); + mp->cur_sym=frozen_inaccessible; mp_ins_error(mp); goto RESTART; + } +} + +@ Before we actually redefine a symbolic token, we need to clear away its +former value, if it was a variable. The following stronger version of +|get_symbol| does that. + +@c static void mp_get_clear_symbol (MP mp) { + mp_get_symbol(mp); mp_clear_symbol(mp, mp->cur_sym,false); +} + +@ Here's another little subroutine; it checks that an equals sign +or assignment sign comes along at the proper place in a macro definition. + +@c static void mp_check_equals (MP mp) { + if ( mp->cur_cmd!=equals ) if ( mp->cur_cmd!=assignment ) { + mp_missing_err(mp, "="); +@.Missing `='@> + help5("The next thing in this `def' should have been `=',", + "because I've already looked at the definition heading.", + "But don't worry; I'll pretend that an equals sign", + "was present. Everything from here to `enddef'", + "will be the replacement text of this macro."); + mp_back_error(mp); + } +} + +@ A \&{primarydef}, \&{secondarydef}, or \&{tertiarydef} is rather easily +handled now that we have |scan_toks|. In this case there are +two parameters, which will be \.{EXPR0} and \.{EXPR1} (i.e., +|expr_base| and |expr_base+1|). + +@c static void mp_make_op_def (MP mp) { + command_code m; /* the type of definition */ + pointer p,q,r; /* for list manipulation */ + m=mp->cur_mod; + mp_get_symbol(mp); q=mp_get_node(mp, token_node_size); + mp_info(q)=mp->cur_sym; value(q)=expr_base; + mp_get_clear_symbol(mp); mp->warning_info=mp->cur_sym; + mp_get_symbol(mp); p=mp_get_node(mp, token_node_size); + mp_info(p)=mp->cur_sym; value(p)=expr_base+1; mp_link(p)=q; + get_t_next; mp_check_equals(mp); + mp->scanner_status=op_defining; q=mp_get_avail(mp); ref_count(q)=null; + r=mp_get_avail(mp); mp_link(q)=r; mp_info(r)=general_macro; + mp_link(r)=mp_scan_toks(mp, macro_def,p,null,0); + mp->scanner_status=normal; eq_type(mp->warning_info)=m; + equiv(mp->warning_info)=q; mp_get_x_next(mp); +} + +@ Parameters to macros are introduced by the keywords \&{expr}, +\&{suffix}, \&{text}, \&{primary}, \&{secondary}, and \&{tertiary}. + +@<Put each...@>= +mp_primitive(mp, "expr",param_type,expr_base); +@:expr_}{\&{expr} primitive@> +mp_primitive(mp, "suffix",param_type,suffix_base); +@:suffix_}{\&{suffix} primitive@> +mp_primitive(mp, "text",param_type,text_base); +@:text_}{\&{text} primitive@> +mp_primitive(mp, "primary",param_type,primary_macro); +@:primary_}{\&{primary} primitive@> +mp_primitive(mp, "secondary",param_type,secondary_macro); +@:secondary_}{\&{secondary} primitive@> +mp_primitive(mp, "tertiary",param_type,tertiary_macro); +@:tertiary_}{\&{tertiary} primitive@> + +@ @<Cases of |print_cmd...@>= +case param_type: + if ( m>=expr_base ) { + if ( m==expr_base ) mp_print(mp, "expr"); + else if ( m==suffix_base ) mp_print(mp, "suffix"); + else mp_print(mp, "text"); + } else if ( m<secondary_macro ) { + mp_print(mp, "primary"); + } else if ( m==secondary_macro ) { + mp_print(mp, "secondary"); + } else { + mp_print(mp, "tertiary"); + } + break; + +@ Let's turn next to the more complex processing associated with \&{def} +and \&{vardef}. When the following procedure is called, |cur_mod| +should be either |start_def| or |var_def|. + +@c +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 */ + pointer r; /* parameter-substitution list */ + pointer q; /* tail of the macro token list */ + pointer p; /* temporary storage */ + halfword base; /* |expr_base|, |suffix_base|, or |text_base| */ + pointer l_delim,r_delim; /* matching delimiters */ + m=mp->cur_mod; c=general_macro; mp_link(hold_head)=null; + q=mp_get_avail(mp); ref_count(q)=null; r=null; + @<Scan the token or variable to be defined; + set |n|, |scanner_status|, and |warning_info|@>; + k=n; + if ( mp->cur_cmd==left_delimiter ) { + @<Absorb delimited parameters, putting them into lists |q| and |r|@>; + } + if ( mp->cur_cmd==param_type ) { + @<Absorb undelimited parameters, putting them into list |r|@>; + } + mp_check_equals(mp); + p=mp_get_avail(mp); mp_info(p)=c; mp_link(q)=p; + @<Attach the replacement text to the tail of node |p|@>; + mp->scanner_status=normal; mp_get_x_next(mp); +} + +@ We don't put `|frozen_end_group|' into the replacement text of +a \&{vardef}, because the user may want to redefine `\.{endgroup}'. + +@<Attach the replacement text to the tail of node |p|@>= +if ( m==start_def ) { + mp_link(p)=mp_scan_toks(mp, macro_def,r,null,n); +} else { + q=mp_get_avail(mp); mp_info(q)=mp->bg_loc; mp_link(p)=q; + p=mp_get_avail(mp); mp_info(p)=mp->eg_loc; + mp_link(q)=mp_scan_toks(mp, macro_def,r,p,n); +} +if ( mp->warning_info==bad_vardef ) + mp_flush_token_list(mp, value(bad_vardef)) + +@ @<Glob...@>= +int bg_loc; +int eg_loc; /* hash addresses of `\.{begingroup}' and `\.{endgroup}' */ + +@ @<Scan the token or variable to be defined;...@>= +if ( m==start_def ) { + mp_get_clear_symbol(mp); mp->warning_info=mp->cur_sym; get_t_next; + mp->scanner_status=op_defining; n=0; + eq_type(mp->warning_info)=defined_macro; equiv(mp->warning_info)=q; +} else { + p=mp_scan_declared_variable(mp); + mp_flush_variable(mp, equiv(mp_info(p)),mp_link(p),true); + mp->warning_info=mp_find_variable(mp, p); mp_flush_list(mp, p); + if ( mp->warning_info==null ) @<Change to `\.{a bad variable}'@>; + mp->scanner_status=var_defining; n=2; + if ( mp->cur_cmd==macro_special ) if ( mp->cur_mod==macro_suffix ) {/* \.{\AT!\#} */ + n=3; get_t_next; + } + mp_type(mp->warning_info)=mp_unsuffixed_macro-2+n; value(mp->warning_info)=q; +} /* |mp_suffixed_macro=mp_unsuffixed_macro+1| */ + +@ @<Change to `\.{a bad variable}'@>= +{ + print_err("This variable already starts with a macro"); +@.This variable already...@> + help2("After `vardef a' you can\'t say `vardef a.b'.", + "So I'll have to discard this definition."); + mp_error(mp); mp->warning_info=bad_vardef; +} + +@ @<Initialize table entries...@>= +mp_name_type(bad_vardef)=mp_root; mp_link(bad_vardef)=frozen_bad_vardef; +equiv(frozen_bad_vardef)=bad_vardef; eq_type(frozen_bad_vardef)=tag_token; + +@ @<Absorb delimited parameters, putting them into lists |q| and |r|@>= +do { + l_delim=mp->cur_sym; r_delim=mp->cur_mod; get_t_next; + if ( (mp->cur_cmd==param_type)&&(mp->cur_mod>=expr_base) ) { + base=mp->cur_mod; + } else { + print_err("Missing parameter type; `expr' will be assumed"); +@.Missing parameter type@> + help1("You should've had `expr' or `suffix' or `text' here."); + mp_back_error(mp); base=expr_base; + } + @<Absorb parameter tokens for type |base|@>; + mp_check_delimiter(mp, l_delim,r_delim); + get_t_next; +} while (mp->cur_cmd==left_delimiter) + +@ @<Absorb parameter tokens for type |base|@>= +do { + mp_link(q)=mp_get_avail(mp); q=mp_link(q); mp_info(q)=base+k; + mp_get_symbol(mp); p=mp_get_node(mp, token_node_size); + value(p)=base+k; mp_info(p)=mp->cur_sym; + if ( k==mp->param_size ) mp_overflow(mp, "parameter stack size",mp->param_size); +@:MetaPost capacity exceeded parameter stack size}{\quad parameter stack size@> + incr(k); mp_link(p)=r; r=p; get_t_next; +} while (mp->cur_cmd==comma) + +@ @<Absorb undelimited parameters, putting them into list |r|@>= +{ + p=mp_get_node(mp, token_node_size); + if ( mp->cur_mod<expr_base ) { + c=mp->cur_mod; value(p)=expr_base+k; + } else { + value(p)=mp->cur_mod+k; + if ( mp->cur_mod==expr_base ) c=expr_macro; + else if ( mp->cur_mod==suffix_base ) c=suffix_macro; + else c=text_macro; + } + if ( k==mp->param_size ) mp_overflow(mp, "parameter stack size",mp->param_size); + incr(k); mp_get_symbol(mp); mp_info(p)=mp->cur_sym; mp_link(p)=r; r=p; get_t_next; + if ( c==expr_macro ) if ( mp->cur_cmd==of_token ) { + c=of_macro; p=mp_get_node(mp, token_node_size); + if ( k==mp->param_size ) mp_overflow(mp, "parameter stack size",mp->param_size); + value(p)=expr_base+k; mp_get_symbol(mp); mp_info(p)=mp->cur_sym; + mp_link(p)=r; r=p; get_t_next; + } +} + +@* \[32] Expanding the next token. +Only a few command codes |<min_command| can possibly be returned by +|get_t_next|; in increasing order, they are +|if_test|, |fi_or_else|, |input|, |iteration|, |repeat_loop|, +|exit_test|, |relax|, |scan_tokens|, |expand_after|, and |defined_macro|. + +\MP\ usually gets the next token of input by saying |get_x_next|. This is +like |get_t_next| except that it keeps getting more tokens until +finding |cur_cmd>=min_command|. In other words, |get_x_next| expands +macros and removes conditionals or iterations or input instructions that +might be present. + +It follows that |get_x_next| might invoke itself recursively. In fact, +there is massive recursion, since macro expansion can involve the +scanning of arbitrarily complex expressions, which in turn involve +macro expansion and conditionals, etc. +@^recursion@> + +Therefore it's necessary to declare a whole bunch of |forward| +procedures at this point, and to insert some other procedures +that will be invoked by |get_x_next|. + +@<Declarations@>= +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_get_boolean (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); + +@ 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) { + pointer p; /* for list manipulation */ + size_t k; /* something that we hope is |<=buf_size| */ + pool_pointer j; /* index into |str_pool| */ + if ( mp->internal[mp_tracing_commands]>unity ) + if ( mp->cur_cmd!=defined_macro ) + show_cur_cmd_mod; + switch (mp->cur_cmd) { + case if_test: + mp_conditional(mp); /* this procedure is discussed in Part 36 below */ + break; + case fi_or_else: + @<Terminate the current conditional and skip to \&{fi}@>; + break; + case input: + @<Initiate or terminate input from a file@>; + break; + case iteration: + if ( mp->cur_mod==end_for ) { + @<Scold the user for having an extra \&{endfor}@>; + } else { + mp_begin_iteration(mp); /* this procedure is discussed in Part 37 below */ + } + break; + case repeat_loop: + @<Repeat a loop@>; + break; + case exit_test: + @<Exit a loop if the proper time has come@>; + break; + case relax: + break; + case expand_after: + @<Expand the token after the next token@>; + break; + case scan_tokens: + @<Put a string into the input buffer@>; + break; + case defined_macro: + mp_macro_call(mp, mp->cur_mod,null,mp->cur_sym); + break; + }; /* there are no other cases */ +} + +@ @<Scold the user...@>= +{ + print_err("Extra `endfor'"); +@.Extra `endfor'@> + help2("I'm not currently working on a for loop,", + "so I had better not try to end anything."); + mp_error(mp); +} + +@ The processing of \&{input} involves the |start_input| subroutine, +which will be declared later; the processing of \&{endinput} is trivial. + +@<Put each...@>= +mp_primitive(mp, "input",input,0); +@:input_}{\&{input} primitive@> +mp_primitive(mp, "endinput",input,1); +@:end_input_}{\&{endinput} primitive@> + +@ @<Cases of |print_cmd_mod|...@>= +case input: + if ( m==0 ) mp_print(mp, "input"); + else mp_print(mp, "endinput"); + break; + +@ @<Initiate or terminate input...@>= +if ( mp->cur_mod>0 ) mp->force_eof=true; +else mp_start_input(mp) + +@ We'll discuss the complicated parts of loop operations later. For now +it suffices to know that there's a global variable called |loop_ptr| +that will be |null| if no loop is in progress. + +@<Repeat a loop@>= +{ while ( token_state &&(loc==null) ) + mp_end_token_list(mp); /* conserve stack space */ + if ( mp->loop_ptr==null ) { + print_err("Lost loop"); +@.Lost loop@> + help2("I'm confused; after exiting from a loop, I still seem", + "to want to repeat it. I'll try to forget the problem."); + mp_error(mp); + } else { + mp_resume_iteration(mp); /* this procedure is in Part 37 below */ + } +} + +@ @<Exit a loop if the proper time has come@>= +{ mp_get_boolean(mp); + if ( mp->internal[mp_tracing_commands]>unity ) + mp_show_cmd_mod(mp, nullary,mp->cur_exp); + if ( mp->cur_exp==true_code ) { + if ( mp->loop_ptr==null ) { + print_err("No loop is in progress"); +@.No loop is in progress@> + help1("Why say `exitif' when there's nothing to exit from?"); + if ( mp->cur_cmd==semicolon ) mp_error(mp); else mp_back_error(mp); + } else { + @<Exit prematurely from an iteration@>; + } + } else if ( mp->cur_cmd!=semicolon ) { + mp_missing_err(mp, ";"); +@.Missing `;'@> + help2("After `exitif <boolean exp>' I expect to see a semicolon.", + "I shall pretend that one was there."); mp_back_error(mp); + } +} + +@ Here we use the fact that |forever_text| is the only |token_type| that +is less than |loop_text|. + +@<Exit prematurely...@>= +{ p=null; + do { + if ( file_state ) { + mp_end_file_reading(mp); + } else { + if ( token_type<=loop_text ) p=start; + mp_end_token_list(mp); + } + } while (p==null); + if ( p!=mp_info(mp->loop_ptr) ) mp_fatal_error(mp, "*** (loop confusion)"); +@.loop confusion@> + mp_stop_iteration(mp); /* this procedure is in Part 34 below */ +} + +@ @<Expand the token after the next token@>= +{ get_t_next; + p=mp_cur_tok(mp); get_t_next; + if ( mp->cur_cmd<min_command ) mp_expand(mp); + else mp_back_input(mp); + back_list(p); +} + +@ @<Put a string into the input buffer@>= +{ mp_get_x_next(mp); mp_scan_primary(mp); + if ( mp->cur_type!=mp_string_type ) { + mp_disp_err(mp, null,"Not a string"); +@.Not a string@> + help2("I'm going to flush this expression, since", + "scantokens should be followed by a known string."); + mp_put_get_flush_error(mp, 0); + } else { + mp_back_input(mp); + if ( length(mp->cur_exp)>0 ) + @<Pretend we're reading a new one-line file@>; + } +} + +@ @<Pretend we're reading a new one-line file@>= +{ mp_begin_file_reading(mp); name=is_scantok; + k=mp->first+length(mp->cur_exp); + if ( k>=mp->max_buf_stack ) { + while ( k>=mp->buf_size ) { + mp_reallocate_buffer(mp,(mp->buf_size+(mp->buf_size/4))); + } + mp->max_buf_stack=k+1; + } + j=mp->str_start[mp->cur_exp]; limit=(halfword)k; + while ( mp->first<(size_t)limit ) { + mp->buffer[mp->first]=mp->str_pool[j]; incr(j); incr(mp->first); + } + mp->buffer[limit]=xord('%'); mp->first=(size_t)(limit+1); loc=start; + mp_flush_cur_exp(mp, 0); +} + +@ Here finally is |get_x_next|. + +The expression scanning routines to be considered later +communicate via the global quantities |cur_type| and |cur_exp|; +we must be very careful to save and restore these quantities while +macros are being expanded. +@^inner loop@> + +@<Declarations@>= +static void mp_get_x_next (MP mp); + +@ @c void mp_get_x_next (MP mp) { + pointer save_exp; /* a capsule to save |cur_type| and |cur_exp| */ + get_t_next; + if ( mp->cur_cmd<min_command ) { + save_exp=mp_stash_cur_exp(mp); + do { + if ( mp->cur_cmd==defined_macro ) + mp_macro_call(mp, mp->cur_mod,null,mp->cur_sym); + else + mp_expand(mp); + get_t_next; + } while (mp->cur_cmd<min_command); + mp_unstash_cur_exp(mp, save_exp); /* that restores |cur_type| and |cur_exp| */ + } +} + +@ Now let's consider the |macro_call| procedure, which is used to start up +all user-defined macros. Since the arguments to a macro might be expressions, +|macro_call| is recursive. +@^recursion@> + +The first parameter to |macro_call| points to the reference count of the +token list that defines the macro. The second parameter contains any +arguments that have already been parsed (see below). The third parameter +points to the symbolic token that names the macro. If the third parameter +is |null|, the macro was defined by \&{vardef}, so its name can be +reconstructed from the prefix and ``at'' arguments found within the +second parameter. + +What is this second parameter? It's simply a linked list of one-word items, +whose |info| fields point to the arguments. In other words, if |arg_list=null|, +no arguments have been scanned yet; otherwise |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,pointer def_ref, pointer arg_list, + pointer macro_name) ; + +@ @c +void mp_macro_call (MP mp,pointer def_ref, pointer arg_list, + pointer macro_name) { + /* invokes a user-defined control sequence */ + pointer r; /* current node in the macro's token list */ + pointer p,q; /* for list manipulation */ + integer n; /* the number of arguments */ + pointer tail = 0; /* tail of the argument list */ + pointer l_delim=0,r_delim=0; /* a delimiter pair */ + r=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 ( mp->internal[mp_tracing_macros]>0 ) { + @<Show the text of the macro being expanded, and the existing arguments@>; + } + @<Scan the remaining arguments, if any; set |r| to the first token + of the replacement text@>; + @<Feed the arguments and replacement text to the scanner@>; +} + +@ @<Show the text of the macro...@>= +mp_begin_diagnostic(mp); mp_print_ln(mp); +mp_print_macro_name(mp, arg_list,macro_name); +if ( n==3 ) mp_print(mp, "@@#"); /* indicate a suffixed macro */ +mp_show_macro(mp, def_ref,null,100000); +if ( arg_list!=null ) { + n=0; p=arg_list; + do { + q=mp_info(p); + mp_print_arg(mp, q,n,0); + incr(n); p=mp_link(p); + } while (p!=null); +} +mp_end_diagnostic(mp, false) + + +@ @<Declarations@>= +static void mp_print_macro_name (MP mp,pointer a, pointer n); + +@ @c +void mp_print_macro_name (MP mp,pointer a, pointer n) { + pointer p,q; /* they traverse the first part of |a| */ + if ( n!=null ) { + mp_print_text(n); + } else { + p=mp_info(a); + if ( p==null ) { + mp_print_text(mp_info(mp_info(mp_link(a)))); + } else { + q=p; + while ( mp_link(q)!=null ) q=mp_link(q); + mp_link(q)=mp_info(mp_link(a)); + mp_show_token_list(mp, p,null,1000,0); + mp_link(q)=null; + } + } +} + +@ @<Declarations@>= +static void mp_print_arg (MP mp,pointer q, integer n, pointer b) ; + +@ @c +void mp_print_arg (MP mp,pointer q, integer n, pointer b) { + if ( mp_link(q)==mp_void ) mp_print_nl(mp, "(EXPR"); + else if ( (b<text_base)&&(b!=text_macro) ) mp_print_nl(mp, "(SUFFIX"); + else mp_print_nl(mp, "(TEXT"); + mp_print_int(mp, n); mp_print(mp, ")<-"); + if ( 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|...@>= +mp->cur_cmd=comma+1; /* anything |<>comma| will do */ +while ( mp_info(r)>=expr_base ) { + @<Scan the delimited argument represented by |mp_info(r)|@>; + r=mp_link(r); +} +if ( mp->cur_cmd==comma ) { + print_err("Too many arguments to "); +@.Too many arguments...@> + mp_print_macro_name(mp, arg_list,macro_name); mp_print_char(mp, xord(';')); + mp_print_nl(mp, " Missing `"); mp_print_text(r_delim); +@.Missing `)'...@> + mp_print(mp, "' has been inserted"); + help3("I'm going to assume that the comma I just read was a", + "right delimiter, and then I'll begin expanding the macro.", + "You might want to delete some tokens before continuing."); + mp_error(mp); +} +if ( mp_info(r)!=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_info(r)|@>= +if ( mp->cur_cmd!=comma ) { + mp_get_x_next(mp); + if ( mp->cur_cmd!=left_delimiter ) { + print_err("Missing argument to "); +@.Missing argument...@> + mp_print_macro_name(mp, arg_list,macro_name); + help3("That macro has more parameters than you thought.", + "I'll continue by pretending that each missing argument", + "is either zero or null."); + if ( mp_info(r)>=suffix_base ) { + mp->cur_exp=null; mp->cur_type=mp_token_list; + } else { + mp->cur_exp=0; mp->cur_type=mp_known; + } + mp_back_error(mp); mp->cur_cmd=right_delimiter; + goto FOUND; + } + l_delim=mp->cur_sym; r_delim=mp->cur_mod; +} +@<Scan the argument represented by |mp_info(r)|@>; +if ( mp->cur_cmd!=comma ) + @<Check that the proper right delimiter was present@>; +FOUND: +@<Append the current expression to |arg_list|@> + +@ @<Check that the proper right delim...@>= +if ( (mp->cur_cmd!=right_delimiter)||(mp->cur_mod!=l_delim) ) { + if ( mp_info(mp_link(r))>=expr_base ) { + mp_missing_err(mp, ","); +@.Missing `,'@> + help3("I've finished reading a macro argument and am about to", + "read another; the arguments weren't delimited correctly.", + "You might want to delete some tokens before continuing."); + mp_back_error(mp); mp->cur_cmd=comma; + } else { + mp_missing_err(mp, str(text(r_delim))); +@.Missing `)'@> + help2("I've gotten to the end of the macro parameter list.", + "You might want to delete some tokens before continuing."); + mp_back_error(mp); + } +} + +@ A \&{suffix} or \&{text} parameter will have been scanned as +a token list pointed to by |cur_exp|, in which case we will have +|cur_type=token_list|. + +@<Append the current expression to |arg_list|@>= +{ + p=mp_get_avail(mp); + if ( mp->cur_type==mp_token_list ) mp_info(p)=mp->cur_exp; + else mp_info(p)=mp_stash_cur_exp(mp); + if ( mp->internal[mp_tracing_macros]>0 ) { + mp_begin_diagnostic(mp); mp_print_arg(mp, mp_info(p),n,mp_info(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_info(r)|@>= +if ( mp_info(r)>=text_base ) { + mp_scan_text_arg(mp, l_delim,r_delim); +} else { + mp_get_x_next(mp); + if ( mp_info(r)>=suffix_base ) mp_scan_suffix(mp); + else mp_scan_expression(mp); +} + +@ The parameters to |scan_text_arg| are either a pair of delimiters +or zero; the latter case is for undelimited text arguments, which +end with the first semicolon or \&{endgroup} or \&{end} that is not +contained in a group. + +@<Declarations@>= +static void mp_scan_text_arg (MP mp,pointer l_delim, pointer r_delim) ; + +@ @c +void mp_scan_text_arg (MP mp,pointer l_delim, pointer r_delim) { + integer balance; /* excess of |l_delim| over |r_delim| */ + pointer p; /* list tail */ + mp->warning_info=l_delim; mp->scanner_status=absorbing; + p=hold_head; balance=1; mp_link(hold_head)=null; + while (1) { + get_t_next; + if ( l_delim==0 ) { + @<Adjust the balance for an undelimited argument; |break| if done@>; + } else { + @<Adjust the balance for a delimited argument; |break| if done@>; + } + mp_link(p)=mp_cur_tok(mp); p=mp_link(p); + } + mp->cur_exp=mp_link(hold_head); mp->cur_type=mp_token_list; + mp->scanner_status=normal; +} + +@ @<Adjust the balance for a delimited argument...@>= +if ( mp->cur_cmd==right_delimiter ) { + if ( mp->cur_mod==l_delim ) { + decr(balance); + if ( balance==0 ) break; + } +} else if ( mp->cur_cmd==left_delimiter ) { + if ( mp->cur_mod==r_delim ) incr(balance); +} + +@ @<Adjust the balance for an undelimited...@>= +if ( end_of_statement ) { /* |cur_cmd=semicolon|, |end_group|, or |stop| */ + if ( balance==1 ) { break; } + else { if ( mp->cur_cmd==end_group ) decr(balance); } +} else if ( mp->cur_cmd==begin_group ) { + incr(balance); +} + +@ @<Scan undelimited argument(s)@>= +{ + if ( mp_info(r)<text_macro ) { + mp_get_x_next(mp); + if ( mp_info(r)!=suffix_macro ) { + if ( (mp->cur_cmd==equals)||(mp->cur_cmd==assignment) ) mp_get_x_next(mp); + } + } + switch (mp_info(r)) { + case primary_macro:mp_scan_primary(mp); break; + case secondary_macro:mp_scan_secondary(mp); break; + case tertiary_macro:mp_scan_tertiary(mp); break; + case expr_macro:mp_scan_expression(mp); break; + case of_macro: + @<Scan an expression followed by `\&{of} $\langle$primary$\rangle$'@>; + break; + case suffix_macro: + @<Scan a suffix with optional delimiters@>; + break; + case text_macro:mp_scan_text_arg(mp, 0,0); break; + } /* there are no other cases */ + mp_back_input(mp); + @<Append the current expression to |arg_list|@>; +} + +@ @<Scan an expression followed by `\&{of} $\langle$primary$\rangle$'@>= +{ + mp_scan_expression(mp); p=mp_get_avail(mp); mp_info(p)=mp_stash_cur_exp(mp); + if ( mp->internal[mp_tracing_macros]>0 ) { + mp_begin_diagnostic(mp); mp_print_arg(mp, mp_info(p),n,0); + mp_end_diagnostic(mp, false); + } + if ( arg_list==null ) arg_list=p; else mp_link(tail)=p; + tail=p;incr(n); + if ( mp->cur_cmd!=of_token ) { + mp_missing_err(mp, "of"); mp_print(mp, " for "); +@.Missing `of'@> + mp_print_macro_name(mp, arg_list,macro_name); + help1("I've got the first argument; will look now for the other."); + mp_back_error(mp); + } + mp_get_x_next(mp); mp_scan_primary(mp); +} + +@ @<Scan a suffix with optional delimiters@>= +{ + if ( mp->cur_cmd!=left_delimiter ) { + l_delim=null; + } else { + l_delim=mp->cur_sym; r_delim=mp->cur_mod; mp_get_x_next(mp); + }; + mp_scan_suffix(mp); + if ( l_delim!=null ) { + if ((mp->cur_cmd!=right_delimiter)||(mp->cur_mod!=l_delim) ) { + mp_missing_err(mp, str(text(r_delim))); +@.Missing `)'@> + help2("I've gotten to the end of the macro parameter list.", + "You might want to delete some tokens before continuing."); + mp_back_error(mp); + } + mp_get_x_next(mp); + } +} + +@ Before we put a new token list on the input stack, it is wise to clean off +all token lists that have recently been depleted. Then a user macro that ends +with a call to itself will not require unbounded stack space. + +@<Feed the arguments and replacement text to the scanner@>= +while ( token_state &&(loc==null) ) mp_end_token_list(mp); /* conserve stack space */ +if ( mp->param_ptr+n>mp->max_param_stack ) { + mp->max_param_stack=mp->param_ptr+n; + if ( mp->max_param_stack>mp->param_size ) + mp_overflow(mp, "parameter stack size",mp->param_size); +@:MetaPost capacity exceeded parameter stack size}{\quad parameter stack size@> +} +mp_begin_token_list(mp, def_ref,macro); name=macro_name; loc=r; +if ( n>0 ) { + p=arg_list; + do { + mp->param_stack[mp->param_ptr]=mp_info(p); incr(mp->param_ptr); p=mp_link(p); + } while (p!=null); + mp_flush_list(mp, arg_list); +} + +@ It's sometimes necessary to put a single argument onto |param_stack|. +The |stack_argument| subroutine does this. + +@c +static void mp_stack_argument (MP mp,pointer p) { + if ( mp->param_ptr==mp->max_param_stack ) { + incr(mp->max_param_stack); + if ( mp->max_param_stack>mp->param_size ) + mp_overflow(mp, "parameter stack size",mp->param_size); +@:MetaPost capacity exceeded parameter stack size}{\quad parameter stack size@> + } + mp->param_stack[mp->param_ptr]=p; incr(mp->param_ptr); +} + +@* \[33] Conditional processing. +Let's consider now the way \&{if} commands are handled. + +Conditions can be inside conditions, and this nesting has a stack +that is independent of other stacks. +Four global variables represent the top of the condition stack: +|cond_ptr| points to pushed-down entries, if~any; |cur_if| tells whether +we are processing \&{if} or \&{elseif}; |if_limit| specifies +the largest code of a |fi_or_else| command that is syntactically legal; +and |if_line| is the line number at which the current conditional began. + +If no conditions are currently in progress, the condition stack has the +special state |cond_ptr=null|, |if_limit=normal|, |cur_if=0|, |if_line=0|. +Otherwise |cond_ptr| points to a two-word node; the |type|, |name_type|, and +|link| fields of the first word contain |if_limit|, |cur_if|, and +|cond_ptr| at the next level, and the second word contains the +corresponding |if_line|. + +@d if_node_size 2 /* number of words in stack entry for conditionals */ +@d if_line_field(A) mp->mem[(A)+1].cint +@d if_code 1 /* code for \&{if} being evaluated */ +@d fi_code 2 /* code for \&{fi} */ +@d else_code 3 /* code for \&{else} */ +@d else_if_code 4 /* code for \&{elseif} */ + +@<Glob...@>= +pointer cond_ptr; /* top of the condition stack */ +integer if_limit; /* upper bound on |fi_or_else| codes */ +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",if_test,if_code); +@:if_}{\&{if} primitive@> +mp_primitive(mp, "fi",fi_or_else,fi_code); mp->eqtb[frozen_fi]=mp->eqtb[mp->cur_sym]; +@:fi_}{\&{fi} primitive@> +mp_primitive(mp, "else",fi_or_else,else_code); +@:else_}{\&{else} primitive@> +mp_primitive(mp, "elseif",fi_or_else,else_if_code); +@:else_if_}{\&{elseif} primitive@> + +@ @<Cases of |print_cmd_mod|...@>= +case if_test: +case fi_or_else: + switch (m) { + case if_code:mp_print(mp, "if"); break; + case fi_code:mp_print(mp, "fi"); break; + case else_code:mp_print(mp, "else"); break; + default: mp_print(mp, "elseif"); break; + } + break; + +@ Here is a procedure that ignores text until coming to an \&{elseif}, +\&{else}, or \&{fi} at level zero of $\&{if}\ldots\&{fi}$ +nesting. After it has acted, |cur_mod| will indicate the token that +was found. + +\MP's smallest two command codes are |if_test| and |fi_or_else|; this +makes the skipping process a bit simpler. + +@c +void mp_pass_text (MP mp) { + integer l = 0; + mp->scanner_status=skipping; + mp->warning_info=mp_true_line(mp); + while (1) { + get_t_next; + if ( mp->cur_cmd<=fi_or_else ) { + if ( mp->cur_cmd<fi_or_else ) { + incr(l); + } else { + if ( l==0 ) break; + if ( mp->cur_mod==fi_code ) decr(l); + } + } else { + @<Decrease the string reference count, + if the current token is a string@>; + } + } + mp->scanner_status=normal; +} + +@ @<Decrease the string reference count...@>= +if ( mp->cur_cmd==string_token ) { delete_str_ref(mp->cur_mod); } + +@ When we begin to process a new \&{if}, we set |if_limit:=if_code|; then +if \&{elseif} or \&{else} or \&{fi} occurs before the current \&{if} +condition has been evaluated, a colon will be inserted. +A construction like `\.{if fi}' would otherwise get \MP\ confused. + +@<Push the condition stack@>= +{ p=mp_get_node(mp, if_node_size); mp_link(p)=mp->cond_ptr; mp_type(p)=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@>= +{ 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, pointer p) { + pointer q; + if ( p==mp->cond_ptr ) { + mp->if_limit=l; /* that's the easy case */ + } else { + q=mp->cond_ptr; + while (1) { + if ( q==null ) mp_confusion(mp, "if"); +@:this can't happen if}{\quad if@> + if ( 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 ( mp->cur_cmd!=colon ) { + mp_missing_err(mp, ":"); +@.Missing `:'@> + help2("There should've been a colon after the condition.", + "I shall pretend that one was there."); + mp_back_error(mp); + } +} + +@ A condition is started when the |get_x_next| procedure encounters +an |if_test| command; in that case |get_x_next| calls |conditional|, +which is a recursive procedure. +@^recursion@> + +@c +void mp_conditional (MP mp) { + pointer save_cond_ptr; /* |cond_ptr| corresponding to this conditional */ + int new_if_limit; /* future value of |if_limit| */ + pointer p; /* temporary register */ + @<Push the condition stack@>; + save_cond_ptr=mp->cond_ptr; +RESWITCH: + mp_get_boolean(mp); new_if_limit=else_if_code; + if ( mp->internal[mp_tracing_commands]>unity ) { + @<Display the boolean value of |cur_exp|@>; + } +FOUND: + mp_check_colon(mp); + if ( mp->cur_exp==true_code ) { + mp_change_if_limit(mp, new_if_limit,save_cond_ptr); + return; /* wait for \&{elseif}, \&{else}, or \&{fi} */ + }; + @<Skip to \&{elseif} or \&{else} or \&{fi}, then |goto done|@>; +DONE: + mp->cur_if=mp->cur_mod; mp->if_line=mp_true_line(mp); + if ( mp->cur_mod==fi_code ) { + @<Pop the condition stack@> + } else if ( mp->cur_mod==else_if_code ) { + goto RESWITCH; + } else { + mp->cur_exp=true_code; new_if_limit=fi_code; mp_get_x_next(mp); + goto FOUND; + } +} + +@ In a construction like `\&{if} \&{if} \&{true}: $0=1$: \\{foo} +\&{else}: \\{bar} \&{fi}', the first \&{else} +that we come to after learning that the \&{if} is false is not the +\&{else} we're looking for. Hence the following curious logic is needed. + +@<Skip to \&{elseif}...@>= +while (1) { + mp_pass_text(mp); + if ( mp->cond_ptr==save_cond_ptr ) goto DONE; + else if ( mp->cur_mod==fi_code ) @<Pop the condition stack@>; +} + + +@ @<Display the boolean value...@>= +{ mp_begin_diagnostic(mp); + if ( mp->cur_exp==true_code ) mp_print(mp, "{true}"); + else mp_print(mp, "{false}"); + mp_end_diagnostic(mp, false); +} + +@ The processing of conditionals is complete except for the following +code, which is actually part of |get_x_next|. It comes into play when +\&{elseif}, \&{else}, or \&{fi} is scanned. + +@<Terminate the current conditional and skip to \&{fi}@>= +if ( mp->cur_mod>mp->if_limit ) { + if ( mp->if_limit==if_code ) { /* condition not yet evaluated */ + mp_missing_err(mp, ":"); +@.Missing `:'@> + mp_back_input(mp); mp->cur_sym=frozen_colon; mp_ins_error(mp); + } else { + print_err("Extra "); mp_print_cmd_mod(mp, fi_or_else,mp->cur_mod); +@.Extra else@> +@.Extra elseif@> +@.Extra fi@> + help1("I'm ignoring this; it doesn't match any if."); + mp_error(mp); + } +} else { + while ( mp->cur_mod!=fi_code ) mp_pass_text(mp); /* skip to \&{fi} */ + @<Pop the condition stack@>; +} + +@* \[34] Iterations. +To bring our treatment of |get_x_next| to a close, we need to consider what +\MP\ does when it sees \&{for}, \&{forsuffixes}, and \&{forever}. + +There's a global variable |loop_ptr| that keeps track of the \&{for} loops +that are currently active. If |loop_ptr=null|, no loops are in progress; +otherwise |mp_info(loop_ptr)| points to the iterative text of the current +(innermost) loop, and |mp_link(loop_ptr)| points to the data for any other +loops that enclose the current one. + +A loop-control node also has two other fields, called |loop_type| and +|loop_list|, whose contents depend on the type of loop: + +\yskip\indent|loop_type(loop_ptr)=null| means that |loop_list(loop_ptr)| +points to a list of one-word nodes whose |info| fields point to the +remaining argument values of a suffix list and expression list. + +\yskip\indent|loop_type(loop_ptr)=mp_void| means that the current loop is +`\&{forever}'. + +\yskip\indent|loop_type(loop_ptr)=progression_flag| means that +|p=loop_list(loop_ptr)| points to a ``progression node'' and |value(p)|, +|step_size(p)|, and |final_value(p)| contain the data for an arithmetic +progression. + +\yskip\indent|loop_type(loop_ptr)=p>mp_void| means that |p| points to an edge +header and |loop_list(loop_ptr)| points into the graphical object list for +that edge header. + +\yskip\noindent In the case of a progression node, the first word is not used +because the link field of words in the dynamic memory area cannot be arbitrary. + +@d loop_list_loc(A) ((A)+1) /* where the |loop_list| field resides */ +@d loop_type(A) mp_info(loop_list_loc((A))) /* the type of \&{for} loop */ +@d loop_list(A) mp_link(loop_list_loc((A))) /* the remaining list elements */ +@d loop_node_size 2 /* the number of words in a loop control node */ +@d progression_node_size 4 /* the number of words in a progression node */ +@d step_size(A) mp->mem[(A)+2].sc /* the step size in an arithmetic progression */ +@d final_value(A) mp->mem[(A)+3].sc /* the final value in an arithmetic progression */ +@d progression_flag (null+2) + /* |loop_type| value when |loop_list| points to a progression node */ + +@<Glob...@>= +pointer loop_ptr; /* top of the loop-control-node stack */ + +@ @<Set init...@>= +mp->loop_ptr=null; + +@ If the expressions that define an arithmetic progression in +a \&{for} loop don't have known numeric values, the |bad_for| +subroutine screams at the user. + +@c +static void mp_bad_for (MP mp, const char * s) { + mp_disp_err(mp, null,"Improper "); /* show the bad expression above the message */ +@.Improper...replaced by 0@> + mp_print(mp, s); mp_print(mp, " has been replaced by 0"); + help4("When you say `for x=a step b until c',", + "the initial value `a' and the step size `b'", + "and the final value `c' must have known numeric values.", + "I'm zeroing this one. Proceed, with fingers crossed."); + mp_put_get_flush_error(mp, 0); +} + +@ Here's what \MP\ does when \&{for}, \&{forsuffixes}, or \&{forever} +has just been scanned. (This code requires slight familiarity with +expression-parsing routines that we have not yet discussed; but it seems +to belong in the present part of the program, even though the original author +didn't write it until later. The reader may wish to come back to it.) + +@c void mp_begin_iteration (MP mp) { + halfword m; /* |expr_base| (\&{for}) or |suffix_base| (\&{forsuffixes}) */ + halfword n; /* hash address of the current symbol */ + pointer s; /* the new loop-control node */ + pointer p; /* substitution list for |scan_toks| */ + pointer q; /* link manipulation register */ + pointer pp; /* a new progression node */ + m=mp->cur_mod; n=mp->cur_sym; s=mp_get_node(mp, loop_node_size); + if ( m==start_forever ){ + loop_type(s)=mp_void; p=null; mp_get_x_next(mp); + } else { + mp_get_symbol(mp); p=mp_get_node(mp, token_node_size); + mp_info(p)=mp->cur_sym; value(p)=m; + mp_get_x_next(mp); + if ( mp->cur_cmd==within_token ) { + @<Set up a picture iteration@>; + } else { + @<Check for the |"="| or |":="| in a loop header@>; + @<Scan the values to be used in the loop@>; + } + } + @<Check for the presence of a colon@>; + @<Scan the loop text and put it on the loop control stack@>; + mp_resume_iteration(mp); +} + +@ @<Check for the |"="| or |":="| in a loop header@>= +if ( (mp->cur_cmd!=equals)&&(mp->cur_cmd!=assignment) ) { + mp_missing_err(mp, "="); +@.Missing `='@> + help3("The next thing in this loop should have been `=' or `:='.", + "But don't worry; I'll pretend that an equals sign", + "was present, and I'll look for the values next."); + mp_back_error(mp); +} + +@ @<Check for the presence of a colon@>= +if ( mp->cur_cmd!=colon ) { + mp_missing_err(mp, ":"); +@.Missing `:'@> + help3("The next thing in this loop should have been a `:'.", + "So I'll pretend that a colon was present;", + "everything from here to `endfor' will be iterated."); + mp_back_error(mp); +} + +@ We append a special |frozen_repeat_loop| token in place of the +`\&{endfor}' at the end of the loop. This will come through \MP's scanner +at the proper time to cause the loop to be repeated. + +(If the user tries some shenanigan like `\&{for} $\ldots$ \&{let} \&{endfor}', +he will be foiled by the |get_symbol| routine, which keeps frozen +tokens unchanged. Furthermore the |frozen_repeat_loop| is an \&{outer} +token, so it won't be lost accidentally.) + +@ @<Scan the loop text...@>= +q=mp_get_avail(mp); mp_info(q)=frozen_repeat_loop; +mp->scanner_status=loop_defining; mp->warning_info=n; +mp_info(s)=mp_scan_toks(mp, iteration,p,q,0); mp->scanner_status=normal; +mp_link(s)=mp->loop_ptr; mp->loop_ptr=s + +@ @<Initialize table...@>= +eq_type(frozen_repeat_loop)=repeat_loop+outer_tag; +text(frozen_repeat_loop)=intern(" ENDFOR"); + +@ The loop text is inserted into \MP's scanning apparatus by the +|resume_iteration| routine. + +@c void mp_resume_iteration (MP mp) { + pointer p,q; /* link registers */ + p=loop_type(mp->loop_ptr); + if ( p==progression_flag ) { + p=loop_list(mp->loop_ptr); /* now |p| points to a progression node */ + mp->cur_exp=value(p); + if ( @<The arithmetic progression has ended@> ) { + mp_stop_iteration(mp); + return; + } + mp->cur_type=mp_known; q=mp_stash_cur_exp(mp); /* make |q| an \&{expr} argument */ + value(p)=mp->cur_exp+step_size(p); /* set |value(p)| for the next iteration */ + } else if ( p==null ) { + p=loop_list(mp->loop_ptr); + if ( p==null ) { + mp_stop_iteration(mp); + return; + } + loop_list(mp->loop_ptr)=mp_link(p); q=mp_info(p); free_avail(p); + } else if ( p==mp_void ) { + mp_begin_token_list(mp, mp_info(mp->loop_ptr),forever_text); return; + } else { + @<Make |q| a capsule containing the next picture component from + |loop_list(loop_ptr)| or |goto not_found|@>; + } + mp_begin_token_list(mp, mp_info(mp->loop_ptr),loop_text); + mp_stack_argument(mp, q); + if ( mp->internal[mp_tracing_commands]>unity ) { + @<Trace the start of a loop@>; + } + return; +NOT_FOUND: + mp_stop_iteration(mp); +} + +@ @<The arithmetic progression has ended@>= +((step_size(p)>0)&&(mp->cur_exp>final_value(p)))|| + ((step_size(p)<0)&&(mp->cur_exp<final_value(p))) + +@ @<Trace the start of a loop@>= +{ + mp_begin_diagnostic(mp); mp_print_nl(mp, "{loop value="); +@.loop value=n@> + if ( (q!=null)&&(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=loop_list(mp->loop_ptr); + if ( q==null ) goto NOT_FOUND; + skip_component(q) goto NOT_FOUND; + mp->cur_exp=mp_copy_objects(mp, loop_list(mp->loop_ptr),q); + mp_init_bbox(mp, mp->cur_exp); + mp->cur_type=mp_picture_type; + loop_list(mp->loop_ptr)=q; + q=mp_stash_cur_exp(mp); +} + +@ A level of loop control disappears when |resume_iteration| has decided +not to resume, or when an \&{exitif} construction has removed the loop text +from the input stack. + +@c void mp_stop_iteration (MP mp) { + pointer p,q; /* the usual */ + p=loop_type(mp->loop_ptr); + if ( p==progression_flag ) { + mp_free_node(mp, loop_list(mp->loop_ptr),progression_node_size); + } else if ( p==null ){ + q=loop_list(mp->loop_ptr); + while ( q!=null ) { + p=mp_info(q); + if ( p!=null ) { + if ( mp_link(p)==mp_void ) { /* it's an \&{expr} parameter */ + mp_recycle_value(mp, p); mp_free_node(mp, p,value_node_size); + } else { + mp_flush_token_list(mp, p); /* it's a \&{suffix} or \&{text} parameter */ + } + } + p=q; q=mp_link(q); free_avail(p); + } + } else if ( p>progression_flag ) { + delete_edge_ref(p); + } + p=mp->loop_ptr; mp->loop_ptr=mp_link(p); mp_flush_token_list(mp, mp_info(p)); + mp_free_node(mp, p,loop_node_size); +} + +@ Now that we know all about loop control, we can finish up +the missing portion of |begin_iteration| and we'll be done. + +The following code is performed after the `\.=' has been scanned in +a \&{for} construction (if |m=expr_base|) or a \&{forsuffixes} construction +(if |m=suffix_base|). + +@<Scan the values to be used in the loop@>= +loop_type(s)=null; q=loop_list_loc(s); mp_link(q)=null; /* |mp_link(q)=loop_list(s)| */ +do { + mp_get_x_next(mp); + if ( m!=expr_base ) { + mp_scan_suffix(mp); + } else { + if ( mp->cur_cmd>=colon ) if ( mp->cur_cmd<=comma ) + goto CONTINUE; + mp_scan_expression(mp); + if ( mp->cur_cmd==step_token ) if ( q==loop_list_loc(s) ) { + @<Prepare for step-until construction and |break|@>; + } + mp->cur_exp=mp_stash_cur_exp(mp); + } + mp_link(q)=mp_get_avail(mp); q=mp_link(q); + mp_info(q)=mp->cur_exp; mp->cur_type=mp_vacuous; +CONTINUE: + ; +} while (mp->cur_cmd==comma) + +@ @<Prepare for step-until construction and |break|@>= +{ + if ( mp->cur_type!=mp_known ) mp_bad_for(mp, "initial value"); + pp=mp_get_node(mp, progression_node_size); value(pp)=mp->cur_exp; + mp_get_x_next(mp); mp_scan_expression(mp); + if ( mp->cur_type!=mp_known ) mp_bad_for(mp, "step size"); + step_size(pp)=mp->cur_exp; + if ( mp->cur_cmd!=until_token ) { + mp_missing_err(mp, "until"); +@.Missing `until'@> + help2("I assume you meant to say `until' after `step'.", + "So I'll look for the final value and colon next."); + mp_back_error(mp); + } + mp_get_x_next(mp); mp_scan_expression(mp); + if ( mp->cur_type!=mp_known ) mp_bad_for(mp, "final value"); + final_value(pp)=mp->cur_exp; loop_list(s)=pp; + loop_type(s)=progression_flag; + break; +} + +@ The last case is when we have just seen ``\&{within}'', and we need to +parse a picture expression and prepare to iterate over it. + +@<Set up a picture iteration@>= +{ mp_get_x_next(mp); + mp_scan_expression(mp); + @<Make sure the current expression is a known picture@>; + loop_type(s)=mp->cur_exp; mp->cur_type=mp_vacuous; + q=mp_link(dummy_loc(mp->cur_exp)); + if ( q!= null ) + if ( is_start_or_stop(q) ) + if ( mp_skip_1component(mp, q)==null ) q=mp_link(q); + loop_list(s)=q; +} + +@ @<Make sure the current expression is a known picture@>= +if ( mp->cur_type!=mp_picture_type ) { + mp_disp_err(mp, null,"Improper iteration spec has been replaced by nullpicture"); + help1("When you say `for x in p', p must be a known picture."); + mp_put_get_flush_error(mp, mp_get_node(mp, edge_header_size)); + mp_init_edges(mp, mp->cur_exp); mp->cur_type=mp_picture_type; +} + +@* \[35] File names. +It's time now to fret about file names. Besides the fact that different +operating systems treat files in different ways, we must cope with the +fact that completely different naming conventions are used by different +groups of people. The following programs show what is required for one +particular operating system; similar routines for other systems are not +difficult to devise. +@^system dependencies@> + +\MP\ assumes that a file name has three parts: the name proper; its +``extension''; and a ``file area'' where it is found in an external file +system. The extension of an input file is assumed to be +`\.{.mp}' unless otherwise specified; it is `\.{.log}' on the +transcript file that records each run of \MP; it is `\.{.tfm}' on the font +metric files that describe characters in any fonts created by \MP; it is +`\.{.ps}' or `.{\it nnn}' for some number {\it nnn} on the \ps\ output files; +and it is `\.{.mem}' on the mem files written by \.{INIMP} to initialize \MP. +The file area can be arbitrary on input files, but files are usually +output to the user's current area. If an input file cannot be +found on the specified area, \MP\ will look for it on a special system +area; this special area is intended for commonly used input files. + +Simple uses of \MP\ refer only to file names that have no explicit +extension or area. For example, a person usually says `\.{input} \.{cmr10}' +instead of `\.{input} \.{cmr10.new}'. Simple file +names are best, because they make the \MP\ source files portable; +whenever a file name consists entirely of letters and digits, it should be +treated in the same way by all implementations of \MP. However, users +need the ability to refer to other files in their environment, especially +when responding to error messages concerning unopenable files; therefore +we want to let them use the syntax that appears in their favorite +operating system. + +@ \MP\ uses the same conventions that have proved to be satisfactory for +\TeX\ and \MF. In order to isolate the system-dependent aspects of file names, +@^system dependencies@> +the system-independent parts of \MP\ are expressed in terms +of three system-dependent +procedures called |begin_name|, |more_name|, and |end_name|. In +essence, if the user-specified characters of the file name are $c_1\ldots c_n$, +the system-independent driver program does the operations +$$|begin_name|;\,|more_name|(c_1);\,\ldots\,;\,|more_name|(c_n); +\,|end_name|.$$ +These three procedures communicate with each other via global variables. +Afterwards the file name will appear in the string pool as three strings +called |cur_name|\penalty10000\hskip-.05em, +|cur_area|, and |cur_ext|; the latter two are null (i.e., +|""|), unless they were explicitly specified by the user. + +Actually the situation is slightly more complicated, because \MP\ needs +to know when the file name ends. The |more_name| routine is a function +(with side effects) that returns |true| on the calls |more_name|$(c_1)$, +\dots, |more_name|$(c_{n-1})$. The final call |more_name|$(c_n)$ +returns |false|; or, it returns |true| and $c_n$ is the last character +on the current input line. In other words, +|more_name| is supposed to return |true| unless it is sure that the +file name has been completely scanned; and |end_name| is supposed to be able +to finish the assembly of |cur_name|, |cur_area|, and |cur_ext| regardless of +whether $|more_name|(c_n)$ returned |true| or |false|. + +@<Glob...@>= +char * cur_name; /* name of file just scanned */ +char * cur_area; /* file area just scanned, or \.{""} */ +char * cur_ext; /* file extension just scanned, or \.{""} */ + +@ It is easier to maintain reference counts if we assign initial values. + +@<Set init...@>= +mp->cur_name=xstrdup(""); +mp->cur_area=xstrdup(""); +mp->cur_ext=xstrdup(""); + +@ @<Dealloc variables@>= +xfree(mp->cur_area); +xfree(mp->cur_name); +xfree(mp->cur_ext); + +@ The file names we shall deal with for illustrative purposes have the +following structure: If the name contains `\.>' or `\.:', the file area +consists of all characters up to and including the final such character; +otherwise the file area is null. If the remaining file name contains +`\..', the file extension consists of all such characters from the first +remaining `\..' to the end, otherwise the file extension is null. +@^system dependencies@> + +We can scan such file names easily by using two global variables that keep track +of the occurrences of area and extension delimiters. Note that these variables +cannot be of type |pool_pointer| because a string pool compaction could occur +while scanning a file name. + +@<Glob...@>= +integer area_delimiter; + /* most recent `\.>' or `\.:' relative to |str_start[str_ptr]| */ +integer ext_delimiter; /* the relevant `\..', if any */ +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@> + +The file name length is limited to |file_name_size|. That is good, because +in the current configuration we cannot call |mp_do_compaction| while a name +is being scanned, |mp->area_delimiter| and |mp->ext_delimiter| are direct +offsets into |mp->str_pool|. I am not in a great hurry to fix this, because +calling |str_room()| just once is more efficient anyway. TODO. + +@<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; + str_room(file_name_size); +} + +@ And here's the second. +@^system dependencies@> + +@d IS_DIR_SEP(c) (c=='/' || c=='\\') + +@c +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=mp->pool_ptr; + mp->ext_delimiter=-1; + } else if ( c=='.' ) { + mp->ext_delimiter=mp->pool_ptr; + } + append_char(c); /* contribute |c| to the current string */ + } + return true; +} + +@ The third. +@^system dependencies@> + +@d copy_pool_segment(A,B,C) { + A = xmalloc(C+1,sizeof(char)); + strncpy(A,(char *)(mp->str_pool+B),C); + A[C] = 0;} + +@c +void mp_end_name (MP mp) { + pool_pointer s; /* length of area, name, and extension */ + unsigned int len; + /* "my/w.mp" */ + s = mp->str_start[mp->str_ptr]; + if ( mp->area_delimiter<0 ) { + mp->cur_area=xstrdup(""); + } else { + len = (unsigned)(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->pool_ptr-s); + } else { + copy_pool_segment(mp->cur_ext,mp->ext_delimiter,(size_t)(mp->pool_ptr-mp->ext_delimiter)); + len = (unsigned)(mp->ext_delimiter-s); + } + copy_pool_segment(mp->cur_name,s,len); + mp->pool_ptr=s; /* don't need this partial string */ +} + +@ Conversely, here is a routine that takes three strings and prints a file +name that might have produced them. (The routine is system dependent, because +some operating systems put the file area last instead of first.) +@^system dependencies@> + +@<Basic printing...@>= +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) { c=xord((ASCII_code)(A)); + if ( k<file_name_size ) { + mp->name_of_file[k]=(char)xchr(c); + incr(k); + } +} + +@ @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| */ + ASCII_code c; /* character being packed */ + const char *j; /* a character index */ + k=0; + assert(n!=NULL); + 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; + mp->name_length=k; +} + +@ @<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 */ + +@ @<Find constant sizes@>= +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; + } + } +} + + +@ @<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, or +when the user is substituting another mem file by typing `\.\&' after +the initial `\.{**}' prompt. The buffer contains the first line of +input in |buffer[loc..(last-1)]|, where |loc<last| and |buffer[loc]<>""|. + +@<Declarations@>= +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,".mem"); + if (test == NULL || test != s+l-4) { + s = xrealloc (s, l+5, 1); + strcat (s, ".mem"); + } + } else { + s = xrealloc (s, l+5, 1); + strcat (s, ".mem"); + } + mp->mem_file = (mp->open_file)(mp,s, "r", mp_filetype_memfile); + xfree(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_ln("Sorry, I can\'t find that mem file; will try PLAIN."); +@.Sorry, I can't find...@> + update_terminal; + /* now pull out all the stops: try for the system \.{plain} file */ + 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 mem 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@> + +@<Declarations@>= +#define mp_a_make_name_string(A,B) mp_make_name_string(A) +#define mp_b_make_name_string(A,B) mp_make_name_string(A) +#define mp_w_make_name_string(A,B) mp_make_name_string(A) + +@ @c +static str_number mp_make_name_string (MP mp) { + int k; /* index into |name_of_file| */ + str_room(mp->name_length); + for (k=0;k<mp->name_length;k++) { + append_char(xord((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, str_number s) ; + +@ @c +void mp_str_scan_file (MP mp, str_number s) { + pool_pointer p,q; /* current position and stopping point */ + mp_begin_name(mp); + p=mp->str_start[s]; q=str_stop(s); + while ( p<q ){ + if ( ! mp_more_name(mp, mp->str_pool[p]) ) break; + incr(p); + } + mp_end_name(mp); +} + +@ And one that reads from a |char*|. + +@<Declare subroutines for parsing file names@>= +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, xord((ASCII_code)(*p)))) break; + p++; + } + mp_end_name(mp); +} + + +@ The global variable |job_name| contains the file name that was first +\&{input} by the user. This name is extended by `\.{.log}' and `\.{ps}' and +`\.{.mem}' and `\.{.tfm}' in order to make the names of \MP's output files. + +@<Glob...@>= +boolean log_opened; /* has the transcript file been opened? */ +char *log_name; /* full name of the log file */ + +@ @<Option variables@>= +char *job_name; /* principal file name */ + +@ Initially |job_name=NULL|; it becomes nonzero as soon as the true name is known. +We have |job_name=NULL| if and only if the `\.{log}' file has not been opened, +except of course for a short time just after |job_name| has become nonzero. + +@<Allocate or ...@>= +mp->job_name=mp_xstrdup(mp, opt->job_name); +if (opt->noninteractive && opt->ini_version) { + if (mp->job_name == NULL) + mp->job_name=mp_xstrdup(mp,mp->mem_name); + if (mp->job_name != NULL) { + size_t l = strlen(mp->job_name); + if (l>4) { + char *test = strstr(mp->job_name,".mem"); + if (test == mp->job_name+l-4) + *test = 0; + } + } +} +mp->log_opened=false; + +@ @<Dealloc variables@>= +xfree(mp->job_name); + +@ Here is a routine that manufactures the output file names, assuming that +|job_name<>0|. It ignores and changes the current settings of |cur_area| +and |cur_ext|. + +@d pack_cur_name mp_pack_file_name(mp, mp->cur_name,mp->cur_area,mp->cur_ext) + +@<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) { + print_err("I can\'t find file `"); +@.I can't find file x@> + } else { + print_err("I can\'t write on file `"); +@.I can't write on file x@> + } + mp_print_file_name(mp, mp->cur_name,mp->cur_area,mp->cur_ext); + mp_print(mp, "'."); + if (strcmp(e,"")==0) + mp_show_context(mp); + mp_print_nl(mp, "Please type another "); mp_print(mp, s); +@.Please type...@> + if (mp->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 */ + old_setting=mp->selector; + if ( mp->job_name==NULL ) { + mp->job_name=xstrdup("mpout"); + } + mp_pack_job_name(mp,".log"); + while ( ! mp_a_open_out(mp, &mp->log_file, mp_filetype_log) ) { + @<Try to get a different log file name@>; + } + mp->log_name=xstrdup(mp->name_of_file); + mp->selector=log_only; mp->log_opened=true; + @<Print the banner line, including the date and time@>; + mp->input_stack[mp->input_ptr]=mp->cur_input; + /* make sure bottom level is in memory */ + if (!mp->noninteractive) { + mp_print_nl(mp, "**"); +@.**@> + l=mp->input_stack[0].limit_field-1; /* last position of first line */ + for (k=0;k<=l;k++) mp_print_str(mp, mp->buffer[k]); + mp_print_ln(mp); /* now the transcript file contains the first line of input */ + } + mp->selector=old_setting+2; /* |log_only| or |term_and_log| */ +} + +@ @<Dealloc variables@>= +xfree(mp->log_name); + +@ Sometimes |open_log_file| is called at awkward moments when \MP\ is +unable to print error messages or even to |show_context|. +The |prompt_file_name| routine can result in a |fatal_error|, but the |error| +routine will not be invoked because |log_opened| will be false. + +The normal idea of |mp_batch_mode| is that nothing at all should be written +on the terminal. However, in the unusual case that +no log file could be opened, we make an exception and allow +an explanatory message to be seen. + +Incidentally, the program always refers to the log file as a `\.{transcript +file}', because some systems cannot use the extension `\.{.log}' for +this file. + +@<Try to get a different log file name@>= +{ + mp->selector=term_only; + mp_prompt_file_name(mp, "transcript file name",".log"); +} + +@ @<Print the banner...@>= +{ + wlog(mp->banner); + mp_print(mp, mp->mem_ident); mp_print(mp, " "); + mp_print_int(mp, mp_round_unscaled(mp, mp->internal[mp_day])); + mp_print_char(mp, xord(' ')); + m=mp_round_unscaled(mp, mp->internal[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, mp_round_unscaled(mp, mp->internal[mp_year])); + mp_print_char(mp, xord(' ')); + m=mp_round_unscaled(mp, mp->internal[mp_time]); + mp_print_dd(mp, m / 60); mp_print_char(mp, xord(':')); mp_print_dd(mp, m % 60); +} + +@ The |try_extension| function tries to open an input file determined by +|cur_name|, |cur_area|, and the argument |ext|. It returns |false| if it +can't find the file in |cur_area| or the appropriate system area. + +@c +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); + if ( mp_a_open_in(mp, &cur_file, mp_filetype_program) ) { + return true; + } else { + mp_pack_file_name(mp, mp->cur_name,NULL,ext); + return mp_a_open_in(mp, &cur_file, mp_filetype_program); + } +} + +@ Let's turn now to the procedure that is used to initiate file reading +when an `\.{input}' command is being processed. + +@c void mp_start_input (MP mp) { /* \MP\ will \.{input} something */ + char *fname = NULL; + @<Put the desired file name in |(cur_name,cur_ext,cur_area)|@>; + while (1) { + mp_begin_file_reading(mp); /* set up |cur_file| and new level of input */ + if ( strlen(mp->cur_ext)==0 ) { + if ( mp_try_extension(mp, ".mp") ) break; + else if ( mp_try_extension(mp, "") ) break; + else if ( mp_try_extension(mp, ".mf") ) break; + /* |else do_nothing; | */ + } else if ( mp_try_extension(mp, mp->cur_ext) ) { + break; + } + mp_end_file_reading(mp); /* remove the level that didn't work */ + mp_prompt_file_name(mp, "input file name",""); + } + name=mp_a_make_name_string(mp, cur_file); + fname = xstrdup(mp->name_of_file); + if ( mp->job_name==NULL ) { + mp->job_name=xstrdup(mp->cur_name); + mp_open_log_file(mp); + } /* |open_log_file| doesn't |show_context|, so |limit| + and |loc| needn't be set to meaningful values yet */ + if ( ((int)mp->term_offset+(int)strlen(fname)) > (mp->max_print_line-2)) mp_print_ln(mp); + else if ( (mp->term_offset>0)||(mp->file_offset>0) ) mp_print_char(mp, 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 |a_make_name_string| returns something other +than just a copy of its argument and the full file name is needed for opening +\.{MPX} files or implementing the switch-to-editor option. +@^system dependencies@> + +@<Flush |name| and replace it with |cur_name| if it won't be needed@>= +mp_flush_string(mp, name); name=rts(mp->cur_name); xfree(mp->cur_name) + +@ If the file is empty, it is considered to contain a single blank line, +so there is no need to test the return value. + +@<Read the first line...@>= +{ + line=1; + (void)mp_input_ln(mp, cur_file ); + mp_firm_up_the_line(mp); + mp->buffer[limit]=xord('%'); mp->first=(size_t)(limit+1); loc=start; +} + +@ @<Put the desired file name in |(cur_name,cur_ext,cur_area)|@>= +while ( token_state &&(loc==null) ) mp_end_token_list(mp); +if ( token_state ) { + print_err("File names can't appear within macros"); +@.File names can't...@> + help3("Sorry...I've converted what follows to tokens,", + "possibly garbaging the name you gave.", + "Please delete the tokens and insert the name again."); + mp_error(mp); +} +if ( file_state ) { + mp_scan_file_name(mp); +} else { + xfree(mp->cur_name); mp->cur_name=xstrdup(""); + xfree(mp->cur_ext); mp->cur_ext =xstrdup(""); + xfree(mp->cur_area); mp->cur_area=xstrdup(""); +} + +@ The following simple routine starts reading the \.{MPX} file associated +with the current input file. + +@c void mp_start_mpx_input (MP mp) { + char *origname = NULL; /* a copy of nameoffile */ + mp_pack_file_name(mp, in_name, in_area, ".mpx"); + @<Try to make sure |name_of_file| refers to a valid \.{MPX} file and + |goto not_found| if there is a problem@>; + mp_begin_file_reading(mp); + if ( ! mp_a_open_in(mp, &cur_file, mp_filetype_program) ) { + mp_end_file_reading(mp); + goto NOT_FOUND; + } + name=mp_a_make_name_string(mp, cur_file); + mp->mpx_name[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; +} + +@ @<Try to make sure |name_of_file| refers to a valid \.{MPX} file and + |goto not_found| if there is a problem@>= +origname = mp_xstrdup(mp,mp->name_of_file); +*(origname+strlen(origname)-1)=0; /* drop the x */ +if (!(mp->run_make_mpx)(mp, origname, mp->name_of_file)) + goto NOT_FOUND + +@ @<Explain that the \.{MPX} file can't be read and |succumb|@>= +if ( mp->interaction==mp_error_stop_mode ) wake_up_terminal; +mp_print_nl(mp, ">> "); +mp_print(mp, origname); +mp_print_nl(mp, ">> "); +mp_print(mp, mp->name_of_file); +mp_print_nl(mp, "! Unable to make mpx file"); +help4("The two files given above are one of your source files", + "and an auxiliary file I need to read to find out what your", + "btex..etex blocks mean. If you don't know why I had trouble,", + "try running it manually through MPtoTeX, TeX, and DVItoMP"); +succumb; + +@ The last file-opening commands are for files accessed via the \&{readfrom} +@:read_from_}{\&{readfrom} primitive@> +operator and the \&{write} command. Such files are stored in separate arrays. +@:write_}{\&{write} primitive@> + +@<Types in the outer block@>= +typedef unsigned int readf_index; /* |0..max_read_files| */ +typedef unsigned int write_index; /* |0..max_write_files| */ + +@ @<Glob...@>= +readf_index max_read_files; /* maximum number of simultaneously open \&{readfrom} files */ +void ** rd_file; /* \&{readfrom} files */ +char ** rd_fname; /* corresponding file name or 0 if file not open */ +readf_index read_files; /* number of valid entries in the above arrays */ +write_index max_write_files; /* maximum number of simultaneously open \&{write} */ +void ** wr_file; /* \&{write} files */ +char ** wr_fname; /* corresponding file name or 0 if file not open */ +write_index write_files; /* number of valid entries in the above arrays */ + +@ @<Allocate or initialize ...@>= +mp->max_read_files=8; +mp->rd_file = xmalloc((mp->max_read_files+1),sizeof(void *)); +mp->rd_fname = xmalloc((mp->max_read_files+1),sizeof(char *)); +memset(mp->rd_fname, 0, sizeof(char *)*(mp->max_read_files+1)); +mp->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_a_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_a_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); +} + + +@* \[36] Introduction to the parsing routines. +We come now to the central nervous system that sparks many of \MP's activities. +By evaluating expressions, from their primary constituents to ever larger +subexpressions, \MP\ builds the structures that ultimately define complete +pictures or fonts of type. + +Four mutually recursive subroutines are involved in this process: We call them +$$\hbox{|scan_primary|, |scan_secondary|, |scan_tertiary|, +and |scan_expression|.}$$ +@^recursion@> +Each of them is parameterless and begins with the first token to be scanned +already represented in |cur_cmd|, |cur_mod|, and |cur_sym|. After execution, +the value of the primary or secondary or tertiary or expression that was +found will appear in the global variables |cur_type| and |cur_exp|. The +token following the expression will be represented in |cur_cmd|, |cur_mod|, +and |cur_sym|. + +Technically speaking, the parsing algorithms are ``LL(1),'' more or less; +backup mechanisms have been added in order to provide reasonable error +recovery. + +@<Glob...@>= +quarterword cur_type; /* the type of the expression just found */ +integer cur_exp; /* the value of the expression just found */ + +@ @<Set init...@>= +mp->cur_exp=0; + +@ Many different kinds of expressions are possible, so it is wise to have +precise descriptions of what |cur_type| and |cur_exp| mean in all cases: + +\smallskip\hang +|cur_type=mp_vacuous| means that this expression didn't turn out to have a +value at all, because it arose from a \&{begingroup}$\,\ldots\,$\&{endgroup} +construction in which there was no expression before the \&{endgroup}. +In this case |cur_exp| has some irrelevant value. + +\smallskip\hang +|cur_type=mp_boolean_type| means that |cur_exp| is either |true_code| +or |false_code|. + +\smallskip\hang +|cur_type=mp_unknown_boolean| means that |cur_exp| points to a capsule +node that is in +a ring of equivalent booleans whose value has not yet been defined. + +\smallskip\hang +|cur_type=mp_string_type| means that |cur_exp| is a string number (i.e., an +integer in the range |0<=cur_exp<str_ptr|). That string's reference count +includes this particular reference. + +\smallskip\hang +|cur_type=mp_unknown_string| means that |cur_exp| points to a capsule +node that is in +a ring of equivalent strings whose value has not yet been defined. + +\smallskip\hang +|cur_type=mp_pen_type| means that |cur_exp| points to a node in a pen. Nobody +else points to any of the nodes in this pen. The pen may be polygonal or +elliptical. + +\smallskip\hang +|cur_type=mp_unknown_pen| means that |cur_exp| points to a capsule +node that is in +a ring of equivalent pens whose value has not yet been defined. + +\smallskip\hang +|cur_type=mp_path_type| means that |cur_exp| points to a the first node of +a path; nobody else points to this particular path. The control points of +the path will have been chosen. + +\smallskip\hang +|cur_type=mp_unknown_path| means that |cur_exp| points to a capsule +node that is in +a ring of equivalent paths whose value has not yet been defined. + +\smallskip\hang +|cur_type=mp_picture_type| means that |cur_exp| points to an edge header node. +There may be other pointers to this particular set of edges. The header node +contains a reference count that includes this particular reference. + +\smallskip\hang +|cur_type=mp_unknown_picture| means that |cur_exp| points to a capsule +node that is in +a ring of equivalent pictures whose value has not yet been defined. + +\smallskip\hang +|cur_type=mp_transform_type| means that |cur_exp| points to a |mp_transform_type| +capsule node. The |value| part of this capsule +points to a transform node that contains six numeric values, +each of which is |independent|, |dependent|, |mp_proto_dependent|, or |known|. + +\smallskip\hang +|cur_type=mp_color_type| means that |cur_exp| points to a |color_type| +capsule node. The |value| part of this capsule +points to a color node that contains three numeric values, +each of which is |independent|, |dependent|, |mp_proto_dependent|, or |known|. + +\smallskip\hang +|cur_type=mp_cmykcolor_type| means that |cur_exp| points to a |mp_cmykcolor_type| +capsule node. The |value| part of this capsule +points to a color node that contains four numeric values, +each of which is |independent|, |dependent|, |mp_proto_dependent|, or |known|. + +\smallskip\hang +|cur_type=mp_pair_type| means that |cur_exp| points to a capsule +node whose type is |mp_pair_type|. The |value| part of this capsule +points to a pair node that contains two numeric values, +each of which is |independent|, |dependent|, |mp_proto_dependent|, or |known|. + +\smallskip\hang +|cur_type=mp_known| means that |cur_exp| is a |scaled| value. + +\smallskip\hang +|cur_type=mp_dependent| means that |cur_exp| points to a capsule node whose type +is |dependent|. The |dep_list| field in this capsule points to the associated +dependency list. + +\smallskip\hang +|cur_type=mp_proto_dependent| means that |cur_exp| points to a |mp_proto_dependent| +capsule node. The |dep_list| field in this capsule +points to the associated dependency list. + +\smallskip\hang +|cur_type=independent| means that |cur_exp| points to a capsule node +whose type is |independent|. This somewhat unusual case can arise, for +example, in the expression +`$x+\&{begingroup}\penalty0\,\&{string}\,x; 0\,\&{endgroup}$'. + +\smallskip\hang +|cur_type=mp_token_list| means that |cur_exp| points to a linked list of +tokens. + +\smallskip\noindent +The possible settings of |cur_type| have been listed here in increasing +numerical order. Notice that |cur_type| will never be |mp_numeric_type| or +|suffixed_macro| or |mp_unsuffixed_macro|, although variables of those types +are allowed. Conversely, \MP\ has no variables of type |mp_vacuous| or +|token_list|. + +@ Capsules are two-word nodes that have a similar meaning +to |cur_type| and |cur_exp|. Such nodes have |name_type=capsule|, +and their |type| field is one of the possibilities for |cur_type| listed above. +Also |link<=void| in capsules that aren't part of a token list. + +The |value| field of a capsule is, in most cases, the value that +corresponds to its |type|, as |cur_exp| corresponds to |cur_type|. +However, when |cur_exp| would point to a capsule, +no extra layer of indirection is present; the |value| +field is what would have been called |value(cur_exp)| if it had not been +encapsulated. Furthermore, if the type is |dependent| or +|mp_proto_dependent|, the |value| field of a capsule is replaced by +|dep_list| and |prev_dep| fields, since dependency lists in capsules are +always part of the general |dep_list| structure. + +The |get_x_next| routine is careful not to change the values of |cur_type| +and |cur_exp| when it gets an expanded token. However, |get_x_next| might +call a macro, which might parse an expression, which might execute lots of +commands in a group; hence it's possible that |cur_type| might change +from, say, |mp_unknown_boolean| to |mp_boolean_type|, or from |dependent| to +|known| or |independent|, during the time |get_x_next| is called. The +programs below are careful to stash sensitive intermediate results in +capsules, so that \MP's generality doesn't cause trouble. + +Here's a procedure that illustrates these conventions. It takes +the contents of $(|cur_type|\kern-.3pt,|cur_exp|\kern-.3pt)$ +and stashes them away in a +capsule. It is not used when |cur_type=mp_token_list|. +After the operation, |cur_type=mp_vacuous|; hence there is no need to +copy path lists or to update reference counts, etc. + +The special link |mp_void| is put on the capsule returned by +|stash_cur_exp|, because this procedure is used to store macro parameters +that must be easily distinguishable from token lists. + +@<Declare the stashing/unstashing routines@>= +static pointer mp_stash_cur_exp (MP mp) { + pointer p; /* the capsule that will be returned */ + switch (mp->cur_type) { + case unknown_types: + case mp_transform_type: + case mp_color_type: + case mp_pair_type: + case mp_dependent: + case mp_proto_dependent: + case mp_independent: + case mp_cmykcolor_type: + p=mp->cur_exp; + break; + default: + p=mp_get_node(mp, value_node_size); mp_name_type(p)=mp_capsule; + mp_type(p)=mp->cur_type; value(p)=mp->cur_exp; + break; + } + mp->cur_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,pointer p) ; + +@ @c +void mp_unstash_cur_exp (MP mp,pointer p) { + mp->cur_type=mp_type(p); + switch (mp->cur_type) { + case unknown_types: + case mp_transform_type: + case mp_color_type: + case mp_pair_type: + case mp_dependent: + case mp_proto_dependent: + case mp_independent: + case mp_cmykcolor_type: + mp->cur_exp=p; + break; + default: + mp->cur_exp=value(p); + mp_free_node(mp, p,value_node_size); + break; + } +} + +@ The following procedure prints the values of expressions in an +abbreviated format. If its first parameter |p| is null, the value of +|(cur_type,cur_exp)| is displayed; otherwise |p| should be a capsule +containing the desired value. The second parameter controls the amount of +output. If it is~0, dependency lists will be abbreviated to +`\.{linearform}' unless they consist of a single term. If it is greater +than~1, complicated structures (pens, pictures, and paths) will be displayed +in full. +@.linearform@> + +@<Declarations@>= +@<Declare the procedure called |print_dp|@> +@<Declare the stashing/unstashing routines@> +static void mp_print_exp (MP mp,pointer p, quarterword verbosity) ; + +@ @c +void mp_print_exp (MP mp,pointer p, quarterword verbosity) { + boolean restore_cur_exp; /* should |cur_exp| be restored? */ + quarterword t; /* the type of the expression */ + pointer q; /* a big node being displayed */ + integer v=0; /* the value of the expression */ + if ( p!=null ) { + restore_cur_exp=false; + } else { + p=mp_stash_cur_exp(mp); restore_cur_exp=true; + } + t=mp_type(p); + if ( t<mp_dependent ) v=value(p); else if ( t<mp_independent ) v=dep_list(p); + @<Print an abbreviated value of |v| with format depending on |t|@>; + if ( restore_cur_exp ) mp_unstash_cur_exp(mp, p); +} + +@ @<Print an abbreviated value of |v| with format depending on |t|@>= +switch (t) { +case mp_vacuous:mp_print(mp, "mp_vacuous"); break; +case mp_boolean_type: + if ( v==true_code ) mp_print(mp, "true"); else mp_print(mp, "false"); + break; +case unknown_types: case mp_numeric_type: + @<Display a variable that's been declared but not defined@>; + break; +case mp_string_type: + mp_print_char(mp, xord('"')); mp_print_str(mp, v); 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: case mp_color_type: case mp_pair_type: case mp_cmykcolor_type: + if ( v==null ) mp_print_type(mp, t); + else @<Display a big node@>; + break; +case mp_known:mp_print_scaled(mp, v); break; +case mp_dependent: case mp_proto_dependent: + mp_print_dp(mp, t,v,verbosity); + break; +case mp_independent:mp_print_variable_name(mp, p); break; +default: mp_confusion(mp, "exp"); break; +@:this can't happen exp}{\quad exp@> +} + +@ @<Display a big node@>= +{ + mp_print_char(mp, xord('(')); q=v+mp->big_node_size[t]; + do { + if ( mp_type(v)==mp_known ) mp_print_scaled(mp, value(v)); + else if ( mp_type(v)==mp_independent ) mp_print_variable_name(mp, v); + else mp_print_dp(mp, mp_type(v),dep_list(v),verbosity); + v=v+2; + if ( v!=q ) mp_print_char(mp, xord(',')); + } while (v!=q); + 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 ( mp->internal[mp_tracing_online]<=0 ) { + mp->selector=term_only; + mp_print_type(mp, t); mp_print(mp, " (see the transcript file)"); + mp->selector=term_and_log; + }; + switch (t) { + case mp_pen_type:mp_print_pen(mp, v,"",false); break; + case mp_path_type:mp_print_path(mp, v,"",false); break; + case mp_picture_type:mp_print_edges(mp, v,"",false); break; + } /* there are no other cases */ +} + +@ @<Declare the procedure called |print_dp|@>= +static void mp_print_dp (MP mp, quarterword t, pointer p, + quarterword verbosity) { + pointer q; /* the node following |p| */ + q=mp_link(p); + if ( (mp_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(v); + mp_print_variable_name(mp, v); + }; +} + +@ When errors are detected during parsing, it is often helpful to +display an expression just above the error message, using |exp_err| +or |disp_err| instead of |print_err|. + +@d exp_err(A) mp_disp_err(mp, null,(A)) /* displays the current expression */ + +@<Declarations@>= +static void mp_disp_err (MP mp,pointer p, const char *s) ; + +@ @c +void mp_disp_err (MP mp,pointer p, const char *s) { + if ( mp->interaction==mp_error_stop_mode ) wake_up_terminal; + mp_print_nl(mp, ">> "); +@.>>@> + mp_print_exp(mp, p,1); /* ``medium verbose'' printing of the expression */ + if (strlen(s)>0) { + print_err(s); + } +} + +@ 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 +static void mp_flush_cur_exp (MP mp,scaled v) { + switch (mp->cur_type) { + case unknown_types: case mp_transform_type: case mp_color_type: case mp_pair_type: + case mp_dependent: case mp_proto_dependent: case mp_independent: case mp_cmykcolor_type: + mp_recycle_value(mp, mp->cur_exp); + mp_free_node(mp, mp->cur_exp,value_node_size); + break; + case mp_string_type: + delete_str_ref(mp->cur_exp); break; + case mp_pen_type: case mp_path_type: + mp_toss_knot_list(mp, mp->cur_exp); break; + case mp_picture_type: + delete_edge_ref(mp->cur_exp); break; + default: + break; + } + mp->cur_type=mp_known; mp->cur_exp=v; +} + +@ There's a much more general procedure that is capable of releasing +the storage associated with any two-word value packet. + +@<Declarations@>= +static void mp_recycle_value (MP mp,pointer p) ; + +@ @c +static void mp_recycle_value (MP mp,pointer p) { + quarterword t; /* a type code */ + integer vv; /* another value */ + pointer q,r,s,pp; /* link manipulation registers */ + integer v=0; /* a value */ + t=mp_type(p); + if ( t<mp_dependent ) v=value(p); + switch (t) { + case undefined: case mp_vacuous: case mp_boolean_type: case mp_known: + case mp_numeric_type: + break; + case unknown_types: + mp_ring_delete(mp, p); break; + case mp_string_type: + delete_str_ref(v); break; + case mp_path_type: case mp_pen_type: + mp_toss_knot_list(mp, v); break; + case mp_picture_type: + delete_edge_ref(v); break; + case mp_cmykcolor_type: case mp_pair_type: case mp_color_type: + case mp_transform_type: + @<Recycle a big node@>; break; + case mp_dependent: case mp_proto_dependent: + @<Recycle a dependency list@>; break; + case mp_independent: + @<Recycle an independent variable@>; break; + case mp_token_list: case mp_structured: + mp_confusion(mp, "recycle"); break; +@:this can't happen recycle}{\quad recycle@> + case mp_unsuffixed_macro: case mp_suffixed_macro: + mp_delete_mac_ref(mp, value(p)); break; + } /* there are no other cases */ + mp_type(p)=undefined; +} + +@ @<Recycle a big node@>= +if ( v!=null ){ + q=v+mp->big_node_size[t]; + do { + q=q-2; mp_recycle_value(mp, q); + } while (q!=v); + mp_free_node(mp, v,mp->big_node_size[t]); +} + +@ @<Recycle a dependency list@>= +{ + q=dep_list(p); + while ( mp_info(q)!=null ) q=mp_link(q); + mp_link(prev_dep(p))=mp_link(q); + prev_dep(mp_link(q))=prev_dep(p); + mp_link(q)=null; mp_flush_node_list(mp, dep_list(p)); +} + +@ When an independent variable disappears, it simply fades away, unless +something depends on it. In the latter case, a dependent variable whose +coefficient of dependence is maximal will take its place. +The relevant algorithm is due to Ignacio~A. Zabala, who implemented it +as part of his Ph.D. thesis (Stanford University, December 1982). +@^Zabala Salelles, Ignacio Andr\'es@> + +For example, suppose that variable $x$ is being recycled, and that the +only variables depending on~$x$ are $y=2x+a$ and $z=x+b$. In this case +we want to make $y$ independent and $z=.5y-.5a+b$; no other variables +will depend on~$y$. If $\\{tracingequations}>0$ in this situation, +we will print `\.{\#\#\# -2x=-y+a}'. + +There's a slight complication, however: An independent variable $x$ +can occur both in dependency lists and in proto-dependency lists. +This makes it necessary to be careful when deciding which coefficient +is maximal. + +Furthermore, this complication is not so slight when +a proto-dependent variable is chosen to become independent. For example, +suppose that $y=2x+100a$ is proto-dependent while $z=x+b$ is dependent; +then we must change $z=.5y-50a+b$ to a proto-dependency, because of the +large coefficient `50'. + +In order to deal with these complications without wasting too much time, +we shall link together the occurrences of~$x$ among all the linear +dependencies, maintaining separate lists for the dependent and +proto-dependent cases. + +@<Recycle an independent variable@>= +{ + mp->max_c[mp_dependent]=0; mp->max_c[mp_proto_dependent]=0; + mp->max_link[mp_dependent]=null; mp->max_link[mp_proto_dependent]=null; + q=mp_link(dep_head); + while ( q!=dep_head ) { + s=value_loc(q); /* now |mp_link(s)=dep_list(q)| */ + while (1) { + r=mp_link(s); + if ( mp_info(r)==null ) break; + if ( mp_info(r)!=p ) { + s=r; + } else { + t=mp_type(q); mp_link(s)=mp_link(r); mp_info(r)=q; + if ( abs(value(r))>mp->max_c[t] ) { + @<Record a new maximum coefficient of type |t|@>; + } else { + mp_link(r)=mp->max_link[t]; mp->max_link[t]=r; + } + } + } + q=mp_link(r); + } + if ( (mp->max_c[mp_dependent]>0)||(mp->max_c[mp_proto_dependent]>0) ) { + @<Choose a dependent variable to take the place of the disappearing + independent variable, and change all remaining dependencies + accordingly@>; + } +} + +@ The code for independency removal makes use of three two-word arrays. + +@<Glob...@>= +integer max_c[mp_proto_dependent+1]; /* max coefficient magnitude */ +pointer max_ptr[mp_proto_dependent+1]; /* where |p| occurs with |max_c| */ +pointer max_link[mp_proto_dependent+1]; /* other occurrences of |p| */ + +@ @<Record a new maximum coefficient...@>= +{ + if ( mp->max_c[t]>0 ) { + mp_link(mp->max_ptr[t])=mp->max_link[t]; mp->max_link[t]=mp->max_ptr[t]; + } + mp->max_c[t]=abs(value(r)); mp->max_ptr[t]=r; +} + +@ @<Choose a dependent...@>= +{ + if ( (mp->max_c[mp_dependent] / 010000) >= mp->max_c[mp_proto_dependent] ) + t=mp_dependent; + else + t=mp_proto_dependent; + @<Determine the dependency list |s| to substitute for the independent + variable~|p|@>; + t=mp_dependent+mp_proto_dependent-t; /* complement |t| */ + if ( mp->max_c[t]>0 ) { /* we need to pick up an unchosen dependency */ + mp_link(mp->max_ptr[t])=mp->max_link[t]; mp->max_link[t]=mp->max_ptr[t]; + } + if ( t!=mp_dependent ) { @<Substitute new dependencies in place of |p|@>; } + else { @<Substitute new proto-dependencies in place of |p|@>;} + mp_flush_node_list(mp, s); + if ( mp->fix_needed ) mp_fix_dependencies(mp); + check_arith; +} + +@ Let |s=max_ptr[t]|. At this point we have $|value|(s)=\pm|max_c|[t]$, +and |mp_info(s)| points to the dependent variable~|pp| of type~|t| from +whose dependency list we have removed node~|s|. We must reinsert +node~|s| into the dependency list, with coefficient $-1.0$, and with +|pp| as the new independent variable. Since |pp| will have a larger serial +number than any other variable, we can put node |s| at the head of the +list. + +@<Determine the dep...@>= +s=mp->max_ptr[t]; pp=mp_info(s); v=value(s); +if ( t==mp_dependent ) value(s)=-fraction_one; else value(s)=-unity; +r=dep_list(pp); mp_link(s)=r; +while ( mp_info(r)!=null ) r=mp_link(r); +q=mp_link(r); mp_link(r)=null; +prev_dep(q)=prev_dep(pp); mp_link(prev_dep(pp))=q; +new_indep(pp); +if ( mp->cur_exp==pp ) if ( mp->cur_type==t ) mp->cur_type=mp_independent; +if ( mp->internal[mp_tracing_equations]>0 ) { + @<Show the transformed dependency@>; +} + +@ Now $(-v)$ times the formerly independent variable~|p| is being replaced +by the dependency list~|s|. + +@<Show the transformed...@>= +if ( mp_interesting(mp, p) ) { + mp_begin_diagnostic(mp); mp_print_nl(mp, "### "); +@:]]]\#\#\#_}{\.{\#\#\#}@> + if ( v>0 ) mp_print_char(mp, xord('-')); + if ( t==mp_dependent ) vv=mp_round_fraction(mp, mp->max_c[mp_dependent]); + else vv=mp->max_c[mp_proto_dependent]; + if ( vv!=unity ) mp_print_scaled(mp, vv); + mp_print_variable_name(mp, p); + while ( value(p) % s_scale>0 ) { + mp_print(mp, "*4"); value(p)=value(p)-2; + } + if ( t==mp_dependent ) mp_print_char(mp, xord('=')); else mp_print(mp, " = "); + mp_print_dependency(mp, s,t); + mp_end_diagnostic(mp, false); +} + +@ Finally, there are dependent and proto-dependent variables whose +dependency lists must be brought up to date. + +@<Substitute new dependencies...@>= +for (t=mp_dependent;t<=mp_proto_dependent;t++){ + r=mp->max_link[t]; + while ( r!=null ) { + q=mp_info(r); + dep_list(q)=mp_p_plus_fq(mp, dep_list(q), + mp_make_fraction(mp, value(r),-v),s,t,mp_dependent); + if ( dep_list(q)==mp->dep_final ) mp_make_known(mp, q,mp->dep_final); + q=r; r=mp_link(r); mp_free_node(mp, q,dep_node_size); + } +} + +@ @<Substitute new proto...@>= +for (t=mp_dependent;t<=mp_proto_dependent;t++) { + r=mp->max_link[t]; + while ( r!=null ) { + q=mp_info(r); + if ( t==mp_dependent ) { /* for safety's sake, we change |q| to |mp_proto_dependent| */ + if ( mp->cur_exp==q ) if ( mp->cur_type==mp_dependent ) + mp->cur_type=mp_proto_dependent; + dep_list(q)=mp_p_over_v(mp, dep_list(q),unity, + mp_dependent,mp_proto_dependent); + mp_type(q)=mp_proto_dependent; + value(r)=mp_round_fraction(mp, value(r)); + } + dep_list(q)=mp_p_plus_fq(mp, dep_list(q), + mp_make_scaled(mp, value(r),-v),s, + mp_proto_dependent,mp_proto_dependent); + if ( dep_list(q)==mp->dep_final ) + mp_make_known(mp, q,mp->dep_final); + q=r; r=mp_link(r); mp_free_node(mp, q,dep_node_size); + } +} + +@ Here are some routines that provide handy combinations of actions +that are often needed during error recovery. For example, +`|flush_error|' flushes the current expression, replaces it by +a given value, and calls |error|. + +Errors often are detected after an extra token has already been scanned. +The `\\{put\_get}' routines put that token back before calling |error|; +then they get it back again. (Or perhaps they get another token, if +the user has changed things.) + +@<Declarations@>= +static void mp_flush_error (MP mp,scaled v); +static void mp_put_get_error (MP mp); +static void mp_put_get_flush_error (MP mp,scaled v) ; + +@ @c +void mp_flush_error (MP mp,scaled v) { + mp_error(mp); mp_flush_cur_exp(mp, v); +} +void mp_put_get_error (MP mp) { + mp_back_error(mp); mp_get_x_next(mp); +} +void mp_put_get_flush_error (MP mp,scaled v) { + mp_put_get_error(mp); + mp_flush_cur_exp(mp, v); +} + +@ A global variable |var_flag| is set to a special command code +just before \MP\ calls |scan_expression|, if the expression should be +treated as a variable when this command code immediately follows. For +example, |var_flag| is set to |assignment| at the beginning of a +statement, because we want to know the {\sl location\/} of a variable at +the left of `\.{:=}', not the {\sl value\/} of that variable. + +The |scan_expression| subroutine calls |scan_tertiary|, +which calls |scan_secondary|, which calls |scan_primary|, which sets +|var_flag:=0|. In this way each of the scanning routines ``knows'' +when it has been called with a special |var_flag|, but |var_flag| is +usually zero. + +A variable preceding a command that equals |var_flag| is converted to a +token list rather than a value. Furthermore, an `\.{=}' sign following an +expression with |var_flag=assignment| is not considered to be a relation +that produces boolean expressions. + + +@<Glob...@>= +int var_flag; /* command that wants a variable */ + +@ @<Set init...@>= +mp->var_flag=0; + +@* \[37] Parsing primary expressions. +The first parsing routine, |scan_primary|, is also the most complicated one, +since it involves so many different cases. But each case---with one +exception---is fairly simple by itself. + +When |scan_primary| begins, the first token of the primary to be scanned +should already appear in |cur_cmd|, |cur_mod|, and |cur_sym|. The values +of |cur_type| and |cur_exp| should be either dead or dormant, as explained +earlier. If |cur_cmd| is not between |min_primary_command| and +|max_primary_command|, inclusive, a syntax error will be signaled. + +@<Declare the basic parsing subroutines@>= +void mp_scan_primary (MP mp) { + pointer p,q,r; /* for list manipulation */ + quarterword c; /* a primitive operation code */ + int my_var_flag; /* initial value of |my_var_flag| */ + pointer l_delim,r_delim; /* hash addresses of a delimiter pair */ + @<Other local variables for |scan_primary|@>; + my_var_flag=mp->var_flag; mp->var_flag=0; +RESTART: + check_arith; + @<Supply diagnostic information, if requested@>; + switch (mp->cur_cmd) { + case left_delimiter: + @<Scan a delimited primary@>; break; + case begin_group: + @<Scan a grouped primary@>; break; + case string_token: + @<Scan a string constant@>; break; + case numeric_token: + @<Scan a primary that starts with a numeric token@>; break; + case nullary: + @<Scan a nullary operation@>; break; + case unary: case type_name: case cycle: case plus_or_minus: + @<Scan a unary operation@>; break; + case primary_binary: + @<Scan a binary operation with `\&{of}' between its operands@>; break; + case str_op: + @<Convert a suffix to a string@>; break; + case internal_quantity: + @<Scan an internal numeric quantity@>; break; + case capsule_token: + mp_make_exp_copy(mp, mp->cur_mod); break; + case tag_token: + @<Scan a variable primary; |goto restart| if it turns out to be a macro@>; break; + default: + mp_bad_exp(mp, "A primary"); goto RESTART; break; +@.A primary expression...@> + } + mp_get_x_next(mp); /* the routines |goto done| if they don't want this */ +DONE: + if ( mp->cur_cmd==left_bracket ) { + if ( mp->cur_type>=mp_known ) { + @<Scan a mediation construction@>; + } + } +} + + + +@ Errors at the beginning of expressions are flagged by |bad_exp|. + +@c +static void mp_bad_exp (MP mp, const char * s) { + int save_flag; + print_err(s); mp_print(mp, " expression can't begin with `"); + mp_print_cmd_mod(mp, mp->cur_cmd,mp->cur_mod); + mp_print_char(mp, xord('\'')); + help4("I'm afraid I need some sort of value in order to continue,", + "so I've tentatively inserted `0'. You may want to", + "delete this zero and insert something else;", + "see Chapter 27 of The METAFONTbook for an example."); +@:METAFONTbook}{\sl The {\logos METAFONT\/}book@> + mp_back_input(mp); mp->cur_sym=0; mp->cur_cmd=numeric_token; + mp->cur_mod=0; mp_ins_error(mp); + save_flag=mp->var_flag; mp->var_flag=0; mp_get_x_next(mp); + mp->var_flag=save_flag; +} + +@ @<Supply diagnostic information, if requested@>= +#ifdef DEBUG +if ( mp->panicking ) mp_check_mem(mp, false); +#endif +if ( mp->interrupt!=0 ) if ( mp->OK_to_interrupt ) { + mp_back_input(mp); check_interrupt; mp_get_x_next(mp); +} + +@ @<Scan a delimited primary@>= +{ + l_delim=mp->cur_sym; r_delim=mp->cur_mod; + mp_get_x_next(mp); mp_scan_expression(mp); + if ( (mp->cur_cmd==comma) && (mp->cur_type>=mp_known) ) { + @<Scan the rest of a delimited set of numerics@>; + } else { + mp_check_delimiter(mp, l_delim,r_delim); + } +} + +@ The |stash_in| subroutine puts the current (numeric) expression into a field +within a ``big node.'' + +@c +static void mp_stash_in (MP mp,pointer p) { + pointer q; /* temporary register */ + mp_type(p)=mp->cur_type; + if ( mp->cur_type==mp_known ) { + value(p)=mp->cur_exp; + } else { + if ( mp->cur_type==mp_independent ) { + @<Stash an independent |cur_exp| into a big node@>; + } else { + mp->mem[value_loc(p)]=mp->mem[value_loc(mp->cur_exp)]; + /* |dep_list(p):=dep_list(cur_exp)| and |prev_dep(p):=prev_dep(cur_exp)| */ + mp_link(prev_dep(p))=p; + } + mp_free_node(mp, mp->cur_exp,value_node_size); + } + mp->cur_type=mp_vacuous; +} + +@ In rare cases the current expression can become |independent|. There +may be many dependency lists pointing to such an independent capsule, +so we can't simply move it into place within a big node. Instead, +we copy it, then recycle it. + +@ @<Stash an independent |cur_exp|...@>= +{ + q=mp_single_dependency(mp, mp->cur_exp); + if ( q==mp->dep_final ){ + mp_type(p)=mp_known; value(p)=0; mp_free_node(mp, q,dep_node_size); + } else { + mp_type(p)=mp_dependent; mp_new_dep(mp, p,q); + } + mp_recycle_value(mp, mp->cur_exp); +} + +@ This code uses the fact that |red_part_loc| and |green_part_loc| +are synonymous with |x_part_loc| and |y_part_loc|. + +@<Scan the rest of a delimited set of numerics@>= +{ +p=mp_stash_cur_exp(mp); +mp_get_x_next(mp); mp_scan_expression(mp); +@<Make sure the second part of a pair or color has a numeric type@>; +q=mp_get_node(mp, value_node_size); mp_name_type(q)=mp_capsule; +if ( mp->cur_cmd==comma ) mp_type(q)=mp_color_type; +else mp_type(q)=mp_pair_type; +mp_init_big_node(mp, q); r=value(q); +mp_stash_in(mp, y_part_loc(r)); +mp_unstash_cur_exp(mp, p); +mp_stash_in(mp, x_part_loc(r)); +if ( mp->cur_cmd==comma ) { + @<Scan the last of a triplet of numerics@>; +} +if ( mp->cur_cmd==comma ) { + mp_type(q)=mp_cmykcolor_type; + mp_init_big_node(mp, q); t=value(q); + mp->mem[cyan_part_loc(t)]=mp->mem[red_part_loc(r)]; + value(cyan_part_loc(t))=value(red_part_loc(r)); + mp->mem[magenta_part_loc(t)]=mp->mem[green_part_loc(r)]; + value(magenta_part_loc(t))=value(green_part_loc(r)); + mp->mem[yellow_part_loc(t)]=mp->mem[blue_part_loc(r)]; + value(yellow_part_loc(t))=value(blue_part_loc(r)); + mp_recycle_value(mp, r); + r=t; + @<Scan the last of a quartet of numerics@>; +} +mp_check_delimiter(mp, l_delim,r_delim); +mp->cur_type=mp_type(q); +mp->cur_exp=q; +} + +@ @<Make sure the second part of a pair or color has a numeric type@>= +if ( mp->cur_type<mp_known ) { + exp_err("Nonnumeric ypart has been replaced by 0"); +@.Nonnumeric...replaced by 0@> + help4("I've started to scan a pair `(a,b)' or a color `(a,b,c)';", + "but after finding a nice `a' I found a `b' that isn't", + "of numeric type. So I've changed that part to zero.", + "(The b that I didn't like appears above the error message.)"); + mp_put_get_flush_error(mp, 0); +} + +@ @<Scan the last of a triplet of numerics@>= +{ + mp_get_x_next(mp); mp_scan_expression(mp); + if ( mp->cur_type<mp_known ) { + exp_err("Nonnumeric third part has been replaced by 0"); +@.Nonnumeric...replaced by 0@> + help3("I've just scanned a color `(a,b,c)' or cmykcolor(a,b,c,d); but the `c'", + "isn't of numeric type. So I've changed that part to zero.", + "(The c that I didn't like appears above the error message.)"); + mp_put_get_flush_error(mp, 0); + } + mp_stash_in(mp, blue_part_loc(r)); +} + +@ @<Scan the last of a quartet of numerics@>= +{ + mp_get_x_next(mp); mp_scan_expression(mp); + if ( mp->cur_type<mp_known ) { + exp_err("Nonnumeric blackpart has been replaced by 0"); +@.Nonnumeric...replaced by 0@> + help3("I've just scanned a cmykcolor `(c,m,y,k)'; but the `k' isn't", + "of numeric type. So I've changed that part to zero.", + "(The k that I didn't like appears above the error message.)"); + mp_put_get_flush_error(mp, 0); + } + mp_stash_in(mp, black_part_loc(r)); +} + +@ The local variable |group_line| keeps track of the line +where a \&{begingroup} command occurred; this will be useful +in an error message if the group doesn't actually end. + +@<Other local variables for |scan_primary|@>= +integer group_line; /* where a group began */ + +@ @<Scan a grouped primary@>= +{ + group_line=mp_true_line(mp); + if ( mp->internal[mp_tracing_commands]>0 ) show_cur_cmd_mod; + save_boundary_item(p); + do { + mp_do_statement(mp); /* ends with |cur_cmd>=semicolon| */ + } while (mp->cur_cmd==semicolon); + if ( mp->cur_cmd!=end_group ) { + print_err("A group begun on line "); +@.A group...never ended@> + mp_print_int(mp, group_line); + mp_print(mp, " never ended"); + help2("I saw a `begingroup' back there that hasn't been matched", + "by `endgroup'. So I've inserted `endgroup' now."); + mp_back_error(mp); mp->cur_cmd=end_group; + } + mp_unsave(mp); + /* this might change |cur_type|, if independent variables are recycled */ + if ( mp->internal[mp_tracing_commands]>0 ) show_cur_cmd_mod; +} + +@ @<Scan a string constant@>= +{ + mp->cur_type=mp_string_type; mp->cur_exp=mp->cur_mod; +} + +@ Later we'll come to procedures that perform actual operations like +addition, square root, and so on; our purpose now is to do the parsing. +But we might as well mention those future procedures now, so that the +suspense won't be too bad: + +\smallskip +|do_nullary(c)| does primitive operations that have no operands (e.g., +`\&{true}' or `\&{pencircle}'); + +\smallskip +|do_unary(c)| applies a primitive operation to the current expression; + +\smallskip +|do_binary(p,c)| applies a primitive operation to the capsule~|p| +and the current expression. + +@<Scan a nullary operation@>=mp_do_nullary(mp, mp->cur_mod) + +@ @<Scan a unary operation@>= +{ + c=mp->cur_mod; mp_get_x_next(mp); mp_scan_primary(mp); + mp_do_unary(mp, c); goto DONE; +} + +@ A numeric token might be a primary by itself, or it might be the +numerator of a fraction composed solely of numeric tokens, or it might +multiply the primary that follows (provided that the primary doesn't begin +with a plus sign or a minus sign). The code here uses the facts that +|max_primary_command=plus_or_minus| and +|max_primary_command-1=numeric_token|. If a fraction is found that is less +than unity, we try to retain higher precision when we use it in scalar +multiplication. + +@<Other local variables for |scan_primary|@>= +scaled num,denom; /* for primaries that are fractions, like `1/2' */ + +@ @<Scan a primary that starts with a numeric token@>= +{ + mp->cur_exp=mp->cur_mod; mp->cur_type=mp_known; mp_get_x_next(mp); + if ( mp->cur_cmd!=slash ) { + num=0; denom=0; + } else { + mp_get_x_next(mp); + if ( mp->cur_cmd!=numeric_token ) { + mp_back_input(mp); + mp->cur_cmd=slash; mp->cur_mod=over; mp->cur_sym=frozen_slash; + goto DONE; + } + num=mp->cur_exp; denom=mp->cur_mod; + if ( denom==0 ) { @<Protest division by zero@>; } + else { mp->cur_exp=mp_make_scaled(mp, num,denom); } + check_arith; mp_get_x_next(mp); + } + if ( mp->cur_cmd>=min_primary_command ) { + if ( mp->cur_cmd<numeric_token ) { /* in particular, |cur_cmd<>plus_or_minus| */ + p=mp_stash_cur_exp(mp); mp_scan_primary(mp); + if ( (abs(num)>=abs(denom))||(mp->cur_type<mp_color_type) ) { + mp_do_binary(mp, p,times); + } else { + mp_frac_mult(mp, num,denom); + mp_free_node(mp, p,value_node_size); + } + } + } + goto DONE; +} + +@ @<Protest division...@>= +{ + print_err("Division by zero"); +@.Division by zero@> + help1("I'll pretend that you meant to divide by 1."); mp_error(mp); +} + +@ @<Scan a binary operation with `\&{of}' between its operands@>= +{ + c=mp->cur_mod; mp_get_x_next(mp); mp_scan_expression(mp); + if ( mp->cur_cmd!=of_token ) { + mp_missing_err(mp, "of"); mp_print(mp, " for "); + mp_print_cmd_mod(mp, primary_binary,c); +@.Missing `of'@> + help1("I've got the first argument; will look now for the other."); + mp_back_error(mp); + } + p=mp_stash_cur_exp(mp); mp_get_x_next(mp); mp_scan_primary(mp); + mp_do_binary(mp, p,c); goto DONE; +} + +@ @<Convert a suffix to a string@>= +{ + mp_get_x_next(mp); mp_scan_suffix(mp); + mp->old_setting=mp->selector; mp->selector=new_string; + mp_show_token_list(mp, mp->cur_exp,null,100000,0); + mp_flush_token_list(mp, mp->cur_exp); + mp->cur_exp=mp_make_string(mp); mp->selector=mp->old_setting; + mp->cur_type=mp_string_type; + goto DONE; +} + +@ If an internal quantity appears all by itself on the left of an +assignment, we return a token list of length one, containing the address +of the internal quantity plus |hash_end|. (This accords with the conventions +of the save stack, as described earlier.) + +@<Scan an internal...@>= +{ + q=mp->cur_mod; + if ( my_var_flag==assignment ) { + mp_get_x_next(mp); + if ( mp->cur_cmd==assignment ) { + mp->cur_exp=mp_get_avail(mp); + mp_info(mp->cur_exp)=q+hash_end; mp->cur_type=mp_token_list; + goto DONE; + } + mp_back_input(mp); + } + mp->cur_type=mp_known; mp->cur_exp=mp->internal[q]; + if (q == mp_output_format || q == mp_output_template) + mp->cur_type=mp_string_type; +} + +@ 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. + +@ @<Other local variables for |scan_primary|@>= +pointer pre_head,post_head,tail; + /* prefix and suffix list variables */ +quarterword tt; /* approximation to the type of the variable-so-far */ +pointer t; /* a token */ +pointer macro_ref = 0; /* reference count for a suffixed macro */ + +@ @<Scan a variable primary...@>= +{ + fast_get_avail(pre_head); tail=pre_head; post_head=null; tt=mp_vacuous; + while (1) { + t=mp_cur_tok(mp); mp_link(tail)=t; + if ( tt!=undefined ) { + @<Find the approximate type |tt| and corresponding~|q|@>; + if ( tt>=mp_unsuffixed_macro ) { + @<Either begin an unsuffixed macro call or + prepare for a suffixed one@>; + } + } + mp_get_x_next(mp); tail=t; + if ( mp->cur_cmd==left_bracket ) { + @<Scan for a subscript; replace |cur_cmd| by |numeric_token| if found@>; + } + if ( mp->cur_cmd>max_suffix_token ) break; + if ( mp->cur_cmd<min_suffix_token ) break; + } /* now |cur_cmd| is |internal_quantity|, |tag_token|, or |numeric_token| */ + @<Handle unusual cases that masquerade as variables, and |goto restart| + or |goto done| if appropriate; + otherwise make a copy of the variable and |goto done|@>; +} + +@ @<Either begin an unsuffixed macro call or...@>= +{ + mp_link(tail)=null; + if ( tt>mp_unsuffixed_macro ) { /* |tt=mp_suffixed_macro| */ + post_head=mp_get_avail(mp); tail=post_head; mp_link(tail)=t; + tt=undefined; macro_ref=value(q); add_mac_ref(macro_ref); + } else { + @<Set up unsuffixed macro call and |goto restart|@>; + } +} + +@ @<Scan for a subscript; replace |cur_cmd| by |numeric_token| if found@>= +{ + mp_get_x_next(mp); mp_scan_expression(mp); + if ( mp->cur_cmd!=right_bracket ) { + @<Put the left bracket and the expression back to be rescanned@>; + } else { + if ( mp->cur_type!=mp_known ) mp_bad_subscript(mp); + mp->cur_cmd=numeric_token; mp->cur_mod=mp->cur_exp; mp->cur_sym=0; + } +} + +@ The left bracket that we thought was introducing a subscript might have +actually been the left bracket in a mediation construction like `\.{x[a,b]}'. +So we don't issue an error message at this point; but we do want to back up +so as to avoid any embarrassment about our incorrect assumption. + +@<Put the left bracket and the expression back to be rescanned@>= +{ + mp_back_input(mp); /* that was the token following the current expression */ + mp_back_expr(mp); mp->cur_cmd=left_bracket; + mp->cur_mod=0; mp->cur_sym=frozen_left_bracket; +} + +@ Here's a routine that puts the current expression back to be read again. + +@c +static void mp_back_expr (MP mp) { + pointer 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) { + exp_err("Improper subscript has been replaced by zero"); +@.Improper subscript...@> + help3("A bracketed subscript must have a known numeric value;", + "unfortunately, what I found was the value that appears just", + "above this error message. So I'll try a zero subscript."); + mp_flush_error(mp, 0); +} + +@ Every time we call |get_x_next|, there's a chance that the variable we've +been looking at will disappear. Thus, we cannot safely keep |q| pointing +into the variable structure; we need to start searching from the root each time. + +@<Find the approximate type |tt| and corresponding~|q|@>= +@^inner loop@> +{ + p=mp_link(pre_head); q=mp_info(p); tt=undefined; + if ( eq_type(q) % outer_tag==tag_token ) { + q=equiv(q); + 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 ( p>=mp->hi_mem_min ) { /* it's not a subscript */ + do { q=mp_link(q); } while (! (attr_loc(q)>=mp_info(p))); + if ( attr_loc(q)>mp_info(p) ) goto DONE2; + } + } + } +DONE2: + ; +} + +@ How do things stand now? Well, we have scanned an entire variable name, +including possible subscripts and/or attributes; |cur_cmd|, |cur_mod|, and +|cur_sym| represent the token that follows. If |post_head=null|, a +token list for this variable name starts at |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 prints an error message when a variable +unexpectedly disappears. Its help message isn't quite right for +our present purposes, but we'll be able to fix that up. + +@c +static void mp_obliterated (MP mp,pointer q) { + print_err("Variable "); mp_show_token_list(mp, q,null,1000,0); + mp_print(mp, " has been obliterated"); +@.Variable...obliterated@> + help5("It seems you did a nasty thing---probably by accident,", + "but nevertheless you nearly hornswoggled me...", + "While I was evaluating the right-hand side of this", + "command, something happened, and the left-hand side", + "is no longer a variable! So I won't change anything."); +} + +@ If the variable does exist, we also need to check +for a few other special cases before deciding that a plain old ordinary +variable has, indeed, been scanned. + +@<Handle unusual cases that masquerade as variables...@>= +if ( post_head!=null ) { + @<Set up suffixed macro call and |goto restart|@>; +} +q=mp_link(pre_head); free_avail(pre_head); +if ( mp->cur_cmd==my_var_flag ) { + mp->cur_type=mp_token_list; mp->cur_exp=q; goto DONE; +} +p=mp_find_variable(mp, q); +if ( p!=null ) { + mp_make_exp_copy(mp, p); +} else { + mp_obliterated(mp, q); + mp->help_line[2]="While I was evaluating the suffix of this variable,"; + mp->help_line[1]="something was redefined, and it's no longer a variable!"; + mp->help_line[0]="In order to get back on my feet, I've inserted `0' instead."; + mp_put_get_flush_error(mp, 0); +} +mp_flush_node_list(mp, q); +goto DONE + +@ The only complication associated with macro calling is that the prefix +and ``at'' parameters must be packaged in an appropriate list of lists. + +@<Set up unsuffixed macro call and |goto restart|@>= +{ + p=mp_get_avail(mp); mp_info(pre_head)=mp_link(pre_head); mp_link(pre_head)=p; + mp_info(p)=t; mp_macro_call(mp, value(q),pre_head,null); + mp_get_x_next(mp); + goto RESTART; +} + +@ If the ``variable'' that turned out to be a suffixed macro no longer exists, +we don't care, because we have reserved a pointer (|macro_ref|) to its +token list. + +@<Set up suffixed macro call and |goto restart|@>= +{ + mp_back_input(mp); p=mp_get_avail(mp); q=mp_link(post_head); + mp_info(pre_head)=mp_link(pre_head); mp_link(pre_head)=post_head; + mp_info(post_head)=q; mp_link(post_head)=p; mp_info(p)=mp_link(q); mp_link(q)=null; + mp_macro_call(mp, macro_ref,pre_head,null); decr(ref_count(macro_ref)); + mp_get_x_next(mp); goto RESTART; +} + +@ Our remaining job is simply to make a copy of the value that has been +found. Some cases are harder than others, but complexity arises solely +because of the multiplicity of possible cases. + +@<Declare the procedure called |make_exp_copy|@>= +@<Declare subroutines needed by |make_exp_copy|@> +static void mp_make_exp_copy (MP mp,pointer p) { + pointer q,r,t; /* registers for list manipulation */ +RESTART: + mp->cur_type=mp_type(p); + switch (mp->cur_type) { + case mp_vacuous: case mp_boolean_type: case mp_known: + mp->cur_exp=value(p); break; + case unknown_types: + mp->cur_exp=mp_new_ring_entry(mp, p); + break; + case mp_string_type: + mp->cur_exp=value(p); add_str_ref(mp->cur_exp); + break; + case mp_picture_type: + mp->cur_exp=value(p);add_edge_ref(mp->cur_exp); + break; + case mp_pen_type: + mp->cur_exp=copy_pen(value(p)); + break; + case mp_path_type: + mp->cur_exp=mp_copy_path(mp, value(p)); + break; + case mp_transform_type: case mp_color_type: + case mp_cmykcolor_type: case mp_pair_type: + @<Copy the big node |p|@>; + break; + case mp_dependent: case mp_proto_dependent: + mp_encapsulate(mp, mp_copy_dep_list(mp, dep_list(p))); + break; + case mp_numeric_type: + new_indep(p); goto RESTART; + break; + case mp_independent: + q=mp_single_dependency(mp, p); + if ( q==mp->dep_final ){ + mp->cur_type=mp_known; mp->cur_exp=0; mp_free_node(mp, q,dep_node_size); + } else { + mp->cur_type=mp_dependent; mp_encapsulate(mp, q); + } + break; + default: + mp_confusion(mp, "copy"); +@:this can't happen copy}{\quad copy@> + break; + } +} + +@ The |encapsulate| subroutine assumes that |dep_final| is the +tail of dependency list~|p|. + +@<Declare subroutines needed by |make_exp_copy|@>= +static void mp_encapsulate (MP mp,pointer p) { + mp->cur_exp=mp_get_node(mp, value_node_size); mp_type(mp->cur_exp)=mp->cur_type; + mp_name_type(mp->cur_exp)=mp_capsule; mp_new_dep(mp, mp->cur_exp,p); +} + +@ The most tedious case arises when the user refers to a +\&{pair}, \&{color}, or \&{transform} variable; we must copy several fields, +each of which can be |independent|, |dependent|, |mp_proto_dependent|, +or |known|. + +@<Copy the big node |p|@>= +{ + if ( value(p)==null ) + mp_init_big_node(mp, p); + t=mp_get_node(mp, value_node_size); mp_name_type(t)=mp_capsule; mp_type(t)=mp->cur_type; + mp_init_big_node(mp, t); + q=value(p)+mp->big_node_size[mp->cur_type]; + r=value(t)+mp->big_node_size[mp->cur_type]; + do { + q=q-2; r=r-2; mp_install(mp, r,q); + } while (q!=value(p)); + mp->cur_exp=t; +} + +@ The |install| procedure copies a numeric field~|q| into field~|r| of +a big node that will be part of a capsule. + +@<Declare subroutines needed by |make_exp_copy|@>= +static void mp_install (MP mp,pointer r, pointer q) { + pointer p; /* temporary register */ + if ( mp_type(q)==mp_known ){ + value(r)=value(q); mp_type(r)=mp_known; + } else if ( mp_type(q)==mp_independent ) { + p=mp_single_dependency(mp, q); + if ( p==mp->dep_final ) { + mp_type(r)=mp_known; value(r)=0; mp_free_node(mp, p,dep_node_size); + } else { + mp_type(r)=mp_dependent; mp_new_dep(mp, r,p); + } + } else { + mp_type(r)=mp_type(q); mp_new_dep(mp, r,mp_copy_dep_list(mp, dep_list(q))); + } +} + +@ Expressions of the form `\.{a[b,c]}' are converted into +`\.{b+a*(c-b)}', without checking the types of \.b~or~\.c, +provided that \.a is numeric. + +@<Scan a mediation...@>= +{ + p=mp_stash_cur_exp(mp); mp_get_x_next(mp); mp_scan_expression(mp); + if ( mp->cur_cmd!=comma ) { + @<Put the left bracket and the expression back...@>; + mp_unstash_cur_exp(mp, p); + } else { + q=mp_stash_cur_exp(mp); mp_get_x_next(mp); mp_scan_expression(mp); + if ( mp->cur_cmd!=right_bracket ) { + mp_missing_err(mp, "]"); +@.Missing `]'@> + help3("I've scanned an expression of the form `a[b,c',", + "so a right bracket should have come next.", + "I shall pretend that one was there."); + mp_back_error(mp); + } + r=mp_stash_cur_exp(mp); mp_make_exp_copy(mp, q); + mp_do_binary(mp, r,minus); mp_do_binary(mp, p,times); + mp_do_binary(mp, q,plus); mp_get_x_next(mp); + } +} + +@ Here is a comparatively simple routine that is used to scan the +\&{suffix} parameters of a macro. + +@<Declare the basic parsing subroutines@>= +static void mp_scan_suffix (MP mp) { + pointer h,t; /* head and tail of the list being built */ + pointer p; /* temporary register */ + h=mp_get_avail(mp); t=h; + while (1) { + if ( mp->cur_cmd==left_bracket ) { + @<Scan a bracketed subscript and set |cur_cmd:=numeric_token|@>; + } + if ( mp->cur_cmd==numeric_token ) { + p=mp_new_num_tok(mp, mp->cur_mod); + } else if ((mp->cur_cmd==tag_token)||(mp->cur_cmd==internal_quantity) ) { + p=mp_get_avail(mp); mp_info(p)=mp->cur_sym; + } else { + break; + } + mp_link(t)=p; t=p; mp_get_x_next(mp); + } + mp->cur_exp=mp_link(h); free_avail(h); mp->cur_type=mp_token_list; +} + +@ @<Scan a bracketed subscript and set |cur_cmd:=numeric_token|@>= +{ + mp_get_x_next(mp); mp_scan_expression(mp); + if ( mp->cur_type!=mp_known ) mp_bad_subscript(mp); + if ( mp->cur_cmd!=right_bracket ) { + mp_missing_err(mp, "]"); +@.Missing `]'@> + help3("I've seen a `[' and a subscript value, in a suffix,", + "so a right bracket should have come next.", + "I shall pretend that one was there."); + mp_back_error(mp); + } + mp->cur_cmd=numeric_token; mp->cur_mod=mp->cur_exp; +} + +@* \[38] Parsing secondary and higher expressions. + +After the intricacies of |scan_primary|\kern-1pt, +the |scan_secondary| routine is +refreshingly simple. It's not trivial, but the operations are relatively +straightforward; the main difficulty is, again, that expressions and data +structures might change drastically every time we call |get_x_next|, so a +cautious approach is mandatory. For example, a macro defined by +\&{primarydef} might have disappeared by the time its second argument has +been scanned; we solve this by increasing the reference count of its token +list, so that the macro can be called even after it has been clobbered. + +@<Declare the basic parsing subroutines@>= +static void mp_scan_secondary (MP mp) { + pointer p; /* for list manipulation */ + halfword c,d; /* operation codes or modifiers */ + pointer mac_name; /* token defined with \&{primarydef} */ +RESTART: + if ((mp->cur_cmd<min_primary_command)|| + (mp->cur_cmd>max_primary_command) ) + mp_bad_exp(mp, "A secondary"); +@.A secondary expression...@> + mp_scan_primary(mp); +CONTINUE: + if ( mp->cur_cmd<=max_secondary_command && + mp->cur_cmd>=min_secondary_command ) { + p=mp_stash_cur_exp(mp); + c=mp->cur_mod; d=mp->cur_cmd; + if ( d==secondary_primary_macro ) { + mac_name=mp->cur_sym; + add_mac_ref(c); + } + mp_get_x_next(mp); + mp_scan_primary(mp); + if ( d!=secondary_primary_macro ) { + mp_do_binary(mp, p,c); + } else { + mp_back_input(mp); + mp_binary_mac(mp, p,c,mac_name); + decr(ref_count(c)); + mp_get_x_next(mp); + goto RESTART; + } + goto CONTINUE; + } +} + +@ The following procedure calls a macro that has two parameters, +|p| and |cur_exp|. + +@c +static void mp_binary_mac (MP mp,pointer p, pointer c, pointer n) { + pointer q,r; /* nodes in the parameter list */ + q=mp_get_avail(mp); r=mp_get_avail(mp); mp_link(q)=r; + mp_info(q)=p; mp_info(r)=mp_stash_cur_exp(mp); + mp_macro_call(mp, c,q,n); +} + +@ The next procedure, |scan_tertiary|, is pretty much the same deal. + +@<Declare the basic parsing subroutines@>= +static void mp_scan_tertiary (MP mp) { + pointer p; /* for list manipulation */ + halfword c,d; /* operation codes or modifiers */ + pointer mac_name; /* token defined with \&{secondarydef} */ +RESTART: + if ((mp->cur_cmd<min_primary_command)|| + (mp->cur_cmd>max_primary_command) ) + mp_bad_exp(mp, "A tertiary"); +@.A tertiary expression...@> + mp_scan_secondary(mp); +CONTINUE: + if ( mp->cur_cmd<=max_tertiary_command ) { + if ( mp->cur_cmd>=min_tertiary_command ) { + p=mp_stash_cur_exp(mp); c=mp->cur_mod; d=mp->cur_cmd; + if ( d==tertiary_secondary_macro ) { + mac_name=mp->cur_sym; add_mac_ref(c); + }; + mp_get_x_next(mp); mp_scan_secondary(mp); + if ( d!=tertiary_secondary_macro ) { + mp_do_binary(mp, p,c); + } else { + mp_back_input(mp); mp_binary_mac(mp, p,c,mac_name); + decr(ref_count(c)); mp_get_x_next(mp); + goto RESTART; + } + goto CONTINUE; + } + } +} + +@ Finally we reach the deepest level in our quartet of parsing routines. +This one is much like the others; but it has an extra complication from +paths, which materialize here. + +@d continue_path 25 /* a label inside of |scan_expression| */ +@d finish_path 26 /* another */ + +@<Declare the basic parsing subroutines@>= +static void mp_scan_expression (MP mp) { + pointer p,q,r,pp,qq; /* for list manipulation */ + halfword c,d; /* operation codes or modifiers */ + int my_var_flag; /* initial value of |var_flag| */ + pointer mac_name; /* token defined with \&{tertiarydef} */ + boolean cycle_hit; /* did a path expression just end with `\&{cycle}'? */ + scaled x,y; /* explicit coordinates or tension at a path join */ + int t; /* knot type following a path join */ + t=0; y=0; x=0; + my_var_flag=mp->var_flag; mac_name=null; +RESTART: + if ((mp->cur_cmd<min_primary_command)|| + (mp->cur_cmd>max_primary_command) ) + mp_bad_exp(mp, "An"); +@.An expression...@> + mp_scan_tertiary(mp); +CONTINUE: + if ( mp->cur_cmd<=max_expression_command ) + if ( mp->cur_cmd>=min_expression_command ) { + if ( (mp->cur_cmd!=equals)||(my_var_flag!=assignment) ) { + p=mp_stash_cur_exp(mp); c=mp->cur_mod; d=mp->cur_cmd; + if ( d==expression_tertiary_macro ) { + mac_name=mp->cur_sym; add_mac_ref(c); + } + if ( (d<ampersand)||((d==ampersand)&& + ((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@>; + } else { + mp_get_x_next(mp); mp_scan_tertiary(mp); + if ( d!=expression_tertiary_macro ) { + mp_do_binary(mp, p,c); + } else { + mp_back_input(mp); mp_binary_mac(mp, p,c,mac_name); + decr(ref_count(c)); mp_get_x_next(mp); + goto RESTART; + } + } + goto CONTINUE; + } + } +} + +@ The reader should review the data structure conventions for paths before +hoping to understand the next part of this code. + +@<Scan a path construction operation...@>= +{ + cycle_hit=false; + @<Convert the left operand, |p|, into a partial path ending at~|q|; + but |return| if |p| doesn't have a suitable type@>; +CONTINUE_PATH: + @<Determine the path join parameters; + but |goto finish_path| if there's only a direction specifier@>; + if ( mp->cur_cmd==cycle ) { + @<Get ready to close a cycle@>; + } else { + mp_scan_tertiary(mp); + @<Convert the right operand, |cur_exp|, + into a partial path from |pp| to~|qq|@>; + } + @<Join the partial paths and reset |p| and |q| to the head and tail + of the result@>; + if ( mp->cur_cmd>=min_expression_command ) + if ( mp->cur_cmd<=ampersand ) if ( ! cycle_hit ) goto CONTINUE_PATH; +FINISH_PATH: + @<Choose control points for the path and put the result into |cur_exp|@>; +} + +@ @<Convert the left operand, |p|, into a partial path ending at~|q|...@>= +{ + mp_unstash_cur_exp(mp, p); + if ( mp->cur_type==mp_pair_type ) p=mp_new_knot(mp); + else if ( mp->cur_type==mp_path_type ) p=mp->cur_exp; + else return; + q=p; + while ( mp_link(q)!=p ) q=mp_link(q); + if ( mp_left_type(p)!=mp_endpoint ) { /* open up a cycle */ + r=mp_copy_knot(mp, p); mp_link(q)=r; q=r; + } + mp_left_type(p)=mp_open; mp_right_type(q)=mp_open; +} + +@ A pair of numeric values is changed into a knot node for a one-point path +when \MP\ discovers that the pair is part of a path. + +@c +static pointer mp_new_knot (MP mp) { /* convert a pair to a knot with two endpoints */ + pointer q; /* the new node */ + q=mp_get_node(mp, knot_node_size); mp_left_type(q)=mp_endpoint; + mp_right_type(q)=mp_endpoint; mp_originator(q)=mp_metapost_user; mp_link(q)=q; + mp_known_pair(mp); mp_x_coord(q)=mp->cur_x; mp_y_coord(q)=mp->cur_y; + return q; +} + +@ The |known_pair| subroutine sets |cur_x| and |cur_y| to the components +of the current expression, assuming that the current expression is a +pair of known numerics. Unknown components are zeroed, and the +current expression is flushed. + +@<Declarations@>= +static void mp_known_pair (MP mp); + +@ @c +void mp_known_pair (MP mp) { + pointer p; /* the pair node */ + if ( mp->cur_type!=mp_pair_type ) { + exp_err("Undefined coordinates have been replaced by (0,0)"); +@.Undefined coordinates...@> + help5("I need x and y numbers for this part of the path.", + "The value I found (see above) was no good;", + "so I'll try to keep going by using zero instead.", + "(Chapter 27 of The METAFONTbook explains that", +@:METAFONTbook}{\sl The {\logos METAFONT\/}book@> + "you might want to type `I ??" "?' now.)"); + mp_put_get_flush_error(mp, 0); mp->cur_x=0; mp->cur_y=0; + } else { + p=value(mp->cur_exp); + @<Make sure that both |x| and |y| parts of |p| are known; + copy them into |cur_x| and |cur_y|@>; + mp_flush_cur_exp(mp, 0); + } +} + +@ @<Make sure that both |x| and |y| parts of |p| are known...@>= +if ( mp_type(x_part_loc(p))==mp_known ) { + mp->cur_x=value(x_part_loc(p)); +} else { + mp_disp_err(mp, x_part_loc(p), + "Undefined x coordinate has been replaced by 0"); +@.Undefined coordinates...@> + help5("I need a `known' x value for this part of the path.", + "The value I found (see above) was no good;", + "so I'll try to keep going by using zero instead.", + "(Chapter 27 of The METAFONTbook explains that", +@:METAFONTbook}{\sl The {\logos METAFONT\/}book@> + "you might want to type `I ??" "?' now.)"); + mp_put_get_error(mp); mp_recycle_value(mp, x_part_loc(p)); mp->cur_x=0; +} +if ( mp_type(y_part_loc(p))==mp_known ) { + mp->cur_y=value(y_part_loc(p)); +} else { + mp_disp_err(mp, y_part_loc(p), + "Undefined y coordinate has been replaced by 0"); + help5("I need a `known' y value for this part of the path.", + "The value I found (see above) was no good;", + "so I'll try to keep going by using zero instead.", + "(Chapter 27 of The METAFONTbook explains that", + "you might want to type `I ??" "?' now.)"); + mp_put_get_error(mp); mp_recycle_value(mp, y_part_loc(p)); mp->cur_y=0; +} + +@ At this point |cur_cmd| is either |ampersand|, |left_brace|, or |path_join|. + +@<Determine the path join parameters...@>= +if ( mp->cur_cmd==left_brace ) { + @<Put the pre-join direction information into node |q|@>; +} +d=mp->cur_cmd; +if ( d==path_join ) { + @<Determine the tension and/or control points@>; +} else if ( d!=ampersand ) { + goto FINISH_PATH; +} +mp_get_x_next(mp); +if ( mp->cur_cmd==left_brace ) { + @<Put the post-join direction information into |x| and |t|@>; +} else if ( mp_right_type(q)!=mp_explicit ) { + t=mp_open; x=0; +} + +@ The |scan_direction| subroutine looks at the directional information +that is enclosed in braces, and also scans ahead to the following character. +A type code is returned, either |open| (if the direction was $(0,0)$), +or |curl| (if the direction was a curl of known value |cur_exp|), or +|given| (if the direction is given by the |angle| value that now +appears in |cur_exp|). + +There's nothing difficult about this subroutine, but the program is rather +lengthy because a variety of potential errors need to be nipped in the bud. + +@c +static quarterword mp_scan_direction (MP mp) { + int t; /* the type of information found */ + scaled x; /* an |x| coordinate */ + mp_get_x_next(mp); + if ( mp->cur_cmd==curl_command ) { + @<Scan a curl specification@>; + } else { + @<Scan a given direction@>; + } + if ( mp->cur_cmd!=right_brace ) { + mp_missing_err(mp, "}"); +@.Missing `\char`\}'@> + help3("I've scanned a direction spec for part of a path,", + "so a right brace should have come next.", + "I shall pretend that one was there."); + mp_back_error(mp); + } + mp_get_x_next(mp); + return t; +} + +@ @<Scan a curl specification@>= +{ mp_get_x_next(mp); mp_scan_expression(mp); +if ( (mp->cur_type!=mp_known)||(mp->cur_exp<0) ){ + exp_err("Improper curl has been replaced by 1"); +@.Improper curl@> + help1("A curl must be a known, nonnegative number."); + mp_put_get_flush_error(mp, unity); +} +t=mp_curl; +} + +@ @<Scan a given direction@>= +{ mp_scan_expression(mp); + if ( mp->cur_type>mp_pair_type ) { + @<Get given directions separated by commas@>; + } else { + mp_known_pair(mp); + } + if ( (mp->cur_x==0)&&(mp->cur_y==0) ) t=mp_open; + else { t=mp_given; mp->cur_exp=mp_n_arg(mp, mp->cur_x,mp->cur_y);} +} + +@ @<Get given directions separated by commas@>= +{ + if ( mp->cur_type!=mp_known ) { + exp_err("Undefined x coordinate has been replaced by 0"); +@.Undefined coordinates...@> + help5("I need a `known' x value for this part of the path.", + "The value I found (see above) was no good;", + "so I'll try to keep going by using zero instead.", + "(Chapter 27 of The METAFONTbook explains that", +@:METAFONTbook}{\sl The {\logos METAFONT\/}book@> + "you might want to type `I ??" "?' now.)"); + mp_put_get_flush_error(mp, 0); + } + x=mp->cur_exp; + if ( mp->cur_cmd!=comma ) { + mp_missing_err(mp, ","); +@.Missing `,'@> + help2("I've got the x coordinate of a path direction;", + "will look for the y coordinate next."); + mp_back_error(mp); + } + mp_get_x_next(mp); mp_scan_expression(mp); + if ( mp->cur_type!=mp_known ) { + exp_err("Undefined y coordinate has been replaced by 0"); + help5("I need a `known' y value for this part of the path.", + "The value I found (see above) was no good;", + "so I'll try to keep going by using zero instead.", + "(Chapter 27 of The METAFONTbook explains that", + "you might want to type `I ??" "?' now.)"); + mp_put_get_flush_error(mp, 0); + } + mp->cur_y=mp->cur_exp; mp->cur_x=x; +} + +@ At this point |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\}..}'. + +@<Put the pre-join...@>= +{ + t=mp_scan_direction(mp); + if ( t!=mp_open ) { + mp_right_type(q)=t; right_given(q)=mp->cur_exp; + if ( mp_left_type(q)==mp_open ) { + mp_left_type(q)=t; left_given(q)=mp->cur_exp; + } /* note that |left_given(q)=left_curl(q)| */ + } +} + +@ Since |left_tension| and |mp_left_y| share the same position in knot nodes, +and since |left_given| is similarly equivalent to |mp_left_x|, we use +|x| and |y| to hold the given direction and tension information when +there are no explicit control points. + +@<Put the post-join...@>= +{ + t=mp_scan_direction(mp); + if ( mp_right_type(q)!=mp_explicit ) x=mp->cur_exp; + else t=mp_explicit; /* the direction information is superfluous */ +} + +@ @<Determine the tension and/or...@>= +{ + mp_get_x_next(mp); + if ( mp->cur_cmd==tension ) { + @<Set explicit tensions@>; + } else if ( mp->cur_cmd==controls ) { + @<Set explicit control points@>; + } else { + right_tension(q)=unity; y=unity; mp_back_input(mp); /* default tension */ + goto DONE; + }; + if ( mp->cur_cmd!=path_join ) { + mp_missing_err(mp, ".."); +@.Missing `..'@> + help1("A path join command should end with two dots."); + mp_back_error(mp); + } +DONE: + ; +} + +@ @<Set explicit tensions@>= +{ + mp_get_x_next(mp); y=mp->cur_cmd; + if ( mp->cur_cmd==at_least ) mp_get_x_next(mp); + mp_scan_primary(mp); + @<Make sure that the current expression is a valid tension setting@>; + if ( y==at_least ) negate(mp->cur_exp); + right_tension(q)=mp->cur_exp; + if ( mp->cur_cmd==and_command ) { + mp_get_x_next(mp); y=mp->cur_cmd; + if ( mp->cur_cmd==at_least ) mp_get_x_next(mp); + mp_scan_primary(mp); + @<Make sure that the current expression is a valid tension setting@>; + if ( y==at_least ) negate(mp->cur_exp); + } + y=mp->cur_exp; +} + +@ @d min_tension three_quarter_unit + +@<Make sure that the current expression is a valid tension setting@>= +if ( (mp->cur_type!=mp_known)||(mp->cur_exp<min_tension) ) { + exp_err("Improper tension has been set to 1"); +@.Improper tension@> + help1("The expression above should have been a number >=3/4."); + mp_put_get_flush_error(mp, unity); +} + +@ @<Set explicit control points@>= +{ + mp_right_type(q)=mp_explicit; t=mp_explicit; mp_get_x_next(mp); mp_scan_primary(mp); + mp_known_pair(mp); mp_right_x(q)=mp->cur_x; mp_right_y(q)=mp->cur_y; + if ( mp->cur_cmd!=and_command ) { + x=mp_right_x(q); y=mp_right_y(q); + } else { + mp_get_x_next(mp); mp_scan_primary(mp); + mp_known_pair(mp); x=mp->cur_x; y=mp->cur_y; + } +} + +@ @<Convert the right operand, |cur_exp|, into a partial path...@>= +{ + if ( mp->cur_type!=mp_path_type ) pp=mp_new_knot(mp); + else pp=mp->cur_exp; + qq=pp; + while ( mp_link(qq)!=pp ) qq=mp_link(qq); + if ( mp_left_type(pp)!=mp_endpoint ) { /* open up a cycle */ + r=mp_copy_knot(mp, pp); mp_link(qq)=r; qq=r; + } + mp_left_type(pp)=mp_open; mp_right_type(qq)=mp_open; +} + +@ If a person tries to define an entire path by saying `\.{(x,y)\&cycle}', +we silently change the specification to `\.{(x,y)..cycle}', since a cycle +shouldn't have length zero. + +@<Get ready to close a cycle@>= +{ + cycle_hit=true; mp_get_x_next(mp); pp=p; qq=p; + if ( d==ampersand ) if ( p==q ) { + d=path_join; right_tension(q)=unity; y=unity; + } +} + +@ @<Join the partial paths and reset |p| and |q|...@>= +{ +if ( d==ampersand ) { + if ( (mp_x_coord(q)!=mp_x_coord(pp))||(mp_y_coord(q)!=mp_y_coord(pp)) ) { + print_err("Paths don't touch; `&' will be changed to `..'"); +@.Paths don't touch@> + help3("When you join paths `p&q', the ending point of p", + "must be exactly equal to the starting point of q.", + "So I'm going to pretend that you said `p..q' instead."); + mp_put_get_error(mp); d=path_join; right_tension(q)=unity; y=unity; + } +} +@<Plug an opening in |mp_right_type(pp)|, if possible@>; +if ( d==ampersand ) { + @<Splice independent paths together@>; +} else { + @<Plug an opening in |mp_right_type(q)|, if possible@>; + mp_link(q)=pp; mp_left_y(pp)=y; + if ( t!=mp_open ) { mp_left_x(pp)=x; mp_left_type(pp)=t; }; +} +q=qq; +} + +@ @<Plug an opening in |mp_right_type(q)|...@>= +if ( mp_right_type(q)==mp_open ) { + if ( (mp_left_type(q)==mp_curl)||(mp_left_type(q)==mp_given) ) { + mp_right_type(q)=mp_left_type(q); right_given(q)=left_given(q); + } +} + +@ @<Plug an opening in |mp_right_type(pp)|...@>= +if ( mp_right_type(pp)==mp_open ) { + if ( (t==mp_curl)||(t==mp_given) ) { + mp_right_type(pp)=t; right_given(pp)=x; + } +} + +@ @<Splice independent paths together@>= +{ + if ( mp_left_type(q)==mp_open ) if ( mp_right_type(q)==mp_open ) { + mp_left_type(q)=mp_curl; left_curl(q)=unity; + } + if ( mp_right_type(pp)==mp_open ) if ( t==mp_open ) { + mp_right_type(pp)=mp_curl; right_curl(pp)=unity; + } + mp_right_type(q)=mp_right_type(pp); mp_link(q)=mp_link(pp); + mp_right_x(q)=mp_right_x(pp); mp_right_y(q)=mp_right_y(pp); + mp_free_node(mp, pp,knot_node_size); + if ( qq==pp ) qq=q; +} + +@ @<Choose control points for the path...@>= +if ( cycle_hit ) { + if ( d==ampersand ) p=q; +} else { + mp_left_type(p)=mp_endpoint; + if ( mp_right_type(p)==mp_open ) { + mp_right_type(p)=mp_curl; right_curl(p)=unity; + } + mp_right_type(q)=mp_endpoint; + if ( mp_left_type(q)==mp_open ) { + mp_left_type(q)=mp_curl; left_curl(q)=unity; + } + mp_link(q)=p; +} +mp_make_choices(mp, p); +mp->cur_type=mp_path_type; mp->cur_exp=p + +@ Finally, we sometimes need to scan an expression whose value is +supposed to be either |true_code| or |false_code|. + +@<Declare the basic parsing subroutines@>= +static void mp_get_boolean (MP mp) { + mp_get_x_next(mp); mp_scan_expression(mp); + if ( mp->cur_type!=mp_boolean_type ) { + exp_err("Undefined condition will be treated as `false'"); +@.Undefined condition...@> + help2("The expression shown above should have had a definite", + "true-or-false value. I'm changing it to `false'."); + mp_put_get_flush_error(mp, false_code); mp->cur_type=mp_boolean_type; + } +} + +@* \[39] Doing the operations. +The purpose of parsing is primarily to permit people to avoid piles of +parentheses. But the real work is done after the structure of an expression +has been recognized; that's when new expressions are generated. We +turn now to the guts of \MP, which handles individual operators that +have come through the parsing mechanism. + +We'll start with the easy ones that take no operands, then work our way +up to operators with one and ultimately two arguments. In other words, +we will write the three procedures |do_nullary|, |do_unary|, and |do_binary| +that are invoked periodically by the expression scanners. + +First let's make sure that all of the primitive operators are in the +hash table. Although |scan_primary| and its relatives made use of the +\\{cmd} code for these operators, the \\{do} routines base everything +on the \\{mod} code. For example, |do_binary| doesn't care whether the +operation it performs is a |primary_binary| or |secondary_binary|, etc. + +@<Put each...@>= +mp_primitive(mp, "true",nullary,true_code); +@:true_}{\&{true} primitive@> +mp_primitive(mp, "false",nullary,false_code); +@:false_}{\&{false} primitive@> +mp_primitive(mp, "nullpicture",nullary,null_picture_code); +@:null_picture_}{\&{nullpicture} primitive@> +mp_primitive(mp, "nullpen",nullary,null_pen_code); +@:null_pen_}{\&{nullpen} primitive@> +mp_primitive(mp, "jobname",nullary,job_name_op); +@:job_name_}{\&{jobname} primitive@> +mp_primitive(mp, "readstring",nullary,read_string_op); +@:read_string_}{\&{readstring} primitive@> +mp_primitive(mp, "pencircle",nullary,pen_circle); +@:pen_circle_}{\&{pencircle} primitive@> +mp_primitive(mp, "normaldeviate",nullary,normal_deviate); +@:normal_deviate_}{\&{normaldeviate} primitive@> +mp_primitive(mp, "readfrom",unary,read_from_op); +@:read_from_}{\&{readfrom} primitive@> +mp_primitive(mp, "closefrom",unary,close_from_op); +@:close_from_}{\&{closefrom} primitive@> +mp_primitive(mp, "odd",unary,odd_op); +@:odd_}{\&{odd} primitive@> +mp_primitive(mp, "known",unary,known_op); +@:known_}{\&{known} primitive@> +mp_primitive(mp, "unknown",unary,unknown_op); +@:unknown_}{\&{unknown} primitive@> +mp_primitive(mp, "not",unary,not_op); +@:not_}{\&{not} primitive@> +mp_primitive(mp, "decimal",unary,decimal); +@:decimal_}{\&{decimal} primitive@> +mp_primitive(mp, "reverse",unary,reverse); +@:reverse_}{\&{reverse} primitive@> +mp_primitive(mp, "makepath",unary,make_path_op); +@:make_path_}{\&{makepath} primitive@> +mp_primitive(mp, "makepen",unary,make_pen_op); +@:make_pen_}{\&{makepen} primitive@> +mp_primitive(mp, "oct",unary,oct_op); +@:oct_}{\&{oct} primitive@> +mp_primitive(mp, "hex",unary,hex_op); +@:hex_}{\&{hex} primitive@> +mp_primitive(mp, "ASCII",unary,ASCII_op); +@:ASCII_}{\&{ASCII} primitive@> +mp_primitive(mp, "char",unary,char_op); +@:char_}{\&{char} primitive@> +mp_primitive(mp, "length",unary,length_op); +@:length_}{\&{length} primitive@> +mp_primitive(mp, "turningnumber",unary,turning_op); +@:turning_number_}{\&{turningnumber} primitive@> +mp_primitive(mp, "xpart",unary,x_part); +@:x_part_}{\&{xpart} primitive@> +mp_primitive(mp, "ypart",unary,y_part); +@:y_part_}{\&{ypart} primitive@> +mp_primitive(mp, "xxpart",unary,xx_part); +@:xx_part_}{\&{xxpart} primitive@> +mp_primitive(mp, "xypart",unary,xy_part); +@:xy_part_}{\&{xypart} primitive@> +mp_primitive(mp, "yxpart",unary,yx_part); +@:yx_part_}{\&{yxpart} primitive@> +mp_primitive(mp, "yypart",unary,yy_part); +@:yy_part_}{\&{yypart} primitive@> +mp_primitive(mp, "redpart",unary,red_part); +@:red_part_}{\&{redpart} primitive@> +mp_primitive(mp, "greenpart",unary,green_part); +@:green_part_}{\&{greenpart} primitive@> +mp_primitive(mp, "bluepart",unary,blue_part); +@:blue_part_}{\&{bluepart} primitive@> +mp_primitive(mp, "cyanpart",unary,cyan_part); +@:cyan_part_}{\&{cyanpart} primitive@> +mp_primitive(mp, "magentapart",unary,magenta_part); +@:magenta_part_}{\&{magentapart} primitive@> +mp_primitive(mp, "yellowpart",unary,yellow_part); +@:yellow_part_}{\&{yellowpart} primitive@> +mp_primitive(mp, "blackpart",unary,black_part); +@:black_part_}{\&{blackpart} primitive@> +mp_primitive(mp, "greypart",unary,grey_part); +@:grey_part_}{\&{greypart} primitive@> +mp_primitive(mp, "colormodel",unary,color_model_part); +@:color_model_part_}{\&{colormodel} primitive@> +mp_primitive(mp, "fontpart",unary,font_part); +@:font_part_}{\&{fontpart} primitive@> +mp_primitive(mp, "textpart",unary,text_part); +@:text_part_}{\&{textpart} primitive@> +mp_primitive(mp, "pathpart",unary,path_part); +@:path_part_}{\&{pathpart} primitive@> +mp_primitive(mp, "penpart",unary,pen_part); +@:pen_part_}{\&{penpart} primitive@> +mp_primitive(mp, "dashpart",unary,dash_part); +@:dash_part_}{\&{dashpart} primitive@> +mp_primitive(mp, "sqrt",unary,sqrt_op); +@:sqrt_}{\&{sqrt} primitive@> +mp_primitive(mp, "mexp",unary,mp_m_exp_op); +@:m_exp_}{\&{mexp} primitive@> +mp_primitive(mp, "mlog",unary,mp_m_log_op); +@:m_log_}{\&{mlog} primitive@> +mp_primitive(mp, "sind",unary,sin_d_op); +@:sin_d_}{\&{sind} primitive@> +mp_primitive(mp, "cosd",unary,cos_d_op); +@:cos_d_}{\&{cosd} primitive@> +mp_primitive(mp, "floor",unary,floor_op); +@:floor_}{\&{floor} primitive@> +mp_primitive(mp, "uniformdeviate",unary,uniform_deviate); +@:uniform_deviate_}{\&{uniformdeviate} primitive@> +mp_primitive(mp, "charexists",unary,char_exists_op); +@:char_exists_}{\&{charexists} primitive@> +mp_primitive(mp, "fontsize",unary,font_size); +@:font_size_}{\&{fontsize} primitive@> +mp_primitive(mp, "llcorner",unary,ll_corner_op); +@:ll_corner_}{\&{llcorner} primitive@> +mp_primitive(mp, "lrcorner",unary,lr_corner_op); +@:lr_corner_}{\&{lrcorner} primitive@> +mp_primitive(mp, "ulcorner",unary,ul_corner_op); +@:ul_corner_}{\&{ulcorner} primitive@> +mp_primitive(mp, "urcorner",unary,ur_corner_op); +@:ur_corner_}{\&{urcorner} primitive@> +mp_primitive(mp, "arclength",unary,arc_length); +@:arc_length_}{\&{arclength} primitive@> +mp_primitive(mp, "angle",unary,angle_op); +@:angle_}{\&{angle} primitive@> +mp_primitive(mp, "cycle",cycle,cycle_op); +@:cycle_}{\&{cycle} primitive@> +mp_primitive(mp, "stroked",unary,stroked_op); +@:stroked_}{\&{stroked} primitive@> +mp_primitive(mp, "filled",unary,filled_op); +@:filled_}{\&{filled} primitive@> +mp_primitive(mp, "textual",unary,textual_op); +@:textual_}{\&{textual} primitive@> +mp_primitive(mp, "clipped",unary,clipped_op); +@:clipped_}{\&{clipped} primitive@> +mp_primitive(mp, "bounded",unary,bounded_op); +@:bounded_}{\&{bounded} primitive@> +mp_primitive(mp, "+",plus_or_minus,plus); +@:+ }{\.{+} primitive@> +mp_primitive(mp, "-",plus_or_minus,minus); +@:- }{\.{-} primitive@> +mp_primitive(mp, "*",secondary_binary,times); +@:* }{\.{*} primitive@> +mp_primitive(mp, "/",slash,over); mp->eqtb[frozen_slash]=mp->eqtb[mp->cur_sym]; +@:/ }{\.{/} primitive@> +mp_primitive(mp, "++",tertiary_binary,pythag_add); +@:++_}{\.{++} primitive@> +mp_primitive(mp, "+-+",tertiary_binary,pythag_sub); +@:+-+_}{\.{+-+} primitive@> +mp_primitive(mp, "or",tertiary_binary,or_op); +@:or_}{\&{or} primitive@> +mp_primitive(mp, "and",and_command,and_op); +@:and_}{\&{and} primitive@> +mp_primitive(mp, "<",expression_binary,less_than); +@:< }{\.{<} primitive@> +mp_primitive(mp, "<=",expression_binary,less_or_equal); +@:<=_}{\.{<=} primitive@> +mp_primitive(mp, ">",expression_binary,greater_than); +@:> }{\.{>} primitive@> +mp_primitive(mp, ">=",expression_binary,greater_or_equal); +@:>=_}{\.{>=} primitive@> +mp_primitive(mp, "=",equals,equal_to); +@:= }{\.{=} primitive@> +mp_primitive(mp, "<>",expression_binary,unequal_to); +@:<>_}{\.{<>} primitive@> +mp_primitive(mp, "substring",primary_binary,substring_of); +@:substring_}{\&{substring} primitive@> +mp_primitive(mp, "subpath",primary_binary,subpath_of); +@:subpath_}{\&{subpath} primitive@> +mp_primitive(mp, "directiontime",primary_binary,direction_time_of); +@:direction_time_}{\&{directiontime} primitive@> +mp_primitive(mp, "point",primary_binary,point_of); +@:point_}{\&{point} primitive@> +mp_primitive(mp, "precontrol",primary_binary,precontrol_of); +@:precontrol_}{\&{precontrol} primitive@> +mp_primitive(mp, "postcontrol",primary_binary,postcontrol_of); +@:postcontrol_}{\&{postcontrol} primitive@> +mp_primitive(mp, "penoffset",primary_binary,pen_offset_of); +@:pen_offset_}{\&{penoffset} primitive@> +mp_primitive(mp, "arctime",primary_binary,arc_time_of); +@:arc_time_of_}{\&{arctime} primitive@> +mp_primitive(mp, "mpversion",nullary,mp_version); +@:mp_verison_}{\&{mpversion} primitive@> +mp_primitive(mp, "&",ampersand,concatenate); +@:!!!}{\.{\&} primitive@> +mp_primitive(mp, "rotated",secondary_binary,rotated_by); +@:rotated_}{\&{rotated} primitive@> +mp_primitive(mp, "slanted",secondary_binary,slanted_by); +@:slanted_}{\&{slanted} primitive@> +mp_primitive(mp, "scaled",secondary_binary,scaled_by); +@:scaled_}{\&{scaled} primitive@> +mp_primitive(mp, "shifted",secondary_binary,shifted_by); +@:shifted_}{\&{shifted} primitive@> +mp_primitive(mp, "transformed",secondary_binary,transformed_by); +@:transformed_}{\&{transformed} primitive@> +mp_primitive(mp, "xscaled",secondary_binary,x_scaled); +@:x_scaled_}{\&{xscaled} primitive@> +mp_primitive(mp, "yscaled",secondary_binary,y_scaled); +@:y_scaled_}{\&{yscaled} primitive@> +mp_primitive(mp, "zscaled",secondary_binary,z_scaled); +@:z_scaled_}{\&{zscaled} primitive@> +mp_primitive(mp, "infont",secondary_binary,in_font); +@:in_font_}{\&{infont} primitive@> +mp_primitive(mp, "intersectiontimes",tertiary_binary,intersect); +@:intersection_times_}{\&{intersectiontimes} primitive@> +mp_primitive(mp, "envelope",primary_binary,envelope_of); +@:envelope_}{\&{envelope} primitive@> + +@ @<Cases of |print_cmd...@>= +case nullary: +case unary: +case primary_binary: +case secondary_binary: +case tertiary_binary: +case expression_binary: +case cycle: +case plus_or_minus: +case slash: +case ampersand: +case equals: +case and_command: + mp_print_op(mp, m); + break; + +@ OK, let's look at the simplest \\{do} procedure first. + +@c @<Declare nullary action procedure@> +static void mp_do_nullary (MP mp,quarterword c) { + check_arith; + if ( mp->internal[mp_tracing_commands]>two ) + mp_show_cmd_mod(mp, nullary,c); + switch (c) { + case true_code: case false_code: + mp->cur_type=mp_boolean_type; mp->cur_exp=c; + break; + case null_picture_code: + mp->cur_type=mp_picture_type; + mp->cur_exp=mp_get_node(mp, edge_header_size); + mp_init_edges(mp, mp->cur_exp); + break; + case null_pen_code: + mp->cur_type=mp_pen_type; mp->cur_exp=mp_get_pen_circle(mp, 0); + break; + case normal_deviate: + mp->cur_type=mp_known; mp->cur_exp=mp_norm_rand(mp); + break; + case pen_circle: + mp->cur_type=mp_pen_type; mp->cur_exp=mp_get_pen_circle(mp, unity); + break; + case job_name_op: + if ( mp->job_name==NULL ) mp_open_log_file(mp); + mp->cur_type=mp_string_type; mp->cur_exp=rts(mp->job_name); + break; + case mp_version: + mp->cur_type=mp_string_type; + mp->cur_exp=intern(metapost_version) ; + break; + case read_string_op: + @<Read a string from the terminal@>; + break; + } /* there are no other cases */ + check_arith; +} + +@ @<Read a string...@>= +{ + if (mp->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); +} + +@ @<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-start); + for (k=(size_t)start;k<mp->last;k++) { + append_char(mp->buffer[k]); + } + mp_end_file_reading(mp); mp->cur_type=mp_string_type; + mp->cur_exp=mp_make_string(mp); +} + +@ Things get a bit more interesting when there's an operand. The +operand to |do_unary| appears in |cur_type| and |cur_exp|. + +@c @<Declare unary action procedures@> +static void mp_do_unary (MP mp,quarterword c) { + pointer p,q,r; /* for list manipulation */ + integer x; /* a temporary register */ + check_arith; + if ( mp->internal[mp_tracing_commands]>two ) + @<Trace the current unary operation@>; + switch (c) { + case plus: + if ( mp->cur_type<mp_color_type ) mp_bad_unary(mp, plus); + break; + case minus: + @<Negate the current expression@>; + break; + @<Additional cases of unary operators@>; + } /* there are no other cases */ + check_arith; +} + +@ The |nice_pair| function returns |true| if both components of a pair +are known. + +@<Declare unary action procedures@>= +static boolean mp_nice_pair (MP mp,integer p, quarterword t) { + if ( t==mp_pair_type ) { + p=value(p); + if ( mp_type(x_part_loc(p))==mp_known ) + if ( mp_type(y_part_loc(p))==mp_known ) + return true; + } + return false; +} + +@ The |nice_color_or_pair| function is analogous except that it also accepts +fully known colors. + +@<Declare unary action procedures@>= +static boolean mp_nice_color_or_pair (MP mp,integer p, quarterword t) { + pointer q,r; /* for scanning the big node */ + if ( (t!=mp_pair_type)&&(t!=mp_color_type)&&(t!=mp_cmykcolor_type) ) { + return false; + } else { + q=value(p); + r=q+mp->big_node_size[mp_type(p)]; + do { + r=r-2; + if ( mp_type(r)!=mp_known ) + return false; + } while (r!=q); + return true; + } +} + +@ @<Declare unary action...@>= +static void mp_print_known_or_unknown_type (MP mp,quarterword t, integer 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) { + exp_err("Not implemented: "); mp_print_op(mp, c); +@.Not implemented...@> + mp_print_known_or_unknown_type(mp, mp->cur_type,mp->cur_exp); + help3("I'm afraid I don't know how to apply that operation to that", + "particular type. Continue, and I'll simply return the", + "argument (shown above) as the result of the operation."); + mp_put_get_error(mp); +} + +@ @<Trace the current unary operation@>= +{ + mp_begin_diagnostic(mp); mp_print_nl(mp, "{"); + mp_print_op(mp, c); mp_print_char(mp, xord('(')); + mp_print_exp(mp, null,0); /* show the operand, but not verbosely */ + mp_print(mp, ")}"); mp_end_diagnostic(mp, false); +} + +@ Negation is easy except when the current expression +is of type |independent|, or when it is a pair with one or more +|independent| components. + +It is tempting to argue that the negative of an independent variable +is an independent variable, hence we don't have to do anything when +negating it. The fallacy is that other dependent variables pointing +to the current expression must change the sign of their +coefficients if we make no change to the current expression. + +Instead, we work around the problem by copying the current expression +and recycling it afterwards (cf.~the |stash_in| routine). + +@<Negate the current expression@>= +switch (mp->cur_type) { +case mp_color_type: +case mp_cmykcolor_type: +case mp_pair_type: +case mp_independent: + q=mp->cur_exp; mp_make_exp_copy(mp, q); + if ( mp->cur_type==mp_dependent ) { + mp_negate_dep_list(mp, dep_list(mp->cur_exp)); + } else if ( mp->cur_type<=mp_pair_type ) { /* |mp_color_type| or |mp_pair_type| */ + p=value(mp->cur_exp); + r=p+mp->big_node_size[mp->cur_type]; + do { + r=r-2; + if ( mp_type(r)==mp_known ) negate(value(r)); + else mp_negate_dep_list(mp, dep_list(r)); + } while (r!=p); + } /* if |cur_type=mp_known| then |cur_exp=0| */ + mp_recycle_value(mp, q); mp_free_node(mp, q,value_node_size); + break; +case mp_dependent: +case mp_proto_dependent: + mp_negate_dep_list(mp, dep_list(mp->cur_exp)); + break; +case mp_known: + negate(mp->cur_exp); + break; +default: + mp_bad_unary(mp, minus); + break; +} + +@ @<Declare unary action...@>= +static void mp_negate_dep_list (MP mp,pointer p) { + while (1) { + negate(value(p)); + if ( mp_info(p)==null ) return; + p=mp_link(p); + } +} + +@ @<Additional cases of unary operators@>= +case not_op: + if ( mp->cur_type!=mp_boolean_type ) mp_bad_unary(mp, not_op); + else mp->cur_exp=true_code+false_code-mp->cur_exp; + break; + +@ @d three_sixty_units 23592960 /* that's |360*unity| */ +@d boolean_reset(A) if ( (A) ) mp->cur_exp=true_code; else mp->cur_exp=false_code + +@<Additional cases of unary operators@>= +case sqrt_op: +case mp_m_exp_op: +case mp_m_log_op: +case sin_d_op: +case cos_d_op: +case floor_op: +case uniform_deviate: +case odd_op: +case char_exists_op: + if ( mp->cur_type!=mp_known ) { + mp_bad_unary(mp, c); + } else { + switch (c) { + case sqrt_op:mp->cur_exp=mp_square_rt(mp, mp->cur_exp);break; + case mp_m_exp_op:mp->cur_exp=mp_m_exp(mp, mp->cur_exp);break; + case mp_m_log_op:mp->cur_exp=mp_m_log(mp, mp->cur_exp);break; + case sin_d_op: + case cos_d_op: + mp_n_sin_cos(mp, (mp->cur_exp % three_sixty_units)*16); + if ( c==sin_d_op ) mp->cur_exp=mp_round_fraction(mp, mp->n_sin); + else mp->cur_exp=mp_round_fraction(mp, mp->n_cos); + break; + case floor_op:mp->cur_exp=mp_floor_scaled(mp, mp->cur_exp);break; + case uniform_deviate:mp->cur_exp=mp_unif_rand(mp, mp->cur_exp);break; + case odd_op: + boolean_reset(odd(mp_round_unscaled(mp, mp->cur_exp))); + mp->cur_type=mp_boolean_type; + break; + case char_exists_op: + @<Determine if a character has been shipped out@>; + break; + } /* there are no other cases */ + } + break; + +@ @<Additional cases of unary operators@>= +case angle_op: + if ( mp_nice_pair(mp, mp->cur_exp,mp->cur_type) ) { + p=value(mp->cur_exp); + x=mp_n_arg(mp, value(x_part_loc(p)),value(y_part_loc(p))); + if ( x>=0 ) mp_flush_cur_exp(mp, (x+8)/ 16); + else mp_flush_cur_exp(mp, -((-x+8)/ 16)); + } else { + mp_bad_unary(mp, angle_op); + } + break; + +@ If the current expression is a pair, but the context wants it to +be a path, we call |pair_to_path|. + +@<Declare unary action...@>= +static void mp_pair_to_path (MP mp) { + mp->cur_exp=mp_new_knot(mp); + mp->cur_type=mp_path_type; +} + +@ +@d pict_color_type(A) ((mp_link(dummy_loc(mp->cur_exp))!=null) && + (has_color(mp_link(dummy_loc(mp->cur_exp)))) && + ((mp_color_model(mp_link(dummy_loc(mp->cur_exp)))==A) + || + ((mp_color_model(mp_link(dummy_loc(mp->cur_exp)))==mp_uninitialized_model) && + (mp->internal[mp_default_color_model]/unity)==(A)))) + +@<Additional cases of unary operators@>= +case x_part: +case y_part: + if ( (mp->cur_type==mp_pair_type)||(mp->cur_type==mp_transform_type) ) + mp_take_part(mp, c); + else if ( mp->cur_type==mp_picture_type ) mp_take_pict_part(mp, c); + else mp_bad_unary(mp, c); + break; +case xx_part: +case xy_part: +case yx_part: +case yy_part: + if ( mp->cur_type==mp_transform_type ) mp_take_part(mp, c); + else if ( mp->cur_type==mp_picture_type ) mp_take_pict_part(mp, c); + else mp_bad_unary(mp, c); + break; +case red_part: +case green_part: +case blue_part: + if ( mp->cur_type==mp_color_type ) mp_take_part(mp, c); + else if ( mp->cur_type==mp_picture_type ) { + if pict_color_type(mp_rgb_model) mp_take_pict_part(mp, c); + else mp_bad_color_part(mp, c); + } + else mp_bad_unary(mp, c); + break; +case cyan_part: +case magenta_part: +case yellow_part: +case black_part: + if ( mp->cur_type==mp_cmykcolor_type) mp_take_part(mp, c); + else if ( mp->cur_type==mp_picture_type ) { + if pict_color_type(mp_cmyk_model) mp_take_pict_part(mp, c); + else mp_bad_color_part(mp, c); + } + else mp_bad_unary(mp, c); + break; +case grey_part: + if ( mp->cur_type==mp_known ) mp->cur_exp=value(c); + else if ( mp->cur_type==mp_picture_type ) { + if pict_color_type(mp_grey_model) mp_take_pict_part(mp, c); + else mp_bad_color_part(mp, c); + } + else mp_bad_unary(mp, c); + break; +case color_model_part: + if ( mp->cur_type==mp_picture_type ) mp_take_pict_part(mp, c); + else mp_bad_unary(mp, c); + break; + +@ @<Declarations@>= +static void mp_bad_color_part(MP mp, quarterword c); + +@ @c +static void mp_bad_color_part(MP mp, quarterword c) { + pointer p; /* the big node */ + p=mp_link(dummy_loc(mp->cur_exp)); + exp_err("Wrong picture color model: "); mp_print_op(mp, c); +@.Wrong picture color model...@> + if (mp_color_model(p)==mp_grey_model) + mp_print(mp, " of grey object"); + else if (mp_color_model(p)==mp_cmyk_model) + mp_print(mp, " of cmyk object"); + else if (mp_color_model(p)==mp_rgb_model) + mp_print(mp, " of rgb object"); + else if (mp_color_model(p)==mp_no_model) + mp_print(mp, " of marking object"); + else + mp_print(mp," of defaulted object"); + help3("You can only ask for the redpart, greenpart, bluepart of a rgb object,", + "the cyanpart, magentapart, yellowpart or blackpart of a cmyk object, ", + "or the greypart of a grey object. No mixing and matching, please."); + mp_error(mp); + if (c==black_part) + mp_flush_cur_exp(mp,unity); + else + mp_flush_cur_exp(mp,0); +} + +@ In the following procedure, |cur_exp| points to a capsule, which points to +a big node. We want to delete all but one part of the big node. + +@<Declare unary action...@>= +static void mp_take_part (MP mp,quarterword c) { + pointer p; /* the big node */ + p=value(mp->cur_exp); value(temp_val)=p; mp_type(temp_val)=mp->cur_type; + mp_link(p)=temp_val; mp_free_node(mp, mp->cur_exp,value_node_size); + mp_make_exp_copy(mp, p+mp->sector_offset[c+mp_x_part_sector-x_part]); + mp_recycle_value(mp, temp_val); +} + +@ @<Initialize table entries...@>= +mp_name_type(temp_val)=mp_capsule; + +@ @<Additional cases of unary operators@>= +case font_part: +case text_part: +case path_part: +case pen_part: +case dash_part: + if ( mp->cur_type==mp_picture_type ) mp_take_pict_part(mp, c); + else mp_bad_unary(mp, c); + break; + +@ @<Declarations@>= +static void mp_scale_edges (MP mp); + +@ @<Declare unary action...@>= +static void mp_take_pict_part (MP mp,quarterword c) { + pointer p; /* first graphical object in |cur_exp| */ + p=mp_link(dummy_loc(mp->cur_exp)); + if ( p!=null ) { + switch (c) { + case x_part: case y_part: case xx_part: + case xy_part: case yx_part: case yy_part: + if ( mp_type(p)==mp_text_code ) mp_flush_cur_exp(mp, text_trans_part(p+c)); + else goto NOT_FOUND; + break; + case red_part: case green_part: case blue_part: + if ( has_color(p) ) mp_flush_cur_exp(mp, obj_color_part(p+c)); + else goto NOT_FOUND; + break; + case cyan_part: case magenta_part: case yellow_part: + case black_part: + if ( has_color(p) ) { + if ( mp_color_model(p)==mp_uninitialized_model && c==black_part) + mp_flush_cur_exp(mp, unity); + else + mp_flush_cur_exp(mp, obj_color_part(p+c+(red_part-cyan_part))); + } else goto NOT_FOUND; + break; + case grey_part: + if ( has_color(p) ) + mp_flush_cur_exp(mp, obj_color_part(p+c+(red_part-grey_part))); + else goto NOT_FOUND; + break; + case color_model_part: + if ( has_color(p) ) { + if ( mp_color_model(p)==mp_uninitialized_model ) + mp_flush_cur_exp(mp, mp->internal[mp_default_color_model]); + else + mp_flush_cur_exp(mp, mp_color_model(p)*unity); + } else goto NOT_FOUND; + break; + @<Handle other cases in |take_pict_part| or |goto not_found|@>; + } /* all cases have been enumerated */ + return; + }; +NOT_FOUND: + @<Convert the current expression to a null value appropriate + for |c|@>; +} + +@ @<Handle other cases in |take_pict_part| or |goto not_found|@>= +case text_part: + if ( mp_type(p)!=mp_text_code ) goto NOT_FOUND; + else { + mp_flush_cur_exp(mp, mp_text_p(p)); + add_str_ref(mp->cur_exp); + mp->cur_type=mp_string_type; + }; + break; +case font_part: + if ( mp_type(p)!=mp_text_code ) goto NOT_FOUND; + else { + mp_flush_cur_exp(mp, rts(mp->font_name[mp_font_n(p)])); + add_str_ref(mp->cur_exp); + mp->cur_type=mp_string_type; + }; + break; +case path_part: + if ( mp_type(p)==mp_text_code ) goto NOT_FOUND; + else if ( is_stop(p) ) mp_confusion(mp, "pict"); +@:this can't happen pict}{\quad pict@> + else { + mp_flush_cur_exp(mp, mp_copy_path(mp, mp_path_p(p))); + mp->cur_type=mp_path_type; + } + break; +case pen_part: + if ( ! has_pen(p) ) goto NOT_FOUND; + else { + if ( mp_pen_p(p)==null ) goto NOT_FOUND; + else { mp_flush_cur_exp(mp, copy_pen(mp_pen_p(p))); + mp->cur_type=mp_pen_type; + }; + } + break; +case dash_part: + if ( mp_type(p)!=mp_stroked_code ) goto NOT_FOUND; + else { if ( mp_dash_p(p)==null ) goto NOT_FOUND; + else { add_edge_ref(mp_dash_p(p)); + mp->se_sf=dash_scale(p); + mp->se_pic=mp_dash_p(p); + mp_scale_edges(mp); + mp_flush_cur_exp(mp, mp->se_pic); + mp->cur_type=mp_picture_type; + }; + } + break; + +@ Since |scale_edges| had to be declared |forward|, it had to be declared as a +parameterless procedure even though it really takes two arguments and updates +one of them. Hence the following globals are needed. + +@<Global...@>= +pointer se_pic; /* edge header used and updated by |scale_edges| */ +scaled se_sf; /* the scale factor argument to |scale_edges| */ + +@ @<Convert the current expression to a null value appropriate...@>= +switch (c) { +case text_part: case font_part: + mp_flush_cur_exp(mp, null_str); + mp->cur_type=mp_string_type; + break; +case path_part: + mp_flush_cur_exp(mp, mp_get_node(mp, knot_node_size)); + mp_left_type(mp->cur_exp)=mp_endpoint; + mp_right_type(mp->cur_exp)=mp_endpoint; + mp_link(mp->cur_exp)=mp->cur_exp; + mp_x_coord(mp->cur_exp)=0; + mp_y_coord(mp->cur_exp)=0; + mp_originator(mp->cur_exp)=mp_metapost_user; + mp->cur_type=mp_path_type; + break; +case pen_part: + mp_flush_cur_exp(mp, mp_get_pen_circle(mp, 0)); + mp->cur_type=mp_pen_type; + break; +case dash_part: + mp_flush_cur_exp(mp, mp_get_node(mp, edge_header_size)); + mp_init_edges(mp, mp->cur_exp); + mp->cur_type=mp_picture_type; + break; +default: + mp_flush_cur_exp(mp, 0); + break; +} + +@ @<Additional cases of unary...@>= +case char_op: + if ( mp->cur_type!=mp_known ) { + mp_bad_unary(mp, char_op); + } else { + mp->cur_exp=mp_round_unscaled(mp, mp->cur_exp) % 256; + mp->cur_type=mp_string_type; + if ( mp->cur_exp<0 ) mp->cur_exp=mp->cur_exp+256; + } + break; +case decimal: + if ( mp->cur_type!=mp_known ) { + mp_bad_unary(mp, decimal); + } else { + mp->old_setting=mp->selector; mp->selector=new_string; + mp_print_scaled(mp, mp->cur_exp); mp->cur_exp=mp_make_string(mp); + mp->selector=mp->old_setting; mp->cur_type=mp_string_type; + } + break; +case oct_op: +case hex_op: +case ASCII_op: + if ( mp->cur_type!=mp_string_type ) mp_bad_unary(mp, c); + else mp_str_to_num(mp, c); + break; +case font_size: + if ( mp->cur_type!=mp_string_type ) mp_bad_unary(mp, font_size); + else @<Find the design size of the font whose name is |cur_exp|@>; + break; + +@ @<Declare unary action...@>= +static void mp_str_to_num (MP mp,quarterword c) { /* converts a string to a number */ + integer n; /* accumulator */ + ASCII_code m; /* current character */ + pool_pointer k; /* index into |str_pool| */ + int b; /* radix of conversion */ + boolean bad_char; /* did the string contain an invalid digit? */ + if ( c==ASCII_op ) { + if ( length(mp->cur_exp)==0 ) n=-1; + else n=mp->str_pool[mp->str_start[mp->cur_exp]]; + } else { + if ( c==oct_op ) b=8; else b=16; + n=0; bad_char=false; + for (k=mp->str_start[mp->cur_exp];k<str_stop(mp->cur_exp);k++) { + m=mp->str_pool[k]; + if ( (m>='0')&&(m<='9') ) m=m-'0'; + else if ( (m>='A')&&(m<='F') ) m=m-'A'+10; + else if ( (m>='a')&&(m<='f') ) m=m-'a'+10; + else { bad_char=true; m=0; }; + if ( (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|@>; + } + mp_flush_cur_exp(mp, n*unity); +} + +@ @<Give error messages if |bad_char|...@>= +if ( bad_char ) { + exp_err("String contains illegal digits"); +@.String contains illegal digits@> + if ( c==oct_op ) { + help1("I zeroed out characters that weren't in the range 0..7."); + } else { + help1("I zeroed out characters that weren't hex digits."); + } + mp_put_get_error(mp); +} +if ( (n>4095) ) { + if ( mp->internal[mp_warning_check]>0 ) { + print_err("Number too large ("); + mp_print_int(mp, n); mp_print_char(mp, xord(')')); +@.Number too large@> + help2("I have trouble with numbers greater than 4095; watch out.", + "(Set warningcheck:=0 to suppress this message.)"); + mp_put_get_error(mp); + } +} + +@ The length operation is somewhat unusual in that it applies to a variety +of different types of operands. + +@<Additional cases of unary...@>= +case length_op: + switch (mp->cur_type) { + case mp_string_type: mp_flush_cur_exp(mp, length(mp->cur_exp)*unity); break; + case mp_path_type: mp_flush_cur_exp(mp, mp_path_length(mp)); break; + case mp_known: mp->cur_exp=abs(mp->cur_exp); break; + case mp_picture_type: mp_flush_cur_exp(mp, mp_pict_length(mp)); break; + default: + if ( mp_nice_pair(mp, mp->cur_exp,mp->cur_type) ) + mp_flush_cur_exp(mp, mp_pyth_add(mp, + value(x_part_loc(value(mp->cur_exp))), + value(y_part_loc(value(mp->cur_exp))))); + else mp_bad_unary(mp, c); + break; + } + break; + +@ @<Declare unary action...@>= +static scaled mp_path_length (MP mp) { /* computes the length of the current path */ + scaled n; /* the path length so far */ + pointer p; /* traverser */ + p=mp->cur_exp; + if ( mp_left_type(p)==mp_endpoint ) n=-unity; else n=0; + do { p=mp_link(p); n=n+unity; } while (p!=mp->cur_exp); + return n; +} + +@ @<Declare unary action...@>= +static scaled mp_pict_length (MP mp) { + /* counts interior components in picture |cur_exp| */ + scaled n; /* the count so far */ + pointer p; /* traverser */ + n=0; + p=mp_link(dummy_loc(mp->cur_exp)); + if ( p!=null ) { + if ( is_start_or_stop(p) ) + if ( mp_skip_1component(mp, p)==null ) p=mp_link(p); + while ( p!=null ) { + skip_component(p) return n; + n=n+unity; + } + } + return n; +} + +@ Implement |turningnumber| + +@<Additional cases of unary...@>= +case turning_op: + if ( mp->cur_type==mp_pair_type ) mp_flush_cur_exp(mp, 0); + else if ( mp->cur_type!=mp_path_type ) mp_bad_unary(mp, turning_op); + else if ( mp_left_type(mp->cur_exp)==mp_endpoint ) + mp_flush_cur_exp(mp, 0); /* not a cyclic path */ + else + mp_flush_cur_exp(mp, mp_turn_cycles_wrapper(mp, mp->cur_exp)); + break; + +@ The function |an_angle| returns the value of the |angle| primitive, or $0$ if the +argument is |origin|. + +@<Declare unary action...@>= +static angle mp_an_angle (MP mp,scaled xpar, scaled ypar) { + if ( (! ((xpar==0) && (ypar==0))) ) + return mp_n_arg(mp, xpar,ypar); + return 0; +} + + +@ The actual turning number is (for the moment) computed in a C function +that receives eight integers corresponding to the four controlling points, +and returns a single angle. Besides those, we have to account for discrete +moves at the actual points. + +@d 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)/(256*256*16)) +@d divisor (256*256) +@d double2angle(a) (int)mp_floor(a*256.0*256.0*16.0) + +@<Declare unary action...@>= +static angle mp_bezier_slope(MP mp, integer AX,integer AY,integer BX,integer BY, + integer CX,integer CY,integer DX,integer DY); + +@ @c +static angle mp_bezier_slope(MP mp, integer AX,integer AY,integer BX,integer BY, + integer CX,integer CY,integer DX,integer DY) { + double a, b, c; + integer deltax,deltay; + double ax,ay,bx,by,cx,cy,dx,dy; + angle xi = 0, xo = 0, xm = 0; + double res = 0; + ax=(double)(AX/divisor); ay=(double)(AY/divisor); + bx=(double)(BX/divisor); by=(double)(BY/divisor); + cx=(double)(CX/divisor); cy=(double)(CY/divisor); + dx=(double)(DX/divisor); dy=(double)(DY/divisor); + + deltax = (BX-AX); deltay = (BY-AY); + if (deltax==0 && deltay == 0) { deltax=(CX-AX); deltay=(CY-AY); } + if (deltax==0 && deltay == 0) { deltax=(DX-AX); deltay=(DY-AY); } + xi = mp_an_angle(mp,deltax,deltay); + + deltax = (CX-BX); deltay = (CY-BY); + xm = mp_an_angle(mp,deltax,deltay); + + deltax = (DX-CX); deltay = (DY-CY); + if (deltax==0 && deltay == 0) { deltax=(DX-BX); deltay=(DY-BY); } + if (deltax==0 && deltay == 0) { deltax=(DX-AX); deltay=(DY-AY); } + xo = mp_an_angle(mp,deltax,deltay); + + a = (bx-ax)*(cy-by) - (cx-bx)*(by-ay); /* a = (bp-ap)x(cp-bp); */ + b = (bx-ax)*(dy-cy) - (by-ay)*(dx-cx);; /* b = (bp-ap)x(dp-cp);*/ + c = (cx-bx)*(dy-cy) - (dx-cx)*(cy-by); /* c = (cp-bp)x(dp-cp);*/ + + if ((a==0)&&(c==0)) { + res = (b==0 ? 0 : (mp_out(xo)-mp_out(xi))); + } else if ((a==0)||(c==0)) { + if ((mp_sign(b) == mp_sign(a)) || (mp_sign(b) == mp_sign(c))) { + res = mp_out(xo)-mp_out(xi); /* ? */ + if (res<-180.0) + res += 360.0; + else if (res>180.0) + res -= 360.0; + } else { + res = mp_out(xo)-mp_out(xi); /* ? */ + } + } else if ((mp_sign(a)*mp_sign(c))<0) { + res = mp_out(xo)-mp_out(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(xo)-mp_out(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(xo)-mp_out(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(xo)-mp_out(xi); + if (res<-180.0) + res += 360.0; + else if (res>180.0) + res -= 360.0; + } + } + } + return double2angle(res); +} + +@ +@d p_nextnext mp_link(mp_link(p)) +@d p_next mp_link(p) +@d seven_twenty_deg 05500000000 /* $720\cdot2^{20}$, represents $720^\circ$ */ + +@<Declare unary action...@>= +static scaled mp_new_turn_cycles (MP mp,pointer c) { + angle res,ang; /* the angles of intermediate results */ + scaled turns; /* the turn counter */ + pointer p; /* for running around the path */ + integer xp,yp; /* coordinates of next point */ + integer x,y; /* helper coordinates */ + angle in_angle,out_angle; /* helper angles */ + unsigned old_setting; /* saved |selector| setting */ + res=0; + turns= 0; + p=c; + old_setting = mp->selector; mp->selector=term_only; + if ( mp->internal[mp_tracing_commands]>unity ) { + mp_begin_diagnostic(mp); + mp_print_nl(mp, ""); + mp_end_diagnostic(mp, false); + } + do { + xp = mp_x_coord(p_next); yp = mp_y_coord(p_next); + ang = mp_bezier_slope(mp,mp_x_coord(p), mp_y_coord(p), mp_right_x(p), mp_right_y(p), + mp_left_x(p_next), mp_left_y(p_next), xp, yp); + if ( ang>seven_twenty_deg ) { + print_err("Strange path"); + mp_error(mp); + mp->selector=old_setting; + return 0; + } + res = res + ang; + if ( res > one_eighty_deg ) { + res = res - three_sixty_deg; + turns = turns + unity; + } + if ( res <= -one_eighty_deg ) { + res = res + three_sixty_deg; + turns = turns - unity; + } + /* incoming angle at next point */ + x = mp_left_x(p_next); y = mp_left_y(p_next); + if ( (xp==x)&&(yp==y) ) { x = mp_right_x(p); y = mp_right_y(p); }; + if ( (xp==x)&&(yp==y) ) { x = mp_x_coord(p); y = mp_y_coord(p); }; + in_angle = mp_an_angle(mp, xp - x, yp - y); + /* outgoing angle at next point */ + x = mp_right_x(p_next); y = mp_right_y(p_next); + if ( (xp==x)&&(yp==y) ) { x = mp_left_x(p_nextnext); y = mp_left_y(p_nextnext); }; + if ( (xp==x)&&(yp==y) ) { x = mp_x_coord(p_nextnext); y = mp_y_coord(p_nextnext); }; + out_angle = mp_an_angle(mp, x - xp, y- yp); + ang = (out_angle - in_angle); + reduce_angle(ang); + if ( ang!=0 ) { + res = res + ang; + if ( res >= one_eighty_deg ) { + res = res - three_sixty_deg; + turns = turns + unity; + }; + if ( res <= -one_eighty_deg ) { + res = res + three_sixty_deg; + turns = turns - unity; + }; + }; + p = mp_link(p); + } while (p!=c); + mp->selector=old_setting; + return turns; +} + + +@ This code is based on Bogus\l{}av Jackowski's +|emergency_turningnumber| macro, with some minor changes by Taco +Hoekwater. The macro code looked more like this: +{\obeylines +vardef turning\_number primary p = +~~save res, ang, turns; +~~res := 0; +~~if length p <= 2: +~~~~if Angle ((point 0 of p) - (postcontrol 0 of p)) >= 0: 1 else: -1 fi +~~else: +~~~~for t = 0 upto length p-1 : +~~~~~~angc := Angle ((point t+1 of p) - (point t of p)) +~~~~~~~~- Angle ((point t of p) - (point t-1 of p)); +~~~~~~if angc > 180: angc := angc - 360; fi; +~~~~~~if angc < -180: angc := angc + 360; fi; +~~~~~~res := res + angc; +~~~~endfor; +~~res/360 +~~fi +enddef;} +The general idea is to calculate only the sum of the angles of +straight lines between the points, of a path, not worrying about cusps +or self-intersections in the segments at all. If the segment is not +well-behaved, the result is not necesarily correct. But the old code +was not always correct either, and worse, it sometimes failed for +well-behaved paths as well. All known bugs that were triggered by the +original code no longer occur with this code, and it runs roughly 3 +times as fast because the algorithm is much simpler. + +@ It is possible to overflow the return value of the |turn_cycles| +function when the path is sufficiently long and winding, but I am not +going to bother testing for that. In any case, it would only return +the looped result value, which is not a big problem. + +The macro code for the repeat loop was a bit nicer to look +at than the pascal code, because it could use |point -1 of p|. In +pascal, the fastest way to loop around the path is not to look +backward once, but forward twice. These defines help hide the trick. + +@d p_to mp_link(mp_link(p)) +@d p_here mp_link(p) +@d p_from p + +@<Declare unary action...@>= +static scaled mp_turn_cycles (MP mp,pointer c) { + angle res,ang; /* the angles of intermediate results */ + scaled turns; /* the turn counter */ + pointer p; /* for running around the path */ + res=0; turns= 0; p=c; + do { + ang = mp_an_angle (mp, mp_x_coord(p_to) - mp_x_coord(p_here), + mp_y_coord(p_to) - mp_y_coord(p_here)) + - mp_an_angle (mp, mp_x_coord(p_here) - mp_x_coord(p_from), + mp_y_coord(p_here) - mp_y_coord(p_from)); + reduce_angle(ang); + res = res + ang; + if ( res >= three_sixty_deg ) { + res = res - three_sixty_deg; + turns = turns + unity; + }; + if ( res <= -three_sixty_deg ) { + res = res + three_sixty_deg; + turns = turns - unity; + }; + p = mp_link(p); + } while (p!=c); + return turns; +} + +@ @<Declare unary action...@>= +static scaled mp_turn_cycles_wrapper (MP mp,pointer c) { + scaled nval,oval; + scaled saved_t_o; /* tracing\_online saved */ + if ( (mp_link(c)==c)||(mp_link(mp_link(c))==c) ) { + if ( mp_an_angle (mp, mp_x_coord(c) - mp_right_x(c), mp_y_coord(c) - mp_right_y(c)) > 0 ) + return unity; + else + return -unity; + } else { + nval = mp_new_turn_cycles(mp, c); + oval = mp_turn_cycles(mp, c); + if ( nval!=oval ) { + saved_t_o=mp->internal[mp_tracing_online]; + mp->internal[mp_tracing_online]=unity; + mp_begin_diagnostic(mp); + mp_print_nl (mp, "Warning: the turningnumber algorithms do not agree." + " The current computed value is "); + mp_print_scaled(mp, nval); + mp_print(mp, ", but the 'connect-the-dots' algorithm returned "); + mp_print_scaled(mp, oval); + mp_end_diagnostic(mp, false); + mp->internal[mp_tracing_online]=saved_t_o; + } + return nval; + } +} + +@ @d type_range(A,B) { + if ( (mp->cur_type>=(A)) && (mp->cur_type<=(B)) ) + mp_flush_cur_exp(mp, true_code); + else mp_flush_cur_exp(mp, false_code); + mp->cur_type=mp_boolean_type; + } +@d type_test(A) { + if ( mp->cur_type==(A) ) mp_flush_cur_exp(mp, true_code); + else mp_flush_cur_exp(mp, false_code); + mp->cur_type=mp_boolean_type; + } + +@<Additional cases of unary operators@>= +case mp_boolean_type: + type_range(mp_boolean_type,mp_unknown_boolean); break; +case mp_string_type: + type_range(mp_string_type,mp_unknown_string); break; +case mp_pen_type: + type_range(mp_pen_type,mp_unknown_pen); break; +case mp_path_type: + type_range(mp_path_type,mp_unknown_path); break; +case mp_picture_type: + type_range(mp_picture_type,mp_unknown_picture); break; +case mp_transform_type: case mp_color_type: case mp_cmykcolor_type: +case mp_pair_type: + type_test(c); break; +case mp_numeric_type: + type_range(mp_known,mp_independent); break; +case known_op: case unknown_op: + mp_test_known(mp, c); break; + +@ @<Declare unary action procedures@>= +static void mp_test_known (MP mp,quarterword c) { + int b; /* is the current expression known? */ + pointer p,q; /* locations in a big node */ + b=false_code; + switch (mp->cur_type) { + case mp_vacuous: case mp_boolean_type: case mp_string_type: + case mp_pen_type: case mp_path_type: case mp_picture_type: + case mp_known: + b=true_code; + break; + case mp_transform_type: + case mp_color_type: case mp_cmykcolor_type: case mp_pair_type: + p=value(mp->cur_exp); + q=p+mp->big_node_size[mp->cur_type]; + do { + q=q-2; + if ( mp_type(q)!=mp_known ) + goto DONE; + } while (q!=p); + b=true_code; + DONE: + break; + default: + break; + } + if ( c==known_op ) mp_flush_cur_exp(mp, b); + else mp_flush_cur_exp(mp, true_code+false_code-b); + mp->cur_type=mp_boolean_type; +} + +@ @<Additional cases of unary operators@>= +case cycle_op: + if ( mp->cur_type!=mp_path_type ) mp_flush_cur_exp(mp, false_code); + else if ( mp_left_type(mp->cur_exp)!=mp_endpoint ) mp_flush_cur_exp(mp, true_code); + else mp_flush_cur_exp(mp, false_code); + mp->cur_type=mp_boolean_type; + break; + +@ @<Additional cases of unary operators@>= +case arc_length: + if ( mp->cur_type==mp_pair_type ) mp_pair_to_path(mp); + if ( mp->cur_type!=mp_path_type ) mp_bad_unary(mp, arc_length); + else mp_flush_cur_exp(mp, mp_get_arc_length(mp, mp->cur_exp)); + break; + +@ Here we use the fact that |c-filled_op+fill_code| is the desired graphical +object |type|. +@^data structure assumptions@> + +@<Additional cases of unary operators@>= +case filled_op: +case stroked_op: +case textual_op: +case clipped_op: +case bounded_op: + if ( mp->cur_type!=mp_picture_type ) mp_flush_cur_exp(mp, false_code); + else if ( mp_link(dummy_loc(mp->cur_exp))==null ) mp_flush_cur_exp(mp, false_code); + else if ( mp_type(mp_link(dummy_loc(mp->cur_exp)))==c+mp_fill_code-filled_op ) + mp_flush_cur_exp(mp, true_code); + else mp_flush_cur_exp(mp, false_code); + mp->cur_type=mp_boolean_type; + break; + +@ @<Additional cases of unary operators@>= +case make_pen_op: + if ( mp->cur_type==mp_pair_type ) mp_pair_to_path(mp); + if ( mp->cur_type!=mp_path_type ) mp_bad_unary(mp, make_pen_op); + else { + mp->cur_type=mp_pen_type; + mp->cur_exp=mp_make_pen(mp, mp->cur_exp,true); + }; + break; +case make_path_op: + if ( mp->cur_type!=mp_pen_type ) mp_bad_unary(mp, make_path_op); + else { + mp->cur_type=mp_path_type; + mp_make_path(mp, mp->cur_exp); + }; + break; +case reverse: + if ( mp->cur_type==mp_path_type ) { + p=mp_htap_ypoc(mp, mp->cur_exp); + if ( mp_right_type(p)==mp_endpoint ) p=mp_link(p); + mp_toss_knot_list(mp, mp->cur_exp); mp->cur_exp=p; + } else if ( mp->cur_type==mp_pair_type ) mp_pair_to_path(mp); + else mp_bad_unary(mp, reverse); + break; + +@ The |pair_value| routine changes the current expression to a +given ordered pair of values. + +@<Declare unary action procedures@>= +static void mp_pair_value (MP mp,scaled x, scaled y) { + pointer p; /* a pair node */ + p=mp_get_node(mp, value_node_size); + mp_flush_cur_exp(mp, p); mp->cur_type=mp_pair_type; + mp_type(p)=mp_pair_type; mp_name_type(p)=mp_capsule; mp_init_big_node(mp, p); + p=value(p); + mp_type(x_part_loc(p))=mp_known; value(x_part_loc(p))=x; + mp_type(y_part_loc(p))=mp_known; value(y_part_loc(p))=y; +} + +@ @<Additional cases of unary operators@>= +case ll_corner_op: + if ( ! mp_get_cur_bbox(mp) ) mp_bad_unary(mp, ll_corner_op); + else mp_pair_value(mp, mp_minx, mp_miny); + break; +case lr_corner_op: + if ( ! mp_get_cur_bbox(mp) ) mp_bad_unary(mp, lr_corner_op); + else mp_pair_value(mp, mp_maxx, mp_miny); + break; +case ul_corner_op: + if ( ! mp_get_cur_bbox(mp) ) mp_bad_unary(mp, ul_corner_op); + else mp_pair_value(mp, mp_minx, mp_maxy); + break; +case ur_corner_op: + if ( ! mp_get_cur_bbox(mp) ) mp_bad_unary(mp, ur_corner_op); + else mp_pair_value(mp, mp_maxx, mp_maxy); + break; + +@ Here is a function that sets |minx|, |maxx|, |miny|, |maxy| to the bounding +box of the current expression. The boolean result is |false| if the expression +has the wrong type. + +@<Declare unary action procedures@>= +static boolean mp_get_cur_bbox (MP mp) { + switch (mp->cur_type) { + case mp_picture_type: + mp_set_bbox(mp, mp->cur_exp,true); + if ( minx_val(mp->cur_exp)>maxx_val(mp->cur_exp) ) { + mp_minx=0; mp_maxx=0; mp_miny=0; mp_maxy=0; + } else { + mp_minx=minx_val(mp->cur_exp); + mp_maxx=maxx_val(mp->cur_exp); + mp_miny=miny_val(mp->cur_exp); + mp_maxy=maxy_val(mp->cur_exp); + } + break; + case mp_path_type: + mp_path_bbox(mp, mp->cur_exp); + break; + case mp_pen_type: + mp_pen_bbox(mp, mp->cur_exp); + break; + default: + return false; + } + return true; +} + +@ @<Additional cases of unary operators@>= +case read_from_op: +case close_from_op: + if ( mp->cur_type!=mp_string_type ) mp_bad_unary(mp, c); + else mp_do_read_or_close(mp,c); + break; + +@ Here is a routine that interprets |cur_exp| as a file name and tries to read +a line from the file or to close the file. + +@<Declare unary action procedures@>= +static void mp_do_read_or_close (MP mp,quarterword c) { + readf_index n,n0; /* indices for searching |rd_fname| */ + @<Find the |n| where |rd_fname[n]=cur_exp|; if |cur_exp| must be inserted, + call |start_read_input| and |goto found| or |not_found|@>; + mp_begin_file_reading(mp); + name=is_read; + if ( mp_input_ln(mp, mp->rd_file[n] ) ) + goto FOUND; + mp_end_file_reading(mp); +NOT_FOUND: + @<Record the end of file and set |cur_exp| to a dummy value@>; + return; +CLOSE_FILE: + mp_flush_cur_exp(mp, 0); mp->cur_type=mp_vacuous; + return; +FOUND: + mp_flush_cur_exp(mp, 0); + mp_finish_read(mp); +} + +@ Free slots in the |rd_file| and |rd_fname| arrays are marked with NULL's in +|rd_fname|. + +@<Find the |n| where |rd_fname[n]=cur_exp|...@>= +{ + char *fn; + n=mp->read_files; + n0=mp->read_files; + fn = str(mp->cur_exp); + while (mp_xstrcmp(fn,mp->rd_fname[n])!=0) { + if ( n>0 ) { + decr(n); + } else if ( c==close_from_op ) { + goto CLOSE_FILE; + } else { + if ( n0==mp->read_files ) { + if ( mp->read_files<mp->max_read_files ) { + incr(mp->read_files); + } else { + void **rd_file; + char **rd_fname; + readf_index l,k; + l = mp->max_read_files + (mp->max_read_files/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==close_from_op ) { + (mp->close_file)(mp,mp->rd_file[n]); + goto NOT_FOUND; + } +} + +@ @<Record the end of file and set |cur_exp| to a dummy value@>= +xfree(mp->rd_fname[n]); +mp->rd_fname[n]=NULL; +if ( n==mp->read_files-1 ) mp->read_files=n; +if ( c==close_from_op ) + goto CLOSE_FILE; +mp_flush_cur_exp(mp, mp->eof_line); +mp->cur_type=mp_string_type + +@ The string denoting end-of-file is a one-byte string at position zero, by definition + +@<Glob...@>= +str_number eof_line; + +@ @<Set init...@>= +mp->eof_line=0; + +@ Finally, we have the operations that combine a capsule~|p| +with the current expression. + +@d binary_return { mp_finish_binary(mp, old_p, old_exp); return; } + +@c @<Declare binary action procedures@> +static void mp_finish_binary (MP mp, pointer old_p, pointer old_exp ){ + check_arith; + @<Recycle any sidestepped |independent| capsules@>; +} +static void mp_do_binary (MP mp,pointer p, quarterword c) { + pointer q,r,rr; /* for list manipulation */ + pointer old_p,old_exp; /* capsules to recycle */ + integer v; /* for numeric manipulation */ + check_arith; + if ( mp->internal[mp_tracing_commands]>two ) { + @<Trace the current binary operation@>; + } + @<Sidestep |independent| cases in capsule |p|@>; + @<Sidestep |independent| cases in the current expression@>; + switch (c) { + case plus: case minus: + @<Add or subtract the current expression from |p|@>; + break; + @<Additional cases of binary operators@>; + }; /* there are no other cases */ + mp_recycle_value(mp, p); + mp_free_node(mp, p,value_node_size); /* |return| to avoid this */ + mp_finish_binary(mp, old_p, old_exp); +} + +@ @<Declare binary action...@>= +static void mp_bad_binary (MP mp,pointer p, quarterword c) { + mp_disp_err(mp, p,""); + exp_err("Not implemented: "); +@.Not implemented...@> + if ( c>=min_of ) mp_print_op(mp, c); + mp_print_known_or_unknown_type(mp, mp_type(p),p); + if ( c>=min_of ) mp_print(mp, "of"); else mp_print_op(mp, c); + mp_print_known_or_unknown_type(mp, mp->cur_type,mp->cur_exp); + help3("I'm afraid I don't know how to apply that operation to that", + "combination of types. Continue, and I'll return the second", + "argument (see above) as the result of the operation."); + mp_put_get_error(mp); +} +static void mp_bad_envelope_pen (MP mp) { + mp_disp_err(mp, null,""); + exp_err("Not implemented: envelope(elliptical pen)of(path)"); +@.Not implemented...@> + help3("I'm afraid I don't know how to apply that operation to that", + "combination of types. Continue, and I'll return the second", + "argument (see above) as the result of the operation."); + mp_put_get_error(mp); +} + +@ @<Trace the current binary operation@>= +{ + mp_begin_diagnostic(mp); mp_print_nl(mp, "{("); + mp_print_exp(mp,p,0); /* show the operand, but not verbosely */ + mp_print_char(mp,xord(')')); mp_print_op(mp,c); mp_print_char(mp,xord('(')); + mp_print_exp(mp,null,0); mp_print(mp,")}"); + mp_end_diagnostic(mp, false); +} + +@ Several of the binary operations are potentially complicated by the +fact that |independent| values can sneak into capsules. For example, +we've seen an instance of this difficulty in the unary operation +of negation. In order to reduce the number of cases that need to be +handled, we first change the two operands (if necessary) +to rid them of |independent| components. The original operands are +put into capsules called |old_p| and |old_exp|, which will be +recycled after the binary operation has been safely carried out. + +@<Recycle any sidestepped |independent| capsules@>= +if ( old_p!=null ) { + mp_recycle_value(mp, old_p); mp_free_node(mp, old_p,value_node_size); +} +if ( old_exp!=null ) { + mp_recycle_value(mp, old_exp); mp_free_node(mp, old_exp,value_node_size); +} + +@ A big node is considered to be ``tarnished'' if it contains at least one +independent component. We will define a simple function called `|tarnished|' +that returns |null| if and only if its argument is not tarnished. + +@<Sidestep |independent| cases in capsule |p|@>= +switch (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_type) { +case mp_transform_type: +case mp_color_type: +case mp_cmykcolor_type: +case mp_pair_type: + old_exp=mp_tarnished(mp, mp->cur_exp); + break; +case mp_independent:old_exp=mp_void; break; +default: old_exp=null; break; +} +if ( old_exp!=null ) { + old_exp=mp->cur_exp; mp_make_exp_copy(mp, old_exp); +} + +@ @<Declare binary action...@>= +static pointer mp_tarnished (MP mp,pointer p) { + pointer q; /* beginning of the big node */ + pointer r; /* current position in the big node */ + q=value(p); r=q+mp->big_node_size[mp_type(p)]; + do { + r=r-2; + if ( mp_type(r)==mp_independent ) return mp_void; + } while (r!=q); + return null; +} + +@ @<Add or subtract the current expression from |p|@>= +if ( (mp->cur_type<mp_color_type)||(mp_type(p)<mp_color_type) ) { + mp_bad_binary(mp, p,c); +} else { + if ((mp->cur_type>mp_pair_type)&&(mp_type(p)>mp_pair_type) ) { + mp_add_or_subtract(mp, p,null,c); + } else { + if ( mp->cur_type!=mp_type(p) ) { + mp_bad_binary(mp, p,c); + } else { + q=value(p); r=value(mp->cur_exp); + rr=r+mp->big_node_size[mp->cur_type]; + while ( r<rr ) { + mp_add_or_subtract(mp, q,r,c); + q=q+2; r=r+2; + } + } + } +} + +@ The first argument to |add_or_subtract| is the location of a value node +in a capsule or pair node that will soon be recycled. The second argument +is either a location within a pair or transform node of |cur_exp|, +or it is null (which means that |cur_exp| itself should be the second +argument). The third argument is either |plus| or |minus|. + +The sum or difference of the numeric quantities will replace the second +operand. Arithmetic overflow may go undetected; users aren't supposed to +be monkeying around with really big values. +@^overflow in arithmetic@> + +@<Declare binary action...@>= +@<Declare the procedure called |dep_finish|@> +static void mp_add_or_subtract (MP mp,pointer p, pointer q, quarterword c) { + quarterword s,t; /* operand types */ + pointer r; /* list traverser */ + integer v; /* second operand value */ + if ( q==null ) { + t=mp->cur_type; + if ( t<mp_dependent ) v=mp->cur_exp; else v=dep_list(mp->cur_exp); + } else { + t=mp_type(q); + if ( t<mp_dependent ) v=value(q); else v=dep_list(q); + } + if ( t==mp_known ) { + if ( c==minus ) negate(v); + if ( mp_type(p)==mp_known ) { + v=mp_slow_add(mp, value(p),v); + if ( q==null ) mp->cur_exp=v; else value(q)=v; + return; + } + @<Add a known value to the constant term of |dep_list(p)|@>; + } else { + if ( c==minus ) mp_negate_dep_list(mp, v); + @<Add operand |p| to the dependency list |v|@>; + } +} + +@ @<Add a known value to the constant term of |dep_list(p)|@>= +r=dep_list(p); +while ( mp_info(r)!=null ) r=mp_link(r); +value(r)=mp_slow_add(mp, value(r),v); +if ( q==null ) { + q=mp_get_node(mp, value_node_size); mp->cur_exp=q; mp->cur_type=mp_type(p); + mp_name_type(q)=mp_capsule; +} +dep_list(q)=dep_list(p); mp_type(q)=mp_type(p); +prev_dep(q)=prev_dep(p); mp_link(prev_dep(p))=q; +mp_type(p)=mp_known; /* this will keep the recycler from collecting non-garbage */ + +@ We prefer |dependent| lists to |mp_proto_dependent| ones, because it is +nice to retain the extra accuracy of |fraction| coefficients. +But we have to handle both kinds, and mixtures too. + +@<Add operand |p| to the dependency list |v|@>= +if ( mp_type(p)==mp_known ) { + @<Add the known |value(p)| to the constant term of |v|@>; +} else { + s=mp_type(p); r=dep_list(p); + if ( t==mp_dependent ) { + if ( s==mp_dependent ) { + if ( mp_max_coef(mp, r)+mp_max_coef(mp, v)<coef_bound ) { + v=mp_p_plus_q(mp, v,r,mp_dependent); goto DONE; + } + } /* |fix_needed| will necessarily be false */ + t=mp_proto_dependent; + v=mp_p_over_v(mp, v,unity,mp_dependent,mp_proto_dependent); + } + if ( s==mp_proto_dependent ) v=mp_p_plus_q(mp, v,r,mp_proto_dependent); + else v=mp_p_plus_fq(mp, v,unity,r,mp_proto_dependent,mp_dependent); + DONE: + @<Output the answer, |v| (which might have become |known|)@>; +} + +@ @<Add the known |value(p)| to the constant term of |v|@>= +{ + while ( mp_info(v)!=null ) v=mp_link(v); + value(v)=mp_slow_add(mp, value(p),value(v)); +} + +@ @<Output the answer, |v| (which might have become |known|)@>= +if ( q!=null ) mp_dep_finish(mp, v,q,t); +else { mp->cur_type=t; mp_dep_finish(mp, v,null,t); } + +@ Here's the current situation: The dependency list |v| of type |t| +should either be put into the current expression (if |q=null|) or +into location |q| within a pair node (otherwise). The destination (|cur_exp| +or |q|) formerly held a dependency list with the same +final pointer as the list |v|. + +@<Declare the procedure called |dep_finish|@>= +static void mp_dep_finish (MP mp, pointer v, pointer q, quarterword t) { + pointer p; /* the destination */ + scaled vv; /* the value, if it is |known| */ + if ( q==null ) p=mp->cur_exp; else p=q; + dep_list(p)=v; mp_type(p)=t; + if ( mp_info(v)==null ) { + vv=value(v); + if ( q==null ) { + mp_flush_cur_exp(mp, vv); + } else { + mp_recycle_value(mp, p); mp_type(q)=mp_known; value(q)=vv; + } + } else if ( q==null ) { + mp->cur_type=t; + } + if ( mp->fix_needed ) mp_fix_dependencies(mp); +} + +@ Let's turn now to the six basic relations of comparison. + +@<Additional cases of binary operators@>= +case less_than: case less_or_equal: case greater_than: +case greater_or_equal: case equal_to: case unequal_to: + check_arith; /* at this point |arith_error| should be |false|? */ + if ( (mp->cur_type>mp_pair_type)&&(mp_type(p)>mp_pair_type) ) { + mp_add_or_subtract(mp, p,null,minus); /* |cur_exp:=(p)-cur_exp| */ + } else if ( mp->cur_type!=mp_type(p) ) { + mp_bad_binary(mp, p,c); goto DONE; + } else if ( mp->cur_type==mp_string_type ) { + mp_flush_cur_exp(mp, mp_str_vs_str(mp, value(p),mp->cur_exp)); + } else if ((mp->cur_type==mp_unknown_string)|| + (mp->cur_type==mp_unknown_boolean) ) { + @<Check if unknowns have been equated@>; + } else if ( (mp->cur_type<=mp_pair_type)&&(mp->cur_type>=mp_transform_type)) { + @<Reduce comparison of big nodes to comparison of scalars@>; + } else if ( mp->cur_type==mp_boolean_type ) { + mp_flush_cur_exp(mp, mp->cur_exp-value(p)); + } else { + mp_bad_binary(mp, p,c); goto DONE; + } + @<Compare the current expression with zero@>; +DONE: + mp->arith_error=false; /* ignore overflow in comparisons */ + break; + +@ @<Compare the current expression with zero@>= +if ( mp->cur_type!=mp_known ) { + if ( mp->cur_type<mp_known ) { + mp_disp_err(mp, p,""); + help1("The quantities shown above have not been equated.") + } else { + help2("Oh dear. I can\'t decide if the expression above is positive,", + "negative, or zero. So this comparison test won't be `true'."); + } + exp_err("Unknown relation will be considered false"); +@.Unknown relation...@> + mp_put_get_flush_error(mp, false_code); +} else { + switch (c) { + case less_than: boolean_reset(mp->cur_exp<0); break; + case less_or_equal: boolean_reset(mp->cur_exp<=0); break; + case greater_than: boolean_reset(mp->cur_exp>0); break; + case greater_or_equal: boolean_reset(mp->cur_exp>=0); break; + case equal_to: boolean_reset(mp->cur_exp==0); break; + case unequal_to: boolean_reset(mp->cur_exp!=0); break; + }; /* there are no other cases */ +} +mp->cur_type=mp_boolean_type + +@ When two unknown strings are in the same ring, we know that they are +equal. Otherwise, we don't know whether they are equal or not, so we +make no change. + +@<Check if unknowns have been equated@>= +{ + q=value(mp->cur_exp); + while ( (q!=mp->cur_exp)&&(q!=p) ) q=value(q); + if ( q==p ) mp_flush_cur_exp(mp, 0); +} + +@ @<Reduce comparison of big nodes to comparison of scalars@>= +{ + q=value(p); r=value(mp->cur_exp); + rr=r+mp->big_node_size[mp->cur_type]-2; + while (1) { mp_add_or_subtract(mp, q,r,minus); + if ( mp_type(r)!=mp_known ) break; + if ( value(r)!=0 ) break; + if ( r==rr ) break; + q=q+2; r=r+2; + } + mp_take_part(mp, mp_name_type(r)+x_part-mp_x_part_sector); +} + +@ Here we use the sneaky fact that |and_op-false_code=or_op-true_code|. + +@<Additional cases of binary operators@>= +case and_op: +case or_op: + if ( (mp_type(p)!=mp_boolean_type)||(mp->cur_type!=mp_boolean_type) ) + mp_bad_binary(mp, p,c); + else if ( value(p)==c+false_code-and_op ) mp->cur_exp=value(p); + break; + +@ @<Additional cases of binary operators@>= +case times: + if ( (mp->cur_type<mp_color_type)||(mp_type(p)<mp_color_type) ) { + mp_bad_binary(mp, p,times); + } else if ( (mp->cur_type==mp_known)||(mp_type(p)==mp_known) ) { + @<Multiply when at least one operand is known@>; + } else if ( (mp_nice_color_or_pair(mp, p,mp_type(p))&&(mp->cur_type>mp_pair_type)) + ||(mp_nice_color_or_pair(mp, mp->cur_exp,mp->cur_type)&& + (mp_type(p)>mp_pair_type)) ) { + mp_hard_times(mp, p); + binary_return; + } else { + mp_bad_binary(mp, p,times); + } + break; + +@ @<Multiply when at least one operand is known@>= +{ + if ( mp_type(p)==mp_known ) { + v=value(p); mp_free_node(mp, p,value_node_size); + } else { + v=mp->cur_exp; mp_unstash_cur_exp(mp, p); + } + if ( mp->cur_type==mp_known ) { + mp->cur_exp=mp_take_scaled(mp, mp->cur_exp,v); + } else if ( (mp->cur_type==mp_pair_type)|| + (mp->cur_type==mp_color_type)|| + (mp->cur_type==mp_cmykcolor_type) ) { + p=value(mp->cur_exp)+mp->big_node_size[mp->cur_type]; + do { + p=p-2; mp_dep_mult(mp, p,v,true); + } while (p!=value(mp->cur_exp)); + } else { + mp_dep_mult(mp, null,v,true); + } + binary_return; +} + +@ @<Declare binary action...@>= +static void mp_dep_mult (MP mp,pointer p, integer v, boolean v_is_scaled) { + pointer q; /* the dependency list being multiplied by |v| */ + quarterword s,t; /* its type, before and after */ + if ( p==null ) { + q=mp->cur_exp; + } else if ( mp_type(p)!=mp_known ) { + q=p; + } else { + if ( v_is_scaled ) value(p)=mp_take_scaled(mp, value(p),v); + else value(p)=mp_take_fraction(mp, value(p),v); + return; + }; + t=mp_type(q); q=dep_list(q); s=t; + if ( t==mp_dependent ) if ( v_is_scaled ) + if (mp_ab_vs_cd(mp, mp_max_coef(mp,q),abs(v),coef_bound-1,unity)>=0 ) + t=mp_proto_dependent; + q=mp_p_times_v(mp, q,v,s,t,v_is_scaled); + mp_dep_finish(mp, q,p,t); +} + +@ Here is a routine that is similar to |times|; but it is invoked only +internally, when |v| is a |fraction| whose magnitude is at most~1, +and when |cur_type>=mp_color_type|. + +@c +static void mp_frac_mult (MP mp,scaled n, scaled d) { + /* multiplies |cur_exp| by |n/d| */ + pointer p; /* a pair node */ + pointer old_exp; /* a capsule to recycle */ + fraction v; /* |n/d| */ + if ( mp->internal[mp_tracing_commands]>two ) { + @<Trace the fraction multiplication@>; + } + switch (mp->cur_type) { + case mp_transform_type: + case mp_color_type: + case mp_cmykcolor_type: + case mp_pair_type: + old_exp=mp_tarnished(mp, mp->cur_exp); + break; + case mp_independent: old_exp=mp_void; break; + default: old_exp=null; break; + } + if ( old_exp!=null ) { + old_exp=mp->cur_exp; mp_make_exp_copy(mp, old_exp); + } + v=mp_make_fraction(mp, n,d); + if ( mp->cur_type==mp_known ) { + mp->cur_exp=mp_take_fraction(mp, mp->cur_exp,v); + } else if ( mp->cur_type<=mp_pair_type ) { + p=value(mp->cur_exp)+mp->big_node_size[mp->cur_type]; + do { + p=p-2; + mp_dep_mult(mp, p,v,false); + } while (p!=value(mp->cur_exp)); + } else { + mp_dep_mult(mp, null,v,false); + } + if ( old_exp!=null ) { + mp_recycle_value(mp, old_exp); + mp_free_node(mp, old_exp,value_node_size); + } +} + +@ @<Trace the fraction multiplication@>= +{ + mp_begin_diagnostic(mp); + mp_print_nl(mp, "{("); mp_print_scaled(mp,n); mp_print_char(mp,xord('/')); + mp_print_scaled(mp,d); mp_print(mp,")*("); mp_print_exp(mp,null,0); + mp_print(mp,")}"); + mp_end_diagnostic(mp, false); +} + +@ The |hard_times| routine multiplies a nice color or pair by a dependency list. + +@<Declare binary action procedures@>= +static void mp_hard_times (MP mp,pointer p) { + pointer q; /* a copy of the dependent variable |p| */ + pointer r; /* a component of the big node for the nice color or pair */ + scaled v; /* the known value for |r| */ + if ( mp_type(p)<=mp_pair_type ) { + q=mp_stash_cur_exp(mp); mp_unstash_cur_exp(mp, p); p=q; + }; /* now |cur_type=mp_pair_type| or |cur_type=mp_color_type| */ + r=value(mp->cur_exp)+mp->big_node_size[mp->cur_type]; + while (1) { + r=r-2; + v=value(r); + mp_type(r)=mp_type(p); + if ( r==value(mp->cur_exp) ) + break; + mp_new_dep(mp, r,mp_copy_dep_list(mp, dep_list(p))); + mp_dep_mult(mp, r,v,true); + } + mp->mem[value_loc(r)]=mp->mem[value_loc(p)]; + mp_link(prev_dep(p))=r; + mp_free_node(mp, p,value_node_size); + mp_dep_mult(mp, r,v,true); +} + +@ @<Additional cases of binary operators@>= +case over: + if ( (mp->cur_type!=mp_known)||(mp_type(p)<mp_color_type) ) { + mp_bad_binary(mp, p,over); + } else { + v=mp->cur_exp; mp_unstash_cur_exp(mp, p); + if ( v==0 ) { + @<Squeal about division by zero@>; + } else { + if ( mp->cur_type==mp_known ) { + mp->cur_exp=mp_make_scaled(mp, mp->cur_exp,v); + } else if ( mp->cur_type<=mp_pair_type ) { + p=value(mp->cur_exp)+mp->big_node_size[mp->cur_type]; + do { + p=p-2; mp_dep_div(mp, p,v); + } while (p!=value(mp->cur_exp)); + } else { + mp_dep_div(mp, null,v); + } + } + binary_return; + } + break; + +@ @<Declare binary action...@>= +static void mp_dep_div (MP mp,pointer p, scaled v) { + pointer q; /* the dependency list being divided by |v| */ + quarterword s,t; /* its type, before and after */ + if ( p==null ) q=mp->cur_exp; + else if ( mp_type(p)!=mp_known ) q=p; + else { value(p)=mp_make_scaled(mp, value(p),v); return; }; + t=mp_type(q); q=dep_list(q); s=t; + if ( t==mp_dependent ) + if ( mp_ab_vs_cd(mp, mp_max_coef(mp,q),unity,coef_bound-1,abs(v))>=0 ) + t=mp_proto_dependent; + q=mp_p_over_v(mp, q,v,s,t); + mp_dep_finish(mp, q,p,t); +} + +@ @<Squeal about division by zero@>= +{ + exp_err("Division by zero"); +@.Division by zero@> + help2("You're trying to divide the quantity shown above the error", + "message by zero. I'm going to divide it by one instead."); + mp_put_get_error(mp); +} + +@ @<Additional cases of binary operators@>= +case pythag_add: +case pythag_sub: + if ( (mp->cur_type==mp_known)&&(mp_type(p)==mp_known) ) { + if ( c==pythag_add ) mp->cur_exp=mp_pyth_add(mp, value(p),mp->cur_exp); + else mp->cur_exp=mp_pyth_sub(mp, value(p),mp->cur_exp); + } else mp_bad_binary(mp, p,c); + break; + +@ The next few sections of the program deal with affine transformations +of coordinate data. + +@<Additional cases of binary operators@>= +case rotated_by: case slanted_by: +case scaled_by: case shifted_by: case transformed_by: +case x_scaled: case y_scaled: case z_scaled: + if ( mp_type(p)==mp_path_type ) { + path_trans(c,p); binary_return; + } else if ( mp_type(p)==mp_pen_type ) { + pen_trans(c,p); + mp->cur_exp=mp_convex_hull(mp, mp->cur_exp); + /* rounding error could destroy convexity */ + binary_return; + } else if ( (mp_type(p)==mp_pair_type)||(mp_type(p)==mp_transform_type) ) { + mp_big_trans(mp, p,c); + } else if ( mp_type(p)==mp_picture_type ) { + mp_do_edges_trans(mp, p,c); binary_return; + } else { + mp_bad_binary(mp, p,c); + } + break; + +@ Let |c| be one of the eight transform operators. The procedure call +|set_up_trans(c)| first changes |cur_exp| to a transform that corresponds to +|c| and the original value of |cur_exp|. (In particular, |cur_exp| doesn't +change at all if |c=transformed_by|.) + +Then, if all components of the resulting transform are |known|, they are +moved to the global variables |txx|, |txy|, |tyx|, |tyy|, |tx|, |ty|; +and |cur_exp| is changed to the known value zero. + +@<Declare binary action...@>= +static void mp_set_up_trans (MP mp,quarterword c) { + pointer p,q,r; /* list manipulation registers */ + if ( (c!=transformed_by)||(mp->cur_type!=mp_transform_type) ) { + @<Put the current transform into |cur_exp|@>; + } + @<If the current transform is entirely known, stash it in global variables; + otherwise |return|@>; +} + +@ @<Glob...@>= +scaled txx; +scaled txy; +scaled tyx; +scaled tyy; +scaled tx; +scaled ty; /* current transform coefficients */ + +@ @<Put the current transform...@>= +{ + p=mp_stash_cur_exp(mp); + mp->cur_exp=mp_id_transform(mp); + mp->cur_type=mp_transform_type; + q=value(mp->cur_exp); + switch (c) { + @<For each of the eight cases, change the relevant fields of |cur_exp| + and |goto done|; + but do nothing if capsule |p| doesn't have the appropriate type@>; + }; /* there are no other cases */ + mp_disp_err(mp, p,"Improper transformation argument"); +@.Improper transformation argument@> + help3("The expression shown above has the wrong type,", + "so I can\'t transform anything using it.", + "Proceed, and I'll omit the transformation."); + mp_put_get_error(mp); +DONE: + mp_recycle_value(mp, p); + mp_free_node(mp, p,value_node_size); +} + +@ @<If the current transform is entirely known, ...@>= +q=value(mp->cur_exp); r=q+transform_node_size; +do { + r=r-2; + if ( mp_type(r)!=mp_known ) return; +} while (r!=q); +mp->txx=value(xx_part_loc(q)); +mp->txy=value(xy_part_loc(q)); +mp->tyx=value(yx_part_loc(q)); +mp->tyy=value(yy_part_loc(q)); +mp->tx=value(x_part_loc(q)); +mp->ty=value(y_part_loc(q)); +mp_flush_cur_exp(mp, 0) + +@ @<For each of the eight cases...@>= +case rotated_by: + if ( mp_type(p)==mp_known ) + @<Install sines and cosines, then |goto done|@>; + break; +case slanted_by: + if ( mp_type(p)>mp_pair_type ) { + mp_install(mp, xy_part_loc(q),p); goto DONE; + }; + break; +case scaled_by: + if ( mp_type(p)>mp_pair_type ) { + mp_install(mp, xx_part_loc(q),p); mp_install(mp, yy_part_loc(q),p); + goto DONE; + }; + break; +case shifted_by: + if ( mp_type(p)==mp_pair_type ) { + r=value(p); mp_install(mp, x_part_loc(q),x_part_loc(r)); + mp_install(mp, y_part_loc(q),y_part_loc(r)); goto DONE; + }; + break; +case x_scaled: + if ( mp_type(p)>mp_pair_type ) { + mp_install(mp, xx_part_loc(q),p); goto DONE; + }; + break; +case y_scaled: + if ( mp_type(p)>mp_pair_type ) { + mp_install(mp, yy_part_loc(q),p); goto DONE; + }; + break; +case z_scaled: + if ( mp_type(p)==mp_pair_type ) + @<Install a complex multiplier, then |goto done|@>; + break; +case transformed_by: + break; + + +@ @<Install sines and cosines, then |goto done|@>= +{ mp_n_sin_cos(mp, (value(p) % three_sixty_units)*16); + value(xx_part_loc(q))=mp_round_fraction(mp, mp->n_cos); + value(yx_part_loc(q))=mp_round_fraction(mp, mp->n_sin); + value(xy_part_loc(q))=-value(yx_part_loc(q)); + value(yy_part_loc(q))=value(xx_part_loc(q)); + goto DONE; +} + +@ @<Install a complex multiplier, then |goto done|@>= +{ + r=value(p); + mp_install(mp, xx_part_loc(q),x_part_loc(r)); + mp_install(mp, yy_part_loc(q),x_part_loc(r)); + mp_install(mp, yx_part_loc(q),y_part_loc(r)); + if ( mp_type(y_part_loc(r))==mp_known ) negate(value(y_part_loc(r))); + else mp_negate_dep_list(mp, dep_list(y_part_loc(r))); + mp_install(mp, xy_part_loc(q),y_part_loc(r)); + goto DONE; +} + +@ Procedure |set_up_known_trans| is like |set_up_trans|, but it +insists that the transformation be entirely known. + +@<Declare binary action...@>= +static void mp_set_up_known_trans (MP mp,quarterword c) { + mp_set_up_trans(mp, c); + if ( mp->cur_type!=mp_known ) { + exp_err("Transform components aren't all known"); +@.Transform components...@> + help3("I'm unable to apply a partially specified transformation", + "except to a fully known pair or transform.", + "Proceed, and I'll omit the transformation."); + mp_put_get_flush_error(mp, 0); + mp->txx=unity; mp->txy=0; mp->tyx=0; mp->tyy=unity; + mp->tx=0; mp->ty=0; + } +} + +@ Here's a procedure that applies the transform |txx..ty| to a pair of +coordinates in locations |p| and~|q|. + +@<Declare binary action...@>= +static void mp_trans (MP mp,pointer p, pointer q) { + scaled v; /* the new |x| value */ + v=mp_take_scaled(mp, mp->mem[p].sc,mp->txx)+ + mp_take_scaled(mp, mp->mem[q].sc,mp->txy)+mp->tx; + mp->mem[q].sc=mp_take_scaled(mp, mp->mem[p].sc,mp->tyx)+ + mp_take_scaled(mp, mp->mem[q].sc,mp->tyy)+mp->ty; + mp->mem[p].sc=v; +} + +@ The simplest transformation procedure applies a transform to all +coordinates of a path. The |path_trans(c)(p)| macro applies +a transformation defined by |cur_exp| and the transform operator |c| +to the path~|p|. + +@d path_trans(A,B) { mp_set_up_known_trans(mp, (A)); + mp_unstash_cur_exp(mp, (B)); + mp_do_path_trans(mp, mp->cur_exp); } + +@<Declare binary action...@>= +static void mp_do_path_trans (MP mp,pointer p) { + pointer q; /* list traverser */ + q=p; + do { + if ( mp_left_type(q)!=mp_endpoint ) + mp_trans(mp, q+3,q+4); /* that's |mp_left_x| and |mp_left_y| */ + mp_trans(mp, q+1,q+2); /* that's |mp_x_coord| and |mp_y_coord| */ + if ( mp_right_type(q)!=mp_endpoint ) + mp_trans(mp, q+5,q+6); /* that's |mp_right_x| and |mp_right_y| */ +@^data structure assumptions@> + q=mp_link(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, mp->cur_exp); } + +@<Declare binary action...@>= +static void mp_do_pen_trans (MP mp,pointer p) { + pointer q; /* list traverser */ + if ( pen_is_elliptical(p) ) { + mp_trans(mp, p+3,p+4); /* that's |mp_left_x| and |mp_left_y| */ + mp_trans(mp, p+5,p+6); /* that's |mp_right_x| and |mp_right_y| */ + }; + q=p; + do { + mp_trans(mp, q+1,q+2); /* that's |mp_x_coord| and |mp_y_coord| */ +@^data structure assumptions@> + q=mp_link(q); + } while (q!=p); +} + +@ The next transformation procedure applies to edge structures. It will do +any transformation, but the results may be substandard if the picture contains +text that uses downloaded bitmap fonts. The binary action procedure is +|do_edges_trans|, but we also need a function that just scales a picture. +That routine is |scale_edges|. Both it and the underlying routine |edges_trans| +should be thought of as procedures that update an edge structure |h|, except +that they have to return a (possibly new) structure because of the need to call +|private_edges|. + +@<Declare binary action...@>= +static pointer mp_edges_trans (MP mp, pointer h) { + pointer q; /* the object being transformed */ + pointer r,s; /* for list manipulation */ + scaled sx,sy; /* saved transformation parameters */ + scaled sqdet; /* square root of determinant for |dash_scale| */ + integer sgndet; /* sign of the determinant */ + scaled v; /* a temporary value */ + h=mp_private_edges(mp, h); + sqdet=mp_sqrt_det(mp, mp->txx,mp->txy,mp->tyx,mp->tyy); + sgndet=mp_ab_vs_cd(mp, mp->txx,mp->tyy,mp->txy,mp->tyx); + if ( dash_list(h)!=null_dash ) { + @<Try to transform the dash list of |h|@>; + } + @<Make the bounding box of |h| unknown if it can't be updated properly + without scanning the whole structure@>; + q=mp_link(dummy_loc(h)); + while ( q!=null ) { + @<Transform graphical object |q|@>; + q=mp_link(q); + } + return h; +} +static void mp_do_edges_trans (MP mp,pointer p, quarterword c) { + mp_set_up_known_trans(mp, c); + value(p)=mp_edges_trans(mp, value(p)); + mp_unstash_cur_exp(mp, p); +} +static void mp_scale_edges (MP mp) { + mp->txx=mp->se_sf; mp->tyy=mp->se_sf; + mp->txy=0; mp->tyx=0; mp->tx=0; mp->ty=0; + mp->se_pic=mp_edges_trans(mp, mp->se_pic); +} + +@ @<Try to transform the dash list of |h|@>= +if ( (mp->txy!=0)||(mp->tyx!=0)|| + (mp->ty!=0)||(abs(mp->txx)!=abs(mp->tyy))) { + mp_flush_dash_list(mp, h); +} else { + if ( mp->txx<0 ) { @<Reverse the dash list of |h|@>; } + @<Scale the dash list by |txx| and shift it by |tx|@>; + dash_y(h)=mp_take_scaled(mp, dash_y(h),abs(mp->tyy)); +} + +@ @<Reverse the dash list of |h|@>= +{ + r=dash_list(h); + dash_list(h)=null_dash; + while ( r!=null_dash ) { + s=r; r=mp_link(r); + v=start_x(s); start_x(s)=stop_x(s); stop_x(s)=v; + mp_link(s)=dash_list(h); + dash_list(h)=s; + } +} + +@ @<Scale the dash list by |txx| and shift it by |tx|@>= +r=dash_list(h); +while ( r!=null_dash ) { + start_x(r)=mp_take_scaled(mp, start_x(r),mp->txx)+mp->tx; + stop_x(r)=mp_take_scaled(mp, stop_x(r),mp->txx)+mp->tx; + r=mp_link(r); +} + +@ @<Make the bounding box of |h| unknown if it can't be updated properly...@>= +if ( (mp->txx==0)&&(mp->tyy==0) ) { + @<Swap the $x$ and $y$ parameters in the bounding box of |h|@>; +} else if ( (mp->txy!=0)||(mp->tyx!=0) ) { + mp_init_bbox(mp, h); + goto DONE1; +} +if ( minx_val(h)<=maxx_val(h) ) { + @<Scale the bounding box by |txx+txy| and |tyx+tyy|; then shift by + |(tx,ty)|@>; +} +DONE1: + + + +@ @<Swap the $x$ and $y$ parameters in the bounding box of |h|@>= +{ + v=minx_val(h); minx_val(h)=miny_val(h); miny_val(h)=v; + v=maxx_val(h); maxx_val(h)=maxy_val(h); maxy_val(h)=v; +} + +@ The sum ``|txx+txy|'' is whichever of |txx| or |txy| is nonzero. The other +sum is similar. + +@<Scale the bounding box by |txx+txy| and |tyx+tyy|; then shift...@>= +{ + minx_val(h)=mp_take_scaled(mp, minx_val(h),mp->txx+mp->txy)+mp->tx; + maxx_val(h)=mp_take_scaled(mp, maxx_val(h),mp->txx+mp->txy)+mp->tx; + miny_val(h)=mp_take_scaled(mp, miny_val(h),mp->tyx+mp->tyy)+mp->ty; + maxy_val(h)=mp_take_scaled(mp, maxy_val(h),mp->tyx+mp->tyy)+mp->ty; + if ( mp->txx+mp->txy<0 ) { + v=minx_val(h); minx_val(h)=maxx_val(h); maxx_val(h)=v; + } + if ( mp->tyx+mp->tyy<0 ) { + v=miny_val(h); miny_val(h)=maxy_val(h); maxy_val(h)=v; + } +} + +@ Now we ready for the main task of transforming the graphical objects in edge +structure~|h|. + +@<Transform graphical object |q|@>= +switch (mp_type(q)) { +case mp_fill_code: case mp_stroked_code: + mp_do_path_trans(mp, mp_path_p(q)); + @<Transform |mp_pen_p(q)|, making sure polygonal pens stay counter-clockwise@>; + break; +case mp_start_clip_code: case mp_start_bounds_code: + mp_do_path_trans(mp, mp_path_p(q)); + break; +case mp_text_code: + r=text_tx_loc(q); + @<Transform the compact transformation starting at |r|@>; + break; +case mp_stop_clip_code: case mp_stop_bounds_code: + break; +} /* there are no other cases */ + +@ Note that the shift parameters |(tx,ty)| apply only to the path being stroked. +The |dash_scale| has to be adjusted to scale the dash lengths in |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. + +@<Transform |mp_pen_p(q)|, making sure...@>= +if ( mp_pen_p(q)!=null ) { + sx=mp->tx; sy=mp->ty; + mp->tx=0; mp->ty=0; + mp_do_pen_trans(mp, mp_pen_p(q)); + if ( ((mp_type(q)==mp_stroked_code)&&(mp_dash_p(q)!=null)) ) + dash_scale(q)=mp_take_scaled(mp, dash_scale(q),sqdet); + if ( ! pen_is_elliptical(mp_pen_p(q)) ) + if ( sgndet<0 ) + mp_pen_p(q)=mp_make_pen(mp, mp_copy_path(mp, mp_pen_p(q)),true); + /* this unreverses the pen */ + mp->tx=sx; mp->ty=sy; +} + +@ This uses the fact that transformations are stored in the order +|(tx,ty,txx,txy,tyx,tyy)|. +@^data structure assumptions@> + +@<Transform the compact transformation starting at |r|@>= +mp_trans(mp, r,r+1); +sx=mp->tx; sy=mp->ty; +mp->tx=0; mp->ty=0; +mp_trans(mp, r+2,r+4); +mp_trans(mp, r+3,r+5); +mp->tx=sx; mp->ty=sy + +@ The hard cases of transformation occur when big nodes are involved, +and when some of their components are unknown. + +@<Declare binary action...@>= +@<Declare subroutines needed by |big_trans|@> +static void mp_big_trans (MP mp,pointer p, quarterword c) { + pointer q,r,pp,qq; /* list manipulation registers */ + quarterword s; /* size of a big node */ + s=mp->big_node_size[mp_type(p)]; q=value(p); r=q+s; + do { + r=r-2; + if ( mp_type(r)!=mp_known ) { + @<Transform an unknown big node and |return|@>; + } + } while (r!=q); + @<Transform a known big node@>; +} /* node |p| will now be recycled by |do_binary| */ + +@ @<Transform an unknown big node and |return|@>= +{ + mp_set_up_known_trans(mp, c); mp_make_exp_copy(mp, p); + r=value(mp->cur_exp); + if ( mp->cur_type==mp_transform_type ) { + mp_bilin1(mp, yy_part_loc(r),mp->tyy,xy_part_loc(q),mp->tyx,0); + mp_bilin1(mp, yx_part_loc(r),mp->tyy,xx_part_loc(q),mp->tyx,0); + mp_bilin1(mp, xy_part_loc(r),mp->txx,yy_part_loc(q),mp->txy,0); + mp_bilin1(mp, xx_part_loc(r),mp->txx,yx_part_loc(q),mp->txy,0); + } + mp_bilin1(mp, y_part_loc(r),mp->tyy,x_part_loc(q),mp->tyx,mp->ty); + mp_bilin1(mp, x_part_loc(r),mp->txx,y_part_loc(q),mp->txy,mp->tx); + return; +} + +@ Let |p| point to a two-word value field inside a big node of |cur_exp|, +and let |q| point to a another value field. The |bilin1| procedure +replaces |p| by $p\cdot t+q\cdot u+\delta$. + +@<Declare subroutines needed by |big_trans|@>= +static void mp_bilin1 (MP mp, pointer p, scaled t, pointer q, + scaled u, scaled delta) { + pointer r; /* list traverser */ + if ( t!=unity ) mp_dep_mult(mp, p,t,true); + if ( u!=0 ) { + if ( mp_type(q)==mp_known ) { + delta+=mp_take_scaled(mp, value(q),u); + } else { + @<Ensure that |type(p)=mp_proto_dependent|@>; + dep_list(p)=mp_p_plus_fq(mp, dep_list(p),u,dep_list(q), + mp_proto_dependent,mp_type(q)); + } + } + if ( mp_type(p)==mp_known ) { + value(p)+=delta; + } else { + r=dep_list(p); + while ( mp_info(r)!=null ) r=mp_link(r); + delta+=value(r); + if ( r!=dep_list(p) ) value(r)=delta; + else { mp_recycle_value(mp, p); mp_type(p)=mp_known; value(p)=delta; }; + } + if ( mp->fix_needed ) mp_fix_dependencies(mp); +} + +@ @<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_const_dependency(mp, value(p))); + else + dep_list(p)=mp_p_times_v(mp, dep_list(p),unity,mp_dependent, + mp_proto_dependent,true); + mp_type(p)=mp_proto_dependent; +} + +@ @<Transform a known big node@>= +mp_set_up_trans(mp, c); +if ( mp->cur_type==mp_known ) { + @<Transform known by known@>; +} else { + pp=mp_stash_cur_exp(mp); qq=value(pp); + mp_make_exp_copy(mp, p); r=value(mp->cur_exp); + if ( mp->cur_type==mp_transform_type ) { + mp_bilin2(mp, yy_part_loc(r),yy_part_loc(qq), + value(xy_part_loc(q)),yx_part_loc(qq),null); + mp_bilin2(mp, yx_part_loc(r),yy_part_loc(qq), + value(xx_part_loc(q)),yx_part_loc(qq),null); + mp_bilin2(mp, xy_part_loc(r),xx_part_loc(qq), + value(yy_part_loc(q)),xy_part_loc(qq),null); + mp_bilin2(mp, xx_part_loc(r),xx_part_loc(qq), + value(yx_part_loc(q)),xy_part_loc(qq),null); + }; + mp_bilin2(mp, y_part_loc(r),yy_part_loc(qq), + value(x_part_loc(q)),yx_part_loc(qq),y_part_loc(qq)); + mp_bilin2(mp, x_part_loc(r),xx_part_loc(qq), + value(y_part_loc(q)),xy_part_loc(qq),x_part_loc(qq)); + mp_recycle_value(mp, pp); mp_free_node(mp, pp,value_node_size); +} + +@ Let |p| be a |mp_proto_dependent| value whose dependency list ends +at |dep_final|. The following procedure adds |v| times another +numeric quantity to~|p|. + +@<Declare subroutines needed by |big_trans|@>= +static void mp_add_mult_dep (MP mp,pointer p, scaled v, pointer r) { + if ( mp_type(r)==mp_known ) { + value(mp->dep_final)+=mp_take_scaled(mp, value(r),v); + } else { + dep_list(p)=mp_p_plus_fq(mp, dep_list(p),v,dep_list(r), + mp_proto_dependent,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,pointer p, pointer t, scaled v, + pointer u, pointer q) { + scaled vv; /* temporary storage for |value(p)| */ + vv=value(p); mp_type(p)=mp_proto_dependent; + mp_new_dep(mp, p,mp_const_dependency(mp, 0)); /* this sets |dep_final| */ + if ( vv!=0 ) + mp_add_mult_dep(mp, p,vv,t); /* |dep_final| doesn't change */ + if ( v!=0 ) mp_add_mult_dep(mp, p,v,u); + if ( q!=null ) mp_add_mult_dep(mp, p,unity,q); + if ( dep_list(p)==mp->dep_final ) { + vv=value(mp->dep_final); mp_recycle_value(mp, p); + mp_type(p)=mp_known; value(p)=vv; + } +} + +@ @<Transform known by known@>= +{ + mp_make_exp_copy(mp, p); r=value(mp->cur_exp); + if ( mp->cur_type==mp_transform_type ) { + mp_bilin3(mp, yy_part_loc(r),mp->tyy,value(xy_part_loc(q)),mp->tyx,0); + mp_bilin3(mp, yx_part_loc(r),mp->tyy,value(xx_part_loc(q)),mp->tyx,0); + mp_bilin3(mp, xy_part_loc(r),mp->txx,value(yy_part_loc(q)),mp->txy,0); + mp_bilin3(mp, xx_part_loc(r),mp->txx,value(yx_part_loc(q)),mp->txy,0); + } + mp_bilin3(mp, y_part_loc(r),mp->tyy,value(x_part_loc(q)),mp->tyx,mp->ty); + mp_bilin3(mp, x_part_loc(r),mp->txx,value(y_part_loc(q)),mp->txy,mp->tx); +} + +@ Finally, in |bilin3| everything is |known|. + +@<Declare subroutines needed by |big_trans|@>= +static void mp_bilin3 (MP mp,pointer p, scaled t, + scaled v, scaled u, scaled delta) { + if ( t!=unity ) + delta+=mp_take_scaled(mp, value(p),t); + else + delta+=value(p); + if ( u!=0 ) value(p)=delta+mp_take_scaled(mp, v,u); + else value(p)=delta; +} + +@ @<Additional cases of binary operators@>= +case concatenate: + if ( (mp->cur_type==mp_string_type)&&(mp_type(p)==mp_string_type) ) mp_cat(mp, p); + else mp_bad_binary(mp, p,concatenate); + break; +case substring_of: + if ( mp_nice_pair(mp, p,mp_type(p))&&(mp->cur_type==mp_string_type) ) + mp_chop_string(mp, value(p)); + else mp_bad_binary(mp, p,substring_of); + break; +case subpath_of: + if ( mp->cur_type==mp_pair_type ) mp_pair_to_path(mp); + if ( mp_nice_pair(mp, p,mp_type(p))&&(mp->cur_type==mp_path_type) ) + mp_chop_path(mp, value(p)); + else mp_bad_binary(mp, p,subpath_of); + break; + +@ @<Declare binary action...@>= +static void mp_cat (MP mp,pointer p) { + str_number a,b; /* the strings being concatenated */ + integer k; /* run length */ + integer needed; + a=value(p); b=mp->cur_exp; k=length(a); + needed=mp->pool_ptr+k+length(b); + /* this will free some memory, hopefully */ + if (mp->pool_ptr>(11*mp->old_pool_size)/10) { + mp->old_pool_size = mp->pool_ptr; + mp_do_compaction(mp, mp->pool_size); + } + if ( needed > mp->max_pool_ptr ) { + if ( needed > mp->pool_size ) { + mp_reallocate_pool(mp,needed); + } + mp->max_pool_ptr=needed; + } + memcpy(mp->str_pool+mp->pool_ptr, mp->str_pool+mp->str_start[a],(size_t)k); + mp->pool_ptr+=k; + k=length(b); + memcpy(mp->str_pool+mp->pool_ptr, mp->str_pool+mp->str_start[b],(size_t)k); + mp->pool_ptr+=k; + mp->cur_exp=mp_make_string(mp); delete_str_ref(b); +} + +@ @<Declare binary action...@>= +static void mp_chop_string (MP mp,pointer p) { + integer a, b; /* start and stop points */ + integer l; /* length of the original string */ + integer k; /* runs from |a| to |b| */ + str_number s; /* the original string */ + boolean reversed; /* was |a>b|? */ + a=mp_round_unscaled(mp, value(x_part_loc(p))); + b=mp_round_unscaled(mp, value(y_part_loc(p))); + if ( a<=b ) reversed=false; + else { reversed=true; k=a; a=b; b=k; }; + s=mp->cur_exp; l=length(s); + if ( a<0 ) { + a=0; + if ( b<0 ) b=0; + } + if ( b>l ) { + b=l; + if ( a>l ) a=l; + } + str_room(b-a); + if ( reversed ) { + for (k=mp->str_start[s]+b-1;k>=mp->str_start[s]+a;k--) { + append_char(mp->str_pool[k]); + } + } else { + for (k=mp->str_start[s]+a;k<mp->str_start[s]+b;k++) { + append_char(mp->str_pool[k]); + } + } + mp->cur_exp=mp_make_string(mp); delete_str_ref(s); +} + +@ @<Declare binary action...@>= +static void mp_chop_path (MP mp,pointer p) { + pointer q; /* a knot in the original path */ + pointer pp,qq,rr,ss; /* link variables for copies of path nodes */ + scaled a,b,k,l; /* indices for chopping */ + boolean reversed; /* was |a>b|? */ + l=mp_path_length(mp); a=value(x_part_loc(p)); b=value(y_part_loc(p)); + if ( a<=b ) reversed=false; + else { reversed=true; k=a; a=b; b=k; }; + @<Dispense with the cases |a<0| and/or |b>l|@>; + q=mp->cur_exp; + while ( a>=unity ) { + q=mp_link(q); a=a-unity; b=b-unity; + } + if ( b==a ) { + @<Construct a path from |pp| to |qq| of length zero@>; + } else { + @<Construct a path from |pp| to |qq| of length $\lceil b\rceil$@>; + } + mp_left_type(pp)=mp_endpoint; mp_right_type(qq)=mp_endpoint; mp_link(qq)=pp; + mp_toss_knot_list(mp, mp->cur_exp); + if ( reversed ) { + mp->cur_exp=mp_link(mp_htap_ypoc(mp, pp)); mp_toss_knot_list(mp, pp); + } else { + mp->cur_exp=pp; + } +} + +@ @<Dispense with the cases |a<0| and/or |b>l|@>= +if ( a<0 ) { + if ( mp_left_type(mp->cur_exp)==mp_endpoint ) { + a=0; if ( b<0 ) b=0; + } else { + do { a=a+l; b=b+l; } while (a<0); /* a cycle always has length |l>0| */ + } +} +if ( b>l ) { + if ( mp_left_type(mp->cur_exp)==mp_endpoint ) { + b=l; if ( a>l ) a=l; + } else { + while ( a>=l ) { + a=a-l; b=b-l; + } + } +} + +@ @<Construct a path from |pp| to |qq| of length $\lceil b\rceil$@>= +{ + pp=mp_copy_knot(mp, q); qq=pp; + do { + q=mp_link(q); rr=qq; qq=mp_copy_knot(mp, q); mp_link(rr)=qq; b=b-unity; + } while (b>0); + if ( a>0 ) { + ss=pp; pp=mp_link(pp); + mp_split_cubic(mp, ss,a*010000); pp=mp_link(ss); + mp_free_node(mp, ss,knot_node_size); + if ( rr==ss ) { + b=mp_make_scaled(mp, b,unity-a); rr=pp; + } + } + if ( b<0 ) { + mp_split_cubic(mp, rr,(b+unity)*010000); + mp_free_node(mp, qq,knot_node_size); + qq=mp_link(rr); + } +} + +@ @<Construct a path from |pp| to |qq| of length zero@>= +{ + if ( a>0 ) { mp_split_cubic(mp, q,a*010000); q=mp_link(q); }; + pp=mp_copy_knot(mp, q); qq=pp; +} + +@ @<Additional cases of binary operators@>= +case point_of: case precontrol_of: case postcontrol_of: + if ( mp->cur_type==mp_pair_type ) + mp_pair_to_path(mp); + if ( (mp->cur_type==mp_path_type)&&(mp_type(p)==mp_known) ) + mp_find_point(mp, value(p),c); + else + mp_bad_binary(mp, p,c); + break; +case pen_offset_of: + if ( (mp->cur_type==mp_pen_type)&& mp_nice_pair(mp, p,mp_type(p)) ) + mp_set_up_offset(mp, value(p)); + else + mp_bad_binary(mp, p,pen_offset_of); + break; +case direction_time_of: + if ( mp->cur_type==mp_pair_type ) mp_pair_to_path(mp); + if ( (mp->cur_type==mp_path_type)&& mp_nice_pair(mp, p,mp_type(p)) ) + mp_set_up_direction_time(mp, value(p)); + else + mp_bad_binary(mp, p,direction_time_of); + break; +case envelope_of: + if ( (mp_type(p) != mp_pen_type) || (mp->cur_type != mp_path_type) ) + mp_bad_binary(mp, p,envelope_of); + else + mp_set_up_envelope(mp, p); + break; + +@ @<Declare binary action...@>= +static void mp_set_up_offset (MP mp,pointer p) { + mp_find_offset(mp, value(x_part_loc(p)),value(y_part_loc(p)),mp->cur_exp); + mp_pair_value(mp, mp->cur_x,mp->cur_y); +} +static void mp_set_up_direction_time (MP mp,pointer p) { + mp_flush_cur_exp(mp, mp_find_direction_time(mp, value(x_part_loc(p)), + value(y_part_loc(p)),mp->cur_exp)); +} +static void mp_set_up_envelope (MP mp,pointer p) { + quarterword ljoin, lcap; + scaled miterlim; + pointer q = mp_copy_path(mp, mp->cur_exp); /* the original path */ + /* TODO: accept elliptical pens for straight paths */ + if (pen_is_elliptical(value(p))) { + mp_bad_envelope_pen(mp); + mp->cur_exp = q; + mp->cur_type = mp_path_type; + return; + } + if ( mp->internal[mp_linejoin]>unity ) ljoin=2; + else if ( mp->internal[mp_linejoin]>0 ) ljoin=1; + else ljoin=0; + if ( mp->internal[mp_linecap]>unity ) lcap=2; + else if ( mp->internal[mp_linecap]>0 ) lcap=1; + else lcap=0; + if ( mp->internal[mp_miterlimit]<unity ) + miterlim=unity; + else + miterlim=mp->internal[mp_miterlimit]; + mp->cur_exp = mp_make_envelope(mp, q, value(p), ljoin,lcap,miterlim); + mp->cur_type = mp_path_type; +} + +@ @<Declare binary action...@>= +static void mp_find_point (MP mp,scaled v, quarterword c) { + pointer p; /* the path */ + scaled n; /* its length */ + p=mp->cur_exp; + if ( mp_left_type(p)==mp_endpoint ) n=-unity; else n=0; + do { p=mp_link(p); n=n+unity; } while (p!=mp->cur_exp); + if ( n==0 ) { + v=0; + } else if ( v<0 ) { + if ( mp_left_type(p)==mp_endpoint ) v=0; + else v=n-1-((-v-1) % n); + } else if ( v>n ) { + if ( mp_left_type(p)==mp_endpoint ) v=n; + else v=v % n; + } + p=mp->cur_exp; + while ( v>=unity ) { p=mp_link(p); v=v-unity; }; + if ( v!=0 ) { + @<Insert a fractional node by splitting the cubic@>; + } + @<Set the current expression to the desired path coordinates@>; +} + +@ @<Insert a fractional node...@>= +{ mp_split_cubic(mp, p,v*010000); p=mp_link(p); } + +@ @<Set the current expression to the desired path coordinates...@>= +switch (c) { +case point_of: + mp_pair_value(mp, mp_x_coord(p),mp_y_coord(p)); + break; +case precontrol_of: + if ( mp_left_type(p)==mp_endpoint ) mp_pair_value(mp, mp_x_coord(p),mp_y_coord(p)); + else mp_pair_value(mp, mp_left_x(p),mp_left_y(p)); + break; +case postcontrol_of: + if ( mp_right_type(p)==mp_endpoint ) mp_pair_value(mp, mp_x_coord(p),mp_y_coord(p)); + else mp_pair_value(mp, mp_right_x(p),mp_right_y(p)); + break; +} /* there are no other cases */ + +@ @<Additional cases of binary operators@>= +case arc_time_of: + if ( mp->cur_type==mp_pair_type ) + mp_pair_to_path(mp); + if ( (mp->cur_type==mp_path_type)&&(mp_type(p)==mp_known) ) + mp_flush_cur_exp(mp, mp_get_arc_time(mp, mp->cur_exp,value(p))); + else + mp_bad_binary(mp, p,c); + break; + +@ @<Additional cases of bin...@>= +case intersect: + if ( 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_type==mp_pair_type ) mp_pair_to_path(mp); + if ( (mp->cur_type==mp_path_type)&&(mp_type(p)==mp_path_type) ) { + mp_path_intersection(mp, value(p),mp->cur_exp); + mp_pair_value(mp, mp->cur_t,mp->cur_tt); + } else { + mp_bad_binary(mp, p,intersect); + } + break; + +@ @<Additional cases of bin...@>= +case in_font: + if ( (mp->cur_type!=mp_string_type)||(mp_type(p)!=mp_string_type)) + mp_bad_binary(mp, p,in_font); + else { mp_do_infont(mp, p); binary_return; } + break; + +@ Function |new_text_node| owns the reference count for its second argument +(the text string) but not its first (the font name). + +@<Declare binary action...@>= +static void mp_do_infont (MP mp,pointer p) { + pointer q; + q=mp_get_node(mp, edge_header_size); + mp_init_edges(mp, q); + mp_link(obj_tail(q))=mp_new_text_node(mp,str(mp->cur_exp),value(p)); + obj_tail(q)=mp_link(obj_tail(q)); + mp_free_node(mp, p,value_node_size); + mp_flush_cur_exp(mp, q); + mp->cur_type=mp_picture_type; +} + +@* \[40] Statements and commands. +The chief executive of \MP\ is the |do_statement| routine, which +contains the master switch that causes all the various pieces of \MP\ +to do their things, in the right order. + +In a sense, this is the grand climax of the program: It applies all the +tools that we have worked so hard to construct. In another sense, this is +the messiest part of the program: It necessarily refers to other pieces +of code all over the place, so that a person can't fully understand what is +going on without paging back and forth to be reminded of conventions that +are defined elsewhere. We are now at the hub of the web. + +The structure of |do_statement| itself is quite simple. The first token +of the statement is fetched using |get_x_next|. If it can be the first +token of an expression, we look for an equation, an assignment, or a +title. Otherwise we use a \&{case} construction to branch at high speed to +the appropriate routine for various and sundry other types of commands, +each of which has an ``action procedure'' that does the necessary work. + +The program uses the fact that +$$\hbox{|min_primary_command=max_statement_command=type_name|}$$ +to interpret a statement that starts with, e.g., `\&{string}', +as a type declaration rather than a boolean expression. + +@c void mp_do_statement (MP mp) { /* governs \MP's activities */ + mp->cur_type=mp_vacuous; mp_get_x_next(mp); + if ( mp->cur_cmd>max_primary_command ) { + @<Worry about bad statement@>; + } else if ( mp->cur_cmd>max_statement_command ) { + @<Do an equation, assignment, title, or + `$\langle\,$expression$\,\rangle\,$\&{endgroup}'@>; + } else { + @<Do a statement that doesn't begin with an expression@>; + } + if ( mp->cur_cmd<semicolon ) + @<Flush unparsable junk that was found after the statement@>; + mp->error_count=0; +} + +@ @<Declarations@>= +@<Declare action procedures for use by |do_statement|@> + +@ The only command codes |>max_primary_command| that can be present +at the beginning of a statement are |semicolon| and higher; these +occur when the statement is null. + +@<Worry about bad statement@>= +{ + if ( mp->cur_cmd<semicolon ) { + print_err("A statement can't begin with `"); +@.A statement can't begin with x@> + mp_print_cmd_mod(mp, mp->cur_cmd,mp->cur_mod); mp_print_char(mp, xord('\'')); + help5("I was looking for the beginning of a new statement.", + "If you just proceed without changing anything, I'll ignore", + "everything up to the next `;'. Please insert a semicolon", + "now in front of anything that you don't want me to delete.", + "(See Chapter 27 of The METAFONTbook for an example.)"); +@:METAFONTbook}{\sl The {\logos METAFONT\/}book@> + mp_back_error(mp); mp_get_x_next(mp); + } +} + +@ The help message printed here says that everything is flushed up to +a semicolon, but actually the commands |end_group| and |stop| will +also terminate a statement. + +@<Flush unparsable junk that was found after the statement@>= +{ + print_err("Extra tokens will be flushed"); +@.Extra tokens will be flushed@> + help6("I've just read as much of that statement as I could fathom,", + "so a semicolon should have been next. It's very puzzling...", + "but I'll try to get myself back together, by ignoring", + "everything up to the next `;'. Please insert a semicolon", + "now in front of anything that you don't want me to delete.", + "(See Chapter 27 of The METAFONTbook for an example.)"); +@:METAFONTbook}{\sl The {\logos METAFONT\/}book@> + mp_back_error(mp); mp->scanner_status=flushing; + do { + get_t_next; + @<Decrease the string reference count...@>; + } while (! end_of_statement); /* |cur_cmd=semicolon|, |end_group|, or |stop| */ + mp->scanner_status=normal; +} + +@ If |do_statement| ends with |cur_cmd=end_group|, we should have +|cur_type=mp_vacuous| unless the statement was simply an expression; +in the latter case, |cur_type| and |cur_exp| should represent that +expression. + +@<Do a statement that doesn't...@>= +{ + if ( mp->internal[mp_tracing_commands]>0 ) + show_cur_cmd_mod; + switch (mp->cur_cmd ) { + case type_name:mp_do_type_declaration(mp); break; + case macro_def: + if ( mp->cur_mod>var_def ) mp_make_op_def(mp); + else if ( mp->cur_mod>end_def ) mp_scan_def(mp); + break; + @<Cases of |do_statement| that invoke particular commands@>; + } /* there are no other cases */ + mp->cur_type=mp_vacuous; +} + +@ The most important statements begin with expressions. + +@<Do an equation, assignment, title, or...@>= +{ + mp->var_flag=assignment; mp_scan_expression(mp); + if ( mp->cur_cmd<end_group ) { + if ( mp->cur_cmd==equals ) mp_do_equation(mp); + else if ( mp->cur_cmd==assignment ) mp_do_assignment(mp); + else if ( mp->cur_type==mp_string_type ) {@<Do a title@> ; } + else if ( mp->cur_type!=mp_vacuous ){ + exp_err("Isolated expression"); +@.Isolated expression@> + help3("I couldn't find an `=' or `:=' after the", + "expression that is shown above this error message,", + "so I guess I'll just ignore it and carry on."); + mp_put_get_error(mp); + } + mp_flush_cur_exp(mp, 0); mp->cur_type=mp_vacuous; + } +} + +@ @<Do a title@>= +{ + if ( mp->internal[mp_tracing_titles]>0 ) { + mp_print_nl(mp, ""); mp_print_str(mp, mp->cur_exp); update_terminal; + } +} + +@ Equations and assignments are performed by the pair of mutually recursive +@^recursion@> +routines |do_equation| and |do_assignment|. These routines are called when +|cur_cmd=equals| and when |cur_cmd=assignment|, respectively; the left-hand +side is in |cur_type| and |cur_exp|, while the right-hand side is yet +to be scanned. After the routines are finished, |cur_type| and |cur_exp| +will be equal to the right-hand side (which will normally be equal +to the left-hand side). + +@<Declarations@>= +@<Declare the procedure called |make_eq|@> +static void mp_do_equation (MP mp) ; + +@ @c +void mp_do_equation (MP mp) { + pointer lhs; /* capsule for the left-hand side */ + pointer p; /* temporary register */ + lhs=mp_stash_cur_exp(mp); mp_get_x_next(mp); + mp->var_flag=assignment; mp_scan_expression(mp); + if ( mp->cur_cmd==equals ) mp_do_equation(mp); + else if ( mp->cur_cmd==assignment ) mp_do_assignment(mp); + if ( mp->internal[mp_tracing_commands]>two ) + @<Trace the current equation@>; + if ( mp->cur_type==mp_unknown_path ) if ( mp_type(lhs)==mp_pair_type ) { + p=mp_stash_cur_exp(mp); mp_unstash_cur_exp(mp, lhs); lhs=p; + }; /* in this case |make_eq| will change the pair to a path */ + mp_make_eq(mp, lhs); /* equate |lhs| to |(cur_type,cur_exp)| */ +} + +@ And |do_assignment| is similar to |do_equation|: + +@<Declarations@>= +static void mp_do_assignment (MP mp); + +@ @c +void mp_do_assignment (MP mp) { + pointer lhs; /* token list for the left-hand side */ + pointer p; /* where the left-hand value is stored */ + pointer q; /* temporary capsule for the right-hand value */ + if ( mp->cur_type!=mp_token_list ) { + exp_err("Improper `:=' will be changed to `='"); +@.Improper `:='@> + help2("I didn't find a variable name at the left of the `:=',", + "so I'm going to pretend that you said `=' instead."); + mp_error(mp); mp_do_equation(mp); + } else { + lhs=mp->cur_exp; mp->cur_type=mp_vacuous; + mp_get_x_next(mp); mp->var_flag=assignment; mp_scan_expression(mp); + if ( mp->cur_cmd==equals ) mp_do_equation(mp); + else if ( mp->cur_cmd==assignment ) mp_do_assignment(mp); + if ( mp->internal[mp_tracing_commands]>two ) + @<Trace the current assignment@>; + if ( mp_info(lhs)>hash_end ) { + @<Assign the current expression to an internal variable@>; + } else { + @<Assign the current expression to the variable |lhs|@>; + } + mp_flush_node_list(mp, lhs); + } +} + +@ @<Trace the current equation@>= +{ + mp_begin_diagnostic(mp); mp_print_nl(mp, "{("); mp_print_exp(mp,lhs,0); + mp_print(mp,")=("); mp_print_exp(mp,null,0); + mp_print(mp,")}"); mp_end_diagnostic(mp, false); +} + +@ @<Trace the current assignment@>= +{ + mp_begin_diagnostic(mp); mp_print_nl(mp, "{"); + if ( mp_info(lhs)>hash_end ) + mp_print(mp, mp->int_name[mp_info(lhs)-(hash_end)]); + else + mp_show_token_list(mp, lhs,null,1000,0); + mp_print(mp, ":="); mp_print_exp(mp, null,0); + mp_print_char(mp, xord('}')); mp_end_diagnostic(mp, false); +} + +@ @<Assign the current expression to an internal variable@>= +if ( mp->cur_type==mp_known || mp->cur_type==mp_string_type ) { + if (mp->cur_type==mp_string_type) + add_str_ref(mp->cur_exp); + mp->internal[mp_info(lhs)-(hash_end)]=mp->cur_exp; +} else { + exp_err("Internal quantity `"); +@.Internal quantity...@> + mp_print(mp, mp->int_name[mp_info(lhs)-(hash_end)]); + mp_print(mp, "' must receive a known value"); + help2("I can\'t set an internal quantity to anything but a known", + "numeric value, so I'll have to ignore this assignment."); + mp_put_get_error(mp); +} + +@ @<Assign the current expression to the variable |lhs|@>= +{ + p=mp_find_variable(mp, lhs); + if ( p!=null ) { + q=mp_stash_cur_exp(mp); mp->cur_type=mp_und_type(mp, p); + mp_recycle_value(mp, p); + mp_type(p)=mp->cur_type; value(p)=null; mp_make_exp_copy(mp, p); + p=mp_stash_cur_exp(mp); mp_unstash_cur_exp(mp, q); mp_make_eq(mp, p); + } else { + mp_obliterated(mp, lhs); mp_put_get_error(mp); + } +} + + +@ And now we get to the nitty-gritty. The |make_eq| procedure is given +a pointer to a capsule that is to be equated to the current expression. + +@<Declare the procedure called |make_eq|@>= +static void mp_make_eq (MP mp,pointer lhs) ; + + +@ +@c void mp_make_eq (MP mp,pointer lhs) { + quarterword t; /* type of the left-hand side */ + pointer p,q; /* pointers inside of big nodes */ + integer v=0; /* value of the left-hand side */ +RESTART: + t=mp_type(lhs); + if ( t<=mp_pair_type ) v=value(lhs); + switch (t) { + @<For each type |t|, make an equation and |goto done| unless |cur_type| + is incompatible with~|t|@>; + } /* all cases have been listed */ + @<Announce that the equation cannot be performed@>; +DONE: + check_arith; mp_recycle_value(mp, lhs); + mp_free_node(mp, lhs,value_node_size); +} + +@ @<Announce that the equation cannot be performed@>= +mp_disp_err(mp, lhs,""); +exp_err("Equation cannot be performed ("); +@.Equation cannot be performed@> +if ( mp_type(lhs)<=mp_pair_type ) mp_print_type(mp, mp_type(lhs)); +else mp_print(mp, "numeric"); +mp_print_char(mp, xord('=')); +if ( mp->cur_type<=mp_pair_type ) mp_print_type(mp, mp->cur_type); +else mp_print(mp, "numeric"); +mp_print_char(mp, xord(')')); +help2("I'm sorry, but I don't know how to make such things equal.", + "(See the two expressions just above the error message.)"); +mp_put_get_error(mp) + +@ @<For each type |t|, make an equation and |goto done| unless...@>= +case mp_boolean_type: case mp_string_type: case mp_pen_type: +case mp_path_type: case mp_picture_type: + if ( mp->cur_type==t+unknown_tag ) { + mp_nonlinear_eq(mp, v,mp->cur_exp,false); + mp_unstash_cur_exp(mp, mp->cur_exp); goto DONE; + } else if ( mp->cur_type==t ) { + @<Report redundant or inconsistent equation and |goto done|@>; + } + break; +case unknown_types: + if ( mp->cur_type==t-unknown_tag ) { + mp_nonlinear_eq(mp, mp->cur_exp,lhs,true); goto DONE; + } else if ( mp->cur_type==t ) { + mp_ring_merge(mp, lhs,mp->cur_exp); goto DONE; + } else if ( mp->cur_type==mp_pair_type ) { + if ( t==mp_unknown_path ) { + mp_pair_to_path(mp); goto RESTART; + }; + } + break; +case mp_transform_type: case mp_color_type: +case mp_cmykcolor_type: case mp_pair_type: + if ( mp->cur_type==t ) { + @<Do multiple equations and |goto done|@>; + } + break; +case mp_known: case mp_dependent: +case mp_proto_dependent: case mp_independent: + if ( mp->cur_type>=mp_known ) { + mp_try_eq(mp, lhs,null); goto DONE; + }; + break; +case mp_vacuous: + break; + +@ @<Report redundant or inconsistent equation and |goto done|@>= +{ + if ( mp->cur_type<=mp_string_type ) { + if ( mp->cur_type==mp_string_type ) { + if ( mp_str_vs_str(mp, v,mp->cur_exp)!=0 ) { + goto NOT_FOUND; + } + } else if ( v!=mp->cur_exp ) { + goto NOT_FOUND; + } + @<Exclaim about a redundant equation@>; goto DONE; + } + print_err("Redundant or inconsistent equation"); +@.Redundant or inconsistent equation@> + help2("An equation between already-known quantities can't help.", + "But don't worry; continue and I'll just ignore it."); + mp_put_get_error(mp); goto DONE; +NOT_FOUND: + print_err("Inconsistent equation"); +@.Inconsistent equation@> + help2("The equation I just read contradicts what was said before.", + "But don't worry; continue and I'll just ignore it."); + mp_put_get_error(mp); goto DONE; +} + +@ @<Do multiple equations and |goto done|@>= +{ + p=v+mp->big_node_size[t]; + q=value(mp->cur_exp)+mp->big_node_size[t]; + do { + p=p-2; q=q-2; mp_try_eq(mp, p,q); + } while (p!=v); + goto DONE; +} + +@ The first argument to |try_eq| is the location of a value node +in a capsule that will soon be recycled. The second argument is +either a location within a pair or transform node pointed to by +|cur_exp|, or it is |null| (which means that |cur_exp| itself +serves as the second argument). The idea is to leave |cur_exp| unchanged, +but to equate the two operands. + +@<Declarations@>= +static void mp_try_eq (MP mp,pointer l, pointer r) ; + +@ +@c void mp_try_eq (MP mp,pointer l, pointer r) { + pointer p; /* dependency list for right operand minus left operand */ + int t; /* the type of list |p| */ + pointer q; /* the constant term of |p| is here */ + pointer pp; /* dependency list for right operand */ + int tt; /* the type of list |pp| */ + boolean copied; /* have we copied a list that ought to be recycled? */ + @<Remove the left operand from its container, negate it, and + put it into dependency list~|p| with constant term~|q|@>; + @<Add the right operand to list |p|@>; + if ( mp_info(p)==null ) { + @<Deal with redundant or inconsistent equation@>; + } else { + mp_linear_eq(mp, p,t); + if ( r==null ) if ( mp->cur_type!=mp_known ) { + if ( mp_type(mp->cur_exp)==mp_known ) { + pp=mp->cur_exp; mp->cur_exp=value(mp->cur_exp); mp->cur_type=mp_known; + mp_free_node(mp, pp,value_node_size); + } + } + } +} + +@ @<Remove the left operand from its container, negate it, and...@>= +t=mp_type(l); +if ( t==mp_known ) { + t=mp_dependent; p=mp_const_dependency(mp, -value(l)); q=p; +} else if ( t==mp_independent ) { + t=mp_dependent; p=mp_single_dependency(mp, l); negate(value(p)); + q=mp->dep_final; +} else { + p=dep_list(l); q=p; + while (1) { + negate(value(q)); + if ( mp_info(q)==null ) break; + q=mp_link(q); + } + mp_link(prev_dep(l))=mp_link(q); prev_dep(mp_link(q))=prev_dep(l); + mp_type(l)=mp_known; +} + +@ @<Deal with redundant or inconsistent equation@>= +{ + if ( abs(value(p))>64 ) { /* off by .001 or more */ + print_err("Inconsistent equation"); +@.Inconsistent equation@> + mp_print(mp, " (off by "); mp_print_scaled(mp, value(p)); + mp_print_char(mp, xord(')')); + help2("The equation I just read contradicts what was said before.", + "But don't worry; continue and I'll just ignore it."); + mp_put_get_error(mp); + } else if ( r==null ) { + @<Exclaim about a redundant equation@>; + } + mp_free_node(mp, p,dep_node_size); +} + +@ @<Add the right operand to list |p|@>= +if ( r==null ) { + if ( mp->cur_type==mp_known ) { + value(q)=value(q)+mp->cur_exp; goto DONE1; + } else { + tt=mp->cur_type; + if ( tt==mp_independent ) pp=mp_single_dependency(mp, mp->cur_exp); + else pp=dep_list(mp->cur_exp); + } +} else { + if ( mp_type(r)==mp_known ) { + value(q)=value(q)+value(r); goto DONE1; + } else { + tt=mp_type(r); + if ( tt==mp_independent ) pp=mp_single_dependency(mp, r); + else pp=dep_list(r); + } +} +if ( tt!=mp_independent ) copied=false; +else { copied=true; tt=mp_dependent; }; +@<Add dependency list |pp| of type |tt| to dependency list~|p| of type~|t|@>; +if ( copied ) mp_flush_node_list(mp, pp); +DONE1: + +@ @<Add dependency list |pp| of type |tt| to dependency list~|p| of type~|t|@>= +mp->watch_coefs=false; +if ( t==tt ) { + p=mp_p_plus_q(mp, p,pp,t); +} else if ( t==mp_proto_dependent ) { + p=mp_p_plus_fq(mp, p,unity,pp,mp_proto_dependent,mp_dependent); +} else { + q=p; + while ( mp_info(q)!=null ) { + value(q)=mp_round_fraction(mp, value(q)); q=mp_link(q); + } + t=mp_proto_dependent; p=mp_p_plus_q(mp, p,pp,t); +} +mp->watch_coefs=true; + +@ Our next goal is to process type declarations. For this purpose it's +convenient to have a procedure that scans a $\langle\,$declared +variable$\,\rangle$ and returns the corresponding token list. After the +following procedure has acted, the token after the declared variable +will have been scanned, so it will appear in |cur_cmd|, |cur_mod|, +and~|cur_sym|. + +@<Declarations@>= +static pointer mp_scan_declared_variable (MP mp) ; + +@ @c +pointer mp_scan_declared_variable (MP mp) { + pointer x; /* hash address of the variable's root */ + pointer h,t; /* head and tail of the token list to be returned */ + pointer l; /* hash address of left bracket */ + mp_get_symbol(mp); x=mp->cur_sym; + if ( mp->cur_cmd!=tag_token ) mp_clear_symbol(mp, x,false); + h=mp_get_avail(mp); mp_info(h)=x; t=h; + while (1) { + mp_get_x_next(mp); + if ( mp->cur_sym==0 ) break; + if ( mp->cur_cmd!=tag_token ) if ( mp->cur_cmd!=internal_quantity) { + if ( mp->cur_cmd==left_bracket ) { + @<Descend past a collective subscript@>; + } else { + break; + } + } + mp_link(t)=mp_get_avail(mp); t=mp_link(t); mp_info(t)=mp->cur_sym; + } + if ( (eq_type(x)%outer_tag)!=tag_token ) mp_clear_symbol(mp, x,false); + if ( equiv(x)==null ) mp_new_root(mp, x); + return h; +} + +@ If the subscript isn't collective, we don't accept it as part of the +declared variable. + +@<Descend past a collective subscript@>= +{ + l=mp->cur_sym; mp_get_x_next(mp); + if ( mp->cur_cmd!=right_bracket ) { + mp_back_input(mp); mp->cur_sym=l; mp->cur_cmd=left_bracket; break; + } else { + mp->cur_sym=collective_subscript; + } +} + +@ Type declarations are introduced by the following primitive operations. + +@<Put each...@>= +mp_primitive(mp, "numeric",type_name,mp_numeric_type); +@:numeric_}{\&{numeric} primitive@> +mp_primitive(mp, "string",type_name,mp_string_type); +@:string_}{\&{string} primitive@> +mp_primitive(mp, "boolean",type_name,mp_boolean_type); +@:boolean_}{\&{boolean} primitive@> +mp_primitive(mp, "path",type_name,mp_path_type); +@:path_}{\&{path} primitive@> +mp_primitive(mp, "pen",type_name,mp_pen_type); +@:pen_}{\&{pen} primitive@> +mp_primitive(mp, "picture",type_name,mp_picture_type); +@:picture_}{\&{picture} primitive@> +mp_primitive(mp, "transform",type_name,mp_transform_type); +@:transform_}{\&{transform} primitive@> +mp_primitive(mp, "color",type_name,mp_color_type); +@:color_}{\&{color} primitive@> +mp_primitive(mp, "rgbcolor",type_name,mp_color_type); +@:color_}{\&{rgbcolor} primitive@> +mp_primitive(mp, "cmykcolor",type_name,mp_cmykcolor_type); +@:color_}{\&{cmykcolor} primitive@> +mp_primitive(mp, "pair",type_name,mp_pair_type); +@:pair_}{\&{pair} primitive@> + +@ @<Cases of |print_cmd...@>= +case type_name: mp_print_type(mp, m); break; + +@ Now we are ready to handle type declarations, assuming that a +|type_name| has just been scanned. + +@<Declare action procedures for use by |do_statement|@>= +static void mp_do_type_declaration (MP mp) ; + +@ @c +void mp_do_type_declaration (MP mp) { + quarterword t; /* the type being declared */ + pointer p; /* token list for a declared variable */ + pointer q; /* value node for the variable */ + if ( mp->cur_mod>=mp_transform_type ) + t=mp->cur_mod; + else + t=mp->cur_mod+unknown_tag; + do { + p=mp_scan_declared_variable(mp); + mp_flush_variable(mp, equiv(mp_info(p)),mp_link(p),false); + q=mp_find_variable(mp, p); + if ( q!=null ) { + mp_type(q)=t; value(q)=null; + } else { + print_err("Declared variable conflicts with previous vardef"); +@.Declared variable conflicts...@> + help2("You can't use, e.g., `numeric foo[]' after `vardef foo'.", + "Proceed, and I'll ignore the illegal redeclaration."); + mp_put_get_error(mp); + } + mp_flush_list(mp, p); + if ( mp->cur_cmd<comma ) { + @<Flush spurious symbols after the declared variable@>; + } + } while (! end_of_statement); +} + +@ @<Flush spurious symbols after the declared variable@>= +{ + print_err("Illegal suffix of declared variable will be flushed"); +@.Illegal suffix...flushed@> + help5("Variables in declarations must consist entirely of", + "names and collective subscripts, e.g., `x[]a'.", + "Are you trying to use a reserved word in a variable name?", + "I'm going to discard the junk I found here,", + "up to the next comma or the end of the declaration."); + if ( mp->cur_cmd==numeric_token ) + mp->help_line[2]="Explicit subscripts like `x15a' aren't permitted."; + mp_put_get_error(mp); mp->scanner_status=flushing; + do { + get_t_next; + @<Decrease the string reference count...@>; + } while (mp->cur_cmd<comma); /* either |end_of_statement| or |cur_cmd=comma| */ + mp->scanner_status=normal; +} + +@ \MP's |main_control| procedure just calls |do_statement| repeatedly +until coming to the end of the user's program. +Each execution of |do_statement| concludes with +|cur_cmd=semicolon|, |end_group|, or |stop|. + +@c +static void mp_main_control (MP mp) { + do { + mp_do_statement(mp); + if ( mp->cur_cmd==end_group ) { + print_err("Extra `endgroup'"); +@.Extra `endgroup'@> + help2("I'm not currently working on a `begingroup',", + "so I had better not try to end anything."); + mp_flush_error(mp, 0); + } + } while (mp->cur_cmd!=stop); +} +int 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; +} + +@ 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|. + +@<Exported types@>= +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 ps_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, int 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->ps_out)); + ff->f = xmalloc(1,1); + run->ps_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) { + s = xrealloc(s, (lim + (lim >> 2)),1); + if (s == NULL) + return NULL; + lim += (lim >> 2); + } + s[len++] = 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); + if ((a->used+l)>=a->size) { + a->size += 256+(a->size)/5+l; + a->data = xrealloc(a->data,a->size,1); + } + (void)strcpy(a->data+a->used,b); + 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->ps_out.fptr) { + mp_append_string(mp,&(run->ps_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) { + FILE *f = ((File *) ff)->f; + if (f != NULL) + (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->ps_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, int h) +{ + 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.ps_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=0; +mp->in_open=0; mp->open_parens=0; mp->max_buf_stack=0; +mp->param_ptr=0; mp->max_param_stack=0; +start = loc = iindex = 0; mp->first = 0; +line=0; name=is_term; +mp->mpx_name[0]=absent; +mp->force_eof=false; +t_open_in; +mp->scanner_status=normal; +if (mp->mem_ident==NULL) { + if ( ! mp_load_mem_file(mp) ) { + (mp->close_file)(mp, mp->mem_file); + mp->history = mp_fatal_error_stop; + return mp->history; + } + (mp->close_file)(mp, mp->mem_file); +} +mp_fix_date_and_time(mp); +if (mp->random_seed==0) + mp->random_seed = (mp->internal[mp_time] / unity)+mp->internal[mp_day]; +mp_init_randoms(mp, mp->random_seed); +@<Initialize the print |selector|...@>; +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) { + mp->internal[mp_gtroffmode]=unity; + mp->internal[mp_prologues]=unity; +} +if ( mp->start_sym>0 ) { /* insert the `\&{everyjob}' symbol */ + mp->cur_sym=mp->start_sym; mp_back_input(mp); +} + +@ @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.ps_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 (mp->cur_cmd!=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); +} + +@ @<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); + +@ @<Put each...@>= +mp_primitive(mp, "end",stop,0); +@:end_}{\&{end} primitive@> +mp_primitive(mp, "dump",stop,1); +@:dump_}{\&{dump} primitive@> + +@ @<Cases of |print_cmd...@>= +case stop: + if ( m==0 ) mp_print(mp, "end"); + else mp_print(mp, "dump"); + break; + +@* \[41] Commands. +Let's turn now to statements that are classified as ``commands'' because +of their imperative nature. We'll begin with simple ones, so that it +will be clear how to hook command processing into the |do_statement| routine; +then we'll tackle the tougher commands. + +Here's one of the simplest: + +@<Cases of |do_statement|...@>= +case mp_random_seed: mp_do_random_seed(mp); break; + +@ @<Declare action procedures for use by |do_statement|@>= +static void mp_do_random_seed (MP mp) ; + +@ @c void mp_do_random_seed (MP mp) { + mp_get_x_next(mp); + if ( mp->cur_cmd!=assignment ) { + mp_missing_err(mp, ":="); +@.Missing `:='@> + help1("Always say `randomseed:=<numeric expression>'."); + mp_back_error(mp); + }; + mp_get_x_next(mp); mp_scan_expression(mp); + if ( mp->cur_type!=mp_known ) { + exp_err("Unknown value will be ignored"); +@.Unknown value...ignored@> + help2("Your expression was too random for me to handle,", + "so I won't change the random seed just now."); + mp_put_get_flush_error(mp, 0); + } else { + @<Initialize the random seed to |cur_exp|@>; + } +} + +@ @<Initialize the random seed to |cur_exp|@>= +{ + mp_init_randoms(mp, mp->cur_exp); + if ( mp->selector>=log_only && mp->selector<write_file) { + mp->old_setting=mp->selector; mp->selector=log_only; + mp_print_nl(mp, "{randomseed:="); + mp_print_scaled(mp, mp->cur_exp); + mp_print_char(mp, xord('}')); + mp_print_nl(mp, ""); mp->selector=mp->old_setting; + } +} + +@ And here's another simple one (somewhat different in flavor): + +@<Cases of |do_statement|...@>= +case mode_command: + mp_print_ln(mp); mp->interaction=mp->cur_mod; + @<Initialize the print |selector| based on |interaction|@>; + if ( mp->log_opened ) mp->selector=mp->selector+2; + mp_get_x_next(mp); + break; + +@ @<Put each...@>= +mp_primitive(mp, "batchmode",mode_command,mp_batch_mode); +@:mp_batch_mode_}{\&{batchmode} primitive@> +mp_primitive(mp, "nonstopmode",mode_command,mp_nonstop_mode); +@:mp_nonstop_mode_}{\&{nonstopmode} primitive@> +mp_primitive(mp, "scrollmode",mode_command,mp_scroll_mode); +@:mp_scroll_mode_}{\&{scrollmode} primitive@> +mp_primitive(mp, "errorstopmode",mode_command,mp_error_stop_mode); +@:mp_error_stop_mode_}{\&{errorstopmode} primitive@> + +@ @<Cases of |print_cmd_mod|...@>= +case mode_command: + switch (m) { + case mp_batch_mode: mp_print(mp, "batchmode"); break; + case mp_nonstop_mode: mp_print(mp, "nonstopmode"); break; + case mp_scroll_mode: mp_print(mp, "scrollmode"); break; + default: mp_print(mp, "errorstopmode"); break; + } + break; + +@ The `\&{inner}' and `\&{outer}' commands are only slightly harder. + +@<Cases of |do_statement|...@>= +case protection_command: mp_do_protection(mp); break; + +@ @<Put each...@>= +mp_primitive(mp, "inner",protection_command,0); +@:inner_}{\&{inner} primitive@> +mp_primitive(mp, "outer",protection_command,1); +@:outer_}{\&{outer} primitive@> + +@ @<Cases of |print_cmd...@>= +case protection_command: + if ( m==0 ) mp_print(mp, "inner"); + else mp_print(mp, "outer"); + break; + +@ @<Declare action procedures for use by |do_statement|@>= +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=mp->cur_mod; + do { + mp_get_symbol(mp); t=eq_type(mp->cur_sym); + if ( m==0 ) { + if ( t>=outer_tag ) + eq_type(mp->cur_sym)=t-outer_tag; + } else if ( t<outer_tag ) { + eq_type(mp->cur_sym)=t+outer_tag; + } + mp_get_x_next(mp); + } while (mp->cur_cmd==comma); +} + +@ \MP\ never defines the tokens `\.(' and `\.)' to be primitives, but +plain \MP\ begins with the declaration `\&{delimiters} \.{()}'. Such a +declaration assigns the command code |left_delimiter| to `\.{(}' and +|right_delimiter| to `\.{)}'; the |equiv| of each delimiter is the +hash address of its mate. + +@<Cases of |do_statement|...@>= +case delimiters: mp_def_delims(mp); break; + +@ @<Declare action procedures for use by |do_statement|@>= +static void mp_def_delims (MP mp) ; + +@ @c void mp_def_delims (MP mp) { + pointer l_delim,r_delim; /* the new delimiter pair */ + mp_get_clear_symbol(mp); l_delim=mp->cur_sym; + mp_get_clear_symbol(mp); r_delim=mp->cur_sym; + eq_type(l_delim)=left_delimiter; equiv(l_delim)=r_delim; + eq_type(r_delim)=right_delimiter; equiv(r_delim)=l_delim; + mp_get_x_next(mp); +} + +@ Here is a procedure that is called when \MP\ has reached a point +where some right delimiter is mandatory. + +@<Declarations@>= +static void mp_check_delimiter (MP mp,pointer l_delim, pointer r_delim); + +@ @c +void mp_check_delimiter (MP mp,pointer l_delim, pointer r_delim) { + if ( mp->cur_cmd==right_delimiter ) + if ( mp->cur_mod==l_delim ) + return; + if ( mp->cur_sym!=r_delim ) { + mp_missing_err(mp, str(text(r_delim))); +@.Missing `)'@> + help2("I found no right delimiter to match a left one. So I've", + "put one in, behind the scenes; this may fix the problem."); + mp_back_error(mp); + } else { + print_err("The token `"); mp_print_text(r_delim); +@.The token...delimiter@> + mp_print(mp, "' is no longer a right delimiter"); + help3("Strange: This token has lost its former meaning!", + "I'll read it as a right delimiter this time;", + "but watch out, I'll probably miss it later."); + mp_error(mp); + } +} + +@ The next four commands save or change the values associated with tokens. + +@<Cases of |do_statement|...@>= +case save_command: + do { + mp_get_symbol(mp); mp_save_variable(mp, mp->cur_sym); mp_get_x_next(mp); + } while (mp->cur_cmd==comma); + break; +case interim_command: mp_do_interim(mp); break; +case let_command: mp_do_let(mp); break; +case new_internal: mp_do_new_internal(mp); break; + +@ @<Declare action procedures for use by |do_statement|@>= +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 ( mp->cur_cmd!=internal_quantity ) { + print_err("The token `"); +@.The token...quantity@> + if ( mp->cur_sym==0 ) mp_print(mp, "(%CAPSULE)"); + else mp_print_text(mp->cur_sym); + mp_print(mp, "' isn't an internal quantity"); + help1("Something like `tracingonline' should follow `interim'."); + mp_back_error(mp); + } else { + mp_save_internal(mp, mp->cur_mod); mp_back_input(mp); + } + mp_do_statement(mp); +} + +@ The following procedure is careful not to undefine the left-hand symbol +too soon, lest commands like `{\tt let x=x}' have a surprising effect. + +@<Declare action procedures for use by |do_statement|@>= +static void mp_do_let (MP mp) ; + +@ @c void mp_do_let (MP mp) { + pointer l; /* hash location of the left-hand symbol */ + mp_get_symbol(mp); l=mp->cur_sym; mp_get_x_next(mp); + if ( mp->cur_cmd!=equals ) if ( mp->cur_cmd!=assignment ) { + mp_missing_err(mp, "="); +@.Missing `='@> + help3("You should have said `let symbol = something'.", + "But don't worry; I'll pretend that an equals sign", + "was present. The next token I read will be `something'."); + mp_back_error(mp); + } + mp_get_symbol(mp); + switch (mp->cur_cmd) { + case defined_macro: case secondary_primary_macro: + case tertiary_secondary_macro: case expression_tertiary_macro: + add_mac_ref(mp->cur_mod); + break; + default: + break; + } + mp_clear_symbol(mp, l,false); eq_type(l)=mp->cur_cmd; + if ( mp->cur_cmd==tag_token ) equiv(l)=null; + else equiv(l)=mp->cur_mod; + mp_get_x_next(mp); +} + +@ @<Declarations@>= +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) { + scaled *internal; + char * *int_name; + int k; + if ( hash_end+l>max_halfword ) { + mp_confusion(mp, "out of memory space"); /* can't be reached */ + } + int_name = xmalloc ((l+1),sizeof(char *)); + internal = xmalloc ((l+1),sizeof(scaled)); + for (k=0;k<=l; k++ ) { + if (k<=mp->max_internal) { + internal[k]=mp->internal[k]; + int_name[k]=mp->int_name[k]; + } else { + internal[k]=0; + int_name[k]=NULL; + } + } + xfree(mp->internal); xfree(mp->int_name); + mp->int_name = int_name; + mp->internal = internal; + mp->max_internal = l; +} + +void mp_do_new_internal (MP mp) { + do { + if ( mp->int_ptr==mp->max_internal ) { + mp_grow_internals(mp, (mp->max_internal + (mp->max_internal/4))); + } + mp_get_clear_symbol(mp); incr(mp->int_ptr); + eq_type(mp->cur_sym)=internal_quantity; + equiv(mp->cur_sym)=mp->int_ptr; + if(mp->int_name[mp->int_ptr]!=NULL) + xfree(mp->int_name[mp->int_ptr]); + mp->int_name[mp->int_ptr]=str(text(mp->cur_sym)); + mp->internal[mp->int_ptr]=0; + mp_get_x_next(mp); + } while (mp->cur_cmd==comma); +} + +@ @<Dealloc variables@>= +for (k=0;k<=mp->max_internal;k++) { + xfree(mp->int_name[k]); +} +xfree(mp->internal); +xfree(mp->int_name); + + +@ The various `\&{show}' commands are distinguished by modifier fields +in the usual way. + +@d show_token_code 0 /* show the meaning of a single token */ +@d show_stats_code 1 /* show current memory and string usage */ +@d show_code 2 /* show a list of expressions */ +@d show_var_code 3 /* show a variable and its descendents */ +@d show_dependencies_code 4 /* show dependent variables in terms of independents */ + +@<Put each...@>= +mp_primitive(mp, "showtoken",show_command,show_token_code); +@:show_token_}{\&{showtoken} primitive@> +mp_primitive(mp, "showstats",show_command,show_stats_code); +@:show_stats_}{\&{showstats} primitive@> +mp_primitive(mp, "show",show_command,show_code); +@:show_}{\&{show} primitive@> +mp_primitive(mp, "showvariable",show_command,show_var_code); +@:show_var_}{\&{showvariable} primitive@> +mp_primitive(mp, "showdependencies",show_command,show_dependencies_code); +@:show_dependencies_}{\&{showdependencies} primitive@> + +@ @<Cases of |print_cmd...@>= +case show_command: + switch (m) { + case show_token_code:mp_print(mp, "showtoken"); break; + case show_stats_code:mp_print(mp, "showstats"); break; + case show_code:mp_print(mp, "show"); break; + case show_var_code:mp_print(mp, "showvariable"); break; + default: mp_print(mp, "showdependencies"); break; + } + break; + +@ @<Cases of |do_statement|...@>= +case show_command:mp_do_show_whatever(mp); break; + +@ The value of |cur_mod| controls the |verbosity| in the |print_exp| routine: +if it's |show_code|, complicated structures are abbreviated, otherwise +they aren't. + +@<Declare action procedures for use by |do_statement|@>= +static void mp_do_show (MP mp) ; + +@ @c void mp_do_show (MP mp) { + do { + mp_get_x_next(mp); mp_scan_expression(mp); + mp_print_nl(mp, ">> "); +@.>>@> + mp_print_exp(mp, null,2); mp_flush_cur_exp(mp, 0); + } while (mp->cur_cmd==comma); +} + +@ @<Declare action procedures for use by |do_statement|@>= +static void mp_disp_token (MP mp) ; + +@ @c void mp_disp_token (MP mp) { + mp_print_nl(mp, "> "); +@.>\relax@> + if ( mp->cur_sym==0 ) { + @<Show a numeric or string or capsule token@>; + } else { + mp_print_text(mp->cur_sym); mp_print_char(mp, xord('=')); + if ( eq_type(mp->cur_sym)>=outer_tag ) mp_print(mp, "(outer) "); + mp_print_cmd_mod(mp, mp->cur_cmd,mp->cur_mod); + if ( mp->cur_cmd==defined_macro ) { + mp_print_ln(mp); mp_show_macro(mp, mp->cur_mod,null,100000); + } /* this avoids recursion between |show_macro| and |print_cmd_mod| */ +@^recursion@> + } +} + +@ @<Show a numeric or string or capsule token@>= +{ + if ( mp->cur_cmd==numeric_token ) { + mp_print_scaled(mp, mp->cur_mod); + } else if ( mp->cur_cmd==capsule_token ) { + mp_print_capsule(mp,mp->cur_mod); + } else { + mp_print_char(mp, xord('"')); + mp_print_str(mp, mp->cur_mod); mp_print_char(mp, xord('"')); + delete_str_ref(mp->cur_mod); + } +} + +@ The following cases of |print_cmd_mod| might arise in connection +with |disp_token|, although they don't necessarily correspond to +primitive tokens. + +@<Cases of |print_cmd_...@>= +case left_delimiter: +case right_delimiter: + if ( c==left_delimiter ) mp_print(mp, "left"); + else mp_print(mp, "right"); + mp_print(mp, " delimiter that matches "); + mp_print_text(m); + break; +case tag_token: + if ( m==null ) mp_print(mp, "tag"); + else mp_print(mp, "variable"); + break; +case defined_macro: + mp_print(mp, "macro:"); + break; +case secondary_primary_macro: +case tertiary_secondary_macro: +case expression_tertiary_macro: + mp_print_cmd_mod(mp, macro_def,c); + mp_print(mp, "'d macro:"); + mp_print_ln(mp); mp_show_token_list(mp, mp_link(mp_link(m)),null,1000,0); + break; +case repeat_loop: + mp_print(mp, "[repeat the loop]"); + break; +case internal_quantity: + mp_print(mp, mp->int_name[m]); + break; + +@ @<Declare action procedures for use by |do_statement|@>= +static void mp_do_show_token (MP mp) ; + +@ @c void mp_do_show_token (MP mp) { + do { + get_t_next; mp_disp_token(mp); + mp_get_x_next(mp); + } while (mp->cur_cmd==comma); +} + +@ @<Declare action procedures for use by |do_statement|@>= +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, mp->var_used); mp_print_char(mp, xord('&')); mp_print_int(mp, mp->dyn_used); + mp_print(mp, " ("); mp_print_int(mp, mp->hi_mem_min-mp->lo_mem_max-1); + mp_print(mp, " still untouched)"); mp_print_ln(mp); + mp_print_nl(mp, "String usage "); + mp_print_int(mp, mp->strs_in_use-mp->init_str_use); + mp_print_char(mp, xord('&')); mp_print_int(mp, mp->pool_in_use-mp->init_pool_ptr); + mp_print(mp, " ("); + mp_print_int(mp, mp->max_strings-1-mp->strs_used_up); mp_print_char(mp, xord('&')); + mp_print_int(mp, mp->pool_size-mp->pool_ptr); + mp_print(mp, " now untouched)"); mp_print_ln(mp); + mp_get_x_next(mp); +} + +@ Here's a recursive procedure that gives an abbreviated account +of a variable, for use by |do_show_var|. + +@<Declare action procedures for use by |do_statement|@>= +static void mp_disp_var (MP mp,pointer p) ; + +@ @c void mp_disp_var (MP mp,pointer p) { + pointer q; /* traverses attributes and subscripts */ + int n; /* amount of macro text to show */ + if ( 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)!=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!=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-mp->file_offset-15; + mp_show_macro(mp, value(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; + if ( mp->cur_sym>0 ) if ( mp->cur_sym<=hash_end ) + if ( mp->cur_cmd==tag_token ) if ( mp->cur_mod!=null ) { + mp_disp_var(mp, mp->cur_mod); goto DONE; + } + mp_disp_token(mp); + DONE: + mp_get_x_next(mp); + } while (mp->cur_cmd==comma); +} + +@ @<Declare action procedures for use by |do_statement|@>= +static void mp_do_show_dependencies (MP mp) ; + +@ @c void mp_do_show_dependencies (MP mp) { + pointer p; /* link that runs through all dependencies */ + p=mp_link(dep_head); + while ( p!=dep_head ) { + if ( mp_interesting(mp, p) ) { + mp_print_nl(mp, ""); mp_print_variable_name(mp, 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, dep_list(p),mp_type(p)); + } + p=dep_list(p); + while ( mp_info(p)!=null ) p=mp_link(p); + p=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 (mp->cur_mod) { + case show_token_code:mp_do_show_token(mp); break; + case show_stats_code:mp_do_show_stats(mp); break; + case show_code:mp_do_show(mp); break; + case show_var_code:mp_do_show_var(mp); break; + case show_dependencies_code:mp_do_show_dependencies(mp); break; + } /* there are no other cases */ + if ( mp->internal[mp_showstopping]>0 ){ + print_err("OK"); +@.OK@> + if ( mp->interaction<mp_error_stop_mode ) { + help0; decr(mp->error_count); + } else { + help1("This isn't an error message; I'm just showing something."); + } + if ( mp->cur_cmd==semicolon ) mp_error(mp); + else mp_put_get_error(mp); + } +} + +@ The `\&{addto}' command needs the following additional primitives: + +@d double_path_code 0 /* command modifier for `\&{doublepath}' */ +@d contour_code 1 /* command modifier for `\&{contour}' */ +@d also_code 2 /* command modifier for `\&{also}' */ + +@ Pre and postscripts need two new identifiers: + +@d with_mp_pre_script 11 +@d with_mp_post_script 13 + +@<Put each...@>= +mp_primitive(mp, "doublepath",thing_to_add,double_path_code); +@:double_path_}{\&{doublepath} primitive@> +mp_primitive(mp, "contour",thing_to_add,contour_code); +@:contour_}{\&{contour} primitive@> +mp_primitive(mp, "also",thing_to_add,also_code); +@:also_}{\&{also} primitive@> +mp_primitive(mp, "withpen",with_option,mp_pen_type); +@:with_pen_}{\&{withpen} primitive@> +mp_primitive(mp, "dashed",with_option,mp_picture_type); +@:dashed_}{\&{dashed} primitive@> +mp_primitive(mp, "withprescript",with_option,with_mp_pre_script); +@:with_mp_pre_script_}{\&{withprescript} primitive@> +mp_primitive(mp, "withpostscript",with_option,with_mp_post_script); +@:with_mp_post_script_}{\&{withpostscript} primitive@> +mp_primitive(mp, "withoutcolor",with_option,mp_no_model); +@:with_color_}{\&{withoutcolor} primitive@> +mp_primitive(mp, "withgreyscale",with_option,mp_grey_model); +@:with_color_}{\&{withgreyscale} primitive@> +mp_primitive(mp, "withcolor",with_option,mp_uninitialized_model); +@:with_color_}{\&{withcolor} primitive@> +/* \&{withrgbcolor} is an alias for \&{withcolor} */ +mp_primitive(mp, "withrgbcolor",with_option,mp_rgb_model); +@:with_color_}{\&{withrgbcolor} primitive@> +mp_primitive(mp, "withcmykcolor",with_option,mp_cmyk_model); +@:with_color_}{\&{withcmykcolor} primitive@> + +@ @<Cases of |print_cmd...@>= +case thing_to_add: + if ( m==contour_code ) mp_print(mp, "contour"); + else if ( m==double_path_code ) mp_print(mp, "doublepath"); + else mp_print(mp, "also"); + break; +case with_option: + if ( m==mp_pen_type ) mp_print(mp, "withpen"); + else if ( m==with_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,pointer p) ; + +@ @c void mp_scan_with_list (MP mp,pointer p) { + quarterword t; /* |cur_mod| of the |with_option| (should match |cur_type|) */ + pointer q; /* for list manipulation */ + unsigned old_setting; /* saved |selector| setting */ + pointer k; /* for finding the near-last item in a list */ + str_number s; /* for string cleanup after combining */ + pointer cp,pp,dp,ap,bp; + /* objects being updated; |void| initially; |null| to suppress update */ + cp=mp_void; pp=mp_void; dp=mp_void; ap=mp_void; bp=mp_void; + k=0; + while ( mp->cur_cmd==with_option ){ + t=mp->cur_mod; + mp_get_x_next(mp); + if ( t!=mp_no_model ) mp_scan_expression(mp); + if (((t==with_mp_pre_script)&&(mp->cur_type!=mp_string_type))|| + ((t==with_mp_post_script)&&(mp->cur_type!=mp_string_type))|| + ((t==mp_uninitialized_model)&& + ((mp->cur_type!=mp_cmykcolor_type)&&(mp->cur_type!=mp_color_type) + &&(mp->cur_type!=mp_known)&&(mp->cur_type!=mp_boolean_type)))|| + ((t==mp_cmyk_model)&&(mp->cur_type!=mp_cmykcolor_type))|| + ((t==mp_rgb_model)&&(mp->cur_type!=mp_color_type))|| + ((t==mp_grey_model)&&(mp->cur_type!=mp_known))|| + ((t==mp_pen_type)&&(mp->cur_type!=t))|| + ((t==mp_picture_type)&&(mp->cur_type!=t)) ) { + @<Complain about improper type@>; + } else if ( t==mp_uninitialized_model ) { + if ( cp==mp_void ) @<Make |cp| a colored object in object list~|p|@>; + if ( cp!=null ) + @<Transfer a color from the current expression to object~|cp|@>; + mp_flush_cur_exp(mp, 0); + } else if ( t==mp_rgb_model ) { + if ( cp==mp_void ) @<Make |cp| a colored object in object list~|p|@>; + if ( cp!=null ) + @<Transfer a rgbcolor from the current expression to object~|cp|@>; + mp_flush_cur_exp(mp, 0); + } else if ( t==mp_cmyk_model ) { + if ( cp==mp_void ) @<Make |cp| a colored object in object list~|p|@>; + if ( cp!=null ) + @<Transfer a cmykcolor from the current expression to object~|cp|@>; + mp_flush_cur_exp(mp, 0); + } else if ( t==mp_grey_model ) { + if ( cp==mp_void ) @<Make |cp| a colored object in object list~|p|@>; + if ( cp!=null ) + @<Transfer a greyscale from the current expression to object~|cp|@>; + mp_flush_cur_exp(mp, 0); + } else if ( t==mp_no_model ) { + if ( cp==mp_void ) @<Make |cp| a colored object in object list~|p|@>; + if ( cp!=null ) + @<Transfer a noncolor from the current expression to object~|cp|@>; + } else if ( t==mp_pen_type ) { + if ( pp==mp_void ) @<Make |pp| an object in list~|p| that needs a pen@>; + if ( pp!=null ) { + if ( mp_pen_p(pp)!=null ) mp_toss_knot_list(mp, mp_pen_p(pp)); + mp_pen_p(pp)=mp->cur_exp; mp->cur_type=mp_vacuous; + } + } else if ( t==with_mp_pre_script ) { + 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 */ + s=mp_pre_script(ap); + old_setting=mp->selector; + mp->selector=new_string; + str_room(length(mp_pre_script(ap))+length(mp->cur_exp)+2); + mp_print_str(mp, mp->cur_exp); + append_char(13); /* a forced \ps\ newline */ + mp_print_str(mp, 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)=mp->cur_exp; + } + mp->cur_type=mp_vacuous; + } + } else if ( t==with_mp_post_script ) { + if ( bp==mp_void ) + k=p; + bp=k; + while ( mp_link(k)!=null ) { + k=mp_link(k); + if ( has_color(k) ) bp=k; + } + if ( bp!=null ) { + if ( mp_post_script(bp)!=null ) { + s=mp_post_script(bp); + old_setting=mp->selector; + mp->selector=new_string; + str_room(length(mp_post_script(bp))+length(mp->cur_exp)+2); + mp_print_str(mp, mp_post_script(bp)); + append_char(13); /* a forced \ps\ newline */ + mp_print_str(mp, mp->cur_exp); + mp_post_script(bp)=mp_make_string(mp); + delete_str_ref(s); + mp->selector=old_setting; + } else { + mp_post_script(bp)=mp->cur_exp; + } + mp->cur_type=mp_vacuous; + } + } else { + if ( dp==mp_void ) { + @<Make |dp| a stroked node in list~|p|@>; + } + if ( dp!=null ) { + if ( mp_dash_p(dp)!=null ) delete_edge_ref(mp_dash_p(dp)); + mp_dash_p(dp)=mp_make_dashes(mp, mp->cur_exp); + dash_scale(dp)=unity; + mp->cur_type=mp_vacuous; + } + } + } + @<Copy the information from objects |cp|, |pp|, and |dp| into the rest + of the list@>; +} + +@ @<Complain about improper type@>= +{ exp_err("Improper type"); +@.Improper type@> +help2("Next time say `withpen <known pen expression>';", + "I'll ignore the bad `with' clause and look for another."); +if ( t==with_mp_pre_script ) + mp->help_line[1]="Next time say `withprescript <known string expression>';"; +else if ( t==with_mp_post_script ) + mp->help_line[1]="Next time say `withpostscript <known string expression>';"; +else if ( t==mp_picture_type ) + mp->help_line[1]="Next time say `dashed <known picture expression>';"; +else if ( t==mp_uninitialized_model ) + mp->help_line[1]="Next time say `withcolor <known color expression>';"; +else if ( t==mp_rgb_model ) + mp->help_line[1]="Next time say `withrgbcolor <known color expression>';"; +else if ( t==mp_cmyk_model ) + mp->help_line[1]="Next time say `withcmykcolor <known cmykcolor expression>';"; +else if ( t==mp_grey_model ) + mp->help_line[1]="Next time say `withgreyscale <known numeric expression>';";; +mp_put_get_flush_error(mp, 0); +} + +@ Forcing the color to be between |0| and |unity| here guarantees that no +picture will ever contain a color outside the legal range for \ps\ graphics. + +@<Transfer a color from the current expression to object~|cp|@>= +{ if ( mp->cur_type==mp_color_type ) + @<Transfer a rgbcolor from the current expression to object~|cp|@> +else if ( mp->cur_type==mp_cmykcolor_type ) + @<Transfer a cmykcolor from the current expression to object~|cp|@> +else if ( mp->cur_type==mp_known ) + @<Transfer a greyscale from the current expression to object~|cp|@> +else if ( mp->cur_exp==false_code ) + @<Transfer a noncolor from the current expression to object~|cp|@>; +} + +@ @<Transfer a rgbcolor from the current expression to object~|cp|@>= +{ q=value(mp->cur_exp); +cyan_val(cp)=0; +magenta_val(cp)=0; +yellow_val(cp)=0; +black_val(cp)=0; +red_val(cp)=value(red_part_loc(q)); +green_val(cp)=value(green_part_loc(q)); +blue_val(cp)=value(blue_part_loc(q)); +mp_color_model(cp)=mp_rgb_model; +if ( red_val(cp)<0 ) red_val(cp)=0; +if ( green_val(cp)<0 ) green_val(cp)=0; +if ( blue_val(cp)<0 ) blue_val(cp)=0; +if ( red_val(cp)>unity ) red_val(cp)=unity; +if ( green_val(cp)>unity ) green_val(cp)=unity; +if ( blue_val(cp)>unity ) blue_val(cp)=unity; +} + +@ @<Transfer a cmykcolor from the current expression to object~|cp|@>= +{ q=value(mp->cur_exp); +cyan_val(cp)=value(cyan_part_loc(q)); +magenta_val(cp)=value(magenta_part_loc(q)); +yellow_val(cp)=value(yellow_part_loc(q)); +black_val(cp)=value(black_part_loc(q)); +mp_color_model(cp)=mp_cmyk_model; +if ( cyan_val(cp)<0 ) cyan_val(cp)=0; +if ( magenta_val(cp)<0 ) magenta_val(cp)=0; +if ( yellow_val(cp)<0 ) yellow_val(cp)=0; +if ( black_val(cp)<0 ) black_val(cp)=0; +if ( cyan_val(cp)>unity ) cyan_val(cp)=unity; +if ( magenta_val(cp)>unity ) magenta_val(cp)=unity; +if ( yellow_val(cp)>unity ) yellow_val(cp)=unity; +if ( black_val(cp)>unity ) black_val(cp)=unity; +} + +@ @<Transfer a greyscale from the current expression to object~|cp|@>= +{ q=mp->cur_exp; +cyan_val(cp)=0; +magenta_val(cp)=0; +yellow_val(cp)=0; +black_val(cp)=0; +grey_val(cp)=q; +mp_color_model(cp)=mp_grey_model; +if ( grey_val(cp)<0 ) grey_val(cp)=0; +if ( grey_val(cp)>unity ) grey_val(cp)=unity; +} + +@ @<Transfer a noncolor from the current expression to object~|cp|@>= +{ +cyan_val(cp)=0; +magenta_val(cp)=0; +yellow_val(cp)=0; +black_val(cp)=0; +grey_val(cp)=0; +mp_color_model(cp)=mp_no_model; +} + +@ @<Make |cp| a colored object in object list~|p|@>= +{ cp=p; + while ( cp!=null ){ + if ( has_color(cp) ) break; + cp=mp_link(cp); + } +} + +@ @<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); + } +} + +@ @<Make |dp| a stroked node in list~|p|@>= +{ dp=p; + while ( dp!=null ) { + if ( mp_type(dp)==mp_stroked_code ) break; + dp=mp_link(dp); + } +} + +@ @<Copy the information from objects |cp|, |pp|, and |dp| into...@>= +@<Copy |cp|'s color into the colored objects linked to~|cp|@>; +if ( pp>mp_void ) { + @<Copy |mp_pen_p(pp)| into stroked and filled nodes linked to |pp|@>; +} +if ( dp>mp_void ) { + @<Make stroked nodes linked to |dp| refer to |mp_dash_p(dp)|@>; +} + + +@ @<Copy |cp|'s color into the colored objects linked to~|cp|@>= +{ q=mp_link(cp); + while ( q!=null ) { + if ( has_color(q) ) { + red_val(q)=red_val(cp); + green_val(q)=green_val(cp); + blue_val(q)=blue_val(cp); + black_val(q)=black_val(cp); + mp_color_model(q)=mp_color_model(cp); + } + q=mp_link(q); + } +} + +@ @<Copy |mp_pen_p(pp)| into stroked and filled nodes linked to |pp|@>= +{ q=mp_link(pp); + while ( q!=null ) { + if ( has_pen(q) ) { + if ( mp_pen_p(q)!=null ) mp_toss_knot_list(mp, mp_pen_p(q)); + mp_pen_p(q)=copy_pen(mp_pen_p(pp)); + } + q=mp_link(q); + } +} + +@ @<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_code ) { + if ( mp_dash_p(q)!=null ) delete_edge_ref(mp_dash_p(q)); + mp_dash_p(q)=mp_dash_p(dp); + dash_scale(q)=unity; + 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 pointer mp_find_edges_var (MP mp, pointer t) ; + +@ @c pointer mp_find_edges_var (MP mp, pointer t) { + pointer p; + pointer cur_edges; /* the return value */ + p=mp_find_variable(mp, t); cur_edges=null; + if ( p==null ) { + mp_obliterated(mp, t); mp_put_get_error(mp); + } else if ( mp_type(p)!=mp_picture_type ) { + print_err("Variable "); mp_show_token_list(mp, t,null,1000,0); +@.Variable x is the wrong type@> + mp_print(mp, " is the wrong type ("); + mp_print_type(mp, mp_type(p)); mp_print_char(mp, xord(')')); + help2("I was looking for a \"known\" picture variable.", + "So I'll not change anything just now."); + mp_put_get_error(mp); + } else { + value(p)=mp_private_edges(mp, value(p)); + cur_edges=value(p); + } + mp_flush_node_list(mp, t); + return cur_edges; +} + +@ @<Cases of |do_statement|...@>= +case add_to_command: mp_do_add_to(mp); break; +case bounds_command:mp_do_bounds(mp); break; + +@ @<Put each...@>= +mp_primitive(mp, "clip",bounds_command,mp_start_clip_code); +@:clip_}{\&{clip} primitive@> +mp_primitive(mp, "setbounds",bounds_command,mp_start_bounds_code); +@:set_bounds_}{\&{setbounds} primitive@> + +@ @<Cases of |print_cmd...@>= +case bounds_command: + if ( m==mp_start_clip_code ) mp_print(mp, "clip"); + else mp_print(mp, "setbounds"); + break; + +@ The following function parses the beginning of an \&{addto} or \&{clip} +command: it expects a variable name followed by a token with |cur_cmd=sep| +and then an expression. The function returns the token list for the variable +and stores the command modifier for the separator token in the global variable +|last_add_type|. We must be careful because this variable might get overwritten +any time we call |get_x_next|. + +@<Glob...@>= +quarterword last_add_type; + /* command modifier that identifies the last \&{addto} command */ + +@ @<Declare action procedures for use by |do_statement|@>= +static pointer mp_start_draw_cmd (MP mp,quarterword sep) ; + +@ @c pointer mp_start_draw_cmd (MP mp,quarterword sep) { + pointer lhv; /* variable to add to left */ + quarterword add_type=0; /* value to be returned in |last_add_type| */ + lhv=null; + mp_get_x_next(mp); mp->var_flag=sep; mp_scan_primary(mp); + if ( mp->cur_type!=mp_token_list ) { + @<Abandon edges command because there's no variable@>; + } else { + lhv=mp->cur_exp; add_type=mp->cur_mod; + mp->cur_type=mp_vacuous; mp_get_x_next(mp); mp_scan_expression(mp); + } + mp->last_add_type=add_type; + return lhv; +} + +@ @<Abandon edges command because there's no variable@>= +{ exp_err("Not a suitable variable"); +@.Not a suitable variable@> + help4("At this point I needed to see the name of a picture variable.", + "(Or perhaps you have indeed presented me with one; I might", + "have missed it, if it wasn't followed by the proper token.)", + "So I'll not change anything just now."); + mp_put_get_flush_error(mp, 0); +} + +@ Here is an example of how to use |start_draw_cmd|. + +@<Declare action procedures for use by |do_statement|@>= +static void mp_do_bounds (MP mp) ; + +@ @c void mp_do_bounds (MP mp) { + pointer lhv,lhe; /* variable on left, the corresponding edge structure */ + pointer p; /* for list manipulation */ + integer m; /* initial value of |cur_mod| */ + m=mp->cur_mod; + lhv=mp_start_draw_cmd(mp, to_token); + if ( lhv!=null ) { + lhe=mp_find_edges_var(mp, lhv); + if ( lhe==null ) { + mp_flush_cur_exp(mp, 0); + } else if ( mp->cur_type!=mp_path_type ) { + exp_err("Improper `clip'"); +@.Improper `addto'@> + help2("This expression should have specified a known path.", + "So I'll not change anything just now."); + mp_put_get_flush_error(mp, 0); + } else if ( mp_left_type(mp->cur_exp)==mp_endpoint ) { + @<Complain about a non-cycle@>; + } else { + @<Make |cur_exp| into a \&{setbounds} or clipping path and add it to |lhe|@>; + } + } +} + +@ @<Complain about a non-cycle@>= +{ print_err("Not a cycle"); +@.Not a cycle@> + help2("That contour should have ended with `..cycle' or `&cycle'.", + "So I'll not change anything just now."); mp_put_get_error(mp); +} + +@ @<Make |cur_exp| into a \&{setbounds} or clipping path and add...@>= +{ p=mp_new_bounds_node(mp, mp->cur_exp,m); + mp_link(p)=mp_link(dummy_loc(lhe)); + mp_link(dummy_loc(lhe))=p; + if ( obj_tail(lhe)==dummy_loc(lhe) ) obj_tail(lhe)=p; + p=mp_get_node(mp, mp->gr_object_size[stop_type(m)]); + mp_type(p)=stop_type(m); + 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) { + pointer lhv,lhe; /* variable on left, the corresponding edge structure */ + pointer p; /* the graphical object or list for |scan_with_list| to update */ + pointer e; /* an edge structure to be merged */ + quarterword add_type; /* |also_code|, |contour_code|, or |double_path_code| */ + lhv=mp_start_draw_cmd(mp, thing_to_add); add_type=mp->last_add_type; + if ( lhv!=null ) { + if ( add_type==also_code ) { + @<Make sure the current expression is a suitable picture and set |e| and |p| + appropriately@>; + } else { + @<Create a graphical object |p| based on |add_type| and the current + expression@>; + } + mp_scan_with_list(mp, p); + @<Use |p|, |e|, and |add_type| to augment |lhv| as requested@>; + } +} + +@ Setting |p:=null| causes the $\langle$with list$\rangle$ to be ignored; +setting |e:=null| prevents anything from being added to |lhe|. + +@ @<Make sure the current expression is a suitable picture and set |e|...@>= +{ + p=null; e=null; + if ( mp->cur_type!=mp_picture_type ) { + exp_err("Improper `addto'"); +@.Improper `addto'@> + help2("This expression should have specified a known picture.", + "So I'll not change anything just now."); + mp_put_get_flush_error(mp, 0); + } else { + e=mp_private_edges(mp, mp->cur_exp); mp->cur_type=mp_vacuous; + p=mp_link(dummy_loc(e)); + } +} + +@ In this case |add_type<>also_code| so setting |p:=null| suppresses future +attempts to add to the edge structure. + +@<Create a graphical object |p| based on |add_type| and the current...@>= +{ e=null; p=null; + if ( mp->cur_type==mp_pair_type ) mp_pair_to_path(mp); + if ( mp->cur_type!=mp_path_type ) { + exp_err("Improper `addto'"); +@.Improper `addto'@> + help2("This expression should have specified a known path.", + "So I'll not change anything just now."); + mp_put_get_flush_error(mp, 0); + } else if ( add_type==contour_code ) { + if ( mp_left_type(mp->cur_exp)==mp_endpoint ) { + @<Complain about a non-cycle@>; + } else { + p=mp_new_fill_node(mp, mp->cur_exp); + mp->cur_type=mp_vacuous; + } + } else { + p=mp_new_stroked_node(mp, mp->cur_exp); + mp->cur_type=mp_vacuous; + } +} + +@ @<Use |p|, |e|, and |add_type| to augment |lhv| as requested@>= +lhe=mp_find_edges_var(mp, lhv); +if ( lhe==null ) { + if ( (e==null)&&(p!=null) ) e=mp_toss_gr_object(mp, p); + if ( e!=null ) delete_edge_ref(e); +} else if ( add_type==also_code ) { + if ( e!=null ) { + @<Merge |e| into |lhe| and delete |e|@>; + } else { + do_nothing; + } +} else if ( p!=null ) { + mp_link(obj_tail(lhe))=p; + obj_tail(lhe)=p; + if ( add_type==double_path_code ) + if ( mp_pen_p(p)==null ) + mp_pen_p(p)=mp_get_pen_circle(mp, 0); +} + +@ @<Merge |e| into |lhe| and delete |e|@>= +{ if ( mp_link(dummy_loc(e))!=null ) { + mp_link(obj_tail(lhe))=mp_link(dummy_loc(e)); + obj_tail(lhe)=obj_tail(e); + obj_tail(e)=dummy_loc(e); + mp_link(dummy_loc(e))=null; + mp_flush_dash_list(mp, lhe); + } + mp_toss_edges(mp, e); +} + +@ @<Cases of |do_statement|...@>= +case ship_out_command: mp_do_ship_out(mp); break; + +@ @<Declare action procedures for use by |do_statement|@>= +@<Declare the \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_get_x_next(mp); mp_scan_expression(mp); + if ( mp->cur_type!=mp_picture_type ) { + @<Complain that it's not a known picture@>; + } else { + c=mp_round_unscaled(mp, mp->internal[mp_char_code]) % 256; + if ( c<0 ) c=c+256; + @<Store the width information for character code~|c|@>; + mp_ship_out(mp, mp->cur_exp); + mp_flush_cur_exp(mp, 0); + } +} + +@ @<Complain that it's not a known picture@>= +{ + exp_err("Not a known picture"); + help1("I can only output known pictures."); + mp_put_get_flush_error(mp, 0); +} + +@ The \&{everyjob} command simply assigns a nonzero value to the global variable +|start_sym|. + +@<Cases of |do_statement|...@>= +case every_job_command: + mp_get_symbol(mp); mp->start_sym=mp->cur_sym; mp_get_x_next(mp); + break; + +@ @<Glob...@>= +halfword start_sym; /* a symbolic token to insert at beginning of job */ + +@ @<Set init...@>= +mp->start_sym=0; + +@ Finally, we have only the ``message'' commands remaining. + +@d message_code 0 +@d err_message_code 1 +@d err_help_code 2 +@d filename_template_code 3 +@d print_with_leading_zeroes(A) g = mp->pool_ptr; + mp_print_int(mp, (A)); g = mp->pool_ptr-g; + if ( f>g ) { + mp->pool_ptr = mp->pool_ptr - g; + while ( f>g ) { + mp_print_char(mp, xord('0')); + decr(f); + }; + mp_print_int(mp, (A)); + }; + f = 0 + +@<Put each...@>= +mp_primitive(mp, "message",message_command,message_code); +@:message_}{\&{message} primitive@> +mp_primitive(mp, "errmessage",message_command,err_message_code); +@:err_message_}{\&{errmessage} primitive@> +mp_primitive(mp, "errhelp",message_command,err_help_code); +@:err_help_}{\&{errhelp} primitive@> +mp_primitive(mp, "filenametemplate",message_command,filename_template_code); +@:filename_template_}{\&{filenametemplate} primitive@> + +@ @<Cases of |print_cmd...@>= +case message_command: + if ( m<err_message_code ) mp_print(mp, "message"); + else if ( m==err_message_code ) mp_print(mp, "errmessage"); + else if ( m==filename_template_code ) mp_print(mp, "filenametemplate"); + else mp_print(mp, "errhelp"); + break; + +@ @<Cases of |do_statement|...@>= +case message_command: mp_do_message(mp); break; + +@ @<Declare action procedures for use by |do_statement|@>= +@<Declare a procedure called |no_string_err|@> +static void mp_do_message (MP mp) ; + +@ +@c void mp_do_message (MP mp) { + int m; /* the type of message */ + m=mp->cur_mod; mp_get_x_next(mp); mp_scan_expression(mp); + if ( mp->cur_type!=mp_string_type ) + mp_no_string_err(mp, "A message should be a known string expression."); + else { + switch (m) { + case message_code: + mp_print_nl(mp, ""); mp_print_str(mp, mp->cur_exp); + break; + case err_message_code: + @<Print string |cur_exp| as an error message@>; + break; + case err_help_code: + @<Save string |cur_exp| as the |err_help|@>; + break; + case filename_template_code: + @<Save the filename template@>; + break; + } /* there are no other cases */ + } + mp_flush_cur_exp(mp, 0); +} + +@ @<Declare a procedure called |no_string_err|@>= +static void mp_no_string_err (MP mp, const char *s) { + exp_err("Not a string"); +@.Not a string@> + help1(s); + mp_put_get_error(mp); +} + +@ The global variable |err_help| is zero when the user has most recently +given an empty help string, or if none has ever been given. + +@<Save string |cur_exp| as the |err_help|@>= +{ + if ( mp->err_help!=0 ) delete_str_ref(mp->err_help); + if ( length(mp->cur_exp)==0 ) mp->err_help=0; + else { mp->err_help=mp->cur_exp; add_str_ref(mp->err_help); } +} + +@ If \&{errmessage} occurs often in |mp_scroll_mode|, without user-defined +\&{errhelp}, we don't want to give a long help message each time. So we +give a verbose explanation only once. + +@<Glob...@>= +boolean long_help_seen; /* has the long \.{\\errmessage} help been used? */ + +@ @<Set init...@>=mp->long_help_seen=false; + +@ @<Print string |cur_exp| as an error message@>= +{ + print_err(""); mp_print_str(mp, mp->cur_exp); + if ( mp->err_help!=0 ) { + mp->use_err_help=true; + } else if ( mp->long_help_seen ) { + help1("(That was another `errmessage'.)") ; + } else { + if ( mp->interaction<mp_error_stop_mode ) mp->long_help_seen=true; + help4("This error message was generated by an `errmessage'", + "command, so I can\'t give any explicit help.", + "Pretend that you're Miss Marple: Examine all clues,", +@^Marple, Jane@> + "and deduce the truth by inspired guesses."); + } + mp_put_get_error(mp); mp->use_err_help=false; +} + +@ @<Cases of |do_statement|...@>= +case write_command: mp_do_write(mp); break; + +@ @<Declare action procedures for use by |do_statement|@>= +static void mp_do_write (MP mp) ; + +@ @c void mp_do_write (MP mp) { + str_number t; /* the line of text to be written */ + write_index n,n0; /* for searching |wr_fname| and |wr_file| arrays */ + unsigned old_setting; /* for saving |selector| during output */ + mp_get_x_next(mp); + mp_scan_expression(mp); + if ( mp->cur_type!=mp_string_type ) { + mp_no_string_err(mp, "The text to be written should be a known string expression"); + } else if ( mp->cur_cmd!=to_token ) { + print_err("Missing `to' clause"); + help1("A write command should end with `to <filename>'"); + mp_put_get_error(mp); + } else { + t=mp->cur_exp; mp->cur_type=mp_vacuous; + mp_get_x_next(mp); + mp_scan_expression(mp); + if ( mp->cur_type!=mp_string_type ) + mp_no_string_err(mp, "I can\'t write to that file name. It isn't a known string"); + else { + @<Write |t| to the file named by |cur_exp|@>; + } + delete_str_ref(t); + } + mp_flush_cur_exp(mp, 0); +} + +@ @<Write |t| to the file named by |cur_exp|@>= +{ + @<Find |n| where |wr_fname[n]=cur_exp| and call |open_write_file| if + |cur_exp| must be inserted@>; + if ( mp_str_vs_str(mp, t,mp->eof_line)==0 ) { + @<Record the end of file on |wr_file[n]|@>; + } else { + old_setting=mp->selector; + mp->selector=n+write_file; + mp_print_str(mp, t); mp_print_ln(mp); + mp->selector = old_setting; + } +} + +@ @<Find |n| where |wr_fname[n]=cur_exp| and call |open_write_file| if...@>= +{ + char *fn = str(mp->cur_exp); + n=mp->write_files; + n0=mp->write_files; + while (mp_xstrcmp(fn,mp->wr_fname[n])!=0) { + if ( n==0 ) { /* bottom reached */ + if ( n0==mp->write_files ) { + if ( mp->write_files<mp->max_write_files ) { + incr(mp->write_files); + } else { + void **wr_file; + char **wr_fname; + write_index l,k; + l = mp->max_write_files + (mp->max_write_files/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; +} + + +@* \[42] Writing font metric data. +\TeX\ gets its knowledge about fonts from font metric files, also called +\.{TFM} files; the `\.T' in `\.{TFM}' stands for \TeX, +but other programs know about them too. One of \MP's duties is to +write \.{TFM} files so that the user's fonts can readily be +applied to typesetting. +@:TFM files}{\.{TFM} files@> +@^font metric files@> + +The information in a \.{TFM} file appears in a sequence of 8-bit bytes. +Since the number of bytes is always a multiple of~4, we could +also regard the file as a sequence of 32-bit words, but \MP\ uses the +byte interpretation. The format of \.{TFM} files was designed by +Lyle Ramshaw in 1980. The intent is to convey a lot of different kinds +@^Ramshaw, Lyle Harold@> +of information in a compact but useful form. + +@<Glob...@>= +void * tfm_file; /* the font metric output goes here */ +char * metric_file_name; /* full name of the font metric file */ + +@ The first 24 bytes (6 words) of a \.{TFM} file contain twelve 16-bit +integers that give the lengths of the various subsequent portions +of the file. These twelve integers are, in order: +$$\vbox{\halign{\hfil#&$\null=\null$#\hfil\cr +|lf|&length of the entire file, in words;\cr +|lh|&length of the header data, in words;\cr +|bc|&smallest character code in the font;\cr +|ec|&largest character code in the font;\cr +|nw|&number of words in the width table;\cr +|nh|&number of words in the height table;\cr +|nd|&number of words in the depth table;\cr +|ni|&number of words in the italic correction table;\cr +|nl|&number of words in the lig/kern table;\cr +|nk|&number of words in the kern table;\cr +|ne|&number of words in the extensible character table;\cr +|np|&number of font parameter words.\cr}}$$ +They are all nonnegative and less than $2^{15}$. We must have |bc-1<=ec<=255|, +|ne<=256|, and +$$\hbox{|lf=6+lh+(ec-bc+1)+nw+nh+nd+ni+nl+nk+ne+np|.}$$ +Note that a font may contain as many as 256 characters (if |bc=0| and |ec=255|), +and as few as 0 characters (if |bc=ec+1|). + +Incidentally, when two or more 8-bit bytes are combined to form an integer of +16 or more bits, the most significant bytes appear first in the file. +This is called BigEndian order. +@^BigEndian order@> + +@ The rest of the \.{TFM} file may be regarded as a sequence of ten data +arrays. + +The most important data type used here is a |fix_word|, which is +a 32-bit representation of a binary fraction. A |fix_word| is a signed +quantity, with the two's complement of the entire word used to represent +negation. Of the 32 bits in a |fix_word|, exactly 12 are to the left of the +binary point; thus, the largest |fix_word| value is $2048-2^{-20}$, and +the smallest is $-2048$. We will see below, however, that all but two of +the |fix_word| values must lie between $-16$ and $+16$. + +@ The first data array is a block of header information, which contains +general facts about the font. The header must contain at least two words, +|header[0]| and |header[1]|, whose meaning is explained below. Additional +header information of use to other software routines might also be +included, and \MP\ will generate it if the \.{headerbyte} command occurs. +For example, 16 more words of header information are in use at the Xerox +Palo Alto Research Center; the first ten specify the character coding +scheme used (e.g., `\.{XEROX TEXT}' or `\.{TEX MATHSY}'), the next five +give the font family name (e.g., `\.{HELVETICA}' or `\.{CMSY}'), and the +last gives the ``face byte.'' + +\yskip\hang|header[0]| is a 32-bit check sum that \MP\ will copy into +the \.{GF} output file. This helps ensure consistency between files, +since \TeX\ records the check sums from the \.{TFM}'s it reads, and these +should match the check sums on actual fonts that are used. The actual +relation between this check sum and the rest of the \.{TFM} file is not +important; the check sum is simply an identification number with the +property that incompatible fonts almost always have distinct check sums. +@^check sum@> + +\yskip\hang|header[1]| is a |fix_word| containing the design size of the +font, in units of \TeX\ points. This number must be at least 1.0; it is +fairly arbitrary, but usually the design size is 10.0 for a ``10 point'' +font, i.e., a font that was designed to look best at a 10-point size, +whatever that really means. When a \TeX\ user asks for a font `\.{at} +$\delta$ \.{pt}', the effect is to override the design size and replace it +by $\delta$, and to multiply the $x$ and~$y$ coordinates of the points in +the font image by a factor of $\delta$ divided by the design size. {\sl +All other dimensions in the\/ \.{TFM} file are |fix_word|\kern-1pt\ +numbers in design-size units.} Thus, for example, the value of |param[6]|, +which defines the \.{em} unit, is often the |fix_word| value $2^{20}=1.0$, +since many fonts have a design size equal to one em. The other dimensions +must be less than 16 design-size units in absolute value; thus, +|header[1]| and |param[1]| are the only |fix_word| entries in the whole +\.{TFM} file whose first byte might be something besides 0 or 255. +@^design size@> + +@ Next comes the |char_info| array, which contains one |char_info_word| +per character. Each word in this part of the file contains six fields +packed into four bytes as follows. + +\yskip\hang first byte: |width_index| (8 bits)\par +\hang second byte: |height_index| (4 bits) times 16, plus |depth_index| + (4~bits)\par +\hang third byte: |italic_index| (6 bits) times 4, plus |tag| + (2~bits)\par +\hang fourth byte: |remainder| (8 bits)\par +\yskip\noindent +The actual width of a character is \\{width}|[width_index]|, in design-size +units; this is a device for compressing information, since many characters +have the same width. Since it is quite common for many characters +to have the same height, depth, or italic correction, the \.{TFM} format +imposes a limit of 16 different heights, 16 different depths, and +64 different italic corrections. + +Incidentally, the relation $\\{width}[0]=\\{height}[0]=\\{depth}[0]= +\\{italic}[0]=0$ should always hold, so that an index of zero implies a +value of zero. The |width_index| should never be zero unless the +character does not exist in the font, since a character is valid if and +only if it lies between |bc| and |ec| and has a nonzero |width_index|. + +@ The |tag| field in a |char_info_word| has four values that explain how to +interpret the |remainder| field. + +\yskip\hang|tag=0| (|no_tag|) means that |remainder| is unused.\par +\hang|tag=1| (|lig_tag|) means that this character has a ligature/kerning +program starting at location |remainder| in the |lig_kern| array.\par +\hang|tag=2| (|list_tag|) means that this character is part of a chain of +characters of ascending sizes, and not the largest in the chain. The +|remainder| field gives the character code of the next larger character.\par +\hang|tag=3| (|ext_tag|) means that this character code represents an +extensible character, i.e., a character that is built up of smaller pieces +so that it can be made arbitrarily large. The pieces are specified in +|exten[remainder]|.\par +\yskip\noindent +Characters with |tag=2| and |tag=3| are treated as characters with |tag=0| +unless they are used in special circumstances in math formulas. For example, +\TeX's \.{\\sum} operation looks for a |list_tag|, and the \.{\\left} +operation looks for both |list_tag| and |ext_tag|. + +@d no_tag 0 /* vanilla character */ +@d lig_tag 1 /* character has a ligature/kerning program */ +@d list_tag 2 /* character has a successor in a charlist */ +@d ext_tag 3 /* character is extensible */ + +@ The |lig_kern| array contains instructions in a simple programming language +that explains what to do for special letter pairs. Each word in this array is a +|lig_kern_command| of four bytes. + +\yskip\hang first byte: |skip_byte|, indicates that this is the final program + step if the byte is 128 or more, otherwise the next step is obtained by + skipping this number of intervening steps.\par +\hang second byte: |next_char|, ``if |next_char| follows the current character, + then perform the operation and stop, otherwise continue.''\par +\hang third byte: |op_byte|, indicates a ligature step if less than~128, + a kern step otherwise.\par +\hang fourth byte: |remainder|.\par +\yskip\noindent +In a kern step, an +additional space equal to |kern[256*(op_byte-128)+remainder]| is inserted +between the current character and |next_char|. This amount is +often negative, so that the characters are brought closer together +by kerning; but it might be positive. + +There are eight kinds of ligature steps, having |op_byte| codes $4a+2b+c$ where +$0\le a\le b+c$ and $0\le b,c\le1$. The character whose code is +|remainder| is inserted between the current character and |next_char|; +then the current character is deleted if $b=0$, and |next_char| is +deleted if $c=0$; then we pass over $a$~characters to reach the next +current character (which may have a ligature/kerning program of its own). + +If the very first instruction of the |lig_kern| array has |skip_byte=255|, +the |next_char| byte is the so-called right boundary character of this font; +the value of |next_char| need not lie between |bc| and~|ec|. +If the very last instruction of the |lig_kern| array has |skip_byte=255|, +there is a special ligature/kerning program for a left boundary character, +beginning at location |256*op_byte+remainder|. +The interpretation is that \TeX\ puts implicit boundary characters +before and after each consecutive string of characters from the same font. +These implicit characters do not appear in the output, but they can affect +ligatures and kerning. + +If the very first instruction of a character's |lig_kern| program has +|skip_byte>128|, the program actually begins in location +|256*op_byte+remainder|. This feature allows access to large |lig_kern| +arrays, because the first instruction must otherwise +appear in a location |<=255|. + +Any instruction with |skip_byte>128| in the |lig_kern| array must satisfy +the condition +$$\hbox{|256*op_byte+remainder<nl|.}$$ +If such an instruction is encountered during +normal program execution, it denotes an unconditional halt; no ligature +command is performed. + +@d stop_flag (128) + /* value indicating `\.{STOP}' in a lig/kern program */ +@d kern_flag (128) /* op code for a kern step */ +@d skip_byte(A) mp->lig_kern[(A)].b0 +@d next_char(A) mp->lig_kern[(A)].b1 +@d op_byte(A) mp->lig_kern[(A)].b2 +@d rem_byte(A) mp->lig_kern[(A)].b3 + +@ Extensible characters are specified by an |extensible_recipe|, which +consists of four bytes called |top|, |mid|, |bot|, and |rep| (in this +order). These bytes are the character codes of individual pieces used to +build up a large symbol. If |top|, |mid|, or |bot| are zero, they are not +present in the built-up result. For example, an extensible vertical line is +like an extensible bracket, except that the top and bottom pieces are missing. + +Let $T$, $M$, $B$, and $R$ denote the respective pieces, or an empty box +if the piece isn't present. Then the extensible characters have the form +$TR^kMR^kB$ from top to bottom, for some |k>=0|, unless $M$ is absent; +in the latter case we can have $TR^kB$ for both even and odd values of~|k|. +The width of the extensible character is the width of $R$; and the +height-plus-depth is the sum of the individual height-plus-depths of the +components used, since the pieces are butted together in a vertical list. + +@d ext_top(A) mp->exten[(A)].b0 /* |top| piece in a recipe */ +@d ext_mid(A) mp->exten[(A)].b1 /* |mid| piece in a recipe */ +@d ext_bot(A) mp->exten[(A)].b2 /* |bot| piece in a recipe */ +@d ext_rep(A) mp->exten[(A)].b3 /* |rep| piece in a recipe */ + +@ The final portion of a \.{TFM} file is the |param| array, which is another +sequence of |fix_word| values. + +\yskip\hang|param[1]=slant| is the amount of italic slant, which is used +to help position accents. For example, |slant=.25| means that when you go +up one unit, you also go .25 units to the right. The |slant| is a pure +number; it is the only |fix_word| other than the design size itself that is +not scaled by the design size. +@^design size@> + +\hang|param[2]=space| is the normal spacing between words in text. +Note that character 040 in the font need not have anything to do with +blank spaces. + +\hang|param[3]=space_stretch| is the amount of glue stretching between words. + +\hang|param[4]=space_shrink| is the amount of glue shrinking between words. + +\hang|param[5]=x_height| is the size of one ex in the font; it is also +the height of letters for which accents don't have to be raised or lowered. + +\hang|param[6]=quad| is the size of one em in the font. + +\hang|param[7]=extra_space| is the amount added to |param[2]| at the +ends of sentences. + +\yskip\noindent +If fewer than seven parameters are present, \TeX\ sets the missing parameters +to zero. + +@d slant_code 1 +@d space_code 2 +@d space_stretch_code 3 +@d space_shrink_code 4 +@d x_height_code 5 +@d quad_code 6 +@d extra_space_code 7 + +@ So that is what \.{TFM} files hold. One of \MP's duties is to output such +information, and it does this all at once at the end of a job. +In order to prepare for such frenetic activity, it squirrels away the +necessary facts in various arrays as information becomes available. + +Character dimensions (\&{charwd}, \&{charht}, \&{chardp}, and \&{charic}) +are stored respectively in |tfm_width|, |tfm_height|, |tfm_depth|, and +|tfm_ital_corr|. Other information about a character (e.g., about +its ligatures or successors) is accessible via the |char_tag| and +|char_remainder| arrays. Other information about the font as a whole +is kept in additional arrays called |header_byte|, |lig_kern|, +|kern|, |exten|, and |param|. + +@d max_tfm_int 32510 +@d undefined_label max_tfm_int /* an undefined local label */ + +@<Glob...@>= +#define TFM_ITEMS 257 +eight_bits bc; +eight_bits ec; /* smallest and largest character codes shipped out */ +scaled tfm_width[TFM_ITEMS]; /* \&{charwd} values */ +scaled tfm_height[TFM_ITEMS]; /* \&{charht} values */ +scaled tfm_depth[TFM_ITEMS]; /* \&{chardp} values */ +scaled tfm_ital_corr[TFM_ITEMS]; /* \&{charic} values */ +boolean char_exists[TFM_ITEMS]; /* has this code been shipped out? */ +int char_tag[TFM_ITEMS]; /* |remainder| category */ +int char_remainder[TFM_ITEMS]; /* the |remainder| byte */ +char *header_byte; /* bytes of the \.{TFM} header */ +int header_last; /* last initialized \.{TFM} header byte */ +int header_size; /* size of the \.{TFM} header */ +four_quarters *lig_kern; /* the ligature/kern table */ +short nl; /* the number of ligature/kern steps so far */ +scaled *kern; /* distinct kerning amounts */ +short nk; /* the number of distinct kerns so far */ +four_quarters exten[TFM_ITEMS]; /* extensible character recipes */ +short ne; /* the number of extensible characters so far */ +scaled *param; /* \&{fontinfo} parameters */ +short np; /* the largest \&{fontinfo} parameter specified so far */ +short nw;short nh;short nd;short ni; /* sizes of \.{TFM} subtables */ +short skip_table[TFM_ITEMS]; /* local label status */ +boolean lk_started; /* has there been a lig/kern step in this command yet? */ +integer bchar; /* right boundary character */ +short bch_label; /* left boundary starting location */ +short ll;short lll; /* registers used for lig/kern processing */ +short label_loc[257]; /* lig/kern starting addresses */ +eight_bits label_char[257]; /* characters for |label_loc| */ +short label_ptr; /* highest position occupied in |label_loc| */ + +@ @<Allocate or initialize ...@>= +mp->header_last=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); +xfree(mp->kern); +xfree(mp->param); + +@ @<Set init...@>= +for (k=0;k<= 255;k++ ) { + mp->tfm_width[k]=0; mp->tfm_height[k]=0; mp->tfm_depth[k]=0; mp->tfm_ital_corr[k]=0; + mp->char_exists[k]=false; mp->char_tag[k]=no_tag; mp->char_remainder[k]=0; + mp->skip_table[k]=undefined_label; +} +memset(mp->header_byte,0,(size_t)mp->header_size); +mp->bc=255; mp->ec=0; mp->nl=0; mp->nk=0; mp->ne=0; mp->np=0; +mp->internal[mp_boundary_char]=-unity; +mp->bch_label=undefined_label; +mp->label_loc[0]=-1; mp->label_ptr=0; + +@ @<Declarations@>= +static scaled mp_tfm_check (MP mp,quarterword m) ; + +@ @c +static scaled mp_tfm_check (MP mp,quarterword m) { + if ( abs(mp->internal[m])>=fraction_half ) { + print_err("Enormous "); mp_print(mp, mp->int_name[m]); +@.Enormous charwd...@> +@.Enormous chardp...@> +@.Enormous charht...@> +@.Enormous charic...@> +@.Enormous designsize...@> + mp_print(mp, " has been reduced"); + help1("Font metric dimensions must be less than 2048pt."); + mp_put_get_error(mp); + if ( mp->internal[m]>0 ) return (fraction_half-1); + else return (1-fraction_half); + } else { + return mp->internal[m]; + } +} + +@ @<Store the width information for character code~|c|@>= +if ( c<mp->bc ) mp->bc=(eight_bits)c; +if ( c>mp->ec ) mp->ec=(eight_bits)c; +mp->char_exists[c]=true; +mp->tfm_width[c]=mp_tfm_check(mp,mp_char_wd); +mp->tfm_height[c]=mp_tfm_check(mp, mp_char_ht); +mp->tfm_depth[c]=mp_tfm_check(mp, mp_char_dp); +mp->tfm_ital_corr[c]=mp_tfm_check(mp, mp_char_ic) + +@ Now let's consider \MP's special \.{TFM}-oriented commands. + +@<Cases of |do_statement|...@>= +case tfm_command: mp_do_tfm_command(mp); break; + +@ @d char_list_code 0 +@d lig_table_code 1 +@d extensible_code 2 +@d header_byte_code 3 +@d font_dimen_code 4 + +@<Put each...@>= +mp_primitive(mp, "charlist",tfm_command,char_list_code); +@:char_list_}{\&{charlist} primitive@> +mp_primitive(mp, "ligtable",tfm_command,lig_table_code); +@:lig_table_}{\&{ligtable} primitive@> +mp_primitive(mp, "extensible",tfm_command,extensible_code); +@:extensible_}{\&{extensible} primitive@> +mp_primitive(mp, "headerbyte",tfm_command,header_byte_code); +@:header_byte_}{\&{headerbyte} primitive@> +mp_primitive(mp, "fontdimen",tfm_command,font_dimen_code); +@:font_dimen_}{\&{fontdimen} primitive@> + +@ @<Cases of |print_cmd...@>= +case tfm_command: + switch (m) { + case char_list_code:mp_print(mp, "charlist"); break; + case lig_table_code:mp_print(mp, "ligtable"); break; + case extensible_code:mp_print(mp, "extensible"); break; + case header_byte_code:mp_print(mp, "headerbyte"); break; + default: mp_print(mp, "fontdimen"); break; + } + break; + +@ @<Declare action procedures for use by |do_statement|@>= +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_get_x_next(mp); mp_scan_expression(mp); + if ( mp->cur_type==mp_known ) { + c=mp_round_unscaled(mp, mp->cur_exp); + if ( c>=0 ) if ( c<256 ) return (eight_bits)c; + } else if ( mp->cur_type==mp_string_type ) { + if ( length(mp->cur_exp)==1 ) { + c=mp->str_pool[mp->str_start[mp->cur_exp]]; + return (eight_bits)c; + } + } + exp_err("Invalid code has been replaced by 0"); +@.Invalid code...@> + help2("I was looking for a number between 0 and 255, or for a", + "string of length 1. Didn't find it; will use 0 instead."); + mp_put_get_flush_error(mp, 0); c=0; + return (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 ){ + incr(mp->label_ptr); mp->label_loc[mp->label_ptr]=r; + mp->label_char[mp->label_ptr]=(eight_bits)c; + } + } else { + @<Complain about a character tag conflict@>; + } +} + +@ @<Complain about a character tag conflict@>= +{ + print_err("Character "); + if ( (c>' ')&&(c<127) ) mp_print_char(mp,xord(c)); + else if ( c==256 ) mp_print(mp, "||"); + else { mp_print(mp, "code "); mp_print_int(mp, c); }; + mp_print(mp, " is already "); +@.Character c is already...@> + switch (mp->char_tag[c]) { + case lig_tag: mp_print(mp, "in a ligtable"); break; + case list_tag: mp_print(mp, "in a charlist"); break; + case ext_tag: mp_print(mp, "extensible"); break; + } /* there are no other cases */ + help2("It's not legal to label a character more than once.", + "So I'll not change anything just now."); + mp_put_get_error(mp); +} + +@ @<Declare action procedures for use by |do_statement|@>= +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| */ + switch (mp->cur_mod) { + case char_list_code: + c=mp_get_code(mp); + /* we will store a list of character successors */ + while ( mp->cur_cmd==colon ) { + cc=mp_get_code(mp); mp_set_tag(mp, c,list_tag,cc); c=cc; + }; + break; + case lig_table_code: + if (mp->lig_kern==NULL) + mp->lig_kern = xmalloc((max_tfm_int+1),sizeof(four_quarters)); + if (mp->kern==NULL) + mp->kern = xmalloc((max_tfm_int+1),sizeof(scaled)); + @<Store a list of ligature/kern steps@>; + break; + case extensible_code: + @<Define an extensible recipe@>; + break; + case header_byte_code: + case font_dimen_code: + c=mp->cur_mod; mp_get_x_next(mp); + mp_scan_expression(mp); + if ( (mp->cur_type!=mp_known)||(mp->cur_exp<half_unit) ) { + exp_err("Improper location"); +@.Improper location@> + help2("I was looking for a known, positive number.", + "For safety's sake I'll ignore the present command."); + mp_put_get_error(mp); + } else { + j=mp_round_unscaled(mp, mp->cur_exp); + if ( mp->cur_cmd!=colon ) { + mp_missing_err(mp, ":"); +@.Missing `:'@> + help1("A colon should follow a headerbyte or fontinfo location."); + mp_back_error(mp); + } + if ( c==header_byte_code ) { + @<Store a list of header bytes@>; + } else { + if (mp->param==NULL) + mp->param = xmalloc((max_tfm_int+1),sizeof(scaled)); + @<Store a list of font dimensions@>; + } + } + break; + } /* there are no other cases */ +} + +@ @<Store a list of ligature/kern steps@>= +{ + mp->lk_started=false; +CONTINUE: + mp_get_x_next(mp); + if ((mp->cur_cmd==skip_to)&& mp->lk_started ) + @<Process a |skip_to| command and |goto done|@>; + if ( mp->cur_cmd==bchar_label ) { c=256; mp->cur_cmd=colon; } + else { mp_back_input(mp); c=mp_get_code(mp); }; + if ((mp->cur_cmd==colon)||(mp->cur_cmd==double_colon)) { + @<Record a label in a lig/kern subprogram and |goto continue|@>; + } + if ( mp->cur_cmd==lig_kern_token ) { + @<Compile a ligature/kern command@>; + } else { + print_err("Illegal ligtable step"); +@.Illegal ligtable step@> + help1("I was looking for `=:' or `kern' here."); + mp_back_error(mp); next_char(mp->nl)=qi(0); + op_byte(mp->nl)=qi(0); rem_byte(mp->nl)=qi(0); + skip_byte(mp->nl)=stop_flag+1; /* this specifies an unconditional stop */ + } + if ( mp->nl==max_tfm_int) mp_fatal_error(mp, "ligtable too large"); + incr(mp->nl); + if ( mp->cur_cmd==comma ) goto CONTINUE; + if ( skip_byte(mp->nl-1)<stop_flag ) skip_byte(mp->nl-1)=stop_flag; +} +DONE: + +@ @<Put each...@>= +mp_primitive(mp, "=:",lig_kern_token,0); +@:=:_}{\.{=:} primitive@> +mp_primitive(mp, "=:|",lig_kern_token,1); +@:=:/_}{\.{=:\char'174} primitive@> +mp_primitive(mp, "=:|>",lig_kern_token,5); +@:=:/>_}{\.{=:\char'174>} primitive@> +mp_primitive(mp, "|=:",lig_kern_token,2); +@:=:/_}{\.{\char'174=:} primitive@> +mp_primitive(mp, "|=:>",lig_kern_token,6); +@:=:/>_}{\.{\char'174=:>} primitive@> +mp_primitive(mp, "|=:|",lig_kern_token,3); +@:=:/_}{\.{\char'174=:\char'174} primitive@> +mp_primitive(mp, "|=:|>",lig_kern_token,7); +@:=:/>_}{\.{\char'174=:\char'174>} primitive@> +mp_primitive(mp, "|=:|>>",lig_kern_token,11); +@:=:/>_}{\.{\char'174=:\char'174>>} primitive@> +mp_primitive(mp, "kern",lig_kern_token,128); +@:kern_}{\&{kern} primitive@> + +@ @<Cases of |print_cmd...@>= +case lig_kern_token: + switch (m) { + case 0:mp_print(mp, "=:"); break; + case 1:mp_print(mp, "=:|"); break; + case 2:mp_print(mp, "|=:"); break; + case 3:mp_print(mp, "|=:|"); break; + case 5:mp_print(mp, "=:|>"); break; + case 6:mp_print(mp, "|=:>"); break; + case 7:mp_print(mp, "|=:|>"); break; + case 11:mp_print(mp, "|=:|>>"); break; + default: mp_print(mp, "kern"); break; + } + break; + +@ Local labels are implemented by maintaining the |skip_table| array, +where |skip_table[c]| is either |undefined_label| or the address of the +most recent lig/kern instruction that skips to local label~|c|. In the +latter case, the |skip_byte| in that instruction will (temporarily) +be zero if there were no prior skips to this label, or it will be the +distance to the prior skip. + +We may need to cancel skips that span more than 127 lig/kern steps. + +@d cancel_skips(A) mp->ll=(A); + do { + mp->lll=qo(skip_byte(mp->ll)); + skip_byte(mp->ll)=stop_flag; mp->ll=mp->ll-mp->lll; + } while (mp->lll!=0) +@d skip_error(A) { print_err("Too far to skip"); +@.Too far to skip@> + help1("At most 127 lig/kern steps can separate skipto1 from 1::."); + mp_error(mp); cancel_skips((A)); + } + +@<Process a |skip_to| command and |goto done|@>= +{ + c=mp_get_code(mp); + if ( mp->nl-mp->skip_table[c]>128 ) { + skip_error(mp->skip_table[c]); mp->skip_table[c]=undefined_label; + } + if ( mp->skip_table[c]==undefined_label ) skip_byte(mp->nl-1)=qi(0); + else skip_byte(mp->nl-1)=qi(mp->nl-mp->skip_table[c]-1); + mp->skip_table[c]=mp->nl-1; goto DONE; +} + +@ @<Record a label in a lig/kern subprogram and |goto continue|@>= +{ + if ( mp->cur_cmd==colon ) { + if ( c==256 ) mp->bch_label=mp->nl; + else mp_set_tag(mp, c,lig_tag,mp->nl); + } else if ( mp->skip_table[c]<undefined_label ) { + mp->ll=mp->skip_table[c]; mp->skip_table[c]=undefined_label; + do { + mp->lll=qo(skip_byte(mp->ll)); + if ( mp->nl-mp->ll>128 ) { + skip_error(mp->ll); goto CONTINUE; + } + skip_byte(mp->ll)=qi(mp->nl-mp->ll-1); mp->ll=mp->ll-mp->lll; + } while (mp->lll!=0); + } + goto CONTINUE; +} + +@ @<Compile a ligature/kern...@>= +{ + next_char(mp->nl)=qi(c); skip_byte(mp->nl)=qi(0); + if ( mp->cur_mod<128 ) { /* ligature op */ + op_byte(mp->nl)=qi(mp->cur_mod); rem_byte(mp->nl)=qi(mp_get_code(mp)); + } else { + mp_get_x_next(mp); mp_scan_expression(mp); + if ( mp->cur_type!=mp_known ) { + exp_err("Improper kern"); +@.Improper kern@> + help2("The amount of kern should be a known numeric value.", + "I'm zeroing this one. Proceed, with fingers crossed."); + mp_put_get_flush_error(mp, 0); + } + mp->kern[mp->nk]=mp->cur_exp; + k=0; + while ( mp->kern[k]!=mp->cur_exp ) incr(k); + if ( k==mp->nk ) { + if ( mp->nk==max_tfm_int ) mp_fatal_error(mp, "too many TFM kerns"); + incr(mp->nk); + } + op_byte(mp->nl)=kern_flag+(k / 256); + rem_byte(mp->nl)=qi((k % 256)); + } + mp->lk_started=true; +} + +@ @d missing_extensible_punctuation(A) + { mp_missing_err(mp, (A)); +@.Missing `\char`\#'@> + help1("I'm processing `extensible c: t,m,b,r'."); mp_back_error(mp); + } + +@<Define an extensible recipe@>= +{ + if ( mp->ne==256 ) mp_fatal_error(mp, "too many extensible recipies"); + c=mp_get_code(mp); mp_set_tag(mp, c,ext_tag,mp->ne); + if ( mp->cur_cmd!=colon ) missing_extensible_punctuation(":"); + ext_top(mp->ne)=qi(mp_get_code(mp)); + if ( mp->cur_cmd!=comma ) missing_extensible_punctuation(","); + ext_mid(mp->ne)=qi(mp_get_code(mp)); + if ( mp->cur_cmd!=comma ) missing_extensible_punctuation(","); + ext_bot(mp->ne)=qi(mp_get_code(mp)); + if ( mp->cur_cmd!=comma ) missing_extensible_punctuation(","); + ext_rep(mp->ne)=qi(mp_get_code(mp)); + incr(mp->ne); +} + +@ The header could contain ASCII zeroes, so can't use |strdup|. + +@<Store a list of header bytes@>= +do { + if ( j>=mp->header_size ) { + size_t l = (size_t)(mp->header_size + (mp->header_size/4)); + char *t = xmalloc(l,1); + memset(t,0,l); + 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); + incr(j); incr(mp->header_last); +} while (mp->cur_cmd==comma) + +@ @<Store a list of font dimensions@>= +do { + if ( j>max_tfm_int ) mp_fatal_error(mp, "too many fontdimens"); + while ( j>mp->np ) { incr(mp->np); mp->param[mp->np]=0; }; + mp_get_x_next(mp); mp_scan_expression(mp); + if ( mp->cur_type!=mp_known ){ + exp_err("Improper font parameter"); +@.Improper font parameter@> + help1("I'm zeroing this one. Proceed, with fingers crossed."); + mp_put_get_flush_error(mp, 0); + } + mp->param[j]=mp->cur_exp; incr(j); +} while (mp->cur_cmd==comma) + +@ OK: We've stored all the data that is needed for the \.{TFM} file. +All that remains is to output it in the correct format. + +An interesting problem needs to be solved in this connection, because +the \.{TFM} format allows at most 256~widths, 16~heights, 16~depths, +and 64~italic corrections. If the data has more distinct values than +this, we want to meet the necessary restrictions by perturbing the +given values as little as possible. + +\MP\ solves this problem in two steps. First the values of a given +kind (widths, heights, depths, or italic corrections) are sorted; +then the list of sorted values is perturbed, if necessary. + +The sorting operation is facilitated by having a special node of +essentially infinite |value| at the end of the current list. + +@<Initialize table entries...@>= +value(inf_val)=fraction_four; + +@ Straight linear insertion is good enough for sorting, since the lists +are usually not terribly long. As we work on the data, the current list +will start at |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(temp_head)=inf_val + +@c +static pointer mp_sort_in (MP mp,scaled v) { + pointer p,q,r; /* list manipulation registers */ + p=temp_head; + while (1) { + q=mp_link(p); + if ( v<=value(q) ) break; + p=q; + } + if ( v<value(q) ) { + r=mp_get_node(mp, value_node_size); value(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,scaled d) { + pointer p; /* runs through the current list */ + scaled l; /* the least element covered by the current interval */ + integer m; /* lower bound on the size of the minimum cover */ + m=0; p=mp_link(temp_head); mp->perturbation=el_gordo; + while ( p!=inf_val ){ + incr(m); l=value(p); + do { p=mp_link(p); } while (value(p)<=l+d); + if ( value(p)-l<mp->perturbation ) + mp->perturbation=value(p)-l; + } + return m; +} + +@ @<Glob...@>= +scaled perturbation; /* quantity related to \.{TFM} rounding */ +integer excess; /* the list is this much too long */ + +@ The smallest |d| such that a given list can be covered with |m| intervals +is determined by the |threshold| routine, which is sort of an inverse +to |min_cover|. The idea is to increase the interval size rapidly until +finding the range, then to go sequentially until the exact borderline has +been discovered. + +@c +static scaled mp_threshold (MP mp,integer m) { + scaled d; /* lower bound on the smallest interval size */ + mp->excess=mp_min_cover(mp, 0)-m; + if ( mp->excess<=0 ) { + return 0; + } else { + do { + d=mp->perturbation; + } while (mp_min_cover(mp, d+d)>m); + while ( mp_min_cover(mp, d)>m ) + d=mp->perturbation; + return d; + } +} + +@ The |skimp| procedure reduces the current list to at most |m| entries, +by changing values if necessary. It also sets |mp_info(p):=k| if |value(p)| +is the |k|th distinct value on the resulting list, and it sets +|perturbation| to the maximum amount by which a |value| field has +been changed. The size of the resulting list is returned as the +value of |skimp|. + +@c +static integer mp_skimp (MP mp,integer m) { + scaled d; /* the size of intervals being coalesced */ + pointer p,q,r; /* list manipulation registers */ + scaled l; /* the least value in the current interval */ + scaled v; /* a compromise value */ + d=mp_threshold(mp, m); mp->perturbation=0; + q=temp_head; m=0; p=mp_link(temp_head); + while ( p!=inf_val ) { + incr(m); l=value(p); mp_info(p)=m; + if ( value(mp_link(p))<=l+d ) { + @<Replace an interval of values by its midpoint@>; + } + q=p; p=mp_link(p); + } + return m; +} + +@ @<Replace an interval...@>= +{ + do { + p=mp_link(p); mp_info(p)=m; + decr(mp->excess); if ( mp->excess==0 ) d=0; + } while (value(mp_link(p))<=l+d); + v=l+halfp(value(p)-l); + if ( value(p)-v>mp->perturbation ) + mp->perturbation=value(p)-v; + r=q; + do { + r=mp_link(r); value(r)=v; + } while (r!=p); + mp_link(q)=p; /* remove duplicate values from the current list */ +} + +@ A warning message is issued whenever something is perturbed by +more than 1/16\thinspace pt. + +@c +static void mp_tfm_warning (MP mp,quarterword m) { + mp_print_nl(mp, "(some "); + mp_print(mp, mp->int_name[m]); +@.some charwds...@> +@.some chardps...@> +@.some charhts...@> +@.some charics...@> + mp_print(mp, " values had to be adjusted by as much as "); + mp_print_scaled(mp, mp->perturbation); mp_print(mp, "pt)"); +} + +@ Here's an example of how we use these routines. +The width data needs to be perturbed only if there are 256 distinct +widths, but \MP\ must check for this case even though it is +highly unusual. + +An integer variable |k| will be defined when we use this code. +The |dimen_head| array will contain pointers to the sorted +lists of dimensions. + +@<Massage the \.{TFM} widths@>= +clear_the_list; +for (k=mp->bc;k<=mp->ec;k++) { + if ( mp->char_exists[k] ) + mp->tfm_width[k]=mp_sort_in(mp, mp->tfm_width[k]); +} +mp->nw=mp_skimp(mp, 255)+1; mp->dimen_head[1]=mp_link(temp_head); +if ( mp->perturbation>=010000 ) mp_tfm_warning(mp, mp_char_wd) + +@ @<Glob...@>= +pointer dimen_head[5]; /* lists of \.{TFM} dimensions */ + +@ Heights, depths, and italic corrections are different from widths +not only because their list length is more severely restricted, but +also because zero values do not need to be put into the lists. + +@<Massage the \.{TFM} heights, depths, and italic corrections@>= +clear_the_list; +for (k=mp->bc;k<=mp->ec;k++) { + if ( mp->char_exists[k] ) { + if ( mp->tfm_height[k]==0 ) mp->tfm_height[k]=zero_val; + else mp->tfm_height[k]=mp_sort_in(mp, mp->tfm_height[k]); + } +} +mp->nh=mp_skimp(mp, 15)+1; mp->dimen_head[2]=mp_link(temp_head); +if ( mp->perturbation>=010000 ) mp_tfm_warning(mp, mp_char_ht); +clear_the_list; +for (k=mp->bc;k<=mp->ec;k++) { + if ( mp->char_exists[k] ) { + if ( mp->tfm_depth[k]==0 ) mp->tfm_depth[k]=zero_val; + else mp->tfm_depth[k]=mp_sort_in(mp, mp->tfm_depth[k]); + } +} +mp->nd=mp_skimp(mp, 15)+1; mp->dimen_head[3]=mp_link(temp_head); +if ( mp->perturbation>=010000 ) mp_tfm_warning(mp, mp_char_dp); +clear_the_list; +for (k=mp->bc;k<=mp->ec;k++) { + if ( mp->char_exists[k] ) { + if ( mp->tfm_ital_corr[k]==0 ) mp->tfm_ital_corr[k]=zero_val; + else mp->tfm_ital_corr[k]=mp_sort_in(mp, mp->tfm_ital_corr[k]); + } +} +mp->ni=mp_skimp(mp, 63)+1; mp->dimen_head[4]=mp_link(temp_head); +if ( mp->perturbation>=010000 ) mp_tfm_warning(mp, mp_char_ic) + +@ @<Initialize table entries...@>= +value(zero_val)=0; mp_info(zero_val)=0; + +@ Bytes 5--8 of the header are set to the design size, unless the user has +some crazy reason for specifying them differently. +@^design size@> + +Error messages are not allowed at the time this procedure is called, +so a warning is printed instead. + +The value of |max_tfm_dimen| is calculated so that +$$\hbox{|make_scaled(16*max_tfm_dimen,internal[mp_design_size])|} + < \\{three\_bytes}.$$ + +@d three_bytes 0100000000 /* $2^{24}$ */ + +@c +static void mp_fix_design_size (MP mp) { + scaled d; /* the design size */ + d=mp->internal[mp_design_size]; + if ( (d<unity)||(d>=fraction_half) ) { + if ( d!=0 ) + mp_print_nl(mp, "(illegal design size has been changed to 128pt)"); +@.illegal design size...@> + d=040000000; mp->internal[mp_design_size]=d; + } + if ( mp->header_byte[4]==0 && mp->header_byte[5]==0 && + mp->header_byte[6]==0 && mp->header_byte[7]==0 ) { + mp->header_byte[4]=d / 04000000; + mp->header_byte[5]=(d / 4096) % 256; + mp->header_byte[6]=(d / 16) % 256; + mp->header_byte[7]=(d % 16)*16; + } + mp->max_tfm_dimen=16*mp->internal[mp_design_size]-1-mp->internal[mp_design_size] / 010000000; + if ( mp->max_tfm_dimen>=fraction_half ) mp->max_tfm_dimen=fraction_half-1; +} + +@ The |dimen_out| procedure computes a |fix_word| relative to the +design size. If the data was out of range, it is corrected and the +global variable |tfm_changed| is increased by~one. + +@c +static integer mp_dimen_out (MP mp,scaled x) { + if ( abs(x)>mp->max_tfm_dimen ) { + incr(mp->tfm_changed); + if ( x>0 ) x=mp->max_tfm_dimen; else x=-mp->max_tfm_dimen; + } + x=mp_make_scaled(mp, x*16,mp->internal[mp_design_size]); + return x; +} + +@ @<Glob...@>= +scaled max_tfm_dimen; /* bound on widths, heights, kerns, etc. */ +integer tfm_changed; /* the number of data entries that were out of bounds */ + +@ If the user has not specified any of the first four header bytes, +the |fix_check_sum| procedure replaces them by a ``check sum'' computed +from the |tfm_width| data relative to the design size. +@^check sum@> + +@c +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(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 / unity); + x=x % unity; 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_b_open_out(mp, &mp->tfm_file, mp_filetype_metrics) ) + mp_prompt_file_name(mp, "file name for font metrics",".tfm"); +mp->metric_file_name=xstrdup(mp->name_of_file); +@<Output the subfile sizes and header bytes@>; +@<Output the character information bytes, then + output the dimensions themselves@>; +@<Output the ligature/kern program@>; +@<Output the extensible character recipes and the font metric parameters@>; + if ( mp->internal[mp_tracing_stats]>0 ) + @<Log the subfile sizes of the \.{TFM} file@>; +mp_print_nl(mp, "Font metrics written on "); +mp_print(mp, mp->metric_file_name); mp_print_char(mp, 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(mp_info(mp->tfm_width[k])); /* the width index */ + tfm_out((mp_info(mp->tfm_height[k]))*16+mp_info(mp->tfm_depth[k])); + tfm_out((mp_info(mp->tfm_ital_corr[k]))*4+mp->char_tag[k]); + tfm_out(mp->char_remainder[k]); + }; +} +mp->tfm_changed=0; +for (k=1;k<=4;k++) { + mp_tfm_four(mp, 0); p=mp->dimen_head[k]; + while ( p!=inf_val ) { + mp_tfm_four(mp, mp_dimen_out(mp, value(p))); p=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=mp_round_unscaled(mp, mp->internal[mp_boundary_char]); +if ((mp->bchar<0)||(mp->bchar>255)) { + mp->bchar=-1; mp->lk_started=false; lk_offset=0; +} else { + mp->lk_started=true; lk_offset=1; +} +@<Find the minimum |lk_offset| and adjust all remainders@>; +if ( mp->bch_label<undefined_label ) + { skip_byte(mp->nl)=qi(255); next_char(mp->nl)=qi(0); + op_byte(mp->nl)=qi(((mp->bch_label+lk_offset)/ 256)); + rem_byte(mp->nl)=qi(((mp->bch_label+lk_offset)% 256)); + incr(mp->nl); /* possibly |nl=lig_table_size+1| */ + } + +@ @<Find the minimum |lk_offset|...@>= +k=mp->label_ptr; /* pointer to the largest unallocated label */ +if ( mp->label_loc[k]+lk_offset>255 ) { + lk_offset=0; mp->lk_started=false; /* location 0 can do double duty */ + do { + mp->char_remainder[mp->label_char[k]]=lk_offset; + while ( mp->label_loc[k-1]==mp->label_loc[k] ) { + decr(k); mp->char_remainder[mp->label_char[k]]=lk_offset; + } + incr(lk_offset); decr(k); + } while (! (lk_offset+mp->label_loc[k]<256)); + /* N.B.: |lk_offset=256| satisfies this when |k=0| */ +} +if ( lk_offset>0 ) { + while ( k>0 ) { + mp->char_remainder[mp->label_char[k]] + =mp->char_remainder[mp->label_char[k]]+lk_offset; + decr(k); + } +} + +@ @<Output the ligature/kern program@>= +for (k=0;k<= 255;k++ ) { + if ( mp->skip_table[k]<undefined_label ) { + mp_print_nl(mp, "(local label "); mp_print_int(mp, k); mp_print(mp, ":: was missing)"); +@.local label l:: was missing@> + cancel_skips(mp->skip_table[k]); + } +} +if ( mp->lk_started ) { /* |lk_offset=1| for the special |bchar| */ + tfm_out(255); tfm_out(mp->bchar); mp_tfm_two(mp, 0); +} else { + for (k=1;k<=lk_offset;k++) {/* output the redirection specs */ + mp->ll=mp->label_loc[mp->label_ptr]; + if ( mp->bchar<0 ) { tfm_out(254); tfm_out(0); } + else { tfm_out(255); tfm_out(mp->bchar); }; + mp_tfm_two(mp, mp->ll+lk_offset); + do { + decr(mp->label_ptr); + } while (! (mp->label_loc[mp->label_ptr]<mp->ll)); + } +} +for (k=0;k<mp->nl;k++) mp_tfm_qqqq(mp, mp->lig_kern[k]); +for (k=0;k<mp->nk;k++) mp_tfm_four(mp, mp_dimen_out(mp, mp->kern[k])) + +@ @<Output the extensible character recipes...@>= +for (k=0;k<mp->ne;k++) + mp_tfm_qqqq(mp, mp->exten[k]); +for (k=1;k<=mp->np;k++) { + if ( k==1 ) { + if ( abs(mp->param[1])<fraction_half ) { + mp_tfm_four(mp, mp->param[1]*16); + } else { + incr(mp->tfm_changed); + if ( mp->param[1]>0 ) mp_tfm_four(mp, el_gordo); + else mp_tfm_four(mp, -el_gordo); + } + } else { + mp_tfm_four(mp, mp_dimen_out(mp, mp->param[k])); + } +} +if ( mp->tfm_changed>0 ) { + if ( mp->tfm_changed==1 ) mp_print_nl(mp, "(a font metric dimension"); +@.a font metric dimension...@> + else { + mp_print_nl(mp, "("); mp_print_int(mp, mp->tfm_changed); +@.font metric dimensions...@> + mp_print(mp, " font metric dimensions"); + } + mp_print(mp, " had to be decreased)"); +} + +@ @<Log the subfile sizes of the \.{TFM} file@>= +{ + char s[200]; + wlog_ln(" "); + if ( mp->bch_label<undefined_label ) decr(mp->nl); + 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); +} + +@* \[43] Reading font metric data. + +\MP\ isn't a typesetting program but it does need to find the bounding box +of a sequence of typeset characters. Thus it needs to read \.{TFM} files as +well as write them. + +@<Glob...@>= +void * tfm_infile; + +@ All the width, height, and depth information is stored in an array called +|font_info|. This array is allocated sequentially and each font is stored +as a series of |char_info| words followed by the width, height, and depth +tables. Since |font_name| entries are permanent, their |str_ref| values are +set to |max_str_ref|. + +@<Types...@>= +typedef unsigned int font_number; /* |0..font_max| */ + +@ The |font_info| array is indexed via a group directory arrays. +For example, the |char_info| data for character~|c| in font~|f| will be +in |font_info[char_base[f]+c].qqqq|. + +@<Glob...@>= +font_number font_max; /* maximum font number for included text fonts */ +size_t font_mem_size; /* number of words for \.{TFM} information for text fonts */ +memory_word *font_info; /* height, width, and depth data */ +char **font_enc_name; /* encoding names, if any */ +boolean *font_ps_name_fixed; /* are the postscript names fixed already? */ +size_t next_fmem; /* next unused entry in |font_info| */ +font_number last_fnum; /* last font number used so far */ +scaled *font_dsize; /* 16 times the ``design'' size in \ps\ points */ +char **font_name; /* name as specified in the \&{infont} command */ +char **font_ps_name; /* PostScript name for use when |internal[mp_prologues]>0| */ +font_number last_ps_fnum; /* last valid |font_ps_name| index */ +eight_bits *font_bc; +eight_bits *font_ec; /* first and last character code */ +int *char_base; /* base address for |char_info| */ +int *width_base; /* index for zeroth character width */ +int *height_base; /* index for zeroth character height */ +int *depth_base; /* index for zeroth character depth */ +pointer *font_sizes; + +@ @<Allocate or initialize ...@>= +mp->font_mem_size = 10000; +mp->font_info = xmalloc ((mp->font_mem_size+1),sizeof(memory_word)); +memset (mp->font_info,0,sizeof(memory_word)*(mp->font_mem_size+1)); +mp->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]); +} +xfree(mp->font_info); +xfree(mp->font_enc_name); +xfree(mp->font_ps_name_fixed); +xfree(mp->font_dsize); +xfree(mp->font_name); +xfree(mp->font_ps_name); +xfree(mp->font_bc); +xfree(mp->font_ec); +xfree(mp->char_base); +xfree(mp->width_base); +xfree(mp->height_base); +xfree(mp->depth_base); +xfree(mp->font_sizes); + +@ +@c +void mp_reallocate_fonts (MP mp, font_number l) { + font_number f; + XREALLOC(mp->font_enc_name, l, char *); + XREALLOC(mp->font_ps_name_fixed, l, boolean); + XREALLOC(mp->font_dsize, l, scaled); + XREALLOC(mp->font_name, l, char *); + XREALLOC(mp->font_ps_name, l, char *); + XREALLOC(mp->font_bc, l, eight_bits); + XREALLOC(mp->font_ec, l, eight_bits); + XREALLOC(mp->char_base, l, int); + XREALLOC(mp->width_base, l, int); + XREALLOC(mp->height_base, l, int); + XREALLOC(mp->depth_base, l, int); + XREALLOC(mp->font_sizes, l, pointer); + for (f=(mp->last_fnum+1);f<=l;f++) { + mp->font_enc_name[f]=NULL; + mp->font_ps_name_fixed[f] = false; + mp->font_name[f]=NULL; + mp->font_ps_name[f]=NULL; + mp->font_sizes[f]=null; + } + mp->font_max = l; +} + +@ @<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; +mp->font_name[null_font]=(char *)"nullfont"; +mp->font_ps_name[null_font]=(char *)""; +mp->font_ps_name_fixed[null_font] = false; +mp->font_enc_name[null_font]=NULL; +mp->font_sizes[null_font]=null; + +@ Each |char_info| word is of type |four_quarters|. The |b0| field contains +the |width index|; the |b1| field contains the height +index; the |b2| fields contains the depth index, and the |b3| field used only +for temporary storage. (It is used to keep track of which characters occur in +an edge structure that is being shipped out.) +The corresponding words in the width, height, and depth tables are stored as +|scaled| values in units of \ps\ points. + +With the macros below, the |char_info| word for character~|c| in font~|f| is +|char_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 ) { + mp_xfree(f); + return n; + } + } + n = mp_read_font_info(mp, f); + mp_xfree(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); + + +@ One simple application of |find_font| is the implementation of the |font_size| +operator that gets the design size for a given font name. + +@<Find the design size of the font whose name is |cur_exp|@>= +mp_flush_cur_exp(mp, (mp->font_dsize[mp_find_font(mp, str(mp->cur_exp))]+8) / 16) + +@ If we discover that the font doesn't have a requested character, we omit it +from the bounding box computation and expect the \ps\ interpreter to drop it. +This routine issues a warning message if the user has asked for it. + +@<Declarations@>= +static void mp_lost_warning (MP mp,font_number f, pool_pointer k); + +@ @c +void mp_lost_warning (MP mp,font_number f, pool_pointer k) { + if ( mp->internal[mp_tracing_lost_chars]>0 ) { + mp_begin_diagnostic(mp); + if ( mp->selector==log_only ) incr(mp->selector); + mp_print_nl(mp, "Missing character: There is no "); +@.Missing character@> + mp_print_str(mp, mp->str_pool[k]); + mp_print(mp, " in font "); + mp_print(mp, mp->font_name[f]); mp_print_char(mp, 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,pointer p); + +@ @c +void mp_set_text_box (MP mp,pointer p) { + font_number f; /* |mp_font_n(p)| */ + ASCII_code bc,ec; /* range of valid characters for font |f| */ + pool_pointer k,kk; /* current character and character to stop at */ + four_quarters cc; /* the |char_info| for the current character */ + scaled h,d; /* dimensions of the current character */ + width_val(p)=0; + height_val(p)=-el_gordo; + depth_val(p)=-el_gordo; + f=(font_number)mp_font_n(p); + bc=mp->font_bc[f]; + ec=mp->font_ec[f]; + kk=str_stop(mp_text_p(p)); + k=mp->str_start[mp_text_p(p)]; + while ( k<kk ) { + @<Adjust |p|'s bounding box to contain |str_pool[k]|; advance |k|@>; + } + @<Set the height and depth to zero if the bounding box is empty@>; +} + +@ @<Adjust |p|'s bounding box to contain |str_pool[k]|; advance |k|@>= +{ + if ( (mp->str_pool[k]<bc)||(mp->str_pool[k]>ec) ) { + mp_lost_warning(mp, f,k); + } else { + cc=char_mp_info(f,mp->str_pool[k]); + if ( ! ichar_exists(cc) ) { + mp_lost_warning(mp, f,k); + } else { + width_val(p)=width_val(p)+char_width(f,cc); + h=char_height(f,cc); + d=char_depth(f,cc); + if ( h>height_val(p) ) height_val(p)=h; + if ( d>depth_val(p) ) depth_val(p)=d; + } + } + incr(k); +} + +@ Let's hope modern compilers do comparisons correctly when the difference would +overflow. + +@<Set the height and depth to zero if the bounding box is empty@>= +if ( height_val(p)<-depth_val(p) ) { + height_val(p)=0; + depth_val(p)=0; +} + +@ The new primitives fontmapfile and fontmapline. + +@<Declare action procedures for use by |do_statement|@>= +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_type!=mp_string_type ) { + @<Complain about improper map operation@>; + } else { + mp_map_file(mp,mp->cur_exp); + } +} +static void mp_do_mapline (MP mp) { + mp_get_x_next(mp); mp_scan_expression(mp); + if ( mp->cur_type!=mp_string_type ) { + @<Complain about improper map operation@>; + } else { + mp_map_line(mp,mp->cur_exp); + } +} + +@ @<Complain about improper map operation@>= +{ + exp_err("Unsuitable expression"); + help1("Only known strings can be map files or map lines."); + mp_put_get_error(mp); +} + +@ To print |scaled| value to PDF output we need some subroutines to ensure +accurary. + +@d max_integer 0x7FFFFFFF /* $2^{31}-1$ */ + +@<Glob...@>= +scaled one_bp; /* scaled value corresponds to 1bp */ +scaled one_hundred_bp; /* scaled value corresponds to 100bp */ +scaled one_hundred_inch; /* scaled value corresponds to 100in */ +integer ten_pow[10]; /* $10^0..10^9$ */ +integer scaled_out; /* amount of |scaled| that was taken out in |divide_scaled| */ + +@ @<Set init...@>= +mp->one_bp = 65782; /* 65781.76 */ +mp->one_hundred_bp = 6578176; +mp->one_hundred_inch = 473628672; +mp->ten_pow[0] = 1; +for (i = 1;i<= 9; i++ ) { + mp->ten_pow[i] = 10*mp->ten_pow[i - 1]; +} + +@ The following function divides |s| by |m|. |dd| is number of decimal digits. + +@c scaled mp_divide_scaled (MP mp,scaled s, scaled m, integer dd) { + scaled q,r; + integer sign,i; + sign = 1; + if ( s < 0 ) { sign = -sign; s = -s; } + if ( m < 0 ) { sign = -sign; m = -m; } + if ( m == 0 ) + mp_confusion(mp, "arithmetic: divided by zero"); + else if ( m >= (max_integer / 10) ) + mp_confusion(mp, "arithmetic: number too big"); + q = s / m; + r = s % m; + for (i = 1;i<=dd;i++) { + q = 10*q + (10*r) / m; + r = (10*r) % m; + } + if ( 2*r >= m ) { incr(q); r = r - m; } + mp->scaled_out = sign*(s - (r / mp->ten_pow[dd])); + return (sign*q); +} + +@* \[44] Shipping pictures out. +The |ship_out| procedure, to be described below, is given a pointer to +an edge structure. Its mission is to output a file containing the \ps\ +description of an edge structure. + +@ Each time an edge structure is shipped out we write a new \ps\ output +file named according to the current \&{charcode}. +@:char_code_}{\&{charcode} primitive@> + +This is the only backend function that remains in the main |mpost.w| file. +There are just too many variable accesses needed for status reporting +etcetera to make it worthwile to move the code to |psout.w|. + +@<Internal library declarations@>= +void mp_open_output_file (MP mp) ; + +@ @c +static 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 */ + pool_pointer i; /* indexes into |filename_template| */ + integer cc; /* a temporary integer for template building */ + integer f,g=0; /* field widths */ + if ( mp->job_name==NULL ) mp_open_log_file(mp); + if ( mp->internal[mp_output_template]==0) { + char *s; /* a file extension derived from |c| */ + if ( c<0 ) + s=xstrdup(".ps"); + else + @<Use |c| to compute the file extension |s|@>; + mp_pack_job_name(mp, s); + free(s); + ss = xstrdup(mp->name_of_file); + } else { /* initializations */ + str_number s, n; /* a file extension derived from |c| */ + old_setting=mp->selector; + mp->selector=new_string; + f = 0; + i = mp->str_start[mp->internal[mp_output_template]]; + n = null_str; /* initialize */ + while ( i<str_stop(mp->internal[mp_output_template]) ) { + if ( mp->str_pool[i]=='%' ) { + CONTINUE: + incr(i); + if ( i<str_stop(mp->internal[mp_output_template]) ) { + if ( mp->str_pool[i]=='j' ) { + mp_print(mp, mp->job_name); + } else if ( mp->str_pool[i]=='o' ) { + { char *s; + s = str(mp->internal[mp_output_format]); + mp_print(mp, s); + mp_xfree(s); + } + } else if ( mp->str_pool[i]=='d' ) { + cc= mp_round_unscaled(mp, mp->internal[mp_day]); + print_with_leading_zeroes(cc); + } else if ( mp->str_pool[i]=='m' ) { + cc= mp_round_unscaled(mp, mp->internal[mp_month]); + print_with_leading_zeroes(cc); + } else if ( mp->str_pool[i]=='y' ) { + cc= mp_round_unscaled(mp, mp->internal[mp_year]); + print_with_leading_zeroes(cc); + } else if ( mp->str_pool[i]=='H' ) { + cc= mp_round_unscaled(mp, mp->internal[mp_time]) / 60; + print_with_leading_zeroes(cc); + } else if ( mp->str_pool[i]=='M' ) { + cc= mp_round_unscaled(mp, mp->internal[mp_time]) % 60; + print_with_leading_zeroes(cc); + } else if ( mp->str_pool[i]=='c' ) { + if ( c<0 ) mp_print(mp, "ps"); + else print_with_leading_zeroes(c); + } else if ( (mp->str_pool[i]>='0') && + (mp->str_pool[i]<='9') ) { + if ( (f<10) ) + f = (f*10) + mp->str_pool[i]-'0'; + goto CONTINUE; + } else { + mp_print_str(mp, mp->str_pool[i]); + } + } + } else { + if ( mp->str_pool[i]=='.' ) + if (length(n)==0) + n = mp_make_string(mp); + mp_print_str(mp, mp->str_pool[i]); + }; + incr(i); + } + s = mp_make_string(mp); + mp->selector= old_setting; + if (length(n)==0) { + n=s; + s=null_str; + } + ss = str(s); + nn = str(n); + mp_pack_file_name(mp, nn,"",ss); + free(nn); + delete_str_ref(n); + delete_str_ref(s); + } + return ss; +} + +static char * mp_get_output_file_name (MP mp) { + char *f; + char *saved_name; /* saved |name_of_file| */ + saved_name = xstrdup(mp->name_of_file); + f = xstrdup(mp_set_output_file_name(mp, mp_round_unscaled(mp, mp->internal[mp_char_code]))); + 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 */ + integer c; /* \&{charcode} rounded to the nearest integer */ + c=mp_round_unscaled(mp, mp->internal[mp_char_code]); + ss = mp_set_output_file_name(mp, c); + while ( ! mp_a_open_out(mp, (void *)&mp->output_file, mp_filetype_postscript) ) + mp_prompt_file_name(mp, "file name for output",ss); + xfree(ss); + @<Store the true output file name if appropriate@>; +} + +@ The file extension created here could be up to five characters long in +extreme cases so it may have to be shortened on some systems. +@^system dependencies@> + +@<Use |c| to compute the file extension |s|@>= +{ + s = xmalloc(7,1); + mp_snprintf(s,7,".%i",(int)c); +} + +@ The user won't want to see all the output file names so we only save the +first and last ones and a count of how many there were. For this purpose +files are ordered primarily by \&{charcode} and secondarily by order of +creation. +@:char_code_}{\&{charcode} primitive@> + +@<Store the true output file name if appropriate@>= +if ((c<mp->first_output_code)&&(mp->first_output_code>=0)) { + mp->first_output_code=c; + xfree(mp->first_file_name); + mp->first_file_name=xstrdup(mp->name_of_file); +} +if ( c>=mp->last_output_code ) { + mp->last_output_code=c; + xfree(mp->last_file_name); + mp->last_file_name=xstrdup(mp->name_of_file); +} + +@ @<Glob...@>= +char * first_file_name; +char * last_file_name; /* full file names */ +integer first_output_code;integer last_output_code; /* rounded \&{charcode} values */ +@:char_code_}{\&{charcode} primitive@> +integer total_shipped; /* total number of |ship_out| operations completed */ + +@ @<Set init...@>= +mp->first_file_name=xstrdup(""); +mp->last_file_name=xstrdup(""); +mp->first_output_code=32768; +mp->last_output_code=-32768; +mp->total_shipped=0; + +@ @<Dealloc variables@>= +xfree(mp->first_file_name); +xfree(mp->last_file_name); + +@ @<Begin the progress report for the output of picture~|c|@>= +if ( (int)mp->term_offset>mp->max_print_line-6 ) mp_print_ln(mp); +else if ( (mp->term_offset>0)||(mp->file_offset>0) ) mp_print_char(mp, 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); + } + } +} + +@ @<Internal library declarations@>= +boolean mp_has_font_size(MP mp, font_number f ); + +@ @c +boolean mp_has_font_size(MP mp, font_number f ) { + return (mp->font_sizes[f]!=null); +} + +@ The \&{special} command saves up lines of text to be printed during the next +|ship_out| operation. The saved items are stored as a list of capsule tokens. + +@<Glob...@>= +pointer last_pending; /* the last token in a list of pending specials */ + +@ @<Set init...@>= +mp->last_pending=spec_head; + +@ @<Cases of |do_statement|...@>= +case special_command: + if ( mp->cur_mod==0 ) mp_do_special(mp); else + if ( mp->cur_mod==1 ) mp_do_mapfile(mp); else + mp_do_mapline(mp); + break; + +@ @<Declare action procedures for use by |do_statement|@>= +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_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@>= +{ + exp_err("Unsuitable expression"); + help1("Only known strings are allowed for output as specials."); + mp_put_get_error(mp); +} + +@ On the export side, we need an extra object type for special strings. + +@<Graphical object codes@>= +mp_special_code=8, + +@ @<Export pending specials@>= +p=mp_link(spec_head); +while ( p!=null ) { + mp_special_object *tp; + tp = (mp_special_object *)mp_new_graphic_object(mp,mp_special_code); + gr_pre_script(tp) = str(value(p)); + if (hh->body==NULL) hh->body = (mp_graphic_object *)tp; + else gr_link(hp) = (mp_graphic_object *)tp; + hp = (mp_graphic_object *)tp; + p=mp_link(p); +} +mp_flush_token_list(mp, mp_link(spec_head)); +mp_link(spec_head)=null; +mp->last_pending=spec_head + +@ We are now ready for the main output procedure. Note that the |selector| +setting is saved in a global variable so that |begin_diagnostic| can access it. + +@<Declare the \ps\ output procedures@>= +static void mp_ship_out (MP mp, pointer h) ; + +@ Once again, the |gr_XXXX| macros are defined in |mppsout.h| + +@d export_color(q,p) + if ( mp_color_model(p)==mp_uninitialized_model ) { + gr_color_model(q) = (unsigned char)(mp->internal[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 ? unity : 0); + } else { + gr_color_model(q) = (unsigned char)mp_color_model(p); + gr_cyan_val(q) = cyan_val(p); + gr_magenta_val(q) = magenta_val(p); + gr_yellow_val(q) = yellow_val(p); + gr_black_val(q) = black_val(p); + } + +@d export_scripts(q,p) + if (mp_pre_script(p)!=null) gr_pre_script(q) = str(mp_pre_script(p)); + if (mp_post_script(p)!=null) gr_post_script(q) = str(mp_post_script(p)); + +@c +struct mp_edge_object *mp_gr_export(MP mp, pointer h) { + pointer p; /* the current graphical object */ + integer t; /* a temporary value */ + integer c; /* a rounded charcode */ + scaled 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 = minx_val(h); + hh->miny = miny_val(h); + hh->maxx = maxx_val(h); + hh->maxy = maxy_val(h); + hh->filename = mp_get_output_file_name(mp); + c = mp_round_unscaled(mp,mp->internal[mp_char_code]); + hh->charcode = c; + hh->width = mp->internal[mp_char_wd]; + hh->height = mp->internal[mp_char_ht]; + hh->depth = mp->internal[mp_char_dp]; + hh->ital_corr = mp->internal[mp_char_ic]; + @<Export pending specials@>; + p=mp_link(dummy_loc(h)); + while ( p!=null ) { + hq = mp_new_graphic_object(mp,mp_type(p)); + switch (mp_type(p)) { + case mp_fill_code: + tf = (mp_fill_object *)hq; + gr_pen_p(tf) = mp_export_knot_list(mp,mp_pen_p(p)); + d_width = mp_get_pen_scale(mp, mp_pen_p(p)); + if ((mp_pen_p(p)==null) || pen_is_elliptical(mp_pen_p(p))) { + gr_path_p(tf) = mp_export_knot_list(mp,mp_path_p(p)); + } else { + pointer pc, pp; + pc = mp_copy_path(mp, mp_path_p(p)); + pp = mp_make_envelope(mp, pc, mp_pen_p(p),ljoin_val(p),0,miterlim_val(p)); + gr_path_p(tf) = mp_export_knot_list(mp,pp); + mp_toss_knot_list(mp, pp); + pc = mp_htap_ypoc(mp, mp_path_p(p)); + pp = mp_make_envelope(mp, pc, mp_pen_p(p),ljoin_val(p),0,miterlim_val(p)); + gr_htap_p(tf) = mp_export_knot_list(mp,pp); + mp_toss_knot_list(mp, pp); + } + export_color(tf,p) ; + export_scripts(tf,p); + gr_ljoin_val(tf) = (unsigned char)ljoin_val(p); + gr_miterlim_val(tf) = miterlim_val(p); + break; + case mp_stroked_code: + ts = (mp_stroked_object *)hq; + gr_pen_p(ts) = mp_export_knot_list(mp,mp_pen_p(p)); + d_width = mp_get_pen_scale(mp, mp_pen_p(p)); + if (pen_is_elliptical(mp_pen_p(p))) { + gr_path_p(ts) = mp_export_knot_list(mp,mp_path_p(p)); + } else { + pointer pc; + pc=mp_copy_path(mp, mp_path_p(p)); + t=lcap_val(p); + if ( mp_left_type(pc)!=mp_endpoint ) { + mp_left_type(mp_insert_knot(mp, pc,mp_x_coord(pc),mp_y_coord(pc)))=mp_endpoint; + mp_right_type(pc)=mp_endpoint; + pc=mp_link(pc); + t=1; + } + pc=mp_make_envelope(mp,pc,mp_pen_p(p),ljoin_val(p),t,miterlim_val(p)); + gr_path_p(ts) = mp_export_knot_list(mp,pc); + mp_toss_knot_list(mp, pc); + } + export_color(ts,p) ; + export_scripts(ts,p); + gr_ljoin_val(ts) = (unsigned char)ljoin_val(p); + gr_miterlim_val(ts) = miterlim_val(p); + gr_lcap_val(ts) = (unsigned char)lcap_val(p); + gr_dash_p(ts) = mp_export_dashes(mp,p,&d_width); + break; + case mp_text_code: + tt = (mp_text_object *)hq; + gr_text_p(tt) = str(mp_text_p(p)); + gr_text_l(tt) = (size_t)length(mp_text_p(p)); + 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) = (unsigned int)mp->font_dsize[mp_font_n(p)]; + export_color(tt,p) ; + export_scripts(tt,p); + gr_width_val(tt) = width_val(p); + gr_height_val(tt) = height_val(p); + gr_depth_val(tt) = depth_val(p); + gr_tx_val(tt) = tx_val(p); + gr_ty_val(tt) = ty_val(p); + gr_txx_val(tt) = txx_val(p); + gr_txy_val(tt) = txy_val(p); + gr_tyx_val(tt) = tyx_val(p); + gr_tyy_val(tt) = tyy_val(p); + break; + case mp_start_clip_code: + tc = (mp_clip_object *)hq; + gr_path_p(tc) = mp_export_knot_list(mp,mp_path_p(p)); + break; + case mp_start_bounds_code: + tb = (mp_bounds_object *)hq; + gr_path_p(tb) = mp_export_knot_list(mp,mp_path_p(p)); + break; + case mp_stop_clip_code: + case mp_stop_bounds_code: + /* nothing to do here */ + break; + } + if (hh->body==NULL) hh->body=hq; else gr_link(hp) = hq; + hp = hq; + p=mp_link(p); + } + return hh; +} + +@ @<Declarations@>= +static struct mp_edge_object *mp_gr_export(MP mp, int h); + +@ This function is now nearly trivial. + +@c +void mp_ship_out (MP mp, pointer h) { /* output edge structure |h| */ + integer c; /* \&{charcode} rounded to the nearest integer */ + c=mp_round_unscaled(mp, mp->internal[mp_char_code]); + @<Begin the progress report for the output of picture~|c|@>; + (mp->shipout_backend) (mp, h); + @<End progress report@>; + if ( mp->internal[mp_tracing_output]>0 ) + mp_print_edges(mp, h," (just shipped out)",true); +} + +@ @<Declarations@>= +static void mp_shipout_backend (MP mp, pointer h); + +@ +@c +void mp_shipout_backend (MP mp, pointer h) { + char *s; + mp_edge_object *hh; /* the first graphical object */ + hh = mp_gr_export(mp,h); + s = NULL; + if (mp->internal[mp_output_format]>0) + s = str(mp->internal[mp_output_format]); + if (s && strcmp(s,"svg")==0) { + (void)mp_svg_gr_ship_out (hh, + (mp->internal[mp_prologues]/65536), + false); + } else { + (void)mp_gr_ship_out (hh, + (mp->internal[mp_prologues]/65536), + (mp->internal[mp_procset]/65536), + false); + } + mp_gr_toss_objects(hh); +} + +@ @<Exported types@>= +typedef void (*mp_backend_writer)(MP, int); + +@ @<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. + +@ @<Determine if a character has been shipped out@>= +{ + mp->cur_exp=mp_round_unscaled(mp, mp->cur_exp) % 256; + if ( mp->cur_exp<0 ) mp->cur_exp=mp->cur_exp+256; + boolean_reset(mp->char_exists[mp->cur_exp]); + mp->cur_type=mp_boolean_type; +} + +@ @<Glob...@>= +psout_data ps; +svgout_data svg; + +@ @<Allocate or initialize ...@>= +mp_ps_backend_initialize(mp); +mp_svg_backend_initialize(mp); + +@ @<Dealloc...@>= +mp_ps_backend_free(mp); +mp_svg_backend_free(mp); + + +@* \[45] Dumping and undumping the tables. +After \.{INIMP} has seen a collection of macros, it +can write all the necessary information on an auxiliary file so +that production versions of \MP\ are able to initialize their +memory at high speed. The present section of the program takes +care of such output and input. We shall consider simultaneously +the processes of storing and restoring, +so that the inverse relation between them is clear. +@.INIMP@> + +The global variable |mem_ident| is a string that is printed right +after the |banner| line when \MP\ is ready to start. For \.{INIMP} this +string says simply `\.{(INIMP)}'; for other versions of \MP\ it says, +for example, `\.{(mem=plain 1990.4.14)}', showing the year, +month, and day that the mem file was created. We have |mem_ident=0| +before \MP's tables are loaded. + +@<Glob...@>= +char * mem_ident; +void * mem_file; /* for input or output of mem information */ + +@ @<Set init...@>= +mp->mem_ident=NULL; + +@ @<Initialize table entries...@>= +mp->mem_ident=xstrdup(" (INIMP)"); + +@ @<Declarations@>= +extern void mp_store_mem_file (MP mp) ; +extern boolean mp_load_mem_file (MP mp); +extern int mp_undump_constants (MP mp); + +@ @<Dealloc variables@>= +xfree(mp->mem_ident); + + +@* \[46] The main program. +This is it: the part of \MP\ that executes all those procedures we have +written. + +Well---almost. We haven't put the parsing subroutines into the +program yet; and we'd better leave space for a few more routines that may +have been forgotten. + +@c @<Declare the basic parsing subroutines@> +@<Declare miscellaneous procedures that were declared |forward|@> + +@ We've noted that there are two versions of \MP. One, called \.{INIMP}, +@.INIMP@> +has to be run first; it initializes everything from scratch, without +reading a mem file, and it has the capability of dumping a mem file. +The other one is called `\.{VIRMP}'; it is a ``virgin'' program that needs +@.VIRMP@> +to input a mem file in order to get started. \.{VIRMP} typically has +a bit more memory capacity than \.{INIMP}, because it does not need the +space consumed by the dumping/undumping routines and the numerous calls on +|primitive|, etc. + +The \.{VIRMP} program cannot read a mem file instantaneously, of course; +the best implementations therefore allow for production versions of \MP\ that +not only avoid the loading routine for object code, they also have +a mem file pre-loaded. + +@ @<Option variables@>= +int ini_version; /* are we iniMP? */ + +@ @<Set |ini_version|@>= +mp->ini_version = (opt->ini_version ? true : false); + +@ The code below make the final chosen hash size the next larger +multiple of 2 from the requested size, and this array is a list of +suitable prime numbers to go with such values. + +The top limit is chosen such that it is definately lower than +|max_halfword-3*param_size|, because |param_size| cannot be larger +than |max_halfword/sizeof(pointer)|. + +@<Declarations@>= +static int mp_prime_choices[] = + { 12289, 24593, 49157, 98317, + 196613, 393241, 786433, 1572869, + 3145739, 6291469, 12582917, 25165843, + 50331653, 100663319 }; + +@ @<Find constant sizes@>= +if (mp->ini_version) { + unsigned i = 14; + set_value(mp->mem_top,opt->main_memory,5000); + mp->mem_max = mp->mem_top; + set_value(mp->param_size,opt->param_size,150); + set_value(mp->max_in_open,opt->max_in_open,10); + if (opt->hash_size>0x8000000) + opt->hash_size=0x8000000; + if (opt->hash_size>0) { + set_value(mp->hash_size,(2*opt->hash_size-1),16384); + } else { + mp->hash_size = 16384; + } + mp->hash_size = mp->hash_size>>i; + while (mp->hash_size>=2) { + mp->hash_size /= 2; + i++; + } + mp->hash_size = mp->hash_size << i; + if (mp->hash_size>0x8000000) + mp->hash_size=0x8000000; + mp->hash_prime=mp_prime_choices[(i-14)]; +} else { + int i = -1; + if (mp->mem_name == NULL) { + mp->mem_name = mp_xstrdup(mp,"plain"); + } + if (mp_open_mem_file(mp)) { + i = mp_undump_constants(mp); + if (i != metapost_magic) + goto OFF_BASE; + set_value(mp->mem_max,opt->main_memory,mp->mem_top); + goto DONE; +OFF_BASE: + wterm_ln("(Fatal mem file error; "); + wterm((mp->find_file)(mp, mp->mem_name, "r", mp_filetype_memfile)); + if (i>metapost_old_magic && i<metapost_magic) { + wterm(" was written by an older version)\n"); + } else { + wterm(" appears not to be a mem file)\n"); + } + } + mp->history = mp_fatal_error_stop; + mp_jump_out(mp); +} +DONE: + + +@ Here we do whatever is needed to complete \MP's job gracefully on the +local operating system. The code here might come into play after a fatal +error; it must therefore consist entirely of ``safe'' operations that +cannot produce error messages. For example, it would be a mistake to call +|str_room| or |make_string| at this time, because a call on |overflow| +might lead to an infinite loop. +@^system dependencies@> + +This program doesn't bother to close the input files that may still be open. + +@ @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 */ + pointer 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 ( mp->internal[mp_tracing_stats]>0 ) + @<Output statistics about this job@>; + wake_up_terminal; + @<Do all the finishing work on the \.{TFM} file@>; + @<Explain what output files were written@>; + if ( mp->log_opened && ! 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 ( mp->internal[mp_fontmaking]>0 ) { + @<Make the dynamic memory into one big available node@>; + @<Massage the \.{TFM} widths@>; + mp_fix_design_size(mp); mp_fix_check_sum(mp); + @<Massage the \.{TFM} heights, depths, and italic corrections@>; + mp->internal[mp_fontmaking]=0; /* avoid loop in case of fatal error */ + @<Finish the \.{TFM} file@>; +} + +@ @<Make the dynamic memory into one big available node@>= +mp->rover=lo_mem_stat_max+1; mp_link(mp->rover)=empty_flag; mp->lo_mem_max=mp->hi_mem_min-1; +if ( mp->lo_mem_max-mp->rover>max_halfword ) mp->lo_mem_max=max_halfword+mp->rover; +node_size(mp->rover)=mp->lo_mem_max-mp->rover; +lmp_link(mp->rover)=mp->rover; rmp_link(mp->rover)=mp->rover; +mp_link(mp->lo_mem_max)=null; mp_info(mp->lo_mem_max)=null + +@ The present section goes directly to the log file instead of using +|print| commands, because there's no need for these strings to take +up |str_pool| memory when a non-{\bf stat} version of \MP\ is being used. + +@<Output statistics...@>= +if ( mp->log_opened ) { + char s[128]; + wlog_ln(" "); + wlog_ln("Here is how much of MetaPost's memory you used:"); +@.Here is how much...@> + mp_snprintf(s,128," %i string%s out of %i",(int)mp->max_strs_used-mp->init_str_use, + (mp->max_strs_used!=mp->init_str_use+1 ? "s" : ""), + (int)(mp->max_strings-1-mp->init_str_use)); + wlog_ln(s); + mp_snprintf(s,128," %i string characters out of %i", + (int)mp->max_pl_used-mp->init_pool_ptr, + (int)mp->pool_size-mp->init_pool_ptr); + wlog_ln(s); + mp_snprintf(s,128," %i words of memory out of %i", + (int)mp->lo_mem_max+mp->mem_end-mp->hi_mem_min+2, + (int)mp->mem_end); + wlog_ln(s); + mp_snprintf(s,128," %i symbolic tokens out of %i", (int)mp->st_count, (int)mp->hash_size); + 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, + (int)mp->stack_size,(int)mp->max_internal,(int)mp->param_size, + (int)mp->buf_size,(int)mp->max_in_open); + wlog_ln(s); + mp_snprintf(s,128," %i string compactions (moved %i characters, %i strings)", + (int)mp->pact_count,(int)mp->pact_chars,(int)mp->pact_strs); + wlog_ln(s); +} + +@ It is nice to have have some of the stats available from the API. + +@<Exported function ...@>= +int mp_memory_usage (MP mp ); +int mp_hash_usage (MP mp ); +int mp_param_usage (MP mp ); +int mp_open_usage (MP mp ); + +@ @c +int mp_memory_usage (MP mp ) { + return (int)mp->lo_mem_max+mp->mem_end-mp->hi_mem_min+2; +} +int mp_hash_usage (MP mp ) { + return (int)mp->st_count; +} +int mp_param_usage (MP mp ) { + return (int)mp->max_param_stack; +} +int mp_open_usage (MP mp ) { + return (int)mp->max_in_stack; +} + +@ We get to the |final_cleanup| routine when \&{end} or \&{dump} has +been scanned. + +@c +void mp_final_cleanup (MP mp) { + quarterword c; /* 0 for \&{end}, 1 for \&{dump} */ + c=mp->cur_mod; + if ( mp->job_name==NULL ) mp_open_log_file(mp); + while ( mp->input_ptr>0 ) { + if ( token_state ) mp_end_token_list(mp); + else mp_end_file_reading(mp); + } + while ( mp->loop_ptr!=null ) mp_stop_iteration(mp); + while ( mp->open_parens>0 ) { + mp_print(mp, " )"); decr(mp->open_parens); + }; + while ( mp->cond_ptr!=null ) { + mp_print_nl(mp, "(end occurred when "); +@.end occurred...@> + mp_print_cmd_mod(mp, fi_or_else,mp->cur_if); + /* `\.{if}' or `\.{elseif}' or `\.{else}' */ + if ( mp->if_line!=0 ) { + mp_print(mp, " on line "); mp_print_int(mp, mp->if_line); + } + mp_print(mp, " was incomplete)"); + mp->if_line=if_line_field(mp->cond_ptr); + mp->cur_if=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; + } + if ( c==1 ) { + if (mp->ini_version) { + mp_store_mem_file(mp); return; + } + mp_print_nl(mp, "(dump is performed only by INIMP)"); return; +@.dump...only by INIMP@> + } +} + +@ @<Declarations@>= +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 */ + integer k; /* all-purpose index */ + @<Initialize table entries (done by \.{INIMP} only)@>; +} + + +@ When we begin the following code, \MP's tables may still contain garbage; +thus we must proceed cautiously to get bootstrapped in. + +But when we finish this part of the program, \MP\ is ready to call on the +|main_control| routine to do its work. + +@<Get the first line...@>= +{ + @<Initialize the input routines@>; + if (mp->mem_ident==NULL) { + if ( ! mp_load_mem_file(mp) ) { + (mp->close_file)(mp, mp->mem_file); + mp->history = mp_fatal_error_stop; + return mp; + } + (mp->close_file)(mp, mp->mem_file); + } + @<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 = (mp->internal[mp_time] / unity)+mp->internal[mp_day]; + mp_init_randoms(mp, mp->random_seed); + @<Initialize the print |selector|...@>; + if ( loc<limit ) if ( mp->buffer[loc]!='\\' ) + mp_start_input(mp); /* \&{input} assumed */ + +@ @<Run inimpost commands@>= +{ + mp_get_strings_started(mp); + mp_init_tab(mp); /* initialize the tables */ + mp_init_prim(mp); /* call |primitive| for each primitive */ + mp->init_str_use=mp->max_str_ptr=mp->str_ptr; + mp->init_pool_ptr=mp->max_pool_ptr=mp->pool_ptr; + mp_fix_date_and_time(mp); +} + +@ Saving the filename template + +@<Save the filename template@>= +{ + delete_str_ref(mp->internal[mp_output_template]); + if ( length(mp->cur_exp)==0 ) { + mp->internal[mp_output_template] = rts("%j.%c"); + } else { + mp->internal[mp_output_template]=mp->cur_exp; + add_str_ref(mp->internal[mp_output_template]); + } +} + +@* \[47] Debugging. + + +@* \[48] System-dependent changes. +This section should be replaced, if necessary, by any special +modification of the program +that are necessary to make \MP\ work at a particular installation. +It is usually best to design your change file so that all changes to +previous sections preserve the section numbering; then everybody's version +will be consistent with the published program. More extensive changes, +which introduce new sections, can be inserted here; then only the index +itself will get a new section number. +@^system dependencies@> + +@* \[49] Index. +Here is where you can find all uses of each identifier in the program, +with underlined entries pointing to where the identifier was defined. +If the identifier is only one letter long, however, you get to see only +the underlined entries. {\sl All references are to section numbers instead of +page numbers.} + +This index also lists error messages and other aspects of the program +that you might want to look up some day. For example, the entry +for ``system dependencies'' lists all sections that should receive +special attention from people who are installing \MP\ in a new +operating environment. A list of various things that can't happen appears +under ``this can't happen''. +Approximately 25 sections are listed under ``inner loop''; these account +for more than 60\pct! of \MP's running time, exclusive of input and output. diff --git a/Build/source/texk/web2c/mplibdir/mpost.w b/Build/source/texk/web2c/mplibdir/mpost.w new file mode 100644 index 00000000000..79ade1ead57 --- /dev/null +++ b/Build/source/texk/web2c/mplibdir/mpost.w @@ -0,0 +1,939 @@ +% $Id: mpost.w 892 2009-04-14 14:28:42Z taco $ +% +% Copyright 2008 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/>. + +\font\tenlogo=logo10 % font used for the METAFONT logo +\def\MP{{\tenlogo META}\-{\tenlogo POST}} + +\def\title{MetaPost executable} +\def\[#1]{#1.} +\pdfoutput=1 + +@* \[1] Metapost 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 C includes. |avl.h| is needed because of an +|avl_allocator| that is defined in |mplib.h| + +@d true 1 +@d false 0 + +@c +#include "config.h" +#include <stdio.h> +#include <stdlib.h> +#include <string.h> +#include <time.h> +#if defined (HAVE_SYS_TIME_H) +#include <sys/time.h> +#elif defined (HAVE_SYS_TIMEB_H) +#include <sys/timeb.h> +#endif +#include <mplib.h> +#include <mpxout.h> +#ifdef WIN32 +#include <process.h> +#endif +#include <kpathsea/kpathsea.h> +extern char *kpathsea_version_string; +@= /*@@null@@*/ @> static char *mpost_tex_program = NULL; +static int debug = 0; /* debugging for makempx */ +#ifdef WIN32 +#define GETCWD _getcwd +#else +#define GETCWD getcwd +#endif +static boolean recorder_enabled = false; +static string recorder_name = NULL; +static FILE *recorder_file = NULL; +static char *job_name = NULL; +static int dvitomp_only = 0; + +@ 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; + } + res[idx--] = (char)v; + if (i<0) { + res[idx--] = '-'; + } + return mpost_xstrdup(res+idx); +} + + +@ @c +static void mpost_run_editor (MP mp, char *fname, int fline) { + char *temp, *command, *edit_value; + char c; + boolean sdone, ddone; + 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; + 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); + if (s != NULL) { + while (*s != '\0') + *temp++ = *s++; + free(s); + } + 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 { + *temp++ = c; + } + } + *temp = '\0'; + if (system (command) != 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 NUL. */ + 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. + +@c +void recorder_start(char *jobname) { + char cwd[1024]; + 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) { + 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') { + 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 (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; + char *tmp = normalize_quotes(mpname, "mpname"); + char *qmpname = kpse_find_file (tmp,kpse_mp_format, true); + char *qmpxname = normalize_quotes(mpxname, "mpxname"); + mpost_xfree(tmp); + 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; + { + 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 i, ret; + 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 ; + } + mpxopt->mpname = d; + mpxopt->mpxname = m; + + mpxopt->find_file = makempx_find_file; + { + 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); + 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 = (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(); + +@ @c +static char *mpost_find_file(MP mp, const char *fname, const char *fmode, int ftype) { + size_t l ; + char *s; + (void)mp; + s = NULL; + if (fmode[0]=='r') { + 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 { + if (fname!=NULL) + s = mpost_xstrdup(fname); /* when writing */ + } + return s; +} + +@ @<Register the callback routines@>= +if (!nokpse) + options->find_file = mpost_find_file; + +@ @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; + + +@ At the moment, the command line is very simple. + +@d option_is(A) ((strncmp(argv[a],"--" A, strlen(A)+2)==0) || + (strncmp(argv[a],"-" A, strlen(A)+1)==0)) +@d option_arg(B) (mpost_optarg != NULL && strncmp(mpost_optarg,B, strlen(B))==0) + + +@<Read and set command line options@>= +{ + char *mpost_optarg; + boolean ini_version_test = false; + while (++a<argc) { + mpost_optarg = strstr(argv[a],"=") ; + if (mpost_optarg!=NULL) { + mpost_optarg++; + if (*mpost_optarg == '\0') mpost_optarg=NULL; + } + if (option_is("ini")) { + ini_version_test = true; + } else if (option_is("debug")) { + debug = 1; + } else if (option_is ("kpathsea-debug")) { + if (mpost_optarg!=NULL) + kpathsea_debug |= atoi (mpost_optarg); + } else if (option_is("mem")) { + if (mpost_optarg!=NULL) { + mpost_xfree(options->mem_name); + options->mem_name = mpost_xstrdup(mpost_optarg); + if (user_progname == NULL) + user_progname = mpost_optarg; + } + } else if (option_is("jobname")) { + if (mpost_optarg!=NULL) { + mpost_xfree(options->job_name); + options->job_name = mpost_xstrdup(mpost_optarg); + } + } else if (option_is ("progname")) { + user_progname = mpost_optarg; + } else if (option_is("troff") || option_is("T")) { + options->troff_mode = (int)true; + } else if (option_is("recorder")) { + recorder_enabled = true; + } else if (option_is ("tex")) { + mpost_tex_program = mpost_optarg; + } else if (option_is("interaction")) { + if (option_arg("batchmode")) { + options->interaction = mp_batch_mode; + } else if (option_arg("nonstopmode")) { + options->interaction = mp_nonstop_mode; + } else if (option_arg("scrollmode")) { + options->interaction = mp_scroll_mode; + } else if (option_arg("errorstopmode")) { + options->interaction = mp_error_stop_mode; + } else { + fprintf(stdout,"warning: %s: unknown option argument %s\n", argv[0], argv[a]); + } + } else if (option_is("no-kpathsea")) { + nokpse=true; + } else if (option_is("file-line-error")) { + options->file_line_error_style=true; + } else if (option_is("no-file-line-error")) { + options->file_line_error_style=false; + } else if (option_is("dvitomp")) { + dvitomp_only = 1; + } else if (option_is("help")) { + @<Show help and exit@>; + } else if (option_is("version")) { + @<Show version and exit@>; + } else if (option_is("8bit") || + option_is("parse-first-line")) { + /* do nothing, these are always on */ + } else if (option_is("halt-on-error")) { + options->halt_on_error = true; + } else if (option_is("translate-file") || + option_is("output-directory") || + option_is("no-parse-first-line")) { + fprintf(stdout,"warning: %s: unimplemented option %s\n", argv[0], argv[a]); + } else if (option_is("")) { + fprintf(stdout,"fatal error: %s: unknown option %s\n", argv[0], argv[a]); + exit(EXIT_FAILURE); + } else { + break; + } + } + options->ini_version = (int)ini_version_test; +} + +@ +@<Show help...@>= +{ +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\n"); +fprintf(stdout, +" -ini be inimpost, for dumping mem files\n" +" -interaction=STRING set interaction mode (STRING=batchmode/nonstopmode/\n" +" scrollmode/errorstopmode)\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, +" -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" +" -troff set prologues:=1 and assume TEXPROGRAM is really troff\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(); +fprintf(stdout, +"\n" +"MetaPost %s\n" +"Copyright 2008 AT&T Bell Laboratories.\n" +"There is NO warranty. Redistribution of this software is\n" +"covered by the terms of both the MetaPost copyright and\n" +"the Lesser GNU Lesser General Public License.\n" +"For more information about these matters, see the files\n" +"named COPYING, COPYING.LESSER and the MetaPost source.\n" +"Primary author of MetaPost: John Hobby.\n" +"Current maintainer of MetaPost: Taco Hoekwater.\n" +"\n", s); + mpost_xfree(s); + 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 + +@<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 (a<argc) { + k=0; + for(;a<argc;a++) { + char *c = argv[a]; + while (*c != '\0') { + if (k<(command_line_size-1)) { + 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(kpsebanner_start)+ + strlen(kpathsea_version_string)+ + strlen(kpsebanner_stop)+1); + strcpy (options->banner, banner); + strcat (options->banner, mpversion); + 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 jobname needs to be known for the recorder to work. + +@<Discover the job name@>= +if ( options->job_name == NULL ) { + 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'; + job_name = 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'; + job_name = mpost_xstrdup(mm); + } + } + } + free(m); + } + if (job_name == NULL) { + if (options->ini_version == 1 && + options->mem_name != NULL) { + job_name = mpost_xstrdup(options->mem_name); + } + } + if (job_name == NULL) { + job_name = mpost_xstrdup("mpout"); + } else { + size_t i = strlen(job_name); + if (i>3 + && *(job_name+i-3)=='.' + && *(job_name+i-2)=='m' + && *(job_name+i-1)=='p') + *(job_name+i-3)='\0'; + } + options->job_name = job_name; +} else { + job_name = mpost_xstrdup(options->job_name); +} + + +@ Now this is really it: \MP\ starts and ends here. + +@c +int main (int argc, char **argv) { /* |start_here| */ + int k; /* index into buffer */ + int history; /* the exit status */ + MP mp; /* a metapost instance */ + struct MP_options * options; /* instance options */ + int a=0; /* argc counter */ + boolean nokpse = false; /* switch to {\it not} enable kpse */ + 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; + @<Read and set command line options@>; + if (dvitomp_only) { + char *mpx = NULL, *dvi = NULL; + if (a==argc) { + /* error ? */ + } else { + dvi = argv[a++]; + if (a<argc) { + mpx = argv[a++]; + } + } + if (!nokpse) + kpse_set_program_name("dvitomp", user_progname); + 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("mpost", user_progname); + } + @= /*@@=nullpass@@*/ @> + if(putenv((char *)"engine=metapost")) + fprintf(stdout,"warning: could not set up $engine\n"); + options->main_memory = setup_var (50000,"main_memory",nokpse); + options->hash_size = (unsigned)setup_var (16384,"hash_size",nokpse); + options->max_in_open = setup_var (25,"max_in_open",nokpse); + options->param_size = setup_var (1500,"param_size",nokpse); + 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@>; + if (options->ini_version!=(int)true) { + @<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) + exit(history); + history = mp_run(mp); + (void)mp_finish(mp); + exit(history); +} + diff --git a/Build/source/texk/web2c/mplibdir/mpxout.w b/Build/source/texk/web2c/mplibdir/mpxout.w new file mode 100644 index 00000000000..283f1c9c41c --- /dev/null +++ b/Build/source/texk/web2c/mplibdir/mpxout.w @@ -0,0 +1,4312 @@ +% $Id: mpxout.w 892 2009-04-14 14:28:42Z taco $
+%
+% Copyright 2008 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/>.
+
+\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 "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"
+extern void *avl_probe (avl_tree t, void *p);
+#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@>=
+typedef enum {
+ mpx_tex_mode=0,
+ mpx_troff_mode=1
+} mpx_modes;
+typedef struct mpx_data * MPX;
+
+@ @<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, char *header, 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, 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, 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, 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, char *msg, ...) {
+ va_list 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, char *fname, 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_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++] = 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(char *s, 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.
+
+@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;
+ 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) {
+ char *s; /* where a string to print stops */
+ char *t; /* for finding start of last line */
+ char c;
+ char *res = NULL;
+ do {
+ if (*mpx->aa == 0) {
+ if ((mpx->aa = mpx_getline(mpx,mpx->mpfile)) == NULL) {
+ mpx_error(mpx,"btex section does not end");
+ }
+ }
+ if (mpx_getbta(mpx, mpx->aa) && *(mpx->tt) == 'e') {
+ s = mpx->tt;
+ } else {
+ if (*(mpx->tt) == 'b')
+ mpx_error(mpx,"btex in TeX mode");
+ if (*(mpx->tt) == 'v')
+ mpx_error(mpx,"verbatimtex in TeX mode");
+ 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');
+ /* whitespace at the end */
+ for (s = res + strlen(res) - 1;
+ s >= res && (*s == ' ' || *s == '\t' || *s == '\r' || *s == '\n'); s--);
+ t = s;
+ *(++s) = '\0';
+ /* 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);
+ /* 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 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) {
+ while (mpx_getline(mpx, fr) != NULL)
+ fputs(mpx->buf, 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);
+ 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);
+ mpx_copy_mpto(mpx, outfile);
+ fprintf(outfile,"%s", mpx_postverb[mode]);
+ } else {
+ mpx_error(mpx,"unmatched etex");
+ }
+ }
+}
+
+@ @<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: %s !", 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]=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 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;
+ 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+mpx->font_ec[f]-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+mpx->font_ec[f]-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;
+ }
+}
+
+@ @<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-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+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, ")infont n%d", mpx->font_num[mpx->str_f]);
+ mpx_slant_and_ht(mpx);
+ fprintf(mpx->mpxfile, ",%.5f,%.4f,%.4f);\n", (m*1.00375), x, y);
+ }
+ 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 {
+ char *name; /* color name */
+ 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, char *n, 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, char *n, 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;
+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;
+
+@ @(mpxout.h@>=
+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, char *nam, int format);
+
+@ @c
+static FILE *mpx_fsearch(MPX mpx, 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 */
+ avl_entry *p, *q;
+ p = (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 avl_entry * mpx_avl_probe(MPX mpx, avl_tree tab, avl_entry *p) {
+ avl_entry *r = (avl_entry *)avl_probe(tab,p);
+ if (r==NULL)
+ mpx_abort(mpx,"Memory allocation failure");
+ return r;
+
+}
+
+
+@ 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 = 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 = 10.0 * x + d;
+ digits++;
+ s++;
+ }
+ if (*s == '.') {
+ y = 1.0;
+ while (d = *++s - '0', 0 <= d && d <= 9) {
+ y /= 10.0;
+ x += y * 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(*s))
+ s++;
+ while (!isspace(*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, 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++;
+ tmp = xmalloc(sizeof(avl_entry),1);
+ tmp->name = nam;
+ tmp->num = (int)mpx->nfonts++;
+ (void)mpx_avl_probe (mpx,mpx->trfonts, tmp) ;
+ if (*buf) {
+ *buf = 0; buf++;
+ do buf++; while (*buf == '\t');
+ while (*buf && *buf != '\t'); buf++; /* skip over psname */
+ do buf++; while (*buf == '\t');
+ 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->nfonts++;
+ }
+ 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, 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);
+ 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++;
+ s = xmalloc((size_t)(lin-t+1),1);
+ strncpy(s,t,(size_t)(lin-t));
+ while (*lin == ' ' || *lin == '\t')
+ lin++;
+ if (*lin == '"') {
+ if (lastcode < MAXCHARS) {
+ tmp = xmalloc(sizeof(avl_entry),1);
+ tmp->name = s ;
+ tmp->num = lastcode;
+ (void)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;
+ (void)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");
+ 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;
+ 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++;
+ }
+ if (i > 0)
+ fprintf(mpx->mpxfile, "\n ");
+}
+
+
+@ 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++)
+ 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 + 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 += char_width(mpx->curfont,(int)*cname);
+ while (*++cname) {
+ mpx_print_char(mpx,(unsigned char)*cname);
+ hh += 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++ = 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:
+ 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;
+ sp = (spec_entry *)avl_probe(mpx->spec_tab,sp);
+ if (sp==NULL)
+ 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, mpx->font_num[f]);
+ mpx_slant_and_ht(mpx);
+ fprintf(mpx->mpxfile, ",%.5f,%.4f,%.4f);\n",
+ (mpx->cursize/mpx->font_design_size[f])*1.00375,
+ (double)(mpx->h*mpx->unit), YCORR-mpx->v*mpx->unit);
+ }
+}
+
+@ 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);
+ f = p->num;
+ if ( mpx->info_base[f]==max_widths ) {
+ 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, 0.8946431597, 0.7071067812 };
+static const float yy[] = { 0.0, 0.2652164899, 0.5195704026, 0.7071067812 };
+
+@ @c
+static float mpx_circangle(float t) {
+ float ti;
+ ti = 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(atan2(ay, ax));
+ t2 = mpx_circtime(atan2(by, bx));
+ if (t2 < t1)
+ t2 += 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 = 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 = 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) * (PI / 180.0);
+ x = cos(mpx->Xslant);
+ if (-1e-4 < x && x < 1e-4)
+ mpx_abort(mpx,"Excessive slant");
+ mpx->Xslant = 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_open_mpxfile(mpx);
+ if (mpx->banner != NULL)
+ fprintf (mpx->mpxfile,"%s\n",mpx->banner);
+ mpx_read_desc(mpx);
+ mpx_read_fmap(mpx,dbname);
+ if (!mpx->gflag)
+ mpx_read_char_adj(mpx,adjname);
+ 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);
+ mpx_fclose(mpx,mpx->mpxfile);
+ 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, char *a, char *b) {
+ mpx_report(mpx,"renaming %s to %s",a,b);
+ rename(a,b);
+}
+
+@ @<Globals@>=
+char tex[15] ;
+int debug ;
+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,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 *cmd, char **options) {
+#ifndef WIN32
+ int retcode = -1;
+ pid_t child;
+ 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));
+ }
+ }
+ return retcode;
+#else
+ (void)mpx;
+ return spawnvp(P_WAIT, cmd, (const char **)options);
+#endif
+}
+
+@ @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);
+}
+
+
+
+@ @(mpxout.h@>=
+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);
+
+ 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;
+ }
+ strcpy(infile,cur_in);
+ }
+ }
+ if (tmp_a!=infile) { remove(tmp_a); }
+ if (tmp_b!=infile) { remove(tmp_b); }
+}
+
+@ 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/psout.w b/Build/source/texk/web2c/mplibdir/psout.w new file mode 100644 index 00000000000..90bc96a9aa3 --- /dev/null +++ b/Build/source/texk/web2c/mplibdir/psout.w @@ -0,0 +1,6246 @@ +% $Id: psout.w 878 2009-03-22 08:22:33Z taco $ +% +% Copyright 2008 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 +\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 true 1 +@d false 0 +@d null_font 0 +@d null 0 +@d unity 0200000 /* $2^{16}$, represents 1.00000 */ +@d el_gordo 017777777777 /* $2^{31}-1$, the largest value that \MP\ likes */ +@d incr(A) (A)=(A)+1 /* increase a variable by unity */ +@d decr(A) (A)=(A)-1 /* decrease a variable by unity */ +@d negate(A) (A)=-(A) /* change the sign of a variable */ +@d odd(A) ((A)%2==1) +@d half(A) ((A)/2) +@d print_err(A) mp_print_err(mp,(A)) +@d max_quarterword 0x3FFF /* largest allowable value in a |quarterword| */ + +@c +#include "config.h" +#include <stdio.h> +#include <stdlib.h> +#include <string.h> +#include <stdarg.h> +#include <assert.h> +#include "avl.h" +#include "mplib.h" +#include "mplibps.h" /* external header */ +#include "mpmp.h" /* internal header */ +#include "mppsout.h" /* internal header */ +@h +@<Declarations@> +@<Static variables in the outer block@> + +@ There is a small bit of code from the backend that bleads through +to the frontend because I do not know how to set up the includes +properly. That is the |typedef struct psout_data_struct * psout_data|. + +@ @(mppsout.h@>= +#include "avl.h" +@<Types...@> +typedef struct psout_data_struct { + @<Globals@> +} psout_data_struct ; +@<Exported function headers@> + +@ +@c +void *avl_probe (avl_tree t, void *p) { + int ret = avl_ins(p, t, false); + if (ret < 0) + return NULL; + else + return avl_find(p, t); +} + +@ @<Exported...@>= +void *avl_probe (avl_tree t, void *p) ; + + +@ @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 = mp_tolower(*c); c++; + } + ss2 = mp_strdup(s2); + c = ss2; + while (*c != '\0') { + *c = 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)); + @<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]=(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; + while ( j<len ){ + mp_ps_print_char(mp, ss[j]); incr(j); + } +} + +@ Deciding where to break the ps output line. + +@d ps_room(A) if (mp->ps->ps_offset>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)); +} + +@ 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); +} + +@ An array of digits in the range |0..9| is printed by |print_the_digs|. + +@c +static void mp_ps_print_the_digs (MP mp, int k) { + /* prints |dig[k-1]|$\,\ldots\,$|dig[0]| */ + while ( k-->0 ){ + mp_ps_print_char(mp, '0'+mp->dig[k]); + } +} + +@ The following procedure, which prints out the decimal representation of a +given integer |n|, has been written carefully so that it works properly +if |n=0| or if |(-n)| would cause overflow. It does not apply |mod| or |div| +to negative arguments, since such operations are not implemented consistently +by all \PASCAL\ compilers. + +@c +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 */ + int k = 0; /* index to current digit; we assume that $|n|<10^{23}$ */ + if ( n<0 ) { + mp_ps_print_char(mp, '-'); + if ( n>-100000000 ) { + negate(n); + } else { + m=-1-n; n=m / 10; m=(m % 10)+1; k=1; + if ( m<10 ) { + mp->dig[0]=(unsigned char)m; + } else { + mp->dig[0]=0; incr(n); + } + } + } + do { + mp->dig[k]=(unsigned char)(n % 10); n=n / 10; incr(k); + } while (n!=0); + mp_ps_print_the_digs(mp, k); +} + +@ \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=abs(n) % 100; + mp_ps_print_char(mp, '0'+(n / 10)); + mp_ps_print_char(mp, '0'+(n % 10)); +} + +@ Conversely, here is a procedure analogous to |print_int|. If the output +of this procedure is subsequently read by \MP\ and converted by the +|round_decimals| routine above, it turns out that the original value will +be reproduced exactly. A decimal point is printed only if the value is +not an integer. If there is more than one way to print the result with +the optimum number of digits following the decimal point, the closest +possible value is given. + +The invariant relation in the \&{repeat} loop is that a sequence of +decimal digits yet to be printed will yield the original number if and only if +they form a fraction~$f$ in the range $s-\delta\L10\cdot2^{16}f<s$. +We can stop if and only if $f=0$ satisfies this condition; the loop will +terminate before $s$ can possibly become zero. + +@c +static void mp_ps_print_scaled (MP mp,scaled s) { + scaled delta; /* amount of allowable inaccuracy */ + if ( s<0 ) { + mp_ps_print_char(mp, '-'); + negate(s); /* print the sign, if negative */ + } + mp_ps_print_int(mp, s / unity); /* print the integer part */ + s=10*(s % unity)+5; + if ( s!=5 ) { + delta=10; + mp_ps_print_char(mp, '.'); + do { + if ( delta>unity ) + s=s+0100000-(delta / 2); /* round the final digit */ + mp_ps_print_char(mp, '0'+(s / unity)); + s=10*(s % unity); + delta=delta*10; + } while (s>delta); + } +} + + +@* \[44a] Dealing with font encodings. + +First, here are a few helpers for parsing files + +@d check_buf(size, buf_size) + if ((unsigned)(size) > (unsigned)(buf_size)) { + char S[128]; + 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++ = 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 ()) { + print_err("unexpected end of file"); + mp_error(mp); + } + p = mp->ps->enc_line; + do { + c = enc_getchar (mp); + append_char_to_buf (c, p, mp->ps->enc_line, ENC_BUF_SIZE); + } while (c != 10); + append_eol (p, mp->ps->enc_line, ENC_BUF_SIZE); + if (p - mp->ps->enc_line < 2 || *mp->ps->enc_line == '%') + goto RESTART; +} +static void mp_load_enc (MP mp, char *enc_name, + char **enc_encname, char **glyph_names){ + char buf[ENC_BUF_SIZE], *p, *r; + int names_count; + char *myname; + unsigned save_selector = mp->selector; + if (!mp_enc_open (mp,enc_name)) { + mp_print (mp,"cannot open encoding file for reading"); + return; + } + mp_normalize_selector(mp); + mp_print (mp,"{"); + mp_print (mp, enc_name); + mp_enc_getline (mp); + if (*mp->ps->enc_line != '/' || (r = strchr (mp->ps->enc_line, '[')) == NULL) { + remove_eol (r, mp->ps->enc_line); + print_err ("invalid encoding vector (a name or `[' missing): `"); + mp_print(mp,mp->ps->enc_line); + mp_print(mp,"'"); + mp_error(mp); + } + while (*(r-1)==' ') r--; /* strip trailing spaces from encoding name */ + myname = mp_xmalloc(mp,r-mp->ps->enc_line,1); + memcpy(myname,mp->ps->enc_line+1,(r-mp->ps->enc_line)-1); + *(myname+(r-mp->ps->enc_line-1))=0; + *enc_encname = myname; + while (*r!='[') r++; + r++; /* skip '[' */ + names_count = 0; + skip (r, ' '); + for (;;) { + while (*r == '/') { + for (p = buf, r++; + *r != ' ' && *r != 10 && *r != ']' && *r != '/'; *p++ = *r++); + *p = 0; + skip (r, ' '); + if (names_count > 256) { + print_err ("encoding vector contains more than 256 names"); + mp_error(mp); + } + if (mp_xstrcmp (buf, notdef) != 0) + glyph_names[names_count] = mp_xstrdup (mp,buf); + names_count++; + } + if (*r != 10 && *r != '%') { + if (str_prefix (r, "] def")) + goto DONE; + else { + remove_eol (r, mp->ps->enc_line); + print_err + ("invalid encoding vector: a name or `] def' expected: `"); + mp_print(mp,mp->ps->enc_line); + mp_print(mp,"'"); + mp_error(mp); + } + } + mp_enc_getline (mp); + r = mp->ps->enc_line; + } +DONE: + enc_close (); + mp_print (mp,"}"); + mp->selector = save_selector; +} +static void mp_read_enc (MP mp, enc_entry * e) { + if (e->loaded) + return; + e->enc_name = NULL; + mp_load_enc (mp,e->file_name, &e->enc_name, e->glyph_names); + e->loaded = true; +} + +@ |write_enc| is used to write either external encoding (given in map file) or + internal encoding (read from the font file); + the 2nd argument is a pointer to the encoding entry; + +@c +static void mp_write_enc (MP mp, enc_entry * e) { + int i; + 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 const 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->glyph_names); + mp_xfree (p); +} +static void *copy_enc_entry (const void *pa) { + enc_entry *p, *q; + int i; + p = (enc_entry *) pa; + q = malloc (sizeof (enc_entry)); + if (q!=NULL) { + q->loaded = p->loaded; + q->file_name = strdup (p->file_name); + 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]); + else + q->glyph_names[i] = NULL; + } + } + return (void *)q; +} + +static enc_entry * mp_add_enc (MP mp, char *s) { + int i; + enc_entry tmp, *p; + void **aa; + if (mp->ps->enc_tree == NULL) { + mp->ps->enc_tree = avl_create (comp_enc_entry, + 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)); + p->loaded = false; + p->file_name = mp_xstrdup (mp,s); + p->objnum = 0; + p->tounicode = 0; + p->glyph_names = mp_xmalloc (mp,256,sizeof (char *)); + for (i = 0; i < 256; i++) + p->glyph_names[i] = (char *) notdef; + aa = avl_probe (mp->ps->enc_tree, p); + return p; +} + +@ cleaning up... + + +@ @<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; + +@ +@d fm_close() (mp->close_file)(mp,mp->ps->fm_file) +@d fm_eof() (mp->eof_file)(mp,mp->ps->fm_file) + +@c +static int fm_getchar(MP mp) { + size_t len = 1; + unsigned char abyte=0; + void *byte_ptr = &abyte; + (mp->read_binary_file)(mp,mp->ps->fm_file,&byte_ptr,&len); + if (len==0) + return EOF; + return abyte; +} + + +@ @<Types...@>= +enum _mode { FM_DUPIGNORE, FM_REPLACE, FM_DELETE }; +enum _ltype { MAPFILE, MAPLINE }; +enum _tfmavail { TFM_UNCHECKED, TFM_FOUND, TFM_NOTFOUND }; +typedef struct mitem { + int mode; /* |FM_DUPIGNORE| or |FM_REPLACE| or |FM_DELETE| */ + int type; /* map file or map line */ + char *map_line; /* pointer to map file name or map line */ + int lineno; /* line number in map file */ +} mapitem; + +@ @<Glob...@>= +mapitem *mitem; +fm_entry *fm_cur; +fm_entry *loaded_tfm_found; +fm_entry *avail_tfm_found; +fm_entry *non_tfm_found; +fm_entry *not_avail_tfm_found; + +@ @<Set initial...@>= +mp->ps->mitem = NULL; + +@ @<Declarations@>= +static const char nontfm[] = "<nontfm>"; + +@ +@d read_field(r, q, buf) do { + q = buf; + while (*r != ' ' && *r != '\0') + *q++ = *r++; + *q = '\0'; + skip (r, ' '); +} while (0) + +@d set_field(F) do { + if (q > buf) + fm->F = mp_xstrdup(mp,buf); + if (*r == '\0') + goto DONE; +} while (0) + +@d cmp_return(a, b) + if (a > b) + return 1; + if (a < b) + return -1 + +@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, *fp; + fp = (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); +} + +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, *fp; + fp = (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); +} + +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 unset_tfmlink(fm) ((fm)->links &= ~LINK_TFM) +@d unset_pslink(fm) ((fm)->links &= ~LINK_PS) +@d has_tfmlink(fm) ((fm)->links & LINK_TFM) +@d has_pslink(fm) ((fm)->links & LINK_PS) + +@c +static int avl_do_entry (MP mp, fm_entry * fp, int mode) { + fm_entry *p; + void *a; + void **aa; + char s[128]; + + /* handle |tfm_name| link */ + + if (strcmp (fp->tfm_name, nontfm)) { + p = (fm_entry *) avl_find (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,&a); + assert (a != NULL); + unset_tfmlink (p); + if (!has_pslink (p)) + delete_fm_entry (p); + } + } + if (mode != FM_DELETE) { + aa = avl_probe (mp->ps->tfm_tree, fp); + assert (aa != NULL); + set_tfmlink (fp); + } + } + + /* handle |ps_name| link */ + + if (fp->ps_name != NULL) { + assert (fp->tfm_name != NULL); + p = (fm_entry *) avl_find (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,&a); + assert (a != NULL); + unset_pslink (p); + if (!has_tfmlink (p)) + delete_fm_entry (p); + } + } + if (mode != FM_DELETE) { + aa = avl_probe (mp->ps->ps_tree, fp); + assert (aa != NULL); + set_pslink (fp); + } + } + exit: + if (!has_tfmlink (fp) && !has_pslink (fp)) /* e. g. after |FM_DELETE| */ + return 1; /* deallocation of |fm_entry| structure required */ + else + return 0; +} + +@ consistency check for map entry, with warn flag + +@c +static int check_fm_entry (MP mp, fm_entry * fm, boolean warn) { + int a = 0; + char s[128]; + assert (fm != NULL); + if (fm->ps_name != NULL) { + if (is_basefont (fm)) { + if (is_fontfile (fm) && !is_included (fm)) { + if (warn) { + 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, *r, *s; + char warn_s[128]; + switch (mp->ps->mitem->type) { + case MAPFILE: + p = fm_line; + do { + c = fm_getchar (mp); + append_char_to_buf (c, p, fm_line, FM_BUF_SIZE); + } while (c != 10); + *(--p) = '\0'; + r = fm_line; + break; + case MAPLINE: + r = mp->ps->mitem->map_line; + break; + default: + assert (0); + } + if (*r == '\0' || is_cfg_comment (*r)) + return; + fm = new_fm_entry (mp); + read_field (r, q, buf); + set_field (tfm_name); + p = r; + read_field (r, q, buf); + if (*buf != '<' && *buf != '"') + set_field (ps_name); + else + r = p; /* unget the field */ + if (mp_isdigit (*r)) { /* font flags given */ + fm->flags = atoi (r); + while (mp_isdigit (*r)) + r++; + } + while (1) { /* loop through "specials", encoding, font file */ + skip (r, ' '); + switch (*r) { + case '\0': + goto DONE; + case '"': /* opening quote */ + r++; + u = v = 0; + do { + skip (r, ' '); + if (sscanf (r, "%f %n", &d, &j) > 0) { + s = r + j; /* jump behind number, eat also blanks, if any */ + if (*(s - 1) == 'E' || *(s - 1) == 'e') + s--; /* e. g. 0.5ExtendFont: \%f = 0.5E */ + if (str_prefix (s, "SlantFont")) { + d *= 1000.0; /* correct rounding also for neg. numbers */ + fm->slant = (short int) (d > 0 ? d + 0.5 : d - 0.5); + r = s + strlen ("SlantFont"); + } else if (str_prefix (s, "ExtendFont")) { + d *= 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 = 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 */ + 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) + fm_read_info (mp); /* only to read default map file */ + tfm = mp->font_name[f]; + assert (strcmp (tfm, nontfm)); + /* Look up for full <tfmname>[+-]<expand> */ + tmp.tfm_name = tfm; + fm = (fm_entry *) avl_find (&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; + void **aa; + + 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); + aa = avl_probe (mp->ps->ff_tree, ff); + assert (aa != NULL); + } + return ff; +} + +@ Process map file given by its name or map line contents. Items not +beginning with [+-=] flush default map file, if it has not yet been +read. Leading blanks and blanks immediately following [+-=] are ignored. + + +@c static void mp_process_map_item (MP mp, char *s, int type) { + char *p; + int mode; + if (*s == ' ') + s++; /* ignore leading blank */ + switch (*s) { + case '+': /* +mapfile.map, +mapline */ + mode = FM_DUPIGNORE; /* insert entry, if it is not duplicate */ + s++; + break; + case '=': /* =mapfile.map, =mapline */ + mode = FM_REPLACE; /* try to replace earlier entry */ + s++; + break; + case '-': /* -mapfile.map, -mapline */ + mode = FM_DELETE; /* try to delete entry */ + s++; + break; + default: + mode = FM_DUPIGNORE; /* like +, but also: */ + mp_xfree(mp->ps->mitem->map_line); + mp->ps->mitem->map_line = NULL; /* flush default map file name */ + } + if (*s == ' ') + s++; /* ignore blank after [+-=] */ + p = s; /* map item starts here */ + switch (type) { + case MAPFILE: /* remove blank at end */ + while (*p != '\0' && *p != ' ') + p++; + *p = '\0'; + break; + case MAPLINE: /* blank at end allowed */ + break; + default: + assert (0); + } + if (mp->ps->mitem->map_line != NULL) /* read default map file first */ + fm_read_info (mp); + if (*s != '\0') { /* only if real item to process */ + mp->ps->mitem->mode = mode; + mp->ps->mitem->type = type; + mp->ps->mitem->map_line = s; + fm_read_info (mp); + } +} + +@ @<Exported function headers@>= +void mp_map_file (MP mp, str_number t); +void mp_map_line (MP mp, str_number t); +void mp_init_map_file (MP mp, int is_troff); + +@ @c +void mp_map_file (MP mp, str_number t) { + char *s = mp_xstrdup(mp,mp_str (mp,t)); + mp_process_map_item (mp, s, MAPFILE); +} +void mp_map_line (MP mp, str_number t) { + char *s = mp_xstrdup(mp,mp_str (mp,t)); + mp_process_map_item (mp, s, MAPLINE); +} + +@ +@c void mp_init_map_file (MP mp, int is_troff) { + char *r; + mp->ps->mitem = mp_xmalloc (mp,1,sizeof(mapitem)); + mp->ps->mitem->mode = FM_DUPIGNORE; + mp->ps->mitem->type = MAPFILE; + mp->ps->mitem->map_line = NULL; + r = (mp->find_file)(mp,"mpost.map", "r", mp_filetype_fontmap); + if (r != NULL) { + mp_xfree(r); + mp->ps->mitem->map_line = mp_xstrdup (mp,"mpost.map"); + } else { + if (is_troff) { + mp->ps->mitem->map_line = mp_xstrdup (mp,"troff.map"); + } else { + mp->ps->mitem->map_line = mp_xstrdup (mp,"pdftex.map"); + } + } +} + +@ @<Dealloc variables@>= +if (mp->ps->mitem!=NULL) { + mp_xfree(mp->ps->mitem->map_line); + mp_xfree(mp->ps->mitem); +} + +@ cleaning up... + +@c +static void destroy_fm_entry_tfm (void *pa, void *pb) { + fm_entry *fm; + (void)pb; + fm = (fm_entry *) pa; + if (!has_pslink (fm)) + delete_fm_entry (fm); + else + unset_tfmlink (fm); +} +static void destroy_fm_entry_ps (void *pa, void *pb) { + fm_entry *fm; + (void)pb; + fm = (fm_entry *) pa; + if (!has_tfmlink (fm)) + delete_fm_entry (fm); + else + unset_pslink (fm); +} +static void destroy_ff_entry (void *pa, void *pb) { + ff_entry *ff; + (void)pb; + ff = (ff_entry *) pa; + delete_ff_entry (ff); +} + +@ @<Declarations@>= +static void fm_free (MP mp); + +@ @c +static void fm_free (MP mp) { + if (mp->ps->tfm_tree != NULL) + avl_destroy (mp->ps->tfm_tree); + 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; + if (mp->ps->mitem == NULL) { + mp->ps->mitem = mp_xmalloc (mp,1,sizeof(mapitem)); + mp->ps->mitem->mode = FM_DUPIGNORE; + mp->ps->mitem->type = MAPFILE; + mp->ps->mitem->map_line = NULL; + } + mp->ps->mitem->map_line = mp_xstrdup (mp,ps_tab_name); + fm_read_info (mp); + for (k=mp->last_ps_fnum+1;k<=mp->last_fnum;k++) { + if (mp_has_fm_entry(mp, k, NULL)) { + mp->font_ps_name[k] = mp_fm_font_name(mp,k); + } + } + mp->last_ps_fnum=mp->last_fnum; +} + + +@ The traditional function is a lot shorter now. + + + +@* \[44c] Helper functions for Type1 fonts. + +@<Types...@>= +typedef char char_entry; +typedef unsigned char Byte; +typedef Byte Bytef; + +@ @<Glob...@>= +char_entry *char_ptr, *char_array; +size_t char_limit; +char *job_id_string; + +@ @<Set initial...@>= +mp->ps->char_array = NULL; +mp->ps->job_id_string = NULL; + +@ +@d SMALL_ARRAY_SIZE 256 +@d Z_NULL 0 + +@c +void mp_set_job_id (MP mp) { + char *name_string, *format_string, *s; + size_t slen; + if (mp->ps->job_id_string != NULL) + return; + if ( mp->job_name==NULL ) + mp->job_name = mp_xstrdup(mp,"mpout"); + name_string = mp_xstrdup (mp,mp->job_name); + format_string = mp_xstrdup (mp,mp->mem_ident); + slen = SMALL_BUF_SIZE + + strlen (name_string) + + strlen (format_string); + s = mp_xmalloc (mp,slen, sizeof (char)); + @= /*@@-bufferoverflowhigh@@*/ @> + sprintf (s,"%.4u/%.2u/%.2u %.2u:%.2u %s %s", + ((unsigned)mp->internal[mp_year]>>16), + ((unsigned)mp->internal[mp_month]>>16), + ((unsigned)mp->internal[mp_day]>>16), + ((unsigned)mp->internal[mp_time]>>16) / 60, + ((unsigned)mp->internal[mp_time]>>16) % 60, + name_string, format_string); + @= /*@@=bufferoverflowhigh@@*/ @> + mp->ps->job_id_string = mp_xstrdup (mp,s); + mp_xfree (s); + mp_xfree (name_string); + mp_xfree (format_string); +} +static void fnstr_append (MP mp, const char *s) { + size_t l = strlen (s) + 1; + alloc_array (char, l, SMALL_ARRAY_SIZE); + strcat (mp->ps->char_ptr, s); + mp->ps->char_ptr = strend (mp->ps->char_ptr); +} + +@ @<Exported function headers@>= +void mp_set_job_id (MP mp) ; + +@ @<Dealloc variables@>= +mp_xfree(mp->ps->job_id_string); + +@ this is not really a true crc32, but it should be just enough to keep + subsets prefixes somewhat disjunct + +@c +static unsigned long crc32 (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) { + if (glyph_names[i]!=NULL) { + fnstr_append (mp,"/"); + fnstr_append (mp,glyph_names[i]); + } + } + if (fm_cur->charset != NULL) { + fnstr_append (mp," Extra CharSet: "); + fnstr_append (mp, fm_cur->charset); + } + crc = crc32 (0L, Z_NULL, 0); + crc = crc32 (crc, (Bytef *) mp->ps->char_array, strlen (mp->ps->char_array)); + /* we need to fit a 32-bit number into a string of 6 uppercase chars long; + * there are 26 uppercase chars ==> each char represents a number in range + * |0..25|. The maximal number that can be represented by the tag is + * $26^6 - 1$, which is a number between $2^28$ and $2^29$. Thus the bits |29..31| + * of the CRC must be dropped out. + */ + for (i = 0; i < 6; i++) { + tag[i] = 'A' + crc % 26; + crc /= 26; + } + tag[6] = 0; + fm_cur->subset_tag = mp_xstrdup (mp,tag); +} + + + +@ +@d external_enc() (fm_cur->encoding)->glyph_names +@d is_used_char(c) mp_char_marked (mp, tex_font, (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,(char *)s) +@d t1_putchar(c) wps_chr(c) +@d embed_all_glyphs(tex_font) false +@d t1_char(c) c +@d extra_charset() mp->ps->dvips_extra_charset +@d update_subset_tag() +@d fixedcontent true + +@<Glob...@>= +#define PRINTF_BUF_SIZE 1024 +char *dvips_extra_charset; +char *cur_enc_name; +unsigned char *grid; +char *ext_glyph_names[256]; +char print_buf[PRINTF_BUF_SIZE]; +int t1_byte_waiting; + +@ @<Set initial ...@>= +mp->ps->dvips_extra_charset=NULL; +mp->ps->t1_byte_waiting=0; + +@ +@d t1_ungetchar(A) mp->ps->t1_byte_waiting=(int)(A) +@d t1_eof() (mp->eof_file)(mp,mp->ps->t1_file) +@d t1_close() (mp->close_file)(mp,mp->ps->t1_file) +@d valid_code(c) (c >= 0 && c < 256) + +@c +static int t1_getchar (MP mp) { + size_t len = 1; + unsigned char abyte=0; + void *byte_ptr = &abyte; + if (mp->ps->t1_byte_waiting) { + abyte = mp->ps->t1_byte_waiting; + mp->ps->t1_byte_waiting = 0; + } else { + (mp->read_binary_file)(mp,mp->ps->t1_file,&byte_ptr,&len); + } + return (int)abyte; +} + +@ @<Static variables in the outer block@>= +static const char *standard_glyph_names[256] = + { notdef, notdef, notdef, notdef, notdef, notdef, notdef, notdef, + notdef, notdef, notdef, notdef, notdef, notdef, notdef, notdef, notdef, + notdef, notdef, notdef, notdef, notdef, notdef, + notdef, notdef, notdef, notdef, notdef, notdef, notdef, notdef, notdef, + "space", "exclam", "quotedbl", "numbersign", + "dollar", "percent", "ampersand", "quoteright", "parenleft", + "parenright", "asterisk", "plus", "comma", "hyphen", "period", + "slash", "zero", "one", "two", "three", "four", "five", "six", "seven", + "eight", "nine", "colon", "semicolon", "less", + "equal", "greater", "question", "at", "A", "B", "C", "D", "E", "F", + "G", "H", "I", "J", "K", "L", "M", "N", "O", "P", "Q", + "R", "S", "T", "U", "V", "W", "X", "Y", "Z", "bracketleft", + "backslash", "bracketright", "asciicircum", "underscore", + "quoteleft", "a", "b", "c", "d", "e", "f", "g", "h", "i", "j", "k", + "l", "m", "n", "o", "p", "q", "r", "s", "t", "u", "v", + "w", "x", "y", "z", "braceleft", "bar", "braceright", "asciitilde", + notdef, notdef, notdef, notdef, notdef, notdef, notdef, + notdef, notdef, notdef, notdef, notdef, notdef, notdef, notdef, notdef, + notdef, notdef, notdef, notdef, notdef, notdef, + notdef, notdef, notdef, notdef, notdef, notdef, notdef, notdef, notdef, + notdef, notdef, notdef, "exclamdown", "cent", + "sterling", "fraction", "yen", "florin", "section", "currency", + "quotesingle", "quotedblleft", "guillemotleft", + "guilsinglleft", "guilsinglright", "fi", "fl", notdef, "endash", + "dagger", "daggerdbl", "periodcentered", notdef, + "paragraph", "bullet", "quotesinglbase", "quotedblbase", + "quotedblright", "guillemotright", "ellipsis", "perthousand", + notdef, "questiondown", notdef, "grave", "acute", "circumflex", + "tilde", "macron", "breve", "dotaccent", "dieresis", notdef, + "ring", "cedilla", notdef, "hungarumlaut", "ogonek", "caron", "emdash", + notdef, notdef, notdef, notdef, notdef, notdef, + notdef, notdef, notdef, notdef, notdef, notdef, notdef, notdef, notdef, + notdef, "AE", notdef, "ordfeminine", notdef, notdef, + notdef, notdef, "Lslash", "Oslash", "OE", "ordmasculine", notdef, + notdef, notdef, notdef, notdef, "ae", notdef, notdef, + notdef, "dotlessi", notdef, notdef, "lslash", "oslash", "oe", + "germandbls", notdef, notdef, notdef, notdef }; +static const char charstringname[] = "/CharStrings"; + +@ @<Glob...@>= +char **t1_glyph_names; +char *t1_builtin_glyph_names[256]; +char charsetstr[0x4000]; +boolean read_encoding_only; +int t1_encoding; + +@ @c +#define T1_BUF_SIZE 0x10 + +#define CS_HSTEM 1 +#define CS_VSTEM 3 +#define CS_VMOVETO 4 +#define CS_RLINETO 5 +#define CS_HLINETO 6 +#define CS_VLINETO 7 +#define CS_RRCURVETO 8 +#define CS_CLOSEPATH 9 +#define CS_CALLSUBR 10 +#define CS_RETURN 11 +#define CS_ESCAPE 12 +#define CS_HSBW 13 +#define CS_ENDCHAR 14 +#define CS_RMOVETO 21 +#define CS_HMOVETO 22 +#define CS_VHCURVETO 30 +#define CS_HVCURVETO 31 +#define CS_1BYTE_MAX (CS_HVCURVETO + 1) + +#define CS_DOTSECTION CS_1BYTE_MAX + 0 +#define CS_VSTEM3 CS_1BYTE_MAX + 1 +#define CS_HSTEM3 CS_1BYTE_MAX + 2 +#define CS_SEAC CS_1BYTE_MAX + 6 +#define CS_SBW CS_1BYTE_MAX + 7 +#define CS_DIV CS_1BYTE_MAX + 12 +#define CS_CALLOTHERSUBR CS_1BYTE_MAX + 16 +#define CS_POP CS_1BYTE_MAX + 17 +#define CS_SETCURRENTPOINT CS_1BYTE_MAX + 33 +#define CS_2BYTE_MAX (CS_SETCURRENTPOINT + 1) +#define CS_MAX CS_2BYTE_MAX + +@ @<Types...@>= +typedef unsigned char byte; +typedef struct { + byte nargs; /* number of arguments */ + boolean bottom; /* take arguments from bottom of stack? */ + boolean clear; /* clear stack? */ + boolean valid; +} cc_entry; /* CharString Command */ +typedef struct { + char *glyph_name; /* glyph name (or notdef for Subrs entry) */ + byte *data; + unsigned short len; /* length of the whole string */ + unsigned short cslen; /* length of the encoded part of the string */ + boolean is_used; + boolean valid; +} cs_entry; + +@ +@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 (c); +} +static int t1_getbyte (MP mp) +{ + int c = t1_getchar (mp); + if (mp->ps->t1_pfa) + return c; + if (mp->ps->t1_block_length == 0) { + if (c != 128) + mp_fatal_error (mp, "invalid marker"); + c = t1_getchar (mp); + if (c == 3) { + while (!t1_eof ()) + (void)t1_getchar (mp); + return EOF; + } + mp->ps->t1_block_length = t1_getchar (mp) & 0xff; + mp->ps->t1_block_length |= (unsigned)(t1_getchar (mp) & 0xff) << 8; + mp->ps->t1_block_length |= (unsigned)(t1_getchar (mp) & 0xff) << 16; + mp->ps->t1_block_length |= (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 = (cipher ^ (mp->ps->t1_dr >> 8)); + mp->ps->t1_dr = (cipher + mp->ps->t1_dr) * t1_c1 + t1_c2; + return plain; +} +static byte cdecrypt (byte cipher, unsigned short *cr) +{ + const byte plain = (cipher ^ (*cr >> 8)); + *cr = (cipher + *cr) * t1_c1 + t1_c2; + return plain; +} +static byte eencrypt (MP mp, byte plain) +{ + const byte cipher = (plain ^ (mp->ps->t1_er >> 8)); + mp->ps->t1_er = (cipher + mp->ps->t1_er) * t1_c1 + t1_c2; + return cipher; +} + +static byte cencrypt (byte plain, unsigned short *cr) +{ + const byte cipher = (plain ^ (*cr >> 8)); + *cr = (cipher + *cr) * t1_c1 + t1_c2; + return cipher; +} + +static char *eol (char *s) { + char *p = strend (s); + if (p!=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 { + if (mp->ps->T##_array == NULL) { + mp->ps->T##_limit = (s); + if ((size_t)(n) > mp->ps->T##_limit) + mp->ps->T##_limit = (size_t)(n); + mp->ps->T##_array = mp_xmalloc (mp,mp->ps->T##_limit,sizeof(T##_entry)); + mp->ps->T##_ptr = mp->ps->T##_array; + } + else if ((size_t)(mp->ps->T##_ptr - mp->ps->T##_array + (n)) > 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; + if ((size_t)(mp->ps->T##_ptr - mp->ps->T##_array + (n)) > mp->ps->T##_limit) + mp->ps->T##_limit = (size_t)(mp->ps->T##_ptr - mp->ps->T##_array + (n)); + mp->ps->T##_array = mp_xrealloc(mp,mp->ps->T##_array,mp->ps->T##_limit, sizeof(T##_entry)); + mp->ps->T##_ptr = mp->ps->T##_array + last_ptr_index; + } +} while (0) + +@d out_eexec_char(A) t1_outhex(mp,(A)) + +@c +static void t1_outhex (MP mp, byte b) +{ + static const char *hexdigits = "0123456789ABCDEF"; + t1_putchar (hexdigits[b / 16]); + t1_putchar (hexdigits[b % 16]); + mp->ps->hexline_length += 2; + end_hexline (mp); +} +static void t1_getline (MP mp) { + int c, l, eexec_scan; + char *p; + static const char eexec_str[] = "currentfile eexec"; + static int eexec_len = 17; /* |strlen(eexec_str)| */ + RESTART: + if (t1_eof ()) + mp_fatal_error (mp,"unexpected end of file"); + mp->ps->t1_line_ptr = mp->ps->t1_line_array; + alloc_array (t1_line, 1, T1_BUF_SIZE); + mp->ps->t1_cslen = 0; + eexec_scan = 0; + c = t1_getbyte (mp); + if (c == EOF) + goto EXIT; + while (!t1_eof ()) { + if (mp->ps->t1_in_eexec == 1) + c = edecrypt (mp,(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 = 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 *p = mp->ps->t1_line_array; + if (mp->ps->t1_line_ptr - mp->ps->t1_line_array <= 1) + return; + if (mp->ps->t1_eexec_encrypt) { + while (p < mp->ps->t1_line_ptr) + out_eexec_char (eencrypt (mp,(byte)*p++)); + } else { + while (p < mp->ps->t1_line_ptr) + t1_putchar (*p++); + } +} + +static void t1_puts (MP mp, const char *s) +{ + if (s != mp->ps->t1_line_array) + strcpy (mp->ps->t1_line_array, s); + mp->ps->t1_line_ptr = strend (mp->ps->t1_line_array); + t1_putline (mp); +} + +static void t1_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 = 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, (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] = (char *) notdef; + } + if (glyph_names[a] != notdef) { + glyph_names[b] = mp_xstrdup (mp,glyph_names[a]); + } +} +static void t1_builtin_enc (MP mp) { + int i, a, b, c, counter = 0; + char *r, *p; + /* + * At this moment "/Encoding" is the prefix of |mp->ps->t1_line_array| + */ + if (t1_suffix ("def")) { /* predefined encoding */ + (void)sscanf (mp->ps->t1_line_array + strlen ("/Encoding"), "%256s", mp->ps->t1_buf_array); + if (strcmp (mp->ps->t1_buf_array, "StandardEncoding") == 0) { + for (i = 0; i < 256; i++) + if (standard_glyph_names[i] == notdef) + mp->ps->t1_builtin_glyph_names[i] = (char *) notdef; + else + mp->ps->t1_builtin_glyph_names[i] = + mp_xstrdup (mp,standard_glyph_names[i]); + mp->ps->t1_encoding = ENC_STANDARD; + } else { + char s[128]; + 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++) + mp->ps->t1_builtin_glyph_names[i] = (char *) notdef; + if (t1_prefix ("/Encoding [") || t1_prefix ("/Encoding[")) { /* the first case */ + r = strchr (mp->ps->t1_line_array, '[') + 1; + skip (r, ' '); + for (;;) { + while (*r == '/') { + for (p = mp->ps->t1_buf_array, r++; + *r != 32 && *r != 10 && *r != ']' && *r != '/'; + *p++ = *r++); + *p = 0; + skip (r, ' '); + if (counter > 255) { + mp_fatal_error + (mp, "encoding vector contains more than 256 names"); + } + if (strcmp (mp->ps->t1_buf_array, notdef) != 0) + mp->ps->t1_builtin_glyph_names[counter] = mp_xstrdup (mp,mp->ps->t1_buf_array); + counter++; + } + if (*r != 10 && *r != '%') { + if (str_prefix (r, "] def") + || str_prefix (r, "] readonly def")) + break; + else { + char s[128]; + remove_eol (r, mp->ps->t1_line_array); + 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%256s put", &i, mp->ps->t1_buf_array) == 2 && + *mp->ps->t1_buf_array == '/' && valid_code (i)) { + if (strcmp (mp->ps->t1_buf_array + 1, notdef) != 0) + mp->ps->t1_builtin_glyph_names[i] = + mp_xstrdup (mp,mp->ps->t1_buf_array + 1); + p = strstr (p, " put") + strlen (" put"); + skip (p, ' '); + } + /* + check for `dup dup <to> exch <from> get put' + */ + else if (sscanf (p, "dup dup %i exch %i get put", &b, &a) == 2 + && valid_code (a) && valid_code (b)) { + copy_glyph_names (mp,mp->ps->t1_builtin_glyph_names, a, b); + p = strstr (p, " get put") + strlen (" get put"); + skip (p, ' '); + } + /* + check for `dup dup <from> <size> getinterval <to> exch putinterval' + */ + else if (sscanf + (p, "dup dup %i %i getinterval %i exch putinterval", + &a, &c, &b) == 3 && valid_code (a) && valid_code (b) + && valid_code (c)) { + for (i = 0; i < c; i++) + copy_glyph_names (mp,mp->ps->t1_builtin_glyph_names, a + i, b + i); + p = strstr (p, " putinterval") + strlen (" putinterval"); + skip (p, ' '); + } + /* + check for `def' or `readonly def' + */ + else if ((p == mp->ps->t1_line_array || (p > mp->ps->t1_line_array && p[-1] == ' ')) + && strcmp (p, "def\n") == 0) + return; + /* + skip an unrecognizable word + */ + else { + while (*p != ' ' && *p != 10) + p++; + skip (p, ' '); + } + } + } +} + +static void t1_check_end (MP mp) { + if (t1_eof ()) + return; + t1_getline (mp); + if (t1_prefix ("{restore}")) + t1_putline (mp); +} + +@ @<Types...@>= +typedef struct { + char *ff_name; /* base name of font file */ + char *ff_path; /* full path to font file */ +} ff_entry; + +@ @c +static boolean t1_open_fontfile (MP mp, fm_entry *fm_cur,const char *open_name_prefix) { + ff_entry *ff; + ff = check_ff_exist (mp, fm_cur); + 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) { + mp_warn (mp, "cannot open Type 1 font file for reading"); + 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); + } + if (strcmp (mp->ps->t1_buf_array + 1, notdef) == 0) /* skip the slash */ + ptr->glyph_name = (char *) notdef; + else + ptr->glyph_name = mp_xstrdup (mp,mp->ps->t1_buf_array + 1); + } + /* copy " RD " + cs data to |mp->ps->t1_buf_array| */ + memcpy (mp->ps->t1_buf_array, mp->ps->t1_line_array + mp->ps->cs_start - 4, + (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); + t1_putline (mp); + t1_getline (mp); + } + t1_builtin_enc (mp); + if (is_reencoded (fm_cur)) + mp->ps->t1_glyph_names = external_enc (); + else + mp->ps->t1_glyph_names = mp->ps->t1_builtin_glyph_names; + /* + |if (is_included (fm_cur) && is_subsetted (fm_cur)) { + make_subset_tag (fm_cur, t1_glyph_names, tex_font); + update_subset_tag (); + }| + */ + if ((!is_subsetted (fm_cur)) && mp->ps->t1_encoding == ENC_STANDARD) + t1_puts (mp,"/Encoding StandardEncoding def\n"); + else { + t1_puts + (mp,"/Encoding 256 array\n0 1 255 {1 index exch /.notdef put} for\n"); + for (i = 0, j = 0; i < 256; i++) { + if (is_used_char (i) && mp->ps->t1_glyph_names[i] != notdef) { + j++; + 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 += 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); +} + +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) { + 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 = 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 = + 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; + 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) { + mp_xfree (mp->ps->t1_line_array); + mp_xfree (mp->ps->t1_buf_array); +} + +@* 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 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, 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,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,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,tex_font, fm_cur, true); + mp->ps->t1_synthetic = true ; + t1_do_subset_charstrings (mp, 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->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) { + (void)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 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_knot *pp; /* the last known knot in the subpath */ + + +@ @c +mp_edge_object *mp_ps_font_charstring (MP mp, mp_ps_font *f, int c) { + mp_edge_object *h = NULL; + f->h = NULL; f->p = NULL; f->pp = NULL; /* just in case */ + f->cur_x = f->cur_y = 0.0; + f->orig_x = f->orig_y = 0.0; + if (cs_parse(mp,f,f->t1_glyph_names[c], 0)) { + h = f->h; + } else { + if (f->h != NULL) { + finish_subpath(); + mp_gr_toss_objects(f->h); + } + } + f->h = NULL; f->p = NULL; f->pp = NULL; + return h; +} + + + +@ @<Exported function headers@>= +mp_edge_object *mp_ps_font_charstring (MP mp, mp_ps_font *f, int c); + + +@ +@<Declarations@>= +boolean cs_parse (MP mp, mp_ps_font *f, const char *cs_name, int subr); + +@ +@d scaled_from_double(a) (scaled)((a)*65536.0) +@d double_from_scaled(a) (double)((a)/65536.0) + +@d start_subpath(f,dx,dy) do { + assert(f->pp == NULL); + assert(f->p == NULL); + f->pp = mp_xmalloc(mp, 1, sizeof (mp_knot)); + f->pp->left_type = mp_endpoint; + f->pp->right_type = mp_open; + f->pp->x_coord = scaled_from_double(f->cur_x + dx); + f->pp->y_coord = scaled_from_double(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; +} while (0) + +@d finish_subpath() do { + 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; + } + } + f->p = NULL; + f->pp = NULL; +} while (0) + +@d add_line_segment(f,dx,dy) do { + assert(f->pp != NULL); + n = mp_xmalloc(mp,1, sizeof (mp_knot)); + n->left_type = mp_open; + n->right_type = mp_endpoint; + n->next = gr_path_p((mp_fill_object *)f->p); /* loop */ + n->x_coord = scaled_from_double(f->cur_x + dx); + n->y_coord = scaled_from_double(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->right_type = mp_open; + f->pp->next = n; + f->pp = n; + f->cur_x += dx; + f->cur_y += dy; +} while (0) + +@d add_curve_segment(f,dx1,dy1,dx2,dy2,dx3,dy3) do { + n = mp_xmalloc(mp, 1, sizeof (mp_knot)); + n->left_type = mp_open; + n->right_type = mp_endpoint; + n->next = gr_path_p((mp_fill_object *)f->p); /* loop */ + n->x_coord = scaled_from_double(f->cur_x + dx1 + dx2 + dx3); + n->y_coord = scaled_from_double(f->cur_y + dy1 + dy2 + dy3); + n->right_x = n->x_coord; + n->right_y = n->y_coord; + n->left_x = scaled_from_double(f->cur_x + dx1 + dx2); + n->left_y = scaled_from_double(f->cur_y + dy1 + dy2); + f->pp->right_x = scaled_from_double(f->cur_x + dx1); + f->pp->right_y = scaled_from_double(f->cur_y + dy1); + f->pp->right_type = mp_open; + f->pp->next = n; + f->pp = n; + f->cur_x += dx1 + dx2 + dx3; + f->cur_y += dy1 + dy2 + dy3; +} while (0) + +@d cs_no_debug(A) cs_do_debug(mp,f,A,#A) +@d cs_debug(A) + +@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; + mp_knot *n; + + 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 */ + } + + 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(); + cc_clear (); + break; + case CS_HLINETO: /* |- dx HLINETO |- */ + cs_debug(CS_HLINETO); + add_line_segment(f,cc_get(-1),0); + cc_clear (); + break; + case CS_HVCURVETO: /* |- dx1 dx2 dy2 dy3 HVCURVETO |- */ + cs_debug(CS_HVCURVETO); + add_curve_segment(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(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(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(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(f,0,cc_get(-1)); + cc_clear (); + break; + case CS_HMOVETO: /* |- dx HMOVETO |- */ + cs_debug(CS_HMOVETO); + finish_subpath(); + start_subpath(f,cc_get(-1),0); + cc_clear (); + break; + case CS_RMOVETO: /* |- dx dy RMOVETO |- */ + cs_debug(CS_RMOVETO); + finish_subpath(); + start_subpath(f,cc_get(-2),cc_get(-1)); + cc_clear (); + break; + case CS_VMOVETO: /* |- dy VMOVETO |- */ + cs_debug(CS_VMOVETO); + finish_subpath(); + start_subpath(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; + 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; + 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); + 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; + 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); + 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; + 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); + 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 - */ + 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); + f->cur_x = cc_get(-2); + f->cur_y = cc_get(-1); + f->pp = NULL; + 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; + } + } + } + print_err ("fontmap encoding problems for font "); + mp_print(mp,mp->font_name[f]); + mp_error(mp); + return NULL; +} +char * mp_fm_font_name (MP mp, 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 { + print_err ("font loading problems for font "); + mp_print(mp,mp->font_name[f]); + mp_error(mp); + } + } + return mp_xstrdup(mp,fm->ps_name); + } + } + print_err ("fontmap name problems for font "); + mp_print(mp,mp->font_name[f]); + mp_error(mp); + return NULL; +} + +static char * mp_fm_font_subset_name (MP mp, 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); + } + } + } + print_err ("fontmap name problems for font "); + mp_print(mp,mp->font_name[f]); + mp_error(mp); + return NULL; +} + +@ @<Declarations@>= +static integer mp_fm_font_slant (MP mp, 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 ( 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_print(mp, 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 ( 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)) ) + mp_ps_print(mp, mp_fm_font_subset_name(mp,f)); + else + mp_ps_print(mp, 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 ( 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_print(mp, 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 ( 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) ) + mp_ps_print(mp, mp_fm_font_subset_name(mp,f)); + else + mp_ps_print(mp, 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 ( 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_print(mp, mp->font_ps_name[f]); + ldf=(int)f; + } + FOUND: + ; + } + if ( ! firstitem ) { + mp_ps_print_ln(mp); + ldf=null_font; + firstitem=true; + for (f=null_font+1;f<= mp->last_fnum;f++) { + if ( mp_has_font_size(mp,f) ) { + for (ff=ldf;ff>=null_font;ff-- ) { + if ( mp_has_font_size(mp,(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)) + mp_ps_name_out(mp, mp_fm_font_subset_name(mp,f),true); + else + mp_ps_name_out(mp, mp->font_ps_name[f],true); + mp_ps_print(mp, " fcp"); + mp_ps_print_ln(mp); + if ( applied_reencoding(f) ) { + mp_ps_print(mp, "/Encoding "); + mp_ps_print(mp, mp->font_enc_name[f]); + mp_ps_print(mp, " def "); + }; + if ( mp_fm_font_slant(mp,f)!=0 ) { + mp_ps_print_int(mp, mp_fm_font_slant(mp,f)); + mp_ps_print(mp, " SlantFont "); + }; + if ( mp_fm_font_extend(mp,f)!=0 ) { + mp_ps_print_int(mp, mp_fm_font_extend(mp,f)); + mp_ps_print(mp, " ExtendFont "); + }; + if ( mp_xstrcmp(mp->font_name[f],"psyrgo")==0 ) { + mp_ps_print(mp, " 890 ScaleFont "); + mp_ps_print(mp, " 277 SlantFont "); + }; + if ( mp_xstrcmp(mp->font_name[f],"zpzdr-reversed")==0 ) { + mp_ps_print(mp, " FontMatrix [-1 0 0 1 0 0] matrix concatmatrix /FontMatrix exch def "); + mp_ps_print(mp, "/Metrics 2 dict dup begin "); + mp_ps_print(mp, "/space[0 -278]def "); + mp_ps_print(mp, "/a12[-904 -939]def "); + mp_ps_print(mp, "end def "); + }; + mp_ps_print(mp, "currentdict end"); + mp_ps_print_ln(mp); + mp_ps_print_defined_name(mp,f,prologues); + mp_ps_print(mp, " exch definefont pop"); + mp_ps_print_ln(mp); + } +} + +@ @<Declarations@>= +static void mp_ps_print_defined_name (MP mp, font_number f, int prologues); + +@ +@c static void mp_ps_print_defined_name(MP mp, font_number f, int prologues) { + mp_ps_print(mp, " /"); + if ((mp_font_is_subsetted(mp,f))&& + (mp_font_is_included(mp,f))&&(prologues==3)) + mp_ps_print(mp, mp_fm_font_subset_name(mp,f)); + 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) ) { + print_err("Font embedding failed"); + mp_error(mp); + } + } + } + cur_fsize[f]=link(cur_fsize[f]); + if ( cur_fsize[f]!=null ) { mp_unmark_font(mp, f); done_fonts=false; } + } + } + if ( ! done_fonts ) + @<Increment |next_size| and apply |mark_string_chars| to all text nodes with + that size index@>; +} while (! done_fonts); +} + +@ @<Increment |next_size| and apply |mark_string_chars| to all text nodes...@>= +{ + next_size++; + mp_apply_mark_string_chars(mp, h, next_size); +} + +@ We also need to keep track of which characters are used in text nodes +in the edge structure that is being shipped out. This is done by procedures +that use the left-over |b3| field in the |char_info| words; i.e., +|char_info(f)(c).b3| gives the status of character |c| in font |f|. + +@<Types...@>= +enum mp_char_mark_state {mp_unused=0, mp_used}; + +@ @<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 */ + 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=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 */ + pointer *cur_fsize; /* current positions in |font_sizes| */ + boolean done_fonts; /* have we finished listing the fonts in the header? */ + font_number f; /* a font number for loops */ + cur_fsize = mp_xmalloc(mp,(size_t)(mp->font_max+1),sizeof(pointer)); + mp_list_used_resources(mp, prologues, procset); + mp_list_supplied_resources(mp, prologues, procset); + mp_list_needed_resources(mp, prologues); + mp_ps_print_nl(mp, "%%EndComments"); + mp_ps_print_nl(mp, "%%BeginProlog"); + if ( procset>0 ) + mp_ps_print_nl(mp, "%%BeginResource: procset mpost"); + else + mp_ps_print_nl(mp, "%%BeginResource: procset mpost-minimal"); + mp_ps_print_nl(mp, "/bd{bind def}bind def" + "/fshow {exch findfont exch scalefont setfont show}bd"); + if ( procset>0 ) @<Print the procset@>; + mp_ps_print_nl(mp, "/fcp{findfont dup length dict begin" + "{1 index/FID ne{def}{pop pop}ifelse}forall}bd"); + mp_ps_print_nl(mp, "/fmc{FontMatrix dup length array copy dup dup}bd" + "/fmd{/FontMatrix exch def}bd"); + mp_ps_print_nl(mp, "/Amul{4 -1 roll exch mul 1000 div}bd" + "/ExtendFont{fmc 0 get Amul 0 exch put fmd}bd"); + mp_ps_print_nl(mp, "/ScaleFont{dup fmc 0 get" + " Amul 0 exch put dup dup 3 get Amul 3 exch put fmd}bd"); + mp_ps_print_nl(mp, "/SlantFont{fmc 2 get dup 0 eq{pop 1}if" + " Amul FontMatrix 0 get mul 2 exch put fmd}bd"); + mp_ps_print_nl(mp, "%%EndResource"); + @<Include encodings and fonts for edge structure~|h|@>; + mp_ps_print_nl(mp, "%%EndProlog"); + mp_ps_print_nl(mp, "%%BeginSetup"); + mp_ps_print_ln(mp); + for (f=null_font+1;f<=mp->last_fnum;f++) { + if ( mp_has_font_size(mp,f) ) { + if ( mp_has_fm_entry(mp,f,NULL) ) { + mp_write_font_definition(mp,f, prologues); + mp_ps_name_out(mp, mp->font_name[f],true); + mp_ps_print_defined_name(mp,f, prologues); + mp_ps_print(mp, " def"); + } else { + char s[256]; + 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 */ + pointer *cur_fsize; /* current positions in |font_sizes| */ + int ff; /* a loop counter */ + boolean done_fonts; /* have we finished listing the fonts in the header? */ + font_number f; /* a font number for loops */ + scaled ds; /* design size and scale factor for a text node */ + int ldf=0; /* the last \.{DocumentFont} listed (otherwise |null_font|) */ + cur_fsize = mp_xmalloc(mp,(size_t)(mp->font_max+1),sizeof(pointer)); + if ( prologues>0 ) { + @<Give a \.{DocumentFonts} comment listing all fonts with non-null + |font_sizes| and eliminate duplicates@>; + } else { + next_size=0; + @<Make |cur_fsize| a copy of the |font_sizes| array@>; + do { done_fonts=true; + for (f=null_font+1;f<=mp->last_fnum;f++) { + if ( cur_fsize[f]!=null ) { + @<Print the \.{\%*Font} comment for font |f| and advance |cur_fsize[f]|@>; + } + if ( cur_fsize[f]!=null ) { mp_unmark_font(mp, f); done_fonts=false; }; + } + if ( ! done_fonts ) { + @<Increment |next_size| and apply |mark_string_chars| to all text nodes with + that size index@>; + } + } while (! done_fonts); + } + mp_xfree(cur_fsize); + return (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 ( 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 |c| or +|font_bc[f]|, whichever is greater. If the output has to be truncated +to avoid exceeding |emergency_line_length| the return value says where to +start scanning next time. + +@<Declarations@>= +static halfword mp_ps_marks_out (MP mp,font_number f, eight_bits c); + +@ +@d emergency_line_length 255 + /* \ps\ output lines can be this long in unusual circumstances */ + +@c +static halfword mp_ps_marks_out (MP mp,font_number f, eight_bits c) { + eight_bits bc,ec; /* only encode characters between these bounds */ + integer lim; /* the maximum number of marks to encode before truncating */ + int p; /* |font_info| index for the current character */ + int d; /* used to construct a hexadecimal digit */ + unsigned b; /* used to construct a hexadecimal digit */ + lim=4*(emergency_line_length-mp->ps->ps_offset-4); + bc=mp->font_bc[f]; + ec=mp->font_ec[f]; + if ( c>bc ) bc=c; + @<Restrict the range |bc..ec| so that it contains no unused characters + at either end and has length at most |lim|@>; + @<Print the initial label indicating that the bitmap starts at |bc|@>; + @<Print a hexadecimal encoding of the marks for characters |bc..ec|@>; + while ( (ec<mp->font_ec[f])&&(mp->font_info[p].qqqq.b3==mp_unused) ) { + p++; ec++; + } + return (ec+1); +} + +@ We could save time by setting the return value before the loop that +decrements |ec|, but there is no point in being so tricky. + +@<Restrict the range |bc..ec| so that it contains no unused characters...@>= +p=mp->char_base[f]+bc; +while ( (mp->font_info[p].qqqq.b3==mp_unused)&&(bc<ec) ) { + p++; bc++; +} +if ( ec>=(eight_bits)(bc+lim)) ec=(eight_bits)(bc+lim-1); +p=mp->char_base[f]+ec; +while ( (mp->font_info[p].qqqq.b3==mp_unused)&&(bc<ec) ) { + p--; ec--; +} + +@ @<Print the initial label indicating that the bitmap starts at |bc|@>= +mp_ps_print_char(mp, ' '); +mp_hex_digit_out(mp, (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=d+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| with character code at least~|c|. + +@<Declarations@>= +static boolean mp_check_ps_marks (MP mp,font_number f, integer c) ; + +@ @c +static boolean mp_check_ps_marks (MP mp,font_number f, integer c) { + int p; /* |font_info| index for the current character */ + for (p=mp->char_base[f]+c;p<=mp->char_base[f]+mp->font_ec[f];p++) { + if ( mp->font_info[p].qqqq.b3==mp_used ) + return true; + } + return false; +} + + +@ If the file name is so long that it can't be printed without exceeding +|emergency_line_length| then there will be missing items in the \.{\%*Font:} +line. We might have to repeat line in order to get the character usage +information to fit within |emergency_line_length|. + +TODO: these two defines are also defined in mp.w! + +@d link(A) mp->mem[(A)].hh.rh /* the |link| field of a memory word */ +@d sc_factor(A) mp->mem[(A)+1].cint /* the scale factor stored in a font size node */ + +@<Print the \.{\%*Font} comment for font |f| and advance |cur_fsize[f]|@>= +{ integer t=0; + while ( mp_check_ps_marks(mp, f,t) ) { + mp_ps_print_nl(mp, "%*Font: "); + if ( mp->ps->ps_offset+strlen(mp->font_name[f])+12>emergency_line_length ) + break; + mp_ps_print(mp, mp->font_name[f]); + mp_ps_print_char(mp, ' '); + ds=(mp->font_dsize[f] + 8) / 16; + mp_ps_print_scaled(mp, mp_take_scaled(mp, ds,sc_factor(cur_fsize[f]))); + if ( mp->ps->ps_offset+12>emergency_line_length ) break; + mp_ps_print_char(mp, ' '); + mp_ps_print_scaled(mp, ds); + if ( mp->ps->ps_offset+5>emergency_line_length ) break; + t=mp_ps_marks_out(mp, f, (eight_bits)t); + } + cur_fsize[f]=link(cur_fsize[f]); +} + +@ @<Print the procset@>= +{ + mp_ps_print_nl(mp, "/hlw{0 dtransform exch truncate exch idtransform pop setlinewidth}bd"); + mp_ps_print_nl(mp, "/vlw{0 exch dtransform truncate idtransform setlinewidth pop}bd"); + mp_ps_print_nl(mp, "/l{lineto}bd/r{rlineto}bd/c{curveto}bd/m{moveto}bd" + "/p{closepath}bd/n{newpath}bd"); + mp_ps_print_nl(mp, "/C{setcmykcolor}bd/G{setgray}bd/R{setrgbcolor}bd" + "/lj{setlinejoin}bd/ml{setmiterlimit}bd"); + mp_ps_print_nl(mp, "/lc{setlinecap}bd/S{stroke}bd/F{fill}bd/q{gsave}bd" + "/Q{grestore}bd/s{scale}bd/t{concat}bd"); + mp_ps_print_nl(mp, "/sd{setdash}bd/rd{[] 0 setdash}bd/P{showpage}bd/B{q F Q}bd/W{clip}bd"); +} + + +@ The prologue defines \.{fshow} and corrects for the fact that \.{fshow} +arguments use |font_name| instead of |font_ps_name|. Downloaded bitmap fonts +might not have reasonable |font_ps_name| entries, but we just charge ahead +anyway. The user should not make \&{prologues} positive if this will cause +trouble. +@:prologues_}{\&{prologues} primitive@> + +@<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<mp->last_fnum) ) + mp_read_psname_table(mp); + mp_ps_print(mp, "%%BeginProlog"); mp_ps_print_ln(mp); + if ( (prologues>0)||(procset>0) ) { + if ( ldf!=null_font ) { + if ( prologues>0 ) { + for (f=null_font+1;f<=mp->last_fnum;f++) { + if ( mp_has_font_size(mp,f) ) { + mp_ps_name_out(mp, mp->font_name[f],true); + mp_ps_name_out(mp, mp->font_ps_name[f],true); + mp_ps_print(mp, " def"); + mp_ps_print_ln(mp); + } + } + if ( procset==0 ) { + mp_ps_print(mp, "/fshow {exch findfont exch scalefont setfont show}bind def"); + mp_ps_print_ln(mp); + } + } + } + if (procset>0 ) { + mp_ps_print_nl(mp, "%%BeginResource: procset mpost"); + if ( (prologues>0)&&(ldf!=null_font) ) + mp_ps_print_nl(mp, + "/bd{bind def}bind def/fshow {exch findfont exch scalefont setfont show}bd"); + else + mp_ps_print_nl(mp, "/bd{bind def}bind def"); + @<Print the procset@>; + mp_ps_print_nl(mp, "%%EndResource"); + mp_ps_print_ln(mp); + } + } + mp_ps_print(mp, "%%EndProlog"); + mp_ps_print_nl(mp, "%%Page: 1 1"); mp_ps_print_ln(mp); +} + +@ \MP\ used to have one single routine to print to both `write' files +and the PostScript output. Web2c redefines ``Character |k| cannot be +printed'', and that resulted in some bugs where 8-bit characters were +written to the PostScript file (reported by Wlodek Bzyl). + +Also, Hans Hagen requested spaces to be output as "\\040" instead of +a plain space, since that makes it easier to parse the result file +for postprocessing. + +@<Character |k| is not allowed in PostScript output@>= + (k<=' ')||(k>'~') + +@ We often need to print a pair of coordinates. + +@c +void mp_ps_pair_out (MP mp,scaled x, scaled y) { + ps_room(26); + mp_ps_print_scaled(mp, x); mp_ps_print_char(mp, ' '); + mp_ps_print_scaled(mp, y); mp_ps_print_char(mp, ' '); +} + +@ @<Declarations@>= +static void mp_ps_pair_out (MP mp,scaled x, scaled y) ; + +@ @c +void mp_ps_print_cmd (MP mp, const char *l, const char *s) { + if ( mp->internal[mp_procset]>0 ) { ps_room(strlen(s)); mp_ps_print(mp,s); } + else { ps_room(strlen(l)); mp_ps_print(mp, l); }; +} + +@ @<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) { + scaled t; + 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, mp_floor_scaled(mp, hh->minx),mp_floor_scaled(mp, hh->miny)); + mp_ps_pair_out(mp, -mp_floor_scaled(mp, -hh->maxx),-mp_floor_scaled(mp, -hh->maxy)); + } + mp_ps_print_nl(mp, "%%HiResBoundingBox: "); + if ( hh->minx>hh->maxx ) { + mp_ps_print(mp, "0 0 0 0"); + } else { + mp_ps_pair_out(mp, hh->minx,hh->miny); + mp_ps_pair_out(mp, hh->maxx,hh->maxy); + } + mp_ps_print_nl(mp, "%%Creator: MetaPost "); + s = mp_metapost_version(); + mp_ps_print(mp, s); + mp_xfree(s); + mp_ps_print_nl(mp, "%%CreationDate: "); + mp_ps_print_int(mp, mp_round_unscaled(mp, mp->internal[mp_year])); + mp_ps_print_char(mp, '.'); + mp_ps_print_dd(mp, mp_round_unscaled(mp, mp->internal[mp_month])); + mp_ps_print_char(mp, '.'); + mp_ps_print_dd(mp, mp_round_unscaled(mp, mp->internal[mp_day])); + mp_ps_print_char(mp, ':'); + t=mp_round_unscaled(mp, mp->internal[mp_time]); + mp_ps_print_dd(mp, t / 60); + mp_ps_print_dd(mp, t % 60); + mp_ps_print_nl(mp, "%%Pages: 1"); +} + +@ The most important output procedure is the one that gives the \ps\ version of +a \MP\ path. + +@(mplibps.h@>= +typedef struct mp_knot { + unsigned short left_type; + unsigned short right_type; + signed int x_coord; + signed int y_coord; + signed int left_x; + signed int left_y; + signed int right_x; + signed int right_y; + struct mp_knot * next; + unsigned char originator; +} mp_knot; + +@ @<Types...@>= +#define gr_left_type(A) (A)->left_type +#define gr_right_type(A) (A)->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_knot *mp_gr_copy_knot (MP mp, mp_knot *p) { + mp_knot *q; /* the copy */ + q = mp_xmalloc(mp, 1, sizeof (mp_knot)); + memcpy(q,p,sizeof (mp_knot)); + gr_next_knot(q)=NULL; + return q; +} + +@ The |copy_path| routine makes a clone of a given path. + +@c +static mp_knot *mp_gr_copy_path (MP mp, mp_knot *p) { + mp_knot *q, *pp, *qq; /* for list manipulation */ + if (p==NULL) + return NULL; + q=mp_gr_copy_knot(mp, p); + qq=q; + pp=gr_next_knot(p); + while ( pp!=p ) { + gr_next_knot(qq)=mp_gr_copy_knot(mp, pp); + qq=gr_next_knot(qq); + pp=gr_next_knot(pp); + } + gr_next_knot(qq)=q; + return q; +} + +@ Similarly, there's a way to copy the {\sl reverse\/} of a path. This procedure +returns a pointer to the first node of the copy, if the path is a cycle, +but to the final node of a non-cyclic copy. The global +variable |path_tail| will point to the final node of the original path; +this trick makes it easier to implement `\&{doublepath}'. + +All node types are assumed to be |endpoint| or |explicit| only. + +This function is currenly unused. + +@c +mp_knot * mp_gr_htap_ypoc (MP mp, mp_knot *p) { + mp_knot *q, *pp, *qq, *rr; /* for list manipulation */ + q=mp_xmalloc(mp, 1, sizeof (mp_knot)); /* this will correspond to |p| */ + qq=q; pp=p; + while (1) { + gr_right_type(qq)=gr_left_type(pp); + gr_left_type(qq)=gr_right_type(pp); + gr_x_coord(qq)=gr_x_coord(pp); + gr_y_coord(qq)=gr_y_coord(pp); + gr_right_x(qq)=gr_left_x(pp); + gr_right_y(qq)=gr_left_y(pp); + gr_left_x(qq)=gr_right_x(pp); + gr_left_y(qq)=gr_right_y(pp); + gr_originator(qq)=gr_originator(pp); + if ( gr_next_knot(pp)==p ) { + gr_next_knot(q)=qq; + /* |mp->path_tail=pp;| */ /* ? */ + return q; + } + rr=mp_xmalloc(mp, 1, sizeof (mp_knot)); + gr_next_knot(rr)=qq; + qq=rr; + pp=gr_next_knot(pp); + } +} + +@ When a cyclic list of knot nodes is no longer needed, it can be recycled by +calling the following subroutine. + +@<Declarations@>= +static void mp_do_gr_toss_knot_list (mp_knot *p) ; + +@ +@d mp_gr_toss_knot_list(B,A) mp_do_gr_toss_knot_list(A) + +@c +void mp_do_gr_toss_knot_list (mp_knot * p) { + mp_knot *q; /* the node being freed */ + mp_knot *r; /* the next node */ + if (p==NULL) + return; + q=p; + do { + r=gr_next_knot(q); + mp_xfree(q); q=r; + } while (q!=p); +} + + + +@ @c +static void mp_gr_ps_path_out (MP mp, mp_knot *h) { + mp_knot *p, *q; /* for scanning the path */ + scaled d; /* a temporary value */ + boolean curved; /* |true| unless the cubic is almost straight */ + ps_room(40); + mp_ps_print_cmd(mp, "newpath ","n "); + mp_ps_pair_out(mp, gr_x_coord(h),gr_y_coord(h)); + mp_ps_print_cmd(mp, "moveto","m"); + p=h; + do { + if ( gr_right_type(p)==mp_endpoint ) { + if ( p==h ) mp_ps_print_cmd(mp, " 0 0 rlineto"," 0 0 r"); + return; + } + q=gr_next_knot(p); + @<Start a new line and print the \ps\ commands for the curve from + |p| to~|q|@>; + p=q; + } while (p!=h); + mp_ps_print_cmd(mp, " closepath"," p"); +} + +@ @<Start a new line and print the \ps\ commands for the curve from...@>= +curved=true; +@<Set |curved:=false| if the cubic from |p| to |q| is almost straight@>; +mp_ps_print_ln(mp); +if ( curved ){ + mp_ps_pair_out(mp, gr_right_x(p),gr_right_y(p)); + mp_ps_pair_out(mp, gr_left_x(q),gr_left_y(q)); + mp_ps_pair_out(mp, gr_x_coord(q),gr_y_coord(q)); + mp_ps_print_cmd(mp, "curveto","c"); +} else if ( q!=h ){ + mp_ps_pair_out(mp, gr_x_coord(q),gr_y_coord(q)); + mp_ps_print_cmd(mp, "lineto","l"); +} + +@ Two types of straight lines come up often in \MP\ paths: +cubics with zero initial and final velocity as created by |make_path| or +|make_envelope|, and cubics with control points uniformly spaced on a line +as created by |make_choices|. + +@d bend_tolerance 131 /* allow rounding error of $2\cdot10^{-3}$ */ + +@<Set |curved:=false| if the cubic from |p| to |q| is almost straight@>= +if ( gr_right_x(p)==gr_x_coord(p) ) + if ( gr_right_y(p)==gr_y_coord(p) ) + if ( gr_left_x(q)==gr_x_coord(q) ) + if ( gr_left_y(q)==gr_y_coord(q) ) curved=false; +d=gr_left_x(q)-gr_right_x(p); +if ( abs(gr_right_x(p)-gr_x_coord(p)-d)<=bend_tolerance ) + if ( abs(gr_x_coord(q)-gr_left_x(q)-d)<=bend_tolerance ) + { d=gr_left_y(q)-gr_right_y(p); + if ( abs(gr_right_y(p)-gr_y_coord(p)-d)<=bend_tolerance ) + if ( abs(gr_y_coord(q)-gr_left_y(q)-d)<=bend_tolerance ) curved=false; + } + +@ The colored objects use a struct with anonymous fields to express the color parts: + +@(mplibps.h@>= +typedef struct { + int 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. + +@(mplibps.h@>= +typedef struct { + int offset; + int *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 (scaled)); + memcpy(q->array,dl->array, (i*sizeof(scaled))); + } + return q; +} + + +@ Now for outputting the actual graphic objects. First, set up some +structures and access macros. + +@d gr_has_color(A) (gr_type((A))<mp_start_clip_code) + +@<Types...@>= +#define gr_type(A) (A)->type +#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 + +@ @(mplibps.h@>= +#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 ; + unsigned int font_dsize ; + unsigned int font_n ; + int width ; + int height ; + int depth ; + int tx ; + int ty ; + int txx ; + int txy ; + int tyx ; + int 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_knot * path_p; + mp_knot * htap_p; + mp_knot * pen_p; + int 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_knot * path_p; + mp_knot * pen_p; + int miterlim ; + mp_dash_object *dash_p; +} mp_stroked_object; + +typedef struct mp_clip_object { + GRAPHIC_BODY; + mp_knot * path_p; +} mp_clip_object; + +typedef struct mp_bounds_object { + GRAPHIC_BODY; + mp_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; + int minx, miny, maxx, maxy; + int 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 { + scaled red_field ; + scaled green_field ; + scaled blue_field ; + scaled black_field ; + /* color from the last \&{setcmykcolor} or \&{setrgbcolor} or \&{setgray} command */ + quarterword colormodel_field ; + /* the current colormodel */ + quarterword ljoin_field ; + quarterword lcap_field ; + /* values from the last \&{setlinejoin} and \&{setlinecap} commands */ + quarterword adj_wx_field ; + /* what resolution-dependent adjustment applies to the width */ + scaled miterlim_field ; + /* the value from the last \&{setmiterlimit} command */ + mp_dash_object * dash_p_field ; + /* edge structure for last \&{setdash} command */ + boolean dash_done_field ; /* to test for initial \&{setdash} */ + struct _gs_state * previous_field ; + /* backlink to the previous |_gs_state| structure */ + scaled width_field ; + /* width setting or $-1$ if no \&{setlinewidth} command so far */ +} _gs_state; + + +@ @<Glob...@>= +struct _gs_state * gs_state; + +@ @<Set init...@>= +mp->ps->gs_state=NULL; + +@ @<Dealloc variables@>= +mp_xfree(mp->ps->gs_state); + +@ To avoid making undue assumptions about the initial graphics state, these +parameters are given special values that are guaranteed not to match anything +in the edge structure being shipped out. On the other hand, the initial color +should be black so that the translation of an all-black picture will have no +\&{setcolor} commands. (These would be undesirable in a font application.) +Hence we use |c=0| when initializing the graphics state and we use |c<0| +to recover from a situation where we have lost track of the graphics state. + +@d mp_void (null+1) /* a null pointer different from |null| */ + +@c static void mp_gs_unknown_graphics_state (MP mp,scaled c) { + struct _gs_state *p; /* to shift graphic states around */ + if ( (c==0)||(c==-1) ) { + if ( mp->ps->gs_state==NULL ) { + mp->ps->gs_state = mp_xmalloc(mp,1,sizeof(struct _gs_state)); + gs_previous=NULL; + } else { + while ( gs_previous!=NULL ) { + p = gs_previous; + mp_xfree(mp->ps->gs_state); + mp->ps->gs_state=p; + } + } + gs_red=c; gs_green=c; gs_blue=c; gs_black=c; + gs_colormodel=mp_uninitialized_model; + gs_ljoin=3; + gs_lcap=3; + gs_miterlim=0; + gs_dash_p=NULL; + gs_dash_init_done=false; + gs_width=-1; + } else if ( c==1 ) { + p= mp->ps->gs_state; + mp->ps->gs_state = mp_xmalloc(mp,1,sizeof(struct _gs_state)); + memcpy(mp->ps->gs_state,p,sizeof(struct _gs_state)); + gs_previous = p; + } else if ( c==2 ) { + p = gs_previous; + mp_xfree(mp->ps->gs_state); + mp->ps->gs_state=p; + } +} + + +@ When it is time to output a graphical object, |fix_graphics_state| ensures +that \ps's idea of the graphics state agrees with what is stored in the object. + +@<Declarations@>= +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_knot *pp, *path_p; /* for list manipulation */ + mp_dash_object *hh; + scaled wx,wy,ww; /* dimensions of pen bounding box */ + quarterword adj_wx; /* whether pixel rounding should be based on |wx| or |wy| */ + integer 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_scaled(mp, gr_miterlim_val(p)); + mp_ps_print_cmd(mp, " setmiterlimit"," ml"); + gs_miterlim=gr_miterlim_val(p); + } + +@<Set the other numeric parameters as needed for object~|p|@>= +if ( gr_type(p)==mp_stroked_code ) { + mp_stroked_object *ts = (mp_stroked_object *)p; + set_ljoin_miterlim(ts); +} else { + mp_fill_object *ts = (mp_fill_object *)p; + set_ljoin_miterlim(ts); +} + +@ +@d set_color_objects(pq) + object_color_model = pq->color_model; + 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; + int object_color_a, object_color_b, object_color_c, object_color_d ; + if (gr_type(p) == mp_fill_code) { + mp_fill_object *pq = (mp_fill_object *)p; + set_color_objects(pq); + } else if (gr_type(p) == mp_stroked_code) { + mp_stroked_object *pq = (mp_stroked_object *)p; + set_color_objects(pq); + } else { + mp_text_object *pq = (mp_text_object *)p; + set_color_objects(pq); + } + + if ( object_color_model==mp_rgb_model) { + if ( (gs_colormodel!=mp_rgb_model)||(gs_red!=object_color_a)|| + (gs_green!=object_color_b)||(gs_blue!=object_color_c) ) { + gs_red = object_color_a; + gs_green = object_color_b; + gs_blue = object_color_c; + gs_black = -1; + gs_colormodel=mp_rgb_model; + { ps_room(36); + mp_ps_print_char(mp, ' '); + mp_ps_print_scaled(mp, gs_red); mp_ps_print_char(mp, ' '); + mp_ps_print_scaled(mp, gs_green); mp_ps_print_char(mp, ' '); + mp_ps_print_scaled(mp, gs_blue); + mp_ps_print_cmd(mp, " setrgbcolor", " R"); + } + } + } else if ( object_color_model==mp_cmyk_model) { + if ( (gs_red!=object_color_a)||(gs_green!=object_color_b)|| + (gs_blue!=object_color_c)||(gs_black!=object_color_d)|| + (gs_colormodel!=mp_cmyk_model) ) { + gs_red = object_color_a; + gs_green = object_color_b; + gs_blue = object_color_c; + gs_black = object_color_d; + gs_colormodel=mp_cmyk_model; + { ps_room(45); + mp_ps_print_char(mp, ' '); + mp_ps_print_scaled(mp, gs_red); + mp_ps_print_char(mp, ' '); + mp_ps_print_scaled(mp, gs_green); + mp_ps_print_char(mp, ' '); + mp_ps_print_scaled(mp, gs_blue); + mp_ps_print_char(mp, ' '); + mp_ps_print_scaled(mp, gs_black); + mp_ps_print_cmd(mp, " setcmykcolor"," C"); + } + } + } else if ( object_color_model==mp_grey_model ) { + if ( (gs_red!=object_color_a)||(gs_colormodel!=mp_grey_model) ) { + gs_red = object_color_a; + gs_green = -1; + gs_blue = -1; + gs_black = -1; + gs_colormodel=mp_grey_model; + { ps_room(16); + mp_ps_print_char(mp, ' '); + mp_ps_print_scaled(mp, gs_red); + mp_ps_print_cmd(mp, " setgray"," G"); + } + } + } else if ( object_color_model==mp_no_model ) { + gs_colormodel=mp_no_model; + } +} + +@ In order to get consistent widths for horizontal and vertical pen strokes, we +want \ps\ to use an integer number of pixels for the \&{setwidth} parameter. +@:setwidth}{\&{setwidth}command@> +We set |gs_width| to the ideal horizontal or vertical stroke width and then +generate \ps\ code that computes the rounded value. For non-circular pens, the +pen shape will be rescaled so that horizontal or vertical parts of the stroke +have the computed width. + +Rounding the width to whole pixels is not likely to improve the appearance of +diagonal or curved strokes, but we do it anyway for consistency. The +\&{truncate} command generated here tends to make all the strokes a little +@:truncate}{\&{truncate} command@> +thinner, but this is appropriate for \ps's scan-conversion rules. Even with +truncation, an ideal with of $w$~pixels gets mapped into $\lfloor w\rfloor+1$. +It would be better to have $\lceil w\rceil$ but that is ridiculously expensive +to compute in \ps. + +@<Generate \ps\ code that sets the stroke width...@>= +@<Set |wx| and |wy| to the width and height of the bounding box for + |pen_p(p)|@>; +@<Use |pen_p(p)| and |path_p(p)| to decide whether |wx| or |wy| is more + important and set |adj_wx| and |ww| accordingly@>; +if ( (ww!=gs_width) || (adj_wx!=gs_adj_wx) ) { + if ( adj_wx != 0 ) { + ps_room(13); + mp_ps_print_char(mp, ' '); mp_ps_print_scaled(mp, ww); + mp_ps_print_cmd(mp, + " 0 dtransform exch truncate exch idtransform pop setlinewidth"," hlw"); + } else { + if ( mp->internal[mp_procset]>0 ) { + ps_room(13); + mp_ps_print_char(mp, ' '); + mp_ps_print_scaled(mp, ww); + mp_ps_print(mp, " vlw"); + } else { + ps_room(15); + mp_ps_print(mp, " 0 "); mp_ps_print_scaled(mp, ww); + mp_ps_print(mp, " dtransform truncate idtransform setlinewidth pop"); + } + } + gs_width = ww; + gs_adj_wx = adj_wx; +} + +@ @<Set |wx| and |wy| to the width and height of the bounding box for...@>= +if ( (gr_right_x(pp)==gr_x_coord(pp)) && (gr_left_y(pp)==gr_y_coord(pp)) ) { + wx = abs(gr_left_x(pp) - gr_x_coord(pp)); + wy = abs(gr_right_y(pp) - gr_y_coord(pp)); +} else { + wx = mp_pyth_add(mp, gr_left_x(pp)-gr_x_coord(pp), gr_right_x(pp)-gr_x_coord(pp)); + wy = mp_pyth_add(mp, gr_left_y(pp)-gr_y_coord(pp), gr_right_y(pp)-gr_y_coord(pp)); +} + +@ The path is considered ``essentially horizontal'' if its range of +$y$~coordinates is less than the $y$~range |wy| for the pen. ``Essentially +vertical'' paths are detected similarly. This code ensures that no component +of the pen transformation is more that |aspect_bound*(ww+1)|. + +@d aspect_bound 10 /* ``less important'' of |wx|, |wy| cannot exceed the other by + more than this factor */ + +@d do_x_loc 1 +@d do_y_loc 2 + +@<Use |pen_p(p)| and |path_p(p)| to decide whether |wx| or |wy| is more...@>= +tx=1; ty=1; +if ( mp_gr_coord_rangeOK(path_p, do_y_loc, wy) ) tx=aspect_bound; +else if ( mp_gr_coord_rangeOK(path_p, do_x_loc, wx) ) ty=aspect_bound; +if ( wy / ty>=wx / tx ) { ww=wy; adj_wx=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_knot *h, + quarterword zoff, scaled dz); + +@ @c +boolean mp_gr_coord_rangeOK (mp_knot *h, + quarterword zoff, scaled dz) { + mp_knot *p; /* for scanning the path form |h| */ + scaled zlo,zhi; /* coordinate range so far */ + scaled z; /* coordinate currently being tested */ + if (zoff==do_x_loc) { + zlo=gr_x_coord(h); + zhi=zlo; + p=h; + while ( gr_right_type(p)!=mp_endpoint ) { + z=gr_right_x(p); + @<Make |zlo..zhi| include |z| and |return false| if |zhi-zlo>dz|@>; + p=gr_next_knot(p); z=gr_left_x(p); + @<Make |zlo..zhi| include |z| and |return false| if |zhi-zlo>dz|@>; + z=gr_x_coord(p); + @<Make |zlo..zhi| include |z| and |return false| if |zhi-zlo>dz|@>; + if ( p==h ) break; + } + } else { + zlo=gr_y_coord(h); + zhi=zlo; + p=h; + while ( gr_right_type(p)!=mp_endpoint ) { + z=gr_right_y(p); + @<Make |zlo..zhi| include |z| and |return false| if |zhi-zlo>dz|@>; + p=gr_next_knot(p); z=gr_left_y(p); + @<Make |zlo..zhi| include |z| and |return false| if |zhi-zlo>dz|@>; + z=gr_y_coord(p); + @<Make |zlo..zhi| include |z| and |return false| if |zhi-zlo>dz|@>; + if ( p==h ) break; + } + } + return true; +} + +@ @<Make |zlo..zhi| include |z| and |return false| if |zhi-zlo>dz|@>= +if ( z<zlo ) zlo=z; +else if ( z>zhi ) zhi=z; +if ( zhi-zlo>dz ) return false + +@ Filling with an elliptical pen is implemented via a combination of \&{stroke} +and \&{fill} commands and a nontrivial dash pattern would interfere with this. +@:stroke}{\&{stroke} command@> +@:fill}{\&{fill} command@> +Note that we don't use |delete_edge_ref| because |gs_dash_p| is not counted as +a reference. + +@<Make sure \ps\ will use the right dash pattern for |dash_p(p)|@>= +if ( gr_type(p)==mp_fill_code || gr_dash_p(p) == NULL) { + hh=NULL; +} else { + hh=gr_dash_p(p); +} +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_scaled(mp, *(hh->array+i)); + mp_ps_print_char(mp, ' ') ; + } + ps_room(22); + mp_ps_print(mp, "] "); + mp_ps_print_scaled(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| */ + scaled txx,txy,tyx,tyy; /* transformation parameters */ + mp_knot *p; /* the pen to stroke with */ + scaled d1,det; /* for tweaking transformation parameters */ + integer s; /* also for tweaking transformation paramters */ + boolean transformed; /* keeps track of whether gsave/grestore are needed */ + transformed=false; + @<Use |pen_p(h)| to set the transformation parameters and give the initial + translation@>; + @<Tweak the transformation parameters so the transformation is nonsingular@>; + if (gr_type(h)==mp_fill_code) { + mp_gr_ps_path_out(mp, gr_path_p((mp_fill_object *)h)); + } else { + mp_gr_ps_path_out(mp, gr_path_p((mp_stroked_object *)h)); + } + if ( mp->internal[mp_procset]==0 ) { + if ( fill_also ) mp_ps_print_nl(mp, "gsave fill grestore"); + @<Issue \ps\ commands to transform the coordinate system@>; + mp_ps_print(mp, " stroke"); + if ( transformed ) mp_ps_print(mp, " grestore"); + } else { + if ( fill_also ) mp_ps_print_nl(mp, "B"); else mp_ps_print_ln(mp); + if ( (txy!=0)||(tyx!=0) ) { + mp_ps_print(mp, " ["); + mp_ps_pair_out(mp, txx,tyx); + mp_ps_pair_out(mp, txy,tyy); + mp_ps_print(mp, "0 0] t"); + } else if ((txx!=unity)||(tyy!=unity) ) { + mp_ps_pair_out(mp,txx,tyy); + mp_ps_print(mp, " s"); + }; + mp_ps_print(mp, " S"); + if ( transformed ) mp_ps_print(mp, " Q"); + } + mp_ps_print_ln(mp); +} + +@ @<Use |pen_p(h)| to set the transformation parameters and give the...@>= +if (gr_type(h)==mp_fill_code) { + p=gr_pen_p((mp_fill_object *)h); +} else { + p=gr_pen_p((mp_stroked_object *)h); +} +txx=gr_left_x(p); +tyx=gr_left_y(p); +txy=gr_right_x(p); +tyy=gr_right_y(p); +if ( (gr_x_coord(p)!=0)||(gr_y_coord(p)!=0) ) { + mp_ps_print_nl(mp, ""); + mp_ps_print_cmd(mp, "gsave ","q "); + mp_ps_pair_out(mp, gr_x_coord(p), gr_y_coord(p)); + mp_ps_print(mp, "translate "); + txx-=gr_x_coord(p); + tyx-=gr_y_coord(p); + txy-=gr_x_coord(p); + tyy-=gr_y_coord(p); + transformed=true; +} else { + mp_ps_print_nl(mp, ""); +} +@<Adjust the transformation to account for |gs_width| and output the + initial \&{gsave} if |transformed| should be |true|@> + +@ @<Adjust the transformation to account for |gs_width| and output the...@>= +if ( gs_width!=unity ) { + if ( gs_width==0 ) { + txx=unity; tyy=unity; + } else { + txx=mp_make_scaled(mp, txx,gs_width); + txy=mp_make_scaled(mp, txy,gs_width); + tyx=mp_make_scaled(mp, tyx,gs_width); + tyy=mp_make_scaled(mp, tyy,gs_width); + }; +} +if ( (txy!=0)||(tyx!=0)||(txx!=unity)||(tyy!=unity) ) { + if ( (! transformed) ){ + mp_ps_print_cmd(mp, "gsave ","q "); + transformed=true; + } +} + +@ @<Issue \ps\ commands to transform the coordinate system@>= +if ( (txy!=0)||(tyx!=0) ){ + mp_ps_print_ln(mp); + mp_ps_print_char(mp, '['); + mp_ps_pair_out(mp, txx,tyx); + mp_ps_pair_out(mp, txy,tyy); + mp_ps_print(mp, "0 0] concat"); +} else if ( (txx!=unity)||(tyy!=unity) ){ + mp_ps_print_ln(mp); + mp_ps_pair_out(mp, txx,tyy); + mp_ps_print(mp, "scale"); +} + +@ The \ps\ interpreter will probably abort if it encounters a singular +transformation matrix. The determinant must be large enough to ensure that +the printed representation will be nonsingular. Since the printed +representation is always within $2^{-17}$ of the internal |scaled| value, the +total error is at most $4T_{\rm max}2^{-17}$, where $T_{\rm max}$ is a bound on +the magnitudes of |txx/65536|, |txy/65536|, etc. + +The |aspect_bound*(gs_width+1)| bound on the components of the pen +transformation allows $T_{\rm max}$ to be at most |2*aspect_bound|. + +@<Tweak the transformation parameters so the transformation is nonsingular@>= +det=mp_take_scaled(mp, txx,tyy) - mp_take_scaled(mp, txy,tyx); +d1=4*aspect_bound+1; +if ( abs(det)<d1 ) { + if ( det>=0 ) { d1=d1-det; s=1; } + else { d1=-d1-det; s=-1; }; + d1=d1*unity; + if ( abs(txx)+abs(tyy)>=abs(txy)+abs(tyy) ) { + if ( abs(txx)>abs(tyy) ) tyy=tyy+(d1+s*abs(txx)) / txx; + else txx=txx+(d1+s*abs(tyy)) / tyy; + } else { + if ( abs(txy)>abs(tyx) ) tyx=tyx+(d1+s*abs(txy)) / txy; + else txy=txy+(d1+s*abs(tyx)) / tyx; + } +} + +@ Here is a simple routine that just fills a cycle. + +@<Declarations@>= +static void mp_gr_ps_fill_out (MP mp, mp_knot *p); + +@ @c +void mp_gr_ps_fill_out (MP mp, mp_knot *p) { /* fill cyclic path~|p| */ + mp_gr_ps_path_out(mp, p); + mp_ps_print_cmd(mp, " fill"," F"); + mp_ps_print_ln(mp); +} + +@ A text node may specify an arbitrary transformation but the usual case +involves only shifting, scaling, and occasionally rotation. The purpose +of |choose_scale| is to select a scale factor so that the remaining +transformation is as ``nice'' as possible. The definition of ``nice'' +is somewhat arbitrary but shifting and $90^\circ$ rotation are especially +nice because they work out well for bitmap fonts. The code here selects +a scale factor equal to $1/\sqrt2$ times the Frobenius norm of the +non-shifting part of the transformation matrix. It is careful to avoid +additions that might cause undetected overflow. + +@<Declarations@>= +static scaled mp_gr_choose_scale (MP mp, mp_graphic_object *p) ; + +@ @c scaled mp_gr_choose_scale (MP mp, mp_graphic_object *p) { + /* |p| should point to a text node */ + scaled a,b,c,d,ad,bc; /* temporary values */ + a=gr_txx_val(p); + b=gr_txy_val(p); + c=gr_tyx_val(p); + d=gr_tyy_val(p); + if ( a<0 ) negate(a); + if ( b<0 ) negate(b); + if ( c<0 ) negate(c); + if ( d<0 ) negate(d); + ad=half(a-d); + bc=half(b-c); + return mp_pyth_add(mp, mp_pyth_add(mp, d+ad,ad), mp_pyth_add(mp, c+bc,bc)); +} + +@ The potential overflow here is caused by the fact the returned value +has to fit in a |name_type|, which is a quarterword. + +@d fscale_tolerance 65 /* that's $.001\times2^{16}$ */ + +@<Declarations@>= +static quarterword mp_size_index (MP mp, font_number f, scaled s) ; + +@ @c +quarterword mp_size_index (MP mp, font_number f, scaled s) { + pointer p,q; /* the previous and current font size nodes */ + quarterword i; /* the size index for |q| */ + q=mp->font_sizes[f]; + i=0; + while ( q!=null ) { + if ( abs(s-sc_factor(q))<=fscale_tolerance ) + return i; + else + { p=q; q=link(q); incr(i); }; + if ( i==max_quarterword ) + mp_overflow(mp, "sizes per font",max_quarterword); +@:MetaPost capacity exceeded sizes per font}{\quad sizes per font@> + } + q=mp_get_node(mp, font_size_size); + sc_factor(q)=s; + if ( i==0 ) mp->font_sizes[f]=q; else link(p)=q; + return i; +} + +@ @<Declarations@>= +static scaled mp_indexed_size (MP mp,font_number f, quarterword j); + +@ @c +scaled mp_indexed_size (MP mp,font_number f, quarterword j) { + pointer p; /* a font size node */ + quarterword i; /* the size index for |p| */ + p=mp->font_sizes[f]; + i=0; + if ( p==null ) mp_confusion(mp, "size"); + while ( (i!=j) ) { + incr(i); p=link(p); + if ( p==null ) mp_confusion(mp, "size"); + } + return sc_factor(p); +} + +@ @<Declarations@>= +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 */ + pointer p; /* current font size nodes */ + for (f=null_font+1;f<=mp->last_fnum;f++) { + while ( mp->font_sizes[f]!=null ) { + p=mp->font_sizes[f]; + mp->font_sizes[f]=link(p); + mp_free_node(mp, p,font_size_size); + } + } +} + +@ A text node may specify an arbitrary transformation but the usual case +involves only shifting, scaling, and occasionally rotation. The purpose +of |choose_scale| is to select a scale factor so that the remaining +transformation is as ``nice'' as possible. The definition of ``nice'' +is somewhat arbitrary but shifting and $90^\circ$ rotation are especially +nice because they work out well for bitmap fonts. The code here selects +a scale factor equal to $1/\sqrt2$ times the Frobenius norm of the +non-shifting part of the transformation matrix. It is careful to avoid +additions that might cause undetected overflow. + + +@ @c static scaled mp_choose_scale (MP mp, mp_graphic_object *p) { + /* |p| should point to a text node */ + scaled a,b,c,d,ad,bc; /* temporary values */ + a=gr_txx_val(p); + b=gr_txy_val(p); + c=gr_tyx_val(p); + d=gr_tyy_val(p); + if ( (a<0) ) negate(a); + if ( (b<0) ) negate(b); + if ( (c<0) ) negate(c); + if ( (d<0) ) negate(d); + ad=half(a-d); + bc=half(b-c); + return mp_pyth_add(mp, mp_pyth_add(mp, d+ad,ad), mp_pyth_add(mp, c+bc,bc)); +} + +@ There may be many sizes of one font and we need to keep track of the +characters used for each size. This is done by keeping a linked list of +sizes for each font with a counter in each text node giving the appropriate +position in the size list for its font. + +@d font_size_size 2 /* size of a font size node */ + + +@ @<Declarations@>= +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->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_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; + scaled ds,scf; /* design size and scale factor for a text node */ + font_number f; /* for loops over fonts while (un)marking characters */ + boolean transformed; /* is the coordinate system being transformed? */ + 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)mp->internal[mp_prologues]>>16); + else + prologues=qprologues; + if (qprocset<0) + procset = (int)((unsigned)mp->internal[mp_procset]>>16); + else + procset=qprocset; + mp_open_output_file(mp); + mp_print_initial_comment(mp, hh, prologues); + p = hh->body; + @<Unmark all marked characters@>; + if ( prologues==2 || prologues==3 ) { + mp_reload_encodings(mp); + } + @<Scan all the text nodes and mark the used characters@>; + if ( prologues==2 || prologues==3 ) { + mp_print_improved_prologue(mp, hh, prologues, procset); + } else { + mp_print_prologue(mp, hh, prologues, procset); + } + mp_gs_unknown_graphics_state(mp, 0); + p = hh->body; + while ( p!=NULL ) { + if ( gr_has_color(p) ) { + @<Write |pre_script| of |p|@>; + } + mp_gr_fix_graphics_state(mp, p); + switch (gr_type(p)) { + case mp_fill_code: + if ( gr_pen_p((mp_fill_object *)p)==NULL ) { + mp_gr_ps_fill_out(mp, gr_path_p((mp_fill_object *)p)); + } else if ( pen_is_elliptical(gr_pen_p((mp_fill_object *)p)) ) { + mp_gr_stroke_ellipse(mp, p,true); + } else { + mp_gr_ps_fill_out(mp, gr_path_p((mp_fill_object *)p)); + mp_gr_ps_fill_out(mp, gr_htap_p(p)); + } + if ( gr_post_script((mp_fill_object *)p)!=NULL ) { + mp_ps_print_nl (mp, gr_post_script((mp_fill_object *)p)); + mp_ps_print_ln(mp); + } + break; + case mp_stroked_code: + if ( pen_is_elliptical(gr_pen_p((mp_stroked_object *)p)) ) + mp_gr_stroke_ellipse(mp, p,false); + else { + mp_gr_ps_fill_out(mp, gr_path_p((mp_stroked_object *)p)); + } + if ( gr_post_script((mp_stroked_object *)p)!=NULL ) { + mp_ps_print_nl (mp, gr_post_script((mp_stroked_object *)p)); + mp_ps_print_ln(mp); + } + break; + case mp_text_code: + if ( (gr_font_n(p)!=null_font) && (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 ( mp->internal[mp_restore_clip_color]>0 ) + mp_gs_unknown_graphics_state(mp, 1); + break; + case mp_stop_clip_code: + mp_ps_print_nl(mp, ""); mp_ps_print_cmd(mp, "grestore","Q"); + mp_ps_print_ln(mp); + if ( mp->internal[mp_restore_clip_color]>0 ) + mp_gs_unknown_graphics_state(mp, 2); + else + mp_gs_unknown_graphics_state(mp, -1); + break; + case mp_start_bounds_code: + case mp_stop_bounds_code: + break; + case mp_special_code: + { + mp_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; +} + +@ @(mplibps.h@>= +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_scaled(mp, mp_take_scaled(mp, ds,scf)); +mp_ps_print(mp, " fshow"); +if ( transformed ) + mp_ps_print_cmd(mp, " grestore"," Q") + + + +@ @<Shift or transform as necessary before outputting text node~|p| at...@>= +transformed=(gr_txx_val(p)!=scf)||(gr_tyy_val(p)!=scf)|| + (gr_txy_val(p)!=0)||(gr_tyx_val(p)!=0); +if ( transformed ) { + mp_ps_print_cmd(mp, "gsave [", "q ["); + mp_ps_pair_out(mp, mp_make_scaled(mp, gr_txx_val(p),scf), + mp_make_scaled(mp, gr_tyx_val(p),scf)); + mp_ps_pair_out(mp, mp_make_scaled(mp, gr_txy_val(p),scf), + mp_make_scaled(mp, gr_tyy_val(p),scf)); + mp_ps_pair_out(mp, gr_tx_val(p),gr_ty_val(p)); + mp_ps_print_cmd(mp, "] concat 0 0 moveto","] t 0 0 m"); +} else { + mp_ps_pair_out(mp, gr_tx_val(p),gr_ty_val(p)); + mp_ps_print_cmd(mp, "moveto","m"); +} +mp_ps_print_ln(mp) + +@ @(mplibps.h@>= +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); +} + +@ @(mplibps.h@>= +mp_graphic_object *mp_gr_copy_object (MP mp, mp_graphic_object *p) ; + +@ @c +mp_graphic_object * +mp_gr_copy_object (MP mp, mp_graphic_object *p) { + mp_fill_object *tf; + mp_stroked_object *ts; + mp_text_object *tt; + mp_clip_object *tc; + mp_bounds_object *tb; + mp_special_object *tp; + mp_graphic_object *q = NULL; + switch (gr_type(p)) { + case mp_fill_code: + tf = (mp_fill_object *)mp_new_graphic_object(mp, mp_fill_code); + gr_pre_script(tf) = mp_xstrdup(mp, gr_pre_script((mp_fill_object *)p)); + gr_post_script(tf) = mp_xstrdup(mp, gr_post_script((mp_fill_object *)p)); + gr_path_p(tf) = mp_gr_copy_path(mp,gr_path_p((mp_fill_object *)p)); + gr_htap_p(tf) = mp_gr_copy_path(mp,gr_htap_p(p)); + gr_pen_p(tf) = mp_gr_copy_path(mp,gr_pen_p((mp_fill_object *)p)); + q = (mp_graphic_object *)tf; + break; + case mp_stroked_code: + ts = (mp_stroked_object *)mp_new_graphic_object(mp, mp_stroked_code); + gr_pre_script(ts) = mp_xstrdup(mp, gr_pre_script((mp_stroked_object *)p)); + gr_post_script(ts) = mp_xstrdup(mp, gr_post_script((mp_stroked_object *)p)); + gr_path_p(ts) = mp_gr_copy_path(mp,gr_path_p((mp_stroked_object *)p)); + gr_pen_p(ts) = mp_gr_copy_path(mp,gr_pen_p((mp_stroked_object *)p)); + gr_dash_p(ts) = mp_gr_copy_dashes(mp,gr_dash_p(p)); + q = (mp_graphic_object *)ts; + break; + case mp_text_code: + tt = (mp_text_object *)mp_new_graphic_object(mp, mp_text_code); + gr_pre_script(tt) = mp_xstrdup(mp, gr_pre_script((mp_text_object *)p)); + gr_post_script(tt) = mp_xstrdup(mp, gr_post_script((mp_text_object *)p)); + gr_text_p(tt) = mp_xstrldup(mp, gr_text_p(p), gr_text_l(p)); + gr_text_l(tt) = gr_text_l(p); + gr_font_name(tt) = mp_xstrdup(mp, gr_font_name(p)); + q = (mp_graphic_object *)tt; + break; + case mp_start_clip_code: + tc = (mp_clip_object *)mp_new_graphic_object(mp, mp_start_clip_code); + gr_path_p(tc) = mp_gr_copy_path(mp,gr_path_p((mp_clip_object *)p)); + q = (mp_graphic_object *)tc; + break; + case mp_start_bounds_code: + tb = (mp_bounds_object *)mp_new_graphic_object(mp, mp_start_bounds_code); + gr_path_p(tb) = mp_gr_copy_path(mp,gr_path_p((mp_bounds_object *)p)); + q = (mp_graphic_object *)tb; + break; + case mp_special_code: + tp = (mp_special_object *)mp_new_graphic_object(mp, mp_special_code); + gr_pre_script(tp) = mp_xstrdup(mp, gr_pre_script((mp_special_object *)p)); + q = (mp_graphic_object *)tp; + break; + case mp_stop_clip_code: + q = mp_new_graphic_object(mp, mp_stop_clip_code); + break; + case mp_stop_bounds_code: + q = mp_new_graphic_object(mp, mp_stop_bounds_code); + break; + } /* all cases are enumerated */ + return q; +} + diff --git a/Build/source/texk/web2c/mplibdir/svgout.w b/Build/source/texk/web2c/mplibdir/svgout.w new file mode 100644 index 00000000000..22072530ac0 --- /dev/null +++ b/Build/source/texk/web2c/mplibdir/svgout.w @@ -0,0 +1,1314 @@ +% $Id: svgout.w 657 2008-10-08 09:48:49Z taco $ +% +% Copyright 2008 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 true 1 +@d false 0 +@d null_font 0 +@d null 0 +@d unity 0200000 /* $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 */ + +@c +#include "config.h" +#include <stdio.h> +#include <stdlib.h> +#include <string.h> +#include "mplib.h" +#include "mplibps.h" /* external header */ +#include "mpmp.h" /* internal header */ +#include "mppsout.h" /* internal header */ +#include "mpsvgout.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@>= +typedef struct svgout_data_struct { + @<Globals@> +} svgout_data_struct ; +@<Exported function headers@> + +@ @<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@>= +integer 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]=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,(char *)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; +int loc; +int 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,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 { + 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) { + 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 ) { + mp->dig[0]=(unsigned char)m; + } else { + mp->dig[0]=0; incr(n); + } + } + } + do { + mp->dig[k]=(unsigned char)(n % 10); n=n / 10; incr(k); + } while (n!=0); + /* print the digits */ + while ( k-->0 ){ + append_char('0'+mp->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) { + n=abs(n) % 100; + append_char('0'+(n / 10)); + append_char('0'+(n % 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_scaled (MP mp,scaled s) { + scaled delta; /* amount of allowable inaccuracy */ + if ( s<0 ) { + append_char('-'); + negate(s); /* print the sign, if negative */ + } + mp_svg_store_int(mp, s / unity); /* print the integer part */ + s=10*(s % unity)+5; + if ( s!=5 ) { + delta=10; + append_char('.'); + do { + if ( delta>unity ) + s=s+0100000-(delta / 2); /* round the final digit */ + append_char('0'+(s / unity)); + s=10*(s % unity); + delta=delta*10; + } while (s>delta); + } +} + + +@ 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, 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, 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, char *s, 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,scaled x, scaled y) { + mp_svg_store_scaled(mp, (x+mp->svg->dx)); + append_char(' '); + mp_svg_store_scaled(mp, (-(y+mp->svg->dy))); +} + +@ @c +void mp_svg_font_pair_out (MP mp,scaled x, scaled y) { + mp_svg_store_scaled(mp, (x)); + append_char(' '); + mp_svg_store_scaled(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. + +@d scaled_from_double(a) (scaled)((a)*65536.0) +@d double_from_scaled(a) (double)((a)/65536.0) + +@c +void mp_svg_trans_pair_out (MP mp, mp_pen_info *pen, scaled x, scaled y) { + double sx,sy, rx,ry, px, py, retval, divider; + sx = double_from_scaled(pen->sx); + sy = double_from_scaled(pen->sy); + rx = double_from_scaled(pen->rx); + ry = double_from_scaled(pen->ry); + px = double_from_scaled((x+mp->svg->dx)); + py = double_from_scaled((-(y+mp->svg->dy))); + divider = (sx*sy - rx*ry); + retval = (sy*px-ry*py)/divider; + mp_svg_store_scaled(mp, scaled_from_double(retval)); + append_char(' '); + retval = (sx*py-rx*px)/divider; + mp_svg_store_scaled(mp, scaled_from_double(retval)); +} + + + +@ @<Declarations@>= +static void mp_svg_pair_out (MP mp,scaled x, scaled 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) { + scaled t, tx, ty; + mp_svg_print(mp, "<?xml version=\"1.0\"?>"); + @<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_scaled(mp, tx); + mp_svg_attribute(mp,"width", mp->svg->buf); + mp_svg_reset_buf(mp); + mp_svg_store_scaled(mp, ty); + mp_svg_attribute(mp,"height", mp->svg->buf); + mp_svg_reset_buf(mp); + append_string("0 0 "); mp_svg_store_scaled(mp,tx); + append_char(' '); mp_svg_store_scaled(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_scaled(mp, hh->minx); append_char(' '); + mp_svg_store_scaled(mp, hh->miny); append_char(' '); + mp_svg_store_scaled(mp, hh->maxx); append_char(' '); + mp_svg_store_scaled(mp, hh->maxy); + mp_svg_print_buf(mp); + mp_svg_print(mp," -->"); +} + +@ @<Print the MetaPost version and time @>= +{ + char *s; + 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, mp_round_unscaled(mp, mp->internal[mp_year])); + append_char('.'); + mp_svg_store_dd(mp, mp_round_unscaled(mp, mp->internal[mp_month])); + append_char('.'); + mp_svg_store_dd(mp, mp_round_unscaled(mp, mp->internal[mp_day])); + append_char(':'); + t=mp_round_unscaled(mp, mp->internal[mp_time]); + mp_svg_store_dd(mp, t / 60); + mp_svg_store_dd(mp, t % 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; + int object_color_a, object_color_b, object_color_c, object_color_d ; + if (gr_type(p) == mp_fill_code) { + mp_fill_object *pq = (mp_fill_object *)p; + set_color_objects(pq); + } else if (gr_type(p) == mp_stroked_code) { + mp_stroked_object *pq = (mp_stroked_object *)p; + set_color_objects(pq); + } else { + mp_text_object *pq = (mp_text_object *)p; + set_color_objects(pq); + } + if ( object_color_model==mp_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_scaled(mp, (object_color_a * 100)); + append_char('%'); + append_char(','); + mp_svg_store_scaled(mp, (object_color_b * 100)); + append_char('%'); + append_char(','); + mp_svg_store_scaled(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 { + scaled tx, ty; + scaled sx, rx, ry, sy; + scaled ww; +} mp_pen_info; + + +@ (Re)discover the characteristics of an elliptical pen + +@<Declarations@>= +mp_pen_info *mp_svg_pen_info(MP mp, mp_knot *pp, mp_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 +@d aspect_default 1 + +@c +static scaled coord_range_x (mp_knot *h, scaled dz) { + scaled z; + scaled zlo = 0, zhi = 0; + mp_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 scaled coord_range_y (mp_knot *h, scaled dz) { + scaled z; + scaled zlo = 0, zhi = 0; + mp_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_knot *pp, mp_knot *p) { + scaled 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 = abs(gr_left_x(p) - gr_x_coord(p)); + wy = abs(gr_right_y(p) - gr_y_coord(p)); + } else { + wx = mp_pyth_add(mp, gr_left_x(p)-gr_x_coord(p), + gr_right_x(p)-gr_x_coord(p)); + wy = mp_pyth_add(mp, gr_left_y(p)-gr_y_coord(p), + gr_right_y(p)-gr_y_coord(p)); + } + 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 = mp_make_scaled(mp, pen->rx, pen->ww); + pen->ry = mp_make_scaled(mp, pen->ry, pen->ww); + pen->sx = mp_make_scaled(mp, pen->sx, pen->ww); + pen->sy = mp_make_scaled(mp, 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_knot *p, mp_knot *q) ; + + +@ +@d bend_tolerance 131 /* allow rounding error of $2\cdot10^{-3}$ */ + +@c +boolean mp_is_curved(mp_knot *p, mp_knot *q) { + scaled 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 ( abs(gr_right_x(p)-gr_x_coord(p)-d)<=bend_tolerance ) + if ( abs(gr_x_coord(q)-gr_left_x(q)-d)<=bend_tolerance ) { + d=gr_left_y(q)-gr_right_y(p); + if ( abs(gr_right_y(p)-gr_y_coord(p)-d)<=bend_tolerance ) + if ( abs(gr_y_coord(q)-gr_left_y(q)-d)<=bend_tolerance ) + return false; + } + return true; +} + + +@ @c +static void mp_svg_path_out (MP mp, mp_knot *h) { + mp_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_knot *h, mp_pen_info *pen) { + mp_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_print(mp, "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_knot *h) { + mp_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, sizeof(int *)); + memset(mp_chars, 0, (mp->font_max * 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) + +@c +void mp_svg_print_glyph_defs (MP mp, mp_edge_object *h) { + mp_graphic_object *p; /* object index */ + int k, l; /* general purpose indices */ + 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 ) { + l = gr_text_l(p); + if ((gr_type(p) == mp_text_code) && + (gr_font_n(p)!=null_font) && + (l>0) ) { + char *s = 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 */ + scaled ds,dx,sk; + ds =(mp->font_dsize[k]+8) / 16; + scale = (1/1000.0) * double_from_scaled(ds); + ds = scaled_from_double(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->extend != 0) { + dx = scaled_from_double(((double)f->extend / 1000.0) * scale); + } + if (f->slant != 0) { + sk = scaled_from_double(((double)f->slant / 1000.0) * 90); + } + } + mp_svg_open_starttag(mp,"g"); + append_string("scale("); + mp_svg_store_scaled(mp,dx); + append_char(','); + mp_svg_store_scaled(mp,ds); + append_char(')'); + if (sk!=0) { + append_string(" skewX("); + mp_svg_store_scaled(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,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,l); + if (ch != NULL) { + p = ch->body; + mp_svg_open_starttag(mp,"path"); + mp_svg_attribute(mp, "style", "fill-rule: evenodd;"); + while (p!=NULL) { + mp_svg_font_path_out(mp, gr_path_p((mp_fill_object *)p)); + p = gr_link(p); + } + 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) { + char *s, *fname; + int k; /* a character */ + int l; /* string length */ + boolean transformed ; + scaled ds; /* design size and scale factor for a text node */ + fname = mp->font_ps_name[gr_font_n(p)]; + s = 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_scaled(mp,gr_txx_val(p)); append_char(','); + mp_svg_store_scaled(mp,-gr_tyx_val(p)); append_char(','); + mp_svg_store_scaled(mp,-gr_txy_val(p)); append_char(','); + mp_svg_store_scaled(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 ) { + + scaled 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 = scaled_from_double((wd/100)); + if (charwd!=0) { + mp_svg_store_scaled(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; + mp_svg_store_scaled(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(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_scaled(mp,pen->sx); append_char(','); + mp_svg_store_scaled(mp,pen->rx); append_char(','); + mp_svg_store_scaled(mp,pen->ry); append_char(','); + mp_svg_store_scaled(mp,pen->sy); append_char(','); + mp_svg_store_scaled(mp,pen->tx); append_char(','); + mp_svg_store_scaled(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_scaled(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_scaled(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_scaled(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_knot *p, mp_graphic_object *h); + +@ @c +void mp_svg_fill_out (MP mp, mp_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<mp->last_fnum) ) + mp_read_psname_table(mp); + 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@>= +int mp_svg_ship_out (mp_edge_object *hh, int prologues) ; + +@ @c +int mp_svg_ship_out (mp_edge_object *hh, int prologues) { + return mp_svg_gr_ship_out (hh, prologues, (int)true); +} + +@ +@d do_write_prescript(a,b) { + if ( (gr_pre_script((b *)a))!=NULL ) { + mp_svg_print_nl (mp, gr_pre_script((b *)a)); + mp_svg_print_ln(mp); + } +} + +@<Write |pre_script| of |p|@>= +{ + if (gr_type(p)==mp_fill_code) { do_write_prescript(p,mp_fill_object); } + else if (gr_type(p)==mp_stroked_code) { do_write_prescript(p,mp_stroked_object); } + else if (gr_type(p)==mp_text_code) { do_write_prescript(p,mp_text_object); } +} + + +@ +@d do_write_postscript(a,b) { + if ( (gr_post_script((b *)a))!=NULL ) { + mp_svg_print_nl (mp, gr_post_script((b *)a)); + mp_svg_print_ln(mp); + } +} + +@<Write |post_script| of |p|@>= +{ + if (gr_type(p)==mp_fill_code) { do_write_postscript(p,mp_fill_object); } + else if (gr_type(p)==mp_stroked_code) { do_write_postscript(p,mp_stroked_object); } + else if (gr_type(p)==mp_text_code) { do_write_postscript(p,mp_text_object); } +} diff --git a/Build/source/texk/web2c/mplibdir/tfmin.w b/Build/source/texk/web2c/mplibdir/tfmin.w new file mode 100644 index 00000000000..d6361d767e7 --- /dev/null +++ b/Build/source/texk/web2c/mplibdir/tfmin.w @@ -0,0 +1,242 @@ +% $Id: mp.w 597 2008-07-03 15:35:34Z taco $ +% +% Copyright 2008 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 "config.h" +#include <stdio.h> +#include <stdlib.h> +#include <string.h> +#include "mplib.h" +#include "mpmp.h" /* internal header */ +@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. + +@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 */ + scaled z; /* used to compute the design size */ + fraction 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@>= +mp_print_err(mp,"Font "); +mp_print(mp, fname); +if ( file_opened ) mp_print(mp, " not usable: TFM file is bad"); +else mp_print(mp, " not usable: TFM file not found"); +help3("I wasn't able to read the size data for this font so this", + "`infont' operation won't produce anything. If the font name", + "is right, you might ask an expert to make a TFM file"); +if ( file_opened ) + mp->help_line[0]="is right, try asking an expert to fix the TFM file"; +mp_error(mp) + +@ @<Read data from |tfm_infile|; if there is no room, say so...@>= +@<Read the \.{TFM} size fields@>; +@<Use the size fields to allocate space in |font_info|@>; +@<Read the \.{TFM} header@>; +@<Read the character data and the width, height, and depth tables and + |goto done|@> + +@ A bad \.{TFM} file can be shorter than it claims to be. The code given here +might try to read past the end of the file if this happens. Changes will be +needed if it causes a system error to refer to |tfm_infile^| or call +|get_tfm_infile| when |eof(tfm_infile)| is true. For example, the definition +@^system dependencies@> +of |tfget| could be changed to +``|begin get(tfm_infile); if eof(tfm_infile) then goto bad_tfm; end|.'' + +@d tfget do { + size_t wanted=1; + 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+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); + memory_word *font_info; + font_info = mp_xmalloc (mp,(l+1),sizeof(memory_word)); + memset (font_info,0,sizeof(memory_word)*(l+1)); + memcpy (font_info,mp->font_info,sizeof(memory_word)*(mp->font_mem_size+1)); + 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-bc); +mp->width_base[n]=(int)(mp->next_fmem+ec-bc+1); +mp->height_base[n]=mp->width_base[n]+nw; +mp->depth_base[n]=mp->height_base[n]+nh; +mp->next_fmem=mp->next_fmem+whd_size; + + +@ @<Read the \.{TFM} header@>= +if ( tfm_lh<2 ) goto BAD_TFM; +tf_ignore(4); +tfget; read_two(z); +tfget; z=z*0400+tfbyte; +tfget; z=z*0400+tfbyte; /* now |z| is 16 times the design size */ +mp->font_dsize[n]=mp_take_fraction(mp, z,267432584); + /* times ${72\over72.27}2^{28}$ to convert from \TeX\ points */ +tf_ignore(4*(tfm_lh-2)) + +@ @<Read the character data and the width, height, and depth tables...@>= +ii=mp->width_base[n]; +i=mp->char_base[n]+bc; +while ( i<ii ) { + tfget; mp->font_info[i].qqqq.b0=qi(tfbyte); + tfget; h_and_d=tfbyte; + mp->font_info[i].qqqq.b1=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].cint=mp_take_fraction(mp, d*16,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 + + + + + + + + |