Commit | Line | Data |
---|---|---|
bccb33a9 | 1 | /* Copyright (C) 1995,1996,1997,1998, 2000 Free Software Foundation, Inc. |
0f2d19dd JB |
2 | * |
3 | * This program is free software; you can redistribute it and/or modify | |
4 | * it under the terms of the GNU General Public License as published by | |
5 | * the Free Software Foundation; either version 2, or (at your option) | |
6 | * any later version. | |
7 | * | |
8 | * This program is distributed in the hope that it will be useful, | |
9 | * but WITHOUT ANY WARRANTY; without even the implied warranty of | |
10 | * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the | |
11 | * GNU General Public License for more details. | |
12 | * | |
13 | * You should have received a copy of the GNU General Public License | |
14 | * along with this software; see the file COPYING. If not, write to | |
82892bed JB |
15 | * the Free Software Foundation, Inc., 59 Temple Place, Suite 330, |
16 | * Boston, MA 02111-1307 USA | |
0f2d19dd JB |
17 | * |
18 | * As a special exception, the Free Software Foundation gives permission | |
19 | * for additional uses of the text contained in its release of GUILE. | |
20 | * | |
21 | * The exception is that, if you link the GUILE library with other files | |
22 | * to produce an executable, this does not by itself cause the | |
23 | * resulting executable to be covered by the GNU General Public License. | |
24 | * Your use of that executable is in no way restricted on account of | |
25 | * linking the GUILE library code into it. | |
26 | * | |
27 | * This exception does not however invalidate any other reasons why | |
28 | * the executable file might be covered by the GNU General Public License. | |
29 | * | |
30 | * This exception applies only to the code released by the | |
31 | * Free Software Foundation under the name GUILE. If you copy | |
32 | * code from other Free Software Foundation releases into a copy of | |
33 | * GUILE, as the General Public License permits, the exception does | |
34 | * not apply to the code that you add in this way. To avoid misleading | |
35 | * anyone as to the status of such modified files, you must delete | |
36 | * this exception notice from them. | |
37 | * | |
38 | * If you write modifications of your own for GUILE, it is your choice | |
39 | * whether to permit this exception to apply to your modifications. | |
82892bed | 40 | * If you do not wish that, delete this exception notice. */ |
1bbd0b84 GB |
41 | |
42 | /* Software engineering face-lift by Greg J. Badros, 11-Dec-1999, | |
43 | gjb@cs.washington.edu, http://www.cs.washington.edu/homes/gjb */ | |
44 | ||
0f2d19dd JB |
45 | \f |
46 | ||
47 | #include <stdio.h> | |
a0599745 MD |
48 | #include "libguile/_scm.h" |
49 | #include "libguile/chars.h" | |
50 | #include "libguile/eval.h" | |
ba393257 | 51 | #include "libguile/hash.h" |
fb43bf74 | 52 | #include "libguile/smob.h" |
a0599745 MD |
53 | #include "libguile/variable.h" |
54 | #include "libguile/alist.h" | |
7e73eaee | 55 | #include "libguile/fluids.h" |
a0599745 MD |
56 | #include "libguile/strings.h" |
57 | #include "libguile/vectors.h" | |
00ffa0e7 | 58 | #include "libguile/hashtab.h" |
a0599745 | 59 | #include "libguile/weaks.h" |
eb8db440 | 60 | #include "libguile/modules.h" |
a0599745 MD |
61 | |
62 | #include "libguile/validate.h" | |
63 | #include "libguile/symbols.h" | |
0f2d19dd | 64 | |
95b88819 GH |
65 | #ifdef HAVE_STRING_H |
66 | #include <string.h> | |
67 | #endif | |
68 | ||
0f2d19dd JB |
69 | \f |
70 | ||
0f979f3f DH |
71 | static SCM symbols; |
72 | ||
73 | \f | |
74 | ||
28b06554 DH |
75 | static char * |
76 | duplicate_string (const char * src, unsigned long length) | |
77 | { | |
78 | char * dst = scm_must_malloc (length + 1, "duplicate_string"); | |
1e1384f0 MD |
79 | memcpy (dst, src, length); |
80 | dst[length] = 0; | |
28b06554 DH |
81 | return dst; |
82 | } | |
83 | ||
84 | \f | |
0f2d19dd JB |
85 | |
86 | /* {Symbols} | |
87 | */ | |
88 | ||
1cc91f1b | 89 | |
b52e071b DH |
90 | SCM |
91 | scm_mem2symbol (const char *name, scm_sizet len) | |
92 | { | |
93 | scm_sizet raw_hash = scm_string_hash ((const unsigned char *) name, len); | |
0f979f3f | 94 | scm_sizet hash = raw_hash % SCM_VECTOR_LENGTH (symbols); |
b52e071b DH |
95 | |
96 | { | |
0f979f3f | 97 | /* Try to find the symbol in the symbols table */ |
b52e071b DH |
98 | |
99 | SCM l; | |
100 | ||
0f979f3f | 101 | for (l = SCM_VELTS (symbols) [hash]; !SCM_NULLP (l); l = SCM_CDR (l)) |
b52e071b DH |
102 | { |
103 | SCM sym = SCM_CAAR (l); | |
104 | if (SCM_SYMBOL_HASH (sym) == raw_hash && SCM_SYMBOL_LENGTH (sym) == len) | |
105 | { | |
106 | char *chrs = SCM_SYMBOL_CHARS (sym); | |
107 | scm_sizet i = len; | |
108 | ||
109 | while (i != 0) | |
110 | { | |
111 | --i; | |
112 | if (name[i] != chrs[i]) | |
113 | goto next_symbol; | |
114 | } | |
115 | ||
116 | return sym; | |
117 | } | |
118 | next_symbol: | |
8d5a2737 | 119 | ; |
b52e071b DH |
120 | } |
121 | } | |
122 | ||
123 | { | |
124 | /* The symbol was not found - create it. */ | |
125 | ||
126 | SCM symbol; | |
127 | SCM cell; | |
128 | SCM slot; | |
129 | ||
130 | SCM_NEWCELL2 (symbol); | |
131 | SCM_SET_SYMBOL_CHARS (symbol, duplicate_string (name, len)); | |
132 | SCM_SET_SYMBOL_HASH (symbol, raw_hash); | |
133 | SCM_SET_PROP_SLOTS (symbol, scm_cons (SCM_BOOL_F, SCM_EOL)); | |
134 | SCM_SET_SYMBOL_LENGTH (symbol, (long) len); | |
135 | ||
136 | cell = scm_cons (symbol, SCM_UNDEFINED); | |
0f979f3f DH |
137 | slot = SCM_VELTS (symbols) [hash]; |
138 | SCM_VELTS (symbols) [hash] = scm_cons (cell, slot); | |
b52e071b DH |
139 | |
140 | return symbol; | |
141 | } | |
142 | } | |
143 | ||
144 | ||
145 | SCM | |
146 | scm_str2symbol (const char *str) | |
147 | { | |
148 | return scm_mem2symbol (str, strlen (str)); | |
149 | } | |
150 | ||
151 | ||
0f2d19dd JB |
152 | /* scm_sym2vcell |
153 | * looks up the symbol in the symhash table. | |
154 | */ | |
1cc91f1b | 155 | |
0f2d19dd | 156 | SCM |
bccb33a9 | 157 | scm_sym2vcell (SCM sym, SCM thunk, SCM definep) |
0f2d19dd | 158 | { |
bccb33a9 | 159 | if (SCM_NIMP (thunk)) |
0f2d19dd | 160 | { |
bccb33a9 MD |
161 | SCM var; |
162 | ||
fb43bf74 | 163 | if (SCM_EVAL_CLOSURE_P (thunk)) |
bccb33a9 | 164 | /* Bypass evaluator in the standard case. */ |
fb43bf74 | 165 | var = scm_eval_closure_lookup (thunk, sym, definep); |
bccb33a9 MD |
166 | else |
167 | var = scm_apply (thunk, sym, scm_cons (definep, scm_listofnull)); | |
0f2d19dd | 168 | |
bc66755e | 169 | if (SCM_FALSEP (var)) |
0f2d19dd | 170 | return SCM_BOOL_F; |
93d40df2 DH |
171 | else if (SCM_VARIABLEP (var)) |
172 | return SCM_VARVCELL (var); | |
0f2d19dd | 173 | else |
38ae064c | 174 | return scm_wta (sym, "strangely interned symbol? ", ""); |
0f2d19dd JB |
175 | } |
176 | else | |
177 | { | |
178 | SCM lsym; | |
b52e071b | 179 | scm_sizet hash; |
0f2d19dd JB |
180 | |
181 | SCM_DEFER_INTS; | |
b52e071b DH |
182 | hash = SCM_SYMBOL_HASH (sym) % SCM_VECTOR_LENGTH (scm_symhash); |
183 | for (lsym = SCM_VELTS (scm_symhash)[hash]; SCM_NIMP (lsym); lsym = SCM_CDR (lsym)) | |
0f2d19dd | 184 | { |
93d40df2 | 185 | SCM z = SCM_CAR (lsym); |
bc66755e | 186 | if (SCM_EQ_P (SCM_CAR (z), sym)) |
0f2d19dd JB |
187 | { |
188 | SCM_ALLOW_INTS; | |
189 | return z; | |
190 | } | |
191 | } | |
192 | ||
b52e071b | 193 | if (!SCM_FALSEP (definep)) |
0f2d19dd | 194 | { |
b52e071b DH |
195 | SCM cell = scm_cons (sym, SCM_UNDEFINED); |
196 | SCM slot = SCM_VELTS (scm_symhash) [hash]; | |
197 | ||
198 | SCM_VELTS (scm_symhash) [hash] = scm_cons (cell, slot); | |
199 | ||
200 | SCM_ALLOW_INTS; | |
201 | return cell; | |
202 | } | |
203 | else | |
204 | { | |
205 | SCM_ALLOW_INTS; | |
206 | return SCM_BOOL_F; | |
0f2d19dd | 207 | } |
0f2d19dd JB |
208 | } |
209 | } | |
210 | ||
211 | /* scm_sym2ovcell | |
49bc24fe | 212 | * looks up the symbol in an arbitrary obarray. |
0f2d19dd | 213 | */ |
1cc91f1b | 214 | |
0f2d19dd | 215 | SCM |
1bbd0b84 | 216 | scm_sym2ovcell_soft (SCM sym, SCM obarray) |
0f2d19dd JB |
217 | { |
218 | SCM lsym, z; | |
0f87853a | 219 | scm_sizet hash = SCM_SYMBOL_HASH (sym) % SCM_VECTOR_LENGTH (obarray); |
0f2d19dd | 220 | SCM_REDEFER_INTS; |
28b06554 | 221 | for (lsym = SCM_VELTS (obarray)[hash]; |
0f2d19dd JB |
222 | SCM_NIMP (lsym); |
223 | lsym = SCM_CDR (lsym)) | |
224 | { | |
225 | z = SCM_CAR (lsym); | |
bc66755e | 226 | if (SCM_EQ_P (SCM_CAR (z), sym)) |
0f2d19dd JB |
227 | { |
228 | SCM_REALLOW_INTS; | |
229 | return z; | |
230 | } | |
231 | } | |
232 | SCM_REALLOW_INTS; | |
233 | return SCM_BOOL_F; | |
234 | } | |
235 | ||
1cc91f1b | 236 | |
0f2d19dd | 237 | SCM |
1bbd0b84 | 238 | scm_sym2ovcell (SCM sym, SCM obarray) |
0f2d19dd JB |
239 | { |
240 | SCM answer; | |
241 | answer = scm_sym2ovcell_soft (sym, obarray); | |
bc66755e | 242 | if (!SCM_FALSEP (answer)) |
0f2d19dd JB |
243 | return answer; |
244 | scm_wta (sym, "uninterned symbol? ", ""); | |
245 | return SCM_UNSPECIFIED; /* not reached */ | |
246 | } | |
247 | ||
8ce94504 JB |
248 | /* Intern a symbol whose name is the LEN characters at NAME in OBARRAY. |
249 | ||
250 | OBARRAY should be a vector of lists, indexed by the name's hash | |
251 | value, modulo OBARRAY's length. Each list has the form | |
252 | ((SYMBOL . VALUE) ...), where SYMBOL is a symbol, and VALUE is the | |
253 | value associated with that symbol (in the current module? in the | |
254 | system module?) | |
255 | ||
256 | To "intern" a symbol means: if OBARRAY already contains a symbol by | |
257 | that name, return its (SYMBOL . VALUE) pair; otherwise, create a | |
258 | new symbol, add the pair (SYMBOL . SCM_UNDEFINED) to the | |
259 | appropriate list of the OBARRAY, and return the pair. | |
260 | ||
261 | If softness is non-zero, don't create a symbol if it isn't already | |
262 | in OBARRAY; instead, just return #f. | |
263 | ||
264 | If OBARRAY is SCM_BOOL_F, create a symbol listed in no obarray and | |
b52e071b | 265 | return (SYMBOL . SCM_UNDEFINED). */ |
8ce94504 | 266 | |
1cc91f1b | 267 | |
0f2d19dd | 268 | SCM |
28b06554 | 269 | scm_intern_obarray_soft (const char *name,scm_sizet len,SCM obarray,unsigned int softness) |
0f2d19dd | 270 | { |
b52e071b DH |
271 | SCM symbol = scm_mem2symbol (name, len); |
272 | scm_sizet raw_hash = SCM_SYMBOL_HASH (symbol); | |
28b06554 | 273 | scm_sizet hash; |
0f2d19dd | 274 | SCM lsym; |
0f2d19dd | 275 | |
bc66755e | 276 | if (SCM_FALSEP (obarray)) |
0f2d19dd | 277 | { |
b52e071b DH |
278 | if (softness) |
279 | return SCM_BOOL_F; | |
280 | else | |
281 | return scm_cons (symbol, SCM_UNDEFINED); | |
0f2d19dd JB |
282 | } |
283 | ||
9fd38a3d | 284 | hash = raw_hash % SCM_VECTOR_LENGTH (obarray); |
0f2d19dd | 285 | |
28b06554 | 286 | for (lsym = SCM_VELTS (obarray)[hash]; SCM_NIMP (lsym); lsym = SCM_CDR (lsym)) |
0f2d19dd | 287 | { |
28b06554 DH |
288 | SCM a = SCM_CAR (lsym); |
289 | SCM z = SCM_CAR (a); | |
b52e071b | 290 | if (SCM_EQ_P (z, symbol)) |
0f2d19dd | 291 | return a; |
0f2d19dd JB |
292 | } |
293 | ||
0f2d19dd JB |
294 | if (softness) |
295 | { | |
0f2d19dd JB |
296 | return SCM_BOOL_F; |
297 | } | |
0f2d19dd JB |
298 | else |
299 | { | |
b52e071b DH |
300 | SCM cell = scm_cons (symbol, SCM_UNDEFINED); |
301 | SCM slot = SCM_VELTS (obarray) [hash]; | |
23ade5e7 | 302 | |
b52e071b | 303 | SCM_VELTS (obarray) [hash] = scm_cons (cell, slot); |
23ade5e7 | 304 | |
b52e071b DH |
305 | return cell; |
306 | } | |
23ade5e7 DH |
307 | } |
308 | ||
309 | ||
0f2d19dd | 310 | SCM |
1bbd0b84 | 311 | scm_intern_obarray (const char *name,scm_sizet len,SCM obarray) |
0f2d19dd JB |
312 | { |
313 | return scm_intern_obarray_soft (name, len, obarray, 0); | |
314 | } | |
315 | ||
316 | ||
0f2d19dd | 317 | SCM |
1bbd0b84 | 318 | scm_intern (const char *name,scm_sizet len) |
0f2d19dd JB |
319 | { |
320 | return scm_intern_obarray (name, len, scm_symhash); | |
321 | } | |
322 | ||
1cc91f1b | 323 | |
0f2d19dd | 324 | SCM |
1bbd0b84 | 325 | scm_intern0 (const char * name) |
0f2d19dd JB |
326 | { |
327 | return scm_intern (name, strlen (name)); | |
328 | } | |
329 | ||
330 | ||
5aab5d96 | 331 | /* Intern the symbol named NAME in scm_symhash, NAME is null-terminated. */ |
0f2d19dd | 332 | SCM |
1bbd0b84 | 333 | scm_sysintern0_no_module_lookup (const char *name) |
0f2d19dd | 334 | { |
b52e071b | 335 | scm_sizet len = strlen (name); |
0f2d19dd JB |
336 | SCM easy_answer; |
337 | SCM_DEFER_INTS; | |
b52e071b | 338 | easy_answer = scm_intern_obarray_soft (name, len, scm_symhash, 1); |
0f2d19dd JB |
339 | if (SCM_NIMP (easy_answer)) |
340 | { | |
0f2d19dd JB |
341 | SCM_ALLOW_INTS; |
342 | return easy_answer; | |
343 | } | |
344 | else | |
345 | { | |
b52e071b DH |
346 | SCM symbol = scm_mem2symbol (name, len); |
347 | scm_sizet raw_hash = SCM_SYMBOL_HASH (symbol); | |
93d40df2 | 348 | scm_sizet hash = raw_hash % SCM_VECTOR_LENGTH (scm_symhash); |
b52e071b DH |
349 | SCM cell = scm_cons (symbol, SCM_UNDEFINED); |
350 | SCM slot = SCM_VELTS (scm_symhash) [hash]; | |
28b06554 | 351 | |
b52e071b | 352 | SCM_VELTS (scm_symhash) [hash] = scm_cons (cell, slot); |
0f2d19dd | 353 | SCM_ALLOW_INTS; |
b52e071b | 354 | return cell; |
0f2d19dd JB |
355 | } |
356 | } | |
357 | ||
9b8d3288 MV |
358 | /* Intern the symbol named NAME in scm_symhash, and give it the value |
359 | VAL. NAME is null-terminated. Use the current top_level lookup | |
360 | closure to give NAME its value. | |
361 | */ | |
362 | SCM | |
1bbd0b84 | 363 | scm_sysintern (const char *name, SCM val) |
5aab5d96 MD |
364 | { |
365 | SCM vcell = scm_sysintern0 (name); | |
366 | SCM_SETCDR (vcell, val); | |
367 | return vcell; | |
368 | } | |
369 | ||
370 | SCM | |
1bbd0b84 | 371 | scm_sysintern0 (const char *name) |
9b8d3288 MV |
372 | { |
373 | SCM lookup_proc; | |
eb8db440 MD |
374 | if (scm_module_system_booted_p |
375 | && SCM_NIMP (lookup_proc = SCM_TOP_LEVEL_LOOKUP_CLOSURE)) | |
9b8d3288 | 376 | { |
38ae064c | 377 | SCM sym = scm_str2symbol (name); |
9b8d3288 | 378 | SCM vcell = scm_sym2vcell (sym, lookup_proc, SCM_BOOL_T); |
bc66755e | 379 | if (SCM_FALSEP (vcell)) |
5d2d2ffc | 380 | scm_misc_error ("sysintern0", "can't define variable", sym); |
9b8d3288 MV |
381 | return vcell; |
382 | } | |
383 | else | |
5aab5d96 | 384 | return scm_sysintern0_no_module_lookup (name); |
9b8d3288 MV |
385 | } |
386 | ||
1dd28b3d MD |
387 | /* Lookup the value of the symbol named by the nul-terminated string |
388 | NAME in the current module. */ | |
389 | SCM | |
1bbd0b84 | 390 | scm_symbol_value0 (const char *name) |
1dd28b3d MD |
391 | { |
392 | /* This looks silly - we look up the symbol twice. But it is in | |
393 | fact necessary given the current module system because the module | |
394 | lookup closures are written in scheme which needs real symbols. */ | |
b52e071b DH |
395 | SCM symbol = scm_str2symbol (name); |
396 | SCM vcell = scm_sym2vcell (symbol, SCM_TOP_LEVEL_LOOKUP_CLOSURE, SCM_BOOL_F); | |
1dd28b3d MD |
397 | if (SCM_FALSEP (vcell)) |
398 | return SCM_UNDEFINED; | |
399 | return SCM_CDR (vcell); | |
400 | } | |
401 | ||
0f979f3f | 402 | |
3b3b36dd | 403 | SCM_DEFINE (scm_symbol_p, "symbol?", 1, 0, 0, |
8e93e199 | 404 | (SCM obj), |
5ffe9968 | 405 | "Returns @t{#t} if @var{obj} is a symbol, otherwise returns @t{#f}. (r5rs)") |
1bbd0b84 | 406 | #define FUNC_NAME s_scm_symbol_p |
0f2d19dd | 407 | { |
8e93e199 | 408 | return SCM_BOOL (SCM_SYMBOLP (obj)); |
0f2d19dd | 409 | } |
1bbd0b84 | 410 | #undef FUNC_NAME |
0f2d19dd | 411 | |
3b3b36dd | 412 | SCM_DEFINE (scm_symbol_to_string, "symbol->string", 1, 0, 0, |
1bbd0b84 | 413 | (SCM s), |
5ffe9968 | 414 | "Returns the name of @var{symbol} as a string. If the symbol was part of\n" |
ae42688c NJ |
415 | "an object returned as the value of a literal expression (section\n" |
416 | "@pxref{Literal expressions,,,r4rs, The Revised^4 Report on Scheme}) or\n" | |
417 | "by a call to the @samp{read} procedure, and its name contains alphabetic\n" | |
418 | "characters, then the string returned will contain characters in the\n" | |
419 | "implementation's preferred standard case---some implementations will\n" | |
420 | "prefer upper case, others lower case. If the symbol was returned by\n" | |
421 | "@samp{string->symbol}, the case of characters in the string returned\n" | |
422 | "will be the same as the case in the string that was passed to\n" | |
423 | "@samp{string->symbol}. It is an error to apply mutation procedures like\n" | |
424 | "@code{string-set!} to strings returned by this procedure. (r5rs)\n\n" | |
5ffe9968 GB |
425 | "The following examples assume that the implementation's standard case is\n" |
426 | "lower case:\n\n" | |
427 | "@format\n" | |
428 | "@t{(symbol->string 'flying-fish) \n" | |
429 | " ==> \"flying-fish\"\n" | |
430 | "(symbol->string 'Martin) ==> \"martin\"\n" | |
431 | "(symbol->string\n" | |
ae42688c NJ |
432 | " (string->symbol \"Malvina\")) \n" |
433 | " ==> \"Malvina\"\n" | |
5ffe9968 GB |
434 | "}\n" |
435 | "@end format") | |
1bbd0b84 | 436 | #define FUNC_NAME s_scm_symbol_to_string |
0f2d19dd | 437 | { |
28b06554 | 438 | SCM_VALIDATE_SYMBOL (1, s); |
9fd38a3d | 439 | return scm_makfromstr (SCM_SYMBOL_CHARS (s), SCM_SYMBOL_LENGTH (s), 0); |
0f2d19dd | 440 | } |
1bbd0b84 | 441 | #undef FUNC_NAME |
0f2d19dd JB |
442 | |
443 | ||
3b3b36dd | 444 | SCM_DEFINE (scm_string_to_symbol, "string->symbol", 1, 0, 0, |
1bbd0b84 | 445 | (SCM s), |
5ffe9968 GB |
446 | "Returns the symbol whose name is @var{string}. This procedure can\n" |
447 | "create symbols with names containing special characters or letters in\n" | |
448 | "the non-standard case, but it is usually a bad idea to create such\n" | |
449 | "symbols because in some implementations of Scheme they cannot be read as\n" | |
450 | "themselves. See @samp{symbol->string}.\n\n" | |
451 | "The following examples assume that the implementation's standard case is\n" | |
452 | "lower case:\n\n" | |
453 | "@format\n" | |
454 | "@t{(eq? 'mISSISSIppi 'mississippi) \n" | |
455 | " ==> #t\n" | |
456 | "(string->symbol \"mISSISSIppi\") \n" | |
457 | " ==>\n" | |
458 | " @r{}the symbol with name \"mISSISSIppi\"\n" | |
459 | "(eq? 'bitBlt (string->symbol \"bitBlt\")) \n" | |
460 | " ==> #f\n" | |
461 | "(eq? 'JollyWog\n" | |
462 | " (string->symbol\n" | |
463 | " (symbol->string 'JollyWog))) \n" | |
464 | " ==> #t\n" | |
465 | "(string=? \"K. Harper, M.D.\"\n" | |
466 | " (symbol->string\n" | |
467 | " (string->symbol \"K. Harper, M.D.\"))) \n" | |
468 | " ==> #t\n" | |
469 | "}\n" | |
470 | "@end format") | |
1bbd0b84 | 471 | #define FUNC_NAME s_scm_string_to_symbol |
0f2d19dd | 472 | { |
38ae064c DH |
473 | SCM_VALIDATE_STRING (1, s); |
474 | return scm_mem2symbol (SCM_STRING_CHARS (s), SCM_STRING_LENGTH (s)); | |
0f2d19dd | 475 | } |
1bbd0b84 | 476 | #undef FUNC_NAME |
0f2d19dd JB |
477 | |
478 | ||
3b3b36dd | 479 | SCM_DEFINE (scm_string_to_obarray_symbol, "string->obarray-symbol", 2, 1, 0, |
1bbd0b84 | 480 | (SCM o, SCM s, SCM softp), |
a3c8b9fc MD |
481 | "Intern a new symbol in @var{obarray}, a symbol table, with name\n" |
482 | "@var{string}.\n\n" | |
483 | "If @var{obarray} is @code{#f}, use the default system symbol table. If\n" | |
484 | "@var{obarray} is @code{#t}, the symbol should not be interned in any\n" | |
485 | "symbol table; merely return the pair (@var{symbol}\n" | |
486 | ". @var{#<undefined>}).\n\n" | |
487 | "The @var{soft?} argument determines whether new symbol table entries\n" | |
488 | "should be created when the specified symbol is not already present in\n" | |
489 | "@var{obarray}. If @var{soft?} is specified and is a true value, then\n" | |
490 | "new entries should not be added for symbols not already present in the\n" | |
491 | "table; instead, simply return @code{#f}.") | |
1bbd0b84 | 492 | #define FUNC_NAME s_scm_string_to_obarray_symbol |
0f2d19dd JB |
493 | { |
494 | SCM vcell; | |
495 | SCM answer; | |
496 | int softness; | |
497 | ||
a6d9e5ab | 498 | SCM_VALIDATE_STRING (2, s); |
bc66755e | 499 | SCM_ASSERT (SCM_BOOLP (o) || SCM_VECTORP (o), o, SCM_ARG1, FUNC_NAME); |
0f2d19dd | 500 | |
bc66755e | 501 | softness = (!SCM_UNBNDP (softp) && !SCM_FALSEP(softp)); |
0f2d19dd | 502 | /* iron out some screwy calling conventions */ |
bc66755e | 503 | if (SCM_FALSEP (o)) |
0f2d19dd | 504 | o = scm_symhash; |
9a09deb1 | 505 | else if (SCM_EQ_P (o, SCM_BOOL_T)) |
0f2d19dd JB |
506 | o = SCM_BOOL_F; |
507 | ||
34f0f2b8 | 508 | vcell = scm_intern_obarray_soft (SCM_STRING_CHARS(s), |
a6d9e5ab | 509 | SCM_STRING_LENGTH (s), |
49bc24fe MD |
510 | o, |
511 | softness); | |
bc66755e | 512 | if (SCM_FALSEP (vcell)) |
0f2d19dd JB |
513 | return vcell; |
514 | answer = SCM_CAR (vcell); | |
0f2d19dd JB |
515 | return answer; |
516 | } | |
1bbd0b84 | 517 | #undef FUNC_NAME |
0f2d19dd | 518 | |
3b3b36dd | 519 | SCM_DEFINE (scm_intern_symbol, "intern-symbol", 2, 0, 0, |
1bbd0b84 | 520 | (SCM o, SCM s), |
b380b885 MD |
521 | "Add a new symbol to @var{obarray} with name @var{string}, bound to an\n" |
522 | "unspecified initial value. The symbol table is not modified if a symbol\n" | |
523 | "with this name is already present.") | |
1bbd0b84 | 524 | #define FUNC_NAME s_scm_intern_symbol |
0f2d19dd | 525 | { |
49bc24fe | 526 | scm_sizet hval; |
3b3b36dd | 527 | SCM_VALIDATE_SYMBOL (2,s); |
bc66755e | 528 | if (SCM_FALSEP (o)) |
49bc24fe | 529 | o = scm_symhash; |
3b3b36dd | 530 | SCM_VALIDATE_VECTOR (1,o); |
0f87853a | 531 | hval = SCM_SYMBOL_HASH (s) % SCM_VECTOR_LENGTH (o); |
49bc24fe MD |
532 | /* If the symbol is already interned, simply return. */ |
533 | SCM_REDEFER_INTS; | |
534 | { | |
535 | SCM lsym; | |
536 | SCM sym; | |
537 | for (lsym = SCM_VELTS (o)[hval]; | |
538 | SCM_NIMP (lsym); | |
539 | lsym = SCM_CDR (lsym)) | |
540 | { | |
541 | sym = SCM_CAR (lsym); | |
bc66755e | 542 | if (SCM_EQ_P (SCM_CAR (sym), s)) |
49bc24fe MD |
543 | { |
544 | SCM_REALLOW_INTS; | |
545 | return SCM_UNSPECIFIED; | |
546 | } | |
547 | } | |
548 | SCM_VELTS (o)[hval] = | |
549 | scm_acons (s, SCM_UNDEFINED, SCM_VELTS (o)[hval]); | |
550 | } | |
551 | SCM_REALLOW_INTS; | |
552 | return SCM_UNSPECIFIED; | |
0f2d19dd | 553 | } |
1bbd0b84 | 554 | #undef FUNC_NAME |
0f2d19dd | 555 | |
3b3b36dd | 556 | SCM_DEFINE (scm_unintern_symbol, "unintern-symbol", 2, 0, 0, |
1bbd0b84 | 557 | (SCM o, SCM s), |
b380b885 MD |
558 | "Remove the symbol with name @var{string} from @var{obarray}. This\n" |
559 | "function returns @code{#t} if the symbol was present and @code{#f}\n" | |
560 | "otherwise.") | |
1bbd0b84 | 561 | #define FUNC_NAME s_scm_unintern_symbol |
0f2d19dd | 562 | { |
49bc24fe | 563 | scm_sizet hval; |
3b3b36dd | 564 | SCM_VALIDATE_SYMBOL (2,s); |
bc66755e | 565 | if (SCM_FALSEP (o)) |
49bc24fe | 566 | o = scm_symhash; |
3b3b36dd | 567 | SCM_VALIDATE_VECTOR (1,o); |
0f87853a | 568 | hval = SCM_SYMBOL_HASH (s) % SCM_VECTOR_LENGTH (o); |
49bc24fe MD |
569 | SCM_DEFER_INTS; |
570 | { | |
571 | SCM lsym_follow; | |
572 | SCM lsym; | |
573 | SCM sym; | |
574 | for (lsym = SCM_VELTS (o)[hval], lsym_follow = SCM_BOOL_F; | |
575 | SCM_NIMP (lsym); | |
576 | lsym_follow = lsym, lsym = SCM_CDR (lsym)) | |
577 | { | |
578 | sym = SCM_CAR (lsym); | |
bc66755e | 579 | if (SCM_EQ_P (SCM_CAR (sym), s)) |
49bc24fe MD |
580 | { |
581 | /* Found the symbol to unintern. */ | |
bc66755e | 582 | if (SCM_FALSEP (lsym_follow)) |
49bc24fe MD |
583 | SCM_VELTS(o)[hval] = lsym; |
584 | else | |
25d8012c | 585 | SCM_SETCDR (lsym_follow, SCM_CDR(lsym)); |
49bc24fe MD |
586 | SCM_ALLOW_INTS; |
587 | return SCM_BOOL_T; | |
588 | } | |
589 | } | |
590 | } | |
591 | SCM_ALLOW_INTS; | |
592 | return SCM_BOOL_F; | |
0f2d19dd | 593 | } |
1bbd0b84 | 594 | #undef FUNC_NAME |
0f2d19dd | 595 | |
3b3b36dd | 596 | SCM_DEFINE (scm_symbol_binding, "symbol-binding", 2, 0, 0, |
1bbd0b84 | 597 | (SCM o, SCM s), |
b380b885 MD |
598 | "Look up in @var{obarray} the symbol whose name is @var{string}, and\n" |
599 | "return the value to which it is bound. If @var{obarray} is @code{#f},\n" | |
600 | "use the global symbol table. If @var{string} is not interned in\n" | |
601 | "@var{obarray}, an error is signalled.") | |
1bbd0b84 | 602 | #define FUNC_NAME s_scm_symbol_binding |
0f2d19dd JB |
603 | { |
604 | SCM vcell; | |
3b3b36dd | 605 | SCM_VALIDATE_SYMBOL (2,s); |
bc66755e | 606 | if (SCM_FALSEP (o)) |
0f2d19dd | 607 | o = scm_symhash; |
3b3b36dd | 608 | SCM_VALIDATE_VECTOR (1,o); |
0f2d19dd JB |
609 | vcell = scm_sym2ovcell (s, o); |
610 | return SCM_CDR(vcell); | |
611 | } | |
1bbd0b84 | 612 | #undef FUNC_NAME |
0f2d19dd JB |
613 | |
614 | ||
3b3b36dd | 615 | SCM_DEFINE (scm_symbol_interned_p, "symbol-interned?", 2, 0, 0, |
1bbd0b84 | 616 | (SCM o, SCM s), |
b380b885 MD |
617 | "Return @var{#t} if @var{obarray} contains a symbol with name\n" |
618 | "@var{string}, and @var{#f} otherwise.") | |
1bbd0b84 | 619 | #define FUNC_NAME s_scm_symbol_interned_p |
0f2d19dd JB |
620 | { |
621 | SCM vcell; | |
3b3b36dd | 622 | SCM_VALIDATE_SYMBOL (2,s); |
bc66755e | 623 | if (SCM_FALSEP (o)) |
0f2d19dd | 624 | o = scm_symhash; |
3b3b36dd | 625 | SCM_VALIDATE_VECTOR (1,o); |
0f2d19dd | 626 | vcell = scm_sym2ovcell_soft (s, o); |
0f2d19dd JB |
627 | return (SCM_NIMP(vcell) |
628 | ? SCM_BOOL_T | |
629 | : SCM_BOOL_F); | |
630 | } | |
1bbd0b84 | 631 | #undef FUNC_NAME |
0f2d19dd JB |
632 | |
633 | ||
3b3b36dd | 634 | SCM_DEFINE (scm_symbol_bound_p, "symbol-bound?", 2, 0, 0, |
1bbd0b84 | 635 | (SCM o, SCM s), |
b380b885 MD |
636 | "Return @var{#t} if @var{obarray} contains a symbol with name\n" |
637 | "@var{string} bound to a defined value. This differs from\n" | |
debe0dc2 | 638 | "@var{symbol-interned?} in that the mere mention of a symbol usually causes\n" |
b380b885 MD |
639 | "it to be interned; @code{symbol-bound?} determines whether a symbol has\n" |
640 | "been given any meaningful value.") | |
1bbd0b84 | 641 | #define FUNC_NAME s_scm_symbol_bound_p |
0f2d19dd JB |
642 | { |
643 | SCM vcell; | |
3b3b36dd | 644 | SCM_VALIDATE_SYMBOL (2,s); |
bc66755e | 645 | if (SCM_FALSEP (o)) |
0f2d19dd | 646 | o = scm_symhash; |
3b3b36dd | 647 | SCM_VALIDATE_VECTOR (1,o); |
0f2d19dd | 648 | vcell = scm_sym2ovcell_soft (s, o); |
bc66755e | 649 | return SCM_BOOL (SCM_NIMP (vcell) && !SCM_UNBNDP (SCM_CDR (vcell))); |
0f2d19dd | 650 | } |
1bbd0b84 | 651 | #undef FUNC_NAME |
0f2d19dd JB |
652 | |
653 | ||
3b3b36dd | 654 | SCM_DEFINE (scm_symbol_set_x, "symbol-set!", 3, 0, 0, |
1bbd0b84 | 655 | (SCM o, SCM s, SCM v), |
b380b885 MD |
656 | "Find the symbol in @var{obarray} whose name is @var{string}, and rebind\n" |
657 | "it to @var{value}. An error is signalled if @var{string} is not present\n" | |
658 | "in @var{obarray}.") | |
1bbd0b84 | 659 | #define FUNC_NAME s_scm_symbol_set_x |
0f2d19dd JB |
660 | { |
661 | SCM vcell; | |
3b3b36dd | 662 | SCM_VALIDATE_SYMBOL (2,s); |
bc66755e | 663 | if (SCM_FALSEP (o)) |
0f2d19dd | 664 | o = scm_symhash; |
3b3b36dd | 665 | SCM_VALIDATE_VECTOR (1,o); |
0f2d19dd | 666 | vcell = scm_sym2ovcell (s, o); |
25d8012c | 667 | SCM_SETCDR (vcell, v); |
0f2d19dd JB |
668 | return SCM_UNSPECIFIED; |
669 | } | |
1bbd0b84 | 670 | #undef FUNC_NAME |
0f2d19dd | 671 | |
0f2d19dd | 672 | |
3b3b36dd | 673 | SCM_DEFINE (scm_symbol_fref, "symbol-fref", 1, 0, 0, |
1bbd0b84 | 674 | (SCM s), |
b380b885 | 675 | "Return the contents of @var{symbol}'s @dfn{function slot}.") |
1bbd0b84 | 676 | #define FUNC_NAME s_scm_symbol_fref |
0f2d19dd | 677 | { |
3b3b36dd | 678 | SCM_VALIDATE_SYMBOL (1,s); |
0f2d19dd JB |
679 | return SCM_SYMBOL_FUNC (s); |
680 | } | |
1bbd0b84 | 681 | #undef FUNC_NAME |
0f2d19dd JB |
682 | |
683 | ||
3b3b36dd | 684 | SCM_DEFINE (scm_symbol_pref, "symbol-pref", 1, 0, 0, |
1bbd0b84 | 685 | (SCM s), |
b380b885 | 686 | "Return the @dfn{property list} currently associated with @var{symbol}.") |
1bbd0b84 | 687 | #define FUNC_NAME s_scm_symbol_pref |
0f2d19dd | 688 | { |
3b3b36dd | 689 | SCM_VALIDATE_SYMBOL (1,s); |
0f2d19dd JB |
690 | return SCM_SYMBOL_PROPS (s); |
691 | } | |
1bbd0b84 | 692 | #undef FUNC_NAME |
0f2d19dd JB |
693 | |
694 | ||
3b3b36dd | 695 | SCM_DEFINE (scm_symbol_fset_x, "symbol-fset!", 2, 0, 0, |
1bbd0b84 | 696 | (SCM s, SCM val), |
b380b885 | 697 | "Change the binding of @var{symbol}'s function slot.") |
1bbd0b84 | 698 | #define FUNC_NAME s_scm_symbol_fset_x |
0f2d19dd | 699 | { |
3b3b36dd | 700 | SCM_VALIDATE_SYMBOL (1,s); |
cf551a2b | 701 | SCM_SET_SYMBOL_FUNC (s, val); |
0f2d19dd JB |
702 | return SCM_UNSPECIFIED; |
703 | } | |
1bbd0b84 | 704 | #undef FUNC_NAME |
0f2d19dd JB |
705 | |
706 | ||
3b3b36dd | 707 | SCM_DEFINE (scm_symbol_pset_x, "symbol-pset!", 2, 0, 0, |
1bbd0b84 | 708 | (SCM s, SCM val), |
b380b885 | 709 | "Change the binding of @var{symbol}'s property slot.") |
1bbd0b84 | 710 | #define FUNC_NAME s_scm_symbol_pset_x |
0f2d19dd | 711 | { |
3b3b36dd | 712 | SCM_VALIDATE_SYMBOL (1,s); |
0f2d19dd | 713 | SCM_DEFER_INTS; |
cf551a2b | 714 | SCM_SET_SYMBOL_PROPS (s, val); |
0f2d19dd JB |
715 | SCM_ALLOW_INTS; |
716 | return SCM_UNSPECIFIED; | |
717 | } | |
1bbd0b84 | 718 | #undef FUNC_NAME |
0f2d19dd JB |
719 | |
720 | ||
3b3b36dd | 721 | SCM_DEFINE (scm_symbol_hash, "symbol-hash", 1, 0, 0, |
28b06554 DH |
722 | (SCM symbol), |
723 | "Return a hash value for @var{symbol}.") | |
1bbd0b84 | 724 | #define FUNC_NAME s_scm_symbol_hash |
0f2d19dd | 725 | { |
28b06554 DH |
726 | SCM_VALIDATE_SYMBOL (1, symbol); |
727 | return SCM_MAKINUM (SCM_SYMBOL_HASH (symbol)); | |
0f2d19dd | 728 | } |
1bbd0b84 | 729 | #undef FUNC_NAME |
0f2d19dd JB |
730 | |
731 | ||
b2530d66 | 732 | static void |
1bbd0b84 | 733 | copy_and_prune_obarray (SCM from, SCM to) |
b2530d66 MD |
734 | { |
735 | int i; | |
9fd38a3d | 736 | int length = SCM_VECTOR_LENGTH (from); |
b2530d66 MD |
737 | for (i = 0; i < length; ++i) |
738 | { | |
739 | SCM head = SCM_VELTS (from)[i]; /* GC protection */ | |
740 | SCM ls = head; | |
741 | SCM res = SCM_EOL; | |
742 | SCM *lloc = &res; | |
743 | while (SCM_NIMP (ls)) | |
744 | { | |
745 | if (!SCM_UNBNDP (SCM_CDAR (ls))) | |
746 | { | |
747 | *lloc = scm_cons (SCM_CAR (ls), SCM_EOL); | |
748 | lloc = SCM_CDRLOC (*lloc); | |
749 | } | |
750 | ls = SCM_CDR (ls); | |
751 | } | |
752 | SCM_VELTS (to)[i] = res; | |
753 | } | |
754 | } | |
755 | ||
756 | ||
3b3b36dd | 757 | SCM_DEFINE (scm_builtin_bindings, "builtin-bindings", 0, 0, 0, |
5ffe9968 | 758 | (), |
b380b885 MD |
759 | "Create and return a copy of the global symbol table, removing all\n" |
760 | "unbound symbols.") | |
1bbd0b84 | 761 | #define FUNC_NAME s_scm_builtin_bindings |
b2530d66 | 762 | { |
9fd38a3d | 763 | int length = SCM_VECTOR_LENGTH (scm_symhash); |
00ffa0e7 | 764 | SCM obarray = scm_c_make_hash_table (length); |
b2530d66 MD |
765 | copy_and_prune_obarray (scm_symhash, obarray); |
766 | return obarray; | |
767 | } | |
1bbd0b84 | 768 | #undef FUNC_NAME |
b2530d66 MD |
769 | |
770 | ||
e1313058 MD |
771 | #define MAX_PREFIX_LENGTH 30 |
772 | ||
1ff4df7a | 773 | static int gensym_counter; |
e1313058 MD |
774 | |
775 | SCM_DEFINE (scm_gensym, "gensym", 0, 1, 0, | |
776 | (SCM prefix), | |
16bad705 MG |
777 | "Create a new symbol with a name constructed from a prefix and\n" |
778 | "a counter value. The string @var{prefix} can be specified as\n" | |
779 | "an optional argument. Default prefix is @code{g}. The counter\n" | |
780 | "is increased by 1 at each call. There is no provision for\n" | |
781 | "resetting the counter.") | |
1bbd0b84 | 782 | #define FUNC_NAME s_scm_gensym |
1ff4df7a | 783 | { |
e1313058 MD |
784 | char buf[MAX_PREFIX_LENGTH + SCM_INTBUFLEN]; |
785 | char *name = buf; | |
786 | int len; | |
787 | if (SCM_UNBNDP (prefix)) | |
788 | { | |
789 | name[0] = 'g'; | |
790 | len = 1; | |
791 | } | |
1ff4df7a | 792 | else |
c64d02c5 | 793 | { |
d1ca2c64 DH |
794 | SCM_VALIDATE_STRING (1, prefix); |
795 | len = SCM_STRING_LENGTH (prefix); | |
e1313058 MD |
796 | if (len > MAX_PREFIX_LENGTH) |
797 | name = SCM_MUST_MALLOC (MAX_PREFIX_LENGTH + SCM_INTBUFLEN); | |
34f0f2b8 | 798 | strncpy (name, SCM_STRING_CHARS (prefix), len); |
c64d02c5 | 799 | } |
e1313058 MD |
800 | { |
801 | int n_digits = scm_iint2str (gensym_counter++, 10, &name[len]); | |
38ae064c | 802 | SCM res = scm_mem2symbol (name, len + n_digits); |
e1313058 MD |
803 | if (name != buf) |
804 | scm_must_free (name); | |
805 | return res; | |
806 | } | |
807 | } | |
808 | #undef FUNC_NAME | |
1bbd0b84 | 809 | |
e1313058 MD |
810 | static int gentemp_counter; |
811 | ||
812 | SCM_DEFINE (scm_gentemp, "gentemp", 0, 2, 0, | |
813 | (SCM prefix, SCM obarray), | |
814 | "Create a new symbol with a name unique in an obarray.\n" | |
16bad705 MG |
815 | "The name is constructed from an optional string @var{prefix}\n" |
816 | "and a counter value. The default prefix is @code{t}. The\n" | |
817 | "@var{obarray} is specified as a second optional argument.\n" | |
818 | "Default is the system obarray where all normal symbols are\n" | |
819 | "interned. The counter is increased by 1 at each\n" | |
e1313058 MD |
820 | "call. There is no provision for resetting the counter.") |
821 | #define FUNC_NAME s_scm_gentemp | |
822 | { | |
823 | char buf[MAX_PREFIX_LENGTH + SCM_INTBUFLEN]; | |
824 | char *name = buf; | |
825 | int len, n_digits; | |
826 | if (SCM_UNBNDP (prefix)) | |
827 | { | |
828 | name[0] = 't'; | |
829 | len = 1; | |
830 | } | |
831 | else | |
1ff4df7a | 832 | { |
d1ca2c64 DH |
833 | SCM_VALIDATE_STRING (1, prefix); |
834 | len = SCM_STRING_LENGTH (prefix); | |
e1313058 MD |
835 | if (len > MAX_PREFIX_LENGTH) |
836 | name = SCM_MUST_MALLOC (MAX_PREFIX_LENGTH + SCM_INTBUFLEN); | |
34f0f2b8 | 837 | strncpy (name, SCM_STRING_CHARS (prefix), len); |
1ff4df7a | 838 | } |
e1313058 MD |
839 | |
840 | if (SCM_UNBNDP (obarray)) | |
841 | obarray = scm_symhash; | |
1ff4df7a | 842 | else |
368cf54d | 843 | SCM_ASSERT ((SCM_VECTORP (obarray) || SCM_WVECTP (obarray)), |
1ff4df7a MD |
844 | obarray, |
845 | SCM_ARG2, | |
1bbd0b84 | 846 | FUNC_NAME); |
e1313058 MD |
847 | do |
848 | n_digits = scm_iint2str (gentemp_counter++, 10, &name[len]); | |
849 | while (!SCM_FALSEP (scm_intern_obarray_soft (name, | |
850 | len + n_digits, | |
851 | obarray, | |
852 | 1))); | |
853 | { | |
854 | SCM vcell = scm_intern_obarray_soft (name, | |
855 | len + n_digits, | |
856 | obarray, | |
857 | 0); | |
858 | if (name != buf) | |
859 | scm_must_free (name); | |
860 | return SCM_CAR (vcell); | |
861 | } | |
1ff4df7a | 862 | } |
1bbd0b84 | 863 | #undef FUNC_NAME |
1cc91f1b | 864 | |
0f979f3f DH |
865 | |
866 | void | |
867 | scm_symbols_prehistory () | |
868 | { | |
869 | symbols = scm_make_weak_key_hash_table (SCM_MAKINUM (277)); | |
870 | scm_permanent_object (symbols); | |
871 | } | |
872 | ||
873 | ||
0f2d19dd JB |
874 | void |
875 | scm_init_symbols () | |
0f2d19dd | 876 | { |
1ff4df7a | 877 | gensym_counter = 0; |
e1313058 | 878 | gentemp_counter = 0; |
8dc9439f | 879 | #ifndef SCM_MAGIC_SNARFER |
a0599745 | 880 | #include "libguile/symbols.x" |
8dc9439f | 881 | #endif |
0f2d19dd | 882 | } |
89e00824 ML |
883 | |
884 | /* | |
885 | Local Variables: | |
886 | c-file-style: "gnu" | |
887 | End: | |
888 | */ |