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., 59 Temple Place, Suite 330, Boston, MA 02111-1307 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_SYMBOLP (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_SYMBOLP (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_SYMBOLP (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 gh_call3 (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_SYMBOLP (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_SYMBOLP(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_SYMBOLP (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_SYMBOLP (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_SYMBOLP (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 gh_call1 (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_SYMBOL_HASH (symbol
) % SCM_HASHTABLE_N_BUCKETS (obarray
);
511 SCM entry
= scm_cons (symbol
, data
);
512 SCM slot
= scm_cons (entry
, SCM_HASHTABLE_BUCKETS (obarray
)[hash
]);
513 SCM_SET_HASHTABLE_BUCKET (obarray
, hash
, slot
);
514 if (SCM_HASHTABLE_N_ITEMS (obarray
) > SCM_HASHTABLE_UPPER (obarray
))
515 scm_i_rehash (obarray
, scm_i_hash_symbol
, 0, "obarray_enter");
522 * Enter symbol into obarray. An existing entry for symbol is replaced. If
523 * an entry existed, the old (symbol . data) cell is returned, #f otherwise.
526 obarray_replace (SCM obarray
, SCM symbol
, SCM data
)
528 size_t hash
= SCM_SYMBOL_HASH (symbol
) % SCM_HASHTABLE_N_BUCKETS (obarray
);
529 SCM new_entry
= scm_cons (symbol
, data
);
533 for (lsym
= SCM_HASHTABLE_BUCKETS (obarray
)[hash
];
535 lsym
= SCM_CDR (lsym
))
537 SCM old_entry
= SCM_CAR (lsym
);
538 if (scm_is_eq (SCM_CAR (old_entry
), symbol
))
540 SCM_SETCAR (lsym
, new_entry
);
545 slot
= scm_cons (new_entry
, SCM_HASHTABLE_BUCKETS (obarray
)[hash
]);
546 SCM_SET_HASHTABLE_BUCKET (obarray
, hash
, slot
);
547 if (SCM_HASHTABLE_N_ITEMS (obarray
) > SCM_HASHTABLE_UPPER (obarray
))
548 scm_i_rehash (obarray
, scm_i_hash_symbol
, 0, "obarray_replace");
555 * Look up symbol in obarray
558 obarray_retrieve (SCM obarray
, SCM sym
)
560 size_t hash
= SCM_SYMBOL_HASH (sym
) % SCM_HASHTABLE_N_BUCKETS (obarray
);
563 for (lsym
= SCM_HASHTABLE_BUCKETS (obarray
)[hash
];
565 lsym
= SCM_CDR (lsym
))
567 SCM entry
= SCM_CAR (lsym
);
568 if (scm_is_eq (SCM_CAR (entry
), sym
))
572 return SCM_UNDEFINED
;
577 * Remove entry from obarray. If the symbol was found and removed, the old
578 * (symbol . data) cell is returned, #f otherwise.
581 obarray_remove (SCM obarray
, SCM sym
)
583 size_t hash
= SCM_SYMBOL_HASH (sym
) % SCM_HASHTABLE_N_BUCKETS (obarray
);
584 SCM table_entry
= SCM_HASHTABLE_BUCKETS (obarray
)[hash
];
585 SCM handle
= scm_sloppy_assq (sym
, table_entry
);
587 if (SCM_CONSP (handle
))
589 SCM new_table_entry
= scm_delq1_x (handle
, table_entry
);
590 SCM_SET_HASHTABLE_BUCKET (obarray
, hash
, new_table_entry
);
591 SCM_HASHTABLE_DECREMENT (obarray
);
599 obarray_remove_all (SCM obarray
)
601 size_t size
= SCM_HASHTABLE_N_BUCKETS (obarray
);
604 for (i
= 0; i
< size
; i
++)
606 SCM_SET_HASHTABLE_BUCKET (obarray
, i
, SCM_EOL
);
608 SCM_SET_HASHTABLE_N_ITEMS (obarray
, 0);
613 /* core environments base
615 * This struct and the corresponding functions form a base class for guile's
616 * built-in environment types.
620 struct core_environments_base
{
621 struct scm_environment_funcs
*funcs
;
628 #define CORE_ENVIRONMENTS_BASE(env) \
629 ((struct core_environments_base *) SCM_CELL_WORD_1 (env))
630 #define CORE_ENVIRONMENT_OBSERVERS(env) \
631 (CORE_ENVIRONMENTS_BASE (env)->observers)
632 #define SCM_SET_CORE_ENVIRONMENT_OBSERVERS(env, v) \
633 (CORE_ENVIRONMENT_OBSERVERS (env) = (v))
634 #define CORE_ENVIRONMENT_WEAK_OBSERVER_VECTOR(env) \
635 (CORE_ENVIRONMENTS_BASE (env)->weak_observers)
636 #define CORE_ENVIRONMENT_WEAK_OBSERVERS(env) \
637 (SCM_VELTS (CORE_ENVIRONMENT_WEAK_OBSERVER_VECTOR (env)) [0])
638 #define SCM_SET_CORE_ENVIRONMENT_WEAK_OBSERVERS(env, v) \
639 (SCM_VECTOR_SET (CORE_ENVIRONMENT_WEAK_OBSERVER_VECTOR (env), 0, (v)))
644 core_environments_observe (SCM env
, scm_environment_observer proc
, SCM data
, int weak_p
)
646 SCM observer
= scm_double_cell (scm_tc16_observer
,
653 SCM observers
= CORE_ENVIRONMENT_OBSERVERS (env
);
654 SCM new_observers
= scm_cons (observer
, observers
);
655 SCM_SET_CORE_ENVIRONMENT_OBSERVERS (env
, new_observers
);
659 SCM observers
= CORE_ENVIRONMENT_WEAK_OBSERVERS (env
);
660 SCM new_observers
= scm_acons (SCM_BOOL_F
, observer
, observers
);
661 SCM_SET_CORE_ENVIRONMENT_WEAK_OBSERVERS (env
, new_observers
);
669 core_environments_unobserve (SCM env
, SCM observer
)
671 unsigned int handling_weaks
;
672 for (handling_weaks
= 0; handling_weaks
<= 1; ++handling_weaks
)
674 SCM l
= handling_weaks
675 ? CORE_ENVIRONMENT_WEAK_OBSERVERS (env
)
676 : CORE_ENVIRONMENT_OBSERVERS (env
);
680 SCM rest
= SCM_CDR (l
);
681 SCM first
= handling_weaks
685 if (scm_is_eq (first
, observer
))
687 /* Remove the first observer */
689 ? SCM_SET_CORE_ENVIRONMENT_WEAK_OBSERVERS (env
, rest
)
690 : SCM_SET_CORE_ENVIRONMENT_OBSERVERS (env
, rest
);
695 SCM rest
= SCM_CDR (l
);
697 if (!SCM_NULLP (rest
))
699 SCM next
= handling_weaks
703 if (scm_is_eq (next
, observer
))
705 SCM_SETCDR (l
, SCM_CDR (rest
));
711 } while (!SCM_NULLP (l
));
715 /* Dirk:FIXME:: What to do now, since the observer is not found? */
720 core_environments_mark (SCM env
)
722 scm_gc_mark (CORE_ENVIRONMENT_OBSERVERS (env
));
723 return CORE_ENVIRONMENT_WEAK_OBSERVER_VECTOR (env
);
728 core_environments_finalize (SCM env SCM_UNUSED
)
734 core_environments_preinit (struct core_environments_base
*body
)
737 body
->observers
= SCM_BOOL_F
;
738 body
->weak_observers
= SCM_BOOL_F
;
743 core_environments_init (struct core_environments_base
*body
,
744 struct scm_environment_funcs
*funcs
)
747 body
->observers
= SCM_EOL
;
748 body
->weak_observers
= scm_make_weak_value_alist_vector (scm_from_int (1));
752 /* Tell all observers to clear their caches.
754 * Environments have to be informed about changes in the following cases:
755 * - The observed env has a new binding. This must be always reported.
756 * - The observed env has dropped a binding. This must be always reported.
757 * - A binding in the observed environment has changed. This must only be
758 * reported, if there is a chance that the binding is being cached outside.
759 * However, this potential optimization is not performed currently.
761 * Errors that occur while the observers are called are accumulated and
762 * signalled as one single error message to the caller.
773 update_catch_body (void *ptr
)
775 struct update_data
*data
= (struct update_data
*) ptr
;
776 SCM observer
= data
->observer
;
778 (*SCM_OBSERVER_PROC (observer
))
779 (data
->environment
, SCM_OBSERVER_DATA (observer
));
781 return SCM_UNDEFINED
;
786 update_catch_handler (void *ptr
, SCM tag
, SCM args
)
788 struct update_data
*data
= (struct update_data
*) ptr
;
789 SCM observer
= data
->observer
;
790 SCM message
= scm_makfrom0str ("Observer `~A' signals `~A' error: ~S");
792 return scm_cons (message
, scm_list_3 (observer
, tag
, args
));
797 core_environments_broadcast (SCM env
)
798 #define FUNC_NAME "core_environments_broadcast"
800 unsigned int handling_weaks
;
801 SCM errors
= SCM_EOL
;
803 for (handling_weaks
= 0; handling_weaks
<= 1; ++handling_weaks
)
805 SCM observers
= handling_weaks
806 ? CORE_ENVIRONMENT_WEAK_OBSERVERS (env
)
807 : CORE_ENVIRONMENT_OBSERVERS (env
);
809 for (; !SCM_NULLP (observers
); observers
= SCM_CDR (observers
))
811 struct update_data data
;
812 SCM observer
= handling_weaks
813 ? SCM_CDAR (observers
)
814 : SCM_CAR (observers
);
817 data
.observer
= observer
;
818 data
.environment
= env
;
820 error
= scm_internal_catch (SCM_BOOL_T
,
821 update_catch_body
, &data
,
822 update_catch_handler
, &data
);
824 if (!SCM_UNBNDP (error
))
825 errors
= scm_cons (error
, errors
);
829 if (!SCM_NULLP (errors
))
831 /* Dirk:FIXME:: As soon as scm_misc_error is fixed to handle the name
832 * parameter correctly it should not be necessary any more to also pass
833 * namestr in order to get the desired information from the error
836 SCM ordered_errors
= scm_reverse (errors
);
839 "Observers of `~A' have signalled the following errors: ~S",
840 scm_cons2 (env
, ordered_errors
, SCM_EOL
));
849 * A leaf environment is simply a mutable set of definitions. A leaf
850 * environment supports no operations beyond the common set.
852 * Implementation: The obarray of the leaf environment holds (symbol . value)
853 * pairs. No further information is necessary, since all bindings and
854 * locations in a leaf environment are mutable.
858 struct leaf_environment
{
859 struct core_environments_base base
;
865 #define LEAF_ENVIRONMENT(env) \
866 ((struct leaf_environment *) SCM_CELL_WORD_1 (env))
871 leaf_environment_ref (SCM env
, SCM sym
)
873 SCM obarray
= LEAF_ENVIRONMENT (env
)->obarray
;
874 SCM binding
= obarray_retrieve (obarray
, sym
);
875 return SCM_UNBNDP (binding
) ? binding
: SCM_CDR (binding
);
880 leaf_environment_fold (SCM env
, scm_environment_folder proc
, SCM data
, SCM init
)
884 SCM obarray
= LEAF_ENVIRONMENT (env
)->obarray
;
886 for (i
= 0; i
< SCM_HASHTABLE_N_BUCKETS (obarray
); i
++)
889 for (l
= SCM_HASHTABLE_BUCKETS (obarray
)[i
];
893 SCM binding
= SCM_CAR (l
);
894 SCM symbol
= SCM_CAR (binding
);
895 SCM value
= SCM_CDR (binding
);
896 result
= (*proc
) (data
, symbol
, value
, result
);
904 leaf_environment_define (SCM env
, SCM sym
, SCM val
)
905 #define FUNC_NAME "leaf_environment_define"
907 SCM obarray
= LEAF_ENVIRONMENT (env
)->obarray
;
909 obarray_replace (obarray
, sym
, val
);
910 core_environments_broadcast (env
);
912 return SCM_ENVIRONMENT_SUCCESS
;
918 leaf_environment_undefine (SCM env
, SCM sym
)
919 #define FUNC_NAME "leaf_environment_undefine"
921 SCM obarray
= LEAF_ENVIRONMENT (env
)->obarray
;
922 SCM removed
= obarray_remove (obarray
, sym
);
924 if (scm_is_true (removed
))
925 core_environments_broadcast (env
);
927 return SCM_ENVIRONMENT_SUCCESS
;
933 leaf_environment_set_x (SCM env
, SCM sym
, SCM val
)
934 #define FUNC_NAME "leaf_environment_set_x"
936 SCM obarray
= LEAF_ENVIRONMENT (env
)->obarray
;
937 SCM binding
= obarray_retrieve (obarray
, sym
);
939 if (!SCM_UNBNDP (binding
))
941 SCM_SETCDR (binding
, val
);
942 return SCM_ENVIRONMENT_SUCCESS
;
946 return SCM_UNDEFINED
;
953 leaf_environment_cell (SCM env
, SCM sym
, int for_write SCM_UNUSED
)
955 SCM obarray
= LEAF_ENVIRONMENT (env
)->obarray
;
956 SCM binding
= obarray_retrieve (obarray
, sym
);
962 leaf_environment_mark (SCM env
)
964 scm_gc_mark (LEAF_ENVIRONMENT (env
)->obarray
);
965 return core_environments_mark (env
);
970 leaf_environment_free (SCM env
)
972 core_environments_finalize (env
);
973 scm_gc_free (LEAF_ENVIRONMENT (env
), sizeof (struct leaf_environment
),
979 leaf_environment_print (SCM type
, SCM port
, scm_print_state
*pstate SCM_UNUSED
)
981 SCM address
= scm_from_size_t (SCM_UNPACK (type
));
982 SCM base16
= scm_number_to_string (address
, scm_from_int (16));
984 scm_puts ("#<leaf environment ", port
);
985 scm_display (base16
, port
);
986 scm_puts (">", port
);
992 static struct scm_environment_funcs leaf_environment_funcs
= {
993 leaf_environment_ref
,
994 leaf_environment_fold
,
995 leaf_environment_define
,
996 leaf_environment_undefine
,
997 leaf_environment_set_x
,
998 leaf_environment_cell
,
999 core_environments_observe
,
1000 core_environments_unobserve
,
1001 leaf_environment_mark
,
1002 leaf_environment_free
,
1003 leaf_environment_print
1007 void *scm_type_leaf_environment
= &leaf_environment_funcs
;
1010 SCM_DEFINE (scm_make_leaf_environment
, "make-leaf-environment", 0, 0, 0,
1012 "Create a new leaf environment, containing no bindings.\n"
1013 "All bindings and locations created in the new environment\n"
1015 #define FUNC_NAME s_scm_make_leaf_environment
1017 size_t size
= sizeof (struct leaf_environment
);
1018 struct leaf_environment
*body
= scm_gc_malloc (size
, "leaf environment");
1021 core_environments_preinit (&body
->base
);
1022 body
->obarray
= SCM_BOOL_F
;
1024 env
= scm_make_environment (body
);
1026 core_environments_init (&body
->base
, &leaf_environment_funcs
);
1027 body
->obarray
= scm_c_make_hash_table (DEFAULT_OBARRAY_SIZE
);
1034 SCM_DEFINE (scm_leaf_environment_p
, "leaf-environment?", 1, 0, 0,
1036 "Return @code{#t} if object is a leaf environment, or @code{#f}\n"
1038 #define FUNC_NAME s_scm_leaf_environment_p
1040 return scm_from_bool (SCM_LEAF_ENVIRONMENT_P (object
));
1046 /* eval environments
1048 * A module's source code refers to definitions imported from other modules,
1049 * and definitions made within itself. An eval environment combines two
1050 * environments -- a local environment and an imported environment -- to
1051 * produce a new environment in which both sorts of references can be
1054 * Implementation: The obarray of the eval environment is used to cache
1055 * entries from the local and imported environments such that in most of the
1056 * cases only a single lookup is necessary. Since for neither the local nor
1057 * the imported environment it is known, what kind of environment they form,
1058 * the most general case is assumed. Therefore, entries in the obarray take
1059 * one of the following forms:
1061 * 1) (<symbol> location mutability . source-env), where mutability indicates
1062 * one of the following states: IMMUTABLE if the location is known to be
1063 * immutable, MUTABLE if the location is known to be mutable, UNKNOWN if
1064 * the location has only been requested for non modifying accesses.
1066 * 2) (symbol . source-env) if the symbol has a binding in the source-env, but
1067 * if the source-env can't provide a cell for the binding. Thus, for every
1068 * access, the source-env has to be contacted directly.
1072 struct eval_environment
{
1073 struct core_environments_base base
;
1078 SCM imported_observer
;
1084 #define EVAL_ENVIRONMENT(env) \
1085 ((struct eval_environment *) SCM_CELL_WORD_1 (env))
1087 #define IMMUTABLE SCM_I_MAKINUM (0)
1088 #define MUTABLE SCM_I_MAKINUM (1)
1089 #define UNKNOWN SCM_I_MAKINUM (2)
1091 #define CACHED_LOCATION(x) SCM_CAR (x)
1092 #define CACHED_MUTABILITY(x) SCM_CADR (x)
1093 #define SET_CACHED_MUTABILITY(x, v) SCM_SETCAR (SCM_CDR (x), (v))
1094 #define CACHED_SOURCE_ENVIRONMENT(x) SCM_CDDR (x)
1098 /* eval_environment_lookup will report one of the following distinct results:
1099 * a) (<object> . value) if a cell could be obtained.
1100 * b) <environment> if the environment has to be contacted directly.
1101 * c) IMMUTABLE if an immutable cell was requested for write.
1102 * d) SCM_UNDEFINED if there is no binding for the symbol.
1105 eval_environment_lookup (SCM env
, SCM sym
, int for_write
)
1107 SCM obarray
= EVAL_ENVIRONMENT (env
)->obarray
;
1108 SCM binding
= obarray_retrieve (obarray
, sym
);
1110 if (!SCM_UNBNDP (binding
))
1112 /* The obarray holds an entry for the symbol. */
1114 SCM entry
= SCM_CDR (binding
);
1116 if (SCM_CONSP (entry
))
1118 /* The entry in the obarray is a cached location. */
1120 SCM location
= CACHED_LOCATION (entry
);
1126 mutability
= CACHED_MUTABILITY (entry
);
1127 if (scm_is_eq (mutability
, MUTABLE
))
1130 if (scm_is_eq (mutability
, UNKNOWN
))
1132 SCM source_env
= CACHED_SOURCE_ENVIRONMENT (entry
);
1133 SCM location
= SCM_ENVIRONMENT_CELL (source_env
, sym
, 1);
1135 if (SCM_CONSP (location
))
1137 SET_CACHED_MUTABILITY (entry
, MUTABLE
);
1140 else /* IMMUTABLE */
1142 SET_CACHED_MUTABILITY (entry
, IMMUTABLE
);
1151 /* The obarray entry is an environment */
1158 /* There is no entry for the symbol in the obarray. This can either
1159 * mean that there has not been a request for the symbol yet, or that
1160 * the symbol is really undefined. We are looking for the symbol in
1161 * both the local and the imported environment. If we find a binding, a
1162 * cached entry is created.
1165 struct eval_environment
*body
= EVAL_ENVIRONMENT (env
);
1166 unsigned int handling_import
;
1168 for (handling_import
= 0; handling_import
<= 1; ++handling_import
)
1170 SCM source_env
= handling_import
? body
->imported
: body
->local
;
1171 SCM location
= SCM_ENVIRONMENT_CELL (source_env
, sym
, for_write
);
1173 if (!SCM_UNBNDP (location
))
1175 if (SCM_CONSP (location
))
1177 SCM mutability
= for_write
? MUTABLE
: UNKNOWN
;
1178 SCM entry
= scm_cons2 (location
, mutability
, source_env
);
1179 obarray_enter (obarray
, sym
, entry
);
1182 else if (scm_is_eq (location
, SCM_ENVIRONMENT_LOCATION_NO_CELL
))
1184 obarray_enter (obarray
, sym
, source_env
);
1194 return SCM_UNDEFINED
;
1200 eval_environment_ref (SCM env
, SCM sym
)
1201 #define FUNC_NAME "eval_environment_ref"
1203 SCM location
= eval_environment_lookup (env
, sym
, 0);
1205 if (SCM_CONSP (location
))
1206 return SCM_CDR (location
);
1207 else if (!SCM_UNBNDP (location
))
1208 return SCM_ENVIRONMENT_REF (location
, sym
);
1210 return SCM_UNDEFINED
;
1216 eval_environment_folder (SCM extended_data
, SCM symbol
, SCM value
, SCM tail
)
1218 SCM local
= SCM_CAR (extended_data
);
1220 if (!SCM_ENVIRONMENT_BOUND_P (local
, symbol
))
1222 SCM proc_as_nr
= SCM_CADR (extended_data
);
1223 unsigned long int proc_as_ul
= scm_to_ulong (proc_as_nr
);
1224 scm_environment_folder proc
= (scm_environment_folder
) proc_as_ul
;
1225 SCM data
= SCM_CDDR (extended_data
);
1227 return (*proc
) (data
, symbol
, value
, tail
);
1237 eval_environment_fold (SCM env
, scm_environment_folder proc
, SCM data
, SCM init
)
1239 SCM local
= EVAL_ENVIRONMENT (env
)->local
;
1240 SCM imported
= EVAL_ENVIRONMENT (env
)->imported
;
1241 SCM proc_as_nr
= scm_from_ulong ((unsigned long) proc
);
1242 SCM extended_data
= scm_cons2 (local
, proc_as_nr
, data
);
1243 SCM tmp_result
= scm_c_environment_fold (imported
, eval_environment_folder
, extended_data
, init
);
1245 return scm_c_environment_fold (local
, proc
, data
, tmp_result
);
1250 eval_environment_define (SCM env
, SCM sym
, SCM val
)
1251 #define FUNC_NAME "eval_environment_define"
1253 SCM local
= EVAL_ENVIRONMENT (env
)->local
;
1254 return SCM_ENVIRONMENT_DEFINE (local
, sym
, val
);
1260 eval_environment_undefine (SCM env
, SCM sym
)
1261 #define FUNC_NAME "eval_environment_undefine"
1263 SCM local
= EVAL_ENVIRONMENT (env
)->local
;
1264 return SCM_ENVIRONMENT_UNDEFINE (local
, sym
);
1270 eval_environment_set_x (SCM env
, SCM sym
, SCM val
)
1271 #define FUNC_NAME "eval_environment_set_x"
1273 SCM location
= eval_environment_lookup (env
, sym
, 1);
1275 if (SCM_CONSP (location
))
1277 SCM_SETCDR (location
, val
);
1278 return SCM_ENVIRONMENT_SUCCESS
;
1280 else if (SCM_ENVIRONMENT_P (location
))
1282 return SCM_ENVIRONMENT_SET (location
, sym
, val
);
1284 else if (scm_is_eq (location
, IMMUTABLE
))
1286 return SCM_ENVIRONMENT_LOCATION_IMMUTABLE
;
1290 return SCM_UNDEFINED
;
1297 eval_environment_cell (SCM env
, SCM sym
, int for_write
)
1298 #define FUNC_NAME "eval_environment_cell"
1300 SCM location
= eval_environment_lookup (env
, sym
, for_write
);
1302 if (SCM_CONSP (location
))
1304 else if (SCM_ENVIRONMENT_P (location
))
1305 return SCM_ENVIRONMENT_LOCATION_NO_CELL
;
1306 else if (scm_is_eq (location
, IMMUTABLE
))
1307 return SCM_ENVIRONMENT_LOCATION_IMMUTABLE
;
1309 return SCM_UNDEFINED
;
1315 eval_environment_mark (SCM env
)
1317 struct eval_environment
*body
= EVAL_ENVIRONMENT (env
);
1319 scm_gc_mark (body
->obarray
);
1320 scm_gc_mark (body
->imported
);
1321 scm_gc_mark (body
->imported_observer
);
1322 scm_gc_mark (body
->local
);
1323 scm_gc_mark (body
->local_observer
);
1325 return core_environments_mark (env
);
1330 eval_environment_free (SCM env
)
1332 core_environments_finalize (env
);
1333 scm_gc_free (EVAL_ENVIRONMENT (env
), sizeof (struct eval_environment
),
1334 "eval environment");
1339 eval_environment_print (SCM type
, SCM port
, scm_print_state
*pstate SCM_UNUSED
)
1341 SCM address
= scm_from_size_t (SCM_UNPACK (type
));
1342 SCM base16
= scm_number_to_string (address
, scm_from_int (16));
1344 scm_puts ("#<eval environment ", port
);
1345 scm_display (base16
, port
);
1346 scm_puts (">", port
);
1352 static struct scm_environment_funcs eval_environment_funcs
= {
1353 eval_environment_ref
,
1354 eval_environment_fold
,
1355 eval_environment_define
,
1356 eval_environment_undefine
,
1357 eval_environment_set_x
,
1358 eval_environment_cell
,
1359 core_environments_observe
,
1360 core_environments_unobserve
,
1361 eval_environment_mark
,
1362 eval_environment_free
,
1363 eval_environment_print
1367 void *scm_type_eval_environment
= &eval_environment_funcs
;
1371 eval_environment_observer (SCM caller SCM_UNUSED
, SCM eval_env
)
1373 SCM obarray
= EVAL_ENVIRONMENT (eval_env
)->obarray
;
1375 obarray_remove_all (obarray
);
1376 core_environments_broadcast (eval_env
);
1380 SCM_DEFINE (scm_make_eval_environment
, "make-eval-environment", 2, 0, 0,
1381 (SCM local
, SCM imported
),
1382 "Return a new environment object eval whose bindings are the\n"
1383 "union of the bindings in the environments @var{local} and\n"
1384 "@var{imported}, with bindings from @var{local} taking\n"
1385 "precedence. Definitions made in eval are placed in @var{local}.\n"
1386 "Applying @code{environment-define} or\n"
1387 "@code{environment-undefine} to eval has the same effect as\n"
1388 "applying the procedure to @var{local}.\n"
1389 "Note that eval incorporates @var{local} and @var{imported} by\n"
1391 "If, after creating eval, the program changes the bindings of\n"
1392 "@var{local} or @var{imported}, those changes will be visible\n"
1394 "Since most Scheme evaluation takes place in eval environments,\n"
1395 "they transparently cache the bindings received from @var{local}\n"
1396 "and @var{imported}. Thus, the first time the program looks up\n"
1397 "a symbol in eval, eval may make calls to @var{local} or\n"
1398 "@var{imported} to find their bindings, but subsequent\n"
1399 "references to that symbol will be as fast as references to\n"
1400 "bindings in finite environments.\n"
1401 "In typical use, @var{local} will be a finite environment, and\n"
1402 "@var{imported} will be an import environment")
1403 #define FUNC_NAME s_scm_make_eval_environment
1406 struct eval_environment
*body
;
1408 SCM_ASSERT (SCM_ENVIRONMENT_P (local
), local
, SCM_ARG1
, FUNC_NAME
);
1409 SCM_ASSERT (SCM_ENVIRONMENT_P (imported
), imported
, SCM_ARG2
, FUNC_NAME
);
1411 body
= scm_gc_malloc (sizeof (struct eval_environment
), "eval environment");
1413 core_environments_preinit (&body
->base
);
1414 body
->obarray
= SCM_BOOL_F
;
1415 body
->imported
= SCM_BOOL_F
;
1416 body
->imported_observer
= SCM_BOOL_F
;
1417 body
->local
= SCM_BOOL_F
;
1418 body
->local_observer
= SCM_BOOL_F
;
1420 env
= scm_make_environment (body
);
1422 core_environments_init (&body
->base
, &eval_environment_funcs
);
1423 body
->obarray
= scm_c_make_hash_table (DEFAULT_OBARRAY_SIZE
);
1424 body
->imported
= imported
;
1425 body
->imported_observer
1426 = SCM_ENVIRONMENT_OBSERVE (imported
, eval_environment_observer
, env
, 1);
1427 body
->local
= local
;
1428 body
->local_observer
1429 = SCM_ENVIRONMENT_OBSERVE (local
, eval_environment_observer
, env
, 1);
1436 SCM_DEFINE (scm_eval_environment_p
, "eval-environment?", 1, 0, 0,
1438 "Return @code{#t} if object is an eval environment, or @code{#f}\n"
1440 #define FUNC_NAME s_scm_eval_environment_p
1442 return scm_from_bool (SCM_EVAL_ENVIRONMENT_P (object
));
1447 SCM_DEFINE (scm_eval_environment_local
, "eval-environment-local", 1, 0, 0,
1449 "Return the local environment of eval environment @var{env}.")
1450 #define FUNC_NAME s_scm_eval_environment_local
1452 SCM_ASSERT (SCM_EVAL_ENVIRONMENT_P (env
), env
, SCM_ARG1
, FUNC_NAME
);
1454 return EVAL_ENVIRONMENT (env
)->local
;
1459 SCM_DEFINE (scm_eval_environment_set_local_x
, "eval-environment-set-local!", 2, 0, 0,
1460 (SCM env
, SCM local
),
1461 "Change @var{env}'s local environment to @var{local}.")
1462 #define FUNC_NAME s_scm_eval_environment_set_local_x
1464 struct eval_environment
*body
;
1466 SCM_ASSERT (SCM_EVAL_ENVIRONMENT_P (env
), env
, SCM_ARG1
, FUNC_NAME
);
1467 SCM_ASSERT (SCM_ENVIRONMENT_P (local
), local
, SCM_ARG2
, FUNC_NAME
);
1469 body
= EVAL_ENVIRONMENT (env
);
1471 obarray_remove_all (body
->obarray
);
1472 SCM_ENVIRONMENT_UNOBSERVE (body
->local
, body
->local_observer
);
1474 body
->local
= local
;
1475 body
->local_observer
1476 = SCM_ENVIRONMENT_OBSERVE (local
, eval_environment_observer
, env
, 1);
1478 core_environments_broadcast (env
);
1480 return SCM_UNSPECIFIED
;
1485 SCM_DEFINE (scm_eval_environment_imported
, "eval-environment-imported", 1, 0, 0,
1487 "Return the imported environment of eval environment @var{env}.")
1488 #define FUNC_NAME s_scm_eval_environment_imported
1490 SCM_ASSERT (SCM_EVAL_ENVIRONMENT_P (env
), env
, SCM_ARG1
, FUNC_NAME
);
1492 return EVAL_ENVIRONMENT (env
)->imported
;
1497 SCM_DEFINE (scm_eval_environment_set_imported_x
, "eval-environment-set-imported!", 2, 0, 0,
1498 (SCM env
, SCM imported
),
1499 "Change @var{env}'s imported environment to @var{imported}.")
1500 #define FUNC_NAME s_scm_eval_environment_set_imported_x
1502 struct eval_environment
*body
;
1504 SCM_ASSERT (SCM_EVAL_ENVIRONMENT_P (env
), env
, SCM_ARG1
, FUNC_NAME
);
1505 SCM_ASSERT (SCM_ENVIRONMENT_P (imported
), imported
, SCM_ARG2
, FUNC_NAME
);
1507 body
= EVAL_ENVIRONMENT (env
);
1509 obarray_remove_all (body
->obarray
);
1510 SCM_ENVIRONMENT_UNOBSERVE (body
->imported
, body
->imported_observer
);
1512 body
->imported
= imported
;
1513 body
->imported_observer
1514 = SCM_ENVIRONMENT_OBSERVE (imported
, eval_environment_observer
, env
, 1);
1516 core_environments_broadcast (env
);
1518 return SCM_UNSPECIFIED
;
1524 /* import environments
1526 * An import environment combines the bindings of a set of argument
1527 * environments, and checks for naming clashes.
1529 * Implementation: The import environment does no caching at all. For every
1530 * access, the list of imported environments is scanned.
1534 struct import_environment
{
1535 struct core_environments_base base
;
1538 SCM import_observers
;
1544 #define IMPORT_ENVIRONMENT(env) \
1545 ((struct import_environment *) SCM_CELL_WORD_1 (env))
1549 /* Lookup will report one of the following distinct results:
1550 * a) <environment> if only environment binds the symbol.
1551 * b) (env-1 env-2 ...) for conflicting bindings in env-1, ...
1552 * c) SCM_UNDEFINED if there is no binding for the symbol.
1555 import_environment_lookup (SCM env
, SCM sym
)
1557 SCM imports
= IMPORT_ENVIRONMENT (env
)->imports
;
1558 SCM result
= SCM_UNDEFINED
;
1561 for (l
= imports
; !SCM_NULLP (l
); l
= SCM_CDR (l
))
1563 SCM imported
= SCM_CAR (l
);
1565 if (SCM_ENVIRONMENT_BOUND_P (imported
, sym
))
1567 if (SCM_UNBNDP (result
))
1569 else if (SCM_CONSP (result
))
1570 result
= scm_cons (imported
, result
);
1572 result
= scm_cons2 (imported
, result
, SCM_EOL
);
1576 if (SCM_CONSP (result
))
1577 return scm_reverse (result
);
1584 import_environment_conflict (SCM env
, SCM sym
, SCM imports
)
1586 SCM conflict_proc
= IMPORT_ENVIRONMENT (env
)->conflict_proc
;
1587 SCM args
= scm_cons2 (env
, sym
, scm_cons (imports
, SCM_EOL
));
1589 return scm_apply_0 (conflict_proc
, args
);
1594 import_environment_ref (SCM env
, SCM sym
)
1595 #define FUNC_NAME "import_environment_ref"
1597 SCM owner
= import_environment_lookup (env
, sym
);
1599 if (SCM_UNBNDP (owner
))
1601 return SCM_UNDEFINED
;
1603 else if (SCM_CONSP (owner
))
1605 SCM resolve
= import_environment_conflict (env
, sym
, owner
);
1607 if (SCM_ENVIRONMENT_P (resolve
))
1608 return SCM_ENVIRONMENT_REF (resolve
, sym
);
1610 return SCM_UNSPECIFIED
;
1614 return SCM_ENVIRONMENT_REF (owner
, sym
);
1621 import_environment_folder (SCM extended_data
, SCM symbol
, SCM value
, SCM tail
)
1622 #define FUNC_NAME "import_environment_fold"
1624 SCM import_env
= SCM_CAR (extended_data
);
1625 SCM imported_env
= SCM_CADR (extended_data
);
1626 SCM owner
= import_environment_lookup (import_env
, symbol
);
1627 SCM proc_as_nr
= SCM_CADDR (extended_data
);
1628 unsigned long int proc_as_ul
= scm_to_ulong (proc_as_nr
);
1629 scm_environment_folder proc
= (scm_environment_folder
) proc_as_ul
;
1630 SCM data
= SCM_CDDDR (extended_data
);
1632 if (SCM_CONSP (owner
) && scm_is_eq (SCM_CAR (owner
), imported_env
))
1633 owner
= import_environment_conflict (import_env
, symbol
, owner
);
1635 if (SCM_ENVIRONMENT_P (owner
))
1636 return (*proc
) (data
, symbol
, value
, tail
);
1637 else /* unresolved conflict */
1638 return (*proc
) (data
, symbol
, SCM_UNSPECIFIED
, tail
);
1644 import_environment_fold (SCM env
, scm_environment_folder proc
, SCM data
, SCM init
)
1646 SCM proc_as_nr
= scm_from_ulong ((unsigned long) proc
);
1650 for (l
= IMPORT_ENVIRONMENT (env
)->imports
; !SCM_NULLP (l
); l
= SCM_CDR (l
))
1652 SCM imported_env
= SCM_CAR (l
);
1653 SCM extended_data
= scm_cons (env
, scm_cons2 (imported_env
, proc_as_nr
, data
));
1655 result
= scm_c_environment_fold (imported_env
, import_environment_folder
, extended_data
, result
);
1663 import_environment_define (SCM env SCM_UNUSED
,
1666 #define FUNC_NAME "import_environment_define"
1668 return SCM_ENVIRONMENT_BINDING_IMMUTABLE
;
1674 import_environment_undefine (SCM env SCM_UNUSED
,
1676 #define FUNC_NAME "import_environment_undefine"
1678 return SCM_ENVIRONMENT_BINDING_IMMUTABLE
;
1684 import_environment_set_x (SCM env
, SCM sym
, SCM val
)
1685 #define FUNC_NAME "import_environment_set_x"
1687 SCM owner
= import_environment_lookup (env
, sym
);
1689 if (SCM_UNBNDP (owner
))
1691 return SCM_UNDEFINED
;
1693 else if (SCM_CONSP (owner
))
1695 SCM resolve
= import_environment_conflict (env
, sym
, owner
);
1697 if (SCM_ENVIRONMENT_P (resolve
))
1698 return SCM_ENVIRONMENT_SET (resolve
, sym
, val
);
1700 return SCM_ENVIRONMENT_LOCATION_IMMUTABLE
;
1704 return SCM_ENVIRONMENT_SET (owner
, sym
, val
);
1711 import_environment_cell (SCM env
, SCM sym
, int for_write
)
1712 #define FUNC_NAME "import_environment_cell"
1714 SCM owner
= import_environment_lookup (env
, sym
);
1716 if (SCM_UNBNDP (owner
))
1718 return SCM_UNDEFINED
;
1720 else if (SCM_CONSP (owner
))
1722 SCM resolve
= import_environment_conflict (env
, sym
, owner
);
1724 if (SCM_ENVIRONMENT_P (resolve
))
1725 return SCM_ENVIRONMENT_CELL (resolve
, sym
, for_write
);
1727 return SCM_ENVIRONMENT_LOCATION_NO_CELL
;
1731 return SCM_ENVIRONMENT_CELL (owner
, sym
, for_write
);
1738 import_environment_mark (SCM env
)
1740 scm_gc_mark (IMPORT_ENVIRONMENT (env
)->imports
);
1741 scm_gc_mark (IMPORT_ENVIRONMENT (env
)->import_observers
);
1742 scm_gc_mark (IMPORT_ENVIRONMENT (env
)->conflict_proc
);
1743 return core_environments_mark (env
);
1748 import_environment_free (SCM env
)
1750 core_environments_finalize (env
);
1751 scm_gc_free (IMPORT_ENVIRONMENT (env
), sizeof (struct import_environment
),
1752 "import environment");
1757 import_environment_print (SCM type
, SCM port
,
1758 scm_print_state
*pstate SCM_UNUSED
)
1760 SCM address
= scm_from_size_t (SCM_UNPACK (type
));
1761 SCM base16
= scm_number_to_string (address
, scm_from_int (16));
1763 scm_puts ("#<import environment ", port
);
1764 scm_display (base16
, port
);
1765 scm_puts (">", port
);
1771 static struct scm_environment_funcs import_environment_funcs
= {
1772 import_environment_ref
,
1773 import_environment_fold
,
1774 import_environment_define
,
1775 import_environment_undefine
,
1776 import_environment_set_x
,
1777 import_environment_cell
,
1778 core_environments_observe
,
1779 core_environments_unobserve
,
1780 import_environment_mark
,
1781 import_environment_free
,
1782 import_environment_print
1786 void *scm_type_import_environment
= &import_environment_funcs
;
1790 import_environment_observer (SCM caller SCM_UNUSED
, SCM import_env
)
1792 core_environments_broadcast (import_env
);
1796 SCM_DEFINE (scm_make_import_environment
, "make-import-environment", 2, 0, 0,
1797 (SCM imports
, SCM conflict_proc
),
1798 "Return a new environment @var{imp} whose bindings are the union\n"
1799 "of the bindings from the environments in @var{imports};\n"
1800 "@var{imports} must be a list of environments. That is,\n"
1801 "@var{imp} binds a symbol to a location when some element of\n"
1802 "@var{imports} does.\n"
1803 "If two different elements of @var{imports} have a binding for\n"
1804 "the same symbol, the @var{conflict-proc} is called with the\n"
1805 "following parameters: the import environment, the symbol and\n"
1806 "the list of the imported environments that bind the symbol.\n"
1807 "If the @var{conflict-proc} returns an environment @var{env},\n"
1808 "the conflict is considered as resolved and the binding from\n"
1809 "@var{env} is used. If the @var{conflict-proc} returns some\n"
1810 "non-environment object, the conflict is considered unresolved\n"
1811 "and the symbol is treated as unspecified in the import\n"
1813 "The checking for conflicts may be performed lazily, i. e. at\n"
1814 "the moment when a value or binding for a certain symbol is\n"
1815 "requested instead of the moment when the environment is\n"
1816 "created or the bindings of the imports change.\n"
1817 "All bindings in @var{imp} are immutable. If you apply\n"
1818 "@code{environment-define} or @code{environment-undefine} to\n"
1819 "@var{imp}, Guile will signal an\n"
1820 " @code{environment:immutable-binding} error. However,\n"
1821 "notice that the set of bindings in @var{imp} may still change,\n"
1822 "if one of its imported environments changes.")
1823 #define FUNC_NAME s_scm_make_import_environment
1825 size_t size
= sizeof (struct import_environment
);
1826 struct import_environment
*body
= scm_gc_malloc (size
, "import environment");
1829 core_environments_preinit (&body
->base
);
1830 body
->imports
= SCM_BOOL_F
;
1831 body
->import_observers
= SCM_BOOL_F
;
1832 body
->conflict_proc
= SCM_BOOL_F
;
1834 env
= scm_make_environment (body
);
1836 core_environments_init (&body
->base
, &import_environment_funcs
);
1837 body
->imports
= SCM_EOL
;
1838 body
->import_observers
= SCM_EOL
;
1839 body
->conflict_proc
= conflict_proc
;
1841 scm_import_environment_set_imports_x (env
, imports
);
1848 SCM_DEFINE (scm_import_environment_p
, "import-environment?", 1, 0, 0,
1850 "Return @code{#t} if object is an import environment, or\n"
1851 "@code{#f} otherwise.")
1852 #define FUNC_NAME s_scm_import_environment_p
1854 return scm_from_bool (SCM_IMPORT_ENVIRONMENT_P (object
));
1859 SCM_DEFINE (scm_import_environment_imports
, "import-environment-imports", 1, 0, 0,
1861 "Return the list of environments imported by the import\n"
1862 "environment @var{env}.")
1863 #define FUNC_NAME s_scm_import_environment_imports
1865 SCM_ASSERT (SCM_IMPORT_ENVIRONMENT_P (env
), env
, SCM_ARG1
, FUNC_NAME
);
1867 return IMPORT_ENVIRONMENT (env
)->imports
;
1872 SCM_DEFINE (scm_import_environment_set_imports_x
, "import-environment-set-imports!", 2, 0, 0,
1873 (SCM env
, SCM imports
),
1874 "Change @var{env}'s list of imported environments to\n"
1875 "@var{imports}, and check for conflicts.")
1876 #define FUNC_NAME s_scm_import_environment_set_imports_x
1878 struct import_environment
*body
= IMPORT_ENVIRONMENT (env
);
1879 SCM import_observers
= SCM_EOL
;
1882 SCM_ASSERT (SCM_IMPORT_ENVIRONMENT_P (env
), env
, SCM_ARG1
, FUNC_NAME
);
1883 for (l
= imports
; SCM_CONSP (l
); l
= SCM_CDR (l
))
1885 SCM obj
= SCM_CAR (l
);
1886 SCM_ASSERT (SCM_ENVIRONMENT_P (obj
), imports
, SCM_ARG2
, FUNC_NAME
);
1888 SCM_ASSERT (SCM_NULLP (l
), imports
, SCM_ARG2
, FUNC_NAME
);
1890 for (l
= body
->import_observers
; !SCM_NULLP (l
); l
= SCM_CDR (l
))
1892 SCM obs
= SCM_CAR (l
);
1893 SCM_ENVIRONMENT_UNOBSERVE (env
, obs
);
1896 for (l
= imports
; !SCM_NULLP (l
); l
= SCM_CDR (l
))
1898 SCM imp
= SCM_CAR (l
);
1899 SCM obs
= SCM_ENVIRONMENT_OBSERVE (imp
, import_environment_observer
, env
, 1);
1900 import_observers
= scm_cons (obs
, import_observers
);
1903 body
->imports
= imports
;
1904 body
->import_observers
= import_observers
;
1906 return SCM_UNSPECIFIED
;
1912 /* export environments
1914 * An export environment restricts an environment to a specified set of
1917 * Implementation: The export environment does no caching at all. For every
1918 * access, the signature is scanned. The signature that is stored internally
1919 * is an alist of pairs (symbol . (mutability)).
1923 struct export_environment
{
1924 struct core_environments_base base
;
1927 SCM private_observer
;
1933 #define EXPORT_ENVIRONMENT(env) \
1934 ((struct export_environment *) SCM_CELL_WORD_1 (env))
1937 SCM_SYMBOL (symbol_immutable_location
, "immutable-location");
1938 SCM_SYMBOL (symbol_mutable_location
, "mutable-location");
1943 export_environment_ref (SCM env
, SCM sym
)
1944 #define FUNC_NAME "export_environment_ref"
1946 struct export_environment
*body
= EXPORT_ENVIRONMENT (env
);
1947 SCM entry
= scm_assq (sym
, body
->signature
);
1949 if (scm_is_false (entry
))
1950 return SCM_UNDEFINED
;
1952 return SCM_ENVIRONMENT_REF (body
->private, sym
);
1958 export_environment_fold (SCM env
, scm_environment_folder proc
, SCM data
, SCM init
)
1960 struct export_environment
*body
= EXPORT_ENVIRONMENT (env
);
1964 for (l
= body
->signature
; !SCM_NULLP (l
); l
= SCM_CDR (l
))
1966 SCM symbol
= SCM_CAR (l
);
1967 SCM value
= SCM_ENVIRONMENT_REF (body
->private, symbol
);
1968 if (!SCM_UNBNDP (value
))
1969 result
= (*proc
) (data
, symbol
, value
, result
);
1976 export_environment_define (SCM env SCM_UNUSED
,
1979 #define FUNC_NAME "export_environment_define"
1981 return SCM_ENVIRONMENT_BINDING_IMMUTABLE
;
1987 export_environment_undefine (SCM env SCM_UNUSED
, SCM sym SCM_UNUSED
)
1988 #define FUNC_NAME "export_environment_undefine"
1990 return SCM_ENVIRONMENT_BINDING_IMMUTABLE
;
1996 export_environment_set_x (SCM env
, SCM sym
, SCM val
)
1997 #define FUNC_NAME "export_environment_set_x"
1999 struct export_environment
*body
= EXPORT_ENVIRONMENT (env
);
2000 SCM entry
= scm_assq (sym
, body
->signature
);
2002 if (scm_is_false (entry
))
2004 return SCM_UNDEFINED
;
2008 if (scm_is_eq (SCM_CADR (entry
), symbol_mutable_location
))
2009 return SCM_ENVIRONMENT_SET (body
->private, sym
, val
);
2011 return SCM_ENVIRONMENT_LOCATION_IMMUTABLE
;
2018 export_environment_cell (SCM env
, SCM sym
, int for_write
)
2019 #define FUNC_NAME "export_environment_cell"
2021 struct export_environment
*body
= EXPORT_ENVIRONMENT (env
);
2022 SCM entry
= scm_assq (sym
, body
->signature
);
2024 if (scm_is_false (entry
))
2026 return SCM_UNDEFINED
;
2030 if (!for_write
|| scm_is_eq (SCM_CADR (entry
), symbol_mutable_location
))
2031 return SCM_ENVIRONMENT_CELL (body
->private, sym
, for_write
);
2033 return SCM_ENVIRONMENT_LOCATION_IMMUTABLE
;
2040 export_environment_mark (SCM env
)
2042 struct export_environment
*body
= EXPORT_ENVIRONMENT (env
);
2044 scm_gc_mark (body
->private);
2045 scm_gc_mark (body
->private_observer
);
2046 scm_gc_mark (body
->signature
);
2048 return core_environments_mark (env
);
2053 export_environment_free (SCM env
)
2055 core_environments_finalize (env
);
2056 scm_gc_free (EXPORT_ENVIRONMENT (env
), sizeof (struct export_environment
),
2057 "export environment");
2062 export_environment_print (SCM type
, SCM port
,
2063 scm_print_state
*pstate SCM_UNUSED
)
2065 SCM address
= scm_from_size_t (SCM_UNPACK (type
));
2066 SCM base16
= scm_number_to_string (address
, scm_from_int (16));
2068 scm_puts ("#<export environment ", port
);
2069 scm_display (base16
, port
);
2070 scm_puts (">", port
);
2076 static struct scm_environment_funcs export_environment_funcs
= {
2077 export_environment_ref
,
2078 export_environment_fold
,
2079 export_environment_define
,
2080 export_environment_undefine
,
2081 export_environment_set_x
,
2082 export_environment_cell
,
2083 core_environments_observe
,
2084 core_environments_unobserve
,
2085 export_environment_mark
,
2086 export_environment_free
,
2087 export_environment_print
2091 void *scm_type_export_environment
= &export_environment_funcs
;
2095 export_environment_observer (SCM caller SCM_UNUSED
, SCM export_env
)
2097 core_environments_broadcast (export_env
);
2101 SCM_DEFINE (scm_make_export_environment
, "make-export-environment", 2, 0, 0,
2102 (SCM
private, SCM signature
),
2103 "Return a new environment @var{exp} containing only those\n"
2104 "bindings in private whose symbols are present in\n"
2105 "@var{signature}. The @var{private} argument must be an\n"
2107 "The environment @var{exp} binds symbol to location when\n"
2108 "@var{env} does, and symbol is exported by @var{signature}.\n\n"
2109 "@var{signature} is a list specifying which of the bindings in\n"
2110 "@var{private} should be visible in @var{exp}. Each element of\n"
2111 "@var{signature} should be a list of the form:\n"
2112 " (symbol attribute ...)\n"
2113 "where each attribute is one of the following:\n"
2115 "@item the symbol @code{mutable-location}\n"
2116 " @var{exp} should treat the\n"
2117 " location bound to symbol as mutable. That is, @var{exp}\n"
2118 " will pass calls to @code{environment-set!} or\n"
2119 " @code{environment-cell} directly through to private.\n"
2120 "@item the symbol @code{immutable-location}\n"
2121 " @var{exp} should treat\n"
2122 " the location bound to symbol as immutable. If the program\n"
2123 " applies @code{environment-set!} to @var{exp} and symbol, or\n"
2124 " calls @code{environment-cell} to obtain a writable value\n"
2125 " cell, @code{environment-set!} will signal an\n"
2126 " @code{environment:immutable-location} error. Note that, even\n"
2127 " if an export environment treats a location as immutable, the\n"
2128 " underlying environment may treat it as mutable, so its\n"
2129 " value may change.\n"
2131 "It is an error for an element of signature to specify both\n"
2132 "@code{mutable-location} and @code{immutable-location}. If\n"
2133 "neither is specified, @code{immutable-location} is assumed.\n\n"
2134 "As a special case, if an element of signature is a lone\n"
2135 "symbol @var{sym}, it is equivalent to an element of the form\n"
2137 "All bindings in @var{exp} are immutable. If you apply\n"
2138 "@code{environment-define} or @code{environment-undefine} to\n"
2139 "@var{exp}, Guile will signal an\n"
2140 "@code{environment:immutable-binding} error. However,\n"
2141 "notice that the set of bindings in @var{exp} may still change,\n"
2142 "if the bindings in private change.")
2143 #define FUNC_NAME s_scm_make_export_environment
2146 struct export_environment
*body
;
2149 SCM_ASSERT (SCM_ENVIRONMENT_P (private), private, SCM_ARG1
, FUNC_NAME
);
2151 size
= sizeof (struct export_environment
);
2152 body
= scm_gc_malloc (size
, "export environment");
2154 core_environments_preinit (&body
->base
);
2155 body
->private = SCM_BOOL_F
;
2156 body
->private_observer
= SCM_BOOL_F
;
2157 body
->signature
= SCM_BOOL_F
;
2159 env
= scm_make_environment (body
);
2161 core_environments_init (&body
->base
, &export_environment_funcs
);
2162 body
->private = private;
2163 body
->private_observer
2164 = SCM_ENVIRONMENT_OBSERVE (private, export_environment_observer
, env
, 1);
2165 body
->signature
= SCM_EOL
;
2167 scm_export_environment_set_signature_x (env
, signature
);
2174 SCM_DEFINE (scm_export_environment_p
, "export-environment?", 1, 0, 0,
2176 "Return @code{#t} if object is an export environment, or\n"
2177 "@code{#f} otherwise.")
2178 #define FUNC_NAME s_scm_export_environment_p
2180 return scm_from_bool (SCM_EXPORT_ENVIRONMENT_P (object
));
2185 SCM_DEFINE (scm_export_environment_private
, "export-environment-private", 1, 0, 0,
2187 "Return the private environment of export environment @var{env}.")
2188 #define FUNC_NAME s_scm_export_environment_private
2190 SCM_ASSERT (SCM_EXPORT_ENVIRONMENT_P (env
), env
, SCM_ARG1
, FUNC_NAME
);
2192 return EXPORT_ENVIRONMENT (env
)->private;
2197 SCM_DEFINE (scm_export_environment_set_private_x
, "export-environment-set-private!", 2, 0, 0,
2198 (SCM env
, SCM
private),
2199 "Change the private environment of export environment @var{env}.")
2200 #define FUNC_NAME s_scm_export_environment_set_private_x
2202 struct export_environment
*body
;
2204 SCM_ASSERT (SCM_EXPORT_ENVIRONMENT_P (env
), env
, SCM_ARG1
, FUNC_NAME
);
2205 SCM_ASSERT (SCM_ENVIRONMENT_P (private), private, SCM_ARG2
, FUNC_NAME
);
2207 body
= EXPORT_ENVIRONMENT (env
);
2208 SCM_ENVIRONMENT_UNOBSERVE (private, body
->private_observer
);
2210 body
->private = private;
2211 body
->private_observer
2212 = SCM_ENVIRONMENT_OBSERVE (private, export_environment_observer
, env
, 1);
2214 return SCM_UNSPECIFIED
;
2219 SCM_DEFINE (scm_export_environment_signature
, "export-environment-signature", 1, 0, 0,
2221 "Return the signature of export environment @var{env}.")
2222 #define FUNC_NAME s_scm_export_environment_signature
2224 SCM_ASSERT (SCM_EXPORT_ENVIRONMENT_P (env
), env
, SCM_ARG1
, FUNC_NAME
);
2226 return EXPORT_ENVIRONMENT (env
)->signature
;
2232 export_environment_parse_signature (SCM signature
, const char* caller
)
2234 SCM result
= SCM_EOL
;
2237 for (l
= signature
; SCM_CONSP (l
); l
= SCM_CDR (l
))
2239 SCM entry
= SCM_CAR (l
);
2241 if (SCM_SYMBOLP (entry
))
2243 SCM new_entry
= scm_cons2 (entry
, symbol_immutable_location
, SCM_EOL
);
2244 result
= scm_cons (new_entry
, result
);
2255 SCM_ASSERT (SCM_CONSP (entry
), entry
, SCM_ARGn
, caller
);
2256 SCM_ASSERT (SCM_SYMBOLP (SCM_CAR (entry
)), entry
, SCM_ARGn
, caller
);
2258 sym
= SCM_CAR (entry
);
2260 for (l2
= SCM_CDR (entry
); SCM_CONSP (l2
); l2
= SCM_CDR (l2
))
2262 SCM attribute
= SCM_CAR (l2
);
2263 if (scm_is_eq (attribute
, symbol_immutable_location
))
2265 else if (scm_is_eq (attribute
, symbol_mutable_location
))
2268 SCM_ASSERT (0, entry
, SCM_ARGn
, caller
);
2270 SCM_ASSERT (SCM_NULLP (l2
), entry
, SCM_ARGn
, caller
);
2271 SCM_ASSERT (!mutable || !immutable
, entry
, SCM_ARGn
, caller
);
2273 if (!mutable && !immutable
)
2276 mutability
= mutable ? symbol_mutable_location
: symbol_immutable_location
;
2277 new_entry
= scm_cons2 (sym
, mutability
, SCM_EOL
);
2278 result
= scm_cons (new_entry
, result
);
2281 SCM_ASSERT (SCM_NULLP (l
), signature
, SCM_ARGn
, caller
);
2283 /* Dirk:FIXME:: Now we know that signature is syntactically correct. There
2284 * are, however, no checks for symbols entered twice with contradicting
2285 * mutabilities. It would be nice, to implement this test, to be able to
2286 * call the sort functions conveniently from C.
2289 return scm_reverse (result
);
2293 SCM_DEFINE (scm_export_environment_set_signature_x
, "export-environment-set-signature!", 2, 0, 0,
2294 (SCM env
, SCM signature
),
2295 "Change the signature of export environment @var{env}.")
2296 #define FUNC_NAME s_scm_export_environment_set_signature_x
2300 SCM_ASSERT (SCM_EXPORT_ENVIRONMENT_P (env
), env
, SCM_ARG1
, FUNC_NAME
);
2301 parsed_sig
= export_environment_parse_signature (signature
, FUNC_NAME
);
2303 EXPORT_ENVIRONMENT (env
)->signature
= parsed_sig
;
2305 return SCM_UNSPECIFIED
;
2312 scm_environments_prehistory ()
2314 /* create environment smob */
2315 scm_tc16_environment
= scm_make_smob_type ("environment", 0);
2316 scm_set_smob_mark (scm_tc16_environment
, environment_mark
);
2317 scm_set_smob_free (scm_tc16_environment
, environment_free
);
2318 scm_set_smob_print (scm_tc16_environment
, environment_print
);
2320 /* create observer smob */
2321 scm_tc16_observer
= scm_make_smob_type ("observer", 0);
2322 scm_set_smob_mark (scm_tc16_observer
, observer_mark
);
2323 scm_set_smob_print (scm_tc16_observer
, observer_print
);
2325 /* create system environment */
2326 scm_system_environment
= scm_make_leaf_environment ();
2327 scm_permanent_object (scm_system_environment
);
2332 scm_init_environments ()
2334 #include "libguile/environments.x"