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_t_bits scm_tc16_environment
;
60 scm_t_bits 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 SCM_UNUSED
)
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 size_t 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 size_t 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 size_t 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 size_t 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 size_t 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 SCM_UNUSED
)
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_list_3 (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 SCM_UNUSED
)
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 SCM_UNUSED
)
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 size_t 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 SCM_UNUSED
)
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_UNUSED
, 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_0 (conflict_proc
, args
);
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_UNUSED
,
1693 #define FUNC_NAME "import_environment_define"
1695 return SCM_ENVIRONMENT_BINDING_IMMUTABLE
;
1701 import_environment_undefine (SCM env SCM_UNUSED
,
1703 #define FUNC_NAME "import_environment_undefine"
1705 return SCM_ENVIRONMENT_BINDING_IMMUTABLE
;
1711 import_environment_set_x (SCM env
, SCM sym
, SCM val
)
1712 #define FUNC_NAME "import_environment_set_x"
1714 SCM owner
= import_environment_lookup (env
, sym
);
1716 if (SCM_UNBNDP (owner
))
1718 return SCM_UNDEFINED
;
1720 else if (SCM_CONSP (owner
))
1722 SCM resolve
= import_environment_conflict (env
, sym
, owner
);
1724 if (SCM_ENVIRONMENT_P (resolve
))
1725 return SCM_ENVIRONMENT_SET (resolve
, sym
, val
);
1727 return SCM_ENVIRONMENT_LOCATION_IMMUTABLE
;
1731 return SCM_ENVIRONMENT_SET (owner
, sym
, val
);
1738 import_environment_cell (SCM env
, SCM sym
, int for_write
)
1739 #define FUNC_NAME "import_environment_cell"
1741 SCM owner
= import_environment_lookup (env
, sym
);
1743 if (SCM_UNBNDP (owner
))
1745 return SCM_UNDEFINED
;
1747 else if (SCM_CONSP (owner
))
1749 SCM resolve
= import_environment_conflict (env
, sym
, owner
);
1751 if (SCM_ENVIRONMENT_P (resolve
))
1752 return SCM_ENVIRONMENT_CELL (resolve
, sym
, for_write
);
1754 return SCM_ENVIRONMENT_LOCATION_NO_CELL
;
1758 return SCM_ENVIRONMENT_CELL (owner
, sym
, for_write
);
1765 import_environment_mark (SCM env
)
1767 scm_gc_mark (IMPORT_ENVIRONMENT (env
)->imports
);
1768 scm_gc_mark (IMPORT_ENVIRONMENT (env
)->import_observers
);
1769 scm_gc_mark (IMPORT_ENVIRONMENT (env
)->conflict_proc
);
1770 return core_environments_mark (env
);
1775 import_environment_free (SCM env
)
1777 core_environments_finalize (env
);
1779 free (IMPORT_ENVIRONMENT (env
));
1780 return sizeof (struct import_environment
);
1785 import_environment_print (SCM type
, SCM port
,
1786 scm_print_state
*pstate SCM_UNUSED
)
1788 SCM address
= scm_ulong2num (SCM_UNPACK (type
));
1789 SCM base16
= scm_number_to_string (address
, SCM_MAKINUM (16));
1791 scm_puts ("#<import environment ", port
);
1792 scm_puts (SCM_STRING_CHARS (base16
), port
);
1793 scm_puts (">", port
);
1799 static struct scm_environment_funcs import_environment_funcs
= {
1800 import_environment_ref
,
1801 import_environment_fold
,
1802 import_environment_define
,
1803 import_environment_undefine
,
1804 import_environment_set_x
,
1805 import_environment_cell
,
1806 core_environments_observe
,
1807 core_environments_unobserve
,
1808 import_environment_mark
,
1809 import_environment_free
,
1810 import_environment_print
1814 void *scm_type_import_environment
= &import_environment_funcs
;
1818 import_environment_observer (SCM caller SCM_UNUSED
, SCM import_env
)
1820 core_environments_broadcast (import_env
);
1824 SCM_DEFINE (scm_make_import_environment
, "make-import-environment", 2, 0, 0,
1825 (SCM imports
, SCM conflict_proc
),
1826 "Return a new environment @var{imp} whose bindings are the union\n"
1827 "of the bindings from the environments in @var{imports};\n"
1828 "@var{imports} must be a list of environments. That is,\n"
1829 "@var{imp} binds a symbol to a location when some element of\n"
1830 "@var{imports} does.\n"
1831 "If two different elements of @var{imports} have a binding for\n"
1832 "the same symbol, the @var{conflict-proc} is called with the\n"
1833 "following parameters: the import environment, the symbol and\n"
1834 "the list of the imported environments that bind the symbol.\n"
1835 "If the @var{conflict-proc} returns an environment @var{env},\n"
1836 "the conflict is considered as resolved and the binding from\n"
1837 "@var{env} is used. If the @var{conflict-proc} returns some\n"
1838 "non-environment object, the conflict is considered unresolved\n"
1839 "and the symbol is treated as unspecified in the import\n"
1841 "The checking for conflicts may be performed lazily, i. e. at\n"
1842 "the moment when a value or binding for a certain symbol is\n"
1843 "requested instead of the moment when the environment is\n"
1844 "created or the bindings of the imports change.\n"
1845 "All bindings in @var{imp} are immutable. If you apply\n"
1846 "@code{environment-define} or @code{environment-undefine} to\n"
1847 "@var{imp}, Guile will signal an\n"
1848 " @code{environment:immutable-binding} error. However,\n"
1849 "notice that the set of bindings in @var{imp} may still change,\n"
1850 "if one of its imported environments changes.")
1851 #define FUNC_NAME s_scm_make_import_environment
1853 size_t size
= sizeof (struct import_environment
);
1854 struct import_environment
*body
= scm_must_malloc (size
, FUNC_NAME
);
1857 core_environments_preinit (&body
->base
);
1858 body
->imports
= SCM_BOOL_F
;
1859 body
->import_observers
= SCM_BOOL_F
;
1860 body
->conflict_proc
= SCM_BOOL_F
;
1862 env
= scm_make_environment (body
);
1864 core_environments_init (&body
->base
, &import_environment_funcs
);
1865 body
->imports
= SCM_EOL
;
1866 body
->import_observers
= SCM_EOL
;
1867 body
->conflict_proc
= conflict_proc
;
1869 scm_import_environment_set_imports_x (env
, imports
);
1876 SCM_DEFINE (scm_import_environment_p
, "import-environment?", 1, 0, 0,
1878 "Return @code{#t} if object is an import environment, or\n"
1879 "@code{#f} otherwise.")
1880 #define FUNC_NAME s_scm_import_environment_p
1882 return SCM_BOOL (SCM_IMPORT_ENVIRONMENT_P (object
));
1887 SCM_DEFINE (scm_import_environment_imports
, "import-environment-imports", 1, 0, 0,
1889 "Return the list of environments imported by the import\n"
1890 "environment @var{env}.")
1891 #define FUNC_NAME s_scm_import_environment_imports
1893 SCM_ASSERT (SCM_IMPORT_ENVIRONMENT_P (env
), env
, SCM_ARG1
, FUNC_NAME
);
1895 return IMPORT_ENVIRONMENT (env
)->imports
;
1900 SCM_DEFINE (scm_import_environment_set_imports_x
, "import-environment-set-imports!", 2, 0, 0,
1901 (SCM env
, SCM imports
),
1902 "Change @var{env}'s list of imported environments to\n"
1903 "@var{imports}, and check for conflicts.")
1904 #define FUNC_NAME s_scm_import_environment_set_imports_x
1906 struct import_environment
*body
= IMPORT_ENVIRONMENT (env
);
1907 SCM import_observers
= SCM_EOL
;
1910 SCM_ASSERT (SCM_IMPORT_ENVIRONMENT_P (env
), env
, SCM_ARG1
, FUNC_NAME
);
1911 for (l
= imports
; SCM_CONSP (l
); l
= SCM_CDR (l
))
1913 SCM obj
= SCM_CAR (l
);
1914 SCM_ASSERT (SCM_ENVIRONMENT_P (obj
), imports
, SCM_ARG2
, FUNC_NAME
);
1916 SCM_ASSERT (SCM_NULLP (l
), imports
, SCM_ARG2
, FUNC_NAME
);
1918 for (l
= body
->import_observers
; !SCM_NULLP (l
); l
= SCM_CDR (l
))
1920 SCM obs
= SCM_CAR (l
);
1921 SCM_ENVIRONMENT_UNOBSERVE (env
, obs
);
1924 for (l
= imports
; !SCM_NULLP (l
); l
= SCM_CDR (l
))
1926 SCM imp
= SCM_CAR (l
);
1927 SCM obs
= SCM_ENVIRONMENT_OBSERVE (imp
, import_environment_observer
, env
, 1);
1928 import_observers
= scm_cons (obs
, import_observers
);
1931 body
->imports
= imports
;
1932 body
->import_observers
= import_observers
;
1934 return SCM_UNSPECIFIED
;
1940 /* export environments
1942 * An export environment restricts an environment to a specified set of
1945 * Implementation: The export environment does no caching at all. For every
1946 * access, the signature is scanned. The signature that is stored internally
1947 * is an alist of pairs (symbol . (mutability)).
1951 struct export_environment
{
1952 struct core_environments_base base
;
1955 SCM private_observer
;
1961 #define EXPORT_ENVIRONMENT(env) \
1962 ((struct export_environment *) SCM_CELL_WORD_1 (env))
1965 SCM_SYMBOL (symbol_immutable_location
, "immutable-location");
1966 SCM_SYMBOL (symbol_mutable_location
, "mutable-location");
1971 export_environment_ref (SCM env
, SCM sym
)
1972 #define FUNC_NAME "export_environment_ref"
1974 struct export_environment
*body
= EXPORT_ENVIRONMENT (env
);
1975 SCM entry
= scm_assq (sym
, body
->signature
);
1977 if (SCM_FALSEP (entry
))
1978 return SCM_UNDEFINED
;
1980 return SCM_ENVIRONMENT_REF (body
->private, sym
);
1986 export_environment_fold (SCM env
, scm_environment_folder proc
, SCM data
, SCM init
)
1988 struct export_environment
*body
= EXPORT_ENVIRONMENT (env
);
1992 for (l
= body
->signature
; !SCM_NULLP (l
); l
= SCM_CDR (l
))
1994 SCM symbol
= SCM_CAR (l
);
1995 SCM value
= SCM_ENVIRONMENT_REF (body
->private, symbol
);
1996 if (!SCM_UNBNDP (value
))
1997 result
= (*proc
) (data
, symbol
, value
, result
);
2004 export_environment_define (SCM env SCM_UNUSED
,
2007 #define FUNC_NAME "export_environment_define"
2009 return SCM_ENVIRONMENT_BINDING_IMMUTABLE
;
2015 export_environment_undefine (SCM env SCM_UNUSED
, SCM sym SCM_UNUSED
)
2016 #define FUNC_NAME "export_environment_undefine"
2018 return SCM_ENVIRONMENT_BINDING_IMMUTABLE
;
2024 export_environment_set_x (SCM env
, SCM sym
, SCM val
)
2025 #define FUNC_NAME "export_environment_set_x"
2027 struct export_environment
*body
= EXPORT_ENVIRONMENT (env
);
2028 SCM entry
= scm_assq (sym
, body
->signature
);
2030 if (SCM_FALSEP (entry
))
2032 return SCM_UNDEFINED
;
2036 if (SCM_EQ_P (SCM_CADR (entry
), symbol_mutable_location
))
2037 return SCM_ENVIRONMENT_SET (body
->private, sym
, val
);
2039 return SCM_ENVIRONMENT_LOCATION_IMMUTABLE
;
2046 export_environment_cell (SCM env
, SCM sym
, int for_write
)
2047 #define FUNC_NAME "export_environment_cell"
2049 struct export_environment
*body
= EXPORT_ENVIRONMENT (env
);
2050 SCM entry
= scm_assq (sym
, body
->signature
);
2052 if (SCM_FALSEP (entry
))
2054 return SCM_UNDEFINED
;
2058 if (!for_write
|| SCM_EQ_P (SCM_CADR (entry
), symbol_mutable_location
))
2059 return SCM_ENVIRONMENT_CELL (body
->private, sym
, for_write
);
2061 return SCM_ENVIRONMENT_LOCATION_IMMUTABLE
;
2068 export_environment_mark (SCM env
)
2070 struct export_environment
*body
= EXPORT_ENVIRONMENT (env
);
2072 scm_gc_mark (body
->private);
2073 scm_gc_mark (body
->private_observer
);
2074 scm_gc_mark (body
->signature
);
2076 return core_environments_mark (env
);
2081 export_environment_free (SCM env
)
2083 core_environments_finalize (env
);
2085 free (EXPORT_ENVIRONMENT (env
));
2086 return sizeof (struct export_environment
);
2091 export_environment_print (SCM type
, SCM port
,
2092 scm_print_state
*pstate SCM_UNUSED
)
2094 SCM address
= scm_ulong2num (SCM_UNPACK (type
));
2095 SCM base16
= scm_number_to_string (address
, SCM_MAKINUM (16));
2097 scm_puts ("#<export environment ", port
);
2098 scm_puts (SCM_STRING_CHARS (base16
), port
);
2099 scm_puts (">", port
);
2105 static struct scm_environment_funcs export_environment_funcs
= {
2106 export_environment_ref
,
2107 export_environment_fold
,
2108 export_environment_define
,
2109 export_environment_undefine
,
2110 export_environment_set_x
,
2111 export_environment_cell
,
2112 core_environments_observe
,
2113 core_environments_unobserve
,
2114 export_environment_mark
,
2115 export_environment_free
,
2116 export_environment_print
2120 void *scm_type_export_environment
= &export_environment_funcs
;
2124 export_environment_observer (SCM caller SCM_UNUSED
, SCM export_env
)
2126 core_environments_broadcast (export_env
);
2130 SCM_DEFINE (scm_make_export_environment
, "make-export-environment", 2, 0, 0,
2131 (SCM
private, SCM signature
),
2132 "Return a new environment @var{exp} containing only those\n"
2133 "bindings in private whose symbols are present in\n"
2134 "@var{signature}. The @var{private} argument must be an\n"
2136 "The environment @var{exp} binds symbol to location when\n"
2137 "@var{env} does, and symbol is exported by @var{signature}.\n\n"
2138 "@var{signature} is a list specifying which of the bindings in\n"
2139 "@var{private} should be visible in @var{exp}. Each element of\n"
2140 "@var{signature} should be a list of the form:\n"
2141 " (symbol attribute ...)\n"
2142 "where each attribute is one of the following:\n"
2144 "@item the symbol @code{mutable-location}\n"
2145 " @var{exp} should treat the\n"
2146 " location bound to symbol as mutable. That is, @var{exp}\n"
2147 " will pass calls to @code{environment-set!} or\n"
2148 " @code{environment-cell} directly through to private.\n"
2149 "@item the symbol @code{immutable-location}\n"
2150 " @var{exp} should treat\n"
2151 " the location bound to symbol as immutable. If the program\n"
2152 " applies @code{environment-set!} to @var{exp} and symbol, or\n"
2153 " calls @code{environment-cell} to obtain a writable value\n"
2154 " cell, @code{environment-set!} will signal an\n"
2155 " @code{environment:immutable-location} error. Note that, even\n"
2156 " if an export environment treats a location as immutable, the\n"
2157 " underlying environment may treat it as mutable, so its\n"
2158 " value may change.\n"
2160 "It is an error for an element of signature to specify both\n"
2161 "@code{mutable-location} and @code{immutable-location}. If\n"
2162 "neither is specified, @code{immutable-location} is assumed.\n\n"
2163 "As a special case, if an element of signature is a lone\n"
2164 "symbol @var{sym}, it is equivalent to an element of the form\n"
2166 "All bindings in @var{exp} are immutable. If you apply\n"
2167 "@code{environment-define} or @code{environment-undefine} to\n"
2168 "@var{exp}, Guile will signal an\n"
2169 "@code{environment:immutable-binding} error. However,\n"
2170 "notice that the set of bindings in @var{exp} may still change,\n"
2171 "if the bindings in private change.")
2172 #define FUNC_NAME s_scm_make_export_environment
2175 struct export_environment
*body
;
2178 SCM_ASSERT (SCM_ENVIRONMENT_P (private), private, SCM_ARG1
, FUNC_NAME
);
2180 size
= sizeof (struct export_environment
);
2181 body
= scm_must_malloc (size
, FUNC_NAME
);
2183 core_environments_preinit (&body
->base
);
2184 body
->private = SCM_BOOL_F
;
2185 body
->private_observer
= SCM_BOOL_F
;
2186 body
->signature
= SCM_BOOL_F
;
2188 env
= scm_make_environment (body
);
2190 core_environments_init (&body
->base
, &export_environment_funcs
);
2191 body
->private = private;
2192 body
->private_observer
2193 = SCM_ENVIRONMENT_OBSERVE (private, export_environment_observer
, env
, 1);
2194 body
->signature
= SCM_EOL
;
2196 scm_export_environment_set_signature_x (env
, signature
);
2203 SCM_DEFINE (scm_export_environment_p
, "export-environment?", 1, 0, 0,
2205 "Return @code{#t} if object is an export environment, or\n"
2206 "@code{#f} otherwise.")
2207 #define FUNC_NAME s_scm_export_environment_p
2209 return SCM_BOOL (SCM_EXPORT_ENVIRONMENT_P (object
));
2214 SCM_DEFINE (scm_export_environment_private
, "export-environment-private", 1, 0, 0,
2216 "Return the private environment of export environment @var{env}.")
2217 #define FUNC_NAME s_scm_export_environment_private
2219 SCM_ASSERT (SCM_EXPORT_ENVIRONMENT_P (env
), env
, SCM_ARG1
, FUNC_NAME
);
2221 return EXPORT_ENVIRONMENT (env
)->private;
2226 SCM_DEFINE (scm_export_environment_set_private_x
, "export-environment-set-private!", 2, 0, 0,
2227 (SCM env
, SCM
private),
2228 "Change the private environment of export environment @var{env}.")
2229 #define FUNC_NAME s_scm_export_environment_set_private_x
2231 struct export_environment
*body
;
2233 SCM_ASSERT (SCM_EXPORT_ENVIRONMENT_P (env
), env
, SCM_ARG1
, FUNC_NAME
);
2234 SCM_ASSERT (SCM_ENVIRONMENT_P (private), private, SCM_ARG2
, FUNC_NAME
);
2236 body
= EXPORT_ENVIRONMENT (env
);
2237 SCM_ENVIRONMENT_UNOBSERVE (private, body
->private_observer
);
2239 body
->private = private;
2240 body
->private_observer
2241 = SCM_ENVIRONMENT_OBSERVE (private, export_environment_observer
, env
, 1);
2243 return SCM_UNSPECIFIED
;
2248 SCM_DEFINE (scm_export_environment_signature
, "export-environment-signature", 1, 0, 0,
2250 "Return the signature of export environment @var{env}.")
2251 #define FUNC_NAME s_scm_export_environment_signature
2253 SCM_ASSERT (SCM_EXPORT_ENVIRONMENT_P (env
), env
, SCM_ARG1
, FUNC_NAME
);
2255 return EXPORT_ENVIRONMENT (env
)->signature
;
2261 export_environment_parse_signature (SCM signature
, const char* caller
)
2263 SCM result
= SCM_EOL
;
2266 for (l
= signature
; SCM_CONSP (l
); l
= SCM_CDR (l
))
2268 SCM entry
= SCM_CAR (l
);
2270 if (SCM_SYMBOLP (entry
))
2272 SCM new_entry
= scm_cons2 (entry
, symbol_immutable_location
, SCM_EOL
);
2273 result
= scm_cons (new_entry
, result
);
2284 SCM_ASSERT (SCM_CONSP (entry
), entry
, SCM_ARGn
, caller
);
2285 SCM_ASSERT (SCM_SYMBOLP (SCM_CAR (entry
)), entry
, SCM_ARGn
, caller
);
2287 sym
= SCM_CAR (entry
);
2289 for (l2
= SCM_CDR (entry
); SCM_CONSP (l2
); l2
= SCM_CDR (l2
))
2291 SCM attribute
= SCM_CAR (l2
);
2292 if (SCM_EQ_P (attribute
, symbol_immutable_location
))
2294 else if (SCM_EQ_P (attribute
, symbol_mutable_location
))
2297 SCM_ASSERT (0, entry
, SCM_ARGn
, caller
);
2299 SCM_ASSERT (SCM_NULLP (l2
), entry
, SCM_ARGn
, caller
);
2300 SCM_ASSERT (!mutable || !immutable
, entry
, SCM_ARGn
, caller
);
2302 if (!mutable && !immutable
)
2305 mutability
= mutable ? symbol_mutable_location
: symbol_immutable_location
;
2306 new_entry
= scm_cons2 (sym
, mutability
, SCM_EOL
);
2307 result
= scm_cons (new_entry
, result
);
2310 SCM_ASSERT (SCM_NULLP (l
), signature
, SCM_ARGn
, caller
);
2312 /* Dirk:FIXME:: Now we know that signature is syntactically correct. There
2313 * are, however, no checks for symbols entered twice with contradicting
2314 * mutabilities. It would be nice, to implement this test, to be able to
2315 * call the sort functions conveniently from C.
2318 return scm_reverse (result
);
2322 SCM_DEFINE (scm_export_environment_set_signature_x
, "export-environment-set-signature!", 2, 0, 0,
2323 (SCM env
, SCM signature
),
2324 "Change the signature of export environment @var{env}.")
2325 #define FUNC_NAME s_scm_export_environment_set_signature_x
2329 SCM_ASSERT (SCM_EXPORT_ENVIRONMENT_P (env
), env
, SCM_ARG1
, FUNC_NAME
);
2330 parsed_sig
= export_environment_parse_signature (signature
, FUNC_NAME
);
2332 EXPORT_ENVIRONMENT (env
)->signature
= parsed_sig
;
2334 return SCM_UNSPECIFIED
;
2341 scm_environments_prehistory ()
2343 /* create environment smob */
2344 scm_tc16_environment
= scm_make_smob_type ("environment", 0);
2345 scm_set_smob_mark (scm_tc16_environment
, environment_mark
);
2346 scm_set_smob_free (scm_tc16_environment
, environment_free
);
2347 scm_set_smob_print (scm_tc16_environment
, environment_print
);
2349 /* create observer smob */
2350 scm_tc16_observer
= scm_make_smob_type ("observer", 0);
2351 scm_set_smob_mark (scm_tc16_observer
, observer_mark
);
2352 scm_set_smob_print (scm_tc16_observer
, observer_print
);
2354 /* create system environment */
2355 scm_system_environment
= scm_make_leaf_environment ();
2356 scm_permanent_object (scm_system_environment
);
2361 scm_init_environments ()
2363 #ifndef SCM_MAGIC_SNARFER
2364 #include "libguile/environments.x"