summaryrefslogtreecommitdiff
path: root/Build/source/texk/web2c/luatexdir/lua
diff options
context:
space:
mode:
authorTaco Hoekwater <taco@elvenkind.com>2009-03-27 15:30:55 +0000
committerTaco Hoekwater <taco@elvenkind.com>2009-03-27 15:30:55 +0000
commit178de0871d690556af74f3768c11bc812b07f347 (patch)
treea939c31adc90d6207848effaec87dd78ec00e658 /Build/source/texk/web2c/luatexdir/lua
parent4865b23b5199697829e4e6633f2f697b4634c462 (diff)
Import of luatex 0.37.0 (autoreconf has not been run yet!)
git-svn-id: svn://tug.org/texlive/trunk@12529 c570f23f-e606-0410-a88d-b1316a301751
Diffstat (limited to 'Build/source/texk/web2c/luatexdir/lua')
-rw-r--r--Build/source/texk/web2c/luatexdir/lua/lcallbacklib.c863
-rw-r--r--Build/source/texk/web2c/luatexdir/lua/lfontlib.c378
-rw-r--r--Build/source/texk/web2c/luatexdir/lua/limglib.c269
-rw-r--r--Build/source/texk/web2c/luatexdir/lua/lkpselib.c614
-rw-r--r--Build/source/texk/web2c/luatexdir/lua/llanglib.c401
-rw-r--r--Build/source/texk/web2c/luatexdir/lua/llualib.c486
-rw-r--r--Build/source/texk/web2c/luatexdir/lua/lmplib.c1273
-rw-r--r--Build/source/texk/web2c/luatexdir/lua/lnodelib.c4679
-rw-r--r--Build/source/texk/web2c/luatexdir/lua/loslibext.c1168
-rw-r--r--Build/source/texk/web2c/luatexdir/lua/lpdflib.c42
-rw-r--r--Build/source/texk/web2c/luatexdir/lua/lstatslib.c383
-rw-r--r--Build/source/texk/web2c/luatexdir/lua/ltexiolib.c231
-rw-r--r--Build/source/texk/web2c/luatexdir/lua/ltexlib.c2138
-rw-r--r--Build/source/texk/web2c/luatexdir/lua/ltokenlib.c437
-rw-r--r--Build/source/texk/web2c/luatexdir/lua/luainit.c902
-rw-r--r--Build/source/texk/web2c/luatexdir/lua/luanode.c401
-rw-r--r--Build/source/texk/web2c/luatexdir/lua/luastuff.c616
-rw-r--r--Build/source/texk/web2c/luatexdir/lua/luatex.c534
-rw-r--r--Build/source/texk/web2c/luatexdir/lua/luatoken.c1072
-rw-r--r--Build/source/texk/web2c/luatexdir/lua/mp.w26202
-rw-r--r--Build/source/texk/web2c/luatexdir/lua/psout.w5686
-rw-r--r--Build/source/texk/web2c/luatexdir/lua/texluac.c324
22 files changed, 9556 insertions, 39543 deletions
diff --git a/Build/source/texk/web2c/luatexdir/lua/lcallbacklib.c b/Build/source/texk/web2c/luatexdir/lua/lcallbacklib.c
index 09e94fda2e9..c85a1912e49 100644
--- a/Build/source/texk/web2c/luatexdir/lua/lcallbacklib.c
+++ b/Build/source/texk/web2c/luatexdir/lua/lcallbacklib.c
@@ -1,149 +1,175 @@
-/* $Id: lcallbacklib.c 1013 2008-02-14 00:09:02Z oneiros $ */
+/* lcallbacklib.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 General Public License as published by the Free
+ Software Foundation; either version 2 of the License, or (at your
+ option) any later version.
+
+ LuaTeX is distributed in the hope that it will be useful, but WITHOUT
+ ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
+ FITNESS FOR A PARTICULAR PURPOSE. See the GNU Lesser General Public
+ License for more details.
+
+ You should have received a copy of the GNU General Public License along
+ with LuaTeX; if not, see <http://www.gnu.org/licenses/>. */
#include "luatex-api.h"
#include <ptexlib.h>
-extern int do_run_callback (int special, char *values, va_list vl);
+static const char _svn_version[] =
+ "$Id: lcallbacklib.c 2064 2009-03-20 13:13:14Z taco $ $URL: http://scm.foundry.supelec.fr/svn/luatex/trunk/src/texk/web2c/luatexdir/lua/lcallbacklib.c $";
-int callback_set[total_callbacks] = {0};
+extern int do_run_callback(int special, char *values, va_list vl);
+extern int lua_traceback(lua_State * L);
+
+int callback_count = 0;
+int saved_callback_count = 0;
+
+int callback_set[total_callbacks] = { 0 };
static const char *const callbacknames[] = {
- "", /* empty on purpose */
- "find_write_file",
- "find_output_file",
- "find_image_file",
- "find_format_file",
- "find_read_file", "open_read_file",
- "find_ocp_file", "read_ocp_file",
- "find_vf_file", "read_vf_file",
- "find_data_file", "read_data_file",
- "find_font_file", "read_font_file",
- "find_map_file", "read_map_file",
- "find_enc_file", "read_enc_file",
- "find_type1_file", "read_type1_file",
- "find_truetype_file", "read_truetype_file",
- "find_opentype_file", "read_opentype_file",
- "find_sfd_file", "read_sfd_file",
- "find_pk_file", "read_pk_file",
- "show_error_hook",
- "process_input_buffer",
- "start_page_number", "stop_page_number",
- "start_run", "stop_run",
- "define_font",
- "token_filter",
- "pre_output_filter",
- "buildpage_filter",
- "hpack_filter", "vpack_filter",
- "char_exists",
- "hyphenate",
- "ligaturing",
- "kerning",
- "pre_linebreak_filter",
- "linebreak_filter",
- "post_linebreak_filter",
- NULL };
+ "", /* empty on purpose */
+ "find_write_file",
+ "find_output_file",
+ "find_image_file",
+ "find_format_file",
+ "find_read_file", "open_read_file",
+ "find_ocp_file", "read_ocp_file",
+ "find_vf_file", "read_vf_file",
+ "find_data_file", "read_data_file",
+ "find_font_file", "read_font_file",
+ "find_map_file", "read_map_file",
+ "find_enc_file", "read_enc_file",
+ "find_type1_file", "read_type1_file",
+ "find_truetype_file", "read_truetype_file",
+ "find_opentype_file", "read_opentype_file",
+ "find_sfd_file", "read_sfd_file",
+ "find_pk_file", "read_pk_file",
+ "show_error_hook",
+ "process_input_buffer",
+ "start_page_number", "stop_page_number",
+ "start_run", "stop_run",
+ "define_font",
+ "token_filter",
+ "pre_output_filter",
+ "buildpage_filter",
+ "hpack_filter", "vpack_filter",
+ "char_exists",
+ "hyphenate",
+ "ligaturing",
+ "kerning",
+ "pre_linebreak_filter",
+ "linebreak_filter",
+ "post_linebreak_filter",
+ "mlist_to_hlist",
+ NULL
+};
int callback_callbacks_id = 0;
-void
-get_lua_boolean (char *table, char *name, boolean *target) {
- int stacktop;
- stacktop = lua_gettop(Luas[0]);
- luaL_checkstack(Luas[0],2,"out of stack space");
- lua_getglobal(Luas[0],table);
- if (lua_istable(Luas[0],-1)) {
- lua_getfield(Luas[0],-1,name);
- if (lua_isboolean(Luas[0],-1)) {
- *target = (lua_toboolean(Luas[0],-1));
- } else if (lua_isnumber(Luas[0],-1)) {
- *target = (lua_tonumber(Luas[0],-1)==0 ? 0 : 1);
+void get_lua_boolean(char *table, char *name, boolean * target)
+{
+ int stacktop;
+ stacktop = lua_gettop(Luas);
+ luaL_checkstack(Luas, 2, "out of stack space");
+ lua_getglobal(Luas, table);
+ if (lua_istable(Luas, -1)) {
+ lua_getfield(Luas, -1, name);
+ if (lua_isboolean(Luas, -1)) {
+ *target = (lua_toboolean(Luas, -1));
+ } else if (lua_isnumber(Luas, -1)) {
+ *target = (lua_tonumber(Luas, -1) == 0 ? 0 : 1);
+ }
}
- }
- lua_settop(Luas[0],stacktop);
- return;
+ lua_settop(Luas, stacktop);
+ return;
}
-void
-get_saved_lua_boolean (int r, char *name, boolean *target) {
- int stacktop;
- stacktop = lua_gettop(Luas[0]);
- luaL_checkstack(Luas[0],2,"out of stack space");
- lua_rawgeti(Luas[0],LUA_REGISTRYINDEX,r);
- if (lua_istable(Luas[0],-1)) {
- lua_getfield(Luas[0],-1,name);
- if (lua_isboolean(Luas[0],-1)) {
- *target = lua_toboolean(Luas[0],-1);
- } else if (lua_isnumber(Luas[0],-1)) {
- *target = (lua_tonumber(Luas[0],-1)==0 ? 0 : 1);
- }
- }
- lua_settop(Luas[0],stacktop);
- return;
+void get_saved_lua_boolean(int r, char *name, boolean * target)
+{
+ int stacktop;
+ stacktop = lua_gettop(Luas);
+ luaL_checkstack(Luas, 2, "out of stack space");
+ lua_rawgeti(Luas, LUA_REGISTRYINDEX, r);
+ if (lua_istable(Luas, -1)) {
+ lua_getfield(Luas, -1, name);
+ if (lua_isboolean(Luas, -1)) {
+ *target = lua_toboolean(Luas, -1);
+ } else if (lua_isnumber(Luas, -1)) {
+ *target = (lua_tonumber(Luas, -1) == 0 ? 0 : 1);
+ }
+ }
+ lua_settop(Luas, stacktop);
+ return;
}
-void
-get_lua_number (char *table, char *name, integer *target) {
- int stacktop;
- stacktop = lua_gettop(Luas[0]);
- luaL_checkstack(Luas[0],2,"out of stack space");
- lua_getglobal(Luas[0],table);
- if (lua_istable(Luas[0],-1)) {
- lua_getfield(Luas[0],-1,name);
- if (lua_isnumber(Luas[0],-1)) {
- *target = lua_tonumber(Luas[0],-1);
+void get_lua_number(char *table, char *name, integer * target)
+{
+ int stacktop;
+ stacktop = lua_gettop(Luas);
+ luaL_checkstack(Luas, 2, "out of stack space");
+ lua_getglobal(Luas, table);
+ if (lua_istable(Luas, -1)) {
+ lua_getfield(Luas, -1, name);
+ if (lua_isnumber(Luas, -1)) {
+ *target = lua_tonumber(Luas, -1);
+ }
}
- }
- lua_settop(Luas[0],stacktop);
- return;
+ lua_settop(Luas, stacktop);
+ return;
}
-void
-get_saved_lua_number (int r, char *name, integer *target) {
- int stacktop;
- stacktop = lua_gettop(Luas[0]);
- luaL_checkstack(Luas[0],2,"out of stack space");
- lua_rawgeti(Luas[0],LUA_REGISTRYINDEX,r);
- if (lua_istable(Luas[0],-1)) {
- lua_getfield(Luas[0],-1,name);
- if (lua_isnumber(Luas[0],-1)) {
- *target = lua_tonumber(Luas[0],-1);
- }
- }
- lua_settop(Luas[0],stacktop);
- return;
+void get_saved_lua_number(int r, char *name, integer * target)
+{
+ int stacktop;
+ stacktop = lua_gettop(Luas);
+ luaL_checkstack(Luas, 2, "out of stack space");
+ lua_rawgeti(Luas, LUA_REGISTRYINDEX, r);
+ if (lua_istable(Luas, -1)) {
+ lua_getfield(Luas, -1, name);
+ if (lua_isnumber(Luas, -1)) {
+ *target = lua_tonumber(Luas, -1);
+ }
+ }
+ lua_settop(Luas, stacktop);
+ return;
}
-void
-get_lua_string (char *table, char *name, char **target) {
- int stacktop;
- stacktop = lua_gettop(Luas[0]);
- luaL_checkstack(Luas[0],2,"out of stack space");
- lua_getglobal(Luas[0],table);
- if (lua_istable(Luas[0],-1)) {
- lua_getfield(Luas[0],-1,name);
- if (lua_isstring(Luas[0],-1)) {
- *target = (char *)lua_tostring(Luas[0],-1);
+void get_lua_string(char *table, char *name, char **target)
+{
+ int stacktop;
+ stacktop = lua_gettop(Luas);
+ luaL_checkstack(Luas, 2, "out of stack space");
+ lua_getglobal(Luas, table);
+ if (lua_istable(Luas, -1)) {
+ lua_getfield(Luas, -1, name);
+ if (lua_isstring(Luas, -1)) {
+ *target = (char *) lua_tostring(Luas, -1);
+ }
}
- }
- lua_settop(Luas[0],stacktop);
- return;
+ lua_settop(Luas, stacktop);
+ return;
}
-void
-get_saved_lua_string (int r, char *name, char **target) {
- int stacktop;
- stacktop = lua_gettop(Luas[0]);
- luaL_checkstack(Luas[0],2,"out of stack space");
- lua_rawgeti(Luas[0],LUA_REGISTRYINDEX,r);
- if (lua_istable(Luas[0],-1)) {
- lua_getfield(Luas[0],-1,name);
- if (lua_isstring(Luas[0],-1)) {
- *target = (char *)lua_tostring(Luas[0],-1);
- }
- }
- lua_settop(Luas[0],stacktop);
- return;
+void get_saved_lua_string(int r, char *name, char **target)
+{
+ int stacktop;
+ stacktop = lua_gettop(Luas);
+ luaL_checkstack(Luas, 2, "out of stack space");
+ lua_rawgeti(Luas, LUA_REGISTRYINDEX, r);
+ if (lua_istable(Luas, -1)) {
+ lua_getfield(Luas, -1, name);
+ if (lua_isstring(Luas, -1)) {
+ *target = (char *) lua_tostring(Luas, -1);
+ }
+ }
+ lua_settop(Luas, stacktop);
+ return;
}
@@ -154,311 +180,340 @@ get_saved_lua_string (int r, char *name, char **target) {
#define CALLBACK_STRING 'S'
#define CALLBACK_CHARNUM 'c'
-int
-run_saved_callback (int r, char *name, char *values, ...) {
- va_list args;
- int ret = 0;
- lua_State *L = Luas[0];
- int stacktop = lua_gettop(L);
- va_start(args,values);
- luaL_checkstack(L,2,"out of stack space");
- lua_rawgeti(L,LUA_REGISTRYINDEX,r);
- lua_pushstring(L,name);
- lua_rawget(L,-2);
- if (lua_isfunction(L,-1)) {
- ret = do_run_callback(2,values,args);
- }
- va_end(args);
- lua_settop(L,stacktop);
- return ret;
+
+int run_saved_callback(int r, char *name, char *values, ...)
+{
+ va_list args;
+ int ret = 0;
+ lua_State *L = Luas;
+ int stacktop = lua_gettop(L);
+ va_start(args, values);
+ luaL_checkstack(L, 2, "out of stack space");
+ lua_rawgeti(L, LUA_REGISTRYINDEX, r);
+ lua_pushstring(L, name);
+ lua_rawget(L, -2);
+ if (lua_isfunction(L, -1)) {
+ saved_callback_count++;
+ callback_count++;
+ ret = do_run_callback(2, values, args);
+ }
+ va_end(args);
+ lua_settop(L, stacktop);
+ return ret;
}
-int
-run_and_save_callback (int i, char *values, ...) {
- va_list args;
- int ret = 0;
- lua_State *L = Luas[0];
- int stacktop = lua_gettop(L);
- va_start(args,values);
- luaL_checkstack(L,2,"out of stack space");
- lua_rawgeti(L,LUA_REGISTRYINDEX,callback_callbacks_id);
- lua_rawgeti(L,-1,i);
- if (lua_isfunction(L,-1)) {
- ret = do_run_callback(1,values,args);
- }
- va_end(args);
- if (ret>0) {
- ret = luaL_ref(L,LUA_REGISTRYINDEX);
- }
- lua_settop(L,stacktop);
- return ret;
+boolean get_callback(lua_State * L, int i)
+{
+ luaL_checkstack(L, 2, "out of stack space");
+ lua_rawgeti(L, LUA_REGISTRYINDEX, callback_callbacks_id);
+ lua_rawgeti(L, -1, i);
+ if (lua_isfunction(L, -1)) {
+ callback_count++;
+ return true;
+ } else {
+ return false;
+ }
+}
+
+int run_and_save_callback(int i, char *values, ...)
+{
+ va_list args;
+ int ret = 0;
+ lua_State *L = Luas;
+ int stacktop = lua_gettop(L);
+ va_start(args, values);
+ if (get_callback(L, i)) {
+ ret = do_run_callback(1, values, args);
+ }
+ va_end(args);
+ if (ret > 0) {
+ ret = luaL_ref(L, LUA_REGISTRYINDEX);
+ }
+ lua_settop(L, stacktop);
+ return ret;
}
-int
-run_callback (int i, char *values, ...) {
- va_list args;
- int ret = 0;
- lua_State *L = Luas[0];
- int stacktop = lua_gettop(L);
- va_start(args,values);
- luaL_checkstack(L,2,"out of stack space");
- lua_rawgeti(L,LUA_REGISTRYINDEX,callback_callbacks_id);
- lua_rawgeti(L,-1, i);
- if (lua_isfunction(L,-1)) {
- ret = do_run_callback(0,values,args);
- }
- va_end(args);
- lua_settop(L,stacktop);
- return ret;
+int run_callback(int i, char *values, ...)
+{
+ va_list args;
+ int ret = 0;
+ lua_State *L = Luas;
+ int stacktop = lua_gettop(L);
+ va_start(args, values);
+ if (get_callback(L, i)) {
+ ret = do_run_callback(0, values, args);
+ }
+ va_end(args);
+ lua_settop(L, stacktop);
+ return ret;
}
-int
-do_run_callback (int special, char *values, va_list vl) {
- int ret, len;
- int narg,nres;
- char *s;
- char cs;
- int *bufloc;
- char *ss = NULL;
- int retval = 0;
- lua_State *L = Luas[0];
- if (special==2) { /* copy the enclosing table */
- luaL_checkstack(L,1,"out of stack space");
- lua_pushvalue(L,-2);
- }
- for (narg = 0; *values; narg++) {
- luaL_checkstack(L,1,"out of stack space");
- switch (*values++) {
- case CALLBACK_CHARNUM: /* an ascii char! */
- cs = (char)va_arg(vl, int);
- lua_pushlstring(L,&cs, 1);
- break;
- case CALLBACK_STRING: /* C string */
- s = va_arg(vl, char *);
- lua_pushstring(L, s);
- break;
- case CALLBACK_INTEGER: /* int */
- lua_pushnumber(L, va_arg(vl, int));
- break;
- case CALLBACK_STRNUMBER: /* TeX string */
- s = makeclstring(va_arg(vl, int),&len);
- lua_pushlstring(L, s,len);
- break;
- case CALLBACK_BOOLEAN: /* boolean */
- lua_pushboolean(L, va_arg(vl, int));
- break;
- case CALLBACK_LINE: /* a buffer section, with implied start */
- lua_pushlstring(L, (char *)(buffer+first), va_arg(vl, int));
- break;
- case '-':
- narg--;
- break;
- case '>':
- goto ENDARGS;
- default :
- ;
+int do_run_callback(int special, char *values, va_list vl)
+{
+ int ret;
+ size_t len;
+ int narg, nres;
+ const char *s;
+ char cs;
+ int *bufloc;
+ char *ss = NULL;
+ int retval = 0;
+ lua_State *L = Luas;
+ if (special == 2) { /* copy the enclosing table */
+ luaL_checkstack(L, 1, "out of stack space");
+ lua_pushvalue(L, -2);
}
- }
- ENDARGS:
- nres = strlen(values);
- if (special==1) {
- nres++;
- }
- if (special==2) {
- narg++;
- }
- if(lua_pcall(L,narg,nres,0) != 0) {
- /* Can't be more precise here, could be called before
- * TeX initialization is complete
- */
- fprintf(stderr,"This went wrong: %s\n",lua_tostring(L,-1));
- error();
- return 0;
- };
- if (nres==0) {
- return 1;
- }
- nres = -nres;
- while (*values) {
- int b;
- switch (*values++) {
- case CALLBACK_BOOLEAN:
- if (!lua_isboolean(L,nres)) {
- fprintf(stderr,"Expected a boolean, not: %s\n", lua_typename(L,lua_type(L,nres)));
- goto EXIT;
- }
- b = lua_toboolean(L,nres);
- *va_arg(vl, boolean *) = (boolean)b;
- break;
- case CALLBACK_INTEGER:
- if (!lua_isnumber(L,nres)) {
- fprintf(stderr,"Expected a number, not: %s\n", lua_typename(L,lua_type(L,nres)));
- goto EXIT;
- }
- b = lua_tonumber(L,nres);
- *va_arg(vl, int *) = b;
- break;
- case CALLBACK_LINE: /* TeX line */
- if (!lua_isstring(L,nres)) {
- if (!lua_isnil(L,nres))
- fprintf(stderr,"Expected a string for (l), not: %s\n",
- lua_typename(L,lua_type(L,nres)));
- goto EXIT;
- }
- s = (char *)lua_tolstring(L,nres, (size_t *)&len);
- if (s!=NULL) { /* |len| can be zero */
- bufloc = va_arg(vl, int *);
- ret = *bufloc;
- check_buffer_overflow (ret+len);
- while (len--) {
- buffer[(*bufloc)++] = *s++;
- }
- while ((*bufloc)-1>ret && buffer[(*bufloc)-1] == ' ')
- (*bufloc)--;
- } else {
- bufloc = 0;
- }
- break;
- case CALLBACK_STRNUMBER: /* TeX string */
- if (!lua_isstring(L,nres)) {
- if (!lua_isnil(L,nres)) {
- fprintf(stderr,"Expected a string for (s), not: %s\n",
- lua_typename(L,lua_type(L,nres)));
- goto EXIT;
- }
- }
- s = (char *)lua_tolstring(L,nres,(size_t *)&len);
- if (s==NULL) /* |len| can be zero */
- *va_arg(vl, int *) = 0;
- else {
- *va_arg(vl, int *) = maketexlstring(s,len);
- }
- break;
- case CALLBACK_STRING: /* C string aka buffer */
- if (!lua_isstring(L,nres)) {
- if (!lua_isnil(L,nres)) {
- fprintf(stderr,"Expected a string for (S), not: %s\n",
- lua_typename(L,lua_type(L,nres)));
- goto EXIT;
- }
- }
- s = (char *)lua_tolstring(L,nres,(size_t *)&len);
-
- if (s==NULL) /* |len| can be zero */
- *va_arg(vl, int *) = 0;
- else {
- ss = xmalloc(len+1);
- (void)memcpy(ss,s,(len+1));
- *va_arg(vl, char **) = ss;
- }
- break;
- default:
- fprintf(stdout,"invalid return value type");
- goto EXIT;
+ ss = index(values, '>');
+ assert(ss);
+ luaL_checkstack(L, (ss - values + 1), "out of stack space");
+ ss = NULL;
+ for (narg = 0; *values; narg++) {
+ switch (*values++) {
+ case CALLBACK_CHARNUM: /* an ascii char! */
+ cs = (char) va_arg(vl, int);
+ lua_pushlstring(L, &cs, 1);
+ break;
+ case CALLBACK_STRING: /* C string */
+ s = va_arg(vl, char *);
+ lua_pushstring(L, s);
+ break;
+ case CALLBACK_INTEGER: /* int */
+ lua_pushnumber(L, va_arg(vl, int));
+ break;
+ case CALLBACK_STRNUMBER: /* TeX string */
+ s = makeclstring(va_arg(vl, int), &len);
+ lua_pushlstring(L, s, len);
+ break;
+ case CALLBACK_BOOLEAN: /* boolean */
+ lua_pushboolean(L, va_arg(vl, int));
+ break;
+ case CALLBACK_LINE: /* a buffer section, with implied start */
+ lua_pushlstring(L, (char *) (buffer + first), va_arg(vl, int));
+ break;
+ case '-':
+ narg--;
+ break;
+ case '>':
+ goto ENDARGS;
+ default:
+ ;
+ }
+ }
+ ENDARGS:
+ nres = strlen(values);
+ if (special == 1) {
+ nres++;
+ }
+ if (special == 2) {
+ narg++;
+ }
+ {
+ int i;
+ lua_active++;
+ i = lua_pcall(L, narg, nres, 0);
+ lua_active--;
+ /* lua_remove(L, base); *//* remove traceback function */
+ if (i != 0) {
+ /* Can't be more precise here, could be called before
+ * TeX initialization is complete
+ */
+ if (!log_opened) {
+ fprintf(stderr, "This went wrong: %s\n", lua_tostring(L, -1));
+ error();
+ } else {
+ lua_gc(L, LUA_GCCOLLECT, 0);
+ luatex_error(L, (i == LUA_ERRRUN ? 0 : 1));
+ }
+ return 0;
+ }
+ }
+ if (nres == 0) {
+ return 1;
+ }
+ nres = -nres;
+ while (*values) {
+ int b;
+ switch (*values++) {
+ case CALLBACK_BOOLEAN:
+ if (!lua_isboolean(L, nres)) {
+ fprintf(stderr, "Expected a boolean, not: %s\n",
+ lua_typename(L, lua_type(L, nres)));
+ goto EXIT;
+ }
+ b = lua_toboolean(L, nres);
+ *va_arg(vl, boolean *) = (boolean) b;
+ break;
+ case CALLBACK_INTEGER:
+ if (!lua_isnumber(L, nres)) {
+ fprintf(stderr, "Expected a number, not: %s\n",
+ lua_typename(L, lua_type(L, nres)));
+ goto EXIT;
+ }
+ b = lua_tonumber(L, nres);
+ *va_arg(vl, int *) = b;
+ break;
+ case CALLBACK_LINE: /* TeX line */
+ if (!lua_isstring(L, nres)) {
+ if (!lua_isnil(L, nres))
+ fprintf(stderr, "Expected a string for (l), not: %s\n",
+ lua_typename(L, lua_type(L, nres)));
+ goto EXIT;
+ }
+ s = lua_tolstring(L, nres, &len);
+ if (s != NULL) { /* |len| can be zero */
+ bufloc = va_arg(vl, int *);
+ if (len != 0) {
+ ret = *bufloc;
+ check_buffer_overflow(ret + len);
+ strncpy((char *) (buffer + ret), s, len);
+ *bufloc += len;
+ /* while (len--) { buffer[(*bufloc)++] = *s++; } */
+ while ((*bufloc) - 1 > ret && buffer[(*bufloc) - 1] == ' ')
+ (*bufloc)--;
+ }
+ } else {
+ bufloc = 0;
+ }
+ break;
+ case CALLBACK_STRNUMBER: /* TeX string */
+ if (!lua_isstring(L, nres)) {
+ if (!lua_isnil(L, nres)) {
+ fprintf(stderr, "Expected a string for (s), not: %s\n",
+ lua_typename(L, lua_type(L, nres)));
+ goto EXIT;
+ }
+ }
+ s = lua_tolstring(L, nres, &len);
+ if (s == NULL) /* |len| can be zero */
+ *va_arg(vl, int *) = 0;
+ else {
+ *va_arg(vl, int *) = maketexlstring(s, len);
+ }
+ break;
+ case CALLBACK_STRING: /* C string aka buffer */
+ if (!lua_isstring(L, nres)) {
+ if (!lua_isnil(L, nres)) {
+ fprintf(stderr, "Expected a string for (S), not: %s\n",
+ lua_typename(L, lua_type(L, nres)));
+ goto EXIT;
+ }
+ }
+ s = lua_tolstring(L, nres, &len);
+
+ if (s == NULL) /* |len| can be zero */
+ *va_arg(vl, int *) = 0;
+ else {
+ ss = xmalloc(len + 1);
+ (void) memcpy(ss, s, (len + 1));
+ *va_arg(vl, char **) = ss;
+ }
+ break;
+ default:
+ fprintf(stdout, "invalid return value type");
+ goto EXIT;
+ }
+ nres++;
}
- nres++;
- }
- retval = 1;
- EXIT:
- return retval;
+ retval = 1;
+ EXIT:
+ return retval;
}
-void
-destroy_saved_callback (int i) {
- luaL_unref(Luas[0],LUA_REGISTRYINDEX,i);
+void destroy_saved_callback(int i)
+{
+ luaL_unref(Luas, LUA_REGISTRYINDEX, i);
}
-static int callback_register (lua_State *L) {
- int cb;
- char *s;
- if (!lua_isstring(L,1) ||
- ((!lua_isfunction(L,2)) && !lua_isnil(L,2))) {
- lua_pushnil(L);
- lua_pushstring(L,"Invalid arguments to callback.register.");
- return 2;
- }
- s = (char *)lua_tostring(L,1);
- for(cb=0;cb<total_callbacks;cb++) {
- if (strcmp(callbacknames[cb],s)==0)
- break;
- }
- if (cb==total_callbacks) {
- lua_pushnil(L);
- lua_pushstring(L,"No such callback exists.");
- return 2;
- }
- if (lua_isfunction(L,2)) {
- callback_set[cb]=cb;
- } else {
- callback_set[cb]=0;
- }
- luaL_checkstack(L,2,"out of stack space");
- lua_rawgeti(L,LUA_REGISTRYINDEX,callback_callbacks_id); /* push the table */
- lua_pushvalue(L,2); /* the function or nil */
- lua_rawseti(L,-2,cb);
- lua_rawseti(L,LUA_REGISTRYINDEX,callback_callbacks_id);
- lua_pushnumber(L,cb);
- return 1;
+static int callback_register(lua_State * L)
+{
+ int cb;
+ char *s;
+ if (!lua_isstring(L, 1) || ((!lua_isfunction(L, 2)) && !lua_isnil(L, 2))) {
+ lua_pushnil(L);
+ lua_pushstring(L, "Invalid arguments to callback.register.");
+ return 2;
+ }
+ s = (char *) lua_tostring(L, 1);
+ for (cb = 0; cb < total_callbacks; cb++) {
+ if (strcmp(callbacknames[cb], s) == 0)
+ break;
+ }
+ if (cb == total_callbacks) {
+ lua_pushnil(L);
+ lua_pushstring(L, "No such callback exists.");
+ return 2;
+ }
+ if (lua_isfunction(L, 2)) {
+ callback_set[cb] = cb;
+ } else {
+ callback_set[cb] = 0;
+ }
+ luaL_checkstack(L, 2, "out of stack space");
+ lua_rawgeti(L, LUA_REGISTRYINDEX, callback_callbacks_id); /* push the table */
+ lua_pushvalue(L, 2); /* the function or nil */
+ lua_rawseti(L, -2, cb);
+ lua_rawseti(L, LUA_REGISTRYINDEX, callback_callbacks_id);
+ lua_pushnumber(L, cb);
+ return 1;
}
-static int callback_find (lua_State *L) {
- int cb;
- char * s;
- if (!lua_isstring(L,1)) {
- lua_pushnil(L);
- lua_pushstring(L,"Invalid arguments to callback.find.");
- return 2;
- }
- s = (char *)lua_tostring(L,1);
- for(cb=0;cb<total_callbacks;cb++) {
- if (strcmp(callbacknames[cb],s)==0)
- break;
- }
- if (cb==total_callbacks) {
- lua_pushnil(L);
- lua_pushstring(L,"No such callback exists.");
- return 2;
- }
- luaL_checkstack(L,2,"out of stack space");
- lua_rawgeti(L,LUA_REGISTRYINDEX,callback_callbacks_id); /* push the table */
- lua_rawgeti(L,-1,cb);
- return 1;
+static int callback_find(lua_State * L)
+{
+ int cb;
+ char *s;
+ if (!lua_isstring(L, 1)) {
+ lua_pushnil(L);
+ lua_pushstring(L, "Invalid arguments to callback.find.");
+ return 2;
+ }
+ s = (char *) lua_tostring(L, 1);
+ for (cb = 0; cb < total_callbacks; cb++) {
+ if (strcmp(callbacknames[cb], s) == 0)
+ break;
+ }
+ if (cb == total_callbacks) {
+ lua_pushnil(L);
+ lua_pushstring(L, "No such callback exists.");
+ return 2;
+ }
+ luaL_checkstack(L, 2, "out of stack space");
+ lua_rawgeti(L, LUA_REGISTRYINDEX, callback_callbacks_id); /* push the table */
+ lua_rawgeti(L, -1, cb);
+ return 1;
}
-static int callback_listf (lua_State *L) {
- int i;
- luaL_checkstack(L,3,"out of stack space");
- lua_newtable(L);
- for (i=1; callbacknames[i]; i++) {
- lua_pushstring(L,callbacknames[i]);
- if (callback_defined(i)) {
- lua_pushboolean(L,1);
- } else {
- lua_pushboolean(L,0);
+static int callback_listf(lua_State * L)
+{
+ int i;
+ luaL_checkstack(L, 3, "out of stack space");
+ lua_newtable(L);
+ for (i = 1; callbacknames[i]; i++) {
+ lua_pushstring(L, callbacknames[i]);
+ if (callback_defined(i)) {
+ lua_pushboolean(L, 1);
+ } else {
+ lua_pushboolean(L, 0);
+ }
+ lua_rawset(L, -3);
}
- lua_rawset(L,-3);
- }
- return 1;
+ return 1;
}
-static const struct luaL_reg callbacklib [] = {
- {"find", callback_find},
- {"register",callback_register},
- {"list", callback_listf},
- {NULL, NULL} /* sentinel */
+static const struct luaL_reg callbacklib[] = {
+ {"find", callback_find},
+ {"register", callback_register},
+ {"list", callback_listf},
+ {NULL, NULL} /* sentinel */
};
-int luaopen_callback (lua_State *L)
+int luaopen_callback(lua_State * L)
{
- luaL_register(L, "callback", callbacklib);
- luaL_checkstack(L,1,"out of stack space");
- lua_newtable(L);
- callback_callbacks_id = luaL_ref(L,LUA_REGISTRYINDEX);
- return 1;
+ luaL_register(L, "callback", callbacklib);
+ luaL_checkstack(L, 1, "out of stack space");
+ lua_newtable(L);
+ callback_callbacks_id = luaL_ref(L, LUA_REGISTRYINDEX);
+ return 1;
}
-
-
-
diff --git a/Build/source/texk/web2c/luatexdir/lua/lfontlib.c b/Build/source/texk/web2c/luatexdir/lua/lfontlib.c
index 4bb5252daa7..6dd698ffe0a 100644
--- a/Build/source/texk/web2c/luatexdir/lua/lfontlib.c
+++ b/Build/source/texk/web2c/luatexdir/lua/lfontlib.c
@@ -1,224 +1,246 @@
-/* $Id: lfontlib.c 1171 2008-04-16 13:56:53Z taco $ */
+/* lfontlib.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 General Public License as published by the Free
+ Software Foundation; either version 2 of the License, or (at your
+ option) any later version.
+
+ LuaTeX is distributed in the hope that it will be useful, but WITHOUT
+ ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
+ FITNESS FOR A PARTICULAR PURPOSE. See the GNU Lesser General Public
+ License for more details.
+
+ You should have received a copy of the GNU General Public License along
+ with LuaTeX; if not, see <http://www.gnu.org/licenses/>. */
#include "luatex-api.h"
#include <ptexlib.h>
#include "nodes.h"
+static const char _svn_version[] =
+ "$Id: lfontlib.c 1226 2008-05-02 16:11:02Z oneiros $ $URL: http://scm.foundry.supelec.fr/svn/luatex/trunk/src/texk/web2c/luatexdir/lua/lfontlib.c $";
+
/* this function is in vfovf.c for the moment */
-extern int make_vf_table(lua_State *L, char *name, scaled s);
-
-static int
-font_read_tfm (lua_State *L) {
- internalfontnumber f;
- scaled s;
- int k;
- char *cnom;
- if(lua_isstring(L, 1)) {
- cnom = (char *)lua_tostring(L, 1);
- if(lua_isnumber(L, 2)) {
- s = (integer)lua_tonumber(L,2);
- if (strlen(cnom)) {
- f = new_font();
- if (read_tfm_info(f, cnom, "", s)) {
- k = font_to_lua(L,f);
- delete_font(f);
- return k;
- } else {
- delete_font(f);
- lua_pushstring(L, "font loading failed");
- lua_error(L);
- }
- } else {
- lua_pushstring(L, "expected tfm name as first argument");
- lua_error(L);
- }
+extern int make_vf_table(lua_State * L, char *name, scaled s);
+
+static int font_read_tfm(lua_State * L)
+{
+ internalfontnumber f;
+ scaled s;
+ int k;
+ char *cnom;
+ if (lua_isstring(L, 1)) {
+ cnom = (char *) lua_tostring(L, 1);
+ if (lua_isnumber(L, 2)) {
+ s = (integer) lua_tonumber(L, 2);
+ if (strlen(cnom)) {
+ f = new_font();
+ if (read_tfm_info(f, cnom, "", s)) {
+ k = font_to_lua(L, f);
+ delete_font(f);
+ return k;
+ } else {
+ delete_font(f);
+ lua_pushstring(L, "font loading failed");
+ lua_error(L);
+ }
+ } else {
+ lua_pushstring(L, "expected tfm name as first argument");
+ lua_error(L);
+ }
+ } else {
+ lua_pushstring(L, "expected an integer size as second argument");
+ lua_error(L);
+ }
} else {
- lua_pushstring(L, "expected an integer size as second argument");
- lua_error(L);
+ lua_pushstring(L, "expected tfm name as first argument");
+ lua_error(L);
}
- } else {
- lua_pushstring(L, "expected tfm name as first argument");
- lua_error(L);
- }
- return 2; /* not reached */
+ return 2; /* not reached */
}
-static int
-font_read_vf (lua_State *L) {
- scaled s;
- char *cnom;
- if(lua_isstring(L, 1)) {
- cnom = (char *)lua_tostring(L, 1);
- if (strlen(cnom)) {
- if(lua_isnumber(L, 2)) {
- s = lua_tonumber(L,2);
- return make_vf_table(L,cnom,s);
- } else {
- lua_pushstring(L, "expected an integer size as second argument");
- lua_error(L);
- return 2;
- }
- }
- }
- lua_pushstring(L, "expected vf name as first argument");
- lua_error(L);
- return 2; /* not reached */
+static int font_read_vf(lua_State * L)
+{
+ scaled s;
+ char *cnom;
+ if (lua_isstring(L, 1)) {
+ cnom = (char *) lua_tostring(L, 1);
+ if (strlen(cnom)) {
+ if (lua_isnumber(L, 2)) {
+ s = lua_tonumber(L, 2);
+ return make_vf_table(L, cnom, s);
+ } else {
+ lua_pushstring(L,
+ "expected an integer size as second argument");
+ lua_error(L);
+ return 2;
+ }
+ }
+ }
+ lua_pushstring(L, "expected vf name as first argument");
+ lua_error(L);
+ return 2; /* not reached */
}
-static int
-tex_current_font (lua_State *L) {
- int i;
- i = (int)luaL_optinteger(L,1,0);
- if (i>0) {
- if (is_valid_font(i)) {
- zset_cur_font(i);
- return 0;
- } else {
- lua_pushstring(L, "expected a valid font id");
- lua_error(L);
- return 2; /* not reached */
- }
- } else {
- lua_pushnumber(L,get_cur_font());
- return 1;
- }
+static int tex_current_font(lua_State * L)
+{
+ int i;
+ i = (int) luaL_optinteger(L, 1, 0);
+ if (i > 0) {
+ if (is_valid_font(i)) {
+ zset_cur_font(i);
+ return 0;
+ } else {
+ lua_pushstring(L, "expected a valid font id");
+ lua_error(L);
+ return 2; /* not reached */
+ }
+ } else {
+ lua_pushnumber(L, get_cur_font());
+ return 1;
+ }
}
-static int
-tex_max_font (lua_State *L) {
- lua_pushnumber(L,max_font_id());
- return 1;
+static int tex_max_font(lua_State * L)
+{
+ lua_pushnumber(L, max_font_id());
+ return 1;
}
-static int
-tex_each_font_next (lua_State *L) {
- int i,m; /* id */
- m = lua_tonumber(L,1);
- i = lua_tonumber(L,2);
- i++;
- while(i<=m && !is_valid_font(i))
- i++;
- if (i>m) {
- lua_pushnil(L);
- return 1;
- } else {
- lua_pushnumber(L, i);
- font_to_lua (L, i);
- return 2;
- }
+static int tex_each_font_next(lua_State * L)
+{
+ int i, m; /* id */
+ m = lua_tonumber(L, 1);
+ i = lua_tonumber(L, 2);
+ i++;
+ while (i <= m && !is_valid_font(i))
+ i++;
+ if (i > m) {
+ lua_pushnil(L);
+ return 1;
+ } else {
+ lua_pushnumber(L, i);
+ font_to_lua(L, i);
+ return 2;
+ }
}
-static int
-tex_each_font (lua_State *L) {
- lua_pushcclosure(L, tex_each_font_next, 0);
- lua_pushnumber(L, max_font_id());
- lua_pushnumber(L, 0);
- return 3;
+static int tex_each_font(lua_State * L)
+{
+ lua_pushcclosure(L, tex_each_font_next, 0);
+ lua_pushnumber(L, max_font_id());
+ lua_pushnumber(L, 0);
+ return 3;
}
-static int
-frozenfont (lua_State *L) {
- int i;
- i = (int)luaL_checkinteger(L,1);
- if (i) {
- if (is_valid_font(i)) {
- if (font_touched(i) || font_used(i)) {
- lua_pushboolean(L,1);
- } else {
- lua_pushboolean(L,0);
- }
+static int frozenfont(lua_State * L)
+{
+ int i;
+ i = (int) luaL_checkinteger(L, 1);
+ if (i) {
+ if (is_valid_font(i)) {
+ if (font_touched(i) || font_used(i)) {
+ lua_pushboolean(L, 1);
+ } else {
+ lua_pushboolean(L, 0);
+ }
+ } else {
+ lua_pushnil(L);
+ }
+ return 1;
} else {
- lua_pushnil(L);
+ lua_pushstring(L, "expected an integer argument");
+ lua_error(L);
}
- return 1;
- } else {
- lua_pushstring(L, "expected an integer argument");
- lua_error(L);
- }
- return 0; /* not reached */
+ return 0; /* not reached */
}
-static int
-setfont (lua_State *L) {
- int i;
- i = (int)luaL_checkinteger(L,-2);
- if (i) {
- luaL_checktype(L,-1,LUA_TTABLE);
- if (is_valid_font(i)) {
- if (! (font_touched(i) || font_used(i))) {
- font_from_lua (L,i) ;
- } else {
- lua_pushstring(L, "that font has been accessed already, changing it is forbidden");
- lua_error(L);
- }
- } else {
- lua_pushstring(L, "that integer id is not a valid font");
- lua_error(L);
+static int setfont(lua_State * L)
+{
+ int i;
+ i = (int) luaL_checkinteger(L, -2);
+ if (i) {
+ luaL_checktype(L, -1, LUA_TTABLE);
+ if (is_valid_font(i)) {
+ if (!(font_touched(i) || font_used(i))) {
+ font_from_lua(L, i);
+ } else {
+ lua_pushstring(L,
+ "that font has been accessed already, changing it is forbidden");
+ lua_error(L);
+ }
+ } else {
+ lua_pushstring(L, "that integer id is not a valid font");
+ lua_error(L);
+ }
}
- }
- return 0;
+ return 0;
}
-static int
-deffont (lua_State *L) {
- int i;
- luaL_checktype(L,-1,LUA_TTABLE);
+static int deffont(lua_State * L)
+{
+ int i;
+ luaL_checktype(L, -1, LUA_TTABLE);
- i = new_font();
- if(font_from_lua (L,i)) {
- lua_pushnumber(L,i);
- return 1;
- } else {
- lua_pop(L,1); /* pop the broken table */
- delete_font(i);
- lua_pushstring(L, "font creation failed");
- lua_error(L);
- }
- return 0; /* not reached */
+ i = new_font();
+ if (font_from_lua(L, i)) {
+ lua_pushnumber(L, i);
+ return 1;
+ } else {
+ lua_pop(L, 1); /* pop the broken table */
+ delete_font(i);
+ lua_pushstring(L, "font creation failed");
+ lua_error(L);
+ }
+ return 0; /* not reached */
}
/* this returns the expected (!) next fontid. */
-static int
-nextfontid (lua_State *L) {
- int i = new_font();
- lua_pushnumber(L,i);
- delete_font(i);
- return 1;
+static int nextfontid(lua_State * L)
+{
+ int i = new_font();
+ lua_pushnumber(L, i);
+ delete_font(i);
+ return 1;
}
-static int
-getfont (lua_State *L) {
- int i;
- i = (int)luaL_checkinteger(L,-1);
- if (i && is_valid_font(i) && font_to_lua (L, i))
+static int getfont(lua_State * L)
+{
+ int i;
+ i = (int) luaL_checkinteger(L, -1);
+ if (i && is_valid_font(i) && font_to_lua(L, i))
+ return 1;
+ lua_pushnil(L);
return 1;
- lua_pushnil(L);
- return 1;
}
-static const struct luaL_reg fontlib [] = {
- {"read_tfm", font_read_tfm},
- {"read_vf", font_read_vf},
- {"current", tex_current_font},
- {"max", tex_max_font},
- {"each", tex_each_font},
- {"getfont", getfont},
- {"setfont", setfont},
- {"define", deffont},
- {"nextid", nextfontid},
- {"frozen", frozenfont},
- {NULL, NULL} /* sentinel */
+static const struct luaL_reg fontlib[] = {
+ {"read_tfm", font_read_tfm},
+ {"read_vf", font_read_vf},
+ {"current", tex_current_font},
+ {"max", tex_max_font},
+ {"each", tex_each_font},
+ {"getfont", getfont},
+ {"setfont", setfont},
+ {"define", deffont},
+ {"nextid", nextfontid},
+ {"frozen", frozenfont},
+ {NULL, NULL} /* sentinel */
};
-int luaopen_font (lua_State *L)
+int luaopen_font(lua_State * L)
{
- luaL_register(L, "font", fontlib);
- make_table(L,"fonts","getfont","setfont");
- return 1;
+ luaL_register(L, "font", fontlib);
+ make_table(L, "fonts", "getfont", "setfont");
+ return 1;
}
diff --git a/Build/source/texk/web2c/luatexdir/lua/limglib.c b/Build/source/texk/web2c/luatexdir/lua/limglib.c
index 8f3f70ec718..44b3a04712d 100644
--- a/Build/source/texk/web2c/luatexdir/lua/limglib.c
+++ b/Build/source/texk/web2c/luatexdir/lua/limglib.c
@@ -1,4 +1,21 @@
-/* $Id: limglib.c 1098 2008-03-09 10:28:19Z hhenkel $ */
+/* limglib.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 General Public License as published by the Free
+ Software Foundation; either version 2 of the License, or (at your
+ option) any later version.
+
+ LuaTeX is distributed in the hope that it will be useful, but WITHOUT
+ ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
+ FITNESS FOR A PARTICULAR PURPOSE. See the GNU Lesser General Public
+ License for more details.
+
+ You should have received a copy of the GNU General Public License along
+ with LuaTeX; if not, see <http://www.gnu.org/licenses/>. */
#include <stdio.h>
#include <string.h>
@@ -9,16 +26,18 @@
#include "../image/image.h"
#include "../luatex-api.h"
+static const char _svn_version[] =
+ "$Id: limglib.c 2064 2009-03-20 13:13:14Z taco $ $URL: http://scm.foundry.supelec.fr/svn/luatex/trunk/src/texk/web2c/luatexdir/lua/limglib.c $";
+
/**********************************************************************/
#ifdef DEBUG
-static void stackDump(lua_State * L, char *s)
+void stackDump(lua_State * L, char *s)
{
- int i;
- int top = lua_gettop(L);
+ int i, t, top = lua_gettop(L);
printf("\n=== stackDump <%s>: ", s);
- for (i = 1; i <= top; i++) { /* repeat for each level */
- int t = lua_type(L, i);
+ for (i = top; i >= 1; i--) { /* repeat for each level */
+ t = lua_type(L, i);
printf("%d: ", i);
switch (t) {
case LUA_TSTRING: /* strings */
@@ -42,10 +61,10 @@ static void stackDump(lua_State * L, char *s)
/**********************************************************************/
-typedef enum { P__ZERO, P_ATTR, P_COLORDEPTH, P_COLORSPACE, P_DEPTH, P_FILENAME,
- P_FILEPATH, P_HEIGHT, P_IMAGETYPE, P_INDEX, P_OBJNUM, P_PAGE, P_PAGEBOX,
- P_TOTALPAGES, P_TRANSFORM, P_WIDTH, P_XRES, P_XSIZE, P_YRES, P_YSIZE,
- P__SENTINEL
+typedef enum { P__ZERO, P_ATTR, P_BBOX, P_COLORDEPTH, P_COLORSPACE, P_DEPTH,
+ P_FILENAME, P_FILEPATH, P_HEIGHT, P_IMAGETYPE, P_INDEX, P_OBJNUM,
+ P_PAGE, P_PAGEBOX, P_TOTALPAGES, P_ROTATION, P_STREAM, P_TRANSFORM,
+ P_WIDTH, P_XRES, P_XSIZE, P_YRES, P_YSIZE, P__SENTINEL
} parm_idx;
typedef struct {
@@ -53,9 +72,10 @@ typedef struct {
parm_idx idx; /* index within img_parms array */
} parm_struct;
-parm_struct img_parms[] = {
+const parm_struct img_parms[] = {
{NULL, P__ZERO}, /* dummy; lua indices run from 1 */
{"attr", P_ATTR},
+ {"bbox", P_BBOX},
{"colordepth", P_COLORDEPTH},
{"colorspace", P_COLORSPACE},
{"depth", P_DEPTH},
@@ -68,6 +88,8 @@ parm_struct img_parms[] = {
{"page", P_PAGE},
{"pagebox", P_PAGEBOX},
{"pages", P_TOTALPAGES},
+ {"rotation", P_ROTATION},
+ {"stream", P_STREAM},
{"transform", P_TRANSFORM},
{"width", P_WIDTH},
{"xres", P_XRES},
@@ -77,8 +99,9 @@ parm_struct img_parms[] = {
{NULL, P__SENTINEL}
};
-#define imgtype_max 4
-const char *imgtype_s[] = { "none", "pdf", "png", "jpg", "jbig2", NULL };
+#define imgtype_max 5
+const char *imgtype_s[] =
+ { "none", "pdf", "png", "jpg", "jbig2", "stream", NULL };
#define pagebox_max 5
const char *pdfboxspec_s[] =
@@ -94,7 +117,7 @@ static void image_to_lua(lua_State * L, image * a)
lua_pushvalue(L, -1); /* k k u ... */
lua_gettable(L, LUA_ENVIRONINDEX); /* i? k u ... */
if (!lua_isnumber(L, -1)) /* !i k u ... */
- luaL_error(L, "image_to_lua not a valid image key: %s",
+ luaL_error(L, "image_to_lua(): %s is not a valid image key",
lua_tostring(L, -2));
i = lua_tointeger(L, -1); /* i k u ... */
lua_pop(L, 2); /* u ... */
@@ -148,11 +171,17 @@ static void image_to_lua(lua_State * L, image * a)
case P_TOTALPAGES:
lua_pushinteger(L, img_totalpages(d));
break;
- case P_XSIZE:
- lua_pushinteger(L, img_xsize(d));
+ case P_XSIZE: /* Modify by /Rotate only for output */
+ if ((img_rotation(d) & 1) == 0)
+ lua_pushinteger(L, img_xsize(d));
+ else
+ lua_pushinteger(L, img_ysize(d));
break;
- case P_YSIZE:
- lua_pushinteger(L, img_ysize(d));
+ case P_YSIZE: /* Modify by /Rotate only for output */
+ if ((img_rotation(d) & 1) == 0)
+ lua_pushinteger(L, img_ysize(d));
+ else
+ lua_pushinteger(L, img_xsize(d));
break;
case P_XRES:
lua_pushinteger(L, img_xres(d));
@@ -160,6 +189,9 @@ static void image_to_lua(lua_State * L, image * a)
case P_YRES:
lua_pushinteger(L, img_yres(d));
break;
+ case P_ROTATION:
+ lua_pushinteger(L, img_rotation(d));
+ break;
case P_COLORSPACE:
if (img_colorspace(d) == 0)
lua_pushnil(L);
@@ -175,7 +207,7 @@ static void image_to_lua(lua_State * L, image * a)
case P_IMAGETYPE:
j = img_type(d);
if (j >= 0 && j <= imgtype_max) {
- if (j == IMAGE_TYPE_NONE)
+ if (j == IMG_TYPE_NONE)
lua_pushnil(L);
else
lua_pushstring(L, imgtype_s[j]);
@@ -192,6 +224,27 @@ static void image_to_lua(lua_State * L, image * a)
} else
assert(0);
break;
+ case P_BBOX:
+ if (!img_is_bbox(d)) {
+ img_bbox(d)[0] = img_xorig(d);
+ img_bbox(d)[1] = img_yorig(d);
+ img_bbox(d)[2] = img_xorig(d) + img_xsize(d);
+ img_bbox(d)[3] = img_yorig(d) + img_ysize(d);
+ }
+ lua_newtable(L);
+ lua_pushinteger(L, 1);
+ lua_pushinteger(L, img_bbox(d)[0]);
+ lua_settable(L, -3);
+ lua_pushinteger(L, 2);
+ lua_pushinteger(L, img_bbox(d)[1]);
+ lua_settable(L, -3);
+ lua_pushinteger(L, 3);
+ lua_pushinteger(L, img_bbox(d)[2]);
+ lua_settable(L, -3);
+ lua_pushinteger(L, 4);
+ lua_pushinteger(L, img_bbox(d)[3]);
+ lua_settable(L, -3);
+ break;
case P_OBJNUM:
if (img_objnum(d) == 0)
lua_pushnil(L);
@@ -204,6 +257,14 @@ static void image_to_lua(lua_State * L, image * a)
else
lua_pushinteger(L, img_index(d));
break;
+ case P_STREAM:
+ if (img_type(d) != IMG_TYPE_PDFSTREAM || img_pdfstream_ptr(d) == NULL
+ || img_pdfstream_stream(d) == NULL
+ || strlen(img_pdfstream_stream(d)) == 0)
+ lua_pushnil(L);
+ else
+ lua_pushstring(L, img_pdfstream_stream(d));
+ break;
default:
assert(0);
} /* v u ... */
@@ -217,7 +278,7 @@ static void lua_to_image(lua_State * L, image * a)
lua_pushvalue(L, -2); /* k v k t ... */
lua_gettable(L, LUA_ENVIRONINDEX); /* i? v k t ... */
if (!lua_isnumber(L, -1)) /* !i v k t ... */
- luaL_error(L, "lua_to_image not a valid image key: %s",
+ luaL_error(L, "lua_to_image(): %s is not a valid image key",
lua_tostring(L, -3));
i = lua_tointeger(L, -1); /* i v k t ... */
lua_pop(L, 1); /* v k t ... */
@@ -277,6 +338,8 @@ static void lua_to_image(lua_State * L, image * a)
case P_FILENAME:
if (img_state(d) >= DICT_FILESCANNED)
luaL_error(L, "image.filename is now read-only");
+ if (img_type(d) == IMG_TYPE_PDFSTREAM)
+ luaL_error(L, "image.filename can't be used with image.stream");
if (lua_isstring(L, -1)) {
if (img_filename(d) != NULL)
xfree(img_filename(d));
@@ -331,12 +394,49 @@ static void lua_to_image(lua_State * L, image * a)
else
luaL_error(L, "image.pagebox needs string or nil value");
break;
+ case P_BBOX:
+ if (img_state(d) >= DICT_FILESCANNED)
+ luaL_error(L, "image.bbox is now read-only");
+ if (!lua_istable(L, -1))
+ luaL_error(L, "image.bbox needs table value");
+ if (lua_objlen(L, -1) != 4)
+ luaL_error(L, "image.bbox table must have exactly 4 elements");
+ for (i = 1; i <= 4; i++) { /* v k t ... */
+ lua_pushinteger(L, i); /* idx v k t ... */
+ lua_gettable(L, -2); /* int v k t ... */
+ if (lua_type(L, -1) == LUA_TNUMBER)
+ img_bbox(d)[i - 1] = lua_tointeger(L, -1);
+ else if (lua_type(L, -1) == LUA_TSTRING)
+ img_bbox(d)[i - 1] =
+ dimen_to_number(L, (char *) lua_tostring(L, -1));
+ else
+ luaL_error(L,
+ "image.bbox table needs integer value or dimension string elements");
+ lua_pop(L, 1); /* v k t ... */
+ }
+ img_set_bbox(d);
+ img_unset_scaled(a);
+ break;
+ case P_STREAM:
+ if (img_filename(d) != NULL)
+ luaL_error(L, "image.stream can't be used with image.filename");
+ if (img_state(d) >= DICT_FILESCANNED)
+ luaL_error(L, "image.stream is now read-only");
+ if (img_pdfstream_ptr(d) == NULL)
+ new_img_pdfstream_struct(d);
+ if (img_pdfstream_stream(d) != NULL)
+ xfree(img_pdfstream_stream(d));
+ img_pdfstream_stream(d) = xstrdup(lua_tostring(L, -1));
+ img_type(d) = IMG_TYPE_PDFSTREAM;
+ img_unset_scaled(a);
+ break;
case P_FILEPATH:
case P_TOTALPAGES:
case P_XSIZE:
case P_YSIZE:
case P_XRES:
case P_YRES:
+ case P_ROTATION:
case P_IMAGETYPE:
case P_OBJNUM:
case P_INDEX:
@@ -389,24 +489,24 @@ void copy_image(lua_State * L, lua_Number scale)
/**********************************************************************/
-static int l_new_image(lua_State * L)
+int l_new_image(lua_State * L)
{
image *a, **aa;
image_dict **add;
if (lua_gettop(L) > 1)
luaL_error(L, "img.new() needs maximum 1 argument");
- if (lua_gettop(L) == 1 && !lua_istable(L, 1))
+ if (lua_gettop(L) == 1 && !lua_istable(L, -1))
luaL_error(L, "img.new() needs table as optional argument"); /* (t) */
aa = (image **) lua_newuserdata(L, sizeof(image *)); /* i (t) */
luaL_getmetatable(L, TYPE_IMG); /* m i (t) */
lua_setmetatable(L, -2); /* i (t) */
a = *aa = new_image();
- add = (image_dict **) lua_newuserdata(L, sizeof(image_dict *)); /* ad i (t) */
+ add = (image_dict **) lua_newuserdata(L, sizeof(image_dict *)); /* ad i (t) */
luaL_getmetatable(L, TYPE_IMG_DICT); /* m ad i (t) */
lua_setmetatable(L, -2); /* ad i (t) */
img_dict(a) = *add = new_image_dict();
img_dictref(a) = luaL_ref(L, LUA_GLOBALSINDEX); /* i (t) */
- if (lua_gettop(L) != 1) { /* i t, else just i */
+ if (lua_gettop(L) == 2) { /* i t, else just i */
lua_insert(L, -2); /* t i */
lua_pushnil(L); /* n t i (1st key for iterator) */
while (lua_next(L, -2) != 0) { /* v k t i */
@@ -423,40 +523,62 @@ static int l_copy_image(lua_State * L)
if (lua_gettop(L) != 1)
luaL_error(L, "img.copy() needs exactly 1 argument");
if (lua_istable(L, 1))
- l_new_image(L); /* image --- if everything worked well */
+ (void) l_new_image(L); /* image --- if everything worked well */
else
- copy_image(L, 1.0); /* image */
+ (void) copy_image(L, 1.0); /* image */
return 1; /* image */
}
+static void read_scale_img(lua_State * L, image * a)
+{
+ image_dict *ad;
+ assert(a != NULL);
+ ad = img_dict(a);
+ assert(ad != NULL);
+ if (img_state(ad) == DICT_NEW) {
+ if (img_type(ad) == IMG_TYPE_PDFSTREAM)
+ check_pdfstream_dict(ad);
+ else {
+ /* check_pdfminorversion() should not be here, as it belongs
+ * to the output functions, and it is too early here to start
+ * already the PDF file only for image file scanning; but
+ * it's needed as several fixed_* parameters are used early,
+ * e. g. by read_png_info(). */
+ check_pdfminorversion();
+ read_img(ad, get_pdf_minor_version(),
+ get_pdf_inclusion_errorlevel());
+ img_unset_scaled(a);
+ }
+ }
+ fix_image_size(L, a);
+}
+
static int l_scan_image(lua_State * L)
{
image *a, **aa;
- image_dict *ad;
if (lua_gettop(L) != 1)
luaL_error(L, "img.scan() needs exactly 1 argument");
if (lua_istable(L, 1))
- l_new_image(L); /* image --- if everything worked well */
+ (void) l_new_image(L); /* image --- if everything worked well */
aa = (image **) luaL_checkudata(L, 1, TYPE_IMG); /* image */
a = *aa;
- ad = img_dict(a);
- if (img_state(ad) == DICT_NEW) {
- read_img(ad, get_pdf_minor_version(), get_pdf_inclusion_errorlevel());
- img_unset_scaled(a);
- }
- fix_image_size(L, a);
+ check_pdfoutput(maketexstring("img.scan()"), true);
+ flush_str(last_tex_string);
+ read_scale_img(L, a);
return 1; /* image */
}
-/* these should go into some header file... */
-#define obj_type_ximage 8
+/* DANGER! these should go into some header file... */
+#define obj_type_ximage 7
#define obj_aux(a) obj_tab[a].int4 /* auxiliary pointer */
#define obj_data_ptr obj_aux /* pointer to |pdf_mem| */
static halfword img_to_node(image * a, integer ref)
{
- image_dict *ad = img_dict(a);
+ image_dict *ad;
halfword n;
+ assert(a != NULL);
+ ad = img_dict(a);
assert(ad != NULL);
assert(img_objnum(ad) != 0);
n = new_node(whatsit_node, pdf_refximage_node);
@@ -467,44 +589,47 @@ static halfword img_to_node(image * a, integer ref)
return n;
}
-typedef enum { WR_WRITE, WR_IMMEDIATEWRITE, WR_NODE } wrtype_e;
+typedef enum { WR_WRITE, WR_IMMEDIATEWRITE, WR_NODE, WR_VF_IMG } wrtype_e;
const char *wrtype_s[] =
- { "img.write()", "img.immediatewrite()", "img.node()" };
+ { "img.write()", "img.immediatewrite()", "img.node()", "write vf image" };
extern void lua_nodelib_push_fast(lua_State * L, halfword n);
+static void setup_image(lua_State * L, image * a, wrtype_e writetype)
+{
+ image_dict *ad;
+ assert(a != NULL);
+ ad = img_dict(a);
+ check_pdfoutput(maketexstring(wrtype_s[writetype]), true);
+ flush_str(last_tex_string);
+ read_scale_img(L, a);
+ if (img_arrayidx(a) == -1)
+ img_arrayidx(a) = img_to_array(a); /* now a is read-only */
+ if (img_objnum(ad) == 0) { /* latest needed just before out_img() */
+ pdf_ximage_count++;
+ pdf_create_obj(obj_type_ximage, pdf_ximage_count);
+ img_objnum(ad) = obj_ptr;
+ img_index(ad) = pdf_ximage_count;
+ obj_data_ptr(obj_ptr) = img_arrayidx(a);
+ }
+}
+
static void write_image_or_node(lua_State * L, wrtype_e writetype)
{
image *a, **aa;
image_dict *ad;
halfword n;
- integer ref;
if (lua_gettop(L) != 1)
luaL_error(L, "%s needs exactly 1 argument", wrtype_s[writetype]);
if (lua_istable(L, 1))
- l_new_image(L); /* image --- if everything worked well */
+ (void) l_new_image(L); /* image --- if everything worked well */
aa = (image **) luaL_checkudata(L, 1, TYPE_IMG); /* image */
a = *aa;
ad = img_dict(a);
- assert(ad != NULL);
- if (img_state(ad) == DICT_NEW) {
- read_img(ad, get_pdf_minor_version(), get_pdf_inclusion_errorlevel());
- img_unset_scaled(a);
- }
- fix_image_size(L, a);
- check_pdfoutput(maketexstring(wrtype_s[writetype]), true);
- flush_str(last_tex_string);
- ref = img_to_array(a);
- if (img_objnum(ad) == 0) { /* not strictly needed here, could be delayed until out_image() */
- pdf_ximage_count++;
- pdf_create_obj(obj_type_ximage, pdf_ximage_count);
- img_objnum(ad) = obj_ptr;
- img_index(ad) = pdf_ximage_count;
- obj_data_ptr(obj_ptr) = ref;
- }
+ setup_image(L, a, writetype);
switch (writetype) {
case WR_WRITE:
- n = img_to_node(a, ref);
+ n = img_to_node(a, img_arrayidx(a));
new_tail_append(n);
break; /* image */
case WR_IMMEDIATEWRITE:
@@ -514,7 +639,7 @@ static void write_image_or_node(lua_State * L, wrtype_e writetype)
break; /* image */
case WR_NODE: /* image */
lua_pop(L, 1); /* - */
- n = img_to_node(a, ref);
+ n = img_to_node(a, img_arrayidx(a));
lua_nodelib_push_fast(L, n);
break; /* node */
default:
@@ -522,7 +647,6 @@ static void write_image_or_node(lua_State * L, wrtype_e writetype)
}
if (img_state(ad) < DICT_REFERED)
img_state(ad) = DICT_REFERED;
- img_set_refered(a); /* now image may not be freed by gc */
}
static int l_write_image(lua_State * L)
@@ -545,7 +669,7 @@ static int l_image_node(lua_State * L)
static int l_image_keys(lua_State * L)
{
- parm_struct *p = img_parms + 1;
+ const parm_struct *p = img_parms + 1;
if (lua_gettop(L) != 0)
luaL_error(L, "img.keys() goes without argument");
lua_newtable(L); /* t */
@@ -601,6 +725,21 @@ static const struct luaL_Reg imglib[] = {
};
/**********************************************************************/
+
+void vf_out_image(unsigned i)
+{
+ image *a, **aa;
+ lua_State *L = Luas; /* ... */
+ lua_rawgeti(L, LUA_GLOBALSINDEX, i); /* image ... */
+ aa = (image **) luaL_checkudata(L, -1, TYPE_IMG);
+ a = *aa;
+ setup_image(L, a, WR_VF_IMG); /* image ... */
+ assert(img_is_refered(a));
+ output_image(img_arrayidx(a));
+ lua_pop(L, 1); /* ... */
+}
+
+/**********************************************************************/
/* Metamethods for image */
static int m_img_get(lua_State * L)
@@ -635,8 +774,10 @@ static int m_img_mul(lua_State * L)
static int m_img_print(lua_State * L)
{
- image **aa = (image **) luaL_checkudata(L, 1, TYPE_IMG);
- image_dict *d = img_dict(*aa);
+ image **aa;
+ image_dict *d;
+ aa = (image **) luaL_checkudata(L, 1, TYPE_IMG);
+ d = img_dict(*aa);
if (img_pagename(d) != NULL && strlen(img_pagename(d)) != 0)
lua_pushfstring(L, "<img{filename=\"%s\", page=\"%s\"}>",
img_filename(d), img_pagename(d));
@@ -692,7 +833,7 @@ static const struct luaL_Reg img_dict_m[] = {
/**********************************************************************/
-void preset_environment(lua_State * L, parm_struct * p)
+void preset_environment(lua_State * L, const parm_struct * p)
{
int i;
lua_newtable(L); /* t */
diff --git a/Build/source/texk/web2c/luatexdir/lua/lkpselib.c b/Build/source/texk/web2c/luatexdir/lua/lkpselib.c
index 5ec4dfed869..23bd37e2f5f 100644
--- a/Build/source/texk/web2c/luatexdir/lua/lkpselib.c
+++ b/Build/source/texk/web2c/luatexdir/lua/lkpselib.c
@@ -1,4 +1,21 @@
-/* $Id: lkpselib.c 1061 2008-02-20 09:51:04Z taco $ */
+/* lkpselib.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 General Public License as published by the Free
+ Software Foundation; either version 2 of the License, or (at your
+ option) any later version.
+
+ LuaTeX is distributed in the hope that it will be useful, but WITHOUT
+ ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
+ FITNESS FOR A PARTICULAR PURPOSE. See the GNU Lesser General Public
+ License for more details.
+
+ You should have received a copy of the GNU General Public License along
+ with LuaTeX; if not, see <http://www.gnu.org/licenses/>. */
#include "luatex-api.h"
#include <ptexlib.h>
@@ -7,202 +24,298 @@
#include <kpathsea/tex-glyph.h>
#include <kpathsea/readable.h>
+static const char _svn_version[] =
+ "$Id: lkpselib.c 2093 2009-03-23 11:44:13Z taco $ $URL: http://scm.foundry.supelec.fr/svn/luatex/trunk/src/texk/web2c/luatexdir/lua/lkpselib.c $";
+
static const int filetypes[] = {
- kpse_gf_format,
- kpse_pk_format,
- kpse_any_glyph_format,
- kpse_tfm_format,
- kpse_afm_format,
- kpse_base_format,
- kpse_bib_format,
- kpse_bst_format,
- kpse_cnf_format,
- kpse_db_format,
- kpse_fmt_format,
- kpse_fontmap_format,
- kpse_mem_format,
- kpse_mf_format,
- kpse_mfpool_format,
- kpse_mft_format,
- kpse_mp_format,
- kpse_mppool_format,
- kpse_mpsupport_format,
- kpse_ocp_format,
- kpse_ofm_format,
- kpse_opl_format,
- kpse_otp_format,
- kpse_ovf_format,
- kpse_ovp_format,
- kpse_pict_format,
- kpse_tex_format,
- kpse_texdoc_format,
- kpse_texpool_format,
- kpse_texsource_format,
- kpse_tex_ps_header_format,
- kpse_troff_font_format,
- kpse_type1_format,
- kpse_vf_format,
- kpse_dvips_config_format,
- kpse_ist_format,
- kpse_truetype_format,
- kpse_type42_format,
- kpse_web2c_format,
- kpse_program_text_format,
- kpse_program_binary_format,
- kpse_miscfonts_format,
- kpse_web_format,
- kpse_cweb_format,
- kpse_enc_format,
- kpse_cmap_format,
- kpse_sfd_format,
- kpse_opentype_format,
- kpse_pdftex_config_format,
- kpse_lig_format,
- kpse_texmfscripts_format };
+ kpse_gf_format,
+ kpse_pk_format,
+ kpse_any_glyph_format,
+ kpse_tfm_format,
+ kpse_afm_format,
+ kpse_base_format,
+ kpse_bib_format,
+ kpse_bst_format,
+ kpse_cnf_format,
+ kpse_db_format,
+ kpse_fmt_format,
+ kpse_fontmap_format,
+ kpse_mem_format,
+ kpse_mf_format,
+ kpse_mfpool_format,
+ kpse_mft_format,
+ kpse_mp_format,
+ kpse_mppool_format,
+ kpse_mpsupport_format,
+ kpse_ocp_format,
+ kpse_ofm_format,
+ kpse_opl_format,
+ kpse_otp_format,
+ kpse_ovf_format,
+ kpse_ovp_format,
+ kpse_pict_format,
+ kpse_tex_format,
+ kpse_texdoc_format,
+ kpse_texpool_format,
+ kpse_texsource_format,
+ kpse_tex_ps_header_format,
+ kpse_troff_font_format,
+ kpse_type1_format,
+ kpse_vf_format,
+ kpse_dvips_config_format,
+ kpse_ist_format,
+ kpse_truetype_format,
+ kpse_type42_format,
+ kpse_web2c_format,
+ kpse_program_text_format,
+ kpse_program_binary_format,
+ kpse_miscfonts_format,
+ kpse_web_format,
+ kpse_cweb_format,
+ kpse_enc_format,
+ kpse_cmap_format,
+ kpse_sfd_format,
+ kpse_opentype_format,
+ kpse_pdftex_config_format,
+ kpse_lig_format,
+ kpse_texmfscripts_format,
+ kpse_lua_format
+};
static const char *const filetypenames[] = {
- "gf",
- "pk",
- "bitmap font",
- "tfm",
- "afm",
- "base",
- "bib",
- "bst",
- "cnf",
- "ls-R",
- "fmt",
- "map",
- "mem",
- "mf",
- "mfpool",
- "mft",
- "mp",
- "mppool",
- "MetaPost support",
- "ocp",
- "ofm",
- "opl",
- "otp",
- "ovf",
- "ovp",
- "graphic/figure",
- "tex",
- "TeX system documentation",
- "texpool",
- "TeX system sources",
- "PostScript header",
- "Troff fonts",
- "type1 fonts",
- "vf",
- "dvips config",
- "ist",
- "truetype fonts",
- "type42 fonts",
- "web2c files",
- "other text files",
- "other binary files",
- "misc fonts",
- "web",
- "cweb",
- "enc files",
- "cmap files",
- "subfont definition files",
- "opentype fonts",
- "pdftex config",
- "lig files",
- "texmfscripts",
- NULL };
+ "gf",
+ "pk",
+ "bitmap font",
+ "tfm",
+ "afm",
+ "base",
+ "bib",
+ "bst",
+ "cnf",
+ "ls-R",
+ "fmt",
+ "map",
+ "mem",
+ "mf",
+ "mfpool",
+ "mft",
+ "mp",
+ "mppool",
+ "MetaPost support",
+ "ocp",
+ "ofm",
+ "opl",
+ "otp",
+ "ovf",
+ "ovp",
+ "graphic/figure",
+ "tex",
+ "TeX system documentation",
+ "texpool",
+ "TeX system sources",
+ "PostScript header",
+ "Troff fonts",
+ "type1 fonts",
+ "vf",
+ "dvips config",
+ "ist",
+ "truetype fonts",
+ "type42 fonts",
+ "web2c files",
+ "other text files",
+ "other binary files",
+ "misc fonts",
+ "web",
+ "cweb",
+ "enc files",
+ "cmap files",
+ "subfont definition files",
+ "opentype fonts",
+ "pdftex config",
+ "lig files",
+ "texmfscripts",
+ "lua",
+ NULL
+};
+
+
+#define KPATHSEA_METATABLE "luatex_kpathsea"
/* set to 1 by the |program_name| function */
-int program_name_set = 0;
+int program_name_set = 0;
-#define TEST_PROGRAM_NAME_SET do { \
- if (! program_name_set) { \
+#define TEST_PROGRAM_NAME_SET do { \
+ if (! program_name_set) { \
lua_pushstring(L, "Please call kpse.set_program_name() before using the library"); \
- return lua_error(L); \
- } \
+ return lua_error(L); \
+ } \
} while (0)
-static int find_file (lua_State *L) {
- int i;
- char *st;
- int ftype = kpse_tex_format;
- int mexist = 0;
- TEST_PROGRAM_NAME_SET;
- if (!lua_isstring(L,1)) {
- lua_pushstring(L, "not a file name");
- lua_error(L);
- }
- st = (char *)lua_tostring(L,1);
- i = lua_gettop(L);
- while (i>1) {
- if (lua_isboolean (L,i)) {
- mexist = lua_toboolean (L,i);
- } else if (lua_isnumber (L,i)) {
- mexist = lua_tonumber (L,i) ;
- } else if (lua_isstring(L,i)) {
- int op = luaL_checkoption(L, i, NULL, filetypenames);
- ftype = filetypes[op];
+static int find_file(lua_State * L)
+{
+ int i;
+ char *st;
+ int ftype = kpse_tex_format;
+ int mexist = 0;
+ TEST_PROGRAM_NAME_SET;
+ if (!lua_isstring(L, 1)) {
+ lua_pushstring(L, "not a file name");
+ lua_error(L);
+ }
+ st = (char *) lua_tostring(L, 1);
+ i = lua_gettop(L);
+ while (i > 1) {
+ if (lua_isboolean(L, i)) {
+ mexist = lua_toboolean(L, i);
+ } else if (lua_isnumber(L, i)) {
+ mexist = lua_tonumber(L, i);
+ } else if (lua_isstring(L, i)) {
+ int op = luaL_checkoption(L, i, NULL, filetypenames);
+ ftype = filetypes[op];
+ }
+ i--;
+ }
+ if (ftype == kpse_pk_format ||
+ ftype == kpse_gf_format || ftype == kpse_any_glyph_format) {
+ /* ret.format, ret.name, ret.dpi */
+ kpse_glyph_file_type ret;
+ lua_pushstring(L, kpse_find_glyph(st, mexist, ftype, &ret));
+ } else {
+ if (mexist > 0)
+ mexist = 1;
+ if (mexist < 0)
+ mexist = 0;
+ lua_pushstring(L, kpse_find_file(st, ftype, mexist));
+ }
+ return 1;
+}
+
+
+static int lua_kpathsea_find_file(lua_State * L)
+{
+ int i;
+ int ftype = kpse_tex_format;
+ int mexist = 0;
+ kpathsea *kp = (kpathsea *)luaL_checkudata(L, 1, KPATHSEA_METATABLE);
+ char *st = (char *) luaL_checkstring(L, 2);
+ i = lua_gettop(L);
+ while (i > 2) {
+ if (lua_isboolean(L, i)) {
+ mexist = lua_toboolean(L, i);
+ } else if (lua_isnumber(L, i)) {
+ mexist = lua_tonumber(L, i);
+ } else if (lua_isstring(L, i)) {
+ int op = luaL_checkoption(L, i, NULL, filetypenames);
+ ftype = filetypes[op];
+ }
+ i--;
}
- i--;
- }
- if (ftype==kpse_pk_format ||
- ftype==kpse_gf_format ||
- ftype==kpse_any_glyph_format) {
- /* ret.format, ret.name, ret.dpi */
- kpse_glyph_file_type ret;
- lua_pushstring(L, kpse_find_glyph (st,mexist, ftype, &ret));
- } else {
- if (mexist>0)
- mexist = 1;
- if (mexist<0)
- mexist = 0;
- lua_pushstring(L, kpse_find_file (st,ftype,mexist));
- }
- return 1;
+ if (ftype == kpse_pk_format ||
+ ftype == kpse_gf_format || ftype == kpse_any_glyph_format) {
+ /* ret.format, ret.name, ret.dpi */
+ kpse_glyph_file_type ret;
+ lua_pushstring(L, kpathsea_find_glyph(*kp, st, mexist, ftype, &ret));
+ } else {
+ if (mexist > 0)
+ mexist = 1;
+ if (mexist < 0)
+ mexist = 0;
+ lua_pushstring(L, kpathsea_find_file(*kp, st, ftype, mexist));
+ }
+ return 1;
+
+}
+
+static int show_path(lua_State * L)
+{
+ int op = luaL_checkoption(L, -1, "tex", filetypenames);
+ int user_format = filetypes[op];
+ TEST_PROGRAM_NAME_SET;
+ if (!kpse_format_info[user_format].type) /* needed if arg was numeric */
+ kpse_init_format(user_format);
+ lua_pushstring(L, kpse_format_info[user_format].path);
+ return 1;
+}
+
+static int lua_kpathsea_show_path(lua_State * L)
+{
+ kpathsea *kp = (kpathsea *)luaL_checkudata(L, 1, KPATHSEA_METATABLE);
+ int op = luaL_checkoption(L, -1, "tex", filetypenames);
+ int user_format = filetypes[op];
+ if (!(*kp)->format_info[user_format].type) /* needed if arg was numeric */
+ kpathsea_init_format(*kp, user_format);
+ lua_pushstring(L, (*kp)->format_info[user_format].path);
+ return 1;
+}
+
+static int expand_path(lua_State * L)
+{
+ const char *st = luaL_checkstring(L, 1);
+ TEST_PROGRAM_NAME_SET;
+ lua_pushstring(L, kpse_path_expand(st));
+ return 1;
+}
+
+static int lua_kpathsea_expand_path(lua_State * L)
+{
+ kpathsea *kp = (kpathsea *)luaL_checkudata(L, 1, KPATHSEA_METATABLE);
+ const char *st = luaL_checkstring(L, 2);
+ lua_pushstring(L, kpathsea_path_expand(*kp, st));
+ return 1;
+}
+
+static int expand_braces(lua_State * L)
+{
+ const char *st = luaL_checkstring(L, 1);
+ TEST_PROGRAM_NAME_SET;
+ lua_pushstring(L, kpse_brace_expand(st));
+ return 1;
}
-static int show_path (lua_State *L) {
- int op = luaL_checkoption(L, -1, "tex", filetypenames);
- int user_format = filetypes[op];
- TEST_PROGRAM_NAME_SET;
- if (!kpse_format_info[user_format].type) /* needed if arg was numeric */
- kpse_init_format (user_format);
- lua_pushstring (L, kpse_format_info[user_format].path);
- return 1;
+static int lua_kpathsea_expand_braces(lua_State * L)
+{
+ kpathsea *kp = (kpathsea *)luaL_checkudata(L, 1, KPATHSEA_METATABLE);
+ const char *st = luaL_checkstring(L, 2);
+ lua_pushstring(L, kpathsea_brace_expand(*kp, st));
+ return 1;
}
-static int expand_path (lua_State *L) {
- const char *st = luaL_checkstring(L,1);
- TEST_PROGRAM_NAME_SET;
- lua_pushstring(L, kpse_path_expand(st));
- return 1;
+static int expand_var(lua_State * L)
+{
+ const char *st = luaL_checkstring(L, 1);
+ TEST_PROGRAM_NAME_SET;
+ lua_pushstring(L, kpse_var_expand(st));
+ return 1;
}
-static int expand_braces (lua_State *L) {
- const char *st = luaL_checkstring(L,1);
- TEST_PROGRAM_NAME_SET;
- lua_pushstring(L, kpse_brace_expand(st));
- return 1;
+static int lua_kpathsea_expand_var(lua_State * L)
+{
+ kpathsea *kp = (kpathsea *)luaL_checkudata(L, 1, KPATHSEA_METATABLE);
+ const char *st = luaL_checkstring(L, 2);
+ lua_pushstring(L, kpathsea_var_expand(*kp, st));
+ return 1;
}
-static int expand_var (lua_State *L) {
- const char *st = luaL_checkstring(L,1);
- TEST_PROGRAM_NAME_SET;
- lua_pushstring(L, kpse_var_expand(st));
- return 1;
+
+static int var_value(lua_State * L)
+{
+ const char *st = luaL_checkstring(L, 1);
+ TEST_PROGRAM_NAME_SET;
+ lua_pushstring(L, kpse_var_value(st));
+ return 1;
}
-static int var_value (lua_State *L) {
- const char *st = luaL_checkstring(L,1);
- TEST_PROGRAM_NAME_SET;
- lua_pushstring(L, kpse_var_value(st));
- return 1;
+static int lua_kpathsea_var_value(lua_State * L)
+{
+ kpathsea *kp = (kpathsea *)luaL_checkudata(L, 1, KPATHSEA_METATABLE);
+ const char *st = luaL_checkstring(L, 2);
+ lua_pushstring(L, kpathsea_var_value(*kp, st));
+ return 1;
}
+
/* Engine support is a bit of a problem, because we do not want
* to interfere with the normal format discovery of |luatex|.
* Current approach: run |os.setenv()| if you have to.
@@ -210,63 +323,122 @@ static int var_value (lua_State *L) {
extern int luainit;
-static int set_program_name (lua_State *L) {
- const char *exe_name = luaL_checkstring(L,1);
- const char *prog_name = luaL_optstring(L,2,exe_name);
- if (! program_name_set) {
- kpse_set_program_name(exe_name, prog_name);
- program_name_set = 1;
- } else {
- kpse_reset_program_name(prog_name);
- }
- /* fix up the texconfig entry */
- lua_checkstack(L,3);
- lua_getglobal(L,"texconfig");
- if (lua_istable(L,-1)) {
- lua_pushstring(L,"kpse_init");
- lua_pushboolean(L,0);
- lua_rawset(L,-3);
- }
- lua_pop(L,1);
- return 0;
+static int set_program_name(lua_State * L)
+{
+ const char *exe_name = luaL_checkstring(L, 1);
+ const char *prog_name = luaL_optstring(L, 2, exe_name);
+ if (!program_name_set) {
+ kpse_set_program_name(exe_name, prog_name);
+ program_name_set = 1;
+ } else {
+ kpse_reset_program_name(prog_name);
+ }
+ /* fix up the texconfig entry */
+ lua_checkstack(L, 3);
+ lua_getglobal(L, "texconfig");
+ if (lua_istable(L, -1)) {
+ lua_pushstring(L, "kpse_init");
+ lua_pushboolean(L, 0);
+ lua_rawset(L, -3);
+ }
+ lua_pop(L, 1);
+ return 0;
+}
+
+static int init_prog(lua_State * L)
+{
+ const char *prefix = luaL_checkstring(L, 1);
+ unsigned dpi = luaL_checkinteger(L, 2);
+ const char *mode = luaL_checkstring(L, 3);
+ const char *fallback = luaL_optstring(L, 4, NULL);
+ TEST_PROGRAM_NAME_SET;
+ kpse_init_prog(prefix, dpi, mode, fallback);
+ return 0;
}
-static int init_prog (lua_State *L) {
- const char *prefix = luaL_checkstring(L,1);
- unsigned dpi = luaL_checkinteger(L,2);
- const char *mode = luaL_checkstring(L,3);
- const char *fallback = luaL_optstring(L,4,NULL);
- TEST_PROGRAM_NAME_SET;
- kpse_init_prog(prefix,dpi,mode,fallback);
- return 0;
+static int lua_kpathsea_init_prog(lua_State * L)
+{
+ kpathsea *kp = (kpathsea *)luaL_checkudata(L, 1, KPATHSEA_METATABLE);
+ const char *prefix = luaL_checkstring(L, 2);
+ unsigned dpi = luaL_checkinteger(L, 3);
+ const char *mode = luaL_checkstring(L, 4);
+ const char *fallback = luaL_optstring(L, 5, NULL);
+ kpathsea_init_prog(*kp,prefix, dpi, mode, fallback);
+ return 0;
}
-static int readable_file (lua_State *L) {
- const char *name = luaL_checkstring(L,1);
- TEST_PROGRAM_NAME_SET;
- lua_pushstring(L,(char *)kpse_readable_file (name));
- return 1;
+static int readable_file(lua_State * L)
+{
+ const char *name = luaL_checkstring(L, 1);
+ TEST_PROGRAM_NAME_SET;
+ lua_pushstring(L, (char *) kpse_readable_file(name));
+ return 1;
}
+static int lua_kpathsea_readable_file(lua_State * L)
+{
+ kpathsea *kp = (kpathsea *)luaL_checkudata(L, 1, KPATHSEA_METATABLE);
+ const char *name = luaL_checkstring(L, 2);
+ lua_pushstring(L, (char *) kpathsea_readable_file(*kp,name));
+ return 1;
+}
-static const struct luaL_reg kpselib [] = {
- {"set_program_name", set_program_name},
- {"init_prog", init_prog},
- {"readable_file", readable_file},
- {"find_file", find_file},
- {"expand_path", expand_path},
- {"expand_var", expand_var},
- {"expand_braces",expand_braces},
- {"var_value",var_value},
- {"show_path",show_path},
- {NULL, NULL} /* sentinel */
-};
+static int lua_kpathsea_finish(lua_State * L)
+{
+ kpathsea *kp = (kpathsea *)luaL_checkudata(L, 1, KPATHSEA_METATABLE);
+ kpathsea_finish(*kp);
+ return 0;
+}
-int
-luaopen_kpse (lua_State *L)
+static int lua_kpathsea_new(lua_State * L)
{
- luaL_register(L,"kpse",kpselib);
- return 1;
+ kpathsea kpse = NULL;
+ kpathsea *kp = NULL;
+ char *argv = (char *)luaL_checkstring(L,1);
+ char *liar = (char *)luaL_optstring(L,2,argv);
+ kpse = kpathsea_new();
+ kpathsea_set_program_name(kpse, argv, liar);
+ kp = (kpathsea *)lua_newuserdata(L, sizeof(kpathsea *));
+ *kp = kpse;
+ luaL_getmetatable(L, KPATHSEA_METATABLE);
+ lua_setmetatable(L, -2);
+ return 1;
}
+static const struct luaL_reg kpselib_m[] = {
+ {"__gc", lua_kpathsea_finish },
+ {"init_prog", lua_kpathsea_init_prog },
+ {"readable_file", lua_kpathsea_readable_file },
+ {"find_file", lua_kpathsea_find_file },
+ {"expand_path", lua_kpathsea_expand_path },
+ {"expand_var", lua_kpathsea_expand_var },
+ {"expand_braces", lua_kpathsea_expand_braces },
+ {"var_value", lua_kpathsea_var_value },
+ {"show_path", lua_kpathsea_show_path },
+ {NULL, NULL} /* sentinel */
+};
+
+static const struct luaL_reg kpselib_l[] = {
+ {"new", lua_kpathsea_new },
+ {"set_program_name", set_program_name },
+ {"init_prog", init_prog },
+ {"readable_file", readable_file },
+ {"find_file", find_file },
+ {"expand_path", expand_path },
+ {"expand_var", expand_var },
+ {"expand_braces", expand_braces },
+ {"var_value", var_value },
+ {"show_path", show_path },
+ {NULL, NULL} /* sentinel */
+};
+
+int luaopen_kpse(lua_State * L)
+{
+ luaL_newmetatable(L, KPATHSEA_METATABLE);
+ lua_pushvalue(L, -1);
+ lua_setfield(L, -2,"__index");
+ luaL_register(L, NULL, kpselib_m);
+ luaL_register(L, "kpse", kpselib_l);
+ return 1;
+}
diff --git a/Build/source/texk/web2c/luatexdir/lua/llanglib.c b/Build/source/texk/web2c/luatexdir/lua/llanglib.c
index a5227afa1a0..6aa634525b5 100644
--- a/Build/source/texk/web2c/luatexdir/lua/llanglib.c
+++ b/Build/source/texk/web2c/luatexdir/lua/llanglib.c
@@ -1,222 +1,275 @@
-/*
-Copyright (c) 2007 Taco Hoekwater <taco@latex.org>
+/* llanglib.c
+
+ Copyright 2006-2008 Taco Hoekwater <taco@luatex.org>
-This file is part of luatex.
+ This file is part of LuaTeX.
-luatex is free software; you can redistribute it and/or modify
-it under the terms of the GNU General Public License as published by
-the Free Software Foundation; either version 2 of the License, or
-(at your option) any later version.
+ LuaTeX is free software; you can redistribute it and/or modify it under
+ the terms of the GNU General Public License as published by the Free
+ Software Foundation; either version 2 of the License, or (at your
+ option) any later version.
-luatex is distributed in the hope that it will be useful,
-but WITHOUT ANY WARRANTY; without even the implied warranty of
-MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-GNU General Public License for more details.
+ 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 General Public License
-along with luatex; if not, write to the Free Software
-Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
-
-This is llanglib.c
-*/
+ You should have received a copy of the GNU General Public License along
+ with LuaTeX; if not, see <http://www.gnu.org/licenses/>. */
#include "luatex-api.h"
#include <ptexlib.h>
#include "nodes.h"
+static const char _svn_version[] =
+ "$Id: llanglib.c 1594 2008-11-28 13:32:48Z oneiros $ $URL: http://scm.foundry.supelec.fr/svn/luatex/trunk/src/texk/web2c/luatexdir/lua/llanglib.c $";
+
#define LANG_METATABLE "luatex.lang"
#define check_islang(L,b) (struct tex_language **)luaL_checkudata(L,b,LANG_METATABLE)
-extern halfword *check_isnode (lua_State *L, int ud) ;
+extern halfword *check_isnode(lua_State * L, int ud);
-static int
-lang_new (lua_State *L) {
- struct tex_language **lang;
- if (lua_gettop(L)==0) {
- lang = lua_newuserdata(L, sizeof(struct tex_language *));
- *lang = new_language();
- if (!*lang) {
- lua_pushstring(L,"lang.new(): no room for a new language");
- return lua_error(L);
+static int lang_new(lua_State * L)
+{
+ struct tex_language **lang;
+ if (lua_gettop(L) == 0) {
+ lang = lua_newuserdata(L, sizeof(struct tex_language *));
+ *lang = new_language(-1);
+ if (!*lang) {
+ lua_pushstring(L, "lang.new(): no room for a new language");
+ return lua_error(L);
+ }
+ } else {
+ lang = lua_newuserdata(L, sizeof(struct tex_language *));
+ *lang = get_language(lua_tonumber(L, 1));
+ if (!*lang) {
+ lua_pushfstring(L, "lang.new(%d): undefined language",
+ lua_tonumber(L, 1));
+ return lua_error(L);
+ }
}
- } else {
- lang = lua_newuserdata(L, sizeof(struct tex_language *));
- *lang = get_language(lua_tonumber(L,1));
- }
- luaL_getmetatable(L,LANG_METATABLE);
- lua_setmetatable(L,-2);
- return 1;
+ luaL_getmetatable(L, LANG_METATABLE);
+ lua_setmetatable(L, -2);
+ return 1;
}
-static int
-lang_id (lua_State *L) {
- struct tex_language **lang_ptr;
- lang_ptr = check_islang(L,1);
- lua_pushnumber(L,(*lang_ptr)->id);
- return 1;
+static int lang_id(lua_State * L)
+{
+ struct tex_language **lang_ptr;
+ lang_ptr = check_islang(L, 1);
+ lua_pushnumber(L, (*lang_ptr)->id);
+ return 1;
}
-static int
-lang_patterns (lua_State *L) {
- struct tex_language **lang_ptr;
- lang_ptr = check_islang(L,1);
- if (lua_gettop(L)!=1) {
- if (!lua_isstring(L,2)) {
- lua_pushstring(L,"lang.patterns(): argument should be a string");
- return lua_error(L);
- }
- load_patterns(*lang_ptr, (unsigned char *)lua_tostring(L,2));
- return 0;
- } else {
- if ((*lang_ptr)->patterns!=NULL) {
- lua_pushstring(L,(char *)hnj_serialize((*lang_ptr)->patterns));
- } else {
- lua_pushnil(L);
- }
- return 1;
- }
+static int lang_patterns(lua_State * L)
+{
+ struct tex_language **lang_ptr;
+ lang_ptr = check_islang(L, 1);
+ if (lua_gettop(L) != 1) {
+ if (!lua_isstring(L, 2)) {
+ lua_pushstring(L, "lang.patterns(): argument should be a string");
+ return lua_error(L);
+ }
+ load_patterns(*lang_ptr, (unsigned char *) lua_tostring(L, 2));
+ return 0;
+ } else {
+ if ((*lang_ptr)->patterns != NULL) {
+ lua_pushstring(L, (char *) hnj_serialize((*lang_ptr)->patterns));
+ } else {
+ lua_pushnil(L);
+ }
+ return 1;
+ }
}
-static int
-lang_clear_patterns (lua_State *L) {
- struct tex_language **lang_ptr;
- lang_ptr = check_islang(L,1);
- clear_patterns(*lang_ptr);
- return 0;
+static int lang_clear_patterns(lua_State * L)
+{
+ struct tex_language **lang_ptr;
+ lang_ptr = check_islang(L, 1);
+ clear_patterns(*lang_ptr);
+ return 0;
}
-static int
-lang_hyphenation (lua_State *L) {
- struct tex_language **lang_ptr;
- lang_ptr = check_islang(L,1);
- if (lua_gettop(L)!=1) {
- if(!lua_isstring(L,2)) {
- lua_pushstring(L,"lang.hyphenation(): argument should be a string");
- return lua_error(L);
- }
- load_hyphenation(*lang_ptr,(unsigned char *)lua_tostring(L,2));
- return 0;
- } else {
- if ((*lang_ptr)->exceptions!=0) {
- lua_pushstring(L,exception_strings(*lang_ptr));
- } else {
- lua_pushnil(L);
- }
- return 1;
- }
+static int lang_hyphenation(lua_State * L)
+{
+ struct tex_language **lang_ptr;
+ lang_ptr = check_islang(L, 1);
+ if (lua_gettop(L) != 1) {
+ if (!lua_isstring(L, 2)) {
+ lua_pushstring(L,
+ "lang.hyphenation(): argument should be a string");
+ return lua_error(L);
+ }
+ load_hyphenation(*lang_ptr, (unsigned char *) lua_tostring(L, 2));
+ return 0;
+ } else {
+ if ((*lang_ptr)->exceptions != 0) {
+ lua_pushstring(L, exception_strings(*lang_ptr));
+ } else {
+ lua_pushnil(L);
+ }
+ return 1;
+ }
}
-static int
-lang_pre_hyphen_char (lua_State *L) {
- struct tex_language **lang_ptr;
- lang_ptr = check_islang(L,1);
- if (lua_gettop(L)!=1) {
- if(!lua_isnumber(L,2)) {
- lua_pushstring(L,"lang.prehyphenchar(): argument should be a character number");
- return lua_error(L);
- }
- (*lang_ptr)->pre_hyphen_char = lua_tonumber(L,2);
- return 0;
- } else {
- lua_pushnumber(L,(*lang_ptr)->pre_hyphen_char);
- return 1;
- }
+static int lang_pre_hyphen_char(lua_State * L)
+{
+ struct tex_language **lang_ptr;
+ lang_ptr = check_islang(L, 1);
+ if (lua_gettop(L) != 1) {
+ if (!lua_isnumber(L, 2)) {
+ lua_pushstring(L,
+ "lang.prehyphenchar(): argument should be a character number");
+ return lua_error(L);
+ }
+ (*lang_ptr)->pre_hyphen_char = lua_tonumber(L, 2);
+ return 0;
+ } else {
+ lua_pushnumber(L, (*lang_ptr)->pre_hyphen_char);
+ return 1;
+ }
}
-static int
-lang_post_hyphen_char (lua_State *L) {
- struct tex_language **lang_ptr;
- lang_ptr = check_islang(L,1);
- if (lua_gettop(L)!=1) {
- if(!lua_isnumber(L,2)) {
- lua_pushstring(L,"lang.posthyphenchar(): argument should be a character number");
- return lua_error(L);
- }
- (*lang_ptr)->post_hyphen_char = lua_tonumber(L,2);
- return 0;
- } else {
- lua_pushnumber(L,(*lang_ptr)->post_hyphen_char);
- return 1;
- }
+static int lang_post_hyphen_char(lua_State * L)
+{
+ struct tex_language **lang_ptr;
+ lang_ptr = check_islang(L, 1);
+ if (lua_gettop(L) != 1) {
+ if (!lua_isnumber(L, 2)) {
+ lua_pushstring(L,
+ "lang.posthyphenchar(): argument should be a character number");
+ return lua_error(L);
+ }
+ (*lang_ptr)->post_hyphen_char = lua_tonumber(L, 2);
+ return 0;
+ } else {
+ lua_pushnumber(L, (*lang_ptr)->post_hyphen_char);
+ return 1;
+ }
}
-static int
-lang_clear_hyphenation (lua_State *L) {
- struct tex_language **lang_ptr;
- lang_ptr = check_islang(L,1);
- clear_hyphenation(*lang_ptr);
- return 0;
+
+static int lang_pre_exhyphen_char(lua_State * L)
+{
+ struct tex_language **lang_ptr;
+ lang_ptr = check_islang(L, 1);
+ if (lua_gettop(L) != 1) {
+ if (!lua_isnumber(L, 2)) {
+ lua_pushstring(L,
+ "lang.preexhyphenchar(): argument should be a character number");
+ return lua_error(L);
+ }
+ (*lang_ptr)->pre_exhyphen_char = lua_tonumber(L, 2);
+ return 0;
+ } else {
+ lua_pushnumber(L, (*lang_ptr)->pre_exhyphen_char);
+ return 1;
+ }
}
+static int lang_post_exhyphen_char(lua_State * L)
+{
+ struct tex_language **lang_ptr;
+ lang_ptr = check_islang(L, 1);
+ if (lua_gettop(L) != 1) {
+ if (!lua_isnumber(L, 2)) {
+ lua_pushstring(L,
+ "lang.postexhyphenchar(): argument should be a character number");
+ return lua_error(L);
+ }
+ (*lang_ptr)->post_exhyphen_char = lua_tonumber(L, 2);
+ return 0;
+ } else {
+ lua_pushnumber(L, (*lang_ptr)->post_exhyphen_char);
+ return 1;
+ }
+}
+
+
+static int lang_clear_hyphenation(lua_State * L)
+{
+ struct tex_language **lang_ptr;
+ lang_ptr = check_islang(L, 1);
+ clear_hyphenation(*lang_ptr);
+ return 0;
+}
-static int
-do_lang_clean (lua_State *L) {
- char *cleaned;
- if (!lua_isstring(L,1)) {
- lua_pushstring(L,"lang.clean(): argument should be a string");
- return lua_error(L);
- }
- (void)clean_hyphenation((char *)lua_tostring(L,1),&cleaned);
- lua_pushstring(L,cleaned);
- return 1;
+
+static int do_lang_clean(lua_State * L)
+{
+ char *cleaned;
+ if (!lua_isstring(L, 1)) {
+ lua_pushstring(L, "lang.clean(): argument should be a string");
+ return lua_error(L);
+ }
+ (void) clean_hyphenation((char *) lua_tostring(L, 1), &cleaned);
+ lua_pushstring(L, cleaned);
+ return 1;
}
-static int
-do_lang_hyphenate (lua_State *L) {
- halfword *h,*t;
- h = check_isnode(L,1);
- if (lua_isuserdata(L,2)) {
- t = check_isnode(L,2);
- lua_pop(L,1);
- } else {
- t = h;
- while (vlink(*t)!=null)
- *t = vlink(*t);
- }
- hnj_hyphenation(*h,*t);
- lua_pushboolean(L,1);
- return 1;
+static int do_lang_hyphenate(lua_State * L)
+{
+ halfword *h, *t;
+ h = check_isnode(L, 1);
+ if (lua_isuserdata(L, 2)) {
+ t = check_isnode(L, 2);
+ lua_pop(L, 1);
+ } else {
+ t = h;
+ while (vlink(*t) != null)
+ *t = vlink(*t);
+ }
+ hnj_hyphenation(*h, *t);
+ lua_pushboolean(L, 1);
+ return 1;
}
-static const struct luaL_reg langlib_d [] = {
- {"clear_patterns", lang_clear_patterns},
- {"clear_hyphenation", lang_clear_hyphenation},
- {"patterns", lang_patterns},
- {"hyphenation", lang_hyphenation},
- {"prehyphenchar", lang_pre_hyphen_char},
- {"posthyphenchar", lang_post_hyphen_char},
- {"id", lang_id},
- {NULL, NULL} /* sentinel */
+static const struct luaL_reg langlib_d[] = {
+ /* *INDENT-OFF* */
+ {"clear_patterns", lang_clear_patterns},
+ {"clear_hyphenation", lang_clear_hyphenation},
+ {"patterns", lang_patterns},
+ {"hyphenation", lang_hyphenation},
+ {"prehyphenchar", lang_pre_hyphen_char},
+ {"posthyphenchar", lang_post_hyphen_char},
+ {"preexhyphenchar", lang_pre_exhyphen_char},
+ {"postexhyphenchar", lang_post_exhyphen_char},
+ {"id", lang_id},
+ /* *INDENT-ON* */
+ {NULL, NULL} /* sentinel */
};
static const struct luaL_reg langlib[] = {
- {"clear_patterns", lang_clear_patterns},
- {"clear_hyphenation", lang_clear_hyphenation},
- {"patterns", lang_patterns},
- {"hyphenation", lang_hyphenation},
- {"prehyphenchar", lang_pre_hyphen_char},
- {"posthyphenchar", lang_post_hyphen_char},
- {"id", lang_id},
- {"clean", do_lang_clean},
- {"hyphenate", do_lang_hyphenate},
- {"new", lang_new},
- {NULL, NULL} /* sentinel */
+ /* *INDENT-OFF* */
+ {"clear_patterns", lang_clear_patterns},
+ {"clear_hyphenation", lang_clear_hyphenation},
+ {"patterns", lang_patterns},
+ {"hyphenation", lang_hyphenation},
+ {"prehyphenchar", lang_pre_hyphen_char},
+ {"posthyphenchar", lang_post_hyphen_char},
+ {"preexhyphenchar", lang_pre_exhyphen_char},
+ {"postexhyphenchar", lang_post_exhyphen_char},
+ {"id", lang_id},
+ {"clean", do_lang_clean},
+ {"hyphenate", do_lang_hyphenate},
+ {"new", lang_new},
+ /* *INDENT-ON* */
+ {NULL, NULL} /* sentinel */
};
-int
-luaopen_lang (lua_State *L) {
- luaL_newmetatable(L,LANG_METATABLE);
- lua_pushvalue(L, -1); /* push metatable */
- lua_setfield(L, -2, "__index"); /* metatable.__index = metatable */
- luaL_register(L, NULL, langlib_d); /* dict methods */
- luaL_register(L, "lang", langlib);
- return 1;
+int luaopen_lang(lua_State * L)
+{
+ luaL_newmetatable(L, LANG_METATABLE);
+ lua_pushvalue(L, -1); /* push metatable */
+ lua_setfield(L, -2, "__index"); /* metatable.__index = metatable */
+ luaL_register(L, NULL, langlib_d); /* dict methods */
+ luaL_register(L, "lang", langlib);
+ return 1;
}
-
diff --git a/Build/source/texk/web2c/luatexdir/lua/llualib.c b/Build/source/texk/web2c/luatexdir/lua/llualib.c
index 90b1687f3b1..7efff052754 100644
--- a/Build/source/texk/web2c/luatexdir/lua/llualib.c
+++ b/Build/source/texk/web2c/luatexdir/lua/llualib.c
@@ -1,17 +1,36 @@
+/* llualib.c
+
+ Copyright 2006-2008 Taco Hoekwater <taco@luatex.org>
-/* $Id: llualib.c 1169 2008-04-15 14:57:56Z oneiros $ */
+ This file is part of LuaTeX.
+
+ LuaTeX is free software; you can redistribute it and/or modify it under
+ the terms of the GNU General Public License as published by the Free
+ Software Foundation; either version 2 of the License, or (at your
+ option) any later version.
+
+ LuaTeX is distributed in the hope that it will be useful, but WITHOUT
+ ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
+ FITNESS FOR A PARTICULAR PURPOSE. See the GNU Lesser General Public
+ License for more details.
+
+ You should have received a copy of the GNU General Public License along
+ with LuaTeX; if not, see <http://www.gnu.org/licenses/>. */
#include "luatex-api.h"
#include <ptexlib.h>
+static const char _svn_version[] =
+ "$Id: llualib.c 2064 2009-03-20 13:13:14Z taco $ $URL: http://scm.foundry.supelec.fr/svn/luatex/trunk/src/texk/web2c/luatexdir/lua/llualib.c $";
+
#define LOAD_BUF_SIZE 256
#define UINT_MAX32 0xFFFFFFFF
typedef struct {
- unsigned char* buf;
- int size;
- int done;
- int alloc;
+ unsigned char *buf;
+ int size;
+ int done;
+ int alloc;
} bytecode;
static bytecode *lua_bytecode_registers = NULL;
@@ -19,211 +38,298 @@ static bytecode *lua_bytecode_registers = NULL;
int luabytecode_max = -1;
unsigned int luabytecode_bytes = 0;
-void dump_luac_registers (void) {
- int k,n;
- bytecode b;
- dump_int(luabytecode_max);
- if (lua_bytecode_registers != NULL) {
- n = 0;
- for (k=0;k<=luabytecode_max;k++) {
- if (lua_bytecode_registers[k].size != 0)
- n++;
- }
- dump_int(n);
- for (k=0;k<=luabytecode_max;k++) {
- b = lua_bytecode_registers[k];
- if (b.size != 0) {
- dump_int(k);
- dump_int(b.size);
- do_zdump ((char *)b.buf,1,(b.size), DUMP_FILE);
- }
- }
- }
+char *luanames[65536] = {NULL};
+
+extern char *luanames[];
+
+char *
+get_lua_name (int i)
+{
+ if (i<0 || i>65535)
+ return NULL;
+ return luanames[i];
+}
+
+void dump_luac_registers(void)
+{
+ integer x;
+ int k, n;
+ bytecode b;
+ dump_int(luabytecode_max);
+ if (lua_bytecode_registers != NULL) {
+ n = 0;
+ for (k = 0; k <= luabytecode_max; k++) {
+ if (lua_bytecode_registers[k].size != 0)
+ n++;
+ }
+ dump_int(n);
+ for (k = 0; k <= luabytecode_max; k++) {
+ b = lua_bytecode_registers[k];
+ if (b.size != 0) {
+ dump_int(k);
+ dump_int(b.size);
+ do_zdump((char *) b.buf, 1, (b.size), DUMP_FILE);
+ }
+ }
+ }
+ for (k = 0; k < 65536; k++) {
+ char *a = luanames[k];
+ if (a!=NULL) {
+ x = strlen(a)+1;
+ dump_int(x);
+ dump_things(*a, x);
+ } else {
+ x = 0;
+ dump_int(x);
+ }
+ }
}
-void undump_luac_registers (void) {
- int k,n;
- unsigned int i;
- bytecode b;
- undump_int(luabytecode_max);
- if (luabytecode_max>=0) {
- i = (luabytecode_max+1);
- if ((int)(UINT_MAX32/sizeof(bytecode)+1)<=i) {
- lua_fatal_error(maketexstring("Corrupt format file"));
- }
- lua_bytecode_registers = xmalloc(i*sizeof(bytecode));
- luabytecode_bytes = i*sizeof(bytecode);
- for (i=0;i<=(unsigned)luabytecode_max;i++) {
- lua_bytecode_registers[i].done = 0;
- lua_bytecode_registers[i].size = 0;
- lua_bytecode_registers[i].buf = NULL;
- }
- undump_int(n);
- for (i=0;i<(unsigned)n;i++) {
- undump_int(k);
- undump_int(b.size);
- b.buf=xmalloc(b.size);
- luabytecode_bytes += b.size;
- memset(b.buf, 0, b.size);
- do_zundump ((char *)b.buf,1, b.size, DUMP_FILE);
- lua_bytecode_registers[k].size = b.size;
- lua_bytecode_registers[k].alloc = b.size;
- lua_bytecode_registers[k].buf = b.buf;
- }
- }
+void undump_luac_registers(void)
+{
+ integer x;
+ int k, n;
+ unsigned int i;
+ bytecode b;
+ undump_int(luabytecode_max);
+ if (luabytecode_max >= 0) {
+ i = (luabytecode_max + 1);
+ if ((int) (UINT_MAX32 / sizeof(bytecode) + 1) <= i) {
+ lua_fatal_error(maketexstring("Corrupt format file"));
+ }
+ lua_bytecode_registers = xmalloc(i * sizeof(bytecode));
+ luabytecode_bytes = i * sizeof(bytecode);
+ for (i = 0; i <= (unsigned) luabytecode_max; i++) {
+ lua_bytecode_registers[i].done = 0;
+ lua_bytecode_registers[i].size = 0;
+ lua_bytecode_registers[i].buf = NULL;
+ }
+ undump_int(n);
+ for (i = 0; i < (unsigned) n; i++) {
+ undump_int(k);
+ undump_int(b.size);
+ b.buf = xmalloc(b.size);
+ luabytecode_bytes += b.size;
+ memset(b.buf, 0, b.size);
+ do_zundump((char *) b.buf, 1, b.size, DUMP_FILE);
+ lua_bytecode_registers[k].size = b.size;
+ lua_bytecode_registers[k].alloc = b.size;
+ lua_bytecode_registers[k].buf = b.buf;
+ }
+ }
+ for (k = 0; k < 65536; k++) {
+ undump_int(x);
+ if (x > 0) {
+ char *s = xmalloc(x);
+ undump_things(*s, x);
+ luanames[k] = s;
+ }
+ }
}
-static void
-bytecode_register_shadow_set (lua_State* L, int k){
- /* the stack holds the value to be set */
- lua_pushstring(L,"bytecode_shadow"); /* lua.bytecode_shadow */
- lua_rawget(L,LUA_REGISTRYINDEX);
- if (lua_istable(L, -1)) {
- lua_pushvalue(L,-2);
- lua_rawseti(L,-2,k);
- }
- lua_pop(L,1); /* pop table or nil */
- lua_pop(L,1); /* pop value */
+static void bytecode_register_shadow_set(lua_State * L, int k)
+{
+ /* the stack holds the value to be set */
+ lua_pushstring(L, "bytecode_shadow"); /* lua.bytecode_shadow */
+ lua_rawget(L, LUA_REGISTRYINDEX);
+ if (lua_istable(L, -1)) {
+ lua_pushvalue(L, -2);
+ lua_rawseti(L, -2, k);
+ }
+ lua_pop(L, 1); /* pop table or nil */
+ lua_pop(L, 1); /* pop value */
}
-static int
-bytecode_register_shadow_get (lua_State* L, int k){
- /* the stack holds the value to be set */
- int ret = 0;
- lua_pushstring(L,"bytecode_shadow");
- lua_rawget(L,LUA_REGISTRYINDEX);
- if (lua_istable(L, -1)) {
- lua_rawgeti(L,-1,k);
- if (!lua_isnil(L,-1))
- ret = 1;
- lua_insert(L,-3); /* store the value or nil, deeper down */
- lua_pop(L,1); /* pop the value or nil at top */
- }
- lua_pop(L,1); /* pop table or nil */
- return ret;
+static int bytecode_register_shadow_get(lua_State * L, int k)
+{
+ /* the stack holds the value to be set */
+ int ret = 0;
+ lua_pushstring(L, "bytecode_shadow");
+ lua_rawget(L, LUA_REGISTRYINDEX);
+ if (lua_istable(L, -1)) {
+ lua_rawgeti(L, -1, k);
+ if (!lua_isnil(L, -1))
+ ret = 1;
+ lua_insert(L, -3); /* store the value or nil, deeper down */
+ lua_pop(L, 1); /* pop the value or nil at top */
+ }
+ lua_pop(L, 1); /* pop table or nil */
+ return ret;
}
-int writer(lua_State* L, const void* b, size_t size, void* B) {
- bytecode* buf = (bytecode*)B;
- if ((int)(buf->size + size) > buf->alloc) {
- buf->buf = xrealloc(buf->buf,buf->alloc+size+LOAD_BUF_SIZE);
- buf->alloc = buf->alloc+size+LOAD_BUF_SIZE;
- }
- memcpy(buf->buf+buf->size, b, size);
- buf->size += size;
- luabytecode_bytes += size;
- return 0;
+int writer(lua_State * L, const void *b, size_t size, void *B)
+{
+ bytecode *buf = (bytecode *) B;
+ (void)L; /* for -Wunused */
+ if ((int) (buf->size + size) > buf->alloc) {
+ buf->buf = xrealloc(buf->buf, buf->alloc + size + LOAD_BUF_SIZE);
+ buf->alloc = buf->alloc + size + LOAD_BUF_SIZE;
+ }
+ memcpy(buf->buf + buf->size, b, size);
+ buf->size += size;
+ luabytecode_bytes += size;
+ return 0;
}
-const char* reader(lua_State* L, void* ud, size_t* size) {
- bytecode* buf = (bytecode*)ud;
- if (buf->done == buf->size) {
- *size = 0;
- buf->done = 0;
- return NULL;
- }
- *size = buf->size;
- buf->done = buf->size;
- return (const char*)buf->buf;
+const char *reader(lua_State * L, void *ud, size_t * size)
+{
+ bytecode *buf = (bytecode *) ud;
+ (void)L; /* for -Wunused */
+ if (buf->done == buf->size) {
+ *size = 0;
+ buf->done = 0;
+ return NULL;
+ }
+ *size = buf->size;
+ buf->done = buf->size;
+ return (const char *) buf->buf;
}
-int get_bytecode (lua_State *L) {
- int k;
- k = (int)luaL_checkinteger(L,-1);
- if (k<0) {
- lua_pushnil(L);
- } else if (!bytecode_register_shadow_get(L,k)) {
- if (k<=luabytecode_max && lua_bytecode_registers[k].buf != NULL) {
- if(lua_load(L,reader,(void *)(lua_bytecode_registers+k),"bytecode")) {
- lua_error(L);
- lua_pushnil(L);
- } else {
- lua_pushvalue(L,-1);
- bytecode_register_shadow_set(L,k);
- }
- } else {
- lua_pushnil(L);
+int get_bytecode(lua_State * L)
+{
+ int k;
+ k = (int) luaL_checkinteger(L, -1);
+ if (k < 0) {
+ lua_pushnil(L);
+ } else if (!bytecode_register_shadow_get(L, k)) {
+ if (k <= luabytecode_max && lua_bytecode_registers[k].buf != NULL) {
+ if (lua_load
+ (L, reader, (void *) (lua_bytecode_registers + k),
+ "bytecode")) {
+ lua_error(L);
+ lua_pushnil(L);
+ } else {
+ lua_pushvalue(L, -1);
+ bytecode_register_shadow_set(L, k);
+ }
+ } else {
+ lua_pushnil(L);
+ }
}
- }
- return 1;
+ return 1;
}
-int set_bytecode (lua_State *L) {
- int k, ltype;
- unsigned int i;
- k = (int)luaL_checkinteger(L,-2);
- i = k+1;
- if ((int)(UINT_MAX32/sizeof(bytecode)+1)<i) {
- lua_pushstring(L, "value too large");
- lua_error(L);
- }
- if (k<0) {
- lua_pushstring(L, "negative values not allowed");
- lua_error(L);
- }
- ltype = lua_type(L,-1);
- if (ltype != LUA_TFUNCTION && ltype != LUA_TNIL){
- lua_pushstring(L, "unsupported type");
- lua_error(L);
- }
- if (k>luabytecode_max) {
- i = sizeof(bytecode)*(k+1);
- lua_bytecode_registers = xrealloc(lua_bytecode_registers,i);
- if (luabytecode_max==-1) {
- luabytecode_bytes += sizeof(bytecode)*(k+1);
- } else {
- luabytecode_bytes += sizeof(bytecode)*(k+1-luabytecode_max);
- }
- for (i=(luabytecode_max+1);i<=(unsigned)k;i++) {
- lua_bytecode_registers[i].buf=NULL;
- lua_bytecode_registers[i].size=0;
- lua_bytecode_registers[i].done=0;
- }
- luabytecode_max = k;
- }
- if (lua_bytecode_registers[k].buf != NULL) {
- xfree(lua_bytecode_registers[k].buf);
- luabytecode_bytes -= lua_bytecode_registers[k].size;
- lua_bytecode_registers[k].buf = NULL;
- lua_bytecode_registers[k].size=0;
- lua_bytecode_registers[k].done=0;
- lua_pushnil(L);
- bytecode_register_shadow_set(L,k);
- }
- if (ltype == LUA_TFUNCTION) {
- lua_bytecode_registers[k].buf=xmalloc(LOAD_BUF_SIZE);
- lua_bytecode_registers[k].alloc = LOAD_BUF_SIZE;
- memset(lua_bytecode_registers[k].buf, 0, LOAD_BUF_SIZE);
- lua_dump(L,writer,(void *)(lua_bytecode_registers+k));
- }
- lua_pop(L,1);
- return 0;
+int set_bytecode(lua_State * L)
+{
+ int k, ltype;
+ unsigned int i;
+ k = (int) luaL_checkinteger(L, -2);
+ i = k + 1;
+ if ((int) (UINT_MAX32 / sizeof(bytecode) + 1) < i) {
+ lua_pushstring(L, "value too large");
+ lua_error(L);
+ }
+ if (k < 0) {
+ lua_pushstring(L, "negative values not allowed");
+ lua_error(L);
+ }
+ ltype = lua_type(L, -1);
+ if (ltype != LUA_TFUNCTION && ltype != LUA_TNIL) {
+ lua_pushstring(L, "unsupported type");
+ lua_error(L);
+ }
+ if (k > luabytecode_max) {
+ i = sizeof(bytecode) * (k + 1);
+ lua_bytecode_registers = xrealloc(lua_bytecode_registers, i);
+ if (luabytecode_max == -1) {
+ luabytecode_bytes += sizeof(bytecode) * (k + 1);
+ } else {
+ luabytecode_bytes += sizeof(bytecode) * (k + 1 - luabytecode_max);
+ }
+ for (i = (luabytecode_max + 1); i <= (unsigned) k; i++) {
+ lua_bytecode_registers[i].buf = NULL;
+ lua_bytecode_registers[i].size = 0;
+ lua_bytecode_registers[i].done = 0;
+ }
+ luabytecode_max = k;
+ }
+ if (lua_bytecode_registers[k].buf != NULL) {
+ xfree(lua_bytecode_registers[k].buf);
+ luabytecode_bytes -= lua_bytecode_registers[k].size;
+ lua_bytecode_registers[k].buf = NULL;
+ lua_bytecode_registers[k].size = 0;
+ lua_bytecode_registers[k].done = 0;
+ lua_pushnil(L);
+ bytecode_register_shadow_set(L, k);
+ }
+ if (ltype == LUA_TFUNCTION) {
+ lua_bytecode_registers[k].buf = xmalloc(LOAD_BUF_SIZE);
+ lua_bytecode_registers[k].alloc = LOAD_BUF_SIZE;
+ memset(lua_bytecode_registers[k].buf, 0, LOAD_BUF_SIZE);
+ lua_dump(L, writer, (void *) (lua_bytecode_registers + k));
+ }
+ lua_pop(L, 1);
+ return 0;
}
-static const struct luaL_reg lualib [] = {
- {"getbytecode", get_bytecode},
- {"setbytecode", set_bytecode},
- {NULL, NULL} /* sentinel */
-};
-int luaopen_lua (lua_State *L, int n, char *fname)
+int set_luaname(lua_State * L)
{
- luaL_register(L, "lua", lualib);
- make_table(L,"bytecode","getbytecode","setbytecode");
- lua_newtable(L);
- lua_setfield(L, LUA_REGISTRYINDEX, "bytecode_shadow");
- lua_pushinteger(L, n);
- lua_setfield(L, -2, "id");
- lua_pushstring(L, "0.1");
- lua_setfield(L, -2, "version");
- if (fname == NULL) {
- lua_pushnil(L);
- } else {
- lua_pushstring(L, fname);
- }
- lua_setfield(L, -2, "startupfile");
- return 1;
+ int k;
+ char *s;
+ if (lua_gettop(L)==3) {
+ k = (int) luaL_checkinteger(L, 2);
+ if (k>65535 || k<0) {
+ /* error */
+ } else {
+ if (luanames[k] != NULL) {
+ free(luanames[k]);
+ luanames[k] = NULL;
+ }
+ if (lua_isstring(L, 3)) {
+ s = (char *) lua_tostring(L,3);
+ if (s!=NULL)
+ luanames[k] = xstrdup(s);
+ }
+ }
+ }
+ return 0;
}
+int get_luaname(lua_State * L)
+{
+ int k;
+ k = (int) luaL_checkinteger(L, 2);
+ if (k>65535 || k<0) {
+ /* error */
+ lua_pushnil(L);
+ } else {
+ if (luanames[k]!=NULL)
+ lua_pushstring(L, luanames[k]);
+ else
+ lua_pushnil(L);
+ }
+ return 1;
+}
+
+
+
+static const struct luaL_reg lualib[] = {
+ /* *INDENT-OFF* */
+ {"getluaname", get_luaname},
+ {"setluaname", set_luaname},
+ {"getbytecode", get_bytecode},
+ {"setbytecode", set_bytecode},
+ /* *INDENT-ON* */
+ {NULL, NULL} /* sentinel */
+};
+
+int luaopen_lua(lua_State * L, char *fname)
+{
+ luaL_register(L, "lua", lualib);
+ make_table(L, "bytecode", "getbytecode", "setbytecode");
+ make_table(L, "name", "getluaname", "setluaname");
+ lua_newtable(L);
+ lua_setfield(L, LUA_REGISTRYINDEX, "bytecode_shadow");
+ lua_pushstring(L, LUA_VERSION);
+ lua_setfield(L, -2, "version");
+ if (fname == NULL) {
+ lua_pushnil(L);
+ } else {
+ lua_pushstring(L, fname);
+ }
+ lua_setfield(L, -2, "startupfile");
+ return 1;
+}
diff --git a/Build/source/texk/web2c/luatexdir/lua/lmplib.c b/Build/source/texk/web2c/luatexdir/lua/lmplib.c
deleted file mode 100644
index b435618e97b..00000000000
--- a/Build/source/texk/web2c/luatexdir/lua/lmplib.c
+++ /dev/null
@@ -1,1273 +0,0 @@
-/* $Id$ */
-
-#include <stdlib.h>
-#include <string.h>
-#include <unistd.h>
-
-#ifndef pdfTeX
-#include <lua.h>
-#include <lauxlib.h>
-#include <lualib.h>
-#else
-#include <../lua51/lua.h>
-#include <../lua51/lauxlib.h>
-#include <../lua51/lualib.h>
-#endif
-
-#include "mplib.h"
-#include "mpmp.h"
-#include "mppsout.h" /* for mp_edge_object */
-
-#define MPLIB_METATABLE "MPlib"
-#define MPLIB_FIG_METATABLE "MPlib.fig"
-#define MPLIB_GR_METATABLE "MPlib.gr"
-
-#define mplib_init_S(a) do { \
- lua_pushliteral(L,#a); \
- mplib_##a##_ptr = (char *)lua_tostring(L,-1); \
- mplib_##a##_index = luaL_ref (L,LUA_REGISTRYINDEX); \
- } while (0)
-
-#define mplib_push_S(a) do { \
- lua_rawgeti(L,LUA_REGISTRYINDEX,mplib_##a##_index); \
- } while (0)
-
-#define mplib_is_S(a,i) (mplib_##a##_ptr==(char *)lua_tostring(L,i))
-
-#define mplib_make_S(a) \
- static int mplib_##a##_index = 0; \
- static char *mplib_##a##_ptr = NULL
-
-static int mplib_type_Ses[mp_special_code+1] = {0}; /* [0] is not used */
-
-mplib_make_S(fill);
-mplib_make_S(outline);
-mplib_make_S(text);
-mplib_make_S(special);
-mplib_make_S(start_bounds);
-mplib_make_S(stop_bounds);
-mplib_make_S(start_clip);
-mplib_make_S(stop_clip);
-
-mplib_make_S(left_type);
-mplib_make_S(right_type);
-mplib_make_S(x_coord);
-mplib_make_S(y_coord);
-mplib_make_S(left_x);
-mplib_make_S(left_y);
-mplib_make_S(right_x);
-mplib_make_S(right_y);
-
-mplib_make_S(color);
-mplib_make_S(dash);
-mplib_make_S(depth);
-mplib_make_S(dsize);
-mplib_make_S(font);
-mplib_make_S(height);
-mplib_make_S(htap);
-mplib_make_S(linecap);
-mplib_make_S(linejoin);
-mplib_make_S(miterlimit);
-mplib_make_S(path);
-mplib_make_S(pen);
-mplib_make_S(postscript);
-mplib_make_S(prescript);
-mplib_make_S(transform);
-mplib_make_S(type);
-mplib_make_S(width);
-
-void mplib_init_Ses(lua_State *L) {
- mplib_init_S(fill);
- mplib_init_S(outline);
- mplib_init_S(text);
- mplib_init_S(start_bounds);
- mplib_init_S(stop_bounds);
- mplib_init_S(start_clip);
- mplib_init_S(stop_clip);
- mplib_init_S(special);
-
- mplib_type_Ses[mp_fill_code] = mplib_fill_index;
- mplib_type_Ses[mp_stroked_code] = mplib_outline_index;
- mplib_type_Ses[mp_text_code] = mplib_text_index;
- mplib_type_Ses[mp_start_bounds_code] = mplib_start_bounds_index;
- mplib_type_Ses[mp_stop_bounds_code] = mplib_stop_bounds_index;
- mplib_type_Ses[mp_start_clip_code] = mplib_start_clip_index;
- mplib_type_Ses[mp_stop_clip_code] = mplib_stop_clip_index;
- mplib_type_Ses[mp_special_code] = mplib_special_index;
-
- mplib_init_S(left_type);
- mplib_init_S(right_type);
- mplib_init_S(x_coord);
- mplib_init_S(y_coord);
- mplib_init_S(left_x);
- mplib_init_S(left_y);
- mplib_init_S(right_x);
- mplib_init_S(right_y);
-
- mplib_init_S(color);
- mplib_init_S(dash);
- mplib_init_S(depth);
- mplib_init_S(dsize);
- mplib_init_S(font);
- mplib_init_S(height);
- mplib_init_S(htap);
- mplib_init_S(linecap);
- mplib_init_S(linejoin);
- mplib_init_S(miterlimit);
- mplib_init_S(path);
- mplib_init_S(pen);
- mplib_init_S(postscript);
- mplib_init_S(prescript);
- mplib_init_S(transform);
- mplib_init_S(type);
- mplib_init_S(width);
-}
-
-
-
-
-#define xfree(A) if ((A)!=NULL) { free((A)); A = NULL; }
-
-#define is_mp(L,b) (MP *)luaL_checkudata(L,b,MPLIB_METATABLE)
-#define is_fig(L,b) (struct mp_edge_object **)luaL_checkudata(L,b,MPLIB_FIG_METATABLE)
-#define is_gr_object(L,b) (struct mp_graphic_object **)luaL_checkudata(L,b,MPLIB_GR_METATABLE)
-
-/* Enumeration string arrays */
-
-static const char *interaction_options[] =
- { "unknown","batch","nonstop","scroll","errorstop", NULL};
-
-static const char *mplib_filetype_names[] =
- {"term", "error", "mp", "log", "ps", "mem", "tfm", "map", "pfb", "enc", NULL};
-
-/* only "endpoint" and "explicit" actually happen in paths,
- as well as "open" in elliptical pens */
-
-static const char *knot_type_enum[] =
- { "endpoint", "explicit", "given", "curl", "open", "end_cycle" };
-
-/* object fields */
-
-static const char *fill_fields[] =
- { "type", "path", "htap", "pen", "color", "linejoin", "miterlimit",
- "prescript", "postscript", NULL };
-
-static const char *stroked_fields[] =
- { "type", "path", "pen", "color", "linejoin", "miterlimit", "linecap", "dash",
- "prescript", "postscript", NULL };
-
-static const char *text_fields[] =
- { "type", "text", "dsize", "font", "color", "width", "height", "depth", "transform",
- "prescript", "postscript", NULL };
-
-static const char *special_fields[] =
- { "type", "prescript", NULL };
-
-static const char *start_bounds_fields[] =
- { "type", "path", NULL };
-
-static const char *start_clip_fields[] =
- { "type", "path", NULL };
-
-static const char *stop_bounds_fields[] =
- { "type", NULL };
-
-static const char *stop_clip_fields[] =
- { "type", NULL };
-
-static const char *no_fields[] =
- { NULL };
-
-typedef enum {
- P_ERROR_LINE, P_HALF_LINE, P_MAX_LINE, P_MAIN_MEMORY,
- P_HASH_SIZE, P_HASH_PRIME, P_PARAM_SIZE, P_IN_OPEN, P_RANDOM_SEED,
- P_INTERACTION, P_INI_VERSION, P_TROFF_MODE, P_PRINT_NAMES, P_MEM_NAME,
- P_JOB_NAME, P_FIND_FILE, P__SENTINEL
-} mplib_parm_idx;
-
-typedef struct {
- const char *name; /* parameter name */
- mplib_parm_idx idx; /* parameter index */
-} mplib_parm_struct;
-
-static mplib_parm_struct mplib_parms[] = {
- {"error_line", P_ERROR_LINE },
- {"half_error_line", P_HALF_LINE },
- {"max_print_line", P_MAX_LINE },
- {"main_memory", P_MAIN_MEMORY },
- {"hash_size", P_HASH_SIZE },
- {"hash_prime", P_HASH_PRIME },
- {"param_size", P_PARAM_SIZE },
- {"max_in_open", P_IN_OPEN },
- {"random_seed", P_RANDOM_SEED },
- {"interaction", P_INTERACTION },
- {"ini_version", P_INI_VERSION },
- {"troff_mode", P_TROFF_MODE },
- {"print_found_names", P_PRINT_NAMES },
- {"mem_name", P_MEM_NAME },
- {"job_name", P_JOB_NAME },
- {"find_file", P_FIND_FILE },
- {NULL, P__SENTINEL }
-};
-
-typedef struct _FILE_ITEM {
- FILE *f;
-} _FILE_ITEM ;
-
-typedef struct _FILE_ITEM File;
-
-#define make_stream_buf(A) char *A; size_t A##_size; size_t A##_used
-
-#define free_stream_buf(A) xfree(mplib_data->A); mplib_data->A##_size = 0; mplib_data->A##_used = 0
-
-typedef struct _MPLIB_INSTANCE_DATA {
- void *term_file_ptr;
- void *err_file_ptr;
- void *log_file_ptr;
- void *ps_file_ptr;
- make_stream_buf(term_out);
- make_stream_buf(error_out);
- make_stream_buf(log_out);
- make_stream_buf(ps_out);
- char *input_data;
- char *input_data_ptr;
- size_t input_data_len;
- struct mp_edge_object *edges ;
- lua_State *LL;
-} _MPLIB_INSTANCE_DATA;
-
-typedef struct _MPLIB_INSTANCE_DATA mplib_instance;
-
-static mplib_instance *mplib_get_data (MP mp) {
- return (mplib_instance *)mp->userdata;
-}
-
-static mplib_instance *mplib_make_data (void) {
- mplib_instance *mplib_data = malloc(sizeof(mplib_instance));
- memset(mplib_data,0,sizeof(mplib_instance));
- return mplib_data ;
-}
-
-
-/* Start by defining all the callback routines for the library
- * except |run_make_mpx| and |run_editor|.
- */
-
-
-char *mplib_find_file (MP mp, const char *fname, const char *fmode, int ftype) {
- mplib_instance *mplib_data = mplib_get_data(mp);
- lua_State *L = mplib_data->LL;
- lua_checkstack(L,4);
- lua_getfield(L,LUA_REGISTRYINDEX,"mplib_file_finder");
- if (lua_isfunction(L,-1)) {
- char *s = NULL, *x = NULL;
- lua_pushstring(L, fname);
- lua_pushstring(L, fmode);
- if (ftype >= mp_filetype_text) {
- lua_pushnumber(L, ftype-mp_filetype_text);
- } else {
- lua_pushstring(L, mplib_filetype_names[ftype]);
- }
- if(lua_pcall(L,3,1,0) != 0) {
- fprintf(stdout,"Error in mp.find_file: %s\n", (char *)lua_tostring(L,-1));
- return NULL;
- }
- x = (char *)lua_tostring(L,-1);
- if (x!=NULL)
- s = strdup(x);
- lua_pop(L,1); /* pop the string */
- return s;
- } else {
- lua_pop(L,1);
- }
- if (fmode[0] != 'r' || (! access (fname,R_OK)) || ftype) {
- return strdup(fname);
- }
- return NULL;
-}
-
-static int
-mplib_find_file_function (lua_State *L) {
- if (! (lua_isfunction(L,-1)|| lua_isnil(L,-1) )) {
- return 1; /* error */
- }
- lua_pushstring(L, "mplib_file_finder");
- lua_pushvalue(L,-2);
- lua_rawset(L,LUA_REGISTRYINDEX);
- return 0;
-}
-
-void *mplib_open_file(MP mp, const char *fname, const char *fmode, int ftype) {
- File *ff = malloc(sizeof (File));
- if (ff) {
- mplib_instance *mplib_data = mplib_get_data(mp);
- ff->f = NULL;
- if (ftype==mp_filetype_terminal) {
- if (fmode[0] == 'r') {
- ff->f = stdin;
- } else {
- xfree(mplib_data->term_file_ptr);
- ff->f = malloc(1);
- mplib_data->term_file_ptr = ff->f;
- }
- } else if (ftype==mp_filetype_error) {
- xfree(mplib_data->err_file_ptr);
- ff->f = malloc(1);
- mplib_data->err_file_ptr = ff->f;
- } else if (ftype == mp_filetype_log) {
- xfree(mplib_data->log_file_ptr);
- ff->f = malloc(1);
- mplib_data->log_file_ptr = ff->f;
- } else if (ftype == mp_filetype_postscript) {
- xfree(mplib_data->ps_file_ptr);
- ff->f = malloc(1);
- mplib_data->ps_file_ptr = ff->f;
- } else {
- char realmode[3];
- char *f = mplib_find_file(mp, fname,fmode,ftype);
- if (f==NULL)
- return NULL;
- realmode[0] = *fmode;
- realmode[1] = 'b';
- realmode[2] = 0;
- ff->f = fopen(f, realmode);
- if ((fmode[0] == 'r') && (ff->f == NULL)) {
- free(ff);
- return NULL;
- }
- }
- return ff;
- }
- return NULL;
-}
-
-static int
-mplib_get_char (void *f, mplib_instance *mplib_data) {
- int c;
- if (f==stdin && mplib_data->input_data != NULL) {
- if (mplib_data->input_data_len==0) {
- if (mplib_data->input_data_ptr!=NULL)
- mplib_data->input_data_ptr = NULL;
- else
- mplib_data->input_data = NULL;
- c = EOF;
- } else {
- mplib_data->input_data_len--;
- c = *(mplib_data->input_data_ptr)++;
- }
- } else {
- c = fgetc(f);
- }
- return c;
-}
-
-static void
-mplib_unget_char (void *f, mplib_instance *mplib_data, int c) {
- if (f==stdin && mplib_data->input_data_ptr != NULL) {
- mplib_data->input_data_len++;
- mplib_data->input_data_ptr--;
- } else {
- ungetc(c,f);
- }
-}
-
-
-char *mplib_read_ascii_file (MP mp, void *ff, size_t *size) {
- char *s = NULL;
- if (ff!=NULL) {
- int c;
- size_t len = 0, lim = 128;
- mplib_instance *mplib_data = mplib_get_data(mp);
- FILE *f = ((File *)ff)->f;
- if (f==NULL)
- return NULL;
- *size = 0;
- c = mplib_get_char(f,mplib_data);
- if (c==EOF)
- return NULL;
- s = malloc(lim);
- if (s==NULL) return NULL;
- while (c!=EOF && c!='\n' && c!='\r') {
- if (len==lim) {
- s =realloc(s, (lim+(lim>>2)));
- if (s==NULL) return NULL;
- lim+=(lim>>2);
- }
- s[len++] = c;
- c = mplib_get_char(f,mplib_data);
- }
- if (c=='\r') {
- c = mplib_get_char(f,mplib_data);
- if (c!=EOF && c!='\n')
- mplib_unget_char(f,mplib_data,c);
- }
- s[len] = 0;
- *size = len;
- }
- return s;
-}
-
-#define APPEND_STRING(a,b) do { \
- if ((mplib_data->a##_used+strlen(b))>=mplib_data->a##_size) { \
- mplib_data->a##_size += 256+(mplib_data->a##_size)/5+strlen(b); \
- mplib_data->a = realloc(mplib_data->a,mplib_data->a##_size); \
- } \
- (void)strcpy(mplib_data->a+mplib_data->a##_used,b); \
- mplib_data->a##_used += strlen(b); \
- } while (0)
-
-void mplib_write_ascii_file (MP mp, void *ff, const char *s) {
- if (ff!=NULL) {
- void *f = ((File *)ff)->f;
- mplib_instance *mplib_data = mplib_get_data(mp);
- if (f!=NULL) {
- if (f==mplib_data->term_file_ptr) {
- APPEND_STRING(term_out,s);
- } else if (f==mplib_data->err_file_ptr) {
- APPEND_STRING(error_out,s);
- } else if (f==mplib_data->log_file_ptr) {
- APPEND_STRING(log_out,s);
- } else if (f==mplib_data->ps_file_ptr) {
- APPEND_STRING(ps_out,s);
- } else {
- fprintf((FILE *)f,"%s",s);
- }
- }
- }
-}
-
-void mplib_read_binary_file (MP mp, void *ff, void **data, size_t *size) {
- (void)mp;
- if (ff!=NULL) {
- size_t len = 0;
- FILE *f = ((File *)ff)->f;
- if (f!=NULL)
- len = fread(*data,1,*size,f);
- *size = len;
- }
-}
-
-void mplib_write_binary_file (MP mp, void *ff, void *s, size_t size) {
- (void)mp;
- if (ff!=NULL) {
- FILE *f = ((File *)ff)->f;
- if (f!=NULL)
- fwrite(s,size,1,f);
- }
-}
-
-
-void mplib_close_file (MP mp, void *ff) {
- if (ff!=NULL) {
- mplib_instance *mplib_data = mplib_get_data(mp);
- void *f = ((File *)ff)->f;
- if (f != NULL && f != mplib_data->term_file_ptr && f != mplib_data->err_file_ptr
- && f != mplib_data->log_file_ptr && f != mplib_data->ps_file_ptr) {
- fclose(f);
- }
- free(ff);
- }
-}
-
-int mplib_eof_file (MP mp, void *ff) {
- if (ff!=NULL) {
- mplib_instance *mplib_data = mplib_get_data(mp);
- FILE *f = ((File *)ff)->f;
- if (f==NULL)
- return 1;
- if (f==stdin && mplib_data->input_data != NULL) {
- return (mplib_data->input_data_len==0);
- }
- return feof(f);
- }
- return 1;
-}
-
-void mplib_flush_file (MP mp, void *ff) {
- (void)mp;
- (void)ff;
- return ;
-}
-
-#define APPEND_TO_EDGES(a) do { \
- if (mplib_data->edges==NULL) { \
- mplib_data->edges = hh; \
- } else { \
- struct mp_edge_object *p = mplib_data->edges; \
- while (p->_next!=NULL) { p = p->_next; } \
- p->_next = hh; \
- } \
-} while (0)
-
-void mplib_shipout_backend (MP mp, int h) {
- struct mp_edge_object *hh = mp_gr_export(mp, h);
- if (hh) {
- mplib_instance *mplib_data = mplib_get_data(mp);
- APPEND_TO_EDGES(hh);
- }
-}
-
-
-static void
-mplib_setup_file_ops(struct MP_options * options) {
- options->find_file = mplib_find_file;
- options->open_file = mplib_open_file;
- options->close_file = mplib_close_file;
- options->eof_file = mplib_eof_file;
- options->flush_file = mplib_flush_file;
- options->write_ascii_file = mplib_write_ascii_file;
- options->read_ascii_file = mplib_read_ascii_file;
- options->write_binary_file = mplib_write_binary_file;
- options->read_binary_file = mplib_read_binary_file;
- options->shipout_backend = mplib_shipout_backend;
-}
-
-static int
-mplib_new (lua_State *L) {
- MP *mp_ptr;
- mp_ptr = lua_newuserdata(L, sizeof(MP *));
- if (mp_ptr) {
- int i;
- mplib_instance *mplib_data;
- struct MP_options * options; /* instance options */
- options = mp_options();
- mplib_setup_file_ops(options);
- mplib_data = mplib_make_data();
- mplib_data->LL = L;
- options->userdata = (void *)mplib_data;
- options->noninteractive = 1; /* required ! */
- options->print_found_names = 0;
- if (lua_type(L,1)==LUA_TTABLE) {
- for (i=0;mplib_parms[i].name!=NULL;i++) {
- lua_getfield(L,1,mplib_parms[i].name);
- if (lua_isnil(L,-1)) {
- lua_pop(L,1);
- continue; /* skip unset */
- }
- switch(mplib_parms[i].idx) {
- case P_ERROR_LINE:
- options->error_line = lua_tointeger(L,-1);
- break;
- case P_HALF_LINE:
- options->half_error_line = lua_tointeger(L,-1);
- break;
- case P_MAX_LINE:
- options->max_print_line = lua_tointeger(L,-1);
- break;
- case P_MAIN_MEMORY:
- options->main_memory = lua_tointeger(L,-1);
- break;
- case P_HASH_SIZE:
- options->hash_size = lua_tointeger(L,-1);
- break;
- case P_HASH_PRIME:
- options->hash_prime = lua_tointeger(L,-1);
- break;
- case P_PARAM_SIZE:
- options->param_size = lua_tointeger(L,-1);
- break;
- case P_IN_OPEN:
- options->max_in_open = lua_tointeger(L,-1);
- break;
- case P_RANDOM_SEED:
- options->random_seed = lua_tointeger(L,-1);
- break;
- case P_INTERACTION:
- options->interaction = luaL_checkoption(L,-1,"errorstopmode", interaction_options);
- break;
- case P_INI_VERSION:
- options->ini_version = lua_toboolean(L,-1);
- break;
- case P_TROFF_MODE:
- options->troff_mode = lua_toboolean(L,-1);
- break;
- case P_PRINT_NAMES:
- options->print_found_names = lua_toboolean(L,-1);
- break;
- /*
- case P_COMMAND_LINE:
- options->command_line = strdup((char *)lua_tostring(L,-1));
- break;
- */
- case P_MEM_NAME:
- options->mem_name = strdup((char *)lua_tostring(L,-1));
- break;
- case P_JOB_NAME:
- options->job_name = strdup((char *)lua_tostring(L,-1));
- break;
- case P_FIND_FILE:
- if(mplib_find_file_function(L)) { /* error here */
- fprintf(stdout,"Invalid arguments to mp.new({find_file=...})\n");
- }
- break;
- default:
- break;
- }
- lua_pop(L,1);
- }
- }
- *mp_ptr = mp_new(options);
- xfree(options->command_line);
- xfree(options->mem_name);
- xfree(options->job_name);
- free(options);
- if (*mp_ptr) {
- luaL_getmetatable(L,MPLIB_METATABLE);
- lua_setmetatable(L,-2);
- return 1;
- }
- }
- lua_pushnil(L);
- return 1;
-}
-
-static int
-mplib_collect (lua_State *L) {
- MP *mp_ptr = is_mp(L,1);
- xfree(*mp_ptr);
- return 0;
-}
-
-static int
-mplib_tostring (lua_State *L) {
- MP *mp_ptr = is_mp(L,1);
- if (*mp_ptr!=NULL) {
- lua_pushfstring(L,"<MP %p>",*mp_ptr);
- return 1;
- }
- return 0;
-}
-
-static int
-mplib_wrapresults(lua_State *L, mplib_instance *mplib_data, int h) {
- lua_checkstack(L,5);
- lua_newtable(L);
- if (mplib_data->term_out != NULL) {
- lua_pushstring(L,mplib_data->term_out);
- lua_setfield(L,-2,"term");
- free_stream_buf(term_out);
- }
- if (mplib_data->error_out != NULL) {
- lua_pushstring(L,mplib_data->error_out);
- lua_setfield(L,-2,"error");
- free_stream_buf(error_out);
- }
- if (mplib_data->log_out != NULL ) {
- lua_pushstring(L,mplib_data->log_out);
- lua_setfield(L,-2,"log");
- free_stream_buf(log_out);
- }
- if (mplib_data->edges != NULL ) {
- struct mp_edge_object **v;
- struct mp_edge_object *p = mplib_data->edges;
- int i = 1;
- lua_newtable(L);
- while (p!=NULL) {
- v = lua_newuserdata (L, sizeof(struct mp_edge_object *));
- *v = p;
- luaL_getmetatable(L,MPLIB_FIG_METATABLE);
- lua_setmetatable(L,-2);
- lua_rawseti(L,-2,i); i++;
- p = p->_next;
- }
- lua_setfield(L,-2,"fig");
- mplib_data->edges = NULL;
- }
- lua_pushnumber(L,h);
- lua_setfield(L,-2,"status");
- return 1;
-}
-
-static int
-mplib_execute (lua_State *L) {
- MP *mp_ptr = is_mp(L,1);
- if (*mp_ptr!=NULL && lua_isstring(L,2)) {
- int h;
- mplib_instance *mplib_data = mplib_get_data(*mp_ptr);
- mplib_data->input_data = (char *)lua_tolstring(L,2, &(mplib_data->input_data_len));
- mplib_data->input_data_ptr = mplib_data->input_data;
- if ((*mp_ptr)->run_state==0) {
- h = mp_initialize(*mp_ptr);
- }
- h = mp_execute(*mp_ptr);
- if (mplib_data->input_data_len!=0) {
- mplib_data->input_data = NULL;
- mplib_data->input_data_ptr = NULL;
- mplib_data->input_data_len=0;
- }
- return mplib_wrapresults(L, mplib_data, h);
- } else {
- lua_pushnil(L);
- }
- return 1;
-}
-
-static int
-mplib_finish (lua_State *L) {
- MP *mp_ptr = is_mp(L,1);
- if (*mp_ptr!=NULL) {
- mplib_instance *mplib_data = mplib_get_data(*mp_ptr);
- int h = mp_finish(*mp_ptr);
- return mplib_wrapresults(L, mplib_data, h);
- } else {
- lua_pushnil(L);
- }
- return 1;
-}
-
-static int
-mplib_statistics (lua_State *L) {
- MP *mp_ptr = is_mp(L,1);
- if (*mp_ptr!=NULL) {
- lua_newtable(L);
- lua_pushnumber(L, mp_memory_usage (*mp_ptr));
- lua_setfield(L,-2,"main_memory");
- lua_pushnumber(L, mp_hash_usage (*mp_ptr));
- lua_setfield(L,-2,"hash_size");
- lua_pushnumber(L, mp_param_usage (*mp_ptr));
- lua_setfield(L,-2,"param_size");
- lua_pushnumber(L, mp_open_usage (*mp_ptr));
- lua_setfield(L,-2,"max_in_open");
- } else {
- lua_pushnil(L);
- }
- return 1;
-}
-
-
-/* figure methods */
-
-static int
-mplib_fig_collect (lua_State *L) {
- struct mp_edge_object **hh = is_fig(L,1);
- if (*hh!=NULL) {
- mp_gr_toss_objects (*hh);
- *hh=NULL;
- }
- return 0;
-}
-
-static int
-mplib_fig_body (lua_State *L) {
- int i = 1;
- struct mp_graphic_object **v;
- struct mp_graphic_object *p;
- struct mp_edge_object **hh = is_fig(L,1);
- lua_newtable(L);
- p = (*hh)->body;
- while (p!=NULL) {
- v = lua_newuserdata (L, sizeof(struct mp_graphic_object *));
- *v = p;
- luaL_getmetatable(L,MPLIB_GR_METATABLE);
- lua_setmetatable(L,-2);
- lua_rawseti(L,-2,i); i++;
- p = p->_link_field;
- }
- (*hh)->body = NULL; /* prevent double free */
- return 1;
-}
-
-static int
-mplib_fig_copy_body (lua_State *L) {
- int i = 1;
- struct mp_graphic_object **v;
- struct mp_graphic_object *p;
- struct mp_edge_object **hh = is_fig(L,1);
- lua_newtable(L);
- p = (*hh)->body;
- while (p!=NULL) {
- v = lua_newuserdata (L, sizeof(struct mp_graphic_object *));
- *v = mp_gr_copy_object((*hh)->_parent,p);
- luaL_getmetatable(L,MPLIB_GR_METATABLE);
- lua_setmetatable(L,-2);
- lua_rawseti(L,-2,i); i++;
- p = p->_link_field;
- }
- return 1;
-}
-
-
-static int
-mplib_fig_tostring (lua_State *L) {
- struct mp_edge_object **hh = is_fig(L,1);
- lua_pushfstring(L,"<figure %p>",*hh);
- return 1;
-}
-
-
-
-static int
-mp_wrapped_shipout (struct mp_edge_object *hh, int prologues, int procset) {
- MP mp = hh->_parent;
- if (setjmp(mp->jump_buf)) {
- return 0;
- }
- mp_gr_ship_out(hh,prologues,procset);
- return 1;
-}
-
-static int
-mplib_fig_postscript (lua_State *L) {
- struct mp_edge_object **hh = is_fig(L,1);
- int prologues = luaL_optnumber(L,2,-1);
- int procset = luaL_optnumber(L,3,-1);
- mplib_instance *mplib_data = mplib_get_data((*hh)->_parent);
- if (mplib_data->ps_out == NULL) {
- if (mp_wrapped_shipout(*hh,prologues, procset)) {
- if (mplib_data->ps_out!=NULL ) {
- lua_pushstring(L, mplib_data->ps_out);
- free_stream_buf(ps_out);
- } else {
- lua_pushnil(L);
- }
- return 1;
- } else {
- lua_pushnil(L);
- lua_pushstring(L,mplib_data->log_out);
- xfree(mplib_data->ps_out);
- return 2;
- }
- }
- lua_pushnil(L);
- return 1;
-}
-
-static int
-mplib_fig_filename (lua_State *L) {
- struct mp_edge_object **hh = is_fig(L,1);
- if (*hh!= NULL) {
- char *s = (*hh)->_filename;
- lua_pushstring(L,s);
- } else {
- lua_pushnil(L);
- }
- return 1;
-}
-
-
-static int
-mplib_fig_bb (lua_State *L) {
- struct mp_edge_object **hh = is_fig(L,1);
- lua_newtable(L);
- lua_pushnumber(L, (double)(*hh)->_minx/65536.0);
- lua_rawseti(L,-2,1);
- lua_pushnumber(L, (double)(*hh)->_miny/65536.0);
- lua_rawseti(L,-2,2);
- lua_pushnumber(L, (double)(*hh)->_maxx/65536.0);
- lua_rawseti(L,-2,3);
- lua_pushnumber(L, (double)(*hh)->_maxy/65536.0);
- lua_rawseti(L,-2,4);
- return 1;
-}
-
-/* object methods */
-
-static int
-mplib_gr_collect (lua_State *L) {
- struct mp_graphic_object **hh = is_gr_object(L,1);
- if (*hh!=NULL) {
- mp_gr_toss_object(*hh);
- *hh=NULL;
- }
- return 0;
-}
-
-static int
-mplib_gr_tostring (lua_State *L) {
- struct mp_graphic_object **hh = is_gr_object(L,1);
- lua_pushfstring(L,"<object %p>",*hh);
- return 1;
-}
-
-
-static int
-mplib_gr_fields (lua_State *L) {
- const char **fields;
- int i ;
- struct mp_graphic_object **hh = is_gr_object(L,1);
- if (*hh) {
- switch ((*hh)->_type_field) {
- case mp_fill_code: fields = fill_fields; break;
- case mp_stroked_code: fields = stroked_fields; break;
- case mp_text_code: fields = text_fields; break;
- case mp_special_code: fields = special_fields; break;
- case mp_start_clip_code: fields = start_clip_fields; break;
- case mp_start_bounds_code: fields = start_bounds_fields; break;
- case mp_stop_clip_code: fields = stop_clip_fields; break;
- case mp_stop_bounds_code: fields = stop_bounds_fields; break;
- default: fields = no_fields;
- }
- lua_newtable(L);
- for (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_field != mp_explicit) {
- mplib_push_S(left_type);
- lua_pushstring(L,knot_type_enum[p->left_type_field]);
- lua_rawset(L,-3);
- }
- if (p->right_type_field != mp_explicit) {
- mplib_push_S(right_type);
- lua_pushstring(L,knot_type_enum[p->right_type_field]);
- lua_rawset(L,-3);
- }
- }
- mplib_push_S(x_coord);
- mplib_push_number(L,p->x_coord_field);
- lua_rawset(L,-3);
- mplib_push_S(y_coord);
- mplib_push_number(L,p->y_coord_field);
- lua_rawset(L,-3);
- mplib_push_S(left_x);
- mplib_push_number(L,p->left_x_field);
- lua_rawset(L,-3);
- mplib_push_S(left_y);
- mplib_push_number(L,p->left_y_field);
- lua_rawset(L,-3);
- mplib_push_S(right_x);
- mplib_push_number(L,p->right_x_field);
- lua_rawset(L,-3);
- mplib_push_S(right_y);
- mplib_push_number(L,p->right_y_field);
- lua_rawset(L,-3);
- lua_rawseti(L,-2,i); i++;
- if ( p->right_type_field==mp_endpoint ) {
- return;
- }
- p=p->next_field;
- } while (p!=h) ;
- } else {
- lua_pushnil(L);
- }
-}
-
-/* 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_field) {
- mplib_push_S(type);
- lua_pushstring(L,"elliptical");
- lua_rawset(L,-3);
- } else {
- }
-}
-
-#define set_color_objects(pq) \
- object_color_model = pq->color_model_field; \
- object_color_a = pq->color_field._a_val; \
- object_color_b = pq->color_field._b_val; \
- object_color_c = pq->color_field._c_val; \
- object_color_d = pq->color_field._d_val;
-
-
-static void
-mplib_push_color (lua_State *L, struct mp_graphic_object *p ) {
- int object_color_model;
- int object_color_a, object_color_b, object_color_c, object_color_d ;
- if (p!=NULL) {
- if (p->_type_field == mp_fill_code) {
- mp_fill_object *h = (mp_fill_object *)p;
- set_color_objects(h);
- } else if (p->_type_field == mp_stroked_code) {
- mp_stroked_object *h = (mp_stroked_object *)p;
- set_color_objects(h);
- } else {
- mp_text_object *h = (mp_text_object *)p;
- set_color_objects(h);
- }
- lua_newtable(L);
- if (object_color_model >= mp_grey_model) {
- mplib_push_number(L,object_color_a);
- lua_rawseti(L,-2,1);
- if (object_color_model >= mp_rgb_model) {
- mplib_push_number(L,object_color_b);
- lua_rawseti(L,-2,2);
- mplib_push_number(L,object_color_c);
- lua_rawseti(L,-2,3);
- if (object_color_model == mp_cmyk_model) {
- mplib_push_number(L,object_color_d);
- lua_rawseti(L,-2,4);
- }
- }
- }
- } else {
- lua_pushnil(L);
- }
-}
-
-/* the dash scale is not exported, the field has no external value */
-static void
-mplib_push_dash (lua_State *L, struct mp_stroked_object *h ) {
- mp_dash_object *d;
- double ds;
- if (h!=NULL && h->dash_p_field != NULL) {
- d = h->dash_p_field;
- lua_newtable(L);
- mplib_push_number(L,d->offset_field);
- lua_setfield(L,-2,"offset");
- if (d->array_field!=NULL ) {
- int i = 0;
- lua_newtable(L);
- while (*(d->array_field+i) != -1) {
- ds = *(d->array_field+1) / 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_field);
- lua_rawseti(L,-2,i); i++;
- mplib_push_number(L,h->ty_field);
- lua_rawseti(L,-2,i); i++;
- mplib_push_number(L,h->txx_field);
- lua_rawseti(L,-2,i); i++;
- mplib_push_number(L,h->tyx_field);
- lua_rawseti(L,-2,i); i++;
- mplib_push_number(L,h->txy_field);
- lua_rawseti(L,-2,i); i++;
- mplib_push_number(L,h->tyy_field);
- lua_rawseti(L,-2,i); i++;
- } else {
- lua_pushnil(L);
- }
-}
-
-#define FIELD(A) (mplib_is_S(A,2))
-
-static void
-mplib_fill_field (lua_State *L, struct mp_fill_object *h) {
- if (FIELD(path)) {
- mplib_push_path(L, h->path_p_field, MPLIB_PATH);
- } else if (FIELD(htap)) {
- mplib_push_path(L, h->htap_p_field, MPLIB_PATH);
- } else if (FIELD(pen)) {
- mplib_push_path(L, h->pen_p_field, MPLIB_PEN);
- mplib_push_pentype(L, h->pen_p_field);
- } else if (FIELD(color)) {
- mplib_push_color(L,(mp_graphic_object *)h);
- } else if (FIELD(linejoin)) {
- lua_pushnumber(L,h->ljoin_field);
- } else if (FIELD(miterlimit)) {
- mplib_push_number(L,h->miterlim_field);
- } else if (FIELD(prescript)) {
- lua_pushstring(L,h->pre_script_field);
- } else if (FIELD(postscript)) {
- lua_pushstring(L,h->post_script_field);
- } else {
- lua_pushnil(L);
- }
-}
-
-static void
-mplib_stroked_field (lua_State *L, struct mp_stroked_object *h) {
- if (FIELD(path)) {
- mplib_push_path(L, h->path_p_field, MPLIB_PATH);
- } else if (FIELD(pen)) {
- mplib_push_path(L, h->pen_p_field, MPLIB_PEN);
- mplib_push_pentype(L, h->pen_p_field);
- } else if (FIELD(color)) {
- mplib_push_color(L, (mp_graphic_object *)h);
- } else if (FIELD(dash)) {
- mplib_push_dash(L,h);
- } else if (FIELD(linecap)) {
- lua_pushnumber(L,h->lcap_field);
- } else if (FIELD(linejoin)) {
- lua_pushnumber(L,h->ljoin_field);
- } else if (FIELD(miterlimit)) {
- mplib_push_number(L,h->miterlim_field);
- } else if (FIELD(prescript)) {
- lua_pushstring(L,h->pre_script_field);
- } else if (FIELD(postscript)) {
- lua_pushstring(L,h->post_script_field);
- } else {
- lua_pushnil(L);
- }
-}
-
-static void
-mplib_text_field (lua_State *L, struct mp_text_object *h) {
- if (FIELD(text)) {
- lua_pushstring(L,h->text_p_field);
- } else if (FIELD(dsize)) {
- mplib_push_number(L,(h->font_dsize_field/16));
- } else if (FIELD(font)) {
- lua_pushstring(L,h->font_name_field);
- } else if (FIELD(color)) {
- mplib_push_color(L,(mp_graphic_object *)h);
- } else if (FIELD(width)) {
- mplib_push_number(L,h->width_field);
- } else if (FIELD(height)) {
- mplib_push_number(L,h->height_field);
- } else if (FIELD(depth)) {
- mplib_push_number(L,h->depth_field);
- } else if (FIELD(transform)) {
- mplib_push_transform(L,h);
- } else if (FIELD(prescript)) {
- lua_pushstring(L,h->pre_script_field);
- } else if (FIELD(postscript)) {
- lua_pushstring(L,h->post_script_field);
- } else {
- lua_pushnil(L);
- }
-}
-
-static void
-mplib_special_field (lua_State *L, struct mp_special_object *h) {
- if (FIELD(prescript)) {
- lua_pushstring(L,h->pre_script_field);
- } else {
- lua_pushnil(L);
- }
-}
-
-static void
-mplib_start_bounds_field (lua_State *L, struct mp_bounds_object *h) {
- if (FIELD(path)) {
- mplib_push_path(L,h->path_p_field, MPLIB_PATH);
- } else {
- lua_pushnil(L);
- }
-}
-
-static void
-mplib_start_clip_field (lua_State *L, struct mp_clip_object *h) {
- if (FIELD(path)) {
- mplib_push_path(L,h->path_p_field, MPLIB_PATH);
- } else {
- lua_pushnil(L);
- }
-}
-
-static int
-mplib_gr_index (lua_State *L) {
- struct mp_graphic_object **hh = is_gr_object(L,1);
- if (*hh) {
- struct mp_graphic_object *h = *hh;
-
- if (mplib_is_S(type,2)) {
- lua_rawgeti(L,LUA_REGISTRYINDEX,mplib_type_Ses[h->_type_field]);
- } else {
- switch (h->_type_field) {
- case mp_fill_code: mplib_fill_field(L,(mp_fill_object *)h); break;
- case mp_stroked_code: mplib_stroked_field(L,(mp_stroked_object *)h); break;
- case mp_text_code: mplib_text_field(L,(mp_text_object *)h); break;
- case mp_special_code: mplib_special_field(L,(mp_special_object *)h); break;
- case mp_start_clip_code: mplib_start_clip_field(L,(mp_clip_object *)h); break;
- case mp_start_bounds_code: mplib_start_bounds_field(L,(mp_bounds_object *)h); break;
- /* case mp_stop_clip_code: */
- /* case mp_stop_bounds_code: */
- default: lua_pushnil(L);
- }
- }
- } else {
- lua_pushnil(L);
- }
- return 1;
-}
-
-
-static const struct luaL_reg mplib_meta[] = {
- {"__gc", mplib_collect},
- {"__tostring", mplib_tostring},
- {NULL, NULL} /* sentinel */
-};
-
-static const struct luaL_reg mplib_fig_meta[] = {
- {"__gc", mplib_fig_collect },
- {"__tostring", mplib_fig_tostring },
- {"objects", mplib_fig_body },
- {"copy_objects", mplib_fig_copy_body },
- {"filename", mplib_fig_filename },
- {"postscript", mplib_fig_postscript },
- {"boundingbox", mplib_fig_bb },
- {NULL, NULL} /* sentinel */
-};
-
-static const struct luaL_reg mplib_gr_meta[] = {
- {"__gc", mplib_gr_collect },
- {"__tostring", mplib_gr_tostring },
- {"__index", mplib_gr_index },
- {NULL, NULL} /* sentinel */
-};
-
-
-static const struct luaL_reg mplib_d [] = {
- {"execute", mplib_execute },
- {"finish", mplib_finish },
- {"statistics", mplib_statistics },
- {NULL, NULL} /* sentinel */
-};
-
-
-static const struct luaL_reg mplib_m[] = {
- {"new", mplib_new },
- {"fields", mplib_gr_fields },
- {NULL, NULL} /* sentinel */
-};
-
-
-int
-luaopen_mp (lua_State *L) {
- mplib_init_Ses(L);
-
- luaL_newmetatable(L,MPLIB_GR_METATABLE);
- lua_pushvalue(L, -1); /* push metatable */
- lua_setfield(L, -2, "__index"); /* metatable.__index = metatable */
- luaL_register(L, NULL, mplib_gr_meta); /* object meta methods */
- lua_pop(L,1);
-
- luaL_newmetatable(L,MPLIB_FIG_METATABLE);
- lua_pushvalue(L, -1); /* push metatable */
- lua_setfield(L, -2, "__index"); /* metatable.__index = metatable */
- luaL_register(L, NULL, mplib_fig_meta); /* figure meta methods */
- lua_pop(L,1);
-
- luaL_newmetatable(L,MPLIB_METATABLE);
- lua_pushvalue(L, -1); /* push metatable */
- lua_setfield(L, -2, "__index"); /* metatable.__index = metatable */
- luaL_register(L, NULL, mplib_meta); /* meta methods */
- luaL_register(L, NULL, mplib_d); /* dict methods */
- luaL_register(L, "mplib", mplib_m); /* module functions */
- return 1;
-}
-
diff --git a/Build/source/texk/web2c/luatexdir/lua/lnodelib.c b/Build/source/texk/web2c/luatexdir/lua/lnodelib.c
index de269d5d9c8..0bbbc021987 100644
--- a/Build/source/texk/web2c/luatexdir/lua/lnodelib.c
+++ b/Build/source/texk/web2c/luatexdir/lua/lnodelib.c
@@ -1,10 +1,32 @@
-/* $Id: lnodelib.c 1056 2008-02-19 15:42:17Z taco $ */
+/* lnodelib.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 General Public License as published by the Free
+ Software Foundation; either version 2 of the License, or (at your
+ option) any later version.
+
+ LuaTeX is distributed in the hope that it will be useful, but WITHOUT
+ ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
+ FITNESS FOR A PARTICULAR PURPOSE. See the GNU Lesser General Public
+ License for more details.
+
+ You should have received a copy of the GNU General Public License along
+ with LuaTeX; if not, see <http://www.gnu.org/licenses/>. */
#include "luatex-api.h"
#include <ptexlib.h>
#include "nodes.h"
+#include "commands.h"
+
+static const char _svn_version[] =
+ "$Id: lnodelib.c 2027 2009-03-14 18:47:32Z oneiros $ $URL: http://scm.foundry.supelec.fr/svn/luatex/trunk/src/texk/web2c/luatexdir/lua/lnodelib.c $";
+
#define init_luaS_index(a) do { \
lua_pushliteral(L,#a); \
luaS_##a##_ptr = (char *)lua_tostring(L,-1); \
@@ -15,7 +37,7 @@
static int luaS_##a##_index = 0; \
static char * luaS_##a##_ptr = NULL
-#define luaS_index(a) luaS_##a##_index
+#define luaS_index(a) luaS_##a##_index
#define luaS_ptr_eq(a,b) (a==luaS_##b##_ptr)
@@ -23,75 +45,81 @@
make_luaS_index(luatex_node);
-halfword *check_isnode (lua_State *L, int ud) {
- register halfword *p = lua_touserdata(L, ud);
- if (p != NULL) {
- if (lua_getmetatable(L, ud)) {
- lua_rawgeti(L,LUA_REGISTRYINDEX,luaS_index(luatex_node));
- lua_gettable(L, LUA_REGISTRYINDEX);
- if (lua_rawequal(L, -1, -2)) {
- lua_pop(L, 2);
- return p;
- }
+halfword *check_isnode(lua_State * L, int ud)
+{
+ register halfword *p = lua_touserdata(L, ud);
+ if (p != NULL) {
+ if (lua_getmetatable(L, ud)) {
+ lua_rawgeti(L, LUA_REGISTRYINDEX, luaS_index(luatex_node));
+ lua_gettable(L, LUA_REGISTRYINDEX);
+ if (lua_rawequal(L, -1, -2)) {
+ lua_pop(L, 2);
+ return p;
+ }
+ }
}
- }
- luaL_typerror(L, ud, NODE_METATABLE);
- return NULL;
+ luaL_typerror(L, ud, NODE_METATABLE);
+ return NULL;
}
/* This routine finds the numerical value of a string (or number) at
lua stack index |n|. If it is not a valid node type, returns -1 */
-static
-int do_get_node_type_id (lua_State *L, int n, node_info *data) {
- register int j;
- if (lua_type(L,n)==LUA_TSTRING) {
- char *s = (char *)lua_tostring(L,n);
- for (j=0;data[j].id!=-1;j++) {
- if (strcmp(s,data[j].name)==0)
- return j;
- }
- } else if (lua_type(L,n)==LUA_TNUMBER) {
- register int i = lua_tointeger(L,n);
- if (data[i].id==i)
- return i;
- for (j=0;data[j].id!=-1;j++) {
- if (data[j].id==i)
- return j;
+static
+int do_get_node_type_id(lua_State * L, int n, node_info * data)
+{
+ register int j;
+ if (lua_type(L, n) == LUA_TSTRING) {
+ char *s = (char *) lua_tostring(L, n);
+ for (j = 0; data[j].id != -1; j++) {
+ if (strcmp(s, data[j].name) == 0)
+ return j;
+ }
+ } else if (lua_type(L, n) == LUA_TNUMBER) {
+ register int i = lua_tointeger(L, n);
+ for (j = 0; data[j].id != -1; j++) {
+ if (data[j].id == i)
+ return j;
+ }
}
- }
- return -1;
+ return -1;
}
#define get_node_type_id(L,n) do_get_node_type_id(L,n,node_data)
#define get_node_subtype_id(L,n) do_get_node_type_id(L,n,whatsit_node_data)
-static
-int get_valid_node_type_id (lua_State *L, int n) {
- int i = get_node_type_id(L,n);
- if (i==-1) {
- if (lua_type(L,n)==LUA_TSTRING) {
- lua_pushfstring(L, "Invalid node type id: %s",(char *)lua_tostring(L,n));
- } else {
- lua_pushfstring(L, "Invalid node type id: %d",(int)lua_tonumber(L,n));
+static
+int get_valid_node_type_id(lua_State * L, int n)
+{
+ int i = get_node_type_id(L, n);
+ if (i == -1) {
+ if (lua_type(L, n) == LUA_TSTRING) {
+ lua_pushfstring(L, "Invalid node type id: %s",
+ (char *) lua_tostring(L, n));
+ } else {
+ lua_pushfstring(L, "Invalid node type id: %d",
+ (int) lua_tonumber(L, n));
+ }
+ return lua_error(L);
}
- return lua_error(L);
- }
- return i;
+ return i;
}
-static
-int get_valid_node_subtype_id (lua_State *L, int n) {
- int i = get_node_subtype_id(L,n);
- if (i==-1) {
- if (lua_type(L,n)==LUA_TSTRING) {
- lua_pushfstring(L, "Invalid whatsit node id: %s",(char *)lua_tostring(L,n));
- } else {
- lua_pushfstring(L, "Invalid whatsit node id: %d",(int)lua_tonumber(L,n));
+static
+int get_valid_node_subtype_id(lua_State * L, int n)
+{
+ int i = get_node_subtype_id(L, n);
+ if (i == -1) {
+ if (lua_type(L, n) == LUA_TSTRING) {
+ lua_pushfstring(L, "Invalid whatsit node id: %s",
+ (char *) lua_tostring(L, n));
+ } else {
+ lua_pushfstring(L, "Invalid whatsit node id: %d",
+ (int) lua_tonumber(L, n));
+ }
+ return lua_error(L);
}
- return lua_error(L);
- }
- return i;
+ return i;
}
@@ -103,362 +131,454 @@ int get_valid_node_subtype_id (lua_State *L, int n) {
range. This test could be improved.
*/
-void
-lua_nodelib_push(lua_State *L) {
- halfword n;
- halfword *a;
- n = -1;
- if (lua_isnumber(L,-1)) {
- n = lua_tointeger(L,-1);
- }
- lua_pop(L,1);
- if ((n==null) || (n<0) || (n>var_mem_max)) {
- lua_pushnil(L);
- } else {
- a = lua_newuserdata(L, sizeof(halfword));
- *a = n;
- lua_rawgeti(L,LUA_REGISTRYINDEX,luaS_index(luatex_node));
- lua_gettable(L, LUA_REGISTRYINDEX);
- lua_setmetatable(L,-2);
- }
- return;
+void lua_nodelib_push(lua_State * L)
+{
+ halfword n;
+ halfword *a;
+ n = -1;
+ if (lua_isnumber(L, -1)) {
+ n = lua_tointeger(L, -1);
+ }
+ lua_pop(L, 1);
+ if ((n == null) || (n < 0) || (n > var_mem_max)) {
+ lua_pushnil(L);
+ } else {
+ a = lua_newuserdata(L, sizeof(halfword));
+ *a = n;
+ lua_rawgeti(L, LUA_REGISTRYINDEX, luaS_index(luatex_node));
+ lua_gettable(L, LUA_REGISTRYINDEX);
+ lua_setmetatable(L, -2);
+ }
+ return;
}
-void
-lua_nodelib_push_fast(lua_State *L, halfword n) {
- halfword *a;
- a = lua_newuserdata(L, sizeof(halfword));
- *a = n;
- lua_rawgeti(L,LUA_REGISTRYINDEX,luaS_index(luatex_node));
- lua_gettable(L, LUA_REGISTRYINDEX);
- lua_setmetatable(L,-2);
- return;
+void lua_nodelib_push_fast(lua_State * L, halfword n)
+{
+ halfword *a;
+ a = lua_newuserdata(L, sizeof(halfword));
+ *a = n;
+ lua_rawgeti(L, LUA_REGISTRYINDEX, luaS_index(luatex_node));
+ lua_gettable(L, LUA_REGISTRYINDEX);
+ lua_setmetatable(L, -2);
+ return;
}
/* converts type strings to type ids */
-static int
-lua_nodelib_id (lua_State *L) {
- integer i = get_node_type_id(L,1);
- if (i>=0) {
- lua_pushnumber(L,i);
- } else {
- lua_pushnil(L);
- }
- return 1;
+static int lua_nodelib_id(lua_State * L)
+{
+ integer i = get_node_type_id(L, 1);
+ if (i >= 0) {
+ lua_pushnumber(L, i);
+ } else {
+ lua_pushnil(L);
+ }
+ return 1;
}
-static int
-lua_nodelib_subtype (lua_State *L) {
- integer i = get_node_subtype_id(L,1);
- if (i>=0) {
- lua_pushnumber(L,i);
- } else {
- lua_pushnil(L);
- }
- return 1;
+static int lua_nodelib_subtype(lua_State * L)
+{
+ integer i = get_node_subtype_id(L, 1);
+ if (i >= 0) {
+ lua_pushnumber(L, i);
+ } else {
+ lua_pushnil(L);
+ }
+ return 1;
}
/* converts id numbers to type names */
-static int
-lua_nodelib_type (lua_State *L) {
- integer i = get_node_type_id(L,1);
- if (i>=0) {
- lua_pushstring(L,node_data[i].name);
- } else {
- lua_pushnil(L);
- }
- return 1;
+static int lua_nodelib_type(lua_State * L)
+{
+ integer i = get_node_type_id(L, 1);
+ if (i >= 0) {
+ lua_pushstring(L, node_data[i].name);
+ } else {
+ lua_pushnil(L);
+ }
+ return 1;
}
/* allocate a new node */
-static int
-lua_nodelib_new(lua_State *L) {
- int i,j;
- halfword n = null;
- i = get_valid_node_type_id(L,1);
-
- if (i==whatsit_node) {
- j = -1;
- if (lua_gettop(L)>1) { j = get_valid_node_subtype_id(L,2); }
- if (j<0) {
- lua_pushstring(L, "Creating a whatsit requires the subtype number as a second argument");
- lua_error(L);
- }
- } else {
- j = 0;
- if (lua_gettop(L)>1) { j = lua_tointeger(L,2); }
- }
- n = new_node(i,j);
- lua_nodelib_push_fast(L,n);
- return 1;
+static int lua_nodelib_new(lua_State * L)
+{
+ int i, j;
+ halfword n = null;
+ i = get_valid_node_type_id(L, 1);
+
+ if (i == whatsit_node) {
+ j = -1;
+ if (lua_gettop(L) > 1) {
+ j = get_valid_node_subtype_id(L, 2);
+ }
+ if (j < 0) {
+ lua_pushstring(L,
+ "Creating a whatsit requires the subtype number as a second argument");
+ lua_error(L);
+ }
+ } else {
+ j = 0;
+ if (lua_gettop(L) > 1) {
+ j = lua_tointeger(L, 2);
+ }
+ }
+ n = new_node(i, j);
+ lua_nodelib_push_fast(L, n);
+ return 1;
}
/* Free a node.
This function returns the 'next' node, because that may be helpful */
-static int
-lua_nodelib_free(lua_State *L) {
- halfword *n;
- halfword p;
- if (lua_gettop(L)<1) {
- lua_pushnil(L);
+static int lua_nodelib_free(lua_State * L)
+{
+ halfword *n;
+ halfword p;
+ if (lua_gettop(L) < 1) {
+ lua_pushnil(L);
+ return 1;
+ } else if (lua_isnil(L, 1)) {
+ return 1; /* the nil itself */
+ }
+ n = check_isnode(L, 1);
+ p = vlink(*n);
+ flush_node(*n);
+ lua_pushnumber(L, p);
+ lua_nodelib_push(L);
return 1;
- } else if(lua_isnil(L,1)) {
- return 1; /* the nil itself */
- }
- n = check_isnode(L,1);
- p = vlink(*n);
- flush_node(*n);
- lua_pushnumber(L,p);
- lua_nodelib_push(L);
- return 1;
}
/* Free a node list */
-static int
-lua_nodelib_flush_list(lua_State *L) {
- halfword *n_ptr;
- if ((lua_gettop(L)<1) || lua_isnil(L,1))
+static int lua_nodelib_flush_list(lua_State * L)
+{
+ halfword *n_ptr;
+ if ((lua_gettop(L) < 1) || lua_isnil(L, 1))
+ return 0;
+ n_ptr = check_isnode(L, 1);
+ flush_node_list(*n_ptr);
return 0;
- n_ptr = check_isnode(L,1);
- flush_node_list(*n_ptr);
- return 0;
}
/* find prev, and fix backlinks */
-#define set_t_to_prev(head,current) \
- t = head; \
- while (vlink(t)!=current && t != null) { \
- if (vlink(t)!=null) \
- alink(vlink(t)) = t; \
- t = vlink(t); \
+#define set_t_to_prev(head,current) \
+ t = head; \
+ while (vlink(t)!=current && t != null) { \
+ if (vlink(t)!=null) \
+ alink(vlink(t)) = t; \
+ t = vlink(t); \
}
/* remove a node from a list */
-static int
-lua_nodelib_remove (lua_State *L) {
- halfword head, current, t;
- if (lua_gettop(L)<2) {
- lua_pushstring(L,"Not enough arguments for node.remove()");
- lua_error(L);
- }
- head = *(check_isnode(L,1));
- if (lua_isnil(L,2)) {
- return 2; /* the arguments, as they are */
- }
- current = *(check_isnode(L,2));
-
- if (head == current) {
- if (alink(head)!=null && vlink(current)!=null) {
- alink(vlink(current)) = alink(head);
- }
- head = vlink(current);
- current = head;
- } else { /* head != current */
- t = alink(current);
- if (t==null || vlink(t)!=current) {
- set_t_to_prev(head,current);
- if (t==null) { /* error! */
- lua_pushstring(L,"Attempt to node.remove() a non-existing node");
- lua_error(L);
- }
- }
- /* t is now the previous node */
- vlink(t) = vlink(current);
- if (vlink(current)!=null) {
- alink(vlink(current)) = t;
- }
- current = vlink(current);
- }
- lua_pushnumber(L,head);
- lua_nodelib_push(L);
- lua_pushnumber(L,current);
- lua_nodelib_push(L);
- return 2;
+static int lua_nodelib_remove(lua_State * L)
+{
+ halfword head, current, t;
+ if (lua_gettop(L) < 2) {
+ lua_pushstring(L, "Not enough arguments for node.remove()");
+ lua_error(L);
+ }
+ head = *(check_isnode(L, 1));
+ if (lua_isnil(L, 2)) {
+ return 2; /* the arguments, as they are */
+ }
+ current = *(check_isnode(L, 2));
+
+ if (head == current) {
+ if (alink(head) != null && vlink(current) != null) {
+ alink(vlink(current)) = alink(head);
+ }
+ head = vlink(current);
+ current = head;
+ } else { /* head != current */
+ t = alink(current);
+ if (t == null || vlink(t) != current) {
+ set_t_to_prev(head, current);
+ if (t == null) { /* error! */
+ lua_pushstring(L,
+ "Attempt to node.remove() a non-existing node");
+ lua_error(L);
+ }
+ }
+ /* t is now the previous node */
+ vlink(t) = vlink(current);
+ if (vlink(current) != null) {
+ alink(vlink(current)) = t;
+ }
+ current = vlink(current);
+ }
+ lua_pushnumber(L, head);
+ lua_nodelib_push(L);
+ lua_pushnumber(L, current);
+ lua_nodelib_push(L);
+ return 2;
}
/* Insert a node in a list */
-static int
-lua_nodelib_insert_before (lua_State *L) {
- halfword head, current, n, t;
- if (lua_gettop(L)<3) {
- lua_pushstring(L,"Not enough arguments for node.insert_before()");
- lua_error(L);
- }
- if (lua_isnil(L,3)) {
- lua_pop(L,1);
- return 2;
- } else {
- n = *(check_isnode(L,3));
- }
- if (lua_isnil(L,1)) { /* no head */
- vlink(n) = null;
- alink(n) = null;
- lua_nodelib_push_fast(L,n);
- lua_pushvalue(L,-1);
- return 2;
- } else {
- head = *(check_isnode(L,1));
- }
- if (lua_isnil(L,2)) {
- current = tail_of_list(head);
- } else {
- current = *(check_isnode(L,2));
- }
- t = alink(current);
- if (t==null || vlink(t)!=current) {
- set_t_to_prev(head,current);
- if (t==null) { /* error! */
- lua_pushstring(L,"Attempt to node.insert_before() a non-existing node");
- lua_error(L);
+static int lua_nodelib_insert_before(lua_State * L)
+{
+ halfword head, current, n, t;
+ if (lua_gettop(L) < 3) {
+ lua_pushstring(L, "Not enough arguments for node.insert_before()");
+ lua_error(L);
}
- }
- couple_nodes(t,n);
- couple_nodes(n,current);
- if (head==current) {
- lua_nodelib_push_fast(L,n);
- } else {
- lua_nodelib_push_fast(L,head);
- }
- lua_nodelib_push_fast(L,n);
- return 2;
+ if (lua_isnil(L, 3)) {
+ lua_pop(L, 1);
+ return 2;
+ } else {
+ n = *(check_isnode(L, 3));
+ }
+ if (lua_isnil(L, 1)) { /* no head */
+ vlink(n) = null;
+ alink(n) = null;
+ lua_nodelib_push_fast(L, n);
+ lua_pushvalue(L, -1);
+ return 2;
+ } else {
+ head = *(check_isnode(L, 1));
+ }
+ if (lua_isnil(L, 2)) {
+ current = tail_of_list(head);
+ } else {
+ current = *(check_isnode(L, 2));
+ }
+ if (head != current) {
+ t = alink(current);
+ if (t == null || vlink(t) != current) {
+ set_t_to_prev(head, current);
+ if (t == null) { /* error! */
+ lua_pushstring(L,
+ "Attempt to node.insert_before() a non-existing node");
+ lua_error(L);
+ }
+ }
+ couple_nodes(t, n);
+ }
+ couple_nodes(n, current);
+ if (head == current) {
+ lua_nodelib_push_fast(L, n);
+ } else {
+ lua_nodelib_push_fast(L, head);
+ }
+ lua_nodelib_push_fast(L, n);
+ return 2;
}
-static int
-lua_nodelib_insert_after (lua_State *L) {
- halfword head, current, n;
- if (lua_gettop(L)<3) {
- lua_pushstring(L,"Not enough arguments for node.insert_after()");
- lua_error(L);
- }
- if (lua_isnil(L,3)) {
- lua_pop(L,1);
- return 2;
- } else {
- n = *(check_isnode(L,3));
- }
- if (lua_isnil(L,1)) { /* no head */
- vlink(n) = null;
- alink(n) = null;
- lua_nodelib_push_fast(L,n);
- lua_pushvalue(L,-1);
- return 2;
- } else {
- head = *(check_isnode(L,1));
- }
- if (lua_isnil(L,2)) {
- current = head;
- while (vlink(current)!=null)
- current = vlink(current);
- } else {
- current = *(check_isnode(L,2));
- }
- try_couple_nodes(n,vlink(current));
- couple_nodes(current, n);
+static int lua_nodelib_insert_after(lua_State * L)
+{
+ halfword head, current, n;
+ if (lua_gettop(L) < 3) {
+ lua_pushstring(L, "Not enough arguments for node.insert_after()");
+ lua_error(L);
+ }
+ if (lua_isnil(L, 3)) {
+ lua_pop(L, 1);
+ return 2;
+ } else {
+ n = *(check_isnode(L, 3));
+ }
+ if (lua_isnil(L, 1)) { /* no head */
+ vlink(n) = null;
+ alink(n) = null;
+ lua_nodelib_push_fast(L, n);
+ lua_pushvalue(L, -1);
+ return 2;
+ } else {
+ head = *(check_isnode(L, 1));
+ }
+ if (lua_isnil(L, 2)) {
+ current = head;
+ while (vlink(current) != null)
+ current = vlink(current);
+ } else {
+ current = *(check_isnode(L, 2));
+ }
+ try_couple_nodes(n, vlink(current));
+ couple_nodes(current, n);
- lua_pop(L,2);
- lua_nodelib_push_fast(L,n);
- return 2;
+ lua_pop(L, 2);
+ lua_nodelib_push_fast(L, n);
+ return 2;
}
/* Copy a node list */
-static int
-lua_nodelib_copy_list (lua_State *L) {
- halfword *n;
- halfword m;
- if (lua_isnil(L,1))
- return 1; /* the nil itself */
- n = check_isnode(L,1);
- m = copy_node_list(*n);
- lua_nodelib_push_fast(L,m);
- return 1;
+static int lua_nodelib_copy_list(lua_State * L)
+{
+ halfword *n;
+ halfword m;
+ if (lua_isnil(L, 1))
+ return 1; /* the nil itself */
+ n = check_isnode(L, 1);
+ m = copy_node_list(*n);
+ lua_nodelib_push_fast(L, m);
+ return 1;
}
/* (Deep) copy a node */
-static int
-lua_nodelib_copy(lua_State *L) {
- halfword *n;
- halfword m;
- if (lua_isnil(L,1))
- return 1; /* the nil itself */
- n = check_isnode(L,1);
- m = copy_node(*n);
- lua_nodelib_push_fast(L,m);
- return 1;
+static int lua_nodelib_copy(lua_State * L)
+{
+ halfword *n;
+ halfword m;
+ if (lua_isnil(L, 1))
+ return 1; /* the nil itself */
+ n = check_isnode(L, 1);
+ m = copy_node(*n);
+ lua_nodelib_push_fast(L, m);
+ return 1;
}
/* output (write) a node to tex's processor */
-static int
-lua_nodelib_append(lua_State *L) {
- halfword *n;
- halfword m;
- int i, j;
- j = lua_gettop(L);
- for (i=1;i<=j;i++) {
- n = check_isnode(L,i);
- m = copy_node_list(*n);
- new_tail_append(m);
- while (vlink(m)!= null) {
- m = vlink(m);
- new_tail_append(m);
- }
- }
- return 0;
+static int lua_nodelib_append(lua_State * L)
+{
+ halfword *n;
+ halfword m;
+ int i, j;
+ j = lua_gettop(L);
+ for (i = 1; i <= j; i++) {
+ n = check_isnode(L, i);
+ m = copy_node_list(*n);
+ new_tail_append(m);
+ while (vlink(m) != null) {
+ m = vlink(m);
+ new_tail_append(m);
+ }
+ }
+ return 0;
}
-static int
-lua_nodelib_last_node(lua_State *L) {
- halfword m;
- m = pop_tail();
- lua_pushnumber(L,m);
- lua_nodelib_push(L);
- return 1;
+static int lua_nodelib_last_node(lua_State * L)
+{
+ halfword m;
+ m = pop_tail();
+ lua_pushnumber(L, m);
+ lua_nodelib_push(L);
+ return 1;
}
/* build a hbox */
-static int
-lua_nodelib_hpack(lua_State *L) {
- halfword n, p;
- char *s;
- integer w = 0;
- int m = 1;
- n = *(check_isnode(L,1));
- if (lua_gettop(L)>1) {
- w = lua_tointeger(L,2);
- if (lua_gettop(L)>2 && lua_type(L,3)==LUA_TSTRING) {
- s = (char *)lua_tostring(L,3);
- if (strcmp(s,"additional")==0) {
- m = 1;
- } else {
- m = lua_tonumber(L,3);
- }
+static int lua_nodelib_hpack(lua_State * L)
+{
+ halfword n, p;
+ char *s;
+ integer w = 0;
+ int m = 1;
+ n = *(check_isnode(L, 1));
+ if (lua_gettop(L) > 1) {
+ w = lua_tointeger(L, 2);
+ if (lua_gettop(L) > 2) {
+ if (lua_type(L, 3) == LUA_TSTRING) {
+ s = (char *) lua_tostring(L, 3);
+ if (strcmp(s, "additional") == 0)
+ m = 1;
+ else if (strcmp(s, "exactly") == 0)
+ m = 0;
+ else {
+ lua_pushstring(L,
+ "3rd argument should be either additional or exactly");
+ lua_error(L);
+ }
+ }
+
+ else if (lua_type(L, 3) == LUA_TNUMBER) {
+ m = lua_tonumber(L, 3);
+ } else {
+ lua_pushstring(L, "incorrect 3rd argument");
+ }
+ }
}
- }
- p = hpack(n,w,m);
- lua_nodelib_push_fast(L,p);
- return 1;
+ p = hpack(n, w, m);
+ lua_nodelib_push_fast(L, p);
+ return 1;
+}
+
+
+/* build a vbox */
+static int lua_nodelib_vpack(lua_State * L)
+{
+ halfword n, p;
+ char *s;
+ integer w = 0;
+ int m = 1;
+ n = *(check_isnode(L, 1));
+ if (lua_gettop(L) > 1) {
+ w = lua_tointeger(L, 2);
+ if (lua_gettop(L) > 2) {
+ if (lua_type(L, 3) == LUA_TSTRING) {
+ s = (char *) lua_tostring(L, 3);
+ if (strcmp(s, "additional") == 0)
+ m = 1;
+ else if (strcmp(s, "exactly") == 0)
+ m = 0;
+ else {
+ lua_pushstring(L,
+ "3rd argument should be either additional or exactly");
+ lua_error(L);
+ }
+ }
+
+ else if (lua_type(L, 3) == LUA_TNUMBER) {
+ m = lua_tonumber(L, 3);
+ } else {
+ lua_pushstring(L, "incorrect 3rd argument");
+ }
+ }
+ }
+ p = vpackage(n, w, m, max_dimen);
+ lua_nodelib_push_fast(L, p);
+ return 1;
+}
+
+
+/* create a hlist from a formula */
+
+static int lua_nodelib_mlist_to_hlist(lua_State * L)
+{
+ halfword n;
+ int w;
+ boolean m;
+ n = *(check_isnode(L, 1));
+ w = luaL_checkoption(L, 2, "text", math_style_names);
+ luaL_checkany(L, 3);
+ m = lua_toboolean(L, 3);
+ cur_mlist = n;
+ cur_style = w;
+ mlist_penalties = m;
+ mlist_to_hlist();
+ lua_nodelib_push_fast(L, vlink(temp_head));
+ return 1;
}
+static int lua_nodelib_mfont(lua_State * L)
+{
+ int f, s;
+ f = luaL_checkinteger(L, 1);
+ if (lua_gettop(L) == 2)
+ s = lua_tointeger(L, 2); /* this should be a multiple of 256 ! */
+ else
+ s = 0;
+ lua_pushnumber(L, fam_fnt(f, s));
+ return 1;
+}
+
+
+
/* This function is similar to |get_node_type_id|, for field
identifiers. It has to do some more work, because not all
identifiers are valid for all types of nodes.
@@ -486,338 +606,363 @@ make_luaS_index(xoffset);
make_luaS_index(yoffset);
-void initialize_luaS_indexes(lua_State *L) {
- init_luaS_index(id);
- init_luaS_index(next);
- init_luaS_index(char);
- init_luaS_index(font);
- init_luaS_index(attr);
- init_luaS_index(prev);
- init_luaS_index(lang);
- init_luaS_index(subtype);
- init_luaS_index(left);
- init_luaS_index(right);
- init_luaS_index(uchyph);
- init_luaS_index(components);
- init_luaS_index(xoffset);
- init_luaS_index(yoffset);
+void initialize_luaS_indexes(lua_State * L)
+{
+ init_luaS_index(id);
+ init_luaS_index(next);
+ init_luaS_index(char);
+ init_luaS_index(font);
+ init_luaS_index(attr);
+ init_luaS_index(prev);
+ init_luaS_index(lang);
+ init_luaS_index(subtype);
+ init_luaS_index(left);
+ init_luaS_index(right);
+ init_luaS_index(uchyph);
+ init_luaS_index(components);
+ init_luaS_index(xoffset);
+ init_luaS_index(yoffset);
}
-static int
-get_node_field_id (lua_State *L, int n, int node ) {
- register int t = type(node);
- register char *s = (char *)lua_tostring(L,n);
- if (luaS_ptr_eq(s,next)) { return 0; }
- else if (luaS_ptr_eq(s,id)) { return 1; }
- else if (luaS_ptr_eq(s,attr) &&
- nodetype_has_attributes(t)) { return 3 ; }
- else if (t==glyph_node) {
- if (luaS_ptr_eq(s,subtype)) { return 2; }
- else if (luaS_ptr_eq(s,font)) { return 5; }
- else if (luaS_ptr_eq(s,char)) { return 4; }
- else if (luaS_ptr_eq(s,prev)) { return -1; }
- else if (luaS_ptr_eq(s,lang)) { return 6; }
- else if (luaS_ptr_eq(s,left)) { return 7; }
- else if (luaS_ptr_eq(s,right)) { return 8; }
- else if (luaS_ptr_eq(s,uchyph)) { return 9; }
- else if (luaS_ptr_eq(s,components)) { return 10; }
- else if (luaS_ptr_eq(s,xoffset)) { return 11; }
- else if (luaS_ptr_eq(s,yoffset)) { return 12; }
- }
- else if (luaS_ptr_eq(s,prev)) { return -1; }
- else if (luaS_ptr_eq(s,subtype)) { return 2; }
- else {
- int j;
- char **fields = node_data[t].fields;
- if (t==whatsit_node)
- fields = whatsit_node_data[subtype(node)].fields;
- for (j=0;fields[j]!=NULL;j++) {
- if (strcmp(s,fields[j])==0) {
- return j+3;
- }
- }
- }
- return -2;
+static int get_node_field_id(lua_State * L, int n, int node)
+{
+ register int t = type(node);
+ register char *s = (char *) lua_tostring(L, n);
+ if (luaS_ptr_eq(s, next)) {
+ return 0;
+ } else if (luaS_ptr_eq(s, id)) {
+ return 1;
+ } else if (luaS_ptr_eq(s, attr) && nodetype_has_attributes(t)) {
+ return 3;
+ } else if (t == glyph_node) {
+ if (luaS_ptr_eq(s, subtype)) {
+ return 2;
+ } else if (luaS_ptr_eq(s, font)) {
+ return 5;
+ } else if (luaS_ptr_eq(s, char)) {
+ return 4;
+ } else if (luaS_ptr_eq(s, prev)) {
+ return -1;
+ } else if (luaS_ptr_eq(s, lang)) {
+ return 6;
+ } else if (luaS_ptr_eq(s, left)) {
+ return 7;
+ } else if (luaS_ptr_eq(s, right)) {
+ return 8;
+ } else if (luaS_ptr_eq(s, uchyph)) {
+ return 9;
+ } else if (luaS_ptr_eq(s, components)) {
+ return 10;
+ } else if (luaS_ptr_eq(s, xoffset)) {
+ return 11;
+ } else if (luaS_ptr_eq(s, yoffset)) {
+ return 12;
+ }
+ } else if (luaS_ptr_eq(s, prev)) {
+ return -1;
+ } else if (luaS_ptr_eq(s, subtype)) {
+ return 2;
+ } else {
+ int j;
+ char **fields = node_data[t].fields;
+ if (t == whatsit_node)
+ fields = whatsit_node_data[subtype(node)].fields;
+ for (j = 0; fields[j] != NULL; j++) {
+ if (strcmp(s, fields[j]) == 0) {
+ return j + 3;
+ }
+ }
+ }
+ return -2;
}
-static int
-get_valid_node_field_id (lua_State *L, int n, int node ) {
- int i = get_node_field_id(L,n,node);
- if (i==-2) {
- char *s = (char *)lua_tostring(L,n);
- lua_pushfstring(L, "Invalid field id %s for node type %s (%d)" , s, node_data[type(node)].name,subtype(node));
- lua_error(L);
- }
- return i;
+static int get_valid_node_field_id(lua_State * L, int n, int node)
+{
+ int i = get_node_field_id(L, n, node);
+ if (i == -2) {
+ char *s = (char *) lua_tostring(L, n);
+ lua_pushfstring(L, "Invalid field id %s for node type %s (%d)", s,
+ node_data[type(node)].name, subtype(node));
+ lua_error(L);
+ }
+ return i;
}
-static int
-lua_nodelib_has_field (lua_State *L) {
- int i= -2;
- if (!lua_isnil(L,1)) {
- i = get_node_field_id(L,2,*(check_isnode(L,1)));
- }
- lua_pushboolean(L,(i!=-2));
- return 1;
+static int lua_nodelib_has_field(lua_State * L)
+{
+ int i = -2;
+ if (!lua_isnil(L, 1)) {
+ i = get_node_field_id(L, 2, *(check_isnode(L, 1)));
+ }
+ lua_pushboolean(L, (i != -2));
+ return 1;
}
/* fetch the list of valid node types */
-static int
-do_lua_nodelib_types (lua_State *L, node_info *data) {
- int i;
- lua_newtable(L);
- for (i=0;data[i].id!=-1;i++) {
- lua_pushstring(L,data[i].name);
- lua_rawseti(L,-2,data[i].id);
- }
- return 1;
+static int do_lua_nodelib_types(lua_State * L, node_info * data)
+{
+ int i;
+ lua_newtable(L);
+ for (i = 0; data[i].id != -1; i++) {
+ lua_pushstring(L, data[i].name);
+ lua_rawseti(L, -2, data[i].id);
+ }
+ return 1;
}
-static int
-lua_nodelib_types (lua_State *L) {
- return do_lua_nodelib_types (L, node_data);
+static int lua_nodelib_types(lua_State * L)
+{
+ return do_lua_nodelib_types(L, node_data);
}
-static int
-lua_nodelib_whatsits (lua_State *L) {
- return do_lua_nodelib_types (L, whatsit_node_data);
+static int lua_nodelib_whatsits(lua_State * L)
+{
+ return do_lua_nodelib_types(L, whatsit_node_data);
}
/* fetch the list of valid fields */
-static int
-lua_nodelib_fields (lua_State *L) {
- int i = -1;
- char ** fields;
- int t = get_valid_node_type_id(L,1);
- if (t==whatsit_node ) {
- t = get_valid_node_subtype_id(L,2);
- fields = whatsit_node_data[t].fields;
- } else {
- fields = node_data[t].fields;
- }
- lua_checkstack(L,2);
- lua_newtable(L);
- lua_pushstring(L,"next");
- lua_rawseti(L,-2,0);
- lua_pushstring(L,"id");
- lua_rawseti(L,-2,1);
- lua_pushstring(L,"subtype");
- lua_rawseti(L,-2,2);
- if (fields!=NULL) {
- lua_pushstring(L,"prev");
- lua_rawseti(L,-2,-1);
- for (i=0;fields[i]!=NULL;i++) {
- lua_pushstring(L,fields[i]);
- lua_rawseti(L,-2,(i+3));
+static int lua_nodelib_fields(lua_State * L)
+{
+ int i = -1;
+ char **fields;
+ int t = get_valid_node_type_id(L, 1);
+ if (t == whatsit_node) {
+ t = get_valid_node_subtype_id(L, 2);
+ fields = whatsit_node_data[t].fields;
+ } else {
+ fields = node_data[t].fields;
}
- }
- return 1;
+ lua_checkstack(L, 2);
+ lua_newtable(L);
+ lua_pushstring(L, "next");
+ lua_rawseti(L, -2, 0);
+ lua_pushstring(L, "id");
+ lua_rawseti(L, -2, 1);
+ lua_pushstring(L, "subtype");
+ lua_rawseti(L, -2, 2);
+ if (fields != NULL) {
+ lua_pushstring(L, "prev");
+ lua_rawseti(L, -2, -1);
+ for (i = 0; fields[i] != NULL; i++) {
+ lua_pushstring(L, fields[i]);
+ lua_rawseti(L, -2, (i + 3));
+ }
+ }
+ return 1;
}
/* find the end of a list */
-static int
-lua_nodelib_tail (lua_State *L) {
- halfword *n;
- halfword t;
- if (lua_isnil(L,1))
- return 1; /* the nil itself */
- n = check_isnode(L,1);
- t=*n;
- if (t==null)
- return 1; /* the old userdata */
- alink(t) = null;
- while (vlink(t)!=null) {
- alink(vlink(t)) = t;
- t = vlink(t);
- }
- lua_nodelib_push_fast(L,t);
- return 1;
+static int lua_nodelib_tail(lua_State * L)
+{
+ halfword *n;
+ halfword t;
+ if (lua_isnil(L, 1))
+ return 1; /* the nil itself */
+ n = check_isnode(L, 1);
+ t = *n;
+ if (t == null)
+ return 1; /* the old userdata */
+ alink(t) = null;
+ while (vlink(t) != null) {
+ alink(vlink(t)) = t;
+ t = vlink(t);
+ }
+ lua_nodelib_push_fast(L, t);
+ return 1;
}
/* a few utility functions for attribute stuff */
-static int
-lua_nodelib_has_attribute (lua_State *L) {
- halfword *n;
- int i, val ;
- if (lua_isnil(L,1))
- return 1; /* the nil itself */
- n = check_isnode(L,1);
- i = lua_tointeger(L,2);
- val = luaL_optinteger(L,3,-1);
- if((val = has_attribute(*n,i,val))>=0) {
- lua_pushnumber(L,val);
- } else {
+static int lua_nodelib_has_attribute(lua_State * L)
+{
+ halfword *n;
+ int i, val;
+ n = check_isnode(L, 1);
+ if (n != NULL) {
+ i = lua_tointeger(L, 2);
+ val = luaL_optinteger(L, 3, -1);
+ if ((val = has_attribute(*n, i, val)) >= 0) {
+ lua_pushnumber(L, val);
+ return 1;
+ }
+ }
lua_pushnil(L);
- }
- return 1;
+ return 1;
}
-static int
-lua_nodelib_set_attribute (lua_State *L) {
- halfword *n;
- int i, val;
- if (lua_gettop(L)==3) {
- i = lua_tointeger(L,2);
- val = lua_tointeger(L,3);
- n = check_isnode(L,1);
- if (val<0) {
- (void)unset_attribute(*n,i,val);
+static int lua_nodelib_set_attribute(lua_State * L)
+{
+ halfword *n;
+ int i, val;
+ if (lua_gettop(L) == 3) {
+ i = lua_tointeger(L, 2);
+ val = lua_tointeger(L, 3);
+ n = check_isnode(L, 1);
+ if (val < 0) {
+ (void) unset_attribute(*n, i, val);
+ } else {
+ set_attribute(*n, i, val);
+ }
} else {
- set_attribute(*n,i,val);
+ lua_pushstring(L, "incorrect number of arguments");
+ lua_error(L);
}
- } else {
- lua_pushstring(L,"incorrect number of arguments");
- lua_error(L);
- }
- return 0;
+ return 0;
}
-static int
-lua_nodelib_unset_attribute (lua_State *L) {
- halfword *n;
- int i, val, ret;
- if (lua_gettop(L)<=3) {
- i = luaL_checknumber(L,2);
- val = luaL_optnumber(L,3,-1);
- n = check_isnode(L,1);
- ret = unset_attribute(*n,i,val);
- if(ret>=0) {
- lua_pushnumber(L,ret);
+static int lua_nodelib_unset_attribute(lua_State * L)
+{
+ halfword *n;
+ int i, val, ret;
+ if (lua_gettop(L) <= 3) {
+ i = luaL_checknumber(L, 2);
+ val = luaL_optnumber(L, 3, -1);
+ n = check_isnode(L, 1);
+ ret = unset_attribute(*n, i, val);
+ if (ret >= 0) {
+ lua_pushnumber(L, ret);
+ } else {
+ lua_pushnil(L);
+ }
+ return 1;
} else {
- lua_pushnil(L);
+ lua_pushstring(L, "incorrect number of arguments");
+ return lua_error(L);
}
- return 1;
- } else {
- lua_pushstring(L,"incorrect number of arguments");
- return lua_error(L);
- }
}
/* iteration */
-static int nodelib_aux_nil (lua_State *L) {
- lua_pushnil(L);
- return 1;
+static int nodelib_aux_nil(lua_State * L)
+{
+ lua_pushnil(L);
+ return 1;
}
-static int
-nodelib_aux_next_filtered (lua_State *L) {
- register halfword t; /* traverser */
- register int i = lua_tointeger(L,lua_upvalueindex(1));
- if (lua_isnil(L,2)) { /* first call */
- t = *check_isnode(L,1);
- } else {
- t = *check_isnode(L,2);
- t = vlink(t);
- }
- while (t!=null && type(t)!=i) { t = vlink(t); }
- if (t==null) {
- lua_pushnil(L);
- } else {
- lua_nodelib_push_fast(L,t);
- }
- return 1;
+static int nodelib_aux_next_filtered(lua_State * L)
+{
+ register halfword t; /* traverser */
+ register int i = lua_tointeger(L, lua_upvalueindex(1));
+ if (lua_isnil(L, 2)) { /* first call */
+ t = *check_isnode(L, 1);
+ } else {
+ t = *check_isnode(L, 2);
+ t = vlink(t);
+ }
+ while (t != null && type(t) != i) {
+ t = vlink(t);
+ }
+ if (t == null) {
+ lua_pushnil(L);
+ } else {
+ lua_nodelib_push_fast(L, t);
+ }
+ return 1;
}
-static int
-lua_nodelib_traverse_filtered (lua_State *L) {
- halfword n;
- if (lua_isnil(L,2)) {
- lua_pushcclosure(L, nodelib_aux_nil, 0);
- return 1;
- }
- n = *(check_isnode(L,2));
- lua_pop(L,1); /* the node, integer remains */
- lua_pushcclosure(L, nodelib_aux_next_filtered, 1);
- lua_nodelib_push_fast(L,n);
- lua_pushnil(L);
- return 3;
-}
-
-static int
-nodelib_aux_next (lua_State *L) {
- register halfword t; /* traverser */
- if (lua_isnil(L,2)) { /* first call */
- t = *check_isnode(L,1);
- } else {
- t = *check_isnode(L,2);
- t = vlink(t);
- }
- if (t==null) {
+static int lua_nodelib_traverse_filtered(lua_State * L)
+{
+ halfword n;
+ if (lua_isnil(L, 2)) {
+ lua_pushcclosure(L, nodelib_aux_nil, 0);
+ return 1;
+ }
+ n = *(check_isnode(L, 2));
+ lua_pop(L, 1); /* the node, integer remains */
+ lua_pushcclosure(L, nodelib_aux_next_filtered, 1);
+ lua_nodelib_push_fast(L, n);
lua_pushnil(L);
- } else {
- lua_nodelib_push_fast(L,t);
- }
- return 1;
+ return 3;
}
-static int
-lua_nodelib_traverse (lua_State *L) {
- halfword n;
- if (lua_isnil(L,1)) {
- lua_pushcclosure(L, nodelib_aux_nil, 0);
+static int nodelib_aux_next(lua_State * L)
+{
+ register halfword t; /* traverser */
+ if (lua_isnil(L, 2)) { /* first call */
+ t = *check_isnode(L, 1);
+ } else {
+ t = *check_isnode(L, 2);
+ t = vlink(t);
+ }
+ if (t == null) {
+ lua_pushnil(L);
+ } else {
+ lua_nodelib_push_fast(L, t);
+ }
return 1;
- }
- n = *(check_isnode(L,1));
- lua_pushcclosure(L, nodelib_aux_next, 0);
- lua_nodelib_push_fast(L,n);
- lua_pushnil(L);
- return 3;
-;
+}
+
+static int lua_nodelib_traverse(lua_State * L)
+{
+ halfword n;
+ if (lua_isnil(L, 1)) {
+ lua_pushcclosure(L, nodelib_aux_nil, 0);
+ return 1;
+ }
+ n = *(check_isnode(L, 1));
+ lua_pushcclosure(L, nodelib_aux_next, 0);
+ lua_nodelib_push_fast(L, n);
+ lua_pushnil(L);
+ return 3;
+ ;
}
static int
-do_lua_nodelib_count (lua_State *L, halfword match, int i, halfword first) {
- int count = 0;
- int t = first;
- while (t!=match) {
- if (i<0 || type(t)==i) { count++; }
- t = vlink(t);
- }
- lua_pushnumber(L,count);
- return 1;
+do_lua_nodelib_count(lua_State * L, halfword match, int i, halfword first)
+{
+ int count = 0;
+ int t = first;
+ while (t != match) {
+ if (i < 0 || type(t) == i) {
+ count++;
+ }
+ t = vlink(t);
+ }
+ lua_pushnumber(L, count);
+ return 1;
}
-static int lua_nodelib_length (lua_State *L) {
- halfword n;
- halfword m = null;
- if (lua_isnil(L,1)) {
- lua_pushnumber(L,0);
- return 1;
- }
- n = *(check_isnode(L,1));
- if (lua_gettop(L)==2) {
- m = *(check_isnode(L,2));
- }
- return do_lua_nodelib_count(L,m,-1,n);
+static int lua_nodelib_length(lua_State * L)
+{
+ halfword n;
+ halfword m = null;
+ if (lua_isnil(L, 1)) {
+ lua_pushnumber(L, 0);
+ return 1;
+ }
+ n = *(check_isnode(L, 1));
+ if (lua_gettop(L) == 2) {
+ m = *(check_isnode(L, 2));
+ }
+ return do_lua_nodelib_count(L, m, -1, n);
}
-static int lua_nodelib_count (lua_State *L) {
- halfword n;
- halfword m = null;
- int i = -1;
- i = lua_tointeger(L,1);
- if (lua_isnil(L,2)) {
- lua_pushnumber(L,0);
- return 1;
- }
- n = *(check_isnode(L,2));
- if (lua_gettop(L)==3)
- m = *(check_isnode(L,3));
- return do_lua_nodelib_count(L,m,i,n);
+static int lua_nodelib_count(lua_State * L)
+{
+ halfword n;
+ halfword m = null;
+ int i = -1;
+ i = lua_tointeger(L, 1);
+ if (lua_isnil(L, 2)) {
+ lua_pushnumber(L, 0);
+ return 1;
+ }
+ n = *(check_isnode(L, 2));
+ if (lua_gettop(L) == 3)
+ m = *(check_isnode(L, 3));
+ return do_lua_nodelib_count(L, m, i, n);
}
/* fetching a field from a node */
@@ -828,1140 +973,2332 @@ static int lua_nodelib_count (lua_State *L) {
#define nodelib_pushaction(L,n) { lua_pushnumber(L,n); lua_nodelib_push(L); }
#define nodelib_pushstring(L,n) { lua_pushstring(L,makecstring(n)); }
-static void
-lua_nodelib_getfield_whatsit (lua_State *L, int n, int field) {
- if (field==2) {
- lua_pushnumber(L,subtype(n));
- } else {
- switch (subtype(n)) {
- case open_node:
- switch (field) {
- case 4: lua_pushnumber(L,write_stream(n)); break;
- case 5: nodelib_pushstring(L,open_name(n)); break;
- case 6: nodelib_pushstring(L,open_area(n)); break;
- case 7: nodelib_pushstring(L,open_ext(n)); break;
- default: lua_pushnil(L);
- }
- break;
- case write_node:
- switch (field) {
- case 4: lua_pushnumber(L,write_stream(n)); break;
- case 5: tokenlist_to_lua(L,write_tokens(n)); break;
- default: lua_pushnil(L);
- }
- break;
- case close_node:
- switch (field) {
- case 4: lua_pushnumber(L,write_stream(n)); break;
- default: lua_pushnil(L);
- }
- break;
- case special_node:
- switch (field) {
- case 4: tokenlist_to_luastring(L,write_tokens(n)); break;
- default: lua_pushnil(L);
- }
- break;
- case local_par_node:
- switch (field) {
- case 4: lua_pushnumber(L,local_pen_inter(n)); break;
- case 5: lua_pushnumber(L,local_pen_broken(n)); break;
- case 6: lua_pushnumber(L,local_par_dir(n)); break;
- case 7: nodelib_pushlist(L,local_box_left(n)); break;
- case 8: lua_pushnumber(L,local_box_left_width(n)); break;
- case 9: nodelib_pushlist(L,local_box_right(n)); break;
- case 10: lua_pushnumber(L,local_box_right_width(n)); break;
- default: lua_pushnil(L);
- }
- break;
- case dir_node:
- switch (field) {
- case 4: lua_pushnumber(L,dir_dir(n)); break;
- case 5: lua_pushnumber(L,dir_level(n)); break;
- case 6: lua_pushnumber(L,dir_dvi_ptr(n)); break;
- case 7: lua_pushnumber(L,dir_dvi_h(n)); break;
- default: lua_pushnil(L);
- }
- break;
- case pdf_literal_node:
- switch (field) {
- case 4: lua_pushnumber(L,pdf_literal_mode(n)); break;
- case 5: tokenlist_to_luastring(L,pdf_literal_data(n)); break;
- default: lua_pushnil(L);
- }
- break;
- case pdf_refobj_node:
- switch (field) {
- case 4: lua_pushnumber(L,pdf_obj_objnum(n)); break;
- default: lua_pushnil(L);
- }
- break;
- case pdf_refxform_node:
- switch (field) {
- case 4: lua_pushnumber(L,pdf_width(n)); break;
- case 5: lua_pushnumber(L,pdf_height(n)); break;
- case 6: lua_pushnumber(L,pdf_depth(n)); break;
- case 7: lua_pushnumber(L,pdf_xform_objnum(n)); break;
- default: lua_pushnil(L);
- }
- break;
- case pdf_refximage_node:
- switch (field) {
- case 4: lua_pushnumber(L,pdf_width(n)); break;
- case 5: lua_pushnumber(L,pdf_height(n)); break;
- case 6: lua_pushnumber(L,pdf_depth(n)); break;
- case 7: lua_pushnumber(L,pdf_ximage_objnum(n)); break;
- default: lua_pushnil(L);
- }
- break;
- case pdf_annot_node:
- switch (field) {
- case 4: lua_pushnumber(L,pdf_width(n)); break;
- case 5: lua_pushnumber(L,pdf_height(n)); break;
- case 6: lua_pushnumber(L,pdf_depth(n)); break;
- case 7: lua_pushnumber(L,pdf_annot_objnum(n)); break;
- case 8: tokenlist_to_luastring(L,pdf_annot_data(n)); break;
- default: lua_pushnil(L);
- }
- break;
- case pdf_start_link_node:
- switch (field) {
- case 4: lua_pushnumber(L,pdf_width(n)); break;
- case 5: lua_pushnumber(L,pdf_height(n)); break;
- case 6: lua_pushnumber(L,pdf_depth(n)); break;
- case 7: lua_pushnumber(L,pdf_link_objnum(n)); break;
- case 8: tokenlist_to_luastring(L,pdf_link_attr(n)); break;
- case 9: nodelib_pushaction(L,pdf_link_action(n)); break;
- default: lua_pushnil(L);
- }
- break;
- case pdf_dest_node:
- switch (field) {
- case 4: lua_pushnumber(L,pdf_width(n)); break;
- case 5: lua_pushnumber(L,pdf_height(n)); break;
- case 6: lua_pushnumber(L,pdf_depth(n)); break;
- case 7: lua_pushnumber(L,pdf_dest_named_id(n)); break;
- case 8: if (pdf_dest_named_id(n) == 1)
- tokenlist_to_luastring(L,pdf_dest_id(n));
- else
- lua_pushnumber(L,pdf_dest_id(n)); break;
- case 9: lua_pushnumber(L,pdf_dest_type(n)); break;
- case 10: lua_pushnumber(L,pdf_dest_xyz_zoom(n)); break;
- case 11: lua_pushnumber(L,pdf_dest_objnum(n)); break;
- default: lua_pushnil(L);
- }
- break;
- case pdf_thread_node:
- case pdf_start_thread_node:
- switch (field) {
- case 4: lua_pushnumber(L,pdf_width(n)); break;
- case 5: lua_pushnumber(L,pdf_height(n)); break;
- case 6: lua_pushnumber(L,pdf_depth(n)); break;
- case 7: lua_pushnumber(L,pdf_thread_named_id(n)); break;
- case 8: if (pdf_thread_named_id(n) == 1)
- tokenlist_to_luastring(L,pdf_thread_id(n));
- else
- lua_pushnumber(L,pdf_thread_id(n)); break;
- case 9: tokenlist_to_luastring(L,pdf_thread_attr(n)); break;
- default: lua_pushnil(L);
- }
- break;
- case late_lua_node:
- switch (field) {
- case 4: lua_pushnumber(L,late_lua_reg(n)); break;
- case 5: tokenlist_to_luastring(L,late_lua_data(n)); break;
- default: lua_pushnil(L);
- }
- break;
- case close_lua_node:
- switch (field) {
- case 4: lua_pushnumber(L,late_lua_reg(n)); break;
- default: lua_pushnil(L);
- }
- break;
- case pdf_colorstack_node:
- switch (field) {
- case 4: lua_pushnumber(L,pdf_colorstack_stack(n)); break;
- case 5: lua_pushnumber(L,pdf_colorstack_cmd(n)); break;
- case 6: tokenlist_to_luastring(L,pdf_colorstack_data(n)); break;
- default: lua_pushnil(L);
- }
- break;
- case pdf_setmatrix_node:
- switch (field) {
- case 4: tokenlist_to_luastring(L,pdf_setmatrix_data(n)); break;
- default: lua_pushnil(L);
- }
- break;
- case user_defined_node:
- switch (field) {
- case 4: lua_pushnumber(L,user_node_id(n)); break;
- case 5: lua_pushnumber(L,user_node_type(n)); break;
- case 6:
- switch (user_node_type(n)) {
- case 'a': nodelib_pushlist(L,user_node_value(n)); break;
- case 'd': lua_pushnumber(L,user_node_value(n)); break;
- case 'n': nodelib_pushlist(L,user_node_value(n)); break;
- case 's': nodelib_pushstring(L,user_node_value(n)); break;
- case 't': tokenlist_to_lua(L,user_node_value(n)); break;
- default: lua_pushnumber(L,user_node_value(n)); break;
- } break;
- default: lua_pushnil(L);
- }
- break;
- default:
- lua_pushnil(L);
- break;
- }
- }
+static void nodelib_pushdir(lua_State * L, int n, boolean dirnode)
+{
+ int f = 0;
+ char dirstring[5] = { 0 };
+ if (dirnode) {
+ dirstring[f++] = (n < 0 ? '-' : '+');
+ }
+ if (n < 0)
+ n += 64;
+ dirstring[f++] = dir_names[(int) dir_primary[n]];
+ dirstring[f++] = dir_names[(int) dir_secondary[n]];
+ dirstring[f++] = dir_names[(int) dir_tertiary[n]];
+ lua_pushstring(L, dirstring);
+}
+
+static void lua_nodelib_getfield_whatsit(lua_State * L, int n, int field)
+{
+ if (field == 2) {
+ lua_pushnumber(L, subtype(n));
+ } else {
+ switch (subtype(n)) {
+ case open_node:
+ switch (field) {
+ case 4:
+ lua_pushnumber(L, write_stream(n));
+ break;
+ case 5:
+ nodelib_pushstring(L, open_name(n));
+ break;
+ case 6:
+ nodelib_pushstring(L, open_area(n));
+ break;
+ case 7:
+ nodelib_pushstring(L, open_ext(n));
+ break;
+ default:
+ lua_pushnil(L);
+ }
+ break;
+ case write_node:
+ switch (field) {
+ case 4:
+ lua_pushnumber(L, write_stream(n));
+ break;
+ case 5:
+ tokenlist_to_lua(L, write_tokens(n));
+ break;
+ default:
+ lua_pushnil(L);
+ }
+ break;
+ case close_node:
+ switch (field) {
+ case 4:
+ lua_pushnumber(L, write_stream(n));
+ break;
+ default:
+ lua_pushnil(L);
+ }
+ break;
+ case special_node:
+ switch (field) {
+ case 4:
+ tokenlist_to_luastring(L, write_tokens(n));
+ break;
+ default:
+ lua_pushnil(L);
+ }
+ break;
+ case local_par_node:
+ switch (field) {
+ case 4:
+ lua_pushnumber(L, local_pen_inter(n));
+ break;
+ case 5:
+ lua_pushnumber(L, local_pen_broken(n));
+ break;
+ case 6:
+ nodelib_pushdir(L, local_par_dir(n), false);
+ break;
+ case 7:
+ nodelib_pushlist(L, local_box_left(n));
+ break;
+ case 8:
+ lua_pushnumber(L, local_box_left_width(n));
+ break;
+ case 9:
+ nodelib_pushlist(L, local_box_right(n));
+ break;
+ case 10:
+ lua_pushnumber(L, local_box_right_width(n));
+ break;
+ default:
+ lua_pushnil(L);
+ }
+ break;
+ case dir_node:
+ switch (field) {
+ case 4:
+ nodelib_pushdir(L, dir_dir(n), true);
+ break;
+ case 5:
+ lua_pushnumber(L, dir_level(n));
+ break;
+ case 6:
+ lua_pushnumber(L, dir_dvi_ptr(n));
+ break;
+ case 7:
+ lua_pushnumber(L, dir_dvi_h(n));
+ break;
+ default:
+ lua_pushnil(L);
+ }
+ break;
+ case pdf_literal_node:
+ switch (field) {
+ case 4:
+ lua_pushnumber(L, pdf_literal_mode(n));
+ break;
+ case 5:
+ tokenlist_to_luastring(L, pdf_literal_data(n));
+ break;
+ default:
+ lua_pushnil(L);
+ }
+ break;
+ case pdf_refobj_node:
+ switch (field) {
+ case 4:
+ lua_pushnumber(L, pdf_obj_objnum(n));
+ break;
+ default:
+ lua_pushnil(L);
+ }
+ break;
+ case pdf_refxform_node:
+ switch (field) {
+ case 4:
+ lua_pushnumber(L, pdf_width(n));
+ break;
+ case 5:
+ lua_pushnumber(L, pdf_height(n));
+ break;
+ case 6:
+ lua_pushnumber(L, pdf_depth(n));
+ break;
+ case 7:
+ lua_pushnumber(L, pdf_xform_objnum(n));
+ break;
+ default:
+ lua_pushnil(L);
+ }
+ break;
+ case pdf_refximage_node:
+ switch (field) {
+ case 4:
+ lua_pushnumber(L, pdf_width(n));
+ break;
+ case 5:
+ lua_pushnumber(L, pdf_height(n));
+ break;
+ case 6:
+ lua_pushnumber(L, pdf_depth(n));
+ break;
+ case 7:
+ lua_pushnumber(L, pdf_ximage_objnum(n));
+ break;
+ default:
+ lua_pushnil(L);
+ }
+ break;
+ case pdf_annot_node:
+ switch (field) {
+ case 4:
+ lua_pushnumber(L, pdf_width(n));
+ break;
+ case 5:
+ lua_pushnumber(L, pdf_height(n));
+ break;
+ case 6:
+ lua_pushnumber(L, pdf_depth(n));
+ break;
+ case 7:
+ lua_pushnumber(L, pdf_annot_objnum(n));
+ break;
+ case 8:
+ tokenlist_to_luastring(L, pdf_annot_data(n));
+ break;
+ default:
+ lua_pushnil(L);
+ }
+ break;
+ case pdf_start_link_node:
+ switch (field) {
+ case 4:
+ lua_pushnumber(L, pdf_width(n));
+ break;
+ case 5:
+ lua_pushnumber(L, pdf_height(n));
+ break;
+ case 6:
+ lua_pushnumber(L, pdf_depth(n));
+ break;
+ case 7:
+ lua_pushnumber(L, pdf_link_objnum(n));
+ break;
+ case 8:
+ tokenlist_to_luastring(L, pdf_link_attr(n));
+ break;
+ case 9:
+ nodelib_pushaction(L, pdf_link_action(n));
+ break;
+ default:
+ lua_pushnil(L);
+ }
+ break;
+ case pdf_dest_node:
+ switch (field) {
+ case 4:
+ lua_pushnumber(L, pdf_width(n));
+ break;
+ case 5:
+ lua_pushnumber(L, pdf_height(n));
+ break;
+ case 6:
+ lua_pushnumber(L, pdf_depth(n));
+ break;
+ case 7:
+ lua_pushnumber(L, pdf_dest_named_id(n));
+ break;
+ case 8:
+ if (pdf_dest_named_id(n) == 1)
+ tokenlist_to_luastring(L, pdf_dest_id(n));
+ else
+ lua_pushnumber(L, pdf_dest_id(n));
+ break;
+ case 9:
+ lua_pushnumber(L, pdf_dest_type(n));
+ break;
+ case 10:
+ lua_pushnumber(L, pdf_dest_xyz_zoom(n));
+ break;
+ case 11:
+ lua_pushnumber(L, pdf_dest_objnum(n));
+ break;
+ default:
+ lua_pushnil(L);
+ }
+ break;
+ case pdf_thread_node:
+ case pdf_start_thread_node:
+ switch (field) {
+ case 4:
+ lua_pushnumber(L, pdf_width(n));
+ break;
+ case 5:
+ lua_pushnumber(L, pdf_height(n));
+ break;
+ case 6:
+ lua_pushnumber(L, pdf_depth(n));
+ break;
+ case 7:
+ lua_pushnumber(L, pdf_thread_named_id(n));
+ break;
+ case 8:
+ if (pdf_thread_named_id(n) == 1)
+ tokenlist_to_luastring(L, pdf_thread_id(n));
+ else
+ lua_pushnumber(L, pdf_thread_id(n));
+ break;
+ case 9:
+ tokenlist_to_luastring(L, pdf_thread_attr(n));
+ break;
+ default:
+ lua_pushnil(L);
+ }
+ break;
+ case late_lua_node:
+ switch (field) {
+ case 4:
+ lua_pushnumber(L, late_lua_reg(n));
+ break;
+ case 5:
+ tokenlist_to_luastring(L, late_lua_data(n));
+ break;
+ case 6:
+ tokenlist_to_luastring(L, late_lua_name(n));
+ break;
+ default:
+ lua_pushnil(L);
+ }
+ break;
+ case close_lua_node:
+ switch (field) {
+ case 4:
+ lua_pushnumber(L, late_lua_reg(n));
+ break;
+ default:
+ lua_pushnil(L);
+ }
+ break;
+ case pdf_colorstack_node:
+ switch (field) {
+ case 4:
+ lua_pushnumber(L, pdf_colorstack_stack(n));
+ break;
+ case 5:
+ lua_pushnumber(L, pdf_colorstack_cmd(n));
+ break;
+ case 6:
+ tokenlist_to_luastring(L, pdf_colorstack_data(n));
+ break;
+ default:
+ lua_pushnil(L);
+ }
+ break;
+ case pdf_setmatrix_node:
+ switch (field) {
+ case 4:
+ tokenlist_to_luastring(L, pdf_setmatrix_data(n));
+ break;
+ default:
+ lua_pushnil(L);
+ }
+ break;
+ case user_defined_node:
+ switch (field) {
+ case 4:
+ lua_pushnumber(L, user_node_id(n));
+ break;
+ case 5:
+ lua_pushnumber(L, user_node_type(n));
+ break;
+ case 6:
+ switch (user_node_type(n)) {
+ case 'a':
+ nodelib_pushlist(L, user_node_value(n));
+ break;
+ case 'd':
+ lua_pushnumber(L, user_node_value(n));
+ break;
+ case 'n':
+ nodelib_pushlist(L, user_node_value(n));
+ break;
+ case 's':
+ nodelib_pushstring(L, user_node_value(n));
+ break;
+ case 't':
+ tokenlist_to_lua(L, user_node_value(n));
+ break;
+ default:
+ lua_pushnumber(L, user_node_value(n));
+ break;
+ }
+ break;
+ default:
+ lua_pushnil(L);
+ }
+ break;
+ default:
+ lua_pushnil(L);
+ break;
+ }
+ }
}
-static int
-lua_nodelib_getfield (lua_State *L) {
- halfword *n_ptr, n;
- int field;
- if (lua_isnil(L,1))
- return 1; /* a nil */
- n_ptr = check_isnode(L,1);
- n = *n_ptr;
- field = get_valid_node_field_id(L,2, n);
-
- if (field<-1)
- return 0;
- if (field==0) {
- lua_pushnumber(L,vlink(n));
- lua_nodelib_push(L);
- } else if (field==1) {
- lua_pushnumber(L,type(n));
- } else if (field==-1) {
- lua_pushnumber(L,alink(n));
- lua_nodelib_push(L);
- } else if (field==3 && nodetype_has_attributes(type(n))) {
- nodelib_pushattr(L,node_attr(n));
- } else {
+static int lua_nodelib_getfield(lua_State * L)
+{
+ register halfword n;
+ register int field;
+ n = *((halfword *) lua_touserdata(L, 1));
+ field = get_valid_node_field_id(L, 2, n);
+ if (field == 0) {
+ lua_pushnumber(L, vlink(n));
+ lua_nodelib_push(L);
+ return 1;
+ }
+ if (field == 1) {
+ lua_pushnumber(L, type(n));
+ return 1;
+ }
+ if (field == -1) {
+ lua_pushnumber(L, alink(n));
+ lua_nodelib_push(L);
+ return 1;
+ }
+ if (field == 3 && nodetype_has_attributes(type(n))) {
+ nodelib_pushattr(L, node_attr(n));
+ return 1;
+ }
+ if (field < -1)
+ return 0;
switch (type(n)) {
case hlist_node:
case vlist_node:
- switch (field) {
- case 2: lua_pushnumber(L,subtype(n)); break;
- case 4: lua_pushnumber(L,width(n)); break;
- case 5: lua_pushnumber(L,depth(n)); break;
- case 6: lua_pushnumber(L,height(n)); break;
- case 7: lua_pushnumber(L,box_dir(n)); break;
- case 8: lua_pushnumber(L,shift_amount(n)); break;
- case 9: lua_pushnumber(L,glue_order(n)); break;
- case 10: lua_pushnumber(L,glue_sign(n)); break;
- case 11: lua_pushnumber(L,(double)glue_set(n)); break;
- case 12: nodelib_pushlist(L,list_ptr(n)); break;
- default: lua_pushnil(L);
- }
- break;
+ switch (field) {
+ case 2:
+ lua_pushnumber(L, subtype(n));
+ break;
+ case 4:
+ lua_pushnumber(L, width(n));
+ break;
+ case 5:
+ lua_pushnumber(L, depth(n));
+ break;
+ case 6:
+ lua_pushnumber(L, height(n));
+ break;
+ case 7:
+ nodelib_pushdir(L, box_dir(n), false);
+ break;
+ case 8:
+ lua_pushnumber(L, shift_amount(n));
+ break;
+ case 9:
+ lua_pushnumber(L, glue_order(n));
+ break;
+ case 10:
+ lua_pushnumber(L, glue_sign(n));
+ break;
+ case 11:
+ lua_pushnumber(L, (double) glue_set(n));
+ break;
+ case 12:
+ nodelib_pushlist(L, list_ptr(n));
+ break;
+ default:
+ lua_pushnil(L);
+ }
+ break;
case unset_node:
- switch (field) {
- case 2: lua_pushnumber(L,0); break;
- case 4: lua_pushnumber(L,width(n)); break;
- case 5: lua_pushnumber(L,depth(n)); break;
- case 6: lua_pushnumber(L,height(n)); break;
- case 7: lua_pushnumber(L,box_dir(n)); break;
- case 8: lua_pushnumber(L,glue_shrink(n)); break;
- case 9: lua_pushnumber(L,glue_order(n)); break;
- case 10: lua_pushnumber(L,glue_sign(n)); break;
- case 11: lua_pushnumber(L,glue_stretch(n)); break;
- case 12: lua_pushnumber(L,span_count(n)); break;
- case 13: nodelib_pushlist(L,list_ptr(n)); break;
- default: lua_pushnil(L);
- }
- break;
+ switch (field) {
+ case 2:
+ lua_pushnumber(L, 0);
+ break;
+ case 4:
+ lua_pushnumber(L, width(n));
+ break;
+ case 5:
+ lua_pushnumber(L, depth(n));
+ break;
+ case 6:
+ lua_pushnumber(L, height(n));
+ break;
+ case 7:
+ nodelib_pushdir(L, box_dir(n), false);
+ break;
+ case 8:
+ lua_pushnumber(L, glue_shrink(n));
+ break;
+ case 9:
+ lua_pushnumber(L, glue_order(n));
+ break;
+ case 10:
+ lua_pushnumber(L, glue_sign(n));
+ break;
+ case 11:
+ lua_pushnumber(L, glue_stretch(n));
+ break;
+ case 12:
+ lua_pushnumber(L, span_count(n));
+ break;
+ case 13:
+ nodelib_pushlist(L, list_ptr(n));
+ break;
+ default:
+ lua_pushnil(L);
+ }
+ break;
case rule_node:
- switch (field) {
- case 2: lua_pushnumber(L,0); break;
- case 4: lua_pushnumber(L,width(n)); break;
- case 5: lua_pushnumber(L,depth(n)); break;
- case 6: lua_pushnumber(L,height(n)); break;
- case 7: lua_pushnumber(L,rule_dir(n)); break;
- default: lua_pushnil(L);
- }
- break;
+ switch (field) {
+ case 2:
+ lua_pushnumber(L, 0);
+ break;
+ case 4:
+ lua_pushnumber(L, width(n));
+ break;
+ case 5:
+ lua_pushnumber(L, depth(n));
+ break;
+ case 6:
+ lua_pushnumber(L, height(n));
+ break;
+ case 7:
+ nodelib_pushdir(L, rule_dir(n), false);
+ break;
+ default:
+ lua_pushnil(L);
+ }
+ break;
case ins_node:
- switch (field) {
- case 2: lua_pushnumber(L,subtype(n)); break;
- case 4: lua_pushnumber(L,float_cost(n)); break;
- case 5: lua_pushnumber(L,depth(n)); break;
- case 6: lua_pushnumber(L,height(n)); break;
- case 7: nodelib_pushspec(L,split_top_ptr(n)); break;
- case 8: nodelib_pushlist(L,ins_ptr(n)); break;
- default: lua_pushnil(L);
- }
- break;
- case mark_node:
- switch (field) {
- case 2: lua_pushnumber(L,subtype(n)); break;
- case 4: lua_pushnumber(L,mark_class(n)); break;
- case 5: tokenlist_to_lua(L,mark_ptr(n)); break;
- default: lua_pushnil(L);
- }
- break;
- case adjust_node:
- switch (field) {
- case 2: lua_pushnumber(L,subtype(n)); break;
- case 4: nodelib_pushlist(L,adjust_ptr(n)); break;
- default: lua_pushnil(L);
- }
- break;
- case disc_node:
- switch (field) {
- case 2: lua_pushnumber(L,subtype(n)); break;
- case 4: nodelib_pushlist(L,vlink(pre_break(n))); break;
- case 5: nodelib_pushlist(L,vlink(post_break(n))); break;
- case 6: nodelib_pushlist(L,vlink(no_break(n))); break;
- default: lua_pushnil(L);
- }
- break;
- case math_node:
- switch (field) {
- case 2: lua_pushnumber(L,subtype(n)); break;
- case 4: lua_pushnumber(L,surround(n)); break;
- default: lua_pushnil(L);
- }
- break;
- case glue_node:
- switch (field) {
- case 2: lua_pushnumber(L,subtype(n)); break;
- case 4: nodelib_pushspec(L,glue_ptr(n)); break;
- case 5: nodelib_pushlist(L,leader_ptr(n)); break;
- default: lua_pushnil(L);
- }
- break;
- case glue_spec_node:
- switch (field) {
- case 2: lua_pushnumber(L,0); break;
- case 3: lua_pushnumber(L,width(n)); break;
- case 4: lua_pushnumber(L,stretch(n)); break;
- case 5: lua_pushnumber(L,shrink(n)); break;
- case 6: lua_pushnumber(L,stretch_order(n)); break;
- case 7: lua_pushnumber(L,shrink_order(n)); break;
- case 8: lua_pushnumber(L,glue_ref_count(n)); break;
- default: lua_pushnil(L);
- }
- break;
- case kern_node:
- switch (field) {
- case 2: lua_pushnumber(L,subtype(n)); break;
- case 4: lua_pushnumber(L,width(n)); break;
- default: lua_pushnil(L);
- }
- break;
- case penalty_node:
- switch (field) {
- case 2: lua_pushnumber(L,0); break;
- case 4: lua_pushnumber(L,penalty(n)); break;
- default: lua_pushnil(L);
- }
- break;
- case glyph_node:
- switch (field) {
- case 2: lua_pushnumber(L,subtype(n)); break;
- case 4: lua_pushnumber(L,character(n)); break;
- case 5: lua_pushnumber(L,font(n)); break;
- case 6: lua_pushnumber(L,char_lang(n)); break;
- case 7: lua_pushnumber(L,char_lhmin(n)); break;
- case 8: lua_pushnumber(L,char_rhmin(n)); break;
- case 9: lua_pushnumber(L,char_uchyph(n)); break;
- case 10: nodelib_pushlist(L,lig_ptr(n)); break;
- case 11: lua_pushnumber(L,x_displace(n)); break;
- case 12: lua_pushnumber(L,y_displace(n)); break;
- default: lua_pushnil(L);
- }
- break;
+ switch (field) {
+ case 2:
+ lua_pushnumber(L, subtype(n));
+ break;
+ case 4:
+ lua_pushnumber(L, float_cost(n));
+ break;
+ case 5:
+ lua_pushnumber(L, depth(n));
+ break;
+ case 6:
+ lua_pushnumber(L, height(n));
+ break;
+ case 7:
+ nodelib_pushspec(L, split_top_ptr(n));
+ break;
+ case 8:
+ nodelib_pushlist(L, ins_ptr(n));
+ break;
+ default:
+ lua_pushnil(L);
+ }
+ break;
+ case mark_node:
+ switch (field) {
+ case 2:
+ lua_pushnumber(L, subtype(n));
+ break;
+ case 4:
+ lua_pushnumber(L, mark_class(n));
+ break;
+ case 5:
+ tokenlist_to_lua(L, mark_ptr(n));
+ break;
+ default:
+ lua_pushnil(L);
+ }
+ break;
+ case adjust_node:
+ switch (field) {
+ case 2:
+ lua_pushnumber(L, subtype(n));
+ break;
+ case 4:
+ nodelib_pushlist(L, adjust_ptr(n));
+ break;
+ default:
+ lua_pushnil(L);
+ }
+ break;
+ case disc_node:
+ switch (field) {
+ case 2:
+ lua_pushnumber(L, subtype(n));
+ break;
+ case 4:
+ nodelib_pushlist(L, vlink(pre_break(n)));
+ break;
+ case 5:
+ nodelib_pushlist(L, vlink(post_break(n)));
+ break;
+ case 6:
+ nodelib_pushlist(L, vlink(no_break(n)));
+ break;
+ default:
+ lua_pushnil(L);
+ }
+ break;
+ case math_node:
+ switch (field) {
+ case 2:
+ lua_pushnumber(L, subtype(n));
+ break;
+ case 4:
+ lua_pushnumber(L, surround(n));
+ break;
+ default:
+ lua_pushnil(L);
+ }
+ break;
+ case glue_node:
+ switch (field) {
+ case 2:
+ lua_pushnumber(L, subtype(n));
+ break;
+ case 4:
+ nodelib_pushspec(L, glue_ptr(n));
+ break;
+ case 5:
+ nodelib_pushlist(L, leader_ptr(n));
+ break;
+ default:
+ lua_pushnil(L);
+ }
+ break;
+ case glue_spec_node:
+ switch (field) {
+ case 2:
+ lua_pushnumber(L, 0);
+ break;
+ case 3:
+ lua_pushnumber(L, width(n));
+ break;
+ case 4:
+ lua_pushnumber(L, stretch(n));
+ break;
+ case 5:
+ lua_pushnumber(L, shrink(n));
+ break;
+ case 6:
+ lua_pushnumber(L, stretch_order(n));
+ break;
+ case 7:
+ lua_pushnumber(L, shrink_order(n));
+ break;
+ case 8:
+ lua_pushnumber(L, glue_ref_count(n));
+ break;
+ default:
+ lua_pushnil(L);
+ }
+ break;
+ case kern_node:
+ switch (field) {
+ case 2:
+ lua_pushnumber(L, subtype(n));
+ break;
+ case 4:
+ lua_pushnumber(L, width(n));
+ break;
+ default:
+ lua_pushnil(L);
+ }
+ break;
+ case penalty_node:
+ switch (field) {
+ case 2:
+ lua_pushnumber(L, 0);
+ break;
+ case 4:
+ lua_pushnumber(L, penalty(n));
+ break;
+ default:
+ lua_pushnil(L);
+ }
+ break;
+ case glyph_node:
+ switch (field) {
+ case 2:
+ lua_pushnumber(L, subtype(n));
+ break;
+ case 4:
+ lua_pushnumber(L, character(n));
+ break;
+ case 5:
+ lua_pushnumber(L, font(n));
+ break;
+ case 6:
+ lua_pushnumber(L, char_lang(n));
+ break;
+ case 7:
+ lua_pushnumber(L, char_lhmin(n));
+ break;
+ case 8:
+ lua_pushnumber(L, char_rhmin(n));
+ break;
+ case 9:
+ lua_pushnumber(L, char_uchyph(n));
+ break;
+ case 10:
+ nodelib_pushlist(L, lig_ptr(n));
+ break;
+ case 11:
+ lua_pushnumber(L, x_displace(n));
+ break;
+ case 12:
+ lua_pushnumber(L, y_displace(n));
+ break;
+ default:
+ lua_pushnil(L);
+ }
+ break;
+ case style_node:
+ switch (field) {
+ case 2:
+ lua_pushnumber(L, 0);
+ break;
+ case 4:
+ lua_pushstring(L, math_style_names[subtype(n)]);
+ break;
+ default:
+ lua_pushnil(L);
+ }
+ break;
+ case choice_node:
+ switch (field) {
+ case 2:
+ lua_pushnumber(L, subtype(n));
+ break;
+ case 4:
+ nodelib_pushlist(L, display_mlist(n));
+ break;
+ case 5:
+ nodelib_pushlist(L, text_mlist(n));
+ break;
+ case 6:
+ nodelib_pushlist(L, script_mlist(n));
+ break;
+ case 7:
+ nodelib_pushlist(L, script_script_mlist(n));
+ break;
+ default:
+ lua_pushnil(L);
+ }
+ break;
+ case ord_noad:
+ case op_noad:
+ case bin_noad:
+ case rel_noad:
+ case open_noad:
+ case close_noad:
+ case punct_noad:
+ case inner_noad:
+ case under_noad:
+ case over_noad:
+ case vcenter_noad:
+ switch (field) {
+ case 2:
+ lua_pushnumber(L, subtype(n));
+ break;
+ case 4:
+ nodelib_pushlist(L, nucleus(n));
+ break;
+ case 5:
+ nodelib_pushlist(L, subscr(n));
+ break;
+ case 6:
+ nodelib_pushlist(L, supscr(n));
+ break;
+ default:
+ lua_pushnil(L);
+ }
+ break;
+ case radical_noad:
+ switch (field) {
+ case 2:
+ lua_pushnumber(L, subtype(n));
+ break;
+ case 4:
+ nodelib_pushlist(L, nucleus(n));
+ break;
+ case 5:
+ nodelib_pushlist(L, subscr(n));
+ break;
+ case 6:
+ nodelib_pushlist(L, supscr(n));
+ break;
+ case 7:
+ nodelib_pushlist(L, left_delimiter(n));
+ break;
+ case 8:
+ nodelib_pushlist(L, degree(n));
+ break;
+ default:
+ lua_pushnil(L);
+ }
+ break;
+ case fraction_noad:
+ switch (field) {
+ case 2:
+ lua_pushnumber(L, subtype(n));
+ break;
+ case 4:
+ lua_pushnumber(L, thickness(n));
+ break;
+ case 5:
+ nodelib_pushlist(L, numerator(n));
+ break;
+ case 6:
+ nodelib_pushlist(L, denominator(n));
+ break;
+ case 7:
+ nodelib_pushlist(L, left_delimiter(n));
+ break;
+ case 8:
+ nodelib_pushlist(L, right_delimiter(n));
+ break;
+ default:
+ lua_pushnil(L);
+ }
+ break;
+ case accent_noad:
+ switch (field) {
+ case 2:
+ lua_pushnumber(L, subtype(n));
+ break;
+ case 4:
+ nodelib_pushlist(L, nucleus(n));
+ break;
+ case 5:
+ nodelib_pushlist(L, subscr(n));
+ break;
+ case 6:
+ nodelib_pushlist(L, supscr(n));
+ break;
+ case 7:
+ nodelib_pushlist(L, accent_chr(n));
+ break;
+ case 8:
+ nodelib_pushlist(L, bot_accent_chr(n));
+ break;
+ default:
+ lua_pushnil(L);
+ }
+ break;
+ case fence_noad:
+ switch (field) {
+ case 2:
+ lua_pushnumber(L, subtype(n));
+ break;
+ case 4:
+ nodelib_pushlist(L, delimiter(n));
+ break;
+ default:
+ lua_pushnil(L);
+ }
+ break;
+ case math_char_node:
+ case math_text_char_node:
+ switch (field) {
+ case 2:
+ lua_pushnumber(L, subtype(n));
+ break;
+ case 4:
+ lua_pushnumber(L, math_fam(n));
+ break;
+ case 5:
+ lua_pushnumber(L, math_character(n));
+ break;
+ default:
+ lua_pushnil(L);
+ }
+ break;
+ case sub_box_node:
+ case sub_mlist_node:
+ switch (field) {
+ case 2:
+ lua_pushnumber(L, subtype(n));
+ break;
+ case 4:
+ nodelib_pushlist(L, math_list(n));
+ break;
+ default:
+ lua_pushnil(L);
+ }
+ break;
+ case delim_node:
+ switch (field) {
+ case 2:
+ lua_pushnumber(L, subtype(n));
+ break;
+ case 4:
+ lua_pushnumber(L, small_fam(n));
+ break;
+ case 5:
+ lua_pushnumber(L, small_char(n));
+ break;
+ case 6:
+ lua_pushnumber(L, large_fam(n));
+ break;
+ case 7:
+ lua_pushnumber(L, large_char(n));
+ break;
+ default:
+ lua_pushnil(L);
+ }
+ break;
case inserting_node:
- switch (field) {
- case 2: lua_pushnumber(L,subtype(n)); break;
- case 3: nodelib_pushlist(L,last_ins_ptr(n)); break;
- case 4: nodelib_pushlist(L,best_ins_ptr(n)); break;
- default: lua_pushnil(L);
- }
- break;
+ switch (field) {
+ case 2:
+ lua_pushnumber(L, subtype(n));
+ break;
+ case 3:
+ nodelib_pushlist(L, last_ins_ptr(n));
+ break;
+ case 4:
+ nodelib_pushlist(L, best_ins_ptr(n));
+ break;
+ default:
+ lua_pushnil(L);
+ }
+ break;
case split_up_node:
- switch (field) {
- case 2: lua_pushnumber(L,subtype(n)); break;
- case 3: nodelib_pushlist(L,last_ins_ptr(n)); break;
- case 4: nodelib_pushlist(L,best_ins_ptr(n)); break;
- case 5: nodelib_pushlist(L,broken_ptr(n)); break;
- case 6: nodelib_pushlist(L,broken_ins(n)); break;
- default: lua_pushnil(L);
- }
- break;
- case margin_kern_node :
- switch (field) {
- case 2: lua_pushnumber(L,subtype(n)); break;
- case 3: lua_pushnumber(L,width(n)); break;
- case 4: nodelib_pushlist(L,margin_char(n)); break;
- default: lua_pushnil(L);
- }
- break;
+ switch (field) {
+ case 2:
+ lua_pushnumber(L, subtype(n));
+ break;
+ case 3:
+ nodelib_pushlist(L, last_ins_ptr(n));
+ break;
+ case 4:
+ nodelib_pushlist(L, best_ins_ptr(n));
+ break;
+ case 5:
+ nodelib_pushlist(L, broken_ptr(n));
+ break;
+ case 6:
+ nodelib_pushlist(L, broken_ins(n));
+ break;
+ default:
+ lua_pushnil(L);
+ }
+ break;
+ case margin_kern_node:
+ switch (field) {
+ case 2:
+ lua_pushnumber(L, subtype(n));
+ break;
+ case 3:
+ lua_pushnumber(L, width(n));
+ break;
+ case 4:
+ nodelib_pushlist(L, margin_char(n));
+ break;
+ default:
+ lua_pushnil(L);
+ }
+ break;
case action_node:
- switch (field) {
- case 2: lua_pushnil(L); /* dummy subtype */ break;
- case 3: lua_pushnumber(L,pdf_action_type(n)); break;
- case 4: lua_pushnumber(L,pdf_action_named_id(n)); break;
- case 5: if (pdf_action_named_id(n)==1) {
- tokenlist_to_luastring(L,pdf_action_id(n));
- } else {
- lua_pushnumber(L,pdf_action_id(n));
- } break;
- case 6: tokenlist_to_luastring(L,pdf_action_file(n)); break;
- case 7: lua_pushnumber(L,pdf_action_new_window(n)); break;
- case 8: tokenlist_to_luastring(L,pdf_action_tokens(n));break;
- case 9: lua_pushnumber(L,pdf_action_refcount(n)); break;
- default: lua_pushnil(L);
- }
- break;
- case attribute_list_node :
- switch (field) {
- case 2: lua_pushnumber(L,0); break;
- default: lua_pushnil(L);
- }
- break;
- case attribute_node :
- switch (field) {
- case 2: lua_pushnumber(L,0); break;
- case 3: lua_pushnumber(L,attribute_id(n)); break;
- case 4: lua_pushnumber(L,attribute_value(n)); break;
- default: lua_pushnil(L);
- }
- break;
+ switch (field) {
+ case 2:
+ lua_pushnil(L); /* dummy subtype */
+ break;
+ case 3:
+ lua_pushnumber(L, pdf_action_type(n));
+ break;
+ case 4:
+ lua_pushnumber(L, pdf_action_named_id(n));
+ break;
+ case 5:
+ if (pdf_action_named_id(n) == 1) {
+ tokenlist_to_luastring(L, pdf_action_id(n));
+ } else {
+ lua_pushnumber(L, pdf_action_id(n));
+ }
+ break;
+ case 6:
+ tokenlist_to_luastring(L, pdf_action_file(n));
+ break;
+ case 7:
+ lua_pushnumber(L, pdf_action_new_window(n));
+ break;
+ case 8:
+ tokenlist_to_luastring(L, pdf_action_tokens(n));
+ break;
+ case 9:
+ lua_pushnumber(L, pdf_action_refcount(n));
+ break;
+ default:
+ lua_pushnil(L);
+ }
+ break;
+ case attribute_list_node:
+ switch (field) {
+ case 2:
+ lua_pushnumber(L, 0);
+ break;
+ default:
+ lua_pushnil(L);
+ }
+ break;
+ case attribute_node:
+ switch (field) {
+ case 2:
+ lua_pushnumber(L, 0);
+ break;
+ case 3:
+ lua_pushnumber(L, attribute_id(n));
+ break;
+ case 4:
+ lua_pushnumber(L, attribute_value(n));
+ break;
+ default:
+ lua_pushnil(L);
+ }
+ break;
case whatsit_node:
- lua_nodelib_getfield_whatsit(L,n,field);
- break;
- default:
- lua_pushnil(L);
- break;
+ lua_nodelib_getfield_whatsit(L, n, field);
+ break;
+ default:
+ lua_pushnil(L);
+ break;
}
- }
- return 1;
+ return 1;
}
-static int nodelib_getlist(lua_State *L, int n) {
- halfword *m;
- if (lua_isuserdata(L,n)) {
- m = check_isnode(L,n);
- return *m;
- } else {
- return null ;
- }
+
+
+static int nodelib_getlist(lua_State * L, int n)
+{
+ halfword *m;
+ if (lua_isuserdata(L, n)) {
+ m = check_isnode(L, n);
+ return *m;
+ } else {
+ return null;
+ }
}
+static int nodelib_getdir(lua_State * L, int n)
+{
+ char *s = NULL;
+ int d = 32; /* invalid number */
+ int a = -1, b = -1, c = -1;
+ if (lua_type(L, n) == LUA_TSTRING) {
+ s = (char *) lua_tostring(L, n);
+ if (strlen(s) == 3) {
+ d = 0;
+ }
+ if (strlen(s) == 4) {
+ if (*s == '-')
+ d = -64;
+ else if (*s == '+')
+ d = 0;
+ s++;
+ }
+ if (strlen(s) == 3) {
+ switch (*s) {
+ /* *INDENT-OFF* */
+ case 'T': a=0; break;
+ case 'L': a=1; break;
+ case 'B': a=2; break;
+ case 'R': a=3; break;
+ /* *INDENT-ON* */
+ }
+ switch (*(s + 1)) {
+ /* *INDENT-OFF* */
+ case 'T': b=0; break;
+ case 'L': b=1; break;
+ case 'B': b=2; break;
+ case 'R': b=3; break;
+ /* *INDENT-ON* */
+ }
+ switch (*(s + 2)) {
+ /* *INDENT-OFF* */
+ case 'T': c=0; break;
+ case 'L': c=1; break;
+ case 'B': c=2; break;
+ case 'R': c=3; break;
+ /* *INDENT-ON* */
+ }
+ }
+ if (a != -1 && b != -1 && c != -1 && !dir_parallel(a, b)) {
+ d += (a * 8 + dir_rearrange[b] * 4 + c);
+ }
+ } else if (lua_isnumber(L, n)) {
+ d = lua_tonumber(L, n);
+ }
+ if ((d > 31) || (d < -64) || (d < 0 && (d + 64) > 31)) {
+ d = 0;
+ lua_pushfstring(L, "Bad direction specifier %s",
+ (char *) lua_tostring(L, n));
+ lua_error(L);
+ }
+ return d;
+}
+
+
#define nodelib_getspec nodelib_getlist
#define nodelib_getaction nodelib_getlist
-static str_number
-nodelib_getstring(lua_State *L, int a) {
- size_t k;
- char *s=(char *)lua_tolstring(L,a, &k);
- return maketexlstring(s,k);
+static str_number nodelib_getstring(lua_State * L, int a)
+{
+ size_t k;
+ char *s = (char *) lua_tolstring(L, a, &k);
+ return maketexlstring(s, k);
}
#define nodelib_gettoks(L,a) tokenlist_from_lua(L)
-static void nodelib_setattr (lua_State *L, int stackindex, halfword n) {
- halfword p;
- p = nodelib_getlist(L,stackindex);
- if (node_attr(n) != p) {
- if (node_attr(n)!=null)
- delete_attribute_ref(node_attr(n));
- node_attr(n) = p;
- attr_list_ref(p)++;
- }
+static void nodelib_setattr(lua_State * L, int stackindex, halfword n)
+{
+ halfword p;
+ p = nodelib_getlist(L, stackindex);
+ if (node_attr(n) != p) {
+ if (node_attr(n) != null)
+ delete_attribute_ref(node_attr(n));
+ node_attr(n) = p;
+ attr_list_ref(p)++;
+ }
}
-static int nodelib_cantset (lua_State *L, int field, int n) {
- lua_pushfstring(L,"You cannot set field %d in a node of type %s",
- field, node_data[type(n)].name);
- lua_error(L);
- return 0;
+static int nodelib_cantset(lua_State * L, int field, int n)
+{
+ lua_pushfstring(L, "You cannot set field %d in a node of type %s",
+ field, node_data[type(n)].name);
+ lua_error(L);
+ return 0;
}
-static int
-lua_nodelib_setfield_whatsit(lua_State *L, int n, int field) {
- switch (subtype(n)) {
- case open_node:
- switch (field) {
- case 4: write_stream(n) = lua_tointeger(L,3); break;
- case 5: open_name(n) = nodelib_getstring(L,3); break;
- case 6: open_area(n) = nodelib_getstring(L,3); break;
- case 7: open_ext(n) = nodelib_getstring(L,3); break;
- default: return nodelib_cantset(L,field,n);
- }
- break;
- case write_node:
- switch (field) {
- case 4: write_stream(n) = lua_tointeger(L,3); break;
- case 5: write_tokens(n) = nodelib_gettoks(L,3); break;
- default: return nodelib_cantset(L,field,n);
- }
- break;
- case close_node:
- switch (field) {
- case 4: write_stream(n) = lua_tointeger(L,3); break;
- default: return nodelib_cantset(L,field,n);
- }
- break;
- case special_node:
- switch (field) {
- case 4: write_tokens(n) = nodelib_gettoks(L,3); break;
- default: return nodelib_cantset(L,field,n);
- }
- break;
- case local_par_node:
- switch (field) {
- case 4: local_pen_inter(n) = lua_tointeger(L,3); break;
- case 5: local_pen_broken(n) = lua_tointeger(L,3); break;
- case 6: local_par_dir(n) = lua_tointeger(L,3); break;
- case 7: local_box_left(n) = nodelib_getlist(L,3); break;
- case 8: local_box_left_width(n) = lua_tointeger(L,3); break;
- case 9: local_box_right(n) = nodelib_getlist(L,3); break;
- case 10: local_box_right_width(n) = lua_tointeger(L,3); break;
- default: return nodelib_cantset(L,field,n);
- }
- break;
- case dir_node:
- switch (field) {
- case 4: dir_dir(n) = lua_tointeger(L,3); break;
- case 5: dir_level(n) = lua_tointeger(L,3); break;
- case 6: dir_dvi_ptr(n) = lua_tointeger(L,3); break;
- case 7: dir_dvi_h(n) = lua_tointeger(L,3); break;
- default: return nodelib_cantset(L,field,n);
- }
- break;
- case pdf_literal_node:
- switch (field) {
- case 4: pdf_literal_mode(n) = lua_tointeger(L,3); break;
- case 5: pdf_literal_data(n) = nodelib_gettoks(L,3); break;
- default: return nodelib_cantset(L,field,n);
- }
- break;
- case pdf_refobj_node:
- switch (field) {
- case 4: pdf_obj_objnum(n) = lua_tointeger(L,3); break;
- default: return nodelib_cantset(L,field,n);
- }
- break;
- case pdf_refxform_node:
- switch (field) {
- case 4: pdf_width(n) = lua_tointeger(L,3); break;
- case 5: pdf_height(n) = lua_tointeger(L,3); break;
- case 6: pdf_depth(n) = lua_tointeger(L,3); break;
- case 7: pdf_xform_objnum(n) = lua_tointeger(L,3); break;
- default: return nodelib_cantset(L,field,n);
- }
- break;
- case pdf_refximage_node:
- switch (field) {
- case 4: pdf_width(n) = lua_tointeger(L,3); break;
- case 5: pdf_height(n) = lua_tointeger(L,3); break;
- case 6: pdf_depth(n) = lua_tointeger(L,3); break;
- case 7: pdf_ximage_objnum(n) = lua_tointeger(L,3); break;
- default: return nodelib_cantset(L,field,n);
- }
- break;
- case pdf_annot_node:
- switch (field) {
- case 4: pdf_width(n) = lua_tointeger(L,3); break;
- case 5: pdf_height(n) = lua_tointeger(L,3); break;
- case 6: pdf_depth(n) = lua_tointeger(L,3); break;
- case 7: pdf_annot_objnum(n) = lua_tointeger(L,3); break;
- case 8: pdf_annot_data(n) = nodelib_getstring(L,3); break;
- default: return nodelib_cantset(L,field,n);
- }
- break;
- case pdf_start_link_node:
- switch (field) {
- case 4: pdf_width(n) = lua_tointeger(L,3); break;
- case 5: pdf_height(n) = lua_tointeger(L,3); break;
- case 6: pdf_depth(n) = lua_tointeger(L,3); break;
- case 7: pdf_link_objnum(n) = lua_tointeger(L,3); break;
- case 8: pdf_link_attr(n) = nodelib_getstring(L,3); break;
- case 9: pdf_link_action(n) = nodelib_getaction(L,3); break;
- default: return nodelib_cantset(L,field,n);
- }
- break;
- case pdf_end_link_node:
- switch (field) {
- default: return nodelib_cantset(L,field,n);
- }
- break;
- case pdf_dest_node:
- switch (field) {
- case 4: pdf_width(n) = lua_tointeger(L,3); break;
- case 5: pdf_height(n) = lua_tointeger(L,3); break;
- case 6: pdf_depth(n) = lua_tointeger(L,3); break;
- case 7: pdf_dest_named_id(n) = lua_tointeger(L,3); break;
- case 8: if (pdf_dest_named_id(n)==1)
- pdf_dest_id(n) = nodelib_gettoks(L,3);
- else
- pdf_dest_id(n) = lua_tointeger(L,3); break;
- case 9: pdf_dest_type(n) = lua_tointeger(L,3); break;
- case 10: pdf_dest_xyz_zoom(n) = lua_tointeger(L,3); break;
- case 11: pdf_dest_objnum(n) = lua_tointeger(L,3); break;
- default: return nodelib_cantset(L,field,n);
- }
- break;
- case pdf_thread_node:
- case pdf_start_thread_node:
- switch (field) {
- case 4: pdf_width(n) = lua_tointeger(L,3); break;
- case 5: pdf_height(n) = lua_tointeger(L,3); break;
- case 6: pdf_depth(n) = lua_tointeger(L,3); break;
- case 7: pdf_thread_named_id(n) = lua_tointeger(L,3); break;
- case 8: if (pdf_thread_named_id(n)==1)
- pdf_thread_id(n) = nodelib_gettoks(L,3);
- else
- pdf_thread_id(n) = lua_tointeger(L,3); break;
- case 9: pdf_thread_attr(n) = nodelib_gettoks(L,3); break;
- default: return nodelib_cantset(L,field,n);
- }
- break;
- case pdf_end_thread_node:
- case pdf_save_pos_node:
- return nodelib_cantset(L,field,n);
- break;
- case late_lua_node:
- switch (field) {
- case 4: late_lua_reg(n) = lua_tointeger(L,3); break;
- case 5: late_lua_data(n) = nodelib_gettoks(L,3); break;
- default: return nodelib_cantset(L,field,n);
- }
- break;
- case close_lua_node:
- switch (field) {
- case 4: late_lua_reg(n) = lua_tointeger(L,3); break;
- default: return nodelib_cantset(L,field,n);
- }
- break;
- case pdf_colorstack_node:
- switch (field) {
- case 4: pdf_colorstack_stack(n) = lua_tointeger(L,3); break;
- case 5: pdf_colorstack_cmd(n) = lua_tointeger(L,3); break;
- case 6: pdf_colorstack_data(n) = nodelib_gettoks(L,3); break;
- default: return nodelib_cantset(L,field,n);
- }
- break;
- case pdf_setmatrix_node:
- switch (field) {
- case 4: pdf_setmatrix_data(n) = nodelib_gettoks(L,3); break;
- default: return nodelib_cantset(L,field,n);
- }
- break;
- case pdf_save_node:
- case pdf_restore_node:
- case cancel_boundary_node:
- return nodelib_cantset(L,field,n);
- break;
- case user_defined_node:
- switch (field) {
- case 4: user_node_id(n) = lua_tointeger(L,3); break;
- case 5: user_node_type(n) = lua_tointeger(L,3); break;
- case 6:
- switch(user_node_type(n)) {
- case 'a': user_node_value(n) = nodelib_getlist(L,3); break;
- case 'd': user_node_value(n) = lua_tointeger(L,3); break;
- case 'n': user_node_value(n) = nodelib_getlist(L,3); break;
- case 's': user_node_value(n) = nodelib_getstring(L,3); break;
- case 't': user_node_value(n) = nodelib_gettoks(L,3); break;
- default: user_node_value(n) = lua_tointeger(L,3); break;
- } break;
- default: return nodelib_cantset(L,field,n);
- }
- break;
- default:
- /* do nothing */
- break;
- }
- return 0;
+static int lua_nodelib_setfield_whatsit(lua_State * L, int n, int field)
+{
+ switch (subtype(n)) {
+ case open_node:
+ switch (field) {
+ case 4:
+ write_stream(n) = lua_tointeger(L, 3);
+ break;
+ case 5:
+ open_name(n) = nodelib_getstring(L, 3);
+ break;
+ case 6:
+ open_area(n) = nodelib_getstring(L, 3);
+ break;
+ case 7:
+ open_ext(n) = nodelib_getstring(L, 3);
+ break;
+ default:
+ return nodelib_cantset(L, field, n);
+ }
+ break;
+ case write_node:
+ switch (field) {
+ case 4:
+ write_stream(n) = lua_tointeger(L, 3);
+ break;
+ case 5:
+ write_tokens(n) = nodelib_gettoks(L, 3);
+ break;
+ default:
+ return nodelib_cantset(L, field, n);
+ }
+ break;
+ case close_node:
+ switch (field) {
+ case 4:
+ write_stream(n) = lua_tointeger(L, 3);
+ break;
+ default:
+ return nodelib_cantset(L, field, n);
+ }
+ break;
+ case special_node:
+ switch (field) {
+ case 4:
+ write_tokens(n) = nodelib_gettoks(L, 3);
+ break;
+ default:
+ return nodelib_cantset(L, field, n);
+ }
+ break;
+ case local_par_node:
+ switch (field) {
+ case 4:
+ local_pen_inter(n) = lua_tointeger(L, 3);
+ break;
+ case 5:
+ local_pen_broken(n) = lua_tointeger(L, 3);
+ break;
+ case 6:
+ local_par_dir(n) = nodelib_getdir(L, 3);
+ break;
+ case 7:
+ local_box_left(n) = nodelib_getlist(L, 3);
+ break;
+ case 8:
+ local_box_left_width(n) = lua_tointeger(L, 3);
+ break;
+ case 9:
+ local_box_right(n) = nodelib_getlist(L, 3);
+ break;
+ case 10:
+ local_box_right_width(n) = lua_tointeger(L, 3);
+ break;
+ default:
+ return nodelib_cantset(L, field, n);
+ }
+ break;
+ case dir_node:
+ switch (field) {
+ case 4:
+ dir_dir(n) = nodelib_getdir(L, 3);
+ break;
+ case 5:
+ dir_level(n) = lua_tointeger(L, 3);
+ break;
+ case 6:
+ dir_dvi_ptr(n) = lua_tointeger(L, 3);
+ break;
+ case 7:
+ dir_dvi_h(n) = lua_tointeger(L, 3);
+ break;
+ default:
+ return nodelib_cantset(L, field, n);
+ }
+ break;
+ case pdf_literal_node:
+ switch (field) {
+ case 4:
+ pdf_literal_mode(n) = lua_tointeger(L, 3);
+ break;
+ case 5:
+ pdf_literal_data(n) = nodelib_gettoks(L, 3);
+ break;
+ default:
+ return nodelib_cantset(L, field, n);
+ }
+ break;
+ case pdf_refobj_node:
+ switch (field) {
+ case 4:
+ pdf_obj_objnum(n) = lua_tointeger(L, 3);
+ break;
+ default:
+ return nodelib_cantset(L, field, n);
+ }
+ break;
+ case pdf_refxform_node:
+ switch (field) {
+ case 4:
+ pdf_width(n) = lua_tointeger(L, 3);
+ break;
+ case 5:
+ pdf_height(n) = lua_tointeger(L, 3);
+ break;
+ case 6:
+ pdf_depth(n) = lua_tointeger(L, 3);
+ break;
+ case 7:
+ pdf_xform_objnum(n) = lua_tointeger(L, 3);
+ break;
+ default:
+ return nodelib_cantset(L, field, n);
+ }
+ break;
+ case pdf_refximage_node:
+ switch (field) {
+ case 4:
+ pdf_width(n) = lua_tointeger(L, 3);
+ break;
+ case 5:
+ pdf_height(n) = lua_tointeger(L, 3);
+ break;
+ case 6:
+ pdf_depth(n) = lua_tointeger(L, 3);
+ break;
+ case 7:
+ pdf_ximage_objnum(n) = lua_tointeger(L, 3);
+ break;
+ default:
+ return nodelib_cantset(L, field, n);
+ }
+ break;
+ case pdf_annot_node:
+ switch (field) {
+ case 4:
+ pdf_width(n) = lua_tointeger(L, 3);
+ break;
+ case 5:
+ pdf_height(n) = lua_tointeger(L, 3);
+ break;
+ case 6:
+ pdf_depth(n) = lua_tointeger(L, 3);
+ break;
+ case 7:
+ pdf_annot_objnum(n) = lua_tointeger(L, 3);
+ break;
+ case 8:
+ pdf_annot_data(n) = nodelib_getstring(L, 3);
+ break;
+ default:
+ return nodelib_cantset(L, field, n);
+ }
+ break;
+ case pdf_start_link_node:
+ switch (field) {
+ case 4:
+ pdf_width(n) = lua_tointeger(L, 3);
+ break;
+ case 5:
+ pdf_height(n) = lua_tointeger(L, 3);
+ break;
+ case 6:
+ pdf_depth(n) = lua_tointeger(L, 3);
+ break;
+ case 7:
+ pdf_link_objnum(n) = lua_tointeger(L, 3);
+ break;
+ case 8:
+ pdf_link_attr(n) = nodelib_getstring(L, 3);
+ break;
+ case 9:
+ pdf_link_action(n) = nodelib_getaction(L, 3);
+ break;
+ default:
+ return nodelib_cantset(L, field, n);
+ }
+ break;
+ case pdf_end_link_node:
+ switch (field) {
+ default:
+ return nodelib_cantset(L, field, n);
+ }
+ break;
+ case pdf_dest_node:
+ switch (field) {
+ case 4:
+ pdf_width(n) = lua_tointeger(L, 3);
+ break;
+ case 5:
+ pdf_height(n) = lua_tointeger(L, 3);
+ break;
+ case 6:
+ pdf_depth(n) = lua_tointeger(L, 3);
+ break;
+ case 7:
+ pdf_dest_named_id(n) = lua_tointeger(L, 3);
+ break;
+ case 8:
+ if (pdf_dest_named_id(n) == 1)
+ pdf_dest_id(n) = nodelib_gettoks(L, 3);
+ else
+ pdf_dest_id(n) = lua_tointeger(L, 3);
+ break;
+ case 9:
+ pdf_dest_type(n) = lua_tointeger(L, 3);
+ break;
+ case 10:
+ pdf_dest_xyz_zoom(n) = lua_tointeger(L, 3);
+ break;
+ case 11:
+ pdf_dest_objnum(n) = lua_tointeger(L, 3);
+ break;
+ default:
+ return nodelib_cantset(L, field, n);
+ }
+ break;
+ case pdf_thread_node:
+ case pdf_start_thread_node:
+ switch (field) {
+ case 4:
+ pdf_width(n) = lua_tointeger(L, 3);
+ break;
+ case 5:
+ pdf_height(n) = lua_tointeger(L, 3);
+ break;
+ case 6:
+ pdf_depth(n) = lua_tointeger(L, 3);
+ break;
+ case 7:
+ pdf_thread_named_id(n) = lua_tointeger(L, 3);
+ break;
+ case 8:
+ if (pdf_thread_named_id(n) == 1)
+ pdf_thread_id(n) = nodelib_gettoks(L, 3);
+ else
+ pdf_thread_id(n) = lua_tointeger(L, 3);
+ break;
+ case 9:
+ pdf_thread_attr(n) = nodelib_gettoks(L, 3);
+ break;
+ default:
+ return nodelib_cantset(L, field, n);
+ }
+ break;
+ case pdf_end_thread_node:
+ case pdf_save_pos_node:
+ return nodelib_cantset(L, field, n);
+ break;
+ case late_lua_node:
+ switch (field) {
+ case 4:
+ late_lua_reg(n) = lua_tointeger(L, 3);
+ break;
+ case 5:
+ late_lua_data(n) = nodelib_gettoks(L, 3);
+ break;
+ case 6:
+ late_lua_name(n) = nodelib_gettoks(L, 3);
+ break;
+ default:
+ return nodelib_cantset(L, field, n);
+ }
+ break;
+ case close_lua_node:
+ switch (field) {
+ case 4:
+ late_lua_reg(n) = lua_tointeger(L, 3);
+ break;
+ default:
+ return nodelib_cantset(L, field, n);
+ }
+ break;
+ case pdf_colorstack_node:
+ switch (field) {
+ case 4:
+ pdf_colorstack_stack(n) = lua_tointeger(L, 3);
+ break;
+ case 5:
+ pdf_colorstack_cmd(n) = lua_tointeger(L, 3);
+ break;
+ case 6:
+ pdf_colorstack_data(n) = nodelib_gettoks(L, 3);
+ break;
+ default:
+ return nodelib_cantset(L, field, n);
+ }
+ break;
+ case pdf_setmatrix_node:
+ switch (field) {
+ case 4:
+ pdf_setmatrix_data(n) = nodelib_gettoks(L, 3);
+ break;
+ default:
+ return nodelib_cantset(L, field, n);
+ }
+ break;
+ case pdf_save_node:
+ case pdf_restore_node:
+ case cancel_boundary_node:
+ return nodelib_cantset(L, field, n);
+ break;
+ case user_defined_node:
+ switch (field) {
+ case 4:
+ user_node_id(n) = lua_tointeger(L, 3);
+ break;
+ case 5:
+ user_node_type(n) = lua_tointeger(L, 3);
+ break;
+ case 6:
+ switch (user_node_type(n)) {
+ case 'a':
+ user_node_value(n) = nodelib_getlist(L, 3);
+ break;
+ case 'd':
+ user_node_value(n) = lua_tointeger(L, 3);
+ break;
+ case 'n':
+ user_node_value(n) = nodelib_getlist(L, 3);
+ break;
+ case 's':
+ user_node_value(n) = nodelib_getstring(L, 3);
+ break;
+ case 't':
+ user_node_value(n) = nodelib_gettoks(L, 3);
+ break;
+ default:
+ user_node_value(n) = lua_tointeger(L, 3);
+ break;
+ }
+ break;
+ default:
+ return nodelib_cantset(L, field, n);
+ }
+ break;
+ default:
+ /* do nothing */
+ break;
+ }
+ return 0;
}
-static int
-lua_nodelib_setfield (lua_State *L) {
- register halfword n;
- register int field;
- n = *check_isnode(L,1);
- field = get_valid_node_field_id(L,2,n);
- if (field<-1)
- return 0;
- if (field==0) {
- vlink(n) = nodelib_getlist(L,3);
- } else if (field==-1) {
- alink(n) = nodelib_getlist(L,3);
- } else if (field==3 && nodetype_has_attributes(type(n))) {
- nodelib_setattr(L,3,n);
- } else if (type(n)==glyph_node) {
- switch (field) {
- case 2: subtype(n) = lua_tointeger(L,3); break;
- case 4: character(n) = lua_tointeger(L,3); break;
- case 5: font(n) = lua_tointeger(L,3); break;
- case 6: set_char_lang(n,lua_tointeger(L,3)); break;
- case 7: set_char_lhmin(n,lua_tointeger(L,3)); break;
- case 8: set_char_rhmin(n,lua_tointeger(L,3)); break;
- case 9: set_char_uchyph(n,lua_tointeger(L,3)); break;
- case 10: lig_ptr(n) = nodelib_getlist(L,3); break;
- case 11: x_displace(n) = lua_tointeger(L,3); break;
- case 12: y_displace(n) = lua_tointeger(L,3); break;
- default: return nodelib_cantset(L,field,n);
- }
- } else {
- switch (type(n)) {
- case hlist_node:
- case vlist_node:
- switch (field) {
- case 2: subtype(n) = lua_tointeger(L,3); break;
- case 4: width(n) = lua_tointeger(L,3); break;
- case 5: depth(n) = lua_tointeger(L,3); break;
- case 6: height(n) = lua_tointeger(L,3); break;
- case 7: box_dir(n) = lua_tointeger(L,3); break;
- case 8: shift_amount(n) = lua_tointeger(L,3); break;
- case 9: glue_order(n) = lua_tointeger(L,3); break;
- case 10: glue_sign(n) = lua_tointeger(L,3); break;
- case 11: glue_set(n) = (double)lua_tonumber(L,3); break;
- case 12: list_ptr(n) = nodelib_getlist(L,3); break;
- default: return nodelib_cantset(L,field,n);
- }
- break;
- case unset_node:
- switch (field) {
- case 2: /* dummy subtype */ break;
- case 4: width(n) = lua_tointeger(L,3); break;
- case 5: depth(n) = lua_tointeger(L,3); break;
- case 6: height(n) = lua_tointeger(L,3); break;
- case 7: box_dir(n) = lua_tointeger(L,3); break;
- case 8: glue_shrink(n) = lua_tointeger(L,3); break;
- case 9: glue_order(n) = lua_tointeger(L,3); break;
- case 10: glue_sign(n) = lua_tointeger(L,3); break;
- case 11: glue_stretch(n) = lua_tointeger(L,3); break;
- case 12: span_count(n) = lua_tointeger(L,3); break;
- case 13: list_ptr(n) = nodelib_getlist(L,3); break;
- default: return nodelib_cantset(L,field,n);
- }
- break;
- case rule_node:
- switch (field) {
- case 2: /* dummy subtype */ break;
- case 4: width(n) = lua_tointeger(L,3); break;
- case 5: depth(n) = lua_tointeger(L,3); break;
- case 6: height(n) = lua_tointeger(L,3); break;
- case 7: rule_dir(n) = lua_tointeger(L,3); break;
- default: return nodelib_cantset(L,field,n);
- }
- break;
- case ins_node:
- switch (field) {
- case 2: subtype(n) = lua_tointeger(L,3); break;
- case 4: float_cost(n) = lua_tointeger(L,3); break;
- case 5: depth(n) = lua_tointeger(L,3); break;
- case 6: height(n) = lua_tointeger(L,3); break;
- case 7: split_top_ptr(n) = nodelib_getspec(L,3); break;
- case 8: ins_ptr(n) = nodelib_getlist(L,3); break;
- default: return nodelib_cantset(L,field,n);
- }
- break;
- case mark_node:
- switch (field) {
- case 2: subtype(n) = lua_tointeger(L,3); break;
- case 4: mark_class(n) = lua_tointeger(L,3); break;
- case 5: mark_ptr(n) = nodelib_gettoks(L,3); break;
- default: return nodelib_cantset(L,field,n);
- }
- break;
- case adjust_node:
- switch (field) {
- case 2: subtype(n) = lua_tointeger(L,3); break;
- case 4: adjust_ptr(n) = nodelib_getlist(L,3); break;
- default: return nodelib_cantset(L,field,n);
- }
- break;
- case disc_node:
- switch (field) {
- case 2: subtype(n) = lua_tointeger(L,3); break;
- case 4: set_disc_field(pre_break(n),nodelib_getlist(L,3)); break;
- case 5: set_disc_field(post_break(n),nodelib_getlist(L,3)); break;
- case 6: set_disc_field(no_break(n),nodelib_getlist(L,3)); break;
- default: return nodelib_cantset(L,field,n);
- }
- break;
- case math_node:
- switch (field) {
- case 2: subtype(n) = lua_tointeger(L,3); break;
- case 4: surround(n) = lua_tointeger(L,3); break;
- default: return nodelib_cantset(L,field,n);
- }
- break;
- case glue_node:
- switch (field) {
- case 2: subtype(n) = lua_tointeger(L,3); break;
- case 4: glue_ptr(n) = nodelib_getspec(L,3); break;
- case 5: leader_ptr(n) = nodelib_getlist(L,3); break;
- default: return nodelib_cantset(L,field,n);
- }
- break;
- case glue_spec_node:
- switch (field) {
- case 2: /* dummy subtype */ break;
- case 3: width(n) = lua_tointeger(L,3); break;
- case 4: stretch(n) = lua_tointeger(L,3); break;
- case 5: shrink(n) = lua_tointeger(L,3); break;
- case 6: stretch_order(n) = lua_tointeger(L,3); break;
- case 7: shrink_order(n) = lua_tointeger(L,3); break;
- case 8: glue_ref_count(n) = lua_tointeger(L,3); break;
- default: return nodelib_cantset(L,field,n);
- }
- break;
- case kern_node:
- switch (field) {
- case 2: subtype(n) = lua_tointeger(L,3); break;
- case 4: width(n) = lua_tointeger(L,3); break;
- default: return nodelib_cantset(L,field,n);
- }
- break;
- case penalty_node:
- switch (field) {
- case 2: /* dummy subtype */ break;
- case 4: penalty(n) = lua_tointeger(L,3); break;
- default: return nodelib_cantset(L,field,n);
- }
- break;
- case action_node:
- switch (field) {
- case 2: /* dummy subtype */ break;
- case 3: pdf_action_type(n) = lua_tointeger(L,3); break;
- case 4: pdf_action_named_id(n) = lua_tointeger(L,3); break;
- case 5: if (pdf_action_named_id(n)==1) {
- pdf_action_id(n) = nodelib_gettoks(L,3);
- } else {
- pdf_action_id(n) = lua_tointeger(L,3);
- } break;
- case 6: pdf_action_file(n) = nodelib_gettoks(L,3); break;
- case 7: pdf_action_new_window(n) = lua_tointeger(L,3); break;
- case 8: pdf_action_tokens(n) = nodelib_gettoks(L,3); break;
- case 9: pdf_action_refcount(n) = lua_tointeger(L,3); break;
- default: return nodelib_cantset(L,field,n);
- }
- break;
- case margin_kern_node:
- switch (field) {
- case 2: subtype(n) = lua_tointeger(L,3); break;
- case 3: width(n) = lua_tointeger(L,3); break;
- case 4: margin_char(n) = nodelib_getlist(L,3); break;
- default: return nodelib_cantset(L,field,n);
- }
- break;
- case inserting_node:
- switch (field) {
- case 2: subtype(n) = lua_tointeger(L,3); break;
- case 3: last_ins_ptr(n) = nodelib_getlist(L,3); break;
- case 4: best_ins_ptr(n) = nodelib_getlist(L,3); break;
- default: return nodelib_cantset(L,field,n);
- }
- break;
- case split_up_node:
- switch (field) {
- case 2: subtype(n) = lua_tointeger(L,3); break;
- case 3: last_ins_ptr(n) = nodelib_getlist(L,3); break;
- case 4: best_ins_ptr(n) = nodelib_getlist(L,3); break;
- case 5: broken_ptr(n) = nodelib_getlist(L,3); break;
- case 6: broken_ins(n) = nodelib_getlist(L,3); break;
- default: return nodelib_cantset(L,field,n);
- }
- break;
- case attribute_list_node:
- switch (field) {
- case 2: /* dummy subtype */ break;
- default: return nodelib_cantset(L,field,n);
- }
- break;
- case attribute_node:
- switch (field) {
- case 2: /* dummy subtype */ break;
- case 3: attribute_id(n) = lua_tointeger(L,3); break;
- case 4: attribute_value(n) = lua_tointeger(L,3); break;
- default: return nodelib_cantset(L,field,n);
- }
- break;
- case whatsit_node:
- lua_nodelib_setfield_whatsit(L,n,field);
- break;
- default:
- /* do nothing */
- break;
+static int lua_nodelib_setfield(lua_State * L)
+{
+ register halfword n;
+ register int field;
+ n = *((halfword *) lua_touserdata(L, 1));
+ field = get_valid_node_field_id(L, 2, n);
+ if (field < -1)
+ return 0;
+ if (field == 0) {
+ vlink(n) = nodelib_getlist(L, 3);
+ } else if (field == -1) {
+ alink(n) = nodelib_getlist(L, 3);
+ } else if (field == 3 && nodetype_has_attributes(type(n))) {
+ nodelib_setattr(L, 3, n);
+ } else if (type(n) == glyph_node) {
+ switch (field) {
+ case 2:
+ subtype(n) = lua_tointeger(L, 3);
+ break;
+ case 4:
+ character(n) = lua_tointeger(L, 3);
+ break;
+ case 5:
+ font(n) = lua_tointeger(L, 3);
+ break;
+ case 6:
+ set_char_lang(n, lua_tointeger(L, 3));
+ break;
+ case 7:
+ set_char_lhmin(n, lua_tointeger(L, 3));
+ break;
+ case 8:
+ set_char_rhmin(n, lua_tointeger(L, 3));
+ break;
+ case 9:
+ set_char_uchyph(n, lua_tointeger(L, 3));
+ break;
+ case 10:
+ lig_ptr(n) = nodelib_getlist(L, 3);
+ break;
+ case 11:
+ x_displace(n) = lua_tointeger(L, 3);
+ break;
+ case 12:
+ y_displace(n) = lua_tointeger(L, 3);
+ break;
+ default:
+ return nodelib_cantset(L, field, n);
+ }
+ } else {
+ switch (type(n)) {
+ case hlist_node:
+ case vlist_node:
+ switch (field) {
+ case 2:
+ subtype(n) = lua_tointeger(L, 3);
+ break;
+ case 4:
+ width(n) = lua_tointeger(L, 3);
+ break;
+ case 5:
+ depth(n) = lua_tointeger(L, 3);
+ break;
+ case 6:
+ height(n) = lua_tointeger(L, 3);
+ break;
+ case 7:
+ box_dir(n) = nodelib_getdir(L, 3);
+ break;
+ case 8:
+ shift_amount(n) = lua_tointeger(L, 3);
+ break;
+ case 9:
+ glue_order(n) = lua_tointeger(L, 3);
+ break;
+ case 10:
+ glue_sign(n) = lua_tointeger(L, 3);
+ break;
+ case 11:
+ glue_set(n) = (double) lua_tonumber(L, 3);
+ break;
+ case 12:
+ list_ptr(n) = nodelib_getlist(L, 3);
+ break;
+ default:
+ return nodelib_cantset(L, field, n);
+ }
+ break;
+ case unset_node:
+ switch (field) {
+ case 2: /* dummy subtype */
+ break;
+ case 4:
+ width(n) = lua_tointeger(L, 3);
+ break;
+ case 5:
+ depth(n) = lua_tointeger(L, 3);
+ break;
+ case 6:
+ height(n) = lua_tointeger(L, 3);
+ break;
+ case 7:
+ box_dir(n) = lua_tointeger(L, 3);
+ break;
+ case 8:
+ glue_shrink(n) = lua_tointeger(L, 3);
+ break;
+ case 9:
+ glue_order(n) = lua_tointeger(L, 3);
+ break;
+ case 10:
+ glue_sign(n) = lua_tointeger(L, 3);
+ break;
+ case 11:
+ glue_stretch(n) = lua_tointeger(L, 3);
+ break;
+ case 12:
+ span_count(n) = lua_tointeger(L, 3);
+ break;
+ case 13:
+ list_ptr(n) = nodelib_getlist(L, 3);
+ break;
+ default:
+ return nodelib_cantset(L, field, n);
+ }
+ break;
+ case rule_node:
+ switch (field) {
+ case 2: /* dummy subtype */
+ break;
+ case 4:
+ width(n) = lua_tointeger(L, 3);
+ break;
+ case 5:
+ depth(n) = lua_tointeger(L, 3);
+ break;
+ case 6:
+ height(n) = lua_tointeger(L, 3);
+ break;
+ case 7:
+ rule_dir(n) = nodelib_getdir(L, 3);
+ break;
+ default:
+ return nodelib_cantset(L, field, n);
+ }
+ break;
+ case ins_node:
+ switch (field) {
+ case 2:
+ subtype(n) = lua_tointeger(L, 3);
+ break;
+ case 4:
+ float_cost(n) = lua_tointeger(L, 3);
+ break;
+ case 5:
+ depth(n) = lua_tointeger(L, 3);
+ break;
+ case 6:
+ height(n) = lua_tointeger(L, 3);
+ break;
+ case 7:
+ split_top_ptr(n) = nodelib_getspec(L, 3);
+ break;
+ case 8:
+ ins_ptr(n) = nodelib_getlist(L, 3);
+ break;
+ default:
+ return nodelib_cantset(L, field, n);
+ }
+ break;
+ case mark_node:
+ switch (field) {
+ case 2:
+ subtype(n) = lua_tointeger(L, 3);
+ break;
+ case 4:
+ mark_class(n) = lua_tointeger(L, 3);
+ break;
+ case 5:
+ mark_ptr(n) = nodelib_gettoks(L, 3);
+ break;
+ default:
+ return nodelib_cantset(L, field, n);
+ }
+ break;
+ case adjust_node:
+ switch (field) {
+ case 2:
+ subtype(n) = lua_tointeger(L, 3);
+ break;
+ case 4:
+ adjust_ptr(n) = nodelib_getlist(L, 3);
+ break;
+ default:
+ return nodelib_cantset(L, field, n);
+ }
+ break;
+ case disc_node:
+ switch (field) {
+ case 2:
+ subtype(n) = lua_tointeger(L, 3);
+ break;
+ case 4:
+ set_disc_field(pre_break(n), nodelib_getlist(L, 3));
+ break;
+ case 5:
+ set_disc_field(post_break(n), nodelib_getlist(L, 3));
+ break;
+ case 6:
+ set_disc_field(no_break(n), nodelib_getlist(L, 3));
+ break;
+ default:
+ return nodelib_cantset(L, field, n);
+ }
+ break;
+ case math_node:
+ switch (field) {
+ case 2:
+ subtype(n) = lua_tointeger(L, 3);
+ break;
+ case 4:
+ surround(n) = lua_tointeger(L, 3);
+ break;
+ default:
+ return nodelib_cantset(L, field, n);
+ }
+ break;
+ case glue_node:
+ switch (field) {
+ case 2:
+ subtype(n) = lua_tointeger(L, 3);
+ break;
+ case 4:
+ glue_ptr(n) = nodelib_getspec(L, 3);
+ break;
+ case 5:
+ leader_ptr(n) = nodelib_getlist(L, 3);
+ break;
+ default:
+ return nodelib_cantset(L, field, n);
+ }
+ break;
+ case glue_spec_node:
+ switch (field) {
+ case 2: /* dummy subtype */
+ break;
+ case 3:
+ width(n) = lua_tointeger(L, 3);
+ break;
+ case 4:
+ stretch(n) = lua_tointeger(L, 3);
+ break;
+ case 5:
+ shrink(n) = lua_tointeger(L, 3);
+ break;
+ case 6:
+ stretch_order(n) = lua_tointeger(L, 3);
+ break;
+ case 7:
+ shrink_order(n) = lua_tointeger(L, 3);
+ break;
+ case 8:
+ glue_ref_count(n) = lua_tointeger(L, 3);
+ break;
+ default:
+ return nodelib_cantset(L, field, n);
+ }
+ break;
+ case kern_node:
+ switch (field) {
+ case 2:
+ subtype(n) = lua_tointeger(L, 3);
+ break;
+ case 4:
+ width(n) = lua_tointeger(L, 3);
+ break;
+ default:
+ return nodelib_cantset(L, field, n);
+ }
+ break;
+ case penalty_node:
+ switch (field) {
+ case 2: /* dummy subtype */
+ break;
+ case 4:
+ penalty(n) = lua_tointeger(L, 3);
+ break;
+ default:
+ return nodelib_cantset(L, field, n);
+ }
+ break;
+ case action_node:
+ switch (field) {
+ case 2: /* dummy subtype */
+ break;
+ case 3:
+ pdf_action_type(n) = lua_tointeger(L, 3);
+ break;
+ case 4:
+ pdf_action_named_id(n) = lua_tointeger(L, 3);
+ break;
+ case 5:
+ if (pdf_action_named_id(n) == 1) {
+ pdf_action_id(n) = nodelib_gettoks(L, 3);
+ } else {
+ pdf_action_id(n) = lua_tointeger(L, 3);
+ }
+ break;
+ case 6:
+ pdf_action_file(n) = nodelib_gettoks(L, 3);
+ break;
+ case 7:
+ pdf_action_new_window(n) = lua_tointeger(L, 3);
+ break;
+ case 8:
+ pdf_action_tokens(n) = nodelib_gettoks(L, 3);
+ break;
+ case 9:
+ pdf_action_refcount(n) = lua_tointeger(L, 3);
+ break;
+ default:
+ return nodelib_cantset(L, field, n);
+ }
+ break;
+ case style_node:
+ switch (field) {
+ case 2: /* dummy subtype */
+ break;
+ case 4:
+ subtype(n) = luaL_checkoption(L, 3, "text", math_style_names);
+ break;
+ default:
+ return nodelib_cantset(L, field, n);
+ }
+ break;
+ case choice_node:
+ switch (field) {
+ case 2:
+ subtype(n) = lua_tointeger(L, 3);
+ break;
+ case 4:
+ display_mlist(n) = nodelib_getlist(L, 3);
+ break;
+ case 5:
+ text_mlist(n) = nodelib_getlist(L, 3);
+ break;
+ case 6:
+ script_mlist(n) = nodelib_getlist(L, 3);
+ break;
+ case 7:
+ script_script_mlist(n) = nodelib_getlist(L, 3);
+ break;
+ default:
+ return nodelib_cantset(L, field, n);
+ }
+ break;
+ case ord_noad:
+ case op_noad:
+ case bin_noad:
+ case rel_noad:
+ case open_noad:
+ case close_noad:
+ case punct_noad:
+ case inner_noad:
+ case under_noad:
+ case over_noad:
+ case vcenter_noad:
+ switch (field) {
+ case 2:
+ subtype(n) = lua_tointeger(L, 3);
+ break;
+ case 4:
+ nucleus(n) = nodelib_getlist(L, 3);
+ break;
+ case 5:
+ subscr(n) = nodelib_getlist(L, 3);
+ break;
+ case 6:
+ supscr(n) = nodelib_getlist(L, 3);
+ break;
+ default:
+ return nodelib_cantset(L, field, n);
+ }
+ break;
+ case radical_noad:
+ switch (field) {
+ case 2:
+ subtype(n) = lua_tointeger(L, 3);
+ break;
+ case 4:
+ nucleus(n) = nodelib_getlist(L, 3);
+ break;
+ case 5:
+ subscr(n) = nodelib_getlist(L, 3);
+ break;
+ case 6:
+ supscr(n) = nodelib_getlist(L, 3);
+ break;
+ case 7:
+ left_delimiter(n) = nodelib_getlist(L, 3);
+ break;
+ case 8:
+ degree(n) = nodelib_getlist(L, 3);
+ break;
+ default:
+ return nodelib_cantset(L, field, n);
+ }
+ break;
+ case fraction_noad:
+ switch (field) {
+ case 2:
+ subtype(n) = lua_tointeger(L, 3);
+ break;
+ case 4:
+ thickness(n) = lua_tointeger(L, 3);
+ break;
+ case 5:
+ numerator(n) = nodelib_getlist(L, 3);
+ break;
+ case 6:
+ denominator(n) = nodelib_getlist(L, 3);
+ break;
+ case 7:
+ left_delimiter(n) = nodelib_getlist(L, 3);
+ break;
+ case 8:
+ right_delimiter(n) = nodelib_getlist(L, 3);
+ break;
+ default:
+ return nodelib_cantset(L, field, n);
+ }
+ break;
+ case accent_noad:
+ switch (field) {
+ case 2:
+ subtype(n) = lua_tointeger(L, 3);
+ break;
+ case 4:
+ nucleus(n) = nodelib_getlist(L, 3);
+ break;
+ case 5:
+ subscr(n) = nodelib_getlist(L, 3);
+ break;
+ case 6:
+ supscr(n) = nodelib_getlist(L, 3);
+ break;
+ case 7:
+ accent_chr(n) = nodelib_getlist(L, 3);
+ break;
+ case 8:
+ bot_accent_chr(n) = nodelib_getlist(L, 3);
+ break;
+ default:
+ return nodelib_cantset(L, field, n);
+ }
+ break;
+ case fence_noad:
+ switch (field) {
+ case 2:
+ subtype(n) = lua_tointeger(L, 3);
+ break;
+ case 4:
+ delimiter(n) = nodelib_getlist(L, 3);
+ break;
+ default:
+ return nodelib_cantset(L, field, n);
+ }
+ break;
+ case math_char_node:
+ case math_text_char_node:
+ switch (field) {
+ case 2:
+ subtype(n) = lua_tointeger(L, 3);
+ break;
+ case 4:
+ math_fam(n) = lua_tointeger(L, 3);
+ break;
+ case 5:
+ math_character(n) = lua_tointeger(L, 3);
+ break;
+ default:
+ return nodelib_cantset(L, field, n);
+ }
+ break;
+ case sub_box_node:
+ case sub_mlist_node:
+ switch (field) {
+ case 2:
+ subtype(n) = lua_tointeger(L, 3);
+ break;
+ case 4:
+ math_list(n) = nodelib_getlist(L, 3);
+ break;
+ default:
+ return nodelib_cantset(L, field, n);
+ }
+ break;
+ case delim_node:
+ switch (field) {
+ case 2:
+ subtype(n) = lua_tointeger(L, 3);
+ break;
+ case 4:
+ small_fam(n) = lua_tointeger(L, 3);
+ break;
+ case 5:
+ small_char(n) = lua_tointeger(L, 3);
+ break;
+ case 6:
+ large_fam(n) = lua_tointeger(L, 3);
+ break;
+ case 7:
+ large_char(n) = lua_tointeger(L, 3);
+ break;
+ default:
+ return nodelib_cantset(L, field, n);
+ }
+ break;
+ case margin_kern_node:
+ switch (field) {
+ case 2:
+ subtype(n) = lua_tointeger(L, 3);
+ break;
+ case 3:
+ width(n) = lua_tointeger(L, 3);
+ break;
+ case 4:
+ margin_char(n) = nodelib_getlist(L, 3);
+ break;
+ default:
+ return nodelib_cantset(L, field, n);
+ }
+ break;
+ case inserting_node:
+ switch (field) {
+ case 2:
+ subtype(n) = lua_tointeger(L, 3);
+ break;
+ case 3:
+ last_ins_ptr(n) = nodelib_getlist(L, 3);
+ break;
+ case 4:
+ best_ins_ptr(n) = nodelib_getlist(L, 3);
+ break;
+ default:
+ return nodelib_cantset(L, field, n);
+ }
+ break;
+ case split_up_node:
+ switch (field) {
+ case 2:
+ subtype(n) = lua_tointeger(L, 3);
+ break;
+ case 3:
+ last_ins_ptr(n) = nodelib_getlist(L, 3);
+ break;
+ case 4:
+ best_ins_ptr(n) = nodelib_getlist(L, 3);
+ break;
+ case 5:
+ broken_ptr(n) = nodelib_getlist(L, 3);
+ break;
+ case 6:
+ broken_ins(n) = nodelib_getlist(L, 3);
+ break;
+ default:
+ return nodelib_cantset(L, field, n);
+ }
+ break;
+ case attribute_list_node:
+ switch (field) {
+ case 2: /* dummy subtype */
+ break;
+ default:
+ return nodelib_cantset(L, field, n);
+ }
+ break;
+ case attribute_node:
+ switch (field) {
+ case 2: /* dummy subtype */
+ break;
+ case 3:
+ attribute_id(n) = lua_tointeger(L, 3);
+ break;
+ case 4:
+ attribute_value(n) = lua_tointeger(L, 3);
+ break;
+ default:
+ return nodelib_cantset(L, field, n);
+ }
+ break;
+ case whatsit_node:
+ lua_nodelib_setfield_whatsit(L, n, field);
+ break;
+ default:
+ /* do nothing */
+ break;
+ }
}
- }
- return 0;
+ return 0;
}
-static int
-lua_nodelib_print (lua_State *L) {
- char *msg;
- char a[7] = {' ',' ',' ', 'n', 'i', 'l', 0};
- char v[7] = {' ',' ',' ', 'n', 'i', 'l', 0};
- halfword *n;
- n = check_isnode(L,1);
- msg = xmalloc(256);
- if (alink(*n)!=null)
- snprintf(a,7,"%6d",(int)alink(*n));
- if (vlink(*n)!=null)
- snprintf(v,7,"%6d",(int)vlink(*n));
- snprintf(msg,255,"<node %s < %6d > %s : %s %d>", a, (int)*n, v, node_data[type(*n)].name, subtype(*n));
- lua_pushstring(L,msg);
- free(msg);
- return 1;
+static int lua_nodelib_print(lua_State * L)
+{
+ char *msg;
+ char a[7] = { ' ', ' ', ' ', 'n', 'i', 'l', 0 };
+ char v[7] = { ' ', ' ', ' ', 'n', 'i', 'l', 0 };
+ halfword *n;
+ n = check_isnode(L, 1);
+ msg = xmalloc(256);
+ if (alink(*n) != null)
+ snprintf(a, 7, "%6d", (int) alink(*n));
+ if (vlink(*n) != null)
+ snprintf(v, 7, "%6d", (int) vlink(*n));
+ snprintf(msg, 255, "<node %s < %6d > %s : %s %d>", a, (int) *n, v,
+ node_data[type(*n)].name, subtype(*n));
+ lua_pushstring(L, msg);
+ free(msg);
+ return 1;
}
-static int
-lua_nodelib_equal (lua_State *L) {
- halfword n, m;
- n = *(check_isnode(L,1));
- m = *(check_isnode(L,2));
- lua_pushboolean(L,(n==m));
- return 1;
-}
-
-static int
-font_tex_ligaturing (lua_State *L) {
- /* on the stack are two nodes and a direction */
- halfword tmp_head;
- halfword *h;
- halfword t =null;
- if (lua_gettop(L)<1) {
- lua_pushnil(L);
- lua_pushboolean(L,0);
- return 2;
- }
- h = check_isnode(L,1);
- if (lua_gettop(L)>1) {
- t = *(check_isnode(L,2));
- }
- tmp_head = new_node(nesting_node,1);
- couple_nodes(tmp_head,*h);
- tlink(tmp_head)=t;
- t = handle_ligaturing(tmp_head,t);
- lua_pushnumber(L,vlink(tmp_head));
- flush_node(tmp_head);
- lua_nodelib_push(L);
- lua_pushnumber(L,t);
- lua_nodelib_push(L);
- lua_pushboolean(L,1);
- return 3;
-}
-
-static int
-font_tex_kerning (lua_State *L) {
- /* on the stack are two nodes and a direction */
-
- halfword tmp_head;
- halfword *h;
- halfword t =null;
- if (lua_gettop(L)<1) {
- lua_pushnil(L);
- lua_pushboolean(L,0);
- return 2;
- }
- h = check_isnode(L,1);
- if (lua_gettop(L)>1) {
- t = *(check_isnode(L,2));
- }
- tmp_head = new_node(nesting_node,1);
- couple_nodes(tmp_head,*h);
- tlink(tmp_head)=t;
- t = handle_kerning(tmp_head,t);
- lua_pushnumber(L,vlink(tmp_head));
- flush_node(tmp_head);
- lua_nodelib_push(L);
- lua_pushnumber(L,t);
- lua_nodelib_push(L);
- lua_pushboolean(L,1);
- return 3;
+static int lua_nodelib_equal(lua_State * L)
+{
+ register halfword n, m;
+ n = *((halfword *) lua_touserdata(L, 1));
+ m = *((halfword *) lua_touserdata(L, 2));
+ lua_pushboolean(L, (n == m));
+ return 1;
}
-static int
-lua_nodelib_protect_glyphs (lua_State *L) {
- int t = 0;
- halfword head = *(check_isnode(L,1));
- while (head!=null) {
- if (type(head)==glyph_node) {
- register int s = subtype(head);
- if (s<256) {
- t = 1;
- subtype(head) = ((s&0xFE) << 8);
- }
- }
- head = vlink(head);
- }
- lua_pushboolean(L,t);
- lua_pushvalue(L,1);
- return 2;
+static int font_tex_ligaturing(lua_State * L)
+{
+ /* on the stack are two nodes and a direction */
+ halfword tmp_head;
+ halfword *h;
+ halfword t = null;
+ if (lua_gettop(L) < 1) {
+ lua_pushnil(L);
+ lua_pushboolean(L, 0);
+ return 2;
+ }
+ h = check_isnode(L, 1);
+ if (lua_gettop(L) > 1) {
+ t = *(check_isnode(L, 2));
+ }
+ tmp_head = new_node(nesting_node, 1);
+ couple_nodes(tmp_head, *h);
+ tlink(tmp_head) = t;
+ t = handle_ligaturing(tmp_head, t);
+ lua_pushnumber(L, vlink(tmp_head));
+ flush_node(tmp_head);
+ lua_nodelib_push(L);
+ lua_pushnumber(L, t);
+ lua_nodelib_push(L);
+ lua_pushboolean(L, 1);
+ return 3;
}
-static int
-lua_nodelib_unprotect_glyphs (lua_State *L) {
- int t = 0;
- halfword head = *(check_isnode(L,1));
- while (head!=null) {
- if (type(head)==glyph_node) {
- register int s = subtype(head);
- if (s>=256) {
- t = 1;
- subtype(head) = (s >> 8);
- }
- }
- head = vlink(head);
- }
- lua_pushboolean(L,t);
- lua_pushvalue(L,1);
- return 2;
+static int font_tex_kerning(lua_State * L)
+{
+ /* on the stack are two nodes and a direction */
+
+ halfword tmp_head;
+ halfword *h;
+ halfword t = null;
+ if (lua_gettop(L) < 1) {
+ lua_pushnil(L);
+ lua_pushboolean(L, 0);
+ return 2;
+ }
+ h = check_isnode(L, 1);
+ if (lua_gettop(L) > 1) {
+ t = *(check_isnode(L, 2));
+ }
+ tmp_head = new_node(nesting_node, 1);
+ couple_nodes(tmp_head, *h);
+ tlink(tmp_head) = t;
+ t = handle_kerning(tmp_head, t);
+ lua_pushnumber(L, vlink(tmp_head));
+ flush_node(tmp_head);
+ lua_nodelib_push(L);
+ lua_pushnumber(L, t);
+ lua_nodelib_push(L);
+ lua_pushboolean(L, 1);
+ return 3;
}
+static int lua_nodelib_protect_glyphs(lua_State * L)
+{
+ int t = 0;
+ halfword head = *(check_isnode(L, 1));
+ while (head != null) {
+ if (type(head) == glyph_node) {
+ register int s = subtype(head);
+ if (s <= 256) {
+ t = 1;
+ subtype(head) = (s == 1 ? 256 : 256 + s);
+ }
+ }
+ head = vlink(head);
+ }
+ lua_pushboolean(L, t);
+ lua_pushvalue(L, 1);
+ return 2;
+}
-static int
-lua_nodelib_first_character (lua_State *L) {
- /* on the stack are two nodes and a direction */
- halfword h, savetail = null, t = null;
- if (lua_gettop(L)<1) {
- lua_pushnil(L);
- lua_pushboolean(L,0);
+static int lua_nodelib_unprotect_glyphs(lua_State * L)
+{
+ int t = 0;
+ halfword head = *(check_isnode(L, 1));
+ while (head != null) {
+ if (type(head) == glyph_node) {
+ register int s = subtype(head);
+ if (s > 256) {
+ t = 1;
+ subtype(head) = s - 256;
+ }
+ }
+ head = vlink(head);
+ }
+ lua_pushboolean(L, t);
+ lua_pushvalue(L, 1);
+ return 2;
+}
+
+
+static int lua_nodelib_first_character(lua_State * L)
+{
+ /* on the stack are two nodes and a direction */
+ halfword h, savetail = null, t = null;
+ if (lua_gettop(L) < 1) {
+ lua_pushnil(L);
+ lua_pushboolean(L, 0);
+ return 2;
+ }
+ h = *(check_isnode(L, 1));
+ if (lua_gettop(L) > 1) {
+ t = *(check_isnode(L, 2));
+ savetail = vlink(t);
+ vlink(t) = null;
+ }
+ while (h != null && !is_simple_character(h)) {
+ h = vlink(h);
+ }
+ if (savetail != null) {
+ vlink(t) = savetail;
+ }
+ lua_pushnumber(L, h);
+ lua_nodelib_push(L);
+ lua_pushboolean(L, (h == null ? 0 : 1));
return 2;
- }
- h = *(check_isnode(L,1));
- if (lua_gettop(L)>1) {
- t = *(check_isnode(L,2));
- savetail = vlink(t);
- vlink(t) = null;
- }
- while (h!=null && !is_simple_character(h)) {
- h = vlink(h);
- }
- if (savetail!=null) { vlink(t) = savetail; }
- lua_pushnumber(L,h);
- lua_nodelib_push(L);
- lua_pushboolean(L,(h==null? 0 : 1));
- return 2;
}
/* this is too simplistic, but it helps Hans to get going */
-halfword
-do_ligature_n (halfword prev, halfword stop, halfword lig) {
- vlink(lig) = vlink(stop);
- vlink(stop) = null;
- lig_ptr(lig) = vlink(prev);
- vlink(prev) = lig;
- return lig;
+halfword do_ligature_n(halfword prev, halfword stop, halfword lig)
+{
+ vlink(lig) = vlink(stop);
+ vlink(stop) = null;
+ lig_ptr(lig) = vlink(prev);
+ vlink(prev) = lig;
+ return lig;
}
/* node.do_ligature_n(node prev, node last, node lig) */
-static int
-lua_nodelib_do_ligature_n (lua_State *L) {
- halfword n, m, o, p, tmp_head;
- n = *(check_isnode(L,1));
- m = *(check_isnode(L,2));
- o = *(check_isnode(L,3));
- if (alink(n)==null || vlink(alink(n))!=n) {
- tmp_head = new_node(temp_node,0);
- couple_nodes(tmp_head,n);
- p = do_ligature_n(tmp_head,m,o);
- flush_node(tmp_head);
- } else {
- p = do_ligature_n(alink(n),m,o);
- }
- lua_pushnumber(L,p);
- lua_nodelib_push(L);
- return 1;
+static int lua_nodelib_do_ligature_n(lua_State * L)
+{
+ halfword n, m, o, p, tmp_head;
+ n = *(check_isnode(L, 1));
+ m = *(check_isnode(L, 2));
+ o = *(check_isnode(L, 3));
+ if (alink(n) == null || vlink(alink(n)) != n) {
+ tmp_head = new_node(temp_node, 0);
+ couple_nodes(tmp_head, n);
+ p = do_ligature_n(tmp_head, m, o);
+ flush_node(tmp_head);
+ } else {
+ p = do_ligature_n(alink(n), m, o);
+ }
+ lua_pushnumber(L, p);
+ lua_nodelib_push(L);
+ return 1;
}
-extern halfword list_node_mem_usage (void) ;
+extern halfword list_node_mem_usage(void);
-static int
-lua_nodelib_usedlist (lua_State *L) {
- lua_pushnumber(L,list_node_mem_usage());
- lua_nodelib_push(L);
- return 1;
-}
-
-
-static const struct luaL_reg nodelib_f [] = {
- {"id", lua_nodelib_id},
- {"subtype", lua_nodelib_subtype},
- {"type", lua_nodelib_type},
- {"new", lua_nodelib_new},
- {"length", lua_nodelib_length},
- {"count", lua_nodelib_count},
- {"traverse", lua_nodelib_traverse},
- {"traverse_id", lua_nodelib_traverse_filtered},
- {"slide", lua_nodelib_tail},
- {"types", lua_nodelib_types},
- {"whatsits", lua_nodelib_whatsits},
- {"fields", lua_nodelib_fields},
- {"has_field", lua_nodelib_has_field},
- {"free", lua_nodelib_free},
- {"flush_list", lua_nodelib_flush_list},
- {"remove", lua_nodelib_remove},
- {"insert_before", lua_nodelib_insert_before},
- {"insert_after", lua_nodelib_insert_after},
- {"write", lua_nodelib_append},
- {"last_node", lua_nodelib_last_node},
- {"copy", lua_nodelib_copy},
- {"copy_list", lua_nodelib_copy_list},
- {"hpack", lua_nodelib_hpack},
- {"has_attribute", lua_nodelib_has_attribute},
- {"set_attribute", lua_nodelib_set_attribute},
- {"unset_attribute", lua_nodelib_unset_attribute},
- {"do_ligature_n", lua_nodelib_do_ligature_n},
- {"ligaturing", font_tex_ligaturing},
- {"kerning", font_tex_kerning},
- {"first_character", lua_nodelib_first_character},
- {"usedlist", lua_nodelib_usedlist},
- {"protect_glyphs", lua_nodelib_protect_glyphs},
- {"unprotect_glyphs", lua_nodelib_unprotect_glyphs},
- {NULL, NULL} /* sentinel */
+static int lua_nodelib_usedlist(lua_State * L)
+{
+ lua_pushnumber(L, list_node_mem_usage());
+ lua_nodelib_push(L);
+ return 1;
+}
+
+
+static const struct luaL_reg nodelib_f[] = {
+ {"id", lua_nodelib_id},
+ {"subtype", lua_nodelib_subtype},
+ {"type", lua_nodelib_type},
+ {"new", lua_nodelib_new},
+ {"length", lua_nodelib_length},
+ {"count", lua_nodelib_count},
+ {"traverse", lua_nodelib_traverse},
+ {"traverse_id", lua_nodelib_traverse_filtered},
+ {"slide", lua_nodelib_tail},
+ {"types", lua_nodelib_types},
+ {"whatsits", lua_nodelib_whatsits},
+ {"fields", lua_nodelib_fields},
+ {"has_field", lua_nodelib_has_field},
+ {"free", lua_nodelib_free},
+ {"flush_list", lua_nodelib_flush_list},
+ {"remove", lua_nodelib_remove},
+ {"insert_before", lua_nodelib_insert_before},
+ {"insert_after", lua_nodelib_insert_after},
+ {"write", lua_nodelib_append},
+ {"last_node", lua_nodelib_last_node},
+ {"copy", lua_nodelib_copy},
+ {"copy_list", lua_nodelib_copy_list},
+ {"hpack", lua_nodelib_hpack},
+ {"vpack", lua_nodelib_vpack},
+ {"mlist_to_hlist", lua_nodelib_mlist_to_hlist},
+ {"family_font", lua_nodelib_mfont},
+ {"has_attribute", lua_nodelib_has_attribute},
+ {"set_attribute", lua_nodelib_set_attribute},
+ {"unset_attribute", lua_nodelib_unset_attribute},
+ {"do_ligature_n", lua_nodelib_do_ligature_n},
+ {"ligaturing", font_tex_ligaturing},
+ {"kerning", font_tex_kerning},
+ {"first_character", lua_nodelib_first_character},
+ {"usedlist", lua_nodelib_usedlist},
+ {"protect_glyphs", lua_nodelib_protect_glyphs},
+ {"unprotect_glyphs", lua_nodelib_unprotect_glyphs},
+ {NULL, NULL} /* sentinel */
};
-static const struct luaL_reg nodelib_m [] = {
- {"__index", lua_nodelib_getfield},
- {"__newindex", lua_nodelib_setfield},
- {"__tostring", lua_nodelib_print},
- {"__eq", lua_nodelib_equal},
- {NULL, NULL} /* sentinel */
+static const struct luaL_reg nodelib_m[] = {
+ {"__index", lua_nodelib_getfield},
+ {"__newindex", lua_nodelib_setfield},
+ {"__tostring", lua_nodelib_print},
+ {"__eq", lua_nodelib_equal},
+ {NULL, NULL} /* sentinel */
};
-int
-luaopen_node (lua_State *L)
+int luaopen_node(lua_State * L)
{
- luaL_newmetatable(L,NODE_METATABLE);
- luaL_register(L, NULL, nodelib_m);
- luaL_register(L, "node", nodelib_f);
- init_luaS_index(luatex_node);
- initialize_luaS_indexes(L);
- return 1;
+ luaL_newmetatable(L, NODE_METATABLE);
+ luaL_register(L, NULL, nodelib_m);
+ luaL_register(L, "node", nodelib_f);
+ init_luaS_index(luatex_node);
+ initialize_luaS_indexes(L);
+ return 1;
}
-void
-nodelist_to_lua (lua_State *L, int n) {
- lua_pushnumber(L,n);
- lua_nodelib_push(L);
+void nodelist_to_lua(lua_State * L, int n)
+{
+ lua_pushnumber(L, n);
+ lua_nodelib_push(L);
}
-int
-nodelist_from_lua (lua_State *L) {
- halfword *n;
- if (lua_isnil(L,-1))
- return null;
- n = check_isnode(L,-1);
- return *n;
+int nodelist_from_lua(lua_State * L)
+{
+ halfword *n;
+ if (lua_isnil(L, -1))
+ return null;
+ n = check_isnode(L, -1);
+ return *n;
}
-
diff --git a/Build/source/texk/web2c/luatexdir/lua/loslibext.c b/Build/source/texk/web2c/luatexdir/lua/loslibext.c
index e79e3a52a98..5f5da8dd6f5 100644
--- a/Build/source/texk/web2c/luatexdir/lua/loslibext.c
+++ b/Build/source/texk/web2c/luatexdir/lua/loslibext.c
@@ -1,4 +1,21 @@
-/* $Id: loslibext.c 1066 2008-02-23 10:52:51Z taco $ */
+/* loslibext.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 General Public License as published by the Free
+ Software Foundation; either version 2 of the License, or (at your
+ option) any later version.
+
+ LuaTeX is distributed in the hope that it will be useful, but WITHOUT
+ ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
+ FITNESS FOR A PARTICULAR PURPOSE. See the GNU Lesser General Public
+ License for more details.
+
+ You should have received a copy of the GNU General Public License along
+ with LuaTeX; if not, see <http://www.gnu.org/licenses/>. */
#include "luatex-api.h"
#include <ptexlib.h>
@@ -7,6 +24,15 @@
#include <sys/types.h>
#include <time.h>
+static const char _svn_version[] =
+ "$Id: loslibext.c 1594 2008-11-28 13:32:48Z oneiros $ $URL: http://scm.foundry.supelec.fr/svn/luatex/trunk/src/texk/web2c/luatexdir/lua/loslibext.c $";
+
+#if defined(_WIN32) || defined(WIN32) || defined(__NT__)
+#define MKDIR(a,b) mkdir(a)
+#else
+#define MKDIR(a,b) mkdir(a,b)
+#endif
+
/* An attempt to figure out the basic platform, does not
care about niceties like version numbers yet,
and ignores platforms where luatex is unlikely to
@@ -14,47 +40,48 @@
(amiga|mac|os2|vms) */
#if defined(_WIN32) || defined(WIN32) || defined(__NT__)
-#define OS_PLATTYPE "windows"
-#define OS_PLATNAME "windows"
-#elif defined(__GO32__) || defined(__DJGPP__) || defined(__DOS__)
-#define OS_PLATTYPE "msdos"
-#define OS_PLATNAME "msdos"
-#else /* assume everything else is unix-y */
-#define OS_PLATTYPE "unix"
+# define OS_PLATTYPE "windows"
+# define OS_PLATNAME "windows"
+#elif defined(__GO32__) || defined(__DJGPP__) || defined(__DOS__)
+# define OS_PLATTYPE "msdos"
+# define OS_PLATNAME "msdos"
+#else /* assume everything else is unix-y */
+# include <sys/utsname.h>
+# define OS_PLATTYPE "unix"
/* this is just a first guess */
-#if defined(__BSD__)
- #define OS_PLATNAME "bsd"
-#elif defined(__SYSV__)
- #define OS_PLATNAME "sysv"
-#else
- #define OS_PLATNAME "generic"
-#endif
+# if defined(__BSD__)
+# define OS_PLATNAME "bsd"
+# elif defined(__SYSV__)
+# define OS_PLATNAME "sysv"
+# else
+# define OS_PLATNAME "generic"
+# endif
/* attempt to be more precise */
-#if defined(__LINUX__) || defined (__linux)
- #undef OS_PLATNAME
- #define OS_PLATNAME "linux"
-#elif defined(__FREEBSD__) || defined(__FreeBSD)
- #undef OS_PLATNAME
- #define OS_PLATNAME "freebsd"
-#elif defined(__OPENBSD__) || defined(__OpenBSD)
- #undef OS_PLATNAME
- #define OS_PLATNAME "openbsd"
-#elif defined(__SOLARIS__)
- #undef OS_PLATNAME
- #define OS_PLATNAME "solaris"
-#elif defined(__SUNOS__) || defined(__SUN__) || defined(sun)
- #undef OS_PLATNAME
- #define OS_PLATNAME "sunos"
-#elif defined(HPUX) || defined(__hpux)
- #undef OS_PLATNAME
- #define OS_PLATNAME "hpux"
-#elif defined(__sgi)
- #undef OS_PLATNAME
- #define OS_PLATNAME "irix"
-#elif defined(__MACH__) && defined(__APPLE__)
- #undef OS_PLATNAME
- #define OS_PLATNAME "macosx"
-#endif
+# if defined(__LINUX__) || defined (__linux)
+# undef OS_PLATNAME
+# define OS_PLATNAME "linux"
+# elif defined(__FREEBSD__) || defined(__FreeBSD__) || defined(__FreeBSD)
+# undef OS_PLATNAME
+# define OS_PLATNAME "freebsd"
+# elif defined(__OPENBSD__) || defined(__OpenBSD)
+# undef OS_PLATNAME
+# define OS_PLATNAME "openbsd"
+# elif defined(__SOLARIS__)
+# undef OS_PLATNAME
+# define OS_PLATNAME "solaris"
+# elif defined(__SUNOS__) || defined(__SUN__) || defined(sun)
+# undef OS_PLATNAME
+# define OS_PLATNAME "sunos"
+# elif defined(HPUX) || defined(__hpux)
+# undef OS_PLATNAME
+# define OS_PLATNAME "hpux"
+# elif defined(__sgi)
+# undef OS_PLATNAME
+# define OS_PLATNAME "irix"
+# elif defined(__MACH__) && defined(__APPLE__)
+# undef OS_PLATNAME
+# define OS_PLATNAME "macosx"
+# endif
#endif
@@ -67,77 +94,76 @@
*/
#if (! defined(WIN32)) && (! defined(__SUNOS__))
-#include <sys/time.h> /* gettimeofday() */
-#include <sys/times.h> /* times() */
-#include <sys/wait.h>
-#endif
+# include <sys/time.h> /* gettimeofday() */
+# include <sys/times.h> /* times() */
+# include <sys/wait.h>
+#endif
/* set this to one for spawn instead of exec on windows */
#define DONT_REALLY_EXIT 1
#ifdef WIN32
-#include <process.h>
-#define spawn_command(a,b,c) _spawnvpe(_P_WAIT,(const char *)a,(const char* const*)b,(const char* const*)c)
-#if DONT_REALLY_EXIT
-#define exec_command(a,b,c) exit(spawn_command((a),(b),(c)))
+# include <process.h>
+# define spawn_command(a,b,c) _spawnvpe(_P_WAIT,(const char *)a,(const char* const*)b,(const char* const*)c)
+# if DONT_REALLY_EXIT
+# define exec_command(a,b,c) exit(spawn_command((a),(b),(c)))
+# else
+# define exec_command(a,b,c) _execvpe((const char *)a,(const char* const*)b,(const char* const*)c)
+# endif
#else
-#define exec_command(a,b,c) _execvpe((const char *)a,(const char* const*)b,(const char* const*)c)
-#endif
-#else
-#include <unistd.h>
-#define DEFAULT_PATH "/bin:/usr/bin:."
+# include <unistd.h>
+# define DEFAULT_PATH "/bin:/usr/bin:."
-static int
-exec_command(const char *file, char *const *argv, char *const *envp)
+static int exec_command(const char *file, char *const *argv, char *const *envp)
{
- char path[PATH_MAX];
- const char *searchpath, *esp;
- size_t prefixlen, filelen, totallen;
-
- if (strchr(file, '/')) /* Specific path */
- return execve(file, argv, envp);
-
- filelen = strlen(file);
-
- searchpath = getenv("PATH");
- if (!searchpath)
- searchpath = DEFAULT_PATH;
-
- errno = ENOENT; /* Default errno, if execve() doesn't change it */
-
- do {
- esp = strchr(searchpath, ':');
- if (esp)
- prefixlen = esp - searchpath;
- else
- prefixlen = strlen(searchpath);
-
- if (prefixlen == 0 || searchpath[prefixlen - 1] == '/') {
- totallen = prefixlen + filelen;
- if (totallen >= PATH_MAX)
- continue;
- memcpy(path, searchpath, prefixlen);
- memcpy(path + prefixlen, file, filelen);
- } else {
- totallen = prefixlen + filelen + 1;
- if (totallen >= PATH_MAX)
- continue;
- memcpy(path, searchpath, prefixlen);
- path[prefixlen] = '/';
- memcpy(path + prefixlen + 1, file, filelen);
- }
- path[totallen] = '\0';
-
- execve(path, argv, envp);
- if (errno == E2BIG || errno == ENOEXEC ||
- errno == ENOMEM || errno == ETXTBSY)
- break; /* Report this as an error, no more search */
-
- searchpath = esp + 1;
- } while (esp);
-
- return -1;
+ char path[PATH_MAX];
+ const char *searchpath, *esp;
+ size_t prefixlen, filelen, totallen;
+
+ if (strchr(file, '/')) /* Specific path */
+ return execve(file, argv, envp);
+
+ filelen = strlen(file);
+
+ searchpath = getenv("PATH");
+ if (!searchpath)
+ searchpath = DEFAULT_PATH;
+
+ errno = ENOENT; /* Default errno, if execve() doesn't change it */
+
+ do {
+ esp = strchr(searchpath, ':');
+ if (esp)
+ prefixlen = esp - searchpath;
+ else
+ prefixlen = strlen(searchpath);
+
+ if (prefixlen == 0 || searchpath[prefixlen - 1] == '/') {
+ totallen = prefixlen + filelen;
+ if (totallen >= PATH_MAX)
+ continue;
+ memcpy(path, searchpath, prefixlen);
+ memcpy(path + prefixlen, file, filelen);
+ } else {
+ totallen = prefixlen + filelen + 1;
+ if (totallen >= PATH_MAX)
+ continue;
+ memcpy(path, searchpath, prefixlen);
+ path[prefixlen] = '/';
+ memcpy(path + prefixlen + 1, file, filelen);
+ }
+ path[totallen] = '\0';
+
+ execve(path, argv, envp);
+ if (errno == E2BIG || errno == ENOEXEC ||
+ errno == ENOMEM || errno == ETXTBSY)
+ break; /* Report this as an error, no more search */
+
+ searchpath = esp + 1;
+ } while (esp);
+
+ return -1;
}
/*
@@ -159,61 +185,66 @@ exec_command(const char *file, char *const *argv, char *const *envp)
range in the 8-bit section.
*/
-#define INVALID_RET_E2BIG 143
-#define INVALID_RET_ENOENT 144
-#define INVALID_RET_ENOEXEC 145
-#define INVALID_RET_ENOMEM 146
-#define INVALID_RET_ETXTBSY 147
-#define INVALID_RET_UNKNOWN 148
-#define INVALID_RET_INTR 149
+# define INVALID_RET_E2BIG 143
+# define INVALID_RET_ENOENT 144
+# define INVALID_RET_ENOEXEC 145
+# define INVALID_RET_ENOMEM 146
+# define INVALID_RET_ETXTBSY 147
+# define INVALID_RET_UNKNOWN 148
+# define INVALID_RET_INTR 149
-static int
-spawn_command(const char *file, char *const *argv, char *const *envp)
+static int spawn_command(const char *file, char *const *argv, char *const *envp)
{
- pid_t pid, wait_pid;
- int status;
- pid = fork();
- if (pid<0) {
- return -1; /* fork failed */
- }
- if (pid>0) { /* parent */
- status = 0;
- wait_pid = waitpid (pid, &status,0);
- if (wait_pid == pid) {
- if (WIFEXITED(status))
- return WEXITSTATUS(status);
- else
- return INVALID_RET_INTR;
- } else {
- return -1; /* some waitpid error */
+ pid_t pid, wait_pid;
+ int status;
+ pid = fork();
+ if (pid < 0) {
+ return -1; /* fork failed */
}
- } else {
- int f;
- /* somewhat random upper limit. ignore errors on purpose */
- for (f = 0; f<256; f++)
- (void)fsync(f);
-
- if (exec_command(file, argv, envp)) {
- /* let's hope no-one uses these values */
- switch (errno) {
- case E2BIG: exit(INVALID_RET_E2BIG);
- case ETXTBSY: exit(INVALID_RET_ETXTBSY);
- case ENOENT: exit(INVALID_RET_ENOENT);
- case ENOEXEC: exit(INVALID_RET_ENOEXEC);
- case ENOMEM: exit(INVALID_RET_ENOMEM);
- default: exit(INVALID_RET_UNKNOWN);
- }
- return -1;
+ if (pid > 0) { /* parent */
+ status = 0;
+ wait_pid = waitpid(pid, &status, 0);
+ if (wait_pid == pid) {
+ if (WIFEXITED(status))
+ return WEXITSTATUS(status);
+ else
+ return INVALID_RET_INTR;
+ } else {
+ return -1; /* some waitpid error */
+ }
+ } else {
+ int f;
+ /* somewhat random upper limit. ignore errors on purpose */
+ for (f = 0; f < 256; f++)
+ (void) fsync(f);
+
+ if (exec_command(file, argv, envp)) {
+ /* let's hope no-one uses these values */
+ switch (errno) {
+ case E2BIG:
+ exit(INVALID_RET_E2BIG);
+ case ETXTBSY:
+ exit(INVALID_RET_ETXTBSY);
+ case ENOENT:
+ exit(INVALID_RET_ENOENT);
+ case ENOEXEC:
+ exit(INVALID_RET_ENOEXEC);
+ case ENOMEM:
+ exit(INVALID_RET_ENOMEM);
+ default:
+ exit(INVALID_RET_UNKNOWN);
+ }
+ return -1;
+ }
}
- }
+ return 0;
}
#endif
extern char **environ;
-static char **
-do_split_command(char *maincmd)
+static char **do_split_command(char *maincmd)
{
char *piece, *start_piece;
char *cmd;
@@ -223,299 +254,489 @@ do_split_command(char *maincmd)
int in_string = 0;
int quoted = 0;
if (strlen(maincmd) == 0)
- return NULL;
+ return NULL;
/* allocate the array of options first. it will probably be
be a little bit too big, but better too much than to little */
- j=2;
- for (i = 0; i < strlen(maincmd); i++) { if (maincmd[i]==' ') j++; }
+ j = 2;
+ for (i = 0; i < strlen(maincmd); i++) {
+ if (maincmd[i] == ' ')
+ j++;
+ }
cmdline = malloc(sizeof(char *) * j);
- for (i = 0; i < j; i++) { cmdline[i] = NULL; }
+ for (i = 0; i < j; i++) {
+ cmdline[i] = NULL;
+ }
cmd = maincmd;
i = 0;
- while (cmd[i] == ' ') i++; /* skip leading spaces */
- start_piece = malloc(strlen(cmd)+1); /* a buffer */
+ while (cmd[i] == ' ')
+ i++; /* skip leading spaces */
+ start_piece = malloc(strlen(cmd) + 1); /* a buffer */
piece = start_piece;
for (; i <= strlen(maincmd); i++) {
- if (cmd[i]=='\\' &&
- (cmd[i+1] == '\\' || cmd[i+1] == '\'' || cmd[i+1] == '"')) {
- quoted =1;
- continue;
- }
- if (in_string && cmd[i] == in_string && !quoted) {
- in_string = 0;
- continue;
- }
- if ((cmd[i] == '"' || cmd[i] == '\'')&& !quoted) {
- in_string = cmd[i];
- continue;
- }
- if ((in_string==0 && cmd[i] == ' ') || cmd[i]==0) {
- *piece = 0;
- cmdline[ret++] = xstrdup(start_piece);
- piece = start_piece;
- while (i < strlen(maincmd) && cmd[(i + 1)] == ' ')
- i++;
- continue;
- }
- *piece++ = cmd[i];
- quoted=0;
+ if (cmd[i] == '\\' &&
+ (cmd[i + 1] == '\\' || cmd[i + 1] == '\'' || cmd[i + 1] == '"')) {
+ quoted = 1;
+ continue;
+ }
+ if (in_string && cmd[i] == in_string && !quoted) {
+ in_string = 0;
+ continue;
+ }
+ if ((cmd[i] == '"' || cmd[i] == '\'') && !quoted) {
+ in_string = cmd[i];
+ continue;
+ }
+ if ((in_string == 0 && cmd[i] == ' ') || cmd[i] == 0) {
+ *piece = 0;
+ cmdline[ret++] = xstrdup(start_piece);
+ piece = start_piece;
+ while (i < strlen(maincmd) && cmd[(i + 1)] == ' ')
+ i++;
+ continue;
+ }
+ *piece++ = cmd[i];
+ quoted = 0;
}
xfree(start_piece);
return cmdline;
}
-static char **
-do_flatten_command(lua_State *L, char **runcmd) {
- unsigned int i, j ;
- char *s;
- char **cmdline = NULL;
- *runcmd = NULL;
-
- for (j = 1;;j++) {
- lua_rawgeti(L,-1,j);
- if (lua_isnil(L,-1)) {
- lua_pop(L,1);
- break;
- }
- lua_pop(L,1);
- }
- if (j == 1)
- return NULL;
- cmdline = malloc(sizeof(char *) * (j+1));
- for (i = 1; i <= j; i++) {
- cmdline[i] = NULL;
- lua_rawgeti(L,-1,i);
- if (lua_isnil(L,-1) || (s=(char *)lua_tostring(L,-1))==NULL) {
- lua_pop(L,1);
- if (i==1) {
- xfree(cmdline) ;
- return NULL;
- } else {
- break;
- }
- } else {
- lua_pop(L,1);
- cmdline[(i-1)] = xstrdup(s);
- }
- }
- cmdline[i] = NULL;
-
- lua_rawgeti(L,-1,0);
- if (lua_isnil(L,-1) || (s=(char *)lua_tostring(L,-1))==NULL) {
- *runcmd = cmdline[0];
- } else {
- *runcmd = xstrdup(s);
- }
- lua_pop(L,1);
-
- return cmdline;
+static char **do_flatten_command(lua_State * L, char **runcmd)
+{
+ unsigned int i, j;
+ char *s;
+ char **cmdline = NULL;
+ *runcmd = NULL;
+
+ for (j = 1;; j++) {
+ lua_rawgeti(L, -1, j);
+ if (lua_isnil(L, -1)) {
+ lua_pop(L, 1);
+ break;
+ }
+ lua_pop(L, 1);
+ }
+ if (j == 1)
+ return NULL;
+ cmdline = malloc(sizeof(char *) * (j + 1));
+ for (i = 1; i <= j; i++) {
+ cmdline[i] = NULL;
+ lua_rawgeti(L, -1, i);
+ if (lua_isnil(L, -1) || (s = (char *) lua_tostring(L, -1)) == NULL) {
+ lua_pop(L, 1);
+ if (i == 1) {
+ xfree(cmdline);
+ return NULL;
+ } else {
+ break;
+ }
+ } else {
+ lua_pop(L, 1);
+ cmdline[(i - 1)] = xstrdup(s);
+ }
+ }
+ cmdline[i] = NULL;
+
+ lua_rawgeti(L, -1, 0);
+ if (lua_isnil(L, -1) || (s = (char *) lua_tostring(L, -1)) == NULL) {
+ *runcmd = cmdline[0];
+ } else {
+ *runcmd = xstrdup(s);
+ }
+ lua_pop(L, 1);
+
+ return cmdline;
}
-static int os_exec (lua_State *L) {
- char * maincmd, * runcmd;
- char ** cmdline = NULL;
+static int os_exec(lua_State * L)
+{
+ char *maincmd, *runcmd;
+ char **cmdline = NULL;
- if (lua_gettop(L)!=1) {
- lua_pushnil(L);
- lua_pushliteral(L,"invalid arguments passed");
- return 2;
- }
- if (lua_type(L,1)==LUA_TSTRING) {
- maincmd = (char *)lua_tostring(L, 1);
- cmdline = do_split_command(maincmd);
- runcmd = cmdline[0];
- } else if (lua_type(L,1)==LUA_TTABLE) {
- cmdline = do_flatten_command(L, & runcmd);
- }
- if (cmdline!=NULL) {
+ if (lua_gettop(L) != 1) {
+ lua_pushnil(L);
+ lua_pushliteral(L, "invalid arguments passed");
+ return 2;
+ }
+ if (lua_type(L, 1) == LUA_TSTRING) {
+ maincmd = (char *) lua_tostring(L, 1);
+ cmdline = do_split_command(maincmd);
+ runcmd = cmdline[0];
+ } else if (lua_type(L, 1) == LUA_TTABLE) {
+ cmdline = do_flatten_command(L, &runcmd);
+ }
+ if (cmdline != NULL) {
#if defined(WIN32) && DONT_REALLY_EXIT
- exec_command(runcmd, cmdline, environ);
+ exec_command(runcmd, cmdline, environ);
#else
- if (exec_command(runcmd, cmdline, environ)==-1) {
- lua_pushnil(L);
- lua_pushfstring(L,"%s: %s",runcmd, strerror(errno));
- lua_pushnumber(L, errno);
- return 3;
- }
+ if (exec_command(runcmd, cmdline, environ) == -1) {
+ lua_pushnil(L);
+ lua_pushfstring(L, "%s: %s", runcmd, strerror(errno));
+ lua_pushnumber(L, errno);
+ return 3;
+ }
#endif
- }
- lua_pushnil(L);
- lua_pushliteral(L,"invalid command line passed");
- return 2;
+ }
+ lua_pushnil(L);
+ lua_pushliteral(L, "invalid command line passed");
+ return 2;
}
-#define do_error_return(A,B) do { \
- lua_pushnil(L); \
- lua_pushfstring(L,"%s: %s",runcmd,(A)); \
- lua_pushnumber(L, B); \
- return 3; \
+#define do_error_return(A,B) do { \
+ lua_pushnil(L); \
+ lua_pushfstring(L,"%s: %s",runcmd,(A)); \
+ lua_pushnumber(L, B); \
+ return 3; \
} while (0)
-static int os_spawn (lua_State *L) {
- char * maincmd, * runcmd;
- char ** cmdline = NULL;
- int i;
+static int os_spawn(lua_State * L)
+{
+ char *maincmd, *runcmd;
+ char **cmdline = NULL;
+ int i;
- if (lua_gettop(L)!=1) {
- lua_pushnil(L);
- lua_pushliteral(L,"invalid arguments passed");
- return 2;
- }
- if (lua_type(L,1)==LUA_TSTRING) {
- maincmd = (char *)lua_tostring(L, 1);
- cmdline = do_split_command(maincmd);
- runcmd = cmdline[0];
- } else if (lua_type(L,1)==LUA_TTABLE) {
- cmdline = do_flatten_command(L, &runcmd);
- }
- if (cmdline!=NULL) {
- i = spawn_command(runcmd, cmdline, environ);
- if (i==0) {
- lua_pushnumber(L, i);
- return 1;
- } else if (i==-1) {
- /* this branch covers WIN32 as well as fork() and waitpid() errors */
- do_error_return(strerror(errno),errno);
+ if (lua_gettop(L) != 1) {
+ lua_pushnil(L);
+ lua_pushliteral(L, "invalid arguments passed");
+ return 2;
+ }
+ if (lua_type(L, 1) == LUA_TSTRING) {
+ maincmd = (char *) lua_tostring(L, 1);
+ cmdline = do_split_command(maincmd);
+ runcmd = cmdline[0];
+ } else if (lua_type(L, 1) == LUA_TTABLE) {
+ cmdline = do_flatten_command(L, &runcmd);
+ }
+ if (cmdline != NULL) {
+ i = spawn_command(runcmd, cmdline, environ);
+ if (i == 0) {
+ lua_pushnumber(L, i);
+ return 1;
+ } else if (i == -1) {
+ /* this branch covers WIN32 as well as fork() and waitpid() errors */
+ do_error_return(strerror(errno), errno);
#ifndef WIN32
- } else if (i==INVALID_RET_E2BIG) { do_error_return(strerror(E2BIG),i);
- } else if (i==INVALID_RET_ENOENT) { do_error_return(strerror(ENOENT),i);
- } else if (i==INVALID_RET_ENOEXEC) { do_error_return(strerror(ENOEXEC),i);
- } else if (i==INVALID_RET_ENOMEM) { do_error_return(strerror(ENOMEM),i);
- } else if (i==INVALID_RET_ETXTBSY) { do_error_return(strerror(ETXTBSY),i);
- } else if (i==INVALID_RET_UNKNOWN) { do_error_return("execution failed",i);
- } else if (i==INVALID_RET_INTR) { do_error_return("execution interrupted",i);
+ } else if (i == INVALID_RET_E2BIG) {
+ do_error_return(strerror(E2BIG), i);
+ } else if (i == INVALID_RET_ENOENT) {
+ do_error_return(strerror(ENOENT), i);
+ } else if (i == INVALID_RET_ENOEXEC) {
+ do_error_return(strerror(ENOEXEC), i);
+ } else if (i == INVALID_RET_ENOMEM) {
+ do_error_return(strerror(ENOMEM), i);
+ } else if (i == INVALID_RET_ETXTBSY) {
+ do_error_return(strerror(ETXTBSY), i);
+ } else if (i == INVALID_RET_UNKNOWN) {
+ do_error_return("execution failed", i);
+ } else if (i == INVALID_RET_INTR) {
+ do_error_return("execution interrupted", i);
#endif
- } else {
- lua_pushnumber(L, i);
- return 1;
+ } else {
+ lua_pushnumber(L, i);
+ return 1;
+ }
}
- }
- lua_pushnil(L);
- lua_pushliteral(L,"invalid command line passed");
- return 2;
+ lua_pushnil(L);
+ lua_pushliteral(L, "invalid command line passed");
+ return 2;
}
/* Hans wants to set env values */
-static int os_setenv (lua_State *L) {
- char *value, *key, *val;
- key = (char *)luaL_optstring(L, 1, NULL);
- val = (char *)luaL_optstring(L, 2, NULL);
- if (key) {
- if (val) {
- value = xmalloc(strlen(key)+strlen(val)+2);
- sprintf(value,"%s=%s",key,val);
- if (putenv(value)) {
- return luaL_error(L, "unable to change environment");
- }
- } else {
+static int os_setenv(lua_State * L)
+{
+ char *value, *key, *val;
+ key = (char *) luaL_optstring(L, 1, NULL);
+ val = (char *) luaL_optstring(L, 2, NULL);
+ if (key) {
+ if (val) {
+ value = xmalloc(strlen(key) + strlen(val) + 2);
+ sprintf(value, "%s=%s", key, val);
+ if (putenv(value)) {
+ return luaL_error(L, "unable to change environment");
+ }
+ } else {
#if defined(WIN32) || defined(__sun__) || defined(__sun) || defined(_AIX)
- value = xmalloc(strlen(key)+2);
- sprintf(value,"%s=",key);
- if (putenv(value)) {
- return luaL_error(L, "unable to change environment");
- }
+ value = xmalloc(strlen(key) + 2);
+ sprintf(value, "%s=", key);
+ if (putenv(value)) {
+ return luaL_error(L, "unable to change environment");
+ }
#else
- (void)unsetenv(key);
-#endif
- }
- }
- lua_pushboolean (L, 1);
- return 1;
+ (void) unsetenv(key);
+#endif
+ }
+ }
+ lua_pushboolean(L, 1);
+ return 1;
}
-void find_env (lua_State *L){
- char *envitem, *envitem_orig;
- char *envkey;
- char **envpointer;
- envpointer = environ;
- lua_getglobal(L,"os");
- if (envpointer!=NULL && lua_istable(L,-1)) {
- luaL_checkstack(L,2,"out of stack space");
- lua_pushstring(L,"env");
- lua_newtable(L);
- while (*envpointer) {
- /* TODO: perhaps a memory leak here */
- luaL_checkstack(L,2,"out of stack space");
- envitem = xstrdup(*envpointer);
- envitem_orig = envitem;
- envkey=envitem;
- while (*envitem != '=') {
- envitem++;
- }
- *envitem=0;
- envitem++;
- lua_pushstring(L,envkey);
- lua_pushstring(L,envitem);
- lua_rawset(L,-3);
- envpointer++;
- free(envitem_orig);
+void find_env(lua_State * L)
+{
+ char *envitem, *envitem_orig;
+ char *envkey;
+ char **envpointer;
+ envpointer = environ;
+ lua_getglobal(L, "os");
+ if (envpointer != NULL && lua_istable(L, -1)) {
+ luaL_checkstack(L, 2, "out of stack space");
+ lua_pushstring(L, "env");
+ lua_newtable(L);
+ while (*envpointer) {
+ /* TODO: perhaps a memory leak here */
+ luaL_checkstack(L, 2, "out of stack space");
+ envitem = xstrdup(*envpointer);
+ envitem_orig = envitem;
+ envkey = envitem;
+ while (*envitem != '=') {
+ envitem++;
+ }
+ *envitem = 0;
+ envitem++;
+ lua_pushstring(L, envkey);
+ lua_pushstring(L, envitem);
+ lua_rawset(L, -3);
+ envpointer++;
+ free(envitem_orig);
+ }
+ lua_rawset(L, -3);
}
- lua_rawset(L,-3);
- }
- lua_pop(L,1);
+ lua_pop(L, 1);
}
-static int ex_sleep(lua_State *L)
+static int ex_sleep(lua_State * L)
{
- lua_Number interval = luaL_checknumber(L, 1);
- lua_Number units = luaL_optnumber(L, 2, 1);
+ lua_Number interval = luaL_checknumber(L, 1);
+ lua_Number units = luaL_optnumber(L, 2, 1);
#ifdef WIN32
- Sleep(1e3 * interval / units);
-#else /* assumes posix or bsd */
- usleep(1e6 * interval / units);
+ Sleep(1e3 * interval / units);
+#else /* assumes posix or bsd */
+ usleep(1e6 * interval / units);
#endif
- return 0;
+ return 0;
}
-#if (! defined (WIN32)) && (! defined (__SUNOS__))
-static int os_times (lua_State *L) {
- struct tms r;
- (void)times(&r);
- lua_newtable(L);
- lua_pushnumber(L, ((lua_Number)(r.tms_utime))/(lua_Number)sysconf(_SC_CLK_TCK));
- lua_setfield(L,-2,"utime");
- lua_pushnumber(L, ((lua_Number)(r.tms_stime))/(lua_Number)sysconf(_SC_CLK_TCK));
- lua_setfield(L,-2,"stime");
- lua_pushnumber(L, ((lua_Number)(r.tms_cutime))/(lua_Number)sysconf(_SC_CLK_TCK));
- lua_setfield(L,-2,"cutime");
- lua_pushnumber(L, ((lua_Number)(r.tms_cstime))/(lua_Number)sysconf(_SC_CLK_TCK));
- lua_setfield(L,-2,"cstime");
- return 1;
+
+
+#ifdef WIN32
+# define _UTSNAME_LENGTH 65
+
+/* Structure describing the system and machine. */
+struct utsname {
+ char sysname[_UTSNAME_LENGTH];
+ char nodename[_UTSNAME_LENGTH];
+ char release[_UTSNAME_LENGTH];
+ char version[_UTSNAME_LENGTH];
+ char machine[_UTSNAME_LENGTH];
+};
+
+/*
+ * Get name and information about current kernel.
+ */
+static int uname(struct utsname *uts)
+{
+ enum { WinNT, Win95, Win98, WinUnknown };
+ OSVERSIONINFO osver;
+ SYSTEM_INFO sysinfo;
+ DWORD sLength;
+ DWORD os = WinUnknown;
+
+ memset(uts, 0, sizeof(*uts));
+
+ osver.dwOSVersionInfoSize = sizeof(osver);
+ GetVersionEx(&osver);
+ GetSystemInfo(&sysinfo);
+
+ switch (osver.dwPlatformId) {
+ case VER_PLATFORM_WIN32_NT: /* NT, Windows 2000 or Windows XP */
+ if (osver.dwMajorVersion == 4)
+ strcpy(uts->sysname, "Windows NT4x"); /* NT4x */
+ else if (osver.dwMajorVersion <= 3)
+ strcpy(uts->sysname, "Windows NT3x"); /* NT3x */
+ else if (osver.dwMajorVersion == 5) {
+ if (osver.dwMinorVersion == 0)
+ strcpy(uts->sysname, "Windows 2000"); /* 2k */
+ else if (osver.dwMinorVersion == 1)
+ strcpy(uts->sysname, "Windows XP"); /* XP */
+ else if (osver.dwMinorVersion == 2)
+ strcpy(uts->sysname, "Windows Server 2003"); /* Server 2003 */
+ } else if (osver.dwMajorVersion == 6) {
+ /*
+ if( osver.wProductType == VER_NT_WORKSTATION )
+ */
+ strcpy(uts->sysname, "Windows Vista"); /* Vista */
+ /*
+ else
+ strcpy (uts->sysname, "Windows Server 2008");
+ */
+ }
+ os = WinNT;
+ break;
+
+ case VER_PLATFORM_WIN32_WINDOWS: /* Win95, Win98 or WinME */
+ if ((osver.dwMajorVersion > 4) ||
+ ((osver.dwMajorVersion == 4) && (osver.dwMinorVersion > 0))) {
+ if (osver.dwMinorVersion >= 90)
+ strcpy(uts->sysname, "Windows ME"); /* ME */
+ else
+ strcpy(uts->sysname, "Windows 98"); /* 98 */
+ os = Win98;
+ } else {
+ strcpy(uts->sysname, "Windows 95"); /* 95 */
+ os = Win95;
+ }
+ break;
+
+ case VER_PLATFORM_WIN32s: /* Windows 3.x */
+ strcpy(uts->sysname, "Windows");
+ break;
+
+ default: /* anything else */
+ strcpy(uts->sysname, "Windows");
+ break;
+ }
+
+ sprintf(uts->version, "%ld.%02ld",
+ osver.dwMajorVersion, osver.dwMinorVersion);
+
+ if (osver.szCSDVersion[0] != '\0' &&
+ (strlen(osver.szCSDVersion) + strlen(uts->version) + 1) <
+ sizeof(uts->version)) {
+ strcat(uts->version, " ");
+ strcat(uts->version, osver.szCSDVersion);
+ }
+
+ sprintf(uts->release, "build %ld", osver.dwBuildNumber & 0xFFFF);
+
+ switch (sysinfo.wProcessorArchitecture) {
+ case PROCESSOR_ARCHITECTURE_PPC:
+ strcpy(uts->machine, "ppc");
+ break;
+ case PROCESSOR_ARCHITECTURE_ALPHA:
+ strcpy(uts->machine, "alpha");
+ break;
+ case PROCESSOR_ARCHITECTURE_MIPS:
+ strcpy(uts->machine, "mips");
+ break;
+ case PROCESSOR_ARCHITECTURE_INTEL:
+ /*
+ * dwProcessorType is only valid in Win95 and Win98 and WinME
+ * wProcessorLevel is only valid in WinNT
+ */
+ switch (os) {
+ case Win95:
+ case Win98:
+ switch (sysinfo.dwProcessorType) {
+ case PROCESSOR_INTEL_386:
+ case PROCESSOR_INTEL_486:
+ case PROCESSOR_INTEL_PENTIUM:
+ sprintf(uts->machine, "i%ld", sysinfo.dwProcessorType);
+ break;
+ default:
+ strcpy(uts->machine, "i386");
+ break;
+ }
+ break;
+ case WinNT:
+ sprintf(uts->machine, "i%d86", sysinfo.wProcessorLevel);
+ break;
+ default:
+ strcpy(uts->machine, "unknown");
+ break;
+ }
+ break;
+ default:
+ strcpy(uts->machine, "unknown");
+ break;
+ }
+
+ sLength = sizeof(uts->nodename) - 1;
+ GetComputerName(uts->nodename, &sLength);
+ return 0;
}
#endif
-#if ! defined (__SUNOS__)
-#if defined(_MSC_VER) || defined(_MSC_EXTENSIONS)
- #define DELTA_EPOCH_IN_MICROSECS 11644473600000000Ui64
-#else
- #define DELTA_EPOCH_IN_MICROSECS 11644473600000000ULL
+static int ex_uname(lua_State * L)
+{
+ struct utsname uts;
+ if (uname(&uts) >= 0) {
+ lua_newtable(L);
+ lua_pushstring(L, uts.sysname);
+ lua_setfield(L, -2, "sysname");
+ lua_pushstring(L, uts.machine);
+ lua_setfield(L, -2, "machine");
+ lua_pushstring(L, uts.release);
+ lua_setfield(L, -2, "release");
+ lua_pushstring(L, uts.version);
+ lua_setfield(L, -2, "version");
+ lua_pushstring(L, uts.nodename);
+ lua_setfield(L, -2, "nodename");
+ } else {
+ lua_pushnil(L);
+ }
+ return 1;
+}
+
+
+#if (! defined (WIN32)) && (! defined (__SUNOS__))
+static int os_times(lua_State * L)
+{
+ struct tms r;
+ (void) times(&r);
+ lua_newtable(L);
+ lua_pushnumber(L,
+ ((lua_Number) (r.tms_utime)) /
+ (lua_Number) sysconf(_SC_CLK_TCK));
+ lua_setfield(L, -2, "utime");
+ lua_pushnumber(L,
+ ((lua_Number) (r.tms_stime)) /
+ (lua_Number) sysconf(_SC_CLK_TCK));
+ lua_setfield(L, -2, "stime");
+ lua_pushnumber(L,
+ ((lua_Number) (r.tms_cutime)) /
+ (lua_Number) sysconf(_SC_CLK_TCK));
+ lua_setfield(L, -2, "cutime");
+ lua_pushnumber(L,
+ ((lua_Number) (r.tms_cstime)) /
+ (lua_Number) sysconf(_SC_CLK_TCK));
+ lua_setfield(L, -2, "cstime");
+ return 1;
+}
#endif
-static int os_gettimeofday (lua_State *L) {
- double v;
-#ifndef WIN32
- struct timeval tv;
- gettimeofday(&tv, NULL);
- v = (double)tv.tv_sec + (double)tv.tv_usec / 1000000.0;
-#else
- FILETIME ft;
- unsigned __int64 tmpres = 0;
+#if ! defined (__SUNOS__)
- GetSystemTimeAsFileTime(&ft);
+# if defined(_MSC_VER) || defined(_MSC_EXTENSIONS)
+# define DELTA_EPOCH_IN_MICROSECS 11644473600000000Ui64
+# else
+# define DELTA_EPOCH_IN_MICROSECS 11644473600000000ULL
+# endif
- tmpres |= ft.dwHighDateTime;
- tmpres <<= 32;
- tmpres |= ft.dwLowDateTime;
- tmpres /= 10;
- tmpres -= DELTA_EPOCH_IN_MICROSECS; /*converting file time to unix epoch*/
- v = (double)tmpres / 1000000.0;
-#endif
- lua_pushnumber(L, v);
- return 1;
+static int os_gettimeofday(lua_State * L)
+{
+ double v;
+# ifndef WIN32
+ struct timeval tv;
+ gettimeofday(&tv, NULL);
+ v = (double) tv.tv_sec + (double) tv.tv_usec / 1000000.0;
+# else
+ FILETIME ft;
+ unsigned __int64 tmpres = 0;
+
+ GetSystemTimeAsFileTime(&ft);
+
+ tmpres |= ft.dwHighDateTime;
+ tmpres <<= 32;
+ tmpres |= ft.dwLowDateTime;
+ tmpres /= 10;
+ tmpres -= DELTA_EPOCH_IN_MICROSECS; /*converting file time to unix epoch */
+ v = (double) tmpres / 1000000.0;
+# endif
+ lua_pushnumber(L, v);
+ return 1;
}
#endif
@@ -525,103 +746,110 @@ static int dirs_made = 0;
#define MAXTRIES 36*36*36
-char *
-do_mkdtemp (char *tmpl)
+char *do_mkdtemp(char *tmpl)
{
- int count ;
- int value ;
- char *xes = &tmpl[strlen (tmpl) - 6];
- /* this is not really all that random, but it will do */
- if (dirs_made==0) {
- srand(time(NULL));
- }
- value = rand();
- for (count = 0; count < MAXTRIES; value += 8413, ++count) {
- int v = value;
- xes[0] = repl[v % 36]; v /= 36;
- xes[1] = repl[v % 36]; v /= 36;
- xes[2] = repl[v % 36]; v /= 36;
- xes[3] = repl[v % 36]; v /= 36;
- xes[4] = repl[v % 36]; v /= 36;
- xes[5] = repl[v % 36];
- if (mkdir (tmpl, S_IRUSR | S_IWUSR | S_IXUSR) >= 0) {
- dirs_made++;
- return tmpl;
- } else if (errno != EEXIST) {
- return NULL;
- }
+ int count;
+ int value;
+ char *xes = &tmpl[strlen(tmpl) - 6];
+ /* this is not really all that random, but it will do */
+ if (dirs_made == 0) {
+ srand(time(NULL));
+ }
+ value = rand();
+ for (count = 0; count < MAXTRIES; value += 8413, ++count) {
+ int v = value;
+ xes[0] = repl[v % 36];
+ v /= 36;
+ xes[1] = repl[v % 36];
+ v /= 36;
+ xes[2] = repl[v % 36];
+ v /= 36;
+ xes[3] = repl[v % 36];
+ v /= 36;
+ xes[4] = repl[v % 36];
+ v /= 36;
+ xes[5] = repl[v % 36];
+ if (MKDIR(tmpl, S_IRUSR | S_IWUSR | S_IXUSR) >= 0) {
+ dirs_made++;
+ return tmpl;
+ } else if (errno != EEXIST) {
+ return NULL;
+ }
}
- return NULL;
+ return NULL;
}
-static int os_tmpdir (lua_State *L) {
- char *s, *tempdir;
- char *tmp = (char *)luaL_optstring(L, 1, "luatex.XXXXXX");
- if (tmp==NULL ||
- strlen(tmp)<6 ||
- (strcmp(tmp+strlen(tmp)-6,"XXXXXX") != 0)) {
- lua_pushnil(L);
- lua_pushstring(L, "Invalid argument to os.tmpdir()");
- return 2;
- } else {
- tempdir = xstrdup(tmp);
- }
+static int os_tmpdir(lua_State * L)
+{
+ char *s, *tempdir;
+ char *tmp = (char *) luaL_optstring(L, 1, "luatex.XXXXXX");
+ if (tmp == NULL ||
+ strlen(tmp) < 6 || (strcmp(tmp + strlen(tmp) - 6, "XXXXXX") != 0)) {
+ lua_pushnil(L);
+ lua_pushstring(L, "Invalid argument to os.tmpdir()");
+ return 2;
+ } else {
+ tempdir = xstrdup(tmp);
+ }
#ifdef HAVE_MKDTEMP
- s = mkdtemp(tempdir);
+ s = mkdtemp(tempdir);
#else
- s = do_mkdtemp(tempdir);
+ s = do_mkdtemp(tempdir);
#endif
- if (s==NULL) {
- int en = errno; /* calls to Lua API may change this value */
- lua_pushnil(L);
- lua_pushfstring(L, "%s", strerror(en));
- return 2;
- } else {
- lua_pushstring(L,s);
- return 1;
- }
+ if (s == NULL) {
+ int en = errno; /* calls to Lua API may change this value */
+ lua_pushnil(L);
+ lua_pushfstring(L, "%s", strerror(en));
+ return 2;
+ } else {
+ lua_pushstring(L, s);
+ return 1;
+ }
}
-void
-open_oslibext (lua_State *L, int safer_option) {
-
- find_env(L);
+void open_oslibext(lua_State * L, int safer_option)
+{
- lua_getglobal(L,"os");
- lua_pushcfunction(L, ex_sleep);
- lua_setfield(L,-2,"sleep");
- lua_getglobal(L,"os");
- lua_pushliteral(L, OS_PLATTYPE);
- lua_setfield(L,-2,"type");
- lua_getglobal(L,"os");
- lua_pushliteral(L, OS_PLATNAME);
- lua_setfield(L,-2,"name");
+ find_env(L);
+
+ lua_getglobal(L, "os");
+ lua_pushcfunction(L, ex_sleep);
+ lua_setfield(L, -2, "sleep");
+ lua_getglobal(L, "os");
+ lua_pushliteral(L, OS_PLATTYPE);
+ lua_setfield(L, -2, "type");
+ lua_getglobal(L, "os");
+ lua_pushliteral(L, OS_PLATNAME);
+ lua_setfield(L, -2, "name");
+ lua_getglobal(L, "os");
+ lua_pushcfunction(L, ex_uname);
+ lua_setfield(L, -2, "uname");
#if (! defined (WIN32)) && (! defined (__SUNOS__))
- lua_getglobal(L,"os");
- lua_pushcfunction(L, os_times);
- lua_setfield(L,-2,"times");
+ lua_getglobal(L, "os");
+ lua_pushcfunction(L, os_times);
+ lua_setfield(L, -2, "times");
#endif
#if ! defined (__SUNOS__)
- lua_getglobal(L,"os");
- lua_pushcfunction(L, os_gettimeofday);
- lua_setfield(L,-2,"gettimeofday");
+ lua_getglobal(L, "os");
+ lua_pushcfunction(L, os_gettimeofday);
+ lua_setfield(L, -2, "gettimeofday");
#endif
- if (!safer_option) {
- lua_getglobal(L,"os");
- lua_pushcfunction(L, os_setenv);
- lua_setfield(L,-2,"setenv");
- lua_getglobal(L,"os");
- lua_pushcfunction(L, os_exec);
- lua_setfield(L,-2,"exec");
- lua_getglobal(L,"os");
- lua_pushcfunction(L, os_spawn);
- lua_setfield(L,-2,"spawn");
- lua_getglobal(L,"os");
- lua_pushcfunction(L, os_tmpdir);
- lua_setfield(L,-2,"tmpdir");
-
- }
+ if (!safer_option) {
+ lua_getglobal(L, "os");
+ lua_pushcfunction(L, os_setenv);
+ lua_setfield(L, -2, "setenv");
+ lua_getglobal(L, "os");
+ lua_pushcfunction(L, os_exec);
+ lua_setfield(L, -2, "exec");
+ lua_getglobal(L, "os");
+ lua_pushcfunction(L, os_spawn);
+ lua_setfield(L, -2, "spawn");
+ lua_getglobal(L, "os");
+ lua_pushcfunction(L, os_tmpdir);
+ lua_setfield(L, -2, "tmpdir");
+
+ }
}
diff --git a/Build/source/texk/web2c/luatexdir/lua/lpdflib.c b/Build/source/texk/web2c/luatexdir/lua/lpdflib.c
index 393409b0729..6c1558e47a6 100644
--- a/Build/source/texk/web2c/luatexdir/lua/lpdflib.c
+++ b/Build/source/texk/web2c/luatexdir/lua/lpdflib.c
@@ -1,8 +1,27 @@
-/* $Id: lpdflib.c 1154 2008-04-13 22:36:03Z oneiros $ */
+/* lpdflib.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 General Public License as published by the Free
+ Software Foundation; either version 2 of the License, or (at your
+ option) any later version.
+
+ LuaTeX is distributed in the hope that it will be useful, but WITHOUT
+ ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
+ FITNESS FOR A PARTICULAR PURPOSE. See the GNU Lesser General Public
+ License for more details.
+
+ You should have received a copy of the GNU General Public License along
+ with LuaTeX; if not, see <http://www.gnu.org/licenses/>. */
#include "luatex-api.h"
#include <ptexlib.h>
+static const char _svn_version[] =
+ "$Id: lpdflib.c 2072 2009-03-21 08:50:20Z hhenkel $ $URL: http://scm.foundry.supelec.fr/svn/luatex/trunk/src/texk/web2c/luatexdir/lua/lpdflib.c $";
static int findcurv(lua_State * L)
{
@@ -20,7 +39,6 @@ static int findcurh(lua_State * L)
return 1;
}
-
typedef enum { set_origin, direct_page, direct_always } pdf_lit_mode;
int luapdfprint(lua_State * L)
@@ -57,13 +75,15 @@ int luapdfprint(lua_State * L)
lua_error(L);
}
}
+ check_pdfminorversion();
switch (literal_mode) {
case (set_origin):
- pdf_end_text();
- pdf_set_origin(cur_h, cur_v);
+ pdf_goto_pagemode();
+ pos = synch_p_with_c(cur);
+ pdf_set_pos(pos.h, pos.v);
break;
case (direct_page):
- pdf_end_text();
+ pdf_goto_pagemode();
break;
case (direct_always):
pdf_end_string_nl();
@@ -80,15 +100,25 @@ int luapdfprint(lua_State * L)
return 0;
}
+/* DANGER! this should go into some header file */
#define obj_type_others 0
static int l_immediateobj(lua_State * L)
{
+ unsigned i;
+ size_t len;
+ const char *st;
if (!lua_isstring(L, -1))
luaL_error(L, "pdf.immediateobj needs string value");
pdf_create_obj(obj_type_others, 0);
pdf_begin_obj(obj_ptr, 1);
- pdf_printf("%s\n", lua_tostring(L, -1));
+ st = lua_tolstring(L, -1, &len);
+ for (i = 0; i < len; i++) {
+ if (i % 16 == 0)
+ pdfroom(16);
+ pdf_buf[pdf_ptr++] = st[i];
+ }
+ pdf_puts("\n");
pdf_end_obj();
lua_pop(L, 1);
lua_pushinteger(L, obj_ptr);
diff --git a/Build/source/texk/web2c/luatexdir/lua/lstatslib.c b/Build/source/texk/web2c/luatexdir/lua/lstatslib.c
index 025e851e775..586ded0db4f 100644
--- a/Build/source/texk/web2c/luatexdir/lua/lstatslib.c
+++ b/Build/source/texk/web2c/luatexdir/lua/lstatslib.c
@@ -1,211 +1,248 @@
-/* $Id: lstatslib.c 1013 2008-02-14 00:09:02Z oneiros $ */
+/* lstatslib.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 General Public License as published by the Free
+ Software Foundation; either version 2 of the License, or (at your
+ option) any later version.
+
+ LuaTeX is distributed in the hope that it will be useful, but WITHOUT
+ ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
+ FITNESS FOR A PARTICULAR PURPOSE. See the GNU Lesser General Public
+ License for more details.
+
+ You should have received a copy of the GNU General Public License along
+ with LuaTeX; if not, see <http://www.gnu.org/licenses/>. */
#include "luatex-api.h"
#include <ptexlib.h>
+
+static const char _svn_version[] =
+ "$Id: lstatslib.c 2064 2009-03-20 13:13:14Z taco $ $URL: http://scm.foundry.supelec.fr/svn/luatex/trunk/src/texk/web2c/luatexdir/lua/lstatslib.c $";
+
typedef struct statistic {
- const char *name;
- char type;
- void *value;
-} statistic ;
+ const char *name;
+ char type;
+ void *value;
+} statistic;
extern char *ptexbanner;
-/* extern string getcurrentfilenamestring; */
+extern void lua_nodelib_push_fast(lua_State * L, halfword n);
-typedef char * (*charfunc)(void);
-typedef integer (*intfunc)(void);
+typedef char *(*charfunc) (void);
+typedef integer(*intfunc) (void);
-char *getbanner (void) {
- return ptexbanner;
+char *getbanner(void)
+{
+ return ptexbanner;
}
/* hack, I really should implement the makecstring */
-char *getfilename (void) {
- integer t;
- t = get_current_name();
- if (t>(1<<21))
- return makecstring(t);
- else
- return xstrdup ("");
+char *getfilename(void)
+{
+ integer t;
+ t = get_current_name();
+ if (t > (1 << 21))
+ return makecstring(t);
+ else
+ return xstrdup("");
}
-char *getlasterror (void) {
- return makecstring(last_error);
+char *getlasterror(void)
+{
+ return makecstring(last_error);
}
extern int luabytecode_max;
extern int luabytecode_bytes;
-extern int luastate_max;
+static int luastate_max = 1; /* fixed value */
extern int luastate_bytes;
+extern int callback_count;
+extern int saved_callback_count;
static struct statistic stats[] = {
- { "pdf_gone", 'g', &pdf_gone },
- { "pdf_ptr", 'g', &pdf_ptr },
- { "dvi_gone", 'g', &dvi_offset },
- { "dvi_ptr", 'g', &dvi_ptr },
- { "total_pages", 'g', &total_pages },
- { "output_file_name", 's', &output_file_name },
- { "log_name", 's', &texmf_log_name }, /* weird */
- { "banner", 'S', &getbanner },
- { "pdftex_banner", 's', &pdftex_banner },
- /*
- * mem stat
- */
- { "var_used", 'g', &var_used },
- { "dyn_used", 'g', &dyn_used },
- /*
- * traditional tex stats
- */
- { "str_ptr", 'g', &str_ptr },
- { "init_str_ptr", 'g', &init_str_ptr },
- { "max_strings", 'g', &max_strings },
- { "pool_ptr", 'g', &pool_ptr },
- { "init_pool_ptr", 'g', &init_pool_ptr },
- { "pool_size", 'g', &pool_size },
- { "var_mem_max", 'g', &var_mem_max },
- { "node_mem_usage", 'S', &sprint_node_mem_usage },
- { "fix_mem_max", 'g', &fix_mem_max },
- { "fix_mem_min", 'g', &fix_mem_min },
- { "fix_mem_end", 'g', &fix_mem_end },
- { "cs_count", 'g', &cs_count },
- { "hash_size", 'G', &get_hash_size },
- { "hash_extra", 'g', &hash_extra },
- { "font_ptr", 'G', &max_font_id },
- { "max_in_stack", 'g', &max_in_stack },
- { "max_nest_stack", 'g', &max_nest_stack },
- { "max_param_stack", 'g', &max_param_stack },
- { "max_buf_stack", 'g', &max_buf_stack },
- { "max_save_stack", 'g', &max_save_stack },
- { "stack_size", 'g', &stack_size },
- { "nest_size", 'g', &nest_size },
- { "param_size", 'g', &param_size },
- { "buf_size", 'g', &buf_size },
- { "save_size", 'g', &save_size },
- /* pdf stats */
- { "obj_ptr", 'g', &obj_ptr },
- { "obj_tab_size", 'g', &obj_tab_size },
- { "pdf_os_cntr", 'g', &pdf_os_cntr },
- { "pdf_os_objidx", 'g', &pdf_os_objidx },
- { "pdf_dest_names_ptr", 'g', &pdf_dest_names_ptr },
- { "dest_names_size", 'g', &dest_names_size },
- { "pdf_mem_ptr", 'g', &pdf_mem_ptr },
- { "pdf_mem_size", 'g', &pdf_mem_size },
-
- { "largest_used_mark", 'g', &biggest_used_mark },
-
- { "filename", 'S', &getfilename },
- { "inputid", 'G', &get_current_name },
- { "linenumber", 'g', &line },
- { "lasterrorstring", 'S', &getlasterror },
-
- { "luabytecodes", 'g', &luabytecode_max },
- { "luabytecode_bytes", 'g', &luabytecode_bytes },
- { "luastates", 'g', &luastate_max },
- { "luastate_bytes", 'g', &luastate_bytes },
-
- { "output_active", 'b', &output_active },
-
- { NULL, 0 , 0 } };
-
-
-static int stats_name_to_id (char *name) {
- int i;
- for (i=0; stats[i].name!=NULL; i++) {
- if (strcmp(stats[i].name, name) == 0)
- return i;
- }
- return 0;
+ {"pdf_gone", 'g', &pdf_gone},
+ {"pdf_ptr", 'g', &pdf_ptr},
+ {"dvi_gone", 'g', &dvi_offset},
+ {"dvi_ptr", 'g', &dvi_ptr},
+ {"total_pages", 'g', &total_pages},
+ {"output_file_name", 's', &output_file_name},
+ {"log_name", 's', &texmf_log_name}, /* weird */
+ {"banner", 'S', &getbanner},
+ {"pdftex_banner", 's', &pdftex_banner},
+ /*
+ * mem stat
+ */
+ {"var_used", 'g', &var_used},
+ {"dyn_used", 'g', &dyn_used},
+ /*
+ * traditional tex stats
+ */
+ {"str_ptr", 'g', &str_ptr},
+ {"init_str_ptr", 'g', &init_str_ptr},
+ {"max_strings", 'g', &max_strings},
+ {"pool_ptr", 'g', &pool_ptr},
+ {"init_pool_ptr", 'g', &init_pool_ptr},
+ {"pool_size", 'g', &pool_size},
+ {"var_mem_max", 'g', &var_mem_max},
+ {"node_mem_usage", 'S', &sprint_node_mem_usage},
+ {"fix_mem_max", 'g', &fix_mem_max},
+ {"fix_mem_min", 'g', &fix_mem_min},
+ {"fix_mem_end", 'g', &fix_mem_end},
+ {"cs_count", 'g', &cs_count},
+ {"hash_size", 'G', &get_hash_size},
+ {"hash_extra", 'g', &hash_extra},
+ {"font_ptr", 'G', &max_font_id},
+ {"max_in_stack", 'g', &max_in_stack},
+ {"max_nest_stack", 'g', &max_nest_stack},
+ {"max_param_stack", 'g', &max_param_stack},
+ {"max_buf_stack", 'g', &max_buf_stack},
+ {"max_save_stack", 'g', &max_save_stack},
+ {"stack_size", 'g', &stack_size},
+ {"nest_size", 'g', &nest_size},
+ {"param_size", 'g', &param_size},
+ {"buf_size", 'g', &buf_size},
+ {"save_size", 'g', &save_size},
+ /* pdf stats */
+ {"obj_ptr", 'g', &obj_ptr},
+ {"obj_tab_size", 'g', &obj_tab_size},
+ {"pdf_os_cntr", 'g', &pdf_os_cntr},
+ {"pdf_os_objidx", 'g', &pdf_os_objidx},
+ {"pdf_dest_names_ptr", 'g', &pdf_dest_names_ptr},
+ {"dest_names_size", 'g', &dest_names_size},
+ {"pdf_mem_ptr", 'g', &pdf_mem_ptr},
+ {"pdf_mem_size", 'g', &pdf_mem_size},
+
+ {"largest_used_mark", 'g', &biggest_used_mark},
+
+ {"filename", 'S', &getfilename},
+ {"inputid", 'G', &get_current_name},
+ {"linenumber", 'g', &line},
+ {"lasterrorstring", 'S', &getlasterror},
+
+ {"luabytecodes", 'g', &luabytecode_max},
+ {"luabytecode_bytes", 'g', &luabytecode_bytes},
+ {"luastates", 'g', &luastate_max},
+ {"luastate_bytes", 'g', &luastate_bytes},
+ {"callbacks", 'g', &callback_count},
+ {"indirect_callbacks", 'g', &saved_callback_count},
+
+ {"output_active", 'b', &output_active},
+ {"best_page_break", 'n', &best_page_break},
+ {NULL, 0, 0}
+};
+
+
+static int stats_name_to_id(char *name)
+{
+ int i;
+ for (i = 0; stats[i].name != NULL; i++) {
+ if (strcmp(stats[i].name, name) == 0)
+ return i;
+ }
+ return 0;
}
-static int do_getstat (lua_State *L,int i) {
- int t;
- char *st;
- charfunc f;
- intfunc g;
- int str;
- t = stats[i].type;
- switch(t) {
- case 'S':
- f = stats[i].value;
- st = f();
- lua_pushstring(L,st);
- break;
- case 's':
- str = *(integer *)(stats[i].value);
- if (str) {
- lua_pushstring(L,makecstring(str));
- } else {
- lua_pushnil(L);
- }
- break;
- case 'G':
- g = stats[i].value;
- lua_pushnumber(L,g());
- break;
- case 'g':
- lua_pushnumber(L,*(integer *)(stats[i].value));
- break;
- case 'B':
- g = stats[i].value;
- lua_pushboolean(L,g());
- break;
- case 'b':
- lua_pushboolean(L,*(integer *)(stats[i].value));
- break;
- default:
- lua_pushnil(L);
- }
- return 1;
+static int do_getstat(lua_State * L, int i)
+{
+ int t;
+ char *st;
+ charfunc f;
+ intfunc g;
+ int str;
+ t = stats[i].type;
+ switch (t) {
+ case 'S':
+ f = stats[i].value;
+ st = f();
+ lua_pushstring(L, st);
+ break;
+ case 's':
+ str = *(integer *) (stats[i].value);
+ if (str) {
+ lua_pushstring(L, makecstring(str));
+ } else {
+ lua_pushnil(L);
+ }
+ break;
+ case 'G':
+ g = stats[i].value;
+ lua_pushnumber(L, g());
+ break;
+ case 'g':
+ lua_pushnumber(L, *(integer *) (stats[i].value));
+ break;
+ case 'B':
+ g = stats[i].value;
+ lua_pushboolean(L, g());
+ break;
+ case 'n':
+ lua_nodelib_push_fast(L, *(halfword *) (stats[i].value));
+ break;
+ case 'b':
+ lua_pushboolean(L, *(integer *) (stats[i].value));
+ break;
+ default:
+ lua_pushnil(L);
+ }
+ return 1;
}
-static int getstats (lua_State *L) {
- char *st;
- int i;
- if (lua_isstring(L,-1)) {
- st = (char *)lua_tostring(L,-1);
- i = stats_name_to_id(st);
- if (i>0) {
- return do_getstat(L,i);
- }
- }
- return 0;
+static int getstats(lua_State * L)
+{
+ char *st;
+ int i;
+ if (lua_isstring(L, -1)) {
+ st = (char *) lua_tostring(L, -1);
+ i = stats_name_to_id(st);
+ if (i > 0) {
+ return do_getstat(L, i);
+ }
+ }
+ return 0;
}
-static int setstats (lua_State *L) {
- return 0;
+static int setstats(lua_State * L)
+{
+ return 0;
}
-static int statslist (lua_State *L) {
- int i;
- luaL_checkstack(L,1,"out of stack space");
- lua_newtable(L);
- for (i=0; stats[i].name!=NULL; i++) {
- luaL_checkstack(L,2,"out of stack space");
- lua_pushstring(L,stats[i].name);
- do_getstat(L,i);
- lua_rawset(L,-3);
- }
- return 1;
+static int statslist(lua_State * L)
+{
+ int i;
+ luaL_checkstack(L, 1, "out of stack space");
+ lua_newtable(L);
+ for (i = 0; stats[i].name != NULL; i++) {
+ luaL_checkstack(L, 2, "out of stack space");
+ lua_pushstring(L, stats[i].name);
+ do_getstat(L, i);
+ lua_rawset(L, -3);
+ }
+ return 1;
}
-static const struct luaL_reg statslib [] = {
- {"list",statslist},
- {NULL, NULL} /* sentinel */
+static const struct luaL_reg statslib[] = {
+ {"list", statslist},
+ {NULL, NULL} /* sentinel */
};
-int luaopen_stats (lua_State *L)
+int luaopen_stats(lua_State * L)
{
- luaL_register(L, "status", statslib);
- luaL_newmetatable(L,"stats_meta");
- lua_pushstring(L, "__index");
- lua_pushcfunction(L, getstats);
- lua_settable(L, -3);
- lua_pushstring(L, "__newindex");
- lua_pushcfunction(L, setstats);
- lua_settable(L, -3);
- lua_setmetatable(L,-2); /* meta to itself */
- return 1;
+ luaL_register(L, "status", statslib);
+ luaL_newmetatable(L, "stats_meta");
+ lua_pushstring(L, "__index");
+ lua_pushcfunction(L, getstats);
+ lua_settable(L, -3);
+ lua_pushstring(L, "__newindex");
+ lua_pushcfunction(L, setstats);
+ lua_settable(L, -3);
+ lua_setmetatable(L, -2); /* meta to itself */
+ return 1;
}
diff --git a/Build/source/texk/web2c/luatexdir/lua/ltexiolib.c b/Build/source/texk/web2c/luatexdir/lua/ltexiolib.c
index a61409b2943..c07d3cac696 100644
--- a/Build/source/texk/web2c/luatexdir/lua/ltexiolib.c
+++ b/Build/source/texk/web2c/luatexdir/lua/ltexiolib.c
@@ -1,117 +1,160 @@
-/* $Id: ltexiolib.c 1013 2008-02-14 00:09:02Z oneiros $ */
+/* ltexiolib.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 General Public License as published by the Free
+ Software Foundation; either version 2 of the License, or (at your
+ option) any later version.
+
+ LuaTeX is distributed in the hope that it will be useful, but WITHOUT
+ ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
+ FITNESS FOR A PARTICULAR PURPOSE. See the GNU Lesser General Public
+ License for more details.
+
+ You should have received a copy of the GNU General Public License along
+ with LuaTeX; if not, see <http://www.gnu.org/licenses/>. */
#include "luatex-api.h"
#include <ptexlib.h>
+static const char _svn_version[] =
+ "$Id: ltexiolib.c 2027 2009-03-14 18:47:32Z oneiros $ $URL: http://scm.foundry.supelec.fr/svn/luatex/trunk/src/texk/web2c/luatexdir/lua/ltexiolib.c $";
+
typedef void (*texio_printer) (strnumber s);
static char *loggable_info = NULL;
-static int
-do_texio_print (lua_State *L, texio_printer printfunction) {
- strnumber texs,u;
- char *s;
- char save_selector;
- int n,i;
- size_t k;
- u = 0;
- n = lua_gettop(L);
- if (n==0 || !lua_isstring(L, -1)) {
- lua_pushstring(L, "no string to print");
- lua_error(L);
- }
- save_selector = selector;
- i = 1;
- if (n>1) {
- s=(char *)lua_tostring(L, 1);
- if (strcmp(s,"log") == 0) { i++; selector = log_only; }
- else if (strcmp(s,"term") == 0) { i++; selector = term_only; }
- else if (strcmp(s,"term and log") == 0) { i++; selector = term_and_log; }
- }
- if (selector!=log_only && selector!=term_only && selector != term_and_log) {
- normalize_selector(); /* sets selector */
- }
- /* just in case there is a string in progress */
- if (str_start[str_ptr-0x200000]<pool_ptr)
- u=make_string();
- for (;i<=n;i++) {
- s = (char *)lua_tolstring(L, i, &k);
- texs = maketexlstring(s,k);
- printfunction(texs);
- flush_str(texs);
- }
- selector = save_selector;
- if (u!=0) str_ptr--;
- return 0;
+static boolean get_selector_value(lua_State * L, int i, char *l)
+{
+ boolean r = false;
+ if (lua_isstring(L, i)) {
+ char *s = (char *) lua_tostring(L, i);
+ if (strcmp(s, "log") == 0) {
+ *l = log_only;
+ r = true;
+ } else if (strcmp(s, "term") == 0) {
+ *l = term_only;
+ r = true;
+ } else if (strcmp(s, "term and log") == 0) {
+ *l = term_and_log;
+ r = true;
+ }
+ } else {
+ lua_pushstring(L, "first argument is not a string");
+ lua_error(L);
+ }
+ return r;
+}
+
+static int do_texio_print(lua_State * L, texio_printer printfunction)
+{
+ strnumber texs;
+ char *s;
+ size_t k;
+ int i = 1;
+ strnumber u = 0;
+ char save_selector = selector;
+ int n = lua_gettop(L);
+ if (n == 0 || !lua_isstring(L, -1)) {
+ lua_pushstring(L, "no string to print");
+ lua_error(L);
+ }
+ if (n > 1) {
+ if (get_selector_value(L, i, &selector))
+ i++;
+ }
+ if (selector != log_only && selector != term_only
+ && selector != term_and_log) {
+ normalize_selector(); /* sets selector */
+ }
+ /* just in case there is a string in progress */
+ if (str_start[str_ptr - 0x200000] < pool_ptr)
+ u = make_string();
+ for (; i <= n; i++) {
+ if (lua_isstring(L, i)) {
+ s = (char *) lua_tolstring(L, i, &k);
+ texs = maketexlstring(s, k);
+ printfunction(texs);
+ flush_str(texs);
+ } else {
+ lua_pushstring(L, "argument is not a string");
+ lua_error(L);
+ }
+ }
+ selector = save_selector;
+ if (u != 0)
+ str_ptr--;
+ return 0;
}
-static void
-do_texio_ini_print (lua_State *L, char *extra) {
- char *s;
- int i,n,l;
- n = lua_gettop(L);
- i = 1;
- l = 3;
- if (n>1) {
- s=(char *)lua_tostring(L, 1);
- if (strcmp(s,"log") == 0) { i++; l = 1; }
- else if (strcmp(s,"term") == 0) { i++; l = 2; }
- else if (strcmp(s,"term and log") == 0) { i++; l = 3; }
- }
- for (;i<=n;i++) {
- if(lua_isstring(L, i)) {
- s = (char *)lua_tostring(L, i);
- if (l==2||l==3)
- fprintf(stdout,"%s%s", extra, s);
- if (l==1||l==3) {
- if (loggable_info==NULL) {
- loggable_info = strdup(s);
- } else {
- char *v = concat3 (loggable_info,extra,s);
- free(loggable_info);
- loggable_info = v;
- }
- }
- }
- }
+static void do_texio_ini_print(lua_State * L, char *extra)
+{
+ char *s;
+ int i = 1;
+ char l = term_and_log;
+ int n = lua_gettop(L);
+ if (n > 1) {
+ if (get_selector_value(L, i, &l))
+ i++;
+ }
+ for (; i <= n; i++) {
+ if (lua_isstring(L, i)) {
+ s = (char *) lua_tostring(L, i);
+ if (l == term_and_log || l == term_only)
+ fprintf(stdout, "%s%s", extra, s);
+ if (l == log_only || l == term_and_log) {
+ if (loggable_info == NULL) {
+ loggable_info = strdup(s);
+ } else {
+ char *v = concat3(loggable_info, extra, s);
+ free(loggable_info);
+ loggable_info = v;
+ }
+ }
+ }
+ }
}
-static int
-texio_print (lua_State *L) {
- if (ready_already!=314159 || pool_ptr==0 || job_name==0) {
- do_texio_ini_print(L,"");
- return 0;
- }
- return do_texio_print(L,zprint);
+static int texio_print(lua_State * L)
+{
+ if (ready_already != 314159 || pool_ptr == 0 || job_name == 0) {
+ do_texio_ini_print(L, "");
+ return 0;
+ }
+ return do_texio_print(L, zprint);
}
-static int
-texio_printnl (lua_State *L) {
- if (ready_already!=314159 || pool_ptr==0 || job_name==0) {
- do_texio_ini_print(L,"\n");
- return 0;
- }
- return do_texio_print(L,zprint_nl);
+static int texio_printnl(lua_State * L)
+{
+ if (ready_already != 314159 || pool_ptr == 0 || job_name == 0) {
+ do_texio_ini_print(L, "\n");
+ return 0;
+ }
+ return do_texio_print(L, zprint_nl);
}
/* at the point this function is called, the selector is log_only */
-void flush_loggable_info (void) {
- if (loggable_info!=NULL) {
- fprintf(log_file,"%s\n",loggable_info);
- free(loggable_info);
- loggable_info=NULL;
- }
+void flush_loggable_info(void)
+{
+ if (loggable_info != NULL) {
+ fprintf(log_file, "%s\n", loggable_info);
+ free(loggable_info);
+ loggable_info = NULL;
+ }
}
-static const struct luaL_reg texiolib [] = {
- {"write", texio_print},
- {"write_nl", texio_printnl},
- {NULL, NULL} /* sentinel */
+static const struct luaL_reg texiolib[] = {
+ {"write", texio_print},
+ {"write_nl", texio_printnl},
+ {NULL, NULL} /* sentinel */
};
-int
-luaopen_texio (lua_State *L) {
- luaL_register(L,"texio",texiolib);
- return 1;
+int luaopen_texio(lua_State * L)
+{
+ luaL_register(L, "texio", texiolib);
+ return 1;
}
diff --git a/Build/source/texk/web2c/luatexdir/lua/ltexlib.c b/Build/source/texk/web2c/luatexdir/lua/ltexlib.c
index 937c802727a..a847d89f12e 100644
--- a/Build/source/texk/web2c/luatexdir/lua/ltexlib.c
+++ b/Build/source/texk/web2c/luatexdir/lua/ltexlib.c
@@ -1,191 +1,226 @@
-/* $Id: ltexlib.c 1168 2008-04-15 13:43:34Z taco $ */
+/* ltexlib.c
+
+ Copyright 2006-2009 Taco Hoekwater <taco@luatex.org>
+
+ This file is part of LuaTeX.
+
+ LuaTeX is free software; you can redistribute it and/or modify it under
+ the terms of the GNU General Public License as published by the Free
+ Software Foundation; either version 2 of the License, or (at your
+ option) any later version.
+
+ LuaTeX is distributed in the hope that it will be useful, but WITHOUT
+ ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
+ FITNESS FOR A PARTICULAR PURPOSE. See the GNU Lesser General Public
+ License for more details.
+
+ You should have received a copy of the GNU General Public License along
+ with LuaTeX; if not, see <http://www.gnu.org/licenses/>. */
#include "luatex-api.h"
#include <ptexlib.h>
#include "nodes.h"
+#include "commands.h"
+#include "tokens.h"
+
+static const char _svn_version[] =
+ "$Id: ltexlib.c 2079 2009-03-22 10:15:03Z taco $ $URL: http://scm.foundry.supelec.fr/svn/luatex/trunk/src/texk/web2c/luatexdir/lua/ltexlib.c $";
+
+extern halfword *check_isnode(lua_State * L, int ud);
+extern void lua_nodelib_push_fast(lua_State * L, halfword n);
typedef struct {
- char *text;
- unsigned int tsize;
- void *next;
- unsigned char partial;
- int cattable;
+ char *text;
+ unsigned int tsize;
+ void *next;
+ boolean partial;
+ integer cattable;
} rope;
typedef struct {
- rope *head;
- rope *tail;
- char complete; /* currently still writing ? */
+ rope *head;
+ rope *tail;
+ char complete; /* currently still writing ? */
} spindle;
#define PARTIAL_LINE 1
#define FULL_LINE 0
-#define NO_CAT_TABLE -2
-#define DEFAULT_CAT_TABLE -1
-
#define write_spindle spindles[spindle_index]
#define read_spindle spindles[(spindle_index-1)]
-static int spindle_size = 0;
-static spindle *spindles = NULL;
-static int spindle_index = 0;
-
-
-static int
-do_luacprint (lua_State * L, int partial, int deftable) {
- int i, n;
- size_t tsize;
- char *st, *sttemp;
- rope *rn;
- int cattable = deftable;
- int startstrings = 1;
- n = lua_gettop(L);
- if (cattable != NO_CAT_TABLE) {
- if (lua_type(L,1)==LUA_TNUMBER && n>1) {
- cattable = lua_tonumber(L, 1);
- startstrings = 2;
- }
- }
- for (i = startstrings; i <= n; i++) {
- if (!lua_isstring(L, i)) {
- lua_pushstring(L, "no string to print");
- lua_error(L);
- }
- sttemp = (char *)lua_tolstring(L, i,&tsize);
- st = xmalloc((tsize+1));
- memcpy(st,sttemp,(tsize+1));
+static int spindle_size = 0;
+static spindle *spindles = NULL;
+static int spindle_index = 0;
+
+static void
+luac_store (lua_State *L, int i, int partial, integer cattable)
+{
+ char *st, *sttemp;
+ size_t tsize;
+ rope *rn = NULL;
+ sttemp = (char *) lua_tolstring(L, i, &tsize);
+ st = xmalloc((tsize + 1));
+ memcpy(st, sttemp, (tsize + 1));
if (st) {
- /* fprintf(stderr,"W[%d]:=%s\n",spindle_index,st);*/
- luacstrings++;
- rn = (rope *)xmalloc(sizeof(rope)); /* valgrind says we leak here */
- rn->text = st;
- rn->tsize = tsize;
- rn->partial = partial;
- rn->cattable = cattable;
- rn->next = NULL;
- if (write_spindle.head == NULL) {
- assert(write_spindle.tail == NULL);
- write_spindle.head = rn;
- } else {
- write_spindle.tail->next = rn;
- }
- write_spindle.tail = rn;
- write_spindle.complete = 0;
+ luacstrings++;
+ rn = (rope *) xmalloc(sizeof(rope));
+ rn->text = st;
+ rn->tsize = tsize;
+ rn->partial = partial;
+ rn->cattable = cattable;
+ rn->next = NULL;
+ if (write_spindle.head == NULL) {
+ assert(write_spindle.tail == NULL);
+ write_spindle.head = rn;
+ } else {
+ write_spindle.tail->next = rn;
+ }
+ write_spindle.tail = rn;
+ write_spindle.complete = 0;
}
- }
- return 0;
}
-int luacwrite(lua_State * L) {
- return do_luacprint(L,FULL_LINE,NO_CAT_TABLE);
-}
-int luacprint(lua_State * L) {
- return do_luacprint(L,FULL_LINE,DEFAULT_CAT_TABLE);
+static int
+do_luacprint(lua_State * L, int partial, int deftable)
+{
+ int i, n;
+ integer cattable = (integer) deftable;
+ int startstrings = 1;
+ n = lua_gettop(L);
+ if (cattable != NO_CAT_TABLE) {
+ if (lua_type(L, 1) == LUA_TNUMBER && n > 1) {
+ cattable = lua_tonumber(L, 1);
+ startstrings = 2;
+ }
+ }
+ if (lua_type(L, startstrings) == LUA_TTABLE) {
+ for (i = 1; ; i++) {
+ lua_rawgeti(L,startstrings, i);
+ if (lua_isstring(L, -1)) {
+ luac_store(L, -1, partial, cattable);
+ lua_pop(L,1);
+ } else {
+ break;
+ }
+ }
+ } else {
+ for (i = startstrings; i <= n; i++) {
+ if (!lua_isstring(L, i)) {
+ lua_pushstring(L, "no string to print");
+ lua_error(L);
+ }
+ luac_store(L,i, partial, cattable);
+ }
+ }
+ return 0;
}
-int luacsprint(lua_State * L) {
- return do_luacprint(L,PARTIAL_LINE,DEFAULT_CAT_TABLE);
+int luacwrite(lua_State * L)
+{
+ return do_luacprint(L, FULL_LINE, NO_CAT_TABLE);
}
-int
-luacstring_detokenized (void) {
- return (read_spindle.tail->cattable == NO_CAT_TABLE);
+int luacprint(lua_State * L)
+{
+ return do_luacprint(L, FULL_LINE, DEFAULT_CAT_TABLE);
}
-int
-luacstring_defaultcattable (void) {
- return (read_spindle.tail->cattable == DEFAULT_CAT_TABLE);
+int luacsprint(lua_State * L)
+{
+ return do_luacprint(L, PARTIAL_LINE, DEFAULT_CAT_TABLE);
}
-integer
-luacstring_cattable (void) {
- return (integer)read_spindle.tail->cattable;
+integer luacstring_cattable(void)
+{
+ return (integer) read_spindle.tail->cattable;
}
-int
-luacstring_simple (void) {
- return (read_spindle.tail->partial == PARTIAL_LINE);
+int luacstring_partial(void)
+{
+ return read_spindle.tail->partial;
}
-int
-luacstring_penultimate (void) {
- return (read_spindle.tail->next == NULL);
+int luacstring_final_line(void)
+{
+ return (read_spindle.tail->next == NULL);
}
-int
-luacstring_input (void) {
- char *st;
- int ret;
- rope *t = read_spindle.head;
- if (!read_spindle.complete) {
- read_spindle.complete =1;
- read_spindle.tail = NULL;
- }
- if (t == NULL) {
- if(read_spindle.tail != NULL)
- free(read_spindle.tail);
- read_spindle.tail = NULL;
- return 0;
- }
- if (t->text != NULL) {
- st = t->text;
- /* put that thing in the buffer */
- last = first;
- ret = last;
- check_buffer_overflow (last + t->tsize);
- /* make sure it fits in the pool as well (for show_token_list c.s) */
- check_pool_overflow(pool_ptr + t->tsize);
- while (t->tsize-->0)
- buffer[last++] = *st++;
- if (!t->partial) {
- while (last-1>ret && buffer[last-1] == ' ')
- last--;
- }
- free (t->text);
- t->text = NULL;
- }
- if (read_spindle.tail != NULL) { /* not a one-liner */
- free(read_spindle.tail);
- }
- read_spindle.tail = t;
- read_spindle.head = t->next;
- return 1;
+int luacstring_input(void)
+{
+ char *st;
+ int ret;
+ rope *t = read_spindle.head;
+ if (!read_spindle.complete) {
+ read_spindle.complete = 1;
+ read_spindle.tail = NULL;
+ }
+ if (t == NULL) {
+ if (read_spindle.tail != NULL)
+ free(read_spindle.tail);
+ read_spindle.tail = NULL;
+ return 0;
+ }
+ if (t->text != NULL) {
+ st = t->text;
+ /* put that thing in the buffer */
+ last = first;
+ ret = last;
+ check_buffer_overflow(last + t->tsize);
+ /* make sure it fits in the pool as well (for show_token_list c.s) */
+ check_pool_overflow(pool_ptr + t->tsize);
+ while (t->tsize-- > 0)
+ buffer[last++] = *st++;
+ if (!t->partial) {
+ while (last - 1 > ret && buffer[last - 1] == ' ')
+ last--;
+ }
+ free(t->text);
+ t->text = NULL;
+ }
+ if (read_spindle.tail != NULL) { /* not a one-liner */
+ free(read_spindle.tail);
+ }
+ read_spindle.tail = t;
+ read_spindle.head = t->next;
+ return 1;
}
/* open for reading, and make a new one for writing */
-void
-luacstring_start (int n) {
- spindle_index++;
- if(spindle_size == spindle_index) { /* add a new one */
- spindles = xrealloc(spindles,sizeof(spindle)*(spindle_size+1));
- spindles[spindle_index].head = NULL;
- spindles[spindle_index].tail = NULL;
- spindles[spindle_index].complete = 0;
- spindle_size++;
- }
+void luacstring_start(int n)
+{
+ (void) n; /* for -W */
+ spindle_index++;
+ if (spindle_size == spindle_index) { /* add a new one */
+ spindles = xrealloc(spindles, sizeof(spindle) * (spindle_size + 1));
+ spindles[spindle_index].head = NULL;
+ spindles[spindle_index].tail = NULL;
+ spindles[spindle_index].complete = 0;
+ spindle_size++;
+ }
}
/* close for reading */
-void
-luacstring_close (int n) {
- rope *next, *t;
- next = read_spindle.head;
- while (next != NULL) {
- if (next->text != NULL)
- free(next->text);
- t = next;
- next = next->next;
- free(t);
- }
- read_spindle.head = NULL;
- if(read_spindle.tail != NULL)
- free(read_spindle.tail);
- read_spindle.tail = NULL;
- read_spindle.complete = 0;
- spindle_index--;
+void luacstring_close(int n)
+{
+ rope *next, *t;
+ (void) n; /* for -W */
+ next = read_spindle.head;
+ while (next != NULL) {
+ if (next->text != NULL)
+ free(next->text);
+ t = next;
+ next = next->next;
+ free(t);
+ }
+ read_spindle.head = NULL;
+ if (read_spindle.tail != NULL)
+ free(read_spindle.tail);
+ read_spindle.tail = NULL;
+ read_spindle.complete = 0;
+ spindle_index--;
}
/* local (static) versions */
@@ -196,653 +231,1210 @@ luacstring_close (int n) {
#define check_index_range(j) \
if (j > 65535) { \
- lua_pushstring(L, "incorrect index value"); \
- lua_error(L); }
-
-
-int dimen_to_number (lua_State *L,char *s){
- double v;
- char *d;
- int j;
- v = strtod(s,&d);
- if (strcmp (d,"in") == 0) { j = (int)(((v*7227)/100) *65536); }
- else if (strcmp (d,"pc") == 0) { j = (int)((v*12) *65536); }
- else if (strcmp (d,"cm") == 0) { j = (int)(((v*7227)/254) *65536); }
- else if (strcmp (d,"mm") == 0) { j = (int)(((v*7227)/2540) *65536); }
- else if (strcmp (d,"bp") == 0) { j = (int)(((v*7227)/7200) *65536); }
- else if (strcmp (d,"dd") == 0) { j = (int)(((v*1238)/1157) *65536); }
- else if (strcmp (d,"cc") == 0) { j = (int)(((v*14856)/1157) *65536); }
- else if (strcmp (d,"nd") == 0) { j = (int)(((v*21681)/20320)*65536); }
- else if (strcmp (d,"nc") == 0) { j = (int)(((v*65043)/5080) *65536); }
- else if (strcmp (d,"pt") == 0) { j = (int)(v *65536); }
- else if (strcmp (d,"sp") == 0) { j = (int)(v); }
- else {
- lua_pushstring(L, "unknown dimension specifier");
- lua_error(L);
- j = 0;
- }
- return j;
-}
-
-int setdimen (lua_State *L) {
- int i,j;
- size_t k;
- int cur_cs;
- int texstr;
- char *s;
- i = lua_gettop(L);
- j = 0;
- /* find the value*/
- if (!lua_isnumber(L,i))
- if (lua_isstring(L,i)) {
- j = dimen_to_number(L,(char *)lua_tostring(L,i));
+ lua_pushstring(L, "incorrect index value"); \
+ lua_error(L); }
+
+
+int dimen_to_number(lua_State * L, char *s)
+{
+ double v;
+ char *d;
+ int j;
+ v = strtod(s, &d);
+ if (strcmp(d, "in") == 0) {
+ j = (int) (((v * 7227) / 100) * 65536);
+ } else if (strcmp(d, "pc") == 0) {
+ j = (int) ((v * 12) * 65536);
+ } else if (strcmp(d, "cm") == 0) {
+ j = (int) (((v * 7227) / 254) * 65536);
+ } else if (strcmp(d, "mm") == 0) {
+ j = (int) (((v * 7227) / 2540) * 65536);
+ } else if (strcmp(d, "bp") == 0) {
+ j = (int) (((v * 7227) / 7200) * 65536);
+ } else if (strcmp(d, "dd") == 0) {
+ j = (int) (((v * 1238) / 1157) * 65536);
+ } else if (strcmp(d, "cc") == 0) {
+ j = (int) (((v * 14856) / 1157) * 65536);
+ } else if (strcmp(d, "nd") == 0) {
+ j = (int) (((v * 21681) / 20320) * 65536);
+ } else if (strcmp(d, "nc") == 0) {
+ j = (int) (((v * 65043) / 5080) * 65536);
+ } else if (strcmp(d, "pt") == 0) {
+ j = (int) (v * 65536);
+ } else if (strcmp(d, "sp") == 0) {
+ j = (int) (v);
} else {
- lua_pushstring(L, "unsupported value type");
- lua_error(L);
- }
- else
- j = (int)lua_tonumber(L,i);
- /* find the index*/
- if (lua_type(L,i-1)==LUA_TSTRING) {
- s = (char *)lua_tolstring(L,i-1, &k);
- texstr = maketexlstring(s,k);
- cur_cs = string_lookup(texstr);
- flush_str(texstr);
- k = zget_equiv(cur_cs)-get_scaled_base();
- } else {
- k = (int)luaL_checkinteger(L,i-1);
- }
- check_index_range(k);
- if(set_tex_dimen_register(k,j)) {
- lua_pushstring(L, "incorrect value");
- lua_error(L);
- }
- return 0;
-}
-
-int getdimen (lua_State *L) {
- int i,j;
- size_t k;
- int cur_cs;
- int texstr;
- char *s;
- i = lua_gettop(L);
- if (lua_type(L,i)==LUA_TSTRING) {
- s = (char *)lua_tolstring(L,i, &k);
- texstr = maketexlstring(s,k);
- cur_cs = string_lookup(texstr);
- flush_str(texstr);
- if (is_undefined_cs(cur_cs)) {
- lua_pushnil(L);
- return 1;
- }
- k = zget_equiv(cur_cs)-get_scaled_base();
- } else {
- k = (int)luaL_checkinteger(L,i);
- }
- check_index_range(k);
- j = get_tex_dimen_register(k);
- lua_pushnumber(L, j);
- return 1;
-}
-
-int setcount (lua_State *L) {
- int i,j;
- size_t k;
- int cur_cs;
- int texstr;
- char *s;
- i = lua_gettop(L);
- j = (int)luaL_checkinteger(L,i);
- if (lua_type(L,i-1)==LUA_TSTRING) {
- s = (char *)lua_tolstring(L,i-1,&k);
- texstr = maketexlstring(s,k);
- cur_cs = string_lookup(texstr);
- flush_str(texstr);
- k = zget_equiv(cur_cs)-get_count_base();
- } else {
- k = (int)luaL_checkinteger(L,i-1);
- }
- check_index_range(k);
- if (set_tex_count_register(k,j)) {
- lua_pushstring(L, "incorrect value");
- lua_error(L);
- }
- return 0;
-}
-
-int getcount (lua_State *L) {
- int i, j;
- size_t k;
- int cur_cs;
- int texstr;
- char *s;
- i = lua_gettop(L);
- if (lua_type(L,i)==LUA_TSTRING) {
- s = (char *)lua_tolstring(L,i, &k);
- texstr = maketexlstring(s,k);
- cur_cs = string_lookup(texstr);
- flush_str(texstr);
- if (is_undefined_cs(cur_cs)) {
- lua_pushnil(L);
- return 1;
- }
- k = zget_equiv(cur_cs)-get_count_base();
- } else {
- k = (int)luaL_checkinteger(L,i);
- }
- check_index_range(k);
- j = get_tex_count_register(k);
- lua_pushnumber(L, j);
- return 1;
-}
-
-
-int setattribute (lua_State *L) {
- int i,j;
- size_t k;
- int cur_cs;
- int texstr;
- char *s;
- i = lua_gettop(L);
- j = (int)luaL_checkinteger(L,i);
- if (lua_type(L,i-1)==LUA_TSTRING) {
- s = (char *)lua_tolstring(L,i-1, &k);
- texstr = maketexlstring(s,k);
- cur_cs = string_lookup(texstr);
- flush_str(texstr);
- k = zget_equiv(cur_cs)-get_attribute_base();
- } else {
- k = (int)luaL_checkinteger(L,i-1);
- }
- check_index_range(k);
- if (set_tex_attribute_register(k,j)) {
- lua_pushstring(L, "incorrect value");
- lua_error(L);
- }
- return 0;
-}
-
-int getattribute (lua_State *L) {
- int i, j;
- size_t k;
- int cur_cs;
- int texstr;
- char *s;
- i = lua_gettop(L);
- if (lua_type(L,i)==LUA_TSTRING) {
- s = (char *)lua_tolstring(L,i, &k);
- texstr = maketexlstring(s,k);
- cur_cs = string_lookup(texstr);
- flush_str(texstr);
- if (is_undefined_cs(cur_cs)) {
- lua_pushnil(L);
- return 1;
- }
- k = zget_equiv(cur_cs)-get_attribute_base();
- } else {
- k = (int)luaL_checkinteger(L,i);
- }
- check_index_range(k);
- j = get_tex_attribute_register(k);
- lua_pushnumber(L, j);
- return 1;
-}
-
-int settoks (lua_State *L) {
- int i,j;
- size_t k,len;
- int cur_cs;
- int texstr;
- char *s, *st;
- i = lua_gettop(L);
- if (!lua_isstring(L,i)) {
- lua_pushstring(L, "unsupported value type");
- lua_error(L);
- }
- st = (char *)lua_tolstring(L,i,&len);
-
- if (lua_type(L,i-1)==LUA_TSTRING) {
- s = (char *)lua_tolstring(L,i-1, &k);
- texstr = maketexlstring(s,k);
- cur_cs = string_lookup(texstr);
- flush_str(texstr);
- k = zget_equiv(cur_cs)-get_toks_base();
- } else {
- k = (int)luaL_checkinteger(L,i-1);
- }
- check_index_range(k);
- j = maketexlstring(st,len);
-
- if(zset_tex_toks_register(k,j)) {
- flush_str(j);
- lua_pushstring(L, "incorrect value");
- lua_error(L);
- }
- return 0;
-}
-
-int gettoks (lua_State *L) {
- int i;
- size_t k;
- strnumber t;
- int cur_cs;
- int texstr;
- char *s;
- i = lua_gettop(L);
- if (lua_type(L,i)==LUA_TSTRING) {
- s = (char *)lua_tolstring(L,i, &k);
- texstr = maketexlstring(s,k);
- cur_cs = string_lookup(texstr);
- flush_str(texstr);
- if (is_undefined_cs(cur_cs)) {
- lua_pushnil(L);
- return 1;
- }
- k = zget_equiv(cur_cs)-get_toks_base();
- } else {
- k = (int)luaL_checkinteger(L,i);
- }
-
- check_index_range(k);
- t = get_tex_toks_register(k);
- lua_pushstring(L, makecstring(t));
- flush_str(t);
- return 1;
-}
-
-/* UGLY hack */
-
-#define char_given 70
-#define math_given 71
-#define omath_given 72
-
-static int get_box_id (lua_State *L, int i) {
- const char *s;
- integer cur_cs, cur_cmd;
- str_number texstr;
- size_t k = 0;
- int j = -1;
- if (lua_type(L,i)==LUA_TSTRING) {
- s = (char *)lua_tolstring(L,i, &k);
- texstr = maketexlstring(s,k);
- cur_cs = string_lookup(texstr);
- cur_cmd = zget_eq_type(cur_cs);
- flush_str(texstr);
- if (cur_cmd==char_given ||
- cur_cmd==math_given ||
- cur_cmd==omath_given) {
- j = zget_equiv(cur_cs);
- }
- } else {
- j = (int)lua_tonumber(L,(i));
- }
- return j;
-}
-
-int getbox (lua_State *L) {
- int k, t;
- k = get_box_id(L,-1);
- check_index_range(k);
- t = get_tex_box_register(k);
- nodelist_to_lua(L,t);
- return 1;
-}
-
-int setbox (lua_State *L) {
- int i,j,k;
- k = get_box_id(L,-2);
- check_index_range(k);
- i = get_tex_box_register(k);
- if (lua_isboolean(L,-1)) {
- j = lua_toboolean(L,-1);
- if (j==0)
- j = null;
- else
- return 0;
- } else {
- j = nodelist_from_lua(L);
- }
- if(set_tex_box_register(k,j)) {
- lua_pushstring(L, "incorrect value");
- lua_error(L);
- }
- return 0;
-}
-
-static int getboxdim (lua_State *L, int whichdim) {
- int i, j;
- i = lua_gettop(L);
- j = get_box_id(L,i);
- lua_settop(L,(i-2)); /* table at -1 */
- if (j<0 || j > 65535) {
- lua_pushstring(L, "incorrect index");
- lua_error(L);
- }
- switch (whichdim) {
- case width_offset:
- lua_pushnumber(L, get_tex_box_width(j));
- break;
- case height_offset:
- lua_pushnumber(L, get_tex_box_height(j));
- break;
- case depth_offset:
- lua_pushnumber(L, get_tex_box_depth(j));
- }
- return 1;
-}
-
-int getboxwd (lua_State *L) {
- return getboxdim (L, width_offset);
-}
-
-int getboxht (lua_State *L) {
- return getboxdim (L, height_offset);
-}
-
-int getboxdp (lua_State *L) {
- return getboxdim (L, depth_offset);
-}
-
-static int setboxdim (lua_State *L, int whichdim) {
- int i,j,k,err;
- i = lua_gettop(L);
- if (!lua_isnumber(L,i)) {
- j = dimen_to_number(L,(char *)lua_tostring(L,i));
- } else {
- j = (int)lua_tonumber(L,i);
- }
- k = get_box_id(L,(i-1));
- lua_settop(L,(i-3)); /* table at -2 */
- if (k<0 || k > 65535) {
- lua_pushstring(L, "incorrect index");
- lua_error(L);
- }
- err = 0;
- switch (whichdim) {
- case width_offset:
- err = set_tex_box_width(k,j);
- break;
- case height_offset:
- err = set_tex_box_height(k,j);
- break;
- case depth_offset:
- err = set_tex_box_depth(k,j);
- }
- if (err) {
- lua_pushstring(L, "not a box");
- lua_error(L);
- }
- return 0;
-}
-
-int setboxwd (lua_State *L) {
- return setboxdim(L,width_offset);
-}
-
-int setboxht (lua_State *L) {
- return setboxdim(L,height_offset);
-}
-
-int setboxdp (lua_State *L) {
- return setboxdim(L,depth_offset);
-}
-
-int settex (lua_State *L) {
- char *st;
- int i,j,texstr;
- size_t k;
- int cur_cs, cur_cmd;
- j = 0;
- i = lua_gettop(L);
- if (lua_isstring(L,(i-1))) {
- st = (char *)lua_tolstring(L,(i-1), &k);
- texstr = maketexlstring(st,k);
- if (zis_primitive(texstr)) {
- cur_cs = string_lookup(texstr);
- flush_str(texstr);
- cur_cmd = zget_eq_type(cur_cs);
- if (is_int_assign(cur_cmd)) {
- if (lua_isnumber(L,i)) {
- assign_internal_int(zget_equiv(cur_cs),lua_tonumber(L,i));
- } else {
- lua_pushstring(L, "unsupported value type");
- lua_error(L);
- }
- } else if (is_dim_assign(cur_cmd)) {
- if (!lua_isnumber(L,i))
- if (lua_isstring(L,i)) {
- j = dimen_to_number(L,(char *)lua_tostring(L,i));
- } else {
- lua_pushstring(L, "unsupported value type");
- lua_error(L);
- }
- else
- j = (int)lua_tonumber(L,i);
- assign_internal_dim(zget_equiv(cur_cs),j);
- } else {
- lua_pushstring(L, "unsupported tex internal assignment");
- lua_error(L);
- }
+ lua_pushstring(L, "unknown dimension specifier");
+ lua_error(L);
+ j = 0;
+ }
+ return j;
+}
+
+int setdimen(lua_State * L)
+{
+ int i, j;
+ size_t k;
+ int cur_cs;
+ char *s;
+ i = lua_gettop(L);
+ j = 0;
+ /* find the value */
+ if (!lua_isnumber(L, i))
+ if (lua_isstring(L, i)) {
+ j = dimen_to_number(L, (char *) lua_tostring(L, i));
+ } else {
+ lua_pushstring(L, "unsupported value type");
+ lua_error(L);
+ } else
+ j = (int) lua_tonumber(L, i);
+ /* find the index */
+ if (lua_type(L, i - 1) == LUA_TSTRING) {
+ s = (char *) lua_tolstring(L, i - 1, &k);
+ cur_cs = string_lookup(s, k);
+ k = zget_equiv(cur_cs) - get_scaled_base();
+ } else {
+ k = (int) luaL_checkinteger(L, i - 1);
+ }
+ check_index_range(k);
+ if (set_tex_dimen_register(k, j)) {
+ lua_pushstring(L, "incorrect value");
+ lua_error(L);
+ }
+ return 0;
+}
+
+int getdimen(lua_State * L)
+{
+ int i, j;
+ size_t k;
+ int cur_cs;
+ char *s;
+ i = lua_gettop(L);
+ if (lua_type(L, i) == LUA_TSTRING) {
+ s = (char *) lua_tolstring(L, i, &k);
+ cur_cs = string_lookup(s, k);
+ if (is_undefined_cs(cur_cs)) {
+ lua_pushnil(L);
+ return 1;
+ }
+ k = zget_equiv(cur_cs) - get_scaled_base();
+ } else {
+ k = (int) luaL_checkinteger(L, i);
+ }
+ check_index_range(k);
+ j = get_tex_dimen_register(k);
+ lua_pushnumber(L, j);
+ return 1;
+}
+
+
+int setskip(lua_State * L)
+{
+ int i;
+ halfword *j;
+ size_t k;
+ int cur_cs;
+ char *s;
+ i = lua_gettop(L);
+ j = check_isnode(L, i); /* the value */
+
+ if (lua_type(L, i - 1) == LUA_TSTRING) {
+ s = (char *) lua_tolstring(L, i - 1, &k);
+ cur_cs = string_lookup(s, k);
+ k = zget_equiv(cur_cs) - get_scaled_base();
+ } else {
+ k = (int) luaL_checkinteger(L, i - 1);
+ }
+ check_index_range(k); /* the index */
+ if (set_tex_skip_register(k, *j)) {
+ lua_pushstring(L, "incorrect value");
+ lua_error(L);
+ }
+ return 0;
+}
+
+int getskip(lua_State * L)
+{
+ int i;
+ halfword j;
+ size_t k;
+ int cur_cs;
+ char *s;
+ i = lua_gettop(L);
+ if (lua_type(L, i) == LUA_TSTRING) {
+ s = (char *) lua_tolstring(L, i, &k);
+ cur_cs = string_lookup(s, k);
+ if (is_undefined_cs(cur_cs)) {
+ lua_pushnil(L);
+ return 1;
+ }
+ k = zget_equiv(cur_cs) - get_scaled_base();
+ } else {
+ k = (int) luaL_checkinteger(L, i);
+ }
+ check_index_range(k);
+ j = get_tex_skip_register(k);
+ lua_nodelib_push_fast(L, j);
+ return 1;
+}
+
+
+
+int setcount(lua_State * L)
+{
+ int i, j;
+ size_t k;
+ int cur_cs;
+ char *s;
+ i = lua_gettop(L);
+ j = (int) luaL_checkinteger(L, i);
+ if (lua_type(L, i - 1) == LUA_TSTRING) {
+ s = (char *) lua_tolstring(L, i - 1, &k);
+ cur_cs = string_lookup(s, k);
+ k = zget_equiv(cur_cs) - get_count_base();
+ } else {
+ k = (int) luaL_checkinteger(L, i - 1);
+ }
+ check_index_range(k);
+ if (set_tex_count_register(k, j)) {
+ lua_pushstring(L, "incorrect value");
+ lua_error(L);
+ }
+ return 0;
+}
+
+int getcount(lua_State * L)
+{
+ int i, j;
+ size_t k;
+ int cur_cs;
+ char *s;
+ i = lua_gettop(L);
+ if (lua_type(L, i) == LUA_TSTRING) {
+ s = (char *) lua_tolstring(L, i, &k);
+ cur_cs = string_lookup(s, k);
+ if (is_undefined_cs(cur_cs)) {
+ lua_pushnil(L);
+ return 1;
+ }
+ k = zget_equiv(cur_cs) - get_count_base();
+ } else {
+ k = (int) luaL_checkinteger(L, i);
+ }
+ check_index_range(k);
+ j = get_tex_count_register(k);
+ lua_pushnumber(L, j);
+ return 1;
+}
+
+
+int setattribute(lua_State * L)
+{
+ int i, j;
+ size_t k;
+ int cur_cs;
+ char *s;
+ i = lua_gettop(L);
+ j = (int) luaL_checkinteger(L, i);
+ if (lua_type(L, i - 1) == LUA_TSTRING) {
+ s = (char *) lua_tolstring(L, i - 1, &k);
+ cur_cs = string_lookup(s, k);
+ k = zget_equiv(cur_cs) - get_attribute_base();
+ } else {
+ k = (int) luaL_checkinteger(L, i - 1);
+ }
+ check_index_range(k);
+ if (set_tex_attribute_register(k, j)) {
+ lua_pushstring(L, "incorrect value");
+ lua_error(L);
+ }
+ return 0;
+}
+
+int getattribute(lua_State * L)
+{
+ int i, j;
+ size_t k;
+ int cur_cs;
+ char *s;
+ i = lua_gettop(L);
+ if (lua_type(L, i) == LUA_TSTRING) {
+ s = (char *) lua_tolstring(L, i, &k);
+ cur_cs = string_lookup(s, k);
+ if (is_undefined_cs(cur_cs)) {
+ lua_pushnil(L);
+ return 1;
+ }
+ k = zget_equiv(cur_cs) - get_attribute_base();
+ } else {
+ k = (int) luaL_checkinteger(L, i);
+ }
+ check_index_range(k);
+ j = get_tex_attribute_register(k);
+ lua_pushnumber(L, j);
+ return 1;
+}
+
+int settoks(lua_State * L)
+{
+ int i, j;
+ size_t k, len;
+ int cur_cs;
+ char *s, *st;
+ i = lua_gettop(L);
+ if (!lua_isstring(L, i)) {
+ lua_pushstring(L, "unsupported value type");
+ lua_error(L);
+ }
+ st = (char *) lua_tolstring(L, i, &len);
+
+ if (lua_type(L, i - 1) == LUA_TSTRING) {
+ s = (char *) lua_tolstring(L, i - 1, &k);
+ cur_cs = string_lookup(s, k);
+ k = zget_equiv(cur_cs) - get_toks_base();
+ } else {
+ k = (int) luaL_checkinteger(L, i - 1);
+ }
+ check_index_range(k);
+ j = maketexlstring(st, len);
+
+ if (zset_tex_toks_register(k, j)) {
+ flush_str(j);
+ lua_pushstring(L, "incorrect value");
+ lua_error(L);
+ }
+ return 0;
+}
+
+int gettoks(lua_State * L)
+{
+ int i;
+ size_t k;
+ strnumber t;
+ int cur_cs;
+ char *s;
+ i = lua_gettop(L);
+ if (lua_type(L, i) == LUA_TSTRING) {
+ s = (char *) lua_tolstring(L, i, &k);
+ cur_cs = string_lookup(s, k);
+ if (is_undefined_cs(cur_cs)) {
+ lua_pushnil(L);
+ return 1;
+ }
+ k = zget_equiv(cur_cs) - get_toks_base();
} else {
- lua_rawset(L,(i-2));
- }
- } else {
- lua_rawset(L,(i-2));
- }
- return 0;
-}
-
-char *
-get_something_internal (int cur_cmd, int cur_code) {
- int texstr;
- char *str;
- int save_cur_val,save_cur_val_level;
- save_cur_val = cur_val;
- save_cur_val_level = cur_val_level;
- zscan_something_simple(cur_cmd,cur_code);
- texstr = the_scanned_result();
- cur_val = save_cur_val;
- cur_val_level = save_cur_val_level;
- str = makecstring(texstr);
- flush_str(texstr);
- return str;
-}
-
-char *
-get_convert (int cur_code) {
- int texstr;
- char *str = NULL;
- texstr = the_convert_string(cur_code);
- if (texstr) {
+ k = (int) luaL_checkinteger(L, i);
+ }
+
+ check_index_range(k);
+ t = get_tex_toks_register(k);
+ lua_pushstring(L, makecstring(t));
+ flush_str(t);
+ return 1;
+}
+
+static int get_box_id(lua_State * L, int i)
+{
+ char *s;
+ integer cur_cs, cur_cmd;
+ size_t k = 0;
+ int j = -1;
+ if (lua_type(L, i) == LUA_TSTRING) {
+ s = (char *) lua_tolstring(L, i, &k);
+ cur_cs = string_lookup(s, k);
+ cur_cmd = zget_eq_type(cur_cs);
+ if (cur_cmd == char_given_cmd ||
+ cur_cmd == math_given_cmd || cur_cmd == omath_given_cmd) {
+ j = zget_equiv(cur_cs);
+ }
+ } else {
+ j = (int) lua_tonumber(L, (i));
+ }
+ return j;
+}
+
+int getbox(lua_State * L)
+{
+ int k, t;
+ k = get_box_id(L, -1);
+ check_index_range(k);
+ t = get_tex_box_register(k);
+ nodelist_to_lua(L, t);
+ return 1;
+}
+
+int setbox(lua_State * L)
+{
+ int i, j, k;
+ k = get_box_id(L, -2);
+ check_index_range(k);
+ i = get_tex_box_register(k);
+ if (lua_isboolean(L, -1)) {
+ j = lua_toboolean(L, -1);
+ if (j == 0)
+ j = null;
+ else
+ return 0;
+ } else {
+ j = nodelist_from_lua(L);
+ }
+ if (set_tex_box_register(k, j)) {
+ lua_pushstring(L, "incorrect value");
+ lua_error(L);
+ }
+ return 0;
+}
+
+static int getboxdim(lua_State * L, int whichdim)
+{
+ int i, j;
+ i = lua_gettop(L);
+ j = get_box_id(L, i);
+ lua_settop(L, (i - 2)); /* table at -1 */
+ if (j < 0 || j > 65535) {
+ lua_pushstring(L, "incorrect index");
+ lua_error(L);
+ }
+ switch (whichdim) {
+ case width_offset:
+ lua_pushnumber(L, get_tex_box_width(j));
+ break;
+ case height_offset:
+ lua_pushnumber(L, get_tex_box_height(j));
+ break;
+ case depth_offset:
+ lua_pushnumber(L, get_tex_box_depth(j));
+ }
+ return 1;
+}
+
+int getboxwd(lua_State * L)
+{
+ return getboxdim(L, width_offset);
+}
+
+int getboxht(lua_State * L)
+{
+ return getboxdim(L, height_offset);
+}
+
+int getboxdp(lua_State * L)
+{
+ return getboxdim(L, depth_offset);
+}
+
+static int setboxdim(lua_State * L, int whichdim)
+{
+ int i, j, k, err;
+ i = lua_gettop(L);
+ if (!lua_isnumber(L, i)) {
+ j = dimen_to_number(L, (char *) lua_tostring(L, i));
+ } else {
+ j = (int) lua_tonumber(L, i);
+ }
+ k = get_box_id(L, (i - 1));
+ lua_settop(L, (i - 3)); /* table at -2 */
+ if (k < 0 || k > 65535) {
+ lua_pushstring(L, "incorrect index");
+ lua_error(L);
+ }
+ err = 0;
+ switch (whichdim) {
+ case width_offset:
+ err = set_tex_box_width(k, j);
+ break;
+ case height_offset:
+ err = set_tex_box_height(k, j);
+ break;
+ case depth_offset:
+ err = set_tex_box_depth(k, j);
+ }
+ if (err) {
+ lua_pushstring(L, "not a box");
+ lua_error(L);
+ }
+ return 0;
+}
+
+int setboxwd(lua_State * L)
+{
+ return setboxdim(L, width_offset);
+}
+
+int setboxht(lua_State * L)
+{
+ return setboxdim(L, height_offset);
+}
+
+int setboxdp(lua_State * L)
+{
+ return setboxdim(L, depth_offset);
+}
+
+int settex(lua_State * L)
+{
+ char *st;
+ int i, j, texstr;
+ size_t k;
+ int cur_cs, cur_cmd;
+ j = 0;
+ i = lua_gettop(L);
+ if (lua_isstring(L, (i - 1))) {
+ st = (char *) lua_tolstring(L, (i - 1), &k);
+ texstr = maketexlstring(st, k);
+ if (is_primitive(texstr)) {
+ cur_cs = string_lookup(st, k);
+ flush_str(texstr);
+ cur_cmd = zget_eq_type(cur_cs);
+ if (is_int_assign(cur_cmd)) {
+ if (lua_isnumber(L, i)) {
+ assign_internal_value(0, zget_equiv(cur_cs),
+ lua_tonumber(L, i));
+ } else {
+ lua_pushstring(L, "unsupported value type");
+ lua_error(L);
+ }
+ } else if (is_dim_assign(cur_cmd)) {
+ if (!lua_isnumber(L, i))
+ if (lua_isstring(L, i)) {
+ j = dimen_to_number(L, (char *) lua_tostring(L, i));
+ } else {
+ lua_pushstring(L, "unsupported value type");
+ lua_error(L);
+ } else
+ j = (int) lua_tonumber(L, i);
+ assign_internal_value(0, zget_equiv(cur_cs), j);
+ } else {
+ lua_pushstring(L, "unsupported tex internal assignment");
+ lua_error(L);
+ }
+ } else {
+ lua_rawset(L, (i - 2));
+ }
+ } else {
+ lua_rawset(L, (i - 2));
+ }
+ return 0;
+}
+
+char *get_something_internal(int cur_cmd, int cur_code)
+{
+ int texstr;
+ char *str;
+ int save_cur_val, save_cur_val_level;
+ save_cur_val = cur_val;
+ save_cur_val_level = cur_val_level;
+ zscan_something_simple(cur_cmd, cur_code);
+ texstr = the_scanned_result();
+ cur_val = save_cur_val;
+ cur_val_level = save_cur_val_level;
str = makecstring(texstr);
flush_str(texstr);
- }
- return str;
-}
-
-
-int
-gettex (lua_State *L) {
- char *st;
- int i,texstr;
- size_t k;
- char *str;
- int cur_cs, cur_cmd, cur_code;
- i = lua_gettop(L);
- if (lua_isstring(L,i)) {
- st = (char *)lua_tolstring(L,i, &k);
- texstr = maketexlstring(st,k);
- cur_cs = zprim_lookup(texstr);
- flush_str(texstr);
- if (cur_cs) {
- cur_cmd = zget_prim_eq_type(cur_cs);
- cur_code = zget_prim_equiv(cur_cs);
- if (is_convert(cur_cmd))
- str = get_convert(cur_code);
- else
- str = get_something_internal(cur_cmd,cur_code);
- if (str)
- lua_pushstring(L,str);
- else
- lua_pushnil(L);
- return 1;
+ return str;
+}
+
+int do_convert(lua_State * L, int cur_code)
+{
+ int texstr;
+ integer i = -1;
+ char *str = NULL;
+ switch (cur_code) {
+ case convert_pdf_creation_date_code: /* ? */
+ case convert_pdf_insert_ht_code: /* arg <register int> */
+ case convert_pdf_ximage_bbox_code: /* arg 2 ints */
+ case convert_lua_code: /* arg complex */
+ case convert_lua_escape_string_code: /* arg token list */
+ case convert_pdf_colorstack_init_code: /* arg complex */
+ case convert_left_margin_kern_code: /* arg box */
+ case convert_right_margin_kern_code: /* arg box */
+ break;
+ case convert_string_code: /* arg token */
+ case convert_meaning_code: /* arg token */
+ break;
+
+ /* the next fall through, and come from 'official' indices! */
+ case convert_font_name_code: /* arg fontid */
+ case convert_font_identifier_code: /* arg fontid */
+ case convert_pdf_font_name_code: /* arg fontid */
+ case convert_pdf_font_objnum_code: /* arg fontid */
+ case convert_pdf_font_size_code: /* arg fontid */
+ case convert_uniform_deviate_code: /* arg int */
+ case convert_number_code: /* arg int */
+ case convert_roman_numeral_code: /* arg int */
+ case convert_pdf_page_ref_code: /* arg int */
+ case convert_pdf_xform_name_code: /* arg int */
+ if (lua_gettop(L) < 1) {
+ /* error */
+ }
+ i = lua_tonumber(L, 1); /* these fall through! */
+ default:
+ texstr = the_convert_string(cur_code, i);
+ if (texstr) {
+ str = makecstring(texstr);
+ flush_str(texstr);
+ }
+ }
+ if (str)
+ lua_pushstring(L, str);
+ else
+ lua_pushnil(L);
+ return 1;
+}
+
+
+int do_scan_internal(lua_State * L, int cur_cmd, int cur_code)
+{
+ int texstr;
+ char *str = NULL;
+ int save_cur_val, save_cur_val_level;
+ save_cur_val = cur_val;
+ save_cur_val_level = cur_val_level;
+ zscan_something_simple(cur_cmd, cur_code);
+
+ if (cur_val_level == int_val_level ||
+ cur_val_level == dimen_val_level || cur_val_level == attr_val_level) {
+ lua_pushnumber(L, cur_val);
+ } else if (cur_val_level == glue_val_level) {
+ lua_nodelib_push_fast(L, cur_val);
+ } else { /* dir_val_level, mu_val_level, tok_val_level */
+ texstr = the_scanned_result();
+ str = makecstring(texstr);
+ if (str)
+ lua_pushstring(L, str);
+ else
+ lua_pushnil(L);
+ flush_str(texstr);
+ }
+ cur_val = save_cur_val;
+ cur_val_level = save_cur_val_level;
+ return 1;
+}
+
+int do_lastitem(lua_State * L, int cur_code)
+{
+ int retval = 1;
+ switch (cur_code) {
+ /* the next two do not actually exist */
+ case last_item_lastattr_code:
+ case last_item_attrexpr_code:
+ lua_pushnil(L);
+ break;
+ /* the expressions do something complicated with arguments, yuck */
+ case last_item_numexpr_code:
+ case last_item_dimexpr_code:
+ case last_item_glueexpr_code:
+ case last_item_muexpr_code:
+ lua_pushnil(L);
+ break;
+ /* these read a glue or muglue, todo */
+ case last_item_mu_to_glue_code:
+ case last_item_glue_to_mu_code:
+ case last_item_glue_stretch_order_code:
+ case last_item_glue_shrink_order_code:
+ case last_item_glue_stretch_code:
+ case last_item_glue_shrink_code:
+ lua_pushnil(L);
+ break;
+ /* these read a fontid and a char, todo */
+ case last_item_font_char_wd_code:
+ case last_item_font_char_ht_code:
+ case last_item_font_char_dp_code:
+ case last_item_font_char_ic_code:
+ lua_pushnil(L);
+ break;
+ /* these read an integer, todo */
+ case last_item_par_shape_length_code:
+ case last_item_par_shape_indent_code:
+ case last_item_par_shape_dimen_code:
+ lua_pushnil(L);
+ break;
+ case last_item_lastpenalty_code:
+ case last_item_lastkern_code:
+ case last_item_lastskip_code:
+ case last_item_last_node_type_code:
+ case last_item_input_line_no_code:
+ case last_item_badness_code:
+ case last_item_pdftex_version_code:
+ case last_item_pdf_last_obj_code:
+ case last_item_pdf_last_xform_code:
+ case last_item_pdf_last_ximage_code:
+ case last_item_pdf_last_ximage_pages_code:
+ case last_item_pdf_last_annot_code:
+ case last_item_pdf_last_x_pos_code:
+ case last_item_pdf_last_y_pos_code:
+ case last_item_pdf_retval_code:
+ case last_item_pdf_last_ximage_colordepth_code:
+ case last_item_random_seed_code:
+ case last_item_pdf_last_link_code:
+ case last_item_luatex_version_code:
+ case last_item_Aleph_version_code:
+ case last_item_Omega_version_code:
+ case last_item_Aleph_minor_version_code:
+ case last_item_Omega_minor_version_code:
+ case last_item_eTeX_minor_version_code:
+ case last_item_eTeX_version_code:
+ case last_item_current_group_level_code:
+ case last_item_current_group_type_code:
+ case last_item_current_if_level_code:
+ case last_item_current_if_type_code:
+ case last_item_current_if_branch_code:
+ retval = do_scan_internal(L, last_item_cmd, cur_code);
+ break;
+ default:
+ lua_pushnil(L);
+ break;
+ }
+ return retval;
+}
+
+
+static int getfontname(lua_State * L)
+{
+ return do_convert(L, convert_font_name_code);
+}
+
+static int getfontidentifier(lua_State * L)
+{
+ return do_convert(L, convert_font_identifier_code);
+}
+
+static int getpdffontname(lua_State * L)
+{
+ return do_convert(L, convert_pdf_font_name_code);
+}
+
+static int getpdffontobjnum(lua_State * L)
+{
+ return do_convert(L, convert_pdf_font_objnum_code);
+}
+
+static int getpdffontsize(lua_State * L)
+{
+ return do_convert(L, convert_pdf_font_size_code);
+}
+
+static int getuniformdeviate(lua_State * L)
+{
+ return do_convert(L, convert_uniform_deviate_code);
+}
+
+static int getnumber(lua_State * L)
+{
+ return do_convert(L, convert_number_code);
+}
+
+static int getromannumeral(lua_State * L)
+{
+ return do_convert(L, convert_roman_numeral_code);
+}
+
+static int getpdfpageref(lua_State * L)
+{
+ return do_convert(L, convert_pdf_page_ref_code);
+}
+
+static int getpdfxformname(lua_State * L)
+{
+ return do_convert(L, convert_pdf_xform_name_code);
+}
+
+
+int get_parshape(lua_State * L)
+{
+ int n;
+ halfword par_shape_ptr = get_par_shape_ptr();
+ if (par_shape_ptr != 0) {
+ int m = 1;
+ n = vinfo(par_shape_ptr + 1);
+ lua_createtable(L, n, 0);
+ while (m <= n) {
+ lua_createtable(L, 2, 0);
+ lua_pushnumber(L, vlink((par_shape_ptr) + (2 * (m - 1)) + 2));
+ lua_rawseti(L, -2, 1);
+ lua_pushnumber(L, vlink((par_shape_ptr) + (2 * (m - 1)) + 3));
+ lua_rawseti(L, -2, 2);
+ lua_rawseti(L, -2, m);
+ m++;
+ }
} else {
- lua_rawget(L,(i-1));
- return 1;
- }
- } else {
- lua_rawget(L,(i-1));
+ lua_pushnil(L);
+ }
return 1;
- }
- return 0; /* not reached */
-}
-
-
-int
-getlist (lua_State *L) {
- char *str;
- if (lua_isstring(L,2)) {
- str = (char *)lua_tostring(L,2);
- if (strcmp(str,"page_ins_head")==0) {
- lua_pushnumber(L,page_ins_head); lua_nodelib_push(L);
- } else if (strcmp(str,"contrib_head")==0) {
- lua_pushnumber(L,contrib_head); lua_nodelib_push(L);
- } else if (strcmp(str,"page_head")==0) {
- lua_pushnumber(L,page_head); lua_nodelib_push(L);
- } else if (strcmp(str,"temp_head")==0) {
- lua_pushnumber(L,temp_head); lua_nodelib_push(L);
- } else if (strcmp(str,"hold_head")==0) {
- lua_pushnumber(L,hold_head); lua_nodelib_push(L);
- } else if (strcmp(str,"adjust_head")==0) {
- lua_pushnumber(L,adjust_head); lua_nodelib_push(L);
- } else if (strcmp(str,"pre_adjust_head")==0) {
- lua_pushnumber(L,pre_adjust_head); lua_nodelib_push(L);
- } else if (strcmp(str,"align_head")==0) {
- lua_pushnumber(L,align_head); lua_nodelib_push(L);
+}
+
+
+int gettex(lua_State * L)
+{
+ int cur_cs = -1;
+ int retval = 1; /* default is to return nil */
+
+ if (lua_isstring(L, 2)) { /* 1 == 'tex' */
+ int texstr;
+ size_t k;
+ char *st = (char *) lua_tolstring(L, 2, &k);
+ texstr = maketexlstring(st, k);
+ cur_cs = prim_lookup(texstr); /* not found == relax == 0 */
+ flush_str(texstr);
+ }
+ if (cur_cs > 0) {
+ int cur_cmd, cur_code;
+ cur_cmd = get_prim_eq_type(cur_cs);
+ cur_code = get_prim_equiv(cur_cs);
+ switch (cur_cmd) {
+ case last_item_cmd:
+ retval = do_lastitem(L, cur_code);
+ break;
+ case convert_cmd:
+ retval = do_convert(L, cur_code);
+ break;
+ case assign_toks_cmd:
+ case assign_int_cmd:
+ case assign_attr_cmd:
+ case assign_dir_cmd:
+ case assign_dimen_cmd:
+ case assign_glue_cmd:
+ case assign_mu_glue_cmd:
+ case set_aux_cmd:
+ case set_prev_graf_cmd:
+ case set_page_int_cmd:
+ case set_page_dimen_cmd:
+ case char_given_cmd:
+ case math_given_cmd:
+ case omath_given_cmd:
+ retval = do_scan_internal(L, cur_cmd, cur_code);
+ break;
+ case set_tex_shape_cmd:
+ retval = get_parshape(L);
+ break;
+ default:
+ lua_pushnil(L);
+ break;
+ }
} else {
- lua_pushnil(L);
+ lua_rawget(L, 1); /* fetch other index from table */
}
- } else {
- lua_pushnil(L);
- }
- return 1;
+ return retval;
}
-int
-setlist (lua_State *L) {
- assert(L);
- return 0;
+
+int getlist(lua_State * L)
+{
+ char *str;
+ if (lua_isstring(L, 2)) {
+ str = (char *) lua_tostring(L, 2);
+ if (strcmp(str, "page_ins_head") == 0) {
+ if (vlink(page_ins_head) == page_ins_head)
+ lua_pushnumber(L, null);
+ else
+ lua_pushnumber(L, vlink(page_ins_head));
+ lua_nodelib_push(L);
+ } else if (strcmp(str, "contrib_head") == 0) {
+ lua_pushnumber(L, vlink(contrib_head));
+ lua_nodelib_push(L);
+ } else if (strcmp(str, "page_head") == 0) {
+ lua_pushnumber(L, vlink(page_head));
+ lua_nodelib_push(L);
+ } else if (strcmp(str, "temp_head") == 0) {
+ lua_pushnumber(L, vlink(temp_head));
+ lua_nodelib_push(L);
+ } else if (strcmp(str, "hold_head") == 0) {
+ lua_pushnumber(L, vlink(hold_head));
+ lua_nodelib_push(L);
+ } else if (strcmp(str, "adjust_head") == 0) {
+ lua_pushnumber(L, vlink(adjust_head));
+ lua_nodelib_push(L);
+ } else if (strcmp(str, "best_page_break") == 0) {
+ lua_pushnumber(L, best_page_break);
+ lua_nodelib_push(L);
+ } else if (strcmp(str, "least_page_cost") == 0) {
+ lua_pushnumber(L, least_page_cost);
+ } else if (strcmp(str, "best_size") == 0) {
+ lua_pushnumber(L, best_size);
+ } else if (strcmp(str, "pre_adjust_head") == 0) {
+ lua_pushnumber(L, vlink(pre_adjust_head));
+ lua_nodelib_push(L);
+ } else if (strcmp(str, "align_head") == 0) {
+ lua_pushnumber(L, vlink(align_head));
+ lua_nodelib_push(L);
+ } else {
+ lua_pushnil(L);
+ }
+ } else {
+ lua_pushnil(L);
+ }
+ return 1;
+}
+
+int setlist(lua_State * L)
+{
+ halfword *n_ptr;
+ char *str;
+ halfword n = 0;
+ if (lua_isstring(L, 2)) {
+ str = (char *) lua_tostring(L, 2);
+ if (strcmp(str, "best_size") == 0) {
+ best_size = lua_tointeger(L, 3);
+ } else if (strcmp(str, "least_page_cost") == 0) {
+ least_page_cost = lua_tointeger(L, 3);
+ } else {
+ if (!lua_isnil(L, 3)) {
+ n_ptr = check_isnode(L, 3);
+ n = *n_ptr;
+ }
+ if (strcmp(str, "page_ins_head") == 0) {
+ if (n == 0) {
+ vlink(page_ins_head) = page_ins_head;
+ } else {
+ halfword m;
+ vlink(page_ins_head) = n;
+ m = tail_of_list(n);
+ vlink(m) = page_ins_head;
+ }
+ } else if (strcmp(str, "contrib_head") == 0) {
+ vlink(contrib_head) = n;
+ if (n == 0) {
+ if (nest_ptr == 0)
+ cur_list.tail_field = contrib_head; /* vertical mode */
+ else
+ nest[0].tail_field = contrib_head; /* other modes */
+ }
+ } else if (strcmp(str, "best_page_break") == 0) {
+ best_page_break = n;
+ } else if (strcmp(str, "page_head") == 0) {
+ vlink(page_head) = n;
+ page_tail = (n == 0 ? page_head : tail_of_list(n));
+ } else if (strcmp(str, "temp_head") == 0) {
+ vlink(temp_head) = n;
+ } else if (strcmp(str, "hold_head") == 0) {
+ vlink(hold_head) = n;
+ } else if (strcmp(str, "adjust_head") == 0) {
+ vlink(adjust_head) = n;
+ adjust_tail = (n == 0 ? adjust_head : tail_of_list(n));
+ } else if (strcmp(str, "pre_adjust_head") == 0) {
+ vlink(pre_adjust_head) = n;
+ pre_adjust_tail = (n == 0 ? pre_adjust_head : tail_of_list(n));
+ } else if (strcmp(str, "align_head") == 0) {
+ vlink(align_head) = n;
+ }
+ }
+ }
+ return 0;
}
#define infinity 2147483647
-static int
-do_integer_error(double m) {
- char *help[] = {"I can only go up to 2147483647='17777777777=""7FFFFFFF,",
- "so I'm using that number instead of yours.",
- NULL } ;
- tex_error("Number too big",help);
- return (m>0.0 ? infinity : -infinity);
+static int do_integer_error(double m)
+{
+ char *help[] = { "I can only go up to 2147483647='17777777777=" "7FFFFFFF,",
+ "so I'm using that number instead of yours.",
+ NULL
+ };
+ tex_error("Number too big", help);
+ return (m > 0.0 ? infinity : -infinity);
}
-static int
-tex_roundnumber (lua_State *L) {
- double m = lua_tonumber(L, 1)+0.5;
- if (abs(m)>(double)infinity)
- lua_pushnumber(L,do_integer_error(m));
- else
- lua_pushnumber(L,floor(m));
- return 1;
+static int tex_roundnumber(lua_State * L)
+{
+ double m = lua_tonumber(L, 1) + 0.5;
+ if (abs(m) > (double) infinity)
+ lua_pushnumber(L, do_integer_error(m));
+ else
+ lua_pushnumber(L, floor(m));
+ return 1;
}
-static int
-tex_scaletable (lua_State *L) {
- double delta = luaL_checknumber(L, 2);
- if (lua_istable(L,1)) {
- lua_newtable(L); /* the new table is at index 3 */
- lua_pushnil(L);
- while (lua_next(L,1)!= 0 ) { /* numeric value */
- lua_pushvalue(L,-2);
- lua_insert(L,-2);
- if (lua_isnumber(L,-1)) {
- double m = lua_tonumber(L,-1)*delta + 0.5;
- lua_pop(L,1);
- if (abs(m)>(double)infinity)
- lua_pushnumber(L,do_integer_error(m));
- else
- lua_pushnumber(L,floor(m));
- }
- lua_rawset(L,3);
- }
- } else if (lua_isnumber(L,1)) {
- double m = lua_tonumber(L,1)*delta + 0.5;
- if (abs(m)>(double)infinity)
- lua_pushnumber(L,do_integer_error(m));
- else
- lua_pushnumber(L,floor(m));
- } else {
- lua_pushnil(L);
- }
- return 1;
-}
-
-static const struct luaL_reg texlib [] = {
- {"write", luacwrite},
- {"print", luacprint},
- {"sprint", luacsprint},
- {"setdimen", setdimen},
- {"getdimen", getdimen},
- {"setattribute", setattribute},
- {"getattribute", getattribute},
- {"setcount", setcount},
- {"getcount", getcount},
- {"settoks", settoks},
- {"gettoks", gettoks},
- {"setbox", setbox},
- {"getbox", getbox},
- {"setlist", setlist},
- {"getlist", getlist},
- {"setboxwd", setboxwd},
- {"getboxwd", getboxwd},
- {"setboxht", setboxht},
- {"getboxht", getboxht},
- {"setboxdp", setboxdp},
- {"getboxdp", getboxdp},
- {"round", tex_roundnumber},
- {"scale", tex_scaletable},
- {NULL, NULL} /* sentinel */
-};
+static int tex_scaletable(lua_State * L)
+{
+ double delta = luaL_checknumber(L, 2);
+ if (lua_istable(L, 1)) {
+ lua_newtable(L); /* the new table is at index 3 */
+ lua_pushnil(L);
+ while (lua_next(L, 1) != 0) { /* numeric value */
+ lua_pushvalue(L, -2);
+ lua_insert(L, -2);
+ if (lua_isnumber(L, -1)) {
+ double m = lua_tonumber(L, -1) * delta + 0.5;
+ lua_pop(L, 1);
+ if (abs(m) > (double) infinity)
+ lua_pushnumber(L, do_integer_error(m));
+ else
+ lua_pushnumber(L, floor(m));
+ }
+ lua_rawset(L, 3);
+ }
+ } else if (lua_isnumber(L, 1)) {
+ double m = lua_tonumber(L, 1) * delta + 0.5;
+ if (abs(m) > (double) infinity)
+ lua_pushnumber(L, do_integer_error(m));
+ else
+ lua_pushnumber(L, floor(m));
+ } else {
+ lua_pushnil(L);
+ }
+ return 1;
+}
+
+#define hash_text(A) hash[(A)].rh
+
+static int tex_definefont(lua_State * L)
+{
+ char *csname;
+ int f, u;
+ str_number t;
+ size_t l;
+ int i = 1;
+ int a = 0;
+ if (!no_new_control_sequence) {
+ char *help[] =
+ { "You can't create a new font inside a \\csname\\endcsname pair",
+ NULL
+ };
+ tex_error("Definition active", help);
+ }
+ if ((lua_gettop(L) == 3) && lua_isboolean(L, 1)) {
+ a = lua_toboolean(L, 1);
+ i = 2;
+ }
+ csname = (char *) luaL_checklstring(L, i, &l);
+ f = luaL_checkinteger(L, (i + 1));
+ t = maketexlstring(csname, l);
+ no_new_control_sequence = 0;
+ u = string_lookup(csname, l);
+ no_new_control_sequence = 1;
+ if (a)
+ geq_define(u, set_font_cmd, f);
+ else
+ eq_define(u, set_font_cmd, f);
+ zeqtb[get_font_id_base() + f] = zeqtb[u];
+ hash_text(get_font_id_base() + f) = t;
+ return 0;
+}
+
+static int tex_hashpairs(lua_State * L)
+{
+ int cmd, chr;
+ str_number s = 0;
+ int cs = 1;
+ int eqtb_size = get_eqtb_size();
+ lua_newtable(L);
+ while (cs < eqtb_size) {
+ s = hash_text(cs);
+ if (s > 0) {
+ lua_pushstring(L, makecstring(s));
+ cmd = zget_eq_type(cs);
+ chr = zget_equiv(cs);
+ make_token_table(L, cmd, chr, cs);
+ lua_rawset(L, -3);
+ }
+ cs++;
+ }
+ return 1;
+}
+
+static int tex_primitives(lua_State * L)
+{
+ int cmd, chr;
+ str_number s = 0;
+ int cs = 0;
+ lua_newtable(L);
+ while (cs < prim_size) {
+ s = get_prim_text(cs);
+ if (s > 0) {
+ lua_pushstring(L, makecstring(s));
+ cmd = get_prim_eq_type(cs);
+ chr = get_prim_equiv(cs);
+ make_token_table(L, cmd, chr, 0);
+ lua_rawset(L, -3);
+ }
+ cs++;
+ }
+ return 1;
+}
-int luaopen_tex (lua_State *L)
-{
- luaL_register(L, "tex", texlib);
- make_table(L,"attribute","getattribute","setattribute");
- make_table(L,"dimen","getdimen","setdimen");
- make_table(L,"count","getcount","setcount");
- make_table(L,"toks","gettoks","settoks");
- make_table(L,"box","getbox","setbox");
- make_table(L,"lists","getlist","setlist");
- make_table(L,"wd","getboxwd","setboxwd");
- make_table(L,"ht","getboxht","setboxht");
- make_table(L,"dp","getboxdp","setboxdp");
- /* make the meta entries */
- /* fetch it back */
- luaL_newmetatable(L,"tex_meta");
- lua_pushstring(L, "__index");
- lua_pushcfunction(L, gettex);
- lua_settable(L, -3);
- lua_pushstring(L, "__newindex");
- lua_pushcfunction(L, settex);
- lua_settable(L, -3);
- lua_setmetatable(L,-2); /* meta to itself */
- /* initialize the I/O stack: */
- spindles = xmalloc(sizeof(spindle));
- spindle_index = 0;
- spindles[0].head = NULL;
- spindles[0].tail = NULL;
- spindle_size = 1;
- return 1;
+static int tex_extraprimitives(lua_State * L)
+{
+ int n, i;
+ int mask = 0;
+ str_number s = 0;
+ int cs = 0;
+ n = lua_gettop(L);
+ if (n == 0) {
+ mask = etex_command + aleph_command + omega_command +
+ pdftex_command + luatex_command;
+ } else {
+ for (i = 1; i <= n; i++) {
+ if (lua_isstring(L, i)) {
+ char *s = (char *) lua_tostring(L, i);
+ if (strcmp(s, "etex") == 0) {
+ mask |= etex_command;
+ } else if (strcmp(s, "tex") == 0) {
+ mask |= tex_command;
+ } else if (strcmp(s, "core") == 0) {
+ mask |= core_command;
+ } else if (strcmp(s, "pdftex") == 0) {
+ mask |= pdftex_command;
+ } else if (strcmp(s, "aleph") == 0) {
+ mask |= aleph_command;
+ } else if (strcmp(s, "omega") == 0) {
+ mask |= omega_command;
+ } else if (strcmp(s, "luatex") == 0) {
+ mask |= luatex_command;
+ }
+ }
+ }
+ }
+ lua_newtable(L);
+ i = 1;
+ while (cs < prim_size) {
+ s = get_prim_text(cs);
+ if (s > 0) {
+ if (get_prim_origin(cs) & mask) {
+ lua_pushstring(L, makecstring(s));
+ lua_rawseti(L, -2, i++);
+ }
+ }
+ cs++;
+ }
+ return 1;
+}
+
+static int tex_enableprimitives(lua_State * L)
+{
+ int n = lua_gettop(L);
+ if (n != 2) {
+ lua_pushstring(L, "wrong number of arguments");
+ lua_error(L);
+ } else {
+ size_t l;
+ int i;
+ char *pre = (char *) luaL_checklstring(L, 1, &l);
+ if (lua_istable(L,2)) {
+ int nncs = no_new_control_sequence;
+ no_new_control_sequence = true;
+ i = 1;
+ while (1) {
+ lua_rawgeti(L,2,i);
+ if (lua_isstring(L,3)) {
+ char *prim = (char *) lua_tostring(L,3);
+ str_number s = maketexstring(prim);
+ halfword prim_val = prim_lookup(s);
+ if (prim_val != undefined_primitive) {
+ char *newprim;
+ size_t newl;
+ halfword cur_cmd = get_prim_eq_type(prim_val);
+ halfword cur_chr = get_prim_equiv(prim_val);
+ if (strncmp(pre,prim,l)!=0) { /* not a prefix */
+ newl = strlen(prim)+l;
+ newprim = (char *) xmalloc (newl+1);
+ strcpy(newprim,pre);
+ strcat(newprim+l,prim);
+ } else {
+ newl = strlen(prim);
+ newprim = (char *) xmalloc (newl+1);
+ strcpy(newprim,prim);
+ }
+ if (string_lookup(newprim, newl) == static_undefined_control_sequence ) {
+ primitive_def(newprim, newl, cur_cmd, cur_chr);
+ }
+ free (newprim);
+ }
+ flush_str(s);
+ } else {
+ lua_pop(L,1);
+ break;
+ }
+ lua_pop(L,1);
+ i++;
+ }
+ lua_pop(L,1); /* the table */
+ no_new_control_sequence = nncs;
+ } else {
+ lua_pushstring(L, "Expected an array of names as second argument");
+ lua_error(L);
+ }
+ }
+ return 0;
}
+
+
+static const struct luaL_reg texlib[] = {
+ {"write", luacwrite},
+ {"print", luacprint},
+ {"sprint", luacsprint},
+ {"setdimen", setdimen},
+ {"getdimen", getdimen},
+ {"setskip", setskip},
+ {"getskip", getskip},
+ {"setattribute", setattribute},
+ {"getattribute", getattribute},
+ {"setcount", setcount},
+ {"getcount", getcount},
+ {"settoks", settoks},
+ {"gettoks", gettoks},
+ {"setbox", setbox},
+ {"getbox", getbox},
+ {"setlist", setlist},
+ {"getlist", getlist},
+ {"setboxwd", setboxwd},
+ {"getboxwd", getboxwd},
+ {"setboxht", setboxht},
+ {"getboxht", getboxht},
+ {"setboxdp", setboxdp},
+ {"getboxdp", getboxdp},
+ {"round", tex_roundnumber},
+ {"scale", tex_scaletable},
+ {"fontname", getfontname},
+ {"fontidentifier", getfontidentifier},
+ {"pdffontname", getpdffontname},
+ {"pdffontobjnum", getpdffontobjnum},
+ {"pdffontsize", getpdffontsize},
+ {"uniformdeviate", getuniformdeviate},
+ {"number", getnumber},
+ {"romannumeral", getromannumeral},
+ {"pdfpageref", getpdfpageref},
+ {"pdfxformname", getpdfxformname},
+ {"definefont", tex_definefont},
+ {"hashtokens", tex_hashpairs},
+ {"primitives", tex_primitives},
+ {"extraprimitives", tex_extraprimitives},
+ {"enableprimitives", tex_enableprimitives},
+ {NULL, NULL} /* sentinel */
+};
+
+int luaopen_tex(lua_State * L)
+{
+ luaL_register(L, "tex", texlib);
+ make_table(L, "attribute", "getattribute", "setattribute");
+ make_table(L, "skip", "getskip", "setskip");
+ make_table(L, "dimen", "getdimen", "setdimen");
+ make_table(L, "count", "getcount", "setcount");
+ make_table(L, "toks", "gettoks", "settoks");
+ make_table(L, "box", "getbox", "setbox");
+ make_table(L, "lists", "getlist", "setlist");
+ make_table(L, "wd", "getboxwd", "setboxwd");
+ make_table(L, "ht", "getboxht", "setboxht");
+ make_table(L, "dp", "getboxdp", "setboxdp");
+ /* make the meta entries */
+ /* fetch it back */
+ luaL_newmetatable(L, "tex_meta");
+ lua_pushstring(L, "__index");
+ lua_pushcfunction(L, gettex);
+ lua_settable(L, -3);
+ lua_pushstring(L, "__newindex");
+ lua_pushcfunction(L, settex);
+ lua_settable(L, -3);
+ lua_setmetatable(L, -2); /* meta to itself */
+ /* initialize the I/O stack: */
+ spindles = xmalloc(sizeof(spindle));
+ spindle_index = 0;
+ spindles[0].head = NULL;
+ spindles[0].tail = NULL;
+ spindle_size = 1;
+ /* a somewhat odd place for this assert, maybe */
+ assert(command_names[data_cmd].command_offset == data_cmd);
+ assert(param_int_pars == (get_count_base() - get_int_base()));
+ return 1;
+}
diff --git a/Build/source/texk/web2c/luatexdir/lua/ltokenlib.c b/Build/source/texk/web2c/luatexdir/lua/ltokenlib.c
index 582779623cf..b81c61f4023 100644
--- a/Build/source/texk/web2c/luatexdir/lua/ltokenlib.c
+++ b/Build/source/texk/web2c/luatexdir/lua/ltokenlib.c
@@ -1,263 +1,284 @@
-/* $Id: ltokenlib.c 1013 2008-02-14 00:09:02Z oneiros $ */
+/* ltokenlib.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 General Public License as published by the Free
+ Software Foundation; either version 2 of the License, or (at your
+ option) any later version.
+
+ LuaTeX is distributed in the hope that it will be useful, but WITHOUT
+ ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
+ FITNESS FOR A PARTICULAR PURPOSE. See the GNU Lesser General Public
+ License for more details.
+
+ You should have received a copy of the GNU General Public License along
+ with LuaTeX; if not, see <http://www.gnu.org/licenses/>. */
#include "luatex-api.h"
#include <ptexlib.h>
+#include "tokens.h"
+static const char _svn_version[] =
+ "$Id: ltokenlib.c 2015 2009-03-13 19:06:34Z taco $ $URL: http://scm.foundry.supelec.fr/svn/luatex/trunk/src/texk/web2c/luatexdir/lua/ltokenlib.c $";
-extern int get_command_id (char *);
+extern int get_command_id(char *);
static int max_command = 0;
-static int hash_base = 0;
-static int active_base = 0;
static int null_cs = 0;
#define protected_token 0x1C00001
#define is_valid_token(L,i) (lua_istable(L,i) && lua_objlen(L,i)==3)
-#define get_token_cmd(L,i) lua_rawgeti(L,i,1)
-#define get_token_chr(L,i) lua_rawgeti(L,i,2)
-#define get_token_cs(L,i) lua_rawgeti(L,i,3)
-
-static int
-test_expandable (lua_State *L) {
- integer cmd = -1;
- if (is_valid_token(L,-1)) {
- get_token_cmd(L,-1);
- if (lua_isnumber(L,-1)) {
- cmd = lua_tointeger(L,-1);
- } else if (lua_isstring(L,-1)) {
- cmd = get_command_id((char *)lua_tostring(L,-1));
- }
- if (cmd>max_command) {
- lua_pushboolean(L,1);
+#define get_token_cmd(L,i) lua_rawgeti(L,i,1)
+#define get_token_chr(L,i) lua_rawgeti(L,i,2)
+#define get_token_cs(L,i) lua_rawgeti(L,i,3)
+#define is_active_string(s) (strlen((char *)s)>3 && *s==0xEF && *(s+1)==0xBF && *(s+2)==0xBF)
+
+
+static int test_expandable(lua_State * L)
+{
+ integer cmd = -1;
+ if (is_valid_token(L, -1)) {
+ get_token_cmd(L, -1);
+ if (lua_isnumber(L, -1)) {
+ cmd = lua_tointeger(L, -1);
+ } else if (lua_isstring(L, -1)) {
+ cmd = get_command_id((char *) lua_tostring(L, -1));
+ }
+ if (cmd > max_command) {
+ lua_pushboolean(L, 1);
+ } else {
+ lua_pushboolean(L, 0);
+ }
} else {
- lua_pushboolean(L,0);
+ lua_pushnil(L);
}
- } else {
- lua_pushnil(L);
- }
- return 1;
+ return 1;
}
-static int
-test_protected (lua_State *L) {
- integer chr = -1;
- if (is_valid_token(L,-1)) {
- get_token_chr(L,-1);
- if (lua_isnumber(L,-1)) {
- chr = lua_tointeger(L,-1);
- } else if (lua_isstring(L,-1)) {
- chr = get_command_id((char *)lua_tostring(L,-1));
- }
- if (fixmem[fixmem[chr].hhrh].hhlh==protected_token) {
- lua_pushboolean(L,1);
+static int test_protected(lua_State * L)
+{
+ integer chr = -1;
+ if (is_valid_token(L, -1)) {
+ get_token_chr(L, -1);
+ if (lua_isnumber(L, -1)) {
+ chr = lua_tointeger(L, -1);
+ } else if (lua_isstring(L, -1)) {
+ chr = get_command_id((char *) lua_tostring(L, -1));
+ }
+ if (fixmem[fixmem[chr].hhrh].hhlh == protected_token) {
+ lua_pushboolean(L, 1);
+ } else {
+ lua_pushboolean(L, 0);
+ }
} else {
- lua_pushboolean(L,0);
+ lua_pushnil(L);
}
- } else {
- lua_pushnil(L);
- }
- return 1;
+ return 1;
}
-static int
-test_activechar (lua_State *L) {
- integer cmd = -1;
- if (is_valid_token(L,-1)) {
- get_token_chr(L,-1);
- if (lua_isnumber(L,-1)) {
- cmd = lua_tointeger(L,-1);
- }
- if (cmd>0 && cmd==protected_token) {
- lua_pushboolean(L,1);
- } else {
- lua_pushboolean(L,0);
+static int test_activechar(lua_State * L)
+{
+ if (is_valid_token(L, -1)) {
+ str_number n;
+ integer cs = 0;
+ get_token_cs(L, -1);
+ if (lua_isnumber(L, -1)) {
+ cs = lua_tointeger(L, -1);
+ }
+ lua_pop(L, 1);
+ if (cs != 0 && (n = zget_cs_text(cs)) && n > 0) {
+ unsigned char *s = (unsigned char *) makecstring(n);
+ if (is_active_string(s)) {
+ free(s);
+ lua_pushboolean(L, 1);
+ return 1;
+ }
+ free(s);
+ }
}
- } else {
- lua_pushnil(L);
- }
- return 1;
+ lua_pushboolean(L, 0);
+ return 1;
}
-static int
-run_get_command_name (lua_State *L) {
- int cs;
- if (is_valid_token(L,-1)) {
- get_token_cmd(L,-1);
- if (lua_isnumber(L,-1)) {
- cs = lua_tointeger(L,-1);
- lua_pushstring(L,command_names[cs].cmd_name);
+static int run_get_command_name(lua_State * L)
+{
+ int cs;
+ if (is_valid_token(L, -1)) {
+ get_token_cmd(L, -1);
+ if (lua_isnumber(L, -1)) {
+ cs = lua_tointeger(L, -1);
+ lua_pushstring(L, command_names[cs].cmd_name);
+ } else {
+ lua_pushstring(L, "");
+ }
} else {
- lua_pushstring(L,"");
+ lua_pushnil(L);
}
- } else {
- lua_pushnil(L);
- }
- return 1;
+ return 1;
}
-static int
-run_get_csname_name (lua_State *L) {
- int cs,cmd,n;
- char *s;
-
- if (is_valid_token(L,-1)) {
- get_token_cmd(L,-1);
- if (lua_isnumber(L,-1)) {
- cmd = lua_tointeger(L,-1);
- }
- lua_pop(L,1);
- cs = 0;
- get_token_cs(L,-1);
- if (lua_isnumber(L,-1)) {
- cs = lua_tointeger(L,-1);
- }
- lua_pop(L,1);
-
- if (cs != 0 && (n = zget_cs_text(cs)) && n>=0) {
- s = makecstring(n);
- lua_pushstring(L,s);
- } else {
- lua_pushstring(L,"");
- }
- } else {
- lua_pushnil(L);
- }
- return 1;
+
+static int run_get_csname_name(lua_State * L)
+{
+ int cs, cmd, n;
+
+ if (is_valid_token(L, -1)) {
+ get_token_cmd(L, -1);
+ if (lua_isnumber(L, -1)) {
+ cmd = lua_tointeger(L, -1);
+ }
+ lua_pop(L, 1);
+ cs = 0;
+ get_token_cs(L, -1);
+ if (lua_isnumber(L, -1)) {
+ cs = lua_tointeger(L, -1);
+ }
+ lua_pop(L, 1);
+
+ if (cs != 0 && (n = zget_cs_text(cs)) && n >= 0) {
+ unsigned char *s = (unsigned char *) makecstring(n);
+ if (is_active_string(s))
+ lua_pushstring(L, (char *) (s + 3));
+ else
+ lua_pushstring(L, (char *) s);
+ } else {
+ lua_pushstring(L, "");
+ }
+ } else {
+ lua_pushnil(L);
+ }
+ return 1;
}
-static int
-run_get_command_id (lua_State *L) {
- int cs = -1;
- if (lua_isstring(L,-1)) {
- cs = get_command_id((char *)lua_tostring(L,-1));
- }
- lua_pushnumber(L,cs);
- return 1;
+static int run_get_command_id(lua_State * L)
+{
+ int cs = -1;
+ if (lua_isstring(L, -1)) {
+ cs = get_command_id((char *) lua_tostring(L, -1));
+ }
+ lua_pushnumber(L, cs);
+ return 1;
}
-static int
-run_get_csname_id (lua_State *L) {
- int texstr;
- char *s;
- size_t k,cs = 0;
- if (lua_isstring(L,-1)) {
- s = (char *)lua_tolstring(L,-1, &k);
- texstr = maketexlstring(s,k);
- cs = string_lookup(texstr);
- flush_str(texstr);
- }
- lua_pushnumber(L,cs);
- return 1;
+static int run_get_csname_id(lua_State * L)
+{
+ char *s;
+ size_t k, cs = 0;
+ if (lua_isstring(L, -1)) {
+ s = (char *) lua_tolstring(L, -1, &k);
+ cs = string_lookup(s, k);
+ }
+ lua_pushnumber(L, cs);
+ return 1;
}
-void
-make_token_table (lua_State *L, int cmd, int chr, int cs) {
- lua_createtable(L,3,0);
- lua_pushnumber(L,cmd);
- lua_rawseti(L,-2,1);
- lua_pushnumber(L,chr);
- lua_rawseti(L,-2,2);
- lua_pushnumber(L,cs);
- lua_rawseti(L,-2,3);
+void make_token_table(lua_State * L, int cmd, int chr, int cs)
+{
+ lua_createtable(L, 3, 0);
+ lua_pushnumber(L, cmd);
+ lua_rawseti(L, -2, 1);
+ lua_pushnumber(L, chr);
+ lua_rawseti(L, -2, 2);
+ lua_pushnumber(L, cs);
+ lua_rawseti(L, -2, 3);
}
-static int
-run_get_next (lua_State *L) {
- int save_nncs;
- save_nncs = no_new_control_sequence;
- no_new_control_sequence = 0;
- get_next();
- no_new_control_sequence = save_nncs;
- make_token_table(L,cur_cmd,cur_chr,cur_cs);
- return 1;
+static int run_get_next(lua_State * L)
+{
+ int save_nncs;
+ save_nncs = no_new_control_sequence;
+ no_new_control_sequence = 0;
+ get_next();
+ no_new_control_sequence = save_nncs;
+ make_token_table(L, cur_cmd, cur_chr, cur_cs);
+ return 1;
}
-static int
-run_expand (lua_State *L) {
- expand();
- return 0;
+static int run_expand(lua_State * L)
+{
+ expand();
+ return 0;
}
-static int
-run_lookup (lua_State *L) {
- char *s;
- size_t l;
- str_number t;
- integer cs,cmd,chr;
- int save_nncs;
- if (lua_isstring(L,-1)) {
- s = (char *)lua_tolstring(L,-1,&l);
- if (l>0) {
- save_nncs = no_new_control_sequence;
- no_new_control_sequence = true;
- cs = id_lookup((last+1),l); /* cleans up the lookup buffer */
- t = maketexlstring(s,l);
- cs = string_lookup(t);
- flush_str(t);
- cmd = zget_eq_type(cs);
- chr = zget_equiv(cs);
- make_token_table(L,cmd,chr,cs);
- no_new_control_sequence = save_nncs;
- return 1;
+static int run_lookup(lua_State * L)
+{
+ char *s;
+ size_t l;
+ integer cs, cmd, chr;
+ int save_nncs;
+ if (lua_isstring(L, -1)) {
+ s = (char *) lua_tolstring(L, -1, &l);
+ if (l > 0) {
+ save_nncs = no_new_control_sequence;
+ no_new_control_sequence = true;
+ cs = id_lookup((last + 1), l); /* cleans up the lookup buffer */
+ cs = string_lookup(s, l);
+ cmd = zget_eq_type(cs);
+ chr = zget_equiv(cs);
+ make_token_table(L, cmd, chr, cs);
+ no_new_control_sequence = save_nncs;
+ return 1;
+ }
}
- }
- lua_newtable(L);
- return 1;
+ lua_newtable(L);
+ return 1;
}
-static int
-run_build (lua_State *L) {
- integer cmd,chr,cs;
- if (lua_isnumber(L,1)) {
- cs =0;
- chr = lua_tointeger(L,1);
- cmd = luaL_optinteger(L,2,zget_char_cat_code(chr));
- if (cmd==0 || cmd == 9 || cmd == 14 || cmd == 15) {
- fprintf(stdout, "\n\nluatex error: not a good token.\nCatcode %i can not be returned, so I replaced it by 12 (other)",(int)cmd);
- error();
- cmd=12;
- }
- if (cmd == 13) {
- cs=chr+active_base;
- cmd=zget_eq_type(cs);
- chr=zget_equiv(cs);
+static int run_build(lua_State * L)
+{
+ integer cmd, chr, cs;
+ if (lua_isnumber(L, 1)) {
+ cs = 0;
+ chr = lua_tointeger(L, 1);
+ cmd = luaL_optinteger(L, 2, get_char_cat_code(chr));
+ if (cmd == 0 || cmd == 9 || cmd == 14 || cmd == 15) {
+ fprintf(stdout,
+ "\n\nluatex error: not a good token.\nCatcode %i can not be returned, so I replaced it by 12 (other)",
+ (int) cmd);
+ error();
+ cmd = 12;
+ }
+ if (cmd == 13) {
+ cs = active_to_cs(chr, false);
+ cmd = zget_eq_type(cs);
+ chr = zget_equiv(cs);
+ }
+ make_token_table(L, cmd, chr, cs);
+ return 1;
+ } else {
+ return run_lookup(L);
}
- make_token_table(L,cmd,chr,cs);
- return 1;
- } else {
- return run_lookup(L);
- }
}
-static const struct luaL_reg tokenlib [] = {
- {"get_next", run_get_next},
- {"expand", run_expand},
- {"lookup", run_lookup},
- {"create", run_build},
- {"is_expandable",test_expandable},
- {"is_activechar",test_activechar},
- {"is_protected", test_protected},
- {"csname_id", run_get_csname_id},
- {"csname_name", run_get_csname_name},
- {"command_name", run_get_command_name},
- {"command_id", run_get_command_id},
- {NULL, NULL} /* sentinel */
+static const struct luaL_reg tokenlib[] = {
+ {"get_next", run_get_next},
+ {"expand", run_expand},
+ {"lookup", run_lookup},
+ {"create", run_build},
+ {"is_expandable", test_expandable},
+ {"is_activechar", test_activechar},
+ {"is_protected", test_protected},
+ {"csname_id", run_get_csname_id},
+ {"csname_name", run_get_csname_name},
+ {"command_name", run_get_command_name},
+ {"command_id", run_get_command_id},
+ {NULL, NULL} /* sentinel */
};
-int luaopen_token (lua_State *L)
+int luaopen_token(lua_State * L)
{
- luaL_register(L, "token", tokenlib);
- max_command = get_max_command();
- hash_base = get_hash_base();
- active_base = get_active_base();
- null_cs = get_nullcs();
- return 1;
+ luaL_register(L, "token", tokenlib);
+ max_command = get_max_command();
+ null_cs = get_nullcs();
+ return 1;
}
-
diff --git a/Build/source/texk/web2c/luatexdir/lua/luainit.c b/Build/source/texk/web2c/luatexdir/lua/luainit.c
index 3aa5dfc35b5..f89607530ac 100644
--- a/Build/source/texk/web2c/luatexdir/lua/luainit.c
+++ b/Build/source/texk/web2c/luatexdir/lua/luainit.c
@@ -1,3 +1,22 @@
+/* luainit.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 General Public License as published by the Free
+ Software Foundation; either version 2 of the License, or (at your
+ option) any later version.
+
+ LuaTeX is distributed in the hope that it will be useful, but WITHOUT
+ ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
+ FITNESS FOR A PARTICULAR PURPOSE. See the GNU Lesser General Public
+ License for more details.
+
+ You should have received a copy of the GNU General Public License along
+ with LuaTeX; if not, see <http://www.gnu.org/licenses/>. */
+
#include <sys/stat.h>
#include "luatex-api.h"
@@ -5,21 +24,37 @@
#include <luatexdir/luatexextra.h>
-#ifndef program_invocation_name
-/* char *program_invocation_name = NULL; */
-#endif
-
-extern void parse_src_specials_option (char *n) ;
+static const char _svn_version[] =
+ "$Id: luainit.c 2064 2009-03-20 13:13:14Z taco $ $URL: http://scm.foundry.supelec.fr/svn/luatex/trunk/src/texk/web2c/luatexdir/lua/luainit.c $";
+
+/* TH: TODO
+ *
+ * This file is getting a bit messy, but it is not simple to fix unilaterally.
+ *
+ * Better to wait until Karl has some time (after texlive 2008) so we can
+ * synchronize with kpathsea. One problem, for instance, is that I would
+ * like to resolve the full executable path. kpse_set_program_name() does
+ * that, indirectly (by setting SELFAUTOLOC in the environment), but it
+ * does much more, making it hard to use for our purpose.
+ *
+ * In fact, it sets three C variables:
+ * program_invocation_name program_invocation_short_name kpse->program_name
+ * and four environment variables:
+ * SELFAUTOLOC SELFAUTODIR SELFAUTOPARENT progname
+ *
+ */
+
+extern string normalize_quotes(const_string name, const_string mesg);
const_string LUATEX_IHELP[] = {
"Usage: luatex --lua=FILE [OPTION]... [TEXNAME[.tex]] [COMMANDS]",
" or: luatex --lua=FILE [OPTION]... \\FIRST-LINE",
" or: luatex --lua=FILE [OPTION]... &FMT ARGS",
- " Run luaTeX on TEXNAME, usually creating TEXNAME.pdf.",
+ " Run LuaTeX on TEXNAME, usually creating TEXNAME.pdf.",
" Any remaining COMMANDS are processed as luatex input, after TEXNAME is read.",
"",
" Alternatively, if the first non-option argument begins with a backslash,",
- " interpret all non-option arguments as a line of luatex input.",
+ " luatex interprets all non-option arguments as an input line.",
"",
" Alternatively, if the first non-option argument begins with a &, the",
" next word is taken as the FMT to read, overriding all else. Any",
@@ -28,7 +63,8 @@ const_string LUATEX_IHELP[] = {
" If no arguments or options are specified, prompt for input.",
"",
" --lua=FILE the lua initialization file",
- " --safer disable some easily exploitable lua commands",
+ " --nosocket disable the luasocket (network) library",
+ " --safer disable easily exploitable lua commands",
" --fmt=FORMAT load the format file FORMAT",
" --ini be initex, for dumping formats",
" --help display this help and exit",
@@ -41,23 +77,50 @@ const_string LUATEX_IHELP[] = {
NULL
};
+char *ex_selfdir(char *argv0)
+{
+#if defined(WIN32)
+ char short_path[PATH_MAX], path[PATH_MAX], *fp;
+
+ /* SearchPath() always gives back an absolute directory */
+ if (SearchPath(NULL, argv0, ".exe", PATH_MAX, short_path, &fp) == 0)
+ FATAL1("Can't determine where the executable %s is.\n", argv0);
+ if (!win32_get_long_filename(short_path, path, sizeof(path))) {
+ FATAL1("This path points to an invalid file : %s\n", short_path);
+ }
+ /* slashify the dirname */
+ for (fp = path; fp && *fp; fp++)
+ if (IS_DIR_SEP(*fp))
+ *fp = DIR_SEP;
+ /* sdir will be the directory of the executable, ie: c:/TeX/bin */
+ return xdirname(path);
+#else
+ return kpse_selfdir(argv0);
+#endif
+}
+
static void
prepare_cmdline(lua_State * L, char **argv, int argc, int zero_offset)
{
int i;
+ char *s;
luaL_checkstack(L, argc + 3, "too many arguments to script");
lua_createtable(L, 0, 0);
for (i = 0; i < argc; i++) {
- lua_pushstring(L, argv[i]);
- lua_rawseti(L, -2, (i-zero_offset));
+ lua_pushstring(L, argv[i]);
+ lua_rawseti(L, -2, (i - zero_offset));
}
lua_setglobal(L, "arg");
+ lua_getglobal(L, "os");
+ s = ex_selfdir(argv[0]);
+ lua_pushstring(L, s);
+ xfree(s);
+ lua_setfield(L, -2, "selfdir");
return;
}
extern string dump_name;
extern const_string c_job_name;
-extern boolean srcspecialsoption;
extern char *last_source_name;
extern int last_lineno;
@@ -66,7 +129,7 @@ string input_name = NULL;
static string user_progname = NULL;
extern char *ptexbanner;
-extern int program_name_set; /* in lkpselib.c */
+extern int program_name_set; /* in lkpselib.c */
/* for topenin() */
extern char **argv;
@@ -77,6 +140,7 @@ int lua_only = 0;
int lua_offset = 0;
int safer_option = 0;
+int nosocket_option = 0;
/* Reading the options. */
@@ -87,444 +151,448 @@ int safer_option = 0;
/* SunOS cc can't initialize automatic structs, so make this static. */
static struct option long_options[]
- = { { "fmt", 1, 0, 0},
- { "lua", 1, 0, 0},
- { "luaonly", 0, 0, 0},
- { "safer", 0, &safer_option, 1},
- { "help", 0, 0, 0 },
- { "ini", 0, &ini_version, 1 },
- { "interaction", 1, 0, 0 },
- { "halt-on-error", 0, &haltonerrorp, 1 },
- { "kpathsea-debug", 1, 0, 0 },
- { "progname", 1, 0, 0 },
- { "version", 0, 0, 0 },
- { "recorder", 0, &recorder_enabled, 1 },
- { "etex", 0, 0, 0 },
- { "output-comment", 1, 0, 0 },
- { "output-directory", 1, 0, 0 },
- { "draftmode", 0, 0, 0 },
- { "output-format", 1, 0, 0 },
- { "shell-escape", 0, &shellenabledp, 1 },
- { "no-shell-escape", 0, &shellenabledp, -1 },
- { "enable-write18", 0, &shellenabledp, 1 },
- { "disable-write18", 0, &shellenabledp, -1 },
- { "shell-restricted", 0, 0, 0 },
- { "debug-format", 0, &debug_format_file, 1 },
- { "src-specials", 2, 0, 0 },
- { "file-line-error-style", 0, &filelineerrorstylep, 1 },
- { "no-file-line-error-style", 0, &filelineerrorstylep, -1 },
+= { {"fmt", 1, 0, 0},
+{"lua", 1, 0, 0},
+{"luaonly", 0, 0, 0},
+{"safer", 0, &safer_option, 1},
+{"nosocket", 0, &nosocket_option, 1},
+{"help", 0, 0, 0},
+{"ini", 0, &ini_version, 1},
+{"interaction", 1, 0, 0},
+{"halt-on-error", 0, &haltonerrorp, 1},
+{"kpathsea-debug", 1, 0, 0},
+{"progname", 1, 0, 0},
+{"version", 0, 0, 0},
+{"credits", 0, 0, 0},
+{"recorder", 0, &recorder_enabled, 1},
+{"etex", 0, 0, 0},
+{"output-comment", 1, 0, 0},
+{"output-directory", 1, 0, 0},
+{"draftmode", 0, 0, 0},
+{"output-format", 1, 0, 0},
+{"shell-escape", 0, &shellenabledp, 1},
+{"no-shell-escape", 0, &shellenabledp, -1},
+{"debug-format", 0, &debug_format_file, 1},
+{"file-line-error-style", 0, &filelineerrorstylep, 1},
+{"no-file-line-error-style", 0, &filelineerrorstylep, -1},
/* Shorter option names for the above. */
- { "file-line-error", 0, &filelineerrorstylep, 1 },
- { "no-file-line-error", 0, &filelineerrorstylep, -1 },
- { "jobname", 1, 0, 0 },
- { "parse-first-line", 0, &parsefirstlinep, 1 },
- { "no-parse-first-line", 0, &parsefirstlinep, -1 },
- { "translate-file", 1, 0, 0 },
- { "default-translate-file", 1, 0, 0 },
- { "8bit", 0, 0, 0 },
- { "mktex", 1, 0, 0 },
- { "no-mktex", 1, 0, 0 },
+{"file-line-error", 0, &filelineerrorstylep, 1},
+{"no-file-line-error", 0, &filelineerrorstylep, -1},
+{"jobname", 1, 0, 0},
+{"parse-first-line", 0, &parsefirstlinep, 1},
+{"no-parse-first-line", 0, &parsefirstlinep, -1},
+{"translate-file", 1, 0, 0},
+{"default-translate-file", 1, 0, 0},
+{"8bit", 0, 0, 0},
+{"mktex", 1, 0, 0},
+{"no-mktex", 1, 0, 0},
+/* Synchronization: just like "interaction" above */
+{"synctex", 1, 0, 0},
{0, 0, 0, 0}
};
-static void
-parse_options(int argc, char **argv)
+static void parse_options(int argc, char **argv)
{
- int g; /* `getopt' return code. */
- int option_index;
- char *firstfile = NULL;
- opterr = 0; /* dont whine */
- for (;;) {
- g = getopt_long_only(argc, argv, "+", long_options, &option_index);
-
- if (g == -1) /* End of arguments, exit the loop. */
- break;
- if (g == '?') /* Unknown option. */
- continue;
-
- assert(g == 0); /* We have no short option names. */
-
- if (ARGUMENT_IS("luaonly")) {
- lua_only = 1;
- lua_offset = optind;
- luainit = 1 ;
- } else if (ARGUMENT_IS("lua")) {
- startup_filename = optarg;
- lua_offset = (optind-1);
- luainit = 1 ;
-
- } else if (ARGUMENT_IS ("kpathsea-debug")) {
- kpathsea_debug |= atoi (optarg);
-
- } else if (ARGUMENT_IS("progname")) {
- user_progname = optarg;
-
- } else if (ARGUMENT_IS ("jobname")) {
- c_job_name = optarg;
-
- } else if (ARGUMENT_IS("fmt")) {
- dump_name = optarg;
-
- } else if (ARGUMENT_IS ("output-directory")) {
- output_directory = optarg;
-
- } else if (ARGUMENT_IS ("output-comment")) {
- unsigned len = strlen (optarg);
- if (len < 256) {
- output_comment = optarg;
- } else {
- WARNING2 ("Comment truncated to 255 characters from %d. (%s)",
- len, optarg);
- output_comment = (string)xmalloc (256);
- strncpy (output_comment, optarg, 255);
- output_comment[255] = 0;
- }
-
- } else if (ARGUMENT_IS ("src-specials")) {
- last_source_name = xstrdup("");
- /* Option `--src" without any value means `auto' mode. */
- if (optarg == NULL) {
- insertsrcspecialeverypar = true;
- insertsrcspecialauto = true;
- srcspecialsoption = true;
- srcspecialsp = true;
- } else {
- parse_src_specials_option(optarg);
- }
-
- } else if (ARGUMENT_IS ("output-format")) {
- pdf_output_option = 1;
- if (strcmp(optarg, "dvi") == 0) {
- pdf_output_value = 0;
- } else if (strcmp(optarg, "pdf") == 0) {
- pdf_output_value = 2;
- } else {
- WARNING1 ("Ignoring unknown value `%s' for --output-format", optarg);
- pdf_output_option = 0;
- }
-
- } else if (ARGUMENT_IS ("draftmode")) {
- pdf_draftmode_option = 1;
- pdf_draftmode_value = 1;
-
- } else if (ARGUMENT_IS ("mktex")) {
- kpse_maketex_option (optarg, true);
-
- } else if (ARGUMENT_IS ("no-mktex")) {
- kpse_maketex_option (optarg, false);
-
- } else if (ARGUMENT_IS ("interaction")) {
- /* These numbers match @d's in *.ch */
- if (STREQ (optarg, "batchmode")) {
- interactionoption = 0;
- } else if (STREQ (optarg, "nonstopmode")) {
- interactionoption = 1;
- } else if (STREQ (optarg, "scrollmode")) {
- interactionoption = 2;
- } else if (STREQ (optarg, "errorstopmode")) {
- interactionoption = 3;
- } else {
- WARNING1 ("Ignoring unknown argument `%s' to --interaction", optarg);
- }
-
- } else if (ARGUMENT_IS("help")) {
- usagehelp(LUATEX_IHELP, BUG_ADDRESS);
-
- } else if (ARGUMENT_IS("version")) {
- char *versions;
- initversionstring(&versions);
- print_version_banner();
-
- puts(
-"\n\nLuaTeX merges and builds upon (parts of) the code from these projects:\n\n"
-"tex by Donald Knuth\n"
-"etex by Peter Breitenlohner, Phil Taylor and friends\n"
-"omega by John Plaice and Yannis Haralambous\n"
-"aleph by Giuseppe Bilotta\n"
-"pdftex by Han The Thanh and friends\n"
-"kpathsea by Karl Berry, Olaf Weber and others\n"
-"lua by Roberto Ierusalimschy, Waldemar Celes,\n"
-" Luiz Henrique de Figueiredo\n"
-"metapost by John Hobby, Taco Hoekwater and friends.\n"
-"xpdf by Derek Noonberg (partial)\n"
-"fontforge by George Williams (partial)\n\n"
-"Some extensions to lua and additional lua libraries are used, as well as\n"
-"libraries for graphic inclusion. More details can be found in the source.\n"
-"Code development was sponsored by a grant from Colorado State University\n"
-"via the 'oriental tex' project, the TeX User Groups, and donations.\n\n"
-"The LuaTeX team is Hans Hagen, Hartmut Henkel, Taco Hoekwater.\n\n"
-"There is NO warranty. Redistribution of this software is covered by\n"
-"the terms of the GNU General Public License, version 2. For more\n"
-"information about these matters, see the file named COPYING and\n"
-"the LuaTeX source.\n\n"
-"Copyright 2008 Taco Hoekwater, the LuaTeX Team.\n");
-
- puts(versions);
- uexit(0);
- }
- }
- /* attempt to find dump_name */
- if (argv[optind] && argv[optind][0] == '&') {
- dump_name = strdup(argv[optind] + 1);
- } else if (argv[optind] && argv[optind][0] != '\\') {
- if (argv[optind][0] == '*') {
- input_name = strdup(argv[optind] + 1);
- } else {
- firstfile = strdup(argv[optind]);
- if (lua_only) {
- startup_filename = firstfile;
- } else {
- if ((strstr(firstfile,".lua") == firstfile+strlen(firstfile)-4) ||
- (strstr(firstfile,".luc") == firstfile+strlen(firstfile)-4) ||
- (strstr(firstfile,".LUA") == firstfile+strlen(firstfile)-4) ||
- (strstr(firstfile,".LUC") == firstfile+strlen(firstfile)-4) ||
- (strstr(argv[0],"luatexlua") != NULL) ||
- (strstr(argv[0],"texlua") != NULL)) {
- startup_filename = firstfile;
- lua_only = 1;
- lua_offset = optind;
- luainit = 1 ;
- } else {
- input_name = firstfile;
- }
- }
- }
- } else {
- if ((strstr(argv[0],"luatexlua") != NULL)||
- (strstr(argv[0],"texlua") != NULL)) {
- lua_only = 1;
- luainit = 1 ;
- }
- }
+ int g; /* `getopt' return code. */
+ int option_index;
+ char *firstfile = NULL;
+ opterr = 0; /* dont whine */
+ for (;;) {
+ g = getopt_long_only(argc, argv, "+", long_options, &option_index);
+
+ if (g == -1) /* End of arguments, exit the loop. */
+ break;
+ if (g == '?') /* Unknown option. */
+ continue;
+
+ assert(g == 0); /* We have no short option names. */
+
+ if (ARGUMENT_IS("luaonly")) {
+ lua_only = 1;
+ lua_offset = optind;
+ luainit = 1;
+ } else if (ARGUMENT_IS("lua")) {
+ startup_filename = optarg;
+ lua_offset = (optind - 1);
+ luainit = 1;
+
+ } else if (ARGUMENT_IS("kpathsea-debug")) {
+ kpathsea_debug |= atoi(optarg);
+
+ } else if (ARGUMENT_IS("progname")) {
+ user_progname = optarg;
+
+ } else if (ARGUMENT_IS("jobname")) {
+ c_job_name = optarg;
+
+ } else if (ARGUMENT_IS("fmt")) {
+ dump_name = optarg;
+
+ } else if (ARGUMENT_IS("output-directory")) {
+ output_directory = optarg;
+
+ } else if (ARGUMENT_IS("output-comment")) {
+ unsigned len = strlen(optarg);
+ if (len < 256) {
+ output_comment = optarg;
+ } else {
+ WARNING2("Comment truncated to 255 characters from %d. (%s)",
+ len, optarg);
+ output_comment = (string) xmalloc(256);
+ strncpy(output_comment, optarg, 255);
+ output_comment[255] = 0;
+ }
+
+ } else if (ARGUMENT_IS("output-format")) {
+ pdf_output_option = 1;
+ if (strcmp(optarg, "dvi") == 0) {
+ pdf_output_value = 0;
+ } else if (strcmp(optarg, "pdf") == 0) {
+ pdf_output_value = 2;
+ } else {
+ WARNING1("Ignoring unknown value `%s' for --output-format",
+ optarg);
+ pdf_output_option = 0;
+ }
+
+ } else if (ARGUMENT_IS("draftmode")) {
+ pdf_draftmode_option = 1;
+ pdf_draftmode_value = 1;
+
+ } else if (ARGUMENT_IS("mktex")) {
+ kpse_maketex_option(optarg, true);
+
+ } else if (ARGUMENT_IS("no-mktex")) {
+ kpse_maketex_option(optarg, false);
+
+ } else if (ARGUMENT_IS("interaction")) {
+ /* These numbers match @d's in *.ch */
+ if (STREQ(optarg, "batchmode")) {
+ interactionoption = 0;
+ } else if (STREQ(optarg, "nonstopmode")) {
+ interactionoption = 1;
+ } else if (STREQ(optarg, "scrollmode")) {
+ interactionoption = 2;
+ } else if (STREQ(optarg, "errorstopmode")) {
+ interactionoption = 3;
+ } else {
+ WARNING1("Ignoring unknown argument `%s' to --interaction",
+ optarg);
+ }
+
+ } else if (ARGUMENT_IS("synctex")) {
+ /* Synchronize TeXnology: catching the command line option as a long */
+ synctexoption = (int) strtol(optarg, NULL, 0);
+
+ } else if (ARGUMENT_IS("help")) {
+ usagehelp(LUATEX_IHELP, BUG_ADDRESS);
+
+ } else if (ARGUMENT_IS("version")) {
+ print_version_banner();
+ /* *INDENT-OFF* */
+ puts("\n\nExecute 'luatex --credits' for credits and version details.\n\n"
+ "There is NO warranty. Redistribution of this software is covered by\n"
+ "the terms of the GNU General Public License, version 2. For more\n"
+ "information about these matters, see the file named COPYING and\n"
+ "the LuaTeX source.\n\n"
+ "Copyright 2009 Taco Hoekwater, the LuaTeX Team.\n");
+ /* *INDENT-ON* */
+ uexit(0);
+ } else if (ARGUMENT_IS("credits")) {
+ char *versions;
+ initversionstring(&versions);
+ print_version_banner();
+ /* *INDENT-OFF* */
+ puts("\n\nThe LuaTeX team is Hans Hagen, Hartmut Henkel, Taco Hoekwater.\n"
+ "LuaTeX merges and builds upon (parts of) the code from these projects:\n\n"
+ "tex by Donald Knuth\n"
+ "etex by Peter Breitenlohner, Phil Taylor and friends\n"
+ "omega by John Plaice and Yannis Haralambous\n"
+ "aleph by Giuseppe Bilotta\n"
+ "pdftex by Han The Thanh and friends\n"
+ "kpathsea by Karl Berry, Olaf Weber and others\n"
+ "lua by Roberto Ierusalimschy, Waldemar Celes,\n"
+ " Luiz Henrique de Figueiredo\n"
+ "metapost by John Hobby, Taco Hoekwater and friends.\n"
+ "xpdf by Derek Noonberg (partial)\n"
+ "fontforge by George Williams (partial)\n\n"
+ "Some extensions to lua and additional lua libraries are used, as well as\n"
+ "libraries for graphic inclusion. More details can be found in the source.\n"
+ "Code development was sponsored by a grant from Colorado State University\n"
+ "via the 'oriental tex' project, the TeX User Groups, and donations.\n");
+ /* *INDENT-ON* */
+ puts(versions);
+ uexit(0);
+ }
+ }
+ /* attempt to find dump_name */
+ if (argv[optind] && argv[optind][0] == '&') {
+ dump_name = strdup(argv[optind] + 1);
+ } else if (argv[optind] && argv[optind][0] != '\\') {
+ if (argv[optind][0] == '*') {
+ input_name = strdup(argv[optind] + 1);
+ } else {
+ firstfile = strdup(argv[optind]);
+ if (lua_only) {
+ startup_filename = firstfile;
+ } else {
+ if ((strstr(firstfile, ".lua") ==
+ firstfile + strlen(firstfile) - 4)
+ || (strstr(firstfile, ".luc") ==
+ firstfile + strlen(firstfile) - 4)
+ || (strstr(firstfile, ".LUA") ==
+ firstfile + strlen(firstfile) - 4)
+ || (strstr(firstfile, ".LUC") ==
+ firstfile + strlen(firstfile) - 4)
+ || (strstr(argv[0], "luatexlua") != NULL)
+ || (strstr(argv[0], "texlua") != NULL)) {
+ startup_filename = firstfile;
+ lua_only = 1;
+ lua_offset = optind;
+ luainit = 1;
+ } else {
+ input_name = firstfile;
+ }
+ }
+ }
+ } else {
+ if ((strstr(argv[0], "luatexlua") != NULL) ||
+ (strstr(argv[0], "texlua") != NULL)) {
+ lua_only = 1;
+ luainit = 1;
+ }
+ }
+ if (safer_option) /* --safer implies --nosocket */
+ nosocket_option = 1;
+
+ /* Finalize the input filename. */
+ if (input_name != NULL) {
+ argv[optind] = normalize_quotes(input_name, "argument");
+ }
}
/* test for readability */
#define is_readable(a) (stat(a,&finfo)==0) && S_ISREG(finfo.st_mode) && \
(f=fopen(a,"r")) != NULL && !fclose(f)
-char *
-find_filename(char *name, char *envkey)
+char *find_filename(char *name, char *envkey)
{
struct stat finfo;
char *dirname = NULL;
char *filename = NULL;
FILE *f;
if (is_readable(name)) {
- return name;
+ return name;
} else {
- dirname = getenv(envkey);
- if ((dirname != NULL) && strlen(dirname)) {
- dirname = strdup(getenv(envkey));
- if (*(dirname + strlen(dirname) - 1) == '/') {
- *(dirname + strlen(dirname) - 1) = 0;
- }
- filename = xmalloc(strlen(dirname) + strlen(name) + 2);
- filename = concat3(dirname, "/", name);
- if (is_readable(filename)) {
- xfree(dirname);
- return filename;
- }
- xfree(filename);
- }
+ dirname = getenv(envkey);
+ if ((dirname != NULL) && strlen(dirname)) {
+ dirname = strdup(getenv(envkey));
+ if (*(dirname + strlen(dirname) - 1) == '/') {
+ *(dirname + strlen(dirname) - 1) = 0;
+ }
+ filename = xmalloc(strlen(dirname) + strlen(name) + 2);
+ filename = concat3(dirname, "/", name);
+ if (is_readable(filename)) {
+ xfree(dirname);
+ return filename;
+ }
+ xfree(filename);
+ }
}
return NULL;
}
-void
-init_kpse (void) {
-
- if (!user_progname) {
- user_progname = dump_name;
- } else if (!dump_name) {
- dump_name = user_progname;
- }
- if (!user_progname) {
- if (ini_version) {
- user_progname = input_name;
- } else {
- if(!startup_filename) {
- if (!dump_name) {
- dump_name = strdup(argv[0]);
- user_progname = dump_name;
- }
- }
- }
- }
- if (!user_progname) {
- fprintf(stdout,
- "kpathsea mode needs a --progname or --fmt switch\n");
- exit(1);
- }
-
- kpse_set_program_enabled (kpse_fmt_format, MAKE_TEX_FMT_BY_DEFAULT,
- kpse_src_compile);
-
- kpse_set_program_name(argv[0], user_progname);
- program_name_set=1;
-
- /* Needs program_name set. */
- init_shell_escape ();
-}
-
-void
-fix_dumpname (void) {
- int dist;
- if (dump_name) {
- /* adjust array for Pascal and provide extension, if needed */
- dist = strlen(dump_name) - strlen(DUMP_EXT);
- if (strstr(dump_name, DUMP_EXT) == dump_name + dist)
- DUMP_VAR = concat(" ", dump_name);
- else
- DUMP_VAR = concat3(" ", dump_name, DUMP_EXT);
- DUMP_LENGTH_VAR = strlen(DUMP_VAR + 1);
- } else {
- /* For dump_name to be NULL is a bug. */
- if (!ini_version)
- abort();
- }
+char *cleaned_invocation_name(char *arg)
+{
+ char *ret, *dot;
+ const char *start = xbasename(arg);
+ ret = xstrdup(start);
+ dot = index(ret, '.');
+ if (dot != NULL) {
+ *dot = 0; /* chop */
+ }
+ return ret;
}
-void
-lua_initialize(int ac, char **av)
+void init_kpse(void)
{
- char *given_file = NULL;
- int kpse_init;
- int tex_table_id;
- int pdf_table_id;
- int token_table_id;
- int node_table_id;
- /* Save to pass along to topenin. */
- argc = ac;
- argv = av;
-
- ptexbanner = BANNER;
- program_invocation_name = argv[0];
-
- /* be 'luac' */
- if (argc>1 &&
- (STREQ(argv[0],"texluac") ||
- STREQ(argv[1],"--luaconly") ||
- STREQ(argv[1],"--luac"))) {
- exit(luac_main(ac,av));
- }
-
- /* Must be initialized before options are parsed. */
- interactionoption = 4;
- dump_name = NULL;
- /* parse commandline */
- parse_options(ac, av);
-
- /* make sure that the locale is 'sane' (for lua) */
- putenv("LC_CTYPE=C");
- putenv("LC_COLLATE=C");
- putenv("LC_NUMERIC=C");
-
- /* this is sometimes needed */
- putenv("engine=luatex");
-
- luainterpreter(0);
-
- prepare_cmdline(Luas[0], argv, argc, lua_offset); /* collect arguments */
-
- if (startup_filename != NULL) {
- given_file = xstrdup(startup_filename);
- startup_filename = find_filename(startup_filename, "LUATEXDIR");
- }
- /* now run the file */
- if (startup_filename != NULL) {
- /* hide the 'tex' and 'pdf' table */
- tex_table_id = hide_lua_table(Luas[0], "tex");
- token_table_id = hide_lua_table(Luas[0], "token");
- node_table_id = hide_lua_table(Luas[0], "node");
- pdf_table_id = hide_lua_table(Luas[0], "pdf");
-
- if (luaL_loadfile(Luas[0], startup_filename)) {
- fprintf(stdout, "%s\n",lua_tostring(Luas[0], -1));
- exit(1);
+ if (!user_progname) {
+ user_progname = dump_name;
+ } else if (!dump_name) {
+ dump_name = user_progname;
}
- if (lua_pcall(Luas[0], 0, 0, 0)) {
- fprintf(stdout, "%s\n",lua_tostring(Luas[0], -1));
- exit(1);
+ if (!user_progname) {
+ if (ini_version) {
+ user_progname = input_name;
+ } else {
+ if (!startup_filename) {
+ if (!dump_name) {
+ dump_name = cleaned_invocation_name(argv[0]);
+ user_progname = dump_name;
+ }
+ }
+ }
}
- /* no filename? quit now! */
- if (!input_name) {
- get_lua_string("texconfig", "jobname", &input_name);
+ if (!user_progname) {
+ fprintf(stdout, "kpathsea mode needs a --progname or --fmt switch\n");
+ exit(1);
}
- if (!dump_name) {
- get_lua_string("texconfig", "formatname", &dump_name);
+
+ kpse_set_program_enabled(kpse_fmt_format, MAKE_TEX_FMT_BY_DEFAULT,
+ kpse_src_compile);
+
+ kpse_set_program_name(argv[0], user_progname);
+ program_name_set = 1;
+}
+
+void fix_dumpname(void)
+{
+ int dist;
+ if (dump_name) {
+ /* adjust array for Pascal and provide extension, if needed */
+ dist = strlen(dump_name) - strlen(DUMP_EXT);
+ if (strstr(dump_name, DUMP_EXT) == dump_name + dist)
+ DUMP_VAR = concat(" ", dump_name);
+ else
+ DUMP_VAR = concat3(" ", dump_name, DUMP_EXT);
+ DUMP_LENGTH_VAR = strlen(DUMP_VAR + 1);
+ } else {
+ /* For dump_name to be NULL is a bug. */
+ if (!ini_version)
+ abort();
}
- if ((lua_only) || ((!input_name) && (!dump_name))) {
- exit(0);
+}
+
+void lua_initialize(int ac, char **av)
+{
+
+ char *given_file = NULL;
+ int kpse_init;
+ int tex_table_id;
+ int pdf_table_id;
+ int token_table_id;
+ int node_table_id;
+ /* Save to pass along to topenin. */
+ argc = ac;
+ argv = av;
+
+ ptexbanner = BANNER;
+
+ program_invocation_name = cleaned_invocation_name(argv[0]);
+
+ /* be 'luac' */
+ if (argc > 1 &&
+ (STREQ(program_invocation_name, "texluac") ||
+ STREQ(argv[1], "--luaconly") || STREQ(argv[1], "--luac"))) {
+ exit(luac_main(ac, av));
}
- /* unhide the 'tex' and 'pdf' table */
- unhide_lua_table(Luas[0], "tex", tex_table_id);
- unhide_lua_table(Luas[0], "pdf", pdf_table_id);
- unhide_lua_table(Luas[0], "token", token_table_id);
- unhide_lua_table(Luas[0], "node", node_table_id);
-
- /* kpse_init */
- kpse_init = -1;
- get_lua_boolean("texconfig", "kpse_init", &kpse_init);
-
- if (kpse_init != 0) {
- init_kpse();
+
+ /* Must be initialized before options are parsed. */
+ interactionoption = 4;
+ dump_name = NULL;
+
+#warning SyncTeX: -synctex command line option available
+ /* 0 means "disable Synchronize TeXnology".
+ * synctexoption is a *.web variable.
+ * We initialize it to a weird value to catch the -synctex command line flag
+ * At runtime, if synctexoption is not INT_MAX, then it contains the command line option provided,
+ * otherwise no such option was given by the user. */
+#define SYNCTEX_NO_OPTION INT_MAX
+ synctexoption = SYNCTEX_NO_OPTION;
+
+ /* parse commandline */
+ parse_options(ac, av);
+
+ /* make sure that the locale is 'sane' (for lua) */
+ putenv("LC_CTYPE=C");
+ putenv("LC_COLLATE=C");
+ putenv("LC_NUMERIC=C");
+
+ /* this is sometimes needed */
+ putenv("engine=luatex");
+
+ luainterpreter();
+
+ prepare_cmdline(Luas, argv, argc, lua_offset); /* collect arguments */
+
+ if (startup_filename != NULL) {
+ given_file = xstrdup(startup_filename);
+ startup_filename = find_filename(startup_filename, "LUATEXDIR");
}
- /* prohibit_file_trace (boolean) */
- tracefilenames = 1;
- get_lua_boolean("texconfig", "trace_file_names", &tracefilenames);
-
- /* src_special_xx */
- insertsrcspecialauto = insertsrcspecialeverypar =
- insertsrcspecialeveryparend = insertsrcspecialeverycr =
- insertsrcspecialeverymath = insertsrcspecialeveryhbox =
- insertsrcspecialeveryvbox = insertsrcspecialeverydisplay =
- false;
- get_lua_boolean("texconfig", "src_special_auto",
- &insertsrcspecialauto);
- get_lua_boolean("texconfig", "src_special_everypar",
- &insertsrcspecialeverypar);
- get_lua_boolean("texconfig", "src_special_everyparend",
- &insertsrcspecialeveryparend);
- get_lua_boolean("texconfig", "src_special_everycr",
- &insertsrcspecialeverycr);
- get_lua_boolean("texconfig", "src_special_everymath",
- &insertsrcspecialeverymath);
- get_lua_boolean("texconfig", "src_special_everyhbox",
- &insertsrcspecialeveryhbox);
- get_lua_boolean("texconfig", "src_special_everyvbox",
- &insertsrcspecialeveryvbox);
- get_lua_boolean("texconfig", "src_special_everydisplay",
- &insertsrcspecialeverydisplay);
-
- srcspecialsp = insertsrcspecialauto | insertsrcspecialeverypar |
- insertsrcspecialeveryparend | insertsrcspecialeverycr |
- insertsrcspecialeverymath | insertsrcspecialeveryhbox |
- insertsrcspecialeveryvbox | insertsrcspecialeverydisplay;
-
- /* file_line_error */
- filelineerrorstylep = false;
- get_lua_boolean("texconfig", "file_line_error",
- &filelineerrorstylep);
-
- /* halt_on_error */
- haltonerrorp = false;
- get_lua_boolean("texconfig", "halt_on_error", &haltonerrorp);
-
- fix_dumpname();
- } else {
- if (luainit) {
- if (given_file) {
- fprintf(stdout, "%s file %s not found\n", (lua_only ? "Script" : "Configuration"), given_file);
- } else {
- fprintf(stdout, "No %s file given\n", (lua_only ? "script" : "configuration"));
- }
- exit(1);
+ /* now run the file */
+ if (startup_filename != NULL) {
+ /* hide the 'tex' and 'pdf' table */
+ tex_table_id = hide_lua_table(Luas, "tex");
+ token_table_id = hide_lua_table(Luas, "token");
+ node_table_id = hide_lua_table(Luas, "node");
+ pdf_table_id = hide_lua_table(Luas, "pdf");
+
+ if (luaL_loadfile(Luas, startup_filename)) {
+ fprintf(stdout, "%s\n", lua_tostring(Luas, -1));
+ exit(1);
+ }
+ if (lua_pcall(Luas, 0, 0, 0)) {
+ fprintf(stdout, "%s\n", lua_tostring(Luas, -1));
+ exit(1);
+ }
+ /* no filename? quit now! */
+ if (!input_name) {
+ get_lua_string("texconfig", "jobname", &input_name);
+ }
+ if (!dump_name) {
+ get_lua_string("texconfig", "formatname", &dump_name);
+ }
+ if ((lua_only) || ((!input_name) && (!dump_name))) {
+ if (given_file)
+ free(given_file);
+ /* this is not strictly needed but it pleases valgrind */
+ lua_close(Luas);
+ exit(0);
+ }
+ /* unhide the 'tex' and 'pdf' table */
+ unhide_lua_table(Luas, "tex", tex_table_id);
+ unhide_lua_table(Luas, "pdf", pdf_table_id);
+ unhide_lua_table(Luas, "token", token_table_id);
+ unhide_lua_table(Luas, "node", node_table_id);
+
+ /* kpse_init */
+ kpse_init = -1;
+ get_lua_boolean("texconfig", "kpse_init", &kpse_init);
+
+ if (kpse_init != 0) {
+ luainit = 0; /* re-enable loading of texmf.cnf values, see luatex.ch */
+ init_kpse();
+ }
+ /* prohibit_file_trace (boolean) */
+ tracefilenames = 1;
+ get_lua_boolean("texconfig", "trace_file_names", &tracefilenames);
+
+ /* file_line_error */
+ filelineerrorstylep = false;
+ get_lua_boolean("texconfig", "file_line_error", &filelineerrorstylep);
+
+ /* halt_on_error */
+ haltonerrorp = false;
+ get_lua_boolean("texconfig", "halt_on_error", &haltonerrorp);
+
+ fix_dumpname();
} else {
- /* init */
- init_kpse();
- fix_dumpname();
+ if (luainit) {
+ if (given_file) {
+ fprintf(stdout, "%s file %s not found\n",
+ (lua_only ? "Script" : "Configuration"), given_file);
+ free(given_file);
+ } else {
+ fprintf(stdout, "No %s file given\n",
+ (lua_only ? "script" : "configuration"));
+ }
+ exit(1);
+ } else {
+ /* init */
+ init_kpse();
+ fix_dumpname();
+ }
}
- }
}
diff --git a/Build/source/texk/web2c/luatexdir/lua/luanode.c b/Build/source/texk/web2c/luatexdir/lua/luanode.c
index 17c8e7be8e2..0be6547446f 100644
--- a/Build/source/texk/web2c/luatexdir/lua/luanode.c
+++ b/Build/source/texk/web2c/luatexdir/lua/luanode.c
@@ -1,181 +1,247 @@
-/* $Id: luanode.c 1013 2008-02-14 00:09:02Z oneiros $ */
+/* luanode.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 General Public License as published by the Free
+ Software Foundation; either version 2 of the License, or (at your
+ option) any later version.
+
+ LuaTeX is distributed in the hope that it will be useful, but WITHOUT
+ ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
+ FITNESS FOR A PARTICULAR PURPOSE. See the GNU Lesser General Public
+ License for more details.
+
+ You should have received a copy of the GNU General Public License along
+ with LuaTeX; if not, see <http://www.gnu.org/licenses/>. */
#include "luatex-api.h"
#include <ptexlib.h>
#include "nodes.h"
-#undef link /* defined by cpascal.h */
+static const char _svn_version[] =
+ "$Id: luanode.c 2064 2009-03-20 13:13:14Z taco $ $URL: http://scm.foundry.supelec.fr/svn/luatex/trunk/src/texk/web2c/luatexdir/lua/luanode.c $";
+
+#undef link /* defined by cpascal.h */
#define info(a) fixmem[(a)].hhlh
#define link(a) fixmem[(a)].hhrh
-
static char *group_code_names[] = {
- "",
- "simple",
- "hbox",
- "adjusted_hbox",
- "vbox",
- "vtop",
- "align",
- "no_align",
- "output",
- "math",
- "disc",
- "insert",
- "vcenter",
- "math_choice",
- "semi_simple",
- "math_shift",
- "math_left",
- "local_box" ,
- "split_off",
- "split_keep",
- "preamble",
- "align_set",
- "fin_row"};
-
-char *pack_type_name[] = { "exactly", "additional"};
+ "",
+ "simple",
+ "hbox",
+ "adjusted_hbox",
+ "vbox",
+ "vtop",
+ "align",
+ "no_align",
+ "output",
+ "math",
+ "disc",
+ "insert",
+ "vcenter",
+ "math_choice",
+ "semi_simple",
+ "math_shift",
+ "math_left",
+ "local_box",
+ "split_off",
+ "split_keep",
+ "preamble",
+ "align_set",
+ "fin_row"
+};
+char *pack_type_name[] = { "exactly", "additional" };
-void
-lua_node_filter_s (int filterid, char *extrainfo, halfword head_node, halfword *tail_node) {
- halfword ret;
- int a;
- lua_State *L = Luas[0];
- int callback_id = callback_defined(filterid);
- if (head_node==null || vlink(head_node)==null || callback_id==0)
- return;
- lua_rawgeti(L,LUA_REGISTRYINDEX,callback_callbacks_id);
- lua_rawgeti(L,-1, callback_id);
- if (!lua_isfunction(L,-1)) {
- lua_pop(L,2);
- return;
- }
- nodelist_to_lua(L,vlink(head_node)); /* arg 1 */
- lua_pushstring(L,extrainfo); /* arg 2 */
- if (lua_pcall(L,2,1,0) != 0) { /* no arg, 1 result */
- fprintf(stdout,"error: %s\n",lua_tostring(L,-1));
- lua_pop(L,2);
- error();
+
+void lua_node_filter_s(int filterid, char *extrainfo)
+{
+ lua_State *L = Luas;
+ int s_top = lua_gettop(L);
+ if (!get_callback(L, callback_defined(filterid))) {
+ lua_settop(L, s_top);
+ return;
+ }
+ lua_pushstring(L, extrainfo); /* arg 1 */
+ if (lua_pcall(L, 1, 0, 0) != 0) {
+ fprintf(stdout, "error: %s\n", lua_tostring(L, -1));
+ lua_settop(L, s_top);
+ error();
+ return;
+ }
+ lua_settop(L, s_top);
return;
- }
- if (lua_isboolean(L,-1)) {
- if (lua_toboolean(L,-1)!=1) {
- flush_node_list(vlink(head_node));
- vlink(head_node) = null;
- }
- } else {
- a = nodelist_from_lua(L);
- vlink(head_node)= a;
- }
- lua_pop(L,2); /* result and callback container table */
- if (fix_node_lists)
- fix_node_list(head_node);
- ret = vlink(head_node);
- if (ret!=null) {
- while (vlink(ret)!=null)
- ret=vlink(ret);
- *tail_node=ret;
- } else {
- *tail_node=head_node;
- }
- return ;
}
void
-lua_node_filter (int filterid, int extrainfo, halfword head_node, halfword *tail_node) {
- lua_node_filter_s(filterid, group_code_names[extrainfo], head_node, tail_node);
- return ;
+lua_node_filter(int filterid, int xextrainfo, halfword head_node,
+ halfword * tail_node)
+{
+ halfword ret;
+ int a;
+ lua_State *L = Luas;
+ char *extrainfo = group_code_names[xextrainfo];
+ int callback_id = callback_defined(filterid);
+ if (head_node == null || vlink(head_node) == null || callback_id == 0)
+ return;
+ if (!get_callback(L, callback_id)) {
+ lua_pop(L, 2);
+ return;
+ }
+ nodelist_to_lua(L, vlink(head_node)); /* arg 1 */
+ lua_pushstring(L, extrainfo); /* arg 2 */
+ if (lua_pcall(L, 2, 1, 0) != 0) { /* no arg, 1 result */
+ fprintf(stdout, "error: %s\n", lua_tostring(L, -1));
+ lua_pop(L, 2);
+ error();
+ return;
+ }
+ if (lua_isboolean(L, -1)) {
+ if (lua_toboolean(L, -1) != 1) {
+ flush_node_list(vlink(head_node));
+ vlink(head_node) = null;
+ }
+ } else {
+ a = nodelist_from_lua(L);
+ vlink(head_node) = a;
+ }
+ lua_pop(L, 2); /* result and callback container table */
+ if (fix_node_lists)
+ fix_node_list(head_node);
+ ret = vlink(head_node);
+ if (ret != null) {
+ while (vlink(ret) != null)
+ ret = vlink(ret);
+ *tail_node = ret;
+ } else {
+ *tail_node = head_node;
+ }
+ return;
+}
+
+
+int
+lua_linebreak_callback(int is_broken, halfword head_node, halfword * new_head)
+{
+ int a;
+ register halfword *p;
+ int ret = 0; /* failure */
+ lua_State *L = Luas;
+ int callback_id = callback_defined(linebreak_filter_callback);
+ if (head_node == null || vlink(head_node) == null || callback_id == 0)
+ return ret;
+ if (!get_callback(L, callback_id)) {
+ lua_pop(L, 2);
+ return ret;
+ }
+ nodelist_to_lua(L, vlink(head_node)); /* arg 1 */
+ lua_pushboolean(L, is_broken); /* arg 2 */
+ if (lua_pcall(L, 2, 1, 0) != 0) { /* no arg, 1 result */
+ fprintf(stdout, "error: %s\n", lua_tostring(L, -1));
+ lua_pop(L, 2);
+ error();
+ return ret;
+ }
+
+ p = lua_touserdata(L, -1);
+ if (p != NULL) {
+ a = nodelist_from_lua(L);
+ vlink(*new_head) = a;
+ ret = 1;
+ }
+ lua_pop(L, 2); /* result and callback container table */
+ return ret;
}
halfword
-lua_hpack_filter (halfword head_node, scaled size, int pack_type, int extrainfo) {
- halfword ret;
- lua_State *L = Luas[0];
- int callback_id = callback_defined(hpack_filter_callback);
- if (head_node==null || callback_id == 0)
- return head_node;
- lua_rawgeti(L,LUA_REGISTRYINDEX,callback_callbacks_id);
- lua_rawgeti(L,-1, callback_id);
- if (!lua_isfunction(L,-1)) {
- lua_pop(L,2);
- return head_node;
- }
-
- nodelist_to_lua(L,head_node);
- lua_pushstring(L,group_code_names[extrainfo]);
- lua_pushnumber(L,size);
- lua_pushstring(L,pack_type_name[pack_type]);
- if (lua_pcall(L,4,1,0) != 0) { /* no arg, 1 result */
- fprintf(stdout,"error: %s\n",lua_tostring(L,-1));
- lua_pop(L,2);
- error();
- return head_node;
- }
- ret = head_node;
- if (lua_isboolean(L,-1)) {
- if (lua_toboolean(L,-1)!=1) {
- flush_node_list(head_node);
- ret = null;
- }
- } else {
- ret = nodelist_from_lua(L);
- }
- lua_pop(L,2); /* result and callback container table */
- /* lua_gc(L,LUA_GCSTEP, LUA_GC_STEP_SIZE);*/
- if (fix_node_lists)
- fix_node_list(ret);
- return ret;
+lua_hpack_filter(halfword head_node, scaled size, int pack_type, int extrainfo)
+{
+ halfword ret;
+ lua_State *L = Luas;
+ int callback_id = callback_defined(hpack_filter_callback);
+ if (head_node == null || callback_id == 0)
+ return head_node;
+ if (!get_callback(L, callback_id)) {
+ lua_pop(L, 2);
+ return head_node;
+ }
+ nodelist_to_lua(L, head_node);
+ lua_pushstring(L, group_code_names[extrainfo]);
+ lua_pushnumber(L, size);
+ lua_pushstring(L, pack_type_name[pack_type]);
+ if (lua_pcall(L, 4, 1, 0) != 0) { /* no arg, 1 result */
+ fprintf(stdout, "error: %s\n", lua_tostring(L, -1));
+ lua_pop(L, 2);
+ error();
+ return head_node;
+ }
+ ret = head_node;
+ if (lua_isboolean(L, -1)) {
+ if (lua_toboolean(L, -1) != 1) {
+ flush_node_list(head_node);
+ ret = null;
+ }
+ } else {
+ ret = nodelist_from_lua(L);
+ }
+ lua_pop(L, 2); /* result and callback container table */
+ /* lua_gc(L,LUA_GCSTEP, LUA_GC_STEP_SIZE); */
+ if (fix_node_lists)
+ fix_node_list(ret);
+ return ret;
}
halfword
-lua_vpack_filter (halfword head_node, scaled size, int pack_type, scaled maxd, int extrainfo) {
- halfword ret;
- integer callback_id ;
- lua_State *L = Luas[0];
- if (head_node==null)
- return head_node;
- if (strcmp("output",group_code_names[extrainfo])==0) {
- callback_id = callback_defined(pre_output_filter_callback);
- } else {
- callback_id = callback_defined(vpack_filter_callback);
- }
- if (callback_id==0) {
- return head_node;
- }
- lua_rawgeti(L,LUA_REGISTRYINDEX,callback_callbacks_id);
- lua_rawgeti(L,-1, callback_id);
- if (!lua_isfunction(L,-1)) {
- lua_pop(L,2);
- return head_node;
- }
- nodelist_to_lua(L,head_node);
- lua_pushstring(L,group_code_names[extrainfo]);
- lua_pushnumber(L,size);
- lua_pushstring(L,pack_type_name[pack_type]);
- lua_pushnumber(L,maxd);
- if (lua_pcall(L,5,1,0) != 0) { /* no arg, 1 result */
- fprintf(stdout,"error: %s\n",lua_tostring(L,-1));
- lua_pop(L,2);
- error();
- return head_node;
- }
- ret = head_node;
- if (lua_isboolean(L,-1)) {
- if (lua_toboolean(L,-1)!=1) {
- flush_node_list(head_node);
- ret = null;
- }
- } else {
- ret = nodelist_from_lua(L);
- }
- lua_pop(L,2); /* result and callback container table */
- /* lua_gc(L,LUA_GCSTEP, LUA_GC_STEP_SIZE);*/
- if (fix_node_lists)
- fix_node_list(ret);
- return ret;
+lua_vpack_filter(halfword head_node, scaled size, int pack_type, scaled maxd,
+ int extrainfo)
+{
+ halfword ret;
+ integer callback_id;
+ lua_State *L = Luas;
+ if (head_node == null)
+ return head_node;
+ if (strcmp("output", group_code_names[extrainfo]) == 0) {
+ callback_id = callback_defined(pre_output_filter_callback);
+ } else {
+ callback_id = callback_defined(vpack_filter_callback);
+ }
+ if (callback_id == 0) {
+ return head_node;
+ }
+ if (!get_callback(L, callback_id)) {
+ lua_pop(L, 2);
+ return head_node;
+ }
+ nodelist_to_lua(L, head_node);
+ lua_pushstring(L, group_code_names[extrainfo]);
+ lua_pushnumber(L, size);
+ lua_pushstring(L, pack_type_name[pack_type]);
+ lua_pushnumber(L, maxd);
+ if (lua_pcall(L, 5, 1, 0) != 0) { /* no arg, 1 result */
+ fprintf(stdout, "error: %s\n", lua_tostring(L, -1));
+ lua_pop(L, 2);
+ error();
+ return head_node;
+ }
+ ret = head_node;
+ if (lua_isboolean(L, -1)) {
+ if (lua_toboolean(L, -1) != 1) {
+ flush_node_list(head_node);
+ ret = null;
+ }
+ } else {
+ ret = nodelist_from_lua(L);
+ }
+ lua_pop(L, 2); /* result and callback container table */
+ /* lua_gc(L,LUA_GCSTEP, LUA_GC_STEP_SIZE); */
+ if (fix_node_lists)
+ fix_node_list(ret);
+ return ret;
}
@@ -184,17 +250,16 @@ lua_vpack_filter (halfword head_node, scaled size, int pack_type, scaled maxd, i
* eTeX manual for the expected return values.
*/
-int
-visible_last_node_type (int n) {
- int i = type(n);
- if ((i!=math_node) && (i<=unset_node))
- return i+1;
- if (i==glyph_node)
- return -1;
- if (i==whatsit_node && subtype(n)==local_par_node)
- return -1;
- if (i==255)
- return -1 ; /* this is not right, probably dir nodes! */
- return last_known_node +1 ;
+int visible_last_node_type(int n)
+{
+ int i = type(n);
+ if ((i != math_node) && (i <= unset_node))
+ return i + 1;
+ if (i == glyph_node)
+ return -1;
+ if (i == whatsit_node && subtype(n) == local_par_node)
+ return -1;
+ if (i == 255)
+ return -1; /* this is not right, probably dir nodes! */
+ return last_known_node + 1;
}
-
diff --git a/Build/source/texk/web2c/luatexdir/lua/luastuff.c b/Build/source/texk/web2c/luatexdir/lua/luastuff.c
index f48bfdb0171..49298ea2fc5 100644
--- a/Build/source/texk/web2c/luatexdir/lua/luastuff.c
+++ b/Build/source/texk/web2c/luatexdir/lua/luastuff.c
@@ -1,41 +1,64 @@
-/* $Id: luastuff.c 1079 2008-03-05 15:34:41Z taco $ */
+/* luastuff.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 General Public License as published by the Free
+ Software Foundation; either version 2 of the License, or (at your
+ option) any later version.
+
+ LuaTeX is distributed in the hope that it will be useful, but WITHOUT
+ ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
+ FITNESS FOR A PARTICULAR PURPOSE. See the GNU Lesser General Public
+ License for more details.
+
+ You should have received a copy of the GNU General Public License along
+ with LuaTeX; if not, see <http://www.gnu.org/licenses/>. */
#include "luatex-api.h"
#include <ptexlib.h>
-lua_State *Luas[65536];
+static const char _svn_version[] =
+ "$Id: luastuff.c 2064 2009-03-20 13:13:14Z taco $ $URL: http://scm.foundry.supelec.fr/svn/luatex/trunk/src/texk/web2c/luatexdir/lua/luastuff.c $";
+
+lua_State *Luas = NULL;
extern char *startup_filename;
extern int safer_option;
+extern int nosocket_option;
-int luastate_max = 0;
int luastate_bytes = 0;
-void
-make_table (lua_State *L, char *tab, char *getfunc, char *setfunc) {
- /* make the table */ /* [{<tex>}] */
- lua_pushstring(L,tab); /* [{<tex>},"dimen"] */
- lua_newtable(L); /* [{<tex>},"dimen",{}] */
- lua_settable(L, -3); /* [{<tex>}] */
- /* fetch it back */
- lua_pushstring(L,tab); /* [{<tex>},"dimen"] */
- lua_gettable(L, -2); /* [{<tex>},{<dimen>}] */
- /* make the meta entries */
- luaL_newmetatable(L,tab); /* [{<tex>},{<dimen>},{<dimen_m>}] */
- lua_pushstring(L, "__index"); /* [{<tex>},{<dimen>},{<dimen_m>},"__index"] */
- lua_pushstring(L, getfunc); /* [{<tex>},{<dimen>},{<dimen_m>},"__index","getdimen"] */
- lua_gettable(L, -5); /* [{<tex>},{<dimen>},{<dimen_m>},"__index",<tex.getdimen>] */
- lua_settable(L, -3); /* [{<tex>},{<dimen>},{<dimen_m>}] */
- lua_pushstring(L, "__newindex");/* [{<tex>},{<dimen>},{<dimen_m>},"__newindex"] */
- lua_pushstring(L, setfunc); /* [{<tex>},{<dimen>},{<dimen_m>},"__newindex","setdimen"] */
- lua_gettable(L, -5); /* [{<tex>},{<dimen>},{<dimen_m>},"__newindex",<tex.setdimen>] */
- lua_settable(L, -3); /* [{<tex>},{<dimen>},{<dimen_m>}] */
- lua_setmetatable(L,-2); /* [{<tex>},{<dimen>}] : assign the metatable */
- lua_pop(L,1); /* [{<tex>}] : clean the stack */
+int lua_active = 0;
+
+void make_table(lua_State * L, char *tab, char *getfunc, char *setfunc)
+{
+ /* make the table *//* [{<tex>}] */
+ lua_pushstring(L, tab); /* [{<tex>},"dimen"] */
+ lua_newtable(L); /* [{<tex>},"dimen",{}] */
+ lua_settable(L, -3); /* [{<tex>}] */
+ /* fetch it back */
+ lua_pushstring(L, tab); /* [{<tex>},"dimen"] */
+ lua_gettable(L, -2); /* [{<tex>},{<dimen>}] */
+ /* make the meta entries */
+ luaL_newmetatable(L, tab); /* [{<tex>},{<dimen>},{<dimen_m>}] */
+ lua_pushstring(L, "__index"); /* [{<tex>},{<dimen>},{<dimen_m>},"__index"] */
+ lua_pushstring(L, getfunc); /* [{<tex>},{<dimen>},{<dimen_m>},"__index","getdimen"] */
+ lua_gettable(L, -5); /* [{<tex>},{<dimen>},{<dimen_m>},"__index",<tex.getdimen>] */
+ lua_settable(L, -3); /* [{<tex>},{<dimen>},{<dimen_m>}] */
+ lua_pushstring(L, "__newindex"); /* [{<tex>},{<dimen>},{<dimen_m>},"__newindex"] */
+ lua_pushstring(L, setfunc); /* [{<tex>},{<dimen>},{<dimen_m>},"__newindex","setdimen"] */
+ lua_gettable(L, -5); /* [{<tex>},{<dimen>},{<dimen_m>},"__newindex",<tex.setdimen>] */
+ lua_settable(L, -3); /* [{<tex>},{<dimen>},{<dimen_m>}] */
+ lua_setmetatable(L, -2); /* [{<tex>},{<dimen>}] : assign the metatable */
+ lua_pop(L, 1); /* [{<tex>}] : clean the stack */
}
-static
-const char *getS(lua_State * L, void *ud, size_t * size) {
+static
+const char *getS(lua_State * L, void *ud, size_t * size)
+{
LoadS *ls = (LoadS *) ud;
(void) L;
if (ls->size == 0)
@@ -45,266 +68,345 @@ const char *getS(lua_State * L, void *ud, size_t * size) {
return ls->s;
}
-void *my_luaalloc (void *ud, void *ptr, size_t osize, size_t nsize) {
- void *ret = NULL;
- if (nsize == 0)
- free(ptr);
- else
- ret = realloc(ptr, nsize);
- luastate_bytes += (nsize-osize);
- return ret;
+void *my_luaalloc(void *ud, void *ptr, size_t osize, size_t nsize)
+{
+ void *ret = NULL;
+ (void)ud; /* for -Wunused */
+ if (nsize == 0)
+ free(ptr);
+ else
+ ret = realloc(ptr, nsize);
+ luastate_bytes += (nsize - osize);
+ return ret;
}
-static int my_luapanic (lua_State *L) {
- (void)L; /* to avoid warnings */
- fprintf(stderr, "PANIC: unprotected error in call to Lua API (%s)\n",
- lua_tostring(L, -1));
- return 0;
+static int my_luapanic(lua_State * L)
+{
+ (void) L; /* to avoid warnings */
+ fprintf(stderr, "PANIC: unprotected error in call to Lua API (%s)\n",
+ lua_tostring(L, -1));
+ return 0;
}
-void
-luainterpreter (int n) {
- lua_State *L;
- L = lua_newstate(my_luaalloc, NULL);
- if (L==NULL) {
- fprintf(stderr,"Can't create a new Lua state (%d).",n);
- return;
- }
- lua_atpanic(L, &my_luapanic);
-
- luastate_max++;
- luaL_openlibs(L);
-
- open_oslibext(L,safer_option);
-
- lua_getglobal(L,"package");
- lua_pushstring(L,"");
- lua_setfield(L,-2,"cpath");
- lua_pop(L,1); /* pop the table */
-
- /*luaopen_unicode(L);*/
- lua_pushcfunction(L, luaopen_unicode);
- lua_pushstring(L, "unicode");
- lua_call(L, 1, 0);
-
- /*luaopen_zip(L);*/
- lua_pushcfunction(L, luaopen_zip);
- lua_pushstring(L, "zip");
- lua_call(L, 1, 0);
-
- /*luaopen_lpeg(L);*/
- lua_pushcfunction(L, luaopen_lpeg);
- lua_pushstring(L, "lpeg");
- lua_call(L, 1, 0);
-
- /*luaopen_md5(L);*/
- lua_pushcfunction(L, luaopen_md5);
- lua_pushstring(L, "md5");
- lua_call(L, 1, 0);
-
- /*luaopen_lfs(L);*/
- lua_pushcfunction(L, luaopen_lfs);
- lua_pushstring(L, "lfs");
- lua_call(L, 1, 0);
-
- /* zlib. slightly odd calling convention */
- luaopen_zlib(L);
- lua_setglobal(L,"zlib");
- luaopen_gzip(L);
- /* fontforge */
- luaopen_ff(L);
-
- luaopen_pdf(L);
- luaopen_tex(L);
- luaopen_token(L);
- luaopen_node(L);
- luaopen_texio(L);
- luaopen_kpse(L);
- if (n==0) {
+void luainterpreter(void)
+{
+ lua_State *L;
+ L = lua_newstate(my_luaalloc, NULL);
+ if (L == NULL) {
+ fprintf(stderr, "Can't create the Lua state.\n");
+ return;
+ }
+ lua_atpanic(L, &my_luapanic);
+
+ luaL_openlibs(L);
+
+ open_oslibext(L, safer_option);
+
+ lua_getglobal(L, "package");
+ lua_pushstring(L, "");
+ lua_setfield(L, -2, "cpath");
+ lua_pop(L, 1); /* pop the table */
+
+ /*luaopen_unicode(L); */
+ lua_pushcfunction(L, luaopen_unicode);
+ lua_pushstring(L, "unicode");
+ lua_call(L, 1, 0);
+
+ /*luaopen_zip(L); */
+ lua_pushcfunction(L, luaopen_zip);
+ lua_pushstring(L, "zip");
+ lua_call(L, 1, 0);
+
+ /* luasockets */
+ /* socket and mime are a bit tricky to open because
+ * they use a load-time dependency that has to be
+ * worked around for luatex, where the C module is
+ * loaded way before the lua module.
+ */
+ if (!nosocket_option) {
+ lua_getglobal(L, "package");
+ lua_getfield(L, -1, "loaded");
+ if (!lua_istable(L, -1)) {
+ lua_newtable(L);
+ lua_setfield(L, -2, "loaded");
+ lua_getfield(L, -1, "loaded");
+ }
+ luaopen_socket_core(L);
+ lua_setfield(L, -2, "socket.core");
+ lua_pushnil(L);
+ lua_setfield(L, -2, "socket"); /* package.loaded.socket = nil */
+
+ luaopen_mime_core(L);
+ lua_setfield(L, -2, "mime.core");
+ lua_pushnil(L);
+ lua_setfield(L, -2, "mime"); /* package.loaded.mime = nil */
+ lua_pop(L, 2); /* pop the tables */
+
+ luatex_socketlua_open(L); /* preload the pure lua modules */
+ }
+
+ /*luaopen_lpeg(L); */
+ lua_pushcfunction(L, luaopen_lpeg);
+ lua_pushstring(L, "lpeg");
+ lua_call(L, 1, 0);
+
+ /*luaopen_md5(L); */
+ lua_pushcfunction(L, luaopen_md5);
+ lua_pushstring(L, "md5");
+ lua_call(L, 1, 0);
+
+ /*luaopen_lfs(L); */
+ lua_pushcfunction(L, luaopen_lfs);
+ lua_pushstring(L, "lfs");
+ lua_call(L, 1, 0);
+
+ /* zlib. slightly odd calling convention */
+ luaopen_zlib(L);
+ lua_setglobal(L, "zlib");
+ luaopen_gzip(L);
+ /* fontforge */
+ luaopen_ff(L);
+ /* profiler, from kepler */
+ luaopen_profiler(L);
+
+ luaopen_pdf(L);
+ luaopen_tex(L);
+ luaopen_token(L);
+ luaopen_node(L);
+ luaopen_texio(L);
+ luaopen_kpse(L);
+
luaopen_callback(L);
lua_createtable(L, 0, 0);
lua_setglobal(L, "texconfig");
- }
- luaopen_lua(L,n,startup_filename);
- luaopen_stats(L);
- luaopen_font(L);
- luaopen_lang(L);
-
- /* luaopen_img(L); */
- lua_pushcfunction(L, luaopen_img);
- lua_pushstring(L, "img");
- lua_call(L, 1, 0);
-
- luaopen_mp(L);
-
- if (safer_option) {
- /* disable some stuff if --safer */
- (void)hide_lua_value(L, "os","execute");
- (void)hide_lua_value(L, "os","rename");
- (void)hide_lua_value(L, "os","remove");
- (void)hide_lua_value(L, "io","popen");
- /* make io.open only read files */
- luaL_checkstack(L,2,"out of stack space");
- lua_getglobal(L,"io");
- lua_getfield(L,-1,"open_ro");
- lua_setfield(L,-2,"open");
- (void)hide_lua_value(L, "io","tmpfile");
- (void)hide_lua_value(L, "io","output");
- (void)hide_lua_value(L, "lfs","chdir");
- (void)hide_lua_value(L, "lfs","lock");
- (void)hide_lua_value(L, "lfs","touch");
- (void)hide_lua_value(L, "lfs","rmdir");
- (void)hide_lua_value(L, "lfs","mkdir");
- }
- Luas[n] = L;
+
+ luaopen_lua(L, startup_filename);
+ luaopen_stats(L);
+ luaopen_font(L);
+ luaopen_lang(L);
+
+ /* luaopen_img(L); */
+ lua_pushcfunction(L, luaopen_img);
+ lua_pushstring(L, "img");
+ lua_call(L, 1, 0);
+
+ luaopen_mplib(L);
+
+ if (safer_option) {
+ /* disable some stuff if --safer */
+ (void) hide_lua_value(L, "os", "execute");
+ (void) hide_lua_value(L, "os", "rename");
+ (void) hide_lua_value(L, "os", "remove");
+ (void) hide_lua_value(L, "io", "popen");
+ /* make io.open only read files */
+ luaL_checkstack(L, 2, "out of stack space");
+ lua_getglobal(L, "io");
+ lua_getfield(L, -1, "open_ro");
+ lua_setfield(L, -2, "open");
+ (void) hide_lua_value(L, "io", "tmpfile");
+ (void) hide_lua_value(L, "io", "output");
+ (void) hide_lua_value(L, "lfs", "chdir");
+ (void) hide_lua_value(L, "lfs", "lock");
+ (void) hide_lua_value(L, "lfs", "touch");
+ (void) hide_lua_value(L, "lfs", "rmdir");
+ (void) hide_lua_value(L, "lfs", "mkdir");
+ }
+ Luas = L;
+}
+
+int hide_lua_table(lua_State * L, char *name)
+{
+ int r = 0;
+ lua_getglobal(L, name);
+ if (lua_istable(L, -1)) {
+ r = luaL_ref(L, LUA_REGISTRYINDEX);
+ lua_pushnil(L);
+ lua_setglobal(L, name);
+ }
+ return r;
}
-int hide_lua_table(lua_State *L, char *name) {
- int r=0;
- lua_getglobal(L,name);
- if(lua_istable(L,-1)) {
- r = luaL_ref(L,LUA_REGISTRYINDEX);
- lua_pushnil(L);
- lua_setglobal(L,name);
- }
- return r;
+void unhide_lua_table(lua_State * L, char *name, int r)
+{
+ lua_rawgeti(L, LUA_REGISTRYINDEX, r);
+ lua_setglobal(L, name);
+ luaL_unref(L, LUA_REGISTRYINDEX, r);
}
-void unhide_lua_table(lua_State *L, char *name, int r) {
- lua_rawgeti(L,LUA_REGISTRYINDEX,r);
- lua_setglobal(L,name);
- luaL_unref(L,LUA_REGISTRYINDEX,r);
+int hide_lua_value(lua_State * L, char *name, char *item)
+{
+ int r = 0;
+ lua_getglobal(L, name);
+ if (lua_istable(L, -1)) {
+ lua_getfield(L, -1, item);
+ r = luaL_ref(L, LUA_REGISTRYINDEX);
+ lua_pushnil(L);
+ lua_setfield(L, -2, item);
+ }
+ return r;
}
-int hide_lua_value(lua_State *L, char *name, char *item) {
- int r=0;
- lua_getglobal(L,name);
- if(lua_istable(L,-1)) {
- lua_getfield(L,-1,item);
- r = luaL_ref(L,LUA_REGISTRYINDEX);
- lua_pushnil(L);
- lua_setfield(L,-2,item);
- }
- return r;
+void unhide_lua_value(lua_State * L, char *name, char *item, int r)
+{
+ lua_getglobal(L, name);
+ if (lua_istable(L, -1)) {
+ lua_rawgeti(L, LUA_REGISTRYINDEX, r);
+ lua_setfield(L, -2, item);
+ luaL_unref(L, LUA_REGISTRYINDEX, r);
+ }
}
-void unhide_lua_value(lua_State *L, char *name, char *item, int r) {
- lua_getglobal(L,name);
- if(lua_istable(L,-1)) {
- lua_rawgeti(L,LUA_REGISTRYINDEX,r);
- lua_setfield(L,-2,item);
- luaL_unref(L,LUA_REGISTRYINDEX,r);
- }
+
+int lua_traceback(lua_State * L)
+{
+ lua_getfield(L, LUA_GLOBALSINDEX, "debug");
+ if (!lua_istable(L, -1)) {
+ lua_pop(L, 1);
+ return 1;
+ }
+ lua_getfield(L, -1, "traceback");
+ if (!lua_isfunction(L, -1)) {
+ lua_pop(L, 2);
+ return 1;
+ }
+ lua_pushvalue(L, 1); /* pass error message */
+ lua_pushinteger(L, 2); /* skip this function and traceback */
+ lua_call(L, 2, 1); /* call debug.traceback */
+ return 1;
}
+void luacall(int p, int nameptr)
+{
+ LoadS ls;
+ int i, l;
+ char *lua_id;
+ char *s = NULL;
-void
-luacall(int n, int s) {
- LoadS ls;
- int i ;
- char lua_id[12];
- if (Luas[n] == NULL) {
- luainterpreter(n);
- }
- luatex_load_init(s,&ls);
- if (ls.size>0) {
- snprintf((char *)lua_id,12,"luas[%d]",n);
- i = lua_load(Luas[n], getS, &ls, lua_id);
- if (i != 0) {
- Luas[n] = luatex_error(Luas[n],(i == LUA_ERRSYNTAX ? 0 : 1));
- } else {
- i = lua_pcall(Luas[n], 0, 0, 0);
- if (i != 0) {
- Luas[n] = luatex_error(Luas[n],(i == LUA_ERRRUN ? 0 : 1));
- }
- }
- }
+ if (Luas == NULL) {
+ luainterpreter();
+ }
+ l = 0;
+ lua_active++;
+ s = tokenlist_to_cstring(p, 1, &l);
+ ls.s = s;
+ ls.size = l;
+
+ if (ls.size > 0) {
+ if (nameptr > 0) {
+ lua_id = tokenlist_to_cstring(nameptr, 1, &l);
+ } else if (nameptr<0) {
+ char *tmp = get_lua_name((nameptr+65536));
+ if (tmp!=NULL)
+ lua_id = xstrdup(tmp);
+ else
+ lua_id = xstrdup("\\latelua ");
+ } else {
+ lua_id = xmalloc(20);
+ snprintf((char *) lua_id, 20, "\\latelua ") ;
+ }
+
+ i = lua_load(Luas, getS, &ls, lua_id);
+ if (i != 0) {
+ Luas = luatex_error(Luas, (i == LUA_ERRSYNTAX ? 0 : 1));
+ } else {
+ int base = lua_gettop(Luas); /* function index */
+ lua_checkstack(Luas, 1);
+ lua_pushcfunction(Luas, lua_traceback); /* push traceback function */
+ lua_insert(Luas, base); /* put it under chunk */
+ i = lua_pcall(Luas, 0, 0, base);
+ lua_remove(Luas, base); /* remove traceback function */
+ if (i != 0) {
+ lua_gc(Luas, LUA_GCCOLLECT, 0);
+ Luas = luatex_error(Luas, (i == LUA_ERRRUN ? 0 : 1));
+ }
+ }
+ xfree(lua_id);
+ }
+ lua_active--;
}
-void
-luatokencall(int n, int p) {
- LoadS ls;
- int i, l;
- char *s=NULL;
- char lua_id[12];
- if (Luas[n] == NULL) {
- luainterpreter(n);
- }
- l = 0;
- s = tokenlist_to_cstring(p,1,&l);
- ls.s = s;
- ls.size = l;
- if (ls.size>0) {
- snprintf((char *)lua_id,12,"luas[%d]",n);
- i = lua_load(Luas[n], getS, &ls, lua_id);
- xfree(s);
- if (i != 0) {
- Luas[n] = luatex_error(Luas[n],(i == LUA_ERRSYNTAX ? 0 : 1));
- } else {
- i = lua_pcall(Luas[n], 0, 0, 0);
- if (i != 0) {
- Luas[n] = luatex_error(Luas[n],(i == LUA_ERRRUN ? 0 : 1));
- }
- }
- }
+void luatokencall(int p, int nameptr)
+{
+ LoadS ls;
+ int i, l;
+ char *s = NULL;
+ char *lua_id;
+ assert (Luas);
+ l = 0;
+ lua_active++;
+ s = tokenlist_to_cstring(p, 1, &l);
+ ls.s = s;
+ ls.size = l;
+ if (ls.size > 0) {
+ if (nameptr > 0) {
+ lua_id = tokenlist_to_cstring(nameptr, 1, &l);
+ } else if (nameptr<0) {
+ char *tmp = get_lua_name((nameptr+65536));
+ if (tmp!=NULL)
+ lua_id = xstrdup(tmp);
+ else
+ lua_id = xstrdup("\\directlua ");
+ } else {
+ lua_id = xstrdup("\\directlua ");
+ }
+ i = lua_load(Luas, getS, &ls, lua_id);
+ xfree(s);
+ if (i != 0) {
+ Luas = luatex_error(Luas, (i == LUA_ERRSYNTAX ? 0 : 1));
+ } else {
+ int base = lua_gettop(Luas); /* function index */
+ lua_checkstack(Luas, 1);
+ lua_pushcfunction(Luas, lua_traceback); /* push traceback function */
+ lua_insert(Luas, base); /* put it under chunk */
+ i = lua_pcall(Luas, 0, 0, base);
+ lua_remove(Luas, base); /* remove traceback function */
+ if (i != 0) {
+ lua_gc(Luas, LUA_GCCOLLECT, 0);
+ Luas = luatex_error(Luas, (i == LUA_ERRRUN ? 0 : 1));
+ }
+ }
+ xfree(lua_id);
+ }
+ lua_active--;
}
-void
-closelua(int n) {
- if (n!=0 && Luas[n] != NULL) {
- lua_close(Luas[n]);
- luastate_max--;
- Luas[n] = NULL;
- }
+void luatex_load_init(int s, LoadS * ls)
+{
+ ls->s = (const char *) &(str_pool[str_start[s]]);
+ ls->size = str_start[s + 1] - str_start[s];
}
-void
-luatex_load_init (int s, LoadS *ls) {
- ls->s = (const char *)&(str_pool[str_start[s]]);
- ls->size = str_start[s + 1] - str_start[s];
-}
+lua_State *luatex_error(lua_State * L, int is_fatal)
+{
-lua_State *
-luatex_error (lua_State * L, int is_fatal) {
-
- size_t len;
- char *err;
- strnumber s;
- const char *luaerr = lua_tolstring(L, -1,&len);
- err = (char *)xmalloc(len+1);
- len = snprintf(err,(len+1),"%s",luaerr);
- if (is_fatal>0) {
- /* Normally a memory error from lua.
- The pool may overflow during the maketexlstring(), but we
- are crashing anyway so we may as well abort on the pool size */
- s = maketexlstring(err, len);
- lua_fatal_error(s);
- /* never reached */
- xfree (err);
- lua_close(L);
- luastate_max--;
- return (lua_State *)NULL;
- } else {
- /* Here, the pool could be full already, but we can possibly escape from that
- * condition, since the lua chunk that caused the error is the current string.
- */
- s = str_ptr-0x200000;
- /* fprintf(stderr,"poolinfo: %d: %d,%d out of %d\n",s,pool_ptr,str_start[(s-1)],pool_size);*/
- pool_ptr = str_start[(s-1)];
- str_start[s] = pool_ptr;
- if (pool_ptr+len>=pool_size) {
- lua_norm_error(' ');
+ strnumber s;
+ const char *luaerr;
+ size_t len = 0;
+ char *err = NULL;
+ if (lua_isstring(L, -1)) {
+ luaerr = lua_tolstring(L, -1, &len);
+ err = (char *) xmalloc(len + 1);
+ len = snprintf(err, (len + 1), "%s", luaerr);
+ }
+ if (is_fatal > 0) {
+ /* Normally a memory error from lua.
+ The pool may overflow during the maketexlstring(), but we
+ are crashing anyway so we may as well abort on the pool size */
+ s = maketexlstring(err, len);
+ lua_fatal_error(s);
+ /* never reached */
+ xfree(err);
+ lua_close(L);
+ return (lua_State *) NULL;
} else {
- s = maketexlstring(err,len);
- lua_norm_error(s);
- flush_str(s);
+ s = maketexlstring(err, len);
+ lua_norm_error(s);
+ flush_str(s);
+ xfree(err);
+ return L;
}
- xfree (err);
- return L;
- }
}
-
diff --git a/Build/source/texk/web2c/luatexdir/lua/luatex.c b/Build/source/texk/web2c/luatexdir/lua/luatex.c
index 5172ca24292..24b928fba45 100644
--- a/Build/source/texk/web2c/luatexdir/lua/luatex.c
+++ b/Build/source/texk/web2c/luatexdir/lua/luatex.c
@@ -1,32 +1,53 @@
-/* $Id: luatex.c 1013 2008-02-14 00:09:02Z oneiros $ */
+/* luatex.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 General Public License as published by the Free
+ Software Foundation; either version 2 of the License, or (at your
+ option) any later version.
+
+ LuaTeX is distributed in the hope that it will be useful, but WITHOUT
+ ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
+ FITNESS FOR A PARTICULAR PURPOSE. See the GNU Lesser General Public
+ License for more details.
+
+ You should have received a copy of the GNU General Public License along
+ with LuaTeX; if not, see <http://www.gnu.org/licenses/>. */
#include "luatex-api.h"
#include <ptexlib.h>
#include <zlib.h>
+static const char _svn_version[] =
+ "$Id: luatex.c 2028 2009-03-14 18:50:21Z oneiros $ $URL: http://scm.foundry.supelec.fr/svn/luatex/trunk/src/texk/web2c/luatexdir/lua/luatex.c $";
+
/* do this aleph stuff here, for now */
-void
-b_test_in(void)
+extern int program_name_set; /* in lkpselib.c */
+
+void b_test_in(void)
{
- string fname = kpse_find_file ((char *)(nameoffile + 1),
- kpse_program_binary_format, true);
-
- if (fname) {
- libcfree(nameoffile);
- nameoffile = xmalloc(2+strlen(fname));
- namelength = strlen(fname);
- strcpy((char *)nameoffile+1, fname);
- }
- else {
- libcfree(nameoffile);
- nameoffile = xmalloc(2);
- namelength = 0;
- nameoffile[0] = 0;
- nameoffile[1] = 0;
+ if (program_name_set) {
+ string fname = kpse_find_file((char *) (nameoffile + 1),
+ kpse_program_binary_format, true);
+ if (fname) {
+ libcfree(nameoffile);
+ nameoffile = xmalloc(2 + strlen(fname));
+ namelength = strlen(fname);
+ strcpy((char *) nameoffile + 1, fname);
+ } else {
+ libcfree(nameoffile);
+ nameoffile = xmalloc(2);
+ namelength = 0;
+ nameoffile[0] = 0;
+ nameoffile[1] = 0;
+ }
}
}
-
+
int **ocp_tables;
static int ocp_entries = 0;
@@ -35,41 +56,39 @@ void
allocate_ocp_table P2C(int, ocp_number, int, ocp_size)
{
int i;
- if (ocp_entries==0) {
- ocp_tables = (int **) xmalloc(256*sizeof(int**));
- ocp_entries=256;
- } else if ((ocp_number==256)&&(ocp_entries==256)) {
- ocp_tables = xrealloc(ocp_tables, 65536);
- ocp_entries=65536;
+ if (ocp_entries == 0) {
+ ocp_tables = (int **) xmalloc(256 * sizeof(int **));
+ ocp_entries = 256;
+ } else if ((ocp_number == 256) && (ocp_entries == 256)) {
+ ocp_tables = xrealloc(ocp_tables, 65536);
+ ocp_entries = 65536;
}
- ocp_tables[ocp_number] =
- (int *) xmalloc((1+ocp_size)*sizeof(int));
+ ocp_tables[ocp_number] = (int *) xmalloc((1 + ocp_size) * sizeof(int));
ocp_tables[ocp_number][0] = ocp_size;
- for (i=1; i<=ocp_size; i++) {
- ocp_tables[ocp_number][i] = 0;
+ for (i = 1; i <= ocp_size; i++) {
+ ocp_tables[ocp_number][i] = 0;
}
}
void
dump_ocp_table P1C(int, ocp_number)
{
- dump_things(ocp_tables[ocp_number][0], ocp_tables[ocp_number][0]+1);
+ dump_things(ocp_tables[ocp_number][0], ocp_tables[ocp_number][0] + 1);
}
void
undump_ocp_table P1C(int, ocp_number)
{
int sizeword;
- if (ocp_entries==0) {
- ocp_tables = (int **) xmalloc(256*sizeof(int**));
- ocp_entries=256;
- } else if ((ocp_number==256)&&(ocp_entries==256)) {
- ocp_tables = xrealloc(ocp_tables, 65536);
- ocp_entries=65536;
+ if (ocp_entries == 0) {
+ ocp_tables = (int **) xmalloc(256 * sizeof(int **));
+ ocp_entries = 256;
+ } else if ((ocp_number == 256) && (ocp_entries == 256)) {
+ ocp_tables = xrealloc(ocp_tables, 65536);
+ ocp_entries = 65536;
}
- undump_things(sizeword,1);
- ocp_tables[ocp_number] =
- (int *) xmalloc((1+sizeword)*sizeof(int));
+ undump_things(sizeword, 1);
+ ocp_tables[ocp_number] = (int *) xmalloc((1 + sizeword) * sizeof(int));
ocp_tables[ocp_number][0] = sizeword;
undump_things(ocp_tables[ocp_number][1], sizeword);
}
@@ -78,141 +97,146 @@ undump_ocp_table P1C(int, ocp_number)
void
run_external_ocp P1C(string, external_ocp_name)
{
- char *in_file_name;
- char *out_file_name;
- FILE *in_file;
- FILE *out_file;
- char command_line[400];
- int i;
- unsigned c;
- int c_in;
+ char *in_file_name;
+ char *out_file_name;
+ FILE *in_file;
+ FILE *out_file;
+ int in_file_fd;
+ int out_file_fd;
+ char command_line[400];
+ int i;
+ unsigned c;
+ int c_in;
#ifdef WIN32
- char *tempenv;
-
-#define null_string(s) ((s == NULL) || (*s == '\0'))
-
- tempenv = getenv("TMPDIR");
- if (null_string(tempenv))
- tempenv = getenv("TEMP");
- if (null_string(tempenv))
- tempenv = getenv("TMP");
- if (null_string(tempenv))
- tempenv = "c:/tmp"; /* "/tmp" is not good if we are on a CD-ROM */
- in_file_name = concat(tempenv, "/__aleph__in__XXXXXX");
- mktemp(in_file_name);
+ char *tempenv;
+
+# define null_string(s) ((s == NULL) || (*s == '\0'))
+
+ tempenv = getenv("TMPDIR");
+ if (null_string(tempenv))
+ tempenv = getenv("TEMP");
+ if (null_string(tempenv))
+ tempenv = getenv("TMP");
+ if (null_string(tempenv))
+ tempenv = "c:/tmp"; /* "/tmp" is not good if we are on a CD-ROM */
+ in_file_name = concat(tempenv, "/__aleph__in__XXXXXX");
+ mktemp(in_file_name);
+ in_file = fopen(in_file_name, FOPEN_WBIN_MODE);
#else
- in_file_name = strdup("/tmp/__aleph__in__XXXXXX");
- mkstemp(in_file_name);
-#endif /* WIN32 */
-
- in_file = fopen(in_file_name, FOPEN_WBIN_MODE);
-
- for (i=1; i<=otp_input_end; i++) {
- c = otp_input_buf[i];
- if (c>0xffff) {
- fprintf(stderr, "Aleph does not currently support 31-bit chars\n");
- exit(1);
- }
- if (c>0x4000000) {
- fputc(0xfc | ((c>>30) & 0x1), in_file);
- fputc(0x80 | ((c>>24) & 0x3f), in_file);
- fputc(0x80 | ((c>>18) & 0x3f), in_file);
- fputc(0x80 | ((c>>12) & 0x3f), in_file);
- fputc(0x80 | ((c>>6) & 0x3f), in_file);
- fputc(0x80 | (c & 0x3f), in_file);
- } else if (c>0x200000) {
- fputc(0xf8 | ((c>>24) & 0x3), in_file);
- fputc(0x80 | ((c>>18) & 0x3f), in_file);
- fputc(0x80 | ((c>>12) & 0x3f), in_file);
- fputc(0x80 | ((c>>6) & 0x3f), in_file);
- fputc(0x80 | (c & 0x3f), in_file);
- } else if (c>0x10000) {
- fputc(0xf0 | ((c>>18) & 0x7), in_file);
- fputc(0x80 | ((c>>12) & 0x3f), in_file);
- fputc(0x80 | ((c>>6) & 0x3f), in_file);
- fputc(0x80 | (c & 0x3f), in_file);
- } else if (c>0x800) {
- fputc(0xe0 | ((c>>12) & 0xf), in_file);
- fputc(0x80 | ((c>>6) & 0x3f), in_file);
- fputc(0x80 | (c & 0x3f), in_file);
- } else if (c>0x80) {
- fputc(0xc0 | ((c>>6) & 0x1f), in_file);
- fputc(0x80 | (c & 0x3f), in_file);
- } else {
- fputc(c & 0x7f, in_file);
- }
- }
- fclose(in_file);
-
+ in_file_name = strdup("/tmp/__aleph__in__XXXXXX");
+ in_file_fd = mkstemp(in_file_name);
+ in_file = fdopen(in_file_fd, FOPEN_WBIN_MODE);
+#endif /* WIN32 */
+
+
+ for (i = 1; i <= otp_input_end; i++) {
+ c = otp_input_buf[i];
+ if (c > 0xffff) {
+ fprintf(stderr, "Aleph does not currently support 31-bit chars\n");
+ exit(1);
+ }
+ if (c > 0x4000000) {
+ fputc(0xfc | ((c >> 30) & 0x1), in_file);
+ fputc(0x80 | ((c >> 24) & 0x3f), in_file);
+ fputc(0x80 | ((c >> 18) & 0x3f), in_file);
+ fputc(0x80 | ((c >> 12) & 0x3f), in_file);
+ fputc(0x80 | ((c >> 6) & 0x3f), in_file);
+ fputc(0x80 | (c & 0x3f), in_file);
+ } else if (c > 0x200000) {
+ fputc(0xf8 | ((c >> 24) & 0x3), in_file);
+ fputc(0x80 | ((c >> 18) & 0x3f), in_file);
+ fputc(0x80 | ((c >> 12) & 0x3f), in_file);
+ fputc(0x80 | ((c >> 6) & 0x3f), in_file);
+ fputc(0x80 | (c & 0x3f), in_file);
+ } else if (c > 0x10000) {
+ fputc(0xf0 | ((c >> 18) & 0x7), in_file);
+ fputc(0x80 | ((c >> 12) & 0x3f), in_file);
+ fputc(0x80 | ((c >> 6) & 0x3f), in_file);
+ fputc(0x80 | (c & 0x3f), in_file);
+ } else if (c > 0x800) {
+ fputc(0xe0 | ((c >> 12) & 0xf), in_file);
+ fputc(0x80 | ((c >> 6) & 0x3f), in_file);
+ fputc(0x80 | (c & 0x3f), in_file);
+ } else if (c > 0x80) {
+ fputc(0xc0 | ((c >> 6) & 0x1f), in_file);
+ fputc(0x80 | (c & 0x3f), in_file);
+ } else {
+ fputc(c & 0x7f, in_file);
+ }
+ }
+ fclose(in_file);
+
#define advance_cin if ((c_in = fgetc(out_file)) == -1) { \
fprintf(stderr, "File contains bad char\n"); \
goto end_of_while; \
}
-
+
#ifdef WIN32
- out_file_name = concat(tempenv, "/__aleph__out__XXXXXX");
- mktemp(out_file_name);
+ out_file_name = concat(tempenv, "/__aleph__out__XXXXXX");
+ mktemp(out_file_name);
+ out_file = fopen(out_file_name, FOPEN_RBIN_MODE);
#else
- out_file_name = strdup("/tmp/__aleph__out__XXXXXX");
- mkstemp(out_file_name);
+ out_file_name = strdup("/tmp/__aleph__out__XXXXXX");
+ out_file_fd = mkstemp(out_file_name);
+ out_file = fdopen(out_file_fd, FOPEN_RBIN_MODE);
#endif
- sprintf(command_line, "%s <%s >%s\n",
- external_ocp_name+1, in_file_name, out_file_name);
- system(command_line);
- out_file = fopen(out_file_name, FOPEN_RBIN_MODE);
- otp_output_end = 0;
- otp_output_buf[otp_output_end] = 0;
- while ((c_in = fgetc(out_file)) != -1) {
- if (c_in>=0xfc) {
- c = (c_in & 0x1) << 30;
- {advance_cin}
- c |= (c_in & 0x3f) << 24;
- {advance_cin}
- c |= (c_in & 0x3f) << 18;
- {advance_cin}
- c |= (c_in & 0x3f) << 12;
- {advance_cin}
- c |= (c_in & 0x3f) << 6;
- {advance_cin}
- c |= c_in & 0x3f;
- } else if (c_in>=0xf8) {
- c = (c_in & 0x3) << 24;
- {advance_cin}
- c |= (c_in & 0x3f) << 18;
- {advance_cin}
- c |= (c_in & 0x3f) << 12;
- {advance_cin}
- c |= (c_in & 0x3f) << 6;
- {advance_cin}
- c |= c_in & 0x3f;
- } else if (c_in>=0xf0) {
- c = (c_in & 0x7) << 18;
- {advance_cin}
- c |= (c_in & 0x3f) << 12;
- {advance_cin}
- c |= (c_in & 0x3f) << 6;
- {advance_cin}
- c |= c_in & 0x3f;
- } else if (c_in>=0xe0) {
- c = (c_in & 0xf) << 12;
- {advance_cin}
- c |= (c_in & 0x3f) << 6;
- {advance_cin}
- c |= c_in & 0x3f;
- } else if (c_in>=0x80) {
- c = (c_in & 0x1f) << 6;
- {advance_cin}
- c |= c_in & 0x3f;
- } else {
- c = c_in & 0x7f;
- }
- otp_output_buf[++otp_output_end] = c;
- }
-
-end_of_while:
- remove(in_file_name);
- remove(out_file_name);
+ sprintf(command_line, "%s <%s >%s\n",
+ external_ocp_name + 1, in_file_name, out_file_name);
+ system(command_line);
+ otp_output_end = 0;
+ otp_output_buf[otp_output_end] = 0;
+ while ((c_in = fgetc(out_file)) != -1) {
+ if (c_in >= 0xfc) {
+ c = (c_in & 0x1) << 30;
+ advance_cin;
+ c |= (c_in & 0x3f) << 24;
+ advance_cin;
+ c |= (c_in & 0x3f) << 18;
+ advance_cin;
+ c |= (c_in & 0x3f) << 12;
+ advance_cin;
+ c |= (c_in & 0x3f) << 6;
+ advance_cin;
+ c |= c_in & 0x3f;
+ } else if (c_in >= 0xf8) {
+ c = (c_in & 0x3) << 24;
+ advance_cin;
+ c |= (c_in & 0x3f) << 18;
+ advance_cin;
+ c |= (c_in & 0x3f) << 12;
+ advance_cin;
+ c |= (c_in & 0x3f) << 6;
+ advance_cin;
+ c |= c_in & 0x3f;
+ } else if (c_in >= 0xf0) {
+ c = (c_in & 0x7) << 18;
+ advance_cin;
+ c |= (c_in & 0x3f) << 12;
+ advance_cin;
+ c |= (c_in & 0x3f) << 6;
+ advance_cin;
+ c |= c_in & 0x3f;
+ } else if (c_in >= 0xe0) {
+ c = (c_in & 0xf) << 12;
+ advance_cin;
+ c |= (c_in & 0x3f) << 6;
+ advance_cin;
+ c |= c_in & 0x3f;
+ } else if (c_in >= 0x80) {
+ c = (c_in & 0x1f) << 6;
+ advance_cin;
+ c |= c_in & 0x3f;
+ } else {
+ c = c_in & 0x7f;
+ }
+ otp_output_buf[++otp_output_end] = c;
+ }
+ fclose(out_file);
+
+ end_of_while:
+ remove(in_file_name);
+ remove(out_file_name);
}
/* Read and write dump files through zlib */
@@ -224,120 +248,116 @@ end_of_while:
static gzFile gz_fmtfile = NULL;
-void
-do_zdump (char *p, int item_size, int nitems, FILE *out_file)
+void do_zdump(char *p, int item_size, int nitems, FILE * out_file)
{
- int err;
- if (nitems==0)
- return;
- if (gzwrite (gz_fmtfile,(void *)p, item_size*nitems) != item_size*nitems)
- {
- fprintf (stderr, "! Could not write %d %d-byte item(s): %s.\n",
- nitems, item_size, gzerror(gz_fmtfile,&err));
- uexit (1);
+ int err;
+ if (nitems == 0)
+ return;
+ if (gzwrite(gz_fmtfile, (void *) p, item_size * nitems) !=
+ item_size * nitems) {
+ fprintf(stderr, "! Could not write %d %d-byte item(s): %s.\n", nitems,
+ item_size, gzerror(gz_fmtfile, &err));
+ uexit(1);
}
}
-void
-do_zundump (char *p, int item_size, int nitems, FILE *in_file)
+void do_zundump(char *p, int item_size, int nitems, FILE * in_file)
{
- int err;
- if (nitems==0)
- return;
- if (gzread (gz_fmtfile,(void *)p, item_size*nitems) <= 0)
- {
- fprintf (stderr, "Could not undump %d %d-byte item(s): %s.\n",
- nitems, item_size, gzerror(gz_fmtfile,&err));
- uexit (1);
- }
+ int err;
+ if (nitems == 0)
+ return;
+ if (gzread(gz_fmtfile, (void *) p, item_size * nitems) <= 0) {
+ fprintf(stderr, "Could not undump %d %d-byte item(s): %s.\n",
+ nitems, item_size, gzerror(gz_fmtfile, &err));
+ uexit(1);
+ }
}
#define COMPRESSION "R3"
-boolean
-zopen_w_input (FILE **f, int format, const_string fopen_mode) {
- int callbackid;
- int res;
- char *fnam;
- callbackid = callback_defined(find_format_file_callback);
- if (callbackid>0) {
- res = run_callback(callbackid,"S->S",(nameoffile+1),&fnam);
- if (res && fnam && strlen(fnam)>0) {
- xfree (nameoffile);
- nameoffile = xmalloc (strlen(fnam)+2);
- memcpy((nameoffile+1),fnam,strlen(fnam));
- *(nameoffile+strlen(fnam)+1)=0;
- *f = xfopen(fnam,fopen_mode);
- if (*f == NULL) {
- return 0;
- }
- } else {
- return 0;
- }
- } else {
- res = open_input(f,format,fopen_mode);
- }
- if (res) {
- gz_fmtfile = gzdopen(fileno(*f),"rb" COMPRESSION);
- }
- return res;
+boolean zopen_w_input(FILE ** f, int format, const_string fopen_mode)
+{
+ int callbackid;
+ int res;
+ char *fnam;
+ callbackid = callback_defined(find_format_file_callback);
+ if (callbackid > 0) {
+ res = run_callback(callbackid, "S->S", (nameoffile + 1), &fnam);
+ if (res && fnam && strlen(fnam) > 0) {
+ xfree(nameoffile);
+ nameoffile = xmalloc(strlen(fnam) + 2);
+ memcpy((nameoffile + 1), fnam, strlen(fnam));
+ *(nameoffile + strlen(fnam) + 1) = 0;
+ *f = xfopen(fnam, fopen_mode);
+ if (*f == NULL) {
+ return 0;
+ }
+ } else {
+ return 0;
+ }
+ } else {
+ res = open_input(f, format, fopen_mode);
+ }
+ if (res) {
+ gz_fmtfile = gzdopen(fileno(*f), "rb" COMPRESSION);
+ }
+ return res;
}
-boolean
-zopen_w_output (FILE **f, const_string fopen_mode) {
- int res = 1;
- if (luainit) {
- *f = fopen((nameoffile+1),fopen_mode);
- if (*f == NULL) {
- return 0;
+boolean zopen_w_output(FILE ** f, const_string fopen_mode)
+{
+ int res = 1;
+ if (luainit) {
+ *f = fopen((const_string) (nameoffile + 1), fopen_mode);
+ if (*f == NULL) {
+ return 0;
+ }
+ } else {
+ res = open_output(f, fopen_mode);
+ }
+ if (res) {
+ gz_fmtfile = gzdopen(fileno(*f), "wb" COMPRESSION);
}
- } else {
- res = open_output(f,fopen_mode);
- }
- if (res) {
- gz_fmtfile = gzdopen(fileno(*f),"wb" COMPRESSION);
- }
- return res;
+ return res;
}
-void
-zwclose (FILE *f) {
- gzclose(gz_fmtfile);
+void zwclose(FILE * f)
+{
+ gzclose(gz_fmtfile);
}
/* create the dvi or pdf file */
-int
-open_outfile(FILE **f, char *name, char *mode) {
- FILE *res;
- res = fopen(name,mode);
- if (res != NULL) {
- *f = res;
- return 1;
- }
- return 0;
+int open_outfile(FILE ** f, char *name, char *mode)
+{
+ FILE *res;
+ res = fopen(name, mode);
+ if (res != NULL) {
+ *f = res;
+ return 1;
+ }
+ return 0;
}
/* the caller sets tfm_buffer=NULL and tfm_size=0 */
-int
-readbinfile (FILE *f, unsigned char **tfm_buffer, integer *tfm_size) {
- void *buf;
- int size;
- if (fseek(f, 0, SEEK_END)==0) {
- size = ftell(f);
- if (size>0) {
- buf = xmalloc(size);
- if(fseek(f, 0, SEEK_SET)==0) {
- if(fread((void *)buf,size,1,f)==1) {
- *tfm_buffer=(unsigned char *)buf;
- *tfm_size=(integer)size;
- return 1;
- }
- }
- }
- } /* seek failed, or zero-sized file */
- return 0;
+int readbinfile(FILE * f, unsigned char **tfm_buffer, integer * tfm_size)
+{
+ void *buf;
+ int size;
+ if (fseek(f, 0, SEEK_END) == 0) {
+ size = ftell(f);
+ if (size > 0) {
+ buf = xmalloc(size);
+ if (fseek(f, 0, SEEK_SET) == 0) {
+ if (fread((void *) buf, size, 1, f) == 1) {
+ *tfm_buffer = (unsigned char *) buf;
+ *tfm_size = (integer) size;
+ return 1;
+ }
+ }
+ }
+ } /* seek failed, or zero-sized file */
+ return 0;
}
-
diff --git a/Build/source/texk/web2c/luatexdir/lua/luatoken.c b/Build/source/texk/web2c/luatexdir/lua/luatoken.c
index 5f823104d56..4182d94e6fe 100644
--- a/Build/source/texk/web2c/luatexdir/lua/luatoken.c
+++ b/Build/source/texk/web2c/luatexdir/lua/luatoken.c
@@ -1,548 +1,600 @@
-/* $Id: luatoken.c 1168 2008-04-15 13:43:34Z taco $ */
+/* luatoken.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 General Public License as published by the Free
+ Software Foundation; either version 2 of the License, or (at your
+ option) any later version.
+
+ LuaTeX is distributed in the hope that it will be useful, but WITHOUT
+ ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
+ FITNESS FOR A PARTICULAR PURPOSE. See the GNU Lesser General Public
+ License for more details.
+
+ You should have received a copy of the GNU General Public License along
+ with LuaTeX; if not, see <http://www.gnu.org/licenses/>. */
#include "luatex-api.h"
#include <ptexlib.h>
#include "tokens.h"
+#include "commands.h"
-command_item command_names[] =
- { { "relax", 0, NULL },
- { "left_brace", 0 , NULL },
- { "right_brace", 0 , NULL },
- { "math_shift", 0 , NULL },
- { "tab_mark", 0 , NULL },
- { "car_ret", 0 , NULL },
- { "mac_param", 0 , NULL },
- { "sup_mark", 0 , NULL },
- { "sub_mark", 0 , NULL },
- { "endv", 0 , NULL },
- { "spacer", 0 , NULL },
- { "letter", 0 , NULL },
- { "other_char", 0 , NULL },
- { "par_end", 0 , NULL },
- { "stop", 0 , NULL },
- { "delim_num", 0 , NULL },
- { "char_num", 0 , NULL },
- { "math_char_num", 0 , NULL },
- { "mark", 0 , NULL },
- { "xray", 0 , NULL },
- { "make_box", 0 , NULL },
- { "hmove", 0 , NULL },
- { "vmove", 0 , NULL },
- { "un_hbox", 0 , NULL },
- { "un_vbox", 0 , NULL },
- { "remove_item", 0 , NULL },
- { "hskip", 0 , NULL },
- { "vskip", 0 , NULL },
- { "mskip", 0 , NULL },
- { "kern", 0 , NULL },
- { "mkern", 0 , NULL },
- { "leader_ship", 0 , NULL },
- { "halign", 0 , NULL },
- { "valign", 0 , NULL },
- { "no_align", 0 , NULL },
- { "vrule", 0 , NULL },
- { "hrule", 0 , NULL },
- { "insert", 0 , NULL },
- { "vadjust", 0 , NULL },
- { "ignore_spaces", 0 , NULL },
- { "after_assignment", 0 , NULL },
- { "after_group", 0 , NULL },
- { "break_penalty", 0 , NULL },
- { "start_par", 0 , NULL },
- { "ital_corr", 0 , NULL },
- { "accent", 0 , NULL },
- { "math_accent", 0 , NULL },
- { "discretionary", 0 , NULL },
- { "eq_no", 0 , NULL },
- { "left_right", 0 , NULL },
- { "math_comp", 0 , NULL },
- { "limit_switch", 0 , NULL },
- { "above", 0 , NULL },
- { "math_style", 0 , NULL },
- { "math_choice", 0 , NULL },
- { "non_script", 0 , NULL },
- { "vcenter", 0 , NULL },
- { "case_shift", 0 , NULL },
- { "message", 0 , NULL },
- { "extension", 0 , NULL },
- { "in_stream", 0 , NULL },
- { "begin_group", 0 , NULL },
- { "end_group", 0 , NULL },
- { "omit", 0 , NULL },
- { "ex_space", 0 , NULL },
- { "no_boundary", 0 , NULL },
- { "radical", 0 , NULL },
- { "end_cs_name", 0 , NULL },
- { "char_ghost", 0 , NULL },
- { "assign_local_box", 0 , NULL },
- { "char_given", 0 , NULL },
- { "math_given", 0 , NULL },
- { "omath_given", 0 , NULL },
- { "last_item", 0 , NULL },
- { "toks_register", 0 , NULL },
- { "assign_toks", 0, NULL },
- { "assign_int", 0, NULL },
- { "assign_dimen", 0 , NULL },
- { "assign_glue", 0 ,NULL },
- { "assign_mu_glue", 0 , NULL },
- { "assign_font_dimen", 0 , NULL },
- { "assign_font_int", 0 , NULL },
- { "set_aux", 0 , NULL },
- { "set_prev_graf", 0 , NULL },
- { "set_page_dimen", 0 , NULL },
- { "set_page_int", 0 , NULL },
- { "set_box_dimen", 0 , NULL },
- { "set_shape", 0, NULL },
- { "def_code", 0 , NULL },
- { "extdef_code", 0 , NULL },
- { "def_family", 0 , NULL },
- { "set_font", 0 , NULL },
- { "def_font", 0 , NULL },
- { "register", 0 , NULL },
- { "assign_box_dir", 0 , NULL },
- { "assign_dir", 0 , NULL },
- { "advance", 0 , NULL },
- { "multiply", 0 , NULL },
- { "divide", 0 , NULL },
- { "prefix", 0 , NULL },
- { "let", 0 , NULL }, /* 100 */
- { "shorthand_def", 0 , NULL },
- { "read_to_cs", 0 , NULL },
- { "def", 0 , NULL },
- { "set_box", 0 , NULL },
- { "hyph_data", 0 , NULL },
- { "set_interaction", 0 , NULL },
- { "letterspace_font", 0 , NULL },
- { "set_ocp", 0 , NULL },
- { "def_ocp", 0 , NULL },
- { "set_ocp_list", 0 , NULL }, /* 110 */
- { "def_ocp_list", 0 , NULL },
- { "clear_ocp_lists", 0 , NULL },
- { "push_ocp_list", 0 , NULL },
- { "pop_ocp_list", 0 , NULL },
- { "ocp_list_op", 0 , NULL },
- { "ocp_trace_level", 0 , NULL},
- { "undefined_cs", 0 , NULL },
- { "expand_after", 0 , NULL },
- { "no_expand", 0 , NULL },
- { "input", 0 , NULL }, /* 120 */
- { "if_test", 0 , NULL },
- { "fi_or_else", 0 , NULL },
- { "cs_name", 0 , NULL },
- { "convert", 0 , NULL },
- { "the", 0 , NULL },
- { "top_bot_mark", 0 , NULL },
- { "call", 0 , NULL },
- { "long_call", 0 , NULL },
- { "outer_call", 0 , NULL },
- { "long_outer_call", 0 , NULL }, /* 130 */
- { "end_template", 0 , NULL },
- { "dont_expand", 0, NULL },
- { "glue_ref", 0 , NULL },
- { "shape_ref", 0 , NULL },
- { "box_ref", 0 , NULL },
- { "data", 0 , NULL },
- { NULL, 0, NULL } };
-
-
-int get_command_id (char *s) {
- int i;
- int cmd = -1;
- for (i=0;command_names[i].cmd_name != NULL;i++) {
- if (strcmp(s,command_names[i].cmd_name) == 0)
- break;
- }
- if (command_names[i].cmd_name!=NULL) {
- cmd = i;
- }
- return cmd;
+static const char _svn_version[] =
+ "$Id: luatoken.c 2079 2009-03-22 10:15:03Z taco $ $URL: http://scm.foundry.supelec.fr/svn/luatex/trunk/src/texk/web2c/luatexdir/lua/luatoken.c $";
+
+command_item command_names[] = {
+ {"relax", relax_cmd, NULL},
+ {"left_brace", left_brace_cmd, NULL},
+ {"right_brace", right_brace_cmd, NULL},
+ {"math_shift", math_shift_cmd, NULL},
+ {"tab_mark", tab_mark_cmd, NULL},
+ {"car_ret", car_ret_cmd, NULL},
+ {"mac_param", mac_param_cmd, NULL},
+ {"sup_mark", sup_mark_cmd, NULL},
+ {"sub_mark", sub_mark_cmd, NULL},
+ {"endv", endv_cmd, NULL},
+ {"spacer", spacer_cmd, NULL},
+ {"letter", letter_cmd, NULL},
+ {"other_char", other_char_cmd, NULL},
+ {"par_end", par_end_cmd, NULL},
+ {"stop", stop_cmd, NULL},
+ {"delim_num", delim_num_cmd, NULL},
+ {"char_num", char_num_cmd, NULL},
+ {"math_char_num", math_char_num_cmd, NULL},
+ {"mark", mark_cmd, NULL},
+ {"xray", xray_cmd, NULL},
+ {"make_box", make_box_cmd, NULL},
+ {"hmove", hmove_cmd, NULL},
+ {"vmove", vmove_cmd, NULL},
+ {"un_hbox", un_hbox_cmd, NULL},
+ {"un_vbox", un_vbox_cmd, NULL},
+ {"remove_item", remove_item_cmd, NULL},
+ {"hskip", hskip_cmd, NULL},
+ {"vskip", vskip_cmd, NULL},
+ {"mskip", mskip_cmd, NULL},
+ {"kern", kern_cmd, NULL},
+ {"mkern", mkern_cmd, NULL},
+ {"leader_ship", leader_ship_cmd, NULL},
+ {"halign", halign_cmd, NULL},
+ {"valign", valign_cmd, NULL},
+ {"no_align", no_align_cmd, NULL},
+ {"vrule", vrule_cmd, NULL},
+ {"hrule", hrule_cmd, NULL},
+ {"insert", insert_cmd, NULL},
+ {"vadjust", vadjust_cmd, NULL},
+ {"ignore_spaces", ignore_spaces_cmd, NULL},
+ {"after_assignment", after_assignment_cmd, NULL},
+ {"after_group", after_group_cmd, NULL},
+ {"break_penalty", break_penalty_cmd, NULL},
+ {"start_par", start_par_cmd, NULL},
+ {"ital_corr", ital_corr_cmd, NULL},
+ {"accent", accent_cmd, NULL},
+ {"math_accent", math_accent_cmd, NULL},
+ {"discretionary", discretionary_cmd, NULL},
+ {"eq_no", eq_no_cmd, NULL},
+ {"left_right", left_right_cmd, NULL},
+ {"math_comp", math_comp_cmd, NULL},
+ {"limit_switch", limit_switch_cmd, NULL},
+ {"above", above_cmd, NULL},
+ {"math_style", math_style_cmd, NULL},
+ {"math_choice", math_choice_cmd, NULL},
+ {"non_script", non_script_cmd, NULL},
+ {"vcenter", vcenter_cmd, NULL},
+ {"case_shift", case_shift_cmd, NULL},
+ {"message", message_cmd, NULL},
+ {"extension", extension_cmd, NULL},
+ {"in_stream", in_stream_cmd, NULL},
+ {"begin_group", begin_group_cmd, NULL},
+ {"end_group", end_group_cmd, NULL},
+ {"omit", omit_cmd, NULL},
+ {"ex_space", ex_space_cmd, NULL},
+ {"no_boundary", no_boundary_cmd, NULL},
+ {"radical", radical_cmd, NULL},
+ {"end_cs_name", end_cs_name_cmd, NULL},
+ {"char_ghost", char_ghost_cmd, NULL},
+ {"assign_local_box", assign_local_box_cmd, NULL},
+ {"char_given", char_given_cmd, NULL},
+ {"math_given", math_given_cmd, NULL},
+ {"omath_given", omath_given_cmd, NULL},
+ {"xmath_given", xmath_given_cmd, NULL},
+ {"last_item", last_item_cmd, NULL},
+ {"toks_register", toks_register_cmd, NULL},
+ {"assign_toks", assign_toks_cmd, NULL},
+ {"assign_int", assign_int_cmd, NULL},
+ {"assign_attr", assign_attr_cmd, NULL},
+ {"assign_dimen", assign_dimen_cmd, NULL},
+ {"assign_glue", assign_glue_cmd, NULL},
+ {"assign_mu_glue", assign_mu_glue_cmd, NULL},
+ {"assign_font_dimen", assign_font_dimen_cmd, NULL},
+ {"assign_font_int", assign_font_int_cmd, NULL},
+ {"set_aux", set_aux_cmd, NULL},
+ {"set_prev_graf", set_prev_graf_cmd, NULL},
+ {"set_page_dimen", set_page_dimen_cmd, NULL},
+ {"set_page_int", set_page_int_cmd, NULL},
+ {"set_box_dimen", set_box_dimen_cmd, NULL},
+ {"set_tex_shape", set_tex_shape_cmd, NULL},
+ {"set_etex_shape", set_etex_shape_cmd, NULL},
+ {"def_char_code", def_char_code_cmd, NULL},
+ {"def_del_code", def_del_code_cmd, NULL},
+ {"extdef_math_code", extdef_math_code_cmd, NULL},
+ {"extdef_del_code", extdef_del_code_cmd, NULL},
+ {"def_family", def_family_cmd, NULL},
+ {"set_math_param", set_math_param_cmd, NULL},
+ {"set_font", set_font_cmd, NULL},
+ {"def_font", def_font_cmd, NULL},
+ {"register", register_cmd, NULL},
+ {"assign_box_dir", assign_box_dir_cmd, NULL},
+ {"assign_dir", assign_dir_cmd, NULL},
+ {"advance", advance_cmd, NULL},
+ {"multiply", multiply_cmd, NULL},
+ {"divide", divide_cmd, NULL},
+ {"prefix", prefix_cmd, NULL},
+ {"let", let_cmd, NULL},
+ {"shorthand_def", shorthand_def_cmd, NULL},
+ {"read_to_cs", read_to_cs_cmd, NULL},
+ {"def", def_cmd, NULL},
+ {"set_box", set_box_cmd, NULL},
+ {"hyph_data", hyph_data_cmd, NULL},
+ {"set_interaction", set_interaction_cmd, NULL},
+ {"letterspace_font", letterspace_font_cmd, NULL},
+ {"pdf_copy_font", pdf_copy_font_cmd, NULL},
+ {"set_ocp", set_ocp_cmd, NULL},
+ {"def_ocp", def_ocp_cmd, NULL},
+ {"set_ocp_list", set_ocp_list_cmd, NULL},
+ {"def_ocp_list", def_ocp_list_cmd, NULL},
+ {"clear_ocp_lists", clear_ocp_lists_cmd, NULL},
+ {"push_ocp_list", push_ocp_list_cmd, NULL},
+ {"pop_ocp_list", pop_ocp_list_cmd, NULL},
+ {"ocp_list_op", ocp_list_op_cmd, NULL},
+ {"ocp_trace_level", ocp_trace_level_cmd, NULL},
+ {"undefined_cs", undefined_cs_cmd, NULL},
+ {"expand_after", expand_after_cmd, NULL},
+ {"no_expand", no_expand_cmd, NULL},
+ {"input", input_cmd, NULL},
+ {"if_test", if_test_cmd, NULL},
+ {"fi_or_else", fi_or_else_cmd, NULL},
+ {"cs_name", cs_name_cmd, NULL},
+ {"convert", convert_cmd, NULL},
+ {"the", the_cmd, NULL},
+ {"top_bot_mark", top_bot_mark_cmd, NULL},
+ {"call", call_cmd, NULL},
+ {"long_call", long_call_cmd, NULL},
+ {"outer_call", outer_call_cmd, NULL},
+ {"long_outer_call", long_outer_call_cmd, NULL},
+ {"end_template", end_template_cmd, NULL},
+ {"dont_expand", dont_expand_cmd, NULL},
+ {"glue_ref", glue_ref_cmd, NULL},
+ {"shape_ref", shape_ref_cmd, NULL},
+ {"box_ref", box_ref_cmd, NULL},
+ {"data", data_cmd, NULL},
+ {NULL, 0, NULL}
+};
+
+
+int get_command_id(char *s)
+{
+ int i;
+ int cmd = -1;
+ for (i = 0; command_names[i].cmd_name != NULL; i++) {
+ if (strcmp(s, command_names[i].cmd_name) == 0)
+ break;
+ }
+ if (command_names[i].cmd_name != NULL) {
+ cmd = i;
+ }
+ return cmd;
}
-static int
-get_cur_cmd (lua_State *L) {
- int r = 0, len;
- cur_cs = 0;
- len = lua_objlen(L,-1);
- if (len==3 || len==2) {
- r = 1;
- lua_rawgeti(L,-1,1);
- cur_cmd = lua_tointeger(L,-1);
- lua_rawgeti(L,-2,2);
- cur_chr = lua_tointeger(L,-1);
- if (len==3) {
- lua_rawgeti(L,-3,3);
- cur_cs = lua_tointeger(L,-1);
- }
- lua_pop(L,len);
- if (cur_cs==0)
- cur_tok=(cur_cmd*string_offset)+cur_chr;
- else
- cur_tok=cs_token_flag+cur_cs;
- }
- return r;
+static int get_cur_cmd(lua_State * L)
+{
+ int r = 0;
+ int len = lua_objlen(L, -1);
+ cur_cs = 0;
+ if (len == 3 || len == 2) {
+ r = 1;
+ lua_rawgeti(L, -1, 1);
+ cur_cmd = lua_tointeger(L, -1);
+ lua_rawgeti(L, -2, 2);
+ cur_chr = lua_tointeger(L, -1);
+ if (len == 3) {
+ lua_rawgeti(L, -3, 3);
+ cur_cs = lua_tointeger(L, -1);
+ }
+ lua_pop(L, len);
+ if (cur_cs == 0)
+ cur_tok = (cur_cmd * string_offset) + cur_chr;
+ else
+ cur_tok = cs_token_flag + cur_cs;
+ }
+ return r;
}
-static int
-token_from_lua (lua_State *L) {
- int cmd,chr;
- int cs = 0;
- int len = lua_objlen(L,-1);
- if (len==3 || len==2) {
- lua_rawgeti(L,-1,1);
- cmd = lua_tointeger(L,-1);
- lua_rawgeti(L,-2,2);
- chr = lua_tointeger(L,-1);
- if (len==3) {
- lua_rawgeti(L,-3,3);
- cs = lua_tointeger(L,-1);
- }
- lua_pop(L,len);
- if (cs==0) {
- return (cmd*string_offset)+chr;
- } else {
- return cs_token_flag+cs;
+static int token_from_lua(lua_State * L)
+{
+ int cmd, chr;
+ int cs = 0;
+ int len = lua_objlen(L, -1);
+ if (len == 3 || len == 2) {
+ lua_rawgeti(L, -1, 1);
+ cmd = lua_tointeger(L, -1);
+ lua_rawgeti(L, -2, 2);
+ chr = lua_tointeger(L, -1);
+ if (len == 3) {
+ lua_rawgeti(L, -3, 3);
+ cs = lua_tointeger(L, -1);
+ }
+ lua_pop(L, len);
+ if (cs == 0) {
+ return (cmd * string_offset) + chr;
+ } else {
+ return cs_token_flag + cs;
+ }
}
- }
- return -1;
+ return -1;
}
-static int
-get_cur_cs (lua_State *L) {
- char *s;
- unsigned j;
- size_t l;
- integer cs;
- int save_nncs;
- int ret;
- ret = 0;
- cur_cs = 0;
- lua_getfield(L,-1,"name");
- if (lua_isstring(L,-1)) {
- s = (char *)lua_tolstring(L,-1,&l);
- if (l>0) {
- if ((int)(last+l)>buf_size)
- check_buffer_overflow(last+l);
- for (j=0;j<l;j++) {
- buffer[last+1+j]=*s++;
- }
- save_nncs = no_new_control_sequence;
- no_new_control_sequence = false;
- cs = id_lookup((last+1),l);
- cur_tok = cs_token_flag+cs;
- cur_cmd = zget_eq_type(cs);
- cur_chr = zget_equiv(cs);
- no_new_control_sequence = save_nncs;
- ret = 1;
+static int get_cur_cs(lua_State * L)
+{
+ char *s;
+ unsigned j;
+ size_t l;
+ integer cs;
+ int save_nncs;
+ int ret;
+ ret = 0;
+ cur_cs = 0;
+ lua_getfield(L, -1, "name");
+ if (lua_isstring(L, -1)) {
+ s = (char *) lua_tolstring(L, -1, &l);
+ if (l > 0) {
+ if ((int) (last + l) > buf_size)
+ check_buffer_overflow(last + l);
+ for (j = 0; j < l; j++) {
+ buffer[last + 1 + j] = *s++;
+ }
+ save_nncs = no_new_control_sequence;
+ no_new_control_sequence = false;
+ cs = id_lookup((last + 1), l);
+ cur_tok = cs_token_flag + cs;
+ cur_cmd = zget_eq_type(cs);
+ cur_chr = zget_equiv(cs);
+ no_new_control_sequence = save_nncs;
+ ret = 1;
+ }
}
- }
- lua_pop(L,1);
- return ret;
+ lua_pop(L, 1);
+ return ret;
}
-#define append_i_byte(a) { \
- if ((i+2)>alloci) { \
- ret = xrealloc(ret,alloci+64); \
- alloci = alloci + 64; } \
- ret[i++] = a; }
-
-#define Print_char(a) append_i_byte(a)
-
-#define Print_uchar(s) { \
- if (s<=0x7F) { \
- Print_char(s); \
- } else if (s<=0x7FF) { \
- Print_char(0xC0 + (s / 0x40)); \
- Print_char(0x80 + (s % 0x40)); \
- } else if (s<=0xFFFF) { \
- Print_char(0xE0 + (s / 0x1000)); \
- Print_char(0x80 + ((s % 0x1000) / 0x40)); \
- Print_char(0x80 + ((s % 0x1000) % 0x40)); \
- } else if (s>=0x10FF00) { \
- Print_char(s-0x10FF00); \
- } else { \
- Print_char(0xF0 + (s / 0x40000)); \
- Print_char(0x80 + ((s % 0x40000) / 0x1000)); \
- Print_char(0x80 + (((s % 0x40000) % 0x1000) / 0x40)); \
- Print_char(0x80 + (((s % 0x40000) % 0x1000) % 0x40)); \
- } }
-
-
-#define Print_esc(b) { if (e>0 && e<string_offset) { Print_uchar (e); Print_uchar (e); } \
- { char *v = b; while (*v) { Print_char(*v); v++; } } }
-
-#define single_letter(a) (length(a)==1)|| \
- ((length(a)==4)&&(str_pool[str_start_macro(a)]>=0xF0))|| \
- ((length(a)==3)&&(str_pool[str_start_macro(a)]>=0xE0))|| \
+#define make_room(a) \
+ if ((i+a+1)>alloci) { \
+ ret = xrealloc(ret,alloci+64); \
+ alloci = alloci + 64; \
+ }
+
+
+#define append_i_byte(a) ret[i++] = a
+
+#define Print_char(a) make_room(1); append_i_byte(a)
+
+#define Print_uchar(s) { \
+ make_room(4); \
+ if (s<=0x7F) { \
+ append_i_byte(s); \
+ } else if (s<=0x7FF) { \
+ append_i_byte(0xC0 + (s / 0x40)); \
+ append_i_byte(0x80 + (s % 0x40)); \
+ } else if (s<=0xFFFF) { \
+ append_i_byte(0xE0 + (s / 0x1000)); \
+ append_i_byte(0x80 + ((s % 0x1000) / 0x40)); \
+ append_i_byte(0x80 + ((s % 0x1000) % 0x40)); \
+ } else if (s>=0x110000) { \
+ append_i_byte(s-0x11000); \
+ } else { \
+ append_i_byte(0xF0 + (s / 0x40000)); \
+ append_i_byte(0x80 + ((s % 0x40000) / 0x1000)); \
+ append_i_byte(0x80 + (((s % 0x40000) % 0x1000) / 0x40)); \
+ append_i_byte(0x80 + (((s % 0x40000) % 0x1000) % 0x40)); \
+ } }
+
+
+#define Print_esc(b) { \
+ char *v = b; \
+ if (e>0 && e<string_offset) { \
+ Print_uchar (e); Print_uchar (e); \
+ } \
+ while (*v) { Print_char(*v); v++; } \
+ }
+
+#define single_letter(a) (length(a)==1)|| \
+ ((length(a)==4)&&(str_pool[str_start_macro(a)]>=0xF0))|| \
+ ((length(a)==3)&&(str_pool[str_start_macro(a)]>=0xE0))|| \
((length(a)==2)&&(str_pool[str_start_macro(a)]>=0xC0))
-#define is_cat_letter(a) \
+#define is_active_cs(a) (length(a)>3 && \
+ (str_pool[str_start_macro(a)] == 0xEF) && \
+ (str_pool[str_start_macro(a)+1] == 0xBF) && \
+ (str_pool[str_start_macro(a)+2] == 0xBF))
+
+#define is_cat_letter(a) \
(get_char_cat_code(pool_to_unichar(str_start_macro(a))) == 11)
-static int active_base = 0;
-static int hash_base = 0;
-static int eqtb_size = 0;
static int null_cs = 0;
-static int undefined_control_sequence;
-
-char *
-tokenlist_to_cstring ( int p , int inhibit_par, int *siz) {
- integer m, c ;
- integer q;
- char *s;
- int e;
- char *ret=NULL;
- int match_chr = '#';
- int n = '0';
- int alloci = 0;
- int i = 0;
- if (p==null || link(p)==null) {
- if (siz!=NULL)
- *siz = 0;
- return NULL;
- }
- p = link(p); /* skip refcount */
- if (active_base==0) {
- active_base = get_active_base();
- hash_base = get_hash_base();
- null_cs = get_nullcs();
- eqtb_size = get_eqtb_size();
- undefined_control_sequence = get_undefined_control_sequence();
- }
- e = get_escape_char();
- while ( p != null ) {
- if (p < fix_mem_min || p > fix_mem_end ) {
- Print_esc ("CLOBBERED.") ;
- break;
- }
- if (info(p)>=cs_token_flag) {
- if ( ! (inhibit_par && info(p)==par_token) ) {
- q = info(p) - cs_token_flag;
- if (q<hash_base) {
- if (q==null_cs) {
- /* Print_esc("csname"); Print_esc("endcsname"); */
- } else {
- if (q<active_base) {
- Print_esc("IMPOSSIBLE.");
- } else {
- Print_uchar(q-active_base);
- }
- }
- } else if ((q>=undefined_control_sequence)&&((q<=eqtb_size)||(q>eqtb_size+hash_extra))) {
- Print_esc("IMPOSSIBLE.");
- } else if ((zget_cs_text(q)<0)||(zget_cs_text(q)>=str_ptr)) {
- Print_esc("NONEXISTENT.");
- } else {
- Print_uchar (e);
- s = makecstring(zget_cs_text(q));
- while (*s) { Print_char(*s); s++; }
- if ((! single_letter(zget_cs_text(q))) || is_cat_letter(zget_cs_text(q))) {
- Print_char(' ');
- }
- }
- }
- } else {
- m=info(p) / string_offset;
- c=info(p) % string_offset;
- if ( info(p) < 0 ) {
- Print_esc ( "BAD.") ;
- } else {
- switch ( m ) {
- case 6 : /* falls through */
- Print_uchar ( c ) ;
- case 1 :
- case 2 :
- case 3 :
- case 4 :
- case 7 :
- case 8 :
- case 10 :
- case 11 :
- case 12 :
- Print_uchar ( c ) ;
- break ;
- case 5 :
- Print_uchar ( match_chr ) ;
- if ( c <= 9 ) {
- Print_char ( c + '0') ;
- } else {
- Print_char ( '!' ) ;
- return NULL;
- }
- break ;
- case 13 :
- match_chr = c ;
- Print_uchar ( c ) ;
- incr ( n ) ;
- Print_char ( n ) ;
- if ( n > '9' )
- return NULL;
- break ;
- case 14 :
- if ( c == 0 ) {
- Print_char ('-');
- Print_char ('>') ;
- }
- break ;
- default:
- Print_esc ( "BAD.") ;
- break ;
- }
- }
- }
- p = link(p);
- }
- ret[i]=0;
- if (siz!=NULL)
- *siz = i;
- return ret;
+static int eqtb_size = 0;
+
+/* 2,720,652 */
+char *tokenlist_to_cstring(int pp, int inhibit_par, int *siz)
+{
+ register integer p, c, m;
+ integer q;
+ integer infop;
+ char *s;
+ int e;
+ char *ret;
+ int match_chr = '#';
+ int n = '0';
+ int alloci = 1024;
+ int i = 0;
+ p = pp;
+ if (p == null || link(p) == null) {
+ if (siz != NULL)
+ *siz = 0;
+ return NULL;
+ }
+ ret = xmalloc(alloci);
+ p = link(p); /* skip refcount */
+ if (null_cs == 0) {
+ null_cs = get_nullcs();
+ eqtb_size = get_eqtb_size();
+ }
+ e = get_escape_char();
+ while (p != null) {
+ if (p < fix_mem_min || p > fix_mem_end) {
+ Print_esc("CLOBBERED.");
+ break;
+ }
+ infop = info(p);
+ if (infop >= cs_token_flag) {
+ if (!(inhibit_par && infop == par_token)) {
+ q = infop - cs_token_flag;
+ if (q < hash_base) {
+ if (q == null_cs) {
+ /* Print_esc("csname"); Print_esc("endcsname"); */
+ }
+ } else if ((q >= static_undefined_control_sequence)
+ && ((q <= eqtb_size)
+ || (q > eqtb_size + hash_extra))) {
+ Print_esc("IMPOSSIBLE.");
+ } else if ((zget_cs_text(q) < 0)
+ || (zget_cs_text(q) >= str_ptr)) {
+ Print_esc("NONEXISTENT.");
+ } else {
+ str_number txt = zget_cs_text(q);
+ s = makecstring(txt);
+ if (is_active_cs(txt)) {
+ s = s + 3;
+ while (*s) {
+ Print_char(*s);
+ s++;
+ }
+ } else {
+ Print_uchar(e);
+ while (*s) {
+ Print_char(*s);
+ s++;
+ }
+ if ((!single_letter(zget_cs_text(q)))
+ || is_cat_letter(zget_cs_text(q))) {
+ Print_char(' ');
+ }
+ }
+ }
+ }
+ } else {
+ if (infop < 0) {
+ Print_esc("BAD.");
+ } else {
+ m = infop >> string_offset_bits;
+ c = infop & (string_offset - 1);
+ switch (m) {
+ case 10:
+ case 11:
+ case 12:
+ case 1:
+ case 2:
+ case 3:
+ case 4:
+ case 7:
+ case 8:
+ Print_uchar(c);
+ break;
+ case 6:
+ /* Print_uchar(c); */
+ Print_uchar(c);
+ break;
+ case 5:
+ Print_uchar(match_chr);
+ if (c <= 9) {
+ Print_char(c + '0');
+ } else {
+ Print_char('!');
+ xfree(ret);
+ return NULL;
+ }
+ break;
+ case 13:
+ match_chr = c;
+ Print_uchar(c);
+ n++;
+ Print_char(n);
+ if (n > '9') {
+ xfree(ret);
+ return NULL;
+ }
+ break;
+ case 14:
+ if (c == 0) {
+ Print_char('-');
+ Print_char('>');
+ }
+ break;
+ default:
+ Print_esc("BAD.");
+ break;
+ }
+ }
+ }
+ p = link(p);
+ }
+ ret[i] = 0;
+ if (siz != NULL)
+ *siz = i;
+ return ret;
}
-void
-tokenlist_to_lua(lua_State *L, int p) {
- int cmd,chr,cs;
- int v;
- int i = 1;
- v = p;
- while (v!=null && v < fix_mem_end) { i++; v = link(v); }
- i = 1;
- lua_createtable(L,i,0);
- while (p!=null&& p < fix_mem_end) {
- if (info(p)>=cs_token_flag) {
- cs=info(p)-cs_token_flag;
- cmd = zget_eq_type(cs);
- chr = zget_equiv(cs);
- make_token_table(L,cmd,chr,cs);
- } else {
- cmd=info(p) / string_offset;
- chr=info(p) % string_offset;
- make_token_table(L,cmd,chr,0);
+void tokenlist_to_lua(lua_State * L, int p)
+{
+ int cmd, chr, cs;
+ int v;
+ int i = 1;
+ v = p;
+ while (v != null && v < fix_mem_end) {
+ i++;
+ v = link(v);
+ }
+ i = 1;
+ lua_createtable(L, i, 0);
+ while (p != null && p < fix_mem_end) {
+ if (info(p) >= cs_token_flag) {
+ cs = info(p) - cs_token_flag;
+ cmd = zget_eq_type(cs);
+ chr = zget_equiv(cs);
+ make_token_table(L, cmd, chr, cs);
+ } else {
+ cmd = info(p) / string_offset;
+ chr = info(p) % string_offset;
+ make_token_table(L, cmd, chr, 0);
+ }
+ lua_rawseti(L, -2, i++);
+ p = link(p);
}
- lua_rawseti(L,-2,i++);
- p = link(p);
- }
}
-void
-tokenlist_to_luastring(lua_State *L, int p) {
- int l;
- char *s;
- s = tokenlist_to_cstring(p,1,&l);
- lua_pushlstring(L,s,l);
+void tokenlist_to_luastring(lua_State * L, int p)
+{
+ int l;
+ char *s;
+ s = tokenlist_to_cstring(p, 1, &l);
+ lua_pushlstring(L, s, l);
}
-int
-tokenlist_from_lua(lua_State *L) {
- char *s;
- int tok;
- size_t i,j;
- halfword p,q,r;
- r = get_avail();
- info(r)=0; /* ref count */
- link(r)=null;
- p = r;
- if (lua_istable(L,-1)) {
- j = lua_objlen(L,-1);
- if (j>0) {
- for (i=1;i<=j;i++) {
- lua_rawgeti(L,-1,i);
- tok = token_from_lua(L);
- if (tok>=0) {
- store_new_token(tok);
- }
- lua_pop(L,1);
- };
- }
- return r;
- } else if (lua_isstring(L,-1)) {
- s = (char *)lua_tolstring(L,-1,&j);
- for (i=0;i<j;i++) {
- if (s[i] == 32) {
- tok = (10*string_offset)+s[i];
- } else {
- tok = (12*string_offset)+s[i];
- }
- store_new_token(tok);
+int tokenlist_from_lua(lua_State * L)
+{
+ char *s;
+ int tok;
+ size_t i, j;
+ halfword p, q, r;
+ r = get_avail();
+ info(r) = 0; /* ref count */
+ link(r) = null;
+ p = r;
+ if (lua_istable(L, -1)) {
+ j = lua_objlen(L, -1);
+ if (j > 0) {
+ for (i = 1; i <= j; i++) {
+ lua_rawgeti(L, -1, i);
+ tok = token_from_lua(L);
+ if (tok >= 0) {
+ store_new_token(tok);
+ }
+ lua_pop(L, 1);
+ };
+ }
+ return r;
+ } else if (lua_isstring(L, -1)) {
+ s = (char *) lua_tolstring(L, -1, &j);
+ for (i = 0; i < j; i++) {
+ if (s[i] == 32) {
+ tok = (10 * string_offset) + s[i];
+ } else {
+ tok = (12 * string_offset) + s[i];
+ }
+ store_new_token(tok);
+ }
+ return r;
+ } else {
+ free_avail(r);
+ return null;
}
- return r;
- } else {
- free_avail(r);
- return null;
- }
}
-void
-do_get_token_lua (integer callback_id) {
- lua_State *L = Luas[0];
-
- lua_rawgeti(L,LUA_REGISTRYINDEX,callback_callbacks_id);
- while (1) {
- lua_rawgeti(L,-1, callback_id);
- if (!lua_isfunction(L,-1)) {
- lua_pop(L,2); /* the not-a-function callback and the container */
- get_next();
- return;
- }
- if (lua_pcall(L,0,1,0) != 0) { /* no arg, 1 result */
- fprintf(stdout,"error: %s\n",lua_tostring(L,-1));
- lua_pop(L,2);
- error();
- return;
- }
- if (lua_istable(L,-1)) {
- lua_rawgeti(L,-1,1);
- if (lua_istable(L,-1)) {
- integer p,q,r;
- int i,j;
- lua_pop(L,1);
- /* build a token list */
- r = get_avail();
- p = r;
- j = lua_objlen(L,-1);
- if (j>0) {
- for (i=1;i<=j;i++) {
- lua_rawgeti(L,-1,i);
- if (get_cur_cmd(L) || get_cur_cs(L)) {
- store_new_token(cur_tok);
- }
- lua_pop(L,1);
- }
- }
- if (p!=r) {
- p = link(r);
- free_avail(r);
- begin_token_list(p, inserted);
- cur_input.nofilter_field=true;
- get_next();
- lua_pop(L,1);
- break;
- } else {
- fprintf(stdout,"error: illegal or empty token list returned\n");
- lua_pop(L,2);
- error();
- return;
- }
- } else {
- lua_pop(L,1);
- if (get_cur_cmd(L) || get_cur_cs(L)) {
- lua_pop(L,1);
- break;
- } else {
- lua_pop(L,2);
- continue;
- }
- }
- } else {
- lua_pop(L,1);
- continue;
+void do_get_token_lua(integer callback_id)
+{
+ lua_State *L = Luas;
+ while (1) {
+ if (!get_callback(L, callback_id)) {
+ get_next();
+ lua_pop(L, 2); /* the not-a-function callback and the container */
+ break;
+ }
+ if (lua_pcall(L, 0, 1, 0) != 0) { /* no arg, 1 result */
+ tex_error((char *) lua_tostring(L, -1), NULL);
+ lua_pop(L, 2); /* container and result */
+ break;
+ }
+ if (lua_istable(L, -1)) {
+ lua_rawgeti(L, -1, 1);
+ if (lua_istable(L, -1)) { /* container, result, result[1] */
+ integer p, q, r;
+ int i, j;
+ lua_pop(L, 1); /* container, result */
+ /* build a token list */
+ r = get_avail();
+ p = r;
+ j = lua_objlen(L, -1);
+ if (j > 0) {
+ for (i = 1; i <= j; i++) {
+ lua_rawgeti(L, -1, i);
+ if (get_cur_cmd(L) || get_cur_cs(L)) {
+ store_new_token(cur_tok);
+ }
+ lua_pop(L, 1);
+ }
+ }
+ if (p != r) {
+ p = link(r);
+ free_avail(r);
+ begin_token_list(p, inserted);
+ cur_input.nofilter_field = true;
+ get_next();
+ } else {
+ tex_error("error: illegal or empty token list returned",
+ NULL);
+ }
+ lua_pop(L, 2);
+ break;
+ } else { /* container, result, whatever */
+ lua_pop(L, 1); /* container, result */
+ if (get_cur_cmd(L) || get_cur_cs(L)) {
+ lua_pop(L, 2);
+ break;
+ } else {
+ lua_pop(L, 2);
+ continue;
+ }
+ }
+ } else {
+ lua_pop(L, 2); /* container, result */
+ }
}
- }
- lua_pop(L,1); /* callback container */
- return;
+ return;
}
-
diff --git a/Build/source/texk/web2c/luatexdir/lua/mp.w b/Build/source/texk/web2c/luatexdir/lua/mp.w
deleted file mode 100644
index 4894a54e9aa..00000000000
--- a/Build/source/texk/web2c/luatexdir/lua/mp.w
+++ /dev/null
@@ -1,26202 +0,0 @@
-% $Id: mp.web,v 1.8 2005/08/24 10:54:02 taco Exp $
-% MetaPost, by John Hobby. Public domain.
-
-% Much of this program was copied with permission from MF.web Version 1.9
-% It interprets a language very similar to D.E. Knuth's METAFONT, but with
-% changes designed to make it more suitable for PostScript output.
-
-% TeX is a trademark of the American Mathematical Society.
-% METAFONT is a trademark of Addison-Wesley Publishing Company.
-% PostScript is a trademark of Adobe Systems Incorporated.
-
-% Here is TeX material that gets inserted after \input webmac
-\def\hang{\hangindent 3em\noindent\ignorespaces}
-\def\textindent#1{\hangindent2.5em\noindent\hbox to2.5em{\hss#1 }\ignorespaces}
-\def\ps{PostScript}
-\def\psqrt#1{\sqrt{\mathstrut#1}}
-\def\k{_{k+1}}
-\def\pct!{{\char`\%}} % percent sign in ordinary text
-\font\tenlogo=logo10 % font used for the METAFONT logo
-\font\logos=logosl10
-\def\MF{{\tenlogo META}\-{\tenlogo FONT}}
-\def\MP{{\tenlogo META}\-{\tenlogo POST}}
-\def\[#1]{\ignorespaces} % left over from pascal web
-\def\<#1>{$\langle#1\rangle$}
-\def\section{\mathhexbox278}
-\let\swap=\leftrightarrow
-\def\round{\mathop{\rm round}\nolimits}
-\mathchardef\vb="026A % synonym for `\|'
-
-\def\(#1){} % this is used to make section names sort themselves better
-\def\9#1{} % this is used for sort keys in the index via @@:sort key}{entry@@>
-\def\title{MetaPost}
-\pdfoutput=1
-\pageno=3
-
-@* \[1] Introduction.
-
-This is \MP, a graphics-language processor based on D. E. Knuth's \MF.
-
-The main purpose of the following program is to explain the algorithms of \MP\
-as clearly as possible. However, the program has been written so that it
-can be tuned to run efficiently in a wide variety of operating environments
-by making comparatively few changes. Such flexibility is possible because
-the documentation that follows is written in the \.{WEB} language, which is
-at a higher level than C.
-
-A large piece of software like \MP\ has inherent complexity that cannot
-be reduced below a certain level of difficulty, although each individual
-part is fairly simple by itself. The \.{WEB} language is intended to make
-the algorithms as readable as possible, by reflecting the way the
-individual program pieces fit together and by providing the
-cross-references that connect different parts. Detailed comments about
-what is going on, and about why things were done in certain ways, have
-been liberally sprinkled throughout the program. These comments explain
-features of the implementation, but they rarely attempt to explain the
-\MP\ language itself, since the reader is supposed to be familiar with
-{\sl The {\logos METAFONT\/}book} as well as the manual
-@.WEB@>
-@:METAFONTbook}{\sl The {\logos METAFONT\/}book@>
-{\sl A User's Manual for MetaPost}, Computing Science Technical Report 162,
-AT\AM T Bell Laboratories.
-
-@ The present implementation is a preliminary version, but the possibilities
-for new features are limited by the desire to remain as nearly compatible
-with \MF\ as possible.
-
-On the other hand, the \.{WEB} description can be extended without changing
-the core of the program, and it has been designed so that such
-extensions are not extremely difficult to make.
-The |banner| string defined here should be changed whenever \MP\
-undergoes any modifications, so that it will be clear which version of
-\MP\ might be the guilty party when a problem arises.
-@^extensions to \MP@>
-@^system dependencies@>
-
-@d banner "This is MetaPost, Version 1.003" /* printed when \MP\ starts */
-@d metapost_version "1.003"
-@d mplib_version "0.40"
-@d version_string " (Cweb version 0.40)"
-
-@d true 1
-@d false 0
-
-@ The external library header for \MP\ is |mplib.h|. It contains a
-few typedefs and the header defintions for the externally used
-fuctions.
-
-The most important of the typedefs is the definition of the structure
-|MP_options|, that acts as a small, configurable front-end to the fairly
-large |MP_instance| structure.
-
-@(mplib.h@>=
-typedef struct MP_instance * MP;
-@<Exported types@>
-typedef struct MP_options {
- @<Option variables@>
-} MP_options;
-@<Exported function headers@>
-
-@ The internal header file is much longer: it not only lists the complete
-|MP_instance|, but also a lot of functions that have to be available to
-the \ps\ backend, that is defined in a separate \.{WEB} file.
-
-The variables from |MP_options| are included inside the |MP_instance|
-wholesale.
-
-@(mpmp.h@>=
-#include <setjmp.h>
-typedef struct psout_data_struct * psout_data;
-typedef int boolean;
-typedef signed int integer;
-@<Declare helpers@>
-@<Types in the outer block@>
-@<Constants in the outer block@>
-# ifndef LIBAVL_ALLOCATOR
-# define LIBAVL_ALLOCATOR
- struct libavl_allocator {
- void *(*libavl_malloc) (struct libavl_allocator *, size_t libavl_size);
- void (*libavl_free) (struct libavl_allocator *, void *libavl_block);
- };
-# endif
-typedef struct MP_instance {
- @<Option variables@>
- @<Global variables@>
-} MP_instance;
-@<Internal library declarations@>
-
-@ @c
-#include <stdio.h>
-#include <stdlib.h>
-#include <string.h>
-#include <stdarg.h>
-#include <assert.h>
-#include <unistd.h> /* for access() */
-#include <time.h> /* for struct tm \& co */
-#include "mplib.h"
-#include "mpmp.h" /* internal header */
-#include "mppsout.h" /* internal header */
-@h
-@<Declarations@>
-@<Basic printing procedures@>
-@<Error handling procedures@>
-
-@ Here are the functions that set up the \MP\ instance.
-
-@<Declarations@> =
-@<Declare |mp_reallocate| functions@>
-struct MP_options *mp_options (void);
-MP mp_new (struct MP_options *opt);
-
-@ @c
-struct MP_options *mp_options (void) {
- struct MP_options *opt;
- opt = malloc(sizeof(MP_options));
- if (opt!=NULL) {
- memset (opt,0,sizeof(MP_options));
- }
- return opt;
-}
-
-@ The |__attribute__| pragma is gcc-only.
-
-@<Internal library ... @>=
-#if !defined(__GNUC__) || (__GNUC__ < 2)
-# define __attribute__(x)
-#endif /* !defined(__GNUC__) || (__GNUC__ < 2) */
-
-@ @c
-MP __attribute__ ((noinline))
-mp_new (struct MP_options *opt) {
- MP mp;
- mp = malloc(1*sizeof(MP_instance));
- if (mp==NULL)
- return mp;
- @<Set |ini_version|@>;
- @<Setup the non-local jump buffer in |mp_new|@>;
- @<Allocate or initialize variables@>
- if (opt->main_memory>mp->mem_max)
- mp_reallocate_memory(mp,opt->main_memory);
- mp_reallocate_paths(mp,1000);
- mp_reallocate_fonts(mp,8);
- return mp;
-}
-
-@ @c
-void mp_free (MP mp) {
- int k; /* loop variable */
- @<Dealloc variables@>
- xfree(mp);
-}
-
-@ @c
-void __attribute__((noinline))
-mp_do_initialize ( MP mp) {
- @<Local variables for initialization@>
- @<Set initial values of key variables@>
-}
-int mp_initialize (MP mp) { /* this procedure gets things started properly */
- mp->history=mp_fatal_error_stop; /* in case we quit during initialization */
- @<Install and test the non-local jump buffer@>;
- t_open_out; /* open the terminal for output */
- @<Check the ``constant'' values...@>;
- if ( mp->bad>0 ) {
- char ss[256];
- snprintf(ss,256,"Ouch---my internal constants have been clobbered!\n"
- "---case %i",(int)mp->bad);
- do_fprintf(mp->err_out,(char *)ss);
-@.Ouch...clobbered@>
- return mp->history;
- }
- mp_do_initialize(mp); /* erase preloaded mem */
- if (mp->ini_version) {
- @<Run inimpost commands@>;
- }
- @<Initialize the output routines@>;
- @<Get the first line of input and prepare to start@>;
- mp_set_job_id(mp);
- mp_init_map_file(mp, mp->troff_mode);
- mp->history=mp_spotless; /* ready to go! */
- if (mp->troff_mode) {
- mp->internal[mp_gtroffmode]=unity;
- mp->internal[mp_prologues]=unity;
- }
- if ( mp->start_sym>0 ) { /* insert the `\&{everyjob}' symbol */
- mp->cur_sym=mp->start_sym; mp_back_input(mp);
- }
- return mp->history;
-}
-
-@
-@<Exported function headers@>=
-extern struct MP_options *mp_options (void);
-extern MP mp_new (struct MP_options *opt) ;
-extern void mp_free (MP mp);
-extern int mp_initialize (MP mp);
-
-@ The overall \MP\ program begins with the heading just shown, after which
-comes a bunch of procedure declarations and function declarations.
-Finally we will get to the main program, which begins with the
-comment `|start_here|'. If you want to skip down to the
-main program now, you can look up `|start_here|' in the index.
-But the author suggests that the best way to understand this program
-is to follow pretty much the order of \MP's components as they appear in the
-\.{WEB} description you are now reading, since the present ordering is
-intended to combine the advantages of the ``bottom up'' and ``top down''
-approaches to the problem of understanding a somewhat complicated system.
-
-@ Some of the code below is intended to be used only when diagnosing the
-strange behavior that sometimes occurs when \MP\ is being installed or
-when system wizards are fooling around with \MP\ without quite knowing
-what they are doing. Such code will not normally be compiled; it is
-delimited by the preprocessor test `|#ifdef DEBUG .. #endif|'.
-
-@ This program has two important variations: (1) There is a long and slow
-version called \.{INIMP}, which does the extra calculations needed to
-@.INIMP@>
-initialize \MP's internal tables; and (2)~there is a shorter and faster
-production version, which cuts the initialization to a bare minimum.
-
-Which is which is decided at runtime.
-
-@ The following parameters can be changed at compile time to extend or
-reduce \MP's capacity. They may have different values in \.{INIMP} and
-in production versions of \MP.
-@.INIMP@>
-@^system dependencies@>
-
-@<Constants...@>=
-#define file_name_size 255 /* file names shouldn't be longer than this */
-#define bistack_size 1500 /* size of stack for bisection algorithms;
- should probably be left at this value */
-
-@ Like the preceding parameters, the following quantities can be changed
-at compile time to extend or reduce \MP's capacity. But if they are changed,
-it is necessary to rerun the initialization program \.{INIMP}
-@.INIMP@>
-to generate new tables for the production \MP\ program.
-One can't simply make helter-skelter changes to the following constants,
-since certain rather complex initialization
-numbers are computed from them.
-
-@ @<Glob...@>=
-int max_strings; /* maximum number of strings; must not exceed |max_halfword| */
-int pool_size; /* maximum number of characters in strings, including all
- error messages and help texts, and the names of all identifiers */
-int mem_max; /* greatest index in \MP's internal |mem| array;
- must be strictly less than |max_halfword|;
- must be equal to |mem_top| in \.{INIMP}, otherwise |>=mem_top| */
-int mem_top; /* largest index in the |mem| array dumped by \.{INIMP};
- must not be greater than |mem_max| */
-
-@ @<Option variables@>=
-int error_line; /* width of context lines on terminal error messages */
-int half_error_line; /* width of first lines of contexts in terminal
- error messages; should be between 30 and |error_line-15| */
-int max_print_line; /* width of longest text lines output; should be at least 60 */
-int hash_size; /* maximum number of symbolic tokens,
- must be less than |max_halfword-3*param_size| */
-int hash_prime; /* a prime number equal to about 85\pct! of |hash_size| */
-int param_size; /* maximum number of simultaneous macro parameters */
-int max_in_open; /* maximum number of input files and error insertions that
- can be going on simultaneously */
-int main_memory; /* only for options, to set up |mem_max| and |mem_top| */
-void *userdata; /* this allows the calling application to setup local */
-
-@
-@d set_value(a,b,c) do { a=c; if (b>c) a=b; } while (0)
-
-@<Allocate or ...@>=
-mp->max_strings=500;
-mp->pool_size=10000;
-set_value(mp->error_line,opt->error_line,79);
-set_value(mp->half_error_line,opt->half_error_line,50);
-set_value(mp->max_print_line,opt->max_print_line,100);
-mp->main_memory=5000;
-mp->mem_max=5000;
-mp->mem_top=5000;
-set_value(mp->hash_size,opt->hash_size,9500);
-set_value(mp->hash_prime,opt->hash_prime,7919);
-set_value(mp->param_size,opt->param_size,150);
-set_value(mp->max_in_open,opt->max_in_open,10);
-mp->userdata=opt->userdata;
-
-@ In case somebody has inadvertently made bad settings of the ``constants,''
-\MP\ checks them using a global variable called |bad|.
-
-This is the first of many sections of \MP\ where global variables are
-defined.
-
-@<Glob...@>=
-integer bad; /* is some ``constant'' wrong? */
-
-@ Later on we will say `\ignorespaces|if (mem_max>=max_halfword) bad=10;|',
-or something similar. (We can't do that until |max_halfword| has been defined.)
-
-@<Check the ``constant'' values for consistency@>=
-mp->bad=0;
-if ( (mp->half_error_line<30)||(mp->half_error_line>mp->error_line-15) ) mp->bad=1;
-if ( mp->max_print_line<60 ) mp->bad=2;
-if ( mp->mem_top<=1100 ) mp->bad=4;
-if (mp->hash_prime>mp->hash_size ) mp->bad=5;
-
-@ Some |goto| labels are used by the following definitions. The label
-`|restart|' is occasionally used at the very beginning of a procedure; and
-the label `|reswitch|' is occasionally used just prior to a |case|
-statement in which some cases change the conditions and we wish to branch
-to the newly applicable case. Loops that are set up with the |loop|
-construction defined below are commonly exited by going to `|done|' or to
-`|found|' or to `|not_found|', and they are sometimes repeated by going to
-`|continue|'. If two or more parts of a subroutine start differently but
-end up the same, the shared code may be gathered together at
-`|common_ending|'.
-
-@ Here are some macros for common programming idioms.
-
-@d incr(A) (A)=(A)+1 /* increase a variable by unity */
-@d decr(A) (A)=(A)-1 /* decrease a variable by unity */
-@d negate(A) (A)=-(A) /* change the sign of a variable */
-@d double(A) (A)=(A)+(A)
-@d odd(A) ((A)%2==1)
-@d chr(A) (A)
-@d do_nothing /* empty statement */
-@d Return goto exit /* terminate a procedure call */
-@f return nil /* \.{WEB} will henceforth say |return| instead of \\{return} */
-
-@* \[2] The character set.
-In order to make \MP\ readily portable to a wide variety of
-computers, all of its input text is converted to an internal eight-bit
-code that includes standard ASCII, the ``American Standard Code for
-Information Interchange.'' This conversion is done immediately when each
-character is read in. Conversely, characters are converted from ASCII to
-the user's external representation just before they are output to a
-text file.
-@^ASCII code@>
-
-Such an internal code is relevant to users of \MP\ only with respect to
-the \&{char} and \&{ASCII} operations, and the comparison of strings.
-
-@ Characters of text that have been converted to \MP's internal form
-are said to be of type |ASCII_code|, which is a subrange of the integers.
-
-@<Types...@>=
-typedef unsigned char ASCII_code; /* eight-bit numbers */
-
-@ The present specification of \MP\ has been written under the assumption
-that the character set contains at least the letters and symbols associated
-with ASCII codes 040 through 0176; all of these characters are now
-available on most computer terminals.
-
-We shall use the name |text_char| to stand for the data type of the characters
-that are converted to and from |ASCII_code| when they are input and output.
-We shall also assume that |text_char| consists of the elements
-|chr(first_text_char)| through |chr(last_text_char)|, inclusive.
-The following definitions should be adjusted if necessary.
-@^system dependencies@>
-
-@d first_text_char 0 /* ordinal number of the smallest element of |text_char| */
-@d last_text_char 255 /* ordinal number of the largest element of |text_char| */
-
-@<Types...@>=
-typedef unsigned char text_char; /* the data type of characters in text files */
-
-@ @<Local variables for init...@>=
-integer i;
-
-@ The \MP\ processor converts between ASCII code and
-the user's external character set by means of arrays |xord| and |xchr|
-that are analogous to Pascal's |ord| and |chr| functions.
-
-@d xchr(A) mp->xchr[(A)]
-@d xord(A) mp->xord[(A)]
-
-@<Glob...@>=
-ASCII_code xord[256]; /* specifies conversion of input characters */
-text_char xchr[256]; /* specifies conversion of output characters */
-
-@ The core system assumes all 8-bit is acceptable. If it is not,
-a change file has to alter the below section.
-@^system dependencies@>
-
-Additionally, people with extended character sets can
-assign codes arbitrarily, giving an |xchr| equivalent to whatever
-characters the users of \MP\ are allowed to have in their input files.
-Appropriate changes to \MP's |char_class| table should then be made.
-(Unlike \TeX, each installation of \MP\ has a fixed assignment of category
-codes, called the |char_class|.) Such changes make portability of programs
-more difficult, so they should be introduced cautiously if at all.
-@^character set dependencies@>
-@^system dependencies@>
-
-@<Set initial ...@>=
-for (i=0;i<=0377;i++) { xchr(i)=i; }
-
-@ The following system-independent code makes the |xord| array contain a
-suitable inverse to the information in |xchr|. Note that if |xchr[i]=xchr[j]|
-where |i<j<0177|, the value of |xord[xchr[i]]| will turn out to be
-|j| or more; hence, standard ASCII code numbers will be used instead of
-codes below 040 in case there is a coincidence.
-
-@<Set initial ...@>=
-for (i=first_text_char;i<=last_text_char;i++) {
- xord(chr(i))=0177;
-}
-for (i=0200;i<=0377;i++) { xord(xchr(i))=i;}
-for (i=0;i<=0176;i++) { xord(xchr(i))=i;}
-
-@* \[3] Input and output.
-The bane of portability is the fact that different operating systems treat
-input and output quite differently, perhaps because computer scientists
-have not given sufficient attention to this problem. People have felt somehow
-that input and output are not part of ``real'' programming. Well, it is true
-that some kinds of programming are more fun than others. With existing
-input/output conventions being so diverse and so messy, the only sources of
-joy in such parts of the code are the rare occasions when one can find a
-way to make the program a little less bad than it might have been. We have
-two choices, either to attack I/O now and get it over with, or to postpone
-I/O until near the end. Neither prospect is very attractive, so let's
-get it over with.
-
-The basic operations we need to do are (1)~inputting and outputting of
-text, to or from a file or the user's terminal; (2)~inputting and
-outputting of eight-bit bytes, to or from a file; (3)~instructing the
-operating system to initiate (``open'') or to terminate (``close'') input or
-output from a specified file; (4)~testing whether the end of an input
-file has been reached; (5)~display of bits on the user's screen.
-The bit-display operation will be discussed in a later section; we shall
-deal here only with more traditional kinds of I/O.
-
-@ Finding files happens in a slightly roundabout fashion: the \MP\
-instance object contains a field that holds a function pointer that finds a
-file, and returns its name, or NULL. For this, it receives three
-parameters: the non-qualified name |fname|, the intended |fopen|
-operation type |fmode|, and the type of the file |ftype|.
-
-The file types that are passed on in |ftype| can be used to
-differentiate file searches if a library like kpathsea is used,
-the fopen mode is passed along for the same reason.
-
-@<Types...@>=
-typedef unsigned char eight_bits ; /* unsigned one-byte quantity */
-
-@ @<Exported types@>=
-enum mp_filetype {
- mp_filetype_terminal = 0, /* the terminal */
- mp_filetype_error, /* the terminal */
- mp_filetype_program , /* \MP\ language input */
- mp_filetype_log, /* the log file */
- mp_filetype_postscript, /* the postscript output */
- mp_filetype_memfile, /* memory dumps */
- mp_filetype_metrics, /* TeX font metric files */
- mp_filetype_fontmap, /* PostScript font mapping files */
- mp_filetype_font, /* PostScript type1 font programs */
- mp_filetype_encoding, /* PostScript font encoding files */
- mp_filetype_text /* first text file for readfrom and writeto primitives */
-};
-typedef char *(*mp_file_finder)(MP, const char *, const char *, int);
-typedef void *(*mp_file_opener)(MP, const char *, const char *, int);
-typedef char *(*mp_file_reader)(MP, void *, size_t *);
-typedef void (*mp_binfile_reader)(MP, void *, void **, size_t *);
-typedef void (*mp_file_closer)(MP, void *);
-typedef int (*mp_file_eoftest)(MP, void *);
-typedef void (*mp_file_flush)(MP, void *);
-typedef void (*mp_file_writer)(MP, void *, const char *);
-typedef void (*mp_binfile_writer)(MP, void *, void *, size_t);
-#define NOTTESTING 1
-
-@ @<Option variables@>=
-mp_file_finder find_file;
-mp_file_opener open_file;
-mp_file_reader read_ascii_file;
-mp_binfile_reader read_binary_file;
-mp_file_closer close_file;
-mp_file_eoftest eof_file;
-mp_file_flush flush_file;
-mp_file_writer write_ascii_file;
-mp_binfile_writer write_binary_file;
-
-@ The default function for finding files is |mp_find_file|. It is
-pretty stupid: it will only find files in the current directory.
-
-This function may disappear altogether, it is currently only
-used for the default font map file.
-
-@c
-char *mp_find_file (MP mp, const char *fname, const char *fmode, int ftype) {
- (void) mp;
- if (fmode[0] != 'r' || (! access (fname,R_OK)) || ftype) {
- return strdup(fname);
- }
- return NULL;
-}
-
-@ This has to be done very early on, so it is best to put it in with
-the |mp_new| allocations
-
-@d set_callback_option(A) do { mp->A = mp_##A;
- if (opt->A!=NULL) mp->A = opt->A;
-} while (0)
-
-@<Allocate or initialize ...@>=
-set_callback_option(find_file);
-set_callback_option(open_file);
-set_callback_option(read_ascii_file);
-set_callback_option(read_binary_file);
-set_callback_option(close_file);
-set_callback_option(eof_file);
-set_callback_option(flush_file);
-set_callback_option(write_ascii_file);
-set_callback_option(write_binary_file);
-
-@ Because |mp_find_file| is used so early, it has to be in the helpers
-section.
-
-@<Internal ...@>=
-char *mp_find_file (MP mp, const char *fname, const char *fmode, int ftype) ;
-void *mp_open_file (MP mp , const char *fname, const char *fmode, int ftype) ;
-char *mp_read_ascii_file (MP mp, void *f, size_t *size) ;
-void mp_read_binary_file (MP mp, void *f, void **d, size_t *size) ;
-void mp_close_file (MP mp, void *f) ;
-int mp_eof_file (MP mp, void *f) ;
-void mp_flush_file (MP mp, void *f) ;
-void mp_write_ascii_file (MP mp, void *f, const char *s) ;
-void mp_write_binary_file (MP mp, void *f, void *s, size_t t) ;
-
-@ The function to open files can now be very short.
-
-@c
-void *mp_open_file(MP mp, const char *fname, const char *fmode, int ftype) {
- char realmode[3];
- (void) mp;
- realmode[0] = *fmode;
- realmode[1] = 'b';
- realmode[2] = 0;
-#if NOTTESTING
- if (ftype==mp_filetype_terminal) {
- return (fmode[0] == 'r' ? stdin : stdout);
- } else if (ftype==mp_filetype_error) {
- return stderr;
- } else if (fname != NULL && (fmode[0] != 'r' || (! access (fname,R_OK)))) {
- return (void *)fopen(fname, realmode);
- }
-#endif
- return NULL;
-}
-
-@ This is a legacy interface: (almost) all file names pass through |name_of_file|.
-
-@<Glob...@>=
-char name_of_file[file_name_size+1]; /* the name of a system file */
-int name_length;/* this many characters are actually
- relevant in |name_of_file| (the rest are blank) */
-
-@ @<Option variables@>=
-int print_found_names; /* configuration parameter */
-
-@ If this parameter is true, the terminal and log will report the found
-file names for input files instead of the requested ones.
-It is off by default because it creates an extra filename lookup.
-
-@<Allocate or initialize ...@>=
-mp->print_found_names = (opt->print_found_names>0 ? true : false);
-
-@ \MP's file-opening procedures return |false| if no file identified by
-|name_of_file| could be opened.
-
-The |OPEN_FILE| macro takes care of the |print_found_names| parameter.
-It is not used for opening a mem file for read, because that file name
-is never printed.
-
-@d OPEN_FILE(A) do {
- if (mp->print_found_names) {
- char *s = (mp->find_file)(mp,mp->name_of_file,A,ftype);
- if (s!=NULL) {
- *f = (mp->open_file)(mp,mp->name_of_file,A, ftype);
- strncpy(mp->name_of_file,s,file_name_size);
- xfree(s);
- } else {
- *f = NULL;
- }
- } else {
- *f = (mp->open_file)(mp,mp->name_of_file,A, ftype);
- }
-} while (0);
-return (*f ? true : false)
-
-@c
-boolean mp_a_open_in (MP mp, void **f, int ftype) {
- /* open a text file for input */
- OPEN_FILE("r");
-}
-@#
-boolean mp_w_open_in (MP mp, void **f) {
- /* open a word file for input */
- *f = (mp->open_file)(mp,mp->name_of_file,"r",mp_filetype_memfile);
- return (*f ? true : false);
-}
-@#
-boolean mp_a_open_out (MP mp, void **f, int ftype) {
- /* open a text file for output */
- OPEN_FILE("w");
-}
-@#
-boolean mp_b_open_out (MP mp, void **f, int ftype) {
- /* open a binary file for output */
- OPEN_FILE("w");
-}
-@#
-boolean mp_w_open_out (MP mp, void **f) {
- /* open a word file for output */
- int ftype = mp_filetype_memfile;
- OPEN_FILE("w");
-}
-
-@ @c
-char *mp_read_ascii_file (MP mp, void *ff, size_t *size) {
- int c;
- size_t len = 0, lim = 128;
- char *s = NULL;
- FILE *f = (FILE *)ff;
- *size = 0;
- (void) mp; /* for -Wunused */
- if (f==NULL)
- return NULL;
-#if NOTTESTING
- c = fgetc(f);
- if (c==EOF)
- return NULL;
- s = malloc(lim);
- if (s==NULL) return NULL;
- while (c!=EOF && c!='\n' && c!='\r') {
- if (len==lim) {
- s =realloc(s, (lim+(lim>>2)));
- if (s==NULL) return NULL;
- lim+=(lim>>2);
- }
- s[len++] = c;
- c =fgetc(f);
- }
- if (c=='\r') {
- c = fgetc(f);
- if (c!=EOF && c!='\n')
- ungetc(c,f);
- }
- s[len] = 0;
- *size = len;
-#endif
- return s;
-}
-
-@ @c
-void mp_write_ascii_file (MP mp, void *f, const char *s) {
- (void) mp;
-#if NOTTESTING
- if (f!=NULL) {
- fputs(s,(FILE *)f);
- }
-#endif
-}
-
-@ @c
-void mp_read_binary_file (MP mp, void *f, void **data, size_t *size) {
- size_t len = 0;
- (void) mp;
-#if NOTTESTING
- if (f!=NULL)
- len = fread(*data,1,*size,(FILE *)f);
-#endif
- *size = len;
-}
-
-@ @c
-void mp_write_binary_file (MP mp, void *f, void *s, size_t size) {
- (void) mp;
-#if NOTTESTING
- if (f!=NULL)
- fwrite(s,size,1,(FILE *)f);
-#endif
-}
-
-
-@ @c
-void mp_close_file (MP mp, void *f) {
- (void) mp;
-#if NOTTESTING
- if (f!=NULL)
- fclose((FILE *)f);
-#endif
-}
-
-@ @c
-int mp_eof_file (MP mp, void *f) {
- (void) mp;
-#if NOTTESTING
- if (f!=NULL)
- return feof((FILE *)f);
- else
- return 1;
-#else
- return 0;
-#endif
-}
-
-@ @c
-void mp_flush_file (MP mp, void *f) {
- (void) mp;
-#if NOTTESTING
- if (f!=NULL)
- fflush((FILE *)f);
-#endif
-}
-
-@ Input from text files is read one line at a time, using a routine called
-|input_ln|. This function is defined in terms of global variables called
-|buffer|, |first|, and |last| that will be described in detail later; for
-now, it suffices for us to know that |buffer| is an array of |ASCII_code|
-values, and that |first| and |last| are indices into this array
-representing the beginning and ending of a line of text.
-
-@<Glob...@>=
-size_t buf_size; /* maximum number of characters simultaneously present in
- current lines of open files */
-ASCII_code *buffer; /* lines of characters being read */
-size_t first; /* the first unused position in |buffer| */
-size_t last; /* end of the line just input to |buffer| */
-size_t max_buf_stack; /* largest index used in |buffer| */
-
-@ @<Allocate or initialize ...@>=
-mp->buf_size = 200;
-mp->buffer = xmalloc((mp->buf_size+1),sizeof(ASCII_code));
-
-@ @<Dealloc variables@>=
-xfree(mp->buffer);
-
-@ @c
-void mp_reallocate_buffer(MP mp, size_t l) {
- ASCII_code *buffer;
- if (l>max_halfword) {
- mp_confusion(mp,"buffer size"); /* can't happen (I hope) */
- }
- buffer = xmalloc((l+1),sizeof(ASCII_code));
- memcpy(buffer,mp->buffer,(mp->buf_size+1));
- xfree(mp->buffer);
- mp->buffer = buffer ;
- mp->buf_size = l;
-}
-
-@ The |input_ln| function brings the next line of input from the specified
-field into available positions of the buffer array and returns the value
-|true|, unless the file has already been entirely read, in which case it
-returns |false| and sets |last:=first|. In general, the |ASCII_code|
-numbers that represent the next line of the file are input into
-|buffer[first]|, |buffer[first+1]|, \dots, |buffer[last-1]|; and the
-global variable |last| is set equal to |first| plus the length of the
-line. Trailing blanks are removed from the line; thus, either |last=first|
-(in which case the line was entirely blank) or |buffer[last-1]<>" "|.
-@^inner loop@>
-
-The variable |max_buf_stack|, which is used to keep track of how large
-the |buf_size| parameter must be to accommodate the present job, is
-also kept up to date by |input_ln|.
-
-@c
-boolean mp_input_ln (MP mp, void *f ) {
- /* inputs the next line or returns |false| */
- char *s;
- size_t size = 0;
- mp->last=mp->first; /* cf.\ Matthew 19\thinspace:\thinspace30 */
- s = (mp->read_ascii_file)(mp,f, &size);
- if (s==NULL)
- return false;
- if (size>0) {
- mp->last = mp->first+size;
- if ( mp->last>=mp->max_buf_stack ) {
- mp->max_buf_stack=mp->last+1;
- while ( mp->max_buf_stack>=mp->buf_size ) {
- mp_reallocate_buffer(mp,(mp->buf_size+(mp->buf_size>>2)));
- }
- }
- memcpy((mp->buffer+mp->first),s,size);
- /* while ( mp->buffer[mp->last]==' ' ) mp->last--; */
- }
- free(s);
- return true;
-}
-
-@ The user's terminal acts essentially like other files of text, except
-that it is used both for input and for output. When the terminal is
-considered an input file, the file variable is called |term_in|, and when it
-is considered an output file the file variable is |term_out|.
-@^system dependencies@>
-
-@<Glob...@>=
-void * term_in; /* the terminal as an input file */
-void * term_out; /* the terminal as an output file */
-void * err_out; /* the terminal as an output file */
-
-@ Here is how to open the terminal files. In the default configuration,
-nothing happens except that the command line (if there is one) is copied
-to the input buffer. The variable |command_line| will be filled by the
-|main| procedure. The copying can not be done earlier in the program
-logic because in the |INI| version, the |buffer| is also used for primitive
-initialization.
-
-@^system dependencies@>
-
-@d t_open_out do {/* open the terminal for text output */
- mp->term_out = (mp->open_file)(mp,"terminal", "w", mp_filetype_terminal);
- mp->err_out = (mp->open_file)(mp,"error", "w", mp_filetype_error);
-} while (0)
-@d t_open_in do { /* open the terminal for text input */
- mp->term_in = (mp->open_file)(mp,"terminal", "r", mp_filetype_terminal);
- if (mp->command_line!=NULL) {
- mp->last = strlen(mp->command_line);
- strncpy((char *)mp->buffer,mp->command_line,mp->last);
- xfree(mp->command_line);
- } else {
- mp->last = 0;
- }
-} while (0)
-
-@d t_close_out do { /* close the terminal */
- (mp->close_file)(mp,mp->term_out);
- (mp->close_file)(mp,mp->err_out);
-} while (0)
-
-@d t_close_in do { /* close the terminal */
- (mp->close_file)(mp,mp->term_in);
-} while (0)
-
-@<Option variables@>=
-char *command_line;
-
-@ @<Allocate or initialize ...@>=
-mp->command_line = xstrdup(opt->command_line);
-
-@ Sometimes it is necessary to synchronize the input/output mixture that
-happens on the user's terminal, and three system-dependent
-procedures are used for this
-purpose. The first of these, |update_terminal|, is called when we want
-to make sure that everything we have output to the terminal so far has
-actually left the computer's internal buffers and been sent.
-The second, |clear_terminal|, is called when we wish to cancel any
-input that the user may have typed ahead (since we are about to
-issue an unexpected error message). The third, |wake_up_terminal|,
-is supposed to revive the terminal if the user has disabled it by
-some instruction to the operating system. The following macros show how
-these operations can be specified:
-@^system dependencies@>
-
-@d update_terminal (mp->flush_file)(mp,mp->term_out) /* empty the terminal output buffer */
-@d clear_terminal do_nothing /* clear the terminal input buffer */
-@d wake_up_terminal (mp->flush_file)(mp,mp->term_out)
- /* cancel the user's cancellation of output */
-
-@ We need a special routine to read the first line of \MP\ input from
-the user's terminal. This line is different because it is read before we
-have opened the transcript file; there is sort of a ``chicken and
-egg'' problem here. If the user types `\.{input cmr10}' on the first
-line, or if some macro invoked by that line does such an \.{input},
-the transcript file will be named `\.{cmr10.log}'; but if no \.{input}
-commands are performed during the first line of terminal input, the transcript
-file will acquire its default name `\.{mpout.log}'. (The transcript file
-will not contain error messages generated by the first line before the
-first \.{input} command.)
-
-The first line is even more special. It's nice to let the user start
-running a \MP\ job by typing a command line like `\.{MP cmr10}'; in
-such a case, \MP\ will operate as if the first line of input were
-`\.{cmr10}', i.e., the first line will consist of the remainder of the
-command line, after the part that invoked \MP.
-
-@ Different systems have different ways to get started. But regardless of
-what conventions are adopted, the routine that initializes the terminal
-should satisfy the following specifications:
-
-\yskip\textindent{1)}It should open file |term_in| for input from the
- terminal. (The file |term_out| will already be open for output to the
- terminal.)
-
-\textindent{2)}If the user has given a command line, this line should be
- considered the first line of terminal input. Otherwise the
- user should be prompted with `\.{**}', and the first line of input
- should be whatever is typed in response.
-
-\textindent{3)}The first line of input, which might or might not be a
- command line, should appear in locations |first| to |last-1| of the
- |buffer| array.
-
-\textindent{4)}The global variable |loc| should be set so that the
- character to be read next by \MP\ is in |buffer[loc]|. This
- character should not be blank, and we should have |loc<last|.
-
-\yskip\noindent(It may be necessary to prompt the user several times
-before a non-blank line comes in. The prompt is `\.{**}' instead of the
-later `\.*' because the meaning is slightly different: `\.{input}' need
-not be typed immediately after~`\.{**}'.)
-
-@d loc mp->cur_input.loc_field /* location of first unread character in |buffer| */
-
-@ The following program does the required initialization
-without retrieving a possible command line.
-It should be clear how to modify this routine to deal with command lines,
-if the system permits them.
-@^system dependencies@>
-
-@c
-boolean mp_init_terminal (MP mp) { /* gets the terminal input started */
- t_open_in;
- if (mp->last!=0) {
- loc = mp->first = 0;
- return true;
- }
- while (1) {
- if (!mp->noninteractive) {
- wake_up_terminal; do_fprintf(mp->term_out,"**"); update_terminal;
-@.**@>
- }
- if ( ! mp_input_ln(mp, mp->term_in ) ) { /* this shouldn't happen */
- do_fprintf(mp->term_out,"\n! End of file on the terminal... why?");
-@.End of file on the terminal@>
- return false;
- }
- loc=mp->first;
- while ( (loc<(int)mp->last)&&(mp->buffer[loc]==' ') )
- incr(loc);
- if ( loc<(int)mp->last ) {
- return true; /* return unless the line was all blank */
- }
- if (!mp->noninteractive) {
- do_fprintf(mp->term_out,"Please type the name of your input file.\n");
- }
- }
-}
-
-@ @<Declarations@>=
-boolean mp_init_terminal (MP mp) ;
-
-
-@* \[4] String handling.
-Symbolic token names and diagnostic messages are variable-length strings
-of eight-bit characters. Many strings \MP\ uses are simply literals
-in the compiled source, like the error messages and the names of the
-internal parameters. Other strings are used or defined from the \MP\ input
-language, and these have to be interned.
-
-\MP\ uses strings more extensively than \MF\ does, but the necessary
-operations can still be handled with a fairly simple data structure.
-The array |str_pool| contains all of the (eight-bit) ASCII codes in all
-of the strings, and the array |str_start| contains indices of the starting
-points of each string. Strings are referred to by integer numbers, so that
-string number |s| comprises the characters |str_pool[j]| for
-|str_start[s]<=j<str_start[ss]| where |ss=next_str[s]|. The string pool
-is allocated sequentially and |str_pool[pool_ptr]| is the next unused
-location. The first string number not currently in use is |str_ptr|
-and |next_str[str_ptr]| begins a list of free string numbers. String
-pool entries |str_start[str_ptr]| up to |pool_ptr| are reserved for a
-string currently being constructed.
-
-String numbers 0 to 255 are reserved for strings that correspond to single
-ASCII characters. This is in accordance with the conventions of \.{WEB},
-@.WEB@>
-which converts single-character strings into the ASCII code number of the
-single character involved, while it converts other strings into integers
-and builds a string pool file. Thus, when the string constant \.{"."} appears
-in the program below, \.{WEB} converts it into the integer 46, which is the
-ASCII code for a period, while \.{WEB} will convert a string like \.{"hello"}
-into some integer greater than~255. String number 46 will presumably be the
-single character `\..'\thinspace; but some ASCII codes have no standard visible
-representation, and \MP\ may need to be able to print an arbitrary
-ASCII character, so the first 256 strings are used to specify exactly what
-should be printed for each of the 256 possibilities.
-
-@<Types...@>=
-typedef int pool_pointer; /* for variables that point into |str_pool| */
-typedef int str_number; /* for variables that point into |str_start| */
-
-@ @<Glob...@>=
-ASCII_code *str_pool; /* the characters */
-pool_pointer *str_start; /* the starting pointers */
-str_number *next_str; /* for linking strings in order */
-pool_pointer pool_ptr; /* first unused position in |str_pool| */
-str_number str_ptr; /* number of the current string being created */
-pool_pointer init_pool_ptr; /* the starting value of |pool_ptr| */
-str_number init_str_use; /* the initial number of strings in use */
-pool_pointer max_pool_ptr; /* the maximum so far of |pool_ptr| */
-str_number max_str_ptr; /* the maximum so far of |str_ptr| */
-
-@ @<Allocate or initialize ...@>=
-mp->str_pool = xmalloc ((mp->pool_size +1),sizeof(ASCII_code));
-mp->str_start = xmalloc ((mp->max_strings+1),sizeof(pool_pointer));
-mp->next_str = xmalloc ((mp->max_strings+1),sizeof(str_number));
-
-@ @<Dealloc variables@>=
-xfree(mp->str_pool);
-xfree(mp->str_start);
-xfree(mp->next_str);
-
-@ Most printing is done from |char *|s, but sometimes not. Here are
-functions that convert an internal string into a |char *| for use
-by the printing routines, and vice versa.
-
-@d str(A) mp_str(mp,A)
-@d rts(A) mp_rts(mp,A)
-
-@<Internal ...@>=
-int mp_xstrcmp (const char *a, const char *b);
-char * mp_str (MP mp, str_number s);
-
-@ @<Declarations@>=
-str_number mp_rts (MP mp, const char *s);
-str_number mp_make_string (MP mp);
-
-@ The attempt to catch interrupted strings that is in |mp_rts|, is not
-very good: it does not handle nesting over more than one level.
-
-@c
-int mp_xstrcmp (const char *a, const char *b) {
- if (a==NULL && b==NULL)
- return 0;
- if (a==NULL)
- return -1;
- if (b==NULL)
- return 1;
- return strcmp(a,b);
-}
-
-@ @c
-char * mp_str (MP mp, str_number ss) {
- char *s;
- int len;
- if (ss==mp->str_ptr) {
- return NULL;
- } else {
- len = length(ss);
- s = xmalloc(len+1,sizeof(char));
- strncpy(s,(char *)(mp->str_pool+(mp->str_start[ss])),len);
- s[len] = 0;
- return (char *)s;
- }
-}
-str_number mp_rts (MP mp, const char *s) {
- int r; /* the new string */
- int old; /* a possible string in progress */
- int i=0;
- if (strlen(s)==0) {
- return 256;
- } else if (strlen(s)==1) {
- return s[0];
- } else {
- old=0;
- str_room((integer)strlen(s));
- if (mp->str_start[mp->str_ptr]<mp->pool_ptr)
- old = mp_make_string(mp);
- while (*s) {
- append_char(*s);
- s++;
- }
- r = mp_make_string(mp);
- if (old!=0) {
- str_room(length(old));
- while (i<length(old)) {
- append_char((mp->str_start[old]+i));
- }
- mp_flush_string(mp,old);
- }
- return r;
- }
-}
-
-@ Except for |strs_used_up|, the following string statistics are only
-maintained when code between |stat| $\ldots$ |tats| delimiters is not
-commented out:
-
-@<Glob...@>=
-integer strs_used_up; /* strings in use or unused but not reclaimed */
-integer pool_in_use; /* total number of cells of |str_pool| actually in use */
-integer strs_in_use; /* total number of strings actually in use */
-integer max_pl_used; /* maximum |pool_in_use| so far */
-integer max_strs_used; /* maximum |strs_in_use| so far */
-
-@ Several of the elementary string operations are performed using \.{WEB}
-macros instead of functions, because many of the
-operations are done quite frequently and we want to avoid the
-overhead of procedure calls. For example, here is
-a simple macro that computes the length of a string.
-@.WEB@>
-
-@d str_stop(A) mp->str_start[mp->next_str[(A)]] /* one cell past the end of string
- number \# */
-@d length(A) (str_stop((A))-mp->str_start[(A)]) /* the number of characters in string \# */
-
-@ The length of the current string is called |cur_length|. If we decide that
-the current string is not needed, |flush_cur_string| resets |pool_ptr| so that
-|cur_length| becomes zero.
-
-@d cur_length (mp->pool_ptr - mp->str_start[mp->str_ptr])
-@d flush_cur_string mp->pool_ptr=mp->str_start[mp->str_ptr]
-
-@ Strings are created by appending character codes to |str_pool|.
-The |append_char| macro, defined here, does not check to see if the
-value of |pool_ptr| has gotten too high; this test is supposed to be
-made before |append_char| is used.
-
-To test if there is room to append |l| more characters to |str_pool|,
-we shall write |str_room(l)|, which tries to make sure there is enough room
-by compacting the string pool if necessary. If this does not work,
-|do_compaction| aborts \MP\ and gives an apologetic error message.
-
-@d append_char(A) /* put |ASCII_code| \# at the end of |str_pool| */
-{ mp->str_pool[mp->pool_ptr]=(A); incr(mp->pool_ptr);
-}
-@d str_room(A) /* make sure that the pool hasn't overflowed */
- { if ( mp->pool_ptr+(A) > mp->max_pool_ptr ) {
- if ( mp->pool_ptr+(A) > mp->pool_size ) mp_do_compaction(mp, (A));
- else mp->max_pool_ptr=mp->pool_ptr+(A); }
- }
-
-@ The following routine is similar to |str_room(1)| but it uses the
-argument |mp->pool_size| to prevent |do_compaction| from aborting when
-string space is exhausted.
-
-@<Declare the procedure called |unit_str_room|@>=
-void mp_unit_str_room (MP mp);
-
-@ @c
-void mp_unit_str_room (MP mp) {
- if ( mp->pool_ptr>=mp->pool_size ) mp_do_compaction(mp, mp->pool_size);
- if ( mp->pool_ptr>=mp->max_pool_ptr ) mp->max_pool_ptr=mp->pool_ptr+1;
-}
-
-@ \MP's string expressions are implemented in a brute-force way: Every
-new string or substring that is needed is simply copied into the string pool.
-Space is eventually reclaimed by a procedure called |do_compaction| with
-the aid of a simple system system of reference counts.
-@^reference counts@>
-
-The number of references to string number |s| will be |str_ref[s]|. The
-special value |str_ref[s]=max_str_ref=127| is used to denote an unknown
-positive number of references; such strings will never be recycled. If
-a string is ever referred to more than 126 times, simultaneously, we
-put it in this category. Hence a single byte suffices to store each |str_ref|.
-
-@d max_str_ref 127 /* ``infinite'' number of references */
-@d add_str_ref(A) { if ( mp->str_ref[(A)]<max_str_ref ) incr(mp->str_ref[(A)]);
- }
-
-@<Glob...@>=
-int *str_ref;
-
-@ @<Allocate or initialize ...@>=
-mp->str_ref = xmalloc ((mp->max_strings+1),sizeof(int));
-
-@ @<Dealloc variables@>=
-xfree(mp->str_ref);
-
-@ Here's what we do when a string reference disappears:
-
-@d delete_str_ref(A) {
- if ( mp->str_ref[(A)]<max_str_ref ) {
- if ( mp->str_ref[(A)]>1 ) decr(mp->str_ref[(A)]);
- else mp_flush_string(mp, (A));
- }
- }
-
-@<Declare the procedure called |flush_string|@>=
-void mp_flush_string (MP mp,str_number s) ;
-
-
-@ We can't flush the first set of static strings at all, so there
-is no point in trying
-
-@c
-void mp_flush_string (MP mp,str_number s) {
- if (length(s)>1) {
- mp->pool_in_use=mp->pool_in_use-length(s);
- decr(mp->strs_in_use);
- if ( mp->next_str[s]!=mp->str_ptr ) {
- mp->str_ref[s]=0;
- } else {
- mp->str_ptr=s;
- decr(mp->strs_used_up);
- }
- mp->pool_ptr=mp->str_start[mp->str_ptr];
- }
-}
-
-@ C literals cannot be simply added, they need to be set so they can't
-be flushed.
-
-@d intern(A) mp_intern(mp,(A))
-
-@c
-str_number mp_intern (MP mp, const char *s) {
- str_number r ;
- r = rts(s);
- mp->str_ref[r] = max_str_ref;
- return r;
-}
-
-@ @<Declarations@>=
-str_number mp_intern (MP mp, const char *s);
-
-
-@ Once a sequence of characters has been appended to |str_pool|, it
-officially becomes a string when the function |make_string| is called.
-This function returns the identification number of the new string as its
-value.
-
-When getting the next unused string number from the linked list, we pretend
-that
-$$ \hbox{|max_str_ptr+1|, |max_str_ptr+2|, $\ldots$, |mp->max_strings|} $$
-are linked sequentially even though the |next_str| entries have not been
-initialized yet. We never allow |str_ptr| to reach |mp->max_strings|;
-|do_compaction| is responsible for making sure of this.
-
-@<Declarations@>=
-@<Declare the procedure called |do_compaction|@>
-@<Declare the procedure called |unit_str_room|@>
-str_number mp_make_string (MP mp);
-
-@ @c
-str_number mp_make_string (MP mp) { /* current string enters the pool */
- str_number s; /* the new string */
-RESTART:
- s=mp->str_ptr;
- mp->str_ptr=mp->next_str[s];
- if ( mp->str_ptr>mp->max_str_ptr ) {
- if ( mp->str_ptr==mp->max_strings ) {
- mp->str_ptr=s;
- mp_do_compaction(mp, 0);
- goto RESTART;
- } else {
-#ifdef DEBUG
- if ( mp->strs_used_up!=mp->max_str_ptr ) mp_confusion(mp, "s");
-@:this can't happen s}{\quad \.s@>
-#endif
- mp->max_str_ptr=mp->str_ptr;
- mp->next_str[mp->str_ptr]=mp->max_str_ptr+1;
- }
- }
- mp->str_ref[s]=1;
- mp->str_start[mp->str_ptr]=mp->pool_ptr;
- incr(mp->strs_used_up);
- incr(mp->strs_in_use);
- mp->pool_in_use=mp->pool_in_use+length(s);
- if ( mp->pool_in_use>mp->max_pl_used )
- mp->max_pl_used=mp->pool_in_use;
- if ( mp->strs_in_use>mp->max_strs_used )
- mp->max_strs_used=mp->strs_in_use;
- return s;
-}
-
-@ The most interesting string operation is string pool compaction. The idea
-is to recover unused space in the |str_pool| array by recopying the strings
-to close the gaps created when some strings become unused. All string
-numbers~$k$ where |str_ref[k]=0| are to be linked into the list of free string
-numbers after |str_ptr|. If this fails to free enough pool space we issue an
-|overflow| error unless |needed=mp->pool_size|. Calling |do_compaction|
-with |needed=mp->pool_size| supresses all overflow tests.
-
-The compaction process starts with |last_fixed_str| because all lower numbered
-strings are permanently allocated with |max_str_ref| in their |str_ref| entries.
-
-@<Glob...@>=
-str_number last_fixed_str; /* last permanently allocated string */
-str_number fixed_str_use; /* number of permanently allocated strings */
-
-@ @<Declare the procedure called |do_compaction|@>=
-void mp_do_compaction (MP mp, pool_pointer needed) ;
-
-@ @c
-void mp_do_compaction (MP mp, pool_pointer needed) {
- str_number str_use; /* a count of strings in use */
- str_number r,s,t; /* strings being manipulated */
- pool_pointer p,q; /* destination and source for copying string characters */
- @<Advance |last_fixed_str| as far as possible and set |str_use|@>;
- r=mp->last_fixed_str;
- s=mp->next_str[r];
- p=mp->str_start[s];
- while ( s!=mp->str_ptr ) {
- while ( mp->str_ref[s]==0 ) {
- @<Advance |s| and add the old |s| to the list of free string numbers;
- then |break| if |s=str_ptr|@>;
- }
- r=s; s=mp->next_str[s];
- incr(str_use);
- @<Move string |r| back so that |str_start[r]=p|; make |p| the location
- after the end of the string@>;
- }
- @<Move the current string back so that it starts at |p|@>;
- if ( needed<mp->pool_size ) {
- @<Make sure that there is room for another string with |needed| characters@>;
- }
- @<Account for the compaction and make sure the statistics agree with the
- global versions@>;
- mp->strs_used_up=str_use;
-}
-
-@ @<Advance |last_fixed_str| as far as possible and set |str_use|@>=
-t=mp->next_str[mp->last_fixed_str];
-while (t!=mp->str_ptr && mp->str_ref[t]==max_str_ref) {
- incr(mp->fixed_str_use);
- mp->last_fixed_str=t;
- t=mp->next_str[t];
-}
-str_use=mp->fixed_str_use
-
-@ Because of the way |flush_string| has been written, it should never be
-necessary to |break| here. The extra line of code seems worthwhile to
-preserve the generality of |do_compaction|.
-
-@<Advance |s| and add the old |s| to the list of free string numbers;...@>=
-{
-t=s;
-s=mp->next_str[s];
-mp->next_str[r]=s;
-mp->next_str[t]=mp->next_str[mp->str_ptr];
-mp->next_str[mp->str_ptr]=t;
-if ( s==mp->str_ptr ) break;
-}
-
-@ The string currently starts at |str_start[r]| and ends just before
-|str_start[s]|. We don't change |str_start[s]| because it might be needed
-to locate the next string.
-
-@<Move string |r| back so that |str_start[r]=p|; make |p| the location...@>=
-q=mp->str_start[r];
-mp->str_start[r]=p;
-while ( q<mp->str_start[s] ) {
- mp->str_pool[p]=mp->str_pool[q];
- incr(p); incr(q);
-}
-
-@ Pointers |str_start[str_ptr]| and |pool_ptr| have not been updated. When
-we do this, anything between them should be moved.
-
-@ @<Move the current string back so that it starts at |p|@>=
-q=mp->str_start[mp->str_ptr];
-mp->str_start[mp->str_ptr]=p;
-while ( q<mp->pool_ptr ) {
- mp->str_pool[p]=mp->str_pool[q];
- incr(p); incr(q);
-}
-mp->pool_ptr=p
-
-@ We must remember that |str_ptr| is not allowed to reach |mp->max_strings|.
-
-@<Make sure that there is room for another string with |needed| char...@>=
-if ( str_use>=mp->max_strings-1 )
- mp_reallocate_strings (mp,str_use);
-if ( mp->pool_ptr+needed>mp->max_pool_ptr ) {
- mp_reallocate_pool(mp, mp->pool_ptr+needed);
- mp->max_pool_ptr=mp->pool_ptr+needed;
-}
-
-@ @<Declarations@>=
-void mp_reallocate_strings (MP mp, str_number str_use) ;
-void mp_reallocate_pool(MP mp, pool_pointer needed) ;
-
-@ @c
-void mp_reallocate_strings (MP mp, str_number str_use) {
- while ( str_use>=mp->max_strings-1 ) {
- int l = mp->max_strings + (mp->max_strings>>2);
- XREALLOC (mp->str_ref, l, int);
- XREALLOC (mp->str_start, l, pool_pointer);
- XREALLOC (mp->next_str, l, str_number);
- mp->max_strings = l;
- }
-}
-void mp_reallocate_pool(MP mp, pool_pointer needed) {
- while ( needed>mp->pool_size ) {
- int l = mp->pool_size + (mp->pool_size>>2);
- XREALLOC (mp->str_pool, l, ASCII_code);
- mp->pool_size = l;
- }
-}
-
-@ @<Account for the compaction and make sure the statistics agree with...@>=
-if ( (mp->str_start[mp->str_ptr]!=mp->pool_in_use)||(str_use!=mp->strs_in_use) )
- mp_confusion(mp, "string");
-@:this can't happen string}{\quad string@>
-incr(mp->pact_count);
-mp->pact_chars=mp->pact_chars+mp->pool_ptr-str_stop(mp->last_fixed_str);
-mp->pact_strs=mp->pact_strs+str_use-mp->fixed_str_use;
-#ifdef DEBUG
-s=mp->str_ptr; t=str_use;
-while ( s<=mp->max_str_ptr ){
- if ( t>mp->max_str_ptr ) mp_confusion(mp, "\"");
- incr(t); s=mp->next_str[s];
-};
-if ( t<=mp->max_str_ptr ) mp_confusion(mp, "\"");
-#endif
-
-@ A few more global variables are needed to keep track of statistics when
-|stat| $\ldots$ |tats| blocks are not commented out.
-
-@<Glob...@>=
-integer pact_count; /* number of string pool compactions so far */
-integer pact_chars; /* total number of characters moved during compactions */
-integer pact_strs; /* total number of strings moved during compactions */
-
-@ @<Initialize compaction statistics@>=
-mp->pact_count=0;
-mp->pact_chars=0;
-mp->pact_strs=0;
-
-@ The following subroutine compares string |s| with another string of the
-same length that appears in |buffer| starting at position |k|;
-the result is |true| if and only if the strings are equal.
-
-@c
-boolean mp_str_eq_buf (MP mp,str_number s, integer k) {
- /* test equality of strings */
- pool_pointer j; /* running index */
- j=mp->str_start[s];
- while ( j<str_stop(s) ) {
- if ( mp->str_pool[j++]!=mp->buffer[k++] )
- return false;
- }
- return true;
-}
-
-@ Here is a similar routine, but it compares two strings in the string pool,
-and it does not assume that they have the same length. If the first string
-is lexicographically greater than, less than, or equal to the second,
-the result is respectively positive, negative, or zero.
-
-@c
-integer mp_str_vs_str (MP mp, str_number s, str_number t) {
- /* test equality of strings */
- pool_pointer j,k; /* running indices */
- integer ls,lt; /* lengths */
- integer l; /* length remaining to test */
- ls=length(s); lt=length(t);
- if ( ls<=lt ) l=ls; else l=lt;
- j=mp->str_start[s]; k=mp->str_start[t];
- while ( l-->0 ) {
- if ( mp->str_pool[j]!=mp->str_pool[k] ) {
- return (mp->str_pool[j]-mp->str_pool[k]);
- }
- incr(j); incr(k);
- }
- return (ls-lt);
-}
-
-@ The initial values of |str_pool|, |str_start|, |pool_ptr|,
-and |str_ptr| are computed by the \.{INIMP} program, based in part
-on the information that \.{WEB} has output while processing \MP.
-@.INIMP@>
-@^string pool@>
-
-@c
-void mp_get_strings_started (MP mp) {
- /* initializes the string pool,
- but returns |false| if something goes wrong */
- int k; /* small indices or counters */
- str_number g; /* a new string */
- mp->pool_ptr=0; mp->str_ptr=0; mp->max_pool_ptr=0; mp->max_str_ptr=0;
- mp->str_start[0]=0;
- mp->next_str[0]=1;
- mp->pool_in_use=0; mp->strs_in_use=0;
- mp->max_pl_used=0; mp->max_strs_used=0;
- @<Initialize compaction statistics@>;
- mp->strs_used_up=0;
- @<Make the first 256 strings@>;
- g=mp_make_string(mp); /* string 256 == "" */
- mp->str_ref[g]=max_str_ref;
- mp->last_fixed_str=mp->str_ptr-1;
- mp->fixed_str_use=mp->str_ptr;
- return;
-}
-
-@ @<Declarations@>=
-void mp_get_strings_started (MP mp);
-
-@ The first 256 strings will consist of a single character only.
-
-@<Make the first 256...@>=
-for (k=0;k<=255;k++) {
- append_char(k);
- g=mp_make_string(mp);
- mp->str_ref[g]=max_str_ref;
-}
-
-@ The first 128 strings will contain 95 standard ASCII characters, and the
-other 33 characters will be printed in three-symbol form like `\.{\^\^A}'
-unless a system-dependent change is made here. Installations that have
-an extended character set, where for example |xchr[032]=@t\.{'^^Z'}@>|,
-would like string 032 to be printed as the single character 032 instead
-of the three characters 0136, 0136, 0132 (\.{\^\^Z}). On the other hand,
-even people with an extended character set will want to represent string
-015 by \.{\^\^M}, since 015 is ASCII's ``carriage return'' code; the idea is
-to produce visible strings instead of tabs or line-feeds or carriage-returns
-or bell-rings or characters that are treated anomalously in text files.
-
-Unprintable characters of codes 128--255 are, similarly, rendered
-\.{\^\^80}--\.{\^\^ff}.
-
-The boolean expression defined here should be |true| unless \MP\ internal
-code number~|k| corresponds to a non-troublesome visible symbol in the
-local character set.
-If character |k| cannot be printed, and |k<0200|, then character |k+0100| or
-|k-0100| must be printable; moreover, ASCII codes |[060..071, 0141..0146]|
-must be printable.
-@^character set dependencies@>
-@^system dependencies@>
-
-@<Character |k| cannot be printed@>=
- (k<' ')||(k>'~')
-
-@* \[5] On-line and off-line printing.
-Messages that are sent to a user's terminal and to the transcript-log file
-are produced by several `|print|' procedures. These procedures will
-direct their output to a variety of places, based on the setting of
-the global variable |selector|, which has the following possible
-values:
-
-\yskip
-\hang |term_and_log|, the normal setting, prints on the terminal and on the
- transcript file.
-
-\hang |log_only|, prints only on the transcript file.
-
-\hang |term_only|, prints only on the terminal.
-
-\hang |no_print|, doesn't print at all. This is used only in rare cases
- before the transcript file is open.
-
-\hang |pseudo|, puts output into a cyclic buffer that is used
- by the |show_context| routine; when we get to that routine we shall discuss
- the reasoning behind this curious mode.
-
-\hang |new_string|, appends the output to the current string in the
- string pool.
-
-\hang |>=write_file| prints on one of the files used for the \&{write}
-@:write_}{\&{write} primitive@>
- command.
-
-\yskip
-\noindent The symbolic names `|term_and_log|', etc., have been assigned
-numeric codes that satisfy the convenient relations |no_print+1=term_only|,
-|no_print+2=log_only|, |term_only+2=log_only+1=term_and_log|. These
-relations are not used when |selector| could be |pseudo|, or |new_string|.
-We need not check for unprintable characters when |selector<pseudo|.
-
-Three additional global variables, |tally|, |term_offset| and |file_offset|
-record the number of characters that have been printed
-since they were most recently cleared to zero. We use |tally| to record
-the length of (possibly very long) stretches of printing; |term_offset|,
-and |file_offset|, on the other hand, keep track of how many
-characters have appeared so far on the current line that has been output
-to the terminal, the transcript file, or the \ps\ output file, respectively.
-
-@d new_string 0 /* printing is deflected to the string pool */
-@d pseudo 2 /* special |selector| setting for |show_context| */
-@d no_print 3 /* |selector| setting that makes data disappear */
-@d term_only 4 /* printing is destined for the terminal only */
-@d log_only 5 /* printing is destined for the transcript file only */
-@d term_and_log 6 /* normal |selector| setting */
-@d write_file 7 /* first write file selector */
-
-@<Glob...@>=
-void * log_file; /* transcript of \MP\ session */
-void * ps_file; /* the generic font output goes here */
-unsigned int selector; /* where to print a message */
-unsigned char dig[23]; /* digits in a number being output */
-integer tally; /* the number of characters recently printed */
-unsigned int term_offset;
- /* the number of characters on the current terminal line */
-unsigned int file_offset;
- /* the number of characters on the current file line */
-ASCII_code *trick_buf; /* circular buffer for pseudoprinting */
-integer trick_count; /* threshold for pseudoprinting, explained later */
-integer first_count; /* another variable for pseudoprinting */
-
-@ @<Allocate or initialize ...@>=
-memset(mp->dig,0,23);
-mp->trick_buf = xmalloc((mp->error_line+1),sizeof(ASCII_code));
-
-@ @<Dealloc variables@>=
-xfree(mp->trick_buf);
-
-@ @<Initialize the output routines@>=
-mp->selector=term_only; mp->tally=0; mp->term_offset=0; mp->file_offset=0;
-
-@ Macro abbreviations for output to the terminal and to the log file are
-defined here for convenience. Some systems need special conventions
-for terminal output, and it is possible to adhere to those conventions
-by changing |wterm|, |wterm_ln|, and |wterm_cr| here.
-@^system dependencies@>
-
-@d do_fprintf(f,b) (mp->write_ascii_file)(mp,f,b)
-@d wterm(A) do_fprintf(mp->term_out,(A))
-@d wterm_chr(A) { unsigned char ss[2]; ss[0]=(A); ss[1]=0; do_fprintf(mp->term_out,(char *)ss); }
-@d wterm_cr do_fprintf(mp->term_out,"\n")
-@d wterm_ln(A) { wterm_cr; do_fprintf(mp->term_out,(A)); }
-@d wlog(A) do_fprintf(mp->log_file,(A))
-@d wlog_chr(A) { unsigned char ss[2]; ss[0]=(A); ss[1]=0; do_fprintf(mp->log_file,(char *)ss); }
-@d wlog_cr do_fprintf(mp->log_file, "\n")
-@d wlog_ln(A) { wlog_cr; do_fprintf(mp->log_file,(A)); }
-
-
-@ To end a line of text output, we call |print_ln|. Cases |0..max_write_files|
-use an array |wr_file| that will be declared later.
-
-@d mp_print_text(A) mp_print_str(mp,text((A)))
-
-@<Internal ...@>=
-void mp_print_ln (MP mp);
-void mp_print_visible_char (MP mp, ASCII_code s);
-void mp_print_char (MP mp, ASCII_code k);
-void mp_print (MP mp, const char *s);
-void mp_print_str (MP mp, str_number s);
-void mp_print_nl (MP mp, const char *s);
-void mp_print_two (MP mp,scaled x, scaled y) ;
-void mp_print_scaled (MP mp,scaled s);
-
-@ @<Basic print...@>=
-void mp_print_ln (MP mp) { /* prints an end-of-line */
- switch (mp->selector) {
- case term_and_log:
- wterm_cr; wlog_cr;
- mp->term_offset=0; mp->file_offset=0;
- break;
- case log_only:
- wlog_cr; mp->file_offset=0;
- break;
- case term_only:
- wterm_cr; mp->term_offset=0;
- break;
- case no_print:
- case pseudo:
- case new_string:
- break;
- default:
- do_fprintf(mp->wr_file[(mp->selector-write_file)],"\n");
- }
-} /* note that |tally| is not affected */
-
-@ The |print_visible_char| procedure sends one character to the desired
-destination, using the |xchr| array to map it into an external character
-compatible with |input_ln|. (It assumes that it is always called with
-a visible ASCII character.) All printing comes through |print_ln| or
-|print_char|, which ultimately calls |print_visible_char|, hence these
-routines are the ones that limit lines to at most |max_print_line| characters.
-But we must make an exception for the \ps\ output file since it is not safe
-to cut up lines arbitrarily in \ps.
-
-Procedure |unit_str_room| needs to be declared |forward| here because it calls
-|do_compaction| and |do_compaction| can call the error routines. Actually,
-|unit_str_room| avoids |overflow| errors but it can call |confusion|.
-
-@<Basic printing...@>=
-void mp_print_visible_char (MP mp, ASCII_code s) { /* prints a single character */
- switch (mp->selector) {
- case term_and_log:
- wterm_chr(xchr(s)); wlog_chr(xchr(s));
- incr(mp->term_offset); incr(mp->file_offset);
- if ( mp->term_offset==(unsigned)mp->max_print_line ) {
- wterm_cr; mp->term_offset=0;
- };
- if ( mp->file_offset==(unsigned)mp->max_print_line ) {
- wlog_cr; mp->file_offset=0;
- };
- break;
- case log_only:
- wlog_chr(xchr(s)); incr(mp->file_offset);
- if ( mp->file_offset==(unsigned)mp->max_print_line ) mp_print_ln(mp);
- break;
- case term_only:
- wterm_chr(xchr(s)); incr(mp->term_offset);
- if ( mp->term_offset==(unsigned)mp->max_print_line ) mp_print_ln(mp);
- break;
- case no_print:
- break;
- case pseudo:
- if ( mp->tally<mp->trick_count )
- mp->trick_buf[mp->tally % mp->error_line]=s;
- break;
- case new_string:
- if ( mp->pool_ptr>=mp->max_pool_ptr ) {
- mp_unit_str_room(mp);
- if ( mp->pool_ptr>=mp->pool_size )
- goto DONE; /* drop characters if string space is full */
- };
- append_char(s);
- break;
- default:
- { char ss[2]; ss[0] = xchr(s); ss[1]=0;
- do_fprintf(mp->wr_file[(mp->selector-write_file)],(char *)ss);
- }
- }
-DONE:
- incr(mp->tally);
-}
-
-@ The |print_char| procedure sends one character to the desired destination.
-File names and string expressions might contain |ASCII_code| values that
-can't be printed using |print_visible_char|. These characters will be
-printed in three- or four-symbol form like `\.{\^\^A}' or `\.{\^\^e4}'.
-(This procedure assumes that it is safe to bypass all checks for unprintable
-characters when |selector| is in the range |0..max_write_files-1|.
-The user might want to write unprintable characters.
-
-@d print_lc_hex(A) do { l=(A);
- mp_print_visible_char(mp, (l<10 ? l+'0' : l-10+'a'));
- } while (0)
-
-@<Basic printing...@>=
-void mp_print_char (MP mp, ASCII_code k) { /* prints a single character */
- int l; /* small index or counter */
- if ( mp->selector<pseudo || mp->selector>=write_file) {
- mp_print_visible_char(mp, k);
- } else if ( @<Character |k| cannot be printed@> ) {
- mp_print(mp, "^^");
- if ( k<0100 ) {
- mp_print_visible_char(mp, k+0100);
- } else if ( k<0200 ) {
- mp_print_visible_char(mp, k-0100);
- } else {
- print_lc_hex(k / 16);
- print_lc_hex(k % 16);
- }
- } else {
- mp_print_visible_char(mp, k);
- }
-}
-
-@ An entire string is output by calling |print|. Note that if we are outputting
-the single standard ASCII character \.c, we could call |print("c")|, since
-|"c"=99| is the number of a single-character string, as explained above. But
-|print_char("c")| is quicker, so \MP\ goes directly to the |print_char|
-routine when it knows that this is safe. (The present implementation
-assumes that it is always safe to print a visible ASCII character.)
-@^system dependencies@>
-
-@<Basic print...@>=
-void mp_do_print (MP mp, const char *ss, unsigned int len) { /* prints string |s| */
- unsigned int j = 0;
- while ( j<len ){
- mp_print_char(mp, ss[j]); incr(j);
- }
-}
-
-@
-@<Basic print...@>=
-void mp_print (MP mp, const char *ss) {
- mp_do_print(mp, ss, strlen(ss));
-}
-void mp_print_str (MP mp, str_number s) {
- pool_pointer j; /* current character code position */
- if ( (s<0)||(s>mp->max_str_ptr) ) {
- mp_do_print(mp,"???",3); /* this can't happen */
-@.???@>
- }
- j=mp->str_start[s];
- mp_do_print(mp, (char *)(mp->str_pool+j), (str_stop(s)-j));
-}
-
-
-@ Here is the very first thing that \MP\ prints: a headline that identifies
-the version number and base name. The |term_offset| variable is temporarily
-incorrect, but the discrepancy is not serious since we assume that the banner
-and mem identifier together will occupy at most |max_print_line|
-character positions.
-
-@<Initialize the output...@>=
-wterm (banner);
-wterm (version_string);
-if (mp->mem_ident!=NULL)
- mp_print(mp,mp->mem_ident);
-mp_print_ln(mp);
-update_terminal;
-
-@ The procedure |print_nl| is like |print|, but it makes sure that the
-string appears at the beginning of a new line.
-
-@<Basic print...@>=
-void mp_print_nl (MP mp, const char *s) { /* prints string |s| at beginning of line */
- switch(mp->selector) {
- case term_and_log:
- if ( (mp->term_offset>0)||(mp->file_offset>0) ) mp_print_ln(mp);
- break;
- case log_only:
- if ( mp->file_offset>0 ) mp_print_ln(mp);
- break;
- case term_only:
- if ( mp->term_offset>0 ) mp_print_ln(mp);
- break;
- case no_print:
- case pseudo:
- case new_string:
- break;
- } /* there are no other cases */
- mp_print(mp, s);
-}
-
-@ An array of digits in the range |0..9| is printed by |print_the_digs|.
-
-@<Basic print...@>=
-void mp_print_the_digs (MP mp, eight_bits k) {
- /* prints |dig[k-1]|$\,\ldots\,$|dig[0]| */
- while ( k>0 ){
- decr(k); mp_print_char(mp, '0'+mp->dig[k]);
- }
-}
-
-@ The following procedure, which prints out the decimal representation of a
-given integer |n|, has been written carefully so that it works properly
-if |n=0| or if |(-n)| would cause overflow. It does not apply |%| or |/|
-to negative arguments, since such operations are not implemented consistently
-on all platforms.
-
-@<Basic print...@>=
-void mp_print_int (MP mp,integer n) { /* prints an integer in decimal form */
- integer m; /* used to negate |n| in possibly dangerous cases */
- int k = 0; /* index to current digit; we assume that $|n|<10^{23}$ */
- if ( n<0 ) {
- mp_print_char(mp, '-');
- if ( n>-100000000 ) {
- negate(n);
- } else {
- m=-1-n; n=m / 10; m=(m % 10)+1; k=1;
- if ( m<10 ) {
- mp->dig[0]=m;
- } else {
- mp->dig[0]=0; incr(n);
- }
- }
- }
- do {
- mp->dig[k]=n % 10; n=n / 10; incr(k);
- } while (n!=0);
- mp_print_the_digs(mp, k);
-}
-
-@ @<Internal ...@>=
-void mp_print_int (MP mp,integer n);
-
-@ \MP\ also makes use of a trivial procedure to print two digits. The
-following subroutine is usually called with a parameter in the range |0<=n<=99|.
-
-@c
-void mp_print_dd (MP mp,integer n) { /* prints two least significant digits */
- n=abs(n) % 100;
- mp_print_char(mp, '0'+(n / 10));
- mp_print_char(mp, '0'+(n % 10));
-}
-
-
-@ @<Internal ...@>=
-void mp_print_dd (MP mp,integer n);
-
-@ Here is a procedure that asks the user to type a line of input,
-assuming that the |selector| setting is either |term_only| or |term_and_log|.
-The input is placed into locations |first| through |last-1| of the
-|buffer| array, and echoed on the transcript file if appropriate.
-
-This procedure is never called when |interaction<mp_scroll_mode|.
-
-@d prompt_input(A) do {
- if (!mp->noninteractive) {
- wake_up_terminal; mp_print(mp, (A));
- }
- mp_term_input(mp);
- } while (0) /* prints a string and gets a line of input */
-
-@c
-void mp_term_input (MP mp) { /* gets a line from the terminal */
- size_t k; /* index into |buffer| */
- update_terminal; /* Now the user sees the prompt for sure */
- if (!mp_input_ln(mp, mp->term_in )) {
- if (!mp->noninteractive) {
- mp_fatal_error(mp, "End of file on the terminal!");
-@.End of file on the terminal@>
- } else { /* we are done with this input chunk */
- longjmp(mp->jump_buf,1);
- }
- }
- if (!mp->noninteractive) {
- mp->term_offset=0; /* the user's line ended with \<\rm return> */
- decr(mp->selector); /* prepare to echo the input */
- if ( mp->last!=mp->first ) {
- for (k=mp->first;k<=mp->last-1;k++) {
- mp_print_char(mp, mp->buffer[k]);
- }
- }
- mp_print_ln(mp);
- mp->buffer[mp->last]='%';
- incr(mp->selector); /* restore previous status */
- }
-}
-
-@* \[6] Reporting errors.
-When something anomalous is detected, \MP\ typically does something like this:
-$$\vbox{\halign{#\hfil\cr
-|print_err("Something anomalous has been detected");|\cr
-|help3("This is the first line of my offer to help.")|\cr
-|("This is the second line. I'm trying to")|\cr
-|("explain the best way for you to proceed.");|\cr
-|error;|\cr}}$$
-A two-line help message would be given using |help2|, etc.; these informal
-helps should use simple vocabulary that complements the words used in the
-official error message that was printed. (Outside the U.S.A., the help
-messages should preferably be translated into the local vernacular. Each
-line of help is at most 60 characters long, in the present implementation,
-so that |max_print_line| will not be exceeded.)
-
-The |print_err| procedure supplies a `\.!' before the official message,
-and makes sure that the terminal is awake if a stop is going to occur.
-The |error| procedure supplies a `\..' after the official message, then it
-shows the location of the error; and if |interaction=error_stop_mode|,
-it also enters into a dialog with the user, during which time the help
-message may be printed.
-@^system dependencies@>
-
-@ The global variable |interaction| has four settings, representing increasing
-amounts of user interaction:
-
-@<Exported types@>=
-enum mp_interaction_mode {
- mp_unspecified_mode=0, /* extra value for command-line switch */
- mp_batch_mode, /* omits all stops and omits terminal output */
- mp_nonstop_mode, /* omits all stops */
- mp_scroll_mode, /* omits error stops */
- mp_error_stop_mode /* stops at every opportunity to interact */
-};
-
-@ @<Option variables@>=
-int interaction; /* current level of interaction */
-int noninteractive; /* do we have a terminal? */
-
-@ Set it here so it can be overwritten by the commandline
-
-@<Allocate or initialize ...@>=
-mp->interaction=opt->interaction;
-if (mp->interaction==mp_unspecified_mode || mp->interaction>mp_error_stop_mode)
- mp->interaction=mp_error_stop_mode;
-if (mp->interaction<mp_unspecified_mode)
- mp->interaction=mp_batch_mode;
-mp->noninteractive=opt->noninteractive;
-
-@
-
-@d print_err(A) mp_print_err(mp,(A))
-
-@<Internal ...@>=
-void mp_print_err(MP mp, const char * A);
-
-@ @c
-void mp_print_err(MP mp, const char * A) {
- if ( mp->interaction==mp_error_stop_mode )
- wake_up_terminal;
- mp_print_nl(mp, "! ");
- mp_print(mp, A);
-@.!\relax@>
-}
-
-
-@ \MP\ is careful not to call |error| when the print |selector| setting
-might be unusual. The only possible values of |selector| at the time of
-error messages are
-
-\yskip\hang|no_print| (when |interaction=mp_batch_mode|
- and |log_file| not yet open);
-
-\hang|term_only| (when |interaction>mp_batch_mode| and |log_file| not yet open);
-
-\hang|log_only| (when |interaction=mp_batch_mode| and |log_file| is open);
-
-\hang|term_and_log| (when |interaction>mp_batch_mode| and |log_file| is open).
-
-@<Initialize the print |selector| based on |interaction|@>=
-if ( mp->interaction==mp_batch_mode ) mp->selector=no_print; else mp->selector=term_only
-
-@ A global variable |deletions_allowed| is set |false| if the |get_next|
-routine is active when |error| is called; this ensures that |get_next|
-will never be called recursively.
-@^recursion@>
-
-The global variable |history| records the worst level of error that
-has been detected. It has four possible values: |spotless|, |warning_issued|,
-|error_message_issued|, and |fatal_error_stop|.
-
-Another global variable, |error_count|, is increased by one when an
-|error| occurs without an interactive dialog, and it is reset to zero at
-the end of every statement. If |error_count| reaches 100, \MP\ decides
-that there is no point in continuing further.
-
-@<Types...@>=
-enum mp_history_states {
- mp_spotless=0, /* |history| value when nothing has been amiss yet */
- mp_warning_issued, /* |history| value when |begin_diagnostic| has been called */
- mp_error_message_issued, /* |history| value when |error| has been called */
- mp_fatal_error_stop /* |history| value when termination was premature */
-};
-
-@ @<Glob...@>=
-boolean deletions_allowed; /* is it safe for |error| to call |get_next|? */
-int history; /* has the source input been clean so far? */
-int error_count; /* the number of scrolled errors since the last statement ended */
-
-@ The value of |history| is initially |fatal_error_stop|, but it will
-be changed to |spotless| if \MP\ survives the initialization process.
-
-@<Allocate or ...@>=
-mp->deletions_allowed=true; mp->error_count=0; /* |history| is initialized elsewhere */
-
-@ Since errors can be detected almost anywhere in \MP, we want to declare the
-error procedures near the beginning of the program. But the error procedures
-in turn use some other procedures, which need to be declared |forward|
-before we get to |error| itself.
-
-It is possible for |error| to be called recursively if some error arises
-when |get_next| is being used to delete a token, and/or if some fatal error
-occurs while \MP\ is trying to fix a non-fatal one. But such recursion
-@^recursion@>
-is never more than two levels deep.
-
-@<Declarations@>=
-void mp_get_next (MP mp);
-void mp_term_input (MP mp);
-void mp_show_context (MP mp);
-void mp_begin_file_reading (MP mp);
-void mp_open_log_file (MP mp);
-void mp_clear_for_error_prompt (MP mp);
-void mp_debug_help (MP mp);
-@<Declare the procedure called |flush_string|@>
-
-@ @<Internal ...@>=
-void mp_normalize_selector (MP mp);
-
-@ Individual lines of help are recorded in the array |help_line|, which
-contains entries in positions |0..(help_ptr-1)|. They should be printed
-in reverse order, i.e., with |help_line[0]| appearing last.
-
-@d hlp1(A) mp->help_line[0]=(A); }
-@d hlp2(A) mp->help_line[1]=(A); hlp1
-@d hlp3(A) mp->help_line[2]=(A); hlp2
-@d hlp4(A) mp->help_line[3]=(A); hlp3
-@d hlp5(A) mp->help_line[4]=(A); hlp4
-@d hlp6(A) mp->help_line[5]=(A); hlp5
-@d help0 mp->help_ptr=0 /* sometimes there might be no help */
-@d help1 { mp->help_ptr=1; hlp1 /* use this with one help line */
-@d help2 { mp->help_ptr=2; hlp2 /* use this with two help lines */
-@d help3 { mp->help_ptr=3; hlp3 /* use this with three help lines */
-@d help4 { mp->help_ptr=4; hlp4 /* use this with four help lines */
-@d help5 { mp->help_ptr=5; hlp5 /* use this with five help lines */
-@d help6 { mp->help_ptr=6; hlp6 /* use this with six help lines */
-
-@<Glob...@>=
-const char * help_line[6]; /* helps for the next |error| */
-unsigned int help_ptr; /* the number of help lines present */
-boolean use_err_help; /* should the |err_help| string be shown? */
-str_number err_help; /* a string set up by \&{errhelp} */
-str_number filename_template; /* a string set up by \&{filenametemplate} */
-
-@ @<Allocate or ...@>=
-mp->help_ptr=0; mp->use_err_help=false; mp->err_help=0; mp->filename_template=0;
-
-@ The |jump_out| procedure just cuts across all active procedure levels and
-goes to |end_of_MP|. This is the only nonlocal |goto| statement in the
-whole program. It is used when there is no recovery from a particular error.
-
-The program uses a |jump_buf| to handle this, this is initialized at three
-spots: the start of |mp_new|, the start of |mp_initialize|, and the start
-of |mp_run|. Those are the only library enty points.
-
-@^system dependencies@>
-
-@<Glob...@>=
-jmp_buf jump_buf;
-
-@ @<Install and test the non-local jump buffer@>=
-if (setjmp(mp->jump_buf) != 0) { return mp->history; }
-
-@ @<Setup the non-local jump buffer in |mp_new|@>=
-if (setjmp(mp->jump_buf) != 0) return NULL;
-
-
-@ If the array of internals is still |NULL| when |jump_out| is called, a
-crash occured during initialization, and it is not safe to run the normal
-cleanup routine.
-
-@<Error hand...@>=
-void mp_jump_out (MP mp) {
- if(mp->internal!=NULL)
- mp_close_files_and_terminate(mp);
- longjmp(mp->jump_buf,1);
-}
-
-@ Here now is the general |error| routine.
-
-@<Error hand...@>=
-void mp_error (MP mp) { /* completes the job of error reporting */
- ASCII_code c; /* what the user types */
- integer s1,s2,s3; /* used to save global variables when deleting tokens */
- pool_pointer j; /* character position being printed */
- if ( mp->history<mp_error_message_issued )
- mp->history=mp_error_message_issued;
- mp_print_char(mp, '.'); mp_show_context(mp);
- if ((!mp->noninteractive) && (mp->interaction==mp_error_stop_mode )) {
- @<Get user's advice and |return|@>;
- }
- incr(mp->error_count);
- if ( mp->error_count==100 ) {
- mp_print_nl(mp,"(That makes 100 errors; please try again.)");
-@.That makes 100 errors...@>
- mp->history=mp_fatal_error_stop; mp_jump_out(mp);
- }
- @<Put help message on the transcript file@>;
-}
-void mp_warn (MP mp, const char *msg) {
- int saved_selector = mp->selector;
- mp_normalize_selector(mp);
- mp_print_nl(mp,"Warning: ");
- mp_print(mp,msg);
- mp_print_ln(mp);
- mp->selector = saved_selector;
-}
-
-@ @<Exported function ...@>=
-void mp_error (MP mp);
-void mp_warn (MP mp, const char *msg);
-
-
-@ @<Get user's advice...@>=
-while (1) {
-CONTINUE:
- mp_clear_for_error_prompt(mp); prompt_input("? ");
-@.?\relax@>
- if ( mp->last==mp->first ) return;
- c=mp->buffer[mp->first];
- if ( c>='a' ) c=c+'A'-'a'; /* convert to uppercase */
- @<Interpret code |c| and |return| if done@>;
-}
-
-@ It is desirable to provide an `\.E' option here that gives the user
-an easy way to return from \MP\ to the system editor, with the offending
-line ready to be edited. But such an extension requires some system
-wizardry, so the present implementation simply types out the name of the
-file that should be
-edited and the relevant line number.
-@^system dependencies@>
-
-@<Exported types@>=
-typedef void (*mp_run_editor_command)(MP, char *, int);
-
-@ @<Option variables@>=
-mp_run_editor_command run_editor;
-
-@ @<Allocate or initialize ...@>=
-set_callback_option(run_editor);
-
-@ @<Declarations@>=
-void mp_run_editor (MP mp, char *fname, int fline);
-
-@ @c void mp_run_editor (MP mp, char *fname, int fline) {
- mp_print_nl(mp, "You want to edit file ");
-@.You want to edit file x@>
- mp_print(mp, fname);
- mp_print(mp, " at line ");
- mp_print_int(mp, fline);
- mp->interaction=mp_scroll_mode;
- mp_jump_out(mp);
-}
-
-@
-There is a secret `\.D' option available when the debugging routines haven't
-been commented~out.
-@^debugging@>
-
-@<Interpret code |c| and |return| if done@>=
-switch (c) {
-case '0': case '1': case '2': case '3': case '4':
-case '5': case '6': case '7': case '8': case '9':
- if ( mp->deletions_allowed ) {
- @<Delete |c-"0"| tokens and |continue|@>;
- }
- break;
-#ifdef DEBUG
-case 'D':
- mp_debug_help(mp); continue;
- break;
-#endif
-case 'E':
- if ( mp->file_ptr>0 ){
- (mp->run_editor)(mp,
- str(mp->input_stack[mp->file_ptr].name_field),
- mp_true_line(mp));
- }
- break;
-case 'H':
- @<Print the help information and |continue|@>;
- break;
-case 'I':
- @<Introduce new material from the terminal and |return|@>;
- break;
-case 'Q': case 'R': case 'S':
- @<Change the interaction level and |return|@>;
- break;
-case 'X':
- mp->interaction=mp_scroll_mode; mp_jump_out(mp);
- break;
-default:
- break;
-}
-@<Print the menu of available options@>
-
-@ @<Print the menu...@>=
-{
- mp_print(mp, "Type <return> to proceed, S to scroll future error messages,");
-@.Type <return> to proceed...@>
- mp_print_nl(mp, "R to run without stopping, Q to run quietly,");
- mp_print_nl(mp, "I to insert something, ");
- if ( mp->file_ptr>0 )
- mp_print(mp, "E to edit your file,");
- if ( mp->deletions_allowed )
- mp_print_nl(mp, "1 or ... or 9 to ignore the next 1 to 9 tokens of input,");
- mp_print_nl(mp, "H for help, X to quit.");
-}
-
-@ Here the author of \MP\ apologizes for making use of the numerical
-relation between |"Q"|, |"R"|, |"S"|, and the desired interaction settings
-|mp_batch_mode|, |mp_nonstop_mode|, |mp_scroll_mode|.
-@^Knuth, Donald Ervin@>
-
-@<Change the interaction...@>=
-{
- mp->error_count=0; mp->interaction=mp_batch_mode+c-'Q';
- mp_print(mp, "OK, entering ");
- switch (c) {
- case 'Q': mp_print(mp, "batchmode"); decr(mp->selector); break;
- case 'R': mp_print(mp, "nonstopmode"); break;
- case 'S': mp_print(mp, "scrollmode"); break;
- } /* there are no other cases */
- mp_print(mp, "..."); mp_print_ln(mp); update_terminal; return;
-}
-
-@ When the following code is executed, |buffer[(first+1)..(last-1)]| may
-contain the material inserted by the user; otherwise another prompt will
-be given. In order to understand this part of the program fully, you need
-to be familiar with \MP's input stacks.
-
-@<Introduce new material...@>=
-{
- mp_begin_file_reading(mp); /* enter a new syntactic level for terminal input */
- if ( mp->last>mp->first+1 ) {
- loc=mp->first+1; mp->buffer[mp->first]=' ';
- } else {
- prompt_input("insert>"); loc=mp->first;
-@.insert>@>
- };
- mp->first=mp->last+1; mp->cur_input.limit_field=mp->last; return;
-}
-
-@ We allow deletion of up to 99 tokens at a time.
-
-@<Delete |c-"0"| tokens...@>=
-{
- s1=mp->cur_cmd; s2=mp->cur_mod; s3=mp->cur_sym; mp->OK_to_interrupt=false;
- if ( (mp->last>mp->first+1) && (mp->buffer[mp->first+1]>='0')&&(mp->buffer[mp->first+1]<='9') )
- c=c*10+mp->buffer[mp->first+1]-'0'*11;
- else
- c=c-'0';
- while ( c>0 ) {
- mp_get_next(mp); /* one-level recursive call of |error| is possible */
- @<Decrease the string reference count, if the current token is a string@>;
- decr(c);
- };
- mp->cur_cmd=s1; mp->cur_mod=s2; mp->cur_sym=s3; mp->OK_to_interrupt=true;
- help2("I have just deleted some text, as you asked.")
- ("You can now delete more, or insert, or whatever.");
- mp_show_context(mp);
- goto CONTINUE;
-}
-
-@ @<Print the help info...@>=
-{
- if ( mp->use_err_help ) {
- @<Print the string |err_help|, possibly on several lines@>;
- mp->use_err_help=false;
- } else {
- if ( mp->help_ptr==0 ) {
- help2("Sorry, I don't know how to help in this situation.")
- ("Maybe you should try asking a human?");
- }
- do {
- decr(mp->help_ptr); mp_print(mp, mp->help_line[mp->help_ptr]); mp_print_ln(mp);
- } while (mp->help_ptr!=0);
- };
- help4("Sorry, I already gave what help I could...")
- ("Maybe you should try asking a human?")
- ("An error might have occurred before I noticed any problems.")
- ("``If all else fails, read the instructions.''");
- goto CONTINUE;
-}
-
-@ @<Print the string |err_help|, possibly on several lines@>=
-j=mp->str_start[mp->err_help];
-while ( j<str_stop(mp->err_help) ) {
- if ( mp->str_pool[j]!='%' ) mp_print_str(mp, mp->str_pool[j]);
- else if ( j+1==str_stop(mp->err_help) ) mp_print_ln(mp);
- else if ( mp->str_pool[j+1]!='%' ) mp_print_ln(mp);
- else { incr(j); mp_print_char(mp, '%'); };
- incr(j);
-}
-
-@ @<Put help message on the transcript file@>=
-if ( mp->interaction>mp_batch_mode ) decr(mp->selector); /* avoid terminal output */
-if ( mp->use_err_help ) {
- mp_print_nl(mp, "");
- @<Print the string |err_help|, possibly on several lines@>;
-} else {
- while ( mp->help_ptr>0 ){
- decr(mp->help_ptr); mp_print_nl(mp, mp->help_line[mp->help_ptr]);
- };
-}
-mp_print_ln(mp);
-if ( mp->interaction>mp_batch_mode ) incr(mp->selector); /* re-enable terminal output */
-mp_print_ln(mp)
-
-@ In anomalous cases, the print selector might be in an unknown state;
-the following subroutine is called to fix things just enough to keep
-running a bit longer.
-
-@c
-void mp_normalize_selector (MP mp) {
- if ( mp->log_opened ) mp->selector=term_and_log;
- else mp->selector=term_only;
- if ( mp->job_name==NULL ) mp_open_log_file(mp);
- if ( mp->interaction==mp_batch_mode ) decr(mp->selector);
-}
-
-@ The following procedure prints \MP's last words before dying.
-
-@d succumb { if ( mp->interaction==mp_error_stop_mode )
- mp->interaction=mp_scroll_mode; /* no more interaction */
- if ( mp->log_opened ) mp_error(mp);
- /*| if ( mp->interaction>mp_batch_mode ) mp_debug_help(mp); |*/
- mp->history=mp_fatal_error_stop; mp_jump_out(mp); /* irrecoverable error */
- }
-
-@<Error hand...@>=
-void mp_fatal_error (MP mp, const char *s) { /* prints |s|, and that's it */
- mp_normalize_selector(mp);
- print_err("Emergency stop"); help1(s); succumb;
-@.Emergency stop@>
-}
-
-@ @<Exported function ...@>=
-void mp_fatal_error (MP mp, const char *s);
-
-
-@ Here is the most dreaded error message.
-
-@<Error hand...@>=
-void mp_overflow (MP mp, const char *s, integer n) { /* stop due to finiteness */
- mp_normalize_selector(mp);
- print_err("MetaPost capacity exceeded, sorry [");
-@.MetaPost capacity exceeded ...@>
- mp_print(mp, s); mp_print_char(mp, '='); mp_print_int(mp, n); mp_print_char(mp, ']');
- help2("If you really absolutely need more capacity,")
- ("you can ask a wizard to enlarge me.");
- succumb;
-}
-
-@ @<Internal library declarations@>=
-void mp_overflow (MP mp, const char *s, integer n);
-
-@ The program might sometime run completely amok, at which point there is
-no choice but to stop. If no previous error has been detected, that's bad
-news; a message is printed that is really intended for the \MP\
-maintenance person instead of the user (unless the user has been
-particularly diabolical). The index entries for `this can't happen' may
-help to pinpoint the problem.
-@^dry rot@>
-
-@<Internal library ...@>=
-void mp_confusion (MP mp, const char *s);
-
-@ @<Error hand...@>=
-void mp_confusion (MP mp, const char *s) {
- /* consistency check violated; |s| tells where */
- mp_normalize_selector(mp);
- if ( mp->history<mp_error_message_issued ) {
- print_err("This can't happen ("); mp_print(mp, s); mp_print_char(mp, ')');
-@.This can't happen@>
- help1("I'm broken. Please show this to someone who can fix can fix");
- } else {
- print_err("I can\'t go on meeting you like this");
-@.I can't go on...@>
- help2("One of your faux pas seems to have wounded me deeply...")
- ("in fact, I'm barely conscious. Please fix it and try again.");
- }
- succumb;
-}
-
-@ Users occasionally want to interrupt \MP\ while it's running.
-If the runtime system allows this, one can implement
-a routine that sets the global variable |interrupt| to some nonzero value
-when such an interrupt is signaled. Otherwise there is probably at least
-a way to make |interrupt| nonzero using the C debugger.
-@^system dependencies@>
-@^debugging@>
-
-@d check_interrupt { if ( mp->interrupt!=0 )
- mp_pause_for_instructions(mp); }
-
-@<Global...@>=
-integer interrupt; /* should \MP\ pause for instructions? */
-boolean OK_to_interrupt; /* should interrupts be observed? */
-integer run_state; /* are we processing input ?*/
-
-@ @<Allocate or ...@>=
-mp->interrupt=0; mp->OK_to_interrupt=true; mp->run_state=0;
-
-@ When an interrupt has been detected, the program goes into its
-highest interaction level and lets the user have the full flexibility of
-the |error| routine. \MP\ checks for interrupts only at times when it is
-safe to do this.
-
-@c
-void mp_pause_for_instructions (MP mp) {
- if ( mp->OK_to_interrupt ) {
- mp->interaction=mp_error_stop_mode;
- if ( (mp->selector==log_only)||(mp->selector==no_print) )
- incr(mp->selector);
- print_err("Interruption");
-@.Interruption@>
- help3("You rang?")
- ("Try to insert some instructions for me (e.g.,`I show x'),")
- ("unless you just want to quit by typing `X'.");
- mp->deletions_allowed=false; mp_error(mp); mp->deletions_allowed=true;
- mp->interrupt=0;
- }
-}
-
-@ Many of \MP's error messages state that a missing token has been
-inserted behind the scenes. We can save string space and program space
-by putting this common code into a subroutine.
-
-@c
-void mp_missing_err (MP mp, const char *s) {
- print_err("Missing `"); mp_print(mp, s); mp_print(mp, "' has been inserted");
-@.Missing...inserted@>
-}
-
-@* \[7] Arithmetic with scaled numbers.
-The principal computations performed by \MP\ are done entirely in terms of
-integers less than $2^{31}$ in magnitude; thus, the arithmetic specified in this
-program can be carried out in exactly the same way on a wide variety of
-computers, including some small ones.
-@^small computers@>
-
-But C does not rigidly define the |/| operation in the case of negative
-dividends; for example, the result of |(-2*n-1) / 2| is |-(n+1)| on some
-computers and |-n| on others (is this true ?). There are two principal
-types of arithmetic: ``translation-preserving,'' in which the identity
-|(a+q*b)/b=(a/b)+q| is valid; and ``negation-preserving,'' in which
-|(-a)/b=-(a/b)|. This leads to two \MP s, which can produce
-different results, although the differences should be negligible when the
-language is being used properly. The \TeX\ processor has been defined
-carefully so that both varieties of arithmetic will produce identical
-output, but it would be too inefficient to constrain \MP\ in a similar way.
-
-@d el_gordo 017777777777 /* $2^{31}-1$, the largest value that \MP\ likes */
-
-@ One of \MP's most common operations is the calculation of
-$\lfloor{a+b\over2}\rfloor$,
-the midpoint of two given integers |a| and~|b|. The most decent way to do
-this is to write `|(a+b)/2|'; but on many machines it is more efficient
-to calculate `|(a+b)>>1|'.
-
-Therefore the midpoint operation will always be denoted by `|half(a+b)|'
-in this program. If \MP\ is being implemented with languages that permit
-binary shifting, the |half| macro should be changed to make this operation
-as efficient as possible. Since some systems have shift operators that can
-only be trusted to work on positive numbers, there is also a macro |halfp|
-that is used only when the quantity being halved is known to be positive
-or zero.
-
-@d half(A) ((A) / 2)
-@d halfp(A) ((A) >> 1)
-
-@ A single computation might use several subroutine calls, and it is
-desirable to avoid producing multiple error messages in case of arithmetic
-overflow. So the routines below set the global variable |arith_error| to |true|
-instead of reporting errors directly to the user.
-@^overflow in arithmetic@>
-
-@<Glob...@>=
-boolean arith_error; /* has arithmetic overflow occurred recently? */
-
-@ @<Allocate or ...@>=
-mp->arith_error=false;
-
-@ At crucial points the program will say |check_arith|, to test if
-an arithmetic error has been detected.
-
-@d check_arith { if ( mp->arith_error ) mp_clear_arith(mp); }
-
-@c
-void mp_clear_arith (MP mp) {
- print_err("Arithmetic overflow");
-@.Arithmetic overflow@>
- help4("Uh, oh. A little while ago one of the quantities that I was")
- ("computing got too large, so I'm afraid your answers will be")
- ("somewhat askew. You'll probably have to adopt different")
- ("tactics next time. But I shall try to carry on anyway.");
- mp_error(mp);
- mp->arith_error=false;
-}
-
-@ Addition is not always checked to make sure that it doesn't overflow,
-but in places where overflow isn't too unlikely the |slow_add| routine
-is used.
-
-@c integer mp_slow_add (MP mp,integer x, integer y) {
- if ( x>=0 ) {
- if ( y<=el_gordo-x ) {
- return x+y;
- } else {
- mp->arith_error=true;
- return el_gordo;
- }
- } else if ( -y<=el_gordo+x ) {
- return x+y;
- } else {
- mp->arith_error=true;
- return -el_gordo;
- }
-}
-
-@ Fixed-point arithmetic is done on {\sl scaled integers\/} that are multiples
-of $2^{-16}$. In other words, a binary point is assumed to be sixteen bit
-positions from the right end of a binary computer word.
-
-@d quarter_unit 040000 /* $2^{14}$, represents 0.250000 */
-@d half_unit 0100000 /* $2^{15}$, represents 0.50000 */
-@d three_quarter_unit 0140000 /* $3\cdot2^{14}$, represents 0.75000 */
-@d unity 0200000 /* $2^{16}$, represents 1.00000 */
-@d two 0400000 /* $2^{17}$, represents 2.00000 */
-@d three 0600000 /* $2^{17}+2^{16}$, represents 3.00000 */
-
-@<Types...@>=
-typedef integer scaled; /* this type is used for scaled integers */
-typedef unsigned char small_number; /* this type is self-explanatory */
-
-@ The following function is used to create a scaled integer from a given decimal
-fraction $(.d_0d_1\ldots d_{k-1})$, where |0<=k<=17|. The digit $d_i$ is
-given in |dig[i]|, and the calculation produces a correctly rounded result.
-
-@c
-scaled mp_round_decimals (MP mp,small_number k) {
- /* converts a decimal fraction */
- integer a = 0; /* the accumulator */
- while ( k-->0 ) {
- a=(a+mp->dig[k]*two) / 10;
- }
- return halfp(a+1);
-}
-
-@ Conversely, here is a procedure analogous to |print_int|. If the output
-of this procedure is subsequently read by \MP\ and converted by the
-|round_decimals| routine above, it turns out that the original value will
-be reproduced exactly. A decimal point is printed only if the value is
-not an integer. If there is more than one way to print the result with
-the optimum number of digits following the decimal point, the closest
-possible value is given.
-
-The invariant relation in the \&{repeat} loop is that a sequence of
-decimal digits yet to be printed will yield the original number if and only if
-they form a fraction~$f$ in the range $s-\delta\L10\cdot2^{16}f<s$.
-We can stop if and only if $f=0$ satisfies this condition; the loop will
-terminate before $s$ can possibly become zero.
-
-@<Basic printing...@>=
-void mp_print_scaled (MP mp,scaled s) { /* prints scaled real, rounded to five digits */
- scaled delta; /* amount of allowable inaccuracy */
- if ( s<0 ) {
- mp_print_char(mp, '-');
- negate(s); /* print the sign, if negative */
- }
- mp_print_int(mp, s / unity); /* print the integer part */
- s=10*(s % unity)+5;
- if ( s!=5 ) {
- delta=10;
- mp_print_char(mp, '.');
- do {
- if ( delta>unity )
- s=s+0100000-(delta / 2); /* round the final digit */
- mp_print_char(mp, '0'+(s / unity));
- s=10*(s % unity);
- delta=delta*10;
- } while (s>delta);
- }
-}
-
-@ We often want to print two scaled quantities in parentheses,
-separated by a comma.
-
-@<Basic printing...@>=
-void mp_print_two (MP mp,scaled x, scaled y) { /* prints `|(x,y)|' */
- mp_print_char(mp, '(');
- mp_print_scaled(mp, x);
- mp_print_char(mp, ',');
- mp_print_scaled(mp, y);
- mp_print_char(mp, ')');
-}
-
-@ The |scaled| quantities in \MP\ programs are generally supposed to be
-less than $2^{12}$ in absolute value, so \MP\ does much of its internal
-arithmetic with 28~significant bits of precision. A |fraction| denotes
-a scaled integer whose binary point is assumed to be 28 bit positions
-from the right.
-
-@d fraction_half 01000000000 /* $2^{27}$, represents 0.50000000 */
-@d fraction_one 02000000000 /* $2^{28}$, represents 1.00000000 */
-@d fraction_two 04000000000 /* $2^{29}$, represents 2.00000000 */
-@d fraction_three 06000000000 /* $3\cdot2^{28}$, represents 3.00000000 */
-@d fraction_four 010000000000 /* $2^{30}$, represents 4.00000000 */
-
-@<Types...@>=
-typedef integer fraction; /* this type is used for scaled fractions */
-
-@ In fact, the two sorts of scaling discussed above aren't quite
-sufficient; \MP\ has yet another, used internally to keep track of angles
-in units of $2^{-20}$ degrees.
-
-@d forty_five_deg 0264000000 /* $45\cdot2^{20}$, represents $45^\circ$ */
-@d ninety_deg 0550000000 /* $90\cdot2^{20}$, represents $90^\circ$ */
-@d one_eighty_deg 01320000000 /* $180\cdot2^{20}$, represents $180^\circ$ */
-@d three_sixty_deg 02640000000 /* $360\cdot2^{20}$, represents $360^\circ$ */
-
-@<Types...@>=
-typedef integer angle; /* this type is used for scaled angles */
-
-@ The |make_fraction| routine produces the |fraction| equivalent of
-|p/q|, given integers |p| and~|q|; it computes the integer
-$f=\lfloor2^{28}p/q+{1\over2}\rfloor$, when $p$ and $q$ are
-positive. If |p| and |q| are both of the same scaled type |t|,
-the ``type relation'' |make_fraction(t,t)=fraction| is valid;
-and it's also possible to use the subroutine ``backwards,'' using
-the relation |make_fraction(t,fraction)=t| between scaled types.
-
-If the result would have magnitude $2^{31}$ or more, |make_fraction|
-sets |arith_error:=true|. Most of \MP's internal computations have
-been designed to avoid this sort of error.
-
-If this subroutine were programmed in assembly language on a typical
-machine, we could simply compute |(@t$2^{28}$@>*p)div q|, since a
-double-precision product can often be input to a fixed-point division
-instruction. But when we are restricted to int-eger arithmetic it
-is necessary either to resort to multiple-precision maneuvering
-or to use a simple but slow iteration. The multiple-precision technique
-would be about three times faster than the code adopted here, but it
-would be comparatively long and tricky, involving about sixteen
-additional multiplications and divisions.
-
-This operation is part of \MP's ``inner loop''; indeed, it will
-consume nearly 10\pct! of the running time (exclusive of input and output)
-if the code below is left unchanged. A machine-dependent recoding
-will therefore make \MP\ run faster. The present implementation
-is highly portable, but slow; it avoids multiplication and division
-except in the initial stage. System wizards should be careful to
-replace it with a routine that is guaranteed to produce identical
-results in all cases.
-@^system dependencies@>
-
-As noted below, a few more routines should also be replaced by machine-dependent
-code, for efficiency. But when a procedure is not part of the ``inner loop,''
-such changes aren't advisable; simplicity and robustness are
-preferable to trickery, unless the cost is too high.
-@^inner loop@>
-
-@<Internal ...@>=
-fraction mp_make_fraction (MP mp,integer p, integer q);
-integer mp_take_scaled (MP mp,integer q, scaled f) ;
-
-@ If FIXPT is not defined, we need these preprocessor values
-
-@d ELGORDO 0x7fffffff
-@d TWEXP31 2147483648.0
-@d TWEXP28 268435456.0
-@d TWEXP16 65536.0
-@d TWEXP_16 (1.0/65536.0)
-@d TWEXP_28 (1.0/268435456.0)
-
-
-@c
-fraction mp_make_fraction (MP mp,integer p, integer q) {
-#ifdef FIXPT
- integer f; /* the fraction bits, with a leading 1 bit */
- integer n; /* the integer part of $\vert p/q\vert$ */
- integer be_careful; /* disables certain compiler optimizations */
- boolean negative = false; /* should the result be negated? */
- if ( p<0 ) {
- negate(p); negative=true;
- }
- if ( q<=0 ) {
-#ifdef DEBUG
- if ( q==0 ) mp_confusion(mp, '/');
-#endif
-@:this can't happen /}{\quad \./@>
- negate(q); negative = ! negative;
- };
- n=p / q; p=p % q;
- if ( n>=8 ){
- mp->arith_error=true;
- return ( negative ? -el_gordo : el_gordo);
- } else {
- n=(n-1)*fraction_one;
- @<Compute $f=\lfloor 2^{28}(1+p/q)+{1\over2}\rfloor$@>;
- return (negative ? (-(f+n)) : (f+n));
- }
-#else /* FIXPT */
- register double d;
- register integer i;
-#ifdef DEBUG
- if (q==0) mp_confusion(mp,'/');
-#endif /* DEBUG */
- d = TWEXP28 * (double)p /(double)q;
- if ((p^q) >= 0) {
- d += 0.5;
- if (d>=TWEXP31) {mp->arith_error=true; return ELGORDO;}
- i = (integer) d;
- if (d==i && ( ((q>0 ? -q : q)&077777)
- * (((i&037777)<<1)-1) & 04000)!=0) --i;
- } else {
- d -= 0.5;
- if (d<= -TWEXP31) {mp->arith_error=true; return -ELGORDO;}
- i = (integer) d;
- if (d==i && ( ((q>0 ? q : -q)&077777)
- * (((i&037777)<<1)+1) & 04000)!=0) ++i;
- }
- return i;
-#endif /* FIXPT */
-}
-
-@ The |repeat| loop here preserves the following invariant relations
-between |f|, |p|, and~|q|:
-(i)~|0<=p<q|; (ii)~$fq+p=2^k(q+p_0)$, where $k$ is an integer and
-$p_0$ is the original value of~$p$.
-
-Notice that the computation specifies
-|(p-q)+p| instead of |(p+p)-q|, because the latter could overflow.
-Let us hope that optimizing compilers do not miss this point; a
-special variable |be_careful| is used to emphasize the necessary
-order of computation. Optimizing compilers should keep |be_careful|
-in a register, not store it in memory.
-@^inner loop@>
-
-@<Compute $f=\lfloor 2^{28}(1+p/q)+{1\over2}\rfloor$@>=
-{
- f=1;
- do {
- be_careful=p-q; p=be_careful+p;
- if ( p>=0 ) {
- f=f+f+1;
- } else {
- f+=f; p=p+q;
- }
- } while (f<fraction_one);
- be_careful=p-q;
- if ( be_careful+p>=0 ) incr(f);
-}
-
-@ The dual of |make_fraction| is |take_fraction|, which multiplies a
-given integer~|q| by a fraction~|f|. When the operands are positive, it
-computes $p=\lfloor qf/2^{28}+{1\over2}\rfloor$, a symmetric function
-of |q| and~|f|.
-
-This routine is even more ``inner loopy'' than |make_fraction|;
-the present implementation consumes almost 20\pct! of \MP's computation
-time during typical jobs, so a machine-language substitute is advisable.
-@^inner loop@> @^system dependencies@>
-
-@<Declarations@>=
-integer mp_take_fraction (MP mp,integer q, fraction f) ;
-
-@ @c
-#ifdef FIXPT
-integer mp_take_fraction (MP mp,integer q, fraction f) {
- integer p; /* the fraction so far */
- boolean negative; /* should the result be negated? */
- integer n; /* additional multiple of $q$ */
- integer be_careful; /* disables certain compiler optimizations */
- @<Reduce to the case that |f>=0| and |q>=0|@>;
- if ( f<fraction_one ) {
- n=0;
- } else {
- n=f / fraction_one; f=f % fraction_one;
- if ( q<=el_gordo / n ) {
- n=n*q ;
- } else {
- mp->arith_error=true; n=el_gordo;
- }
- }
- f=f+fraction_one;
- @<Compute $p=\lfloor qf/2^{28}+{1\over2}\rfloor-q$@>;
- be_careful=n-el_gordo;
- if ( be_careful+p>0 ){
- mp->arith_error=true; n=el_gordo-p;
- }
- if ( negative )
- return (-(n+p));
- else
- return (n+p);
-#else /* FIXPT */
-integer mp_take_fraction (MP mp,integer p, fraction q) {
- register double d;
- register integer i;
- d = (double)p * (double)q * TWEXP_28;
- if ((p^q) >= 0) {
- d += 0.5;
- if (d>=TWEXP31) {
- if (d!=TWEXP31 || (((p&077777)*(q&077777))&040000)==0)
- mp->arith_error = true;
- return ELGORDO;
- }
- i = (integer) d;
- if (d==i && (((p&077777)*(q&077777))&040000)!=0) --i;
- } else {
- d -= 0.5;
- if (d<= -TWEXP31) {
- if (d!= -TWEXP31 || ((-(p&077777)*(q&077777))&040000)==0)
- mp->arith_error = true;
- return -ELGORDO;
- }
- i = (integer) d;
- if (d==i && ((-(p&077777)*(q&077777))&040000)!=0) ++i;
- }
- return i;
-#endif /* FIXPT */
-}
-
-@ @<Reduce to the case that |f>=0| and |q>=0|@>=
-if ( f>=0 ) {
- negative=false;
-} else {
- negate( f); negative=true;
-}
-if ( q<0 ) {
- negate(q); negative=! negative;
-}
-
-@ The invariant relations in this case are (i)~$\lfloor(qf+p)/2^k\rfloor
-=\lfloor qf_0/2^{28}+{1\over2}\rfloor$, where $k$ is an integer and
-$f_0$ is the original value of~$f$; (ii)~$2^k\L f<2^{k+1}$.
-@^inner loop@>
-
-@<Compute $p=\lfloor qf/2^{28}+{1\over2}\rfloor-q$@>=
-p=fraction_half; /* that's $2^{27}$; the invariants hold now with $k=28$ */
-if ( q<fraction_four ) {
- do {
- if ( odd(f) ) p=halfp(p+q); else p=halfp(p);
- f=halfp(f);
- } while (f!=1);
-} else {
- do {
- if ( odd(f) ) p=p+halfp(q-p); else p=halfp(p);
- f=halfp(f);
- } while (f!=1);
-}
-
-
-@ When we want to multiply something by a |scaled| quantity, we use a scheme
-analogous to |take_fraction| but with a different scaling.
-Given positive operands, |take_scaled|
-computes the quantity $p=\lfloor qf/2^{16}+{1\over2}\rfloor$.
-
-Once again it is a good idea to use a machine-language replacement if
-possible; otherwise |take_scaled| will use more than 2\pct! of the running time
-when the Computer Modern fonts are being generated.
-@^inner loop@>
-
-@c
-#ifdef FIXPT
-integer mp_take_scaled (MP mp,integer q, scaled f) {
- integer p; /* the fraction so far */
- boolean negative; /* should the result be negated? */
- integer n; /* additional multiple of $q$ */
- integer be_careful; /* disables certain compiler optimizations */
- @<Reduce to the case that |f>=0| and |q>=0|@>;
- if ( f<unity ) {
- n=0;
- } else {
- n=f / unity; f=f % unity;
- if ( q<=el_gordo / n ) {
- n=n*q;
- } else {
- mp->arith_error=true; n=el_gordo;
- }
- }
- f=f+unity;
- @<Compute $p=\lfloor qf/2^{16}+{1\over2}\rfloor-q$@>;
- be_careful=n-el_gordo;
- if ( be_careful+p>0 ) {
- mp->arith_error=true; n=el_gordo-p;
- }
- return ( negative ?(-(n+p)) :(n+p));
-#else /* FIXPT */
-integer mp_take_scaled (MP mp,integer p, scaled q) {
- register double d;
- register integer i;
- d = (double)p * (double)q * TWEXP_16;
- if ((p^q) >= 0) {
- d += 0.5;
- if (d>=TWEXP31) {
- if (d!=TWEXP31 || (((p&077777)*(q&077777))&040000)==0)
- mp->arith_error = true;
- return ELGORDO;
- }
- i = (integer) d;
- if (d==i && (((p&077777)*(q&077777))&040000)!=0) --i;
- } else {
- d -= 0.5;
- if (d<= -TWEXP31) {
- if (d!= -TWEXP31 || ((-(p&077777)*(q&077777))&040000)==0)
- mp->arith_error = true;
- return -ELGORDO;
- }
- i = (integer) d;
- if (d==i && ((-(p&077777)*(q&077777))&040000)!=0) ++i;
- }
- return i;
-#endif /* FIXPT */
-}
-
-@ @<Compute $p=\lfloor qf/2^{16}+{1\over2}\rfloor-q$@>=
-p=half_unit; /* that's $2^{15}$; the invariants hold now with $k=16$ */
-@^inner loop@>
-if ( q<fraction_four ) {
- do {
- p = (odd(f) ? halfp(p+q) : halfp(p));
- f=halfp(f);
- } while (f!=1);
-} else {
- do {
- p = (odd(f) ? p+halfp(q-p) : halfp(p));
- f=halfp(f);
- } while (f!=1);
-}
-
-@ For completeness, there's also |make_scaled|, which computes a
-quotient as a |scaled| number instead of as a |fraction|.
-In other words, the result is $\lfloor2^{16}p/q+{1\over2}\rfloor$, if the
-operands are positive. \ (This procedure is not used especially often,
-so it is not part of \MP's inner loop.)
-
-@<Internal library ...@>=
-scaled mp_make_scaled (MP mp,integer p, integer q) ;
-
-@ @c
-scaled mp_make_scaled (MP mp,integer p, integer q) {
-#ifdef FIXPT
- integer f; /* the fraction bits, with a leading 1 bit */
- integer n; /* the integer part of $\vert p/q\vert$ */
- boolean negative; /* should the result be negated? */
- integer be_careful; /* disables certain compiler optimizations */
- if ( p>=0 ) negative=false;
- else { negate(p); negative=true; };
- if ( q<=0 ) {
-#ifdef DEBUG
- if ( q==0 ) mp_confusion(mp, "/");
-@:this can't happen /}{\quad \./@>
-#endif
- negate(q); negative=! negative;
- }
- n=p / q; p=p % q;
- if ( n>=0100000 ) {
- mp->arith_error=true;
- return (negative ? (-el_gordo) : el_gordo);
- } else {
- n=(n-1)*unity;
- @<Compute $f=\lfloor 2^{16}(1+p/q)+{1\over2}\rfloor$@>;
- return ( negative ? (-(f+n)) :(f+n));
- }
-#else /* FIXPT */
- register double d;
- register integer i;
-#ifdef DEBUG
- if (q==0) mp_confusion(mp,"/");
-#endif /* DEBUG */
- d = TWEXP16 * (double)p /(double)q;
- if ((p^q) >= 0) {
- d += 0.5;
- if (d>=TWEXP31) {mp->arith_error=true; return ELGORDO;}
- i = (integer) d;
- if (d==i && ( ((q>0 ? -q : q)&077777)
- * (((i&037777)<<1)-1) & 04000)!=0) --i;
- } else {
- d -= 0.5;
- if (d<= -TWEXP31) {mp->arith_error=true; return -ELGORDO;}
- i = (integer) d;
- if (d==i && ( ((q>0 ? q : -q)&077777)
- * (((i&037777)<<1)+1) & 04000)!=0) ++i;
- }
- return i;
-#endif /* FIXPT */
-}
-
-@ @<Compute $f=\lfloor 2^{16}(1+p/q)+{1\over2}\rfloor$@>=
-f=1;
-do {
- be_careful=p-q; p=be_careful+p;
- if ( p>=0 ) f=f+f+1;
- else { f+=f; p=p+q; };
-} while (f<unity);
-be_careful=p-q;
-if ( be_careful+p>=0 ) incr(f)
-
-@ Here is a typical example of how the routines above can be used.
-It computes the function
-$${1\over3\tau}f(\theta,\phi)=
-{\tau^{-1}\bigl(2+\sqrt2\,(\sin\theta-{1\over16}\sin\phi)
- (\sin\phi-{1\over16}\sin\theta)(\cos\theta-\cos\phi)\bigr)\over
-3\,\bigl(1+{1\over2}(\sqrt5-1)\cos\theta+{1\over2}(3-\sqrt5\,)\cos\phi\bigr)},$$
-where $\tau$ is a |scaled| ``tension'' parameter. This is \MP's magic
-fudge factor for placing the first control point of a curve that starts
-at an angle $\theta$ and ends at an angle $\phi$ from the straight path.
-(Actually, if the stated quantity exceeds 4, \MP\ reduces it to~4.)
-
-The trigonometric quantity to be multiplied by $\sqrt2$ is less than $\sqrt2$.
-(It's a sum of eight terms whose absolute values can be bounded using
-relations such as $\sin\theta\cos\theta\L{1\over2}$.) Thus the numerator
-is positive; and since the tension $\tau$ is constrained to be at least
-$3\over4$, the numerator is less than $16\over3$. The denominator is
-nonnegative and at most~6. Hence the fixed-point calculations below
-are guaranteed to stay within the bounds of a 32-bit computer word.
-
-The angles $\theta$ and $\phi$ are given implicitly in terms of |fraction|
-arguments |st|, |ct|, |sf|, and |cf|, representing $\sin\theta$, $\cos\theta$,
-$\sin\phi$, and $\cos\phi$, respectively.
-
-@c
-fraction mp_velocity (MP mp,fraction st, fraction ct, fraction sf,
- fraction cf, scaled t) {
- integer acc,num,denom; /* registers for intermediate calculations */
- acc=mp_take_fraction(mp, st-(sf / 16), sf-(st / 16));
- acc=mp_take_fraction(mp, acc,ct-cf);
- num=fraction_two+mp_take_fraction(mp, acc,379625062);
- /* $2^{28}\sqrt2\approx379625062.497$ */
- denom=fraction_three+mp_take_fraction(mp, ct,497706707)+mp_take_fraction(mp, cf,307599661);
- /* $3\cdot2^{27}\cdot(\sqrt5-1)\approx497706706.78$ and
- $3\cdot2^{27}\cdot(3-\sqrt5\,)\approx307599661.22$ */
- if ( t!=unity ) num=mp_make_scaled(mp, num,t);
- /* |make_scaled(fraction,scaled)=fraction| */
- if ( num / 4>=denom )
- return fraction_four;
- else
- return mp_make_fraction(mp, num, denom);
-}
-
-@ The following somewhat different subroutine tests rigorously if $ab$ is
-greater than, equal to, or less than~$cd$,
-given integers $(a,b,c,d)$. In most cases a quick decision is reached.
-The result is $+1$, 0, or~$-1$ in the three respective cases.
-
-@d mp_ab_vs_cd(M,A,B,C,D) mp_do_ab_vs_cd(A,B,C,D)
-
-@c
-integer mp_do_ab_vs_cd (integer a,integer b, integer c, integer d) {
- integer q,r; /* temporary registers */
- @<Reduce to the case that |a,c>=0|, |b,d>0|@>;
- while (1) {
- q = a / d; r = c / b;
- if ( q!=r )
- return ( q>r ? 1 : -1);
- q = a % d; r = c % b;
- if ( r==0 )
- return (q ? 1 : 0);
- if ( q==0 ) return -1;
- a=b; b=q; c=d; d=r;
- } /* now |a>d>0| and |c>b>0| */
-}
-
-@ @<Reduce to the case that |a...@>=
-if ( a<0 ) { negate(a); negate(b); };
-if ( c<0 ) { negate(c); negate(d); };
-if ( d<=0 ) {
- if ( b>=0 ) {
- if ( (a==0||b==0)&&(c==0||d==0) ) return 0;
- else return 1;
- }
- if ( d==0 )
- return ( a==0 ? 0 : -1);
- q=a; a=c; c=q; q=-b; b=-d; d=q;
-} else if ( b<=0 ) {
- if ( b<0 ) if ( a>0 ) return -1;
- return (c==0 ? 0 : -1);
-}
-
-@ We conclude this set of elementary routines with some simple rounding
-and truncation operations.
-
-@<Internal library declarations@>=
-#define mp_floor_scaled(M,i) ((i)&(-65536))
-#define mp_round_unscaled(M,i) (((i>>15)+1)>>1)
-#define mp_round_fraction(M,i) (((i>>11)+1)>>1)
-
-
-@* \[8] Algebraic and transcendental functions.
-\MP\ computes all of the necessary special functions from scratch, without
-relying on |real| arithmetic or system subroutines for sines, cosines, etc.
-
-@ To get the square root of a |scaled| number |x|, we want to calculate
-$s=\lfloor 2^8\!\sqrt x +{1\over2}\rfloor$. If $x>0$, this is the unique
-integer such that $2^{16}x-s\L s^2<2^{16}x+s$. The following subroutine
-determines $s$ by an iterative method that maintains the invariant
-relations $x=2^{46-2k}x_0\bmod 2^{30}$, $0<y=\lfloor 2^{16-2k}x_0\rfloor
--s^2+s\L q=2s$, where $x_0$ is the initial value of $x$. The value of~$y$
-might, however, be zero at the start of the first iteration.
-
-@<Declarations@>=
-scaled mp_square_rt (MP mp,scaled x) ;
-
-@ @c
-scaled mp_square_rt (MP mp,scaled x) {
- small_number k; /* iteration control counter */
- integer y,q; /* registers for intermediate calculations */
- if ( x<=0 ) {
- @<Handle square root of zero or negative argument@>;
- } else {
- k=23; q=2;
- while ( x<fraction_two ) { /* i.e., |while x<@t$2^{29}$@>|\unskip */
- decr(k); x=x+x+x+x;
- }
- if ( x<fraction_four ) y=0;
- else { x=x-fraction_four; y=1; };
- do {
- @<Decrease |k| by 1, maintaining the invariant
- relations between |x|, |y|, and~|q|@>;
- } while (k!=0);
- return (halfp(q));
- }
-}
-
-@ @<Handle square root of zero...@>=
-{
- if ( x<0 ) {
- print_err("Square root of ");
-@.Square root...replaced by 0@>
- mp_print_scaled(mp, x); mp_print(mp, " has been replaced by 0");
- help2("Since I don't take square roots of negative numbers,")
- ("I'm zeroing this one. Proceed, with fingers crossed.");
- mp_error(mp);
- };
- return 0;
-}
-
-@ @<Decrease |k| by 1, maintaining...@>=
-x+=x; y+=y;
-if ( x>=fraction_four ) { /* note that |fraction_four=@t$2^{30}$@>| */
- x=x-fraction_four; incr(y);
-};
-x+=x; y=y+y-q; q+=q;
-if ( x>=fraction_four ) { x=x-fraction_four; incr(y); };
-if ( y>q ){ y=y-q; q=q+2; }
-else if ( y<=0 ) { q=q-2; y=y+q; };
-decr(k)
-
-@ Pythagorean addition $\psqrt{a^2+b^2}$ is implemented by an elegant
-iterative scheme due to Cleve Moler and Donald Morrison [{\sl IBM Journal
-@^Moler, Cleve Barry@>
-@^Morrison, Donald Ross@>
-of Research and Development\/ \bf27} (1983), 577--581]. It modifies |a| and~|b|
-in such a way that their Pythagorean sum remains invariant, while the
-smaller argument decreases.
-
-@<Internal library ...@>=
-integer mp_pyth_add (MP mp,integer a, integer b);
-
-
-@ @c
-integer mp_pyth_add (MP mp,integer a, integer b) {
- fraction r; /* register used to transform |a| and |b| */
- boolean big; /* is the result dangerously near $2^{31}$? */
- a=abs(a); b=abs(b);
- if ( a<b ) { r=b; b=a; a=r; }; /* now |0<=b<=a| */
- if ( b>0 ) {
- if ( a<fraction_two ) {
- big=false;
- } else {
- a=a / 4; b=b / 4; big=true;
- }; /* we reduced the precision to avoid arithmetic overflow */
- @<Replace |a| by an approximation to $\psqrt{a^2+b^2}$@>;
- if ( big ) {
- if ( a<fraction_two ) {
- a=a+a+a+a;
- } else {
- mp->arith_error=true; a=el_gordo;
- };
- }
- }
- return a;
-}
-
-@ The key idea here is to reflect the vector $(a,b)$ about the
-line through $(a,b/2)$.
-
-@<Replace |a| by an approximation to $\psqrt{a^2+b^2}$@>=
-while (1) {
- r=mp_make_fraction(mp, b,a);
- r=mp_take_fraction(mp, r,r); /* now $r\approx b^2/a^2$ */
- if ( r==0 ) break;
- r=mp_make_fraction(mp, r,fraction_four+r);
- a=a+mp_take_fraction(mp, a+a,r); b=mp_take_fraction(mp, b,r);
-}
-
-
-@ Here is a similar algorithm for $\psqrt{a^2-b^2}$.
-It converges slowly when $b$ is near $a$, but otherwise it works fine.
-
-@c
-integer mp_pyth_sub (MP mp,integer a, integer b) {
- fraction r; /* register used to transform |a| and |b| */
- boolean big; /* is the input dangerously near $2^{31}$? */
- a=abs(a); b=abs(b);
- if ( a<=b ) {
- @<Handle erroneous |pyth_sub| and set |a:=0|@>;
- } else {
- if ( a<fraction_four ) {
- big=false;
- } else {
- a=halfp(a); b=halfp(b); big=true;
- }
- @<Replace |a| by an approximation to $\psqrt{a^2-b^2}$@>;
- if ( big ) double(a);
- }
- return a;
-}
-
-@ @<Replace |a| by an approximation to $\psqrt{a^2-b^2}$@>=
-while (1) {
- r=mp_make_fraction(mp, b,a);
- r=mp_take_fraction(mp, r,r); /* now $r\approx b^2/a^2$ */
- if ( r==0 ) break;
- r=mp_make_fraction(mp, r,fraction_four-r);
- a=a-mp_take_fraction(mp, a+a,r); b=mp_take_fraction(mp, b,r);
-}
-
-@ @<Handle erroneous |pyth_sub| and set |a:=0|@>=
-{
- if ( a<b ){
- print_err("Pythagorean subtraction "); mp_print_scaled(mp, a);
- mp_print(mp, "+-+"); mp_print_scaled(mp, b);
- mp_print(mp, " has been replaced by 0");
-@.Pythagorean...@>
- help2("Since I don't take square roots of negative numbers,")
- ("I'm zeroing this one. Proceed, with fingers crossed.");
- mp_error(mp);
- }
- a=0;
-}
-
-@ The subroutines for logarithm and exponential involve two tables.
-The first is simple: |two_to_the[k]| equals $2^k$. The second involves
-a bit more calculation, which the author claims to have done correctly:
-|spec_log[k]| is $2^{27}$ times $\ln\bigl(1/(1-2^{-k})\bigr)=
-2^{-k}+{1\over2}2^{-2k}+{1\over3}2^{-3k}+\cdots\,$, rounded to the
-nearest integer.
-
-@d two_to_the(A) (1<<(A))
-
-@<Constants ...@>=
-static const integer spec_log[29] = { 0, /* special logarithms */
-93032640, 38612034, 17922280, 8662214, 4261238, 2113709,
-1052693, 525315, 262400, 131136, 65552, 32772, 16385,
-8192, 4096, 2048, 1024, 512, 256, 128, 64, 32, 16, 8, 4, 2, 1, 1 };
-
-@ @<Local variables for initialization@>=
-integer k; /* all-purpose loop index */
-
-
-@ Here is the routine that calculates $2^8$ times the natural logarithm
-of a |scaled| quantity; it is an integer approximation to $2^{24}\ln(x/2^{16})$,
-when |x| is a given positive integer.
-
-The method is based on exercise 1.2.2--25 in {\sl The Art of Computer
-Programming\/}: During the main iteration we have $1\L 2^{-30}x<1/(1-2^{1-k})$,
-and the logarithm of $2^{30}x$ remains to be added to an accumulator
-register called~$y$. Three auxiliary bits of accuracy are retained in~$y$
-during the calculation, and sixteen auxiliary bits to extend |y| are
-kept in~|z| during the initial argument reduction. (We add
-$100\cdot2^{16}=6553600$ to~|z| and subtract 100 from~|y| so that |z| will
-not become negative; also, the actual amount subtracted from~|y| is~96,
-not~100, because we want to add~4 for rounding before the final division by~8.)
-
-@c
-scaled mp_m_log (MP mp,scaled x) {
- integer y,z; /* auxiliary registers */
- integer k; /* iteration counter */
- if ( x<=0 ) {
- @<Handle non-positive logarithm@>;
- } else {
- y=1302456956+4-100; /* $14\times2^{27}\ln2\approx1302456956.421063$ */
- z=27595+6553600; /* and $2^{16}\times .421063\approx 27595$ */
- while ( x<fraction_four ) {
- double(x); y-=93032639; z-=48782;
- } /* $2^{27}\ln2\approx 93032639.74436163$ and $2^{16}\times.74436163\approx 48782$ */
- y=y+(z / unity); k=2;
- while ( x>fraction_four+4 ) {
- @<Increase |k| until |x| can be multiplied by a
- factor of $2^{-k}$, and adjust $y$ accordingly@>;
- }
- return (y / 8);
- }
-}
-
-@ @<Increase |k| until |x| can...@>=
-{
- z=((x-1) / two_to_the(k))+1; /* $z=\lceil x/2^k\rceil$ */
- while ( x<fraction_four+z ) { z=halfp(z+1); incr(k); };
- y+=spec_log[k]; x-=z;
-}
-
-@ @<Handle non-positive logarithm@>=
-{
- print_err("Logarithm of ");
-@.Logarithm...replaced by 0@>
- mp_print_scaled(mp, x); mp_print(mp, " has been replaced by 0");
- help2("Since I don't take logs of non-positive numbers,")
- ("I'm zeroing this one. Proceed, with fingers crossed.");
- mp_error(mp);
- return 0;
-}
-
-@ Conversely, the exponential routine calculates $\exp(x/2^8)$,
-when |x| is |scaled|. The result is an integer approximation to
-$2^{16}\exp(x/2^{24})$, when |x| is regarded as an integer.
-
-@c
-scaled mp_m_exp (MP mp,scaled x) {
- small_number k; /* loop control index */
- integer y,z; /* auxiliary registers */
- if ( x>174436200 ) {
- /* $2^{24}\ln((2^{31}-1)/2^{16})\approx 174436199.51$ */
- mp->arith_error=true;
- return el_gordo;
- } else if ( x<-197694359 ) {
- /* $2^{24}\ln(2^{-1}/2^{16})\approx-197694359.45$ */
- return 0;
- } else {
- if ( x<=0 ) {
- z=-8*x; y=04000000; /* $y=2^{20}$ */
- } else {
- if ( x<=127919879 ) {
- z=1023359037-8*x;
- /* $2^{27}\ln((2^{31}-1)/2^{20})\approx 1023359037.125$ */
- } else {
- z=8*(174436200-x); /* |z| is always nonnegative */
- }
- y=el_gordo;
- };
- @<Multiply |y| by $\exp(-z/2^{27})$@>;
- if ( x<=127919879 )
- return ((y+8) / 16);
- else
- return y;
- }
-}
-
-@ The idea here is that subtracting |spec_log[k]| from |z| corresponds
-to multiplying |y| by $1-2^{-k}$.
-
-A subtle point (which had to be checked) was that if $x=127919879$, the
-value of~|y| will decrease so that |y+8| doesn't overflow. In fact,
-$z$ will be 5 in this case, and |y| will decrease by~64 when |k=25|
-and by~16 when |k=27|.
-
-@<Multiply |y| by...@>=
-k=1;
-while ( z>0 ) {
- while ( z>=spec_log[k] ) {
- z-=spec_log[k];
- y=y-1-((y-two_to_the(k-1)) / two_to_the(k));
- }
- incr(k);
-}
-
-@ The trigonometric subroutines use an auxiliary table such that
-|spec_atan[k]| contains an approximation to the |angle| whose tangent
-is~$1/2^k$. $\arctan2^{-k}$ times $2^{20}\cdot180/\pi$
-
-@<Constants ...@>=
-static const angle spec_atan[27] = { 0, 27855475, 14718068, 7471121, 3750058,
-1876857, 938658, 469357, 234682, 117342, 58671, 29335, 14668, 7334, 3667,
-1833, 917, 458, 229, 115, 57, 29, 14, 7, 4, 2, 1 };
-
-@ Given integers |x| and |y|, not both zero, the |n_arg| function
-returns the |angle| whose tangent points in the direction $(x,y)$.
-This subroutine first determines the correct octant, then solves the
-problem for |0<=y<=x|, then converts the result appropriately to
-return an answer in the range |-one_eighty_deg<=@t$\theta$@><=one_eighty_deg|.
-(The answer is |+one_eighty_deg| if |y=0| and |x<0|, but an answer of
-|-one_eighty_deg| is possible if, for example, |y=-1| and $x=-2^{30}$.)
-
-The octants are represented in a ``Gray code,'' since that turns out
-to be computationally simplest.
-
-@d negate_x 1
-@d negate_y 2
-@d switch_x_and_y 4
-@d first_octant 1
-@d second_octant (first_octant+switch_x_and_y)
-@d third_octant (first_octant+switch_x_and_y+negate_x)
-@d fourth_octant (first_octant+negate_x)
-@d fifth_octant (first_octant+negate_x+negate_y)
-@d sixth_octant (first_octant+switch_x_and_y+negate_x+negate_y)
-@d seventh_octant (first_octant+switch_x_and_y+negate_y)
-@d eighth_octant (first_octant+negate_y)
-
-@c
-angle mp_n_arg (MP mp,integer x, integer y) {
- angle z; /* auxiliary register */
- integer t; /* temporary storage */
- small_number k; /* loop counter */
- int octant; /* octant code */
- if ( x>=0 ) {
- octant=first_octant;
- } else {
- negate(x); octant=first_octant+negate_x;
- }
- if ( y<0 ) {
- negate(y); octant=octant+negate_y;
- }
- if ( x<y ) {
- t=y; y=x; x=t; octant=octant+switch_x_and_y;
- }
- if ( x==0 ) {
- @<Handle undefined arg@>;
- } else {
- @<Set variable |z| to the arg of $(x,y)$@>;
- @<Return an appropriate answer based on |z| and |octant|@>;
- }
-}
-
-@ @<Handle undefined arg@>=
-{
- print_err("angle(0,0) is taken as zero");
-@.angle(0,0)...zero@>
- help2("The `angle' between two identical points is undefined.")
- ("I'm zeroing this one. Proceed, with fingers crossed.");
- mp_error(mp);
- return 0;
-}
-
-@ @<Return an appropriate answer...@>=
-switch (octant) {
-case first_octant: return z;
-case second_octant: return (ninety_deg-z);
-case third_octant: return (ninety_deg+z);
-case fourth_octant: return (one_eighty_deg-z);
-case fifth_octant: return (z-one_eighty_deg);
-case sixth_octant: return (-z-ninety_deg);
-case seventh_octant: return (z-ninety_deg);
-case eighth_octant: return (-z);
-}; /* there are no other cases */
-return 0
-
-@ At this point we have |x>=y>=0|, and |x>0|. The numbers are scaled up
-or down until $2^{28}\L x<2^{29}$, so that accurate fixed-point calculations
-will be made.
-
-@<Set variable |z| to the arg...@>=
-while ( x>=fraction_two ) {
- x=halfp(x); y=halfp(y);
-}
-z=0;
-if ( y>0 ) {
- while ( x<fraction_one ) {
- x+=x; y+=y;
- };
- @<Increase |z| to the arg of $(x,y)$@>;
-}
-
-@ During the calculations of this section, variables |x| and~|y|
-represent actual coordinates $(x,2^{-k}y)$. We will maintain the
-condition |x>=y|, so that the tangent will be at most $2^{-k}$.
-If $x<2y$, the tangent is greater than $2^{-k-1}$. The transformation
-$(a,b)\mapsto(a+b\tan\phi,b-a\tan\phi)$ replaces $(a,b)$ by
-coordinates whose angle has decreased by~$\phi$; in the special case
-$a=x$, $b=2^{-k}y$, and $\tan\phi=2^{-k-1}$, this operation reduces
-to the particularly simple iteration shown here. [Cf.~John E. Meggitt,
-@^Meggitt, John E.@>
-{\sl IBM Journal of Research and Development\/ \bf6} (1962), 210--226.]
-
-The initial value of |x| will be multiplied by at most
-$(1+{1\over2})(1+{1\over8})(1+{1\over32})\cdots\approx 1.7584$; hence
-there is no chance of integer overflow.
-
-@<Increase |z|...@>=
-k=0;
-do {
- y+=y; incr(k);
- if ( y>x ){
- z=z+spec_atan[k]; t=x; x=x+(y / two_to_the(k+k)); y=y-t;
- };
-} while (k!=15);
-do {
- y+=y; incr(k);
- if ( y>x ) { z=z+spec_atan[k]; y=y-x; };
-} while (k!=26)
-
-@ Conversely, the |n_sin_cos| routine takes an |angle| and produces the sine
-and cosine of that angle. The results of this routine are
-stored in global integer variables |n_sin| and |n_cos|.
-
-@<Glob...@>=
-fraction n_sin;fraction n_cos; /* results computed by |n_sin_cos| */
-
-@ Given an integer |z| that is $2^{20}$ times an angle $\theta$ in degrees,
-the purpose of |n_sin_cos(z)| is to set
-|x=@t$r\cos\theta$@>| and |y=@t$r\sin\theta$@>| (approximately),
-for some rather large number~|r|. The maximum of |x| and |y|
-will be between $2^{28}$ and $2^{30}$, so that there will be hardly
-any loss of accuracy. Then |x| and~|y| are divided by~|r|.
-
-@c
-void mp_n_sin_cos (MP mp,angle z) { /* computes a multiple of the sine
- and cosine */
- small_number k; /* loop control variable */
- int q; /* specifies the quadrant */
- fraction r; /* magnitude of |(x,y)| */
- integer x,y,t; /* temporary registers */
- while ( z<0 ) z=z+three_sixty_deg;
- z=z % three_sixty_deg; /* now |0<=z<three_sixty_deg| */
- q=z / forty_five_deg; z=z % forty_five_deg;
- x=fraction_one; y=x;
- if ( ! odd(q) ) z=forty_five_deg-z;
- @<Subtract angle |z| from |(x,y)|@>;
- @<Convert |(x,y)| to the octant determined by~|q|@>;
- r=mp_pyth_add(mp, x,y);
- mp->n_cos=mp_make_fraction(mp, x,r);
- mp->n_sin=mp_make_fraction(mp, y,r);
-}
-
-@ In this case the octants are numbered sequentially.
-
-@<Convert |(x,...@>=
-switch (q) {
-case 0: break;
-case 1: t=x; x=y; y=t; break;
-case 2: t=x; x=-y; y=t; break;
-case 3: negate(x); break;
-case 4: negate(x); negate(y); break;
-case 5: t=x; x=-y; y=-t; break;
-case 6: t=x; x=y; y=-t; break;
-case 7: negate(y); break;
-} /* there are no other cases */
-
-@ The main iteration of |n_sin_cos| is similar to that of |n_arg| but
-applied in reverse. The values of |spec_atan[k]| decrease slowly enough
-that this loop is guaranteed to terminate before the (nonexistent) value
-|spec_atan[27]| would be required.
-
-@<Subtract angle |z|...@>=
-k=1;
-while ( z>0 ){
- if ( z>=spec_atan[k] ) {
- z=z-spec_atan[k]; t=x;
- x=t+y / two_to_the(k);
- y=y-t / two_to_the(k);
- }
- incr(k);
-}
-if ( y<0 ) y=0 /* this precaution may never be needed */
-
-@ And now let's complete our collection of numeric utility routines
-by considering random number generation.
-\MP\ generates pseudo-random numbers with the additive scheme recommended
-in Section 3.6 of {\sl The Art of Computer Programming}; however, the
-results are random fractions between 0 and |fraction_one-1|, inclusive.
-
-There's an auxiliary array |randoms| that contains 55 pseudo-random
-fractions. Using the recurrence $x_n=(x_{n-55}-x_{n-31})\bmod 2^{28}$,
-we generate batches of 55 new $x_n$'s at a time by calling |new_randoms|.
-The global variable |j_random| tells which element has most recently
-been consumed.
-The global variable |random_seed| was introduced in version 0.9,
-for the sole reason of stressing the fact that the initial value of the
-random seed is system-dependant. The initialization code below will initialize
-this variable to |(internal[mp_time] div unity)+internal[mp_day]|, but this
-is not good enough on modern fast machines that are capable of running
-multiple MetaPost processes within the same second.
-@^system dependencies@>
-
-@<Glob...@>=
-fraction randoms[55]; /* the last 55 random values generated */
-int j_random; /* the number of unused |randoms| */
-
-@ @<Option variables@>=
-int random_seed; /* the default random seed */
-
-@ @<Allocate or initialize ...@>=
-mp->random_seed = (scaled)opt->random_seed;
-
-@ To consume a random fraction, the program below will say `|next_random|'
-and then it will fetch |randoms[j_random]|.
-
-@d next_random { if ( mp->j_random==0 ) mp_new_randoms(mp);
- else decr(mp->j_random); }
-
-@c
-void mp_new_randoms (MP mp) {
- int k; /* index into |randoms| */
- fraction x; /* accumulator */
- for (k=0;k<=23;k++) {
- x=mp->randoms[k]-mp->randoms[k+31];
- if ( x<0 ) x=x+fraction_one;
- mp->randoms[k]=x;
- }
- for (k=24;k<= 54;k++){
- x=mp->randoms[k]-mp->randoms[k-24];
- if ( x<0 ) x=x+fraction_one;
- mp->randoms[k]=x;
- }
- mp->j_random=54;
-}
-
-@ @<Declarations@>=
-void mp_init_randoms (MP mp,scaled seed);
-
-@ To initialize the |randoms| table, we call the following routine.
-
-@c
-void mp_init_randoms (MP mp,scaled seed) {
- fraction j,jj,k; /* more or less random integers */
- int i; /* index into |randoms| */
- j=abs(seed);
- while ( j>=fraction_one ) j=halfp(j);
- k=1;
- for (i=0;i<=54;i++ ){
- jj=k; k=j-k; j=jj;
- if ( k<0 ) k=k+fraction_one;
- mp->randoms[(i*21)% 55]=j;
- }
- mp_new_randoms(mp);
- mp_new_randoms(mp);
- mp_new_randoms(mp); /* ``warm up'' the array */
-}
-
-@ To produce a uniform random number in the range |0<=u<x| or |0>=u>x|
-or |0=u=x|, given a |scaled| value~|x|, we proceed as shown here.
-
-Note that the call of |take_fraction| will produce the values 0 and~|x|
-with about half the probability that it will produce any other particular
-values between 0 and~|x|, because it rounds its answers.
-
-@c
-scaled mp_unif_rand (MP mp,scaled x) {
- scaled y; /* trial value */
- next_random; y=mp_take_fraction(mp, abs(x),mp->randoms[mp->j_random]);
- if ( y==abs(x) ) return 0;
- else if ( x>0 ) return y;
- else return (-y);
-}
-
-@ Finally, a normal deviate with mean zero and unit standard deviation
-can readily be obtained with the ratio method (Algorithm 3.4.1R in
-{\sl The Art of Computer Programming\/}).
-
-@c
-scaled mp_norm_rand (MP mp) {
- integer x,u,l; /* what the book would call $2^{16}X$, $2^{28}U$, and $-2^{24}\ln U$ */
- do {
- do {
- next_random;
- x=mp_take_fraction(mp, 112429,mp->randoms[mp->j_random]-fraction_half);
- /* $2^{16}\sqrt{8/e}\approx 112428.82793$ */
- next_random; u=mp->randoms[mp->j_random];
- } while (abs(x)>=u);
- x=mp_make_fraction(mp, x,u);
- l=139548960-mp_m_log(mp, u); /* $2^{24}\cdot12\ln2\approx139548959.6165$ */
- } while (mp_ab_vs_cd(mp, 1024,l,x,x)<0);
- return x;
-}
-
-@* \[9] Packed data.
-In order to make efficient use of storage space, \MP\ bases its major data
-structures on a |memory_word|, which contains either a (signed) integer,
-possibly scaled, or a small number of fields that are one half or one
-quarter of the size used for storing integers.
-
-If |x| is a variable of type |memory_word|, it contains up to four
-fields that can be referred to as follows:
-$$\vbox{\halign{\hfil#&#\hfil&#\hfil\cr
-|x|&.|int|&(an |integer|)\cr
-|x|&.|sc|\qquad&(a |scaled| integer)\cr
-|x.hh.lh|, |x.hh|&.|rh|&(two halfword fields)\cr
-|x.hh.b0|, |x.hh.b1|, |x.hh|&.|rh|&(two quarterword fields, one halfword
- field)\cr
-|x.qqqq.b0|, |x.qqqq.b1|, |x.qqqq|&.|b2|, |x.qqqq.b3|\hskip-100pt
- &\qquad\qquad\qquad(four quarterword fields)\cr}}$$
-This is somewhat cumbersome to write, and not very readable either, but
-macros will be used to make the notation shorter and more transparent.
-The code below gives a formal definition of |memory_word| and
-its subsidiary types, using packed variant records. \MP\ makes no
-assumptions about the relative positions of the fields within a word.
-
-@d max_quarterword 0x3FFF /* largest allowable value in a |quarterword| */
-@d max_halfword 0xFFFFFFF /* largest allowable value in a |halfword| */
-
-@ Here are the inequalities that the quarterword and halfword values
-must satisfy (or rather, the inequalities that they mustn't satisfy):
-
-@<Check the ``constant''...@>=
-if (mp->ini_version) {
- if ( mp->mem_max!=mp->mem_top ) mp->bad=8;
-} else {
- if ( mp->mem_max<mp->mem_top ) mp->bad=8;
-}
-if ( max_quarterword<255 ) mp->bad=9;
-if ( max_halfword<65535 ) mp->bad=10;
-if ( max_quarterword>max_halfword ) mp->bad=11;
-if ( mp->mem_max>=max_halfword ) mp->bad=12;
-if ( mp->max_strings>max_halfword ) mp->bad=13;
-
-@ The macros |qi| and |qo| are used for input to and output
-from quarterwords. These are legacy macros.
-@^system dependencies@>
-
-@d qo(A) (A) /* to read eight bits from a quarterword */
-@d qi(A) (A) /* to store eight bits in a quarterword */
-
-@ The reader should study the following definitions closely:
-@^system dependencies@>
-
-@d sc cint /* |scaled| data is equivalent to |integer| */
-
-@<Types...@>=
-typedef short quarterword; /* 1/4 of a word */
-typedef int halfword; /* 1/2 of a word */
-typedef union {
- struct {
- halfword RH, LH;
- } v;
- struct { /* Make B0,B1 overlap the most significant bytes of LH. */
- halfword junk;
- quarterword B0, B1;
- } u;
-} two_halves;
-typedef struct {
- struct {
- quarterword B2, B3, B0, B1;
- } u;
-} four_quarters;
-typedef union {
- two_halves hh;
- integer cint;
- four_quarters qqqq;
-} memory_word;
-#define b0 u.B0
-#define b1 u.B1
-#define b2 u.B2
-#define b3 u.B3
-#define rh v.RH
-#define lh v.LH
-
-@ When debugging, we may want to print a |memory_word| without knowing
-what type it is; so we print it in all modes.
-@^debugging@>
-
-@c
-void mp_print_word (MP mp,memory_word w) {
- /* prints |w| in all ways */
- mp_print_int(mp, w.cint); mp_print_char(mp, ' ');
- mp_print_scaled(mp, w.sc); mp_print_char(mp, ' ');
- mp_print_scaled(mp, w.sc / 010000); mp_print_ln(mp);
- mp_print_int(mp, w.hh.lh); mp_print_char(mp, '=');
- mp_print_int(mp, w.hh.b0); mp_print_char(mp, ':');
- mp_print_int(mp, w.hh.b1); mp_print_char(mp, ';');
- mp_print_int(mp, w.hh.rh); mp_print_char(mp, ' ');
- mp_print_int(mp, w.qqqq.b0); mp_print_char(mp, ':');
- mp_print_int(mp, w.qqqq.b1); mp_print_char(mp, ':');
- mp_print_int(mp, w.qqqq.b2); mp_print_char(mp, ':');
- mp_print_int(mp, w.qqqq.b3);
-}
-
-
-@* \[10] Dynamic memory allocation.
-
-The \MP\ system does nearly all of its own memory allocation, so that it
-can readily be transported into environments that do not have automatic
-facilities for strings, garbage collection, etc., and so that it can be in
-control of what error messages the user receives. The dynamic storage
-requirements of \MP\ are handled by providing a large array |mem| in
-which consecutive blocks of words are used as nodes by the \MP\ routines.
-
-Pointer variables are indices into this array, or into another array
-called |eqtb| that will be explained later. A pointer variable might
-also be a special flag that lies outside the bounds of |mem|, so we
-allow pointers to assume any |halfword| value. The minimum memory
-index represents a null pointer.
-
-@d null 0 /* the null pointer */
-@d mp_void (null+1) /* a null pointer different from |null| */
-
-
-@<Types...@>=
-typedef halfword pointer; /* a flag or a location in |mem| or |eqtb| */
-
-@ The |mem| array is divided into two regions that are allocated separately,
-but the dividing line between these two regions is not fixed; they grow
-together until finding their ``natural'' size in a particular job.
-Locations less than or equal to |lo_mem_max| are used for storing
-variable-length records consisting of two or more words each. This region
-is maintained using an algorithm similar to the one described in exercise
-2.5--19 of {\sl The Art of Computer Programming}. However, no size field
-appears in the allocated nodes; the program is responsible for knowing the
-relevant size when a node is freed. Locations greater than or equal to
-|hi_mem_min| are used for storing one-word records; a conventional
-\.{AVAIL} stack is used for allocation in this region.
-
-Locations of |mem| between |0| and |mem_top| may be dumped as part
-of preloaded mem files, by the \.{INIMP} preprocessor.
-@.INIMP@>
-Production versions of \MP\ may extend the memory at the top end in order to
-provide more space; these locations, between |mem_top| and |mem_max|,
-are always used for single-word nodes.
-
-The key pointers that govern |mem| allocation have a prescribed order:
-$$\hbox{|null=0<lo_mem_max<hi_mem_min<mem_top<=mem_end<=mem_max|.}$$
-
-@<Glob...@>=
-memory_word *mem; /* the big dynamic storage area */
-pointer lo_mem_max; /* the largest location of variable-size memory in use */
-pointer hi_mem_min; /* the smallest location of one-word memory in use */
-
-
-@
-@d xfree(A) do { mp_xfree(A); A=NULL; } while (0)
-@d xrealloc(P,A,B) mp_xrealloc(mp,P,A,B)
-@d xmalloc(A,B) mp_xmalloc(mp,A,B)
-@d xstrdup(A) mp_xstrdup(mp,A)
-@d XREALLOC(a,b,c) a = xrealloc(a,(b+1),sizeof(c));
-
-@<Declare helpers@>=
-void mp_xfree (void *x);
-void *mp_xrealloc (MP mp, void *p, size_t nmem, size_t size) ;
-void *mp_xmalloc (MP mp, size_t nmem, size_t size) ;
-char *mp_xstrdup(MP mp, const char *s);
-
-@ The |max_size_test| guards against overflow, on the assumption that
-|size_t| is at least 31bits wide.
-
-@d max_size_test 0x7FFFFFFF
-
-@c
-void mp_xfree (void *x) {
- if (x!=NULL) free(x);
-}
-void *mp_xrealloc (MP mp, void *p, size_t nmem, size_t size) {
- void *w ;
- if ((max_size_test/size)<nmem) {
- do_fprintf(mp->err_out,"Memory size overflow!\n");
- mp->history =mp_fatal_error_stop; mp_jump_out(mp);
- }
- w = realloc (p,(nmem*size));
- if (w==NULL) {
- do_fprintf(mp->err_out,"Out of memory!\n");
- mp->history =mp_fatal_error_stop; mp_jump_out(mp);
- }
- return w;
-}
-void *mp_xmalloc (MP mp, size_t nmem, size_t size) {
- void *w;
- if ((max_size_test/size)<nmem) {
- do_fprintf(mp->err_out,"Memory size overflow!\n");
- mp->history =mp_fatal_error_stop; mp_jump_out(mp);
- }
- w = malloc (nmem*size);
- if (w==NULL) {
- do_fprintf(mp->err_out,"Out of memory!\n");
- mp->history =mp_fatal_error_stop; mp_jump_out(mp);
- }
- return w;
-}
-char *mp_xstrdup(MP mp, const char *s) {
- char *w;
- if (s==NULL)
- return NULL;
- w = strdup(s);
- if (w==NULL) {
- do_fprintf(mp->err_out,"Out of memory!\n");
- mp->history =mp_fatal_error_stop; mp_jump_out(mp);
- }
- return w;
-}
-
-
-@
-@<Allocate or initialize ...@>=
-mp->mem = xmalloc ((mp->mem_max+1),sizeof (memory_word));
-memset(mp->mem,0,(mp->mem_max+1)*sizeof (memory_word));
-
-@ @<Dealloc variables@>=
-xfree(mp->mem);
-
-@ Users who wish to study the memory requirements of particular applications can
-can use optional special features that keep track of current and
-maximum memory usage. When code between the delimiters |stat| $\ldots$
-|tats| is not ``commented out,'' \MP\ will run a bit slower but it will
-report these statistics when |mp_tracing_stats| is positive.
-
-@<Glob...@>=
-integer var_used; integer dyn_used; /* how much memory is in use */
-
-@ Let's consider the one-word memory region first, since it's the
-simplest. The pointer variable |mem_end| holds the highest-numbered location
-of |mem| that has ever been used. The free locations of |mem| that
-occur between |hi_mem_min| and |mem_end|, inclusive, are of type
-|two_halves|, and we write |info(p)| and |link(p)| for the |lh|
-and |rh| fields of |mem[p]| when it is of this type. The single-word
-free locations form a linked list
-$$|avail|,\;\hbox{|link(avail)|},\;\hbox{|link(link(avail))|},\;\ldots$$
-terminated by |null|.
-
-@d link(A) mp->mem[(A)].hh.rh /* the |link| field of a memory word */
-@d info(A) mp->mem[(A)].hh.lh /* the |info| field of a memory word */
-
-@<Glob...@>=
-pointer avail; /* head of the list of available one-word nodes */
-pointer mem_end; /* the last one-word node used in |mem| */
-
-@ If one-word memory is exhausted, it might mean that the user has forgotten
-a token like `\&{enddef}' or `\&{endfor}'. We will define some procedures
-later that try to help pinpoint the trouble.
-
-@c
-@<Declare the procedure called |show_token_list|@>
-@<Declare the procedure called |runaway|@>
-
-@ The function |get_avail| returns a pointer to a new one-word node whose
-|link| field is null. However, \MP\ will halt if there is no more room left.
-@^inner loop@>
-
-@c
-pointer mp_get_avail (MP mp) { /* single-word node allocation */
- pointer p; /* the new node being got */
- p=mp->avail; /* get top location in the |avail| stack */
- if ( p!=null ) {
- mp->avail=link(mp->avail); /* and pop it off */
- } else if ( mp->mem_end<mp->mem_max ) { /* or go into virgin territory */
- incr(mp->mem_end); p=mp->mem_end;
- } else {
- decr(mp->hi_mem_min); p=mp->hi_mem_min;
- if ( mp->hi_mem_min<=mp->lo_mem_max ) {
- mp_runaway(mp); /* if memory is exhausted, display possible runaway text */
- mp_overflow(mp, "main memory size",mp->mem_max);
- /* quit; all one-word nodes are busy */
-@:MetaPost capacity exceeded main memory size}{\quad main memory size@>
- }
- }
- link(p)=null; /* provide an oft-desired initialization of the new node */
- incr(mp->dyn_used);/* maintain statistics */
- return p;
-}
-
-@ Conversely, a one-word node is recycled by calling |free_avail|.
-
-@d free_avail(A) /* single-word node liberation */
- { link((A))=mp->avail; mp->avail=(A); decr(mp->dyn_used); }
-
-@ There's also a |fast_get_avail| routine, which saves the procedure-call
-overhead at the expense of extra programming. This macro is used in
-the places that would otherwise account for the most calls of |get_avail|.
-@^inner loop@>
-
-@d fast_get_avail(A) {
- (A)=mp->avail; /* avoid |get_avail| if possible, to save time */
- if ( (A)==null ) { (A)=mp_get_avail(mp); }
- else { mp->avail=link((A)); link((A))=null; incr(mp->dyn_used); }
- }
-
-@ The available-space list that keeps track of the variable-size portion
-of |mem| is a nonempty, doubly-linked circular list of empty nodes,
-pointed to by the roving pointer |rover|.
-
-Each empty node has size 2 or more; the first word contains the special
-value |max_halfword| in its |link| field and the size in its |info| field;
-the second word contains the two pointers for double linking.
-
-Each nonempty node also has size 2 or more. Its first word is of type
-|two_halves|\kern-1pt, and its |link| field is never equal to |max_halfword|.
-Otherwise there is complete flexibility with respect to the contents
-of its other fields and its other words.
-
-(We require |mem_max<max_halfword| because terrible things can happen
-when |max_halfword| appears in the |link| field of a nonempty node.)
-
-@d empty_flag max_halfword /* the |link| of an empty variable-size node */
-@d is_empty(A) (link((A))==empty_flag) /* tests for empty node */
-@d node_size info /* the size field in empty variable-size nodes */
-@d llink(A) info((A)+1) /* left link in doubly-linked list of empty nodes */
-@d rlink(A) link((A)+1) /* right link in doubly-linked list of empty nodes */
-
-@<Glob...@>=
-pointer rover; /* points to some node in the list of empties */
-
-@ A call to |get_node| with argument |s| returns a pointer to a new node
-of size~|s|, which must be 2~or more. The |link| field of the first word
-of this new node is set to null. An overflow stop occurs if no suitable
-space exists.
-
-If |get_node| is called with $s=2^{30}$, it simply merges adjacent free
-areas and returns the value |max_halfword|.
-
-@<Internal library declarations@>=
-pointer mp_get_node (MP mp,integer s) ;
-
-@ @c
-pointer mp_get_node (MP mp,integer s) { /* variable-size node allocation */
- pointer p; /* the node currently under inspection */
- pointer q; /* the node physically after node |p| */
- integer r; /* the newly allocated node, or a candidate for this honor */
- integer t,tt; /* temporary registers */
-@^inner loop@>
- RESTART:
- p=mp->rover; /* start at some free node in the ring */
- do {
- @<Try to allocate within node |p| and its physical successors,
- and |goto found| if allocation was possible@>;
- if (rlink(p)==null || (rlink(p)==p && p!=mp->rover)) {
- print_err("Free list garbled");
- help3("I found an entry in the list of free nodes that links")
- ("badly. I will try to ignore the broken link, but something")
- ("is seriously amiss. It is wise to warn the maintainers.")
- mp_error(mp);
- rlink(p)=mp->rover;
- }
- p=rlink(p); /* move to the next node in the ring */
- } while (p!=mp->rover); /* repeat until the whole list has been traversed */
- if ( s==010000000000 ) {
- return max_halfword;
- };
- if ( mp->lo_mem_max+2<mp->hi_mem_min ) {
- if ( mp->lo_mem_max+2<=max_halfword ) {
- @<Grow more variable-size memory and |goto restart|@>;
- }
- }
- mp_overflow(mp, "main memory size",mp->mem_max);
- /* sorry, nothing satisfactory is left */
-@:MetaPost capacity exceeded main memory size}{\quad main memory size@>
-FOUND:
- link(r)=null; /* this node is now nonempty */
- mp->var_used+=s; /* maintain usage statistics */
- return r;
-}
-
-@ The lower part of |mem| grows by 1000 words at a time, unless
-we are very close to going under. When it grows, we simply link
-a new node into the available-space list. This method of controlled
-growth helps to keep the |mem| usage consecutive when \MP\ is
-implemented on ``virtual memory'' systems.
-@^virtual memory@>
-
-@<Grow more variable-size memory and |goto restart|@>=
-{
- if ( mp->hi_mem_min-mp->lo_mem_max>=1998 ) {
- t=mp->lo_mem_max+1000;
- } else {
- t=mp->lo_mem_max+1+(mp->hi_mem_min-mp->lo_mem_max) / 2;
- /* |lo_mem_max+2<=t<hi_mem_min| */
- }
- if ( t>max_halfword ) t=max_halfword;
- p=llink(mp->rover); q=mp->lo_mem_max; rlink(p)=q; llink(mp->rover)=q;
- rlink(q)=mp->rover; llink(q)=p; link(q)=empty_flag;
- node_size(q)=t-mp->lo_mem_max;
- mp->lo_mem_max=t; link(mp->lo_mem_max)=null; info(mp->lo_mem_max)=null;
- mp->rover=q;
- goto RESTART;
-}
-
-@ @<Try to allocate...@>=
-q=p+node_size(p); /* find the physical successor */
-while ( is_empty(q) ) { /* merge node |p| with node |q| */
- t=rlink(q); tt=llink(q);
-@^inner loop@>
- if ( q==mp->rover ) mp->rover=t;
- llink(t)=tt; rlink(tt)=t;
- q=q+node_size(q);
-}
-r=q-s;
-if ( r>p+1 ) {
- @<Allocate from the top of node |p| and |goto found|@>;
-}
-if ( r==p ) {
- if ( rlink(p)!=p ) {
- @<Allocate entire node |p| and |goto found|@>;
- }
-}
-node_size(p)=q-p /* reset the size in case it grew */
-
-@ @<Allocate from the top...@>=
-{
- node_size(p)=r-p; /* store the remaining size */
- mp->rover=p; /* start searching here next time */
- goto FOUND;
-}
-
-@ Here we delete node |p| from the ring, and let |rover| rove around.
-
-@<Allocate entire...@>=
-{
- mp->rover=rlink(p); t=llink(p);
- llink(mp->rover)=t; rlink(t)=mp->rover;
- goto FOUND;
-}
-
-@ Conversely, when some variable-size node |p| of size |s| is no longer needed,
-the operation |free_node(p,s)| will make its words available, by inserting
-|p| as a new empty node just before where |rover| now points.
-
-@<Internal library declarations@>=
-void mp_free_node (MP mp, pointer p, halfword s) ;
-
-@ @c
-void mp_free_node (MP mp, pointer p, halfword s) { /* variable-size node
- liberation */
- pointer q; /* |llink(rover)| */
- node_size(p)=s; link(p)=empty_flag;
-@^inner loop@>
- q=llink(mp->rover); llink(p)=q; rlink(p)=mp->rover; /* set both links */
- llink(mp->rover)=p; rlink(q)=p; /* insert |p| into the ring */
- mp->var_used-=s; /* maintain statistics */
-}
-
-@ Just before \.{INIMP} writes out the memory, it sorts the doubly linked
-available space list. The list is probably very short at such times, so a
-simple insertion sort is used. The smallest available location will be
-pointed to by |rover|, the next-smallest by |rlink(rover)|, etc.
-
-@c
-void mp_sort_avail (MP mp) { /* sorts the available variable-size nodes
- by location */
- pointer p,q,r; /* indices into |mem| */
- pointer old_rover; /* initial |rover| setting */
- p=mp_get_node(mp, 010000000000); /* merge adjacent free areas */
- p=rlink(mp->rover); rlink(mp->rover)=max_halfword; old_rover=mp->rover;
- while ( p!=old_rover ) {
- @<Sort |p| into the list starting at |rover|
- and advance |p| to |rlink(p)|@>;
- }
- p=mp->rover;
- while ( rlink(p)!=max_halfword ) {
- llink(rlink(p))=p; p=rlink(p);
- };
- rlink(p)=mp->rover; llink(mp->rover)=p;
-}
-
-@ The following |while| loop is guaranteed to
-terminate, since the list that starts at
-|rover| ends with |max_halfword| during the sorting procedure.
-
-@<Sort |p|...@>=
-if ( p<mp->rover ) {
- q=p; p=rlink(q); rlink(q)=mp->rover; mp->rover=q;
-} else {
- q=mp->rover;
- while ( rlink(q)<p ) q=rlink(q);
- r=rlink(p); rlink(p)=rlink(q); rlink(q)=p; p=r;
-}
-
-@* \[11] Memory layout.
-Some areas of |mem| are dedicated to fixed usage, since static allocation is
-more efficient than dynamic allocation when we can get away with it. For
-example, locations |0| to |1| are always used to store a
-two-word dummy token whose second word is zero.
-The following macro definitions accomplish the static allocation by giving
-symbolic names to the fixed positions. Static variable-size nodes appear
-in locations |0| through |lo_mem_stat_max|, and static single-word nodes
-appear in locations |hi_mem_stat_min| through |mem_top|, inclusive.
-
-@d null_dash (2) /* the first two words are reserved for a null value */
-@d dep_head (null_dash+3) /* we will define |dash_node_size=3| */
-@d zero_val (dep_head+2) /* two words for a permanently zero value */
-@d temp_val (zero_val+2) /* two words for a temporary value node */
-@d end_attr temp_val /* we use |end_attr+2| only */
-@d inf_val (end_attr+2) /* and |inf_val+1| only */
-@d test_pen (inf_val+2)
- /* nine words for a pen used when testing the turning number */
-@d bad_vardef (test_pen+9) /* two words for \&{vardef} error recovery */
-@d lo_mem_stat_max (bad_vardef+1) /* largest statically
- allocated word in the variable-size |mem| */
-@#
-@d sentinel mp->mem_top /* end of sorted lists */
-@d temp_head (mp->mem_top-1) /* head of a temporary list of some kind */
-@d hold_head (mp->mem_top-2) /* head of a temporary list of another kind */
-@d spec_head (mp->mem_top-3) /* head of a list of unprocessed \&{special} items */
-@d hi_mem_stat_min (mp->mem_top-3) /* smallest statically allocated word in
- the one-word |mem| */
-
-@ The following code gets the dynamic part of |mem| off to a good start,
-when \MP\ is initializing itself the slow way.
-
-@<Initialize table entries (done by \.{INIMP} only)@>=
-mp->rover=lo_mem_stat_max+1; /* initialize the dynamic memory */
-link(mp->rover)=empty_flag;
-node_size(mp->rover)=1000; /* which is a 1000-word available node */
-llink(mp->rover)=mp->rover; rlink(mp->rover)=mp->rover;
-mp->lo_mem_max=mp->rover+1000;
-link(mp->lo_mem_max)=null; info(mp->lo_mem_max)=null;
-for (k=hi_mem_stat_min;k<=(int)mp->mem_top;k++) {
- mp->mem[k]=mp->mem[mp->lo_mem_max]; /* clear list heads */
-}
-mp->avail=null; mp->mem_end=mp->mem_top;
-mp->hi_mem_min=hi_mem_stat_min; /* initialize the one-word memory */
-mp->var_used=lo_mem_stat_max+1;
-mp->dyn_used=mp->mem_top+1-(hi_mem_stat_min); /* initialize statistics */
-@<Initialize a pen at |test_pen| so that it fits in nine words@>;
-
-@ The procedure |flush_list(p)| frees an entire linked list of one-word
-nodes that starts at a given position, until coming to |sentinel| or a
-pointer that is not in the one-word region. Another procedure,
-|flush_node_list|, frees an entire linked list of one-word and two-word
-nodes, until coming to a |null| pointer.
-@^inner loop@>
-
-@c
-void mp_flush_list (MP mp,pointer p) { /* makes list of single-word nodes available */
- pointer q,r; /* list traversers */
- if ( p>=mp->hi_mem_min ) if ( p!=sentinel ) {
- r=p;
- do {
- q=r; r=link(r);
- decr(mp->dyn_used);
- if ( r<mp->hi_mem_min ) break;
- } while (r!=sentinel);
- /* now |q| is the last node on the list */
- link(q)=mp->avail; mp->avail=p;
- }
-}
-@#
-void mp_flush_node_list (MP mp,pointer p) {
- pointer q; /* the node being recycled */
- while ( p!=null ){
- q=p; p=link(p);
- if ( q<mp->hi_mem_min )
- mp_free_node(mp, q,2);
- else
- free_avail(q);
- }
-}
-
-@ If \MP\ is extended improperly, the |mem| array might get screwed up.
-For example, some pointers might be wrong, or some ``dead'' nodes might not
-have been freed when the last reference to them disappeared. Procedures
-|check_mem| and |search_mem| are available to help diagnose such
-problems. These procedures make use of two arrays called |free| and
-|was_free| that are present only if \MP's debugging routines have
-been included. (You may want to decrease the size of |mem| while you
-@^debugging@>
-are debugging.)
-
-Because |boolean|s are typedef-d as ints, it is better to use
-unsigned chars here.
-
-@<Glob...@>=
-unsigned char *free; /* free cells */
-unsigned char *was_free; /* previously free cells */
-pointer was_mem_end; pointer was_lo_max; pointer was_hi_min;
- /* previous |mem_end|, |lo_mem_max|,and |hi_mem_min| */
-boolean panicking; /* do we want to check memory constantly? */
-
-@ @<Allocate or initialize ...@>=
-mp->free = xmalloc ((mp->mem_max+1),sizeof (unsigned char));
-mp->was_free = xmalloc ((mp->mem_max+1), sizeof (unsigned char));
-
-@ @<Dealloc variables@>=
-xfree(mp->free);
-xfree(mp->was_free);
-
-@ @<Allocate or ...@>=
-mp->was_mem_end=0; /* indicate that everything was previously free */
-mp->was_lo_max=0; mp->was_hi_min=mp->mem_max;
-mp->panicking=false;
-
-@ @<Declare |mp_reallocate| functions@>=
-void mp_reallocate_memory(MP mp, int l) ;
-
-@ @c
-void mp_reallocate_memory(MP mp, int l) {
- XREALLOC(mp->free, l, unsigned char);
- XREALLOC(mp->was_free, l, unsigned char);
- if (mp->mem) {
- int newarea = l-mp->mem_max;
- XREALLOC(mp->mem, l, memory_word);
- memset (mp->mem+(mp->mem_max+1),0,sizeof(memory_word)*(newarea));
- } else {
- XREALLOC(mp->mem, l, memory_word);
- memset(mp->mem,0,sizeof(memory_word)*(l+1));
- }
- mp->mem_max = l;
- if (mp->ini_version)
- mp->mem_top = l;
-}
-
-
-
-@ Procedure |check_mem| makes sure that the available space lists of
-|mem| are well formed, and it optionally prints out all locations
-that are reserved now but were free the last time this procedure was called.
-
-@c
-void mp_check_mem (MP mp,boolean print_locs ) {
- pointer p,q,r; /* current locations of interest in |mem| */
- boolean clobbered; /* is something amiss? */
- for (p=0;p<=mp->lo_mem_max;p++) {
- mp->free[p]=false; /* you can probably do this faster */
- }
- for (p=mp->hi_mem_min;p<= mp->mem_end;p++) {
- mp->free[p]=false; /* ditto */
- }
- @<Check single-word |avail| list@>;
- @<Check variable-size |avail| list@>;
- @<Check flags of unavailable nodes@>;
- @<Check the list of linear dependencies@>;
- if ( print_locs ) {
- @<Print newly busy locations@>;
- }
- memcpy(mp->was_free,mp->free, sizeof(char)*(mp->mem_end+1));
- mp->was_mem_end=mp->mem_end;
- mp->was_lo_max=mp->lo_mem_max;
- mp->was_hi_min=mp->hi_mem_min;
-}
-
-@ @<Check single-word...@>=
-p=mp->avail; q=null; clobbered=false;
-while ( p!=null ) {
- if ( (p>mp->mem_end)||(p<mp->hi_mem_min) ) clobbered=true;
- else if ( mp->free[p] ) clobbered=true;
- if ( clobbered ) {
- mp_print_nl(mp, "AVAIL list clobbered at ");
-@.AVAIL list clobbered...@>
- mp_print_int(mp, q); break;
- }
- mp->free[p]=true; q=p; p=link(q);
-}
-
-@ @<Check variable-size...@>=
-p=mp->rover; q=null; clobbered=false;
-do {
- if ( (p>=mp->lo_mem_max)||(p<0) ) clobbered=true;
- else if ( (rlink(p)>=mp->lo_mem_max)||(rlink(p)<0) ) clobbered=true;
- else if ( !(is_empty(p))||(node_size(p)<2)||
- (p+node_size(p)>mp->lo_mem_max)|| (llink(rlink(p))!=p) ) clobbered=true;
- if ( clobbered ) {
- mp_print_nl(mp, "Double-AVAIL list clobbered at ");
-@.Double-AVAIL list clobbered...@>
- mp_print_int(mp, q); break;
- }
- for (q=p;q<=p+node_size(p)-1;q++) { /* mark all locations free */
- if ( mp->free[q] ) {
- mp_print_nl(mp, "Doubly free location at ");
-@.Doubly free location...@>
- mp_print_int(mp, q); break;
- }
- mp->free[q]=true;
- }
- q=p; p=rlink(p);
-} while (p!=mp->rover)
-
-
-@ @<Check flags...@>=
-p=0;
-while ( p<=mp->lo_mem_max ) { /* node |p| should not be empty */
- if ( is_empty(p) ) {
- mp_print_nl(mp, "Bad flag at "); mp_print_int(mp, p);
-@.Bad flag...@>
- }
- while ( (p<=mp->lo_mem_max) && ! mp->free[p] ) incr(p);
- while ( (p<=mp->lo_mem_max) && mp->free[p] ) incr(p);
-}
-
-@ @<Print newly busy...@>=
-{
- @<Do intialization required before printing new busy locations@>;
- mp_print_nl(mp, "New busy locs:");
-@.New busy locs@>
- for (p=0;p<= mp->lo_mem_max;p++ ) {
- if ( ! mp->free[p] && ((p>mp->was_lo_max) || mp->was_free[p]) ) {
- @<Indicate that |p| is a new busy location@>;
- }
- }
- for (p=mp->hi_mem_min;p<=mp->mem_end;p++ ) {
- if ( ! mp->free[p] &&
- ((p<mp->was_hi_min) || (p>mp->was_mem_end) || mp->was_free[p]) ) {
- @<Indicate that |p| is a new busy location@>;
- }
- }
- @<Finish printing new busy locations@>;
-}
-
-@ There might be many new busy locations so we are careful to print contiguous
-blocks compactly. During this operation |q| is the last new busy location and
-|r| is the start of the block containing |q|.
-
-@<Indicate that |p| is a new busy location@>=
-{
- if ( p>q+1 ) {
- if ( q>r ) {
- mp_print(mp, ".."); mp_print_int(mp, q);
- }
- mp_print_char(mp, ' '); mp_print_int(mp, p);
- r=p;
- }
- q=p;
-}
-
-@ @<Do intialization required before printing new busy locations@>=
-q=mp->mem_max; r=mp->mem_max
-
-@ @<Finish printing new busy locations@>=
-if ( q>r ) {
- mp_print(mp, ".."); mp_print_int(mp, q);
-}
-
-@ The |search_mem| procedure attempts to answer the question ``Who points
-to node~|p|?'' In doing so, it fetches |link| and |info| fields of |mem|
-that might not be of type |two_halves|. Strictly speaking, this is
-undefined, and it can lead to ``false drops'' (words that seem to
-point to |p| purely by coincidence). But for debugging purposes, we want
-to rule out the places that do {\sl not\/} point to |p|, so a few false
-drops are tolerable.
-
-@c
-void mp_search_mem (MP mp, pointer p) { /* look for pointers to |p| */
- integer q; /* current position being searched */
- for (q=0;q<=mp->lo_mem_max;q++) {
- if ( link(q)==p ){
- mp_print_nl(mp, "LINK("); mp_print_int(mp, q); mp_print_char(mp, ')');
- }
- if ( info(q)==p ) {
- mp_print_nl(mp, "INFO("); mp_print_int(mp, q); mp_print_char(mp, ')');
- }
- }
- for (q=mp->hi_mem_min;q<=mp->mem_end;q++) {
- if ( link(q)==p ) {
- mp_print_nl(mp, "LINK("); mp_print_int(mp, q); mp_print_char(mp, ')');
- }
- if ( info(q)==p ) {
- mp_print_nl(mp, "INFO("); mp_print_int(mp, q); mp_print_char(mp, ')');
- }
- }
- @<Search |eqtb| for equivalents equal to |p|@>;
-}
-
-@* \[12] The command codes.
-Before we can go much further, we need to define symbolic names for the internal
-code numbers that represent the various commands obeyed by \MP. These codes
-are somewhat arbitrary, but not completely so. For example,
-some codes have been made adjacent so that |case| statements in the
-program need not consider cases that are widely spaced, or so that |case|
-statements can be replaced by |if| statements. A command can begin an
-expression if and only if its code lies between |min_primary_command| and
-|max_primary_command|, inclusive. The first token of a statement that doesn't
-begin with an expression has a command code between |min_command| and
-|max_statement_command|, inclusive. Anything less than |min_command| is
-eliminated during macro expansions, and anything no more than |max_pre_command|
-is eliminated when expanding \TeX\ material. Ranges such as
-|min_secondary_command..max_secondary_command| are used when parsing
-expressions, but the relative ordering within such a range is generally not
-critical.
-
-The ordering of the highest-numbered commands
-(|comma<semicolon<end_group<stop|) is crucial for the parsing and
-error-recovery methods of this program as is the ordering |if_test<fi_or_else|
-for the smallest two commands. The ordering is also important in the ranges
-|numeric_token..plus_or_minus| and |left_brace..ampersand|.
-
-At any rate, here is the list, for future reference.
-
-@d start_tex 1 /* begin \TeX\ material (\&{btex}, \&{verbatimtex}) */
-@d etex_marker 2 /* end \TeX\ material (\&{etex}) */
-@d mpx_break 3 /* stop reading an \.{MPX} file (\&{mpxbreak}) */
-@d max_pre_command mpx_break
-@d if_test 4 /* conditional text (\&{if}) */
-@d fi_or_else 5 /* delimiters for conditionals (\&{elseif}, \&{else}, \&{fi}) */
-@d input 6 /* input a source file (\&{input}, \&{endinput}) */
-@d iteration 7 /* iterate (\&{for}, \&{forsuffixes}, \&{forever}, \&{endfor}) */
-@d repeat_loop 8 /* special command substituted for \&{endfor} */
-@d exit_test 9 /* premature exit from a loop (\&{exitif}) */
-@d relax 10 /* do nothing (\.{\char`\\}) */
-@d scan_tokens 11 /* put a string into the input buffer */
-@d expand_after 12 /* look ahead one token */
-@d defined_macro 13 /* a macro defined by the user */
-@d min_command (defined_macro+1)
-@d save_command 14 /* save a list of tokens (\&{save}) */
-@d interim_command 15 /* save an internal quantity (\&{interim}) */
-@d let_command 16 /* redefine a symbolic token (\&{let}) */
-@d new_internal 17 /* define a new internal quantity (\&{newinternal}) */
-@d macro_def 18 /* define a macro (\&{def}, \&{vardef}, etc.) */
-@d ship_out_command 19 /* output a character (\&{shipout}) */
-@d add_to_command 20 /* add to edges (\&{addto}) */
-@d bounds_command 21 /* add bounding path to edges (\&{setbounds}, \&{clip}) */
-@d tfm_command 22 /* command for font metric info (\&{ligtable}, etc.) */
-@d protection_command 23 /* set protection flag (\&{outer}, \&{inner}) */
-@d show_command 24 /* diagnostic output (\&{show}, \&{showvariable}, etc.) */
-@d mode_command 25 /* set interaction level (\&{batchmode}, etc.) */
-@d mp_random_seed 26 /* initialize random number generator (\&{randomseed}) */
-@d message_command 27 /* communicate to user (\&{message}, \&{errmessage}) */
-@d every_job_command 28 /* designate a starting token (\&{everyjob}) */
-@d delimiters 29 /* define a pair of delimiters (\&{delimiters}) */
-@d special_command 30 /* output special info (\&{special})
- or font map info (\&{fontmapfile}, \&{fontmapline}) */
-@d write_command 31 /* write text to a file (\&{write}) */
-@d type_name 32 /* declare a type (\&{numeric}, \&{pair}, etc.) */
-@d max_statement_command type_name
-@d min_primary_command type_name
-@d left_delimiter 33 /* the left delimiter of a matching pair */
-@d begin_group 34 /* beginning of a group (\&{begingroup}) */
-@d nullary 35 /* an operator without arguments (e.g., \&{normaldeviate}) */
-@d unary 36 /* an operator with one argument (e.g., \&{sqrt}) */
-@d str_op 37 /* convert a suffix to a string (\&{str}) */
-@d cycle 38 /* close a cyclic path (\&{cycle}) */
-@d primary_binary 39 /* binary operation taking `\&{of}' (e.g., \&{point}) */
-@d capsule_token 40 /* a value that has been put into a token list */
-@d string_token 41 /* a string constant (e.g., |"hello"|) */
-@d internal_quantity 42 /* internal numeric parameter (e.g., \&{pausing}) */
-@d min_suffix_token internal_quantity
-@d tag_token 43 /* a symbolic token without a primitive meaning */
-@d numeric_token 44 /* a numeric constant (e.g., \.{3.14159}) */
-@d max_suffix_token numeric_token
-@d plus_or_minus 45 /* either `\.+' or `\.-' */
-@d max_primary_command plus_or_minus /* should also be |numeric_token+1| */
-@d min_tertiary_command plus_or_minus
-@d tertiary_secondary_macro 46 /* a macro defined by \&{secondarydef} */
-@d tertiary_binary 47 /* an operator at the tertiary level (e.g., `\.{++}') */
-@d max_tertiary_command tertiary_binary
-@d left_brace 48 /* the operator `\.{\char`\{}' */
-@d min_expression_command left_brace
-@d path_join 49 /* the operator `\.{..}' */
-@d ampersand 50 /* the operator `\.\&' */
-@d expression_tertiary_macro 51 /* a macro defined by \&{tertiarydef} */
-@d expression_binary 52 /* an operator at the expression level (e.g., `\.<') */
-@d equals 53 /* the operator `\.=' */
-@d max_expression_command equals
-@d and_command 54 /* the operator `\&{and}' */
-@d min_secondary_command and_command
-@d secondary_primary_macro 55 /* a macro defined by \&{primarydef} */
-@d slash 56 /* the operator `\./' */
-@d secondary_binary 57 /* an operator at the binary level (e.g., \&{shifted}) */
-@d max_secondary_command secondary_binary
-@d param_type 58 /* type of parameter (\&{primary}, \&{expr}, \&{suffix}, etc.) */
-@d controls 59 /* specify control points explicitly (\&{controls}) */
-@d tension 60 /* specify tension between knots (\&{tension}) */
-@d at_least 61 /* bounded tension value (\&{atleast}) */
-@d curl_command 62 /* specify curl at an end knot (\&{curl}) */
-@d macro_special 63 /* special macro operators (\&{quote}, \.{\#\AT!}, etc.) */
-@d right_delimiter 64 /* the right delimiter of a matching pair */
-@d left_bracket 65 /* the operator `\.[' */
-@d right_bracket 66 /* the operator `\.]' */
-@d right_brace 67 /* the operator `\.{\char`\}}' */
-@d with_option 68 /* option for filling (\&{withpen}, \&{withweight}, etc.) */
-@d thing_to_add 69
- /* variant of \&{addto} (\&{contour}, \&{doublepath}, \&{also}) */
-@d of_token 70 /* the operator `\&{of}' */
-@d to_token 71 /* the operator `\&{to}' */
-@d step_token 72 /* the operator `\&{step}' */
-@d until_token 73 /* the operator `\&{until}' */
-@d within_token 74 /* the operator `\&{within}' */
-@d lig_kern_token 75
- /* the operators `\&{kern}' and `\.{=:}' and `\.{=:\char'174}', etc. */
-@d assignment 76 /* the operator `\.{:=}' */
-@d skip_to 77 /* the operation `\&{skipto}' */
-@d bchar_label 78 /* the operator `\.{\char'174\char'174:}' */
-@d double_colon 79 /* the operator `\.{::}' */
-@d colon 80 /* the operator `\.:' */
-@#
-@d comma 81 /* the operator `\.,', must be |colon+1| */
-@d end_of_statement (mp->cur_cmd>comma)
-@d semicolon 82 /* the operator `\.;', must be |comma+1| */
-@d end_group 83 /* end a group (\&{endgroup}), must be |semicolon+1| */
-@d stop 84 /* end a job (\&{end}, \&{dump}), must be |end_group+1| */
-@d max_command_code stop
-@d outer_tag (max_command_code+1) /* protection code added to command code */
-
-@<Types...@>=
-typedef int command_code;
-
-@ Variables and capsules in \MP\ have a variety of ``types,''
-distinguished by the code numbers defined here. These numbers are also
-not completely arbitrary. Things that get expanded must have types
-|>mp_independent|; a type remaining after expansion is numeric if and only if
-its code number is at least |numeric_type|; objects containing numeric
-parts must have types between |transform_type| and |pair_type|;
-all other types must be smaller than |transform_type|; and among the types
-that are not unknown or vacuous, the smallest two must be |boolean_type|
-and |string_type| in that order.
-
-@d undefined 0 /* no type has been declared */
-@d unknown_tag 1 /* this constant is added to certain type codes below */
-@d unknown_types mp_unknown_boolean: case mp_unknown_string:
- case mp_unknown_pen: case mp_unknown_picture: case mp_unknown_path
-
-@<Types...@>=
-enum mp_variable_type {
-mp_vacuous=1, /* no expression was present */
-mp_boolean_type, /* \&{boolean} with a known value */
-mp_unknown_boolean,
-mp_string_type, /* \&{string} with a known value */
-mp_unknown_string,
-mp_pen_type, /* \&{pen} with a known value */
-mp_unknown_pen,
-mp_path_type, /* \&{path} with a known value */
-mp_unknown_path,
-mp_picture_type, /* \&{picture} with a known value */
-mp_unknown_picture,
-mp_transform_type, /* \&{transform} variable or capsule */
-mp_color_type, /* \&{color} variable or capsule */
-mp_cmykcolor_type, /* \&{cmykcolor} variable or capsule */
-mp_pair_type, /* \&{pair} variable or capsule */
-mp_numeric_type, /* variable that has been declared \&{numeric} but not used */
-mp_known, /* \&{numeric} with a known value */
-mp_dependent, /* a linear combination with |fraction| coefficients */
-mp_proto_dependent, /* a linear combination with |scaled| coefficients */
-mp_independent, /* \&{numeric} with unknown value */
-mp_token_list, /* variable name or suffix argument or text argument */
-mp_structured, /* variable with subscripts and attributes */
-mp_unsuffixed_macro, /* variable defined with \&{vardef} but no \.{\AT!\#} */
-mp_suffixed_macro /* variable defined with \&{vardef} and \.{\AT!\#} */
-} ;
-
-@ @<Declarations@>=
-void mp_print_type (MP mp,small_number t) ;
-
-@ @<Basic printing procedures@>=
-void mp_print_type (MP mp,small_number t) {
- switch (t) {
- case mp_vacuous:mp_print(mp, "mp_vacuous"); break;
- case mp_boolean_type:mp_print(mp, "boolean"); break;
- case mp_unknown_boolean:mp_print(mp, "unknown boolean"); break;
- case mp_string_type:mp_print(mp, "string"); break;
- case mp_unknown_string:mp_print(mp, "unknown string"); break;
- case mp_pen_type:mp_print(mp, "pen"); break;
- case mp_unknown_pen:mp_print(mp, "unknown pen"); break;
- case mp_path_type:mp_print(mp, "path"); break;
- case mp_unknown_path:mp_print(mp, "unknown path"); break;
- case mp_picture_type:mp_print(mp, "picture"); break;
- case mp_unknown_picture:mp_print(mp, "unknown picture"); break;
- case mp_transform_type:mp_print(mp, "transform"); break;
- case mp_color_type:mp_print(mp, "color"); break;
- case mp_cmykcolor_type:mp_print(mp, "cmykcolor"); break;
- case mp_pair_type:mp_print(mp, "pair"); break;
- case mp_known:mp_print(mp, "known numeric"); break;
- case mp_dependent:mp_print(mp, "dependent"); break;
- case mp_proto_dependent:mp_print(mp, "proto-dependent"); break;
- case mp_numeric_type:mp_print(mp, "numeric"); break;
- case mp_independent:mp_print(mp, "independent"); break;
- case mp_token_list:mp_print(mp, "token list"); break;
- case mp_structured:mp_print(mp, "mp_structured"); break;
- case mp_unsuffixed_macro:mp_print(mp, "unsuffixed macro"); break;
- case mp_suffixed_macro:mp_print(mp, "suffixed macro"); break;
- default: mp_print(mp, "undefined"); break;
- }
-}
-
-@ Values inside \MP\ are stored in two-word nodes that have a |name_type|
-as well as a |type|. The possibilities for |name_type| are defined
-here; they will be explained in more detail later.
-
-@<Types...@>=
-enum mp_name_type {
- mp_root=0, /* |name_type| at the top level of a variable */
- mp_saved_root, /* same, when the variable has been saved */
- mp_structured_root, /* |name_type| where a |mp_structured| branch occurs */
- mp_subscr, /* |name_type| in a subscript node */
- mp_attr, /* |name_type| in an attribute node */
- mp_x_part_sector, /* |name_type| in the \&{xpart} of a node */
- mp_y_part_sector, /* |name_type| in the \&{ypart} of a node */
- mp_xx_part_sector, /* |name_type| in the \&{xxpart} of a node */
- mp_xy_part_sector, /* |name_type| in the \&{xypart} of a node */
- mp_yx_part_sector, /* |name_type| in the \&{yxpart} of a node */
- mp_yy_part_sector, /* |name_type| in the \&{yypart} of a node */
- mp_red_part_sector, /* |name_type| in the \&{redpart} of a node */
- mp_green_part_sector, /* |name_type| in the \&{greenpart} of a node */
- mp_blue_part_sector, /* |name_type| in the \&{bluepart} of a node */
- mp_cyan_part_sector, /* |name_type| in the \&{redpart} of a node */
- mp_magenta_part_sector, /* |name_type| in the \&{greenpart} of a node */
- mp_yellow_part_sector, /* |name_type| in the \&{bluepart} of a node */
- mp_black_part_sector, /* |name_type| in the \&{greenpart} of a node */
- mp_grey_part_sector, /* |name_type| in the \&{bluepart} of a node */
- mp_capsule, /* |name_type| in stashed-away subexpressions */
- mp_token /* |name_type| in a numeric token or string token */
-};
-
-@ Primitive operations that produce values have a secondary identification
-code in addition to their command code; it's something like genera and species.
-For example, `\.*' has the command code |primary_binary|, and its
-secondary identification is |times|. The secondary codes start at 30 so that
-they don't overlap with the type codes; some type codes (e.g., |mp_string_type|)
-are used as operators as well as type identifications. The relative values
-are not critical, except for |true_code..false_code|, |or_op..and_op|,
-and |filled_op..bounded_op|. The restrictions are that
-|and_op-false_code=or_op-true_code|, that the ordering of
-|x_part...blue_part| must match that of |x_part_sector..mp_blue_part_sector|,
-and the ordering of |filled_op..bounded_op| must match that of the code
-values they test for.
-
-@d true_code 30 /* operation code for \.{true} */
-@d false_code 31 /* operation code for \.{false} */
-@d null_picture_code 32 /* operation code for \.{nullpicture} */
-@d null_pen_code 33 /* operation code for \.{nullpen} */
-@d job_name_op 34 /* operation code for \.{jobname} */
-@d read_string_op 35 /* operation code for \.{readstring} */
-@d pen_circle 36 /* operation code for \.{pencircle} */
-@d normal_deviate 37 /* operation code for \.{normaldeviate} */
-@d read_from_op 38 /* operation code for \.{readfrom} */
-@d close_from_op 39 /* operation code for \.{closefrom} */
-@d odd_op 40 /* operation code for \.{odd} */
-@d known_op 41 /* operation code for \.{known} */
-@d unknown_op 42 /* operation code for \.{unknown} */
-@d not_op 43 /* operation code for \.{not} */
-@d decimal 44 /* operation code for \.{decimal} */
-@d reverse 45 /* operation code for \.{reverse} */
-@d make_path_op 46 /* operation code for \.{makepath} */
-@d make_pen_op 47 /* operation code for \.{makepen} */
-@d oct_op 48 /* operation code for \.{oct} */
-@d hex_op 49 /* operation code for \.{hex} */
-@d ASCII_op 50 /* operation code for \.{ASCII} */
-@d char_op 51 /* operation code for \.{char} */
-@d length_op 52 /* operation code for \.{length} */
-@d turning_op 53 /* operation code for \.{turningnumber} */
-@d color_model_part 54 /* operation code for \.{colormodel} */
-@d x_part 55 /* operation code for \.{xpart} */
-@d y_part 56 /* operation code for \.{ypart} */
-@d xx_part 57 /* operation code for \.{xxpart} */
-@d xy_part 58 /* operation code for \.{xypart} */
-@d yx_part 59 /* operation code for \.{yxpart} */
-@d yy_part 60 /* operation code for \.{yypart} */
-@d red_part 61 /* operation code for \.{redpart} */
-@d green_part 62 /* operation code for \.{greenpart} */
-@d blue_part 63 /* operation code for \.{bluepart} */
-@d cyan_part 64 /* operation code for \.{cyanpart} */
-@d magenta_part 65 /* operation code for \.{magentapart} */
-@d yellow_part 66 /* operation code for \.{yellowpart} */
-@d black_part 67 /* operation code for \.{blackpart} */
-@d grey_part 68 /* operation code for \.{greypart} */
-@d font_part 69 /* operation code for \.{fontpart} */
-@d text_part 70 /* operation code for \.{textpart} */
-@d path_part 71 /* operation code for \.{pathpart} */
-@d pen_part 72 /* operation code for \.{penpart} */
-@d dash_part 73 /* operation code for \.{dashpart} */
-@d sqrt_op 74 /* operation code for \.{sqrt} */
-@d m_exp_op 75 /* operation code for \.{mexp} */
-@d m_log_op 76 /* operation code for \.{mlog} */
-@d sin_d_op 77 /* operation code for \.{sind} */
-@d cos_d_op 78 /* operation code for \.{cosd} */
-@d floor_op 79 /* operation code for \.{floor} */
-@d uniform_deviate 80 /* operation code for \.{uniformdeviate} */
-@d char_exists_op 81 /* operation code for \.{charexists} */
-@d font_size 82 /* operation code for \.{fontsize} */
-@d ll_corner_op 83 /* operation code for \.{llcorner} */
-@d lr_corner_op 84 /* operation code for \.{lrcorner} */
-@d ul_corner_op 85 /* operation code for \.{ulcorner} */
-@d ur_corner_op 86 /* operation code for \.{urcorner} */
-@d arc_length 87 /* operation code for \.{arclength} */
-@d angle_op 88 /* operation code for \.{angle} */
-@d cycle_op 89 /* operation code for \.{cycle} */
-@d filled_op 90 /* operation code for \.{filled} */
-@d stroked_op 91 /* operation code for \.{stroked} */
-@d textual_op 92 /* operation code for \.{textual} */
-@d clipped_op 93 /* operation code for \.{clipped} */
-@d bounded_op 94 /* operation code for \.{bounded} */
-@d plus 95 /* operation code for \.+ */
-@d minus 96 /* operation code for \.- */
-@d times 97 /* operation code for \.* */
-@d over 98 /* operation code for \./ */
-@d pythag_add 99 /* operation code for \.{++} */
-@d pythag_sub 100 /* operation code for \.{+-+} */
-@d or_op 101 /* operation code for \.{or} */
-@d and_op 102 /* operation code for \.{and} */
-@d less_than 103 /* operation code for \.< */
-@d less_or_equal 104 /* operation code for \.{<=} */
-@d greater_than 105 /* operation code for \.> */
-@d greater_or_equal 106 /* operation code for \.{>=} */
-@d equal_to 107 /* operation code for \.= */
-@d unequal_to 108 /* operation code for \.{<>} */
-@d concatenate 109 /* operation code for \.\& */
-@d rotated_by 110 /* operation code for \.{rotated} */
-@d slanted_by 111 /* operation code for \.{slanted} */
-@d scaled_by 112 /* operation code for \.{scaled} */
-@d shifted_by 113 /* operation code for \.{shifted} */
-@d transformed_by 114 /* operation code for \.{transformed} */
-@d x_scaled 115 /* operation code for \.{xscaled} */
-@d y_scaled 116 /* operation code for \.{yscaled} */
-@d z_scaled 117 /* operation code for \.{zscaled} */
-@d in_font 118 /* operation code for \.{infont} */
-@d intersect 119 /* operation code for \.{intersectiontimes} */
-@d double_dot 120 /* operation code for improper \.{..} */
-@d substring_of 121 /* operation code for \.{substring} */
-@d min_of substring_of
-@d subpath_of 122 /* operation code for \.{subpath} */
-@d direction_time_of 123 /* operation code for \.{directiontime} */
-@d point_of 124 /* operation code for \.{point} */
-@d precontrol_of 125 /* operation code for \.{precontrol} */
-@d postcontrol_of 126 /* operation code for \.{postcontrol} */
-@d pen_offset_of 127 /* operation code for \.{penoffset} */
-@d arc_time_of 128 /* operation code for \.{arctime} */
-@d mp_version 129 /* operation code for \.{mpversion} */
-@d envelope_of 130 /* operation code for \.{envelope} */
-
-@c void mp_print_op (MP mp,quarterword c) {
- if (c<=mp_numeric_type ) {
- mp_print_type(mp, c);
- } else {
- switch (c) {
- case true_code:mp_print(mp, "true"); break;
- case false_code:mp_print(mp, "false"); break;
- case null_picture_code:mp_print(mp, "nullpicture"); break;
- case null_pen_code:mp_print(mp, "nullpen"); break;
- case job_name_op:mp_print(mp, "jobname"); break;
- case read_string_op:mp_print(mp, "readstring"); break;
- case pen_circle:mp_print(mp, "pencircle"); break;
- case normal_deviate:mp_print(mp, "normaldeviate"); break;
- case read_from_op:mp_print(mp, "readfrom"); break;
- case close_from_op:mp_print(mp, "closefrom"); break;
- case odd_op:mp_print(mp, "odd"); break;
- case known_op:mp_print(mp, "known"); break;
- case unknown_op:mp_print(mp, "unknown"); break;
- case not_op:mp_print(mp, "not"); break;
- case decimal:mp_print(mp, "decimal"); break;
- case reverse:mp_print(mp, "reverse"); break;
- case make_path_op:mp_print(mp, "makepath"); break;
- case make_pen_op:mp_print(mp, "makepen"); break;
- case oct_op:mp_print(mp, "oct"); break;
- case hex_op:mp_print(mp, "hex"); break;
- case ASCII_op:mp_print(mp, "ASCII"); break;
- case char_op:mp_print(mp, "char"); break;
- case length_op:mp_print(mp, "length"); break;
- case turning_op:mp_print(mp, "turningnumber"); break;
- case x_part:mp_print(mp, "xpart"); break;
- case y_part:mp_print(mp, "ypart"); break;
- case xx_part:mp_print(mp, "xxpart"); break;
- case xy_part:mp_print(mp, "xypart"); break;
- case yx_part:mp_print(mp, "yxpart"); break;
- case yy_part:mp_print(mp, "yypart"); break;
- case red_part:mp_print(mp, "redpart"); break;
- case green_part:mp_print(mp, "greenpart"); break;
- case blue_part:mp_print(mp, "bluepart"); break;
- case cyan_part:mp_print(mp, "cyanpart"); break;
- case magenta_part:mp_print(mp, "magentapart"); break;
- case yellow_part:mp_print(mp, "yellowpart"); break;
- case black_part:mp_print(mp, "blackpart"); break;
- case grey_part:mp_print(mp, "greypart"); break;
- case color_model_part:mp_print(mp, "colormodel"); break;
- case font_part:mp_print(mp, "fontpart"); break;
- case text_part:mp_print(mp, "textpart"); break;
- case path_part:mp_print(mp, "pathpart"); break;
- case pen_part:mp_print(mp, "penpart"); break;
- case dash_part:mp_print(mp, "dashpart"); break;
- case sqrt_op:mp_print(mp, "sqrt"); break;
- case m_exp_op:mp_print(mp, "mexp"); break;
- case m_log_op:mp_print(mp, "mlog"); break;
- case sin_d_op:mp_print(mp, "sind"); break;
- case cos_d_op:mp_print(mp, "cosd"); break;
- case floor_op:mp_print(mp, "floor"); break;
- case uniform_deviate:mp_print(mp, "uniformdeviate"); break;
- case char_exists_op:mp_print(mp, "charexists"); break;
- case font_size:mp_print(mp, "fontsize"); break;
- case ll_corner_op:mp_print(mp, "llcorner"); break;
- case lr_corner_op:mp_print(mp, "lrcorner"); break;
- case ul_corner_op:mp_print(mp, "ulcorner"); break;
- case ur_corner_op:mp_print(mp, "urcorner"); break;
- case arc_length:mp_print(mp, "arclength"); break;
- case angle_op:mp_print(mp, "angle"); break;
- case cycle_op:mp_print(mp, "cycle"); break;
- case filled_op:mp_print(mp, "filled"); break;
- case stroked_op:mp_print(mp, "stroked"); break;
- case textual_op:mp_print(mp, "textual"); break;
- case clipped_op:mp_print(mp, "clipped"); break;
- case bounded_op:mp_print(mp, "bounded"); break;
- case plus:mp_print_char(mp, '+'); break;
- case minus:mp_print_char(mp, '-'); break;
- case times:mp_print_char(mp, '*'); break;
- case over:mp_print_char(mp, '/'); break;
- case pythag_add:mp_print(mp, "++"); break;
- case pythag_sub:mp_print(mp, "+-+"); break;
- case or_op:mp_print(mp, "or"); break;
- case and_op:mp_print(mp, "and"); break;
- case less_than:mp_print_char(mp, '<'); break;
- case less_or_equal:mp_print(mp, "<="); break;
- case greater_than:mp_print_char(mp, '>'); break;
- case greater_or_equal:mp_print(mp, ">="); break;
- case equal_to:mp_print_char(mp, '='); break;
- case unequal_to:mp_print(mp, "<>"); break;
- case concatenate:mp_print(mp, "&"); break;
- case rotated_by:mp_print(mp, "rotated"); break;
- case slanted_by:mp_print(mp, "slanted"); break;
- case scaled_by:mp_print(mp, "scaled"); break;
- case shifted_by:mp_print(mp, "shifted"); break;
- case transformed_by:mp_print(mp, "transformed"); break;
- case x_scaled:mp_print(mp, "xscaled"); break;
- case y_scaled:mp_print(mp, "yscaled"); break;
- case z_scaled:mp_print(mp, "zscaled"); break;
- case in_font:mp_print(mp, "infont"); break;
- case intersect:mp_print(mp, "intersectiontimes"); break;
- case substring_of:mp_print(mp, "substring"); break;
- case subpath_of:mp_print(mp, "subpath"); break;
- case direction_time_of:mp_print(mp, "directiontime"); break;
- case point_of:mp_print(mp, "point"); break;
- case precontrol_of:mp_print(mp, "precontrol"); break;
- case postcontrol_of:mp_print(mp, "postcontrol"); break;
- case pen_offset_of:mp_print(mp, "penoffset"); break;
- case arc_time_of:mp_print(mp, "arctime"); break;
- case mp_version:mp_print(mp, "mpversion"); break;
- case envelope_of:mp_print(mp, "envelope"); break;
- default: mp_print(mp, ".."); break;
- }
- }
-}
-
-@ \MP\ also has a bunch of internal parameters that a user might want to
-fuss with. Every such parameter has an identifying code number, defined here.
-
-@<Types...@>=
-enum mp_given_internal {
- mp_tracing_titles=1, /* show titles online when they appear */
- mp_tracing_equations, /* show each variable when it becomes known */
- mp_tracing_capsules, /* show capsules too */
- mp_tracing_choices, /* show the control points chosen for paths */
- mp_tracing_specs, /* show path subdivision prior to filling with polygonal a pen */
- mp_tracing_commands, /* show commands and operations before they are performed */
- mp_tracing_restores, /* show when a variable or internal is restored */
- mp_tracing_macros, /* show macros before they are expanded */
- mp_tracing_output, /* show digitized edges as they are output */
- mp_tracing_stats, /* show memory usage at end of job */
- mp_tracing_lost_chars, /* show characters that aren't \&{infont} */
- mp_tracing_online, /* show long diagnostics on terminal and in the log file */
- mp_year, /* the current year (e.g., 1984) */
- mp_month, /* the current month (e.g., 3 $\equiv$ March) */
- mp_day, /* the current day of the month */
- mp_time, /* the number of minutes past midnight when this job started */
- mp_char_code, /* the number of the next character to be output */
- mp_char_ext, /* the extension code of the next character to be output */
- mp_char_wd, /* the width of the next character to be output */
- mp_char_ht, /* the height of the next character to be output */
- mp_char_dp, /* the depth of the next character to be output */
- mp_char_ic, /* the italic correction of the next character to be output */
- mp_design_size, /* the unit of measure used for |mp_char_wd..mp_char_ic|, in points */
- mp_pausing, /* positive to display lines on the terminal before they are read */
- mp_showstopping, /* positive to stop after each \&{show} command */
- mp_fontmaking, /* positive if font metric output is to be produced */
- mp_linejoin, /* as in \ps: 0 for mitered, 1 for round, 2 for beveled */
- mp_linecap, /* as in \ps: 0 for butt, 1 for round, 2 for square */
- mp_miterlimit, /* controls miter length as in \ps */
- mp_warning_check, /* controls error message when variable value is large */
- mp_boundary_char, /* the right boundary character for ligatures */
- mp_prologues, /* positive to output conforming PostScript using built-in fonts */
- mp_true_corners, /* positive to make \&{llcorner} etc. ignore \&{setbounds} */
- mp_default_color_model, /* the default color model for unspecified items */
- mp_restore_clip_color,
- mp_procset, /* wether or not create PostScript command shortcuts */
- mp_gtroffmode /* whether the user specified |-troff| on the command line */
-};
-
-@
-
-@d max_given_internal mp_gtroffmode
-
-@<Glob...@>=
-scaled *internal; /* the values of internal quantities */
-char **int_name; /* their names */
-int int_ptr; /* the maximum internal quantity defined so far */
-int max_internal; /* current maximum number of internal quantities */
-
-@ @<Option variables@>=
-int troff_mode;
-
-@ @<Allocate or initialize ...@>=
-mp->max_internal=2*max_given_internal;
-mp->internal = xmalloc ((mp->max_internal+1), sizeof(scaled));
-mp->int_name = xmalloc ((mp->max_internal+1), sizeof(char *));
-mp->troff_mode=(opt->troff_mode>0 ? true : false);
-
-@ @<Exported function ...@>=
-int mp_troff_mode(MP mp);
-
-@ @c
-int mp_troff_mode(MP mp) { return mp->troff_mode; }
-
-@ @<Set initial ...@>=
-for (k=0;k<= mp->max_internal; k++ ) {
- mp->internal[k]=0;
- mp->int_name[k]=NULL;
-}
-mp->int_ptr=max_given_internal;
-
-@ The symbolic names for internal quantities are put into \MP's hash table
-by using a routine called |primitive|, which will be defined later. Let us
-enter them now, so that we don't have to list all those names again
-anywhere else.
-
-@<Put each of \MP's primitives into the hash table@>=
-mp_primitive(mp, "tracingtitles",internal_quantity,mp_tracing_titles);
-@:tracingtitles_}{\&{tracingtitles} primitive@>
-mp_primitive(mp, "tracingequations",internal_quantity,mp_tracing_equations);
-@:mp_tracing_equations_}{\&{tracingequations} primitive@>
-mp_primitive(mp, "tracingcapsules",internal_quantity,mp_tracing_capsules);
-@:mp_tracing_capsules_}{\&{tracingcapsules} primitive@>
-mp_primitive(mp, "tracingchoices",internal_quantity,mp_tracing_choices);
-@:mp_tracing_choices_}{\&{tracingchoices} primitive@>
-mp_primitive(mp, "tracingspecs",internal_quantity,mp_tracing_specs);
-@:mp_tracing_specs_}{\&{tracingspecs} primitive@>
-mp_primitive(mp, "tracingcommands",internal_quantity,mp_tracing_commands);
-@:mp_tracing_commands_}{\&{tracingcommands} primitive@>
-mp_primitive(mp, "tracingrestores",internal_quantity,mp_tracing_restores);
-@:mp_tracing_restores_}{\&{tracingrestores} primitive@>
-mp_primitive(mp, "tracingmacros",internal_quantity,mp_tracing_macros);
-@:mp_tracing_macros_}{\&{tracingmacros} primitive@>
-mp_primitive(mp, "tracingoutput",internal_quantity,mp_tracing_output);
-@:mp_tracing_output_}{\&{tracingoutput} primitive@>
-mp_primitive(mp, "tracingstats",internal_quantity,mp_tracing_stats);
-@:mp_tracing_stats_}{\&{tracingstats} primitive@>
-mp_primitive(mp, "tracinglostchars",internal_quantity,mp_tracing_lost_chars);
-@:mp_tracing_lost_chars_}{\&{tracinglostchars} primitive@>
-mp_primitive(mp, "tracingonline",internal_quantity,mp_tracing_online);
-@:mp_tracing_online_}{\&{tracingonline} primitive@>
-mp_primitive(mp, "year",internal_quantity,mp_year);
-@:mp_year_}{\&{year} primitive@>
-mp_primitive(mp, "month",internal_quantity,mp_month);
-@:mp_month_}{\&{month} primitive@>
-mp_primitive(mp, "day",internal_quantity,mp_day);
-@:mp_day_}{\&{day} primitive@>
-mp_primitive(mp, "time",internal_quantity,mp_time);
-@:time_}{\&{time} primitive@>
-mp_primitive(mp, "charcode",internal_quantity,mp_char_code);
-@:mp_char_code_}{\&{charcode} primitive@>
-mp_primitive(mp, "charext",internal_quantity,mp_char_ext);
-@:mp_char_ext_}{\&{charext} primitive@>
-mp_primitive(mp, "charwd",internal_quantity,mp_char_wd);
-@:mp_char_wd_}{\&{charwd} primitive@>
-mp_primitive(mp, "charht",internal_quantity,mp_char_ht);
-@:mp_char_ht_}{\&{charht} primitive@>
-mp_primitive(mp, "chardp",internal_quantity,mp_char_dp);
-@:mp_char_dp_}{\&{chardp} primitive@>
-mp_primitive(mp, "charic",internal_quantity,mp_char_ic);
-@:mp_char_ic_}{\&{charic} primitive@>
-mp_primitive(mp, "designsize",internal_quantity,mp_design_size);
-@:mp_design_size_}{\&{designsize} primitive@>
-mp_primitive(mp, "pausing",internal_quantity,mp_pausing);
-@:mp_pausing_}{\&{pausing} primitive@>
-mp_primitive(mp, "showstopping",internal_quantity,mp_showstopping);
-@:mp_showstopping_}{\&{showstopping} primitive@>
-mp_primitive(mp, "fontmaking",internal_quantity,mp_fontmaking);
-@:mp_fontmaking_}{\&{fontmaking} primitive@>
-mp_primitive(mp, "linejoin",internal_quantity,mp_linejoin);
-@:mp_linejoin_}{\&{linejoin} primitive@>
-mp_primitive(mp, "linecap",internal_quantity,mp_linecap);
-@:mp_linecap_}{\&{linecap} primitive@>
-mp_primitive(mp, "miterlimit",internal_quantity,mp_miterlimit);
-@:mp_miterlimit_}{\&{miterlimit} primitive@>
-mp_primitive(mp, "warningcheck",internal_quantity,mp_warning_check);
-@:mp_warning_check_}{\&{warningcheck} primitive@>
-mp_primitive(mp, "boundarychar",internal_quantity,mp_boundary_char);
-@:mp_boundary_char_}{\&{boundarychar} primitive@>
-mp_primitive(mp, "prologues",internal_quantity,mp_prologues);
-@:mp_prologues_}{\&{prologues} primitive@>
-mp_primitive(mp, "truecorners",internal_quantity,mp_true_corners);
-@:mp_true_corners_}{\&{truecorners} primitive@>
-mp_primitive(mp, "mpprocset",internal_quantity,mp_procset);
-@:mp_procset_}{\&{mpprocset} primitive@>
-mp_primitive(mp, "troffmode",internal_quantity,mp_gtroffmode);
-@:troffmode_}{\&{troffmode} primitive@>
-mp_primitive(mp, "defaultcolormodel",internal_quantity,mp_default_color_model);
-@:mp_default_color_model_}{\&{defaultcolormodel} primitive@>
-mp_primitive(mp, "restoreclipcolor",internal_quantity,mp_restore_clip_color);
-@:mp_restore_clip_color_}{\&{restoreclipcolor} primitive@>
-
-@ Colors can be specified in four color models. In the special
-case of |no_model|, MetaPost does not output any color operator to
-the postscript output.
-
-Note: these values are passed directly on to |with_option|. This only
-works because the other possible values passed to |with_option| are
-8 and 10 respectively (from |with_pen| and |with_picture|).
-
-There is a first state, that is only used for |gs_colormodel|. It flags
-the fact that there has not been any kind of color specification by
-the user so far in the game.
-
-@<Types...@>=
-enum mp_color_model {
- mp_no_model=1,
- mp_grey_model=3,
- mp_rgb_model=5,
- mp_cmyk_model=7,
- mp_uninitialized_model=9
-};
-
-
-@ @<Initialize table entries (done by \.{INIMP} only)@>=
-mp->internal[mp_default_color_model]=(mp_rgb_model*unity);
-mp->internal[mp_restore_clip_color]=unity;
-
-@ Well, we do have to list the names one more time, for use in symbolic
-printouts.
-
-@<Initialize table...@>=
-mp->int_name[mp_tracing_titles]=xstrdup("tracingtitles");
-mp->int_name[mp_tracing_equations]=xstrdup("tracingequations");
-mp->int_name[mp_tracing_capsules]=xstrdup("tracingcapsules");
-mp->int_name[mp_tracing_choices]=xstrdup("tracingchoices");
-mp->int_name[mp_tracing_specs]=xstrdup("tracingspecs");
-mp->int_name[mp_tracing_commands]=xstrdup("tracingcommands");
-mp->int_name[mp_tracing_restores]=xstrdup("tracingrestores");
-mp->int_name[mp_tracing_macros]=xstrdup("tracingmacros");
-mp->int_name[mp_tracing_output]=xstrdup("tracingoutput");
-mp->int_name[mp_tracing_stats]=xstrdup("tracingstats");
-mp->int_name[mp_tracing_lost_chars]=xstrdup("tracinglostchars");
-mp->int_name[mp_tracing_online]=xstrdup("tracingonline");
-mp->int_name[mp_year]=xstrdup("year");
-mp->int_name[mp_month]=xstrdup("month");
-mp->int_name[mp_day]=xstrdup("day");
-mp->int_name[mp_time]=xstrdup("time");
-mp->int_name[mp_char_code]=xstrdup("charcode");
-mp->int_name[mp_char_ext]=xstrdup("charext");
-mp->int_name[mp_char_wd]=xstrdup("charwd");
-mp->int_name[mp_char_ht]=xstrdup("charht");
-mp->int_name[mp_char_dp]=xstrdup("chardp");
-mp->int_name[mp_char_ic]=xstrdup("charic");
-mp->int_name[mp_design_size]=xstrdup("designsize");
-mp->int_name[mp_pausing]=xstrdup("pausing");
-mp->int_name[mp_showstopping]=xstrdup("showstopping");
-mp->int_name[mp_fontmaking]=xstrdup("fontmaking");
-mp->int_name[mp_linejoin]=xstrdup("linejoin");
-mp->int_name[mp_linecap]=xstrdup("linecap");
-mp->int_name[mp_miterlimit]=xstrdup("miterlimit");
-mp->int_name[mp_warning_check]=xstrdup("warningcheck");
-mp->int_name[mp_boundary_char]=xstrdup("boundarychar");
-mp->int_name[mp_prologues]=xstrdup("prologues");
-mp->int_name[mp_true_corners]=xstrdup("truecorners");
-mp->int_name[mp_default_color_model]=xstrdup("defaultcolormodel");
-mp->int_name[mp_procset]=xstrdup("mpprocset");
-mp->int_name[mp_gtroffmode]=xstrdup("troffmode");
-mp->int_name[mp_restore_clip_color]=xstrdup("restoreclipcolor");
-
-@ The following procedure, which is called just before \MP\ initializes its
-input and output, establishes the initial values of the date and time.
-@^system dependencies@>
-
-Note that the values are |scaled| integers. Hence \MP\ can no longer
-be used after the year 32767.
-
-@c
-void mp_fix_date_and_time (MP mp) {
- time_t aclock = time ((time_t *) 0);
- struct tm *tmptr = localtime (&aclock);
- mp->internal[mp_time]=
- (tmptr->tm_hour*60+tmptr->tm_min)*unity; /* minutes since midnight */
- mp->internal[mp_day]=(tmptr->tm_mday)*unity; /* fourth day of the month */
- mp->internal[mp_month]=(tmptr->tm_mon+1)*unity; /* seventh month of the year */
- mp->internal[mp_year]=(tmptr->tm_year+1900)*unity; /* Anno Domini */
-}
-
-@ @<Declarations@>=
-void mp_fix_date_and_time (MP mp) ;
-
-@ \MP\ is occasionally supposed to print diagnostic information that
-goes only into the transcript file, unless |mp_tracing_online| is positive.
-Now that we have defined |mp_tracing_online| we can define
-two routines that adjust the destination of print commands:
-
-@<Declarations@>=
-void mp_begin_diagnostic (MP mp) ;
-void mp_end_diagnostic (MP mp,boolean blank_line);
-void mp_print_diagnostic (MP mp, const char *s, const char *t, boolean nuline) ;
-
-@ @<Basic printing...@>=
-@<Declare a function called |true_line|@>
-void mp_begin_diagnostic (MP mp) { /* prepare to do some tracing */
- mp->old_setting=mp->selector;
- if ((mp->internal[mp_tracing_online]<=0)&&(mp->selector==term_and_log)){
- decr(mp->selector);
- if ( mp->history==mp_spotless ) mp->history=mp_warning_issued;
- }
-}
-@#
-void mp_end_diagnostic (MP mp,boolean blank_line) {
- /* restore proper conditions after tracing */
- mp_print_nl(mp, "");
- if ( blank_line ) mp_print_ln(mp);
- mp->selector=mp->old_setting;
-}
-
-@
-
-@<Glob...@>=
-unsigned int old_setting;
-
-@ We will occasionally use |begin_diagnostic| in connection with line-number
-printing, as follows. (The parameter |s| is typically |"Path"| or
-|"Cycle spec"|, etc.)
-
-@<Basic printing...@>=
-void mp_print_diagnostic (MP mp, const char *s, const char *t, boolean nuline) {
- mp_begin_diagnostic(mp);
- if ( nuline ) mp_print_nl(mp, s); else mp_print(mp, s);
- mp_print(mp, " at line ");
- mp_print_int(mp, mp_true_line(mp));
- mp_print(mp, t); mp_print_char(mp, ':');
-}
-
-@ The 256 |ASCII_code| characters are grouped into classes by means of
-the |char_class| table. Individual class numbers have no semantic
-or syntactic significance, except in a few instances defined here.
-There's also |max_class|, which can be used as a basis for additional
-class numbers in nonstandard extensions of \MP.
-
-@d digit_class 0 /* the class number of \.{0123456789} */
-@d period_class 1 /* the class number of `\..' */
-@d space_class 2 /* the class number of spaces and nonstandard characters */
-@d percent_class 3 /* the class number of `\.\%' */
-@d string_class 4 /* the class number of `\."' */
-@d right_paren_class 8 /* the class number of `\.)' */
-@d isolated_classes 5: case 6: case 7: case 8 /* characters that make length-one tokens only */
-@d letter_class 9 /* letters and the underline character */
-@d left_bracket_class 17 /* `\.[' */
-@d right_bracket_class 18 /* `\.]' */
-@d invalid_class 20 /* bad character in the input */
-@d max_class 20 /* the largest class number */
-
-@<Glob...@>=
-int char_class[256]; /* the class numbers */
-
-@ If changes are made to accommodate non-ASCII character sets, they should
-follow the guidelines in Appendix~C of {\sl The {\logos METAFONT\/}book}.
-@:METAFONTbook}{\sl The {\logos METAFONT\/}book@>
-@^system dependencies@>
-
-@<Set initial ...@>=
-for (k='0';k<='9';k++)
- mp->char_class[k]=digit_class;
-mp->char_class['.']=period_class;
-mp->char_class[' ']=space_class;
-mp->char_class['%']=percent_class;
-mp->char_class['"']=string_class;
-mp->char_class[',']=5;
-mp->char_class[';']=6;
-mp->char_class['(']=7;
-mp->char_class[')']=right_paren_class;
-for (k='A';k<= 'Z';k++ )
- mp->char_class[k]=letter_class;
-for (k='a';k<='z';k++)
- mp->char_class[k]=letter_class;
-mp->char_class['_']=letter_class;
-mp->char_class['<']=10;
-mp->char_class['=']=10;
-mp->char_class['>']=10;
-mp->char_class[':']=10;
-mp->char_class['|']=10;
-mp->char_class['`']=11;
-mp->char_class['\'']=11;
-mp->char_class['+']=12;
-mp->char_class['-']=12;
-mp->char_class['/']=13;
-mp->char_class['*']=13;
-mp->char_class['\\']=13;
-mp->char_class['!']=14;
-mp->char_class['?']=14;
-mp->char_class['#']=15;
-mp->char_class['&']=15;
-mp->char_class['@@']=15;
-mp->char_class['$']=15;
-mp->char_class['^']=16;
-mp->char_class['~']=16;
-mp->char_class['[']=left_bracket_class;
-mp->char_class[']']=right_bracket_class;
-mp->char_class['{']=19;
-mp->char_class['}']=19;
-for (k=0;k<' ';k++)
- mp->char_class[k]=invalid_class;
-mp->char_class['\t']=space_class;
-mp->char_class['\f']=space_class;
-for (k=127;k<=255;k++)
- mp->char_class[k]=invalid_class;
-
-@* \[13] The hash table.
-Symbolic tokens are stored and retrieved by means of a fairly standard hash
-table algorithm called the method of ``coalescing lists'' (cf.\ Algorithm 6.4C
-in {\sl The Art of Computer Programming\/}). Once a symbolic token enters the
-table, it is never removed.
-
-The actual sequence of characters forming a symbolic token is
-stored in the |str_pool| array together with all the other strings. An
-auxiliary array |hash| consists of items with two halfword fields per
-word. The first of these, called |next(p)|, points to the next identifier
-belonging to the same coalesced list as the identifier corresponding to~|p|;
-and the other, called |text(p)|, points to the |str_start| entry for
-|p|'s identifier. If position~|p| of the hash table is empty, we have
-|text(p)=0|; if position |p| is either empty or the end of a coalesced
-hash list, we have |next(p)=0|.
-
-An auxiliary pointer variable called |hash_used| is maintained in such a
-way that all locations |p>=hash_used| are nonempty. The global variable
-|st_count| tells how many symbolic tokens have been defined, if statistics
-are being kept.
-
-The first 256 locations of |hash| are reserved for symbols of length one.
-
-There's a parallel array called |eqtb| that contains the current equivalent
-values of each symbolic token. The entries of this array consist of
-two halfwords called |eq_type| (a command code) and |equiv| (a secondary
-piece of information that qualifies the |eq_type|).
-
-@d next(A) mp->hash[(A)].lh /* link for coalesced lists */
-@d text(A) mp->hash[(A)].rh /* string number for symbolic token name */
-@d eq_type(A) mp->eqtb[(A)].lh /* the current ``meaning'' of a symbolic token */
-@d equiv(A) mp->eqtb[(A)].rh /* parametric part of a token's meaning */
-@d hash_base 257 /* hashing actually starts here */
-@d hash_is_full (mp->hash_used==hash_base) /* are all positions occupied? */
-
-@<Glob...@>=
-pointer hash_used; /* allocation pointer for |hash| */
-integer st_count; /* total number of known identifiers */
-
-@ Certain entries in the hash table are ``frozen'' and not redefinable,
-since they are used in error recovery.
-
-@d hash_top (hash_base+mp->hash_size) /* the first location of the frozen area */
-@d frozen_inaccessible hash_top /* |hash| location to protect the frozen area */
-@d frozen_repeat_loop (hash_top+1) /* |hash| location of a loop-repeat token */
-@d frozen_right_delimiter (hash_top+2) /* |hash| location of a permanent `\.)' */
-@d frozen_left_bracket (hash_top+3) /* |hash| location of a permanent `\.[' */
-@d frozen_slash (hash_top+4) /* |hash| location of a permanent `\./' */
-@d frozen_colon (hash_top+5) /* |hash| location of a permanent `\.:' */
-@d frozen_semicolon (hash_top+6) /* |hash| location of a permanent `\.;' */
-@d frozen_end_for (hash_top+7) /* |hash| location of a permanent \&{endfor} */
-@d frozen_end_def (hash_top+8) /* |hash| location of a permanent \&{enddef} */
-@d frozen_fi (hash_top+9) /* |hash| location of a permanent \&{fi} */
-@d frozen_end_group (hash_top+10) /* |hash| location of a permanent `\.{endgroup}' */
-@d frozen_etex (hash_top+11) /* |hash| location of a permanent \&{etex} */
-@d frozen_mpx_break (hash_top+12) /* |hash| location of a permanent \&{mpxbreak} */
-@d frozen_bad_vardef (hash_top+13) /* |hash| location of `\.{a bad variable}' */
-@d frozen_undefined (hash_top+14) /* |hash| location that never gets defined */
-@d hash_end (hash_top+14) /* the actual size of the |hash| and |eqtb| arrays */
-
-@<Glob...@>=
-two_halves *hash; /* the hash table */
-two_halves *eqtb; /* the equivalents */
-
-@ @<Allocate or initialize ...@>=
-mp->hash = xmalloc((hash_end+1),sizeof(two_halves));
-mp->eqtb = xmalloc((hash_end+1),sizeof(two_halves));
-
-@ @<Dealloc variables@>=
-xfree(mp->hash);
-xfree(mp->eqtb);
-
-@ @<Set init...@>=
-next(1)=0; text(1)=0; eq_type(1)=tag_token; equiv(1)=null;
-for (k=2;k<=hash_end;k++) {
- mp->hash[k]=mp->hash[1]; mp->eqtb[k]=mp->eqtb[1];
-}
-
-@ @<Initialize table entries...@>=
-mp->hash_used=frozen_inaccessible; /* nothing is used */
-mp->st_count=0;
-text(frozen_bad_vardef)=intern("a bad variable");
-text(frozen_etex)=intern("etex");
-text(frozen_mpx_break)=intern("mpxbreak");
-text(frozen_fi)=intern("fi");
-text(frozen_end_group)=intern("endgroup");
-text(frozen_end_def)=intern("enddef");
-text(frozen_end_for)=intern("endfor");
-text(frozen_semicolon)=intern(";");
-text(frozen_colon)=intern(":");
-text(frozen_slash)=intern("/");
-text(frozen_left_bracket)=intern("[");
-text(frozen_right_delimiter)=intern(")");
-text(frozen_inaccessible)=intern(" INACCESSIBLE");
-eq_type(frozen_right_delimiter)=right_delimiter;
-
-@ @<Check the ``constant'' values...@>=
-if ( hash_end+mp->max_internal>max_halfword ) mp->bad=17;
-
-@ Here is the subroutine that searches the hash table for an identifier
-that matches a given string of length~|l| appearing in |buffer[j..
-(j+l-1)]|. If the identifier is not found, it is inserted; hence it
-will always be found, and the corresponding hash table address
-will be returned.
-
-@c
-pointer mp_id_lookup (MP mp,integer j, integer l) { /* search the hash table */
- integer h; /* hash code */
- pointer p; /* index in |hash| array */
- pointer k; /* index in |buffer| array */
- if (l==1) {
- @<Treat special case of length 1 and |break|@>;
- }
- @<Compute the hash code |h|@>;
- p=h+hash_base; /* we start searching here; note that |0<=h<hash_prime| */
- while (true) {
- if (text(p)>0 && length(text(p))==l && mp_str_eq_buf(mp, text(p),j))
- break;
- if ( next(p)==0 ) {
- @<Insert a new symbolic token after |p|, then
- make |p| point to it and |break|@>;
- }
- p=next(p);
- }
- return p;
-}
-
-@ @<Treat special case of length 1...@>=
- p=mp->buffer[j]+1; text(p)=p-1; return p;
-
-
-@ @<Insert a new symbolic...@>=
-{
-if ( text(p)>0 ) {
- do {
- if ( hash_is_full )
- mp_overflow(mp, "hash size",mp->hash_size);
-@:MetaPost capacity exceeded hash size}{\quad hash size@>
- decr(mp->hash_used);
- } while (text(mp->hash_used)!=0); /* search for an empty location in |hash| */
- next(p)=mp->hash_used;
- p=mp->hash_used;
-}
-str_room(l);
-for (k=j;k<=j+l-1;k++) {
- append_char(mp->buffer[k]);
-}
-text(p)=mp_make_string(mp);
-mp->str_ref[text(p)]=max_str_ref;
-incr(mp->st_count);
-break;
-}
-
-
-@ The value of |hash_prime| should be roughly 85\pct! of |hash_size|, and it
-should be a prime number. The theory of hashing tells us to expect fewer
-than two table probes, on the average, when the search is successful.
-[See J.~S. Vitter, {\sl Journal of the ACM\/ \bf30} (1983), 231--258.]
-@^Vitter, Jeffrey Scott@>
-
-@<Compute the hash code |h|@>=
-h=mp->buffer[j];
-for (k=j+1;k<=j+l-1;k++){
- h=h+h+mp->buffer[k];
- while ( h>=mp->hash_prime ) h=h-mp->hash_prime;
-}
-
-@ @<Search |eqtb| for equivalents equal to |p|@>=
-for (q=1;q<=hash_end;q++) {
- if ( equiv(q)==p ) {
- mp_print_nl(mp, "EQUIV(");
- mp_print_int(mp, q);
- mp_print_char(mp, ')');
- }
-}
-
-@ We need to put \MP's ``primitive'' symbolic tokens into the hash
-table, together with their command code (which will be the |eq_type|)
-and an operand (which will be the |equiv|). The |primitive| procedure
-does this, in a way that no \MP\ user can. The global value |cur_sym|
-contains the new |eqtb| pointer after |primitive| has acted.
-
-@c
-void mp_primitive (MP mp, const char *ss, halfword c, halfword o) {
- pool_pointer k; /* index into |str_pool| */
- small_number j; /* index into |buffer| */
- small_number l; /* length of the string */
- str_number s;
- s = intern(ss);
- k=mp->str_start[s]; l=str_stop(s)-k;
- /* we will move |s| into the (empty) |buffer| */
- for (j=0;j<=l-1;j++) {
- mp->buffer[j]=mp->str_pool[k+j];
- }
- mp->cur_sym=mp_id_lookup(mp, 0,l);
- if ( s>=256 ) { /* we don't want to have the string twice */
- mp_flush_string(mp, text(mp->cur_sym)); text(mp->cur_sym)=s;
- };
- eq_type(mp->cur_sym)=c;
- equiv(mp->cur_sym)=o;
-}
-
-
-@ Many of \MP's primitives need no |equiv|, since they are identifiable
-by their |eq_type| alone. These primitives are loaded into the hash table
-as follows:
-
-@<Put each of \MP's primitives into the hash table@>=
-mp_primitive(mp, "..",path_join,0);
-@:.._}{\.{..} primitive@>
-mp_primitive(mp, "[",left_bracket,0); mp->eqtb[frozen_left_bracket]=mp->eqtb[mp->cur_sym];
-@:[ }{\.{[} primitive@>
-mp_primitive(mp, "]",right_bracket,0);
-@:] }{\.{]} primitive@>
-mp_primitive(mp, "}",right_brace,0);
-@:]]}{\.{\char`\}} primitive@>
-mp_primitive(mp, "{",left_brace,0);
-@:][}{\.{\char`\{} primitive@>
-mp_primitive(mp, ":",colon,0); mp->eqtb[frozen_colon]=mp->eqtb[mp->cur_sym];
-@:: }{\.{:} primitive@>
-mp_primitive(mp, "::",double_colon,0);
-@::: }{\.{::} primitive@>
-mp_primitive(mp, "||:",bchar_label,0);
-@:::: }{\.{\char'174\char'174:} primitive@>
-mp_primitive(mp, ":=",assignment,0);
-@::=_}{\.{:=} primitive@>
-mp_primitive(mp, ",",comma,0);
-@:, }{\., primitive@>
-mp_primitive(mp, ";",semicolon,0); mp->eqtb[frozen_semicolon]=mp->eqtb[mp->cur_sym];
-@:; }{\.; primitive@>
-mp_primitive(mp, "\\",relax,0);
-@:]]\\}{\.{\char`\\} primitive@>
-@#
-mp_primitive(mp, "addto",add_to_command,0);
-@:add_to_}{\&{addto} primitive@>
-mp_primitive(mp, "atleast",at_least,0);
-@:at_least_}{\&{atleast} primitive@>
-mp_primitive(mp, "begingroup",begin_group,0); mp->bg_loc=mp->cur_sym;
-@:begin_group_}{\&{begingroup} primitive@>
-mp_primitive(mp, "controls",controls,0);
-@:controls_}{\&{controls} primitive@>
-mp_primitive(mp, "curl",curl_command,0);
-@:curl_}{\&{curl} primitive@>
-mp_primitive(mp, "delimiters",delimiters,0);
-@:delimiters_}{\&{delimiters} primitive@>
-mp_primitive(mp, "endgroup",end_group,0);
- mp->eqtb[frozen_end_group]=mp->eqtb[mp->cur_sym]; mp->eg_loc=mp->cur_sym;
-@:endgroup_}{\&{endgroup} primitive@>
-mp_primitive(mp, "everyjob",every_job_command,0);
-@:every_job_}{\&{everyjob} primitive@>
-mp_primitive(mp, "exitif",exit_test,0);
-@:exit_if_}{\&{exitif} primitive@>
-mp_primitive(mp, "expandafter",expand_after,0);
-@:expand_after_}{\&{expandafter} primitive@>
-mp_primitive(mp, "interim",interim_command,0);
-@:interim_}{\&{interim} primitive@>
-mp_primitive(mp, "let",let_command,0);
-@:let_}{\&{let} primitive@>
-mp_primitive(mp, "newinternal",new_internal,0);
-@:new_internal_}{\&{newinternal} primitive@>
-mp_primitive(mp, "of",of_token,0);
-@:of_}{\&{of} primitive@>
-mp_primitive(mp, "randomseed",mp_random_seed,0);
-@:mp_random_seed_}{\&{randomseed} primitive@>
-mp_primitive(mp, "save",save_command,0);
-@:save_}{\&{save} primitive@>
-mp_primitive(mp, "scantokens",scan_tokens,0);
-@:scan_tokens_}{\&{scantokens} primitive@>
-mp_primitive(mp, "shipout",ship_out_command,0);
-@:ship_out_}{\&{shipout} primitive@>
-mp_primitive(mp, "skipto",skip_to,0);
-@:skip_to_}{\&{skipto} primitive@>
-mp_primitive(mp, "special",special_command,0);
-@:special}{\&{special} primitive@>
-mp_primitive(mp, "fontmapfile",special_command,1);
-@:fontmapfile}{\&{fontmapfile} primitive@>
-mp_primitive(mp, "fontmapline",special_command,2);
-@:fontmapline}{\&{fontmapline} primitive@>
-mp_primitive(mp, "step",step_token,0);
-@:step_}{\&{step} primitive@>
-mp_primitive(mp, "str",str_op,0);
-@:str_}{\&{str} primitive@>
-mp_primitive(mp, "tension",tension,0);
-@:tension_}{\&{tension} primitive@>
-mp_primitive(mp, "to",to_token,0);
-@:to_}{\&{to} primitive@>
-mp_primitive(mp, "until",until_token,0);
-@:until_}{\&{until} primitive@>
-mp_primitive(mp, "within",within_token,0);
-@:within_}{\&{within} primitive@>
-mp_primitive(mp, "write",write_command,0);
-@:write_}{\&{write} primitive@>
-
-@ Each primitive has a corresponding inverse, so that it is possible to
-display the cryptic numeric contents of |eqtb| in symbolic form.
-Every call of |primitive| in this program is therefore accompanied by some
-straightforward code that forms part of the |print_cmd_mod| routine
-explained below.
-
-@<Cases of |print_cmd_mod| for symbolic printing of primitives@>=
-case add_to_command:mp_print(mp, "addto"); break;
-case assignment:mp_print(mp, ":="); break;
-case at_least:mp_print(mp, "atleast"); break;
-case bchar_label:mp_print(mp, "||:"); break;
-case begin_group:mp_print(mp, "begingroup"); break;
-case colon:mp_print(mp, ":"); break;
-case comma:mp_print(mp, ","); break;
-case controls:mp_print(mp, "controls"); break;
-case curl_command:mp_print(mp, "curl"); break;
-case delimiters:mp_print(mp, "delimiters"); break;
-case double_colon:mp_print(mp, "::"); break;
-case end_group:mp_print(mp, "endgroup"); break;
-case every_job_command:mp_print(mp, "everyjob"); break;
-case exit_test:mp_print(mp, "exitif"); break;
-case expand_after:mp_print(mp, "expandafter"); break;
-case interim_command:mp_print(mp, "interim"); break;
-case left_brace:mp_print(mp, "{"); break;
-case left_bracket:mp_print(mp, "["); break;
-case let_command:mp_print(mp, "let"); break;
-case new_internal:mp_print(mp, "newinternal"); break;
-case of_token:mp_print(mp, "of"); break;
-case path_join:mp_print(mp, ".."); break;
-case mp_random_seed:mp_print(mp, "randomseed"); break;
-case relax:mp_print_char(mp, '\\'); break;
-case right_brace:mp_print(mp, "}"); break;
-case right_bracket:mp_print(mp, "]"); break;
-case save_command:mp_print(mp, "save"); break;
-case scan_tokens:mp_print(mp, "scantokens"); break;
-case semicolon:mp_print(mp, ";"); break;
-case ship_out_command:mp_print(mp, "shipout"); break;
-case skip_to:mp_print(mp, "skipto"); break;
-case special_command: if ( m==2 ) mp_print(mp, "fontmapline"); else
- if ( m==1 ) mp_print(mp, "fontmapfile"); else
- mp_print(mp, "special"); break;
-case step_token:mp_print(mp, "step"); break;
-case str_op:mp_print(mp, "str"); break;
-case tension:mp_print(mp, "tension"); break;
-case to_token:mp_print(mp, "to"); break;
-case until_token:mp_print(mp, "until"); break;
-case within_token:mp_print(mp, "within"); break;
-case write_command:mp_print(mp, "write"); break;
-
-@ We will deal with the other primitives later, at some point in the program
-where their |eq_type| and |equiv| values are more meaningful. For example,
-the primitives for macro definitions will be loaded when we consider the
-routines that define macros.
-It is easy to find where each particular
-primitive was treated by looking in the index at the end; for example, the
-section where |"def"| entered |eqtb| is listed under `\&{def} primitive'.
-
-@* \[14] Token lists.
-A \MP\ token is either symbolic or numeric or a string, or it denotes
-a macro parameter or capsule; so there are five corresponding ways to encode it
-@^token@>
-internally: (1)~A symbolic token whose hash code is~|p|
-is represented by the number |p|, in the |info| field of a single-word
-node in~|mem|. (2)~A numeric token whose |scaled| value is~|v| is
-represented in a two-word node of~|mem|; the |type| field is |known|,
-the |name_type| field is |token|, and the |value| field holds~|v|.
-The fact that this token appears in a two-word node rather than a
-one-word node is, of course, clear from the node address.
-(3)~A string token is also represented in a two-word node; the |type|
-field is |mp_string_type|, the |name_type| field is |token|, and the
-|value| field holds the corresponding |str_number|. (4)~Capsules have
-|name_type=capsule|, and their |type| and |value| fields represent
-arbitrary values (in ways to be explained later). (5)~Macro parameters
-are like symbolic tokens in that they appear in |info| fields of
-one-word nodes. The $k$th parameter is represented by |expr_base+k| if it
-is of type \&{expr}, or by |suffix_base+k| if it is of type \&{suffix}, or
-by |text_base+k| if it is of type \&{text}. (Here |0<=k<param_size|.)
-Actual values of these parameters are kept in a separate stack, as we will
-see later. The constants |expr_base|, |suffix_base|, and |text_base| are,
-of course, chosen so that there will be no confusion between symbolic
-tokens and parameters of various types.
-
-Note that
-the `\\{type}' field of a node has nothing to do with ``type'' in a
-printer's sense. It's curious that the same word is used in such different ways.
-
-@d type(A) mp->mem[(A)].hh.b0 /* identifies what kind of value this is */
-@d name_type(A) mp->mem[(A)].hh.b1 /* a clue to the name of this value */
-@d token_node_size 2 /* the number of words in a large token node */
-@d value_loc(A) ((A)+1) /* the word that contains the |value| field */
-@d value(A) mp->mem[value_loc((A))].cint /* the value stored in a large token node */
-@d expr_base (hash_end+1) /* code for the zeroth \&{expr} parameter */
-@d suffix_base (expr_base+mp->param_size) /* code for the zeroth \&{suffix} parameter */
-@d text_base (suffix_base+mp->param_size) /* code for the zeroth \&{text} parameter */
-
-@<Check the ``constant''...@>=
-if ( text_base+mp->param_size>max_halfword ) mp->bad=18;
-
-@ We have set aside a two word node beginning at |null| so that we can have
-|value(null)=0|. We will make use of this coincidence later.
-
-@<Initialize table entries...@>=
-link(null)=null; value(null)=0;
-
-@ A numeric token is created by the following trivial routine.
-
-@c
-pointer mp_new_num_tok (MP mp,scaled v) {
- pointer p; /* the new node */
- p=mp_get_node(mp, token_node_size); value(p)=v;
- type(p)=mp_known; name_type(p)=mp_token;
- return p;
-}
-
-@ A token list is a singly linked list of nodes in |mem|, where
-each node contains a token and a link. Here's a subroutine that gets rid
-of a token list when it is no longer needed.
-
-@c void mp_flush_token_list (MP mp,pointer p) {
- pointer q; /* the node being recycled */
- while ( p!=null ) {
- q=p; p=link(p);
- if ( q>=mp->hi_mem_min ) {
- free_avail(q);
- } else {
- switch (type(q)) {
- case mp_vacuous: case mp_boolean_type: case mp_known:
- break;
- case mp_string_type:
- delete_str_ref(value(q));
- break;
- case unknown_types: case mp_pen_type: case mp_path_type:
- case mp_picture_type: case mp_pair_type: case mp_color_type:
- case mp_cmykcolor_type: case mp_transform_type: case mp_dependent:
- case mp_proto_dependent: case mp_independent:
- mp_recycle_value(mp,q);
- break;
- default: mp_confusion(mp, "token");
-@:this can't happen token}{\quad token@>
- }
- mp_free_node(mp, q,token_node_size);
- }
- }
-}
-
-@ The procedure |show_token_list|, which prints a symbolic form of
-the token list that starts at a given node |p|, illustrates these
-conventions. The token list being displayed should not begin with a reference
-count. However, the procedure is intended to be fairly robust, so that if the
-memory links are awry or if |p| is not really a pointer to a token list,
-almost nothing catastrophic can happen.
-
-An additional parameter |q| is also given; this parameter is either null
-or it points to a node in the token list where a certain magic computation
-takes place that will be explained later. (Basically, |q| is non-null when
-we are printing the two-line context information at the time of an error
-message; |q| marks the place corresponding to where the second line
-should begin.)
-
-The generation will stop, and `\.{\char`\ ETC.}' will be printed, if the length
-of printing exceeds a given limit~|l|; the length of printing upon entry is
-assumed to be a given amount called |null_tally|. (Note that
-|show_token_list| sometimes uses itself recursively to print
-variable names within a capsule.)
-@^recursion@>
-
-Unusual entries are printed in the form of all-caps tokens
-preceded by a space, e.g., `\.{\char`\ BAD}'.
-
-@<Declare the procedure called |show_token_list|@>=
-void mp_show_token_list (MP mp, integer p, integer q, integer l,
- integer null_tally) ;
-
-@ @c
-void mp_show_token_list (MP mp, integer p, integer q, integer l,
- integer null_tally) {
- small_number class,c; /* the |char_class| of previous and new tokens */
- integer r,v; /* temporary registers */
- class=percent_class;
- mp->tally=null_tally;
- while ( (p!=null) && (mp->tally<l) ) {
- if ( p==q )
- @<Do magic computation@>;
- @<Display token |p| and set |c| to its class;
- but |return| if there are problems@>;
- class=c; p=link(p);
- }
- if ( p!=null )
- mp_print(mp, " ETC.");
-@.ETC@>
- return;
-}
-
-@ @<Display token |p| and set |c| to its class...@>=
-c=letter_class; /* the default */
-if ( (p<0)||(p>mp->mem_end) ) {
- mp_print(mp, " CLOBBERED"); return;
-@.CLOBBERED@>
-}
-if ( p<mp->hi_mem_min ) {
- @<Display two-word token@>;
-} else {
- r=info(p);
- if ( r>=expr_base ) {
- @<Display a parameter token@>;
- } else {
- if ( r<1 ) {
- if ( r==0 ) {
- @<Display a collective subscript@>
- } else {
- mp_print(mp, " IMPOSSIBLE");
-@.IMPOSSIBLE@>
- }
- } else {
- r=text(r);
- if ( (r<0)||(r>mp->max_str_ptr) ) {
- mp_print(mp, " NONEXISTENT");
-@.NONEXISTENT@>
- } else {
- @<Print string |r| as a symbolic token
- and set |c| to its class@>;
- }
- }
- }
-}
-
-@ @<Display two-word token@>=
-if ( name_type(p)==mp_token ) {
- if ( type(p)==mp_known ) {
- @<Display a numeric token@>;
- } else if ( type(p)!=mp_string_type ) {
- mp_print(mp, " BAD");
-@.BAD@>
- } else {
- mp_print_char(mp, '"'); mp_print_str(mp, value(p)); mp_print_char(mp, '"');
- c=string_class;
- }
-} else if ((name_type(p)!=mp_capsule)||(type(p)<mp_vacuous)||(type(p)>mp_independent) ) {
- mp_print(mp, " BAD");
-} else {
- mp_print_capsule(mp,p); c=right_paren_class;
-}
-
-@ @<Display a numeric token@>=
-if ( class==digit_class )
- mp_print_char(mp, ' ');
-v=value(p);
-if ( v<0 ){
- if ( class==left_bracket_class )
- mp_print_char(mp, ' ');
- mp_print_char(mp, '['); mp_print_scaled(mp, v); mp_print_char(mp, ']');
- c=right_bracket_class;
-} else {
- mp_print_scaled(mp, v); c=digit_class;
-}
-
-
-@ Strictly speaking, a genuine token will never have |info(p)=0|.
-But we will see later (in the |print_variable_name| routine) that
-it is convenient to let |info(p)=0| stand for `\.{[]}'.
-
-@<Display a collective subscript@>=
-{
-if ( class==left_bracket_class )
- mp_print_char(mp, ' ');
-mp_print(mp, "[]"); c=right_bracket_class;
-}
-
-@ @<Display a parameter token@>=
-{
-if ( r<suffix_base ) {
- mp_print(mp, "(EXPR"); r=r-(expr_base);
-@.EXPR@>
-} else if ( r<text_base ) {
- mp_print(mp, "(SUFFIX"); r=r-(suffix_base);
-@.SUFFIX@>
-} else {
- mp_print(mp, "(TEXT"); r=r-(text_base);
-@.TEXT@>
-}
-mp_print_int(mp, r); mp_print_char(mp, ')'); c=right_paren_class;
-}
-
-
-@ @<Print string |r| as a symbolic token...@>=
-{
-c=mp->char_class[mp->str_pool[mp->str_start[r]]];
-if ( c==class ) {
- switch (c) {
- case letter_class:mp_print_char(mp, '.'); break;
- case isolated_classes: break;
- default: mp_print_char(mp, ' '); break;
- }
-}
-mp_print_str(mp, r);
-}
-
-@ @<Declarations@>=
-void mp_print_capsule (MP mp, pointer p);
-
-@ @<Declare miscellaneous procedures that were declared |forward|@>=
-void mp_print_capsule (MP mp, pointer p) {
- mp_print_char(mp, '('); mp_print_exp(mp,p,0); mp_print_char(mp, ')');
-}
-
-@ Macro definitions are kept in \MP's memory in the form of token lists
-that have a few extra one-word nodes at the beginning.
-
-The first node contains a reference count that is used to tell when the
-list is no longer needed. To emphasize the fact that a reference count is
-present, we shall refer to the |info| field of this special node as the
-|ref_count| field.
-@^reference counts@>
-
-The next node or nodes after the reference count serve to describe the
-formal parameters. They consist of zero or more parameter tokens followed
-by a code for the type of macro.
-
-@d ref_count info
- /* reference count preceding a macro definition or picture header */
-@d add_mac_ref(A) incr(ref_count((A))) /* make a new reference to a macro list */
-@d general_macro 0 /* preface to a macro defined with a parameter list */
-@d primary_macro 1 /* preface to a macro with a \&{primary} parameter */
-@d secondary_macro 2 /* preface to a macro with a \&{secondary} parameter */
-@d tertiary_macro 3 /* preface to a macro with a \&{tertiary} parameter */
-@d expr_macro 4 /* preface to a macro with an undelimited \&{expr} parameter */
-@d of_macro 5 /* preface to a macro with
- undelimited `\&{expr} |x| \&{of}~|y|' parameters */
-@d suffix_macro 6 /* preface to a macro with an undelimited \&{suffix} parameter */
-@d text_macro 7 /* preface to a macro with an undelimited \&{text} parameter */
-
-@c
-void mp_delete_mac_ref (MP mp,pointer p) {
- /* |p| points to the reference count of a macro list that is
- losing one reference */
- if ( ref_count(p)==null ) mp_flush_token_list(mp, p);
- else decr(ref_count(p));
-}
-
-@ The following subroutine displays a macro, given a pointer to its
-reference count.
-
-@c
-@<Declare the procedure called |print_cmd_mod|@>
-void mp_show_macro (MP mp, pointer p, integer q, integer l) {
- pointer r; /* temporary storage */
- p=link(p); /* bypass the reference count */
- while ( info(p)>text_macro ){
- r=link(p); link(p)=null;
- mp_show_token_list(mp, p,null,l,0); link(p)=r; p=r;
- if ( l>0 ) l=l-mp->tally; else return;
- } /* control printing of `\.{ETC.}' */
-@.ETC@>
- mp->tally=0;
- switch(info(p)) {
- case general_macro:mp_print(mp, "->"); break;
-@.->@>
- case primary_macro: case secondary_macro: case tertiary_macro:
- mp_print_char(mp, '<');
- mp_print_cmd_mod(mp, param_type,info(p));
- mp_print(mp, ">->");
- break;
- case expr_macro:mp_print(mp, "<expr>->"); break;
- case of_macro:mp_print(mp, "<expr>of<primary>->"); break;
- case suffix_macro:mp_print(mp, "<suffix>->"); break;
- case text_macro:mp_print(mp, "<text>->"); break;
- } /* there are no other cases */
- mp_show_token_list(mp, link(p),q,l-mp->tally,0);
-}
-
-@* \[15] Data structures for variables.
-The variables of \MP\ programs can be simple, like `\.x', or they can
-combine the structural properties of arrays and records, like `\.{x20a.b}'.
-A \MP\ user assigns a type to a variable like \.{x20a.b} by saying, for
-example, `\.{boolean} \.{x[]a.b}'. It's time for us to study how such
-things are represented inside of the computer.
-
-Each variable value occupies two consecutive words, either in a two-word
-node called a value node, or as a two-word subfield of a larger node. One
-of those two words is called the |value| field; it is an integer,
-containing either a |scaled| numeric value or the representation of some
-other type of quantity. (It might also be subdivided into halfwords, in
-which case it is referred to by other names instead of |value|.) The other
-word is broken into subfields called |type|, |name_type|, and |link|. The
-|type| field is a quarterword that specifies the variable's type, and
-|name_type| is a quarterword from which \MP\ can reconstruct the
-variable's name (sometimes by using the |link| field as well). Thus, only
-1.25 words are actually devoted to the value itself; the other
-three-quarters of a word are overhead, but they aren't wasted because they
-allow \MP\ to deal with sparse arrays and to provide meaningful diagnostics.
-
-In this section we shall be concerned only with the structural aspects of
-variables, not their values. Later parts of the program will change the
-|type| and |value| fields, but we shall treat those fields as black boxes
-whose contents should not be touched.
-
-However, if the |type| field is |mp_structured|, there is no |value| field,
-and the second word is broken into two pointer fields called |attr_head|
-and |subscr_head|. Those fields point to additional nodes that
-contain structural information, as we shall see.
-
-@d subscr_head_loc(A) (A)+1 /* where |value|, |subscr_head| and |attr_head| are */
-@d attr_head(A) info(subscr_head_loc((A))) /* pointer to attribute info */
-@d subscr_head(A) link(subscr_head_loc((A))) /* pointer to subscript info */
-@d value_node_size 2 /* the number of words in a value node */
-
-@ An attribute node is three words long. Two of these words contain |type|
-and |value| fields as described above, and the third word contains
-additional information: There is an |attr_loc| field, which contains the
-hash address of the token that names this attribute; and there's also a
-|parent| field, which points to the value node of |mp_structured| type at the
-next higher level (i.e., at the level to which this attribute is
-subsidiary). The |name_type| in an attribute node is `|attr|'. The
-|link| field points to the next attribute with the same parent; these are
-arranged in increasing order, so that |attr_loc(link(p))>attr_loc(p)|. The
-final attribute node links to the constant |end_attr|, whose |attr_loc|
-field is greater than any legal hash address. The |attr_head| in the
-parent points to a node whose |name_type| is |mp_structured_root|; this
-node represents the null attribute, i.e., the variable that is relevant
-when no attributes are attached to the parent. The |attr_head| node
-has the fields of either
-a value node, a subscript node, or an attribute node, depending on what
-the parent would be if it were not structured; but the subscript and
-attribute fields are ignored, so it effectively contains only the data of
-a value node. The |link| field in this special node points to an attribute
-node whose |attr_loc| field is zero; the latter node represents a collective
-subscript `\.{[]}' attached to the parent, and its |link| field points to
-the first non-special attribute node (or to |end_attr| if there are none).
-
-A subscript node likewise occupies three words, with |type| and |value| fields
-plus extra information; its |name_type| is |subscr|. In this case the
-third word is called the |subscript| field, which is a |scaled| integer.
-The |link| field points to the subscript node with the next larger
-subscript, if any; otherwise the |link| points to the attribute node
-for collective subscripts at this level. We have seen that the latter node
-contains an upward pointer, so that the parent can be deduced.
-
-The |name_type| in a parent-less value node is |root|, and the |link|
-is the hash address of the token that names this value.
-
-In other words, variables have a hierarchical structure that includes
-enough threads running around so that the program is able to move easily
-between siblings, parents, and children. An example should be helpful:
-(The reader is advised to draw a picture while reading the following
-description, since that will help to firm up the ideas.)
-Suppose that `\.x' and `\.{x.a}' and `\.{x[]b}' and `\.{x5}'
-and `\.{x20b}' have been mentioned in a user's program, where
-\.{x[]b} has been declared to be of \&{boolean} type. Let |h(x)|, |h(a)|,
-and |h(b)| be the hash addresses of \.x, \.a, and~\.b. Then
-|eq_type(h(x))=name| and |equiv(h(x))=p|, where |p|~is a two-word value
-node with |name_type(p)=root| and |link(p)=h(x)|. We have |type(p)=mp_structured|,
-|attr_head(p)=q|, and |subscr_head(p)=r|, where |q| points to a value
-node and |r| to a subscript node. (Are you still following this? Use
-a pencil to draw a diagram.) The lone variable `\.x' is represented by
-|type(q)| and |value(q)|; furthermore
-|name_type(q)=mp_structured_root| and |link(q)=q1|, where |q1| points
-to an attribute node representing `\.{x[]}'. Thus |name_type(q1)=attr|,
-|attr_loc(q1)=collective_subscript=0|, |parent(q1)=p|,
-|type(q1)=mp_structured|, |attr_head(q1)=qq|, and |subscr_head(q1)=qq1|;
-|qq| is a three-word ``attribute-as-value'' node with |type(qq)=numeric_type|
-(assuming that \.{x5} is numeric, because |qq| represents `\.{x[]}'
-with no further attributes), |name_type(qq)=structured_root|,
-|attr_loc(qq)=0|, |parent(qq)=p|, and
-|link(qq)=qq1|. (Now pay attention to the next part.) Node |qq1| is
-an attribute node representing `\.{x[][]}', which has never yet
-occurred; its |type| field is |undefined|, and its |value| field is
-undefined. We have |name_type(qq1)=attr|, |attr_loc(qq1)=collective_subscript|,
-|parent(qq1)=q1|, and |link(qq1)=qq2|. Since |qq2| represents
-`\.{x[]b}', |type(qq2)=mp_unknown_boolean|; also |attr_loc(qq2)=h(b)|,
-|parent(qq2)=q1|, |name_type(qq2)=attr|, |link(qq2)=end_attr|.
-(Maybe colored lines will help untangle your picture.)
- Node |r| is a subscript node with |type| and |value|
-representing `\.{x5}'; |name_type(r)=subscr|, |subscript(r)=5.0|,
-and |link(r)=r1| is another subscript node. To complete the picture,
-see if you can guess what |link(r1)| is; give up? It's~|q1|.
-Furthermore |subscript(r1)=20.0|, |name_type(r1)=subscr|,
-|type(r1)=mp_structured|, |attr_head(r1)=qqq|, |subscr_head(r1)=qqq1|,
-and we finish things off with three more nodes
-|qqq|, |qqq1|, and |qqq2| hung onto~|r1|. (Perhaps you should start again
-with a larger sheet of paper.) The value of variable \.{x20b}
-appears in node~|qqq2|, as you can well imagine.
-
-If the example in the previous paragraph doesn't make things crystal
-clear, a glance at some of the simpler subroutines below will reveal how
-things work out in practice.
-
-The only really unusual thing about these conventions is the use of
-collective subscript attributes. The idea is to avoid repeating a lot of
-type information when many elements of an array are identical macros
-(for which distinct values need not be stored) or when they don't have
-all of the possible attributes. Branches of the structure below collective
-subscript attributes do not carry actual values except for macro identifiers;
-branches of the structure below subscript nodes do not carry significant
-information in their collective subscript attributes.
-
-@d attr_loc_loc(A) ((A)+2) /* where the |attr_loc| and |parent| fields are */
-@d attr_loc(A) info(attr_loc_loc((A))) /* hash address of this attribute */
-@d parent(A) link(attr_loc_loc((A))) /* pointer to |mp_structured| variable */
-@d subscript_loc(A) ((A)+2) /* where the |subscript| field lives */
-@d subscript(A) mp->mem[subscript_loc((A))].sc /* subscript of this variable */
-@d attr_node_size 3 /* the number of words in an attribute node */
-@d subscr_node_size 3 /* the number of words in a subscript node */
-@d collective_subscript 0 /* code for the attribute `\.{[]}' */
-
-@<Initialize table...@>=
-attr_loc(end_attr)=hash_end+1; parent(end_attr)=null;
-
-@ Variables of type \&{pair} will have values that point to four-word
-nodes containing two numeric values. The first of these values has
-|name_type=mp_x_part_sector| and the second has |name_type=mp_y_part_sector|;
-the |link| in the first points back to the node whose |value| points
-to this four-word node.
-
-Variables of type \&{transform} are similar, but in this case their
-|value| points to a 12-word node containing six values, identified by
-|x_part_sector|, |y_part_sector|, |mp_xx_part_sector|, |mp_xy_part_sector|,
-|mp_yx_part_sector|, and |mp_yy_part_sector|.
-Finally, variables of type \&{color} have 3~values in 6~words
-identified by |mp_red_part_sector|, |mp_green_part_sector|, and |mp_blue_part_sector|.
-
-When an entire structured variable is saved, the |root| indication
-is temporarily replaced by |saved_root|.
-
-Some variables have no name; they just are used for temporary storage
-while expressions are being evaluated. We call them {\sl capsules}.
-
-@d x_part_loc(A) (A) /* where the \&{xpart} is found in a pair or transform node */
-@d y_part_loc(A) ((A)+2) /* where the \&{ypart} is found in a pair or transform node */
-@d xx_part_loc(A) ((A)+4) /* where the \&{xxpart} is found in a transform node */
-@d xy_part_loc(A) ((A)+6) /* where the \&{xypart} is found in a transform node */
-@d yx_part_loc(A) ((A)+8) /* where the \&{yxpart} is found in a transform node */
-@d yy_part_loc(A) ((A)+10) /* where the \&{yypart} is found in a transform node */
-@d red_part_loc(A) (A) /* where the \&{redpart} is found in a color node */
-@d green_part_loc(A) ((A)+2) /* where the \&{greenpart} is found in a color node */
-@d blue_part_loc(A) ((A)+4) /* where the \&{bluepart} is found in a color node */
-@d cyan_part_loc(A) (A) /* where the \&{cyanpart} is found in a color node */
-@d magenta_part_loc(A) ((A)+2) /* where the \&{magentapart} is found in a color node */
-@d yellow_part_loc(A) ((A)+4) /* where the \&{yellowpart} is found in a color node */
-@d black_part_loc(A) ((A)+6) /* where the \&{blackpart} is found in a color node */
-@d grey_part_loc(A) (A) /* where the \&{greypart} is found in a color node */
-@#
-@d pair_node_size 4 /* the number of words in a pair node */
-@d transform_node_size 12 /* the number of words in a transform node */
-@d color_node_size 6 /* the number of words in a color node */
-@d cmykcolor_node_size 8 /* the number of words in a color node */
-
-@<Glob...@>=
-small_number big_node_size[mp_pair_type+1];
-small_number sector0[mp_pair_type+1];
-small_number sector_offset[mp_black_part_sector+1];
-
-@ The |sector0| array gives for each big node type, |name_type| values
-for its first subfield; the |sector_offset| array gives for each
-|name_type| value, the offset from the first subfield in words;
-and the |big_node_size| array gives the size in words for each type of
-big node.
-
-@<Set init...@>=
-mp->big_node_size[mp_transform_type]=transform_node_size;
-mp->big_node_size[mp_pair_type]=pair_node_size;
-mp->big_node_size[mp_color_type]=color_node_size;
-mp->big_node_size[mp_cmykcolor_type]=cmykcolor_node_size;
-mp->sector0[mp_transform_type]=mp_x_part_sector;
-mp->sector0[mp_pair_type]=mp_x_part_sector;
-mp->sector0[mp_color_type]=mp_red_part_sector;
-mp->sector0[mp_cmykcolor_type]=mp_cyan_part_sector;
-for (k=mp_x_part_sector;k<= mp_yy_part_sector;k++ ) {
- mp->sector_offset[k]=2*(k-mp_x_part_sector);
-}
-for (k=mp_red_part_sector;k<= mp_blue_part_sector ; k++) {
- mp->sector_offset[k]=2*(k-mp_red_part_sector);
-}
-for (k=mp_cyan_part_sector;k<= mp_black_part_sector;k++ ) {
- mp->sector_offset[k]=2*(k-mp_cyan_part_sector);
-}
-
-@ If |type(p)=mp_pair_type| or |mp_transform_type| and if |value(p)=null|, the
-procedure call |init_big_node(p)| will allocate a pair or transform node
-for~|p|. The individual parts of such nodes are initially of type
-|mp_independent|.
-
-@c
-void mp_init_big_node (MP mp,pointer p) {
- pointer q; /* the new node */
- small_number s; /* its size */
- s=mp->big_node_size[type(p)]; q=mp_get_node(mp, s);
- do {
- s=s-2;
- @<Make variable |q+s| newly independent@>;
- name_type(q+s)=halfp(s)+mp->sector0[type(p)];
- link(q+s)=null;
- } while (s!=0);
- link(q)=p; value(p)=q;
-}
-
-@ The |id_transform| function creates a capsule for the
-identity transformation.
-
-@c
-pointer mp_id_transform (MP mp) {
- pointer p,q,r; /* list manipulation registers */
- p=mp_get_node(mp, value_node_size); type(p)=mp_transform_type;
- name_type(p)=mp_capsule; value(p)=null; mp_init_big_node(mp, p); q=value(p);
- r=q+transform_node_size;
- do {
- r=r-2;
- type(r)=mp_known; value(r)=0;
- } while (r!=q);
- value(xx_part_loc(q))=unity;
- value(yy_part_loc(q))=unity;
- return p;
-}
-
-@ Tokens are of type |tag_token| when they first appear, but they point
-to |null| until they are first used as the root of a variable.
-The following subroutine establishes the root node on such grand occasions.
-
-@c
-void mp_new_root (MP mp,pointer x) {
- pointer p; /* the new node */
- p=mp_get_node(mp, value_node_size); type(p)=undefined; name_type(p)=mp_root;
- link(p)=x; equiv(x)=p;
-}
-
-@ These conventions for variable representation are illustrated by the
-|print_variable_name| routine, which displays the full name of a
-variable given only a pointer to its two-word value packet.
-
-@<Declarations@>=
-void mp_print_variable_name (MP mp, pointer p);
-
-@ @c
-void mp_print_variable_name (MP mp, pointer p) {
- pointer q; /* a token list that will name the variable's suffix */
- pointer r; /* temporary for token list creation */
- while ( name_type(p)>=mp_x_part_sector ) {
- @<Preface the output with a part specifier; |return| in the
- case of a capsule@>;
- }
- q=null;
- while ( name_type(p)>mp_saved_root ) {
- @<Ascend one level, pushing a token onto list |q|
- and replacing |p| by its parent@>;
- }
- r=mp_get_avail(mp); info(r)=link(p); link(r)=q;
- if ( name_type(p)==mp_saved_root ) mp_print(mp, "(SAVED)");
-@.SAVED@>
- mp_show_token_list(mp, r,null,el_gordo,mp->tally);
- mp_flush_token_list(mp, r);
-}
-
-@ @<Ascend one level, pushing a token onto list |q|...@>=
-{
- if ( name_type(p)==mp_subscr ) {
- r=mp_new_num_tok(mp, subscript(p));
- do {
- p=link(p);
- } while (name_type(p)!=mp_attr);
- } else if ( name_type(p)==mp_structured_root ) {
- p=link(p); goto FOUND;
- } else {
- if ( name_type(p)!=mp_attr ) mp_confusion(mp, "var");
-@:this can't happen var}{\quad var@>
- r=mp_get_avail(mp); info(r)=attr_loc(p);
- }
- link(r)=q; q=r;
-FOUND:
- p=parent(p);
-}
-
-@ @<Preface the output with a part specifier...@>=
-{ switch (name_type(p)) {
- case mp_x_part_sector: mp_print_char(mp, 'x'); break;
- case mp_y_part_sector: mp_print_char(mp, 'y'); break;
- case mp_xx_part_sector: mp_print(mp, "xx"); break;
- case mp_xy_part_sector: mp_print(mp, "xy"); break;
- case mp_yx_part_sector: mp_print(mp, "yx"); break;
- case mp_yy_part_sector: mp_print(mp, "yy"); break;
- case mp_red_part_sector: mp_print(mp, "red"); break;
- case mp_green_part_sector: mp_print(mp, "green"); break;
- case mp_blue_part_sector: mp_print(mp, "blue"); break;
- case mp_cyan_part_sector: mp_print(mp, "cyan"); break;
- case mp_magenta_part_sector: mp_print(mp, "magenta"); break;
- case mp_yellow_part_sector: mp_print(mp, "yellow"); break;
- case mp_black_part_sector: mp_print(mp, "black"); break;
- case mp_grey_part_sector: mp_print(mp, "grey"); break;
- case mp_capsule:
- mp_print(mp, "%CAPSULE"); mp_print_int(mp, p-null); return;
- break;
-@.CAPSULE@>
- } /* there are no other cases */
- mp_print(mp, "part ");
- p=link(p-mp->sector_offset[name_type(p)]);
-}
-
-@ The |interesting| function returns |true| if a given variable is not
-in a capsule, or if the user wants to trace capsules.
-
-@c
-boolean mp_interesting (MP mp,pointer p) {
- small_number t; /* a |name_type| */
- if ( mp->internal[mp_tracing_capsules]>0 ) {
- return true;
- } else {
- t=name_type(p);
- if ( t>=mp_x_part_sector ) if ( t!=mp_capsule )
- t=name_type(link(p-mp->sector_offset[t]));
- return (t!=mp_capsule);
- }
-}
-
-@ Now here is a subroutine that converts an unstructured type into an
-equivalent structured type, by inserting a |mp_structured| node that is
-capable of growing. This operation is done only when |name_type(p)=root|,
-|subscr|, or |attr|.
-
-The procedure returns a pointer to the new node that has taken node~|p|'s
-place in the structure. Node~|p| itself does not move, nor are its
-|value| or |type| fields changed in any way.
-
-@c
-pointer mp_new_structure (MP mp,pointer p) {
- pointer q,r=0; /* list manipulation registers */
- switch (name_type(p)) {
- case mp_root:
- q=link(p); r=mp_get_node(mp, value_node_size); equiv(q)=r;
- break;
- case mp_subscr:
- @<Link a new subscript node |r| in place of node |p|@>;
- break;
- case mp_attr:
- @<Link a new attribute node |r| in place of node |p|@>;
- break;
- default:
- mp_confusion(mp, "struct");
-@:this can't happen struct}{\quad struct@>
- break;
- }
- link(r)=link(p); type(r)=mp_structured; name_type(r)=name_type(p);
- attr_head(r)=p; name_type(p)=mp_structured_root;
- q=mp_get_node(mp, attr_node_size); link(p)=q; subscr_head(r)=q;
- parent(q)=r; type(q)=undefined; name_type(q)=mp_attr; link(q)=end_attr;
- attr_loc(q)=collective_subscript;
- return r;
-}
-
-@ @<Link a new subscript node |r| in place of node |p|@>=
-{
- q=p;
- do {
- q=link(q);
- } while (name_type(q)!=mp_attr);
- q=parent(q); r=subscr_head_loc(q); /* |link(r)=subscr_head(q)| */
- do {
- q=r; r=link(r);
- } while (r!=p);
- r=mp_get_node(mp, subscr_node_size);
- link(q)=r; subscript(r)=subscript(p);
-}
-
-@ If the attribute is |collective_subscript|, there are two pointers to
-node~|p|, so we must change both of them.
-
-@<Link a new attribute node |r| in place of node |p|@>=
-{
- q=parent(p); r=attr_head(q);
- do {
- q=r; r=link(r);
- } while (r!=p);
- r=mp_get_node(mp, attr_node_size); link(q)=r;
- mp->mem[attr_loc_loc(r)]=mp->mem[attr_loc_loc(p)]; /* copy |attr_loc| and |parent| */
- if ( attr_loc(p)==collective_subscript ) {
- q=subscr_head_loc(parent(p));
- while ( link(q)!=p ) q=link(q);
- link(q)=r;
- }
-}
-
-@ The |find_variable| routine is given a pointer~|t| to a nonempty token
-list of suffixes; it returns a pointer to the corresponding two-word
-value. For example, if |t| points to token \.x followed by a numeric
-token containing the value~7, |find_variable| finds where the value of
-\.{x7} is stored in memory. This may seem a simple task, and it
-usually is, except when \.{x7} has never been referenced before.
-Indeed, \.x may never have even been subscripted before; complexities
-arise with respect to updating the collective subscript information.
-
-If a macro type is detected anywhere along path~|t|, or if the first
-item on |t| isn't a |tag_token|, the value |null| is returned.
-Otherwise |p| will be a non-null pointer to a node such that
-|undefined<type(p)<mp_structured|.
-
-@d abort_find { return null; }
-
-@c
-pointer mp_find_variable (MP mp,pointer t) {
- pointer p,q,r,s; /* nodes in the ``value'' line */
- pointer pp,qq,rr,ss; /* nodes in the ``collective'' line */
- integer n; /* subscript or attribute */
- memory_word save_word; /* temporary storage for a word of |mem| */
-@^inner loop@>
- p=info(t); t=link(t);
- if ( (eq_type(p) % outer_tag) != tag_token ) abort_find;
- if ( equiv(p)==null ) mp_new_root(mp, p);
- p=equiv(p); pp=p;
- while ( t!=null ) {
- @<Make sure that both nodes |p| and |pp| are of |mp_structured| type@>;
- if ( t<mp->hi_mem_min ) {
- @<Descend one level for the subscript |value(t)|@>
- } else {
- @<Descend one level for the attribute |info(t)|@>;
- }
- t=link(t);
- }
- if ( type(pp)>=mp_structured ) {
- if ( type(pp)==mp_structured ) pp=attr_head(pp); else abort_find;
- }
- if ( type(p)==mp_structured ) p=attr_head(p);
- if ( type(p)==undefined ) {
- if ( type(pp)==undefined ) { type(pp)=mp_numeric_type; value(pp)=null; };
- type(p)=type(pp); value(p)=null;
- };
- return p;
-}
-
-@ Although |pp| and |p| begin together, they diverge when a subscript occurs;
-|pp|~stays in the collective line while |p|~goes through actual subscript
-values.
-
-@<Make sure that both nodes |p| and |pp|...@>=
-if ( type(pp)!=mp_structured ) {
- if ( type(pp)>mp_structured ) abort_find;
- ss=mp_new_structure(mp, pp);
- if ( p==pp ) p=ss;
- pp=ss;
-}; /* now |type(pp)=mp_structured| */
-if ( type(p)!=mp_structured ) /* it cannot be |>mp_structured| */
- p=mp_new_structure(mp, p) /* now |type(p)=mp_structured| */
-
-@ We want this part of the program to be reasonably fast, in case there are
-@^inner loop@>
-lots of subscripts at the same level of the data structure. Therefore
-we store an ``infinite'' value in the word that appears at the end of the
-subscript list, even though that word isn't part of a subscript node.
-
-@<Descend one level for the subscript |value(t)|@>=
-{
- n=value(t);
- pp=link(attr_head(pp)); /* now |attr_loc(pp)=collective_subscript| */
- q=link(attr_head(p)); save_word=mp->mem[subscript_loc(q)];
- subscript(q)=el_gordo; s=subscr_head_loc(p); /* |link(s)=subscr_head(p)| */
- do {
- r=s; s=link(s);
- } while (n>subscript(s));
- if ( n==subscript(s) ) {
- p=s;
- } else {
- p=mp_get_node(mp, subscr_node_size); link(r)=p; link(p)=s;
- subscript(p)=n; name_type(p)=mp_subscr; type(p)=undefined;
- }
- mp->mem[subscript_loc(q)]=save_word;
-}
-
-@ @<Descend one level for the attribute |info(t)|@>=
-{
- n=info(t);
- ss=attr_head(pp);
- do {
- rr=ss; ss=link(ss);
- } while (n>attr_loc(ss));
- if ( n<attr_loc(ss) ) {
- qq=mp_get_node(mp, attr_node_size); link(rr)=qq; link(qq)=ss;
- attr_loc(qq)=n; name_type(qq)=mp_attr; type(qq)=undefined;
- parent(qq)=pp; ss=qq;
- }
- if ( p==pp ) {
- p=ss; pp=ss;
- } else {
- pp=ss; s=attr_head(p);
- do {
- r=s; s=link(s);
- } while (n>attr_loc(s));
- if ( n==attr_loc(s) ) {
- p=s;
- } else {
- q=mp_get_node(mp, attr_node_size); link(r)=q; link(q)=s;
- attr_loc(q)=n; name_type(q)=mp_attr; type(q)=undefined;
- parent(q)=p; p=q;
- }
- }
-}
-
-@ Variables lose their former values when they appear in a type declaration,
-or when they are defined to be macros or \&{let} equal to something else.
-A subroutine will be defined later that recycles the storage associated
-with any particular |type| or |value|; our goal now is to study a higher
-level process called |flush_variable|, which selectively frees parts of a
-variable structure.
-
-This routine has some complexity because of examples such as
-`\hbox{\tt numeric x[]a[]b}'
-which recycles all variables of the form \.{x[i]a[j]b} (and no others), while
-`\hbox{\tt vardef x[]a[]=...}'
-discards all variables of the form \.{x[i]a[j]} followed by an arbitrary
-suffix, except for the collective node \.{x[]a[]} itself. The obvious way
-to handle such examples is to use recursion; so that's what we~do.
-@^recursion@>
-
-Parameter |p| points to the root information of the variable;
-parameter |t| points to a list of one-word nodes that represent
-suffixes, with |info=collective_subscript| for subscripts.
-
-@<Declarations@>=
-@<Declare subroutines for printing expressions@>
-@<Declare basic dependency-list subroutines@>
-@<Declare the recycling subroutines@>
-void mp_flush_cur_exp (MP mp,scaled v) ;
-@<Declare the procedure called |flush_below_variable|@>
-
-@ @c
-void mp_flush_variable (MP mp,pointer p, pointer t, boolean discard_suffixes) {
- pointer q,r; /* list manipulation */
- halfword n; /* attribute to match */
- while ( t!=null ) {
- if ( type(p)!=mp_structured ) return;
- n=info(t); t=link(t);
- if ( n==collective_subscript ) {
- r=subscr_head_loc(p); q=link(r); /* |q=subscr_head(p)| */
- while ( name_type(q)==mp_subscr ){
- mp_flush_variable(mp, q,t,discard_suffixes);
- if ( t==null ) {
- if ( type(q)==mp_structured ) r=q;
- else { link(r)=link(q); mp_free_node(mp, q,subscr_node_size); }
- } else {
- r=q;
- }
- q=link(r);
- }
- }
- p=attr_head(p);
- do {
- r=p; p=link(p);
- } while (attr_loc(p)<n);
- if ( attr_loc(p)!=n ) return;
- }
- if ( discard_suffixes ) {
- mp_flush_below_variable(mp, p);
- } else {
- if ( type(p)==mp_structured ) p=attr_head(p);
- mp_recycle_value(mp, p);
- }
-}
-
-@ The next procedure is simpler; it wipes out everything but |p| itself,
-which becomes undefined.
-
-@<Declare the procedure called |flush_below_variable|@>=
-void mp_flush_below_variable (MP mp, pointer p);
-
-@ @c
-void mp_flush_below_variable (MP mp,pointer p) {
- pointer q,r; /* list manipulation registers */
- if ( type(p)!=mp_structured ) {
- mp_recycle_value(mp, p); /* this sets |type(p)=undefined| */
- } else {
- q=subscr_head(p);
- while ( name_type(q)==mp_subscr ) {
- mp_flush_below_variable(mp, q); r=q; q=link(q);
- mp_free_node(mp, r,subscr_node_size);
- }
- r=attr_head(p); q=link(r); mp_recycle_value(mp, r);
- if ( name_type(p)<=mp_saved_root ) mp_free_node(mp, r,value_node_size);
- else mp_free_node(mp, r,subscr_node_size);
- /* we assume that |subscr_node_size=attr_node_size| */
- do {
- mp_flush_below_variable(mp, q); r=q; q=link(q); mp_free_node(mp, r,attr_node_size);
- } while (q!=end_attr);
- type(p)=undefined;
- }
-}
-
-@ Just before assigning a new value to a variable, we will recycle the
-old value and make the old value undefined. The |und_type| routine
-determines what type of undefined value should be given, based on
-the current type before recycling.
-
-@c
-small_number mp_und_type (MP mp,pointer p) {
- switch (type(p)) {
- case undefined: case mp_vacuous:
- return undefined;
- case mp_boolean_type: case mp_unknown_boolean:
- return mp_unknown_boolean;
- case mp_string_type: case mp_unknown_string:
- return mp_unknown_string;
- case mp_pen_type: case mp_unknown_pen:
- return mp_unknown_pen;
- case mp_path_type: case mp_unknown_path:
- return mp_unknown_path;
- case mp_picture_type: case mp_unknown_picture:
- return mp_unknown_picture;
- case mp_transform_type: case mp_color_type: case mp_cmykcolor_type:
- case mp_pair_type: case mp_numeric_type:
- return type(p);
- case mp_known: case mp_dependent: case mp_proto_dependent: case mp_independent:
- return mp_numeric_type;
- } /* there are no other cases */
- return 0;
-}
-
-@ The |clear_symbol| routine is used when we want to redefine the equivalent
-of a symbolic token. It must remove any variable structure or macro
-definition that is currently attached to that symbol. If the |saving|
-parameter is true, a subsidiary structure is saved instead of destroyed.
-
-@c
-void mp_clear_symbol (MP mp,pointer p, boolean saving) {
- pointer q; /* |equiv(p)| */
- q=equiv(p);
- switch (eq_type(p) % outer_tag) {
- case defined_macro:
- case secondary_primary_macro:
- case tertiary_secondary_macro:
- case expression_tertiary_macro:
- if ( ! saving ) mp_delete_mac_ref(mp, q);
- break;
- case tag_token:
- if ( q!=null ) {
- if ( saving ) {
- name_type(q)=mp_saved_root;
- } else {
- mp_flush_below_variable(mp, q);
- mp_free_node(mp,q,value_node_size);
- }
- }
- break;
- default:
- break;
- }
- mp->eqtb[p]=mp->eqtb[frozen_undefined];
-}
-
-@* \[16] Saving and restoring equivalents.
-The nested structure given by \&{begingroup} and \&{endgroup}
-allows |eqtb| entries to be saved and restored, so that temporary changes
-can be made without difficulty. When the user requests a current value to
-be saved, \MP\ puts that value into its ``save stack.'' An appearance of
-\&{endgroup} ultimately causes the old values to be removed from the save
-stack and put back in their former places.
-
-The save stack is a linked list containing three kinds of entries,
-distinguished by their |info| fields. If |p| points to a saved item,
-then
-
-\smallskip\hang
-|info(p)=0| stands for a group boundary; each \&{begingroup} contributes
-such an item to the save stack and each \&{endgroup} cuts back the stack
-until the most recent such entry has been removed.
-
-\smallskip\hang
-|info(p)=q|, where |1<=q<=hash_end|, means that |mem[p+1]| holds the former
-contents of |eqtb[q]|. Such save stack entries are generated by \&{save}
-commands.
-
-\smallskip\hang
-|info(p)=hash_end+q|, where |q>0|, means that |value(p)| is a |scaled|
-integer to be restored to internal parameter number~|q|. Such entries
-are generated by \&{interim} commands.
-
-\smallskip\noindent
-The global variable |save_ptr| points to the top item on the save stack.
-
-@d save_node_size 2 /* number of words per non-boundary save-stack node */
-@d saved_equiv(A) mp->mem[(A)+1].hh /* where an |eqtb| entry gets saved */
-@d save_boundary_item(A) { (A)=mp_get_avail(mp); info((A))=0;
- link((A))=mp->save_ptr; mp->save_ptr=(A);
- }
-
-@<Glob...@>=
-pointer save_ptr; /* the most recently saved item */
-
-@ @<Set init...@>=mp->save_ptr=null;
-
-@ The |save_variable| routine is given a hash address |q|; it salts this
-address in the save stack, together with its current equivalent,
-then makes token~|q| behave as though it were brand new.
-
-Nothing is stacked when |save_ptr=null|, however; there's no way to remove
-things from the stack when the program is not inside a group, so there's
-no point in wasting the space.
-
-@c void mp_save_variable (MP mp,pointer q) {
- pointer p; /* temporary register */
- if ( mp->save_ptr!=null ){
- p=mp_get_node(mp, save_node_size); info(p)=q; link(p)=mp->save_ptr;
- saved_equiv(p)=mp->eqtb[q]; mp->save_ptr=p;
- }
- mp_clear_symbol(mp, q,(mp->save_ptr!=null));
-}
-
-@ Similarly, |save_internal| is given the location |q| of an internal
-quantity like |mp_tracing_pens|. It creates a save stack entry of the
-third kind.
-
-@c void mp_save_internal (MP mp,halfword q) {
- pointer p; /* new item for the save stack */
- if ( mp->save_ptr!=null ){
- p=mp_get_node(mp, save_node_size); info(p)=hash_end+q;
- link(p)=mp->save_ptr; value(p)=mp->internal[q]; mp->save_ptr=p;
- }
-}
-
-@ At the end of a group, the |unsave| routine restores all of the saved
-equivalents in reverse order. This routine will be called only when there
-is at least one boundary item on the save stack.
-
-@c
-void mp_unsave (MP mp) {
- pointer q; /* index to saved item */
- pointer p; /* temporary register */
- while ( info(mp->save_ptr)!=0 ) {
- q=info(mp->save_ptr);
- if ( q>hash_end ) {
- if ( mp->internal[mp_tracing_restores]>0 ) {
- mp_begin_diagnostic(mp); mp_print_nl(mp, "{restoring ");
- mp_print(mp, mp->int_name[q-(hash_end)]); mp_print_char(mp, '=');
- mp_print_scaled(mp, value(mp->save_ptr)); mp_print_char(mp, '}');
- mp_end_diagnostic(mp, false);
- }
- mp->internal[q-(hash_end)]=value(mp->save_ptr);
- } else {
- if ( mp->internal[mp_tracing_restores]>0 ) {
- mp_begin_diagnostic(mp); mp_print_nl(mp, "{restoring ");
- mp_print_text(q); mp_print_char(mp, '}');
- mp_end_diagnostic(mp, false);
- }
- mp_clear_symbol(mp, q,false);
- mp->eqtb[q]=saved_equiv(mp->save_ptr);
- if ( eq_type(q) % outer_tag==tag_token ) {
- p=equiv(q);
- if ( p!=null ) name_type(p)=mp_root;
- }
- }
- p=link(mp->save_ptr);
- mp_free_node(mp, mp->save_ptr,save_node_size); mp->save_ptr=p;
- }
- p=link(mp->save_ptr); free_avail(mp->save_ptr); mp->save_ptr=p;
-}
-
-@* \[17] Data structures for paths.
-When a \MP\ user specifies a path, \MP\ will create a list of knots
-and control points for the associated cubic spline curves. If the
-knots are $z_0$, $z_1$, \dots, $z_n$, there are control points
-$z_k^+$ and $z_{k+1}^-$ such that the cubic splines between knots
-$z_k$ and $z_{k+1}$ are defined by B\'ezier's formula
-@:Bezier}{B\'ezier, Pierre Etienne@>
-$$\eqalign{z(t)&=B(z_k,z_k^+,z_{k+1}^-,z_{k+1};t)\cr
-&=(1-t)^3z_k+3(1-t)^2tz_k^++3(1-t)t^2z_{k+1}^-+t^3z_{k+1}\cr}$$
-for |0<=t<=1|.
-
-There is a 8-word node for each knot $z_k$, containing one word of
-control information and six words for the |x| and |y| coordinates of
-$z_k^-$ and $z_k$ and~$z_k^+$. The control information appears in the
-|left_type| and |right_type| fields, which each occupy a quarter of
-the first word in the node; they specify properties of the curve as it
-enters and leaves the knot. There's also a halfword |link| field,
-which points to the following knot, and a final supplementary word (of
-which only a quarter is used).
-
-If the path is a closed contour, knots 0 and |n| are identical;
-i.e., the |link| in knot |n-1| points to knot~0. But if the path
-is not closed, the |left_type| of knot~0 and the |right_type| of knot~|n|
-are equal to |endpoint|. In the latter case the |link| in knot~|n| points
-to knot~0, and the control points $z_0^-$ and $z_n^+$ are not used.
-
-@d left_type(A) mp->mem[(A)].hh.b0 /* characterizes the path entering this knot */
-@d right_type(A) mp->mem[(A)].hh.b1 /* characterizes the path leaving this knot */
-@d x_coord(A) mp->mem[(A)+1].sc /* the |x| coordinate of this knot */
-@d y_coord(A) mp->mem[(A)+2].sc /* the |y| coordinate of this knot */
-@d left_x(A) mp->mem[(A)+3].sc /* the |x| coordinate of previous control point */
-@d left_y(A) mp->mem[(A)+4].sc /* the |y| coordinate of previous control point */
-@d right_x(A) mp->mem[(A)+5].sc /* the |x| coordinate of next control point */
-@d right_y(A) mp->mem[(A)+6].sc /* the |y| coordinate of next control point */
-@d x_loc(A) ((A)+1) /* where the |x| coordinate is stored in a knot */
-@d y_loc(A) ((A)+2) /* where the |y| coordinate is stored in a knot */
-@d knot_coord(A) mp->mem[(A)].sc /* |x| or |y| coordinate given |x_loc| or |y_loc| */
-@d left_coord(A) mp->mem[(A)+2].sc
- /* coordinate of previous control point given |x_loc| or |y_loc| */
-@d right_coord(A) mp->mem[(A)+4].sc
- /* coordinate of next control point given |x_loc| or |y_loc| */
-@d knot_node_size 8 /* number of words in a knot node */
-
-@<Types...@>=
-enum mp_knot_type {
- mp_endpoint=0, /* |left_type| at path beginning and |right_type| at path end */
- mp_explicit, /* |left_type| or |right_type| when control points are known */
- mp_given, /* |left_type| or |right_type| when a direction is given */
- mp_curl, /* |left_type| or |right_type| when a curl is desired */
- mp_open, /* |left_type| or |right_type| when \MP\ should choose the direction */
- mp_end_cycle
-};
-
-@ Before the B\'ezier control points have been calculated, the memory
-space they will ultimately occupy is taken up by information that can be
-used to compute them. There are four cases:
-
-\yskip
-\textindent{$\bullet$} If |right_type=mp_open|, the curve should leave
-the knot in the same direction it entered; \MP\ will figure out a
-suitable direction.
-
-\yskip
-\textindent{$\bullet$} If |right_type=mp_curl|, the curve should leave the
-knot in a direction depending on the angle at which it enters the next
-knot and on the curl parameter stored in |right_curl|.
-
-\yskip
-\textindent{$\bullet$} If |right_type=mp_given|, the curve should leave the
-knot in a nonzero direction stored as an |angle| in |right_given|.
-
-\yskip
-\textindent{$\bullet$} If |right_type=mp_explicit|, the B\'ezier control
-point for leaving this knot has already been computed; it is in the
-|right_x| and |right_y| fields.
-
-\yskip\noindent
-The rules for |left_type| are similar, but they refer to the curve entering
-the knot, and to \\{left} fields instead of \\{right} fields.
-
-Non-|explicit| control points will be chosen based on ``tension'' parameters
-in the |left_tension| and |right_tension| fields. The
-`\&{atleast}' option is represented by negative tension values.
-@:at_least_}{\&{atleast} primitive@>
-
-For example, the \MP\ path specification
-$$\.{z0..z1..tension atleast 1..\{curl 2\}z2..z3\{-1,-2\}..tension
- 3 and 4..p},$$
-where \.p is the path `\.{z4..controls z45 and z54..z5}', will be represented
-by the six knots
-\def\lodash{\hbox to 1.1em{\thinspace\hrulefill\thinspace}}
-$$\vbox{\halign{#\hfil&&\qquad#\hfil\cr
-|left_type|&\\{left} info&|x_coord,y_coord|&|right_type|&\\{right} info\cr
-\noalign{\yskip}
-|endpoint|&\lodash$,\,$\lodash&$x_0,y_0$&|curl|&$1.0,1.0$\cr
-|open|&\lodash$,1.0$&$x_1,y_1$&|open|&\lodash$,-1.0$\cr
-|curl|&$2.0,-1.0$&$x_2,y_2$&|curl|&$2.0,1.0$\cr
-|given|&$d,1.0$&$x_3,y_3$&|given|&$d,3.0$\cr
-|open|&\lodash$,4.0$&$x_4,y_4$&|explicit|&$x_{45},y_{45}$\cr
-|explicit|&$x_{54},y_{54}$&$x_5,y_5$&|endpoint|&\lodash$,\,$\lodash\cr}}$$
-Here |d| is the |angle| obtained by calling |n_arg(-unity,-two)|.
-Of course, this example is more complicated than anything a normal user
-would ever write.
-
-These types must satisfy certain restrictions because of the form of \MP's
-path syntax:
-(i)~|open| type never appears in the same node together with |endpoint|,
-|given|, or |curl|.
-(ii)~The |right_type| of a node is |explicit| if and only if the
-|left_type| of the following node is |explicit|.
-(iii)~|endpoint| types occur only at the ends, as mentioned above.
-
-@d left_curl left_x /* curl information when entering this knot */
-@d left_given left_x /* given direction when entering this knot */
-@d left_tension left_y /* tension information when entering this knot */
-@d right_curl right_x /* curl information when leaving this knot */
-@d right_given right_x /* given direction when leaving this knot */
-@d right_tension right_y /* tension information when leaving this knot */
-
-@ Knots can be user-supplied, or they can be created by program code,
-like the |split_cubic| function, or |copy_path|. The distinction is
-needed for the cleanup routine that runs after |split_cubic|, because
-it should only delete knots it has previously inserted, and never
-anything that was user-supplied. In order to be able to differentiate
-one knot from another, we will set |originator(p):=mp_metapost_user| when
-it appeared in the actual metapost program, and
-|originator(p):=mp_program_code| in all other cases.
-
-@d originator(A) mp->mem[(A)+7].hh.b0 /* the creator of this knot */
-
-@<Types...@>=
-enum {
- mp_program_code=0, /* not created by a user */
- mp_metapost_user /* created by a user */
-};
-
-@ Here is a routine that prints a given knot list
-in symbolic form. It illustrates the conventions discussed above,
-and checks for anomalies that might arise while \MP\ is being debugged.
-
-@<Declare subroutines for printing expressions@>=
-void mp_pr_path (MP mp,pointer h);
-
-@ @c
-void mp_pr_path (MP mp,pointer h) {
- pointer p,q; /* for list traversal */
- p=h;
- do {
- q=link(p);
- if ( (p==null)||(q==null) ) {
- mp_print_nl(mp, "???"); return; /* this won't happen */
-@.???@>
- }
- @<Print information for adjacent knots |p| and |q|@>;
- DONE1:
- p=q;
- if ( (p!=h)||(left_type(h)!=mp_endpoint) ) {
- @<Print two dots, followed by |given| or |curl| if present@>;
- }
- } while (p!=h);
- if ( left_type(h)!=mp_endpoint )
- mp_print(mp, "cycle");
-}
-
-@ @<Print information for adjacent knots...@>=
-mp_print_two(mp, x_coord(p),y_coord(p));
-switch (right_type(p)) {
-case mp_endpoint:
- if ( left_type(p)==mp_open ) mp_print(mp, "{open?}"); /* can't happen */
-@.open?@>
- if ( (left_type(q)!=mp_endpoint)||(q!=h) ) q=null; /* force an error */
- goto DONE1;
- break;
-case mp_explicit:
- @<Print control points between |p| and |q|, then |goto done1|@>;
- break;
-case mp_open:
- @<Print information for a curve that begins |open|@>;
- break;
-case mp_curl:
-case mp_given:
- @<Print information for a curve that begins |curl| or |given|@>;
- break;
-default:
- mp_print(mp, "???"); /* can't happen */
-@.???@>
- break;
-}
-if ( left_type(q)<=mp_explicit ) {
- mp_print(mp, "..control?"); /* can't happen */
-@.control?@>
-} else if ( (right_tension(p)!=unity)||(left_tension(q)!=unity) ) {
- @<Print tension between |p| and |q|@>;
-}
-
-@ Since |n_sin_cos| produces |fraction| results, which we will print as if they
-were |scaled|, the magnitude of a |given| direction vector will be~4096.
-
-@<Print two dots...@>=
-{
- mp_print_nl(mp, " ..");
- if ( left_type(p)==mp_given ) {
- mp_n_sin_cos(mp, left_given(p)); mp_print_char(mp, '{');
- mp_print_scaled(mp, mp->n_cos); mp_print_char(mp, ',');
- mp_print_scaled(mp, mp->n_sin); mp_print_char(mp, '}');
- } else if ( left_type(p)==mp_curl ){
- mp_print(mp, "{curl ");
- mp_print_scaled(mp, left_curl(p)); mp_print_char(mp, '}');
- }
-}
-
-@ @<Print tension between |p| and |q|@>=
-{
- mp_print(mp, "..tension ");
- if ( right_tension(p)<0 ) mp_print(mp, "atleast");
- mp_print_scaled(mp, abs(right_tension(p)));
- if ( right_tension(p)!=left_tension(q) ){
- mp_print(mp, " and ");
- if ( left_tension(q)<0 ) mp_print(mp, "atleast");
- mp_print_scaled(mp, abs(left_tension(q)));
- }
-}
-
-@ @<Print control points between |p| and |q|, then |goto done1|@>=
-{
- mp_print(mp, "..controls ");
- mp_print_two(mp, right_x(p),right_y(p));
- mp_print(mp, " and ");
- if ( left_type(q)!=mp_explicit ) {
- mp_print(mp, "??"); /* can't happen */
-@.??@>
- } else {
- mp_print_two(mp, left_x(q),left_y(q));
- }
- goto DONE1;
-}
-
-@ @<Print information for a curve that begins |open|@>=
-if ( (left_type(p)!=mp_explicit)&&(left_type(p)!=mp_open) ) {
- mp_print(mp, "{open?}"); /* can't happen */
-@.open?@>
-}
-
-@ A curl of 1 is shown explicitly, so that the user sees clearly that
-\MP's default curl is present.
-
-@<Print information for a curve that begins |curl|...@>=
-{
- if ( left_type(p)==mp_open )
- mp_print(mp, "??"); /* can't happen */
-@.??@>
- if ( right_type(p)==mp_curl ) {
- mp_print(mp, "{curl "); mp_print_scaled(mp, right_curl(p));
- } else {
- mp_n_sin_cos(mp, right_given(p)); mp_print_char(mp, '{');
- mp_print_scaled(mp, mp->n_cos); mp_print_char(mp, ',');
- mp_print_scaled(mp, mp->n_sin);
- }
- mp_print_char(mp, '}');
-}
-
-@ It is convenient to have another version of |pr_path| that prints the path
-as a diagnostic message.
-
-@<Declare subroutines for printing expressions@>=
-void mp_print_path (MP mp,pointer h, const char *s, boolean nuline) {
- mp_print_diagnostic(mp, "Path", s, nuline); mp_print_ln(mp);
-@.Path at line...@>
- mp_pr_path(mp, h);
- mp_end_diagnostic(mp, true);
-}
-
-@ If we want to duplicate a knot node, we can say |copy_knot|:
-
-@c
-pointer mp_copy_knot (MP mp,pointer p) {
- pointer q; /* the copy */
- int k; /* runs through the words of a knot node */
- q=mp_get_node(mp, knot_node_size);
- for (k=0;k<knot_node_size;k++) {
- mp->mem[q+k]=mp->mem[p+k];
- }
- originator(q)=originator(p);
- return q;
-}
-
-@ The |copy_path| routine makes a clone of a given path.
-
-@c
-pointer mp_copy_path (MP mp, pointer p) {
- pointer q,pp,qq; /* for list manipulation */
- q=mp_copy_knot(mp, p);
- qq=q; pp=link(p);
- while ( pp!=p ) {
- link(qq)=mp_copy_knot(mp, pp);
- qq=link(qq);
- pp=link(pp);
- }
- link(qq)=q;
- return q;
-}
-
-
-@ Just before |ship_out|, knot lists are exported for printing.
-
-The |gr_XXXX| macros are defined in |mppsout.h|.
-
-@c
-mp_knot *mp_export_knot (MP mp,pointer p) {
- mp_knot *q; /* the copy */
- if (p==null)
- return NULL;
- q = mp_xmalloc(mp, 1, sizeof (mp_knot));
- memset(q,0,sizeof (mp_knot));
- gr_left_type(q) = left_type(p);
- gr_right_type(q) = right_type(p);
- gr_x_coord(q) = x_coord(p);
- gr_y_coord(q) = y_coord(p);
- gr_left_x(q) = left_x(p);
- gr_left_y(q) = left_y(p);
- gr_right_x(q) = right_x(p);
- gr_right_y(q) = right_y(p);
- gr_originator(q) = originator(p);
- return q;
-}
-
-@ The |export_knot_list| routine therefore also makes a clone
-of a given path.
-
-@c
-mp_knot *mp_export_knot_list (MP mp, pointer p) {
- mp_knot *q, *qq; /* for list manipulation */
- pointer pp; /* for list manipulation */
- if (p==null)
- return NULL;
- q=mp_export_knot(mp, p);
- qq=q; pp=link(p);
- while ( pp!=p ) {
- gr_next_knot(qq)=mp_export_knot(mp, pp);
- qq=gr_next_knot(qq);
- pp=link(pp);
- }
- gr_next_knot(qq)=q;
- return q;
-}
-
-
-@ Similarly, there's a way to copy the {\sl reverse\/} of a path. This procedure
-returns a pointer to the first node of the copy, if the path is a cycle,
-but to the final node of a non-cyclic copy. The global
-variable |path_tail| will point to the final node of the original path;
-this trick makes it easier to implement `\&{doublepath}'.
-
-All node types are assumed to be |endpoint| or |explicit| only.
-
-@c
-pointer mp_htap_ypoc (MP mp,pointer p) {
- pointer q,pp,qq,rr; /* for list manipulation */
- q=mp_get_node(mp, knot_node_size); /* this will correspond to |p| */
- qq=q; pp=p;
- while (1) {
- right_type(qq)=left_type(pp); left_type(qq)=right_type(pp);
- x_coord(qq)=x_coord(pp); y_coord(qq)=y_coord(pp);
- right_x(qq)=left_x(pp); right_y(qq)=left_y(pp);
- left_x(qq)=right_x(pp); left_y(qq)=right_y(pp);
- originator(qq)=originator(pp);
- if ( link(pp)==p ) {
- link(q)=qq; mp->path_tail=pp; return q;
- }
- rr=mp_get_node(mp, knot_node_size); link(rr)=qq; qq=rr; pp=link(pp);
- }
-}
-
-@ @<Glob...@>=
-pointer path_tail; /* the node that links to the beginning of a path */
-
-@ When a cyclic list of knot nodes is no longer needed, it can be recycled by
-calling the following subroutine.
-
-@<Declare the recycling subroutines@>=
-void mp_toss_knot_list (MP mp,pointer p) ;
-
-@ @c
-void mp_toss_knot_list (MP mp,pointer p) {
- pointer q; /* the node being freed */
- pointer r; /* the next node */
- q=p;
- do {
- r=link(q);
- mp_free_node(mp, q,knot_node_size); q=r;
- } while (q!=p);
-}
-
-@* \[18] Choosing control points.
-Now we must actually delve into one of \MP's more difficult routines,
-the |make_choices| procedure that chooses angles and control points for
-the splines of a curve when the user has not specified them explicitly.
-The parameter to |make_choices| points to a list of knots and
-path information, as described above.
-
-A path decomposes into independent segments at ``breakpoint'' knots,
-which are knots whose left and right angles are both prespecified in
-some way (i.e., their |left_type| and |right_type| aren't both open).
-
-@c
-@<Declare the procedure called |solve_choices|@>
-void mp_make_choices (MP mp,pointer knots) {
- pointer h; /* the first breakpoint */
- pointer p,q; /* consecutive breakpoints being processed */
- @<Other local variables for |make_choices|@>;
- check_arith; /* make sure that |arith_error=false| */
- if ( mp->internal[mp_tracing_choices]>0 )
- mp_print_path(mp, knots,", before choices",true);
- @<If consecutive knots are equal, join them explicitly@>;
- @<Find the first breakpoint, |h|, on the path;
- insert an artificial breakpoint if the path is an unbroken cycle@>;
- p=h;
- do {
- @<Fill in the control points between |p| and the next breakpoint,
- then advance |p| to that breakpoint@>;
- } while (p!=h);
- if ( mp->internal[mp_tracing_choices]>0 )
- mp_print_path(mp, knots,", after choices",true);
- if ( mp->arith_error ) {
- @<Report an unexpected problem during the choice-making@>;
- }
-}
-
-@ @<Report an unexpected problem during the choice...@>=
-{
- print_err("Some number got too big");
-@.Some number got too big@>
- help2("The path that I just computed is out of range.")
- ("So it will probably look funny. Proceed, for a laugh.");
- mp_put_get_error(mp); mp->arith_error=false;
-}
-
-@ Two knots in a row with the same coordinates will always be joined
-by an explicit ``curve'' whose control points are identical with the
-knots.
-
-@<If consecutive knots are equal, join them explicitly@>=
-p=knots;
-do {
- q=link(p);
- if ( x_coord(p)==x_coord(q) && y_coord(p)==y_coord(q) && right_type(p)>mp_explicit ) {
- right_type(p)=mp_explicit;
- if ( left_type(p)==mp_open ) {
- left_type(p)=mp_curl; left_curl(p)=unity;
- }
- left_type(q)=mp_explicit;
- if ( right_type(q)==mp_open ) {
- right_type(q)=mp_curl; right_curl(q)=unity;
- }
- right_x(p)=x_coord(p); left_x(q)=x_coord(p);
- right_y(p)=y_coord(p); left_y(q)=y_coord(p);
- }
- p=q;
-} while (p!=knots)
-
-@ If there are no breakpoints, it is necessary to compute the direction
-angles around an entire cycle. In this case the |left_type| of the first
-node is temporarily changed to |end_cycle|.
-
-@<Find the first breakpoint, |h|, on the path...@>=
-h=knots;
-while (1) {
- if ( left_type(h)!=mp_open ) break;
- if ( right_type(h)!=mp_open ) break;
- h=link(h);
- if ( h==knots ) {
- left_type(h)=mp_end_cycle; break;
- }
-}
-
-@ If |right_type(p)<given| and |q=link(p)|, we must have
-|right_type(p)=left_type(q)=mp_explicit| or |endpoint|.
-
-@<Fill in the control points between |p| and the next breakpoint...@>=
-q=link(p);
-if ( right_type(p)>=mp_given ) {
- while ( (left_type(q)==mp_open)&&(right_type(q)==mp_open) ) q=link(q);
- @<Fill in the control information between
- consecutive breakpoints |p| and |q|@>;
-} else if ( right_type(p)==mp_endpoint ) {
- @<Give reasonable values for the unused control points between |p| and~|q|@>;
-}
-p=q
-
-@ This step makes it possible to transform an explicitly computed path without
-checking the |left_type| and |right_type| fields.
-
-@<Give reasonable values for the unused control points between |p| and~|q|@>=
-{
- right_x(p)=x_coord(p); right_y(p)=y_coord(p);
- left_x(q)=x_coord(q); left_y(q)=y_coord(q);
-}
-
-@ Before we can go further into the way choices are made, we need to
-consider the underlying theory. The basic ideas implemented in |make_choices|
-are due to John Hobby, who introduced the notion of ``mock curvature''
-@^Hobby, John Douglas@>
-at a knot. Angles are chosen so that they preserve mock curvature when
-a knot is passed, and this has been found to produce excellent results.
-
-It is convenient to introduce some notations that simplify the necessary
-formulas. Let $d_{k,k+1}=\vert z\k-z_k\vert$ be the (nonzero) distance
-between knots |k| and |k+1|; and let
-$${z\k-z_k\over z_k-z_{k-1}}={d_{k,k+1}\over d_{k-1,k}}e^{i\psi_k}$$
-so that a polygonal line from $z_{k-1}$ to $z_k$ to $z\k$ turns left
-through an angle of~$\psi_k$. We assume that $\vert\psi_k\vert\L180^\circ$.
-The control points for the spline from $z_k$ to $z\k$ will be denoted by
-$$\eqalign{z_k^+&=z_k+
- \textstyle{1\over3}\rho_k e^{i\theta_k}(z\k-z_k),\cr
- z\k^-&=z\k-
- \textstyle{1\over3}\sigma\k e^{-i\phi\k}(z\k-z_k),\cr}$$
-where $\rho_k$ and $\sigma\k$ are nonnegative ``velocity ratios'' at the
-beginning and end of the curve, while $\theta_k$ and $\phi\k$ are the
-corresponding ``offset angles.'' These angles satisfy the condition
-$$\theta_k+\phi_k+\psi_k=0,\eqno(*)$$
-whenever the curve leaves an intermediate knot~|k| in the direction that
-it enters.
-
-@ Let $\alpha_k$ and $\beta\k$ be the reciprocals of the ``tension'' of
-the curve at its beginning and ending points. This means that
-$\rho_k=\alpha_k f(\theta_k,\phi\k)$ and $\sigma\k=\beta\k f(\phi\k,\theta_k)$,
-where $f(\theta,\phi)$ is \MP's standard velocity function defined in
-the |velocity| subroutine. The cubic spline $B(z_k^{\phantom+},z_k^+,
-z\k^-,z\k^{\phantom+};t)$
-has curvature
-@^curvature@>
-$${2\sigma\k\sin(\theta_k+\phi\k)-6\sin\theta_k\over\rho_k^2d_{k,k+1}}
-\qquad{\rm and}\qquad
-{2\rho_k\sin(\theta_k+\phi\k)-6\sin\phi\k\over\sigma\k^2d_{k,k+1}}$$
-at |t=0| and |t=1|, respectively. The mock curvature is the linear
-@^mock curvature@>
-approximation to this true curvature that arises in the limit for
-small $\theta_k$ and~$\phi\k$, if second-order terms are discarded.
-The standard velocity function satisfies
-$$f(\theta,\phi)=1+O(\theta^2+\theta\phi+\phi^2);$$
-hence the mock curvatures are respectively
-$${2\beta\k(\theta_k+\phi\k)-6\theta_k\over\alpha_k^2d_{k,k+1}}
-\qquad{\rm and}\qquad
-{2\alpha_k(\theta_k+\phi\k)-6\phi\k\over\beta\k^2d_{k,k+1}}.\eqno(**)$$
-
-@ The turning angles $\psi_k$ are given, and equation $(*)$ above
-determines $\phi_k$ when $\theta_k$ is known, so the task of
-angle selection is essentially to choose appropriate values for each
-$\theta_k$. When equation~$(*)$ is used to eliminate $\phi$~variables
-from $(**)$, we obtain a system of linear equations of the form
-$$A_k\theta_{k-1}+(B_k+C_k)\theta_k+D_k\theta\k=-B_k\psi_k-D_k\psi\k,$$
-where
-$$A_k={\alpha_{k-1}\over\beta_k^2d_{k-1,k}},
-\qquad B_k={3-\alpha_{k-1}\over\beta_k^2d_{k-1,k}},
-\qquad C_k={3-\beta\k\over\alpha_k^2d_{k,k+1}},
-\qquad D_k={\beta\k\over\alpha_k^2d_{k,k+1}}.$$
-The tensions are always $3\over4$ or more, hence each $\alpha$ and~$\beta$
-will be at most $4\over3$. It follows that $B_k\G{5\over4}A_k$ and
-$C_k\G{5\over4}D_k$; hence the equations are diagonally dominant;
-hence they have a unique solution. Moreover, in most cases the tensions
-are equal to~1, so that $B_k=2A_k$ and $C_k=2D_k$. This makes the
-solution numerically stable, and there is an exponential damping
-effect: The data at knot $k\pm j$ affects the angle at knot~$k$ by
-a factor of~$O(2^{-j})$.
-
-@ However, we still must consider the angles at the starting and ending
-knots of a non-cyclic path. These angles might be given explicitly, or
-they might be specified implicitly in terms of an amount of ``curl.''
-
-Let's assume that angles need to be determined for a non-cyclic path
-starting at $z_0$ and ending at~$z_n$. Then equations of the form
-$$A_k\theta_{k-1}+(B_k+C_k)\theta_k+D_k\theta_{k+1}=R_k$$
-have been given for $0<k<n$, and it will be convenient to introduce
-equations of the same form for $k=0$ and $k=n$, where
-$$A_0=B_0=C_n=D_n=0.$$
-If $\theta_0$ is supposed to have a given value $E_0$, we simply
-define $C_0=1$, $D_0=0$, and $R_0=E_0$. Otherwise a curl
-parameter, $\gamma_0$, has been specified at~$z_0$; this means
-that the mock curvature at $z_0$ should be $\gamma_0$ times the
-mock curvature at $z_1$; i.e.,
-$${2\beta_1(\theta_0+\phi_1)-6\theta_0\over\alpha_0^2d_{01}}
-=\gamma_0{2\alpha_0(\theta_0+\phi_1)-6\phi_1\over\beta_1^2d_{01}}.$$
-This equation simplifies to
-$$(\alpha_0\chi_0+3-\beta_1)\theta_0+
- \bigl((3-\alpha_0)\chi_0+\beta_1\bigr)\theta_1=
- -\bigl((3-\alpha_0)\chi_0+\beta_1\bigr)\psi_1,$$
-where $\chi_0=\alpha_0^2\gamma_0/\beta_1^2$; so we can set $C_0=
-\chi_0\alpha_0+3-\beta_1$, $D_0=(3-\alpha_0)\chi_0+\beta_1$, $R_0=-D_0\psi_1$.
-It can be shown that $C_0>0$ and $C_0B_1-A_1D_0>0$ when $\gamma_0\G0$,
-hence the linear equations remain nonsingular.
-
-Similar considerations apply at the right end, when the final angle $\phi_n$
-may or may not need to be determined. It is convenient to let $\psi_n=0$,
-hence $\theta_n=-\phi_n$. We either have an explicit equation $\theta_n=E_n$,
-or we have
-$$\bigl((3-\beta_n)\chi_n+\alpha_{n-1}\bigr)\theta_{n-1}+
-(\beta_n\chi_n+3-\alpha_{n-1})\theta_n=0,\qquad
- \chi_n={\beta_n^2\gamma_n\over\alpha_{n-1}^2}.$$
-
-When |make_choices| chooses angles, it must compute the coefficients of
-these linear equations, then solve the equations. To compute the coefficients,
-it is necessary to compute arctangents of the given turning angles~$\psi_k$.
-When the equations are solved, the chosen directions $\theta_k$ are put
-back into the form of control points by essentially computing sines and
-cosines.
-
-@ OK, we are ready to make the hard choices of |make_choices|.
-Most of the work is relegated to an auxiliary procedure
-called |solve_choices|, which has been introduced to keep
-|make_choices| from being extremely long.
-
-@<Fill in the control information between...@>=
-@<Calculate the turning angles $\psi_k$ and the distances $d_{k,k+1}$;
- set $n$ to the length of the path@>;
-@<Remove |open| types at the breakpoints@>;
-mp_solve_choices(mp, p,q,n)
-
-@ It's convenient to precompute quantities that will be needed several
-times later. The values of |delta_x[k]| and |delta_y[k]| will be the
-coordinates of $z\k-z_k$, and the magnitude of this vector will be
-|delta[k]=@t$d_{k,k+1}$@>|. The path angle $\psi_k$ between $z_k-z_{k-1}$
-and $z\k-z_k$ will be stored in |psi[k]|.
-
-@<Glob...@>=
-int path_size; /* maximum number of knots between breakpoints of a path */
-scaled *delta_x;
-scaled *delta_y;
-scaled *delta; /* knot differences */
-angle *psi; /* turning angles */
-
-@ @<Allocate or initialize ...@>=
-mp->delta_x = NULL;
-mp->delta_y = NULL;
-mp->delta = NULL;
-mp->psi = NULL;
-
-@ @<Dealloc variables@>=
-xfree(mp->delta_x);
-xfree(mp->delta_y);
-xfree(mp->delta);
-xfree(mp->psi);
-
-@ @<Other local variables for |make_choices|@>=
- int k,n; /* current and final knot numbers */
- pointer s,t; /* registers for list traversal */
- scaled delx,dely; /* directions where |open| meets |explicit| */
- fraction sine,cosine; /* trig functions of various angles */
-
-@ @<Calculate the turning angles...@>=
-{
-RESTART:
- k=0; s=p; n=mp->path_size;
- do {
- t=link(s);
- mp->delta_x[k]=x_coord(t)-x_coord(s);
- mp->delta_y[k]=y_coord(t)-y_coord(s);
- mp->delta[k]=mp_pyth_add(mp, mp->delta_x[k],mp->delta_y[k]);
- if ( k>0 ) {
- sine=mp_make_fraction(mp, mp->delta_y[k-1],mp->delta[k-1]);
- cosine=mp_make_fraction(mp, mp->delta_x[k-1],mp->delta[k-1]);
- mp->psi[k]=mp_n_arg(mp, mp_take_fraction(mp, mp->delta_x[k],cosine)+
- mp_take_fraction(mp, mp->delta_y[k],sine),
- mp_take_fraction(mp, mp->delta_y[k],cosine)-
- mp_take_fraction(mp, mp->delta_x[k],sine));
- }
- incr(k); s=t;
- if ( k==mp->path_size ) {
- mp_reallocate_paths(mp, mp->path_size+(mp->path_size>>2));
- goto RESTART; /* retry, loop size has changed */
- }
- if ( s==q ) n=k;
- } while (!((k>=n)&&(left_type(s)!=mp_end_cycle)));
- if ( k==n ) mp->psi[n]=0; else mp->psi[k]=mp->psi[1];
-}
-
-@ When we get to this point of the code, |right_type(p)| is either
-|given| or |curl| or |open|. If it is |open|, we must have
-|left_type(p)=mp_end_cycle| or |left_type(p)=mp_explicit|. In the latter
-case, the |open| type is converted to |given|; however, if the
-velocity coming into this knot is zero, the |open| type is
-converted to a |curl|, since we don't know the incoming direction.
-
-Similarly, |left_type(q)| is either |given| or |curl| or |open| or
-|mp_end_cycle|. The |open| possibility is reduced either to |given| or to |curl|.
-
-@<Remove |open| types at the breakpoints@>=
-if ( left_type(q)==mp_open ) {
- delx=right_x(q)-x_coord(q); dely=right_y(q)-y_coord(q);
- if ( (delx==0)&&(dely==0) ) {
- left_type(q)=mp_curl; left_curl(q)=unity;
- } else {
- left_type(q)=mp_given; left_given(q)=mp_n_arg(mp, delx,dely);
- }
-}
-if ( (right_type(p)==mp_open)&&(left_type(p)==mp_explicit) ) {
- delx=x_coord(p)-left_x(p); dely=y_coord(p)-left_y(p);
- if ( (delx==0)&&(dely==0) ) {
- right_type(p)=mp_curl; right_curl(p)=unity;
- } else {
- right_type(p)=mp_given; right_given(p)=mp_n_arg(mp, delx,dely);
- }
-}
-
-@ Linear equations need to be solved whenever |n>1|; and also when |n=1|
-and exactly one of the breakpoints involves a curl. The simplest case occurs
-when |n=1| and there is a curl at both breakpoints; then we simply draw
-a straight line.
-
-But before coding up the simple cases, we might as well face the general case,
-since we must deal with it sooner or later, and since the general case
-is likely to give some insight into the way simple cases can be handled best.
-
-When there is no cycle, the linear equations to be solved form a tridiagonal
-system, and we can apply the standard technique of Gaussian elimination
-to convert that system to a sequence of equations of the form
-$$\theta_0+u_0\theta_1=v_0,\quad
-\theta_1+u_1\theta_2=v_1,\quad\ldots,\quad
-\theta_{n-1}+u_{n-1}\theta_n=v_{n-1},\quad
-\theta_n=v_n.$$
-It is possible to do this diagonalization while generating the equations.
-Once $\theta_n$ is known, it is easy to determine $\theta_{n-1}$, \dots,
-$\theta_1$, $\theta_0$; thus, the equations will be solved.
-
-The procedure is slightly more complex when there is a cycle, but the
-basic idea will be nearly the same. In the cyclic case the right-hand
-sides will be $v_k+w_k\theta_0$ instead of simply $v_k$, and we will start
-the process off with $u_0=v_0=0$, $w_0=1$. The final equation will be not
-$\theta_n=v_n$ but $\theta_n+u_n\theta_1=v_n+w_n\theta_0$; an appropriate
-ending routine will take account of the fact that $\theta_n=\theta_0$ and
-eliminate the $w$'s from the system, after which the solution can be
-obtained as before.
-
-When $u_k$, $v_k$, and $w_k$ are being computed, the three pointer
-variables |r|, |s|,~|t| will point respectively to knots |k-1|, |k|,
-and~|k+1|. The $u$'s and $w$'s are scaled by $2^{28}$, i.e., they are
-of type |fraction|; the $\theta$'s and $v$'s are of type |angle|.
-
-@<Glob...@>=
-angle *theta; /* values of $\theta_k$ */
-fraction *uu; /* values of $u_k$ */
-angle *vv; /* values of $v_k$ */
-fraction *ww; /* values of $w_k$ */
-
-@ @<Allocate or initialize ...@>=
-mp->theta = NULL;
-mp->uu = NULL;
-mp->vv = NULL;
-mp->ww = NULL;
-
-@ @<Dealloc variables@>=
-xfree(mp->theta);
-xfree(mp->uu);
-xfree(mp->vv);
-xfree(mp->ww);
-
-@ @<Declare |mp_reallocate| functions@>=
-void mp_reallocate_paths (MP mp, int l);
-
-@ @c
-void mp_reallocate_paths (MP mp, int l) {
- XREALLOC (mp->delta_x, l, scaled);
- XREALLOC (mp->delta_y, l, scaled);
- XREALLOC (mp->delta, l, scaled);
- XREALLOC (mp->psi, l, angle);
- XREALLOC (mp->theta, l, angle);
- XREALLOC (mp->uu, l, fraction);
- XREALLOC (mp->vv, l, angle);
- XREALLOC (mp->ww, l, fraction);
- mp->path_size = l;
-}
-
-@ Our immediate problem is to get the ball rolling by setting up the
-first equation or by realizing that no equations are needed, and to fit
-this initialization into a framework suitable for the overall computation.
-
-@<Declare the procedure called |solve_choices|@>=
-@<Declare subroutines needed by |solve_choices|@>
-void mp_solve_choices (MP mp,pointer p, pointer q, halfword n) {
- int k; /* current knot number */
- pointer r,s,t; /* registers for list traversal */
- @<Other local variables for |solve_choices|@>;
- k=0; s=p; r=0;
- while (1) {
- t=link(s);
- if ( k==0 ) {
- @<Get the linear equations started; or |return|
- with the control points in place, if linear equations
- needn't be solved@>
- } else {
- switch (left_type(s)) {
- case mp_end_cycle: case mp_open:
- @<Set up equation to match mock curvatures
- at $z_k$; then |goto found| with $\theta_n$
- adjusted to equal $\theta_0$, if a cycle has ended@>;
- break;
- case mp_curl:
- @<Set up equation for a curl at $\theta_n$
- and |goto found|@>;
- break;
- case mp_given:
- @<Calculate the given value of $\theta_n$
- and |goto found|@>;
- break;
- } /* there are no other cases */
- }
- r=s; s=t; incr(k);
- }
-FOUND:
- @<Finish choosing angles and assigning control points@>;
-}
-
-@ On the first time through the loop, we have |k=0| and |r| is not yet
-defined. The first linear equation, if any, will have $A_0=B_0=0$.
-
-@<Get the linear equations started...@>=
-switch (right_type(s)) {
-case mp_given:
- if ( left_type(t)==mp_given ) {
- @<Reduce to simple case of two givens and |return|@>
- } else {
- @<Set up the equation for a given value of $\theta_0$@>;
- }
- break;
-case mp_curl:
- if ( left_type(t)==mp_curl ) {
- @<Reduce to simple case of straight line and |return|@>
- } else {
- @<Set up the equation for a curl at $\theta_0$@>;
- }
- break;
-case mp_open:
- mp->uu[0]=0; mp->vv[0]=0; mp->ww[0]=fraction_one;
- /* this begins a cycle */
- break;
-} /* there are no other cases */
-
-@ The general equation that specifies equality of mock curvature at $z_k$ is
-$$A_k\theta_{k-1}+(B_k+C_k)\theta_k+D_k\theta\k=-B_k\psi_k-D_k\psi\k,$$
-as derived above. We want to combine this with the already-derived equation
-$\theta_{k-1}+u_{k-1}\theta_k=v_{k-1}+w_{k-1}\theta_0$ in order to obtain
-a new equation
-$\theta_k+u_k\theta\k=v_k+w_k\theta_0$. This can be done by dividing the
-equation
-$$(B_k-u_{k-1}A_k+C_k)\theta_k+D_k\theta\k=-B_k\psi_k-D_k\psi\k-A_kv_{k-1}
- -A_kw_{k-1}\theta_0$$
-by $B_k-u_{k-1}A_k+C_k$. The trick is to do this carefully with
-fixed-point arithmetic, avoiding the chance of overflow while retaining
-suitable precision.
-
-The calculations will be performed in several registers that
-provide temporary storage for intermediate quantities.
-
-@<Other local variables for |solve_choices|@>=
-fraction aa,bb,cc,ff,acc; /* temporary registers */
-scaled dd,ee; /* likewise, but |scaled| */
-scaled lt,rt; /* tension values */
-
-@ @<Set up equation to match mock curvatures...@>=
-{ @<Calculate the values $\\{aa}=A_k/B_k$, $\\{bb}=D_k/C_k$,
- $\\{dd}=(3-\alpha_{k-1})d_{k,k+1}$, $\\{ee}=(3-\beta\k)d_{k-1,k}$,
- and $\\{cc}=(B_k-u_{k-1}A_k)/B_k$@>;
- @<Calculate the ratio $\\{ff}=C_k/(C_k+B_k-u_{k-1}A_k)$@>;
- mp->uu[k]=mp_take_fraction(mp, ff,bb);
- @<Calculate the values of $v_k$ and $w_k$@>;
- if ( left_type(s)==mp_end_cycle ) {
- @<Adjust $\theta_n$ to equal $\theta_0$ and |goto found|@>;
- }
-}
-
-@ Since tension values are never less than 3/4, the values |aa| and
-|bb| computed here are never more than 4/5.
-
-@<Calculate the values $\\{aa}=...@>=
-if ( abs(right_tension(r))==unity) {
- aa=fraction_half; dd=2*mp->delta[k];
-} else {
- aa=mp_make_fraction(mp, unity,3*abs(right_tension(r))-unity);
- dd=mp_take_fraction(mp, mp->delta[k],
- fraction_three-mp_make_fraction(mp, unity,abs(right_tension(r))));
-}
-if ( abs(left_tension(t))==unity ){
- bb=fraction_half; ee=2*mp->delta[k-1];
-} else {
- bb=mp_make_fraction(mp, unity,3*abs(left_tension(t))-unity);
- ee=mp_take_fraction(mp, mp->delta[k-1],
- fraction_three-mp_make_fraction(mp, unity,abs(left_tension(t))));
-}
-cc=fraction_one-mp_take_fraction(mp, mp->uu[k-1],aa)
-
-@ The ratio to be calculated in this step can be written in the form
-$$\beta_k^2\cdot\\{ee}\over\beta_k^2\cdot\\{ee}+\alpha_k^2\cdot
- \\{cc}\cdot\\{dd},$$
-because of the quantities just calculated. The values of |dd| and |ee|
-will not be needed after this step has been performed.
-
-@<Calculate the ratio $\\{ff}=C_k/(C_k+B_k-u_{k-1}A_k)$@>=
-dd=mp_take_fraction(mp, dd,cc); lt=abs(left_tension(s)); rt=abs(right_tension(s));
-if ( lt!=rt ) { /* $\beta_k^{-1}\ne\alpha_k^{-1}$ */
- if ( lt<rt ) {
- ff=mp_make_fraction(mp, lt,rt);
- ff=mp_take_fraction(mp, ff,ff); /* $\alpha_k^2/\beta_k^2$ */
- dd=mp_take_fraction(mp, dd,ff);
- } else {
- ff=mp_make_fraction(mp, rt,lt);
- ff=mp_take_fraction(mp, ff,ff); /* $\beta_k^2/\alpha_k^2$ */
- ee=mp_take_fraction(mp, ee,ff);
- }
-}
-ff=mp_make_fraction(mp, ee,ee+dd)
-
-@ The value of $u_{k-1}$ will be |<=1| except when $k=1$ and the previous
-equation was specified by a curl. In that case we must use a special
-method of computation to prevent overflow.
-
-Fortunately, the calculations turn out to be even simpler in this ``hard''
-case. The curl equation makes $w_0=0$ and $v_0=-u_0\psi_1$, hence
-$-B_1\psi_1-A_1v_0=-(B_1-u_0A_1)\psi_1=-\\{cc}\cdot B_1\psi_1$.
-
-@<Calculate the values of $v_k$ and $w_k$@>=
-acc=-mp_take_fraction(mp, mp->psi[k+1],mp->uu[k]);
-if ( right_type(r)==mp_curl ) {
- mp->ww[k]=0;
- mp->vv[k]=acc-mp_take_fraction(mp, mp->psi[1],fraction_one-ff);
-} else {
- ff=mp_make_fraction(mp, fraction_one-ff,cc); /* this is
- $B_k/(C_k+B_k-u_{k-1}A_k)<5$ */
- acc=acc-mp_take_fraction(mp, mp->psi[k],ff);
- ff=mp_take_fraction(mp, ff,aa); /* this is $A_k/(C_k+B_k-u_{k-1}A_k)$ */
- mp->vv[k]=acc-mp_take_fraction(mp, mp->vv[k-1],ff);
- if ( mp->ww[k-1]==0 ) mp->ww[k]=0;
- else mp->ww[k]=-mp_take_fraction(mp, mp->ww[k-1],ff);
-}
-
-@ When a complete cycle has been traversed, we have $\theta_k+u_k\theta\k=
-v_k+w_k\theta_0$, for |1<=k<=n|. We would like to determine the value of
-$\theta_n$ and reduce the system to the form $\theta_k+u_k\theta\k=v_k$
-for |0<=k<n|, so that the cyclic case can be finished up just as if there
-were no cycle.
-
-The idea in the following code is to observe that
-$$\eqalign{\theta_n&=v_n+w_n\theta_0-u_n\theta_1=\cdots\cr
-&=v_n+w_n\theta_0-u_n\bigl(v_1+w_1\theta_0-u_1(v_2+\cdots
- -u_{n-2}(v_{n-1}+w_{n-1}\theta_0-u_{n-1}\theta_0))\bigr),\cr}$$
-so we can solve for $\theta_n=\theta_0$.
-
-@<Adjust $\theta_n$ to equal $\theta_0$ and |goto found|@>=
-{
-aa=0; bb=fraction_one; /* we have |k=n| */
-do { decr(k);
-if ( k==0 ) k=n;
- aa=mp->vv[k]-mp_take_fraction(mp, aa,mp->uu[k]);
- bb=mp->ww[k]-mp_take_fraction(mp, bb,mp->uu[k]);
-} while (k!=n); /* now $\theta_n=\\{aa}+\\{bb}\cdot\theta_n$ */
-aa=mp_make_fraction(mp, aa,fraction_one-bb);
-mp->theta[n]=aa; mp->vv[0]=aa;
-for (k=1;k<=n-1;k++) {
- mp->vv[k]=mp->vv[k]+mp_take_fraction(mp, aa,mp->ww[k]);
-}
-goto FOUND;
-}
-
-@ @d reduce_angle(A) if ( abs((A))>one_eighty_deg ) {
- if ( (A)>0 ) (A)=(A)-three_sixty_deg; else (A)=(A)+three_sixty_deg; }
-
-@<Calculate the given value of $\theta_n$...@>=
-{
- mp->theta[n]=left_given(s)-mp_n_arg(mp, mp->delta_x[n-1],mp->delta_y[n-1]);
- reduce_angle(mp->theta[n]);
- goto FOUND;
-}
-
-@ @<Set up the equation for a given value of $\theta_0$@>=
-{
- mp->vv[0]=right_given(s)-mp_n_arg(mp, mp->delta_x[0],mp->delta_y[0]);
- reduce_angle(mp->vv[0]);
- mp->uu[0]=0; mp->ww[0]=0;
-}
-
-@ @<Set up the equation for a curl at $\theta_0$@>=
-{ cc=right_curl(s); lt=abs(left_tension(t)); rt=abs(right_tension(s));
- if ( (rt==unity)&&(lt==unity) )
- mp->uu[0]=mp_make_fraction(mp, cc+cc+unity,cc+two);
- else
- mp->uu[0]=mp_curl_ratio(mp, cc,rt,lt);
- mp->vv[0]=-mp_take_fraction(mp, mp->psi[1],mp->uu[0]); mp->ww[0]=0;
-}
-
-@ @<Set up equation for a curl at $\theta_n$...@>=
-{ cc=left_curl(s); lt=abs(left_tension(s)); rt=abs(right_tension(r));
- if ( (rt==unity)&&(lt==unity) )
- ff=mp_make_fraction(mp, cc+cc+unity,cc+two);
- else
- ff=mp_curl_ratio(mp, cc,lt,rt);
- mp->theta[n]=-mp_make_fraction(mp, mp_take_fraction(mp, mp->vv[n-1],ff),
- fraction_one-mp_take_fraction(mp, ff,mp->uu[n-1]));
- goto FOUND;
-}
-
-@ The |curl_ratio| subroutine has three arguments, which our previous notation
-encourages us to call $\gamma$, $\alpha^{-1}$, and $\beta^{-1}$. It is
-a somewhat tedious program to calculate
-$${(3-\alpha)\alpha^2\gamma+\beta^3\over
- \alpha^3\gamma+(3-\beta)\beta^2},$$
-with the result reduced to 4 if it exceeds 4. (This reduction of curl
-is necessary only if the curl and tension are both large.)
-The values of $\alpha$ and $\beta$ will be at most~4/3.
-
-@<Declare subroutines needed by |solve_choices|@>=
-fraction mp_curl_ratio (MP mp,scaled gamma, scaled a_tension,
- scaled b_tension) {
- fraction alpha,beta,num,denom,ff; /* registers */
- alpha=mp_make_fraction(mp, unity,a_tension);
- beta=mp_make_fraction(mp, unity,b_tension);
- if ( alpha<=beta ) {
- ff=mp_make_fraction(mp, alpha,beta); ff=mp_take_fraction(mp, ff,ff);
- gamma=mp_take_fraction(mp, gamma,ff);
- beta=beta / 010000; /* convert |fraction| to |scaled| */
- denom=mp_take_fraction(mp, gamma,alpha)+three-beta;
- num=mp_take_fraction(mp, gamma,fraction_three-alpha)+beta;
- } else {
- ff=mp_make_fraction(mp, beta,alpha); ff=mp_take_fraction(mp, ff,ff);
- beta=mp_take_fraction(mp, beta,ff) / 010000; /* convert |fraction| to |scaled| */
- denom=mp_take_fraction(mp, gamma,alpha)+(ff / 1365)-beta;
- /* $1365\approx 2^{12}/3$ */
- num=mp_take_fraction(mp, gamma,fraction_three-alpha)+beta;
- }
- if ( num>=denom+denom+denom+denom ) return fraction_four;
- else return mp_make_fraction(mp, num,denom);
-}
-
-@ We're in the home stretch now.
-
-@<Finish choosing angles and assigning control points@>=
-for (k=n-1;k>=0;k--) {
- mp->theta[k]=mp->vv[k]-mp_take_fraction(mp,mp->theta[k+1],mp->uu[k]);
-}
-s=p; k=0;
-do {
- t=link(s);
- mp_n_sin_cos(mp, mp->theta[k]); mp->st=mp->n_sin; mp->ct=mp->n_cos;
- mp_n_sin_cos(mp, -mp->psi[k+1]-mp->theta[k+1]); mp->sf=mp->n_sin; mp->cf=mp->n_cos;
- mp_set_controls(mp, s,t,k);
- incr(k); s=t;
-} while (k!=n)
-
-@ The |set_controls| routine actually puts the control points into
-a pair of consecutive nodes |p| and~|q|. Global variables are used to
-record the values of $\sin\theta$, $\cos\theta$, $\sin\phi$, and
-$\cos\phi$ needed in this calculation.
-
-@<Glob...@>=
-fraction st;
-fraction ct;
-fraction sf;
-fraction cf; /* sines and cosines */
-
-@ @<Declare subroutines needed by |solve_choices|@>=
-void mp_set_controls (MP mp,pointer p, pointer q, integer k) {
- fraction rr,ss; /* velocities, divided by thrice the tension */
- scaled lt,rt; /* tensions */
- fraction sine; /* $\sin(\theta+\phi)$ */
- lt=abs(left_tension(q)); rt=abs(right_tension(p));
- rr=mp_velocity(mp, mp->st,mp->ct,mp->sf,mp->cf,rt);
- ss=mp_velocity(mp, mp->sf,mp->cf,mp->st,mp->ct,lt);
- if ( (right_tension(p)<0)||(left_tension(q)<0) ) {
- @<Decrease the velocities,
- if necessary, to stay inside the bounding triangle@>;
- }
- right_x(p)=x_coord(p)+mp_take_fraction(mp,
- mp_take_fraction(mp, mp->delta_x[k],mp->ct)-
- mp_take_fraction(mp, mp->delta_y[k],mp->st),rr);
- right_y(p)=y_coord(p)+mp_take_fraction(mp,
- mp_take_fraction(mp, mp->delta_y[k],mp->ct)+
- mp_take_fraction(mp, mp->delta_x[k],mp->st),rr);
- left_x(q)=x_coord(q)-mp_take_fraction(mp,
- mp_take_fraction(mp, mp->delta_x[k],mp->cf)+
- mp_take_fraction(mp, mp->delta_y[k],mp->sf),ss);
- left_y(q)=y_coord(q)-mp_take_fraction(mp,
- mp_take_fraction(mp, mp->delta_y[k],mp->cf)-
- mp_take_fraction(mp, mp->delta_x[k],mp->sf),ss);
- right_type(p)=mp_explicit; left_type(q)=mp_explicit;
-}
-
-@ The boundedness conditions $\\{rr}\L\sin\phi\,/\sin(\theta+\phi)$ and
-$\\{ss}\L\sin\theta\,/\sin(\theta+\phi)$ are to be enforced if $\sin\theta$,
-$\sin\phi$, and $\sin(\theta+\phi)$ all have the same sign. Otherwise
-there is no ``bounding triangle.''
-
-@<Decrease the velocities, if necessary...@>=
-if (((mp->st>=0)&&(mp->sf>=0))||((mp->st<=0)&&(mp->sf<=0)) ) {
- sine=mp_take_fraction(mp, abs(mp->st),mp->cf)+
- mp_take_fraction(mp, abs(mp->sf),mp->ct);
- if ( sine>0 ) {
- sine=mp_take_fraction(mp, sine,fraction_one+unity); /* safety factor */
- if ( right_tension(p)<0 )
- if ( mp_ab_vs_cd(mp, abs(mp->sf),fraction_one,rr,sine)<0 )
- rr=mp_make_fraction(mp, abs(mp->sf),sine);
- if ( left_tension(q)<0 )
- if ( mp_ab_vs_cd(mp, abs(mp->st),fraction_one,ss,sine)<0 )
- ss=mp_make_fraction(mp, abs(mp->st),sine);
- }
-}
-
-@ Only the simple cases remain to be handled.
-
-@<Reduce to simple case of two givens and |return|@>=
-{
- aa=mp_n_arg(mp, mp->delta_x[0],mp->delta_y[0]);
- mp_n_sin_cos(mp, right_given(p)-aa); mp->ct=mp->n_cos; mp->st=mp->n_sin;
- mp_n_sin_cos(mp, left_given(q)-aa); mp->cf=mp->n_cos; mp->sf=-mp->n_sin;
- mp_set_controls(mp, p,q,0); return;
-}
-
-@ @<Reduce to simple case of straight line and |return|@>=
-{
- right_type(p)=mp_explicit; left_type(q)=mp_explicit;
- lt=abs(left_tension(q)); rt=abs(right_tension(p));
- if ( rt==unity ) {
- if ( mp->delta_x[0]>=0 ) right_x(p)=x_coord(p)+((mp->delta_x[0]+1) / 3);
- else right_x(p)=x_coord(p)+((mp->delta_x[0]-1) / 3);
- if ( mp->delta_y[0]>=0 ) right_y(p)=y_coord(p)+((mp->delta_y[0]+1) / 3);
- else right_y(p)=y_coord(p)+((mp->delta_y[0]-1) / 3);
- } else {
- ff=mp_make_fraction(mp, unity,3*rt); /* $\alpha/3$ */
- right_x(p)=x_coord(p)+mp_take_fraction(mp, mp->delta_x[0],ff);
- right_y(p)=y_coord(p)+mp_take_fraction(mp, mp->delta_y[0],ff);
- }
- if ( lt==unity ) {
- if ( mp->delta_x[0]>=0 ) left_x(q)=x_coord(q)-((mp->delta_x[0]+1) / 3);
- else left_x(q)=x_coord(q)-((mp->delta_x[0]-1) / 3);
- if ( mp->delta_y[0]>=0 ) left_y(q)=y_coord(q)-((mp->delta_y[0]+1) / 3);
- else left_y(q)=y_coord(q)-((mp->delta_y[0]-1) / 3);
- } else {
- ff=mp_make_fraction(mp, unity,3*lt); /* $\beta/3$ */
- left_x(q)=x_coord(q)-mp_take_fraction(mp, mp->delta_x[0],ff);
- left_y(q)=y_coord(q)-mp_take_fraction(mp, mp->delta_y[0],ff);
- }
- return;
-}
-
-@* \[19] Measuring paths.
-\MP's \&{llcorner}, \&{lrcorner}, \&{ulcorner}, and \&{urcorner} operators
-allow the user to measure the bounding box of anything that can go into a
-picture. It's easy to get rough bounds on the $x$ and $y$ extent of a path
-by just finding the bounding box of the knots and the control points. We
-need a more accurate version of the bounding box, but we can still use the
-easy estimate to save time by focusing on the interesting parts of the path.
-
-@ Computing an accurate bounding box involves a theme that will come up again
-and again. Given a Bernshte{\u\i}n polynomial
-@^Bernshte{\u\i}n, Serge{\u\i} Natanovich@>
-$$B(z_0,z_1,\ldots,z_n;t)=\sum_k{n\choose k}t^k(1-t)^{n-k}z_k,$$
-we can conveniently bisect its range as follows:
-
-\smallskip
-\textindent{1)} Let $z_k^{(0)}=z_k$, for |0<=k<=n|.
-
-\smallskip
-\textindent{2)} Let $z_k^{(j+1)}={1\over2}(z_k^{(j)}+z\k^{(j)})$, for
-|0<=k<n-j|, for |0<=j<n|.
-
-\smallskip\noindent
-Then
-$$B(z_0,z_1,\ldots,z_n;t)=B(z_0^{(0)},z_0^{(1)},\ldots,z_0^{(n)};2t)
- =B(z_0^{(n)},z_1^{(n-1)},\ldots,z_n^{(0)};2t-1).$$
-This formula gives us the coefficients of polynomials to use over the ranges
-$0\L t\L{1\over2}$ and ${1\over2}\L t\L1$.
-
-@ Now here's a subroutine that's handy for all sorts of path computations:
-Given a quadratic polynomial $B(a,b,c;t)$, the |crossing_point| function
-returns the unique |fraction| value |t| between 0 and~1 at which
-$B(a,b,c;t)$ changes from positive to negative, or returns
-|t=fraction_one+1| if no such value exists. If |a<0| (so that $B(a,b,c;t)$
-is already negative at |t=0|), |crossing_point| returns the value zero.
-
-@d no_crossing { return (fraction_one+1); }
-@d one_crossing { return fraction_one; }
-@d zero_crossing { return 0; }
-@d mp_crossing_point(M,A,B,C) mp_do_crossing_point(A,B,C)
-
-@c fraction mp_do_crossing_point (integer a, integer b, integer c) {
- integer d; /* recursive counter */
- integer x,xx,x0,x1,x2; /* temporary registers for bisection */
- if ( a<0 ) zero_crossing;
- if ( c>=0 ) {
- if ( b>=0 ) {
- if ( c>0 ) { no_crossing; }
- else if ( (a==0)&&(b==0) ) { no_crossing;}
- else { one_crossing; }
- }
- if ( a==0 ) zero_crossing;
- } else if ( a==0 ) {
- if ( b<=0 ) zero_crossing;
- }
- @<Use bisection to find the crossing point, if one exists@>;
-}
-
-@ The general bisection method is quite simple when $n=2$, hence
-|crossing_point| does not take much time. At each stage in the
-recursion we have a subinterval defined by |l| and~|j| such that
-$B(a,b,c;2^{-l}(j+t))=B(x_0,x_1,x_2;t)$, and we want to ``zero in'' on
-the subinterval where $x_0\G0$ and $\min(x_1,x_2)<0$.
-
-It is convenient for purposes of calculation to combine the values
-of |l| and~|j| in a single variable $d=2^l+j$, because the operation
-of bisection then corresponds simply to doubling $d$ and possibly
-adding~1. Furthermore it proves to be convenient to modify
-our previous conventions for bisection slightly, maintaining the
-variables $X_0=2^lx_0$, $X_1=2^l(x_0-x_1)$, and $X_2=2^l(x_1-x_2)$.
-With these variables the conditions $x_0\ge0$ and $\min(x_1,x_2)<0$ are
-equivalent to $\max(X_1,X_1+X_2)>X_0\ge0$.
-
-The following code maintains the invariant relations
-$0\L|x0|<\max(|x1|,|x1|+|x2|)$,
-$\vert|x1|\vert<2^{30}$, $\vert|x2|\vert<2^{30}$;
-it has been constructed in such a way that no arithmetic overflow
-will occur if the inputs satisfy
-$a<2^{30}$, $\vert a-b\vert<2^{30}$, and $\vert b-c\vert<2^{30}$.
-
-@<Use bisection to find the crossing point...@>=
-d=1; x0=a; x1=a-b; x2=b-c;
-do {
- x=half(x1+x2);
- if ( x1-x0>x0 ) {
- x2=x; x0+=x0; d+=d;
- } else {
- xx=x1+x-x0;
- if ( xx>x0 ) {
- x2=x; x0+=x0; d+=d;
- } else {
- x0=x0-xx;
- if ( x<=x0 ) { if ( x+x2<=x0 ) no_crossing; }
- x1=x; d=d+d+1;
- }
- }
-} while (d<fraction_one);
-return (d-fraction_one)
-
-@ Here is a routine that computes the $x$ or $y$ coordinate of the point on
-a cubic corresponding to the |fraction| value~|t|.
-
-It is convenient to define a \.{WEB} macro |t_of_the_way| such that
-|t_of_the_way(a,b)| expands to |a-(a-b)*t|, i.e., to |t[a,b]|.
-
-@d t_of_the_way(A,B) ((A)-mp_take_fraction(mp,((A)-(B)),t))
-
-@c scaled mp_eval_cubic (MP mp,pointer p, pointer q, fraction t) {
- scaled x1,x2,x3; /* intermediate values */
- x1=t_of_the_way(knot_coord(p),right_coord(p));
- x2=t_of_the_way(right_coord(p),left_coord(q));
- x3=t_of_the_way(left_coord(q),knot_coord(q));
- x1=t_of_the_way(x1,x2);
- x2=t_of_the_way(x2,x3);
- return t_of_the_way(x1,x2);
-}
-
-@ The actual bounding box information is stored in global variables.
-Since it is convenient to address the $x$ and $y$ information
-separately, we define arrays indexed by |x_code..y_code| and use
-macros to give them more convenient names.
-
-@<Types...@>=
-enum mp_bb_code {
- mp_x_code=0, /* index for |minx| and |maxx| */
- mp_y_code /* index for |miny| and |maxy| */
-} ;
-
-@
-@d minx mp->bbmin[mp_x_code]
-@d maxx mp->bbmax[mp_x_code]
-@d miny mp->bbmin[mp_y_code]
-@d maxy mp->bbmax[mp_y_code]
-
-@<Glob...@>=
-scaled bbmin[mp_y_code+1];
-scaled bbmax[mp_y_code+1];
-/* the result of procedures that compute bounding box information */
-
-@ Now we're ready for the key part of the bounding box computation.
-The |bound_cubic| procedure updates |bbmin[c]| and |bbmax[c]| based on
-$$B(\hbox{|knot_coord(p)|}, \hbox{|right_coord(p)|},
- \hbox{|left_coord(q)|}, \hbox{|knot_coord(q)|};t)
-$$
-for $0<t\le1$. In other words, the procedure adjusts the bounds to
-accommodate |knot_coord(q)| and any extremes over the range $0<t<1$.
-The |c| parameter is |x_code| or |y_code|.
-
-@c void mp_bound_cubic (MP mp,pointer p, pointer q, small_number c) {
- boolean wavy; /* whether we need to look for extremes */
- scaled del1,del2,del3,del,dmax; /* proportional to the control
- points of a quadratic derived from a cubic */
- fraction t,tt; /* where a quadratic crosses zero */
- scaled x; /* a value that |bbmin[c]| and |bbmax[c]| must accommodate */
- x=knot_coord(q);
- @<Adjust |bbmin[c]| and |bbmax[c]| to accommodate |x|@>;
- @<Check the control points against the bounding box and set |wavy:=true|
- if any of them lie outside@>;
- if ( wavy ) {
- del1=right_coord(p)-knot_coord(p);
- del2=left_coord(q)-right_coord(p);
- del3=knot_coord(q)-left_coord(q);
- @<Scale up |del1|, |del2|, and |del3| for greater accuracy;
- also set |del| to the first nonzero element of |(del1,del2,del3)|@>;
- if ( del<0 ) {
- negate(del1); negate(del2); negate(del3);
- };
- t=mp_crossing_point(mp, del1,del2,del3);
- if ( t<fraction_one ) {
- @<Test the extremes of the cubic against the bounding box@>;
- }
- }
-}
-
-@ @<Adjust |bbmin[c]| and |bbmax[c]| to accommodate |x|@>=
-if ( x<mp->bbmin[c] ) mp->bbmin[c]=x;
-if ( x>mp->bbmax[c] ) mp->bbmax[c]=x
-
-@ @<Check the control points against the bounding box and set...@>=
-wavy=true;
-if ( mp->bbmin[c]<=right_coord(p) )
- if ( right_coord(p)<=mp->bbmax[c] )
- if ( mp->bbmin[c]<=left_coord(q) )
- if ( left_coord(q)<=mp->bbmax[c] )
- wavy=false
-
-@ If |del1=del2=del3=0|, it's impossible to obey the title of this
-section. We just set |del=0| in that case.
-
-@<Scale up |del1|, |del2|, and |del3| for greater accuracy...@>=
-if ( del1!=0 ) del=del1;
-else if ( del2!=0 ) del=del2;
-else del=del3;
-if ( del!=0 ) {
- dmax=abs(del1);
- if ( abs(del2)>dmax ) dmax=abs(del2);
- if ( abs(del3)>dmax ) dmax=abs(del3);
- while ( dmax<fraction_half ) {
- dmax+=dmax; del1+=del1; del2+=del2; del3+=del3;
- }
-}
-
-@ Since |crossing_point| has tried to choose |t| so that
-$B(|del1|,|del2|,|del3|;\tau)$ crosses zero at $\tau=|t|$ with negative
-slope, the value of |del2| computed below should not be positive.
-But rounding error could make it slightly positive in which case we
-must cut it to zero to avoid confusion.
-
-@<Test the extremes of the cubic against the bounding box@>=
-{
- x=mp_eval_cubic(mp, p,q,t);
- @<Adjust |bbmin[c]| and |bbmax[c]| to accommodate |x|@>;
- del2=t_of_the_way(del2,del3);
- /* now |0,del2,del3| represent the derivative on the remaining interval */
- if ( del2>0 ) del2=0;
- tt=mp_crossing_point(mp, 0,-del2,-del3);
- if ( tt<fraction_one ) {
- @<Test the second extreme against the bounding box@>;
- }
-}
-
-@ @<Test the second extreme against the bounding box@>=
-{
- x=mp_eval_cubic(mp, p,q,t_of_the_way(tt,fraction_one));
- @<Adjust |bbmin[c]| and |bbmax[c]| to accommodate |x|@>;
-}
-
-@ Finding the bounding box of a path is basically a matter of applying
-|bound_cubic| twice for each pair of adjacent knots.
-
-@c void mp_path_bbox (MP mp,pointer h) {
- pointer p,q; /* a pair of adjacent knots */
- minx=x_coord(h); miny=y_coord(h);
- maxx=minx; maxy=miny;
- p=h;
- do {
- if ( right_type(p)==mp_endpoint ) return;
- q=link(p);
- mp_bound_cubic(mp, x_loc(p),x_loc(q),mp_x_code);
- mp_bound_cubic(mp, y_loc(p),y_loc(q),mp_y_code);
- p=q;
- } while (p!=h);
-}
-
-@ Another important way to measure a path is to find its arc length. This
-is best done by using the general bisection algorithm to subdivide the path
-until obtaining ``well behaved'' subpaths whose arc lengths can be approximated
-by simple means.
-
-Since the arc length is the integral with respect to time of the magnitude of
-the velocity, it is natural to use Simpson's rule for the approximation.
-@^Simpson's rule@>
-If $\dot B(t)$ is the spline velocity, Simpson's rule gives
-$$ \vb\dot B(0)\vb + 4\vb\dot B({1\over2})\vb + \vb\dot B(1)\vb \over 6 $$
-for the arc length of a path of length~1. For a cubic spline
-$B(z_0,z_1,z_2,z_3;t)$, the time derivative $\dot B(t)$ is
-$3B(dz_0,dz_1,dz_2;t)$, where $dz_i=z_{i+1}-z_i$. Hence the arc length
-approximation is
-$$ {\vb dz_0\vb \over 2} + 2\vb dz_{02}\vb + {\vb dz_2\vb \over 2}, $$
-where
-$$ dz_{02}={1\over2}\left({dz_0+dz_1\over 2}+{dz_1+dz_2\over 2}\right)$$
-is the result of the bisection algorithm.
-
-@ The remaining problem is how to decide when a subpath is ``well behaved.''
-This could be done via the theoretical error bound for Simpson's rule,
-@^Simpson's rule@>
-but this is impractical because it requires an estimate of the fourth
-derivative of the quantity being integrated. It is much easier to just perform
-a bisection step and see how much the arc length estimate changes. Since the
-error for Simpson's rule is proportional to the fourth power of the sample
-spacing, the remaining error is typically about $1\over16$ of the amount of
-the change. We say ``typically'' because the error has a pseudo-random behavior
-that could cause the two estimates to agree when each contain large errors.
-
-To protect against disasters such as undetected cusps, the bisection process
-should always continue until all the $dz_i$ vectors belong to a single
-$90^\circ$ sector. This ensures that no point on the spline can have velocity
-less than 70\% of the minimum of $\vb dz_0\vb$, $\vb dz_1\vb$ and $\vb dz_2\vb$.
-If such a spline happens to produce an erroneous arc length estimate that
-is little changed by bisection, the amount of the error is likely to be fairly
-small. We will try to arrange things so that freak accidents of this type do
-not destroy the inverse relationship between the \&{arclength} and
-\&{arctime} operations.
-@:arclength_}{\&{arclength} primitive@>
-@:arctime_}{\&{arctime} primitive@>
-
-@ The \&{arclength} and \&{arctime} operations are both based on a recursive
-@^recursion@>
-function that finds the arc length of a cubic spline given $dz_0$, $dz_1$,
-$dz_2$. This |arc_test| routine also takes an arc length goal |a_goal| and
-returns the time when the arc length reaches |a_goal| if there is such a time.
-Thus the return value is either an arc length less than |a_goal| or, if the
-arc length would be at least |a_goal|, it returns a time value decreased by
-|two|. This allows the caller to use the sign of the result to distinguish
-between arc lengths and time values. On certain types of overflow, it is
-possible for |a_goal| and the result of |arc_test| both to be |el_gordo|.
-Otherwise, the result is always less than |a_goal|.
-
-Rather than halving the control point coordinates on each recursive call to
-|arc_test|, it is better to keep them proportional to velocity on the original
-curve and halve the results instead. This means that recursive calls can
-potentially use larger error tolerances in their arc length estimates. How
-much larger depends on to what extent the errors behave as though they are
-independent of each other. To save computing time, we use optimistic assumptions
-and increase the tolerance by a factor of about $\sqrt2$ for each recursive
-call.
-
-In addition to the tolerance parameter, |arc_test| should also have parameters
-for ${1\over3}\vb\dot B(0)\vb$, ${2\over3}\vb\dot B({1\over2})\vb$, and
-${1\over3}\vb\dot B(1)\vb$. These quantities are relatively expensive to compute
-and they are needed in different instances of |arc_test|.
-
-@c @<Declare subroutines needed by |arc_test|@>
-scaled mp_arc_test (MP mp, scaled dx0, scaled dy0, scaled dx1, scaled dy1,
- scaled dx2, scaled dy2, scaled v0, scaled v02,
- scaled v2, scaled a_goal, scaled tol) {
- boolean simple; /* are the control points confined to a $90^\circ$ sector? */
- scaled dx01, dy01, dx12, dy12, dx02, dy02; /* bisection results */
- scaled v002, v022;
- /* twice the velocity magnitudes at $t={1\over4}$ and $t={3\over4}$ */
- scaled arc; /* best arc length estimate before recursion */
- @<Other local variables in |arc_test|@>;
- @<Bisect the B\'ezier quadratic given by |dx0|, |dy0|, |dx1|, |dy1|,
- |dx2|, |dy2|@>;
- @<Initialize |v002|, |v022|, and the arc length estimate |arc|; if it overflows
- set |arc_test| and |return|@>;
- @<Test if the control points are confined to one quadrant or rotating them
- $45^\circ$ would put them in one quadrant. Then set |simple| appropriately@>;
- if ( simple && (abs(arc-v02-halfp(v0+v2)) <= tol) ) {
- if ( arc < a_goal ) {
- return arc;
- } else {
- @<Estimate when the arc length reaches |a_goal| and set |arc_test| to
- that time minus |two|@>;
- }
- } else {
- @<Use one or two recursive calls to compute the |arc_test| function@>;
- }
-}
-
-@ The |tol| value should by multiplied by $\sqrt 2$ before making recursive
-calls, but $1.5$ is an adequate approximation. It is best to avoid using
-|make_fraction| in this inner loop.
-@^inner loop@>
-
-@<Use one or two recursive calls to compute the |arc_test| function@>=
-{
- @<Set |a_new| and |a_aux| so their sum is |2*a_goal| and |a_new| is as
- large as possible@>;
- tol = tol + halfp(tol);
- a = mp_arc_test(mp, dx0,dy0, dx01,dy01, dx02,dy02, v0, v002,
- halfp(v02), a_new, tol);
- if ( a<0 ) {
- return (-halfp(two-a));
- } else {
- @<Update |a_new| to reduce |a_new+a_aux| by |a|@>;
- b = mp_arc_test(mp, dx02,dy02, dx12,dy12, dx2,dy2,
- halfp(v02), v022, v2, a_new, tol);
- if ( b<0 )
- return (-halfp(-b) - half_unit);
- else
- return (a + half(b-a));
- }
-}
-
-@ @<Other local variables in |arc_test|@>=
-scaled a,b; /* results of recursive calls */
-scaled a_new,a_aux; /* the sum of these gives the |a_goal| */
-
-@ @<Set |a_new| and |a_aux| so their sum is |2*a_goal| and |a_new| is...@>=
-a_aux = el_gordo - a_goal;
-if ( a_goal > a_aux ) {
- a_aux = a_goal - a_aux;
- a_new = el_gordo;
-} else {
- a_new = a_goal + a_goal;
- a_aux = 0;
-}
-
-@ There is no need to maintain |a_aux| at this point so we use it as a temporary
-to force the additions and subtractions to be done in an order that avoids
-overflow.
-
-@<Update |a_new| to reduce |a_new+a_aux| by |a|@>=
-if ( a > a_aux ) {
- a_aux = a_aux - a;
- a_new = a_new + a_aux;
-}
-
-@ This code assumes all {\it dx} and {\it dy} variables have magnitude less than
-|fraction_four|. To simplify the rest of the |arc_test| routine, we strengthen
-this assumption by requiring the norm of each $({\it dx},{\it dy})$ pair to obey
-this bound. Note that recursive calls will maintain this invariant.
-
-@<Bisect the B\'ezier quadratic given by |dx0|, |dy0|, |dx1|, |dy1|,...@>=
-dx01 = half(dx0 + dx1);
-dx12 = half(dx1 + dx2);
-dx02 = half(dx01 + dx12);
-dy01 = half(dy0 + dy1);
-dy12 = half(dy1 + dy2);
-dy02 = half(dy01 + dy12)
-
-@ We should be careful to keep |arc<el_gordo| so that calling |arc_test| with
-|a_goal=el_gordo| is guaranteed to yield the arc length.
-
-@<Initialize |v002|, |v022|, and the arc length estimate |arc|;...@>=
-v002 = mp_pyth_add(mp, dx01+half(dx0+dx02), dy01+half(dy0+dy02));
-v022 = mp_pyth_add(mp, dx12+half(dx02+dx2), dy12+half(dy02+dy2));
-tmp = halfp(v02+2);
-arc1 = v002 + half(halfp(v0+tmp) - v002);
-arc = v022 + half(halfp(v2+tmp) - v022);
-if ( (arc < el_gordo-arc1) ) {
- arc = arc+arc1;
-} else {
- mp->arith_error = true;
- if ( a_goal==el_gordo ) return (el_gordo);
- else return (-two);
-}
-
-@ @<Other local variables in |arc_test|@>=
-scaled tmp, tmp2; /* all purpose temporary registers */
-scaled arc1; /* arc length estimate for the first half */
-
-@ @<Test if the control points are confined to one quadrant or rotating...@>=
-simple = ((dx0>=0) && (dx1>=0) && (dx2>=0)) ||
- ((dx0<=0) && (dx1<=0) && (dx2<=0));
-if ( simple )
- simple = ((dy0>=0) && (dy1>=0) && (dy2>=0)) ||
- ((dy0<=0) && (dy1<=0) && (dy2<=0));
-if ( ! simple ) {
- simple = ((dx0>=dy0) && (dx1>=dy1) && (dx2>=dy2)) ||
- ((dx0<=dy0) && (dx1<=dy1) && (dx2<=dy2));
- if ( simple )
- simple = ((-dx0>=dy0) && (-dx1>=dy1) && (-dx2>=dy2)) ||
- ((-dx0<=dy0) && (-dx1<=dy1) && (-dx2<=dy2));
-}
-
-@ Since Simpson's rule is based on approximating the integrand by a parabola,
-@^Simpson's rule@>
-it is appropriate to use the same approximation to decide when the integral
-reaches the intermediate value |a_goal|. At this point
-$$\eqalign{
- {\vb\dot B(0)\vb\over 3} &= \hbox{|v0|}, \qquad
- {\vb\dot B({1\over4})\vb\over 3} = {\hbox{|v002|}\over 2}, \qquad
- {\vb\dot B({1\over2})\vb\over 3} = {\hbox{|v02|}\over 2}, \cr
- {\vb\dot B({3\over4})\vb\over 3} &= {\hbox{|v022|}\over 2}, \qquad
- {\vb\dot B(1)\vb\over 3} = \hbox{|v2|} \cr
-}
-$$
-and
-$$ {\vb\dot B(t)\vb\over 3} \approx
- \cases{B\left(\hbox{|v0|},
- \hbox{|v002|}-{1\over 2}\hbox{|v0|}-{1\over 4}\hbox{|v02|},
- {1\over 2}\hbox{|v02|}; 2t \right)&
- if $t\le{1\over 2}$\cr
- B\left({1\over 2}\hbox{|v02|},
- \hbox{|v022|}-{1\over 4}\hbox{|v02|}-{1\over 2}\hbox{|v2|},
- \hbox{|v2|}; 2t-1 \right)&
- if $t\ge{1\over 2}$.\cr}
- \eqno (*)
-$$
-We can integrate $\vb\dot B(t)\vb$ by using
-$$\int 3B(a,b,c;\tau)\,dt =
- {B(0,a,a+b,a+b+c;\tau) + {\rm constant} \over {d\tau\over dt}}.
-$$
-
-This construction allows us to find the time when the arc length reaches
-|a_goal| by solving a cubic equation of the form
-$$ B(0,a,a+b,a+b+c;\tau) = x, $$
-where $\tau$ is $2t$ or $2t+1$, $x$ is |a_goal| or |a_goal-arc1|, and $a$, $b$,
-and $c$ are the Bernshte{\u\i}n coefficients from $(*)$ divided by
-@^Bernshte{\u\i}n, Serge{\u\i} Natanovich@>
-$d\tau\over dt$. We shall define a function |solve_rising_cubic| that finds
-$\tau$ given $a$, $b$, $c$, and $x$.
-
-@<Estimate when the arc length reaches |a_goal| and set |arc_test| to...@>=
-{
- tmp = (v02 + 2) / 4;
- if ( a_goal<=arc1 ) {
- tmp2 = halfp(v0);
- return
- (halfp(mp_solve_rising_cubic(mp, tmp2, arc1-tmp2-tmp, tmp, a_goal))- two);
- } else {
- tmp2 = halfp(v2);
- return ((half_unit - two) +
- halfp(mp_solve_rising_cubic(mp, tmp, arc-arc1-tmp-tmp2, tmp2, a_goal-arc1)));
- }
-}
-
-@ Here is the |solve_rising_cubic| routine that finds the time~$t$ when
-$$ B(0, a, a+b, a+b+c; t) = x. $$
-This routine is based on |crossing_point| but is simplified by the
-assumptions that $B(a,b,c;t)\ge0$ for $0\le t\le1$ and that |0<=x<=a+b+c|.
-If rounding error causes this condition to be violated slightly, we just ignore
-it and proceed with binary search. This finds a time when the function value
-reaches |x| and the slope is positive.
-
-@<Declare subroutines needed by |arc_test|@>=
-scaled mp_solve_rising_cubic (MP mp,scaled a, scaled b, scaled c, scaled x) {
- scaled ab, bc, ac; /* bisection results */
- integer t; /* $2^k+q$ where unscaled answer is in $[q2^{-k},(q+1)2^{-k})$ */
- integer xx; /* temporary for updating |x| */
- if ( (a<0) || (c<0) ) mp_confusion(mp, "rising?");
-@:this can't happen rising?}{\quad rising?@>
- if ( x<=0 ) {
- return 0;
- } else if ( x >= a+b+c ) {
- return unity;
- } else {
- t = 1;
- @<Rescale if necessary to make sure |a|, |b|, and |c| are all less than
- |el_gordo div 3|@>;
- do {
- t+=t;
- @<Subdivide the B\'ezier quadratic defined by |a|, |b|, |c|@>;
- xx = x - a - ab - ac;
- if ( xx < -x ) { x+=x; b=ab; c=ac; }
- else { x = x + xx; a=ac; b=bc; t = t+1; };
- } while (t < unity);
- return (t - unity);
- }
-}
-
-@ @<Subdivide the B\'ezier quadratic defined by |a|, |b|, |c|@>=
-ab = half(a+b);
-bc = half(b+c);
-ac = half(ab+bc)
-
-@ @d one_third_el_gordo 05252525252 /* upper bound on |a|, |b|, and |c| */
-
-@<Rescale if necessary to make sure |a|, |b|, and |c| are all less than...@>=
-while ((a>one_third_el_gordo)||(b>one_third_el_gordo)||(c>one_third_el_gordo)) {
- a = halfp(a);
- b = half(b);
- c = halfp(c);
- x = halfp(x);
-}
-
-@ It is convenient to have a simpler interface to |arc_test| that requires no
-unnecessary arguments and ensures that each $({\it dx},{\it dy})$ pair has
-length less than |fraction_four|.
-
-@d arc_tol 16 /* quit when change in arc length estimate reaches this */
-
-@c scaled mp_do_arc_test (MP mp,scaled dx0, scaled dy0, scaled dx1,
- scaled dy1, scaled dx2, scaled dy2, scaled a_goal) {
- scaled v0,v1,v2; /* length of each $({\it dx},{\it dy})$ pair */
- scaled v02; /* twice the norm of the quadratic at $t={1\over2}$ */
- v0 = mp_pyth_add(mp, dx0,dy0);
- v1 = mp_pyth_add(mp, dx1,dy1);
- v2 = mp_pyth_add(mp, dx2,dy2);
- if ( (v0>=fraction_four) || (v1>=fraction_four) || (v2>=fraction_four) ) {
- mp->arith_error = true;
- if ( a_goal==el_gordo ) return el_gordo;
- else return (-two);
- } else {
- v02 = mp_pyth_add(mp, dx1+half(dx0+dx2), dy1+half(dy0+dy2));
- return (mp_arc_test(mp, dx0,dy0, dx1,dy1, dx2,dy2,
- v0, v02, v2, a_goal, arc_tol));
- }
-}
-
-@ Now it is easy to find the arc length of an entire path.
-
-@c scaled mp_get_arc_length (MP mp,pointer h) {
- pointer p,q; /* for traversing the path */
- scaled a,a_tot; /* current and total arc lengths */
- a_tot = 0;
- p = h;
- while ( right_type(p)!=mp_endpoint ){
- q = link(p);
- a = mp_do_arc_test(mp, right_x(p)-x_coord(p), right_y(p)-y_coord(p),
- left_x(q)-right_x(p), left_y(q)-right_y(p),
- x_coord(q)-left_x(q), y_coord(q)-left_y(q), el_gordo);
- a_tot = mp_slow_add(mp, a, a_tot);
- if ( q==h ) break; else p=q;
- }
- check_arith;
- return a_tot;
-}
-
-@ The inverse operation of finding the time on a path~|h| when the arc length
-reaches some value |arc0| can also be accomplished via |do_arc_test|. Some care
-is required to handle very large times or negative times on cyclic paths. For
-non-cyclic paths, |arc0| values that are negative or too large cause
-|get_arc_time| to return 0 or the length of path~|h|.
-
-If |arc0| is greater than the arc length of a cyclic path~|h|, the result is a
-time value greater than the length of the path. Since it could be much greater,
-we must be prepared to compute the arc length of path~|h| and divide this into
-|arc0| to find how many multiples of the length of path~|h| to add.
-
-@c scaled mp_get_arc_time (MP mp,pointer h, scaled arc0) {
- pointer p,q; /* for traversing the path */
- scaled t_tot; /* accumulator for the result */
- scaled t; /* the result of |do_arc_test| */
- scaled arc; /* portion of |arc0| not used up so far */
- integer n; /* number of extra times to go around the cycle */
- if ( arc0<0 ) {
- @<Deal with a negative |arc0| value and |return|@>;
- }
- if ( arc0==el_gordo ) decr(arc0);
- t_tot = 0;
- arc = arc0;
- p = h;
- while ( (right_type(p)!=mp_endpoint) && (arc>0) ) {
- q = link(p);
- t = mp_do_arc_test(mp, right_x(p)-x_coord(p), right_y(p)-y_coord(p),
- left_x(q)-right_x(p), left_y(q)-right_y(p),
- x_coord(q)-left_x(q), y_coord(q)-left_y(q), arc);
- @<Update |arc| and |t_tot| after |do_arc_test| has just returned |t|@>;
- if ( q==h ) {
- @<Update |t_tot| and |arc| to avoid going around the cyclic
- path too many times but set |arith_error:=true| and |goto done| on
- overflow@>;
- }
- p = q;
- }
- check_arith;
- return t_tot;
-}
-
-@ @<Update |arc| and |t_tot| after |do_arc_test| has just returned |t|@>=
-if ( t<0 ) { t_tot = t_tot + t + two; arc = 0; }
-else { t_tot = t_tot + unity; arc = arc - t; }
-
-@ @<Deal with a negative |arc0| value and |return|@>=
-{
- if ( left_type(h)==mp_endpoint ) {
- t_tot=0;
- } else {
- p = mp_htap_ypoc(mp, h);
- t_tot = -mp_get_arc_time(mp, p, -arc0);
- mp_toss_knot_list(mp, p);
- }
- check_arith;
- return t_tot;
-}
-
-@ @<Update |t_tot| and |arc| to avoid going around the cyclic...@>=
-if ( arc>0 ) {
- n = arc / (arc0 - arc);
- arc = arc - n*(arc0 - arc);
- if ( t_tot > (el_gordo / (n+1)) ) {
- return el_gordo;
- }
- t_tot = (n + 1)*t_tot;
-}
-
-@* \[20] Data structures for pens.
-A Pen in \MP\ can be either elliptical or polygonal. Elliptical pens result
-in \ps\ \&{stroke} commands, while anything drawn with a polygonal pen is
-@:stroke}{\&{stroke} command@>
-converted into an area fill as described in the next part of this program.
-The mathematics behind this process is based on simple aspects of the theory
-of tracings developed by Leo Guibas, Lyle Ramshaw, and Jorge Stolfi
-[``A kinematic framework for computational geometry,'' Proc.\ IEEE Symp.\
-Foundations of Computer Science {\bf 24} (1983), 100--111].
-
-Polygonal pens are created from paths via \MP's \&{makepen} primitive.
-@:makepen_}{\&{makepen} primitive@>
-This path representation is almost sufficient for our purposes except that
-a pen path should always be a convex polygon with the vertices in
-counter-clockwise order.
-Since we will need to scan pen polygons both forward and backward, a pen
-should be represented as a doubly linked ring of knot nodes. There is
-room for the extra back pointer because we do not need the
-|left_type| or |right_type| fields. In fact, we don't need the |left_x|,
-|left_y|, |right_x|, or |right_y| fields either but we leave these alone
-so that certain procedures can operate on both pens and paths. In particular,
-pens can be copied using |copy_path| and recycled using |toss_knot_list|.
-
-@d knil info
- /* this replaces the |left_type| and |right_type| fields in a pen knot */
-
-@ The |make_pen| procedure turns a path into a pen by initializing
-the |knil| pointers and making sure the knots form a convex polygon.
-Thus each cubic in the given path becomes a straight line and the control
-points are ignored. If the path is not cyclic, the ends are connected by a
-straight line.
-
-@d copy_pen(A) mp_make_pen(mp, mp_copy_path(mp, (A)),false)
-
-@c @<Declare a function called |convex_hull|@>
-pointer mp_make_pen (MP mp,pointer h, boolean need_hull) {
- pointer p,q; /* two consecutive knots */
- q=h;
- do {
- p=q; q=link(q);
- knil(q)=p;
- } while (q!=h);
- if ( need_hull ){
- h=mp_convex_hull(mp, h);
- @<Make sure |h| isn't confused with an elliptical pen@>;
- }
- return h;
-}
-
-@ The only information required about an elliptical pen is the overall
-transformation that has been applied to the original \&{pencircle}.
-@:pencircle_}{\&{pencircle} primitive@>
-Since it suffices to keep track of how the three points $(0,0)$, $(1,0)$,
-and $(0,1)$ are transformed, an elliptical pen can be stored in a single
-knot node and transformed as if it were a path.
-
-@d pen_is_elliptical(A) ((A)==link((A)))
-
-@c pointer mp_get_pen_circle (MP mp,scaled diam) {
- pointer h; /* the knot node to return */
- h=mp_get_node(mp, knot_node_size);
- link(h)=h; knil(h)=h;
- originator(h)=mp_program_code;
- x_coord(h)=0; y_coord(h)=0;
- left_x(h)=diam; left_y(h)=0;
- right_x(h)=0; right_y(h)=diam;
- return h;
-}
-
-@ If the polygon being returned by |make_pen| has only one vertex, it will
-be interpreted as an elliptical pen. This is no problem since a degenerate
-polygon can equally well be thought of as a degenerate ellipse. We need only
-initialize the |left_x|, |left_y|, |right_x|, and |right_y| fields.
-
-@<Make sure |h| isn't confused with an elliptical pen@>=
-if ( pen_is_elliptical( h) ){
- left_x(h)=x_coord(h); left_y(h)=y_coord(h);
- right_x(h)=x_coord(h); right_y(h)=y_coord(h);
-}
-
-@ We have to cheat a little here but most operations on pens only use
-the first three words in each knot node.
-@^data structure assumptions@>
-
-@<Initialize a pen at |test_pen| so that it fits in nine words@>=
-x_coord(test_pen)=-half_unit;
-y_coord(test_pen)=0;
-x_coord(test_pen+3)=half_unit;
-y_coord(test_pen+3)=0;
-x_coord(test_pen+6)=0;
-y_coord(test_pen+6)=unity;
-link(test_pen)=test_pen+3;
-link(test_pen+3)=test_pen+6;
-link(test_pen+6)=test_pen;
-knil(test_pen)=test_pen+6;
-knil(test_pen+3)=test_pen;
-knil(test_pen+6)=test_pen+3
-
-@ Printing a polygonal pen is very much like printing a path
-
-@<Declare subroutines for printing expressions@>=
-void mp_pr_pen (MP mp,pointer h) {
- pointer p,q; /* for list traversal */
- if ( pen_is_elliptical(h) ) {
- @<Print the elliptical pen |h|@>;
- } else {
- p=h;
- do {
- mp_print_two(mp, x_coord(p),y_coord(p));
- mp_print_nl(mp, " .. ");
- @<Advance |p| making sure the links are OK and |return| if there is
- a problem@>;
- } while (p!=h);
- mp_print(mp, "cycle");
- }
-}
-
-@ @<Advance |p| making sure the links are OK and |return| if there is...@>=
-q=link(p);
-if ( (q==null) || (knil(q)!=p) ) {
- mp_print_nl(mp, "???"); return; /* this won't happen */
-@.???@>
-}
-p=q
-
-@ @<Print the elliptical pen |h|@>=
-{
-mp_print(mp, "pencircle transformed (");
-mp_print_scaled(mp, x_coord(h));
-mp_print_char(mp, ',');
-mp_print_scaled(mp, y_coord(h));
-mp_print_char(mp, ',');
-mp_print_scaled(mp, left_x(h)-x_coord(h));
-mp_print_char(mp, ',');
-mp_print_scaled(mp, right_x(h)-x_coord(h));
-mp_print_char(mp, ',');
-mp_print_scaled(mp, left_y(h)-y_coord(h));
-mp_print_char(mp, ',');
-mp_print_scaled(mp, right_y(h)-y_coord(h));
-mp_print_char(mp, ')');
-}
-
-@ Here us another version of |pr_pen| that prints the pen as a diagnostic
-message.
-
-@<Declare subroutines for printing expressions@>=
-void mp_print_pen (MP mp,pointer h, const char *s, boolean nuline) {
- mp_print_diagnostic(mp, "Pen",s,nuline); mp_print_ln(mp);
-@.Pen at line...@>
- mp_pr_pen(mp, h);
- mp_end_diagnostic(mp, true);
-}
-
-@ Making a polygonal pen into a path involves restoring the |left_type| and
-|right_type| fields and setting the control points so as to make a polygonal
-path.
-
-@c
-void mp_make_path (MP mp,pointer h) {
- pointer p; /* for traversing the knot list */
- small_number k; /* a loop counter */
- @<Other local variables in |make_path|@>;
- if ( pen_is_elliptical(h) ) {
- @<Make the elliptical pen |h| into a path@>;
- } else {
- p=h;
- do {
- left_type(p)=mp_explicit;
- right_type(p)=mp_explicit;
- @<copy the coordinates of knot |p| into its control points@>;
- p=link(p);
- } while (p!=h);
- }
-}
-
-@ @<copy the coordinates of knot |p| into its control points@>=
-left_x(p)=x_coord(p);
-left_y(p)=y_coord(p);
-right_x(p)=x_coord(p);
-right_y(p)=y_coord(p)
-
-@ We need an eight knot path to get a good approximation to an ellipse.
-
-@<Make the elliptical pen |h| into a path@>=
-{
- @<Extract the transformation parameters from the elliptical pen~|h|@>;
- p=h;
- for (k=0;k<=7;k++ ) {
- @<Initialize |p| as the |k|th knot of a circle of unit diameter,
- transforming it appropriately@>;
- if ( k==7 ) link(p)=h; else link(p)=mp_get_node(mp, knot_node_size);
- p=link(p);
- }
-}
-
-@ @<Extract the transformation parameters from the elliptical pen~|h|@>=
-center_x=x_coord(h);
-center_y=y_coord(h);
-width_x=left_x(h)-center_x;
-width_y=left_y(h)-center_y;
-height_x=right_x(h)-center_x;
-height_y=right_y(h)-center_y
-
-@ @<Other local variables in |make_path|@>=
-scaled center_x,center_y; /* translation parameters for an elliptical pen */
-scaled width_x,width_y; /* the effect of a unit change in $x$ */
-scaled height_x,height_y; /* the effect of a unit change in $y$ */
-scaled dx,dy; /* the vector from knot |p| to its right control point */
-integer kk;
- /* |k| advanced $270^\circ$ around the ring (cf. $\sin\theta=\cos(\theta+270)$) */
-
-@ The only tricky thing here are the tables |half_cos| and |d_cos| used to
-find the point $k/8$ of the way around the circle and the direction vector
-to use there.
-
-@<Initialize |p| as the |k|th knot of a circle of unit diameter,...@>=
-kk=(k+6)% 8;
-x_coord(p)=center_x+mp_take_fraction(mp, mp->half_cos[k],width_x)
- +mp_take_fraction(mp, mp->half_cos[kk],height_x);
-y_coord(p)=center_y+mp_take_fraction(mp, mp->half_cos[k],width_y)
- +mp_take_fraction(mp, mp->half_cos[kk],height_y);
-dx=-mp_take_fraction(mp, mp->d_cos[kk],width_x)
- +mp_take_fraction(mp, mp->d_cos[k],height_x);
-dy=-mp_take_fraction(mp, mp->d_cos[kk],width_y)
- +mp_take_fraction(mp, mp->d_cos[k],height_y);
-right_x(p)=x_coord(p)+dx;
-right_y(p)=y_coord(p)+dy;
-left_x(p)=x_coord(p)-dx;
-left_y(p)=y_coord(p)-dy;
-left_type(p)=mp_explicit;
-right_type(p)=mp_explicit;
-originator(p)=mp_program_code
-
-@ @<Glob...@>=
-fraction half_cos[8]; /* ${1\over2}\cos(45k)$ */
-fraction d_cos[8]; /* a magic constant times $\cos(45k)$ */
-
-@ The magic constant for |d_cos| is the distance between $({1\over2},0)$ and
-$({1\over4}\sqrt2,{1\over4}\sqrt2)$ times the result of the |velocity|
-function for $\theta=\phi=22.5^\circ$. This comes out to be
-$$ d = {\sqrt{2-\sqrt2}\over 3+3\cos22.5^\circ}
- \approx 0.132608244919772.
-$$
-
-@<Set init...@>=
-mp->half_cos[0]=fraction_half;
-mp->half_cos[1]=94906266; /* $2^{26}\sqrt2\approx94906265.62$ */
-mp->half_cos[2]=0;
-mp->d_cos[0]=35596755; /* $2^{28}d\approx35596754.69$ */
-mp->d_cos[1]=25170707; /* $2^{27}\sqrt2\,d\approx25170706.63$ */
-mp->d_cos[2]=0;
-for (k=3;k<= 4;k++ ) {
- mp->half_cos[k]=-mp->half_cos[4-k];
- mp->d_cos[k]=-mp->d_cos[4-k];
-}
-for (k=5;k<= 7;k++ ) {
- mp->half_cos[k]=mp->half_cos[8-k];
- mp->d_cos[k]=mp->d_cos[8-k];
-}
-
-@ The |convex_hull| function forces a pen polygon to be convex when it is
-returned by |make_pen| and after any subsequent transformation where rounding
-error might allow the convexity to be lost.
-The convex hull algorithm used here is described by F.~P. Preparata and
-M.~I. Shamos [{\sl Computational Geometry}, Springer-Verlag, 1985].
-
-@<Declare a function called |convex_hull|@>=
-@<Declare a procedure called |move_knot|@>
-pointer mp_convex_hull (MP mp,pointer h) { /* Make a polygonal pen convex */
- pointer l,r; /* the leftmost and rightmost knots */
- pointer p,q; /* knots being scanned */
- pointer s; /* the starting point for an upcoming scan */
- scaled dx,dy; /* a temporary pointer */
- if ( pen_is_elliptical(h) ) {
- return h;
- } else {
- @<Set |l| to the leftmost knot in polygon~|h|@>;
- @<Set |r| to the rightmost knot in polygon~|h|@>;
- if ( l!=r ) {
- s=link(r);
- @<Find any knots on the path from |l| to |r| above the |l|-|r| line and
- move them past~|r|@>;
- @<Find any knots on the path from |s| to |l| below the |l|-|r| line and
- move them past~|l|@>;
- @<Sort the path from |l| to |r| by increasing $x$@>;
- @<Sort the path from |r| to |l| by decreasing $x$@>;
- }
- if ( l!=link(l) ) {
- @<Do a Gramm scan and remove vertices where there is no left turn@>;
- }
- return l;
- }
-}
-
-@ All comparisons are done primarily on $x$ and secondarily on $y$.
-
-@<Set |l| to the leftmost knot in polygon~|h|@>=
-l=h;
-p=link(h);
-while ( p!=h ) {
- if ( x_coord(p)<=x_coord(l) )
- if ( (x_coord(p)<x_coord(l)) || (y_coord(p)<y_coord(l)) )
- l=p;
- p=link(p);
-}
-
-@ @<Set |r| to the rightmost knot in polygon~|h|@>=
-r=h;
-p=link(h);
-while ( p!=h ) {
- if ( x_coord(p)>=x_coord(r) )
- if ( (x_coord(p)>x_coord(r)) || (y_coord(p)>y_coord(r)) )
- r=p;
- p=link(p);
-}
-
-@ @<Find any knots on the path from |l| to |r| above the |l|-|r| line...@>=
-dx=x_coord(r)-x_coord(l);
-dy=y_coord(r)-y_coord(l);
-p=link(l);
-while ( p!=r ) {
- q=link(p);
- if ( mp_ab_vs_cd(mp, dx,y_coord(p)-y_coord(l),dy,x_coord(p)-x_coord(l))>0 )
- mp_move_knot(mp, p, r);
- p=q;
-}
-
-@ The |move_knot| procedure removes |p| from a doubly linked list and inserts
-it after |q|.
-
-@ @<Declare a procedure called |move_knot|@>=
-void mp_move_knot (MP mp,pointer p, pointer q) {
- link(knil(p))=link(p);
- knil(link(p))=knil(p);
- knil(p)=q;
- link(p)=link(q);
- link(q)=p;
- knil(link(p))=p;
-}
-
-@ @<Find any knots on the path from |s| to |l| below the |l|-|r| line...@>=
-p=s;
-while ( p!=l ) {
- q=link(p);
- if ( mp_ab_vs_cd(mp, dx,y_coord(p)-y_coord(l),dy,x_coord(p)-x_coord(l))<0 )
- mp_move_knot(mp, p,l);
- p=q;
-}
-
-@ The list is likely to be in order already so we just do linear insertions.
-Secondary comparisons on $y$ ensure that the sort is consistent with the
-choice of |l| and |r|.
-
-@<Sort the path from |l| to |r| by increasing $x$@>=
-p=link(l);
-while ( p!=r ) {
- q=knil(p);
- while ( x_coord(q)>x_coord(p) ) q=knil(q);
- while ( x_coord(q)==x_coord(p) ) {
- if ( y_coord(q)>y_coord(p) ) q=knil(q); else break;
- }
- if ( q==knil(p) ) p=link(p);
- else { p=link(p); mp_move_knot(mp, knil(p),q); };
-}
-
-@ @<Sort the path from |r| to |l| by decreasing $x$@>=
-p=link(r);
-while ( p!=l ){
- q=knil(p);
- while ( x_coord(q)<x_coord(p) ) q=knil(q);
- while ( x_coord(q)==x_coord(p) ) {
- if ( y_coord(q)<y_coord(p) ) q=knil(q); else break;
- }
- if ( q==knil(p) ) p=link(p);
- else { p=link(p); mp_move_knot(mp, knil(p),q); };
-}
-
-@ The condition involving |ab_vs_cd| tests if there is not a left turn
-at knot |q|. There usually will be a left turn so we streamline the case
-where the |then| clause is not executed.
-
-@<Do a Gramm scan and remove vertices where there...@>=
-{
-p=l; q=link(l);
-while (1) {
- dx=x_coord(q)-x_coord(p);
- dy=y_coord(q)-y_coord(p);
- p=q; q=link(q);
- if ( p==l ) break;
- if ( p!=r )
- if ( mp_ab_vs_cd(mp, dx,y_coord(q)-y_coord(p),dy,x_coord(q)-x_coord(p))<=0 ) {
- @<Remove knot |p| and back up |p| and |q| but don't go past |l|@>;
- }
- }
-}
-
-@ @<Remove knot |p| and back up |p| and |q| but don't go past |l|@>=
-{
-s=knil(p);
-mp_free_node(mp, p,knot_node_size);
-link(s)=q; knil(q)=s;
-if ( s==l ) p=s;
-else { p=knil(s); q=s; };
-}
-
-@ The |find_offset| procedure sets global variables |(cur_x,cur_y)| to the
-offset associated with the given direction |(x,y)|. If two different offsets
-apply, it chooses one of them.
-
-@c
-void mp_find_offset (MP mp,scaled x, scaled y, pointer h) {
- pointer p,q; /* consecutive knots */
- scaled wx,wy,hx,hy;
- /* the transformation matrix for an elliptical pen */
- fraction xx,yy; /* untransformed offset for an elliptical pen */
- fraction d; /* a temporary register */
- if ( pen_is_elliptical(h) ) {
- @<Find the offset for |(x,y)| on the elliptical pen~|h|@>
- } else {
- q=h;
- do {
- p=q; q=link(q);
- } while (!(mp_ab_vs_cd(mp, x_coord(q)-x_coord(p),y, y_coord(q)-y_coord(p),x)>=0));
- do {
- p=q; q=link(q);
- } while (!(mp_ab_vs_cd(mp, x_coord(q)-x_coord(p),y, y_coord(q)-y_coord(p),x)<=0));
- mp->cur_x=x_coord(p);
- mp->cur_y=y_coord(p);
- }
-}
-
-@ @<Glob...@>=
-scaled cur_x;
-scaled cur_y; /* all-purpose return value registers */
-
-@ @<Find the offset for |(x,y)| on the elliptical pen~|h|@>=
-if ( (x==0) && (y==0) ) {
- mp->cur_x=x_coord(h); mp->cur_y=y_coord(h);
-} else {
- @<Find the non-constant part of the transformation for |h|@>;
- while ( (abs(x)<fraction_half) && (abs(y)<fraction_half) ){
- x+=x; y+=y;
- };
- @<Make |(xx,yy)| the offset on the untransformed \&{pencircle} for the
- untransformed version of |(x,y)|@>;
- mp->cur_x=x_coord(h)+mp_take_fraction(mp, xx,wx)+mp_take_fraction(mp, yy,hx);
- mp->cur_y=y_coord(h)+mp_take_fraction(mp, xx,wy)+mp_take_fraction(mp, yy,hy);
-}
-
-@ @<Find the non-constant part of the transformation for |h|@>=
-wx=left_x(h)-x_coord(h);
-wy=left_y(h)-y_coord(h);
-hx=right_x(h)-x_coord(h);
-hy=right_y(h)-y_coord(h)
-
-@ @<Make |(xx,yy)| the offset on the untransformed \&{pencircle} for the...@>=
-yy=-(mp_take_fraction(mp, x,hy)+mp_take_fraction(mp, y,-hx));
-xx=mp_take_fraction(mp, x,-wy)+mp_take_fraction(mp, y,wx);
-d=mp_pyth_add(mp, xx,yy);
-if ( d>0 ) {
- xx=half(mp_make_fraction(mp, xx,d));
- yy=half(mp_make_fraction(mp, yy,d));
-}
-
-@ Finding the bounding box of a pen is easy except if the pen is elliptical.
-But we can handle that case by just calling |find_offset| twice. The answer
-is stored in the global variables |minx|, |maxx|, |miny|, and |maxy|.
-
-@c
-void mp_pen_bbox (MP mp,pointer h) {
- pointer p; /* for scanning the knot list */
- if ( pen_is_elliptical(h) ) {
- @<Find the bounding box of an elliptical pen@>;
- } else {
- minx=x_coord(h); maxx=minx;
- miny=y_coord(h); maxy=miny;
- p=link(h);
- while ( p!=h ) {
- if ( x_coord(p)<minx ) minx=x_coord(p);
- if ( y_coord(p)<miny ) miny=y_coord(p);
- if ( x_coord(p)>maxx ) maxx=x_coord(p);
- if ( y_coord(p)>maxy ) maxy=y_coord(p);
- p=link(p);
- }
- }
-}
-
-@ @<Find the bounding box of an elliptical pen@>=
-{
-mp_find_offset(mp, 0,fraction_one,h);
-maxx=mp->cur_x;
-minx=2*x_coord(h)-mp->cur_x;
-mp_find_offset(mp, -fraction_one,0,h);
-maxy=mp->cur_y;
-miny=2*y_coord(h)-mp->cur_y;
-}
-
-@* \[21] Edge structures.
-Now we come to \MP's internal scheme for representing pictures.
-The representation is very different from \MF's edge structures
-because \MP\ pictures contain \ps\ graphics objects instead of pixel
-images. However, the basic idea is somewhat similar in that shapes
-are represented via their boundaries.
-
-The main purpose of edge structures is to keep track of graphical objects
-until it is time to translate them into \ps. Since \MP\ does not need to
-know anything about an edge structure other than how to translate it into
-\ps\ and how to find its bounding box, edge structures can be just linked
-lists of graphical objects. \MP\ has no easy way to determine whether
-two such objects overlap, but it suffices to draw the first one first and
-let the second one overwrite it if necessary.
-
-@<Types...@>=
-enum mp_graphical_object_code {
- @<Graphical object codes@>
- mp_final_graphic
-};
-
-@ Let's consider the types of graphical objects one at a time.
-First of all, a filled contour is represented by a eight-word node. The first
-word contains |type| and |link| fields, and the next six words contain a
-pointer to a cyclic path and the value to use for \ps' \&{currentrgbcolor}
-parameter. If a pen is used for filling |pen_p|, |ljoin_val| and |miterlim_val|
-give the relevant information.
-
-@d path_p(A) link((A)+1)
- /* a pointer to the path that needs filling */
-@d pen_p(A) info((A)+1)
- /* a pointer to the pen to fill or stroke with */
-@d color_model(A) type((A)+2) /* the color model */
-@d obj_red_loc(A) ((A)+3) /* the first of three locations for the color */
-@d obj_cyan_loc obj_red_loc /* the first of four locations for the color */
-@d obj_grey_loc obj_red_loc /* the location for the color */
-@d red_val(A) mp->mem[(A)+3].sc
- /* the red component of the color in the range $0\ldots1$ */
-@d cyan_val red_val
-@d grey_val red_val
-@d green_val(A) mp->mem[(A)+4].sc
- /* the green component of the color in the range $0\ldots1$ */
-@d magenta_val green_val
-@d blue_val(A) mp->mem[(A)+5].sc
- /* the blue component of the color in the range $0\ldots1$ */
-@d yellow_val blue_val
-@d black_val(A) mp->mem[(A)+6].sc
- /* the blue component of the color in the range $0\ldots1$ */
-@d ljoin_val(A) name_type((A)) /* the value of \&{linejoin} */
-@:mp_linejoin_}{\&{linejoin} primitive@>
-@d miterlim_val(A) mp->mem[(A)+7].sc /* the value of \&{miterlimit} */
-@:mp_miterlimit_}{\&{miterlimit} primitive@>
-@d obj_color_part(A) mp->mem[(A)+3-red_part].sc
- /* interpret an object pointer that has been offset by |red_part..blue_part| */
-@d pre_script(A) mp->mem[(A)+8].hh.lh
-@d post_script(A) mp->mem[(A)+8].hh.rh
-@d fill_node_size 9
-
-@ @<Graphical object codes@>=
-mp_fill_code=1,
-
-@ @c
-pointer mp_new_fill_node (MP mp,pointer p) {
- /* make a fill node for cyclic path |p| and color black */
- pointer t; /* the new node */
- t=mp_get_node(mp, fill_node_size);
- type(t)=mp_fill_code;
- path_p(t)=p;
- pen_p(t)=null; /* |null| means don't use a pen */
- red_val(t)=0;
- green_val(t)=0;
- blue_val(t)=0;
- black_val(t)=0;
- color_model(t)=mp_uninitialized_model;
- pre_script(t)=null;
- post_script(t)=null;
- @<Set the |ljoin_val| and |miterlim_val| fields in object |t|@>;
- return t;
-}
-
-@ @<Set the |ljoin_val| and |miterlim_val| fields in object |t|@>=
-if ( mp->internal[mp_linejoin]>unity ) ljoin_val(t)=2;
-else if ( mp->internal[mp_linejoin]>0 ) ljoin_val(t)=1;
-else ljoin_val(t)=0;
-if ( mp->internal[mp_miterlimit]<unity )
- miterlim_val(t)=unity;
-else
- miterlim_val(t)=mp->internal[mp_miterlimit]
-
-@ A stroked path is represented by an eight-word node that is like a filled
-contour node except that it contains the current \&{linecap} value, a scale
-factor for the dash pattern, and a pointer that is non-null if the stroke
-is to be dashed. The purpose of the scale factor is to allow a picture to
-be transformed without touching the picture that |dash_p| points to.
-
-@d dash_p(A) link((A)+9)
- /* a pointer to the edge structure that gives the dash pattern */
-@d lcap_val(A) type((A)+9)
- /* the value of \&{linecap} */
-@:mp_linecap_}{\&{linecap} primitive@>
-@d dash_scale(A) mp->mem[(A)+10].sc /* dash lengths are scaled by this factor */
-@d stroked_node_size 11
-
-@ @<Graphical object codes@>=
-mp_stroked_code=2,
-
-@ @c
-pointer mp_new_stroked_node (MP mp,pointer p) {
- /* make a stroked node for path |p| with |pen_p(p)| temporarily |null| */
- pointer t; /* the new node */
- t=mp_get_node(mp, stroked_node_size);
- type(t)=mp_stroked_code;
- path_p(t)=p; pen_p(t)=null;
- dash_p(t)=null;
- dash_scale(t)=unity;
- red_val(t)=0;
- green_val(t)=0;
- blue_val(t)=0;
- black_val(t)=0;
- color_model(t)=mp_uninitialized_model;
- pre_script(t)=null;
- post_script(t)=null;
- @<Set the |ljoin_val| and |miterlim_val| fields in object |t|@>;
- if ( mp->internal[mp_linecap]>unity ) lcap_val(t)=2;
- else if ( mp->internal[mp_linecap]>0 ) lcap_val(t)=1;
- else lcap_val(t)=0;
- return t;
-}
-
-@ When a dashed line is computed in a transformed coordinate system, the dash
-lengths get scaled like the pen shape and we need to compensate for this. Since
-there is no unique scale factor for an arbitrary transformation, we use the
-the square root of the determinant. The properties of the determinant make it
-easier to maintain the |dash_scale|. The computation is fairly straight-forward
-except for the initialization of the scale factor |s|. The factor of 64 is
-needed because |square_rt| scales its result by $2^8$ while we need $2^{14}$
-to counteract the effect of |take_fraction|.
-
-@<Declare subroutines needed by |print_edges|@>=
-scaled mp_sqrt_det (MP mp,scaled a, scaled b, scaled c, scaled d) {
- scaled maxabs; /* $max(|a|,|b|,|c|,|d|)$ */
- integer s; /* amount by which the result of |square_rt| needs to be scaled */
- @<Initialize |maxabs|@>;
- s=64;
- while ( (maxabs<fraction_one) && (s>1) ){
- a+=a; b+=b; c+=c; d+=d;
- maxabs+=maxabs; s=halfp(s);
- }
- return s*mp_square_rt(mp, abs(mp_take_fraction(mp, a,d)-mp_take_fraction(mp, b,c)));
-}
-@#
-scaled mp_get_pen_scale (MP mp,pointer p) {
- return mp_sqrt_det(mp,
- left_x(p)-x_coord(p), right_x(p)-x_coord(p),
- left_y(p)-y_coord(p), right_y(p)-y_coord(p));
-}
-
-@ @<Internal library ...@>=
-scaled mp_sqrt_det (MP mp,scaled a, scaled b, scaled c, scaled d) ;
-
-
-@ @<Initialize |maxabs|@>=
-maxabs=abs(a);
-if ( abs(b)>maxabs ) maxabs=abs(b);
-if ( abs(c)>maxabs ) maxabs=abs(c);
-if ( abs(d)>maxabs ) maxabs=abs(d)
-
-@ When a picture contains text, this is represented by a fourteen-word node
-where the color information and |type| and |link| fields are augmented by
-additional fields that describe the text and how it is transformed.
-The |path_p| and |pen_p| pointers are replaced by a number that identifies
-the font and a string number that gives the text to be displayed.
-The |width|, |height|, and |depth| fields
-give the dimensions of the text at its design size, and the remaining six
-words give a transformation to be applied to the text. The |new_text_node|
-function initializes everything to default values so that the text comes out
-black with its reference point at the origin.
-
-@d text_p(A) link((A)+1) /* a string pointer for the text to display */
-@d font_n(A) info((A)+1) /* the font number */
-@d width_val(A) mp->mem[(A)+7].sc /* unscaled width of the text */
-@d height_val(A) mp->mem[(A)+9].sc /* unscaled height of the text */
-@d depth_val(A) mp->mem[(A)+10].sc /* unscaled depth of the text */
-@d text_tx_loc(A) ((A)+11)
- /* the first of six locations for transformation parameters */
-@d tx_val(A) mp->mem[(A)+11].sc /* $x$ shift amount */
-@d ty_val(A) mp->mem[(A)+12].sc /* $y$ shift amount */
-@d txx_val(A) mp->mem[(A)+13].sc /* |txx| transformation parameter */
-@d txy_val(A) mp->mem[(A)+14].sc /* |txy| transformation parameter */
-@d tyx_val(A) mp->mem[(A)+15].sc /* |tyx| transformation parameter */
-@d tyy_val(A) mp->mem[(A)+16].sc /* |tyy| transformation parameter */
-@d text_trans_part(A) mp->mem[(A)+11-x_part].sc
- /* interpret a text node pointer that has been offset by |x_part..yy_part| */
-@d text_node_size 17
-
-@ @<Graphical object codes@>=
-mp_text_code=3,
-
-@ @c @<Declare text measuring subroutines@>
-pointer mp_new_text_node (MP mp,char *f,str_number s) {
- /* make a text node for font |f| and text string |s| */
- pointer t; /* the new node */
- t=mp_get_node(mp, text_node_size);
- type(t)=mp_text_code;
- text_p(t)=s;
- font_n(t)=mp_find_font(mp, f); /* this identifies the font */
- red_val(t)=0;
- green_val(t)=0;
- blue_val(t)=0;
- black_val(t)=0;
- color_model(t)=mp_uninitialized_model;
- pre_script(t)=null;
- post_script(t)=null;
- tx_val(t)=0; ty_val(t)=0;
- txx_val(t)=unity; txy_val(t)=0;
- tyx_val(t)=0; tyy_val(t)=unity;
- mp_set_text_box(mp, t); /* this finds the bounding box */
- return t;
-}
-
-@ The last two types of graphical objects that can occur in an edge structure
-are clipping paths and \&{setbounds} paths. These are slightly more difficult
-@:set_bounds_}{\&{setbounds} primitive@>
-to implement because we must keep track of exactly what is being clipped or
-bounded when pictures get merged together. For this reason, each clipping or
-\&{setbounds} operation is represented by a pair of nodes: first comes a
-two-word node whose |path_p| gives the relevant path, then there is the list
-of objects to clip or bound followed by a two-word node whose second word is
-unused.
-
-Using at least two words for each graphical object node allows them all to be
-allocated and deallocated similarly with a global array |gr_object_size| to
-give the size in words for each object type.
-
-@d start_clip_size 2
-@d start_bounds_size 2
-@d stop_clip_size 2 /* the second word is not used here */
-@d stop_bounds_size 2 /* the second word is not used here */
-@#
-@d stop_type(A) ((A)+2)
- /* matching |type| for |start_clip_code| or |start_bounds_code| */
-@d has_color(A) (type((A))<mp_start_clip_code)
- /* does a graphical object have color fields? */
-@d has_pen(A) (type((A))<mp_text_code)
- /* does a graphical object have a |pen_p| field? */
-@d is_start_or_stop(A) (type((A))>=mp_start_clip_code)
-@d is_stop(A) (type((A))>=mp_stop_clip_code)
-
-@ @<Graphical object codes@>=
-mp_start_clip_code=4, /* |type| of a node that starts clipping */
-mp_start_bounds_code=5, /* |type| of a node that gives a \&{setbounds} path */
-mp_stop_clip_code=6, /* |type| of a node that stops clipping */
-mp_stop_bounds_code=7, /* |type| of a node that stops \&{setbounds} */
-
-@ @c
-pointer mp_new_bounds_node (MP mp,pointer p, small_number c) {
- /* make a node of type |c| where |p| is the clipping or \&{setbounds} path */
- pointer t; /* the new node */
- t=mp_get_node(mp, mp->gr_object_size[c]);
- type(t)=c;
- path_p(t)=p;
- return t;
-}
-
-@ We need an array to keep track of the sizes of graphical objects.
-
-@<Glob...@>=
-small_number gr_object_size[mp_stop_bounds_code+1];
-
-@ @<Set init...@>=
-mp->gr_object_size[mp_fill_code]=fill_node_size;
-mp->gr_object_size[mp_stroked_code]=stroked_node_size;
-mp->gr_object_size[mp_text_code]=text_node_size;
-mp->gr_object_size[mp_start_clip_code]=start_clip_size;
-mp->gr_object_size[mp_stop_clip_code]=stop_clip_size;
-mp->gr_object_size[mp_start_bounds_code]=start_bounds_size;
-mp->gr_object_size[mp_stop_bounds_code]=stop_bounds_size;
-
-@ All the essential information in an edge structure is encoded as a linked list
-of graphical objects as we have just seen, but it is helpful to add some
-redundant information. A single edge structure might be used as a dash pattern
-many times, and it would be nice to avoid scanning the same structure
-repeatedly. Thus, an edge structure known to be a suitable dash pattern
-has a header that gives a list of dashes in a sorted order designed for rapid
-translation into \ps.
-
-Each dash is represented by a three-word node containing the initial and final
-$x$~coordinates as well as the usual |link| field. The |link| fields points to
-the dash node with the next higher $x$-coordinates and the final link points
-to a special location called |null_dash|. (There should be no overlap between
-dashes). Since the $y$~coordinate of the dash pattern is needed to determine
-the period of repetition, this needs to be stored in the edge header along
-with a pointer to the list of dash nodes.
-
-@d start_x(A) mp->mem[(A)+1].sc /* the starting $x$~coordinate in a dash node */
-@d stop_x(A) mp->mem[(A)+2].sc /* the ending $x$~coordinate in a dash node */
-@d dash_node_size 3
-@d dash_list link
- /* in an edge header this points to the first dash node */
-@d dash_y(A) mp->mem[(A)+1].sc /* $y$ value for the dash list in an edge header */
-
-@ It is also convenient for an edge header to contain the bounding
-box information needed by the \&{llcorner} and \&{urcorner} operators
-so that this does not have to be recomputed unnecessarily. This is done by
-adding fields for the $x$~and $y$ extremes as well as a pointer that indicates
-how far the bounding box computation has gotten. Thus if the user asks for
-the bounding box and then adds some more text to the picture before asking
-for more bounding box information, the second computation need only look at
-the additional text.
-
-When the bounding box has not been computed, the |bblast| pointer points
-to a dummy link at the head of the graphical object list while the |minx_val|
-and |miny_val| fields contain |el_gordo| and the |maxx_val| and |maxy_val|
-fields contain |-el_gordo|.
-
-Since the bounding box of pictures containing objects of type
-|mp_start_bounds_code| depends on the value of \&{truecorners}, the bounding box
-@:mp_true_corners_}{\&{truecorners} primitive@>
-data might not be valid for all values of this parameter. Hence, the |bbtype|
-field is needed to keep track of this.
-
-@d minx_val(A) mp->mem[(A)+2].sc
-@d miny_val(A) mp->mem[(A)+3].sc
-@d maxx_val(A) mp->mem[(A)+4].sc
-@d maxy_val(A) mp->mem[(A)+5].sc
-@d bblast(A) link((A)+6) /* last item considered in bounding box computation */
-@d bbtype(A) info((A)+6) /* tells how bounding box data depends on \&{truecorners} */
-@d dummy_loc(A) ((A)+7) /* where the object list begins in an edge header */
-@d no_bounds 0
- /* |bbtype| value when bounding box data is valid for all \&{truecorners} values */
-@d bounds_set 1
- /* |bbtype| value when bounding box data is for \&{truecorners}${}\le 0$ */
-@d bounds_unset 2
- /* |bbtype| value when bounding box data is for \&{truecorners}${}>0$ */
-
-@c
-void mp_init_bbox (MP mp,pointer h) {
- /* Initialize the bounding box information in edge structure |h| */
- bblast(h)=dummy_loc(h);
- bbtype(h)=no_bounds;
- minx_val(h)=el_gordo;
- miny_val(h)=el_gordo;
- maxx_val(h)=-el_gordo;
- maxy_val(h)=-el_gordo;
-}
-
-@ The only other entries in an edge header are a reference count in the first
-word and a pointer to the tail of the object list in the last word.
-
-@d obj_tail(A) info((A)+7) /* points to the last entry in the object list */
-@d edge_header_size 8
-
-@c
-void mp_init_edges (MP mp,pointer h) {
- /* initialize an edge header to null values */
- dash_list(h)=null_dash;
- obj_tail(h)=dummy_loc(h);
- link(dummy_loc(h))=null;
- ref_count(h)=null;
- mp_init_bbox(mp, h);
-}
-
-@ Here is how edge structures are deleted. The process can be recursive because
-of the need to dereference edge structures that are used as dash patterns.
-@^recursion@>
-
-@d add_edge_ref(A) incr(ref_count(A))
-@d delete_edge_ref(A) {
- if ( ref_count((A))==null )
- mp_toss_edges(mp, A);
- else
- decr(ref_count(A));
- }
-
-@<Declare the recycling subroutines@>=
-void mp_flush_dash_list (MP mp,pointer h);
-pointer mp_toss_gr_object (MP mp,pointer p) ;
-void mp_toss_edges (MP mp,pointer h) ;
-
-@ @c void mp_toss_edges (MP mp,pointer h) {
- pointer p,q; /* pointers that scan the list being recycled */
- pointer r; /* an edge structure that object |p| refers to */
- mp_flush_dash_list(mp, h);
- q=link(dummy_loc(h));
- while ( (q!=null) ) {
- p=q; q=link(q);
- r=mp_toss_gr_object(mp, p);
- if ( r!=null ) delete_edge_ref(r);
- }
- mp_free_node(mp, h,edge_header_size);
-}
-void mp_flush_dash_list (MP mp,pointer h) {
- pointer p,q; /* pointers that scan the list being recycled */
- q=dash_list(h);
- while ( q!=null_dash ) {
- p=q; q=link(q);
- mp_free_node(mp, p,dash_node_size);
- }
- dash_list(h)=null_dash;
-}
-pointer mp_toss_gr_object (MP mp,pointer p) {
- /* returns an edge structure that needs to be dereferenced */
- pointer e; /* the edge structure to return */
- e=null;
- @<Prepare to recycle graphical object |p|@>;
- mp_free_node(mp, p,mp->gr_object_size[type(p)]);
- return e;
-}
-
-@ @<Prepare to recycle graphical object |p|@>=
-switch (type(p)) {
-case mp_fill_code:
- mp_toss_knot_list(mp, path_p(p));
- if ( pen_p(p)!=null ) mp_toss_knot_list(mp, pen_p(p));
- if ( pre_script(p)!=null ) delete_str_ref(pre_script(p));
- if ( post_script(p)!=null ) delete_str_ref(post_script(p));
- break;
-case mp_stroked_code:
- mp_toss_knot_list(mp, path_p(p));
- if ( pen_p(p)!=null ) mp_toss_knot_list(mp, pen_p(p));
- if ( pre_script(p)!=null ) delete_str_ref(pre_script(p));
- if ( post_script(p)!=null ) delete_str_ref(post_script(p));
- e=dash_p(p);
- break;
-case mp_text_code:
- delete_str_ref(text_p(p));
- if ( pre_script(p)!=null ) delete_str_ref(pre_script(p));
- if ( post_script(p)!=null ) delete_str_ref(post_script(p));
- break;
-case mp_start_clip_code:
-case mp_start_bounds_code:
- mp_toss_knot_list(mp, path_p(p));
- break;
-case mp_stop_clip_code:
-case mp_stop_bounds_code:
- break;
-} /* there are no other cases */
-
-@ If we use |add_edge_ref| to ``copy'' edge structures, the real copying needs
-to be done before making a significant change to an edge structure. Much of
-the work is done in a separate routine |copy_objects| that copies a list of
-graphical objects into a new edge header.
-
-@c @<Declare a function called |copy_objects|@>
-pointer mp_private_edges (MP mp,pointer h) {
- /* make a private copy of the edge structure headed by |h| */
- pointer hh; /* the edge header for the new copy */
- pointer p,pp; /* pointers for copying the dash list */
- if ( ref_count(h)==null ) {
- return h;
- } else {
- decr(ref_count(h));
- hh=mp_copy_objects(mp, link(dummy_loc(h)),null);
- @<Copy the dash list from |h| to |hh|@>;
- @<Copy the bounding box information from |h| to |hh| and make |bblast(hh)|
- point into the new object list@>;
- return hh;
- }
-}
-
-@ Here we use the fact that |dash_list(hh)=link(hh)|.
-@^data structure assumptions@>
-
-@<Copy the dash list from |h| to |hh|@>=
-pp=hh; p=dash_list(h);
-while ( (p!=null_dash) ) {
- link(pp)=mp_get_node(mp, dash_node_size);
- pp=link(pp);
- start_x(pp)=start_x(p);
- stop_x(pp)=stop_x(p);
- p=link(p);
-}
-link(pp)=null_dash;
-dash_y(hh)=dash_y(h)
-
-
-@ |h| is an edge structure
-
-@c
-mp_dash_object *mp_export_dashes (MP mp, pointer q, scaled *w) {
- mp_dash_object *d;
- pointer p, h;
- scaled scf; /* scale factor */
- scaled *dashes = NULL;
- int num_dashes = 1;
- h = dash_p(q);
- if (h==null || dash_list(h)==null_dash)
- return NULL;
- p = dash_list(h);
- scf=mp_get_pen_scale(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 = mp_xmalloc(mp,1,sizeof(mp_dash_object));
- start_x(null_dash)=start_x(p)+dash_y(h);
- while (p != null_dash) {
- dashes = mp_xrealloc(mp, dashes, num_dashes+2, sizeof(scaled));
- dashes[(num_dashes-1)] =
- mp_take_scaled(mp,(stop_x(p)-start_x(p)),scf);
- dashes[(num_dashes)] =
- mp_take_scaled(mp,(start_x(link(p))-stop_x(p)),scf);
- dashes[(num_dashes+1)] = -1; /* terminus */
- num_dashes+=2;
- p=link(p);
- }
- d->array_field = dashes;
- d->offset_field =
- 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=link(p); pp=link(pp);
-}
-bblast(hh)=pp
-
-@ Here is the promised routine for copying graphical objects into a new edge
-structure. It starts copying at object~|p| and stops just before object~|q|.
-If |q| is null, it copies the entire sublist headed at |p|. The resulting edge
-structure requires further initialization by |init_bbox|.
-
-@<Declare a function called |copy_objects|@>=
-pointer mp_copy_objects (MP mp, pointer p, pointer q) {
- pointer hh; /* the new edge header */
- pointer pp; /* the last newly copied object */
- small_number k; /* temporary register */
- hh=mp_get_node(mp, edge_header_size);
- dash_list(hh)=null_dash;
- ref_count(hh)=null;
- pp=dummy_loc(hh);
- while ( (p!=q) ) {
- @<Make |link(pp)| point to a copy of object |p|, and update |p| and |pp|@>;
- }
- obj_tail(hh)=pp;
- link(pp)=null;
- return hh;
-}
-
-@ @<Make |link(pp)| point to a copy of object |p|, and update |p| and |pp|@>=
-{ k=mp->gr_object_size[type(p)];
- link(pp)=mp_get_node(mp, k);
- pp=link(pp);
- while ( (k>0) ) { decr(k); mp->mem[pp+k]=mp->mem[p+k]; };
- @<Fix anything in graphical object |pp| that should differ from the
- corresponding field in |p|@>;
- p=link(p);
-}
-
-@ @<Fix anything in graphical object |pp| that should differ from the...@>=
-switch (type(p)) {
-case mp_start_clip_code:
-case mp_start_bounds_code:
- path_p(pp)=mp_copy_path(mp, path_p(p));
- break;
-case mp_fill_code:
- path_p(pp)=mp_copy_path(mp, path_p(p));
- if ( pre_script(p)!=null ) add_str_ref(pre_script(p));
- if ( post_script(p)!=null ) add_str_ref(post_script(p));
- if ( pen_p(p)!=null ) pen_p(pp)=copy_pen(pen_p(p));
- break;
-case mp_stroked_code:
- if ( pre_script(p)!=null ) add_str_ref(pre_script(p));
- if ( post_script(p)!=null ) add_str_ref(post_script(p));
- path_p(pp)=mp_copy_path(mp, path_p(p));
- pen_p(pp)=copy_pen(pen_p(p));
- if ( dash_p(p)!=null ) add_edge_ref(dash_p(pp));
- break;
-case mp_text_code:
- if ( pre_script(p)!=null ) add_str_ref(pre_script(p));
- if ( post_script(p)!=null ) add_str_ref(post_script(p));
- add_str_ref(text_p(pp));
- break;
-case mp_stop_clip_code:
-case mp_stop_bounds_code:
- break;
-} /* there are no other cases */
-
-@ Here is one way to find an acceptable value for the second argument to
-|copy_objects|. Given a non-null graphical object list, |skip_1component|
-skips past one picture component, where a ``picture component'' is a single
-graphical object, or a start bounds or start clip object and everything up
-through the matching stop bounds or stop clip object. The macro version avoids
-procedure call overhead and error handling: |skip_component(p)(e)| advances |p|
-unless |p| points to a stop bounds or stop clip node, in which case it executes
-|e| instead.
-
-@d skip_component(A)
- if ( ! is_start_or_stop((A)) ) (A)=link((A));
- else if ( ! is_stop((A)) ) (A)=mp_skip_1component(mp, (A));
- else
-
-@c
-pointer mp_skip_1component (MP mp,pointer p) {
- integer lev; /* current nesting level */
- lev=0;
- do {
- if ( is_start_or_stop(p) ) {
- if ( is_stop(p) ) decr(lev); else incr(lev);
- }
- p=link(p);
- } while (lev!=0);
- return p;
-}
-
-@ Here is a diagnostic routine for printing an edge structure in symbolic form.
-
-@<Declare subroutines for printing expressions@>=
-@<Declare subroutines needed by |print_edges|@>
-void mp_print_edges (MP mp,pointer h, const char *s, boolean nuline) {
- pointer p; /* a graphical object to be printed */
- pointer hh,pp; /* temporary pointers */
- scaled scf; /* a scale factor for the dash pattern */
- boolean ok_to_dash; /* |false| for polygonal pen strokes */
- mp_print_diagnostic(mp, "Edge structure",s,nuline);
- p=dummy_loc(h);
- while ( link(p)!=null ) {
- p=link(p);
- mp_print_ln(mp);
- switch (type(p)) {
- @<Cases for printing graphical object node |p|@>;
- default:
- mp_print(mp, "[unknown object type!]");
- break;
- }
- }
- mp_print_nl(mp, "End edges");
- if ( p!=obj_tail(h) ) mp_print(mp, "?");
-@.End edges?@>
- mp_end_diagnostic(mp, true);
-}
-
-@ @<Cases for printing graphical object node |p|@>=
-case mp_fill_code:
- mp_print(mp, "Filled contour ");
- mp_print_obj_color(mp, p);
- mp_print_char(mp, ':'); mp_print_ln(mp);
- mp_pr_path(mp, path_p(p)); mp_print_ln(mp);
- if ( (pen_p(p)!=null) ) {
- @<Print join type for graphical object |p|@>;
- mp_print(mp, " with pen"); mp_print_ln(mp);
- mp_pr_pen(mp, pen_p(p));
- }
- break;
-
-@ @<Print join type for graphical object |p|@>=
-switch (ljoin_val(p)) {
-case 0:
- mp_print(mp, "mitered joins limited ");
- mp_print_scaled(mp, miterlim_val(p));
- break;
-case 1:
- mp_print(mp, "round joins");
- break;
-case 2:
- mp_print(mp, "beveled joins");
- break;
-default:
- mp_print(mp, "?? joins");
-@.??@>
- break;
-}
-
-@ For stroked nodes, we need to print |lcap_val(p)| as well.
-
-@<Print join and cap types for stroked node |p|@>=
-switch (lcap_val(p)) {
-case 0:mp_print(mp, "butt"); break;
-case 1:mp_print(mp, "round"); break;
-case 2:mp_print(mp, "square"); break;
-default: mp_print(mp, "??"); break;
-@.??@>
-}
-mp_print(mp, " ends, ");
-@<Print join type for graphical object |p|@>
-
-@ Here is a routine that prints the color of a graphical object if it isn't
-black (the default color).
-
-@<Declare subroutines needed by |print_edges|@>=
-@<Declare a procedure called |print_compact_node|@>
-void mp_print_obj_color (MP mp,pointer p) {
- if ( color_model(p)==mp_grey_model ) {
- if ( grey_val(p)>0 ) {
- mp_print(mp, "greyed ");
- mp_print_compact_node(mp, obj_grey_loc(p),1);
- };
- } else if ( color_model(p)==mp_cmyk_model ) {
- if ( (cyan_val(p)>0) || (magenta_val(p)>0) ||
- (yellow_val(p)>0) || (black_val(p)>0) ) {
- mp_print(mp, "processcolored ");
- mp_print_compact_node(mp, obj_cyan_loc(p),4);
- };
- } else if ( color_model(p)==mp_rgb_model ) {
- if ( (red_val(p)>0) || (green_val(p)>0) || (blue_val(p)>0) ) {
- mp_print(mp, "colored ");
- mp_print_compact_node(mp, obj_red_loc(p),3);
- };
- }
-}
-
-@ We also need a procedure for printing consecutive scaled values as if they
-were a known big node.
-
-@<Declare a procedure called |print_compact_node|@>=
-void mp_print_compact_node (MP mp,pointer p, small_number k) {
- pointer q; /* last location to print */
- q=p+k-1;
- mp_print_char(mp, '(');
- while ( p<=q ){
- mp_print_scaled(mp, mp->mem[p].sc);
- if ( p<q ) mp_print_char(mp, ',');
- incr(p);
- }
- mp_print_char(mp, ')');
-}
-
-@ @<Cases for printing graphical object node |p|@>=
-case mp_stroked_code:
- mp_print(mp, "Filled pen stroke ");
- mp_print_obj_color(mp, p);
- mp_print_char(mp, ':'); mp_print_ln(mp);
- mp_pr_path(mp, path_p(p));
- if ( dash_p(p)!=null ) {
- mp_print_nl(mp, "dashed (");
- @<Finish printing the dash pattern that |p| refers to@>;
- }
- mp_print_ln(mp);
- @<Print join and cap types for stroked node |p|@>;
- mp_print(mp, " with pen"); mp_print_ln(mp);
- if ( pen_p(p)==null ) mp_print(mp, "???"); /* shouldn't happen */
-@.???@>
- else mp_pr_pen(mp, pen_p(p));
- break;
-
-@ Normally, the |dash_list| field in an edge header is set to |null_dash|
-when it is not known to define a suitable dash pattern. This is disallowed
-here because the |dash_p| field should never point to such an edge header.
-Note that memory is allocated for |start_x(null_dash)| and we are free to
-give it any convenient value.
-
-@<Finish printing the dash pattern that |p| refers to@>=
-ok_to_dash=pen_is_elliptical(pen_p(p));
-if ( ! ok_to_dash ) scf=unity; else scf=dash_scale(p);
-hh=dash_p(p);
-pp=dash_list(hh);
-if ( (pp==null_dash) || (dash_y(hh)<0) ) {
- mp_print(mp, " ??");
-} else { start_x(null_dash)=start_x(pp)+dash_y(hh);
- while ( pp!=null_dash ) {
- mp_print(mp, "on ");
- mp_print_scaled(mp, mp_take_scaled(mp, stop_x(pp)-start_x(pp),scf));
- mp_print(mp, " off ");
- mp_print_scaled(mp, mp_take_scaled(mp, start_x(link(pp))-stop_x(pp),scf));
- pp = link(pp);
- if ( pp!=null_dash ) mp_print_char(mp, ' ');
- }
- mp_print(mp, ") shifted ");
- mp_print_scaled(mp, -mp_take_scaled(mp, mp_dash_offset(mp, hh),scf));
- if ( ! ok_to_dash || (dash_y(hh)==0) ) mp_print(mp, " (this will be ignored)");
-}
-
-@ @<Declare subroutines needed by |print_edges|@>=
-scaled mp_dash_offset (MP mp,pointer h) {
- scaled x; /* the answer */
- if (dash_list(h)==null_dash || dash_y(h)<0) mp_confusion(mp, "dash0");
-@:this can't happen dash0}{\quad dash0@>
- if ( dash_y(h)==0 ) {
- x=0;
- } else {
- x=-(start_x(dash_list(h)) % dash_y(h));
- if ( x<0 ) x=x+dash_y(h);
- }
- return x;
-}
-
-@ @<Cases for printing graphical object node |p|@>=
-case mp_text_code:
- mp_print_char(mp, '"'); mp_print_str(mp,text_p(p));
- mp_print(mp, "\" infont \""); mp_print(mp, mp->font_name[font_n(p)]);
- mp_print_char(mp, '"'); mp_print_ln(mp);
- mp_print_obj_color(mp, p);
- mp_print(mp, "transformed ");
- mp_print_compact_node(mp, text_tx_loc(p),6);
- break;
-
-@ @<Cases for printing graphical object node |p|@>=
-case mp_start_clip_code:
- mp_print(mp, "clipping path:");
- mp_print_ln(mp);
- mp_pr_path(mp, path_p(p));
- break;
-case mp_stop_clip_code:
- mp_print(mp, "stop clipping");
- break;
-
-@ @<Cases for printing graphical object node |p|@>=
-case mp_start_bounds_code:
- mp_print(mp, "setbounds path:");
- mp_print_ln(mp);
- mp_pr_path(mp, path_p(p));
- break;
-case mp_stop_bounds_code:
- mp_print(mp, "end of setbounds");
- break;
-
-@ To initialize the |dash_list| field in an edge header~|h|, we need a
-subroutine that scans an edge structure and tries to interpret it as a dash
-pattern. This can only be done when there are no filled regions or clipping
-paths and all the pen strokes have the same color. The first step is to let
-$y_0$ be the initial $y$~coordinate of the first pen stroke. Then we implicitly
-project all the pen stroke paths onto the line $y=y_0$ and require that there
-be no retracing. If the resulting paths cover a range of $x$~coordinates of
-length $\Delta x$, we set |dash_y(h)| to the length of the dash pattern by
-finding the maximum of $\Delta x$ and the absolute value of~$y_0$.
-
-@c @<Declare a procedure called |x_retrace_error|@>
-pointer mp_make_dashes (MP mp,pointer h) { /* returns |h| or |null| */
- pointer p; /* this scans the stroked nodes in the object list */
- pointer p0; /* if not |null| this points to the first stroked node */
- pointer pp,qq,rr; /* pointers into |path_p(p)| */
- pointer d,dd; /* pointers used to create the dash list */
- scaled y0;
- @<Other local variables in |make_dashes|@>;
- y0=0; /* the initial $y$ coordinate */
- if ( dash_list(h)!=null_dash )
- return h;
- p0=null;
- p=link(dummy_loc(h));
- while ( p!=null ) {
- if ( type(p)!=mp_stroked_code ) {
- @<Compain that the edge structure contains a node of the wrong type
- and |goto not_found|@>;
- }
- pp=path_p(p);
- if ( p0==null ){ p0=p; y0=y_coord(pp); };
- @<Make |d| point to a new dash node created from stroke |p| and path |pp|
- or |goto not_found| if there is an error@>;
- @<Insert |d| into the dash list and |goto not_found| if there is an error@>;
- p=link(p);
- }
- if ( dash_list(h)==null_dash )
- goto NOT_FOUND; /* No error message */
- @<Scan |dash_list(h)| and deal with any dashes that are themselves dashed@>;
- @<Set |dash_y(h)| and merge the first and last dashes if necessary@>;
- return h;
-NOT_FOUND:
- @<Flush the dash list, recycle |h| and return |null|@>;
-}
-
-@ @<Compain that the edge structure contains a node of the wrong type...@>=
-{
-print_err("Picture is too complicated to use as a dash pattern");
-help3("When you say `dashed p', picture p should not contain any")
- ("text, filled regions, or clipping paths. This time it did")
- ("so I'll just make it a solid line instead.");
-mp_put_get_error(mp);
-goto NOT_FOUND;
-}
-
-@ A similar error occurs when monotonicity fails.
-
-@<Declare a procedure called |x_retrace_error|@>=
-void mp_x_retrace_error (MP mp) {
-print_err("Picture is too complicated to use as a dash pattern");
-help3("When you say `dashed p', every path in p should be monotone")
- ("in x and there must be no overlapping. This failed")
- ("so I'll just make it a solid line instead.");
-mp_put_get_error(mp);
-}
-
-@ We stash |p| in |info(d)| if |dash_p(p)<>0| so that subsequent processing can
-handle the case where the pen stroke |p| is itself dashed.
-
-@<Make |d| point to a new dash node created from stroke |p| and path...@>=
-@<Make sure |p| and |p0| are the same color and |goto not_found| if there is
- an error@>;
-rr=pp;
-if ( link(pp)!=pp ) {
- do {
- qq=rr; rr=link(rr);
- @<Check for retracing between knots |qq| and |rr| and |goto not_found|
- if there is a problem@>;
- } while (right_type(rr)!=mp_endpoint);
-}
-d=mp_get_node(mp, dash_node_size);
-if ( dash_p(p)==0 ) info(d)=0; else info(d)=p;
-if ( x_coord(pp)<x_coord(rr) ) {
- start_x(d)=x_coord(pp);
- stop_x(d)=x_coord(rr);
-} else {
- start_x(d)=x_coord(rr);
- stop_x(d)=x_coord(pp);
-}
-
-@ We also need to check for the case where the segment from |qq| to |rr| is
-monotone in $x$ but is reversed relative to the path from |pp| to |qq|.
-
-@<Check for retracing between knots |qq| and |rr| and |goto not_found|...@>=
-x0=x_coord(qq);
-x1=right_x(qq);
-x2=left_x(rr);
-x3=x_coord(rr);
-if ( (x0>x1) || (x1>x2) || (x2>x3) ) {
- if ( (x0<x1) || (x1<x2) || (x2<x3) ) {
- if ( mp_ab_vs_cd(mp, x2-x1,x2-x1,x1-x0,x3-x2)>0 ) {
- mp_x_retrace_error(mp); goto NOT_FOUND;
- }
- }
-}
-if ( (x_coord(pp)>x0) || (x0>x3) ) {
- if ( (x_coord(pp)<x0) || (x0<x3) ) {
- mp_x_retrace_error(mp); goto NOT_FOUND;
- }
-}
-
-@ @<Other local variables in |make_dashes|@>=
- scaled x0,x1,x2,x3; /* $x$ coordinates of the segment from |qq| to |rr| */
-
-@ @<Make sure |p| and |p0| are the same color and |goto not_found|...@>=
-if ( (red_val(p)!=red_val(p0)) || (black_val(p)!=black_val(p0)) ||
- (green_val(p)!=green_val(p0)) || (blue_val(p)!=blue_val(p0)) ) {
- print_err("Picture is too complicated to use as a dash pattern");
- help3("When you say `dashed p', everything in picture p should")
- ("be the same color. I can\'t handle your color changes")
- ("so I'll just make it a solid line instead.");
- mp_put_get_error(mp);
- goto NOT_FOUND;
-}
-
-@ @<Insert |d| into the dash list and |goto not_found| if there is an error@>=
-start_x(null_dash)=stop_x(d);
-dd=h; /* this makes |link(dd)=dash_list(h)| */
-while ( start_x(link(dd))<stop_x(d) )
- dd=link(dd);
-if ( dd!=h ) {
- if ( (stop_x(dd)>start_x(d)) )
- { mp_x_retrace_error(mp); goto NOT_FOUND; };
-}
-link(d)=link(dd);
-link(dd)=d
-
-@ @<Set |dash_y(h)| and merge the first and last dashes if necessary@>=
-d=dash_list(h);
-while ( (link(d)!=null_dash) )
- d=link(d);
-dd=dash_list(h);
-dash_y(h)=stop_x(d)-start_x(dd);
-if ( abs(y0)>dash_y(h) ) {
- dash_y(h)=abs(y0);
-} else if ( d!=dd ) {
- dash_list(h)=link(dd);
- stop_x(d)=stop_x(dd)+dash_y(h);
- mp_free_node(mp, dd,dash_node_size);
-}
-
-@ We get here when the argument is a null picture or when there is an error.
-Recovering from an error involves making |dash_list(h)| empty to indicate
-that |h| is not known to be a valid dash pattern. We also dereference |h|
-since it is not being used for the return value.
-
-@<Flush the dash list, recycle |h| and return |null|@>=
-mp_flush_dash_list(mp, h);
-delete_edge_ref(h);
-return null
-
-@ Having carefully saved the dashed stroked nodes in the
-corresponding dash nodes, we must be prepared to break up these dashes into
-smaller dashes.
-
-@<Scan |dash_list(h)| and deal with any dashes that are themselves dashed@>=
-d=h; /* now |link(d)=dash_list(h)| */
-while ( link(d)!=null_dash ) {
- ds=info(link(d));
- if ( ds==null ) {
- d=link(d);
- } else {
- hh=dash_p(ds);
- hsf=dash_scale(ds);
- if ( (hh==null) ) mp_confusion(mp, "dash1");
-@:this can't happen dash0}{\quad dash1@>
- if ( dash_y(hh)==0 ) {
- d=link(d);
- } else {
- if ( dash_list(hh)==null ) mp_confusion(mp, "dash1");
-@:this can't happen dash0}{\quad dash1@>
- @<Replace |link(d)| by a dashed version as determined by edge header
- |hh| and scale factor |ds|@>;
- }
- }
-}
-
-@ @<Other local variables in |make_dashes|@>=
-pointer dln; /* |link(d)| */
-pointer hh; /* an edge header that tells how to break up |dln| */
-scaled hsf; /* the dash pattern from |hh| gets scaled by this */
-pointer ds; /* the stroked node from which |hh| and |hsf| are derived */
-scaled xoff; /* added to $x$ values in |dash_list(hh)| to match |dln| */
-
-@ @<Replace |link(d)| by a dashed version as determined by edge header...@>=
-dln=link(d);
-dd=dash_list(hh);
-xoff=start_x(dln)-mp_take_scaled(mp, hsf,start_x(dd))-
- mp_take_scaled(mp, hsf,mp_dash_offset(mp, hh));
-start_x(null_dash)=mp_take_scaled(mp, hsf,start_x(dd))
- +mp_take_scaled(mp, hsf,dash_y(hh));
-stop_x(null_dash)=start_x(null_dash);
-@<Advance |dd| until finding the first dash that overlaps |dln| when
- offset by |xoff|@>;
-while ( start_x(dln)<=stop_x(dln) ) {
- @<If |dd| has `fallen off the end', back up to the beginning and fix |xoff|@>;
- @<Insert a dash between |d| and |dln| for the overlap with the offset version
- of |dd|@>;
- dd=link(dd);
- start_x(dln)=xoff+mp_take_scaled(mp, hsf,start_x(dd));
-}
-link(d)=link(dln);
-mp_free_node(mp, dln,dash_node_size)
-
-@ The name of this module is a bit of a lie because we just find the
-first |dd| where |take_scaled (hsf, stop_x(dd))| is large enough to make an
-overlap possible. It could be that the unoffset version of dash |dln| falls
-in the gap between |dd| and its predecessor.
-
-@<Advance |dd| until finding the first dash that overlaps |dln| when...@>=
-while ( xoff+mp_take_scaled(mp, hsf,stop_x(dd))<start_x(dln) ) {
- dd=link(dd);
-}
-
-@ @<If |dd| has `fallen off the end', back up to the beginning and fix...@>=
-if ( dd==null_dash ) {
- dd=dash_list(hh);
- xoff=xoff+mp_take_scaled(mp, hsf,dash_y(hh));
-}
-
-@ At this point we already know that
-|start_x(dln)<=xoff+take_scaled(hsf,stop_x(dd))|.
-
-@<Insert a dash between |d| and |dln| for the overlap with the offset...@>=
-if ( (xoff+mp_take_scaled(mp, hsf,start_x(dd)))<=stop_x(dln) ) {
- link(d)=mp_get_node(mp, dash_node_size);
- d=link(d);
- link(d)=dln;
- if ( start_x(dln)>(xoff+mp_take_scaled(mp, hsf,start_x(dd))))
- start_x(d)=start_x(dln);
- else
- start_x(d)=xoff+mp_take_scaled(mp, hsf,start_x(dd));
- if ( stop_x(dln)<(xoff+mp_take_scaled(mp, hsf,stop_x(dd))))
- stop_x(d)=stop_x(dln);
- else
- stop_x(d)=xoff+mp_take_scaled(mp, hsf,stop_x(dd));
-}
-
-@ The next major task is to update the bounding box information in an edge
-header~|h|. This is done via a procedure |adjust_bbox| that enlarges an edge
-header's bounding box to accommodate the box computed by |path_bbox| or
-|pen_bbox|. (This is stored in global variables |minx|, |miny|, |maxx|, and
-|maxy|.)
-
-@c void mp_adjust_bbox (MP mp,pointer h) {
- if ( minx<minx_val(h) ) minx_val(h)=minx;
- if ( miny<miny_val(h) ) miny_val(h)=miny;
- if ( maxx>maxx_val(h) ) maxx_val(h)=maxx;
- if ( maxy>maxy_val(h) ) maxy_val(h)=maxy;
-}
-
-@ Here is a special routine for updating the bounding box information in
-edge header~|h| to account for the squared-off ends of a non-cyclic path~|p|
-that is to be stroked with the pen~|pp|.
-
-@c void mp_box_ends (MP mp, pointer p, pointer pp, pointer h) {
- pointer q; /* a knot node adjacent to knot |p| */
- fraction dx,dy; /* a unit vector in the direction out of the path at~|p| */
- scaled d; /* a factor for adjusting the length of |(dx,dy)| */
- scaled z; /* a coordinate being tested against the bounding box */
- scaled xx,yy; /* the extreme pen vertex in the |(dx,dy)| direction */
- integer i; /* a loop counter */
- if ( right_type(p)!=mp_endpoint ) {
- q=link(p);
- while (1) {
- @<Make |(dx,dy)| the final direction for the path segment from
- |q| to~|p|; set~|d|@>;
- d=mp_pyth_add(mp, dx,dy);
- if ( d>0 ) {
- @<Normalize the direction |(dx,dy)| and find the pen offset |(xx,yy)|@>;
- for (i=1;i<= 2;i++) {
- @<Use |(dx,dy)| to generate a vertex of the square end cap and
- update the bounding box to accommodate it@>;
- dx=-dx; dy=-dy;
- }
- }
- if ( right_type(p)==mp_endpoint ) {
- return;
- } else {
- @<Advance |p| to the end of the path and make |q| the previous knot@>;
- }
- }
- }
-}
-
-@ @<Make |(dx,dy)| the final direction for the path segment from...@>=
-if ( q==link(p) ) {
- dx=x_coord(p)-right_x(p);
- dy=y_coord(p)-right_y(p);
- if ( (dx==0)&&(dy==0) ) {
- dx=x_coord(p)-left_x(q);
- dy=y_coord(p)-left_y(q);
- }
-} else {
- dx=x_coord(p)-left_x(p);
- dy=y_coord(p)-left_y(p);
- if ( (dx==0)&&(dy==0) ) {
- dx=x_coord(p)-right_x(q);
- dy=y_coord(p)-right_y(q);
- }
-}
-dx=x_coord(p)-x_coord(q);
-dy=y_coord(p)-y_coord(q)
-
-@ @<Normalize the direction |(dx,dy)| and find the pen offset |(xx,yy)|@>=
-dx=mp_make_fraction(mp, dx,d);
-dy=mp_make_fraction(mp, dy,d);
-mp_find_offset(mp, -dy,dx,pp);
-xx=mp->cur_x; yy=mp->cur_y
-
-@ @<Use |(dx,dy)| to generate a vertex of the square end cap and...@>=
-mp_find_offset(mp, dx,dy,pp);
-d=mp_take_fraction(mp, xx-mp->cur_x,dx)+mp_take_fraction(mp, yy-mp->cur_y,dy);
-if ( ((d<0)&&(i==1)) || ((d>0)&&(i==2)))
- mp_confusion(mp, "box_ends");
-@:this can't happen box ends}{\quad\\{box\_ends}@>
-z=x_coord(p)+mp->cur_x+mp_take_fraction(mp, d,dx);
-if ( z<minx_val(h) ) minx_val(h)=z;
-if ( z>maxx_val(h) ) maxx_val(h)=z;
-z=y_coord(p)+mp->cur_y+mp_take_fraction(mp, d,dy);
-if ( z<miny_val(h) ) miny_val(h)=z;
-if ( z>maxy_val(h) ) maxy_val(h)=z
-
-@ @<Advance |p| to the end of the path and make |q| the previous knot@>=
-do {
- q=p;
- p=link(p);
-} while (right_type(p)!=mp_endpoint)
-
-@ The major difficulty in finding the bounding box of an edge structure is the
-effect of clipping paths. We treat them conservatively by only clipping to the
-clipping path's bounding box, but this still
-requires recursive calls to |set_bbox| in order to find the bounding box of
-@^recursion@>
-the objects to be clipped. Such calls are distinguished by the fact that the
-boolean parameter |top_level| is false.
-
-@c void mp_set_bbox (MP mp,pointer h, boolean top_level) {
- pointer p; /* a graphical object being considered */
- scaled sminx,sminy,smaxx,smaxy;
- /* for saving the bounding box during recursive calls */
- scaled x0,x1,y0,y1; /* temporary registers */
- integer lev; /* nesting level for |mp_start_bounds_code| nodes */
- @<Wipe out any existing bounding box information if |bbtype(h)| is
- incompatible with |internal[mp_true_corners]|@>;
- while ( link(bblast(h))!=null ) {
- p=link(bblast(h));
- bblast(h)=p;
- switch (type(p)) {
- case mp_stop_clip_code:
- if ( top_level ) mp_confusion(mp, "bbox"); else return;
-@:this can't happen bbox}{\quad bbox@>
- break;
- @<Other cases for updating the bounding box based on the type of object |p|@>;
- } /* all cases are enumerated above */
- }
- if ( ! top_level ) mp_confusion(mp, "bbox");
-}
-
-@ @<Internal library declarations@>=
-void mp_set_bbox (MP mp,pointer h, boolean top_level);
-
-@ @<Wipe out any existing bounding box information if |bbtype(h)| is...@>=
-switch (bbtype(h)) {
-case no_bounds:
- break;
-case bounds_set:
- if ( mp->internal[mp_true_corners]>0 ) mp_init_bbox(mp, h);
- break;
-case bounds_unset:
- if ( mp->internal[mp_true_corners]<=0 ) mp_init_bbox(mp, h);
- break;
-} /* there are no other cases */
-
-@ @<Other cases for updating the bounding box...@>=
-case mp_fill_code:
- mp_path_bbox(mp, path_p(p));
- if ( pen_p(p)!=null ) {
- x0=minx; y0=miny;
- x1=maxx; y1=maxy;
- mp_pen_bbox(mp, pen_p(p));
- minx=minx+x0;
- miny=miny+y0;
- maxx=maxx+x1;
- maxy=maxy+y1;
- }
- mp_adjust_bbox(mp, h);
- break;
-
-@ @<Other cases for updating the bounding box...@>=
-case mp_start_bounds_code:
- if ( mp->internal[mp_true_corners]>0 ) {
- bbtype(h)=bounds_unset;
- } else {
- bbtype(h)=bounds_set;
- mp_path_bbox(mp, path_p(p));
- mp_adjust_bbox(mp, h);
- @<Scan to the matching |mp_stop_bounds_code| node and update |p| and
- |bblast(h)|@>;
- }
- break;
-case mp_stop_bounds_code:
- if ( mp->internal[mp_true_corners]<=0 ) mp_confusion(mp, "bbox2");
-@:this can't happen bbox2}{\quad bbox2@>
- break;
-
-@ @<Scan to the matching |mp_stop_bounds_code| node and update |p| and...@>=
-lev=1;
-while ( lev!=0 ) {
- if ( link(p)==null ) mp_confusion(mp, "bbox2");
-@:this can't happen bbox2}{\quad bbox2@>
- p=link(p);
- if ( type(p)==mp_start_bounds_code ) incr(lev);
- else if ( type(p)==mp_stop_bounds_code ) decr(lev);
-}
-bblast(h)=p
-
-@ It saves a lot of grief here to be slightly conservative and not account for
-omitted parts of dashed lines. We also don't worry about the material omitted
-when using butt end caps. The basic computation is for round end caps and
-|box_ends| augments it for square end caps.
-
-@<Other cases for updating the bounding box...@>=
-case mp_stroked_code:
- mp_path_bbox(mp, path_p(p));
- x0=minx; y0=miny;
- x1=maxx; y1=maxy;
- mp_pen_bbox(mp, pen_p(p));
- minx=minx+x0;
- miny=miny+y0;
- maxx=maxx+x1;
- maxy=maxy+y1;
- mp_adjust_bbox(mp, h);
- if ( (left_type(path_p(p))==mp_endpoint)&&(lcap_val(p)==2) )
- mp_box_ends(mp, path_p(p), pen_p(p), h);
- break;
-
-@ The height width and depth information stored in a text node determines a
-rectangle that needs to be transformed according to the transformation
-parameters stored in the text node.
-
-@<Other cases for updating the bounding box...@>=
-case mp_text_code:
- x1=mp_take_scaled(mp, txx_val(p),width_val(p));
- y0=mp_take_scaled(mp, txy_val(p),-depth_val(p));
- y1=mp_take_scaled(mp, txy_val(p),height_val(p));
- minx=tx_val(p);
- maxx=minx;
- if ( y0<y1 ) { minx=minx+y0; maxx=maxx+y1; }
- else { minx=minx+y1; maxx=maxx+y0; }
- if ( x1<0 ) minx=minx+x1; else maxx=maxx+x1;
- x1=mp_take_scaled(mp, tyx_val(p),width_val(p));
- y0=mp_take_scaled(mp, tyy_val(p),-depth_val(p));
- y1=mp_take_scaled(mp, tyy_val(p),height_val(p));
- miny=ty_val(p);
- maxy=miny;
- if ( y0<y1 ) { miny=miny+y0; maxy=maxy+y1; }
- else { miny=miny+y1; maxy=maxy+y0; }
- if ( x1<0 ) miny=miny+x1; else maxy=maxy+x1;
- mp_adjust_bbox(mp, h);
- break;
-
-@ This case involves a recursive call that advances |bblast(h)| to the node of
-type |mp_stop_clip_code| that matches |p|.
-
-@<Other cases for updating the bounding box...@>=
-case mp_start_clip_code:
- mp_path_bbox(mp, path_p(p));
- x0=minx; y0=miny;
- x1=maxx; y1=maxy;
- sminx=minx_val(h); sminy=miny_val(h);
- smaxx=maxx_val(h); smaxy=maxy_val(h);
- @<Reinitialize the bounding box in header |h| and call |set_bbox| recursively
- starting at |link(p)|@>;
- @<Clip the bounding box in |h| to the rectangle given by |x0|, |x1|,
- |y0|, |y1|@>;
- minx=sminx; miny=sminy;
- maxx=smaxx; maxy=smaxy;
- mp_adjust_bbox(mp, h);
- break;
-
-@ @<Reinitialize the bounding box in header |h| and call |set_bbox|...@>=
-minx_val(h)=el_gordo;
-miny_val(h)=el_gordo;
-maxx_val(h)=-el_gordo;
-maxy_val(h)=-el_gordo;
-mp_set_bbox(mp, h,false)
-
-@ @<Clip the bounding box in |h| to the rectangle given by |x0|, |x1|,...@>=
-if ( minx_val(h)<x0 ) minx_val(h)=x0;
-if ( miny_val(h)<y0 ) miny_val(h)=y0;
-if ( maxx_val(h)>x1 ) maxx_val(h)=x1;
-if ( maxy_val(h)>y1 ) maxy_val(h)=y1
-
-@* \[22] Finding an envelope.
-When \MP\ has a path and a polygonal pen, it needs to express the desired
-shape in terms of things \ps\ can understand. The present task is to compute
-a new path that describes the region to be filled. It is convenient to
-define this as a two step process where the first step is determining what
-offset to use for each segment of the path.
-
-@ Given a pointer |c| to a cyclic path,
-and a pointer~|h| to the first knot of a pen polygon,
-the |offset_prep| routine changes the path into cubics that are
-associated with particular pen offsets. Thus if the cubic between |p|
-and~|q| is associated with the |k|th offset and the cubic between |q| and~|r|
-has offset |l| then |info(q)=zero_off+l-k|. (The constant |zero_off| is added
-to because |l-k| could be negative.)
-
-After overwriting the type information with offset differences, we no longer
-have a true path so we refer to the knot list returned by |offset_prep| as an
-``envelope spec.''
-@^envelope spec@>
-Since an envelope spec only determines relative changes in pen offsets,
-|offset_prep| sets a global variable |spec_offset| to the relative change from
-|h| to the first offset.
-
-@d zero_off 16384 /* added to offset changes to make them positive */
-
-@<Glob...@>=
-integer spec_offset; /* number of pen edges between |h| and the initial offset */
-
-@ @c @<Declare subroutines needed by |offset_prep|@>
-pointer mp_offset_prep (MP mp,pointer c, pointer h) {
- halfword n; /* the number of vertices in the pen polygon */
- pointer c0,p,q,q0,r,w, ww; /* for list manipulation */
- integer k_needed; /* amount to be added to |info(p)| when it is computed */
- pointer w0; /* a pointer to pen offset to use just before |p| */
- scaled dxin,dyin; /* the direction into knot |p| */
- integer turn_amt; /* change in pen offsets for the current cubic */
- @<Other local variables for |offset_prep|@>;
- dx0=0; dy0=0;
- @<Initialize the pen size~|n|@>;
- @<Initialize the incoming direction and pen offset at |c|@>;
- p=c; c0=c; k_needed=0;
- do {
- q=link(p);
- @<Split the cubic between |p| and |q|, if necessary, into cubics
- associated with single offsets, after which |q| should
- point to the end of the final such cubic@>;
- NOT_FOUND:
- @<Advance |p| to node |q|, removing any ``dead'' cubics that
- might have been introduced by the splitting process@>;
- } while (q!=c);
- @<Fix the offset change in |info(c)| and set |c| to the return value of
- |offset_prep|@>;
- return c;
-}
-
-@ We shall want to keep track of where certain knots on the cyclic path
-wind up in the envelope spec. It doesn't suffice just to keep pointers to
-knot nodes because some nodes are deleted while removing dead cubics. Thus
-|offset_prep| updates the following pointers
-
-@<Glob...@>=
-pointer spec_p1;
-pointer spec_p2; /* pointers to distinguished knots */
-
-@ @<Set init...@>=
-mp->spec_p1=null; mp->spec_p2=null;
-
-@ @<Initialize the pen size~|n|@>=
-n=0; p=h;
-do {
- incr(n);
- p=link(p);
-} while (p!=h)
-
-@ Since the true incoming direction isn't known yet, we just pick a direction
-consistent with the pen offset~|h|. If this is wrong, it can be corrected
-later.
-
-@<Initialize the incoming direction and pen offset at |c|@>=
-dxin=x_coord(link(h))-x_coord(knil(h));
-dyin=y_coord(link(h))-y_coord(knil(h));
-if ( (dxin==0)&&(dyin==0) ) {
- dxin=y_coord(knil(h))-y_coord(h);
- dyin=x_coord(h)-x_coord(knil(h));
-}
-w0=h
-
-@ We must be careful not to remove the only cubic in a cycle.
-
-But we must also be careful for another reason. If the user-supplied
-path starts with a set of degenerate cubics, the target node |q| can
-be collapsed to the initial node |p| which might be the same as the
-initial node |c| of the curve. This would cause the |offset_prep| routine
-to bail out too early, causing distress later on. (See for example
-the testcase reported by Bogus\l{}aw Jackowski in tracker id 267, case 52c
-on Sarovar.)
-
-@<Advance |p| to node |q|, removing any ``dead'' cubics...@>=
-q0=q;
-do {
- r=link(p);
- if ( x_coord(p)==right_x(p) && y_coord(p)==right_y(p) &&
- x_coord(p)==left_x(r) && y_coord(p)==left_y(r) &&
- x_coord(p)==x_coord(r) && y_coord(p)==y_coord(r) &&
- r!=p ) {
- @<Remove the cubic following |p| and update the data structures
- to merge |r| into |p|@>;
- }
- p=r;
-} while (p!=q);
-/* Check if we removed too much */
-if ((q!=q0)&&(q!=c||c==c0))
- q = link(q)
-
-@ @<Remove the cubic following |p| and update the data structures...@>=
-{ k_needed=info(p)-zero_off;
- if ( r==q ) {
- q=p;
- } else {
- info(p)=k_needed+info(r);
- k_needed=0;
- };
- if ( r==c ) { info(p)=info(c); c=p; };
- if ( r==mp->spec_p1 ) mp->spec_p1=p;
- if ( r==mp->spec_p2 ) mp->spec_p2=p;
- r=p; mp_remove_cubic(mp, p);
-}
-
-@ Not setting the |info| field of the newly created knot allows the splitting
-routine to work for paths.
-
-@<Declare subroutines needed by |offset_prep|@>=
-void mp_split_cubic (MP mp,pointer p, fraction t) { /* splits the cubic after |p| */
- scaled v; /* an intermediate value */
- pointer q,r; /* for list manipulation */
- q=link(p); r=mp_get_node(mp, knot_node_size); link(p)=r; link(r)=q;
- originator(r)=mp_program_code;
- left_type(r)=mp_explicit; right_type(r)=mp_explicit;
- v=t_of_the_way(right_x(p),left_x(q));
- right_x(p)=t_of_the_way(x_coord(p),right_x(p));
- left_x(q)=t_of_the_way(left_x(q),x_coord(q));
- left_x(r)=t_of_the_way(right_x(p),v);
- right_x(r)=t_of_the_way(v,left_x(q));
- x_coord(r)=t_of_the_way(left_x(r),right_x(r));
- v=t_of_the_way(right_y(p),left_y(q));
- right_y(p)=t_of_the_way(y_coord(p),right_y(p));
- left_y(q)=t_of_the_way(left_y(q),y_coord(q));
- left_y(r)=t_of_the_way(right_y(p),v);
- right_y(r)=t_of_the_way(v,left_y(q));
- y_coord(r)=t_of_the_way(left_y(r),right_y(r));
-}
-
-@ This does not set |info(p)| or |right_type(p)|.
-
-@<Declare subroutines needed by |offset_prep|@>=
-void mp_remove_cubic (MP mp,pointer p) { /* removes the dead cubic following~|p| */
- pointer q; /* the node that disappears */
- q=link(p); link(p)=link(q);
- right_x(p)=right_x(q); right_y(p)=right_y(q);
- mp_free_node(mp, q,knot_node_size);
-}
-
-@ Let $d\prec d'$ mean that the counter-clockwise angle from $d$ to~$d'$ is
-strictly between zero and $180^\circ$. Then we can define $d\preceq d'$ to
-mean that the angle could be zero or $180^\circ$. If $w_k=(u_k,v_k)$ is the
-$k$th pen offset, the $k$th pen edge direction is defined by the formula
-$$d_k=(u\k-u_k,\,v\k-v_k).$$
-When listed by increasing $k$, these directions occur in counter-clockwise
-order so that $d_k\preceq d\k$ for all~$k$.
-The goal of |offset_prep| is to find an offset index~|k| to associate with
-each cubic, such that the direction $d(t)$ of the cubic satisfies
-$$d_{k-1}\preceq d(t)\preceq d_k\qquad\hbox{for $0\le t\le 1$.}\eqno(*)$$
-We may have to split a cubic into many pieces before each
-piece corresponds to a unique offset.
-
-@<Split the cubic between |p| and |q|, if necessary, into cubics...@>=
-info(p)=zero_off+k_needed;
-k_needed=0;
-@<Prepare for derivative computations;
- |goto not_found| if the current cubic is dead@>;
-@<Find the initial direction |(dx,dy)|@>;
-@<Update |info(p)| and find the offset $w_k$ such that
- $d_{k-1}\preceq(\\{dx},\\{dy})\prec d_k$; also advance |w0| for
- the direction change at |p|@>;
-@<Find the final direction |(dxin,dyin)|@>;
-@<Decide on the net change in pen offsets and set |turn_amt|@>;
-@<Complete the offset splitting process@>;
-w0=mp_pen_walk(mp, w0,turn_amt)
-
-@ @<Declare subroutines needed by |offset_prep|@>=
-pointer mp_pen_walk (MP mp,pointer w, integer k) {
- /* walk |k| steps around a pen from |w| */
- while ( k>0 ) { w=link(w); decr(k); };
- while ( k<0 ) { w=knil(w); incr(k); };
- return w;
-}
-
-@ The direction of a cubic $B(z_0,z_1,z_2,z_3;t)=\bigl(x(t),y(t)\bigr)$ can be
-calculated from the quadratic polynomials
-${1\over3}x'(t)=B(x_1-x_0,x_2-x_1,x_3-x_2;t)$ and
-${1\over3}y'(t)=B(y_1-y_0,y_2-y_1,y_3-y_2;t)$.
-Since we may be calculating directions from several cubics
-split from the current one, it is desirable to do these calculations
-without losing too much precision. ``Scaled up'' values of the
-derivatives, which will be less tainted by accumulated errors than
-derivatives found from the cubics themselves, are maintained in
-local variables |x0|, |x1|, and |x2|, representing $X_0=2^l(x_1-x_0)$,
-$X_1=2^l(x_2-x_1)$, and $X_2=2^l(x_3-x_2)$; similarly |y0|, |y1|, and~|y2|
-represent $Y_0=2^l(y_1-y_0)$, $Y_1=2^l(y_2-y_1)$, and $Y_2=2^l(y_3-y_2)$.
-
-@<Other local variables for |offset_prep|@>=
-integer x0,x1,x2,y0,y1,y2; /* representatives of derivatives */
-integer t0,t1,t2; /* coefficients of polynomial for slope testing */
-integer du,dv,dx,dy; /* for directions of the pen and the curve */
-integer dx0,dy0; /* initial direction for the first cubic in the curve */
-integer max_coef; /* used while scaling */
-integer x0a,x1a,x2a,y0a,y1a,y2a; /* intermediate values */
-fraction t; /* where the derivative passes through zero */
-fraction s; /* a temporary value */
-
-@ @<Prepare for derivative computations...@>=
-x0=right_x(p)-x_coord(p);
-x2=x_coord(q)-left_x(q);
-x1=left_x(q)-right_x(p);
-y0=right_y(p)-y_coord(p); y2=y_coord(q)-left_y(q);
-y1=left_y(q)-right_y(p);
-max_coef=abs(x0);
-if ( abs(x1)>max_coef ) max_coef=abs(x1);
-if ( abs(x2)>max_coef ) max_coef=abs(x2);
-if ( abs(y0)>max_coef ) max_coef=abs(y0);
-if ( abs(y1)>max_coef ) max_coef=abs(y1);
-if ( abs(y2)>max_coef ) max_coef=abs(y2);
-if ( max_coef==0 ) goto NOT_FOUND;
-while ( max_coef<fraction_half ) {
- double(max_coef);
- double(x0); double(x1); double(x2);
- double(y0); double(y1); double(y2);
-}
-
-@ Let us first solve a special case of the problem: Suppose we
-know an index~$k$ such that either (i)~$d(t)\succeq d_{k-1}$ for all~$t$
-and $d(0)\prec d_k$, or (ii)~$d(t)\preceq d_k$ for all~$t$ and
-$d(0)\succ d_{k-1}$.
-Then, in a sense, we're halfway done, since one of the two relations
-in $(*)$ is satisfied, and the other couldn't be satisfied for
-any other value of~|k|.
-
-Actually, the conditions can be relaxed somewhat since a relation such as
-$d(t)\succeq d_{k-1}$ restricts $d(t)$ to a half plane when all that really
-matters is whether $d(t)$ crosses the ray in the $d_{k-1}$ direction from
-the origin. The condition for case~(i) becomes $d_{k-1}\preceq d(0)\prec d_k$
-and $d(t)$ never crosses the $d_{k-1}$ ray in the clockwise direction.
-Case~(ii) is similar except $d(t)$ cannot cross the $d_k$ ray in the
-counterclockwise direction.
-
-The |fin_offset_prep| subroutine solves the stated subproblem.
-It has a parameter called |rise| that is |1| in
-case~(i), |-1| in case~(ii). Parameters |x0| through |y2| represent
-the derivative of the cubic following |p|.
-The |w| parameter should point to offset~$w_k$ and |info(p)| should already
-be set properly. The |turn_amt| parameter gives the absolute value of the
-overall net change in pen offsets.
-
-@<Declare subroutines needed by |offset_prep|@>=
-void mp_fin_offset_prep (MP mp,pointer p, pointer w, integer
- x0,integer x1, integer x2, integer y0, integer y1, integer y2,
- integer rise, integer turn_amt) {
- pointer ww; /* for list manipulation */
- scaled du,dv; /* for slope calculation */
- integer t0,t1,t2; /* test coefficients */
- fraction t; /* place where the derivative passes a critical slope */
- fraction s; /* slope or reciprocal slope */
- integer v; /* intermediate value for updating |x0..y2| */
- pointer q; /* original |link(p)| */
- q=link(p);
- while (1) {
- if ( rise>0 ) ww=link(w); /* a pointer to $w\k$ */
- else ww=knil(w); /* a pointer to $w_{k-1}$ */
- @<Compute test coefficients |(t0,t1,t2)|
- for $d(t)$ versus $d_k$ or $d_{k-1}$@>;
- t=mp_crossing_point(mp, t0,t1,t2);
- if ( t>=fraction_one ) {
- if ( turn_amt>0 ) t=fraction_one; else return;
- }
- @<Split the cubic at $t$,
- and split off another cubic if the derivative crosses back@>;
- w=ww;
- }
-}
-
-@ We want $B(\\{t0},\\{t1},\\{t2};t)$ to be the dot product of $d(t)$ with a
-$-90^\circ$ rotation of the vector from |w| to |ww|. This makes the resulting
-function cross from positive to negative when $d_{k-1}\preceq d(t)\preceq d_k$
-begins to fail.
-
-@<Compute test coefficients |(t0,t1,t2)| for $d(t)$ versus...@>=
-du=x_coord(ww)-x_coord(w); dv=y_coord(ww)-y_coord(w);
-if ( abs(du)>=abs(dv) ) {
- s=mp_make_fraction(mp, dv,du);
- t0=mp_take_fraction(mp, x0,s)-y0;
- t1=mp_take_fraction(mp, x1,s)-y1;
- t2=mp_take_fraction(mp, x2,s)-y2;
- if ( du<0 ) { negate(t0); negate(t1); negate(t2); }
-} else {
- s=mp_make_fraction(mp, du,dv);
- t0=x0-mp_take_fraction(mp, y0,s);
- t1=x1-mp_take_fraction(mp, y1,s);
- t2=x2-mp_take_fraction(mp, y2,s);
- if ( dv<0 ) { negate(t0); negate(t1); negate(t2); }
-}
-if ( t0<0 ) t0=0 /* should be positive without rounding error */
-
-@ The curve has crossed $d_k$ or $d_{k-1}$; its initial segment satisfies
-$(*)$, and it might cross again and return towards $s_{k-1}$ or $s_k$,
-respectively, yielding another solution of $(*)$.
-
-@<Split the cubic at $t$, and split off another...@>=
-{
-mp_split_cubic(mp, p,t); p=link(p); info(p)=zero_off+rise;
-decr(turn_amt);
-v=t_of_the_way(x0,x1); x1=t_of_the_way(x1,x2);
-x0=t_of_the_way(v,x1);
-v=t_of_the_way(y0,y1); y1=t_of_the_way(y1,y2);
-y0=t_of_the_way(v,y1);
-if ( turn_amt<0 ) {
- t1=t_of_the_way(t1,t2);
- if ( t1>0 ) t1=0; /* without rounding error, |t1| would be |<=0| */
- t=mp_crossing_point(mp, 0,-t1,-t2);
- if ( t>fraction_one ) t=fraction_one;
- incr(turn_amt);
- if ( (t==fraction_one)&&(link(p)!=q) ) {
- info(link(p))=info(link(p))-rise;
- } else {
- mp_split_cubic(mp, p,t); info(link(p))=zero_off-rise;
- v=t_of_the_way(x1,x2); x1=t_of_the_way(x0,x1);
- x2=t_of_the_way(x1,v);
- v=t_of_the_way(y1,y2); y1=t_of_the_way(y0,y1);
- y2=t_of_the_way(y1,v);
- }
-}
-}
-
-@ Now we must consider the general problem of |offset_prep|, when
-nothing is known about a given cubic. We start by finding its
-direction in the vicinity of |t=0|.
-
-If $z'(t)=0$, the given cubic is numerically unstable but |offset_prep|
-has not yet introduced any more numerical errors. Thus we can compute
-the true initial direction for the given cubic, even if it is almost
-degenerate.
-
-@<Find the initial direction |(dx,dy)|@>=
-dx=x0; dy=y0;
-if ( dx==0 && dy==0 ) {
- dx=x1; dy=y1;
- if ( dx==0 && dy==0 ) {
- dx=x2; dy=y2;
- }
-}
-if ( p==c ) { dx0=dx; dy0=dy; }
-
-@ @<Find the final direction |(dxin,dyin)|@>=
-dxin=x2; dyin=y2;
-if ( dxin==0 && dyin==0 ) {
- dxin=x1; dyin=y1;
- if ( dxin==0 && dyin==0 ) {
- dxin=x0; dyin=y0;
- }
-}
-
-@ The next step is to bracket the initial direction between consecutive
-edges of the pen polygon. We must be careful to turn clockwise only if
-this makes the turn less than $180^\circ$. (A $180^\circ$ turn must be
-counter-clockwise in order to make \&{doublepath} envelopes come out
-@:double_path_}{\&{doublepath} primitive@>
-right.) This code depends on |w0| being the offset for |(dxin,dyin)|.
-
-@<Update |info(p)| and find the offset $w_k$ such that...@>=
-turn_amt=mp_get_turn_amt(mp,w0,dx,dy,(mp_ab_vs_cd(mp, dy,dxin,dx,dyin)>=0));
-w=mp_pen_walk(mp, w0, turn_amt);
-w0=w;
-info(p)=info(p)+turn_amt
-
-@ Decide how many pen offsets to go away from |w| in order to find the offset
-for |(dx,dy)|, going counterclockwise if |ccw| is |true|. This assumes that
-|w| is the offset for some direction $(x',y')$ from which the angle to |(dx,dy)|
-in the sense determined by |ccw| is less than or equal to $180^\circ$.
-
-If the pen polygon has only two edges, they could both be parallel
-to |(dx,dy)|. In this case, we must be careful to stop after crossing the first
-such edge in order to avoid an infinite loop.
-
-@<Declare subroutines needed by |offset_prep|@>=
-integer mp_get_turn_amt (MP mp,pointer w, scaled dx,
- scaled dy, boolean ccw) {
- pointer ww; /* a neighbor of knot~|w| */
- integer s; /* turn amount so far */
- integer t; /* |ab_vs_cd| result */
- s=0;
- if ( ccw ) {
- ww=link(w);
- do {
- t=mp_ab_vs_cd(mp, dy,(x_coord(ww)-x_coord(w)),
- dx,(y_coord(ww)-y_coord(w)));
- if ( t<0 ) break;
- incr(s);
- w=ww; ww=link(ww);
- } while (t>0);
- } else {
- ww=knil(w);
- while ( mp_ab_vs_cd(mp, dy,(x_coord(w)-x_coord(ww)),
- dx,(y_coord(w)-y_coord(ww))) < 0) {
- decr(s);
- w=ww; ww=knil(ww);
- }
- }
- return s;
-}
-
-@ When we're all done, the final offset is |w0| and the final curve direction
-is |(dxin,dyin)|. With this knowledge of the incoming direction at |c|, we
-can correct |info(c)| which was erroneously based on an incoming offset
-of~|h|.
-
-@d fix_by(A) info(c)=info(c)+(A)
-
-@<Fix the offset change in |info(c)| and set |c| to the return value of...@>=
-mp->spec_offset=info(c)-zero_off;
-if ( link(c)==c ) {
- info(c)=zero_off+n;
-} else {
- fix_by(k_needed);
- while ( w0!=h ) { fix_by(1); w0=link(w0); };
- while ( info(c)<=zero_off-n ) fix_by(n);
- while ( info(c)>zero_off ) fix_by(-n);
- if ( (info(c)!=zero_off)&&(mp_ab_vs_cd(mp, dy0,dxin,dx0,dyin)>=0) ) fix_by(n);
-}
-
-@ Finally we want to reduce the general problem to situations that
-|fin_offset_prep| can handle. We split the cubic into at most three parts
-with respect to $d_{k-1}$, and apply |fin_offset_prep| to each part.
-
-@<Complete the offset splitting process@>=
-ww=knil(w);
-@<Compute test coeff...@>;
-@<Find the first |t| where $d(t)$ crosses $d_{k-1}$ or set
- |t:=fraction_one+1|@>;
-if ( t>fraction_one ) {
- mp_fin_offset_prep(mp, p,w,x0,x1,x2,y0,y1,y2,1,turn_amt);
-} else {
- mp_split_cubic(mp, p,t); r=link(p);
- x1a=t_of_the_way(x0,x1); x1=t_of_the_way(x1,x2);
- x2a=t_of_the_way(x1a,x1);
- y1a=t_of_the_way(y0,y1); y1=t_of_the_way(y1,y2);
- y2a=t_of_the_way(y1a,y1);
- mp_fin_offset_prep(mp, p,w,x0,x1a,x2a,y0,y1a,y2a,1,0); x0=x2a; y0=y2a;
- info(r)=zero_off-1;
- if ( turn_amt>=0 ) {
- t1=t_of_the_way(t1,t2);
- if ( t1>0 ) t1=0;
- t=mp_crossing_point(mp, 0,-t1,-t2);
- if ( t>fraction_one ) t=fraction_one;
- @<Split off another rising cubic for |fin_offset_prep|@>;
- mp_fin_offset_prep(mp, r,ww,x0,x1,x2,y0,y1,y2,-1,0);
- } else {
- mp_fin_offset_prep(mp, r,ww,x0,x1,x2,y0,y1,y2,-1,(-1-turn_amt));
- }
-}
-
-@ @<Split off another rising cubic for |fin_offset_prep|@>=
-mp_split_cubic(mp, r,t); info(link(r))=zero_off+1;
-x1a=t_of_the_way(x1,x2); x1=t_of_the_way(x0,x1);
-x0a=t_of_the_way(x1,x1a);
-y1a=t_of_the_way(y1,y2); y1=t_of_the_way(y0,y1);
-y0a=t_of_the_way(y1,y1a);
-mp_fin_offset_prep(mp, link(r),w,x0a,x1a,x2,y0a,y1a,y2,1,turn_amt);
-x2=x0a; y2=y0a
-
-@ At this point, the direction of the incoming pen edge is |(-du,-dv)|.
-When the component of $d(t)$ perpendicular to |(-du,-dv)| crosses zero, we
-need to decide whether the directions are parallel or antiparallel. We
-can test this by finding the dot product of $d(t)$ and |(-du,-dv)|, but this
-should be avoided when the value of |turn_amt| already determines the
-answer. If |t2<0|, there is one crossing and it is antiparallel only if
-|turn_amt>=0|. If |turn_amt<0|, there should always be at least one
-crossing and the first crossing cannot be antiparallel.
-
-@<Find the first |t| where $d(t)$ crosses $d_{k-1}$ or set...@>=
-t=mp_crossing_point(mp, t0,t1,t2);
-if ( turn_amt>=0 ) {
- if ( t2<0 ) {
- t=fraction_one+1;
- } else {
- u0=t_of_the_way(x0,x1);
- u1=t_of_the_way(x1,x2);
- ss=mp_take_fraction(mp, -du,t_of_the_way(u0,u1));
- v0=t_of_the_way(y0,y1);
- v1=t_of_the_way(y1,y2);
- ss=ss+mp_take_fraction(mp, -dv,t_of_the_way(v0,v1));
- if ( ss<0 ) t=fraction_one+1;
- }
-} else if ( t>fraction_one ) {
- t=fraction_one;
-}
-
-@ @<Other local variables for |offset_prep|@>=
-integer u0,u1,v0,v1; /* intermediate values for $d(t)$ calculation */
-integer ss = 0; /* the part of the dot product computed so far */
-int d_sign; /* sign of overall change in direction for this cubic */
-
-@ If the cubic almost has a cusp, it is a numerically ill-conditioned
-problem to decide which way it loops around but that's OK as long we're
-consistent. To make \&{doublepath} envelopes work properly, reversing
-the path should always change the sign of |turn_amt|.
-
-@<Decide on the net change in pen offsets and set |turn_amt|@>=
-d_sign=mp_ab_vs_cd(mp, dx,dyin, dxin,dy);
-if ( d_sign==0 ) {
- @<Check rotation direction based on node position@>
-}
-if ( d_sign==0 ) {
- if ( dx==0 ) {
- if ( dy>0 ) d_sign=1; else d_sign=-1;
- } else {
- if ( dx>0 ) d_sign=1; else d_sign=-1;
- }
-}
-@<Make |ss| negative if and only if the total change in direction is
- more than $180^\circ$@>;
-turn_amt=mp_get_turn_amt(mp, w, dxin, dyin, (d_sign>0));
-if ( ss<0 ) turn_amt=turn_amt-d_sign*n
-
-@ We check rotation direction by looking at the vector connecting the current
-node with the next. If its angle with incoming and outgoing tangents has the
-same sign, we pick this as |d_sign|, since it means we have a flex, not a cusp.
-Otherwise we proceed to the cusp code.
-
-@<Check rotation direction based on node position@>=
-u0=x_coord(q)-x_coord(p);
-u1=y_coord(q)-y_coord(p);
-d_sign = half(mp_ab_vs_cd(mp, dx, u1, u0, dy)+
- mp_ab_vs_cd(mp, u0, dyin, dxin, u1));
-
-@ In order to be invariant under path reversal, the result of this computation
-should not change when |x0|, |y0|, $\ldots$ are all negated and |(x0,y0)| is
-then swapped with |(x2,y2)|. We make use of the identities
-|take_fraction(-a,-b)=take_fraction(a,b)| and
-|t_of_the_way(-a,-b)=-(t_of_the_way(a,b))|.
-
-@<Make |ss| negative if and only if the total change in direction is...@>=
-t0=half(mp_take_fraction(mp, x0,y2))-half(mp_take_fraction(mp, x2,y0));
-t1=half(mp_take_fraction(mp, x1,(y0+y2)))-half(mp_take_fraction(mp, y1,(x0+x2)));
-if ( t0==0 ) t0=d_sign; /* path reversal always negates |d_sign| */
-if ( t0>0 ) {
- t=mp_crossing_point(mp, t0,t1,-t0);
- u0=t_of_the_way(x0,x1);
- u1=t_of_the_way(x1,x2);
- v0=t_of_the_way(y0,y1);
- v1=t_of_the_way(y1,y2);
-} else {
- t=mp_crossing_point(mp, -t0,t1,t0);
- u0=t_of_the_way(x2,x1);
- u1=t_of_the_way(x1,x0);
- v0=t_of_the_way(y2,y1);
- v1=t_of_the_way(y1,y0);
-}
-ss=mp_take_fraction(mp, (x0+x2),t_of_the_way(u0,u1))+
- mp_take_fraction(mp, (y0+y2),t_of_the_way(v0,v1))
-
-@ Here's a routine that prints an envelope spec in symbolic form. It assumes
-that the |cur_pen| has not been walked around to the first offset.
-
-@c
-void mp_print_spec (MP mp,pointer cur_spec, pointer cur_pen, const char *s) {
- pointer p,q; /* list traversal */
- pointer w; /* the current pen offset */
- mp_print_diagnostic(mp, "Envelope spec",s,true);
- p=cur_spec; w=mp_pen_walk(mp, cur_pen,mp->spec_offset);
- mp_print_ln(mp);
- mp_print_two(mp, x_coord(cur_spec),y_coord(cur_spec));
- mp_print(mp, " % beginning with offset ");
- mp_print_two(mp, x_coord(w),y_coord(w));
- do {
- while (1) {
- q=link(p);
- @<Print the cubic between |p| and |q|@>;
- p=q;
- if ((p==cur_spec) || (info(p)!=zero_off))
- break;
- }
- if ( info(p)!=zero_off ) {
- @<Update |w| as indicated by |info(p)| and print an explanation@>;
- }
- } while (p!=cur_spec);
- mp_print_nl(mp, " & cycle");
- mp_end_diagnostic(mp, true);
-}
-
-@ @<Update |w| as indicated by |info(p)| and print an explanation@>=
-{
- w=mp_pen_walk(mp, w, (info(p)-zero_off));
- mp_print(mp, " % ");
- if ( info(p)>zero_off ) mp_print(mp, "counter");
- mp_print(mp, "clockwise to offset ");
- mp_print_two(mp, x_coord(w),y_coord(w));
-}
-
-@ @<Print the cubic between |p| and |q|@>=
-{
- mp_print_nl(mp, " ..controls ");
- mp_print_two(mp, right_x(p),right_y(p));
- mp_print(mp, " and ");
- mp_print_two(mp, left_x(q),left_y(q));
- mp_print_nl(mp, " ..");
- mp_print_two(mp, x_coord(q),y_coord(q));
-}
-
-@ Once we have an envelope spec, the remaining task to construct the actual
-envelope by offsetting each cubic as determined by the |info| fields in
-the knots. First we use |offset_prep| to convert the |c| into an envelope
-spec. Then we add the offsets so that |c| becomes a cyclic path that represents
-the envelope.
-
-The |ljoin| and |miterlim| parameters control the treatment of points where the
-pen offset changes, and |lcap| controls the endpoints of a \&{doublepath}.
-The endpoints are easily located because |c| is given in undoubled form
-and then doubled in this procedure. We use |spec_p1| and |spec_p2| to keep
-track of the endpoints and treat them like very sharp corners.
-Butt end caps are treated like beveled joins; round end caps are treated like
-round joins; and square end caps are achieved by setting |join_type:=3|.
-
-None of these parameters apply to inside joins where the convolution tracing
-has retrograde lines. In such cases we use a simple connect-the-endpoints
-approach that is achieved by setting |join_type:=2|.
-
-@c @<Declare a function called |insert_knot|@>
-pointer mp_make_envelope (MP mp,pointer c, pointer h, small_number ljoin,
- small_number lcap, scaled miterlim) {
- pointer p,q,r,q0; /* for manipulating the path */
- int join_type=0; /* codes |0..3| for mitered, round, beveled, or square */
- pointer w,w0; /* the pen knot for the current offset */
- scaled qx,qy; /* unshifted coordinates of |q| */
- halfword k,k0; /* controls pen edge insertion */
- @<Other local variables for |make_envelope|@>;
- dxin=0; dyin=0; dxout=0; dyout=0;
- mp->spec_p1=null; mp->spec_p2=null;
- @<If endpoint, double the path |c|, and set |spec_p1| and |spec_p2|@>;
- @<Use |offset_prep| to compute the envelope spec then walk |h| around to
- the initial offset@>;
- w=h;
- p=c;
- do {
- q=link(p); q0=q;
- qx=x_coord(q); qy=y_coord(q);
- k=info(q);
- k0=k; w0=w;
- if ( k!=zero_off ) {
- @<Set |join_type| to indicate how to handle offset changes at~|q|@>;
- }
- @<Add offset |w| to the cubic from |p| to |q|@>;
- while ( k!=zero_off ) {
- @<Step |w| and move |k| one step closer to |zero_off|@>;
- if ( (join_type==1)||(k==zero_off) )
- q=mp_insert_knot(mp, q,qx+x_coord(w),qy+y_coord(w));
- };
- if ( q!=link(p) ) {
- @<Set |p=link(p)| and add knots between |p| and |q| as
- required by |join_type|@>;
- }
- p=q;
- } while (q0!=c);
- return c;
-}
-
-@ @<Use |offset_prep| to compute the envelope spec then walk |h| around to...@>=
-c=mp_offset_prep(mp, c,h);
-if ( mp->internal[mp_tracing_specs]>0 )
- mp_print_spec(mp, c,h,"");
-h=mp_pen_walk(mp, h,mp->spec_offset)
-
-@ Mitered and squared-off joins depend on path directions that are difficult to
-compute for degenerate cubics. The envelope spec computed by |offset_prep| can
-have degenerate cubics only if the entire cycle collapses to a single
-degenerate cubic. Setting |join_type:=2| in this case makes the computed
-envelope degenerate as well.
-
-@<Set |join_type| to indicate how to handle offset changes at~|q|@>=
-if ( k<zero_off ) {
- join_type=2;
-} else {
- if ( (q!=mp->spec_p1)&&(q!=mp->spec_p2) ) join_type=ljoin;
- else if ( lcap==2 ) join_type=3;
- else join_type=2-lcap;
- if ( (join_type==0)||(join_type==3) ) {
- @<Set the incoming and outgoing directions at |q|; in case of
- degeneracy set |join_type:=2|@>;
- if ( join_type==0 ) {
- @<If |miterlim| is less than the secant of half the angle at |q|
- then set |join_type:=2|@>;
- }
- }
-}
-
-@ @<If |miterlim| is less than the secant of half the angle at |q|...@>=
-{
- tmp=mp_take_fraction(mp, miterlim,fraction_half+
- half(mp_take_fraction(mp, dxin,dxout)+mp_take_fraction(mp, dyin,dyout)));
- if ( tmp<unity )
- if ( mp_take_scaled(mp, miterlim,tmp)<unity ) join_type=2;
-}
-
-@ @<Other local variables for |make_envelope|@>=
-fraction dxin,dyin,dxout,dyout; /* directions at |q| when square or mitered */
-scaled tmp; /* a temporary value */
-
-@ The coordinates of |p| have already been shifted unless |p| is the first
-knot in which case they get shifted at the very end.
-
-@<Add offset |w| to the cubic from |p| to |q|@>=
-right_x(p)=right_x(p)+x_coord(w);
-right_y(p)=right_y(p)+y_coord(w);
-left_x(q)=left_x(q)+x_coord(w);
-left_y(q)=left_y(q)+y_coord(w);
-x_coord(q)=x_coord(q)+x_coord(w);
-y_coord(q)=y_coord(q)+y_coord(w);
-left_type(q)=mp_explicit;
-right_type(q)=mp_explicit
-
-@ @<Step |w| and move |k| one step closer to |zero_off|@>=
-if ( k>zero_off ){ w=link(w); decr(k); }
-else { w=knil(w); incr(k); }
-
-@ The cubic from |q| to the new knot at |(x,y)| becomes a line segment and
-the |right_x| and |right_y| fields of |r| are set from |q|. This is done in
-case the cubic containing these control points is ``yet to be examined.''
-
-@<Declare a function called |insert_knot|@>=
-pointer mp_insert_knot (MP mp,pointer q, scaled x, scaled y) {
- /* returns the inserted knot */
- pointer r; /* the new knot */
- r=mp_get_node(mp, knot_node_size);
- link(r)=link(q); link(q)=r;
- right_x(r)=right_x(q);
- right_y(r)=right_y(q);
- x_coord(r)=x;
- y_coord(r)=y;
- right_x(q)=x_coord(q);
- right_y(q)=y_coord(q);
- left_x(r)=x_coord(r);
- left_y(r)=y_coord(r);
- left_type(r)=mp_explicit;
- right_type(r)=mp_explicit;
- originator(r)=mp_program_code;
- return r;
-}
-
-@ After setting |p:=link(p)|, either |join_type=1| or |q=link(p)|.
-
-@<Set |p=link(p)| and add knots between |p| and |q| as...@>=
-{
- p=link(p);
- if ( (join_type==0)||(join_type==3) ) {
- if ( join_type==0 ) {
- @<Insert a new knot |r| between |p| and |q| as required for a mitered join@>
- } else {
- @<Make |r| the last of two knots inserted between |p| and |q| to form a
- squared join@>;
- }
- if ( r!=null ) {
- right_x(r)=x_coord(r);
- right_y(r)=y_coord(r);
- }
- }
-}
-
-@ For very small angles, adding a knot is unnecessary and would cause numerical
-problems, so we just set |r:=null| in that case.
-
-@<Insert a new knot |r| between |p| and |q| as required for a mitered join@>=
-{
- det=mp_take_fraction(mp, dyout,dxin)-mp_take_fraction(mp, dxout,dyin);
- if ( abs(det)<26844 ) {
- r=null; /* sine $<10^{-4}$ */
- } else {
- tmp=mp_take_fraction(mp, x_coord(q)-x_coord(p),dyout)-
- mp_take_fraction(mp, y_coord(q)-y_coord(p),dxout);
- tmp=mp_make_fraction(mp, tmp,det);
- r=mp_insert_knot(mp, p,x_coord(p)+mp_take_fraction(mp, tmp,dxin),
- y_coord(p)+mp_take_fraction(mp, tmp,dyin));
- }
-}
-
-@ @<Other local variables for |make_envelope|@>=
-fraction det; /* a determinant used for mitered join calculations */
-
-@ @<Make |r| the last of two knots inserted between |p| and |q| to form a...@>=
-{
- ht_x=y_coord(w)-y_coord(w0);
- ht_y=x_coord(w0)-x_coord(w);
- while ( (abs(ht_x)<fraction_half)&&(abs(ht_y)<fraction_half) ) {
- ht_x+=ht_x; ht_y+=ht_y;
- }
- @<Scan the pen polygon between |w0| and |w| and make |max_ht| the range dot
- product with |(ht_x,ht_y)|@>;
- tmp=mp_make_fraction(mp, max_ht,mp_take_fraction(mp, dxin,ht_x)+
- mp_take_fraction(mp, dyin,ht_y));
- r=mp_insert_knot(mp, p,x_coord(p)+mp_take_fraction(mp, tmp,dxin),
- y_coord(p)+mp_take_fraction(mp, tmp,dyin));
- tmp=mp_make_fraction(mp, max_ht,mp_take_fraction(mp, dxout,ht_x)+
- mp_take_fraction(mp, dyout,ht_y));
- r=mp_insert_knot(mp, r,x_coord(q)+mp_take_fraction(mp, tmp,dxout),
- y_coord(q)+mp_take_fraction(mp, tmp,dyout));
-}
-
-@ @<Other local variables for |make_envelope|@>=
-fraction ht_x,ht_y; /* perpendicular to the segment from |p| to |q| */
-scaled max_ht; /* maximum height of the pen polygon above the |w0|-|w| line */
-halfword kk; /* keeps track of the pen vertices being scanned */
-pointer ww; /* the pen vertex being tested */
-
-@ The dot product of the vector from |w0| to |ww| with |(ht_x,ht_y)| ranges
-from zero to |max_ht|.
-
-@<Scan the pen polygon between |w0| and |w| and make |max_ht| the range...@>=
-max_ht=0;
-kk=zero_off;
-ww=w;
-while (1) {
- @<Step |ww| and move |kk| one step closer to |k0|@>;
- if ( kk==k0 ) break;
- tmp=mp_take_fraction(mp, (x_coord(ww)-x_coord(w0)),ht_x)+
- mp_take_fraction(mp, (y_coord(ww)-y_coord(w0)),ht_y);
- if ( tmp>max_ht ) max_ht=tmp;
-}
-
-
-@ @<Step |ww| and move |kk| one step closer to |k0|@>=
-if ( kk>k0 ) { ww=link(ww); decr(kk); }
-else { ww=knil(ww); incr(kk); }
-
-@ @<If endpoint, double the path |c|, and set |spec_p1| and |spec_p2|@>=
-if ( left_type(c)==mp_endpoint ) {
- mp->spec_p1=mp_htap_ypoc(mp, c);
- mp->spec_p2=mp->path_tail;
- originator(mp->spec_p1)=mp_program_code;
- link(mp->spec_p2)=link(mp->spec_p1);
- link(mp->spec_p1)=c;
- mp_remove_cubic(mp, mp->spec_p1);
- c=mp->spec_p1;
- if ( c!=link(c) ) {
- originator(mp->spec_p2)=mp_program_code;
- mp_remove_cubic(mp, mp->spec_p2);
- } else {
- @<Make |c| look like a cycle of length one@>;
- }
-}
-
-@ @<Make |c| look like a cycle of length one@>=
-{
- left_type(c)=mp_explicit; right_type(c)=mp_explicit;
- left_x(c)=x_coord(c); left_y(c)=y_coord(c);
- right_x(c)=x_coord(c); right_y(c)=y_coord(c);
-}
-
-@ In degenerate situations we might have to look at the knot preceding~|q|.
-That knot is |p| but if |p<>c|, its coordinates have already been offset by |w|.
-
-@<Set the incoming and outgoing directions at |q|; in case of...@>=
-dxin=x_coord(q)-left_x(q);
-dyin=y_coord(q)-left_y(q);
-if ( (dxin==0)&&(dyin==0) ) {
- dxin=x_coord(q)-right_x(p);
- dyin=y_coord(q)-right_y(p);
- if ( (dxin==0)&&(dyin==0) ) {
- dxin=x_coord(q)-x_coord(p);
- dyin=y_coord(q)-y_coord(p);
- if ( p!=c ) { /* the coordinates of |p| have been offset by |w| */
- dxin=dxin+x_coord(w);
- dyin=dyin+y_coord(w);
- }
- }
-}
-tmp=mp_pyth_add(mp, dxin,dyin);
-if ( tmp==0 ) {
- join_type=2;
-} else {
- dxin=mp_make_fraction(mp, dxin,tmp);
- dyin=mp_make_fraction(mp, dyin,tmp);
- @<Set the outgoing direction at |q|@>;
-}
-
-@ If |q=c| then the coordinates of |r| and the control points between |q|
-and~|r| have already been offset by |h|.
-
-@<Set the outgoing direction at |q|@>=
-dxout=right_x(q)-x_coord(q);
-dyout=right_y(q)-y_coord(q);
-if ( (dxout==0)&&(dyout==0) ) {
- r=link(q);
- dxout=left_x(r)-x_coord(q);
- dyout=left_y(r)-y_coord(q);
- if ( (dxout==0)&&(dyout==0) ) {
- dxout=x_coord(r)-x_coord(q);
- dyout=y_coord(r)-y_coord(q);
- }
-}
-if ( q==c ) {
- dxout=dxout-x_coord(h);
- dyout=dyout-y_coord(h);
-}
-tmp=mp_pyth_add(mp, dxout,dyout);
-if ( tmp==0 ) mp_confusion(mp, "degenerate spec");
-@:this can't happen degerate spec}{\quad degenerate spec@>
-dxout=mp_make_fraction(mp, dxout,tmp);
-dyout=mp_make_fraction(mp, dyout,tmp)
-
-@* \[23] Direction and intersection times.
-A path of length $n$ is defined parametrically by functions $x(t)$ and
-$y(t)$, for |0<=t<=n|; we can regard $t$ as the ``time'' at which the path
-reaches the point $\bigl(x(t),y(t)\bigr)$. In this section of the program
-we shall consider operations that determine special times associated with
-given paths: the first time that a path travels in a given direction, and
-a pair of times at which two paths cross each other.
-
-@ Let's start with the easier task. The function |find_direction_time| is
-given a direction |(x,y)| and a path starting at~|h|. If the path never
-travels in direction |(x,y)|, the direction time will be~|-1|; otherwise
-it will be nonnegative.
-
-Certain anomalous cases can arise: If |(x,y)=(0,0)|, so that the given
-direction is undefined, the direction time will be~0. If $\bigl(x'(t),
-y'(t)\bigr)=(0,0)$, so that the path direction is undefined, it will be
-assumed to match any given direction at time~|t|.
-
-The routine solves this problem in nondegenerate cases by rotating the path
-and the given direction so that |(x,y)=(1,0)|; i.e., the main task will be
-to find when a given path first travels ``due east.''
-
-@c
-scaled mp_find_direction_time (MP mp,scaled x, scaled y, pointer h) {
- scaled max; /* $\max\bigl(\vert x\vert,\vert y\vert\bigr)$ */
- pointer p,q; /* for list traversal */
- scaled n; /* the direction time at knot |p| */
- scaled tt; /* the direction time within a cubic */
- @<Other local variables for |find_direction_time|@>;
- @<Normalize the given direction for better accuracy;
- but |return| with zero result if it's zero@>;
- n=0; p=h; phi=0;
- while (1) {
- if ( right_type(p)==mp_endpoint ) break;
- q=link(p);
- @<Rotate the cubic between |p| and |q|; then
- |goto found| if the rotated cubic travels due east at some time |tt|;
- but |break| if an entire cyclic path has been traversed@>;
- p=q; n=n+unity;
- }
- return (-unity);
-FOUND:
- return (n+tt);
-}
-
-@ @<Normalize the given direction for better accuracy...@>=
-if ( abs(x)<abs(y) ) {
- x=mp_make_fraction(mp, x,abs(y));
- if ( y>0 ) y=fraction_one; else y=-fraction_one;
-} else if ( x==0 ) {
- return 0;
-} else {
- y=mp_make_fraction(mp, y,abs(x));
- if ( x>0 ) x=fraction_one; else x=-fraction_one;
-}
-
-@ Since we're interested in the tangent directions, we work with the
-derivative $${1\over3}B'(x_0,x_1,x_2,x_3;t)=
-B(x_1-x_0,x_2-x_1,x_3-x_2;t)$$ instead of
-$B(x_0,x_1,x_2,x_3;t)$ itself. The derived coefficients are also scaled up
-in order to achieve better accuracy.
-
-The given path may turn abruptly at a knot, and it might pass the critical
-tangent direction at such a time. Therefore we remember the direction |phi|
-in which the previous rotated cubic was traveling. (The value of |phi| will be
-undefined on the first cubic, i.e., when |n=0|.)
-
-@<Rotate the cubic between |p| and |q|; then...@>=
-tt=0;
-@<Set local variables |x1,x2,x3| and |y1,y2,y3| to multiples of the control
- points of the rotated derivatives@>;
-if ( y1==0 ) if ( x1>=0 ) goto FOUND;
-if ( n>0 ) {
- @<Exit to |found| if an eastward direction occurs at knot |p|@>;
- if ( p==h ) break;
- };
-if ( (x3!=0)||(y3!=0) ) phi=mp_n_arg(mp, x3,y3);
-@<Exit to |found| if the curve whose derivatives are specified by
- |x1,x2,x3,y1,y2,y3| travels eastward at some time~|tt|@>
-
-@ @<Other local variables for |find_direction_time|@>=
-scaled x1,x2,x3,y1,y2,y3; /* multiples of rotated derivatives */
-angle theta,phi; /* angles of exit and entry at a knot */
-fraction t; /* temp storage */
-
-@ @<Set local variables |x1,x2,x3| and |y1,y2,y3| to multiples...@>=
-x1=right_x(p)-x_coord(p); x2=left_x(q)-right_x(p);
-x3=x_coord(q)-left_x(q);
-y1=right_y(p)-y_coord(p); y2=left_y(q)-right_y(p);
-y3=y_coord(q)-left_y(q);
-max=abs(x1);
-if ( abs(x2)>max ) max=abs(x2);
-if ( abs(x3)>max ) max=abs(x3);
-if ( abs(y1)>max ) max=abs(y1);
-if ( abs(y2)>max ) max=abs(y2);
-if ( abs(y3)>max ) max=abs(y3);
-if ( max==0 ) goto FOUND;
-while ( max<fraction_half ){
- max+=max; x1+=x1; x2+=x2; x3+=x3;
- y1+=y1; y2+=y2; y3+=y3;
-}
-t=x1; x1=mp_take_fraction(mp, x1,x)+mp_take_fraction(mp, y1,y);
-y1=mp_take_fraction(mp, y1,x)-mp_take_fraction(mp, t,y);
-t=x2; x2=mp_take_fraction(mp, x2,x)+mp_take_fraction(mp, y2,y);
-y2=mp_take_fraction(mp, y2,x)-mp_take_fraction(mp, t,y);
-t=x3; x3=mp_take_fraction(mp, x3,x)+mp_take_fraction(mp, y3,y);
-y3=mp_take_fraction(mp, y3,x)-mp_take_fraction(mp, t,y)
-
-@ @<Exit to |found| if an eastward direction occurs at knot |p|@>=
-theta=mp_n_arg(mp, x1,y1);
-if ( theta>=0 ) if ( phi<=0 ) if ( phi>=theta-one_eighty_deg ) goto FOUND;
-if ( theta<=0 ) if ( phi>=0 ) if ( phi<=theta+one_eighty_deg ) goto FOUND
-
-@ In this step we want to use the |crossing_point| routine to find the
-roots of the quadratic equation $B(y_1,y_2,y_3;t)=0$.
-Several complications arise: If the quadratic equation has a double root,
-the curve never crosses zero, and |crossing_point| will find nothing;
-this case occurs iff $y_1y_3=y_2^2$ and $y_1y_2<0$. If the quadratic
-equation has simple roots, or only one root, we may have to negate it
-so that $B(y_1,y_2,y_3;t)$ crosses from positive to negative at its first root.
-And finally, we need to do special things if $B(y_1,y_2,y_3;t)$ is
-identically zero.
-
-@ @<Exit to |found| if the curve whose derivatives are specified by...@>=
-if ( x1<0 ) if ( x2<0 ) if ( x3<0 ) goto DONE;
-if ( mp_ab_vs_cd(mp, y1,y3,y2,y2)==0 ) {
- @<Handle the test for eastward directions when $y_1y_3=y_2^2$;
- either |goto found| or |goto done|@>;
-}
-if ( y1<=0 ) {
- if ( y1<0 ) { y1=-y1; y2=-y2; y3=-y3; }
- else if ( y2>0 ){ y2=-y2; y3=-y3; };
-}
-@<Check the places where $B(y_1,y_2,y_3;t)=0$ to see if
- $B(x_1,x_2,x_3;t)\ge0$@>;
-DONE:
-
-@ The quadratic polynomial $B(y_1,y_2,y_3;t)$ begins |>=0| and has at most
-two roots, because we know that it isn't identically zero.
-
-It must be admitted that the |crossing_point| routine is not perfectly accurate;
-rounding errors might cause it to find a root when $y_1y_3>y_2^2$, or to
-miss the roots when $y_1y_3<y_2^2$. The rotation process is itself
-subject to rounding errors. Yet this code optimistically tries to
-do the right thing.
-
-@d we_found_it { tt=(t+04000) / 010000; goto FOUND; }
-
-@<Check the places where $B(y_1,y_2,y_3;t)=0$...@>=
-t=mp_crossing_point(mp, y1,y2,y3);
-if ( t>fraction_one ) goto DONE;
-y2=t_of_the_way(y2,y3);
-x1=t_of_the_way(x1,x2);
-x2=t_of_the_way(x2,x3);
-x1=t_of_the_way(x1,x2);
-if ( x1>=0 ) we_found_it;
-if ( y2>0 ) y2=0;
-tt=t; t=mp_crossing_point(mp, 0,-y2,-y3);
-if ( t>fraction_one ) goto DONE;
-x1=t_of_the_way(x1,x2);
-x2=t_of_the_way(x2,x3);
-if ( t_of_the_way(x1,x2)>=0 ) {
- t=t_of_the_way(tt,fraction_one); we_found_it;
-}
-
-@ @<Handle the test for eastward directions when $y_1y_3=y_2^2$;
- either |goto found| or |goto done|@>=
-{
- if ( mp_ab_vs_cd(mp, y1,y2,0,0)<0 ) {
- t=mp_make_fraction(mp, y1,y1-y2);
- x1=t_of_the_way(x1,x2);
- x2=t_of_the_way(x2,x3);
- if ( t_of_the_way(x1,x2)>=0 ) we_found_it;
- } else if ( y3==0 ) {
- if ( y1==0 ) {
- @<Exit to |found| if the derivative $B(x_1,x_2,x_3;t)$ becomes |>=0|@>;
- } else if ( x3>=0 ) {
- tt=unity; goto FOUND;
- }
- }
- goto DONE;
-}
-
-@ At this point we know that the derivative of |y(t)| is identically zero,
-and that |x1<0|; but either |x2>=0| or |x3>=0|, so there's some hope of
-traveling east.
-
-@<Exit to |found| if the derivative $B(x_1,x_2,x_3;t)$ becomes |>=0|...@>=
-{
- t=mp_crossing_point(mp, -x1,-x2,-x3);
- if ( t<=fraction_one ) we_found_it;
- if ( mp_ab_vs_cd(mp, x1,x3,x2,x2)<=0 ) {
- t=mp_make_fraction(mp, x1,x1-x2); we_found_it;
- }
-}
-
-@ The intersection of two cubics can be found by an interesting variant
-of the general bisection scheme described in the introduction to
-|crossing_point|.\
-Given $w(t)=B(w_0,w_1,w_2,w_3;t)$ and $z(t)=B(z_0,z_1,z_2,z_3;t)$,
-we wish to find a pair of times $(t_1,t_2)$ such that $w(t_1)=z(t_2)$,
-if an intersection exists. First we find the smallest rectangle that
-encloses the points $\{w_0,w_1,w_2,w_3\}$ and check that it overlaps
-the smallest rectangle that encloses
-$\{z_0,z_1,z_2,z_3\}$; if not, the cubics certainly don't intersect.
-But if the rectangles do overlap, we bisect the intervals, getting
-new cubics $w'$ and~$w''$, $z'$~and~$z''$; the intersection routine first
-tries for an intersection between $w'$ and~$z'$, then (if unsuccessful)
-between $w'$ and~$z''$, then (if still unsuccessful) between $w''$ and~$z'$,
-finally (if thrice unsuccessful) between $w''$ and~$z''$. After $l$~successful
-levels of bisection we will have determined the intersection times $t_1$
-and~$t_2$ to $l$~bits of accuracy.
-
-\def\submin{_{\rm min}} \def\submax{_{\rm max}}
-As before, it is better to work with the numbers $W_k=2^l(w_k-w_{k-1})$
-and $Z_k=2^l(z_k-z_{k-1})$ rather than the coefficients $w_k$ and $z_k$
-themselves. We also need one other quantity, $\Delta=2^l(w_0-z_0)$,
-to determine when the enclosing rectangles overlap. Here's why:
-The $x$~coordinates of~$w(t)$ are between $u\submin$ and $u\submax$,
-and the $x$~coordinates of~$z(t)$ are between $x\submin$ and $x\submax$,
-if we write $w_k=(u_k,v_k)$ and $z_k=(x_k,y_k)$ and $u\submin=
-\min(u_0,u_1,u_2,u_3)$, etc. These intervals of $x$~coordinates
-overlap if and only if $u\submin\L x\submax$ and
-$x\submin\L u\submax$. Letting
-$$U\submin=\min(0,U_1,U_1+U_2,U_1+U_2+U_3),\;
- U\submax=\max(0,U_1,U_1+U_2,U_1+U_2+U_3),$$
-we have $2^lu\submin=2^lu_0+U\submin$, etc.; the condition for overlap
-reduces to
-$$X\submin-U\submax\L 2^l(u_0-x_0)\L X\submax-U\submin.$$
-Thus we want to maintain the quantity $2^l(u_0-x_0)$; similarly,
-the quantity $2^l(v_0-y_0)$ accounts for the $y$~coordinates. The
-coordinates of $\Delta=2^l(w_0-z_0)$ must stay bounded as $l$ increases,
-because of the overlap condition; i.e., we know that $X\submin$,
-$X\submax$, and their relatives are bounded, hence $X\submax-
-U\submin$ and $X\submin-U\submax$ are bounded.
-
-@ Incidentally, if the given cubics intersect more than once, the process
-just sketched will not necessarily find the lexicographically smallest pair
-$(t_1,t_2)$. The solution actually obtained will be smallest in ``shuffled
-order''; i.e., if $t_1=(.a_1a_2\ldots a_{16})_2$ and
-$t_2=(.b_1b_2\ldots b_{16})_2$, then we will minimize
-$a_1b_1a_2b_2\ldots a_{16}b_{16}$, not
-$a_1a_2\ldots a_{16}b_1b_2\ldots b_{16}$.
-Shuffled order agrees with lexicographic order if all pairs of solutions
-$(t_1,t_2)$ and $(t_1',t_2')$ have the property that $t_1<t_1'$ iff
-$t_2<t_2'$; but in general, lexicographic order can be quite different,
-and the bisection algorithm would be substantially less efficient if it were
-constrained by lexicographic order.
-
-For example, suppose that an overlap has been found for $l=3$ and
-$(t_1,t_2)= (.101,.011)$ in binary, but that no overlap is produced by
-either of the alternatives $(.1010,.0110)$, $(.1010,.0111)$ at level~4.
-Then there is probably an intersection in one of the subintervals
-$(.1011,.011x)$; but lexicographic order would require us to explore
-$(.1010,.1xxx)$ and $(.1011,.00xx)$ and $(.1011,.010x)$ first. We wouldn't
-want to store all of the subdivision data for the second path, so the
-subdivisions would have to be regenerated many times. Such inefficiencies
-would be associated with every `1' in the binary representation of~$t_1$.
-
-@ The subdivision process introduces rounding errors, hence we need to
-make a more liberal test for overlap. It is not hard to show that the
-computed values of $U_i$ differ from the truth by at most~$l$, on
-level~$l$, hence $U\submin$ and $U\submax$ will be at most $3l$ in error.
-If $\beta$ is an upper bound on the absolute error in the computed
-components of $\Delta=(|delx|,|dely|)$ on level~$l$, we will replace
-the test `$X\submin-U\submax\L|delx|$' by the more liberal test
-`$X\submin-U\submax\L|delx|+|tol|$', where $|tol|=6l+\beta$.
-
-More accuracy is obtained if we try the algorithm first with |tol=0|;
-the more liberal tolerance is used only if an exact approach fails.
-It is convenient to do this double-take by letting `3' in the preceding
-paragraph be a parameter, which is first 0, then 3.
-
-@<Glob...@>=
-unsigned int tol_step; /* either 0 or 3, usually */
-
-@ We shall use an explicit stack to implement the recursive bisection
-method described above. The |bisect_stack| array will contain numerous 5-word
-packets like $(U_1,U_2,U_3,U\submin,U\submax)$, as well as 20-word packets
-comprising the 5-word packets for $U$, $V$, $X$, and~$Y$.
-
-The following macros define the allocation of stack positions to
-the quantities needed for bisection-intersection.
-
-@d stack_1(A) mp->bisect_stack[(A)] /* $U_1$, $V_1$, $X_1$, or $Y_1$ */
-@d stack_2(A) mp->bisect_stack[(A)+1] /* $U_2$, $V_2$, $X_2$, or $Y_2$ */
-@d stack_3(A) mp->bisect_stack[(A)+2] /* $U_3$, $V_3$, $X_3$, or $Y_3$ */
-@d stack_min(A) mp->bisect_stack[(A)+3]
- /* $U\submin$, $V\submin$, $X\submin$, or $Y\submin$ */
-@d stack_max(A) mp->bisect_stack[(A)+4]
- /* $U\submax$, $V\submax$, $X\submax$, or $Y\submax$ */
-@d int_packets 20 /* number of words to represent $U_k$, $V_k$, $X_k$, and $Y_k$ */
-@#
-@d u_packet(A) ((A)-5)
-@d v_packet(A) ((A)-10)
-@d x_packet(A) ((A)-15)
-@d y_packet(A) ((A)-20)
-@d l_packets (mp->bisect_ptr-int_packets)
-@d r_packets mp->bisect_ptr
-@d ul_packet u_packet(l_packets) /* base of $U'_k$ variables */
-@d vl_packet v_packet(l_packets) /* base of $V'_k$ variables */
-@d xl_packet x_packet(l_packets) /* base of $X'_k$ variables */
-@d yl_packet y_packet(l_packets) /* base of $Y'_k$ variables */
-@d ur_packet u_packet(r_packets) /* base of $U''_k$ variables */
-@d vr_packet v_packet(r_packets) /* base of $V''_k$ variables */
-@d xr_packet x_packet(r_packets) /* base of $X''_k$ variables */
-@d yr_packet y_packet(r_packets) /* base of $Y''_k$ variables */
-@#
-@d u1l stack_1(ul_packet) /* $U'_1$ */
-@d u2l stack_2(ul_packet) /* $U'_2$ */
-@d u3l stack_3(ul_packet) /* $U'_3$ */
-@d v1l stack_1(vl_packet) /* $V'_1$ */
-@d v2l stack_2(vl_packet) /* $V'_2$ */
-@d v3l stack_3(vl_packet) /* $V'_3$ */
-@d x1l stack_1(xl_packet) /* $X'_1$ */
-@d x2l stack_2(xl_packet) /* $X'_2$ */
-@d x3l stack_3(xl_packet) /* $X'_3$ */
-@d y1l stack_1(yl_packet) /* $Y'_1$ */
-@d y2l stack_2(yl_packet) /* $Y'_2$ */
-@d y3l stack_3(yl_packet) /* $Y'_3$ */
-@d u1r stack_1(ur_packet) /* $U''_1$ */
-@d u2r stack_2(ur_packet) /* $U''_2$ */
-@d u3r stack_3(ur_packet) /* $U''_3$ */
-@d v1r stack_1(vr_packet) /* $V''_1$ */
-@d v2r stack_2(vr_packet) /* $V''_2$ */
-@d v3r stack_3(vr_packet) /* $V''_3$ */
-@d x1r stack_1(xr_packet) /* $X''_1$ */
-@d x2r stack_2(xr_packet) /* $X''_2$ */
-@d x3r stack_3(xr_packet) /* $X''_3$ */
-@d y1r stack_1(yr_packet) /* $Y''_1$ */
-@d y2r stack_2(yr_packet) /* $Y''_2$ */
-@d y3r stack_3(yr_packet) /* $Y''_3$ */
-@#
-@d stack_dx mp->bisect_stack[mp->bisect_ptr] /* stacked value of |delx| */
-@d stack_dy mp->bisect_stack[mp->bisect_ptr+1] /* stacked value of |dely| */
-@d stack_tol mp->bisect_stack[mp->bisect_ptr+2] /* stacked value of |tol| */
-@d stack_uv mp->bisect_stack[mp->bisect_ptr+3] /* stacked value of |uv| */
-@d stack_xy mp->bisect_stack[mp->bisect_ptr+4] /* stacked value of |xy| */
-@d int_increment (int_packets+int_packets+5) /* number of stack words per level */
-
-@<Glob...@>=
-integer *bisect_stack;
-unsigned int bisect_ptr;
-
-@ @<Allocate or initialize ...@>=
-mp->bisect_stack = xmalloc((bistack_size+1),sizeof(integer));
-
-@ @<Dealloc variables@>=
-xfree(mp->bisect_stack);
-
-@ @<Check the ``constant''...@>=
-if ( int_packets+17*int_increment>bistack_size ) mp->bad=19;
-
-@ Computation of the min and max is a tedious but fairly fast sequence of
-instructions; exactly four comparisons are made in each branch.
-
-@d set_min_max(A)
- if ( stack_1((A))<0 ) {
- if ( stack_3((A))>=0 ) {
- if ( stack_2((A))<0 ) stack_min((A))=stack_1((A))+stack_2((A));
- else stack_min((A))=stack_1((A));
- stack_max((A))=stack_1((A))+stack_2((A))+stack_3((A));
- if ( stack_max((A))<0 ) stack_max((A))=0;
- } else {
- stack_min((A))=stack_1((A))+stack_2((A))+stack_3((A));
- if ( stack_min((A))>stack_1((A)) ) stack_min((A))=stack_1((A));
- stack_max((A))=stack_1((A))+stack_2((A));
- if ( stack_max((A))<0 ) stack_max((A))=0;
- }
- } else if ( stack_3((A))<=0 ) {
- if ( stack_2((A))>0 ) stack_max((A))=stack_1((A))+stack_2((A));
- else stack_max((A))=stack_1((A));
- stack_min((A))=stack_1((A))+stack_2((A))+stack_3((A));
- if ( stack_min((A))>0 ) stack_min((A))=0;
- } else {
- stack_max((A))=stack_1((A))+stack_2((A))+stack_3((A));
- if ( stack_max((A))<stack_1((A)) ) stack_max((A))=stack_1((A));
- stack_min((A))=stack_1((A))+stack_2((A));
- if ( stack_min((A))>0 ) stack_min((A))=0;
- }
-
-@ It's convenient to keep the current values of $l$, $t_1$, and $t_2$ in
-the integer form $2^l+2^lt_1$ and $2^l+2^lt_2$. The |cubic_intersection|
-routine uses global variables |cur_t| and |cur_tt| for this purpose;
-after successful completion, |cur_t| and |cur_tt| will contain |unity|
-plus the |scaled| values of $t_1$ and~$t_2$.
-
-The values of |cur_t| and |cur_tt| will be set to zero if |cubic_intersection|
-finds no intersection. The routine gives up and gives an approximate answer
-if it has backtracked
-more than 5000 times (otherwise there are cases where several minutes
-of fruitless computation would be possible).
-
-@d max_patience 5000
-
-@<Glob...@>=
-integer cur_t;integer cur_tt; /* controls and results of |cubic_intersection| */
-integer time_to_go; /* this many backtracks before giving up */
-integer max_t; /* maximum of $2^{l+1}$ so far achieved */
-
-@ The given cubics $B(w_0,w_1,w_2,w_3;t)$ and
-$B(z_0,z_1,z_2,z_3;t)$ are specified in adjacent knot nodes |(p,link(p))|
-and |(pp,link(pp))|, respectively.
-
-@c void mp_cubic_intersection (MP mp,pointer p, pointer pp) {
- pointer q,qq; /* |link(p)|, |link(pp)| */
- mp->time_to_go=max_patience; mp->max_t=2;
- @<Initialize for intersections at level zero@>;
-CONTINUE:
- while (1) {
- if ( mp->delx-mp->tol<=stack_max(x_packet(mp->xy))-stack_min(u_packet(mp->uv)))
- if ( mp->delx+mp->tol>=stack_min(x_packet(mp->xy))-stack_max(u_packet(mp->uv)))
- if ( mp->dely-mp->tol<=stack_max(y_packet(mp->xy))-stack_min(v_packet(mp->uv)))
- if ( mp->dely+mp->tol>=stack_min(y_packet(mp->xy))-stack_max(v_packet(mp->uv)))
- {
- if ( mp->cur_t>=mp->max_t ){
- if ( mp->max_t==two ) { /* we've done 17 bisections */
- mp->cur_t=halfp(mp->cur_t+1);
- mp->cur_tt=halfp(mp->cur_tt+1);
- return;
- }
- mp->max_t+=mp->max_t; mp->appr_t=mp->cur_t; mp->appr_tt=mp->cur_tt;
- }
- @<Subdivide for a new level of intersection@>;
- goto CONTINUE;
- }
- if ( mp->time_to_go>0 ) {
- decr(mp->time_to_go);
- } else {
- while ( mp->appr_t<unity ) {
- mp->appr_t+=mp->appr_t; mp->appr_tt+=mp->appr_tt;
- }
- mp->cur_t=mp->appr_t; mp->cur_tt=mp->appr_tt; return;
- }
- @<Advance to the next pair |(cur_t,cur_tt)|@>;
- }
-}
-
-@ The following variables are global, although they are used only by
-|cubic_intersection|, because it is necessary on some machines to
-split |cubic_intersection| up into two procedures.
-
-@<Glob...@>=
-integer delx;integer dely; /* the components of $\Delta=2^l(w_0-z_0)$ */
-integer tol; /* bound on the uncertainty in the overlap test */
-unsigned int uv;
-unsigned int xy; /* pointers to the current packets of interest */
-integer three_l; /* |tol_step| times the bisection level */
-integer appr_t;integer appr_tt; /* best approximations known to the answers */
-
-@ We shall assume that the coordinates are sufficiently non-extreme that
-integer overflow will not occur.
-@^overflow in arithmetic@>
-
-@<Initialize for intersections at level zero@>=
-q=link(p); qq=link(pp); mp->bisect_ptr=int_packets;
-u1r=right_x(p)-x_coord(p); u2r=left_x(q)-right_x(p);
-u3r=x_coord(q)-left_x(q); set_min_max(ur_packet);
-v1r=right_y(p)-y_coord(p); v2r=left_y(q)-right_y(p);
-v3r=y_coord(q)-left_y(q); set_min_max(vr_packet);
-x1r=right_x(pp)-x_coord(pp); x2r=left_x(qq)-right_x(pp);
-x3r=x_coord(qq)-left_x(qq); set_min_max(xr_packet);
-y1r=right_y(pp)-y_coord(pp); y2r=left_y(qq)-right_y(pp);
-y3r=y_coord(qq)-left_y(qq); set_min_max(yr_packet);
-mp->delx=x_coord(p)-x_coord(pp); mp->dely=y_coord(p)-y_coord(pp);
-mp->tol=0; mp->uv=r_packets; mp->xy=r_packets;
-mp->three_l=0; mp->cur_t=1; mp->cur_tt=1
-
-@ @<Subdivide for a new level of intersection@>=
-stack_dx=mp->delx; stack_dy=mp->dely; stack_tol=mp->tol;
-stack_uv=mp->uv; stack_xy=mp->xy;
-mp->bisect_ptr=mp->bisect_ptr+int_increment;
-mp->cur_t+=mp->cur_t; mp->cur_tt+=mp->cur_tt;
-u1l=stack_1(u_packet(mp->uv)); u3r=stack_3(u_packet(mp->uv));
-u2l=half(u1l+stack_2(u_packet(mp->uv)));
-u2r=half(u3r+stack_2(u_packet(mp->uv)));
-u3l=half(u2l+u2r); u1r=u3l;
-set_min_max(ul_packet); set_min_max(ur_packet);
-v1l=stack_1(v_packet(mp->uv)); v3r=stack_3(v_packet(mp->uv));
-v2l=half(v1l+stack_2(v_packet(mp->uv)));
-v2r=half(v3r+stack_2(v_packet(mp->uv)));
-v3l=half(v2l+v2r); v1r=v3l;
-set_min_max(vl_packet); set_min_max(vr_packet);
-x1l=stack_1(x_packet(mp->xy)); x3r=stack_3(x_packet(mp->xy));
-x2l=half(x1l+stack_2(x_packet(mp->xy)));
-x2r=half(x3r+stack_2(x_packet(mp->xy)));
-x3l=half(x2l+x2r); x1r=x3l;
-set_min_max(xl_packet); set_min_max(xr_packet);
-y1l=stack_1(y_packet(mp->xy)); y3r=stack_3(y_packet(mp->xy));
-y2l=half(y1l+stack_2(y_packet(mp->xy)));
-y2r=half(y3r+stack_2(y_packet(mp->xy)));
-y3l=half(y2l+y2r); y1r=y3l;
-set_min_max(yl_packet); set_min_max(yr_packet);
-mp->uv=l_packets; mp->xy=l_packets;
-mp->delx+=mp->delx; mp->dely+=mp->dely;
-mp->tol=mp->tol-mp->three_l+mp->tol_step;
-mp->tol+=mp->tol; mp->three_l=mp->three_l+mp->tol_step
-
-@ @<Advance to the next pair |(cur_t,cur_tt)|@>=
-NOT_FOUND:
-if ( odd(mp->cur_tt) ) {
- if ( odd(mp->cur_t) ) {
- @<Descend to the previous level and |goto not_found|@>;
- } else {
- incr(mp->cur_t);
- mp->delx=mp->delx+stack_1(u_packet(mp->uv))+stack_2(u_packet(mp->uv))
- +stack_3(u_packet(mp->uv));
- mp->dely=mp->dely+stack_1(v_packet(mp->uv))+stack_2(v_packet(mp->uv))
- +stack_3(v_packet(mp->uv));
- mp->uv=mp->uv+int_packets; /* switch from |l_packets| to |r_packets| */
- decr(mp->cur_tt); mp->xy=mp->xy-int_packets;
- /* switch from |r_packets| to |l_packets| */
- mp->delx=mp->delx+stack_1(x_packet(mp->xy))+stack_2(x_packet(mp->xy))
- +stack_3(x_packet(mp->xy));
- mp->dely=mp->dely+stack_1(y_packet(mp->xy))+stack_2(y_packet(mp->xy))
- +stack_3(y_packet(mp->xy));
- }
-} else {
- incr(mp->cur_tt); mp->tol=mp->tol+mp->three_l;
- mp->delx=mp->delx-stack_1(x_packet(mp->xy))-stack_2(x_packet(mp->xy))
- -stack_3(x_packet(mp->xy));
- mp->dely=mp->dely-stack_1(y_packet(mp->xy))-stack_2(y_packet(mp->xy))
- -stack_3(y_packet(mp->xy));
- mp->xy=mp->xy+int_packets; /* switch from |l_packets| to |r_packets| */
-}
-
-@ @<Descend to the previous level...@>=
-{
- mp->cur_t=halfp(mp->cur_t); mp->cur_tt=halfp(mp->cur_tt);
- if ( mp->cur_t==0 ) return;
- mp->bisect_ptr=mp->bisect_ptr-int_increment;
- mp->three_l=mp->three_l-mp->tol_step;
- mp->delx=stack_dx; mp->dely=stack_dy; mp->tol=stack_tol;
- mp->uv=stack_uv; mp->xy=stack_xy;
- goto NOT_FOUND;
-}
-
-@ The |path_intersection| procedure is much simpler.
-It invokes |cubic_intersection| in lexicographic order until finding a
-pair of cubics that intersect. The final intersection times are placed in
-|cur_t| and~|cur_tt|.
-
-@c void mp_path_intersection (MP mp,pointer h, pointer hh) {
- pointer p,pp; /* link registers that traverse the given paths */
- integer n,nn; /* integer parts of intersection times, minus |unity| */
- @<Change one-point paths into dead cycles@>;
- mp->tol_step=0;
- do {
- n=-unity; p=h;
- do {
- if ( right_type(p)!=mp_endpoint ) {
- nn=-unity; pp=hh;
- do {
- if ( right_type(pp)!=mp_endpoint ) {
- mp_cubic_intersection(mp, p,pp);
- if ( mp->cur_t>0 ) {
- mp->cur_t=mp->cur_t+n; mp->cur_tt=mp->cur_tt+nn;
- return;
- }
- }
- nn=nn+unity; pp=link(pp);
- } while (pp!=hh);
- }
- n=n+unity; p=link(p);
- } while (p!=h);
- mp->tol_step=mp->tol_step+3;
- } while (mp->tol_step<=3);
- mp->cur_t=-unity; mp->cur_tt=-unity;
-}
-
-@ @<Change one-point paths...@>=
-if ( right_type(h)==mp_endpoint ) {
- right_x(h)=x_coord(h); left_x(h)=x_coord(h);
- right_y(h)=y_coord(h); left_y(h)=y_coord(h); right_type(h)=mp_explicit;
-}
-if ( right_type(hh)==mp_endpoint ) {
- right_x(hh)=x_coord(hh); left_x(hh)=x_coord(hh);
- right_y(hh)=y_coord(hh); left_y(hh)=y_coord(hh); right_type(hh)=mp_explicit;
-}
-
-@* \[24] Dynamic linear equations.
-\MP\ users define variables implicitly by stating equations that should be
-satisfied; the computer is supposed to be smart enough to solve those equations.
-And indeed, the computer tries valiantly to do so, by distinguishing five
-different types of numeric values:
-
-\smallskip\hang
-|type(p)=mp_known| is the nice case, when |value(p)| is the |scaled| value
-of the variable whose address is~|p|.
-
-\smallskip\hang
-|type(p)=mp_dependent| means that |value(p)| is not present, but |dep_list(p)|
-points to a {\sl dependency list\/} that expresses the value of variable~|p|
-as a |scaled| number plus a sum of independent variables with |fraction|
-coefficients.
-
-\smallskip\hang
-|type(p)=mp_independent| means that |value(p)=64s+m|, where |s>0| is a ``serial
-number'' reflecting the time this variable was first used in an equation;
-also |0<=m<64|, and each dependent variable
-that refers to this one is actually referring to the future value of
-this variable times~$2^m$. (Usually |m=0|, but higher degrees of
-scaling are sometimes needed to keep the coefficients in dependency lists
-from getting too large. The value of~|m| will always be even.)
-
-\smallskip\hang
-|type(p)=mp_numeric_type| means that variable |p| hasn't appeared in an
-equation before, but it has been explicitly declared to be numeric.
-
-\smallskip\hang
-|type(p)=undefined| means that variable |p| hasn't appeared before.
-
-\smallskip\noindent
-We have actually discussed these five types in the reverse order of their
-history during a computation: Once |known|, a variable never again
-becomes |dependent|; once |dependent|, it almost never again becomes
-|mp_independent|; once |mp_independent|, it never again becomes |mp_numeric_type|;
-and once |mp_numeric_type|, it never again becomes |undefined| (except
-of course when the user specifically decides to scrap the old value
-and start again). A backward step may, however, take place: Sometimes
-a |dependent| variable becomes |mp_independent| again, when one of the
-independent variables it depends on is reverting to |undefined|.
-
-
-The next patch detects overflow of independent-variable serial
-numbers. Diagnosed and patched by Thorsten Dahlheimer.
-
-@d s_scale 64 /* the serial numbers are multiplied by this factor */
-@d new_indep(A) /* create a new independent variable */
- { if ( mp->serial_no>el_gordo-s_scale )
- mp_fatal_error(mp, "variable instance identifiers exhausted");
- type((A))=mp_independent; mp->serial_no=mp->serial_no+s_scale;
- value((A))=mp->serial_no;
- }
-
-@<Glob...@>=
-integer serial_no; /* the most recent serial number, times |s_scale| */
-
-@ @<Make variable |q+s| newly independent@>=new_indep(q+s)
-
-@ But how are dependency lists represented? It's simple: The linear combination
-$\alpha_1v_1+\cdots+\alpha_kv_k+\beta$ appears in |k+1| value nodes. If
-|q=dep_list(p)| points to this list, and if |k>0|, then |value(q)=
-@t$\alpha_1$@>| (which is a |fraction|); |info(q)| points to the location
-of $\alpha_1$; and |link(p)| points to the dependency list
-$\alpha_2v_2+\cdots+\alpha_kv_k+\beta$. On the other hand if |k=0|,
-then |value(q)=@t$\beta$@>| (which is |scaled|) and |info(q)=null|.
-The independent variables $v_1$, \dots,~$v_k$ have been sorted so that
-they appear in decreasing order of their |value| fields (i.e., of
-their serial numbers). \ (It is convenient to use decreasing order,
-since |value(null)=0|. If the independent variables were not sorted by
-serial number but by some other criterion, such as their location in |mem|,
-the equation-solving mechanism would be too system-dependent, because
-the ordering can affect the computed results.)
-
-The |link| field in the node that contains the constant term $\beta$ is
-called the {\sl final link\/} of the dependency list. \MP\ maintains
-a doubly-linked master list of all dependency lists, in terms of a permanently
-allocated node
-in |mem| called |dep_head|. If there are no dependencies, we have
-|link(dep_head)=dep_head| and |prev_dep(dep_head)=dep_head|;
-otherwise |link(dep_head)| points to the first dependent variable, say~|p|,
-and |prev_dep(p)=dep_head|. We have |type(p)=mp_dependent|, and |dep_list(p)|
-points to its dependency list. If the final link of that dependency list
-occurs in location~|q|, then |link(q)| points to the next dependent
-variable (say~|r|); and we have |prev_dep(r)=q|, etc.
-
-@d dep_list(A) link(value_loc((A)))
- /* half of the |value| field in a |dependent| variable */
-@d prev_dep(A) info(value_loc((A)))
- /* the other half; makes a doubly linked list */
-@d dep_node_size 2 /* the number of words per dependency node */
-
-@<Initialize table entries...@>= mp->serial_no=0;
-link(dep_head)=dep_head; prev_dep(dep_head)=dep_head;
-info(dep_head)=null; dep_list(dep_head)=null;
-
-@ Actually the description above contains a little white lie. There's
-another kind of variable called |mp_proto_dependent|, which is
-just like a |dependent| one except that the $\alpha$ coefficients
-in its dependency list are |scaled| instead of being fractions.
-Proto-dependency lists are mixed with dependency lists in the
-nodes reachable from |dep_head|.
-
-@ Here is a procedure that prints a dependency list in symbolic form.
-The second parameter should be either |dependent| or |mp_proto_dependent|,
-to indicate the scaling of the coefficients.
-
-@<Declare subroutines for printing expressions@>=
-void mp_print_dependency (MP mp,pointer p, small_number t) {
- integer v; /* a coefficient */
- pointer pp,q; /* for list manipulation */
- pp=p;
- while (1) {
- v=abs(value(p)); q=info(p);
- if ( q==null ) { /* the constant term */
- if ( (v!=0)||(p==pp) ) {
- if ( value(p)>0 ) if ( p!=pp ) mp_print_char(mp, '+');
- mp_print_scaled(mp, value(p));
- }
- return;
- }
- @<Print the coefficient, unless it's $\pm1.0$@>;
- if ( type(q)!=mp_independent ) mp_confusion(mp, "dep");
-@:this can't happen dep}{\quad dep@>
- mp_print_variable_name(mp, q); v=value(q) % s_scale;
- while ( v>0 ) { mp_print(mp, "*4"); v=v-2; }
- p=link(p);
- }
-}
-
-@ @<Print the coefficient, unless it's $\pm1.0$@>=
-if ( value(p)<0 ) mp_print_char(mp, '-');
-else if ( p!=pp ) mp_print_char(mp, '+');
-if ( t==mp_dependent ) v=mp_round_fraction(mp, v);
-if ( v!=unity ) mp_print_scaled(mp, v)
-
-@ The maximum absolute value of a coefficient in a given dependency list
-is returned by the following simple function.
-
-@c fraction mp_max_coef (MP mp,pointer p) {
- fraction x; /* the maximum so far */
- x=0;
- while ( info(p)!=null ) {
- if ( abs(value(p))>x ) x=abs(value(p));
- p=link(p);
- }
- return x;
-}
-
-@ One of the main operations needed on dependency lists is to add a multiple
-of one list to the other; we call this |p_plus_fq|, where |p| and~|q| point
-to dependency lists and |f| is a fraction.
-
-If the coefficient of any independent variable becomes |coef_bound| or
-more, in absolute value, this procedure changes the type of that variable
-to `|independent_needing_fix|', and sets the global variable |fix_needed|
-to~|true|. The value of $|coef_bound|=\mu$ is chosen so that
-$\mu^2+\mu<8$; this means that the numbers we deal with won't
-get too large. (Instead of the ``optimum'' $\mu=(\sqrt{33}-1)/2\approx
-2.3723$, the safer value 7/3 is taken as the threshold.)
-
-The changes mentioned in the preceding paragraph are actually done only if
-the global variable |watch_coefs| is |true|. But it usually is; in fact,
-it is |false| only when \MP\ is making a dependency list that will soon
-be equated to zero.
-
-Several procedures that act on dependency lists, including |p_plus_fq|,
-set the global variable |dep_final| to the final (constant term) node of
-the dependency list that they produce.
-
-@d coef_bound 04525252525 /* |fraction| approximation to 7/3 */
-@d independent_needing_fix 0
-
-@<Glob...@>=
-boolean fix_needed; /* does at least one |independent| variable need scaling? */
-boolean watch_coefs; /* should we scale coefficients that exceed |coef_bound|? */
-pointer dep_final; /* location of the constant term and final link */
-
-@ @<Set init...@>=
-mp->fix_needed=false; mp->watch_coefs=true;
-
-@ The |p_plus_fq| procedure has a fourth parameter, |t|, that should be
-set to |mp_proto_dependent| if |p| is a proto-dependency list. In this
-case |f| will be |scaled|, not a |fraction|. Similarly, the fifth parameter~|tt|
-should be |mp_proto_dependent| if |q| is a proto-dependency list.
-
-List |q| is unchanged by the operation; but list |p| is totally destroyed.
-
-The final link of the dependency list or proto-dependency list returned
-by |p_plus_fq| is the same as the original final link of~|p|. Indeed, the
-constant term of the result will be located in the same |mem| location
-as the original constant term of~|p|.
-
-Coefficients of the result are assumed to be zero if they are less than
-a certain threshold. This compensates for inevitable rounding errors,
-and tends to make more variables `|known|'. The threshold is approximately
-$10^{-5}$ in the case of normal dependency lists, $10^{-4}$ for
-proto-dependencies.
-
-@d fraction_threshold 2685 /* a |fraction| coefficient less than this is zeroed */
-@d half_fraction_threshold 1342 /* half of |fraction_threshold| */
-@d scaled_threshold 8 /* a |scaled| coefficient less than this is zeroed */
-@d half_scaled_threshold 4 /* half of |scaled_threshold| */
-
-@<Declare basic dependency-list subroutines@>=
-pointer mp_p_plus_fq ( MP mp, pointer p, integer f,
- pointer q, small_number t, small_number tt) ;
-
-@ @c
-pointer mp_p_plus_fq ( MP mp, pointer p, integer f,
- pointer q, small_number t, small_number tt) {
- pointer pp,qq; /* |info(p)| and |info(q)|, respectively */
- pointer r,s; /* for list manipulation */
- integer threshold; /* defines a neighborhood of zero */
- integer v; /* temporary register */
- if ( t==mp_dependent ) threshold=fraction_threshold;
- else threshold=scaled_threshold;
- r=temp_head; pp=info(p); qq=info(q);
- while (1) {
- if ( pp==qq ) {
- if ( pp==null ) {
- break;
- } else {
- @<Contribute a term from |p|, plus |f| times the
- corresponding term from |q|@>
- }
- } else if ( value(pp)<value(qq) ) {
- @<Contribute a term from |q|, multiplied by~|f|@>
- } else {
- link(r)=p; r=p; p=link(p); pp=info(p);
- }
- }
- if ( t==mp_dependent )
- value(p)=mp_slow_add(mp, value(p),mp_take_fraction(mp, value(q),f));
- else
- value(p)=mp_slow_add(mp, value(p),mp_take_scaled(mp, value(q),f));
- link(r)=p; mp->dep_final=p;
- return link(temp_head);
-}
-
-@ @<Contribute a term from |p|, plus |f|...@>=
-{
- if ( tt==mp_dependent ) v=value(p)+mp_take_fraction(mp, f,value(q));
- else v=value(p)+mp_take_scaled(mp, f,value(q));
- value(p)=v; s=p; p=link(p);
- if ( abs(v)<threshold ) {
- mp_free_node(mp, s,dep_node_size);
- } else {
- if ( (abs(v)>=coef_bound) && mp->watch_coefs ) {
- type(qq)=independent_needing_fix; mp->fix_needed=true;
- }
- link(r)=s; r=s;
- };
- pp=info(p); q=link(q); qq=info(q);
-}
-
-@ @<Contribute a term from |q|, multiplied by~|f|@>=
-{
- if ( tt==mp_dependent ) v=mp_take_fraction(mp, f,value(q));
- else v=mp_take_scaled(mp, f,value(q));
- if ( abs(v)>halfp(threshold) ) {
- s=mp_get_node(mp, dep_node_size); info(s)=qq; value(s)=v;
- if ( (abs(v)>=coef_bound) && mp->watch_coefs ) {
- type(qq)=independent_needing_fix; mp->fix_needed=true;
- }
- link(r)=s; r=s;
- }
- q=link(q); qq=info(q);
-}
-
-@ It is convenient to have another subroutine for the special case
-of |p_plus_fq| when |f=1.0|. In this routine lists |p| and |q| are
-both of the same type~|t| (either |dependent| or |mp_proto_dependent|).
-
-@c pointer mp_p_plus_q (MP mp,pointer p, pointer q, small_number t) {
- pointer pp,qq; /* |info(p)| and |info(q)|, respectively */
- pointer r,s; /* for list manipulation */
- integer threshold; /* defines a neighborhood of zero */
- integer v; /* temporary register */
- if ( t==mp_dependent ) threshold=fraction_threshold;
- else threshold=scaled_threshold;
- r=temp_head; pp=info(p); qq=info(q);
- while (1) {
- if ( pp==qq ) {
- if ( pp==null ) {
- break;
- } else {
- @<Contribute a term from |p|, plus the
- corresponding term from |q|@>
- }
- } else {
- if ( value(pp)<value(qq) ) {
- s=mp_get_node(mp, dep_node_size); info(s)=qq; value(s)=value(q);
- q=link(q); qq=info(q); link(r)=s; r=s;
- } else {
- link(r)=p; r=p; p=link(p); pp=info(p);
- }
- }
- }
- value(p)=mp_slow_add(mp, value(p),value(q));
- link(r)=p; mp->dep_final=p;
- return link(temp_head);
-}
-
-@ @<Contribute a term from |p|, plus the...@>=
-{
- v=value(p)+value(q);
- value(p)=v; s=p; p=link(p); pp=info(p);
- if ( abs(v)<threshold ) {
- mp_free_node(mp, s,dep_node_size);
- } else {
- if ( (abs(v)>=coef_bound ) && mp->watch_coefs ) {
- type(qq)=independent_needing_fix; mp->fix_needed=true;
- }
- link(r)=s; r=s;
- }
- q=link(q); qq=info(q);
-}
-
-@ A somewhat simpler routine will multiply a dependency list
-by a given constant~|v|. The constant is either a |fraction| less than
-|fraction_one|, or it is |scaled|. In the latter case we might be forced to
-convert a dependency list to a proto-dependency list.
-Parameters |t0| and |t1| are the list types before and after;
-they should agree unless |t0=mp_dependent| and |t1=mp_proto_dependent|
-and |v_is_scaled=true|.
-
-@c pointer mp_p_times_v (MP mp,pointer p, integer v, small_number t0,
- small_number t1, boolean v_is_scaled) {
- pointer r,s; /* for list manipulation */
- integer w; /* tentative coefficient */
- integer threshold;
- boolean scaling_down;
- if ( t0!=t1 ) scaling_down=true; else scaling_down=(!v_is_scaled);
- if ( t1==mp_dependent ) threshold=half_fraction_threshold;
- else threshold=half_scaled_threshold;
- r=temp_head;
- while ( info(p)!=null ) {
- if ( scaling_down ) w=mp_take_fraction(mp, v,value(p));
- else w=mp_take_scaled(mp, v,value(p));
- if ( abs(w)<=threshold ) {
- s=link(p); mp_free_node(mp, p,dep_node_size); p=s;
- } else {
- if ( abs(w)>=coef_bound ) {
- mp->fix_needed=true; type(info(p))=independent_needing_fix;
- }
- link(r)=p; r=p; value(p)=w; p=link(p);
- }
- }
- link(r)=p;
- if ( v_is_scaled ) value(p)=mp_take_scaled(mp, value(p),v);
- else value(p)=mp_take_fraction(mp, value(p),v);
- return link(temp_head);
-}
-
-@ Similarly, we sometimes need to divide a dependency list
-by a given |scaled| constant.
-
-@<Declare basic dependency-list subroutines@>=
-pointer mp_p_over_v (MP mp,pointer p, scaled v, small_number
- t0, small_number t1) ;
-
-@ @c
-pointer mp_p_over_v (MP mp,pointer p, scaled v, small_number
- t0, small_number t1) {
- pointer r,s; /* for list manipulation */
- integer w; /* tentative coefficient */
- integer threshold;
- boolean scaling_down;
- if ( t0!=t1 ) scaling_down=true; else scaling_down=false;
- if ( t1==mp_dependent ) threshold=half_fraction_threshold;
- else threshold=half_scaled_threshold;
- r=temp_head;
- while ( info( p)!=null ) {
- if ( scaling_down ) {
- if ( abs(v)<02000000 ) w=mp_make_scaled(mp, value(p),v*010000);
- else w=mp_make_scaled(mp, mp_round_fraction(mp, value(p)),v);
- } else {
- w=mp_make_scaled(mp, value(p),v);
- }
- if ( abs(w)<=threshold ) {
- s=link(p); mp_free_node(mp, p,dep_node_size); p=s;
- } else {
- if ( abs(w)>=coef_bound ) {
- mp->fix_needed=true; type(info(p))=independent_needing_fix;
- }
- link(r)=p; r=p; value(p)=w; p=link(p);
- }
- }
- link(r)=p; value(p)=mp_make_scaled(mp, value(p),v);
- return link(temp_head);
-}
-
-@ Here's another utility routine for dependency lists. When an independent
-variable becomes dependent, we want to remove it from all existing
-dependencies. The |p_with_x_becoming_q| function computes the
-dependency list of~|p| after variable~|x| has been replaced by~|q|.
-
-This procedure has basically the same calling conventions as |p_plus_fq|:
-List~|q| is unchanged; list~|p| is destroyed; the constant node and the
-final link are inherited from~|p|; and the fourth parameter tells whether
-or not |p| is |mp_proto_dependent|. However, the global variable |dep_final|
-is not altered if |x| does not occur in list~|p|.
-
-@c pointer mp_p_with_x_becoming_q (MP mp,pointer p,
- pointer x, pointer q, small_number t) {
- pointer r,s; /* for list manipulation */
- integer v; /* coefficient of |x| */
- integer sx; /* serial number of |x| */
- s=p; r=temp_head; sx=value(x);
- while ( value(info(s))>sx ) { r=s; s=link(s); };
- if ( info(s)!=x ) {
- return p;
- } else {
- link(temp_head)=p; link(r)=link(s); v=value(s);
- mp_free_node(mp, s,dep_node_size);
- return mp_p_plus_fq(mp, link(temp_head),v,q,t,mp_dependent);
- }
-}
-
-@ Here's a simple procedure that reports an error when a variable
-has just received a known value that's out of the required range.
-
-@<Declare basic dependency-list subroutines@>=
-void mp_val_too_big (MP mp,scaled x) ;
-
-@ @c void mp_val_too_big (MP mp,scaled x) {
- if ( mp->internal[mp_warning_check]>0 ) {
- print_err("Value is too large ("); mp_print_scaled(mp, x); mp_print_char(mp, ')');
-@.Value is too large@>
- help4("The equation I just processed has given some variable")
- ("a value of 4096 or more. Continue and I'll try to cope")
- ("with that big value; but it might be dangerous.")
- ("(Set warningcheck:=0 to suppress this message.)");
- mp_error(mp);
- }
-}
-
-@ When a dependent variable becomes known, the following routine
-removes its dependency list. Here |p| points to the variable, and
-|q| points to the dependency list (which is one node long).
-
-@<Declare basic dependency-list subroutines@>=
-void mp_make_known (MP mp,pointer p, pointer q) ;
-
-@ @c void mp_make_known (MP mp,pointer p, pointer q) {
- int t; /* the previous type */
- prev_dep(link(q))=prev_dep(p);
- link(prev_dep(p))=link(q); t=type(p);
- type(p)=mp_known; value(p)=value(q); mp_free_node(mp, q,dep_node_size);
- if ( abs(value(p))>=fraction_one ) mp_val_too_big(mp, value(p));
- if (( mp->internal[mp_tracing_equations]>0) && mp_interesting(mp, p) ) {
- mp_begin_diagnostic(mp); mp_print_nl(mp, "#### ");
-@:]]]\#\#\#\#_}{\.{\#\#\#\#}@>
- mp_print_variable_name(mp, p);
- mp_print_char(mp, '='); mp_print_scaled(mp, value(p));
- mp_end_diagnostic(mp, false);
- }
- if (( mp->cur_exp==p ) && mp->cur_type==t ) {
- mp->cur_type=mp_known; mp->cur_exp=value(p);
- mp_free_node(mp, p,value_node_size);
- }
-}
-
-@ The |fix_dependencies| routine is called into action when |fix_needed|
-has been triggered. The program keeps a list~|s| of independent variables
-whose coefficients must be divided by~4.
-
-In unusual cases, this fixup process might reduce one or more coefficients
-to zero, so that a variable will become known more or less by default.
-
-@<Declare basic dependency-list subroutines@>=
-void mp_fix_dependencies (MP mp);
-
-@ @c void mp_fix_dependencies (MP mp) {
- pointer p,q,r,s,t; /* list manipulation registers */
- pointer x; /* an independent variable */
- r=link(dep_head); s=null;
- while ( r!=dep_head ){
- t=r;
- @<Run through the dependency list for variable |t|, fixing
- all nodes, and ending with final link~|q|@>;
- r=link(q);
- if ( q==dep_list(t) ) mp_make_known(mp, t,q);
- }
- while ( s!=null ) {
- p=link(s); x=info(s); free_avail(s); s=p;
- type(x)=mp_independent; value(x)=value(x)+2;
- }
- mp->fix_needed=false;
-}
-
-@ @d independent_being_fixed 1 /* this variable already appears in |s| */
-
-@<Run through the dependency list for variable |t|...@>=
-r=value_loc(t); /* |link(r)=dep_list(t)| */
-while (1) {
- q=link(r); x=info(q);
- if ( x==null ) break;
- if ( type(x)<=independent_being_fixed ) {
- if ( type(x)<independent_being_fixed ) {
- p=mp_get_avail(mp); link(p)=s; s=p;
- info(s)=x; type(x)=independent_being_fixed;
- }
- value(q)=value(q) / 4;
- if ( value(q)==0 ) {
- link(r)=link(q); mp_free_node(mp, q,dep_node_size); q=r;
- }
- }
- r=q;
-}
-
-
-@ The |new_dep| routine installs a dependency list~|p| into the value node~|q|,
-linking it into the list of all known dependencies. We assume that
-|dep_final| points to the final node of list~|p|.
-
-@c void mp_new_dep (MP mp,pointer q, pointer p) {
- pointer r; /* what used to be the first dependency */
- dep_list(q)=p; prev_dep(q)=dep_head;
- r=link(dep_head); link(mp->dep_final)=r; prev_dep(r)=mp->dep_final;
- link(dep_head)=q;
-}
-
-@ Here is one of the ways a dependency list gets started.
-The |const_dependency| routine produces a list that has nothing but
-a constant term.
-
-@c pointer mp_const_dependency (MP mp, scaled v) {
- mp->dep_final=mp_get_node(mp, dep_node_size);
- value(mp->dep_final)=v; info(mp->dep_final)=null;
- return mp->dep_final;
-}
-
-@ And here's a more interesting way to start a dependency list from scratch:
-The parameter to |single_dependency| is the location of an
-independent variable~|x|, and the result is the simple dependency list
-`|x+0|'.
-
-In the unlikely event that the given independent variable has been doubled so
-often that we can't refer to it with a nonzero coefficient,
-|single_dependency| returns the simple list `0'. This case can be
-recognized by testing that the returned list pointer is equal to
-|dep_final|.
-
-@c pointer mp_single_dependency (MP mp,pointer p) {
- pointer q; /* the new dependency list */
- integer m; /* the number of doublings */
- m=value(p) % s_scale;
- if ( m>28 ) {
- return mp_const_dependency(mp, 0);
- } else {
- q=mp_get_node(mp, dep_node_size);
- value(q)=two_to_the(28-m); info(q)=p;
- link(q)=mp_const_dependency(mp, 0);
- return q;
- }
-}
-
-@ We sometimes need to make an exact copy of a dependency list.
-
-@c pointer mp_copy_dep_list (MP mp,pointer p) {
- pointer q; /* the new dependency list */
- q=mp_get_node(mp, dep_node_size); mp->dep_final=q;
- while (1) {
- info(mp->dep_final)=info(p); value(mp->dep_final)=value(p);
- if ( info(mp->dep_final)==null ) break;
- link(mp->dep_final)=mp_get_node(mp, dep_node_size);
- mp->dep_final=link(mp->dep_final); p=link(p);
- }
- return q;
-}
-
-@ But how do variables normally become known? Ah, now we get to the heart of the
-equation-solving mechanism. The |linear_eq| procedure is given a |dependent|
-or |mp_proto_dependent| list,~|p|, in which at least one independent variable
-appears. It equates this list to zero, by choosing an independent variable
-with the largest coefficient and making it dependent on the others. The
-newly dependent variable is eliminated from all current dependencies,
-thereby possibly making other dependent variables known.
-
-The given list |p| is, of course, totally destroyed by all this processing.
-
-@c void mp_linear_eq (MP mp, pointer p, small_number t) {
- pointer q,r,s; /* for link manipulation */
- pointer x; /* the variable that loses its independence */
- integer n; /* the number of times |x| had been halved */
- integer v; /* the coefficient of |x| in list |p| */
- pointer prev_r; /* lags one step behind |r| */
- pointer final_node; /* the constant term of the new dependency list */
- integer w; /* a tentative coefficient */
- @<Find a node |q| in list |p| whose coefficient |v| is largest@>;
- x=info(q); n=value(x) % s_scale;
- @<Divide list |p| by |-v|, removing node |q|@>;
- if ( mp->internal[mp_tracing_equations]>0 ) {
- @<Display the new dependency@>;
- }
- @<Simplify all existing dependencies by substituting for |x|@>;
- @<Change variable |x| from |independent| to |dependent| or |known|@>;
- if ( mp->fix_needed ) mp_fix_dependencies(mp);
-}
-
-@ @<Find a node |q| in list |p| whose coefficient |v| is largest@>=
-q=p; r=link(p); v=value(q);
-while ( info(r)!=null ) {
- if ( abs(value(r))>abs(v) ) { q=r; v=value(r); };
- r=link(r);
-}
-
-@ Here we want to change the coefficients from |scaled| to |fraction|,
-except in the constant term. In the common case of a trivial equation
-like `\.{x=3.14}', we will have |v=-fraction_one|, |q=p|, and |t=mp_dependent|.
-
-@<Divide list |p| by |-v|, removing node |q|@>=
-s=temp_head; link(s)=p; r=p;
-do {
- if ( r==q ) {
- link(s)=link(r); mp_free_node(mp, r,dep_node_size);
- } else {
- w=mp_make_fraction(mp, value(r),v);
- if ( abs(w)<=half_fraction_threshold ) {
- link(s)=link(r); mp_free_node(mp, r,dep_node_size);
- } else {
- value(r)=-w; s=r;
- }
- }
- r=link(s);
-} while (info(r)!=null);
-if ( t==mp_proto_dependent ) {
- value(r)=-mp_make_scaled(mp, value(r),v);
-} else if ( v!=-fraction_one ) {
- value(r)=-mp_make_fraction(mp, value(r),v);
-}
-final_node=r; p=link(temp_head)
-
-@ @<Display the new dependency@>=
-if ( mp_interesting(mp, x) ) {
- mp_begin_diagnostic(mp); mp_print_nl(mp, "## ");
- mp_print_variable_name(mp, x);
-@:]]]\#\#_}{\.{\#\#}@>
- w=n;
- while ( w>0 ) { mp_print(mp, "*4"); w=w-2; };
- mp_print_char(mp, '='); mp_print_dependency(mp, p,mp_dependent);
- mp_end_diagnostic(mp, false);
-}
-
-@ @<Simplify all existing dependencies by substituting for |x|@>=
-prev_r=dep_head; r=link(dep_head);
-while ( r!=dep_head ) {
- s=dep_list(r); q=mp_p_with_x_becoming_q(mp, s,x,p,type(r));
- if ( info(q)==null ) {
- mp_make_known(mp, r,q);
- } else {
- dep_list(r)=q;
- do { q=link(q); } while (info(q)!=null);
- prev_r=q;
- }
- r=link(prev_r);
-}
-
-@ @<Change variable |x| from |independent| to |dependent| or |known|@>=
-if ( n>0 ) @<Divide list |p| by $2^n$@>;
-if ( info(p)==null ) {
- type(x)=mp_known;
- value(x)=value(p);
- if ( abs(value(x))>=fraction_one ) mp_val_too_big(mp, value(x));
- mp_free_node(mp, p,dep_node_size);
- if ( mp->cur_exp==x ) if ( mp->cur_type==mp_independent ) {
- mp->cur_exp=value(x); mp->cur_type=mp_known;
- mp_free_node(mp, x,value_node_size);
- }
-} else {
- type(x)=mp_dependent; mp->dep_final=final_node; mp_new_dep(mp, x,p);
- if ( mp->cur_exp==x ) if ( mp->cur_type==mp_independent ) mp->cur_type=mp_dependent;
-}
-
-@ @<Divide list |p| by $2^n$@>=
-{
- s=temp_head; link(temp_head)=p; r=p;
- do {
- if ( n>30 ) w=0;
- else w=value(r) / two_to_the(n);
- if ( (abs(w)<=half_fraction_threshold)&&(info(r)!=null) ) {
- link(s)=link(r);
- mp_free_node(mp, r,dep_node_size);
- } else {
- value(r)=w; s=r;
- }
- r=link(s);
- } while (info(s)!=null);
- p=link(temp_head);
-}
-
-@ The |check_mem| procedure, which is used only when \MP\ is being
-debugged, makes sure that the current dependency lists are well formed.
-
-@<Check the list of linear dependencies@>=
-q=dep_head; p=link(q);
-while ( p!=dep_head ) {
- if ( prev_dep(p)!=q ) {
- mp_print_nl(mp, "Bad PREVDEP at "); mp_print_int(mp, p);
-@.Bad PREVDEP...@>
- }
- p=dep_list(p);
- while (1) {
- r=info(p); q=p; p=link(q);
- if ( r==null ) break;
- if ( value(info(p))>=value(r) ) {
- mp_print_nl(mp, "Out of order at "); mp_print_int(mp, p);
-@.Out of order...@>
- }
- }
-}
-
-@* \[25] Dynamic nonlinear equations.
-Variables of numeric type are maintained by the general scheme of
-independent, dependent, and known values that we have just studied;
-and the components of pair and transform variables are handled in the
-same way. But \MP\ also has five other types of values: \&{boolean},
-\&{string}, \&{pen}, \&{path}, and \&{picture}; what about them?
-
-Equations are allowed between nonlinear quantities, but only in a
-simple form. Two variables that haven't yet been assigned values are
-either equal to each other, or they're not.
-
-Before a boolean variable has received a value, its type is |mp_unknown_boolean|;
-similarly, there are variables whose type is |mp_unknown_string|, |mp_unknown_pen|,
-|mp_unknown_path|, and |mp_unknown_picture|. In such cases the value is either
-|null| (which means that no other variables are equivalent to this one), or
-it points to another variable of the same undefined type. The pointers in the
-latter case form a cycle of nodes, which we shall call a ``ring.''
-Rings of undefined variables may include capsules, which arise as
-intermediate results within expressions or as \&{expr} parameters to macros.
-
-When one member of a ring receives a value, the same value is given to
-all the other members. In the case of paths and pictures, this implies
-making separate copies of a potentially large data structure; users should
-restrain their enthusiasm for such generality, unless they have lots and
-lots of memory space.
-
-@ The following procedure is called when a capsule node is being
-added to a ring (e.g., when an unknown variable is mentioned in an expression).
-
-@c pointer mp_new_ring_entry (MP mp,pointer p) {
- pointer q; /* the new capsule node */
- q=mp_get_node(mp, value_node_size); name_type(q)=mp_capsule;
- type(q)=type(p);
- if ( value(p)==null ) value(q)=p; else value(q)=value(p);
- value(p)=q;
- return q;
-}
-
-@ Conversely, we might delete a capsule or a variable before it becomes known.
-The following procedure simply detaches a quantity from its ring,
-without recycling the storage.
-
-@<Declare the recycling subroutines@>=
-void mp_ring_delete (MP mp,pointer p) {
- pointer q;
- q=value(p);
- if ( q!=null ) if ( q!=p ){
- while ( value(q)!=p ) q=value(q);
- value(q)=value(p);
- }
-}
-
-@ Eventually there might be an equation that assigns values to all of the
-variables in a ring. The |nonlinear_eq| subroutine does the necessary
-propagation of values.
-
-If the parameter |flush_p| is |true|, node |p| itself needn't receive a
-value, it will soon be recycled.
-
-@c void mp_nonlinear_eq (MP mp,integer v, pointer p, boolean flush_p) {
- small_number t; /* the type of ring |p| */
- pointer q,r; /* link manipulation registers */
- t=type(p)-unknown_tag; q=value(p);
- if ( flush_p ) type(p)=mp_vacuous; else p=q;
- do {
- r=value(q); type(q)=t;
- switch (t) {
- case mp_boolean_type: value(q)=v; break;
- case mp_string_type: value(q)=v; add_str_ref(v); break;
- case mp_pen_type: value(q)=copy_pen(v); break;
- case mp_path_type: value(q)=mp_copy_path(mp, v); break;
- case mp_picture_type: value(q)=v; add_edge_ref(v); break;
- } /* there ain't no more cases */
- q=r;
- } while (q!=p);
-}
-
-@ If two members of rings are equated, and if they have the same type,
-the |ring_merge| procedure is called on to make them equivalent.
-
-@c void mp_ring_merge (MP mp,pointer p, pointer q) {
- pointer r; /* traverses one list */
- r=value(p);
- while ( r!=p ) {
- if ( r==q ) {
- @<Exclaim about a redundant equation@>;
- return;
- };
- r=value(r);
- }
- r=value(p); value(p)=value(q); value(q)=r;
-}
-
-@ @<Exclaim about a redundant equation@>=
-{
- print_err("Redundant equation");
-@.Redundant equation@>
- help2("I already knew that this equation was true.")
- ("But perhaps no harm has been done; let's continue.");
- mp_put_get_error(mp);
-}
-
-@* \[26] Introduction to the syntactic routines.
-Let's pause a moment now and try to look at the Big Picture.
-The \MP\ program consists of three main parts: syntactic routines,
-semantic routines, and output routines. The chief purpose of the
-syntactic routines is to deliver the user's input to the semantic routines,
-while parsing expressions and locating operators and operands. The
-semantic routines act as an interpreter responding to these operators,
-which may be regarded as commands. And the output routines are
-periodically called on to produce compact font descriptions that can be
-used for typesetting or for making interim proof drawings. We have
-discussed the basic data structures and many of the details of semantic
-operations, so we are good and ready to plunge into the part of \MP\ that
-actually controls the activities.
-
-Our current goal is to come to grips with the |get_next| procedure,
-which is the keystone of \MP's input mechanism. Each call of |get_next|
-sets the value of three variables |cur_cmd|, |cur_mod|, and |cur_sym|,
-representing the next input token.
-$$\vbox{\halign{#\hfil\cr
- \hbox{|cur_cmd| denotes a command code from the long list of codes
- given earlier;}\cr
- \hbox{|cur_mod| denotes a modifier of the command code;}\cr
- \hbox{|cur_sym| is the hash address of the symbolic token that was
- just scanned,}\cr
- \hbox{\qquad or zero in the case of a numeric or string
- or capsule token.}\cr}}$$
-Underlying this external behavior of |get_next| is all the machinery
-necessary to convert from character files to tokens. At a given time we
-may be only partially finished with the reading of several files (for
-which \&{input} was specified), and partially finished with the expansion
-of some user-defined macros and/or some macro parameters, and partially
-finished reading some text that the user has inserted online,
-and so on. When reading a character file, the characters must be
-converted to tokens; comments and blank spaces must
-be removed, numeric and string tokens must be evaluated.
-
-To handle these situations, which might all be present simultaneously,
-\MP\ uses various stacks that hold information about the incomplete
-activities, and there is a finite state control for each level of the
-input mechanism. These stacks record the current state of an implicitly
-recursive process, but the |get_next| procedure is not recursive.
-
-@<Glob...@>=
-eight_bits cur_cmd; /* current command set by |get_next| */
-integer cur_mod; /* operand of current command */
-halfword cur_sym; /* hash address of current symbol */
-
-@ The |print_cmd_mod| routine prints a symbolic interpretation of a
-command code and its modifier.
-It consists of a rather tedious sequence of print
-commands, and most of it is essentially an inverse to the |primitive|
-routine that enters a \MP\ primitive into |hash| and |eqtb|. Therefore almost
-all of this procedure appears elsewhere in the program, together with the
-corresponding |primitive| calls.
-
-@<Declare the procedure called |print_cmd_mod|@>=
-void mp_print_cmd_mod (MP mp,integer c, integer m) {
- switch (c) {
- @<Cases of |print_cmd_mod| for symbolic printing of primitives@>
- default: mp_print(mp, "[unknown command code!]"); break;
- }
-}
-
-@ Here is a procedure that displays a given command in braces, in the
-user's transcript file.
-
-@d show_cur_cmd_mod mp_show_cmd_mod(mp, mp->cur_cmd,mp->cur_mod)
-
-@c
-void mp_show_cmd_mod (MP mp,integer c, integer m) {
- mp_begin_diagnostic(mp); mp_print_nl(mp, "{");
- mp_print_cmd_mod(mp, c,m); mp_print_char(mp, '}');
- mp_end_diagnostic(mp, false);
-}
-
-@* \[27] Input stacks and states.
-The state of \MP's input mechanism appears in the input stack, whose
-entries are records with five fields, called |index|, |start|, |loc|,
-|limit|, and |name|. The top element of this stack is maintained in a
-global variable for which no subscripting needs to be done; the other
-elements of the stack appear in an array. Hence the stack is declared thus:
-
-@<Types...@>=
-typedef struct {
- quarterword index_field;
- halfword start_field, loc_field, limit_field, name_field;
-} in_state_record;
-
-@ @<Glob...@>=
-in_state_record *input_stack;
-integer input_ptr; /* first unused location of |input_stack| */
-integer max_in_stack; /* largest value of |input_ptr| when pushing */
-in_state_record cur_input; /* the ``top'' input state */
-int stack_size; /* maximum number of simultaneous input sources */
-
-@ @<Allocate or initialize ...@>=
-mp->stack_size = 300;
-mp->input_stack = xmalloc((mp->stack_size+1),sizeof(in_state_record));
-
-@ @<Dealloc variables@>=
-xfree(mp->input_stack);
-
-@ We've already defined the special variable |loc==cur_input.loc_field|
-in our discussion of basic input-output routines. The other components of
-|cur_input| are defined in the same way:
-
-@d index mp->cur_input.index_field /* reference for buffer information */
-@d start mp->cur_input.start_field /* starting position in |buffer| */
-@d limit mp->cur_input.limit_field /* end of current line in |buffer| */
-@d name mp->cur_input.name_field /* name of the current file */
-
-@ Let's look more closely now at the five control variables
-(|index|,~|start|,~|loc|,~|limit|,~|name|),
-assuming that \MP\ is reading a line of characters that have been input
-from some file or from the user's terminal. There is an array called
-|buffer| that acts as a stack of all lines of characters that are
-currently being read from files, including all lines on subsidiary
-levels of the input stack that are not yet completed. \MP\ will return to
-the other lines when it is finished with the present input file.
-
-(Incidentally, on a machine with byte-oriented addressing, it would be
-appropriate to combine |buffer| with the |str_pool| array,
-letting the buffer entries grow downward from the top of the string pool
-and checking that these two tables don't bump into each other.)
-
-The line we are currently working on begins in position |start| of the
-buffer; the next character we are about to read is |buffer[loc]|; and
-|limit| is the location of the last character present. We always have
-|loc<=limit|. For convenience, |buffer[limit]| has been set to |"%"|, so
-that the end of a line is easily sensed.
-
-The |name| variable is a string number that designates the name of
-the current file, if we are reading an ordinary text file. Special codes
-|is_term..max_spec_src| indicate other sources of input text.
-
-@d is_term 0 /* |name| value when reading from the terminal for normal input */
-@d is_read 1 /* |name| value when executing a \&{readstring} or \&{readfrom} */
-@d is_scantok 2 /* |name| value when reading text generated by \&{scantokens} */
-@d max_spec_src is_scantok
-
-@ Additional information about the current line is available via the
-|index| variable, which counts how many lines of characters are present
-in the buffer below the current level. We have |index=0| when reading
-from the terminal and prompting the user for each line; then if the user types,
-e.g., `\.{input figs}', we will have |index=1| while reading
-the file \.{figs.mp}. However, it does not follow that |index| is the
-same as the input stack pointer, since many of the levels on the input
-stack may come from token lists and some |index| values may correspond
-to \.{MPX} files that are not currently on the stack.
-
-The global variable |in_open| is equal to the highest |index| value counting
-\.{MPX} files but excluding token-list input levels. Thus, the number of
-partially read lines in the buffer is |in_open+1| and we have |in_open>=index|
-when we are not reading a token list.
-
-If we are not currently reading from the terminal,
-we are reading from the file variable |input_file[index]|. We use
-the notation |terminal_input| as a convenient abbreviation for |name=is_term|,
-and |cur_file| as an abbreviation for |input_file[index]|.
-
-When \MP\ is not reading from the terminal, the global variable |line| contains
-the line number in the current file, for use in error messages. More precisely,
-|line| is a macro for |line_stack[index]| and the |line_stack| array gives
-the line number for each file in the |input_file| array.
-
-When an \.{MPX} file is opened the file name is stored in the |mpx_name|
-array so that the name doesn't get lost when the file is temporarily removed
-from the input stack.
-Thus when |input_file[k]| is an \.{MPX} file, its name is |mpx_name[k]|
-and it contains translated \TeX\ pictures for |input_file[k-1]|.
-Since this is not an \.{MPX} file, we have
-$$ \hbox{|mpx_name[k-1]<=absent|}. $$
-This |name| field is set to |finished| when |input_file[k]| is completely
-read.
-
-If more information about the input state is needed, it can be
-included in small arrays like those shown here. For example,
-the current page or segment number in the input file might be put
-into a variable |page|, that is really a macro for the current entry
-in `\ignorespaces|page_stack:array[0..max_in_open] of integer|\unskip'
-by analogy with |line_stack|.
-@^system dependencies@>
-
-@d terminal_input (name==is_term) /* are we reading from the terminal? */
-@d cur_file mp->input_file[index] /* the current |void *| variable */
-@d line mp->line_stack[index] /* current line number in the current source file */
-@d in_name mp->iname_stack[index] /* a string used to construct \.{MPX} file names */
-@d in_area mp->iarea_stack[index] /* another string for naming \.{MPX} files */
-@d absent 1 /* |name_field| value for unused |mpx_in_stack| entries */
-@d mpx_reading (mp->mpx_name[index]>absent)
- /* when reading a file, is it an \.{MPX} file? */
-@d finished 0
- /* |name_field| value when the corresponding \.{MPX} file is finished */
-
-@<Glob...@>=
-integer in_open; /* the number of lines in the buffer, less one */
-unsigned int open_parens; /* the number of open text files */
-void * *input_file ;
-integer *line_stack ; /* the line number for each file */
-char * *iname_stack; /* used for naming \.{MPX} files */
-char * *iarea_stack; /* used for naming \.{MPX} files */
-halfword*mpx_name ;
-
-@ @<Allocate or ...@>=
-mp->input_file = xmalloc((mp->max_in_open+1),sizeof(void *));
-mp->line_stack = xmalloc((mp->max_in_open+1),sizeof(integer));
-mp->iname_stack = xmalloc((mp->max_in_open+1),sizeof(char *));
-mp->iarea_stack = xmalloc((mp->max_in_open+1),sizeof(char *));
-mp->mpx_name = xmalloc((mp->max_in_open+1),sizeof(halfword));
-{
- int k;
- for (k=0;k<=mp->max_in_open;k++) {
- mp->iname_stack[k] =NULL;
- mp->iarea_stack[k] =NULL;
- }
-}
-
-@ @<Dealloc variables@>=
-{
- int l;
- for (l=0;l<=mp->max_in_open;l++) {
- xfree(mp->iname_stack[l]);
- xfree(mp->iarea_stack[l]);
- }
-}
-xfree(mp->input_file);
-xfree(mp->line_stack);
-xfree(mp->iname_stack);
-xfree(mp->iarea_stack);
-xfree(mp->mpx_name);
-
-
-@ However, all this discussion about input state really applies only to the
-case that we are inputting from a file. There is another important case,
-namely when we are currently getting input from a token list. In this case
-|index>max_in_open|, and the conventions about the other state variables
-are different:
-
-\yskip\hang|loc| is a pointer to the current node in the token list, i.e.,
-the node that will be read next. If |loc=null|, the token list has been
-fully read.
-
-\yskip\hang|start| points to the first node of the token list; this node
-may or may not contain a reference count, depending on the type of token
-list involved.
-
-\yskip\hang|token_type|, which takes the place of |index| in the
-discussion above, is a code number that explains what kind of token list
-is being scanned.
-
-\yskip\hang|name| points to the |eqtb| address of the control sequence
-being expanded, if the current token list is a macro not defined by
-\&{vardef}. Macros defined by \&{vardef} have |name=null|; their name
-can be deduced by looking at their first two parameters.
-
-\yskip\hang|param_start|, which takes the place of |limit|, tells where
-the parameters of the current macro or loop text begin in the |param_stack|.
-
-\yskip\noindent The |token_type| can take several values, depending on
-where the current token list came from:
-
-\yskip
-\indent|forever_text|, if the token list being scanned is the body of
-a \&{forever} loop;
-
-\indent|loop_text|, if the token list being scanned is the body of
-a \&{for} or \&{forsuffixes} loop;
-
-\indent|parameter|, if a \&{text} or \&{suffix} parameter is being scanned;
-
-\indent|backed_up|, if the token list being scanned has been inserted as
-`to be read again'.
-
-\indent|inserted|, if the token list being scanned has been inserted as
-part of error recovery;
-
-\indent|macro|, if the expansion of a user-defined symbolic token is being
-scanned.
-
-\yskip\noindent
-The token list begins with a reference count if and only if |token_type=
-macro|.
-@^reference counts@>
-
-@d token_type index /* type of current token list */
-@d token_state (index>(int)mp->max_in_open) /* are we scanning a token list? */
-@d file_state (index<=(int)mp->max_in_open) /* are we scanning a file line? */
-@d param_start limit /* base of macro parameters in |param_stack| */
-@d forever_text (mp->max_in_open+1) /* |token_type| code for loop texts */
-@d loop_text (mp->max_in_open+2) /* |token_type| code for loop texts */
-@d parameter (mp->max_in_open+3) /* |token_type| code for parameter texts */
-@d backed_up (mp->max_in_open+4) /* |token_type| code for texts to be reread */
-@d inserted (mp->max_in_open+5) /* |token_type| code for inserted texts */
-@d macro (mp->max_in_open+6) /* |token_type| code for macro replacement texts */
-
-@ The |param_stack| is an auxiliary array used to hold pointers to the token
-lists for parameters at the current level and subsidiary levels of input.
-This stack grows at a different rate from the others.
-
-@<Glob...@>=
-pointer *param_stack; /* token list pointers for parameters */
-integer param_ptr; /* first unused entry in |param_stack| */
-integer max_param_stack; /* largest value of |param_ptr| */
-
-@ @<Allocate or initialize ...@>=
-mp->param_stack = xmalloc((mp->param_size+1),sizeof(pointer));
-
-@ @<Dealloc variables@>=
-xfree(mp->param_stack);
-
-@ Notice that the |line| isn't valid when |token_state| is true because it
-depends on |index|. If we really need to know the line number for the
-topmost file in the index stack we use the following function. If a page
-number or other information is needed, this routine should be modified to
-compute it as well.
-@^system dependencies@>
-
-@<Declare a function called |true_line|@>=
-integer mp_true_line (MP mp) {
- int k; /* an index into the input stack */
- if ( file_state && (name>max_spec_src) ) {
- return line;
- } else {
- k=mp->input_ptr;
- while ((k>0) &&
- ((mp->input_stack[(k-1)].index_field>mp->max_in_open)||
- (mp->input_stack[(k-1)].name_field<=max_spec_src))) {
- decr(k);
- }
- return (k>0 ? mp->line_stack[(k-1)] : 0 );
- }
-}
-
-@ Thus, the ``current input state'' can be very complicated indeed; there
-can be many levels and each level can arise in a variety of ways. The
-|show_context| procedure, which is used by \MP's error-reporting routine to
-print out the current input state on all levels down to the most recent
-line of characters from an input file, illustrates most of these conventions.
-The global variable |file_ptr| contains the lowest level that was
-displayed by this procedure.
-
-@<Glob...@>=
-integer file_ptr; /* shallowest level shown by |show_context| */
-
-@ The status at each level is indicated by printing two lines, where the first
-line indicates what was read so far and the second line shows what remains
-to be read. The context is cropped, if necessary, so that the first line
-contains at most |half_error_line| characters, and the second contains
-at most |error_line|. Non-current input levels whose |token_type| is
-`|backed_up|' are shown only if they have not been fully read.
-
-@c void mp_show_context (MP mp) { /* prints where the scanner is */
- int old_setting; /* saved |selector| setting */
- @<Local variables for formatting calculations@>
- mp->file_ptr=mp->input_ptr; mp->input_stack[mp->file_ptr]=mp->cur_input;
- /* store current state */
- while (1) {
- mp->cur_input=mp->input_stack[mp->file_ptr]; /* enter into the context */
- @<Display the current context@>;
- if ( file_state )
- if ( (name>max_spec_src) || (mp->file_ptr==0) ) break;
- decr(mp->file_ptr);
- }
- mp->cur_input=mp->input_stack[mp->input_ptr]; /* restore original state */
-}
-
-@ @<Display the current context@>=
-if ( (mp->file_ptr==mp->input_ptr) || file_state ||
- (token_type!=backed_up) || (loc!=null) ) {
- /* we omit backed-up token lists that have already been read */
- mp->tally=0; /* get ready to count characters */
- old_setting=mp->selector;
- if ( file_state ) {
- @<Print location of current line@>;
- @<Pseudoprint the line@>;
- } else {
- @<Print type of token list@>;
- @<Pseudoprint the token list@>;
- }
- mp->selector=old_setting; /* stop pseudoprinting */
- @<Print two lines using the tricky pseudoprinted information@>;
-}
-
-@ This routine should be changed, if necessary, to give the best possible
-indication of where the current line resides in the input file.
-For example, on some systems it is best to print both a page and line number.
-@^system dependencies@>
-
-@<Print location of current line@>=
-if ( name>max_spec_src ) {
- mp_print_nl(mp, "l."); mp_print_int(mp, mp_true_line(mp));
-} else if ( terminal_input ) {
- if ( mp->file_ptr==0 ) mp_print_nl(mp, "<*>");
- else mp_print_nl(mp, "<insert>");
-} else if ( name==is_scantok ) {
- mp_print_nl(mp, "<scantokens>");
-} else {
- mp_print_nl(mp, "<read>");
-}
-mp_print_char(mp, ' ')
-
-@ Can't use case statement here because the |token_type| is not
-a constant expression.
-
-@<Print type of token list@>=
-{
- if(token_type==forever_text) {
- mp_print_nl(mp, "<forever> ");
- } else if (token_type==loop_text) {
- @<Print the current loop value@>;
- } else if (token_type==parameter) {
- mp_print_nl(mp, "<argument> ");
- } else if (token_type==backed_up) {
- if ( loc==null ) mp_print_nl(mp, "<recently read> ");
- else mp_print_nl(mp, "<to be read again> ");
- } else if (token_type==inserted) {
- mp_print_nl(mp, "<inserted text> ");
- } else if (token_type==macro) {
- mp_print_ln(mp);
- if ( name!=null ) mp_print_text(name);
- else @<Print the name of a \&{vardef}'d macro@>;
- mp_print(mp, "->");
- } else {
- mp_print_nl(mp, "?");/* this should never happen */
-@.?\relax@>
- }
-}
-
-@ The parameter that corresponds to a loop text is either a token list
-(in the case of \&{forsuffixes}) or a ``capsule'' (in the case of \&{for}).
-We'll discuss capsules later; for now, all we need to know is that
-the |link| field in a capsule parameter is |void| and that
-|print_exp(p,0)| displays the value of capsule~|p| in abbreviated form.
-
-@<Print the current loop value@>=
-{ mp_print_nl(mp, "<for("); p=mp->param_stack[param_start];
- if ( p!=null ) {
- if ( link(p)==mp_void ) mp_print_exp(mp, p,0); /* we're in a \&{for} loop */
- else mp_show_token_list(mp, p,null,20,mp->tally);
- }
- mp_print(mp, ")> ");
-}
-
-@ The first two parameters of a macro defined by \&{vardef} will be token
-lists representing the macro's prefix and ``at point.'' By putting these
-together, we get the macro's full name.
-
-@<Print the name of a \&{vardef}'d macro@>=
-{ p=mp->param_stack[param_start];
- if ( p==null ) {
- mp_show_token_list(mp, mp->param_stack[param_start+1],null,20,mp->tally);
- } else {
- q=p;
- while ( link(q)!=null ) q=link(q);
- link(q)=mp->param_stack[param_start+1];
- mp_show_token_list(mp, p,null,20,mp->tally);
- link(q)=null;
- }
-}
-
-@ Now it is necessary to explain a little trick. We don't want to store a long
-string that corresponds to a token list, because that string might take up
-lots of memory; and we are printing during a time when an error message is
-being given, so we dare not do anything that might overflow one of \MP's
-tables. So `pseudoprinting' is the answer: We enter a mode of printing
-that stores characters into a buffer of length |error_line|, where character
-$k+1$ is placed into \hbox{|trick_buf[k mod error_line]|} if
-|k<trick_count|, otherwise character |k| is dropped. Initially we set
-|tally:=0| and |trick_count:=1000000|; then when we reach the
-point where transition from line 1 to line 2 should occur, we
-set |first_count:=tally| and |trick_count:=@tmax@>(error_line,
-tally+1+error_line-half_error_line)|. At the end of the
-pseudoprinting, the values of |first_count|, |tally|, and
-|trick_count| give us all the information we need to print the two lines,
-and all of the necessary text is in |trick_buf|.
-
-Namely, let |l| be the length of the descriptive information that appears
-on the first line. The length of the context information gathered for that
-line is |k=first_count|, and the length of the context information
-gathered for line~2 is $m=\min(|tally|, |trick_count|)-k$. If |l+k<=h|,
-where |h=half_error_line|, we print |trick_buf[0..k-1]| after the
-descriptive information on line~1, and set |n:=l+k|; here |n| is the
-length of line~1. If $l+k>h$, some cropping is necessary, so we set |n:=h|
-and print `\.{...}' followed by
-$$\hbox{|trick_buf[(l+k-h+3)..k-1]|,}$$
-where subscripts of |trick_buf| are circular modulo |error_line|. The
-second line consists of |n|~spaces followed by |trick_buf[k..(k+m-1)]|,
-unless |n+m>error_line|; in the latter case, further cropping is done.
-This is easier to program than to explain.
-
-@<Local variables for formatting...@>=
-int i; /* index into |buffer| */
-integer l; /* length of descriptive information on line 1 */
-integer m; /* context information gathered for line 2 */
-int n; /* length of line 1 */
-integer p; /* starting or ending place in |trick_buf| */
-integer q; /* temporary index */
-
-@ The following code tells the print routines to gather
-the desired information.
-
-@d begin_pseudoprint {
- l=mp->tally; mp->tally=0; mp->selector=pseudo;
- mp->trick_count=1000000;
-}
-@d set_trick_count {
- mp->first_count=mp->tally;
- mp->trick_count=mp->tally+1+mp->error_line-mp->half_error_line;
- if ( mp->trick_count<mp->error_line ) mp->trick_count=mp->error_line;
-}
-
-@ And the following code uses the information after it has been gathered.
-
-@<Print two lines using the tricky pseudoprinted information@>=
-if ( mp->trick_count==1000000 ) set_trick_count;
- /* |set_trick_count| must be performed */
-if ( mp->tally<mp->trick_count ) m=mp->tally-mp->first_count;
-else m=mp->trick_count-mp->first_count; /* context on line 2 */
-if ( l+mp->first_count<=mp->half_error_line ) {
- p=0; n=l+mp->first_count;
-} else {
- mp_print(mp, "..."); p=l+mp->first_count-mp->half_error_line+3;
- n=mp->half_error_line;
-}
-for (q=p;q<=mp->first_count-1;q++) {
- mp_print_char(mp, mp->trick_buf[q % mp->error_line]);
-}
-mp_print_ln(mp);
-for (q=1;q<=n;q++) {
- mp_print_char(mp, ' '); /* print |n| spaces to begin line~2 */
-}
-if ( m+n<=mp->error_line ) p=mp->first_count+m;
-else p=mp->first_count+(mp->error_line-n-3);
-for (q=mp->first_count;q<=p-1;q++) {
- mp_print_char(mp, mp->trick_buf[q % mp->error_line]);
-}
-if ( m+n>mp->error_line ) mp_print(mp, "...")
-
-@ But the trick is distracting us from our current goal, which is to
-understand the input state. So let's concentrate on the data structures that
-are being pseudoprinted as we finish up the |show_context| procedure.
-
-@<Pseudoprint the line@>=
-begin_pseudoprint;
-if ( limit>0 ) {
- for (i=start;i<=limit-1;i++) {
- if ( i==loc ) set_trick_count;
- mp_print_str(mp, mp->buffer[i]);
- }
-}
-
-@ @<Pseudoprint the token list@>=
-begin_pseudoprint;
-if ( token_type!=macro ) mp_show_token_list(mp, start,loc,100000,0);
-else mp_show_macro(mp, start,loc,100000)
-
-@ Here is the missing piece of |show_token_list| that is activated when the
-token beginning line~2 is about to be shown:
-
-@<Do magic computation@>=set_trick_count
-
-@* \[28] Maintaining the input stacks.
-The following subroutines change the input status in commonly needed ways.
-
-First comes |push_input|, which stores the current state and creates a
-new level (having, initially, the same properties as the old).
-
-@d push_input { /* enter a new input level, save the old */
- if ( mp->input_ptr>mp->max_in_stack ) {
- mp->max_in_stack=mp->input_ptr;
- if ( mp->input_ptr==mp->stack_size ) {
- int l = (mp->stack_size+(mp->stack_size>>2));
- XREALLOC(mp->input_stack, l, in_state_record);
- mp->stack_size = l;
- }
- }
- mp->input_stack[mp->input_ptr]=mp->cur_input; /* stack the record */
- incr(mp->input_ptr);
-}
-
-@ And of course what goes up must come down.
-
-@d pop_input { /* leave an input level, re-enter the old */
- decr(mp->input_ptr); mp->cur_input=mp->input_stack[mp->input_ptr];
- }
-
-@ Here is a procedure that starts a new level of token-list input, given
-a token list |p| and its type |t|. If |t=macro|, the calling routine should
-set |name|, reset~|loc|, and increase the macro's reference count.
-
-@d back_list(A) mp_begin_token_list(mp, (A),backed_up) /* backs up a simple token list */
-
-@c void mp_begin_token_list (MP mp,pointer p, quarterword t) {
- push_input; start=p; token_type=t;
- param_start=mp->param_ptr; loc=p;
-}
-
-@ When a token list has been fully scanned, the following computations
-should be done as we leave that level of input.
-@^inner loop@>
-
-@c void mp_end_token_list (MP mp) { /* leave a token-list input level */
- pointer p; /* temporary register */
- if ( token_type>=backed_up ) { /* token list to be deleted */
- if ( token_type<=inserted ) {
- mp_flush_token_list(mp, start); goto DONE;
- } else {
- mp_delete_mac_ref(mp, start); /* update reference count */
- }
- }
- while ( mp->param_ptr>param_start ) { /* parameters must be flushed */
- decr(mp->param_ptr);
- p=mp->param_stack[mp->param_ptr];
- if ( p!=null ) {
- if ( link(p)==mp_void ) { /* it's an \&{expr} parameter */
- mp_recycle_value(mp, p); mp_free_node(mp, p,value_node_size);
- } else {
- mp_flush_token_list(mp, p); /* it's a \&{suffix} or \&{text} parameter */
- }
- }
- }
-DONE:
- pop_input; check_interrupt;
-}
-
-@ The contents of |cur_cmd,cur_mod,cur_sym| are placed into an equivalent
-token by the |cur_tok| routine.
-@^inner loop@>
-
-@c @<Declare the procedure called |make_exp_copy|@>
-pointer mp_cur_tok (MP mp) {
- pointer p; /* a new token node */
- small_number save_type; /* |cur_type| to be restored */
- integer save_exp; /* |cur_exp| to be restored */
- if ( mp->cur_sym==0 ) {
- if ( mp->cur_cmd==capsule_token ) {
- save_type=mp->cur_type; save_exp=mp->cur_exp;
- mp_make_exp_copy(mp, mp->cur_mod); p=mp_stash_cur_exp(mp); link(p)=null;
- mp->cur_type=save_type; mp->cur_exp=save_exp;
- } else {
- p=mp_get_node(mp, token_node_size);
- value(p)=mp->cur_mod; name_type(p)=mp_token;
- if ( mp->cur_cmd==numeric_token ) type(p)=mp_known;
- else type(p)=mp_string_type;
- }
- } else {
- fast_get_avail(p); info(p)=mp->cur_sym;
- }
- return p;
-}
-
-@ Sometimes \MP\ has read too far and wants to ``unscan'' what it has
-seen. The |back_input| procedure takes care of this by putting the token
-just scanned back into the input stream, ready to be read again.
-If |cur_sym<>0|, the values of |cur_cmd| and |cur_mod| are irrelevant.
-
-@<Declarations@>=
-void mp_back_input (MP mp);
-
-@ @c void mp_back_input (MP mp) {/* undoes one token of input */
- pointer p; /* a token list of length one */
- p=mp_cur_tok(mp);
- while ( token_state &&(loc==null) )
- mp_end_token_list(mp); /* conserve stack space */
- back_list(p);
-}
-
-@ The |back_error| routine is used when we want to restore or replace an
-offending token just before issuing an error message. We disable interrupts
-during the call of |back_input| so that the help message won't be lost.
-
-@<Declarations@>=
-void mp_error (MP mp);
-void mp_back_error (MP mp);
-
-@ @c void mp_back_error (MP mp) { /* back up one token and call |error| */
- mp->OK_to_interrupt=false;
- mp_back_input(mp);
- mp->OK_to_interrupt=true; mp_error(mp);
-}
-void mp_ins_error (MP mp) { /* back up one inserted token and call |error| */
- mp->OK_to_interrupt=false;
- mp_back_input(mp); token_type=inserted;
- mp->OK_to_interrupt=true; mp_error(mp);
-}
-
-@ The |begin_file_reading| procedure starts a new level of input for lines
-of characters to be read from a file, or as an insertion from the
-terminal. It does not take care of opening the file, nor does it set |loc|
-or |limit| or |line|.
-@^system dependencies@>
-
-@c void mp_begin_file_reading (MP mp) {
- if ( mp->in_open==mp->max_in_open )
- mp_overflow(mp, "text input levels",mp->max_in_open);
-@:MetaPost capacity exceeded text input levels}{\quad text input levels@>
- if ( mp->first==mp->buf_size )
- mp_reallocate_buffer(mp,(mp->buf_size+(mp->buf_size>>2)));
- incr(mp->in_open); push_input; index=mp->in_open;
- mp->mpx_name[index]=absent;
- start=mp->first;
- name=is_term; /* |terminal_input| is now |true| */
-}
-
-@ Conversely, the variables must be downdated when such a level of input
-is finished. Any associated \.{MPX} file must also be closed and popped
-off the file stack.
-
-@c void mp_end_file_reading (MP mp) {
- if ( mp->in_open>index ) {
- if ( (mp->mpx_name[mp->in_open]==absent)||(name<=max_spec_src) ) {
- mp_confusion(mp, "endinput");
-@:this can't happen endinput}{\quad endinput@>
- } else {
- (mp->close_file)(mp,mp->input_file[mp->in_open]); /* close an \.{MPX} file */
- delete_str_ref(mp->mpx_name[mp->in_open]);
- decr(mp->in_open);
- }
- }
- mp->first=start;
- if ( index!=mp->in_open ) mp_confusion(mp, "endinput");
- if ( name>max_spec_src ) {
- (mp->close_file)(mp,cur_file);
- delete_str_ref(name);
- xfree(in_name);
- xfree(in_area);
- }
- pop_input; decr(mp->in_open);
-}
-
-@ Here is a function that tries to resume input from an \.{MPX} file already
-associated with the current input file. It returns |false| if this doesn't
-work.
-
-@c boolean mp_begin_mpx_reading (MP mp) {
- if ( mp->in_open!=index+1 ) {
- return false;
- } else {
- if ( mp->mpx_name[mp->in_open]<=absent ) mp_confusion(mp, "mpx");
-@:this can't happen mpx}{\quad mpx@>
- if ( mp->first==mp->buf_size )
- mp_reallocate_buffer(mp,(mp->buf_size+(mp->buf_size>>2)));
- push_input; index=mp->in_open;
- start=mp->first;
- name=mp->mpx_name[mp->in_open]; add_str_ref(name);
- @<Put an empty line in the input buffer@>;
- return true;
- }
-}
-
-@ This procedure temporarily stops reading an \.{MPX} file.
-
-@c void mp_end_mpx_reading (MP mp) {
- if ( mp->in_open!=index ) mp_confusion(mp, "mpx");
-@:this can't happen mpx}{\quad mpx@>
- if ( loc<limit ) {
- @<Complain that we are not at the end of a line in the \.{MPX} file@>;
- }
- mp->first=start;
- pop_input;
-}
-
-@ Here we enforce a restriction that simplifies the input stacks considerably.
-This should not inconvenience the user because \.{MPX} files are generated
-by an auxiliary program called \.{DVItoMP}.
-
-@ @<Complain that we are not at the end of a line in the \.{MPX} file@>=
-{
-print_err("`mpxbreak' must be at the end of a line");
-help4("This file contains picture expressions for btex...etex")
- ("blocks. Such files are normally generated automatically")
- ("but this one seems to be messed up. I'm going to ignore")
- ("the rest of this line.");
-mp_error(mp);
-}
-
-@ In order to keep the stack from overflowing during a long sequence of
-inserted `\.{show}' commands, the following routine removes completed
-error-inserted lines from memory.
-
-@c void mp_clear_for_error_prompt (MP mp) {
- while ( file_state && terminal_input &&
- (mp->input_ptr>0)&&(loc==limit) ) mp_end_file_reading(mp);
- mp_print_ln(mp); clear_terminal;
-}
-
-@ To get \MP's whole input mechanism going, we perform the following
-actions.
-
-@<Initialize the input routines@>=
-{ mp->input_ptr=0; mp->max_in_stack=0;
- mp->in_open=0; mp->open_parens=0; mp->max_buf_stack=0;
- mp->param_ptr=0; mp->max_param_stack=0;
- mp->first=1;
- start=1; index=0; line=0; name=is_term;
- mp->mpx_name[0]=absent;
- mp->force_eof=false;
- if ( ! mp_init_terminal(mp) ) mp_jump_out(mp);
- limit=mp->last; mp->first=mp->last+1;
- /* |init_terminal| has set |loc| and |last| */
-}
-
-@* \[29] Getting the next token.
-The heart of \MP's input mechanism is the |get_next| procedure, which
-we shall develop in the next few sections of the program. Perhaps we
-shouldn't actually call it the ``heart,'' however; it really acts as \MP's
-eyes and mouth, reading the source files and gobbling them up. And it also
-helps \MP\ to regurgitate stored token lists that are to be processed again.
-
-The main duty of |get_next| is to input one token and to set |cur_cmd|
-and |cur_mod| to that token's command code and modifier. Furthermore, if
-the input token is a symbolic token, that token's |hash| address
-is stored in |cur_sym|; otherwise |cur_sym| is set to zero.
-
-Underlying this simple description is a certain amount of complexity
-because of all the cases that need to be handled.
-However, the inner loop of |get_next| is reasonably short and fast.
-
-@ Before getting into |get_next|, we need to consider a mechanism by which
-\MP\ helps keep errors from propagating too far. Whenever the program goes
-into a mode where it keeps calling |get_next| repeatedly until a certain
-condition is met, it sets |scanner_status| to some value other than |normal|.
-Then if an input file ends, or if an `\&{outer}' symbol appears,
-an appropriate error recovery will be possible.
-
-The global variable |warning_info| helps in this error recovery by providing
-additional information. For example, |warning_info| might indicate the
-name of a macro whose replacement text is being scanned.
-
-@d normal 0 /* |scanner_status| at ``quiet times'' */
-@d skipping 1 /* |scanner_status| when false conditional text is being skipped */
-@d flushing 2 /* |scanner_status| when junk after a statement is being ignored */
-@d absorbing 3 /* |scanner_status| when a \&{text} parameter is being scanned */
-@d var_defining 4 /* |scanner_status| when a \&{vardef} is being scanned */
-@d op_defining 5 /* |scanner_status| when a macro \&{def} is being scanned */
-@d loop_defining 6 /* |scanner_status| when a \&{for} loop is being scanned */
-@d tex_flushing 7 /* |scanner_status| when skipping \TeX\ material */
-
-@<Glob...@>=
-integer scanner_status; /* are we scanning at high speed? */
-integer warning_info; /* if so, what else do we need to know,
- in case an error occurs? */
-
-@ @<Initialize the input routines@>=
-mp->scanner_status=normal;
-
-@ The following subroutine
-is called when an `\&{outer}' symbolic token has been scanned or
-when the end of a file has been reached. These two cases are distinguished
-by |cur_sym|, which is zero at the end of a file.
-
-@c boolean mp_check_outer_validity (MP mp) {
- pointer p; /* points to inserted token list */
- if ( mp->scanner_status==normal ) {
- return true;
- } else if ( mp->scanner_status==tex_flushing ) {
- @<Check if the file has ended while flushing \TeX\ material and set the
- result value for |check_outer_validity|@>;
- } else {
- mp->deletions_allowed=false;
- @<Back up an outer symbolic token so that it can be reread@>;
- if ( mp->scanner_status>skipping ) {
- @<Tell the user what has run away and try to recover@>;
- } else {
- print_err("Incomplete if; all text was ignored after line ");
-@.Incomplete if...@>
- mp_print_int(mp, mp->warning_info);
- help3("A forbidden `outer' token occurred in skipped text.")
- ("This kind of error happens when you say `if...' and forget")
- ("the matching `fi'. I've inserted a `fi'; this might work.");
- if ( mp->cur_sym==0 )
- mp->help_line[2]="The file ended while I was skipping conditional text.";
- mp->cur_sym=frozen_fi; mp_ins_error(mp);
- }
- mp->deletions_allowed=true;
- return false;
- }
-}
-
-@ @<Check if the file has ended while flushing \TeX\ material and set...@>=
-if ( mp->cur_sym!=0 ) {
- return true;
-} else {
- mp->deletions_allowed=false;
- print_err("TeX mode didn't end; all text was ignored after line ");
- mp_print_int(mp, mp->warning_info);
- help2("The file ended while I was looking for the `etex' to")
- ("finish this TeX material. I've inserted `etex' now.");
- mp->cur_sym = frozen_etex;
- mp_ins_error(mp);
- mp->deletions_allowed=true;
- return false;
-}
-
-@ @<Back up an outer symbolic token so that it can be reread@>=
-if ( mp->cur_sym!=0 ) {
- p=mp_get_avail(mp); info(p)=mp->cur_sym;
- back_list(p); /* prepare to read the symbolic token again */
-}
-
-@ @<Tell the user what has run away...@>=
-{
- mp_runaway(mp); /* print the definition-so-far */
- if ( mp->cur_sym==0 ) {
- print_err("File ended");
-@.File ended while scanning...@>
- } else {
- print_err("Forbidden token found");
-@.Forbidden token found...@>
- }
- mp_print(mp, " while scanning ");
- help4("I suspect you have forgotten an `enddef',")
- ("causing me to read past where you wanted me to stop.")
- ("I'll try to recover; but if the error is serious,")
- ("you'd better type `E' or `X' now and fix your file.");
- switch (mp->scanner_status) {
- @<Complete the error message,
- and set |cur_sym| to a token that might help recover from the error@>
- } /* there are no other cases */
- mp_ins_error(mp);
-}
-
-@ As we consider various kinds of errors, it is also appropriate to
-change the first line of the help message just given; |help_line[3]|
-points to the string that might be changed.
-
-@<Complete the error message,...@>=
-case flushing:
- mp_print(mp, "to the end of the statement");
- mp->help_line[3]="A previous error seems to have propagated,";
- mp->cur_sym=frozen_semicolon;
- break;
-case absorbing:
- mp_print(mp, "a text argument");
- mp->help_line[3]="It seems that a right delimiter was left out,";
- if ( mp->warning_info==0 ) {
- mp->cur_sym=frozen_end_group;
- } else {
- mp->cur_sym=frozen_right_delimiter;
- equiv(frozen_right_delimiter)=mp->warning_info;
- }
- break;
-case var_defining:
-case op_defining:
- mp_print(mp, "the definition of ");
- if ( mp->scanner_status==op_defining )
- mp_print_text(mp->warning_info);
- else
- mp_print_variable_name(mp, mp->warning_info);
- mp->cur_sym=frozen_end_def;
- break;
-case loop_defining:
- mp_print(mp, "the text of a ");
- mp_print_text(mp->warning_info);
- mp_print(mp, " loop");
- mp->help_line[3]="I suspect you have forgotten an `endfor',";
- mp->cur_sym=frozen_end_for;
- break;
-
-@ The |runaway| procedure displays the first part of the text that occurred
-when \MP\ began its special |scanner_status|, if that text has been saved.
-
-@<Declare the procedure called |runaway|@>=
-void mp_runaway (MP mp) {
- if ( mp->scanner_status>flushing ) {
- mp_print_nl(mp, "Runaway ");
- switch (mp->scanner_status) {
- case absorbing: mp_print(mp, "text?"); break;
- case var_defining:
- case op_defining: mp_print(mp,"definition?"); break;
- case loop_defining: mp_print(mp, "loop?"); break;
- } /* there are no other cases */
- mp_print_ln(mp);
- mp_show_token_list(mp, link(hold_head),null,mp->error_line-10,0);
- }
-}
-
-@ We need to mention a procedure that may be called by |get_next|.
-
-@<Declarations@>=
-void mp_firm_up_the_line (MP mp);
-
-@ And now we're ready to take the plunge into |get_next| itself.
-Note that the behavior depends on the |scanner_status| because percent signs
-and double quotes need to be passed over when skipping TeX material.
-
-@c
-void mp_get_next (MP mp) {
- /* sets |cur_cmd|, |cur_mod|, |cur_sym| to next token */
-@^inner loop@>
- /*restart*/ /* go here to get the next input token */
- /*exit*/ /* go here when the next input token has been got */
- /*|common_ending|*/ /* go here to finish getting a symbolic token */
- /*found*/ /* go here when the end of a symbolic token has been found */
- /*switch*/ /* go here to branch on the class of an input character */
- /*|start_numeric_token|,|start_decimal_token|,|fin_numeric_token|,|done|*/
- /* go here at crucial stages when scanning a number */
- int k; /* an index into |buffer| */
- ASCII_code c; /* the current character in the buffer */
- ASCII_code class; /* its class number */
- integer n,f; /* registers for decimal-to-binary conversion */
-RESTART:
- mp->cur_sym=0;
- if ( file_state ) {
- @<Input from external file; |goto restart| if no input found,
- or |return| if a non-symbolic token is found@>;
- } else {
- @<Input from token list; |goto restart| if end of list or
- if a parameter needs to be expanded,
- or |return| if a non-symbolic token is found@>;
- }
-COMMON_ENDING:
- @<Finish getting the symbolic token in |cur_sym|;
- |goto restart| if it is illegal@>;
-}
-
-@ When a symbolic token is declared to be `\&{outer}', its command code
-is increased by |outer_tag|.
-@^inner loop@>
-
-@<Finish getting the symbolic token in |cur_sym|...@>=
-mp->cur_cmd=eq_type(mp->cur_sym); mp->cur_mod=equiv(mp->cur_sym);
-if ( mp->cur_cmd>=outer_tag ) {
- if ( mp_check_outer_validity(mp) )
- mp->cur_cmd=mp->cur_cmd-outer_tag;
- else
- goto RESTART;
-}
-
-@ A percent sign appears in |buffer[limit]|; this makes it unnecessary
-to have a special test for end-of-line.
-@^inner loop@>
-
-@<Input from external file;...@>=
-{
-SWITCH:
- c=mp->buffer[loc]; incr(loc); class=mp->char_class[c];
- switch (class) {
- case digit_class: goto START_NUMERIC_TOKEN; break;
- case period_class:
- class=mp->char_class[mp->buffer[loc]];
- if ( class>period_class ) {
- goto SWITCH;
- } else if ( class<period_class ) { /* |class=digit_class| */
- n=0; goto START_DECIMAL_TOKEN;
- }
-@:. }{\..\ token@>
- break;
- case space_class: goto SWITCH; break;
- case percent_class:
- if ( mp->scanner_status==tex_flushing ) {
- if ( loc<limit ) goto SWITCH;
- }
- @<Move to next line of file, or |goto restart| if there is no next line@>;
- check_interrupt;
- goto SWITCH;
- break;
- case string_class:
- if ( mp->scanner_status==tex_flushing ) goto SWITCH;
- else @<Get a string token and |return|@>;
- break;
- case isolated_classes:
- k=loc-1; goto FOUND; break;
- case invalid_class:
- if ( mp->scanner_status==tex_flushing ) goto SWITCH;
- else @<Decry the invalid character and |goto restart|@>;
- break;
- default: break; /* letters, etc. */
- }
- k=loc-1;
- while ( mp->char_class[mp->buffer[loc]]==class ) incr(loc);
- goto FOUND;
-START_NUMERIC_TOKEN:
- @<Get the integer part |n| of a numeric token;
- set |f:=0| and |goto fin_numeric_token| if there is no decimal point@>;
-START_DECIMAL_TOKEN:
- @<Get the fraction part |f| of a numeric token@>;
-FIN_NUMERIC_TOKEN:
- @<Pack the numeric and fraction parts of a numeric token
- and |return|@>;
-FOUND:
- mp->cur_sym=mp_id_lookup(mp, k,loc-k);
-}
-
-@ We go to |restart| instead of to |SWITCH|, because we might enter
-|token_state| after the error has been dealt with
-(cf.\ |clear_for_error_prompt|).
-
-@<Decry the invalid...@>=
-{
- print_err("Text line contains an invalid character");
-@.Text line contains...@>
- help2("A funny symbol that I can\'t read has just been input.")
- ("Continue, and I'll forget that it ever happened.");
- mp->deletions_allowed=false; mp_error(mp); mp->deletions_allowed=true;
- goto RESTART;
-}
-
-@ @<Get a string token and |return|@>=
-{
- if ( mp->buffer[loc]=='"' ) {
- mp->cur_mod=rts("");
- } else {
- k=loc; mp->buffer[limit+1]='"';
- do {
- incr(loc);
- } while (mp->buffer[loc]!='"');
- if ( loc>limit ) {
- @<Decry the missing string delimiter and |goto restart|@>;
- }
- if ( loc==k+1 ) {
- mp->cur_mod=mp->buffer[k];
- } else {
- str_room(loc-k);
- do {
- append_char(mp->buffer[k]); incr(k);
- } while (k!=loc);
- mp->cur_mod=mp_make_string(mp);
- }
- }
- incr(loc); mp->cur_cmd=string_token;
- return;
-}
-
-@ We go to |restart| after this error message, not to |SWITCH|,
-because the |clear_for_error_prompt| routine might have reinstated
-|token_state| after |error| has finished.
-
-@<Decry the missing string delimiter and |goto restart|@>=
-{
- loc=limit; /* the next character to be read on this line will be |"%"| */
- print_err("Incomplete string token has been flushed");
-@.Incomplete string token...@>
- help3("Strings should finish on the same line as they began.")
- ("I've deleted the partial string; you might want to")
- ("insert another by typing, e.g., `I\"new string\"'.");
- mp->deletions_allowed=false; mp_error(mp);
- mp->deletions_allowed=true;
- goto RESTART;
-}
-
-@ @<Get the integer part |n| of a numeric token...@>=
-n=c-'0';
-while ( mp->char_class[mp->buffer[loc]]==digit_class ) {
- if ( n<32768 ) n=10*n+mp->buffer[loc]-'0';
- incr(loc);
-}
-if ( mp->buffer[loc]=='.' )
- if ( mp->char_class[mp->buffer[loc+1]]==digit_class )
- goto DONE;
-f=0;
-goto FIN_NUMERIC_TOKEN;
-DONE: incr(loc)
-
-@ @<Get the fraction part |f| of a numeric token@>=
-k=0;
-do {
- if ( k<17 ) { /* digits for |k>=17| cannot affect the result */
- mp->dig[k]=mp->buffer[loc]-'0'; incr(k);
- }
- incr(loc);
-} while (mp->char_class[mp->buffer[loc]]==digit_class);
-f=mp_round_decimals(mp, k);
-if ( f==unity ) {
- incr(n); f=0;
-}
-
-@ @<Pack the numeric and fraction parts of a numeric token and |return|@>=
-if ( n<32768 ) {
- @<Set |cur_mod:=n*unity+f| and check if it is uncomfortably large@>;
-} else if ( mp->scanner_status!=tex_flushing ) {
- print_err("Enormous number has been reduced");
-@.Enormous number...@>
- help2("I can\'t handle numbers bigger than 32767.99998;")
- ("so I've changed your constant to that maximum amount.");
- mp->deletions_allowed=false; mp_error(mp); mp->deletions_allowed=true;
- mp->cur_mod=el_gordo;
-}
-mp->cur_cmd=numeric_token; return
-
-@ @<Set |cur_mod:=n*unity+f| and check if it is uncomfortably large@>=
-{
- mp->cur_mod=n*unity+f;
- if ( mp->cur_mod>=fraction_one ) {
- if ( (mp->internal[mp_warning_check]>0) &&
- (mp->scanner_status!=tex_flushing) ) {
- print_err("Number is too large (");
- mp_print_scaled(mp, mp->cur_mod);
- mp_print_char(mp, ')');
- help3("It is at least 4096. Continue and I'll try to cope")
- ("with that big value; but it might be dangerous.")
- ("(Set warningcheck:=0 to suppress this message.)");
- mp_error(mp);
- }
- }
-}
-
-@ Let's consider now what happens when |get_next| is looking at a token list.
-@^inner loop@>
-
-@<Input from token list;...@>=
-if ( loc>=mp->hi_mem_min ) { /* one-word token */
- mp->cur_sym=info(loc); loc=link(loc); /* move to next */
- if ( mp->cur_sym>=expr_base ) {
- if ( mp->cur_sym>=suffix_base ) {
- @<Insert a suffix or text parameter and |goto restart|@>;
- } else {
- mp->cur_cmd=capsule_token;
- mp->cur_mod=mp->param_stack[param_start+mp->cur_sym-(expr_base)];
- mp->cur_sym=0; return;
- }
- }
-} else if ( loc>null ) {
- @<Get a stored numeric or string or capsule token and |return|@>
-} else { /* we are done with this token list */
- mp_end_token_list(mp); goto RESTART; /* resume previous level */
-}
-
-@ @<Insert a suffix or text parameter...@>=
-{
- if ( mp->cur_sym>=text_base ) mp->cur_sym=mp->cur_sym-mp->param_size;
- /* |param_size=text_base-suffix_base| */
- mp_begin_token_list(mp,
- mp->param_stack[param_start+mp->cur_sym-(suffix_base)],
- parameter);
- goto RESTART;
-}
-
-@ @<Get a stored numeric or string or capsule token...@>=
-{
- if ( name_type(loc)==mp_token ) {
- mp->cur_mod=value(loc);
- if ( type(loc)==mp_known ) {
- mp->cur_cmd=numeric_token;
- } else {
- mp->cur_cmd=string_token; add_str_ref(mp->cur_mod);
- }
- } else {
- mp->cur_mod=loc; mp->cur_cmd=capsule_token;
- };
- loc=link(loc); return;
-}
-
-@ All of the easy branches of |get_next| have now been taken care of.
-There is one more branch.
-
-@<Move to next line of file, or |goto restart|...@>=
-if ( name>max_spec_src ) {
- @<Read next line of file into |buffer|, or
- |goto restart| if the file has ended@>;
-} else {
- if ( mp->input_ptr>0 ) {
- /* text was inserted during error recovery or by \&{scantokens} */
- mp_end_file_reading(mp); goto RESTART; /* resume previous level */
- }
- if ( mp->selector<log_only || mp->selector>=write_file) mp_open_log_file(mp);
- if ( mp->interaction>mp_nonstop_mode ) {
- if ( limit==start ) /* previous line was empty */
- mp_print_nl(mp, "(Please type a command or say `end')");
-@.Please type...@>
- mp_print_ln(mp); mp->first=start;
- prompt_input("*"); /* input on-line into |buffer| */
-@.*\relax@>
- limit=mp->last; mp->buffer[limit]='%';
- mp->first=limit+1; loc=start;
- } else {
- mp_fatal_error(mp, "*** (job aborted, no legal end found)");
-@.job aborted@>
- /* nonstop mode, which is intended for overnight batch processing,
- never waits for on-line input */
- }
-}
-
-@ The global variable |force_eof| is normally |false|; it is set |true|
-by an \&{endinput} command.
-
-@<Glob...@>=
-boolean force_eof; /* should the next \&{input} be aborted early? */
-
-@ We must decrement |loc| in order to leave the buffer in a valid state
-when an error condition causes us to |goto restart| without calling
-|end_file_reading|.
-
-@<Read next line of file into |buffer|, or
- |goto restart| if the file has ended@>=
-{
- incr(line); mp->first=start;
- if ( ! mp->force_eof ) {
- if ( mp_input_ln(mp, cur_file ) ) /* not end of file */
- mp_firm_up_the_line(mp); /* this sets |limit| */
- else
- mp->force_eof=true;
- };
- if ( mp->force_eof ) {
- mp->force_eof=false;
- decr(loc);
- if ( mpx_reading ) {
- @<Complain that the \.{MPX} file ended unexpectly; then set
- |cur_sym:=frozen_mpx_break| and |goto comon_ending|@>;
- } else {
- mp_print_char(mp, ')'); decr(mp->open_parens);
- update_terminal; /* show user that file has been read */
- mp_end_file_reading(mp); /* resume previous level */
- if ( mp_check_outer_validity(mp) ) goto RESTART;
- else goto RESTART;
- }
- }
- mp->buffer[limit]='%'; mp->first=limit+1; loc=start; /* ready to read */
-}
-
-@ We should never actually come to the end of an \.{MPX} file because such
-files should have an \&{mpxbreak} after the translation of the last
-\&{btex}$\,\ldots\,$\&{etex} block.
-
-@<Complain that the \.{MPX} file ended unexpectly; then set...@>=
-{
- mp->mpx_name[index]=finished;
- print_err("mpx file ended unexpectedly");
- help4("The file had too few picture expressions for btex...etex")
- ("blocks. Such files are normally generated automatically")
- ("but this one got messed up. You might want to insert a")
- ("picture expression now.");
- mp->deletions_allowed=false; mp_error(mp); mp->deletions_allowed=true;
- mp->cur_sym=frozen_mpx_break; goto COMMON_ENDING;
-}
-
-@ Sometimes we want to make it look as though we have just read a blank line
-without really doing so.
-
-@<Put an empty line in the input buffer@>=
-mp->last=mp->first; limit=mp->last; /* simulate |input_ln| and |firm_up_the_line| */
-mp->buffer[limit]='%'; mp->first=limit+1; loc=start
-
-@ If the user has set the |mp_pausing| parameter to some positive value,
-and if nonstop mode has not been selected, each line of input is displayed
-on the terminal and the transcript file, followed by `\.{=>}'.
-\MP\ waits for a response. If the response is null (i.e., if nothing is
-typed except perhaps a few blank spaces), the original
-line is accepted as it stands; otherwise the line typed is
-used instead of the line in the file.
-
-@c void mp_firm_up_the_line (MP mp) {
- size_t k; /* an index into |buffer| */
- limit=mp->last;
- if ( mp->internal[mp_pausing]>0) if ( mp->interaction>mp_nonstop_mode ) {
- wake_up_terminal; mp_print_ln(mp);
- if ( start<limit ) {
- for (k=(size_t)start;k<=(size_t)(limit-1);k++) {
- mp_print_str(mp, mp->buffer[k]);
- }
- }
- mp->first=limit; prompt_input("=>"); /* wait for user response */
-@.=>@>
- if ( mp->last>mp->first ) {
- for (k=mp->first;k<=mp->last-1;k++) { /* move line down in buffer */
- mp->buffer[k+start-mp->first]=mp->buffer[k];
- }
- limit=start+mp->last-mp->first;
- }
- }
-}
-
-@* \[30] Dealing with \TeX\ material.
-The \&{btex}$\,\ldots\,$\&{etex} and \&{verbatimtex}$\,\ldots\,$\&{etex}
-features need to be implemented at a low level in the scanning process
-so that \MP\ can stay in synch with the a preprocessor that treats
-blocks of \TeX\ material as they occur in the input file without trying
-to expand \MP\ macros. Thus we need a special version of |get_next|
-that does not expand macros and such but does handle \&{btex},
-\&{verbatimtex}, etc.
-
-The special version of |get_next| is called |get_t_next|. It works by flushing
-\&{btex}$\,\ldots\,$\&{etex} and \&{verbatimtex}\allowbreak
-$\,\ldots\,$\&{etex} blocks, switching to the \.{MPX} file when it sees
-\&{btex}, and switching back when it sees \&{mpxbreak}.
-
-@d btex_code 0
-@d verbatim_code 1
-
-@ @<Put each...@>=
-mp_primitive(mp, "btex",start_tex,btex_code);
-@:btex_}{\&{btex} primitive@>
-mp_primitive(mp, "verbatimtex",start_tex,verbatim_code);
-@:verbatimtex_}{\&{verbatimtex} primitive@>
-mp_primitive(mp, "etex",etex_marker,0); mp->eqtb[frozen_etex]=mp->eqtb[mp->cur_sym];
-@:etex_}{\&{etex} primitive@>
-mp_primitive(mp, "mpxbreak",mpx_break,0); mp->eqtb[frozen_mpx_break]=mp->eqtb[mp->cur_sym];
-@:mpx_break_}{\&{mpxbreak} primitive@>
-
-@ @<Cases of |print_cmd...@>=
-case start_tex: if ( m==btex_code ) mp_print(mp, "btex");
- else mp_print(mp, "verbatimtex"); break;
-case etex_marker: mp_print(mp, "etex"); break;
-case mpx_break: mp_print(mp, "mpxbreak"); break;
-
-@ Actually, |get_t_next| is a macro that avoids procedure overhead except
-in the unusual case where \&{btex}, \&{verbatimtex}, \&{etex}, or \&{mpxbreak}
-is encountered.
-
-@d get_t_next {mp_get_next(mp); if ( mp->cur_cmd<=max_pre_command ) mp_t_next(mp); }
-
-@<Declarations@>=
-void mp_start_mpx_input (MP mp);
-
-@ @c
-void mp_t_next (MP mp) {
- int old_status; /* saves the |scanner_status| */
- integer old_info; /* saves the |warning_info| */
- while ( mp->cur_cmd<=max_pre_command ) {
- if ( mp->cur_cmd==mpx_break ) {
- if ( ! file_state || (mp->mpx_name[index]==absent) ) {
- @<Complain about a misplaced \&{mpxbreak}@>;
- } else {
- mp_end_mpx_reading(mp);
- goto TEX_FLUSH;
- }
- } else if ( mp->cur_cmd==start_tex ) {
- if ( token_state || (name<=max_spec_src) ) {
- @<Complain that we are not reading a file@>;
- } else if ( mpx_reading ) {
- @<Complain that \.{MPX} files cannot contain \TeX\ material@>;
- } else if ( (mp->cur_mod!=verbatim_code)&&
- (mp->mpx_name[index]!=finished) ) {
- if ( ! mp_begin_mpx_reading(mp) ) mp_start_mpx_input(mp);
- } else {
- goto TEX_FLUSH;
- }
- } else {
- @<Complain about a misplaced \&{etex}@>;
- }
- goto COMMON_ENDING;
- TEX_FLUSH:
- @<Flush the \TeX\ material@>;
- COMMON_ENDING:
- mp_get_next(mp);
- }
-}
-
-@ We could be in the middle of an operation such as skipping false conditional
-text when \TeX\ material is encountered, so we must be careful to save the
-|scanner_status|.
-
-@<Flush the \TeX\ material@>=
-old_status=mp->scanner_status;
-old_info=mp->warning_info;
-mp->scanner_status=tex_flushing;
-mp->warning_info=line;
-do { mp_get_next(mp); } while (mp->cur_cmd!=etex_marker);
-mp->scanner_status=old_status;
-mp->warning_info=old_info
-
-@ @<Complain that \.{MPX} files cannot contain \TeX\ material@>=
-{ print_err("An mpx file cannot contain btex or verbatimtex blocks");
-help4("This file contains picture expressions for btex...etex")
- ("blocks. Such files are normally generated automatically")
- ("but this one seems to be messed up. I'll just keep going")
- ("and hope for the best.");
-mp_error(mp);
-}
-
-@ @<Complain that we are not reading a file@>=
-{ print_err("You can only use `btex' or `verbatimtex' in a file");
-help3("I'll have to ignore this preprocessor command because it")
- ("only works when there is a file to preprocess. You might")
- ("want to delete everything up to the next `etex`.");
-mp_error(mp);
-}
-
-@ @<Complain about a misplaced \&{mpxbreak}@>=
-{ print_err("Misplaced mpxbreak");
-help2("I'll ignore this preprocessor command because it")
- ("doesn't belong here");
-mp_error(mp);
-}
-
-@ @<Complain about a misplaced \&{etex}@>=
-{ print_err("Extra etex will be ignored");
-help1("There is no btex or verbatimtex for this to match");
-mp_error(mp);
-}
-
-@* \[31] Scanning macro definitions.
-\MP\ has a variety of ways to tuck tokens away into token lists for later
-use: Macros can be defined with \&{def}, \&{vardef}, \&{primarydef}, etc.;
-repeatable code can be defined with \&{for}, \&{forever}, \&{forsuffixes}.
-All such operations are handled by the routines in this part of the program.
-
-The modifier part of each command code is zero for the ``ending delimiters''
-like \&{enddef} and \&{endfor}.
-
-@d start_def 1 /* command modifier for \&{def} */
-@d var_def 2 /* command modifier for \&{vardef} */
-@d end_def 0 /* command modifier for \&{enddef} */
-@d start_forever 1 /* command modifier for \&{forever} */
-@d end_for 0 /* command modifier for \&{endfor} */
-
-@<Put each...@>=
-mp_primitive(mp, "def",macro_def,start_def);
-@:def_}{\&{def} primitive@>
-mp_primitive(mp, "vardef",macro_def,var_def);
-@:var_def_}{\&{vardef} primitive@>
-mp_primitive(mp, "primarydef",macro_def,secondary_primary_macro);
-@:primary_def_}{\&{primarydef} primitive@>
-mp_primitive(mp, "secondarydef",macro_def,tertiary_secondary_macro);
-@:secondary_def_}{\&{secondarydef} primitive@>
-mp_primitive(mp, "tertiarydef",macro_def,expression_tertiary_macro);
-@:tertiary_def_}{\&{tertiarydef} primitive@>
-mp_primitive(mp, "enddef",macro_def,end_def); mp->eqtb[frozen_end_def]=mp->eqtb[mp->cur_sym];
-@:end_def_}{\&{enddef} primitive@>
-@#
-mp_primitive(mp, "for",iteration,expr_base);
-@:for_}{\&{for} primitive@>
-mp_primitive(mp, "forsuffixes",iteration,suffix_base);
-@:for_suffixes_}{\&{forsuffixes} primitive@>
-mp_primitive(mp, "forever",iteration,start_forever);
-@:forever_}{\&{forever} primitive@>
-mp_primitive(mp, "endfor",iteration,end_for); mp->eqtb[frozen_end_for]=mp->eqtb[mp->cur_sym];
-@:end_for_}{\&{endfor} primitive@>
-
-@ @<Cases of |print_cmd...@>=
-case macro_def:
- if ( m<=var_def ) {
- if ( m==start_def ) mp_print(mp, "def");
- else if ( m<start_def ) mp_print(mp, "enddef");
- else mp_print(mp, "vardef");
- } else if ( m==secondary_primary_macro ) {
- mp_print(mp, "primarydef");
- } else if ( m==tertiary_secondary_macro ) {
- mp_print(mp, "secondarydef");
- } else {
- mp_print(mp, "tertiarydef");
- }
- break;
-case iteration:
- if ( m<=start_forever ) {
- if ( m==start_forever ) mp_print(mp, "forever");
- else mp_print(mp, "endfor");
- } else if ( m==expr_base ) {
- mp_print(mp, "for");
- } else {
- mp_print(mp, "forsuffixes");
- }
- break;
-
-@ Different macro-absorbing operations have different syntaxes, but they
-also have a lot in common. There is a list of special symbols that are to
-be replaced by parameter tokens; there is a special command code that
-ends the definition; the quotation conventions are identical. Therefore
-it makes sense to have most of the work done by a single subroutine. That
-subroutine is called |scan_toks|.
-
-The first parameter to |scan_toks| is the command code that will
-terminate scanning (either |macro_def| or |iteration|).
-
-The second parameter, |subst_list|, points to a (possibly empty) list
-of two-word nodes whose |info| and |value| fields specify symbol tokens
-before and after replacement. The list will be returned to free storage
-by |scan_toks|.
-
-The third parameter is simply appended to the token list that is built.
-And the final parameter tells how many of the special operations
-\.{\#\AT!}, \.{\AT!}, and \.{\AT!\#} are to be replaced by suffix parameters.
-When such parameters are present, they are called \.{(SUFFIX0)},
-\.{(SUFFIX1)}, and \.{(SUFFIX2)}.
-
-@c pointer mp_scan_toks (MP mp,command_code terminator, pointer
- subst_list, pointer tail_end, small_number suffix_count) {
- pointer p; /* tail of the token list being built */
- pointer q; /* temporary for link management */
- integer balance; /* left delimiters minus right delimiters */
- p=hold_head; balance=1; link(hold_head)=null;
- while (1) {
- get_t_next;
- if ( mp->cur_sym>0 ) {
- @<Substitute for |cur_sym|, if it's on the |subst_list|@>;
- if ( mp->cur_cmd==terminator ) {
- @<Adjust the balance; |break| if it's zero@>;
- } else if ( mp->cur_cmd==macro_special ) {
- @<Handle quoted symbols, \.{\#\AT!}, \.{\AT!}, or \.{\AT!\#}@>;
- }
- }
- link(p)=mp_cur_tok(mp); p=link(p);
- }
- link(p)=tail_end; mp_flush_node_list(mp, subst_list);
- return link(hold_head);
-}
-
-@ @<Substitute for |cur_sym|...@>=
-{
- q=subst_list;
- while ( q!=null ) {
- if ( info(q)==mp->cur_sym ) {
- mp->cur_sym=value(q); mp->cur_cmd=relax; break;
- }
- q=link(q);
- }
-}
-
-@ @<Adjust the balance; |break| if it's zero@>=
-if ( mp->cur_mod>0 ) {
- incr(balance);
-} else {
- decr(balance);
- if ( balance==0 )
- break;
-}
-
-@ Four commands are intended to be used only within macro texts: \&{quote},
-\.{\#\AT!}, \.{\AT!}, and \.{\AT!\#}. They are variants of a single command
-code called |macro_special|.
-
-@d quote 0 /* |macro_special| modifier for \&{quote} */
-@d macro_prefix 1 /* |macro_special| modifier for \.{\#\AT!} */
-@d macro_at 2 /* |macro_special| modifier for \.{\AT!} */
-@d macro_suffix 3 /* |macro_special| modifier for \.{\AT!\#} */
-
-@<Put each...@>=
-mp_primitive(mp, "quote",macro_special,quote);
-@:quote_}{\&{quote} primitive@>
-mp_primitive(mp, "#@@",macro_special,macro_prefix);
-@:]]]\#\AT!_}{\.{\#\AT!} primitive@>
-mp_primitive(mp, "@@",macro_special,macro_at);
-@:]]]\AT!_}{\.{\AT!} primitive@>
-mp_primitive(mp, "@@#",macro_special,macro_suffix);
-@:]]]\AT!\#_}{\.{\AT!\#} primitive@>
-
-@ @<Cases of |print_cmd...@>=
-case macro_special:
- switch (m) {
- case macro_prefix: mp_print(mp, "#@@"); break;
- case macro_at: mp_print_char(mp, '@@'); break;
- case macro_suffix: mp_print(mp, "@@#"); break;
- default: mp_print(mp, "quote"); break;
- }
- break;
-
-@ @<Handle quoted...@>=
-{
- if ( mp->cur_mod==quote ) { get_t_next; }
- else if ( mp->cur_mod<=suffix_count )
- mp->cur_sym=suffix_base-1+mp->cur_mod;
-}
-
-@ Here is a routine that's used whenever a token will be redefined. If
-the user's token is unredefinable, the `|frozen_inaccessible|' token is
-substituted; the latter is redefinable but essentially impossible to use,
-hence \MP's tables won't get fouled up.
-
-@c void mp_get_symbol (MP mp) { /* sets |cur_sym| to a safe symbol */
-RESTART:
- get_t_next;
- if ( (mp->cur_sym==0)||(mp->cur_sym>frozen_inaccessible) ) {
- print_err("Missing symbolic token inserted");
-@.Missing symbolic token...@>
- help3("Sorry: You can\'t redefine a number, string, or expr.")
- ("I've inserted an inaccessible symbol so that your")
- ("definition will be completed without mixing me up too badly.");
- if ( mp->cur_sym>0 )
- mp->help_line[2]="Sorry: You can\'t redefine my error-recovery tokens.";
- else if ( mp->cur_cmd==string_token )
- delete_str_ref(mp->cur_mod);
- mp->cur_sym=frozen_inaccessible; mp_ins_error(mp); goto RESTART;
- }
-}
-
-@ Before we actually redefine a symbolic token, we need to clear away its
-former value, if it was a variable. The following stronger version of
-|get_symbol| does that.
-
-@c void mp_get_clear_symbol (MP mp) {
- mp_get_symbol(mp); mp_clear_symbol(mp, mp->cur_sym,false);
-}
-
-@ Here's another little subroutine; it checks that an equals sign
-or assignment sign comes along at the proper place in a macro definition.
-
-@c void mp_check_equals (MP mp) {
- if ( mp->cur_cmd!=equals ) if ( mp->cur_cmd!=assignment ) {
- mp_missing_err(mp, "=");
-@.Missing `='@>
- help5("The next thing in this `def' should have been `=',")
- ("because I've already looked at the definition heading.")
- ("But don't worry; I'll pretend that an equals sign")
- ("was present. Everything from here to `enddef'")
- ("will be the replacement text of this macro.");
- mp_back_error(mp);
- }
-}
-
-@ A \&{primarydef}, \&{secondarydef}, or \&{tertiarydef} is rather easily
-handled now that we have |scan_toks|. In this case there are
-two parameters, which will be \.{EXPR0} and \.{EXPR1} (i.e.,
-|expr_base| and |expr_base+1|).
-
-@c void mp_make_op_def (MP mp) {
- command_code m; /* the type of definition */
- pointer p,q,r; /* for list manipulation */
- m=mp->cur_mod;
- mp_get_symbol(mp); q=mp_get_node(mp, token_node_size);
- info(q)=mp->cur_sym; value(q)=expr_base;
- mp_get_clear_symbol(mp); mp->warning_info=mp->cur_sym;
- mp_get_symbol(mp); p=mp_get_node(mp, token_node_size);
- info(p)=mp->cur_sym; value(p)=expr_base+1; link(p)=q;
- get_t_next; mp_check_equals(mp);
- mp->scanner_status=op_defining; q=mp_get_avail(mp); ref_count(q)=null;
- r=mp_get_avail(mp); link(q)=r; info(r)=general_macro;
- link(r)=mp_scan_toks(mp, macro_def,p,null,0);
- mp->scanner_status=normal; eq_type(mp->warning_info)=m;
- equiv(mp->warning_info)=q; mp_get_x_next(mp);
-}
-
-@ Parameters to macros are introduced by the keywords \&{expr},
-\&{suffix}, \&{text}, \&{primary}, \&{secondary}, and \&{tertiary}.
-
-@<Put each...@>=
-mp_primitive(mp, "expr",param_type,expr_base);
-@:expr_}{\&{expr} primitive@>
-mp_primitive(mp, "suffix",param_type,suffix_base);
-@:suffix_}{\&{suffix} primitive@>
-mp_primitive(mp, "text",param_type,text_base);
-@:text_}{\&{text} primitive@>
-mp_primitive(mp, "primary",param_type,primary_macro);
-@:primary_}{\&{primary} primitive@>
-mp_primitive(mp, "secondary",param_type,secondary_macro);
-@:secondary_}{\&{secondary} primitive@>
-mp_primitive(mp, "tertiary",param_type,tertiary_macro);
-@:tertiary_}{\&{tertiary} primitive@>
-
-@ @<Cases of |print_cmd...@>=
-case param_type:
- if ( m>=expr_base ) {
- if ( m==expr_base ) mp_print(mp, "expr");
- else if ( m==suffix_base ) mp_print(mp, "suffix");
- else mp_print(mp, "text");
- } else if ( m<secondary_macro ) {
- mp_print(mp, "primary");
- } else if ( m==secondary_macro ) {
- mp_print(mp, "secondary");
- } else {
- mp_print(mp, "tertiary");
- }
- break;
-
-@ Let's turn next to the more complex processing associated with \&{def}
-and \&{vardef}. When the following procedure is called, |cur_mod|
-should be either |start_def| or |var_def|.
-
-@c @<Declare the procedure called |check_delimiter|@>
-@<Declare the function called |scan_declared_variable|@>
-void mp_scan_def (MP mp) {
- int m; /* the type of definition */
- int n; /* the number of special suffix parameters */
- int k; /* the total number of parameters */
- int c; /* the kind of macro we're defining */
- pointer r; /* parameter-substitution list */
- pointer q; /* tail of the macro token list */
- pointer p; /* temporary storage */
- halfword base; /* |expr_base|, |suffix_base|, or |text_base| */
- pointer l_delim,r_delim; /* matching delimiters */
- m=mp->cur_mod; c=general_macro; link(hold_head)=null;
- q=mp_get_avail(mp); ref_count(q)=null; r=null;
- @<Scan the token or variable to be defined;
- set |n|, |scanner_status|, and |warning_info|@>;
- k=n;
- if ( mp->cur_cmd==left_delimiter ) {
- @<Absorb delimited parameters, putting them into lists |q| and |r|@>;
- }
- if ( mp->cur_cmd==param_type ) {
- @<Absorb undelimited parameters, putting them into list |r|@>;
- }
- mp_check_equals(mp);
- p=mp_get_avail(mp); info(p)=c; link(q)=p;
- @<Attach the replacement text to the tail of node |p|@>;
- mp->scanner_status=normal; mp_get_x_next(mp);
-}
-
-@ We don't put `|frozen_end_group|' into the replacement text of
-a \&{vardef}, because the user may want to redefine `\.{endgroup}'.
-
-@<Attach the replacement text to the tail of node |p|@>=
-if ( m==start_def ) {
- link(p)=mp_scan_toks(mp, macro_def,r,null,n);
-} else {
- q=mp_get_avail(mp); info(q)=mp->bg_loc; link(p)=q;
- p=mp_get_avail(mp); info(p)=mp->eg_loc;
- link(q)=mp_scan_toks(mp, macro_def,r,p,n);
-}
-if ( mp->warning_info==bad_vardef )
- mp_flush_token_list(mp, value(bad_vardef))
-
-@ @<Glob...@>=
-int bg_loc;
-int eg_loc; /* hash addresses of `\.{begingroup}' and `\.{endgroup}' */
-
-@ @<Scan the token or variable to be defined;...@>=
-if ( m==start_def ) {
- mp_get_clear_symbol(mp); mp->warning_info=mp->cur_sym; get_t_next;
- mp->scanner_status=op_defining; n=0;
- eq_type(mp->warning_info)=defined_macro; equiv(mp->warning_info)=q;
-} else {
- p=mp_scan_declared_variable(mp);
- mp_flush_variable(mp, equiv(info(p)),link(p),true);
- mp->warning_info=mp_find_variable(mp, p); mp_flush_list(mp, p);
- if ( mp->warning_info==null ) @<Change to `\.{a bad variable}'@>;
- mp->scanner_status=var_defining; n=2;
- if ( mp->cur_cmd==macro_special ) if ( mp->cur_mod==macro_suffix ) {/* \.{\AT!\#} */
- n=3; get_t_next;
- }
- type(mp->warning_info)=mp_unsuffixed_macro-2+n; value(mp->warning_info)=q;
-} /* |mp_suffixed_macro=mp_unsuffixed_macro+1| */
-
-@ @<Change to `\.{a bad variable}'@>=
-{
- print_err("This variable already starts with a macro");
-@.This variable already...@>
- help2("After `vardef a' you can\'t say `vardef a.b'.")
- ("So I'll have to discard this definition.");
- mp_error(mp); mp->warning_info=bad_vardef;
-}
-
-@ @<Initialize table entries...@>=
-name_type(bad_vardef)=mp_root; link(bad_vardef)=frozen_bad_vardef;
-equiv(frozen_bad_vardef)=bad_vardef; eq_type(frozen_bad_vardef)=tag_token;
-
-@ @<Absorb delimited parameters, putting them into lists |q| and |r|@>=
-do {
- l_delim=mp->cur_sym; r_delim=mp->cur_mod; get_t_next;
- if ( (mp->cur_cmd==param_type)&&(mp->cur_mod>=expr_base) ) {
- base=mp->cur_mod;
- } else {
- print_err("Missing parameter type; `expr' will be assumed");
-@.Missing parameter type@>
- help1("You should've had `expr' or `suffix' or `text' here.");
- mp_back_error(mp); base=expr_base;
- }
- @<Absorb parameter tokens for type |base|@>;
- mp_check_delimiter(mp, l_delim,r_delim);
- get_t_next;
-} while (mp->cur_cmd==left_delimiter)
-
-@ @<Absorb parameter tokens for type |base|@>=
-do {
- link(q)=mp_get_avail(mp); q=link(q); info(q)=base+k;
- mp_get_symbol(mp); p=mp_get_node(mp, token_node_size);
- value(p)=base+k; info(p)=mp->cur_sym;
- if ( k==mp->param_size ) mp_overflow(mp, "parameter stack size",mp->param_size);
-@:MetaPost capacity exceeded parameter stack size}{\quad parameter stack size@>
- incr(k); link(p)=r; r=p; get_t_next;
-} while (mp->cur_cmd==comma)
-
-@ @<Absorb undelimited parameters, putting them into list |r|@>=
-{
- p=mp_get_node(mp, token_node_size);
- if ( mp->cur_mod<expr_base ) {
- c=mp->cur_mod; value(p)=expr_base+k;
- } else {
- value(p)=mp->cur_mod+k;
- if ( mp->cur_mod==expr_base ) c=expr_macro;
- else if ( mp->cur_mod==suffix_base ) c=suffix_macro;
- else c=text_macro;
- }
- if ( k==mp->param_size ) mp_overflow(mp, "parameter stack size",mp->param_size);
- incr(k); mp_get_symbol(mp); info(p)=mp->cur_sym; link(p)=r; r=p; get_t_next;
- if ( c==expr_macro ) if ( mp->cur_cmd==of_token ) {
- c=of_macro; p=mp_get_node(mp, token_node_size);
- if ( k==mp->param_size ) mp_overflow(mp, "parameter stack size",mp->param_size);
- value(p)=expr_base+k; mp_get_symbol(mp); info(p)=mp->cur_sym;
- link(p)=r; r=p; get_t_next;
- }
-}
-
-@* \[32] Expanding the next token.
-Only a few command codes |<min_command| can possibly be returned by
-|get_t_next|; in increasing order, they are
-|if_test|, |fi_or_else|, |input|, |iteration|, |repeat_loop|,
-|exit_test|, |relax|, |scan_tokens|, |expand_after|, and |defined_macro|.
-
-\MP\ usually gets the next token of input by saying |get_x_next|. This is
-like |get_t_next| except that it keeps getting more tokens until
-finding |cur_cmd>=min_command|. In other words, |get_x_next| expands
-macros and removes conditionals or iterations or input instructions that
-might be present.
-
-It follows that |get_x_next| might invoke itself recursively. In fact,
-there is massive recursion, since macro expansion can involve the
-scanning of arbitrarily complex expressions, which in turn involve
-macro expansion and conditionals, etc.
-@^recursion@>
-
-Therefore it's necessary to declare a whole bunch of |forward|
-procedures at this point, and to insert some other procedures
-that will be invoked by |get_x_next|.
-
-@<Declarations@>=
-void mp_scan_primary (MP mp);
-void mp_scan_secondary (MP mp);
-void mp_scan_tertiary (MP mp);
-void mp_scan_expression (MP mp);
-void mp_scan_suffix (MP mp);
-@<Declare the procedure called |macro_call|@>
-void mp_get_boolean (MP mp);
-void mp_pass_text (MP mp);
-void mp_conditional (MP mp);
-void mp_start_input (MP mp);
-void mp_begin_iteration (MP mp);
-void mp_resume_iteration (MP mp);
-void mp_stop_iteration (MP mp);
-
-@ An auxiliary subroutine called |expand| is used by |get_x_next|
-when it has to do exotic expansion commands.
-
-@c void mp_expand (MP mp) {
- pointer p; /* for list manipulation */
- size_t k; /* something that we hope is |<=buf_size| */
- pool_pointer j; /* index into |str_pool| */
- if ( mp->internal[mp_tracing_commands]>unity )
- if ( mp->cur_cmd!=defined_macro )
- show_cur_cmd_mod;
- switch (mp->cur_cmd) {
- case if_test:
- mp_conditional(mp); /* this procedure is discussed in Part 36 below */
- break;
- case fi_or_else:
- @<Terminate the current conditional and skip to \&{fi}@>;
- break;
- case input:
- @<Initiate or terminate input from a file@>;
- break;
- case iteration:
- if ( mp->cur_mod==end_for ) {
- @<Scold the user for having an extra \&{endfor}@>;
- } else {
- mp_begin_iteration(mp); /* this procedure is discussed in Part 37 below */
- }
- break;
- case repeat_loop:
- @<Repeat a loop@>;
- break;
- case exit_test:
- @<Exit a loop if the proper time has come@>;
- break;
- case relax:
- break;
- case expand_after:
- @<Expand the token after the next token@>;
- break;
- case scan_tokens:
- @<Put a string into the input buffer@>;
- break;
- case defined_macro:
- mp_macro_call(mp, mp->cur_mod,null,mp->cur_sym);
- break;
- }; /* there are no other cases */
-}
-
-@ @<Scold the user...@>=
-{
- print_err("Extra `endfor'");
-@.Extra `endfor'@>
- help2("I'm not currently working on a for loop,")
- ("so I had better not try to end anything.");
- mp_error(mp);
-}
-
-@ The processing of \&{input} involves the |start_input| subroutine,
-which will be declared later; the processing of \&{endinput} is trivial.
-
-@<Put each...@>=
-mp_primitive(mp, "input",input,0);
-@:input_}{\&{input} primitive@>
-mp_primitive(mp, "endinput",input,1);
-@:end_input_}{\&{endinput} primitive@>
-
-@ @<Cases of |print_cmd_mod|...@>=
-case input:
- if ( m==0 ) mp_print(mp, "input");
- else mp_print(mp, "endinput");
- break;
-
-@ @<Initiate or terminate input...@>=
-if ( mp->cur_mod>0 ) mp->force_eof=true;
-else mp_start_input(mp)
-
-@ We'll discuss the complicated parts of loop operations later. For now
-it suffices to know that there's a global variable called |loop_ptr|
-that will be |null| if no loop is in progress.
-
-@<Repeat a loop@>=
-{ while ( token_state &&(loc==null) )
- mp_end_token_list(mp); /* conserve stack space */
- if ( mp->loop_ptr==null ) {
- print_err("Lost loop");
-@.Lost loop@>
- help2("I'm confused; after exiting from a loop, I still seem")
- ("to want to repeat it. I'll try to forget the problem.");
- mp_error(mp);
- } else {
- mp_resume_iteration(mp); /* this procedure is in Part 37 below */
- }
-}
-
-@ @<Exit a loop if the proper time has come@>=
-{ mp_get_boolean(mp);
- if ( mp->internal[mp_tracing_commands]>unity )
- mp_show_cmd_mod(mp, nullary,mp->cur_exp);
- if ( mp->cur_exp==true_code ) {
- if ( mp->loop_ptr==null ) {
- print_err("No loop is in progress");
-@.No loop is in progress@>
- help1("Why say `exitif' when there's nothing to exit from?");
- if ( mp->cur_cmd==semicolon ) mp_error(mp); else mp_back_error(mp);
- } else {
- @<Exit prematurely from an iteration@>;
- }
- } else if ( mp->cur_cmd!=semicolon ) {
- mp_missing_err(mp, ";");
-@.Missing `;'@>
- help2("After `exitif <boolean exp>' I expect to see a semicolon.")
- ("I shall pretend that one was there."); mp_back_error(mp);
- }
-}
-
-@ Here we use the fact that |forever_text| is the only |token_type| that
-is less than |loop_text|.
-
-@<Exit prematurely...@>=
-{ p=null;
- do {
- if ( file_state ) {
- mp_end_file_reading(mp);
- } else {
- if ( token_type<=loop_text ) p=start;
- mp_end_token_list(mp);
- }
- } while (p==null);
- if ( p!=info(mp->loop_ptr) ) mp_fatal_error(mp, "*** (loop confusion)");
-@.loop confusion@>
- mp_stop_iteration(mp); /* this procedure is in Part 34 below */
-}
-
-@ @<Expand the token after the next token@>=
-{ get_t_next;
- p=mp_cur_tok(mp); get_t_next;
- if ( mp->cur_cmd<min_command ) mp_expand(mp);
- else mp_back_input(mp);
- back_list(p);
-}
-
-@ @<Put a string into the input buffer@>=
-{ mp_get_x_next(mp); mp_scan_primary(mp);
- if ( mp->cur_type!=mp_string_type ) {
- mp_disp_err(mp, null,"Not a string");
-@.Not a string@>
- help2("I'm going to flush this expression, since")
- ("scantokens should be followed by a known string.");
- mp_put_get_flush_error(mp, 0);
- } else {
- mp_back_input(mp);
- if ( length(mp->cur_exp)>0 )
- @<Pretend we're reading a new one-line file@>;
- }
-}
-
-@ @<Pretend we're reading a new one-line file@>=
-{ mp_begin_file_reading(mp); name=is_scantok;
- k=mp->first+length(mp->cur_exp);
- if ( k>=mp->max_buf_stack ) {
- while ( k>=mp->buf_size ) {
- mp_reallocate_buffer(mp,(mp->buf_size+(mp->buf_size>>2)));
- }
- mp->max_buf_stack=k+1;
- }
- j=mp->str_start[mp->cur_exp]; limit=k;
- while ( mp->first<(size_t)limit ) {
- mp->buffer[mp->first]=mp->str_pool[j]; incr(j); incr(mp->first);
- }
- mp->buffer[limit]='%'; mp->first=limit+1; loc=start;
- mp_flush_cur_exp(mp, 0);
-}
-
-@ Here finally is |get_x_next|.
-
-The expression scanning routines to be considered later
-communicate via the global quantities |cur_type| and |cur_exp|;
-we must be very careful to save and restore these quantities while
-macros are being expanded.
-@^inner loop@>
-
-@<Declarations@>=
-void mp_get_x_next (MP mp);
-
-@ @c void mp_get_x_next (MP mp) {
- pointer save_exp; /* a capsule to save |cur_type| and |cur_exp| */
- get_t_next;
- if ( mp->cur_cmd<min_command ) {
- save_exp=mp_stash_cur_exp(mp);
- do {
- if ( mp->cur_cmd==defined_macro )
- mp_macro_call(mp, mp->cur_mod,null,mp->cur_sym);
- else
- mp_expand(mp);
- get_t_next;
- } while (mp->cur_cmd<min_command);
- mp_unstash_cur_exp(mp, save_exp); /* that restores |cur_type| and |cur_exp| */
- }
-}
-
-@ Now let's consider the |macro_call| procedure, which is used to start up
-all user-defined macros. Since the arguments to a macro might be expressions,
-|macro_call| is recursive.
-@^recursion@>
-
-The first parameter to |macro_call| points to the reference count of the
-token list that defines the macro. The second parameter contains any
-arguments that have already been parsed (see below). The third parameter
-points to the symbolic token that names the macro. If the third parameter
-is |null|, the macro was defined by \&{vardef}, so its name can be
-reconstructed from the prefix and ``at'' arguments found within the
-second parameter.
-
-What is this second parameter? It's simply a linked list of one-word items,
-whose |info| fields point to the arguments. In other words, if |arg_list=null|,
-no arguments have been scanned yet; otherwise |info(arg_list)| points to
-the first scanned argument, and |link(arg_list)| points to the list of
-further arguments (if any).
-
-Arguments of type \&{expr} are so-called capsules, which we will
-discuss later when we concentrate on expressions; they can be
-recognized easily because their |link| field is |void|. Arguments of type
-\&{suffix} and \&{text} are token lists without reference counts.
-
-@ After argument scanning is complete, the arguments are moved to the
-|param_stack|. (They can't be put on that stack any sooner, because
-the stack is growing and shrinking in unpredictable ways as more arguments
-are being acquired.) Then the macro body is fed to the scanner; i.e.,
-the replacement text of the macro is placed at the top of the \MP's
-input stack, so that |get_t_next| will proceed to read it next.
-
-@<Declare the procedure called |macro_call|@>=
-@<Declare the procedure called |print_macro_name|@>
-@<Declare the procedure called |print_arg|@>
-@<Declare the procedure called |scan_text_arg|@>
-void mp_macro_call (MP mp,pointer def_ref, pointer arg_list,
- pointer macro_name) ;
-
-@ @c
-void mp_macro_call (MP mp,pointer def_ref, pointer arg_list,
- pointer macro_name) {
- /* invokes a user-defined control sequence */
- pointer r; /* current node in the macro's token list */
- pointer p,q; /* for list manipulation */
- integer n; /* the number of arguments */
- pointer tail = 0; /* tail of the argument list */
- pointer l_delim=0,r_delim=0; /* a delimiter pair */
- r=link(def_ref); add_mac_ref(def_ref);
- if ( arg_list==null ) {
- n=0;
- } else {
- @<Determine the number |n| of arguments already supplied,
- and set |tail| to the tail of |arg_list|@>;
- }
- if ( mp->internal[mp_tracing_macros]>0 ) {
- @<Show the text of the macro being expanded, and the existing arguments@>;
- }
- @<Scan the remaining arguments, if any; set |r| to the first token
- of the replacement text@>;
- @<Feed the arguments and replacement text to the scanner@>;
-}
-
-@ @<Show the text of the macro...@>=
-mp_begin_diagnostic(mp); mp_print_ln(mp);
-mp_print_macro_name(mp, arg_list,macro_name);
-if ( n==3 ) mp_print(mp, "@@#"); /* indicate a suffixed macro */
-mp_show_macro(mp, def_ref,null,100000);
-if ( arg_list!=null ) {
- n=0; p=arg_list;
- do {
- q=info(p);
- mp_print_arg(mp, q,n,0);
- incr(n); p=link(p);
- } while (p!=null);
-}
-mp_end_diagnostic(mp, false)
-
-
-@ @<Declare the procedure called |print_macro_name|@>=
-void mp_print_macro_name (MP mp,pointer a, pointer n);
-
-@ @c
-void mp_print_macro_name (MP mp,pointer a, pointer n) {
- pointer p,q; /* they traverse the first part of |a| */
- if ( n!=null ) {
- mp_print_text(n);
- } else {
- p=info(a);
- if ( p==null ) {
- mp_print_text(info(info(link(a))));
- } else {
- q=p;
- while ( link(q)!=null ) q=link(q);
- link(q)=info(link(a));
- mp_show_token_list(mp, p,null,1000,0);
- link(q)=null;
- }
- }
-}
-
-@ @<Declare the procedure called |print_arg|@>=
-void mp_print_arg (MP mp,pointer q, integer n, pointer b) ;
-
-@ @c
-void mp_print_arg (MP mp,pointer q, integer n, pointer b) {
- if ( link(q)==mp_void ) mp_print_nl(mp, "(EXPR");
- else if ( (b<text_base)&&(b!=text_macro) ) mp_print_nl(mp, "(SUFFIX");
- else mp_print_nl(mp, "(TEXT");
- mp_print_int(mp, n); mp_print(mp, ")<-");
- if ( link(q)==mp_void ) mp_print_exp(mp, q,1);
- else mp_show_token_list(mp, q,null,1000,0);
-}
-
-@ @<Determine the number |n| of arguments already supplied...@>=
-{
- n=1; tail=arg_list;
- while ( link(tail)!=null ) {
- incr(n); tail=link(tail);
- }
-}
-
-@ @<Scan the remaining arguments, if any; set |r|...@>=
-mp->cur_cmd=comma+1; /* anything |<>comma| will do */
-while ( info(r)>=expr_base ) {
- @<Scan the delimited argument represented by |info(r)|@>;
- r=link(r);
-}
-if ( mp->cur_cmd==comma ) {
- print_err("Too many arguments to ");
-@.Too many arguments...@>
- mp_print_macro_name(mp, arg_list,macro_name); mp_print_char(mp, ';');
- mp_print_nl(mp, " Missing `"); mp_print_text(r_delim);
-@.Missing `)'...@>
- mp_print(mp, "' has been inserted");
- help3("I'm going to assume that the comma I just read was a")
- ("right delimiter, and then I'll begin expanding the macro.")
- ("You might want to delete some tokens before continuing.");
- mp_error(mp);
-}
-if ( info(r)!=general_macro ) {
- @<Scan undelimited argument(s)@>;
-}
-r=link(r)
-
-@ At this point, the reader will find it advisable to review the explanation
-of token list format that was presented earlier, paying special attention to
-the conventions that apply only at the beginning of a macro's token list.
-
-On the other hand, the reader will have to take the expression-parsing
-aspects of the following program on faith; we will explain |cur_type|
-and |cur_exp| later. (Several things in this program depend on each other,
-and it's necessary to jump into the circle somewhere.)
-
-@<Scan the delimited argument represented by |info(r)|@>=
-if ( mp->cur_cmd!=comma ) {
- mp_get_x_next(mp);
- if ( mp->cur_cmd!=left_delimiter ) {
- print_err("Missing argument to ");
-@.Missing argument...@>
- mp_print_macro_name(mp, arg_list,macro_name);
- help3("That macro has more parameters than you thought.")
- ("I'll continue by pretending that each missing argument")
- ("is either zero or null.");
- if ( info(r)>=suffix_base ) {
- mp->cur_exp=null; mp->cur_type=mp_token_list;
- } else {
- mp->cur_exp=0; mp->cur_type=mp_known;
- }
- mp_back_error(mp); mp->cur_cmd=right_delimiter;
- goto FOUND;
- }
- l_delim=mp->cur_sym; r_delim=mp->cur_mod;
-}
-@<Scan the argument represented by |info(r)|@>;
-if ( mp->cur_cmd!=comma )
- @<Check that the proper right delimiter was present@>;
-FOUND:
-@<Append the current expression to |arg_list|@>
-
-@ @<Check that the proper right delim...@>=
-if ( (mp->cur_cmd!=right_delimiter)||(mp->cur_mod!=l_delim) ) {
- if ( info(link(r))>=expr_base ) {
- mp_missing_err(mp, ",");
-@.Missing `,'@>
- help3("I've finished reading a macro argument and am about to")
- ("read another; the arguments weren't delimited correctly.")
- ("You might want to delete some tokens before continuing.");
- mp_back_error(mp); mp->cur_cmd=comma;
- } else {
- mp_missing_err(mp, str(text(r_delim)));
-@.Missing `)'@>
- help2("I've gotten to the end of the macro parameter list.")
- ("You might want to delete some tokens before continuing.");
- mp_back_error(mp);
- }
-}
-
-@ A \&{suffix} or \&{text} parameter will have been scanned as
-a token list pointed to by |cur_exp|, in which case we will have
-|cur_type=token_list|.
-
-@<Append the current expression to |arg_list|@>=
-{
- p=mp_get_avail(mp);
- if ( mp->cur_type==mp_token_list ) info(p)=mp->cur_exp;
- else info(p)=mp_stash_cur_exp(mp);
- if ( mp->internal[mp_tracing_macros]>0 ) {
- mp_begin_diagnostic(mp); mp_print_arg(mp, info(p),n,info(r));
- mp_end_diagnostic(mp, false);
- }
- if ( arg_list==null ) arg_list=p;
- else link(tail)=p;
- tail=p; incr(n);
-}
-
-@ @<Scan the argument represented by |info(r)|@>=
-if ( info(r)>=text_base ) {
- mp_scan_text_arg(mp, l_delim,r_delim);
-} else {
- mp_get_x_next(mp);
- if ( info(r)>=suffix_base ) mp_scan_suffix(mp);
- else mp_scan_expression(mp);
-}
-
-@ The parameters to |scan_text_arg| are either a pair of delimiters
-or zero; the latter case is for undelimited text arguments, which
-end with the first semicolon or \&{endgroup} or \&{end} that is not
-contained in a group.
-
-@<Declare the procedure called |scan_text_arg|@>=
-void mp_scan_text_arg (MP mp,pointer l_delim, pointer r_delim) ;
-
-@ @c
-void mp_scan_text_arg (MP mp,pointer l_delim, pointer r_delim) {
- integer balance; /* excess of |l_delim| over |r_delim| */
- pointer p; /* list tail */
- mp->warning_info=l_delim; mp->scanner_status=absorbing;
- p=hold_head; balance=1; link(hold_head)=null;
- while (1) {
- get_t_next;
- if ( l_delim==0 ) {
- @<Adjust the balance for an undelimited argument; |break| if done@>;
- } else {
- @<Adjust the balance for a delimited argument; |break| if done@>;
- }
- link(p)=mp_cur_tok(mp); p=link(p);
- }
- mp->cur_exp=link(hold_head); mp->cur_type=mp_token_list;
- mp->scanner_status=normal;
-}
-
-@ @<Adjust the balance for a delimited argument...@>=
-if ( mp->cur_cmd==right_delimiter ) {
- if ( mp->cur_mod==l_delim ) {
- decr(balance);
- if ( balance==0 ) break;
- }
-} else if ( mp->cur_cmd==left_delimiter ) {
- if ( mp->cur_mod==r_delim ) incr(balance);
-}
-
-@ @<Adjust the balance for an undelimited...@>=
-if ( end_of_statement ) { /* |cur_cmd=semicolon|, |end_group|, or |stop| */
- if ( balance==1 ) { break; }
- else { if ( mp->cur_cmd==end_group ) decr(balance); }
-} else if ( mp->cur_cmd==begin_group ) {
- incr(balance);
-}
-
-@ @<Scan undelimited argument(s)@>=
-{
- if ( info(r)<text_macro ) {
- mp_get_x_next(mp);
- if ( info(r)!=suffix_macro ) {
- if ( (mp->cur_cmd==equals)||(mp->cur_cmd==assignment) ) mp_get_x_next(mp);
- }
- }
- switch (info(r)) {
- case primary_macro:mp_scan_primary(mp); break;
- case secondary_macro:mp_scan_secondary(mp); break;
- case tertiary_macro:mp_scan_tertiary(mp); break;
- case expr_macro:mp_scan_expression(mp); break;
- case of_macro:
- @<Scan an expression followed by `\&{of} $\langle$primary$\rangle$'@>;
- break;
- case suffix_macro:
- @<Scan a suffix with optional delimiters@>;
- break;
- case text_macro:mp_scan_text_arg(mp, 0,0); break;
- } /* there are no other cases */
- mp_back_input(mp);
- @<Append the current expression to |arg_list|@>;
-}
-
-@ @<Scan an expression followed by `\&{of} $\langle$primary$\rangle$'@>=
-{
- mp_scan_expression(mp); p=mp_get_avail(mp); info(p)=mp_stash_cur_exp(mp);
- if ( mp->internal[mp_tracing_macros]>0 ) {
- mp_begin_diagnostic(mp); mp_print_arg(mp, info(p),n,0);
- mp_end_diagnostic(mp, false);
- }
- if ( arg_list==null ) arg_list=p; else link(tail)=p;
- tail=p;incr(n);
- if ( mp->cur_cmd!=of_token ) {
- mp_missing_err(mp, "of"); mp_print(mp, " for ");
-@.Missing `of'@>
- mp_print_macro_name(mp, arg_list,macro_name);
- help1("I've got the first argument; will look now for the other.");
- mp_back_error(mp);
- }
- mp_get_x_next(mp); mp_scan_primary(mp);
-}
-
-@ @<Scan a suffix with optional delimiters@>=
-{
- if ( mp->cur_cmd!=left_delimiter ) {
- l_delim=null;
- } else {
- l_delim=mp->cur_sym; r_delim=mp->cur_mod; mp_get_x_next(mp);
- };
- mp_scan_suffix(mp);
- if ( l_delim!=null ) {
- if ((mp->cur_cmd!=right_delimiter)||(mp->cur_mod!=l_delim) ) {
- mp_missing_err(mp, str(text(r_delim)));
-@.Missing `)'@>
- help2("I've gotten to the end of the macro parameter list.")
- ("You might want to delete some tokens before continuing.");
- mp_back_error(mp);
- }
- mp_get_x_next(mp);
- }
-}
-
-@ Before we put a new token list on the input stack, it is wise to clean off
-all token lists that have recently been depleted. Then a user macro that ends
-with a call to itself will not require unbounded stack space.
-
-@<Feed the arguments and replacement text to the scanner@>=
-while ( token_state &&(loc==null) ) mp_end_token_list(mp); /* conserve stack space */
-if ( mp->param_ptr+n>mp->max_param_stack ) {
- mp->max_param_stack=mp->param_ptr+n;
- if ( mp->max_param_stack>mp->param_size )
- mp_overflow(mp, "parameter stack size",mp->param_size);
-@:MetaPost capacity exceeded parameter stack size}{\quad parameter stack size@>
-}
-mp_begin_token_list(mp, def_ref,macro); name=macro_name; loc=r;
-if ( n>0 ) {
- p=arg_list;
- do {
- mp->param_stack[mp->param_ptr]=info(p); incr(mp->param_ptr); p=link(p);
- } while (p!=null);
- mp_flush_list(mp, arg_list);
-}
-
-@ It's sometimes necessary to put a single argument onto |param_stack|.
-The |stack_argument| subroutine does this.
-
-@c void mp_stack_argument (MP mp,pointer p) {
- if ( mp->param_ptr==mp->max_param_stack ) {
- incr(mp->max_param_stack);
- if ( mp->max_param_stack>mp->param_size )
- mp_overflow(mp, "parameter stack size",mp->param_size);
-@:MetaPost capacity exceeded parameter stack size}{\quad parameter stack size@>
- }
- mp->param_stack[mp->param_ptr]=p; incr(mp->param_ptr);
-}
-
-@* \[33] Conditional processing.
-Let's consider now the way \&{if} commands are handled.
-
-Conditions can be inside conditions, and this nesting has a stack
-that is independent of other stacks.
-Four global variables represent the top of the condition stack:
-|cond_ptr| points to pushed-down entries, if~any; |cur_if| tells whether
-we are processing \&{if} or \&{elseif}; |if_limit| specifies
-the largest code of a |fi_or_else| command that is syntactically legal;
-and |if_line| is the line number at which the current conditional began.
-
-If no conditions are currently in progress, the condition stack has the
-special state |cond_ptr=null|, |if_limit=normal|, |cur_if=0|, |if_line=0|.
-Otherwise |cond_ptr| points to a two-word node; the |type|, |name_type|, and
-|link| fields of the first word contain |if_limit|, |cur_if|, and
-|cond_ptr| at the next level, and the second word contains the
-corresponding |if_line|.
-
-@d if_node_size 2 /* number of words in stack entry for conditionals */
-@d if_line_field(A) mp->mem[(A)+1].cint
-@d if_code 1 /* code for \&{if} being evaluated */
-@d fi_code 2 /* code for \&{fi} */
-@d else_code 3 /* code for \&{else} */
-@d else_if_code 4 /* code for \&{elseif} */
-
-@<Glob...@>=
-pointer cond_ptr; /* top of the condition stack */
-integer if_limit; /* upper bound on |fi_or_else| codes */
-small_number cur_if; /* type of conditional being worked on */
-integer if_line; /* line where that conditional began */
-
-@ @<Set init...@>=
-mp->cond_ptr=null; mp->if_limit=normal; mp->cur_if=0; mp->if_line=0;
-
-@ @<Put each...@>=
-mp_primitive(mp, "if",if_test,if_code);
-@:if_}{\&{if} primitive@>
-mp_primitive(mp, "fi",fi_or_else,fi_code); mp->eqtb[frozen_fi]=mp->eqtb[mp->cur_sym];
-@:fi_}{\&{fi} primitive@>
-mp_primitive(mp, "else",fi_or_else,else_code);
-@:else_}{\&{else} primitive@>
-mp_primitive(mp, "elseif",fi_or_else,else_if_code);
-@:else_if_}{\&{elseif} primitive@>
-
-@ @<Cases of |print_cmd_mod|...@>=
-case if_test:
-case fi_or_else:
- switch (m) {
- case if_code:mp_print(mp, "if"); break;
- case fi_code:mp_print(mp, "fi"); break;
- case else_code:mp_print(mp, "else"); break;
- default: mp_print(mp, "elseif"); break;
- }
- break;
-
-@ Here is a procedure that ignores text until coming to an \&{elseif},
-\&{else}, or \&{fi} at level zero of $\&{if}\ldots\&{fi}$
-nesting. After it has acted, |cur_mod| will indicate the token that
-was found.
-
-\MP's smallest two command codes are |if_test| and |fi_or_else|; this
-makes the skipping process a bit simpler.
-
-@c
-void mp_pass_text (MP mp) {
- integer l = 0;
- mp->scanner_status=skipping;
- mp->warning_info=mp_true_line(mp);
- while (1) {
- get_t_next;
- if ( mp->cur_cmd<=fi_or_else ) {
- if ( mp->cur_cmd<fi_or_else ) {
- incr(l);
- } else {
- if ( l==0 ) break;
- if ( mp->cur_mod==fi_code ) decr(l);
- }
- } else {
- @<Decrease the string reference count,
- if the current token is a string@>;
- }
- }
- mp->scanner_status=normal;
-}
-
-@ @<Decrease the string reference count...@>=
-if ( mp->cur_cmd==string_token ) { delete_str_ref(mp->cur_mod); }
-
-@ When we begin to process a new \&{if}, we set |if_limit:=if_code|; then
-if \&{elseif} or \&{else} or \&{fi} occurs before the current \&{if}
-condition has been evaluated, a colon will be inserted.
-A construction like `\.{if fi}' would otherwise get \MP\ confused.
-
-@<Push the condition stack@>=
-{ p=mp_get_node(mp, if_node_size); link(p)=mp->cond_ptr; type(p)=mp->if_limit;
- name_type(p)=mp->cur_if; if_line_field(p)=mp->if_line;
- mp->cond_ptr=p; mp->if_limit=if_code; mp->if_line=mp_true_line(mp);
- mp->cur_if=if_code;
-}
-
-@ @<Pop the condition stack@>=
-{ p=mp->cond_ptr; mp->if_line=if_line_field(p);
- mp->cur_if=name_type(p); mp->if_limit=type(p); mp->cond_ptr=link(p);
- mp_free_node(mp, p,if_node_size);
-}
-
-@ Here's a procedure that changes the |if_limit| code corresponding to
-a given value of |cond_ptr|.
-
-@c void mp_change_if_limit (MP mp,small_number l, pointer p) {
- pointer q;
- if ( p==mp->cond_ptr ) {
- mp->if_limit=l; /* that's the easy case */
- } else {
- q=mp->cond_ptr;
- while (1) {
- if ( q==null ) mp_confusion(mp, "if");
-@:this can't happen if}{\quad if@>
- if ( link(q)==p ) {
- type(q)=l; return;
- }
- q=link(q);
- }
- }
-}
-
-@ The user is supposed to put colons into the proper parts of conditional
-statements. Therefore, \MP\ has to check for their presence.
-
-@c
-void mp_check_colon (MP mp) {
- if ( mp->cur_cmd!=colon ) {
- mp_missing_err(mp, ":");
-@.Missing `:'@>
- help2("There should've been a colon after the condition.")
- ("I shall pretend that one was there.");;
- mp_back_error(mp);
- }
-}
-
-@ A condition is started when the |get_x_next| procedure encounters
-an |if_test| command; in that case |get_x_next| calls |conditional|,
-which is a recursive procedure.
-@^recursion@>
-
-@c void mp_conditional (MP mp) {
- pointer save_cond_ptr; /* |cond_ptr| corresponding to this conditional */
- int new_if_limit; /* future value of |if_limit| */
- pointer p; /* temporary register */
- @<Push the condition stack@>;
- save_cond_ptr=mp->cond_ptr;
-RESWITCH:
- mp_get_boolean(mp); new_if_limit=else_if_code;
- if ( mp->internal[mp_tracing_commands]>unity ) {
- @<Display the boolean value of |cur_exp|@>;
- }
-FOUND:
- mp_check_colon(mp);
- if ( mp->cur_exp==true_code ) {
- mp_change_if_limit(mp, new_if_limit,save_cond_ptr);
- return; /* wait for \&{elseif}, \&{else}, or \&{fi} */
- };
- @<Skip to \&{elseif} or \&{else} or \&{fi}, then |goto done|@>;
-DONE:
- mp->cur_if=mp->cur_mod; mp->if_line=mp_true_line(mp);
- if ( mp->cur_mod==fi_code ) {
- @<Pop the condition stack@>
- } else if ( mp->cur_mod==else_if_code ) {
- goto RESWITCH;
- } else {
- mp->cur_exp=true_code; new_if_limit=fi_code; mp_get_x_next(mp);
- goto FOUND;
- }
-}
-
-@ In a construction like `\&{if} \&{if} \&{true}: $0=1$: \\{foo}
-\&{else}: \\{bar} \&{fi}', the first \&{else}
-that we come to after learning that the \&{if} is false is not the
-\&{else} we're looking for. Hence the following curious logic is needed.
-
-@<Skip to \&{elseif}...@>=
-while (1) {
- mp_pass_text(mp);
- if ( mp->cond_ptr==save_cond_ptr ) goto DONE;
- else if ( mp->cur_mod==fi_code ) @<Pop the condition stack@>;
-}
-
-
-@ @<Display the boolean value...@>=
-{ mp_begin_diagnostic(mp);
- if ( mp->cur_exp==true_code ) mp_print(mp, "{true}");
- else mp_print(mp, "{false}");
- mp_end_diagnostic(mp, false);
-}
-
-@ The processing of conditionals is complete except for the following
-code, which is actually part of |get_x_next|. It comes into play when
-\&{elseif}, \&{else}, or \&{fi} is scanned.
-
-@<Terminate the current conditional and skip to \&{fi}@>=
-if ( mp->cur_mod>mp->if_limit ) {
- if ( mp->if_limit==if_code ) { /* condition not yet evaluated */
- mp_missing_err(mp, ":");
-@.Missing `:'@>
- mp_back_input(mp); mp->cur_sym=frozen_colon; mp_ins_error(mp);
- } else {
- print_err("Extra "); mp_print_cmd_mod(mp, fi_or_else,mp->cur_mod);
-@.Extra else@>
-@.Extra elseif@>
-@.Extra fi@>
- help1("I'm ignoring this; it doesn't match any if.");
- mp_error(mp);
- }
-} else {
- while ( mp->cur_mod!=fi_code ) mp_pass_text(mp); /* skip to \&{fi} */
- @<Pop the condition stack@>;
-}
-
-@* \[34] Iterations.
-To bring our treatment of |get_x_next| to a close, we need to consider what
-\MP\ does when it sees \&{for}, \&{forsuffixes}, and \&{forever}.
-
-There's a global variable |loop_ptr| that keeps track of the \&{for} loops
-that are currently active. If |loop_ptr=null|, no loops are in progress;
-otherwise |info(loop_ptr)| points to the iterative text of the current
-(innermost) loop, and |link(loop_ptr)| points to the data for any other
-loops that enclose the current one.
-
-A loop-control node also has two other fields, called |loop_type| and
-|loop_list|, whose contents depend on the type of loop:
-
-\yskip\indent|loop_type(loop_ptr)=null| means that |loop_list(loop_ptr)|
-points to a list of one-word nodes whose |info| fields point to the
-remaining argument values of a suffix list and expression list.
-
-\yskip\indent|loop_type(loop_ptr)=mp_void| means that the current loop is
-`\&{forever}'.
-
-\yskip\indent|loop_type(loop_ptr)=progression_flag| means that
-|p=loop_list(loop_ptr)| points to a ``progression node'' and |value(p)|,
-|step_size(p)|, and |final_value(p)| contain the data for an arithmetic
-progression.
-
-\yskip\indent|loop_type(loop_ptr)=p>mp_void| means that |p| points to an edge
-header and |loop_list(loop_ptr)| points into the graphical object list for
-that edge header.
-
-\yskip\noindent In the case of a progression node, the first word is not used
-because the link field of words in the dynamic memory area cannot be arbitrary.
-
-@d loop_list_loc(A) ((A)+1) /* where the |loop_list| field resides */
-@d loop_type(A) info(loop_list_loc((A))) /* the type of \&{for} loop */
-@d loop_list(A) link(loop_list_loc((A))) /* the remaining list elements */
-@d loop_node_size 2 /* the number of words in a loop control node */
-@d progression_node_size 4 /* the number of words in a progression node */
-@d step_size(A) mp->mem[(A)+2].sc /* the step size in an arithmetic progression */
-@d final_value(A) mp->mem[(A)+3].sc /* the final value in an arithmetic progression */
-@d progression_flag (null+2)
- /* |loop_type| value when |loop_list| points to a progression node */
-
-@<Glob...@>=
-pointer loop_ptr; /* top of the loop-control-node stack */
-
-@ @<Set init...@>=
-mp->loop_ptr=null;
-
-@ If the expressions that define an arithmetic progression in
-a \&{for} loop don't have known numeric values, the |bad_for|
-subroutine screams at the user.
-
-@c void mp_bad_for (MP mp, const char * s) {
- mp_disp_err(mp, null,"Improper "); /* show the bad expression above the message */
-@.Improper...replaced by 0@>
- mp_print(mp, s); mp_print(mp, " has been replaced by 0");
- help4("When you say `for x=a step b until c',")
- ("the initial value `a' and the step size `b'")
- ("and the final value `c' must have known numeric values.")
- ("I'm zeroing this one. Proceed, with fingers crossed.");
- mp_put_get_flush_error(mp, 0);
-}
-
-@ Here's what \MP\ does when \&{for}, \&{forsuffixes}, or \&{forever}
-has just been scanned. (This code requires slight familiarity with
-expression-parsing routines that we have not yet discussed; but it seems
-to belong in the present part of the program, even though the original author
-didn't write it until later. The reader may wish to come back to it.)
-
-@c void mp_begin_iteration (MP mp) {
- halfword m; /* |expr_base| (\&{for}) or |suffix_base| (\&{forsuffixes}) */
- halfword n; /* hash address of the current symbol */
- pointer s; /* the new loop-control node */
- pointer p; /* substitution list for |scan_toks| */
- pointer q; /* link manipulation register */
- pointer pp; /* a new progression node */
- m=mp->cur_mod; n=mp->cur_sym; s=mp_get_node(mp, loop_node_size);
- if ( m==start_forever ){
- loop_type(s)=mp_void; p=null; mp_get_x_next(mp);
- } else {
- mp_get_symbol(mp); p=mp_get_node(mp, token_node_size);
- info(p)=mp->cur_sym; value(p)=m;
- mp_get_x_next(mp);
- if ( mp->cur_cmd==within_token ) {
- @<Set up a picture iteration@>;
- } else {
- @<Check for the |"="| or |":="| in a loop header@>;
- @<Scan the values to be used in the loop@>;
- }
- }
- @<Check for the presence of a colon@>;
- @<Scan the loop text and put it on the loop control stack@>;
- mp_resume_iteration(mp);
-}
-
-@ @<Check for the |"="| or |":="| in a loop header@>=
-if ( (mp->cur_cmd!=equals)&&(mp->cur_cmd!=assignment) ) {
- mp_missing_err(mp, "=");
-@.Missing `='@>
- help3("The next thing in this loop should have been `=' or `:='.")
- ("But don't worry; I'll pretend that an equals sign")
- ("was present, and I'll look for the values next.");
- mp_back_error(mp);
-}
-
-@ @<Check for the presence of a colon@>=
-if ( mp->cur_cmd!=colon ) {
- mp_missing_err(mp, ":");
-@.Missing `:'@>
- help3("The next thing in this loop should have been a `:'.")
- ("So I'll pretend that a colon was present;")
- ("everything from here to `endfor' will be iterated.");
- mp_back_error(mp);
-}
-
-@ We append a special |frozen_repeat_loop| token in place of the
-`\&{endfor}' at the end of the loop. This will come through \MP's scanner
-at the proper time to cause the loop to be repeated.
-
-(If the user tries some shenanigan like `\&{for} $\ldots$ \&{let} \&{endfor}',
-he will be foiled by the |get_symbol| routine, which keeps frozen
-tokens unchanged. Furthermore the |frozen_repeat_loop| is an \&{outer}
-token, so it won't be lost accidentally.)
-
-@ @<Scan the loop text...@>=
-q=mp_get_avail(mp); info(q)=frozen_repeat_loop;
-mp->scanner_status=loop_defining; mp->warning_info=n;
-info(s)=mp_scan_toks(mp, iteration,p,q,0); mp->scanner_status=normal;
-link(s)=mp->loop_ptr; mp->loop_ptr=s
-
-@ @<Initialize table...@>=
-eq_type(frozen_repeat_loop)=repeat_loop+outer_tag;
-text(frozen_repeat_loop)=intern(" ENDFOR");
-
-@ The loop text is inserted into \MP's scanning apparatus by the
-|resume_iteration| routine.
-
-@c void mp_resume_iteration (MP mp) {
- pointer p,q; /* link registers */
- p=loop_type(mp->loop_ptr);
- if ( p==progression_flag ) {
- p=loop_list(mp->loop_ptr); /* now |p| points to a progression node */
- mp->cur_exp=value(p);
- if ( @<The arithmetic progression has ended@> ) {
- mp_stop_iteration(mp);
- return;
- }
- mp->cur_type=mp_known; q=mp_stash_cur_exp(mp); /* make |q| an \&{expr} argument */
- value(p)=mp->cur_exp+step_size(p); /* set |value(p)| for the next iteration */
- } else if ( p==null ) {
- p=loop_list(mp->loop_ptr);
- if ( p==null ) {
- mp_stop_iteration(mp);
- return;
- }
- loop_list(mp->loop_ptr)=link(p); q=info(p); free_avail(p);
- } else if ( p==mp_void ) {
- mp_begin_token_list(mp, info(mp->loop_ptr),forever_text); return;
- } else {
- @<Make |q| a capsule containing the next picture component from
- |loop_list(loop_ptr)| or |goto not_found|@>;
- }
- mp_begin_token_list(mp, info(mp->loop_ptr),loop_text);
- mp_stack_argument(mp, q);
- if ( mp->internal[mp_tracing_commands]>unity ) {
- @<Trace the start of a loop@>;
- }
- return;
-NOT_FOUND:
- mp_stop_iteration(mp);
-}
-
-@ @<The arithmetic progression has ended@>=
-((step_size(p)>0)&&(mp->cur_exp>final_value(p)))||
- ((step_size(p)<0)&&(mp->cur_exp<final_value(p)))
-
-@ @<Trace the start of a loop@>=
-{
- mp_begin_diagnostic(mp); mp_print_nl(mp, "{loop value=");
-@.loop value=n@>
- if ( (q!=null)&&(link(q)==mp_void) ) mp_print_exp(mp, q,1);
- else mp_show_token_list(mp, q,null,50,0);
- mp_print_char(mp, '}'); mp_end_diagnostic(mp, false);
-}
-
-@ @<Make |q| a capsule containing the next picture component from...@>=
-{ q=loop_list(mp->loop_ptr);
- if ( q==null ) goto NOT_FOUND;
- skip_component(q) goto NOT_FOUND;
- mp->cur_exp=mp_copy_objects(mp, loop_list(mp->loop_ptr),q);
- mp_init_bbox(mp, mp->cur_exp);
- mp->cur_type=mp_picture_type;
- loop_list(mp->loop_ptr)=q;
- q=mp_stash_cur_exp(mp);
-}
-
-@ A level of loop control disappears when |resume_iteration| has decided
-not to resume, or when an \&{exitif} construction has removed the loop text
-from the input stack.
-
-@c void mp_stop_iteration (MP mp) {
- pointer p,q; /* the usual */
- p=loop_type(mp->loop_ptr);
- if ( p==progression_flag ) {
- mp_free_node(mp, loop_list(mp->loop_ptr),progression_node_size);
- } else if ( p==null ){
- q=loop_list(mp->loop_ptr);
- while ( q!=null ) {
- p=info(q);
- if ( p!=null ) {
- if ( link(p)==mp_void ) { /* it's an \&{expr} parameter */
- mp_recycle_value(mp, p); mp_free_node(mp, p,value_node_size);
- } else {
- mp_flush_token_list(mp, p); /* it's a \&{suffix} or \&{text} parameter */
- }
- }
- p=q; q=link(q); free_avail(p);
- }
- } else if ( p>progression_flag ) {
- delete_edge_ref(p);
- }
- p=mp->loop_ptr; mp->loop_ptr=link(p); mp_flush_token_list(mp, info(p));
- mp_free_node(mp, p,loop_node_size);
-}
-
-@ Now that we know all about loop control, we can finish up
-the missing portion of |begin_iteration| and we'll be done.
-
-The following code is performed after the `\.=' has been scanned in
-a \&{for} construction (if |m=expr_base|) or a \&{forsuffixes} construction
-(if |m=suffix_base|).
-
-@<Scan the values to be used in the loop@>=
-loop_type(s)=null; q=loop_list_loc(s); link(q)=null; /* |link(q)=loop_list(s)| */
-do {
- mp_get_x_next(mp);
- if ( m!=expr_base ) {
- mp_scan_suffix(mp);
- } else {
- if ( mp->cur_cmd>=colon ) if ( mp->cur_cmd<=comma )
- goto CONTINUE;
- mp_scan_expression(mp);
- if ( mp->cur_cmd==step_token ) if ( q==loop_list_loc(s) ) {
- @<Prepare for step-until construction and |break|@>;
- }
- mp->cur_exp=mp_stash_cur_exp(mp);
- }
- link(q)=mp_get_avail(mp); q=link(q);
- info(q)=mp->cur_exp; mp->cur_type=mp_vacuous;
-CONTINUE:
- ;
-} while (mp->cur_cmd==comma)
-
-@ @<Prepare for step-until construction and |break|@>=
-{
- if ( mp->cur_type!=mp_known ) mp_bad_for(mp, "initial value");
- pp=mp_get_node(mp, progression_node_size); value(pp)=mp->cur_exp;
- mp_get_x_next(mp); mp_scan_expression(mp);
- if ( mp->cur_type!=mp_known ) mp_bad_for(mp, "step size");
- step_size(pp)=mp->cur_exp;
- if ( mp->cur_cmd!=until_token ) {
- mp_missing_err(mp, "until");
-@.Missing `until'@>
- help2("I assume you meant to say `until' after `step'.")
- ("So I'll look for the final value and colon next.");
- mp_back_error(mp);
- }
- mp_get_x_next(mp); mp_scan_expression(mp);
- if ( mp->cur_type!=mp_known ) mp_bad_for(mp, "final value");
- final_value(pp)=mp->cur_exp; loop_list(s)=pp;
- loop_type(s)=progression_flag;
- break;
-}
-
-@ The last case is when we have just seen ``\&{within}'', and we need to
-parse a picture expression and prepare to iterate over it.
-
-@<Set up a picture iteration@>=
-{ mp_get_x_next(mp);
- mp_scan_expression(mp);
- @<Make sure the current expression is a known picture@>;
- loop_type(s)=mp->cur_exp; mp->cur_type=mp_vacuous;
- q=link(dummy_loc(mp->cur_exp));
- if ( q!= null )
- if ( is_start_or_stop(q) )
- if ( mp_skip_1component(mp, q)==null ) q=link(q);
- loop_list(s)=q;
-}
-
-@ @<Make sure the current expression is a known picture@>=
-if ( mp->cur_type!=mp_picture_type ) {
- mp_disp_err(mp, null,"Improper iteration spec has been replaced by nullpicture");
- help1("When you say `for x in p', p must be a known picture.");
- mp_put_get_flush_error(mp, mp_get_node(mp, edge_header_size));
- mp_init_edges(mp, mp->cur_exp); mp->cur_type=mp_picture_type;
-}
-
-@* \[35] File names.
-It's time now to fret about file names. Besides the fact that different
-operating systems treat files in different ways, we must cope with the
-fact that completely different naming conventions are used by different
-groups of people. The following programs show what is required for one
-particular operating system; similar routines for other systems are not
-difficult to devise.
-@^system dependencies@>
-
-\MP\ assumes that a file name has three parts: the name proper; its
-``extension''; and a ``file area'' where it is found in an external file
-system. The extension of an input file is assumed to be
-`\.{.mp}' unless otherwise specified; it is `\.{.log}' on the
-transcript file that records each run of \MP; it is `\.{.tfm}' on the font
-metric files that describe characters in any fonts created by \MP; it is
-`\.{.ps}' or `.{\it nnn}' for some number {\it nnn} on the \ps\ output files;
-and it is `\.{.mem}' on the mem files written by \.{INIMP} to initialize \MP.
-The file area can be arbitrary on input files, but files are usually
-output to the user's current area. If an input file cannot be
-found on the specified area, \MP\ will look for it on a special system
-area; this special area is intended for commonly used input files.
-
-Simple uses of \MP\ refer only to file names that have no explicit
-extension or area. For example, a person usually says `\.{input} \.{cmr10}'
-instead of `\.{input} \.{cmr10.new}'. Simple file
-names are best, because they make the \MP\ source files portable;
-whenever a file name consists entirely of letters and digits, it should be
-treated in the same way by all implementations of \MP. However, users
-need the ability to refer to other files in their environment, especially
-when responding to error messages concerning unopenable files; therefore
-we want to let them use the syntax that appears in their favorite
-operating system.
-
-@ \MP\ uses the same conventions that have proved to be satisfactory for
-\TeX\ and \MF. In order to isolate the system-dependent aspects of file names,
-@^system dependencies@>
-the system-independent parts of \MP\ are expressed in terms
-of three system-dependent
-procedures called |begin_name|, |more_name|, and |end_name|. In
-essence, if the user-specified characters of the file name are $c_1\ldots c_n$,
-the system-independent driver program does the operations
-$$|begin_name|;\,|more_name|(c_1);\,\ldots\,;\,|more_name|(c_n);
-\,|end_name|.$$
-These three procedures communicate with each other via global variables.
-Afterwards the file name will appear in the string pool as three strings
-called |cur_name|\penalty10000\hskip-.05em,
-|cur_area|, and |cur_ext|; the latter two are null (i.e.,
-|""|), unless they were explicitly specified by the user.
-
-Actually the situation is slightly more complicated, because \MP\ needs
-to know when the file name ends. The |more_name| routine is a function
-(with side effects) that returns |true| on the calls |more_name|$(c_1)$,
-\dots, |more_name|$(c_{n-1})$. The final call |more_name|$(c_n)$
-returns |false|; or, it returns |true| and $c_n$ is the last character
-on the current input line. In other words,
-|more_name| is supposed to return |true| unless it is sure that the
-file name has been completely scanned; and |end_name| is supposed to be able
-to finish the assembly of |cur_name|, |cur_area|, and |cur_ext| regardless of
-whether $|more_name|(c_n)$ returned |true| or |false|.
-
-@<Glob...@>=
-char * cur_name; /* name of file just scanned */
-char * cur_area; /* file area just scanned, or \.{""} */
-char * cur_ext; /* file extension just scanned, or \.{""} */
-
-@ It is easier to maintain reference counts if we assign initial values.
-
-@<Set init...@>=
-mp->cur_name=xstrdup("");
-mp->cur_area=xstrdup("");
-mp->cur_ext=xstrdup("");
-
-@ @<Dealloc variables@>=
-xfree(mp->cur_area);
-xfree(mp->cur_name);
-xfree(mp->cur_ext);
-
-@ The file names we shall deal with for illustrative purposes have the
-following structure: If the name contains `\.>' or `\.:', the file area
-consists of all characters up to and including the final such character;
-otherwise the file area is null. If the remaining file name contains
-`\..', the file extension consists of all such characters from the first
-remaining `\..' to the end, otherwise the file extension is null.
-@^system dependencies@>
-
-We can scan such file names easily by using two global variables that keep track
-of the occurrences of area and extension delimiters. Note that these variables
-cannot be of type |pool_pointer| because a string pool compaction could occur
-while scanning a file name.
-
-@<Glob...@>=
-integer area_delimiter;
- /* most recent `\.>' or `\.:' relative to |str_start[str_ptr]| */
-integer ext_delimiter; /* the relevant `\..', if any */
-
-@ Here now is the first of the system-dependent routines for file name scanning.
-@^system dependencies@>
-
-@<Declare subroutines for parsing file names@>=
-void mp_begin_name (MP mp) {
- xfree(mp->cur_name);
- xfree(mp->cur_area);
- xfree(mp->cur_ext);
- mp->area_delimiter=-1;
- mp->ext_delimiter=-1;
-}
-
-@ And here's the second.
-@^system dependencies@>
-
-@<Declare subroutines for parsing file names@>=
-boolean mp_more_name (MP mp, ASCII_code c) {
- if (c==' ') {
- return false;
- } else {
- if ( (c=='>')||(c==':') ) {
- mp->area_delimiter=mp->pool_ptr;
- mp->ext_delimiter=-1;
- } else if ( (c=='.')&&(mp->ext_delimiter<0) ) {
- mp->ext_delimiter=mp->pool_ptr;
- }
- str_room(1); append_char(c); /* contribute |c| to the current string */
- return true;
- }
-}
-
-@ The third.
-@^system dependencies@>
-
-@d copy_pool_segment(A,B,C) {
- A = xmalloc(C+1,sizeof(char));
- strncpy(A,(char *)(mp->str_pool+B),C);
- A[C] = 0;}
-
-@<Declare subroutines for parsing file names@>=
-void mp_end_name (MP mp) {
- pool_pointer s; /* length of area, name, and extension */
- unsigned int len;
- /* "my/w.mp" */
- s = mp->str_start[mp->str_ptr];
- if ( mp->area_delimiter<0 ) {
- mp->cur_area=xstrdup("");
- } else {
- len = mp->area_delimiter-s;
- copy_pool_segment(mp->cur_area,s,len);
- s += len+1;
- }
- if ( mp->ext_delimiter<0 ) {
- mp->cur_ext=xstrdup("");
- len = mp->pool_ptr-s;
- } else {
- copy_pool_segment(mp->cur_ext,mp->ext_delimiter,(mp->pool_ptr-mp->ext_delimiter));
- len = mp->ext_delimiter-s;
- }
- copy_pool_segment(mp->cur_name,s,len);
- mp->pool_ptr=s; /* don't need this partial string */
-}
-
-@ Conversely, here is a routine that takes three strings and prints a file
-name that might have produced them. (The routine is system dependent, because
-some operating systems put the file area last instead of first.)
-@^system dependencies@>
-
-@<Basic printing...@>=
-void mp_print_file_name (MP mp, char * n, char * a, char * e) {
- mp_print(mp, a); mp_print(mp, n); mp_print(mp, e);
-}
-
-@ Another system-dependent routine is needed to convert three internal
-\MP\ strings
-to the |name_of_file| value that is used to open files. The present code
-allows both lowercase and uppercase letters in the file name.
-@^system dependencies@>
-
-@d append_to_name(A) { c=(A);
- if ( k<file_name_size ) {
- mp->name_of_file[k]=xchr(c);
- incr(k);
- }
-}
-
-@<Declare subroutines for parsing file names@>=
-void mp_pack_file_name (MP mp, const char *n, const char *a, const char *e) {
- integer k; /* number of positions filled in |name_of_file| */
- ASCII_code c; /* character being packed */
- const char *j; /* a character index */
- k=0;
- assert(n);
- if (a!=NULL) {
- for (j=a;*j;j++) { append_to_name(*j); }
- }
- for (j=n;*j;j++) { append_to_name(*j); }
- if (e!=NULL) {
- for (j=e;*j;j++) { append_to_name(*j); }
- }
- mp->name_of_file[k]=0;
- mp->name_length=k;
-}
-
-@ @<Internal library declarations@>=
-void mp_pack_file_name (MP mp, const char *n, const char *a, const char *e) ;
-
-@ A messier routine is also needed, since mem file names must be scanned
-before \MP's string mechanism has been initialized. We shall use the
-global variable |MP_mem_default| to supply the text for default system areas
-and extensions related to mem files.
-@^system dependencies@>
-
-@d mem_default_length 9 /* length of the |MP_mem_default| string */
-@d mem_ext_length 4 /* length of its `\.{.mem}' part */
-@d mem_extension ".mem" /* the extension, as a \.{WEB} constant */
-
-@<Glob...@>=
-char *MP_mem_default;
-
-@ @<Option variables@>=
-char *mem_name; /* for commandline */
-
-@ @<Allocate or initialize ...@>=
-mp->MP_mem_default = xstrdup("plain.mem");
-mp->mem_name = xstrdup(opt->mem_name);
-@.plain@>
-@^system dependencies@>
-
-@ @<Dealloc variables@>=
-xfree(mp->MP_mem_default);
-xfree(mp->mem_name);
-
-@ @<Check the ``constant'' values for consistency@>=
-if ( mem_default_length>file_name_size ) mp->bad=20;
-
-@ Here is the messy routine that was just mentioned. It sets |name_of_file|
-from the first |n| characters of |MP_mem_default|, followed by
-|buffer[a..b-1]|, followed by the last |mem_ext_length| characters of
-|MP_mem_default|.
-
-We dare not give error messages here, since \MP\ calls this routine before
-the |error| routine is ready to roll. Instead, we simply drop excess characters,
-since the error will be detected in another way when a strange file name
-isn't found.
-@^system dependencies@>
-
-@c void mp_pack_buffered_name (MP mp,small_number n, integer a,
- integer b) {
- integer k; /* number of positions filled in |name_of_file| */
- ASCII_code c; /* character being packed */
- integer j; /* index into |buffer| or |MP_mem_default| */
- if ( n+b-a+1+mem_ext_length>file_name_size )
- b=a+file_name_size-n-1-mem_ext_length;
- k=0;
- for (j=0;j<n;j++) {
- append_to_name(xord((int)mp->MP_mem_default[j]));
- }
- for (j=a;j<b;j++) {
- append_to_name(mp->buffer[j]);
- }
- for (j=mem_default_length-mem_ext_length;
- j<mem_default_length;j++) {
- append_to_name(xord((int)mp->MP_mem_default[j]));
- }
- mp->name_of_file[k]=0;
- mp->name_length=k;
-}
-
-@ Here is the only place we use |pack_buffered_name|. This part of the program
-becomes active when a ``virgin'' \MP\ is trying to get going, just after
-the preliminary initialization, or when the user is substituting another
-mem file by typing `\.\&' after the initial `\.{**}' prompt. The buffer
-contains the first line of input in |buffer[loc..(last-1)]|, where
-|loc<last| and |buffer[loc]<>" "|.
-
-@<Declarations@>=
-boolean mp_open_mem_file (MP mp) ;
-
-@ @c
-boolean mp_open_mem_file (MP mp) {
- int j; /* the first space after the file name */
- if (mp->mem_name!=NULL) {
- mp->mem_file = (mp->open_file)(mp,mp->mem_name, "r", mp_filetype_memfile);
- if ( mp->mem_file ) return true;
- }
- j=loc;
- if ( mp->buffer[loc]=='&' ) {
- incr(loc); j=loc; mp->buffer[mp->last]=' ';
- while ( mp->buffer[j]!=' ' ) incr(j);
- mp_pack_buffered_name(mp, 0,loc,j); /* try first without the system file area */
- if ( mp_w_open_in(mp, &mp->mem_file) ) goto FOUND;
- wake_up_terminal;
- wterm_ln("Sorry, I can\'t find that mem file; will try PLAIN.");
-@.Sorry, I can't find...@>
- update_terminal;
- }
- /* now pull out all the stops: try for the system \.{plain} file */
- mp_pack_buffered_name(mp, mem_default_length-mem_ext_length,0,0);
- if ( ! mp_w_open_in(mp, &mp->mem_file) ) {
- wake_up_terminal;
- wterm_ln("I can\'t find the PLAIN mem file!\n");
-@.I can't find PLAIN...@>
-@.plain@>
- return false;
- }
-FOUND:
- loc=j; return true;
-}
-
-@ Operating systems often make it possible to determine the exact name (and
-possible version number) of a file that has been opened. The following routine,
-which simply makes a \MP\ string from the value of |name_of_file|, should
-ideally be changed to deduce the full name of file~|f|, which is the file
-most recently opened, if it is possible to do this.
-@^system dependencies@>
-
-@<Declarations@>=
-#define mp_a_make_name_string(A,B) mp_make_name_string(A)
-#define mp_b_make_name_string(A,B) mp_make_name_string(A)
-#define mp_w_make_name_string(A,B) mp_make_name_string(A)
-
-@ @c
-str_number mp_make_name_string (MP mp) {
- int k; /* index into |name_of_file| */
- str_room(mp->name_length);
- for (k=0;k<mp->name_length;k++) {
- append_char(xord((int)mp->name_of_file[k]));
- }
- return mp_make_string(mp);
-}
-
-@ Now let's consider the ``driver''
-routines by which \MP\ deals with file names
-in a system-independent manner. First comes a procedure that looks for a
-file name in the input by taking the information from the input buffer.
-(We can't use |get_next|, because the conversion to tokens would
-destroy necessary information.)
-
-This procedure doesn't allow semicolons or percent signs to be part of
-file names, because of other conventions of \MP.
-{\sl The {\logos METAFONT\/}book} doesn't
-use semicolons or percents immediately after file names, but some users
-no doubt will find it natural to do so; therefore system-dependent
-changes to allow such characters in file names should probably
-be made with reluctance, and only when an entire file name that
-includes special characters is ``quoted'' somehow.
-@^system dependencies@>
-
-@c void mp_scan_file_name (MP mp) {
- mp_begin_name(mp);
- while ( mp->buffer[loc]==' ' ) incr(loc);
- while (1) {
- if ( (mp->buffer[loc]==';')||(mp->buffer[loc]=='%') ) break;
- if ( ! mp_more_name(mp, mp->buffer[loc]) ) break;
- incr(loc);
- }
- mp_end_name(mp);
-}
-
-@ Here is another version that takes its input from a string.
-
-@<Declare subroutines for parsing file names@>=
-void mp_str_scan_file (MP mp, str_number s) {
- pool_pointer p,q; /* current position and stopping point */
- mp_begin_name(mp);
- p=mp->str_start[s]; q=str_stop(s);
- while ( p<q ){
- if ( ! mp_more_name(mp, mp->str_pool[p]) ) break;
- incr(p);
- }
- mp_end_name(mp);
-}
-
-@ And one that reads from a |char*|.
-
-@<Declare subroutines for parsing file names@>=
-void mp_ptr_scan_file (MP mp, char *s) {
- char *p, *q; /* current position and stopping point */
- mp_begin_name(mp);
- p=s; q=p+strlen(s);
- while ( p<q ){
- if ( ! mp_more_name(mp, *p)) break;
- p++;
- }
- mp_end_name(mp);
-}
-
-
-@ The global variable |job_name| contains the file name that was first
-\&{input} by the user. This name is extended by `\.{.log}' and `\.{ps}' and
-`\.{.mem}' and `\.{.tfm}' in order to make the names of \MP's output files.
-
-@<Glob...@>=
-boolean log_opened; /* has the transcript file been opened? */
-char *log_name; /* full name of the log file */
-
-@ @<Option variables@>=
-char *job_name; /* principal file name */
-
-@ Initially |job_name=NULL|; it becomes nonzero as soon as the true name is known.
-We have |job_name=NULL| if and only if the `\.{log}' file has not been opened,
-except of course for a short time just after |job_name| has become nonzero.
-
-@<Allocate or ...@>=
-mp->job_name=mp_xstrdup(mp, opt->job_name);
-mp->log_opened=false;
-
-@ @<Dealloc variables@>=
-xfree(mp->job_name);
-
-@ Here is a routine that manufactures the output file names, assuming that
-|job_name<>0|. It ignores and changes the current settings of |cur_area|
-and |cur_ext|.
-
-@d pack_cur_name mp_pack_file_name(mp, mp->cur_name,mp->cur_area,mp->cur_ext)
-
-@<Declarations@>=
-void mp_pack_job_name (MP mp, const char *s) ;
-
-@ @c
-void mp_pack_job_name (MP mp, const char *s) { /* |s = ".log"|, |".mem"|, |".ps"|, or .\\{nnn} */
- xfree(mp->cur_name); mp->cur_name=xstrdup(mp->job_name);
- xfree(mp->cur_area); mp->cur_area=xstrdup("");
- xfree(mp->cur_ext); mp->cur_ext=xstrdup(s);
- pack_cur_name;
-}
-
-@ If some trouble arises when \MP\ tries to open a file, the following
-routine calls upon the user to supply another file name. Parameter~|s|
-is used in the error message to identify the type of file; parameter~|e|
-is the default extension if none is given. Upon exit from the routine,
-variables |cur_name|, |cur_area|, |cur_ext|, and |name_of_file| are
-ready for another attempt at file opening.
-
-@<Declarations@>=
-void mp_prompt_file_name (MP mp, const char * s, const char * e) ;
-
-@ @c void mp_prompt_file_name (MP mp, const char * s, const char * e) {
- size_t k; /* index into |buffer| */
- char * saved_cur_name;
- if ( mp->interaction==mp_scroll_mode )
- wake_up_terminal;
- if (strcmp(s,"input file name")==0) {
- print_err("I can\'t find file `");
-@.I can't find file x@>
- } else {
- print_err("I can\'t write on file `");
- }
-@.I can't write on file x@>
- mp_print_file_name(mp, mp->cur_name,mp->cur_area,mp->cur_ext);
- mp_print(mp, "'.");
- if (strcmp(e,"")==0)
- mp_show_context(mp);
- mp_print_nl(mp, "Please type another "); mp_print(mp, s);
-@.Please type...@>
- if ( mp->interaction<mp_scroll_mode )
- mp_fatal_error(mp, "*** (job aborted, file error in nonstop mode)");
-@.job aborted, file error...@>
- saved_cur_name = xstrdup(mp->cur_name);
- clear_terminal; prompt_input(": "); @<Scan file name in the buffer@>;
- if (strcmp(mp->cur_ext,"")==0)
- mp->cur_ext=xstrdup(e);
- if (strlen(mp->cur_name)==0) {
- mp->cur_name=saved_cur_name;
- } else {
- xfree(saved_cur_name);
- }
- pack_cur_name;
-}
-
-@ @<Scan file name in the buffer@>=
-{
- mp_begin_name(mp); k=mp->first;
- while ( (mp->buffer[k]==' ')&&(k<mp->last) ) incr(k);
- while (1) {
- if ( k==mp->last ) break;
- if ( ! mp_more_name(mp, mp->buffer[k]) ) break;
- incr(k);
- }
- mp_end_name(mp);
-}
-
-@ The |open_log_file| routine is used to open the transcript file and to help
-it catch up to what has previously been printed on the terminal.
-
-@c void mp_open_log_file (MP mp) {
- int old_setting; /* previous |selector| setting */
- int k; /* index into |months| and |buffer| */
- int l; /* end of first input line */
- integer m; /* the current month */
- const char *months="JANFEBMARAPRMAYJUNJULAUGSEPOCTNOVDEC";
- /* abbreviations of month names */
- old_setting=mp->selector;
- if ( mp->job_name==NULL ) {
- mp->job_name=xstrdup("mpout");
- }
- mp_pack_job_name(mp,".log");
- while ( ! mp_a_open_out(mp, &mp->log_file, mp_filetype_log) ) {
- @<Try to get a different log file name@>;
- }
- mp->log_name=xstrdup(mp->name_of_file);
- mp->selector=log_only; mp->log_opened=true;
- @<Print the banner line, including the date and time@>;
- mp->input_stack[mp->input_ptr]=mp->cur_input;
- /* make sure bottom level is in memory */
-@.**@>
- if (!mp->noninteractive) {
- mp_print_nl(mp, "**");
- l=mp->input_stack[0].limit_field-1; /* last position of first line */
- for (k=0;k<=l;k++) mp_print_str(mp, mp->buffer[k]);
- mp_print_ln(mp); /* now the transcript file contains the first line of input */
- }
- mp->selector=old_setting+2; /* |log_only| or |term_and_log| */
-}
-
-@ @<Dealloc variables@>=
-xfree(mp->log_name);
-
-@ Sometimes |open_log_file| is called at awkward moments when \MP\ is
-unable to print error messages or even to |show_context|.
-The |prompt_file_name| routine can result in a |fatal_error|, but the |error|
-routine will not be invoked because |log_opened| will be false.
-
-The normal idea of |mp_batch_mode| is that nothing at all should be written
-on the terminal. However, in the unusual case that
-no log file could be opened, we make an exception and allow
-an explanatory message to be seen.
-
-Incidentally, the program always refers to the log file as a `\.{transcript
-file}', because some systems cannot use the extension `\.{.log}' for
-this file.
-
-@<Try to get a different log file name@>=
-{
- mp->selector=term_only;
- mp_prompt_file_name(mp, "transcript file name",".log");
-}
-
-@ @<Print the banner...@>=
-{
- wlog(banner);
- mp_print(mp, mp->mem_ident); mp_print(mp, " ");
- mp_print_int(mp, mp_round_unscaled(mp, mp->internal[mp_day]));
- mp_print_char(mp, ' ');
- m=mp_round_unscaled(mp, mp->internal[mp_month]);
- for (k=3*m-3;k<3*m;k++) { wlog_chr(months[k]); }
- mp_print_char(mp, ' ');
- mp_print_int(mp, mp_round_unscaled(mp, mp->internal[mp_year]));
- mp_print_char(mp, ' ');
- m=mp_round_unscaled(mp, mp->internal[mp_time]);
- mp_print_dd(mp, m / 60); mp_print_char(mp, ':'); mp_print_dd(mp, m % 60);
-}
-
-@ The |try_extension| function tries to open an input file determined by
-|cur_name|, |cur_area|, and the argument |ext|. It returns |false| if it
-can't find the file in |cur_area| or the appropriate system area.
-
-@c boolean mp_try_extension (MP mp, const char *ext) {
- mp_pack_file_name(mp, mp->cur_name,mp->cur_area, ext);
- in_name=xstrdup(mp->cur_name);
- in_area=xstrdup(mp->cur_area);
- if ( mp_a_open_in(mp, &cur_file, mp_filetype_program) ) {
- return true;
- } else {
- mp_pack_file_name(mp, mp->cur_name,NULL,ext);
- return mp_a_open_in(mp, &cur_file, mp_filetype_program);
- }
-}
-
-@ Let's turn now to the procedure that is used to initiate file reading
-when an `\.{input}' command is being processed.
-
-@c void mp_start_input (MP mp) { /* \MP\ will \.{input} something */
- char *fname = NULL;
- @<Put the desired file name in |(cur_name,cur_ext,cur_area)|@>;
- while (1) {
- mp_begin_file_reading(mp); /* set up |cur_file| and new level of input */
- if ( strlen(mp->cur_ext)==0 ) {
- if ( mp_try_extension(mp, ".mp") ) break;
- else if ( mp_try_extension(mp, "") ) break;
- else if ( mp_try_extension(mp, ".mf") ) break;
- /* |else do_nothing; | */
- } else if ( mp_try_extension(mp, mp->cur_ext) ) {
- break;
- }
- mp_end_file_reading(mp); /* remove the level that didn't work */
- mp_prompt_file_name(mp, "input file name","");
- }
- name=mp_a_make_name_string(mp, cur_file);
- fname = xstrdup(mp->name_of_file);
- if ( mp->job_name==NULL ) {
- mp->job_name=xstrdup(mp->cur_name);
- mp_open_log_file(mp);
- } /* |open_log_file| doesn't |show_context|, so |limit|
- and |loc| needn't be set to meaningful values yet */
- if ( ((int)mp->term_offset+(int)strlen(fname)) > (mp->max_print_line-2)) mp_print_ln(mp);
- else if ( (mp->term_offset>0)||(mp->file_offset>0) ) mp_print_char(mp, ' ');
- mp_print_char(mp, '('); incr(mp->open_parens); mp_print(mp, fname);
- xfree(fname);
- update_terminal;
- @<Flush |name| and replace it with |cur_name| if it won't be needed@>;
- @<Read the first line of the new file@>;
-}
-
-@ This code should be omitted if |a_make_name_string| returns something other
-than just a copy of its argument and the full file name is needed for opening
-\.{MPX} files or implementing the switch-to-editor option.
-@^system dependencies@>
-
-@<Flush |name| and replace it with |cur_name| if it won't be needed@>=
-mp_flush_string(mp, name); name=rts(mp->cur_name); xfree(mp->cur_name)
-
-@ If the file is empty, it is considered to contain a single blank line,
-so there is no need to test the return value.
-
-@<Read the first line...@>=
-{
- line=1;
- (void)mp_input_ln(mp, cur_file );
- mp_firm_up_the_line(mp);
- mp->buffer[limit]='%'; mp->first=limit+1; loc=start;
-}
-
-@ @<Put the desired file name in |(cur_name,cur_ext,cur_area)|@>=
-while ( token_state &&(loc==null) ) mp_end_token_list(mp);
-if ( token_state ) {
- print_err("File names can't appear within macros");
-@.File names can't...@>
- help3("Sorry...I've converted what follows to tokens,")
- ("possibly garbaging the name you gave.")
- ("Please delete the tokens and insert the name again.");
- mp_error(mp);
-}
-if ( file_state ) {
- mp_scan_file_name(mp);
-} else {
- xfree(mp->cur_name); mp->cur_name=xstrdup("");
- xfree(mp->cur_ext); mp->cur_ext =xstrdup("");
- xfree(mp->cur_area); mp->cur_area=xstrdup("");
-}
-
-@ The following simple routine starts reading the \.{MPX} file associated
-with the current input file.
-
-@c void mp_start_mpx_input (MP mp) {
- char *origname = NULL; /* a copy of nameoffile */
- mp_pack_file_name(mp, in_name, in_area, ".mpx");
- @<Try to make sure |name_of_file| refers to a valid \.{MPX} file and
- |goto not_found| if there is a problem@>;
- mp_begin_file_reading(mp);
- if ( ! mp_a_open_in(mp, &cur_file, mp_filetype_program) ) {
- mp_end_file_reading(mp);
- goto NOT_FOUND;
- }
- name=mp_a_make_name_string(mp, cur_file);
- mp->mpx_name[index]=name; add_str_ref(name);
- @<Read the first line of the new file@>;
- return;
-NOT_FOUND:
- @<Explain that the \.{MPX} file can't be read and |succumb|@>;
- xfree(origname);
-}
-
-@ This should ideally be changed to do whatever is necessary to create the
-\.{MPX} file given by |name_of_file| if it does not exist or if it is out
-of date. This requires invoking \.{MPtoTeX} on the |origname| and passing
-the results through \TeX\ and \.{DVItoMP}. (It is possible to use a
-completely different typesetting program if suitable postprocessor is
-available to perform the function of \.{DVItoMP}.)
-@^system dependencies@>
-
-@ @<Exported types@>=
-typedef int (*mp_run_make_mpx_command)(MP mp, char *origname, char *mtxname);
-
-@ @<Option variables@>=
-mp_run_make_mpx_command run_make_mpx;
-
-@ @<Allocate or initialize ...@>=
-set_callback_option(run_make_mpx);
-
-@ @<Internal library declarations@>=
-int mp_run_make_mpx (MP mp, char *origname, char *mtxname);
-
-@ The default does nothing.
-@c
-int mp_run_make_mpx (MP mp, char *origname, char *mtxname) {
- (void)mp;
- (void)origname;
- (void)mtxname;
- return false;
-}
-
-@ @<Try to make sure |name_of_file| refers to a valid \.{MPX} file and
- |goto not_found| if there is a problem@>=
-origname = mp_xstrdup(mp,mp->name_of_file);
-*(origname+strlen(origname)-1)=0; /* drop the x */
-if (!(mp->run_make_mpx)(mp, origname, mp->name_of_file))
- goto NOT_FOUND
-
-@ @<Explain that the \.{MPX} file can't be read and |succumb|@>=
-if ( mp->interaction==mp_error_stop_mode ) wake_up_terminal;
-mp_print_nl(mp, ">> ");
-mp_print(mp, origname);
-mp_print_nl(mp, ">> ");
-mp_print(mp, mp->name_of_file);
-mp_print_nl(mp, "! Unable to make mpx file");
-help4("The two files given above are one of your source files")
- ("and an auxiliary file I need to read to find out what your")
- ("btex..etex blocks mean. If you don't know why I had trouble,")
- ("try running it manually through MPtoTeX, TeX, and DVItoMP");
-succumb;
-
-@ The last file-opening commands are for files accessed via the \&{readfrom}
-@:read_from_}{\&{readfrom} primitive@>
-operator and the \&{write} command. Such files are stored in separate arrays.
-@:write_}{\&{write} primitive@>
-
-@<Types in the outer block@>=
-typedef unsigned int readf_index; /* |0..max_read_files| */
-typedef unsigned int write_index; /* |0..max_write_files| */
-
-@ @<Glob...@>=
-readf_index max_read_files; /* maximum number of simultaneously open \&{readfrom} files */
-void ** rd_file; /* \&{readfrom} files */
-char ** rd_fname; /* corresponding file name or 0 if file not open */
-readf_index read_files; /* number of valid entries in the above arrays */
-write_index max_write_files; /* maximum number of simultaneously open \&{write} */
-void ** wr_file; /* \&{write} files */
-char ** wr_fname; /* corresponding file name or 0 if file not open */
-write_index write_files; /* number of valid entries in the above arrays */
-
-@ @<Allocate or initialize ...@>=
-mp->max_read_files=8;
-mp->rd_file = xmalloc((mp->max_read_files+1),sizeof(void *));
-mp->rd_fname = xmalloc((mp->max_read_files+1),sizeof(char *));
-memset(mp->rd_fname, 0, sizeof(char *)*(mp->max_read_files+1));
-mp->read_files=0;
-mp->max_write_files=8;
-mp->wr_file = xmalloc((mp->max_write_files+1),sizeof(void *));
-mp->wr_fname = xmalloc((mp->max_write_files+1),sizeof(char *));
-memset(mp->wr_fname, 0, sizeof(char *)*(mp->max_write_files+1));
-mp->write_files=0;
-
-
-@ This routine starts reading the file named by string~|s| without setting
-|loc|, |limit|, or |name|. It returns |false| if the file is empty or cannot
-be opened. Otherwise it updates |rd_file[n]| and |rd_fname[n]|.
-
-@c boolean mp_start_read_input (MP mp,char *s, readf_index n) {
- mp_ptr_scan_file(mp, s);
- pack_cur_name;
- mp_begin_file_reading(mp);
- if ( ! mp_a_open_in(mp, &mp->rd_file[n], (mp_filetype_text+n)) )
- goto NOT_FOUND;
- if ( ! mp_input_ln(mp, mp->rd_file[n] ) ) {
- (mp->close_file)(mp,mp->rd_file[n]);
- goto NOT_FOUND;
- }
- mp->rd_fname[n]=xstrdup(mp->name_of_file);
- return true;
-NOT_FOUND:
- mp_end_file_reading(mp);
- return false;
-}
-
-@ Open |wr_file[n]| using file name~|s| and update |wr_fname[n]|.
-
-@<Declarations@>=
-void mp_open_write_file (MP mp, char *s, readf_index n) ;
-
-@ @c void mp_open_write_file (MP mp,char *s, readf_index n) {
- mp_ptr_scan_file(mp, s);
- pack_cur_name;
- while ( ! mp_a_open_out(mp, &mp->wr_file[n], (mp_filetype_text+n)) )
- mp_prompt_file_name(mp, "file name for write output","");
- mp->wr_fname[n]=xstrdup(mp->name_of_file);
-}
-
-
-@* \[36] Introduction to the parsing routines.
-We come now to the central nervous system that sparks many of \MP's activities.
-By evaluating expressions, from their primary constituents to ever larger
-subexpressions, \MP\ builds the structures that ultimately define complete
-pictures or fonts of type.
-
-Four mutually recursive subroutines are involved in this process: We call them
-$$\hbox{|scan_primary|, |scan_secondary|, |scan_tertiary|,
-and |scan_expression|.}$$
-@^recursion@>
-Each of them is parameterless and begins with the first token to be scanned
-already represented in |cur_cmd|, |cur_mod|, and |cur_sym|. After execution,
-the value of the primary or secondary or tertiary or expression that was
-found will appear in the global variables |cur_type| and |cur_exp|. The
-token following the expression will be represented in |cur_cmd|, |cur_mod|,
-and |cur_sym|.
-
-Technically speaking, the parsing algorithms are ``LL(1),'' more or less;
-backup mechanisms have been added in order to provide reasonable error
-recovery.
-
-@<Glob...@>=
-small_number cur_type; /* the type of the expression just found */
-integer cur_exp; /* the value of the expression just found */
-
-@ @<Set init...@>=
-mp->cur_exp=0;
-
-@ Many different kinds of expressions are possible, so it is wise to have
-precise descriptions of what |cur_type| and |cur_exp| mean in all cases:
-
-\smallskip\hang
-|cur_type=mp_vacuous| means that this expression didn't turn out to have a
-value at all, because it arose from a \&{begingroup}$\,\ldots\,$\&{endgroup}
-construction in which there was no expression before the \&{endgroup}.
-In this case |cur_exp| has some irrelevant value.
-
-\smallskip\hang
-|cur_type=mp_boolean_type| means that |cur_exp| is either |true_code|
-or |false_code|.
-
-\smallskip\hang
-|cur_type=mp_unknown_boolean| means that |cur_exp| points to a capsule
-node that is in
-a ring of equivalent booleans whose value has not yet been defined.
-
-\smallskip\hang
-|cur_type=mp_string_type| means that |cur_exp| is a string number (i.e., an
-integer in the range |0<=cur_exp<str_ptr|). That string's reference count
-includes this particular reference.
-
-\smallskip\hang
-|cur_type=mp_unknown_string| means that |cur_exp| points to a capsule
-node that is in
-a ring of equivalent strings whose value has not yet been defined.
-
-\smallskip\hang
-|cur_type=mp_pen_type| means that |cur_exp| points to a node in a pen. Nobody
-else points to any of the nodes in this pen. The pen may be polygonal or
-elliptical.
-
-\smallskip\hang
-|cur_type=mp_unknown_pen| means that |cur_exp| points to a capsule
-node that is in
-a ring of equivalent pens whose value has not yet been defined.
-
-\smallskip\hang
-|cur_type=mp_path_type| means that |cur_exp| points to a the first node of
-a path; nobody else points to this particular path. The control points of
-the path will have been chosen.
-
-\smallskip\hang
-|cur_type=mp_unknown_path| means that |cur_exp| points to a capsule
-node that is in
-a ring of equivalent paths whose value has not yet been defined.
-
-\smallskip\hang
-|cur_type=mp_picture_type| means that |cur_exp| points to an edge header node.
-There may be other pointers to this particular set of edges. The header node
-contains a reference count that includes this particular reference.
-
-\smallskip\hang
-|cur_type=mp_unknown_picture| means that |cur_exp| points to a capsule
-node that is in
-a ring of equivalent pictures whose value has not yet been defined.
-
-\smallskip\hang
-|cur_type=mp_transform_type| means that |cur_exp| points to a |mp_transform_type|
-capsule node. The |value| part of this capsule
-points to a transform node that contains six numeric values,
-each of which is |independent|, |dependent|, |mp_proto_dependent|, or |known|.
-
-\smallskip\hang
-|cur_type=mp_color_type| means that |cur_exp| points to a |color_type|
-capsule node. The |value| part of this capsule
-points to a color node that contains three numeric values,
-each of which is |independent|, |dependent|, |mp_proto_dependent|, or |known|.
-
-\smallskip\hang
-|cur_type=mp_cmykcolor_type| means that |cur_exp| points to a |mp_cmykcolor_type|
-capsule node. The |value| part of this capsule
-points to a color node that contains four numeric values,
-each of which is |independent|, |dependent|, |mp_proto_dependent|, or |known|.
-
-\smallskip\hang
-|cur_type=mp_pair_type| means that |cur_exp| points to a capsule
-node whose type is |mp_pair_type|. The |value| part of this capsule
-points to a pair node that contains two numeric values,
-each of which is |independent|, |dependent|, |mp_proto_dependent|, or |known|.
-
-\smallskip\hang
-|cur_type=mp_known| means that |cur_exp| is a |scaled| value.
-
-\smallskip\hang
-|cur_type=mp_dependent| means that |cur_exp| points to a capsule node whose type
-is |dependent|. The |dep_list| field in this capsule points to the associated
-dependency list.
-
-\smallskip\hang
-|cur_type=mp_proto_dependent| means that |cur_exp| points to a |mp_proto_dependent|
-capsule node. The |dep_list| field in this capsule
-points to the associated dependency list.
-
-\smallskip\hang
-|cur_type=independent| means that |cur_exp| points to a capsule node
-whose type is |independent|. This somewhat unusual case can arise, for
-example, in the expression
-`$x+\&{begingroup}\penalty0\,\&{string}\,x; 0\,\&{endgroup}$'.
-
-\smallskip\hang
-|cur_type=mp_token_list| means that |cur_exp| points to a linked list of
-tokens.
-
-\smallskip\noindent
-The possible settings of |cur_type| have been listed here in increasing
-numerical order. Notice that |cur_type| will never be |mp_numeric_type| or
-|suffixed_macro| or |mp_unsuffixed_macro|, although variables of those types
-are allowed. Conversely, \MP\ has no variables of type |mp_vacuous| or
-|token_list|.
-
-@ Capsules are two-word nodes that have a similar meaning
-to |cur_type| and |cur_exp|. Such nodes have |name_type=capsule|,
-and their |type| field is one of the possibilities for |cur_type| listed above.
-Also |link<=void| in capsules that aren't part of a token list.
-
-The |value| field of a capsule is, in most cases, the value that
-corresponds to its |type|, as |cur_exp| corresponds to |cur_type|.
-However, when |cur_exp| would point to a capsule,
-no extra layer of indirection is present; the |value|
-field is what would have been called |value(cur_exp)| if it had not been
-encapsulated. Furthermore, if the type is |dependent| or
-|mp_proto_dependent|, the |value| field of a capsule is replaced by
-|dep_list| and |prev_dep| fields, since dependency lists in capsules are
-always part of the general |dep_list| structure.
-
-The |get_x_next| routine is careful not to change the values of |cur_type|
-and |cur_exp| when it gets an expanded token. However, |get_x_next| might
-call a macro, which might parse an expression, which might execute lots of
-commands in a group; hence it's possible that |cur_type| might change
-from, say, |mp_unknown_boolean| to |mp_boolean_type|, or from |dependent| to
-|known| or |independent|, during the time |get_x_next| is called. The
-programs below are careful to stash sensitive intermediate results in
-capsules, so that \MP's generality doesn't cause trouble.
-
-Here's a procedure that illustrates these conventions. It takes
-the contents of $(|cur_type|\kern-.3pt,|cur_exp|\kern-.3pt)$
-and stashes them away in a
-capsule. It is not used when |cur_type=mp_token_list|.
-After the operation, |cur_type=mp_vacuous|; hence there is no need to
-copy path lists or to update reference counts, etc.
-
-The special link |mp_void| is put on the capsule returned by
-|stash_cur_exp|, because this procedure is used to store macro parameters
-that must be easily distinguishable from token lists.
-
-@<Declare the stashing/unstashing routines@>=
-pointer mp_stash_cur_exp (MP mp) {
- pointer p; /* the capsule that will be returned */
- switch (mp->cur_type) {
- case unknown_types:
- case mp_transform_type:
- case mp_color_type:
- case mp_pair_type:
- case mp_dependent:
- case mp_proto_dependent:
- case mp_independent:
- case mp_cmykcolor_type:
- p=mp->cur_exp;
- break;
- default:
- p=mp_get_node(mp, value_node_size); name_type(p)=mp_capsule;
- type(p)=mp->cur_type; value(p)=mp->cur_exp;
- break;
- }
- mp->cur_type=mp_vacuous; link(p)=mp_void;
- return p;
-}
-
-@ The inverse of |stash_cur_exp| is the following procedure, which
-deletes an unnecessary capsule and puts its contents into |cur_type|
-and |cur_exp|.
-
-The program steps of \MP\ can be divided into two categories: those in
-which |cur_type| and |cur_exp| are ``alive'' and those in which they are
-``dead,'' in the sense that |cur_type| and |cur_exp| contain relevant
-information or not. It's important not to ignore them when they're alive,
-and it's important not to pay attention to them when they're dead.
-
-There's also an intermediate category: If |cur_type=mp_vacuous|, then
-|cur_exp| is irrelevant, hence we can proceed without caring if |cur_type|
-and |cur_exp| are alive or dead. In such cases we say that |cur_type|
-and |cur_exp| are {\sl dormant}. It is permissible to call |get_x_next|
-only when they are alive or dormant.
-
-The \\{stash} procedure above assumes that |cur_type| and |cur_exp|
-are alive or dormant. The \\{unstash} procedure assumes that they are
-dead or dormant; it resuscitates them.
-
-@<Declare the stashing/unstashing...@>=
-void mp_unstash_cur_exp (MP mp,pointer p) ;
-
-@ @c
-void mp_unstash_cur_exp (MP mp,pointer p) {
- mp->cur_type=type(p);
- switch (mp->cur_type) {
- case unknown_types:
- case mp_transform_type:
- case mp_color_type:
- case mp_pair_type:
- case mp_dependent:
- case mp_proto_dependent:
- case mp_independent:
- case mp_cmykcolor_type:
- mp->cur_exp=p;
- break;
- default:
- mp->cur_exp=value(p);
- mp_free_node(mp, p,value_node_size);
- break;
- }
-}
-
-@ The following procedure prints the values of expressions in an
-abbreviated format. If its first parameter |p| is null, the value of
-|(cur_type,cur_exp)| is displayed; otherwise |p| should be a capsule
-containing the desired value. The second parameter controls the amount of
-output. If it is~0, dependency lists will be abbreviated to
-`\.{linearform}' unless they consist of a single term. If it is greater
-than~1, complicated structures (pens, pictures, and paths) will be displayed
-in full.
-@.linearform@>
-
-@<Declare subroutines for printing expressions@>=
-@<Declare the procedure called |print_dp|@>
-@<Declare the stashing/unstashing routines@>
-void mp_print_exp (MP mp,pointer p, small_number verbosity) {
- boolean restore_cur_exp; /* should |cur_exp| be restored? */
- small_number t; /* the type of the expression */
- pointer q; /* a big node being displayed */
- integer v=0; /* the value of the expression */
- if ( p!=null ) {
- restore_cur_exp=false;
- } else {
- p=mp_stash_cur_exp(mp); restore_cur_exp=true;
- }
- t=type(p);
- if ( t<mp_dependent ) v=value(p); else if ( t<mp_independent ) v=dep_list(p);
- @<Print an abbreviated value of |v| with format depending on |t|@>;
- if ( restore_cur_exp ) mp_unstash_cur_exp(mp, p);
-}
-
-@ @<Print an abbreviated value of |v| with format depending on |t|@>=
-switch (t) {
-case mp_vacuous:mp_print(mp, "mp_vacuous"); break;
-case mp_boolean_type:
- if ( v==true_code ) mp_print(mp, "true"); else mp_print(mp, "false");
- break;
-case unknown_types: case mp_numeric_type:
- @<Display a variable that's been declared but not defined@>;
- break;
-case mp_string_type:
- mp_print_char(mp, '"'); mp_print_str(mp, v); mp_print_char(mp, '"');
- break;
-case mp_pen_type: case mp_path_type: case mp_picture_type:
- @<Display a complex type@>;
- break;
-case mp_transform_type: case mp_color_type: case mp_pair_type: case mp_cmykcolor_type:
- if ( v==null ) mp_print_type(mp, t);
- else @<Display a big node@>;
- break;
-case mp_known:mp_print_scaled(mp, v); break;
-case mp_dependent: case mp_proto_dependent:
- mp_print_dp(mp, t,v,verbosity);
- break;
-case mp_independent:mp_print_variable_name(mp, p); break;
-default: mp_confusion(mp, "exp"); break;
-@:this can't happen exp}{\quad exp@>
-}
-
-@ @<Display a big node@>=
-{
- mp_print_char(mp, '('); q=v+mp->big_node_size[t];
- do {
- if ( type(v)==mp_known ) mp_print_scaled(mp, value(v));
- else if ( type(v)==mp_independent ) mp_print_variable_name(mp, v);
- else mp_print_dp(mp, type(v),dep_list(v),verbosity);
- v=v+2;
- if ( v!=q ) mp_print_char(mp, ',');
- } while (v!=q);
- mp_print_char(mp, ')');
-}
-
-@ Values of type \&{picture}, \&{path}, and \&{pen} are displayed verbosely
-in the log file only, unless the user has given a positive value to
-\\{tracingonline}.
-
-@<Display a complex type@>=
-if ( verbosity<=1 ) {
- mp_print_type(mp, t);
-} else {
- if ( mp->selector==term_and_log )
- if ( mp->internal[mp_tracing_online]<=0 ) {
- mp->selector=term_only;
- mp_print_type(mp, t); mp_print(mp, " (see the transcript file)");
- mp->selector=term_and_log;
- };
- switch (t) {
- case mp_pen_type:mp_print_pen(mp, v,"",false); break;
- case mp_path_type:mp_print_path(mp, v,"",false); break;
- case mp_picture_type:mp_print_edges(mp, v,"",false); break;
- } /* there are no other cases */
-}
-
-@ @<Declare the procedure called |print_dp|@>=
-void mp_print_dp (MP mp,small_number t, pointer p,
- small_number verbosity) {
- pointer q; /* the node following |p| */
- q=link(p);
- if ( (info(q)==null) || (verbosity>0) ) mp_print_dependency(mp, p,t);
- else mp_print(mp, "linearform");
-}
-
-@ The displayed name of a variable in a ring will not be a capsule unless
-the ring consists entirely of capsules.
-
-@<Display a variable that's been declared but not defined@>=
-{ mp_print_type(mp, t);
-if ( v!=null )
- { mp_print_char(mp, ' ');
- while ( (name_type(v)==mp_capsule) && (v!=p) ) v=value(v);
- mp_print_variable_name(mp, v);
- };
-}
-
-@ When errors are detected during parsing, it is often helpful to
-display an expression just above the error message, using |exp_err|
-or |disp_err| instead of |print_err|.
-
-@d exp_err(A) mp_disp_err(mp, null,(A)) /* displays the current expression */
-
-@<Declare subroutines for printing expressions@>=
-void mp_disp_err (MP mp,pointer p, const char *s) {
- if ( mp->interaction==mp_error_stop_mode ) wake_up_terminal;
- mp_print_nl(mp, ">> ");
-@.>>@>
- mp_print_exp(mp, p,1); /* ``medium verbose'' printing of the expression */
- if (strlen(s)) {
- mp_print_nl(mp, "! "); mp_print(mp, s);
-@.!\relax@>
- }
-}
-
-@ If |cur_type| and |cur_exp| contain relevant information that should
-be recycled, we will use the following procedure, which changes |cur_type|
-to |known| and stores a given value in |cur_exp|. We can think of |cur_type|
-and |cur_exp| as either alive or dormant after this has been done,
-because |cur_exp| will not contain a pointer value.
-
-@ @c void mp_flush_cur_exp (MP mp,scaled v) {
- switch (mp->cur_type) {
- case unknown_types: case mp_transform_type: case mp_color_type: case mp_pair_type:
- case mp_dependent: case mp_proto_dependent: case mp_independent: case mp_cmykcolor_type:
- mp_recycle_value(mp, mp->cur_exp);
- mp_free_node(mp, mp->cur_exp,value_node_size);
- break;
- case mp_string_type:
- delete_str_ref(mp->cur_exp); break;
- case mp_pen_type: case mp_path_type:
- mp_toss_knot_list(mp, mp->cur_exp); break;
- case mp_picture_type:
- delete_edge_ref(mp->cur_exp); break;
- default:
- break;
- }
- mp->cur_type=mp_known; mp->cur_exp=v;
-}
-
-@ There's a much more general procedure that is capable of releasing
-the storage associated with any two-word value packet.
-
-@<Declare the recycling subroutines@>=
-void mp_recycle_value (MP mp,pointer p) ;
-
-@ @c void mp_recycle_value (MP mp,pointer p) {
- small_number t; /* a type code */
- integer vv; /* another value */
- pointer q,r,s,pp; /* link manipulation registers */
- integer v=0; /* a value */
- t=type(p);
- if ( t<mp_dependent ) v=value(p);
- switch (t) {
- case undefined: case mp_vacuous: case mp_boolean_type: case mp_known:
- case mp_numeric_type:
- break;
- case unknown_types:
- mp_ring_delete(mp, p); break;
- case mp_string_type:
- delete_str_ref(v); break;
- case mp_path_type: case mp_pen_type:
- mp_toss_knot_list(mp, v); break;
- case mp_picture_type:
- delete_edge_ref(v); break;
- case mp_cmykcolor_type: case mp_pair_type: case mp_color_type:
- case mp_transform_type:
- @<Recycle a big node@>; break;
- case mp_dependent: case mp_proto_dependent:
- @<Recycle a dependency list@>; break;
- case mp_independent:
- @<Recycle an independent variable@>; break;
- case mp_token_list: case mp_structured:
- mp_confusion(mp, "recycle"); break;
-@:this can't happen recycle}{\quad recycle@>
- case mp_unsuffixed_macro: case mp_suffixed_macro:
- mp_delete_mac_ref(mp, value(p)); break;
- } /* there are no other cases */
- type(p)=undefined;
-}
-
-@ @<Recycle a big node@>=
-if ( v!=null ){
- q=v+mp->big_node_size[t];
- do {
- q=q-2; mp_recycle_value(mp, q);
- } while (q!=v);
- mp_free_node(mp, v,mp->big_node_size[t]);
-}
-
-@ @<Recycle a dependency list@>=
-{
- q=dep_list(p);
- while ( info(q)!=null ) q=link(q);
- link(prev_dep(p))=link(q);
- prev_dep(link(q))=prev_dep(p);
- link(q)=null; mp_flush_node_list(mp, dep_list(p));
-}
-
-@ When an independent variable disappears, it simply fades away, unless
-something depends on it. In the latter case, a dependent variable whose
-coefficient of dependence is maximal will take its place.
-The relevant algorithm is due to Ignacio~A. Zabala, who implemented it
-as part of his Ph.D. thesis (Stanford University, December 1982).
-@^Zabala Salelles, Ignacio Andr\'es@>
-
-For example, suppose that variable $x$ is being recycled, and that the
-only variables depending on~$x$ are $y=2x+a$ and $z=x+b$. In this case
-we want to make $y$ independent and $z=.5y-.5a+b$; no other variables
-will depend on~$y$. If $\\{tracingequations}>0$ in this situation,
-we will print `\.{\#\#\# -2x=-y+a}'.
-
-There's a slight complication, however: An independent variable $x$
-can occur both in dependency lists and in proto-dependency lists.
-This makes it necessary to be careful when deciding which coefficient
-is maximal.
-
-Furthermore, this complication is not so slight when
-a proto-dependent variable is chosen to become independent. For example,
-suppose that $y=2x+100a$ is proto-dependent while $z=x+b$ is dependent;
-then we must change $z=.5y-50a+b$ to a proto-dependency, because of the
-large coefficient `50'.
-
-In order to deal with these complications without wasting too much time,
-we shall link together the occurrences of~$x$ among all the linear
-dependencies, maintaining separate lists for the dependent and
-proto-dependent cases.
-
-@<Recycle an independent variable@>=
-{
- mp->max_c[mp_dependent]=0; mp->max_c[mp_proto_dependent]=0;
- mp->max_link[mp_dependent]=null; mp->max_link[mp_proto_dependent]=null;
- q=link(dep_head);
- while ( q!=dep_head ) {
- s=value_loc(q); /* now |link(s)=dep_list(q)| */
- while (1) {
- r=link(s);
- if ( info(r)==null ) break;
- if ( info(r)!=p ) {
- s=r;
- } else {
- t=type(q); link(s)=link(r); info(r)=q;
- if ( abs(value(r))>mp->max_c[t] ) {
- @<Record a new maximum coefficient of type |t|@>;
- } else {
- link(r)=mp->max_link[t]; mp->max_link[t]=r;
- }
- }
- }
- q=link(r);
- }
- if ( (mp->max_c[mp_dependent]>0)||(mp->max_c[mp_proto_dependent]>0) ) {
- @<Choose a dependent variable to take the place of the disappearing
- independent variable, and change all remaining dependencies
- accordingly@>;
- }
-}
-
-@ The code for independency removal makes use of three two-word arrays.
-
-@<Glob...@>=
-integer max_c[mp_proto_dependent+1]; /* max coefficient magnitude */
-pointer max_ptr[mp_proto_dependent+1]; /* where |p| occurs with |max_c| */
-pointer max_link[mp_proto_dependent+1]; /* other occurrences of |p| */
-
-@ @<Record a new maximum coefficient...@>=
-{
- if ( mp->max_c[t]>0 ) {
- link(mp->max_ptr[t])=mp->max_link[t]; mp->max_link[t]=mp->max_ptr[t];
- }
- mp->max_c[t]=abs(value(r)); mp->max_ptr[t]=r;
-}
-
-@ @<Choose a dependent...@>=
-{
- if ( (mp->max_c[mp_dependent] / 010000) >= mp->max_c[mp_proto_dependent] )
- t=mp_dependent;
- else
- t=mp_proto_dependent;
- @<Determine the dependency list |s| to substitute for the independent
- variable~|p|@>;
- t=mp_dependent+mp_proto_dependent-t; /* complement |t| */
- if ( mp->max_c[t]>0 ) { /* we need to pick up an unchosen dependency */
- link(mp->max_ptr[t])=mp->max_link[t]; mp->max_link[t]=mp->max_ptr[t];
- }
- if ( t!=mp_dependent ) { @<Substitute new dependencies in place of |p|@>; }
- else { @<Substitute new proto-dependencies in place of |p|@>;}
- mp_flush_node_list(mp, s);
- if ( mp->fix_needed ) mp_fix_dependencies(mp);
- check_arith;
-}
-
-@ Let |s=max_ptr[t]|. At this point we have $|value|(s)=\pm|max_c|[t]$,
-and |info(s)| points to the dependent variable~|pp| of type~|t| from
-whose dependency list we have removed node~|s|. We must reinsert
-node~|s| into the dependency list, with coefficient $-1.0$, and with
-|pp| as the new independent variable. Since |pp| will have a larger serial
-number than any other variable, we can put node |s| at the head of the
-list.
-
-@<Determine the dep...@>=
-s=mp->max_ptr[t]; pp=info(s); v=value(s);
-if ( t==mp_dependent ) value(s)=-fraction_one; else value(s)=-unity;
-r=dep_list(pp); link(s)=r;
-while ( info(r)!=null ) r=link(r);
-q=link(r); link(r)=null;
-prev_dep(q)=prev_dep(pp); link(prev_dep(pp))=q;
-new_indep(pp);
-if ( mp->cur_exp==pp ) if ( mp->cur_type==t ) mp->cur_type=mp_independent;
-if ( mp->internal[mp_tracing_equations]>0 ) {
- @<Show the transformed dependency@>;
-}
-
-@ Now $(-v)$ times the formerly independent variable~|p| is being replaced
-by the dependency list~|s|.
-
-@<Show the transformed...@>=
-if ( mp_interesting(mp, p) ) {
- mp_begin_diagnostic(mp); mp_print_nl(mp, "### ");
-@:]]]\#\#\#_}{\.{\#\#\#}@>
- if ( v>0 ) mp_print_char(mp, '-');
- if ( t==mp_dependent ) vv=mp_round_fraction(mp, mp->max_c[mp_dependent]);
- else vv=mp->max_c[mp_proto_dependent];
- if ( vv!=unity ) mp_print_scaled(mp, vv);
- mp_print_variable_name(mp, p);
- while ( value(p) % s_scale>0 ) {
- mp_print(mp, "*4"); value(p)=value(p)-2;
- }
- if ( t==mp_dependent ) mp_print_char(mp, '='); else mp_print(mp, " = ");
- mp_print_dependency(mp, s,t);
- mp_end_diagnostic(mp, false);
-}
-
-@ Finally, there are dependent and proto-dependent variables whose
-dependency lists must be brought up to date.
-
-@<Substitute new dependencies...@>=
-for (t=mp_dependent;t<=mp_proto_dependent;t++){
- r=mp->max_link[t];
- while ( r!=null ) {
- q=info(r);
- dep_list(q)=mp_p_plus_fq(mp, dep_list(q),
- mp_make_fraction(mp, value(r),-v),s,t,mp_dependent);
- if ( dep_list(q)==mp->dep_final ) mp_make_known(mp, q,mp->dep_final);
- q=r; r=link(r); mp_free_node(mp, q,dep_node_size);
- }
-}
-
-@ @<Substitute new proto...@>=
-for (t=mp_dependent;t<=mp_proto_dependent;t++) {
- r=mp->max_link[t];
- while ( r!=null ) {
- q=info(r);
- if ( t==mp_dependent ) { /* for safety's sake, we change |q| to |mp_proto_dependent| */
- if ( mp->cur_exp==q ) if ( mp->cur_type==mp_dependent )
- mp->cur_type=mp_proto_dependent;
- dep_list(q)=mp_p_over_v(mp, dep_list(q),unity,
- mp_dependent,mp_proto_dependent);
- type(q)=mp_proto_dependent;
- value(r)=mp_round_fraction(mp, value(r));
- }
- dep_list(q)=mp_p_plus_fq(mp, dep_list(q),
- mp_make_scaled(mp, value(r),-v),s,
- mp_proto_dependent,mp_proto_dependent);
- if ( dep_list(q)==mp->dep_final )
- mp_make_known(mp, q,mp->dep_final);
- q=r; r=link(r); mp_free_node(mp, q,dep_node_size);
- }
-}
-
-@ Here are some routines that provide handy combinations of actions
-that are often needed during error recovery. For example,
-`|flush_error|' flushes the current expression, replaces it by
-a given value, and calls |error|.
-
-Errors often are detected after an extra token has already been scanned.
-The `\\{put\_get}' routines put that token back before calling |error|;
-then they get it back again. (Or perhaps they get another token, if
-the user has changed things.)
-
-@<Declarations@>=
-void mp_flush_error (MP mp,scaled v);
-void mp_put_get_error (MP mp);
-void mp_put_get_flush_error (MP mp,scaled v) ;
-
-@ @c
-void mp_flush_error (MP mp,scaled v) {
- mp_error(mp); mp_flush_cur_exp(mp, v);
-}
-void mp_put_get_error (MP mp) {
- mp_back_error(mp); mp_get_x_next(mp);
-}
-void mp_put_get_flush_error (MP mp,scaled v) {
- mp_put_get_error(mp);
- mp_flush_cur_exp(mp, v);
-}
-
-@ A global variable |var_flag| is set to a special command code
-just before \MP\ calls |scan_expression|, if the expression should be
-treated as a variable when this command code immediately follows. For
-example, |var_flag| is set to |assignment| at the beginning of a
-statement, because we want to know the {\sl location\/} of a variable at
-the left of `\.{:=}', not the {\sl value\/} of that variable.
-
-The |scan_expression| subroutine calls |scan_tertiary|,
-which calls |scan_secondary|, which calls |scan_primary|, which sets
-|var_flag:=0|. In this way each of the scanning routines ``knows''
-when it has been called with a special |var_flag|, but |var_flag| is
-usually zero.
-
-A variable preceding a command that equals |var_flag| is converted to a
-token list rather than a value. Furthermore, an `\.{=}' sign following an
-expression with |var_flag=assignment| is not considered to be a relation
-that produces boolean expressions.
-
-
-@<Glob...@>=
-int var_flag; /* command that wants a variable */
-
-@ @<Set init...@>=
-mp->var_flag=0;
-
-@* \[37] Parsing primary expressions.
-The first parsing routine, |scan_primary|, is also the most complicated one,
-since it involves so many different cases. But each case---with one
-exception---is fairly simple by itself.
-
-When |scan_primary| begins, the first token of the primary to be scanned
-should already appear in |cur_cmd|, |cur_mod|, and |cur_sym|. The values
-of |cur_type| and |cur_exp| should be either dead or dormant, as explained
-earlier. If |cur_cmd| is not between |min_primary_command| and
-|max_primary_command|, inclusive, a syntax error will be signaled.
-
-@<Declare the basic parsing subroutines@>=
-void mp_scan_primary (MP mp) {
- pointer p,q,r; /* for list manipulation */
- quarterword c; /* a primitive operation code */
- int my_var_flag; /* initial value of |my_var_flag| */
- pointer l_delim,r_delim; /* hash addresses of a delimiter pair */
- @<Other local variables for |scan_primary|@>;
- my_var_flag=mp->var_flag; mp->var_flag=0;
-RESTART:
- check_arith;
- @<Supply diagnostic information, if requested@>;
- switch (mp->cur_cmd) {
- case left_delimiter:
- @<Scan a delimited primary@>; break;
- case begin_group:
- @<Scan a grouped primary@>; break;
- case string_token:
- @<Scan a string constant@>; break;
- case numeric_token:
- @<Scan a primary that starts with a numeric token@>; break;
- case nullary:
- @<Scan a nullary operation@>; break;
- case unary: case type_name: case cycle: case plus_or_minus:
- @<Scan a unary operation@>; break;
- case primary_binary:
- @<Scan a binary operation with `\&{of}' between its operands@>; break;
- case str_op:
- @<Convert a suffix to a string@>; break;
- case internal_quantity:
- @<Scan an internal numeric quantity@>; break;
- case capsule_token:
- mp_make_exp_copy(mp, mp->cur_mod); break;
- case tag_token:
- @<Scan a variable primary; |goto restart| if it turns out to be a macro@>; break;
- default:
- mp_bad_exp(mp, "A primary"); goto RESTART; break;
-@.A primary expression...@>
- }
- mp_get_x_next(mp); /* the routines |goto done| if they don't want this */
-DONE:
- if ( mp->cur_cmd==left_bracket ) {
- if ( mp->cur_type>=mp_known ) {
- @<Scan a mediation construction@>;
- }
- }
-}
-
-
-
-@ Errors at the beginning of expressions are flagged by |bad_exp|.
-
-@c void mp_bad_exp (MP mp, const char * s) {
- int save_flag;
- print_err(s); mp_print(mp, " expression can't begin with `");
- mp_print_cmd_mod(mp, mp->cur_cmd,mp->cur_mod);
- mp_print_char(mp, '\'');
- help4("I'm afraid I need some sort of value in order to continue,")
- ("so I've tentatively inserted `0'. You may want to")
- ("delete this zero and insert something else;")
- ("see Chapter 27 of The METAFONTbook for an example.");
-@:METAFONTbook}{\sl The {\logos METAFONT\/}book@>
- mp_back_input(mp); mp->cur_sym=0; mp->cur_cmd=numeric_token;
- mp->cur_mod=0; mp_ins_error(mp);
- save_flag=mp->var_flag; mp->var_flag=0; mp_get_x_next(mp);
- mp->var_flag=save_flag;
-}
-
-@ @<Supply diagnostic information, if requested@>=
-#ifdef DEBUG
-if ( mp->panicking ) mp_check_mem(mp, false);
-#endif
-if ( mp->interrupt!=0 ) if ( mp->OK_to_interrupt ) {
- mp_back_input(mp); check_interrupt; mp_get_x_next(mp);
-}
-
-@ @<Scan a delimited primary@>=
-{
- l_delim=mp->cur_sym; r_delim=mp->cur_mod;
- mp_get_x_next(mp); mp_scan_expression(mp);
- if ( (mp->cur_cmd==comma) && (mp->cur_type>=mp_known) ) {
- @<Scan the rest of a delimited set of numerics@>;
- } else {
- mp_check_delimiter(mp, l_delim,r_delim);
- }
-}
-
-@ The |stash_in| subroutine puts the current (numeric) expression into a field
-within a ``big node.''
-
-@c void mp_stash_in (MP mp,pointer p) {
- pointer q; /* temporary register */
- type(p)=mp->cur_type;
- if ( mp->cur_type==mp_known ) {
- value(p)=mp->cur_exp;
- } else {
- if ( mp->cur_type==mp_independent ) {
- @<Stash an independent |cur_exp| into a big node@>;
- } else {
- mp->mem[value_loc(p)]=mp->mem[value_loc(mp->cur_exp)];
- /* |dep_list(p):=dep_list(cur_exp)| and |prev_dep(p):=prev_dep(cur_exp)| */
- link(prev_dep(p))=p;
- }
- mp_free_node(mp, mp->cur_exp,value_node_size);
- }
- mp->cur_type=mp_vacuous;
-}
-
-@ In rare cases the current expression can become |independent|. There
-may be many dependency lists pointing to such an independent capsule,
-so we can't simply move it into place within a big node. Instead,
-we copy it, then recycle it.
-
-@ @<Stash an independent |cur_exp|...@>=
-{
- q=mp_single_dependency(mp, mp->cur_exp);
- if ( q==mp->dep_final ){
- type(p)=mp_known; value(p)=0; mp_free_node(mp, q,dep_node_size);
- } else {
- type(p)=mp_dependent; mp_new_dep(mp, p,q);
- }
- mp_recycle_value(mp, mp->cur_exp);
-}
-
-@ This code uses the fact that |red_part_loc| and |green_part_loc|
-are synonymous with |x_part_loc| and |y_part_loc|.
-
-@<Scan the rest of a delimited set of numerics@>=
-{
-p=mp_stash_cur_exp(mp);
-mp_get_x_next(mp); mp_scan_expression(mp);
-@<Make sure the second part of a pair or color has a numeric type@>;
-q=mp_get_node(mp, value_node_size); name_type(q)=mp_capsule;
-if ( mp->cur_cmd==comma ) type(q)=mp_color_type;
-else type(q)=mp_pair_type;
-mp_init_big_node(mp, q); r=value(q);
-mp_stash_in(mp, y_part_loc(r));
-mp_unstash_cur_exp(mp, p);
-mp_stash_in(mp, x_part_loc(r));
-if ( mp->cur_cmd==comma ) {
- @<Scan the last of a triplet of numerics@>;
-}
-if ( mp->cur_cmd==comma ) {
- type(q)=mp_cmykcolor_type;
- mp_init_big_node(mp, q); t=value(q);
- mp->mem[cyan_part_loc(t)]=mp->mem[red_part_loc(r)];
- value(cyan_part_loc(t))=value(red_part_loc(r));
- mp->mem[magenta_part_loc(t)]=mp->mem[green_part_loc(r)];
- value(magenta_part_loc(t))=value(green_part_loc(r));
- mp->mem[yellow_part_loc(t)]=mp->mem[blue_part_loc(r)];
- value(yellow_part_loc(t))=value(blue_part_loc(r));
- mp_recycle_value(mp, r);
- r=t;
- @<Scan the last of a quartet of numerics@>;
-}
-mp_check_delimiter(mp, l_delim,r_delim);
-mp->cur_type=type(q);
-mp->cur_exp=q;
-}
-
-@ @<Make sure the second part of a pair or color has a numeric type@>=
-if ( mp->cur_type<mp_known ) {
- exp_err("Nonnumeric ypart has been replaced by 0");
-@.Nonnumeric...replaced by 0@>
- help4("I've started to scan a pair `(a,b)' or a color `(a,b,c)';")
- ("but after finding a nice `a' I found a `b' that isn't")
- ("of numeric type. So I've changed that part to zero.")
- ("(The b that I didn't like appears above the error message.)");
- mp_put_get_flush_error(mp, 0);
-}
-
-@ @<Scan the last of a triplet of numerics@>=
-{
- mp_get_x_next(mp); mp_scan_expression(mp);
- if ( mp->cur_type<mp_known ) {
- exp_err("Nonnumeric third part has been replaced by 0");
-@.Nonnumeric...replaced by 0@>
- help3("I've just scanned a color `(a,b,c)' or cmykcolor(a,b,c,d); but the `c'")
- ("isn't of numeric type. So I've changed that part to zero.")
- ("(The c that I didn't like appears above the error message.)");
- mp_put_get_flush_error(mp, 0);
- }
- mp_stash_in(mp, blue_part_loc(r));
-}
-
-@ @<Scan the last of a quartet of numerics@>=
-{
- mp_get_x_next(mp); mp_scan_expression(mp);
- if ( mp->cur_type<mp_known ) {
- exp_err("Nonnumeric blackpart has been replaced by 0");
-@.Nonnumeric...replaced by 0@>
- help3("I've just scanned a cmykcolor `(c,m,y,k)'; but the `k' isn't")
- ("of numeric type. So I've changed that part to zero.")
- ("(The k that I didn't like appears above the error message.)");
- mp_put_get_flush_error(mp, 0);
- }
- mp_stash_in(mp, black_part_loc(r));
-}
-
-@ The local variable |group_line| keeps track of the line
-where a \&{begingroup} command occurred; this will be useful
-in an error message if the group doesn't actually end.
-
-@<Other local variables for |scan_primary|@>=
-integer group_line; /* where a group began */
-
-@ @<Scan a grouped primary@>=
-{
- group_line=mp_true_line(mp);
- if ( mp->internal[mp_tracing_commands]>0 ) show_cur_cmd_mod;
- save_boundary_item(p);
- do {
- mp_do_statement(mp); /* ends with |cur_cmd>=semicolon| */
- } while (mp->cur_cmd==semicolon);
- if ( mp->cur_cmd!=end_group ) {
- print_err("A group begun on line ");
-@.A group...never ended@>
- mp_print_int(mp, group_line);
- mp_print(mp, " never ended");
- help2("I saw a `begingroup' back there that hasn't been matched")
- ("by `endgroup'. So I've inserted `endgroup' now.");
- mp_back_error(mp); mp->cur_cmd=end_group;
- }
- mp_unsave(mp);
- /* this might change |cur_type|, if independent variables are recycled */
- if ( mp->internal[mp_tracing_commands]>0 ) show_cur_cmd_mod;
-}
-
-@ @<Scan a string constant@>=
-{
- mp->cur_type=mp_string_type; mp->cur_exp=mp->cur_mod;
-}
-
-@ Later we'll come to procedures that perform actual operations like
-addition, square root, and so on; our purpose now is to do the parsing.
-But we might as well mention those future procedures now, so that the
-suspense won't be too bad:
-
-\smallskip
-|do_nullary(c)| does primitive operations that have no operands (e.g.,
-`\&{true}' or `\&{pencircle}');
-
-\smallskip
-|do_unary(c)| applies a primitive operation to the current expression;
-
-\smallskip
-|do_binary(p,c)| applies a primitive operation to the capsule~|p|
-and the current expression.
-
-@<Scan a nullary operation@>=mp_do_nullary(mp, mp->cur_mod)
-
-@ @<Scan a unary operation@>=
-{
- c=mp->cur_mod; mp_get_x_next(mp); mp_scan_primary(mp);
- mp_do_unary(mp, c); goto DONE;
-}
-
-@ A numeric token might be a primary by itself, or it might be the
-numerator of a fraction composed solely of numeric tokens, or it might
-multiply the primary that follows (provided that the primary doesn't begin
-with a plus sign or a minus sign). The code here uses the facts that
-|max_primary_command=plus_or_minus| and
-|max_primary_command-1=numeric_token|. If a fraction is found that is less
-than unity, we try to retain higher precision when we use it in scalar
-multiplication.
-
-@<Other local variables for |scan_primary|@>=
-scaled num,denom; /* for primaries that are fractions, like `1/2' */
-
-@ @<Scan a primary that starts with a numeric token@>=
-{
- mp->cur_exp=mp->cur_mod; mp->cur_type=mp_known; mp_get_x_next(mp);
- if ( mp->cur_cmd!=slash ) {
- num=0; denom=0;
- } else {
- mp_get_x_next(mp);
- if ( mp->cur_cmd!=numeric_token ) {
- mp_back_input(mp);
- mp->cur_cmd=slash; mp->cur_mod=over; mp->cur_sym=frozen_slash;
- goto DONE;
- }
- num=mp->cur_exp; denom=mp->cur_mod;
- if ( denom==0 ) { @<Protest division by zero@>; }
- else { mp->cur_exp=mp_make_scaled(mp, num,denom); }
- check_arith; mp_get_x_next(mp);
- }
- if ( mp->cur_cmd>=min_primary_command ) {
- if ( mp->cur_cmd<numeric_token ) { /* in particular, |cur_cmd<>plus_or_minus| */
- p=mp_stash_cur_exp(mp); mp_scan_primary(mp);
- if ( (abs(num)>=abs(denom))||(mp->cur_type<mp_color_type) ) {
- mp_do_binary(mp, p,times);
- } else {
- mp_frac_mult(mp, num,denom);
- mp_free_node(mp, p,value_node_size);
- }
- }
- }
- goto DONE;
-}
-
-@ @<Protest division...@>=
-{
- print_err("Division by zero");
-@.Division by zero@>
- help1("I'll pretend that you meant to divide by 1."); mp_error(mp);
-}
-
-@ @<Scan a binary operation with `\&{of}' between its operands@>=
-{
- c=mp->cur_mod; mp_get_x_next(mp); mp_scan_expression(mp);
- if ( mp->cur_cmd!=of_token ) {
- mp_missing_err(mp, "of"); mp_print(mp, " for ");
- mp_print_cmd_mod(mp, primary_binary,c);
-@.Missing `of'@>
- help1("I've got the first argument; will look now for the other.");
- mp_back_error(mp);
- }
- p=mp_stash_cur_exp(mp); mp_get_x_next(mp); mp_scan_primary(mp);
- mp_do_binary(mp, p,c); goto DONE;
-}
-
-@ @<Convert a suffix to a string@>=
-{
- mp_get_x_next(mp); mp_scan_suffix(mp);
- mp->old_setting=mp->selector; mp->selector=new_string;
- mp_show_token_list(mp, mp->cur_exp,null,100000,0);
- mp_flush_token_list(mp, mp->cur_exp);
- mp->cur_exp=mp_make_string(mp); mp->selector=mp->old_setting;
- mp->cur_type=mp_string_type;
- goto DONE;
-}
-
-@ If an internal quantity appears all by itself on the left of an
-assignment, we return a token list of length one, containing the address
-of the internal quantity plus |hash_end|. (This accords with the conventions
-of the save stack, as described earlier.)
-
-@<Scan an internal...@>=
-{
- q=mp->cur_mod;
- if ( my_var_flag==assignment ) {
- mp_get_x_next(mp);
- if ( mp->cur_cmd==assignment ) {
- mp->cur_exp=mp_get_avail(mp);
- info(mp->cur_exp)=q+hash_end; mp->cur_type=mp_token_list;
- goto DONE;
- }
- mp_back_input(mp);
- }
- mp->cur_type=mp_known; mp->cur_exp=mp->internal[q];
-}
-
-@ The most difficult part of |scan_primary| has been saved for last, since
-it was necessary to build up some confidence first. We can now face the task
-of scanning a variable.
-
-As we scan a variable, we build a token list containing the relevant
-names and subscript values, simultaneously following along in the
-``collective'' structure to see if we are actually dealing with a macro
-instead of a value.
-
-The local variables |pre_head| and |post_head| will point to the beginning
-of the prefix and suffix lists; |tail| will point to the end of the list
-that is currently growing.
-
-Another local variable, |tt|, contains partial information about the
-declared type of the variable-so-far. If |tt>=mp_unsuffixed_macro|, the
-relation |tt=type(q)| will always hold. If |tt=undefined|, the routine
-doesn't bother to update its information about type. And if
-|undefined<tt<mp_unsuffixed_macro|, the precise value of |tt| isn't critical.
-
-@ @<Other local variables for |scan_primary|@>=
-pointer pre_head,post_head,tail;
- /* prefix and suffix list variables */
-small_number tt; /* approximation to the type of the variable-so-far */
-pointer t; /* a token */
-pointer macro_ref = 0; /* reference count for a suffixed macro */
-
-@ @<Scan a variable primary...@>=
-{
- fast_get_avail(pre_head); tail=pre_head; post_head=null; tt=mp_vacuous;
- while (1) {
- t=mp_cur_tok(mp); link(tail)=t;
- if ( tt!=undefined ) {
- @<Find the approximate type |tt| and corresponding~|q|@>;
- if ( tt>=mp_unsuffixed_macro ) {
- @<Either begin an unsuffixed macro call or
- prepare for a suffixed one@>;
- }
- }
- mp_get_x_next(mp); tail=t;
- if ( mp->cur_cmd==left_bracket ) {
- @<Scan for a subscript; replace |cur_cmd| by |numeric_token| if found@>;
- }
- if ( mp->cur_cmd>max_suffix_token ) break;
- if ( mp->cur_cmd<min_suffix_token ) break;
- } /* now |cur_cmd| is |internal_quantity|, |tag_token|, or |numeric_token| */
- @<Handle unusual cases that masquerade as variables, and |goto restart|
- or |goto done| if appropriate;
- otherwise make a copy of the variable and |goto done|@>;
-}
-
-@ @<Either begin an unsuffixed macro call or...@>=
-{
- link(tail)=null;
- if ( tt>mp_unsuffixed_macro ) { /* |tt=mp_suffixed_macro| */
- post_head=mp_get_avail(mp); tail=post_head; link(tail)=t;
- tt=undefined; macro_ref=value(q); add_mac_ref(macro_ref);
- } else {
- @<Set up unsuffixed macro call and |goto restart|@>;
- }
-}
-
-@ @<Scan for a subscript; replace |cur_cmd| by |numeric_token| if found@>=
-{
- mp_get_x_next(mp); mp_scan_expression(mp);
- if ( mp->cur_cmd!=right_bracket ) {
- @<Put the left bracket and the expression back to be rescanned@>;
- } else {
- if ( mp->cur_type!=mp_known ) mp_bad_subscript(mp);
- mp->cur_cmd=numeric_token; mp->cur_mod=mp->cur_exp; mp->cur_sym=0;
- }
-}
-
-@ The left bracket that we thought was introducing a subscript might have
-actually been the left bracket in a mediation construction like `\.{x[a,b]}'.
-So we don't issue an error message at this point; but we do want to back up
-so as to avoid any embarrassment about our incorrect assumption.
-
-@<Put the left bracket and the expression back to be rescanned@>=
-{
- mp_back_input(mp); /* that was the token following the current expression */
- mp_back_expr(mp); mp->cur_cmd=left_bracket;
- mp->cur_mod=0; mp->cur_sym=frozen_left_bracket;
-}
-
-@ Here's a routine that puts the current expression back to be read again.
-
-@c void mp_back_expr (MP mp) {
- pointer p; /* capsule token */
- p=mp_stash_cur_exp(mp); link(p)=null; back_list(p);
-}
-
-@ Unknown subscripts lead to the following error message.
-
-@c void mp_bad_subscript (MP mp) {
- exp_err("Improper subscript has been replaced by zero");
-@.Improper subscript...@>
- help3("A bracketed subscript must have a known numeric value;")
- ("unfortunately, what I found was the value that appears just")
- ("above this error message. So I'll try a zero subscript.");
- mp_flush_error(mp, 0);
-}
-
-@ Every time we call |get_x_next|, there's a chance that the variable we've
-been looking at will disappear. Thus, we cannot safely keep |q| pointing
-into the variable structure; we need to start searching from the root each time.
-
-@<Find the approximate type |tt| and corresponding~|q|@>=
-@^inner loop@>
-{
- p=link(pre_head); q=info(p); tt=undefined;
- if ( eq_type(q) % outer_tag==tag_token ) {
- q=equiv(q);
- if ( q==null ) goto DONE2;
- while (1) {
- p=link(p);
- if ( p==null ) {
- tt=type(q); goto DONE2;
- };
- if ( type(q)!=mp_structured ) goto DONE2;
- q=link(attr_head(q)); /* the |collective_subscript| attribute */
- if ( p>=mp->hi_mem_min ) { /* it's not a subscript */
- do { q=link(q); } while (! (attr_loc(q)>=info(p)));
- if ( attr_loc(q)>info(p) ) goto DONE2;
- }
- }
- }
-DONE2:
- ;
-}
-
-@ How do things stand now? Well, we have scanned an entire variable name,
-including possible subscripts and/or attributes; |cur_cmd|, |cur_mod|, and
-|cur_sym| represent the token that follows. If |post_head=null|, a
-token list for this variable name starts at |link(pre_head)|, with all
-subscripts evaluated. But if |post_head<>null|, the variable turned out
-to be a suffixed macro; |pre_head| is the head of the prefix list, while
-|post_head| is the head of a token list containing both `\.{\AT!}' and
-the suffix.
-
-Our immediate problem is to see if this variable still exists. (Variable
-structures can change drastically whenever we call |get_x_next|; users
-aren't supposed to do this, but the fact that it is possible means that
-we must be cautious.)
-
-The following procedure prints an error message when a variable
-unexpectedly disappears. Its help message isn't quite right for
-our present purposes, but we'll be able to fix that up.
-
-@c
-void mp_obliterated (MP mp,pointer q) {
- print_err("Variable "); mp_show_token_list(mp, q,null,1000,0);
- mp_print(mp, " has been obliterated");
-@.Variable...obliterated@>
- help5("It seems you did a nasty thing---probably by accident,")
- ("but nevertheless you nearly hornswoggled me...")
- ("While I was evaluating the right-hand side of this")
- ("command, something happened, and the left-hand side")
- ("is no longer a variable! So I won't change anything.");
-}
-
-@ If the variable does exist, we also need to check
-for a few other special cases before deciding that a plain old ordinary
-variable has, indeed, been scanned.
-
-@<Handle unusual cases that masquerade as variables...@>=
-if ( post_head!=null ) {
- @<Set up suffixed macro call and |goto restart|@>;
-}
-q=link(pre_head); free_avail(pre_head);
-if ( mp->cur_cmd==my_var_flag ) {
- mp->cur_type=mp_token_list; mp->cur_exp=q; goto DONE;
-}
-p=mp_find_variable(mp, q);
-if ( p!=null ) {
- mp_make_exp_copy(mp, p);
-} else {
- mp_obliterated(mp, q);
- mp->help_line[2]="While I was evaluating the suffix of this variable,";
- mp->help_line[1]="something was redefined, and it's no longer a variable!";
- mp->help_line[0]="In order to get back on my feet, I've inserted `0' instead.";
- mp_put_get_flush_error(mp, 0);
-}
-mp_flush_node_list(mp, q);
-goto DONE
-
-@ The only complication associated with macro calling is that the prefix
-and ``at'' parameters must be packaged in an appropriate list of lists.
-
-@<Set up unsuffixed macro call and |goto restart|@>=
-{
- p=mp_get_avail(mp); info(pre_head)=link(pre_head); link(pre_head)=p;
- info(p)=t; mp_macro_call(mp, value(q),pre_head,null);
- mp_get_x_next(mp);
- goto RESTART;
-}
-
-@ If the ``variable'' that turned out to be a suffixed macro no longer exists,
-we don't care, because we have reserved a pointer (|macro_ref|) to its
-token list.
-
-@<Set up suffixed macro call and |goto restart|@>=
-{
- mp_back_input(mp); p=mp_get_avail(mp); q=link(post_head);
- info(pre_head)=link(pre_head); link(pre_head)=post_head;
- info(post_head)=q; link(post_head)=p; info(p)=link(q); link(q)=null;
- mp_macro_call(mp, macro_ref,pre_head,null); decr(ref_count(macro_ref));
- mp_get_x_next(mp); goto RESTART;
-}
-
-@ Our remaining job is simply to make a copy of the value that has been
-found. Some cases are harder than others, but complexity arises solely
-because of the multiplicity of possible cases.
-
-@<Declare the procedure called |make_exp_copy|@>=
-@<Declare subroutines needed by |make_exp_copy|@>
-void mp_make_exp_copy (MP mp,pointer p) {
- pointer q,r,t; /* registers for list manipulation */
-RESTART:
- mp->cur_type=type(p);
- switch (mp->cur_type) {
- case mp_vacuous: case mp_boolean_type: case mp_known:
- mp->cur_exp=value(p); break;
- case unknown_types:
- mp->cur_exp=mp_new_ring_entry(mp, p);
- break;
- case mp_string_type:
- mp->cur_exp=value(p); add_str_ref(mp->cur_exp);
- break;
- case mp_picture_type:
- mp->cur_exp=value(p);add_edge_ref(mp->cur_exp);
- break;
- case mp_pen_type:
- mp->cur_exp=copy_pen(value(p));
- break;
- case mp_path_type:
- mp->cur_exp=mp_copy_path(mp, value(p));
- break;
- case mp_transform_type: case mp_color_type:
- case mp_cmykcolor_type: case mp_pair_type:
- @<Copy the big node |p|@>;
- break;
- case mp_dependent: case mp_proto_dependent:
- mp_encapsulate(mp, mp_copy_dep_list(mp, dep_list(p)));
- break;
- case mp_numeric_type:
- new_indep(p); goto RESTART;
- break;
- case mp_independent:
- q=mp_single_dependency(mp, p);
- if ( q==mp->dep_final ){
- mp->cur_type=mp_known; mp->cur_exp=0; mp_free_node(mp, q,dep_node_size);
- } else {
- mp->cur_type=mp_dependent; mp_encapsulate(mp, q);
- }
- break;
- default:
- mp_confusion(mp, "copy");
-@:this can't happen copy}{\quad copy@>
- break;
- }
-}
-
-@ The |encapsulate| subroutine assumes that |dep_final| is the
-tail of dependency list~|p|.
-
-@<Declare subroutines needed by |make_exp_copy|@>=
-void mp_encapsulate (MP mp,pointer p) {
- mp->cur_exp=mp_get_node(mp, value_node_size); type(mp->cur_exp)=mp->cur_type;
- name_type(mp->cur_exp)=mp_capsule; mp_new_dep(mp, mp->cur_exp,p);
-}
-
-@ The most tedious case arises when the user refers to a
-\&{pair}, \&{color}, or \&{transform} variable; we must copy several fields,
-each of which can be |independent|, |dependent|, |mp_proto_dependent|,
-or |known|.
-
-@<Copy the big node |p|@>=
-{
- if ( value(p)==null )
- mp_init_big_node(mp, p);
- t=mp_get_node(mp, value_node_size); name_type(t)=mp_capsule; type(t)=mp->cur_type;
- mp_init_big_node(mp, t);
- q=value(p)+mp->big_node_size[mp->cur_type];
- r=value(t)+mp->big_node_size[mp->cur_type];
- do {
- q=q-2; r=r-2; mp_install(mp, r,q);
- } while (q!=value(p));
- mp->cur_exp=t;
-}
-
-@ The |install| procedure copies a numeric field~|q| into field~|r| of
-a big node that will be part of a capsule.
-
-@<Declare subroutines needed by |make_exp_copy|@>=
-void mp_install (MP mp,pointer r, pointer q) {
- pointer p; /* temporary register */
- if ( type(q)==mp_known ){
- value(r)=value(q); type(r)=mp_known;
- } else if ( type(q)==mp_independent ) {
- p=mp_single_dependency(mp, q);
- if ( p==mp->dep_final ) {
- type(r)=mp_known; value(r)=0; mp_free_node(mp, p,dep_node_size);
- } else {
- type(r)=mp_dependent; mp_new_dep(mp, r,p);
- }
- } else {
- type(r)=type(q); mp_new_dep(mp, r,mp_copy_dep_list(mp, dep_list(q)));
- }
-}
-
-@ Expressions of the form `\.{a[b,c]}' are converted into
-`\.{b+a*(c-b)}', without checking the types of \.b~or~\.c,
-provided that \.a is numeric.
-
-@<Scan a mediation...@>=
-{
- p=mp_stash_cur_exp(mp); mp_get_x_next(mp); mp_scan_expression(mp);
- if ( mp->cur_cmd!=comma ) {
- @<Put the left bracket and the expression back...@>;
- mp_unstash_cur_exp(mp, p);
- } else {
- q=mp_stash_cur_exp(mp); mp_get_x_next(mp); mp_scan_expression(mp);
- if ( mp->cur_cmd!=right_bracket ) {
- mp_missing_err(mp, "]");
-@.Missing `]'@>
- help3("I've scanned an expression of the form `a[b,c',")
- ("so a right bracket should have come next.")
- ("I shall pretend that one was there.");
- mp_back_error(mp);
- }
- r=mp_stash_cur_exp(mp); mp_make_exp_copy(mp, q);
- mp_do_binary(mp, r,minus); mp_do_binary(mp, p,times);
- mp_do_binary(mp, q,plus); mp_get_x_next(mp);
- }
-}
-
-@ Here is a comparatively simple routine that is used to scan the
-\&{suffix} parameters of a macro.
-
-@<Declare the basic parsing subroutines@>=
-void mp_scan_suffix (MP mp) {
- pointer h,t; /* head and tail of the list being built */
- pointer p; /* temporary register */
- h=mp_get_avail(mp); t=h;
- while (1) {
- if ( mp->cur_cmd==left_bracket ) {
- @<Scan a bracketed subscript and set |cur_cmd:=numeric_token|@>;
- }
- if ( mp->cur_cmd==numeric_token ) {
- p=mp_new_num_tok(mp, mp->cur_mod);
- } else if ((mp->cur_cmd==tag_token)||(mp->cur_cmd==internal_quantity) ) {
- p=mp_get_avail(mp); info(p)=mp->cur_sym;
- } else {
- break;
- }
- link(t)=p; t=p; mp_get_x_next(mp);
- }
- mp->cur_exp=link(h); free_avail(h); mp->cur_type=mp_token_list;
-}
-
-@ @<Scan a bracketed subscript and set |cur_cmd:=numeric_token|@>=
-{
- mp_get_x_next(mp); mp_scan_expression(mp);
- if ( mp->cur_type!=mp_known ) mp_bad_subscript(mp);
- if ( mp->cur_cmd!=right_bracket ) {
- mp_missing_err(mp, "]");
-@.Missing `]'@>
- help3("I've seen a `[' and a subscript value, in a suffix,")
- ("so a right bracket should have come next.")
- ("I shall pretend that one was there.");
- mp_back_error(mp);
- }
- mp->cur_cmd=numeric_token; mp->cur_mod=mp->cur_exp;
-}
-
-@* \[38] Parsing secondary and higher expressions.
-
-After the intricacies of |scan_primary|\kern-1pt,
-the |scan_secondary| routine is
-refreshingly simple. It's not trivial, but the operations are relatively
-straightforward; the main difficulty is, again, that expressions and data
-structures might change drastically every time we call |get_x_next|, so a
-cautious approach is mandatory. For example, a macro defined by
-\&{primarydef} might have disappeared by the time its second argument has
-been scanned; we solve this by increasing the reference count of its token
-list, so that the macro can be called even after it has been clobbered.
-
-@<Declare the basic parsing subroutines@>=
-void mp_scan_secondary (MP mp) {
- pointer p; /* for list manipulation */
- halfword c,d; /* operation codes or modifiers */
- pointer mac_name; /* token defined with \&{primarydef} */
-RESTART:
- if ((mp->cur_cmd<min_primary_command)||
- (mp->cur_cmd>max_primary_command) )
- mp_bad_exp(mp, "A secondary");
-@.A secondary expression...@>
- mp_scan_primary(mp);
-CONTINUE:
- if ( mp->cur_cmd<=max_secondary_command &&
- mp->cur_cmd>=min_secondary_command ) {
- p=mp_stash_cur_exp(mp);
- c=mp->cur_mod; d=mp->cur_cmd;
- if ( d==secondary_primary_macro ) {
- mac_name=mp->cur_sym;
- add_mac_ref(c);
- }
- mp_get_x_next(mp);
- mp_scan_primary(mp);
- if ( d!=secondary_primary_macro ) {
- mp_do_binary(mp, p,c);
- } else {
- mp_back_input(mp);
- mp_binary_mac(mp, p,c,mac_name);
- decr(ref_count(c));
- mp_get_x_next(mp);
- goto RESTART;
- }
- goto CONTINUE;
- }
-}
-
-@ The following procedure calls a macro that has two parameters,
-|p| and |cur_exp|.
-
-@c void mp_binary_mac (MP mp,pointer p, pointer c, pointer n) {
- pointer q,r; /* nodes in the parameter list */
- q=mp_get_avail(mp); r=mp_get_avail(mp); link(q)=r;
- info(q)=p; info(r)=mp_stash_cur_exp(mp);
- mp_macro_call(mp, c,q,n);
-}
-
-@ The next procedure, |scan_tertiary|, is pretty much the same deal.
-
-@<Declare the basic parsing subroutines@>=
-void mp_scan_tertiary (MP mp) {
- pointer p; /* for list manipulation */
- halfword c,d; /* operation codes or modifiers */
- pointer mac_name; /* token defined with \&{secondarydef} */
-RESTART:
- if ((mp->cur_cmd<min_primary_command)||
- (mp->cur_cmd>max_primary_command) )
- mp_bad_exp(mp, "A tertiary");
-@.A tertiary expression...@>
- mp_scan_secondary(mp);
-CONTINUE:
- if ( mp->cur_cmd<=max_tertiary_command ) {
- if ( mp->cur_cmd>=min_tertiary_command ) {
- p=mp_stash_cur_exp(mp); c=mp->cur_mod; d=mp->cur_cmd;
- if ( d==tertiary_secondary_macro ) {
- mac_name=mp->cur_sym; add_mac_ref(c);
- };
- mp_get_x_next(mp); mp_scan_secondary(mp);
- if ( d!=tertiary_secondary_macro ) {
- mp_do_binary(mp, p,c);
- } else {
- mp_back_input(mp); mp_binary_mac(mp, p,c,mac_name);
- decr(ref_count(c)); mp_get_x_next(mp);
- goto RESTART;
- }
- goto CONTINUE;
- }
- }
-}
-
-@ Finally we reach the deepest level in our quartet of parsing routines.
-This one is much like the others; but it has an extra complication from
-paths, which materialize here.
-
-@d continue_path 25 /* a label inside of |scan_expression| */
-@d finish_path 26 /* another */
-
-@<Declare the basic parsing subroutines@>=
-void mp_scan_expression (MP mp) {
- pointer p,q,r,pp,qq; /* for list manipulation */
- halfword c,d; /* operation codes or modifiers */
- int my_var_flag; /* initial value of |var_flag| */
- pointer mac_name; /* token defined with \&{tertiarydef} */
- boolean cycle_hit; /* did a path expression just end with `\&{cycle}'? */
- scaled x,y; /* explicit coordinates or tension at a path join */
- int t; /* knot type following a path join */
- t=0; y=0; x=0;
- my_var_flag=mp->var_flag; mac_name=null;
-RESTART:
- if ((mp->cur_cmd<min_primary_command)||
- (mp->cur_cmd>max_primary_command) )
- mp_bad_exp(mp, "An");
-@.An expression...@>
- mp_scan_tertiary(mp);
-CONTINUE:
- if ( mp->cur_cmd<=max_expression_command )
- if ( mp->cur_cmd>=min_expression_command ) {
- if ( (mp->cur_cmd!=equals)||(my_var_flag!=assignment) ) {
- p=mp_stash_cur_exp(mp); c=mp->cur_mod; d=mp->cur_cmd;
- if ( d==expression_tertiary_macro ) {
- mac_name=mp->cur_sym; add_mac_ref(c);
- }
- if ( (d<ampersand)||((d==ampersand)&&
- ((type(p)==mp_pair_type)||(type(p)==mp_path_type))) ) {
- @<Scan a path construction operation;
- but |return| if |p| has the wrong type@>;
- } else {
- mp_get_x_next(mp); mp_scan_tertiary(mp);
- if ( d!=expression_tertiary_macro ) {
- mp_do_binary(mp, p,c);
- } else {
- mp_back_input(mp); mp_binary_mac(mp, p,c,mac_name);
- decr(ref_count(c)); mp_get_x_next(mp);
- goto RESTART;
- }
- }
- goto CONTINUE;
- }
- }
-}
-
-@ The reader should review the data structure conventions for paths before
-hoping to understand the next part of this code.
-
-@<Scan a path construction operation...@>=
-{
- cycle_hit=false;
- @<Convert the left operand, |p|, into a partial path ending at~|q|;
- but |return| if |p| doesn't have a suitable type@>;
-CONTINUE_PATH:
- @<Determine the path join parameters;
- but |goto finish_path| if there's only a direction specifier@>;
- if ( mp->cur_cmd==cycle ) {
- @<Get ready to close a cycle@>;
- } else {
- mp_scan_tertiary(mp);
- @<Convert the right operand, |cur_exp|,
- into a partial path from |pp| to~|qq|@>;
- }
- @<Join the partial paths and reset |p| and |q| to the head and tail
- of the result@>;
- if ( mp->cur_cmd>=min_expression_command )
- if ( mp->cur_cmd<=ampersand ) if ( ! cycle_hit ) goto CONTINUE_PATH;
-FINISH_PATH:
- @<Choose control points for the path and put the result into |cur_exp|@>;
-}
-
-@ @<Convert the left operand, |p|, into a partial path ending at~|q|...@>=
-{
- mp_unstash_cur_exp(mp, p);
- if ( mp->cur_type==mp_pair_type ) p=mp_new_knot(mp);
- else if ( mp->cur_type==mp_path_type ) p=mp->cur_exp;
- else return;
- q=p;
- while ( link(q)!=p ) q=link(q);
- if ( left_type(p)!=mp_endpoint ) { /* open up a cycle */
- r=mp_copy_knot(mp, p); link(q)=r; q=r;
- }
- left_type(p)=mp_open; right_type(q)=mp_open;
-}
-
-@ A pair of numeric values is changed into a knot node for a one-point path
-when \MP\ discovers that the pair is part of a path.
-
-@c @<Declare the procedure called |known_pair|@>
-pointer mp_new_knot (MP mp) { /* convert a pair to a knot with two endpoints */
- pointer q; /* the new node */
- q=mp_get_node(mp, knot_node_size); left_type(q)=mp_endpoint;
- right_type(q)=mp_endpoint; originator(q)=mp_metapost_user; link(q)=q;
- mp_known_pair(mp); x_coord(q)=mp->cur_x; y_coord(q)=mp->cur_y;
- return q;
-}
-
-@ The |known_pair| subroutine sets |cur_x| and |cur_y| to the components
-of the current expression, assuming that the current expression is a
-pair of known numerics. Unknown components are zeroed, and the
-current expression is flushed.
-
-@<Declare the procedure called |known_pair|@>=
-void mp_known_pair (MP mp) {
- pointer p; /* the pair node */
- if ( mp->cur_type!=mp_pair_type ) {
- exp_err("Undefined coordinates have been replaced by (0,0)");
-@.Undefined coordinates...@>
- help5("I need x and y numbers for this part of the path.")
- ("The value I found (see above) was no good;")
- ("so I'll try to keep going by using zero instead.")
- ("(Chapter 27 of The METAFONTbook explains that")
-@:METAFONTbook}{\sl The {\logos METAFONT\/}book@>
- ("you might want to type `I ??" "?' now.)");
- mp_put_get_flush_error(mp, 0); mp->cur_x=0; mp->cur_y=0;
- } else {
- p=value(mp->cur_exp);
- @<Make sure that both |x| and |y| parts of |p| are known;
- copy them into |cur_x| and |cur_y|@>;
- mp_flush_cur_exp(mp, 0);
- }
-}
-
-@ @<Make sure that both |x| and |y| parts of |p| are known...@>=
-if ( type(x_part_loc(p))==mp_known ) {
- mp->cur_x=value(x_part_loc(p));
-} else {
- mp_disp_err(mp, x_part_loc(p),
- "Undefined x coordinate has been replaced by 0");
-@.Undefined coordinates...@>
- help5("I need a `known' x value for this part of the path.")
- ("The value I found (see above) was no good;")
- ("so I'll try to keep going by using zero instead.")
- ("(Chapter 27 of The METAFONTbook explains that")
-@:METAFONTbook}{\sl The {\logos METAFONT\/}book@>
- ("you might want to type `I ??" "?' now.)");
- mp_put_get_error(mp); mp_recycle_value(mp, x_part_loc(p)); mp->cur_x=0;
-}
-if ( type(y_part_loc(p))==mp_known ) {
- mp->cur_y=value(y_part_loc(p));
-} else {
- mp_disp_err(mp, y_part_loc(p),
- "Undefined y coordinate has been replaced by 0");
- help5("I need a `known' y value for this part of the path.")
- ("The value I found (see above) was no good;")
- ("so I'll try to keep going by using zero instead.")
- ("(Chapter 27 of The METAFONTbook explains that")
- ("you might want to type `I ??" "?' now.)");
- mp_put_get_error(mp); mp_recycle_value(mp, y_part_loc(p)); mp->cur_y=0;
-}
-
-@ At this point |cur_cmd| is either |ampersand|, |left_brace|, or |path_join|.
-
-@<Determine the path join parameters...@>=
-if ( mp->cur_cmd==left_brace ) {
- @<Put the pre-join direction information into node |q|@>;
-}
-d=mp->cur_cmd;
-if ( d==path_join ) {
- @<Determine the tension and/or control points@>;
-} else if ( d!=ampersand ) {
- goto FINISH_PATH;
-}
-mp_get_x_next(mp);
-if ( mp->cur_cmd==left_brace ) {
- @<Put the post-join direction information into |x| and |t|@>;
-} else if ( right_type(q)!=mp_explicit ) {
- t=mp_open; x=0;
-}
-
-@ The |scan_direction| subroutine looks at the directional information
-that is enclosed in braces, and also scans ahead to the following character.
-A type code is returned, either |open| (if the direction was $(0,0)$),
-or |curl| (if the direction was a curl of known value |cur_exp|), or
-|given| (if the direction is given by the |angle| value that now
-appears in |cur_exp|).
-
-There's nothing difficult about this subroutine, but the program is rather
-lengthy because a variety of potential errors need to be nipped in the bud.
-
-@c small_number mp_scan_direction (MP mp) {
- int t; /* the type of information found */
- scaled x; /* an |x| coordinate */
- mp_get_x_next(mp);
- if ( mp->cur_cmd==curl_command ) {
- @<Scan a curl specification@>;
- } else {
- @<Scan a given direction@>;
- }
- if ( mp->cur_cmd!=right_brace ) {
- mp_missing_err(mp, "}");
-@.Missing `\char`\}'@>
- help3("I've scanned a direction spec for part of a path,")
- ("so a right brace should have come next.")
- ("I shall pretend that one was there.");
- mp_back_error(mp);
- }
- mp_get_x_next(mp);
- return t;
-}
-
-@ @<Scan a curl specification@>=
-{ mp_get_x_next(mp); mp_scan_expression(mp);
-if ( (mp->cur_type!=mp_known)||(mp->cur_exp<0) ){
- exp_err("Improper curl has been replaced by 1");
-@.Improper curl@>
- help1("A curl must be a known, nonnegative number.");
- mp_put_get_flush_error(mp, unity);
-}
-t=mp_curl;
-}
-
-@ @<Scan a given direction@>=
-{ mp_scan_expression(mp);
- if ( mp->cur_type>mp_pair_type ) {
- @<Get given directions separated by commas@>;
- } else {
- mp_known_pair(mp);
- }
- if ( (mp->cur_x==0)&&(mp->cur_y==0) ) t=mp_open;
- else { t=mp_given; mp->cur_exp=mp_n_arg(mp, mp->cur_x,mp->cur_y);}
-}
-
-@ @<Get given directions separated by commas@>=
-{
- if ( mp->cur_type!=mp_known ) {
- exp_err("Undefined x coordinate has been replaced by 0");
-@.Undefined coordinates...@>
- help5("I need a `known' x value for this part of the path.")
- ("The value I found (see above) was no good;")
- ("so I'll try to keep going by using zero instead.")
- ("(Chapter 27 of The METAFONTbook explains that")
-@:METAFONTbook}{\sl The {\logos METAFONT\/}book@>
- ("you might want to type `I ??" "?' now.)");
- mp_put_get_flush_error(mp, 0);
- }
- x=mp->cur_exp;
- if ( mp->cur_cmd!=comma ) {
- mp_missing_err(mp, ",");
-@.Missing `,'@>
- help2("I've got the x coordinate of a path direction;")
- ("will look for the y coordinate next.");
- mp_back_error(mp);
- }
- mp_get_x_next(mp); mp_scan_expression(mp);
- if ( mp->cur_type!=mp_known ) {
- exp_err("Undefined y coordinate has been replaced by 0");
- help5("I need a `known' y value for this part of the path.")
- ("The value I found (see above) was no good;")
- ("so I'll try to keep going by using zero instead.")
- ("(Chapter 27 of The METAFONTbook explains that")
- ("you might want to type `I ??" "?' now.)");
- mp_put_get_flush_error(mp, 0);
- }
- mp->cur_y=mp->cur_exp; mp->cur_x=x;
-}
-
-@ At this point |right_type(q)| is usually |open|, but it may have been
-set to some other value by a previous operation. We must maintain
-the value of |right_type(q)| in cases such as
-`\.{..\{curl2\}z\{0,0\}..}'.
-
-@<Put the pre-join...@>=
-{
- t=mp_scan_direction(mp);
- if ( t!=mp_open ) {
- right_type(q)=t; right_given(q)=mp->cur_exp;
- if ( left_type(q)==mp_open ) {
- left_type(q)=t; left_given(q)=mp->cur_exp;
- } /* note that |left_given(q)=left_curl(q)| */
- }
-}
-
-@ Since |left_tension| and |left_y| share the same position in knot nodes,
-and since |left_given| is similarly equivalent to |left_x|, we use
-|x| and |y| to hold the given direction and tension information when
-there are no explicit control points.
-
-@<Put the post-join...@>=
-{
- t=mp_scan_direction(mp);
- if ( right_type(q)!=mp_explicit ) x=mp->cur_exp;
- else t=mp_explicit; /* the direction information is superfluous */
-}
-
-@ @<Determine the tension and/or...@>=
-{
- mp_get_x_next(mp);
- if ( mp->cur_cmd==tension ) {
- @<Set explicit tensions@>;
- } else if ( mp->cur_cmd==controls ) {
- @<Set explicit control points@>;
- } else {
- right_tension(q)=unity; y=unity; mp_back_input(mp); /* default tension */
- goto DONE;
- };
- if ( mp->cur_cmd!=path_join ) {
- mp_missing_err(mp, "..");
-@.Missing `..'@>
- help1("A path join command should end with two dots.");
- mp_back_error(mp);
- }
-DONE:
- ;
-}
-
-@ @<Set explicit tensions@>=
-{
- mp_get_x_next(mp); y=mp->cur_cmd;
- if ( mp->cur_cmd==at_least ) mp_get_x_next(mp);
- mp_scan_primary(mp);
- @<Make sure that the current expression is a valid tension setting@>;
- if ( y==at_least ) negate(mp->cur_exp);
- right_tension(q)=mp->cur_exp;
- if ( mp->cur_cmd==and_command ) {
- mp_get_x_next(mp); y=mp->cur_cmd;
- if ( mp->cur_cmd==at_least ) mp_get_x_next(mp);
- mp_scan_primary(mp);
- @<Make sure that the current expression is a valid tension setting@>;
- if ( y==at_least ) negate(mp->cur_exp);
- }
- y=mp->cur_exp;
-}
-
-@ @d min_tension three_quarter_unit
-
-@<Make sure that the current expression is a valid tension setting@>=
-if ( (mp->cur_type!=mp_known)||(mp->cur_exp<min_tension) ) {
- exp_err("Improper tension has been set to 1");
-@.Improper tension@>
- help1("The expression above should have been a number >=3/4.");
- mp_put_get_flush_error(mp, unity);
-}
-
-@ @<Set explicit control points@>=
-{
- right_type(q)=mp_explicit; t=mp_explicit; mp_get_x_next(mp); mp_scan_primary(mp);
- mp_known_pair(mp); right_x(q)=mp->cur_x; right_y(q)=mp->cur_y;
- if ( mp->cur_cmd!=and_command ) {
- x=right_x(q); y=right_y(q);
- } else {
- mp_get_x_next(mp); mp_scan_primary(mp);
- mp_known_pair(mp); x=mp->cur_x; y=mp->cur_y;
- }
-}
-
-@ @<Convert the right operand, |cur_exp|, into a partial path...@>=
-{
- if ( mp->cur_type!=mp_path_type ) pp=mp_new_knot(mp);
- else pp=mp->cur_exp;
- qq=pp;
- while ( link(qq)!=pp ) qq=link(qq);
- if ( left_type(pp)!=mp_endpoint ) { /* open up a cycle */
- r=mp_copy_knot(mp, pp); link(qq)=r; qq=r;
- }
- left_type(pp)=mp_open; right_type(qq)=mp_open;
-}
-
-@ If a person tries to define an entire path by saying `\.{(x,y)\&cycle}',
-we silently change the specification to `\.{(x,y)..cycle}', since a cycle
-shouldn't have length zero.
-
-@<Get ready to close a cycle@>=
-{
- cycle_hit=true; mp_get_x_next(mp); pp=p; qq=p;
- if ( d==ampersand ) if ( p==q ) {
- d=path_join; right_tension(q)=unity; y=unity;
- }
-}
-
-@ @<Join the partial paths and reset |p| and |q|...@>=
-{
-if ( d==ampersand ) {
- if ( (x_coord(q)!=x_coord(pp))||(y_coord(q)!=y_coord(pp)) ) {
- print_err("Paths don't touch; `&' will be changed to `..'");
-@.Paths don't touch@>
- help3("When you join paths `p&q', the ending point of p")
- ("must be exactly equal to the starting point of q.")
- ("So I'm going to pretend that you said `p..q' instead.");
- mp_put_get_error(mp); d=path_join; right_tension(q)=unity; y=unity;
- }
-}
-@<Plug an opening in |right_type(pp)|, if possible@>;
-if ( d==ampersand ) {
- @<Splice independent paths together@>;
-} else {
- @<Plug an opening in |right_type(q)|, if possible@>;
- link(q)=pp; left_y(pp)=y;
- if ( t!=mp_open ) { left_x(pp)=x; left_type(pp)=t; };
-}
-q=qq;
-}
-
-@ @<Plug an opening in |right_type(q)|...@>=
-if ( right_type(q)==mp_open ) {
- if ( (left_type(q)==mp_curl)||(left_type(q)==mp_given) ) {
- right_type(q)=left_type(q); right_given(q)=left_given(q);
- }
-}
-
-@ @<Plug an opening in |right_type(pp)|...@>=
-if ( right_type(pp)==mp_open ) {
- if ( (t==mp_curl)||(t==mp_given) ) {
- right_type(pp)=t; right_given(pp)=x;
- }
-}
-
-@ @<Splice independent paths together@>=
-{
- if ( left_type(q)==mp_open ) if ( right_type(q)==mp_open ) {
- left_type(q)=mp_curl; left_curl(q)=unity;
- }
- if ( right_type(pp)==mp_open ) if ( t==mp_open ) {
- right_type(pp)=mp_curl; right_curl(pp)=unity;
- }
- right_type(q)=right_type(pp); link(q)=link(pp);
- right_x(q)=right_x(pp); right_y(q)=right_y(pp);
- mp_free_node(mp, pp,knot_node_size);
- if ( qq==pp ) qq=q;
-}
-
-@ @<Choose control points for the path...@>=
-if ( cycle_hit ) {
- if ( d==ampersand ) p=q;
-} else {
- left_type(p)=mp_endpoint;
- if ( right_type(p)==mp_open ) {
- right_type(p)=mp_curl; right_curl(p)=unity;
- }
- right_type(q)=mp_endpoint;
- if ( left_type(q)==mp_open ) {
- left_type(q)=mp_curl; left_curl(q)=unity;
- }
- link(q)=p;
-}
-mp_make_choices(mp, p);
-mp->cur_type=mp_path_type; mp->cur_exp=p
-
-@ Finally, we sometimes need to scan an expression whose value is
-supposed to be either |true_code| or |false_code|.
-
-@<Declare the basic parsing subroutines@>=
-void mp_get_boolean (MP mp) {
- mp_get_x_next(mp); mp_scan_expression(mp);
- if ( mp->cur_type!=mp_boolean_type ) {
- exp_err("Undefined condition will be treated as `false'");
-@.Undefined condition...@>
- help2("The expression shown above should have had a definite")
- ("true-or-false value. I'm changing it to `false'.");
- mp_put_get_flush_error(mp, false_code); mp->cur_type=mp_boolean_type;
- }
-}
-
-@* \[39] Doing the operations.
-The purpose of parsing is primarily to permit people to avoid piles of
-parentheses. But the real work is done after the structure of an expression
-has been recognized; that's when new expressions are generated. We
-turn now to the guts of \MP, which handles individual operators that
-have come through the parsing mechanism.
-
-We'll start with the easy ones that take no operands, then work our way
-up to operators with one and ultimately two arguments. In other words,
-we will write the three procedures |do_nullary|, |do_unary|, and |do_binary|
-that are invoked periodically by the expression scanners.
-
-First let's make sure that all of the primitive operators are in the
-hash table. Although |scan_primary| and its relatives made use of the
-\\{cmd} code for these operators, the \\{do} routines base everything
-on the \\{mod} code. For example, |do_binary| doesn't care whether the
-operation it performs is a |primary_binary| or |secondary_binary|, etc.
-
-@<Put each...@>=
-mp_primitive(mp, "true",nullary,true_code);
-@:true_}{\&{true} primitive@>
-mp_primitive(mp, "false",nullary,false_code);
-@:false_}{\&{false} primitive@>
-mp_primitive(mp, "nullpicture",nullary,null_picture_code);
-@:null_picture_}{\&{nullpicture} primitive@>
-mp_primitive(mp, "nullpen",nullary,null_pen_code);
-@:null_pen_}{\&{nullpen} primitive@>
-mp_primitive(mp, "jobname",nullary,job_name_op);
-@:job_name_}{\&{jobname} primitive@>
-mp_primitive(mp, "readstring",nullary,read_string_op);
-@:read_string_}{\&{readstring} primitive@>
-mp_primitive(mp, "pencircle",nullary,pen_circle);
-@:pen_circle_}{\&{pencircle} primitive@>
-mp_primitive(mp, "normaldeviate",nullary,normal_deviate);
-@:normal_deviate_}{\&{normaldeviate} primitive@>
-mp_primitive(mp, "readfrom",unary,read_from_op);
-@:read_from_}{\&{readfrom} primitive@>
-mp_primitive(mp, "closefrom",unary,close_from_op);
-@:close_from_}{\&{closefrom} primitive@>
-mp_primitive(mp, "odd",unary,odd_op);
-@:odd_}{\&{odd} primitive@>
-mp_primitive(mp, "known",unary,known_op);
-@:known_}{\&{known} primitive@>
-mp_primitive(mp, "unknown",unary,unknown_op);
-@:unknown_}{\&{unknown} primitive@>
-mp_primitive(mp, "not",unary,not_op);
-@:not_}{\&{not} primitive@>
-mp_primitive(mp, "decimal",unary,decimal);
-@:decimal_}{\&{decimal} primitive@>
-mp_primitive(mp, "reverse",unary,reverse);
-@:reverse_}{\&{reverse} primitive@>
-mp_primitive(mp, "makepath",unary,make_path_op);
-@:make_path_}{\&{makepath} primitive@>
-mp_primitive(mp, "makepen",unary,make_pen_op);
-@:make_pen_}{\&{makepen} primitive@>
-mp_primitive(mp, "oct",unary,oct_op);
-@:oct_}{\&{oct} primitive@>
-mp_primitive(mp, "hex",unary,hex_op);
-@:hex_}{\&{hex} primitive@>
-mp_primitive(mp, "ASCII",unary,ASCII_op);
-@:ASCII_}{\&{ASCII} primitive@>
-mp_primitive(mp, "char",unary,char_op);
-@:char_}{\&{char} primitive@>
-mp_primitive(mp, "length",unary,length_op);
-@:length_}{\&{length} primitive@>
-mp_primitive(mp, "turningnumber",unary,turning_op);
-@:turning_number_}{\&{turningnumber} primitive@>
-mp_primitive(mp, "xpart",unary,x_part);
-@:x_part_}{\&{xpart} primitive@>
-mp_primitive(mp, "ypart",unary,y_part);
-@:y_part_}{\&{ypart} primitive@>
-mp_primitive(mp, "xxpart",unary,xx_part);
-@:xx_part_}{\&{xxpart} primitive@>
-mp_primitive(mp, "xypart",unary,xy_part);
-@:xy_part_}{\&{xypart} primitive@>
-mp_primitive(mp, "yxpart",unary,yx_part);
-@:yx_part_}{\&{yxpart} primitive@>
-mp_primitive(mp, "yypart",unary,yy_part);
-@:yy_part_}{\&{yypart} primitive@>
-mp_primitive(mp, "redpart",unary,red_part);
-@:red_part_}{\&{redpart} primitive@>
-mp_primitive(mp, "greenpart",unary,green_part);
-@:green_part_}{\&{greenpart} primitive@>
-mp_primitive(mp, "bluepart",unary,blue_part);
-@:blue_part_}{\&{bluepart} primitive@>
-mp_primitive(mp, "cyanpart",unary,cyan_part);
-@:cyan_part_}{\&{cyanpart} primitive@>
-mp_primitive(mp, "magentapart",unary,magenta_part);
-@:magenta_part_}{\&{magentapart} primitive@>
-mp_primitive(mp, "yellowpart",unary,yellow_part);
-@:yellow_part_}{\&{yellowpart} primitive@>
-mp_primitive(mp, "blackpart",unary,black_part);
-@:black_part_}{\&{blackpart} primitive@>
-mp_primitive(mp, "greypart",unary,grey_part);
-@:grey_part_}{\&{greypart} primitive@>
-mp_primitive(mp, "colormodel",unary,color_model_part);
-@:color_model_part_}{\&{colormodel} primitive@>
-mp_primitive(mp, "fontpart",unary,font_part);
-@:font_part_}{\&{fontpart} primitive@>
-mp_primitive(mp, "textpart",unary,text_part);
-@:text_part_}{\&{textpart} primitive@>
-mp_primitive(mp, "pathpart",unary,path_part);
-@:path_part_}{\&{pathpart} primitive@>
-mp_primitive(mp, "penpart",unary,pen_part);
-@:pen_part_}{\&{penpart} primitive@>
-mp_primitive(mp, "dashpart",unary,dash_part);
-@:dash_part_}{\&{dashpart} primitive@>
-mp_primitive(mp, "sqrt",unary,sqrt_op);
-@:sqrt_}{\&{sqrt} primitive@>
-mp_primitive(mp, "mexp",unary,m_exp_op);
-@:m_exp_}{\&{mexp} primitive@>
-mp_primitive(mp, "mlog",unary,m_log_op);
-@:m_log_}{\&{mlog} primitive@>
-mp_primitive(mp, "sind",unary,sin_d_op);
-@:sin_d_}{\&{sind} primitive@>
-mp_primitive(mp, "cosd",unary,cos_d_op);
-@:cos_d_}{\&{cosd} primitive@>
-mp_primitive(mp, "floor",unary,floor_op);
-@:floor_}{\&{floor} primitive@>
-mp_primitive(mp, "uniformdeviate",unary,uniform_deviate);
-@:uniform_deviate_}{\&{uniformdeviate} primitive@>
-mp_primitive(mp, "charexists",unary,char_exists_op);
-@:char_exists_}{\&{charexists} primitive@>
-mp_primitive(mp, "fontsize",unary,font_size);
-@:font_size_}{\&{fontsize} primitive@>
-mp_primitive(mp, "llcorner",unary,ll_corner_op);
-@:ll_corner_}{\&{llcorner} primitive@>
-mp_primitive(mp, "lrcorner",unary,lr_corner_op);
-@:lr_corner_}{\&{lrcorner} primitive@>
-mp_primitive(mp, "ulcorner",unary,ul_corner_op);
-@:ul_corner_}{\&{ulcorner} primitive@>
-mp_primitive(mp, "urcorner",unary,ur_corner_op);
-@:ur_corner_}{\&{urcorner} primitive@>
-mp_primitive(mp, "arclength",unary,arc_length);
-@:arc_length_}{\&{arclength} primitive@>
-mp_primitive(mp, "angle",unary,angle_op);
-@:angle_}{\&{angle} primitive@>
-mp_primitive(mp, "cycle",cycle,cycle_op);
-@:cycle_}{\&{cycle} primitive@>
-mp_primitive(mp, "stroked",unary,stroked_op);
-@:stroked_}{\&{stroked} primitive@>
-mp_primitive(mp, "filled",unary,filled_op);
-@:filled_}{\&{filled} primitive@>
-mp_primitive(mp, "textual",unary,textual_op);
-@:textual_}{\&{textual} primitive@>
-mp_primitive(mp, "clipped",unary,clipped_op);
-@:clipped_}{\&{clipped} primitive@>
-mp_primitive(mp, "bounded",unary,bounded_op);
-@:bounded_}{\&{bounded} primitive@>
-mp_primitive(mp, "+",plus_or_minus,plus);
-@:+ }{\.{+} primitive@>
-mp_primitive(mp, "-",plus_or_minus,minus);
-@:- }{\.{-} primitive@>
-mp_primitive(mp, "*",secondary_binary,times);
-@:* }{\.{*} primitive@>
-mp_primitive(mp, "/",slash,over); mp->eqtb[frozen_slash]=mp->eqtb[mp->cur_sym];
-@:/ }{\.{/} primitive@>
-mp_primitive(mp, "++",tertiary_binary,pythag_add);
-@:++_}{\.{++} primitive@>
-mp_primitive(mp, "+-+",tertiary_binary,pythag_sub);
-@:+-+_}{\.{+-+} primitive@>
-mp_primitive(mp, "or",tertiary_binary,or_op);
-@:or_}{\&{or} primitive@>
-mp_primitive(mp, "and",and_command,and_op);
-@:and_}{\&{and} primitive@>
-mp_primitive(mp, "<",expression_binary,less_than);
-@:< }{\.{<} primitive@>
-mp_primitive(mp, "<=",expression_binary,less_or_equal);
-@:<=_}{\.{<=} primitive@>
-mp_primitive(mp, ">",expression_binary,greater_than);
-@:> }{\.{>} primitive@>
-mp_primitive(mp, ">=",expression_binary,greater_or_equal);
-@:>=_}{\.{>=} primitive@>
-mp_primitive(mp, "=",equals,equal_to);
-@:= }{\.{=} primitive@>
-mp_primitive(mp, "<>",expression_binary,unequal_to);
-@:<>_}{\.{<>} primitive@>
-mp_primitive(mp, "substring",primary_binary,substring_of);
-@:substring_}{\&{substring} primitive@>
-mp_primitive(mp, "subpath",primary_binary,subpath_of);
-@:subpath_}{\&{subpath} primitive@>
-mp_primitive(mp, "directiontime",primary_binary,direction_time_of);
-@:direction_time_}{\&{directiontime} primitive@>
-mp_primitive(mp, "point",primary_binary,point_of);
-@:point_}{\&{point} primitive@>
-mp_primitive(mp, "precontrol",primary_binary,precontrol_of);
-@:precontrol_}{\&{precontrol} primitive@>
-mp_primitive(mp, "postcontrol",primary_binary,postcontrol_of);
-@:postcontrol_}{\&{postcontrol} primitive@>
-mp_primitive(mp, "penoffset",primary_binary,pen_offset_of);
-@:pen_offset_}{\&{penoffset} primitive@>
-mp_primitive(mp, "arctime",primary_binary,arc_time_of);
-@:arc_time_of_}{\&{arctime} primitive@>
-mp_primitive(mp, "mpversion",nullary,mp_version);
-@:mp_verison_}{\&{mpversion} primitive@>
-mp_primitive(mp, "&",ampersand,concatenate);
-@:!!!}{\.{\&} primitive@>
-mp_primitive(mp, "rotated",secondary_binary,rotated_by);
-@:rotated_}{\&{rotated} primitive@>
-mp_primitive(mp, "slanted",secondary_binary,slanted_by);
-@:slanted_}{\&{slanted} primitive@>
-mp_primitive(mp, "scaled",secondary_binary,scaled_by);
-@:scaled_}{\&{scaled} primitive@>
-mp_primitive(mp, "shifted",secondary_binary,shifted_by);
-@:shifted_}{\&{shifted} primitive@>
-mp_primitive(mp, "transformed",secondary_binary,transformed_by);
-@:transformed_}{\&{transformed} primitive@>
-mp_primitive(mp, "xscaled",secondary_binary,x_scaled);
-@:x_scaled_}{\&{xscaled} primitive@>
-mp_primitive(mp, "yscaled",secondary_binary,y_scaled);
-@:y_scaled_}{\&{yscaled} primitive@>
-mp_primitive(mp, "zscaled",secondary_binary,z_scaled);
-@:z_scaled_}{\&{zscaled} primitive@>
-mp_primitive(mp, "infont",secondary_binary,in_font);
-@:in_font_}{\&{infont} primitive@>
-mp_primitive(mp, "intersectiontimes",tertiary_binary,intersect);
-@:intersection_times_}{\&{intersectiontimes} primitive@>
-mp_primitive(mp, "envelope",primary_binary,envelope_of);
-@:envelope_}{\&{envelope} primitive@>
-
-@ @<Cases of |print_cmd...@>=
-case nullary:
-case unary:
-case primary_binary:
-case secondary_binary:
-case tertiary_binary:
-case expression_binary:
-case cycle:
-case plus_or_minus:
-case slash:
-case ampersand:
-case equals:
-case and_command:
- mp_print_op(mp, m);
- break;
-
-@ OK, let's look at the simplest \\{do} procedure first.
-
-@c @<Declare nullary action procedure@>
-void mp_do_nullary (MP mp,quarterword c) {
- check_arith;
- if ( mp->internal[mp_tracing_commands]>two )
- mp_show_cmd_mod(mp, nullary,c);
- switch (c) {
- case true_code: case false_code:
- mp->cur_type=mp_boolean_type; mp->cur_exp=c;
- break;
- case null_picture_code:
- mp->cur_type=mp_picture_type;
- mp->cur_exp=mp_get_node(mp, edge_header_size);
- mp_init_edges(mp, mp->cur_exp);
- break;
- case null_pen_code:
- mp->cur_type=mp_pen_type; mp->cur_exp=mp_get_pen_circle(mp, 0);
- break;
- case normal_deviate:
- mp->cur_type=mp_known; mp->cur_exp=mp_norm_rand(mp);
- break;
- case pen_circle:
- mp->cur_type=mp_pen_type; mp->cur_exp=mp_get_pen_circle(mp, unity);
- break;
- case job_name_op:
- if ( mp->job_name==NULL ) mp_open_log_file(mp);
- mp->cur_type=mp_string_type; mp->cur_exp=rts(mp->job_name);
- break;
- case mp_version:
- mp->cur_type=mp_string_type;
- mp->cur_exp=intern(metapost_version) ;
- break;
- case read_string_op:
- @<Read a string from the terminal@>;
- break;
- } /* there are no other cases */
- check_arith;
-}
-
-@ @<Read a string...@>=
-{
- if ( mp->interaction<=mp_nonstop_mode )
- mp_fatal_error(mp, "*** (cannot readstring in nonstop modes)");
- mp_begin_file_reading(mp); name=is_read;
- limit=start; prompt_input("");
- mp_finish_read(mp);
-}
-
-@ @<Declare nullary action procedure@>=
-void mp_finish_read (MP mp) { /* copy |buffer| line to |cur_exp| */
- size_t k;
- str_room((int)mp->last-start);
- for (k=start;k<=mp->last-1;k++) {
- append_char(mp->buffer[k]);
- }
- mp_end_file_reading(mp); mp->cur_type=mp_string_type;
- mp->cur_exp=mp_make_string(mp);
-}
-
-@ Things get a bit more interesting when there's an operand. The
-operand to |do_unary| appears in |cur_type| and |cur_exp|.
-
-@c @<Declare unary action procedures@>
-void mp_do_unary (MP mp,quarterword c) {
- pointer p,q,r; /* for list manipulation */
- integer x; /* a temporary register */
- check_arith;
- if ( mp->internal[mp_tracing_commands]>two )
- @<Trace the current unary operation@>;
- switch (c) {
- case plus:
- if ( mp->cur_type<mp_color_type ) mp_bad_unary(mp, plus);
- break;
- case minus:
- @<Negate the current expression@>;
- break;
- @<Additional cases of unary operators@>;
- } /* there are no other cases */
- check_arith;
-}
-
-@ The |nice_pair| function returns |true| if both components of a pair
-are known.
-
-@<Declare unary action procedures@>=
-boolean mp_nice_pair (MP mp,integer p, quarterword t) {
- if ( t==mp_pair_type ) {
- p=value(p);
- if ( type(x_part_loc(p))==mp_known )
- if ( type(y_part_loc(p))==mp_known )
- return true;
- }
- return false;
-}
-
-@ The |nice_color_or_pair| function is analogous except that it also accepts
-fully known colors.
-
-@<Declare unary action procedures@>=
-boolean mp_nice_color_or_pair (MP mp,integer p, quarterword t) {
- pointer q,r; /* for scanning the big node */
- if ( (t!=mp_pair_type)&&(t!=mp_color_type)&&(t!=mp_cmykcolor_type) ) {
- return false;
- } else {
- q=value(p);
- r=q+mp->big_node_size[type(p)];
- do {
- r=r-2;
- if ( type(r)!=mp_known )
- return false;
- } while (r!=q);
- return true;
- }
-}
-
-@ @<Declare unary action...@>=
-void mp_print_known_or_unknown_type (MP mp,small_number t, integer v) {
- mp_print_char(mp, '(');
- if ( t>mp_known ) mp_print(mp, "unknown numeric");
- else { if ( (t==mp_pair_type)||(t==mp_color_type)||(t==mp_cmykcolor_type) )
- if ( ! mp_nice_color_or_pair(mp, v,t) ) mp_print(mp, "unknown ");
- mp_print_type(mp, t);
- }
- mp_print_char(mp, ')');
-}
-
-@ @<Declare unary action...@>=
-void mp_bad_unary (MP mp,quarterword c) {
- exp_err("Not implemented: "); mp_print_op(mp, c);
-@.Not implemented...@>
- mp_print_known_or_unknown_type(mp, mp->cur_type,mp->cur_exp);
- help3("I'm afraid I don't know how to apply that operation to that")
- ("particular type. Continue, and I'll simply return the")
- ("argument (shown above) as the result of the operation.");
- mp_put_get_error(mp);
-}
-
-@ @<Trace the current unary operation@>=
-{
- mp_begin_diagnostic(mp); mp_print_nl(mp, "{");
- mp_print_op(mp, c); mp_print_char(mp, '(');
- mp_print_exp(mp, null,0); /* show the operand, but not verbosely */
- mp_print(mp, ")}"); mp_end_diagnostic(mp, false);
-}
-
-@ Negation is easy except when the current expression
-is of type |independent|, or when it is a pair with one or more
-|independent| components.
-
-It is tempting to argue that the negative of an independent variable
-is an independent variable, hence we don't have to do anything when
-negating it. The fallacy is that other dependent variables pointing
-to the current expression must change the sign of their
-coefficients if we make no change to the current expression.
-
-Instead, we work around the problem by copying the current expression
-and recycling it afterwards (cf.~the |stash_in| routine).
-
-@<Negate the current expression@>=
-switch (mp->cur_type) {
-case mp_color_type:
-case mp_cmykcolor_type:
-case mp_pair_type:
-case mp_independent:
- q=mp->cur_exp; mp_make_exp_copy(mp, q);
- if ( mp->cur_type==mp_dependent ) {
- mp_negate_dep_list(mp, dep_list(mp->cur_exp));
- } else if ( mp->cur_type<=mp_pair_type ) { /* |mp_color_type| or |mp_pair_type| */
- p=value(mp->cur_exp);
- r=p+mp->big_node_size[mp->cur_type];
- do {
- r=r-2;
- if ( type(r)==mp_known ) negate(value(r));
- else mp_negate_dep_list(mp, dep_list(r));
- } while (r!=p);
- } /* if |cur_type=mp_known| then |cur_exp=0| */
- mp_recycle_value(mp, q); mp_free_node(mp, q,value_node_size);
- break;
-case mp_dependent:
-case mp_proto_dependent:
- mp_negate_dep_list(mp, dep_list(mp->cur_exp));
- break;
-case mp_known:
- negate(mp->cur_exp);
- break;
-default:
- mp_bad_unary(mp, minus);
- break;
-}
-
-@ @<Declare unary action...@>=
-void mp_negate_dep_list (MP mp,pointer p) {
- while (1) {
- negate(value(p));
- if ( info(p)==null ) return;
- p=link(p);
- }
-}
-
-@ @<Additional cases of unary operators@>=
-case not_op:
- if ( mp->cur_type!=mp_boolean_type ) mp_bad_unary(mp, not_op);
- else mp->cur_exp=true_code+false_code-mp->cur_exp;
- break;
-
-@ @d three_sixty_units 23592960 /* that's |360*unity| */
-@d boolean_reset(A) if ( (A) ) mp->cur_exp=true_code; else mp->cur_exp=false_code
-
-@<Additional cases of unary operators@>=
-case sqrt_op:
-case m_exp_op:
-case m_log_op:
-case sin_d_op:
-case cos_d_op:
-case floor_op:
-case uniform_deviate:
-case odd_op:
-case char_exists_op:
- if ( mp->cur_type!=mp_known ) {
- mp_bad_unary(mp, c);
- } else {
- switch (c) {
- case sqrt_op:mp->cur_exp=mp_square_rt(mp, mp->cur_exp);break;
- case m_exp_op:mp->cur_exp=mp_m_exp(mp, mp->cur_exp);break;
- case m_log_op:mp->cur_exp=mp_m_log(mp, mp->cur_exp);break;
- case sin_d_op:
- case cos_d_op:
- mp_n_sin_cos(mp, (mp->cur_exp % three_sixty_units)*16);
- if ( c==sin_d_op ) mp->cur_exp=mp_round_fraction(mp, mp->n_sin);
- else mp->cur_exp=mp_round_fraction(mp, mp->n_cos);
- break;
- case floor_op:mp->cur_exp=mp_floor_scaled(mp, mp->cur_exp);break;
- case uniform_deviate:mp->cur_exp=mp_unif_rand(mp, mp->cur_exp);break;
- case odd_op:
- boolean_reset(odd(mp_round_unscaled(mp, mp->cur_exp)));
- mp->cur_type=mp_boolean_type;
- break;
- case char_exists_op:
- @<Determine if a character has been shipped out@>;
- break;
- } /* there are no other cases */
- }
- break;
-
-@ @<Additional cases of unary operators@>=
-case angle_op:
- if ( mp_nice_pair(mp, mp->cur_exp,mp->cur_type) ) {
- p=value(mp->cur_exp);
- x=mp_n_arg(mp, value(x_part_loc(p)),value(y_part_loc(p)));
- if ( x>=0 ) mp_flush_cur_exp(mp, (x+8)/ 16);
- else mp_flush_cur_exp(mp, -((-x+8)/ 16));
- } else {
- mp_bad_unary(mp, angle_op);
- }
- break;
-
-@ If the current expression is a pair, but the context wants it to
-be a path, we call |pair_to_path|.
-
-@<Declare unary action...@>=
-void mp_pair_to_path (MP mp) {
- mp->cur_exp=mp_new_knot(mp);
- mp->cur_type=mp_path_type;
-}
-
-@
-@d pict_color_type(A) ((link(dummy_loc(mp->cur_exp))!=null) &&
- (has_color(link(dummy_loc(mp->cur_exp)))) &&
- (color_model(link(dummy_loc(mp->cur_exp)))==A))
-
-@<Additional cases of unary operators@>=
-case x_part:
-case y_part:
- if ( (mp->cur_type==mp_pair_type)||(mp->cur_type==mp_transform_type) )
- mp_take_part(mp, c);
- else if ( mp->cur_type==mp_picture_type ) mp_take_pict_part(mp, c);
- else mp_bad_unary(mp, c);
- break;
-case xx_part:
-case xy_part:
-case yx_part:
-case yy_part:
- if ( mp->cur_type==mp_transform_type ) mp_take_part(mp, c);
- else if ( mp->cur_type==mp_picture_type ) mp_take_pict_part(mp, c);
- else mp_bad_unary(mp, c);
- break;
-case red_part:
-case green_part:
-case blue_part:
- if ( mp->cur_type==mp_color_type ) mp_take_part(mp, c);
- else if ( mp->cur_type==mp_picture_type ) {
- if pict_color_type(mp_rgb_model) mp_take_pict_part(mp, c);
- else mp_bad_color_part(mp, c);
- }
- else mp_bad_unary(mp, c);
- break;
-case cyan_part:
-case magenta_part:
-case yellow_part:
-case black_part:
- if ( mp->cur_type==mp_cmykcolor_type) mp_take_part(mp, c);
- else if ( mp->cur_type==mp_picture_type ) {
- if pict_color_type(mp_cmyk_model) mp_take_pict_part(mp, c);
- else mp_bad_color_part(mp, c);
- }
- else mp_bad_unary(mp, c);
- break;
-case grey_part:
- if ( mp->cur_type==mp_known ) mp->cur_exp=value(c);
- else if ( mp->cur_type==mp_picture_type ) {
- if pict_color_type(mp_grey_model) mp_take_pict_part(mp, c);
- else mp_bad_color_part(mp, c);
- }
- else mp_bad_unary(mp, c);
- break;
-case color_model_part:
- if ( mp->cur_type==mp_picture_type ) mp_take_pict_part(mp, c);
- else mp_bad_unary(mp, c);
- break;
-
-@ @<Declarations@>=
-void mp_bad_color_part(MP mp, quarterword c);
-
-@ @c
-void mp_bad_color_part(MP mp, quarterword c) {
- pointer p; /* the big node */
- p=link(dummy_loc(mp->cur_exp));
- exp_err("Wrong picture color model: "); mp_print_op(mp, c);
-@.Wrong picture color model...@>
- if (color_model(p)==mp_grey_model)
- mp_print(mp, " of grey object");
- else if (color_model(p)==mp_cmyk_model)
- mp_print(mp, " of cmyk object");
- else if (color_model(p)==mp_rgb_model)
- mp_print(mp, " of rgb object");
- else if (color_model(p)==mp_no_model)
- mp_print(mp, " of marking object");
- else
- mp_print(mp," of defaulted object");
- help3("You can only ask for the redpart, greenpart, bluepart of a rgb object,")
- ("the cyanpart, magentapart, yellowpart or blackpart of a cmyk object, ")
- ("or the greypart of a grey object. No mixing and matching, please.");
- mp_error(mp);
- if (c==black_part)
- mp_flush_cur_exp(mp,unity);
- else
- mp_flush_cur_exp(mp,0);
-}
-
-@ In the following procedure, |cur_exp| points to a capsule, which points to
-a big node. We want to delete all but one part of the big node.
-
-@<Declare unary action...@>=
-void mp_take_part (MP mp,quarterword c) {
- pointer p; /* the big node */
- p=value(mp->cur_exp); value(temp_val)=p; type(temp_val)=mp->cur_type;
- link(p)=temp_val; mp_free_node(mp, mp->cur_exp,value_node_size);
- mp_make_exp_copy(mp, p+mp->sector_offset[c+mp_x_part_sector-x_part]);
- mp_recycle_value(mp, temp_val);
-}
-
-@ @<Initialize table entries...@>=
-name_type(temp_val)=mp_capsule;
-
-@ @<Additional cases of unary operators@>=
-case font_part:
-case text_part:
-case path_part:
-case pen_part:
-case dash_part:
- if ( mp->cur_type==mp_picture_type ) mp_take_pict_part(mp, c);
- else mp_bad_unary(mp, c);
- break;
-
-@ @<Declarations@>=
-void mp_scale_edges (MP mp);
-
-@ @<Declare unary action...@>=
-void mp_take_pict_part (MP mp,quarterword c) {
- pointer p; /* first graphical object in |cur_exp| */
- p=link(dummy_loc(mp->cur_exp));
- if ( p!=null ) {
- switch (c) {
- case x_part: case y_part: case xx_part:
- case xy_part: case yx_part: case yy_part:
- if ( type(p)==mp_text_code ) mp_flush_cur_exp(mp, text_trans_part(p+c));
- else goto NOT_FOUND;
- break;
- case red_part: case green_part: case blue_part:
- if ( has_color(p) ) mp_flush_cur_exp(mp, obj_color_part(p+c));
- else goto NOT_FOUND;
- break;
- case cyan_part: case magenta_part: case yellow_part:
- case black_part:
- if ( has_color(p) ) {
- if ( color_model(p)==mp_uninitialized_model )
- mp_flush_cur_exp(mp, unity);
- else
- mp_flush_cur_exp(mp, obj_color_part(p+c+(red_part-cyan_part)));
- } else goto NOT_FOUND;
- break;
- case grey_part:
- if ( has_color(p) )
- mp_flush_cur_exp(mp, obj_color_part(p+c+(red_part-grey_part)));
- else goto NOT_FOUND;
- break;
- case color_model_part:
- if ( has_color(p) ) {
- if ( color_model(p)==mp_uninitialized_model )
- mp_flush_cur_exp(mp, mp->internal[mp_default_color_model]);
- else
- mp_flush_cur_exp(mp, color_model(p)*unity);
- } else goto NOT_FOUND;
- break;
- @<Handle other cases in |take_pict_part| or |goto not_found|@>;
- } /* all cases have been enumerated */
- return;
- };
-NOT_FOUND:
- @<Convert the current expression to a null value appropriate
- for |c|@>;
-}
-
-@ @<Handle other cases in |take_pict_part| or |goto not_found|@>=
-case text_part:
- if ( type(p)!=mp_text_code ) goto NOT_FOUND;
- else {
- mp_flush_cur_exp(mp, text_p(p));
- add_str_ref(mp->cur_exp);
- mp->cur_type=mp_string_type;
- };
- break;
-case font_part:
- if ( type(p)!=mp_text_code ) goto NOT_FOUND;
- else {
- mp_flush_cur_exp(mp, rts(mp->font_name[font_n(p)]));
- add_str_ref(mp->cur_exp);
- mp->cur_type=mp_string_type;
- };
- break;
-case path_part:
- if ( type(p)==mp_text_code ) goto NOT_FOUND;
- else if ( is_stop(p) ) mp_confusion(mp, "pict");
-@:this can't happen pict}{\quad pict@>
- else {
- mp_flush_cur_exp(mp, mp_copy_path(mp, path_p(p)));
- mp->cur_type=mp_path_type;
- }
- break;
-case pen_part:
- if ( ! has_pen(p) ) goto NOT_FOUND;
- else {
- if ( pen_p(p)==null ) goto NOT_FOUND;
- else { mp_flush_cur_exp(mp, copy_pen(pen_p(p)));
- mp->cur_type=mp_pen_type;
- };
- }
- break;
-case dash_part:
- if ( type(p)!=mp_stroked_code ) goto NOT_FOUND;
- else { if ( dash_p(p)==null ) goto NOT_FOUND;
- else { add_edge_ref(dash_p(p));
- mp->se_sf=dash_scale(p);
- mp->se_pic=dash_p(p);
- mp_scale_edges(mp);
- mp_flush_cur_exp(mp, mp->se_pic);
- mp->cur_type=mp_picture_type;
- };
- }
- break;
-
-@ Since |scale_edges| had to be declared |forward|, it had to be declared as a
-parameterless procedure even though it really takes two arguments and updates
-one of them. Hence the following globals are needed.
-
-@<Global...@>=
-pointer se_pic; /* edge header used and updated by |scale_edges| */
-scaled se_sf; /* the scale factor argument to |scale_edges| */
-
-@ @<Convert the current expression to a null value appropriate...@>=
-switch (c) {
-case text_part: case font_part:
- mp_flush_cur_exp(mp, rts(""));
- mp->cur_type=mp_string_type;
- break;
-case path_part:
- mp_flush_cur_exp(mp, mp_get_node(mp, knot_node_size));
- left_type(mp->cur_exp)=mp_endpoint;
- right_type(mp->cur_exp)=mp_endpoint;
- link(mp->cur_exp)=mp->cur_exp;
- x_coord(mp->cur_exp)=0;
- y_coord(mp->cur_exp)=0;
- originator(mp->cur_exp)=mp_metapost_user;
- mp->cur_type=mp_path_type;
- break;
-case pen_part:
- mp_flush_cur_exp(mp, mp_get_pen_circle(mp, 0));
- mp->cur_type=mp_pen_type;
- break;
-case dash_part:
- mp_flush_cur_exp(mp, mp_get_node(mp, edge_header_size));
- mp_init_edges(mp, mp->cur_exp);
- mp->cur_type=mp_picture_type;
- break;
-default:
- mp_flush_cur_exp(mp, 0);
- break;
-}
-
-@ @<Additional cases of unary...@>=
-case char_op:
- if ( mp->cur_type!=mp_known ) {
- mp_bad_unary(mp, char_op);
- } else {
- mp->cur_exp=mp_round_unscaled(mp, mp->cur_exp) % 256;
- mp->cur_type=mp_string_type;
- if ( mp->cur_exp<0 ) mp->cur_exp=mp->cur_exp+256;
- }
- break;
-case decimal:
- if ( mp->cur_type!=mp_known ) {
- mp_bad_unary(mp, decimal);
- } else {
- mp->old_setting=mp->selector; mp->selector=new_string;
- mp_print_scaled(mp, mp->cur_exp); mp->cur_exp=mp_make_string(mp);
- mp->selector=mp->old_setting; mp->cur_type=mp_string_type;
- }
- break;
-case oct_op:
-case hex_op:
-case ASCII_op:
- if ( mp->cur_type!=mp_string_type ) mp_bad_unary(mp, c);
- else mp_str_to_num(mp, c);
- break;
-case font_size:
- if ( mp->cur_type!=mp_string_type ) mp_bad_unary(mp, font_size);
- else @<Find the design size of the font whose name is |cur_exp|@>;
- break;
-
-@ @<Declare unary action...@>=
-void mp_str_to_num (MP mp,quarterword c) { /* converts a string to a number */
- integer n; /* accumulator */
- ASCII_code m; /* current character */
- pool_pointer k; /* index into |str_pool| */
- int b; /* radix of conversion */
- boolean bad_char; /* did the string contain an invalid digit? */
- if ( c==ASCII_op ) {
- if ( length(mp->cur_exp)==0 ) n=-1;
- else n=mp->str_pool[mp->str_start[mp->cur_exp]];
- } else {
- if ( c==oct_op ) b=8; else b=16;
- n=0; bad_char=false;
- for (k=mp->str_start[mp->cur_exp];k<=str_stop(mp->cur_exp)-1;k++) {
- m=mp->str_pool[k];
- if ( (m>='0')&&(m<='9') ) m=m-'0';
- else if ( (m>='A')&&(m<='F') ) m=m-'A'+10;
- else if ( (m>='a')&&(m<='f') ) m=m-'a'+10;
- else { bad_char=true; m=0; };
- if ( m>=b ) { bad_char=true; m=0; };
- if ( n<32768 / b ) n=n*b+m; else n=32767;
- }
- @<Give error messages if |bad_char| or |n>=4096|@>;
- }
- mp_flush_cur_exp(mp, n*unity);
-}
-
-@ @<Give error messages if |bad_char|...@>=
-if ( bad_char ) {
- exp_err("String contains illegal digits");
-@.String contains illegal digits@>
- if ( c==oct_op ) {
- help1("I zeroed out characters that weren't in the range 0..7.");
- } else {
- help1("I zeroed out characters that weren't hex digits.");
- }
- mp_put_get_error(mp);
-}
-if ( (n>4095) ) {
- if ( mp->internal[mp_warning_check]>0 ) {
- print_err("Number too large (");
- mp_print_int(mp, n); mp_print_char(mp, ')');
-@.Number too large@>
- help2("I have trouble with numbers greater than 4095; watch out.")
- ("(Set warningcheck:=0 to suppress this message.)");
- mp_put_get_error(mp);
- }
-}
-
-@ The length operation is somewhat unusual in that it applies to a variety
-of different types of operands.
-
-@<Additional cases of unary...@>=
-case length_op:
- switch (mp->cur_type) {
- case mp_string_type: mp_flush_cur_exp(mp, length(mp->cur_exp)*unity); break;
- case mp_path_type: mp_flush_cur_exp(mp, mp_path_length(mp)); break;
- case mp_known: mp->cur_exp=abs(mp->cur_exp); break;
- case mp_picture_type: mp_flush_cur_exp(mp, mp_pict_length(mp)); break;
- default:
- if ( mp_nice_pair(mp, mp->cur_exp,mp->cur_type) )
- mp_flush_cur_exp(mp, mp_pyth_add(mp,
- value(x_part_loc(value(mp->cur_exp))),
- value(y_part_loc(value(mp->cur_exp)))));
- else mp_bad_unary(mp, c);
- break;
- }
- break;
-
-@ @<Declare unary action...@>=
-scaled mp_path_length (MP mp) { /* computes the length of the current path */
- scaled n; /* the path length so far */
- pointer p; /* traverser */
- p=mp->cur_exp;
- if ( left_type(p)==mp_endpoint ) n=-unity; else n=0;
- do { p=link(p); n=n+unity; } while (p!=mp->cur_exp);
- return n;
-}
-
-@ @<Declare unary action...@>=
-scaled mp_pict_length (MP mp) {
- /* counts interior components in picture |cur_exp| */
- scaled n; /* the count so far */
- pointer p; /* traverser */
- n=0;
- p=link(dummy_loc(mp->cur_exp));
- if ( p!=null ) {
- if ( is_start_or_stop(p) )
- if ( mp_skip_1component(mp, p)==null ) p=link(p);
- while ( p!=null ) {
- skip_component(p) return n;
- n=n+unity;
- }
- }
- return n;
-}
-
-@ Implement |turningnumber|
-
-@<Additional cases of unary...@>=
-case turning_op:
- if ( mp->cur_type==mp_pair_type ) mp_flush_cur_exp(mp, 0);
- else if ( mp->cur_type!=mp_path_type ) mp_bad_unary(mp, turning_op);
- else if ( left_type(mp->cur_exp)==mp_endpoint )
- mp_flush_cur_exp(mp, 0); /* not a cyclic path */
- else
- mp_flush_cur_exp(mp, mp_turn_cycles_wrapper(mp, mp->cur_exp));
- break;
-
-@ The function |an_angle| returns the value of the |angle| primitive, or $0$ if the
-argument is |origin|.
-
-@<Declare unary action...@>=
-angle mp_an_angle (MP mp,scaled xpar, scaled ypar) {
- if ( (! ((xpar==0) && (ypar==0))) )
- return mp_n_arg(mp, xpar,ypar);
- return 0;
-}
-
-
-@ The actual turning number is (for the moment) computed in a C function
-that receives eight integers corresponding to the four controlling points,
-and returns a single angle. Besides those, we have to account for discrete
-moves at the actual points.
-
-@d floor(a) (a>=0 ? a : -(int)(-a))
-@d bezier_error (720<<20)+1
-@d sign(v) ((v)>0 ? 1 : ((v)<0 ? -1 : 0 ))
-@d print_roots(a)
-@d out ((double)(xo>>20))
-@d mid ((double)(xm>>20))
-@d in ((double)(xi>>20))
-@d divisor (256*256)
-@d double2angle(a) (int)floor(a*256.0*256.0*16.0)
-
-@<Declare unary action...@>=
-angle mp_bezier_slope(MP mp, integer AX,integer AY,integer BX,integer BY,
- integer CX,integer CY,integer DX,integer DY);
-
-@ @c
-angle mp_bezier_slope(MP mp, integer AX,integer AY,integer BX,integer BY,
- integer CX,integer CY,integer DX,integer DY) {
- double a, b, c;
- integer deltax,deltay;
- double ax,ay,bx,by,cx,cy,dx,dy;
- angle xi = 0, xo = 0, xm = 0;
- double res = 0;
- ax=AX/divisor; ay=AY/divisor;
- bx=BX/divisor; by=BY/divisor;
- cx=CX/divisor; cy=CY/divisor;
- dx=DX/divisor; dy=DY/divisor;
-
- deltax = (BX-AX); deltay = (BY-AY);
- if (deltax==0 && deltay == 0) { deltax=(CX-AX); deltay=(CY-AY); }
- if (deltax==0 && deltay == 0) { deltax=(DX-AX); deltay=(DY-AY); }
- xi = mp_an_angle(mp,deltax,deltay);
-
- deltax = (CX-BX); deltay = (CY-BY);
- xm = mp_an_angle(mp,deltax,deltay);
-
- deltax = (DX-CX); deltay = (DY-CY);
- if (deltax==0 && deltay == 0) { deltax=(DX-BX); deltay=(DY-BY); }
- if (deltax==0 && deltay == 0) { deltax=(DX-AX); deltay=(DY-AY); }
- xo = mp_an_angle(mp,deltax,deltay);
-
- a = (bx-ax)*(cy-by) - (cx-bx)*(by-ay); /* a = (bp-ap)x(cp-bp); */
- b = (bx-ax)*(dy-cy) - (by-ay)*(dx-cx);; /* b = (bp-ap)x(dp-cp);*/
- c = (cx-bx)*(dy-cy) - (dx-cx)*(cy-by); /* c = (cp-bp)x(dp-cp);*/
-
- if ((a==0)&&(c==0)) {
- res = (b==0 ? 0 : (out-in));
- print_roots("no roots (a)");
- } else if ((a==0)||(c==0)) {
- if ((sign(b) == sign(a)) || (sign(b) == sign(c))) {
- res = out-in; /* ? */
- if (res<-180.0)
- res += 360.0;
- else if (res>180.0)
- res -= 360.0;
- print_roots("no roots (b)");
- } else {
- res = out-in; /* ? */
- print_roots("one root (a)");
- }
- } else if ((sign(a)*sign(c))<0) {
- res = out-in; /* ? */
- if (res<-180.0)
- res += 360.0;
- else if (res>180.0)
- res -= 360.0;
- print_roots("one root (b)");
- } else {
- if (sign(a) == sign(b)) {
- res = out-in; /* ? */
- if (res<-180.0)
- res += 360.0;
- else if (res>180.0)
- res -= 360.0;
- print_roots("no roots (d)");
- } else {
- if ((b*b) == (4*a*c)) {
- res = bezier_error;
- print_roots("double root"); /* cusp */
- } else if ((b*b) < (4*a*c)) {
- res = out-in; /* ? */
- if (res<=0.0 &&res>-180.0)
- res += 360.0;
- else if (res>=0.0 && res<180.0)
- res -= 360.0;
- print_roots("no roots (e)");
- } else {
- res = out-in;
- if (res<-180.0)
- res += 360.0;
- else if (res>180.0)
- res -= 360.0;
- print_roots("two roots"); /* two inflections */
- }
- }
- }
- return double2angle(res);
-}
-
-@
-@d p_nextnext link(link(p))
-@d p_next link(p)
-@d seven_twenty_deg 05500000000 /* $720\cdot2^{20}$, represents $720^\circ$ */
-
-@<Declare unary action...@>=
-scaled mp_new_turn_cycles (MP mp,pointer c) {
- angle res,ang; /* the angles of intermediate results */
- scaled turns; /* the turn counter */
- pointer p; /* for running around the path */
- integer xp,yp; /* coordinates of next point */
- integer x,y; /* helper coordinates */
- angle in_angle,out_angle; /* helper angles */
- int old_setting; /* saved |selector| setting */
- res=0;
- turns= 0;
- p=c;
- old_setting = mp->selector; mp->selector=term_only;
- if ( mp->internal[mp_tracing_commands]>unity ) {
- mp_begin_diagnostic(mp);
- mp_print_nl(mp, "");
- mp_end_diagnostic(mp, false);
- }
- do {
- xp = x_coord(p_next); yp = y_coord(p_next);
- ang = mp_bezier_slope(mp,x_coord(p), y_coord(p), right_x(p), right_y(p),
- left_x(p_next), left_y(p_next), xp, yp);
- if ( ang>seven_twenty_deg ) {
- print_err("Strange path");
- mp_error(mp);
- mp->selector=old_setting;
- return 0;
- }
- res = res + ang;
- if ( res > one_eighty_deg ) {
- res = res - three_sixty_deg;
- turns = turns + unity;
- }
- if ( res <= -one_eighty_deg ) {
- res = res + three_sixty_deg;
- turns = turns - unity;
- }
- /* incoming angle at next point */
- x = left_x(p_next); y = left_y(p_next);
- if ( (xp==x)&&(yp==y) ) { x = right_x(p); y = right_y(p); };
- if ( (xp==x)&&(yp==y) ) { x = x_coord(p); y = y_coord(p); };
- in_angle = mp_an_angle(mp, xp - x, yp - y);
- /* outgoing angle at next point */
- x = right_x(p_next); y = right_y(p_next);
- if ( (xp==x)&&(yp==y) ) { x = left_x(p_nextnext); y = left_y(p_nextnext); };
- if ( (xp==x)&&(yp==y) ) { x = x_coord(p_nextnext); y = y_coord(p_nextnext); };
- out_angle = mp_an_angle(mp, x - xp, y- yp);
- ang = (out_angle - in_angle);
- reduce_angle(ang);
- if ( ang!=0 ) {
- res = res + ang;
- if ( res >= one_eighty_deg ) {
- res = res - three_sixty_deg;
- turns = turns + unity;
- };
- if ( res <= -one_eighty_deg ) {
- res = res + three_sixty_deg;
- turns = turns - unity;
- };
- };
- p = link(p);
- } while (p!=c);
- mp->selector=old_setting;
- return turns;
-}
-
-
-@ This code is based on Bogus\l{}av Jackowski's
-|emergency_turningnumber| macro, with some minor changes by Taco
-Hoekwater. The macro code looked more like this:
-{\obeylines
-vardef turning\_number primary p =
-~~save res, ang, turns;
-~~res := 0;
-~~if length p <= 2:
-~~~~if Angle ((point 0 of p) - (postcontrol 0 of p)) >= 0: 1 else: -1 fi
-~~else:
-~~~~for t = 0 upto length p-1 :
-~~~~~~angc := Angle ((point t+1 of p) - (point t of p))
-~~~~~~~~- Angle ((point t of p) - (point t-1 of p));
-~~~~~~if angc > 180: angc := angc - 360; fi;
-~~~~~~if angc < -180: angc := angc + 360; fi;
-~~~~~~res := res + angc;
-~~~~endfor;
-~~res/360
-~~fi
-enddef;}
-The general idea is to calculate only the sum of the angles of
-straight lines between the points, of a path, not worrying about cusps
-or self-intersections in the segments at all. If the segment is not
-well-behaved, the result is not necesarily correct. But the old code
-was not always correct either, and worse, it sometimes failed for
-well-behaved paths as well. All known bugs that were triggered by the
-original code no longer occur with this code, and it runs roughly 3
-times as fast because the algorithm is much simpler.
-
-@ It is possible to overflow the return value of the |turn_cycles|
-function when the path is sufficiently long and winding, but I am not
-going to bother testing for that. In any case, it would only return
-the looped result value, which is not a big problem.
-
-The macro code for the repeat loop was a bit nicer to look
-at than the pascal code, because it could use |point -1 of p|. In
-pascal, the fastest way to loop around the path is not to look
-backward once, but forward twice. These defines help hide the trick.
-
-@d p_to link(link(p))
-@d p_here link(p)
-@d p_from p
-
-@<Declare unary action...@>=
-scaled mp_turn_cycles (MP mp,pointer c) {
- angle res,ang; /* the angles of intermediate results */
- scaled turns; /* the turn counter */
- pointer p; /* for running around the path */
- res=0; turns= 0; p=c;
- do {
- ang = mp_an_angle (mp, x_coord(p_to) - x_coord(p_here),
- y_coord(p_to) - y_coord(p_here))
- - mp_an_angle (mp, x_coord(p_here) - x_coord(p_from),
- y_coord(p_here) - y_coord(p_from));
- reduce_angle(ang);
- res = res + ang;
- if ( res >= three_sixty_deg ) {
- res = res - three_sixty_deg;
- turns = turns + unity;
- };
- if ( res <= -three_sixty_deg ) {
- res = res + three_sixty_deg;
- turns = turns - unity;
- };
- p = link(p);
- } while (p!=c);
- return turns;
-}
-
-@ @<Declare unary action...@>=
-scaled mp_turn_cycles_wrapper (MP mp,pointer c) {
- scaled nval,oval;
- scaled saved_t_o; /* tracing\_online saved */
- if ( (link(c)==c)||(link(link(c))==c) ) {
- if ( mp_an_angle (mp, x_coord(c) - right_x(c), y_coord(c) - right_y(c)) > 0 )
- return unity;
- else
- return -unity;
- } else {
- nval = mp_new_turn_cycles(mp, c);
- oval = mp_turn_cycles(mp, c);
- if ( nval!=oval ) {
- saved_t_o=mp->internal[mp_tracing_online];
- mp->internal[mp_tracing_online]=unity;
- mp_begin_diagnostic(mp);
- mp_print_nl (mp, "Warning: the turningnumber algorithms do not agree."
- " The current computed value is ");
- mp_print_scaled(mp, nval);
- mp_print(mp, ", but the 'connect-the-dots' algorithm returned ");
- mp_print_scaled(mp, oval);
- mp_end_diagnostic(mp, false);
- mp->internal[mp_tracing_online]=saved_t_o;
- }
- return nval;
- }
-}
-
-@ @<Declare unary action...@>=
-scaled mp_count_turns (MP mp,pointer c) {
- pointer p; /* a knot in envelope spec |c| */
- integer t; /* total pen offset changes counted */
- t=0; p=c;
- do {
- t=t+info(p)-zero_off;
- p=link(p);
- } while (p!=c);
- return ((t / 3)*unity);
-}
-
-@ @d type_range(A,B) {
- if ( (mp->cur_type>=(A)) && (mp->cur_type<=(B)) )
- mp_flush_cur_exp(mp, true_code);
- else mp_flush_cur_exp(mp, false_code);
- mp->cur_type=mp_boolean_type;
- }
-@d type_test(A) {
- if ( mp->cur_type==(A) ) mp_flush_cur_exp(mp, true_code);
- else mp_flush_cur_exp(mp, false_code);
- mp->cur_type=mp_boolean_type;
- }
-
-@<Additional cases of unary operators@>=
-case mp_boolean_type:
- type_range(mp_boolean_type,mp_unknown_boolean); break;
-case mp_string_type:
- type_range(mp_string_type,mp_unknown_string); break;
-case mp_pen_type:
- type_range(mp_pen_type,mp_unknown_pen); break;
-case mp_path_type:
- type_range(mp_path_type,mp_unknown_path); break;
-case mp_picture_type:
- type_range(mp_picture_type,mp_unknown_picture); break;
-case mp_transform_type: case mp_color_type: case mp_cmykcolor_type:
-case mp_pair_type:
- type_test(c); break;
-case mp_numeric_type:
- type_range(mp_known,mp_independent); break;
-case known_op: case unknown_op:
- mp_test_known(mp, c); break;
-
-@ @<Declare unary action procedures@>=
-void mp_test_known (MP mp,quarterword c) {
- int b; /* is the current expression known? */
- pointer p,q; /* locations in a big node */
- b=false_code;
- switch (mp->cur_type) {
- case mp_vacuous: case mp_boolean_type: case mp_string_type:
- case mp_pen_type: case mp_path_type: case mp_picture_type:
- case mp_known:
- b=true_code;
- break;
- case mp_transform_type:
- case mp_color_type: case mp_cmykcolor_type: case mp_pair_type:
- p=value(mp->cur_exp);
- q=p+mp->big_node_size[mp->cur_type];
- do {
- q=q-2;
- if ( type(q)!=mp_known )
- goto DONE;
- } while (q!=p);
- b=true_code;
- DONE:
- break;
- default:
- break;
- }
- if ( c==known_op ) mp_flush_cur_exp(mp, b);
- else mp_flush_cur_exp(mp, true_code+false_code-b);
- mp->cur_type=mp_boolean_type;
-}
-
-@ @<Additional cases of unary operators@>=
-case cycle_op:
- if ( mp->cur_type!=mp_path_type ) mp_flush_cur_exp(mp, false_code);
- else if ( left_type(mp->cur_exp)!=mp_endpoint ) mp_flush_cur_exp(mp, true_code);
- else mp_flush_cur_exp(mp, false_code);
- mp->cur_type=mp_boolean_type;
- break;
-
-@ @<Additional cases of unary operators@>=
-case arc_length:
- if ( mp->cur_type==mp_pair_type ) mp_pair_to_path(mp);
- if ( mp->cur_type!=mp_path_type ) mp_bad_unary(mp, arc_length);
- else mp_flush_cur_exp(mp, mp_get_arc_length(mp, mp->cur_exp));
- break;
-
-@ Here we use the fact that |c-filled_op+fill_code| is the desired graphical
-object |type|.
-@^data structure assumptions@>
-
-@<Additional cases of unary operators@>=
-case filled_op:
-case stroked_op:
-case textual_op:
-case clipped_op:
-case bounded_op:
- if ( mp->cur_type!=mp_picture_type ) mp_flush_cur_exp(mp, false_code);
- else if ( link(dummy_loc(mp->cur_exp))==null ) mp_flush_cur_exp(mp, false_code);
- else if ( type(link(dummy_loc(mp->cur_exp)))==c+mp_fill_code-filled_op )
- mp_flush_cur_exp(mp, true_code);
- else mp_flush_cur_exp(mp, false_code);
- mp->cur_type=mp_boolean_type;
- break;
-
-@ @<Additional cases of unary operators@>=
-case make_pen_op:
- if ( mp->cur_type==mp_pair_type ) mp_pair_to_path(mp);
- if ( mp->cur_type!=mp_path_type ) mp_bad_unary(mp, make_pen_op);
- else {
- mp->cur_type=mp_pen_type;
- mp->cur_exp=mp_make_pen(mp, mp->cur_exp,true);
- };
- break;
-case make_path_op:
- if ( mp->cur_type!=mp_pen_type ) mp_bad_unary(mp, make_path_op);
- else {
- mp->cur_type=mp_path_type;
- mp_make_path(mp, mp->cur_exp);
- };
- break;
-case reverse:
- if ( mp->cur_type==mp_path_type ) {
- p=mp_htap_ypoc(mp, mp->cur_exp);
- if ( right_type(p)==mp_endpoint ) p=link(p);
- mp_toss_knot_list(mp, mp->cur_exp); mp->cur_exp=p;
- } else if ( mp->cur_type==mp_pair_type ) mp_pair_to_path(mp);
- else mp_bad_unary(mp, reverse);
- break;
-
-@ The |pair_value| routine changes the current expression to a
-given ordered pair of values.
-
-@<Declare unary action procedures@>=
-void mp_pair_value (MP mp,scaled x, scaled y) {
- pointer p; /* a pair node */
- p=mp_get_node(mp, value_node_size);
- mp_flush_cur_exp(mp, p); mp->cur_type=mp_pair_type;
- type(p)=mp_pair_type; name_type(p)=mp_capsule; mp_init_big_node(mp, p);
- p=value(p);
- type(x_part_loc(p))=mp_known; value(x_part_loc(p))=x;
- type(y_part_loc(p))=mp_known; value(y_part_loc(p))=y;
-}
-
-@ @<Additional cases of unary operators@>=
-case ll_corner_op:
- if ( ! mp_get_cur_bbox(mp) ) mp_bad_unary(mp, ll_corner_op);
- else mp_pair_value(mp, minx,miny);
- break;
-case lr_corner_op:
- if ( ! mp_get_cur_bbox(mp) ) mp_bad_unary(mp, lr_corner_op);
- else mp_pair_value(mp, maxx,miny);
- break;
-case ul_corner_op:
- if ( ! mp_get_cur_bbox(mp) ) mp_bad_unary(mp, ul_corner_op);
- else mp_pair_value(mp, minx,maxy);
- break;
-case ur_corner_op:
- if ( ! mp_get_cur_bbox(mp) ) mp_bad_unary(mp, ur_corner_op);
- else mp_pair_value(mp, maxx,maxy);
- break;
-
-@ Here is a function that sets |minx|, |maxx|, |miny|, |maxy| to the bounding
-box of the current expression. The boolean result is |false| if the expression
-has the wrong type.
-
-@<Declare unary action procedures@>=
-boolean mp_get_cur_bbox (MP mp) {
- switch (mp->cur_type) {
- case mp_picture_type:
- mp_set_bbox(mp, mp->cur_exp,true);
- if ( minx_val(mp->cur_exp)>maxx_val(mp->cur_exp) ) {
- minx=0; maxx=0; miny=0; maxy=0;
- } else {
- minx=minx_val(mp->cur_exp);
- maxx=maxx_val(mp->cur_exp);
- miny=miny_val(mp->cur_exp);
- maxy=maxy_val(mp->cur_exp);
- }
- break;
- case mp_path_type:
- mp_path_bbox(mp, mp->cur_exp);
- break;
- case mp_pen_type:
- mp_pen_bbox(mp, mp->cur_exp);
- break;
- default:
- return false;
- }
- return true;
-}
-
-@ @<Additional cases of unary operators@>=
-case read_from_op:
-case close_from_op:
- if ( mp->cur_type!=mp_string_type ) mp_bad_unary(mp, c);
- else mp_do_read_or_close(mp,c);
- break;
-
-@ Here is a routine that interprets |cur_exp| as a file name and tries to read
-a line from the file or to close the file.
-
-@<Declare unary action procedures@>=
-void mp_do_read_or_close (MP mp,quarterword c) {
- readf_index n,n0; /* indices for searching |rd_fname| */
- @<Find the |n| where |rd_fname[n]=cur_exp|; if |cur_exp| must be inserted,
- call |start_read_input| and |goto found| or |not_found|@>;
- mp_begin_file_reading(mp);
- name=is_read;
- if ( mp_input_ln(mp, mp->rd_file[n] ) )
- goto FOUND;
- mp_end_file_reading(mp);
-NOT_FOUND:
- @<Record the end of file and set |cur_exp| to a dummy value@>;
- return;
-CLOSE_FILE:
- mp_flush_cur_exp(mp, 0); mp->cur_type=mp_vacuous;
- return;
-FOUND:
- mp_flush_cur_exp(mp, 0);
- mp_finish_read(mp);
-}
-
-@ Free slots in the |rd_file| and |rd_fname| arrays are marked with NULL's in
-|rd_fname|.
-
-@<Find the |n| where |rd_fname[n]=cur_exp|...@>=
-{
- char *fn;
- n=mp->read_files;
- n0=mp->read_files;
- fn = str(mp->cur_exp);
- while (mp_xstrcmp(fn,mp->rd_fname[n])!=0) {
- if ( n>0 ) {
- decr(n);
- } else if ( c==close_from_op ) {
- goto CLOSE_FILE;
- } else {
- if ( n0==mp->read_files ) {
- if ( mp->read_files<mp->max_read_files ) {
- incr(mp->read_files);
- } else {
- void **rd_file;
- char **rd_fname;
- readf_index l,k;
- l = mp->max_read_files + (mp->max_read_files>>2);
- rd_file = xmalloc((l+1), sizeof(void *));
- rd_fname = xmalloc((l+1), sizeof(char *));
- for (k=0;k<=l;k++) {
- if (k<=mp->max_read_files) {
- rd_file[k]=mp->rd_file[k];
- rd_fname[k]=mp->rd_fname[k];
- } else {
- rd_file[k]=0;
- rd_fname[k]=NULL;
- }
- }
- xfree(mp->rd_file); xfree(mp->rd_fname);
- mp->max_read_files = l;
- mp->rd_file = rd_file;
- mp->rd_fname = rd_fname;
- }
- }
- n=n0;
- if ( mp_start_read_input(mp,fn,n) )
- goto FOUND;
- else
- goto NOT_FOUND;
- }
- if ( mp->rd_fname[n]==NULL ) { n0=n; }
- }
- if ( c==close_from_op ) {
- (mp->close_file)(mp,mp->rd_file[n]);
- goto NOT_FOUND;
- }
-}
-
-@ @<Record the end of file and set |cur_exp| to a dummy value@>=
-xfree(mp->rd_fname[n]);
-mp->rd_fname[n]=NULL;
-if ( n==mp->read_files-1 ) mp->read_files=n;
-if ( c==close_from_op )
- goto CLOSE_FILE;
-mp_flush_cur_exp(mp, mp->eof_line);
-mp->cur_type=mp_string_type
-
-@ The string denoting end-of-file is a one-byte string at position zero, by definition
-
-@<Glob...@>=
-str_number eof_line;
-
-@ @<Set init...@>=
-mp->eof_line=0;
-
-@ Finally, we have the operations that combine a capsule~|p|
-with the current expression.
-
-@d binary_return { mp_finish_binary(mp, old_p, old_exp); return; }
-
-@c @<Declare binary action procedures@>
-void mp_finish_binary (MP mp, pointer old_p, pointer old_exp ){
- check_arith;
- @<Recycle any sidestepped |independent| capsules@>;
-}
-void mp_do_binary (MP mp,pointer p, quarterword c) {
- pointer q,r,rr; /* for list manipulation */
- pointer old_p,old_exp; /* capsules to recycle */
- integer v; /* for numeric manipulation */
- check_arith;
- if ( mp->internal[mp_tracing_commands]>two ) {
- @<Trace the current binary operation@>;
- }
- @<Sidestep |independent| cases in capsule |p|@>;
- @<Sidestep |independent| cases in the current expression@>;
- switch (c) {
- case plus: case minus:
- @<Add or subtract the current expression from |p|@>;
- break;
- @<Additional cases of binary operators@>;
- }; /* there are no other cases */
- mp_recycle_value(mp, p);
- mp_free_node(mp, p,value_node_size); /* |return| to avoid this */
- mp_finish_binary(mp, old_p, old_exp);
-}
-
-@ @<Declare binary action...@>=
-void mp_bad_binary (MP mp,pointer p, quarterword c) {
- mp_disp_err(mp, p,"");
- exp_err("Not implemented: ");
-@.Not implemented...@>
- if ( c>=min_of ) mp_print_op(mp, c);
- mp_print_known_or_unknown_type(mp, type(p),p);
- if ( c>=min_of ) mp_print(mp, "of"); else mp_print_op(mp, c);
- mp_print_known_or_unknown_type(mp, mp->cur_type,mp->cur_exp);
- help3("I'm afraid I don't know how to apply that operation to that")
- ("combination of types. Continue, and I'll return the second")
- ("argument (see above) as the result of the operation.");
- mp_put_get_error(mp);
-}
-void mp_bad_envelope_pen (MP mp) {
- mp_disp_err(mp, null,"");
- exp_err("Not implemented: envelope(elliptical pen)of(path)");
-@.Not implemented...@>
- help3("I'm afraid I don't know how to apply that operation to that")
- ("combination of types. Continue, and I'll return the second")
- ("argument (see above) as the result of the operation.");
- mp_put_get_error(mp);
-}
-
-@ @<Trace the current binary operation@>=
-{
- mp_begin_diagnostic(mp); mp_print_nl(mp, "{(");
- mp_print_exp(mp,p,0); /* show the operand, but not verbosely */
- mp_print_char(mp,')'); mp_print_op(mp,c); mp_print_char(mp,'(');
- mp_print_exp(mp,null,0); mp_print(mp,")}");
- mp_end_diagnostic(mp, false);
-}
-
-@ Several of the binary operations are potentially complicated by the
-fact that |independent| values can sneak into capsules. For example,
-we've seen an instance of this difficulty in the unary operation
-of negation. In order to reduce the number of cases that need to be
-handled, we first change the two operands (if necessary)
-to rid them of |independent| components. The original operands are
-put into capsules called |old_p| and |old_exp|, which will be
-recycled after the binary operation has been safely carried out.
-
-@<Recycle any sidestepped |independent| capsules@>=
-if ( old_p!=null ) {
- mp_recycle_value(mp, old_p); mp_free_node(mp, old_p,value_node_size);
-}
-if ( old_exp!=null ) {
- mp_recycle_value(mp, old_exp); mp_free_node(mp, old_exp,value_node_size);
-}
-
-@ A big node is considered to be ``tarnished'' if it contains at least one
-independent component. We will define a simple function called `|tarnished|'
-that returns |null| if and only if its argument is not tarnished.
-
-@<Sidestep |independent| cases in capsule |p|@>=
-switch (type(p)) {
-case mp_transform_type:
-case mp_color_type:
-case mp_cmykcolor_type:
-case mp_pair_type:
- old_p=mp_tarnished(mp, p);
- break;
-case mp_independent: old_p=mp_void; break;
-default: old_p=null; break;
-}
-if ( old_p!=null ) {
- q=mp_stash_cur_exp(mp); old_p=p; mp_make_exp_copy(mp, old_p);
- p=mp_stash_cur_exp(mp); mp_unstash_cur_exp(mp, q);
-}
-
-@ @<Sidestep |independent| cases in the current expression@>=
-switch (mp->cur_type) {
-case mp_transform_type:
-case mp_color_type:
-case mp_cmykcolor_type:
-case mp_pair_type:
- old_exp=mp_tarnished(mp, mp->cur_exp);
- break;
-case mp_independent:old_exp=mp_void; break;
-default: old_exp=null; break;
-}
-if ( old_exp!=null ) {
- old_exp=mp->cur_exp; mp_make_exp_copy(mp, old_exp);
-}
-
-@ @<Declare binary action...@>=
-pointer mp_tarnished (MP mp,pointer p) {
- pointer q; /* beginning of the big node */
- pointer r; /* current position in the big node */
- q=value(p); r=q+mp->big_node_size[type(p)];
- do {
- r=r-2;
- if ( type(r)==mp_independent ) return mp_void;
- } while (r!=q);
- return null;
-}
-
-@ @<Add or subtract the current expression from |p|@>=
-if ( (mp->cur_type<mp_color_type)||(type(p)<mp_color_type) ) {
- mp_bad_binary(mp, p,c);
-} else {
- if ((mp->cur_type>mp_pair_type)&&(type(p)>mp_pair_type) ) {
- mp_add_or_subtract(mp, p,null,c);
- } else {
- if ( mp->cur_type!=type(p) ) {
- mp_bad_binary(mp, p,c);
- } else {
- q=value(p); r=value(mp->cur_exp);
- rr=r+mp->big_node_size[mp->cur_type];
- while ( r<rr ) {
- mp_add_or_subtract(mp, q,r,c);
- q=q+2; r=r+2;
- }
- }
- }
-}
-
-@ The first argument to |add_or_subtract| is the location of a value node
-in a capsule or pair node that will soon be recycled. The second argument
-is either a location within a pair or transform node of |cur_exp|,
-or it is null (which means that |cur_exp| itself should be the second
-argument). The third argument is either |plus| or |minus|.
-
-The sum or difference of the numeric quantities will replace the second
-operand. Arithmetic overflow may go undetected; users aren't supposed to
-be monkeying around with really big values.
-@^overflow in arithmetic@>
-
-@<Declare binary action...@>=
-@<Declare the procedure called |dep_finish|@>
-void mp_add_or_subtract (MP mp,pointer p, pointer q, quarterword c) {
- small_number s,t; /* operand types */
- pointer r; /* list traverser */
- integer v; /* second operand value */
- if ( q==null ) {
- t=mp->cur_type;
- if ( t<mp_dependent ) v=mp->cur_exp; else v=dep_list(mp->cur_exp);
- } else {
- t=type(q);
- if ( t<mp_dependent ) v=value(q); else v=dep_list(q);
- }
- if ( t==mp_known ) {
- if ( c==minus ) negate(v);
- if ( type(p)==mp_known ) {
- v=mp_slow_add(mp, value(p),v);
- if ( q==null ) mp->cur_exp=v; else value(q)=v;
- return;
- }
- @<Add a known value to the constant term of |dep_list(p)|@>;
- } else {
- if ( c==minus ) mp_negate_dep_list(mp, v);
- @<Add operand |p| to the dependency list |v|@>;
- }
-}
-
-@ @<Add a known value to the constant term of |dep_list(p)|@>=
-r=dep_list(p);
-while ( info(r)!=null ) r=link(r);
-value(r)=mp_slow_add(mp, value(r),v);
-if ( q==null ) {
- q=mp_get_node(mp, value_node_size); mp->cur_exp=q; mp->cur_type=type(p);
- name_type(q)=mp_capsule;
-}
-dep_list(q)=dep_list(p); type(q)=type(p);
-prev_dep(q)=prev_dep(p); link(prev_dep(p))=q;
-type(p)=mp_known; /* this will keep the recycler from collecting non-garbage */
-
-@ We prefer |dependent| lists to |mp_proto_dependent| ones, because it is
-nice to retain the extra accuracy of |fraction| coefficients.
-But we have to handle both kinds, and mixtures too.
-
-@<Add operand |p| to the dependency list |v|@>=
-if ( type(p)==mp_known ) {
- @<Add the known |value(p)| to the constant term of |v|@>;
-} else {
- s=type(p); r=dep_list(p);
- if ( t==mp_dependent ) {
- if ( s==mp_dependent ) {
- if ( mp_max_coef(mp, r)+mp_max_coef(mp, v)<coef_bound )
- v=mp_p_plus_q(mp, v,r,mp_dependent); goto DONE;
- } /* |fix_needed| will necessarily be false */
- t=mp_proto_dependent;
- v=mp_p_over_v(mp, v,unity,mp_dependent,mp_proto_dependent);
- }
- if ( s==mp_proto_dependent ) v=mp_p_plus_q(mp, v,r,mp_proto_dependent);
- else v=mp_p_plus_fq(mp, v,unity,r,mp_proto_dependent,mp_dependent);
- DONE:
- @<Output the answer, |v| (which might have become |known|)@>;
- }
-
-@ @<Add the known |value(p)| to the constant term of |v|@>=
-{
- while ( info(v)!=null ) v=link(v);
- value(v)=mp_slow_add(mp, value(p),value(v));
-}
-
-@ @<Output the answer, |v| (which might have become |known|)@>=
-if ( q!=null ) mp_dep_finish(mp, v,q,t);
-else { mp->cur_type=t; mp_dep_finish(mp, v,null,t); }
-
-@ Here's the current situation: The dependency list |v| of type |t|
-should either be put into the current expression (if |q=null|) or
-into location |q| within a pair node (otherwise). The destination (|cur_exp|
-or |q|) formerly held a dependency list with the same
-final pointer as the list |v|.
-
-@<Declare the procedure called |dep_finish|@>=
-void mp_dep_finish (MP mp, pointer v, pointer q, small_number t) {
- pointer p; /* the destination */
- scaled vv; /* the value, if it is |known| */
- if ( q==null ) p=mp->cur_exp; else p=q;
- dep_list(p)=v; type(p)=t;
- if ( info(v)==null ) {
- vv=value(v);
- if ( q==null ) {
- mp_flush_cur_exp(mp, vv);
- } else {
- mp_recycle_value(mp, p); type(q)=mp_known; value(q)=vv;
- }
- } else if ( q==null ) {
- mp->cur_type=t;
- }
- if ( mp->fix_needed ) mp_fix_dependencies(mp);
-}
-
-@ Let's turn now to the six basic relations of comparison.
-
-@<Additional cases of binary operators@>=
-case less_than: case less_or_equal: case greater_than:
-case greater_or_equal: case equal_to: case unequal_to:
- check_arith; /* at this point |arith_error| should be |false|? */
- if ( (mp->cur_type>mp_pair_type)&&(type(p)>mp_pair_type) ) {
- mp_add_or_subtract(mp, p,null,minus); /* |cur_exp:=(p)-cur_exp| */
- } else if ( mp->cur_type!=type(p) ) {
- mp_bad_binary(mp, p,c); goto DONE;
- } else if ( mp->cur_type==mp_string_type ) {
- mp_flush_cur_exp(mp, mp_str_vs_str(mp, value(p),mp->cur_exp));
- } else if ((mp->cur_type==mp_unknown_string)||
- (mp->cur_type==mp_unknown_boolean) ) {
- @<Check if unknowns have been equated@>;
- } else if ( (mp->cur_type<=mp_pair_type)&&(mp->cur_type>=mp_transform_type)) {
- @<Reduce comparison of big nodes to comparison of scalars@>;
- } else if ( mp->cur_type==mp_boolean_type ) {
- mp_flush_cur_exp(mp, mp->cur_exp-value(p));
- } else {
- mp_bad_binary(mp, p,c); goto DONE;
- }
- @<Compare the current expression with zero@>;
-DONE:
- mp->arith_error=false; /* ignore overflow in comparisons */
- break;
-
-@ @<Compare the current expression with zero@>=
-if ( mp->cur_type!=mp_known ) {
- if ( mp->cur_type<mp_known ) {
- mp_disp_err(mp, p,"");
- help1("The quantities shown above have not been equated.")
- } else {
- help2("Oh dear. I can\'t decide if the expression above is positive,")
- ("negative, or zero. So this comparison test won't be `true'.");
- }
- exp_err("Unknown relation will be considered false");
-@.Unknown relation...@>
- mp_put_get_flush_error(mp, false_code);
-} else {
- switch (c) {
- case less_than: boolean_reset(mp->cur_exp<0); break;
- case less_or_equal: boolean_reset(mp->cur_exp<=0); break;
- case greater_than: boolean_reset(mp->cur_exp>0); break;
- case greater_or_equal: boolean_reset(mp->cur_exp>=0); break;
- case equal_to: boolean_reset(mp->cur_exp==0); break;
- case unequal_to: boolean_reset(mp->cur_exp!=0); break;
- }; /* there are no other cases */
-}
-mp->cur_type=mp_boolean_type
-
-@ When two unknown strings are in the same ring, we know that they are
-equal. Otherwise, we don't know whether they are equal or not, so we
-make no change.
-
-@<Check if unknowns have been equated@>=
-{
- q=value(mp->cur_exp);
- while ( (q!=mp->cur_exp)&&(q!=p) ) q=value(q);
- if ( q==p ) mp_flush_cur_exp(mp, 0);
-}
-
-@ @<Reduce comparison of big nodes to comparison of scalars@>=
-{
- q=value(p); r=value(mp->cur_exp);
- rr=r+mp->big_node_size[mp->cur_type]-2;
- while (1) { mp_add_or_subtract(mp, q,r,minus);
- if ( type(r)!=mp_known ) break;
- if ( value(r)!=0 ) break;
- if ( r==rr ) break;
- q=q+2; r=r+2;
- }
- mp_take_part(mp, name_type(r)+x_part-mp_x_part_sector);
-}
-
-@ Here we use the sneaky fact that |and_op-false_code=or_op-true_code|.
-
-@<Additional cases of binary operators@>=
-case and_op:
-case or_op:
- if ( (type(p)!=mp_boolean_type)||(mp->cur_type!=mp_boolean_type) )
- mp_bad_binary(mp, p,c);
- else if ( value(p)==c+false_code-and_op ) mp->cur_exp=value(p);
- break;
-
-@ @<Additional cases of binary operators@>=
-case times:
- if ( (mp->cur_type<mp_color_type)||(type(p)<mp_color_type) ) {
- mp_bad_binary(mp, p,times);
- } else if ( (mp->cur_type==mp_known)||(type(p)==mp_known) ) {
- @<Multiply when at least one operand is known@>;
- } else if ( (mp_nice_color_or_pair(mp, p,type(p))&&(mp->cur_type>mp_pair_type))
- ||(mp_nice_color_or_pair(mp, mp->cur_exp,mp->cur_type)&&
- (type(p)>mp_pair_type)) ) {
- mp_hard_times(mp, p);
- binary_return;
- } else {
- mp_bad_binary(mp, p,times);
- }
- break;
-
-@ @<Multiply when at least one operand is known@>=
-{
- if ( type(p)==mp_known ) {
- v=value(p); mp_free_node(mp, p,value_node_size);
- } else {
- v=mp->cur_exp; mp_unstash_cur_exp(mp, p);
- }
- if ( mp->cur_type==mp_known ) {
- mp->cur_exp=mp_take_scaled(mp, mp->cur_exp,v);
- } else if ( (mp->cur_type==mp_pair_type)||
- (mp->cur_type==mp_color_type)||
- (mp->cur_type==mp_cmykcolor_type) ) {
- p=value(mp->cur_exp)+mp->big_node_size[mp->cur_type];
- do {
- p=p-2; mp_dep_mult(mp, p,v,true);
- } while (p!=value(mp->cur_exp));
- } else {
- mp_dep_mult(mp, null,v,true);
- }
- binary_return;
-}
-
-@ @<Declare binary action...@>=
-void mp_dep_mult (MP mp,pointer p, integer v, boolean v_is_scaled) {
- pointer q; /* the dependency list being multiplied by |v| */
- small_number s,t; /* its type, before and after */
- if ( p==null ) {
- q=mp->cur_exp;
- } else if ( type(p)!=mp_known ) {
- q=p;
- } else {
- if ( v_is_scaled ) value(p)=mp_take_scaled(mp, value(p),v);
- else value(p)=mp_take_fraction(mp, value(p),v);
- return;
- };
- t=type(q); q=dep_list(q); s=t;
- if ( t==mp_dependent ) if ( v_is_scaled )
- if (mp_ab_vs_cd(mp, mp_max_coef(mp,q),abs(v),coef_bound-1,unity)>=0 )
- t=mp_proto_dependent;
- q=mp_p_times_v(mp, q,v,s,t,v_is_scaled);
- mp_dep_finish(mp, q,p,t);
-}
-
-@ Here is a routine that is similar to |times|; but it is invoked only
-internally, when |v| is a |fraction| whose magnitude is at most~1,
-and when |cur_type>=mp_color_type|.
-
-@c void mp_frac_mult (MP mp,scaled n, scaled d) {
- /* multiplies |cur_exp| by |n/d| */
- pointer p; /* a pair node */
- pointer old_exp; /* a capsule to recycle */
- fraction v; /* |n/d| */
- if ( mp->internal[mp_tracing_commands]>two ) {
- @<Trace the fraction multiplication@>;
- }
- switch (mp->cur_type) {
- case mp_transform_type:
- case mp_color_type:
- case mp_cmykcolor_type:
- case mp_pair_type:
- old_exp=mp_tarnished(mp, mp->cur_exp);
- break;
- case mp_independent: old_exp=mp_void; break;
- default: old_exp=null; break;
- }
- if ( old_exp!=null ) {
- old_exp=mp->cur_exp; mp_make_exp_copy(mp, old_exp);
- }
- v=mp_make_fraction(mp, n,d);
- if ( mp->cur_type==mp_known ) {
- mp->cur_exp=mp_take_fraction(mp, mp->cur_exp,v);
- } else if ( mp->cur_type<=mp_pair_type ) {
- p=value(mp->cur_exp)+mp->big_node_size[mp->cur_type];
- do {
- p=p-2;
- mp_dep_mult(mp, p,v,false);
- } while (p!=value(mp->cur_exp));
- } else {
- mp_dep_mult(mp, null,v,false);
- }
- if ( old_exp!=null ) {
- mp_recycle_value(mp, old_exp);
- mp_free_node(mp, old_exp,value_node_size);
- }
-}
-
-@ @<Trace the fraction multiplication@>=
-{
- mp_begin_diagnostic(mp);
- mp_print_nl(mp, "{("); mp_print_scaled(mp,n); mp_print_char(mp,'/');
- mp_print_scaled(mp,d); mp_print(mp,")*("); mp_print_exp(mp,null,0);
- mp_print(mp,")}");
- mp_end_diagnostic(mp, false);
-}
-
-@ The |hard_times| routine multiplies a nice color or pair by a dependency list.
-
-@<Declare binary action procedures@>=
-void mp_hard_times (MP mp,pointer p) {
- pointer q; /* a copy of the dependent variable |p| */
- pointer r; /* a component of the big node for the nice color or pair */
- scaled v; /* the known value for |r| */
- if ( type(p)<=mp_pair_type ) {
- q=mp_stash_cur_exp(mp); mp_unstash_cur_exp(mp, p); p=q;
- }; /* now |cur_type=mp_pair_type| or |cur_type=mp_color_type| */
- r=value(mp->cur_exp)+mp->big_node_size[mp->cur_type];
- while (1) {
- r=r-2;
- v=value(r);
- type(r)=type(p);
- if ( r==value(mp->cur_exp) )
- break;
- mp_new_dep(mp, r,mp_copy_dep_list(mp, dep_list(p)));
- mp_dep_mult(mp, r,v,true);
- }
- mp->mem[value_loc(r)]=mp->mem[value_loc(p)];
- link(prev_dep(p))=r;
- mp_free_node(mp, p,value_node_size);
- mp_dep_mult(mp, r,v,true);
-}
-
-@ @<Additional cases of binary operators@>=
-case over:
- if ( (mp->cur_type!=mp_known)||(type(p)<mp_color_type) ) {
- mp_bad_binary(mp, p,over);
- } else {
- v=mp->cur_exp; mp_unstash_cur_exp(mp, p);
- if ( v==0 ) {
- @<Squeal about division by zero@>;
- } else {
- if ( mp->cur_type==mp_known ) {
- mp->cur_exp=mp_make_scaled(mp, mp->cur_exp,v);
- } else if ( mp->cur_type<=mp_pair_type ) {
- p=value(mp->cur_exp)+mp->big_node_size[mp->cur_type];
- do {
- p=p-2; mp_dep_div(mp, p,v);
- } while (p!=value(mp->cur_exp));
- } else {
- mp_dep_div(mp, null,v);
- }
- }
- binary_return;
- }
- break;
-
-@ @<Declare binary action...@>=
-void mp_dep_div (MP mp,pointer p, scaled v) {
- pointer q; /* the dependency list being divided by |v| */
- small_number s,t; /* its type, before and after */
- if ( p==null ) q=mp->cur_exp;
- else if ( type(p)!=mp_known ) q=p;
- else { value(p)=mp_make_scaled(mp, value(p),v); return; };
- t=type(q); q=dep_list(q); s=t;
- if ( t==mp_dependent )
- if ( mp_ab_vs_cd(mp, mp_max_coef(mp,q),unity,coef_bound-1,abs(v))>=0 )
- t=mp_proto_dependent;
- q=mp_p_over_v(mp, q,v,s,t);
- mp_dep_finish(mp, q,p,t);
-}
-
-@ @<Squeal about division by zero@>=
-{
- exp_err("Division by zero");
-@.Division by zero@>
- help2("You're trying to divide the quantity shown above the error")
- ("message by zero. I'm going to divide it by one instead.");
- mp_put_get_error(mp);
-}
-
-@ @<Additional cases of binary operators@>=
-case pythag_add:
-case pythag_sub:
- if ( (mp->cur_type==mp_known)&&(type(p)==mp_known) ) {
- if ( c==pythag_add ) mp->cur_exp=mp_pyth_add(mp, value(p),mp->cur_exp);
- else mp->cur_exp=mp_pyth_sub(mp, value(p),mp->cur_exp);
- } else mp_bad_binary(mp, p,c);
- break;
-
-@ The next few sections of the program deal with affine transformations
-of coordinate data.
-
-@<Additional cases of binary operators@>=
-case rotated_by: case slanted_by:
-case scaled_by: case shifted_by: case transformed_by:
-case x_scaled: case y_scaled: case z_scaled:
- if ( type(p)==mp_path_type ) {
- path_trans(c,p); binary_return;
- } else if ( type(p)==mp_pen_type ) {
- pen_trans(c,p);
- mp->cur_exp=mp_convex_hull(mp, mp->cur_exp);
- /* rounding error could destroy convexity */
- binary_return;
- } else if ( (type(p)==mp_pair_type)||(type(p)==mp_transform_type) ) {
- mp_big_trans(mp, p,c);
- } else if ( type(p)==mp_picture_type ) {
- mp_do_edges_trans(mp, p,c); binary_return;
- } else {
- mp_bad_binary(mp, p,c);
- }
- break;
-
-@ Let |c| be one of the eight transform operators. The procedure call
-|set_up_trans(c)| first changes |cur_exp| to a transform that corresponds to
-|c| and the original value of |cur_exp|. (In particular, |cur_exp| doesn't
-change at all if |c=transformed_by|.)
-
-Then, if all components of the resulting transform are |known|, they are
-moved to the global variables |txx|, |txy|, |tyx|, |tyy|, |tx|, |ty|;
-and |cur_exp| is changed to the known value zero.
-
-@<Declare binary action...@>=
-void mp_set_up_trans (MP mp,quarterword c) {
- pointer p,q,r; /* list manipulation registers */
- if ( (c!=transformed_by)||(mp->cur_type!=mp_transform_type) ) {
- @<Put the current transform into |cur_exp|@>;
- }
- @<If the current transform is entirely known, stash it in global variables;
- otherwise |return|@>;
-}
-
-@ @<Glob...@>=
-scaled txx;
-scaled txy;
-scaled tyx;
-scaled tyy;
-scaled tx;
-scaled ty; /* current transform coefficients */
-
-@ @<Put the current transform...@>=
-{
- p=mp_stash_cur_exp(mp);
- mp->cur_exp=mp_id_transform(mp);
- mp->cur_type=mp_transform_type;
- q=value(mp->cur_exp);
- switch (c) {
- @<For each of the eight cases, change the relevant fields of |cur_exp|
- and |goto done|;
- but do nothing if capsule |p| doesn't have the appropriate type@>;
- }; /* there are no other cases */
- mp_disp_err(mp, p,"Improper transformation argument");
-@.Improper transformation argument@>
- help3("The expression shown above has the wrong type,")
- ("so I can\'t transform anything using it.")
- ("Proceed, and I'll omit the transformation.");
- mp_put_get_error(mp);
-DONE:
- mp_recycle_value(mp, p);
- mp_free_node(mp, p,value_node_size);
-}
-
-@ @<If the current transform is entirely known, ...@>=
-q=value(mp->cur_exp); r=q+transform_node_size;
-do {
- r=r-2;
- if ( type(r)!=mp_known ) return;
-} while (r!=q);
-mp->txx=value(xx_part_loc(q));
-mp->txy=value(xy_part_loc(q));
-mp->tyx=value(yx_part_loc(q));
-mp->tyy=value(yy_part_loc(q));
-mp->tx=value(x_part_loc(q));
-mp->ty=value(y_part_loc(q));
-mp_flush_cur_exp(mp, 0)
-
-@ @<For each of the eight cases...@>=
-case rotated_by:
- if ( type(p)==mp_known )
- @<Install sines and cosines, then |goto done|@>;
- break;
-case slanted_by:
- if ( type(p)>mp_pair_type ) {
- mp_install(mp, xy_part_loc(q),p); goto DONE;
- };
- break;
-case scaled_by:
- if ( type(p)>mp_pair_type ) {
- mp_install(mp, xx_part_loc(q),p); mp_install(mp, yy_part_loc(q),p);
- goto DONE;
- };
- break;
-case shifted_by:
- if ( type(p)==mp_pair_type ) {
- r=value(p); mp_install(mp, x_part_loc(q),x_part_loc(r));
- mp_install(mp, y_part_loc(q),y_part_loc(r)); goto DONE;
- };
- break;
-case x_scaled:
- if ( type(p)>mp_pair_type ) {
- mp_install(mp, xx_part_loc(q),p); goto DONE;
- };
- break;
-case y_scaled:
- if ( type(p)>mp_pair_type ) {
- mp_install(mp, yy_part_loc(q),p); goto DONE;
- };
- break;
-case z_scaled:
- if ( type(p)==mp_pair_type )
- @<Install a complex multiplier, then |goto done|@>;
- break;
-case transformed_by:
- break;
-
-
-@ @<Install sines and cosines, then |goto done|@>=
-{ mp_n_sin_cos(mp, (value(p) % three_sixty_units)*16);
- value(xx_part_loc(q))=mp_round_fraction(mp, mp->n_cos);
- value(yx_part_loc(q))=mp_round_fraction(mp, mp->n_sin);
- value(xy_part_loc(q))=-value(yx_part_loc(q));
- value(yy_part_loc(q))=value(xx_part_loc(q));
- goto DONE;
-}
-
-@ @<Install a complex multiplier, then |goto done|@>=
-{
- r=value(p);
- mp_install(mp, xx_part_loc(q),x_part_loc(r));
- mp_install(mp, yy_part_loc(q),x_part_loc(r));
- mp_install(mp, yx_part_loc(q),y_part_loc(r));
- if ( type(y_part_loc(r))==mp_known ) negate(value(y_part_loc(r)));
- else mp_negate_dep_list(mp, dep_list(y_part_loc(r)));
- mp_install(mp, xy_part_loc(q),y_part_loc(r));
- goto DONE;
-}
-
-@ Procedure |set_up_known_trans| is like |set_up_trans|, but it
-insists that the transformation be entirely known.
-
-@<Declare binary action...@>=
-void mp_set_up_known_trans (MP mp,quarterword c) {
- mp_set_up_trans(mp, c);
- if ( mp->cur_type!=mp_known ) {
- exp_err("Transform components aren't all known");
-@.Transform components...@>
- help3("I'm unable to apply a partially specified transformation")
- ("except to a fully known pair or transform.")
- ("Proceed, and I'll omit the transformation.");
- mp_put_get_flush_error(mp, 0);
- mp->txx=unity; mp->txy=0; mp->tyx=0; mp->tyy=unity;
- mp->tx=0; mp->ty=0;
- }
-}
-
-@ Here's a procedure that applies the transform |txx..ty| to a pair of
-coordinates in locations |p| and~|q|.
-
-@<Declare binary action...@>=
-void mp_trans (MP mp,pointer p, pointer q) {
- scaled v; /* the new |x| value */
- v=mp_take_scaled(mp, mp->mem[p].sc,mp->txx)+
- mp_take_scaled(mp, mp->mem[q].sc,mp->txy)+mp->tx;
- mp->mem[q].sc=mp_take_scaled(mp, mp->mem[p].sc,mp->tyx)+
- mp_take_scaled(mp, mp->mem[q].sc,mp->tyy)+mp->ty;
- mp->mem[p].sc=v;
-}
-
-@ The simplest transformation procedure applies a transform to all
-coordinates of a path. The |path_trans(c)(p)| macro applies
-a transformation defined by |cur_exp| and the transform operator |c|
-to the path~|p|.
-
-@d path_trans(A,B) { mp_set_up_known_trans(mp, (A));
- mp_unstash_cur_exp(mp, (B));
- mp_do_path_trans(mp, mp->cur_exp); }
-
-@<Declare binary action...@>=
-void mp_do_path_trans (MP mp,pointer p) {
- pointer q; /* list traverser */
- q=p;
- do {
- if ( left_type(q)!=mp_endpoint )
- mp_trans(mp, q+3,q+4); /* that's |left_x| and |left_y| */
- mp_trans(mp, q+1,q+2); /* that's |x_coord| and |y_coord| */
- if ( right_type(q)!=mp_endpoint )
- mp_trans(mp, q+5,q+6); /* that's |right_x| and |right_y| */
-@^data structure assumptions@>
- q=link(q);
- } while (q!=p);
-}
-
-@ Transforming a pen is very similar, except that there are no |left_type|
-and |right_type| fields.
-
-@d pen_trans(A,B) { mp_set_up_known_trans(mp, (A));
- mp_unstash_cur_exp(mp, (B));
- mp_do_pen_trans(mp, mp->cur_exp); }
-
-@<Declare binary action...@>=
-void mp_do_pen_trans (MP mp,pointer p) {
- pointer q; /* list traverser */
- if ( pen_is_elliptical(p) ) {
- mp_trans(mp, p+3,p+4); /* that's |left_x| and |left_y| */
- mp_trans(mp, p+5,p+6); /* that's |right_x| and |right_y| */
- };
- q=p;
- do {
- mp_trans(mp, q+1,q+2); /* that's |x_coord| and |y_coord| */
-@^data structure assumptions@>
- q=link(q);
- } while (q!=p);
-}
-
-@ The next transformation procedure applies to edge structures. It will do
-any transformation, but the results may be substandard if the picture contains
-text that uses downloaded bitmap fonts. The binary action procedure is
-|do_edges_trans|, but we also need a function that just scales a picture.
-That routine is |scale_edges|. Both it and the underlying routine |edges_trans|
-should be thought of as procedures that update an edge structure |h|, except
-that they have to return a (possibly new) structure because of the need to call
-|private_edges|.
-
-@<Declare binary action...@>=
-pointer mp_edges_trans (MP mp, pointer h) {
- pointer q; /* the object being transformed */
- pointer r,s; /* for list manipulation */
- scaled sx,sy; /* saved transformation parameters */
- scaled sqdet; /* square root of determinant for |dash_scale| */
- integer sgndet; /* sign of the determinant */
- scaled v; /* a temporary value */
- h=mp_private_edges(mp, h);
- sqdet=mp_sqrt_det(mp, mp->txx,mp->txy,mp->tyx,mp->tyy);
- sgndet=mp_ab_vs_cd(mp, mp->txx,mp->tyy,mp->txy,mp->tyx);
- if ( dash_list(h)!=null_dash ) {
- @<Try to transform the dash list of |h|@>;
- }
- @<Make the bounding box of |h| unknown if it can't be updated properly
- without scanning the whole structure@>;
- q=link(dummy_loc(h));
- while ( q!=null ) {
- @<Transform graphical object |q|@>;
- q=link(q);
- }
- return h;
-}
-void mp_do_edges_trans (MP mp,pointer p, quarterword c) {
- mp_set_up_known_trans(mp, c);
- value(p)=mp_edges_trans(mp, value(p));
- mp_unstash_cur_exp(mp, p);
-}
-void mp_scale_edges (MP mp) {
- mp->txx=mp->se_sf; mp->tyy=mp->se_sf;
- mp->txy=0; mp->tyx=0; mp->tx=0; mp->ty=0;
- mp->se_pic=mp_edges_trans(mp, mp->se_pic);
-}
-
-@ @<Try to transform the dash list of |h|@>=
-if ( (mp->txy!=0)||(mp->tyx!=0)||
- (mp->ty!=0)||(abs(mp->txx)!=abs(mp->tyy))) {
- mp_flush_dash_list(mp, h);
-} else {
- if ( mp->txx<0 ) { @<Reverse the dash list of |h|@>; }
- @<Scale the dash list by |txx| and shift it by |tx|@>;
- dash_y(h)=mp_take_scaled(mp, dash_y(h),abs(mp->tyy));
-}
-
-@ @<Reverse the dash list of |h|@>=
-{
- r=dash_list(h);
- dash_list(h)=null_dash;
- while ( r!=null_dash ) {
- s=r; r=link(r);
- v=start_x(s); start_x(s)=stop_x(s); stop_x(s)=v;
- link(s)=dash_list(h);
- dash_list(h)=s;
- }
-}
-
-@ @<Scale the dash list by |txx| and shift it by |tx|@>=
-r=dash_list(h);
-while ( r!=null_dash ) {
- start_x(r)=mp_take_scaled(mp, start_x(r),mp->txx)+mp->tx;
- stop_x(r)=mp_take_scaled(mp, stop_x(r),mp->txx)+mp->tx;
- r=link(r);
-}
-
-@ @<Make the bounding box of |h| unknown if it can't be updated properly...@>=
-if ( (mp->txx==0)&&(mp->tyy==0) ) {
- @<Swap the $x$ and $y$ parameters in the bounding box of |h|@>;
-} else if ( (mp->txy!=0)||(mp->tyx!=0) ) {
- mp_init_bbox(mp, h);
- goto DONE1;
-}
-if ( minx_val(h)<=maxx_val(h) ) {
- @<Scale the bounding box by |txx+txy| and |tyx+tyy|; then shift by
- |(tx,ty)|@>;
-}
-DONE1:
-
-
-
-@ @<Swap the $x$ and $y$ parameters in the bounding box of |h|@>=
-{
- v=minx_val(h); minx_val(h)=miny_val(h); miny_val(h)=v;
- v=maxx_val(h); maxx_val(h)=maxy_val(h); maxy_val(h)=v;
-}
-
-@ The sum ``|txx+txy|'' is whichever of |txx| or |txy| is nonzero. The other
-sum is similar.
-
-@<Scale the bounding box by |txx+txy| and |tyx+tyy|; then shift...@>=
-{
- minx_val(h)=mp_take_scaled(mp, minx_val(h),mp->txx+mp->txy)+mp->tx;
- maxx_val(h)=mp_take_scaled(mp, maxx_val(h),mp->txx+mp->txy)+mp->tx;
- miny_val(h)=mp_take_scaled(mp, miny_val(h),mp->tyx+mp->tyy)+mp->ty;
- maxy_val(h)=mp_take_scaled(mp, maxy_val(h),mp->tyx+mp->tyy)+mp->ty;
- if ( mp->txx+mp->txy<0 ) {
- v=minx_val(h); minx_val(h)=maxx_val(h); maxx_val(h)=v;
- }
- if ( mp->tyx+mp->tyy<0 ) {
- v=miny_val(h); miny_val(h)=maxy_val(h); maxy_val(h)=v;
- }
-}
-
-@ Now we ready for the main task of transforming the graphical objects in edge
-structure~|h|.
-
-@<Transform graphical object |q|@>=
-switch (type(q)) {
-case mp_fill_code: case mp_stroked_code:
- mp_do_path_trans(mp, path_p(q));
- @<Transform |pen_p(q)|, making sure polygonal pens stay counter-clockwise@>;
- break;
-case mp_start_clip_code: case mp_start_bounds_code:
- mp_do_path_trans(mp, path_p(q));
- break;
-case mp_text_code:
- r=text_tx_loc(q);
- @<Transform the compact transformation starting at |r|@>;
- break;
-case mp_stop_clip_code: case mp_stop_bounds_code:
- break;
-} /* there are no other cases */
-
-@ Note that the shift parameters |(tx,ty)| apply only to the path being stroked.
-The |dash_scale| has to be adjusted to scale the dash lengths in |dash_p(q)|
-since the \ps\ output procedures will try to compensate for the transformation
-we are applying to |pen_p(q)|. Since this compensation is based on the square
-root of the determinant, |sqdet| is the appropriate factor.
-
-@<Transform |pen_p(q)|, making sure...@>=
-if ( pen_p(q)!=null ) {
- sx=mp->tx; sy=mp->ty;
- mp->tx=0; mp->ty=0;
- mp_do_pen_trans(mp, pen_p(q));
- if ( ((type(q)==mp_stroked_code)&&(dash_p(q)!=null)) )
- dash_scale(q)=mp_take_scaled(mp, dash_scale(q),sqdet);
- if ( ! pen_is_elliptical(pen_p(q)) )
- if ( sgndet<0 )
- pen_p(q)=mp_make_pen(mp, mp_copy_path(mp, pen_p(q)),true);
- /* this unreverses the pen */
- mp->tx=sx; mp->ty=sy;
-}
-
-@ This uses the fact that transformations are stored in the order
-|(tx,ty,txx,txy,tyx,tyy)|.
-@^data structure assumptions@>
-
-@<Transform the compact transformation starting at |r|@>=
-mp_trans(mp, r,r+1);
-sx=mp->tx; sy=mp->ty;
-mp->tx=0; mp->ty=0;
-mp_trans(mp, r+2,r+4);
-mp_trans(mp, r+3,r+5);
-mp->tx=sx; mp->ty=sy
-
-@ The hard cases of transformation occur when big nodes are involved,
-and when some of their components are unknown.
-
-@<Declare binary action...@>=
-@<Declare subroutines needed by |big_trans|@>
-void mp_big_trans (MP mp,pointer p, quarterword c) {
- pointer q,r,pp,qq; /* list manipulation registers */
- small_number s; /* size of a big node */
- s=mp->big_node_size[type(p)]; q=value(p); r=q+s;
- do {
- r=r-2;
- if ( type(r)!=mp_known ) {
- @<Transform an unknown big node and |return|@>;
- }
- } while (r!=q);
- @<Transform a known big node@>;
-} /* node |p| will now be recycled by |do_binary| */
-
-@ @<Transform an unknown big node and |return|@>=
-{
- mp_set_up_known_trans(mp, c); mp_make_exp_copy(mp, p);
- r=value(mp->cur_exp);
- if ( mp->cur_type==mp_transform_type ) {
- mp_bilin1(mp, yy_part_loc(r),mp->tyy,xy_part_loc(q),mp->tyx,0);
- mp_bilin1(mp, yx_part_loc(r),mp->tyy,xx_part_loc(q),mp->tyx,0);
- mp_bilin1(mp, xy_part_loc(r),mp->txx,yy_part_loc(q),mp->txy,0);
- mp_bilin1(mp, xx_part_loc(r),mp->txx,yx_part_loc(q),mp->txy,0);
- }
- mp_bilin1(mp, y_part_loc(r),mp->tyy,x_part_loc(q),mp->tyx,mp->ty);
- mp_bilin1(mp, x_part_loc(r),mp->txx,y_part_loc(q),mp->txy,mp->tx);
- return;
-}
-
-@ Let |p| point to a two-word value field inside a big node of |cur_exp|,
-and let |q| point to a another value field. The |bilin1| procedure
-replaces |p| by $p\cdot t+q\cdot u+\delta$.
-
-@<Declare subroutines needed by |big_trans|@>=
-void mp_bilin1 (MP mp, pointer p, scaled t, pointer q,
- scaled u, scaled delta) {
- pointer r; /* list traverser */
- if ( t!=unity ) mp_dep_mult(mp, p,t,true);
- if ( u!=0 ) {
- if ( type(q)==mp_known ) {
- delta+=mp_take_scaled(mp, value(q),u);
- } else {
- @<Ensure that |type(p)=mp_proto_dependent|@>;
- dep_list(p)=mp_p_plus_fq(mp, dep_list(p),u,dep_list(q),
- mp_proto_dependent,type(q));
- }
- }
- if ( type(p)==mp_known ) {
- value(p)+=delta;
- } else {
- r=dep_list(p);
- while ( info(r)!=null ) r=link(r);
- delta+=value(r);
- if ( r!=dep_list(p) ) value(r)=delta;
- else { mp_recycle_value(mp, p); type(p)=mp_known; value(p)=delta; };
- }
- if ( mp->fix_needed ) mp_fix_dependencies(mp);
-}
-
-@ @<Ensure that |type(p)=mp_proto_dependent|@>=
-if ( type(p)!=mp_proto_dependent ) {
- if ( type(p)==mp_known )
- mp_new_dep(mp, p,mp_const_dependency(mp, value(p)));
- else
- dep_list(p)=mp_p_times_v(mp, dep_list(p),unity,mp_dependent,
- mp_proto_dependent,true);
- type(p)=mp_proto_dependent;
-}
-
-@ @<Transform a known big node@>=
-mp_set_up_trans(mp, c);
-if ( mp->cur_type==mp_known ) {
- @<Transform known by known@>;
-} else {
- pp=mp_stash_cur_exp(mp); qq=value(pp);
- mp_make_exp_copy(mp, p); r=value(mp->cur_exp);
- if ( mp->cur_type==mp_transform_type ) {
- mp_bilin2(mp, yy_part_loc(r),yy_part_loc(qq),
- value(xy_part_loc(q)),yx_part_loc(qq),null);
- mp_bilin2(mp, yx_part_loc(r),yy_part_loc(qq),
- value(xx_part_loc(q)),yx_part_loc(qq),null);
- mp_bilin2(mp, xy_part_loc(r),xx_part_loc(qq),
- value(yy_part_loc(q)),xy_part_loc(qq),null);
- mp_bilin2(mp, xx_part_loc(r),xx_part_loc(qq),
- value(yx_part_loc(q)),xy_part_loc(qq),null);
- };
- mp_bilin2(mp, y_part_loc(r),yy_part_loc(qq),
- value(x_part_loc(q)),yx_part_loc(qq),y_part_loc(qq));
- mp_bilin2(mp, x_part_loc(r),xx_part_loc(qq),
- value(y_part_loc(q)),xy_part_loc(qq),x_part_loc(qq));
- mp_recycle_value(mp, pp); mp_free_node(mp, pp,value_node_size);
-}
-
-@ Let |p| be a |mp_proto_dependent| value whose dependency list ends
-at |dep_final|. The following procedure adds |v| times another
-numeric quantity to~|p|.
-
-@<Declare subroutines needed by |big_trans|@>=
-void mp_add_mult_dep (MP mp,pointer p, scaled v, pointer r) {
- if ( type(r)==mp_known ) {
- value(mp->dep_final)+=mp_take_scaled(mp, value(r),v);
- } else {
- dep_list(p)=mp_p_plus_fq(mp, dep_list(p),v,dep_list(r),
- mp_proto_dependent,type(r));
- if ( mp->fix_needed ) mp_fix_dependencies(mp);
- }
-}
-
-@ The |bilin2| procedure is something like |bilin1|, but with known
-and unknown quantities reversed. Parameter |p| points to a value field
-within the big node for |cur_exp|; and |type(p)=mp_known|. Parameters
-|t| and~|u| point to value fields elsewhere; so does parameter~|q|,
-unless it is |null| (which stands for zero). Location~|p| will be
-replaced by $p\cdot t+v\cdot u+q$.
-
-@<Declare subroutines needed by |big_trans|@>=
-void mp_bilin2 (MP mp,pointer p, pointer t, scaled v,
- pointer u, pointer q) {
- scaled vv; /* temporary storage for |value(p)| */
- vv=value(p); type(p)=mp_proto_dependent;
- mp_new_dep(mp, p,mp_const_dependency(mp, 0)); /* this sets |dep_final| */
- if ( vv!=0 )
- mp_add_mult_dep(mp, p,vv,t); /* |dep_final| doesn't change */
- if ( v!=0 ) mp_add_mult_dep(mp, p,v,u);
- if ( q!=null ) mp_add_mult_dep(mp, p,unity,q);
- if ( dep_list(p)==mp->dep_final ) {
- vv=value(mp->dep_final); mp_recycle_value(mp, p);
- type(p)=mp_known; value(p)=vv;
- }
-}
-
-@ @<Transform known by known@>=
-{
- mp_make_exp_copy(mp, p); r=value(mp->cur_exp);
- if ( mp->cur_type==mp_transform_type ) {
- mp_bilin3(mp, yy_part_loc(r),mp->tyy,value(xy_part_loc(q)),mp->tyx,0);
- mp_bilin3(mp, yx_part_loc(r),mp->tyy,value(xx_part_loc(q)),mp->tyx,0);
- mp_bilin3(mp, xy_part_loc(r),mp->txx,value(yy_part_loc(q)),mp->txy,0);
- mp_bilin3(mp, xx_part_loc(r),mp->txx,value(yx_part_loc(q)),mp->txy,0);
- }
- mp_bilin3(mp, y_part_loc(r),mp->tyy,value(x_part_loc(q)),mp->tyx,mp->ty);
- mp_bilin3(mp, x_part_loc(r),mp->txx,value(y_part_loc(q)),mp->txy,mp->tx);
-}
-
-@ Finally, in |bilin3| everything is |known|.
-
-@<Declare subroutines needed by |big_trans|@>=
-void mp_bilin3 (MP mp,pointer p, scaled t,
- scaled v, scaled u, scaled delta) {
- if ( t!=unity )
- delta+=mp_take_scaled(mp, value(p),t);
- else
- delta+=value(p);
- if ( u!=0 ) value(p)=delta+mp_take_scaled(mp, v,u);
- else value(p)=delta;
-}
-
-@ @<Additional cases of binary operators@>=
-case concatenate:
- if ( (mp->cur_type==mp_string_type)&&(type(p)==mp_string_type) ) mp_cat(mp, p);
- else mp_bad_binary(mp, p,concatenate);
- break;
-case substring_of:
- if ( mp_nice_pair(mp, p,type(p))&&(mp->cur_type==mp_string_type) )
- mp_chop_string(mp, value(p));
- else mp_bad_binary(mp, p,substring_of);
- break;
-case subpath_of:
- if ( mp->cur_type==mp_pair_type ) mp_pair_to_path(mp);
- if ( mp_nice_pair(mp, p,type(p))&&(mp->cur_type==mp_path_type) )
- mp_chop_path(mp, value(p));
- else mp_bad_binary(mp, p,subpath_of);
- break;
-
-@ @<Declare binary action...@>=
-void mp_cat (MP mp,pointer p) {
- str_number a,b; /* the strings being concatenated */
- pool_pointer k; /* index into |str_pool| */
- a=value(p); b=mp->cur_exp; str_room(length(a)+length(b));
- for (k=mp->str_start[a];k<=str_stop(a)-1;k++) {
- append_char(mp->str_pool[k]);
- }
- for (k=mp->str_start[b];k<=str_stop(b)-1;k++) {
- append_char(mp->str_pool[k]);
- }
- mp->cur_exp=mp_make_string(mp); delete_str_ref(b);
-}
-
-@ @<Declare binary action...@>=
-void mp_chop_string (MP mp,pointer p) {
- integer a, b; /* start and stop points */
- integer l; /* length of the original string */
- integer k; /* runs from |a| to |b| */
- str_number s; /* the original string */
- boolean reversed; /* was |a>b|? */
- a=mp_round_unscaled(mp, value(x_part_loc(p)));
- b=mp_round_unscaled(mp, value(y_part_loc(p)));
- if ( a<=b ) reversed=false;
- else { reversed=true; k=a; a=b; b=k; };
- s=mp->cur_exp; l=length(s);
- if ( a<0 ) {
- a=0;
- if ( b<0 ) b=0;
- }
- if ( b>l ) {
- b=l;
- if ( a>l ) a=l;
- }
- str_room(b-a);
- if ( reversed ) {
- for (k=mp->str_start[s]+b-1;k>=mp->str_start[s]+a;k--) {
- append_char(mp->str_pool[k]);
- }
- } else {
- for (k=mp->str_start[s]+a;k<=mp->str_start[s]+b-1;k++) {
- append_char(mp->str_pool[k]);
- }
- }
- mp->cur_exp=mp_make_string(mp); delete_str_ref(s);
-}
-
-@ @<Declare binary action...@>=
-void mp_chop_path (MP mp,pointer p) {
- pointer q; /* a knot in the original path */
- pointer pp,qq,rr,ss; /* link variables for copies of path nodes */
- scaled a,b,k,l; /* indices for chopping */
- boolean reversed; /* was |a>b|? */
- l=mp_path_length(mp); a=value(x_part_loc(p)); b=value(y_part_loc(p));
- if ( a<=b ) reversed=false;
- else { reversed=true; k=a; a=b; b=k; };
- @<Dispense with the cases |a<0| and/or |b>l|@>;
- q=mp->cur_exp;
- while ( a>=unity ) {
- q=link(q); a=a-unity; b=b-unity;
- }
- if ( b==a ) {
- @<Construct a path from |pp| to |qq| of length zero@>;
- } else {
- @<Construct a path from |pp| to |qq| of length $\lceil b\rceil$@>;
- }
- left_type(pp)=mp_endpoint; right_type(qq)=mp_endpoint; link(qq)=pp;
- mp_toss_knot_list(mp, mp->cur_exp);
- if ( reversed ) {
- mp->cur_exp=link(mp_htap_ypoc(mp, pp)); mp_toss_knot_list(mp, pp);
- } else {
- mp->cur_exp=pp;
- }
-}
-
-@ @<Dispense with the cases |a<0| and/or |b>l|@>=
-if ( a<0 ) {
- if ( left_type(mp->cur_exp)==mp_endpoint ) {
- a=0; if ( b<0 ) b=0;
- } else {
- do { a=a+l; b=b+l; } while (a<0); /* a cycle always has length |l>0| */
- }
-}
-if ( b>l ) {
- if ( left_type(mp->cur_exp)==mp_endpoint ) {
- b=l; if ( a>l ) a=l;
- } else {
- while ( a>=l ) {
- a=a-l; b=b-l;
- }
- }
-}
-
-@ @<Construct a path from |pp| to |qq| of length $\lceil b\rceil$@>=
-{
- pp=mp_copy_knot(mp, q); qq=pp;
- do {
- q=link(q); rr=qq; qq=mp_copy_knot(mp, q); link(rr)=qq; b=b-unity;
- } while (b>0);
- if ( a>0 ) {
- ss=pp; pp=link(pp);
- mp_split_cubic(mp, ss,a*010000); pp=link(ss);
- mp_free_node(mp, ss,knot_node_size);
- if ( rr==ss ) {
- b=mp_make_scaled(mp, b,unity-a); rr=pp;
- }
- }
- if ( b<0 ) {
- mp_split_cubic(mp, rr,(b+unity)*010000);
- mp_free_node(mp, qq,knot_node_size);
- qq=link(rr);
- }
-}
-
-@ @<Construct a path from |pp| to |qq| of length zero@>=
-{
- if ( a>0 ) { mp_split_cubic(mp, q,a*010000); q=link(q); };
- pp=mp_copy_knot(mp, q); qq=pp;
-}
-
-@ @<Additional cases of binary operators@>=
-case point_of: case precontrol_of: case postcontrol_of:
- if ( mp->cur_type==mp_pair_type )
- mp_pair_to_path(mp);
- if ( (mp->cur_type==mp_path_type)&&(type(p)==mp_known) )
- mp_find_point(mp, value(p),c);
- else
- mp_bad_binary(mp, p,c);
- break;
-case pen_offset_of:
- if ( (mp->cur_type==mp_pen_type)&& mp_nice_pair(mp, p,type(p)) )
- mp_set_up_offset(mp, value(p));
- else
- mp_bad_binary(mp, p,pen_offset_of);
- break;
-case direction_time_of:
- if ( mp->cur_type==mp_pair_type ) mp_pair_to_path(mp);
- if ( (mp->cur_type==mp_path_type)&& mp_nice_pair(mp, p,type(p)) )
- mp_set_up_direction_time(mp, value(p));
- else
- mp_bad_binary(mp, p,direction_time_of);
- break;
-case envelope_of:
- if ( (type(p) != mp_pen_type) || (mp->cur_type != mp_path_type) )
- mp_bad_binary(mp, p,envelope_of);
- else
- mp_set_up_envelope(mp, p);
- break;
-
-@ @<Declare binary action...@>=
-void mp_set_up_offset (MP mp,pointer p) {
- mp_find_offset(mp, value(x_part_loc(p)),value(y_part_loc(p)),mp->cur_exp);
- mp_pair_value(mp, mp->cur_x,mp->cur_y);
-}
-void mp_set_up_direction_time (MP mp,pointer p) {
- mp_flush_cur_exp(mp, mp_find_direction_time(mp, value(x_part_loc(p)),
- value(y_part_loc(p)),mp->cur_exp));
-}
-void mp_set_up_envelope (MP mp,pointer p) {
- small_number ljoin, lcap;
- scaled miterlim;
- pointer q = mp_copy_path(mp, mp->cur_exp); /* the original path */
- /* TODO: accept elliptical pens for straight paths */
- if (pen_is_elliptical(value(p))) {
- mp_bad_envelope_pen(mp);
- mp->cur_exp = q;
- mp->cur_type = mp_path_type;
- return;
- }
- if ( mp->internal[mp_linejoin]>unity ) ljoin=2;
- else if ( mp->internal[mp_linejoin]>0 ) ljoin=1;
- else ljoin=0;
- if ( mp->internal[mp_linecap]>unity ) lcap=2;
- else if ( mp->internal[mp_linecap]>0 ) lcap=1;
- else lcap=0;
- if ( mp->internal[mp_miterlimit]<unity )
- miterlim=unity;
- else
- miterlim=mp->internal[mp_miterlimit];
- mp->cur_exp = mp_make_envelope(mp, q, value(p), ljoin,lcap,miterlim);
- mp->cur_type = mp_path_type;
-}
-
-@ @<Declare binary action...@>=
-void mp_find_point (MP mp,scaled v, quarterword c) {
- pointer p; /* the path */
- scaled n; /* its length */
- p=mp->cur_exp;
- if ( left_type(p)==mp_endpoint ) n=-unity; else n=0;
- do { p=link(p); n=n+unity; } while (p!=mp->cur_exp);
- if ( n==0 ) {
- v=0;
- } else if ( v<0 ) {
- if ( left_type(p)==mp_endpoint ) v=0;
- else v=n-1-((-v-1) % n);
- } else if ( v>n ) {
- if ( left_type(p)==mp_endpoint ) v=n;
- else v=v % n;
- }
- p=mp->cur_exp;
- while ( v>=unity ) { p=link(p); v=v-unity; };
- if ( v!=0 ) {
- @<Insert a fractional node by splitting the cubic@>;
- }
- @<Set the current expression to the desired path coordinates@>;
-}
-
-@ @<Insert a fractional node...@>=
-{ mp_split_cubic(mp, p,v*010000); p=link(p); }
-
-@ @<Set the current expression to the desired path coordinates...@>=
-switch (c) {
-case point_of:
- mp_pair_value(mp, x_coord(p),y_coord(p));
- break;
-case precontrol_of:
- if ( left_type(p)==mp_endpoint ) mp_pair_value(mp, x_coord(p),y_coord(p));
- else mp_pair_value(mp, left_x(p),left_y(p));
- break;
-case postcontrol_of:
- if ( right_type(p)==mp_endpoint ) mp_pair_value(mp, x_coord(p),y_coord(p));
- else mp_pair_value(mp, right_x(p),right_y(p));
- break;
-} /* there are no other cases */
-
-@ @<Additional cases of binary operators@>=
-case arc_time_of:
- if ( mp->cur_type==mp_pair_type )
- mp_pair_to_path(mp);
- if ( (mp->cur_type==mp_path_type)&&(type(p)==mp_known) )
- mp_flush_cur_exp(mp, mp_get_arc_time(mp, mp->cur_exp,value(p)));
- else
- mp_bad_binary(mp, p,c);
- break;
-
-@ @<Additional cases of bin...@>=
-case intersect:
- if ( type(p)==mp_pair_type ) {
- q=mp_stash_cur_exp(mp); mp_unstash_cur_exp(mp, p);
- mp_pair_to_path(mp); p=mp_stash_cur_exp(mp); mp_unstash_cur_exp(mp, q);
- };
- if ( mp->cur_type==mp_pair_type ) mp_pair_to_path(mp);
- if ( (mp->cur_type==mp_path_type)&&(type(p)==mp_path_type) ) {
- mp_path_intersection(mp, value(p),mp->cur_exp);
- mp_pair_value(mp, mp->cur_t,mp->cur_tt);
- } else {
- mp_bad_binary(mp, p,intersect);
- }
- break;
-
-@ @<Additional cases of bin...@>=
-case in_font:
- if ( (mp->cur_type!=mp_string_type)||(type(p)!=mp_string_type))
- mp_bad_binary(mp, p,in_font);
- else { mp_do_infont(mp, p); binary_return; }
- break;
-
-@ Function |new_text_node| owns the reference count for its second argument
-(the text string) but not its first (the font name).
-
-@<Declare binary action...@>=
-void mp_do_infont (MP mp,pointer p) {
- pointer q;
- q=mp_get_node(mp, edge_header_size);
- mp_init_edges(mp, q);
- link(obj_tail(q))=mp_new_text_node(mp,str(mp->cur_exp),value(p));
- obj_tail(q)=link(obj_tail(q));
- mp_free_node(mp, p,value_node_size);
- mp_flush_cur_exp(mp, q);
- mp->cur_type=mp_picture_type;
-}
-
-@* \[40] Statements and commands.
-The chief executive of \MP\ is the |do_statement| routine, which
-contains the master switch that causes all the various pieces of \MP\
-to do their things, in the right order.
-
-In a sense, this is the grand climax of the program: It applies all the
-tools that we have worked so hard to construct. In another sense, this is
-the messiest part of the program: It necessarily refers to other pieces
-of code all over the place, so that a person can't fully understand what is
-going on without paging back and forth to be reminded of conventions that
-are defined elsewhere. We are now at the hub of the web.
-
-The structure of |do_statement| itself is quite simple. The first token
-of the statement is fetched using |get_x_next|. If it can be the first
-token of an expression, we look for an equation, an assignment, or a
-title. Otherwise we use a \&{case} construction to branch at high speed to
-the appropriate routine for various and sundry other types of commands,
-each of which has an ``action procedure'' that does the necessary work.
-
-The program uses the fact that
-$$\hbox{|min_primary_command=max_statement_command=type_name|}$$
-to interpret a statement that starts with, e.g., `\&{string}',
-as a type declaration rather than a boolean expression.
-
-@c void mp_do_statement (MP mp) { /* governs \MP's activities */
- mp->cur_type=mp_vacuous; mp_get_x_next(mp);
- if ( mp->cur_cmd>max_primary_command ) {
- @<Worry about bad statement@>;
- } else if ( mp->cur_cmd>max_statement_command ) {
- @<Do an equation, assignment, title, or
- `$\langle\,$expression$\,\rangle\,$\&{endgroup}'@>;
- } else {
- @<Do a statement that doesn't begin with an expression@>;
- }
- if ( mp->cur_cmd<semicolon )
- @<Flush unparsable junk that was found after the statement@>;
- mp->error_count=0;
-}
-
-@ @<Declarations@>=
-@<Declare action procedures for use by |do_statement|@>
-
-@ The only command codes |>max_primary_command| that can be present
-at the beginning of a statement are |semicolon| and higher; these
-occur when the statement is null.
-
-@<Worry about bad statement@>=
-{
- if ( mp->cur_cmd<semicolon ) {
- print_err("A statement can't begin with `");
-@.A statement can't begin with x@>
- mp_print_cmd_mod(mp, mp->cur_cmd,mp->cur_mod); mp_print_char(mp, '\'');
- help5("I was looking for the beginning of a new statement.")
- ("If you just proceed without changing anything, I'll ignore")
- ("everything up to the next `;'. Please insert a semicolon")
- ("now in front of anything that you don't want me to delete.")
- ("(See Chapter 27 of The METAFONTbook for an example.)");
-@:METAFONTbook}{\sl The {\logos METAFONT\/}book@>
- mp_back_error(mp); mp_get_x_next(mp);
- }
-}
-
-@ The help message printed here says that everything is flushed up to
-a semicolon, but actually the commands |end_group| and |stop| will
-also terminate a statement.
-
-@<Flush unparsable junk that was found after the statement@>=
-{
- print_err("Extra tokens will be flushed");
-@.Extra tokens will be flushed@>
- help6("I've just read as much of that statement as I could fathom,")
- ("so a semicolon should have been next. It's very puzzling...")
- ("but I'll try to get myself back together, by ignoring")
- ("everything up to the next `;'. Please insert a semicolon")
- ("now in front of anything that you don't want me to delete.")
- ("(See Chapter 27 of The METAFONTbook for an example.)");
-@:METAFONTbook}{\sl The {\logos METAFONT\/}book@>
- mp_back_error(mp); mp->scanner_status=flushing;
- do {
- get_t_next;
- @<Decrease the string reference count...@>;
- } while (! end_of_statement); /* |cur_cmd=semicolon|, |end_group|, or |stop| */
- mp->scanner_status=normal;
-}
-
-@ If |do_statement| ends with |cur_cmd=end_group|, we should have
-|cur_type=mp_vacuous| unless the statement was simply an expression;
-in the latter case, |cur_type| and |cur_exp| should represent that
-expression.
-
-@<Do a statement that doesn't...@>=
-{
- if ( mp->internal[mp_tracing_commands]>0 )
- show_cur_cmd_mod;
- switch (mp->cur_cmd ) {
- case type_name:mp_do_type_declaration(mp); break;
- case macro_def:
- if ( mp->cur_mod>var_def ) mp_make_op_def(mp);
- else if ( mp->cur_mod>end_def ) mp_scan_def(mp);
- break;
- @<Cases of |do_statement| that invoke particular commands@>;
- } /* there are no other cases */
- mp->cur_type=mp_vacuous;
-}
-
-@ The most important statements begin with expressions.
-
-@<Do an equation, assignment, title, or...@>=
-{
- mp->var_flag=assignment; mp_scan_expression(mp);
- if ( mp->cur_cmd<end_group ) {
- if ( mp->cur_cmd==equals ) mp_do_equation(mp);
- else if ( mp->cur_cmd==assignment ) mp_do_assignment(mp);
- else if ( mp->cur_type==mp_string_type ) {@<Do a title@> ; }
- else if ( mp->cur_type!=mp_vacuous ){
- exp_err("Isolated expression");
-@.Isolated expression@>
- help3("I couldn't find an `=' or `:=' after the")
- ("expression that is shown above this error message,")
- ("so I guess I'll just ignore it and carry on.");
- mp_put_get_error(mp);
- }
- mp_flush_cur_exp(mp, 0); mp->cur_type=mp_vacuous;
- }
-}
-
-@ @<Do a title@>=
-{
- if ( mp->internal[mp_tracing_titles]>0 ) {
- mp_print_nl(mp, ""); mp_print_str(mp, mp->cur_exp); update_terminal;
- }
-}
-
-@ Equations and assignments are performed by the pair of mutually recursive
-@^recursion@>
-routines |do_equation| and |do_assignment|. These routines are called when
-|cur_cmd=equals| and when |cur_cmd=assignment|, respectively; the left-hand
-side is in |cur_type| and |cur_exp|, while the right-hand side is yet
-to be scanned. After the routines are finished, |cur_type| and |cur_exp|
-will be equal to the right-hand side (which will normally be equal
-to the left-hand side).
-
-@<Declare action procedures for use by |do_statement|@>=
-@<Declare the procedure called |try_eq|@>
-@<Declare the procedure called |make_eq|@>
-void mp_do_equation (MP mp) ;
-
-@ @c
-void mp_do_equation (MP mp) {
- pointer lhs; /* capsule for the left-hand side */
- pointer p; /* temporary register */
- lhs=mp_stash_cur_exp(mp); mp_get_x_next(mp);
- mp->var_flag=assignment; mp_scan_expression(mp);
- if ( mp->cur_cmd==equals ) mp_do_equation(mp);
- else if ( mp->cur_cmd==assignment ) mp_do_assignment(mp);
- if ( mp->internal[mp_tracing_commands]>two )
- @<Trace the current equation@>;
- if ( mp->cur_type==mp_unknown_path ) if ( type(lhs)==mp_pair_type ) {
- p=mp_stash_cur_exp(mp); mp_unstash_cur_exp(mp, lhs); lhs=p;
- }; /* in this case |make_eq| will change the pair to a path */
- mp_make_eq(mp, lhs); /* equate |lhs| to |(cur_type,cur_exp)| */
-}
-
-@ And |do_assignment| is similar to |do_equation|:
-
-@<Declarations@>=
-void mp_do_assignment (MP mp);
-
-@ @<Declare action procedures for use by |do_statement|@>=
-void mp_do_assignment (MP mp) ;
-
-@ @c
-void mp_do_assignment (MP mp) {
- pointer lhs; /* token list for the left-hand side */
- pointer p; /* where the left-hand value is stored */
- pointer q; /* temporary capsule for the right-hand value */
- if ( mp->cur_type!=mp_token_list ) {
- exp_err("Improper `:=' will be changed to `='");
-@.Improper `:='@>
- help2("I didn't find a variable name at the left of the `:=',")
- ("so I'm going to pretend that you said `=' instead.");
- mp_error(mp); mp_do_equation(mp);
- } else {
- lhs=mp->cur_exp; mp->cur_type=mp_vacuous;
- mp_get_x_next(mp); mp->var_flag=assignment; mp_scan_expression(mp);
- if ( mp->cur_cmd==equals ) mp_do_equation(mp);
- else if ( mp->cur_cmd==assignment ) mp_do_assignment(mp);
- if ( mp->internal[mp_tracing_commands]>two )
- @<Trace the current assignment@>;
- if ( info(lhs)>hash_end ) {
- @<Assign the current expression to an internal variable@>;
- } else {
- @<Assign the current expression to the variable |lhs|@>;
- }
- mp_flush_node_list(mp, lhs);
- }
-}
-
-@ @<Trace the current equation@>=
-{
- mp_begin_diagnostic(mp); mp_print_nl(mp, "{("); mp_print_exp(mp,lhs,0);
- mp_print(mp,")=("); mp_print_exp(mp,null,0);
- mp_print(mp,")}"); mp_end_diagnostic(mp, false);
-}
-
-@ @<Trace the current assignment@>=
-{
- mp_begin_diagnostic(mp); mp_print_nl(mp, "{");
- if ( info(lhs)>hash_end )
- mp_print(mp, mp->int_name[info(lhs)-(hash_end)]);
- else
- mp_show_token_list(mp, lhs,null,1000,0);
- mp_print(mp, ":="); mp_print_exp(mp, null,0);
- mp_print_char(mp, '}'); mp_end_diagnostic(mp, false);
-}
-
-@ @<Assign the current expression to an internal variable@>=
-if ( mp->cur_type==mp_known ) {
- mp->internal[info(lhs)-(hash_end)]=mp->cur_exp;
-} else {
- exp_err("Internal quantity `");
-@.Internal quantity...@>
- mp_print(mp, mp->int_name[info(lhs)-(hash_end)]);
- mp_print(mp, "' must receive a known value");
- help2("I can\'t set an internal quantity to anything but a known")
- ("numeric value, so I'll have to ignore this assignment.");
- mp_put_get_error(mp);
-}
-
-@ @<Assign the current expression to the variable |lhs|@>=
-{
- p=mp_find_variable(mp, lhs);
- if ( p!=null ) {
- q=mp_stash_cur_exp(mp); mp->cur_type=mp_und_type(mp, p);
- mp_recycle_value(mp, p);
- type(p)=mp->cur_type; value(p)=null; mp_make_exp_copy(mp, p);
- p=mp_stash_cur_exp(mp); mp_unstash_cur_exp(mp, q); mp_make_eq(mp, p);
- } else {
- mp_obliterated(mp, lhs); mp_put_get_error(mp);
- }
-}
-
-
-@ And now we get to the nitty-gritty. The |make_eq| procedure is given
-a pointer to a capsule that is to be equated to the current expression.
-
-@<Declare the procedure called |make_eq|@>=
-void mp_make_eq (MP mp,pointer lhs) ;
-
-
-@
-@c void mp_make_eq (MP mp,pointer lhs) {
- small_number t; /* type of the left-hand side */
- pointer p,q; /* pointers inside of big nodes */
- integer v=0; /* value of the left-hand side */
-RESTART:
- t=type(lhs);
- if ( t<=mp_pair_type ) v=value(lhs);
- switch (t) {
- @<For each type |t|, make an equation and |goto done| unless |cur_type|
- is incompatible with~|t|@>;
- } /* all cases have been listed */
- @<Announce that the equation cannot be performed@>;
-DONE:
- check_arith; mp_recycle_value(mp, lhs);
- mp_free_node(mp, lhs,value_node_size);
-}
-
-@ @<Announce that the equation cannot be performed@>=
-mp_disp_err(mp, lhs,"");
-exp_err("Equation cannot be performed (");
-@.Equation cannot be performed@>
-if ( type(lhs)<=mp_pair_type ) mp_print_type(mp, type(lhs));
-else mp_print(mp, "numeric");
-mp_print_char(mp, '=');
-if ( mp->cur_type<=mp_pair_type ) mp_print_type(mp, mp->cur_type);
-else mp_print(mp, "numeric");
-mp_print_char(mp, ')');
-help2("I'm sorry, but I don't know how to make such things equal.")
- ("(See the two expressions just above the error message.)");
-mp_put_get_error(mp)
-
-@ @<For each type |t|, make an equation and |goto done| unless...@>=
-case mp_boolean_type: case mp_string_type: case mp_pen_type:
-case mp_path_type: case mp_picture_type:
- if ( mp->cur_type==t+unknown_tag ) {
- mp_nonlinear_eq(mp, v,mp->cur_exp,false);
- mp_unstash_cur_exp(mp, mp->cur_exp); goto DONE;
- } else if ( mp->cur_type==t ) {
- @<Report redundant or inconsistent equation and |goto done|@>;
- }
- break;
-case unknown_types:
- if ( mp->cur_type==t-unknown_tag ) {
- mp_nonlinear_eq(mp, mp->cur_exp,lhs,true); goto DONE;
- } else if ( mp->cur_type==t ) {
- mp_ring_merge(mp, lhs,mp->cur_exp); goto DONE;
- } else if ( mp->cur_type==mp_pair_type ) {
- if ( t==mp_unknown_path ) {
- mp_pair_to_path(mp); goto RESTART;
- };
- }
- break;
-case mp_transform_type: case mp_color_type:
-case mp_cmykcolor_type: case mp_pair_type:
- if ( mp->cur_type==t ) {
- @<Do multiple equations and |goto done|@>;
- }
- break;
-case mp_known: case mp_dependent:
-case mp_proto_dependent: case mp_independent:
- if ( mp->cur_type>=mp_known ) {
- mp_try_eq(mp, lhs,null); goto DONE;
- };
- break;
-case mp_vacuous:
- break;
-
-@ @<Report redundant or inconsistent equation and |goto done|@>=
-{
- if ( mp->cur_type<=mp_string_type ) {
- if ( mp->cur_type==mp_string_type ) {
- if ( mp_str_vs_str(mp, v,mp->cur_exp)!=0 ) {
- goto NOT_FOUND;
- }
- } else if ( v!=mp->cur_exp ) {
- goto NOT_FOUND;
- }
- @<Exclaim about a redundant equation@>; goto DONE;
- }
- print_err("Redundant or inconsistent equation");
-@.Redundant or inconsistent equation@>
- help2("An equation between already-known quantities can't help.")
- ("But don't worry; continue and I'll just ignore it.");
- mp_put_get_error(mp); goto DONE;
-NOT_FOUND:
- print_err("Inconsistent equation");
-@.Inconsistent equation@>
- help2("The equation I just read contradicts what was said before.")
- ("But don't worry; continue and I'll just ignore it.");
- mp_put_get_error(mp); goto DONE;
-}
-
-@ @<Do multiple equations and |goto done|@>=
-{
- p=v+mp->big_node_size[t];
- q=value(mp->cur_exp)+mp->big_node_size[t];
- do {
- p=p-2; q=q-2; mp_try_eq(mp, p,q);
- } while (p!=v);
- goto DONE;
-}
-
-@ The first argument to |try_eq| is the location of a value node
-in a capsule that will soon be recycled. The second argument is
-either a location within a pair or transform node pointed to by
-|cur_exp|, or it is |null| (which means that |cur_exp| itself
-serves as the second argument). The idea is to leave |cur_exp| unchanged,
-but to equate the two operands.
-
-@<Declare the procedure called |try_eq|@>=
-void mp_try_eq (MP mp,pointer l, pointer r) ;
-
-@
-@c void mp_try_eq (MP mp,pointer l, pointer r) {
- pointer p; /* dependency list for right operand minus left operand */
- int t; /* the type of list |p| */
- pointer q; /* the constant term of |p| is here */
- pointer pp; /* dependency list for right operand */
- int tt; /* the type of list |pp| */
- boolean copied; /* have we copied a list that ought to be recycled? */
- @<Remove the left operand from its container, negate it, and
- put it into dependency list~|p| with constant term~|q|@>;
- @<Add the right operand to list |p|@>;
- if ( info(p)==null ) {
- @<Deal with redundant or inconsistent equation@>;
- } else {
- mp_linear_eq(mp, p,t);
- if ( r==null ) if ( mp->cur_type!=mp_known ) {
- if ( type(mp->cur_exp)==mp_known ) {
- pp=mp->cur_exp; mp->cur_exp=value(mp->cur_exp); mp->cur_type=mp_known;
- mp_free_node(mp, pp,value_node_size);
- }
- }
- }
-}
-
-@ @<Remove the left operand from its container, negate it, and...@>=
-t=type(l);
-if ( t==mp_known ) {
- t=mp_dependent; p=mp_const_dependency(mp, -value(l)); q=p;
-} else if ( t==mp_independent ) {
- t=mp_dependent; p=mp_single_dependency(mp, l); negate(value(p));
- q=mp->dep_final;
-} else {
- p=dep_list(l); q=p;
- while (1) {
- negate(value(q));
- if ( info(q)==null ) break;
- q=link(q);
- }
- link(prev_dep(l))=link(q); prev_dep(link(q))=prev_dep(l);
- type(l)=mp_known;
-}
-
-@ @<Deal with redundant or inconsistent equation@>=
-{
- if ( abs(value(p))>64 ) { /* off by .001 or more */
- print_err("Inconsistent equation");
-@.Inconsistent equation@>
- mp_print(mp, " (off by "); mp_print_scaled(mp, value(p));
- mp_print_char(mp, ')');
- help2("The equation I just read contradicts what was said before.")
- ("But don't worry; continue and I'll just ignore it.");
- mp_put_get_error(mp);
- } else if ( r==null ) {
- @<Exclaim about a redundant equation@>;
- }
- mp_free_node(mp, p,dep_node_size);
-}
-
-@ @<Add the right operand to list |p|@>=
-if ( r==null ) {
- if ( mp->cur_type==mp_known ) {
- value(q)=value(q)+mp->cur_exp; goto DONE1;
- } else {
- tt=mp->cur_type;
- if ( tt==mp_independent ) pp=mp_single_dependency(mp, mp->cur_exp);
- else pp=dep_list(mp->cur_exp);
- }
-} else {
- if ( type(r)==mp_known ) {
- value(q)=value(q)+value(r); goto DONE1;
- } else {
- tt=type(r);
- if ( tt==mp_independent ) pp=mp_single_dependency(mp, r);
- else pp=dep_list(r);
- }
-}
-if ( tt!=mp_independent ) copied=false;
-else { copied=true; tt=mp_dependent; };
-@<Add dependency list |pp| of type |tt| to dependency list~|p| of type~|t|@>;
-if ( copied ) mp_flush_node_list(mp, pp);
-DONE1:
-
-@ @<Add dependency list |pp| of type |tt| to dependency list~|p| of type~|t|@>=
-mp->watch_coefs=false;
-if ( t==tt ) {
- p=mp_p_plus_q(mp, p,pp,t);
-} else if ( t==mp_proto_dependent ) {
- p=mp_p_plus_fq(mp, p,unity,pp,mp_proto_dependent,mp_dependent);
-} else {
- q=p;
- while ( info(q)!=null ) {
- value(q)=mp_round_fraction(mp, value(q)); q=link(q);
- }
- t=mp_proto_dependent; p=mp_p_plus_q(mp, p,pp,t);
-}
-mp->watch_coefs=true;
-
-@ Our next goal is to process type declarations. For this purpose it's
-convenient to have a procedure that scans a $\langle\,$declared
-variable$\,\rangle$ and returns the corresponding token list. After the
-following procedure has acted, the token after the declared variable
-will have been scanned, so it will appear in |cur_cmd|, |cur_mod|,
-and~|cur_sym|.
-
-@<Declare the function called |scan_declared_variable|@>=
-pointer mp_scan_declared_variable (MP mp) {
- pointer x; /* hash address of the variable's root */
- pointer h,t; /* head and tail of the token list to be returned */
- pointer l; /* hash address of left bracket */
- mp_get_symbol(mp); x=mp->cur_sym;
- if ( mp->cur_cmd!=tag_token ) mp_clear_symbol(mp, x,false);
- h=mp_get_avail(mp); info(h)=x; t=h;
- while (1) {
- mp_get_x_next(mp);
- if ( mp->cur_sym==0 ) break;
- if ( mp->cur_cmd!=tag_token ) if ( mp->cur_cmd!=internal_quantity) {
- if ( mp->cur_cmd==left_bracket ) {
- @<Descend past a collective subscript@>;
- } else {
- break;
- }
- }
- link(t)=mp_get_avail(mp); t=link(t); info(t)=mp->cur_sym;
- }
- if ( (eq_type(x)%outer_tag)!=tag_token ) mp_clear_symbol(mp, x,false);
- if ( equiv(x)==null ) mp_new_root(mp, x);
- return h;
-}
-
-@ If the subscript isn't collective, we don't accept it as part of the
-declared variable.
-
-@<Descend past a collective subscript@>=
-{
- l=mp->cur_sym; mp_get_x_next(mp);
- if ( mp->cur_cmd!=right_bracket ) {
- mp_back_input(mp); mp->cur_sym=l; mp->cur_cmd=left_bracket; break;
- } else {
- mp->cur_sym=collective_subscript;
- }
-}
-
-@ Type declarations are introduced by the following primitive operations.
-
-@<Put each...@>=
-mp_primitive(mp, "numeric",type_name,mp_numeric_type);
-@:numeric_}{\&{numeric} primitive@>
-mp_primitive(mp, "string",type_name,mp_string_type);
-@:string_}{\&{string} primitive@>
-mp_primitive(mp, "boolean",type_name,mp_boolean_type);
-@:boolean_}{\&{boolean} primitive@>
-mp_primitive(mp, "path",type_name,mp_path_type);
-@:path_}{\&{path} primitive@>
-mp_primitive(mp, "pen",type_name,mp_pen_type);
-@:pen_}{\&{pen} primitive@>
-mp_primitive(mp, "picture",type_name,mp_picture_type);
-@:picture_}{\&{picture} primitive@>
-mp_primitive(mp, "transform",type_name,mp_transform_type);
-@:transform_}{\&{transform} primitive@>
-mp_primitive(mp, "color",type_name,mp_color_type);
-@:color_}{\&{color} primitive@>
-mp_primitive(mp, "rgbcolor",type_name,mp_color_type);
-@:color_}{\&{rgbcolor} primitive@>
-mp_primitive(mp, "cmykcolor",type_name,mp_cmykcolor_type);
-@:color_}{\&{cmykcolor} primitive@>
-mp_primitive(mp, "pair",type_name,mp_pair_type);
-@:pair_}{\&{pair} primitive@>
-
-@ @<Cases of |print_cmd...@>=
-case type_name: mp_print_type(mp, m); break;
-
-@ Now we are ready to handle type declarations, assuming that a
-|type_name| has just been scanned.
-
-@<Declare action procedures for use by |do_statement|@>=
-void mp_do_type_declaration (MP mp) ;
-
-@ @c
-void mp_do_type_declaration (MP mp) {
- small_number t; /* the type being declared */
- pointer p; /* token list for a declared variable */
- pointer q; /* value node for the variable */
- if ( mp->cur_mod>=mp_transform_type )
- t=mp->cur_mod;
- else
- t=mp->cur_mod+unknown_tag;
- do {
- p=mp_scan_declared_variable(mp);
- mp_flush_variable(mp, equiv(info(p)),link(p),false);
- q=mp_find_variable(mp, p);
- if ( q!=null ) {
- type(q)=t; value(q)=null;
- } else {
- print_err("Declared variable conflicts with previous vardef");
-@.Declared variable conflicts...@>
- help2("You can't use, e.g., `numeric foo[]' after `vardef foo'.")
- ("Proceed, and I'll ignore the illegal redeclaration.");
- mp_put_get_error(mp);
- }
- mp_flush_list(mp, p);
- if ( mp->cur_cmd<comma ) {
- @<Flush spurious symbols after the declared variable@>;
- }
- } while (! end_of_statement);
-}
-
-@ @<Flush spurious symbols after the declared variable@>=
-{
- print_err("Illegal suffix of declared variable will be flushed");
-@.Illegal suffix...flushed@>
- help5("Variables in declarations must consist entirely of")
- ("names and collective subscripts, e.g., `x[]a'.")
- ("Are you trying to use a reserved word in a variable name?")
- ("I'm going to discard the junk I found here,")
- ("up to the next comma or the end of the declaration.");
- if ( mp->cur_cmd==numeric_token )
- mp->help_line[2]="Explicit subscripts like `x15a' aren't permitted.";
- mp_put_get_error(mp); mp->scanner_status=flushing;
- do {
- get_t_next;
- @<Decrease the string reference count...@>;
- } while (mp->cur_cmd<comma); /* either |end_of_statement| or |cur_cmd=comma| */
- mp->scanner_status=normal;
-}
-
-@ \MP's |main_control| procedure just calls |do_statement| repeatedly
-until coming to the end of the user's program.
-Each execution of |do_statement| concludes with
-|cur_cmd=semicolon|, |end_group|, or |stop|.
-
-@c void mp_main_control (MP mp) {
- do {
- mp_do_statement(mp);
- if ( mp->cur_cmd==end_group ) {
- print_err("Extra `endgroup'");
-@.Extra `endgroup'@>
- help2("I'm not currently working on a `begingroup',")
- ("so I had better not try to end anything.");
- mp_flush_error(mp, 0);
- }
- } while (mp->cur_cmd!=stop);
-}
-int __attribute__((noinline))
-mp_run (MP mp) {
- if (mp->history < mp_fatal_error_stop ) {
- @<Install and test the non-local jump buffer@>;
- mp_main_control(mp); /* come to life */
- mp_final_cleanup(mp); /* prepare for death */
- mp_close_files_and_terminate(mp);
- }
- return mp->history;
-}
-int __attribute__((noinline))
-mp_execute (MP mp) {
- if (mp->history < mp_fatal_error_stop ) {
- mp->history = mp_spotless;
- mp->file_offset = 0;
- mp->term_offset = 0;
- mp->tally = 0;
- @<Install and test the non-local jump buffer@>;
- if (mp->run_state==0) {
- mp->run_state = 1;
- } else {
- mp_input_ln(mp,mp->term_in);
- mp_firm_up_the_line(mp);
- mp->buffer[limit]='%';
- mp->first=limit+1;
- loc=start;
- }
- do {
- mp_do_statement(mp);
- } while (mp->cur_cmd!=stop);
- }
- return mp->history;
-}
-int __attribute__((noinline))
-mp_finish (MP mp) {
- if (mp->history < mp_fatal_error_stop ) {
- @<Install and test the non-local jump buffer@>;
- mp_final_cleanup(mp); /* prepare for death */
- mp_close_files_and_terminate(mp);
- }
- return mp->history;
-}
-const char * mp_mplib_version (MP mp) {
- (void)mp;
- return mplib_version;
-}
-const char * mp_metapost_version (MP mp) {
- (void)mp;
- return metapost_version;
-}
-
-@ @<Exported function headers@>=
-int mp_run (MP mp);
-int mp_execute (MP mp);
-int mp_finish (MP mp);
-const char * mp_mplib_version (MP mp);
-const char * mp_metapost_version (MP mp);
-
-@ @<Put each...@>=
-mp_primitive(mp, "end",stop,0);
-@:end_}{\&{end} primitive@>
-mp_primitive(mp, "dump",stop,1);
-@:dump_}{\&{dump} primitive@>
-
-@ @<Cases of |print_cmd...@>=
-case stop:
- if ( m==0 ) mp_print(mp, "end");
- else mp_print(mp, "dump");
- break;
-
-@* \[41] Commands.
-Let's turn now to statements that are classified as ``commands'' because
-of their imperative nature. We'll begin with simple ones, so that it
-will be clear how to hook command processing into the |do_statement| routine;
-then we'll tackle the tougher commands.
-
-Here's one of the simplest:
-
-@<Cases of |do_statement|...@>=
-case mp_random_seed: mp_do_random_seed(mp); break;
-
-@ @<Declare action procedures for use by |do_statement|@>=
-void mp_do_random_seed (MP mp) ;
-
-@ @c void mp_do_random_seed (MP mp) {
- mp_get_x_next(mp);
- if ( mp->cur_cmd!=assignment ) {
- mp_missing_err(mp, ":=");
-@.Missing `:='@>
- help1("Always say `randomseed:=<numeric expression>'.");
- mp_back_error(mp);
- };
- mp_get_x_next(mp); mp_scan_expression(mp);
- if ( mp->cur_type!=mp_known ) {
- exp_err("Unknown value will be ignored");
-@.Unknown value...ignored@>
- help2("Your expression was too random for me to handle,")
- ("so I won't change the random seed just now.");
- mp_put_get_flush_error(mp, 0);
- } else {
- @<Initialize the random seed to |cur_exp|@>;
- }
-}
-
-@ @<Initialize the random seed to |cur_exp|@>=
-{
- mp_init_randoms(mp, mp->cur_exp);
- if ( mp->selector>=log_only && mp->selector<write_file) {
- mp->old_setting=mp->selector; mp->selector=log_only;
- mp_print_nl(mp, "{randomseed:=");
- mp_print_scaled(mp, mp->cur_exp);
- mp_print_char(mp, '}');
- mp_print_nl(mp, ""); mp->selector=mp->old_setting;
- }
-}
-
-@ And here's another simple one (somewhat different in flavor):
-
-@<Cases of |do_statement|...@>=
-case mode_command:
- mp_print_ln(mp); mp->interaction=mp->cur_mod;
- @<Initialize the print |selector| based on |interaction|@>;
- if ( mp->log_opened ) mp->selector=mp->selector+2;
- mp_get_x_next(mp);
- break;
-
-@ @<Put each...@>=
-mp_primitive(mp, "batchmode",mode_command,mp_batch_mode);
-@:mp_batch_mode_}{\&{batchmode} primitive@>
-mp_primitive(mp, "nonstopmode",mode_command,mp_nonstop_mode);
-@:mp_nonstop_mode_}{\&{nonstopmode} primitive@>
-mp_primitive(mp, "scrollmode",mode_command,mp_scroll_mode);
-@:mp_scroll_mode_}{\&{scrollmode} primitive@>
-mp_primitive(mp, "errorstopmode",mode_command,mp_error_stop_mode);
-@:mp_error_stop_mode_}{\&{errorstopmode} primitive@>
-
-@ @<Cases of |print_cmd_mod|...@>=
-case mode_command:
- switch (m) {
- case mp_batch_mode: mp_print(mp, "batchmode"); break;
- case mp_nonstop_mode: mp_print(mp, "nonstopmode"); break;
- case mp_scroll_mode: mp_print(mp, "scrollmode"); break;
- default: mp_print(mp, "errorstopmode"); break;
- }
- break;
-
-@ The `\&{inner}' and `\&{outer}' commands are only slightly harder.
-
-@<Cases of |do_statement|...@>=
-case protection_command: mp_do_protection(mp); break;
-
-@ @<Put each...@>=
-mp_primitive(mp, "inner",protection_command,0);
-@:inner_}{\&{inner} primitive@>
-mp_primitive(mp, "outer",protection_command,1);
-@:outer_}{\&{outer} primitive@>
-
-@ @<Cases of |print_cmd...@>=
-case protection_command:
- if ( m==0 ) mp_print(mp, "inner");
- else mp_print(mp, "outer");
- break;
-
-@ @<Declare action procedures for use by |do_statement|@>=
-void mp_do_protection (MP mp) ;
-
-@ @c void mp_do_protection (MP mp) {
- int m; /* 0 to unprotect, 1 to protect */
- halfword t; /* the |eq_type| before we change it */
- m=mp->cur_mod;
- do {
- mp_get_symbol(mp); t=eq_type(mp->cur_sym);
- if ( m==0 ) {
- if ( t>=outer_tag )
- eq_type(mp->cur_sym)=t-outer_tag;
- } else if ( t<outer_tag ) {
- eq_type(mp->cur_sym)=t+outer_tag;
- }
- mp_get_x_next(mp);
- } while (mp->cur_cmd==comma);
-}
-
-@ \MP\ never defines the tokens `\.(' and `\.)' to be primitives, but
-plain \MP\ begins with the declaration `\&{delimiters} \.{()}'. Such a
-declaration assigns the command code |left_delimiter| to `\.{(}' and
-|right_delimiter| to `\.{)}'; the |equiv| of each delimiter is the
-hash address of its mate.
-
-@<Cases of |do_statement|...@>=
-case delimiters: mp_def_delims(mp); break;
-
-@ @<Declare action procedures for use by |do_statement|@>=
-void mp_def_delims (MP mp) ;
-
-@ @c void mp_def_delims (MP mp) {
- pointer l_delim,r_delim; /* the new delimiter pair */
- mp_get_clear_symbol(mp); l_delim=mp->cur_sym;
- mp_get_clear_symbol(mp); r_delim=mp->cur_sym;
- eq_type(l_delim)=left_delimiter; equiv(l_delim)=r_delim;
- eq_type(r_delim)=right_delimiter; equiv(r_delim)=l_delim;
- mp_get_x_next(mp);
-}
-
-@ Here is a procedure that is called when \MP\ has reached a point
-where some right delimiter is mandatory.
-
-@<Declare the procedure called |check_delimiter|@>=
-void mp_check_delimiter (MP mp,pointer l_delim, pointer r_delim) {
- if ( mp->cur_cmd==right_delimiter )
- if ( mp->cur_mod==l_delim )
- return;
- if ( mp->cur_sym!=r_delim ) {
- mp_missing_err(mp, str(text(r_delim)));
-@.Missing `)'@>
- help2("I found no right delimiter to match a left one. So I've")
- ("put one in, behind the scenes; this may fix the problem.");
- mp_back_error(mp);
- } else {
- print_err("The token `"); mp_print_text(r_delim);
-@.The token...delimiter@>
- mp_print(mp, "' is no longer a right delimiter");
- help3("Strange: This token has lost its former meaning!")
- ("I'll read it as a right delimiter this time;")
- ("but watch out, I'll probably miss it later.");
- mp_error(mp);
- }
-}
-
-@ The next four commands save or change the values associated with tokens.
-
-@<Cases of |do_statement|...@>=
-case save_command:
- do {
- mp_get_symbol(mp); mp_save_variable(mp, mp->cur_sym); mp_get_x_next(mp);
- } while (mp->cur_cmd==comma);
- break;
-case interim_command: mp_do_interim(mp); break;
-case let_command: mp_do_let(mp); break;
-case new_internal: mp_do_new_internal(mp); break;
-
-@ @<Declare action procedures for use by |do_statement|@>=
-void mp_do_statement (MP mp);
-void mp_do_interim (MP mp);
-
-@ @c void mp_do_interim (MP mp) {
- mp_get_x_next(mp);
- if ( mp->cur_cmd!=internal_quantity ) {
- print_err("The token `");
-@.The token...quantity@>
- if ( mp->cur_sym==0 ) mp_print(mp, "(%CAPSULE)");
- else mp_print_text(mp->cur_sym);
- mp_print(mp, "' isn't an internal quantity");
- help1("Something like `tracingonline' should follow `interim'.");
- mp_back_error(mp);
- } else {
- mp_save_internal(mp, mp->cur_mod); mp_back_input(mp);
- }
- mp_do_statement(mp);
-}
-
-@ The following procedure is careful not to undefine the left-hand symbol
-too soon, lest commands like `{\tt let x=x}' have a surprising effect.
-
-@<Declare action procedures for use by |do_statement|@>=
-void mp_do_let (MP mp) ;
-
-@ @c void mp_do_let (MP mp) {
- pointer l; /* hash location of the left-hand symbol */
- mp_get_symbol(mp); l=mp->cur_sym; mp_get_x_next(mp);
- if ( mp->cur_cmd!=equals ) if ( mp->cur_cmd!=assignment ) {
- mp_missing_err(mp, "=");
-@.Missing `='@>
- help3("You should have said `let symbol = something'.")
- ("But don't worry; I'll pretend that an equals sign")
- ("was present. The next token I read will be `something'.");
- mp_back_error(mp);
- }
- mp_get_symbol(mp);
- switch (mp->cur_cmd) {
- case defined_macro: case secondary_primary_macro:
- case tertiary_secondary_macro: case expression_tertiary_macro:
- add_mac_ref(mp->cur_mod);
- break;
- default:
- break;
- }
- mp_clear_symbol(mp, l,false); eq_type(l)=mp->cur_cmd;
- if ( mp->cur_cmd==tag_token ) equiv(l)=null;
- else equiv(l)=mp->cur_mod;
- mp_get_x_next(mp);
-}
-
-@ @<Declarations@>=
-void mp_grow_internals (MP mp, int l);
-void mp_do_new_internal (MP mp) ;
-
-@ @c
-void mp_grow_internals (MP mp, int l) {
- scaled *internal;
- char * *int_name;
- int k;
- if ( hash_end+l>max_halfword ) {
- mp_confusion(mp, "out of memory space"); /* can't be reached */
- }
- int_name = xmalloc ((l+1),sizeof(char *));
- internal = xmalloc ((l+1),sizeof(scaled));
- for (k=0;k<=l; k++ ) {
- if (k<=mp->max_internal) {
- internal[k]=mp->internal[k];
- int_name[k]=mp->int_name[k];
- } else {
- internal[k]=0;
- int_name[k]=NULL;
- }
- }
- xfree(mp->internal); xfree(mp->int_name);
- mp->int_name = int_name;
- mp->internal = internal;
- mp->max_internal = l;
-}
-
-
-void mp_do_new_internal (MP mp) {
- do {
- if ( mp->int_ptr==mp->max_internal ) {
- mp_grow_internals(mp, (mp->max_internal + (mp->max_internal>>2)));
- }
- mp_get_clear_symbol(mp); incr(mp->int_ptr);
- eq_type(mp->cur_sym)=internal_quantity;
- equiv(mp->cur_sym)=mp->int_ptr;
- if(mp->int_name[mp->int_ptr]!=NULL)
- xfree(mp->int_name[mp->int_ptr]);
- mp->int_name[mp->int_ptr]=str(text(mp->cur_sym));
- mp->internal[mp->int_ptr]=0;
- mp_get_x_next(mp);
- } while (mp->cur_cmd==comma);
-}
-
-@ @<Dealloc variables@>=
-for (k=0;k<=mp->max_internal;k++) {
- xfree(mp->int_name[k]);
-}
-xfree(mp->internal);
-xfree(mp->int_name);
-
-
-@ The various `\&{show}' commands are distinguished by modifier fields
-in the usual way.
-
-@d show_token_code 0 /* show the meaning of a single token */
-@d show_stats_code 1 /* show current memory and string usage */
-@d show_code 2 /* show a list of expressions */
-@d show_var_code 3 /* show a variable and its descendents */
-@d show_dependencies_code 4 /* show dependent variables in terms of independents */
-
-@<Put each...@>=
-mp_primitive(mp, "showtoken",show_command,show_token_code);
-@:show_token_}{\&{showtoken} primitive@>
-mp_primitive(mp, "showstats",show_command,show_stats_code);
-@:show_stats_}{\&{showstats} primitive@>
-mp_primitive(mp, "show",show_command,show_code);
-@:show_}{\&{show} primitive@>
-mp_primitive(mp, "showvariable",show_command,show_var_code);
-@:show_var_}{\&{showvariable} primitive@>
-mp_primitive(mp, "showdependencies",show_command,show_dependencies_code);
-@:show_dependencies_}{\&{showdependencies} primitive@>
-
-@ @<Cases of |print_cmd...@>=
-case show_command:
- switch (m) {
- case show_token_code:mp_print(mp, "showtoken"); break;
- case show_stats_code:mp_print(mp, "showstats"); break;
- case show_code:mp_print(mp, "show"); break;
- case show_var_code:mp_print(mp, "showvariable"); break;
- default: mp_print(mp, "showdependencies"); break;
- }
- break;
-
-@ @<Cases of |do_statement|...@>=
-case show_command:mp_do_show_whatever(mp); break;
-
-@ The value of |cur_mod| controls the |verbosity| in the |print_exp| routine:
-if it's |show_code|, complicated structures are abbreviated, otherwise
-they aren't.
-
-@<Declare action procedures for use by |do_statement|@>=
-void mp_do_show (MP mp) ;
-
-@ @c void mp_do_show (MP mp) {
- do {
- mp_get_x_next(mp); mp_scan_expression(mp);
- mp_print_nl(mp, ">> ");
-@.>>@>
- mp_print_exp(mp, null,2); mp_flush_cur_exp(mp, 0);
- } while (mp->cur_cmd==comma);
-}
-
-@ @<Declare action procedures for use by |do_statement|@>=
-void mp_disp_token (MP mp) ;
-
-@ @c void mp_disp_token (MP mp) {
- mp_print_nl(mp, "> ");
-@.>\relax@>
- if ( mp->cur_sym==0 ) {
- @<Show a numeric or string or capsule token@>;
- } else {
- mp_print_text(mp->cur_sym); mp_print_char(mp, '=');
- if ( eq_type(mp->cur_sym)>=outer_tag ) mp_print(mp, "(outer) ");
- mp_print_cmd_mod(mp, mp->cur_cmd,mp->cur_mod);
- if ( mp->cur_cmd==defined_macro ) {
- mp_print_ln(mp); mp_show_macro(mp, mp->cur_mod,null,100000);
- } /* this avoids recursion between |show_macro| and |print_cmd_mod| */
-@^recursion@>
- }
-}
-
-@ @<Show a numeric or string or capsule token@>=
-{
- if ( mp->cur_cmd==numeric_token ) {
- mp_print_scaled(mp, mp->cur_mod);
- } else if ( mp->cur_cmd==capsule_token ) {
- mp_print_capsule(mp,mp->cur_mod);
- } else {
- mp_print_char(mp, '"');
- mp_print_str(mp, mp->cur_mod); mp_print_char(mp, '"');
- delete_str_ref(mp->cur_mod);
- }
-}
-
-@ The following cases of |print_cmd_mod| might arise in connection
-with |disp_token|, although they don't necessarily correspond to
-primitive tokens.
-
-@<Cases of |print_cmd_...@>=
-case left_delimiter:
-case right_delimiter:
- if ( c==left_delimiter ) mp_print(mp, "left");
- else mp_print(mp, "right");
- mp_print(mp, " delimiter that matches ");
- mp_print_text(m);
- break;
-case tag_token:
- if ( m==null ) mp_print(mp, "tag");
- else mp_print(mp, "variable");
- break;
-case defined_macro:
- mp_print(mp, "macro:");
- break;
-case secondary_primary_macro:
-case tertiary_secondary_macro:
-case expression_tertiary_macro:
- mp_print_cmd_mod(mp, macro_def,c);
- mp_print(mp, "'d macro:");
- mp_print_ln(mp); mp_show_token_list(mp, link(link(m)),null,1000,0);
- break;
-case repeat_loop:
- mp_print(mp, "[repeat the loop]");
- break;
-case internal_quantity:
- mp_print(mp, mp->int_name[m]);
- break;
-
-@ @<Declare action procedures for use by |do_statement|@>=
-void mp_do_show_token (MP mp) ;
-
-@ @c void mp_do_show_token (MP mp) {
- do {
- get_t_next; mp_disp_token(mp);
- mp_get_x_next(mp);
- } while (mp->cur_cmd==comma);
-}
-
-@ @<Declare action procedures for use by |do_statement|@>=
-void mp_do_show_stats (MP mp) ;
-
-@ @c void mp_do_show_stats (MP mp) {
- mp_print_nl(mp, "Memory usage ");
-@.Memory usage...@>
- mp_print_int(mp, mp->var_used); mp_print_char(mp, '&'); mp_print_int(mp, mp->dyn_used);
- mp_print(mp, " ("); mp_print_int(mp, mp->hi_mem_min-mp->lo_mem_max-1);
- mp_print(mp, " still untouched)"); mp_print_ln(mp);
- mp_print_nl(mp, "String usage ");
- mp_print_int(mp, mp->strs_in_use-mp->init_str_use);
- mp_print_char(mp, '&'); mp_print_int(mp, mp->pool_in_use-mp->init_pool_ptr);
- mp_print(mp, " (");
- mp_print_int(mp, mp->max_strings-1-mp->strs_used_up); mp_print_char(mp, '&');
- mp_print_int(mp, mp->pool_size-mp->pool_ptr);
- mp_print(mp, " now untouched)"); mp_print_ln(mp);
- mp_get_x_next(mp);
-}
-
-@ Here's a recursive procedure that gives an abbreviated account
-of a variable, for use by |do_show_var|.
-
-@<Declare action procedures for use by |do_statement|@>=
-void mp_disp_var (MP mp,pointer p) ;
-
-@ @c void mp_disp_var (MP mp,pointer p) {
- pointer q; /* traverses attributes and subscripts */
- int n; /* amount of macro text to show */
- if ( type(p)==mp_structured ) {
- @<Descend the structure@>;
- } else if ( type(p)>=mp_unsuffixed_macro ) {
- @<Display a variable macro@>;
- } else if ( type(p)!=undefined ){
- mp_print_nl(mp, ""); mp_print_variable_name(mp, p);
- mp_print_char(mp, '=');
- mp_print_exp(mp, p,0);
- }
-}
-
-@ @<Descend the structure@>=
-{
- q=attr_head(p);
- do { mp_disp_var(mp, q); q=link(q); } while (q!=end_attr);
- q=subscr_head(p);
- while ( name_type(q)==mp_subscr ) {
- mp_disp_var(mp, q); q=link(q);
- }
-}
-
-@ @<Display a variable macro@>=
-{
- mp_print_nl(mp, ""); mp_print_variable_name(mp, p);
- if ( type(p)>mp_unsuffixed_macro )
- mp_print(mp, "@@#"); /* |suffixed_macro| */
- mp_print(mp, "=macro:");
- if ( (int)mp->file_offset>=mp->max_print_line-20 ) n=5;
- else n=mp->max_print_line-mp->file_offset-15;
- mp_show_macro(mp, value(p),null,n);
-}
-
-@ @<Declare action procedures for use by |do_statement|@>=
-void mp_do_show_var (MP mp) ;
-
-@ @c void mp_do_show_var (MP mp) {
- do {
- get_t_next;
- if ( mp->cur_sym>0 ) if ( mp->cur_sym<=hash_end )
- if ( mp->cur_cmd==tag_token ) if ( mp->cur_mod!=null ) {
- mp_disp_var(mp, mp->cur_mod); goto DONE;
- }
- mp_disp_token(mp);
- DONE:
- mp_get_x_next(mp);
- } while (mp->cur_cmd==comma);
-}
-
-@ @<Declare action procedures for use by |do_statement|@>=
-void mp_do_show_dependencies (MP mp) ;
-
-@ @c void mp_do_show_dependencies (MP mp) {
- pointer p; /* link that runs through all dependencies */
- p=link(dep_head);
- while ( p!=dep_head ) {
- if ( mp_interesting(mp, p) ) {
- mp_print_nl(mp, ""); mp_print_variable_name(mp, p);
- if ( type(p)==mp_dependent ) mp_print_char(mp, '=');
- else mp_print(mp, " = "); /* extra spaces imply proto-dependency */
- mp_print_dependency(mp, dep_list(p),type(p));
- }
- p=dep_list(p);
- while ( info(p)!=null ) p=link(p);
- p=link(p);
- }
- mp_get_x_next(mp);
-}
-
-@ Finally we are ready for the procedure that governs all of the
-show commands.
-
-@<Declare action procedures for use by |do_statement|@>=
-void mp_do_show_whatever (MP mp) ;
-
-@ @c void mp_do_show_whatever (MP mp) {
- if ( mp->interaction==mp_error_stop_mode ) wake_up_terminal;
- switch (mp->cur_mod) {
- case show_token_code:mp_do_show_token(mp); break;
- case show_stats_code:mp_do_show_stats(mp); break;
- case show_code:mp_do_show(mp); break;
- case show_var_code:mp_do_show_var(mp); break;
- case show_dependencies_code:mp_do_show_dependencies(mp); break;
- } /* there are no other cases */
- if ( mp->internal[mp_showstopping]>0 ){
- print_err("OK");
-@.OK@>
- if ( mp->interaction<mp_error_stop_mode ) {
- help0; decr(mp->error_count);
- } else {
- help1("This isn't an error message; I'm just showing something.");
- }
- if ( mp->cur_cmd==semicolon ) mp_error(mp);
- else mp_put_get_error(mp);
- }
-}
-
-@ The `\&{addto}' command needs the following additional primitives:
-
-@d double_path_code 0 /* command modifier for `\&{doublepath}' */
-@d contour_code 1 /* command modifier for `\&{contour}' */
-@d also_code 2 /* command modifier for `\&{also}' */
-
-@ Pre and postscripts need two new identifiers:
-
-@d with_pre_script 11
-@d with_post_script 13
-
-@<Put each...@>=
-mp_primitive(mp, "doublepath",thing_to_add,double_path_code);
-@:double_path_}{\&{doublepath} primitive@>
-mp_primitive(mp, "contour",thing_to_add,contour_code);
-@:contour_}{\&{contour} primitive@>
-mp_primitive(mp, "also",thing_to_add,also_code);
-@:also_}{\&{also} primitive@>
-mp_primitive(mp, "withpen",with_option,mp_pen_type);
-@:with_pen_}{\&{withpen} primitive@>
-mp_primitive(mp, "dashed",with_option,mp_picture_type);
-@:dashed_}{\&{dashed} primitive@>
-mp_primitive(mp, "withprescript",with_option,with_pre_script);
-@:with_pre_script_}{\&{withprescript} primitive@>
-mp_primitive(mp, "withpostscript",with_option,with_post_script);
-@:with_post_script_}{\&{withpostscript} primitive@>
-mp_primitive(mp, "withoutcolor",with_option,mp_no_model);
-@:with_color_}{\&{withoutcolor} primitive@>
-mp_primitive(mp, "withgreyscale",with_option,mp_grey_model);
-@:with_color_}{\&{withgreyscale} primitive@>
-mp_primitive(mp, "withcolor",with_option,mp_uninitialized_model);
-@:with_color_}{\&{withcolor} primitive@>
-/* \&{withrgbcolor} is an alias for \&{withcolor} */
-mp_primitive(mp, "withrgbcolor",with_option,mp_rgb_model);
-@:with_color_}{\&{withrgbcolor} primitive@>
-mp_primitive(mp, "withcmykcolor",with_option,mp_cmyk_model);
-@:with_color_}{\&{withcmykcolor} primitive@>
-
-@ @<Cases of |print_cmd...@>=
-case thing_to_add:
- if ( m==contour_code ) mp_print(mp, "contour");
- else if ( m==double_path_code ) mp_print(mp, "doublepath");
- else mp_print(mp, "also");
- break;
-case with_option:
- if ( m==mp_pen_type ) mp_print(mp, "withpen");
- else if ( m==with_pre_script ) mp_print(mp, "withprescript");
- else if ( m==with_post_script ) mp_print(mp, "withpostscript");
- else if ( m==mp_no_model ) mp_print(mp, "withoutcolor");
- else if ( m==mp_rgb_model ) mp_print(mp, "withrgbcolor");
- else if ( m==mp_uninitialized_model ) mp_print(mp, "withcolor");
- else if ( m==mp_cmyk_model ) mp_print(mp, "withcmykcolor");
- else if ( m==mp_grey_model ) mp_print(mp, "withgreyscale");
- else mp_print(mp, "dashed");
- break;
-
-@ The |scan_with_list| procedure parses a $\langle$with list$\rangle$ and
-updates the list of graphical objects starting at |p|. Each $\langle$with
-clause$\rangle$ updates all graphical objects whose |type| is compatible.
-Other objects are ignored.
-
-@<Declare action procedures for use by |do_statement|@>=
-void mp_scan_with_list (MP mp,pointer p) ;
-
-@ @c void mp_scan_with_list (MP mp,pointer p) {
- small_number t; /* |cur_mod| of the |with_option| (should match |cur_type|) */
- pointer q; /* for list manipulation */
- int old_setting; /* saved |selector| setting */
- pointer k; /* for finding the near-last item in a list */
- str_number s; /* for string cleanup after combining */
- pointer cp,pp,dp,ap,bp;
- /* objects being updated; |void| initially; |null| to suppress update */
- cp=mp_void; pp=mp_void; dp=mp_void; ap=mp_void; bp=mp_void;
- k=0;
- while ( mp->cur_cmd==with_option ){
- t=mp->cur_mod;
- mp_get_x_next(mp);
- if ( t!=mp_no_model ) mp_scan_expression(mp);
- if (((t==with_pre_script)&&(mp->cur_type!=mp_string_type))||
- ((t==with_post_script)&&(mp->cur_type!=mp_string_type))||
- ((t==mp_uninitialized_model)&&
- ((mp->cur_type!=mp_cmykcolor_type)&&(mp->cur_type!=mp_color_type)
- &&(mp->cur_type!=mp_known)&&(mp->cur_type!=mp_boolean_type)))||
- ((t==mp_cmyk_model)&&(mp->cur_type!=mp_cmykcolor_type))||
- ((t==mp_rgb_model)&&(mp->cur_type!=mp_color_type))||
- ((t==mp_grey_model)&&(mp->cur_type!=mp_known))||
- ((t==mp_pen_type)&&(mp->cur_type!=t))||
- ((t==mp_picture_type)&&(mp->cur_type!=t)) ) {
- @<Complain about improper type@>;
- } else if ( t==mp_uninitialized_model ) {
- if ( cp==mp_void ) @<Make |cp| a colored object in object list~|p|@>;
- if ( cp!=null )
- @<Transfer a color from the current expression to object~|cp|@>;
- mp_flush_cur_exp(mp, 0);
- } else if ( t==mp_rgb_model ) {
- if ( cp==mp_void ) @<Make |cp| a colored object in object list~|p|@>;
- if ( cp!=null )
- @<Transfer a rgbcolor from the current expression to object~|cp|@>;
- mp_flush_cur_exp(mp, 0);
- } else if ( t==mp_cmyk_model ) {
- if ( cp==mp_void ) @<Make |cp| a colored object in object list~|p|@>;
- if ( cp!=null )
- @<Transfer a cmykcolor from the current expression to object~|cp|@>;
- mp_flush_cur_exp(mp, 0);
- } else if ( t==mp_grey_model ) {
- if ( cp==mp_void ) @<Make |cp| a colored object in object list~|p|@>;
- if ( cp!=null )
- @<Transfer a greyscale from the current expression to object~|cp|@>;
- mp_flush_cur_exp(mp, 0);
- } else if ( t==mp_no_model ) {
- if ( cp==mp_void ) @<Make |cp| a colored object in object list~|p|@>;
- if ( cp!=null )
- @<Transfer a noncolor from the current expression to object~|cp|@>;
- } else if ( t==mp_pen_type ) {
- if ( pp==mp_void ) @<Make |pp| an object in list~|p| that needs a pen@>;
- if ( pp!=null ) {
- if ( pen_p(pp)!=null ) mp_toss_knot_list(mp, pen_p(pp));
- pen_p(pp)=mp->cur_exp; mp->cur_type=mp_vacuous;
- }
- } else if ( t==with_pre_script ) {
- if ( ap==mp_void )
- ap=p;
- while ( (ap!=null)&&(! has_color(ap)) )
- ap=link(ap);
- if ( ap!=null ) {
- if ( pre_script(ap)!=null ) { /* build a new,combined string */
- s=pre_script(ap);
- old_setting=mp->selector;
- mp->selector=new_string;
- str_room(length(pre_script(ap))+length(mp->cur_exp)+2);
- mp_print_str(mp, mp->cur_exp);
- append_char(13); /* a forced \ps\ newline */
- mp_print_str(mp, pre_script(ap));
- pre_script(ap)=mp_make_string(mp);
- delete_str_ref(s);
- mp->selector=old_setting;
- } else {
- pre_script(ap)=mp->cur_exp;
- }
- mp->cur_type=mp_vacuous;
- }
- } else if ( t==with_post_script ) {
- if ( bp==mp_void )
- k=p;
- bp=k;
- while ( link(k)!=null ) {
- k=link(k);
- if ( has_color(k) ) bp=k;
- }
- if ( bp!=null ) {
- if ( post_script(bp)!=null ) {
- s=post_script(bp);
- old_setting=mp->selector;
- mp->selector=new_string;
- str_room(length(post_script(bp))+length(mp->cur_exp)+2);
- mp_print_str(mp, post_script(bp));
- append_char(13); /* a forced \ps\ newline */
- mp_print_str(mp, mp->cur_exp);
- post_script(bp)=mp_make_string(mp);
- delete_str_ref(s);
- mp->selector=old_setting;
- } else {
- post_script(bp)=mp->cur_exp;
- }
- mp->cur_type=mp_vacuous;
- }
- } else {
- if ( dp==mp_void ) {
- @<Make |dp| a stroked node in list~|p|@>;
- }
- if ( dp!=null ) {
- if ( dash_p(dp)!=null ) delete_edge_ref(dash_p(dp));
- dash_p(dp)=mp_make_dashes(mp, mp->cur_exp);
- dash_scale(dp)=unity;
- mp->cur_type=mp_vacuous;
- }
- }
- }
- @<Copy the information from objects |cp|, |pp|, and |dp| into the rest
- of the list@>;
-}
-
-@ @<Complain about improper type@>=
-{ exp_err("Improper type");
-@.Improper type@>
-help2("Next time say `withpen <known pen expression>';")
- ("I'll ignore the bad `with' clause and look for another.");
-if ( t==with_pre_script )
- mp->help_line[1]="Next time say `withprescript <known string expression>';";
-else if ( t==with_post_script )
- mp->help_line[1]="Next time say `withpostscript <known string expression>';";
-else if ( t==mp_picture_type )
- mp->help_line[1]="Next time say `dashed <known picture expression>';";
-else if ( t==mp_uninitialized_model )
- mp->help_line[1]="Next time say `withcolor <known color expression>';";
-else if ( t==mp_rgb_model )
- mp->help_line[1]="Next time say `withrgbcolor <known color expression>';";
-else if ( t==mp_cmyk_model )
- mp->help_line[1]="Next time say `withcmykcolor <known cmykcolor expression>';";
-else if ( t==mp_grey_model )
- mp->help_line[1]="Next time say `withgreyscale <known numeric expression>';";;
-mp_put_get_flush_error(mp, 0);
-}
-
-@ Forcing the color to be between |0| and |unity| here guarantees that no
-picture will ever contain a color outside the legal range for \ps\ graphics.
-
-@<Transfer a color from the current expression to object~|cp|@>=
-{ if ( mp->cur_type==mp_color_type )
- @<Transfer a rgbcolor from the current expression to object~|cp|@>
-else if ( mp->cur_type==mp_cmykcolor_type )
- @<Transfer a cmykcolor from the current expression to object~|cp|@>
-else if ( mp->cur_type==mp_known )
- @<Transfer a greyscale from the current expression to object~|cp|@>
-else if ( mp->cur_exp==false_code )
- @<Transfer a noncolor from the current expression to object~|cp|@>;
-}
-
-@ @<Transfer a rgbcolor from the current expression to object~|cp|@>=
-{ q=value(mp->cur_exp);
-cyan_val(cp)=0;
-magenta_val(cp)=0;
-yellow_val(cp)=0;
-black_val(cp)=0;
-red_val(cp)=value(red_part_loc(q));
-green_val(cp)=value(green_part_loc(q));
-blue_val(cp)=value(blue_part_loc(q));
-color_model(cp)=mp_rgb_model;
-if ( red_val(cp)<0 ) red_val(cp)=0;
-if ( green_val(cp)<0 ) green_val(cp)=0;
-if ( blue_val(cp)<0 ) blue_val(cp)=0;
-if ( red_val(cp)>unity ) red_val(cp)=unity;
-if ( green_val(cp)>unity ) green_val(cp)=unity;
-if ( blue_val(cp)>unity ) blue_val(cp)=unity;
-}
-
-@ @<Transfer a cmykcolor from the current expression to object~|cp|@>=
-{ q=value(mp->cur_exp);
-cyan_val(cp)=value(cyan_part_loc(q));
-magenta_val(cp)=value(magenta_part_loc(q));
-yellow_val(cp)=value(yellow_part_loc(q));
-black_val(cp)=value(black_part_loc(q));
-color_model(cp)=mp_cmyk_model;
-if ( cyan_val(cp)<0 ) cyan_val(cp)=0;
-if ( magenta_val(cp)<0 ) magenta_val(cp)=0;
-if ( yellow_val(cp)<0 ) yellow_val(cp)=0;
-if ( black_val(cp)<0 ) black_val(cp)=0;
-if ( cyan_val(cp)>unity ) cyan_val(cp)=unity;
-if ( magenta_val(cp)>unity ) magenta_val(cp)=unity;
-if ( yellow_val(cp)>unity ) yellow_val(cp)=unity;
-if ( black_val(cp)>unity ) black_val(cp)=unity;
-}
-
-@ @<Transfer a greyscale from the current expression to object~|cp|@>=
-{ q=mp->cur_exp;
-cyan_val(cp)=0;
-magenta_val(cp)=0;
-yellow_val(cp)=0;
-black_val(cp)=0;
-grey_val(cp)=q;
-color_model(cp)=mp_grey_model;
-if ( grey_val(cp)<0 ) grey_val(cp)=0;
-if ( grey_val(cp)>unity ) grey_val(cp)=unity;
-}
-
-@ @<Transfer a noncolor from the current expression to object~|cp|@>=
-{
-cyan_val(cp)=0;
-magenta_val(cp)=0;
-yellow_val(cp)=0;
-black_val(cp)=0;
-grey_val(cp)=0;
-color_model(cp)=mp_no_model;
-}
-
-@ @<Make |cp| a colored object in object list~|p|@>=
-{ cp=p;
- while ( cp!=null ){
- if ( has_color(cp) ) break;
- cp=link(cp);
- }
-}
-
-@ @<Make |pp| an object in list~|p| that needs a pen@>=
-{ pp=p;
- while ( pp!=null ) {
- if ( has_pen(pp) ) break;
- pp=link(pp);
- }
-}
-
-@ @<Make |dp| a stroked node in list~|p|@>=
-{ dp=p;
- while ( dp!=null ) {
- if ( type(dp)==mp_stroked_code ) break;
- dp=link(dp);
- }
-}
-
-@ @<Copy the information from objects |cp|, |pp|, and |dp| into...@>=
-@<Copy |cp|'s color into the colored objects linked to~|cp|@>;
-if ( pp>mp_void ) {
- @<Copy |pen_p(pp)| into stroked and filled nodes linked to |pp|@>;
-}
-if ( dp>mp_void ) {
- @<Make stroked nodes linked to |dp| refer to |dash_p(dp)|@>;
-}
-
-
-@ @<Copy |cp|'s color into the colored objects linked to~|cp|@>=
-{ q=link(cp);
- while ( q!=null ) {
- if ( has_color(q) ) {
- red_val(q)=red_val(cp);
- green_val(q)=green_val(cp);
- blue_val(q)=blue_val(cp);
- black_val(q)=black_val(cp);
- color_model(q)=color_model(cp);
- }
- q=link(q);
- }
-}
-
-@ @<Copy |pen_p(pp)| into stroked and filled nodes linked to |pp|@>=
-{ q=link(pp);
- while ( q!=null ) {
- if ( has_pen(q) ) {
- if ( pen_p(q)!=null ) mp_toss_knot_list(mp, pen_p(q));
- pen_p(q)=copy_pen(pen_p(pp));
- }
- q=link(q);
- }
-}
-
-@ @<Make stroked nodes linked to |dp| refer to |dash_p(dp)|@>=
-{ q=link(dp);
- while ( q!=null ) {
- if ( type(q)==mp_stroked_code ) {
- if ( dash_p(q)!=null ) delete_edge_ref(dash_p(q));
- dash_p(q)=dash_p(dp);
- dash_scale(q)=unity;
- if ( dash_p(q)!=null ) add_edge_ref(dash_p(q));
- }
- q=link(q);
- }
-}
-
-@ One of the things we need to do when we've parsed an \&{addto} or
-similar command is find the header of a supposed \&{picture} variable, given
-a token list for that variable. Since the edge structure is about to be
-updated, we use |private_edges| to make sure that this is possible.
-
-@<Declare action procedures for use by |do_statement|@>=
-pointer mp_find_edges_var (MP mp, pointer t) ;
-
-@ @c pointer mp_find_edges_var (MP mp, pointer t) {
- pointer p;
- pointer cur_edges; /* the return value */
- p=mp_find_variable(mp, t); cur_edges=null;
- if ( p==null ) {
- mp_obliterated(mp, t); mp_put_get_error(mp);
- } else if ( type(p)!=mp_picture_type ) {
- print_err("Variable "); mp_show_token_list(mp, t,null,1000,0);
-@.Variable x is the wrong type@>
- mp_print(mp, " is the wrong type (");
- mp_print_type(mp, type(p)); mp_print_char(mp, ')');
- help2("I was looking for a \"known\" picture variable.")
- ("So I'll not change anything just now.");
- mp_put_get_error(mp);
- } else {
- value(p)=mp_private_edges(mp, value(p));
- cur_edges=value(p);
- }
- mp_flush_node_list(mp, t);
- return cur_edges;
-}
-
-@ @<Cases of |do_statement|...@>=
-case add_to_command: mp_do_add_to(mp); break;
-case bounds_command:mp_do_bounds(mp); break;
-
-@ @<Put each...@>=
-mp_primitive(mp, "clip",bounds_command,mp_start_clip_code);
-@:clip_}{\&{clip} primitive@>
-mp_primitive(mp, "setbounds",bounds_command,mp_start_bounds_code);
-@:set_bounds_}{\&{setbounds} primitive@>
-
-@ @<Cases of |print_cmd...@>=
-case bounds_command:
- if ( m==mp_start_clip_code ) mp_print(mp, "clip");
- else mp_print(mp, "setbounds");
- break;
-
-@ The following function parses the beginning of an \&{addto} or \&{clip}
-command: it expects a variable name followed by a token with |cur_cmd=sep|
-and then an expression. The function returns the token list for the variable
-and stores the command modifier for the separator token in the global variable
-|last_add_type|. We must be careful because this variable might get overwritten
-any time we call |get_x_next|.
-
-@<Glob...@>=
-quarterword last_add_type;
- /* command modifier that identifies the last \&{addto} command */
-
-@ @<Declare action procedures for use by |do_statement|@>=
-pointer mp_start_draw_cmd (MP mp,quarterword sep) ;
-
-@ @c pointer mp_start_draw_cmd (MP mp,quarterword sep) {
- pointer lhv; /* variable to add to left */
- quarterword add_type=0; /* value to be returned in |last_add_type| */
- lhv=null;
- mp_get_x_next(mp); mp->var_flag=sep; mp_scan_primary(mp);
- if ( mp->cur_type!=mp_token_list ) {
- @<Abandon edges command because there's no variable@>;
- } else {
- lhv=mp->cur_exp; add_type=mp->cur_mod;
- mp->cur_type=mp_vacuous; mp_get_x_next(mp); mp_scan_expression(mp);
- }
- mp->last_add_type=add_type;
- return lhv;
-}
-
-@ @<Abandon edges command because there's no variable@>=
-{ exp_err("Not a suitable variable");
-@.Not a suitable variable@>
- help4("At this point I needed to see the name of a picture variable.")
- ("(Or perhaps you have indeed presented me with one; I might")
- ("have missed it, if it wasn't followed by the proper token.)")
- ("So I'll not change anything just now.");
- mp_put_get_flush_error(mp, 0);
-}
-
-@ Here is an example of how to use |start_draw_cmd|.
-
-@<Declare action procedures for use by |do_statement|@>=
-void mp_do_bounds (MP mp) ;
-
-@ @c void mp_do_bounds (MP mp) {
- pointer lhv,lhe; /* variable on left, the corresponding edge structure */
- pointer p; /* for list manipulation */
- integer m; /* initial value of |cur_mod| */
- m=mp->cur_mod;
- lhv=mp_start_draw_cmd(mp, to_token);
- if ( lhv!=null ) {
- lhe=mp_find_edges_var(mp, lhv);
- if ( lhe==null ) {
- mp_flush_cur_exp(mp, 0);
- } else if ( mp->cur_type!=mp_path_type ) {
- exp_err("Improper `clip'");
-@.Improper `addto'@>
- help2("This expression should have specified a known path.")
- ("So I'll not change anything just now.");
- mp_put_get_flush_error(mp, 0);
- } else if ( left_type(mp->cur_exp)==mp_endpoint ) {
- @<Complain about a non-cycle@>;
- } else {
- @<Make |cur_exp| into a \&{setbounds} or clipping path and add it to |lhe|@>;
- }
- }
-}
-
-@ @<Complain about a non-cycle@>=
-{ print_err("Not a cycle");
-@.Not a cycle@>
- help2("That contour should have ended with `..cycle' or `&cycle'.")
- ("So I'll not change anything just now."); mp_put_get_error(mp);
-}
-
-@ @<Make |cur_exp| into a \&{setbounds} or clipping path and add...@>=
-{ p=mp_new_bounds_node(mp, mp->cur_exp,m);
- link(p)=link(dummy_loc(lhe));
- link(dummy_loc(lhe))=p;
- if ( obj_tail(lhe)==dummy_loc(lhe) ) obj_tail(lhe)=p;
- p=mp_get_node(mp, mp->gr_object_size[stop_type(m)]);
- type(p)=stop_type(m);
- link(obj_tail(lhe))=p;
- obj_tail(lhe)=p;
- mp_init_bbox(mp, lhe);
-}
-
-@ The |do_add_to| procedure is a little like |do_clip| but there are a lot more
-cases to deal with.
-
-@<Declare action procedures for use by |do_statement|@>=
-void mp_do_add_to (MP mp) ;
-
-@ @c void mp_do_add_to (MP mp) {
- pointer lhv,lhe; /* variable on left, the corresponding edge structure */
- pointer p; /* the graphical object or list for |scan_with_list| to update */
- pointer e; /* an edge structure to be merged */
- quarterword add_type; /* |also_code|, |contour_code|, or |double_path_code| */
- lhv=mp_start_draw_cmd(mp, thing_to_add); add_type=mp->last_add_type;
- if ( lhv!=null ) {
- if ( add_type==also_code ) {
- @<Make sure the current expression is a suitable picture and set |e| and |p|
- appropriately@>;
- } else {
- @<Create a graphical object |p| based on |add_type| and the current
- expression@>;
- }
- mp_scan_with_list(mp, p);
- @<Use |p|, |e|, and |add_type| to augment |lhv| as requested@>;
- }
-}
-
-@ Setting |p:=null| causes the $\langle$with list$\rangle$ to be ignored;
-setting |e:=null| prevents anything from being added to |lhe|.
-
-@ @<Make sure the current expression is a suitable picture and set |e|...@>=
-{
- p=null; e=null;
- if ( mp->cur_type!=mp_picture_type ) {
- exp_err("Improper `addto'");
-@.Improper `addto'@>
- help2("This expression should have specified a known picture.")
- ("So I'll not change anything just now."); mp_put_get_flush_error(mp, 0);
- } else {
- e=mp_private_edges(mp, mp->cur_exp); mp->cur_type=mp_vacuous;
- p=link(dummy_loc(e));
- }
-}
-
-@ In this case |add_type<>also_code| so setting |p:=null| suppresses future
-attempts to add to the edge structure.
-
-@<Create a graphical object |p| based on |add_type| and the current...@>=
-{ e=null; p=null;
- if ( mp->cur_type==mp_pair_type ) mp_pair_to_path(mp);
- if ( mp->cur_type!=mp_path_type ) {
- exp_err("Improper `addto'");
-@.Improper `addto'@>
- help2("This expression should have specified a known path.")
- ("So I'll not change anything just now.");
- mp_put_get_flush_error(mp, 0);
- } else if ( add_type==contour_code ) {
- if ( left_type(mp->cur_exp)==mp_endpoint ) {
- @<Complain about a non-cycle@>;
- } else {
- p=mp_new_fill_node(mp, mp->cur_exp);
- mp->cur_type=mp_vacuous;
- }
- } else {
- p=mp_new_stroked_node(mp, mp->cur_exp);
- mp->cur_type=mp_vacuous;
- }
-}
-
-@ @<Use |p|, |e|, and |add_type| to augment |lhv| as requested@>=
-lhe=mp_find_edges_var(mp, lhv);
-if ( lhe==null ) {
- if ( (e==null)&&(p!=null) ) e=mp_toss_gr_object(mp, p);
- if ( e!=null ) delete_edge_ref(e);
-} else if ( add_type==also_code ) {
- if ( e!=null ) {
- @<Merge |e| into |lhe| and delete |e|@>;
- } else {
- do_nothing;
- }
-} else if ( p!=null ) {
- link(obj_tail(lhe))=p;
- obj_tail(lhe)=p;
- if ( add_type==double_path_code )
- if ( pen_p(p)==null )
- pen_p(p)=mp_get_pen_circle(mp, 0);
-}
-
-@ @<Merge |e| into |lhe| and delete |e|@>=
-{ if ( link(dummy_loc(e))!=null ) {
- link(obj_tail(lhe))=link(dummy_loc(e));
- obj_tail(lhe)=obj_tail(e);
- obj_tail(e)=dummy_loc(e);
- link(dummy_loc(e))=null;
- mp_flush_dash_list(mp, lhe);
- }
- mp_toss_edges(mp, e);
-}
-
-@ @<Cases of |do_statement|...@>=
-case ship_out_command: mp_do_ship_out(mp); break;
-
-@ @<Declare action procedures for use by |do_statement|@>=
-@<Declare the function called |tfm_check|@>
-@<Declare the \ps\ output procedures@>
-void mp_do_ship_out (MP mp) ;
-
-@ @c void mp_do_ship_out (MP mp) {
- integer c; /* the character code */
- mp_get_x_next(mp); mp_scan_expression(mp);
- if ( mp->cur_type!=mp_picture_type ) {
- @<Complain that it's not a known picture@>;
- } else {
- c=mp_round_unscaled(mp, mp->internal[mp_char_code]) % 256;
- if ( c<0 ) c=c+256;
- @<Store the width information for character code~|c|@>;
- mp_ship_out(mp, mp->cur_exp);
- mp_flush_cur_exp(mp, 0);
- }
-}
-
-@ @<Complain that it's not a known picture@>=
-{
- exp_err("Not a known picture");
- help1("I can only output known pictures.");
- mp_put_get_flush_error(mp, 0);
-}
-
-@ The \&{everyjob} command simply assigns a nonzero value to the global variable
-|start_sym|.
-
-@<Cases of |do_statement|...@>=
-case every_job_command:
- mp_get_symbol(mp); mp->start_sym=mp->cur_sym; mp_get_x_next(mp);
- break;
-
-@ @<Glob...@>=
-halfword start_sym; /* a symbolic token to insert at beginning of job */
-
-@ @<Set init...@>=
-mp->start_sym=0;
-
-@ Finally, we have only the ``message'' commands remaining.
-
-@d message_code 0
-@d err_message_code 1
-@d err_help_code 2
-@d filename_template_code 3
-@d print_with_leading_zeroes(A) g = mp->pool_ptr;
- mp_print_int(mp, (A)); g = mp->pool_ptr-g;
- if ( f>g ) {
- mp->pool_ptr = mp->pool_ptr - g;
- while ( f>g ) {
- mp_print_char(mp, '0');
- decr(f);
- };
- mp_print_int(mp, (A));
- };
- f = 0
-
-@<Put each...@>=
-mp_primitive(mp, "message",message_command,message_code);
-@:message_}{\&{message} primitive@>
-mp_primitive(mp, "errmessage",message_command,err_message_code);
-@:err_message_}{\&{errmessage} primitive@>
-mp_primitive(mp, "errhelp",message_command,err_help_code);
-@:err_help_}{\&{errhelp} primitive@>
-mp_primitive(mp, "filenametemplate",message_command,filename_template_code);
-@:filename_template_}{\&{filenametemplate} primitive@>
-
-@ @<Cases of |print_cmd...@>=
-case message_command:
- if ( m<err_message_code ) mp_print(mp, "message");
- else if ( m==err_message_code ) mp_print(mp, "errmessage");
- else if ( m==filename_template_code ) mp_print(mp, "filenametemplate");
- else mp_print(mp, "errhelp");
- break;
-
-@ @<Cases of |do_statement|...@>=
-case message_command: mp_do_message(mp); break;
-
-@ @<Declare action procedures for use by |do_statement|@>=
-@<Declare a procedure called |no_string_err|@>
-void mp_do_message (MP mp) ;
-
-@
-@c void mp_do_message (MP mp) {
- int m; /* the type of message */
- m=mp->cur_mod; mp_get_x_next(mp); mp_scan_expression(mp);
- if ( mp->cur_type!=mp_string_type )
- mp_no_string_err(mp, "A message should be a known string expression.");
- else {
- switch (m) {
- case message_code:
- mp_print_nl(mp, ""); mp_print_str(mp, mp->cur_exp);
- break;
- case err_message_code:
- @<Print string |cur_exp| as an error message@>;
- break;
- case err_help_code:
- @<Save string |cur_exp| as the |err_help|@>;
- break;
- case filename_template_code:
- @<Save the filename template@>;
- break;
- } /* there are no other cases */
- }
- mp_flush_cur_exp(mp, 0);
-}
-
-@ @<Declare a procedure called |no_string_err|@>=
-void mp_no_string_err (MP mp, const char *s) {
- exp_err("Not a string");
-@.Not a string@>
- help1(s);
- mp_put_get_error(mp);
-}
-
-@ The global variable |err_help| is zero when the user has most recently
-given an empty help string, or if none has ever been given.
-
-@<Save string |cur_exp| as the |err_help|@>=
-{
- if ( mp->err_help!=0 ) delete_str_ref(mp->err_help);
- if ( length(mp->cur_exp)==0 ) mp->err_help=0;
- else { mp->err_help=mp->cur_exp; add_str_ref(mp->err_help); }
-}
-
-@ If \&{errmessage} occurs often in |mp_scroll_mode|, without user-defined
-\&{errhelp}, we don't want to give a long help message each time. So we
-give a verbose explanation only once.
-
-@<Glob...@>=
-boolean long_help_seen; /* has the long \.{\\errmessage} help been used? */
-
-@ @<Set init...@>=mp->long_help_seen=false;
-
-@ @<Print string |cur_exp| as an error message@>=
-{
- print_err(""); mp_print_str(mp, mp->cur_exp);
- if ( mp->err_help!=0 ) {
- mp->use_err_help=true;
- } else if ( mp->long_help_seen ) {
- help1("(That was another `errmessage'.)") ;
- } else {
- if ( mp->interaction<mp_error_stop_mode ) mp->long_help_seen=true;
- help4("This error message was generated by an `errmessage'")
- ("command, so I can\'t give any explicit help.")
- ("Pretend that you're Miss Marple: Examine all clues,")
-@^Marple, Jane@>
- ("and deduce the truth by inspired guesses.");
- }
- mp_put_get_error(mp); mp->use_err_help=false;
-}
-
-@ @<Cases of |do_statement|...@>=
-case write_command: mp_do_write(mp); break;
-
-@ @<Declare action procedures for use by |do_statement|@>=
-void mp_do_write (MP mp) ;
-
-@ @c void mp_do_write (MP mp) {
- str_number t; /* the line of text to be written */
- write_index n,n0; /* for searching |wr_fname| and |wr_file| arrays */
- int old_setting; /* for saving |selector| during output */
- mp_get_x_next(mp);
- mp_scan_expression(mp);
- if ( mp->cur_type!=mp_string_type ) {
- mp_no_string_err(mp, "The text to be written should be a known string expression");
- } else if ( mp->cur_cmd!=to_token ) {
- print_err("Missing `to' clause");
- help1("A write command should end with `to <filename>'");
- mp_put_get_error(mp);
- } else {
- t=mp->cur_exp; mp->cur_type=mp_vacuous;
- mp_get_x_next(mp);
- mp_scan_expression(mp);
- if ( mp->cur_type!=mp_string_type )
- mp_no_string_err(mp, "I can\'t write to that file name. It isn't a known string");
- else {
- @<Write |t| to the file named by |cur_exp|@>;
- }
- delete_str_ref(t);
- }
- mp_flush_cur_exp(mp, 0);
-}
-
-@ @<Write |t| to the file named by |cur_exp|@>=
-{
- @<Find |n| where |wr_fname[n]=cur_exp| and call |open_write_file| if
- |cur_exp| must be inserted@>;
- if ( mp_str_vs_str(mp, t,mp->eof_line)==0 ) {
- @<Record the end of file on |wr_file[n]|@>;
- } else {
- old_setting=mp->selector;
- mp->selector=n+write_file;
- mp_print_str(mp, t); mp_print_ln(mp);
- mp->selector = old_setting;
- }
-}
-
-@ @<Find |n| where |wr_fname[n]=cur_exp| and call |open_write_file| if...@>=
-{
- char *fn = str(mp->cur_exp);
- n=mp->write_files;
- n0=mp->write_files;
- while (mp_xstrcmp(fn,mp->wr_fname[n])!=0) {
- if ( n==0 ) { /* bottom reached */
- if ( n0==mp->write_files ) {
- if ( mp->write_files<mp->max_write_files ) {
- incr(mp->write_files);
- } else {
- void **wr_file;
- char **wr_fname;
- write_index l,k;
- l = mp->max_write_files + (mp->max_write_files>>2);
- wr_file = xmalloc((l+1),sizeof(void *));
- wr_fname = xmalloc((l+1),sizeof(char *));
- for (k=0;k<=l;k++) {
- if (k<=mp->max_write_files) {
- wr_file[k]=mp->wr_file[k];
- wr_fname[k]=mp->wr_fname[k];
- } else {
- wr_file[k]=0;
- wr_fname[k]=NULL;
- }
- }
- xfree(mp->wr_file); xfree(mp->wr_fname);
- mp->max_write_files = l;
- mp->wr_file = wr_file;
- mp->wr_fname = wr_fname;
- }
- }
- n=n0;
- mp_open_write_file(mp, fn ,n);
- } else {
- decr(n);
- if ( mp->wr_fname[n]==NULL ) n0=n;
- }
- }
-}
-
-@ @<Record the end of file on |wr_file[n]|@>=
-{ (mp->close_file)(mp,mp->wr_file[n]);
- xfree(mp->wr_fname[n]);
- if ( n==mp->write_files-1 ) mp->write_files=n;
-}
-
-
-@* \[42] Writing font metric data.
-\TeX\ gets its knowledge about fonts from font metric files, also called
-\.{TFM} files; the `\.T' in `\.{TFM}' stands for \TeX,
-but other programs know about them too. One of \MP's duties is to
-write \.{TFM} files so that the user's fonts can readily be
-applied to typesetting.
-@:TFM files}{\.{TFM} files@>
-@^font metric files@>
-
-The information in a \.{TFM} file appears in a sequence of 8-bit bytes.
-Since the number of bytes is always a multiple of~4, we could
-also regard the file as a sequence of 32-bit words, but \MP\ uses the
-byte interpretation. The format of \.{TFM} files was designed by
-Lyle Ramshaw in 1980. The intent is to convey a lot of different kinds
-@^Ramshaw, Lyle Harold@>
-of information in a compact but useful form.
-
-@<Glob...@>=
-void * tfm_file; /* the font metric output goes here */
-char * metric_file_name; /* full name of the font metric file */
-
-@ The first 24 bytes (6 words) of a \.{TFM} file contain twelve 16-bit
-integers that give the lengths of the various subsequent portions
-of the file. These twelve integers are, in order:
-$$\vbox{\halign{\hfil#&$\null=\null$#\hfil\cr
-|lf|&length of the entire file, in words;\cr
-|lh|&length of the header data, in words;\cr
-|bc|&smallest character code in the font;\cr
-|ec|&largest character code in the font;\cr
-|nw|&number of words in the width table;\cr
-|nh|&number of words in the height table;\cr
-|nd|&number of words in the depth table;\cr
-|ni|&number of words in the italic correction table;\cr
-|nl|&number of words in the lig/kern table;\cr
-|nk|&number of words in the kern table;\cr
-|ne|&number of words in the extensible character table;\cr
-|np|&number of font parameter words.\cr}}$$
-They are all nonnegative and less than $2^{15}$. We must have |bc-1<=ec<=255|,
-|ne<=256|, and
-$$\hbox{|lf=6+lh+(ec-bc+1)+nw+nh+nd+ni+nl+nk+ne+np|.}$$
-Note that a font may contain as many as 256 characters (if |bc=0| and |ec=255|),
-and as few as 0 characters (if |bc=ec+1|).
-
-Incidentally, when two or more 8-bit bytes are combined to form an integer of
-16 or more bits, the most significant bytes appear first in the file.
-This is called BigEndian order.
-@^BigEndian order@>
-
-@ The rest of the \.{TFM} file may be regarded as a sequence of ten data
-arrays.
-
-The most important data type used here is a |fix_word|, which is
-a 32-bit representation of a binary fraction. A |fix_word| is a signed
-quantity, with the two's complement of the entire word used to represent
-negation. Of the 32 bits in a |fix_word|, exactly 12 are to the left of the
-binary point; thus, the largest |fix_word| value is $2048-2^{-20}$, and
-the smallest is $-2048$. We will see below, however, that all but two of
-the |fix_word| values must lie between $-16$ and $+16$.
-
-@ The first data array is a block of header information, which contains
-general facts about the font. The header must contain at least two words,
-|header[0]| and |header[1]|, whose meaning is explained below. Additional
-header information of use to other software routines might also be
-included, and \MP\ will generate it if the \.{headerbyte} command occurs.
-For example, 16 more words of header information are in use at the Xerox
-Palo Alto Research Center; the first ten specify the character coding
-scheme used (e.g., `\.{XEROX TEXT}' or `\.{TEX MATHSY}'), the next five
-give the font family name (e.g., `\.{HELVETICA}' or `\.{CMSY}'), and the
-last gives the ``face byte.''
-
-\yskip\hang|header[0]| is a 32-bit check sum that \MP\ will copy into
-the \.{GF} output file. This helps ensure consistency between files,
-since \TeX\ records the check sums from the \.{TFM}'s it reads, and these
-should match the check sums on actual fonts that are used. The actual
-relation between this check sum and the rest of the \.{TFM} file is not
-important; the check sum is simply an identification number with the
-property that incompatible fonts almost always have distinct check sums.
-@^check sum@>
-
-\yskip\hang|header[1]| is a |fix_word| containing the design size of the
-font, in units of \TeX\ points. This number must be at least 1.0; it is
-fairly arbitrary, but usually the design size is 10.0 for a ``10 point''
-font, i.e., a font that was designed to look best at a 10-point size,
-whatever that really means. When a \TeX\ user asks for a font `\.{at}
-$\delta$ \.{pt}', the effect is to override the design size and replace it
-by $\delta$, and to multiply the $x$ and~$y$ coordinates of the points in
-the font image by a factor of $\delta$ divided by the design size. {\sl
-All other dimensions in the\/ \.{TFM} file are |fix_word|\kern-1pt\
-numbers in design-size units.} Thus, for example, the value of |param[6]|,
-which defines the \.{em} unit, is often the |fix_word| value $2^{20}=1.0$,
-since many fonts have a design size equal to one em. The other dimensions
-must be less than 16 design-size units in absolute value; thus,
-|header[1]| and |param[1]| are the only |fix_word| entries in the whole
-\.{TFM} file whose first byte might be something besides 0 or 255.
-@^design size@>
-
-@ Next comes the |char_info| array, which contains one |char_info_word|
-per character. Each word in this part of the file contains six fields
-packed into four bytes as follows.
-
-\yskip\hang first byte: |width_index| (8 bits)\par
-\hang second byte: |height_index| (4 bits) times 16, plus |depth_index|
- (4~bits)\par
-\hang third byte: |italic_index| (6 bits) times 4, plus |tag|
- (2~bits)\par
-\hang fourth byte: |remainder| (8 bits)\par
-\yskip\noindent
-The actual width of a character is \\{width}|[width_index]|, in design-size
-units; this is a device for compressing information, since many characters
-have the same width. Since it is quite common for many characters
-to have the same height, depth, or italic correction, the \.{TFM} format
-imposes a limit of 16 different heights, 16 different depths, and
-64 different italic corrections.
-
-Incidentally, the relation $\\{width}[0]=\\{height}[0]=\\{depth}[0]=
-\\{italic}[0]=0$ should always hold, so that an index of zero implies a
-value of zero. The |width_index| should never be zero unless the
-character does not exist in the font, since a character is valid if and
-only if it lies between |bc| and |ec| and has a nonzero |width_index|.
-
-@ The |tag| field in a |char_info_word| has four values that explain how to
-interpret the |remainder| field.
-
-\yskip\hang|tag=0| (|no_tag|) means that |remainder| is unused.\par
-\hang|tag=1| (|lig_tag|) means that this character has a ligature/kerning
-program starting at location |remainder| in the |lig_kern| array.\par
-\hang|tag=2| (|list_tag|) means that this character is part of a chain of
-characters of ascending sizes, and not the largest in the chain. The
-|remainder| field gives the character code of the next larger character.\par
-\hang|tag=3| (|ext_tag|) means that this character code represents an
-extensible character, i.e., a character that is built up of smaller pieces
-so that it can be made arbitrarily large. The pieces are specified in
-|exten[remainder]|.\par
-\yskip\noindent
-Characters with |tag=2| and |tag=3| are treated as characters with |tag=0|
-unless they are used in special circumstances in math formulas. For example,
-\TeX's \.{\\sum} operation looks for a |list_tag|, and the \.{\\left}
-operation looks for both |list_tag| and |ext_tag|.
-
-@d no_tag 0 /* vanilla character */
-@d lig_tag 1 /* character has a ligature/kerning program */
-@d list_tag 2 /* character has a successor in a charlist */
-@d ext_tag 3 /* character is extensible */
-
-@ The |lig_kern| array contains instructions in a simple programming language
-that explains what to do for special letter pairs. Each word in this array is a
-|lig_kern_command| of four bytes.
-
-\yskip\hang first byte: |skip_byte|, indicates that this is the final program
- step if the byte is 128 or more, otherwise the next step is obtained by
- skipping this number of intervening steps.\par
-\hang second byte: |next_char|, ``if |next_char| follows the current character,
- then perform the operation and stop, otherwise continue.''\par
-\hang third byte: |op_byte|, indicates a ligature step if less than~128,
- a kern step otherwise.\par
-\hang fourth byte: |remainder|.\par
-\yskip\noindent
-In a kern step, an
-additional space equal to |kern[256*(op_byte-128)+remainder]| is inserted
-between the current character and |next_char|. This amount is
-often negative, so that the characters are brought closer together
-by kerning; but it might be positive.
-
-There are eight kinds of ligature steps, having |op_byte| codes $4a+2b+c$ where
-$0\le a\le b+c$ and $0\le b,c\le1$. The character whose code is
-|remainder| is inserted between the current character and |next_char|;
-then the current character is deleted if $b=0$, and |next_char| is
-deleted if $c=0$; then we pass over $a$~characters to reach the next
-current character (which may have a ligature/kerning program of its own).
-
-If the very first instruction of the |lig_kern| array has |skip_byte=255|,
-the |next_char| byte is the so-called right boundary character of this font;
-the value of |next_char| need not lie between |bc| and~|ec|.
-If the very last instruction of the |lig_kern| array has |skip_byte=255|,
-there is a special ligature/kerning program for a left boundary character,
-beginning at location |256*op_byte+remainder|.
-The interpretation is that \TeX\ puts implicit boundary characters
-before and after each consecutive string of characters from the same font.
-These implicit characters do not appear in the output, but they can affect
-ligatures and kerning.
-
-If the very first instruction of a character's |lig_kern| program has
-|skip_byte>128|, the program actually begins in location
-|256*op_byte+remainder|. This feature allows access to large |lig_kern|
-arrays, because the first instruction must otherwise
-appear in a location |<=255|.
-
-Any instruction with |skip_byte>128| in the |lig_kern| array must satisfy
-the condition
-$$\hbox{|256*op_byte+remainder<nl|.}$$
-If such an instruction is encountered during
-normal program execution, it denotes an unconditional halt; no ligature
-command is performed.
-
-@d stop_flag (128)
- /* value indicating `\.{STOP}' in a lig/kern program */
-@d kern_flag (128) /* op code for a kern step */
-@d skip_byte(A) mp->lig_kern[(A)].b0
-@d next_char(A) mp->lig_kern[(A)].b1
-@d op_byte(A) mp->lig_kern[(A)].b2
-@d rem_byte(A) mp->lig_kern[(A)].b3
-
-@ Extensible characters are specified by an |extensible_recipe|, which
-consists of four bytes called |top|, |mid|, |bot|, and |rep| (in this
-order). These bytes are the character codes of individual pieces used to
-build up a large symbol. If |top|, |mid|, or |bot| are zero, they are not
-present in the built-up result. For example, an extensible vertical line is
-like an extensible bracket, except that the top and bottom pieces are missing.
-
-Let $T$, $M$, $B$, and $R$ denote the respective pieces, or an empty box
-if the piece isn't present. Then the extensible characters have the form
-$TR^kMR^kB$ from top to bottom, for some |k>=0|, unless $M$ is absent;
-in the latter case we can have $TR^kB$ for both even and odd values of~|k|.
-The width of the extensible character is the width of $R$; and the
-height-plus-depth is the sum of the individual height-plus-depths of the
-components used, since the pieces are butted together in a vertical list.
-
-@d ext_top(A) mp->exten[(A)].b0 /* |top| piece in a recipe */
-@d ext_mid(A) mp->exten[(A)].b1 /* |mid| piece in a recipe */
-@d ext_bot(A) mp->exten[(A)].b2 /* |bot| piece in a recipe */
-@d ext_rep(A) mp->exten[(A)].b3 /* |rep| piece in a recipe */
-
-@ The final portion of a \.{TFM} file is the |param| array, which is another
-sequence of |fix_word| values.
-
-\yskip\hang|param[1]=slant| is the amount of italic slant, which is used
-to help position accents. For example, |slant=.25| means that when you go
-up one unit, you also go .25 units to the right. The |slant| is a pure
-number; it is the only |fix_word| other than the design size itself that is
-not scaled by the design size.
-@^design size@>
-
-\hang|param[2]=space| is the normal spacing between words in text.
-Note that character 040 in the font need not have anything to do with
-blank spaces.
-
-\hang|param[3]=space_stretch| is the amount of glue stretching between words.
-
-\hang|param[4]=space_shrink| is the amount of glue shrinking between words.
-
-\hang|param[5]=x_height| is the size of one ex in the font; it is also
-the height of letters for which accents don't have to be raised or lowered.
-
-\hang|param[6]=quad| is the size of one em in the font.
-
-\hang|param[7]=extra_space| is the amount added to |param[2]| at the
-ends of sentences.
-
-\yskip\noindent
-If fewer than seven parameters are present, \TeX\ sets the missing parameters
-to zero.
-
-@d slant_code 1
-@d space_code 2
-@d space_stretch_code 3
-@d space_shrink_code 4
-@d x_height_code 5
-@d quad_code 6
-@d extra_space_code 7
-
-@ So that is what \.{TFM} files hold. One of \MP's duties is to output such
-information, and it does this all at once at the end of a job.
-In order to prepare for such frenetic activity, it squirrels away the
-necessary facts in various arrays as information becomes available.
-
-Character dimensions (\&{charwd}, \&{charht}, \&{chardp}, and \&{charic})
-are stored respectively in |tfm_width|, |tfm_height|, |tfm_depth|, and
-|tfm_ital_corr|. Other information about a character (e.g., about
-its ligatures or successors) is accessible via the |char_tag| and
-|char_remainder| arrays. Other information about the font as a whole
-is kept in additional arrays called |header_byte|, |lig_kern|,
-|kern|, |exten|, and |param|.
-
-@d max_tfm_int 32510
-@d undefined_label max_tfm_int /* an undefined local label */
-
-@<Glob...@>=
-#define TFM_ITEMS 257
-eight_bits bc;
-eight_bits ec; /* smallest and largest character codes shipped out */
-scaled tfm_width[TFM_ITEMS]; /* \&{charwd} values */
-scaled tfm_height[TFM_ITEMS]; /* \&{charht} values */
-scaled tfm_depth[TFM_ITEMS]; /* \&{chardp} values */
-scaled tfm_ital_corr[TFM_ITEMS]; /* \&{charic} values */
-boolean char_exists[TFM_ITEMS]; /* has this code been shipped out? */
-int char_tag[TFM_ITEMS]; /* |remainder| category */
-int char_remainder[TFM_ITEMS]; /* the |remainder| byte */
-char *header_byte; /* bytes of the \.{TFM} header */
-int header_last; /* last initialized \.{TFM} header byte */
-int header_size; /* size of the \.{TFM} header */
-four_quarters *lig_kern; /* the ligature/kern table */
-short nl; /* the number of ligature/kern steps so far */
-scaled *kern; /* distinct kerning amounts */
-short nk; /* the number of distinct kerns so far */
-four_quarters exten[TFM_ITEMS]; /* extensible character recipes */
-short ne; /* the number of extensible characters so far */
-scaled *param; /* \&{fontinfo} parameters */
-short np; /* the largest \&{fontinfo} parameter specified so far */
-short nw;short nh;short nd;short ni; /* sizes of \.{TFM} subtables */
-short skip_table[TFM_ITEMS]; /* local label status */
-boolean lk_started; /* has there been a lig/kern step in this command yet? */
-integer bchar; /* right boundary character */
-short bch_label; /* left boundary starting location */
-short ll;short lll; /* registers used for lig/kern processing */
-short label_loc[257]; /* lig/kern starting addresses */
-eight_bits label_char[257]; /* characters for |label_loc| */
-short label_ptr; /* highest position occupied in |label_loc| */
-
-@ @<Allocate or initialize ...@>=
-mp->header_last = 0; mp->header_size = 128; /* just for init */
-mp->header_byte = xmalloc(mp->header_size, sizeof(char));
-mp->lig_kern = NULL; /* allocated when needed */
-mp->kern = NULL; /* allocated when needed */
-mp->param = NULL; /* allocated when needed */
-
-@ @<Dealloc variables@>=
-xfree(mp->header_byte);
-xfree(mp->lig_kern);
-xfree(mp->kern);
-xfree(mp->param);
-
-@ @<Set init...@>=
-for (k=0;k<= 255;k++ ) {
- mp->tfm_width[k]=0; mp->tfm_height[k]=0; mp->tfm_depth[k]=0; mp->tfm_ital_corr[k]=0;
- mp->char_exists[k]=false; mp->char_tag[k]=no_tag; mp->char_remainder[k]=0;
- mp->skip_table[k]=undefined_label;
-}
-memset(mp->header_byte,0,mp->header_size);
-mp->bc=255; mp->ec=0; mp->nl=0; mp->nk=0; mp->ne=0; mp->np=0;
-mp->internal[mp_boundary_char]=-unity;
-mp->bch_label=undefined_label;
-mp->label_loc[0]=-1; mp->label_ptr=0;
-
-@ @<Declarations@>=
-scaled mp_tfm_check (MP mp,small_number m) ;
-
-@ @<Declare the function called |tfm_check|@>=
-scaled mp_tfm_check (MP mp,small_number m) {
- if ( abs(mp->internal[m])>=fraction_half ) {
- print_err("Enormous "); mp_print(mp, mp->int_name[m]);
-@.Enormous charwd...@>
-@.Enormous chardp...@>
-@.Enormous charht...@>
-@.Enormous charic...@>
-@.Enormous designsize...@>
- mp_print(mp, " has been reduced");
- help1("Font metric dimensions must be less than 2048pt.");
- mp_put_get_error(mp);
- if ( mp->internal[m]>0 ) return (fraction_half-1);
- else return (1-fraction_half);
- } else {
- return mp->internal[m];
- }
-}
-
-@ @<Store the width information for character code~|c|@>=
-if ( c<mp->bc ) mp->bc=c;
-if ( c>mp->ec ) mp->ec=c;
-mp->char_exists[c]=true;
-mp->tfm_width[c]=mp_tfm_check(mp, mp_char_wd);
-mp->tfm_height[c]=mp_tfm_check(mp, mp_char_ht);
-mp->tfm_depth[c]=mp_tfm_check(mp, mp_char_dp);
-mp->tfm_ital_corr[c]=mp_tfm_check(mp, mp_char_ic)
-
-@ Now let's consider \MP's special \.{TFM}-oriented commands.
-
-@<Cases of |do_statement|...@>=
-case tfm_command: mp_do_tfm_command(mp); break;
-
-@ @d char_list_code 0
-@d lig_table_code 1
-@d extensible_code 2
-@d header_byte_code 3
-@d font_dimen_code 4
-
-@<Put each...@>=
-mp_primitive(mp, "charlist",tfm_command,char_list_code);
-@:char_list_}{\&{charlist} primitive@>
-mp_primitive(mp, "ligtable",tfm_command,lig_table_code);
-@:lig_table_}{\&{ligtable} primitive@>
-mp_primitive(mp, "extensible",tfm_command,extensible_code);
-@:extensible_}{\&{extensible} primitive@>
-mp_primitive(mp, "headerbyte",tfm_command,header_byte_code);
-@:header_byte_}{\&{headerbyte} primitive@>
-mp_primitive(mp, "fontdimen",tfm_command,font_dimen_code);
-@:font_dimen_}{\&{fontdimen} primitive@>
-
-@ @<Cases of |print_cmd...@>=
-case tfm_command:
- switch (m) {
- case char_list_code:mp_print(mp, "charlist"); break;
- case lig_table_code:mp_print(mp, "ligtable"); break;
- case extensible_code:mp_print(mp, "extensible"); break;
- case header_byte_code:mp_print(mp, "headerbyte"); break;
- default: mp_print(mp, "fontdimen"); break;
- }
- break;
-
-@ @<Declare action procedures for use by |do_statement|@>=
-eight_bits mp_get_code (MP mp) ;
-
-@ @c eight_bits mp_get_code (MP mp) { /* scans a character code value */
- integer c; /* the code value found */
- mp_get_x_next(mp); mp_scan_expression(mp);
- if ( mp->cur_type==mp_known ) {
- c=mp_round_unscaled(mp, mp->cur_exp);
- if ( c>=0 ) if ( c<256 ) return c;
- } else if ( mp->cur_type==mp_string_type ) {
- if ( length(mp->cur_exp)==1 ) {
- c=mp->str_pool[mp->str_start[mp->cur_exp]];
- return c;
- }
- }
- exp_err("Invalid code has been replaced by 0");
-@.Invalid code...@>
- help2("I was looking for a number between 0 and 255, or for a")
- ("string of length 1. Didn't find it; will use 0 instead.");
- mp_put_get_flush_error(mp, 0); c=0;
- return c;
-}
-
-@ @<Declare action procedures for use by |do_statement|@>=
-void mp_set_tag (MP mp,halfword c, small_number t, halfword r) ;
-
-@ @c void mp_set_tag (MP mp,halfword c, small_number t, halfword r) {
- if ( mp->char_tag[c]==no_tag ) {
- mp->char_tag[c]=t; mp->char_remainder[c]=r;
- if ( t==lig_tag ){
- incr(mp->label_ptr); mp->label_loc[mp->label_ptr]=r;
- mp->label_char[mp->label_ptr]=c;
- }
- } else {
- @<Complain about a character tag conflict@>;
- }
-}
-
-@ @<Complain about a character tag conflict@>=
-{
- print_err("Character ");
- if ( (c>' ')&&(c<127) ) mp_print_char(mp,c);
- else if ( c==256 ) mp_print(mp, "||");
- else { mp_print(mp, "code "); mp_print_int(mp, c); };
- mp_print(mp, " is already ");
-@.Character c is already...@>
- switch (mp->char_tag[c]) {
- case lig_tag: mp_print(mp, "in a ligtable"); break;
- case list_tag: mp_print(mp, "in a charlist"); break;
- case ext_tag: mp_print(mp, "extensible"); break;
- } /* there are no other cases */
- help2("It's not legal to label a character more than once.")
- ("So I'll not change anything just now.");
- mp_put_get_error(mp);
-}
-
-@ @<Declare action procedures for use by |do_statement|@>=
-void mp_do_tfm_command (MP mp) ;
-
-@ @c void mp_do_tfm_command (MP mp) {
- int c,cc; /* character codes */
- int k; /* index into the |kern| array */
- int j; /* index into |header_byte| or |param| */
- switch (mp->cur_mod) {
- case char_list_code:
- c=mp_get_code(mp);
- /* we will store a list of character successors */
- while ( mp->cur_cmd==colon ) {
- cc=mp_get_code(mp); mp_set_tag(mp, c,list_tag,cc); c=cc;
- };
- break;
- case lig_table_code:
- if (mp->lig_kern==NULL)
- mp->lig_kern = xmalloc((max_tfm_int+1),sizeof(four_quarters));
- if (mp->kern==NULL)
- mp->kern = xmalloc((max_tfm_int+1),sizeof(scaled));
- @<Store a list of ligature/kern steps@>;
- break;
- case extensible_code:
- @<Define an extensible recipe@>;
- break;
- case header_byte_code:
- case font_dimen_code:
- c=mp->cur_mod; mp_get_x_next(mp);
- mp_scan_expression(mp);
- if ( (mp->cur_type!=mp_known)||(mp->cur_exp<half_unit) ) {
- exp_err("Improper location");
-@.Improper location@>
- help2("I was looking for a known, positive number.")
- ("For safety's sake I'll ignore the present command.");
- mp_put_get_error(mp);
- } else {
- j=mp_round_unscaled(mp, mp->cur_exp);
- if ( mp->cur_cmd!=colon ) {
- mp_missing_err(mp, ":");
-@.Missing `:'@>
- help1("A colon should follow a headerbyte or fontinfo location.");
- mp_back_error(mp);
- }
- if ( c==header_byte_code ) {
- @<Store a list of header bytes@>;
- } else {
- if (mp->param==NULL)
- mp->param = xmalloc((max_tfm_int+1),sizeof(scaled));
- @<Store a list of font dimensions@>;
- }
- }
- break;
- } /* there are no other cases */
-}
-
-@ @<Store a list of ligature/kern steps@>=
-{
- mp->lk_started=false;
-CONTINUE:
- mp_get_x_next(mp);
- if ((mp->cur_cmd==skip_to)&& mp->lk_started )
- @<Process a |skip_to| command and |goto done|@>;
- if ( mp->cur_cmd==bchar_label ) { c=256; mp->cur_cmd=colon; }
- else { mp_back_input(mp); c=mp_get_code(mp); };
- if ((mp->cur_cmd==colon)||(mp->cur_cmd==double_colon)) {
- @<Record a label in a lig/kern subprogram and |goto continue|@>;
- }
- if ( mp->cur_cmd==lig_kern_token ) {
- @<Compile a ligature/kern command@>;
- } else {
- print_err("Illegal ligtable step");
-@.Illegal ligtable step@>
- help1("I was looking for `=:' or `kern' here.");
- mp_back_error(mp); next_char(mp->nl)=qi(0);
- op_byte(mp->nl)=qi(0); rem_byte(mp->nl)=qi(0);
- skip_byte(mp->nl)=stop_flag+1; /* this specifies an unconditional stop */
- }
- if ( mp->nl==max_tfm_int) mp_fatal_error(mp, "ligtable too large");
- incr(mp->nl);
- if ( mp->cur_cmd==comma ) goto CONTINUE;
- if ( skip_byte(mp->nl-1)<stop_flag ) skip_byte(mp->nl-1)=stop_flag;
-}
-DONE:
-
-@ @<Put each...@>=
-mp_primitive(mp, "=:",lig_kern_token,0);
-@:=:_}{\.{=:} primitive@>
-mp_primitive(mp, "=:|",lig_kern_token,1);
-@:=:/_}{\.{=:\char'174} primitive@>
-mp_primitive(mp, "=:|>",lig_kern_token,5);
-@:=:/>_}{\.{=:\char'174>} primitive@>
-mp_primitive(mp, "|=:",lig_kern_token,2);
-@:=:/_}{\.{\char'174=:} primitive@>
-mp_primitive(mp, "|=:>",lig_kern_token,6);
-@:=:/>_}{\.{\char'174=:>} primitive@>
-mp_primitive(mp, "|=:|",lig_kern_token,3);
-@:=:/_}{\.{\char'174=:\char'174} primitive@>
-mp_primitive(mp, "|=:|>",lig_kern_token,7);
-@:=:/>_}{\.{\char'174=:\char'174>} primitive@>
-mp_primitive(mp, "|=:|>>",lig_kern_token,11);
-@:=:/>_}{\.{\char'174=:\char'174>>} primitive@>
-mp_primitive(mp, "kern",lig_kern_token,128);
-@:kern_}{\&{kern} primitive@>
-
-@ @<Cases of |print_cmd...@>=
-case lig_kern_token:
- switch (m) {
- case 0:mp_print(mp, "=:"); break;
- case 1:mp_print(mp, "=:|"); break;
- case 2:mp_print(mp, "|=:"); break;
- case 3:mp_print(mp, "|=:|"); break;
- case 5:mp_print(mp, "=:|>"); break;
- case 6:mp_print(mp, "|=:>"); break;
- case 7:mp_print(mp, "|=:|>"); break;
- case 11:mp_print(mp, "|=:|>>"); break;
- default: mp_print(mp, "kern"); break;
- }
- break;
-
-@ Local labels are implemented by maintaining the |skip_table| array,
-where |skip_table[c]| is either |undefined_label| or the address of the
-most recent lig/kern instruction that skips to local label~|c|. In the
-latter case, the |skip_byte| in that instruction will (temporarily)
-be zero if there were no prior skips to this label, or it will be the
-distance to the prior skip.
-
-We may need to cancel skips that span more than 127 lig/kern steps.
-
-@d cancel_skips(A) mp->ll=(A);
- do {
- mp->lll=qo(skip_byte(mp->ll));
- skip_byte(mp->ll)=stop_flag; mp->ll=mp->ll-mp->lll;
- } while (mp->lll!=0)
-@d skip_error(A) { print_err("Too far to skip");
-@.Too far to skip@>
- help1("At most 127 lig/kern steps can separate skipto1 from 1::.");
- mp_error(mp); cancel_skips((A));
- }
-
-@<Process a |skip_to| command and |goto done|@>=
-{
- c=mp_get_code(mp);
- if ( mp->nl-mp->skip_table[c]>128 ) {
- skip_error(mp->skip_table[c]); mp->skip_table[c]=undefined_label;
- }
- if ( mp->skip_table[c]==undefined_label ) skip_byte(mp->nl-1)=qi(0);
- else skip_byte(mp->nl-1)=qi(mp->nl-mp->skip_table[c]-1);
- mp->skip_table[c]=mp->nl-1; goto DONE;
-}
-
-@ @<Record a label in a lig/kern subprogram and |goto continue|@>=
-{
- if ( mp->cur_cmd==colon ) {
- if ( c==256 ) mp->bch_label=mp->nl;
- else mp_set_tag(mp, c,lig_tag,mp->nl);
- } else if ( mp->skip_table[c]<undefined_label ) {
- mp->ll=mp->skip_table[c]; mp->skip_table[c]=undefined_label;
- do {
- mp->lll=qo(skip_byte(mp->ll));
- if ( mp->nl-mp->ll>128 ) {
- skip_error(mp->ll); goto CONTINUE;
- }
- skip_byte(mp->ll)=qi(mp->nl-mp->ll-1); mp->ll=mp->ll-mp->lll;
- } while (mp->lll!=0);
- }
- goto CONTINUE;
-}
-
-@ @<Compile a ligature/kern...@>=
-{
- next_char(mp->nl)=qi(c); skip_byte(mp->nl)=qi(0);
- if ( mp->cur_mod<128 ) { /* ligature op */
- op_byte(mp->nl)=qi(mp->cur_mod); rem_byte(mp->nl)=qi(mp_get_code(mp));
- } else {
- mp_get_x_next(mp); mp_scan_expression(mp);
- if ( mp->cur_type!=mp_known ) {
- exp_err("Improper kern");
-@.Improper kern@>
- help2("The amount of kern should be a known numeric value.")
- ("I'm zeroing this one. Proceed, with fingers crossed.");
- mp_put_get_flush_error(mp, 0);
- }
- mp->kern[mp->nk]=mp->cur_exp;
- k=0;
- while ( mp->kern[k]!=mp->cur_exp ) incr(k);
- if ( k==mp->nk ) {
- if ( mp->nk==max_tfm_int ) mp_fatal_error(mp, "too many TFM kerns");
- incr(mp->nk);
- }
- op_byte(mp->nl)=kern_flag+(k / 256);
- rem_byte(mp->nl)=qi((k % 256));
- }
- mp->lk_started=true;
-}
-
-@ @d missing_extensible_punctuation(A)
- { mp_missing_err(mp, (A));
-@.Missing `\char`\#'@>
- help1("I'm processing `extensible c: t,m,b,r'."); mp_back_error(mp);
- }
-
-@<Define an extensible recipe@>=
-{
- if ( mp->ne==256 ) mp_fatal_error(mp, "too many extensible recipies");
- c=mp_get_code(mp); mp_set_tag(mp, c,ext_tag,mp->ne);
- if ( mp->cur_cmd!=colon ) missing_extensible_punctuation(":");
- ext_top(mp->ne)=qi(mp_get_code(mp));
- if ( mp->cur_cmd!=comma ) missing_extensible_punctuation(",");
- ext_mid(mp->ne)=qi(mp_get_code(mp));
- if ( mp->cur_cmd!=comma ) missing_extensible_punctuation(",");
- ext_bot(mp->ne)=qi(mp_get_code(mp));
- if ( mp->cur_cmd!=comma ) missing_extensible_punctuation(",");
- ext_rep(mp->ne)=qi(mp_get_code(mp));
- incr(mp->ne);
-}
-
-@ The header could contain ASCII zeroes, so can't use |strdup|.
-
-@<Store a list of header bytes@>=
-do {
- if ( j>=mp->header_size ) {
- int l = mp->header_size + (mp->header_size >> 2);
- char *t = xmalloc(l,sizeof(char));
- memset(t,0,l);
- memcpy(t,mp->header_byte,mp->header_size);
- xfree (mp->header_byte);
- mp->header_byte = t;
- mp->header_size = l;
- }
- mp->header_byte[j]=mp_get_code(mp);
- incr(j); incr(mp->header_last);
-} while (mp->cur_cmd==comma)
-
-@ @<Store a list of font dimensions@>=
-do {
- if ( j>max_tfm_int ) mp_fatal_error(mp, "too many fontdimens");
- while ( j>mp->np ) { incr(mp->np); mp->param[mp->np]=0; };
- mp_get_x_next(mp); mp_scan_expression(mp);
- if ( mp->cur_type!=mp_known ){
- exp_err("Improper font parameter");
-@.Improper font parameter@>
- help1("I'm zeroing this one. Proceed, with fingers crossed.");
- mp_put_get_flush_error(mp, 0);
- }
- mp->param[j]=mp->cur_exp; incr(j);
-} while (mp->cur_cmd==comma)
-
-@ OK: We've stored all the data that is needed for the \.{TFM} file.
-All that remains is to output it in the correct format.
-
-An interesting problem needs to be solved in this connection, because
-the \.{TFM} format allows at most 256~widths, 16~heights, 16~depths,
-and 64~italic corrections. If the data has more distinct values than
-this, we want to meet the necessary restrictions by perturbing the
-given values as little as possible.
-
-\MP\ solves this problem in two steps. First the values of a given
-kind (widths, heights, depths, or italic corrections) are sorted;
-then the list of sorted values is perturbed, if necessary.
-
-The sorting operation is facilitated by having a special node of
-essentially infinite |value| at the end of the current list.
-
-@<Initialize table entries...@>=
-value(inf_val)=fraction_four;
-
-@ Straight linear insertion is good enough for sorting, since the lists
-are usually not terribly long. As we work on the data, the current list
-will start at |link(temp_head)| and end at |inf_val|; the nodes in this
-list will be in increasing order of their |value| fields.
-
-Given such a list, the |sort_in| function takes a value and returns a pointer
-to where that value can be found in the list. The value is inserted in
-the proper place, if necessary.
-
-At the time we need to do these operations, most of \MP's work has been
-completed, so we will have plenty of memory to play with. The value nodes
-that are allocated for sorting will never be returned to free storage.
-
-@d clear_the_list link(temp_head)=inf_val
-
-@c pointer mp_sort_in (MP mp,scaled v) {
- pointer p,q,r; /* list manipulation registers */
- p=temp_head;
- while (1) {
- q=link(p);
- if ( v<=value(q) ) break;
- p=q;
- }
- if ( v<value(q) ) {
- r=mp_get_node(mp, value_node_size); value(r)=v; link(r)=q; link(p)=r;
- }
- return link(p);
-}
-
-@ Now we come to the interesting part, where we reduce the list if necessary
-until it has the required size. The |min_cover| routine is basic to this
-process; it computes the minimum number~|m| such that the values of the
-current sorted list can be covered by |m|~intervals of width~|d|. It
-also sets the global value |perturbation| to the smallest value $d'>d$
-such that the covering found by this algorithm would be different.
-
-In particular, |min_cover(0)| returns the number of distinct values in the
-current list and sets |perturbation| to the minimum distance between
-adjacent values.
-
-@c integer mp_min_cover (MP mp,scaled d) {
- pointer p; /* runs through the current list */
- scaled l; /* the least element covered by the current interval */
- integer m; /* lower bound on the size of the minimum cover */
- m=0; p=link(temp_head); mp->perturbation=el_gordo;
- while ( p!=inf_val ){
- incr(m); l=value(p);
- do { p=link(p); } while (value(p)<=l+d);
- if ( value(p)-l<mp->perturbation )
- mp->perturbation=value(p)-l;
- }
- return m;
-}
-
-@ @<Glob...@>=
-scaled perturbation; /* quantity related to \.{TFM} rounding */
-integer excess; /* the list is this much too long */
-
-@ The smallest |d| such that a given list can be covered with |m| intervals
-is determined by the |threshold| routine, which is sort of an inverse
-to |min_cover|. The idea is to increase the interval size rapidly until
-finding the range, then to go sequentially until the exact borderline has
-been discovered.
-
-@c scaled mp_threshold (MP mp,integer m) {
- scaled d; /* lower bound on the smallest interval size */
- mp->excess=mp_min_cover(mp, 0)-m;
- if ( mp->excess<=0 ) {
- return 0;
- } else {
- do {
- d=mp->perturbation;
- } while (mp_min_cover(mp, d+d)>m);
- while ( mp_min_cover(mp, d)>m )
- d=mp->perturbation;
- return d;
- }
-}
-
-@ The |skimp| procedure reduces the current list to at most |m| entries,
-by changing values if necessary. It also sets |info(p):=k| if |value(p)|
-is the |k|th distinct value on the resulting list, and it sets
-|perturbation| to the maximum amount by which a |value| field has
-been changed. The size of the resulting list is returned as the
-value of |skimp|.
-
-@c integer mp_skimp (MP mp,integer m) {
- scaled d; /* the size of intervals being coalesced */
- pointer p,q,r; /* list manipulation registers */
- scaled l; /* the least value in the current interval */
- scaled v; /* a compromise value */
- d=mp_threshold(mp, m); mp->perturbation=0;
- q=temp_head; m=0; p=link(temp_head);
- while ( p!=inf_val ) {
- incr(m); l=value(p); info(p)=m;
- if ( value(link(p))<=l+d ) {
- @<Replace an interval of values by its midpoint@>;
- }
- q=p; p=link(p);
- }
- return m;
-}
-
-@ @<Replace an interval...@>=
-{
- do {
- p=link(p); info(p)=m;
- decr(mp->excess); if ( mp->excess==0 ) d=0;
- } while (value(link(p))<=l+d);
- v=l+halfp(value(p)-l);
- if ( value(p)-v>mp->perturbation )
- mp->perturbation=value(p)-v;
- r=q;
- do {
- r=link(r); value(r)=v;
- } while (r!=p);
- link(q)=p; /* remove duplicate values from the current list */
-}
-
-@ A warning message is issued whenever something is perturbed by
-more than 1/16\thinspace pt.
-
-@c void mp_tfm_warning (MP mp,small_number m) {
- mp_print_nl(mp, "(some ");
- mp_print(mp, mp->int_name[m]);
-@.some charwds...@>
-@.some chardps...@>
-@.some charhts...@>
-@.some charics...@>
- mp_print(mp, " values had to be adjusted by as much as ");
- mp_print_scaled(mp, mp->perturbation); mp_print(mp, "pt)");
-}
-
-@ Here's an example of how we use these routines.
-The width data needs to be perturbed only if there are 256 distinct
-widths, but \MP\ must check for this case even though it is
-highly unusual.
-
-An integer variable |k| will be defined when we use this code.
-The |dimen_head| array will contain pointers to the sorted
-lists of dimensions.
-
-@<Massage the \.{TFM} widths@>=
-clear_the_list;
-for (k=mp->bc;k<=mp->ec;k++) {
- if ( mp->char_exists[k] )
- mp->tfm_width[k]=mp_sort_in(mp, mp->tfm_width[k]);
-}
-mp->nw=mp_skimp(mp, 255)+1; mp->dimen_head[1]=link(temp_head);
-if ( mp->perturbation>=010000 ) mp_tfm_warning(mp, mp_char_wd)
-
-@ @<Glob...@>=
-pointer dimen_head[5]; /* lists of \.{TFM} dimensions */
-
-@ Heights, depths, and italic corrections are different from widths
-not only because their list length is more severely restricted, but
-also because zero values do not need to be put into the lists.
-
-@<Massage the \.{TFM} heights, depths, and italic corrections@>=
-clear_the_list;
-for (k=mp->bc;k<=mp->ec;k++) {
- if ( mp->char_exists[k] ) {
- if ( mp->tfm_height[k]==0 ) mp->tfm_height[k]=zero_val;
- else mp->tfm_height[k]=mp_sort_in(mp, mp->tfm_height[k]);
- }
-}
-mp->nh=mp_skimp(mp, 15)+1; mp->dimen_head[2]=link(temp_head);
-if ( mp->perturbation>=010000 ) mp_tfm_warning(mp, mp_char_ht);
-clear_the_list;
-for (k=mp->bc;k<=mp->ec;k++) {
- if ( mp->char_exists[k] ) {
- if ( mp->tfm_depth[k]==0 ) mp->tfm_depth[k]=zero_val;
- else mp->tfm_depth[k]=mp_sort_in(mp, mp->tfm_depth[k]);
- }
-}
-mp->nd=mp_skimp(mp, 15)+1; mp->dimen_head[3]=link(temp_head);
-if ( mp->perturbation>=010000 ) mp_tfm_warning(mp, mp_char_dp);
-clear_the_list;
-for (k=mp->bc;k<=mp->ec;k++) {
- if ( mp->char_exists[k] ) {
- if ( mp->tfm_ital_corr[k]==0 ) mp->tfm_ital_corr[k]=zero_val;
- else mp->tfm_ital_corr[k]=mp_sort_in(mp, mp->tfm_ital_corr[k]);
- }
-}
-mp->ni=mp_skimp(mp, 63)+1; mp->dimen_head[4]=link(temp_head);
-if ( mp->perturbation>=010000 ) mp_tfm_warning(mp, mp_char_ic)
-
-@ @<Initialize table entries...@>=
-value(zero_val)=0; info(zero_val)=0;
-
-@ Bytes 5--8 of the header are set to the design size, unless the user has
-some crazy reason for specifying them differently.
-@^design size@>
-
-Error messages are not allowed at the time this procedure is called,
-so a warning is printed instead.
-
-The value of |max_tfm_dimen| is calculated so that
-$$\hbox{|make_scaled(16*max_tfm_dimen,internal[mp_design_size])|}
- < \\{three\_bytes}.$$
-
-@d three_bytes 0100000000 /* $2^{24}$ */
-
-@c
-void mp_fix_design_size (MP mp) {
- scaled d; /* the design size */
- d=mp->internal[mp_design_size];
- if ( (d<unity)||(d>=fraction_half) ) {
- if ( d!=0 )
- mp_print_nl(mp, "(illegal design size has been changed to 128pt)");
-@.illegal design size...@>
- d=040000000; mp->internal[mp_design_size]=d;
- }
- if ( mp->header_byte[4]<0 ) if ( mp->header_byte[5]<0 )
- if ( mp->header_byte[6]<0 ) if ( mp->header_byte[7]<0 ) {
- mp->header_byte[4]=d / 04000000;
- mp->header_byte[5]=(d / 4096) % 256;
- mp->header_byte[6]=(d / 16) % 256;
- mp->header_byte[7]=(d % 16)*16;
- };
- mp->max_tfm_dimen=16*mp->internal[mp_design_size]-1-mp->internal[mp_design_size] / 010000000;
- if ( mp->max_tfm_dimen>=fraction_half ) mp->max_tfm_dimen=fraction_half-1;
-}
-
-@ The |dimen_out| procedure computes a |fix_word| relative to the
-design size. If the data was out of range, it is corrected and the
-global variable |tfm_changed| is increased by~one.
-
-@c integer mp_dimen_out (MP mp,scaled x) {
- if ( abs(x)>mp->max_tfm_dimen ) {
- incr(mp->tfm_changed);
- if ( x>0 ) x=mp->max_tfm_dimen; else x=-mp->max_tfm_dimen;
- }
- x=mp_make_scaled(mp, x*16,mp->internal[mp_design_size]);
- return x;
-}
-
-@ @<Glob...@>=
-scaled max_tfm_dimen; /* bound on widths, heights, kerns, etc. */
-integer tfm_changed; /* the number of data entries that were out of bounds */
-
-@ If the user has not specified any of the first four header bytes,
-the |fix_check_sum| procedure replaces them by a ``check sum'' computed
-from the |tfm_width| data relative to the design size.
-@^check sum@>
-
-@c void mp_fix_check_sum (MP mp) {
- eight_bits k; /* runs through character codes */
- eight_bits B1,B2,B3,B4; /* bytes of the check sum */
- integer x; /* hash value used in check sum computation */
- if ( mp->header_byte[0]==0 && mp->header_byte[1]==0 &&
- mp->header_byte[2]==0 && mp->header_byte[3]==0 ) {
- @<Compute a check sum in |(b1,b2,b3,b4)|@>;
- mp->header_byte[0]=B1; mp->header_byte[1]=B2;
- mp->header_byte[2]=B3; mp->header_byte[3]=B4;
- return;
- }
-}
-
-@ @<Compute a check sum in |(b1,b2,b3,b4)|@>=
-B1=mp->bc; B2=mp->ec; B3=mp->bc; B4=mp->ec; mp->tfm_changed=0;
-for (k=mp->bc;k<=mp->ec;k++) {
- if ( mp->char_exists[k] ) {
- x=mp_dimen_out(mp, value(mp->tfm_width[k]))+(k+4)*020000000; /* this is positive */
- B1=(B1+B1+x) % 255;
- B2=(B2+B2+x) % 253;
- B3=(B3+B3+x) % 251;
- B4=(B4+B4+x) % 247;
- }
-}
-
-@ Finally we're ready to actually write the \.{TFM} information.
-Here are some utility routines for this purpose.
-
-@d tfm_out(A) do { /* output one byte to |tfm_file| */
- unsigned char s=(A);
- (mp->write_binary_file)(mp,mp->tfm_file,(void *)&s,1);
- } while (0)
-
-@c void mp_tfm_two (MP mp,integer x) { /* output two bytes to |tfm_file| */
- tfm_out(x / 256); tfm_out(x % 256);
-}
-void mp_tfm_four (MP mp,integer x) { /* output four bytes to |tfm_file| */
- if ( x>=0 ) tfm_out(x / three_bytes);
- else {
- x=x+010000000000; /* use two's complement for negative values */
- x=x+010000000000;
- tfm_out((x / three_bytes) + 128);
- };
- x=x % three_bytes; tfm_out(x / unity);
- x=x % unity; tfm_out(x / 0400);
- tfm_out(x % 0400);
-}
-void mp_tfm_qqqq (MP mp,four_quarters x) { /* output four quarterwords to |tfm_file| */
- tfm_out(qo(x.b0)); tfm_out(qo(x.b1));
- tfm_out(qo(x.b2)); tfm_out(qo(x.b3));
-}
-
-@ @<Finish the \.{TFM} file@>=
-if ( mp->job_name==NULL ) mp_open_log_file(mp);
-mp_pack_job_name(mp, ".tfm");
-while ( ! mp_b_open_out(mp, &mp->tfm_file, mp_filetype_metrics) )
- mp_prompt_file_name(mp, "file name for font metrics",".tfm");
-mp->metric_file_name=xstrdup(mp->name_of_file);
-@<Output the subfile sizes and header bytes@>;
-@<Output the character information bytes, then
- output the dimensions themselves@>;
-@<Output the ligature/kern program@>;
-@<Output the extensible character recipes and the font metric parameters@>;
- if ( mp->internal[mp_tracing_stats]>0 )
- @<Log the subfile sizes of the \.{TFM} file@>;
-mp_print_nl(mp, "Font metrics written on ");
-mp_print(mp, mp->metric_file_name); mp_print_char(mp, '.');
-@.Font metrics written...@>
-(mp->close_file)(mp,mp->tfm_file)
-
-@ Integer variables |lh|, |k|, and |lk_offset| will be defined when we use
-this code.
-
-@<Output the subfile sizes and header bytes@>=
-k=mp->header_last;
-LH=(k+3) / 4; /* this is the number of header words */
-if ( mp->bc>mp->ec ) mp->bc=1; /* if there are no characters, |ec=0| and |bc=1| */
-@<Compute the ligature/kern program offset and implant the
- left boundary label@>;
-mp_tfm_two(mp,6+LH+(mp->ec-mp->bc+1)+mp->nw+mp->nh+mp->nd+mp->ni+mp->nl
- +lk_offset+mp->nk+mp->ne+mp->np);
- /* this is the total number of file words that will be output */
-mp_tfm_two(mp, LH); mp_tfm_two(mp, mp->bc); mp_tfm_two(mp, mp->ec);
-mp_tfm_two(mp, mp->nw); mp_tfm_two(mp, mp->nh);
-mp_tfm_two(mp, mp->nd); mp_tfm_two(mp, mp->ni); mp_tfm_two(mp, mp->nl+lk_offset);
-mp_tfm_two(mp, mp->nk); mp_tfm_two(mp, mp->ne);
-mp_tfm_two(mp, mp->np);
-for (k=0;k< 4*LH;k++) {
- tfm_out(mp->header_byte[k]);
-}
-
-@ @<Output the character information bytes...@>=
-for (k=mp->bc;k<=mp->ec;k++) {
- if ( ! mp->char_exists[k] ) {
- mp_tfm_four(mp, 0);
- } else {
- tfm_out(info(mp->tfm_width[k])); /* the width index */
- tfm_out((info(mp->tfm_height[k]))*16+info(mp->tfm_depth[k]));
- tfm_out((info(mp->tfm_ital_corr[k]))*4+mp->char_tag[k]);
- tfm_out(mp->char_remainder[k]);
- };
-}
-mp->tfm_changed=0;
-for (k=1;k<=4;k++) {
- mp_tfm_four(mp, 0); p=mp->dimen_head[k];
- while ( p!=inf_val ) {
- mp_tfm_four(mp, mp_dimen_out(mp, value(p))); p=link(p);
- }
-}
-
-
-@ We need to output special instructions at the beginning of the
-|lig_kern| array in order to specify the right boundary character
-and/or to handle starting addresses that exceed 255. The |label_loc|
-and |label_char| arrays have been set up to record all the
-starting addresses; we have $-1=|label_loc|[0]<|label_loc|[1]\le\cdots
-\le|label_loc|[|label_ptr]|$.
-
-@<Compute the ligature/kern program offset...@>=
-mp->bchar=mp_round_unscaled(mp, mp->internal[mp_boundary_char]);
-if ((mp->bchar<0)||(mp->bchar>255))
- { mp->bchar=-1; mp->lk_started=false; lk_offset=0; }
-else { mp->lk_started=true; lk_offset=1; };
-@<Find the minimum |lk_offset| and adjust all remainders@>;
-if ( mp->bch_label<undefined_label )
- { skip_byte(mp->nl)=qi(255); next_char(mp->nl)=qi(0);
- op_byte(mp->nl)=qi(((mp->bch_label+lk_offset)/ 256));
- rem_byte(mp->nl)=qi(((mp->bch_label+lk_offset)% 256));
- incr(mp->nl); /* possibly |nl=lig_table_size+1| */
- }
-
-@ @<Find the minimum |lk_offset|...@>=
-k=mp->label_ptr; /* pointer to the largest unallocated label */
-if ( mp->label_loc[k]+lk_offset>255 ) {
- lk_offset=0; mp->lk_started=false; /* location 0 can do double duty */
- do {
- mp->char_remainder[mp->label_char[k]]=lk_offset;
- while ( mp->label_loc[k-1]==mp->label_loc[k] ) {
- decr(k); mp->char_remainder[mp->label_char[k]]=lk_offset;
- }
- incr(lk_offset); decr(k);
- } while (! (lk_offset+mp->label_loc[k]<256));
- /* N.B.: |lk_offset=256| satisfies this when |k=0| */
-}
-if ( lk_offset>0 ) {
- while ( k>0 ) {
- mp->char_remainder[mp->label_char[k]]
- =mp->char_remainder[mp->label_char[k]]+lk_offset;
- decr(k);
- }
-}
-
-@ @<Output the ligature/kern program@>=
-for (k=0;k<= 255;k++ ) {
- if ( mp->skip_table[k]<undefined_label ) {
- mp_print_nl(mp, "(local label "); mp_print_int(mp, k); mp_print(mp, ":: was missing)");
-@.local label l:: was missing@>
- cancel_skips(mp->skip_table[k]);
- }
-}
-if ( mp->lk_started ) { /* |lk_offset=1| for the special |bchar| */
- tfm_out(255); tfm_out(mp->bchar); mp_tfm_two(mp, 0);
-} else {
- for (k=1;k<=lk_offset;k++) {/* output the redirection specs */
- mp->ll=mp->label_loc[mp->label_ptr];
- if ( mp->bchar<0 ) { tfm_out(254); tfm_out(0); }
- else { tfm_out(255); tfm_out(mp->bchar); };
- mp_tfm_two(mp, mp->ll+lk_offset);
- do {
- decr(mp->label_ptr);
- } while (! (mp->label_loc[mp->label_ptr]<mp->ll));
- }
-}
-for (k=0;k<=mp->nl-1;k++) mp_tfm_qqqq(mp, mp->lig_kern[k]);
-for (k=0;k<=mp->nk-1;k++) mp_tfm_four(mp, mp_dimen_out(mp, mp->kern[k]))
-
-@ @<Output the extensible character recipes...@>=
-for (k=0;k<=mp->ne-1;k++)
- mp_tfm_qqqq(mp, mp->exten[k]);
-for (k=1;k<=mp->np;k++) {
- if ( k==1 ) {
- if ( abs(mp->param[1])<fraction_half ) {
- mp_tfm_four(mp, mp->param[1]*16);
- } else {
- incr(mp->tfm_changed);
- if ( mp->param[1]>0 ) mp_tfm_four(mp, el_gordo);
- else mp_tfm_four(mp, -el_gordo);
- }
- } else {
- mp_tfm_four(mp, mp_dimen_out(mp, mp->param[k]));
- }
-}
-if ( mp->tfm_changed>0 ) {
- if ( mp->tfm_changed==1 ) mp_print_nl(mp, "(a font metric dimension");
-@.a font metric dimension...@>
- else {
- mp_print_nl(mp, "("); mp_print_int(mp, mp->tfm_changed);
-@.font metric dimensions...@>
- mp_print(mp, " font metric dimensions");
- }
- mp_print(mp, " had to be decreased)");
-}
-
-@ @<Log the subfile sizes of the \.{TFM} file@>=
-{
- char s[200];
- wlog_ln(" ");
- if ( mp->bch_label<undefined_label ) decr(mp->nl);
- snprintf(s,128,"(You used %iw,%ih,%id,%ii,%il,%ik,%ie,%ip metric file positions)",
- mp->nw, mp->nh, mp->nd, mp->ni, mp->nl, mp->nk, mp->ne,mp->np);
- wlog_ln(s);
-}
-
-@* \[43] Reading font metric data.
-
-\MP\ isn't a typesetting program but it does need to find the bounding box
-of a sequence of typeset characters. Thus it needs to read \.{TFM} files as
-well as write them.
-
-@<Glob...@>=
-void * tfm_infile;
-
-@ All the width, height, and depth information is stored in an array called
-|font_info|. This array is allocated sequentially and each font is stored
-as a series of |char_info| words followed by the width, height, and depth
-tables. Since |font_name| entries are permanent, their |str_ref| values are
-set to |max_str_ref|.
-
-@<Types...@>=
-typedef unsigned int font_number; /* |0..font_max| */
-
-@ The |font_info| array is indexed via a group directory arrays.
-For example, the |char_info| data for character~|c| in font~|f| will be
-in |font_info[char_base[f]+c].qqqq|.
-
-@<Glob...@>=
-font_number font_max; /* maximum font number for included text fonts */
-size_t font_mem_size; /* number of words for \.{TFM} information for text fonts */
-memory_word *font_info; /* height, width, and depth data */
-char **font_enc_name; /* encoding names, if any */
-boolean *font_ps_name_fixed; /* are the postscript names fixed already? */
-int next_fmem; /* next unused entry in |font_info| */
-font_number last_fnum; /* last font number used so far */
-scaled *font_dsize; /* 16 times the ``design'' size in \ps\ points */
-char **font_name; /* name as specified in the \&{infont} command */
-char **font_ps_name; /* PostScript name for use when |internal[mp_prologues]>0| */
-font_number last_ps_fnum; /* last valid |font_ps_name| index */
-eight_bits *font_bc;
-eight_bits *font_ec; /* first and last character code */
-int *char_base; /* base address for |char_info| */
-int *width_base; /* index for zeroth character width */
-int *height_base; /* index for zeroth character height */
-int *depth_base; /* index for zeroth character depth */
-pointer *font_sizes;
-
-@ @<Allocate or initialize ...@>=
-mp->font_mem_size = 10000;
-mp->font_info = xmalloc ((mp->font_mem_size+1),sizeof(memory_word));
-memset (mp->font_info,0,sizeof(memory_word)*(mp->font_mem_size+1));
-mp->font_enc_name = NULL;
-mp->font_ps_name_fixed = NULL;
-mp->font_dsize = NULL;
-mp->font_name = NULL;
-mp->font_ps_name = NULL;
-mp->font_bc = NULL;
-mp->font_ec = NULL;
-mp->last_fnum = null_font;
-mp->char_base = NULL;
-mp->width_base = NULL;
-mp->height_base = NULL;
-mp->depth_base = NULL;
-mp->font_sizes = null;
-
-@ @<Dealloc variables@>=
-for (k=1;k<=(int)mp->last_fnum;k++) {
- xfree(mp->font_enc_name[k]);
- xfree(mp->font_name[k]);
- xfree(mp->font_ps_name[k]);
-}
-xfree(mp->font_info);
-xfree(mp->font_enc_name);
-xfree(mp->font_ps_name_fixed);
-xfree(mp->font_dsize);
-xfree(mp->font_name);
-xfree(mp->font_ps_name);
-xfree(mp->font_bc);
-xfree(mp->font_ec);
-xfree(mp->char_base);
-xfree(mp->width_base);
-xfree(mp->height_base);
-xfree(mp->depth_base);
-xfree(mp->font_sizes);
-
-@
-@c
-void mp_reallocate_fonts (MP mp, font_number l) {
- font_number f;
- XREALLOC(mp->font_enc_name, l, char *);
- XREALLOC(mp->font_ps_name_fixed, l, boolean);
- XREALLOC(mp->font_dsize, l, scaled);
- XREALLOC(mp->font_name, l, char *);
- XREALLOC(mp->font_ps_name, l, char *);
- XREALLOC(mp->font_bc, l, eight_bits);
- XREALLOC(mp->font_ec, l, eight_bits);
- XREALLOC(mp->char_base, l, int);
- XREALLOC(mp->width_base, l, int);
- XREALLOC(mp->height_base, l, int);
- XREALLOC(mp->depth_base, l, int);
- XREALLOC(mp->font_sizes, l, pointer);
- for (f=(mp->last_fnum+1);f<=l;f++) {
- mp->font_enc_name[f]=NULL;
- mp->font_ps_name_fixed[f] = false;
- mp->font_name[f]=NULL;
- mp->font_ps_name[f]=NULL;
- mp->font_sizes[f]=null;
- }
- mp->font_max = l;
-}
-
-@ @<Declare |mp_reallocate| functions@>=
-void mp_reallocate_fonts (MP mp, font_number l);
-
-
-@ A |null_font| containing no characters is useful for error recovery. Its
-|font_name| entry starts out empty but is reset each time an erroneous font is
-found. This helps to cut down on the number of duplicate error messages without
-wasting a lot of space.
-
-@d null_font 0 /* the |font_number| for an empty font */
-
-@<Set initial...@>=
-mp->font_dsize[null_font]=0;
-mp->font_bc[null_font]=1;
-mp->font_ec[null_font]=0;
-mp->char_base[null_font]=0;
-mp->width_base[null_font]=0;
-mp->height_base[null_font]=0;
-mp->depth_base[null_font]=0;
-mp->next_fmem=0;
-mp->last_fnum=null_font;
-mp->last_ps_fnum=null_font;
-mp->font_name[null_font]=(char *)"nullfont";
-mp->font_ps_name[null_font]=(char *)"";
-mp->font_ps_name_fixed[null_font] = false;
-mp->font_enc_name[null_font]=NULL;
-mp->font_sizes[null_font]=null;
-
-@ Each |char_info| word is of type |four_quarters|. The |b0| field contains
-the |width index|; the |b1| field contains the height
-index; the |b2| fields contains the depth index, and the |b3| field used only
-for temporary storage. (It is used to keep track of which characters occur in
-an edge structure that is being shipped out.)
-The corresponding words in the width, height, and depth tables are stored as
-|scaled| values in units of \ps\ points.
-
-With the macros below, the |char_info| word for character~|c| in font~|f| is
-|char_info(f)(c)| and the width is
-$$\hbox{|char_width(f)(char_info(f)(c)).sc|.}$$
-
-@d char_info_end(A) (A)].qqqq
-@d char_info(A) mp->font_info[mp->char_base[(A)]+char_info_end
-@d char_width_end(A) (A).b0].sc
-@d char_width(A) mp->font_info[mp->width_base[(A)]+char_width_end
-@d char_height_end(A) (A).b1].sc
-@d char_height(A) mp->font_info[mp->height_base[(A)]+char_height_end
-@d char_depth_end(A) (A).b2].sc
-@d char_depth(A) mp->font_info[mp->depth_base[(A)]+char_depth_end
-@d ichar_exists(A) ((A).b0>0)
-
-@ The |font_ps_name| for a built-in font should be what PostScript expects.
-A preliminary name is obtained here from the \.{TFM} name as given in the
-|fname| argument. This gets updated later from an external table if necessary.
-
-@<Declare text measuring subroutines@>=
-@<Declare subroutines for parsing file names@>
-font_number mp_read_font_info (MP mp, char *fname) {
- boolean file_opened; /* has |tfm_infile| been opened? */
- font_number n; /* the number to return */
- halfword lf,tfm_lh,bc,ec,nw,nh,nd; /* subfile size parameters */
- size_t whd_size; /* words needed for heights, widths, and depths */
- int i,ii; /* |font_info| indices */
- int jj; /* counts bytes to be ignored */
- scaled z; /* used to compute the design size */
- fraction d;
- /* height, width, or depth as a fraction of design size times $2^{-8}$ */
- eight_bits h_and_d; /* height and depth indices being unpacked */
- unsigned char tfbyte; /* a byte read from the file */
- n=null_font;
- @<Open |tfm_infile| for input@>;
- @<Read data from |tfm_infile|; if there is no room, say so and |goto done|;
- otherwise |goto bad_tfm| or |goto done| as appropriate@>;
-BAD_TFM:
- @<Complain that the \.{TFM} file is bad@>;
-DONE:
- if ( file_opened ) (mp->close_file)(mp,mp->tfm_infile);
- if ( n!=null_font ) {
- mp->font_ps_name[n]=mp_xstrdup(mp,fname);
- mp->font_name[n]=mp_xstrdup(mp,fname);
- }
- return n;
-}
-
-@ \MP\ doesn't bother to check the entire \.{TFM} file for errors or explain
-precisely what is wrong if it does find a problem. Programs called \.{TFtoPL}
-@.TFtoPL@> @.PLtoTF@>
-and \.{PLtoTF} can be used to debug \.{TFM} files.
-
-@<Complain that the \.{TFM} file is bad@>=
-print_err("Font ");
-mp_print(mp, fname);
-if ( file_opened ) mp_print(mp, " not usable: TFM file is bad");
-else mp_print(mp, " not usable: TFM file not found");
-help3("I wasn't able to read the size data for this font so this")
- ("`infont' operation won't produce anything. If the font name")
- ("is right, you might ask an expert to make a TFM file");
-if ( file_opened )
- mp->help_line[0]="is right, try asking an expert to fix the TFM file";
-mp_error(mp)
-
-@ @<Read data from |tfm_infile|; if there is no room, say so...@>=
-@<Read the \.{TFM} size fields@>;
-@<Use the size fields to allocate space in |font_info|@>;
-@<Read the \.{TFM} header@>;
-@<Read the character data and the width, height, and depth tables and
- |goto done|@>
-
-@ A bad \.{TFM} file can be shorter than it claims to be. The code given here
-might try to read past the end of the file if this happens. Changes will be
-needed if it causes a system error to refer to |tfm_infile^| or call
-|get_tfm_infile| when |eof(tfm_infile)| is true. For example, the definition
-@^system dependencies@>
-of |tfget| could be changed to
-``|begin get(tfm_infile); if eof(tfm_infile) then goto bad_tfm; end|.''
-
-@d tfget do {
- size_t wanted=1;
- void *tfbyte_ptr = &tfbyte;
- (mp->read_binary_file)(mp,mp->tfm_infile,&tfbyte_ptr,&wanted);
- if (wanted==0) goto BAD_TFM;
-} while (0)
-@d read_two(A) { (A)=tfbyte;
- if ( (A)>127 ) goto BAD_TFM;
- tfget; (A)=(A)*0400+tfbyte;
-}
-@d tf_ignore(A) { for (jj=(A);jj>=1;jj--) tfget; }
-
-@<Read the \.{TFM} size fields@>=
-tfget; read_two(lf);
-tfget; read_two(tfm_lh);
-tfget; read_two(bc);
-tfget; read_two(ec);
-if ( (bc>1+ec)||(ec>255) ) goto BAD_TFM;
-tfget; read_two(nw);
-tfget; read_two(nh);
-tfget; read_two(nd);
-whd_size=(ec+1-bc)+nw+nh+nd;
-if ( lf<(int)(6+tfm_lh+whd_size) ) goto BAD_TFM;
-tf_ignore(10)
-
-@ Offsets are added to |char_base[n]| and |width_base[n]| so that is not
-necessary to apply the |so| and |qo| macros when looking up the width of a
-character in the string pool. In order to ensure nonnegative |char_base|
-values when |bc>0|, it may be necessary to reserve a few unused |font_info|
-elements.
-
-@<Use the size fields to allocate space in |font_info|@>=
-if ( mp->next_fmem<bc) mp->next_fmem=bc; /* ensure nonnegative |char_base| */
-if (mp->last_fnum==mp->font_max)
- mp_reallocate_fonts(mp,(mp->font_max+(mp->font_max>>2)));
-while (mp->next_fmem+whd_size>=mp->font_mem_size) {
- size_t l = mp->font_mem_size+(mp->font_mem_size>>2);
- memory_word *font_info;
- font_info = xmalloc ((l+1),sizeof(memory_word));
- memset (font_info,0,sizeof(memory_word)*(l+1));
- memcpy (font_info,mp->font_info,sizeof(memory_word)*(mp->font_mem_size+1));
- xfree(mp->font_info);
- mp->font_info = font_info;
- mp->font_mem_size = l;
-}
-incr(mp->last_fnum);
-n=mp->last_fnum;
-mp->font_bc[n]=bc;
-mp->font_ec[n]=ec;
-mp->char_base[n]=mp->next_fmem-bc;
-mp->width_base[n]=mp->next_fmem+ec-bc+1;
-mp->height_base[n]=mp->width_base[n]+nw;
-mp->depth_base[n]=mp->height_base[n]+nh;
-mp->next_fmem=mp->next_fmem+whd_size;
-
-
-@ @<Read the \.{TFM} header@>=
-if ( tfm_lh<2 ) goto BAD_TFM;
-tf_ignore(4);
-tfget; read_two(z);
-tfget; z=z*0400+tfbyte;
-tfget; z=z*0400+tfbyte; /* now |z| is 16 times the design size */
-mp->font_dsize[n]=mp_take_fraction(mp, z,267432584);
- /* times ${72\over72.27}2^{28}$ to convert from \TeX\ points */
-tf_ignore(4*(tfm_lh-2))
-
-@ @<Read the character data and the width, height, and depth tables...@>=
-ii=mp->width_base[n];
-i=mp->char_base[n]+bc;
-while ( i<ii ) {
- tfget; mp->font_info[i].qqqq.b0=qi(tfbyte);
- tfget; h_and_d=tfbyte;
- mp->font_info[i].qqqq.b1=h_and_d / 16;
- mp->font_info[i].qqqq.b2=h_and_d % 16;
- tfget; tfget;
- incr(i);
-}
-while ( i<mp->next_fmem ) {
- @<Read a four byte dimension, scale it by the design size, store it in
- |font_info[i]|, and increment |i|@>;
-}
-goto DONE
-
-@ The raw dimension read into |d| should have magnitude at most $2^{24}$ when
-interpreted as an integer, and this includes a scale factor of $2^{20}$. Thus
-we can multiply it by sixteen and think of it as a |fraction| that has been
-divided by sixteen. This cancels the extra scale factor contained in
-|font_dsize[n|.
-
-@<Read a four byte dimension, scale it by the design size, store it in...@>=
-{
-tfget; d=tfbyte;
-if ( d>=0200 ) d=d-0400;
-tfget; d=d*0400+tfbyte;
-tfget; d=d*0400+tfbyte;
-tfget; d=d*0400+tfbyte;
-mp->font_info[i].sc=mp_take_fraction(mp, d*16,mp->font_dsize[n]);
-incr(i);
-}
-
-@ This function does no longer use the file name parser, because |fname| is
-a C string already.
-@<Open |tfm_infile| for input@>=
-file_opened=false;
-mp_ptr_scan_file(mp, fname);
-if ( strlen(mp->cur_area)==0 ) { xfree(mp->cur_area); }
-if ( strlen(mp->cur_ext)==0 ) { xfree(mp->cur_ext); mp->cur_ext=xstrdup(".tfm"); }
-pack_cur_name;
-mp->tfm_infile = (mp->open_file)(mp, mp->name_of_file, "r",mp_filetype_metrics);
-if ( !mp->tfm_infile ) goto BAD_TFM;
-file_opened=true
-
-@ When we have a font name and we don't know whether it has been loaded yet,
-we scan the |font_name| array before calling |read_font_info|.
-
-@<Declare text measuring subroutines@>=
-font_number mp_find_font (MP mp, char *f) {
- font_number n;
- for (n=0;n<=mp->last_fnum;n++) {
- if (mp_xstrcmp(f,mp->font_name[n])==0 ) {
- mp_xfree(f);
- return n;
- }
- }
- n = mp_read_font_info(mp, f);
- mp_xfree(f);
- return n;
-}
-
-@ One simple application of |find_font| is the implementation of the |font_size|
-operator that gets the design size for a given font name.
-
-@<Find the design size of the font whose name is |cur_exp|@>=
-mp_flush_cur_exp(mp, (mp->font_dsize[mp_find_font(mp, str(mp->cur_exp))]+8) / 16)
-
-@ If we discover that the font doesn't have a requested character, we omit it
-from the bounding box computation and expect the \ps\ interpreter to drop it.
-This routine issues a warning message if the user has asked for it.
-
-@<Declare text measuring subroutines@>=
-void mp_lost_warning (MP mp,font_number f, pool_pointer k) {
- if ( mp->internal[mp_tracing_lost_chars]>0 ) {
- mp_begin_diagnostic(mp);
- if ( mp->selector==log_only ) incr(mp->selector);
- mp_print_nl(mp, "Missing character: There is no ");
-@.Missing character@>
- mp_print_str(mp, mp->str_pool[k]);
- mp_print(mp, " in font ");
- mp_print(mp, mp->font_name[f]); mp_print_char(mp, '!');
- mp_end_diagnostic(mp, false);
- }
-}
-
-@ The whole purpose of saving the height, width, and depth information is to be
-able to find the bounding box of an item of text in an edge structure. The
-|set_text_box| procedure takes a text node and adds this information.
-
-@<Declare text measuring subroutines@>=
-void mp_set_text_box (MP mp,pointer p) {
- font_number f; /* |font_n(p)| */
- ASCII_code bc,ec; /* range of valid characters for font |f| */
- pool_pointer k,kk; /* current character and character to stop at */
- four_quarters cc; /* the |char_info| for the current character */
- scaled h,d; /* dimensions of the current character */
- width_val(p)=0;
- height_val(p)=-el_gordo;
- depth_val(p)=-el_gordo;
- f=font_n(p);
- bc=mp->font_bc[f];
- ec=mp->font_ec[f];
- kk=str_stop(text_p(p));
- k=mp->str_start[text_p(p)];
- while ( k<kk ) {
- @<Adjust |p|'s bounding box to contain |str_pool[k]|; advance |k|@>;
- }
- @<Set the height and depth to zero if the bounding box is empty@>;
-}
-
-@ @<Adjust |p|'s bounding box to contain |str_pool[k]|; advance |k|@>=
-{
- if ( (mp->str_pool[k]<bc)||(mp->str_pool[k]>ec) ) {
- mp_lost_warning(mp, f,k);
- } else {
- cc=char_info(f)(mp->str_pool[k]);
- if ( ! ichar_exists(cc) ) {
- mp_lost_warning(mp, f,k);
- } else {
- width_val(p)=width_val(p)+char_width(f)(cc);
- h=char_height(f)(cc);
- d=char_depth(f)(cc);
- if ( h>height_val(p) ) height_val(p)=h;
- if ( d>depth_val(p) ) depth_val(p)=d;
- }
- }
- incr(k);
-}
-
-@ Let's hope modern compilers do comparisons correctly when the difference would
-overflow.
-
-@<Set the height and depth to zero if the bounding box is empty@>=
-if ( height_val(p)<-depth_val(p) ) {
- height_val(p)=0;
- depth_val(p)=0;
-}
-
-@ The new primitives fontmapfile and fontmapline.
-
-@<Declare action procedures for use by |do_statement|@>=
-void mp_do_mapfile (MP mp) ;
-void mp_do_mapline (MP mp) ;
-
-@ @c void mp_do_mapfile (MP mp) {
- mp_get_x_next(mp); mp_scan_expression(mp);
- if ( mp->cur_type!=mp_string_type ) {
- @<Complain about improper map operation@>;
- } else {
- mp_map_file(mp,mp->cur_exp);
- }
-}
-void mp_do_mapline (MP mp) {
- mp_get_x_next(mp); mp_scan_expression(mp);
- if ( mp->cur_type!=mp_string_type ) {
- @<Complain about improper map operation@>;
- } else {
- mp_map_line(mp,mp->cur_exp);
- }
-}
-
-@ @<Complain about improper map operation@>=
-{
- exp_err("Unsuitable expression");
- help1("Only known strings can be map files or map lines.");
- mp_put_get_error(mp);
-}
-
-@ To print |scaled| value to PDF output we need some subroutines to ensure
-accurary.
-
-@d max_integer 0x7FFFFFFF /* $2^{31}-1$ */
-
-@<Glob...@>=
-scaled one_bp; /* scaled value corresponds to 1bp */
-scaled one_hundred_bp; /* scaled value corresponds to 100bp */
-scaled one_hundred_inch; /* scaled value corresponds to 100in */
-integer ten_pow[10]; /* $10^0..10^9$ */
-integer scaled_out; /* amount of |scaled| that was taken out in |divide_scaled| */
-
-@ @<Set init...@>=
-mp->one_bp = 65782; /* 65781.76 */
-mp->one_hundred_bp = 6578176;
-mp->one_hundred_inch = 473628672;
-mp->ten_pow[0] = 1;
-for (i = 1;i<= 9; i++ ) {
- mp->ten_pow[i] = 10*mp->ten_pow[i - 1];
-}
-
-@ The following function divides |s| by |m|. |dd| is number of decimal digits.
-
-@c scaled mp_divide_scaled (MP mp,scaled s, scaled m, integer dd) {
- scaled q,r;
- integer sign,i;
- sign = 1;
- if ( s < 0 ) { sign = -sign; s = -s; }
- if ( m < 0 ) { sign = -sign; m = -m; }
- if ( m == 0 )
- mp_confusion(mp, "arithmetic: divided by zero");
- else if ( m >= (max_integer / 10) )
- mp_confusion(mp, "arithmetic: number too big");
- q = s / m;
- r = s % m;
- for (i = 1;i<=dd;i++) {
- q = 10*q + (10*r) / m;
- r = (10*r) % m;
- }
- if ( 2*r >= m ) { incr(q); r = r - m; }
- mp->scaled_out = sign*(s - (r / mp->ten_pow[dd]));
- return (sign*q);
-}
-
-@* \[44] Shipping pictures out.
-The |ship_out| procedure, to be described below, is given a pointer to
-an edge structure. Its mission is to output a file containing the \ps\
-description of an edge structure.
-
-@ Each time an edge structure is shipped out we write a new \ps\ output
-file named according to the current \&{charcode}.
-@:char_code_}{\&{charcode} primitive@>
-
-This is the only backend function that remains in the main |mpost.w| file.
-There are just too many variable accesses needed for status reporting
-etcetera to make it worthwile to move the code to |psout.w|.
-
-@<Internal library declarations@>=
-void mp_open_output_file (MP mp) ;
-
-@ @c
-char *mp_set_output_file_name (MP mp, integer c) {
- char *ss = NULL; /* filename extension proposal */
- int old_setting; /* previous |selector| setting */
- pool_pointer i; /* indexes into |filename_template| */
- integer cc; /* a temporary integer for template building */
- integer f,g=0; /* field widths */
- if ( mp->job_name==NULL ) mp_open_log_file(mp);
- if ( mp->filename_template==0 ) {
- char *s; /* a file extension derived from |c| */
- if ( c<0 )
- s=xstrdup(".ps");
- else
- @<Use |c| to compute the file extension |s|@>;
- mp_pack_job_name(mp, s);
- ss = s ;
- } else { /* initializations */
- str_number s, n; /* a file extension derived from |c| */
- old_setting=mp->selector;
- mp->selector=new_string;
- f = 0;
- i = mp->str_start[mp->filename_template];
- n = rts(""); /* initialize */
- while ( i<str_stop(mp->filename_template) ) {
- if ( mp->str_pool[i]=='%' ) {
- CONTINUE:
- incr(i);
- if ( i<str_stop(mp->filename_template) ) {
- if ( mp->str_pool[i]=='j' ) {
- mp_print(mp, mp->job_name);
- } else if ( mp->str_pool[i]=='d' ) {
- cc= mp_round_unscaled(mp, mp->internal[mp_day]);
- print_with_leading_zeroes(cc);
- } else if ( mp->str_pool[i]=='m' ) {
- cc= mp_round_unscaled(mp, mp->internal[mp_month]);
- print_with_leading_zeroes(cc);
- } else if ( mp->str_pool[i]=='y' ) {
- cc= mp_round_unscaled(mp, mp->internal[mp_year]);
- print_with_leading_zeroes(cc);
- } else if ( mp->str_pool[i]=='H' ) {
- cc= mp_round_unscaled(mp, mp->internal[mp_time]) / 60;
- print_with_leading_zeroes(cc);
- } else if ( mp->str_pool[i]=='M' ) {
- cc= mp_round_unscaled(mp, mp->internal[mp_time]) % 60;
- print_with_leading_zeroes(cc);
- } else if ( mp->str_pool[i]=='c' ) {
- if ( c<0 ) mp_print(mp, "ps");
- else print_with_leading_zeroes(c);
- } else if ( (mp->str_pool[i]>='0') &&
- (mp->str_pool[i]<='9') ) {
- if ( (f<10) )
- f = (f*10) + mp->str_pool[i]-'0';
- goto CONTINUE;
- } else {
- mp_print_str(mp, mp->str_pool[i]);
- }
- }
- } else {
- if ( mp->str_pool[i]=='.' )
- if (length(n)==0)
- n = mp_make_string(mp);
- mp_print_str(mp, mp->str_pool[i]);
- };
- incr(i);
- };
- s = mp_make_string(mp);
- mp->selector= old_setting;
- if (length(n)==0) {
- n=s;
- s=rts("");
- };
- mp_pack_file_name(mp, str(n),"",str(s));
- delete_str_ref(n);
- ss = str(s);
- delete_str_ref(s);
- }
- return ss;
-}
-
-char * mp_get_output_file_name (MP mp) {
- char *fname; /* return value */
- char *saved_name; /* saved |name_of_file| */
- saved_name = mp_xstrdup(mp, mp->name_of_file);
- (void)mp_set_output_file_name(mp, mp_round_unscaled(mp, mp->internal[mp_char_code]));
- fname = mp_xstrdup(mp, mp->name_of_file);
- mp_pack_file_name(mp, saved_name,NULL,NULL);
- return fname;
-}
-
-void mp_open_output_file (MP mp) {
- char *ss; /* filename extension proposal */
- integer c; /* \&{charcode} rounded to the nearest integer */
- c=mp_round_unscaled(mp, mp->internal[mp_char_code]);
- ss = mp_set_output_file_name(mp, c);
- while ( ! mp_a_open_out(mp, (void *)&mp->ps_file, mp_filetype_postscript) )
- mp_prompt_file_name(mp, "file name for output",ss);
- xfree(ss);
- @<Store the true output file name if appropriate@>;
-}
-
-@ The file extension created here could be up to five characters long in
-extreme cases so it may have to be shortened on some systems.
-@^system dependencies@>
-
-@<Use |c| to compute the file extension |s|@>=
-{
- s = xmalloc(7,1);
- snprintf(s,7,".%i",(int)c);
-}
-
-@ The user won't want to see all the output file names so we only save the
-first and last ones and a count of how many there were. For this purpose
-files are ordered primarily by \&{charcode} and secondarily by order of
-creation.
-@:char_code_}{\&{charcode} primitive@>
-
-@<Store the true output file name if appropriate@>=
-if ((c<mp->first_output_code)&&(mp->first_output_code>=0)) {
- mp->first_output_code=c;
- xfree(mp->first_file_name);
- mp->first_file_name=xstrdup(mp->name_of_file);
-}
-if ( c>=mp->last_output_code ) {
- mp->last_output_code=c;
- xfree(mp->last_file_name);
- mp->last_file_name=xstrdup(mp->name_of_file);
-}
-
-@ @<Glob...@>=
-char * first_file_name;
-char * last_file_name; /* full file names */
-integer first_output_code;integer last_output_code; /* rounded \&{charcode} values */
-@:char_code_}{\&{charcode} primitive@>
-integer total_shipped; /* total number of |ship_out| operations completed */
-
-@ @<Set init...@>=
-mp->first_file_name=xstrdup("");
-mp->last_file_name=xstrdup("");
-mp->first_output_code=32768;
-mp->last_output_code=-32768;
-mp->total_shipped=0;
-
-@ @<Dealloc variables@>=
-xfree(mp->first_file_name);
-xfree(mp->last_file_name);
-
-@ @<Begin the progress report for the output of picture~|c|@>=
-if ( (int)mp->term_offset>mp->max_print_line-6 ) mp_print_ln(mp);
-else if ( (mp->term_offset>0)||(mp->file_offset>0) ) mp_print_char(mp, ' ');
-mp_print_char(mp, '[');
-if ( c>=0 ) mp_print_int(mp, c)
-
-@ @<End progress report@>=
-mp_print_char(mp, ']');
-update_terminal;
-incr(mp->total_shipped)
-
-@ @<Explain what output files were written@>=
-if ( mp->total_shipped>0 ) {
- mp_print_nl(mp, "");
- mp_print_int(mp, mp->total_shipped);
- mp_print(mp, " output file");
- if ( mp->total_shipped>1 ) mp_print_char(mp, 's');
- mp_print(mp, " written: ");
- mp_print(mp, mp->first_file_name);
- if ( mp->total_shipped>1 ) {
- if ( 31+strlen(mp->first_file_name)+
- strlen(mp->last_file_name)> (unsigned)mp->max_print_line)
- mp_print_ln(mp);
- mp_print(mp, " .. ");
- mp_print(mp, mp->last_file_name);
- }
-}
-
-@ @<Internal library declarations@>=
-boolean mp_has_font_size(MP mp, font_number f );
-
-@ @c
-boolean mp_has_font_size(MP mp, font_number f ) {
- return (mp->font_sizes[f]!=null);
-}
-
-@ The \&{special} command saves up lines of text to be printed during the next
-|ship_out| operation. The saved items are stored as a list of capsule tokens.
-
-@<Glob...@>=
-pointer last_pending; /* the last token in a list of pending specials */
-
-@ @<Set init...@>=
-mp->last_pending=spec_head;
-
-@ @<Cases of |do_statement|...@>=
-case special_command:
- if ( mp->cur_mod==0 ) mp_do_special(mp); else
- if ( mp->cur_mod==1 ) mp_do_mapfile(mp); else
- mp_do_mapline(mp);
- break;
-
-@ @<Declare action procedures for use by |do_statement|@>=
-void mp_do_special (MP mp) ;
-
-@ @c void mp_do_special (MP mp) {
- mp_get_x_next(mp); mp_scan_expression(mp);
- if ( mp->cur_type!=mp_string_type ) {
- @<Complain about improper special operation@>;
- } else {
- link(mp->last_pending)=mp_stash_cur_exp(mp);
- mp->last_pending=link(mp->last_pending);
- link(mp->last_pending)=null;
- }
-}
-
-@ @<Complain about improper special operation@>=
-{
- exp_err("Unsuitable expression");
- help1("Only known strings are allowed for output as specials.");
- mp_put_get_error(mp);
-}
-
-@ On the export side, we need an extra object type for special strings.
-
-@<Graphical object codes@>=
-mp_special_code=8,
-
-@ @<Export pending specials@>=
-p=link(spec_head);
-while ( p!=null ) {
- mp_special_object *tp;
- tp = (mp_special_object *)mp_new_graphic_object(mp,mp_special_code);
- gr_pre_script(tp) = str(value(p));
- if (hh->body==NULL) hh->body = (mp_graphic_object *)tp;
- else gr_link(hp) = (mp_graphic_object *)tp;
- hp = (mp_graphic_object *)tp;
- p=link(p);
-}
-mp_flush_token_list(mp, link(spec_head));
-link(spec_head)=null;
-mp->last_pending=spec_head
-
-@ We are now ready for the main output procedure. Note that the |selector|
-setting is saved in a global variable so that |begin_diagnostic| can access it.
-
-@<Declare the \ps\ output procedures@>=
-void mp_ship_out (MP mp, pointer h) ;
-
-@ Once again, the |gr_XXXX| macros are defined in |mppsout.h|
-
-@d export_color(q,p)
- if ( color_model(p)==mp_uninitialized_model ) {
- gr_color_model(q) = (mp->internal[mp_default_color_model]>>16);
- gr_cyan_val(q) = 0;
- gr_magenta_val(q) = 0;
- gr_yellow_val(q) = 0;
- gr_black_val(q) = (gr_color_model(q)==mp_cmyk_model ? unity : 0);
- } else {
- gr_color_model(q) = color_model(p);
- gr_cyan_val(q) = cyan_val(p);
- gr_magenta_val(q) = magenta_val(p);
- gr_yellow_val(q) = yellow_val(p);
- gr_black_val(q) = black_val(p);
- }
-
-@d export_scripts(q,p)
- if (pre_script(p)!=null) gr_pre_script(q) = str(pre_script(p));
- if (post_script(p)!=null) gr_post_script(q) = str(post_script(p));
-
-@c
-struct mp_edge_object *mp_gr_export(MP mp, pointer h) {
- pointer p; /* the current graphical object */
- integer t; /* a temporary value */
- scaled d_width; /* the current pen width */
- mp_edge_object *hh; /* the first graphical object */
- struct mp_graphic_object *hq; /* something |hp| points to */
- struct mp_text_object *tt;
- struct mp_fill_object *tf;
- struct mp_stroked_object *ts;
- struct mp_clip_object *tc;
- struct mp_bounds_object *tb;
- struct mp_graphic_object *hp = NULL; /* the current graphical object */
- mp_set_bbox(mp, h, true);
- hh = mp_xmalloc(mp,1,sizeof(mp_edge_object));
- hh->body = NULL;
- hh->_next = NULL;
- hh->_parent = mp;
- hh->_minx = minx_val(h);
- hh->_miny = miny_val(h);
- hh->_maxx = maxx_val(h);
- hh->_maxy = maxy_val(h);
- hh->_filename = mp_get_output_file_name(mp);
- @<Export pending specials@>;
- p=link(dummy_loc(h));
- while ( p!=null ) {
- hq = mp_new_graphic_object(mp,type(p));
- switch (type(p)) {
- case mp_fill_code:
- tf = (mp_fill_object *)hq;
- gr_pen_p(tf) = mp_export_knot_list(mp,pen_p(p));
- d_width = mp_get_pen_scale(mp, pen_p(p));
- if ((pen_p(p)==null) || pen_is_elliptical(pen_p(p))) {
- gr_path_p(tf) = mp_export_knot_list(mp,path_p(p));
- } else {
- pointer pc, pp;
- pc = mp_copy_path(mp, path_p(p));
- pp = mp_make_envelope(mp, pc, pen_p(p),ljoin_val(p),0,miterlim_val(p));
- gr_path_p(tf) = mp_export_knot_list(mp,pp);
- mp_toss_knot_list(mp, pp);
- pc = mp_htap_ypoc(mp, path_p(p));
- pp = mp_make_envelope(mp, pc, pen_p(p),ljoin_val(p),0,miterlim_val(p));
- gr_htap_p(tf) = mp_export_knot_list(mp,pp);
- mp_toss_knot_list(mp, pp);
- }
- export_color(tf,p) ;
- export_scripts(tf,p);
- gr_ljoin_val(tf) = ljoin_val(p);
- gr_miterlim_val(tf) = miterlim_val(p);
- break;
- case mp_stroked_code:
- ts = (mp_stroked_object *)hq;
- gr_pen_p(ts) = mp_export_knot_list(mp,pen_p(p));
- d_width = mp_get_pen_scale(mp, pen_p(p));
- if (pen_is_elliptical(pen_p(p))) {
- gr_path_p(ts) = mp_export_knot_list(mp,path_p(p));
- } else {
- pointer pc;
- pc=mp_copy_path(mp, path_p(p));
- t=lcap_val(p);
- if ( left_type(pc)!=mp_endpoint ) {
- left_type(mp_insert_knot(mp, pc,x_coord(pc),y_coord(pc)))=mp_endpoint;
- right_type(pc)=mp_endpoint;
- pc=link(pc);
- t=1;
- }
- pc=mp_make_envelope(mp,pc,pen_p(p),ljoin_val(p),t,miterlim_val(p));
- gr_path_p(ts) = mp_export_knot_list(mp,pc);
- mp_toss_knot_list(mp, pc);
- }
- export_color(ts,p) ;
- export_scripts(ts,p);
- gr_ljoin_val(ts) = ljoin_val(p);
- gr_miterlim_val(ts) = miterlim_val(p);
- gr_lcap_val(ts) = lcap_val(p);
- gr_dash_p(ts) = mp_export_dashes(mp,p,&d_width);
- break;
- case mp_text_code:
- tt = (mp_text_object *)hq;
- gr_text_p(tt) = str(text_p(p));
- gr_font_n(tt) = font_n(p);
- gr_font_name(tt) = mp_xstrdup(mp,mp->font_name[font_n(p)]);
- gr_font_dsize(tt) = mp->font_dsize[font_n(p)];
- export_color(tt,p) ;
- export_scripts(tt,p);
- gr_width_val(tt) = width_val(p);
- gr_height_val(tt) = height_val(p);
- gr_depth_val(tt) = depth_val(p);
- gr_tx_val(tt) = tx_val(p);
- gr_ty_val(tt) = ty_val(p);
- gr_txx_val(tt) = txx_val(p);
- gr_txy_val(tt) = txy_val(p);
- gr_tyx_val(tt) = tyx_val(p);
- gr_tyy_val(tt) = tyy_val(p);
- break;
- case mp_start_clip_code:
- tc = (mp_clip_object *)hq;
- gr_path_p(tc) = mp_export_knot_list(mp,path_p(p));
- break;
- case mp_start_bounds_code:
- tb = (mp_bounds_object *)hq;
- gr_path_p(tb) = mp_export_knot_list(mp,path_p(p));
- break;
- case mp_stop_clip_code:
- case mp_stop_bounds_code:
- /* nothing to do here */
- break;
- }
- if (hh->body==NULL) hh->body=hq; else gr_link(hp) = hq;
- hp = hq;
- p=link(p);
- }
- return hh;
-}
-
-@ @<Exported function ...@>=
-struct mp_edge_object *mp_gr_export(MP mp, int h);
-
-@ This function is now nearly trivial.
-
-@c
-void mp_ship_out (MP mp, pointer h) { /* output edge structure |h| */
- integer c; /* \&{charcode} rounded to the nearest integer */
- c=mp_round_unscaled(mp, mp->internal[mp_char_code]);
- @<Begin the progress report for the output of picture~|c|@>;
- (mp->shipout_backend) (mp, h);
- @<End progress report@>;
- if ( mp->internal[mp_tracing_output]>0 )
- mp_print_edges(mp, h," (just shipped out)",true);
-}
-
-@ @<Declarations@>=
-void mp_shipout_backend (MP mp, pointer h);
-
-@ @c
-void mp_shipout_backend (MP mp, pointer h) {
- mp_edge_object *hh; /* the first graphical object */
- hh = mp_gr_export(mp,h);
- mp_gr_ship_out (hh,
- (mp->internal[mp_prologues]>>16),
- (mp->internal[mp_procset]>>16));
- mp_gr_toss_objects(hh);
-}
-
-@ @<Exported types@>=
-typedef void (*mp_backend_writer)(MP, int);
-
-@ @<Option variables@>=
-mp_backend_writer shipout_backend;
-
-@ @<Allocate or initialize ...@>=
-set_callback_option(shipout_backend);
-
-@ Now that we've finished |ship_out|, let's look at the other commands
-by which a user can send things to the \.{GF} file.
-
-@ @<Determine if a character has been shipped out@>=
-{
- mp->cur_exp=mp_round_unscaled(mp, mp->cur_exp) % 256;
- if ( mp->cur_exp<0 ) mp->cur_exp=mp->cur_exp+256;
- boolean_reset(mp->char_exists[mp->cur_exp]);
- mp->cur_type=mp_boolean_type;
-}
-
-@ @<Glob...@>=
-psout_data ps;
-
-@ @<Allocate or initialize ...@>=
-mp_backend_initialize(mp);
-
-@ @<Dealloc...@>=
-mp_backend_free(mp);
-
-
-@* \[45] Dumping and undumping the tables.
-After \.{INIMP} has seen a collection of macros, it
-can write all the necessary information on an auxiliary file so
-that production versions of \MP\ are able to initialize their
-memory at high speed. The present section of the program takes
-care of such output and input. We shall consider simultaneously
-the processes of storing and restoring,
-so that the inverse relation between them is clear.
-@.INIMP@>
-
-The global variable |mem_ident| is a string that is printed right
-after the |banner| line when \MP\ is ready to start. For \.{INIMP} this
-string says simply `\.{(INIMP)}'; for other versions of \MP\ it says,
-for example, `\.{(mem=plain 1990.4.14)}', showing the year,
-month, and day that the mem file was created. We have |mem_ident=0|
-before \MP's tables are loaded.
-
-@<Glob...@>=
-char * mem_ident;
-
-@ @<Set init...@>=
-mp->mem_ident=NULL;
-
-@ @<Initialize table entries...@>=
-mp->mem_ident=xstrdup(" (INIMP)");
-
-@ @<Declare act...@>=
-void mp_store_mem_file (MP mp) ;
-
-@ @c void mp_store_mem_file (MP mp) {
- integer k; /* all-purpose index */
- pointer p,q; /* all-purpose pointers */
- integer x; /* something to dump */
- four_quarters w; /* four ASCII codes */
- memory_word WW;
- @<Create the |mem_ident|, open the mem file,
- and inform the user that dumping has begun@>;
- @<Dump constants for consistency check@>;
- @<Dump the string pool@>;
- @<Dump the dynamic memory@>;
- @<Dump the table of equivalents and the hash table@>;
- @<Dump a few more things and the closing check word@>;
- @<Close the mem file@>;
-}
-
-@ Corresponding to the procedure that dumps a mem file, we also have a function
-that reads~one~in. The function returns |false| if the dumped mem is
-incompatible with the present \MP\ table sizes, etc.
-
-@d off_base 6666 /* go here if the mem file is unacceptable */
-@d too_small(A) { wake_up_terminal;
- wterm_ln("---! Must increase the "); wterm((A));
-@.Must increase the x@>
- goto OFF_BASE;
- }
-
-@c
-boolean mp_load_mem_file (MP mp) {
- integer k; /* all-purpose index */
- pointer p,q; /* all-purpose pointers */
- integer x; /* something undumped */
- str_number s; /* some temporary string */
- four_quarters w; /* four ASCII codes */
- memory_word WW;
- @<Undump constants for consistency check@>;
- @<Undump the string pool@>;
- @<Undump the dynamic memory@>;
- @<Undump the table of equivalents and the hash table@>;
- @<Undump a few more things and the closing check word@>;
- return true; /* it worked! */
-OFF_BASE:
- wake_up_terminal;
- wterm_ln("(Fatal mem file error; I'm stymied)\n");
-@.Fatal mem file error@>
- return false;
-}
-
-@ @<Declarations@>=
-boolean mp_load_mem_file (MP mp) ;
-
-@ Mem files consist of |memory_word| items, and we use the following
-macros to dump words of different types:
-
-@d dump_wd(A) { WW=(A); (mp->write_binary_file)(mp,mp->mem_file,&WW,sizeof(WW)); }
-@d dump_int(A) { int cint=(A); (mp->write_binary_file)(mp,mp->mem_file,&cint,sizeof(cint)); }
-@d dump_hh(A) { WW.hh=(A); (mp->write_binary_file)(mp,mp->mem_file,&WW,sizeof(WW)); }
-@d dump_qqqq(A) { WW.qqqq=(A); (mp->write_binary_file)(mp,mp->mem_file,&WW,sizeof(WW)); }
-@d dump_string(A) { dump_int(strlen(A)+1);
- (mp->write_binary_file)(mp,mp->mem_file,A,strlen(A)+1); }
-
-@<Glob...@>=
-void * mem_file; /* for input or output of mem information */
-
-@ The inverse macros are slightly more complicated, since we need to check
-the range of the values we are reading in. We say `|undump(a)(b)(x)|' to
-read an integer value |x| that is supposed to be in the range |a<=x<=b|.
-
-@d mgeti(A) do {
- size_t wanted = sizeof(A);
- void *A_ptr = &A;
- (mp->read_binary_file)(mp, mp->mem_file,&A_ptr,&wanted);
- if (wanted!=sizeof(A)) goto OFF_BASE;
-} while (0)
-
-@d mgetw(A) do {
- size_t wanted = sizeof(A);
- void *A_ptr = &A;
- (mp->read_binary_file)(mp, mp->mem_file,&A_ptr,&wanted);
- if (wanted!=sizeof(A)) goto OFF_BASE;
-} while (0)
-
-@d undump_wd(A) { mgetw(WW); A=WW; }
-@d undump_int(A) { int cint; mgeti(cint); A=cint; }
-@d undump_hh(A) { mgetw(WW); A=WW.hh; }
-@d undump_qqqq(A) { mgetw(WW); A=WW.qqqq; }
-@d undump_strings(A,B,C) {
- undump_int(x); if ( (x<(A)) || (x>(B)) ) goto OFF_BASE; else C=str(x); }
-@d undump(A,B,C) { undump_int(x); if ( (x<(A)) || (x>(int)(B)) ) goto OFF_BASE; else C=x; }
-@d undump_size(A,B,C,D) { undump_int(x);
- if (x<(A)) goto OFF_BASE;
- if (x>(B)) { too_small((C)); } else { D=x;} }
-@d undump_string(A) do {
- size_t the_wanted;
- void *the_string;
- integer XX=0;
- undump_int(XX);
- the_wanted = XX;
- the_string = xmalloc(XX,sizeof(char));
- (mp->read_binary_file)(mp,mp->mem_file,&the_string,&the_wanted);
- A = (char *)the_string;
- if (the_wanted!=(size_t)XX) goto OFF_BASE;
-} while (0)
-
-@ The next few sections of the program should make it clear how we use the
-dump/undump macros.
-
-@<Dump constants for consistency check@>=
-dump_int(mp->mem_top);
-dump_int(mp->hash_size);
-dump_int(mp->hash_prime)
-dump_int(mp->param_size);
-dump_int(mp->max_in_open);
-
-@ Sections of a \.{WEB} program that are ``commented out'' still contribute
-strings to the string pool; therefore \.{INIMP} and \MP\ will have
-the same strings. (And it is, of course, a good thing that they do.)
-@.WEB@>
-@^string pool@>
-
-@<Undump constants for consistency check@>=
-undump_int(x); mp->mem_top = x;
-undump_int(x); if (mp->hash_size != x) goto OFF_BASE;
-undump_int(x); if (mp->hash_prime != x) goto OFF_BASE;
-undump_int(x); if (mp->param_size != x) goto OFF_BASE;
-undump_int(x); if (mp->max_in_open != x) goto OFF_BASE
-
-@ We do string pool compaction to avoid dumping unused strings.
-
-@d dump_four_ASCII
- w.b0=qi(mp->str_pool[k]); w.b1=qi(mp->str_pool[k+1]);
- w.b2=qi(mp->str_pool[k+2]); w.b3=qi(mp->str_pool[k+3]);
- dump_qqqq(w)
-
-@<Dump the string pool@>=
-mp_do_compaction(mp, mp->pool_size);
-dump_int(mp->pool_ptr);
-dump_int(mp->max_str_ptr);
-dump_int(mp->str_ptr);
-k=0;
-while ( (mp->next_str[k]==k+1) && (k<=mp->max_str_ptr) )
- incr(k);
-dump_int(k);
-while ( k<=mp->max_str_ptr ) {
- dump_int(mp->next_str[k]); incr(k);
-}
-k=0;
-while (1) {
- dump_int(mp->str_start[k]); /* TODO: valgrind warning here */
- if ( k==mp->str_ptr ) {
- break;
- } else {
- k=mp->next_str[k];
- }
-}
-k=0;
-while (k+4<mp->pool_ptr ) {
- dump_four_ASCII; k=k+4;
-}
-k=mp->pool_ptr-4; dump_four_ASCII;
-mp_print_ln(mp); mp_print(mp, "at most "); mp_print_int(mp, mp->max_str_ptr);
-mp_print(mp, " strings of total length ");
-mp_print_int(mp, mp->pool_ptr)
-
-@ @d undump_four_ASCII
- undump_qqqq(w);
- mp->str_pool[k]=qo(w.b0); mp->str_pool[k+1]=qo(w.b1);
- mp->str_pool[k+2]=qo(w.b2); mp->str_pool[k+3]=qo(w.b3)
-
-@<Undump the string pool@>=
-undump_int(mp->pool_ptr);
-mp_reallocate_pool(mp, mp->pool_ptr) ;
-undump_int(mp->max_str_ptr);
-mp_reallocate_strings (mp,mp->max_str_ptr) ;
-undump(0,mp->max_str_ptr,mp->str_ptr);
-undump(0,mp->max_str_ptr+1,s);
-for (k=0;k<=s-1;k++)
- mp->next_str[k]=k+1;
-for (k=s;k<=mp->max_str_ptr;k++)
- undump(s+1,mp->max_str_ptr+1,mp->next_str[k]);
-mp->fixed_str_use=0;
-k=0;
-while (1) {
- undump(0,mp->pool_ptr,mp->str_start[k]);
- if ( k==mp->str_ptr ) break;
- mp->str_ref[k]=max_str_ref;
- incr(mp->fixed_str_use);
- mp->last_fixed_str=k; k=mp->next_str[k];
-}
-k=0;
-while ( k+4<mp->pool_ptr ) {
- undump_four_ASCII; k=k+4;
-}
-k=mp->pool_ptr-4; undump_four_ASCII;
-mp->init_str_use=mp->fixed_str_use; mp->init_pool_ptr=mp->pool_ptr;
-mp->max_pool_ptr=mp->pool_ptr;
-mp->strs_used_up=mp->fixed_str_use;
-mp->pool_in_use=mp->str_start[mp->str_ptr]; mp->strs_in_use=mp->fixed_str_use;
-mp->max_pl_used=mp->pool_in_use; mp->max_strs_used=mp->strs_in_use;
-mp->pact_count=0; mp->pact_chars=0; mp->pact_strs=0;
-
-@ By sorting the list of available spaces in the variable-size portion of
-|mem|, we are usually able to get by without having to dump very much
-of the dynamic memory.
-
-We recompute |var_used| and |dyn_used|, so that \.{INIMP} dumps valid
-information even when it has not been gathering statistics.
-
-@<Dump the dynamic memory@>=
-mp_sort_avail(mp); mp->var_used=0;
-dump_int(mp->lo_mem_max); dump_int(mp->rover);
-p=0; q=mp->rover; x=0;
-do {
- for (k=p;k<= q+1;k++)
- dump_wd(mp->mem[k]);
- x=x+q+2-p; mp->var_used=mp->var_used+q-p;
- p=q+node_size(q); q=rlink(q);
-} while (q!=mp->rover);
-mp->var_used=mp->var_used+mp->lo_mem_max-p;
-mp->dyn_used=mp->mem_end+1-mp->hi_mem_min;
-for (k=p;k<= mp->lo_mem_max;k++ )
- dump_wd(mp->mem[k]);
-x=x+mp->lo_mem_max+1-p;
-dump_int(mp->hi_mem_min); dump_int(mp->avail);
-for (k=mp->hi_mem_min;k<=mp->mem_end;k++ )
- dump_wd(mp->mem[k]);
-x=x+mp->mem_end+1-mp->hi_mem_min;
-p=mp->avail;
-while ( p!=null ) {
- decr(mp->dyn_used); p=link(p);
-}
-dump_int(mp->var_used); dump_int(mp->dyn_used);
-mp_print_ln(mp); mp_print_int(mp, x);
-mp_print(mp, " memory locations dumped; current usage is ");
-mp_print_int(mp, mp->var_used); mp_print_char(mp, '&'); mp_print_int(mp, mp->dyn_used)
-
-@ @<Undump the dynamic memory@>=
-undump(lo_mem_stat_max+1000,hi_mem_stat_min-1,mp->lo_mem_max);
-undump(lo_mem_stat_max+1,mp->lo_mem_max,mp->rover);
-p=0; q=mp->rover;
-do {
- for (k=p;k<= q+1; k++)
- undump_wd(mp->mem[k]);
- p=q+node_size(q);
- if ( (p>mp->lo_mem_max)||((q>=rlink(q))&&(rlink(q)!=mp->rover)) )
- goto OFF_BASE;
- q=rlink(q);
-} while (q!=mp->rover);
-for (k=p;k<=mp->lo_mem_max;k++ )
- undump_wd(mp->mem[k]);
-undump(mp->lo_mem_max+1,hi_mem_stat_min,mp->hi_mem_min);
-undump(null,mp->mem_top,mp->avail); mp->mem_end=mp->mem_top;
-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|...@>=
-{
- xfree(mp->mem_ident);
- mp->mem_ident = xmalloc(256,1);
- snprintf(mp->mem_ident,256," (mem=%s %i.%i.%i)",
- mp->job_name,
- (int)(mp_round_unscaled(mp, mp->internal[mp_year]) % 100),
- (int)mp_round_unscaled(mp, mp->internal[mp_month]),
- (int)mp_round_unscaled(mp, mp->internal[mp_day]));
- mp_pack_job_name(mp, mem_extension);
- while (! mp_w_open_out(mp, &mp->mem_file) )
- mp_prompt_file_name(mp, "mem file name", mem_extension);
- mp_print_nl(mp, "Beginning to dump on file ");
-@.Beginning to dump...@>
- mp_print(mp, mp->name_of_file);
- mp_print_nl(mp, mp->mem_ident);
-}
-
-@ @<Dealloc variables@>=
-xfree(mp->mem_ident);
-
-@ @<Close the mem file@>=
-(mp->close_file)(mp,mp->mem_file)
-
-@* \[46] The main program.
-This is it: the part of \MP\ that executes all those procedures we have
-written.
-
-Well---almost. We haven't put the parsing subroutines into the
-program yet; and we'd better leave space for a few more routines that may
-have been forgotten.
-
-@c @<Declare the basic parsing subroutines@>
-@<Declare miscellaneous procedures that were declared |forward|@>
-@<Last-minute procedures@>
-
-@ We've noted that there are two versions of \MP. One, called \.{INIMP},
-@.INIMP@>
-has to be run first; it initializes everything from scratch, without
-reading a mem file, and it has the capability of dumping a mem file.
-The other one is called `\.{VIRMP}'; it is a ``virgin'' program that needs
-@.VIRMP@>
-to input a mem file in order to get started. \.{VIRMP} typically has
-a bit more memory capacity than \.{INIMP}, because it does not need the
-space consumed by the dumping/undumping routines and the numerous calls on
-|primitive|, etc.
-
-The \.{VIRMP} program cannot read a mem file instantaneously, of course;
-the best implementations therefore allow for production versions of \MP\ that
-not only avoid the loading routine for object code, they also have
-a mem file pre-loaded.
-
-@ @<Option variables@>=
-int ini_version; /* are we iniMP? */
-
-@ @<Set |ini_version|@>=
-mp->ini_version = (opt->ini_version ? true : false);
-
-@ Here we do whatever is needed to complete \MP's job gracefully on the
-local operating system. The code here might come into play after a fatal
-error; it must therefore consist entirely of ``safe'' operations that
-cannot produce error messages. For example, it would be a mistake to call
-|str_room| or |make_string| at this time, because a call on |overflow|
-might lead to an infinite loop.
-@^system dependencies@>
-
-This program doesn't bother to close the input files that may still be open.
-
-@<Last-minute...@>=
-void mp_close_files_and_terminate (MP mp) {
- integer k; /* all-purpose index */
- integer LH; /* the length of the \.{TFM} header, in words */
- int lk_offset; /* extra words inserted at beginning of |lig_kern| array */
- pointer p; /* runs through a list of \.{TFM} dimensions */
- @<Close all open files in the |rd_file| and |wr_file| arrays@>;
- if ( mp->internal[mp_tracing_stats]>0 )
- @<Output statistics about this job@>;
- wake_up_terminal;
- @<Do all the finishing work on the \.{TFM} file@>;
- @<Explain what output files were written@>;
- if ( mp->log_opened ){
- wlog_cr;
- (mp->close_file)(mp,mp->log_file);
- mp->selector=mp->selector-2;
- if ( mp->selector==term_only ) {
- mp_print_nl(mp, "Transcript written on ");
-@.Transcript written...@>
- mp_print(mp, mp->log_name); mp_print_char(mp, '.');
- }
- }
- mp_print_ln(mp);
- t_close_out;
- t_close_in;
-}
-
-@ @<Declarations@>=
-void mp_close_files_and_terminate (MP mp) ;
-
-@ @<Close all open files in the |rd_file| and |wr_file| arrays@>=
-if (mp->rd_fname!=NULL) {
- for (k=0;k<=(int)mp->read_files-1;k++ ) {
- if ( mp->rd_fname[k]!=NULL ) {
- (mp->close_file)(mp,mp->rd_file[k]);
- xfree(mp->rd_fname[k]);
- }
- }
-}
-if (mp->wr_fname!=NULL) {
- for (k=0;k<=(int)mp->write_files-1;k++) {
- if ( mp->wr_fname[k]!=NULL ) {
- (mp->close_file)(mp,mp->wr_file[k]);
- 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; link(mp->rover)=empty_flag; mp->lo_mem_max=mp->hi_mem_min-1;
-if ( mp->lo_mem_max-mp->rover>max_halfword ) mp->lo_mem_max=max_halfword+mp->rover;
-node_size(mp->rover)=mp->lo_mem_max-mp->rover;
-llink(mp->rover)=mp->rover; rlink(mp->rover)=mp->rover;
-link(mp->lo_mem_max)=null; info(mp->lo_mem_max)=null
-
-@ The present section goes directly to the log file instead of using
-|print| commands, because there's no need for these strings to take
-up |str_pool| memory when a non-{\bf stat} version of \MP\ is being used.
-
-@<Output statistics...@>=
-if ( mp->log_opened ) {
- char s[128];
- wlog_ln(" ");
- wlog_ln("Here is how much of MetaPost's memory you used:");
-@.Here is how much...@>
- snprintf(s,128," %i string%s out of %i",(int)mp->max_strs_used-mp->init_str_use,
- (mp->max_strs_used!=mp->init_str_use+1 ? "s" : ""),
- (int)(mp->max_strings-1-mp->init_str_use));
- wlog_ln(s);
- snprintf(s,128," %i string characters out of %i",
- (int)mp->max_pl_used-mp->init_pool_ptr,
- (int)mp->pool_size-mp->init_pool_ptr);
- wlog_ln(s);
- snprintf(s,128," %i words of memory out of %i",
- (int)mp->lo_mem_max+mp->mem_end-mp->hi_mem_min+2,
- (int)mp->mem_end);
- wlog_ln(s);
- snprintf(s,128," %i symbolic tokens out of %i", (int)mp->st_count, (int)mp->hash_size);
- wlog_ln(s);
- snprintf(s,128," %ii,%in,%ip,%ib stack positions out of %ii,%in,%ip,%ib",
- (int)mp->max_in_stack,(int)mp->int_ptr,
- (int)mp->max_param_stack,(int)mp->max_buf_stack+1,
- (int)mp->stack_size,(int)mp->max_internal,(int)mp->param_size,(int)mp->buf_size);
- wlog_ln(s);
- snprintf(s,128," %i string compactions (moved %i characters, %i strings)",
- (int)mp->pact_count,(int)mp->pact_chars,(int)mp->pact_strs);
- wlog_ln(s);
-}
-
-@ It is nice to have have some of the stats available from the API.
-
-@<Exported function ...@>=
-int mp_memory_usage (MP mp );
-int mp_hash_usage (MP mp );
-int mp_param_usage (MP mp );
-int mp_open_usage (MP mp );
-
-@ @c
-int mp_memory_usage (MP mp ) {
- return (int)mp->lo_mem_max+mp->mem_end-mp->hi_mem_min+2;
-}
-int mp_hash_usage (MP mp ) {
- return (int)mp->st_count;
-}
-int mp_param_usage (MP mp ) {
- return (int)mp->max_param_stack;
-}
-int mp_open_usage (MP mp ) {
- return (int)mp->max_in_stack;
-}
-
-@ We get to the |final_cleanup| routine when \&{end} or \&{dump} has
-been scanned.
-
-@<Last-minute...@>=
-void mp_final_cleanup (MP mp) {
- small_number c; /* 0 for \&{end}, 1 for \&{dump} */
- c=mp->cur_mod;
- if ( mp->job_name==NULL ) mp_open_log_file(mp);
- while ( mp->input_ptr>0 ) {
- if ( token_state ) mp_end_token_list(mp);
- else mp_end_file_reading(mp);
- }
- while ( mp->loop_ptr!=null ) mp_stop_iteration(mp);
- while ( mp->open_parens>0 ) {
- mp_print(mp, " )"); decr(mp->open_parens);
- };
- while ( mp->cond_ptr!=null ) {
- mp_print_nl(mp, "(end occurred when ");
-@.end occurred...@>
- mp_print_cmd_mod(mp, fi_or_else,mp->cur_if);
- /* `\.{if}' or `\.{elseif}' or `\.{else}' */
- if ( mp->if_line!=0 ) {
- mp_print(mp, " on line "); mp_print_int(mp, mp->if_line);
- }
- mp_print(mp, " was incomplete)");
- mp->if_line=if_line_field(mp->cond_ptr);
- mp->cur_if=name_type(mp->cond_ptr); mp->cond_ptr=link(mp->cond_ptr);
- }
- if ( mp->history!=mp_spotless )
- if ( ((mp->history==mp_warning_issued)||(mp->interaction<mp_error_stop_mode)) )
- if ( mp->selector==term_and_log ) {
- mp->selector=term_only;
- mp_print_nl(mp, "(see the transcript file for additional information)");
-@.see the transcript file...@>
- mp->selector=term_and_log;
- }
- if ( c==1 ) {
- if (mp->ini_version) {
- mp_store_mem_file(mp); return;
- }
- mp_print_nl(mp, "(dump is performed only by INIMP)"); return;
-@.dump...only by INIMP@>
- }
-}
-
-@ @<Declarations@>=
-void mp_final_cleanup (MP mp) ;
-void mp_init_prim (MP mp) ;
-void mp_init_tab (MP mp) ;
-
-@ @<Last-minute...@>=
-void mp_init_prim (MP mp) { /* initialize all the primitives */
- @<Put each...@>;
-}
-@#
-void mp_init_tab (MP mp) { /* initialize other tables */
- integer k; /* all-purpose index */
- @<Initialize table entries (done by \.{INIMP} only)@>;
-}
-
-
-@ When we begin the following code, \MP's tables may still contain garbage;
-the strings might not even be present. Thus we must proceed cautiously to get
-bootstrapped in.
-
-But when we finish this part of the program, \MP\ is ready to call on the
-|main_control| routine to do its work.
-
-@<Get the first line...@>=
-{
- @<Initialize the input routines@>;
- if ( (mp->mem_ident==NULL)||(mp->buffer[loc]=='&') ) {
- if ( mp->mem_ident!=NULL ) {
- mp_do_initialize(mp); /* erase preloaded mem */
- }
- if ( ! mp_open_mem_file(mp) ) return mp_fatal_error_stop;
- if ( ! mp_load_mem_file(mp) ) {
- (mp->close_file)(mp, mp->mem_file);
- return mp_fatal_error_stop;
- }
- (mp->close_file)(mp, mp->mem_file);
- while ( (loc<limit)&&(mp->buffer[loc]==' ') ) incr(loc);
- }
- mp->buffer[limit]='%';
- mp_fix_date_and_time(mp);
- if (mp->random_seed==0)
- mp->random_seed = (mp->internal[mp_time] / unity)+mp->internal[mp_day];
- mp_init_randoms(mp, mp->random_seed);
- @<Initialize the print |selector|...@>;
- if ( loc<limit ) if ( mp->buffer[loc]!='\\' )
- mp_start_input(mp); /* \&{input} assumed */
-}
-
-@ @<Run inimpost commands@>=
-{
- mp_get_strings_started(mp);
- mp_init_tab(mp); /* initialize the tables */
- mp_init_prim(mp); /* call |primitive| for each primitive */
- mp->init_str_use=mp->str_ptr; mp->init_pool_ptr=mp->pool_ptr;
- mp->max_str_ptr=mp->str_ptr; mp->max_pool_ptr=mp->pool_ptr;
- mp_fix_date_and_time(mp);
-}
-
-
-@* \[47] Debugging.
-Once \MP\ is working, you should be able to diagnose most errors with
-the \.{show} commands and other diagnostic features. But for the initial
-stages of debugging, and for the revelation of really deep mysteries, you
-can compile \MP\ with a few more aids. An additional routine called |debug_help|
-will also come into play when you type `\.D' after an error message;
-|debug_help| also occurs just before a fatal error causes \MP\ to succumb.
-@^debugging@>
-@^system dependencies@>
-
-The interface to |debug_help| is primitive, but it is good enough when used
-with a debugger that allows you to set breakpoints and to read
-variables and change their values. After getting the prompt `\.{debug \#}', you
-type either a negative number (this exits |debug_help|), or zero (this
-goes to a location where you can set a breakpoint, thereby entering into
-dialog with the debugger), or a positive number |m| followed by
-an argument |n|. The meaning of |m| and |n| will be clear from the
-program below. (If |m=13|, there is an additional argument, |l|.)
-@.debug \#@>
-
-@<Last-minute...@>=
-void mp_debug_help (MP mp) { /* routine to display various things */
- integer k;
- int l,m,n;
- char *aline;
- size_t len;
- while (1) {
- wake_up_terminal;
- mp_print_nl(mp, "debug # (-1 to exit):"); update_terminal;
-@.debug \#@>
- m = 0;
- aline = (mp->read_ascii_file)(mp,mp->term_in, &len);
- if (len) { sscanf(aline,"%i",&m); xfree(aline); }
- if ( m<=0 )
- return;
- n = 0 ;
- aline = (mp->read_ascii_file)(mp,mp->term_in, &len);
- if (len) { sscanf(aline,"%i",&n); xfree(aline); }
- switch (m) {
- @<Numbered cases for |debug_help|@>;
- default: mp_print(mp, "?"); break;
- }
- }
-}
-
-@ @<Numbered cases...@>=
-case 1: mp_print_word(mp, mp->mem[n]); /* display |mem[n]| in all forms */
- break;
-case 2: mp_print_int(mp, info(n));
- break;
-case 3: mp_print_int(mp, link(n));
- break;
-case 4: mp_print_int(mp, eq_type(n)); mp_print_char(mp, ':'); mp_print_int(mp, equiv(n));
- break;
-case 5: mp_print_variable_name(mp, n);
- break;
-case 6: mp_print_int(mp, mp->internal[n]);
- break;
-case 7: mp_do_show_dependencies(mp);
- break;
-case 9: mp_show_token_list(mp, n,null,100000,0);
- break;
-case 10: mp_print_str(mp, n);
- break;
-case 11: mp_check_mem(mp, n>0); /* check wellformedness; print new busy locations if |n>0| */
- break;
-case 12: mp_search_mem(mp, n); /* look for pointers to |n| */
- break;
-case 13:
- l = 0;
- aline = (mp->read_ascii_file)(mp,mp->term_in, &len);
- if (len) { sscanf(aline,"%i",&l); xfree(aline); }
- mp_print_cmd_mod(mp, n,l);
- break;
-case 14: for (k=0;k<=n;k++) mp_print_str(mp, mp->buffer[k]);
- break;
-case 15: mp->panicking=! mp->panicking;
- break;
-
-
-@ Saving the filename template
-
-@<Save the filename template@>=
-{
- if ( mp->filename_template!=0 ) delete_str_ref(mp->filename_template);
- if ( length(mp->cur_exp)==0 ) mp->filename_template=0;
- else {
- mp->filename_template=mp->cur_exp; add_str_ref(mp->filename_template);
- }
-}
-
-@* \[48] System-dependent changes.
-This section should be replaced, if necessary, by any special
-modification of the program
-that are necessary to make \MP\ work at a particular installation.
-It is usually best to design your change file so that all changes to
-previous sections preserve the section numbering; then everybody's version
-will be consistent with the published program. More extensive changes,
-which introduce new sections, can be inserted here; then only the index
-itself will get a new section number.
-@^system dependencies@>
-
-@* \[49] Index.
-Here is where you can find all uses of each identifier in the program,
-with underlined entries pointing to where the identifier was defined.
-If the identifier is only one letter long, however, you get to see only
-the underlined entries. {\sl All references are to section numbers instead of
-page numbers.}
-
-This index also lists error messages and other aspects of the program
-that you might want to look up some day. For example, the entry
-for ``system dependencies'' lists all sections that should receive
-special attention from people who are installing \MP\ in a new
-operating environment. A list of various things that can't happen appears
-under ``this can't happen''.
-Approximately 25 sections are listed under ``inner loop''; these account
-for more than 60\pct! of \MP's running time, exclusive of input and output.
diff --git a/Build/source/texk/web2c/luatexdir/lua/psout.w b/Build/source/texk/web2c/luatexdir/lua/psout.w
deleted file mode 100644
index 90cf6923e01..00000000000
--- a/Build/source/texk/web2c/luatexdir/lua/psout.w
+++ /dev/null
@@ -1,5686 +0,0 @@
-% $Id: mp.web,v 1.8 2005/08/24 10:54:02 taco Exp $
-% MetaPost, by John Hobby. Public domain.
-
-% Much of this program was copied with permission from MF.web Version 1.9
-% It interprets a language very similar to D.E. Knuth's METAFONT, but with
-% changes designed to make it more suitable for PostScript output.
-
-% TeX is a trademark of the American Mathematical Society.
-% METAFONT is a trademark of Addison-Wesley Publishing Company.
-% PostScript is a trademark of Adobe Systems Incorporated.
-
-% Here is TeX material that gets inserted after \input webmac
-\def\hang{\hangindent 3em\noindent\ignorespaces}
-\def\textindent#1{\hangindent2.5em\noindent\hbox to2.5em{\hss#1 }\ignorespaces}
-\def\PASCAL{Pascal}
-\def\ps{PostScript}
-\def\ph{\hbox{Pascal-H}}
-\def\psqrt#1{\sqrt{\mathstrut#1}}
-\def\k{_{k+1}}
-\def\pct!{{\char`\%}} % percent sign in ordinary text
-\font\tenlogo=logo10 % font used for the METAFONT logo
-\font\logos=logosl10
-\def\MF{{\tenlogo META}\-{\tenlogo FONT}}
-\def\MP{{\tenlogo META}\-{\tenlogo POST}}
-\def\<#1>{$\langle#1\rangle$}
-\def\section{\mathhexbox278}
-\let\swap=\leftrightarrow
-\def\round{\mathop{\rm round}\nolimits}
-\mathchardef\vb="026A % synonym for `\|'
-\def\[#1]{} % from pascal web
-\def\(#1){} % this is used to make section names sort themselves better
-\def\9#1{} % this is used for sort keys in the index via @@:sort key}{entry@@>
-
-\let\?=\relax % we want to be able to \write a \?
-
-\def\title{MetaPost \ps\ output}
-\def\topofcontents{\hsize 5.5in
- \vglue -30pt plus 1fil minus 1.5in
- \def\?##1]{\hbox to 1in{\hfil##1.\ }}
- }
-\def\botofcontents{\vskip 0pt plus 1fil minus 1.5in}
-\pdfoutput=1
-\pageno=3
-
-@
-@d true 1
-@d false 0
-@d null_font 0
-@d null 0
-@d unity 0200000 /* $2^{16}$, represents 1.00000 */
-@d el_gordo 017777777777 /* $2^{31}-1$, the largest value that \MP\ likes */
-@d incr(A) (A)=(A)+1 /* increase a variable by unity */
-@d decr(A) (A)=(A)-1 /* decrease a variable by unity */
-@d negate(A) (A)=-(A) /* change the sign of a variable */
-@d odd(A) ((A)%2==1)
-@d half(A) ((A)/2)
-@d print_err(A) mp_print_err(mp,(A))
-@d max_quarterword 0x3FFF /* largest allowable value in a |quarterword| */
-
-@c
-#include <stdio.h>
-#include <stdlib.h>
-#include <string.h>
-#include <stdarg.h>
-#include <assert.h>
-#include "avl.h"
-#include "mplib.h"
-#include "mpmp.h" /* internal header */
-#include "mppsout.h" /* internal header */
-@h
-@<Declarations@>
-@<Static variables in the outer block@>
-
-@ There is a small bit of code from the backend that bleads through
-to the frontend because I do not know how to set up the includes
-properly. Those are the definitions of |struct libavl_allocator|
-and |typedef struct psout_data_struct * psout_data|.
-
-The |libavl_allocator| is a trick that makes sure that frontends
-do not need |avl.h|, and the |psout_data| is needed for the backend
-data structure.
-
-@ @(mppsout.h@>=
-@<Types...@>
-typedef struct psout_data_struct {
- @<Globals@>
-} psout_data_struct ;
-@<Exported function headers@>
-
-@ @<Exported function headers@>=
-void mp_backend_initialize (MP mp) ;
-void mp_backend_free (MP mp) ;
-
-@
-@c void mp_backend_initialize (MP mp) {
- mp->ps = mp_xmalloc(mp,1,sizeof(psout_data_struct));
- @<Set initial values@>;
-}
-void mp_backend_free (MP mp) {
- @<Dealloc variables@>;
- enc_free(mp);
- t1_free(mp);
- fm_free(mp);
- mp_xfree(mp->ps);
- mp->ps = NULL;
-}
-
-@ Writing to ps files
-
-@<Globals@>=
-integer ps_offset;
- /* the number of characters on the current \ps\ file line */
-
-@ @<Set initial values@>=
-mp->ps->ps_offset = 0;
-
-@
-
-@d wps(A) (mp->write_ascii_file)(mp,mp->ps_file,(A))
-@d wps_chr(A) do {
- char ss[2];
- ss[0]=(A); ss[1]=0;
- (mp->write_ascii_file)(mp,mp->ps_file,(char *)ss);
-} while (0)
-@d wps_cr (mp->write_ascii_file)(mp,mp->ps_file,"\n")
-@d wps_ln(A) { wterm_cr; (mp->write_ascii_file)(mp,mp->ps_file,(A)); }
-
-@c
-void mp_ps_print_ln (MP mp) { /* prints an end-of-line */
- wps_cr;
- mp->ps->ps_offset=0;
-}
-
-@ @c
-void mp_ps_print_char (MP mp, ASCII_code s) { /* prints a single character */
- if ( s==13 ) {
- wps_cr; mp->ps->ps_offset=0;
- } else {
- wps_chr(s); incr(mp->ps->ps_offset);
- }
-}
-
-@ @c
-void mp_ps_do_print (MP mp, const char *ss, unsigned int len) { /* prints string |s| */
- unsigned int j = 0;
- while ( j<len ){
- mp_ps_print_char(mp, ss[j]); incr(j);
- }
-}
-
-@ Deciding where to break the ps output line.
-
-@d ps_room(A) if ( (mp->ps->ps_offset+(int)(A))>mp->max_print_line ) {
- mp_ps_print_ln(mp); /* optional line break */
-}
-
-@c
-void mp_ps_print (MP mp, const char *ss) {
- ps_room(strlen(ss));
- mp_ps_do_print(mp, ss, strlen(ss));
-}
-
-@ The procedure |print_nl| is like |print|, but it makes sure that the
-string appears at the beginning of a new line.
-
-@c
-void mp_ps_print_nl (MP mp, const char *s) { /* prints string |s| at beginning of line */
- if ( mp->ps->ps_offset>0 ) mp_ps_print_ln(mp);
- mp_ps_print(mp, s);
-}
-
-@ An array of digits in the range |0..9| is printed by |print_the_digs|.
-
-@c
-void mp_ps_print_the_digs (MP mp, eight_bits k) {
- /* prints |dig[k-1]|$\,\ldots\,$|dig[0]| */
- while ( k-->0 ){
- mp_ps_print_char(mp, '0'+mp->dig[k]);
- }
-}
-
-@ The following procedure, which prints out the decimal representation of a
-given integer |n|, has been written carefully so that it works properly
-if |n=0| or if |(-n)| would cause overflow. It does not apply |mod| or |div|
-to negative arguments, since such operations are not implemented consistently
-by all \PASCAL\ compilers.
-
-@c
-void mp_ps_print_int (MP mp,integer n) { /* prints an integer in decimal form */
- integer m; /* used to negate |n| in possibly dangerous cases */
- int k = 0; /* index to current digit; we assume that $|n|<10^{23}$ */
- if ( n<0 ) {
- mp_ps_print_char(mp, '-');
- if ( n>-100000000 ) {
- negate(n);
- } else {
- m=-1-n; n=m / 10; m=(m % 10)+1; k=1;
- if ( m<10 ) {
- mp->dig[0]=m;
- } else {
- mp->dig[0]=0; incr(n);
- }
- }
- }
- do {
- mp->dig[k]=n % 10; n=n / 10; incr(k);
- } while (n!=0);
- mp_ps_print_the_digs(mp, k);
-}
-
-@ @<Internal ...@>=
-void mp_ps_print_int (MP mp,integer n);
-
-@ \MP\ also makes use of a trivial procedure to print two digits. The
-following subroutine is usually called with a parameter in the range |0<=n<=99|.
-
-@c
-void mp_ps_print_dd (MP mp,integer n) { /* prints two least significant digits */
- n=abs(n) % 100;
- mp_ps_print_char(mp, '0'+(n / 10));
- mp_ps_print_char(mp, '0'+(n % 10));
-}
-
-@ Conversely, here is a procedure analogous to |print_int|. If the output
-of this procedure is subsequently read by \MP\ and converted by the
-|round_decimals| routine above, it turns out that the original value will
-be reproduced exactly. A decimal point is printed only if the value is
-not an integer. If there is more than one way to print the result with
-the optimum number of digits following the decimal point, the closest
-possible value is given.
-
-The invariant relation in the \&{repeat} loop is that a sequence of
-decimal digits yet to be printed will yield the original number if and only if
-they form a fraction~$f$ in the range $s-\delta\L10\cdot2^{16}f<s$.
-We can stop if and only if $f=0$ satisfies this condition; the loop will
-terminate before $s$ can possibly become zero.
-
-@c
-void mp_ps_print_scaled (MP mp,scaled s) {
- scaled delta; /* amount of allowable inaccuracy */
- if ( s<0 ) {
- mp_ps_print_char(mp, '-');
- negate(s); /* print the sign, if negative */
- }
- mp_ps_print_int(mp, s / unity); /* print the integer part */
- s=10*(s % unity)+5;
- if ( s!=5 ) {
- delta=10;
- mp_ps_print_char(mp, '.');
- do {
- if ( delta>unity )
- s=s+0100000-(delta / 2); /* round the final digit */
- mp_ps_print_char(mp, '0'+(s / unity));
- s=10*(s % unity);
- delta=delta*10;
- } while (s>delta);
- }
-}
-
-
-@* \[44a] Dealing with font encodings.
-
-First, here are a few helpers for parsing files
-
-@d check_buf(size, buf_size)
- if ((unsigned)(size) > (unsigned)(buf_size)) {
- char S[128];
- snprintf(S,128,"buffer overflow: (%d,%d) at file %s, line %d",
- size,buf_size, __FILE__, __LINE__ );
- mp_fatal_error(mp,S);
- }
-
-@d append_char_to_buf(c, p, buf, buf_size) do {
- if (c == 9)
- c = 32;
- if (c == 13 || c == EOF)
- c = 10;
- if (c != ' ' || (p > buf && p[-1] != 32)) {
- check_buf(p - buf + 1, (buf_size));
- *p++ = c;
- }
-} while (0)
-
-@d append_eol(p, buf, buf_size) do {
- check_buf(p - buf + 2, (buf_size));
- if (p - buf > 1 && p[-1] != 10)
- *p++ = 10;
- if (p - buf > 2 && p[-2] == 32) {
- p[-2] = 10;
- p--;
- }
- *p = 0;
-} while (0)
-
-@d remove_eol(p, buf) do {
- p = strend(buf) - 1;
- if (*p == 10)
- *p = 0;
-} while (0)
-
-@d skip(p, c) if (*p == c) p++
-@d strend(s) strchr(s, 0)
-@d str_prefix(s1, s2) (strncmp((s1), (s2), strlen(s2)) == 0)
-
-
-@ @<Types...@>=
-typedef struct {
- boolean loaded; /* the encoding has been loaded? */
- char *file_name; /* encoding file name */
- char *enc_name; /* encoding true name */
- integer objnum; /* object number */
- char **glyph_names;
- integer tounicode; /* object number of associated ToUnicode entry */
-} enc_entry;
-
-
-@
-
-@d ENC_STANDARD 0
-@d ENC_BUILTIN 1
-
-@<Glob...@>=
-#define ENC_BUF_SIZE 0x1000
-char enc_line[ENC_BUF_SIZE];
-void * enc_file;
-
-@
-@d enc_eof() (mp->eof_file)(mp,mp->ps->enc_file)
-@d enc_close() (mp->close_file)(mp,mp->ps->enc_file)
-
-@c
-int enc_getchar(MP mp) {
- size_t len = 1;
- unsigned char abyte=0;
- void *byte_ptr = &abyte;
- (mp->read_binary_file)(mp,mp->ps->enc_file,&byte_ptr,&len);
- return abyte;
-}
-
-@ @c
-static boolean mp_enc_open (MP mp, char *n) {
- mp->ps->enc_file=(mp->open_file)(mp,n, "r", mp_filetype_encoding);
- if (mp->ps->enc_file!=NULL)
- return true;
- else
- return false;
-}
-static void mp_enc_getline (MP mp) {
- char *p;
- int c;
-RESTART:
- if (enc_eof ()) {
- print_err("unexpected end of file");
- mp_error(mp);
- }
- p = mp->ps->enc_line;
- do {
- c = enc_getchar (mp);
- append_char_to_buf (c, p, mp->ps->enc_line, ENC_BUF_SIZE);
- } while (c != 10);
- append_eol (p, mp->ps->enc_line, ENC_BUF_SIZE);
- if (p - mp->ps->enc_line < 2 || *mp->ps->enc_line == '%')
- goto RESTART;
-}
-static void mp_load_enc (MP mp, char *enc_name,
- char **enc_encname, char **glyph_names){
- char buf[ENC_BUF_SIZE], *p, *r;
- int names_count;
- char *myname;
- int save_selector = mp->selector;
- if (!mp_enc_open (mp,enc_name)) {
- mp_print (mp,"cannot open encoding file for reading");
- return;
- }
- mp_normalize_selector(mp);
- mp_print (mp,"{");
- mp_print (mp, enc_name);
- mp_enc_getline (mp);
- if (*mp->ps->enc_line != '/' || (r = strchr (mp->ps->enc_line, '[')) == NULL) {
- remove_eol (r, mp->ps->enc_line);
- print_err ("invalid encoding vector (a name or `[' missing): `");
- mp_print(mp,mp->ps->enc_line);
- mp_print(mp,"'");
- mp_error(mp);
- }
- while (*(r-1)==' ') r--; /* strip trailing spaces from encoding name */
- myname = mp_xmalloc(mp,r-mp->ps->enc_line,1);
- memcpy(myname,mp->ps->enc_line+1,(r-mp->ps->enc_line)-1);
- *(myname+(r-mp->ps->enc_line-1))=0;
- *enc_encname = myname;
- while (*r!='[') r++;
- r++; /* skip '[' */
- names_count = 0;
- skip (r, ' ');
- for (;;) {
- while (*r == '/') {
- for (p = buf, r++;
- *r != ' ' && *r != 10 && *r != ']' && *r != '/'; *p++ = *r++);
- *p = 0;
- skip (r, ' ');
- if (names_count > 256) {
- print_err ("encoding vector contains more than 256 names");
- mp_error(mp);
- }
- if (mp_xstrcmp (buf, notdef) != 0)
- glyph_names[names_count] = mp_xstrdup (mp,buf);
- names_count++;
- }
- if (*r != 10 && *r != '%') {
- if (str_prefix (r, "] def"))
- goto DONE;
- else {
- remove_eol (r, mp->ps->enc_line);
- print_err
- ("invalid encoding vector: a name or `] def' expected: `");
- mp_print(mp,mp->ps->enc_line);
- mp_print(mp,"'");
- mp_error(mp);
- }
- }
- mp_enc_getline (mp);
- r = mp->ps->enc_line;
- }
-DONE:
- enc_close ();
- mp_print (mp,"}");
- mp->selector = save_selector;
-}
-static void mp_read_enc (MP mp, enc_entry * e) {
- if (e->loaded)
- return;
- e->enc_name = NULL;
- mp_load_enc (mp,e->file_name, &e->enc_name, e->glyph_names);
- e->loaded = true;
-}
-
-@ |write_enc| is used to write either external encoding (given in map file) or
- internal encoding (read from the font file);
- the 2nd argument is a pointer to the encoding entry;
-
-@c
-static void mp_write_enc (MP mp, enc_entry * e) {
- int i;
- int s;
- int foffset;
- char **g;
- if (e->objnum != 0) /* the encoding has been written already */
- return;
- e->objnum = 1;
- g = e->glyph_names;
-
- mp_ps_print(mp,"\n%%%%BeginResource: encoding ");
- mp_ps_print(mp, e->enc_name);
- mp_ps_print_nl(mp, "/");
- mp_ps_print(mp, e->enc_name);
- mp_ps_print(mp, " [ ");
- foffset = strlen(e->file_name)+3;
- for (i = 0; i < 256; i++) {
- s = strlen(g[i]);
- if (s+1+foffset>=80) {
- mp_ps_print_ln (mp);
- foffset = 0;
- }
- foffset += s+2;
- mp_ps_print_char(mp,'/');
- mp_ps_print(mp, g[i]);
- mp_ps_print_char(mp,' ');
- }
- if (foffset>75)
- mp_ps_print_ln (mp);
- mp_ps_print_nl (mp,"] def\n");
- mp_ps_print(mp,"%%%%EndResource");
-}
-
-
-@ All encoding entries go into AVL tree for fast search by name.
-
-@<Glob...@>=
-struct avl_table *enc_tree;
-
-@ Memory management functions for avl
-
-@<Static variables in the outer block@>=
-static const char notdef[] = ".notdef";
-
-@ @<Declarations@>=
-static void *avl_xmalloc (struct libavl_allocator *allocator, size_t size);
-static void avl_xfree (struct libavl_allocator *allocator, void *block);
-
-@ @c
-static void *avl_xmalloc (struct libavl_allocator *allocator, size_t size) {
- (void)allocator;
- return malloc (size);
-}
-static void avl_xfree (struct libavl_allocator *allocator, void *block) {
- (void)allocator;
- free (block);
-}
-
-@ @<Glob...@>=
-struct libavl_allocator avl_xallocator;
-
-@ @<Set initial...@>=
-mp->ps->avl_xallocator.libavl_malloc=avl_xmalloc;
-mp->ps->avl_xallocator.libavl_free= avl_xfree;
-mp->ps->enc_tree = NULL;
-
-@ @c
-static int comp_enc_entry (const void *pa, const void *pb, void *p) {
- (void)p;
- return strcmp (((const enc_entry *) pa)->file_name,
- ((const enc_entry *) pb)->file_name);
-}
-static enc_entry * mp_add_enc (MP mp, char *s) {
- int i;
- enc_entry tmp, *p;
- void **aa;
- if (mp->ps->enc_tree == NULL) {
- mp->ps->enc_tree = avl_create (comp_enc_entry, NULL, &mp->ps->avl_xallocator);
- }
- tmp.file_name = s;
- p = (enc_entry *) avl_find (mp->ps->enc_tree, &tmp);
- if (p != NULL) /* encoding already registered */
- return p;
- p = mp_xmalloc (mp,1,sizeof (enc_entry));
- p->loaded = false;
- p->file_name = mp_xstrdup (mp,s);
- p->objnum = 0;
- p->tounicode = 0;
- p->glyph_names = mp_xmalloc (mp,256,sizeof (char *));
- for (i = 0; i < 256; i++)
- p->glyph_names[i] = (char *) notdef;
- aa = avl_probe (mp->ps->enc_tree, p);
- return p;
-}
-
-@ cleaning up...
-
-@c
-static void mp_destroy_enc_entry (void *pa, void *pb) {
- enc_entry *p;
- int i;
- p = (enc_entry *) pa;
- (void)pb;
- mp_xfree (p->file_name);
- if (p->glyph_names != NULL)
- for (i = 0; i < 256; i++)
- if (p->glyph_names[i] != notdef)
- mp_xfree (p->glyph_names[i]);
- mp_xfree (p->glyph_names);
- mp_xfree (p);
-}
-
-@ @<Declarations@>=
-static void enc_free (MP mp);
-
-@ @c static void enc_free (MP mp) {
- if (mp->ps->enc_tree != NULL)
- avl_destroy (mp->ps->enc_tree, mp_destroy_enc_entry);
-}
-
-@ @<Exported function headers@>=
-void mp_reload_encodings (MP mp) ;
-
-@ @<Declarations@>=
-static void mp_font_encodings (MP mp, int lastfnum, int encodings_only) ;
-
-@ @c void mp_reload_encodings (MP mp) {
- int f;
- enc_entry *e;
- fm_entry *fm_cur;
- int lastfnum = mp->last_fnum;
- for (f=null_font+1;f<=lastfnum;f++) {
- if (mp->font_enc_name[f]!=NULL ) {
- mp_xfree(mp->font_enc_name[f]);
- mp->font_enc_name[f]=NULL;
- }
- if (mp_has_fm_entry (mp,f,&fm_cur)) {
- if (fm_cur != NULL && fm_cur->ps_name != NULL &&is_reencoded (fm_cur)) {
- e = fm_cur->encoding;
- mp_read_enc (mp,e);
- }
- }
- }
-}
-static void mp_font_encodings (MP mp, int lastfnum, int encodings_only) {
- int f;
- enc_entry *e;
- fm_entry *fm;
- for (f=null_font+1;f<=lastfnum;f++) {
- if (mp_has_font_size(mp,f) && mp_has_fm_entry (mp,f, &fm)) {
- if (fm != NULL && (fm->ps_name != NULL)) {
- if (is_reencoded (fm)) {
- if (encodings_only || (!is_subsetted (fm))) {
- e = fm->encoding;
- mp_write_enc (mp, e);
- /* clear for next run */
- e->objnum = 0;
- }
- }
- }
- }
- }
-}
-
-@* \[44b] Parsing font map files.
-
-@d FM_BUF_SIZE 1024
-
-@<Glob...@>=
-void * fm_file;
-
-@
-@d fm_close() (mp->close_file)(mp,mp->ps->fm_file)
-@d fm_eof() (mp->eof_file)(mp,mp->ps->fm_file)
-
-@c
-int fm_getchar(MP mp) {
- size_t len = 1;
- unsigned char abyte=0;
- void *byte_ptr = &abyte;
- (mp->read_binary_file)(mp,mp->ps->fm_file,&byte_ptr,&len);
- if (len==0)
- return EOF;
- return abyte;
-}
-
-
-@ @<Types...@>=
-enum _mode { FM_DUPIGNORE, FM_REPLACE, FM_DELETE };
-enum _ltype { MAPFILE, MAPLINE };
-enum _tfmavail { TFM_UNCHECKED, TFM_FOUND, TFM_NOTFOUND };
-typedef struct mitem {
- int mode; /* |FM_DUPIGNORE| or |FM_REPLACE| or |FM_DELETE| */
- int type; /* map file or map line */
- char *map_line; /* pointer to map file name or map line */
- int lineno; /* line number in map file */
-} mapitem;
-
-@ @<Glob...@>=
-mapitem *mitem;
-fm_entry *fm_cur;
-fm_entry *loaded_tfm_found;
-fm_entry *avail_tfm_found;
-fm_entry *non_tfm_found;
-fm_entry *not_avail_tfm_found;
-
-@ @<Set initial...@>=
-mp->ps->mitem = NULL;
-
-@ @<Declarations@>=
-static const char nontfm[] = "<nontfm>";
-
-@
-@d read_field(r, q, buf) do {
- q = buf;
- while (*r != ' ' && *r != '\0')
- *q++ = *r++;
- *q = '\0';
- skip (r, ' ');
-} while (0)
-
-@d set_field(F) do {
- if (q > buf)
- fm->F = mp_xstrdup(mp,buf);
- if (*r == '\0')
- goto DONE;
-} while (0)
-
-@d cmp_return(a, b)
- if (a > b)
- return 1;
- if (a < b)
- return -1
-
-@c
-static fm_entry *new_fm_entry (MP mp) {
- fm_entry *fm;
- fm = mp_xmalloc (mp,1,sizeof(fm_entry));
- fm->tfm_name = NULL;
- fm->ps_name = NULL;
- fm->flags = 4;
- fm->ff_name = NULL;
- fm->subset_tag = NULL;
- fm->encoding = NULL;
- fm->tfm_num = null_font;
- fm->tfm_avail = TFM_UNCHECKED;
- fm->type = 0;
- fm->slant = 0;
- fm->extend = 0;
- fm->ff_objnum = 0;
- fm->fn_objnum = 0;
- fm->fd_objnum = 0;
- fm->charset = NULL;
- fm->all_glyphs = false;
- fm->links = 0;
- fm->pid = -1;
- fm->eid = -1;
- return fm;
-}
-
-static void delete_fm_entry (fm_entry * fm) {
- mp_xfree (fm->tfm_name);
- mp_xfree (fm->ps_name);
- mp_xfree (fm->ff_name);
- mp_xfree (fm->subset_tag);
- mp_xfree (fm->charset);
- mp_xfree (fm);
-}
-
-static ff_entry *new_ff_entry (MP mp) {
- ff_entry *ff;
- ff = mp_xmalloc (mp,1,sizeof(ff_entry));
- ff->ff_name = NULL;
- ff->ff_path = NULL;
- return ff;
-}
-
-static void delete_ff_entry (ff_entry * ff) {
- mp_xfree (ff->ff_name);
- mp_xfree (ff->ff_path);
- mp_xfree (ff);
-}
-
-static char *mk_base_tfm (MP mp, char *tfmname, int *i) {
- static char buf[SMALL_BUF_SIZE];
- char *p = tfmname, *r = strend (p) - 1, *q = r;
- while (q > p && isdigit (*q))
- --q;
- if (!(q > p) || q == r || (*q != '+' && *q != '-'))
- return NULL;
- check_buf (q - p + 1, SMALL_BUF_SIZE);
- strncpy (buf, p, (size_t) (q - p));
- buf[q - p] = '\0';
- *i = atoi (q);
- return buf;
-}
-
-@ @<Exported function headers@>=
-boolean mp_has_fm_entry (MP mp,font_number f, fm_entry **fm);
-
-@ @c
-boolean mp_has_fm_entry (MP mp,font_number f, fm_entry **fm) {
- fm_entry *res = NULL;
- res = mp_fm_lookup (mp, f);
- if (fm != NULL) {
- *fm =res;
- }
- return (res != NULL);
-}
-
-@ @<Glob...@>=
-struct avl_table *tfm_tree;
-struct avl_table *ps_tree;
-struct avl_table *ff_tree;
-
-@ @<Set initial...@>=
-mp->ps->tfm_tree = NULL;
-mp->ps->ps_tree = NULL;
-mp->ps->ff_tree = NULL;
-
-@ AVL sort |fm_entry| into |tfm_tree| by |tfm_name |
-
-@c
-static int comp_fm_entry_tfm (const void *pa, const void *pb, void *p) {
- (void)p;
- return strcmp (((const fm_entry *) pa)->tfm_name,
- ((const fm_entry *) pb)->tfm_name);
-}
-
-@ AVL sort |fm_entry| into |ps_tree| by |ps_name|, |slant|, and |extend|
-
-@c static int comp_fm_entry_ps (const void *pa, const void *pb, void *p) {
- int i;
- const fm_entry *p1 = (const fm_entry *) pa;
- const fm_entry *p2 = (const fm_entry *) pb;
- (void)p;
- assert (p1->ps_name != NULL && p2->ps_name != NULL);
- if ((i = strcmp (p1->ps_name, p2->ps_name)))
- return i;
- cmp_return (p1->slant, p2->slant);
- cmp_return (p1->extend, p2->extend);
- if (p1->tfm_name != NULL && p2->tfm_name != NULL &&
- (i = strcmp (p1->tfm_name, p2->tfm_name)))
- return i;
- return 0;
-}
-
-@ AVL sort |ff_entry| into |ff_tree| by |ff_name|
-
-@c static int comp_ff_entry (const void *pa, const void *pb, void *p) {
- (void)p;
- return strcmp (((const ff_entry *) pa)->ff_name,
- ((const ff_entry *) pb)->ff_name);
-}
-
-@ @c static void create_avl_trees (MP mp) {
- if (mp->ps->tfm_tree == NULL) {
- mp->ps->tfm_tree = avl_create (comp_fm_entry_tfm, NULL, &mp->ps->avl_xallocator);
- assert (mp->ps->tfm_tree != NULL);
- }
- if (mp->ps->ps_tree == NULL) {
- mp->ps->ps_tree = avl_create (comp_fm_entry_ps, NULL, &mp->ps->avl_xallocator);
- assert (mp->ps->ps_tree != NULL);
- }
- if (mp->ps->ff_tree == NULL) {
- mp->ps->ff_tree = avl_create (comp_ff_entry, NULL, &mp->ps->avl_xallocator);
- assert (mp->ps->ff_tree != NULL);
- }
-}
-
-@ The function |avl_do_entry| is not completely symmetrical with regards
-to |tfm_name| and |ps_name handling|, e. g. a duplicate |tfm_name| gives a
-|goto exit|, and no |ps_name| link is tried. This is to keep it compatible
-with the original version.
-
-@d LINK_TFM 0x01
-@d LINK_PS 0x02
-@d set_tfmlink(fm) ((fm)->links |= LINK_TFM)
-@d set_pslink(fm) ((fm)->links |= LINK_PS)
-@d unset_tfmlink(fm) ((fm)->links &= ~LINK_TFM)
-@d unset_pslink(fm) ((fm)->links &= ~LINK_PS)
-@d has_tfmlink(fm) ((fm)->links & LINK_TFM)
-@d has_pslink(fm) ((fm)->links & LINK_PS)
-
-@c
-static int avl_do_entry (MP mp, fm_entry * fp, int mode) {
- fm_entry *p;
- void *a;
- void **aa;
- char s[128];
-
- /* handle |tfm_name| link */
-
- if (strcmp (fp->tfm_name, nontfm)) {
- p = (fm_entry *) avl_find (mp->ps->tfm_tree, fp);
- if (p != NULL) {
- if (mode == FM_DUPIGNORE) {
- snprintf(s,128,"fontmap entry for `%s' already exists, duplicates ignored",
- fp->tfm_name);
- mp_warn(mp,s);
- goto exit;
- } else { /* mode == |FM_REPLACE| / |FM_DELETE| */
- if (mp_has_font_size(mp,p->tfm_num)) {
- snprintf(s,128,
- "fontmap entry for `%s' has been used, replace/delete not allowed",
- fp->tfm_name);
- mp_warn(mp,s);
- goto exit;
- }
- a = avl_delete (mp->ps->tfm_tree, p);
- assert (a != NULL);
- unset_tfmlink (p);
- if (!has_pslink (p))
- delete_fm_entry (p);
- }
- }
- if (mode != FM_DELETE) {
- aa = avl_probe (mp->ps->tfm_tree, fp);
- assert (aa != NULL);
- set_tfmlink (fp);
- }
- }
-
- /* handle |ps_name| link */
-
- if (fp->ps_name != NULL) {
- assert (fp->tfm_name != NULL);
- p = (fm_entry *) avl_find (mp->ps->ps_tree, fp);
- if (p != NULL) {
- if (mode == FM_DUPIGNORE) {
- snprintf(s,128,
- "ps_name entry for `%s' already exists, duplicates ignored",
- fp->ps_name);
- mp_warn(mp,s);
- goto exit;
- } else { /* mode == |FM_REPLACE| / |FM_DELETE| */
- if (mp_has_font_size(mp,p->tfm_num)) {
- /* REPLACE/DELETE not allowed */
- snprintf(s,128,
- "fontmap entry for `%s' has been used, replace/delete not allowed",
- p->tfm_name);
- mp_warn(mp,s);
- goto exit;
- }
- a = avl_delete (mp->ps->ps_tree, p);
- assert (a != NULL);
- unset_pslink (p);
- if (!has_tfmlink (p))
- delete_fm_entry (p);
- }
- }
- if (mode != FM_DELETE) {
- aa = avl_probe (mp->ps->ps_tree, fp);
- assert (aa != NULL);
- set_pslink (fp);
- }
- }
- exit:
- if (!has_tfmlink (fp) && !has_pslink (fp)) /* e. g. after |FM_DELETE| */
- return 1; /* deallocation of |fm_entry| structure required */
- else
- return 0;
-}
-
-@ consistency check for map entry, with warn flag
-
-@c
-static int check_fm_entry (MP mp, fm_entry * fm, boolean warn) {
- int a = 0;
- char s[128];
- assert (fm != NULL);
- if (fm->ps_name != NULL) {
- if (is_basefont (fm)) {
- if (is_fontfile (fm) && !is_included (fm)) {
- if (warn) {
- snprintf(s,128, "invalid entry for `%s': "
- "font file must be included or omitted for base fonts",
- fm->tfm_name);
- mp_warn(mp,s);
- }
- a += 1;
- }
- } else { /* not a base font */
- /* if no font file given, drop this entry */
- /* |if (!is_fontfile (fm)) {
- if (warn) {
- snprintf(s,128,
- "invalid entry for `%s': font file missing",
- fm->tfm_name);
- mp_warn(mp,s);
- }
- a += 2;
- }|
- */
- }
- }
- if (is_truetype (fm) && is_reencoded (fm) && !is_subsetted (fm)) {
- if (warn) {
- snprintf(s,128,
- "invalid entry for `%s': only subsetted TrueType font can be reencoded",
- fm->tfm_name);
- mp_warn(mp,s);
- }
- a += 4;
- }
- if ((fm->slant != 0 || fm->extend != 0) &&
- (is_truetype (fm))) {
- if (warn) {
- snprintf(s,128,
- "invalid entry for `%s': "
- "SlantFont/ExtendFont can be used only with embedded T1 fonts",
- fm->tfm_name);
- mp_warn(mp,s);
- }
- a += 8;
- }
- if (abs (fm->slant) > 1000) {
- if (warn) {
- snprintf(s,128,
- "invalid entry for `%s': too big value of SlantFont (%g)",
- fm->tfm_name, fm->slant / 1000.0);
- mp_warn(mp,s);
- }
- a += 16;
- }
- if (abs (fm->extend) > 2000) {
- if (warn) {
- snprintf(s,128,
- "invalid entry for `%s': too big value of ExtendFont (%g)",
- fm->tfm_name, fm->extend / 1000.0);
- mp_warn(mp,s);
- }
- a += 32;
- }
- if (fm->pid != -1 &&
- !(is_truetype (fm) && is_included (fm) &&
- is_subsetted (fm) && !is_reencoded (fm))) {
- if (warn) {
- snprintf(s,128,
- "invalid entry for `%s': "
- "PidEid can be used only with subsetted non-reencoded TrueType fonts",
- fm->tfm_name);
- mp_warn(mp,s);
- }
- a += 64;
- }
- return a;
-}
-
-@ returns true if s is one of the 14 std. font names; speed-trimmed.
-
-@c static boolean check_basefont (char *s) {
- static const char *basefont_names[] = {
- "Courier", /* 0:7 */
- "Courier-Bold", /* 1:12 */
- "Courier-Oblique", /* 2:15 */
- "Courier-BoldOblique", /* 3:19 */
- "Helvetica", /* 4:9 */
- "Helvetica-Bold", /* 5:14 */
- "Helvetica-Oblique", /* 6:17 */
- "Helvetica-BoldOblique", /* 7:21 */
- "Symbol", /* 8:6 */
- "Times-Roman", /* 9:11 */
- "Times-Bold", /* 10:10 */
- "Times-Italic", /* 11:12 */
- "Times-BoldItalic", /* 12:16 */
- "ZapfDingbats" /* 13:12 */
- };
- static const int Index[] =
- { -1, -1, -1, -1, -1, -1, 8, 0, -1, 4, 10, 9, -1, -1, 5, 2, 12, 6,
- -1, 3, -1, 7
- };
- const size_t n = strlen (s);
- int k = -1;
- if (n > 21)
- return false;
- if (n == 12) { /* three names have length 12 */
- switch (*s) {
- case 'C':
- k = 1; /* Courier-Bold */
- break;
- case 'T':
- k = 11; /* Times-Italic */
- break;
- case 'Z':
- k = 13; /* ZapfDingbats */
- break;
- default:
- return false;
- }
- } else
- k = Index[n];
- if (k > -1 && !strcmp (basefont_names[k], s))
- return true;
- return false;
-}
-
-@
-@d is_cfg_comment(c) (c == 10 || c == '*' || c == '#' || c == ';' || c == '%')
-
-@c static void fm_scan_line (MP mp) {
- int a, b, c, j, u = 0, v = 0;
- float d;
- fm_entry *fm;
- char fm_line[FM_BUF_SIZE], buf[FM_BUF_SIZE];
- char *p, *q, *r, *s;
- char warn_s[128];
- switch (mp->ps->mitem->type) {
- case MAPFILE:
- p = fm_line;
- do {
- c = fm_getchar (mp);
- append_char_to_buf (c, p, fm_line, FM_BUF_SIZE);
- } while (c != 10);
- *(--p) = '\0';
- r = fm_line;
- break;
- case MAPLINE:
- r = mp->ps->mitem->map_line;
- break;
- default:
- assert (0);
- }
- if (*r == '\0' || is_cfg_comment (*r))
- return;
- fm = new_fm_entry (mp);
- read_field (r, q, buf);
- set_field (tfm_name);
- p = r;
- read_field (r, q, buf);
- if (*buf != '<' && *buf != '"')
- set_field (ps_name);
- else
- r = p; /* unget the field */
- if (isdigit (*r)) { /* font flags given */
- fm->flags = atoi (r);
- while (isdigit (*r))
- r++;
- }
- while (1) { /* loop through "specials", encoding, font file */
- skip (r, ' ');
- switch (*r) {
- case '\0':
- goto DONE;
- case '"': /* opening quote */
- r++;
- u = v = 0;
- do {
- skip (r, ' ');
- if (sscanf (r, "%f %n", &d, &j) > 0) {
- s = r + j; /* jump behind number, eat also blanks, if any */
- if (*(s - 1) == 'E' || *(s - 1) == 'e')
- s--; /* e. g. 0.5ExtendFont: \%f = 0.5E */
- if (str_prefix (s, "SlantFont")) {
- d *= 1000.0; /* correct rounding also for neg. numbers */
- fm->slant = (integer) (d > 0 ? d + 0.5 : d - 0.5);
- r = s + strlen ("SlantFont");
- } else if (str_prefix (s, "ExtendFont")) {
- d *= 1000.0;
- fm->extend = (integer) (d > 0 ? d + 0.5 : d - 0.5);
- if (fm->extend == 1000)
- fm->extend = 0;
- r = s + strlen ("ExtendFont");
- } else { /* unknown name */
- for (r = s;
- *r != ' ' && *r != '"' && *r != '\0';
- r++); /* jump over name */
- c = *r; /* remember char for temporary end of string */
- *r = '\0';
- snprintf(warn_s,128,
- "invalid entry for `%s': unknown name `%s' ignored",
- fm->tfm_name, s);
- mp_warn(mp,warn_s);
- *r = c;
- }
- } else
- for (; *r != ' ' && *r != '"' && *r != '\0'; r++);
- }
- while (*r == ' ');
- if (*r == '"') /* closing quote */
- r++;
- else {
- snprintf(warn_s,128,
- "invalid entry for `%s': closing quote missing",
- fm->tfm_name);
- mp_warn(mp,warn_s);
- goto bad_line;
- }
- break;
- case 'P': /* handle cases for subfonts like 'PidEid=3,1' */
- if (sscanf (r, "PidEid=%i, %i %n", &a, &b, &c) >= 2) {
- fm->pid = a;
- fm->eid = b;
- r += c;
- break;
- }
- default: /* encoding or font file specification */
- a = b = 0;
- if (*r == '<') {
- a = *r++;
- if (*r == '<' || *r == '[')
- b = *r++;
- }
- read_field (r, q, buf);
- /* encoding, formats: '8r.enc' or '<8r.enc' or '<[8r.enc' */
- if (strlen (buf) > 4 && strcasecmp (strend (buf) - 4, ".enc") == 0) {
- fm->encoding = mp_add_enc (mp, buf);
- u = v = 0; /* u, v used if intervening blank: "<< foo" */
- } else if (strlen (buf) > 0) { /* file name given */
- /* font file, formats:
- * subsetting: '<cmr10.pfa'
- * no subsetting: '<<cmr10.pfa'
- * no embedding: 'cmr10.pfa'
- */
- if (a == '<' || u == '<') {
- set_included (fm);
- if ((a == '<' && b == 0) || (a == 0 && v == 0))
- set_subsetted (fm);
- /* otherwise b == '<' (or '[') => no subsetting */
- }
- set_field (ff_name);
- u = v = 0;
- } else {
- u = a;
- v = b;
- }
- }
- }
- DONE:
- if (fm->ps_name != NULL && check_basefont (fm->ps_name))
- set_basefont (fm);
- if (is_fontfile (fm)
- && strcasecmp (strend (fm_fontfile (fm)) - 4, ".ttf") == 0)
- set_truetype (fm);
- if (check_fm_entry (mp,fm, true) != 0)
- goto bad_line;
- /*
- Until here the map line has been completely scanned without errors;
- fm points to a valid, freshly filled-out |fm_entry| structure.
- Now follows the actual work of registering/deleting.
- */
- if (avl_do_entry (mp, fm, mp->ps->mitem->mode) == 0) /* if success */
- return;
- bad_line:
- delete_fm_entry (fm);
-}
-
-@
-@c static void fm_read_info (MP mp) {
- char *n;
- char s[256];
- if (mp->ps->tfm_tree == NULL)
- create_avl_trees (mp);
- if (mp->ps->mitem->map_line == NULL) /* nothing to do */
- return;
- mp->ps->mitem->lineno = 1;
- switch (mp->ps->mitem->type) {
- case MAPFILE:
- n = mp->ps->mitem->map_line;
- mp->ps->fm_file = (mp->open_file)(mp, n, "r", mp_filetype_fontmap);
- if (!mp->ps->fm_file) {
- snprintf(s,256,"cannot open font map file %s",n);
- mp_warn(mp,s);
- } else {
- int save_selector = mp->selector;
- mp_normalize_selector(mp);
- mp_print (mp, "{");
- mp_print (mp, n);
- while (!fm_eof ()) {
- fm_scan_line (mp);
- mp->ps->mitem->lineno++;
- }
- fm_close ();
- mp_print (mp,"}");
- mp->selector = save_selector;
- mp->ps->fm_file = NULL;
- }
- mp_xfree(n);
- break;
- case MAPLINE:
- fm_scan_line (mp);
- break;
- default:
- assert (0);
- }
- mp->ps->mitem->map_line = NULL; /* done with this line */
- return;
-}
-
-@ @c static void init_fm (fm_entry * fm, font_number f) {
- if (fm->tfm_num == null_font ) {
- fm->tfm_num = f;
- fm->tfm_avail = TFM_FOUND;
- }
-}
-
-@ @<Declarations@>=
-static fm_entry * mp_fm_lookup (MP mp, font_number f);
-
-@ @c
-static fm_entry * mp_fm_lookup (MP mp, font_number f) {
- char *tfm;
- fm_entry *fm;
- fm_entry tmp;
- int e;
- if (mp->ps->tfm_tree == NULL)
- fm_read_info (mp); /* only to read default map file */
- tfm = mp->font_name[f];
- assert (strcmp (tfm, nontfm));
- /* Look up for full <tfmname>[+-]<expand> */
- tmp.tfm_name = tfm;
- fm = (fm_entry *) avl_find (mp->ps->tfm_tree, &tmp);
- if (fm != NULL) {
- init_fm (fm, f);
- return (fm_entry *) fm;
- }
- tfm = mk_base_tfm (mp, mp->font_name[f], &e);
- if (tfm == NULL) /* not an expanded font, nothing to do */
- return NULL;
-
- tmp.tfm_name = tfm;
- fm = (fm_entry *) avl_find (mp->ps->tfm_tree, &tmp);
- if (fm != NULL) { /* found an entry with the base tfm name, e.g. cmr10 */
- return (fm_entry *) fm; /* font expansion uses the base font */
- }
- return NULL;
-}
-
-@ Early check whether a font file exists. Used e. g. for replacing fonts
- of embedded PDF files: Without font file, the font within the embedded
- PDF-file is used. Search tree |ff_tree| is used in 1st instance, as it
- may be faster than the |kpse_find_file()|, and |kpse_find_file()| is called
- only once per font file name + expansion parameter. This might help
- keeping speed, if many PDF pages with same fonts are to be embedded.
-
- The |ff_tree| contains only font files, which are actually needed,
- so this tree typically is much smaller than the |tfm_tree| or |ps_tree|.
-
-@c
-static ff_entry *check_ff_exist (MP mp, fm_entry * fm) {
- ff_entry *ff;
- ff_entry tmp;
- void **aa;
-
- assert (fm->ff_name != NULL);
- tmp.ff_name = fm->ff_name;
- ff = (ff_entry *) avl_find (mp->ps->ff_tree, &tmp);
- if (ff == NULL) { /* not yet in database */
- ff = new_ff_entry (mp);
- ff->ff_name = mp_xstrdup (mp,fm->ff_name);
- ff->ff_path = mp_xstrdup (mp,fm->ff_name);
- aa = avl_probe (mp->ps->ff_tree, ff);
- assert (aa != NULL);
- }
- return ff;
-}
-
-@ Process map file given by its name or map line contents. Items not
-beginning with [+-=] flush default map file, if it has not yet been
-read. Leading blanks and blanks immediately following [+-=] are ignored.
-
-
-@c static void mp_process_map_item (MP mp, char *s, int type) {
- char *p;
- int mode;
- if (*s == ' ')
- s++; /* ignore leading blank */
- switch (*s) {
- case '+': /* +mapfile.map, +mapline */
- mode = FM_DUPIGNORE; /* insert entry, if it is not duplicate */
- s++;
- break;
- case '=': /* =mapfile.map, =mapline */
- mode = FM_REPLACE; /* try to replace earlier entry */
- s++;
- break;
- case '-': /* -mapfile.map, -mapline */
- mode = FM_DELETE; /* try to delete entry */
- s++;
- break;
- default:
- mode = FM_DUPIGNORE; /* like +, but also: */
- mp_xfree(mp->ps->mitem->map_line);
- mp->ps->mitem->map_line = NULL; /* flush default map file name */
- }
- if (*s == ' ')
- s++; /* ignore blank after [+-=] */
- p = s; /* map item starts here */
- switch (type) {
- case MAPFILE: /* remove blank at end */
- while (*p != '\0' && *p != ' ')
- p++;
- *p = '\0';
- break;
- case MAPLINE: /* blank at end allowed */
- break;
- default:
- assert (0);
- }
- if (mp->ps->mitem->map_line != NULL) /* read default map file first */
- fm_read_info (mp);
- if (*s != '\0') { /* only if real item to process */
- mp->ps->mitem->mode = mode;
- mp->ps->mitem->type = type;
- mp->ps->mitem->map_line = s;
- fm_read_info (mp);
- }
-}
-
-@ @<Exported function headers@>=
-void mp_map_file (MP mp, str_number t);
-void mp_map_line (MP mp, str_number t);
-void mp_init_map_file (MP mp, int is_troff);
-
-@ @c
-void mp_map_file (MP mp, str_number t) {
- char *s = mp_xstrdup(mp,mp_str (mp,t));
- mp_process_map_item (mp, s, MAPFILE);
- mp_xfree (s);
-}
-void mp_map_line (MP mp, str_number t) {
- char *s = mp_xstrdup(mp,mp_str (mp,t));
- mp_process_map_item (mp, s, MAPLINE);
- mp_xfree (s);
-}
-
-@
-@c void mp_init_map_file (MP mp, int is_troff) {
- char *r;
- mp->ps->mitem = mp_xmalloc (mp,1,sizeof(mapitem));
- mp->ps->mitem->mode = FM_DUPIGNORE;
- mp->ps->mitem->type = MAPFILE;
- mp->ps->mitem->map_line = NULL;
- r = (mp->find_file)(mp,"mpost.map", "r", mp_filetype_fontmap);
- if (r != NULL) {
- mp_xfree(r);
- mp->ps->mitem->map_line = mp_xstrdup (mp,"mpost.map");
- } else {
- if (is_troff) {
- mp->ps->mitem->map_line = mp_xstrdup (mp,"troff.map");
- } else {
- mp->ps->mitem->map_line = mp_xstrdup (mp,"pdftex.map");
- }
- }
-}
-
-@ @<Dealloc variables@>=
-if (mp->ps->mitem!=NULL) {
- mp_xfree(mp->ps->mitem->map_line);
- mp_xfree(mp->ps->mitem);
-}
-
-@ cleaning up...
-
-@c
-static void destroy_fm_entry_tfm (void *pa, void *pb) {
- fm_entry *fm;
- (void)pb;
- fm = (fm_entry *) pa;
- if (!has_pslink (fm))
- delete_fm_entry (fm);
- else
- unset_tfmlink (fm);
-}
-static void destroy_fm_entry_ps (void *pa, void *pb) {
- fm_entry *fm;
- (void)pb;
- fm = (fm_entry *) pa;
- if (!has_tfmlink (fm))
- delete_fm_entry (fm);
- else
- unset_pslink (fm);
-}
-static void destroy_ff_entry (void *pa, void *pb) {
- ff_entry *ff;
- (void)pb;
- ff = (ff_entry *) pa;
- delete_ff_entry (ff);
-}
-
-@ @<Declarations@>=
-static void fm_free (MP mp);
-
-@ @c
-static void fm_free (MP mp) {
- if (mp->ps->tfm_tree != NULL)
- avl_destroy (mp->ps->tfm_tree, destroy_fm_entry_tfm);
- if (mp->ps->ps_tree != NULL)
- avl_destroy (mp->ps->ps_tree, destroy_fm_entry_ps);
- if (mp->ps->ff_tree != NULL)
- avl_destroy (mp->ps->ff_tree, destroy_ff_entry);
-}
-
-@ The file |ps_tab_file| gives a table of \TeX\ font names and corresponding
-PostScript names for fonts that do not have to be downloaded, i.e., fonts that
-can be used when |internal[prologues]>0|. Each line consists of a \TeX\ name,
-one or more spaces, a PostScript name, and possibly a space and some other junk.
-This routine reads the table, updates |font_ps_name| entries starting after
-|last_ps_fnum|, and sets |last_ps_fnum:=last_fnum|.
-
-@d ps_tab_name "psfonts.map" /* locates font name translation table */
-
-@<Declarations@>=
-static void mp_read_psname_table (MP mp) ;
-
-@ @c
-static void mp_read_psname_table (MP mp) {
- font_number k;
- if (mp->ps->mitem == NULL) {
- mp->ps->mitem = mp_xmalloc (mp,1,sizeof(mapitem));
- mp->ps->mitem->mode = FM_DUPIGNORE;
- mp->ps->mitem->type = MAPFILE;
- mp->ps->mitem->map_line = NULL;
- }
- mp->ps->mitem->map_line = mp_xstrdup (mp,ps_tab_name);
- fm_read_info (mp);
- for (k=mp->last_ps_fnum+1;k<=mp->last_fnum;k++) {
- if (mp_has_fm_entry(mp, k, NULL)) {
- mp->font_ps_name[k] = mp_fm_font_name(mp,k);
- }
- }
- mp->last_ps_fnum=mp->last_fnum;
-}
-
-
-@ The traditional function is a lot shorter now.
-
-
-
-@* \[44c] Helper functions for Type1 fonts.
-
-@<Types...@>=
-typedef char char_entry;
-typedef unsigned char Byte;
-typedef Byte Bytef;
-
-@ @<Glob...@>=
-char_entry *char_ptr, *char_array;
-size_t char_limit;
-char *job_id_string;
-
-@ @<Set initial...@>=
-mp->ps->char_array = NULL;
-mp->ps->job_id_string = NULL;
-
-@
-@d SMALL_ARRAY_SIZE 256
-@d Z_NULL 0
-
-@c
-void mp_set_job_id (MP mp) {
- char *name_string, *format_string, *s;
- size_t slen;
- int i;
- if (mp->ps->job_id_string != NULL)
- return;
- if ( mp->job_name==NULL )
- mp->job_name = mp_xstrdup(mp,"mpout");
- name_string = mp_xstrdup (mp,mp->job_name);
- format_string = mp_xstrdup (mp,mp->mem_ident);
- slen = SMALL_BUF_SIZE +
- strlen (name_string) +
- strlen (format_string);
- s = mp_xmalloc (mp,slen, sizeof (char));
- i = snprintf (s, slen,
- "%.4d/%.2d/%.2d %.2d:%.2d %s %s",
- (mp->internal[mp_year]>>16),
- (mp->internal[mp_month]>>16),
- (mp->internal[mp_day]>>16),
- (mp->internal[mp_time]>>16) / 60,
- (mp->internal[mp_time]>>16) % 60,
- name_string, format_string);
- mp->ps->job_id_string = mp_xstrdup (mp,s);
- mp_xfree (s);
- mp_xfree (name_string);
- mp_xfree (format_string);
-}
-static void fnstr_append (MP mp, const char *s) {
- size_t l = strlen (s) + 1;
- alloc_array (char, l, SMALL_ARRAY_SIZE);
- strcat (mp->ps->char_ptr, s);
- mp->ps->char_ptr = strend (mp->ps->char_ptr);
-}
-
-@ @<Exported function headers@>=
-void mp_set_job_id (MP mp) ;
-
-@ @<Dealloc variables@>=
-mp_xfree(mp->ps->job_id_string);
-
-@ this is not really a true crc32, but it should be just enough to keep
- subsets prefixes somewhat disjunct
-
-@c
-static unsigned long crc32 (int oldcrc, const Byte *buf, int len) {
- unsigned long ret = 0;
- int i;
- if (oldcrc==0)
- ret = (23<<24)+(45<<16)+(67<<8)+89;
- else
- for (i=0;i<len;i++)
- ret = (ret<<2)+buf[i];
- return ret;
-}
-static boolean mp_char_marked (MP mp,font_number f, eight_bits c) {
- integer b; /* |char_base[f]| */
- b=mp->char_base[f];
- if ( (c>=mp->font_bc[f])&&(c<=mp->font_ec[f])&&(mp->font_info[b+c].qqqq.b3!=0) )
- return true;
- else
- return false;
-}
-
-static void make_subset_tag (MP mp, fm_entry * fm_cur, char **glyph_names, int tex_font)
-{
- char tag[7];
- unsigned long crc;
- int i;
- size_t l ;
- if (mp->ps->job_id_string ==NULL)
- mp_fatal_error(mp, "no job id!");
- l = strlen (mp->ps->job_id_string) + 1;
-
- alloc_array (char, l, SMALL_ARRAY_SIZE);
- strcpy (mp->ps->char_array, mp->ps->job_id_string);
- mp->ps->char_ptr = strend (mp->ps->char_array);
- if (fm_cur->tfm_name != NULL) {
- fnstr_append (mp," TFM name: ");
- fnstr_append (mp,fm_cur->tfm_name);
- }
- fnstr_append (mp," PS name: ");
- if (fm_cur->ps_name != NULL)
- fnstr_append (mp,fm_cur->ps_name);
- fnstr_append (mp," Encoding: ");
- if (fm_cur->encoding != NULL && (fm_cur->encoding)->file_name != NULL)
- fnstr_append (mp,(fm_cur->encoding)->file_name);
- else
- fnstr_append (mp,"built-in");
- fnstr_append (mp," CharSet: ");
- for (i = 0; i < 256; i++)
- if (mp_char_marked (mp,tex_font, i) && glyph_names[i] != notdef) {
- if (glyph_names[i]!=NULL) {
- fnstr_append (mp,"/");
- fnstr_append (mp,glyph_names[i]);
- }
- }
- if (fm_cur->charset != NULL) {
- fnstr_append (mp," Extra CharSet: ");
- fnstr_append (mp, fm_cur->charset);
- }
- crc = crc32 (0L, Z_NULL, 0);
- crc = crc32 (crc, (Bytef *) mp->ps->char_array, strlen (mp->ps->char_array));
- /* we need to fit a 32-bit number into a string of 6 uppercase chars long;
- * there are 26 uppercase chars ==> each char represents a number in range
- * |0..25|. The maximal number that can be represented by the tag is
- * $26^6 - 1$, which is a number between $2^28$ and $2^29$. Thus the bits |29..31|
- * of the CRC must be dropped out.
- */
- for (i = 0; i < 6; i++) {
- tag[i] = 'A' + crc % 26;
- crc /= 26;
- }
- tag[6] = 0;
- fm_cur->subset_tag = mp_xstrdup (mp,tag);
-}
-
-
-
-@
-@d external_enc() (fm_cur->encoding)->glyph_names
-@d is_used_char(c) mp_char_marked (mp, tex_font, c)
-@d end_last_eexec_line()
- mp->ps->hexline_length = HEXLINE_WIDTH;
- end_hexline(mp);
- mp->ps->t1_eexec_encrypt = false
-@d t1_log(s) mp_print(mp,(char *)s)
-@d t1_putchar(c) wps_chr(c)
-@d embed_all_glyphs(tex_font) false
-@d t1_char(c) c
-@d extra_charset() mp->ps->dvips_extra_charset
-@d update_subset_tag()
-@d fixedcontent true
-
-@<Glob...@>=
-#define PRINTF_BUF_SIZE 1024
-char *dvips_extra_charset;
-char *cur_enc_name;
-unsigned char *grid;
-char *ext_glyph_names[256];
-char print_buf[PRINTF_BUF_SIZE];
-int t1_byte_waiting;
-
-@ @<Set initial ...@>=
-mp->ps->dvips_extra_charset=NULL;
-mp->ps->t1_byte_waiting=0;
-
-@
-@d t1_ungetchar(A) mp->ps->t1_byte_waiting=A
-@d t1_eof() (mp->eof_file)(mp,mp->ps->t1_file)
-@d t1_close() (mp->close_file)(mp,mp->ps->t1_file)
-@d valid_code(c) (c >= 0 && c < 256)
-
-@c
-int t1_getchar (MP mp) {
- size_t len = 1;
- unsigned char abyte=0;
- void *byte_ptr = &abyte;
- if (mp->ps->t1_byte_waiting) {
- abyte = mp->ps->t1_byte_waiting;
- mp->ps->t1_byte_waiting = 0;
- } else {
- (mp->read_binary_file)(mp,mp->ps->t1_file,&byte_ptr,&len);
- }
- return abyte;
-}
-
-@ @<Static variables in the outer block@>=
-static const char *standard_glyph_names[256] =
- { notdef, notdef, notdef, notdef, notdef, notdef, notdef, notdef,
- notdef, notdef, notdef, notdef, notdef, notdef, notdef, notdef, notdef,
- notdef, notdef, notdef, notdef, notdef, notdef,
- notdef, notdef, notdef, notdef, notdef, notdef, notdef, notdef, notdef,
- "space", "exclam", "quotedbl", "numbersign",
- "dollar", "percent", "ampersand", "quoteright", "parenleft",
- "parenright", "asterisk", "plus", "comma", "hyphen", "period",
- "slash", "zero", "one", "two", "three", "four", "five", "six", "seven",
- "eight", "nine", "colon", "semicolon", "less",
- "equal", "greater", "question", "at", "A", "B", "C", "D", "E", "F",
- "G", "H", "I", "J", "K", "L", "M", "N", "O", "P", "Q",
- "R", "S", "T", "U", "V", "W", "X", "Y", "Z", "bracketleft",
- "backslash", "bracketright", "asciicircum", "underscore",
- "quoteleft", "a", "b", "c", "d", "e", "f", "g", "h", "i", "j", "k",
- "l", "m", "n", "o", "p", "q", "r", "s", "t", "u", "v",
- "w", "x", "y", "z", "braceleft", "bar", "braceright", "asciitilde",
- notdef, notdef, notdef, notdef, notdef, notdef, notdef,
- notdef, notdef, notdef, notdef, notdef, notdef, notdef, notdef, notdef,
- notdef, notdef, notdef, notdef, notdef, notdef,
- notdef, notdef, notdef, notdef, notdef, notdef, notdef, notdef, notdef,
- notdef, notdef, notdef, "exclamdown", "cent",
- "sterling", "fraction", "yen", "florin", "section", "currency",
- "quotesingle", "quotedblleft", "guillemotleft",
- "guilsinglleft", "guilsinglright", "fi", "fl", notdef, "endash",
- "dagger", "daggerdbl", "periodcentered", notdef,
- "paragraph", "bullet", "quotesinglbase", "quotedblbase",
- "quotedblright", "guillemotright", "ellipsis", "perthousand",
- notdef, "questiondown", notdef, "grave", "acute", "circumflex",
- "tilde", "macron", "breve", "dotaccent", "dieresis", notdef,
- "ring", "cedilla", notdef, "hungarumlaut", "ogonek", "caron", "emdash",
- notdef, notdef, notdef, notdef, notdef, notdef,
- notdef, notdef, notdef, notdef, notdef, notdef, notdef, notdef, notdef,
- notdef, "AE", notdef, "ordfeminine", notdef, notdef,
- notdef, notdef, "Lslash", "Oslash", "OE", "ordmasculine", notdef,
- notdef, notdef, notdef, notdef, "ae", notdef, notdef,
- notdef, "dotlessi", notdef, notdef, "lslash", "oslash", "oe",
- "germandbls", notdef, notdef, notdef, notdef };
-static const char charstringname[] = "/CharStrings";
-
-@ @<Glob...@>=
-char **t1_glyph_names;
-char *t1_builtin_glyph_names[256];
-char charsetstr[0x4000];
-boolean read_encoding_only;
-int t1_encoding;
-
-@ @c
-#define T1_BUF_SIZE 0x10
-
-#define CS_HSTEM 1
-#define CS_VSTEM 3
-#define CS_VMOVETO 4
-#define CS_RLINETO 5
-#define CS_HLINETO 6
-#define CS_VLINETO 7
-#define CS_RRCURVETO 8
-#define CS_CLOSEPATH 9
-#define CS_CALLSUBR 10
-#define CS_RETURN 11
-#define CS_ESCAPE 12
-#define CS_HSBW 13
-#define CS_ENDCHAR 14
-#define CS_RMOVETO 21
-#define CS_HMOVETO 22
-#define CS_VHCURVETO 30
-#define CS_HVCURVETO 31
-#define CS_1BYTE_MAX (CS_HVCURVETO + 1)
-
-#define CS_DOTSECTION CS_1BYTE_MAX + 0
-#define CS_VSTEM3 CS_1BYTE_MAX + 1
-#define CS_HSTEM3 CS_1BYTE_MAX + 2
-#define CS_SEAC CS_1BYTE_MAX + 6
-#define CS_SBW CS_1BYTE_MAX + 7
-#define CS_DIV CS_1BYTE_MAX + 12
-#define CS_CALLOTHERSUBR CS_1BYTE_MAX + 16
-#define CS_POP CS_1BYTE_MAX + 17
-#define CS_SETCURRENTPOINT CS_1BYTE_MAX + 33
-#define CS_2BYTE_MAX (CS_SETCURRENTPOINT + 1)
-#define CS_MAX CS_2BYTE_MAX
-
-@ @<Types...@>=
-typedef unsigned char byte;
-typedef struct {
- byte nargs; /* number of arguments */
- boolean bottom; /* take arguments from bottom of stack? */
- boolean clear; /* clear stack? */
- boolean valid;
-} cc_entry; /* CharString Command */
-typedef struct {
- char *glyph_name; /* glyph name (or notdef for Subrs entry) */
- byte *data;
- unsigned short len; /* length of the whole string */
- unsigned short cslen; /* length of the encoded part of the string */
- boolean is_used;
- boolean valid;
-} cs_entry;
-
-@ @<Glob...@>=
-unsigned short t1_dr, t1_er;
-unsigned short t1_c1, t1_c2;
-unsigned short t1_cslen;
-short t1_lenIV;
-
-@ @<Set initial...@>=
-mp->ps->t1_c1 = 52845;
-mp->ps->t1_c2 = 22719;
-
-@ @<Types...@>=
-typedef char t1_line_entry;
-typedef char t1_buf_entry;
-
-@ @<Glob...@>=
-t1_line_entry *t1_line_ptr, *t1_line_array;
-size_t t1_line_limit;
-t1_buf_entry *t1_buf_ptr, *t1_buf_array;
-size_t t1_buf_limit;
-int cs_start;
-cs_entry *cs_tab, *cs_ptr, *cs_notdef;
-char *cs_dict_start, *cs_dict_end;
-int cs_count, cs_size, cs_size_pos;
-cs_entry *subr_tab;
-char *subr_array_start, *subr_array_end;
-int subr_max, subr_size, subr_size_pos;
-
-@ @<Set initial...@>=
-mp->ps->t1_line_array = NULL;
-mp->ps->t1_buf_array = NULL;
-
-@
- This list contains the begin/end tokens commonly used in the
- /Subrs array of a Type 1 font.
-
-@<Static variables in the outer block@>=
-static const char *cs_token_pairs_list[][2] = {
- {" RD", "NP"},
- {" -|", "|"},
- {" RD", "noaccess put"},
- {" -|", "noaccess put"},
- {NULL, NULL}
-};
-
-@ @<Glob...@>=
-const char **cs_token_pair;
-boolean t1_pfa, t1_cs, t1_scan, t1_eexec_encrypt, t1_synthetic;
-int t1_in_eexec; /* 0 before eexec-encrypted, 1 during, 2 after */
-long t1_block_length;
-int last_hexbyte;
-void *t1_file;
-int hexline_length;
-
-@
-@d HEXLINE_WIDTH 64
-
-@<Set initial ...@>=
-mp->ps->hexline_length = 0;
-
-@
-@d t1_prefix(s) str_prefix(mp->ps->t1_line_array, s)
-@d t1_buf_prefix(s) str_prefix(mp->ps->t1_buf_array, s)
-@d t1_suffix(s) str_suffix(mp->ps->t1_line_array, mp->ps->t1_line_ptr, s)
-@d t1_buf_suffix(s) str_suffix(mp->ps->t1_buf_array, mp->ps->t1_buf_ptr, s)
-@d t1_charstrings() strstr(mp->ps->t1_line_array, charstringname)
-@d t1_subrs() t1_prefix("/Subrs")
-@d t1_end_eexec() t1_suffix("mark currentfile closefile")
-@d t1_cleartomark() t1_prefix("cleartomark")
-
-@d isdigit(A) ((A)>='0'&&(A)<='9')
-
-@c
-static void end_hexline (MP mp) {
- if (mp->ps->hexline_length >= HEXLINE_WIDTH) {
- wps_cr;
- mp->ps->hexline_length = 0;
- }
-}
-static void t1_check_pfa (MP mp) {
- const int c = t1_getchar (mp);
- mp->ps->t1_pfa = (c != 128) ? true : false;
- t1_ungetchar (c);
-}
-static int t1_getbyte (MP mp)
-{
- int c = t1_getchar (mp);
- if (mp->ps->t1_pfa)
- return c;
- if (mp->ps->t1_block_length == 0) {
- if (c != 128)
- mp_fatal_error (mp, "invalid marker");
- c = t1_getchar (mp);
- if (c == 3) {
- while (!t1_eof ())
- t1_getchar (mp);
- return EOF;
- }
- mp->ps->t1_block_length = t1_getchar (mp) & 0xff;
- mp->ps->t1_block_length |= (t1_getchar (mp) & 0xff) << 8;
- mp->ps->t1_block_length |= (t1_getchar (mp) & 0xff) << 16;
- mp->ps->t1_block_length |= (t1_getchar (mp) & 0xff) << 24;
- c = t1_getchar (mp);
- }
- mp->ps->t1_block_length--;
- return c;
-}
-static int hexval (int c) {
- if (c >= 'A' && c <= 'F')
- return c - 'A' + 10;
- else if (c >= 'a' && c <= 'f')
- return c - 'a' + 10;
- else if (c >= '0' && c <= '9')
- return c - '0';
- else
- return -1;
-}
-static byte edecrypt (MP mp, byte cipher) {
- byte plain;
- if (mp->ps->t1_pfa) {
- while (cipher == 10 || cipher == 13)
- cipher = t1_getbyte (mp);
- mp->ps->last_hexbyte = cipher = (hexval (cipher) << 4) + hexval (t1_getbyte (mp));
- }
- plain = (cipher ^ (mp->ps->t1_dr >> 8));
- mp->ps->t1_dr = (cipher + mp->ps->t1_dr) * mp->ps->t1_c1 + mp->ps->t1_c2;
- return plain;
-}
-static byte cdecrypt (MP mp, byte cipher, unsigned short *cr)
-{
- const byte plain = (cipher ^ (*cr >> 8));
- *cr = (cipher + *cr) * mp->ps->t1_c1 + mp->ps->t1_c2;
- return plain;
-}
-static byte eencrypt (MP mp, byte plain)
-{
- const byte cipher = (plain ^ (mp->ps->t1_er >> 8));
- mp->ps->t1_er = (cipher + mp->ps->t1_er) * mp->ps->t1_c1 + mp->ps->t1_c2;
- return cipher;
-}
-
-static byte cencrypt (MP mp, byte plain, unsigned short *cr)
-{
- const byte cipher = (plain ^ (*cr >> 8));
- *cr = (cipher + *cr) * mp->ps->t1_c1 + mp->ps->t1_c2;
- return cipher;
-}
-
-static char *eol (char *s) {
- char *p = strend (s);
- if (p - s > 1 && p[-1] != 10) {
- *p++ = 10;
- *p = 0;
- }
- return p;
-}
-static float t1_scan_num (MP mp, char *p, char **r)
-{
- float f;
- char s[128];
- skip (p, ' ');
- if (sscanf (p, "%g", &f) != 1) {
- remove_eol (p, mp->ps->t1_line_array);
- snprintf(s,128, "a number expected: `%s'", mp->ps->t1_line_array);
- mp_fatal_error(mp,s);
- }
- if (r != NULL) {
- for (; isdigit (*p) || *p == '.' ||
- *p == 'e' || *p == 'E' || *p == '+' || *p == '-'; p++);
- *r = p;
- }
- return f;
-}
-
-static boolean str_suffix (const char *begin_buf, const char *end_buf,
- const char *s)
-{
- const char *s1 = end_buf - 1, *s2 = strend (s) - 1;
- if (*s1 == 10)
- s1--;
- while (s1 >= begin_buf && s2 >= s) {
- if (*s1-- != *s2--)
- return false;
- }
- return s2 < s;
-}
-
-@
-
-@d alloc_array(T, n, s) do {
- if (mp->ps->T##_array == NULL) {
- mp->ps->T##_limit = (s);
- if ((unsigned)(n) > mp->ps->T##_limit)
- mp->ps->T##_limit = (n);
- mp->ps->T##_array = mp_xmalloc (mp,mp->ps->T##_limit,sizeof(T##_entry));
- mp->ps->T##_ptr = mp->ps->T##_array;
- }
- else if ((unsigned)(mp->ps->T##_ptr - mp->ps->T##_array + (n)) > mp->ps->T##_limit) {
- size_t last_ptr_index;
- last_ptr_index = mp->ps->T##_ptr - mp->ps->T##_array;
- mp->ps->T##_limit *= 2;
- if ((unsigned)(mp->ps->T##_ptr - mp->ps->T##_array + (n)) > mp->ps->T##_limit)
- mp->ps->T##_limit = mp->ps->T##_ptr - mp->ps->T##_array + (n);
- mp->ps->T##_array = mp_xrealloc(mp,mp->ps->T##_array,mp->ps->T##_limit, sizeof(T##_entry));
- mp->ps->T##_ptr = mp->ps->T##_array + last_ptr_index;
- }
-} while (0)
-
-@d out_eexec_char(A) t1_outhex(mp,(A))
-
-@c
-static void t1_outhex (MP mp, byte b)
-{
- static const char *hexdigits = "0123456789ABCDEF";
- t1_putchar (hexdigits[b / 16]);
- t1_putchar (hexdigits[b % 16]);
- mp->ps->hexline_length += 2;
- end_hexline (mp);
-}
-static void t1_getline (MP mp) {
- int c, l, eexec_scan;
- char *p;
- static const char eexec_str[] = "currentfile eexec";
- static int eexec_len = 17; /* |strlen(eexec_str)| */
- RESTART:
- if (t1_eof ())
- mp_fatal_error (mp,"unexpected end of file");
- mp->ps->t1_line_ptr = mp->ps->t1_line_array;
- alloc_array (t1_line, 1, T1_BUF_SIZE);
- mp->ps->t1_cslen = 0;
- eexec_scan = 0;
- c = t1_getbyte (mp);
- if (c == EOF)
- goto EXIT;
- while (!t1_eof ()) {
- if (mp->ps->t1_in_eexec == 1)
- c = edecrypt (mp,c);
- alloc_array (t1_line, 1, T1_BUF_SIZE);
- append_char_to_buf (c, mp->ps->t1_line_ptr, mp->ps->t1_line_array, mp->ps->t1_line_limit);
- if (mp->ps->t1_in_eexec == 0 && eexec_scan >= 0 && eexec_scan < eexec_len) {
- if (mp->ps->t1_line_array[eexec_scan] == eexec_str[eexec_scan])
- eexec_scan++;
- else
- eexec_scan = -1;
- }
- if (c == 10 || (mp->ps->t1_pfa && eexec_scan == eexec_len && c == 32))
- break;
- if (mp->ps->t1_cs && mp->ps->t1_cslen == 0 &&
- (mp->ps->t1_line_ptr - mp->ps->t1_line_array > 4) &&
- (t1_suffix (" RD ") || t1_suffix (" -| "))) {
- p = mp->ps->t1_line_ptr - 5;
- while (*p != ' ')
- p--;
- mp->ps->t1_cslen = l = t1_scan_num (mp, p + 1, 0);
- mp->ps->cs_start = mp->ps->t1_line_ptr - mp->ps->t1_line_array;
- /* |mp->ps->cs_start| is an index now */
- alloc_array (t1_line, l, T1_BUF_SIZE);
- while (l-- > 0)
- *mp->ps->t1_line_ptr++ = edecrypt (mp,t1_getbyte (mp));
- }
- c = t1_getbyte (mp);
- }
- alloc_array (t1_line, 2, T1_BUF_SIZE); /* |append_eol| can append 2 chars */
- append_eol (mp->ps->t1_line_ptr, mp->ps->t1_line_array, mp->ps->t1_line_limit);
- if (mp->ps->t1_line_ptr - mp->ps->t1_line_array < 2)
- goto RESTART;
- if (eexec_scan == eexec_len)
- mp->ps->t1_in_eexec = 1;
- EXIT:
- /* ensure that |mp->ps->t1_buf_array| has as much room as |t1_line_array| */
- mp->ps->t1_buf_ptr = mp->ps->t1_buf_array;
- alloc_array (t1_buf, mp->ps->t1_line_limit, mp->ps->t1_line_limit);
-}
-
-static void t1_putline (MP mp)
-{
- char *p = mp->ps->t1_line_array;
- if (mp->ps->t1_line_ptr - mp->ps->t1_line_array <= 1)
- return;
- if (mp->ps->t1_eexec_encrypt) {
- while (p < mp->ps->t1_line_ptr)
- out_eexec_char (eencrypt (mp,*p++));
- } else {
- while (p < mp->ps->t1_line_ptr)
- t1_putchar (*p++);
- }
-}
-
-static void t1_puts (MP mp, const char *s)
-{
- if (s != mp->ps->t1_line_array)
- strcpy (mp->ps->t1_line_array, s);
- mp->ps->t1_line_ptr = strend (mp->ps->t1_line_array);
- t1_putline (mp);
-}
-
-static void t1_printf (MP mp, const char *fmt, ...)
-{
- va_list args;
- va_start (args, fmt);
- vsprintf (mp->ps->t1_line_array, fmt, args);
- t1_puts (mp,mp->ps->t1_line_array);
- va_end (args);
-}
-
-static void t1_init_params (MP mp, char *open_name_prefix,
- char *cur_file_name) {
- if ((open_name_prefix != NULL) && strlen(open_name_prefix)) {
- t1_log (open_name_prefix);
- t1_log (cur_file_name);
- }
- mp->ps->t1_lenIV = 4;
- mp->ps->t1_dr = 55665;
- mp->ps->t1_er = 55665;
- mp->ps->t1_in_eexec = 0;
- mp->ps->t1_cs = false;
- mp->ps->t1_scan = true;
- mp->ps->t1_synthetic = false;
- mp->ps->t1_eexec_encrypt = false;
- mp->ps->t1_block_length = 0;
- t1_check_pfa (mp);
-}
-static void t1_close_font_file (MP mp, const char *close_name_suffix) {
- if ((close_name_suffix != NULL) && strlen(close_name_suffix)) {
- t1_log (close_name_suffix);
- }
- t1_close ();
-}
-
-static void t1_check_block_len (MP mp, boolean decrypt) {
- int l, c;
- char s[128];
- if (mp->ps->t1_block_length == 0)
- return;
- c = t1_getbyte (mp);
- if (decrypt)
- c = edecrypt (mp,c);
- l = mp->ps->t1_block_length;
- if (!(l == 0 && (c == 10 || c == 13))) {
- snprintf(s,128,"%i bytes more than expected were ignored", l+ 1);
- mp_warn(mp,s);
- while (l-- > 0)
- t1_getbyte (mp);
- }
-}
-static void t1_start_eexec (MP mp, fm_entry *fm_cur) {
- int i;
- if (!mp->ps->t1_pfa)
- t1_check_block_len (mp, false);
- for (mp->ps->t1_line_ptr = mp->ps->t1_line_array, i = 0; i < 4; i++) {
- edecrypt (mp, t1_getbyte (mp));
- *mp->ps->t1_line_ptr++ = 0;
- }
- mp->ps->t1_eexec_encrypt = true;
- if (!mp->ps->read_encoding_only)
- if (is_included (fm_cur))
- t1_putline (mp); /* to put the first four bytes */
-}
-static void t1_stop_eexec (MP mp) {
- int c;
- end_last_eexec_line ();
- if (!mp->ps->t1_pfa)
- t1_check_block_len (mp,true);
- else {
- c = edecrypt (mp, t1_getbyte (mp));
- if (!(c == 10 || c == 13)) {
- if (mp->ps->last_hexbyte == 0)
- t1_puts (mp,"00");
- else
- mp_warn (mp,"unexpected data after eexec");
- }
- }
- mp->ps->t1_cs = false;
- mp->ps->t1_in_eexec = 2;
-}
-static void t1_modify_fm (MP mp) {
- mp->ps->t1_line_ptr = eol (mp->ps->t1_line_array);
-}
-
-static void t1_modify_italic (MP mp) {
- mp->ps->t1_line_ptr = eol (mp->ps->t1_line_array);
-}
-
-@ @<Types...@>=
-typedef struct {
- const char *pdfname;
- const char *t1name;
- float value;
- boolean valid;
-} key_entry;
-
-@
-@d FONT_KEYS_NUM 11
-
-@<Declarations@>=
-static key_entry font_keys[FONT_KEYS_NUM] = {
- {"Ascent", "Ascender", 0, false},
- {"CapHeight", "CapHeight", 0, false},
- {"Descent", "Descender", 0, false},
- {"FontName", "FontName", 0, false},
- {"ItalicAngle", "ItalicAngle", 0, false},
- {"StemV", "StdVW", 0, false},
- {"XHeight", "XHeight", 0, false},
- {"FontBBox", "FontBBox", 0, false},
- {"", "", 0, false},
- {"", "", 0, false},
- {"", "", 0, false}
-};
-
-
-@
-@d ASCENT_CODE 0
-@d CAPHEIGHT_CODE 1
-@d DESCENT_CODE 2
-@d FONTNAME_CODE 3
-@d ITALIC_ANGLE_CODE 4
-@d STEMV_CODE 5
-@d XHEIGHT_CODE 6
-@d FONTBBOX1_CODE 7
-@d FONTBBOX2_CODE 8
-@d FONTBBOX3_CODE 9
-@d FONTBBOX4_CODE 10
-@d MAX_KEY_CODE (FONTBBOX1_CODE + 1)
-
-@c
-static void t1_scan_keys (MP mp, int tex_font,fm_entry *fm_cur) {
- int i, k;
- char *p, *r;
- key_entry *key;
- if (fm_extend (fm_cur) != 0 || fm_slant (fm_cur) != 0) {
- if (t1_prefix ("/FontMatrix")) {
- t1_modify_fm (mp);
- return;
- }
- if (t1_prefix ("/ItalicAngle")) {
- t1_modify_italic (mp);
- return;
- }
- }
- if (t1_prefix ("/FontType")) {
- p = mp->ps->t1_line_array + strlen ("FontType") + 1;
- if ((i = t1_scan_num (mp,p, 0)) != 1) {
- char s[128];
- snprintf(s,125,"Type%d fonts unsupported by metapost", i);
- mp_fatal_error(mp,s);
- }
- return;
- }
- for (key = font_keys; key - font_keys < MAX_KEY_CODE; key++)
- if (str_prefix (mp->ps->t1_line_array + 1, key->t1name))
- break;
- if (key - font_keys == MAX_KEY_CODE)
- return;
- key->valid = true;
- p = mp->ps->t1_line_array + strlen (key->t1name) + 1;
- skip (p, ' ');
- if ((k = key - font_keys) == FONTNAME_CODE) {
- if (*p != '/') {
- char s[128];
- remove_eol (p, mp->ps->t1_line_array);
- snprintf(s,128,"a name expected: `%s'", mp->ps->t1_line_array);
- mp_fatal_error(mp,s);
- }
- r = ++p; /* skip the slash */
- if (is_included (fm_cur)) {
- /* save the fontname */
- strncpy (mp->ps->fontname_buf, p, FONTNAME_BUF_SIZE);
- for (i=0; mp->ps->fontname_buf[i] != 10; i++);
- mp->ps->fontname_buf[i]=0;
-
- if(is_subsetted (fm_cur)) {
- if (fm_cur->encoding!=NULL && fm_cur->encoding->glyph_names!=NULL)
- make_subset_tag (mp,fm_cur, fm_cur->encoding->glyph_names, tex_font);
- else
- make_subset_tag (mp,fm_cur, mp->ps->t1_builtin_glyph_names, tex_font);
-
- alloc_array (t1_line, (r-mp->ps->t1_line_array+6+1+strlen(mp->ps->fontname_buf)+1),
- T1_BUF_SIZE);
- strncpy (r, fm_cur->subset_tag , 6);
- *(r+6) = '-';
- strncpy (r+7, mp->ps->fontname_buf, strlen(mp->ps->fontname_buf)+1);
- mp->ps->t1_line_ptr = eol (r);
- } else {
- /* |for (q = p; *q != ' ' && *q != 10; *q++);|*/
- /*|*q = 0;|*/
- mp->ps->t1_line_ptr = eol (r);
- }
- }
- return;
- }
- if ((k == STEMV_CODE || k == FONTBBOX1_CODE)
- && (*p == '[' || *p == '{'))
- p++;
- if (k == FONTBBOX1_CODE) {
- for (i = 0; i < 4; i++) {
- key[i].value = t1_scan_num (mp, p, &r);
- p = r;
- }
- return;
- }
- key->value = t1_scan_num (mp, p, 0);
-}
-static void t1_scan_param (MP mp, int tex_font,fm_entry *fm_cur)
-{
- static const char *lenIV = "/lenIV";
- if (!mp->ps->t1_scan || *mp->ps->t1_line_array != '/')
- return;
- if (t1_prefix (lenIV)) {
- mp->ps->t1_lenIV = t1_scan_num (mp,mp->ps->t1_line_array + strlen (lenIV), 0);
- return;
- }
- t1_scan_keys (mp, tex_font,fm_cur);
-}
-static void copy_glyph_names (MP mp, char **glyph_names, int a, int b) {
- if (glyph_names[b] != notdef) {
- mp_xfree (glyph_names[b]);
- glyph_names[b] = (char *) notdef;
- }
- if (glyph_names[a] != notdef) {
- glyph_names[b] = mp_xstrdup (mp,glyph_names[a]);
- }
-}
-static void t1_builtin_enc (MP mp) {
- int i, a, b, c, counter = 0;
- char *r, *p;
- /*
- * At this moment "/Encoding" is the prefix of |mp->ps->t1_line_array|
- */
- if (t1_suffix ("def")) { /* predefined encoding */
- sscanf (mp->ps->t1_line_array + strlen ("/Encoding"), "%256s", mp->ps->t1_buf_array);
- if (strcmp (mp->ps->t1_buf_array, "StandardEncoding") == 0) {
- for (i = 0; i < 256; i++)
- if (standard_glyph_names[i] == notdef)
- mp->ps->t1_builtin_glyph_names[i] = (char *) notdef;
- else
- mp->ps->t1_builtin_glyph_names[i] =
- mp_xstrdup (mp,standard_glyph_names[i]);
- mp->ps->t1_encoding = ENC_STANDARD;
- } else {
- char s[128];
- snprintf(s,128, "cannot subset font (unknown predefined encoding `%s')",
- mp->ps->t1_buf_array);
- mp_fatal_error(mp,s);
- }
- return;
- } else
- mp->ps->t1_encoding = ENC_BUILTIN;
- /*
- * At this moment "/Encoding" is the prefix of |mp->ps->t1_line_array|, and the encoding is
- * not a predefined encoding
- *
- * We have two possible forms of Encoding vector. The first case is
- *
- * /Encoding [/a /b /c...] readonly def
- *
- * and the second case can look like
- *
- * /Encoding 256 array 0 1 255 {1 index exch /.notdef put} for
- * dup 0 /x put
- * dup 1 /y put
- * ...
- * readonly def
- */
- for (i = 0; i < 256; i++)
- mp->ps->t1_builtin_glyph_names[i] = (char *) notdef;
- if (t1_prefix ("/Encoding [") || t1_prefix ("/Encoding[")) { /* the first case */
- r = strchr (mp->ps->t1_line_array, '[') + 1;
- skip (r, ' ');
- for (;;) {
- while (*r == '/') {
- for (p = mp->ps->t1_buf_array, r++;
- *r != 32 && *r != 10 && *r != ']' && *r != '/';
- *p++ = *r++);
- *p = 0;
- skip (r, ' ');
- if (counter > 255) {
- mp_fatal_error
- (mp, "encoding vector contains more than 256 names");
- }
- if (strcmp (mp->ps->t1_buf_array, notdef) != 0)
- mp->ps->t1_builtin_glyph_names[counter] = mp_xstrdup (mp,mp->ps->t1_buf_array);
- counter++;
- }
- if (*r != 10 && *r != '%') {
- if (str_prefix (r, "] def")
- || str_prefix (r, "] readonly def"))
- break;
- else {
- char s[128];
- remove_eol (r, mp->ps->t1_line_array);
- snprintf(s,128,"a name or `] def' or `] readonly def' expected: `%s'",
- mp->ps->t1_line_array);
- mp_fatal_error(mp,s);
- }
- }
- t1_getline (mp);
- r = mp->ps->t1_line_array;
- }
- } else { /* the second case */
- p = strchr (mp->ps->t1_line_array, 10);
- for (;;) {
- if (*p == 10) {
- t1_getline (mp);
- p = mp->ps->t1_line_array;
- }
- /*
- check for `dup <index> <glyph> put'
- */
- if (sscanf (p, "dup %i%256s put", &i, mp->ps->t1_buf_array) == 2 &&
- *mp->ps->t1_buf_array == '/' && valid_code (i)) {
- if (strcmp (mp->ps->t1_buf_array + 1, notdef) != 0)
- mp->ps->t1_builtin_glyph_names[i] =
- mp_xstrdup (mp,mp->ps->t1_buf_array + 1);
- p = strstr (p, " put") + strlen (" put");
- skip (p, ' ');
- }
- /*
- check for `dup dup <to> exch <from> get put'
- */
- else if (sscanf (p, "dup dup %i exch %i get put", &b, &a) == 2
- && valid_code (a) && valid_code (b)) {
- copy_glyph_names (mp,mp->ps->t1_builtin_glyph_names, a, b);
- p = strstr (p, " get put") + strlen (" get put");
- skip (p, ' ');
- }
- /*
- check for `dup dup <from> <size> getinterval <to> exch putinterval'
- */
- else if (sscanf
- (p, "dup dup %i %i getinterval %i exch putinterval",
- &a, &c, &b) == 3 && valid_code (a) && valid_code (b)
- && valid_code (c)) {
- for (i = 0; i < c; i++)
- copy_glyph_names (mp,mp->ps->t1_builtin_glyph_names, a + i, b + i);
- p = strstr (p, " putinterval") + strlen (" putinterval");
- skip (p, ' ');
- }
- /*
- check for `def' or `readonly def'
- */
- else if ((p == mp->ps->t1_line_array || (p > mp->ps->t1_line_array && p[-1] == ' '))
- && strcmp (p, "def\n") == 0)
- return;
- /*
- skip an unrecognizable word
- */
- else {
- while (*p != ' ' && *p != 10)
- p++;
- skip (p, ' ');
- }
- }
- }
-}
-
-static void t1_check_end (MP mp) {
- if (t1_eof ())
- return;
- t1_getline (mp);
- if (t1_prefix ("{restore}"))
- t1_putline (mp);
-}
-
-@ @<Types...@>=
-typedef struct {
- char *ff_name; /* base name of font file */
- char *ff_path; /* full path to font file */
-} ff_entry;
-
-@ @c
-static boolean t1_open_fontfile (MP mp, fm_entry *fm_cur,const char *open_name_prefix) {
- ff_entry *ff;
- ff = check_ff_exist (mp, fm_cur);
- if (ff->ff_path != NULL) {
- mp->ps->t1_file = (mp->open_file)(mp,ff->ff_path, "r", mp_filetype_font);
- } else {
- mp_warn (mp, "cannot open Type 1 font file for reading");
- return false;
- }
- t1_init_params (mp,(char *)open_name_prefix,fm_cur->ff_name);
- mp->ps->fontfile_found = true;
- return true;
-}
-
-static void t1_scan_only (MP mp, int tex_font, fm_entry *fm_cur) {
- do {
- t1_getline (mp);
- t1_scan_param (mp,tex_font, fm_cur);
- }
- while (mp->ps->t1_in_eexec == 0);
- t1_start_eexec (mp,fm_cur);
- do {
- t1_getline (mp);
- t1_scan_param (mp,tex_font, fm_cur);
- }
- while (!(t1_charstrings () || t1_subrs ()));
-}
-
-static void t1_include (MP mp, int tex_font, fm_entry *fm_cur) {
- do {
- t1_getline (mp);
- t1_scan_param (mp,tex_font, fm_cur);
- t1_putline (mp);
- }
- while (mp->ps->t1_in_eexec == 0);
- t1_start_eexec (mp,fm_cur);
- do {
- t1_getline (mp);
- t1_scan_param (mp,tex_font, fm_cur);
- t1_putline (mp);
- }
- while (!(t1_charstrings () || t1_subrs ()));
- mp->ps->t1_cs = true;
- do {
- t1_getline (mp);
- t1_putline (mp);
- }
- while (!t1_end_eexec ());
- t1_stop_eexec (mp);
- if (fixedcontent) { /* copy 512 zeros (not needed for PDF) */
- do {
- t1_getline (mp);
- t1_putline (mp);
- }
- while (!t1_cleartomark ());
- t1_check_end (mp); /* write "{restore}if" if found */
- }
-}
-
-@
-@d check_subr(SUBR) if (SUBR >= mp->ps->subr_size || SUBR < 0) {
- char s[128];
- snprintf(s,128,"Subrs array: entry index out of range (%i)",SUBR);
- mp_fatal_error(mp,s);
- }
-
-@c
-static const char **check_cs_token_pair (MP mp) {
- const char **p = (const char **) cs_token_pairs_list;
- for (; p[0] != NULL; ++p)
- if (t1_buf_prefix (p[0]) && t1_buf_suffix (p[1]))
- return p;
- return NULL;
-}
-
-static void cs_store (MP mp, boolean is_subr) {
- char *p;
- cs_entry *ptr;
- int subr;
- for (p = mp->ps->t1_line_array, mp->ps->t1_buf_ptr = mp->ps->t1_buf_array; *p != ' ';
- *mp->ps->t1_buf_ptr++ = *p++);
- *mp->ps->t1_buf_ptr = 0;
- if (is_subr) {
- subr = t1_scan_num (mp, p + 1, 0);
- check_subr (subr);
- ptr = mp->ps->subr_tab + subr;
- } else {
- ptr = mp->ps->cs_ptr++;
- if (mp->ps->cs_ptr - mp->ps->cs_tab > mp->ps->cs_size) {
- char s[128];
- snprintf(s,128,"CharStrings dict: more entries than dict size (%i)",mp->ps->cs_size);
- mp_fatal_error(mp,s);
- }
- if (strcmp (mp->ps->t1_buf_array + 1, notdef) == 0) /* skip the slash */
- ptr->glyph_name = (char *) notdef;
- else
- ptr->glyph_name = mp_xstrdup (mp,mp->ps->t1_buf_array + 1);
- }
- /* copy " RD " + cs data to |mp->ps->t1_buf_array| */
- memcpy (mp->ps->t1_buf_array, mp->ps->t1_line_array + mp->ps->cs_start - 4,
- (unsigned) (mp->ps->t1_cslen + 4));
- /* copy the end of cs data to |mp->ps->t1_buf_array| */
- for (p = mp->ps->t1_line_array + mp->ps->cs_start + mp->ps->t1_cslen, mp->ps->t1_buf_ptr =
- mp->ps->t1_buf_array + mp->ps->t1_cslen + 4; *p != 10; *mp->ps->t1_buf_ptr++ = *p++);
- *mp->ps->t1_buf_ptr++ = 10;
- if (is_subr && mp->ps->cs_token_pair == NULL)
- mp->ps->cs_token_pair = check_cs_token_pair (mp);
- ptr->len = mp->ps->t1_buf_ptr - mp->ps->t1_buf_array;
- ptr->cslen = mp->ps->t1_cslen;
- ptr->data = mp_xmalloc (mp,ptr->len , sizeof (byte));
- memcpy (ptr->data, mp->ps->t1_buf_array, ptr->len);
- ptr->valid = true;
-}
-
-#define store_subr(mp) cs_store(mp,true)
-#define store_cs(mp) cs_store(mp,false)
-
-#define CC_STACK_SIZE 24
-
-static integer cc_stack[CC_STACK_SIZE], *stack_ptr = cc_stack;
-static cc_entry cc_tab[CS_MAX];
-static boolean is_cc_init = false;
-
-
-#define cc_pop(N) \
- if (stack_ptr - cc_stack < (N)) \
- stack_error(N); \
- stack_ptr -= N
-
-#define stack_error(N) { \
- char s[256]; \
- snprintf(s,255,"CharString: invalid access (%i) to stack (%i entries)", \
- (int) N, (int)(stack_ptr - cc_stack)); \
- mp_warn(mp,s); \
- goto cs_error; \
-}
-
-
-#define cc_get(N) ((N) < 0 ? *(stack_ptr + (N)) : *(cc_stack + (N)))
-
-#define cc_push(V) *stack_ptr++ = V
-#define cc_clear() stack_ptr = cc_stack
-
-#define set_cc(N, B, A, C) \
- cc_tab[N].nargs = A; \
- cc_tab[N].bottom = B; \
- cc_tab[N].clear = C; \
- cc_tab[N].valid = true
-
-static void cc_init (void) {
- int i;
- if (is_cc_init)
- return;
- for (i = 0; i < CS_MAX; i++)
- cc_tab[i].valid = false;
- set_cc (CS_HSTEM, true, 2, true);
- set_cc (CS_VSTEM, true, 2, true);
- set_cc (CS_VMOVETO, true, 1, true);
- set_cc (CS_RLINETO, true, 2, true);
- set_cc (CS_HLINETO, true, 1, true);
- set_cc (CS_VLINETO, true, 1, true);
- set_cc (CS_RRCURVETO, true, 6, true);
- set_cc (CS_CLOSEPATH, false, 0, true);
- set_cc (CS_CALLSUBR, false, 1, false);
- set_cc (CS_RETURN, false, 0, false);
- /*
- |set_cc(CS_ESCAPE, false, 0, false);|
- */
- set_cc (CS_HSBW, true, 2, true);
- set_cc (CS_ENDCHAR, false, 0, true);
- set_cc (CS_RMOVETO, true, 2, true);
- set_cc (CS_HMOVETO, true, 1, true);
- set_cc (CS_VHCURVETO, true, 4, true);
- set_cc (CS_HVCURVETO, true, 4, true);
- set_cc (CS_DOTSECTION, false, 0, true);
- set_cc (CS_VSTEM3, true, 6, true);
- set_cc (CS_HSTEM3, true, 6, true);
- set_cc (CS_SEAC, true, 5, true);
- set_cc (CS_SBW, true, 4, true);
- set_cc (CS_DIV, false, 2, false);
- set_cc (CS_CALLOTHERSUBR, false, 0, false);
- set_cc (CS_POP, false, 0, false);
- set_cc (CS_SETCURRENTPOINT, true, 2, true);
- is_cc_init = true;
-}
-
-@
-
-@d cs_getchar(mp) cdecrypt(mp,*data++, &cr)
-
-@d mark_subr(mp,n) cs_mark(mp,0, n)
-@d mark_cs(mp,s) cs_mark(mp,s, 0)
-@d SMALL_BUF_SIZE 256
-
-@c
-static void cs_warn (MP mp, const char *cs_name, int subr, const char *fmt, ...) {
- char buf[SMALL_BUF_SIZE];
- char s[300];
- va_list args;
- va_start (args, fmt);
- vsprintf (buf, fmt, args);
- va_end (args);
- if (cs_name == NULL) {
- snprintf(s,299,"Subr (%i): %s", (int) subr, buf);
- } else {
- snprintf(s,299,"CharString (/%s): %s", cs_name, buf);
- }
- mp_warn(mp,s);
-}
-
-static void cs_mark (MP mp, const char *cs_name, int subr)
-{
- byte *data;
- int i, b, cs_len;
- integer a, a1, a2;
- unsigned short cr;
- static integer lastargOtherSubr3 = 3; /* the argument of last call to
- OtherSubrs[3] */
- cs_entry *ptr;
- cc_entry *cc;
- if (cs_name == NULL) {
- check_subr (subr);
- ptr = mp->ps->subr_tab + subr;
- if (!ptr->valid)
- return;
- } else {
- if (mp->ps->cs_notdef != NULL &&
- (cs_name == notdef || strcmp (cs_name, notdef) == 0))
- ptr = mp->ps->cs_notdef;
- else {
- for (ptr = mp->ps->cs_tab; ptr < mp->ps->cs_ptr; ptr++)
- if (strcmp (ptr->glyph_name, cs_name) == 0)
- break;
- if (ptr == mp->ps->cs_ptr) {
- char s[128];
- snprintf (s,128,"glyph `%s' undefined", cs_name);
- mp_warn(mp,s);
- return;
- }
- if (ptr->glyph_name == notdef)
- mp->ps->cs_notdef = ptr;
- }
- }
- /* only marked CharString entries and invalid entries can be skipped;
- valid marked subrs must be parsed to keep the stack in sync */
- if (!ptr->valid || (ptr->is_used && cs_name != NULL))
- return;
- ptr->is_used = true;
- cr = 4330;
- cs_len = ptr->cslen;
- data = ptr->data + 4;
- for (i = 0; i < mp->ps->t1_lenIV; i++, cs_len--)
- cs_getchar (mp);
- while (cs_len > 0) {
- --cs_len;
- b = cs_getchar (mp);
- if (b >= 32) {
- if (b <= 246)
- a = b - 139;
- else if (b <= 250) {
- --cs_len;
- a = ((b - 247) << 8) + 108 + cs_getchar (mp);
- } else if (b <= 254) {
- --cs_len;
- a = -((b - 251) << 8) - 108 - cs_getchar (mp);
- } else {
- cs_len -= 4;
- a = (cs_getchar (mp) & 0xff) << 24;
- a |= (cs_getchar (mp) & 0xff) << 16;
- a |= (cs_getchar (mp) & 0xff) << 8;
- a |= (cs_getchar (mp) & 0xff) << 0;
- if (sizeof (integer) > 4 && (a & 0x80000000))
- a |= ~0x7FFFFFFF;
- }
- cc_push (a);
- } else {
- if (b == CS_ESCAPE) {
- b = cs_getchar (mp) + CS_1BYTE_MAX;
- cs_len--;
- }
- if (b >= CS_MAX) {
- cs_warn (mp,cs_name, subr, "command value out of range: %i",
- (int) b);
- goto cs_error;
- }
- cc = cc_tab + b;
- if (!cc->valid) {
- cs_warn (mp,cs_name, subr, "command not valid: %i", (int) b);
- goto cs_error;
- }
- if (cc->bottom) {
- if (stack_ptr - cc_stack < cc->nargs)
- cs_warn (mp,cs_name, subr,
- "less arguments on stack (%i) than required (%i)",
- (int) (stack_ptr - cc_stack), (int) cc->nargs);
- else if (stack_ptr - cc_stack > cc->nargs)
- cs_warn (mp,cs_name, subr,
- "more arguments on stack (%i) than required (%i)",
- (int) (stack_ptr - cc_stack), (int) cc->nargs);
- }
- switch (cc - cc_tab) {
- case CS_CALLSUBR:
- a1 = cc_get (-1);
- cc_pop (1);
- mark_subr (mp,a1);
- if (!mp->ps->subr_tab[a1].valid) {
- cs_warn (mp,cs_name, subr, "cannot call subr (%i)", (int) a1);
- goto cs_error;
- }
- break;
- case CS_DIV:
- cc_pop (2);
- cc_push (0);
- break;
- case CS_CALLOTHERSUBR:
- if (cc_get (-1) == 3)
- lastargOtherSubr3 = cc_get (-3);
- a1 = cc_get (-2) + 2;
- cc_pop (a1);
- break;
- case CS_POP:
- cc_push (lastargOtherSubr3);
- /* the only case when we care about the value being pushed onto
- stack is when POP follows CALLOTHERSUBR (changing hints by
- OtherSubrs[3])
- */
- break;
- case CS_SEAC:
- a1 = cc_get (3);
- a2 = cc_get (4);
- cc_clear ();
- mark_cs (mp,standard_glyph_names[a1]);
- mark_cs (mp,standard_glyph_names[a2]);
- break;
- default:
- if (cc->clear)
- cc_clear ();
- }
- }
- }
- return;
- cs_error: /* an error occured during parsing */
- cc_clear ();
- ptr->valid = false;
- ptr->is_used = false;
-}
-
-static void t1_subset_ascii_part (MP mp, int tex_font, fm_entry *fm_cur)
-{
- int i, j;
- t1_getline (mp);
- while (!t1_prefix ("/Encoding")) {
- t1_scan_param (mp,tex_font, fm_cur);
- t1_putline (mp);
- t1_getline (mp);
- }
- t1_builtin_enc (mp);
- if (is_reencoded (fm_cur))
- mp->ps->t1_glyph_names = external_enc ();
- else
- mp->ps->t1_glyph_names = mp->ps->t1_builtin_glyph_names;
- /*
- |if (is_included (fm_cur) && is_subsetted (fm_cur)) {
- make_subset_tag (fm_cur, t1_glyph_names, tex_font);
- update_subset_tag ();
- }|
- */
- if ((!is_subsetted (fm_cur)) && mp->ps->t1_encoding == ENC_STANDARD)
- t1_puts (mp,"/Encoding StandardEncoding def\n");
- else {
- t1_puts
- (mp,"/Encoding 256 array\n0 1 255 {1 index exch /.notdef put} for\n");
- for (i = 0, j = 0; i < 256; i++) {
- if (is_used_char (i) && mp->ps->t1_glyph_names[i] != notdef) {
- j++;
- t1_printf (mp,"dup %i /%s put\n", (int) t1_char (i),
- mp->ps->t1_glyph_names[i]);
- }
- }
- /* We didn't mark anything for the Encoding array. */
- /* We add "dup 0 /.notdef put" for compatibility */
- /* with Acrobat 5.0. */
- if (j == 0)
- t1_puts (mp,"dup 0 /.notdef put\n");
- t1_puts (mp,"readonly def\n");
- }
- do {
- t1_getline (mp);
- t1_scan_param (mp,tex_font, fm_cur);
- if (!t1_prefix ("/UniqueID")) /* ignore UniqueID for subsetted fonts */
- t1_putline (mp);
- }
- while (mp->ps->t1_in_eexec == 0);
-}
-
-#define t1_subr_flush(mp) t1_flush_cs(mp,true)
-#define t1_cs_flush(mp) t1_flush_cs(mp,false)
-
-static void cs_init (MP mp) {
- mp->ps->cs_ptr = mp->ps->cs_tab = NULL;
- mp->ps->cs_dict_start = mp->ps->cs_dict_end = NULL;
- mp->ps->cs_count = mp->ps->cs_size = mp->ps->cs_size_pos = 0;
- mp->ps->cs_token_pair = NULL;
- mp->ps->subr_tab = NULL;
- mp->ps->subr_array_start = mp->ps->subr_array_end = NULL;
- mp->ps->subr_max = mp->ps->subr_size = mp->ps->subr_size_pos = 0;
-}
-
-static void init_cs_entry ( cs_entry * cs) {
- cs->data = NULL;
- cs->glyph_name = NULL;
- cs->len = 0;
- cs->cslen = 0;
- cs->is_used = false;
- cs->valid = false;
-}
-
-static void t1_mark_glyphs (MP mp, int tex_font);
-
-static void t1_read_subrs (MP mp, int tex_font, fm_entry *fm_cur)
-{
- int i, s;
- cs_entry *ptr;
- t1_getline (mp);
- while (!(t1_charstrings () || t1_subrs ())) {
- t1_scan_param (mp,tex_font, fm_cur);
- t1_putline (mp);
- t1_getline (mp);
- }
- FOUND:
- mp->ps->t1_cs = true;
- mp->ps->t1_scan = false;
- if (!t1_subrs ())
- return;
- mp->ps->subr_size_pos = strlen ("/Subrs") + 1;
- /* |subr_size_pos| points to the number indicating dict size after "/Subrs" */
- mp->ps->subr_size = t1_scan_num (mp,mp->ps->t1_line_array + mp->ps->subr_size_pos, 0);
- if (mp->ps->subr_size == 0) {
- while (!t1_charstrings ())
- t1_getline (mp);
- return;
- }
- /* |subr_tab = xtalloc (subr_size, cs_entry);| */
- mp->ps->subr_tab = (cs_entry *)mp_xmalloc (mp,mp->ps->subr_size, sizeof (cs_entry));
- for (ptr = mp->ps->subr_tab; ptr - mp->ps->subr_tab < mp->ps->subr_size; ptr++)
- init_cs_entry (ptr);
- mp->ps->subr_array_start = mp_xstrdup (mp,mp->ps->t1_line_array);
- t1_getline (mp);
- while (mp->ps->t1_cslen) {
- store_subr (mp);
- t1_getline (mp);
- }
- /* mark the first four entries without parsing */
- for (i = 0; i < mp->ps->subr_size && i < 4; i++)
- mp->ps->subr_tab[i].is_used = true;
- /* the end of the Subrs array might have more than one line so we need to
- concatnate them to |subr_array_end|. Unfortunately some fonts don't have
- the Subrs array followed by the CharStrings dict immediately (synthetic
- fonts). If we cannot find CharStrings in next |POST_SUBRS_SCAN| lines then
- we will treat the font as synthetic and ignore everything until next
- Subrs is found
- */
-#define POST_SUBRS_SCAN 5
- s = 0;
- *mp->ps->t1_buf_array = 0;
- for (i = 0; i < POST_SUBRS_SCAN; i++) {
- if (t1_charstrings ())
- break;
- s += mp->ps->t1_line_ptr - mp->ps->t1_line_array;
- alloc_array (t1_buf, s, T1_BUF_SIZE);
- strcat (mp->ps->t1_buf_array, mp->ps->t1_line_array);
- t1_getline (mp);
- }
- mp->ps->subr_array_end = mp_xstrdup (mp,mp->ps->t1_buf_array);
- if (i == POST_SUBRS_SCAN) { /* CharStrings not found;
- suppose synthetic font */
- for (ptr = mp->ps->subr_tab; ptr - mp->ps->subr_tab < mp->ps->subr_size; ptr++)
- if (ptr->valid)
- mp_xfree (ptr->data);
- mp_xfree (mp->ps->subr_tab);
- mp_xfree (mp->ps->subr_array_start);
- mp_xfree (mp->ps->subr_array_end);
- cs_init (mp);
- mp->ps->t1_cs = false;
- mp->ps->t1_synthetic = true;
- while (!(t1_charstrings () || t1_subrs ()))
- t1_getline (mp);
- goto FOUND;
- }
-}
-
-@ @c
-static void t1_flush_cs (MP mp, boolean is_subr)
-{
- char *p;
- byte *r, *return_cs = NULL;
- cs_entry *tab, *end_tab, *ptr;
- char *start_line, *line_end;
- int count, size_pos;
- unsigned short cr, cs_len = 0; /* to avoid warning about uninitialized use of |cs_len| */
- if (is_subr) {
- start_line = mp->ps->subr_array_start;
- line_end = mp->ps->subr_array_end;
- size_pos = mp->ps->subr_size_pos;
- tab = mp->ps->subr_tab;
- count = mp->ps->subr_max + 1;
- end_tab = mp->ps->subr_tab + count;
- } else {
- start_line = mp->ps->cs_dict_start;
- line_end = mp->ps->cs_dict_end;
- size_pos = mp->ps->cs_size_pos;
- tab = mp->ps->cs_tab;
- end_tab = mp->ps->cs_ptr;
- count = mp->ps->cs_count;
- }
- mp->ps->t1_line_ptr = mp->ps->t1_line_array;
- for (p = start_line; p - start_line < size_pos;)
- *mp->ps->t1_line_ptr++ = *p++;
- while (isdigit (*p))
- p++;
- sprintf (mp->ps->t1_line_ptr, "%u", count);
- strcat (mp->ps->t1_line_ptr, p);
- mp->ps->t1_line_ptr = eol (mp->ps->t1_line_array);
- t1_putline (mp);
-
- /* create |return_cs| to replace unsused subr's */
- if (is_subr) {
- cr = 4330;
- cs_len = 0;
- return_cs = mp_xmalloc (mp, (mp->ps->t1_lenIV + 1) , sizeof(byte));
- if ( mp->ps->t1_lenIV > 0) {
- for (cs_len = 0, r = return_cs; cs_len < mp->ps->t1_lenIV; cs_len++, r++)
- *r = cencrypt (mp,0x00, &cr);
- *r = cencrypt (mp,CS_RETURN, &cr);
- } else {
- *return_cs = CS_RETURN;
- }
- cs_len++;
- }
-
- for (ptr = tab; ptr < end_tab; ptr++) {
- if (ptr->is_used) {
- if (is_subr)
- sprintf (mp->ps->t1_line_array, "dup %i %u", (int) (ptr - tab),
- ptr->cslen);
- else
- sprintf (mp->ps->t1_line_array, "/%s %u", ptr->glyph_name, ptr->cslen);
- p = strend (mp->ps->t1_line_array);
- memcpy (p, ptr->data, ptr->len);
- mp->ps->t1_line_ptr = p + ptr->len;
- t1_putline (mp);
- } else {
- /* replace unsused subr's by |return_cs| */
- if (is_subr) {
- sprintf (mp->ps->t1_line_array, "dup %i %u%s ", (int) (ptr - tab),
- cs_len, mp->ps->cs_token_pair[0]);
- p = strend (mp->ps->t1_line_array);
- memcpy (p, return_cs, cs_len);
- mp->ps->t1_line_ptr = p + cs_len;
- t1_putline (mp);
- sprintf (mp->ps->t1_line_array, " %s", mp->ps->cs_token_pair[1]);
- mp->ps->t1_line_ptr = eol (mp->ps->t1_line_array);
- t1_putline (mp);
- }
- }
- mp_xfree (ptr->data);
- if (ptr->glyph_name != notdef)
- mp_xfree (ptr->glyph_name);
- }
- sprintf (mp->ps->t1_line_array, "%s", line_end);
- mp->ps->t1_line_ptr = eol (mp->ps->t1_line_array);
- t1_putline (mp);
- if (is_subr)
- mp_xfree (return_cs);
- mp_xfree (tab);
- mp_xfree (start_line);
- mp_xfree (line_end);
-}
-
-static void t1_mark_glyphs (MP mp, int tex_font)
-{
- int i;
- char *charset = extra_charset ();
- char *g, *s, *r;
- cs_entry *ptr;
- if (mp->ps->t1_synthetic || embed_all_glyphs (tex_font)) { /* mark everything */
- if (mp->ps->cs_tab != NULL)
- for (ptr = mp->ps->cs_tab; ptr < mp->ps->cs_ptr; ptr++)
- if (ptr->valid)
- ptr->is_used = true;
- if (mp->ps->subr_tab != NULL) {
- for (ptr = mp->ps->subr_tab; ptr - mp->ps->subr_tab < mp->ps->subr_size; ptr++)
- if (ptr->valid)
- ptr->is_used = true;
- mp->ps->subr_max = mp->ps->subr_size - 1;
- }
- return;
- }
- mark_cs (mp,notdef);
- for (i = 0; i < 256; i++)
- if (is_used_char (i)) {
- if (mp->ps->t1_glyph_names[i] == notdef) {
- char S[128];
- snprintf(S,128, "character %i is mapped to %s", i, notdef);
- mp_warn(mp,S);
- } else
- mark_cs (mp,mp->ps->t1_glyph_names[i]);
- }
- if (charset == NULL)
- goto SET_SUBR_MAX;
- g = s = charset + 1; /* skip the first '/' */
- r = strend (g);
- while (g < r) {
- while (*s != '/' && s < r)
- s++;
- *s = 0; /* terminate g by rewriting '/' to 0 */
- mark_cs (mp,g);
- g = s + 1;
- }
- SET_SUBR_MAX:
- if (mp->ps->subr_tab != NULL)
- for (mp->ps->subr_max = -1, ptr = mp->ps->subr_tab;
- ptr - mp->ps->subr_tab < mp->ps->subr_size;
- ptr++)
- if (ptr->is_used && ptr - mp->ps->subr_tab > mp->ps->subr_max)
- mp->ps->subr_max = ptr - mp->ps->subr_tab;
-}
-
-static void t1_subset_charstrings (MP mp, int tex_font)
-{
- cs_entry *ptr;
- mp->ps->cs_size_pos =
- strstr (mp->ps->t1_line_array, charstringname) + strlen (charstringname)
- - mp->ps->t1_line_array + 1;
- /* |cs_size_pos| points to the number indicating
- dict size after "/CharStrings" */
- mp->ps->cs_size = t1_scan_num (mp,mp->ps->t1_line_array + mp->ps->cs_size_pos, 0);
- mp->ps->cs_ptr = mp->ps->cs_tab = mp_xmalloc (mp,mp->ps->cs_size, sizeof(cs_entry));
- for (ptr = mp->ps->cs_tab; ptr - mp->ps->cs_tab < mp->ps->cs_size; ptr++)
- init_cs_entry (ptr);
- mp->ps->cs_notdef = NULL;
- mp->ps->cs_dict_start = mp_xstrdup (mp,mp->ps->t1_line_array);
- t1_getline (mp);
- while (mp->ps->t1_cslen) {
- store_cs (mp);
- t1_getline (mp);
- }
- mp->ps->cs_dict_end = mp_xstrdup (mp,mp->ps->t1_line_array);
- t1_mark_glyphs (mp,tex_font);
- if (mp->ps->subr_tab != NULL) {
- if (mp->ps->cs_token_pair == NULL)
- mp_fatal_error
- (mp, "This Type 1 font uses mismatched subroutine begin/end token pairs.");
- t1_subr_flush (mp);
- }
- for (mp->ps->cs_count = 0, ptr = mp->ps->cs_tab; ptr < mp->ps->cs_ptr; ptr++)
- if (ptr->is_used)
- mp->ps->cs_count++;
- t1_cs_flush (mp);
-}
-
-static void t1_subset_end (MP mp)
-{
- if (mp->ps->t1_synthetic) { /* copy to "dup /FontName get exch definefont pop" */
- while (!strstr (mp->ps->t1_line_array, "definefont")) {
- t1_getline (mp);
- t1_putline (mp);
- }
- while (!t1_end_eexec ())
- t1_getline (mp); /* ignore the rest */
- t1_putline (mp); /* write "mark currentfile closefile" */
- } else
- while (!t1_end_eexec ()) { /* copy to "mark currentfile closefile" */
- t1_getline (mp);
- t1_putline (mp);
- }
- t1_stop_eexec (mp);
- if (fixedcontent) { /* copy 512 zeros (not needed for PDF) */
- while (!t1_cleartomark ()) {
- t1_getline (mp);
- t1_putline (mp);
- }
- if (!mp->ps->t1_synthetic) /* don't check "{restore}if" for synthetic fonts */
- t1_check_end (mp); /* write "{restore}if" if found */
- }
-}
-
-static int t1_updatefm (MP mp, int f, fm_entry *fm)
-{
- char *s, *p;
- mp->ps->read_encoding_only = true;
- if (!t1_open_fontfile (mp,fm,NULL)) {
- return 0;
- }
- t1_scan_only (mp,f, fm);
- s = mp_xstrdup(mp,mp->ps->fontname_buf);
- p = s;
- while (*p != ' ' && *p != 0)
- p++;
- *p=0;
- fm->ps_name = s;
- t1_close_font_file (mp,"");
- return 1;
-}
-
-
-static void writet1 (MP mp, int tex_font, fm_entry *fm_cur) {
- int save_selector = mp->selector;
- mp_normalize_selector(mp);
- mp->ps->read_encoding_only = false;
- if (!is_included (fm_cur)) { /* scan parameters from font file */
- if (!t1_open_fontfile (mp,fm_cur,"{"))
- return;
- t1_scan_only (mp,tex_font, fm_cur);
- t1_close_font_file (mp,"}");
- return;
- }
- if (!is_subsetted (fm_cur)) { /* include entire font */
- if (!t1_open_fontfile (mp,fm_cur,"<<"))
- return;
- t1_include (mp,tex_font,fm_cur);
- t1_close_font_file (mp,">>");
- return;
- }
- /* partial downloading */
- if (!t1_open_fontfile (mp,fm_cur,"<"))
- return;
- t1_subset_ascii_part (mp,tex_font,fm_cur);
- t1_start_eexec (mp,fm_cur);
- cc_init ();
- cs_init (mp);
- t1_read_subrs (mp,tex_font, fm_cur);
- t1_subset_charstrings (mp,tex_font);
- t1_subset_end (mp);
- t1_close_font_file (mp,">");
- mp->selector = save_selector;
-}
-
-@ @<Declarations@>=
-static void t1_free (MP mp);
-
-@ @c
-static void t1_free (MP mp) {
- mp_xfree (mp->ps->t1_line_array);
- mp_xfree (mp->ps->t1_buf_array);
-}
-
-
-@* \[44d] Embedding fonts.
-
-@ The |tfm_num| is officially of type |font_number|, but that
-type does not exist yet at this point in the output order.
-
-@<Types...@>=
-typedef struct {
- char *tfm_name; /* TFM file name */
- char *ps_name; /* PostScript name */
- integer flags; /* font flags */
- char *ff_name; /* font file name */
- char *subset_tag; /* pseudoUniqueTag for subsetted font */
- enc_entry *encoding; /* pointer to corresponding encoding */
- unsigned int tfm_num; /* number of the TFM refering this entry */
- unsigned short type; /* font type (T1/TTF/...) */
- short slant; /* SlantFont */
- short extend; /* ExtendFont */
- integer ff_objnum; /* FontFile object number */
- integer fn_objnum; /* FontName/BaseName object number */
- integer fd_objnum; /* FontDescriptor object number */
- char *charset; /* string containing used glyphs */
- boolean all_glyphs; /* embed all glyphs? */
- unsigned short links; /* link flags from |tfm_tree| and |ps_tree| */
- short tfm_avail; /* flags whether a tfm is available */
- short pid; /* Pid for truetype fonts */
- short eid; /* Eid for truetype fonts */
-} fm_entry;
-
-
-@
-@<Glob...@>=
-#define FONTNAME_BUF_SIZE 128
-boolean fontfile_found;
-boolean is_otf_font;
-char fontname_buf[FONTNAME_BUF_SIZE];
-
-@
-@d F_INCLUDED 0x01
-@d F_SUBSETTED 0x02
-@d F_TRUETYPE 0x04
-@d F_BASEFONT 0x08
-
-@d set_included(fm) ((fm)->type |= F_INCLUDED)
-@d set_subsetted(fm) ((fm)->type |= F_SUBSETTED)
-@d set_truetype(fm) ((fm)->type |= F_TRUETYPE)
-@d set_basefont(fm) ((fm)->type |= F_BASEFONT)
-
-@d is_included(fm) ((fm)->type & F_INCLUDED)
-@d is_subsetted(fm) ((fm)->type & F_SUBSETTED)
-@d is_truetype(fm) ((fm)->type & F_TRUETYPE)
-@d is_basefont(fm) ((fm)->type & F_BASEFONT)
-@d is_reencoded(fm) ((fm)->encoding != NULL)
-@d is_fontfile(fm) (fm_fontfile(fm) != NULL)
-@d is_t1fontfile(fm) (is_fontfile(fm) && !is_truetype(fm))
-
-@d fm_slant(fm) (fm)->slant
-@d fm_extend(fm) (fm)->extend
-@d fm_fontfile(fm) (fm)->ff_name
-
-@<Declarations@>=
-static boolean mp_font_is_reencoded (MP mp, int f);
-static boolean mp_font_is_included (MP mp, int f);
-static boolean mp_font_is_subsetted (MP mp, int f);
-
-@ @c
-static boolean mp_font_is_reencoded (MP mp, int f) {
- fm_entry *fm;
- if (mp_has_font_size(mp,f) && mp_has_fm_entry (mp, f, &fm)) {
- if (fm != NULL
- && (fm->ps_name != NULL)
- && is_reencoded (fm))
- return 1;
- }
- return 0;
-}
-static boolean mp_font_is_included (MP mp, int f) {
- fm_entry *fm;
- if (mp_has_font_size(mp,f) && mp_has_fm_entry (mp, f, &fm)) {
- if (fm != NULL
- && (fm->ps_name != NULL && fm->ff_name != NULL)
- && is_included (fm))
- return 1;
- }
- return 0;
-}
-static boolean mp_font_is_subsetted (MP mp, int f) {
- fm_entry *fm;
- if (mp_has_font_size(mp,f) && mp_has_fm_entry (mp, f,&fm)) {
- if (fm != NULL
- && (fm->ps_name != NULL && fm->ff_name != NULL)
- && is_included (fm) && is_subsetted (fm))
- return 1;
- }
- return 0;
-}
-
-@ @<Exported function headers@>=
-char * mp_fm_encoding_name (MP mp, int f);
-char * mp_fm_font_name (MP mp, int f);
-
-@ @<Declarations@>=
-static char * mp_fm_font_subset_name (MP mp, int f);
-
-@
-@c char * mp_fm_encoding_name (MP mp, int f) {
- enc_entry *e;
- fm_entry *fm;
- if (mp_has_fm_entry (mp, f, &fm)) {
- if (fm != NULL && (fm->ps_name != NULL)) {
- if (is_reencoded (fm)) {
- e = fm->encoding;
- if (e->enc_name!=NULL)
- return mp_xstrdup(mp,e->enc_name);
- } else {
- return NULL;
- }
- }
- }
- print_err ("fontmap encoding problems for font ");
- mp_print(mp,mp->font_name[f]);
- mp_error(mp);
- return NULL;
-}
-char * mp_fm_font_name (MP mp, int f) {
- fm_entry *fm;
- if (mp_has_fm_entry (mp, f,&fm)) {
- if (fm != NULL && (fm->ps_name != NULL)) {
- if (mp_font_is_included(mp, f) && !mp->font_ps_name_fixed[f]) {
- /* find the real fontname, and update |ps_name| and |subset_tag| if needed */
- if (t1_updatefm(mp,f,fm)) {
- mp->font_ps_name_fixed[f] = true;
- } else {
- print_err ("font loading problems for font ");
- mp_print(mp,mp->font_name[f]);
- mp_error(mp);
- }
- }
- return mp_xstrdup(mp,fm->ps_name);
- }
- }
- print_err ("fontmap name problems for font ");
- mp_print(mp,mp->font_name[f]);
- mp_error(mp);
- return NULL;
-}
-
-static char * mp_fm_font_subset_name (MP mp, int f) {
- fm_entry *fm;
- if (mp_has_fm_entry (mp, f, &fm)) {
- if (fm != NULL && (fm->ps_name != NULL)) {
- if (is_subsetted(fm)) {
- char *s = mp_xmalloc(mp,strlen(fm->ps_name)+8,1);
- snprintf(s,strlen(fm->ps_name)+8,"%s-%s",fm->subset_tag,fm->ps_name);
- return s;
- } else {
- return mp_xstrdup(mp,fm->ps_name);
- }
- }
- }
- print_err ("fontmap name problems for font ");
- mp_print(mp,mp->font_name[f]);
- mp_error(mp);
- return NULL;
-}
-
-@ @<Declarations@>=
-static integer mp_fm_font_slant (MP mp, int f);
-static integer mp_fm_font_extend (MP mp, int f);
-
-@
-@c static integer mp_fm_font_slant (MP mp, int f) {
- fm_entry *fm;
- if (mp_has_fm_entry (mp, f, &fm)) {
- if (fm != NULL && (fm->ps_name != NULL)) {
- return fm->slant;
- }
- }
- return 0;
-}
-static integer mp_fm_font_extend (MP mp, int f) {
- fm_entry *fm;
- if (mp_has_fm_entry (mp, f, &fm)) {
- if (fm != NULL && (fm->ps_name != NULL)) {
- return fm->extend;
- }
- }
- return 0;
-}
-
-@ @<Declarations@>=
-static boolean mp_do_ps_font (MP mp, font_number f);
-
-@ @c static boolean mp_do_ps_font (MP mp, font_number f) {
- fm_entry *fm_cur;
- (void)mp_has_fm_entry (mp, f, &fm_cur); /* for side effects */
- if (fm_cur == NULL)
- return 1;
- if (is_truetype(fm_cur) ||
- (fm_cur->ps_name == NULL && fm_cur->ff_name == NULL)) {
- return 0;
- }
- if (is_included(fm_cur)) {
- mp_ps_print_nl(mp,"%%BeginResource: font ");
- if (is_subsetted(fm_cur)) {
- mp_ps_print(mp, fm_cur->subset_tag);
- mp_ps_print_char(mp,'-');
- }
- mp_ps_print(mp, fm_cur->ps_name);
- mp_ps_print_ln(mp);
- writet1 (mp,f,fm_cur);
- mp_ps_print_nl(mp,"%%EndResource");
- mp_ps_print_ln(mp);
- }
- return 1;
-}
-
-@ Included subset fonts do not need and encoding vector, make
-sure we skip that case.
-
-@<Declarations@>=
-static void mp_list_used_resources (MP mp, int prologues, int procset);
-
-@ @c static void mp_list_used_resources (MP mp, int prologues, int procset) {
- font_number f; /* fonts used in a text node or as loop counters */
- int ff; /* a loop counter */
- font_number ldf; /* the last \.{DocumentFont} listed (otherwise |null_font|) */
- boolean firstitem;
- if ( procset>0 )
- mp_ps_print_nl(mp, "%%DocumentResources: procset mpost");
- else
- mp_ps_print_nl(mp, "%%DocumentResources: procset mpost-minimal");
- ldf=null_font;
- firstitem=true;
- for (f=null_font+1;f<=mp->last_fnum;f++) {
- if ( (mp_has_font_size(mp,f))&&(mp_font_is_reencoded(mp,f)) ) {
- for (ff=ldf;ff>=null_font;ff--) {
- if ( mp_has_font_size(mp,ff) )
- if ( mp_xstrcmp(mp->font_enc_name[f],mp->font_enc_name[ff])==0 )
- goto FOUND;
- }
- if ( mp_font_is_subsetted(mp,f) )
- goto FOUND;
- if ( mp->ps->ps_offset+1+strlen(mp->font_enc_name[f])>
- (unsigned)mp->max_print_line )
- mp_ps_print_nl(mp, "%%+ encoding");
- if ( firstitem ) {
- firstitem=false;
- mp_ps_print_nl(mp, "%%+ encoding");
- }
- mp_ps_print_char(mp, ' ');
- mp_ps_print(mp, mp->font_enc_name[f]);
- ldf=f;
- }
- FOUND:
- ;
- }
- ldf=null_font;
- firstitem=true;
- for (f=null_font+1;f<=mp->last_fnum;f++) {
- if ( mp_has_font_size(mp,f) ) {
- for (ff=ldf;ff>=null_font;ff--) {
- if ( mp_has_font_size(mp,ff) )
- if ( mp_xstrcmp(mp->font_name[f],mp->font_name[ff])==0 )
- goto FOUND2;
- }
- if ( mp->ps->ps_offset+1+strlen(mp->font_ps_name[f])>
- (unsigned)mp->max_print_line )
- mp_ps_print_nl(mp, "%%+ font");
- if ( firstitem ) {
- firstitem=false;
- mp_ps_print_nl(mp, "%%+ font");
- }
- mp_ps_print_char(mp, ' ');
- if ( (prologues==3)&&
- (mp_font_is_subsetted(mp,f)) )
- mp_ps_print(mp, mp_fm_font_subset_name(mp,f));
- else
- mp_ps_print(mp, mp->font_ps_name[f]);
- ldf=f;
- }
- FOUND2:
- ;
- }
- mp_ps_print_ln(mp);
-}
-
-@ @<Declarations@>=
-static void mp_list_supplied_resources (MP mp, int prologues, int procset);
-
-@ @c static void mp_list_supplied_resources (MP mp, int prologues, int procset) {
- font_number f; /* fonts used in a text node or as loop counters */
- int ff; /* a loop counter */
- font_number ldf; /* the last \.{DocumentFont} listed (otherwise |null_font|) */
- boolean firstitem;
- if ( procset>0 )
- mp_ps_print_nl(mp, "%%DocumentSuppliedResources: procset mpost");
- else
- mp_ps_print_nl(mp, "%%DocumentSuppliedResources: procset mpost-minimal");
- ldf=null_font;
- firstitem=true;
- for (f=null_font+1;f<=mp->last_fnum;f++) {
- if ( (mp_has_font_size(mp,f))&&(mp_font_is_reencoded(mp,f)) ) {
- for (ff=ldf;ff>= null_font;ff++) {
- if ( mp_has_font_size(mp,ff) )
- if ( mp_xstrcmp(mp->font_enc_name[f],mp->font_enc_name[ff])==0 )
- goto FOUND;
- }
- if ( (prologues==3)&&(mp_font_is_subsetted(mp,f)))
- goto FOUND;
- if ( mp->ps->ps_offset+1+strlen(mp->font_enc_name[f])>(unsigned)mp->max_print_line )
- mp_ps_print_nl(mp, "%%+ encoding");
- if ( firstitem ) {
- firstitem=false;
- mp_ps_print_nl(mp, "%%+ encoding");
- }
- mp_ps_print_char(mp, ' ');
- mp_ps_print(mp, mp->font_enc_name[f]);
- ldf=f;
- }
- FOUND:
- ;
- }
- ldf=null_font;
- firstitem=true;
- if (prologues==3) {
- for (f=null_font+1;f<=mp->last_fnum;f++) {
- if ( mp_has_font_size(mp,f) ) {
- for (ff=ldf;ff>= null_font;ff--) {
- if ( mp_has_font_size(mp,ff) )
- if ( mp_xstrcmp(mp->font_name[f],mp->font_name[ff])==0 )
- goto FOUND2;
- }
- if ( ! mp_font_is_included(mp,f) )
- goto FOUND2;
- if ( mp->ps->ps_offset+1+strlen(mp->font_ps_name[f])>(unsigned)mp->max_print_line )
- mp_ps_print_nl(mp, "%%+ font");
- if ( firstitem ) {
- firstitem=false;
- mp_ps_print_nl(mp, "%%+ font");
- }
- mp_ps_print_char(mp, ' ');
- if ( mp_font_is_subsetted(mp,f) )
- mp_ps_print(mp, mp_fm_font_subset_name(mp,f));
- else
- mp_ps_print(mp, mp->font_ps_name[f]);
- ldf=f;
- }
- FOUND2:
- ;
- }
- mp_ps_print_ln(mp);
- }
-}
-
-@ @<Declarations...@>=
-static void mp_list_needed_resources (MP mp, int prologues);
-
-@ @c static void mp_list_needed_resources (MP mp, int prologues) {
- font_number f; /* fonts used in a text node or as loop counters */
- int ff; /* a loop counter */
- font_number ldf; /* the last \.{DocumentFont} listed (otherwise |null_font|) */
- boolean firstitem;
- ldf=null_font;
- firstitem=true;
- for (f=null_font+1;f<=mp->last_fnum;f++ ) {
- if ( mp_has_font_size(mp,f)) {
- for (ff=ldf;ff>=null_font;ff--) {
- if ( mp_has_font_size(mp,ff) )
- if ( mp_xstrcmp(mp->font_name[f],mp->font_name[ff])==0 )
- goto FOUND;
- };
- if ((prologues==3)&&(mp_font_is_included(mp,f)) )
- goto FOUND;
- if ( mp->ps->ps_offset+1+strlen(mp->font_ps_name[f])>(unsigned)mp->max_print_line )
- mp_ps_print_nl(mp, "%%+ font");
- if ( firstitem ) {
- firstitem=false;
- mp_ps_print_nl(mp, "%%DocumentNeededResources: font");
- }
- mp_ps_print_char(mp, ' ');
- mp_ps_print(mp, mp->font_ps_name[f]);
- ldf=f;
- }
- FOUND:
- ;
- }
- if ( ! firstitem ) {
- mp_ps_print_ln(mp);
- ldf=null_font;
- firstitem=true;
- for (f=null_font+1;f<= mp->last_fnum;f++) {
- if ( mp_has_font_size(mp,f) ) {
- for (ff=ldf;ff>=null_font;ff-- ) {
- if ( mp_has_font_size(mp,ff) )
- if ( mp_xstrcmp(mp->font_name[f],mp->font_name[ff])==0 )
- goto FOUND2;
- }
- if ((prologues==3)&&(mp_font_is_included(mp,f)) )
- goto FOUND2;
- mp_ps_print(mp, "%%IncludeResource: font ");
- mp_ps_print(mp, mp->font_ps_name[f]);
- mp_ps_print_ln(mp);
- ldf=f;
- }
- FOUND2:
- ;
- }
- }
-}
-
-@ @<Declarations@>=
-static void mp_write_font_definition (MP mp, font_number f, int prologues);
-
-@
-
-@d applied_reencoding(A) ((mp_font_is_reencoded(mp,(A)))&&
- ((! mp_font_is_subsetted(mp,(A)))||(prologues==2)))
-
-@c static void mp_write_font_definition(MP mp, font_number f, int prologues) {
- if ( (applied_reencoding(f))||(mp_fm_font_slant(mp,f)!=0)||
- (mp_fm_font_extend(mp,f)!=0)||
- (mp_xstrcmp(mp->font_name[f],"psyrgo")==0)||
- (mp_xstrcmp(mp->font_name[f],"zpzdr-reversed")==0) ) {
- if ( (mp_font_is_subsetted(mp,f))&&
- (mp_font_is_included(mp,f))&&(prologues==3))
- mp_ps_name_out(mp, mp_fm_font_subset_name(mp,f),true);
- else
- mp_ps_name_out(mp, mp->font_ps_name[f],true);
- mp_ps_print(mp, " fcp");
- mp_ps_print_ln(mp);
- if ( applied_reencoding(f) ) {
- mp_ps_print(mp, "/Encoding ");
- mp_ps_print(mp, mp->font_enc_name[f]);
- mp_ps_print(mp, " def ");
- };
- if ( mp_fm_font_slant(mp,f)!=0 ) {
- mp_ps_print_int(mp, mp_fm_font_slant(mp,f));
- mp_ps_print(mp, " SlantFont ");
- };
- if ( mp_fm_font_extend(mp,f)!=0 ) {
- mp_ps_print_int(mp, mp_fm_font_extend(mp,f));
- mp_ps_print(mp, " ExtendFont ");
- };
- if ( mp_xstrcmp(mp->font_name[f],"psyrgo")==0 ) {
- mp_ps_print(mp, " 890 ScaleFont ");
- mp_ps_print(mp, " 277 SlantFont ");
- };
- if ( mp_xstrcmp(mp->font_name[f],"zpzdr-reversed")==0 ) {
- mp_ps_print(mp, " FontMatrix [-1 0 0 1 0 0] matrix concatmatrix /FontMatrix exch def ");
- mp_ps_print(mp, "/Metrics 2 dict dup begin ");
- mp_ps_print(mp, "/space[0 -278]def ");
- mp_ps_print(mp, "/a12[-904 -939]def ");
- mp_ps_print(mp, "end def ");
- };
- mp_ps_print(mp, "currentdict end");
- mp_ps_print_ln(mp);
- mp_ps_print_defined_name(mp,f,prologues);
- mp_ps_print(mp, " exch definefont pop");
- mp_ps_print_ln(mp);
- }
-}
-
-@ @<Declarations@>=
-static void mp_ps_print_defined_name (MP mp, font_number f, int prologues);
-
-@
-@c static void mp_ps_print_defined_name(MP mp, font_number A, int prologues) {
- mp_ps_print(mp, " /");
- if ((mp_font_is_subsetted(mp,(A)))&&
- (mp_font_is_included(mp,(A)))&&(prologues==3))
- mp_ps_print(mp, mp_fm_font_subset_name(mp,(A)));
- else
- mp_ps_print(mp, mp->font_ps_name[(A)]);
- if ( mp_xstrcmp(mp->font_name[(A)],"psyrgo")==0 )
- mp_ps_print(mp, "-Slanted");
- if ( mp_xstrcmp(mp->font_name[(A)],"zpzdr-reversed")==0 )
- mp_ps_print(mp, "-Reverse");
- if ( applied_reencoding((A)) ) {
- mp_ps_print(mp, "-");
- mp_ps_print(mp, mp->font_enc_name[(A)]);
- }
- if ( mp_fm_font_slant(mp,(A))!=0 ) {
- mp_ps_print(mp, "-Slant_"); mp_ps_print_int(mp, mp_fm_font_slant(mp,(A))) ;
- }
- if ( mp_fm_font_extend(mp,(A))!=0 ) {
- mp_ps_print(mp, "-Extend_"); mp_ps_print_int(mp, mp_fm_font_extend(mp,(A)));
- }
-}
-
-@ @<Include encodings and fonts for edge structure~|h|@>=
-mp_font_encodings(mp,mp->last_fnum,(prologues==2));
-@<Embed fonts that are available@>
-
-@ @<Embed fonts that are available@>=
-{
-next_size=0;
-@<Make |cur_fsize| a copy of the |font_sizes| array@>;
-do {
- done_fonts=true;
- for (f=null_font+1;f<=mp->last_fnum;f++) {
- if ( cur_fsize[f]!=null ) {
- if (prologues==3 ) {
- if ( ! mp_do_ps_font(mp,f) ) {
- if ( mp_has_fm_entry(mp,f, NULL) ) {
- print_err("Font embedding failed");
- mp_error(mp);
- }
- }
- }
- cur_fsize[f]=link(cur_fsize[f]);
- if ( cur_fsize[f]!=null ) { mp_unmark_font(mp, f); done_fonts=false; }
- }
- }
- if ( ! done_fonts )
- @<Increment |next_size| and apply |mark_string_chars| to all text nodes with
- that size index@>;
-} while (! done_fonts);
-}
-
-@ @<Increment |next_size| and apply |mark_string_chars| to all text nodes...@>=
-{
- next_size++;
- mp_apply_mark_string_chars(mp, h, next_size);
-}
-
-@ We also need to keep track of which characters are used in text nodes
-in the edge structure that is being shipped out. This is done by procedures
-that use the left-over |b3| field in the |char_info| words; i.e.,
-|char_info(f)(c).b3| gives the status of character |c| in font |f|.
-
-@<Types...@>=
-enum mp_char_mark_state {mp_unused=0, mp_used};
-
-@ @<Exported...@>=
-void mp_mark_string_chars (MP mp,font_number f, char *s) ;
-
-@ @c
-void mp_mark_string_chars (MP mp,font_number f, char *s) {
- integer b; /* |char_base[f]| */
- ASCII_code bc,ec; /* only characters between these bounds are marked */
- char *k; /* an index into string |s| */
- b=mp->char_base[f];
- bc=mp->font_bc[f];
- ec=mp->font_ec[f];
- k=s; /* str_stop */
- while (*k){
- if ( (*k>=bc)&&(*k<=ec) )
- mp->font_info[b+*k].qqqq.b3=mp_used;
- k++;
- }
-}
-
-
-@ @<Exported ...@>=
-void mp_unmark_font (MP mp,font_number f) ;
-
-@ @c
-void mp_unmark_font (MP mp,font_number f) {
- int k; /* an index into |font_info| */
- for (k= mp->char_base[f]+mp->font_bc[f];
- k<=mp->char_base[f]+mp->font_ec[f];
- k++)
- mp->font_info[k].qqqq.b3=mp_unused;
-}
-
-
-@ @<Exported...@>=
-void mp_print_improved_prologue (MP mp, mp_edge_object *h, int prologues, int procset) ;
-
-@ @c
-void mp_print_improved_prologue (MP mp, mp_edge_object *h, int prologues, int procset) {
- quarterword next_size; /* the size index for fonts being listed */
- pointer *cur_fsize; /* current positions in |font_sizes| */
- boolean done_fonts; /* have we finished listing the fonts in the header? */
- font_number f; /* a font number for loops */
- cur_fsize = mp_xmalloc(mp,(mp->font_max+1),sizeof(pointer));
- mp_list_used_resources(mp, prologues, procset);
- mp_list_supplied_resources(mp, prologues, procset);
- mp_list_needed_resources(mp, prologues);
- mp_ps_print_nl(mp, "%%EndComments");
- mp_ps_print_nl(mp, "%%BeginProlog");
- if ( procset>0 )
- mp_ps_print_nl(mp, "%%BeginResource: procset mpost");
- else
- mp_ps_print_nl(mp, "%%BeginResource: procset mpost-minimal");
- mp_ps_print_nl(mp, "/bd{bind def}bind def"
- "/fshow {exch findfont exch scalefont setfont show}bd");
- if ( procset>0 ) @<Print the procset@>;
- mp_ps_print_nl(mp, "/fcp{findfont dup length dict begin"
- "{1 index/FID ne{def}{pop pop}ifelse}forall}bd");
- mp_ps_print_nl(mp, "/fmc{FontMatrix dup length array copy dup dup}bd"
- "/fmd{/FontMatrix exch def}bd");
- mp_ps_print_nl(mp, "/Amul{4 -1 roll exch mul 1000 div}bd"
- "/ExtendFont{fmc 0 get Amul 0 exch put fmd}bd");
- mp_ps_print_nl(mp, "/ScaleFont{dup fmc 0 get"
- " Amul 0 exch put dup dup 3 get Amul 3 exch put fmd}bd");
- mp_ps_print_nl(mp, "/SlantFont{fmc 2 get dup 0 eq{pop 1}if"
- " Amul FontMatrix 0 get mul 2 exch put fmd}bd");
- mp_ps_print_nl(mp, "%%EndResource");
- @<Include encodings and fonts for edge structure~|h|@>;
- mp_ps_print_nl(mp, "%%EndProlog");
- mp_ps_print_nl(mp, "%%BeginSetup");
- mp_ps_print_ln(mp);
- for (f=null_font+1;f<=mp->last_fnum;f++) {
- if ( mp_has_font_size(mp,f) ) {
- if ( mp_has_fm_entry(mp,f,NULL) ) {
- mp_write_font_definition(mp,f, prologues);
- mp_ps_name_out(mp, mp->font_name[f],true);
- mp_ps_print_defined_name(mp,f, prologues);
- mp_ps_print(mp, " def");
- } else {
- char s[256];
- snprintf(s,256,"font %s cannot be found in any fontmapfile!", mp->font_name[f]);
- mp_warn(mp,s);
- mp_ps_name_out(mp, mp->font_name[f],true);
- mp_ps_name_out(mp, mp->font_name[f],true);
- mp_ps_print(mp, " def");
- }
- mp_ps_print_ln(mp);
- }
- }
- mp_ps_print_nl(mp, "%%EndSetup");
- mp_ps_print_nl(mp, "%%Page: 1 1");
- mp_ps_print_ln(mp);
- mp_xfree(cur_fsize);
-}
-
-@ @<Declarations@>=
-static font_number mp_print_font_comments (MP mp , mp_edge_object *h, int prologues);
-
-
-@
-@c
-static font_number mp_print_font_comments (MP mp , mp_edge_object *h, int prologues) {
- quarterword next_size; /* the size index for fonts being listed */
- pointer *cur_fsize; /* current positions in |font_sizes| */
- int ff; /* a loop counter */
- boolean done_fonts; /* have we finished listing the fonts in the header? */
- font_number f; /* a font number for loops */
- scaled ds; /* design size and scale factor for a text node */
- font_number ldf=0; /* the last \.{DocumentFont} listed (otherwise |null_font|) */
- cur_fsize = mp_xmalloc(mp,(mp->font_max+1),sizeof(pointer));
- if ( prologues>0 ) {
- @<Give a \.{DocumentFonts} comment listing all fonts with non-null
- |font_sizes| and eliminate duplicates@>;
- } else {
- next_size=0;
- @<Make |cur_fsize| a copy of the |font_sizes| array@>;
- do { done_fonts=true;
- for (f=null_font+1;f<=mp->last_fnum;f++) {
- if ( cur_fsize[f]!=null ) {
- @<Print the \.{\%*Font} comment for font |f| and advance |cur_fsize[f]|@>;
- }
- if ( cur_fsize[f]!=null ) { mp_unmark_font(mp, f); done_fonts=false; };
- }
- if ( ! done_fonts ) {
- @<Increment |next_size| and apply |mark_string_chars| to all text nodes with
- that size index@>;
- }
- } while (! done_fonts);
- }
- mp_xfree(cur_fsize);
- return ldf;
-}
-
-@ @<Make |cur_fsize| a copy of the |font_sizes| array@>=
-for (f=null_font+1;f<= mp->last_fnum;f++)
- cur_fsize[f]=mp->font_sizes[f]
-
-@ It's not a good idea to make any assumptions about the |font_ps_name| entries,
-so we carefully remove duplicates. There is no harm in using a slow, brute-force
-search.
-
-@<Give a \.{DocumentFonts} comment listing all fonts with non-null...@>=
-{
- ldf=null_font;
- for (f=null_font+1;f<= mp->last_fnum;f++) {
- if ( mp->font_sizes[f]!=null ) {
- if ( ldf==null_font )
- mp_ps_print_nl(mp, "%%DocumentFonts:");
- for (ff=ldf;ff>=null_font;ff--) {
- if ( mp->font_sizes[ff]!=null )
- if ( mp_xstrcmp(mp->font_ps_name[f],mp->font_ps_name[ff])==0 )
- goto FOUND;
- }
- if ( mp->ps->ps_offset+1+strlen(mp->font_ps_name[f])>(unsigned)mp->max_print_line )
- mp_ps_print_nl(mp, "%%+");
- mp_ps_print_char(mp, ' ');
- mp_ps_print(mp, mp->font_ps_name[f]);
- ldf=f;
- FOUND:
- ;
- }
- }
-}
-
-@ @c
-static void mp_hex_digit_out (MP mp,small_number d) {
- if ( d<10 ) mp_ps_print_char(mp, d+'0');
- else mp_ps_print_char(mp, d+'a'-10);
-}
-
-@ We output the marks as a hexadecimal bit string starting at |c| or
-|font_bc[f]|, whichever is greater. If the output has to be truncated
-to avoid exceeding |emergency_line_length| the return value says where to
-start scanning next time.
-
-@<Declarations@>=
-static halfword mp_ps_marks_out (MP mp,font_number f, eight_bits c);
-
-@
-@d emergency_line_length 255
- /* \ps\ output lines can be this long in unusual circumstances */
-
-@c
-static halfword mp_ps_marks_out (MP mp,font_number f, eight_bits c) {
- eight_bits bc,ec; /* only encode characters between these bounds */
- integer lim; /* the maximum number of marks to encode before truncating */
- int p; /* |font_info| index for the current character */
- int d,b; /* used to construct a hexadecimal digit */
- lim=4*(emergency_line_length-mp->ps->ps_offset-4);
- bc=mp->font_bc[f];
- ec=mp->font_ec[f];
- if ( c>bc ) bc=c;
- @<Restrict the range |bc..ec| so that it contains no unused characters
- at either end and has length at most |lim|@>;
- @<Print the initial label indicating that the bitmap starts at |bc|@>;
- @<Print a hexadecimal encoding of the marks for characters |bc..ec|@>;
- while ( (ec<mp->font_ec[f])&&(mp->font_info[p].qqqq.b3==mp_unused) ) {
- p++; ec++;
- }
- return (ec+1);
-}
-
-@ We could save time by setting the return value before the loop that
-decrements |ec|, but there is no point in being so tricky.
-
-@<Restrict the range |bc..ec| so that it contains no unused characters...@>=
-p=mp->char_base[f]+bc;
-while ( (mp->font_info[p].qqqq.b3==mp_unused)&&(bc<ec) ) {
- p++; bc++;
-}
-if ( ec>=bc+lim ) ec=bc+lim-1;
-p=mp->char_base[f]+ec;
-while ( (mp->font_info[p].qqqq.b3==mp_unused)&&(bc<ec) ) {
- p--; ec--;
-}
-
-@ @<Print the initial label indicating that the bitmap starts at |bc|@>=
-mp_ps_print_char(mp, ' ');
-mp_hex_digit_out(mp, bc / 16);
-mp_hex_digit_out(mp, bc % 16);
-mp_ps_print_char(mp, ':')
-
-@
-
-@<Print a hexadecimal encoding of the marks for characters |bc..ec|@>=
-b=8; d=0;
-for (p=mp->char_base[f]+bc;p<=mp->char_base[f]+ec;p++) {
- if ( b==0 ) {
- mp_hex_digit_out(mp, d);
- d=0; b=8;
- }
- if ( mp->font_info[p].qqqq.b3!=mp_unused ) d=d+b;
- b=b>>1;
-}
-mp_hex_digit_out(mp, d)
-
-
-@ Here is a simple function that determines whether there are any marked
-characters in font~|f| with character code at least~|c|.
-
-@<Declarations@>=
-static boolean mp_check_ps_marks (MP mp,font_number f, integer c) ;
-
-@ @c
-static boolean mp_check_ps_marks (MP mp,font_number f, integer c) {
- int p; /* |font_info| index for the current character */
- for (p=mp->char_base[f]+c;p<=mp->char_base[f]+mp->font_ec[f];p++) {
- if ( mp->font_info[p].qqqq.b3==mp_used )
- return true;
- }
- return false;
-}
-
-
-@ If the file name is so long that it can't be printed without exceeding
-|emergency_line_length| then there will be missing items in the \.{\%*Font:}
-line. We might have to repeat line in order to get the character usage
-information to fit within |emergency_line_length|.
-
-TODO: these two defines are also defined in mp.w!
-
-@d link(A) mp->mem[(A)].hh.rh /* the |link| field of a memory word */
-@d sc_factor(A) mp->mem[(A)+1].cint /* the scale factor stored in a font size node */
-
-@<Print the \.{\%*Font} comment for font |f| and advance |cur_fsize[f]|@>=
-{ integer t=0;
- while ( mp_check_ps_marks(mp, f,t) ) {
- mp_ps_print_nl(mp, "%*Font: ");
- if ( mp->ps->ps_offset+strlen(mp->font_name[f])+12>emergency_line_length )
- break;
- mp_ps_print(mp, mp->font_name[f]);
- mp_ps_print_char(mp, ' ');
- ds=(mp->font_dsize[f] + 8) / 16;
- mp_ps_print_scaled(mp, mp_take_scaled(mp, ds,sc_factor(cur_fsize[f])));
- if ( mp->ps->ps_offset+12>emergency_line_length ) break;
- mp_ps_print_char(mp, ' ');
- mp_ps_print_scaled(mp, ds);
- if ( mp->ps->ps_offset+5>emergency_line_length ) break;
- t=mp_ps_marks_out(mp, f,t);
- }
- cur_fsize[f]=link(cur_fsize[f]);
-}
-
-@ @<Print the procset@>=
-{
- mp_ps_print_nl(mp, "/hlw{0 dtransform exch truncate exch idtransform pop setlinewidth}bd");
- mp_ps_print_nl(mp, "/vlw{0 exch dtransform truncate idtransform setlinewidth pop}bd");
- mp_ps_print_nl(mp, "/l{lineto}bd/r{rlineto}bd/c{curveto}bd/m{moveto}bd"
- "/p{closepath}bd/n{newpath}bd");
- mp_ps_print_nl(mp, "/C{setcmykcolor}bd/G{setgray}bd/R{setrgbcolor}bd"
- "/lj{setlinejoin}bd/ml{setmiterlimit}bd");
- mp_ps_print_nl(mp, "/lc{setlinecap}bd/S{stroke}bd/F{fill}bd/q{gsave}bd"
- "/Q{grestore}bd/s{scale}bd/t{concat}bd");
- mp_ps_print_nl(mp, "/sd{setdash}bd/rd{[] 0 setdash}bd/P{showpage}bd/B{q F Q}bd/W{clip}bd");
-}
-
-
-@ The prologue defines \.{fshow} and corrects for the fact that \.{fshow}
-arguments use |font_name| instead of |font_ps_name|. Downloaded bitmap fonts
-might not have reasonable |font_ps_name| entries, but we just charge ahead
-anyway. The user should not make \&{prologues} positive if this will cause
-trouble.
-@:prologues_}{\&{prologues} primitive@>
-
-@<Exported...@>=
-void mp_print_prologue (MP mp, mp_edge_object *h, int prologues, int procset);
-
-@ @c
-void mp_print_prologue (MP mp, mp_edge_object *h, int prologues, int procset) {
- font_number f;
- font_number ldf ;
- ldf = mp_print_font_comments (mp, h, prologues);
- mp_ps_print_ln(mp);
- if ( (prologues==1) && (mp->last_ps_fnum<mp->last_fnum) )
- mp_read_psname_table(mp);
- mp_ps_print(mp, "%%BeginProlog"); mp_ps_print_ln(mp);
- if ( (prologues>0)||(procset>0) ) {
- if ( ldf!=null_font ) {
- if ( prologues>0 ) {
- for (f=null_font+1;f<=mp->last_fnum;f++) {
- if ( mp_has_font_size(mp,f) ) {
- mp_ps_name_out(mp, mp->font_name[f],true);
- mp_ps_name_out(mp, mp->font_ps_name[f],true);
- mp_ps_print(mp, " def");
- mp_ps_print_ln(mp);
- }
- }
- if ( procset==0 ) {
- mp_ps_print(mp, "/fshow {exch findfont exch scalefont setfont show}bind def");
- mp_ps_print_ln(mp);
- }
- }
- }
- if (procset>0 ) {
- mp_ps_print_nl(mp, "%%BeginResource: procset mpost");
- if ( (prologues>0)&&(ldf!=null_font) )
- mp_ps_print_nl(mp,
- "/bd{bind def}bind def/fshow {exch findfont exch scalefont setfont show}bd");
- else
- mp_ps_print_nl(mp, "/bd{bind def}bind def");
- @<Print the procset@>;
- mp_ps_print_nl(mp, "%%EndResource");
- mp_ps_print_ln(mp);
- }
- }
- mp_ps_print(mp, "%%EndProlog");
- mp_ps_print_nl(mp, "%%Page: 1 1"); mp_ps_print_ln(mp);
-}
-
-@ \MP\ used to have one single routine to print to both `write' files
-and the PostScript output. Web2c redefines ``Character |k| cannot be
-printed'', and that resulted in some bugs where 8-bit characters were
-written to the PostScript file (reported by Wlodek Bzyl).
-
-Also, Hans Hagen requested spaces to be output as "\\040" instead of
-a plain space, since that makes it easier to parse the result file
-for postprocessing.
-
-@<Character |k| is not allowed in PostScript output@>=
- (k<=' ')||(k>'~')
-
-@ We often need to print a pair of coordinates.
-
-@c
-void mp_ps_pair_out (MP mp,scaled x, scaled y) {
- ps_room(26);
- mp_ps_print_scaled(mp, x); mp_ps_print_char(mp, ' ');
- mp_ps_print_scaled(mp, y); mp_ps_print_char(mp, ' ');
-}
-
-@ @<Exported...@>=
-void mp_ps_pair_out (MP mp,scaled x, scaled y) ;
-
-@ @c
-void mp_ps_print_cmd (MP mp, const char *l, const char *s) {
- if ( mp->internal[mp_procset]>0 ) { ps_room(strlen(s)); mp_ps_print(mp,s); }
- else { ps_room(strlen(l)); mp_ps_print(mp, l); };
-}
-
-@ @<Exported...@>=
-void mp_ps_print_cmd (MP mp, const char *l, const char *s) ;
-
-@ @c
-void mp_ps_string_out (MP mp, const char *s) {
- ASCII_code k; /* bits to be converted to octal */
- mp_ps_print(mp, "(");
- while ((k=*s++)) {
- if ( mp->ps->ps_offset+5>mp->max_print_line ) {
- mp_ps_print_char(mp, '\\');
- mp_ps_print_ln(mp);
- }
- if ( (@<Character |k| is not allowed in PostScript output@>) ) {
- mp_ps_print_char(mp, '\\');
- mp_ps_print_char(mp, '0'+(k / 64));
- mp_ps_print_char(mp, '0'+((k / 8) % 8));
- mp_ps_print_char(mp, '0'+(k % 8));
- } else {
- if ( (k=='(')||(k==')')||(k=='\\') )
- mp_ps_print_char(mp, '\\');
- mp_ps_print_char(mp, k);
- }
- }
- mp_ps_print_char(mp, ')');
-}
-
-@ @<Exported...@>=
-void mp_ps_string_out (MP mp, const char *s) ;
-
-@ This is a define because the function does not use its |mp| argument.
-
-@d mp_is_ps_name(M,A) mp_do_is_ps_name(A)
-
-@c
-static boolean mp_do_is_ps_name (char *s) {
- ASCII_code k; /* the character being checked */
- while ((k=*s++)) {
- if ( (k<=' ')||(k>'~') ) return false;
- if ( (k=='(')||(k==')')||(k=='<')||(k=='>')||
- (k=='{')||(k=='}')||(k=='/')||(k=='%') ) return false;
- }
- return true;
-}
-
-@ @<Exported...@>=
-void mp_ps_name_out (MP mp, char *s, boolean lit) ;
-
-@ @c
-void mp_ps_name_out (MP mp, char *s, boolean lit) {
- ps_room(strlen(s)+2);
- mp_ps_print_char(mp, ' ');
- if ( mp_is_ps_name(mp, s) ) {
- if ( lit ) mp_ps_print_char(mp, '/');
- mp_ps_print(mp, s);
- } else {
- mp_ps_string_out(mp, s);
- if ( ! lit ) mp_ps_print(mp, "cvx ");
- mp_ps_print(mp, "cvn");
- }
-}
-
-
-@ These special comments described in the {\sl PostScript Language Reference
-Manual}, 2nd.~edition are understood by some \ps-reading programs.
-We can't normally output ``conforming'' \ps\ because
-the structuring conventions don't allow us to say ``Please make sure the
-following characters are downloaded and define the \.{fshow} macro to access
-them.''
-
-The exact bounding box is written out if |mp_prologues<0|, although this
-is not standard \ps, since it allows \TeX\ to calculate the box dimensions
-accurately. (Overfull boxes are avoided if an illustration is made to
-match a given \.{\char`\\hsize}.)
-
-@<Exported...@>=
-void mp_print_initial_comment(MP mp,mp_edge_object *hh, int prologues);
-
-@ @c
-void mp_print_initial_comment(MP mp,mp_edge_object *hh, int prologues) {
- scaled t;
- mp_ps_print(mp, "%!PS");
- if ( prologues>0 )
- mp_ps_print(mp, "-Adobe-3.0 EPSF-3.0");
- mp_ps_print_nl(mp, "%%BoundingBox: ");
- if ( hh->_minx>hh->_maxx) {
- mp_ps_print(mp, "0 0 0 0");
- } else if ( prologues<0 ) {
- mp_ps_pair_out(mp, hh->_minx,hh->_miny);
- mp_ps_pair_out(mp, hh->_maxx,hh->_maxy);
- } else {
- mp_ps_pair_out(mp, mp_floor_scaled(mp, hh->_minx),mp_floor_scaled(mp, hh->_miny));
- mp_ps_pair_out(mp, -mp_floor_scaled(mp, -hh->_maxx),-mp_floor_scaled(mp, -hh->_maxy));
- }
- mp_ps_print_nl(mp, "%%HiResBoundingBox: ");
- if ( hh->_minx>hh->_maxx ) {
- mp_ps_print(mp, "0 0 0 0");
- } else {
- mp_ps_pair_out(mp, hh->_minx,hh->_miny);
- mp_ps_pair_out(mp, hh->_maxx,hh->_maxy);
- }
- mp_ps_print_nl(mp, "%%Creator: MetaPost ");
- mp_ps_print(mp, mp_metapost_version(mp));
- mp_ps_print_nl(mp, "%%CreationDate: ");
- mp_ps_print_int(mp, mp_round_unscaled(mp, mp->internal[mp_year]));
- mp_ps_print_char(mp, '.');
- mp_ps_print_dd(mp, mp_round_unscaled(mp, mp->internal[mp_month]));
- mp_ps_print_char(mp, '.');
- mp_ps_print_dd(mp, mp_round_unscaled(mp, mp->internal[mp_day]));
- mp_ps_print_char(mp, ':');
- t=mp_round_unscaled(mp, mp->internal[mp_time]);
- mp_ps_print_dd(mp, t / 60);
- mp_ps_print_dd(mp, t % 60);
- mp_ps_print_nl(mp, "%%Pages: 1");
-}
-
-@ The most important output procedure is the one that gives the \ps\ version of
-a \MP\ path.
-
-@<Types...@>=
-#define gr_left_type(A) (A)->left_type_field
-#define gr_right_type(A) (A)->right_type_field
-#define gr_x_coord(A) (A)->x_coord_field
-#define gr_y_coord(A) (A)->y_coord_field
-#define gr_left_x(A) (A)->left_x_field
-#define gr_left_y(A) (A)->left_y_field
-#define gr_right_x(A) (A)->right_x_field
-#define gr_right_y(A) (A)->right_y_field
-#define gr_next_knot(A) (A)->next_field
-#define gr_originator(A) (A)->originator_field
-typedef struct mp_knot {
- unsigned short left_type_field;
- unsigned short right_type_field;
- scaled x_coord_field;
- scaled y_coord_field;
- scaled left_x_field;
- scaled left_y_field;
- scaled right_x_field;
- scaled right_y_field;
- struct mp_knot * next_field;
- quarterword originator_field;
-} mp_knot;
-
-@ @c
-mp_knot * mp_gr_insert_knot (MP mp, mp_knot *q, scaled x, scaled y) {
- /* returns the inserted knot */
- mp_knot *r; /* the new knot */
- r= mp_xmalloc(mp, 1, sizeof (mp_knot));
- gr_next_knot(r)=gr_next_knot(q); gr_next_knot(q)=r;
- gr_right_x(r)=gr_right_x(q);
- gr_right_y(r)=gr_right_y(q);
- gr_x_coord(r)=x;
- gr_y_coord(r)=y;
- gr_right_x(q)=gr_x_coord(q);
- gr_right_y(q)=gr_y_coord(q);
- gr_left_x(r)=gr_x_coord(r);
- gr_left_y(r)=gr_y_coord(r);
- gr_left_type(r)=mp_explicit;
- gr_right_type(r)=mp_explicit;
- gr_originator(r)=mp_program_code;
- return r;
-}
-
-
-@ If we want to duplicate a knot node, we can say |copy_knot|:
-
-@c
-mp_knot *mp_gr_copy_knot (MP mp, mp_knot *p) {
- mp_knot *q; /* the copy */
- q = mp_xmalloc(mp, 1, sizeof (mp_knot));
- memcpy(q,p,sizeof (mp_knot));
- gr_next_knot(q)=NULL;
- return q;
-}
-
-@ The |copy_path| routine makes a clone of a given path.
-
-@c
-mp_knot *mp_gr_copy_path (MP mp, mp_knot *p) {
- mp_knot *q, *pp, *qq; /* for list manipulation */
- if (p==NULL)
- return NULL;
- q=mp_gr_copy_knot(mp, p);
- qq=q;
- pp=gr_next_knot(p);
- while ( pp!=p ) {
- gr_next_knot(qq)=mp_gr_copy_knot(mp, pp);
- qq=gr_next_knot(qq);
- pp=gr_next_knot(pp);
- }
- gr_next_knot(qq)=q;
- return q;
-}
-
-@ Similarly, there's a way to copy the {\sl reverse\/} of a path. This procedure
-returns a pointer to the first node of the copy, if the path is a cycle,
-but to the final node of a non-cyclic copy. The global
-variable |path_tail| will point to the final node of the original path;
-this trick makes it easier to implement `\&{doublepath}'.
-
-All node types are assumed to be |endpoint| or |explicit| only.
-
-This function is currenly unused.
-
-@c
-mp_knot * mp_gr_htap_ypoc (MP mp, mp_knot *p) {
- mp_knot *q, *pp, *qq, *rr; /* for list manipulation */
- q=mp_xmalloc(mp, 1, sizeof (mp_knot)); /* this will correspond to |p| */
- qq=q; pp=p;
- while (1) {
- gr_right_type(qq)=gr_left_type(pp);
- gr_left_type(qq)=gr_right_type(pp);
- gr_x_coord(qq)=gr_x_coord(pp);
- gr_y_coord(qq)=gr_y_coord(pp);
- gr_right_x(qq)=gr_left_x(pp);
- gr_right_y(qq)=gr_left_y(pp);
- gr_left_x(qq)=gr_right_x(pp);
- gr_left_y(qq)=gr_right_y(pp);
- gr_originator(qq)=gr_originator(pp);
- if ( gr_next_knot(pp)==p ) {
- gr_next_knot(q)=qq;
- /* mp->path_tail=pp; */ /* ? */
- return q;
- }
- rr=mp_xmalloc(mp, 1, sizeof (mp_knot));
- gr_next_knot(rr)=qq;
- qq=rr;
- pp=gr_next_knot(pp);
- }
-}
-
-@ When a cyclic list of knot nodes is no longer needed, it can be recycled by
-calling the following subroutine.
-
-@<Declarations@>=
-void mp_do_gr_toss_knot_list (mp_knot *p) ;
-
-@
-@d mp_gr_toss_knot_list(B,A) mp_do_gr_toss_knot_list(A)
-
-@c
-void mp_do_gr_toss_knot_list (mp_knot * p) {
- mp_knot *q; /* the node being freed */
- mp_knot *r; /* the next node */
- if (p==NULL)
- return;
- q=p;
- do {
- r=gr_next_knot(q);
- mp_xfree(q); q=r;
- } while (q!=p);
-}
-
-
-
-@ @c
-void mp_gr_ps_path_out (MP mp, mp_knot *h) {
- mp_knot *p, *q; /* for scanning the path */
- scaled d; /* a temporary value */
- boolean curved; /* |true| unless the cubic is almost straight */
- ps_room(40);
- mp_ps_print_cmd(mp, "newpath ","n ");
- mp_ps_pair_out(mp, gr_x_coord(h),gr_y_coord(h));
- mp_ps_print_cmd(mp, "moveto","m");
- p=h;
- do {
- if ( gr_right_type(p)==mp_endpoint ) {
- if ( p==h ) mp_ps_print_cmd(mp, " 0 0 rlineto"," 0 0 r");
- return;
- }
- q=gr_next_knot(p);
- @<Start a new line and print the \ps\ commands for the curve from
- |p| to~|q|@>;
- p=q;
- } while (p!=h);
- mp_ps_print_cmd(mp, " closepath"," p");
-}
-
-@ @<Start a new line and print the \ps\ commands for the curve from...@>=
-curved=true;
-@<Set |curved:=false| if the cubic from |p| to |q| is almost straight@>;
-mp_ps_print_ln(mp);
-if ( curved ){
- mp_ps_pair_out(mp, gr_right_x(p),gr_right_y(p));
- mp_ps_pair_out(mp, gr_left_x(q),gr_left_y(q));
- mp_ps_pair_out(mp, gr_x_coord(q),gr_y_coord(q));
- mp_ps_print_cmd(mp, "curveto","c");
-} else if ( q!=h ){
- mp_ps_pair_out(mp, gr_x_coord(q),gr_y_coord(q));
- mp_ps_print_cmd(mp, "lineto","l");
-}
-
-@ Two types of straight lines come up often in \MP\ paths:
-cubics with zero initial and final velocity as created by |make_path| or
-|make_envelope|, and cubics with control points uniformly spaced on a line
-as created by |make_choices|.
-
-@d bend_tolerance 131 /* allow rounding error of $2\cdot10^{-3}$ */
-
-@<Set |curved:=false| if the cubic from |p| to |q| is almost straight@>=
-if ( gr_right_x(p)==gr_x_coord(p) )
- if ( gr_right_y(p)==gr_y_coord(p) )
- if ( gr_left_x(q)==gr_x_coord(q) )
- if ( gr_left_y(q)==gr_y_coord(q) ) curved=false;
-d=gr_left_x(q)-gr_right_x(p);
-if ( abs(gr_right_x(p)-gr_x_coord(p)-d)<=bend_tolerance )
- if ( abs(gr_x_coord(q)-gr_left_x(q)-d)<=bend_tolerance )
- { d=gr_left_y(q)-gr_right_y(p);
- if ( abs(gr_right_y(p)-gr_y_coord(p)-d)<=bend_tolerance )
- if ( abs(gr_y_coord(q)-gr_left_y(q)-d)<=bend_tolerance ) curved=false;
- }
-
-@ The colored objects use a struct with anonymous fields to express the color parts:
-
-@<Types...@>=
-typedef struct {
- scaled _a_val, _b_val, _c_val, _d_val;
-} mp_color;
-
-@ The exported form of a dash pattern is simpler than the internal
-format, it is closely modelled to the PostScript model. The array of
-dashes is ended by a single negative value, because this is not
-allowed in PostScript.
-
-@<Types...@>=
-typedef struct {
- scaled offset_field;
- scaled *array_field;
-} mp_dash_object ;
-
-
-@
-@d mp_gr_toss_dashes(A,B) mp_do_gr_toss_dashes(B)
-
-@<Declarations@>=
-void mp_do_gr_toss_dashes(mp_dash_object *dl);
-
-@ @c
-void mp_do_gr_toss_dashes(mp_dash_object *dl) {
- if (dl==NULL)
- return;
- mp_xfree(dl->array_field);
- mp_xfree(dl);
-}
-
-
-@ @c
-mp_dash_object *mp_gr_copy_dashes(MP mp, mp_dash_object *dl) {
- mp_dash_object *q = NULL;
- (void)mp;
- if (dl==NULL)
- return NULL;
- q = mp_xmalloc(mp, 1, sizeof (mp_dash_object));
- memcpy (q,dl,sizeof(mp_dash_object));
- if (dl->array_field != NULL) {
- int i = 0;
- while (*(dl->array_field+i) != -1) i++;
- q->array_field = mp_xmalloc(mp, i, sizeof (scaled));
- memcpy(q->array_field,dl->array_field, (i*sizeof(scaled)));
- }
- return q;
-}
-
-
-@ Now for outputting the actual graphic objects. First, set up some
-structures and access macros.
-
-@d gr_has_color(A) (gr_type((A))<mp_start_clip_code)
-
-@<Types...@>=
-#define gr_type(A) (A)->_type_field
-#define gr_link(A) (A)->_link_field
-#define gr_color_model(A) (A)->color_model_field
-#define gr_red_val(A) (A)->color_field._a_val
-#define gr_green_val(A) (A)->color_field._b_val
-#define gr_blue_val(A) (A)->color_field._c_val
-#define gr_cyan_val(A) (A)->color_field._a_val
-#define gr_magenta_val(A) (A)->color_field._b_val
-#define gr_yellow_val(A) (A)->color_field._c_val
-#define gr_black_val(A) (A)->color_field._d_val
-#define gr_grey_val(A) (A)->color_field._a_val
-#define gr_path_p(A) (A)->path_p_field
-#define gr_htap_p(A) ((mp_fill_object *)A)->htap_p_field
-#define gr_pen_p(A) (A)->pen_p_field
-#define gr_ljoin_val(A) (A)->ljoin_field
-#define gr_lcap_val(A) ((mp_stroked_object *)A)->lcap_field
-#define gr_miterlim_val(A) (A)->miterlim_field
-#define gr_pre_script(A) (A)->pre_script_field
-#define gr_post_script(A) (A)->post_script_field
-#define gr_dash_p(A) ((mp_stroked_object *)A)->dash_p_field
-#define gr_name_type(A) ((mp_text_object *)A)->name_type_field
-#define gr_text_p(A) ((mp_text_object *)A)->text_p_field
-#define gr_font_n(A) ((mp_text_object *)A)->font_n_field
-#define gr_font_name(A) ((mp_text_object *)A)->font_name_field
-#define gr_font_dsize(A) ((mp_text_object *)A)->font_dsize_field
-#define gr_width_val(A) ((mp_text_object *)A)->width_field
-#define gr_height_val(A) ((mp_text_object *)A)->height_field
-#define gr_depth_val(A) ((mp_text_object *)A)->depth_field
-#define gr_tx_val(A) ((mp_text_object *)A)->tx_field
-#define gr_ty_val(A) ((mp_text_object *)A)->ty_field
-#define gr_txx_val(A) ((mp_text_object *)A)->txx_field
-#define gr_txy_val(A) ((mp_text_object *)A)->txy_field
-#define gr_tyx_val(A) ((mp_text_object *)A)->tyx_field
-#define gr_tyy_val(A) ((mp_text_object *)A)->tyy_field
-
-#define GRAPHIC_BODY \
- halfword _type_field; \
- struct mp_graphic_object * _link_field
-
-typedef struct mp_graphic_object {
- GRAPHIC_BODY;
-} mp_graphic_object;
-
-typedef struct mp_text_object {
- GRAPHIC_BODY;
- char *pre_script_field;
- char *post_script_field;
- mp_color color_field;
- quarterword color_model_field;
- quarterword name_type_field;
- char *text_p_field;
- char *font_name_field ;
- scaled font_dsize_field ;
- font_number font_n_field ;
- scaled width_field ;
- scaled height_field ;
- scaled depth_field ;
- scaled tx_field ;
- scaled ty_field ;
- scaled txx_field ;
- scaled txy_field ;
- scaled tyx_field ;
- scaled tyy_field ;
-} mp_text_object;
-
-typedef struct mp_fill_object {
- GRAPHIC_BODY;
- char *pre_script_field;
- char *post_script_field;
- mp_color color_field;
- quarterword color_model_field;
- quarterword ljoin_field ;
- mp_knot * path_p_field;
- mp_knot * htap_p_field;
- mp_knot * pen_p_field;
- scaled miterlim_field ;
-} mp_fill_object;
-
-typedef struct mp_stroked_object {
- GRAPHIC_BODY;
- char *pre_script_field;
- char *post_script_field;
- mp_color color_field;
- quarterword color_model_field;
- quarterword ljoin_field ;
- quarterword lcap_field ;
- mp_knot * path_p_field;
- mp_knot * pen_p_field;
- scaled miterlim_field ;
- mp_dash_object *dash_p_field;
-} mp_stroked_object;
-
-typedef struct mp_clip_object {
- GRAPHIC_BODY;
- mp_knot * path_p_field;
-} mp_clip_object;
-
-typedef struct mp_bounds_object {
- GRAPHIC_BODY;
- mp_knot * path_p_field;
-} mp_bounds_object;
-
-typedef struct mp_special_object {
- GRAPHIC_BODY;
- char *pre_script_field;
-} mp_special_object ;
-
-typedef struct mp_edge_object {
- struct mp_graphic_object * body;
- struct mp_edge_object * _next;
- char * _filename;
- MP _parent;
- scaled _minx, _miny, _maxx, _maxy;
-} mp_edge_object;
-
-@ @<Exported function headers@>=
-mp_graphic_object *mp_new_graphic_object(MP mp, int type);
-
-@ @c
-mp_graphic_object *mp_new_graphic_object (MP mp, int type) {
- mp_graphic_object *p;
- int size ;
- switch (type) {
- case mp_fill_code: size = sizeof(mp_fill_object); break;
- case mp_stroked_code: size = sizeof(mp_stroked_object); break;
- case mp_text_code: size = sizeof(mp_text_object); break;
- case mp_start_clip_code: size = sizeof(mp_clip_object); break;
- case mp_start_bounds_code: size = sizeof(mp_bounds_object); break;
- case mp_special_code: size = sizeof(mp_special_object); break;
- default: size = sizeof(mp_graphic_object); break;
- }
- p = (mp_graphic_object *)mp_xmalloc(mp,1,size);
- memset(p,0,size);
- gr_type(p) = type;
- return p;
-}
-
-@ We need to keep track of several parameters from the \ps\ graphics state.
-@^graphics state@>
-This allows us to be sure that \ps\ has the correct values when they are
-needed without wasting time and space setting them unnecessarily.
-
-@d gs_red mp->ps->gs_state->red_field
-@d gs_green mp->ps->gs_state->green_field
-@d gs_blue mp->ps->gs_state->blue_field
-@d gs_black mp->ps->gs_state->black_field
-@d gs_colormodel mp->ps->gs_state->colormodel_field
-@d gs_ljoin mp->ps->gs_state->ljoin_field
-@d gs_lcap mp->ps->gs_state->lcap_field
-@d gs_adj_wx mp->ps->gs_state->adj_wx_field
-@d gs_miterlim mp->ps->gs_state->miterlim_field
-@d gs_dash_p mp->ps->gs_state->dash_p_field
-@d gs_dash_init_done mp->ps->gs_state->dash_done_field
-@d gs_previous mp->ps->gs_state->previous_field
-@d gs_width mp->ps->gs_state->width_field
-
-@<Types...@>=
-typedef struct _gs_state {
- scaled red_field ;
- scaled green_field ;
- scaled blue_field ;
- scaled black_field ;
- /* color from the last \&{setcmykcolor} or \&{setrgbcolor} or \&{setgray} command */
- quarterword colormodel_field ;
- /* the current colormodel */
- quarterword ljoin_field ;
- quarterword lcap_field ;
- /* values from the last \&{setlinejoin} and \&{setlinecap} commands */
- quarterword adj_wx_field ;
- /* what resolution-dependent adjustment applies to the width */
- scaled miterlim_field ;
- /* the value from the last \&{setmiterlimit} command */
- mp_dash_object * dash_p_field ;
- /* edge structure for last \&{setdash} command */
- boolean dash_done_field ; /* to test for initial \&{setdash} */
- struct _gs_state * previous_field ;
- /* backlink to the previous |_gs_state| structure */
- scaled width_field ;
- /* width setting or $-1$ if no \&{setlinewidth} command so far */
-} _gs_state;
-
-
-@ @<Glob...@>=
-struct _gs_state * gs_state;
-
-@ @<Set init...@>=
-mp->ps->gs_state=NULL;
-
-@ @<Dealloc variables@>=
-mp_xfree(mp->ps->gs_state);
-
-@ To avoid making undue assumptions about the initial graphics state, these
-parameters are given special values that are guaranteed not to match anything
-in the edge structure being shipped out. On the other hand, the initial color
-should be black so that the translation of an all-black picture will have no
-\&{setcolor} commands. (These would be undesirable in a font application.)
-Hence we use |c=0| when initializing the graphics state and we use |c<0|
-to recover from a situation where we have lost track of the graphics state.
-
-@c
-void mp_gs_unknown_graphics_state (MP mp,scaled c) ;
-
-@
-@d mp_void (null+1) /* a null pointer different from |null| */
-
-@c void mp_gs_unknown_graphics_state (MP mp,scaled c) {
- struct _gs_state *p; /* to shift graphic states around */
- if ( (c==0)||(c==-1) ) {
- if ( mp->ps->gs_state==NULL ) {
- mp->ps->gs_state = mp_xmalloc(mp,1,sizeof(struct _gs_state));
- gs_previous=NULL;
- } else {
- while ( gs_previous!=NULL ) {
- p = gs_previous;
- mp_xfree(mp->ps->gs_state);
- mp->ps->gs_state=p;
- }
- }
- gs_red=c; gs_green=c; gs_blue=c; gs_black=c;
- gs_colormodel=mp_uninitialized_model;
- gs_ljoin=3;
- gs_lcap=3;
- gs_miterlim=0;
- gs_dash_p=NULL;
- gs_dash_init_done=false;
- gs_width=-1;
- } else if ( c==1 ) {
- p= mp->ps->gs_state;
- mp->ps->gs_state = mp_xmalloc(mp,1,sizeof(struct _gs_state));
- memcpy(mp->ps->gs_state,p,sizeof(struct _gs_state));
- gs_previous = p;
- } else if ( c==2 ) {
- p = gs_previous;
- mp_xfree(mp->ps->gs_state);
- mp->ps->gs_state=p;
- }
-}
-
-
-@ When it is time to output a graphical object, |fix_graphics_state| ensures
-that \ps's idea of the graphics state agrees with what is stored in the object.
-
-@<Declarations@>=
-void mp_gr_fix_graphics_state (MP mp, mp_graphic_object *p) ;
-
-@ @c
-void mp_gr_fix_graphics_state (MP mp, mp_graphic_object *p) {
- /* get ready to output graphical object |p| */
- mp_knot *pp, *path_p; /* for list manipulation */
- mp_dash_object *hh;
- scaled wx,wy,ww; /* dimensions of pen bounding box */
- boolean adj_wx; /* whether pixel rounding should be based on |wx| or |wy| */
- integer tx,ty; /* temporaries for computing |adj_wx| */
- if ( gr_has_color(p) )
- @<Make sure \ps\ will use the right color for object~|p|@>;
- if ( (gr_type(p)==mp_fill_code)||(gr_type(p)==mp_stroked_code) ) {
- if (gr_type(p)==mp_fill_code) {
- pp = gr_pen_p((mp_fill_object *)p);
- path_p = gr_path_p((mp_fill_object *)p);
- } else {
- pp = gr_pen_p((mp_stroked_object *)p);
- path_p = gr_path_p((mp_stroked_object *)p);
- }
- if ( pp!=NULL )
- if ( pen_is_elliptical(pp) ) {
- @<Generate \ps\ code that sets the stroke width to the
- appropriate rounded value@>;
- @<Make sure \ps\ will use the right dash pattern for |dash_p(p)|@>;
- @<Decide whether the line cap parameter matters and set it if necessary@>;
- @<Set the other numeric parameters as needed for object~|p|@>;
- }
- }
- if ( mp->ps->ps_offset>0 ) mp_ps_print_ln(mp);
-}
-
-@ @<Decide whether the line cap parameter matters and set it if necessary@>=
-if ( gr_type(p)==mp_stroked_code ) {
- mp_stroked_object *ts = (mp_stroked_object *)p;
- if ( (gr_left_type(gr_path_p(ts))==mp_endpoint)||(gr_dash_p(ts)!=NULL) )
- if ( gs_lcap!=gr_lcap_val(ts) ) {
- ps_room(13);
- mp_ps_print_char(mp, ' ');
- mp_ps_print_char(mp, '0'+gr_lcap_val(ts));
- mp_ps_print_cmd(mp, " setlinecap"," lc");
- gs_lcap=gr_lcap_val(ts);
- }
-}
-
-@
-@d set_ljoin_miterlim(p)
- if ( gs_ljoin!=gr_ljoin_val(p) ) {
- ps_room(14);
- mp_ps_print_char(mp, ' ');
- mp_ps_print_char(mp, '0'+gr_ljoin_val(p));
- mp_ps_print_cmd(mp, " setlinejoin"," lj");
- gs_ljoin=gr_ljoin_val(p);
- }
- if ( gs_miterlim!=gr_miterlim_val(p) ) {
- ps_room(27);
- mp_ps_print_char(mp, ' ');
- mp_ps_print_scaled(mp, gr_miterlim_val(p));
- mp_ps_print_cmd(mp, " setmiterlimit"," ml");
- gs_miterlim=gr_miterlim_val(p);
- }
-
-@<Set the other numeric parameters as needed for object~|p|@>=
-if ( gr_type(p)==mp_stroked_code ) {
- mp_stroked_object *ts = (mp_stroked_object *)p;
- set_ljoin_miterlim(ts);
-} else {
- mp_fill_object *ts = (mp_fill_object *)p;
- set_ljoin_miterlim(ts);
-}
-
-@
-@d set_color_objects(pq)
- object_color_model = pq->color_model_field;
- object_color_a = pq->color_field._a_val;
- object_color_b = pq->color_field._b_val;
- object_color_c = pq->color_field._c_val;
- object_color_d = pq->color_field._d_val;
-
-@<Make sure \ps\ will use the right color for object~|p|@>=
-{
- int object_color_model;
- int object_color_a, object_color_b, object_color_c, object_color_d ;
- if (gr_type(p) == mp_fill_code) {
- mp_fill_object *pq = (mp_fill_object *)p;
- set_color_objects(pq);
- } else if (gr_type(p) == mp_stroked_code) {
- mp_stroked_object *pq = (mp_stroked_object *)p;
- set_color_objects(pq);
- } else {
- mp_text_object *pq = (mp_text_object *)p;
- set_color_objects(pq);
- }
-
- if ( object_color_model==mp_rgb_model) {
- if ( (gs_colormodel!=mp_rgb_model)||(gs_red!=object_color_a)||
- (gs_green!=object_color_b)||(gs_blue!=object_color_c) ) {
- gs_red = object_color_a;
- gs_green = object_color_b;
- gs_blue = object_color_c;
- gs_black = -1;
- gs_colormodel=mp_rgb_model;
- { ps_room(36);
- mp_ps_print_char(mp, ' ');
- mp_ps_print_scaled(mp, gs_red); mp_ps_print_char(mp, ' ');
- mp_ps_print_scaled(mp, gs_green); mp_ps_print_char(mp, ' ');
- mp_ps_print_scaled(mp, gs_blue);
- mp_ps_print_cmd(mp, " setrgbcolor", " R");
- }
- }
- } else if ( object_color_model==mp_cmyk_model) {
- if ( (gs_red!=object_color_a)||(gs_green!=object_color_b)||
- (gs_blue!=object_color_c)||(gs_black!=object_color_d)||
- (gs_colormodel!=mp_cmyk_model) ) {
- gs_red = object_color_a;
- gs_green = object_color_b;
- gs_blue = object_color_c;
- gs_black = object_color_d;
- gs_colormodel=mp_cmyk_model;
- { ps_room(45);
- mp_ps_print_char(mp, ' ');
- mp_ps_print_scaled(mp, gs_red);
- mp_ps_print_char(mp, ' ');
- mp_ps_print_scaled(mp, gs_green);
- mp_ps_print_char(mp, ' ');
- mp_ps_print_scaled(mp, gs_blue);
- mp_ps_print_char(mp, ' ');
- mp_ps_print_scaled(mp, gs_black);
- mp_ps_print_cmd(mp, " setcmykcolor"," C");
- }
- }
- } else if ( object_color_model==mp_grey_model ) {
- if ( (gs_red!=object_color_a)||(gs_colormodel!=mp_grey_model) ) {
- gs_red = object_color_a;
- gs_green = -1;
- gs_blue = -1;
- gs_black = -1;
- gs_colormodel=mp_grey_model;
- { ps_room(16);
- mp_ps_print_char(mp, ' ');
- mp_ps_print_scaled(mp, gs_red);
- mp_ps_print_cmd(mp, " setgray"," G");
- }
- }
- } else if ( object_color_model==mp_no_model ) {
- gs_colormodel=mp_no_model;
- }
-}
-
-@ In order to get consistent widths for horizontal and vertical pen strokes, we
-want \ps\ to use an integer number of pixels for the \&{setwidth} parameter.
-@:setwidth}{\&{setwidth}command@>
-We set |gs_width| to the ideal horizontal or vertical stroke width and then
-generate \ps\ code that computes the rounded value. For non-circular pens, the
-pen shape will be rescaled so that horizontal or vertical parts of the stroke
-have the computed width.
-
-Rounding the width to whole pixels is not likely to improve the appearance of
-diagonal or curved strokes, but we do it anyway for consistency. The
-\&{truncate} command generated here tends to make all the strokes a little
-@:truncate}{\&{truncate} command@>
-thinner, but this is appropriate for \ps's scan-conversion rules. Even with
-truncation, an ideal with of $w$~pixels gets mapped into $\lfloor w\rfloor+1$.
-It would be better to have $\lceil w\rceil$ but that is ridiculously expensive
-to compute in \ps.
-
-@<Generate \ps\ code that sets the stroke width...@>=
-@<Set |wx| and |wy| to the width and height of the bounding box for
- |pen_p(p)|@>;
-@<Use |pen_p(p)| and |path_p(p)| to decide whether |wx| or |wy| is more
- important and set |adj_wx| and |ww| accordingly@>;
-if ( (ww!=gs_width) || (adj_wx!=gs_adj_wx) ) {
- if ( adj_wx ) {
- ps_room(13);
- mp_ps_print_char(mp, ' '); mp_ps_print_scaled(mp, ww);
- mp_ps_print_cmd(mp,
- " 0 dtransform exch truncate exch idtransform pop setlinewidth"," hlw");
- } else {
- if ( mp->internal[mp_procset]>0 ) {
- ps_room(13);
- mp_ps_print_char(mp, ' ');
- mp_ps_print_scaled(mp, ww);
- mp_ps_print(mp, " vlw");
- } else {
- ps_room(15);
- mp_ps_print(mp, " 0 "); mp_ps_print_scaled(mp, ww);
- mp_ps_print(mp, " dtransform truncate idtransform setlinewidth pop");
- }
- }
- gs_width = ww;
- gs_adj_wx = adj_wx;
-}
-
-@ @<Set |wx| and |wy| to the width and height of the bounding box for...@>=
-if ( (gr_right_x(pp)==gr_x_coord(pp)) && (gr_left_y(pp)==gr_y_coord(pp)) ) {
- wx = abs(gr_left_x(pp) - gr_x_coord(pp));
- wy = abs(gr_right_y(pp) - gr_y_coord(pp));
-} else {
- wx = mp_pyth_add(mp, gr_left_x(pp)-gr_x_coord(pp), gr_right_x(pp)-gr_x_coord(pp));
- wy = mp_pyth_add(mp, gr_left_y(pp)-gr_y_coord(pp), gr_right_y(pp)-gr_y_coord(pp));
-}
-
-@ The path is considered ``essentially horizontal'' if its range of
-$y$~coordinates is less than the $y$~range |wy| for the pen. ``Essentially
-vertical'' paths are detected similarly. This code ensures that no component
-of the pen transformation is more that |aspect_bound*(ww+1)|.
-
-@d aspect_bound 10 /* ``less important'' of |wx|, |wy| cannot exceed the other by
- more than this factor */
-
-@d do_x_loc 1
-@d do_y_loc 2
-
-@<Use |pen_p(p)| and |path_p(p)| to decide whether |wx| or |wy| is more...@>=
-tx=1; ty=1;
-if ( mp_gr_coord_rangeOK(path_p, do_y_loc, wy) ) tx=aspect_bound;
-else if ( mp_gr_coord_rangeOK(path_p, do_x_loc, wx) ) ty=aspect_bound;
-if ( wy / ty>=wx / tx ) { ww=wy; adj_wx=false; }
-else { ww=wx; adj_wx=true; }
-
-@ This routine quickly tests if path |h| is ``essentially horizontal'' or
-``essentially vertical,'' where |zoff| is |x_loc(0)| or |y_loc(0)| and |dz| is
-allowable range for $x$ or~$y$. We do not need and cannot afford a full
-bounding-box computation.
-
-@<Declarations@>=
-boolean mp_gr_coord_rangeOK (mp_knot *h,
- small_number zoff, scaled dz);
-
-@ @c
-boolean mp_gr_coord_rangeOK (mp_knot *h,
- small_number zoff, scaled dz) {
- mp_knot *p; /* for scanning the path form |h| */
- scaled zlo,zhi; /* coordinate range so far */
- scaled z; /* coordinate currently being tested */
- if (zoff==do_x_loc) {
- zlo=gr_x_coord(h);
- zhi=zlo;
- p=h;
- while ( gr_right_type(p)!=mp_endpoint ) {
- z=gr_right_x(p);
- @<Make |zlo..zhi| include |z| and |return false| if |zhi-zlo>dz|@>;
- p=gr_next_knot(p); z=gr_left_x(p);
- @<Make |zlo..zhi| include |z| and |return false| if |zhi-zlo>dz|@>;
- z=gr_x_coord(p);
- @<Make |zlo..zhi| include |z| and |return false| if |zhi-zlo>dz|@>;
- if ( p==h ) break;
- }
- } else {
- zlo=gr_y_coord(h);
- zhi=zlo;
- p=h;
- while ( gr_right_type(p)!=mp_endpoint ) {
- z=gr_right_y(p);
- @<Make |zlo..zhi| include |z| and |return false| if |zhi-zlo>dz|@>;
- p=gr_next_knot(p); z=gr_left_y(p);
- @<Make |zlo..zhi| include |z| and |return false| if |zhi-zlo>dz|@>;
- z=gr_y_coord(p);
- @<Make |zlo..zhi| include |z| and |return false| if |zhi-zlo>dz|@>;
- if ( p==h ) break;
- }
- }
- return true;
-}
-
-@ @<Make |zlo..zhi| include |z| and |return false| if |zhi-zlo>dz|@>=
-if ( z<zlo ) zlo=z;
-else if ( z>zhi ) zhi=z;
-if ( zhi-zlo>dz ) return false
-
-@ Filling with an elliptical pen is implemented via a combination of \&{stroke}
-and \&{fill} commands and a nontrivial dash pattern would interfere with this.
-@:stroke}{\&{stroke} command@>
-@:fill}{\&{fill} command@>
-Note that we don't use |delete_edge_ref| because |gs_dash_p| is not counted as
-a reference.
-
-@<Make sure \ps\ will use the right dash pattern for |dash_p(p)|@>=
-if ( gr_type(p)==mp_fill_code || gr_dash_p(p) == NULL) {
- hh=NULL;
-} else {
- hh=gr_dash_p(p);
-}
-if ( hh==NULL ) {
- if ( gs_dash_p!=NULL || gs_dash_init_done == false) {
- mp_ps_print_cmd(mp, " [] 0 setdash"," rd");
- gs_dash_p=NULL;
- gs_dash_init_done=true;
- }
-} else if ( ! mp_gr_same_dashes(gs_dash_p,hh) ) {
- @<Set the dash pattern from |dash_list(hh)| scaled by |scf|@>;
-}
-
-@ @<Declarations@>=
-scaled mp_gr_get_pen_scale (MP mp, mp_knot *p) ;
-
-
-@ @c
-scaled mp_gr_get_pen_scale (MP mp, mp_knot *p) {
- return mp_sqrt_det(mp,
- gr_left_x(p)-gr_x_coord(p), gr_right_x(p)-gr_x_coord(p),
- gr_left_y(p)-gr_y_coord(p), gr_right_y(p)-gr_y_coord(p));
-}
-
-
-@ The original code had a check here to ensure that the result from
-|mp_take_scaled| did not go out of bounds.
-
-@<Set the dash pattern from |dash_list(hh)| scaled by |scf|@>=
-{ gs_dash_p=hh;
- if ( (gr_dash_p(p)==NULL) || (hh==NULL) || (hh->array_field==NULL)) {
- mp_ps_print_cmd(mp, " [] 0 setdash"," rd");
- } else {
- int i;
- ps_room(28);
- mp_ps_print(mp, " [");
- for (i=0; *(hh->array_field+i) != -1;i++) {
- ps_room(13);
- mp_ps_print_scaled(mp, *(hh->array_field+i));
- mp_ps_print_char(mp, ' ') ;
- }
- ps_room(22);
- mp_ps_print(mp, "] ");
- mp_ps_print_scaled(mp, hh->offset_field);
- mp_ps_print_cmd(mp, " setdash"," sd");
- }
-}
-
-@ @<Declarations@>=
-boolean mp_gr_same_dashes (mp_dash_object *h, mp_dash_object *hh) ;
-
-@ This function test if |h| and |hh| represent the same dash pattern.
-
-@c
-boolean mp_gr_same_dashes (mp_dash_object *h, mp_dash_object *hh) {
- boolean ret=false;
- int i = 0;
- if ( h==hh ) ret=true;
- else if ( (h==NULL)||(hh==NULL) ) ret=false;
- else if ( h->offset_field!=hh->offset_field ) ret=false;
- else if ( h->array_field == hh->array_field) ret=true;
- else if ( h->array_field == NULL || hh->array_field == NULL) ret=false;
- else { @<Compare |dash_list(h)| and |dash_list(hh)|@>; }
- return ret;
-}
-
-@ @<Compare |dash_list(h)| and |dash_list(hh)|@>=
-{
- while (*(h->array_field+i)!=-1 &&
- *(hh->array_field+i)!=-1 &&
- *(h->array_field+i) == *(hh->array_field+i)) i++;
- if (i>0) {
- if (*(h->array_field+(i))==-1 && *(hh->array_field+(i)) == -1)
- ret=true;
- }
-}
-
-@ When stroking a path with an elliptical pen, it is necessary to transform
-the coordinate system so that a unit circular pen will have the desired shape.
-To keep this transformation local, we enclose it in a
-$$\&{gsave}\ldots\&{grestore}$$
-block. Any translation component must be applied to the path being stroked
-while the rest of the transformation must apply only to the pen.
-If |fill_also=true|, the path is to be filled as well as stroked so we must
-insert commands to do this after giving the path.
-
-@<Declarations@>=
-void mp_gr_stroke_ellipse (MP mp, mp_graphic_object *h, boolean fill_also) ;
-
-@
-@c void mp_gr_stroke_ellipse (MP mp, mp_graphic_object *h, boolean fill_also) {
- /* generate an elliptical pen stroke from object |h| */
- scaled txx,txy,tyx,tyy; /* transformation parameters */
- mp_knot *p; /* the pen to stroke with */
- scaled d1,det; /* for tweaking transformation parameters */
- integer s; /* also for tweaking transformation paramters */
- boolean transformed; /* keeps track of whether gsave/grestore are needed */
- transformed=false;
- @<Use |pen_p(h)| to set the transformation parameters and give the initial
- translation@>;
- @<Tweak the transformation parameters so the transformation is nonsingular@>;
- if (gr_type(h)==mp_fill_code) {
- mp_gr_ps_path_out(mp, gr_path_p((mp_fill_object *)h));
- } else {
- mp_gr_ps_path_out(mp, gr_path_p((mp_stroked_object *)h));
- }
- if ( mp->internal[mp_procset]==0 ) {
- if ( fill_also ) mp_ps_print_nl(mp, "gsave fill grestore");
- @<Issue \ps\ commands to transform the coordinate system@>;
- mp_ps_print(mp, " stroke");
- if ( transformed ) mp_ps_print(mp, " grestore");
- } else {
- if ( fill_also ) mp_ps_print_nl(mp, "B"); else mp_ps_print_ln(mp);
- if ( (txy!=0)||(tyx!=0) ) {
- mp_ps_print(mp, " [");
- mp_ps_pair_out(mp, txx,tyx);
- mp_ps_pair_out(mp, txy,tyy);
- mp_ps_print(mp, "0 0] t");
- } else if ((txx!=unity)||(tyy!=unity) ) {
- mp_ps_pair_out(mp,txx,tyy);
- mp_ps_print(mp, " s");
- };
- mp_ps_print(mp, " S");
- if ( transformed ) mp_ps_print(mp, " Q");
- }
- mp_ps_print_ln(mp);
-}
-
-@ @<Use |pen_p(h)| to set the transformation parameters and give the...@>=
-if (gr_type(h)==mp_fill_code) {
- p=gr_pen_p((mp_fill_object *)h);
-} else {
- p=gr_pen_p((mp_stroked_object *)h);
-}
-txx=gr_left_x(p);
-tyx=gr_left_y(p);
-txy=gr_right_x(p);
-tyy=gr_right_y(p);
-if ( (gr_x_coord(p)!=0)||(gr_y_coord(p)!=0) ) {
- mp_ps_print_nl(mp, "");
- mp_ps_print_cmd(mp, "gsave ","q ");
- mp_ps_pair_out(mp, gr_x_coord(p), gr_y_coord(p));
- mp_ps_print(mp, "translate ");
- txx-=gr_x_coord(p);
- tyx-=gr_y_coord(p);
- txy-=gr_x_coord(p);
- tyy-=gr_y_coord(p);
- transformed=true;
-} else {
- mp_ps_print_nl(mp, "");
-}
-@<Adjust the transformation to account for |gs_width| and output the
- initial \&{gsave} if |transformed| should be |true|@>
-
-@ @<Adjust the transformation to account for |gs_width| and output the...@>=
-if ( gs_width!=unity ) {
- if ( gs_width==0 ) {
- txx=unity; tyy=unity;
- } else {
- txx=mp_make_scaled(mp, txx,gs_width);
- txy=mp_make_scaled(mp, txy,gs_width);
- tyx=mp_make_scaled(mp, tyx,gs_width);
- tyy=mp_make_scaled(mp, tyy,gs_width);
- };
-}
-if ( (txy!=0)||(tyx!=0)||(txx!=unity)||(tyy!=unity) ) {
- if ( (! transformed) ){
- mp_ps_print_cmd(mp, "gsave ","q ");
- transformed=true;
- }
-}
-
-@ @<Issue \ps\ commands to transform the coordinate system@>=
-if ( (txy!=0)||(tyx!=0) ){
- mp_ps_print_ln(mp);
- mp_ps_print_char(mp, '[');
- mp_ps_pair_out(mp, txx,tyx);
- mp_ps_pair_out(mp, txy,tyy);
- mp_ps_print(mp, "0 0] concat");
-} else if ( (txx!=unity)||(tyy!=unity) ){
- mp_ps_print_ln(mp);
- mp_ps_pair_out(mp, txx,tyy);
- mp_ps_print(mp, "scale");
-}
-
-@ The \ps\ interpreter will probably abort if it encounters a singular
-transformation matrix. The determinant must be large enough to ensure that
-the printed representation will be nonsingular. Since the printed
-representation is always within $2^{-17}$ of the internal |scaled| value, the
-total error is at most $4T_{\rm max}2^{-17}$, where $T_{\rm max}$ is a bound on
-the magnitudes of |txx/65536|, |txy/65536|, etc.
-
-The |aspect_bound*(gs_width+1)| bound on the components of the pen
-transformation allows $T_{\rm max}$ to be at most |2*aspect_bound|.
-
-@<Tweak the transformation parameters so the transformation is nonsingular@>=
-det=mp_take_scaled(mp, txx,tyy) - mp_take_scaled(mp, txy,tyx);
-d1=4*aspect_bound+1;
-if ( abs(det)<d1 ) {
- if ( det>=0 ) { d1=d1-det; s=1; }
- else { d1=-d1-det; s=-1; };
- d1=d1*unity;
- if ( abs(txx)+abs(tyy)>=abs(txy)+abs(tyy) ) {
- if ( abs(txx)>abs(tyy) ) tyy=tyy+(d1+s*abs(txx)) / txx;
- else txx=txx+(d1+s*abs(tyy)) / tyy;
- } else {
- if ( abs(txy)>abs(tyx) ) tyx=tyx+(d1+s*abs(txy)) / txy;
- else txy=txy+(d1+s*abs(tyx)) / tyx;
- }
-}
-
-@ Here is a simple routine that just fills a cycle.
-
-@<Declarations@>=
-void mp_gr_ps_fill_out (MP mp, mp_knot *p);
-
-@ @c
-void mp_gr_ps_fill_out (MP mp, mp_knot *p) { /* fill cyclic path~|p| */
- mp_gr_ps_path_out(mp, p);
- mp_ps_print_cmd(mp, " fill"," F");
- mp_ps_print_ln(mp);
-}
-
-@ A text node may specify an arbitrary transformation but the usual case
-involves only shifting, scaling, and occasionally rotation. The purpose
-of |choose_scale| is to select a scale factor so that the remaining
-transformation is as ``nice'' as possible. The definition of ``nice''
-is somewhat arbitrary but shifting and $90^\circ$ rotation are especially
-nice because they work out well for bitmap fonts. The code here selects
-a scale factor equal to $1/\sqrt2$ times the Frobenius norm of the
-non-shifting part of the transformation matrix. It is careful to avoid
-additions that might cause undetected overflow.
-
-@<Declarations@>=
-scaled mp_gr_choose_scale (MP mp, mp_graphic_object *p) ;
-
-@ @c scaled mp_gr_choose_scale (MP mp, mp_graphic_object *p) {
- /* |p| should point to a text node */
- scaled a,b,c,d,ad,bc; /* temporary values */
- a=gr_txx_val(p);
- b=gr_txy_val(p);
- c=gr_tyx_val(p);
- d=gr_tyy_val(p);
- if ( a<0 ) negate(a);
- if ( b<0 ) negate(b);
- if ( c<0 ) negate(c);
- if ( d<0 ) negate(d);
- ad=half(a-d);
- bc=half(b-c);
- return mp_pyth_add(mp, mp_pyth_add(mp, d+ad,ad), mp_pyth_add(mp, c+bc,bc));
-}
-
-@ The potential overflow here is caused by the fact the returned value
-has to fit in a |name_type|, which is a quarterword.
-
-@d fscale_tolerance 65 /* that's $.001\times2^{16}$ */
-
-@<Declarations@>=
-quarterword mp_size_index (MP mp, font_number f, scaled s) ;
-
-@ @c
-quarterword mp_size_index (MP mp, font_number f, scaled s) {
- pointer p,q; /* the previous and current font size nodes */
- quarterword i; /* the size index for |q| */
- q=mp->font_sizes[f];
- i=0;
- while ( q!=null ) {
- if ( abs(s-sc_factor(q))<=fscale_tolerance )
- return i;
- else
- { p=q; q=link(q); incr(i); };
- if ( i==max_quarterword )
- mp_overflow(mp, "sizes per font",max_quarterword);
-@:MetaPost capacity exceeded sizes per font}{\quad sizes per font@>
- }
- q=mp_get_node(mp, font_size_size);
- sc_factor(q)=s;
- if ( i==0 ) mp->font_sizes[f]=q; else link(p)=q;
- return i;
-}
-
-@ @<Declarations@>=
-scaled mp_indexed_size (MP mp,font_number f, quarterword j);
-
-@ @c
-scaled mp_indexed_size (MP mp,font_number f, quarterword j) {
- pointer p; /* a font size node */
- quarterword i; /* the size index for |p| */
- p=mp->font_sizes[f];
- i=0;
- if ( p==null ) mp_confusion(mp, "size");
- while ( (i!=j) ) {
- incr(i); p=link(p);
- if ( p==null ) mp_confusion(mp, "size");
- }
- return sc_factor(p);
-}
-
-@ @<Declarations@>=
-void mp_clear_sizes (MP mp) ;
-
-@ @c void mp_clear_sizes (MP mp) {
- font_number f; /* the font whose size list is being cleared */
- pointer p; /* current font size nodes */
- for (f=null_font+1;f<=mp->last_fnum;f++) {
- while ( mp->font_sizes[f]!=null ) {
- p=mp->font_sizes[f];
- mp->font_sizes[f]=link(p);
- mp_free_node(mp, p,font_size_size);
- }
- }
-}
-
-@ A text node may specify an arbitrary transformation but the usual case
-involves only shifting, scaling, and occasionally rotation. The purpose
-of |choose_scale| is to select a scale factor so that the remaining
-transformation is as ``nice'' as possible. The definition of ``nice''
-is somewhat arbitrary but shifting and $90^\circ$ rotation are especially
-nice because they work out well for bitmap fonts. The code here selects
-a scale factor equal to $1/\sqrt2$ times the Frobenius norm of the
-non-shifting part of the transformation matrix. It is careful to avoid
-additions that might cause undetected overflow.
-
-@<Declare the \ps\ output procedures@>=
-scaled mp_choose_scale (MP mp, mp_graphic_object *p) ;
-
-@ @c scaled mp_choose_scale (MP mp, mp_graphic_object *p) {
- /* |p| should point to a text node */
- scaled a,b,c,d,ad,bc; /* temporary values */
- a=gr_txx_val(p);
- b=gr_txy_val(p);
- c=gr_tyx_val(p);
- d=gr_tyy_val(p);
- if ( (a<0) ) negate(a);
- if ( (b<0) ) negate(b);
- if ( (c<0) ) negate(c);
- if ( (d<0) ) negate(d);
- ad=half(a-d);
- bc=half(b-c);
- return mp_pyth_add(mp, mp_pyth_add(mp, d+ad,ad), mp_pyth_add(mp, c+bc,bc));
-}
-
-@ There may be many sizes of one font and we need to keep track of the
-characters used for each size. This is done by keeping a linked list of
-sizes for each font with a counter in each text node giving the appropriate
-position in the size list for its font.
-
-@d font_size_size 2 /* size of a font size node */
-
-
-@ @<Declarations@>=
-void mp_apply_mark_string_chars(MP mp, mp_edge_object *h, int next_size);
-
-@ @c
-void mp_apply_mark_string_chars(MP mp, mp_edge_object *h, int next_size) {
- mp_graphic_object * p;
- p=h->body;
- while ( p!= NULL ) {
- if ( gr_type(p)==mp_text_code ) {
- if ( gr_font_n(p)!=null_font ) {
- if ( gr_name_type(p)==next_size )
- mp_mark_string_chars(mp, gr_font_n(p),gr_text_p(p));
- }
- }
- p=gr_link(p);
- }
-}
-
-@ @<Unmark all marked characters@>=
-for (f=null_font+1;f<=mp->last_fnum;f++) {
- if ( mp->font_sizes[f]!=null ) {
- mp_unmark_font(mp, f);
- mp->font_sizes[f]=null;
- }
-}
-
-@ @<Scan all the text nodes and mark the used ...@>=
-p=hh->body;
-while ( p!=null ) {
- if ( gr_type(p)==mp_text_code ) {
- f = gr_font_n(p);
- if (f!=null_font ) {
- switch (prologues) {
- case 2:
- case 3:
- mp->font_sizes[f] = mp_void;
- mp_mark_string_chars(mp, f, gr_text_p(p));
- if (mp_has_fm_entry(mp,f,NULL) ) {
- if (mp->font_enc_name[f]==NULL )
- mp->font_enc_name[f] = mp_fm_encoding_name(mp,f);
- mp->font_ps_name[f] = mp_fm_font_name(mp,f);
- }
- break;
- case 1:
- mp->font_sizes[f]=mp_void;
- break;
- default:
- gr_name_type(p)=mp_size_index(mp, f,mp_choose_scale(mp, p));
- if ( gr_name_type(p)==0 )
- mp_mark_string_chars(mp, f, gr_text_p(p));
- }
- }
- }
- p=gr_link(p);
-}
-
-
-@
-@d pen_is_elliptical(A) ((A)==gr_next_knot((A)))
-
-@<Exported function headers@>=
-void mp_gr_ship_out (mp_edge_object *hh, int prologues, int procset) ;
-
-@ @c
-void mp_gr_ship_out (mp_edge_object *hh, int prologues, int procset) {
- mp_graphic_object *p;
- scaled ds,scf; /* design size and scale factor for a text node */
- font_number f; /* for loops over fonts while (un)marking characters */
- boolean transformed; /* is the coordinate system being transformed? */
- MP mp = hh->_parent;
- if (mp->history >= mp_fatal_error_stop ) return;
- if (prologues<0)
- prologues = (mp->internal[mp_prologues]>>16);
- if (procset<0)
- procset = (mp->internal[mp_procset]>>16);
- mp_open_output_file(mp);
- mp_print_initial_comment(mp, hh, prologues);
- p = hh->body;
- @<Unmark all marked characters@>;
- if ( prologues==2 || prologues==3 ) {
- mp_reload_encodings(mp);
- }
- @<Scan all the text nodes and mark the used characters@>;
- if ( prologues==2 || prologues==3 ) {
- mp_print_improved_prologue(mp, hh, prologues, procset);
- } else {
- mp_print_prologue(mp, hh, prologues, procset);
- }
- mp_gs_unknown_graphics_state(mp, 0);
- p = hh->body;
- while ( p!=NULL ) {
- if ( gr_has_color(p) ) {
- @<Write |pre_script| of |p|@>;
- }
- mp_gr_fix_graphics_state(mp, p);
- switch (gr_type(p)) {
- case mp_fill_code:
- if ( gr_pen_p((mp_fill_object *)p)==NULL ) {
- mp_gr_ps_fill_out(mp, gr_path_p((mp_fill_object *)p));
- } else if ( pen_is_elliptical(gr_pen_p((mp_fill_object *)p)) ) {
- mp_gr_stroke_ellipse(mp, p,true);
- } else {
- mp_gr_ps_fill_out(mp, gr_path_p((mp_fill_object *)p));
- mp_gr_ps_fill_out(mp, gr_htap_p(p));
- }
- if ( gr_post_script((mp_fill_object *)p)!=NULL ) {
- mp_ps_print_nl (mp, gr_post_script((mp_fill_object *)p));
- mp_ps_print_ln(mp);
- }
- break;
- case mp_stroked_code:
- if ( pen_is_elliptical(gr_pen_p((mp_stroked_object *)p)) )
- mp_gr_stroke_ellipse(mp, p,false);
- else {
- mp_gr_ps_fill_out(mp, gr_path_p((mp_stroked_object *)p));
- }
- if ( gr_post_script((mp_stroked_object *)p)!=NULL ) {
- mp_ps_print_nl (mp, gr_post_script((mp_stroked_object *)p));
- mp_ps_print_ln(mp);
- }
- break;
- case mp_text_code:
- if ( (gr_font_n(p)!=null_font) && (strlen(gr_text_p(p))>0) ) {
- if ( prologues>0 )
- scf=mp_gr_choose_scale(mp, p);
- else
- scf=mp_indexed_size(mp, gr_font_n(p), gr_name_type(p));
- @<Shift or transform as necessary before outputting text node~|p| at scale
- factor~|scf|; set |transformed:=true| if the original transformation must
- be restored@>;
- mp_ps_string_out(mp, gr_text_p(p));
- mp_ps_name_out(mp, mp->font_name[gr_font_n(p)],false);
- @<Print the size information and \ps\ commands for text node~|p|@>;
- mp_ps_print_ln(mp);
- }
- if ( gr_post_script((mp_text_object *)p)!=NULL ) {
- mp_ps_print_nl (mp, gr_post_script((mp_text_object *)p)); mp_ps_print_ln(mp);
- }
- break;
- case mp_start_clip_code:
- mp_ps_print_nl(mp, ""); mp_ps_print_cmd(mp, "gsave ","q ");
- mp_gr_ps_path_out(mp, gr_path_p((mp_clip_object *)p));
- mp_ps_print_cmd(mp, " clip"," W");
- mp_ps_print_ln(mp);
- if ( mp->internal[mp_restore_clip_color]>0 )
- mp_gs_unknown_graphics_state(mp, 1);
- break;
- case mp_stop_clip_code:
- mp_ps_print_nl(mp, ""); mp_ps_print_cmd(mp, "grestore","Q");
- mp_ps_print_ln(mp);
- if ( mp->internal[mp_restore_clip_color]>0 )
- mp_gs_unknown_graphics_state(mp, 2);
- else
- mp_gs_unknown_graphics_state(mp, -1);
- break;
- case mp_start_bounds_code:
- case mp_stop_bounds_code:
- break;
- case mp_special_code:
- {
- mp_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->ps_file);
- if ( prologues<=0 )
- mp_clear_sizes(mp);
-}
-
-@
-@d do_write_prescript(a,b) {
- if ( (gr_pre_script((b *)a))!=NULL ) {
- mp_ps_print_nl (mp, gr_pre_script((b *)a));
- mp_ps_print_ln(mp);
- }
-}
-
-@<Write |pre_script| of |p|@>=
-{
- if (gr_type(p)==mp_fill_code) { do_write_prescript(p,mp_fill_object); }
- else if (gr_type(p)==mp_stroked_code) { do_write_prescript(p,mp_stroked_object); }
- else if (gr_type(p)==mp_text_code) { do_write_prescript(p,mp_text_object); }
-}
-
-@ The envelope of a cyclic path~|q| could be computed by calling
-|make_envelope| once for |q| and once for its reversal. We don't do this
-because it would fail color regions that are covered by the pen regardless
-of where it is placed on~|q|.
-
-@<Break the cycle and set |t:=1| if path |q| is cyclic@>=
-if ( gr_left_type(q)!=mp_endpoint ) {
- gr_left_type(mp_gr_insert_knot(mp, q,gr_x_coord(q),gr_y_coord(q)))=mp_endpoint;
- gr_right_type(q)=mp_endpoint;
- q=gr_next_knot(q);
- t=1;
-}
-
-@ @<Print the size information and \ps\ commands for text node~|p|@>=
-ps_room(18);
-mp_ps_print_char(mp, ' ');
-ds=(mp->font_dsize[gr_font_n(p)]+8) / 16;
-mp_ps_print_scaled(mp, mp_take_scaled(mp, ds,scf));
-mp_ps_print(mp, " fshow");
-if ( transformed )
- mp_ps_print_cmd(mp, " grestore"," Q")
-
-
-
-@ @<Shift or transform as necessary before outputting text node~|p| at...@>=
-transformed=(gr_txx_val(p)!=scf)||(gr_tyy_val(p)!=scf)||
- (gr_txy_val(p)!=0)||(gr_tyx_val(p)!=0);
-if ( transformed ) {
- mp_ps_print_cmd(mp, "gsave [", "q [");
- mp_ps_pair_out(mp, mp_make_scaled(mp, gr_txx_val(p),scf),
- mp_make_scaled(mp, gr_tyx_val(p),scf));
- mp_ps_pair_out(mp, mp_make_scaled(mp, gr_txy_val(p),scf),
- mp_make_scaled(mp, gr_tyy_val(p),scf));
- mp_ps_pair_out(mp, gr_tx_val(p),gr_ty_val(p));
- mp_ps_print_cmd(mp, "] concat 0 0 moveto","] t 0 0 m");
-} else {
- mp_ps_pair_out(mp, gr_tx_val(p),gr_ty_val(p));
- mp_ps_print_cmd(mp, "moveto","m");
-}
-mp_ps_print_ln(mp)
-
-
-@ @<Exported function headers@>=
-void mp_gr_toss_objects ( mp_edge_object *hh) ;
-void mp_gr_toss_object (mp_graphic_object *p) ;
-
-@ @c
-void mp_gr_toss_object (mp_graphic_object *p) {
- mp_fill_object *tf;
- mp_stroked_object *ts;
- mp_text_object *tt;
- switch (gr_type(p)) {
- case mp_fill_code:
- tf = (mp_fill_object *)p;
- mp_xfree(gr_pre_script(tf));
- mp_xfree(gr_post_script(tf));
- mp_gr_toss_knot_list(mp,gr_pen_p(tf));
- mp_gr_toss_knot_list(mp,gr_path_p(tf));
- mp_gr_toss_knot_list(mp,gr_htap_p(p));
- break;
- case mp_stroked_code:
- ts = (mp_stroked_object *)p;
- mp_xfree(gr_pre_script(ts));
- mp_xfree(gr_post_script(ts));
- mp_gr_toss_knot_list(mp,gr_pen_p(ts));
- mp_gr_toss_knot_list(mp,gr_path_p(ts));
- if (gr_dash_p(p)!=NULL)
- mp_gr_toss_dashes (mp,gr_dash_p(p));
- break;
- case mp_text_code:
- tt = (mp_text_object *)p;
- mp_xfree(gr_pre_script(tt));
- mp_xfree(gr_post_script(tt));
- mp_xfree(gr_text_p(p));
- mp_xfree(gr_font_name(p));
- break;
- case mp_start_clip_code:
- mp_gr_toss_knot_list(mp,gr_path_p((mp_clip_object *)p));
- break;
- case mp_start_bounds_code:
- mp_gr_toss_knot_list(mp,gr_path_p((mp_bounds_object *)p));
- break;
- case mp_stop_clip_code:
- case mp_stop_bounds_code:
- break;
- case mp_special_code:
- mp_xfree(gr_pre_script((mp_special_object *)p));
- break;
- } /* all cases are enumerated */
- mp_xfree(p);
-}
-
-
-@ @c
-void mp_gr_toss_objects (mp_edge_object *hh) {
- mp_graphic_object *p, *q;
- p = hh->body;
- while ( p!=NULL ) {
- q = gr_link(p);
- mp_gr_toss_object(p);
- p=q;
- }
- mp_xfree(hh);
-}
-
-@ @<Exported function headers@>=
-mp_graphic_object *mp_gr_copy_object (MP mp, mp_graphic_object *p) ;
-
-@ @c
-mp_graphic_object *
-mp_gr_copy_object (MP mp, mp_graphic_object *p) {
- mp_fill_object *tf;
- mp_stroked_object *ts;
- mp_text_object *tt;
- mp_clip_object *tc;
- mp_bounds_object *tb;
- mp_special_object *tp;
- mp_graphic_object *q = NULL;
- switch (gr_type(p)) {
- case mp_fill_code:
- tf = (mp_fill_object *)mp_new_graphic_object(mp, mp_fill_code);
- gr_pre_script(tf) = mp_xstrdup(mp, gr_pre_script((mp_fill_object *)p));
- gr_post_script(tf) = mp_xstrdup(mp, gr_post_script((mp_fill_object *)p));
- gr_path_p(tf) = mp_gr_copy_path(mp,gr_path_p((mp_fill_object *)p));
- gr_htap_p(tf) = mp_gr_copy_path(mp,gr_htap_p(p));
- gr_pen_p(tf) = mp_gr_copy_path(mp,gr_pen_p((mp_fill_object *)p));
- q = (mp_graphic_object *)tf;
- break;
- case mp_stroked_code:
- ts = (mp_stroked_object *)mp_new_graphic_object(mp, mp_stroked_code);
- gr_pre_script(ts) = mp_xstrdup(mp, gr_pre_script((mp_stroked_object *)p));
- gr_post_script(ts) = mp_xstrdup(mp, gr_post_script((mp_stroked_object *)p));
- gr_path_p(ts) = mp_gr_copy_path(mp,gr_path_p((mp_stroked_object *)p));
- gr_pen_p(ts) = mp_gr_copy_path(mp,gr_pen_p((mp_stroked_object *)p));
- gr_dash_p(ts) = mp_gr_copy_dashes(mp,gr_dash_p(p));
- q = (mp_graphic_object *)ts;
- break;
- case mp_text_code:
- tt = (mp_text_object *)mp_new_graphic_object(mp, mp_text_code);
- gr_pre_script(tt) = mp_xstrdup(mp, gr_pre_script((mp_text_object *)p));
- gr_post_script(tt) = mp_xstrdup(mp, gr_post_script((mp_text_object *)p));
- gr_text_p(tt) = mp_xstrdup(mp, gr_text_p(p));
- gr_font_name(tt) = mp_xstrdup(mp, gr_font_name(p));
- q = (mp_graphic_object *)tt;
- break;
- case mp_start_clip_code:
- tc = (mp_clip_object *)mp_new_graphic_object(mp, mp_start_clip_code);
- gr_path_p(tc) = mp_gr_copy_path(mp,gr_path_p((mp_clip_object *)p));
- q = (mp_graphic_object *)tc;
- break;
- case mp_start_bounds_code:
- tb = (mp_bounds_object *)mp_new_graphic_object(mp, mp_start_bounds_code);
- gr_path_p(tb) = mp_gr_copy_path(mp,gr_path_p((mp_bounds_object *)p));
- q = (mp_graphic_object *)tb;
- break;
- case mp_special_code:
- tp = (mp_special_object *)mp_new_graphic_object(mp, mp_special_code);
- gr_pre_script(tp) = mp_xstrdup(mp, gr_pre_script((mp_special_object *)p));
- q = (mp_graphic_object *)tp;
- break;
- case mp_stop_clip_code:
- q = mp_new_graphic_object(mp, mp_stop_clip_code);
- break;
- case mp_stop_bounds_code:
- q = mp_new_graphic_object(mp, mp_stop_bounds_code);
- break;
- } /* all cases are enumerated */
- return q;
-}
-
diff --git a/Build/source/texk/web2c/luatexdir/lua/texluac.c b/Build/source/texk/web2c/luatexdir/lua/texluac.c
index 4bc13458d13..d4295aba6ae 100644
--- a/Build/source/texk/web2c/luatexdir/lua/texluac.c
+++ b/Build/source/texk/web2c/luatexdir/lua/texluac.c
@@ -1,7 +1,29 @@
-/*
-** $Id: texluac.c 1013 2008-02-14 00:09:02Z oneiros $
-** Lua compiler (saves bytecodes to files; also list bytecodes)
-** See Copyright Notice in lua.h
+/* texlua.c
+
+* Copyright (C) 1994-2007 Lua.org, PUC-Rio. All rights reserved.
+*
+* Permission is hereby granted, free of charge, to any person obtaining
+* a copy of this software and associated documentation files (the
+* "Software"), to deal in the Software without restriction, including
+* without limitation the rights to use, copy, modify, merge, publish,
+* distribute, sublicense, and/or sell copies of the Software, and to
+* permit persons to whom the Software is furnished to do so, subject to
+* the following conditions:
+*
+* The above copyright notice and this permission notice shall be
+* included in all copies or substantial portions of the Software.
+*
+* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
+* EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
+* MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT.
+* IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY
+* CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT,
+* TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE
+* SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
+
+ Copyright 2006-2008 Taco Hoekwater <taco@luatex.org>
+
+ This file is part of LuaTeX.
*/
#include <errno.h>
@@ -23,177 +45,185 @@
#include <../lua51/lstring.h>
#include <../lua51/lundump.h>
-#define PROGNAME "texluac" /* default program name */
-#define OUTPUT PROGNAME ".out" /* default output file */
+static const char _svn_version[] =
+ "$Id: texluac.c 1226 2008-05-02 16:11:02Z oneiros $ $URL: http://scm.foundry.supelec.fr/svn/luatex/trunk/src/texk/web2c/luatexdir/lua/texluac.c $";
-static int dumping=1; /* dump bytecodes? */
-static int stripping=0; /* strip debug information? */
-static char Output[]={ OUTPUT }; /* default output file name */
-static const char* output=Output; /* actual output file name */
-static const char* progname=PROGNAME; /* actual program name */
+#define PROGNAME "texluac" /* default program name */
+#define OUTPUT PROGNAME ".out" /* default output file */
-static void fatal(const char* message)
+static int dumping = 1; /* dump bytecodes? */
+static int stripping = 0; /* strip debug information? */
+static char Output[] = { OUTPUT }; /* default output file name */
+static const char *output = Output; /* actual output file name */
+static const char *progname = PROGNAME; /* actual program name */
+
+static void fatal(const char *message)
{
- fprintf(stderr,"%s: %s\n",progname,message);
- exit(EXIT_FAILURE);
+ fprintf(stderr, "%s: %s\n", progname, message);
+ exit(EXIT_FAILURE);
}
-static void cannot(const char* what)
+static void cannot(const char *what)
{
- fprintf(stderr,"%s: cannot %s %s: %s\n",progname,what,output,strerror(errno));
- exit(EXIT_FAILURE);
+ fprintf(stderr, "%s: cannot %s %s: %s\n", progname, what, output,
+ strerror(errno));
+ exit(EXIT_FAILURE);
}
-static void usage(const char* message)
+static void usage(const char *message)
{
- if (*message=='-')
- fprintf(stderr,"%s: unrecognized option " LUA_QS "\n",progname,message);
- else
- fprintf(stderr,"%s: %s\n",progname,message);
- fprintf(stderr,
- "usage: %s [options] [filenames].\n"
- "Available options are:\n"
- " - process stdin\n"
- " -o name output to file " LUA_QL("name") " (default is \"%s\")\n"
- " -p parse only\n"
- " -s strip debug information\n"
- " -v show version information\n"
- " -- stop handling options\n",
- progname,Output);
- exit(EXIT_FAILURE);
+ if (*message == '-')
+ fprintf(stderr, "%s: unrecognized option " LUA_QS "\n", progname,
+ message);
+ else
+ fprintf(stderr, "%s: %s\n", progname, message);
+ fprintf(stderr,
+ "usage: %s [options] [filenames].\n"
+ "Available options are:\n"
+ " - process stdin\n"
+ " -o name output to file " LUA_QL("name") " (default is \"%s\")\n"
+ " -p parse only\n"
+ " -s strip debug information\n"
+ " -v show version information\n"
+ " -- stop handling options\n", progname, Output);
+ exit(EXIT_FAILURE);
}
-#define IS(s) (strcmp(argv[i],s)==0)
+#define IS(s) (strcmp(argv[i],s)==0)
-static int doargs(int argc, char* argv[])
+static int doargs(int argc, char *argv[])
{
- int i;
- int version=0;
- if (argv[0]!=NULL && *argv[0]!=0) progname=argv[0];
- for (i=1; i<argc; i++)
- {
- if (*argv[i]!='-') /* end of options; keep it */
- break;
- else if (IS("--")) /* end of options; skip it */
- {
- ++i;
- if (version) ++version;
- break;
- }
- else if (IS("-")) /* end of options; use stdin */
- break;
- else if (IS("-o")) /* output file */
- {
- output=argv[++i];
- if (output==NULL || *output==0) usage(LUA_QL("-o") " needs argument");
- if (IS("-")) output=NULL;
- }
- else if (IS("-p")) /* parse only */
- dumping=0;
- else if (IS("-s")) /* strip debug information */
- stripping=1;
- else if (IS("-v")) /* show version */
- ++version;
- else if (IS("--luaconly")) /* ignore */
- ;
- else if (IS("--luac")) /* ignore */
- ;
- else /* unknown option */
- usage(argv[i]);
- }
- if (i==argc && (!dumping))
- {
- dumping=0;
- argv[--i]=Output;
- }
- if (version)
- {
- printf("%s %s\n",LUA_RELEASE,LUA_COPYRIGHT);
- if (version==argc-1) exit(EXIT_SUCCESS);
- }
- return i;
+ int i;
+ int version = 0;
+ if (argv[0] != NULL && *argv[0] != 0)
+ progname = argv[0];
+ for (i = 1; i < argc; i++) {
+ if (*argv[i] != '-') /* end of options; keep it */
+ break;
+ else if (IS("--")) { /* end of options; skip it */
+ ++i;
+ if (version)
+ ++version;
+ break;
+ } else if (IS("-")) /* end of options; use stdin */
+ break;
+ else if (IS("-o")) { /* output file */
+ output = argv[++i];
+ if (output == NULL || *output == 0)
+ usage(LUA_QL("-o") " needs argument");
+ if (IS("-"))
+ output = NULL;
+ } else if (IS("-p")) /* parse only */
+ dumping = 0;
+ else if (IS("-s")) /* strip debug information */
+ stripping = 1;
+ else if (IS("-v")) /* show version */
+ ++version;
+ else if (IS("--luaconly")) /* ignore */
+ ;
+ else if (IS("--luac")) /* ignore */
+ ;
+ else /* unknown option */
+ usage(argv[i]);
+ }
+ if (i == argc && (!dumping)) {
+ dumping = 0;
+ argv[--i] = Output;
+ }
+ if (version) {
+ printf("%s %s\n", LUA_RELEASE, LUA_COPYRIGHT);
+ if (version == argc - 1)
+ exit(EXIT_SUCCESS);
+ }
+ return i;
}
#define toproto(L,i) (clvalue(L->top+(i))->l.p)
-static const Proto* combine(lua_State* L, int n)
+static const Proto *combine(lua_State * L, int n)
{
- if (n==1)
- return toproto(L,-1);
- else
- {
- int i,pc;
- Proto* f=luaF_newproto(L);
- setptvalue2s(L,L->top,f); incr_top(L);
- f->source=luaS_newliteral(L,"=(" PROGNAME ")");
- f->maxstacksize=1;
- pc=2*n+1;
- f->code=luaM_newvector(L,pc,Instruction);
- f->sizecode=pc;
- f->p=luaM_newvector(L,n,Proto*);
- f->sizep=n;
- pc=0;
- for (i=0; i<n; i++)
- {
- f->p[i]=toproto(L,i-n-1);
- f->code[pc++]=CREATE_ABx(OP_CLOSURE,0,i);
- f->code[pc++]=CREATE_ABC(OP_CALL,0,1,1);
- }
- f->code[pc++]=CREATE_ABC(OP_RETURN,0,1,0);
- return f;
- }
+ if (n == 1)
+ return toproto(L, -1);
+ else {
+ int i, pc;
+ Proto *f = luaF_newproto(L);
+ setptvalue2s(L, L->top, f);
+ incr_top(L);
+ f->source = luaS_newliteral(L, "=(" PROGNAME ")");
+ f->maxstacksize = 1;
+ pc = 2 * n + 1;
+ f->code = luaM_newvector(L, pc, Instruction);
+ f->sizecode = pc;
+ f->p = luaM_newvector(L, n, Proto *);
+ f->sizep = n;
+ pc = 0;
+ for (i = 0; i < n; i++) {
+ f->p[i] = toproto(L, i - n - 1);
+ f->code[pc++] = CREATE_ABx(OP_CLOSURE, 0, i);
+ f->code[pc++] = CREATE_ABC(OP_CALL, 0, 1, 1);
+ }
+ f->code[pc++] = CREATE_ABC(OP_RETURN, 0, 1, 0);
+ return f;
+ }
}
-static int writer(lua_State* L, const void* p, size_t size, void* u)
+static int writer(lua_State * L, const void *p, size_t size, void *u)
{
- UNUSED(L);
- return (fwrite(p,size,1,(FILE*)u)!=1) && (size!=0);
+ UNUSED(L);
+ return (fwrite(p, size, 1, (FILE *) u) != 1) && (size != 0);
}
struct Smain {
- int argc;
- char** argv;
+ int argc;
+ char **argv;
};
-static int pmain(lua_State* L)
+static int pmain(lua_State * L)
{
- struct Smain* s = (struct Smain*)lua_touserdata(L, 1);
- int argc=s->argc;
- char** argv=s->argv;
- const Proto* f;
- int i;
- if (!lua_checkstack(L,argc)) fatal("too many input files");
- for (i=0; i<argc; i++)
- {
- const char* filename=IS("-") ? NULL : argv[i];
- if (luaL_loadfile(L,filename)!=0) fatal(lua_tostring(L,-1));
- }
- f=combine(L,argc);
- if (dumping)
- {
- FILE* D= (output==NULL) ? stdout : fopen(output,"wb");
- if (D==NULL) cannot("open");
- lua_lock(L);
- luaU_dump(L,f,writer,D,stripping);
- lua_unlock(L);
- if (ferror(D)) cannot("write");
- if (fclose(D)) cannot("close");
- }
- return 0;
+ struct Smain *s = (struct Smain *) lua_touserdata(L, 1);
+ int argc = s->argc;
+ char **argv = s->argv;
+ const Proto *f;
+ int i;
+ if (!lua_checkstack(L, argc))
+ fatal("too many input files");
+ for (i = 0; i < argc; i++) {
+ const char *filename = IS("-") ? NULL : argv[i];
+ if (luaL_loadfile(L, filename) != 0)
+ fatal(lua_tostring(L, -1));
+ }
+ f = combine(L, argc);
+ if (dumping) {
+ FILE *D = (output == NULL) ? stdout : fopen(output, "wb");
+ if (D == NULL)
+ cannot("open");
+ lua_lock(L);
+ luaU_dump(L, f, writer, D, stripping);
+ lua_unlock(L);
+ if (ferror(D))
+ cannot("write");
+ if (fclose(D))
+ cannot("close");
+ }
+ return 0;
}
-int luac_main(int argc, char* argv[])
+int luac_main(int argc, char *argv[])
{
- lua_State* L;
- struct Smain s;
- int i=doargs(argc,argv);
- argc-=i; argv+=i;
- if (argc<=0) usage("no input files given");
- L=lua_open();
- if (L==NULL) fatal("not enough memory for state");
- s.argc=argc;
- s.argv=argv;
- if (lua_cpcall(L,pmain,&s)!=0) fatal(lua_tostring(L,-1));
- lua_close(L);
- return EXIT_SUCCESS;
+ lua_State *L;
+ struct Smain s;
+ int i = doargs(argc, argv);
+ argc -= i;
+ argv += i;
+ if (argc <= 0)
+ usage("no input files given");
+ L = lua_open();
+ if (L == NULL)
+ fatal("not enough memory for state");
+ s.argc = argc;
+ s.argv = argv;
+ if (lua_cpcall(L, pmain, &s) != 0)
+ fatal(lua_tostring(L, -1));
+ lua_close(L);
+ return EXIT_SUCCESS;
}