1 /* Copyright (C) 1999,2000,2001, 2003, 2006, 2008 Free Software Foundation, Inc.
2 *
3 * This library is free software; you can redistribute it and/or
4 * modify it under the terms of the GNU Lesser General Public
5 * License as published by the Free Software Foundation; either
6 * version 2.1 of the License, or (at your option) any later version.
7 *
8 * This library 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 GNU
11 * Lesser General Public License for more details.
12 *
13 * You should have received a copy of the GNU Lesser General Public
14 * License along with this library; if not, write to the Free Software
15 * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
16 */
17
18
19 #ifdef HAVE_CONFIG_H
20 # include <config.h>
21 #endif
22
23 #include "libguile/_scm.h"
24 #include "libguile/alist.h"
25 #include "libguile/eval.h"
26 #include "libguile/gh.h"
27 #include "libguile/hash.h"
28 #include "libguile/list.h"
29 #include "libguile/ports.h"
30 #include "libguile/smob.h"
31 #include "libguile/symbols.h"
32 #include "libguile/vectors.h"
33 #include "libguile/weaks.h"
34
35 #include "libguile/environments.h"
36
37
38
39 scm_t_bits scm_tc16_environment;
40 scm_t_bits scm_tc16_observer;
41 #define DEFAULT_OBARRAY_SIZE 31
42
43 SCM scm_system_environment;
44
45
46
47 /* error conditions */
48
49 /*
50 * Throw an error if symbol is not bound in environment func
51 */
52 void
scm_error_environment_unbound(const char * func,SCM env,SCM symbol)53 scm_error_environment_unbound (const char *func, SCM env, SCM symbol)
54 {
55 /* Dirk:FIXME:: Should throw an environment:unbound type error */
56 char error[] = "Symbol `~A' not bound in environment `~A'.";
57 SCM arguments = scm_cons2 (symbol, env, SCM_EOL);
58 scm_misc_error (func, error, arguments);
59 }
60
61
62 /*
63 * Throw an error if func tried to create (define) or remove
64 * (undefine) a new binding for symbol in env
65 */
66 void
scm_error_environment_immutable_binding(const char * func,SCM env,SCM symbol)67 scm_error_environment_immutable_binding (const char *func, SCM env, SCM symbol)
68 {
69 /* Dirk:FIXME:: Should throw an environment:immutable-binding type error */
70 char error[] = "Immutable binding in environment ~A (symbol: `~A').";
71 SCM arguments = scm_cons2 (env, symbol, SCM_EOL);
72 scm_misc_error (func, error, arguments);
73 }
74
75
76 /*
77 * Throw an error if func tried to change an immutable location.
78 */
79 void
scm_error_environment_immutable_location(const char * func,SCM env,SCM symbol)80 scm_error_environment_immutable_location (const char *func, SCM env, SCM symbol)
81 {
82 /* Dirk:FIXME:: Should throw an environment:immutable-location type error */
83 char error[] = "Immutable location in environment `~A' (symbol: `~A').";
84 SCM arguments = scm_cons2 (env, symbol, SCM_EOL);
85 scm_misc_error (func, error, arguments);
86 }
87
88
89
90 /* generic environments */
91
92
93 /* Create an environment for the given type. Dereferencing type twice must
94 * deliver the initialized set of environment functions. Thus, type will
95 * also determine the signature of the underlying environment implementation.
96 * Dereferencing type once will typically deliver the data fields used by the
97 * underlying environment implementation.
98 */
99 SCM
scm_make_environment(void * type)100 scm_make_environment (void *type)
101 {
102 return scm_cell (scm_tc16_environment, (scm_t_bits) type);
103 }
104
105
106 SCM_DEFINE (scm_environment_p, "environment?", 1, 0, 0,
107 (SCM obj),
108 "Return @code{#t} if @var{obj} is an environment, or @code{#f}\n"
109 "otherwise.")
110 #define FUNC_NAME s_scm_environment_p
111 {
112 return scm_from_bool (SCM_ENVIRONMENT_P (obj));
113 }
114 #undef FUNC_NAME
115
116
117 SCM_DEFINE (scm_environment_bound_p, "environment-bound?", 2, 0, 0,
118 (SCM env, SCM sym),
119 "Return @code{#t} if @var{sym} is bound in @var{env}, or\n"
120 "@code{#f} otherwise.")
121 #define FUNC_NAME s_scm_environment_bound_p
122 {
123 SCM_ASSERT (SCM_ENVIRONMENT_P (env), env, SCM_ARG1, FUNC_NAME);
124 SCM_ASSERT (scm_is_symbol (sym), sym, SCM_ARG2, FUNC_NAME);
125
126 return scm_from_bool (SCM_ENVIRONMENT_BOUND_P (env, sym));
127 }
128 #undef FUNC_NAME
129
130
131 SCM_DEFINE (scm_environment_ref, "environment-ref", 2, 0, 0,
132 (SCM env, SCM sym),
133 "Return the value of the location bound to @var{sym} in\n"
134 "@var{env}. If @var{sym} is unbound in @var{env}, signal an\n"
135 "@code{environment:unbound} error.")
136 #define FUNC_NAME s_scm_environment_ref
137 {
138 SCM val;
139
140 SCM_ASSERT (SCM_ENVIRONMENT_P (env), env, SCM_ARG1, FUNC_NAME);
141 SCM_ASSERT (scm_is_symbol (sym), sym, SCM_ARG2, FUNC_NAME);
142
143 val = SCM_ENVIRONMENT_REF (env, sym);
144
145 if (!SCM_UNBNDP (val))
146 return val;
147 else
148 scm_error_environment_unbound (FUNC_NAME, env, sym);
149 }
150 #undef FUNC_NAME
151
152
153 /* This C function is identical to environment-ref, except that if symbol is
154 * unbound in env, it returns the value SCM_UNDEFINED, instead of signalling
155 * an error.
156 */
157 SCM
scm_c_environment_ref(SCM env,SCM sym)158 scm_c_environment_ref (SCM env, SCM sym)
159 {
160 SCM_ASSERT (SCM_ENVIRONMENT_P (env), env, SCM_ARG1, "scm_c_environment_ref");
161 SCM_ASSERT (scm_is_symbol (sym), sym, SCM_ARG2, "scm_c_environment_ref");
162 return SCM_ENVIRONMENT_REF (env, sym);
163 }
164
165
166 static SCM
environment_default_folder(SCM proc,SCM symbol,SCM value,SCM tail)167 environment_default_folder (SCM proc, SCM symbol, SCM value, SCM tail)
168 {
169 return scm_call_3 (proc, symbol, value, tail);
170 }
171
172
173 SCM_DEFINE (scm_environment_fold, "environment-fold", 3, 0, 0,
174 (SCM env, SCM proc, SCM init),
175 "Iterate over all the bindings in @var{env}, accumulating some\n"
176 "value.\n"
177 "For each binding in @var{env}, apply @var{proc} to the symbol\n"
178 "bound, its value, and the result from the previous application\n"
179 "of @var{proc}.\n"
180 "Use @var{init} as @var{proc}'s third argument the first time\n"
181 "@var{proc} is applied.\n"
182 "If @var{env} contains no bindings, this function simply returns\n"
183 "@var{init}.\n"
184 "If @var{env} binds the symbol sym1 to the value val1, sym2 to\n"
185 "val2, and so on, then this procedure computes:\n"
186 "@lisp\n"
187 " (proc sym1 val1\n"
188 " (proc sym2 val2\n"
189 " ...\n"
190 " (proc symn valn\n"
191 " init)))\n"
192 "@end lisp\n"
193 "Each binding in @var{env} will be processed exactly once.\n"
194 "@code{environment-fold} makes no guarantees about the order in\n"
195 "which the bindings are processed.\n"
196 "Here is a function which, given an environment, constructs an\n"
197 "association list representing that environment's bindings,\n"
198 "using environment-fold:\n"
199 "@lisp\n"
200 " (define (environment->alist env)\n"
201 " (environment-fold env\n"
202 " (lambda (sym val tail)\n"
203 " (cons (cons sym val) tail))\n"
204 " '()))\n"
205 "@end lisp")
206 #define FUNC_NAME s_scm_environment_fold
207 {
208 SCM_ASSERT (SCM_ENVIRONMENT_P (env), env, SCM_ARG1, FUNC_NAME);
209 SCM_ASSERT (scm_is_true (scm_procedure_p (proc)),
210 proc, SCM_ARG2, FUNC_NAME);
211
212 return SCM_ENVIRONMENT_FOLD (env, environment_default_folder, proc, init);
213 }
214 #undef FUNC_NAME
215
216
217 /* This is the C-level analog of environment-fold. For each binding in ENV,
218 * make the call:
219 * (*proc) (data, symbol, value, previous)
220 * where previous is the value returned from the last call to *PROC, or INIT
221 * for the first call. If ENV contains no bindings, return INIT.
222 */
223 SCM
scm_c_environment_fold(SCM env,scm_environment_folder proc,SCM data,SCM init)224 scm_c_environment_fold (SCM env, scm_environment_folder proc, SCM data, SCM init)
225 {
226 SCM_ASSERT (SCM_ENVIRONMENT_P (env), env, SCM_ARG1, "scm_c_environment_fold");
227
228 return SCM_ENVIRONMENT_FOLD (env, proc, data, init);
229 }
230
231
232 SCM_DEFINE (scm_environment_define, "environment-define", 3, 0, 0,
233 (SCM env, SCM sym, SCM val),
234 "Bind @var{sym} to a new location containing @var{val} in\n"
235 "@var{env}. If @var{sym} is already bound to another location\n"
236 "in @var{env} and the binding is mutable, that binding is\n"
237 "replaced. The new binding and location are both mutable. The\n"
238 "return value is unspecified.\n"
239 "If @var{sym} is already bound in @var{env}, and the binding is\n"
240 "immutable, signal an @code{environment:immutable-binding} error.")
241 #define FUNC_NAME s_scm_environment_define
242 {
243 SCM status;
244
245 SCM_ASSERT (SCM_ENVIRONMENT_P (env), env, SCM_ARG1, FUNC_NAME);
246 SCM_ASSERT (scm_is_symbol (sym), sym, SCM_ARG2, FUNC_NAME);
247
248 status = SCM_ENVIRONMENT_DEFINE (env, sym, val);
249
250 if (scm_is_eq (status, SCM_ENVIRONMENT_SUCCESS))
251 return SCM_UNSPECIFIED;
252 else if (scm_is_eq (status, SCM_ENVIRONMENT_BINDING_IMMUTABLE))
253 scm_error_environment_immutable_binding (FUNC_NAME, env, sym);
254 else
255 abort();
256 }
257 #undef FUNC_NAME
258
259
260 SCM_DEFINE (scm_environment_undefine, "environment-undefine", 2, 0, 0,
261 (SCM env, SCM sym),
262 "Remove any binding for @var{sym} from @var{env}. If @var{sym}\n"
263 "is unbound in @var{env}, do nothing. The return value is\n"
264 "unspecified.\n"
265 "If @var{sym} is already bound in @var{env}, and the binding is\n"
266 "immutable, signal an @code{environment:immutable-binding} error.")
267 #define FUNC_NAME s_scm_environment_undefine
268 {
269 SCM status;
270
271 SCM_ASSERT(SCM_ENVIRONMENT_P(env), env, SCM_ARG1, FUNC_NAME);
272 SCM_ASSERT(scm_is_symbol(sym), sym, SCM_ARG2, FUNC_NAME);
273
274 status = SCM_ENVIRONMENT_UNDEFINE (env, sym);
275
276 if (scm_is_eq (status, SCM_ENVIRONMENT_SUCCESS))
277 return SCM_UNSPECIFIED;
278 else if (scm_is_eq (status, SCM_ENVIRONMENT_BINDING_IMMUTABLE))
279 scm_error_environment_immutable_binding (FUNC_NAME, env, sym);
280 else
281 abort();
282 }
283 #undef FUNC_NAME
284
285
286 SCM_DEFINE (scm_environment_set_x, "environment-set!", 3, 0, 0,
287 (SCM env, SCM sym, SCM val),
288 "If @var{env} binds @var{sym} to some location, change that\n"
289 "location's value to @var{val}. The return value is\n"
290 "unspecified.\n"
291 "If @var{sym} is not bound in @var{env}, signal an\n"
292 "@code{environment:unbound} error. If @var{env} binds @var{sym}\n"
293 "to an immutable location, signal an\n"
294 "@code{environment:immutable-location} error.")
295 #define FUNC_NAME s_scm_environment_set_x
296 {
297 SCM status;
298
299 SCM_ASSERT (SCM_ENVIRONMENT_P (env), env, SCM_ARG1, FUNC_NAME);
300 SCM_ASSERT (scm_is_symbol (sym), sym, SCM_ARG2, FUNC_NAME);
301
302 status = SCM_ENVIRONMENT_SET (env, sym, val);
303
304 if (scm_is_eq (status, SCM_ENVIRONMENT_SUCCESS))
305 return SCM_UNSPECIFIED;
306 else if (SCM_UNBNDP (status))
307 scm_error_environment_unbound (FUNC_NAME, env, sym);
308 else if (scm_is_eq (status, SCM_ENVIRONMENT_LOCATION_IMMUTABLE))
309 scm_error_environment_immutable_binding (FUNC_NAME, env, sym);
310 else
311 abort();
312 }
313 #undef FUNC_NAME
314
315
316 SCM_DEFINE (scm_environment_cell, "environment-cell", 3, 0, 0,
317 (SCM env, SCM sym, SCM for_write),
318 "Return the value cell which @var{env} binds to @var{sym}, or\n"
319 "@code{#f} if the binding does not live in a value cell.\n"
320 "The argument @var{for-write} indicates whether the caller\n"
321 "intends to modify the variable's value by mutating the value\n"
322 "cell. If the variable is immutable, then\n"
323 "@code{environment-cell} signals an\n"
324 "@code{environment:immutable-location} error.\n"
325 "If @var{sym} is unbound in @var{env}, signal an\n"
326 "@code{environment:unbound} error.\n"
327 "If you use this function, you should consider using\n"
328 "@code{environment-observe}, to be notified when @var{sym} gets\n"
329 "re-bound to a new value cell, or becomes undefined.")
330 #define FUNC_NAME s_scm_environment_cell
331 {
332 SCM location;
333
334 SCM_ASSERT (SCM_ENVIRONMENT_P (env), env, SCM_ARG1, FUNC_NAME);
335 SCM_ASSERT (scm_is_symbol (sym), sym, SCM_ARG2, FUNC_NAME);
336 SCM_ASSERT (scm_is_bool (for_write), for_write, SCM_ARG3, FUNC_NAME);
337
338 location = SCM_ENVIRONMENT_CELL (env, sym, scm_is_true (for_write));
339 if (!SCM_IMP (location))
340 return location;
341 else if (SCM_UNBNDP (location))
342 scm_error_environment_unbound (FUNC_NAME, env, sym);
343 else if (scm_is_eq (location, SCM_ENVIRONMENT_LOCATION_IMMUTABLE))
344 scm_error_environment_immutable_location (FUNC_NAME, env, sym);
345 else /* no cell */
346 return location;
347 }
348 #undef FUNC_NAME
349
350
351 /* This C function is identical to environment-cell, with the following
352 * exceptions: If symbol is unbound in env, it returns the value
353 * SCM_UNDEFINED, instead of signalling an error. If symbol is bound to an
354 * immutable location but the cell is requested for write, the value
355 * SCM_ENVIRONMENT_LOCATION_IMMUTABLE is returned.
356 */
357 SCM
scm_c_environment_cell(SCM env,SCM sym,int for_write)358 scm_c_environment_cell(SCM env, SCM sym, int for_write)
359 {
360 SCM_ASSERT (SCM_ENVIRONMENT_P (env), env, SCM_ARG1, "scm_c_environment_cell");
361 SCM_ASSERT (scm_is_symbol (sym), sym, SCM_ARG2, "scm_c_environment_cell");
362
363 return SCM_ENVIRONMENT_CELL (env, sym, for_write);
364 }
365
366
367 static void
environment_default_observer(SCM env,SCM proc)368 environment_default_observer (SCM env, SCM proc)
369 {
370 scm_call_1 (proc, env);
371 }
372
373
374 SCM_DEFINE (scm_environment_observe, "environment-observe", 2, 0, 0,
375 (SCM env, SCM proc),
376 "Whenever @var{env}'s bindings change, apply @var{proc} to\n"
377 "@var{env}.\n"
378 "This function returns an object, token, which you can pass to\n"
379 "@code{environment-unobserve} to remove @var{proc} from the set\n"
380 "of procedures observing @var{env}. The type and value of\n"
381 "token is unspecified.")
382 #define FUNC_NAME s_scm_environment_observe
383 {
384 SCM_ASSERT (SCM_ENVIRONMENT_P (env), env, SCM_ARG1, FUNC_NAME);
385
386 return SCM_ENVIRONMENT_OBSERVE (env, environment_default_observer, proc, 0);
387 }
388 #undef FUNC_NAME
389
390
391 SCM_DEFINE (scm_environment_observe_weak, "environment-observe-weak", 2, 0, 0,
392 (SCM env, SCM proc),
393 "This function is the same as environment-observe, except that\n"
394 "the reference @var{env} retains to @var{proc} is a weak\n"
395 "reference. This means that, if there are no other live,\n"
396 "non-weak references to @var{proc}, it will be\n"
397 "garbage-collected, and dropped from @var{env}'s\n"
398 "list of observing procedures.")
399 #define FUNC_NAME s_scm_environment_observe_weak
400 {
401 SCM_ASSERT (SCM_ENVIRONMENT_P (env), env, SCM_ARG1, FUNC_NAME);
402
403 return SCM_ENVIRONMENT_OBSERVE (env, environment_default_observer, proc, 1);
404 }
405 #undef FUNC_NAME
406
407
408 /* This is the C-level analog of the Scheme functions environment-observe and
409 * environment-observe-weak. Whenever env's bindings change, call the
410 * function proc, passing it env and data. If weak_p is non-zero, env will
411 * retain only a weak reference to data, and if data is garbage collected, the
412 * entire observation will be dropped. This function returns a token, with
413 * the same meaning as those returned by environment-observe and
414 * environment-observe-weak.
415 */
416 SCM
scm_c_environment_observe(SCM env,scm_environment_observer proc,SCM data,int weak_p)417 scm_c_environment_observe (SCM env, scm_environment_observer proc, SCM data, int weak_p)
418 #define FUNC_NAME "scm_c_environment_observe"
419 {
420 SCM_ASSERT (SCM_ENVIRONMENT_P (env), env, SCM_ARG1, FUNC_NAME);
421
422 return SCM_ENVIRONMENT_OBSERVE (env, proc, data, weak_p);
423 }
424 #undef FUNC_NAME
425
426
427 SCM_DEFINE (scm_environment_unobserve, "environment-unobserve", 1, 0, 0,
428 (SCM token),
429 "Cancel the observation request which returned the value\n"
430 "@var{token}. The return value is unspecified.\n"
431 "If a call @code{(environment-observe env proc)} returns\n"
432 "@var{token}, then the call @code{(environment-unobserve token)}\n"
433 "will cause @var{proc} to no longer be called when @var{env}'s\n"
434 "bindings change.")
435 #define FUNC_NAME s_scm_environment_unobserve
436 {
437 SCM env;
438
439 SCM_ASSERT (SCM_OBSERVER_P (token), token, SCM_ARG1, FUNC_NAME);
440
441 env = SCM_OBSERVER_ENVIRONMENT (token);
442 SCM_ENVIRONMENT_UNOBSERVE (env, token);
443
444 return SCM_UNSPECIFIED;
445 }
446 #undef FUNC_NAME
447
448
449 static SCM
environment_mark(SCM env)450 environment_mark (SCM env)
451 {
452 return (*(SCM_ENVIRONMENT_FUNCS (env)->mark)) (env);
453 }
454
455
456 static size_t
environment_free(SCM env)457 environment_free (SCM env)
458 {
459 (*(SCM_ENVIRONMENT_FUNCS (env)->free)) (env);
460 return 0;
461 }
462
463
464 static int
environment_print(SCM env,SCM port,scm_print_state * pstate)465 environment_print (SCM env, SCM port, scm_print_state *pstate)
466 {
467 return (*(SCM_ENVIRONMENT_FUNCS (env)->print)) (env, port, pstate);
468 }
469
470
471
472 /* observers */
473
474 static SCM
observer_mark(SCM observer)475 observer_mark (SCM observer)
476 {
477 scm_gc_mark (SCM_OBSERVER_ENVIRONMENT (observer));
478 scm_gc_mark (SCM_OBSERVER_DATA (observer));
479 return SCM_BOOL_F;
480 }
481
482
483 static int
observer_print(SCM type,SCM port,scm_print_state * pstate SCM_UNUSED)484 observer_print (SCM type, SCM port, scm_print_state *pstate SCM_UNUSED)
485 {
486 SCM address = scm_from_size_t (SCM_UNPACK (type));
487 SCM base16 = scm_number_to_string (address, scm_from_int (16));
488
489 scm_puts ("#<observer ", port);
490 scm_display (base16, port);
491 scm_puts (">", port);
492
493 return 1;
494 }
495
496
497
498 /* obarrays
499 *
500 * Obarrays form the basic lookup tables used to implement most of guile's
501 * built-in environment types. An obarray is implemented as a hash table with
502 * symbols as keys. The content of the data depends on the environment type.
503 */
504
505
506 /*
507 * Enter symbol into obarray. The symbol must not already exist in obarray.
508 * The freshly generated (symbol . data) cell is returned.
509 */
510 static SCM
obarray_enter(SCM obarray,SCM symbol,SCM data)511 obarray_enter (SCM obarray, SCM symbol, SCM data)
512 {
513 size_t hash = scm_i_symbol_hash (symbol) % SCM_HASHTABLE_N_BUCKETS (obarray);
514 SCM entry = scm_cons (symbol, data);
515 SCM slot = scm_cons (entry, SCM_HASHTABLE_BUCKET (obarray, hash));
516 SCM_SET_HASHTABLE_BUCKET (obarray, hash, slot);
517 SCM_HASHTABLE_INCREMENT (obarray);
518 if (SCM_HASHTABLE_N_ITEMS (obarray) > SCM_HASHTABLE_UPPER (obarray))
519 scm_i_rehash (obarray, scm_i_hash_symbol, 0, "obarray_enter");
520
521 return entry;
522 }
523
524
525 /*
526 * Enter symbol into obarray. An existing entry for symbol is replaced. If
527 * an entry existed, the old (symbol . data) cell is returned, #f otherwise.
528 */
529 static SCM
obarray_replace(SCM obarray,SCM symbol,SCM data)530 obarray_replace (SCM obarray, SCM symbol, SCM data)
531 {
532 size_t hash = scm_i_symbol_hash (symbol) % SCM_HASHTABLE_N_BUCKETS (obarray);
533 SCM new_entry = scm_cons (symbol, data);
534 SCM lsym;
535 SCM slot;
536
537 for (lsym = SCM_HASHTABLE_BUCKET (obarray, hash);
538 !scm_is_null (lsym);
539 lsym = SCM_CDR (lsym))
540 {
541 SCM old_entry = SCM_CAR (lsym);
542 if (scm_is_eq (SCM_CAR (old_entry), symbol))
543 {
544 SCM_SETCAR (lsym, new_entry);
545 return old_entry;
546 }
547 }
548
549 slot = scm_cons (new_entry, SCM_HASHTABLE_BUCKET (obarray, hash));
550 SCM_SET_HASHTABLE_BUCKET (obarray, hash, slot);
551 SCM_HASHTABLE_INCREMENT (obarray);
552 if (SCM_HASHTABLE_N_ITEMS (obarray) > SCM_HASHTABLE_UPPER (obarray))
553 scm_i_rehash (obarray, scm_i_hash_symbol, 0, "obarray_replace");
554
555 return SCM_BOOL_F;
556 }
557
558
559 /*
560 * Look up symbol in obarray
561 */
562 static SCM
obarray_retrieve(SCM obarray,SCM sym)563 obarray_retrieve (SCM obarray, SCM sym)
564 {
565 size_t hash = scm_i_symbol_hash (sym) % SCM_HASHTABLE_N_BUCKETS (obarray);
566 SCM lsym;
567
568 for (lsym = SCM_HASHTABLE_BUCKET (obarray, hash);
569 !scm_is_null (lsym);
570 lsym = SCM_CDR (lsym))
571 {
572 SCM entry = SCM_CAR (lsym);
573 if (scm_is_eq (SCM_CAR (entry), sym))
574 return entry;
575 }
576
577 return SCM_UNDEFINED;
578 }
579
580
581 /*
582 * Remove entry from obarray. If the symbol was found and removed, the old
583 * (symbol . data) cell is returned, #f otherwise.
584 */
585 static SCM
obarray_remove(SCM obarray,SCM sym)586 obarray_remove (SCM obarray, SCM sym)
587 {
588 size_t hash = scm_i_symbol_hash (sym) % SCM_HASHTABLE_N_BUCKETS (obarray);
589 SCM table_entry = SCM_HASHTABLE_BUCKET (obarray, hash);
590 SCM handle = scm_sloppy_assq (sym, table_entry);
591
592 if (scm_is_pair (handle))
593 {
594 SCM new_table_entry = scm_delq1_x (handle, table_entry);
595 SCM_SET_HASHTABLE_BUCKET (obarray, hash, new_table_entry);
596 SCM_HASHTABLE_DECREMENT (obarray);
597 }
598
599 return handle;
600 }
601
602
603 static void
obarray_remove_all(SCM obarray)604 obarray_remove_all (SCM obarray)
605 {
606 size_t size = SCM_HASHTABLE_N_BUCKETS (obarray);
607 size_t i;
608
609 for (i = 0; i < size; i++)
610 {
611 SCM_SET_HASHTABLE_BUCKET (obarray, i, SCM_EOL);
612 }
613 SCM_SET_HASHTABLE_N_ITEMS (obarray, 0);
614 }
615
616
617
618 /* core environments base
619 *
620 * This struct and the corresponding functions form a base class for guile's
621 * built-in environment types.
622 */
623
624
625 struct core_environments_base {
626 struct scm_environment_funcs *funcs;
627
628 SCM observers;
629 SCM weak_observers;
630 };
631
632
633 #define CORE_ENVIRONMENTS_BASE(env) \
634 ((struct core_environments_base *) SCM_CELL_WORD_1 (env))
635 #define CORE_ENVIRONMENT_OBSERVERS(env) \
636 (CORE_ENVIRONMENTS_BASE (env)->observers)
637 #define SCM_SET_CORE_ENVIRONMENT_OBSERVERS(env, v) \
638 (CORE_ENVIRONMENT_OBSERVERS (env) = (v))
639 #define CORE_ENVIRONMENT_WEAK_OBSERVER_VECTOR(env) \
640 (CORE_ENVIRONMENTS_BASE (env)->weak_observers)
641 #define CORE_ENVIRONMENT_WEAK_OBSERVERS(env) \
642 (scm_c_vector_ref (CORE_ENVIRONMENT_WEAK_OBSERVER_VECTOR (env), 0))
643 #define SCM_SET_CORE_ENVIRONMENT_WEAK_OBSERVERS(env, v) \
644 (scm_c_vector_set_x (CORE_ENVIRONMENT_WEAK_OBSERVER_VECTOR (env), 0, (v)))
645
646
647
648 static SCM
core_environments_observe(SCM env,scm_environment_observer proc,SCM data,int weak_p)649 core_environments_observe (SCM env, scm_environment_observer proc, SCM data, int weak_p)
650 {
651 SCM observer = scm_double_cell (scm_tc16_observer,
652 SCM_UNPACK (env),
653 SCM_UNPACK (data),
654 (scm_t_bits) proc);
655
656 if (!weak_p)
657 {
658 SCM observers = CORE_ENVIRONMENT_OBSERVERS (env);
659 SCM new_observers = scm_cons (observer, observers);
660 SCM_SET_CORE_ENVIRONMENT_OBSERVERS (env, new_observers);
661 }
662 else
663 {
664 SCM observers = CORE_ENVIRONMENT_WEAK_OBSERVERS (env);
665 SCM new_observers = scm_acons (SCM_BOOL_F, observer, observers);
666 SCM_SET_CORE_ENVIRONMENT_WEAK_OBSERVERS (env, new_observers);
667 }
668
669 return observer;
670 }
671
672
673 static void
core_environments_unobserve(SCM env,SCM observer)674 core_environments_unobserve (SCM env, SCM observer)
675 {
676 unsigned int handling_weaks;
677 for (handling_weaks = 0; handling_weaks <= 1; ++handling_weaks)
678 {
679 SCM l = handling_weaks
680 ? CORE_ENVIRONMENT_WEAK_OBSERVERS (env)
681 : CORE_ENVIRONMENT_OBSERVERS (env);
682
683 if (!scm_is_null (l))
684 {
685 SCM rest = SCM_CDR (l);
686 SCM first = handling_weaks
687 ? SCM_CDAR (l)
688 : SCM_CAR (l);
689
690 if (scm_is_eq (first, observer))
691 {
692 /* Remove the first observer */
693 if (handling_weaks)
694 SCM_SET_CORE_ENVIRONMENT_WEAK_OBSERVERS (env, rest);
695 else
696 SCM_SET_CORE_ENVIRONMENT_OBSERVERS (env, rest);
697 return;
698 }
699
700 do {
701 SCM rest = SCM_CDR (l);
702
703 if (!scm_is_null (rest))
704 {
705 SCM next = handling_weaks
706 ? SCM_CDAR (l)
707 : SCM_CAR (l);
708
709 if (scm_is_eq (next, observer))
710 {
711 SCM_SETCDR (l, SCM_CDR (rest));
712 return;
713 }
714 }
715
716 l = rest;
717 } while (!scm_is_null (l));
718 }
719 }
720
721 /* Dirk:FIXME:: What to do now, since the observer is not found? */
722 }
723
724
725 static SCM
core_environments_mark(SCM env)726 core_environments_mark (SCM env)
727 {
728 scm_gc_mark (CORE_ENVIRONMENT_OBSERVERS (env));
729 return CORE_ENVIRONMENT_WEAK_OBSERVER_VECTOR (env);
730 }
731
732
733 static void
core_environments_finalize(SCM env SCM_UNUSED)734 core_environments_finalize (SCM env SCM_UNUSED)
735 {
736 }
737
738
739 static void
core_environments_preinit(struct core_environments_base * body)740 core_environments_preinit (struct core_environments_base *body)
741 {
742 body->funcs = NULL;
743 body->observers = SCM_BOOL_F;
744 body->weak_observers = SCM_BOOL_F;
745 }
746
747
748 static void
core_environments_init(struct core_environments_base * body,struct scm_environment_funcs * funcs)749 core_environments_init (struct core_environments_base *body,
750 struct scm_environment_funcs *funcs)
751 {
752 body->funcs = funcs;
753 body->observers = SCM_EOL;
754 body->weak_observers = scm_make_weak_value_alist_vector (scm_from_int (1));
755 }
756
757
758 /* Tell all observers to clear their caches.
759 *
760 * Environments have to be informed about changes in the following cases:
761 * - The observed env has a new binding. This must be always reported.
762 * - The observed env has dropped a binding. This must be always reported.
763 * - A binding in the observed environment has changed. This must only be
764 * reported, if there is a chance that the binding is being cached outside.
765 * However, this potential optimization is not performed currently.
766 *
767 * Errors that occur while the observers are called are accumulated and
768 * signalled as one single error message to the caller.
769 */
770
771 struct update_data
772 {
773 SCM observer;
774 SCM environment;
775 };
776
777
778 static SCM
update_catch_body(void * ptr)779 update_catch_body (void *ptr)
780 {
781 struct update_data *data = (struct update_data *) ptr;
782 SCM observer = data->observer;
783
784 (*SCM_OBSERVER_PROC (observer))
785 (data->environment, SCM_OBSERVER_DATA (observer));
786
787 return SCM_UNDEFINED;
788 }
789
790
791 static SCM
update_catch_handler(void * ptr,SCM tag,SCM args)792 update_catch_handler (void *ptr, SCM tag, SCM args)
793 {
794 struct update_data *data = (struct update_data *) ptr;
795 SCM observer = data->observer;
796 SCM message =
797 scm_from_locale_string ("Observer `~A' signals `~A' error: ~S");
798
799 return scm_cons (message, scm_list_3 (observer, tag, args));
800 }
801
802
803 static void
core_environments_broadcast(SCM env)804 core_environments_broadcast (SCM env)
805 #define FUNC_NAME "core_environments_broadcast"
806 {
807 unsigned int handling_weaks;
808 SCM errors = SCM_EOL;
809
810 for (handling_weaks = 0; handling_weaks <= 1; ++handling_weaks)
811 {
812 SCM observers = handling_weaks
813 ? CORE_ENVIRONMENT_WEAK_OBSERVERS (env)
814 : CORE_ENVIRONMENT_OBSERVERS (env);
815
816 for (; !scm_is_null (observers); observers = SCM_CDR (observers))
817 {
818 struct update_data data;
819 SCM observer = handling_weaks
820 ? SCM_CDAR (observers)
821 : SCM_CAR (observers);
822 SCM error;
823
824 data.observer = observer;
825 data.environment = env;
826
827 error = scm_internal_catch (SCM_BOOL_T,
828 update_catch_body, &data,
829 update_catch_handler, &data);
830
831 if (!SCM_UNBNDP (error))
832 errors = scm_cons (error, errors);
833 }
834 }
835
836 if (!scm_is_null (errors))
837 {
838 /* Dirk:FIXME:: As soon as scm_misc_error is fixed to handle the name
839 * parameter correctly it should not be necessary any more to also pass
840 * namestr in order to get the desired information from the error
841 * message.
842 */
843 SCM ordered_errors = scm_reverse (errors);
844 scm_misc_error
845 (FUNC_NAME,
846 "Observers of `~A' have signalled the following errors: ~S",
847 scm_cons2 (env, ordered_errors, SCM_EOL));
848 }
849 }
850 #undef FUNC_NAME
851
852
853
854 /* leaf environments
855 *
856 * A leaf environment is simply a mutable set of definitions. A leaf
857 * environment supports no operations beyond the common set.
858 *
859 * Implementation: The obarray of the leaf environment holds (symbol . value)
860 * pairs. No further information is necessary, since all bindings and
861 * locations in a leaf environment are mutable.
862 */
863
864
865 struct leaf_environment {
866 struct core_environments_base base;
867
868 SCM obarray;
869 };
870
871
872 #define LEAF_ENVIRONMENT(env) \
873 ((struct leaf_environment *) SCM_CELL_WORD_1 (env))
874
875
876
877 static SCM
leaf_environment_ref(SCM env,SCM sym)878 leaf_environment_ref (SCM env, SCM sym)
879 {
880 SCM obarray = LEAF_ENVIRONMENT (env)->obarray;
881 SCM binding = obarray_retrieve (obarray, sym);
882 return SCM_UNBNDP (binding) ? binding : SCM_CDR (binding);
883 }
884
885
886 static SCM
leaf_environment_fold(SCM env,scm_environment_folder proc,SCM data,SCM init)887 leaf_environment_fold (SCM env, scm_environment_folder proc, SCM data, SCM init)
888 {
889 size_t i;
890 SCM result = init;
891 SCM obarray = LEAF_ENVIRONMENT (env)->obarray;
892
893 for (i = 0; i < SCM_HASHTABLE_N_BUCKETS (obarray); i++)
894 {
895 SCM l;
896 for (l = SCM_HASHTABLE_BUCKET (obarray, i);
897 !scm_is_null (l);
898 l = SCM_CDR (l))
899 {
900 SCM binding = SCM_CAR (l);
901 SCM symbol = SCM_CAR (binding);
902 SCM value = SCM_CDR (binding);
903 result = (*proc) (data, symbol, value, result);
904 }
905 }
906 return result;
907 }
908
909
910 static SCM
leaf_environment_define(SCM env,SCM sym,SCM val)911 leaf_environment_define (SCM env, SCM sym, SCM val)
912 #define FUNC_NAME "leaf_environment_define"
913 {
914 SCM obarray = LEAF_ENVIRONMENT (env)->obarray;
915
916 obarray_replace (obarray, sym, val);
917 core_environments_broadcast (env);
918
919 return SCM_ENVIRONMENT_SUCCESS;
920 }
921 #undef FUNC_NAME
922
923
924 static SCM
leaf_environment_undefine(SCM env,SCM sym)925 leaf_environment_undefine (SCM env, SCM sym)
926 #define FUNC_NAME "leaf_environment_undefine"
927 {
928 SCM obarray = LEAF_ENVIRONMENT (env)->obarray;
929 SCM removed = obarray_remove (obarray, sym);
930
931 if (scm_is_true (removed))
932 core_environments_broadcast (env);
933
934 return SCM_ENVIRONMENT_SUCCESS;
935 }
936 #undef FUNC_NAME
937
938
939 static SCM
leaf_environment_set_x(SCM env,SCM sym,SCM val)940 leaf_environment_set_x (SCM env, SCM sym, SCM val)
941 #define FUNC_NAME "leaf_environment_set_x"
942 {
943 SCM obarray = LEAF_ENVIRONMENT (env)->obarray;
944 SCM binding = obarray_retrieve (obarray, sym);
945
946 if (!SCM_UNBNDP (binding))
947 {
948 SCM_SETCDR (binding, val);
949 return SCM_ENVIRONMENT_SUCCESS;
950 }
951 else
952 {
953 return SCM_UNDEFINED;
954 }
955 }
956 #undef FUNC_NAME
957
958
959 static SCM
leaf_environment_cell(SCM env,SCM sym,int for_write SCM_UNUSED)960 leaf_environment_cell (SCM env, SCM sym, int for_write SCM_UNUSED)
961 {
962 SCM obarray = LEAF_ENVIRONMENT (env)->obarray;
963 SCM binding = obarray_retrieve (obarray, sym);
964 return binding;
965 }
966
967
968 static SCM
leaf_environment_mark(SCM env)969 leaf_environment_mark (SCM env)
970 {
971 scm_gc_mark (LEAF_ENVIRONMENT (env)->obarray);
972 return core_environments_mark (env);
973 }
974
975
976 static void
leaf_environment_free(SCM env)977 leaf_environment_free (SCM env)
978 {
979 core_environments_finalize (env);
980 scm_gc_free (LEAF_ENVIRONMENT (env), sizeof (struct leaf_environment),
981 "leaf environment");
982 }
983
984
985 static int
leaf_environment_print(SCM type,SCM port,scm_print_state * pstate SCM_UNUSED)986 leaf_environment_print (SCM type, SCM port, scm_print_state *pstate SCM_UNUSED)
987 {
988 SCM address = scm_from_size_t (SCM_UNPACK (type));
989 SCM base16 = scm_number_to_string (address, scm_from_int (16));
990
991 scm_puts ("#<leaf environment ", port);
992 scm_display (base16, port);
993 scm_puts (">", port);
994
995 return 1;
996 }
997
998
999 static struct scm_environment_funcs leaf_environment_funcs = {
1000 leaf_environment_ref,
1001 leaf_environment_fold,
1002 leaf_environment_define,
1003 leaf_environment_undefine,
1004 leaf_environment_set_x,
1005 leaf_environment_cell,
1006 core_environments_observe,
1007 core_environments_unobserve,
1008 leaf_environment_mark,
1009 leaf_environment_free,
1010 leaf_environment_print
1011 };
1012
1013
1014 void *scm_type_leaf_environment = &leaf_environment_funcs;
1015
1016
1017 SCM_DEFINE (scm_make_leaf_environment, "make-leaf-environment", 0, 0, 0,
1018 (),
1019 "Create a new leaf environment, containing no bindings.\n"
1020 "All bindings and locations created in the new environment\n"
1021 "will be mutable.")
1022 #define FUNC_NAME s_scm_make_leaf_environment
1023 {
1024 size_t size = sizeof (struct leaf_environment);
1025 struct leaf_environment *body = scm_gc_malloc (size, "leaf environment");
1026 SCM env;
1027
1028 core_environments_preinit (&body->base);
1029 body->obarray = SCM_BOOL_F;
1030
1031 env = scm_make_environment (body);
1032
1033 core_environments_init (&body->base, &leaf_environment_funcs);
1034 body->obarray = scm_c_make_hash_table (DEFAULT_OBARRAY_SIZE);
1035
1036 return env;
1037 }
1038 #undef FUNC_NAME
1039
1040
1041 SCM_DEFINE (scm_leaf_environment_p, "leaf-environment?", 1, 0, 0,
1042 (SCM object),
1043 "Return @code{#t} if object is a leaf environment, or @code{#f}\n"
1044 "otherwise.")
1045 #define FUNC_NAME s_scm_leaf_environment_p
1046 {
1047 return scm_from_bool (SCM_LEAF_ENVIRONMENT_P (object));
1048 }
1049 #undef FUNC_NAME
1050
1051
1052
1053 /* eval environments
1054 *
1055 * A module's source code refers to definitions imported from other modules,
1056 * and definitions made within itself. An eval environment combines two
1057 * environments -- a local environment and an imported environment -- to
1058 * produce a new environment in which both sorts of references can be
1059 * resolved.
1060 *
1061 * Implementation: The obarray of the eval environment is used to cache
1062 * entries from the local and imported environments such that in most of the
1063 * cases only a single lookup is necessary. Since for neither the local nor
1064 * the imported environment it is known, what kind of environment they form,
1065 * the most general case is assumed. Therefore, entries in the obarray take
1066 * one of the following forms:
1067 *
1068 * 1) (<symbol> location mutability . source-env), where mutability indicates
1069 * one of the following states: IMMUTABLE if the location is known to be
1070 * immutable, MUTABLE if the location is known to be mutable, UNKNOWN if
1071 * the location has only been requested for non modifying accesses.
1072 *
1073 * 2) (symbol . source-env) if the symbol has a binding in the source-env, but
1074 * if the source-env can't provide a cell for the binding. Thus, for every
1075 * access, the source-env has to be contacted directly.
1076 */
1077
1078
1079 struct eval_environment {
1080 struct core_environments_base base;
1081
1082 SCM obarray;
1083
1084 SCM imported;
1085 SCM imported_observer;
1086 SCM local;
1087 SCM local_observer;
1088 };
1089
1090
1091 #define EVAL_ENVIRONMENT(env) \
1092 ((struct eval_environment *) SCM_CELL_WORD_1 (env))
1093
1094 #define IMMUTABLE SCM_I_MAKINUM (0)
1095 #define MUTABLE SCM_I_MAKINUM (1)
1096 #define UNKNOWN SCM_I_MAKINUM (2)
1097
1098 #define CACHED_LOCATION(x) SCM_CAR (x)
1099 #define CACHED_MUTABILITY(x) SCM_CADR (x)
1100 #define SET_CACHED_MUTABILITY(x, v) SCM_SETCAR (SCM_CDR (x), (v))
1101 #define CACHED_SOURCE_ENVIRONMENT(x) SCM_CDDR (x)
1102
1103
1104
1105 /* eval_environment_lookup will report one of the following distinct results:
1106 * a) (<object> . value) if a cell could be obtained.
1107 * b) <environment> if the environment has to be contacted directly.
1108 * c) IMMUTABLE if an immutable cell was requested for write.
1109 * d) SCM_UNDEFINED if there is no binding for the symbol.
1110 */
1111 static SCM
eval_environment_lookup(SCM env,SCM sym,int for_write)1112 eval_environment_lookup (SCM env, SCM sym, int for_write)
1113 {
1114 SCM obarray = EVAL_ENVIRONMENT (env)->obarray;
1115 SCM binding = obarray_retrieve (obarray, sym);
1116
1117 if (!SCM_UNBNDP (binding))
1118 {
1119 /* The obarray holds an entry for the symbol. */
1120
1121 SCM entry = SCM_CDR (binding);
1122
1123 if (scm_is_pair (entry))
1124 {
1125 /* The entry in the obarray is a cached location. */
1126
1127 SCM location = CACHED_LOCATION (entry);
1128 SCM mutability;
1129
1130 if (!for_write)
1131 return location;
1132
1133 mutability = CACHED_MUTABILITY (entry);
1134 if (scm_is_eq (mutability, MUTABLE))
1135 return location;
1136
1137 if (scm_is_eq (mutability, UNKNOWN))
1138 {
1139 SCM source_env = CACHED_SOURCE_ENVIRONMENT (entry);
1140 SCM location = SCM_ENVIRONMENT_CELL (source_env, sym, 1);
1141
1142 if (scm_is_pair (location))
1143 {
1144 SET_CACHED_MUTABILITY (entry, MUTABLE);
1145 return location;
1146 }
1147 else /* IMMUTABLE */
1148 {
1149 SET_CACHED_MUTABILITY (entry, IMMUTABLE);
1150 return IMMUTABLE;
1151 }
1152 }
1153
1154 return IMMUTABLE;
1155 }
1156 else
1157 {
1158 /* The obarray entry is an environment */
1159
1160 return entry;
1161 }
1162 }
1163 else
1164 {
1165 /* There is no entry for the symbol in the obarray. This can either
1166 * mean that there has not been a request for the symbol yet, or that
1167 * the symbol is really undefined. We are looking for the symbol in
1168 * both the local and the imported environment. If we find a binding, a
1169 * cached entry is created.
1170 */
1171
1172 struct eval_environment *body = EVAL_ENVIRONMENT (env);
1173 unsigned int handling_import;
1174
1175 for (handling_import = 0; handling_import <= 1; ++handling_import)
1176 {
1177 SCM source_env = handling_import ? body->imported : body->local;
1178 SCM location = SCM_ENVIRONMENT_CELL (source_env, sym, for_write);
1179
1180 if (!SCM_UNBNDP (location))
1181 {
1182 if (scm_is_pair (location))
1183 {
1184 SCM mutability = for_write ? MUTABLE : UNKNOWN;
1185 SCM entry = scm_cons2 (location, mutability, source_env);
1186 obarray_enter (obarray, sym, entry);
1187 return location;
1188 }
1189 else if (scm_is_eq (location, SCM_ENVIRONMENT_LOCATION_NO_CELL))
1190 {
1191 obarray_enter (obarray, sym, source_env);
1192 return source_env;
1193 }
1194 else
1195 {
1196 return IMMUTABLE;
1197 }
1198 }
1199 }
1200
1201 return SCM_UNDEFINED;
1202 }
1203 }
1204
1205
1206 static SCM
eval_environment_ref(SCM env,SCM sym)1207 eval_environment_ref (SCM env, SCM sym)
1208 #define FUNC_NAME "eval_environment_ref"
1209 {
1210 SCM location = eval_environment_lookup (env, sym, 0);
1211
1212 if (scm_is_pair (location))
1213 return SCM_CDR (location);
1214 else if (!SCM_UNBNDP (location))
1215 return SCM_ENVIRONMENT_REF (location, sym);
1216 else
1217 return SCM_UNDEFINED;
1218 }
1219 #undef FUNC_NAME
1220
1221
1222 static SCM
eval_environment_folder(SCM extended_data,SCM symbol,SCM value,SCM tail)1223 eval_environment_folder (SCM extended_data, SCM symbol, SCM value, SCM tail)
1224 {
1225 SCM local = SCM_CAR (extended_data);
1226
1227 if (!SCM_ENVIRONMENT_BOUND_P (local, symbol))
1228 {
1229 SCM proc_as_nr = SCM_CADR (extended_data);
1230 unsigned long int proc_as_ul = scm_to_ulong (proc_as_nr);
1231 scm_environment_folder proc = (scm_environment_folder) proc_as_ul;
1232 SCM data = SCM_CDDR (extended_data);
1233
1234 return (*proc) (data, symbol, value, tail);
1235 }
1236 else
1237 {
1238 return tail;
1239 }
1240 }
1241
1242
1243 static SCM
eval_environment_fold(SCM env,scm_environment_folder proc,SCM data,SCM init)1244 eval_environment_fold (SCM env, scm_environment_folder proc, SCM data, SCM init)
1245 {
1246 SCM local = EVAL_ENVIRONMENT (env)->local;
1247 SCM imported = EVAL_ENVIRONMENT (env)->imported;
1248 SCM proc_as_nr = scm_from_ulong ((unsigned long) proc);
1249 SCM extended_data = scm_cons2 (local, proc_as_nr, data);
1250 SCM tmp_result = scm_c_environment_fold (imported, eval_environment_folder, extended_data, init);
1251
1252 return scm_c_environment_fold (local, proc, data, tmp_result);
1253 }
1254
1255
1256 static SCM
eval_environment_define(SCM env,SCM sym,SCM val)1257 eval_environment_define (SCM env, SCM sym, SCM val)
1258 #define FUNC_NAME "eval_environment_define"
1259 {
1260 SCM local = EVAL_ENVIRONMENT (env)->local;
1261 return SCM_ENVIRONMENT_DEFINE (local, sym, val);
1262 }
1263 #undef FUNC_NAME
1264
1265
1266 static SCM
eval_environment_undefine(SCM env,SCM sym)1267 eval_environment_undefine (SCM env, SCM sym)
1268 #define FUNC_NAME "eval_environment_undefine"
1269 {
1270 SCM local = EVAL_ENVIRONMENT (env)->local;
1271 return SCM_ENVIRONMENT_UNDEFINE (local, sym);
1272 }
1273 #undef FUNC_NAME
1274
1275
1276 static SCM
eval_environment_set_x(SCM env,SCM sym,SCM val)1277 eval_environment_set_x (SCM env, SCM sym, SCM val)
1278 #define FUNC_NAME "eval_environment_set_x"
1279 {
1280 SCM location = eval_environment_lookup (env, sym, 1);
1281
1282 if (scm_is_pair (location))
1283 {
1284 SCM_SETCDR (location, val);
1285 return SCM_ENVIRONMENT_SUCCESS;
1286 }
1287 else if (SCM_ENVIRONMENT_P (location))
1288 {
1289 return SCM_ENVIRONMENT_SET (location, sym, val);
1290 }
1291 else if (scm_is_eq (location, IMMUTABLE))
1292 {
1293 return SCM_ENVIRONMENT_LOCATION_IMMUTABLE;
1294 }
1295 else
1296 {
1297 return SCM_UNDEFINED;
1298 }
1299 }
1300 #undef FUNC_NAME
1301
1302
1303 static SCM
eval_environment_cell(SCM env,SCM sym,int for_write)1304 eval_environment_cell (SCM env, SCM sym, int for_write)
1305 #define FUNC_NAME "eval_environment_cell"
1306 {
1307 SCM location = eval_environment_lookup (env, sym, for_write);
1308
1309 if (scm_is_pair (location))
1310 return location;
1311 else if (SCM_ENVIRONMENT_P (location))
1312 return SCM_ENVIRONMENT_LOCATION_NO_CELL;
1313 else if (scm_is_eq (location, IMMUTABLE))
1314 return SCM_ENVIRONMENT_LOCATION_IMMUTABLE;
1315 else
1316 return SCM_UNDEFINED;
1317 }
1318 #undef FUNC_NAME
1319
1320
1321 static SCM
eval_environment_mark(SCM env)1322 eval_environment_mark (SCM env)
1323 {
1324 struct eval_environment *body = EVAL_ENVIRONMENT (env);
1325
1326 scm_gc_mark (body->obarray);
1327 scm_gc_mark (body->imported);
1328 scm_gc_mark (body->imported_observer);
1329 scm_gc_mark (body->local);
1330 scm_gc_mark (body->local_observer);
1331
1332 return core_environments_mark (env);
1333 }
1334
1335
1336 static void
eval_environment_free(SCM env)1337 eval_environment_free (SCM env)
1338 {
1339 core_environments_finalize (env);
1340 scm_gc_free (EVAL_ENVIRONMENT (env), sizeof (struct eval_environment),
1341 "eval environment");
1342 }
1343
1344
1345 static int
eval_environment_print(SCM type,SCM port,scm_print_state * pstate SCM_UNUSED)1346 eval_environment_print (SCM type, SCM port, scm_print_state *pstate SCM_UNUSED)
1347 {
1348 SCM address = scm_from_size_t (SCM_UNPACK (type));
1349 SCM base16 = scm_number_to_string (address, scm_from_int (16));
1350
1351 scm_puts ("#<eval environment ", port);
1352 scm_display (base16, port);
1353 scm_puts (">", port);
1354
1355 return 1;
1356 }
1357
1358
1359 static struct scm_environment_funcs eval_environment_funcs = {
1360 eval_environment_ref,
1361 eval_environment_fold,
1362 eval_environment_define,
1363 eval_environment_undefine,
1364 eval_environment_set_x,
1365 eval_environment_cell,
1366 core_environments_observe,
1367 core_environments_unobserve,
1368 eval_environment_mark,
1369 eval_environment_free,
1370 eval_environment_print
1371 };
1372
1373
1374 void *scm_type_eval_environment = &eval_environment_funcs;
1375
1376
1377 static void
eval_environment_observer(SCM caller SCM_UNUSED,SCM eval_env)1378 eval_environment_observer (SCM caller SCM_UNUSED, SCM eval_env)
1379 {
1380 SCM obarray = EVAL_ENVIRONMENT (eval_env)->obarray;
1381
1382 obarray_remove_all (obarray);
1383 core_environments_broadcast (eval_env);
1384 }
1385
1386
1387 SCM_DEFINE (scm_make_eval_environment, "make-eval-environment", 2, 0, 0,
1388 (SCM local, SCM imported),
1389 "Return a new environment object eval whose bindings are the\n"
1390 "union of the bindings in the environments @var{local} and\n"
1391 "@var{imported}, with bindings from @var{local} taking\n"
1392 "precedence. Definitions made in eval are placed in @var{local}.\n"
1393 "Applying @code{environment-define} or\n"
1394 "@code{environment-undefine} to eval has the same effect as\n"
1395 "applying the procedure to @var{local}.\n"
1396 "Note that eval incorporates @var{local} and @var{imported} by\n"
1397 "reference:\n"
1398 "If, after creating eval, the program changes the bindings of\n"
1399 "@var{local} or @var{imported}, those changes will be visible\n"
1400 "in eval.\n"
1401 "Since most Scheme evaluation takes place in eval environments,\n"
1402 "they transparently cache the bindings received from @var{local}\n"
1403 "and @var{imported}. Thus, the first time the program looks up\n"
1404 "a symbol in eval, eval may make calls to @var{local} or\n"
1405 "@var{imported} to find their bindings, but subsequent\n"
1406 "references to that symbol will be as fast as references to\n"
1407 "bindings in finite environments.\n"
1408 "In typical use, @var{local} will be a finite environment, and\n"
1409 "@var{imported} will be an import environment")
1410 #define FUNC_NAME s_scm_make_eval_environment
1411 {
1412 SCM env;
1413 struct eval_environment *body;
1414
1415 SCM_ASSERT (SCM_ENVIRONMENT_P (local), local, SCM_ARG1, FUNC_NAME);
1416 SCM_ASSERT (SCM_ENVIRONMENT_P (imported), imported, SCM_ARG2, FUNC_NAME);
1417
1418 body = scm_gc_malloc (sizeof (struct eval_environment), "eval environment");
1419
1420 core_environments_preinit (&body->base);
1421 body->obarray = SCM_BOOL_F;
1422 body->imported = SCM_BOOL_F;
1423 body->imported_observer = SCM_BOOL_F;
1424 body->local = SCM_BOOL_F;
1425 body->local_observer = SCM_BOOL_F;
1426
1427 env = scm_make_environment (body);
1428
1429 core_environments_init (&body->base, &eval_environment_funcs);
1430 body->obarray = scm_c_make_hash_table (DEFAULT_OBARRAY_SIZE);
1431 body->imported = imported;
1432 body->imported_observer
1433 = SCM_ENVIRONMENT_OBSERVE (imported, eval_environment_observer, env, 1);
1434 body->local = local;
1435 body->local_observer
1436 = SCM_ENVIRONMENT_OBSERVE (local, eval_environment_observer, env, 1);
1437
1438 return env;
1439 }
1440 #undef FUNC_NAME
1441
1442
1443 SCM_DEFINE (scm_eval_environment_p, "eval-environment?", 1, 0, 0,
1444 (SCM object),
1445 "Return @code{#t} if object is an eval environment, or @code{#f}\n"
1446 "otherwise.")
1447 #define FUNC_NAME s_scm_eval_environment_p
1448 {
1449 return scm_from_bool (SCM_EVAL_ENVIRONMENT_P (object));
1450 }
1451 #undef FUNC_NAME
1452
1453
1454 SCM_DEFINE (scm_eval_environment_local, "eval-environment-local", 1, 0, 0,
1455 (SCM env),
1456 "Return the local environment of eval environment @var{env}.")
1457 #define FUNC_NAME s_scm_eval_environment_local
1458 {
1459 SCM_ASSERT (SCM_EVAL_ENVIRONMENT_P (env), env, SCM_ARG1, FUNC_NAME);
1460
1461 return EVAL_ENVIRONMENT (env)->local;
1462 }
1463 #undef FUNC_NAME
1464
1465
1466 SCM_DEFINE (scm_eval_environment_set_local_x, "eval-environment-set-local!", 2, 0, 0,
1467 (SCM env, SCM local),
1468 "Change @var{env}'s local environment to @var{local}.")
1469 #define FUNC_NAME s_scm_eval_environment_set_local_x
1470 {
1471 struct eval_environment *body;
1472
1473 SCM_ASSERT (SCM_EVAL_ENVIRONMENT_P (env), env, SCM_ARG1, FUNC_NAME);
1474 SCM_ASSERT (SCM_ENVIRONMENT_P (local), local, SCM_ARG2, FUNC_NAME);
1475
1476 body = EVAL_ENVIRONMENT (env);
1477
1478 obarray_remove_all (body->obarray);
1479 SCM_ENVIRONMENT_UNOBSERVE (body->local, body->local_observer);
1480
1481 body->local = local;
1482 body->local_observer
1483 = SCM_ENVIRONMENT_OBSERVE (local, eval_environment_observer, env, 1);
1484
1485 core_environments_broadcast (env);
1486
1487 return SCM_UNSPECIFIED;
1488 }
1489 #undef FUNC_NAME
1490
1491
1492 SCM_DEFINE (scm_eval_environment_imported, "eval-environment-imported", 1, 0, 0,
1493 (SCM env),
1494 "Return the imported environment of eval environment @var{env}.")
1495 #define FUNC_NAME s_scm_eval_environment_imported
1496 {
1497 SCM_ASSERT (SCM_EVAL_ENVIRONMENT_P (env), env, SCM_ARG1, FUNC_NAME);
1498
1499 return EVAL_ENVIRONMENT (env)->imported;
1500 }
1501 #undef FUNC_NAME
1502
1503
1504 SCM_DEFINE (scm_eval_environment_set_imported_x, "eval-environment-set-imported!", 2, 0, 0,
1505 (SCM env, SCM imported),
1506 "Change @var{env}'s imported environment to @var{imported}.")
1507 #define FUNC_NAME s_scm_eval_environment_set_imported_x
1508 {
1509 struct eval_environment *body;
1510
1511 SCM_ASSERT (SCM_EVAL_ENVIRONMENT_P (env), env, SCM_ARG1, FUNC_NAME);
1512 SCM_ASSERT (SCM_ENVIRONMENT_P (imported), imported, SCM_ARG2, FUNC_NAME);
1513
1514 body = EVAL_ENVIRONMENT (env);
1515
1516 obarray_remove_all (body->obarray);
1517 SCM_ENVIRONMENT_UNOBSERVE (body->imported, body->imported_observer);
1518
1519 body->imported = imported;
1520 body->imported_observer
1521 = SCM_ENVIRONMENT_OBSERVE (imported, eval_environment_observer, env, 1);
1522
1523 core_environments_broadcast (env);
1524
1525 return SCM_UNSPECIFIED;
1526 }
1527 #undef FUNC_NAME
1528
1529
1530
1531 /* import environments
1532 *
1533 * An import environment combines the bindings of a set of argument
1534 * environments, and checks for naming clashes.
1535 *
1536 * Implementation: The import environment does no caching at all. For every
1537 * access, the list of imported environments is scanned.
1538 */
1539
1540
1541 struct import_environment {
1542 struct core_environments_base base;
1543
1544 SCM imports;
1545 SCM import_observers;
1546
1547 SCM conflict_proc;
1548 };
1549
1550
1551 #define IMPORT_ENVIRONMENT(env) \
1552 ((struct import_environment *) SCM_CELL_WORD_1 (env))
1553
1554
1555
1556 /* Lookup will report one of the following distinct results:
1557 * a) <environment> if only environment binds the symbol.
1558 * b) (env-1 env-2 ...) for conflicting bindings in env-1, ...
1559 * c) SCM_UNDEFINED if there is no binding for the symbol.
1560 */
1561 static SCM
import_environment_lookup(SCM env,SCM sym)1562 import_environment_lookup (SCM env, SCM sym)
1563 {
1564 SCM imports = IMPORT_ENVIRONMENT (env)->imports;
1565 SCM result = SCM_UNDEFINED;
1566 SCM l;
1567
1568 for (l = imports; !scm_is_null (l); l = SCM_CDR (l))
1569 {
1570 SCM imported = SCM_CAR (l);
1571
1572 if (SCM_ENVIRONMENT_BOUND_P (imported, sym))
1573 {
1574 if (SCM_UNBNDP (result))
1575 result = imported;
1576 else if (scm_is_pair (result))
1577 result = scm_cons (imported, result);
1578 else
1579 result = scm_cons2 (imported, result, SCM_EOL);
1580 }
1581 }
1582
1583 if (scm_is_pair (result))
1584 return scm_reverse (result);
1585 else
1586 return result;
1587 }
1588
1589
1590 static SCM
import_environment_conflict(SCM env,SCM sym,SCM imports)1591 import_environment_conflict (SCM env, SCM sym, SCM imports)
1592 {
1593 SCM conflict_proc = IMPORT_ENVIRONMENT (env)->conflict_proc;
1594 SCM args = scm_cons2 (env, sym, scm_cons (imports, SCM_EOL));
1595
1596 return scm_apply_0 (conflict_proc, args);
1597 }
1598
1599
1600 static SCM
import_environment_ref(SCM env,SCM sym)1601 import_environment_ref (SCM env, SCM sym)
1602 #define FUNC_NAME "import_environment_ref"
1603 {
1604 SCM owner = import_environment_lookup (env, sym);
1605
1606 if (SCM_UNBNDP (owner))
1607 {
1608 return SCM_UNDEFINED;
1609 }
1610 else if (scm_is_pair (owner))
1611 {
1612 SCM resolve = import_environment_conflict (env, sym, owner);
1613
1614 if (SCM_ENVIRONMENT_P (resolve))
1615 return SCM_ENVIRONMENT_REF (resolve, sym);
1616 else
1617 return SCM_UNSPECIFIED;
1618 }
1619 else
1620 {
1621 return SCM_ENVIRONMENT_REF (owner, sym);
1622 }
1623 }
1624 #undef FUNC_NAME
1625
1626
1627 static SCM
import_environment_folder(SCM extended_data,SCM symbol,SCM value,SCM tail)1628 import_environment_folder (SCM extended_data, SCM symbol, SCM value, SCM tail)
1629 #define FUNC_NAME "import_environment_fold"
1630 {
1631 SCM import_env = SCM_CAR (extended_data);
1632 SCM imported_env = SCM_CADR (extended_data);
1633 SCM owner = import_environment_lookup (import_env, symbol);
1634 SCM proc_as_nr = SCM_CADDR (extended_data);
1635 unsigned long int proc_as_ul = scm_to_ulong (proc_as_nr);
1636 scm_environment_folder proc = (scm_environment_folder) proc_as_ul;
1637 SCM data = SCM_CDDDR (extended_data);
1638
1639 if (scm_is_pair (owner) && scm_is_eq (SCM_CAR (owner), imported_env))
1640 owner = import_environment_conflict (import_env, symbol, owner);
1641
1642 if (SCM_ENVIRONMENT_P (owner))
1643 return (*proc) (data, symbol, value, tail);
1644 else /* unresolved conflict */
1645 return (*proc) (data, symbol, SCM_UNSPECIFIED, tail);
1646 }
1647 #undef FUNC_NAME
1648
1649
1650 static SCM
import_environment_fold(SCM env,scm_environment_folder proc,SCM data,SCM init)1651 import_environment_fold (SCM env, scm_environment_folder proc, SCM data, SCM init)
1652 {
1653 SCM proc_as_nr = scm_from_ulong ((unsigned long) proc);
1654 SCM result = init;
1655 SCM l;
1656
1657 for (l = IMPORT_ENVIRONMENT (env)->imports; !scm_is_null (l); l = SCM_CDR (l))
1658 {
1659 SCM imported_env = SCM_CAR (l);
1660 SCM extended_data = scm_cons (env, scm_cons2 (imported_env, proc_as_nr, data));
1661
1662 result = scm_c_environment_fold (imported_env, import_environment_folder, extended_data, result);
1663 }
1664
1665 return result;
1666 }
1667
1668
1669 static SCM
import_environment_define(SCM env SCM_UNUSED,SCM sym SCM_UNUSED,SCM val SCM_UNUSED)1670 import_environment_define (SCM env SCM_UNUSED,
1671 SCM sym SCM_UNUSED,
1672 SCM val SCM_UNUSED)
1673 #define FUNC_NAME "import_environment_define"
1674 {
1675 return SCM_ENVIRONMENT_BINDING_IMMUTABLE;
1676 }
1677 #undef FUNC_NAME
1678
1679
1680 static SCM
import_environment_undefine(SCM env SCM_UNUSED,SCM sym SCM_UNUSED)1681 import_environment_undefine (SCM env SCM_UNUSED,
1682 SCM sym SCM_UNUSED)
1683 #define FUNC_NAME "import_environment_undefine"
1684 {
1685 return SCM_ENVIRONMENT_BINDING_IMMUTABLE;
1686 }
1687 #undef FUNC_NAME
1688
1689
1690 static SCM
import_environment_set_x(SCM env,SCM sym,SCM val)1691 import_environment_set_x (SCM env, SCM sym, SCM val)
1692 #define FUNC_NAME "import_environment_set_x"
1693 {
1694 SCM owner = import_environment_lookup (env, sym);
1695
1696 if (SCM_UNBNDP (owner))
1697 {
1698 return SCM_UNDEFINED;
1699 }
1700 else if (scm_is_pair (owner))
1701 {
1702 SCM resolve = import_environment_conflict (env, sym, owner);
1703
1704 if (SCM_ENVIRONMENT_P (resolve))
1705 return SCM_ENVIRONMENT_SET (resolve, sym, val);
1706 else
1707 return SCM_ENVIRONMENT_LOCATION_IMMUTABLE;
1708 }
1709 else
1710 {
1711 return SCM_ENVIRONMENT_SET (owner, sym, val);
1712 }
1713 }
1714 #undef FUNC_NAME
1715
1716
1717 static SCM
import_environment_cell(SCM env,SCM sym,int for_write)1718 import_environment_cell (SCM env, SCM sym, int for_write)
1719 #define FUNC_NAME "import_environment_cell"
1720 {
1721 SCM owner = import_environment_lookup (env, sym);
1722
1723 if (SCM_UNBNDP (owner))
1724 {
1725 return SCM_UNDEFINED;
1726 }
1727 else if (scm_is_pair (owner))
1728 {
1729 SCM resolve = import_environment_conflict (env, sym, owner);
1730
1731 if (SCM_ENVIRONMENT_P (resolve))
1732 return SCM_ENVIRONMENT_CELL (resolve, sym, for_write);
1733 else
1734 return SCM_ENVIRONMENT_LOCATION_NO_CELL;
1735 }
1736 else
1737 {
1738 return SCM_ENVIRONMENT_CELL (owner, sym, for_write);
1739 }
1740 }
1741 #undef FUNC_NAME
1742
1743
1744 static SCM
import_environment_mark(SCM env)1745 import_environment_mark (SCM env)
1746 {
1747 scm_gc_mark (IMPORT_ENVIRONMENT (env)->imports);
1748 scm_gc_mark (IMPORT_ENVIRONMENT (env)->import_observers);
1749 scm_gc_mark (IMPORT_ENVIRONMENT (env)->conflict_proc);
1750 return core_environments_mark (env);
1751 }
1752
1753
1754 static void
import_environment_free(SCM env)1755 import_environment_free (SCM env)
1756 {
1757 core_environments_finalize (env);
1758 scm_gc_free (IMPORT_ENVIRONMENT (env), sizeof (struct import_environment),
1759 "import environment");
1760 }
1761
1762
1763 static int
import_environment_print(SCM type,SCM port,scm_print_state * pstate SCM_UNUSED)1764 import_environment_print (SCM type, SCM port,
1765 scm_print_state *pstate SCM_UNUSED)
1766 {
1767 SCM address = scm_from_size_t (SCM_UNPACK (type));
1768 SCM base16 = scm_number_to_string (address, scm_from_int (16));
1769
1770 scm_puts ("#<import environment ", port);
1771 scm_display (base16, port);
1772 scm_puts (">", port);
1773
1774 return 1;
1775 }
1776
1777
1778 static struct scm_environment_funcs import_environment_funcs = {
1779 import_environment_ref,
1780 import_environment_fold,
1781 import_environment_define,
1782 import_environment_undefine,
1783 import_environment_set_x,
1784 import_environment_cell,
1785 core_environments_observe,
1786 core_environments_unobserve,
1787 import_environment_mark,
1788 import_environment_free,
1789 import_environment_print
1790 };
1791
1792
1793 void *scm_type_import_environment = &import_environment_funcs;
1794
1795
1796 static void
import_environment_observer(SCM caller SCM_UNUSED,SCM import_env)1797 import_environment_observer (SCM caller SCM_UNUSED, SCM import_env)
1798 {
1799 core_environments_broadcast (import_env);
1800 }
1801
1802
1803 SCM_DEFINE (scm_make_import_environment, "make-import-environment", 2, 0, 0,
1804 (SCM imports, SCM conflict_proc),
1805 "Return a new environment @var{imp} whose bindings are the union\n"
1806 "of the bindings from the environments in @var{imports};\n"
1807 "@var{imports} must be a list of environments. That is,\n"
1808 "@var{imp} binds a symbol to a location when some element of\n"
1809 "@var{imports} does.\n"
1810 "If two different elements of @var{imports} have a binding for\n"
1811 "the same symbol, the @var{conflict-proc} is called with the\n"
1812 "following parameters: the import environment, the symbol and\n"
1813 "the list of the imported environments that bind the symbol.\n"
1814 "If the @var{conflict-proc} returns an environment @var{env},\n"
1815 "the conflict is considered as resolved and the binding from\n"
1816 "@var{env} is used. If the @var{conflict-proc} returns some\n"
1817 "non-environment object, the conflict is considered unresolved\n"
1818 "and the symbol is treated as unspecified in the import\n"
1819 "environment.\n"
1820 "The checking for conflicts may be performed lazily, i. e. at\n"
1821 "the moment when a value or binding for a certain symbol is\n"
1822 "requested instead of the moment when the environment is\n"
1823 "created or the bindings of the imports change.\n"
1824 "All bindings in @var{imp} are immutable. If you apply\n"
1825 "@code{environment-define} or @code{environment-undefine} to\n"
1826 "@var{imp}, Guile will signal an\n"
1827 " @code{environment:immutable-binding} error. However,\n"
1828 "notice that the set of bindings in @var{imp} may still change,\n"
1829 "if one of its imported environments changes.")
1830 #define FUNC_NAME s_scm_make_import_environment
1831 {
1832 size_t size = sizeof (struct import_environment);
1833 struct import_environment *body = scm_gc_malloc (size, "import environment");
1834 SCM env;
1835
1836 core_environments_preinit (&body->base);
1837 body->imports = SCM_BOOL_F;
1838 body->import_observers = SCM_BOOL_F;
1839 body->conflict_proc = SCM_BOOL_F;
1840
1841 env = scm_make_environment (body);
1842
1843 core_environments_init (&body->base, &import_environment_funcs);
1844 body->imports = SCM_EOL;
1845 body->import_observers = SCM_EOL;
1846 body->conflict_proc = conflict_proc;
1847
1848 scm_import_environment_set_imports_x (env, imports);
1849
1850 return env;
1851 }
1852 #undef FUNC_NAME
1853
1854
1855 SCM_DEFINE (scm_import_environment_p, "import-environment?", 1, 0, 0,
1856 (SCM object),
1857 "Return @code{#t} if object is an import environment, or\n"
1858 "@code{#f} otherwise.")
1859 #define FUNC_NAME s_scm_import_environment_p
1860 {
1861 return scm_from_bool (SCM_IMPORT_ENVIRONMENT_P (object));
1862 }
1863 #undef FUNC_NAME
1864
1865
1866 SCM_DEFINE (scm_import_environment_imports, "import-environment-imports", 1, 0, 0,
1867 (SCM env),
1868 "Return the list of environments imported by the import\n"
1869 "environment @var{env}.")
1870 #define FUNC_NAME s_scm_import_environment_imports
1871 {
1872 SCM_ASSERT (SCM_IMPORT_ENVIRONMENT_P (env), env, SCM_ARG1, FUNC_NAME);
1873
1874 return IMPORT_ENVIRONMENT (env)->imports;
1875 }
1876 #undef FUNC_NAME
1877
1878
1879 SCM_DEFINE (scm_import_environment_set_imports_x, "import-environment-set-imports!", 2, 0, 0,
1880 (SCM env, SCM imports),
1881 "Change @var{env}'s list of imported environments to\n"
1882 "@var{imports}, and check for conflicts.")
1883 #define FUNC_NAME s_scm_import_environment_set_imports_x
1884 {
1885 struct import_environment *body = IMPORT_ENVIRONMENT (env);
1886 SCM import_observers = SCM_EOL;
1887 SCM l;
1888
1889 SCM_ASSERT (SCM_IMPORT_ENVIRONMENT_P (env), env, SCM_ARG1, FUNC_NAME);
1890 for (l = imports; scm_is_pair (l); l = SCM_CDR (l))
1891 {
1892 SCM obj = SCM_CAR (l);
1893 SCM_ASSERT (SCM_ENVIRONMENT_P (obj), imports, SCM_ARG2, FUNC_NAME);
1894 }
1895 SCM_ASSERT (scm_is_null (l), imports, SCM_ARG2, FUNC_NAME);
1896
1897 for (l = body->import_observers; !scm_is_null (l); l = SCM_CDR (l))
1898 {
1899 SCM obs = SCM_CAR (l);
1900 SCM_ENVIRONMENT_UNOBSERVE (env, obs);
1901 }
1902
1903 for (l = imports; !scm_is_null (l); l = SCM_CDR (l))
1904 {
1905 SCM imp = SCM_CAR (l);
1906 SCM obs = SCM_ENVIRONMENT_OBSERVE (imp, import_environment_observer, env, 1);
1907 import_observers = scm_cons (obs, import_observers);
1908 }
1909
1910 body->imports = imports;
1911 body->import_observers = import_observers;
1912
1913 return SCM_UNSPECIFIED;
1914 }
1915 #undef FUNC_NAME
1916
1917
1918
1919 /* export environments
1920 *
1921 * An export environment restricts an environment to a specified set of
1922 * bindings.
1923 *
1924 * Implementation: The export environment does no caching at all. For every
1925 * access, the signature is scanned. The signature that is stored internally
1926 * is an alist of pairs (symbol . (mutability)).
1927 */
1928
1929
1930 struct export_environment {
1931 struct core_environments_base base;
1932
1933 SCM private;
1934 SCM private_observer;
1935
1936 SCM signature;
1937 };
1938
1939
1940 #define EXPORT_ENVIRONMENT(env) \
1941 ((struct export_environment *) SCM_CELL_WORD_1 (env))
1942
1943
1944 SCM_SYMBOL (symbol_immutable_location, "immutable-location");
1945 SCM_SYMBOL (symbol_mutable_location, "mutable-location");
1946
1947
1948
1949 static SCM
export_environment_ref(SCM env,SCM sym)1950 export_environment_ref (SCM env, SCM sym)
1951 #define FUNC_NAME "export_environment_ref"
1952 {
1953 struct export_environment *body = EXPORT_ENVIRONMENT (env);
1954 SCM entry = scm_assq (sym, body->signature);
1955
1956 if (scm_is_false (entry))
1957 return SCM_UNDEFINED;
1958 else
1959 return SCM_ENVIRONMENT_REF (body->private, sym);
1960 }
1961 #undef FUNC_NAME
1962
1963
1964 static SCM
export_environment_fold(SCM env,scm_environment_folder proc,SCM data,SCM init)1965 export_environment_fold (SCM env, scm_environment_folder proc, SCM data, SCM init)
1966 {
1967 struct export_environment *body = EXPORT_ENVIRONMENT (env);
1968 SCM result = init;
1969 SCM l;
1970
1971 for (l = body->signature; !scm_is_null (l); l = SCM_CDR (l))
1972 {
1973 SCM symbol = SCM_CAR (l);
1974 SCM value = SCM_ENVIRONMENT_REF (body->private, symbol);
1975 if (!SCM_UNBNDP (value))
1976 result = (*proc) (data, symbol, value, result);
1977 }
1978 return result;
1979 }
1980
1981
1982 static SCM
export_environment_define(SCM env SCM_UNUSED,SCM sym SCM_UNUSED,SCM val SCM_UNUSED)1983 export_environment_define (SCM env SCM_UNUSED,
1984 SCM sym SCM_UNUSED,
1985 SCM val SCM_UNUSED)
1986 #define FUNC_NAME "export_environment_define"
1987 {
1988 return SCM_ENVIRONMENT_BINDING_IMMUTABLE;
1989 }
1990 #undef FUNC_NAME
1991
1992
1993 static SCM
export_environment_undefine(SCM env SCM_UNUSED,SCM sym SCM_UNUSED)1994 export_environment_undefine (SCM env SCM_UNUSED, SCM sym SCM_UNUSED)
1995 #define FUNC_NAME "export_environment_undefine"
1996 {
1997 return SCM_ENVIRONMENT_BINDING_IMMUTABLE;
1998 }
1999 #undef FUNC_NAME
2000
2001
2002 static SCM
export_environment_set_x(SCM env,SCM sym,SCM val)2003 export_environment_set_x (SCM env, SCM sym, SCM val)
2004 #define FUNC_NAME "export_environment_set_x"
2005 {
2006 struct export_environment *body = EXPORT_ENVIRONMENT (env);
2007 SCM entry = scm_assq (sym, body->signature);
2008
2009 if (scm_is_false (entry))
2010 {
2011 return SCM_UNDEFINED;
2012 }
2013 else
2014 {
2015 if (scm_is_eq (SCM_CADR (entry), symbol_mutable_location))
2016 return SCM_ENVIRONMENT_SET (body->private, sym, val);
2017 else
2018 return SCM_ENVIRONMENT_LOCATION_IMMUTABLE;
2019 }
2020 }
2021 #undef FUNC_NAME
2022
2023
2024 static SCM
export_environment_cell(SCM env,SCM sym,int for_write)2025 export_environment_cell (SCM env, SCM sym, int for_write)
2026 #define FUNC_NAME "export_environment_cell"
2027 {
2028 struct export_environment *body = EXPORT_ENVIRONMENT (env);
2029 SCM entry = scm_assq (sym, body->signature);
2030
2031 if (scm_is_false (entry))
2032 {
2033 return SCM_UNDEFINED;
2034 }
2035 else
2036 {
2037 if (!for_write || scm_is_eq (SCM_CADR (entry), symbol_mutable_location))
2038 return SCM_ENVIRONMENT_CELL (body->private, sym, for_write);
2039 else
2040 return SCM_ENVIRONMENT_LOCATION_IMMUTABLE;
2041 }
2042 }
2043 #undef FUNC_NAME
2044
2045
2046 static SCM
export_environment_mark(SCM env)2047 export_environment_mark (SCM env)
2048 {
2049 struct export_environment *body = EXPORT_ENVIRONMENT (env);
2050
2051 scm_gc_mark (body->private);
2052 scm_gc_mark (body->private_observer);
2053 scm_gc_mark (body->signature);
2054
2055 return core_environments_mark (env);
2056 }
2057
2058
2059 static void
export_environment_free(SCM env)2060 export_environment_free (SCM env)
2061 {
2062 core_environments_finalize (env);
2063 scm_gc_free (EXPORT_ENVIRONMENT (env), sizeof (struct export_environment),
2064 "export environment");
2065 }
2066
2067
2068 static int
export_environment_print(SCM type,SCM port,scm_print_state * pstate SCM_UNUSED)2069 export_environment_print (SCM type, SCM port,
2070 scm_print_state *pstate SCM_UNUSED)
2071 {
2072 SCM address = scm_from_size_t (SCM_UNPACK (type));
2073 SCM base16 = scm_number_to_string (address, scm_from_int (16));
2074
2075 scm_puts ("#<export environment ", port);
2076 scm_display (base16, port);
2077 scm_puts (">", port);
2078
2079 return 1;
2080 }
2081
2082
2083 static struct scm_environment_funcs export_environment_funcs = {
2084 export_environment_ref,
2085 export_environment_fold,
2086 export_environment_define,
2087 export_environment_undefine,
2088 export_environment_set_x,
2089 export_environment_cell,
2090 core_environments_observe,
2091 core_environments_unobserve,
2092 export_environment_mark,
2093 export_environment_free,
2094 export_environment_print
2095 };
2096
2097
2098 void *scm_type_export_environment = &export_environment_funcs;
2099
2100
2101 static void
export_environment_observer(SCM caller SCM_UNUSED,SCM export_env)2102 export_environment_observer (SCM caller SCM_UNUSED, SCM export_env)
2103 {
2104 core_environments_broadcast (export_env);
2105 }
2106
2107
2108 SCM_DEFINE (scm_make_export_environment, "make-export-environment", 2, 0, 0,
2109 (SCM private, SCM signature),
2110 "Return a new environment @var{exp} containing only those\n"
2111 "bindings in private whose symbols are present in\n"
2112 "@var{signature}. The @var{private} argument must be an\n"
2113 "environment.\n\n"
2114 "The environment @var{exp} binds symbol to location when\n"
2115 "@var{env} does, and symbol is exported by @var{signature}.\n\n"
2116 "@var{signature} is a list specifying which of the bindings in\n"
2117 "@var{private} should be visible in @var{exp}. Each element of\n"
2118 "@var{signature} should be a list of the form:\n"
2119 " (symbol attribute ...)\n"
2120 "where each attribute is one of the following:\n"
2121 "@table @asis\n"
2122 "@item the symbol @code{mutable-location}\n"
2123 " @var{exp} should treat the\n"
2124 " location bound to symbol as mutable. That is, @var{exp}\n"
2125 " will pass calls to @code{environment-set!} or\n"
2126 " @code{environment-cell} directly through to private.\n"
2127 "@item the symbol @code{immutable-location}\n"
2128 " @var{exp} should treat\n"
2129 " the location bound to symbol as immutable. If the program\n"
2130 " applies @code{environment-set!} to @var{exp} and symbol, or\n"
2131 " calls @code{environment-cell} to obtain a writable value\n"
2132 " cell, @code{environment-set!} will signal an\n"
2133 " @code{environment:immutable-location} error. Note that, even\n"
2134 " if an export environment treats a location as immutable, the\n"
2135 " underlying environment may treat it as mutable, so its\n"
2136 " value may change.\n"
2137 "@end table\n"
2138 "It is an error for an element of signature to specify both\n"
2139 "@code{mutable-location} and @code{immutable-location}. If\n"
2140 "neither is specified, @code{immutable-location} is assumed.\n\n"
2141 "As a special case, if an element of signature is a lone\n"
2142 "symbol @var{sym}, it is equivalent to an element of the form\n"
2143 "@code{(sym)}.\n\n"
2144 "All bindings in @var{exp} are immutable. If you apply\n"
2145 "@code{environment-define} or @code{environment-undefine} to\n"
2146 "@var{exp}, Guile will signal an\n"
2147 "@code{environment:immutable-binding} error. However,\n"
2148 "notice that the set of bindings in @var{exp} may still change,\n"
2149 "if the bindings in private change.")
2150 #define FUNC_NAME s_scm_make_export_environment
2151 {
2152 size_t size;
2153 struct export_environment *body;
2154 SCM env;
2155
2156 SCM_ASSERT (SCM_ENVIRONMENT_P (private), private, SCM_ARG1, FUNC_NAME);
2157
2158 size = sizeof (struct export_environment);
2159 body = scm_gc_malloc (size, "export environment");
2160
2161 core_environments_preinit (&body->base);
2162 body->private = SCM_BOOL_F;
2163 body->private_observer = SCM_BOOL_F;
2164 body->signature = SCM_BOOL_F;
2165
2166 env = scm_make_environment (body);
2167
2168 core_environments_init (&body->base, &export_environment_funcs);
2169 body->private = private;
2170 body->private_observer
2171 = SCM_ENVIRONMENT_OBSERVE (private, export_environment_observer, env, 1);
2172 body->signature = SCM_EOL;
2173
2174 scm_export_environment_set_signature_x (env, signature);
2175
2176 return env;
2177 }
2178 #undef FUNC_NAME
2179
2180
2181 SCM_DEFINE (scm_export_environment_p, "export-environment?", 1, 0, 0,
2182 (SCM object),
2183 "Return @code{#t} if object is an export environment, or\n"
2184 "@code{#f} otherwise.")
2185 #define FUNC_NAME s_scm_export_environment_p
2186 {
2187 return scm_from_bool (SCM_EXPORT_ENVIRONMENT_P (object));
2188 }
2189 #undef FUNC_NAME
2190
2191
2192 SCM_DEFINE (scm_export_environment_private, "export-environment-private", 1, 0, 0,
2193 (SCM env),
2194 "Return the private environment of export environment @var{env}.")
2195 #define FUNC_NAME s_scm_export_environment_private
2196 {
2197 SCM_ASSERT (SCM_EXPORT_ENVIRONMENT_P (env), env, SCM_ARG1, FUNC_NAME);
2198
2199 return EXPORT_ENVIRONMENT (env)->private;
2200 }
2201 #undef FUNC_NAME
2202
2203
2204 SCM_DEFINE (scm_export_environment_set_private_x, "export-environment-set-private!", 2, 0, 0,
2205 (SCM env, SCM private),
2206 "Change the private environment of export environment @var{env}.")
2207 #define FUNC_NAME s_scm_export_environment_set_private_x
2208 {
2209 struct export_environment *body;
2210
2211 SCM_ASSERT (SCM_EXPORT_ENVIRONMENT_P (env), env, SCM_ARG1, FUNC_NAME);
2212 SCM_ASSERT (SCM_ENVIRONMENT_P (private), private, SCM_ARG2, FUNC_NAME);
2213
2214 body = EXPORT_ENVIRONMENT (env);
2215 SCM_ENVIRONMENT_UNOBSERVE (private, body->private_observer);
2216
2217 body->private = private;
2218 body->private_observer
2219 = SCM_ENVIRONMENT_OBSERVE (private, export_environment_observer, env, 1);
2220
2221 return SCM_UNSPECIFIED;
2222 }
2223 #undef FUNC_NAME
2224
2225
2226 SCM_DEFINE (scm_export_environment_signature, "export-environment-signature", 1, 0, 0,
2227 (SCM env),
2228 "Return the signature of export environment @var{env}.")
2229 #define FUNC_NAME s_scm_export_environment_signature
2230 {
2231 SCM_ASSERT (SCM_EXPORT_ENVIRONMENT_P (env), env, SCM_ARG1, FUNC_NAME);
2232
2233 return EXPORT_ENVIRONMENT (env)->signature;
2234 }
2235 #undef FUNC_NAME
2236
2237
2238 static SCM
export_environment_parse_signature(SCM signature,const char * caller)2239 export_environment_parse_signature (SCM signature, const char* caller)
2240 {
2241 SCM result = SCM_EOL;
2242 SCM l;
2243
2244 for (l = signature; scm_is_pair (l); l = SCM_CDR (l))
2245 {
2246 SCM entry = SCM_CAR (l);
2247
2248 if (scm_is_symbol (entry))
2249 {
2250 SCM new_entry = scm_cons2 (entry, symbol_immutable_location, SCM_EOL);
2251 result = scm_cons (new_entry, result);
2252 }
2253 else
2254 {
2255 SCM sym;
2256 SCM new_entry;
2257 int immutable = 0;
2258 int mutable = 0;
2259 SCM mutability;
2260 SCM l2;
2261
2262 SCM_ASSERT (scm_is_pair (entry), entry, SCM_ARGn, caller);
2263 SCM_ASSERT (scm_is_symbol (SCM_CAR (entry)), entry, SCM_ARGn, caller);
2264
2265 sym = SCM_CAR (entry);
2266
2267 for (l2 = SCM_CDR (entry); scm_is_pair (l2); l2 = SCM_CDR (l2))
2268 {
2269 SCM attribute = SCM_CAR (l2);
2270 if (scm_is_eq (attribute, symbol_immutable_location))
2271 immutable = 1;
2272 else if (scm_is_eq (attribute, symbol_mutable_location))
2273 mutable = 1;
2274 else
2275 SCM_ASSERT (0, entry, SCM_ARGn, caller);
2276 }
2277 SCM_ASSERT (scm_is_null (l2), entry, SCM_ARGn, caller);
2278 SCM_ASSERT (!mutable || !immutable, entry, SCM_ARGn, caller);
2279
2280 if (!mutable && !immutable)
2281 immutable = 1;
2282
2283 mutability = mutable ? symbol_mutable_location : symbol_immutable_location;
2284 new_entry = scm_cons2 (sym, mutability, SCM_EOL);
2285 result = scm_cons (new_entry, result);
2286 }
2287 }
2288 SCM_ASSERT (scm_is_null (l), signature, SCM_ARGn, caller);
2289
2290 /* Dirk:FIXME:: Now we know that signature is syntactically correct. There
2291 * are, however, no checks for symbols entered twice with contradicting
2292 * mutabilities. It would be nice, to implement this test, to be able to
2293 * call the sort functions conveniently from C.
2294 */
2295
2296 return scm_reverse (result);
2297 }
2298
2299
2300 SCM_DEFINE (scm_export_environment_set_signature_x, "export-environment-set-signature!", 2, 0, 0,
2301 (SCM env, SCM signature),
2302 "Change the signature of export environment @var{env}.")
2303 #define FUNC_NAME s_scm_export_environment_set_signature_x
2304 {
2305 SCM parsed_sig;
2306
2307 SCM_ASSERT (SCM_EXPORT_ENVIRONMENT_P (env), env, SCM_ARG1, FUNC_NAME);
2308 parsed_sig = export_environment_parse_signature (signature, FUNC_NAME);
2309
2310 EXPORT_ENVIRONMENT (env)->signature = parsed_sig;
2311
2312 return SCM_UNSPECIFIED;
2313 }
2314 #undef FUNC_NAME
2315
2316
2317
2318 void
scm_environments_prehistory()2319 scm_environments_prehistory ()
2320 {
2321 /* create environment smob */
2322 scm_tc16_environment = scm_make_smob_type ("environment", 0);
2323 scm_set_smob_mark (scm_tc16_environment, environment_mark);
2324 scm_set_smob_free (scm_tc16_environment, environment_free);
2325 scm_set_smob_print (scm_tc16_environment, environment_print);
2326
2327 /* create observer smob */
2328 scm_tc16_observer = scm_make_smob_type ("observer", 0);
2329 scm_set_smob_mark (scm_tc16_observer, observer_mark);
2330 scm_set_smob_print (scm_tc16_observer, observer_print);
2331
2332 /* create system environment */
2333 scm_system_environment = scm_make_leaf_environment ();
2334 scm_permanent_object (scm_system_environment);
2335 }
2336
2337
2338 void
scm_init_environments()2339 scm_init_environments ()
2340 {
2341 #include "libguile/environments.x"
2342 }
2343
2344
2345 /*
2346 Local Variables:
2347 c-file-style: "gnu"
2348 End:
2349 */
2350