\font\ninerm=cmr9
\let\mc=\ninerm % medium caps for names like PASCAL
\def\MWEB{{\tt MWEB}}
\def\PASCAL{{\mc PASCAL}}
\def\mo2{{\mc Modula-2}}
\def\[{\ifhmode\ \fi$[\![$}
\def\]{$]\!]$\ }
\def\<{$\langle\,$}
\def\>{$\,\rangle$}
\def\sec{{\tensy x}}
\def\title{Tablehandler}

@* Table Handler: An example of \MWEB.
The following program is based on the TableHandler module in
@^Wirth,Niklaus @>
Niklaus Wirth's {\it Programming in Modula-2}. 
This is the implementation module;
the definition module is in a separate source file.
@p 
implementation @+module table_handler ;
@<Import List@>@;
const @<Constants of the module@>@;
type @<Global types@>@;

@ We are going to be doing some string handling, so we need to import 
some things from the Logitech module |Strings|. 
The boxes signify words that must not be forced to 
uppercase when the program is \.{MANGLED}, since \mo2\ is case-sensitive.
@d length_of_string==@= Length @> (* get the length of a string *)
@d copy_string==@= Assign @> (* Assign one string to another *)
@<Import List@>=
from @= Strings @> import length_of_string,copy_string;

@ @<Constants of the module@>=

@!max_card = 65535;

@ This is the format of the an entry in the symbol table tree. As 
we define the record type,
we define a few symbols to make it easier to access the fields.
@d symbol_ptr==p^.str
@d symbol_defined==p^.defined
@d symbol_value==p^.num
@d left_sub_tree==p^.left
@d right_sub_tree==p^.right
@<Global types@>=
@!treeptr = pointer to tree_record ;
@!tree_record = record
   @!str : symbol_string_ptr ;
   @!num : cardinal ;
   @!defined : boolean;
   @!left, @!right : treeptr ;
end ;
@  We define a structure containing information application to an entire 
table.
@d head_of_table==the_table^.the_tree^.right
@<Global types@>=
@!table_record = record
   @!next_entry : cardinal ;
   @!the_tree : treeptr ;
   @!user_err_routine : error_proc;
   @!last_entry_found : treeptr ;
   @!case_sensitive : boolean;
end ;
@!tableptr = pointer to table_record ;
@!symbol_table = tableptr ;

@ Since we intend to do 
heap operations, it might help to import
the |allocate| and |deallocate| procedures from standard module |Storage|.
We define a macro to determine if a given amount of space is available.
@d mem_available==@= Available @>
@d enough_memory(#)==mem_available(#)
@<Import List@>=
from @= Storage @> import @!allocate,@!deallocate,mem_available; @/
from @!system import @!tsize;

@* Main Table Lookup Procedure.
This is the main symbol table lookup procedure, the one visible to the
calling program. If the entry does not exist it is created.
@p
procedure get_value_of_symbol ( @!the_table: symbol_table;
@!target_symbol : array of char ; 
@!this_is_a_definition : boolean ; 
@+var @+@!string_ptr : symbol_string_ptr) : cardinal ;@/

@<Procedures local to |get_value_of_symbol| @>

   var

   @!p : treeptr ;   @!n : cardinal;
   @!current_symbol : symbol_string  ;

begin
   the_table^.last_entry_found := nil;
   copy_string(target_symbol,current_symbol) ;
   @<If table is not case-sensitive, force string to uppercase@>;
   p := search(the_table^.the_tree) ;
   if p = nil then
      the_table^.user_err_routine(memory_exhausted,' ');
      @/ return max_card;
   else
      @<If this is a definition, check for duplicates@>@;
      @<If name has been referenced before definition, reset the value@>@;
      string_ptr := symbol_ptr;
      the_table^.last_entry_found := p;
      @/ return symbol_value;
   end;
end get_value_of_symbol ;

@ @<If table is not case-sensitive, force string to uppercase@>=
if not the_table^.case_sensitive then
   for n := 0 to length_of_string(current_symbol) - 1 do
      current_symbol[n] := cap(current_symbol[n]);
   end;
end;
@ @<If this is a definition, check for duplicates@>=
      if this_is_a_definition then
        if symbol_defined then
           the_table^.user_err_routine(duplicate_symbol,current_symbol);
           @/ return max_card;
        else
          symbol_defined := true;
        end;
      end;
@ @<If name has been referenced before definition, reset the value@>=
      if symbol_value = max_card then
         symbol_value := the_table^.next_entry ;
         inc(the_table^.next_entry) ;
      end;
@ This function procedure returns with a pointer to either the entry matching 
the target symbol or a newly created entry if no match is found.
@<Procedures local to |get_value_of_symbol| @>=
procedure search(@!p : treeptr) : treeptr ;



   var

   @!q : treeptr ;
   @!r : relation ;
   @!i : cardinal ;
   @!slen : cardinal ;



begin
   q := right_sub_tree ;
   r := greater ;
   while q <>  nil do
      p := q ;
      r := relation_of(symbol_ptr) ;
      if r = equal then
         return p
      elsif r = less then
         q := left_sub_tree
      else
         q := right_sub_tree
      end
   end ;
@<Create new table entry@>;
   return q ;
end search ;

@ We have to create a new  entry in the symbol table. First we allocate the
space for the entry using the standard function |new|. Then we initialize the 
fields. Finally we allocate space for the string itself and copy it.
@d initialize_entry(#)==
 # := nil ;
 if enough_memory(tsize(tree_record)) then
   new(#) ;
   with #^ do
      str := nil ;
      left := nil ;
      right := nil;
      defined := false;
      num := max_card;
   end;
 else
   the_table^.user_err_routine(memory_exhausted,' ');
 end;
@<Create new table entry@>=
 q := nil;
 slen := length_of_string(current_symbol) + 1;
 if enough_memory(tsize(tree_record)+slen) then
   initialize_entry(q) ;
   with q^ do
     allocate(str,slen) ;
     copy_string(current_symbol,str^) ;
   end ;
   @<Put this new entry on proper subtree@>;
 else
   the_table^.user_err_routine(memory_exhausted,' ');
 end;
@ @<Put this new entry on proper subtree@>=
      if r = less then
         left_sub_tree := q ;
      else
         right_sub_tree := q ;
      end ;
@ @<Global types@>=
   @!relation =(less, equal, greater) ;

@ This function procedure determines the relationship |(less, equal, greater)|
of the string |current_symbol| to that of the current table entry (pointed to by 
|k|).
@<Procedures local to |get_value_of_symbol| @>=
   procedure relation_of(@!k : symbol_string_ptr) : relation ;


      var

      @!i : cardinal ;
      @!r : relation ; @!x, @!y : char ;

   begin
      i := 0 ;
      r := equal ;

      loop
         x := current_symbol[i] ;
         y := k^[i] ;
         if cap(x) <>  cap(y) then
            exit;
         end ;
         if x <= ' ' then
            return r
         end ;
         if x < y then
            r := less
         elsif x > y then
            r := greater
         end ;
         i := i + 1 ;
      end ;
      @<Return the result of the comparison@>;
   end relation_of ;

@ @<Return the result of the comparison@>=
      if cap(x) > cap(y) then
         return greater
      else
         return less
      end;
@ We provide a procedure to set the table entry to a specific value.
@p
procedure set_value_of_symbol ( @!the_table: symbol_table;
@!target_symbol : array of char ; 
@!this_is_a_definition : boolean ; 
@+var@+ @+@!string_ptr : symbol_string_ptr;the_val : cardinal) ;
var @!ent : cardinal;
begin
the_table^.last_entry_found := nil ;
ent := get_value_of_symbol ( the_table,target_symbol,this_is_a_definition,
                    string_ptr);
if the_table^.last_entry_found <> nil then
  the_table^.last_entry_found^.num := the_val ;
end;
end set_value_of_symbol ;

@ We provide a function procedure to determine if a particular symbol has been
defined.
@p
procedure symbol_is_defined ( @!the_table: symbol_table;
@!target_symbol : array of char ) : boolean ;
var @!ent : cardinal; @!string_ptr : symbol_string_ptr;
begin
the_table^.last_entry_found := nil ;
ent := get_value_of_symbol ( the_table,target_symbol,false,string_ptr);
if the_table^.last_entry_found <> nil then
  return the_table^.last_entry_found^.defined;
else
  return false;
end;
end symbol_is_defined ;

@* Undefined Symbol Check.
This procedure checks the integretity of the table by searching for entries
that have been referenced, but never defined.  It calls 
|this_node_is_undefined| with
the pointer to the root node, and |this_node_is_undefined| will recursively 
check each
entry in the tree for undefined symbols, eventually returning with a boolean
value containing the result of the search.  If undefined symbols are found,
the user-supplied error routine is called for each.
@p
procedure undefined_symbols_in_table(@!the_table: symbol_table; 
      @!undefined_symbol_handling_routine :error_proc) : boolean;@/

@<Procedure to check an individual node@>

begin
   return this_node_is_undefined(head_of_table);
end undefined_symbols_in_table;
@ This procedure checks an individual tree entry for undefined symbols.  It 
also calls itself recursively to check the subtrees below it for the same
condition.  If this node or any sub-nodes has a undefined symbol, then the
result for this node is true.
This procedure must be
declared as a local procedure to  |undefined_symbols_in_table|, because the 
user-supplied |undefined_symbol_handling_routine| only exists 
within the scope of |undefined_symbols_in_table|.
@<Procedure to check an individual node@>=
   procedure this_node_is_undefined(@!p : treeptr) : boolean;

   var @!undefined_was_found,@!undefined_symbol_in_left_subtree ,
          @!undefined_symbol_in_right_subtree : boolean;

   begin
        undefined_was_found := false;
	if p <> nil then
	    if not symbol_defined then
          undefined_symbol_handling_routine(undefined_symbol,symbol_ptr^);
	    end;
            undefined_symbol_in_left_subtree := 
                           this_node_is_undefined(left_sub_tree) ;
            undefined_symbol_in_right_subtree := 
                           this_node_is_undefined(right_sub_tree);@/
            undefined_was_found := (not symbol_defined) or 
                           undefined_symbol_in_left_subtree or 
                           undefined_symbol_in_right_subtree;
	end;
        return undefined_was_found ;
   end this_node_is_undefined;



@* Table Search Procedures. 
The following procedures are used to perform a
user-provided operation on every entry in the table.
@p
procedure search_symbol_table(@!the_table: symbol_table;
     @!user_action_routine : table_proc) ;@/

@<Procedure to search an individual node@>


begin
   search_a_node(head_of_table); 
end search_symbol_table;

@ This procedure searches an individual node and all of the nodes below it.
As each node is processed, a user-provided procedure is called, with the 
value stored with this name as a parameter.  The user procedure is free to
perform any operation it wishes.  
The nodes are processed alphabetically, 
because this procedure will perform the processing on its left subtree before
its own processing, followed by the right subtree.  This procedure must be
declared as a local procedure to  |search_symbol_table|, because the 
user-supplied |user_action_routine| only exists 
within the scope of |search_symbol_table|.
@<Procedure to search an individual node@>=
   procedure search_a_node(@!p : treeptr) ;


   begin
	if p <> nil then
            search_a_node(left_sub_tree);
	    user_action_routine(symbol_value,symbol_ptr,symbol_defined);
            search_a_node(right_sub_tree);
	end;
   end search_a_node;


@* Table Deletion Procedures. 
The following procedures are used to delete the
table and free the memory allocated to it.
@p
procedure delete_symbol_table(var @!the_table: symbol_table);



begin
 if the_table <> nil then
   delete_a_node(head_of_table); 
   dispose(the_table);
   the_table := nil;
 end;
end delete_symbol_table;
@ This procedure first deletes the subtrees below it, then deletes itself.
@p
   procedure delete_a_node(var @!p : treeptr) ;

   var @!slen : cardinal ;


   begin
   if p <> nil then
            with p^ do
               delete_a_node(left);
               delete_a_node(right);
               slen := length_of_string(str^) + 1;
               deallocate(str,slen) ;
	    end;
   	    dispose(p) ;
	    p := nil ;
	end;
   end delete_a_node;

@* Table Initialization. 
The following procedure is used to create a symbol table.
@p
procedure create_symbol_table(var @!the_table: symbol_table  ;
@!case_sens : boolean; @!user_error_routine :error_proc);

begin
   @<Initialize the symbol table@>@;
end create_symbol_table;
@ To initialze the symbol table, we create a root node with initialized 
fields. The right node of this entry is the head of the table.
@<Initialize the symbol table@>=
 if enough_memory(tsize(table_record)+tsize(tree_record)) then
   new(the_table) ;
   with the_table^ do
     user_err_routine :=  user_error_routine ;
     initialize_entry(the_tree) ;
     next_entry := 0 ;
     case_sensitive := case_sens;
   end;
 else
   user_error_routine(memory_exhausted,' ');
 end;
@ The following procedure is used to change the user-defined error handler for
a symbol table.
@p
procedure set_error_handler(@!the_table: symbol_table ;
@!user_error_routine :error_proc);

begin
   the_table^.user_err_routine :=  user_error_routine ;
end set_error_handler;
@ Here is the end of the module.
@p
end table_handler.

@* Index. Here is the index of names.