%
% This file is part of the Omega project, which
% is based on the web2c distribution of TeX.
%
% Copyright (c) 1995--1999 John Plaice and Yannis Haralambous
% 
%---------------------------------------
@x [1] m.11 l.412 - Omega OCP
  {string of length |file_name_size|; tells where the string pool appears}
@.TeXformats@>
@y
  {string of length |file_name_size|; tells where the string pool appears}
@.TeXformats@>
@!ocp_maxint=@"10000000;
@z
%---------------------------------------
@x [1] m.12 l.436 - Omega OCP
@d hyph_size=307 {another prime; the number of \.{\\hyphenation} exceptions}
@y
@d hyph_size=307 {another prime; the number of \.{\\hyphenation} exceptions}
@d ocp_base=0 {smallest internal ocp number; must not be less
  than |min_quarterword|}
@d ocp_biggest=65535 {the real biggest ocp}
@d number_ocps=ocp_biggest-ocp_base+1
@d ocp_list_base=0 {smallest internal ocp list number; must not be less
  than |min_quarterword|}
@d ocp_list_biggest=65535 {the real biggest ocp list}
@d number_ocp_lists=ocp_list_biggest-ocp_list_base+1
@d max_active_ocp_lists=65536
@z
%---------------------------------------
@x [15] m.209 l.4170 - Omega OCP
@d max_command=set_interaction
   {the largest command code seen at |big_switch|}
@y
@d set_ocp=set_interaction+1
   {Place a translation process in the stream}
@d def_ocp=set_ocp+1
   {Define and load a translation process}
@d set_ocp_list=def_ocp+1
   {Place a list of OCPs in the stream}
@d def_ocp_list=set_ocp_list+1
   {Define a list of OCPs}
@d clear_ocp_lists=def_ocp_list+1
   {Remove all active OCP lists}
@d push_ocp_list=clear_ocp_lists+1
   {Add to the sequence of active OCP lists}
@d pop_ocp_list=push_ocp_list+1
   {Remove from the sequence of active OCP lists}
@d ocp_list_op=pop_ocp_list+1
   {Operations for building a list of OCPs}
@d ocp_trace_level=ocp_list_op+1
   {Tracing of active OCPs, either 0 or 1}
@d max_command=ocp_trace_level
   {the largest command code seen at |big_switch|}
@z
%---------------------------------------
@x [17] m.222 l.4523 - Omega OCP
@d font_id_base=frozen_null_font-font_base
   {begins table of |number_fonts| permanent font identifiers}
@d frozen_null_font_sort=frozen_null_font+number_fonts {permanent null sort}
@d undefined_control_sequence=frozen_null_font_sort+number_font_sorts
   {dummy location}
@y
@d font_id_base=frozen_null_font-font_base
   {begins table of |number_fonts| permanent font identifiers}
@d frozen_null_font_sort=frozen_null_font+number_fonts {permanent null sort}
@d frozen_null_ocp=frozen_null_font_sort+number_font_sorts
  {permanent `\.{\\nullocp}'}
@d ocp_id_base=frozen_null_ocp-ocp_base
  {begins table of |number_ocps| permanent ocp identifiers}
@d frozen_null_ocp_list=frozen_null_ocp+number_ocps
  {permanent `\.{\\nullocplist}'}
@d ocp_list_id_base=frozen_null_ocp_list-ocp_list_base
  {begins table of |number_ocp_lists| permanent ocp list identifiers}
@d undefined_control_sequence=frozen_null_ocp_list+number_ocp_lists 
@z
%---------------------------------------
@x
@d toks_base=local_base+10 {table of |number_regs| token list registers}
@y
@d ocp_trace_level_base=local_base+10
@d ocp_active_number_base=ocp_trace_level_base+1
@d ocp_active_min_ptr_base = ocp_active_number_base+1
@d ocp_active_max_ptr_base = ocp_active_min_ptr_base+1
@d ocp_active_base = ocp_active_max_ptr_base+1
@d toks_base=ocp_active_base+max_active_ocp_lists 
   {table of |number_regs| token list registers}
@z
%---------------------------------------
@x [17] m.232 l.4799 - Omega OCP
@d null_font==font_base
@y
@d null_font==font_base
@d null_ocp==ocp_base
@d null_ocp_list==ocp_list_base
@z
%---------------------------------------
@x [18] m.256 l.5479 - Omega OCP
@d font_id_text(#) == newtext(font_id_base+#) {a frozen font identifier's name}
@y
@d font_id_text(#) == newtext(font_id_base+#) {a frozen font identifier's name}
@d ocp_id_text(#) == newtext(ocp_id_base+#) {a frozen ocp identifier's name}
@d ocp_list_id_text(#) == newtext(ocp_list_id_base+#) 
   {a frozen ocp list identifier's name}
@z
%---------------------------------------
@x [26] m.409 l.8254 - Omega OCP
@t\4\4@>@<Declare procedures that scan font-related stuff@>
@y
@t\4\4@>@<Declare procedures that scan font-related stuff@>
@t\4\4@>@<Declare procedures that scan ocp-related stuff@>
@z
%---------------------------------------
@x [29] m.514 l.9968 - Omega OCP
|TEX_font_area|.  These system area names will, of course, vary from place
to place.
@y
|TEX_font_area|.  $\Omega$'s compiled translation process files whose areas
are not given explicitly are assumed to appear in a standard system area
called |OMEGA_ocp_area|.  These system area names will, of course, vary
from place to place.
@z
%---------------------------------------
@x [29] m.514 l.9974 - Omega OCP
@d TEX_font_area=="TeXfonts:"
@.TeXfonts@>
@y
@d TEX_font_area=="TeXfonts:"
@.TeXfonts@>
@d OMEGA_ocp_area=="OmegaOCPs:"
@.OmegaOCPs@>
@z
%---------------------------------------
@x [30] m.582 l.10379 - Omega OCP
@* \[30] Font metric data.
@y
@* \[30] Font metric data and OCPs.
@z
%---------------------------------------
@x [30] m.??? l.10928 - Omega OCP
@ @<Read and check...@>=
@y
@ @<Read and check the font data...@>=
@z
%---------------------------------------
@x [30] m.??? l.11010 - Omega OCP
@ @<Apologize for not loading...@>=
@y
@ @<Apologize for not loading the font...@>=
@z
%---------------------------------------
@x [30] m.582 l.11283 - Omega OCP
char_warning(f,c);
new_character:=null;
exit:end;
@y
char_warning(f,c);
new_character:=null;
exit:end;

@ Here we begin the \.{OCP} file handling.

@<Glob...@>=
@!ocp_file:byte_file;

@ So that is what \.{OCP} files hold.

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.

@<Types...@>=
@!internal_ocp_number=ocp_base..ocp_biggest;
@!ocp_index=integer;

@ Here now is the array of ocp arrays.

@<Glob...@>=
@!ocp_ptr:internal_ocp_number; {largest internal ocp number in use}

@ Besides the arrays just enumerated, we have two directory arrays that
make it easy to get at the individual entries in |ocp_info|.
The beginning of the info for the |j|-th state in the |i|-th ocp is at
location |ocp_info[ocp_state_base[i]+j]| and the |k|-th entry is in
location |ocp_info[ocp_info[ocp_state_base[i]+j]+k]|.
(These formulas assume that |min_quarterword| has already been 
added to |i|, |j| and |k|, since $\Omega$ stores its quarterwords that way.)

@d ocp_info_end(#)==#]
@d ocp_info(#)==ocp_tables[#,ocp_info_end
@d offset_ocp_file_size=0
@d offset_ocp_name=1
@d offset_ocp_area=offset_ocp_name+1
@d offset_ocp_input=offset_ocp_area+1
@d offset_ocp_output=offset_ocp_input+1
@d offset_ocp_no_states=offset_ocp_output+1
@d offset_ocp_no_tables=offset_ocp_no_states+1
@d offset_ocp_state_base=offset_ocp_no_tables+1
@d offset_ocp_table_base=offset_ocp_state_base+1
@d offset_ocp_info=offset_ocp_table_base+1
@d ocp_file_size(#)==ocp_info(#)(offset_ocp_file_size)
@d ocp_name(#)==ocp_info(#)(offset_ocp_name)
@d ocp_area(#)==ocp_info(#)(offset_ocp_area)
@d ocp_input(#)==ocp_info(#)(offset_ocp_input)
@d ocp_output(#)==ocp_info(#)(offset_ocp_output)
@d ocp_no_states(#)==ocp_info(#)(offset_ocp_no_states)
@d ocp_no_tables(#)==ocp_info(#)(offset_ocp_no_tables)
@d ocp_state_base(#)==ocp_info(#)(offset_ocp_state_base)
@d ocp_table_base(#)==ocp_info(#)(offset_ocp_table_base)

@ $\Omega$ always knows at least one ocp, namely the null ocp.
It does nothing.

@<Initialize table...@>=
ocp_ptr:=null_ocp; 
allocate_ocp_table(null_ocp,12);
ocp_file_size(null_ocp):=12;
ocp_name(null_ocp):="nullocp"; ocp_area(null_ocp):="";
ocp_state_base(null_ocp):=0; ocp_table_base(null_ocp):=0;
ocp_input(null_ocp):=1; ocp_output(null_ocp):=1;
ocp_info(null_ocp)(offset_ocp_info):=0;

@ @<Put each...@>=
primitive("nullocp", set_ocp, null_ocp);
settext(frozen_null_ocp,"nullocp");
set_new_eqtb(frozen_null_ocp,new_eqtb(cur_val));
geq_define(ocp_active_number_base, data, 0);
geq_define(ocp_active_min_ptr_base, data, 0);
geq_define(ocp_active_max_ptr_base, data, 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@>

@d ocp_state_end(#)==#]
@d ocp_state_one(#)==#*2]+ocp_state_end
@d ocp_state_entry(#)==ocp_tables[#,ocp_tables[#,ocp_state_base(#)+ocp_state_one

@d ocp_state_no_end(#)==#*2+1]
@d ocp_state_no(#)==ocp_tables[#,ocp_state_base(#)+ocp_state_no_end

@d ocp_table_end(#)==#]
@d ocp_table_one(#)==#*2]+ocp_table_end
@d ocp_table_entry(#)==ocp_tables[#,ocp_tables[#,ocp_table_base(#)+ocp_table_one

@d ocp_table_no_end(#)==#*2+1]
@d ocp_table_no(#)==ocp_tables[#,ocp_table_base(#)+ocp_table_no_end

@ $\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.

@d bad_ocp=11 {label for |read_ocp_info|}
@d ocp_abort(#)==begin print_nl(#); goto bad_ocp end
 {do this when the \.{OCP} data is wrong}

@p function read_ocp_info(@!u:pointer;@!nom,@!aire:str_number)
  :internal_ocp_number; {input a \.{OCP} file}
label done,bad_ocp,not_found;
var k:ocp_index; {index into |ocp_info|}
@!file_opened:boolean; {was |ocp_file| successfully opened?}
@!f:internal_ocp_number; {the new ocp's number}
@!g:internal_ocp_number; {the number to return}
@!ocpword:integer;
@!ocpmem_run_ptr:ocp_index;
@!ocp_length,real_ocp_length:integer; {length of ocp file}
@!previous_address:ocp_index;
@!temp_ocp_file_size:integer;
@!temp_ocp_input:integer;
@!temp_ocp_output:integer;
@!temp_ocp_no_tables:integer;
@!temp_ocp_no_states:integer;
@!i,new_offset,room_for_tables,room_for_states:integer;
begin g:=null_ocp;@/
@<Read and check the ocp data; |ocp_abort| if the \.{OCP} file is
  malformed; if there's no room for this ocp, say so and |goto
  done|; otherwise |incr(ocp_ptr)| and |goto done|@>;
bad_ocp: @<Report that the ocp won't be loaded@>;
done: if file_opened then b_close(ocp_file);
ocp_name(f):=nom; ocp_area(f):=aire;
read_ocp_info:=g;
end;

@ $\Omega$ does not give precise details about why it
rejects a particular \.{OCP} file.

@d start_ocp_error_message==print_err("Translation process "); 
   sprint_cs(u); print_char("="); print_file_name(nom,aire,"");

@<Report that the ocp won't be loaded@>=
start_ocp_error_message;
@.Translation process x=xx not loadable...@>
if file_opened then print(" not loadable: Bad ocp file")
else print(" not loadable: ocp file not found");
help2("I wasn't able to read the data for this ocp,")@/
("so I will ignore the ocp specification.");
error

@ @<Read and check the ocp data...@>=
@<Open |ocp_file| for input@>;
@<Read the {\.{OCP}} file@>;

@ @<Open |ocp_file| for input@>=
file_opened:=false;
pack_file_name(nom,aire,".ocp");
if not b_open_in(ocp_file) then ocp_abort("opening file");
file_opened:=true

@ Note: A malformed \.{OCP} file might be shorter than it claims to be;
thus |eof(ocp_file)| might be true when |read_ocp_info| refers to
|ocp_file^| or when it says |get(ocp_file)|. If such circumstances
cause system error messages, you will have to defeat them somehow,
for example by defining |ocpget| to be `\ignorespaces|begin get(ocp_file);|
|if eof(ocp_file) then ocp_abort; end|\unskip'.
@^system dependencies@>

@d add_to_ocp_info(#)==begin ocp_tables[f,ocpmem_run_ptr]:=#;
  incr(ocpmem_run_ptr);
  end
@d ocpget==get(ocp_file)
@d ocpbyte==ocp_file^
@d ocp_read(#)==begin ocpword:=ocpbyte;
  if ocpword>127 then ocp_abort("checking first octet");
  ocpget; ocpword:=ocpword*@'400+ocpbyte;
  ocpget; ocpword:=ocpword*@'400+ocpbyte;
  ocpget; ocpword:=ocpword*@'400+ocpbyte;
  #:=ocpword;
  end
@d ocp_read_all(#)==begin ocpget; ocp_read(#); end
@d ocp_read_info==begin ocp_read_all(ocpword);
  add_to_ocp_info(ocpword);
  end

@ @<Read the {\.{OCP}} file@>=
begin
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) then
  ocp_abort("checking size");
real_ocp_length:=real_ocp_length+11+
   temp_ocp_no_states+temp_ocp_no_tables;
allocate_ocp_table(f,real_ocp_length);
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 then
begin
   previous_address:=ocpmem_run_ptr+2*(ocp_no_tables(f));
   for i:=1 to ocp_no_tables(f) do begin
       add_to_ocp_info(previous_address);
       ocp_read_all(new_offset);
       add_to_ocp_info(new_offset);
       previous_address:=previous_address+new_offset;
   end
end;
if room_for_tables <> 0 then
begin
   for i:=1 to room_for_tables do begin
       ocp_read_info;
   end
end;
ocp_state_base(f):=ocpmem_run_ptr;
if ocp_no_states(f) <> 0 then
begin
   previous_address:=ocpmem_run_ptr+2*(ocp_no_states(f));
   for i:=1 to ocp_no_states(f) do begin
       add_to_ocp_info(previous_address);
       ocp_read_all(new_offset);
       add_to_ocp_info(new_offset);
       previous_address:=previous_address+new_offset;
   end;
end;
if room_for_states <> 0 then
begin
   for i:=1 to room_for_states do begin
       ocp_read_info;
   end
end;
ocp_ptr:=f; g:=f;
goto done;
end

@ Before we forget about the format of these tables, let's deal with 
$\Omega$'s basic scanning routine related to ocp information.

@<Declare procedures that scan ocp-related stuff@>=
procedure scan_ocp_ident;
var f:internal_ocp_number;
@!m:halfword;
begin @<Get the next non-blank non-call...@>;
if cur_cmd=set_ocp then f:=cur_chr
else  begin print_err("Missing ocp identifier");
@.Missing ocp identifier@>
  help2("I was looking for a control sequence whose")@/
  ("current meaning has been defined by \ocp.");
  back_error; f:=null_ocp;
  end;
cur_val:=f;
end;


@ Here we begin the \.{OCP} list handling.


@<Types...@>=
@!internal_ocp_list_number=ocp_list_base..ocp_list_biggest;
@!ocp_list_index=integer; {index into |ocp_list_info|}
@!ocp_lstack_index=integer; {index into |ocp_lstack_info|}

@ Here now is the array of ocp arrays.
@d ocp_list_lnext(#)==ocp_list_info[#].hh.b0
@d ocp_list_lstack(#)==ocp_list_info[#].hh.b1
@d ocp_list_lstack_no(#)==ocp_list_info[#+1].sc
@d ocp_lstack_lnext(#)==ocp_lstack_info[#].hh.b0
@d ocp_lstack_ocp(#)==ocp_lstack_info[#].hh.b1
@d make_null_ocp_list==make_ocp_list_node(0,ocp_maxint,0)
@d is_null_ocp_list(#)==ocp_list_lstack_no(#)=ocp_maxint
@d make_null_ocp_lstack==0
@d is_null_ocp_lstack(#)==#=0
@d add_before_op=1
@d add_after_op=2
@d remove_before_op=3
@d remove_after_op=4

@<Glob...@>=
@!ocp_list_info:array[ocp_list_index] of memory_word;
  {the big collection of ocp list data}
@!ocp_listmem_ptr:ocp_list_index; {first unused word of |ocp_list_info|}
@!ocp_listmem_run_ptr:ocp_list_index; {temp unused word of |ocp_list_info|}
@!ocp_lstack_info:array[ocp_lstack_index] of memory_word;
  {the big collection of ocp lstack data}
@!ocp_lstackmem_ptr:ocp_lstack_index; {first unused word of |ocp_lstack_info|}
@!ocp_lstackmem_run_ptr:ocp_lstack_index; {temp unused word of |ocp_lstack_info|}
@!ocp_list_ptr:internal_ocp_list_number; {largest internal ocp list number in use}
@!ocp_list_list:array[internal_ocp_list_number] of ocp_list_index;

@
@<Initialize table...@>=
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;

@ $\Omega$ always knows at least one ocp list, namely the null ocp list.

@ @<Put each...@>=
primitive("nullocplist", set_ocp_list, null_ocp_list);
settext(frozen_null_ocp_list,"nullocplist"); 
set_new_eqtb(frozen_null_ocp_list,new_eqtb(cur_val));

@ @p function make_ocp_list_node(llstack:ocp_lstack_index; 
                                 llstack_no:scaled; 
                                 llnext:ocp_list_index):ocp_list_index;
var p:ocp_list_index;
begin 
   p:=ocp_listmem_run_ptr;
   ocp_list_lstack(p):=llstack;
   ocp_list_lstack_no(p):=llstack_no;
   ocp_list_lnext(p):=llnext;
   ocp_listmem_run_ptr:=ocp_listmem_run_ptr+2;
   make_ocp_list_node:=p;
end;

function make_ocp_lstack_node(locp:internal_ocp_number; llnext:ocp_lstack_index):
         ocp_lstack_index;
var p:ocp_lstack_index;
begin 
   p:=ocp_lstackmem_run_ptr;
   ocp_lstack_ocp(p):=locp;
   ocp_lstack_lnext(p):=llnext;
   incr(ocp_lstackmem_run_ptr);
   make_ocp_lstack_node:=p;
end;

function copy_ocp_lstack(llstack:ocp_lstack_index):ocp_lstack_index;
var result:ocp_lstack_index;
begin
   if is_null_ocp_lstack(llstack)
   then result:=make_null_ocp_lstack
   else result:=
        make_ocp_lstack_node(ocp_lstack_ocp(llstack),
                             copy_ocp_lstack(ocp_lstack_lnext(llstack)));
   copy_ocp_lstack:=result;
end;

function copy_ocp_list(list:ocp_list_index):ocp_list_index;
var result:ocp_list_index;
begin
   if is_null_ocp_list(list)
   then result:=make_null_ocp_list
   else result:=make_ocp_list_node(copy_ocp_lstack(ocp_list_lstack(list)),
                                   ocp_list_lstack_no(list),
                                   copy_ocp_list(ocp_list_lnext(list)));
   copy_ocp_list:=result;
end;

function ocp_ensure_lstack(list:ocp_list_index; llstack_no:scaled):
   ocp_list_index;
var p:ocp_list_index;
    q:ocp_list_index;
begin
   p:=list;
   if is_null_ocp_list(p) then
   begin
      ocp_list_lstack_no(p) := llstack_no;
      ocp_list_lnext(p) := make_null_ocp_list;
   end
   else if ocp_list_lstack_no(p) > llstack_no then
   begin
      ocp_list_lnext(p) := 
         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;
   end
   else
   begin
      q:=ocp_list_lnext(p);
      while (not (is_null_ocp_list(q))) and 
            ocp_list_lstack_no(q) <= llstack_no do
      begin
         p:=q; q:=ocp_list_lnext(q);
      end;
      if ocp_list_lstack_no(p) < llstack_no then
      begin
         ocp_list_lnext(p) := make_ocp_list_node(0, llstack_no, q);
         p := ocp_list_lnext(p);
      end;
   end;
   ocp_ensure_lstack := p;
end;

procedure ocp_apply_add(list_entry:ocp_list_index;
                        lbefore:boolean;
                        locp:internal_ocp_number);
var p:ocp_lstack_index;
    q:ocp_lstack_index;
begin
   p := ocp_list_lstack(list_entry);
   if lbefore or (p=0) then
   begin
      ocp_list_lstack(list_entry) := make_ocp_lstack_node(locp, p);
   end
   else
   begin
      q:=ocp_lstack_lnext(p);
      while q<>0 do
      begin
         p:=q; q:=ocp_lstack_lnext(q);
      end;
      ocp_lstack_lnext(p):=make_ocp_lstack_node(locp, null);
   end;
end;

procedure ocp_apply_remove(list_entry:ocp_list_index;
                           lbefore:boolean);
var p:ocp_lstack_index;
    q:ocp_lstack_index;
    r:ocp_lstack_index;
begin
    p := ocp_list_lstack(list_entry);
    if p=0 then
    begin
       print_err("warning: stack entry already empty"); print_ln
    end
    else 
    begin
       q := ocp_lstack_lnext(p);
       if lbefore or (q=0) then
          ocp_list_lstack(list_entry) := q
       else
       begin
          r:=ocp_lstack_lnext(q);
          while r <> 0 do
          begin
             p:=q; q:=r; r:=ocp_lstack_lnext(r);
          end;
          ocp_lstack_lnext(p) := null;
       end
    end;
end;

procedure scan_scaled; {sets |cur_val| to a scaled value}
label done, done1, done2, found, not_found, attach_fraction,
attach_sign;
var negative:boolean; {should the answer be negated?}
@!f:integer; {numerator of a fraction whose denominator is $2^{16}$}
@<Local variables for dimension calculations@>@;
begin f:=0; arith_error:=false; negative:=false;
  @<Get the next non-blank non-sign...@>;
  back_input;
  if cur_tok=continental_point_token then cur_tok:=point_token;
  if cur_tok<>point_token then scan_int
  else  begin radix:=10; cur_val:=0;
    end;
  if cur_tok=continental_point_token then cur_tok:=point_token;
  if (radix=10)and(cur_tok=point_token) then @<Scan decimal fraction@>;
if cur_val<0 then {in this case |f=0|}
  begin negative := not negative; negate(cur_val);
  end;
if cur_val>@'40000 then arith_error:=true
else cur_val := cur_val*unity +f;
attach_sign: if arith_error or(abs(cur_val)>=@'10000000000) then
begin print_err("Stack number too large");
end;
if negative then negate(cur_val);
end;

procedure print_ocp_lstack(lstack_entry:ocp_lstack_index);
var p:ocp_lstack_index;
begin
   p:=lstack_entry;
   while (p<>0) do
   begin
      print_esc(ocp_id_text(ocp_lstack_ocp(p)));
      p:=ocp_lstack_lnext(p);
      if (p<>0) then print(",");
   end;
end;

procedure print_ocp_list(list_entry:ocp_list_index);
var p:ocp_list_index;
begin
   print("["); p:=list_entry;
   while not (is_null_ocp_list(p)) do
   begin
      print("(");
      print_scaled(ocp_list_lstack_no(p));
      print(" : ");
      print_ocp_lstack(ocp_list_lstack(p));
      print(")");
      p:=ocp_list_lnext(p);
      if not (is_null_ocp_list(p)) then print(", ");
   end;
   print("]");
end;

function scan_ocp_list: ocp_list_index;
var llstack_no:scaled; 
    lop:quarterword;
    lstack_entry:ocp_list_index;
    other_list:ocp_list_index;
    ocp_ident:internal_ocp_number;
    result:ocp_list_index;
begin
get_r_token; 
if cur_cmd = set_ocp_list then
   result := copy_ocp_list(ocp_list_list[cur_chr])
else if cur_cmd <> ocp_list_op then
begin
   print_err("Bad ocp list specification");
@.Bad ocp list specification@>
   help1("I was looking for a ocp list specification.");
   result := make_null_ocp_list;
end
else
begin
   lop:=cur_chr;
   scan_scaled; llstack_no:=cur_val;
   if (llstack_no<=0) or (llstack_no>=ocp_maxint) then
   begin
      print_err("Stack numbers must be between 0 and 4096 (exclusive)");
      result := make_null_ocp_list;
   end
   else
   begin
      if lop <= add_after_op then
      begin
         scan_ocp_ident; ocp_ident:=cur_val;
      end;
      other_list:=scan_ocp_list;
      lstack_entry:=ocp_ensure_lstack(other_list, llstack_no);
      if lop <= add_after_op then
         ocp_apply_add(lstack_entry, (lop=add_before_op), ocp_ident)
      else
         ocp_apply_remove(lstack_entry, (lop=remove_before_op));
      result:=other_list;
   end;
end;
scan_ocp_list:=result;
end;

function read_ocp_list: internal_ocp_list_number;
var f:internal_ocp_list_number;
    g:internal_ocp_list_number;
begin
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;
read_ocp_list:=g;
end;

procedure scan_ocp_list_ident;
var f:internal_ocp_list_number;
begin @<Get the next non-blank non-call...@>;
if cur_cmd=set_ocp_list then f:=cur_chr
else  begin print_err("Missing ocp list identifier");
@.Missing ocp list identifier@>
  help2("I was looking for a control sequence whose")@/
  ("current meaning has been defined by \ocplist.");
  back_error; f:=null_ocp_list;
  end;
cur_val:=f;
end;


@z
%---------------------------------------
@x [49] m.1210 l.22629 - Omega OCP
any_mode(set_interaction):prefixed_command;
@y
any_mode(set_interaction),
any_mode(set_ocp),
any_mode(def_ocp),
any_mode(set_ocp_list),
any_mode(def_ocp_list),
any_mode(clear_ocp_lists),
any_mode(push_ocp_list),
any_mode(pop_ocp_list),
any_mode(ocp_list_op),
any_mode(ocp_trace_level) : prefixed_command;
@z
%---------------------------------------
@x [50] m.1302 l.23682 - Omega OCP
@<Dump the font information@>;
@y
@<Dump the font information@>;
@<Dump the ocp information@>;
@<Dump the ocp list information@>;
@z
%---------------------------------------
@x [50] m.1303 l.23711 - Omega OCP
@<Undump the font information@>;
@y
@<Undump the font information@>;
@<Undump the ocp information@>;
@<Undump the ocp list information@>;
@z
%---------------------------------------
@x [50] m.1323 l.24907 - Omega OCP
begin undump_font_table(k);@/
end
@y
begin undump_font_table(k);@/
end

@ @<Dump the ocp information@>=
dump_int(ocp_ptr);
for k:=null_ocp to ocp_ptr do
  @<Dump the array info for internal ocp number |k|@>;
print_ln; print_int(ocp_ptr-ocp_base); print(" preloaded ocp");
if ocp_ptr<>ocp_base+1 then print_char("s")

@ @<Undump the ocp information@>=
undump_size(ocp_base)(ocp_biggest)('ocp max')(ocp_ptr);
for k:=null_ocp to ocp_ptr do
  @<Undump the array info for internal ocp number |k|@>

@ @<Dump the array info for internal ocp number |k|@>=
begin dump_ocp_table(k);
print_nl("\ocp"); print_esc(ocp_id_text(k)); print_char("=");
print_file_name(ocp_name(k),ocp_area(k),"");
end

@ @<Undump the array info for internal ocp number |k|@>=
begin undump_ocp_table(k);
end

@ @<Dump the ocp list information@>=
dump_int(ocp_listmem_ptr);
for k:=0 to ocp_listmem_ptr-1 do dump_wd(ocp_list_info[k]);
dump_int(ocp_list_ptr);
for k:=null_ocp_list to ocp_list_ptr do
begin
   dump_int(ocp_list_list[k]);
   print_nl("\ocplist"); 
   print_esc(ocp_list_id_text(k)); 
   print_char("=");
   print_ocp_list(ocp_list_list[k]);
end;
dump_int(ocp_lstackmem_ptr);
for k:=0 to ocp_lstackmem_ptr-1 do dump_wd(ocp_lstack_info[k])

@ @<Undump the ocp list information@>=
undump_size(1)(1000000)('ocp list mem size')(ocp_listmem_ptr);
for k:=0 to ocp_listmem_ptr-1 do undump_wd(ocp_list_info[k]);
undump_size(ocp_list_base)(ocp_list_biggest)('ocp list max')(ocp_list_ptr);
for k:=null_ocp_list to ocp_list_ptr do
    undump_int(ocp_list_list[k]);
undump_size(1)(1000000)('ocp lstack mem size')(ocp_lstackmem_ptr);
for k:=0 to ocp_lstackmem_ptr-1 do undump_wd(ocp_lstack_info[k])

@z
%---------------------------------------
@x
@* \[54] $\Omega$ changes.

@y
@* \[54] $\Omega$ changes.

@ Here we do the main work required for reading and interpreting
  $\Omega$ Compiled Translation Processes.

@ @<Put each...@>=
primitive("ocp", def_ocp, 0);
primitive("ocplist", def_ocp_list, 0);
primitive("pushocplist", push_ocp_list, 0);
primitive("popocplist", pop_ocp_list, 0);
primitive("clearocplists", clear_ocp_lists, 0);
primitive("addbeforeocplist", ocp_list_op, add_before_op);
primitive("addafterocplist", ocp_list_op, add_after_op);
primitive("removebeforeocplist", ocp_list_op, remove_before_op);
primitive("removeafterocplist", ocp_list_op, remove_after_op);
primitive("ocptracelevel", ocp_trace_level, 0);
set_equiv(ocp_trace_level_base,0);

@ @<Cases of |print_cmd_chr|...@>=
set_ocp: begin print("select ocp "); 
               slow_print(ocp_name(chr_code)); 
         end;
def_ocp: print_esc("ocp");
set_ocp_list: begin
                print("select ocp list "); 
              end;
def_ocp_list:  print_esc("ocplist");
push_ocp_list: print_esc("pushocplist");
pop_ocp_list:  print_esc("popocplist");
clear_ocp_lists: print_esc("clearocplists");
ocp_list_op:     if chr_code=add_before_op then print_esc("addbeforeocplist")
            else if chr_code=add_after_op then print_esc("addafterocplist")
            else if chr_code=remove_before_op 
                 then print_esc("removebeforeocplist")
            else {|chr_code|=|remove_after_op|} print_esc("removeafterocplist");
ocp_trace_level: begin print_esc("ocptracelevel");
                 end;

@ @<Assignments@>=
set_ocp: begin print_err("To use ocps, use the "); print_esc("pushocplist"); 
               print(" primitive");print_ln
         end;
def_ocp: new_ocp(a);
set_ocp_list: begin print_err("To use ocp lists, use the "); 
                    print_esc("pushocplist"); print(" primitive");print_ln
              end;
def_ocp_list: new_ocp_list(a);
push_ocp_list: do_push_ocp_list(a);
pop_ocp_list: do_pop_ocp_list(a);
clear_ocp_lists: do_clear_ocp_lists(a);
ocp_list_op: begin print_err("To build ocp lists, use the ");
                   print_esc("ocplist"); print(" primitive"); print_ln
             end;
ocp_trace_level: begin scan_optional_equals; scan_int;
  if cur_val<>0 then cur_val:=1;
  define(ocp_trace_level_base, data, cur_val);
  end;

@ @<Declare subprocedures for |prefixed_command|@>=
procedure new_ocp(@!a:small_number);
label common_ending;
var u:pointer; {user's ocp identifier}
@!f:internal_ocp_number; {runs through existing ocps}
@!t:str_number; {name for the frozen ocp identifier}
@!old_setting:0..max_selector; {holds |selector| setting}
@!flushable_string:str_number; {string not yet referenced}
begin if job_name=0 then open_log_file;
  {avoid confusing \.{texput} with the ocp name}
@.texput@>
get_r_token; u:=cur_cs;
if u>=hash_base then t:=newtext(u)
else if u>=single_base then
  if u=null_cs then t:="OCP"@+else t:=u-single_base
else  begin old_setting:=selector; selector:=new_string;
  print("OCP"); print(u-active_base); selector:=old_setting;
@.OCPx@>
  str_room(1); t:=make_string;
  end;
define(u,set_ocp,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|@>;
f:=read_ocp_info(u,cur_name,cur_area);
common_ending: 
    set_equiv(u,f); set_new_eqtb(ocp_id_base+f,new_eqtb(u)); settext(ocp_id_base+f,t);
if equiv(ocp_trace_level_base)=1 then begin
  print_nl(""); print_esc("ocp"); print_esc(t); print("="); print(cur_name);
  end;
end;

@ 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.

@<If this ocp has already been loaded...@>=
flushable_string:=str_ptr-1;
for f:=ocp_base+1 to ocp_ptr do
  if str_eq_str(ocp_name(f),cur_name)and str_eq_str(ocp_area(f),cur_area)
then begin if cur_name=flushable_string then
              begin flush_string; cur_name:=ocp_name(f);
              end;
           goto common_ending
     end

@ @<Declare subprocedures for |prefixed_command|@>=
procedure new_ocp_list(@!a:small_number);
label common_ending;
var u:pointer; {user's ocp list identifier}
@!f:internal_ocp_list_number; {runs through existing ocp lists}
@!t:str_number; {name for the frozen ocp list identifier}
@!old_setting:0..max_selector; {holds |selector| setting}
@!flushable_string:str_number; {string not yet referenced}
begin if job_name=0 then open_log_file;
  {avoid confusing \.{texput} with the ocp list name}
@.texput@>
get_r_token; u:=cur_cs;
if u>=hash_base then t:=newtext(u)
else if u>=single_base then
  if u=null_cs then t:="OCPLIST"@+else t:=u-single_base
else  begin old_setting:=selector; selector:=new_string;
  print("OCPLIST"); print(u-active_base); selector:=old_setting;
@.OCPx@>
  str_room(1); t:=make_string;
  end;
define(u,set_ocp_list,null_ocp_list); scan_optional_equals; 
f:=read_ocp_list;
common_ending: 
    set_equiv(u,f); set_new_eqtb(ocp_list_id_base+f,new_eqtb(u)); settext(ocp_list_id_base+f,t);
if equiv(ocp_trace_level_base)=1 then begin
  print_nl(""); print_esc("ocplist"); print_esc(t); print("=");
  print_ocp_list(ocp_list_list[f]);
  end;
end;

@ @<Declare subprocedures for |prefixed_command|@>=
procedure do_push_ocp_list(@!a:small_number);
var ocp_list_no:halfword;
    old_number:halfword;
    i:integer;
begin
   scan_ocp_list_ident; ocp_list_no:=cur_val;
   old_number:=equiv(ocp_active_number_base);
   define(ocp_active_base+old_number, data, ocp_list_no);
   define(ocp_active_number_base, data, (old_number+1));

if equiv(ocp_trace_level_base)=1 then begin
     print_nl("New active ocp list: {");
     for i:=old_number downto 0 do
     begin
        print_esc(ocp_list_id_text(equiv(ocp_active_base+i)));
        print("="); print_ocp_list(ocp_list_list[equiv(ocp_active_base+i)]);
        if i<>0 then print(",");
     end;
     print("}");
     end;

   active_compile;
   define(ocp_active_min_ptr_base, data, active_min_ptr);
   define(ocp_active_max_ptr_base, data, active_max_ptr);
end;

@ @<Declare subprocedures for |prefixed_command|@>=
procedure do_pop_ocp_list(@!a:small_number);
var old_number:halfword;
    i:integer;
begin
   old_number:=equiv(ocp_active_number_base);
   if old_number=0 then
   begin
      print_err("No active ocp lists to be popped");
   end
   else
      define(ocp_active_number_base, data, (old_number-1));

if equiv(ocp_trace_level_base)=1 then begin
     print_nl("New active ocp list: {");
     for i:=(old_number-2) downto 0 do
     begin
        print_esc(ocp_list_id_text(equiv(ocp_active_base+i)));
        print("="); print_ocp_list(ocp_list_list[equiv(ocp_active_base+i)]);
        if i<>0 then print(",");
     end;
     print("}");
  end;

   active_compile;
   define(ocp_active_min_ptr_base, data, active_min_ptr);
   define(ocp_active_max_ptr_base, data, active_max_ptr);
end;

@ @<Declare subprocedures for |prefixed_command|@>=
procedure do_clear_ocp_lists(@!a:small_number);
begin
   define(ocp_active_number_base, data, 0);
   active_compile;
   define(ocp_active_min_ptr_base, data, active_min_ptr);
   define(ocp_active_max_ptr_base, data, active_max_ptr);
end;

@z
%---------------------------------------
