1 /* Copyright (C) 1999,2000,2001, 2003, 2006 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
20 #include "libguile/_scm.h"
21 #include "libguile/alist.h"
22 #include "libguile/eval.h"
23 #include "libguile/gh.h"
24 #include "libguile/hash.h"
25 #include "libguile/list.h"
26 #include "libguile/ports.h"
27 #include "libguile/smob.h"
28 #include "libguile/symbols.h"
29 #include "libguile/vectors.h"
30 #include "libguile/weaks.h"
32 #include "libguile/environments.h"
36 scm_t_bits scm_tc16_environment
;
37 scm_t_bits scm_tc16_observer
;
38 #define DEFAULT_OBARRAY_SIZE 31
40 SCM scm_system_environment
;
44 /* error conditions */
47 * Throw an error if symbol is not bound in environment func
50 scm_error_environment_unbound (const char *func
, SCM env
, SCM symbol
)
52 /* Dirk:FIXME:: Should throw an environment:unbound type error */
53 char error
[] = "Symbol `~A' not bound in environment `~A'.";
54 SCM arguments
= scm_cons2 (symbol
, env
, SCM_EOL
);
55 scm_misc_error (func
, error
, arguments
);
60 * Throw an error if func tried to create (define) or remove
61 * (undefine) a new binding for symbol in env
64 scm_error_environment_immutable_binding (const char *func
, SCM env
, SCM symbol
)
66 /* Dirk:FIXME:: Should throw an environment:immutable-binding type error */
67 char error
[] = "Immutable binding in environment ~A (symbol: `~A').";
68 SCM arguments
= scm_cons2 (env
, symbol
, SCM_EOL
);
69 scm_misc_error (func
, error
, arguments
);
74 * Throw an error if func tried to change an immutable location.
77 scm_error_environment_immutable_location (const char *func
, SCM env
, SCM symbol
)
79 /* Dirk:FIXME:: Should throw an environment:immutable-location type error */
80 char error
[] = "Immutable location in environment `~A' (symbol: `~A').";
81 SCM arguments
= scm_cons2 (env
, symbol
, SCM_EOL
);
82 scm_misc_error (func
, error
, arguments
);
87 /* generic environments */
90 /* Create an environment for the given type. Dereferencing type twice must
91 * deliver the initialized set of environment functions. Thus, type will
92 * also determine the signature of the underlying environment implementation.
93 * Dereferencing type once will typically deliver the data fields used by the
94 * underlying environment implementation.
97 scm_make_environment (void *type
)
99 SCM_RETURN_NEWSMOB (scm_tc16_environment
, type
);
103 SCM_DEFINE (scm_environment_p
, "environment?", 1, 0, 0,
105 "Return @code{#t} if @var{obj} is an environment, or @code{#f}\n"
107 #define FUNC_NAME s_scm_environment_p
109 return scm_from_bool (SCM_ENVIRONMENT_P (obj
));
114 SCM_DEFINE (scm_environment_bound_p
, "environment-bound?", 2, 0, 0,
116 "Return @code{#t} if @var{sym} is bound in @var{env}, or\n"
117 "@code{#f} otherwise.")
118 #define FUNC_NAME s_scm_environment_bound_p
120 SCM_ASSERT (SCM_ENVIRONMENT_P (env
), env
, SCM_ARG1
, FUNC_NAME
);
121 SCM_ASSERT (scm_is_symbol (sym
), sym
, SCM_ARG2
, FUNC_NAME
);
123 return scm_from_bool (SCM_ENVIRONMENT_BOUND_P (env
, sym
));
128 SCM_DEFINE (scm_environment_ref
, "environment-ref", 2, 0, 0,
130 "Return the value of the location bound to @var{sym} in\n"
131 "@var{env}. If @var{sym} is unbound in @var{env}, signal an\n"
132 "@code{environment:unbound} error.")
133 #define FUNC_NAME s_scm_environment_ref
137 SCM_ASSERT (SCM_ENVIRONMENT_P (env
), env
, SCM_ARG1
, FUNC_NAME
);
138 SCM_ASSERT (scm_is_symbol (sym
), sym
, SCM_ARG2
, FUNC_NAME
);
140 val
= SCM_ENVIRONMENT_REF (env
, sym
);
142 if (!SCM_UNBNDP (val
))
145 scm_error_environment_unbound (FUNC_NAME
, env
, sym
);
150 /* This C function is identical to environment-ref, except that if symbol is
151 * unbound in env, it returns the value SCM_UNDEFINED, instead of signalling
155 scm_c_environment_ref (SCM env
, SCM sym
)
157 SCM_ASSERT (SCM_ENVIRONMENT_P (env
), env
, SCM_ARG1
, "scm_c_environment_ref");
158 SCM_ASSERT (scm_is_symbol (sym
), sym
, SCM_ARG2
, "scm_c_environment_ref");
159 return SCM_ENVIRONMENT_REF (env
, sym
);
164 environment_default_folder (SCM proc
, SCM symbol
, SCM value
, SCM tail
)
166 return scm_call_3 (proc
, symbol
, value
, tail
);
170 SCM_DEFINE (scm_environment_fold
, "environment-fold", 3, 0, 0,
171 (SCM env
, SCM proc
, SCM init
),
172 "Iterate over all the bindings in @var{env}, accumulating some\n"
174 "For each binding in @var{env}, apply @var{proc} to the symbol\n"
175 "bound, its value, and the result from the previous application\n"
177 "Use @var{init} as @var{proc}'s third argument the first time\n"
178 "@var{proc} is applied.\n"
179 "If @var{env} contains no bindings, this function simply returns\n"
181 "If @var{env} binds the symbol sym1 to the value val1, sym2 to\n"
182 "val2, and so on, then this procedure computes:\n"
190 "Each binding in @var{env} will be processed exactly once.\n"
191 "@code{environment-fold} makes no guarantees about the order in\n"
192 "which the bindings are processed.\n"
193 "Here is a function which, given an environment, constructs an\n"
194 "association list representing that environment's bindings,\n"
195 "using environment-fold:\n"
197 " (define (environment->alist env)\n"
198 " (environment-fold env\n"
199 " (lambda (sym val tail)\n"
200 " (cons (cons sym val) tail))\n"
203 #define FUNC_NAME s_scm_environment_fold
205 SCM_ASSERT (SCM_ENVIRONMENT_P (env
), env
, SCM_ARG1
, FUNC_NAME
);
206 SCM_ASSERT (scm_is_true (scm_procedure_p (proc
)),
207 proc
, SCM_ARG2
, FUNC_NAME
);
209 return SCM_ENVIRONMENT_FOLD (env
, environment_default_folder
, proc
, init
);
214 /* This is the C-level analog of environment-fold. For each binding in ENV,
216 * (*proc) (data, symbol, value, previous)
217 * where previous is the value returned from the last call to *PROC, or INIT
218 * for the first call. If ENV contains no bindings, return INIT.
221 scm_c_environment_fold (SCM env
, scm_environment_folder proc
, SCM data
, SCM init
)
223 SCM_ASSERT (SCM_ENVIRONMENT_P (env
), env
, SCM_ARG1
, "scm_c_environment_fold");
225 return SCM_ENVIRONMENT_FOLD (env
, proc
, data
, init
);
229 SCM_DEFINE (scm_environment_define
, "environment-define", 3, 0, 0,
230 (SCM env
, SCM sym
, SCM val
),
231 "Bind @var{sym} to a new location containing @var{val} in\n"
232 "@var{env}. If @var{sym} is already bound to another location\n"
233 "in @var{env} and the binding is mutable, that binding is\n"
234 "replaced. The new binding and location are both mutable. The\n"
235 "return value is unspecified.\n"
236 "If @var{sym} is already bound in @var{env}, and the binding is\n"
237 "immutable, signal an @code{environment:immutable-binding} error.")
238 #define FUNC_NAME s_scm_environment_define
242 SCM_ASSERT (SCM_ENVIRONMENT_P (env
), env
, SCM_ARG1
, FUNC_NAME
);
243 SCM_ASSERT (scm_is_symbol (sym
), sym
, SCM_ARG2
, FUNC_NAME
);
245 status
= SCM_ENVIRONMENT_DEFINE (env
, sym
, val
);
247 if (scm_is_eq (status
, SCM_ENVIRONMENT_SUCCESS
))
248 return SCM_UNSPECIFIED
;
249 else if (scm_is_eq (status
, SCM_ENVIRONMENT_BINDING_IMMUTABLE
))
250 scm_error_environment_immutable_binding (FUNC_NAME
, env
, sym
);
257 SCM_DEFINE (scm_environment_undefine
, "environment-undefine", 2, 0, 0,
259 "Remove any binding for @var{sym} from @var{env}. If @var{sym}\n"
260 "is unbound in @var{env}, do nothing. The return value is\n"
262 "If @var{sym} is already bound in @var{env}, and the binding is\n"
263 "immutable, signal an @code{environment:immutable-binding} error.")
264 #define FUNC_NAME s_scm_environment_undefine
268 SCM_ASSERT(SCM_ENVIRONMENT_P(env
), env
, SCM_ARG1
, FUNC_NAME
);
269 SCM_ASSERT(scm_is_symbol(sym
), sym
, SCM_ARG2
, FUNC_NAME
);
271 status
= SCM_ENVIRONMENT_UNDEFINE (env
, sym
);
273 if (scm_is_eq (status
, SCM_ENVIRONMENT_SUCCESS
))
274 return SCM_UNSPECIFIED
;
275 else if (scm_is_eq (status
, SCM_ENVIRONMENT_BINDING_IMMUTABLE
))
276 scm_error_environment_immutable_binding (FUNC_NAME
, env
, sym
);
283 SCM_DEFINE (scm_environment_set_x
, "environment-set!", 3, 0, 0,
284 (SCM env
, SCM sym
, SCM val
),
285 "If @var{env} binds @var{sym} to some location, change that\n"
286 "location's value to @var{val}. The return value is\n"
288 "If @var{sym} is not bound in @var{env}, signal an\n"
289 "@code{environment:unbound} error. If @var{env} binds @var{sym}\n"
290 "to an immutable location, signal an\n"
291 "@code{environment:immutable-location} error.")
292 #define FUNC_NAME s_scm_environment_set_x
296 SCM_ASSERT (SCM_ENVIRONMENT_P (env
), env
, SCM_ARG1
, FUNC_NAME
);
297 SCM_ASSERT (scm_is_symbol (sym
), sym
, SCM_ARG2
, FUNC_NAME
);
299 status
= SCM_ENVIRONMENT_SET (env
, sym
, val
);
301 if (scm_is_eq (status
, SCM_ENVIRONMENT_SUCCESS
))
302 return SCM_UNSPECIFIED
;
303 else if (SCM_UNBNDP (status
))
304 scm_error_environment_unbound (FUNC_NAME
, env
, sym
);
305 else if (scm_is_eq (status
, SCM_ENVIRONMENT_LOCATION_IMMUTABLE
))
306 scm_error_environment_immutable_binding (FUNC_NAME
, env
, sym
);
313 SCM_DEFINE (scm_environment_cell
, "environment-cell", 3, 0, 0,
314 (SCM env
, SCM sym
, SCM for_write
),
315 "Return the value cell which @var{env} binds to @var{sym}, or\n"
316 "@code{#f} if the binding does not live in a value cell.\n"
317 "The argument @var{for-write} indicates whether the caller\n"
318 "intends to modify the variable's value by mutating the value\n"
319 "cell. If the variable is immutable, then\n"
320 "@code{environment-cell} signals an\n"
321 "@code{environment:immutable-location} error.\n"
322 "If @var{sym} is unbound in @var{env}, signal an\n"
323 "@code{environment:unbound} error.\n"
324 "If you use this function, you should consider using\n"
325 "@code{environment-observe}, to be notified when @var{sym} gets\n"
326 "re-bound to a new value cell, or becomes undefined.")
327 #define FUNC_NAME s_scm_environment_cell
331 SCM_ASSERT (SCM_ENVIRONMENT_P (env
), env
, SCM_ARG1
, FUNC_NAME
);
332 SCM_ASSERT (scm_is_symbol (sym
), sym
, SCM_ARG2
, FUNC_NAME
);
333 SCM_ASSERT (scm_is_bool (for_write
), for_write
, SCM_ARG3
, FUNC_NAME
);
335 location
= SCM_ENVIRONMENT_CELL (env
, sym
, scm_is_true (for_write
));
336 if (!SCM_IMP (location
))
338 else if (SCM_UNBNDP (location
))
339 scm_error_environment_unbound (FUNC_NAME
, env
, sym
);
340 else if (scm_is_eq (location
, SCM_ENVIRONMENT_LOCATION_IMMUTABLE
))
341 scm_error_environment_immutable_location (FUNC_NAME
, env
, sym
);
348 /* This C function is identical to environment-cell, with the following
349 * exceptions: If symbol is unbound in env, it returns the value
350 * SCM_UNDEFINED, instead of signalling an error. If symbol is bound to an
351 * immutable location but the cell is requested for write, the value
352 * SCM_ENVIRONMENT_LOCATION_IMMUTABLE is returned.
355 scm_c_environment_cell(SCM env
, SCM sym
, int for_write
)
357 SCM_ASSERT (SCM_ENVIRONMENT_P (env
), env
, SCM_ARG1
, "scm_c_environment_cell");
358 SCM_ASSERT (scm_is_symbol (sym
), sym
, SCM_ARG2
, "scm_c_environment_cell");
360 return SCM_ENVIRONMENT_CELL (env
, sym
, for_write
);
365 environment_default_observer (SCM env
, SCM proc
)
367 scm_call_1 (proc
, env
);
371 SCM_DEFINE (scm_environment_observe
, "environment-observe", 2, 0, 0,
373 "Whenever @var{env}'s bindings change, apply @var{proc} to\n"
375 "This function returns an object, token, which you can pass to\n"
376 "@code{environment-unobserve} to remove @var{proc} from the set\n"
377 "of procedures observing @var{env}. The type and value of\n"
378 "token is unspecified.")
379 #define FUNC_NAME s_scm_environment_observe
381 SCM_ASSERT (SCM_ENVIRONMENT_P (env
), env
, SCM_ARG1
, FUNC_NAME
);
383 return SCM_ENVIRONMENT_OBSERVE (env
, environment_default_observer
, proc
, 0);
388 SCM_DEFINE (scm_environment_observe_weak
, "environment-observe-weak", 2, 0, 0,
390 "This function is the same as environment-observe, except that\n"
391 "the reference @var{env} retains to @var{proc} is a weak\n"
392 "reference. This means that, if there are no other live,\n"
393 "non-weak references to @var{proc}, it will be\n"
394 "garbage-collected, and dropped from @var{env}'s\n"
395 "list of observing procedures.")
396 #define FUNC_NAME s_scm_environment_observe_weak
398 SCM_ASSERT (SCM_ENVIRONMENT_P (env
), env
, SCM_ARG1
, FUNC_NAME
);
400 return SCM_ENVIRONMENT_OBSERVE (env
, environment_default_observer
, proc
, 1);
405 /* This is the C-level analog of the Scheme functions environment-observe and
406 * environment-observe-weak. Whenever env's bindings change, call the
407 * function proc, passing it env and data. If weak_p is non-zero, env will
408 * retain only a weak reference to data, and if data is garbage collected, the
409 * entire observation will be dropped. This function returns a token, with
410 * the same meaning as those returned by environment-observe and
411 * environment-observe-weak.
414 scm_c_environment_observe (SCM env
, scm_environment_observer proc
, SCM data
, int weak_p
)
415 #define FUNC_NAME "scm_c_environment_observe"
417 SCM_ASSERT (SCM_ENVIRONMENT_P (env
), env
, SCM_ARG1
, FUNC_NAME
);
419 return SCM_ENVIRONMENT_OBSERVE (env
, proc
, data
, weak_p
);
424 SCM_DEFINE (scm_environment_unobserve
, "environment-unobserve", 1, 0, 0,
426 "Cancel the observation request which returned the value\n"
427 "@var{token}. The return value is unspecified.\n"
428 "If a call @code{(environment-observe env proc)} returns\n"
429 "@var{token}, then the call @code{(environment-unobserve token)}\n"
430 "will cause @var{proc} to no longer be called when @var{env}'s\n"
432 #define FUNC_NAME s_scm_environment_unobserve
436 SCM_ASSERT (SCM_OBSERVER_P (token
), token
, SCM_ARG1
, FUNC_NAME
);
438 env
= SCM_OBSERVER_ENVIRONMENT (token
);
439 SCM_ENVIRONMENT_UNOBSERVE (env
, token
);
441 return SCM_UNSPECIFIED
;
448 environment_print (SCM env
, SCM port
, scm_print_state
*pstate
)
450 return (*(SCM_ENVIRONMENT_FUNCS (env
)->print
)) (env
, port
, pstate
);
459 observer_print (SCM type
, SCM port
, scm_print_state
*pstate SCM_UNUSED
)
461 SCM address
= scm_from_size_t (SCM_UNPACK (type
));
462 SCM base16
= scm_number_to_string (address
, scm_from_int (16));
464 scm_puts ("#<observer ", port
);
465 scm_display (base16
, port
);
466 scm_puts (">", port
);
475 * Obarrays form the basic lookup tables used to implement most of guile's
476 * built-in environment types. An obarray is implemented as a hash table with
477 * symbols as keys. The content of the data depends on the environment type.
482 * Enter symbol into obarray. The symbol must not already exist in obarray.
483 * The freshly generated (symbol . data) cell is returned.
486 obarray_enter (SCM obarray
, SCM symbol
, SCM data
)
488 size_t hash
= scm_i_symbol_hash (symbol
) % SCM_HASHTABLE_N_BUCKETS (obarray
);
489 SCM entry
= scm_cons (symbol
, data
);
490 SCM slot
= scm_cons (entry
, SCM_HASHTABLE_BUCKET (obarray
, hash
));
491 SCM_SET_HASHTABLE_BUCKET (obarray
, hash
, slot
);
492 SCM_HASHTABLE_INCREMENT (obarray
);
493 if (SCM_HASHTABLE_N_ITEMS (obarray
) > SCM_HASHTABLE_UPPER (obarray
))
494 scm_i_rehash (obarray
, scm_i_hash_symbol
, 0, "obarray_enter");
501 * Enter symbol into obarray. An existing entry for symbol is replaced. If
502 * an entry existed, the old (symbol . data) cell is returned, #f otherwise.
505 obarray_replace (SCM obarray
, SCM symbol
, SCM data
)
507 size_t hash
= scm_i_symbol_hash (symbol
) % SCM_HASHTABLE_N_BUCKETS (obarray
);
508 SCM new_entry
= scm_cons (symbol
, data
);
512 for (lsym
= SCM_HASHTABLE_BUCKET (obarray
, hash
);
514 lsym
= SCM_CDR (lsym
))
516 SCM old_entry
= SCM_CAR (lsym
);
517 if (scm_is_eq (SCM_CAR (old_entry
), symbol
))
519 SCM_SETCAR (lsym
, new_entry
);
524 slot
= scm_cons (new_entry
, SCM_HASHTABLE_BUCKET (obarray
, hash
));
525 SCM_SET_HASHTABLE_BUCKET (obarray
, hash
, slot
);
526 SCM_HASHTABLE_INCREMENT (obarray
);
527 if (SCM_HASHTABLE_N_ITEMS (obarray
) > SCM_HASHTABLE_UPPER (obarray
))
528 scm_i_rehash (obarray
, scm_i_hash_symbol
, 0, "obarray_replace");
535 * Look up symbol in obarray
538 obarray_retrieve (SCM obarray
, SCM sym
)
540 size_t hash
= scm_i_symbol_hash (sym
) % SCM_HASHTABLE_N_BUCKETS (obarray
);
543 for (lsym
= SCM_HASHTABLE_BUCKET (obarray
, hash
);
545 lsym
= SCM_CDR (lsym
))
547 SCM entry
= SCM_CAR (lsym
);
548 if (scm_is_eq (SCM_CAR (entry
), sym
))
552 return SCM_UNDEFINED
;
557 * Remove entry from obarray. If the symbol was found and removed, the old
558 * (symbol . data) cell is returned, #f otherwise.
561 obarray_remove (SCM obarray
, SCM sym
)
563 size_t hash
= scm_i_symbol_hash (sym
) % SCM_HASHTABLE_N_BUCKETS (obarray
);
564 SCM table_entry
= SCM_HASHTABLE_BUCKET (obarray
, hash
);
565 SCM handle
= scm_sloppy_assq (sym
, table_entry
);
567 if (scm_is_pair (handle
))
569 SCM new_table_entry
= scm_delq1_x (handle
, table_entry
);
570 SCM_SET_HASHTABLE_BUCKET (obarray
, hash
, new_table_entry
);
571 SCM_HASHTABLE_DECREMENT (obarray
);
579 obarray_remove_all (SCM obarray
)
581 size_t size
= SCM_HASHTABLE_N_BUCKETS (obarray
);
584 for (i
= 0; i
< size
; i
++)
586 SCM_SET_HASHTABLE_BUCKET (obarray
, i
, SCM_EOL
);
588 SCM_SET_HASHTABLE_N_ITEMS (obarray
, 0);
593 /* core environments base
595 * This struct and the corresponding functions form a base class for guile's
596 * built-in environment types.
600 struct core_environments_base
{
601 struct scm_environment_funcs
*funcs
;
608 #define CORE_ENVIRONMENTS_BASE(env) \
609 ((struct core_environments_base *) SCM_CELL_WORD_1 (env))
610 #define CORE_ENVIRONMENT_OBSERVERS(env) \
611 (CORE_ENVIRONMENTS_BASE (env)->observers)
612 #define SCM_SET_CORE_ENVIRONMENT_OBSERVERS(env, v) \
613 (CORE_ENVIRONMENT_OBSERVERS (env) = (v))
614 #define CORE_ENVIRONMENT_WEAK_OBSERVER_VECTOR(env) \
615 (CORE_ENVIRONMENTS_BASE (env)->weak_observers)
616 #define CORE_ENVIRONMENT_WEAK_OBSERVERS(env) \
617 (scm_c_vector_ref (CORE_ENVIRONMENT_WEAK_OBSERVER_VECTOR (env), 0))
618 #define SCM_SET_CORE_ENVIRONMENT_WEAK_OBSERVERS(env, v) \
619 (scm_c_vector_set_x (CORE_ENVIRONMENT_WEAK_OBSERVER_VECTOR (env), 0, (v)))
624 core_environments_observe (SCM env
, scm_environment_observer proc
, SCM data
, int weak_p
)
628 SCM_NEWSMOB3 (observer
, scm_tc16_observer
,
635 SCM observers
= CORE_ENVIRONMENT_OBSERVERS (env
);
636 SCM new_observers
= scm_cons (observer
, observers
);
637 SCM_SET_CORE_ENVIRONMENT_OBSERVERS (env
, new_observers
);
641 SCM observers
= CORE_ENVIRONMENT_WEAK_OBSERVERS (env
);
642 SCM new_observers
= scm_acons (SCM_BOOL_F
, observer
, observers
);
643 SCM_SET_CORE_ENVIRONMENT_WEAK_OBSERVERS (env
, new_observers
);
651 core_environments_unobserve (SCM env
, SCM observer
)
653 unsigned int handling_weaks
;
654 for (handling_weaks
= 0; handling_weaks
<= 1; ++handling_weaks
)
656 SCM l
= handling_weaks
657 ? CORE_ENVIRONMENT_WEAK_OBSERVERS (env
)
658 : CORE_ENVIRONMENT_OBSERVERS (env
);
660 if (!scm_is_null (l
))
662 SCM rest
= SCM_CDR (l
);
663 SCM first
= handling_weaks
667 if (scm_is_eq (first
, observer
))
669 /* Remove the first observer */
671 ? SCM_SET_CORE_ENVIRONMENT_WEAK_OBSERVERS (env
, rest
)
672 : SCM_SET_CORE_ENVIRONMENT_OBSERVERS (env
, rest
);
677 SCM rest
= SCM_CDR (l
);
679 if (!scm_is_null (rest
))
681 SCM next
= handling_weaks
685 if (scm_is_eq (next
, observer
))
687 SCM_SETCDR (l
, SCM_CDR (rest
));
693 } while (!scm_is_null (l
));
697 /* Dirk:FIXME:: What to do now, since the observer is not found? */
702 core_environments_preinit (struct core_environments_base
*body
)
705 body
->observers
= SCM_BOOL_F
;
706 body
->weak_observers
= SCM_BOOL_F
;
711 core_environments_init (struct core_environments_base
*body
,
712 struct scm_environment_funcs
*funcs
)
715 body
->observers
= SCM_EOL
;
716 body
->weak_observers
= scm_make_weak_value_alist_vector (scm_from_int (1));
720 /* Tell all observers to clear their caches.
722 * Environments have to be informed about changes in the following cases:
723 * - The observed env has a new binding. This must be always reported.
724 * - The observed env has dropped a binding. This must be always reported.
725 * - A binding in the observed environment has changed. This must only be
726 * reported, if there is a chance that the binding is being cached outside.
727 * However, this potential optimization is not performed currently.
729 * Errors that occur while the observers are called are accumulated and
730 * signalled as one single error message to the caller.
741 update_catch_body (void *ptr
)
743 struct update_data
*data
= (struct update_data
*) ptr
;
744 SCM observer
= data
->observer
;
746 (*SCM_OBSERVER_PROC (observer
))
747 (data
->environment
, SCM_OBSERVER_DATA (observer
));
749 return SCM_UNDEFINED
;
754 update_catch_handler (void *ptr
, SCM tag
, SCM args
)
756 struct update_data
*data
= (struct update_data
*) ptr
;
757 SCM observer
= data
->observer
;
759 scm_from_locale_string ("Observer `~A' signals `~A' error: ~S");
761 return scm_cons (message
, scm_list_3 (observer
, tag
, args
));
766 core_environments_broadcast (SCM env
)
767 #define FUNC_NAME "core_environments_broadcast"
769 unsigned int handling_weaks
;
770 SCM errors
= SCM_EOL
;
772 for (handling_weaks
= 0; handling_weaks
<= 1; ++handling_weaks
)
774 SCM observers
= handling_weaks
775 ? CORE_ENVIRONMENT_WEAK_OBSERVERS (env
)
776 : CORE_ENVIRONMENT_OBSERVERS (env
);
778 for (; !scm_is_null (observers
); observers
= SCM_CDR (observers
))
780 struct update_data data
;
781 SCM observer
= handling_weaks
782 ? SCM_CDAR (observers
)
783 : SCM_CAR (observers
);
786 data
.observer
= observer
;
787 data
.environment
= env
;
789 error
= scm_internal_catch (SCM_BOOL_T
,
790 update_catch_body
, &data
,
791 update_catch_handler
, &data
);
793 if (!SCM_UNBNDP (error
))
794 errors
= scm_cons (error
, errors
);
798 if (!scm_is_null (errors
))
800 /* Dirk:FIXME:: As soon as scm_misc_error is fixed to handle the name
801 * parameter correctly it should not be necessary any more to also pass
802 * namestr in order to get the desired information from the error
805 SCM ordered_errors
= scm_reverse (errors
);
808 "Observers of `~A' have signalled the following errors: ~S",
809 scm_cons2 (env
, ordered_errors
, SCM_EOL
));
818 * A leaf environment is simply a mutable set of definitions. A leaf
819 * environment supports no operations beyond the common set.
821 * Implementation: The obarray of the leaf environment holds (symbol . value)
822 * pairs. No further information is necessary, since all bindings and
823 * locations in a leaf environment are mutable.
827 struct leaf_environment
{
828 struct core_environments_base base
;
834 #define LEAF_ENVIRONMENT(env) \
835 ((struct leaf_environment *) SCM_CELL_WORD_1 (env))
840 leaf_environment_ref (SCM env
, SCM sym
)
842 SCM obarray
= LEAF_ENVIRONMENT (env
)->obarray
;
843 SCM binding
= obarray_retrieve (obarray
, sym
);
844 return SCM_UNBNDP (binding
) ? binding
: SCM_CDR (binding
);
849 leaf_environment_fold (SCM env
, scm_environment_folder proc
, SCM data
, SCM init
)
853 SCM obarray
= LEAF_ENVIRONMENT (env
)->obarray
;
855 for (i
= 0; i
< SCM_HASHTABLE_N_BUCKETS (obarray
); i
++)
858 for (l
= SCM_HASHTABLE_BUCKET (obarray
, i
);
862 SCM binding
= SCM_CAR (l
);
863 SCM symbol
= SCM_CAR (binding
);
864 SCM value
= SCM_CDR (binding
);
865 result
= (*proc
) (data
, symbol
, value
, result
);
873 leaf_environment_define (SCM env
, SCM sym
, SCM val
)
874 #define FUNC_NAME "leaf_environment_define"
876 SCM obarray
= LEAF_ENVIRONMENT (env
)->obarray
;
878 obarray_replace (obarray
, sym
, val
);
879 core_environments_broadcast (env
);
881 return SCM_ENVIRONMENT_SUCCESS
;
887 leaf_environment_undefine (SCM env
, SCM sym
)
888 #define FUNC_NAME "leaf_environment_undefine"
890 SCM obarray
= LEAF_ENVIRONMENT (env
)->obarray
;
891 SCM removed
= obarray_remove (obarray
, sym
);
893 if (scm_is_true (removed
))
894 core_environments_broadcast (env
);
896 return SCM_ENVIRONMENT_SUCCESS
;
902 leaf_environment_set_x (SCM env
, SCM sym
, SCM val
)
903 #define FUNC_NAME "leaf_environment_set_x"
905 SCM obarray
= LEAF_ENVIRONMENT (env
)->obarray
;
906 SCM binding
= obarray_retrieve (obarray
, sym
);
908 if (!SCM_UNBNDP (binding
))
910 SCM_SETCDR (binding
, val
);
911 return SCM_ENVIRONMENT_SUCCESS
;
915 return SCM_UNDEFINED
;
922 leaf_environment_cell (SCM env
, SCM sym
, int for_write SCM_UNUSED
)
924 SCM obarray
= LEAF_ENVIRONMENT (env
)->obarray
;
925 SCM binding
= obarray_retrieve (obarray
, sym
);
932 leaf_environment_print (SCM type
, SCM port
, scm_print_state
*pstate SCM_UNUSED
)
934 SCM address
= scm_from_size_t (SCM_UNPACK (type
));
935 SCM base16
= scm_number_to_string (address
, scm_from_int (16));
937 scm_puts ("#<leaf environment ", port
);
938 scm_display (base16
, port
);
939 scm_puts (">", port
);
945 static struct scm_environment_funcs leaf_environment_funcs
= {
946 leaf_environment_ref
,
947 leaf_environment_fold
,
948 leaf_environment_define
,
949 leaf_environment_undefine
,
950 leaf_environment_set_x
,
951 leaf_environment_cell
,
952 core_environments_observe
,
953 core_environments_unobserve
,
954 leaf_environment_print
958 void *scm_type_leaf_environment
= &leaf_environment_funcs
;
961 SCM_DEFINE (scm_make_leaf_environment
, "make-leaf-environment", 0, 0, 0,
963 "Create a new leaf environment, containing no bindings.\n"
964 "All bindings and locations created in the new environment\n"
966 #define FUNC_NAME s_scm_make_leaf_environment
968 size_t size
= sizeof (struct leaf_environment
);
969 struct leaf_environment
*body
= scm_gc_malloc (size
, "leaf environment");
972 core_environments_preinit (&body
->base
);
973 body
->obarray
= SCM_BOOL_F
;
975 env
= scm_make_environment (body
);
977 core_environments_init (&body
->base
, &leaf_environment_funcs
);
978 body
->obarray
= scm_c_make_hash_table (DEFAULT_OBARRAY_SIZE
);
985 SCM_DEFINE (scm_leaf_environment_p
, "leaf-environment?", 1, 0, 0,
987 "Return @code{#t} if object is a leaf environment, or @code{#f}\n"
989 #define FUNC_NAME s_scm_leaf_environment_p
991 return scm_from_bool (SCM_LEAF_ENVIRONMENT_P (object
));
999 * A module's source code refers to definitions imported from other modules,
1000 * and definitions made within itself. An eval environment combines two
1001 * environments -- a local environment and an imported environment -- to
1002 * produce a new environment in which both sorts of references can be
1005 * Implementation: The obarray of the eval environment is used to cache
1006 * entries from the local and imported environments such that in most of the
1007 * cases only a single lookup is necessary. Since for neither the local nor
1008 * the imported environment it is known, what kind of environment they form,
1009 * the most general case is assumed. Therefore, entries in the obarray take
1010 * one of the following forms:
1012 * 1) (<symbol> location mutability . source-env), where mutability indicates
1013 * one of the following states: IMMUTABLE if the location is known to be
1014 * immutable, MUTABLE if the location is known to be mutable, UNKNOWN if
1015 * the location has only been requested for non modifying accesses.
1017 * 2) (symbol . source-env) if the symbol has a binding in the source-env, but
1018 * if the source-env can't provide a cell for the binding. Thus, for every
1019 * access, the source-env has to be contacted directly.
1023 struct eval_environment
{
1024 struct core_environments_base base
;
1029 SCM imported_observer
;
1035 #define EVAL_ENVIRONMENT(env) \
1036 ((struct eval_environment *) SCM_CELL_WORD_1 (env))
1038 #define IMMUTABLE SCM_I_MAKINUM (0)
1039 #define MUTABLE SCM_I_MAKINUM (1)
1040 #define UNKNOWN SCM_I_MAKINUM (2)
1042 #define CACHED_LOCATION(x) SCM_CAR (x)
1043 #define CACHED_MUTABILITY(x) SCM_CADR (x)
1044 #define SET_CACHED_MUTABILITY(x, v) SCM_SETCAR (SCM_CDR (x), (v))
1045 #define CACHED_SOURCE_ENVIRONMENT(x) SCM_CDDR (x)
1049 /* eval_environment_lookup will report one of the following distinct results:
1050 * a) (<object> . value) if a cell could be obtained.
1051 * b) <environment> if the environment has to be contacted directly.
1052 * c) IMMUTABLE if an immutable cell was requested for write.
1053 * d) SCM_UNDEFINED if there is no binding for the symbol.
1056 eval_environment_lookup (SCM env
, SCM sym
, int for_write
)
1058 SCM obarray
= EVAL_ENVIRONMENT (env
)->obarray
;
1059 SCM binding
= obarray_retrieve (obarray
, sym
);
1061 if (!SCM_UNBNDP (binding
))
1063 /* The obarray holds an entry for the symbol. */
1065 SCM entry
= SCM_CDR (binding
);
1067 if (scm_is_pair (entry
))
1069 /* The entry in the obarray is a cached location. */
1071 SCM location
= CACHED_LOCATION (entry
);
1077 mutability
= CACHED_MUTABILITY (entry
);
1078 if (scm_is_eq (mutability
, MUTABLE
))
1081 if (scm_is_eq (mutability
, UNKNOWN
))
1083 SCM source_env
= CACHED_SOURCE_ENVIRONMENT (entry
);
1084 SCM location
= SCM_ENVIRONMENT_CELL (source_env
, sym
, 1);
1086 if (scm_is_pair (location
))
1088 SET_CACHED_MUTABILITY (entry
, MUTABLE
);
1091 else /* IMMUTABLE */
1093 SET_CACHED_MUTABILITY (entry
, IMMUTABLE
);
1102 /* The obarray entry is an environment */
1109 /* There is no entry for the symbol in the obarray. This can either
1110 * mean that there has not been a request for the symbol yet, or that
1111 * the symbol is really undefined. We are looking for the symbol in
1112 * both the local and the imported environment. If we find a binding, a
1113 * cached entry is created.
1116 struct eval_environment
*body
= EVAL_ENVIRONMENT (env
);
1117 unsigned int handling_import
;
1119 for (handling_import
= 0; handling_import
<= 1; ++handling_import
)
1121 SCM source_env
= handling_import
? body
->imported
: body
->local
;
1122 SCM location
= SCM_ENVIRONMENT_CELL (source_env
, sym
, for_write
);
1124 if (!SCM_UNBNDP (location
))
1126 if (scm_is_pair (location
))
1128 SCM mutability
= for_write
? MUTABLE
: UNKNOWN
;
1129 SCM entry
= scm_cons2 (location
, mutability
, source_env
);
1130 obarray_enter (obarray
, sym
, entry
);
1133 else if (scm_is_eq (location
, SCM_ENVIRONMENT_LOCATION_NO_CELL
))
1135 obarray_enter (obarray
, sym
, source_env
);
1145 return SCM_UNDEFINED
;
1151 eval_environment_ref (SCM env
, SCM sym
)
1152 #define FUNC_NAME "eval_environment_ref"
1154 SCM location
= eval_environment_lookup (env
, sym
, 0);
1156 if (scm_is_pair (location
))
1157 return SCM_CDR (location
);
1158 else if (!SCM_UNBNDP (location
))
1159 return SCM_ENVIRONMENT_REF (location
, sym
);
1161 return SCM_UNDEFINED
;
1167 eval_environment_folder (SCM extended_data
, SCM symbol
, SCM value
, SCM tail
)
1169 SCM local
= SCM_CAR (extended_data
);
1171 if (!SCM_ENVIRONMENT_BOUND_P (local
, symbol
))
1173 SCM proc_as_nr
= SCM_CADR (extended_data
);
1174 unsigned long int proc_as_ul
= scm_to_ulong (proc_as_nr
);
1175 scm_environment_folder proc
= (scm_environment_folder
) proc_as_ul
;
1176 SCM data
= SCM_CDDR (extended_data
);
1178 return (*proc
) (data
, symbol
, value
, tail
);
1188 eval_environment_fold (SCM env
, scm_environment_folder proc
, SCM data
, SCM init
)
1190 SCM local
= EVAL_ENVIRONMENT (env
)->local
;
1191 SCM imported
= EVAL_ENVIRONMENT (env
)->imported
;
1192 SCM proc_as_nr
= scm_from_ulong ((unsigned long) proc
);
1193 SCM extended_data
= scm_cons2 (local
, proc_as_nr
, data
);
1194 SCM tmp_result
= scm_c_environment_fold (imported
, eval_environment_folder
, extended_data
, init
);
1196 return scm_c_environment_fold (local
, proc
, data
, tmp_result
);
1201 eval_environment_define (SCM env
, SCM sym
, SCM val
)
1202 #define FUNC_NAME "eval_environment_define"
1204 SCM local
= EVAL_ENVIRONMENT (env
)->local
;
1205 return SCM_ENVIRONMENT_DEFINE (local
, sym
, val
);
1211 eval_environment_undefine (SCM env
, SCM sym
)
1212 #define FUNC_NAME "eval_environment_undefine"
1214 SCM local
= EVAL_ENVIRONMENT (env
)->local
;
1215 return SCM_ENVIRONMENT_UNDEFINE (local
, sym
);
1221 eval_environment_set_x (SCM env
, SCM sym
, SCM val
)
1222 #define FUNC_NAME "eval_environment_set_x"
1224 SCM location
= eval_environment_lookup (env
, sym
, 1);
1226 if (scm_is_pair (location
))
1228 SCM_SETCDR (location
, val
);
1229 return SCM_ENVIRONMENT_SUCCESS
;
1231 else if (SCM_ENVIRONMENT_P (location
))
1233 return SCM_ENVIRONMENT_SET (location
, sym
, val
);
1235 else if (scm_is_eq (location
, IMMUTABLE
))
1237 return SCM_ENVIRONMENT_LOCATION_IMMUTABLE
;
1241 return SCM_UNDEFINED
;
1248 eval_environment_cell (SCM env
, SCM sym
, int for_write
)
1249 #define FUNC_NAME "eval_environment_cell"
1251 SCM location
= eval_environment_lookup (env
, sym
, for_write
);
1253 if (scm_is_pair (location
))
1255 else if (SCM_ENVIRONMENT_P (location
))
1256 return SCM_ENVIRONMENT_LOCATION_NO_CELL
;
1257 else if (scm_is_eq (location
, IMMUTABLE
))
1258 return SCM_ENVIRONMENT_LOCATION_IMMUTABLE
;
1260 return SCM_UNDEFINED
;
1267 eval_environment_print (SCM type
, SCM port
, scm_print_state
*pstate SCM_UNUSED
)
1269 SCM address
= scm_from_size_t (SCM_UNPACK (type
));
1270 SCM base16
= scm_number_to_string (address
, scm_from_int (16));
1272 scm_puts ("#<eval environment ", port
);
1273 scm_display (base16
, port
);
1274 scm_puts (">", port
);
1280 static struct scm_environment_funcs eval_environment_funcs
= {
1281 eval_environment_ref
,
1282 eval_environment_fold
,
1283 eval_environment_define
,
1284 eval_environment_undefine
,
1285 eval_environment_set_x
,
1286 eval_environment_cell
,
1287 core_environments_observe
,
1288 core_environments_unobserve
,
1289 eval_environment_print
1293 void *scm_type_eval_environment
= &eval_environment_funcs
;
1297 eval_environment_observer (SCM caller SCM_UNUSED
, SCM eval_env
)
1299 SCM obarray
= EVAL_ENVIRONMENT (eval_env
)->obarray
;
1301 obarray_remove_all (obarray
);
1302 core_environments_broadcast (eval_env
);
1306 SCM_DEFINE (scm_make_eval_environment
, "make-eval-environment", 2, 0, 0,
1307 (SCM local
, SCM imported
),
1308 "Return a new environment object eval whose bindings are the\n"
1309 "union of the bindings in the environments @var{local} and\n"
1310 "@var{imported}, with bindings from @var{local} taking\n"
1311 "precedence. Definitions made in eval are placed in @var{local}.\n"
1312 "Applying @code{environment-define} or\n"
1313 "@code{environment-undefine} to eval has the same effect as\n"
1314 "applying the procedure to @var{local}.\n"
1315 "Note that eval incorporates @var{local} and @var{imported} by\n"
1317 "If, after creating eval, the program changes the bindings of\n"
1318 "@var{local} or @var{imported}, those changes will be visible\n"
1320 "Since most Scheme evaluation takes place in eval environments,\n"
1321 "they transparently cache the bindings received from @var{local}\n"
1322 "and @var{imported}. Thus, the first time the program looks up\n"
1323 "a symbol in eval, eval may make calls to @var{local} or\n"
1324 "@var{imported} to find their bindings, but subsequent\n"
1325 "references to that symbol will be as fast as references to\n"
1326 "bindings in finite environments.\n"
1327 "In typical use, @var{local} will be a finite environment, and\n"
1328 "@var{imported} will be an import environment")
1329 #define FUNC_NAME s_scm_make_eval_environment
1332 struct eval_environment
*body
;
1334 SCM_ASSERT (SCM_ENVIRONMENT_P (local
), local
, SCM_ARG1
, FUNC_NAME
);
1335 SCM_ASSERT (SCM_ENVIRONMENT_P (imported
), imported
, SCM_ARG2
, FUNC_NAME
);
1337 body
= scm_gc_malloc (sizeof (struct eval_environment
), "eval environment");
1339 core_environments_preinit (&body
->base
);
1340 body
->obarray
= SCM_BOOL_F
;
1341 body
->imported
= SCM_BOOL_F
;
1342 body
->imported_observer
= SCM_BOOL_F
;
1343 body
->local
= SCM_BOOL_F
;
1344 body
->local_observer
= SCM_BOOL_F
;
1346 env
= scm_make_environment (body
);
1348 core_environments_init (&body
->base
, &eval_environment_funcs
);
1349 body
->obarray
= scm_c_make_hash_table (DEFAULT_OBARRAY_SIZE
);
1350 body
->imported
= imported
;
1351 body
->imported_observer
1352 = SCM_ENVIRONMENT_OBSERVE (imported
, eval_environment_observer
, env
, 1);
1353 body
->local
= local
;
1354 body
->local_observer
1355 = SCM_ENVIRONMENT_OBSERVE (local
, eval_environment_observer
, env
, 1);
1362 SCM_DEFINE (scm_eval_environment_p
, "eval-environment?", 1, 0, 0,
1364 "Return @code{#t} if object is an eval environment, or @code{#f}\n"
1366 #define FUNC_NAME s_scm_eval_environment_p
1368 return scm_from_bool (SCM_EVAL_ENVIRONMENT_P (object
));
1373 SCM_DEFINE (scm_eval_environment_local
, "eval-environment-local", 1, 0, 0,
1375 "Return the local environment of eval environment @var{env}.")
1376 #define FUNC_NAME s_scm_eval_environment_local
1378 SCM_ASSERT (SCM_EVAL_ENVIRONMENT_P (env
), env
, SCM_ARG1
, FUNC_NAME
);
1380 return EVAL_ENVIRONMENT (env
)->local
;
1385 SCM_DEFINE (scm_eval_environment_set_local_x
, "eval-environment-set-local!", 2, 0, 0,
1386 (SCM env
, SCM local
),
1387 "Change @var{env}'s local environment to @var{local}.")
1388 #define FUNC_NAME s_scm_eval_environment_set_local_x
1390 struct eval_environment
*body
;
1392 SCM_ASSERT (SCM_EVAL_ENVIRONMENT_P (env
), env
, SCM_ARG1
, FUNC_NAME
);
1393 SCM_ASSERT (SCM_ENVIRONMENT_P (local
), local
, SCM_ARG2
, FUNC_NAME
);
1395 body
= EVAL_ENVIRONMENT (env
);
1397 obarray_remove_all (body
->obarray
);
1398 SCM_ENVIRONMENT_UNOBSERVE (body
->local
, body
->local_observer
);
1400 body
->local
= local
;
1401 body
->local_observer
1402 = SCM_ENVIRONMENT_OBSERVE (local
, eval_environment_observer
, env
, 1);
1404 core_environments_broadcast (env
);
1406 return SCM_UNSPECIFIED
;
1411 SCM_DEFINE (scm_eval_environment_imported
, "eval-environment-imported", 1, 0, 0,
1413 "Return the imported environment of eval environment @var{env}.")
1414 #define FUNC_NAME s_scm_eval_environment_imported
1416 SCM_ASSERT (SCM_EVAL_ENVIRONMENT_P (env
), env
, SCM_ARG1
, FUNC_NAME
);
1418 return EVAL_ENVIRONMENT (env
)->imported
;
1423 SCM_DEFINE (scm_eval_environment_set_imported_x
, "eval-environment-set-imported!", 2, 0, 0,
1424 (SCM env
, SCM imported
),
1425 "Change @var{env}'s imported environment to @var{imported}.")
1426 #define FUNC_NAME s_scm_eval_environment_set_imported_x
1428 struct eval_environment
*body
;
1430 SCM_ASSERT (SCM_EVAL_ENVIRONMENT_P (env
), env
, SCM_ARG1
, FUNC_NAME
);
1431 SCM_ASSERT (SCM_ENVIRONMENT_P (imported
), imported
, SCM_ARG2
, FUNC_NAME
);
1433 body
= EVAL_ENVIRONMENT (env
);
1435 obarray_remove_all (body
->obarray
);
1436 SCM_ENVIRONMENT_UNOBSERVE (body
->imported
, body
->imported_observer
);
1438 body
->imported
= imported
;
1439 body
->imported_observer
1440 = SCM_ENVIRONMENT_OBSERVE (imported
, eval_environment_observer
, env
, 1);
1442 core_environments_broadcast (env
);
1444 return SCM_UNSPECIFIED
;
1450 /* import environments
1452 * An import environment combines the bindings of a set of argument
1453 * environments, and checks for naming clashes.
1455 * Implementation: The import environment does no caching at all. For every
1456 * access, the list of imported environments is scanned.
1460 struct import_environment
{
1461 struct core_environments_base base
;
1464 SCM import_observers
;
1470 #define IMPORT_ENVIRONMENT(env) \
1471 ((struct import_environment *) SCM_CELL_WORD_1 (env))
1475 /* Lookup will report one of the following distinct results:
1476 * a) <environment> if only environment binds the symbol.
1477 * b) (env-1 env-2 ...) for conflicting bindings in env-1, ...
1478 * c) SCM_UNDEFINED if there is no binding for the symbol.
1481 import_environment_lookup (SCM env
, SCM sym
)
1483 SCM imports
= IMPORT_ENVIRONMENT (env
)->imports
;
1484 SCM result
= SCM_UNDEFINED
;
1487 for (l
= imports
; !scm_is_null (l
); l
= SCM_CDR (l
))
1489 SCM imported
= SCM_CAR (l
);
1491 if (SCM_ENVIRONMENT_BOUND_P (imported
, sym
))
1493 if (SCM_UNBNDP (result
))
1495 else if (scm_is_pair (result
))
1496 result
= scm_cons (imported
, result
);
1498 result
= scm_cons2 (imported
, result
, SCM_EOL
);
1502 if (scm_is_pair (result
))
1503 return scm_reverse (result
);
1510 import_environment_conflict (SCM env
, SCM sym
, SCM imports
)
1512 SCM conflict_proc
= IMPORT_ENVIRONMENT (env
)->conflict_proc
;
1513 SCM args
= scm_cons2 (env
, sym
, scm_cons (imports
, SCM_EOL
));
1515 return scm_apply_0 (conflict_proc
, args
);
1520 import_environment_ref (SCM env
, SCM sym
)
1521 #define FUNC_NAME "import_environment_ref"
1523 SCM owner
= import_environment_lookup (env
, sym
);
1525 if (SCM_UNBNDP (owner
))
1527 return SCM_UNDEFINED
;
1529 else if (scm_is_pair (owner
))
1531 SCM resolve
= import_environment_conflict (env
, sym
, owner
);
1533 if (SCM_ENVIRONMENT_P (resolve
))
1534 return SCM_ENVIRONMENT_REF (resolve
, sym
);
1536 return SCM_UNSPECIFIED
;
1540 return SCM_ENVIRONMENT_REF (owner
, sym
);
1547 import_environment_folder (SCM extended_data
, SCM symbol
, SCM value
, SCM tail
)
1548 #define FUNC_NAME "import_environment_fold"
1550 SCM import_env
= SCM_CAR (extended_data
);
1551 SCM imported_env
= SCM_CADR (extended_data
);
1552 SCM owner
= import_environment_lookup (import_env
, symbol
);
1553 SCM proc_as_nr
= SCM_CADDR (extended_data
);
1554 unsigned long int proc_as_ul
= scm_to_ulong (proc_as_nr
);
1555 scm_environment_folder proc
= (scm_environment_folder
) proc_as_ul
;
1556 SCM data
= SCM_CDDDR (extended_data
);
1558 if (scm_is_pair (owner
) && scm_is_eq (SCM_CAR (owner
), imported_env
))
1559 owner
= import_environment_conflict (import_env
, symbol
, owner
);
1561 if (SCM_ENVIRONMENT_P (owner
))
1562 return (*proc
) (data
, symbol
, value
, tail
);
1563 else /* unresolved conflict */
1564 return (*proc
) (data
, symbol
, SCM_UNSPECIFIED
, tail
);
1570 import_environment_fold (SCM env
, scm_environment_folder proc
, SCM data
, SCM init
)
1572 SCM proc_as_nr
= scm_from_ulong ((unsigned long) proc
);
1576 for (l
= IMPORT_ENVIRONMENT (env
)->imports
; !scm_is_null (l
); l
= SCM_CDR (l
))
1578 SCM imported_env
= SCM_CAR (l
);
1579 SCM extended_data
= scm_cons (env
, scm_cons2 (imported_env
, proc_as_nr
, data
));
1581 result
= scm_c_environment_fold (imported_env
, import_environment_folder
, extended_data
, result
);
1589 import_environment_define (SCM env SCM_UNUSED
,
1592 #define FUNC_NAME "import_environment_define"
1594 return SCM_ENVIRONMENT_BINDING_IMMUTABLE
;
1600 import_environment_undefine (SCM env SCM_UNUSED
,
1602 #define FUNC_NAME "import_environment_undefine"
1604 return SCM_ENVIRONMENT_BINDING_IMMUTABLE
;
1610 import_environment_set_x (SCM env
, SCM sym
, SCM val
)
1611 #define FUNC_NAME "import_environment_set_x"
1613 SCM owner
= import_environment_lookup (env
, sym
);
1615 if (SCM_UNBNDP (owner
))
1617 return SCM_UNDEFINED
;
1619 else if (scm_is_pair (owner
))
1621 SCM resolve
= import_environment_conflict (env
, sym
, owner
);
1623 if (SCM_ENVIRONMENT_P (resolve
))
1624 return SCM_ENVIRONMENT_SET (resolve
, sym
, val
);
1626 return SCM_ENVIRONMENT_LOCATION_IMMUTABLE
;
1630 return SCM_ENVIRONMENT_SET (owner
, sym
, val
);
1637 import_environment_cell (SCM env
, SCM sym
, int for_write
)
1638 #define FUNC_NAME "import_environment_cell"
1640 SCM owner
= import_environment_lookup (env
, sym
);
1642 if (SCM_UNBNDP (owner
))
1644 return SCM_UNDEFINED
;
1646 else if (scm_is_pair (owner
))
1648 SCM resolve
= import_environment_conflict (env
, sym
, owner
);
1650 if (SCM_ENVIRONMENT_P (resolve
))
1651 return SCM_ENVIRONMENT_CELL (resolve
, sym
, for_write
);
1653 return SCM_ENVIRONMENT_LOCATION_NO_CELL
;
1657 return SCM_ENVIRONMENT_CELL (owner
, sym
, for_write
);
1665 import_environment_print (SCM type
, SCM port
,
1666 scm_print_state
*pstate SCM_UNUSED
)
1668 SCM address
= scm_from_size_t (SCM_UNPACK (type
));
1669 SCM base16
= scm_number_to_string (address
, scm_from_int (16));
1671 scm_puts ("#<import environment ", port
);
1672 scm_display (base16
, port
);
1673 scm_puts (">", port
);
1679 static struct scm_environment_funcs import_environment_funcs
= {
1680 import_environment_ref
,
1681 import_environment_fold
,
1682 import_environment_define
,
1683 import_environment_undefine
,
1684 import_environment_set_x
,
1685 import_environment_cell
,
1686 core_environments_observe
,
1687 core_environments_unobserve
,
1688 import_environment_print
1692 void *scm_type_import_environment
= &import_environment_funcs
;
1696 import_environment_observer (SCM caller SCM_UNUSED
, SCM import_env
)
1698 core_environments_broadcast (import_env
);
1702 SCM_DEFINE (scm_make_import_environment
, "make-import-environment", 2, 0, 0,
1703 (SCM imports
, SCM conflict_proc
),
1704 "Return a new environment @var{imp} whose bindings are the union\n"
1705 "of the bindings from the environments in @var{imports};\n"
1706 "@var{imports} must be a list of environments. That is,\n"
1707 "@var{imp} binds a symbol to a location when some element of\n"
1708 "@var{imports} does.\n"
1709 "If two different elements of @var{imports} have a binding for\n"
1710 "the same symbol, the @var{conflict-proc} is called with the\n"
1711 "following parameters: the import environment, the symbol and\n"
1712 "the list of the imported environments that bind the symbol.\n"
1713 "If the @var{conflict-proc} returns an environment @var{env},\n"
1714 "the conflict is considered as resolved and the binding from\n"
1715 "@var{env} is used. If the @var{conflict-proc} returns some\n"
1716 "non-environment object, the conflict is considered unresolved\n"
1717 "and the symbol is treated as unspecified in the import\n"
1719 "The checking for conflicts may be performed lazily, i. e. at\n"
1720 "the moment when a value or binding for a certain symbol is\n"
1721 "requested instead of the moment when the environment is\n"
1722 "created or the bindings of the imports change.\n"
1723 "All bindings in @var{imp} are immutable. If you apply\n"
1724 "@code{environment-define} or @code{environment-undefine} to\n"
1725 "@var{imp}, Guile will signal an\n"
1726 " @code{environment:immutable-binding} error. However,\n"
1727 "notice that the set of bindings in @var{imp} may still change,\n"
1728 "if one of its imported environments changes.")
1729 #define FUNC_NAME s_scm_make_import_environment
1731 size_t size
= sizeof (struct import_environment
);
1732 struct import_environment
*body
= scm_gc_malloc (size
, "import environment");
1735 core_environments_preinit (&body
->base
);
1736 body
->imports
= SCM_BOOL_F
;
1737 body
->import_observers
= SCM_BOOL_F
;
1738 body
->conflict_proc
= SCM_BOOL_F
;
1740 env
= scm_make_environment (body
);
1742 core_environments_init (&body
->base
, &import_environment_funcs
);
1743 body
->imports
= SCM_EOL
;
1744 body
->import_observers
= SCM_EOL
;
1745 body
->conflict_proc
= conflict_proc
;
1747 scm_import_environment_set_imports_x (env
, imports
);
1754 SCM_DEFINE (scm_import_environment_p
, "import-environment?", 1, 0, 0,
1756 "Return @code{#t} if object is an import environment, or\n"
1757 "@code{#f} otherwise.")
1758 #define FUNC_NAME s_scm_import_environment_p
1760 return scm_from_bool (SCM_IMPORT_ENVIRONMENT_P (object
));
1765 SCM_DEFINE (scm_import_environment_imports
, "import-environment-imports", 1, 0, 0,
1767 "Return the list of environments imported by the import\n"
1768 "environment @var{env}.")
1769 #define FUNC_NAME s_scm_import_environment_imports
1771 SCM_ASSERT (SCM_IMPORT_ENVIRONMENT_P (env
), env
, SCM_ARG1
, FUNC_NAME
);
1773 return IMPORT_ENVIRONMENT (env
)->imports
;
1778 SCM_DEFINE (scm_import_environment_set_imports_x
, "import-environment-set-imports!", 2, 0, 0,
1779 (SCM env
, SCM imports
),
1780 "Change @var{env}'s list of imported environments to\n"
1781 "@var{imports}, and check for conflicts.")
1782 #define FUNC_NAME s_scm_import_environment_set_imports_x
1784 struct import_environment
*body
= IMPORT_ENVIRONMENT (env
);
1785 SCM import_observers
= SCM_EOL
;
1788 SCM_ASSERT (SCM_IMPORT_ENVIRONMENT_P (env
), env
, SCM_ARG1
, FUNC_NAME
);
1789 for (l
= imports
; scm_is_pair (l
); l
= SCM_CDR (l
))
1791 SCM obj
= SCM_CAR (l
);
1792 SCM_ASSERT (SCM_ENVIRONMENT_P (obj
), imports
, SCM_ARG2
, FUNC_NAME
);
1794 SCM_ASSERT (scm_is_null (l
), imports
, SCM_ARG2
, FUNC_NAME
);
1796 for (l
= body
->import_observers
; !scm_is_null (l
); l
= SCM_CDR (l
))
1798 SCM obs
= SCM_CAR (l
);
1799 SCM_ENVIRONMENT_UNOBSERVE (env
, obs
);
1802 for (l
= imports
; !scm_is_null (l
); l
= SCM_CDR (l
))
1804 SCM imp
= SCM_CAR (l
);
1805 SCM obs
= SCM_ENVIRONMENT_OBSERVE (imp
, import_environment_observer
, env
, 1);
1806 import_observers
= scm_cons (obs
, import_observers
);
1809 body
->imports
= imports
;
1810 body
->import_observers
= import_observers
;
1812 return SCM_UNSPECIFIED
;
1818 /* export environments
1820 * An export environment restricts an environment to a specified set of
1823 * Implementation: The export environment does no caching at all. For every
1824 * access, the signature is scanned. The signature that is stored internally
1825 * is an alist of pairs (symbol . (mutability)).
1829 struct export_environment
{
1830 struct core_environments_base base
;
1833 SCM private_observer
;
1839 #define EXPORT_ENVIRONMENT(env) \
1840 ((struct export_environment *) SCM_CELL_WORD_1 (env))
1843 SCM_SYMBOL (symbol_immutable_location
, "immutable-location");
1844 SCM_SYMBOL (symbol_mutable_location
, "mutable-location");
1849 export_environment_ref (SCM env
, SCM sym
)
1850 #define FUNC_NAME "export_environment_ref"
1852 struct export_environment
*body
= EXPORT_ENVIRONMENT (env
);
1853 SCM entry
= scm_assq (sym
, body
->signature
);
1855 if (scm_is_false (entry
))
1856 return SCM_UNDEFINED
;
1858 return SCM_ENVIRONMENT_REF (body
->private, sym
);
1864 export_environment_fold (SCM env
, scm_environment_folder proc
, SCM data
, SCM init
)
1866 struct export_environment
*body
= EXPORT_ENVIRONMENT (env
);
1870 for (l
= body
->signature
; !scm_is_null (l
); l
= SCM_CDR (l
))
1872 SCM symbol
= SCM_CAR (l
);
1873 SCM value
= SCM_ENVIRONMENT_REF (body
->private, symbol
);
1874 if (!SCM_UNBNDP (value
))
1875 result
= (*proc
) (data
, symbol
, value
, result
);
1882 export_environment_define (SCM env SCM_UNUSED
,
1885 #define FUNC_NAME "export_environment_define"
1887 return SCM_ENVIRONMENT_BINDING_IMMUTABLE
;
1893 export_environment_undefine (SCM env SCM_UNUSED
, SCM sym SCM_UNUSED
)
1894 #define FUNC_NAME "export_environment_undefine"
1896 return SCM_ENVIRONMENT_BINDING_IMMUTABLE
;
1902 export_environment_set_x (SCM env
, SCM sym
, SCM val
)
1903 #define FUNC_NAME "export_environment_set_x"
1905 struct export_environment
*body
= EXPORT_ENVIRONMENT (env
);
1906 SCM entry
= scm_assq (sym
, body
->signature
);
1908 if (scm_is_false (entry
))
1910 return SCM_UNDEFINED
;
1914 if (scm_is_eq (SCM_CADR (entry
), symbol_mutable_location
))
1915 return SCM_ENVIRONMENT_SET (body
->private, sym
, val
);
1917 return SCM_ENVIRONMENT_LOCATION_IMMUTABLE
;
1924 export_environment_cell (SCM env
, SCM sym
, int for_write
)
1925 #define FUNC_NAME "export_environment_cell"
1927 struct export_environment
*body
= EXPORT_ENVIRONMENT (env
);
1928 SCM entry
= scm_assq (sym
, body
->signature
);
1930 if (scm_is_false (entry
))
1932 return SCM_UNDEFINED
;
1936 if (!for_write
|| scm_is_eq (SCM_CADR (entry
), symbol_mutable_location
))
1937 return SCM_ENVIRONMENT_CELL (body
->private, sym
, for_write
);
1939 return SCM_ENVIRONMENT_LOCATION_IMMUTABLE
;
1947 export_environment_print (SCM type
, SCM port
,
1948 scm_print_state
*pstate SCM_UNUSED
)
1950 SCM address
= scm_from_size_t (SCM_UNPACK (type
));
1951 SCM base16
= scm_number_to_string (address
, scm_from_int (16));
1953 scm_puts ("#<export environment ", port
);
1954 scm_display (base16
, port
);
1955 scm_puts (">", port
);
1961 static struct scm_environment_funcs export_environment_funcs
= {
1962 export_environment_ref
,
1963 export_environment_fold
,
1964 export_environment_define
,
1965 export_environment_undefine
,
1966 export_environment_set_x
,
1967 export_environment_cell
,
1968 core_environments_observe
,
1969 core_environments_unobserve
,
1970 export_environment_print
1974 void *scm_type_export_environment
= &export_environment_funcs
;
1978 export_environment_observer (SCM caller SCM_UNUSED
, SCM export_env
)
1980 core_environments_broadcast (export_env
);
1984 SCM_DEFINE (scm_make_export_environment
, "make-export-environment", 2, 0, 0,
1985 (SCM
private, SCM signature
),
1986 "Return a new environment @var{exp} containing only those\n"
1987 "bindings in private whose symbols are present in\n"
1988 "@var{signature}. The @var{private} argument must be an\n"
1990 "The environment @var{exp} binds symbol to location when\n"
1991 "@var{env} does, and symbol is exported by @var{signature}.\n\n"
1992 "@var{signature} is a list specifying which of the bindings in\n"
1993 "@var{private} should be visible in @var{exp}. Each element of\n"
1994 "@var{signature} should be a list of the form:\n"
1995 " (symbol attribute ...)\n"
1996 "where each attribute is one of the following:\n"
1998 "@item the symbol @code{mutable-location}\n"
1999 " @var{exp} should treat the\n"
2000 " location bound to symbol as mutable. That is, @var{exp}\n"
2001 " will pass calls to @code{environment-set!} or\n"
2002 " @code{environment-cell} directly through to private.\n"
2003 "@item the symbol @code{immutable-location}\n"
2004 " @var{exp} should treat\n"
2005 " the location bound to symbol as immutable. If the program\n"
2006 " applies @code{environment-set!} to @var{exp} and symbol, or\n"
2007 " calls @code{environment-cell} to obtain a writable value\n"
2008 " cell, @code{environment-set!} will signal an\n"
2009 " @code{environment:immutable-location} error. Note that, even\n"
2010 " if an export environment treats a location as immutable, the\n"
2011 " underlying environment may treat it as mutable, so its\n"
2012 " value may change.\n"
2014 "It is an error for an element of signature to specify both\n"
2015 "@code{mutable-location} and @code{immutable-location}. If\n"
2016 "neither is specified, @code{immutable-location} is assumed.\n\n"
2017 "As a special case, if an element of signature is a lone\n"
2018 "symbol @var{sym}, it is equivalent to an element of the form\n"
2020 "All bindings in @var{exp} are immutable. If you apply\n"
2021 "@code{environment-define} or @code{environment-undefine} to\n"
2022 "@var{exp}, Guile will signal an\n"
2023 "@code{environment:immutable-binding} error. However,\n"
2024 "notice that the set of bindings in @var{exp} may still change,\n"
2025 "if the bindings in private change.")
2026 #define FUNC_NAME s_scm_make_export_environment
2029 struct export_environment
*body
;
2032 SCM_ASSERT (SCM_ENVIRONMENT_P (private), private, SCM_ARG1
, FUNC_NAME
);
2034 size
= sizeof (struct export_environment
);
2035 body
= scm_gc_malloc (size
, "export environment");
2037 core_environments_preinit (&body
->base
);
2038 body
->private = SCM_BOOL_F
;
2039 body
->private_observer
= SCM_BOOL_F
;
2040 body
->signature
= SCM_BOOL_F
;
2042 env
= scm_make_environment (body
);
2044 core_environments_init (&body
->base
, &export_environment_funcs
);
2045 body
->private = private;
2046 body
->private_observer
2047 = SCM_ENVIRONMENT_OBSERVE (private, export_environment_observer
, env
, 1);
2048 body
->signature
= SCM_EOL
;
2050 scm_export_environment_set_signature_x (env
, signature
);
2057 SCM_DEFINE (scm_export_environment_p
, "export-environment?", 1, 0, 0,
2059 "Return @code{#t} if object is an export environment, or\n"
2060 "@code{#f} otherwise.")
2061 #define FUNC_NAME s_scm_export_environment_p
2063 return scm_from_bool (SCM_EXPORT_ENVIRONMENT_P (object
));
2068 SCM_DEFINE (scm_export_environment_private
, "export-environment-private", 1, 0, 0,
2070 "Return the private environment of export environment @var{env}.")
2071 #define FUNC_NAME s_scm_export_environment_private
2073 SCM_ASSERT (SCM_EXPORT_ENVIRONMENT_P (env
), env
, SCM_ARG1
, FUNC_NAME
);
2075 return EXPORT_ENVIRONMENT (env
)->private;
2080 SCM_DEFINE (scm_export_environment_set_private_x
, "export-environment-set-private!", 2, 0, 0,
2081 (SCM env
, SCM
private),
2082 "Change the private environment of export environment @var{env}.")
2083 #define FUNC_NAME s_scm_export_environment_set_private_x
2085 struct export_environment
*body
;
2087 SCM_ASSERT (SCM_EXPORT_ENVIRONMENT_P (env
), env
, SCM_ARG1
, FUNC_NAME
);
2088 SCM_ASSERT (SCM_ENVIRONMENT_P (private), private, SCM_ARG2
, FUNC_NAME
);
2090 body
= EXPORT_ENVIRONMENT (env
);
2091 SCM_ENVIRONMENT_UNOBSERVE (private, body
->private_observer
);
2093 body
->private = private;
2094 body
->private_observer
2095 = SCM_ENVIRONMENT_OBSERVE (private, export_environment_observer
, env
, 1);
2097 return SCM_UNSPECIFIED
;
2102 SCM_DEFINE (scm_export_environment_signature
, "export-environment-signature", 1, 0, 0,
2104 "Return the signature of export environment @var{env}.")
2105 #define FUNC_NAME s_scm_export_environment_signature
2107 SCM_ASSERT (SCM_EXPORT_ENVIRONMENT_P (env
), env
, SCM_ARG1
, FUNC_NAME
);
2109 return EXPORT_ENVIRONMENT (env
)->signature
;
2115 export_environment_parse_signature (SCM signature
, const char* caller
)
2117 SCM result
= SCM_EOL
;
2120 for (l
= signature
; scm_is_pair (l
); l
= SCM_CDR (l
))
2122 SCM entry
= SCM_CAR (l
);
2124 if (scm_is_symbol (entry
))
2126 SCM new_entry
= scm_cons2 (entry
, symbol_immutable_location
, SCM_EOL
);
2127 result
= scm_cons (new_entry
, result
);
2138 SCM_ASSERT (scm_is_pair (entry
), entry
, SCM_ARGn
, caller
);
2139 SCM_ASSERT (scm_is_symbol (SCM_CAR (entry
)), entry
, SCM_ARGn
, caller
);
2141 sym
= SCM_CAR (entry
);
2143 for (l2
= SCM_CDR (entry
); scm_is_pair (l2
); l2
= SCM_CDR (l2
))
2145 SCM attribute
= SCM_CAR (l2
);
2146 if (scm_is_eq (attribute
, symbol_immutable_location
))
2148 else if (scm_is_eq (attribute
, symbol_mutable_location
))
2151 SCM_ASSERT (0, entry
, SCM_ARGn
, caller
);
2153 SCM_ASSERT (scm_is_null (l2
), entry
, SCM_ARGn
, caller
);
2154 SCM_ASSERT (!mutable || !immutable
, entry
, SCM_ARGn
, caller
);
2156 if (!mutable && !immutable
)
2159 mutability
= mutable ? symbol_mutable_location
: symbol_immutable_location
;
2160 new_entry
= scm_cons2 (sym
, mutability
, SCM_EOL
);
2161 result
= scm_cons (new_entry
, result
);
2164 SCM_ASSERT (scm_is_null (l
), signature
, SCM_ARGn
, caller
);
2166 /* Dirk:FIXME:: Now we know that signature is syntactically correct. There
2167 * are, however, no checks for symbols entered twice with contradicting
2168 * mutabilities. It would be nice, to implement this test, to be able to
2169 * call the sort functions conveniently from C.
2172 return scm_reverse (result
);
2176 SCM_DEFINE (scm_export_environment_set_signature_x
, "export-environment-set-signature!", 2, 0, 0,
2177 (SCM env
, SCM signature
),
2178 "Change the signature of export environment @var{env}.")
2179 #define FUNC_NAME s_scm_export_environment_set_signature_x
2183 SCM_ASSERT (SCM_EXPORT_ENVIRONMENT_P (env
), env
, SCM_ARG1
, FUNC_NAME
);
2184 parsed_sig
= export_environment_parse_signature (signature
, FUNC_NAME
);
2186 EXPORT_ENVIRONMENT (env
)->signature
= parsed_sig
;
2188 return SCM_UNSPECIFIED
;
2195 scm_environments_prehistory ()
2197 /* create environment smob */
2198 scm_tc16_environment
= scm_make_smob_type ("environment", 0);
2199 scm_set_smob_print (scm_tc16_environment
, environment_print
);
2201 /* create observer smob */
2202 scm_tc16_observer
= scm_make_smob_type ("observer", 0);
2203 scm_set_smob_print (scm_tc16_observer
, observer_print
);
2205 /* create system environment */
2206 scm_system_environment
= scm_make_leaf_environment ();
2207 scm_permanent_object (scm_system_environment
);
2212 scm_init_environments ()
2214 #include "libguile/environments.x"