← Back to branch summary

~ubuntu-branches/ubuntu/intrepid/mit-scheme/intrepid-updates

« back to all changes in this revision

Viewing changes to src/microcode/intern.c

  • Committer: Bazaar Package Importer
  • Author(s): Chris Hanson
  • Date: 2002-03-14 17:04:07 UTC
  • Revision ID: james.westby@ubuntu.com-20020314170407-m5lg1d6bdsl9lv0s
Tags: upstream-7.7.0
Import upstream version 7.7.0

Show diffs side-by-side

added added

removed removed

Lines of Context:
src/microcode/intern.c
 
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
}