home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / lisp / eulisp / mpfeel.lha / MPFeel / table.c < prev    next >
Encoding:
C/C++ Source or Header  |  1992-10-06  |  14.4 KB  |  590 lines
  1. /* ******************************************************************** */
  2. /*  table.c          Copyright (C) Codemist and University of Bath 1989 */
  3. /*                                                                      */
  4. /*  "hash" tables                                                       */
  5. /* ******************************************************************** */
  6.  
  7. /*
  8.  * $Id: table.c,v 1.10 1992/01/29 13:50:50 pab Exp $
  9.  *
  10.  * $Log: table.c,v $
  11.  * Revision 1.10  1992/01/29  13:50:50  pab
  12.  * vax fix
  13.  *
  14.  * Revision 1.9  1992/01/17  22:32:50  pab
  15.  * fixed hash problemette
  16.  *
  17.  * Revision 1.8  1992/01/10  15:16:24  pab
  18.  * macroised total_hash
  19.  *
  20.  * Revision 1.7  1992/01/09  22:29:09  pab
  21.  * Fixed for low tag ints
  22.  *
  23.  * Revision 1.6  1992/01/07  22:15:46  pab
  24.  * ncc compatable, plus backtrace
  25.  *
  26.  * Revision 1.5  1992/01/05  22:48:29  pab
  27.  * Minor bug fixes, plus BSD version
  28.  *
  29.  * Revision 1.4  1991/12/22  15:14:42  pab
  30.  * Xmas revision
  31.  *
  32.  * Revision 1.3  1991/09/22  19:14:42  pab
  33.  * Fixed obvious bugs
  34.  *
  35.  * Revision 1.2  1991/09/11  12:07:48  pab
  36.  * 11/9/91 First Alpha release of modified system
  37.  *
  38.  * Revision 1.1  1991/08/12  16:50:08  pab
  39.  * Initial revision
  40.  *
  41.  * Revision 1.4  1991/02/14  11:27:51  kjp
  42.  * Boosted table efficiency by inlining eq among other stuff.
  43.  *
  44.  */
  45.  
  46. #define KJPDBG(x) 
  47.  
  48. /*
  49.  * Change Log:
  50.  *   Version 1, April 1989
  51.  *        Syntax fixes - JPff
  52.  *        Name changes - RJB
  53.  *        Fixed the copy functions - KJP ( 17/10/89 )
  54.  *        Arbitrary lisp functions - KJP ( 27/9/90 )
  55.  */
  56.  
  57. /* "Tables provide a general key to value association mechanism.
  58.  *  Operationally, tables resemble hashtables, but the actual
  59.  *  representation is not defined in order to permit alternative
  60.  *  solutions, such as various forms of balanced trees."
  61.  
  62.  * (tablep obj) -> { t | nil }
  63.  * (make-table [comparator]) -> table                comparator is an "equal"
  64.  * (table-parameters table) -> multiple-value
  65.  * (tref table key) -> obj
  66.  * ((set tref) table key obj) -> nil
  67.  * (map-table table function) -> nil
  68.  */
  69.  
  70. /* How about: a "table" is a balanced tree of some sorts: use a VECTOR
  71.  * [key, value, hash, left, right]
  72.  * and use the hash to binary chop.
  73.  */
  74.  
  75. #include "funcalls.h"
  76. #include "defs.h"
  77. #include "structs.h"
  78. #include "error.h"
  79. #include "global.h"
  80. #include "modboot.h"
  81.  
  82. #include "ngenerics.h"
  83.  
  84. #include "calls.h"
  85.  
  86. #define TABLES_ENTRIES 11
  87. MODULE Module_tables;
  88. LispObject Module_tables_values[TABLES_ENTRIES];
  89.  
  90. #define TKEY(node)    vref((node),0)
  91. #define TVALUE(node)  vref((node),1)
  92. #define THASH(node)   intval(vref((node),2))
  93. #define TLEFT(node)   vref((node),3)
  94. #define TRIGHT(node)  vref((node),4)
  95.  
  96. #define total_hash(x) (is_symbol(x)? x->SYMBOL.hash: total_hash_fn(x))
  97.  
  98. /* Comparison with optimisation */
  99.  
  100. #define TCOMPARE(tab,k1,k2) \
  101.           (tab->comparator == Fn_eq \
  102.              ? k1 == k2 \
  103.          : (tab->comparator == NULL \
  104.           ? EUCALL_3(apply2,tab->lisp_comparator,k1,k2) != nil \
  105.           : EUCALL_2((*(tab->comparator)),k1,k2) != nil))
  106.  
  107. /* slow but fun hash from gdbm */
  108.  
  109. int
  110. hash (char *dptr)
  111. {
  112.   int  value;        /* Used to compute the hash value.  */
  113.   int  index;        /* Used to cycle through random values. */
  114.  
  115.  
  116.   /* Set the initial value from key. */
  117.   value = 0x238F13AF;
  118.   for (index = 0; index<10&&dptr[index]!='\0'; index++)
  119.     value = (value + (dptr[index] << (index*5 % 24))) & 0x7FFFFFFF;
  120.  
  121.   value = (1103515243 * value + 12345) & 0x7FFFFFFF;  
  122.  
  123.   /* Return the value. */
  124.   return value;
  125. }
  126.  
  127.  
  128. static int total_hash_fn(LispObject x)
  129. {
  130.   switch (typeof(x)) {
  131.   case TYPE_CLASS:
  132.     x=x->CLASS.name; /* and fall through */
  133.    case TYPE_SYMBOL:
  134.     return x->SYMBOL.hash;
  135.    case TYPE_INT:
  136.     return(intval(x));
  137.    case TYPE_FLOAT:
  138.     return((int) (x->FLOAT.fvalue));
  139.   }
  140.  
  141.   /* No dice - linear search */
  142.  
  143.   return(0); 
  144. }
  145.  
  146. EUFUN_1( Fn_tablep, x)
  147. {
  148.   if (is_table(x)) return lisptrue;
  149.   return nil;
  150. }
  151. EUFUN_CLOSE
  152.  
  153. extern LispObject Gf_equal(LispObject*);
  154.  
  155. EUFUN_1( Fn_make_table, forms)
  156. {
  157.   extern LispObject function_eq;
  158.   struct table_structure* new_table;
  159.  
  160.   if (forms == nil) 
  161.     new_table = &allocate_table(stacktop,Fn_eq)->TABLE;
  162.   else {
  163.     LispObject fn;
  164.  
  165.     fn = CAR(forms);
  166.  
  167.     if (fn == function_eq) 
  168.       new_table = &allocate_table(stacktop,Fn_eq)->TABLE;
  169.     else {
  170.       new_table = &allocate_table(stacktop,NULL)->TABLE;
  171.       new_table->lisp_comparator = CAR(ARG_0(stackbase));
  172.     }
  173.   }
  174.   
  175.   return((LispObject) new_table);
  176. }
  177. EUFUN_CLOSE
  178.  
  179. /* temporary while we work out multiple values */
  180. LispObject table_params_kludge;
  181.  
  182. void cons_up_table_params(LispObject *stacktop, LispObject table)
  183. {
  184.  top:
  185.   if (null(table)) return;
  186.   cons_up_table_params(stacktop,TLEFT(table));
  187.   EUCALLSET_2(table_params_kludge,Fn_cons, TVALUE(table), table_params_kludge);
  188.   table = TRIGHT(table);
  189.   goto top;
  190. }
  191.  
  192. extern void cons_up_table_keys(LispObject*,LispObject);
  193.  
  194. void cons_up_table_keys(LispObject *stacktop, LispObject table)
  195. {
  196.  top:
  197.   if (null(table)) return;
  198.   STACK_TMP(table);
  199.   cons_up_table_keys(stacktop,TLEFT(table));
  200.   UNSTACK_TMP(table);
  201.   STACK_TMP(table);
  202.   EUCALLSET_2(table_params_kludge,Fn_cons, TKEY(table), table_params_kludge);
  203.   UNSTACK_TMP(table);
  204.   table = TRIGHT(table);  
  205.   goto top;
  206. }
  207.  
  208. /* return a multiple value of all the values in the table */
  209. EUFUN_1( Fn_table_parameters, table)
  210. {
  211.   while (!is_table(table))
  212.     table = CallError(stacktop,"table-parameters: ~a is not a table", table,
  213.               CONTINUABLE);
  214.   table_params_kludge = nil;
  215.   cons_up_table_params(stacktop,table->TABLE.tree);
  216.   return table_params_kludge;
  217. }
  218. EUFUN_CLOSE
  219.  
  220. /* Usefull ?? */
  221. EUFUN_1( Fn_table_keys, table)
  222. {
  223.   if (table == nil) return(nil); /* HACK !! */
  224.   table_params_kludge = nil;
  225.   cons_up_table_keys(stacktop,table->TABLE.tree);
  226.   return table_params_kludge;
  227. }
  228. EUFUN_CLOSE
  229.  
  230. /* Look for key in table. Return nil if not found */
  231. static LispObject traverse_table(LispObject *stacktop, struct table_structure* table,
  232.               LispObject key)
  233. {
  234.   LispObject node = nil;
  235.   int hashval;
  236.  
  237.   hashval = total_hash(key);
  238.   node = table->tree;
  239.   do {
  240.     if (null(node)) {        /* end of tree - key not found */
  241.       return nil;
  242.     }
  243.  
  244.     if (TCOMPARE(table,TKEY(node),key)) {
  245.       return TVALUE(node);
  246.     }
  247.     if (hashval < THASH(node)) node = TLEFT(node);
  248.     else node = TRIGHT(node);
  249.   } while (TRUE);
  250.  
  251.   return(nil);
  252. }
  253.  
  254. static LispObject traverse_eq_table(LispObject *stacktop, struct table_structure* table,
  255.                     LispObject key)
  256. {
  257.   LispObject node = nil;
  258.   int hashval;
  259.  
  260.   hashval = total_hash(key);
  261.   node = table->tree;
  262.   do {
  263.     if (null(node)) {        /* end of tree - key not found */
  264.       return nil;
  265.     }
  266.  
  267.     if (TKEY(node)==key) {
  268.       return TVALUE(node);
  269.     }
  270.     if (hashval < THASH(node)) node = TLEFT(node);
  271.     else node = TRIGHT(node);
  272.   } while (TRUE);
  273.  
  274.   return(nil);
  275. }
  276.  
  277. EUFUN_2( Fn_tref, table, key)
  278. {
  279.   LispObject ans;
  280.  
  281.   while (!is_table(table))
  282.     table = CallError(stacktop,"tref: ~a is not a table", table, CONTINUABLE);
  283.   if (table->TABLE.comparator == Fn_eq)
  284.     ans = traverse_eq_table(stacktop, (struct table_structure*) table, key);
  285.   else
  286.     ans = traverse_table(stacktop, (struct table_structure*)table, key);
  287.   return ans;
  288. }
  289. EUFUN_CLOSE
  290.  
  291. LispObject insert_tree(LispObject *stacktop,struct table_structure* table,
  292.                LispObject key, LispObject value)
  293. {
  294.   LispObject node = nil, prev = nil;
  295.   int hashval, direction = 0;
  296.  
  297.   hashval = total_hash(key);
  298.   node = table->tree;
  299.   STACK_TMPV(table);
  300.   STACK_TMP(prev);
  301.   do {
  302.     if (null(node))
  303.       {        /* new node */
  304.     LispObject tmp;
  305.  
  306.     STACK_TMP(value);  STACK_TMP(key);
  307.     node = (LispObject)allocate_vector(stacktop,5);
  308.     UNSTACK_TMP(key);  TKEY(node) = key;
  309.     UNSTACK_TMP(value); TVALUE(node) = value;
  310.     STACK_TMP(node);
  311.     tmp = allocate_integer(stacktop,hashval); /* room for int */
  312.     UNSTACK_TMP(node);
  313.     vref(node,2)=tmp;
  314.     TLEFT(node) = nil;
  315.     TRIGHT(node) = nil;
  316.     UNSTACK_TMP(prev);
  317.     if (prev == nil) 
  318.       {    /* new tree */
  319.         UNSTACK_TMP(tmp);
  320.         table= &tmp->TABLE;
  321.         table->tree = node;
  322.         return nil;
  323.       }
  324.     STACK_TMP(prev);
  325.     if (direction == 1)
  326.       {    /* should balance here */
  327.         TRIGHT(prev) = node;
  328.       }
  329.     else
  330.       {
  331.         TLEFT(prev) = node;
  332.       }
  333.     return nil;
  334.       }
  335.     if (hashval == THASH(node) && TCOMPARE(table,TKEY(node),key)) {
  336.       LispObject old = TVALUE(node);
  337.  
  338.       TVALUE(node) = value;
  339.       return old;
  340.     }
  341.     UNSTACK_TMP(prev);
  342.     prev = node;
  343.     STACK_TMP(prev);
  344.     if (hashval < THASH(node))
  345.       {
  346.     direction = -1;
  347.     node = TLEFT(node);
  348.       }
  349.     else 
  350.       {
  351.     direction = 1;
  352.     node = TRIGHT(node);
  353.       }
  354.   } while (TRUE);
  355.  
  356.   return(nil);
  357. }
  358.  
  359. EUFUN_3( tref_updator, table, key, value)
  360. {
  361.   LispObject old;
  362.  
  363.   KJPDBG(  fprintf( stderr, "\n'tref_updator' with table %lX ", table ) );
  364.   
  365.   while(!is_table(table))
  366.     table = CallError(stacktop,
  367.               "tref-updator: ~a is not a table", table, CONTINUABLE);
  368.   key = ARG_1(stackbase); value = ARG_2(stackbase);
  369.   old = insert_tree(stacktop, (struct table_structure*)table, key, value);
  370.  
  371.   return old;
  372. }
  373. EUFUN_CLOSE
  374.  
  375. EUFUN_2( map_table, node, proc)
  376. {
  377. /* proc was stacked by Fn_map_table, and node is accessible through
  378.  * the table. Thus this function should only be called from Fn_map_table.
  379.  */
  380.   if (!null(TLEFT(node)))
  381.     EUCALL_2(map_table,TLEFT(node), proc);
  382.   proc = ARG_1(stackbase);
  383.   node = ARG_0(stackbase);
  384.   EUCALL_3(apply2,proc,TKEY(node),TVALUE(node));
  385.   proc = ARG_1(stackbase);
  386.   node = ARG_0(stackbase);
  387.  
  388.   stacktop = stackbase;
  389.   if (!null(TRIGHT(node)))
  390.     EUCALL_2(map_table, TRIGHT(node), proc);
  391.   return nil;
  392. }
  393. EUFUN_CLOSE
  394.  
  395. EUFUN_2( Fn_map_table, proc, table)
  396. {
  397.   LispObject node = nil;
  398.  
  399.   while (!is_table(table))
  400.     table = CallError(stacktop,
  401.               "map-table: ~a is not a table", table, CONTINUABLE);
  402.   ARG_1(stackbase) = table;
  403.   proc = ARG_0(stackbase);
  404.   while (!is_function(proc))
  405.     proc = CallError(stacktop,
  406.              "map-table: ~a is not a function", proc, CONTINUABLE);
  407.   table = ARG_1(stackbase);
  408.   node = (table->TABLE).tree;
  409.   if (!null(node)) {
  410.     STACK_TMP(node);
  411.     EUCALL_3(apply2,ARG_0(stackbase)/*proc*/,TKEY(node),TVALUE(node));
  412.     UNSTACK_TMP(node);
  413.     STACK_TMP(node);
  414.     if (!null(TLEFT(node)))
  415.       EUCALL_2(map_table, TLEFT(node), ARG_0(stackbase)/*proc*/);
  416.     UNSTACK_TMP(node);
  417.     if (!null(TRIGHT(node)))
  418.       EUCALL_2(map_table, TRIGHT(node), ARG_0(stackbase)/*proc*/);
  419.   }
  420.   return nil;
  421. }
  422. EUFUN_CLOSE
  423.  
  424. void table_copy_aux(LispObject *stacktop, LispObject node, LispObject new)
  425. {
  426. /*  LispObject node; */
  427. /*  node = old->TABLE.tree; */
  428.   if (!null(node)) {
  429.     fprintf(stderr, "copying "); 
  430.     STACK_TMP(new);
  431.     STACK_TMP(node);
  432.     EUCALL_2(Fn_print, TKEY(node), NULL);
  433.     UNSTACK_TMP(node);
  434.     STACK_TMP(node);
  435.     EUCALL_2(Fn_print, TVALUE(node), NULL);
  436.     UNSTACK_TMP(node);
  437.     UNSTACK_TMP(new);
  438.     STACK_TMP(new);
  439.     STACK_TMP(node);
  440.     EUCALL_3(tref_updator, new, TKEY(node), TVALUE(node));
  441.     KJPDBG( fprintf( stderr, "Tref updated the new table\n" ) );
  442.     if (!null(TLEFT(node))) {
  443.       UNSTACK_TMP(node);
  444.       UNSTACK_TMP(new);
  445.       STACK_TMP(new);
  446.       STACK_TMP(node);
  447.       table_copy_aux(stacktop,TLEFT(node), new);
  448.       UNSTACK_TMP(node);
  449.       UNSTACK_TMP(new);
  450.       STACK_TMP(new);
  451.       STACK_TMP(node);
  452.     }
  453.     if (!null(TRIGHT(node))) {
  454.       UNSTACK_TMP(node);
  455.       UNSTACK_TMP(new);
  456.       table_copy_aux(stacktop,TRIGHT(node), new);
  457.     }
  458.   }
  459.   return;
  460. }
  461.  
  462. EUFUN_1( table_copy, table)
  463. {
  464.   LispObject ans;
  465.  
  466.   ans = (LispObject) allocate_table(stacktop,table->TABLE.comparator);
  467.   ans->TABLE.lisp_comparator = table->TABLE.lisp_comparator;
  468.  
  469.   table_copy_aux(stacktop,table->TABLE.tree, ans);
  470.  
  471.   return ans;
  472. }
  473. EUFUN_CLOSE
  474.  
  475. EUFUN_1( Fn_clear_table, table)
  476. {
  477.   while (!is_table(table))
  478.     table = CallError(stacktop,"clear-table: ~a is not a table", table,
  479.               CONTINUABLE);
  480.   table->TABLE.tree = nil;
  481.   return table;
  482. }
  483. EUFUN_CLOSE
  484.  
  485. /* This function is not used by anyone!!!
  486. void put_table(LispObject *stacktop, LispObject tab1, LispObject tab2 )
  487. {
  488.   if ( tab1 == nil )
  489.     return;
  490.   else
  491.     table_copy_aux(stacktop,tab1->TABLE.tree, tab2);
  492. }
  493. */
  494.  
  495. LispObject sym_table_copy;
  496.  
  497. /* Printing... */
  498.  
  499. EUFUN_2( Md_generic_prin_Table, tab, stream)
  500. {
  501.   extern LispObject Gf_generic_prin(LispObject*);
  502.  
  503.   if (!is_stream(stream))
  504.     CallError(stacktop,
  505.           "generic-prin: non-stream argument",stream,NONCONTINUABLE);
  506.  
  507.   /* We assume the table's what it claims to be... */
  508.  
  509.   if (tab->TABLE.comparator == NULL) {
  510.     fprintf(stream->STREAM.handle,"#T(comparator: ");
  511.     EUCALL_2(Gf_generic_prin,tab->TABLE.lisp_comparator,stream);
  512.     stream = ARG_1(stackbase);
  513.     fprintf(stream->STREAM.handle,")");
  514.   }
  515.   else {
  516.     if (tab->TABLE.comparator == Fn_eq)
  517.       fprintf(stream->STREAM.handle,"#T(eq)");
  518.     else
  519.       fprintf(stream->STREAM.handle,"#T(equal)");
  520.   }
  521.  
  522.   return(tab);
  523. }
  524. EUFUN_CLOSE
  525.  
  526. /* Writing... */
  527.  
  528. EUFUN_2( Md_generic_write_Table, tab, stream)
  529. {
  530.   extern LispObject Gf_generic_prin(LispObject*);
  531.  
  532.   if (!is_stream(stream))
  533.     CallError(stacktop,
  534.           "generic-write: non-stream argument",stream,NONCONTINUABLE);
  535.  
  536.   /* We assume the table's what it claims to be... */
  537.  
  538.   if (tab->TABLE.comparator == NULL) {
  539.     fprintf(stream->STREAM.handle,"#T(comparator: ");
  540.     EUCALL_2(Gf_generic_prin,tab->TABLE.lisp_comparator,stream);
  541.     stream = ARG_1(stackbase);
  542.     fprintf(stream->STREAM.handle,")");
  543.   }
  544.   else {
  545.     if (tab->TABLE.comparator == Fn_eq)
  546.       fprintf(stream->STREAM.handle,"#T(eq)");
  547.     else
  548.       fprintf(stream->STREAM.handle,"#T(equal)");
  549.   }
  550.  
  551.   return(tab);
  552. }
  553. EUFUN_CLOSE
  554.  
  555. void initialise_tables(LispObject *stacktop)
  556. {
  557.   extern LispObject generic_generic_prin;
  558.   extern LispObject generic_generic_write;
  559.   LispObject fun, upd;
  560.  
  561.   open_module(stacktop,
  562.           &Module_tables,
  563.           Module_tables_values,
  564.           "tables",
  565.           TABLES_ENTRIES);
  566.  
  567.   (void) make_module_function(stacktop,"tablep",Fn_tablep,1);
  568.   (void) make_module_function(stacktop,"make-table",Fn_make_table,-1);
  569.   (void) make_module_function(stacktop,"table-parameters",Fn_table_parameters,1);
  570.   fun = make_module_function(stacktop,"table-ref",Fn_tref,2);
  571.   STACK_TMP(fun);
  572.   upd = make_unexported_module_function(stacktop,"table-ref-updator", tref_updator, 3);
  573.   UNSTACK_TMP(fun);
  574.   set_anon_associate(stacktop,fun, upd);
  575.  
  576.   (void) make_module_function(stacktop,"map-table",Fn_map_table,2);
  577.   sym_table_copy = make_module_function(stacktop,"copy-table", table_copy, 1);
  578.   add_root(&sym_table_copy);
  579.   sym_table_copy = sym_table_copy->SYMBOL.lvalue;
  580.   add_root(&sym_table_copy);
  581.  
  582.   (void) make_module_function(stacktop,"table-keys",Fn_table_keys,1);
  583.   (void) make_module_function(stacktop,"clear-table",Fn_clear_table,1);
  584.  
  585.   make_module_function(stacktop,"generic_generic_prin,Table",Md_generic_prin_Table,2);
  586.   make_module_function(stacktop,"generic_generic_write,Table",Md_generic_write_Table,2);
  587.   
  588.   close_module();
  589. }
  590.