1 /* Copyright (C) 1999, 2000 Free Software Foundation, Inc.
3 * This program is free software; you can redistribute it and/or modify
4 * it under the terms of the GNU General Public License as published by
5 * the Free Software Foundation; either version 2, or (at your option)
8 * This program 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
11 * GNU General Public License for more details.
13 * You should have received a copy of the GNU General Public License
14 * along with this software; see the file COPYING. If not, write to
15 * the Free Software Foundation, Inc., 59 Temple Place, Suite 330,
16 * Boston, MA 02111-1307 USA
18 * As a special exception, the Free Software Foundation gives permission
19 * for additional uses of the text contained in its release of GUILE.
21 * The exception is that, if you link the GUILE library with other files
22 * to produce an executable, this does not by itself cause the
23 * resulting executable to be covered by the GNU General Public License.
24 * Your use of that executable is in no way restricted on account of
25 * linking the GUILE library code into it.
27 * This exception does not however invalidate any other reasons why
28 * the executable file might be covered by the GNU General Public License.
30 * This exception applies only to the code released by the
31 * Free Software Foundation under the name GUILE. If you copy
32 * code from other Free Software Foundation releases into a copy of
33 * GUILE, as the General Public License permits, the exception does
34 * not apply to the code that you add in this way. To avoid misleading
35 * anyone as to the status of such modified files, you must delete
36 * this exception notice from them.
38 * If you write modifications of your own for GUILE, it is your choice
39 * whether to permit this exception to apply to your modifications.
40 * If you do not wish that, delete this exception notice. */
44 #include "libguile/_scm.h"
45 #include "libguile/alist.h"
46 #include "libguile/eval.h"
47 #include "libguile/gh.h"
48 #include "libguile/hash.h"
49 #include "libguile/ports.h"
50 #include "libguile/smob.h"
51 #include "libguile/symbols.h"
52 #include "libguile/vectors.h"
53 #include "libguile/weaks.h"
55 #include "libguile/environments.h"
59 long scm_tc16_environment
;
60 long scm_tc16_observer
;
64 /* error conditions */
67 * Throw an error if symbol is not bound in environment func
70 scm_error_environment_unbound (const char *func
, SCM env
, SCM symbol
)
72 /* Dirk:FIXME:: Should throw an environment:unbound type error */
73 char error
[] = "Symbol `~A' not bound in environment `~A'.";
74 SCM arguments
= scm_cons2 (symbol
, env
, SCM_EOL
);
75 scm_misc_error (func
, error
, arguments
);
80 * Throw an error if func tried to create (define) or remove
81 * (undefine) a new binding for symbol in env
84 scm_error_environment_immutable_binding (const char *func
, SCM env
, SCM symbol
)
86 /* Dirk:FIXME:: Should throw an environment:immutable-binding type error */
87 char error
[] = "Immutable binding in environment ~A (symbol: `~A').";
88 SCM arguments
= scm_cons2 (env
, symbol
, SCM_EOL
);
89 scm_misc_error (func
, error
, arguments
);
94 * Throw an error if func tried to change an immutable location.
97 scm_error_environment_immutable_location (const char *func
, SCM env
, SCM symbol
)
99 /* Dirk:FIXME:: Should throw an environment:immutable-location type error */
100 char error
[] = "Immutable location in environment `~A' (symbol: `~A').";
101 SCM arguments
= scm_cons2 (env
, symbol
, SCM_EOL
);
102 scm_misc_error (func
, error
, arguments
);
107 /* generic environments */
110 /* Create an environment for the given type. Dereferencing type twice must
111 * deliver the initialized set of environment functions. Thus, type will
112 * also determine the signature of the underlying environment implementation.
113 * Dereferencing type once will typically deliver the data fields used by the
114 * underlying environment implementation.
117 scm_make_environment (void *type
)
122 SCM_SET_CELL_WORD_1 (env
, type
);
123 SCM_SET_CELL_TYPE (env
, scm_tc16_environment
);
129 SCM_DEFINE (scm_environment_p
, "environment?", 1, 0, 0,
131 "Return #t if OBJ is an environment, or #f otherwise.")
132 #define FUNC_NAME s_scm_environment_p
134 return SCM_BOOL (SCM_ENVIRONMENT_P (obj
));
139 SCM_DEFINE (scm_environment_bound_p
, "environment-bound?", 2, 0, 0,
141 "Return #t if SYM is bound in ENV, or #f otherwise.")
142 #define FUNC_NAME s_scm_environment_bound_p
144 SCM_ASSERT (SCM_ENVIRONMENT_P (env
), env
, SCM_ARG1
, FUNC_NAME
);
145 SCM_ASSERT (SCM_SYMBOLP (sym
), sym
, SCM_ARG2
, FUNC_NAME
);
147 return SCM_BOOL (SCM_ENVIRONMENT_BOUND_P (env
, sym
));
152 SCM_DEFINE (scm_environment_ref
, "environment-ref", 2, 0, 0,
154 "Return the value of the location bound to SYM in ENV.\n"
155 "If SYM is unbound in ENV, signal an environment:unbound\n"
157 #define FUNC_NAME s_scm_environment_ref
161 SCM_ASSERT (SCM_ENVIRONMENT_P (env
), env
, SCM_ARG1
, FUNC_NAME
);
162 SCM_ASSERT (SCM_SYMBOLP (sym
), sym
, SCM_ARG2
, FUNC_NAME
);
164 val
= SCM_ENVIRONMENT_REF (env
, sym
);
166 if (!SCM_UNBNDP (val
))
169 scm_error_environment_unbound (FUNC_NAME
, env
, sym
);
174 /* This C function is identical to environment-ref, except that if symbol is
175 * unbound in env, it returns the value SCM_UNDEFINED, instead of signalling
179 scm_c_environment_ref (SCM env
, SCM sym
)
181 SCM_ASSERT (SCM_ENVIRONMENT_P (env
), env
, SCM_ARG1
, "scm_c_environment_ref");
182 SCM_ASSERT (SCM_SYMBOLP (sym
), sym
, SCM_ARG2
, "scm_c_environment_ref");
183 return SCM_ENVIRONMENT_REF (env
, sym
);
188 environment_default_folder (SCM proc
, SCM symbol
, SCM value
, SCM tail
)
190 return gh_call3 (proc
, symbol
, value
, tail
);
194 SCM_DEFINE (scm_environment_fold
, "environment-fold", 3, 0, 0,
195 (SCM env
, SCM proc
, SCM init
),
196 "Iterate over all the bindings in ENV, accumulating some value.\n"
197 "For each binding in ENV, apply PROC to the symbol bound, its\n"
198 "value, and the result from the previous application of PROC.\n"
199 "Use INIT as PROC's third argument the first time PROC is\n"
201 "If ENV contains no bindings, this function simply returns INIT.\n"
202 "If ENV binds the symbol sym1 to the value val1, sym2 to val2,\n"
203 "and so on, then this procedure computes:\n"
209 "Each binding in ENV will be processed exactly once.\n"
210 "environment-fold makes no guarantees about the order in which\n"
211 "the bindings are processed.\n"
212 "Here is a function which, given an environment, constructs an\n"
213 "association list representing that environment's bindings,\n"
214 "using environment-fold:\n"
215 " (define (environment->alist env)\n"
216 " (environment-fold env\n"
217 " (lambda (sym val tail)\n"
218 " (cons (cons sym val) tail))\n"
220 #define FUNC_NAME s_scm_environment_fold
222 SCM_ASSERT (SCM_ENVIRONMENT_P (env
), env
, SCM_ARG1
, FUNC_NAME
);
223 SCM_ASSERT (SCM_EQ_P (scm_procedure_p (proc
), SCM_BOOL_T
),
224 proc
, SCM_ARG2
, FUNC_NAME
);
226 return SCM_ENVIRONMENT_FOLD (env
, environment_default_folder
, proc
, init
);
231 /* This is the C-level analog of environment-fold. For each binding in ENV,
233 * (*proc) (data, symbol, value, previous)
234 * where previous is the value returned from the last call to *PROC, or INIT
235 * for the first call. If ENV contains no bindings, return INIT.
238 scm_c_environment_fold (SCM env
, scm_environment_folder proc
, SCM data
, SCM init
)
240 SCM_ASSERT (SCM_ENVIRONMENT_P (env
), env
, SCM_ARG1
, "scm_c_environment_fold");
242 return SCM_ENVIRONMENT_FOLD (env
, proc
, data
, init
);
246 SCM_DEFINE (scm_environment_define
, "environment-define", 3, 0, 0,
247 (SCM env
, SCM sym
, SCM val
),
248 "Bind SYM to a new location containing VAL in ENV. If SYM is\n"
249 "already bound to another location in ENV and the binding is\n"
250 "mutable, that binding is replaced. The new binding and\n"
251 "location are both mutable. The return value is unspecified.\n"
252 "If SYM is already bound in ENV, and the binding is immutable,\n"
253 "signal an environment:immutable-binding error.")
254 #define FUNC_NAME s_scm_environment_define
258 SCM_ASSERT (SCM_ENVIRONMENT_P (env
), env
, SCM_ARG1
, FUNC_NAME
);
259 SCM_ASSERT (SCM_SYMBOLP (sym
), sym
, SCM_ARG2
, FUNC_NAME
);
261 status
= SCM_ENVIRONMENT_DEFINE (env
, sym
, val
);
263 if (SCM_EQ_P (status
, SCM_ENVIRONMENT_SUCCESS
))
264 return SCM_UNSPECIFIED
;
265 else if (SCM_EQ_P (status
, SCM_ENVIRONMENT_BINDING_IMMUTABLE
))
266 scm_error_environment_immutable_binding (FUNC_NAME
, env
, sym
);
273 SCM_DEFINE (scm_environment_undefine
, "environment-undefine", 2, 0, 0,
275 "Remove any binding for SYM from ENV. If SYM is unbound in ENV,\n"
276 "do nothing. The return value is unspecified.\n"
277 "If SYM is already bound in ENV, and the binding is immutable,\n"
278 "signal an environment:immutable-binding error.")
279 #define FUNC_NAME s_scm_environment_undefine
283 SCM_ASSERT(SCM_ENVIRONMENT_P(env
), env
, SCM_ARG1
, FUNC_NAME
);
284 SCM_ASSERT(SCM_SYMBOLP(sym
), sym
, SCM_ARG2
, FUNC_NAME
);
286 status
= SCM_ENVIRONMENT_UNDEFINE (env
, sym
);
288 if (SCM_EQ_P (status
, SCM_ENVIRONMENT_SUCCESS
))
289 return SCM_UNSPECIFIED
;
290 else if (SCM_EQ_P (status
, SCM_ENVIRONMENT_BINDING_IMMUTABLE
))
291 scm_error_environment_immutable_binding (FUNC_NAME
, env
, sym
);
298 SCM_DEFINE (scm_environment_set_x
, "environment-set!", 3, 0, 0,
299 (SCM env
, SCM sym
, SCM val
),
300 "If ENV binds SYM to some location, change that location's\n"
301 "value to VAL. The return value is unspecified.\n"
302 "If SYM is not bound in ENV, signal an environment:unbound\n"
303 "error. If ENV binds SYM to an immutable location, signal an\n"
304 "environment:immutable-location error.")
305 #define FUNC_NAME s_scm_environment_set_x
309 SCM_ASSERT (SCM_ENVIRONMENT_P (env
), env
, SCM_ARG1
, FUNC_NAME
);
310 SCM_ASSERT (SCM_SYMBOLP (sym
), sym
, SCM_ARG2
, FUNC_NAME
);
312 status
= SCM_ENVIRONMENT_SET (env
, sym
, val
);
314 if (SCM_EQ_P (status
, SCM_ENVIRONMENT_SUCCESS
))
315 return SCM_UNSPECIFIED
;
316 else if (SCM_UNBNDP (status
))
317 scm_error_environment_unbound (FUNC_NAME
, env
, sym
);
318 else if (SCM_EQ_P (status
, SCM_ENVIRONMENT_LOCATION_IMMUTABLE
))
319 scm_error_environment_immutable_binding (FUNC_NAME
, env
, sym
);
326 SCM_DEFINE (scm_environment_cell
, "environment-cell", 3, 0, 0,
327 (SCM env
, SCM sym
, SCM for_write
),
328 "Return the value cell which ENV binds to SYM, or #f if the\n"
329 "binding does not live in a value cell.\n"
330 "The argument FOR-WRITE indicates whether the caller intends\n"
331 "to modify the variable's value by mutating the value cell. If\n"
332 "the variable is immutable, then environment-cell signals an\n"
333 "environment:immutable-location error.\n"
334 "If SYM is unbound in ENV, signal an environment:unbound error.\n"
335 "If you use this function, you should consider using\n"
336 "environment-observe, to be notified when SYM gets re-bound to\n"
337 "a new value cell, or becomes undefined.")
338 #define FUNC_NAME s_scm_environment_cell
342 SCM_ASSERT (SCM_ENVIRONMENT_P (env
), env
, SCM_ARG1
, FUNC_NAME
);
343 SCM_ASSERT (SCM_SYMBOLP (sym
), sym
, SCM_ARG2
, FUNC_NAME
);
344 SCM_ASSERT (SCM_BOOLP (for_write
), for_write
, SCM_ARG3
, FUNC_NAME
);
346 location
= SCM_ENVIRONMENT_CELL (env
, sym
, !SCM_FALSEP (for_write
));
347 if (!SCM_IMP (location
))
349 else if (SCM_UNBNDP (location
))
350 scm_error_environment_unbound (FUNC_NAME
, env
, sym
);
351 else if (SCM_EQ_P (location
, SCM_ENVIRONMENT_LOCATION_IMMUTABLE
))
352 scm_error_environment_immutable_location (FUNC_NAME
, env
, sym
);
359 /* This C function is identical to environment-cell, with the following
360 * exceptions: If symbol is unbound in env, it returns the value
361 * SCM_UNDEFINED, instead of signalling an error. If symbol is bound to an
362 * immutable location but the cell is requested for write, the value
363 * SCM_ENVIRONMENT_LOCATION_IMMUTABLE is returned.
366 scm_c_environment_cell(SCM env
, SCM sym
, int for_write
)
368 SCM_ASSERT (SCM_ENVIRONMENT_P (env
), env
, SCM_ARG1
, "scm_c_environment_cell");
369 SCM_ASSERT (SCM_SYMBOLP (sym
), sym
, SCM_ARG2
, "scm_c_environment_cell");
371 return SCM_ENVIRONMENT_CELL (env
, sym
, for_write
);
376 environment_default_observer (SCM env
, SCM proc
)
378 gh_call1 (proc
, env
);
382 SCM_DEFINE (scm_environment_observe
, "environment-observe", 2, 0, 0,
384 "Whenever ENV's bindings change, apply PROC to ENV.\n"
385 "This function returns an object, token, which you can pass to\n"
386 "environment-unobserve to remove PROC from the set of\n"
387 "procedures observing ENV. The type and value of token is\n"
389 #define FUNC_NAME s_scm_environment_observe
391 SCM_ASSERT (SCM_ENVIRONMENT_P (env
), env
, SCM_ARG1
, FUNC_NAME
);
393 return SCM_ENVIRONMENT_OBSERVE (env
, environment_default_observer
, proc
, 0);
398 SCM_DEFINE (scm_environment_observe_weak
, "environment-observe-weak", 2, 0, 0,
400 "This function is the same as environment-observe, except that\n"
401 "the reference ENV retains to PROC is a weak reference. This\n"
402 "means that, if there are no other live, non-weak references\n"
403 "to PROC, it will be garbage-collected, and dropped from ENV's\n"
404 "list of observing procedures.")
405 #define FUNC_NAME s_scm_environment_observe_weak
407 SCM_ASSERT (SCM_ENVIRONMENT_P (env
), env
, SCM_ARG1
, FUNC_NAME
);
409 return SCM_ENVIRONMENT_OBSERVE (env
, environment_default_observer
, proc
, 1);
414 /* This is the C-level analog of the Scheme functions environment-observe and
415 * environment-observe-weak. Whenever env's bindings change, call the
416 * function proc, passing it env and data. If weak_p is non-zero, env will
417 * retain only a weak reference to data, and if data is garbage collected, the
418 * entire observation will be dropped. This function returns a token, with
419 * the same meaning as those returned by environment-observe and
420 * environment-observe-weak.
423 scm_c_environment_observe (SCM env
, scm_environment_observer proc
, SCM data
, int weak_p
)
424 #define FUNC_NAME "scm_c_environment_observe"
426 SCM_ASSERT (SCM_ENVIRONMENT_P (env
), env
, SCM_ARG1
, FUNC_NAME
);
428 return SCM_ENVIRONMENT_OBSERVE (env
, proc
, data
, weak_p
);
433 SCM_DEFINE (scm_environment_unobserve
, "environment-unobserve", 1, 0, 0,
435 "Cancel the observation request which returned the value\n"
436 "TOKEN. The return value is unspecified.\n"
437 "If a call (environment-observe env proc) returns token, then\n"
438 "the call (environment-unobserve token) will cause proc to no\n"
439 "longer be called when env's bindings change.")
440 #define FUNC_NAME s_scm_environment_unobserve
444 SCM_ASSERT (SCM_OBSERVER_P (token
), token
, SCM_ARG1
, FUNC_NAME
);
446 env
= SCM_OBSERVER_ENVIRONMENT (token
);
447 SCM_ENVIRONMENT_UNOBSERVE (env
, token
);
449 return SCM_UNSPECIFIED
;
455 mark_environment (SCM env
)
457 return (*(SCM_ENVIRONMENT_FUNCS (env
)->mark
)) (env
);
462 free_environment (SCM env
)
464 return (*(SCM_ENVIRONMENT_FUNCS (env
)->free
)) (env
);
469 print_environment (SCM env
, SCM port
, scm_print_state
*pstate
)
471 return (*(SCM_ENVIRONMENT_FUNCS (env
)->print
)) (env
, port
, pstate
);
479 mark_observer (SCM observer
)
481 scm_gc_mark (SCM_OBSERVER_ENVIRONMENT (observer
));
482 scm_gc_mark (SCM_OBSERVER_DATA (observer
));
488 free_observer (SCM observer_smob
)
495 print_observer (SCM type
, SCM port
, scm_print_state
*pstate
)
497 SCM address
= scm_ulong2num (SCM_UNPACK (type
));
498 SCM base16
= scm_number_to_string (address
, SCM_MAKINUM (16));
500 scm_puts ("#<observer ", port
);
501 scm_puts (SCM_STRING_CHARS (base16
), port
);
502 scm_puts (">", port
);
511 * Obarrays form the basic lookup tables used to implement most of guile's
512 * built-in environment types. An obarray is implemented as a hash table with
513 * symbols as keys. The content of the data depends on the environment type.
518 * Enter symbol into obarray. The symbol must not already exist in obarray.
519 * The freshly generated (symbol . data) cell is returned.
522 obarray_enter (SCM obarray
, SCM symbol
, SCM data
)
524 scm_sizet hash
= SCM_SYMBOL_HASH (symbol
) % SCM_LENGTH (obarray
);
525 SCM entry
= scm_cons (symbol
, data
);
526 SCM slot
= scm_cons (entry
, SCM_VELTS (obarray
)[hash
]);
527 SCM_VELTS (obarray
)[hash
] = slot
;
534 * Enter symbol into obarray. An existing entry for symbol is replaced. If
535 * an entry existed, the old (symbol . data) cell is returned, #f otherwise.
538 obarray_replace (SCM obarray
, SCM symbol
, SCM data
)
540 scm_sizet hash
= SCM_SYMBOL_HASH (symbol
) % SCM_LENGTH (obarray
);
541 SCM new_entry
= scm_cons (symbol
, data
);
545 for (lsym
= SCM_VELTS (obarray
)[hash
]; !SCM_NULLP (lsym
); lsym
= SCM_CDR (lsym
))
547 SCM old_entry
= SCM_CAR (lsym
);
548 if (SCM_CAR (old_entry
) == symbol
)
550 SCM_SETCAR (lsym
, new_entry
);
555 slot
= scm_cons (new_entry
, SCM_VELTS (obarray
)[hash
]);
556 SCM_VELTS (obarray
)[hash
] = slot
;
563 * Look up symbol in obarray
566 obarray_retrieve (SCM obarray
, SCM sym
)
568 scm_sizet hash
= SCM_SYMBOL_HASH (sym
) % SCM_LENGTH (obarray
);
571 for (lsym
= SCM_VELTS (obarray
)[hash
]; !SCM_NULLP (lsym
); lsym
= SCM_CDR (lsym
))
573 SCM entry
= SCM_CAR (lsym
);
574 if (SCM_CAR (entry
) == sym
)
578 return SCM_UNDEFINED
;
583 * Remove entry from obarray. If the symbol was found and removed, the old
584 * (symbol . data) cell is returned, #f otherwise.
587 obarray_remove (SCM obarray
, SCM sym
)
589 scm_sizet hash
= SCM_SYMBOL_HASH (sym
) % SCM_LENGTH (obarray
);
593 /* Dirk:FIXME:: gc problem due to use of &SCM_VELTS[hash] */
594 for (lsym
= *(lsymp
= &SCM_VELTS (obarray
)[hash
]);
596 lsym
= *(lsymp
= SCM_CDRLOC (lsym
)))
598 SCM entry
= SCM_CAR (lsym
);
599 if (SCM_CAR (entry
) == sym
)
601 *lsymp
= SCM_CDR (lsym
);
610 obarray_remove_all (SCM obarray
)
612 scm_sizet size
= SCM_LENGTH (obarray
);
615 for (i
= 0; i
< size
; i
++)
617 SCM_VELTS (obarray
)[i
] = SCM_EOL
;
623 /* core environments base
625 * This struct and the corresponding functions form a base class for guile's
626 * built-in environment types.
630 struct core_environments_base
{
631 struct scm_environment_funcs
*funcs
;
638 #define CORE_ENVIRONMENTS_BASE(env) \
639 ((struct core_environments_base *) SCM_CELL_WORD_1 (env))
640 #define CORE_ENVIRONMENT_OBSERVERS(env) \
641 (CORE_ENVIRONMENTS_BASE (env)->observers)
642 #define SCM_SET_CORE_ENVIRONMENT_OBSERVERS(env, v) \
643 (CORE_ENVIRONMENT_OBSERVERS (env) = (v))
644 #define CORE_ENVIRONMENT_WEAK_OBSERVER_VECTOR(env) \
645 (CORE_ENVIRONMENTS_BASE (env)->weak_observers)
646 #define CORE_ENVIRONMENT_WEAK_OBSERVERS(env) \
647 (SCM_VELTS (CORE_ENVIRONMENT_WEAK_OBSERVER_VECTOR (env)) [0])
648 #define SCM_SET_CORE_ENVIRONMENT_WEAK_OBSERVERS(env, v) \
649 (SCM_VELTS (CORE_ENVIRONMENT_WEAK_OBSERVER_VECTOR (env)) [0] = (v))
654 core_environments_observe (SCM env
, scm_environment_observer proc
, SCM data
, int weak_p
)
658 SCM_NEWCELL2 (observer
);
659 SCM_SET_CELL_OBJECT_1 (observer
, env
);
660 SCM_SET_CELL_OBJECT_2 (observer
, data
);
661 SCM_SET_CELL_WORD_3 (observer
, proc
);
662 SCM_SET_CELL_TYPE (observer
, scm_tc16_observer
);
666 SCM observers
= CORE_ENVIRONMENT_OBSERVERS (env
);
667 SCM new_observers
= scm_cons (observer
, observers
);
668 SCM_SET_CORE_ENVIRONMENT_OBSERVERS (env
, new_observers
);
672 SCM observers
= CORE_ENVIRONMENT_WEAK_OBSERVERS (env
);
673 SCM new_observers
= scm_acons (SCM_BOOL_F
, observer
, observers
);
674 SCM_SET_CORE_ENVIRONMENT_WEAK_OBSERVERS (env
, new_observers
);
682 core_environments_unobserve (SCM env
, SCM observer
)
684 unsigned int handling_weaks
;
685 for (handling_weaks
= 0; handling_weaks
<= 1; ++handling_weaks
)
687 SCM l
= handling_weaks
688 ? CORE_ENVIRONMENT_WEAK_OBSERVERS (env
)
689 : CORE_ENVIRONMENT_OBSERVERS (env
);
693 SCM rest
= SCM_CDR (l
);
694 SCM first
= handling_weaks
698 if (SCM_EQ_P (first
, observer
))
700 /* Remove the first observer */
702 ? SCM_SET_CORE_ENVIRONMENT_WEAK_OBSERVERS (env
, rest
)
703 : SCM_SET_CORE_ENVIRONMENT_OBSERVERS (env
, rest
);
708 SCM rest
= SCM_CDR (l
);
710 if (!SCM_NULLP (rest
))
712 SCM next
= handling_weaks
716 if (SCM_EQ_P (next
, observer
))
718 SCM_SETCDR (l
, SCM_CDR (rest
));
724 } while (!SCM_NULLP (l
));
728 /* Dirk:FIXME:: What to do now, since the observer is not found? */
733 core_environments_mark (SCM env
)
735 scm_gc_mark (CORE_ENVIRONMENT_OBSERVERS (env
));
736 return CORE_ENVIRONMENT_WEAK_OBSERVER_VECTOR (env
);
741 core_environments_finalize (SCM env
)
747 core_environments_preinit (struct core_environments_base
*body
)
750 body
->observers
= SCM_BOOL_F
;
751 body
->weak_observers
= SCM_BOOL_F
;
756 core_environments_init (struct core_environments_base
*body
,
757 struct scm_environment_funcs
*funcs
)
760 body
->observers
= SCM_EOL
;
761 body
->weak_observers
= scm_make_weak_value_hash_table (SCM_MAKINUM (1));
765 /* Tell all observers to clear their caches.
767 * Environments have to be informed about changes in the following cases:
768 * - The observed env has a new binding. This must be always reported.
769 * - The observed env has dropped a binding. This must be always reported.
770 * - A binding in the observed environment has changed. This must only be
771 * reported, if there is a chance that the binding is being cached outside.
772 * However, this potential optimization is not performed currently.
774 * Errors that occur while the observers are called are accumulated and
775 * signalled as one single error message to the caller.
786 update_catch_body (void *ptr
)
788 struct update_data
*data
= (struct update_data
*) ptr
;
789 SCM observer
= data
->observer
;
791 (*SCM_OBSERVER_PROC (observer
))
792 (data
->environment
, SCM_OBSERVER_DATA (observer
));
794 return SCM_UNDEFINED
;
799 update_catch_handler (void *ptr
, SCM tag
, SCM args
)
801 struct update_data
*data
= (struct update_data
*) ptr
;
802 SCM observer
= data
->observer
;
803 SCM message
= scm_makfrom0str ("Observer `~A' signals `~A' error: ~S");
805 return scm_cons (message
, scm_listify (observer
, tag
, args
, SCM_UNDEFINED
));
810 core_environments_broadcast (SCM env
)
811 #define FUNC_NAME "core_environments_broadcast"
813 unsigned int handling_weaks
;
814 SCM errors
= SCM_EOL
;
816 for (handling_weaks
= 0; handling_weaks
<= 1; ++handling_weaks
)
818 SCM observers
= handling_weaks
819 ? CORE_ENVIRONMENT_WEAK_OBSERVERS (env
)
820 : CORE_ENVIRONMENT_OBSERVERS (env
);
822 for (; !SCM_NULLP (observers
); observers
= SCM_CDR (observers
))
824 struct update_data data
;
825 SCM observer
= handling_weaks
826 ? SCM_CDAR (observers
)
827 : SCM_CAR (observers
);
830 data
.observer
= observer
;
831 data
.environment
= env
;
833 error
= scm_internal_catch (SCM_BOOL_T
,
834 update_catch_body
, &data
,
835 update_catch_handler
, &data
);
837 if (!SCM_UNBNDP (error
))
838 errors
= scm_cons (error
, errors
);
842 if (!SCM_NULLP (errors
))
844 /* Dirk:FIXME:: As soon as scm_misc_error is fixed to handle the name
845 * parameter correctly it should not be necessary any more to also pass
846 * namestr in order to get the desired information from the error
849 SCM ordered_errors
= scm_reverse (errors
);
852 "Observers of `~A' have signalled the following errors: ~S",
853 scm_cons2 (env
, ordered_errors
, SCM_EOL
));
862 * A leaf environment is simply a mutable set of definitions. A leaf
863 * environment supports no operations beyond the common set.
865 * Implementation: The obarray of the leaf environment holds (symbol . value)
866 * pairs. No further information is necessary, since all bindings and
867 * locations in a leaf environment are mutable.
871 struct leaf_environment
{
872 struct core_environments_base base
;
878 #define LEAF_ENVIRONMENT(env) \
879 ((struct leaf_environment *) SCM_CELL_WORD_1 (env))
884 leaf_environment_ref (SCM env
, SCM sym
)
886 SCM obarray
= LEAF_ENVIRONMENT (env
)->obarray
;
887 SCM binding
= obarray_retrieve (obarray
, sym
);
888 return SCM_UNBNDP (binding
) ? binding
: SCM_CDR (binding
);
893 leaf_environment_fold (SCM env
, scm_environment_folder proc
, SCM data
, SCM init
)
897 SCM obarray
= LEAF_ENVIRONMENT (env
)->obarray
;
899 for (i
= 0; i
< SCM_LENGTH (obarray
); i
++)
902 for (l
= SCM_VELTS (obarray
)[i
]; !SCM_NULLP (l
); l
= SCM_CDR (l
))
904 SCM binding
= SCM_CAR (l
);
905 SCM symbol
= SCM_CAR (binding
);
906 SCM value
= SCM_CDR (binding
);
907 result
= (*proc
) (data
, symbol
, value
, result
);
915 leaf_environment_define (SCM env
, SCM sym
, SCM val
)
916 #define FUNC_NAME "leaf_environment_define"
918 SCM obarray
= LEAF_ENVIRONMENT (env
)->obarray
;
920 obarray_replace (obarray
, sym
, val
);
921 core_environments_broadcast (env
);
923 return SCM_ENVIRONMENT_SUCCESS
;
929 leaf_environment_undefine (SCM env
, SCM sym
)
930 #define FUNC_NAME "leaf_environment_undefine"
932 SCM obarray
= LEAF_ENVIRONMENT (env
)->obarray
;
933 SCM removed
= obarray_remove (obarray
, sym
);
935 if (!SCM_FALSEP (removed
))
936 core_environments_broadcast (env
);
938 return SCM_ENVIRONMENT_SUCCESS
;
944 leaf_environment_set_x (SCM env
, SCM sym
, SCM val
)
945 #define FUNC_NAME "leaf_environment_set_x"
947 SCM obarray
= LEAF_ENVIRONMENT (env
)->obarray
;
948 SCM binding
= obarray_retrieve (obarray
, sym
);
950 if (!SCM_UNBNDP (binding
))
952 SCM_SETCDR (binding
, val
);
953 return SCM_ENVIRONMENT_SUCCESS
;
957 return SCM_UNDEFINED
;
964 leaf_environment_cell(SCM env
, SCM sym
, int for_write
)
966 SCM obarray
= LEAF_ENVIRONMENT (env
)->obarray
;
967 SCM binding
= obarray_retrieve (obarray
, sym
);
973 mark_leaf_environment (SCM env
)
975 scm_gc_mark (LEAF_ENVIRONMENT (env
)->obarray
);
976 return core_environments_mark (env
);
981 free_leaf_environment (SCM env
)
983 core_environments_finalize (env
);
985 free (LEAF_ENVIRONMENT (env
));
986 return sizeof (struct leaf_environment
);
991 print_leaf_environment (SCM type
, SCM port
, scm_print_state
*pstate
)
993 SCM address
= scm_ulong2num (SCM_UNPACK (type
));
994 SCM base16
= scm_number_to_string (address
, SCM_MAKINUM (16));
996 scm_puts ("#<leaf environment ", port
);
997 scm_puts (SCM_STRING_CHARS (base16
), port
);
998 scm_puts (">", port
);
1004 static struct scm_environment_funcs leaf_environment_funcs
= {
1005 leaf_environment_ref
,
1006 leaf_environment_fold
,
1007 leaf_environment_define
,
1008 leaf_environment_undefine
,
1009 leaf_environment_set_x
,
1010 leaf_environment_cell
,
1011 core_environments_observe
,
1012 core_environments_unobserve
,
1013 mark_leaf_environment
,
1014 free_leaf_environment
,
1015 print_leaf_environment
1019 void *scm_type_leaf_environment
= &leaf_environment_funcs
;
1022 SCM_DEFINE (scm_make_leaf_environment
, "make-leaf-environment", 0, 0, 0,
1024 "Create a new leaf environment, containing no bindings.\n"
1025 "All bindings and locations created in the new environment\n"
1027 #define FUNC_NAME s_scm_make_leaf_environment
1029 scm_sizet size
= sizeof (struct leaf_environment
);
1030 struct leaf_environment
*body
= scm_must_malloc (size
, FUNC_NAME
);
1033 core_environments_preinit (&body
->base
);
1034 body
->obarray
= SCM_BOOL_F
;
1036 env
= scm_make_environment (body
);
1038 core_environments_init (&body
->base
, &leaf_environment_funcs
);
1039 body
->obarray
= scm_make_vector (SCM_MAKINUM (scm_symhash_dim
), SCM_EOL
);
1046 SCM_DEFINE (scm_leaf_environment_p
, "leaf-environment?", 1, 0, 0,
1048 "Return #t if object is a leaf environment, or #f otherwise.")
1049 #define FUNC_NAME s_scm_leaf_environment_p
1051 return SCM_BOOL (SCM_LEAF_ENVIRONMENT_P (object
));
1057 /* eval environments
1059 * A module's source code refers to definitions imported from other modules,
1060 * and definitions made within itself. An eval environment combines two
1061 * environments -- a local environment and an imported environment -- to
1062 * produce a new environment in which both sorts of references can be
1065 * Implementation: The obarray of the eval environment is used to cache
1066 * entries from the local and imported environments such that in most of the
1067 * cases only a single lookup is necessary. Since for neither the local nor
1068 * the imported environment it is known, what kind of environment they form,
1069 * the most general case is assumed. Therefore, entries in the obarray take
1070 * one of the following forms:
1072 * 1) (<symbol> location mutability . source-env), where mutability indicates
1073 * one of the following states: IMMUTABLE if the location is known to be
1074 * immutable, MUTABLE if the location is known to be mutable, UNKNOWN if
1075 * the location has only been requested for non modifying accesses.
1077 * 2) (symbol . source-env) if the symbol has a binding in the source-env, but
1078 * if the source-env can't provide a cell for the binding. Thus, for every
1079 * access, the source-env has to be contacted directly.
1083 struct eval_environment
{
1084 struct core_environments_base base
;
1089 SCM imported_observer
;
1095 #define EVAL_ENVIRONMENT(env) \
1096 ((struct eval_environment *) SCM_CELL_WORD_1 (env))
1098 #define IMMUTABLE SCM_MAKINUM (0)
1099 #define MUTABLE SCM_MAKINUM (1)
1100 #define UNKNOWN SCM_MAKINUM (2)
1102 #define CACHED_LOCATION(x) SCM_CAR (x)
1103 #define CACHED_MUTABILITY(x) SCM_CADR (x)
1104 #define SET_CACHED_MUTABILITY(x, v) SCM_SETCAR (SCM_CDR (x), (v))
1105 #define CACHED_SOURCE_ENVIRONMENT(x) SCM_CDDR (x)
1109 /* eval_environment_lookup will report one of the following distinct results:
1110 * a) (<object> . value) if a cell could be obtained.
1111 * b) <environment> if the environment has to be contacted directly.
1112 * c) IMMUTABLE if an immutable cell was requested for write.
1113 * d) SCM_UNDEFINED if there is no binding for the symbol.
1116 eval_environment_lookup (SCM env
, SCM sym
, int for_write
)
1118 SCM obarray
= EVAL_ENVIRONMENT (env
)->obarray
;
1119 SCM binding
= obarray_retrieve (obarray
, sym
);
1121 if (!SCM_UNBNDP (binding
))
1123 /* The obarray holds an entry for the symbol. */
1125 SCM entry
= SCM_CDR (binding
);
1127 if (SCM_CONSP (entry
))
1129 /* The entry in the obarray is a cached location. */
1131 SCM location
= CACHED_LOCATION (entry
);
1137 mutability
= CACHED_MUTABILITY (entry
);
1138 if (SCM_EQ_P (mutability
, MUTABLE
))
1141 if (SCM_EQ_P (mutability
, UNKNOWN
))
1143 SCM source_env
= CACHED_SOURCE_ENVIRONMENT (entry
);
1144 SCM location
= SCM_ENVIRONMENT_CELL (source_env
, sym
, 1);
1146 if (SCM_CONSP (location
))
1148 SET_CACHED_MUTABILITY (entry
, MUTABLE
);
1151 else /* IMMUTABLE */
1153 SET_CACHED_MUTABILITY (entry
, IMMUTABLE
);
1162 /* The obarray entry is an environment */
1169 /* There is no entry for the symbol in the obarray. This can either
1170 * mean that there has not been a request for the symbol yet, or that
1171 * the symbol is really undefined. We are looking for the symbol in
1172 * both the local and the imported environment. If we find a binding, a
1173 * cached entry is created.
1176 struct eval_environment
*body
= EVAL_ENVIRONMENT (env
);
1177 unsigned int handling_import
;
1179 for (handling_import
= 0; handling_import
<= 1; ++handling_import
)
1181 SCM source_env
= handling_import
? body
->imported
: body
->local
;
1182 SCM location
= SCM_ENVIRONMENT_CELL (source_env
, sym
, for_write
);
1184 if (!SCM_UNBNDP (location
))
1186 if (SCM_CONSP (location
))
1188 SCM mutability
= for_write
? MUTABLE
: UNKNOWN
;
1189 SCM entry
= scm_cons2 (location
, mutability
, source_env
);
1190 obarray_enter (obarray
, sym
, entry
);
1193 else if (SCM_EQ_P (location
, SCM_ENVIRONMENT_LOCATION_NO_CELL
))
1195 obarray_enter (obarray
, sym
, source_env
);
1205 return SCM_UNDEFINED
;
1211 eval_environment_ref (SCM env
, SCM sym
)
1212 #define FUNC_NAME "eval_environment_ref"
1214 SCM location
= eval_environment_lookup (env
, sym
, 0);
1216 if (SCM_CONSP (location
))
1217 return SCM_CDR (location
);
1218 else if (!SCM_UNBNDP (location
))
1219 return SCM_ENVIRONMENT_REF (location
, sym
);
1221 return SCM_UNDEFINED
;
1227 eval_environment_folder (SCM extended_data
, SCM symbol
, SCM value
, SCM tail
)
1229 SCM local
= SCM_CAR (extended_data
);
1231 if (!SCM_ENVIRONMENT_BOUND_P (local
, symbol
))
1233 SCM proc_as_nr
= SCM_CADR (extended_data
);
1234 unsigned long int proc_as_ul
= scm_num2ulong (proc_as_nr
, NULL
, NULL
);
1235 scm_environment_folder proc
= (scm_environment_folder
) proc_as_ul
;
1236 SCM data
= SCM_CDDR (extended_data
);
1238 return (*proc
) (data
, symbol
, value
, tail
);
1248 eval_environment_fold (SCM env
, scm_environment_folder proc
, SCM data
, SCM init
)
1250 SCM local
= EVAL_ENVIRONMENT (env
)->local
;
1251 SCM imported
= EVAL_ENVIRONMENT (env
)->imported
;
1252 SCM proc_as_nr
= scm_ulong2num ((unsigned long int) proc
);
1253 SCM extended_data
= scm_cons2 (local
, proc_as_nr
, data
);
1254 SCM tmp_result
= scm_c_environment_fold (imported
, eval_environment_folder
, extended_data
, init
);
1256 return scm_c_environment_fold (local
, proc
, data
, tmp_result
);
1261 eval_environment_define (SCM env
, SCM sym
, SCM val
)
1262 #define FUNC_NAME "eval_environment_define"
1264 SCM local
= EVAL_ENVIRONMENT (env
)->local
;
1265 return SCM_ENVIRONMENT_DEFINE (local
, sym
, val
);
1271 eval_environment_undefine (SCM env
, SCM sym
)
1272 #define FUNC_NAME "eval_environment_undefine"
1274 SCM local
= EVAL_ENVIRONMENT (env
)->local
;
1275 return SCM_ENVIRONMENT_UNDEFINE (local
, sym
);
1281 eval_environment_set_x (SCM env
, SCM sym
, SCM val
)
1282 #define FUNC_NAME "eval_environment_set_x"
1284 SCM location
= eval_environment_lookup (env
, sym
, 1);
1286 if (SCM_CONSP (location
))
1288 SCM_SETCDR (location
, val
);
1289 return SCM_ENVIRONMENT_SUCCESS
;
1291 else if (SCM_ENVIRONMENT_P (location
))
1293 return SCM_ENVIRONMENT_SET (location
, sym
, val
);
1295 else if (SCM_EQ_P (location
, IMMUTABLE
))
1297 return SCM_ENVIRONMENT_LOCATION_IMMUTABLE
;
1301 return SCM_UNDEFINED
;
1308 eval_environment_cell (SCM env
, SCM sym
, int for_write
)
1309 #define FUNC_NAME "eval_environment_cell"
1311 SCM location
= eval_environment_lookup (env
, sym
, for_write
);
1313 if (SCM_CONSP (location
))
1315 else if (SCM_ENVIRONMENT_P (location
))
1316 return SCM_ENVIRONMENT_LOCATION_NO_CELL
;
1317 else if (SCM_EQ_P (location
, IMMUTABLE
))
1318 return SCM_ENVIRONMENT_LOCATION_IMMUTABLE
;
1320 return SCM_UNDEFINED
;
1326 mark_eval_environment (SCM env
)
1328 struct eval_environment
*body
= EVAL_ENVIRONMENT (env
);
1330 scm_gc_mark (body
->obarray
);
1331 scm_gc_mark (body
->imported
);
1332 scm_gc_mark (body
->imported_observer
);
1333 scm_gc_mark (body
->local
);
1334 scm_gc_mark (body
->local_observer
);
1336 return core_environments_mark (env
);
1341 free_eval_environment (SCM env
)
1343 core_environments_finalize (env
);
1345 free (EVAL_ENVIRONMENT (env
));
1346 return sizeof (struct eval_environment
);
1351 print_eval_environment (SCM type
, SCM port
, scm_print_state
*pstate
)
1353 SCM address
= scm_ulong2num (SCM_UNPACK (type
));
1354 SCM base16
= scm_number_to_string (address
, SCM_MAKINUM (16));
1356 scm_puts ("#<eval environment ", port
);
1357 scm_puts (SCM_STRING_CHARS (base16
), port
);
1358 scm_puts (">", port
);
1364 static struct scm_environment_funcs eval_environment_funcs
= {
1365 eval_environment_ref
,
1366 eval_environment_fold
,
1367 eval_environment_define
,
1368 eval_environment_undefine
,
1369 eval_environment_set_x
,
1370 eval_environment_cell
,
1371 core_environments_observe
,
1372 core_environments_unobserve
,
1373 mark_eval_environment
,
1374 free_eval_environment
,
1375 print_eval_environment
1379 void *scm_type_eval_environment
= &eval_environment_funcs
;
1383 eval_environment_observer (SCM caller
, SCM eval_env
)
1385 SCM obarray
= EVAL_ENVIRONMENT (eval_env
)->obarray
;
1387 obarray_remove_all (obarray
);
1388 core_environments_broadcast (eval_env
);
1392 SCM_DEFINE (scm_make_eval_environment
, "make-eval-environment", 2, 0, 0,
1393 (SCM local
, SCM imported
),
1394 "Return a new environment object eval whose bindings are the\n"
1395 "union of the bindings in the environments local and imported,\n"
1396 "with bindings from local taking precedence. Definitions made\n"
1397 "in eval are placed in local.\n"
1398 "Applying environment-define or environment-undefine to eval\n"
1399 "has the same effect as applying the procedure to local.\n"
1400 "Note that eval incorporates local and imported by reference:\n"
1401 "If, after creating eval, the program changes the bindings of\n"
1402 "local or imported, those changes will be visible in eval.\n"
1403 "Since most Scheme evaluation takes place in eval environments,\n"
1404 "they transparenty cache the bindings received from local and\n"
1405 "imported. Thus, the first time the program looks up a symbol\n"
1406 "in eval, eval may make calls to local or imported to find\n"
1407 "their bindings, but subsequent references to that symbol will\n"
1408 "be as fast as references to bindings in finite environments.\n"
1409 "In typical use, local will be a finite environment, and\n"
1410 "imported will be an import environment")
1411 #define FUNC_NAME s_scm_make_eval_environment
1414 struct eval_environment
*body
;
1416 SCM_ASSERT (SCM_ENVIRONMENT_P (local
), local
, SCM_ARG1
, FUNC_NAME
);
1417 SCM_ASSERT (SCM_ENVIRONMENT_P (imported
), imported
, SCM_ARG2
, FUNC_NAME
);
1419 body
= scm_must_malloc (sizeof (struct eval_environment
), FUNC_NAME
);
1421 core_environments_preinit (&body
->base
);
1422 body
->obarray
= SCM_BOOL_F
;
1423 body
->imported
= SCM_BOOL_F
;
1424 body
->imported_observer
= SCM_BOOL_F
;
1425 body
->local
= SCM_BOOL_F
;
1426 body
->local_observer
= SCM_BOOL_F
;
1428 env
= scm_make_environment (body
);
1430 core_environments_init (&body
->base
, &eval_environment_funcs
);
1431 body
->obarray
= scm_make_vector (SCM_MAKINUM (scm_symhash_dim
), SCM_EOL
);
1432 body
->imported
= imported
;
1433 body
->imported_observer
1434 = SCM_ENVIRONMENT_OBSERVE (imported
, eval_environment_observer
, env
, 1);
1435 body
->local
= local
;
1436 body
->local_observer
1437 = SCM_ENVIRONMENT_OBSERVE (local
, eval_environment_observer
, env
, 1);
1444 SCM_DEFINE (scm_eval_environment_p
, "eval-environment?", 1, 0, 0,
1446 "Return #t if object is an eval environment, or #f otherwise.")
1447 #define FUNC_NAME s_scm_eval_environment_p
1449 return SCM_BOOL (SCM_EVAL_ENVIRONMENT_P (object
));
1454 SCM_DEFINE (scm_eval_environment_local
, "eval-environment-local", 1, 0, 0,
1456 "Return the local environment of eval environment env.")
1457 #define FUNC_NAME s_scm_eval_environment_local
1459 SCM_ASSERT (SCM_EVAL_ENVIRONMENT_P (env
), env
, SCM_ARG1
, FUNC_NAME
);
1461 return EVAL_ENVIRONMENT (env
)->local
;
1466 SCM_DEFINE (scm_eval_environment_set_local_x
, "eval-environment-set-local!", 2, 0, 0,
1467 (SCM env
, SCM local
),
1468 "Change env's local environment to LOCAL.")
1469 #define FUNC_NAME s_scm_eval_environment_set_local_x
1471 struct eval_environment
*body
;
1473 SCM_ASSERT (SCM_EVAL_ENVIRONMENT_P (env
), env
, SCM_ARG1
, FUNC_NAME
);
1474 SCM_ASSERT (SCM_ENVIRONMENT_P (local
), local
, SCM_ARG2
, FUNC_NAME
);
1476 body
= EVAL_ENVIRONMENT (env
);
1478 obarray_remove_all (body
->obarray
);
1479 SCM_ENVIRONMENT_UNOBSERVE (body
->local
, body
->local_observer
);
1481 body
->local
= local
;
1482 body
->local_observer
1483 = SCM_ENVIRONMENT_OBSERVE (local
, eval_environment_observer
, env
, 1);
1485 core_environments_broadcast (env
);
1487 return SCM_UNSPECIFIED
;
1492 SCM_DEFINE (scm_eval_environment_imported
, "eval-environment-imported", 1, 0, 0,
1494 "Return the imported environment of eval environment env.")
1495 #define FUNC_NAME s_scm_eval_environment_imported
1497 SCM_ASSERT (SCM_EVAL_ENVIRONMENT_P (env
), env
, SCM_ARG1
, FUNC_NAME
);
1499 return EVAL_ENVIRONMENT (env
)->imported
;
1504 SCM_DEFINE (scm_eval_environment_set_imported_x
, "eval-environment-set-imported!", 2, 0, 0,
1505 (SCM env
, SCM imported
),
1506 "Change env's imported environment to IMPORTED.")
1507 #define FUNC_NAME s_scm_eval_environment_set_imported_x
1509 struct eval_environment
*body
;
1511 SCM_ASSERT (SCM_EVAL_ENVIRONMENT_P (env
), env
, SCM_ARG1
, FUNC_NAME
);
1512 SCM_ASSERT (SCM_ENVIRONMENT_P (imported
), imported
, SCM_ARG2
, FUNC_NAME
);
1514 body
= EVAL_ENVIRONMENT (env
);
1516 obarray_remove_all (body
->obarray
);
1517 SCM_ENVIRONMENT_UNOBSERVE (body
->imported
, body
->imported_observer
);
1519 body
->imported
= imported
;
1520 body
->imported_observer
1521 = SCM_ENVIRONMENT_OBSERVE (imported
, eval_environment_observer
, env
, 1);
1523 core_environments_broadcast (env
);
1525 return SCM_UNSPECIFIED
;
1531 /* import environments
1533 * An import environment combines the bindings of a set of argument
1534 * environments, and checks for naming clashes.
1536 * Implementation: The import environment does no caching at all. For every
1537 * access, the list of imported environments is scanned.
1541 struct import_environment
{
1542 struct core_environments_base base
;
1545 SCM import_observers
;
1551 #define IMPORT_ENVIRONMENT(env) \
1552 ((struct import_environment *) SCM_CELL_WORD_1 (env))
1556 /* Lookup will report one of the following distinct results:
1557 * a) <environment> if only environment binds the symbol.
1558 * b) (env-1 env-2 ...) for conflicting bindings in env-1, ...
1559 * c) SCM_UNDEFINED if there is no binding for the symbol.
1562 import_environment_lookup (SCM env
, SCM sym
)
1564 SCM imports
= IMPORT_ENVIRONMENT (env
)->imports
;
1565 SCM result
= SCM_UNDEFINED
;
1568 for (l
= imports
; !SCM_NULLP (l
); l
= SCM_CDR (l
))
1570 SCM imported
= SCM_CAR (l
);
1572 if (SCM_ENVIRONMENT_BOUND_P (imported
, sym
))
1574 if (SCM_UNBNDP (result
))
1576 else if (SCM_CONSP (result
))
1577 result
= scm_cons (imported
, result
);
1579 result
= scm_cons2 (imported
, result
, SCM_EOL
);
1583 if (SCM_CONSP (result
))
1584 return scm_reverse (result
);
1591 import_environment_conflict (SCM env
, SCM sym
, SCM imports
)
1593 SCM conflict_proc
= IMPORT_ENVIRONMENT (env
)->conflict_proc
;
1594 SCM args
= scm_cons2 (env
, sym
, scm_cons (imports
, SCM_EOL
));
1596 return scm_apply (conflict_proc
, args
, SCM_EOL
);
1601 import_environment_ref (SCM env
, SCM sym
)
1602 #define FUNC_NAME "import_environment_ref"
1604 SCM owner
= import_environment_lookup (env
, sym
);
1606 if (SCM_UNBNDP (owner
))
1608 return SCM_UNDEFINED
;
1610 else if (SCM_CONSP (owner
))
1612 SCM resolve
= import_environment_conflict (env
, sym
, owner
);
1614 if (SCM_ENVIRONMENT_P (resolve
))
1615 return SCM_ENVIRONMENT_REF (resolve
, sym
);
1617 return SCM_UNSPECIFIED
;
1621 return SCM_ENVIRONMENT_REF (owner
, sym
);
1628 import_environment_folder (SCM extended_data
, SCM symbol
, SCM value
, SCM tail
)
1629 #define FUNC_NAME "import_environment_fold"
1631 SCM import_env
= SCM_CAR (extended_data
);
1632 SCM imported_env
= SCM_CADR (extended_data
);
1633 SCM owner
= import_environment_lookup (import_env
, symbol
);
1634 SCM proc_as_nr
= SCM_CADDR (extended_data
);
1635 unsigned long int proc_as_ul
= scm_num2ulong (proc_as_nr
, NULL
, NULL
);
1636 scm_environment_folder proc
= (scm_environment_folder
) proc_as_ul
;
1637 SCM data
= SCM_CDDDR (extended_data
);
1639 if (SCM_CONSP (owner
) && SCM_EQ_P (SCM_CAR (owner
), imported_env
))
1640 owner
= import_environment_conflict (import_env
, symbol
, owner
);
1642 if (SCM_ENVIRONMENT_P (owner
))
1643 return (*proc
) (data
, symbol
, value
, tail
);
1644 else /* unresolved conflict */
1645 return (*proc
) (data
, symbol
, SCM_UNSPECIFIED
, tail
);
1651 import_environment_fold (SCM env
, scm_environment_folder proc
, SCM data
, SCM init
)
1653 SCM proc_as_nr
= scm_ulong2num ((unsigned long int) proc
);
1657 for (l
= IMPORT_ENVIRONMENT (env
)->imports
; !SCM_NULLP (l
); l
= SCM_CDR (l
))
1659 SCM imported_env
= SCM_CAR (l
);
1660 SCM extended_data
= scm_cons (env
, scm_cons2 (imported_env
, proc_as_nr
, data
));
1662 result
= scm_c_environment_fold (imported_env
, import_environment_folder
, extended_data
, result
);
1670 import_environment_define (SCM env
, SCM sym
, SCM val
)
1671 #define FUNC_NAME "import_environment_define"
1673 return SCM_ENVIRONMENT_BINDING_IMMUTABLE
;
1679 import_environment_undefine (SCM env
, SCM sym
)
1680 #define FUNC_NAME "import_environment_undefine"
1682 return SCM_ENVIRONMENT_BINDING_IMMUTABLE
;
1688 import_environment_set_x (SCM env
, SCM sym
, SCM val
)
1689 #define FUNC_NAME "import_environment_set_x"
1691 SCM owner
= import_environment_lookup (env
, sym
);
1693 if (SCM_UNBNDP (owner
))
1695 return SCM_UNDEFINED
;
1697 else if (SCM_CONSP (owner
))
1699 SCM resolve
= import_environment_conflict (env
, sym
, owner
);
1701 if (SCM_ENVIRONMENT_P (resolve
))
1702 return SCM_ENVIRONMENT_SET (resolve
, sym
, val
);
1704 return SCM_ENVIRONMENT_LOCATION_IMMUTABLE
;
1708 return SCM_ENVIRONMENT_SET (owner
, sym
, val
);
1715 import_environment_cell (SCM env
, SCM sym
, int for_write
)
1716 #define FUNC_NAME "import_environment_cell"
1718 SCM owner
= import_environment_lookup (env
, sym
);
1720 if (SCM_UNBNDP (owner
))
1722 return SCM_UNDEFINED
;
1724 else if (SCM_CONSP (owner
))
1726 SCM resolve
= import_environment_conflict (env
, sym
, owner
);
1728 if (SCM_ENVIRONMENT_P (resolve
))
1729 return SCM_ENVIRONMENT_CELL (resolve
, sym
, for_write
);
1731 return SCM_ENVIRONMENT_LOCATION_NO_CELL
;
1735 return SCM_ENVIRONMENT_CELL (owner
, sym
, for_write
);
1742 mark_import_environment (SCM env
)
1744 scm_gc_mark (IMPORT_ENVIRONMENT (env
)->imports
);
1745 scm_gc_mark (IMPORT_ENVIRONMENT (env
)->import_observers
);
1746 scm_gc_mark (IMPORT_ENVIRONMENT (env
)->conflict_proc
);
1747 return core_environments_mark (env
);
1752 free_import_environment (SCM env
)
1754 core_environments_finalize (env
);
1756 free (IMPORT_ENVIRONMENT (env
));
1757 return sizeof (struct import_environment
);
1762 print_import_environment (SCM type
, SCM port
, scm_print_state
*pstate
)
1764 SCM address
= scm_ulong2num (SCM_UNPACK (type
));
1765 SCM base16
= scm_number_to_string (address
, SCM_MAKINUM (16));
1767 scm_puts ("#<import environment ", port
);
1768 scm_puts (SCM_STRING_CHARS (base16
), port
);
1769 scm_puts (">", port
);
1775 static struct scm_environment_funcs import_environment_funcs
= {
1776 import_environment_ref
,
1777 import_environment_fold
,
1778 import_environment_define
,
1779 import_environment_undefine
,
1780 import_environment_set_x
,
1781 import_environment_cell
,
1782 core_environments_observe
,
1783 core_environments_unobserve
,
1784 mark_import_environment
,
1785 free_import_environment
,
1786 print_import_environment
1790 void *scm_type_import_environment
= &import_environment_funcs
;
1794 import_environment_observer (SCM caller
, SCM import_env
)
1796 core_environments_broadcast (import_env
);
1800 SCM_DEFINE (scm_make_import_environment
, "make-import-environment", 2, 0, 0,
1801 (SCM imports
, SCM conflict_proc
),
1802 "Return a new environment imp whose bindings are the union of\n"
1803 "the bindings from the environments in imports; imports must\n"
1804 "be a list of environments. That is, imp binds symbol to\n"
1805 "location when some element of imports does.\n"
1806 "If two different elements of imports have a binding for the\n"
1807 "same symbol, the conflict-proc is called with the following\n"
1808 "parameters: the import environment, the symbol and the list\n"
1809 "of the imported environments that bind the symbol. If the\n"
1810 "conflict-proc returns an environment env, the conflict is\n"
1811 "considered as resolved and the binding from env is used. If\n"
1812 "the conflict-proc returns some non-environment object, the\n"
1813 "conflict is considered unresolved and the symbol is treated\n"
1814 "as unspecified in the import environment.\n"
1815 "The checking for conflicts may be performed lazily, i. e. at\m"
1816 "the moment when a value or binding for a certain symbol is\n"
1817 "requested instead of the moment when the environment is\n"
1818 "created or the bindings of the imports change.\n"
1819 "All bindings in imp are immutable. If you apply\n"
1820 "environment-define or environment-undefine to imp, Guile\n"
1821 "will signal an environment:immutable-binding error. However,\n"
1822 "notice that the set of bindings in imp may still change, if\n"
1823 "one of its imported environments changes.")
1824 #define FUNC_NAME s_scm_make_import_environment
1826 scm_sizet size
= sizeof (struct import_environment
);
1827 struct import_environment
*body
= scm_must_malloc (size
, FUNC_NAME
);
1830 core_environments_preinit (&body
->base
);
1831 body
->imports
= SCM_BOOL_F
;
1832 body
->import_observers
= SCM_BOOL_F
;
1833 body
->conflict_proc
= SCM_BOOL_F
;
1835 env
= scm_make_environment (body
);
1837 core_environments_init (&body
->base
, &import_environment_funcs
);
1838 body
->imports
= SCM_EOL
;
1839 body
->import_observers
= SCM_EOL
;
1840 body
->conflict_proc
= conflict_proc
;
1842 scm_import_environment_set_imports_x (env
, imports
);
1849 SCM_DEFINE (scm_import_environment_p
, "import-environment?", 1, 0, 0,
1851 "Return #t if object is an import environment, or #f otherwise.")
1852 #define FUNC_NAME s_scm_import_environment_p
1854 return SCM_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 environment env.")
1862 #define FUNC_NAME s_scm_import_environment_imports
1864 SCM_ASSERT (SCM_IMPORT_ENVIRONMENT_P (env
), env
, SCM_ARG1
, FUNC_NAME
);
1866 return IMPORT_ENVIRONMENT (env
)->imports
;
1871 SCM_DEFINE (scm_import_environment_set_imports_x
, "import-environment-set-imports!", 2, 0, 0,
1872 (SCM env
, SCM imports
),
1873 "Change env's list of imported environments to imports, and check for conflicts.")
1874 #define FUNC_NAME s_scm_import_environment_set_imports_x
1876 struct import_environment
*body
= IMPORT_ENVIRONMENT (env
);
1877 SCM import_observers
= SCM_EOL
;
1880 SCM_ASSERT (SCM_IMPORT_ENVIRONMENT_P (env
), env
, SCM_ARG1
, FUNC_NAME
);
1881 for (l
= imports
; SCM_CONSP (l
); l
= SCM_CDR (l
))
1883 SCM obj
= SCM_CAR (l
);
1884 SCM_ASSERT (SCM_ENVIRONMENT_P (obj
), imports
, SCM_ARG1
, FUNC_NAME
);
1886 SCM_ASSERT (SCM_NULLP (l
), imports
, SCM_ARG1
, FUNC_NAME
);
1888 for (l
= body
->import_observers
; !SCM_NULLP (l
); l
= SCM_CDR (l
))
1890 SCM obs
= SCM_CAR (l
);
1891 SCM_ENVIRONMENT_UNOBSERVE (env
, obs
);
1894 for (l
= imports
; !SCM_NULLP (l
); l
= SCM_CDR (l
))
1896 SCM imp
= SCM_CAR (l
);
1897 SCM obs
= SCM_ENVIRONMENT_OBSERVE (imp
, import_environment_observer
, env
, 1);
1898 import_observers
= scm_cons (obs
, import_observers
);
1901 body
->imports
= imports
;
1902 body
->import_observers
= import_observers
;
1904 return SCM_UNSPECIFIED
;
1910 /* export environments
1912 * An export environment restricts an environment to a specified set of
1915 * Implementation: The export environment does no caching at all. For every
1916 * access, the signature is scanned. The signature that is stored internally
1917 * is an alist of pairs (symbol . (mutability)).
1921 struct export_environment
{
1922 struct core_environments_base base
;
1925 SCM private_observer
;
1931 #define EXPORT_ENVIRONMENT(env) \
1932 ((struct export_environment *) SCM_CELL_WORD_1 (env))
1935 SCM_SYMBOL (symbol_immutable_location
, "immutable-location");
1936 SCM_SYMBOL (symbol_mutable_location
, "mutable-location");
1941 export_environment_ref (SCM env
, SCM sym
)
1942 #define FUNC_NAME "export_environment_ref"
1944 struct export_environment
*body
= EXPORT_ENVIRONMENT (env
);
1945 SCM entry
= scm_assq (sym
, body
->signature
);
1947 if (SCM_FALSEP (entry
))
1948 return SCM_UNDEFINED
;
1950 return SCM_ENVIRONMENT_REF (body
->private, sym
);
1956 export_environment_fold (SCM env
, scm_environment_folder proc
, SCM data
, SCM init
)
1958 struct export_environment
*body
= EXPORT_ENVIRONMENT (env
);
1962 for (l
= body
->signature
; !SCM_NULLP (l
); l
= SCM_CDR (l
))
1964 SCM symbol
= SCM_CAR (l
);
1965 SCM value
= SCM_ENVIRONMENT_REF (body
->private, symbol
);
1966 if (!SCM_UNBNDP (value
))
1967 result
= (*proc
) (data
, symbol
, value
, result
);
1974 export_environment_define (SCM env
, SCM sym
, SCM val
)
1975 #define FUNC_NAME "export_environment_define"
1977 return SCM_ENVIRONMENT_BINDING_IMMUTABLE
;
1983 export_environment_undefine (SCM env
, SCM sym
)
1984 #define FUNC_NAME "export_environment_undefine"
1986 return SCM_ENVIRONMENT_BINDING_IMMUTABLE
;
1992 export_environment_set_x (SCM env
, SCM sym
, SCM val
)
1993 #define FUNC_NAME "export_environment_set_x"
1995 struct export_environment
*body
= EXPORT_ENVIRONMENT (env
);
1996 SCM entry
= scm_assq (sym
, body
->signature
);
1998 if (SCM_FALSEP (entry
))
2000 return SCM_UNDEFINED
;
2004 if (SCM_EQ_P (SCM_CADR (entry
), symbol_mutable_location
))
2005 return SCM_ENVIRONMENT_SET (body
->private, sym
, val
);
2007 return SCM_ENVIRONMENT_LOCATION_IMMUTABLE
;
2014 export_environment_cell (SCM env
, SCM sym
, int for_write
)
2015 #define FUNC_NAME "export_environment_cell"
2017 struct export_environment
*body
= EXPORT_ENVIRONMENT (env
);
2018 SCM entry
= scm_assq (sym
, body
->signature
);
2020 if (SCM_FALSEP (entry
))
2022 return SCM_UNDEFINED
;
2026 if (!for_write
|| SCM_EQ_P (SCM_CADR (entry
), symbol_mutable_location
))
2027 return SCM_ENVIRONMENT_CELL (body
->private, sym
, for_write
);
2029 return SCM_ENVIRONMENT_LOCATION_IMMUTABLE
;
2036 mark_export_environment (SCM env
)
2038 struct export_environment
*body
= EXPORT_ENVIRONMENT (env
);
2040 scm_gc_mark (body
->private);
2041 scm_gc_mark (body
->private_observer
);
2042 scm_gc_mark (body
->signature
);
2044 return core_environments_mark (env
);
2049 free_export_environment (SCM env
)
2051 core_environments_finalize (env
);
2053 free (EXPORT_ENVIRONMENT (env
));
2054 return sizeof (struct export_environment
);
2059 print_export_environment (SCM type
, SCM port
, scm_print_state
*pstate
)
2061 SCM address
= scm_ulong2num (SCM_UNPACK (type
));
2062 SCM base16
= scm_number_to_string (address
, SCM_MAKINUM (16));
2064 scm_puts ("#<export environment ", port
);
2065 scm_puts (SCM_STRING_CHARS (base16
), port
);
2066 scm_puts (">", port
);
2072 static struct scm_environment_funcs export_environment_funcs
= {
2073 export_environment_ref
,
2074 export_environment_fold
,
2075 export_environment_define
,
2076 export_environment_undefine
,
2077 export_environment_set_x
,
2078 export_environment_cell
,
2079 core_environments_observe
,
2080 core_environments_unobserve
,
2081 mark_export_environment
,
2082 free_export_environment
,
2083 print_export_environment
2087 void *scm_type_export_environment
= &export_environment_funcs
;
2091 export_environment_observer (SCM caller
, SCM export_env
)
2093 core_environments_broadcast (export_env
);
2097 SCM_DEFINE (scm_make_export_environment
, "make-export-environment", 2, 0, 0,
2098 (SCM
private, SCM signature
),
2099 "Return a new environment exp containing only those bindings\n"
2100 "in private whose symbols are present in signature. The\n"
2101 "private argument must be an environment.\n\n"
2102 "The environment exp binds symbol to location when env does,\n"
2103 "and symbol is exported by signature.\n\n"
2104 "Signature is a list specifying which of the bindings in\n"
2105 "private should be visible in exp. Each element of signature\n"
2106 "should be a list of the form:\n"
2107 " (symbol attribute ...)\n"
2108 "where each attribute is one of the following:\n"
2109 "* the symbol mutable-location exp should treat the location\n"
2110 " bound to symbol as mutable. That is, exp will pass calls\n"
2111 " to env-set! or environment-cell directly through to\n"
2113 "* the symbol immutable-location exp should treat the\n"
2114 " location bound to symbol as immutable. If the program\n"
2115 " applies environment-set! to exp and symbol, or calls\n"
2116 " environment-cell to obtain a writable value cell,\n"
2117 " environment-set! will signal an\n"
2118 " environment:immutable-location error. Note that, even if\n"
2119 " an export environment treats a location as immutable, the\n"
2120 " underlying environment may treat it as mutable, so its\n"
2121 " value may change.\n"
2122 "It is an error for an element of signature to specify both\n"
2123 "mutable-location and immutable-location. If neither is\n"
2124 "specified, immutable-location is assumed.\n\n"
2125 "As a special case, if an element of signature is a lone\n"
2126 "symbol sym, it is equivalent to an element of the form\n"
2128 "All bindings in exp are immutable. If you apply\n"
2129 "environment-define or environment-undefine to exp, Guile\n"
2130 "will signal an environment:immutable-binding error. However,\n"
2131 "notice that the set of bindings in exp may still change, if\n"
2132 "the bindings in private change.")
2133 #define FUNC_NAME s_scm_make_export_environment
2136 struct export_environment
*body
;
2139 SCM_ASSERT (SCM_ENVIRONMENT_P (private), private, SCM_ARG1
, FUNC_NAME
);
2141 size
= sizeof (struct export_environment
);
2142 body
= scm_must_malloc (size
, FUNC_NAME
);
2144 core_environments_preinit (&body
->base
);
2145 body
->private = SCM_BOOL_F
;
2146 body
->private_observer
= SCM_BOOL_F
;
2147 body
->signature
= SCM_BOOL_F
;
2149 env
= scm_make_environment (body
);
2151 core_environments_init (&body
->base
, &export_environment_funcs
);
2152 body
->private = private;
2153 body
->private_observer
2154 = SCM_ENVIRONMENT_OBSERVE (private, export_environment_observer
, env
, 1);
2155 body
->signature
= SCM_EOL
;
2157 scm_export_environment_set_signature_x (env
, signature
);
2164 SCM_DEFINE (scm_export_environment_p
, "export-environment?", 1, 0, 0,
2166 "Return #t if object is an export environment, or #f otherwise.")
2167 #define FUNC_NAME s_scm_export_environment_p
2169 return SCM_BOOL (SCM_EXPORT_ENVIRONMENT_P (object
));
2174 SCM_DEFINE (scm_export_environment_private
, "export-environment-private", 1, 0, 0,
2176 "Return the private environment of export environment env.")
2177 #define FUNC_NAME s_scm_export_environment_private
2179 SCM_ASSERT (SCM_EXPORT_ENVIRONMENT_P (env
), env
, SCM_ARG1
, FUNC_NAME
);
2181 return EXPORT_ENVIRONMENT (env
)->private;
2186 SCM_DEFINE (scm_export_environment_set_private_x
, "export-environment-set-private!", 2, 0, 0,
2187 (SCM env
, SCM
private),
2188 "Change the private environment of export environment env.")
2189 #define FUNC_NAME s_scm_export_environment_set_private_x
2191 struct export_environment
*body
;
2193 SCM_ASSERT (SCM_EXPORT_ENVIRONMENT_P (env
), env
, SCM_ARG1
, FUNC_NAME
);
2194 SCM_ASSERT (SCM_ENVIRONMENT_P (private), private, SCM_ARG2
, FUNC_NAME
);
2196 body
= EXPORT_ENVIRONMENT (env
);
2197 SCM_ENVIRONMENT_UNOBSERVE (private, body
->private_observer
);
2199 body
->private = private;
2200 body
->private_observer
2201 = SCM_ENVIRONMENT_OBSERVE (private, export_environment_observer
, env
, 1);
2203 return SCM_UNSPECIFIED
;
2208 SCM_DEFINE (scm_export_environment_signature
, "export-environment-signature", 1, 0, 0,
2210 "Return the signature of export environment env.")
2211 #define FUNC_NAME s_scm_export_environment_signature
2213 SCM_ASSERT (SCM_EXPORT_ENVIRONMENT_P (env
), env
, SCM_ARG1
, FUNC_NAME
);
2215 return EXPORT_ENVIRONMENT (env
)->signature
;
2221 export_environment_parse_signature (SCM signature
, const char* caller
)
2223 SCM result
= SCM_EOL
;
2226 for (l
= signature
; SCM_CONSP (l
); l
= SCM_CDR (l
))
2228 SCM entry
= SCM_CAR (l
);
2230 if (SCM_SYMBOLP (entry
))
2232 SCM new_entry
= scm_cons2 (entry
, symbol_immutable_location
, SCM_EOL
);
2233 result
= scm_cons (new_entry
, result
);
2244 SCM_ASSERT (SCM_CONSP (entry
), entry
, SCM_ARGn
, caller
);
2245 SCM_ASSERT (SCM_SYMBOLP (SCM_CAR (entry
)), entry
, SCM_ARGn
, caller
);
2247 sym
= SCM_CAR (entry
);
2249 for (l2
= SCM_CDR (entry
); SCM_CONSP (l2
); l2
= SCM_CDR (l2
))
2251 SCM attribute
= SCM_CAR (l2
);
2252 if (SCM_EQ_P (attribute
, symbol_immutable_location
))
2254 else if (SCM_EQ_P (attribute
, symbol_mutable_location
))
2257 SCM_ASSERT (0, entry
, SCM_ARGn
, caller
);
2259 SCM_ASSERT (SCM_NULLP (l2
), entry
, SCM_ARGn
, caller
);
2260 SCM_ASSERT (!mutable || !immutable
, entry
, SCM_ARGn
, caller
);
2262 if (!mutable && !immutable
)
2265 mutability
= mutable ? symbol_mutable_location
: symbol_immutable_location
;
2266 new_entry
= scm_cons2 (sym
, mutability
, SCM_EOL
);
2267 result
= scm_cons (new_entry
, result
);
2270 SCM_ASSERT (SCM_NULLP (l
), signature
, SCM_ARGn
, caller
);
2272 /* Dirk:FIXME:: Now we know that signature is syntactically correct. There
2273 * are, however, no checks for symbols entered twice with contradicting
2274 * mutabilities. It would be nice, to implement this test, to be able to
2275 * call the sort functions conveniently from C.
2278 return scm_reverse (result
);
2282 SCM_DEFINE (scm_export_environment_set_signature_x
, "export-environment-set-signature!", 2, 0, 0,
2283 (SCM env
, SCM signature
),
2284 "Change the signature of export environment env.")
2285 #define FUNC_NAME s_scm_export_environment_set_signature_x
2289 SCM_ASSERT (SCM_EXPORT_ENVIRONMENT_P (env
), env
, SCM_ARG1
, FUNC_NAME
);
2290 parsed_sig
= export_environment_parse_signature (signature
, FUNC_NAME
);
2292 EXPORT_ENVIRONMENT (env
)->signature
= parsed_sig
;
2294 return SCM_UNSPECIFIED
;
2301 scm_environments_prehistory ()
2303 /* create environment smob */
2304 scm_tc16_environment
= scm_make_smob_type ("environment", 0);
2305 scm_set_smob_mark (scm_tc16_environment
, mark_environment
);
2306 scm_set_smob_free (scm_tc16_environment
, free_environment
);
2307 scm_set_smob_print (scm_tc16_environment
, print_environment
);
2309 /* create observer smob */
2310 scm_tc16_observer
= scm_make_smob_type ("observer", 0);
2311 scm_set_smob_mark (scm_tc16_observer
, mark_observer
);
2312 scm_set_smob_free (scm_tc16_observer
, free_observer
);
2313 scm_set_smob_print (scm_tc16_observer
, print_observer
);
2318 scm_init_environments ()
2320 #include "libguile/environments.x"