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
5 * License as published by the Free Software Foundation; either
6 * version 2.1 of the License, or (at your option) any later version.
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.
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
23 #include "libguile/_scm.h"
24 #include "libguile/alist.h"
25 #include "libguile/eval.h"
26 #include "libguile/hash.h"
27 #include "libguile/list.h"
28 #include "libguile/ports.h"
29 #include "libguile/smob.h"
30 #include "libguile/symbols.h"
31 #include "libguile/vectors.h"
32 #include "libguile/weaks.h"
34 #include "libguile/environments.h"
38 scm_t_bits scm_tc16_environment
;
39 scm_t_bits scm_tc16_observer
;
40 #define DEFAULT_OBARRAY_SIZE 31
42 SCM scm_system_environment
;
46 /* error conditions */
49 * Throw an error if symbol is not bound in environment func
52 scm_error_environment_unbound (const char *func
, SCM env
, SCM symbol
)
54 /* Dirk:FIXME:: Should throw an environment:unbound type error */
55 char error
[] = "Symbol `~A' not bound in environment `~A'.";
56 SCM arguments
= scm_cons2 (symbol
, env
, SCM_EOL
);
57 scm_misc_error (func
, error
, arguments
);
62 * Throw an error if func tried to create (define) or remove
63 * (undefine) a new binding for symbol in env
66 scm_error_environment_immutable_binding (const char *func
, SCM env
, SCM symbol
)
68 /* Dirk:FIXME:: Should throw an environment:immutable-binding type error */
69 char error
[] = "Immutable binding in environment ~A (symbol: `~A').";
70 SCM arguments
= scm_cons2 (env
, symbol
, SCM_EOL
);
71 scm_misc_error (func
, error
, arguments
);
76 * Throw an error if func tried to change an immutable location.
79 scm_error_environment_immutable_location (const char *func
, SCM env
, SCM symbol
)
81 /* Dirk:FIXME:: Should throw an environment:immutable-location type error */
82 char error
[] = "Immutable location in environment `~A' (symbol: `~A').";
83 SCM arguments
= scm_cons2 (env
, symbol
, SCM_EOL
);
84 scm_misc_error (func
, error
, arguments
);
89 /* generic environments */
92 /* Create an environment for the given type. Dereferencing type twice must
93 * deliver the initialized set of environment functions. Thus, type will
94 * also determine the signature of the underlying environment implementation.
95 * Dereferencing type once will typically deliver the data fields used by the
96 * underlying environment implementation.
99 scm_make_environment (void *type
)
101 SCM_RETURN_NEWSMOB (scm_tc16_environment
, type
);
105 SCM_DEFINE (scm_environment_p
, "environment?", 1, 0, 0,
107 "Return @code{#t} if @var{obj} is an environment, or @code{#f}\n"
109 #define FUNC_NAME s_scm_environment_p
111 return scm_from_bool (SCM_ENVIRONMENT_P (obj
));
116 SCM_DEFINE (scm_environment_bound_p
, "environment-bound?", 2, 0, 0,
118 "Return @code{#t} if @var{sym} is bound in @var{env}, or\n"
119 "@code{#f} otherwise.")
120 #define FUNC_NAME s_scm_environment_bound_p
122 SCM_ASSERT (SCM_ENVIRONMENT_P (env
), env
, SCM_ARG1
, FUNC_NAME
);
123 SCM_ASSERT (scm_is_symbol (sym
), sym
, SCM_ARG2
, FUNC_NAME
);
125 return scm_from_bool (SCM_ENVIRONMENT_BOUND_P (env
, sym
));
130 SCM_DEFINE (scm_environment_ref
, "environment-ref", 2, 0, 0,
132 "Return the value of the location bound to @var{sym} in\n"
133 "@var{env}. If @var{sym} is unbound in @var{env}, signal an\n"
134 "@code{environment:unbound} error.")
135 #define FUNC_NAME s_scm_environment_ref
139 SCM_ASSERT (SCM_ENVIRONMENT_P (env
), env
, SCM_ARG1
, FUNC_NAME
);
140 SCM_ASSERT (scm_is_symbol (sym
), sym
, SCM_ARG2
, FUNC_NAME
);
142 val
= SCM_ENVIRONMENT_REF (env
, sym
);
144 if (!SCM_UNBNDP (val
))
147 scm_error_environment_unbound (FUNC_NAME
, env
, sym
);
152 /* This C function is identical to environment-ref, except that if symbol is
153 * unbound in env, it returns the value SCM_UNDEFINED, instead of signalling
157 scm_c_environment_ref (SCM env
, SCM sym
)
159 SCM_ASSERT (SCM_ENVIRONMENT_P (env
), env
, SCM_ARG1
, "scm_c_environment_ref");
160 SCM_ASSERT (scm_is_symbol (sym
), sym
, SCM_ARG2
, "scm_c_environment_ref");
161 return SCM_ENVIRONMENT_REF (env
, sym
);
166 environment_default_folder (SCM proc
, SCM symbol
, SCM value
, SCM tail
)
168 return scm_call_3 (proc
, symbol
, value
, tail
);
172 SCM_DEFINE (scm_environment_fold
, "environment-fold", 3, 0, 0,
173 (SCM env
, SCM proc
, SCM init
),
174 "Iterate over all the bindings in @var{env}, accumulating some\n"
176 "For each binding in @var{env}, apply @var{proc} to the symbol\n"
177 "bound, its value, and the result from the previous application\n"
179 "Use @var{init} as @var{proc}'s third argument the first time\n"
180 "@var{proc} is applied.\n"
181 "If @var{env} contains no bindings, this function simply returns\n"
183 "If @var{env} binds the symbol sym1 to the value val1, sym2 to\n"
184 "val2, and so on, then this procedure computes:\n"
192 "Each binding in @var{env} will be processed exactly once.\n"
193 "@code{environment-fold} makes no guarantees about the order in\n"
194 "which the bindings are processed.\n"
195 "Here is a function which, given an environment, constructs an\n"
196 "association list representing that environment's bindings,\n"
197 "using environment-fold:\n"
199 " (define (environment->alist env)\n"
200 " (environment-fold env\n"
201 " (lambda (sym val tail)\n"
202 " (cons (cons sym val) tail))\n"
205 #define FUNC_NAME s_scm_environment_fold
207 SCM_ASSERT (SCM_ENVIRONMENT_P (env
), env
, SCM_ARG1
, FUNC_NAME
);
208 SCM_ASSERT (scm_is_true (scm_procedure_p (proc
)),
209 proc
, SCM_ARG2
, FUNC_NAME
);
211 return SCM_ENVIRONMENT_FOLD (env
, environment_default_folder
, proc
, init
);
216 /* This is the C-level analog of environment-fold. For each binding in ENV,
218 * (*proc) (data, symbol, value, previous)
219 * where previous is the value returned from the last call to *PROC, or INIT
220 * for the first call. If ENV contains no bindings, return INIT.
223 scm_c_environment_fold (SCM env
, scm_environment_folder proc
, SCM data
, SCM init
)
225 SCM_ASSERT (SCM_ENVIRONMENT_P (env
), env
, SCM_ARG1
, "scm_c_environment_fold");
227 return SCM_ENVIRONMENT_FOLD (env
, proc
, data
, init
);
231 SCM_DEFINE (scm_environment_define
, "environment-define", 3, 0, 0,
232 (SCM env
, SCM sym
, SCM val
),
233 "Bind @var{sym} to a new location containing @var{val} in\n"
234 "@var{env}. If @var{sym} is already bound to another location\n"
235 "in @var{env} and the binding is mutable, that binding is\n"
236 "replaced. The new binding and location are both mutable. The\n"
237 "return value is unspecified.\n"
238 "If @var{sym} is already bound in @var{env}, and the binding is\n"
239 "immutable, signal an @code{environment:immutable-binding} error.")
240 #define FUNC_NAME s_scm_environment_define
244 SCM_ASSERT (SCM_ENVIRONMENT_P (env
), env
, SCM_ARG1
, FUNC_NAME
);
245 SCM_ASSERT (scm_is_symbol (sym
), sym
, SCM_ARG2
, FUNC_NAME
);
247 status
= SCM_ENVIRONMENT_DEFINE (env
, sym
, val
);
249 if (scm_is_eq (status
, SCM_ENVIRONMENT_SUCCESS
))
250 return SCM_UNSPECIFIED
;
251 else if (scm_is_eq (status
, SCM_ENVIRONMENT_BINDING_IMMUTABLE
))
252 scm_error_environment_immutable_binding (FUNC_NAME
, env
, sym
);
259 SCM_DEFINE (scm_environment_undefine
, "environment-undefine", 2, 0, 0,
261 "Remove any binding for @var{sym} from @var{env}. If @var{sym}\n"
262 "is unbound in @var{env}, do nothing. The return value is\n"
264 "If @var{sym} is already bound in @var{env}, and the binding is\n"
265 "immutable, signal an @code{environment:immutable-binding} error.")
266 #define FUNC_NAME s_scm_environment_undefine
270 SCM_ASSERT(SCM_ENVIRONMENT_P(env
), env
, SCM_ARG1
, FUNC_NAME
);
271 SCM_ASSERT(scm_is_symbol(sym
), sym
, SCM_ARG2
, FUNC_NAME
);
273 status
= SCM_ENVIRONMENT_UNDEFINE (env
, sym
);
275 if (scm_is_eq (status
, SCM_ENVIRONMENT_SUCCESS
))
276 return SCM_UNSPECIFIED
;
277 else if (scm_is_eq (status
, SCM_ENVIRONMENT_BINDING_IMMUTABLE
))
278 scm_error_environment_immutable_binding (FUNC_NAME
, env
, sym
);
285 SCM_DEFINE (scm_environment_set_x
, "environment-set!", 3, 0, 0,
286 (SCM env
, SCM sym
, SCM val
),
287 "If @var{env} binds @var{sym} to some location, change that\n"
288 "location's value to @var{val}. The return value is\n"
290 "If @var{sym} is not bound in @var{env}, signal an\n"
291 "@code{environment:unbound} error. If @var{env} binds @var{sym}\n"
292 "to an immutable location, signal an\n"
293 "@code{environment:immutable-location} error.")
294 #define FUNC_NAME s_scm_environment_set_x
298 SCM_ASSERT (SCM_ENVIRONMENT_P (env
), env
, SCM_ARG1
, FUNC_NAME
);
299 SCM_ASSERT (scm_is_symbol (sym
), sym
, SCM_ARG2
, FUNC_NAME
);
301 status
= SCM_ENVIRONMENT_SET (env
, sym
, val
);
303 if (scm_is_eq (status
, SCM_ENVIRONMENT_SUCCESS
))
304 return SCM_UNSPECIFIED
;
305 else if (SCM_UNBNDP (status
))
306 scm_error_environment_unbound (FUNC_NAME
, env
, sym
);
307 else if (scm_is_eq (status
, SCM_ENVIRONMENT_LOCATION_IMMUTABLE
))
308 scm_error_environment_immutable_binding (FUNC_NAME
, env
, sym
);
315 SCM_DEFINE (scm_environment_cell
, "environment-cell", 3, 0, 0,
316 (SCM env
, SCM sym
, SCM for_write
),
317 "Return the value cell which @var{env} binds to @var{sym}, or\n"
318 "@code{#f} if the binding does not live in a value cell.\n"
319 "The argument @var{for-write} indicates whether the caller\n"
320 "intends to modify the variable's value by mutating the value\n"
321 "cell. If the variable is immutable, then\n"
322 "@code{environment-cell} signals an\n"
323 "@code{environment:immutable-location} error.\n"
324 "If @var{sym} is unbound in @var{env}, signal an\n"
325 "@code{environment:unbound} error.\n"
326 "If you use this function, you should consider using\n"
327 "@code{environment-observe}, to be notified when @var{sym} gets\n"
328 "re-bound to a new value cell, or becomes undefined.")
329 #define FUNC_NAME s_scm_environment_cell
333 SCM_ASSERT (SCM_ENVIRONMENT_P (env
), env
, SCM_ARG1
, FUNC_NAME
);
334 SCM_ASSERT (scm_is_symbol (sym
), sym
, SCM_ARG2
, FUNC_NAME
);
335 SCM_ASSERT (scm_is_bool (for_write
), for_write
, SCM_ARG3
, FUNC_NAME
);
337 location
= SCM_ENVIRONMENT_CELL (env
, sym
, scm_is_true (for_write
));
338 if (!SCM_IMP (location
))
340 else if (SCM_UNBNDP (location
))
341 scm_error_environment_unbound (FUNC_NAME
, env
, sym
);
342 else if (scm_is_eq (location
, SCM_ENVIRONMENT_LOCATION_IMMUTABLE
))
343 scm_error_environment_immutable_location (FUNC_NAME
, env
, sym
);
350 /* This C function is identical to environment-cell, with the following
351 * exceptions: If symbol is unbound in env, it returns the value
352 * SCM_UNDEFINED, instead of signalling an error. If symbol is bound to an
353 * immutable location but the cell is requested for write, the value
354 * SCM_ENVIRONMENT_LOCATION_IMMUTABLE is returned.
357 scm_c_environment_cell(SCM env
, SCM sym
, int for_write
)
359 SCM_ASSERT (SCM_ENVIRONMENT_P (env
), env
, SCM_ARG1
, "scm_c_environment_cell");
360 SCM_ASSERT (scm_is_symbol (sym
), sym
, SCM_ARG2
, "scm_c_environment_cell");
362 return SCM_ENVIRONMENT_CELL (env
, sym
, for_write
);
367 environment_default_observer (SCM env
, SCM proc
)
369 scm_call_1 (proc
, env
);
373 SCM_DEFINE (scm_environment_observe
, "environment-observe", 2, 0, 0,
375 "Whenever @var{env}'s bindings change, apply @var{proc} to\n"
377 "This function returns an object, token, which you can pass to\n"
378 "@code{environment-unobserve} to remove @var{proc} from the set\n"
379 "of procedures observing @var{env}. The type and value of\n"
380 "token is unspecified.")
381 #define FUNC_NAME s_scm_environment_observe
383 SCM_ASSERT (SCM_ENVIRONMENT_P (env
), env
, SCM_ARG1
, FUNC_NAME
);
385 return SCM_ENVIRONMENT_OBSERVE (env
, environment_default_observer
, proc
, 0);
390 SCM_DEFINE (scm_environment_observe_weak
, "environment-observe-weak", 2, 0, 0,
392 "This function is the same as environment-observe, except that\n"
393 "the reference @var{env} retains to @var{proc} is a weak\n"
394 "reference. This means that, if there are no other live,\n"
395 "non-weak references to @var{proc}, it will be\n"
396 "garbage-collected, and dropped from @var{env}'s\n"
397 "list of observing procedures.")
398 #define FUNC_NAME s_scm_environment_observe_weak
400 SCM_ASSERT (SCM_ENVIRONMENT_P (env
), env
, SCM_ARG1
, FUNC_NAME
);
402 return SCM_ENVIRONMENT_OBSERVE (env
, environment_default_observer
, proc
, 1);
407 /* This is the C-level analog of the Scheme functions environment-observe and
408 * environment-observe-weak. Whenever env's bindings change, call the
409 * function proc, passing it env and data. If weak_p is non-zero, env will
410 * retain only a weak reference to data, and if data is garbage collected, the
411 * entire observation will be dropped. This function returns a token, with
412 * the same meaning as those returned by environment-observe and
413 * environment-observe-weak.
416 scm_c_environment_observe (SCM env
, scm_environment_observer proc
, SCM data
, int weak_p
)
417 #define FUNC_NAME "scm_c_environment_observe"
419 SCM_ASSERT (SCM_ENVIRONMENT_P (env
), env
, SCM_ARG1
, FUNC_NAME
);
421 return SCM_ENVIRONMENT_OBSERVE (env
, proc
, data
, weak_p
);
426 SCM_DEFINE (scm_environment_unobserve
, "environment-unobserve", 1, 0, 0,
428 "Cancel the observation request which returned the value\n"
429 "@var{token}. The return value is unspecified.\n"
430 "If a call @code{(environment-observe env proc)} returns\n"
431 "@var{token}, then the call @code{(environment-unobserve token)}\n"
432 "will cause @var{proc} to no longer be called when @var{env}'s\n"
434 #define FUNC_NAME s_scm_environment_unobserve
438 SCM_ASSERT (SCM_OBSERVER_P (token
), token
, SCM_ARG1
, FUNC_NAME
);
440 env
= SCM_OBSERVER_ENVIRONMENT (token
);
441 SCM_ENVIRONMENT_UNOBSERVE (env
, token
);
443 return SCM_UNSPECIFIED
;
450 environment_print (SCM env
, SCM port
, scm_print_state
*pstate
)
452 return (*(SCM_ENVIRONMENT_FUNCS (env
)->print
)) (env
, port
, pstate
);
461 observer_print (SCM type
, SCM port
, scm_print_state
*pstate SCM_UNUSED
)
463 SCM address
= scm_from_size_t (SCM_UNPACK (type
));
464 SCM base16
= scm_number_to_string (address
, scm_from_int (16));
466 scm_puts ("#<observer ", port
);
467 scm_display (base16
, port
);
468 scm_puts (">", port
);
477 * Obarrays form the basic lookup tables used to implement most of guile's
478 * built-in environment types. An obarray is implemented as a hash table with
479 * symbols as keys. The content of the data depends on the environment type.
484 * Enter symbol into obarray. The symbol must not already exist in obarray.
485 * The freshly generated (symbol . data) cell is returned.
488 obarray_enter (SCM obarray
, SCM symbol
, SCM data
)
490 size_t hash
= scm_i_symbol_hash (symbol
) % SCM_HASHTABLE_N_BUCKETS (obarray
);
491 SCM entry
= scm_cons (symbol
, data
);
492 SCM slot
= scm_cons (entry
, SCM_HASHTABLE_BUCKET (obarray
, hash
));
493 SCM_SET_HASHTABLE_BUCKET (obarray
, hash
, slot
);
494 SCM_HASHTABLE_INCREMENT (obarray
);
495 if (SCM_HASHTABLE_N_ITEMS (obarray
) > SCM_HASHTABLE_UPPER (obarray
))
496 scm_i_rehash (obarray
, scm_i_hash_symbol
, 0, "obarray_enter");
503 * Enter symbol into obarray. An existing entry for symbol is replaced. If
504 * an entry existed, the old (symbol . data) cell is returned, #f otherwise.
507 obarray_replace (SCM obarray
, SCM symbol
, SCM data
)
509 size_t hash
= scm_i_symbol_hash (symbol
) % SCM_HASHTABLE_N_BUCKETS (obarray
);
510 SCM new_entry
= scm_cons (symbol
, data
);
514 for (lsym
= SCM_HASHTABLE_BUCKET (obarray
, hash
);
516 lsym
= SCM_CDR (lsym
))
518 SCM old_entry
= SCM_CAR (lsym
);
519 if (scm_is_eq (SCM_CAR (old_entry
), symbol
))
521 SCM_SETCAR (lsym
, new_entry
);
526 slot
= scm_cons (new_entry
, SCM_HASHTABLE_BUCKET (obarray
, hash
));
527 SCM_SET_HASHTABLE_BUCKET (obarray
, hash
, slot
);
528 SCM_HASHTABLE_INCREMENT (obarray
);
529 if (SCM_HASHTABLE_N_ITEMS (obarray
) > SCM_HASHTABLE_UPPER (obarray
))
530 scm_i_rehash (obarray
, scm_i_hash_symbol
, 0, "obarray_replace");
537 * Look up symbol in obarray
540 obarray_retrieve (SCM obarray
, SCM sym
)
542 size_t hash
= scm_i_symbol_hash (sym
) % SCM_HASHTABLE_N_BUCKETS (obarray
);
545 for (lsym
= SCM_HASHTABLE_BUCKET (obarray
, hash
);
547 lsym
= SCM_CDR (lsym
))
549 SCM entry
= SCM_CAR (lsym
);
550 if (scm_is_eq (SCM_CAR (entry
), sym
))
554 return SCM_UNDEFINED
;
559 * Remove entry from obarray. If the symbol was found and removed, the old
560 * (symbol . data) cell is returned, #f otherwise.
563 obarray_remove (SCM obarray
, SCM sym
)
565 size_t hash
= scm_i_symbol_hash (sym
) % SCM_HASHTABLE_N_BUCKETS (obarray
);
566 SCM table_entry
= SCM_HASHTABLE_BUCKET (obarray
, hash
);
567 SCM handle
= scm_sloppy_assq (sym
, table_entry
);
569 if (scm_is_pair (handle
))
571 SCM new_table_entry
= scm_delq1_x (handle
, table_entry
);
572 SCM_SET_HASHTABLE_BUCKET (obarray
, hash
, new_table_entry
);
573 SCM_HASHTABLE_DECREMENT (obarray
);
581 obarray_remove_all (SCM obarray
)
583 size_t size
= SCM_HASHTABLE_N_BUCKETS (obarray
);
586 for (i
= 0; i
< size
; i
++)
588 SCM_SET_HASHTABLE_BUCKET (obarray
, i
, SCM_EOL
);
590 SCM_SET_HASHTABLE_N_ITEMS (obarray
, 0);
595 /* core environments base
597 * This struct and the corresponding functions form a base class for guile's
598 * built-in environment types.
602 struct core_environments_base
{
603 struct scm_environment_funcs
*funcs
;
610 #define CORE_ENVIRONMENTS_BASE(env) \
611 ((struct core_environments_base *) SCM_CELL_WORD_1 (env))
612 #define CORE_ENVIRONMENT_OBSERVERS(env) \
613 (CORE_ENVIRONMENTS_BASE (env)->observers)
614 #define SCM_SET_CORE_ENVIRONMENT_OBSERVERS(env, v) \
615 (CORE_ENVIRONMENT_OBSERVERS (env) = (v))
616 #define CORE_ENVIRONMENT_WEAK_OBSERVER_VECTOR(env) \
617 (CORE_ENVIRONMENTS_BASE (env)->weak_observers)
618 #define CORE_ENVIRONMENT_WEAK_OBSERVERS(env) \
619 (scm_c_vector_ref (CORE_ENVIRONMENT_WEAK_OBSERVER_VECTOR (env), 0))
620 #define SCM_SET_CORE_ENVIRONMENT_WEAK_OBSERVERS(env, v) \
621 (scm_c_vector_set_x (CORE_ENVIRONMENT_WEAK_OBSERVER_VECTOR (env), 0, (v)))
626 core_environments_observe (SCM env
, scm_environment_observer proc
, SCM data
, int weak_p
)
630 SCM_NEWSMOB3 (observer
, scm_tc16_observer
,
637 SCM observers
= CORE_ENVIRONMENT_OBSERVERS (env
);
638 SCM new_observers
= scm_cons (observer
, observers
);
639 SCM_SET_CORE_ENVIRONMENT_OBSERVERS (env
, new_observers
);
643 SCM observers
= CORE_ENVIRONMENT_WEAK_OBSERVERS (env
);
644 SCM new_observers
= scm_acons (SCM_BOOL_F
, observer
, observers
);
645 SCM_SET_CORE_ENVIRONMENT_WEAK_OBSERVERS (env
, new_observers
);
653 core_environments_unobserve (SCM env
, SCM observer
)
655 unsigned int handling_weaks
;
656 for (handling_weaks
= 0; handling_weaks
<= 1; ++handling_weaks
)
658 SCM l
= handling_weaks
659 ? CORE_ENVIRONMENT_WEAK_OBSERVERS (env
)
660 : CORE_ENVIRONMENT_OBSERVERS (env
);
662 if (!scm_is_null (l
))
664 SCM rest
= SCM_CDR (l
);
665 SCM first
= handling_weaks
669 if (scm_is_eq (first
, observer
))
671 /* Remove the first observer */
673 SCM_SET_CORE_ENVIRONMENT_WEAK_OBSERVERS (env
, rest
);
675 SCM_SET_CORE_ENVIRONMENT_OBSERVERS (env
, rest
);
680 SCM rest
= SCM_CDR (l
);
682 if (!scm_is_null (rest
))
684 SCM next
= handling_weaks
688 if (scm_is_eq (next
, observer
))
690 SCM_SETCDR (l
, SCM_CDR (rest
));
696 } while (!scm_is_null (l
));
700 /* Dirk:FIXME:: What to do now, since the observer is not found? */
705 core_environments_preinit (struct core_environments_base
*body
)
708 body
->observers
= SCM_BOOL_F
;
709 body
->weak_observers
= SCM_BOOL_F
;
714 core_environments_init (struct core_environments_base
*body
,
715 struct scm_environment_funcs
*funcs
)
718 body
->observers
= SCM_EOL
;
719 body
->weak_observers
= scm_make_weak_value_alist_vector (scm_from_int (1));
723 /* Tell all observers to clear their caches.
725 * Environments have to be informed about changes in the following cases:
726 * - The observed env has a new binding. This must be always reported.
727 * - The observed env has dropped a binding. This must be always reported.
728 * - A binding in the observed environment has changed. This must only be
729 * reported, if there is a chance that the binding is being cached outside.
730 * However, this potential optimization is not performed currently.
732 * Errors that occur while the observers are called are accumulated and
733 * signalled as one single error message to the caller.
744 update_catch_body (void *ptr
)
746 struct update_data
*data
= (struct update_data
*) ptr
;
747 SCM observer
= data
->observer
;
749 (*SCM_OBSERVER_PROC (observer
))
750 (data
->environment
, SCM_OBSERVER_DATA (observer
));
752 return SCM_UNDEFINED
;
757 update_catch_handler (void *ptr
, SCM tag
, SCM args
)
759 struct update_data
*data
= (struct update_data
*) ptr
;
760 SCM observer
= data
->observer
;
762 scm_from_locale_string ("Observer `~A' signals `~A' error: ~S");
764 return scm_cons (message
, scm_list_3 (observer
, tag
, args
));
769 core_environments_broadcast (SCM env
)
770 #define FUNC_NAME "core_environments_broadcast"
772 unsigned int handling_weaks
;
773 SCM errors
= SCM_EOL
;
775 for (handling_weaks
= 0; handling_weaks
<= 1; ++handling_weaks
)
777 SCM observers
= handling_weaks
778 ? CORE_ENVIRONMENT_WEAK_OBSERVERS (env
)
779 : CORE_ENVIRONMENT_OBSERVERS (env
);
781 for (; !scm_is_null (observers
); observers
= SCM_CDR (observers
))
783 struct update_data data
;
784 SCM observer
= handling_weaks
785 ? SCM_CDAR (observers
)
786 : SCM_CAR (observers
);
789 data
.observer
= observer
;
790 data
.environment
= env
;
792 error
= scm_internal_catch (SCM_BOOL_T
,
793 update_catch_body
, &data
,
794 update_catch_handler
, &data
);
796 if (!SCM_UNBNDP (error
))
797 errors
= scm_cons (error
, errors
);
801 if (!scm_is_null (errors
))
803 /* Dirk:FIXME:: As soon as scm_misc_error is fixed to handle the name
804 * parameter correctly it should not be necessary any more to also pass
805 * namestr in order to get the desired information from the error
808 SCM ordered_errors
= scm_reverse (errors
);
811 "Observers of `~A' have signalled the following errors: ~S",
812 scm_cons2 (env
, ordered_errors
, SCM_EOL
));
821 * A leaf environment is simply a mutable set of definitions. A leaf
822 * environment supports no operations beyond the common set.
824 * Implementation: The obarray of the leaf environment holds (symbol . value)
825 * pairs. No further information is necessary, since all bindings and
826 * locations in a leaf environment are mutable.
830 struct leaf_environment
{
831 struct core_environments_base base
;
837 #define LEAF_ENVIRONMENT(env) \
838 ((struct leaf_environment *) SCM_CELL_WORD_1 (env))
843 leaf_environment_ref (SCM env
, SCM sym
)
845 SCM obarray
= LEAF_ENVIRONMENT (env
)->obarray
;
846 SCM binding
= obarray_retrieve (obarray
, sym
);
847 return SCM_UNBNDP (binding
) ? binding
: SCM_CDR (binding
);
852 leaf_environment_fold (SCM env
, scm_environment_folder proc
, SCM data
, SCM init
)
856 SCM obarray
= LEAF_ENVIRONMENT (env
)->obarray
;
858 for (i
= 0; i
< SCM_HASHTABLE_N_BUCKETS (obarray
); i
++)
861 for (l
= SCM_HASHTABLE_BUCKET (obarray
, i
);
865 SCM binding
= SCM_CAR (l
);
866 SCM symbol
= SCM_CAR (binding
);
867 SCM value
= SCM_CDR (binding
);
868 result
= (*proc
) (data
, symbol
, value
, result
);
876 leaf_environment_define (SCM env
, SCM sym
, SCM val
)
877 #define FUNC_NAME "leaf_environment_define"
879 SCM obarray
= LEAF_ENVIRONMENT (env
)->obarray
;
881 obarray_replace (obarray
, sym
, val
);
882 core_environments_broadcast (env
);
884 return SCM_ENVIRONMENT_SUCCESS
;
890 leaf_environment_undefine (SCM env
, SCM sym
)
891 #define FUNC_NAME "leaf_environment_undefine"
893 SCM obarray
= LEAF_ENVIRONMENT (env
)->obarray
;
894 SCM removed
= obarray_remove (obarray
, sym
);
896 if (scm_is_true (removed
))
897 core_environments_broadcast (env
);
899 return SCM_ENVIRONMENT_SUCCESS
;
905 leaf_environment_set_x (SCM env
, SCM sym
, SCM val
)
906 #define FUNC_NAME "leaf_environment_set_x"
908 SCM obarray
= LEAF_ENVIRONMENT (env
)->obarray
;
909 SCM binding
= obarray_retrieve (obarray
, sym
);
911 if (!SCM_UNBNDP (binding
))
913 SCM_SETCDR (binding
, val
);
914 return SCM_ENVIRONMENT_SUCCESS
;
918 return SCM_UNDEFINED
;
925 leaf_environment_cell (SCM env
, SCM sym
, int for_write SCM_UNUSED
)
927 SCM obarray
= LEAF_ENVIRONMENT (env
)->obarray
;
928 SCM binding
= obarray_retrieve (obarray
, sym
);
935 leaf_environment_print (SCM type
, SCM port
, scm_print_state
*pstate SCM_UNUSED
)
937 SCM address
= scm_from_size_t (SCM_UNPACK (type
));
938 SCM base16
= scm_number_to_string (address
, scm_from_int (16));
940 scm_puts ("#<leaf environment ", port
);
941 scm_display (base16
, port
);
942 scm_puts (">", port
);
948 static struct scm_environment_funcs leaf_environment_funcs
= {
949 leaf_environment_ref
,
950 leaf_environment_fold
,
951 leaf_environment_define
,
952 leaf_environment_undefine
,
953 leaf_environment_set_x
,
954 leaf_environment_cell
,
955 core_environments_observe
,
956 core_environments_unobserve
,
957 leaf_environment_print
961 void *scm_type_leaf_environment
= &leaf_environment_funcs
;
964 SCM_DEFINE (scm_make_leaf_environment
, "make-leaf-environment", 0, 0, 0,
966 "Create a new leaf environment, containing no bindings.\n"
967 "All bindings and locations created in the new environment\n"
969 #define FUNC_NAME s_scm_make_leaf_environment
971 size_t size
= sizeof (struct leaf_environment
);
972 struct leaf_environment
*body
= scm_gc_malloc (size
, "leaf environment");
975 core_environments_preinit (&body
->base
);
976 body
->obarray
= SCM_BOOL_F
;
978 env
= scm_make_environment (body
);
980 core_environments_init (&body
->base
, &leaf_environment_funcs
);
981 body
->obarray
= scm_c_make_hash_table (DEFAULT_OBARRAY_SIZE
);
988 SCM_DEFINE (scm_leaf_environment_p
, "leaf-environment?", 1, 0, 0,
990 "Return @code{#t} if object is a leaf environment, or @code{#f}\n"
992 #define FUNC_NAME s_scm_leaf_environment_p
994 return scm_from_bool (SCM_LEAF_ENVIRONMENT_P (object
));
1000 /* eval environments
1002 * A module's source code refers to definitions imported from other modules,
1003 * and definitions made within itself. An eval environment combines two
1004 * environments -- a local environment and an imported environment -- to
1005 * produce a new environment in which both sorts of references can be
1008 * Implementation: The obarray of the eval environment is used to cache
1009 * entries from the local and imported environments such that in most of the
1010 * cases only a single lookup is necessary. Since for neither the local nor
1011 * the imported environment it is known, what kind of environment they form,
1012 * the most general case is assumed. Therefore, entries in the obarray take
1013 * one of the following forms:
1015 * 1) (<symbol> location mutability . source-env), where mutability indicates
1016 * one of the following states: IMMUTABLE if the location is known to be
1017 * immutable, MUTABLE if the location is known to be mutable, UNKNOWN if
1018 * the location has only been requested for non modifying accesses.
1020 * 2) (symbol . source-env) if the symbol has a binding in the source-env, but
1021 * if the source-env can't provide a cell for the binding. Thus, for every
1022 * access, the source-env has to be contacted directly.
1026 struct eval_environment
{
1027 struct core_environments_base base
;
1032 SCM imported_observer
;
1038 #define EVAL_ENVIRONMENT(env) \
1039 ((struct eval_environment *) SCM_CELL_WORD_1 (env))
1041 #define IMMUTABLE SCM_I_MAKINUM (0)
1042 #define MUTABLE SCM_I_MAKINUM (1)
1043 #define UNKNOWN SCM_I_MAKINUM (2)
1045 #define CACHED_LOCATION(x) SCM_CAR (x)
1046 #define CACHED_MUTABILITY(x) SCM_CADR (x)
1047 #define SET_CACHED_MUTABILITY(x, v) SCM_SETCAR (SCM_CDR (x), (v))
1048 #define CACHED_SOURCE_ENVIRONMENT(x) SCM_CDDR (x)
1052 /* eval_environment_lookup will report one of the following distinct results:
1053 * a) (<object> . value) if a cell could be obtained.
1054 * b) <environment> if the environment has to be contacted directly.
1055 * c) IMMUTABLE if an immutable cell was requested for write.
1056 * d) SCM_UNDEFINED if there is no binding for the symbol.
1059 eval_environment_lookup (SCM env
, SCM sym
, int for_write
)
1061 SCM obarray
= EVAL_ENVIRONMENT (env
)->obarray
;
1062 SCM binding
= obarray_retrieve (obarray
, sym
);
1064 if (!SCM_UNBNDP (binding
))
1066 /* The obarray holds an entry for the symbol. */
1068 SCM entry
= SCM_CDR (binding
);
1070 if (scm_is_pair (entry
))
1072 /* The entry in the obarray is a cached location. */
1074 SCM location
= CACHED_LOCATION (entry
);
1080 mutability
= CACHED_MUTABILITY (entry
);
1081 if (scm_is_eq (mutability
, MUTABLE
))
1084 if (scm_is_eq (mutability
, UNKNOWN
))
1086 SCM source_env
= CACHED_SOURCE_ENVIRONMENT (entry
);
1087 SCM location
= SCM_ENVIRONMENT_CELL (source_env
, sym
, 1);
1089 if (scm_is_pair (location
))
1091 SET_CACHED_MUTABILITY (entry
, MUTABLE
);
1094 else /* IMMUTABLE */
1096 SET_CACHED_MUTABILITY (entry
, IMMUTABLE
);
1105 /* The obarray entry is an environment */
1112 /* There is no entry for the symbol in the obarray. This can either
1113 * mean that there has not been a request for the symbol yet, or that
1114 * the symbol is really undefined. We are looking for the symbol in
1115 * both the local and the imported environment. If we find a binding, a
1116 * cached entry is created.
1119 struct eval_environment
*body
= EVAL_ENVIRONMENT (env
);
1120 unsigned int handling_import
;
1122 for (handling_import
= 0; handling_import
<= 1; ++handling_import
)
1124 SCM source_env
= handling_import
? body
->imported
: body
->local
;
1125 SCM location
= SCM_ENVIRONMENT_CELL (source_env
, sym
, for_write
);
1127 if (!SCM_UNBNDP (location
))
1129 if (scm_is_pair (location
))
1131 SCM mutability
= for_write
? MUTABLE
: UNKNOWN
;
1132 SCM entry
= scm_cons2 (location
, mutability
, source_env
);
1133 obarray_enter (obarray
, sym
, entry
);
1136 else if (scm_is_eq (location
, SCM_ENVIRONMENT_LOCATION_NO_CELL
))
1138 obarray_enter (obarray
, sym
, source_env
);
1148 return SCM_UNDEFINED
;
1154 eval_environment_ref (SCM env
, SCM sym
)
1155 #define FUNC_NAME "eval_environment_ref"
1157 SCM location
= eval_environment_lookup (env
, sym
, 0);
1159 if (scm_is_pair (location
))
1160 return SCM_CDR (location
);
1161 else if (!SCM_UNBNDP (location
))
1162 return SCM_ENVIRONMENT_REF (location
, sym
);
1164 return SCM_UNDEFINED
;
1170 eval_environment_folder (SCM extended_data
, SCM symbol
, SCM value
, SCM tail
)
1172 SCM local
= SCM_CAR (extended_data
);
1174 if (!SCM_ENVIRONMENT_BOUND_P (local
, symbol
))
1176 SCM proc_as_nr
= SCM_CADR (extended_data
);
1177 unsigned long int proc_as_ul
= scm_to_ulong (proc_as_nr
);
1178 scm_environment_folder proc
= (scm_environment_folder
) proc_as_ul
;
1179 SCM data
= SCM_CDDR (extended_data
);
1181 return (*proc
) (data
, symbol
, value
, tail
);
1191 eval_environment_fold (SCM env
, scm_environment_folder proc
, SCM data
, SCM init
)
1193 SCM local
= EVAL_ENVIRONMENT (env
)->local
;
1194 SCM imported
= EVAL_ENVIRONMENT (env
)->imported
;
1195 SCM proc_as_nr
= scm_from_ulong ((unsigned long) proc
);
1196 SCM extended_data
= scm_cons2 (local
, proc_as_nr
, data
);
1197 SCM tmp_result
= scm_c_environment_fold (imported
, eval_environment_folder
, extended_data
, init
);
1199 return scm_c_environment_fold (local
, proc
, data
, tmp_result
);
1204 eval_environment_define (SCM env
, SCM sym
, SCM val
)
1205 #define FUNC_NAME "eval_environment_define"
1207 SCM local
= EVAL_ENVIRONMENT (env
)->local
;
1208 return SCM_ENVIRONMENT_DEFINE (local
, sym
, val
);
1214 eval_environment_undefine (SCM env
, SCM sym
)
1215 #define FUNC_NAME "eval_environment_undefine"
1217 SCM local
= EVAL_ENVIRONMENT (env
)->local
;
1218 return SCM_ENVIRONMENT_UNDEFINE (local
, sym
);
1224 eval_environment_set_x (SCM env
, SCM sym
, SCM val
)
1225 #define FUNC_NAME "eval_environment_set_x"
1227 SCM location
= eval_environment_lookup (env
, sym
, 1);
1229 if (scm_is_pair (location
))
1231 SCM_SETCDR (location
, val
);
1232 return SCM_ENVIRONMENT_SUCCESS
;
1234 else if (SCM_ENVIRONMENT_P (location
))
1236 return SCM_ENVIRONMENT_SET (location
, sym
, val
);
1238 else if (scm_is_eq (location
, IMMUTABLE
))
1240 return SCM_ENVIRONMENT_LOCATION_IMMUTABLE
;
1244 return SCM_UNDEFINED
;
1251 eval_environment_cell (SCM env
, SCM sym
, int for_write
)
1252 #define FUNC_NAME "eval_environment_cell"
1254 SCM location
= eval_environment_lookup (env
, sym
, for_write
);
1256 if (scm_is_pair (location
))
1258 else if (SCM_ENVIRONMENT_P (location
))
1259 return SCM_ENVIRONMENT_LOCATION_NO_CELL
;
1260 else if (scm_is_eq (location
, IMMUTABLE
))
1261 return SCM_ENVIRONMENT_LOCATION_IMMUTABLE
;
1263 return SCM_UNDEFINED
;
1270 eval_environment_print (SCM type
, SCM port
, scm_print_state
*pstate SCM_UNUSED
)
1272 SCM address
= scm_from_size_t (SCM_UNPACK (type
));
1273 SCM base16
= scm_number_to_string (address
, scm_from_int (16));
1275 scm_puts ("#<eval environment ", port
);
1276 scm_display (base16
, port
);
1277 scm_puts (">", port
);
1283 static struct scm_environment_funcs eval_environment_funcs
= {
1284 eval_environment_ref
,
1285 eval_environment_fold
,
1286 eval_environment_define
,
1287 eval_environment_undefine
,
1288 eval_environment_set_x
,
1289 eval_environment_cell
,
1290 core_environments_observe
,
1291 core_environments_unobserve
,
1292 eval_environment_print
1296 void *scm_type_eval_environment
= &eval_environment_funcs
;
1300 eval_environment_observer (SCM caller SCM_UNUSED
, SCM eval_env
)
1302 SCM obarray
= EVAL_ENVIRONMENT (eval_env
)->obarray
;
1304 obarray_remove_all (obarray
);
1305 core_environments_broadcast (eval_env
);
1309 SCM_DEFINE (scm_make_eval_environment
, "make-eval-environment", 2, 0, 0,
1310 (SCM local
, SCM imported
),
1311 "Return a new environment object eval whose bindings are the\n"
1312 "union of the bindings in the environments @var{local} and\n"
1313 "@var{imported}, with bindings from @var{local} taking\n"
1314 "precedence. Definitions made in eval are placed in @var{local}.\n"
1315 "Applying @code{environment-define} or\n"
1316 "@code{environment-undefine} to eval has the same effect as\n"
1317 "applying the procedure to @var{local}.\n"
1318 "Note that eval incorporates @var{local} and @var{imported} by\n"
1320 "If, after creating eval, the program changes the bindings of\n"
1321 "@var{local} or @var{imported}, those changes will be visible\n"
1323 "Since most Scheme evaluation takes place in eval environments,\n"
1324 "they transparently cache the bindings received from @var{local}\n"
1325 "and @var{imported}. Thus, the first time the program looks up\n"
1326 "a symbol in eval, eval may make calls to @var{local} or\n"
1327 "@var{imported} to find their bindings, but subsequent\n"
1328 "references to that symbol will be as fast as references to\n"
1329 "bindings in finite environments.\n"
1330 "In typical use, @var{local} will be a finite environment, and\n"
1331 "@var{imported} will be an import environment")
1332 #define FUNC_NAME s_scm_make_eval_environment
1335 struct eval_environment
*body
;
1337 SCM_ASSERT (SCM_ENVIRONMENT_P (local
), local
, SCM_ARG1
, FUNC_NAME
);
1338 SCM_ASSERT (SCM_ENVIRONMENT_P (imported
), imported
, SCM_ARG2
, FUNC_NAME
);
1340 body
= scm_gc_malloc (sizeof (struct eval_environment
), "eval environment");
1342 core_environments_preinit (&body
->base
);
1343 body
->obarray
= SCM_BOOL_F
;
1344 body
->imported
= SCM_BOOL_F
;
1345 body
->imported_observer
= SCM_BOOL_F
;
1346 body
->local
= SCM_BOOL_F
;
1347 body
->local_observer
= SCM_BOOL_F
;
1349 env
= scm_make_environment (body
);
1351 core_environments_init (&body
->base
, &eval_environment_funcs
);
1352 body
->obarray
= scm_c_make_hash_table (DEFAULT_OBARRAY_SIZE
);
1353 body
->imported
= imported
;
1354 body
->imported_observer
1355 = SCM_ENVIRONMENT_OBSERVE (imported
, eval_environment_observer
, env
, 1);
1356 body
->local
= local
;
1357 body
->local_observer
1358 = SCM_ENVIRONMENT_OBSERVE (local
, eval_environment_observer
, env
, 1);
1365 SCM_DEFINE (scm_eval_environment_p
, "eval-environment?", 1, 0, 0,
1367 "Return @code{#t} if object is an eval environment, or @code{#f}\n"
1369 #define FUNC_NAME s_scm_eval_environment_p
1371 return scm_from_bool (SCM_EVAL_ENVIRONMENT_P (object
));
1376 SCM_DEFINE (scm_eval_environment_local
, "eval-environment-local", 1, 0, 0,
1378 "Return the local environment of eval environment @var{env}.")
1379 #define FUNC_NAME s_scm_eval_environment_local
1381 SCM_ASSERT (SCM_EVAL_ENVIRONMENT_P (env
), env
, SCM_ARG1
, FUNC_NAME
);
1383 return EVAL_ENVIRONMENT (env
)->local
;
1388 SCM_DEFINE (scm_eval_environment_set_local_x
, "eval-environment-set-local!", 2, 0, 0,
1389 (SCM env
, SCM local
),
1390 "Change @var{env}'s local environment to @var{local}.")
1391 #define FUNC_NAME s_scm_eval_environment_set_local_x
1393 struct eval_environment
*body
;
1395 SCM_ASSERT (SCM_EVAL_ENVIRONMENT_P (env
), env
, SCM_ARG1
, FUNC_NAME
);
1396 SCM_ASSERT (SCM_ENVIRONMENT_P (local
), local
, SCM_ARG2
, FUNC_NAME
);
1398 body
= EVAL_ENVIRONMENT (env
);
1400 obarray_remove_all (body
->obarray
);
1401 SCM_ENVIRONMENT_UNOBSERVE (body
->local
, body
->local_observer
);
1403 body
->local
= local
;
1404 body
->local_observer
1405 = SCM_ENVIRONMENT_OBSERVE (local
, eval_environment_observer
, env
, 1);
1407 core_environments_broadcast (env
);
1409 return SCM_UNSPECIFIED
;
1414 SCM_DEFINE (scm_eval_environment_imported
, "eval-environment-imported", 1, 0, 0,
1416 "Return the imported environment of eval environment @var{env}.")
1417 #define FUNC_NAME s_scm_eval_environment_imported
1419 SCM_ASSERT (SCM_EVAL_ENVIRONMENT_P (env
), env
, SCM_ARG1
, FUNC_NAME
);
1421 return EVAL_ENVIRONMENT (env
)->imported
;
1426 SCM_DEFINE (scm_eval_environment_set_imported_x
, "eval-environment-set-imported!", 2, 0, 0,
1427 (SCM env
, SCM imported
),
1428 "Change @var{env}'s imported environment to @var{imported}.")
1429 #define FUNC_NAME s_scm_eval_environment_set_imported_x
1431 struct eval_environment
*body
;
1433 SCM_ASSERT (SCM_EVAL_ENVIRONMENT_P (env
), env
, SCM_ARG1
, FUNC_NAME
);
1434 SCM_ASSERT (SCM_ENVIRONMENT_P (imported
), imported
, SCM_ARG2
, FUNC_NAME
);
1436 body
= EVAL_ENVIRONMENT (env
);
1438 obarray_remove_all (body
->obarray
);
1439 SCM_ENVIRONMENT_UNOBSERVE (body
->imported
, body
->imported_observer
);
1441 body
->imported
= imported
;
1442 body
->imported_observer
1443 = SCM_ENVIRONMENT_OBSERVE (imported
, eval_environment_observer
, env
, 1);
1445 core_environments_broadcast (env
);
1447 return SCM_UNSPECIFIED
;
1453 /* import environments
1455 * An import environment combines the bindings of a set of argument
1456 * environments, and checks for naming clashes.
1458 * Implementation: The import environment does no caching at all. For every
1459 * access, the list of imported environments is scanned.
1463 struct import_environment
{
1464 struct core_environments_base base
;
1467 SCM import_observers
;
1473 #define IMPORT_ENVIRONMENT(env) \
1474 ((struct import_environment *) SCM_CELL_WORD_1 (env))
1478 /* Lookup will report one of the following distinct results:
1479 * a) <environment> if only environment binds the symbol.
1480 * b) (env-1 env-2 ...) for conflicting bindings in env-1, ...
1481 * c) SCM_UNDEFINED if there is no binding for the symbol.
1484 import_environment_lookup (SCM env
, SCM sym
)
1486 SCM imports
= IMPORT_ENVIRONMENT (env
)->imports
;
1487 SCM result
= SCM_UNDEFINED
;
1490 for (l
= imports
; !scm_is_null (l
); l
= SCM_CDR (l
))
1492 SCM imported
= SCM_CAR (l
);
1494 if (SCM_ENVIRONMENT_BOUND_P (imported
, sym
))
1496 if (SCM_UNBNDP (result
))
1498 else if (scm_is_pair (result
))
1499 result
= scm_cons (imported
, result
);
1501 result
= scm_cons2 (imported
, result
, SCM_EOL
);
1505 if (scm_is_pair (result
))
1506 return scm_reverse (result
);
1513 import_environment_conflict (SCM env
, SCM sym
, SCM imports
)
1515 SCM conflict_proc
= IMPORT_ENVIRONMENT (env
)->conflict_proc
;
1516 SCM args
= scm_cons2 (env
, sym
, scm_cons (imports
, SCM_EOL
));
1518 return scm_apply_0 (conflict_proc
, args
);
1523 import_environment_ref (SCM env
, SCM sym
)
1524 #define FUNC_NAME "import_environment_ref"
1526 SCM owner
= import_environment_lookup (env
, sym
);
1528 if (SCM_UNBNDP (owner
))
1530 return SCM_UNDEFINED
;
1532 else if (scm_is_pair (owner
))
1534 SCM resolve
= import_environment_conflict (env
, sym
, owner
);
1536 if (SCM_ENVIRONMENT_P (resolve
))
1537 return SCM_ENVIRONMENT_REF (resolve
, sym
);
1539 return SCM_UNSPECIFIED
;
1543 return SCM_ENVIRONMENT_REF (owner
, sym
);
1550 import_environment_folder (SCM extended_data
, SCM symbol
, SCM value
, SCM tail
)
1551 #define FUNC_NAME "import_environment_fold"
1553 SCM import_env
= SCM_CAR (extended_data
);
1554 SCM imported_env
= SCM_CADR (extended_data
);
1555 SCM owner
= import_environment_lookup (import_env
, symbol
);
1556 SCM proc_as_nr
= SCM_CADDR (extended_data
);
1557 unsigned long int proc_as_ul
= scm_to_ulong (proc_as_nr
);
1558 scm_environment_folder proc
= (scm_environment_folder
) proc_as_ul
;
1559 SCM data
= SCM_CDDDR (extended_data
);
1561 if (scm_is_pair (owner
) && scm_is_eq (SCM_CAR (owner
), imported_env
))
1562 owner
= import_environment_conflict (import_env
, symbol
, owner
);
1564 if (SCM_ENVIRONMENT_P (owner
))
1565 return (*proc
) (data
, symbol
, value
, tail
);
1566 else /* unresolved conflict */
1567 return (*proc
) (data
, symbol
, SCM_UNSPECIFIED
, tail
);
1573 import_environment_fold (SCM env
, scm_environment_folder proc
, SCM data
, SCM init
)
1575 SCM proc_as_nr
= scm_from_ulong ((unsigned long) proc
);
1579 for (l
= IMPORT_ENVIRONMENT (env
)->imports
; !scm_is_null (l
); l
= SCM_CDR (l
))
1581 SCM imported_env
= SCM_CAR (l
);
1582 SCM extended_data
= scm_cons (env
, scm_cons2 (imported_env
, proc_as_nr
, data
));
1584 result
= scm_c_environment_fold (imported_env
, import_environment_folder
, extended_data
, result
);
1592 import_environment_define (SCM env SCM_UNUSED
,
1595 #define FUNC_NAME "import_environment_define"
1597 return SCM_ENVIRONMENT_BINDING_IMMUTABLE
;
1603 import_environment_undefine (SCM env SCM_UNUSED
,
1605 #define FUNC_NAME "import_environment_undefine"
1607 return SCM_ENVIRONMENT_BINDING_IMMUTABLE
;
1613 import_environment_set_x (SCM env
, SCM sym
, SCM val
)
1614 #define FUNC_NAME "import_environment_set_x"
1616 SCM owner
= import_environment_lookup (env
, sym
);
1618 if (SCM_UNBNDP (owner
))
1620 return SCM_UNDEFINED
;
1622 else if (scm_is_pair (owner
))
1624 SCM resolve
= import_environment_conflict (env
, sym
, owner
);
1626 if (SCM_ENVIRONMENT_P (resolve
))
1627 return SCM_ENVIRONMENT_SET (resolve
, sym
, val
);
1629 return SCM_ENVIRONMENT_LOCATION_IMMUTABLE
;
1633 return SCM_ENVIRONMENT_SET (owner
, sym
, val
);
1640 import_environment_cell (SCM env
, SCM sym
, int for_write
)
1641 #define FUNC_NAME "import_environment_cell"
1643 SCM owner
= import_environment_lookup (env
, sym
);
1645 if (SCM_UNBNDP (owner
))
1647 return SCM_UNDEFINED
;
1649 else if (scm_is_pair (owner
))
1651 SCM resolve
= import_environment_conflict (env
, sym
, owner
);
1653 if (SCM_ENVIRONMENT_P (resolve
))
1654 return SCM_ENVIRONMENT_CELL (resolve
, sym
, for_write
);
1656 return SCM_ENVIRONMENT_LOCATION_NO_CELL
;
1660 return SCM_ENVIRONMENT_CELL (owner
, sym
, for_write
);
1668 import_environment_print (SCM type
, SCM port
,
1669 scm_print_state
*pstate SCM_UNUSED
)
1671 SCM address
= scm_from_size_t (SCM_UNPACK (type
));
1672 SCM base16
= scm_number_to_string (address
, scm_from_int (16));
1674 scm_puts ("#<import environment ", port
);
1675 scm_display (base16
, port
);
1676 scm_puts (">", port
);
1682 static struct scm_environment_funcs import_environment_funcs
= {
1683 import_environment_ref
,
1684 import_environment_fold
,
1685 import_environment_define
,
1686 import_environment_undefine
,
1687 import_environment_set_x
,
1688 import_environment_cell
,
1689 core_environments_observe
,
1690 core_environments_unobserve
,
1691 import_environment_print
1695 void *scm_type_import_environment
= &import_environment_funcs
;
1699 import_environment_observer (SCM caller SCM_UNUSED
, SCM import_env
)
1701 core_environments_broadcast (import_env
);
1705 SCM_DEFINE (scm_make_import_environment
, "make-import-environment", 2, 0, 0,
1706 (SCM imports
, SCM conflict_proc
),
1707 "Return a new environment @var{imp} whose bindings are the union\n"
1708 "of the bindings from the environments in @var{imports};\n"
1709 "@var{imports} must be a list of environments. That is,\n"
1710 "@var{imp} binds a symbol to a location when some element of\n"
1711 "@var{imports} does.\n"
1712 "If two different elements of @var{imports} have a binding for\n"
1713 "the same symbol, the @var{conflict-proc} is called with the\n"
1714 "following parameters: the import environment, the symbol and\n"
1715 "the list of the imported environments that bind the symbol.\n"
1716 "If the @var{conflict-proc} returns an environment @var{env},\n"
1717 "the conflict is considered as resolved and the binding from\n"
1718 "@var{env} is used. If the @var{conflict-proc} returns some\n"
1719 "non-environment object, the conflict is considered unresolved\n"
1720 "and the symbol is treated as unspecified in the import\n"
1722 "The checking for conflicts may be performed lazily, i. e. at\n"
1723 "the moment when a value or binding for a certain symbol is\n"
1724 "requested instead of the moment when the environment is\n"
1725 "created or the bindings of the imports change.\n"
1726 "All bindings in @var{imp} are immutable. If you apply\n"
1727 "@code{environment-define} or @code{environment-undefine} to\n"
1728 "@var{imp}, Guile will signal an\n"
1729 " @code{environment:immutable-binding} error. However,\n"
1730 "notice that the set of bindings in @var{imp} may still change,\n"
1731 "if one of its imported environments changes.")
1732 #define FUNC_NAME s_scm_make_import_environment
1734 size_t size
= sizeof (struct import_environment
);
1735 struct import_environment
*body
= scm_gc_malloc (size
, "import environment");
1738 core_environments_preinit (&body
->base
);
1739 body
->imports
= SCM_BOOL_F
;
1740 body
->import_observers
= SCM_BOOL_F
;
1741 body
->conflict_proc
= SCM_BOOL_F
;
1743 env
= scm_make_environment (body
);
1745 core_environments_init (&body
->base
, &import_environment_funcs
);
1746 body
->imports
= SCM_EOL
;
1747 body
->import_observers
= SCM_EOL
;
1748 body
->conflict_proc
= conflict_proc
;
1750 scm_import_environment_set_imports_x (env
, imports
);
1757 SCM_DEFINE (scm_import_environment_p
, "import-environment?", 1, 0, 0,
1759 "Return @code{#t} if object is an import environment, or\n"
1760 "@code{#f} otherwise.")
1761 #define FUNC_NAME s_scm_import_environment_p
1763 return scm_from_bool (SCM_IMPORT_ENVIRONMENT_P (object
));
1768 SCM_DEFINE (scm_import_environment_imports
, "import-environment-imports", 1, 0, 0,
1770 "Return the list of environments imported by the import\n"
1771 "environment @var{env}.")
1772 #define FUNC_NAME s_scm_import_environment_imports
1774 SCM_ASSERT (SCM_IMPORT_ENVIRONMENT_P (env
), env
, SCM_ARG1
, FUNC_NAME
);
1776 return IMPORT_ENVIRONMENT (env
)->imports
;
1781 SCM_DEFINE (scm_import_environment_set_imports_x
, "import-environment-set-imports!", 2, 0, 0,
1782 (SCM env
, SCM imports
),
1783 "Change @var{env}'s list of imported environments to\n"
1784 "@var{imports}, and check for conflicts.")
1785 #define FUNC_NAME s_scm_import_environment_set_imports_x
1787 struct import_environment
*body
= IMPORT_ENVIRONMENT (env
);
1788 SCM import_observers
= SCM_EOL
;
1791 SCM_ASSERT (SCM_IMPORT_ENVIRONMENT_P (env
), env
, SCM_ARG1
, FUNC_NAME
);
1792 for (l
= imports
; scm_is_pair (l
); l
= SCM_CDR (l
))
1794 SCM obj
= SCM_CAR (l
);
1795 SCM_ASSERT (SCM_ENVIRONMENT_P (obj
), imports
, SCM_ARG2
, FUNC_NAME
);
1797 SCM_ASSERT (scm_is_null (l
), imports
, SCM_ARG2
, FUNC_NAME
);
1799 for (l
= body
->import_observers
; !scm_is_null (l
); l
= SCM_CDR (l
))
1801 SCM obs
= SCM_CAR (l
);
1802 SCM_ENVIRONMENT_UNOBSERVE (env
, obs
);
1805 for (l
= imports
; !scm_is_null (l
); l
= SCM_CDR (l
))
1807 SCM imp
= SCM_CAR (l
);
1808 SCM obs
= SCM_ENVIRONMENT_OBSERVE (imp
, import_environment_observer
, env
, 1);
1809 import_observers
= scm_cons (obs
, import_observers
);
1812 body
->imports
= imports
;
1813 body
->import_observers
= import_observers
;
1815 return SCM_UNSPECIFIED
;
1821 /* export environments
1823 * An export environment restricts an environment to a specified set of
1826 * Implementation: The export environment does no caching at all. For every
1827 * access, the signature is scanned. The signature that is stored internally
1828 * is an alist of pairs (symbol . (mutability)).
1832 struct export_environment
{
1833 struct core_environments_base base
;
1836 SCM private_observer
;
1842 #define EXPORT_ENVIRONMENT(env) \
1843 ((struct export_environment *) SCM_CELL_WORD_1 (env))
1846 SCM_SYMBOL (symbol_immutable_location
, "immutable-location");
1847 SCM_SYMBOL (symbol_mutable_location
, "mutable-location");
1852 export_environment_ref (SCM env
, SCM sym
)
1853 #define FUNC_NAME "export_environment_ref"
1855 struct export_environment
*body
= EXPORT_ENVIRONMENT (env
);
1856 SCM entry
= scm_assq (sym
, body
->signature
);
1858 if (scm_is_false (entry
))
1859 return SCM_UNDEFINED
;
1861 return SCM_ENVIRONMENT_REF (body
->private, sym
);
1867 export_environment_fold (SCM env
, scm_environment_folder proc
, SCM data
, SCM init
)
1869 struct export_environment
*body
= EXPORT_ENVIRONMENT (env
);
1873 for (l
= body
->signature
; !scm_is_null (l
); l
= SCM_CDR (l
))
1875 SCM symbol
= SCM_CAR (l
);
1876 SCM value
= SCM_ENVIRONMENT_REF (body
->private, symbol
);
1877 if (!SCM_UNBNDP (value
))
1878 result
= (*proc
) (data
, symbol
, value
, result
);
1885 export_environment_define (SCM env SCM_UNUSED
,
1888 #define FUNC_NAME "export_environment_define"
1890 return SCM_ENVIRONMENT_BINDING_IMMUTABLE
;
1896 export_environment_undefine (SCM env SCM_UNUSED
, SCM sym SCM_UNUSED
)
1897 #define FUNC_NAME "export_environment_undefine"
1899 return SCM_ENVIRONMENT_BINDING_IMMUTABLE
;
1905 export_environment_set_x (SCM env
, SCM sym
, SCM val
)
1906 #define FUNC_NAME "export_environment_set_x"
1908 struct export_environment
*body
= EXPORT_ENVIRONMENT (env
);
1909 SCM entry
= scm_assq (sym
, body
->signature
);
1911 if (scm_is_false (entry
))
1913 return SCM_UNDEFINED
;
1917 if (scm_is_eq (SCM_CADR (entry
), symbol_mutable_location
))
1918 return SCM_ENVIRONMENT_SET (body
->private, sym
, val
);
1920 return SCM_ENVIRONMENT_LOCATION_IMMUTABLE
;
1927 export_environment_cell (SCM env
, SCM sym
, int for_write
)
1928 #define FUNC_NAME "export_environment_cell"
1930 struct export_environment
*body
= EXPORT_ENVIRONMENT (env
);
1931 SCM entry
= scm_assq (sym
, body
->signature
);
1933 if (scm_is_false (entry
))
1935 return SCM_UNDEFINED
;
1939 if (!for_write
|| scm_is_eq (SCM_CADR (entry
), symbol_mutable_location
))
1940 return SCM_ENVIRONMENT_CELL (body
->private, sym
, for_write
);
1942 return SCM_ENVIRONMENT_LOCATION_IMMUTABLE
;
1950 export_environment_print (SCM type
, SCM port
,
1951 scm_print_state
*pstate SCM_UNUSED
)
1953 SCM address
= scm_from_size_t (SCM_UNPACK (type
));
1954 SCM base16
= scm_number_to_string (address
, scm_from_int (16));
1956 scm_puts ("#<export environment ", port
);
1957 scm_display (base16
, port
);
1958 scm_puts (">", port
);
1964 static struct scm_environment_funcs export_environment_funcs
= {
1965 export_environment_ref
,
1966 export_environment_fold
,
1967 export_environment_define
,
1968 export_environment_undefine
,
1969 export_environment_set_x
,
1970 export_environment_cell
,
1971 core_environments_observe
,
1972 core_environments_unobserve
,
1973 export_environment_print
1977 void *scm_type_export_environment
= &export_environment_funcs
;
1981 export_environment_observer (SCM caller SCM_UNUSED
, SCM export_env
)
1983 core_environments_broadcast (export_env
);
1987 SCM_DEFINE (scm_make_export_environment
, "make-export-environment", 2, 0, 0,
1988 (SCM
private, SCM signature
),
1989 "Return a new environment @var{exp} containing only those\n"
1990 "bindings in private whose symbols are present in\n"
1991 "@var{signature}. The @var{private} argument must be an\n"
1993 "The environment @var{exp} binds symbol to location when\n"
1994 "@var{env} does, and symbol is exported by @var{signature}.\n\n"
1995 "@var{signature} is a list specifying which of the bindings in\n"
1996 "@var{private} should be visible in @var{exp}. Each element of\n"
1997 "@var{signature} should be a list of the form:\n"
1998 " (symbol attribute ...)\n"
1999 "where each attribute is one of the following:\n"
2001 "@item the symbol @code{mutable-location}\n"
2002 " @var{exp} should treat the\n"
2003 " location bound to symbol as mutable. That is, @var{exp}\n"
2004 " will pass calls to @code{environment-set!} or\n"
2005 " @code{environment-cell} directly through to private.\n"
2006 "@item the symbol @code{immutable-location}\n"
2007 " @var{exp} should treat\n"
2008 " the location bound to symbol as immutable. If the program\n"
2009 " applies @code{environment-set!} to @var{exp} and symbol, or\n"
2010 " calls @code{environment-cell} to obtain a writable value\n"
2011 " cell, @code{environment-set!} will signal an\n"
2012 " @code{environment:immutable-location} error. Note that, even\n"
2013 " if an export environment treats a location as immutable, the\n"
2014 " underlying environment may treat it as mutable, so its\n"
2015 " value may change.\n"
2017 "It is an error for an element of signature to specify both\n"
2018 "@code{mutable-location} and @code{immutable-location}. If\n"
2019 "neither is specified, @code{immutable-location} is assumed.\n\n"
2020 "As a special case, if an element of signature is a lone\n"
2021 "symbol @var{sym}, it is equivalent to an element of the form\n"
2023 "All bindings in @var{exp} are immutable. If you apply\n"
2024 "@code{environment-define} or @code{environment-undefine} to\n"
2025 "@var{exp}, Guile will signal an\n"
2026 "@code{environment:immutable-binding} error. However,\n"
2027 "notice that the set of bindings in @var{exp} may still change,\n"
2028 "if the bindings in private change.")
2029 #define FUNC_NAME s_scm_make_export_environment
2032 struct export_environment
*body
;
2035 SCM_ASSERT (SCM_ENVIRONMENT_P (private), private, SCM_ARG1
, FUNC_NAME
);
2037 size
= sizeof (struct export_environment
);
2038 body
= scm_gc_malloc (size
, "export environment");
2040 core_environments_preinit (&body
->base
);
2041 body
->private = SCM_BOOL_F
;
2042 body
->private_observer
= SCM_BOOL_F
;
2043 body
->signature
= SCM_BOOL_F
;
2045 env
= scm_make_environment (body
);
2047 core_environments_init (&body
->base
, &export_environment_funcs
);
2048 body
->private = private;
2049 body
->private_observer
2050 = SCM_ENVIRONMENT_OBSERVE (private, export_environment_observer
, env
, 1);
2051 body
->signature
= SCM_EOL
;
2053 scm_export_environment_set_signature_x (env
, signature
);
2060 SCM_DEFINE (scm_export_environment_p
, "export-environment?", 1, 0, 0,
2062 "Return @code{#t} if object is an export environment, or\n"
2063 "@code{#f} otherwise.")
2064 #define FUNC_NAME s_scm_export_environment_p
2066 return scm_from_bool (SCM_EXPORT_ENVIRONMENT_P (object
));
2071 SCM_DEFINE (scm_export_environment_private
, "export-environment-private", 1, 0, 0,
2073 "Return the private environment of export environment @var{env}.")
2074 #define FUNC_NAME s_scm_export_environment_private
2076 SCM_ASSERT (SCM_EXPORT_ENVIRONMENT_P (env
), env
, SCM_ARG1
, FUNC_NAME
);
2078 return EXPORT_ENVIRONMENT (env
)->private;
2083 SCM_DEFINE (scm_export_environment_set_private_x
, "export-environment-set-private!", 2, 0, 0,
2084 (SCM env
, SCM
private),
2085 "Change the private environment of export environment @var{env}.")
2086 #define FUNC_NAME s_scm_export_environment_set_private_x
2088 struct export_environment
*body
;
2090 SCM_ASSERT (SCM_EXPORT_ENVIRONMENT_P (env
), env
, SCM_ARG1
, FUNC_NAME
);
2091 SCM_ASSERT (SCM_ENVIRONMENT_P (private), private, SCM_ARG2
, FUNC_NAME
);
2093 body
= EXPORT_ENVIRONMENT (env
);
2094 SCM_ENVIRONMENT_UNOBSERVE (private, body
->private_observer
);
2096 body
->private = private;
2097 body
->private_observer
2098 = SCM_ENVIRONMENT_OBSERVE (private, export_environment_observer
, env
, 1);
2100 return SCM_UNSPECIFIED
;
2105 SCM_DEFINE (scm_export_environment_signature
, "export-environment-signature", 1, 0, 0,
2107 "Return the signature of export environment @var{env}.")
2108 #define FUNC_NAME s_scm_export_environment_signature
2110 SCM_ASSERT (SCM_EXPORT_ENVIRONMENT_P (env
), env
, SCM_ARG1
, FUNC_NAME
);
2112 return EXPORT_ENVIRONMENT (env
)->signature
;
2118 export_environment_parse_signature (SCM signature
, const char* caller
)
2120 SCM result
= SCM_EOL
;
2123 for (l
= signature
; scm_is_pair (l
); l
= SCM_CDR (l
))
2125 SCM entry
= SCM_CAR (l
);
2127 if (scm_is_symbol (entry
))
2129 SCM new_entry
= scm_cons2 (entry
, symbol_immutable_location
, SCM_EOL
);
2130 result
= scm_cons (new_entry
, result
);
2141 SCM_ASSERT (scm_is_pair (entry
), entry
, SCM_ARGn
, caller
);
2142 SCM_ASSERT (scm_is_symbol (SCM_CAR (entry
)), entry
, SCM_ARGn
, caller
);
2144 sym
= SCM_CAR (entry
);
2146 for (l2
= SCM_CDR (entry
); scm_is_pair (l2
); l2
= SCM_CDR (l2
))
2148 SCM attribute
= SCM_CAR (l2
);
2149 if (scm_is_eq (attribute
, symbol_immutable_location
))
2151 else if (scm_is_eq (attribute
, symbol_mutable_location
))
2154 SCM_ASSERT (0, entry
, SCM_ARGn
, caller
);
2156 SCM_ASSERT (scm_is_null (l2
), entry
, SCM_ARGn
, caller
);
2157 SCM_ASSERT (!mutable || !immutable
, entry
, SCM_ARGn
, caller
);
2159 if (!mutable && !immutable
)
2162 mutability
= mutable ? symbol_mutable_location
: symbol_immutable_location
;
2163 new_entry
= scm_cons2 (sym
, mutability
, SCM_EOL
);
2164 result
= scm_cons (new_entry
, result
);
2167 SCM_ASSERT (scm_is_null (l
), signature
, SCM_ARGn
, caller
);
2169 /* Dirk:FIXME:: Now we know that signature is syntactically correct. There
2170 * are, however, no checks for symbols entered twice with contradicting
2171 * mutabilities. It would be nice, to implement this test, to be able to
2172 * call the sort functions conveniently from C.
2175 return scm_reverse (result
);
2179 SCM_DEFINE (scm_export_environment_set_signature_x
, "export-environment-set-signature!", 2, 0, 0,
2180 (SCM env
, SCM signature
),
2181 "Change the signature of export environment @var{env}.")
2182 #define FUNC_NAME s_scm_export_environment_set_signature_x
2186 SCM_ASSERT (SCM_EXPORT_ENVIRONMENT_P (env
), env
, SCM_ARG1
, FUNC_NAME
);
2187 parsed_sig
= export_environment_parse_signature (signature
, FUNC_NAME
);
2189 EXPORT_ENVIRONMENT (env
)->signature
= parsed_sig
;
2191 return SCM_UNSPECIFIED
;
2198 scm_environments_prehistory ()
2200 /* create environment smob */
2201 scm_tc16_environment
= scm_make_smob_type ("environment", 0);
2202 scm_set_smob_print (scm_tc16_environment
, environment_print
);
2204 /* create observer smob */
2205 scm_tc16_observer
= scm_make_smob_type ("observer", 0);
2206 scm_set_smob_print (scm_tc16_observer
, observer_print
);
2208 /* create system environment */
2209 scm_system_environment
= scm_make_leaf_environment ();
2210 scm_permanent_object (scm_system_environment
);
2215 scm_init_environments ()
2217 #include "libguile/environments.x"