home *** CD-ROM | disk | FTP | other *** search
/ OS/2 Shareware BBS: 10 Tools / 10-Tools.zip / mitsch75.zip / scheme-7_5_17-src.zip / scheme-7.5.17 / src / microcode / intern.c < prev    next >
C/C++ Source or Header  |  2000-12-05  |  7KB  |  241 lines
  1. /* -*-C-*-
  2.  
  3. $Id: intern.c,v 9.57 2000/12/05 21:23:44 cph Exp $
  4.  
  5. Copyright (c) 1987-2000 Massachusetts Institute of Technology
  6.  
  7. This program is free software; you can redistribute it and/or modify
  8. it under the terms of the GNU General Public License as published by
  9. the Free Software Foundation; either version 2 of the License, or (at
  10. your option) any later version.
  11.  
  12. This program is distributed in the hope that it will be useful, but
  13. WITHOUT ANY WARRANTY; without even the implied warranty of
  14. MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  15. General Public License for more details.
  16.  
  17. You should have received a copy of the GNU General Public License
  18. along with this program; if not, write to the Free Software
  19. Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
  20. */
  21.  
  22. /* String hash functions and interning of symbols. */
  23.  
  24. #include "scheme.h"
  25. #include "prims.h"
  26. #include "trap.h"
  27.  
  28. #ifdef STDC_HEADERS
  29. #  include <string.h>
  30. #else
  31.    extern int EXFUN (strlen, (const char *));
  32. #endif
  33.  
  34. /* These are exported to other parts of the system. */
  35.  
  36. extern SCHEME_OBJECT EXFUN (string_to_symbol, (SCHEME_OBJECT));
  37. extern SCHEME_OBJECT EXFUN (char_pointer_to_symbol, (unsigned char *));
  38. extern SCHEME_OBJECT EXFUN (memory_to_symbol, (long, unsigned char *));
  39. extern SCHEME_OBJECT EXFUN (find_symbol, (long, unsigned char *));
  40.  
  41. /* Hashing strings */
  42.  
  43. #define STRING_HASH_BITS 16
  44.  
  45. static unsigned int
  46. DEFUN (string_hash, (length, string),
  47.        long length AND unsigned char * string)
  48. {
  49.   fast unsigned char * scan = string;
  50.   fast unsigned char * end = (scan + length);
  51.   fast unsigned int result = 0;
  52.   while (scan < end)
  53.   {
  54.     result <<= 1;
  55.     result |= (result >> STRING_HASH_BITS);
  56.     result ^= (*scan++);
  57.     result &= ((1 << STRING_HASH_BITS) - 1);
  58.   }
  59.   return (result);
  60. }
  61.  
  62. static Boolean
  63. DEFUN (string_equal, (length1, string1, length2, string2),
  64.        long length1 AND unsigned char * string1
  65.        AND long length2 AND unsigned char * string2)
  66. {
  67.   fast unsigned char * scan1 = string1;
  68.   fast unsigned char * scan2 = string2;
  69.   fast long length = length1;
  70.   fast unsigned char * end1 = (scan1 + length);
  71.   if (scan1 == scan2)
  72.     return (true);
  73.   if (length != length2)
  74.     return (false);
  75.   while (scan1 < end1)
  76.     if ((*scan1++) != (*scan2++))
  77.       return (false);
  78.   return (true);
  79. }
  80.  
  81. static SCHEME_OBJECT *
  82. DEFUN (find_symbol_internal, (length, string),
  83.        long length AND unsigned char * string)
  84. {
  85.   fast SCHEME_OBJECT * bucket;
  86.   {
  87.     fast SCHEME_OBJECT obarray = (Get_Fixed_Obj_Slot (OBArray));
  88.     bucket =
  89.       (MEMORY_LOC (obarray,
  90.            (((string_hash (length, string))
  91.              % (VECTOR_LENGTH (obarray)))
  92.             + 1)));
  93.   }
  94.   while ((*bucket) != EMPTY_LIST)
  95.     {
  96.       fast SCHEME_OBJECT symbol = (PAIR_CAR (*bucket));
  97.       fast SCHEME_OBJECT name = (FAST_MEMORY_REF (symbol, SYMBOL_NAME));
  98.       if (string_equal (length, string,
  99.             (STRING_LENGTH (name)), (STRING_LOC (name, 0))))
  100.     return (PAIR_CAR_LOC (*bucket));
  101.       bucket = (PAIR_CDR_LOC (*bucket));
  102.     }
  103.   return (bucket);
  104. }
  105.  
  106. /* Set this to be informed of symbols as they are interned. */
  107. void EXFUN ((*intern_symbol_hook), (SCHEME_OBJECT)) = 0;
  108.  
  109. static SCHEME_OBJECT
  110. DEFUN (link_new_symbol, (symbol, cell),
  111.        SCHEME_OBJECT symbol
  112.        AND SCHEME_OBJECT * cell)
  113. {
  114.   /* `symbol' does not exist yet in obarray.  `cell' points to the
  115.      cell containing the final '() in the list.  Replace this
  116.      with a cons of the new symbol and '() (i.e. extend the
  117.      list in the bucket by 1 new element). */
  118.  
  119.   fast SCHEME_OBJECT result = (OBJECT_NEW_TYPE (TC_INTERNED_SYMBOL, symbol));
  120.   (*cell) = (cons (result, EMPTY_LIST));
  121.   if (intern_symbol_hook != ((void (*) ()) 0))
  122.     (*intern_symbol_hook) (result);
  123.   return (result);
  124. }
  125.  
  126. SCHEME_OBJECT
  127. DEFUN (find_symbol, (length, string), long length AND unsigned char * string)
  128. {
  129.   SCHEME_OBJECT result = (* (find_symbol_internal (length, string)));
  130.   return ((result == EMPTY_LIST) ? SHARP_F : result);
  131. }
  132.  
  133. static SCHEME_OBJECT
  134. DEFUN (make_symbol, (string, cell),
  135.        SCHEME_OBJECT string AND
  136.        SCHEME_OBJECT * cell)
  137. {
  138.   Primitive_GC_If_Needed (2);
  139.   {
  140.     SCHEME_OBJECT symbol = (MAKE_POINTER_OBJECT (TC_UNINTERNED_SYMBOL, Free));
  141.     (Free [SYMBOL_NAME]) = string;
  142.     (Free [SYMBOL_GLOBAL_VALUE]) = UNBOUND_OBJECT;
  143.     Free += 2;
  144.     return (link_new_symbol (symbol, cell));
  145.   }
  146. }
  147.  
  148. SCHEME_OBJECT
  149. DEFUN (memory_to_symbol, (length, string),
  150.        long length AND
  151.        unsigned char * string)
  152. {
  153.   SCHEME_OBJECT * cell = (find_symbol_internal (length, string));
  154.   return
  155.     (((*cell) == EMPTY_LIST)
  156.      ? (make_symbol ((memory_to_string (length, string)), cell))
  157.      : (*cell));
  158. }
  159.  
  160. SCHEME_OBJECT
  161. DEFUN (char_pointer_to_symbol, (string), unsigned char * string)
  162. {
  163.   return (memory_to_symbol ((strlen (string)), string));
  164. }
  165.  
  166. SCHEME_OBJECT
  167. DEFUN (string_to_symbol, (string), SCHEME_OBJECT string)
  168. {
  169.   SCHEME_OBJECT * cell =
  170.     (find_symbol_internal ((STRING_LENGTH (string)),
  171.                (STRING_LOC (string, 0))));
  172.   return (((*cell) == EMPTY_LIST) ? (make_symbol (string, cell)) : (*cell));
  173. }
  174.  
  175. SCHEME_OBJECT
  176. DEFUN (intern_symbol, (symbol), SCHEME_OBJECT symbol)
  177. {
  178.   SCHEME_OBJECT name = (FAST_MEMORY_REF (symbol, SYMBOL_NAME));
  179.   SCHEME_OBJECT * cell =
  180.     (find_symbol_internal ((STRING_LENGTH (name)), (STRING_LOC (name, 0))));
  181.   return (((*cell) == EMPTY_LIST)
  182.       ? (link_new_symbol (symbol, cell))
  183.       : (*cell));
  184. }
  185.  
  186. DEFINE_PRIMITIVE ("FIND-SYMBOL", Prim_find_symbol, 1, 1,
  187.   "(FIND-SYMBOL STRING)\n\
  188. Returns the symbol whose name is STRING, or #F if no such symbol exists.")
  189. {
  190.   SCHEME_OBJECT string;
  191.   PRIMITIVE_HEADER (1);
  192.  
  193.   CHECK_ARG (1, STRING_P);
  194.   string = (ARG_REF (1));
  195.   PRIMITIVE_RETURN
  196.     (find_symbol ((STRING_LENGTH (string)), (STRING_LOC (string, 0))));
  197. }
  198.  
  199. DEFINE_PRIMITIVE ("STRING->SYMBOL", Prim_string_to_symbol, 1, 1,
  200.   "(STRING->SYMBOL STRING)\n\
  201. Returns the symbol whose name is STRING, constructing a new symbol if needed.")
  202. {
  203.   PRIMITIVE_HEADER (1);
  204.  
  205.   CHECK_ARG (1, STRING_P);
  206.   PRIMITIVE_RETURN (string_to_symbol (ARG_REF (1)));
  207. }
  208.  
  209. DEFINE_PRIMITIVE ("STRING-HASH", Prim_string_hash, 1, 1,
  210.   "(STRING-HASH STRING)\n\
  211. Return a hash value for a string.  This uses the hashing\n\
  212. algorithm used for interning symbols.  It is intended for use by\n\
  213. the reader in creating interned symbols.")
  214. {
  215.   SCHEME_OBJECT string;
  216.   PRIMITIVE_HEADER (1);
  217.  
  218.   CHECK_ARG (1, STRING_P);
  219.   string = (ARG_REF (1));
  220.   PRIMITIVE_RETURN
  221.     (LONG_TO_UNSIGNED_FIXNUM (string_hash ((STRING_LENGTH (string)),
  222.                        (STRING_LOC (string, 0)))));
  223. }
  224.  
  225. DEFINE_PRIMITIVE ("STRING-HASH-MOD", Prim_string_hash_mod, 2, 2,
  226.   "(STRING-HASH-MOD STRING DENOMINATOR)\n\
  227. DENOMINATOR must be a nonnegative integer.\n\
  228. Equivalent to (MOD (STRING-HASH STRING) DENOMINATOR).")
  229. {
  230.   SCHEME_OBJECT string;
  231.   PRIMITIVE_HEADER (2);
  232.  
  233.   CHECK_ARG (1, STRING_P);
  234.   string = (ARG_REF (1));
  235.   PRIMITIVE_RETURN
  236.     (LONG_TO_UNSIGNED_FIXNUM
  237.      ((string_hash ((STRING_LENGTH (string)),
  238.             (STRING_LOC (string, 0))))
  239.       % (arg_nonnegative_integer (2))));
  240. }
  241.