1 /* Copyright (C) 1999,2000,2001 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 scm_bits_t scm_tc16_environment
;
60 scm_bits_t scm_tc16_observer
;
61 #define DEFAULT_OBARRAY_SIZE 137
63 SCM scm_system_environment
;
67 /* error conditions */
70 * Throw an error if symbol is not bound in environment func
73 scm_error_environment_unbound (const char *func
, SCM env
, SCM symbol
)
75 /* Dirk:FIXME:: Should throw an environment:unbound type error */
76 char error
[] = "Symbol `~A' not bound in environment `~A'.";
77 SCM arguments
= scm_cons2 (symbol
, env
, SCM_EOL
);
78 scm_misc_error (func
, error
, arguments
);
83 * Throw an error if func tried to create (define) or remove
84 * (undefine) a new binding for symbol in env
87 scm_error_environment_immutable_binding (const char *func
, SCM env
, SCM symbol
)
89 /* Dirk:FIXME:: Should throw an environment:immutable-binding type error */
90 char error
[] = "Immutable binding in environment ~A (symbol: `~A').";
91 SCM arguments
= scm_cons2 (env
, symbol
, SCM_EOL
);
92 scm_misc_error (func
, error
, arguments
);
97 * Throw an error if func tried to change an immutable location.
100 scm_error_environment_immutable_location (const char *func
, SCM env
, SCM symbol
)
102 /* Dirk:FIXME:: Should throw an environment:immutable-location type error */
103 char error
[] = "Immutable location in environment `~A' (symbol: `~A').";
104 SCM arguments
= scm_cons2 (env
, symbol
, SCM_EOL
);
105 scm_misc_error (func
, error
, arguments
);
110 /* generic environments */
113 /* Create an environment for the given type. Dereferencing type twice must
114 * deliver the initialized set of environment functions. Thus, type will
115 * also determine the signature of the underlying environment implementation.
116 * Dereferencing type once will typically deliver the data fields used by the
117 * underlying environment implementation.
120 scm_make_environment (void *type
)
125 SCM_SET_CELL_WORD_1 (env
, type
);
126 SCM_SET_CELL_TYPE (env
, scm_tc16_environment
);
132 SCM_DEFINE (scm_environment_p
, "environment?", 1, 0, 0,
134 "Return @code{#t} if @var{obj} is an environment, or @code{#f}\n"
136 #define FUNC_NAME s_scm_environment_p
138 return SCM_BOOL (SCM_ENVIRONMENT_P (obj
));
143 SCM_DEFINE (scm_environment_bound_p
, "environment-bound?", 2, 0, 0,
145 "Return @code{#t} if @var{sym} is bound in @var{env}, or\n"
146 "@code{#f} otherwise.")
147 #define FUNC_NAME s_scm_environment_bound_p
149 SCM_ASSERT (SCM_ENVIRONMENT_P (env
), env
, SCM_ARG1
, FUNC_NAME
);
150 SCM_ASSERT (SCM_SYMBOLP (sym
), sym
, SCM_ARG2
, FUNC_NAME
);
152 return SCM_BOOL (SCM_ENVIRONMENT_BOUND_P (env
, sym
));
157 SCM_DEFINE (scm_environment_ref
, "environment-ref", 2, 0, 0,
159 "Return the value of the location bound to @var{sym} in\n"
160 "@var{env}. If @var{sym} is unbound in @var{env}, signal an\n"
161 "@code{environment:unbound} error.")
162 #define FUNC_NAME s_scm_environment_ref
166 SCM_ASSERT (SCM_ENVIRONMENT_P (env
), env
, SCM_ARG1
, FUNC_NAME
);
167 SCM_ASSERT (SCM_SYMBOLP (sym
), sym
, SCM_ARG2
, FUNC_NAME
);
169 val
= SCM_ENVIRONMENT_REF (env
, sym
);
171 if (!SCM_UNBNDP (val
))
174 scm_error_environment_unbound (FUNC_NAME
, env
, sym
);
179 /* This C function is identical to environment-ref, except that if symbol is
180 * unbound in env, it returns the value SCM_UNDEFINED, instead of signalling
184 scm_c_environment_ref (SCM env
, SCM sym
)
186 SCM_ASSERT (SCM_ENVIRONMENT_P (env
), env
, SCM_ARG1
, "scm_c_environment_ref");
187 SCM_ASSERT (SCM_SYMBOLP (sym
), sym
, SCM_ARG2
, "scm_c_environment_ref");
188 return SCM_ENVIRONMENT_REF (env
, sym
);
193 environment_default_folder (SCM proc
, SCM symbol
, SCM value
, SCM tail
)
195 return gh_call3 (proc
, symbol
, value
, tail
);
199 SCM_DEFINE (scm_environment_fold
, "environment-fold", 3, 0, 0,
200 (SCM env
, SCM proc
, SCM init
),
201 "Iterate over all the bindings in @var{env}, accumulating some\n"
203 "For each binding in @var{env}, apply @var{proc} to the symbol\n"
204 "bound, its value, and the result from the previous application\n"
206 "Use @var{init} as @var{proc}'s third argument the first time\n"
207 "@var{proc} is applied.\n"
208 "If @var{env} contains no bindings, this function simply returns\n"
210 "If @var{env} binds the symbol sym1 to the value val1, sym2 to\n"
211 "val2, and so on, then this procedure computes:\n"
219 "Each binding in @var{env} will be processed exactly once.\n"
220 "@code{environment-fold} makes no guarantees about the order in\n"
221 "which the bindings are processed.\n"
222 "Here is a function which, given an environment, constructs an\n"
223 "association list representing that environment's bindings,\n"
224 "using environment-fold:\n"
226 " (define (environment->alist env)\n"
227 " (environment-fold env\n"
228 " (lambda (sym val tail)\n"
229 " (cons (cons sym val) tail))\n"
232 #define FUNC_NAME s_scm_environment_fold
234 SCM_ASSERT (SCM_ENVIRONMENT_P (env
), env
, SCM_ARG1
, FUNC_NAME
);
235 SCM_ASSERT (SCM_EQ_P (scm_procedure_p (proc
), SCM_BOOL_T
),
236 proc
, SCM_ARG2
, FUNC_NAME
);
238 return SCM_ENVIRONMENT_FOLD (env
, environment_default_folder
, proc
, init
);
243 /* This is the C-level analog of environment-fold. For each binding in ENV,
245 * (*proc) (data, symbol, value, previous)
246 * where previous is the value returned from the last call to *PROC, or INIT
247 * for the first call. If ENV contains no bindings, return INIT.
250 scm_c_environment_fold (SCM env
, scm_environment_folder proc
, SCM data
, SCM init
)
252 SCM_ASSERT (SCM_ENVIRONMENT_P (env
), env
, SCM_ARG1
, "scm_c_environment_fold");
254 return SCM_ENVIRONMENT_FOLD (env
, proc
, data
, init
);
258 SCM_DEFINE (scm_environment_define
, "environment-define", 3, 0, 0,
259 (SCM env
, SCM sym
, SCM val
),
260 "Bind @var{sym} to a new location containing @var{val} in\n"
261 "@var{env}. If @var{sym} is already bound to another location\n"
262 "in @var{env} and the binding is mutable, that binding is\n"
263 "replaced. The new binding and location are both mutable. The\n"
264 "return value is unspecified.\n"
265 "If @var{sym} is already bound in @var{env}, and the binding is\n"
266 "immutable, signal an @code{environment:immutable-binding} error.")
267 #define FUNC_NAME s_scm_environment_define
271 SCM_ASSERT (SCM_ENVIRONMENT_P (env
), env
, SCM_ARG1
, FUNC_NAME
);
272 SCM_ASSERT (SCM_SYMBOLP (sym
), sym
, SCM_ARG2
, FUNC_NAME
);
274 status
= SCM_ENVIRONMENT_DEFINE (env
, sym
, val
);
276 if (SCM_EQ_P (status
, SCM_ENVIRONMENT_SUCCESS
))
277 return SCM_UNSPECIFIED
;
278 else if (SCM_EQ_P (status
, SCM_ENVIRONMENT_BINDING_IMMUTABLE
))
279 scm_error_environment_immutable_binding (FUNC_NAME
, env
, sym
);
286 SCM_DEFINE (scm_environment_undefine
, "environment-undefine", 2, 0, 0,
288 "Remove any binding for @var{sym} from @var{env}. If @var{sym}\n"
289 "is unbound in @var{env}, do nothing. The return value is\n"
291 "If @var{sym} is already bound in @var{env}, and the binding is\n"
292 "immutable, signal an @code{environment:immutable-binding} error.")
293 #define FUNC_NAME s_scm_environment_undefine
297 SCM_ASSERT(SCM_ENVIRONMENT_P(env
), env
, SCM_ARG1
, FUNC_NAME
);
298 SCM_ASSERT(SCM_SYMBOLP(sym
), sym
, SCM_ARG2
, FUNC_NAME
);
300 status
= SCM_ENVIRONMENT_UNDEFINE (env
, sym
);
302 if (SCM_EQ_P (status
, SCM_ENVIRONMENT_SUCCESS
))
303 return SCM_UNSPECIFIED
;
304 else if (SCM_EQ_P (status
, SCM_ENVIRONMENT_BINDING_IMMUTABLE
))
305 scm_error_environment_immutable_binding (FUNC_NAME
, env
, sym
);
312 SCM_DEFINE (scm_environment_set_x
, "environment-set!", 3, 0, 0,
313 (SCM env
, SCM sym
, SCM val
),
314 "If @var{env} binds @var{sym} to some location, change that\n"
315 "location's value to @var{val}. The return value is\n"
317 "If @var{sym} is not bound in @var{env}, signal an\n"
318 "@code{environment:unbound} error. If @var{env} binds @var{sym}\n"
319 "to an immutable location, signal an\n"
320 "@code{environment:immutable-location} error.")
321 #define FUNC_NAME s_scm_environment_set_x
325 SCM_ASSERT (SCM_ENVIRONMENT_P (env
), env
, SCM_ARG1
, FUNC_NAME
);
326 SCM_ASSERT (SCM_SYMBOLP (sym
), sym
, SCM_ARG2
, FUNC_NAME
);
328 status
= SCM_ENVIRONMENT_SET (env
, sym
, val
);
330 if (SCM_EQ_P (status
, SCM_ENVIRONMENT_SUCCESS
))
331 return SCM_UNSPECIFIED
;
332 else if (SCM_UNBNDP (status
))
333 scm_error_environment_unbound (FUNC_NAME
, env
, sym
);
334 else if (SCM_EQ_P (status
, SCM_ENVIRONMENT_LOCATION_IMMUTABLE
))
335 scm_error_environment_immutable_binding (FUNC_NAME
, env
, sym
);
342 SCM_DEFINE (scm_environment_cell
, "environment-cell", 3, 0, 0,
343 (SCM env
, SCM sym
, SCM for_write
),
344 "Return the value cell which @var{env} binds to @var{sym}, or\n"
345 "@code{#f} if the binding does not live in a value cell.\n"
346 "The argument @var{for-write} indicates whether the caller\n"
347 "intends to modify the variable's value by mutating the value\n"
348 "cell. If the variable is immutable, then\n"
349 "@code{environment-cell} signals an\n"
350 "@code{environment:immutable-location} error.\n"
351 "If @var{sym} is unbound in @var{env}, signal an\n"
352 "@code{environment:unbound} error.\n"
353 "If you use this function, you should consider using\n"
354 "@code{environment-observe}, to be notified when @var{sym} gets\n"
355 "re-bound to a new value cell, or becomes undefined.")
356 #define FUNC_NAME s_scm_environment_cell
360 SCM_ASSERT (SCM_ENVIRONMENT_P (env
), env
, SCM_ARG1
, FUNC_NAME
);
361 SCM_ASSERT (SCM_SYMBOLP (sym
), sym
, SCM_ARG2
, FUNC_NAME
);
362 SCM_ASSERT (SCM_BOOLP (for_write
), for_write
, SCM_ARG3
, FUNC_NAME
);
364 location
= SCM_ENVIRONMENT_CELL (env
, sym
, !SCM_FALSEP (for_write
));
365 if (!SCM_IMP (location
))
367 else if (SCM_UNBNDP (location
))
368 scm_error_environment_unbound (FUNC_NAME
, env
, sym
);
369 else if (SCM_EQ_P (location
, SCM_ENVIRONMENT_LOCATION_IMMUTABLE
))
370 scm_error_environment_immutable_location (FUNC_NAME
, env
, sym
);
377 /* This C function is identical to environment-cell, with the following
378 * exceptions: If symbol is unbound in env, it returns the value
379 * SCM_UNDEFINED, instead of signalling an error. If symbol is bound to an
380 * immutable location but the cell is requested for write, the value
381 * SCM_ENVIRONMENT_LOCATION_IMMUTABLE is returned.
384 scm_c_environment_cell(SCM env
, SCM sym
, int for_write
)
386 SCM_ASSERT (SCM_ENVIRONMENT_P (env
), env
, SCM_ARG1
, "scm_c_environment_cell");
387 SCM_ASSERT (SCM_SYMBOLP (sym
), sym
, SCM_ARG2
, "scm_c_environment_cell");
389 return SCM_ENVIRONMENT_CELL (env
, sym
, for_write
);
394 environment_default_observer (SCM env
, SCM proc
)
396 gh_call1 (proc
, env
);
400 SCM_DEFINE (scm_environment_observe
, "environment-observe", 2, 0, 0,
402 "Whenever @var{env}'s bindings change, apply @var{proc} to\n"
404 "This function returns an object, token, which you can pass to\n"
405 "@code{environment-unobserve} to remove @var{proc} from the set\n"
406 "of procedures observing @var{env}. The type and value of\n"
407 "token is unspecified.")
408 #define FUNC_NAME s_scm_environment_observe
410 SCM_ASSERT (SCM_ENVIRONMENT_P (env
), env
, SCM_ARG1
, FUNC_NAME
);
412 return SCM_ENVIRONMENT_OBSERVE (env
, environment_default_observer
, proc
, 0);
417 SCM_DEFINE (scm_environment_observe_weak
, "environment-observe-weak", 2, 0, 0,
419 "This function is the same as environment-observe, except that\n"
420 "the reference @var{env} retains to @var{proc} is a weak\n"
421 "reference. This means that, if there are no other live,\n"
422 "non-weak references to @var{proc}, it will be\n"
423 "garbage-collected, and dropped from @var{env}'s\n"
424 "list of observing procedures.")
425 #define FUNC_NAME s_scm_environment_observe_weak
427 SCM_ASSERT (SCM_ENVIRONMENT_P (env
), env
, SCM_ARG1
, FUNC_NAME
);
429 return SCM_ENVIRONMENT_OBSERVE (env
, environment_default_observer
, proc
, 1);
434 /* This is the C-level analog of the Scheme functions environment-observe and
435 * environment-observe-weak. Whenever env's bindings change, call the
436 * function proc, passing it env and data. If weak_p is non-zero, env will
437 * retain only a weak reference to data, and if data is garbage collected, the
438 * entire observation will be dropped. This function returns a token, with
439 * the same meaning as those returned by environment-observe and
440 * environment-observe-weak.
443 scm_c_environment_observe (SCM env
, scm_environment_observer proc
, SCM data
, int weak_p
)
444 #define FUNC_NAME "scm_c_environment_observe"
446 SCM_ASSERT (SCM_ENVIRONMENT_P (env
), env
, SCM_ARG1
, FUNC_NAME
);
448 return SCM_ENVIRONMENT_OBSERVE (env
, proc
, data
, weak_p
);
453 SCM_DEFINE (scm_environment_unobserve
, "environment-unobserve", 1, 0, 0,
455 "Cancel the observation request which returned the value\n"
456 "@var{token}. The return value is unspecified.\n"
457 "If a call @code{(environment-observe env proc)} returns\n"
458 "@var{token}, then the call @code{(environment-unobserve token)}\n"
459 "will cause @var{proc} to no longer be called when @var{env}'s\n"
461 #define FUNC_NAME s_scm_environment_unobserve
465 SCM_ASSERT (SCM_OBSERVER_P (token
), token
, SCM_ARG1
, FUNC_NAME
);
467 env
= SCM_OBSERVER_ENVIRONMENT (token
);
468 SCM_ENVIRONMENT_UNOBSERVE (env
, token
);
470 return SCM_UNSPECIFIED
;
476 environment_mark (SCM env
)
478 return (*(SCM_ENVIRONMENT_FUNCS (env
)->mark
)) (env
);
483 environment_free (SCM env
)
485 return (*(SCM_ENVIRONMENT_FUNCS (env
)->free
)) (env
);
490 environment_print (SCM env
, SCM port
, scm_print_state
*pstate
)
492 return (*(SCM_ENVIRONMENT_FUNCS (env
)->print
)) (env
, port
, pstate
);
500 observer_mark (SCM observer
)
502 scm_gc_mark (SCM_OBSERVER_ENVIRONMENT (observer
));
503 scm_gc_mark (SCM_OBSERVER_DATA (observer
));
509 observer_print (SCM type
, SCM port
, scm_print_state
*pstate
)
511 SCM address
= scm_ulong2num (SCM_UNPACK (type
));
512 SCM base16
= scm_number_to_string (address
, SCM_MAKINUM (16));
514 scm_puts ("#<observer ", port
);
515 scm_puts (SCM_STRING_CHARS (base16
), port
);
516 scm_puts (">", port
);
525 * Obarrays form the basic lookup tables used to implement most of guile's
526 * built-in environment types. An obarray is implemented as a hash table with
527 * symbols as keys. The content of the data depends on the environment type.
532 * Enter symbol into obarray. The symbol must not already exist in obarray.
533 * The freshly generated (symbol . data) cell is returned.
536 obarray_enter (SCM obarray
, SCM symbol
, SCM data
)
538 scm_sizet hash
= SCM_SYMBOL_HASH (symbol
) % SCM_VECTOR_LENGTH (obarray
);
539 SCM entry
= scm_cons (symbol
, data
);
540 SCM slot
= scm_cons (entry
, SCM_VELTS (obarray
)[hash
]);
541 SCM_VELTS (obarray
)[hash
] = slot
;
548 * Enter symbol into obarray. An existing entry for symbol is replaced. If
549 * an entry existed, the old (symbol . data) cell is returned, #f otherwise.
552 obarray_replace (SCM obarray
, SCM symbol
, SCM data
)
554 scm_sizet hash
= SCM_SYMBOL_HASH (symbol
) % SCM_VECTOR_LENGTH (obarray
);
555 SCM new_entry
= scm_cons (symbol
, data
);
559 for (lsym
= SCM_VELTS (obarray
)[hash
]; !SCM_NULLP (lsym
); lsym
= SCM_CDR (lsym
))
561 SCM old_entry
= SCM_CAR (lsym
);
562 if (SCM_EQ_P (SCM_CAR (old_entry
), symbol
))
564 SCM_SETCAR (lsym
, new_entry
);
569 slot
= scm_cons (new_entry
, SCM_VELTS (obarray
)[hash
]);
570 SCM_VELTS (obarray
)[hash
] = slot
;
577 * Look up symbol in obarray
580 obarray_retrieve (SCM obarray
, SCM sym
)
582 scm_sizet hash
= SCM_SYMBOL_HASH (sym
) % SCM_VECTOR_LENGTH (obarray
);
585 for (lsym
= SCM_VELTS (obarray
)[hash
]; !SCM_NULLP (lsym
); lsym
= SCM_CDR (lsym
))
587 SCM entry
= SCM_CAR (lsym
);
588 if (SCM_EQ_P (SCM_CAR (entry
), sym
))
592 return SCM_UNDEFINED
;
597 * Remove entry from obarray. If the symbol was found and removed, the old
598 * (symbol . data) cell is returned, #f otherwise.
601 obarray_remove (SCM obarray
, SCM sym
)
603 scm_sizet hash
= SCM_SYMBOL_HASH (sym
) % SCM_VECTOR_LENGTH (obarray
);
607 /* Dirk:FIXME:: gc problem due to use of &SCM_VELTS[hash] */
608 for (lsym
= *(lsymp
= &SCM_VELTS (obarray
)[hash
]);
610 lsym
= *(lsymp
= SCM_CDRLOC (lsym
)))
612 SCM entry
= SCM_CAR (lsym
);
613 if (SCM_EQ_P (SCM_CAR (entry
), sym
))
615 *lsymp
= SCM_CDR (lsym
);
624 obarray_remove_all (SCM obarray
)
626 scm_sizet size
= SCM_VECTOR_LENGTH (obarray
);
629 for (i
= 0; i
< size
; i
++)
631 SCM_VELTS (obarray
)[i
] = SCM_EOL
;
637 /* core environments base
639 * This struct and the corresponding functions form a base class for guile's
640 * built-in environment types.
644 struct core_environments_base
{
645 struct scm_environment_funcs
*funcs
;
652 #define CORE_ENVIRONMENTS_BASE(env) \
653 ((struct core_environments_base *) SCM_CELL_WORD_1 (env))
654 #define CORE_ENVIRONMENT_OBSERVERS(env) \
655 (CORE_ENVIRONMENTS_BASE (env)->observers)
656 #define SCM_SET_CORE_ENVIRONMENT_OBSERVERS(env, v) \
657 (CORE_ENVIRONMENT_OBSERVERS (env) = (v))
658 #define CORE_ENVIRONMENT_WEAK_OBSERVER_VECTOR(env) \
659 (CORE_ENVIRONMENTS_BASE (env)->weak_observers)
660 #define CORE_ENVIRONMENT_WEAK_OBSERVERS(env) \
661 (SCM_VELTS (CORE_ENVIRONMENT_WEAK_OBSERVER_VECTOR (env)) [0])
662 #define SCM_SET_CORE_ENVIRONMENT_WEAK_OBSERVERS(env, v) \
663 (SCM_VELTS (CORE_ENVIRONMENT_WEAK_OBSERVER_VECTOR (env)) [0] = (v))
668 core_environments_observe (SCM env
, scm_environment_observer proc
, SCM data
, int weak_p
)
672 SCM_NEWCELL2 (observer
);
673 SCM_SET_CELL_OBJECT_1 (observer
, env
);
674 SCM_SET_CELL_OBJECT_2 (observer
, data
);
675 SCM_SET_CELL_WORD_3 (observer
, proc
);
676 SCM_SET_CELL_TYPE (observer
, scm_tc16_observer
);
680 SCM observers
= CORE_ENVIRONMENT_OBSERVERS (env
);
681 SCM new_observers
= scm_cons (observer
, observers
);
682 SCM_SET_CORE_ENVIRONMENT_OBSERVERS (env
, new_observers
);
686 SCM observers
= CORE_ENVIRONMENT_WEAK_OBSERVERS (env
);
687 SCM new_observers
= scm_acons (SCM_BOOL_F
, observer
, observers
);
688 SCM_SET_CORE_ENVIRONMENT_WEAK_OBSERVERS (env
, new_observers
);
696 core_environments_unobserve (SCM env
, SCM observer
)
698 unsigned int handling_weaks
;
699 for (handling_weaks
= 0; handling_weaks
<= 1; ++handling_weaks
)
701 SCM l
= handling_weaks
702 ? CORE_ENVIRONMENT_WEAK_OBSERVERS (env
)
703 : CORE_ENVIRONMENT_OBSERVERS (env
);
707 SCM rest
= SCM_CDR (l
);
708 SCM first
= handling_weaks
712 if (SCM_EQ_P (first
, observer
))
714 /* Remove the first observer */
716 ? SCM_SET_CORE_ENVIRONMENT_WEAK_OBSERVERS (env
, rest
)
717 : SCM_SET_CORE_ENVIRONMENT_OBSERVERS (env
, rest
);
722 SCM rest
= SCM_CDR (l
);
724 if (!SCM_NULLP (rest
))
726 SCM next
= handling_weaks
730 if (SCM_EQ_P (next
, observer
))
732 SCM_SETCDR (l
, SCM_CDR (rest
));
738 } while (!SCM_NULLP (l
));
742 /* Dirk:FIXME:: What to do now, since the observer is not found? */
747 core_environments_mark (SCM env
)
749 scm_gc_mark (CORE_ENVIRONMENT_OBSERVERS (env
));
750 return CORE_ENVIRONMENT_WEAK_OBSERVER_VECTOR (env
);
755 core_environments_finalize (SCM env
)
761 core_environments_preinit (struct core_environments_base
*body
)
764 body
->observers
= SCM_BOOL_F
;
765 body
->weak_observers
= SCM_BOOL_F
;
770 core_environments_init (struct core_environments_base
*body
,
771 struct scm_environment_funcs
*funcs
)
774 body
->observers
= SCM_EOL
;
775 body
->weak_observers
= scm_make_weak_value_hash_table (SCM_MAKINUM (1));
779 /* Tell all observers to clear their caches.
781 * Environments have to be informed about changes in the following cases:
782 * - The observed env has a new binding. This must be always reported.
783 * - The observed env has dropped a binding. This must be always reported.
784 * - A binding in the observed environment has changed. This must only be
785 * reported, if there is a chance that the binding is being cached outside.
786 * However, this potential optimization is not performed currently.
788 * Errors that occur while the observers are called are accumulated and
789 * signalled as one single error message to the caller.
800 update_catch_body (void *ptr
)
802 struct update_data
*data
= (struct update_data
*) ptr
;
803 SCM observer
= data
->observer
;
805 (*SCM_OBSERVER_PROC (observer
))
806 (data
->environment
, SCM_OBSERVER_DATA (observer
));
808 return SCM_UNDEFINED
;
813 update_catch_handler (void *ptr
, SCM tag
, SCM args
)
815 struct update_data
*data
= (struct update_data
*) ptr
;
816 SCM observer
= data
->observer
;
817 SCM message
= scm_makfrom0str ("Observer `~A' signals `~A' error: ~S");
819 return scm_cons (message
, SCM_LIST3 (observer
, tag
, args
));
824 core_environments_broadcast (SCM env
)
825 #define FUNC_NAME "core_environments_broadcast"
827 unsigned int handling_weaks
;
828 SCM errors
= SCM_EOL
;
830 for (handling_weaks
= 0; handling_weaks
<= 1; ++handling_weaks
)
832 SCM observers
= handling_weaks
833 ? CORE_ENVIRONMENT_WEAK_OBSERVERS (env
)
834 : CORE_ENVIRONMENT_OBSERVERS (env
);
836 for (; !SCM_NULLP (observers
); observers
= SCM_CDR (observers
))
838 struct update_data data
;
839 SCM observer
= handling_weaks
840 ? SCM_CDAR (observers
)
841 : SCM_CAR (observers
);
844 data
.observer
= observer
;
845 data
.environment
= env
;
847 error
= scm_internal_catch (SCM_BOOL_T
,
848 update_catch_body
, &data
,
849 update_catch_handler
, &data
);
851 if (!SCM_UNBNDP (error
))
852 errors
= scm_cons (error
, errors
);
856 if (!SCM_NULLP (errors
))
858 /* Dirk:FIXME:: As soon as scm_misc_error is fixed to handle the name
859 * parameter correctly it should not be necessary any more to also pass
860 * namestr in order to get the desired information from the error
863 SCM ordered_errors
= scm_reverse (errors
);
866 "Observers of `~A' have signalled the following errors: ~S",
867 scm_cons2 (env
, ordered_errors
, SCM_EOL
));
876 * A leaf environment is simply a mutable set of definitions. A leaf
877 * environment supports no operations beyond the common set.
879 * Implementation: The obarray of the leaf environment holds (symbol . value)
880 * pairs. No further information is necessary, since all bindings and
881 * locations in a leaf environment are mutable.
885 struct leaf_environment
{
886 struct core_environments_base base
;
892 #define LEAF_ENVIRONMENT(env) \
893 ((struct leaf_environment *) SCM_CELL_WORD_1 (env))
898 leaf_environment_ref (SCM env
, SCM sym
)
900 SCM obarray
= LEAF_ENVIRONMENT (env
)->obarray
;
901 SCM binding
= obarray_retrieve (obarray
, sym
);
902 return SCM_UNBNDP (binding
) ? binding
: SCM_CDR (binding
);
907 leaf_environment_fold (SCM env
, scm_environment_folder proc
, SCM data
, SCM init
)
911 SCM obarray
= LEAF_ENVIRONMENT (env
)->obarray
;
913 for (i
= 0; i
< SCM_VECTOR_LENGTH (obarray
); i
++)
916 for (l
= SCM_VELTS (obarray
)[i
]; !SCM_NULLP (l
); l
= SCM_CDR (l
))
918 SCM binding
= SCM_CAR (l
);
919 SCM symbol
= SCM_CAR (binding
);
920 SCM value
= SCM_CDR (binding
);
921 result
= (*proc
) (data
, symbol
, value
, result
);
929 leaf_environment_define (SCM env
, SCM sym
, SCM val
)
930 #define FUNC_NAME "leaf_environment_define"
932 SCM obarray
= LEAF_ENVIRONMENT (env
)->obarray
;
934 obarray_replace (obarray
, sym
, val
);
935 core_environments_broadcast (env
);
937 return SCM_ENVIRONMENT_SUCCESS
;
943 leaf_environment_undefine (SCM env
, SCM sym
)
944 #define FUNC_NAME "leaf_environment_undefine"
946 SCM obarray
= LEAF_ENVIRONMENT (env
)->obarray
;
947 SCM removed
= obarray_remove (obarray
, sym
);
949 if (!SCM_FALSEP (removed
))
950 core_environments_broadcast (env
);
952 return SCM_ENVIRONMENT_SUCCESS
;
958 leaf_environment_set_x (SCM env
, SCM sym
, SCM val
)
959 #define FUNC_NAME "leaf_environment_set_x"
961 SCM obarray
= LEAF_ENVIRONMENT (env
)->obarray
;
962 SCM binding
= obarray_retrieve (obarray
, sym
);
964 if (!SCM_UNBNDP (binding
))
966 SCM_SETCDR (binding
, val
);
967 return SCM_ENVIRONMENT_SUCCESS
;
971 return SCM_UNDEFINED
;
978 leaf_environment_cell(SCM env
, SCM sym
, int for_write
)
980 SCM obarray
= LEAF_ENVIRONMENT (env
)->obarray
;
981 SCM binding
= obarray_retrieve (obarray
, sym
);
987 leaf_environment_mark (SCM env
)
989 scm_gc_mark (LEAF_ENVIRONMENT (env
)->obarray
);
990 return core_environments_mark (env
);
995 leaf_environment_free (SCM env
)
997 core_environments_finalize (env
);
999 free (LEAF_ENVIRONMENT (env
));
1000 return sizeof (struct leaf_environment
);
1005 leaf_environment_print (SCM type
, SCM port
, scm_print_state
*pstate
)
1007 SCM address
= scm_ulong2num (SCM_UNPACK (type
));
1008 SCM base16
= scm_number_to_string (address
, SCM_MAKINUM (16));
1010 scm_puts ("#<leaf environment ", port
);
1011 scm_puts (SCM_STRING_CHARS (base16
), port
);
1012 scm_puts (">", port
);
1018 static struct scm_environment_funcs leaf_environment_funcs
= {
1019 leaf_environment_ref
,
1020 leaf_environment_fold
,
1021 leaf_environment_define
,
1022 leaf_environment_undefine
,
1023 leaf_environment_set_x
,
1024 leaf_environment_cell
,
1025 core_environments_observe
,
1026 core_environments_unobserve
,
1027 leaf_environment_mark
,
1028 leaf_environment_free
,
1029 leaf_environment_print
1033 void *scm_type_leaf_environment
= &leaf_environment_funcs
;
1036 SCM_DEFINE (scm_make_leaf_environment
, "make-leaf-environment", 0, 0, 0,
1038 "Create a new leaf environment, containing no bindings.\n"
1039 "All bindings and locations created in the new environment\n"
1041 #define FUNC_NAME s_scm_make_leaf_environment
1043 scm_sizet size
= sizeof (struct leaf_environment
);
1044 struct leaf_environment
*body
= scm_must_malloc (size
, FUNC_NAME
);
1047 core_environments_preinit (&body
->base
);
1048 body
->obarray
= SCM_BOOL_F
;
1050 env
= scm_make_environment (body
);
1052 core_environments_init (&body
->base
, &leaf_environment_funcs
);
1053 body
->obarray
= scm_c_make_hash_table (DEFAULT_OBARRAY_SIZE
);
1060 SCM_DEFINE (scm_leaf_environment_p
, "leaf-environment?", 1, 0, 0,
1062 "Return @code{#t} if object is a leaf environment, or @code{#f}\n"
1064 #define FUNC_NAME s_scm_leaf_environment_p
1066 return SCM_BOOL (SCM_LEAF_ENVIRONMENT_P (object
));
1072 /* eval environments
1074 * A module's source code refers to definitions imported from other modules,
1075 * and definitions made within itself. An eval environment combines two
1076 * environments -- a local environment and an imported environment -- to
1077 * produce a new environment in which both sorts of references can be
1080 * Implementation: The obarray of the eval environment is used to cache
1081 * entries from the local and imported environments such that in most of the
1082 * cases only a single lookup is necessary. Since for neither the local nor
1083 * the imported environment it is known, what kind of environment they form,
1084 * the most general case is assumed. Therefore, entries in the obarray take
1085 * one of the following forms:
1087 * 1) (<symbol> location mutability . source-env), where mutability indicates
1088 * one of the following states: IMMUTABLE if the location is known to be
1089 * immutable, MUTABLE if the location is known to be mutable, UNKNOWN if
1090 * the location has only been requested for non modifying accesses.
1092 * 2) (symbol . source-env) if the symbol has a binding in the source-env, but
1093 * if the source-env can't provide a cell for the binding. Thus, for every
1094 * access, the source-env has to be contacted directly.
1098 struct eval_environment
{
1099 struct core_environments_base base
;
1104 SCM imported_observer
;
1110 #define EVAL_ENVIRONMENT(env) \
1111 ((struct eval_environment *) SCM_CELL_WORD_1 (env))
1113 #define IMMUTABLE SCM_MAKINUM (0)
1114 #define MUTABLE SCM_MAKINUM (1)
1115 #define UNKNOWN SCM_MAKINUM (2)
1117 #define CACHED_LOCATION(x) SCM_CAR (x)
1118 #define CACHED_MUTABILITY(x) SCM_CADR (x)
1119 #define SET_CACHED_MUTABILITY(x, v) SCM_SETCAR (SCM_CDR (x), (v))
1120 #define CACHED_SOURCE_ENVIRONMENT(x) SCM_CDDR (x)
1124 /* eval_environment_lookup will report one of the following distinct results:
1125 * a) (<object> . value) if a cell could be obtained.
1126 * b) <environment> if the environment has to be contacted directly.
1127 * c) IMMUTABLE if an immutable cell was requested for write.
1128 * d) SCM_UNDEFINED if there is no binding for the symbol.
1131 eval_environment_lookup (SCM env
, SCM sym
, int for_write
)
1133 SCM obarray
= EVAL_ENVIRONMENT (env
)->obarray
;
1134 SCM binding
= obarray_retrieve (obarray
, sym
);
1136 if (!SCM_UNBNDP (binding
))
1138 /* The obarray holds an entry for the symbol. */
1140 SCM entry
= SCM_CDR (binding
);
1142 if (SCM_CONSP (entry
))
1144 /* The entry in the obarray is a cached location. */
1146 SCM location
= CACHED_LOCATION (entry
);
1152 mutability
= CACHED_MUTABILITY (entry
);
1153 if (SCM_EQ_P (mutability
, MUTABLE
))
1156 if (SCM_EQ_P (mutability
, UNKNOWN
))
1158 SCM source_env
= CACHED_SOURCE_ENVIRONMENT (entry
);
1159 SCM location
= SCM_ENVIRONMENT_CELL (source_env
, sym
, 1);
1161 if (SCM_CONSP (location
))
1163 SET_CACHED_MUTABILITY (entry
, MUTABLE
);
1166 else /* IMMUTABLE */
1168 SET_CACHED_MUTABILITY (entry
, IMMUTABLE
);
1177 /* The obarray entry is an environment */
1184 /* There is no entry for the symbol in the obarray. This can either
1185 * mean that there has not been a request for the symbol yet, or that
1186 * the symbol is really undefined. We are looking for the symbol in
1187 * both the local and the imported environment. If we find a binding, a
1188 * cached entry is created.
1191 struct eval_environment
*body
= EVAL_ENVIRONMENT (env
);
1192 unsigned int handling_import
;
1194 for (handling_import
= 0; handling_import
<= 1; ++handling_import
)
1196 SCM source_env
= handling_import
? body
->imported
: body
->local
;
1197 SCM location
= SCM_ENVIRONMENT_CELL (source_env
, sym
, for_write
);
1199 if (!SCM_UNBNDP (location
))
1201 if (SCM_CONSP (location
))
1203 SCM mutability
= for_write
? MUTABLE
: UNKNOWN
;
1204 SCM entry
= scm_cons2 (location
, mutability
, source_env
);
1205 obarray_enter (obarray
, sym
, entry
);
1208 else if (SCM_EQ_P (location
, SCM_ENVIRONMENT_LOCATION_NO_CELL
))
1210 obarray_enter (obarray
, sym
, source_env
);
1220 return SCM_UNDEFINED
;
1226 eval_environment_ref (SCM env
, SCM sym
)
1227 #define FUNC_NAME "eval_environment_ref"
1229 SCM location
= eval_environment_lookup (env
, sym
, 0);
1231 if (SCM_CONSP (location
))
1232 return SCM_CDR (location
);
1233 else if (!SCM_UNBNDP (location
))
1234 return SCM_ENVIRONMENT_REF (location
, sym
);
1236 return SCM_UNDEFINED
;
1242 eval_environment_folder (SCM extended_data
, SCM symbol
, SCM value
, SCM tail
)
1244 SCM local
= SCM_CAR (extended_data
);
1246 if (!SCM_ENVIRONMENT_BOUND_P (local
, symbol
))
1248 SCM proc_as_nr
= SCM_CADR (extended_data
);
1249 unsigned long int proc_as_ul
= scm_num2ulong (proc_as_nr
, 0, NULL
);
1250 scm_environment_folder proc
= (scm_environment_folder
) proc_as_ul
;
1251 SCM data
= SCM_CDDR (extended_data
);
1253 return (*proc
) (data
, symbol
, value
, tail
);
1263 eval_environment_fold (SCM env
, scm_environment_folder proc
, SCM data
, SCM init
)
1265 SCM local
= EVAL_ENVIRONMENT (env
)->local
;
1266 SCM imported
= EVAL_ENVIRONMENT (env
)->imported
;
1267 SCM proc_as_nr
= scm_ulong2num ((unsigned long int) proc
);
1268 SCM extended_data
= scm_cons2 (local
, proc_as_nr
, data
);
1269 SCM tmp_result
= scm_c_environment_fold (imported
, eval_environment_folder
, extended_data
, init
);
1271 return scm_c_environment_fold (local
, proc
, data
, tmp_result
);
1276 eval_environment_define (SCM env
, SCM sym
, SCM val
)
1277 #define FUNC_NAME "eval_environment_define"
1279 SCM local
= EVAL_ENVIRONMENT (env
)->local
;
1280 return SCM_ENVIRONMENT_DEFINE (local
, sym
, val
);
1286 eval_environment_undefine (SCM env
, SCM sym
)
1287 #define FUNC_NAME "eval_environment_undefine"
1289 SCM local
= EVAL_ENVIRONMENT (env
)->local
;
1290 return SCM_ENVIRONMENT_UNDEFINE (local
, sym
);
1296 eval_environment_set_x (SCM env
, SCM sym
, SCM val
)
1297 #define FUNC_NAME "eval_environment_set_x"
1299 SCM location
= eval_environment_lookup (env
, sym
, 1);
1301 if (SCM_CONSP (location
))
1303 SCM_SETCDR (location
, val
);
1304 return SCM_ENVIRONMENT_SUCCESS
;
1306 else if (SCM_ENVIRONMENT_P (location
))
1308 return SCM_ENVIRONMENT_SET (location
, sym
, val
);
1310 else if (SCM_EQ_P (location
, IMMUTABLE
))
1312 return SCM_ENVIRONMENT_LOCATION_IMMUTABLE
;
1316 return SCM_UNDEFINED
;
1323 eval_environment_cell (SCM env
, SCM sym
, int for_write
)
1324 #define FUNC_NAME "eval_environment_cell"
1326 SCM location
= eval_environment_lookup (env
, sym
, for_write
);
1328 if (SCM_CONSP (location
))
1330 else if (SCM_ENVIRONMENT_P (location
))
1331 return SCM_ENVIRONMENT_LOCATION_NO_CELL
;
1332 else if (SCM_EQ_P (location
, IMMUTABLE
))
1333 return SCM_ENVIRONMENT_LOCATION_IMMUTABLE
;
1335 return SCM_UNDEFINED
;
1341 eval_environment_mark (SCM env
)
1343 struct eval_environment
*body
= EVAL_ENVIRONMENT (env
);
1345 scm_gc_mark (body
->obarray
);
1346 scm_gc_mark (body
->imported
);
1347 scm_gc_mark (body
->imported_observer
);
1348 scm_gc_mark (body
->local
);
1349 scm_gc_mark (body
->local_observer
);
1351 return core_environments_mark (env
);
1356 eval_environment_free (SCM env
)
1358 core_environments_finalize (env
);
1360 free (EVAL_ENVIRONMENT (env
));
1361 return sizeof (struct eval_environment
);
1366 eval_environment_print (SCM type
, SCM port
, scm_print_state
*pstate
)
1368 SCM address
= scm_ulong2num (SCM_UNPACK (type
));
1369 SCM base16
= scm_number_to_string (address
, SCM_MAKINUM (16));
1371 scm_puts ("#<eval environment ", port
);
1372 scm_puts (SCM_STRING_CHARS (base16
), port
);
1373 scm_puts (">", port
);
1379 static struct scm_environment_funcs eval_environment_funcs
= {
1380 eval_environment_ref
,
1381 eval_environment_fold
,
1382 eval_environment_define
,
1383 eval_environment_undefine
,
1384 eval_environment_set_x
,
1385 eval_environment_cell
,
1386 core_environments_observe
,
1387 core_environments_unobserve
,
1388 eval_environment_mark
,
1389 eval_environment_free
,
1390 eval_environment_print
1394 void *scm_type_eval_environment
= &eval_environment_funcs
;
1398 eval_environment_observer (SCM caller
, SCM eval_env
)
1400 SCM obarray
= EVAL_ENVIRONMENT (eval_env
)->obarray
;
1402 obarray_remove_all (obarray
);
1403 core_environments_broadcast (eval_env
);
1407 SCM_DEFINE (scm_make_eval_environment
, "make-eval-environment", 2, 0, 0,
1408 (SCM local
, SCM imported
),
1409 "Return a new environment object eval whose bindings are the\n"
1410 "union of the bindings in the environments @var{local} and\n"
1411 "@var{imported}, with bindings from @var{local} taking\n"
1412 "precedence. Definitions made in eval are placed in @var{local}.\n"
1413 "Applying @code{environment-define} or\n"
1414 "@code{environment-undefine} to eval has the same effect as\n"
1415 "applying the procedure to @var{local}.\n"
1416 "Note that eval incorporates @var{local} and @var{imported} by\n"
1418 "If, after creating eval, the program changes the bindings of\n"
1419 "@var{local} or @var{imported}, those changes will be visible\n"
1421 "Since most Scheme evaluation takes place in eval environments,\n"
1422 "they transparently cache the bindings received from @var{local}\n"
1423 "and @var{imported}. Thus, the first time the program looks up\n"
1424 "a symbol in eval, eval may make calls to @var{local} or\n"
1425 "@var{imported} to find their bindings, but subsequent\n"
1426 "references to that symbol will be as fast as references to\n"
1427 "bindings in finite environments.\n"
1428 "In typical use, @var{local} will be a finite environment, and\n"
1429 "@var{imported} will be an import environment")
1430 #define FUNC_NAME s_scm_make_eval_environment
1433 struct eval_environment
*body
;
1435 SCM_ASSERT (SCM_ENVIRONMENT_P (local
), local
, SCM_ARG1
, FUNC_NAME
);
1436 SCM_ASSERT (SCM_ENVIRONMENT_P (imported
), imported
, SCM_ARG2
, FUNC_NAME
);
1438 body
= scm_must_malloc (sizeof (struct eval_environment
), FUNC_NAME
);
1440 core_environments_preinit (&body
->base
);
1441 body
->obarray
= SCM_BOOL_F
;
1442 body
->imported
= SCM_BOOL_F
;
1443 body
->imported_observer
= SCM_BOOL_F
;
1444 body
->local
= SCM_BOOL_F
;
1445 body
->local_observer
= SCM_BOOL_F
;
1447 env
= scm_make_environment (body
);
1449 core_environments_init (&body
->base
, &eval_environment_funcs
);
1450 body
->obarray
= scm_c_make_hash_table (DEFAULT_OBARRAY_SIZE
);
1451 body
->imported
= imported
;
1452 body
->imported_observer
1453 = SCM_ENVIRONMENT_OBSERVE (imported
, eval_environment_observer
, env
, 1);
1454 body
->local
= local
;
1455 body
->local_observer
1456 = SCM_ENVIRONMENT_OBSERVE (local
, eval_environment_observer
, env
, 1);
1463 SCM_DEFINE (scm_eval_environment_p
, "eval-environment?", 1, 0, 0,
1465 "Return @code{#t} if object is an eval environment, or @code{#f}\n"
1467 #define FUNC_NAME s_scm_eval_environment_p
1469 return SCM_BOOL (SCM_EVAL_ENVIRONMENT_P (object
));
1474 SCM_DEFINE (scm_eval_environment_local
, "eval-environment-local", 1, 0, 0,
1476 "Return the local environment of eval environment @var{env}.")
1477 #define FUNC_NAME s_scm_eval_environment_local
1479 SCM_ASSERT (SCM_EVAL_ENVIRONMENT_P (env
), env
, SCM_ARG1
, FUNC_NAME
);
1481 return EVAL_ENVIRONMENT (env
)->local
;
1486 SCM_DEFINE (scm_eval_environment_set_local_x
, "eval-environment-set-local!", 2, 0, 0,
1487 (SCM env
, SCM local
),
1488 "Change @var{env}'s local environment to @var{local}.")
1489 #define FUNC_NAME s_scm_eval_environment_set_local_x
1491 struct eval_environment
*body
;
1493 SCM_ASSERT (SCM_EVAL_ENVIRONMENT_P (env
), env
, SCM_ARG1
, FUNC_NAME
);
1494 SCM_ASSERT (SCM_ENVIRONMENT_P (local
), local
, SCM_ARG2
, FUNC_NAME
);
1496 body
= EVAL_ENVIRONMENT (env
);
1498 obarray_remove_all (body
->obarray
);
1499 SCM_ENVIRONMENT_UNOBSERVE (body
->local
, body
->local_observer
);
1501 body
->local
= local
;
1502 body
->local_observer
1503 = SCM_ENVIRONMENT_OBSERVE (local
, eval_environment_observer
, env
, 1);
1505 core_environments_broadcast (env
);
1507 return SCM_UNSPECIFIED
;
1512 SCM_DEFINE (scm_eval_environment_imported
, "eval-environment-imported", 1, 0, 0,
1514 "Return the imported environment of eval environment @var{env}.")
1515 #define FUNC_NAME s_scm_eval_environment_imported
1517 SCM_ASSERT (SCM_EVAL_ENVIRONMENT_P (env
), env
, SCM_ARG1
, FUNC_NAME
);
1519 return EVAL_ENVIRONMENT (env
)->imported
;
1524 SCM_DEFINE (scm_eval_environment_set_imported_x
, "eval-environment-set-imported!", 2, 0, 0,
1525 (SCM env
, SCM imported
),
1526 "Change @var{env}'s imported environment to @var{imported}.")
1527 #define FUNC_NAME s_scm_eval_environment_set_imported_x
1529 struct eval_environment
*body
;
1531 SCM_ASSERT (SCM_EVAL_ENVIRONMENT_P (env
), env
, SCM_ARG1
, FUNC_NAME
);
1532 SCM_ASSERT (SCM_ENVIRONMENT_P (imported
), imported
, SCM_ARG2
, FUNC_NAME
);
1534 body
= EVAL_ENVIRONMENT (env
);
1536 obarray_remove_all (body
->obarray
);
1537 SCM_ENVIRONMENT_UNOBSERVE (body
->imported
, body
->imported_observer
);
1539 body
->imported
= imported
;
1540 body
->imported_observer
1541 = SCM_ENVIRONMENT_OBSERVE (imported
, eval_environment_observer
, env
, 1);
1543 core_environments_broadcast (env
);
1545 return SCM_UNSPECIFIED
;
1551 /* import environments
1553 * An import environment combines the bindings of a set of argument
1554 * environments, and checks for naming clashes.
1556 * Implementation: The import environment does no caching at all. For every
1557 * access, the list of imported environments is scanned.
1561 struct import_environment
{
1562 struct core_environments_base base
;
1565 SCM import_observers
;
1571 #define IMPORT_ENVIRONMENT(env) \
1572 ((struct import_environment *) SCM_CELL_WORD_1 (env))
1576 /* Lookup will report one of the following distinct results:
1577 * a) <environment> if only environment binds the symbol.
1578 * b) (env-1 env-2 ...) for conflicting bindings in env-1, ...
1579 * c) SCM_UNDEFINED if there is no binding for the symbol.
1582 import_environment_lookup (SCM env
, SCM sym
)
1584 SCM imports
= IMPORT_ENVIRONMENT (env
)->imports
;
1585 SCM result
= SCM_UNDEFINED
;
1588 for (l
= imports
; !SCM_NULLP (l
); l
= SCM_CDR (l
))
1590 SCM imported
= SCM_CAR (l
);
1592 if (SCM_ENVIRONMENT_BOUND_P (imported
, sym
))
1594 if (SCM_UNBNDP (result
))
1596 else if (SCM_CONSP (result
))
1597 result
= scm_cons (imported
, result
);
1599 result
= scm_cons2 (imported
, result
, SCM_EOL
);
1603 if (SCM_CONSP (result
))
1604 return scm_reverse (result
);
1611 import_environment_conflict (SCM env
, SCM sym
, SCM imports
)
1613 SCM conflict_proc
= IMPORT_ENVIRONMENT (env
)->conflict_proc
;
1614 SCM args
= scm_cons2 (env
, sym
, scm_cons (imports
, SCM_EOL
));
1616 return scm_apply (conflict_proc
, args
, SCM_EOL
);
1621 import_environment_ref (SCM env
, SCM sym
)
1622 #define FUNC_NAME "import_environment_ref"
1624 SCM owner
= import_environment_lookup (env
, sym
);
1626 if (SCM_UNBNDP (owner
))
1628 return SCM_UNDEFINED
;
1630 else if (SCM_CONSP (owner
))
1632 SCM resolve
= import_environment_conflict (env
, sym
, owner
);
1634 if (SCM_ENVIRONMENT_P (resolve
))
1635 return SCM_ENVIRONMENT_REF (resolve
, sym
);
1637 return SCM_UNSPECIFIED
;
1641 return SCM_ENVIRONMENT_REF (owner
, sym
);
1648 import_environment_folder (SCM extended_data
, SCM symbol
, SCM value
, SCM tail
)
1649 #define FUNC_NAME "import_environment_fold"
1651 SCM import_env
= SCM_CAR (extended_data
);
1652 SCM imported_env
= SCM_CADR (extended_data
);
1653 SCM owner
= import_environment_lookup (import_env
, symbol
);
1654 SCM proc_as_nr
= SCM_CADDR (extended_data
);
1655 unsigned long int proc_as_ul
= scm_num2ulong (proc_as_nr
, 0, NULL
);
1656 scm_environment_folder proc
= (scm_environment_folder
) proc_as_ul
;
1657 SCM data
= SCM_CDDDR (extended_data
);
1659 if (SCM_CONSP (owner
) && SCM_EQ_P (SCM_CAR (owner
), imported_env
))
1660 owner
= import_environment_conflict (import_env
, symbol
, owner
);
1662 if (SCM_ENVIRONMENT_P (owner
))
1663 return (*proc
) (data
, symbol
, value
, tail
);
1664 else /* unresolved conflict */
1665 return (*proc
) (data
, symbol
, SCM_UNSPECIFIED
, tail
);
1671 import_environment_fold (SCM env
, scm_environment_folder proc
, SCM data
, SCM init
)
1673 SCM proc_as_nr
= scm_ulong2num ((unsigned long int) proc
);
1677 for (l
= IMPORT_ENVIRONMENT (env
)->imports
; !SCM_NULLP (l
); l
= SCM_CDR (l
))
1679 SCM imported_env
= SCM_CAR (l
);
1680 SCM extended_data
= scm_cons (env
, scm_cons2 (imported_env
, proc_as_nr
, data
));
1682 result
= scm_c_environment_fold (imported_env
, import_environment_folder
, extended_data
, result
);
1690 import_environment_define (SCM env
, SCM sym
, SCM val
)
1691 #define FUNC_NAME "import_environment_define"
1693 return SCM_ENVIRONMENT_BINDING_IMMUTABLE
;
1699 import_environment_undefine (SCM env
, SCM sym
)
1700 #define FUNC_NAME "import_environment_undefine"
1702 return SCM_ENVIRONMENT_BINDING_IMMUTABLE
;
1708 import_environment_set_x (SCM env
, SCM sym
, SCM val
)
1709 #define FUNC_NAME "import_environment_set_x"
1711 SCM owner
= import_environment_lookup (env
, sym
);
1713 if (SCM_UNBNDP (owner
))
1715 return SCM_UNDEFINED
;
1717 else if (SCM_CONSP (owner
))
1719 SCM resolve
= import_environment_conflict (env
, sym
, owner
);
1721 if (SCM_ENVIRONMENT_P (resolve
))
1722 return SCM_ENVIRONMENT_SET (resolve
, sym
, val
);
1724 return SCM_ENVIRONMENT_LOCATION_IMMUTABLE
;
1728 return SCM_ENVIRONMENT_SET (owner
, sym
, val
);
1735 import_environment_cell (SCM env
, SCM sym
, int for_write
)
1736 #define FUNC_NAME "import_environment_cell"
1738 SCM owner
= import_environment_lookup (env
, sym
);
1740 if (SCM_UNBNDP (owner
))
1742 return SCM_UNDEFINED
;
1744 else if (SCM_CONSP (owner
))
1746 SCM resolve
= import_environment_conflict (env
, sym
, owner
);
1748 if (SCM_ENVIRONMENT_P (resolve
))
1749 return SCM_ENVIRONMENT_CELL (resolve
, sym
, for_write
);
1751 return SCM_ENVIRONMENT_LOCATION_NO_CELL
;
1755 return SCM_ENVIRONMENT_CELL (owner
, sym
, for_write
);
1762 import_environment_mark (SCM env
)
1764 scm_gc_mark (IMPORT_ENVIRONMENT (env
)->imports
);
1765 scm_gc_mark (IMPORT_ENVIRONMENT (env
)->import_observers
);
1766 scm_gc_mark (IMPORT_ENVIRONMENT (env
)->conflict_proc
);
1767 return core_environments_mark (env
);
1772 import_environment_free (SCM env
)
1774 core_environments_finalize (env
);
1776 free (IMPORT_ENVIRONMENT (env
));
1777 return sizeof (struct import_environment
);
1782 import_environment_print (SCM type
, SCM port
, scm_print_state
*pstate
)
1784 SCM address
= scm_ulong2num (SCM_UNPACK (type
));
1785 SCM base16
= scm_number_to_string (address
, SCM_MAKINUM (16));
1787 scm_puts ("#<import environment ", port
);
1788 scm_puts (SCM_STRING_CHARS (base16
), port
);
1789 scm_puts (">", port
);
1795 static struct scm_environment_funcs import_environment_funcs
= {
1796 import_environment_ref
,
1797 import_environment_fold
,
1798 import_environment_define
,
1799 import_environment_undefine
,
1800 import_environment_set_x
,
1801 import_environment_cell
,
1802 core_environments_observe
,
1803 core_environments_unobserve
,
1804 import_environment_mark
,
1805 import_environment_free
,
1806 import_environment_print
1810 void *scm_type_import_environment
= &import_environment_funcs
;
1814 import_environment_observer (SCM caller
, SCM import_env
)
1816 core_environments_broadcast (import_env
);
1820 SCM_DEFINE (scm_make_import_environment
, "make-import-environment", 2, 0, 0,
1821 (SCM imports
, SCM conflict_proc
),
1822 "Return a new environment @var{imp} whose bindings are the union\n"
1823 "of the bindings from the environments in @var{imports};\n"
1824 "@var{imports} must be a list of environments. That is,\n"
1825 "@var{imp} binds a symbol to a location when some element of\n"
1826 "@var{imports} does.\n"
1827 "If two different elements of @var{imports} have a binding for\n"
1828 "the same symbol, the @var{conflict-proc} is called with the\n"
1829 "following parameters: the import environment, the symbol and\n"
1830 "the list of the imported environments that bind the symbol.\n"
1831 "If the @var{conflict-proc} returns an environment @var{env},\n"
1832 "the conflict is considered as resolved and the binding from\n"
1833 "@var{env} is used. If the @var{conflict-proc} returns some\n"
1834 "non-environment object, the conflict is considered unresolved\n"
1835 "and the symbol is treated as unspecified in the import\n"
1837 "The checking for conflicts may be performed lazily, i. e. at\n"
1838 "the moment when a value or binding for a certain symbol is\n"
1839 "requested instead of the moment when the environment is\n"
1840 "created or the bindings of the imports change.\n"
1841 "All bindings in @var{imp} are immutable. If you apply\n"
1842 "@code{environment-define} or @code{environment-undefine} to\n"
1843 "@var{imp}, Guile will signal an\n"
1844 " @code{environment:immutable-binding} error. However,\n"
1845 "notice that the set of bindings in @var{imp} may still change,\n"
1846 "if one of its imported environments changes.")
1847 #define FUNC_NAME s_scm_make_import_environment
1849 scm_sizet size
= sizeof (struct import_environment
);
1850 struct import_environment
*body
= scm_must_malloc (size
, FUNC_NAME
);
1853 core_environments_preinit (&body
->base
);
1854 body
->imports
= SCM_BOOL_F
;
1855 body
->import_observers
= SCM_BOOL_F
;
1856 body
->conflict_proc
= SCM_BOOL_F
;
1858 env
= scm_make_environment (body
);
1860 core_environments_init (&body
->base
, &import_environment_funcs
);
1861 body
->imports
= SCM_EOL
;
1862 body
->import_observers
= SCM_EOL
;
1863 body
->conflict_proc
= conflict_proc
;
1865 scm_import_environment_set_imports_x (env
, imports
);
1872 SCM_DEFINE (scm_import_environment_p
, "import-environment?", 1, 0, 0,
1874 "Return @code{#t} if object is an import environment, or\n"
1875 "@code{#f} otherwise.")
1876 #define FUNC_NAME s_scm_import_environment_p
1878 return SCM_BOOL (SCM_IMPORT_ENVIRONMENT_P (object
));
1883 SCM_DEFINE (scm_import_environment_imports
, "import-environment-imports", 1, 0, 0,
1885 "Return the list of environments imported by the import\n"
1886 "environment @var{env}.")
1887 #define FUNC_NAME s_scm_import_environment_imports
1889 SCM_ASSERT (SCM_IMPORT_ENVIRONMENT_P (env
), env
, SCM_ARG1
, FUNC_NAME
);
1891 return IMPORT_ENVIRONMENT (env
)->imports
;
1896 SCM_DEFINE (scm_import_environment_set_imports_x
, "import-environment-set-imports!", 2, 0, 0,
1897 (SCM env
, SCM imports
),
1898 "Change @var{env}'s list of imported environments to\n"
1899 "@var{imports}, and check for conflicts.")
1900 #define FUNC_NAME s_scm_import_environment_set_imports_x
1902 struct import_environment
*body
= IMPORT_ENVIRONMENT (env
);
1903 SCM import_observers
= SCM_EOL
;
1906 SCM_ASSERT (SCM_IMPORT_ENVIRONMENT_P (env
), env
, SCM_ARG1
, FUNC_NAME
);
1907 for (l
= imports
; SCM_CONSP (l
); l
= SCM_CDR (l
))
1909 SCM obj
= SCM_CAR (l
);
1910 SCM_ASSERT (SCM_ENVIRONMENT_P (obj
), imports
, SCM_ARG1
, FUNC_NAME
);
1912 SCM_ASSERT (SCM_NULLP (l
), imports
, SCM_ARG1
, FUNC_NAME
);
1914 for (l
= body
->import_observers
; !SCM_NULLP (l
); l
= SCM_CDR (l
))
1916 SCM obs
= SCM_CAR (l
);
1917 SCM_ENVIRONMENT_UNOBSERVE (env
, obs
);
1920 for (l
= imports
; !SCM_NULLP (l
); l
= SCM_CDR (l
))
1922 SCM imp
= SCM_CAR (l
);
1923 SCM obs
= SCM_ENVIRONMENT_OBSERVE (imp
, import_environment_observer
, env
, 1);
1924 import_observers
= scm_cons (obs
, import_observers
);
1927 body
->imports
= imports
;
1928 body
->import_observers
= import_observers
;
1930 return SCM_UNSPECIFIED
;
1936 /* export environments
1938 * An export environment restricts an environment to a specified set of
1941 * Implementation: The export environment does no caching at all. For every
1942 * access, the signature is scanned. The signature that is stored internally
1943 * is an alist of pairs (symbol . (mutability)).
1947 struct export_environment
{
1948 struct core_environments_base base
;
1951 SCM private_observer
;
1957 #define EXPORT_ENVIRONMENT(env) \
1958 ((struct export_environment *) SCM_CELL_WORD_1 (env))
1961 SCM_SYMBOL (symbol_immutable_location
, "immutable-location");
1962 SCM_SYMBOL (symbol_mutable_location
, "mutable-location");
1967 export_environment_ref (SCM env
, SCM sym
)
1968 #define FUNC_NAME "export_environment_ref"
1970 struct export_environment
*body
= EXPORT_ENVIRONMENT (env
);
1971 SCM entry
= scm_assq (sym
, body
->signature
);
1973 if (SCM_FALSEP (entry
))
1974 return SCM_UNDEFINED
;
1976 return SCM_ENVIRONMENT_REF (body
->private, sym
);
1982 export_environment_fold (SCM env
, scm_environment_folder proc
, SCM data
, SCM init
)
1984 struct export_environment
*body
= EXPORT_ENVIRONMENT (env
);
1988 for (l
= body
->signature
; !SCM_NULLP (l
); l
= SCM_CDR (l
))
1990 SCM symbol
= SCM_CAR (l
);
1991 SCM value
= SCM_ENVIRONMENT_REF (body
->private, symbol
);
1992 if (!SCM_UNBNDP (value
))
1993 result
= (*proc
) (data
, symbol
, value
, result
);
2000 export_environment_define (SCM env
, SCM sym
, SCM val
)
2001 #define FUNC_NAME "export_environment_define"
2003 return SCM_ENVIRONMENT_BINDING_IMMUTABLE
;
2009 export_environment_undefine (SCM env
, SCM sym
)
2010 #define FUNC_NAME "export_environment_undefine"
2012 return SCM_ENVIRONMENT_BINDING_IMMUTABLE
;
2018 export_environment_set_x (SCM env
, SCM sym
, SCM val
)
2019 #define FUNC_NAME "export_environment_set_x"
2021 struct export_environment
*body
= EXPORT_ENVIRONMENT (env
);
2022 SCM entry
= scm_assq (sym
, body
->signature
);
2024 if (SCM_FALSEP (entry
))
2026 return SCM_UNDEFINED
;
2030 if (SCM_EQ_P (SCM_CADR (entry
), symbol_mutable_location
))
2031 return SCM_ENVIRONMENT_SET (body
->private, sym
, val
);
2033 return SCM_ENVIRONMENT_LOCATION_IMMUTABLE
;
2040 export_environment_cell (SCM env
, SCM sym
, int for_write
)
2041 #define FUNC_NAME "export_environment_cell"
2043 struct export_environment
*body
= EXPORT_ENVIRONMENT (env
);
2044 SCM entry
= scm_assq (sym
, body
->signature
);
2046 if (SCM_FALSEP (entry
))
2048 return SCM_UNDEFINED
;
2052 if (!for_write
|| SCM_EQ_P (SCM_CADR (entry
), symbol_mutable_location
))
2053 return SCM_ENVIRONMENT_CELL (body
->private, sym
, for_write
);
2055 return SCM_ENVIRONMENT_LOCATION_IMMUTABLE
;
2062 export_environment_mark (SCM env
)
2064 struct export_environment
*body
= EXPORT_ENVIRONMENT (env
);
2066 scm_gc_mark (body
->private);
2067 scm_gc_mark (body
->private_observer
);
2068 scm_gc_mark (body
->signature
);
2070 return core_environments_mark (env
);
2075 export_environment_free (SCM env
)
2077 core_environments_finalize (env
);
2079 free (EXPORT_ENVIRONMENT (env
));
2080 return sizeof (struct export_environment
);
2085 export_environment_print (SCM type
, SCM port
, scm_print_state
*pstate
)
2087 SCM address
= scm_ulong2num (SCM_UNPACK (type
));
2088 SCM base16
= scm_number_to_string (address
, SCM_MAKINUM (16));
2090 scm_puts ("#<export environment ", port
);
2091 scm_puts (SCM_STRING_CHARS (base16
), port
);
2092 scm_puts (">", port
);
2098 static struct scm_environment_funcs export_environment_funcs
= {
2099 export_environment_ref
,
2100 export_environment_fold
,
2101 export_environment_define
,
2102 export_environment_undefine
,
2103 export_environment_set_x
,
2104 export_environment_cell
,
2105 core_environments_observe
,
2106 core_environments_unobserve
,
2107 export_environment_mark
,
2108 export_environment_free
,
2109 export_environment_print
2113 void *scm_type_export_environment
= &export_environment_funcs
;
2117 export_environment_observer (SCM caller
, SCM export_env
)
2119 core_environments_broadcast (export_env
);
2123 SCM_DEFINE (scm_make_export_environment
, "make-export-environment", 2, 0, 0,
2124 (SCM
private, SCM signature
),
2125 "Return a new environment @var{exp} containing only those\n"
2126 "bindings in private whose symbols are present in\n"
2127 "@var{signature}. The @var{private} argument must be an\n"
2129 "The environment @var{exp} binds symbol to location when\n"
2130 "@var{env} does, and symbol is exported by @var{signature}.\n\n"
2131 "@var{signature} is a list specifying which of the bindings in\n"
2132 "@var{private} should be visible in @var{exp}. Each element of\n"
2133 "@var{signature} should be a list of the form:\n"
2134 " (symbol attribute ...)\n"
2135 "where each attribute is one of the following:\n"
2137 "@item the symbol @code{mutable-location}\n"
2138 " @var{exp} should treat the\n"
2139 " location bound to symbol as mutable. That is, @var{exp}\n"
2140 " will pass calls to @code{environment-set!} or\n"
2141 " @code{environment-cell} directly through to private.\n"
2142 "@item the symbol @code{immutable-location}\n"
2143 " @var{exp} should treat\n"
2144 " the location bound to symbol as immutable. If the program\n"
2145 " applies @code{environment-set!} to @var{exp} and symbol, or\n"
2146 " calls @code{environment-cell} to obtain a writable value\n"
2147 " cell, @code{environment-set!} will signal an\n"
2148 " @code{environment:immutable-location} error. Note that, even\n"
2149 " if an export environment treats a location as immutable, the\n"
2150 " underlying environment may treat it as mutable, so its\n"
2151 " value may change.\n"
2153 "It is an error for an element of signature to specify both\n"
2154 "@code{mutable-location} and @code{immutable-location}. If\n"
2155 "neither is specified, @code{immutable-location} is assumed.\n\n"
2156 "As a special case, if an element of signature is a lone\n"
2157 "symbol @var{sym}, it is equivalent to an element of the form\n"
2159 "All bindings in @var{exp} are immutable. If you apply\n"
2160 "@code{environment-define} or @code{environment-undefine} to\n"
2161 "@var{exp}, Guile will signal an\n"
2162 "@code{environment:immutable-binding} error. However,\n"
2163 "notice that the set of bindings in @var{exp} may still change,\n"
2164 "if the bindings in private change.")
2165 #define FUNC_NAME s_scm_make_export_environment
2168 struct export_environment
*body
;
2171 SCM_ASSERT (SCM_ENVIRONMENT_P (private), private, SCM_ARG1
, FUNC_NAME
);
2173 size
= sizeof (struct export_environment
);
2174 body
= scm_must_malloc (size
, FUNC_NAME
);
2176 core_environments_preinit (&body
->base
);
2177 body
->private = SCM_BOOL_F
;
2178 body
->private_observer
= SCM_BOOL_F
;
2179 body
->signature
= SCM_BOOL_F
;
2181 env
= scm_make_environment (body
);
2183 core_environments_init (&body
->base
, &export_environment_funcs
);
2184 body
->private = private;
2185 body
->private_observer
2186 = SCM_ENVIRONMENT_OBSERVE (private, export_environment_observer
, env
, 1);
2187 body
->signature
= SCM_EOL
;
2189 scm_export_environment_set_signature_x (env
, signature
);
2196 SCM_DEFINE (scm_export_environment_p
, "export-environment?", 1, 0, 0,
2198 "Return @code{#t} if object is an export environment, or\n"
2199 "@code{#f} otherwise.")
2200 #define FUNC_NAME s_scm_export_environment_p
2202 return SCM_BOOL (SCM_EXPORT_ENVIRONMENT_P (object
));
2207 SCM_DEFINE (scm_export_environment_private
, "export-environment-private", 1, 0, 0,
2209 "Return the private environment of export environment @var{env}.")
2210 #define FUNC_NAME s_scm_export_environment_private
2212 SCM_ASSERT (SCM_EXPORT_ENVIRONMENT_P (env
), env
, SCM_ARG1
, FUNC_NAME
);
2214 return EXPORT_ENVIRONMENT (env
)->private;
2219 SCM_DEFINE (scm_export_environment_set_private_x
, "export-environment-set-private!", 2, 0, 0,
2220 (SCM env
, SCM
private),
2221 "Change the private environment of export environment @var{env}.")
2222 #define FUNC_NAME s_scm_export_environment_set_private_x
2224 struct export_environment
*body
;
2226 SCM_ASSERT (SCM_EXPORT_ENVIRONMENT_P (env
), env
, SCM_ARG1
, FUNC_NAME
);
2227 SCM_ASSERT (SCM_ENVIRONMENT_P (private), private, SCM_ARG2
, FUNC_NAME
);
2229 body
= EXPORT_ENVIRONMENT (env
);
2230 SCM_ENVIRONMENT_UNOBSERVE (private, body
->private_observer
);
2232 body
->private = private;
2233 body
->private_observer
2234 = SCM_ENVIRONMENT_OBSERVE (private, export_environment_observer
, env
, 1);
2236 return SCM_UNSPECIFIED
;
2241 SCM_DEFINE (scm_export_environment_signature
, "export-environment-signature", 1, 0, 0,
2243 "Return the signature of export environment @var{env}.")
2244 #define FUNC_NAME s_scm_export_environment_signature
2246 SCM_ASSERT (SCM_EXPORT_ENVIRONMENT_P (env
), env
, SCM_ARG1
, FUNC_NAME
);
2248 return EXPORT_ENVIRONMENT (env
)->signature
;
2254 export_environment_parse_signature (SCM signature
, const char* caller
)
2256 SCM result
= SCM_EOL
;
2259 for (l
= signature
; SCM_CONSP (l
); l
= SCM_CDR (l
))
2261 SCM entry
= SCM_CAR (l
);
2263 if (SCM_SYMBOLP (entry
))
2265 SCM new_entry
= scm_cons2 (entry
, symbol_immutable_location
, SCM_EOL
);
2266 result
= scm_cons (new_entry
, result
);
2277 SCM_ASSERT (SCM_CONSP (entry
), entry
, SCM_ARGn
, caller
);
2278 SCM_ASSERT (SCM_SYMBOLP (SCM_CAR (entry
)), entry
, SCM_ARGn
, caller
);
2280 sym
= SCM_CAR (entry
);
2282 for (l2
= SCM_CDR (entry
); SCM_CONSP (l2
); l2
= SCM_CDR (l2
))
2284 SCM attribute
= SCM_CAR (l2
);
2285 if (SCM_EQ_P (attribute
, symbol_immutable_location
))
2287 else if (SCM_EQ_P (attribute
, symbol_mutable_location
))
2290 SCM_ASSERT (0, entry
, SCM_ARGn
, caller
);
2292 SCM_ASSERT (SCM_NULLP (l2
), entry
, SCM_ARGn
, caller
);
2293 SCM_ASSERT (!mutable || !immutable
, entry
, SCM_ARGn
, caller
);
2295 if (!mutable && !immutable
)
2298 mutability
= mutable ? symbol_mutable_location
: symbol_immutable_location
;
2299 new_entry
= scm_cons2 (sym
, mutability
, SCM_EOL
);
2300 result
= scm_cons (new_entry
, result
);
2303 SCM_ASSERT (SCM_NULLP (l
), signature
, SCM_ARGn
, caller
);
2305 /* Dirk:FIXME:: Now we know that signature is syntactically correct. There
2306 * are, however, no checks for symbols entered twice with contradicting
2307 * mutabilities. It would be nice, to implement this test, to be able to
2308 * call the sort functions conveniently from C.
2311 return scm_reverse (result
);
2315 SCM_DEFINE (scm_export_environment_set_signature_x
, "export-environment-set-signature!", 2, 0, 0,
2316 (SCM env
, SCM signature
),
2317 "Change the signature of export environment @var{env}.")
2318 #define FUNC_NAME s_scm_export_environment_set_signature_x
2322 SCM_ASSERT (SCM_EXPORT_ENVIRONMENT_P (env
), env
, SCM_ARG1
, FUNC_NAME
);
2323 parsed_sig
= export_environment_parse_signature (signature
, FUNC_NAME
);
2325 EXPORT_ENVIRONMENT (env
)->signature
= parsed_sig
;
2327 return SCM_UNSPECIFIED
;
2334 scm_environments_prehistory ()
2336 /* create environment smob */
2337 scm_tc16_environment
= scm_make_smob_type ("environment", 0);
2338 scm_set_smob_mark (scm_tc16_environment
, environment_mark
);
2339 scm_set_smob_free (scm_tc16_environment
, environment_free
);
2340 scm_set_smob_print (scm_tc16_environment
, environment_print
);
2342 /* create observer smob */
2343 scm_tc16_observer
= scm_make_smob_type ("observer", 0);
2344 scm_set_smob_mark (scm_tc16_observer
, observer_mark
);
2345 scm_set_smob_print (scm_tc16_observer
, observer_print
);
2347 /* create system environment */
2348 scm_system_environment
= scm_make_leaf_environment ();
2349 scm_permanent_object (scm_system_environment
);
2354 scm_init_environments ()
2356 #ifndef SCM_MAGIC_SNARFER
2357 #include "libguile/environments.x"