home *** CD-ROM | disk | FTP | other *** search
/ OS/2 Shareware BBS: 22 gnu / 22-gnu.zip / gwm18a.zip / wl_atom.c < prev    next >
C/C++ Source or Header  |  1995-07-03  |  11KB  |  505 lines
  1. /* Copyright 1989 GROUPE BULL -- See license conditions in file COPYRIGHT
  2.  * Copyright 1989 Massachusetts Institute of Technology
  3.  */
  4. /*********************\
  5. *               *
  6. *  WOOL_OBJECT  Atom  *
  7. *  BODY              *
  8. *               *
  9. \*********************/
  10.  
  11. #include "EXTERN.h"
  12. #include <stdio.h>
  13. #include "wool.h"
  14. #include "wl_coll.h"
  15. #include "wl_number.h"
  16. #include "wl_list.h"
  17. #include "wl_string.h"
  18. #include "wl_pointer.h"
  19. #include "wl_active.h"
  20. #include "wl_name.h"
  21. #include "INTERN.h"
  22. #include "wl_atom.h"
  23.  
  24. /*
  25.  * Constructor:
  26.  * Constructed via the hash table management routines.
  27.  */
  28.  
  29. /*
  30.  * Warning: You should NEVER call WLAtom_make, call wool_atom instead,
  31.  * or your atom won't be in the hash table!
  32.  */
  33.  
  34. WOOL_Atom 
  35. WLAtom_make(p_name, c_val)    /* makes an atom */
  36. char           *p_name;        /* is COPIED to atom's p_name */
  37. WOOL_OBJECT     c_val;        /* is just pointed to */
  38. {
  39.     WOOL_Quark       object = (WOOL_Quark)
  40.     Malloc(sizeof(struct _WOOL_Quark) + strlen(p_name));
  41.  
  42.     object -> type = WLAtom;
  43.     zrt_put(&(object -> type));
  44.     strcpy(object -> p_name, p_name);
  45.     object -> c_val = c_val;
  46.     if (c_val)
  47.     increase_reference(c_val);
  48.     return (WOOL_Atom) &(object -> type);
  49. }
  50.  
  51. WOOL_OBJECT
  52. WLAtom_equal(a1, a2)
  53. WOOL_Atom a1, a2;
  54. {
  55.     if (a2 != a1)
  56.     return NIL;
  57.     else if (a1 == (WOOL_Atom) NIL)
  58.     return TRU;
  59.     else
  60.     return (WOOL_OBJECT) a1;
  61. }
  62.  
  63. /************************\
  64. *              *
  65. *  hash table routines      *
  66. *              *
  67. \************************/
  68.  
  69. /*
  70.  * Hash function definition:
  71.  * HASH_FUNCTION: hash function, hash = hashcode, hp = pointer on char,
  72.  *                 hash2 = temporary for hashcode.
  73.  * INITIAL_TABLE_SIZE in slots
  74.  * HASH_TABLE_GROWS how hash table grows.
  75.  */
  76.  
  77. /* Mock lisp function */
  78. /*
  79. #define HASH_FUNCTION       hash = (hash << 5) - hash + *hp++;
  80. #define INITIAL_HASH_SIZE 2017
  81. #define HASH_TABLE_GROWS  HashTableSize = HashTableSize * 2;
  82. */
  83.  
  84. /* aho-sethi-ullman's HPJ (sizes should be primes)*/
  85.  
  86. #define HASH_FUNCTION    hash <<= 4; hash += *hp++; \
  87.     if(hash2 = hash & 0xf0000000) hash ^= (hash2 >> 24) ^ hash2;
  88. #define INITIAL_HASH_SIZE 4095    /* should be 2^n - 1 */
  89. #define HASH_TABLE_GROWS  HashTableSize = HashTableSize << 1 + 1;
  90.  
  91. /* GNU emacs function */
  92. /*
  93. #define HASH_FUNCTION       hash = (hash << 3) + (hash >> 28) + *hp++;
  94. #define INITIAL_HASH_SIZE 2017
  95. #define HASH_TABLE_GROWS  HashTableSize = HashTableSize * 2;
  96. */
  97.  
  98. /* end of hash functions */
  99.  
  100. /*
  101.  * The hash table is used to store atoms via their P_NAME:
  102.  *
  103.  * P_NAME --hash--> ATOM |--p_name--> "foo"
  104.  *             |--c_val--> value of the atom (result of eval)
  105.  *
  106.  * if c_val is UNDEFINED, symbol was undefined. If c_val is NULL, 
  107.  * symbol value is NIL. Parsing replaces p_names with ATOMS.
  108.  */
  109.  
  110. int             HashTableSize;
  111. static          HashTableLimit;
  112. static          HashTableUsed;
  113. static WOOL_Atom *HashTable;    /* table of WLAtom objects */
  114.  
  115. /*
  116.  * HashSlot gives the slot (pointer to WOOL_Atom) of a name
  117.  * (slot points to NULL if it is not defined)
  118.  */
  119.  
  120. WOOL_Atom      *
  121. HashSlot(s)
  122. char  *s;
  123. {
  124.     unsigned int hash, hash2;
  125.     WOOL_Atom *p;
  126.     char  *hp = s;
  127.     char  *ns;
  128.  
  129.     hash = 0;
  130.     while (*hp) {        /* computes hash function */
  131.     HASH_FUNCTION
  132.     }
  133.     p = HashTable + hash % HashTableSize;
  134.     while (*p) {
  135.     ns = (*p) -> p_name;
  136.     if (ns[0] == s[0] && strcmp(ns, s) == 0)
  137.         break;
  138.     p--;
  139.     if (p < HashTable)
  140.         p = HashTable + HashTableSize - 1;
  141.     }
  142.     return p;
  143. }
  144.  
  145. HashTableGrows()
  146. {
  147.     WOOL_Atom *t, *p;
  148.     int       i;
  149.     int             OldHashTableSize = HashTableSize;
  150.  
  151.     t = HashTable;
  152.     HASH_TABLE_GROWS
  153.     HashTableLimit = HashTableSize / 3;
  154.     HashTable = (WOOL_Atom *) Malloc(HashTableSize * sizeof(*HashTable));
  155.     for (p = HashTable + HashTableSize; p > HashTable;)
  156.     *--p = NULL;
  157.     for (i = 0; i < OldHashTableSize; i++)
  158.     if (t[i]) {
  159.         WOOL_Atom      *ps = HashSlot(t[i] -> p_name);
  160.  
  161.         *ps = t[i];
  162.     }
  163.     Free(t);
  164. }
  165.  
  166. /*
  167.  * wool_atom(name)
  168.  * return an WOOL_Atom, which is the one at the slot, if present,
  169.  * or is created if name didn't exist, with c_val UNDEFINED. (NULL)
  170.  * This function is called by the parser for each NAME encountered.
  171.  * so that the parsed expression points directly to atoms.
  172.  * The reference count of the atom is set to 1.
  173.  */
  174.  
  175. WOOL_Atom 
  176. wool_atom(tag)
  177. char           *tag;
  178. {
  179.     WOOL_Atom *slot;
  180.  
  181.     if (HashTableUsed >= HashTableLimit)
  182.     HashTableGrows();
  183.     if (!*(slot = HashSlot(tag))) {    /* undefined, make a new one */
  184.     HashTableUsed++;
  185.     increase_reference((*slot = WLAtom_make(tag, UNDEFINED)));
  186.     }
  187.     return *slot;
  188. }
  189.  
  190. /* WLAtom_unbind
  191.  * Removes an atom from the hash table
  192.  */
  193.  
  194. WOOL_OBJECT
  195. WLAtom_unbind(obj)
  196. WOOL_Atom obj;
  197. {
  198.     decrease_reference(obj -> c_val);
  199.     obj -> c_val = UNDEFINED;
  200.     if (obj -> reference_count == 1)
  201.     decrease_reference(obj);
  202.     return NIL;
  203. }
  204.  
  205. /* must be called before allocating any atom
  206.  */
  207.  
  208. HashTable_init()
  209. {
  210.     WOOL_Atom *p;
  211.  
  212.     HashTableSize = INITIAL_HASH_SIZE;
  213.     HashTableLimit = HashTableSize / 3;
  214.     HashTable = (WOOL_Atom *) Malloc(HashTableSize * sizeof(*HashTable));
  215.     for (p = HashTable + HashTableSize; p > HashTable;)
  216.     *--p = NULL;
  217. }
  218.  
  219. #ifdef STATS
  220.  
  221. /*
  222.  * hashstats:
  223.  * statistics about the hash table
  224.  */
  225.  
  226. WOOL_OBJECT 
  227. hashstats()
  228. {
  229.     int             out_of_place;
  230.  
  231.     wool_puts("Statistics about hash table:\n");
  232.     wool_printf("  %d slots used ", HashTableUsed);
  233.     wool_printf("out of %d allocated\n", HashTableSize);
  234.     out_of_place = outplacedslots();
  235.     wool_printf("  and %d slots out of place ", out_of_place);
  236.     wool_printf("(%d %%)\n", (out_of_place * 100) / HashTableUsed);
  237.     return NIL;
  238. }
  239.  
  240. int 
  241. outplacedslots()
  242. {
  243.     WOOL_Atom *slot;
  244.     int    n = 0;
  245.  
  246.     for (slot = HashTable; slot < HashTable + HashTableSize; slot++) {
  247.     if (*slot) {
  248.         unsigned int hash, hash2;
  249.         char  *hp = (*slot) -> p_name;
  250.         char  *ns;
  251.  
  252.         hash = 0;
  253.         while (*hp) {    /* computes hash function */
  254.         HASH_FUNCTION
  255.         }
  256.         ns = (*(HashTable + hash % HashTableSize)) -> p_name;
  257.         if (!(ns[0] == (*slot) -> p_name[0] &&
  258.           strcmp(ns, (*slot) -> p_name) == 0)) {
  259.         n++;
  260.         }
  261.     }
  262.     }
  263.     return n;
  264. }
  265.  
  266. /*
  267.  *  prints the whole hash table
  268.  */
  269.  
  270. WOOL_OBJECT
  271. oblist()
  272. {
  273.     WOOL_Atom *slot;
  274.     int    num = 0;
  275.  
  276.     for (slot = HashTable; slot < HashTable + HashTableSize; slot++) {
  277.     if (*slot) {
  278.         wool_printf("%s ", (*slot) -> p_name);
  279.         if ((*slot) -> type == WLAtom) {
  280.         if (((*slot) -> p_name[0] > ' ') && ((*slot) -> c_val)) {
  281.             wool_printf("(%s): ", (((*slot) -> c_val) -> type)[0]);
  282.             wool_print((*slot) -> c_val);
  283.         }
  284.         } else {
  285.         wool_print(*slot);
  286.         }
  287.         num++;
  288.         wool_newline();
  289.     }
  290.     }
  291.     return (WOOL_OBJECT) WLNumber_make(num);
  292. }
  293.  
  294. #endif /* STATS */
  295.  
  296. /*
  297.  * prints the names of the atoms pointing to this object (or nothing)
  298.  */
  299.  
  300. print_atom_pointing_to(object)
  301. WOOL_OBJECT    object;
  302. {
  303.     WOOL_Atom *slot;
  304.  
  305.     for (slot = HashTable; slot < HashTable + HashTableSize; slot++)
  306.     if (*slot)
  307.         if ((*slot) -> type == WLAtom)
  308.         if ((*slot) -> c_val)
  309.             if ((*slot) -> c_val == object)
  310.             wool_printf("%s ", (*slot) -> p_name);
  311. }
  312.  
  313. #ifdef MLEAK
  314.  
  315. /*
  316.  * gives the atoms with prefix prefix successivly (or NULL on end);
  317.  * re-initialise with a '\0' prefix
  318.  */
  319.  
  320. WOOL_Atom
  321. find_next_prefixed_atom(prefix)
  322. char    prefix;
  323. {
  324.     WOOL_Atom *slot;
  325.     static WOOL_Atom *slot0;
  326.  
  327.     if (prefix == '\0') {
  328.     slot0 = HashTable;
  329.     } else {
  330.     for (slot = slot0; slot < HashTable + HashTableSize; slot++)
  331.         if ((*slot)
  332.         && ((*slot) -> p_name[0] == prefix)
  333.         && ((*slot) -> c_val)) {
  334.         slot0 = slot + 1;
  335.         return (*slot);
  336.         }
  337.     }
  338.     return NULL;
  339. }
  340.  
  341. #endif /* MLEAK */
  342.     
  343. /*
  344.  * XLAtom_eval:
  345.  * evaluating an atom is giving a pointer to its c_val field.
  346.  * an atom returns its value, or calls wool_error if undefined
  347.  * (increase ref. of value)
  348.  */
  349.  
  350. WOOL_OBJECT 
  351. WLAtom_eval(obj)
  352. WOOL_Atom obj;
  353. {
  354.     if (obj -> c_val != UNDEFINED) {
  355.     return obj -> c_val;
  356.     } else
  357.     return wool_error(UNDEFINED_VARIABLE, obj -> p_name);
  358. }
  359.  
  360. WOOL_OBJECT 
  361. WLAtom_silent_eval(obj)
  362. WOOL_Atom obj;
  363. {
  364.     return obj -> c_val;
  365. }
  366.  
  367. /*
  368.  * WLAtom_print:
  369.  * printing an atom is printing the string in the p_name field.
  370.  */
  371.  
  372. WOOL_OBJECT 
  373. WLAtom_print(obj)
  374. WOOL_Atom       obj;
  375. {
  376.     wool_puts(obj -> p_name);    /* perhaps () for NIL? */
  377.     return (WOOL_OBJECT) obj;
  378. }
  379.  
  380. /*
  381.  * WLAtom_free;
  382.  * Frees the Quark of this Atom
  383.  */
  384.  
  385. WOOL_OBJECT 
  386. WLAtom_free(obj)
  387. WOOL_Atom       obj;
  388. {
  389.     WOOL_Atom      *slot = HashSlot(obj -> p_name);
  390.     WOOL_Atom      *next_slot = slot - 1;
  391.     WOOL_Atom       atom;
  392.  
  393.     *slot = NULL;
  394.     while (atom = *(next_slot = (next_slot < HashTable ?
  395.                   HashTable + HashTableSize - 1 : next_slot))) {
  396.     *next_slot = NULL;
  397.     *(HashSlot(atom -> p_name)) = atom;
  398.     next_slot--;
  399.     }
  400.     Free((((char *) obj)
  401.       - (sizeof(struct _WOOL_Quark) - sizeof(struct _WOOL_Atom))));
  402.     return NULL;
  403. }
  404.  
  405. /*
  406.  * WLAtom_execute:
  407.  * executes the object in the C_val
  408.  */
  409.  
  410. WOOL_OBJECT
  411. WLAtom_execute(obj, list)
  412. WOOL_Atom obj;
  413. WOOL_List list;
  414. {
  415.     if (obj -> c_val && (obj -> c_val -> type != WLAtom)) {
  416.     return WOOL_send(WOOL_execute, obj -> c_val, (obj -> c_val, list));
  417.     } else if (obj -> c_val && (obj -> c_val == NIL)) {
  418.     return NIL;
  419.     } else {
  420.     return (wool_error(UNDEFINED_FUNCTION, obj));
  421.     }
  422. }
  423.  
  424. #ifdef USER_DEBUG
  425. wool_put_spaces(n)
  426. int n;
  427. {
  428.     int             i;
  429.  
  430.     wool_printf("%d ", n);
  431.     for (i = 0; i < n; i++)
  432.     wool_puts(" ");
  433. }
  434. #endif /* USER_DEBUG */
  435. /*
  436.  * WLAtom_set
  437.  * the normal setq routine
  438.  */
  439.  
  440. WOOL_OBJECT
  441. WLAtom_set(atom, value)
  442. WOOL_Atom atom;
  443. WOOL_OBJECT value;
  444. {
  445.     WOOL_OBJECT new =  WOOL_send(WOOL_eval, value, (value));
  446.  
  447.     decrease_reference(atom -> c_val);
  448.     increase_reference(atom -> c_val = new);
  449.     return new;
  450. }
  451.  
  452. WOOL_OBJECT
  453. WLAtom_setq(atom, value)
  454. WOOL_Atom atom;
  455. WOOL_OBJECT value;
  456. {
  457.     decrease_reference(atom -> c_val);
  458.     increase_reference(atom -> c_val = value);
  459.     return value;
  460. }
  461.  
  462. /*
  463.  * C_value of an atom:
  464.  *  NIL => 0
  465.  *  t   => 1
  466.  *  oth => adress of atom itself
  467.  */
  468.  
  469. int
  470. WLAtom_get_C_value(obj)
  471. WOOL_Atom obj;
  472. {
  473.     if (obj == (WOOL_Atom) NIL)
  474.     return 0;
  475.     else if (obj == (WOOL_Atom) TRU)
  476.     return  1;
  477.     else
  478.     return (int) obj;
  479. }
  480.  
  481. void
  482. must_be_atom(atom, n)
  483. WOOL_Atom    atom;
  484. int        n;
  485. {
  486.     if ((atom -> type != WLAtom)    /* verify type of arg1 */
  487.     &&(atom -> type != WLPointer)
  488.     && (atom -> type != WLActive)
  489.     && (atom -> type != WLName))
  490.     bad_argument(atom, n, "symbol");
  491. }
  492.  
  493. int
  494. is_an_atom(atom)
  495. WOOL_Atom    atom;
  496. {
  497.     if ((atom -> type != WLAtom)    /* verify type of arg1 */
  498.     &&(atom -> type != WLPointer)
  499.     && (atom -> type != WLActive)
  500.     && (atom -> type != WLName))
  501.     return 0;
  502.     else
  503.     return 1;
  504. }
  505.