1 /* Copyright (C) 1999,2000,2001, 2003, 2006, 2008 Free Software Foundation, Inc.
3 * This library is free software; you can redistribute it and/or
4 * modify it under the terms of the GNU Lesser General Public License
5 * as published by the Free Software Foundation; either version 3 of
6 * the License, or (at your option) any later version.
8 * This library is distributed in the hope that it will be useful, but
9 * 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.
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
24 #include "libguile/_scm.h"
25 #include "libguile/alist.h"
26 #include "libguile/eval.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"
35 #include "libguile/environments.h"
39 scm_t_bits scm_tc16_environment
;
40 scm_t_bits scm_tc16_observer
;
41 #define DEFAULT_OBARRAY_SIZE 31
43 SCM scm_system_environment
;
47 /* error conditions */
50 * Throw an error if symbol is not bound in environment func
53 scm_error_environment_unbound (const char *func
, SCM env
, SCM symbol
)
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
);
63 * Throw an error if func tried to create (define) or remove
64 * (undefine) a new binding for symbol in env
67 scm_error_environment_immutable_binding (const char *func
, SCM env
, SCM symbol
)
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
);
77 * Throw an error if func tried to change an immutable location.
80 scm_error_environment_immutable_location (const char *func
, SCM env
, SCM symbol
)
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
);
90 /* generic environments */
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.
100 scm_make_environment (void *type
)
102 SCM_RETURN_NEWSMOB (scm_tc16_environment
, type
);
106 SCM_DEFINE (scm_environment_p
, "environment?", 1, 0, 0,
108 "Return @code{#t} if @var{obj} is an environment, or @code{#f}\n"
110 #define FUNC_NAME s_scm_environment_p
112 return scm_from_bool (SCM_ENVIRONMENT_P (obj
));
117 SCM_DEFINE (scm_environment_bound_p
, "environment-bound?", 2, 0, 0,
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
123 SCM_ASSERT (SCM_ENVIRONMENT_P (env
), env
, SCM_ARG1
, FUNC_NAME
);
124 SCM_ASSERT (scm_is_symbol (sym
), sym
, SCM_ARG2
, FUNC_NAME
);
126 return scm_from_bool (SCM_ENVIRONMENT_BOUND_P (env
, sym
));
131 SCM_DEFINE (scm_environment_ref
, "environment-ref", 2, 0, 0,
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
140 SCM_ASSERT (SCM_ENVIRONMENT_P (env
), env
, SCM_ARG1
, FUNC_NAME
);
141 SCM_ASSERT (scm_is_symbol (sym
), sym
, SCM_ARG2
, FUNC_NAME
);
143 val
= SCM_ENVIRONMENT_REF (env
, sym
);
145 if (!SCM_UNBNDP (val
))
148 scm_error_environment_unbound (FUNC_NAME
, env
, sym
);
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
158 scm_c_environment_ref (SCM env
, SCM sym
)
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
);
167 environment_default_folder (SCM proc
, SCM symbol
, SCM value
, SCM tail
)
169 return scm_call_3 (proc
, symbol
, value
, tail
);
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"
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"
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"
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"
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"
200 " (define (environment->alist env)\n"
201 " (environment-fold env\n"
202 " (lambda (sym val tail)\n"
203 " (cons (cons sym val) tail))\n"
206 #define FUNC_NAME s_scm_environment_fold
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
);
212 return SCM_ENVIRONMENT_FOLD (env
, environment_default_folder
, proc
, init
);
217 /* This is the C-level analog of environment-fold. For each binding in ENV,
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.
224 scm_c_environment_fold (SCM env
, scm_environment_folder proc
, SCM data
, SCM init
)
226 SCM_ASSERT (SCM_ENVIRONMENT_P (env
), env
, SCM_ARG1
, "scm_c_environment_fold");
228 return SCM_ENVIRONMENT_FOLD (env
, proc
, data
, init
);
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
245 SCM_ASSERT (SCM_ENVIRONMENT_P (env
), env
, SCM_ARG1
, FUNC_NAME
);
246 SCM_ASSERT (scm_is_symbol (sym
), sym
, SCM_ARG2
, FUNC_NAME
);
248 status
= SCM_ENVIRONMENT_DEFINE (env
, sym
, val
);
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
);
260 SCM_DEFINE (scm_environment_undefine
, "environment-undefine", 2, 0, 0,
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"
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
271 SCM_ASSERT(SCM_ENVIRONMENT_P(env
), env
, SCM_ARG1
, FUNC_NAME
);
272 SCM_ASSERT(scm_is_symbol(sym
), sym
, SCM_ARG2
, FUNC_NAME
);
274 status
= SCM_ENVIRONMENT_UNDEFINE (env
, sym
);
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
);
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"
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
299 SCM_ASSERT (SCM_ENVIRONMENT_P (env
), env
, SCM_ARG1
, FUNC_NAME
);
300 SCM_ASSERT (scm_is_symbol (sym
), sym
, SCM_ARG2
, FUNC_NAME
);
302 status
= SCM_ENVIRONMENT_SET (env
, sym
, val
);
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
);
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
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
);
338 location
= SCM_ENVIRONMENT_CELL (env
, sym
, scm_is_true (for_write
));
339 if (!SCM_IMP (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
);
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.
358 scm_c_environment_cell(SCM env
, SCM sym
, int for_write
)
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");
363 return SCM_ENVIRONMENT_CELL (env
, sym
, for_write
);
368 environment_default_observer (SCM env
, SCM proc
)
370 scm_call_1 (proc
, env
);
374 SCM_DEFINE (scm_environment_observe
, "environment-observe", 2, 0, 0,
376 "Whenever @var{env}'s bindings change, apply @var{proc} to\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
384 SCM_ASSERT (SCM_ENVIRONMENT_P (env
), env
, SCM_ARG1
, FUNC_NAME
);
386 return SCM_ENVIRONMENT_OBSERVE (env
, environment_default_observer
, proc
, 0);
391 SCM_DEFINE (scm_environment_observe_weak
, "environment-observe-weak", 2, 0, 0,
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
401 SCM_ASSERT (SCM_ENVIRONMENT_P (env
), env
, SCM_ARG1
, FUNC_NAME
);
403 return SCM_ENVIRONMENT_OBSERVE (env
, environment_default_observer
, proc
, 1);
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.
417 scm_c_environment_observe (SCM env
, scm_environment_observer proc
, SCM data
, int weak_p
)
418 #define FUNC_NAME "scm_c_environment_observe"
420 SCM_ASSERT (SCM_ENVIRONMENT_P (env
), env
, SCM_ARG1
, FUNC_NAME
);
422 return SCM_ENVIRONMENT_OBSERVE (env
, proc
, data
, weak_p
);
427 SCM_DEFINE (scm_environment_unobserve
, "environment-unobserve", 1, 0, 0,
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"
435 #define FUNC_NAME s_scm_environment_unobserve
439 SCM_ASSERT (SCM_OBSERVER_P (token
), token
, SCM_ARG1
, FUNC_NAME
);
441 env
= SCM_OBSERVER_ENVIRONMENT (token
);
442 SCM_ENVIRONMENT_UNOBSERVE (env
, token
);
444 return SCM_UNSPECIFIED
;
451 environment_print (SCM env
, SCM port
, scm_print_state
*pstate
)
453 return (*(SCM_ENVIRONMENT_FUNCS (env
)->print
)) (env
, port
, pstate
);
462 observer_print (SCM type
, SCM port
, scm_print_state
*pstate SCM_UNUSED
)
464 SCM address
= scm_from_size_t (SCM_UNPACK (type
));
465 SCM base16
= scm_number_to_string (address
, scm_from_int (16));
467 scm_puts ("#<observer ", port
);
468 scm_display (base16
, port
);
469 scm_puts (">", port
);
478 * Obarrays form the basic lookup tables used to implement most of guile's
479 * built-in environment types. An obarray is implemented as a hash table with
480 * symbols as keys. The content of the data depends on the environment type.
485 * Enter symbol into obarray. The symbol must not already exist in obarray.
486 * The freshly generated (symbol . data) cell is returned.
489 obarray_enter (SCM obarray
, SCM symbol
, SCM data
)
491 size_t hash
= scm_i_symbol_hash (symbol
) % SCM_HASHTABLE_N_BUCKETS (obarray
);
492 SCM entry
= scm_cons (symbol
, data
);
493 SCM slot
= scm_cons (entry
, SCM_HASHTABLE_BUCKET (obarray
, hash
));
494 SCM_SET_HASHTABLE_BUCKET (obarray
, hash
, slot
);
495 SCM_HASHTABLE_INCREMENT (obarray
);
496 if (SCM_HASHTABLE_N_ITEMS (obarray
) > SCM_HASHTABLE_UPPER (obarray
))
497 scm_i_rehash (obarray
, scm_i_hash_symbol
, 0, "obarray_enter");
504 * Enter symbol into obarray. An existing entry for symbol is replaced. If
505 * an entry existed, the old (symbol . data) cell is returned, #f otherwise.
508 obarray_replace (SCM obarray
, SCM symbol
, SCM data
)
510 size_t hash
= scm_i_symbol_hash (symbol
) % SCM_HASHTABLE_N_BUCKETS (obarray
);
511 SCM new_entry
= scm_cons (symbol
, data
);
515 for (lsym
= SCM_HASHTABLE_BUCKET (obarray
, hash
);
517 lsym
= SCM_CDR (lsym
))
519 SCM old_entry
= SCM_CAR (lsym
);
520 if (scm_is_eq (SCM_CAR (old_entry
), symbol
))
522 SCM_SETCAR (lsym
, new_entry
);
527 slot
= scm_cons (new_entry
, SCM_HASHTABLE_BUCKET (obarray
, hash
));
528 SCM_SET_HASHTABLE_BUCKET (obarray
, hash
, slot
);
529 SCM_HASHTABLE_INCREMENT (obarray
);
530 if (SCM_HASHTABLE_N_ITEMS (obarray
) > SCM_HASHTABLE_UPPER (obarray
))
531 scm_i_rehash (obarray
, scm_i_hash_symbol
, 0, "obarray_replace");
538 * Look up symbol in obarray
541 obarray_retrieve (SCM obarray
, SCM sym
)
543 size_t hash
= scm_i_symbol_hash (sym
) % SCM_HASHTABLE_N_BUCKETS (obarray
);
546 for (lsym
= SCM_HASHTABLE_BUCKET (obarray
, hash
);
548 lsym
= SCM_CDR (lsym
))
550 SCM entry
= SCM_CAR (lsym
);
551 if (scm_is_eq (SCM_CAR (entry
), sym
))
555 return SCM_UNDEFINED
;
560 * Remove entry from obarray. If the symbol was found and removed, the old
561 * (symbol . data) cell is returned, #f otherwise.
564 obarray_remove (SCM obarray
, SCM sym
)
566 size_t hash
= scm_i_symbol_hash (sym
) % SCM_HASHTABLE_N_BUCKETS (obarray
);
567 SCM table_entry
= SCM_HASHTABLE_BUCKET (obarray
, hash
);
568 SCM handle
= scm_sloppy_assq (sym
, table_entry
);
570 if (scm_is_pair (handle
))
572 SCM new_table_entry
= scm_delq1_x (handle
, table_entry
);
573 SCM_SET_HASHTABLE_BUCKET (obarray
, hash
, new_table_entry
);
574 SCM_HASHTABLE_DECREMENT (obarray
);
582 obarray_remove_all (SCM obarray
)
584 size_t size
= SCM_HASHTABLE_N_BUCKETS (obarray
);
587 for (i
= 0; i
< size
; i
++)
589 SCM_SET_HASHTABLE_BUCKET (obarray
, i
, SCM_EOL
);
591 SCM_SET_HASHTABLE_N_ITEMS (obarray
, 0);
596 /* core environments base
598 * This struct and the corresponding functions form a base class for guile's
599 * built-in environment types.
603 struct core_environments_base
{
604 struct scm_environment_funcs
*funcs
;
611 #define CORE_ENVIRONMENTS_BASE(env) \
612 ((struct core_environments_base *) SCM_CELL_WORD_1 (env))
613 #define CORE_ENVIRONMENT_OBSERVERS(env) \
614 (CORE_ENVIRONMENTS_BASE (env)->observers)
615 #define SCM_SET_CORE_ENVIRONMENT_OBSERVERS(env, v) \
616 (CORE_ENVIRONMENT_OBSERVERS (env) = (v))
617 #define CORE_ENVIRONMENT_WEAK_OBSERVER_VECTOR(env) \
618 (CORE_ENVIRONMENTS_BASE (env)->weak_observers)
619 #define CORE_ENVIRONMENT_WEAK_OBSERVERS(env) \
620 (scm_c_vector_ref (CORE_ENVIRONMENT_WEAK_OBSERVER_VECTOR (env), 0))
621 #define SCM_SET_CORE_ENVIRONMENT_WEAK_OBSERVERS(env, v) \
622 (scm_c_vector_set_x (CORE_ENVIRONMENT_WEAK_OBSERVER_VECTOR (env), 0, (v)))
627 core_environments_observe (SCM env
, scm_environment_observer proc
, SCM data
, int weak_p
)
631 SCM_NEWSMOB3 (observer
, scm_tc16_observer
,
638 SCM observers
= CORE_ENVIRONMENT_OBSERVERS (env
);
639 SCM new_observers
= scm_cons (observer
, observers
);
640 SCM_SET_CORE_ENVIRONMENT_OBSERVERS (env
, new_observers
);
644 SCM observers
= CORE_ENVIRONMENT_WEAK_OBSERVERS (env
);
645 SCM new_observers
= scm_acons (SCM_BOOL_F
, observer
, observers
);
646 SCM_SET_CORE_ENVIRONMENT_WEAK_OBSERVERS (env
, new_observers
);
654 core_environments_unobserve (SCM env
, SCM observer
)
656 unsigned int handling_weaks
;
657 for (handling_weaks
= 0; handling_weaks
<= 1; ++handling_weaks
)
659 SCM l
= handling_weaks
660 ? CORE_ENVIRONMENT_WEAK_OBSERVERS (env
)
661 : CORE_ENVIRONMENT_OBSERVERS (env
);
663 if (!scm_is_null (l
))
665 SCM rest
= SCM_CDR (l
);
666 SCM first
= handling_weaks
670 if (scm_is_eq (first
, observer
))
672 /* Remove the first observer */
674 SCM_SET_CORE_ENVIRONMENT_WEAK_OBSERVERS (env
, rest
);
676 SCM_SET_CORE_ENVIRONMENT_OBSERVERS (env
, rest
);
681 SCM rest
= SCM_CDR (l
);
683 if (!scm_is_null (rest
))
685 SCM next
= handling_weaks
689 if (scm_is_eq (next
, observer
))
691 SCM_SETCDR (l
, SCM_CDR (rest
));
697 } while (!scm_is_null (l
));
701 /* Dirk:FIXME:: What to do now, since the observer is not found? */
706 core_environments_preinit (struct core_environments_base
*body
)
709 body
->observers
= SCM_BOOL_F
;
710 body
->weak_observers
= SCM_BOOL_F
;
715 core_environments_init (struct core_environments_base
*body
,
716 struct scm_environment_funcs
*funcs
)
719 body
->observers
= SCM_EOL
;
720 body
->weak_observers
= scm_make_weak_value_alist_vector (scm_from_int (1));
724 /* Tell all observers to clear their caches.
726 * Environments have to be informed about changes in the following cases:
727 * - The observed env has a new binding. This must be always reported.
728 * - The observed env has dropped a binding. This must be always reported.
729 * - A binding in the observed environment has changed. This must only be
730 * reported, if there is a chance that the binding is being cached outside.
731 * However, this potential optimization is not performed currently.
733 * Errors that occur while the observers are called are accumulated and
734 * signalled as one single error message to the caller.
745 update_catch_body (void *ptr
)
747 struct update_data
*data
= (struct update_data
*) ptr
;
748 SCM observer
= data
->observer
;
750 (*SCM_OBSERVER_PROC (observer
))
751 (data
->environment
, SCM_OBSERVER_DATA (observer
));
753 return SCM_UNDEFINED
;
758 update_catch_handler (void *ptr
, SCM tag
, SCM args
)
760 struct update_data
*data
= (struct update_data
*) ptr
;
761 SCM observer
= data
->observer
;
763 scm_from_locale_string ("Observer `~A' signals `~A' error: ~S");
765 return scm_cons (message
, scm_list_3 (observer
, tag
, args
));
770 core_environments_broadcast (SCM env
)
771 #define FUNC_NAME "core_environments_broadcast"
773 unsigned int handling_weaks
;
774 SCM errors
= SCM_EOL
;
776 for (handling_weaks
= 0; handling_weaks
<= 1; ++handling_weaks
)
778 SCM observers
= handling_weaks
779 ? CORE_ENVIRONMENT_WEAK_OBSERVERS (env
)
780 : CORE_ENVIRONMENT_OBSERVERS (env
);
782 for (; !scm_is_null (observers
); observers
= SCM_CDR (observers
))
784 struct update_data data
;
785 SCM observer
= handling_weaks
786 ? SCM_CDAR (observers
)
787 : SCM_CAR (observers
);
790 data
.observer
= observer
;
791 data
.environment
= env
;
793 error
= scm_internal_catch (SCM_BOOL_T
,
794 update_catch_body
, &data
,
795 update_catch_handler
, &data
);
797 if (!SCM_UNBNDP (error
))
798 errors
= scm_cons (error
, errors
);
802 if (!scm_is_null (errors
))
804 /* Dirk:FIXME:: As soon as scm_misc_error is fixed to handle the name
805 * parameter correctly it should not be necessary any more to also pass
806 * namestr in order to get the desired information from the error
809 SCM ordered_errors
= scm_reverse (errors
);
812 "Observers of `~A' have signalled the following errors: ~S",
813 scm_cons2 (env
, ordered_errors
, SCM_EOL
));
822 * A leaf environment is simply a mutable set of definitions. A leaf
823 * environment supports no operations beyond the common set.
825 * Implementation: The obarray of the leaf environment holds (symbol . value)
826 * pairs. No further information is necessary, since all bindings and
827 * locations in a leaf environment are mutable.
831 struct leaf_environment
{
832 struct core_environments_base base
;
838 #define LEAF_ENVIRONMENT(env) \
839 ((struct leaf_environment *) SCM_CELL_WORD_1 (env))
844 leaf_environment_ref (SCM env
, SCM sym
)
846 SCM obarray
= LEAF_ENVIRONMENT (env
)->obarray
;
847 SCM binding
= obarray_retrieve (obarray
, sym
);
848 return SCM_UNBNDP (binding
) ? binding
: SCM_CDR (binding
);
853 leaf_environment_fold (SCM env
, scm_environment_folder proc
, SCM data
, SCM init
)
857 SCM obarray
= LEAF_ENVIRONMENT (env
)->obarray
;
859 for (i
= 0; i
< SCM_HASHTABLE_N_BUCKETS (obarray
); i
++)
862 for (l
= SCM_HASHTABLE_BUCKET (obarray
, i
);
866 SCM binding
= SCM_CAR (l
);
867 SCM symbol
= SCM_CAR (binding
);
868 SCM value
= SCM_CDR (binding
);
869 result
= (*proc
) (data
, symbol
, value
, result
);
877 leaf_environment_define (SCM env
, SCM sym
, SCM val
)
878 #define FUNC_NAME "leaf_environment_define"
880 SCM obarray
= LEAF_ENVIRONMENT (env
)->obarray
;
882 obarray_replace (obarray
, sym
, val
);
883 core_environments_broadcast (env
);
885 return SCM_ENVIRONMENT_SUCCESS
;
891 leaf_environment_undefine (SCM env
, SCM sym
)
892 #define FUNC_NAME "leaf_environment_undefine"
894 SCM obarray
= LEAF_ENVIRONMENT (env
)->obarray
;
895 SCM removed
= obarray_remove (obarray
, sym
);
897 if (scm_is_true (removed
))
898 core_environments_broadcast (env
);
900 return SCM_ENVIRONMENT_SUCCESS
;
906 leaf_environment_set_x (SCM env
, SCM sym
, SCM val
)
907 #define FUNC_NAME "leaf_environment_set_x"
909 SCM obarray
= LEAF_ENVIRONMENT (env
)->obarray
;
910 SCM binding
= obarray_retrieve (obarray
, sym
);
912 if (!SCM_UNBNDP (binding
))
914 SCM_SETCDR (binding
, val
);
915 return SCM_ENVIRONMENT_SUCCESS
;
919 return SCM_UNDEFINED
;
926 leaf_environment_cell (SCM env
, SCM sym
, int for_write SCM_UNUSED
)
928 SCM obarray
= LEAF_ENVIRONMENT (env
)->obarray
;
929 SCM binding
= obarray_retrieve (obarray
, sym
);
936 leaf_environment_print (SCM type
, SCM port
, scm_print_state
*pstate SCM_UNUSED
)
938 SCM address
= scm_from_size_t (SCM_UNPACK (type
));
939 SCM base16
= scm_number_to_string (address
, scm_from_int (16));
941 scm_puts ("#<leaf environment ", port
);
942 scm_display (base16
, port
);
943 scm_puts (">", port
);
949 static struct scm_environment_funcs leaf_environment_funcs
= {
950 leaf_environment_ref
,
951 leaf_environment_fold
,
952 leaf_environment_define
,
953 leaf_environment_undefine
,
954 leaf_environment_set_x
,
955 leaf_environment_cell
,
956 core_environments_observe
,
957 core_environments_unobserve
,
958 leaf_environment_print
962 void *scm_type_leaf_environment
= &leaf_environment_funcs
;
965 SCM_DEFINE (scm_make_leaf_environment
, "make-leaf-environment", 0, 0, 0,
967 "Create a new leaf environment, containing no bindings.\n"
968 "All bindings and locations created in the new environment\n"
970 #define FUNC_NAME s_scm_make_leaf_environment
972 size_t size
= sizeof (struct leaf_environment
);
973 struct leaf_environment
*body
= scm_gc_malloc (size
, "leaf environment");
976 core_environments_preinit (&body
->base
);
977 body
->obarray
= SCM_BOOL_F
;
979 env
= scm_make_environment (body
);
981 core_environments_init (&body
->base
, &leaf_environment_funcs
);
982 body
->obarray
= scm_c_make_hash_table (DEFAULT_OBARRAY_SIZE
);
989 SCM_DEFINE (scm_leaf_environment_p
, "leaf-environment?", 1, 0, 0,
991 "Return @code{#t} if object is a leaf environment, or @code{#f}\n"
993 #define FUNC_NAME s_scm_leaf_environment_p
995 return scm_from_bool (SCM_LEAF_ENVIRONMENT_P (object
));
1001 /* eval environments
1003 * A module's source code refers to definitions imported from other modules,
1004 * and definitions made within itself. An eval environment combines two
1005 * environments -- a local environment and an imported environment -- to
1006 * produce a new environment in which both sorts of references can be
1009 * Implementation: The obarray of the eval environment is used to cache
1010 * entries from the local and imported environments such that in most of the
1011 * cases only a single lookup is necessary. Since for neither the local nor
1012 * the imported environment it is known, what kind of environment they form,
1013 * the most general case is assumed. Therefore, entries in the obarray take
1014 * one of the following forms:
1016 * 1) (<symbol> location mutability . source-env), where mutability indicates
1017 * one of the following states: IMMUTABLE if the location is known to be
1018 * immutable, MUTABLE if the location is known to be mutable, UNKNOWN if
1019 * the location has only been requested for non modifying accesses.
1021 * 2) (symbol . source-env) if the symbol has a binding in the source-env, but
1022 * if the source-env can't provide a cell for the binding. Thus, for every
1023 * access, the source-env has to be contacted directly.
1027 struct eval_environment
{
1028 struct core_environments_base base
;
1033 SCM imported_observer
;
1039 #define EVAL_ENVIRONMENT(env) \
1040 ((struct eval_environment *) SCM_CELL_WORD_1 (env))
1042 #define IMMUTABLE SCM_I_MAKINUM (0)
1043 #define MUTABLE SCM_I_MAKINUM (1)
1044 #define UNKNOWN SCM_I_MAKINUM (2)
1046 #define CACHED_LOCATION(x) SCM_CAR (x)
1047 #define CACHED_MUTABILITY(x) SCM_CADR (x)
1048 #define SET_CACHED_MUTABILITY(x, v) SCM_SETCAR (SCM_CDR (x), (v))
1049 #define CACHED_SOURCE_ENVIRONMENT(x) SCM_CDDR (x)
1053 /* eval_environment_lookup will report one of the following distinct results:
1054 * a) (<object> . value) if a cell could be obtained.
1055 * b) <environment> if the environment has to be contacted directly.
1056 * c) IMMUTABLE if an immutable cell was requested for write.
1057 * d) SCM_UNDEFINED if there is no binding for the symbol.
1060 eval_environment_lookup (SCM env
, SCM sym
, int for_write
)
1062 SCM obarray
= EVAL_ENVIRONMENT (env
)->obarray
;
1063 SCM binding
= obarray_retrieve (obarray
, sym
);
1065 if (!SCM_UNBNDP (binding
))
1067 /* The obarray holds an entry for the symbol. */
1069 SCM entry
= SCM_CDR (binding
);
1071 if (scm_is_pair (entry
))
1073 /* The entry in the obarray is a cached location. */
1075 SCM location
= CACHED_LOCATION (entry
);
1081 mutability
= CACHED_MUTABILITY (entry
);
1082 if (scm_is_eq (mutability
, MUTABLE
))
1085 if (scm_is_eq (mutability
, UNKNOWN
))
1087 SCM source_env
= CACHED_SOURCE_ENVIRONMENT (entry
);
1088 SCM location
= SCM_ENVIRONMENT_CELL (source_env
, sym
, 1);
1090 if (scm_is_pair (location
))
1092 SET_CACHED_MUTABILITY (entry
, MUTABLE
);
1095 else /* IMMUTABLE */
1097 SET_CACHED_MUTABILITY (entry
, IMMUTABLE
);
1106 /* The obarray entry is an environment */
1113 /* There is no entry for the symbol in the obarray. This can either
1114 * mean that there has not been a request for the symbol yet, or that
1115 * the symbol is really undefined. We are looking for the symbol in
1116 * both the local and the imported environment. If we find a binding, a
1117 * cached entry is created.
1120 struct eval_environment
*body
= EVAL_ENVIRONMENT (env
);
1121 unsigned int handling_import
;
1123 for (handling_import
= 0; handling_import
<= 1; ++handling_import
)
1125 SCM source_env
= handling_import
? body
->imported
: body
->local
;
1126 SCM location
= SCM_ENVIRONMENT_CELL (source_env
, sym
, for_write
);
1128 if (!SCM_UNBNDP (location
))
1130 if (scm_is_pair (location
))
1132 SCM mutability
= for_write
? MUTABLE
: UNKNOWN
;
1133 SCM entry
= scm_cons2 (location
, mutability
, source_env
);
1134 obarray_enter (obarray
, sym
, entry
);
1137 else if (scm_is_eq (location
, SCM_ENVIRONMENT_LOCATION_NO_CELL
))
1139 obarray_enter (obarray
, sym
, source_env
);
1149 return SCM_UNDEFINED
;
1155 eval_environment_ref (SCM env
, SCM sym
)
1156 #define FUNC_NAME "eval_environment_ref"
1158 SCM location
= eval_environment_lookup (env
, sym
, 0);
1160 if (scm_is_pair (location
))
1161 return SCM_CDR (location
);
1162 else if (!SCM_UNBNDP (location
))
1163 return SCM_ENVIRONMENT_REF (location
, sym
);
1165 return SCM_UNDEFINED
;
1171 eval_environment_folder (SCM extended_data
, SCM symbol
, SCM value
, SCM tail
)
1173 SCM local
= SCM_CAR (extended_data
);
1175 if (!SCM_ENVIRONMENT_BOUND_P (local
, symbol
))
1177 SCM proc_as_nr
= SCM_CADR (extended_data
);
1178 unsigned long int proc_as_ul
= scm_to_ulong (proc_as_nr
);
1179 scm_environment_folder proc
= (scm_environment_folder
) proc_as_ul
;
1180 SCM data
= SCM_CDDR (extended_data
);
1182 return (*proc
) (data
, symbol
, value
, tail
);
1192 eval_environment_fold (SCM env
, scm_environment_folder proc
, SCM data
, SCM init
)
1194 SCM local
= EVAL_ENVIRONMENT (env
)->local
;
1195 SCM imported
= EVAL_ENVIRONMENT (env
)->imported
;
1196 SCM proc_as_nr
= scm_from_ulong ((unsigned long) proc
);
1197 SCM extended_data
= scm_cons2 (local
, proc_as_nr
, data
);
1198 SCM tmp_result
= scm_c_environment_fold (imported
, eval_environment_folder
, extended_data
, init
);
1200 return scm_c_environment_fold (local
, proc
, data
, tmp_result
);
1205 eval_environment_define (SCM env
, SCM sym
, SCM val
)
1206 #define FUNC_NAME "eval_environment_define"
1208 SCM local
= EVAL_ENVIRONMENT (env
)->local
;
1209 return SCM_ENVIRONMENT_DEFINE (local
, sym
, val
);
1215 eval_environment_undefine (SCM env
, SCM sym
)
1216 #define FUNC_NAME "eval_environment_undefine"
1218 SCM local
= EVAL_ENVIRONMENT (env
)->local
;
1219 return SCM_ENVIRONMENT_UNDEFINE (local
, sym
);
1225 eval_environment_set_x (SCM env
, SCM sym
, SCM val
)
1226 #define FUNC_NAME "eval_environment_set_x"
1228 SCM location
= eval_environment_lookup (env
, sym
, 1);
1230 if (scm_is_pair (location
))
1232 SCM_SETCDR (location
, val
);
1233 return SCM_ENVIRONMENT_SUCCESS
;
1235 else if (SCM_ENVIRONMENT_P (location
))
1237 return SCM_ENVIRONMENT_SET (location
, sym
, val
);
1239 else if (scm_is_eq (location
, IMMUTABLE
))
1241 return SCM_ENVIRONMENT_LOCATION_IMMUTABLE
;
1245 return SCM_UNDEFINED
;
1252 eval_environment_cell (SCM env
, SCM sym
, int for_write
)
1253 #define FUNC_NAME "eval_environment_cell"
1255 SCM location
= eval_environment_lookup (env
, sym
, for_write
);
1257 if (scm_is_pair (location
))
1259 else if (SCM_ENVIRONMENT_P (location
))
1260 return SCM_ENVIRONMENT_LOCATION_NO_CELL
;
1261 else if (scm_is_eq (location
, IMMUTABLE
))
1262 return SCM_ENVIRONMENT_LOCATION_IMMUTABLE
;
1264 return SCM_UNDEFINED
;
1271 eval_environment_print (SCM type
, SCM port
, scm_print_state
*pstate SCM_UNUSED
)
1273 SCM address
= scm_from_size_t (SCM_UNPACK (type
));
1274 SCM base16
= scm_number_to_string (address
, scm_from_int (16));
1276 scm_puts ("#<eval environment ", port
);
1277 scm_display (base16
, port
);
1278 scm_puts (">", port
);
1284 static struct scm_environment_funcs eval_environment_funcs
= {
1285 eval_environment_ref
,
1286 eval_environment_fold
,
1287 eval_environment_define
,
1288 eval_environment_undefine
,
1289 eval_environment_set_x
,
1290 eval_environment_cell
,
1291 core_environments_observe
,
1292 core_environments_unobserve
,
1293 eval_environment_print
1297 void *scm_type_eval_environment
= &eval_environment_funcs
;
1301 eval_environment_observer (SCM caller SCM_UNUSED
, SCM eval_env
)
1303 SCM obarray
= EVAL_ENVIRONMENT (eval_env
)->obarray
;
1305 obarray_remove_all (obarray
);
1306 core_environments_broadcast (eval_env
);
1310 SCM_DEFINE (scm_make_eval_environment
, "make-eval-environment", 2, 0, 0,
1311 (SCM local
, SCM imported
),
1312 "Return a new environment object eval whose bindings are the\n"
1313 "union of the bindings in the environments @var{local} and\n"
1314 "@var{imported}, with bindings from @var{local} taking\n"
1315 "precedence. Definitions made in eval are placed in @var{local}.\n"
1316 "Applying @code{environment-define} or\n"
1317 "@code{environment-undefine} to eval has the same effect as\n"
1318 "applying the procedure to @var{local}.\n"
1319 "Note that eval incorporates @var{local} and @var{imported} by\n"
1321 "If, after creating eval, the program changes the bindings of\n"
1322 "@var{local} or @var{imported}, those changes will be visible\n"
1324 "Since most Scheme evaluation takes place in eval environments,\n"
1325 "they transparently cache the bindings received from @var{local}\n"
1326 "and @var{imported}. Thus, the first time the program looks up\n"
1327 "a symbol in eval, eval may make calls to @var{local} or\n"
1328 "@var{imported} to find their bindings, but subsequent\n"
1329 "references to that symbol will be as fast as references to\n"
1330 "bindings in finite environments.\n"
1331 "In typical use, @var{local} will be a finite environment, and\n"
1332 "@var{imported} will be an import environment")
1333 #define FUNC_NAME s_scm_make_eval_environment
1336 struct eval_environment
*body
;
1338 SCM_ASSERT (SCM_ENVIRONMENT_P (local
), local
, SCM_ARG1
, FUNC_NAME
);
1339 SCM_ASSERT (SCM_ENVIRONMENT_P (imported
), imported
, SCM_ARG2
, FUNC_NAME
);
1341 body
= scm_gc_malloc (sizeof (struct eval_environment
), "eval environment");
1343 core_environments_preinit (&body
->base
);
1344 body
->obarray
= SCM_BOOL_F
;
1345 body
->imported
= SCM_BOOL_F
;
1346 body
->imported_observer
= SCM_BOOL_F
;
1347 body
->local
= SCM_BOOL_F
;
1348 body
->local_observer
= SCM_BOOL_F
;
1350 env
= scm_make_environment (body
);
1352 core_environments_init (&body
->base
, &eval_environment_funcs
);
1353 body
->obarray
= scm_c_make_hash_table (DEFAULT_OBARRAY_SIZE
);
1354 body
->imported
= imported
;
1355 body
->imported_observer
1356 = SCM_ENVIRONMENT_OBSERVE (imported
, eval_environment_observer
, env
, 1);
1357 body
->local
= local
;
1358 body
->local_observer
1359 = SCM_ENVIRONMENT_OBSERVE (local
, eval_environment_observer
, env
, 1);
1366 SCM_DEFINE (scm_eval_environment_p
, "eval-environment?", 1, 0, 0,
1368 "Return @code{#t} if object is an eval environment, or @code{#f}\n"
1370 #define FUNC_NAME s_scm_eval_environment_p
1372 return scm_from_bool (SCM_EVAL_ENVIRONMENT_P (object
));
1377 SCM_DEFINE (scm_eval_environment_local
, "eval-environment-local", 1, 0, 0,
1379 "Return the local environment of eval environment @var{env}.")
1380 #define FUNC_NAME s_scm_eval_environment_local
1382 SCM_ASSERT (SCM_EVAL_ENVIRONMENT_P (env
), env
, SCM_ARG1
, FUNC_NAME
);
1384 return EVAL_ENVIRONMENT (env
)->local
;
1389 SCM_DEFINE (scm_eval_environment_set_local_x
, "eval-environment-set-local!", 2, 0, 0,
1390 (SCM env
, SCM local
),
1391 "Change @var{env}'s local environment to @var{local}.")
1392 #define FUNC_NAME s_scm_eval_environment_set_local_x
1394 struct eval_environment
*body
;
1396 SCM_ASSERT (SCM_EVAL_ENVIRONMENT_P (env
), env
, SCM_ARG1
, FUNC_NAME
);
1397 SCM_ASSERT (SCM_ENVIRONMENT_P (local
), local
, SCM_ARG2
, FUNC_NAME
);
1399 body
= EVAL_ENVIRONMENT (env
);
1401 obarray_remove_all (body
->obarray
);
1402 SCM_ENVIRONMENT_UNOBSERVE (body
->local
, body
->local_observer
);
1404 body
->local
= local
;
1405 body
->local_observer
1406 = SCM_ENVIRONMENT_OBSERVE (local
, eval_environment_observer
, env
, 1);
1408 core_environments_broadcast (env
);
1410 return SCM_UNSPECIFIED
;
1415 SCM_DEFINE (scm_eval_environment_imported
, "eval-environment-imported", 1, 0, 0,
1417 "Return the imported environment of eval environment @var{env}.")
1418 #define FUNC_NAME s_scm_eval_environment_imported
1420 SCM_ASSERT (SCM_EVAL_ENVIRONMENT_P (env
), env
, SCM_ARG1
, FUNC_NAME
);
1422 return EVAL_ENVIRONMENT (env
)->imported
;
1427 SCM_DEFINE (scm_eval_environment_set_imported_x
, "eval-environment-set-imported!", 2, 0, 0,
1428 (SCM env
, SCM imported
),
1429 "Change @var{env}'s imported environment to @var{imported}.")
1430 #define FUNC_NAME s_scm_eval_environment_set_imported_x
1432 struct eval_environment
*body
;
1434 SCM_ASSERT (SCM_EVAL_ENVIRONMENT_P (env
), env
, SCM_ARG1
, FUNC_NAME
);
1435 SCM_ASSERT (SCM_ENVIRONMENT_P (imported
), imported
, SCM_ARG2
, FUNC_NAME
);
1437 body
= EVAL_ENVIRONMENT (env
);
1439 obarray_remove_all (body
->obarray
);
1440 SCM_ENVIRONMENT_UNOBSERVE (body
->imported
, body
->imported_observer
);
1442 body
->imported
= imported
;
1443 body
->imported_observer
1444 = SCM_ENVIRONMENT_OBSERVE (imported
, eval_environment_observer
, env
, 1);
1446 core_environments_broadcast (env
);
1448 return SCM_UNSPECIFIED
;
1454 /* import environments
1456 * An import environment combines the bindings of a set of argument
1457 * environments, and checks for naming clashes.
1459 * Implementation: The import environment does no caching at all. For every
1460 * access, the list of imported environments is scanned.
1464 struct import_environment
{
1465 struct core_environments_base base
;
1468 SCM import_observers
;
1474 #define IMPORT_ENVIRONMENT(env) \
1475 ((struct import_environment *) SCM_CELL_WORD_1 (env))
1479 /* Lookup will report one of the following distinct results:
1480 * a) <environment> if only environment binds the symbol.
1481 * b) (env-1 env-2 ...) for conflicting bindings in env-1, ...
1482 * c) SCM_UNDEFINED if there is no binding for the symbol.
1485 import_environment_lookup (SCM env
, SCM sym
)
1487 SCM imports
= IMPORT_ENVIRONMENT (env
)->imports
;
1488 SCM result
= SCM_UNDEFINED
;
1491 for (l
= imports
; !scm_is_null (l
); l
= SCM_CDR (l
))
1493 SCM imported
= SCM_CAR (l
);
1495 if (SCM_ENVIRONMENT_BOUND_P (imported
, sym
))
1497 if (SCM_UNBNDP (result
))
1499 else if (scm_is_pair (result
))
1500 result
= scm_cons (imported
, result
);
1502 result
= scm_cons2 (imported
, result
, SCM_EOL
);
1506 if (scm_is_pair (result
))
1507 return scm_reverse (result
);
1514 import_environment_conflict (SCM env
, SCM sym
, SCM imports
)
1516 SCM conflict_proc
= IMPORT_ENVIRONMENT (env
)->conflict_proc
;
1517 SCM args
= scm_cons2 (env
, sym
, scm_cons (imports
, SCM_EOL
));
1519 return scm_apply_0 (conflict_proc
, args
);
1524 import_environment_ref (SCM env
, SCM sym
)
1525 #define FUNC_NAME "import_environment_ref"
1527 SCM owner
= import_environment_lookup (env
, sym
);
1529 if (SCM_UNBNDP (owner
))
1531 return SCM_UNDEFINED
;
1533 else if (scm_is_pair (owner
))
1535 SCM resolve
= import_environment_conflict (env
, sym
, owner
);
1537 if (SCM_ENVIRONMENT_P (resolve
))
1538 return SCM_ENVIRONMENT_REF (resolve
, sym
);
1540 return SCM_UNSPECIFIED
;
1544 return SCM_ENVIRONMENT_REF (owner
, sym
);
1551 import_environment_folder (SCM extended_data
, SCM symbol
, SCM value
, SCM tail
)
1552 #define FUNC_NAME "import_environment_fold"
1554 SCM import_env
= SCM_CAR (extended_data
);
1555 SCM imported_env
= SCM_CADR (extended_data
);
1556 SCM owner
= import_environment_lookup (import_env
, symbol
);
1557 SCM proc_as_nr
= SCM_CADDR (extended_data
);
1558 unsigned long int proc_as_ul
= scm_to_ulong (proc_as_nr
);
1559 scm_environment_folder proc
= (scm_environment_folder
) proc_as_ul
;
1560 SCM data
= SCM_CDDDR (extended_data
);
1562 if (scm_is_pair (owner
) && scm_is_eq (SCM_CAR (owner
), imported_env
))
1563 owner
= import_environment_conflict (import_env
, symbol
, owner
);
1565 if (SCM_ENVIRONMENT_P (owner
))
1566 return (*proc
) (data
, symbol
, value
, tail
);
1567 else /* unresolved conflict */
1568 return (*proc
) (data
, symbol
, SCM_UNSPECIFIED
, tail
);
1574 import_environment_fold (SCM env
, scm_environment_folder proc
, SCM data
, SCM init
)
1576 SCM proc_as_nr
= scm_from_ulong ((unsigned long) proc
);
1580 for (l
= IMPORT_ENVIRONMENT (env
)->imports
; !scm_is_null (l
); l
= SCM_CDR (l
))
1582 SCM imported_env
= SCM_CAR (l
);
1583 SCM extended_data
= scm_cons (env
, scm_cons2 (imported_env
, proc_as_nr
, data
));
1585 result
= scm_c_environment_fold (imported_env
, import_environment_folder
, extended_data
, result
);
1593 import_environment_define (SCM env SCM_UNUSED
,
1596 #define FUNC_NAME "import_environment_define"
1598 return SCM_ENVIRONMENT_BINDING_IMMUTABLE
;
1604 import_environment_undefine (SCM env SCM_UNUSED
,
1606 #define FUNC_NAME "import_environment_undefine"
1608 return SCM_ENVIRONMENT_BINDING_IMMUTABLE
;
1614 import_environment_set_x (SCM env
, SCM sym
, SCM val
)
1615 #define FUNC_NAME "import_environment_set_x"
1617 SCM owner
= import_environment_lookup (env
, sym
);
1619 if (SCM_UNBNDP (owner
))
1621 return SCM_UNDEFINED
;
1623 else if (scm_is_pair (owner
))
1625 SCM resolve
= import_environment_conflict (env
, sym
, owner
);
1627 if (SCM_ENVIRONMENT_P (resolve
))
1628 return SCM_ENVIRONMENT_SET (resolve
, sym
, val
);
1630 return SCM_ENVIRONMENT_LOCATION_IMMUTABLE
;
1634 return SCM_ENVIRONMENT_SET (owner
, sym
, val
);
1641 import_environment_cell (SCM env
, SCM sym
, int for_write
)
1642 #define FUNC_NAME "import_environment_cell"
1644 SCM owner
= import_environment_lookup (env
, sym
);
1646 if (SCM_UNBNDP (owner
))
1648 return SCM_UNDEFINED
;
1650 else if (scm_is_pair (owner
))
1652 SCM resolve
= import_environment_conflict (env
, sym
, owner
);
1654 if (SCM_ENVIRONMENT_P (resolve
))
1655 return SCM_ENVIRONMENT_CELL (resolve
, sym
, for_write
);
1657 return SCM_ENVIRONMENT_LOCATION_NO_CELL
;
1661 return SCM_ENVIRONMENT_CELL (owner
, sym
, for_write
);
1669 import_environment_print (SCM type
, SCM port
,
1670 scm_print_state
*pstate SCM_UNUSED
)
1672 SCM address
= scm_from_size_t (SCM_UNPACK (type
));
1673 SCM base16
= scm_number_to_string (address
, scm_from_int (16));
1675 scm_puts ("#<import environment ", port
);
1676 scm_display (base16
, port
);
1677 scm_puts (">", port
);
1683 static struct scm_environment_funcs import_environment_funcs
= {
1684 import_environment_ref
,
1685 import_environment_fold
,
1686 import_environment_define
,
1687 import_environment_undefine
,
1688 import_environment_set_x
,
1689 import_environment_cell
,
1690 core_environments_observe
,
1691 core_environments_unobserve
,
1692 import_environment_print
1696 void *scm_type_import_environment
= &import_environment_funcs
;
1700 import_environment_observer (SCM caller SCM_UNUSED
, SCM import_env
)
1702 core_environments_broadcast (import_env
);
1706 SCM_DEFINE (scm_make_import_environment
, "make-import-environment", 2, 0, 0,
1707 (SCM imports
, SCM conflict_proc
),
1708 "Return a new environment @var{imp} whose bindings are the union\n"
1709 "of the bindings from the environments in @var{imports};\n"
1710 "@var{imports} must be a list of environments. That is,\n"
1711 "@var{imp} binds a symbol to a location when some element of\n"
1712 "@var{imports} does.\n"
1713 "If two different elements of @var{imports} have a binding for\n"
1714 "the same symbol, the @var{conflict-proc} is called with the\n"
1715 "following parameters: the import environment, the symbol and\n"
1716 "the list of the imported environments that bind the symbol.\n"
1717 "If the @var{conflict-proc} returns an environment @var{env},\n"
1718 "the conflict is considered as resolved and the binding from\n"
1719 "@var{env} is used. If the @var{conflict-proc} returns some\n"
1720 "non-environment object, the conflict is considered unresolved\n"
1721 "and the symbol is treated as unspecified in the import\n"
1723 "The checking for conflicts may be performed lazily, i. e. at\n"
1724 "the moment when a value or binding for a certain symbol is\n"
1725 "requested instead of the moment when the environment is\n"
1726 "created or the bindings of the imports change.\n"
1727 "All bindings in @var{imp} are immutable. If you apply\n"
1728 "@code{environment-define} or @code{environment-undefine} to\n"
1729 "@var{imp}, Guile will signal an\n"
1730 " @code{environment:immutable-binding} error. However,\n"
1731 "notice that the set of bindings in @var{imp} may still change,\n"
1732 "if one of its imported environments changes.")
1733 #define FUNC_NAME s_scm_make_import_environment
1735 size_t size
= sizeof (struct import_environment
);
1736 struct import_environment
*body
= scm_gc_malloc (size
, "import environment");
1739 core_environments_preinit (&body
->base
);
1740 body
->imports
= SCM_BOOL_F
;
1741 body
->import_observers
= SCM_BOOL_F
;
1742 body
->conflict_proc
= SCM_BOOL_F
;
1744 env
= scm_make_environment (body
);
1746 core_environments_init (&body
->base
, &import_environment_funcs
);
1747 body
->imports
= SCM_EOL
;
1748 body
->import_observers
= SCM_EOL
;
1749 body
->conflict_proc
= conflict_proc
;
1751 scm_import_environment_set_imports_x (env
, imports
);
1758 SCM_DEFINE (scm_import_environment_p
, "import-environment?", 1, 0, 0,
1760 "Return @code{#t} if object is an import environment, or\n"
1761 "@code{#f} otherwise.")
1762 #define FUNC_NAME s_scm_import_environment_p
1764 return scm_from_bool (SCM_IMPORT_ENVIRONMENT_P (object
));
1769 SCM_DEFINE (scm_import_environment_imports
, "import-environment-imports", 1, 0, 0,
1771 "Return the list of environments imported by the import\n"
1772 "environment @var{env}.")
1773 #define FUNC_NAME s_scm_import_environment_imports
1775 SCM_ASSERT (SCM_IMPORT_ENVIRONMENT_P (env
), env
, SCM_ARG1
, FUNC_NAME
);
1777 return IMPORT_ENVIRONMENT (env
)->imports
;
1782 SCM_DEFINE (scm_import_environment_set_imports_x
, "import-environment-set-imports!", 2, 0, 0,
1783 (SCM env
, SCM imports
),
1784 "Change @var{env}'s list of imported environments to\n"
1785 "@var{imports}, and check for conflicts.")
1786 #define FUNC_NAME s_scm_import_environment_set_imports_x
1788 struct import_environment
*body
= IMPORT_ENVIRONMENT (env
);
1789 SCM import_observers
= SCM_EOL
;
1792 SCM_ASSERT (SCM_IMPORT_ENVIRONMENT_P (env
), env
, SCM_ARG1
, FUNC_NAME
);
1793 for (l
= imports
; scm_is_pair (l
); l
= SCM_CDR (l
))
1795 SCM obj
= SCM_CAR (l
);
1796 SCM_ASSERT (SCM_ENVIRONMENT_P (obj
), imports
, SCM_ARG2
, FUNC_NAME
);
1798 SCM_ASSERT (scm_is_null (l
), imports
, SCM_ARG2
, FUNC_NAME
);
1800 for (l
= body
->import_observers
; !scm_is_null (l
); l
= SCM_CDR (l
))
1802 SCM obs
= SCM_CAR (l
);
1803 SCM_ENVIRONMENT_UNOBSERVE (env
, obs
);
1806 for (l
= imports
; !scm_is_null (l
); l
= SCM_CDR (l
))
1808 SCM imp
= SCM_CAR (l
);
1809 SCM obs
= SCM_ENVIRONMENT_OBSERVE (imp
, import_environment_observer
, env
, 1);
1810 import_observers
= scm_cons (obs
, import_observers
);
1813 body
->imports
= imports
;
1814 body
->import_observers
= import_observers
;
1816 return SCM_UNSPECIFIED
;
1822 /* export environments
1824 * An export environment restricts an environment to a specified set of
1827 * Implementation: The export environment does no caching at all. For every
1828 * access, the signature is scanned. The signature that is stored internally
1829 * is an alist of pairs (symbol . (mutability)).
1833 struct export_environment
{
1834 struct core_environments_base base
;
1837 SCM private_observer
;
1843 #define EXPORT_ENVIRONMENT(env) \
1844 ((struct export_environment *) SCM_CELL_WORD_1 (env))
1847 SCM_SYMBOL (symbol_immutable_location
, "immutable-location");
1848 SCM_SYMBOL (symbol_mutable_location
, "mutable-location");
1853 export_environment_ref (SCM env
, SCM sym
)
1854 #define FUNC_NAME "export_environment_ref"
1856 struct export_environment
*body
= EXPORT_ENVIRONMENT (env
);
1857 SCM entry
= scm_assq (sym
, body
->signature
);
1859 if (scm_is_false (entry
))
1860 return SCM_UNDEFINED
;
1862 return SCM_ENVIRONMENT_REF (body
->private, sym
);
1868 export_environment_fold (SCM env
, scm_environment_folder proc
, SCM data
, SCM init
)
1870 struct export_environment
*body
= EXPORT_ENVIRONMENT (env
);
1874 for (l
= body
->signature
; !scm_is_null (l
); l
= SCM_CDR (l
))
1876 SCM symbol
= SCM_CAR (l
);
1877 SCM value
= SCM_ENVIRONMENT_REF (body
->private, symbol
);
1878 if (!SCM_UNBNDP (value
))
1879 result
= (*proc
) (data
, symbol
, value
, result
);
1886 export_environment_define (SCM env SCM_UNUSED
,
1889 #define FUNC_NAME "export_environment_define"
1891 return SCM_ENVIRONMENT_BINDING_IMMUTABLE
;
1897 export_environment_undefine (SCM env SCM_UNUSED
, SCM sym SCM_UNUSED
)
1898 #define FUNC_NAME "export_environment_undefine"
1900 return SCM_ENVIRONMENT_BINDING_IMMUTABLE
;
1906 export_environment_set_x (SCM env
, SCM sym
, SCM val
)
1907 #define FUNC_NAME "export_environment_set_x"
1909 struct export_environment
*body
= EXPORT_ENVIRONMENT (env
);
1910 SCM entry
= scm_assq (sym
, body
->signature
);
1912 if (scm_is_false (entry
))
1914 return SCM_UNDEFINED
;
1918 if (scm_is_eq (SCM_CADR (entry
), symbol_mutable_location
))
1919 return SCM_ENVIRONMENT_SET (body
->private, sym
, val
);
1921 return SCM_ENVIRONMENT_LOCATION_IMMUTABLE
;
1928 export_environment_cell (SCM env
, SCM sym
, int for_write
)
1929 #define FUNC_NAME "export_environment_cell"
1931 struct export_environment
*body
= EXPORT_ENVIRONMENT (env
);
1932 SCM entry
= scm_assq (sym
, body
->signature
);
1934 if (scm_is_false (entry
))
1936 return SCM_UNDEFINED
;
1940 if (!for_write
|| scm_is_eq (SCM_CADR (entry
), symbol_mutable_location
))
1941 return SCM_ENVIRONMENT_CELL (body
->private, sym
, for_write
);
1943 return SCM_ENVIRONMENT_LOCATION_IMMUTABLE
;
1951 export_environment_print (SCM type
, SCM port
,
1952 scm_print_state
*pstate SCM_UNUSED
)
1954 SCM address
= scm_from_size_t (SCM_UNPACK (type
));
1955 SCM base16
= scm_number_to_string (address
, scm_from_int (16));
1957 scm_puts ("#<export environment ", port
);
1958 scm_display (base16
, port
);
1959 scm_puts (">", port
);
1965 static struct scm_environment_funcs export_environment_funcs
= {
1966 export_environment_ref
,
1967 export_environment_fold
,
1968 export_environment_define
,
1969 export_environment_undefine
,
1970 export_environment_set_x
,
1971 export_environment_cell
,
1972 core_environments_observe
,
1973 core_environments_unobserve
,
1974 export_environment_print
1978 void *scm_type_export_environment
= &export_environment_funcs
;
1982 export_environment_observer (SCM caller SCM_UNUSED
, SCM export_env
)
1984 core_environments_broadcast (export_env
);
1988 SCM_DEFINE (scm_make_export_environment
, "make-export-environment", 2, 0, 0,
1989 (SCM
private, SCM signature
),
1990 "Return a new environment @var{exp} containing only those\n"
1991 "bindings in private whose symbols are present in\n"
1992 "@var{signature}. The @var{private} argument must be an\n"
1994 "The environment @var{exp} binds symbol to location when\n"
1995 "@var{env} does, and symbol is exported by @var{signature}.\n\n"
1996 "@var{signature} is a list specifying which of the bindings in\n"
1997 "@var{private} should be visible in @var{exp}. Each element of\n"
1998 "@var{signature} should be a list of the form:\n"
1999 " (symbol attribute ...)\n"
2000 "where each attribute is one of the following:\n"
2002 "@item the symbol @code{mutable-location}\n"
2003 " @var{exp} should treat the\n"
2004 " location bound to symbol as mutable. That is, @var{exp}\n"
2005 " will pass calls to @code{environment-set!} or\n"
2006 " @code{environment-cell} directly through to private.\n"
2007 "@item the symbol @code{immutable-location}\n"
2008 " @var{exp} should treat\n"
2009 " the location bound to symbol as immutable. If the program\n"
2010 " applies @code{environment-set!} to @var{exp} and symbol, or\n"
2011 " calls @code{environment-cell} to obtain a writable value\n"
2012 " cell, @code{environment-set!} will signal an\n"
2013 " @code{environment:immutable-location} error. Note that, even\n"
2014 " if an export environment treats a location as immutable, the\n"
2015 " underlying environment may treat it as mutable, so its\n"
2016 " value may change.\n"
2018 "It is an error for an element of signature to specify both\n"
2019 "@code{mutable-location} and @code{immutable-location}. If\n"
2020 "neither is specified, @code{immutable-location} is assumed.\n\n"
2021 "As a special case, if an element of signature is a lone\n"
2022 "symbol @var{sym}, it is equivalent to an element of the form\n"
2024 "All bindings in @var{exp} are immutable. If you apply\n"
2025 "@code{environment-define} or @code{environment-undefine} to\n"
2026 "@var{exp}, Guile will signal an\n"
2027 "@code{environment:immutable-binding} error. However,\n"
2028 "notice that the set of bindings in @var{exp} may still change,\n"
2029 "if the bindings in private change.")
2030 #define FUNC_NAME s_scm_make_export_environment
2033 struct export_environment
*body
;
2036 SCM_ASSERT (SCM_ENVIRONMENT_P (private), private, SCM_ARG1
, FUNC_NAME
);
2038 size
= sizeof (struct export_environment
);
2039 body
= scm_gc_malloc (size
, "export environment");
2041 core_environments_preinit (&body
->base
);
2042 body
->private = SCM_BOOL_F
;
2043 body
->private_observer
= SCM_BOOL_F
;
2044 body
->signature
= SCM_BOOL_F
;
2046 env
= scm_make_environment (body
);
2048 core_environments_init (&body
->base
, &export_environment_funcs
);
2049 body
->private = private;
2050 body
->private_observer
2051 = SCM_ENVIRONMENT_OBSERVE (private, export_environment_observer
, env
, 1);
2052 body
->signature
= SCM_EOL
;
2054 scm_export_environment_set_signature_x (env
, signature
);
2061 SCM_DEFINE (scm_export_environment_p
, "export-environment?", 1, 0, 0,
2063 "Return @code{#t} if object is an export environment, or\n"
2064 "@code{#f} otherwise.")
2065 #define FUNC_NAME s_scm_export_environment_p
2067 return scm_from_bool (SCM_EXPORT_ENVIRONMENT_P (object
));
2072 SCM_DEFINE (scm_export_environment_private
, "export-environment-private", 1, 0, 0,
2074 "Return the private environment of export environment @var{env}.")
2075 #define FUNC_NAME s_scm_export_environment_private
2077 SCM_ASSERT (SCM_EXPORT_ENVIRONMENT_P (env
), env
, SCM_ARG1
, FUNC_NAME
);
2079 return EXPORT_ENVIRONMENT (env
)->private;
2084 SCM_DEFINE (scm_export_environment_set_private_x
, "export-environment-set-private!", 2, 0, 0,
2085 (SCM env
, SCM
private),
2086 "Change the private environment of export environment @var{env}.")
2087 #define FUNC_NAME s_scm_export_environment_set_private_x
2089 struct export_environment
*body
;
2091 SCM_ASSERT (SCM_EXPORT_ENVIRONMENT_P (env
), env
, SCM_ARG1
, FUNC_NAME
);
2092 SCM_ASSERT (SCM_ENVIRONMENT_P (private), private, SCM_ARG2
, FUNC_NAME
);
2094 body
= EXPORT_ENVIRONMENT (env
);
2095 SCM_ENVIRONMENT_UNOBSERVE (private, body
->private_observer
);
2097 body
->private = private;
2098 body
->private_observer
2099 = SCM_ENVIRONMENT_OBSERVE (private, export_environment_observer
, env
, 1);
2101 return SCM_UNSPECIFIED
;
2106 SCM_DEFINE (scm_export_environment_signature
, "export-environment-signature", 1, 0, 0,
2108 "Return the signature of export environment @var{env}.")
2109 #define FUNC_NAME s_scm_export_environment_signature
2111 SCM_ASSERT (SCM_EXPORT_ENVIRONMENT_P (env
), env
, SCM_ARG1
, FUNC_NAME
);
2113 return EXPORT_ENVIRONMENT (env
)->signature
;
2119 export_environment_parse_signature (SCM signature
, const char* caller
)
2121 SCM result
= SCM_EOL
;
2124 for (l
= signature
; scm_is_pair (l
); l
= SCM_CDR (l
))
2126 SCM entry
= SCM_CAR (l
);
2128 if (scm_is_symbol (entry
))
2130 SCM new_entry
= scm_cons2 (entry
, symbol_immutable_location
, SCM_EOL
);
2131 result
= scm_cons (new_entry
, result
);
2142 SCM_ASSERT (scm_is_pair (entry
), entry
, SCM_ARGn
, caller
);
2143 SCM_ASSERT (scm_is_symbol (SCM_CAR (entry
)), entry
, SCM_ARGn
, caller
);
2145 sym
= SCM_CAR (entry
);
2147 for (l2
= SCM_CDR (entry
); scm_is_pair (l2
); l2
= SCM_CDR (l2
))
2149 SCM attribute
= SCM_CAR (l2
);
2150 if (scm_is_eq (attribute
, symbol_immutable_location
))
2152 else if (scm_is_eq (attribute
, symbol_mutable_location
))
2155 SCM_ASSERT (0, entry
, SCM_ARGn
, caller
);
2157 SCM_ASSERT (scm_is_null (l2
), entry
, SCM_ARGn
, caller
);
2158 SCM_ASSERT (!mutable || !immutable
, entry
, SCM_ARGn
, caller
);
2160 if (!mutable && !immutable
)
2163 mutability
= mutable ? symbol_mutable_location
: symbol_immutable_location
;
2164 new_entry
= scm_cons2 (sym
, mutability
, SCM_EOL
);
2165 result
= scm_cons (new_entry
, result
);
2168 SCM_ASSERT (scm_is_null (l
), signature
, SCM_ARGn
, caller
);
2170 /* Dirk:FIXME:: Now we know that signature is syntactically correct. There
2171 * are, however, no checks for symbols entered twice with contradicting
2172 * mutabilities. It would be nice, to implement this test, to be able to
2173 * call the sort functions conveniently from C.
2176 return scm_reverse (result
);
2180 SCM_DEFINE (scm_export_environment_set_signature_x
, "export-environment-set-signature!", 2, 0, 0,
2181 (SCM env
, SCM signature
),
2182 "Change the signature of export environment @var{env}.")
2183 #define FUNC_NAME s_scm_export_environment_set_signature_x
2187 SCM_ASSERT (SCM_EXPORT_ENVIRONMENT_P (env
), env
, SCM_ARG1
, FUNC_NAME
);
2188 parsed_sig
= export_environment_parse_signature (signature
, FUNC_NAME
);
2190 EXPORT_ENVIRONMENT (env
)->signature
= parsed_sig
;
2192 return SCM_UNSPECIFIED
;
2199 scm_environments_prehistory ()
2201 /* create environment smob */
2202 scm_tc16_environment
= scm_make_smob_type ("environment", 0);
2203 scm_set_smob_print (scm_tc16_environment
, environment_print
);
2205 /* create observer smob */
2206 scm_tc16_observer
= scm_make_smob_type ("observer", 0);
2207 scm_set_smob_print (scm_tc16_observer
, observer_print
);
2209 /* create system environment */
2210 scm_system_environment
= scm_make_leaf_environment ();
2211 scm_permanent_object (scm_system_environment
);
2216 scm_init_environments ()
2218 #include "libguile/environments.x"