1 /* Copyright (C) 1999,2000,2001, 2003 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 return scm_cell (scm_tc16_environment
, (scm_t_bits
) 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
;
447 environment_mark (SCM env
)
449 return (*(SCM_ENVIRONMENT_FUNCS (env
)->mark
)) (env
);
454 environment_free (SCM env
)
456 (*(SCM_ENVIRONMENT_FUNCS (env
)->free
)) (env
);
462 environment_print (SCM env
, SCM port
, scm_print_state
*pstate
)
464 return (*(SCM_ENVIRONMENT_FUNCS (env
)->print
)) (env
, port
, pstate
);
472 observer_mark (SCM observer
)
474 scm_gc_mark (SCM_OBSERVER_ENVIRONMENT (observer
));
475 scm_gc_mark (SCM_OBSERVER_DATA (observer
));
481 observer_print (SCM type
, SCM port
, scm_print_state
*pstate SCM_UNUSED
)
483 SCM address
= scm_from_size_t (SCM_UNPACK (type
));
484 SCM base16
= scm_number_to_string (address
, scm_from_int (16));
486 scm_puts ("#<observer ", port
);
487 scm_display (base16
, port
);
488 scm_puts (">", port
);
497 * Obarrays form the basic lookup tables used to implement most of guile's
498 * built-in environment types. An obarray is implemented as a hash table with
499 * symbols as keys. The content of the data depends on the environment type.
504 * Enter symbol into obarray. The symbol must not already exist in obarray.
505 * The freshly generated (symbol . data) cell is returned.
508 obarray_enter (SCM obarray
, SCM symbol
, SCM data
)
510 size_t hash
= scm_i_symbol_hash (symbol
) % SCM_HASHTABLE_N_BUCKETS (obarray
);
511 SCM entry
= scm_cons (symbol
, data
);
512 SCM slot
= scm_cons (entry
, SCM_HASHTABLE_BUCKET (obarray
, hash
));
513 SCM_SET_HASHTABLE_BUCKET (obarray
, hash
, slot
);
514 SCM_HASHTABLE_INCREMENT (obarray
);
515 if (SCM_HASHTABLE_N_ITEMS (obarray
) > SCM_HASHTABLE_UPPER (obarray
))
516 scm_i_rehash (obarray
, scm_i_hash_symbol
, 0, "obarray_enter");
523 * Enter symbol into obarray. An existing entry for symbol is replaced. If
524 * an entry existed, the old (symbol . data) cell is returned, #f otherwise.
527 obarray_replace (SCM obarray
, SCM symbol
, SCM data
)
529 size_t hash
= scm_i_symbol_hash (symbol
) % SCM_HASHTABLE_N_BUCKETS (obarray
);
530 SCM new_entry
= scm_cons (symbol
, data
);
534 for (lsym
= SCM_HASHTABLE_BUCKET (obarray
, hash
);
536 lsym
= SCM_CDR (lsym
))
538 SCM old_entry
= SCM_CAR (lsym
);
539 if (scm_is_eq (SCM_CAR (old_entry
), symbol
))
541 SCM_SETCAR (lsym
, new_entry
);
546 slot
= scm_cons (new_entry
, SCM_HASHTABLE_BUCKET (obarray
, hash
));
547 SCM_SET_HASHTABLE_BUCKET (obarray
, hash
, slot
);
548 SCM_HASHTABLE_INCREMENT (obarray
);
549 if (SCM_HASHTABLE_N_ITEMS (obarray
) > SCM_HASHTABLE_UPPER (obarray
))
550 scm_i_rehash (obarray
, scm_i_hash_symbol
, 0, "obarray_replace");
557 * Look up symbol in obarray
560 obarray_retrieve (SCM obarray
, SCM sym
)
562 size_t hash
= scm_i_symbol_hash (sym
) % SCM_HASHTABLE_N_BUCKETS (obarray
);
565 for (lsym
= SCM_HASHTABLE_BUCKET (obarray
, hash
);
567 lsym
= SCM_CDR (lsym
))
569 SCM entry
= SCM_CAR (lsym
);
570 if (scm_is_eq (SCM_CAR (entry
), sym
))
574 return SCM_UNDEFINED
;
579 * Remove entry from obarray. If the symbol was found and removed, the old
580 * (symbol . data) cell is returned, #f otherwise.
583 obarray_remove (SCM obarray
, SCM sym
)
585 size_t hash
= scm_i_symbol_hash (sym
) % SCM_HASHTABLE_N_BUCKETS (obarray
);
586 SCM table_entry
= SCM_HASHTABLE_BUCKET (obarray
, hash
);
587 SCM handle
= scm_sloppy_assq (sym
, table_entry
);
589 if (scm_is_pair (handle
))
591 SCM new_table_entry
= scm_delq1_x (handle
, table_entry
);
592 SCM_SET_HASHTABLE_BUCKET (obarray
, hash
, new_table_entry
);
593 SCM_HASHTABLE_DECREMENT (obarray
);
601 obarray_remove_all (SCM obarray
)
603 size_t size
= SCM_HASHTABLE_N_BUCKETS (obarray
);
606 for (i
= 0; i
< size
; i
++)
608 SCM_SET_HASHTABLE_BUCKET (obarray
, i
, SCM_EOL
);
610 SCM_SET_HASHTABLE_N_ITEMS (obarray
, 0);
615 /* core environments base
617 * This struct and the corresponding functions form a base class for guile's
618 * built-in environment types.
622 struct core_environments_base
{
623 struct scm_environment_funcs
*funcs
;
630 #define CORE_ENVIRONMENTS_BASE(env) \
631 ((struct core_environments_base *) SCM_CELL_WORD_1 (env))
632 #define CORE_ENVIRONMENT_OBSERVERS(env) \
633 (CORE_ENVIRONMENTS_BASE (env)->observers)
634 #define SCM_SET_CORE_ENVIRONMENT_OBSERVERS(env, v) \
635 (CORE_ENVIRONMENT_OBSERVERS (env) = (v))
636 #define CORE_ENVIRONMENT_WEAK_OBSERVER_VECTOR(env) \
637 (CORE_ENVIRONMENTS_BASE (env)->weak_observers)
638 #define CORE_ENVIRONMENT_WEAK_OBSERVERS(env) \
639 (scm_c_vector_ref (CORE_ENVIRONMENT_WEAK_OBSERVER_VECTOR (env), 0))
640 #define SCM_SET_CORE_ENVIRONMENT_WEAK_OBSERVERS(env, v) \
641 (scm_c_vector_set_x (CORE_ENVIRONMENT_WEAK_OBSERVER_VECTOR (env), 0, (v)))
646 core_environments_observe (SCM env
, scm_environment_observer proc
, SCM data
, int weak_p
)
648 SCM observer
= scm_double_cell (scm_tc16_observer
,
655 SCM observers
= CORE_ENVIRONMENT_OBSERVERS (env
);
656 SCM new_observers
= scm_cons (observer
, observers
);
657 SCM_SET_CORE_ENVIRONMENT_OBSERVERS (env
, new_observers
);
661 SCM observers
= CORE_ENVIRONMENT_WEAK_OBSERVERS (env
);
662 SCM new_observers
= scm_acons (SCM_BOOL_F
, observer
, observers
);
663 SCM_SET_CORE_ENVIRONMENT_WEAK_OBSERVERS (env
, new_observers
);
671 core_environments_unobserve (SCM env
, SCM observer
)
673 unsigned int handling_weaks
;
674 for (handling_weaks
= 0; handling_weaks
<= 1; ++handling_weaks
)
676 SCM l
= handling_weaks
677 ? CORE_ENVIRONMENT_WEAK_OBSERVERS (env
)
678 : CORE_ENVIRONMENT_OBSERVERS (env
);
680 if (!scm_is_null (l
))
682 SCM rest
= SCM_CDR (l
);
683 SCM first
= handling_weaks
687 if (scm_is_eq (first
, observer
))
689 /* Remove the first observer */
691 ? SCM_SET_CORE_ENVIRONMENT_WEAK_OBSERVERS (env
, rest
)
692 : SCM_SET_CORE_ENVIRONMENT_OBSERVERS (env
, rest
);
697 SCM rest
= SCM_CDR (l
);
699 if (!scm_is_null (rest
))
701 SCM next
= handling_weaks
705 if (scm_is_eq (next
, observer
))
707 SCM_SETCDR (l
, SCM_CDR (rest
));
713 } while (!scm_is_null (l
));
717 /* Dirk:FIXME:: What to do now, since the observer is not found? */
722 core_environments_mark (SCM env
)
724 scm_gc_mark (CORE_ENVIRONMENT_OBSERVERS (env
));
725 return CORE_ENVIRONMENT_WEAK_OBSERVER_VECTOR (env
);
730 core_environments_finalize (SCM env SCM_UNUSED
)
736 core_environments_preinit (struct core_environments_base
*body
)
739 body
->observers
= SCM_BOOL_F
;
740 body
->weak_observers
= SCM_BOOL_F
;
745 core_environments_init (struct core_environments_base
*body
,
746 struct scm_environment_funcs
*funcs
)
749 body
->observers
= SCM_EOL
;
750 body
->weak_observers
= scm_make_weak_value_alist_vector (scm_from_int (1));
754 /* Tell all observers to clear their caches.
756 * Environments have to be informed about changes in the following cases:
757 * - The observed env has a new binding. This must be always reported.
758 * - The observed env has dropped a binding. This must be always reported.
759 * - A binding in the observed environment has changed. This must only be
760 * reported, if there is a chance that the binding is being cached outside.
761 * However, this potential optimization is not performed currently.
763 * Errors that occur while the observers are called are accumulated and
764 * signalled as one single error message to the caller.
775 update_catch_body (void *ptr
)
777 struct update_data
*data
= (struct update_data
*) ptr
;
778 SCM observer
= data
->observer
;
780 (*SCM_OBSERVER_PROC (observer
))
781 (data
->environment
, SCM_OBSERVER_DATA (observer
));
783 return SCM_UNDEFINED
;
788 update_catch_handler (void *ptr
, SCM tag
, SCM args
)
790 struct update_data
*data
= (struct update_data
*) ptr
;
791 SCM observer
= data
->observer
;
793 scm_from_locale_string ("Observer `~A' signals `~A' error: ~S");
795 return scm_cons (message
, scm_list_3 (observer
, tag
, args
));
800 core_environments_broadcast (SCM env
)
801 #define FUNC_NAME "core_environments_broadcast"
803 unsigned int handling_weaks
;
804 SCM errors
= SCM_EOL
;
806 for (handling_weaks
= 0; handling_weaks
<= 1; ++handling_weaks
)
808 SCM observers
= handling_weaks
809 ? CORE_ENVIRONMENT_WEAK_OBSERVERS (env
)
810 : CORE_ENVIRONMENT_OBSERVERS (env
);
812 for (; !scm_is_null (observers
); observers
= SCM_CDR (observers
))
814 struct update_data data
;
815 SCM observer
= handling_weaks
816 ? SCM_CDAR (observers
)
817 : SCM_CAR (observers
);
820 data
.observer
= observer
;
821 data
.environment
= env
;
823 error
= scm_internal_catch (SCM_BOOL_T
,
824 update_catch_body
, &data
,
825 update_catch_handler
, &data
);
827 if (!SCM_UNBNDP (error
))
828 errors
= scm_cons (error
, errors
);
832 if (!scm_is_null (errors
))
834 /* Dirk:FIXME:: As soon as scm_misc_error is fixed to handle the name
835 * parameter correctly it should not be necessary any more to also pass
836 * namestr in order to get the desired information from the error
839 SCM ordered_errors
= scm_reverse (errors
);
842 "Observers of `~A' have signalled the following errors: ~S",
843 scm_cons2 (env
, ordered_errors
, SCM_EOL
));
852 * A leaf environment is simply a mutable set of definitions. A leaf
853 * environment supports no operations beyond the common set.
855 * Implementation: The obarray of the leaf environment holds (symbol . value)
856 * pairs. No further information is necessary, since all bindings and
857 * locations in a leaf environment are mutable.
861 struct leaf_environment
{
862 struct core_environments_base base
;
868 #define LEAF_ENVIRONMENT(env) \
869 ((struct leaf_environment *) SCM_CELL_WORD_1 (env))
874 leaf_environment_ref (SCM env
, SCM sym
)
876 SCM obarray
= LEAF_ENVIRONMENT (env
)->obarray
;
877 SCM binding
= obarray_retrieve (obarray
, sym
);
878 return SCM_UNBNDP (binding
) ? binding
: SCM_CDR (binding
);
883 leaf_environment_fold (SCM env
, scm_environment_folder proc
, SCM data
, SCM init
)
887 SCM obarray
= LEAF_ENVIRONMENT (env
)->obarray
;
889 for (i
= 0; i
< SCM_HASHTABLE_N_BUCKETS (obarray
); i
++)
892 for (l
= SCM_HASHTABLE_BUCKET (obarray
, i
);
896 SCM binding
= SCM_CAR (l
);
897 SCM symbol
= SCM_CAR (binding
);
898 SCM value
= SCM_CDR (binding
);
899 result
= (*proc
) (data
, symbol
, value
, result
);
907 leaf_environment_define (SCM env
, SCM sym
, SCM val
)
908 #define FUNC_NAME "leaf_environment_define"
910 SCM obarray
= LEAF_ENVIRONMENT (env
)->obarray
;
912 obarray_replace (obarray
, sym
, val
);
913 core_environments_broadcast (env
);
915 return SCM_ENVIRONMENT_SUCCESS
;
921 leaf_environment_undefine (SCM env
, SCM sym
)
922 #define FUNC_NAME "leaf_environment_undefine"
924 SCM obarray
= LEAF_ENVIRONMENT (env
)->obarray
;
925 SCM removed
= obarray_remove (obarray
, sym
);
927 if (scm_is_true (removed
))
928 core_environments_broadcast (env
);
930 return SCM_ENVIRONMENT_SUCCESS
;
936 leaf_environment_set_x (SCM env
, SCM sym
, SCM val
)
937 #define FUNC_NAME "leaf_environment_set_x"
939 SCM obarray
= LEAF_ENVIRONMENT (env
)->obarray
;
940 SCM binding
= obarray_retrieve (obarray
, sym
);
942 if (!SCM_UNBNDP (binding
))
944 SCM_SETCDR (binding
, val
);
945 return SCM_ENVIRONMENT_SUCCESS
;
949 return SCM_UNDEFINED
;
956 leaf_environment_cell (SCM env
, SCM sym
, int for_write SCM_UNUSED
)
958 SCM obarray
= LEAF_ENVIRONMENT (env
)->obarray
;
959 SCM binding
= obarray_retrieve (obarray
, sym
);
965 leaf_environment_mark (SCM env
)
967 scm_gc_mark (LEAF_ENVIRONMENT (env
)->obarray
);
968 return core_environments_mark (env
);
973 leaf_environment_free (SCM env
)
975 core_environments_finalize (env
);
976 scm_gc_free (LEAF_ENVIRONMENT (env
), sizeof (struct leaf_environment
),
982 leaf_environment_print (SCM type
, SCM port
, scm_print_state
*pstate SCM_UNUSED
)
984 SCM address
= scm_from_size_t (SCM_UNPACK (type
));
985 SCM base16
= scm_number_to_string (address
, scm_from_int (16));
987 scm_puts ("#<leaf environment ", port
);
988 scm_display (base16
, port
);
989 scm_puts (">", port
);
995 static struct scm_environment_funcs leaf_environment_funcs
= {
996 leaf_environment_ref
,
997 leaf_environment_fold
,
998 leaf_environment_define
,
999 leaf_environment_undefine
,
1000 leaf_environment_set_x
,
1001 leaf_environment_cell
,
1002 core_environments_observe
,
1003 core_environments_unobserve
,
1004 leaf_environment_mark
,
1005 leaf_environment_free
,
1006 leaf_environment_print
1010 void *scm_type_leaf_environment
= &leaf_environment_funcs
;
1013 SCM_DEFINE (scm_make_leaf_environment
, "make-leaf-environment", 0, 0, 0,
1015 "Create a new leaf environment, containing no bindings.\n"
1016 "All bindings and locations created in the new environment\n"
1018 #define FUNC_NAME s_scm_make_leaf_environment
1020 size_t size
= sizeof (struct leaf_environment
);
1021 struct leaf_environment
*body
= scm_gc_malloc (size
, "leaf environment");
1024 core_environments_preinit (&body
->base
);
1025 body
->obarray
= SCM_BOOL_F
;
1027 env
= scm_make_environment (body
);
1029 core_environments_init (&body
->base
, &leaf_environment_funcs
);
1030 body
->obarray
= scm_c_make_hash_table (DEFAULT_OBARRAY_SIZE
);
1037 SCM_DEFINE (scm_leaf_environment_p
, "leaf-environment?", 1, 0, 0,
1039 "Return @code{#t} if object is a leaf environment, or @code{#f}\n"
1041 #define FUNC_NAME s_scm_leaf_environment_p
1043 return scm_from_bool (SCM_LEAF_ENVIRONMENT_P (object
));
1049 /* eval environments
1051 * A module's source code refers to definitions imported from other modules,
1052 * and definitions made within itself. An eval environment combines two
1053 * environments -- a local environment and an imported environment -- to
1054 * produce a new environment in which both sorts of references can be
1057 * Implementation: The obarray of the eval environment is used to cache
1058 * entries from the local and imported environments such that in most of the
1059 * cases only a single lookup is necessary. Since for neither the local nor
1060 * the imported environment it is known, what kind of environment they form,
1061 * the most general case is assumed. Therefore, entries in the obarray take
1062 * one of the following forms:
1064 * 1) (<symbol> location mutability . source-env), where mutability indicates
1065 * one of the following states: IMMUTABLE if the location is known to be
1066 * immutable, MUTABLE if the location is known to be mutable, UNKNOWN if
1067 * the location has only been requested for non modifying accesses.
1069 * 2) (symbol . source-env) if the symbol has a binding in the source-env, but
1070 * if the source-env can't provide a cell for the binding. Thus, for every
1071 * access, the source-env has to be contacted directly.
1075 struct eval_environment
{
1076 struct core_environments_base base
;
1081 SCM imported_observer
;
1087 #define EVAL_ENVIRONMENT(env) \
1088 ((struct eval_environment *) SCM_CELL_WORD_1 (env))
1090 #define IMMUTABLE SCM_I_MAKINUM (0)
1091 #define MUTABLE SCM_I_MAKINUM (1)
1092 #define UNKNOWN SCM_I_MAKINUM (2)
1094 #define CACHED_LOCATION(x) SCM_CAR (x)
1095 #define CACHED_MUTABILITY(x) SCM_CADR (x)
1096 #define SET_CACHED_MUTABILITY(x, v) SCM_SETCAR (SCM_CDR (x), (v))
1097 #define CACHED_SOURCE_ENVIRONMENT(x) SCM_CDDR (x)
1101 /* eval_environment_lookup will report one of the following distinct results:
1102 * a) (<object> . value) if a cell could be obtained.
1103 * b) <environment> if the environment has to be contacted directly.
1104 * c) IMMUTABLE if an immutable cell was requested for write.
1105 * d) SCM_UNDEFINED if there is no binding for the symbol.
1108 eval_environment_lookup (SCM env
, SCM sym
, int for_write
)
1110 SCM obarray
= EVAL_ENVIRONMENT (env
)->obarray
;
1111 SCM binding
= obarray_retrieve (obarray
, sym
);
1113 if (!SCM_UNBNDP (binding
))
1115 /* The obarray holds an entry for the symbol. */
1117 SCM entry
= SCM_CDR (binding
);
1119 if (scm_is_pair (entry
))
1121 /* The entry in the obarray is a cached location. */
1123 SCM location
= CACHED_LOCATION (entry
);
1129 mutability
= CACHED_MUTABILITY (entry
);
1130 if (scm_is_eq (mutability
, MUTABLE
))
1133 if (scm_is_eq (mutability
, UNKNOWN
))
1135 SCM source_env
= CACHED_SOURCE_ENVIRONMENT (entry
);
1136 SCM location
= SCM_ENVIRONMENT_CELL (source_env
, sym
, 1);
1138 if (scm_is_pair (location
))
1140 SET_CACHED_MUTABILITY (entry
, MUTABLE
);
1143 else /* IMMUTABLE */
1145 SET_CACHED_MUTABILITY (entry
, IMMUTABLE
);
1154 /* The obarray entry is an environment */
1161 /* There is no entry for the symbol in the obarray. This can either
1162 * mean that there has not been a request for the symbol yet, or that
1163 * the symbol is really undefined. We are looking for the symbol in
1164 * both the local and the imported environment. If we find a binding, a
1165 * cached entry is created.
1168 struct eval_environment
*body
= EVAL_ENVIRONMENT (env
);
1169 unsigned int handling_import
;
1171 for (handling_import
= 0; handling_import
<= 1; ++handling_import
)
1173 SCM source_env
= handling_import
? body
->imported
: body
->local
;
1174 SCM location
= SCM_ENVIRONMENT_CELL (source_env
, sym
, for_write
);
1176 if (!SCM_UNBNDP (location
))
1178 if (scm_is_pair (location
))
1180 SCM mutability
= for_write
? MUTABLE
: UNKNOWN
;
1181 SCM entry
= scm_cons2 (location
, mutability
, source_env
);
1182 obarray_enter (obarray
, sym
, entry
);
1185 else if (scm_is_eq (location
, SCM_ENVIRONMENT_LOCATION_NO_CELL
))
1187 obarray_enter (obarray
, sym
, source_env
);
1197 return SCM_UNDEFINED
;
1203 eval_environment_ref (SCM env
, SCM sym
)
1204 #define FUNC_NAME "eval_environment_ref"
1206 SCM location
= eval_environment_lookup (env
, sym
, 0);
1208 if (scm_is_pair (location
))
1209 return SCM_CDR (location
);
1210 else if (!SCM_UNBNDP (location
))
1211 return SCM_ENVIRONMENT_REF (location
, sym
);
1213 return SCM_UNDEFINED
;
1219 eval_environment_folder (SCM extended_data
, SCM symbol
, SCM value
, SCM tail
)
1221 SCM local
= SCM_CAR (extended_data
);
1223 if (!SCM_ENVIRONMENT_BOUND_P (local
, symbol
))
1225 SCM proc_as_nr
= SCM_CADR (extended_data
);
1226 unsigned long int proc_as_ul
= scm_to_ulong (proc_as_nr
);
1227 scm_environment_folder proc
= (scm_environment_folder
) proc_as_ul
;
1228 SCM data
= SCM_CDDR (extended_data
);
1230 return (*proc
) (data
, symbol
, value
, tail
);
1240 eval_environment_fold (SCM env
, scm_environment_folder proc
, SCM data
, SCM init
)
1242 SCM local
= EVAL_ENVIRONMENT (env
)->local
;
1243 SCM imported
= EVAL_ENVIRONMENT (env
)->imported
;
1244 SCM proc_as_nr
= scm_from_ulong ((unsigned long) proc
);
1245 SCM extended_data
= scm_cons2 (local
, proc_as_nr
, data
);
1246 SCM tmp_result
= scm_c_environment_fold (imported
, eval_environment_folder
, extended_data
, init
);
1248 return scm_c_environment_fold (local
, proc
, data
, tmp_result
);
1253 eval_environment_define (SCM env
, SCM sym
, SCM val
)
1254 #define FUNC_NAME "eval_environment_define"
1256 SCM local
= EVAL_ENVIRONMENT (env
)->local
;
1257 return SCM_ENVIRONMENT_DEFINE (local
, sym
, val
);
1263 eval_environment_undefine (SCM env
, SCM sym
)
1264 #define FUNC_NAME "eval_environment_undefine"
1266 SCM local
= EVAL_ENVIRONMENT (env
)->local
;
1267 return SCM_ENVIRONMENT_UNDEFINE (local
, sym
);
1273 eval_environment_set_x (SCM env
, SCM sym
, SCM val
)
1274 #define FUNC_NAME "eval_environment_set_x"
1276 SCM location
= eval_environment_lookup (env
, sym
, 1);
1278 if (scm_is_pair (location
))
1280 SCM_SETCDR (location
, val
);
1281 return SCM_ENVIRONMENT_SUCCESS
;
1283 else if (SCM_ENVIRONMENT_P (location
))
1285 return SCM_ENVIRONMENT_SET (location
, sym
, val
);
1287 else if (scm_is_eq (location
, IMMUTABLE
))
1289 return SCM_ENVIRONMENT_LOCATION_IMMUTABLE
;
1293 return SCM_UNDEFINED
;
1300 eval_environment_cell (SCM env
, SCM sym
, int for_write
)
1301 #define FUNC_NAME "eval_environment_cell"
1303 SCM location
= eval_environment_lookup (env
, sym
, for_write
);
1305 if (scm_is_pair (location
))
1307 else if (SCM_ENVIRONMENT_P (location
))
1308 return SCM_ENVIRONMENT_LOCATION_NO_CELL
;
1309 else if (scm_is_eq (location
, IMMUTABLE
))
1310 return SCM_ENVIRONMENT_LOCATION_IMMUTABLE
;
1312 return SCM_UNDEFINED
;
1318 eval_environment_mark (SCM env
)
1320 struct eval_environment
*body
= EVAL_ENVIRONMENT (env
);
1322 scm_gc_mark (body
->obarray
);
1323 scm_gc_mark (body
->imported
);
1324 scm_gc_mark (body
->imported_observer
);
1325 scm_gc_mark (body
->local
);
1326 scm_gc_mark (body
->local_observer
);
1328 return core_environments_mark (env
);
1333 eval_environment_free (SCM env
)
1335 core_environments_finalize (env
);
1336 scm_gc_free (EVAL_ENVIRONMENT (env
), sizeof (struct eval_environment
),
1337 "eval environment");
1342 eval_environment_print (SCM type
, SCM port
, scm_print_state
*pstate SCM_UNUSED
)
1344 SCM address
= scm_from_size_t (SCM_UNPACK (type
));
1345 SCM base16
= scm_number_to_string (address
, scm_from_int (16));
1347 scm_puts ("#<eval environment ", port
);
1348 scm_display (base16
, port
);
1349 scm_puts (">", port
);
1355 static struct scm_environment_funcs eval_environment_funcs
= {
1356 eval_environment_ref
,
1357 eval_environment_fold
,
1358 eval_environment_define
,
1359 eval_environment_undefine
,
1360 eval_environment_set_x
,
1361 eval_environment_cell
,
1362 core_environments_observe
,
1363 core_environments_unobserve
,
1364 eval_environment_mark
,
1365 eval_environment_free
,
1366 eval_environment_print
1370 void *scm_type_eval_environment
= &eval_environment_funcs
;
1374 eval_environment_observer (SCM caller SCM_UNUSED
, SCM eval_env
)
1376 SCM obarray
= EVAL_ENVIRONMENT (eval_env
)->obarray
;
1378 obarray_remove_all (obarray
);
1379 core_environments_broadcast (eval_env
);
1383 SCM_DEFINE (scm_make_eval_environment
, "make-eval-environment", 2, 0, 0,
1384 (SCM local
, SCM imported
),
1385 "Return a new environment object eval whose bindings are the\n"
1386 "union of the bindings in the environments @var{local} and\n"
1387 "@var{imported}, with bindings from @var{local} taking\n"
1388 "precedence. Definitions made in eval are placed in @var{local}.\n"
1389 "Applying @code{environment-define} or\n"
1390 "@code{environment-undefine} to eval has the same effect as\n"
1391 "applying the procedure to @var{local}.\n"
1392 "Note that eval incorporates @var{local} and @var{imported} by\n"
1394 "If, after creating eval, the program changes the bindings of\n"
1395 "@var{local} or @var{imported}, those changes will be visible\n"
1397 "Since most Scheme evaluation takes place in eval environments,\n"
1398 "they transparently cache the bindings received from @var{local}\n"
1399 "and @var{imported}. Thus, the first time the program looks up\n"
1400 "a symbol in eval, eval may make calls to @var{local} or\n"
1401 "@var{imported} to find their bindings, but subsequent\n"
1402 "references to that symbol will be as fast as references to\n"
1403 "bindings in finite environments.\n"
1404 "In typical use, @var{local} will be a finite environment, and\n"
1405 "@var{imported} will be an import environment")
1406 #define FUNC_NAME s_scm_make_eval_environment
1409 struct eval_environment
*body
;
1411 SCM_ASSERT (SCM_ENVIRONMENT_P (local
), local
, SCM_ARG1
, FUNC_NAME
);
1412 SCM_ASSERT (SCM_ENVIRONMENT_P (imported
), imported
, SCM_ARG2
, FUNC_NAME
);
1414 body
= scm_gc_malloc (sizeof (struct eval_environment
), "eval environment");
1416 core_environments_preinit (&body
->base
);
1417 body
->obarray
= SCM_BOOL_F
;
1418 body
->imported
= SCM_BOOL_F
;
1419 body
->imported_observer
= SCM_BOOL_F
;
1420 body
->local
= SCM_BOOL_F
;
1421 body
->local_observer
= SCM_BOOL_F
;
1423 env
= scm_make_environment (body
);
1425 core_environments_init (&body
->base
, &eval_environment_funcs
);
1426 body
->obarray
= scm_c_make_hash_table (DEFAULT_OBARRAY_SIZE
);
1427 body
->imported
= imported
;
1428 body
->imported_observer
1429 = SCM_ENVIRONMENT_OBSERVE (imported
, eval_environment_observer
, env
, 1);
1430 body
->local
= local
;
1431 body
->local_observer
1432 = SCM_ENVIRONMENT_OBSERVE (local
, eval_environment_observer
, env
, 1);
1439 SCM_DEFINE (scm_eval_environment_p
, "eval-environment?", 1, 0, 0,
1441 "Return @code{#t} if object is an eval environment, or @code{#f}\n"
1443 #define FUNC_NAME s_scm_eval_environment_p
1445 return scm_from_bool (SCM_EVAL_ENVIRONMENT_P (object
));
1450 SCM_DEFINE (scm_eval_environment_local
, "eval-environment-local", 1, 0, 0,
1452 "Return the local environment of eval environment @var{env}.")
1453 #define FUNC_NAME s_scm_eval_environment_local
1455 SCM_ASSERT (SCM_EVAL_ENVIRONMENT_P (env
), env
, SCM_ARG1
, FUNC_NAME
);
1457 return EVAL_ENVIRONMENT (env
)->local
;
1462 SCM_DEFINE (scm_eval_environment_set_local_x
, "eval-environment-set-local!", 2, 0, 0,
1463 (SCM env
, SCM local
),
1464 "Change @var{env}'s local environment to @var{local}.")
1465 #define FUNC_NAME s_scm_eval_environment_set_local_x
1467 struct eval_environment
*body
;
1469 SCM_ASSERT (SCM_EVAL_ENVIRONMENT_P (env
), env
, SCM_ARG1
, FUNC_NAME
);
1470 SCM_ASSERT (SCM_ENVIRONMENT_P (local
), local
, SCM_ARG2
, FUNC_NAME
);
1472 body
= EVAL_ENVIRONMENT (env
);
1474 obarray_remove_all (body
->obarray
);
1475 SCM_ENVIRONMENT_UNOBSERVE (body
->local
, body
->local_observer
);
1477 body
->local
= local
;
1478 body
->local_observer
1479 = SCM_ENVIRONMENT_OBSERVE (local
, eval_environment_observer
, env
, 1);
1481 core_environments_broadcast (env
);
1483 return SCM_UNSPECIFIED
;
1488 SCM_DEFINE (scm_eval_environment_imported
, "eval-environment-imported", 1, 0, 0,
1490 "Return the imported environment of eval environment @var{env}.")
1491 #define FUNC_NAME s_scm_eval_environment_imported
1493 SCM_ASSERT (SCM_EVAL_ENVIRONMENT_P (env
), env
, SCM_ARG1
, FUNC_NAME
);
1495 return EVAL_ENVIRONMENT (env
)->imported
;
1500 SCM_DEFINE (scm_eval_environment_set_imported_x
, "eval-environment-set-imported!", 2, 0, 0,
1501 (SCM env
, SCM imported
),
1502 "Change @var{env}'s imported environment to @var{imported}.")
1503 #define FUNC_NAME s_scm_eval_environment_set_imported_x
1505 struct eval_environment
*body
;
1507 SCM_ASSERT (SCM_EVAL_ENVIRONMENT_P (env
), env
, SCM_ARG1
, FUNC_NAME
);
1508 SCM_ASSERT (SCM_ENVIRONMENT_P (imported
), imported
, SCM_ARG2
, FUNC_NAME
);
1510 body
= EVAL_ENVIRONMENT (env
);
1512 obarray_remove_all (body
->obarray
);
1513 SCM_ENVIRONMENT_UNOBSERVE (body
->imported
, body
->imported_observer
);
1515 body
->imported
= imported
;
1516 body
->imported_observer
1517 = SCM_ENVIRONMENT_OBSERVE (imported
, eval_environment_observer
, env
, 1);
1519 core_environments_broadcast (env
);
1521 return SCM_UNSPECIFIED
;
1527 /* import environments
1529 * An import environment combines the bindings of a set of argument
1530 * environments, and checks for naming clashes.
1532 * Implementation: The import environment does no caching at all. For every
1533 * access, the list of imported environments is scanned.
1537 struct import_environment
{
1538 struct core_environments_base base
;
1541 SCM import_observers
;
1547 #define IMPORT_ENVIRONMENT(env) \
1548 ((struct import_environment *) SCM_CELL_WORD_1 (env))
1552 /* Lookup will report one of the following distinct results:
1553 * a) <environment> if only environment binds the symbol.
1554 * b) (env-1 env-2 ...) for conflicting bindings in env-1, ...
1555 * c) SCM_UNDEFINED if there is no binding for the symbol.
1558 import_environment_lookup (SCM env
, SCM sym
)
1560 SCM imports
= IMPORT_ENVIRONMENT (env
)->imports
;
1561 SCM result
= SCM_UNDEFINED
;
1564 for (l
= imports
; !scm_is_null (l
); l
= SCM_CDR (l
))
1566 SCM imported
= SCM_CAR (l
);
1568 if (SCM_ENVIRONMENT_BOUND_P (imported
, sym
))
1570 if (SCM_UNBNDP (result
))
1572 else if (scm_is_pair (result
))
1573 result
= scm_cons (imported
, result
);
1575 result
= scm_cons2 (imported
, result
, SCM_EOL
);
1579 if (scm_is_pair (result
))
1580 return scm_reverse (result
);
1587 import_environment_conflict (SCM env
, SCM sym
, SCM imports
)
1589 SCM conflict_proc
= IMPORT_ENVIRONMENT (env
)->conflict_proc
;
1590 SCM args
= scm_cons2 (env
, sym
, scm_cons (imports
, SCM_EOL
));
1592 return scm_apply_0 (conflict_proc
, args
);
1597 import_environment_ref (SCM env
, SCM sym
)
1598 #define FUNC_NAME "import_environment_ref"
1600 SCM owner
= import_environment_lookup (env
, sym
);
1602 if (SCM_UNBNDP (owner
))
1604 return SCM_UNDEFINED
;
1606 else if (scm_is_pair (owner
))
1608 SCM resolve
= import_environment_conflict (env
, sym
, owner
);
1610 if (SCM_ENVIRONMENT_P (resolve
))
1611 return SCM_ENVIRONMENT_REF (resolve
, sym
);
1613 return SCM_UNSPECIFIED
;
1617 return SCM_ENVIRONMENT_REF (owner
, sym
);
1624 import_environment_folder (SCM extended_data
, SCM symbol
, SCM value
, SCM tail
)
1625 #define FUNC_NAME "import_environment_fold"
1627 SCM import_env
= SCM_CAR (extended_data
);
1628 SCM imported_env
= SCM_CADR (extended_data
);
1629 SCM owner
= import_environment_lookup (import_env
, symbol
);
1630 SCM proc_as_nr
= SCM_CADDR (extended_data
);
1631 unsigned long int proc_as_ul
= scm_to_ulong (proc_as_nr
);
1632 scm_environment_folder proc
= (scm_environment_folder
) proc_as_ul
;
1633 SCM data
= SCM_CDDDR (extended_data
);
1635 if (scm_is_pair (owner
) && scm_is_eq (SCM_CAR (owner
), imported_env
))
1636 owner
= import_environment_conflict (import_env
, symbol
, owner
);
1638 if (SCM_ENVIRONMENT_P (owner
))
1639 return (*proc
) (data
, symbol
, value
, tail
);
1640 else /* unresolved conflict */
1641 return (*proc
) (data
, symbol
, SCM_UNSPECIFIED
, tail
);
1647 import_environment_fold (SCM env
, scm_environment_folder proc
, SCM data
, SCM init
)
1649 SCM proc_as_nr
= scm_from_ulong ((unsigned long) proc
);
1653 for (l
= IMPORT_ENVIRONMENT (env
)->imports
; !scm_is_null (l
); l
= SCM_CDR (l
))
1655 SCM imported_env
= SCM_CAR (l
);
1656 SCM extended_data
= scm_cons (env
, scm_cons2 (imported_env
, proc_as_nr
, data
));
1658 result
= scm_c_environment_fold (imported_env
, import_environment_folder
, extended_data
, result
);
1666 import_environment_define (SCM env SCM_UNUSED
,
1669 #define FUNC_NAME "import_environment_define"
1671 return SCM_ENVIRONMENT_BINDING_IMMUTABLE
;
1677 import_environment_undefine (SCM env SCM_UNUSED
,
1679 #define FUNC_NAME "import_environment_undefine"
1681 return SCM_ENVIRONMENT_BINDING_IMMUTABLE
;
1687 import_environment_set_x (SCM env
, SCM sym
, SCM val
)
1688 #define FUNC_NAME "import_environment_set_x"
1690 SCM owner
= import_environment_lookup (env
, sym
);
1692 if (SCM_UNBNDP (owner
))
1694 return SCM_UNDEFINED
;
1696 else if (scm_is_pair (owner
))
1698 SCM resolve
= import_environment_conflict (env
, sym
, owner
);
1700 if (SCM_ENVIRONMENT_P (resolve
))
1701 return SCM_ENVIRONMENT_SET (resolve
, sym
, val
);
1703 return SCM_ENVIRONMENT_LOCATION_IMMUTABLE
;
1707 return SCM_ENVIRONMENT_SET (owner
, sym
, val
);
1714 import_environment_cell (SCM env
, SCM sym
, int for_write
)
1715 #define FUNC_NAME "import_environment_cell"
1717 SCM owner
= import_environment_lookup (env
, sym
);
1719 if (SCM_UNBNDP (owner
))
1721 return SCM_UNDEFINED
;
1723 else if (scm_is_pair (owner
))
1725 SCM resolve
= import_environment_conflict (env
, sym
, owner
);
1727 if (SCM_ENVIRONMENT_P (resolve
))
1728 return SCM_ENVIRONMENT_CELL (resolve
, sym
, for_write
);
1730 return SCM_ENVIRONMENT_LOCATION_NO_CELL
;
1734 return SCM_ENVIRONMENT_CELL (owner
, sym
, for_write
);
1741 import_environment_mark (SCM env
)
1743 scm_gc_mark (IMPORT_ENVIRONMENT (env
)->imports
);
1744 scm_gc_mark (IMPORT_ENVIRONMENT (env
)->import_observers
);
1745 scm_gc_mark (IMPORT_ENVIRONMENT (env
)->conflict_proc
);
1746 return core_environments_mark (env
);
1751 import_environment_free (SCM env
)
1753 core_environments_finalize (env
);
1754 scm_gc_free (IMPORT_ENVIRONMENT (env
), sizeof (struct import_environment
),
1755 "import environment");
1760 import_environment_print (SCM type
, SCM port
,
1761 scm_print_state
*pstate SCM_UNUSED
)
1763 SCM address
= scm_from_size_t (SCM_UNPACK (type
));
1764 SCM base16
= scm_number_to_string (address
, scm_from_int (16));
1766 scm_puts ("#<import environment ", port
);
1767 scm_display (base16
, port
);
1768 scm_puts (">", port
);
1774 static struct scm_environment_funcs import_environment_funcs
= {
1775 import_environment_ref
,
1776 import_environment_fold
,
1777 import_environment_define
,
1778 import_environment_undefine
,
1779 import_environment_set_x
,
1780 import_environment_cell
,
1781 core_environments_observe
,
1782 core_environments_unobserve
,
1783 import_environment_mark
,
1784 import_environment_free
,
1785 import_environment_print
1789 void *scm_type_import_environment
= &import_environment_funcs
;
1793 import_environment_observer (SCM caller SCM_UNUSED
, SCM import_env
)
1795 core_environments_broadcast (import_env
);
1799 SCM_DEFINE (scm_make_import_environment
, "make-import-environment", 2, 0, 0,
1800 (SCM imports
, SCM conflict_proc
),
1801 "Return a new environment @var{imp} whose bindings are the union\n"
1802 "of the bindings from the environments in @var{imports};\n"
1803 "@var{imports} must be a list of environments. That is,\n"
1804 "@var{imp} binds a symbol to a location when some element of\n"
1805 "@var{imports} does.\n"
1806 "If two different elements of @var{imports} have a binding for\n"
1807 "the same symbol, the @var{conflict-proc} is called with the\n"
1808 "following parameters: the import environment, the symbol and\n"
1809 "the list of the imported environments that bind the symbol.\n"
1810 "If the @var{conflict-proc} returns an environment @var{env},\n"
1811 "the conflict is considered as resolved and the binding from\n"
1812 "@var{env} is used. If the @var{conflict-proc} returns some\n"
1813 "non-environment object, the conflict is considered unresolved\n"
1814 "and the symbol is treated as unspecified in the import\n"
1816 "The checking for conflicts may be performed lazily, i. e. at\n"
1817 "the moment when a value or binding for a certain symbol is\n"
1818 "requested instead of the moment when the environment is\n"
1819 "created or the bindings of the imports change.\n"
1820 "All bindings in @var{imp} are immutable. If you apply\n"
1821 "@code{environment-define} or @code{environment-undefine} to\n"
1822 "@var{imp}, Guile will signal an\n"
1823 " @code{environment:immutable-binding} error. However,\n"
1824 "notice that the set of bindings in @var{imp} may still change,\n"
1825 "if one of its imported environments changes.")
1826 #define FUNC_NAME s_scm_make_import_environment
1828 size_t size
= sizeof (struct import_environment
);
1829 struct import_environment
*body
= scm_gc_malloc (size
, "import environment");
1832 core_environments_preinit (&body
->base
);
1833 body
->imports
= SCM_BOOL_F
;
1834 body
->import_observers
= SCM_BOOL_F
;
1835 body
->conflict_proc
= SCM_BOOL_F
;
1837 env
= scm_make_environment (body
);
1839 core_environments_init (&body
->base
, &import_environment_funcs
);
1840 body
->imports
= SCM_EOL
;
1841 body
->import_observers
= SCM_EOL
;
1842 body
->conflict_proc
= conflict_proc
;
1844 scm_import_environment_set_imports_x (env
, imports
);
1851 SCM_DEFINE (scm_import_environment_p
, "import-environment?", 1, 0, 0,
1853 "Return @code{#t} if object is an import environment, or\n"
1854 "@code{#f} otherwise.")
1855 #define FUNC_NAME s_scm_import_environment_p
1857 return scm_from_bool (SCM_IMPORT_ENVIRONMENT_P (object
));
1862 SCM_DEFINE (scm_import_environment_imports
, "import-environment-imports", 1, 0, 0,
1864 "Return the list of environments imported by the import\n"
1865 "environment @var{env}.")
1866 #define FUNC_NAME s_scm_import_environment_imports
1868 SCM_ASSERT (SCM_IMPORT_ENVIRONMENT_P (env
), env
, SCM_ARG1
, FUNC_NAME
);
1870 return IMPORT_ENVIRONMENT (env
)->imports
;
1875 SCM_DEFINE (scm_import_environment_set_imports_x
, "import-environment-set-imports!", 2, 0, 0,
1876 (SCM env
, SCM imports
),
1877 "Change @var{env}'s list of imported environments to\n"
1878 "@var{imports}, and check for conflicts.")
1879 #define FUNC_NAME s_scm_import_environment_set_imports_x
1881 struct import_environment
*body
= IMPORT_ENVIRONMENT (env
);
1882 SCM import_observers
= SCM_EOL
;
1885 SCM_ASSERT (SCM_IMPORT_ENVIRONMENT_P (env
), env
, SCM_ARG1
, FUNC_NAME
);
1886 for (l
= imports
; scm_is_pair (l
); l
= SCM_CDR (l
))
1888 SCM obj
= SCM_CAR (l
);
1889 SCM_ASSERT (SCM_ENVIRONMENT_P (obj
), imports
, SCM_ARG2
, FUNC_NAME
);
1891 SCM_ASSERT (scm_is_null (l
), imports
, SCM_ARG2
, FUNC_NAME
);
1893 for (l
= body
->import_observers
; !scm_is_null (l
); l
= SCM_CDR (l
))
1895 SCM obs
= SCM_CAR (l
);
1896 SCM_ENVIRONMENT_UNOBSERVE (env
, obs
);
1899 for (l
= imports
; !scm_is_null (l
); l
= SCM_CDR (l
))
1901 SCM imp
= SCM_CAR (l
);
1902 SCM obs
= SCM_ENVIRONMENT_OBSERVE (imp
, import_environment_observer
, env
, 1);
1903 import_observers
= scm_cons (obs
, import_observers
);
1906 body
->imports
= imports
;
1907 body
->import_observers
= import_observers
;
1909 return SCM_UNSPECIFIED
;
1915 /* export environments
1917 * An export environment restricts an environment to a specified set of
1920 * Implementation: The export environment does no caching at all. For every
1921 * access, the signature is scanned. The signature that is stored internally
1922 * is an alist of pairs (symbol . (mutability)).
1926 struct export_environment
{
1927 struct core_environments_base base
;
1930 SCM private_observer
;
1936 #define EXPORT_ENVIRONMENT(env) \
1937 ((struct export_environment *) SCM_CELL_WORD_1 (env))
1940 SCM_SYMBOL (symbol_immutable_location
, "immutable-location");
1941 SCM_SYMBOL (symbol_mutable_location
, "mutable-location");
1946 export_environment_ref (SCM env
, SCM sym
)
1947 #define FUNC_NAME "export_environment_ref"
1949 struct export_environment
*body
= EXPORT_ENVIRONMENT (env
);
1950 SCM entry
= scm_assq (sym
, body
->signature
);
1952 if (scm_is_false (entry
))
1953 return SCM_UNDEFINED
;
1955 return SCM_ENVIRONMENT_REF (body
->private, sym
);
1961 export_environment_fold (SCM env
, scm_environment_folder proc
, SCM data
, SCM init
)
1963 struct export_environment
*body
= EXPORT_ENVIRONMENT (env
);
1967 for (l
= body
->signature
; !scm_is_null (l
); l
= SCM_CDR (l
))
1969 SCM symbol
= SCM_CAR (l
);
1970 SCM value
= SCM_ENVIRONMENT_REF (body
->private, symbol
);
1971 if (!SCM_UNBNDP (value
))
1972 result
= (*proc
) (data
, symbol
, value
, result
);
1979 export_environment_define (SCM env SCM_UNUSED
,
1982 #define FUNC_NAME "export_environment_define"
1984 return SCM_ENVIRONMENT_BINDING_IMMUTABLE
;
1990 export_environment_undefine (SCM env SCM_UNUSED
, SCM sym SCM_UNUSED
)
1991 #define FUNC_NAME "export_environment_undefine"
1993 return SCM_ENVIRONMENT_BINDING_IMMUTABLE
;
1999 export_environment_set_x (SCM env
, SCM sym
, SCM val
)
2000 #define FUNC_NAME "export_environment_set_x"
2002 struct export_environment
*body
= EXPORT_ENVIRONMENT (env
);
2003 SCM entry
= scm_assq (sym
, body
->signature
);
2005 if (scm_is_false (entry
))
2007 return SCM_UNDEFINED
;
2011 if (scm_is_eq (SCM_CADR (entry
), symbol_mutable_location
))
2012 return SCM_ENVIRONMENT_SET (body
->private, sym
, val
);
2014 return SCM_ENVIRONMENT_LOCATION_IMMUTABLE
;
2021 export_environment_cell (SCM env
, SCM sym
, int for_write
)
2022 #define FUNC_NAME "export_environment_cell"
2024 struct export_environment
*body
= EXPORT_ENVIRONMENT (env
);
2025 SCM entry
= scm_assq (sym
, body
->signature
);
2027 if (scm_is_false (entry
))
2029 return SCM_UNDEFINED
;
2033 if (!for_write
|| scm_is_eq (SCM_CADR (entry
), symbol_mutable_location
))
2034 return SCM_ENVIRONMENT_CELL (body
->private, sym
, for_write
);
2036 return SCM_ENVIRONMENT_LOCATION_IMMUTABLE
;
2043 export_environment_mark (SCM env
)
2045 struct export_environment
*body
= EXPORT_ENVIRONMENT (env
);
2047 scm_gc_mark (body
->private);
2048 scm_gc_mark (body
->private_observer
);
2049 scm_gc_mark (body
->signature
);
2051 return core_environments_mark (env
);
2056 export_environment_free (SCM env
)
2058 core_environments_finalize (env
);
2059 scm_gc_free (EXPORT_ENVIRONMENT (env
), sizeof (struct export_environment
),
2060 "export environment");
2065 export_environment_print (SCM type
, SCM port
,
2066 scm_print_state
*pstate SCM_UNUSED
)
2068 SCM address
= scm_from_size_t (SCM_UNPACK (type
));
2069 SCM base16
= scm_number_to_string (address
, scm_from_int (16));
2071 scm_puts ("#<export environment ", port
);
2072 scm_display (base16
, port
);
2073 scm_puts (">", port
);
2079 static struct scm_environment_funcs export_environment_funcs
= {
2080 export_environment_ref
,
2081 export_environment_fold
,
2082 export_environment_define
,
2083 export_environment_undefine
,
2084 export_environment_set_x
,
2085 export_environment_cell
,
2086 core_environments_observe
,
2087 core_environments_unobserve
,
2088 export_environment_mark
,
2089 export_environment_free
,
2090 export_environment_print
2094 void *scm_type_export_environment
= &export_environment_funcs
;
2098 export_environment_observer (SCM caller SCM_UNUSED
, SCM export_env
)
2100 core_environments_broadcast (export_env
);
2104 SCM_DEFINE (scm_make_export_environment
, "make-export-environment", 2, 0, 0,
2105 (SCM
private, SCM signature
),
2106 "Return a new environment @var{exp} containing only those\n"
2107 "bindings in private whose symbols are present in\n"
2108 "@var{signature}. The @var{private} argument must be an\n"
2110 "The environment @var{exp} binds symbol to location when\n"
2111 "@var{env} does, and symbol is exported by @var{signature}.\n\n"
2112 "@var{signature} is a list specifying which of the bindings in\n"
2113 "@var{private} should be visible in @var{exp}. Each element of\n"
2114 "@var{signature} should be a list of the form:\n"
2115 " (symbol attribute ...)\n"
2116 "where each attribute is one of the following:\n"
2118 "@item the symbol @code{mutable-location}\n"
2119 " @var{exp} should treat the\n"
2120 " location bound to symbol as mutable. That is, @var{exp}\n"
2121 " will pass calls to @code{environment-set!} or\n"
2122 " @code{environment-cell} directly through to private.\n"
2123 "@item the symbol @code{immutable-location}\n"
2124 " @var{exp} should treat\n"
2125 " the location bound to symbol as immutable. If the program\n"
2126 " applies @code{environment-set!} to @var{exp} and symbol, or\n"
2127 " calls @code{environment-cell} to obtain a writable value\n"
2128 " cell, @code{environment-set!} will signal an\n"
2129 " @code{environment:immutable-location} error. Note that, even\n"
2130 " if an export environment treats a location as immutable, the\n"
2131 " underlying environment may treat it as mutable, so its\n"
2132 " value may change.\n"
2134 "It is an error for an element of signature to specify both\n"
2135 "@code{mutable-location} and @code{immutable-location}. If\n"
2136 "neither is specified, @code{immutable-location} is assumed.\n\n"
2137 "As a special case, if an element of signature is a lone\n"
2138 "symbol @var{sym}, it is equivalent to an element of the form\n"
2140 "All bindings in @var{exp} are immutable. If you apply\n"
2141 "@code{environment-define} or @code{environment-undefine} to\n"
2142 "@var{exp}, Guile will signal an\n"
2143 "@code{environment:immutable-binding} error. However,\n"
2144 "notice that the set of bindings in @var{exp} may still change,\n"
2145 "if the bindings in private change.")
2146 #define FUNC_NAME s_scm_make_export_environment
2149 struct export_environment
*body
;
2152 SCM_ASSERT (SCM_ENVIRONMENT_P (private), private, SCM_ARG1
, FUNC_NAME
);
2154 size
= sizeof (struct export_environment
);
2155 body
= scm_gc_malloc (size
, "export environment");
2157 core_environments_preinit (&body
->base
);
2158 body
->private = SCM_BOOL_F
;
2159 body
->private_observer
= SCM_BOOL_F
;
2160 body
->signature
= SCM_BOOL_F
;
2162 env
= scm_make_environment (body
);
2164 core_environments_init (&body
->base
, &export_environment_funcs
);
2165 body
->private = private;
2166 body
->private_observer
2167 = SCM_ENVIRONMENT_OBSERVE (private, export_environment_observer
, env
, 1);
2168 body
->signature
= SCM_EOL
;
2170 scm_export_environment_set_signature_x (env
, signature
);
2177 SCM_DEFINE (scm_export_environment_p
, "export-environment?", 1, 0, 0,
2179 "Return @code{#t} if object is an export environment, or\n"
2180 "@code{#f} otherwise.")
2181 #define FUNC_NAME s_scm_export_environment_p
2183 return scm_from_bool (SCM_EXPORT_ENVIRONMENT_P (object
));
2188 SCM_DEFINE (scm_export_environment_private
, "export-environment-private", 1, 0, 0,
2190 "Return the private environment of export environment @var{env}.")
2191 #define FUNC_NAME s_scm_export_environment_private
2193 SCM_ASSERT (SCM_EXPORT_ENVIRONMENT_P (env
), env
, SCM_ARG1
, FUNC_NAME
);
2195 return EXPORT_ENVIRONMENT (env
)->private;
2200 SCM_DEFINE (scm_export_environment_set_private_x
, "export-environment-set-private!", 2, 0, 0,
2201 (SCM env
, SCM
private),
2202 "Change the private environment of export environment @var{env}.")
2203 #define FUNC_NAME s_scm_export_environment_set_private_x
2205 struct export_environment
*body
;
2207 SCM_ASSERT (SCM_EXPORT_ENVIRONMENT_P (env
), env
, SCM_ARG1
, FUNC_NAME
);
2208 SCM_ASSERT (SCM_ENVIRONMENT_P (private), private, SCM_ARG2
, FUNC_NAME
);
2210 body
= EXPORT_ENVIRONMENT (env
);
2211 SCM_ENVIRONMENT_UNOBSERVE (private, body
->private_observer
);
2213 body
->private = private;
2214 body
->private_observer
2215 = SCM_ENVIRONMENT_OBSERVE (private, export_environment_observer
, env
, 1);
2217 return SCM_UNSPECIFIED
;
2222 SCM_DEFINE (scm_export_environment_signature
, "export-environment-signature", 1, 0, 0,
2224 "Return the signature of export environment @var{env}.")
2225 #define FUNC_NAME s_scm_export_environment_signature
2227 SCM_ASSERT (SCM_EXPORT_ENVIRONMENT_P (env
), env
, SCM_ARG1
, FUNC_NAME
);
2229 return EXPORT_ENVIRONMENT (env
)->signature
;
2235 export_environment_parse_signature (SCM signature
, const char* caller
)
2237 SCM result
= SCM_EOL
;
2240 for (l
= signature
; scm_is_pair (l
); l
= SCM_CDR (l
))
2242 SCM entry
= SCM_CAR (l
);
2244 if (scm_is_symbol (entry
))
2246 SCM new_entry
= scm_cons2 (entry
, symbol_immutable_location
, SCM_EOL
);
2247 result
= scm_cons (new_entry
, result
);
2258 SCM_ASSERT (scm_is_pair (entry
), entry
, SCM_ARGn
, caller
);
2259 SCM_ASSERT (scm_is_symbol (SCM_CAR (entry
)), entry
, SCM_ARGn
, caller
);
2261 sym
= SCM_CAR (entry
);
2263 for (l2
= SCM_CDR (entry
); scm_is_pair (l2
); l2
= SCM_CDR (l2
))
2265 SCM attribute
= SCM_CAR (l2
);
2266 if (scm_is_eq (attribute
, symbol_immutable_location
))
2268 else if (scm_is_eq (attribute
, symbol_mutable_location
))
2271 SCM_ASSERT (0, entry
, SCM_ARGn
, caller
);
2273 SCM_ASSERT (scm_is_null (l2
), entry
, SCM_ARGn
, caller
);
2274 SCM_ASSERT (!mutable || !immutable
, entry
, SCM_ARGn
, caller
);
2276 if (!mutable && !immutable
)
2279 mutability
= mutable ? symbol_mutable_location
: symbol_immutable_location
;
2280 new_entry
= scm_cons2 (sym
, mutability
, SCM_EOL
);
2281 result
= scm_cons (new_entry
, result
);
2284 SCM_ASSERT (scm_is_null (l
), signature
, SCM_ARGn
, caller
);
2286 /* Dirk:FIXME:: Now we know that signature is syntactically correct. There
2287 * are, however, no checks for symbols entered twice with contradicting
2288 * mutabilities. It would be nice, to implement this test, to be able to
2289 * call the sort functions conveniently from C.
2292 return scm_reverse (result
);
2296 SCM_DEFINE (scm_export_environment_set_signature_x
, "export-environment-set-signature!", 2, 0, 0,
2297 (SCM env
, SCM signature
),
2298 "Change the signature of export environment @var{env}.")
2299 #define FUNC_NAME s_scm_export_environment_set_signature_x
2303 SCM_ASSERT (SCM_EXPORT_ENVIRONMENT_P (env
), env
, SCM_ARG1
, FUNC_NAME
);
2304 parsed_sig
= export_environment_parse_signature (signature
, FUNC_NAME
);
2306 EXPORT_ENVIRONMENT (env
)->signature
= parsed_sig
;
2308 return SCM_UNSPECIFIED
;
2315 scm_environments_prehistory ()
2317 /* create environment smob */
2318 scm_tc16_environment
= scm_make_smob_type ("environment", 0);
2319 scm_set_smob_mark (scm_tc16_environment
, environment_mark
);
2320 scm_set_smob_free (scm_tc16_environment
, environment_free
);
2321 scm_set_smob_print (scm_tc16_environment
, environment_print
);
2323 /* create observer smob */
2324 scm_tc16_observer
= scm_make_smob_type ("observer", 0);
2325 scm_set_smob_mark (scm_tc16_observer
, observer_mark
);
2326 scm_set_smob_print (scm_tc16_observer
, observer_print
);
2328 /* create system environment */
2329 scm_system_environment
= scm_make_leaf_environment ();
2330 scm_permanent_object (scm_system_environment
);
2335 scm_init_environments ()
2337 #include "libguile/environments.x"