diff options
Diffstat (limited to 'Build/source/texk/web2c/luatexdir/ocp')
-rw-r--r-- | Build/source/texk/web2c/luatexdir/ocp/ocp.h | 52 | ||||
-rw-r--r-- | Build/source/texk/web2c/luatexdir/ocp/ocp.w | 201 | ||||
-rw-r--r-- | Build/source/texk/web2c/luatexdir/ocp/ocplist.h | 91 | ||||
-rw-r--r-- | Build/source/texk/web2c/luatexdir/ocp/ocplist.w | 357 | ||||
-rw-r--r-- | Build/source/texk/web2c/luatexdir/ocp/readocp.h | 61 | ||||
-rw-r--r-- | Build/source/texk/web2c/luatexdir/ocp/readocp.w | 273 | ||||
-rw-r--r-- | Build/source/texk/web2c/luatexdir/ocp/runocp.h | 60 | ||||
-rw-r--r-- | Build/source/texk/web2c/luatexdir/ocp/runocp.w | 1069 |
8 files changed, 2164 insertions, 0 deletions
diff --git a/Build/source/texk/web2c/luatexdir/ocp/ocp.h b/Build/source/texk/web2c/luatexdir/ocp/ocp.h new file mode 100644 index 00000000000..3bdaab0e8c8 --- /dev/null +++ b/Build/source/texk/web2c/luatexdir/ocp/ocp.h @@ -0,0 +1,52 @@ +/* ocp.h + + Copyright 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/>. */ + +/* $Id: ocp.h 3261 2009-12-18 11:38:21Z taco $ */ + +#ifndef OCP_H + +# define OCP_H 1 + +typedef int internal_ocp_number; +typedef int ocp_index; + +extern int **ocp_tables; + +extern int ocp_maxint; + +extern internal_ocp_number ocp_ptr; /* largest internal ocp number in use */ + +/* smallest internal ocp number; must not be less than |min_quarterword| */ +# define ocp_base 0 +# define number_ocps 32768 + +# define null_ocp ocp_base + +extern void new_ocp(small_number a); + +# define ocp_trace_level equiv(ocp_trace_level_base) + +extern void allocate_ocp_table(int ocp_number, int ocp_size); + +extern void dump_ocp_info(void); +extern void undump_ocp_info(void); +extern void scan_ocp_ident(void); + + +#endif diff --git a/Build/source/texk/web2c/luatexdir/ocp/ocp.w b/Build/source/texk/web2c/luatexdir/ocp/ocp.w new file mode 100644 index 00000000000..60afca0f4c6 --- /dev/null +++ b/Build/source/texk/web2c/luatexdir/ocp/ocp.w @@ -0,0 +1,201 @@ +% ocp.w +% +% Copyright 2009-2010 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/>. + +@ @c +#include "ptexlib.h" + +static const char _svn_version[] = + "$Id: ocp.w 3584 2010-04-02 17:45:55Z hhenkel $ " +"$URL: http://foundry.supelec.fr/svn/luatex/tags/beta-0.60.0/source/texk/web2c/luatexdir/ocp/ocp.w $"; + +@ @c +int **ocp_tables; + +static int ocp_entries = 0; +int ocp_maxint = 10000000; + +@ When the user defines \.{\\ocp\\f}, say, \TeX\ assigns an internal number +to the user's ocp~\.{\\f}. Adding this number to |ocp_id_base| gives the +|eqtb| location of a ``frozen'' control sequence that will always select +the ocp. + +@c +internal_ocp_number ocp_ptr; /* largest internal ocp number in use */ + +void new_ocp(small_number a) +{ + pointer u; /* user's ocp identifier */ + internal_ocp_number f; /* runs through existing ocps */ + str_number t; /* name for the frozen ocp identifier */ + boolean external_ocp = false; /* external binary file */ + if (job_name == 0) + open_log_file(); + /* avoid confusing \.{texput} with the ocp name */ + if (cur_chr == 1) + external_ocp = true; + get_r_token(); + u = cur_cs; + if (u >= hash_base) + t = cs_text(u); + else + t = maketexstring("OCP"); + define(u, set_ocp_cmd, null_ocp); + scan_optional_equals(); + scan_file_name(); + /* If this ocp has already been loaded, set |f| to the internal + ocp number and |goto common_ending| */ + /* When the user gives a new identifier to a ocp that was previously loaded, + the new name becomes the ocp identifier of record. OCP names `\.{xyz}' and + `\.{XYZ}' are considered to be different. + */ + for (f = ocp_base + 1; f <= ocp_ptr; f++) { + if (str_eq_str(ocp_name(f), cur_name) + && str_eq_str(ocp_area(f), cur_area)) { + flush_str(cur_name); + flush_str(cur_area); + cur_name = ocp_name(f); + cur_area = ocp_area(f); + goto COMMON_ENDING; + } + } + { + char *nam = makecstring(cur_name); + char *are = makecstring(cur_area); + char *ext = makecstring(cur_ext); + f = read_ocp_info(u, nam, are, ext, external_ocp); + free(nam); + free(are); + free(ext); + } + COMMON_ENDING: + equiv(u) = f; + eqtb[ocp_id_base + f] = eqtb[u]; + cs_text(ocp_id_base + f) = t; + if (ocp_trace_level == 1) { + tprint_nl(""); + tprint_esc("ocp"); + print_esc(t); + tprint("="); + print(cur_name); + } +} + +@ Before we forget about the format of these tables, let's deal with +$\Omega$'s basic scanning routine related to ocp information. + +@c +void scan_ocp_ident(void) +{ + internal_ocp_number f; + do { + get_x_token(); + } while (cur_cmd == spacer_cmd); + + if (cur_cmd == set_ocp_cmd) { + f = cur_chr; + } else { + const char *hlp[] = { "I was looking for a control sequence whose", + "current meaning has been defined by \\ocp.", + NULL + }; + back_input(); + tex_error("Missing ocp identifier", hlp); + f = null_ocp; + } + cur_val = f; +} + +void allocate_ocp_table(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; + } + ocp_tables[ocp_number] = + (int *) xmalloc((unsigned) ((1 + (unsigned) ocp_size) * sizeof(int))); + ocp_tables[ocp_number][0] = ocp_size; + for (i = 1; i <= ocp_size; i++) { + ocp_tables[ocp_number][i] = 0; + } +} + +@ @c +static void dump_ocp_table(int ocp_number) +{ + dump_things(ocp_tables[ocp_number][0], ocp_tables[ocp_number][0] + 1); +} + +void dump_ocp_info(void) +{ + int k; + dump_int(123456); + dump_int(ocp_ptr); + for (k = null_ocp; k <= ocp_ptr; k++) { + dump_ocp_table(k); + if (ocp_ptr - ocp_base > 0) { + tprint_nl("\\ocp"); + print_esc(cs_text(ocp_id_base + k)); + print_char('='); + print_file_name(ocp_name(k), ocp_area(k), get_nullstr()); + } + } + dump_int(123456); + if (ocp_ptr - ocp_base > 0) { + print_ln(); + print_int(ocp_ptr - ocp_base); + tprint(" preloaded ocp"); + if (ocp_ptr != ocp_base + 1) + print_char('s'); + } +} + +static void undump_ocp_table(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; + } + undump_things(sizeword, 1); + ocp_tables[ocp_number] = + (int *) xmalloc((unsigned) ((1 + (unsigned) sizeword) * sizeof(int))); + ocp_tables[ocp_number][0] = sizeword; + undump_things(ocp_tables[ocp_number][1], sizeword); +} + + +void undump_ocp_info(void) +{ + int k; + int x; + undump_int(x); + assert(x == 123456); + undump_int(ocp_ptr); + for (k = null_ocp; k <= ocp_ptr; k++) + undump_ocp_table(k); + undump_int(x); + assert(x == 123456); +} diff --git a/Build/source/texk/web2c/luatexdir/ocp/ocplist.h b/Build/source/texk/web2c/luatexdir/ocp/ocplist.h new file mode 100644 index 00000000000..f94f29adf03 --- /dev/null +++ b/Build/source/texk/web2c/luatexdir/ocp/ocplist.h @@ -0,0 +1,91 @@ +/* ocplist.h + + Copyright 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/>. */ + +/* $Id: ocplist.h 3302 2009-12-25 12:49:14Z oneiros $ */ + +#ifndef OCPLIST_H + +# define OCPLIST_H 1 + +# define ocp_list_base 0 /* smallest internal ocp list number; must not be less + than |min_quarterword| */ +# define number_ocp_lists 32768 +# define null_ocp_list ocp_list_base + +typedef int internal_ocp_list_number; +typedef int ocp_list_index; /* index into |ocp_list_info| */ +typedef int ocp_lstack_index; /* index into |ocp_lstack_info| */ + +extern memory_word *ocp_list_info; +extern memory_word *ocp_lstack_info; +extern internal_ocp_list_number ocp_list_ptr; +extern ocp_list_index *ocp_list_list; + +# define ocp_list_lnext(A) ocp_list_info[(A)].hh.u.B0 +# define ocp_list_lstack(A) ocp_list_info[(A)].hh.u.B1 +# define ocp_list_lstack_no(A) ocp_list_info[(A)+1].cint +# define ocp_lstack_lnext(A) ocp_lstack_info[(A)].hh.u.B0 +# define ocp_lstack_ocp(A) ocp_lstack_info[(A)].hh.u.B1 +# define make_null_ocp_list() make_ocp_list_node(0,ocp_maxint,0) +# define is_null_ocp_list(A) (ocp_list_lstack_no(A)==ocp_maxint) + +# define make_null_ocp_lstack() 0 +# define is_null_ocp_lstack(A) ((A)==0) + +typedef enum { + add_before_op = 1, + add_after_op, + remove_before_op, + remove_after_op +} ocplist_ops; + + +extern void initialize_init_ocplists(void); +extern void initialize_ocplist_arrays(int ocp_list_size); + +extern ocp_list_index make_ocp_list_node(ocp_lstack_index llstack, + scaled llstack_no, + ocp_list_index llnext); + +extern ocp_lstack_index make_ocp_lstack_node(internal_ocp_number locp, + ocp_lstack_index llnext); + +extern ocp_lstack_index copy_ocp_lstack(ocp_lstack_index llstack); + +extern ocp_list_index copy_ocp_list(ocp_list_index list); + +extern ocp_list_index ocp_ensure_lstack(ocp_list_index list, scaled llstack_no); + +extern void ocp_apply_add(ocp_list_index list_entry, + boolean lbefore, internal_ocp_number locp); + +extern void ocp_apply_remove(ocp_list_index list_entry, boolean lbefore); + +extern void print_ocp_lstack(ocp_lstack_index lstack_entry); +extern void print_ocp_list(ocp_list_index list_entry); +extern ocp_list_index scan_ocp_list(void); +extern internal_ocp_list_number read_ocp_list(void); +extern void scan_ocp_list_ident(void); + +extern void new_ocp_list(small_number a); + +extern void dump_ocplist_info(void); +extern void undump_ocplist_info(void); + +#endif diff --git a/Build/source/texk/web2c/luatexdir/ocp/ocplist.w b/Build/source/texk/web2c/luatexdir/ocp/ocplist.w new file mode 100644 index 00000000000..533678fd699 --- /dev/null +++ b/Build/source/texk/web2c/luatexdir/ocp/ocplist.w @@ -0,0 +1,357 @@ +% ocplist.w +% +% Copyright 2009-2010 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/>. + +@ @c +#include "ptexlib.h" + +static const char _svn_version[] = + "$Id: ocplist.w 3584 2010-04-02 17:45:55Z hhenkel $ " +"$URL: http://foundry.supelec.fr/svn/luatex/tags/beta-0.60.0/source/texk/web2c/luatexdir/ocp/ocplist.w $"; + +@ @c +memory_word *ocp_list_info; /* the big collection of ocp list data */ +ocp_list_index ocp_listmem_ptr; /* first unused word of |ocp_list_info| */ +ocp_list_index ocp_listmem_run_ptr; /* temp unused word of |ocp_list_info| */ +memory_word *ocp_lstack_info; /* the big collection of ocp lstack data */ +ocp_lstack_index ocp_lstackmem_ptr; /* first unused word of |ocp_lstack_info| */ +ocp_lstack_index ocp_lstackmem_run_ptr; /* temp unused word of |ocp_lstack_info| */ +internal_ocp_list_number ocp_list_ptr; /* largest internal ocp list number in use */ +ocp_list_index *ocp_list_list; + +#define ocp_list_id_text(A) cs_text(ocp_list_id_base+(A)) + +void initialize_init_ocplists(void) +{ + ocp_listmem_ptr = 2; + ocp_list_lstack(0) = 0; + ocp_list_lstack_no(0) = ocp_maxint; + ocp_list_lnext(0) = 0; + ocp_list_ptr = null_ocp_list; + ocp_list_list[null_ocp_list] = 0; + ocp_lstackmem_ptr = 1; +} + + +void initialize_ocplist_arrays(int ocp_list_size) +{ + ocp_list_info = xmallocarray(memory_word, (unsigned) ocp_list_size); + memset(ocp_list_info, 0, sizeof(memory_word) * (unsigned) ocp_list_size); + ocp_lstack_info = xmallocarray(memory_word, (unsigned) ocp_list_size); + memset(ocp_lstack_info, 0, sizeof(memory_word) * (unsigned) ocp_list_size); + ocp_list_list = xmallocarray(ocp_list_index, (unsigned) ocp_list_size); +} + + +@ @c +ocp_list_index make_ocp_list_node(ocp_lstack_index llstack, + scaled llstack_no, ocp_list_index llnext) +{ + ocp_list_index p; + p = ocp_listmem_run_ptr; + ocp_list_lstack(p) = (quarterword) llstack; + ocp_list_lstack_no(p) = llstack_no; + ocp_list_lnext(p) = (quarterword) llnext; + ocp_listmem_run_ptr = ocp_listmem_run_ptr + 2; + if (ocp_listmem_run_ptr >= ocp_list_size) + overflow("ocp_list_size", (unsigned) ocp_list_size); + return p; +} + +ocp_lstack_index make_ocp_lstack_node(internal_ocp_number locp, + ocp_lstack_index llnext) +{ + ocp_lstack_index p; + p = ocp_lstackmem_run_ptr; + ocp_lstack_ocp(p) = (quarterword) locp; + ocp_lstack_lnext(p) = (quarterword) llnext; + incr(ocp_lstackmem_run_ptr); + if (ocp_lstackmem_run_ptr >= ocp_stack_size) + overflow("ocp_stack_size", (unsigned) ocp_stack_size); + return p; +} + +ocp_lstack_index copy_ocp_lstack(ocp_lstack_index llstack) +{ + if (is_null_ocp_lstack(llstack)) + return make_null_ocp_lstack(); + else + return make_ocp_lstack_node(ocp_lstack_ocp(llstack), + copy_ocp_lstack(ocp_lstack_lnext(llstack))); +} + +ocp_list_index copy_ocp_list(ocp_list_index list) +{ + if (is_null_ocp_list(list)) + return make_null_ocp_list(); + else + return make_ocp_list_node(copy_ocp_lstack(ocp_list_lstack(list)), + ocp_list_lstack_no(list), + copy_ocp_list(ocp_list_lnext(list))); +} + +ocp_list_index ocp_ensure_lstack(ocp_list_index list, scaled llstack_no) +{ + ocp_list_index p; + ocp_list_index q; + p = list; + if (is_null_ocp_list(p)) { + ocp_list_lstack_no(p) = llstack_no; + ocp_list_lnext(p) = (quarterword) make_null_ocp_list(); + } else if (ocp_list_lstack_no(p) > llstack_no) { + ocp_list_lnext(p) = (quarterword) + make_ocp_list_node(ocp_list_lstack(p), + ocp_list_lstack_no(p), ocp_list_lnext(p)); + ocp_list_lstack(p) = 0; + ocp_list_lstack_no(p) = llstack_no; + } else { + q = ocp_list_lnext(p); + while ((!(is_null_ocp_list(q))) && ocp_list_lstack_no(q) <= llstack_no) { + p = q; + q = ocp_list_lnext(q); + } + if (ocp_list_lstack_no(p) < llstack_no) { + ocp_list_lnext(p) = + (quarterword) make_ocp_list_node(0, llstack_no, q); + p = ocp_list_lnext(p); + } + } + return p; +} + +void ocp_apply_add(ocp_list_index list_entry, + boolean lbefore, internal_ocp_number locp) +{ + ocp_lstack_index p; + ocp_lstack_index q; + p = ocp_list_lstack(list_entry); + if (lbefore || (p == 0)) { + ocp_list_lstack(list_entry) = + (quarterword) make_ocp_lstack_node(locp, p); + } else { + q = ocp_lstack_lnext(p); + while (q != 0) { + p = q; + q = ocp_lstack_lnext(q); + } + ocp_lstack_lnext(p) = (quarterword) make_ocp_lstack_node(locp, 0); + } +} + +void ocp_apply_remove(ocp_list_index list_entry, boolean lbefore) +{ + ocp_lstack_index p; + ocp_lstack_index q; + ocp_lstack_index r; + p = ocp_list_lstack(list_entry); + if (p == 0) { + print_err("warning: stack entry already empty"); + print_ln(); + } else { + q = ocp_lstack_lnext(p); + if (lbefore || (q == 0)) { + ocp_list_lstack(list_entry) = (quarterword) q; + } else { + r = ocp_lstack_lnext(q); + while (r != 0) { + p = q; + q = r; + r = ocp_lstack_lnext(r); + } + ocp_lstack_lnext(p) = 0; + } + } +} + + +void print_ocp_lstack(ocp_lstack_index lstack_entry) +{ + ocp_lstack_index p; + p = lstack_entry; + while (p != 0) { + print_esc(cs_text(ocp_id_base + ocp_lstack_ocp(p))); + p = ocp_lstack_lnext(p); + if (p != 0) + print_char(','); + } +} + +void print_ocp_list(ocp_list_index list_entry) +{ + ocp_list_index p; + print_char('['); + p = list_entry; + while (!(is_null_ocp_list(p))) { + print_char('('); + print_scaled(ocp_list_lstack_no(p)); + tprint(" : "); + print_ocp_lstack(ocp_list_lstack(p)); + print_char(')'); + p = ocp_list_lnext(p); + if (!(is_null_ocp_list(p))) + tprint(", "); + } + print_char(']'); +} + +@ @c +ocp_list_index scan_ocp_list(void) +{ + scaled llstack_no; + quarterword lop; + ocp_list_index lstack_entry; + ocp_list_index other_list; + internal_ocp_number ocp_ident = 0; + get_r_token(); + if (cur_cmd == set_ocp_list_cmd) { + return copy_ocp_list(ocp_list_list[cur_chr]); + } else if (cur_cmd != ocp_list_op_cmd) { + const char *hlp[] = + { "I was looking for a ocp list specification.", NULL }; + tex_error("Bad ocp list specification", hlp); + return make_null_ocp_list(); + } else { + lop = (quarterword) cur_chr; + scan_scaled(); + llstack_no = cur_val; + if ((llstack_no <= 0) || (llstack_no >= ocp_maxint)) { + tex_error("Stack numbers must be between 0 and 4096 (exclusive)", + NULL); + return make_null_ocp_list(); + } else { + if (lop <= add_after_op) { + scan_ocp_ident(); + ocp_ident = cur_val; + } + other_list = scan_ocp_list(); + lstack_entry = ocp_ensure_lstack(other_list, llstack_no); + if (lop <= add_after_op) { + ocp_apply_add(lstack_entry, (lop = add_before_op), ocp_ident); + } else { + ocp_apply_remove(lstack_entry, (lop = remove_before_op)); + } + return other_list; + } + } +} + +@ @c +internal_ocp_list_number read_ocp_list(void) +{ + internal_ocp_list_number f; + internal_ocp_list_number g; + g = null_ocp_list; + f = ocp_list_ptr + 1; + ocp_listmem_run_ptr = ocp_listmem_ptr; + ocp_lstackmem_run_ptr = ocp_lstackmem_ptr; + ocp_list_list[f] = scan_ocp_list(); + ocp_list_ptr = f; + ocp_listmem_ptr = ocp_listmem_run_ptr; + ocp_lstackmem_ptr = ocp_lstackmem_run_ptr; + g = f; + return g; +} + +@ @c +void scan_ocp_list_ident(void) +{ + internal_ocp_list_number f; + do { + get_x_token(); + } while (cur_cmd == spacer_cmd); + + if (cur_cmd == set_ocp_list_cmd) { + f = cur_chr; + } else { + const char *hlp[] = { "I was looking for a control sequence whose", + "current meaning has been defined by \\ocplist.", + NULL + }; + back_input(); + tex_error("Missing ocp list identifier", hlp); + f = null_ocp_list; + } + cur_val = f; +} + +@ @c +void new_ocp_list(small_number a) +{ + pointer u; /* user's ocp list identifier */ + internal_ocp_list_number f; /* runs through existing ocp lists */ + str_number t; /* name for the frozen ocp list identifier */ + if (job_name == 0) + open_log_file(); + /* avoid confusing \.{texput} with the ocp list name */ + get_r_token(); + u = cur_cs; + if (u >= hash_base) + t = cs_text(u); + else + t = maketexstring("OCPLIST"); + define(u, set_ocp_list_cmd, null_ocp_list); + scan_optional_equals(); + f = read_ocp_list(); + equiv(u) = f; + eqtb[ocp_list_id_base + f] = eqtb[u]; + cs_text(ocp_list_id_base + f) = t; + if (ocp_trace_level == 1) { + tprint_nl(""); + tprint_esc("ocplist"); + print_esc(t); + tprint("="); + print_ocp_list(ocp_list_list[f]); + } +} + +@ @c +void dump_ocplist_info(void) +{ + int k; + dump_int(ocp_listmem_ptr); + for (k = 0; k <= ocp_listmem_ptr - 1; k++) + dump_wd(ocp_list_info[k]); + dump_int(ocp_list_ptr); + for (k = null_ocp_list; k <= ocp_list_ptr; k++) { + dump_int(ocp_list_list[k]); + if (null_ocp_list != ocp_list_ptr) { + tprint_nl("\\ocplist"); + print_esc(ocp_list_id_text(k)); + print_char('='); + print_ocp_list(ocp_list_list[k]); + } + } + dump_int(ocp_lstackmem_ptr); + for (k = 0; k <= ocp_lstackmem_ptr - 1; k++) + dump_wd(ocp_lstack_info[k]); +} + +void undump_ocplist_info(void) +{ + int k; + initialize_ocplist_arrays(ocp_list_size); + undump_int(ocp_listmem_ptr); + for (k = 0; k <= ocp_listmem_ptr - 1; k++) + undump_wd(ocp_list_info[k]); + undump_int(ocp_list_ptr); + for (k = null_ocp_list; k <= ocp_list_ptr; k++) + undump_int(ocp_list_list[k]); + undump_int(ocp_lstackmem_ptr); + for (k = 0; k <= ocp_lstackmem_ptr - 1; k++) + undump_wd(ocp_lstack_info[k]); +} diff --git a/Build/source/texk/web2c/luatexdir/ocp/readocp.h b/Build/source/texk/web2c/luatexdir/ocp/readocp.h new file mode 100644 index 00000000000..f16f464270f --- /dev/null +++ b/Build/source/texk/web2c/luatexdir/ocp/readocp.h @@ -0,0 +1,61 @@ +/* readocp.h + + 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/>. */ + +/* $Id: readocp.h 3127 2009-11-11 10:14:11Z taco $ */ + +#ifndef READOCP_H + +# define READOCP_H 1 + +# define ocp_info(A,B) ocp_tables[(A)][(B)] + +typedef enum { + offset_ocp_file_size = 0, + offset_ocp_name, + offset_ocp_area, + offset_ocp_external, + offset_ocp_external_arg, + offset_ocp_input, + offset_ocp_output, + offset_ocp_no_tables, + offset_ocp_no_states, + offset_ocp_table_base, + offset_ocp_state_base, + offset_ocp_info /* 11 */ +} ocp_offsets; + +# define ocp_file_size(A) ocp_info(A,offset_ocp_file_size) +# define ocp_name(A) ocp_info(A,offset_ocp_name) +# define ocp_area(A) ocp_info(A,offset_ocp_area) +# define ocp_external(A) ocp_info(A,offset_ocp_external) +# define ocp_external_arg(A) ocp_info(A,offset_ocp_external_arg) +# define ocp_input(A) ocp_info(A,offset_ocp_input) +# define ocp_output(A) ocp_info(A,offset_ocp_output) +# define ocp_no_tables(A) ocp_info(A,offset_ocp_no_tables) +# define ocp_no_states(A) ocp_info(A,offset_ocp_no_states) +# define ocp_table_base(A) ocp_info(A,offset_ocp_table_base) +# define ocp_state_base(A) ocp_info(A,offset_ocp_state_base) + +extern internal_ocp_number read_ocp_info(pointer u, char *nom, + char *aire, char *ext, + boolean external_ocp); + +extern void init_null_ocp(str_number a, str_number n); + +#endif diff --git a/Build/source/texk/web2c/luatexdir/ocp/readocp.w b/Build/source/texk/web2c/luatexdir/ocp/readocp.w new file mode 100644 index 00000000000..7beee600347 --- /dev/null +++ b/Build/source/texk/web2c/luatexdir/ocp/readocp.w @@ -0,0 +1,273 @@ +% readocp.w +% +% Copyright 2009-2010 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/>. + +@ @c +#include "ptexlib.h" + +static const char _svn_version[] = + "$Id: readocp.w 3584 2010-04-02 17:45:55Z hhenkel $ " +"$URL: http://foundry.supelec.fr/svn/luatex/tags/beta-0.60.0/source/texk/web2c/luatexdir/ocp/readocp.w $"; + +@ @c +static char *b_test_in(char *nam) +{ + if (program_name_set) { + return (char *) kpse_find_file(nam, kpse_program_binary_format, true); + } + return NULL; +} + + +static unsigned char *ocp_buffer = NULL; /* byte buffer for ocp files */ +static int ocp_size = 0; /* total size of the ocp file */ +static int ocp_cur = 0; /* index into |ocp_buffer| */ + +@ @c +void init_null_ocp(str_number a, str_number n) +{ + ocp_ptr = null_ocp; + allocate_ocp_table(null_ocp, 17); + ocp_file_size(null_ocp) = 17; + ocp_name(null_ocp) = n; + ocp_area(null_ocp) = a; + ocp_external(null_ocp) = 0; + ocp_external_arg(null_ocp) = 0; + ocp_input(null_ocp) = 1; + ocp_output(null_ocp) = 1; + ocp_no_tables(null_ocp) = 0; + ocp_no_states(null_ocp) = 1; + ocp_table_base(f) = offset_ocp_info; + ocp_state_base(f) = offset_ocp_info; + ocp_info(null_ocp, offset_ocp_info) = offset_ocp_info + 2; /* number of entries */ + ocp_info(null_ocp, offset_ocp_info + 1) = offset_ocp_info + 5; /* number of entries */ + ocp_info(null_ocp, offset_ocp_info + 2) = 23; /* |OTP_LEFT_START| */ + ocp_info(null_ocp, offset_ocp_info + 3) = 3; /* |OTP_RIGHT_CHAR| */ + ocp_info(null_ocp, offset_ocp_info + 4) = 36; /* |OTP_STOP| */ +} + + + +@ $\Omega$ checks the information of a \.{OCP} file for validity as the +file is being read in, so that no further checks will be needed when +typesetting is going on. The somewhat tedious subroutine that does this +is called |read_ocp_info|. It has three parameters: the user ocp +identifier~|u|, and the file name and area strings |nom| and |aire|. + +The subroutine opens and closes a global file variable called |ocp_file|. +It returns the value of the internal ocp number that was just loaded. +If an error is detected, an error message is issued and no ocp +information is stored; |null_ocp| is returned in this case. + +@c +/* do this when the \.{OCP} data is wrong */ +#define ocp_abort(A) do { \ + tprint("OCP file error ("); \ + tprint(A); tprint(")"); print_ln(); \ + goto BAD_OCP; \ +} while (0) + +/* macros for reading and storing ocp data */ + +#define add_to_ocp_info(A) ocp_tables[f][ocpmem_run_ptr++]=(A) +#define ocp_read(A) do { \ + ocpword=ocp_buffer[ocp_cur++]; \ + if (ocpword>127) ocp_abort("checking first octet"); \ + ocpword=ocpword*0400+ocp_buffer[ocp_cur++]; \ + ocpword=ocpword*0400+ocp_buffer[ocp_cur++]; \ + ocpword=ocpword*0400+ocp_buffer[ocp_cur++]; \ + (A)=ocpword; \ + } while (0) + +#define ocp_read_all(A) ocp_read(A) +#define ocp_read_info do { ocp_read_all(ocpword); add_to_ocp_info(ocpword); } while (0) + + + +@ Input a \.{OCP} file + +@c +internal_ocp_number +read_ocp_info(pointer u, char *nom, char *aire, char *ext, boolean external_ocp) +{ + boolean file_opened; /* was |ocp_file| successfully opened? */ + boolean res; + int callback_id; + char *cnam; /* C version of file name */ + internal_ocp_number f; /* the new ocp's number */ + internal_ocp_number g; /* the number to return */ + int ocpword; + ocp_index ocpmem_run_ptr; + int ocp_length, real_ocp_length; /* length of ocp file */ + ocp_index previous_address; + int temp_ocp_input; + int temp_ocp_output; + int temp_ocp_no_tables; + int temp_ocp_no_states; + int i, new_offset, room_for_tables, room_for_states; + g = null_ocp; + f = null_ocp; + cnam = NULL; + file_opened = false; + if (external_ocp) { + /* Check |ocp_file| exists */ + cnam = + xmalloc((unsigned) (strlen(nom) + strlen(aire) + strlen(ext) + 1)); + sprintf(cnam, "%s%s%s", aire, nom, ext); + cnam = b_test_in(cnam); + if (!cnam) + ocp_abort("opening file"); + f = ocp_ptr + 1; + allocate_ocp_table(f, 13); + ocp_file_size(f) = 13; + ocp_external(f) = maketexstring(cnam); + scan_string_argument(); + ocp_external_arg(f) = cur_val; + ocp_name(f) = get_nullstr(); + ocp_area(f) = get_nullstr(); + ocp_state_base(f) = 0; + ocp_table_base(f) = 0; + ocp_input(f) = 1; + ocp_output(f) = 1; + ocp_info(f, offset_ocp_info) = 0; + ocp_ptr = f; + g = f; + goto DONE; + + } else { + /* Open |ocp_file| for input */ + char *cname = xmalloc((unsigned) + (strlen(nom) + strlen(aire) + strlen(".ocp") + + 1)); + sprintf(cname, "%s%s.ocp", aire, nom); + xfree(ocp_buffer); + ocp_cur = 0; + ocp_size = 0; + cnam = luatex_find_file(cname, find_ocp_file_callback); + callback_id = callback_defined(read_ocp_file_callback); + if (cnam && callback_id > 0) { + res = run_callback(callback_id, "S->bSd", cnam, + &file_opened, &ocp_buffer, &ocp_size); + if (!res) + ocp_abort("callback error"); + if (!file_opened) + ocp_abort("opening file"); + } else { + FILE *ocp_file = NULL; + if (!cnam) + cnam = cname; + if (!luatex_open_input + (&ocp_file, cnam, kpse_ocp_format, FOPEN_RBIN_MODE, true)) + ocp_abort("opening file"); + file_opened = true; + res = read_ocp_file(ocp_file, &ocp_buffer, &ocp_size); + close_file(ocp_file); + if (!res) + ocp_abort("reading file"); + } + if (ocp_size == 0) + ocp_abort("checking size"); + + /* Read the {\.{OCP}} file */ + f = ocp_ptr + 1; + ocpmem_run_ptr = offset_ocp_info; + ocp_read(ocp_length); + real_ocp_length = ocp_length - 7; + ocp_read_all(temp_ocp_input); + ocp_read_all(temp_ocp_output); + ocp_read_all(temp_ocp_no_tables); + ocp_read_all(room_for_tables); + ocp_read_all(temp_ocp_no_states); + ocp_read_all(room_for_states); + if (real_ocp_length != + (temp_ocp_no_tables + room_for_tables + + temp_ocp_no_states + room_for_states)) + ocp_abort("checking size"); + real_ocp_length = real_ocp_length + 12 + + temp_ocp_no_states + temp_ocp_no_tables; + allocate_ocp_table(f, real_ocp_length); + ocp_external(f) = 0; + ocp_external_arg(f) = 0; + ocp_file_size(f) = real_ocp_length; + ocp_input(f) = temp_ocp_input; + ocp_output(f) = temp_ocp_output; + ocp_no_tables(f) = temp_ocp_no_tables; + ocp_no_states(f) = temp_ocp_no_states; + ocp_table_base(f) = ocpmem_run_ptr; + if (ocp_no_tables(f) != 0) { + previous_address = ocpmem_run_ptr + 2 * (ocp_no_tables(f)); + for (i = 1; i <= ocp_no_tables(f); i++) { + add_to_ocp_info(previous_address); + ocp_read_all(new_offset); + add_to_ocp_info(new_offset); + previous_address = previous_address + new_offset; + } + } + if (room_for_tables != 0) { + for (i = 1; i <= room_for_tables; i++) { + ocp_read_info; + } + } + ocp_state_base(f) = ocpmem_run_ptr; + if (ocp_no_states(f) != 0) { + previous_address = ocpmem_run_ptr + 2 * (ocp_no_states(f)); + for (i = 1; i <= ocp_no_states(f); i++) { + add_to_ocp_info(previous_address); + ocp_read_all(new_offset); + add_to_ocp_info(new_offset); + previous_address = previous_address + new_offset; + } + } + if (room_for_states != 0) { + for (i = 1; i <= room_for_states; i++) { + ocp_read_info; + } + } + ocp_ptr = f; + g = f; + goto DONE; + } + BAD_OCP: + { + /* Report that the ocp won't be loaded */ + /* $\Omega$ does not give precise details about why it + rejects a particular \.{OCP} file. */ + const char *hlp[] = { + "I wasn't able to read the data for this ocp,", + "so I will ignore the ocp specification.", + NULL + }; + char errmsg[256]; + char *c = makecstring(cs_text(u)); + if (file_opened) { + snprintf(errmsg, 255, + "Translation process \\%s=%s not loadable: Bad ocp file", + c, cnam); + } else { + snprintf(errmsg, 255, + "Translation process \\%s=%s not loadable: ocp file not found", + c, cnam); + } + free(c); + tex_error(errmsg, hlp); + } + DONE: + ocp_name(f) = maketexstring(nom); + ocp_area(f) = maketexstring(aire); + return g; +} diff --git a/Build/source/texk/web2c/luatexdir/ocp/runocp.h b/Build/source/texk/web2c/luatexdir/ocp/runocp.h new file mode 100644 index 00000000000..bf94918dc2e --- /dev/null +++ b/Build/source/texk/web2c/luatexdir/ocp/runocp.h @@ -0,0 +1,60 @@ +/* runocp.h + + 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/>. */ + +/* $Id: runocp.h 3302 2009-12-25 12:49:14Z oneiros $ */ + +#ifndef RUNOCP_H + +# define RUNOCP_H 1 + +# define active_mem_size 50000 /* number of words of |active_info| for active ocps */ + +typedef int active_index; + +extern memory_word active_info[(active_mem_size + 1)]; +extern active_index active_min_ptr; +extern active_index active_max_ptr; +extern active_index active_real; + +# define active_ocp(A) active_info[(A)].hh.u.B0 +# define active_counter(A) active_info[(A)].hh.u.B1 +# define active_lstack_no(A) active_info[(A)+1].cint + +extern boolean is_last_ocp(scaled llstack_no, int counter); + +extern void print_active_ocps(void); +extern void add_ocp_stack(int min_index, scaled min_value); +extern void active_compile(void); + +extern void run_ocp(void); +extern void run_otp(void); + +extern void do_push_ocp_list(small_number a); +extern void do_pop_ocp_list(small_number a); +extern void do_clear_ocp_lists(small_number a); + +extern void dump_active_ocp_info(void); +extern void undump_active_ocp_info(void); + +extern void initialize_ocp_buffers(int ocp_buf_size, int ocp_stack_size); + +/* for ocplist.h */ +/* typedef int ocp_list_index ; */ + +#endif diff --git a/Build/source/texk/web2c/luatexdir/ocp/runocp.w b/Build/source/texk/web2c/luatexdir/ocp/runocp.w new file mode 100644 index 00000000000..51d28c6ebc8 --- /dev/null +++ b/Build/source/texk/web2c/luatexdir/ocp/runocp.w @@ -0,0 +1,1069 @@ +% runocp.w +% +% 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/>. + +@ @c +#include "ptexlib.h" + + +static const char _svn_version[] = + "$Id: runocp.w 3584 2010-04-02 17:45:55Z hhenkel $ " +"$URL: http://foundry.supelec.fr/svn/luatex/tags/beta-0.60.0/source/texk/web2c/luatexdir/ocp/runocp.w $"; + +memory_word active_info[(active_mem_size + 1)]; +active_index active_min_ptr = 0; /* first unused word of |active_info| */ +active_index active_max_ptr = 0; /* last unused word of |active_info| */ +active_index active_real = 0; + +static ocp_list_index holding[(active_mem_size + 1)] = { 0 }; + +@ Here we do the main work required for reading and interpreting + $\Omega$ Compiled Translation Processes. + +@c +#define ocp_list_id_text(A) cs_text(ocp_list_id_base+(A)) + +#define ocp_active_min_ptr_base (ocp_active_number_base+1) +#define ocp_active_max_ptr_base (ocp_active_min_ptr_base+1) +#define ocp_active_base (ocp_active_max_ptr_base+1) + + +@ Here are all the instructions in our mini-assembler. + +@c +typedef enum { + otp_right_output = 1, + otp_right_num = 2, + otp_right_char = 3, + otp_right_lchar = 4, + otp_right_some = 5, + otp_pback_output = 6, + otp_pback_num = 7, + otp_pback_char = 8, + otp_pback_lchar = 9, + otp_pback_some = 10, + otp_add = 11, + otp_sub = 12, + otp_mult = 13, + otp_div = 14, + otp_mod = 15, + otp_lookup = 16, + otp_push_num = 17, + otp_push_char = 18, + otp_push_lchar = 19, + otp_state_change = 20, + otp_state_push = 21, + otp_state_pop = 22, + otp_left_start = 23, + otp_left_return = 24, + otp_left_backup = 25, + otp_goto = 26, + otp_goto_ne = 27, + otp_goto_eq = 28, + otp_goto_lt = 29, + otp_goto_le = 30, + otp_goto_gt = 31, + otp_goto_ge = 32, + otp_goto_no_advance = 33, + otp_goto_beg = 34, + otp_goto_end = 35, + otp_stop = 36 +} otp_command_codes; + +#define check_buffer() do { \ + if (last==buf_size-2) { \ + check_buffer_overflow(buf_size+4); \ + } \ + } while (0) + +@ Of course we want to define macros that suppress the detail of how ocp +information is actually packed, so that we don't have to write things like +$$\hbox{|ocp_info[k+ocp_info[j+ocp_state_base[i]]]|}$$ +too often. The \.{WEB} definitions here make |ocp_state_entry(i)(j)(k)| +(|ocp_table_entry(i)(j)(k)|) the |k|-th word in the |j|-th state (table) +of the |i|-th ocp. +@^inner loop@> + +@c +#define ocp_state_entry(A,B,C) ocp_tables[(A)][ocp_tables[(A)][ocp_state_base((A))+((B)*2)]+(C)] + +#define ocp_state_no(A,B) ocp_tables[(A)][ocp_state_base(A)+((B)*2)+1] + +#define ocp_table_entry(A,B,C) ocp_tables[(A)][ocp_tables[(A)][ocp_table_base((A))+(B)*2]+(C)] + +#define ocp_table_no(A,B) ocp_tables[(A)][ocp_table_base((A))+((B)*2)+1] + +#define otp_cur_state otp_states[otp_state_ptr] + +#define tsuccumb pdftex_fail + +halfword otp_init_input_start; +halfword otp_init_input_last; +halfword otp_init_input_end; +quarterword *otp_init_input_buf; + +halfword otp_input_start; +halfword otp_input_last; +halfword otp_input_end; +quarterword *otp_input_buf; + +halfword otp_output_end; +quarterword *otp_output_buf; + +halfword otp_stack_used; +halfword otp_stack_last; +halfword otp_stack_new; +quarterword *otp_stack_buf; + +halfword otp_pc; + +halfword otp_calc_ptr; +halfword *otp_calcs; +halfword otp_state_ptr; +halfword *otp_states; + +halfword otp_input_char; +halfword otp_calculated_char; +halfword otp_no_input_chars; + +halfword otp_instruction; +halfword otp_instr; +halfword otp_arg; +halfword otp_first_arg; +halfword otp_second_arg; + +halfword otp_input_ocp; + +boolean otp_finished; +int otp_ext_str; +int otp_ext_str_arg; +int otp_ext_i; + +#define otp_set_instruction() do { \ + if (otp_pc>=ocp_state_no(otp_input_ocp,otp_cur_state)) { \ + tsuccumb("bad OCP program -- PC not valid"); \ + } \ + otp_instruction=ocp_state_entry(otp_input_ocp,otp_cur_state,otp_pc); \ + otp_instr=otp_instruction / 0x1000000; \ + otp_arg=otp_instruction % 0x1000000; \ + } while (0) + + +#define otp_check_char(A) do { \ + if ((1>(A)) || ((A)>otp_no_input_chars)) { \ + tsuccumb("right hand side of OCP expression is bad"); \ + } \ + } while (0) + + +#define otp_get_char(A) do { \ + otp_check_char((A)); \ + if ((A)>otp_stack_last) { \ + otp_calculated_char=otp_input_buf[otp_input_start+(A)-otp_stack_last]; \ + } else { \ + otp_calculated_char=otp_stack_buf[(A)]; \ + } \ + } while (0) + + +@ @c +void overflow_ocp_buf_size(void) +{ + overflow("ocp_buf_size", (unsigned) ocp_buf_size); +} + +void overflow_ocp_stack_size(void) +{ + overflow("ocp_stack_size", (unsigned) ocp_stack_size); +} + +void run_otp(void) +{ + halfword otp_counter; + otp_set_instruction(); + switch (otp_instr) { + /* Run the |otp_right| instructions */ + case otp_right_output: + incr(otp_output_end); + if (otp_output_end > ocp_buf_size) + overflow_ocp_buf_size(); + otp_output_buf[otp_output_end] = (quarterword) otp_calcs[otp_calc_ptr]; + decr(otp_calc_ptr); + incr(otp_pc); + break; + case otp_right_num: + incr(otp_output_end); + if (otp_output_end > ocp_buf_size) + overflow_ocp_buf_size(); + otp_output_buf[otp_output_end] = (quarterword) otp_arg; + incr(otp_pc); + break; + case otp_right_char: + otp_get_char(otp_arg); + incr(otp_output_end); + if (otp_output_end > ocp_buf_size) + overflow_ocp_buf_size(); + otp_output_buf[otp_output_end] = (quarterword) otp_calculated_char; + incr(otp_pc); + break; + case otp_right_lchar: + otp_get_char(otp_no_input_chars - otp_arg); + incr(otp_output_end); + if (otp_output_end > ocp_buf_size) + overflow_ocp_buf_size(); + otp_output_buf[otp_output_end] = (quarterword) otp_calculated_char; + incr(otp_pc); + break; + case otp_right_some: + otp_first_arg = otp_arg + 1; + incr(otp_pc); + otp_set_instruction(); + otp_second_arg = otp_no_input_chars - otp_arg; + for (otp_counter = otp_first_arg; otp_counter <= otp_second_arg; + otp_counter++) { + otp_get_char(otp_counter); + incr(otp_output_end); + if (otp_output_end > ocp_buf_size) + overflow_ocp_buf_size(); + otp_output_buf[otp_output_end] = (quarterword) otp_calculated_char; + } + incr(otp_pc); + break; + + /* Run the |otp_pback| instructions */ + case otp_pback_output: + incr(otp_stack_new); + if (otp_stack_new >= ocp_stack_size) + overflow_ocp_stack_size(); + otp_stack_buf[otp_stack_new] = (quarterword) otp_calcs[otp_calc_ptr]; + decr(otp_calc_ptr); + incr(otp_pc); + break; + case otp_pback_num: + incr(otp_stack_new); + if (otp_stack_new >= ocp_stack_size) + overflow_ocp_stack_size(); + otp_stack_buf[otp_stack_new] = (quarterword) otp_arg; + incr(otp_pc); + break; + case otp_pback_char: + otp_get_char(otp_arg); + incr(otp_stack_new); + if (otp_stack_new >= ocp_stack_size) + overflow_ocp_stack_size(); + otp_stack_buf[otp_stack_new] = (quarterword) otp_calculated_char; + incr(otp_pc); + break; + case otp_pback_lchar: + otp_get_char(otp_no_input_chars - otp_arg); + incr(otp_stack_new); + if (otp_stack_new >= ocp_stack_size) + overflow_ocp_stack_size(); + otp_stack_buf[otp_stack_new] = (quarterword) otp_calculated_char; + incr(otp_pc); + break; + case otp_pback_some: + otp_first_arg = otp_arg + 1; + incr(otp_pc); + otp_set_instruction(); + otp_second_arg = otp_no_input_chars - otp_arg; + for (otp_counter = otp_first_arg; otp_counter <= otp_second_arg; + otp_counter++) { + otp_get_char(otp_counter); + incr(otp_stack_new); + if (otp_stack_new >= ocp_stack_size) + overflow_ocp_stack_size(); + otp_stack_buf[otp_stack_new] = (quarterword) otp_calculated_char; + } + incr(otp_pc); + break; + + /* Run the arithmetic instructions */ + case otp_add: + otp_calcs[otp_calc_ptr - 1] = + otp_calcs[otp_calc_ptr - 1] + otp_calcs[otp_calc_ptr]; + incr(otp_pc); + decr(otp_calc_ptr); + break; + case otp_sub: + otp_calcs[otp_calc_ptr - 1] = + otp_calcs[otp_calc_ptr - 1] - otp_calcs[otp_calc_ptr]; + incr(otp_pc); + decr(otp_calc_ptr); + break; + case otp_mult: + otp_calcs[otp_calc_ptr - 1] = + otp_calcs[otp_calc_ptr - 1] * otp_calcs[otp_calc_ptr]; + incr(otp_pc); + decr(otp_calc_ptr); + break; + case otp_div: + otp_calcs[otp_calc_ptr - 1] = + otp_calcs[otp_calc_ptr - 1] / otp_calcs[otp_calc_ptr]; + incr(otp_pc); + decr(otp_calc_ptr); + break; + case otp_mod: + otp_calcs[otp_calc_ptr - 1] = + otp_calcs[otp_calc_ptr - 1] % otp_calcs[otp_calc_ptr]; + incr(otp_pc); + decr(otp_calc_ptr); + break; + case otp_lookup: + if (otp_calcs[otp_calc_ptr] >= + ocp_table_no(otp_input_ocp, otp_calcs[otp_calc_ptr - 1])) { + tsuccumb("bad OCP program -- table index not valid"); + } + otp_calcs[otp_calc_ptr - 1] = + ocp_table_entry(otp_input_ocp, otp_calcs[otp_calc_ptr - 1], + otp_calcs[otp_calc_ptr]); + incr(otp_pc); + decr(otp_calc_ptr); + break; + case otp_push_num: + incr(otp_calc_ptr); + if (otp_calc_ptr >= ocp_stack_size) + overflow_ocp_stack_size(); + otp_calcs[otp_calc_ptr] = otp_arg; + incr(otp_pc); + break; + case otp_push_char: + otp_get_char(otp_arg); + incr(otp_calc_ptr); + if (otp_calc_ptr >= ocp_stack_size) + overflow_ocp_stack_size(); + otp_calcs[otp_calc_ptr] = otp_calculated_char; + incr(otp_pc); + break; + case otp_push_lchar: + otp_get_char(otp_no_input_chars - otp_arg); + incr(otp_calc_ptr); + if (otp_calc_ptr >= ocp_stack_size) + overflow_ocp_stack_size(); + otp_calcs[otp_calc_ptr] = otp_calculated_char; + incr(otp_pc); + break; + + /* Run the |otp_state| instructions */ + case otp_state_change: + otp_input_start = otp_input_last; + for (otp_counter = 1; otp_counter <= (otp_stack_new - otp_stack_used); + otp_counter++) { + otp_stack_buf[otp_counter] = + otp_stack_buf[otp_counter + otp_stack_used]; + } + otp_stack_new = otp_stack_new - otp_stack_used; + otp_stack_last = otp_stack_new; + otp_stack_used = 0; + otp_states[otp_state_ptr] = otp_arg; + otp_pc = 0; + break; + case otp_state_push: + otp_input_start = otp_input_last; + for (otp_counter = 1; otp_counter <= (otp_stack_new - otp_stack_used); + otp_counter++) { + otp_stack_buf[otp_counter] = + otp_stack_buf[otp_counter + otp_stack_used]; + }; + otp_stack_new = otp_stack_new - otp_stack_used; + otp_stack_last = otp_stack_new; + otp_stack_used = 0; + incr(otp_state_ptr); + if (otp_state_ptr >= ocp_stack_size) + overflow_ocp_stack_size(); + otp_states[otp_state_ptr] = otp_arg; + otp_pc = 0; + break; + case otp_state_pop: + otp_input_start = otp_input_last; + for (otp_counter = 1; otp_counter <= (otp_stack_new - otp_stack_used); + otp_counter++) { + otp_stack_buf[otp_counter] = + otp_stack_buf[otp_counter + otp_stack_used]; + } + otp_stack_new = otp_stack_new - otp_stack_used; + otp_stack_last = otp_stack_new; + otp_stack_used = 0; + if (otp_state_ptr > 0) + decr(otp_state_ptr); + otp_pc = 0; + break; + + /* Run the |otp_left| instructions */ + case otp_left_start: + otp_input_start = otp_input_last; + otp_input_last = otp_input_start; + otp_stack_used = 0; + if ((otp_stack_last == 0) && (otp_input_last >= otp_input_end)) { + otp_finished = true; + } else if ((otp_stack_used < otp_stack_last)) { + incr(otp_stack_used); /* no overflow problem */ + otp_input_char = otp_stack_buf[otp_stack_used]; + otp_no_input_chars = 1; + incr(otp_pc); + } else { + incr(otp_input_last); /* no overflow problem */ + otp_input_char = otp_input_buf[otp_input_last]; + otp_no_input_chars = 1; + incr(otp_pc); + } + break; + case otp_left_return: + otp_input_last = otp_input_start; + otp_stack_used = 0; + if ((otp_stack_used < otp_stack_last)) { + incr(otp_stack_used); /* no overflow problem */ + otp_input_char = otp_stack_buf[otp_stack_used]; + otp_no_input_chars = 1; + incr(otp_pc); + } else { + incr(otp_input_last); /* no overflow problem */ + otp_input_char = otp_input_buf[otp_input_last]; + otp_no_input_chars = 1; + incr(otp_pc); + } + break; + case otp_left_backup: + if (otp_input_start < otp_input_last) { + decr(otp_input_last); + otp_input_char = otp_input_buf[otp_input_last]; + } else { + decr(otp_stack_used); + otp_input_char = otp_stack_buf[otp_stack_used]; + } + decr(otp_no_input_chars); + incr(otp_pc); + break; + + /* Run the |otp_goto| instructions */ + case otp_goto: + otp_pc = otp_arg; + break; + case otp_goto_ne: + otp_first_arg = otp_arg; + incr(otp_pc); + otp_set_instruction(); + if (otp_input_char != otp_first_arg) { + otp_pc = otp_arg; + } else { + incr(otp_pc); + } + break; + case otp_goto_eq: + otp_first_arg = otp_arg; + incr(otp_pc); + otp_set_instruction(); + if (otp_input_char == otp_first_arg) { + otp_pc = otp_arg; + } else { + incr(otp_pc); + } + break; + case otp_goto_lt: + otp_first_arg = otp_arg; + incr(otp_pc); + otp_set_instruction(); + if (otp_input_char < otp_first_arg) { + otp_pc = otp_arg; + } else { + incr(otp_pc); + } + break; + case otp_goto_le: + otp_first_arg = otp_arg; + incr(otp_pc); + otp_set_instruction(); + if (otp_input_char <= otp_first_arg) { + otp_pc = otp_arg; + } else { + incr(otp_pc); + } + break; + case otp_goto_gt: + otp_first_arg = otp_arg; + incr(otp_pc); + otp_set_instruction(); + if (otp_input_char > otp_first_arg) { + otp_pc = otp_arg; + } else { + incr(otp_pc); + } + break; + case otp_goto_ge: + otp_first_arg = otp_arg; + incr(otp_pc); + otp_set_instruction(); + if (otp_input_char >= otp_first_arg) { + otp_pc = otp_arg; + } else { + incr(otp_pc); + } + break; + case otp_goto_no_advance: + if (otp_stack_used < otp_stack_last) { + incr(otp_stack_used); /* no overflow problem */ + otp_input_char = otp_stack_buf[otp_stack_used]; + incr(otp_no_input_chars); /* no overflow problem */ + incr(otp_pc); + } else if (otp_input_last >= otp_input_end) { + otp_pc = otp_arg; + } else { + incr(otp_input_last); /* no overflow problem */ + otp_input_char = otp_input_buf[otp_input_last]; + incr(otp_no_input_chars); /* no overflow problem */ + incr(otp_pc); + } + break; + case otp_goto_beg: + if (otp_input_last == 0) { + otp_pc = otp_arg; + } else { + incr(otp_pc); + } + break; + case otp_goto_end: + if (otp_input_last >= otp_input_end) { + otp_pc = otp_arg; + } else { + incr(otp_pc); + } + break; + + /* Run the |otp_stop| instruction */ + case otp_stop: + otp_input_start = otp_input_last; + for (otp_counter = 1; otp_counter <= (otp_stack_new - otp_stack_used); + otp_counter++) { + otp_stack_buf[otp_counter] = + otp_stack_buf[otp_counter + otp_stack_used]; + } + otp_stack_new = otp_stack_new - otp_stack_used; + otp_stack_last = otp_stack_new; + otp_stack_used = 0; + otp_pc = 0; + break; + + default: + tsuccumb("bad OCP program -- unknown instruction"); + break; + } +} + +@ @c +#define FPUTC(a,b) fputc((int)(a),b) + +void run_external_ocp(char *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; +#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); + in_file = fopen(in_file_name, FOPEN_WBIN_MODE); +#else + int in_file_fd; + int out_file_fd; + 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 = fopen(out_file_name, FOPEN_RBIN_MODE); +#else + 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); + otp_output_end = 0; + otp_output_buf[otp_output_end] = 0; + while ((c_in = (int) fgetc(out_file)) != -1) { + if (c_in >= 0xfc) { + c = (unsigned) (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 = (unsigned) (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 = (unsigned) (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 = (unsigned) (c_in & 0xf) << 12; + advance_cin; + c |= (c_in & 0x3f) << 6; + advance_cin; + c |= (c_in & 0x3f); + } else if (c_in >= 0x80) { + c = (unsigned) (c_in & 0x1f) << 6; + advance_cin; + c |= (c_in & 0x3f); + } else { + c = (unsigned) (c_in & 0x7f); + } + otp_output_buf[++otp_output_end] = (quarterword) c; + } + fclose(out_file); + + end_of_while: + remove(in_file_name); + remove(out_file_name); +} + +@ @c +void run_ocp(void) +{ + int t = 0; + halfword otp_i; + halfword otp_counter; + /* The OTP input buffer is an array of 16-bit values. + The range |0xD800| \dots |0xDFFF| is used for surrogate pairs, + so it cannot be used for simple 16-bit values like it is in + Omega, and incompatibility with Aleph is unavoidable. + */ + + otp_init_input_end = 0; + while ((cur_cmd == letter_cmd) || (cur_cmd == other_char_cmd) || + (cur_cmd == char_given_cmd) || (cur_cmd == spacer_cmd)) { + incr(otp_init_input_end); + if (otp_init_input_end > ocp_buf_size) + overflow_ocp_buf_size(); + /* |cur_chr| can cover the full range |0..0x10FFFF| */ + if (cur_chr < 0x10000) { + otp_init_input_buf[otp_init_input_end] = (quarterword) cur_chr; + } else { + otp_init_input_buf[otp_init_input_end] = (quarterword) + (((cur_chr - 0x10000) / 0x400) + 0xD800); + incr(otp_init_input_end); + if (otp_init_input_end > ocp_buf_size) + overflow_ocp_buf_size(); + otp_init_input_buf[otp_init_input_end] = (quarterword) + (((cur_chr - 0x10000) % 0x400) + 0xDC00); + } + get_token(); + if ((cur_cmd != letter_cmd) && (cur_cmd != other_char_cmd) && + (cur_cmd != char_given_cmd)) { + x_token(); + if (cur_cmd == char_num_cmd) { + scan_char_num(); + cur_cmd = other_char_cmd; + cur_chr = cur_val; + } + } + } + back_input(); + otp_input_end = otp_init_input_end; + for (otp_i = 0; otp_i <= otp_init_input_end; otp_i++) { + otp_input_buf[otp_i] = otp_init_input_buf[otp_i]; + } + + otp_input_ocp = active_ocp(active_real); + if (otp_input_ocp == 0) { + tex_error("Null ocp being used: all input lost", NULL); + otp_output_end = 0; + } else if (ocp_external(otp_input_ocp) == 0) { + otp_input_start = 0; + otp_input_last = 0; + otp_stack_used = 0; + otp_stack_last = 0; + otp_stack_new = 0; + otp_output_end = 0; + otp_pc = 0; + otp_finished = false; + otp_calc_ptr = 0; + otp_calcs[otp_calc_ptr] = 0; + otp_state_ptr = 0; + otp_states[otp_state_ptr] = 0; + while (!otp_finished) + run_otp(); + } else { + /* k=0; ? */ + char *cmd = makecstring(ocp_external(otp_input_ocp)); + char *arg = makecstring(ocp_external_arg(otp_input_ocp)); + char *cmdline = xmalloc((unsigned) (strlen(cmd) + strlen(arg) + 3)); + strcpy(cmdline, cmd); + strcat(cmdline, " "); + strcat(cmdline, arg); + xfree(cmd); + xfree(arg); + run_external_ocp(cmdline); + } + + + /* The OTP output buffer is an array of 16-bit values. To convert back + to the |buffer| it has to be re-encoded into UTF-8. + */ + + if ((first + otp_output_end) >= ocp_buf_size) + overflow_ocp_buf_size(); + push_input(); + current_ocp_lstack = active_lstack_no(active_real); + current_ocp_no = (short) active_counter(active_real); + istate = mid_line; + istart = first; + last = istart; + iloc = istart; + line_catcode_table = DEFAULT_CAT_TABLE; + line_partial = false; + for (otp_counter = 1; otp_counter <= otp_output_end; otp_counter++) { + /* convert back to utf-8 */ + t = otp_output_buf[otp_counter]; + if (otp_counter < otp_output_end) { + if ((t >= 0xD800) && (t < 0xDC00)) { + if ((otp_output_buf[otp_counter + 1] >= 0xDC00) + && (otp_output_buf[otp_counter + 1] < 0xE000)) { + incr(otp_counter); + t = (t - 0xD800) * 0x400 + (otp_output_buf[otp_counter] - + 0xDC00) + 0x10000; + } + } else if ((t >= 0xDC00) && (t < 0xE000)) { + if ((otp_output_buf[otp_counter + 1] >= 0xD800) + && (otp_output_buf[otp_counter + 1] < 0xDC00)) { + incr(otp_counter); + t = (otp_output_buf[otp_counter] - 0xD800) * 0x400 + (t - + 0xDC00) + + 0x10000; + } + } + } + if (t <= 0x7F) { + buffer[last] = (packed_ASCII_code) t; + } else if (t <= 0x7FF) { + buffer[last] = (packed_ASCII_code) (0xC0 + t / 0x40); + incr(last); + check_buffer(); + buffer[last] = (packed_ASCII_code) (0x80 + t % 0x40); + } else if (t <= 0xFFFF) { + buffer[last] = (packed_ASCII_code) (0xE0 + t / 0x1000); + incr(last); + check_buffer(); + buffer[last] = (packed_ASCII_code) (0x80 + (t % 0x1000) / 0x40); + incr(last); + check_buffer(); + buffer[last] = (packed_ASCII_code) (0x80 + (t % 0x1000) % 0x40); + } else { + buffer[last] = (packed_ASCII_code) (0xF0 + t / 0x400000); + incr(last); + check_buffer(); + buffer[last] = (packed_ASCII_code) (0x80 + (t % 0x40000) / 0x1000); + incr(last); + check_buffer(); + buffer[last] = + (packed_ASCII_code) (0x80 + ((t % 0x40000) % 0x1000) / 0x40); + incr(last); + check_buffer(); + buffer[last] = + (packed_ASCII_code) (0x80 + ((t % 0x40000) % 0x1000) % 0x40); + } + incr(last); + check_buffer(); + } + ilimit = last - 1; + if (t > 0xFFFF) + decr(ilimit); + if (t > 0x7FF) + decr(ilimit); + if (t > 0x7F) + decr(ilimit); + first = last; + +} + +@ @c +void initialize_ocp_buffers(int ocp_buf_size, int ocp_stack_size) +{ + otp_init_input_buf = xmallocarray(quarterword, (unsigned) ocp_buf_size); + otp_input_buf = xmallocarray(quarterword, (unsigned) ocp_buf_size); + otp_output_buf = xmallocarray(quarterword, (unsigned) ocp_buf_size); + otp_stack_buf = xmallocarray(quarterword, (unsigned) ocp_stack_size); + otp_calcs = xmallocarray(halfword, (unsigned) ocp_stack_size); + otp_states = xmallocarray(halfword, (unsigned) ocp_stack_size); +} + +@ @c +boolean is_last_ocp(scaled llstack_no, int counter) +{ + active_min_ptr = equiv(ocp_active_min_ptr_base); + active_max_ptr = equiv(ocp_active_max_ptr_base); + active_real = active_min_ptr; + while ((active_real < active_max_ptr) && + (active_lstack_no(active_real) < llstack_no)) { + active_real = active_real + 2; + } + while ((active_real < active_max_ptr) && + (active_lstack_no(active_real) == llstack_no) && + (active_counter(active_real) <= counter)) { + active_real = active_real + 2; + } + return (active_real == active_max_ptr); +} + +@ @c +void print_active_ocps(void) +{ + int i; + tprint_nl("Active ocps: ["); + i = active_min_ptr; + while (i < active_max_ptr) { + tprint("("); + print_scaled(active_lstack_no(i)); + tprint(","); + print_int(active_counter(i)); + tprint(","); + print_esc(cs_text(ocp_id_base + active_ocp(i))); + tprint(")"); + if (i != (active_max_ptr - 2)) + tprint(","); + i = i + 2; + } + tprint("]"); +} + +@ @c +void add_ocp_stack(int min_index, scaled min_value) +{ + ocp_lstack_index p; + scaled llstack_no; + int counter; + scaled m; + m = min_value; /* TH: whatever this is .. */ + p = ocp_list_lstack(holding[min_index]); + llstack_no = ocp_list_lstack_no(holding[min_index]); + counter = 0; + while (!(is_null_ocp_lstack(p))) { + active_ocp(active_max_ptr) = ocp_lstack_ocp(p); + active_counter(active_max_ptr) = (quarterword) counter; + active_lstack_no(active_max_ptr) = llstack_no; + p = ocp_lstack_lnext(p); + active_max_ptr = active_max_ptr + 2; + incr(counter); /* no overflow problem */ + } +} + +@ @c +void active_compile(void) +{ + int i; + int min_index; + scaled min_stack_ocp; + scaled old_min; + int max_active; + scaled stack_value; + active_min_ptr = active_max_ptr; + min_stack_ocp = ocp_maxint; + max_active = equiv(ocp_active_number_base) - 1; + min_index = max_active; /* TH I hope ... */ + for (i = max_active; i >= 0; i--) { + holding[i] = ocp_list_list[ocp_active_base + i]; + stack_value = ocp_list_lstack_no(holding[i]); + if (stack_value < min_stack_ocp) { + min_index = i; + min_stack_ocp = stack_value; + } + } + while (min_stack_ocp < ocp_maxint) { + add_ocp_stack(min_index, min_stack_ocp); + old_min = min_stack_ocp; + min_stack_ocp = ocp_maxint; + for (i = max_active; i >= 0; i--) { + stack_value = ocp_list_lstack_no(holding[i]); + while (old_min == stack_value) { + holding[i] = ocp_list_lnext(holding[i]); + stack_value = ocp_list_lstack_no(holding[i]); + } + if (stack_value < min_stack_ocp) { + min_index = i; + min_stack_ocp = stack_value; + } + } + } +} + +@ @c +void do_push_ocp_list(small_number a) +{ + halfword ocp_list_no; + halfword old_number; + int i; + scan_ocp_list_ident(); + ocp_list_no = cur_val; + old_number = equiv(ocp_active_number_base); + define(ocp_active_base + old_number, data_cmd, ocp_list_no); + define(ocp_active_number_base, data_cmd, (old_number + 1)); + if (ocp_trace_level == 1) { + tprint_nl("New active ocp list: {"); + for (i = old_number; i >= 0; i--) { + print_esc(ocp_list_id_text(equiv(ocp_active_base + i))); + tprint("="); + print_ocp_list(ocp_list_list[equiv(ocp_active_base + i)]); + if (i != 0) + tprint(","); + } + tprint("}"); + } + active_compile(); + define(ocp_active_min_ptr_base, data_cmd, active_min_ptr); + define(ocp_active_max_ptr_base, data_cmd, active_max_ptr); +} + +@ @c +void do_pop_ocp_list(small_number a) +{ + halfword old_number; + int i; + old_number = equiv(ocp_active_number_base); + if (old_number == 0) { + print_err("No active ocp lists to be popped"); + } else { + define(ocp_active_number_base, data_cmd, (old_number - 1)); + if (ocp_trace_level == 1) { + tprint_nl("New active ocp list: {"); + for (i = (old_number - 2); i >= 0; i++) { + print_esc(ocp_list_id_text(equiv(ocp_active_base + i))); + tprint("="); + print_ocp_list(ocp_list_list[equiv(ocp_active_base + i)]); + if (i != 0) + tprint(","); + } + tprint("}"); + } + active_compile(); + define(ocp_active_min_ptr_base, data_cmd, active_min_ptr); + define(ocp_active_max_ptr_base, data_cmd, active_max_ptr); + } +} + +@ @c +void do_clear_ocp_lists(small_number a) +{ + define(ocp_active_number_base, data_cmd, 0); + active_compile(); + define(ocp_active_min_ptr_base, data_cmd, active_min_ptr); + define(ocp_active_max_ptr_base, data_cmd, active_max_ptr); +} + + +@ @c +void dump_active_ocp_info(void) +{ + int k; + dump_int(active_min_ptr); + dump_int(active_max_ptr); + for (k = 0; k <= active_max_ptr - 1; k++) + dump_wd(active_info[k]); + if (active_max_ptr > 0) { + print_ln(); + print_int(active_max_ptr); + tprint(" words of active ocps"); + } +} + +void undump_active_ocp_info(void) +{ + int k; + undump_int(active_min_ptr); + undump_int(active_max_ptr); + for (k = 0; k <= active_max_ptr - 1; k++) + undump_wd(active_info[k]); +} |