1 /* Copyright (C) 1999,2000,2001, 2003, 2006, 2008 Free Software Foundation, Inc.
3 * This library is free software; you can redistribute it and/or
4 * modify it under the terms of the GNU Lesser General Public
5 * License as published by the Free Software Foundation; either
6 * version 2.1 of the License, or (at your option) any later version.
8 * This library is distributed in the hope that it will be useful,
9 * but WITHOUT ANY WARRANTY; without even the implied warranty of
10 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
11 * Lesser General Public License for more details.
13 * You should have received a copy of the GNU Lesser General Public
14 * License along with this library; if not, write to the Free Software
15 * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
23 #include "libguile/_scm.h"
24 #include "libguile/alist.h"
25 #include "libguile/eval.h"
26 #include "libguile/hash.h"
27 #include "libguile/list.h"
28 #include "libguile/ports.h"
29 #include "libguile/smob.h"
30 #include "libguile/symbols.h"
31 #include "libguile/vectors.h"
32 #include "libguile/weaks.h"
34 #include "libguile/environments.h"
38 scm_t_bits scm_tc16_environment
;
39 scm_t_bits scm_tc16_observer
;
40 #define DEFAULT_OBARRAY_SIZE 31
42 SCM scm_system_environment
;
46 /* error conditions */
49 * Throw an error if symbol is not bound in environment func
52 scm_error_environment_unbound (const char *func
, SCM env
, SCM symbol
)
54 /* Dirk:FIXME:: Should throw an environment:unbound type error */
55 char error
[] = "Symbol `~A' not bound in environment `~A'.";
56 SCM arguments
= scm_cons2 (symbol
, env
, SCM_EOL
);
57 scm_misc_error (func
, error
, arguments
);
62 * Throw an error if func tried to create (define) or remove
63 * (undefine) a new binding for symbol in env
66 scm_error_environment_immutable_binding (const char *func
, SCM env
, SCM symbol
)
68 /* Dirk:FIXME:: Should throw an environment:immutable-binding type error */
69 char error
[] = "Immutable binding in environment ~A (symbol: `~A').";
70 SCM arguments
= scm_cons2 (env
, symbol
, SCM_EOL
);
71 scm_misc_error (func
, error
, arguments
);
76 * Throw an error if func tried to change an immutable location.
79 scm_error_environment_immutable_location (const char *func
, SCM env
, SCM symbol
)
81 /* Dirk:FIXME:: Should throw an environment:immutable-location type error */
82 char error
[] = "Immutable location in environment `~A' (symbol: `~A').";
83 SCM arguments
= scm_cons2 (env
, symbol
, SCM_EOL
);
84 scm_misc_error (func
, error
, arguments
);
89 /* generic environments */
92 /* Create an environment for the given type. Dereferencing type twice must
93 * deliver the initialized set of environment functions. Thus, type will
94 * also determine the signature of the underlying environment implementation.
95 * Dereferencing type once will typically deliver the data fields used by the
96 * underlying environment implementation.
99 scm_make_environment (void *type
)
101 return scm_cell (scm_tc16_environment
, (scm_t_bits
) type
);
105 SCM_DEFINE (scm_environment_p
, "environment?", 1, 0, 0,
107 "Return @code{#t} if @var{obj} is an environment, or @code{#f}\n"
109 #define FUNC_NAME s_scm_environment_p
111 return scm_from_bool (SCM_ENVIRONMENT_P (obj
));
116 SCM_DEFINE (scm_environment_bound_p
, "environment-bound?", 2, 0, 0,
118 "Return @code{#t} if @var{sym} is bound in @var{env}, or\n"
119 "@code{#f} otherwise.")
120 #define FUNC_NAME s_scm_environment_bound_p
122 SCM_ASSERT (SCM_ENVIRONMENT_P (env
), env
, SCM_ARG1
, FUNC_NAME
);
123 SCM_ASSERT (scm_is_symbol (sym
), sym
, SCM_ARG2
, FUNC_NAME
);
125 return scm_from_bool (SCM_ENVIRONMENT_BOUND_P (env
, sym
));
130 SCM_DEFINE (scm_environment_ref
, "environment-ref", 2, 0, 0,
132 "Return the value of the location bound to @var{sym} in\n"
133 "@var{env}. If @var{sym} is unbound in @var{env}, signal an\n"
134 "@code{environment:unbound} error.")
135 #define FUNC_NAME s_scm_environment_ref
139 SCM_ASSERT (SCM_ENVIRONMENT_P (env
), env
, SCM_ARG1
, FUNC_NAME
);
140 SCM_ASSERT (scm_is_symbol (sym
), sym
, SCM_ARG2
, FUNC_NAME
);
142 val
= SCM_ENVIRONMENT_REF (env
, sym
);
144 if (!SCM_UNBNDP (val
))
147 scm_error_environment_unbound (FUNC_NAME
, env
, sym
);
152 /* This C function is identical to environment-ref, except that if symbol is
153 * unbound in env, it returns the value SCM_UNDEFINED, instead of signalling
157 scm_c_environment_ref (SCM env
, SCM sym
)
159 SCM_ASSERT (SCM_ENVIRONMENT_P (env
), env
, SCM_ARG1
, "scm_c_environment_ref");
160 SCM_ASSERT (scm_is_symbol (sym
), sym
, SCM_ARG2
, "scm_c_environment_ref");
161 return SCM_ENVIRONMENT_REF (env
, sym
);
166 environment_default_folder (SCM proc
, SCM symbol
, SCM value
, SCM tail
)
168 return scm_call_3 (proc
, symbol
, value
, tail
);
172 SCM_DEFINE (scm_environment_fold
, "environment-fold", 3, 0, 0,
173 (SCM env
, SCM proc
, SCM init
),
174 "Iterate over all the bindings in @var{env}, accumulating some\n"
176 "For each binding in @var{env}, apply @var{proc} to the symbol\n"
177 "bound, its value, and the result from the previous application\n"
179 "Use @var{init} as @var{proc}'s third argument the first time\n"
180 "@var{proc} is applied.\n"
181 "If @var{env} contains no bindings, this function simply returns\n"
183 "If @var{env} binds the symbol sym1 to the value val1, sym2 to\n"
184 "val2, and so on, then this procedure computes:\n"
192 "Each binding in @var{env} will be processed exactly once.\n"
193 "@code{environment-fold} makes no guarantees about the order in\n"
194 "which the bindings are processed.\n"
195 "Here is a function which, given an environment, constructs an\n"
196 "association list representing that environment's bindings,\n"
197 "using environment-fold:\n"
199 " (define (environment->alist env)\n"
200 " (environment-fold env\n"
201 " (lambda (sym val tail)\n"
202 " (cons (cons sym val) tail))\n"
205 #define FUNC_NAME s_scm_environment_fold
207 SCM_ASSERT (SCM_ENVIRONMENT_P (env
), env
, SCM_ARG1
, FUNC_NAME
);
208 SCM_ASSERT (scm_is_true (scm_procedure_p (proc
)),
209 proc
, SCM_ARG2
, FUNC_NAME
);
211 return SCM_ENVIRONMENT_FOLD (env
, environment_default_folder
, proc
, init
);
216 /* This is the C-level analog of environment-fold. For each binding in ENV,
218 * (*proc) (data, symbol, value, previous)
219 * where previous is the value returned from the last call to *PROC, or INIT
220 * for the first call. If ENV contains no bindings, return INIT.
223 scm_c_environment_fold (SCM env
, scm_environment_folder proc
, SCM data
, SCM init
)
225 SCM_ASSERT (SCM_ENVIRONMENT_P (env
), env
, SCM_ARG1
, "scm_c_environment_fold");
227 return SCM_ENVIRONMENT_FOLD (env
, proc
, data
, init
);
231 SCM_DEFINE (scm_environment_define
, "environment-define", 3, 0, 0,
232 (SCM env
, SCM sym
, SCM val
),
233 "Bind @var{sym} to a new location containing @var{val} in\n"
234 "@var{env}. If @var{sym} is already bound to another location\n"
235 "in @var{env} and the binding is mutable, that binding is\n"
236 "replaced. The new binding and location are both mutable. The\n"
237 "return value is unspecified.\n"
238 "If @var{sym} is already bound in @var{env}, and the binding is\n"
239 "immutable, signal an @code{environment:immutable-binding} error.")
240 #define FUNC_NAME s_scm_environment_define
244 SCM_ASSERT (SCM_ENVIRONMENT_P (env
), env
, SCM_ARG1
, FUNC_NAME
);
245 SCM_ASSERT (scm_is_symbol (sym
), sym
, SCM_ARG2
, FUNC_NAME
);
247 status
= SCM_ENVIRONMENT_DEFINE (env
, sym
, val
);
249 if (scm_is_eq (status
, SCM_ENVIRONMENT_SUCCESS
))
250 return SCM_UNSPECIFIED
;
251 else if (scm_is_eq (status
, SCM_ENVIRONMENT_BINDING_IMMUTABLE
))
252 scm_error_environment_immutable_binding (FUNC_NAME
, env
, sym
);
259 SCM_DEFINE (scm_environment_undefine
, "environment-undefine", 2, 0, 0,
261 "Remove any binding for @var{sym} from @var{env}. If @var{sym}\n"
262 "is unbound in @var{env}, do nothing. The return value is\n"
264 "If @var{sym} is already bound in @var{env}, and the binding is\n"
265 "immutable, signal an @code{environment:immutable-binding} error.")
266 #define FUNC_NAME s_scm_environment_undefine
270 SCM_ASSERT(SCM_ENVIRONMENT_P(env
), env
, SCM_ARG1
, FUNC_NAME
);
271 SCM_ASSERT(scm_is_symbol(sym
), sym
, SCM_ARG2
, FUNC_NAME
);
273 status
= SCM_ENVIRONMENT_UNDEFINE (env
, sym
);
275 if (scm_is_eq (status
, SCM_ENVIRONMENT_SUCCESS
))
276 return SCM_UNSPECIFIED
;
277 else if (scm_is_eq (status
, SCM_ENVIRONMENT_BINDING_IMMUTABLE
))
278 scm_error_environment_immutable_binding (FUNC_NAME
, env
, sym
);
285 SCM_DEFINE (scm_environment_set_x
, "environment-set!", 3, 0, 0,
286 (SCM env
, SCM sym
, SCM val
),
287 "If @var{env} binds @var{sym} to some location, change that\n"
288 "location's value to @var{val}. The return value is\n"
290 "If @var{sym} is not bound in @var{env}, signal an\n"
291 "@code{environment:unbound} error. If @var{env} binds @var{sym}\n"
292 "to an immutable location, signal an\n"
293 "@code{environment:immutable-location} error.")
294 #define FUNC_NAME s_scm_environment_set_x
298 SCM_ASSERT (SCM_ENVIRONMENT_P (env
), env
, SCM_ARG1
, FUNC_NAME
);
299 SCM_ASSERT (scm_is_symbol (sym
), sym
, SCM_ARG2
, FUNC_NAME
);
301 status
= SCM_ENVIRONMENT_SET (env
, sym
, val
);
303 if (scm_is_eq (status
, SCM_ENVIRONMENT_SUCCESS
))
304 return SCM_UNSPECIFIED
;
305 else if (SCM_UNBNDP (status
))
306 scm_error_environment_unbound (FUNC_NAME
, env
, sym
);
307 else if (scm_is_eq (status
, SCM_ENVIRONMENT_LOCATION_IMMUTABLE
))
308 scm_error_environment_immutable_binding (FUNC_NAME
, env
, sym
);
315 SCM_DEFINE (scm_environment_cell
, "environment-cell", 3, 0, 0,
316 (SCM env
, SCM sym
, SCM for_write
),
317 "Return the value cell which @var{env} binds to @var{sym}, or\n"
318 "@code{#f} if the binding does not live in a value cell.\n"
319 "The argument @var{for-write} indicates whether the caller\n"
320 "intends to modify the variable's value by mutating the value\n"
321 "cell. If the variable is immutable, then\n"
322 "@code{environment-cell} signals an\n"
323 "@code{environment:immutable-location} error.\n"
324 "If @var{sym} is unbound in @var{env}, signal an\n"
325 "@code{environment:unbound} error.\n"
326 "If you use this function, you should consider using\n"
327 "@code{environment-observe}, to be notified when @var{sym} gets\n"
328 "re-bound to a new value cell, or becomes undefined.")
329 #define FUNC_NAME s_scm_environment_cell
333 SCM_ASSERT (SCM_ENVIRONMENT_P (env
), env
, SCM_ARG1
, FUNC_NAME
);
334 SCM_ASSERT (scm_is_symbol (sym
), sym
, SCM_ARG2
, FUNC_NAME
);
335 SCM_ASSERT (scm_is_bool (for_write
), for_write
, SCM_ARG3
, FUNC_NAME
);
337 location
= SCM_ENVIRONMENT_CELL (env
, sym
, scm_is_true (for_write
));
338 if (!SCM_IMP (location
))
340 else if (SCM_UNBNDP (location
))
341 scm_error_environment_unbound (FUNC_NAME
, env
, sym
);
342 else if (scm_is_eq (location
, SCM_ENVIRONMENT_LOCATION_IMMUTABLE
))
343 scm_error_environment_immutable_location (FUNC_NAME
, env
, sym
);
350 /* This C function is identical to environment-cell, with the following
351 * exceptions: If symbol is unbound in env, it returns the value
352 * SCM_UNDEFINED, instead of signalling an error. If symbol is bound to an
353 * immutable location but the cell is requested for write, the value
354 * SCM_ENVIRONMENT_LOCATION_IMMUTABLE is returned.
357 scm_c_environment_cell(SCM env
, SCM sym
, int for_write
)
359 SCM_ASSERT (SCM_ENVIRONMENT_P (env
), env
, SCM_ARG1
, "scm_c_environment_cell");
360 SCM_ASSERT (scm_is_symbol (sym
), sym
, SCM_ARG2
, "scm_c_environment_cell");
362 return SCM_ENVIRONMENT_CELL (env
, sym
, for_write
);
367 environment_default_observer (SCM env
, SCM proc
)
369 scm_call_1 (proc
, env
);
373 SCM_DEFINE (scm_environment_observe
, "environment-observe", 2, 0, 0,
375 "Whenever @var{env}'s bindings change, apply @var{proc} to\n"
377 "This function returns an object, token, which you can pass to\n"
378 "@code{environment-unobserve} to remove @var{proc} from the set\n"
379 "of procedures observing @var{env}. The type and value of\n"
380 "token is unspecified.")
381 #define FUNC_NAME s_scm_environment_observe
383 SCM_ASSERT (SCM_ENVIRONMENT_P (env
), env
, SCM_ARG1
, FUNC_NAME
);
385 return SCM_ENVIRONMENT_OBSERVE (env
, environment_default_observer
, proc
, 0);
390 SCM_DEFINE (scm_environment_observe_weak
, "environment-observe-weak", 2, 0, 0,
392 "This function is the same as environment-observe, except that\n"
393 "the reference @var{env} retains to @var{proc} is a weak\n"
394 "reference. This means that, if there are no other live,\n"
395 "non-weak references to @var{proc}, it will be\n"
396 "garbage-collected, and dropped from @var{env}'s\n"
397 "list of observing procedures.")
398 #define FUNC_NAME s_scm_environment_observe_weak
400 SCM_ASSERT (SCM_ENVIRONMENT_P (env
), env
, SCM_ARG1
, FUNC_NAME
);
402 return SCM_ENVIRONMENT_OBSERVE (env
, environment_default_observer
, proc
, 1);
407 /* This is the C-level analog of the Scheme functions environment-observe and
408 * environment-observe-weak. Whenever env's bindings change, call the
409 * function proc, passing it env and data. If weak_p is non-zero, env will
410 * retain only a weak reference to data, and if data is garbage collected, the
411 * entire observation will be dropped. This function returns a token, with
412 * the same meaning as those returned by environment-observe and
413 * environment-observe-weak.
416 scm_c_environment_observe (SCM env
, scm_environment_observer proc
, SCM data
, int weak_p
)
417 #define FUNC_NAME "scm_c_environment_observe"
419 SCM_ASSERT (SCM_ENVIRONMENT_P (env
), env
, SCM_ARG1
, FUNC_NAME
);
421 return SCM_ENVIRONMENT_OBSERVE (env
, proc
, data
, weak_p
);
426 SCM_DEFINE (scm_environment_unobserve
, "environment-unobserve", 1, 0, 0,
428 "Cancel the observation request which returned the value\n"
429 "@var{token}. The return value is unspecified.\n"
430 "If a call @code{(environment-observe env proc)} returns\n"
431 "@var{token}, then the call @code{(environment-unobserve token)}\n"
432 "will cause @var{proc} to no longer be called when @var{env}'s\n"
434 #define FUNC_NAME s_scm_environment_unobserve
438 SCM_ASSERT (SCM_OBSERVER_P (token
), token
, SCM_ARG1
, FUNC_NAME
);
440 env
= SCM_OBSERVER_ENVIRONMENT (token
);
441 SCM_ENVIRONMENT_UNOBSERVE (env
, token
);
443 return SCM_UNSPECIFIED
;
449 environment_mark (SCM env
)
451 return (*(SCM_ENVIRONMENT_FUNCS (env
)->mark
)) (env
);
456 environment_free (SCM env
)
458 (*(SCM_ENVIRONMENT_FUNCS (env
)->free
)) (env
);
464 environment_print (SCM env
, SCM port
, scm_print_state
*pstate
)
466 return (*(SCM_ENVIRONMENT_FUNCS (env
)->print
)) (env
, port
, pstate
);
474 observer_mark (SCM observer
)
476 scm_gc_mark (SCM_OBSERVER_ENVIRONMENT (observer
));
477 scm_gc_mark (SCM_OBSERVER_DATA (observer
));
483 observer_print (SCM type
, SCM port
, scm_print_state
*pstate SCM_UNUSED
)
485 SCM address
= scm_from_size_t (SCM_UNPACK (type
));
486 SCM base16
= scm_number_to_string (address
, scm_from_int (16));
488 scm_puts ("#<observer ", port
);
489 scm_display (base16
, port
);
490 scm_puts (">", port
);
499 * Obarrays form the basic lookup tables used to implement most of guile's
500 * built-in environment types. An obarray is implemented as a hash table with
501 * symbols as keys. The content of the data depends on the environment type.
506 * Enter symbol into obarray. The symbol must not already exist in obarray.
507 * The freshly generated (symbol . data) cell is returned.
510 obarray_enter (SCM obarray
, SCM symbol
, SCM data
)
512 size_t hash
= scm_i_symbol_hash (symbol
) % SCM_HASHTABLE_N_BUCKETS (obarray
);
513 SCM entry
= scm_cons (symbol
, data
);
514 SCM slot
= scm_cons (entry
, SCM_HASHTABLE_BUCKET (obarray
, hash
));
515 SCM_SET_HASHTABLE_BUCKET (obarray
, hash
, slot
);
516 SCM_HASHTABLE_INCREMENT (obarray
);
517 if (SCM_HASHTABLE_N_ITEMS (obarray
) > SCM_HASHTABLE_UPPER (obarray
))
518 scm_i_rehash (obarray
, scm_i_hash_symbol
, 0, "obarray_enter");
525 * Enter symbol into obarray. An existing entry for symbol is replaced. If
526 * an entry existed, the old (symbol . data) cell is returned, #f otherwise.
529 obarray_replace (SCM obarray
, SCM symbol
, SCM data
)
531 size_t hash
= scm_i_symbol_hash (symbol
) % SCM_HASHTABLE_N_BUCKETS (obarray
);
532 SCM new_entry
= scm_cons (symbol
, data
);
536 for (lsym
= SCM_HASHTABLE_BUCKET (obarray
, hash
);
538 lsym
= SCM_CDR (lsym
))
540 SCM old_entry
= SCM_CAR (lsym
);
541 if (scm_is_eq (SCM_CAR (old_entry
), symbol
))
543 SCM_SETCAR (lsym
, new_entry
);
548 slot
= scm_cons (new_entry
, SCM_HASHTABLE_BUCKET (obarray
, hash
));
549 SCM_SET_HASHTABLE_BUCKET (obarray
, hash
, slot
);
550 SCM_HASHTABLE_INCREMENT (obarray
);
551 if (SCM_HASHTABLE_N_ITEMS (obarray
) > SCM_HASHTABLE_UPPER (obarray
))
552 scm_i_rehash (obarray
, scm_i_hash_symbol
, 0, "obarray_replace");
559 * Look up symbol in obarray
562 obarray_retrieve (SCM obarray
, SCM sym
)
564 size_t hash
= scm_i_symbol_hash (sym
) % SCM_HASHTABLE_N_BUCKETS (obarray
);
567 for (lsym
= SCM_HASHTABLE_BUCKET (obarray
, hash
);
569 lsym
= SCM_CDR (lsym
))
571 SCM entry
= SCM_CAR (lsym
);
572 if (scm_is_eq (SCM_CAR (entry
), sym
))
576 return SCM_UNDEFINED
;
581 * Remove entry from obarray. If the symbol was found and removed, the old
582 * (symbol . data) cell is returned, #f otherwise.
585 obarray_remove (SCM obarray
, SCM sym
)
587 size_t hash
= scm_i_symbol_hash (sym
) % SCM_HASHTABLE_N_BUCKETS (obarray
);
588 SCM table_entry
= SCM_HASHTABLE_BUCKET (obarray
, hash
);
589 SCM handle
= scm_sloppy_assq (sym
, table_entry
);
591 if (scm_is_pair (handle
))
593 SCM new_table_entry
= scm_delq1_x (handle
, table_entry
);
594 SCM_SET_HASHTABLE_BUCKET (obarray
, hash
, new_table_entry
);
595 SCM_HASHTABLE_DECREMENT (obarray
);
603 obarray_remove_all (SCM obarray
)
605 size_t size
= SCM_HASHTABLE_N_BUCKETS (obarray
);
608 for (i
= 0; i
< size
; i
++)
610 SCM_SET_HASHTABLE_BUCKET (obarray
, i
, SCM_EOL
);
612 SCM_SET_HASHTABLE_N_ITEMS (obarray
, 0);
617 /* core environments base
619 * This struct and the corresponding functions form a base class for guile's
620 * built-in environment types.
624 struct core_environments_base
{
625 struct scm_environment_funcs
*funcs
;
632 #define CORE_ENVIRONMENTS_BASE(env) \
633 ((struct core_environments_base *) SCM_CELL_WORD_1 (env))
634 #define CORE_ENVIRONMENT_OBSERVERS(env) \
635 (CORE_ENVIRONMENTS_BASE (env)->observers)
636 #define SCM_SET_CORE_ENVIRONMENT_OBSERVERS(env, v) \
637 (CORE_ENVIRONMENT_OBSERVERS (env) = (v))
638 #define CORE_ENVIRONMENT_WEAK_OBSERVER_VECTOR(env) \
639 (CORE_ENVIRONMENTS_BASE (env)->weak_observers)
640 #define CORE_ENVIRONMENT_WEAK_OBSERVERS(env) \
641 (scm_c_vector_ref (CORE_ENVIRONMENT_WEAK_OBSERVER_VECTOR (env), 0))
642 #define SCM_SET_CORE_ENVIRONMENT_WEAK_OBSERVERS(env, v) \
643 (scm_c_vector_set_x (CORE_ENVIRONMENT_WEAK_OBSERVER_VECTOR (env), 0, (v)))
648 core_environments_observe (SCM env
, scm_environment_observer proc
, SCM data
, int weak_p
)
650 SCM observer
= scm_double_cell (scm_tc16_observer
,
657 SCM observers
= CORE_ENVIRONMENT_OBSERVERS (env
);
658 SCM new_observers
= scm_cons (observer
, observers
);
659 SCM_SET_CORE_ENVIRONMENT_OBSERVERS (env
, new_observers
);
663 SCM observers
= CORE_ENVIRONMENT_WEAK_OBSERVERS (env
);
664 SCM new_observers
= scm_acons (SCM_BOOL_F
, observer
, observers
);
665 SCM_SET_CORE_ENVIRONMENT_WEAK_OBSERVERS (env
, new_observers
);
673 core_environments_unobserve (SCM env
, SCM observer
)
675 unsigned int handling_weaks
;
676 for (handling_weaks
= 0; handling_weaks
<= 1; ++handling_weaks
)
678 SCM l
= handling_weaks
679 ? CORE_ENVIRONMENT_WEAK_OBSERVERS (env
)
680 : CORE_ENVIRONMENT_OBSERVERS (env
);
682 if (!scm_is_null (l
))
684 SCM rest
= SCM_CDR (l
);
685 SCM first
= handling_weaks
689 if (scm_is_eq (first
, observer
))
691 /* Remove the first observer */
693 SCM_SET_CORE_ENVIRONMENT_WEAK_OBSERVERS (env
, rest
);
695 SCM_SET_CORE_ENVIRONMENT_OBSERVERS (env
, rest
);
700 SCM rest
= SCM_CDR (l
);
702 if (!scm_is_null (rest
))
704 SCM next
= handling_weaks
708 if (scm_is_eq (next
, observer
))
710 SCM_SETCDR (l
, SCM_CDR (rest
));
716 } while (!scm_is_null (l
));
720 /* Dirk:FIXME:: What to do now, since the observer is not found? */
725 core_environments_mark (SCM env
)
727 scm_gc_mark (CORE_ENVIRONMENT_OBSERVERS (env
));
728 return CORE_ENVIRONMENT_WEAK_OBSERVER_VECTOR (env
);
733 core_environments_finalize (SCM env SCM_UNUSED
)
739 core_environments_preinit (struct core_environments_base
*body
)
742 body
->observers
= SCM_BOOL_F
;
743 body
->weak_observers
= SCM_BOOL_F
;
748 core_environments_init (struct core_environments_base
*body
,
749 struct scm_environment_funcs
*funcs
)
752 body
->observers
= SCM_EOL
;
753 body
->weak_observers
= scm_make_weak_value_alist_vector (scm_from_int (1));
757 /* Tell all observers to clear their caches.
759 * Environments have to be informed about changes in the following cases:
760 * - The observed env has a new binding. This must be always reported.
761 * - The observed env has dropped a binding. This must be always reported.
762 * - A binding in the observed environment has changed. This must only be
763 * reported, if there is a chance that the binding is being cached outside.
764 * However, this potential optimization is not performed currently.
766 * Errors that occur while the observers are called are accumulated and
767 * signalled as one single error message to the caller.
778 update_catch_body (void *ptr
)
780 struct update_data
*data
= (struct update_data
*) ptr
;
781 SCM observer
= data
->observer
;
783 (*SCM_OBSERVER_PROC (observer
))
784 (data
->environment
, SCM_OBSERVER_DATA (observer
));
786 return SCM_UNDEFINED
;
791 update_catch_handler (void *ptr
, SCM tag
, SCM args
)
793 struct update_data
*data
= (struct update_data
*) ptr
;
794 SCM observer
= data
->observer
;
796 scm_from_locale_string ("Observer `~A' signals `~A' error: ~S");
798 return scm_cons (message
, scm_list_3 (observer
, tag
, args
));
803 core_environments_broadcast (SCM env
)
804 #define FUNC_NAME "core_environments_broadcast"
806 unsigned int handling_weaks
;
807 SCM errors
= SCM_EOL
;
809 for (handling_weaks
= 0; handling_weaks
<= 1; ++handling_weaks
)
811 SCM observers
= handling_weaks
812 ? CORE_ENVIRONMENT_WEAK_OBSERVERS (env
)
813 : CORE_ENVIRONMENT_OBSERVERS (env
);
815 for (; !scm_is_null (observers
); observers
= SCM_CDR (observers
))
817 struct update_data data
;
818 SCM observer
= handling_weaks
819 ? SCM_CDAR (observers
)
820 : SCM_CAR (observers
);
823 data
.observer
= observer
;
824 data
.environment
= env
;
826 error
= scm_internal_catch (SCM_BOOL_T
,
827 update_catch_body
, &data
,
828 update_catch_handler
, &data
);
830 if (!SCM_UNBNDP (error
))
831 errors
= scm_cons (error
, errors
);
835 if (!scm_is_null (errors
))
837 /* Dirk:FIXME:: As soon as scm_misc_error is fixed to handle the name
838 * parameter correctly it should not be necessary any more to also pass
839 * namestr in order to get the desired information from the error
842 SCM ordered_errors
= scm_reverse (errors
);
845 "Observers of `~A' have signalled the following errors: ~S",
846 scm_cons2 (env
, ordered_errors
, SCM_EOL
));
855 * A leaf environment is simply a mutable set of definitions. A leaf
856 * environment supports no operations beyond the common set.
858 * Implementation: The obarray of the leaf environment holds (symbol . value)
859 * pairs. No further information is necessary, since all bindings and
860 * locations in a leaf environment are mutable.
864 struct leaf_environment
{
865 struct core_environments_base base
;
871 #define LEAF_ENVIRONMENT(env) \
872 ((struct leaf_environment *) SCM_CELL_WORD_1 (env))
877 leaf_environment_ref (SCM env
, SCM sym
)
879 SCM obarray
= LEAF_ENVIRONMENT (env
)->obarray
;
880 SCM binding
= obarray_retrieve (obarray
, sym
);
881 return SCM_UNBNDP (binding
) ? binding
: SCM_CDR (binding
);
886 leaf_environment_fold (SCM env
, scm_environment_folder proc
, SCM data
, SCM init
)
890 SCM obarray
= LEAF_ENVIRONMENT (env
)->obarray
;
892 for (i
= 0; i
< SCM_HASHTABLE_N_BUCKETS (obarray
); i
++)
895 for (l
= SCM_HASHTABLE_BUCKET (obarray
, i
);
899 SCM binding
= SCM_CAR (l
);
900 SCM symbol
= SCM_CAR (binding
);
901 SCM value
= SCM_CDR (binding
);
902 result
= (*proc
) (data
, symbol
, value
, result
);
910 leaf_environment_define (SCM env
, SCM sym
, SCM val
)
911 #define FUNC_NAME "leaf_environment_define"
913 SCM obarray
= LEAF_ENVIRONMENT (env
)->obarray
;
915 obarray_replace (obarray
, sym
, val
);
916 core_environments_broadcast (env
);
918 return SCM_ENVIRONMENT_SUCCESS
;
924 leaf_environment_undefine (SCM env
, SCM sym
)
925 #define FUNC_NAME "leaf_environment_undefine"
927 SCM obarray
= LEAF_ENVIRONMENT (env
)->obarray
;
928 SCM removed
= obarray_remove (obarray
, sym
);
930 if (scm_is_true (removed
))
931 core_environments_broadcast (env
);
933 return SCM_ENVIRONMENT_SUCCESS
;
939 leaf_environment_set_x (SCM env
, SCM sym
, SCM val
)
940 #define FUNC_NAME "leaf_environment_set_x"
942 SCM obarray
= LEAF_ENVIRONMENT (env
)->obarray
;
943 SCM binding
= obarray_retrieve (obarray
, sym
);
945 if (!SCM_UNBNDP (binding
))
947 SCM_SETCDR (binding
, val
);
948 return SCM_ENVIRONMENT_SUCCESS
;
952 return SCM_UNDEFINED
;
959 leaf_environment_cell (SCM env
, SCM sym
, int for_write SCM_UNUSED
)
961 SCM obarray
= LEAF_ENVIRONMENT (env
)->obarray
;
962 SCM binding
= obarray_retrieve (obarray
, sym
);
968 leaf_environment_mark (SCM env
)
970 scm_gc_mark (LEAF_ENVIRONMENT (env
)->obarray
);
971 return core_environments_mark (env
);
976 leaf_environment_free (SCM env
)
978 core_environments_finalize (env
);
979 scm_gc_free (LEAF_ENVIRONMENT (env
), sizeof (struct leaf_environment
),
985 leaf_environment_print (SCM type
, SCM port
, scm_print_state
*pstate SCM_UNUSED
)
987 SCM address
= scm_from_size_t (SCM_UNPACK (type
));
988 SCM base16
= scm_number_to_string (address
, scm_from_int (16));
990 scm_puts ("#<leaf environment ", port
);
991 scm_display (base16
, port
);
992 scm_puts (">", port
);
998 static struct scm_environment_funcs leaf_environment_funcs
= {
999 leaf_environment_ref
,
1000 leaf_environment_fold
,
1001 leaf_environment_define
,
1002 leaf_environment_undefine
,
1003 leaf_environment_set_x
,
1004 leaf_environment_cell
,
1005 core_environments_observe
,
1006 core_environments_unobserve
,
1007 leaf_environment_mark
,
1008 leaf_environment_free
,
1009 leaf_environment_print
1013 void *scm_type_leaf_environment
= &leaf_environment_funcs
;
1016 SCM_DEFINE (scm_make_leaf_environment
, "make-leaf-environment", 0, 0, 0,
1018 "Create a new leaf environment, containing no bindings.\n"
1019 "All bindings and locations created in the new environment\n"
1021 #define FUNC_NAME s_scm_make_leaf_environment
1023 size_t size
= sizeof (struct leaf_environment
);
1024 struct leaf_environment
*body
= scm_gc_malloc (size
, "leaf environment");
1027 core_environments_preinit (&body
->base
);
1028 body
->obarray
= SCM_BOOL_F
;
1030 env
= scm_make_environment (body
);
1032 core_environments_init (&body
->base
, &leaf_environment_funcs
);
1033 body
->obarray
= scm_c_make_hash_table (DEFAULT_OBARRAY_SIZE
);
1040 SCM_DEFINE (scm_leaf_environment_p
, "leaf-environment?", 1, 0, 0,
1042 "Return @code{#t} if object is a leaf environment, or @code{#f}\n"
1044 #define FUNC_NAME s_scm_leaf_environment_p
1046 return scm_from_bool (SCM_LEAF_ENVIRONMENT_P (object
));
1052 /* eval environments
1054 * A module's source code refers to definitions imported from other modules,
1055 * and definitions made within itself. An eval environment combines two
1056 * environments -- a local environment and an imported environment -- to
1057 * produce a new environment in which both sorts of references can be
1060 * Implementation: The obarray of the eval environment is used to cache
1061 * entries from the local and imported environments such that in most of the
1062 * cases only a single lookup is necessary. Since for neither the local nor
1063 * the imported environment it is known, what kind of environment they form,
1064 * the most general case is assumed. Therefore, entries in the obarray take
1065 * one of the following forms:
1067 * 1) (<symbol> location mutability . source-env), where mutability indicates
1068 * one of the following states: IMMUTABLE if the location is known to be
1069 * immutable, MUTABLE if the location is known to be mutable, UNKNOWN if
1070 * the location has only been requested for non modifying accesses.
1072 * 2) (symbol . source-env) if the symbol has a binding in the source-env, but
1073 * if the source-env can't provide a cell for the binding. Thus, for every
1074 * access, the source-env has to be contacted directly.
1078 struct eval_environment
{
1079 struct core_environments_base base
;
1084 SCM imported_observer
;
1090 #define EVAL_ENVIRONMENT(env) \
1091 ((struct eval_environment *) SCM_CELL_WORD_1 (env))
1093 #define IMMUTABLE SCM_I_MAKINUM (0)
1094 #define MUTABLE SCM_I_MAKINUM (1)
1095 #define UNKNOWN SCM_I_MAKINUM (2)
1097 #define CACHED_LOCATION(x) SCM_CAR (x)
1098 #define CACHED_MUTABILITY(x) SCM_CADR (x)
1099 #define SET_CACHED_MUTABILITY(x, v) SCM_SETCAR (SCM_CDR (x), (v))
1100 #define CACHED_SOURCE_ENVIRONMENT(x) SCM_CDDR (x)
1104 /* eval_environment_lookup will report one of the following distinct results:
1105 * a) (<object> . value) if a cell could be obtained.
1106 * b) <environment> if the environment has to be contacted directly.
1107 * c) IMMUTABLE if an immutable cell was requested for write.
1108 * d) SCM_UNDEFINED if there is no binding for the symbol.
1111 eval_environment_lookup (SCM env
, SCM sym
, int for_write
)
1113 SCM obarray
= EVAL_ENVIRONMENT (env
)->obarray
;
1114 SCM binding
= obarray_retrieve (obarray
, sym
);
1116 if (!SCM_UNBNDP (binding
))
1118 /* The obarray holds an entry for the symbol. */
1120 SCM entry
= SCM_CDR (binding
);
1122 if (scm_is_pair (entry
))
1124 /* The entry in the obarray is a cached location. */
1126 SCM location
= CACHED_LOCATION (entry
);
1132 mutability
= CACHED_MUTABILITY (entry
);
1133 if (scm_is_eq (mutability
, MUTABLE
))
1136 if (scm_is_eq (mutability
, UNKNOWN
))
1138 SCM source_env
= CACHED_SOURCE_ENVIRONMENT (entry
);
1139 SCM location
= SCM_ENVIRONMENT_CELL (source_env
, sym
, 1);
1141 if (scm_is_pair (location
))
1143 SET_CACHED_MUTABILITY (entry
, MUTABLE
);
1146 else /* IMMUTABLE */
1148 SET_CACHED_MUTABILITY (entry
, IMMUTABLE
);
1157 /* The obarray entry is an environment */
1164 /* There is no entry for the symbol in the obarray. This can either
1165 * mean that there has not been a request for the symbol yet, or that
1166 * the symbol is really undefined. We are looking for the symbol in
1167 * both the local and the imported environment. If we find a binding, a
1168 * cached entry is created.
1171 struct eval_environment
*body
= EVAL_ENVIRONMENT (env
);
1172 unsigned int handling_import
;
1174 for (handling_import
= 0; handling_import
<= 1; ++handling_import
)
1176 SCM source_env
= handling_import
? body
->imported
: body
->local
;
1177 SCM location
= SCM_ENVIRONMENT_CELL (source_env
, sym
, for_write
);
1179 if (!SCM_UNBNDP (location
))
1181 if (scm_is_pair (location
))
1183 SCM mutability
= for_write
? MUTABLE
: UNKNOWN
;
1184 SCM entry
= scm_cons2 (location
, mutability
, source_env
);
1185 obarray_enter (obarray
, sym
, entry
);
1188 else if (scm_is_eq (location
, SCM_ENVIRONMENT_LOCATION_NO_CELL
))
1190 obarray_enter (obarray
, sym
, source_env
);
1200 return SCM_UNDEFINED
;
1206 eval_environment_ref (SCM env
, SCM sym
)
1207 #define FUNC_NAME "eval_environment_ref"
1209 SCM location
= eval_environment_lookup (env
, sym
, 0);
1211 if (scm_is_pair (location
))
1212 return SCM_CDR (location
);
1213 else if (!SCM_UNBNDP (location
))
1214 return SCM_ENVIRONMENT_REF (location
, sym
);
1216 return SCM_UNDEFINED
;
1222 eval_environment_folder (SCM extended_data
, SCM symbol
, SCM value
, SCM tail
)
1224 SCM local
= SCM_CAR (extended_data
);
1226 if (!SCM_ENVIRONMENT_BOUND_P (local
, symbol
))
1228 SCM proc_as_nr
= SCM_CADR (extended_data
);
1229 unsigned long int proc_as_ul
= scm_to_ulong (proc_as_nr
);
1230 scm_environment_folder proc
= (scm_environment_folder
) proc_as_ul
;
1231 SCM data
= SCM_CDDR (extended_data
);
1233 return (*proc
) (data
, symbol
, value
, tail
);
1243 eval_environment_fold (SCM env
, scm_environment_folder proc
, SCM data
, SCM init
)
1245 SCM local
= EVAL_ENVIRONMENT (env
)->local
;
1246 SCM imported
= EVAL_ENVIRONMENT (env
)->imported
;
1247 SCM proc_as_nr
= scm_from_ulong ((unsigned long) proc
);
1248 SCM extended_data
= scm_cons2 (local
, proc_as_nr
, data
);
1249 SCM tmp_result
= scm_c_environment_fold (imported
, eval_environment_folder
, extended_data
, init
);
1251 return scm_c_environment_fold (local
, proc
, data
, tmp_result
);
1256 eval_environment_define (SCM env
, SCM sym
, SCM val
)
1257 #define FUNC_NAME "eval_environment_define"
1259 SCM local
= EVAL_ENVIRONMENT (env
)->local
;
1260 return SCM_ENVIRONMENT_DEFINE (local
, sym
, val
);
1266 eval_environment_undefine (SCM env
, SCM sym
)
1267 #define FUNC_NAME "eval_environment_undefine"
1269 SCM local
= EVAL_ENVIRONMENT (env
)->local
;
1270 return SCM_ENVIRONMENT_UNDEFINE (local
, sym
);
1276 eval_environment_set_x (SCM env
, SCM sym
, SCM val
)
1277 #define FUNC_NAME "eval_environment_set_x"
1279 SCM location
= eval_environment_lookup (env
, sym
, 1);
1281 if (scm_is_pair (location
))
1283 SCM_SETCDR (location
, val
);
1284 return SCM_ENVIRONMENT_SUCCESS
;
1286 else if (SCM_ENVIRONMENT_P (location
))
1288 return SCM_ENVIRONMENT_SET (location
, sym
, val
);
1290 else if (scm_is_eq (location
, IMMUTABLE
))
1292 return SCM_ENVIRONMENT_LOCATION_IMMUTABLE
;
1296 return SCM_UNDEFINED
;
1303 eval_environment_cell (SCM env
, SCM sym
, int for_write
)
1304 #define FUNC_NAME "eval_environment_cell"
1306 SCM location
= eval_environment_lookup (env
, sym
, for_write
);
1308 if (scm_is_pair (location
))
1310 else if (SCM_ENVIRONMENT_P (location
))
1311 return SCM_ENVIRONMENT_LOCATION_NO_CELL
;
1312 else if (scm_is_eq (location
, IMMUTABLE
))
1313 return SCM_ENVIRONMENT_LOCATION_IMMUTABLE
;
1315 return SCM_UNDEFINED
;
1321 eval_environment_mark (SCM env
)
1323 struct eval_environment
*body
= EVAL_ENVIRONMENT (env
);
1325 scm_gc_mark (body
->obarray
);
1326 scm_gc_mark (body
->imported
);
1327 scm_gc_mark (body
->imported_observer
);
1328 scm_gc_mark (body
->local
);
1329 scm_gc_mark (body
->local_observer
);
1331 return core_environments_mark (env
);
1336 eval_environment_free (SCM env
)
1338 core_environments_finalize (env
);
1339 scm_gc_free (EVAL_ENVIRONMENT (env
), sizeof (struct eval_environment
),
1340 "eval environment");
1345 eval_environment_print (SCM type
, SCM port
, scm_print_state
*pstate SCM_UNUSED
)
1347 SCM address
= scm_from_size_t (SCM_UNPACK (type
));
1348 SCM base16
= scm_number_to_string (address
, scm_from_int (16));
1350 scm_puts ("#<eval environment ", port
);
1351 scm_display (base16
, port
);
1352 scm_puts (">", port
);
1358 static struct scm_environment_funcs eval_environment_funcs
= {
1359 eval_environment_ref
,
1360 eval_environment_fold
,
1361 eval_environment_define
,
1362 eval_environment_undefine
,
1363 eval_environment_set_x
,
1364 eval_environment_cell
,
1365 core_environments_observe
,
1366 core_environments_unobserve
,
1367 eval_environment_mark
,
1368 eval_environment_free
,
1369 eval_environment_print
1373 void *scm_type_eval_environment
= &eval_environment_funcs
;
1377 eval_environment_observer (SCM caller SCM_UNUSED
, SCM eval_env
)
1379 SCM obarray
= EVAL_ENVIRONMENT (eval_env
)->obarray
;
1381 obarray_remove_all (obarray
);
1382 core_environments_broadcast (eval_env
);
1386 SCM_DEFINE (scm_make_eval_environment
, "make-eval-environment", 2, 0, 0,
1387 (SCM local
, SCM imported
),
1388 "Return a new environment object eval whose bindings are the\n"
1389 "union of the bindings in the environments @var{local} and\n"
1390 "@var{imported}, with bindings from @var{local} taking\n"
1391 "precedence. Definitions made in eval are placed in @var{local}.\n"
1392 "Applying @code{environment-define} or\n"
1393 "@code{environment-undefine} to eval has the same effect as\n"
1394 "applying the procedure to @var{local}.\n"
1395 "Note that eval incorporates @var{local} and @var{imported} by\n"
1397 "If, after creating eval, the program changes the bindings of\n"
1398 "@var{local} or @var{imported}, those changes will be visible\n"
1400 "Since most Scheme evaluation takes place in eval environments,\n"
1401 "they transparently cache the bindings received from @var{local}\n"
1402 "and @var{imported}. Thus, the first time the program looks up\n"
1403 "a symbol in eval, eval may make calls to @var{local} or\n"
1404 "@var{imported} to find their bindings, but subsequent\n"
1405 "references to that symbol will be as fast as references to\n"
1406 "bindings in finite environments.\n"
1407 "In typical use, @var{local} will be a finite environment, and\n"
1408 "@var{imported} will be an import environment")
1409 #define FUNC_NAME s_scm_make_eval_environment
1412 struct eval_environment
*body
;
1414 SCM_ASSERT (SCM_ENVIRONMENT_P (local
), local
, SCM_ARG1
, FUNC_NAME
);
1415 SCM_ASSERT (SCM_ENVIRONMENT_P (imported
), imported
, SCM_ARG2
, FUNC_NAME
);
1417 body
= scm_gc_malloc (sizeof (struct eval_environment
), "eval environment");
1419 core_environments_preinit (&body
->base
);
1420 body
->obarray
= SCM_BOOL_F
;
1421 body
->imported
= SCM_BOOL_F
;
1422 body
->imported_observer
= SCM_BOOL_F
;
1423 body
->local
= SCM_BOOL_F
;
1424 body
->local_observer
= SCM_BOOL_F
;
1426 env
= scm_make_environment (body
);
1428 core_environments_init (&body
->base
, &eval_environment_funcs
);
1429 body
->obarray
= scm_c_make_hash_table (DEFAULT_OBARRAY_SIZE
);
1430 body
->imported
= imported
;
1431 body
->imported_observer
1432 = SCM_ENVIRONMENT_OBSERVE (imported
, eval_environment_observer
, env
, 1);
1433 body
->local
= local
;
1434 body
->local_observer
1435 = SCM_ENVIRONMENT_OBSERVE (local
, eval_environment_observer
, env
, 1);
1442 SCM_DEFINE (scm_eval_environment_p
, "eval-environment?", 1, 0, 0,
1444 "Return @code{#t} if object is an eval environment, or @code{#f}\n"
1446 #define FUNC_NAME s_scm_eval_environment_p
1448 return scm_from_bool (SCM_EVAL_ENVIRONMENT_P (object
));
1453 SCM_DEFINE (scm_eval_environment_local
, "eval-environment-local", 1, 0, 0,
1455 "Return the local environment of eval environment @var{env}.")
1456 #define FUNC_NAME s_scm_eval_environment_local
1458 SCM_ASSERT (SCM_EVAL_ENVIRONMENT_P (env
), env
, SCM_ARG1
, FUNC_NAME
);
1460 return EVAL_ENVIRONMENT (env
)->local
;
1465 SCM_DEFINE (scm_eval_environment_set_local_x
, "eval-environment-set-local!", 2, 0, 0,
1466 (SCM env
, SCM local
),
1467 "Change @var{env}'s local environment to @var{local}.")
1468 #define FUNC_NAME s_scm_eval_environment_set_local_x
1470 struct eval_environment
*body
;
1472 SCM_ASSERT (SCM_EVAL_ENVIRONMENT_P (env
), env
, SCM_ARG1
, FUNC_NAME
);
1473 SCM_ASSERT (SCM_ENVIRONMENT_P (local
), local
, SCM_ARG2
, FUNC_NAME
);
1475 body
= EVAL_ENVIRONMENT (env
);
1477 obarray_remove_all (body
->obarray
);
1478 SCM_ENVIRONMENT_UNOBSERVE (body
->local
, body
->local_observer
);
1480 body
->local
= local
;
1481 body
->local_observer
1482 = SCM_ENVIRONMENT_OBSERVE (local
, eval_environment_observer
, env
, 1);
1484 core_environments_broadcast (env
);
1486 return SCM_UNSPECIFIED
;
1491 SCM_DEFINE (scm_eval_environment_imported
, "eval-environment-imported", 1, 0, 0,
1493 "Return the imported environment of eval environment @var{env}.")
1494 #define FUNC_NAME s_scm_eval_environment_imported
1496 SCM_ASSERT (SCM_EVAL_ENVIRONMENT_P (env
), env
, SCM_ARG1
, FUNC_NAME
);
1498 return EVAL_ENVIRONMENT (env
)->imported
;
1503 SCM_DEFINE (scm_eval_environment_set_imported_x
, "eval-environment-set-imported!", 2, 0, 0,
1504 (SCM env
, SCM imported
),
1505 "Change @var{env}'s imported environment to @var{imported}.")
1506 #define FUNC_NAME s_scm_eval_environment_set_imported_x
1508 struct eval_environment
*body
;
1510 SCM_ASSERT (SCM_EVAL_ENVIRONMENT_P (env
), env
, SCM_ARG1
, FUNC_NAME
);
1511 SCM_ASSERT (SCM_ENVIRONMENT_P (imported
), imported
, SCM_ARG2
, FUNC_NAME
);
1513 body
= EVAL_ENVIRONMENT (env
);
1515 obarray_remove_all (body
->obarray
);
1516 SCM_ENVIRONMENT_UNOBSERVE (body
->imported
, body
->imported_observer
);
1518 body
->imported
= imported
;
1519 body
->imported_observer
1520 = SCM_ENVIRONMENT_OBSERVE (imported
, eval_environment_observer
, env
, 1);
1522 core_environments_broadcast (env
);
1524 return SCM_UNSPECIFIED
;
1530 /* import environments
1532 * An import environment combines the bindings of a set of argument
1533 * environments, and checks for naming clashes.
1535 * Implementation: The import environment does no caching at all. For every
1536 * access, the list of imported environments is scanned.
1540 struct import_environment
{
1541 struct core_environments_base base
;
1544 SCM import_observers
;
1550 #define IMPORT_ENVIRONMENT(env) \
1551 ((struct import_environment *) SCM_CELL_WORD_1 (env))
1555 /* Lookup will report one of the following distinct results:
1556 * a) <environment> if only environment binds the symbol.
1557 * b) (env-1 env-2 ...) for conflicting bindings in env-1, ...
1558 * c) SCM_UNDEFINED if there is no binding for the symbol.
1561 import_environment_lookup (SCM env
, SCM sym
)
1563 SCM imports
= IMPORT_ENVIRONMENT (env
)->imports
;
1564 SCM result
= SCM_UNDEFINED
;
1567 for (l
= imports
; !scm_is_null (l
); l
= SCM_CDR (l
))
1569 SCM imported
= SCM_CAR (l
);
1571 if (SCM_ENVIRONMENT_BOUND_P (imported
, sym
))
1573 if (SCM_UNBNDP (result
))
1575 else if (scm_is_pair (result
))
1576 result
= scm_cons (imported
, result
);
1578 result
= scm_cons2 (imported
, result
, SCM_EOL
);
1582 if (scm_is_pair (result
))
1583 return scm_reverse (result
);
1590 import_environment_conflict (SCM env
, SCM sym
, SCM imports
)
1592 SCM conflict_proc
= IMPORT_ENVIRONMENT (env
)->conflict_proc
;
1593 SCM args
= scm_cons2 (env
, sym
, scm_cons (imports
, SCM_EOL
));
1595 return scm_apply_0 (conflict_proc
, args
);
1600 import_environment_ref (SCM env
, SCM sym
)
1601 #define FUNC_NAME "import_environment_ref"
1603 SCM owner
= import_environment_lookup (env
, sym
);
1605 if (SCM_UNBNDP (owner
))
1607 return SCM_UNDEFINED
;
1609 else if (scm_is_pair (owner
))
1611 SCM resolve
= import_environment_conflict (env
, sym
, owner
);
1613 if (SCM_ENVIRONMENT_P (resolve
))
1614 return SCM_ENVIRONMENT_REF (resolve
, sym
);
1616 return SCM_UNSPECIFIED
;
1620 return SCM_ENVIRONMENT_REF (owner
, sym
);
1627 import_environment_folder (SCM extended_data
, SCM symbol
, SCM value
, SCM tail
)
1628 #define FUNC_NAME "import_environment_fold"
1630 SCM import_env
= SCM_CAR (extended_data
);
1631 SCM imported_env
= SCM_CADR (extended_data
);
1632 SCM owner
= import_environment_lookup (import_env
, symbol
);
1633 SCM proc_as_nr
= SCM_CADDR (extended_data
);
1634 unsigned long int proc_as_ul
= scm_to_ulong (proc_as_nr
);
1635 scm_environment_folder proc
= (scm_environment_folder
) proc_as_ul
;
1636 SCM data
= SCM_CDDDR (extended_data
);
1638 if (scm_is_pair (owner
) && scm_is_eq (SCM_CAR (owner
), imported_env
))
1639 owner
= import_environment_conflict (import_env
, symbol
, owner
);
1641 if (SCM_ENVIRONMENT_P (owner
))
1642 return (*proc
) (data
, symbol
, value
, tail
);
1643 else /* unresolved conflict */
1644 return (*proc
) (data
, symbol
, SCM_UNSPECIFIED
, tail
);
1650 import_environment_fold (SCM env
, scm_environment_folder proc
, SCM data
, SCM init
)
1652 SCM proc_as_nr
= scm_from_ulong ((unsigned long) proc
);
1656 for (l
= IMPORT_ENVIRONMENT (env
)->imports
; !scm_is_null (l
); l
= SCM_CDR (l
))
1658 SCM imported_env
= SCM_CAR (l
);
1659 SCM extended_data
= scm_cons (env
, scm_cons2 (imported_env
, proc_as_nr
, data
));
1661 result
= scm_c_environment_fold (imported_env
, import_environment_folder
, extended_data
, result
);
1669 import_environment_define (SCM env SCM_UNUSED
,
1672 #define FUNC_NAME "import_environment_define"
1674 return SCM_ENVIRONMENT_BINDING_IMMUTABLE
;
1680 import_environment_undefine (SCM env SCM_UNUSED
,
1682 #define FUNC_NAME "import_environment_undefine"
1684 return SCM_ENVIRONMENT_BINDING_IMMUTABLE
;
1690 import_environment_set_x (SCM env
, SCM sym
, SCM val
)
1691 #define FUNC_NAME "import_environment_set_x"
1693 SCM owner
= import_environment_lookup (env
, sym
);
1695 if (SCM_UNBNDP (owner
))
1697 return SCM_UNDEFINED
;
1699 else if (scm_is_pair (owner
))
1701 SCM resolve
= import_environment_conflict (env
, sym
, owner
);
1703 if (SCM_ENVIRONMENT_P (resolve
))
1704 return SCM_ENVIRONMENT_SET (resolve
, sym
, val
);
1706 return SCM_ENVIRONMENT_LOCATION_IMMUTABLE
;
1710 return SCM_ENVIRONMENT_SET (owner
, sym
, val
);
1717 import_environment_cell (SCM env
, SCM sym
, int for_write
)
1718 #define FUNC_NAME "import_environment_cell"
1720 SCM owner
= import_environment_lookup (env
, sym
);
1722 if (SCM_UNBNDP (owner
))
1724 return SCM_UNDEFINED
;
1726 else if (scm_is_pair (owner
))
1728 SCM resolve
= import_environment_conflict (env
, sym
, owner
);
1730 if (SCM_ENVIRONMENT_P (resolve
))
1731 return SCM_ENVIRONMENT_CELL (resolve
, sym
, for_write
);
1733 return SCM_ENVIRONMENT_LOCATION_NO_CELL
;
1737 return SCM_ENVIRONMENT_CELL (owner
, sym
, for_write
);
1744 import_environment_mark (SCM env
)
1746 scm_gc_mark (IMPORT_ENVIRONMENT (env
)->imports
);
1747 scm_gc_mark (IMPORT_ENVIRONMENT (env
)->import_observers
);
1748 scm_gc_mark (IMPORT_ENVIRONMENT (env
)->conflict_proc
);
1749 return core_environments_mark (env
);
1754 import_environment_free (SCM env
)
1756 core_environments_finalize (env
);
1757 scm_gc_free (IMPORT_ENVIRONMENT (env
), sizeof (struct import_environment
),
1758 "import environment");
1763 import_environment_print (SCM type
, SCM port
,
1764 scm_print_state
*pstate SCM_UNUSED
)
1766 SCM address
= scm_from_size_t (SCM_UNPACK (type
));
1767 SCM base16
= scm_number_to_string (address
, scm_from_int (16));
1769 scm_puts ("#<import environment ", port
);
1770 scm_display (base16
, port
);
1771 scm_puts (">", port
);
1777 static struct scm_environment_funcs import_environment_funcs
= {
1778 import_environment_ref
,
1779 import_environment_fold
,
1780 import_environment_define
,
1781 import_environment_undefine
,
1782 import_environment_set_x
,
1783 import_environment_cell
,
1784 core_environments_observe
,
1785 core_environments_unobserve
,
1786 import_environment_mark
,
1787 import_environment_free
,
1788 import_environment_print
1792 void *scm_type_import_environment
= &import_environment_funcs
;
1796 import_environment_observer (SCM caller SCM_UNUSED
, SCM import_env
)
1798 core_environments_broadcast (import_env
);
1802 SCM_DEFINE (scm_make_import_environment
, "make-import-environment", 2, 0, 0,
1803 (SCM imports
, SCM conflict_proc
),
1804 "Return a new environment @var{imp} whose bindings are the union\n"
1805 "of the bindings from the environments in @var{imports};\n"
1806 "@var{imports} must be a list of environments. That is,\n"
1807 "@var{imp} binds a symbol to a location when some element of\n"
1808 "@var{imports} does.\n"
1809 "If two different elements of @var{imports} have a binding for\n"
1810 "the same symbol, the @var{conflict-proc} is called with the\n"
1811 "following parameters: the import environment, the symbol and\n"
1812 "the list of the imported environments that bind the symbol.\n"
1813 "If the @var{conflict-proc} returns an environment @var{env},\n"
1814 "the conflict is considered as resolved and the binding from\n"
1815 "@var{env} is used. If the @var{conflict-proc} returns some\n"
1816 "non-environment object, the conflict is considered unresolved\n"
1817 "and the symbol is treated as unspecified in the import\n"
1819 "The checking for conflicts may be performed lazily, i. e. at\n"
1820 "the moment when a value or binding for a certain symbol is\n"
1821 "requested instead of the moment when the environment is\n"
1822 "created or the bindings of the imports change.\n"
1823 "All bindings in @var{imp} are immutable. If you apply\n"
1824 "@code{environment-define} or @code{environment-undefine} to\n"
1825 "@var{imp}, Guile will signal an\n"
1826 " @code{environment:immutable-binding} error. However,\n"
1827 "notice that the set of bindings in @var{imp} may still change,\n"
1828 "if one of its imported environments changes.")
1829 #define FUNC_NAME s_scm_make_import_environment
1831 size_t size
= sizeof (struct import_environment
);
1832 struct import_environment
*body
= scm_gc_malloc (size
, "import environment");
1835 core_environments_preinit (&body
->base
);
1836 body
->imports
= SCM_BOOL_F
;
1837 body
->import_observers
= SCM_BOOL_F
;
1838 body
->conflict_proc
= SCM_BOOL_F
;
1840 env
= scm_make_environment (body
);
1842 core_environments_init (&body
->base
, &import_environment_funcs
);
1843 body
->imports
= SCM_EOL
;
1844 body
->import_observers
= SCM_EOL
;
1845 body
->conflict_proc
= conflict_proc
;
1847 scm_import_environment_set_imports_x (env
, imports
);
1854 SCM_DEFINE (scm_import_environment_p
, "import-environment?", 1, 0, 0,
1856 "Return @code{#t} if object is an import environment, or\n"
1857 "@code{#f} otherwise.")
1858 #define FUNC_NAME s_scm_import_environment_p
1860 return scm_from_bool (SCM_IMPORT_ENVIRONMENT_P (object
));
1865 SCM_DEFINE (scm_import_environment_imports
, "import-environment-imports", 1, 0, 0,
1867 "Return the list of environments imported by the import\n"
1868 "environment @var{env}.")
1869 #define FUNC_NAME s_scm_import_environment_imports
1871 SCM_ASSERT (SCM_IMPORT_ENVIRONMENT_P (env
), env
, SCM_ARG1
, FUNC_NAME
);
1873 return IMPORT_ENVIRONMENT (env
)->imports
;
1878 SCM_DEFINE (scm_import_environment_set_imports_x
, "import-environment-set-imports!", 2, 0, 0,
1879 (SCM env
, SCM imports
),
1880 "Change @var{env}'s list of imported environments to\n"
1881 "@var{imports}, and check for conflicts.")
1882 #define FUNC_NAME s_scm_import_environment_set_imports_x
1884 struct import_environment
*body
= IMPORT_ENVIRONMENT (env
);
1885 SCM import_observers
= SCM_EOL
;
1888 SCM_ASSERT (SCM_IMPORT_ENVIRONMENT_P (env
), env
, SCM_ARG1
, FUNC_NAME
);
1889 for (l
= imports
; scm_is_pair (l
); l
= SCM_CDR (l
))
1891 SCM obj
= SCM_CAR (l
);
1892 SCM_ASSERT (SCM_ENVIRONMENT_P (obj
), imports
, SCM_ARG2
, FUNC_NAME
);
1894 SCM_ASSERT (scm_is_null (l
), imports
, SCM_ARG2
, FUNC_NAME
);
1896 for (l
= body
->import_observers
; !scm_is_null (l
); l
= SCM_CDR (l
))
1898 SCM obs
= SCM_CAR (l
);
1899 SCM_ENVIRONMENT_UNOBSERVE (env
, obs
);
1902 for (l
= imports
; !scm_is_null (l
); l
= SCM_CDR (l
))
1904 SCM imp
= SCM_CAR (l
);
1905 SCM obs
= SCM_ENVIRONMENT_OBSERVE (imp
, import_environment_observer
, env
, 1);
1906 import_observers
= scm_cons (obs
, import_observers
);
1909 body
->imports
= imports
;
1910 body
->import_observers
= import_observers
;
1912 return SCM_UNSPECIFIED
;
1918 /* export environments
1920 * An export environment restricts an environment to a specified set of
1923 * Implementation: The export environment does no caching at all. For every
1924 * access, the signature is scanned. The signature that is stored internally
1925 * is an alist of pairs (symbol . (mutability)).
1929 struct export_environment
{
1930 struct core_environments_base base
;
1933 SCM private_observer
;
1939 #define EXPORT_ENVIRONMENT(env) \
1940 ((struct export_environment *) SCM_CELL_WORD_1 (env))
1943 SCM_SYMBOL (symbol_immutable_location
, "immutable-location");
1944 SCM_SYMBOL (symbol_mutable_location
, "mutable-location");
1949 export_environment_ref (SCM env
, SCM sym
)
1950 #define FUNC_NAME "export_environment_ref"
1952 struct export_environment
*body
= EXPORT_ENVIRONMENT (env
);
1953 SCM entry
= scm_assq (sym
, body
->signature
);
1955 if (scm_is_false (entry
))
1956 return SCM_UNDEFINED
;
1958 return SCM_ENVIRONMENT_REF (body
->private, sym
);
1964 export_environment_fold (SCM env
, scm_environment_folder proc
, SCM data
, SCM init
)
1966 struct export_environment
*body
= EXPORT_ENVIRONMENT (env
);
1970 for (l
= body
->signature
; !scm_is_null (l
); l
= SCM_CDR (l
))
1972 SCM symbol
= SCM_CAR (l
);
1973 SCM value
= SCM_ENVIRONMENT_REF (body
->private, symbol
);
1974 if (!SCM_UNBNDP (value
))
1975 result
= (*proc
) (data
, symbol
, value
, result
);
1982 export_environment_define (SCM env SCM_UNUSED
,
1985 #define FUNC_NAME "export_environment_define"
1987 return SCM_ENVIRONMENT_BINDING_IMMUTABLE
;
1993 export_environment_undefine (SCM env SCM_UNUSED
, SCM sym SCM_UNUSED
)
1994 #define FUNC_NAME "export_environment_undefine"
1996 return SCM_ENVIRONMENT_BINDING_IMMUTABLE
;
2002 export_environment_set_x (SCM env
, SCM sym
, SCM val
)
2003 #define FUNC_NAME "export_environment_set_x"
2005 struct export_environment
*body
= EXPORT_ENVIRONMENT (env
);
2006 SCM entry
= scm_assq (sym
, body
->signature
);
2008 if (scm_is_false (entry
))
2010 return SCM_UNDEFINED
;
2014 if (scm_is_eq (SCM_CADR (entry
), symbol_mutable_location
))
2015 return SCM_ENVIRONMENT_SET (body
->private, sym
, val
);
2017 return SCM_ENVIRONMENT_LOCATION_IMMUTABLE
;
2024 export_environment_cell (SCM env
, SCM sym
, int for_write
)
2025 #define FUNC_NAME "export_environment_cell"
2027 struct export_environment
*body
= EXPORT_ENVIRONMENT (env
);
2028 SCM entry
= scm_assq (sym
, body
->signature
);
2030 if (scm_is_false (entry
))
2032 return SCM_UNDEFINED
;
2036 if (!for_write
|| scm_is_eq (SCM_CADR (entry
), symbol_mutable_location
))
2037 return SCM_ENVIRONMENT_CELL (body
->private, sym
, for_write
);
2039 return SCM_ENVIRONMENT_LOCATION_IMMUTABLE
;
2046 export_environment_mark (SCM env
)
2048 struct export_environment
*body
= EXPORT_ENVIRONMENT (env
);
2050 scm_gc_mark (body
->private);
2051 scm_gc_mark (body
->private_observer
);
2052 scm_gc_mark (body
->signature
);
2054 return core_environments_mark (env
);
2059 export_environment_free (SCM env
)
2061 core_environments_finalize (env
);
2062 scm_gc_free (EXPORT_ENVIRONMENT (env
), sizeof (struct export_environment
),
2063 "export environment");
2068 export_environment_print (SCM type
, SCM port
,
2069 scm_print_state
*pstate SCM_UNUSED
)
2071 SCM address
= scm_from_size_t (SCM_UNPACK (type
));
2072 SCM base16
= scm_number_to_string (address
, scm_from_int (16));
2074 scm_puts ("#<export environment ", port
);
2075 scm_display (base16
, port
);
2076 scm_puts (">", port
);
2082 static struct scm_environment_funcs export_environment_funcs
= {
2083 export_environment_ref
,
2084 export_environment_fold
,
2085 export_environment_define
,
2086 export_environment_undefine
,
2087 export_environment_set_x
,
2088 export_environment_cell
,
2089 core_environments_observe
,
2090 core_environments_unobserve
,
2091 export_environment_mark
,
2092 export_environment_free
,
2093 export_environment_print
2097 void *scm_type_export_environment
= &export_environment_funcs
;
2101 export_environment_observer (SCM caller SCM_UNUSED
, SCM export_env
)
2103 core_environments_broadcast (export_env
);
2107 SCM_DEFINE (scm_make_export_environment
, "make-export-environment", 2, 0, 0,
2108 (SCM
private, SCM signature
),
2109 "Return a new environment @var{exp} containing only those\n"
2110 "bindings in private whose symbols are present in\n"
2111 "@var{signature}. The @var{private} argument must be an\n"
2113 "The environment @var{exp} binds symbol to location when\n"
2114 "@var{env} does, and symbol is exported by @var{signature}.\n\n"
2115 "@var{signature} is a list specifying which of the bindings in\n"
2116 "@var{private} should be visible in @var{exp}. Each element of\n"
2117 "@var{signature} should be a list of the form:\n"
2118 " (symbol attribute ...)\n"
2119 "where each attribute is one of the following:\n"
2121 "@item the symbol @code{mutable-location}\n"
2122 " @var{exp} should treat the\n"
2123 " location bound to symbol as mutable. That is, @var{exp}\n"
2124 " will pass calls to @code{environment-set!} or\n"
2125 " @code{environment-cell} directly through to private.\n"
2126 "@item the symbol @code{immutable-location}\n"
2127 " @var{exp} should treat\n"
2128 " the location bound to symbol as immutable. If the program\n"
2129 " applies @code{environment-set!} to @var{exp} and symbol, or\n"
2130 " calls @code{environment-cell} to obtain a writable value\n"
2131 " cell, @code{environment-set!} will signal an\n"
2132 " @code{environment:immutable-location} error. Note that, even\n"
2133 " if an export environment treats a location as immutable, the\n"
2134 " underlying environment may treat it as mutable, so its\n"
2135 " value may change.\n"
2137 "It is an error for an element of signature to specify both\n"
2138 "@code{mutable-location} and @code{immutable-location}. If\n"
2139 "neither is specified, @code{immutable-location} is assumed.\n\n"
2140 "As a special case, if an element of signature is a lone\n"
2141 "symbol @var{sym}, it is equivalent to an element of the form\n"
2143 "All bindings in @var{exp} are immutable. If you apply\n"
2144 "@code{environment-define} or @code{environment-undefine} to\n"
2145 "@var{exp}, Guile will signal an\n"
2146 "@code{environment:immutable-binding} error. However,\n"
2147 "notice that the set of bindings in @var{exp} may still change,\n"
2148 "if the bindings in private change.")
2149 #define FUNC_NAME s_scm_make_export_environment
2152 struct export_environment
*body
;
2155 SCM_ASSERT (SCM_ENVIRONMENT_P (private), private, SCM_ARG1
, FUNC_NAME
);
2157 size
= sizeof (struct export_environment
);
2158 body
= scm_gc_malloc (size
, "export environment");
2160 core_environments_preinit (&body
->base
);
2161 body
->private = SCM_BOOL_F
;
2162 body
->private_observer
= SCM_BOOL_F
;
2163 body
->signature
= SCM_BOOL_F
;
2165 env
= scm_make_environment (body
);
2167 core_environments_init (&body
->base
, &export_environment_funcs
);
2168 body
->private = private;
2169 body
->private_observer
2170 = SCM_ENVIRONMENT_OBSERVE (private, export_environment_observer
, env
, 1);
2171 body
->signature
= SCM_EOL
;
2173 scm_export_environment_set_signature_x (env
, signature
);
2180 SCM_DEFINE (scm_export_environment_p
, "export-environment?", 1, 0, 0,
2182 "Return @code{#t} if object is an export environment, or\n"
2183 "@code{#f} otherwise.")
2184 #define FUNC_NAME s_scm_export_environment_p
2186 return scm_from_bool (SCM_EXPORT_ENVIRONMENT_P (object
));
2191 SCM_DEFINE (scm_export_environment_private
, "export-environment-private", 1, 0, 0,
2193 "Return the private environment of export environment @var{env}.")
2194 #define FUNC_NAME s_scm_export_environment_private
2196 SCM_ASSERT (SCM_EXPORT_ENVIRONMENT_P (env
), env
, SCM_ARG1
, FUNC_NAME
);
2198 return EXPORT_ENVIRONMENT (env
)->private;
2203 SCM_DEFINE (scm_export_environment_set_private_x
, "export-environment-set-private!", 2, 0, 0,
2204 (SCM env
, SCM
private),
2205 "Change the private environment of export environment @var{env}.")
2206 #define FUNC_NAME s_scm_export_environment_set_private_x
2208 struct export_environment
*body
;
2210 SCM_ASSERT (SCM_EXPORT_ENVIRONMENT_P (env
), env
, SCM_ARG1
, FUNC_NAME
);
2211 SCM_ASSERT (SCM_ENVIRONMENT_P (private), private, SCM_ARG2
, FUNC_NAME
);
2213 body
= EXPORT_ENVIRONMENT (env
);
2214 SCM_ENVIRONMENT_UNOBSERVE (private, body
->private_observer
);
2216 body
->private = private;
2217 body
->private_observer
2218 = SCM_ENVIRONMENT_OBSERVE (private, export_environment_observer
, env
, 1);
2220 return SCM_UNSPECIFIED
;
2225 SCM_DEFINE (scm_export_environment_signature
, "export-environment-signature", 1, 0, 0,
2227 "Return the signature of export environment @var{env}.")
2228 #define FUNC_NAME s_scm_export_environment_signature
2230 SCM_ASSERT (SCM_EXPORT_ENVIRONMENT_P (env
), env
, SCM_ARG1
, FUNC_NAME
);
2232 return EXPORT_ENVIRONMENT (env
)->signature
;
2238 export_environment_parse_signature (SCM signature
, const char* caller
)
2240 SCM result
= SCM_EOL
;
2243 for (l
= signature
; scm_is_pair (l
); l
= SCM_CDR (l
))
2245 SCM entry
= SCM_CAR (l
);
2247 if (scm_is_symbol (entry
))
2249 SCM new_entry
= scm_cons2 (entry
, symbol_immutable_location
, SCM_EOL
);
2250 result
= scm_cons (new_entry
, result
);
2261 SCM_ASSERT (scm_is_pair (entry
), entry
, SCM_ARGn
, caller
);
2262 SCM_ASSERT (scm_is_symbol (SCM_CAR (entry
)), entry
, SCM_ARGn
, caller
);
2264 sym
= SCM_CAR (entry
);
2266 for (l2
= SCM_CDR (entry
); scm_is_pair (l2
); l2
= SCM_CDR (l2
))
2268 SCM attribute
= SCM_CAR (l2
);
2269 if (scm_is_eq (attribute
, symbol_immutable_location
))
2271 else if (scm_is_eq (attribute
, symbol_mutable_location
))
2274 SCM_ASSERT (0, entry
, SCM_ARGn
, caller
);
2276 SCM_ASSERT (scm_is_null (l2
), entry
, SCM_ARGn
, caller
);
2277 SCM_ASSERT (!mutable || !immutable
, entry
, SCM_ARGn
, caller
);
2279 if (!mutable && !immutable
)
2282 mutability
= mutable ? symbol_mutable_location
: symbol_immutable_location
;
2283 new_entry
= scm_cons2 (sym
, mutability
, SCM_EOL
);
2284 result
= scm_cons (new_entry
, result
);
2287 SCM_ASSERT (scm_is_null (l
), signature
, SCM_ARGn
, caller
);
2289 /* Dirk:FIXME:: Now we know that signature is syntactically correct. There
2290 * are, however, no checks for symbols entered twice with contradicting
2291 * mutabilities. It would be nice, to implement this test, to be able to
2292 * call the sort functions conveniently from C.
2295 return scm_reverse (result
);
2299 SCM_DEFINE (scm_export_environment_set_signature_x
, "export-environment-set-signature!", 2, 0, 0,
2300 (SCM env
, SCM signature
),
2301 "Change the signature of export environment @var{env}.")
2302 #define FUNC_NAME s_scm_export_environment_set_signature_x
2306 SCM_ASSERT (SCM_EXPORT_ENVIRONMENT_P (env
), env
, SCM_ARG1
, FUNC_NAME
);
2307 parsed_sig
= export_environment_parse_signature (signature
, FUNC_NAME
);
2309 EXPORT_ENVIRONMENT (env
)->signature
= parsed_sig
;
2311 return SCM_UNSPECIFIED
;
2318 scm_environments_prehistory ()
2320 /* create environment smob */
2321 scm_tc16_environment
= scm_make_smob_type ("environment", 0);
2322 scm_set_smob_mark (scm_tc16_environment
, environment_mark
);
2323 scm_set_smob_free (scm_tc16_environment
, environment_free
);
2324 scm_set_smob_print (scm_tc16_environment
, environment_print
);
2326 /* create observer smob */
2327 scm_tc16_observer
= scm_make_smob_type ("observer", 0);
2328 scm_set_smob_mark (scm_tc16_observer
, observer_mark
);
2329 scm_set_smob_print (scm_tc16_observer
, observer_print
);
2331 /* create system environment */
2332 scm_system_environment
= scm_make_leaf_environment ();
2333 scm_permanent_object (scm_system_environment
);
2338 scm_init_environments ()
2340 #include "libguile/environments.x"