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/list.h"
50 #include "libguile/ports.h"
51 #include "libguile/smob.h"
52 #include "libguile/symbols.h"
53 #include "libguile/vectors.h"
54 #include "libguile/weaks.h"
56 #include "libguile/environments.h"
60 scm_t_bits scm_tc16_environment
;
61 scm_t_bits scm_tc16_observer
;
62 #define DEFAULT_OBARRAY_SIZE 137
64 SCM scm_system_environment
;
68 /* error conditions */
71 * Throw an error if symbol is not bound in environment func
74 scm_error_environment_unbound (const char *func
, SCM env
, SCM symbol
)
76 /* Dirk:FIXME:: Should throw an environment:unbound type error */
77 char error
[] = "Symbol `~A' not bound in environment `~A'.";
78 SCM arguments
= scm_cons2 (symbol
, env
, SCM_EOL
);
79 scm_misc_error (func
, error
, arguments
);
84 * Throw an error if func tried to create (define) or remove
85 * (undefine) a new binding for symbol in env
88 scm_error_environment_immutable_binding (const char *func
, SCM env
, SCM symbol
)
90 /* Dirk:FIXME:: Should throw an environment:immutable-binding type error */
91 char error
[] = "Immutable binding in environment ~A (symbol: `~A').";
92 SCM arguments
= scm_cons2 (env
, symbol
, SCM_EOL
);
93 scm_misc_error (func
, error
, arguments
);
98 * Throw an error if func tried to change an immutable location.
101 scm_error_environment_immutable_location (const char *func
, SCM env
, SCM symbol
)
103 /* Dirk:FIXME:: Should throw an environment:immutable-location type error */
104 char error
[] = "Immutable location in environment `~A' (symbol: `~A').";
105 SCM arguments
= scm_cons2 (env
, symbol
, SCM_EOL
);
106 scm_misc_error (func
, error
, arguments
);
111 /* generic environments */
114 /* Create an environment for the given type. Dereferencing type twice must
115 * deliver the initialized set of environment functions. Thus, type will
116 * also determine the signature of the underlying environment implementation.
117 * Dereferencing type once will typically deliver the data fields used by the
118 * underlying environment implementation.
121 scm_make_environment (void *type
)
123 return scm_cell (scm_tc16_environment
, (scm_t_bits
) type
);
127 SCM_DEFINE (scm_environment_p
, "environment?", 1, 0, 0,
129 "Return @code{#t} if @var{obj} is an environment, or @code{#f}\n"
131 #define FUNC_NAME s_scm_environment_p
133 return SCM_BOOL (SCM_ENVIRONMENT_P (obj
));
138 SCM_DEFINE (scm_environment_bound_p
, "environment-bound?", 2, 0, 0,
140 "Return @code{#t} if @var{sym} is bound in @var{env}, or\n"
141 "@code{#f} otherwise.")
142 #define FUNC_NAME s_scm_environment_bound_p
144 SCM_ASSERT (SCM_ENVIRONMENT_P (env
), env
, SCM_ARG1
, FUNC_NAME
);
145 SCM_ASSERT (SCM_SYMBOLP (sym
), sym
, SCM_ARG2
, FUNC_NAME
);
147 return SCM_BOOL (SCM_ENVIRONMENT_BOUND_P (env
, sym
));
152 SCM_DEFINE (scm_environment_ref
, "environment-ref", 2, 0, 0,
154 "Return the value of the location bound to @var{sym} in\n"
155 "@var{env}. If @var{sym} is unbound in @var{env}, signal an\n"
156 "@code{environment:unbound} error.")
157 #define FUNC_NAME s_scm_environment_ref
161 SCM_ASSERT (SCM_ENVIRONMENT_P (env
), env
, SCM_ARG1
, FUNC_NAME
);
162 SCM_ASSERT (SCM_SYMBOLP (sym
), sym
, SCM_ARG2
, FUNC_NAME
);
164 val
= SCM_ENVIRONMENT_REF (env
, sym
);
166 if (!SCM_UNBNDP (val
))
169 scm_error_environment_unbound (FUNC_NAME
, env
, sym
);
174 /* This C function is identical to environment-ref, except that if symbol is
175 * unbound in env, it returns the value SCM_UNDEFINED, instead of signalling
179 scm_c_environment_ref (SCM env
, SCM sym
)
181 SCM_ASSERT (SCM_ENVIRONMENT_P (env
), env
, SCM_ARG1
, "scm_c_environment_ref");
182 SCM_ASSERT (SCM_SYMBOLP (sym
), sym
, SCM_ARG2
, "scm_c_environment_ref");
183 return SCM_ENVIRONMENT_REF (env
, sym
);
188 environment_default_folder (SCM proc
, SCM symbol
, SCM value
, SCM tail
)
190 return gh_call3 (proc
, symbol
, value
, tail
);
194 SCM_DEFINE (scm_environment_fold
, "environment-fold", 3, 0, 0,
195 (SCM env
, SCM proc
, SCM init
),
196 "Iterate over all the bindings in @var{env}, accumulating some\n"
198 "For each binding in @var{env}, apply @var{proc} to the symbol\n"
199 "bound, its value, and the result from the previous application\n"
201 "Use @var{init} as @var{proc}'s third argument the first time\n"
202 "@var{proc} is applied.\n"
203 "If @var{env} contains no bindings, this function simply returns\n"
205 "If @var{env} binds the symbol sym1 to the value val1, sym2 to\n"
206 "val2, and so on, then this procedure computes:\n"
214 "Each binding in @var{env} will be processed exactly once.\n"
215 "@code{environment-fold} makes no guarantees about the order in\n"
216 "which the bindings are processed.\n"
217 "Here is a function which, given an environment, constructs an\n"
218 "association list representing that environment's bindings,\n"
219 "using environment-fold:\n"
221 " (define (environment->alist env)\n"
222 " (environment-fold env\n"
223 " (lambda (sym val tail)\n"
224 " (cons (cons sym val) tail))\n"
227 #define FUNC_NAME s_scm_environment_fold
229 SCM_ASSERT (SCM_ENVIRONMENT_P (env
), env
, SCM_ARG1
, FUNC_NAME
);
230 SCM_ASSERT (SCM_EQ_P (scm_procedure_p (proc
), SCM_BOOL_T
),
231 proc
, SCM_ARG2
, FUNC_NAME
);
233 return SCM_ENVIRONMENT_FOLD (env
, environment_default_folder
, proc
, init
);
238 /* This is the C-level analog of environment-fold. For each binding in ENV,
240 * (*proc) (data, symbol, value, previous)
241 * where previous is the value returned from the last call to *PROC, or INIT
242 * for the first call. If ENV contains no bindings, return INIT.
245 scm_c_environment_fold (SCM env
, scm_environment_folder proc
, SCM data
, SCM init
)
247 SCM_ASSERT (SCM_ENVIRONMENT_P (env
), env
, SCM_ARG1
, "scm_c_environment_fold");
249 return SCM_ENVIRONMENT_FOLD (env
, proc
, data
, init
);
253 SCM_DEFINE (scm_environment_define
, "environment-define", 3, 0, 0,
254 (SCM env
, SCM sym
, SCM val
),
255 "Bind @var{sym} to a new location containing @var{val} in\n"
256 "@var{env}. If @var{sym} is already bound to another location\n"
257 "in @var{env} and the binding is mutable, that binding is\n"
258 "replaced. The new binding and location are both mutable. The\n"
259 "return value is unspecified.\n"
260 "If @var{sym} is already bound in @var{env}, and the binding is\n"
261 "immutable, signal an @code{environment:immutable-binding} error.")
262 #define FUNC_NAME s_scm_environment_define
266 SCM_ASSERT (SCM_ENVIRONMENT_P (env
), env
, SCM_ARG1
, FUNC_NAME
);
267 SCM_ASSERT (SCM_SYMBOLP (sym
), sym
, SCM_ARG2
, FUNC_NAME
);
269 status
= SCM_ENVIRONMENT_DEFINE (env
, sym
, val
);
271 if (SCM_EQ_P (status
, SCM_ENVIRONMENT_SUCCESS
))
272 return SCM_UNSPECIFIED
;
273 else if (SCM_EQ_P (status
, SCM_ENVIRONMENT_BINDING_IMMUTABLE
))
274 scm_error_environment_immutable_binding (FUNC_NAME
, env
, sym
);
281 SCM_DEFINE (scm_environment_undefine
, "environment-undefine", 2, 0, 0,
283 "Remove any binding for @var{sym} from @var{env}. If @var{sym}\n"
284 "is unbound in @var{env}, do nothing. The return value is\n"
286 "If @var{sym} is already bound in @var{env}, and the binding is\n"
287 "immutable, signal an @code{environment:immutable-binding} error.")
288 #define FUNC_NAME s_scm_environment_undefine
292 SCM_ASSERT(SCM_ENVIRONMENT_P(env
), env
, SCM_ARG1
, FUNC_NAME
);
293 SCM_ASSERT(SCM_SYMBOLP(sym
), sym
, SCM_ARG2
, FUNC_NAME
);
295 status
= SCM_ENVIRONMENT_UNDEFINE (env
, sym
);
297 if (SCM_EQ_P (status
, SCM_ENVIRONMENT_SUCCESS
))
298 return SCM_UNSPECIFIED
;
299 else if (SCM_EQ_P (status
, SCM_ENVIRONMENT_BINDING_IMMUTABLE
))
300 scm_error_environment_immutable_binding (FUNC_NAME
, env
, sym
);
307 SCM_DEFINE (scm_environment_set_x
, "environment-set!", 3, 0, 0,
308 (SCM env
, SCM sym
, SCM val
),
309 "If @var{env} binds @var{sym} to some location, change that\n"
310 "location's value to @var{val}. The return value is\n"
312 "If @var{sym} is not bound in @var{env}, signal an\n"
313 "@code{environment:unbound} error. If @var{env} binds @var{sym}\n"
314 "to an immutable location, signal an\n"
315 "@code{environment:immutable-location} error.")
316 #define FUNC_NAME s_scm_environment_set_x
320 SCM_ASSERT (SCM_ENVIRONMENT_P (env
), env
, SCM_ARG1
, FUNC_NAME
);
321 SCM_ASSERT (SCM_SYMBOLP (sym
), sym
, SCM_ARG2
, FUNC_NAME
);
323 status
= SCM_ENVIRONMENT_SET (env
, sym
, val
);
325 if (SCM_EQ_P (status
, SCM_ENVIRONMENT_SUCCESS
))
326 return SCM_UNSPECIFIED
;
327 else if (SCM_UNBNDP (status
))
328 scm_error_environment_unbound (FUNC_NAME
, env
, sym
);
329 else if (SCM_EQ_P (status
, SCM_ENVIRONMENT_LOCATION_IMMUTABLE
))
330 scm_error_environment_immutable_binding (FUNC_NAME
, env
, sym
);
337 SCM_DEFINE (scm_environment_cell
, "environment-cell", 3, 0, 0,
338 (SCM env
, SCM sym
, SCM for_write
),
339 "Return the value cell which @var{env} binds to @var{sym}, or\n"
340 "@code{#f} if the binding does not live in a value cell.\n"
341 "The argument @var{for-write} indicates whether the caller\n"
342 "intends to modify the variable's value by mutating the value\n"
343 "cell. If the variable is immutable, then\n"
344 "@code{environment-cell} signals an\n"
345 "@code{environment:immutable-location} error.\n"
346 "If @var{sym} is unbound in @var{env}, signal an\n"
347 "@code{environment:unbound} error.\n"
348 "If you use this function, you should consider using\n"
349 "@code{environment-observe}, to be notified when @var{sym} gets\n"
350 "re-bound to a new value cell, or becomes undefined.")
351 #define FUNC_NAME s_scm_environment_cell
355 SCM_ASSERT (SCM_ENVIRONMENT_P (env
), env
, SCM_ARG1
, FUNC_NAME
);
356 SCM_ASSERT (SCM_SYMBOLP (sym
), sym
, SCM_ARG2
, FUNC_NAME
);
357 SCM_ASSERT (SCM_BOOLP (for_write
), for_write
, SCM_ARG3
, FUNC_NAME
);
359 location
= SCM_ENVIRONMENT_CELL (env
, sym
, !SCM_FALSEP (for_write
));
360 if (!SCM_IMP (location
))
362 else if (SCM_UNBNDP (location
))
363 scm_error_environment_unbound (FUNC_NAME
, env
, sym
);
364 else if (SCM_EQ_P (location
, SCM_ENVIRONMENT_LOCATION_IMMUTABLE
))
365 scm_error_environment_immutable_location (FUNC_NAME
, env
, sym
);
372 /* This C function is identical to environment-cell, with the following
373 * exceptions: If symbol is unbound in env, it returns the value
374 * SCM_UNDEFINED, instead of signalling an error. If symbol is bound to an
375 * immutable location but the cell is requested for write, the value
376 * SCM_ENVIRONMENT_LOCATION_IMMUTABLE is returned.
379 scm_c_environment_cell(SCM env
, SCM sym
, int for_write
)
381 SCM_ASSERT (SCM_ENVIRONMENT_P (env
), env
, SCM_ARG1
, "scm_c_environment_cell");
382 SCM_ASSERT (SCM_SYMBOLP (sym
), sym
, SCM_ARG2
, "scm_c_environment_cell");
384 return SCM_ENVIRONMENT_CELL (env
, sym
, for_write
);
389 environment_default_observer (SCM env
, SCM proc
)
391 gh_call1 (proc
, env
);
395 SCM_DEFINE (scm_environment_observe
, "environment-observe", 2, 0, 0,
397 "Whenever @var{env}'s bindings change, apply @var{proc} to\n"
399 "This function returns an object, token, which you can pass to\n"
400 "@code{environment-unobserve} to remove @var{proc} from the set\n"
401 "of procedures observing @var{env}. The type and value of\n"
402 "token is unspecified.")
403 #define FUNC_NAME s_scm_environment_observe
405 SCM_ASSERT (SCM_ENVIRONMENT_P (env
), env
, SCM_ARG1
, FUNC_NAME
);
407 return SCM_ENVIRONMENT_OBSERVE (env
, environment_default_observer
, proc
, 0);
412 SCM_DEFINE (scm_environment_observe_weak
, "environment-observe-weak", 2, 0, 0,
414 "This function is the same as environment-observe, except that\n"
415 "the reference @var{env} retains to @var{proc} is a weak\n"
416 "reference. This means that, if there are no other live,\n"
417 "non-weak references to @var{proc}, it will be\n"
418 "garbage-collected, and dropped from @var{env}'s\n"
419 "list of observing procedures.")
420 #define FUNC_NAME s_scm_environment_observe_weak
422 SCM_ASSERT (SCM_ENVIRONMENT_P (env
), env
, SCM_ARG1
, FUNC_NAME
);
424 return SCM_ENVIRONMENT_OBSERVE (env
, environment_default_observer
, proc
, 1);
429 /* This is the C-level analog of the Scheme functions environment-observe and
430 * environment-observe-weak. Whenever env's bindings change, call the
431 * function proc, passing it env and data. If weak_p is non-zero, env will
432 * retain only a weak reference to data, and if data is garbage collected, the
433 * entire observation will be dropped. This function returns a token, with
434 * the same meaning as those returned by environment-observe and
435 * environment-observe-weak.
438 scm_c_environment_observe (SCM env
, scm_environment_observer proc
, SCM data
, int weak_p
)
439 #define FUNC_NAME "scm_c_environment_observe"
441 SCM_ASSERT (SCM_ENVIRONMENT_P (env
), env
, SCM_ARG1
, FUNC_NAME
);
443 return SCM_ENVIRONMENT_OBSERVE (env
, proc
, data
, weak_p
);
448 SCM_DEFINE (scm_environment_unobserve
, "environment-unobserve", 1, 0, 0,
450 "Cancel the observation request which returned the value\n"
451 "@var{token}. The return value is unspecified.\n"
452 "If a call @code{(environment-observe env proc)} returns\n"
453 "@var{token}, then the call @code{(environment-unobserve token)}\n"
454 "will cause @var{proc} to no longer be called when @var{env}'s\n"
456 #define FUNC_NAME s_scm_environment_unobserve
460 SCM_ASSERT (SCM_OBSERVER_P (token
), token
, SCM_ARG1
, FUNC_NAME
);
462 env
= SCM_OBSERVER_ENVIRONMENT (token
);
463 SCM_ENVIRONMENT_UNOBSERVE (env
, token
);
465 return SCM_UNSPECIFIED
;
471 environment_mark (SCM env
)
473 return (*(SCM_ENVIRONMENT_FUNCS (env
)->mark
)) (env
);
478 environment_free (SCM env
)
480 (*(SCM_ENVIRONMENT_FUNCS (env
)->free
)) (env
);
486 environment_print (SCM env
, SCM port
, scm_print_state
*pstate
)
488 return (*(SCM_ENVIRONMENT_FUNCS (env
)->print
)) (env
, port
, pstate
);
496 observer_mark (SCM observer
)
498 scm_gc_mark (SCM_OBSERVER_ENVIRONMENT (observer
));
499 scm_gc_mark (SCM_OBSERVER_DATA (observer
));
505 observer_print (SCM type
, SCM port
, scm_print_state
*pstate SCM_UNUSED
)
507 SCM address
= scm_ulong2num (SCM_UNPACK (type
));
508 SCM base16
= scm_number_to_string (address
, SCM_MAKINUM (16));
510 scm_puts ("#<observer ", port
);
511 scm_puts (SCM_STRING_CHARS (base16
), port
);
512 scm_puts (">", port
);
521 * Obarrays form the basic lookup tables used to implement most of guile's
522 * built-in environment types. An obarray is implemented as a hash table with
523 * symbols as keys. The content of the data depends on the environment type.
528 * Enter symbol into obarray. The symbol must not already exist in obarray.
529 * The freshly generated (symbol . data) cell is returned.
532 obarray_enter (SCM obarray
, SCM symbol
, SCM data
)
534 size_t hash
= SCM_SYMBOL_HASH (symbol
) % SCM_VECTOR_LENGTH (obarray
);
535 SCM entry
= scm_cons (symbol
, data
);
536 SCM slot
= scm_cons (entry
, SCM_VELTS (obarray
)[hash
]);
537 SCM_VECTOR_SET (obarray
, hash
, slot
);
544 * Enter symbol into obarray. An existing entry for symbol is replaced. If
545 * an entry existed, the old (symbol . data) cell is returned, #f otherwise.
548 obarray_replace (SCM obarray
, SCM symbol
, SCM data
)
550 size_t hash
= SCM_SYMBOL_HASH (symbol
) % SCM_VECTOR_LENGTH (obarray
);
551 SCM new_entry
= scm_cons (symbol
, data
);
555 for (lsym
= SCM_VELTS (obarray
)[hash
]; !SCM_NULLP (lsym
); lsym
= SCM_CDR (lsym
))
557 SCM old_entry
= SCM_CAR (lsym
);
558 if (SCM_EQ_P (SCM_CAR (old_entry
), symbol
))
560 SCM_SETCAR (lsym
, new_entry
);
565 slot
= scm_cons (new_entry
, SCM_VELTS (obarray
)[hash
]);
566 SCM_VECTOR_SET (obarray
, hash
, slot
);
573 * Look up symbol in obarray
576 obarray_retrieve (SCM obarray
, SCM sym
)
578 size_t hash
= SCM_SYMBOL_HASH (sym
) % SCM_VECTOR_LENGTH (obarray
);
581 for (lsym
= SCM_VELTS (obarray
)[hash
]; !SCM_NULLP (lsym
); lsym
= SCM_CDR (lsym
))
583 SCM entry
= SCM_CAR (lsym
);
584 if (SCM_EQ_P (SCM_CAR (entry
), sym
))
588 return SCM_UNDEFINED
;
593 * Remove entry from obarray. If the symbol was found and removed, the old
594 * (symbol . data) cell is returned, #f otherwise.
597 obarray_remove (SCM obarray
, SCM sym
)
599 size_t hash
= SCM_SYMBOL_HASH (sym
) % SCM_VECTOR_LENGTH (obarray
);
600 SCM table_entry
= SCM_VELTS (obarray
)[hash
];
601 SCM handle
= scm_sloppy_assq (sym
, table_entry
);
603 if (SCM_CONSP (handle
))
605 SCM new_table_entry
= scm_delq1_x (handle
, table_entry
);
606 SCM_VECTOR_SET (obarray
, hash
, new_table_entry
);
614 obarray_remove_all (SCM obarray
)
616 size_t size
= SCM_VECTOR_LENGTH (obarray
);
619 for (i
= 0; i
< size
; i
++)
621 SCM_VECTOR_SET (obarray
, i
, SCM_EOL
);
627 /* core environments base
629 * This struct and the corresponding functions form a base class for guile's
630 * built-in environment types.
634 struct core_environments_base
{
635 struct scm_environment_funcs
*funcs
;
642 #define CORE_ENVIRONMENTS_BASE(env) \
643 ((struct core_environments_base *) SCM_CELL_WORD_1 (env))
644 #define CORE_ENVIRONMENT_OBSERVERS(env) \
645 (CORE_ENVIRONMENTS_BASE (env)->observers)
646 #define SCM_SET_CORE_ENVIRONMENT_OBSERVERS(env, v) \
647 (CORE_ENVIRONMENT_OBSERVERS (env) = (v))
648 #define CORE_ENVIRONMENT_WEAK_OBSERVER_VECTOR(env) \
649 (CORE_ENVIRONMENTS_BASE (env)->weak_observers)
650 #define CORE_ENVIRONMENT_WEAK_OBSERVERS(env) \
651 (SCM_VELTS (CORE_ENVIRONMENT_WEAK_OBSERVER_VECTOR (env)) [0])
652 #define SCM_SET_CORE_ENVIRONMENT_WEAK_OBSERVERS(env, v) \
653 (SCM_VECTOR_SET (CORE_ENVIRONMENT_WEAK_OBSERVER_VECTOR (env), 0, (v)))
658 core_environments_observe (SCM env
, scm_environment_observer proc
, SCM data
, int weak_p
)
660 SCM observer
= scm_double_cell (scm_tc16_observer
,
667 SCM observers
= CORE_ENVIRONMENT_OBSERVERS (env
);
668 SCM new_observers
= scm_cons (observer
, observers
);
669 SCM_SET_CORE_ENVIRONMENT_OBSERVERS (env
, new_observers
);
673 SCM observers
= CORE_ENVIRONMENT_WEAK_OBSERVERS (env
);
674 SCM new_observers
= scm_acons (SCM_BOOL_F
, observer
, observers
);
675 SCM_SET_CORE_ENVIRONMENT_WEAK_OBSERVERS (env
, new_observers
);
683 core_environments_unobserve (SCM env
, SCM observer
)
685 unsigned int handling_weaks
;
686 for (handling_weaks
= 0; handling_weaks
<= 1; ++handling_weaks
)
688 SCM l
= handling_weaks
689 ? CORE_ENVIRONMENT_WEAK_OBSERVERS (env
)
690 : CORE_ENVIRONMENT_OBSERVERS (env
);
694 SCM rest
= SCM_CDR (l
);
695 SCM first
= handling_weaks
699 if (SCM_EQ_P (first
, observer
))
701 /* Remove the first observer */
703 ? SCM_SET_CORE_ENVIRONMENT_WEAK_OBSERVERS (env
, rest
)
704 : SCM_SET_CORE_ENVIRONMENT_OBSERVERS (env
, rest
);
709 SCM rest
= SCM_CDR (l
);
711 if (!SCM_NULLP (rest
))
713 SCM next
= handling_weaks
717 if (SCM_EQ_P (next
, observer
))
719 SCM_SETCDR (l
, SCM_CDR (rest
));
725 } while (!SCM_NULLP (l
));
729 /* Dirk:FIXME:: What to do now, since the observer is not found? */
734 core_environments_mark (SCM env
)
736 scm_gc_mark (CORE_ENVIRONMENT_OBSERVERS (env
));
737 return CORE_ENVIRONMENT_WEAK_OBSERVER_VECTOR (env
);
742 core_environments_finalize (SCM env SCM_UNUSED
)
748 core_environments_preinit (struct core_environments_base
*body
)
751 body
->observers
= SCM_BOOL_F
;
752 body
->weak_observers
= SCM_BOOL_F
;
757 core_environments_init (struct core_environments_base
*body
,
758 struct scm_environment_funcs
*funcs
)
761 body
->observers
= SCM_EOL
;
762 body
->weak_observers
= scm_make_weak_value_hash_table (SCM_MAKINUM (1));
766 /* Tell all observers to clear their caches.
768 * Environments have to be informed about changes in the following cases:
769 * - The observed env has a new binding. This must be always reported.
770 * - The observed env has dropped a binding. This must be always reported.
771 * - A binding in the observed environment has changed. This must only be
772 * reported, if there is a chance that the binding is being cached outside.
773 * However, this potential optimization is not performed currently.
775 * Errors that occur while the observers are called are accumulated and
776 * signalled as one single error message to the caller.
787 update_catch_body (void *ptr
)
789 struct update_data
*data
= (struct update_data
*) ptr
;
790 SCM observer
= data
->observer
;
792 (*SCM_OBSERVER_PROC (observer
))
793 (data
->environment
, SCM_OBSERVER_DATA (observer
));
795 return SCM_UNDEFINED
;
800 update_catch_handler (void *ptr
, SCM tag
, SCM args
)
802 struct update_data
*data
= (struct update_data
*) ptr
;
803 SCM observer
= data
->observer
;
804 SCM message
= scm_makfrom0str ("Observer `~A' signals `~A' error: ~S");
806 return scm_cons (message
, scm_list_3 (observer
, tag
, args
));
811 core_environments_broadcast (SCM env
)
812 #define FUNC_NAME "core_environments_broadcast"
814 unsigned int handling_weaks
;
815 SCM errors
= SCM_EOL
;
817 for (handling_weaks
= 0; handling_weaks
<= 1; ++handling_weaks
)
819 SCM observers
= handling_weaks
820 ? CORE_ENVIRONMENT_WEAK_OBSERVERS (env
)
821 : CORE_ENVIRONMENT_OBSERVERS (env
);
823 for (; !SCM_NULLP (observers
); observers
= SCM_CDR (observers
))
825 struct update_data data
;
826 SCM observer
= handling_weaks
827 ? SCM_CDAR (observers
)
828 : SCM_CAR (observers
);
831 data
.observer
= observer
;
832 data
.environment
= env
;
834 error
= scm_internal_catch (SCM_BOOL_T
,
835 update_catch_body
, &data
,
836 update_catch_handler
, &data
);
838 if (!SCM_UNBNDP (error
))
839 errors
= scm_cons (error
, errors
);
843 if (!SCM_NULLP (errors
))
845 /* Dirk:FIXME:: As soon as scm_misc_error is fixed to handle the name
846 * parameter correctly it should not be necessary any more to also pass
847 * namestr in order to get the desired information from the error
850 SCM ordered_errors
= scm_reverse (errors
);
853 "Observers of `~A' have signalled the following errors: ~S",
854 scm_cons2 (env
, ordered_errors
, SCM_EOL
));
863 * A leaf environment is simply a mutable set of definitions. A leaf
864 * environment supports no operations beyond the common set.
866 * Implementation: The obarray of the leaf environment holds (symbol . value)
867 * pairs. No further information is necessary, since all bindings and
868 * locations in a leaf environment are mutable.
872 struct leaf_environment
{
873 struct core_environments_base base
;
879 #define LEAF_ENVIRONMENT(env) \
880 ((struct leaf_environment *) SCM_CELL_WORD_1 (env))
885 leaf_environment_ref (SCM env
, SCM sym
)
887 SCM obarray
= LEAF_ENVIRONMENT (env
)->obarray
;
888 SCM binding
= obarray_retrieve (obarray
, sym
);
889 return SCM_UNBNDP (binding
) ? binding
: SCM_CDR (binding
);
894 leaf_environment_fold (SCM env
, scm_environment_folder proc
, SCM data
, SCM init
)
898 SCM obarray
= LEAF_ENVIRONMENT (env
)->obarray
;
900 for (i
= 0; i
< SCM_VECTOR_LENGTH (obarray
); i
++)
903 for (l
= SCM_VELTS (obarray
)[i
]; !SCM_NULLP (l
); l
= SCM_CDR (l
))
905 SCM binding
= SCM_CAR (l
);
906 SCM symbol
= SCM_CAR (binding
);
907 SCM value
= SCM_CDR (binding
);
908 result
= (*proc
) (data
, symbol
, value
, result
);
916 leaf_environment_define (SCM env
, SCM sym
, SCM val
)
917 #define FUNC_NAME "leaf_environment_define"
919 SCM obarray
= LEAF_ENVIRONMENT (env
)->obarray
;
921 obarray_replace (obarray
, sym
, val
);
922 core_environments_broadcast (env
);
924 return SCM_ENVIRONMENT_SUCCESS
;
930 leaf_environment_undefine (SCM env
, SCM sym
)
931 #define FUNC_NAME "leaf_environment_undefine"
933 SCM obarray
= LEAF_ENVIRONMENT (env
)->obarray
;
934 SCM removed
= obarray_remove (obarray
, sym
);
936 if (!SCM_FALSEP (removed
))
937 core_environments_broadcast (env
);
939 return SCM_ENVIRONMENT_SUCCESS
;
945 leaf_environment_set_x (SCM env
, SCM sym
, SCM val
)
946 #define FUNC_NAME "leaf_environment_set_x"
948 SCM obarray
= LEAF_ENVIRONMENT (env
)->obarray
;
949 SCM binding
= obarray_retrieve (obarray
, sym
);
951 if (!SCM_UNBNDP (binding
))
953 SCM_SETCDR (binding
, val
);
954 return SCM_ENVIRONMENT_SUCCESS
;
958 return SCM_UNDEFINED
;
965 leaf_environment_cell (SCM env
, SCM sym
, int for_write SCM_UNUSED
)
967 SCM obarray
= LEAF_ENVIRONMENT (env
)->obarray
;
968 SCM binding
= obarray_retrieve (obarray
, sym
);
974 leaf_environment_mark (SCM env
)
976 scm_gc_mark (LEAF_ENVIRONMENT (env
)->obarray
);
977 return core_environments_mark (env
);
982 leaf_environment_free (SCM env
)
984 core_environments_finalize (env
);
985 scm_gc_free (LEAF_ENVIRONMENT (env
), sizeof (struct leaf_environment
),
991 leaf_environment_print (SCM type
, SCM port
, scm_print_state
*pstate SCM_UNUSED
)
993 SCM address
= scm_ulong2num (SCM_UNPACK (type
));
994 SCM base16
= scm_number_to_string (address
, SCM_MAKINUM (16));
996 scm_puts ("#<leaf environment ", port
);
997 scm_puts (SCM_STRING_CHARS (base16
), port
);
998 scm_puts (">", port
);
1004 static struct scm_environment_funcs leaf_environment_funcs
= {
1005 leaf_environment_ref
,
1006 leaf_environment_fold
,
1007 leaf_environment_define
,
1008 leaf_environment_undefine
,
1009 leaf_environment_set_x
,
1010 leaf_environment_cell
,
1011 core_environments_observe
,
1012 core_environments_unobserve
,
1013 leaf_environment_mark
,
1014 leaf_environment_free
,
1015 leaf_environment_print
1019 void *scm_type_leaf_environment
= &leaf_environment_funcs
;
1022 SCM_DEFINE (scm_make_leaf_environment
, "make-leaf-environment", 0, 0, 0,
1024 "Create a new leaf environment, containing no bindings.\n"
1025 "All bindings and locations created in the new environment\n"
1027 #define FUNC_NAME s_scm_make_leaf_environment
1029 size_t size
= sizeof (struct leaf_environment
);
1030 struct leaf_environment
*body
= scm_gc_malloc (size
, "leaf environment");
1033 core_environments_preinit (&body
->base
);
1034 body
->obarray
= SCM_BOOL_F
;
1036 env
= scm_make_environment (body
);
1038 core_environments_init (&body
->base
, &leaf_environment_funcs
);
1039 body
->obarray
= scm_c_make_hash_table (DEFAULT_OBARRAY_SIZE
);
1046 SCM_DEFINE (scm_leaf_environment_p
, "leaf-environment?", 1, 0, 0,
1048 "Return @code{#t} if object is a leaf environment, or @code{#f}\n"
1050 #define FUNC_NAME s_scm_leaf_environment_p
1052 return SCM_BOOL (SCM_LEAF_ENVIRONMENT_P (object
));
1058 /* eval environments
1060 * A module's source code refers to definitions imported from other modules,
1061 * and definitions made within itself. An eval environment combines two
1062 * environments -- a local environment and an imported environment -- to
1063 * produce a new environment in which both sorts of references can be
1066 * Implementation: The obarray of the eval environment is used to cache
1067 * entries from the local and imported environments such that in most of the
1068 * cases only a single lookup is necessary. Since for neither the local nor
1069 * the imported environment it is known, what kind of environment they form,
1070 * the most general case is assumed. Therefore, entries in the obarray take
1071 * one of the following forms:
1073 * 1) (<symbol> location mutability . source-env), where mutability indicates
1074 * one of the following states: IMMUTABLE if the location is known to be
1075 * immutable, MUTABLE if the location is known to be mutable, UNKNOWN if
1076 * the location has only been requested for non modifying accesses.
1078 * 2) (symbol . source-env) if the symbol has a binding in the source-env, but
1079 * if the source-env can't provide a cell for the binding. Thus, for every
1080 * access, the source-env has to be contacted directly.
1084 struct eval_environment
{
1085 struct core_environments_base base
;
1090 SCM imported_observer
;
1096 #define EVAL_ENVIRONMENT(env) \
1097 ((struct eval_environment *) SCM_CELL_WORD_1 (env))
1099 #define IMMUTABLE SCM_MAKINUM (0)
1100 #define MUTABLE SCM_MAKINUM (1)
1101 #define UNKNOWN SCM_MAKINUM (2)
1103 #define CACHED_LOCATION(x) SCM_CAR (x)
1104 #define CACHED_MUTABILITY(x) SCM_CADR (x)
1105 #define SET_CACHED_MUTABILITY(x, v) SCM_SETCAR (SCM_CDR (x), (v))
1106 #define CACHED_SOURCE_ENVIRONMENT(x) SCM_CDDR (x)
1110 /* eval_environment_lookup will report one of the following distinct results:
1111 * a) (<object> . value) if a cell could be obtained.
1112 * b) <environment> if the environment has to be contacted directly.
1113 * c) IMMUTABLE if an immutable cell was requested for write.
1114 * d) SCM_UNDEFINED if there is no binding for the symbol.
1117 eval_environment_lookup (SCM env
, SCM sym
, int for_write
)
1119 SCM obarray
= EVAL_ENVIRONMENT (env
)->obarray
;
1120 SCM binding
= obarray_retrieve (obarray
, sym
);
1122 if (!SCM_UNBNDP (binding
))
1124 /* The obarray holds an entry for the symbol. */
1126 SCM entry
= SCM_CDR (binding
);
1128 if (SCM_CONSP (entry
))
1130 /* The entry in the obarray is a cached location. */
1132 SCM location
= CACHED_LOCATION (entry
);
1138 mutability
= CACHED_MUTABILITY (entry
);
1139 if (SCM_EQ_P (mutability
, MUTABLE
))
1142 if (SCM_EQ_P (mutability
, UNKNOWN
))
1144 SCM source_env
= CACHED_SOURCE_ENVIRONMENT (entry
);
1145 SCM location
= SCM_ENVIRONMENT_CELL (source_env
, sym
, 1);
1147 if (SCM_CONSP (location
))
1149 SET_CACHED_MUTABILITY (entry
, MUTABLE
);
1152 else /* IMMUTABLE */
1154 SET_CACHED_MUTABILITY (entry
, IMMUTABLE
);
1163 /* The obarray entry is an environment */
1170 /* There is no entry for the symbol in the obarray. This can either
1171 * mean that there has not been a request for the symbol yet, or that
1172 * the symbol is really undefined. We are looking for the symbol in
1173 * both the local and the imported environment. If we find a binding, a
1174 * cached entry is created.
1177 struct eval_environment
*body
= EVAL_ENVIRONMENT (env
);
1178 unsigned int handling_import
;
1180 for (handling_import
= 0; handling_import
<= 1; ++handling_import
)
1182 SCM source_env
= handling_import
? body
->imported
: body
->local
;
1183 SCM location
= SCM_ENVIRONMENT_CELL (source_env
, sym
, for_write
);
1185 if (!SCM_UNBNDP (location
))
1187 if (SCM_CONSP (location
))
1189 SCM mutability
= for_write
? MUTABLE
: UNKNOWN
;
1190 SCM entry
= scm_cons2 (location
, mutability
, source_env
);
1191 obarray_enter (obarray
, sym
, entry
);
1194 else if (SCM_EQ_P (location
, SCM_ENVIRONMENT_LOCATION_NO_CELL
))
1196 obarray_enter (obarray
, sym
, source_env
);
1206 return SCM_UNDEFINED
;
1212 eval_environment_ref (SCM env
, SCM sym
)
1213 #define FUNC_NAME "eval_environment_ref"
1215 SCM location
= eval_environment_lookup (env
, sym
, 0);
1217 if (SCM_CONSP (location
))
1218 return SCM_CDR (location
);
1219 else if (!SCM_UNBNDP (location
))
1220 return SCM_ENVIRONMENT_REF (location
, sym
);
1222 return SCM_UNDEFINED
;
1228 eval_environment_folder (SCM extended_data
, SCM symbol
, SCM value
, SCM tail
)
1230 SCM local
= SCM_CAR (extended_data
);
1232 if (!SCM_ENVIRONMENT_BOUND_P (local
, symbol
))
1234 SCM proc_as_nr
= SCM_CADR (extended_data
);
1235 unsigned long int proc_as_ul
= scm_num2ulong (proc_as_nr
, 0, NULL
);
1236 scm_environment_folder proc
= (scm_environment_folder
) proc_as_ul
;
1237 SCM data
= SCM_CDDR (extended_data
);
1239 return (*proc
) (data
, symbol
, value
, tail
);
1249 eval_environment_fold (SCM env
, scm_environment_folder proc
, SCM data
, SCM init
)
1251 SCM local
= EVAL_ENVIRONMENT (env
)->local
;
1252 SCM imported
= EVAL_ENVIRONMENT (env
)->imported
;
1253 SCM proc_as_nr
= scm_ulong2num ((unsigned long int) proc
);
1254 SCM extended_data
= scm_cons2 (local
, proc_as_nr
, data
);
1255 SCM tmp_result
= scm_c_environment_fold (imported
, eval_environment_folder
, extended_data
, init
);
1257 return scm_c_environment_fold (local
, proc
, data
, tmp_result
);
1262 eval_environment_define (SCM env
, SCM sym
, SCM val
)
1263 #define FUNC_NAME "eval_environment_define"
1265 SCM local
= EVAL_ENVIRONMENT (env
)->local
;
1266 return SCM_ENVIRONMENT_DEFINE (local
, sym
, val
);
1272 eval_environment_undefine (SCM env
, SCM sym
)
1273 #define FUNC_NAME "eval_environment_undefine"
1275 SCM local
= EVAL_ENVIRONMENT (env
)->local
;
1276 return SCM_ENVIRONMENT_UNDEFINE (local
, sym
);
1282 eval_environment_set_x (SCM env
, SCM sym
, SCM val
)
1283 #define FUNC_NAME "eval_environment_set_x"
1285 SCM location
= eval_environment_lookup (env
, sym
, 1);
1287 if (SCM_CONSP (location
))
1289 SCM_SETCDR (location
, val
);
1290 return SCM_ENVIRONMENT_SUCCESS
;
1292 else if (SCM_ENVIRONMENT_P (location
))
1294 return SCM_ENVIRONMENT_SET (location
, sym
, val
);
1296 else if (SCM_EQ_P (location
, IMMUTABLE
))
1298 return SCM_ENVIRONMENT_LOCATION_IMMUTABLE
;
1302 return SCM_UNDEFINED
;
1309 eval_environment_cell (SCM env
, SCM sym
, int for_write
)
1310 #define FUNC_NAME "eval_environment_cell"
1312 SCM location
= eval_environment_lookup (env
, sym
, for_write
);
1314 if (SCM_CONSP (location
))
1316 else if (SCM_ENVIRONMENT_P (location
))
1317 return SCM_ENVIRONMENT_LOCATION_NO_CELL
;
1318 else if (SCM_EQ_P (location
, IMMUTABLE
))
1319 return SCM_ENVIRONMENT_LOCATION_IMMUTABLE
;
1321 return SCM_UNDEFINED
;
1327 eval_environment_mark (SCM env
)
1329 struct eval_environment
*body
= EVAL_ENVIRONMENT (env
);
1331 scm_gc_mark (body
->obarray
);
1332 scm_gc_mark (body
->imported
);
1333 scm_gc_mark (body
->imported_observer
);
1334 scm_gc_mark (body
->local
);
1335 scm_gc_mark (body
->local_observer
);
1337 return core_environments_mark (env
);
1342 eval_environment_free (SCM env
)
1344 core_environments_finalize (env
);
1345 scm_gc_free (EVAL_ENVIRONMENT (env
), sizeof (struct eval_environment
),
1346 "eval environment");
1351 eval_environment_print (SCM type
, SCM port
, scm_print_state
*pstate SCM_UNUSED
)
1353 SCM address
= scm_ulong2num (SCM_UNPACK (type
));
1354 SCM base16
= scm_number_to_string (address
, SCM_MAKINUM (16));
1356 scm_puts ("#<eval environment ", port
);
1357 scm_puts (SCM_STRING_CHARS (base16
), port
);
1358 scm_puts (">", port
);
1364 static struct scm_environment_funcs eval_environment_funcs
= {
1365 eval_environment_ref
,
1366 eval_environment_fold
,
1367 eval_environment_define
,
1368 eval_environment_undefine
,
1369 eval_environment_set_x
,
1370 eval_environment_cell
,
1371 core_environments_observe
,
1372 core_environments_unobserve
,
1373 eval_environment_mark
,
1374 eval_environment_free
,
1375 eval_environment_print
1379 void *scm_type_eval_environment
= &eval_environment_funcs
;
1383 eval_environment_observer (SCM caller SCM_UNUSED
, SCM eval_env
)
1385 SCM obarray
= EVAL_ENVIRONMENT (eval_env
)->obarray
;
1387 obarray_remove_all (obarray
);
1388 core_environments_broadcast (eval_env
);
1392 SCM_DEFINE (scm_make_eval_environment
, "make-eval-environment", 2, 0, 0,
1393 (SCM local
, SCM imported
),
1394 "Return a new environment object eval whose bindings are the\n"
1395 "union of the bindings in the environments @var{local} and\n"
1396 "@var{imported}, with bindings from @var{local} taking\n"
1397 "precedence. Definitions made in eval are placed in @var{local}.\n"
1398 "Applying @code{environment-define} or\n"
1399 "@code{environment-undefine} to eval has the same effect as\n"
1400 "applying the procedure to @var{local}.\n"
1401 "Note that eval incorporates @var{local} and @var{imported} by\n"
1403 "If, after creating eval, the program changes the bindings of\n"
1404 "@var{local} or @var{imported}, those changes will be visible\n"
1406 "Since most Scheme evaluation takes place in eval environments,\n"
1407 "they transparently cache the bindings received from @var{local}\n"
1408 "and @var{imported}. Thus, the first time the program looks up\n"
1409 "a symbol in eval, eval may make calls to @var{local} or\n"
1410 "@var{imported} to find their bindings, but subsequent\n"
1411 "references to that symbol will be as fast as references to\n"
1412 "bindings in finite environments.\n"
1413 "In typical use, @var{local} will be a finite environment, and\n"
1414 "@var{imported} will be an import environment")
1415 #define FUNC_NAME s_scm_make_eval_environment
1418 struct eval_environment
*body
;
1420 SCM_ASSERT (SCM_ENVIRONMENT_P (local
), local
, SCM_ARG1
, FUNC_NAME
);
1421 SCM_ASSERT (SCM_ENVIRONMENT_P (imported
), imported
, SCM_ARG2
, FUNC_NAME
);
1423 body
= scm_gc_malloc (sizeof (struct eval_environment
), "eval environment");
1425 core_environments_preinit (&body
->base
);
1426 body
->obarray
= SCM_BOOL_F
;
1427 body
->imported
= SCM_BOOL_F
;
1428 body
->imported_observer
= SCM_BOOL_F
;
1429 body
->local
= SCM_BOOL_F
;
1430 body
->local_observer
= SCM_BOOL_F
;
1432 env
= scm_make_environment (body
);
1434 core_environments_init (&body
->base
, &eval_environment_funcs
);
1435 body
->obarray
= scm_c_make_hash_table (DEFAULT_OBARRAY_SIZE
);
1436 body
->imported
= imported
;
1437 body
->imported_observer
1438 = SCM_ENVIRONMENT_OBSERVE (imported
, eval_environment_observer
, env
, 1);
1439 body
->local
= local
;
1440 body
->local_observer
1441 = SCM_ENVIRONMENT_OBSERVE (local
, eval_environment_observer
, env
, 1);
1448 SCM_DEFINE (scm_eval_environment_p
, "eval-environment?", 1, 0, 0,
1450 "Return @code{#t} if object is an eval environment, or @code{#f}\n"
1452 #define FUNC_NAME s_scm_eval_environment_p
1454 return SCM_BOOL (SCM_EVAL_ENVIRONMENT_P (object
));
1459 SCM_DEFINE (scm_eval_environment_local
, "eval-environment-local", 1, 0, 0,
1461 "Return the local environment of eval environment @var{env}.")
1462 #define FUNC_NAME s_scm_eval_environment_local
1464 SCM_ASSERT (SCM_EVAL_ENVIRONMENT_P (env
), env
, SCM_ARG1
, FUNC_NAME
);
1466 return EVAL_ENVIRONMENT (env
)->local
;
1471 SCM_DEFINE (scm_eval_environment_set_local_x
, "eval-environment-set-local!", 2, 0, 0,
1472 (SCM env
, SCM local
),
1473 "Change @var{env}'s local environment to @var{local}.")
1474 #define FUNC_NAME s_scm_eval_environment_set_local_x
1476 struct eval_environment
*body
;
1478 SCM_ASSERT (SCM_EVAL_ENVIRONMENT_P (env
), env
, SCM_ARG1
, FUNC_NAME
);
1479 SCM_ASSERT (SCM_ENVIRONMENT_P (local
), local
, SCM_ARG2
, FUNC_NAME
);
1481 body
= EVAL_ENVIRONMENT (env
);
1483 obarray_remove_all (body
->obarray
);
1484 SCM_ENVIRONMENT_UNOBSERVE (body
->local
, body
->local_observer
);
1486 body
->local
= local
;
1487 body
->local_observer
1488 = SCM_ENVIRONMENT_OBSERVE (local
, eval_environment_observer
, env
, 1);
1490 core_environments_broadcast (env
);
1492 return SCM_UNSPECIFIED
;
1497 SCM_DEFINE (scm_eval_environment_imported
, "eval-environment-imported", 1, 0, 0,
1499 "Return the imported environment of eval environment @var{env}.")
1500 #define FUNC_NAME s_scm_eval_environment_imported
1502 SCM_ASSERT (SCM_EVAL_ENVIRONMENT_P (env
), env
, SCM_ARG1
, FUNC_NAME
);
1504 return EVAL_ENVIRONMENT (env
)->imported
;
1509 SCM_DEFINE (scm_eval_environment_set_imported_x
, "eval-environment-set-imported!", 2, 0, 0,
1510 (SCM env
, SCM imported
),
1511 "Change @var{env}'s imported environment to @var{imported}.")
1512 #define FUNC_NAME s_scm_eval_environment_set_imported_x
1514 struct eval_environment
*body
;
1516 SCM_ASSERT (SCM_EVAL_ENVIRONMENT_P (env
), env
, SCM_ARG1
, FUNC_NAME
);
1517 SCM_ASSERT (SCM_ENVIRONMENT_P (imported
), imported
, SCM_ARG2
, FUNC_NAME
);
1519 body
= EVAL_ENVIRONMENT (env
);
1521 obarray_remove_all (body
->obarray
);
1522 SCM_ENVIRONMENT_UNOBSERVE (body
->imported
, body
->imported_observer
);
1524 body
->imported
= imported
;
1525 body
->imported_observer
1526 = SCM_ENVIRONMENT_OBSERVE (imported
, eval_environment_observer
, env
, 1);
1528 core_environments_broadcast (env
);
1530 return SCM_UNSPECIFIED
;
1536 /* import environments
1538 * An import environment combines the bindings of a set of argument
1539 * environments, and checks for naming clashes.
1541 * Implementation: The import environment does no caching at all. For every
1542 * access, the list of imported environments is scanned.
1546 struct import_environment
{
1547 struct core_environments_base base
;
1550 SCM import_observers
;
1556 #define IMPORT_ENVIRONMENT(env) \
1557 ((struct import_environment *) SCM_CELL_WORD_1 (env))
1561 /* Lookup will report one of the following distinct results:
1562 * a) <environment> if only environment binds the symbol.
1563 * b) (env-1 env-2 ...) for conflicting bindings in env-1, ...
1564 * c) SCM_UNDEFINED if there is no binding for the symbol.
1567 import_environment_lookup (SCM env
, SCM sym
)
1569 SCM imports
= IMPORT_ENVIRONMENT (env
)->imports
;
1570 SCM result
= SCM_UNDEFINED
;
1573 for (l
= imports
; !SCM_NULLP (l
); l
= SCM_CDR (l
))
1575 SCM imported
= SCM_CAR (l
);
1577 if (SCM_ENVIRONMENT_BOUND_P (imported
, sym
))
1579 if (SCM_UNBNDP (result
))
1581 else if (SCM_CONSP (result
))
1582 result
= scm_cons (imported
, result
);
1584 result
= scm_cons2 (imported
, result
, SCM_EOL
);
1588 if (SCM_CONSP (result
))
1589 return scm_reverse (result
);
1596 import_environment_conflict (SCM env
, SCM sym
, SCM imports
)
1598 SCM conflict_proc
= IMPORT_ENVIRONMENT (env
)->conflict_proc
;
1599 SCM args
= scm_cons2 (env
, sym
, scm_cons (imports
, SCM_EOL
));
1601 return scm_apply_0 (conflict_proc
, args
);
1606 import_environment_ref (SCM env
, SCM sym
)
1607 #define FUNC_NAME "import_environment_ref"
1609 SCM owner
= import_environment_lookup (env
, sym
);
1611 if (SCM_UNBNDP (owner
))
1613 return SCM_UNDEFINED
;
1615 else if (SCM_CONSP (owner
))
1617 SCM resolve
= import_environment_conflict (env
, sym
, owner
);
1619 if (SCM_ENVIRONMENT_P (resolve
))
1620 return SCM_ENVIRONMENT_REF (resolve
, sym
);
1622 return SCM_UNSPECIFIED
;
1626 return SCM_ENVIRONMENT_REF (owner
, sym
);
1633 import_environment_folder (SCM extended_data
, SCM symbol
, SCM value
, SCM tail
)
1634 #define FUNC_NAME "import_environment_fold"
1636 SCM import_env
= SCM_CAR (extended_data
);
1637 SCM imported_env
= SCM_CADR (extended_data
);
1638 SCM owner
= import_environment_lookup (import_env
, symbol
);
1639 SCM proc_as_nr
= SCM_CADDR (extended_data
);
1640 unsigned long int proc_as_ul
= scm_num2ulong (proc_as_nr
, 0, NULL
);
1641 scm_environment_folder proc
= (scm_environment_folder
) proc_as_ul
;
1642 SCM data
= SCM_CDDDR (extended_data
);
1644 if (SCM_CONSP (owner
) && SCM_EQ_P (SCM_CAR (owner
), imported_env
))
1645 owner
= import_environment_conflict (import_env
, symbol
, owner
);
1647 if (SCM_ENVIRONMENT_P (owner
))
1648 return (*proc
) (data
, symbol
, value
, tail
);
1649 else /* unresolved conflict */
1650 return (*proc
) (data
, symbol
, SCM_UNSPECIFIED
, tail
);
1656 import_environment_fold (SCM env
, scm_environment_folder proc
, SCM data
, SCM init
)
1658 SCM proc_as_nr
= scm_ulong2num ((unsigned long int) proc
);
1662 for (l
= IMPORT_ENVIRONMENT (env
)->imports
; !SCM_NULLP (l
); l
= SCM_CDR (l
))
1664 SCM imported_env
= SCM_CAR (l
);
1665 SCM extended_data
= scm_cons (env
, scm_cons2 (imported_env
, proc_as_nr
, data
));
1667 result
= scm_c_environment_fold (imported_env
, import_environment_folder
, extended_data
, result
);
1675 import_environment_define (SCM env SCM_UNUSED
,
1678 #define FUNC_NAME "import_environment_define"
1680 return SCM_ENVIRONMENT_BINDING_IMMUTABLE
;
1686 import_environment_undefine (SCM env SCM_UNUSED
,
1688 #define FUNC_NAME "import_environment_undefine"
1690 return SCM_ENVIRONMENT_BINDING_IMMUTABLE
;
1696 import_environment_set_x (SCM env
, SCM sym
, SCM val
)
1697 #define FUNC_NAME "import_environment_set_x"
1699 SCM owner
= import_environment_lookup (env
, sym
);
1701 if (SCM_UNBNDP (owner
))
1703 return SCM_UNDEFINED
;
1705 else if (SCM_CONSP (owner
))
1707 SCM resolve
= import_environment_conflict (env
, sym
, owner
);
1709 if (SCM_ENVIRONMENT_P (resolve
))
1710 return SCM_ENVIRONMENT_SET (resolve
, sym
, val
);
1712 return SCM_ENVIRONMENT_LOCATION_IMMUTABLE
;
1716 return SCM_ENVIRONMENT_SET (owner
, sym
, val
);
1723 import_environment_cell (SCM env
, SCM sym
, int for_write
)
1724 #define FUNC_NAME "import_environment_cell"
1726 SCM owner
= import_environment_lookup (env
, sym
);
1728 if (SCM_UNBNDP (owner
))
1730 return SCM_UNDEFINED
;
1732 else if (SCM_CONSP (owner
))
1734 SCM resolve
= import_environment_conflict (env
, sym
, owner
);
1736 if (SCM_ENVIRONMENT_P (resolve
))
1737 return SCM_ENVIRONMENT_CELL (resolve
, sym
, for_write
);
1739 return SCM_ENVIRONMENT_LOCATION_NO_CELL
;
1743 return SCM_ENVIRONMENT_CELL (owner
, sym
, for_write
);
1750 import_environment_mark (SCM env
)
1752 scm_gc_mark (IMPORT_ENVIRONMENT (env
)->imports
);
1753 scm_gc_mark (IMPORT_ENVIRONMENT (env
)->import_observers
);
1754 scm_gc_mark (IMPORT_ENVIRONMENT (env
)->conflict_proc
);
1755 return core_environments_mark (env
);
1760 import_environment_free (SCM env
)
1762 core_environments_finalize (env
);
1763 scm_gc_free (IMPORT_ENVIRONMENT (env
), sizeof (struct import_environment
),
1764 "import environment");
1769 import_environment_print (SCM type
, SCM port
,
1770 scm_print_state
*pstate SCM_UNUSED
)
1772 SCM address
= scm_ulong2num (SCM_UNPACK (type
));
1773 SCM base16
= scm_number_to_string (address
, SCM_MAKINUM (16));
1775 scm_puts ("#<import environment ", port
);
1776 scm_puts (SCM_STRING_CHARS (base16
), port
);
1777 scm_puts (">", port
);
1783 static struct scm_environment_funcs import_environment_funcs
= {
1784 import_environment_ref
,
1785 import_environment_fold
,
1786 import_environment_define
,
1787 import_environment_undefine
,
1788 import_environment_set_x
,
1789 import_environment_cell
,
1790 core_environments_observe
,
1791 core_environments_unobserve
,
1792 import_environment_mark
,
1793 import_environment_free
,
1794 import_environment_print
1798 void *scm_type_import_environment
= &import_environment_funcs
;
1802 import_environment_observer (SCM caller SCM_UNUSED
, SCM import_env
)
1804 core_environments_broadcast (import_env
);
1808 SCM_DEFINE (scm_make_import_environment
, "make-import-environment", 2, 0, 0,
1809 (SCM imports
, SCM conflict_proc
),
1810 "Return a new environment @var{imp} whose bindings are the union\n"
1811 "of the bindings from the environments in @var{imports};\n"
1812 "@var{imports} must be a list of environments. That is,\n"
1813 "@var{imp} binds a symbol to a location when some element of\n"
1814 "@var{imports} does.\n"
1815 "If two different elements of @var{imports} have a binding for\n"
1816 "the same symbol, the @var{conflict-proc} is called with the\n"
1817 "following parameters: the import environment, the symbol and\n"
1818 "the list of the imported environments that bind the symbol.\n"
1819 "If the @var{conflict-proc} returns an environment @var{env},\n"
1820 "the conflict is considered as resolved and the binding from\n"
1821 "@var{env} is used. If the @var{conflict-proc} returns some\n"
1822 "non-environment object, the conflict is considered unresolved\n"
1823 "and the symbol is treated as unspecified in the import\n"
1825 "The checking for conflicts may be performed lazily, i. e. at\n"
1826 "the moment when a value or binding for a certain symbol is\n"
1827 "requested instead of the moment when the environment is\n"
1828 "created or the bindings of the imports change.\n"
1829 "All bindings in @var{imp} are immutable. If you apply\n"
1830 "@code{environment-define} or @code{environment-undefine} to\n"
1831 "@var{imp}, Guile will signal an\n"
1832 " @code{environment:immutable-binding} error. However,\n"
1833 "notice that the set of bindings in @var{imp} may still change,\n"
1834 "if one of its imported environments changes.")
1835 #define FUNC_NAME s_scm_make_import_environment
1837 size_t size
= sizeof (struct import_environment
);
1838 struct import_environment
*body
= scm_gc_malloc (size
, "import environment");
1841 core_environments_preinit (&body
->base
);
1842 body
->imports
= SCM_BOOL_F
;
1843 body
->import_observers
= SCM_BOOL_F
;
1844 body
->conflict_proc
= SCM_BOOL_F
;
1846 env
= scm_make_environment (body
);
1848 core_environments_init (&body
->base
, &import_environment_funcs
);
1849 body
->imports
= SCM_EOL
;
1850 body
->import_observers
= SCM_EOL
;
1851 body
->conflict_proc
= conflict_proc
;
1853 scm_import_environment_set_imports_x (env
, imports
);
1860 SCM_DEFINE (scm_import_environment_p
, "import-environment?", 1, 0, 0,
1862 "Return @code{#t} if object is an import environment, or\n"
1863 "@code{#f} otherwise.")
1864 #define FUNC_NAME s_scm_import_environment_p
1866 return SCM_BOOL (SCM_IMPORT_ENVIRONMENT_P (object
));
1871 SCM_DEFINE (scm_import_environment_imports
, "import-environment-imports", 1, 0, 0,
1873 "Return the list of environments imported by the import\n"
1874 "environment @var{env}.")
1875 #define FUNC_NAME s_scm_import_environment_imports
1877 SCM_ASSERT (SCM_IMPORT_ENVIRONMENT_P (env
), env
, SCM_ARG1
, FUNC_NAME
);
1879 return IMPORT_ENVIRONMENT (env
)->imports
;
1884 SCM_DEFINE (scm_import_environment_set_imports_x
, "import-environment-set-imports!", 2, 0, 0,
1885 (SCM env
, SCM imports
),
1886 "Change @var{env}'s list of imported environments to\n"
1887 "@var{imports}, and check for conflicts.")
1888 #define FUNC_NAME s_scm_import_environment_set_imports_x
1890 struct import_environment
*body
= IMPORT_ENVIRONMENT (env
);
1891 SCM import_observers
= SCM_EOL
;
1894 SCM_ASSERT (SCM_IMPORT_ENVIRONMENT_P (env
), env
, SCM_ARG1
, FUNC_NAME
);
1895 for (l
= imports
; SCM_CONSP (l
); l
= SCM_CDR (l
))
1897 SCM obj
= SCM_CAR (l
);
1898 SCM_ASSERT (SCM_ENVIRONMENT_P (obj
), imports
, SCM_ARG2
, FUNC_NAME
);
1900 SCM_ASSERT (SCM_NULLP (l
), imports
, SCM_ARG2
, FUNC_NAME
);
1902 for (l
= body
->import_observers
; !SCM_NULLP (l
); l
= SCM_CDR (l
))
1904 SCM obs
= SCM_CAR (l
);
1905 SCM_ENVIRONMENT_UNOBSERVE (env
, obs
);
1908 for (l
= imports
; !SCM_NULLP (l
); l
= SCM_CDR (l
))
1910 SCM imp
= SCM_CAR (l
);
1911 SCM obs
= SCM_ENVIRONMENT_OBSERVE (imp
, import_environment_observer
, env
, 1);
1912 import_observers
= scm_cons (obs
, import_observers
);
1915 body
->imports
= imports
;
1916 body
->import_observers
= import_observers
;
1918 return SCM_UNSPECIFIED
;
1924 /* export environments
1926 * An export environment restricts an environment to a specified set of
1929 * Implementation: The export environment does no caching at all. For every
1930 * access, the signature is scanned. The signature that is stored internally
1931 * is an alist of pairs (symbol . (mutability)).
1935 struct export_environment
{
1936 struct core_environments_base base
;
1939 SCM private_observer
;
1945 #define EXPORT_ENVIRONMENT(env) \
1946 ((struct export_environment *) SCM_CELL_WORD_1 (env))
1949 SCM_SYMBOL (symbol_immutable_location
, "immutable-location");
1950 SCM_SYMBOL (symbol_mutable_location
, "mutable-location");
1955 export_environment_ref (SCM env
, SCM sym
)
1956 #define FUNC_NAME "export_environment_ref"
1958 struct export_environment
*body
= EXPORT_ENVIRONMENT (env
);
1959 SCM entry
= scm_assq (sym
, body
->signature
);
1961 if (SCM_FALSEP (entry
))
1962 return SCM_UNDEFINED
;
1964 return SCM_ENVIRONMENT_REF (body
->private, sym
);
1970 export_environment_fold (SCM env
, scm_environment_folder proc
, SCM data
, SCM init
)
1972 struct export_environment
*body
= EXPORT_ENVIRONMENT (env
);
1976 for (l
= body
->signature
; !SCM_NULLP (l
); l
= SCM_CDR (l
))
1978 SCM symbol
= SCM_CAR (l
);
1979 SCM value
= SCM_ENVIRONMENT_REF (body
->private, symbol
);
1980 if (!SCM_UNBNDP (value
))
1981 result
= (*proc
) (data
, symbol
, value
, result
);
1988 export_environment_define (SCM env SCM_UNUSED
,
1991 #define FUNC_NAME "export_environment_define"
1993 return SCM_ENVIRONMENT_BINDING_IMMUTABLE
;
1999 export_environment_undefine (SCM env SCM_UNUSED
, SCM sym SCM_UNUSED
)
2000 #define FUNC_NAME "export_environment_undefine"
2002 return SCM_ENVIRONMENT_BINDING_IMMUTABLE
;
2008 export_environment_set_x (SCM env
, SCM sym
, SCM val
)
2009 #define FUNC_NAME "export_environment_set_x"
2011 struct export_environment
*body
= EXPORT_ENVIRONMENT (env
);
2012 SCM entry
= scm_assq (sym
, body
->signature
);
2014 if (SCM_FALSEP (entry
))
2016 return SCM_UNDEFINED
;
2020 if (SCM_EQ_P (SCM_CADR (entry
), symbol_mutable_location
))
2021 return SCM_ENVIRONMENT_SET (body
->private, sym
, val
);
2023 return SCM_ENVIRONMENT_LOCATION_IMMUTABLE
;
2030 export_environment_cell (SCM env
, SCM sym
, int for_write
)
2031 #define FUNC_NAME "export_environment_cell"
2033 struct export_environment
*body
= EXPORT_ENVIRONMENT (env
);
2034 SCM entry
= scm_assq (sym
, body
->signature
);
2036 if (SCM_FALSEP (entry
))
2038 return SCM_UNDEFINED
;
2042 if (!for_write
|| SCM_EQ_P (SCM_CADR (entry
), symbol_mutable_location
))
2043 return SCM_ENVIRONMENT_CELL (body
->private, sym
, for_write
);
2045 return SCM_ENVIRONMENT_LOCATION_IMMUTABLE
;
2052 export_environment_mark (SCM env
)
2054 struct export_environment
*body
= EXPORT_ENVIRONMENT (env
);
2056 scm_gc_mark (body
->private);
2057 scm_gc_mark (body
->private_observer
);
2058 scm_gc_mark (body
->signature
);
2060 return core_environments_mark (env
);
2065 export_environment_free (SCM env
)
2067 core_environments_finalize (env
);
2068 scm_gc_free (EXPORT_ENVIRONMENT (env
), sizeof (struct export_environment
),
2069 "export environment");
2074 export_environment_print (SCM type
, SCM port
,
2075 scm_print_state
*pstate SCM_UNUSED
)
2077 SCM address
= scm_ulong2num (SCM_UNPACK (type
));
2078 SCM base16
= scm_number_to_string (address
, SCM_MAKINUM (16));
2080 scm_puts ("#<export environment ", port
);
2081 scm_puts (SCM_STRING_CHARS (base16
), port
);
2082 scm_puts (">", port
);
2088 static struct scm_environment_funcs export_environment_funcs
= {
2089 export_environment_ref
,
2090 export_environment_fold
,
2091 export_environment_define
,
2092 export_environment_undefine
,
2093 export_environment_set_x
,
2094 export_environment_cell
,
2095 core_environments_observe
,
2096 core_environments_unobserve
,
2097 export_environment_mark
,
2098 export_environment_free
,
2099 export_environment_print
2103 void *scm_type_export_environment
= &export_environment_funcs
;
2107 export_environment_observer (SCM caller SCM_UNUSED
, SCM export_env
)
2109 core_environments_broadcast (export_env
);
2113 SCM_DEFINE (scm_make_export_environment
, "make-export-environment", 2, 0, 0,
2114 (SCM
private, SCM signature
),
2115 "Return a new environment @var{exp} containing only those\n"
2116 "bindings in private whose symbols are present in\n"
2117 "@var{signature}. The @var{private} argument must be an\n"
2119 "The environment @var{exp} binds symbol to location when\n"
2120 "@var{env} does, and symbol is exported by @var{signature}.\n\n"
2121 "@var{signature} is a list specifying which of the bindings in\n"
2122 "@var{private} should be visible in @var{exp}. Each element of\n"
2123 "@var{signature} should be a list of the form:\n"
2124 " (symbol attribute ...)\n"
2125 "where each attribute is one of the following:\n"
2127 "@item the symbol @code{mutable-location}\n"
2128 " @var{exp} should treat the\n"
2129 " location bound to symbol as mutable. That is, @var{exp}\n"
2130 " will pass calls to @code{environment-set!} or\n"
2131 " @code{environment-cell} directly through to private.\n"
2132 "@item the symbol @code{immutable-location}\n"
2133 " @var{exp} should treat\n"
2134 " the location bound to symbol as immutable. If the program\n"
2135 " applies @code{environment-set!} to @var{exp} and symbol, or\n"
2136 " calls @code{environment-cell} to obtain a writable value\n"
2137 " cell, @code{environment-set!} will signal an\n"
2138 " @code{environment:immutable-location} error. Note that, even\n"
2139 " if an export environment treats a location as immutable, the\n"
2140 " underlying environment may treat it as mutable, so its\n"
2141 " value may change.\n"
2143 "It is an error for an element of signature to specify both\n"
2144 "@code{mutable-location} and @code{immutable-location}. If\n"
2145 "neither is specified, @code{immutable-location} is assumed.\n\n"
2146 "As a special case, if an element of signature is a lone\n"
2147 "symbol @var{sym}, it is equivalent to an element of the form\n"
2149 "All bindings in @var{exp} are immutable. If you apply\n"
2150 "@code{environment-define} or @code{environment-undefine} to\n"
2151 "@var{exp}, Guile will signal an\n"
2152 "@code{environment:immutable-binding} error. However,\n"
2153 "notice that the set of bindings in @var{exp} may still change,\n"
2154 "if the bindings in private change.")
2155 #define FUNC_NAME s_scm_make_export_environment
2158 struct export_environment
*body
;
2161 SCM_ASSERT (SCM_ENVIRONMENT_P (private), private, SCM_ARG1
, FUNC_NAME
);
2163 size
= sizeof (struct export_environment
);
2164 body
= scm_gc_malloc (size
, "export environment");
2166 core_environments_preinit (&body
->base
);
2167 body
->private = SCM_BOOL_F
;
2168 body
->private_observer
= SCM_BOOL_F
;
2169 body
->signature
= SCM_BOOL_F
;
2171 env
= scm_make_environment (body
);
2173 core_environments_init (&body
->base
, &export_environment_funcs
);
2174 body
->private = private;
2175 body
->private_observer
2176 = SCM_ENVIRONMENT_OBSERVE (private, export_environment_observer
, env
, 1);
2177 body
->signature
= SCM_EOL
;
2179 scm_export_environment_set_signature_x (env
, signature
);
2186 SCM_DEFINE (scm_export_environment_p
, "export-environment?", 1, 0, 0,
2188 "Return @code{#t} if object is an export environment, or\n"
2189 "@code{#f} otherwise.")
2190 #define FUNC_NAME s_scm_export_environment_p
2192 return SCM_BOOL (SCM_EXPORT_ENVIRONMENT_P (object
));
2197 SCM_DEFINE (scm_export_environment_private
, "export-environment-private", 1, 0, 0,
2199 "Return the private environment of export environment @var{env}.")
2200 #define FUNC_NAME s_scm_export_environment_private
2202 SCM_ASSERT (SCM_EXPORT_ENVIRONMENT_P (env
), env
, SCM_ARG1
, FUNC_NAME
);
2204 return EXPORT_ENVIRONMENT (env
)->private;
2209 SCM_DEFINE (scm_export_environment_set_private_x
, "export-environment-set-private!", 2, 0, 0,
2210 (SCM env
, SCM
private),
2211 "Change the private environment of export environment @var{env}.")
2212 #define FUNC_NAME s_scm_export_environment_set_private_x
2214 struct export_environment
*body
;
2216 SCM_ASSERT (SCM_EXPORT_ENVIRONMENT_P (env
), env
, SCM_ARG1
, FUNC_NAME
);
2217 SCM_ASSERT (SCM_ENVIRONMENT_P (private), private, SCM_ARG2
, FUNC_NAME
);
2219 body
= EXPORT_ENVIRONMENT (env
);
2220 SCM_ENVIRONMENT_UNOBSERVE (private, body
->private_observer
);
2222 body
->private = private;
2223 body
->private_observer
2224 = SCM_ENVIRONMENT_OBSERVE (private, export_environment_observer
, env
, 1);
2226 return SCM_UNSPECIFIED
;
2231 SCM_DEFINE (scm_export_environment_signature
, "export-environment-signature", 1, 0, 0,
2233 "Return the signature of export environment @var{env}.")
2234 #define FUNC_NAME s_scm_export_environment_signature
2236 SCM_ASSERT (SCM_EXPORT_ENVIRONMENT_P (env
), env
, SCM_ARG1
, FUNC_NAME
);
2238 return EXPORT_ENVIRONMENT (env
)->signature
;
2244 export_environment_parse_signature (SCM signature
, const char* caller
)
2246 SCM result
= SCM_EOL
;
2249 for (l
= signature
; SCM_CONSP (l
); l
= SCM_CDR (l
))
2251 SCM entry
= SCM_CAR (l
);
2253 if (SCM_SYMBOLP (entry
))
2255 SCM new_entry
= scm_cons2 (entry
, symbol_immutable_location
, SCM_EOL
);
2256 result
= scm_cons (new_entry
, result
);
2267 SCM_ASSERT (SCM_CONSP (entry
), entry
, SCM_ARGn
, caller
);
2268 SCM_ASSERT (SCM_SYMBOLP (SCM_CAR (entry
)), entry
, SCM_ARGn
, caller
);
2270 sym
= SCM_CAR (entry
);
2272 for (l2
= SCM_CDR (entry
); SCM_CONSP (l2
); l2
= SCM_CDR (l2
))
2274 SCM attribute
= SCM_CAR (l2
);
2275 if (SCM_EQ_P (attribute
, symbol_immutable_location
))
2277 else if (SCM_EQ_P (attribute
, symbol_mutable_location
))
2280 SCM_ASSERT (0, entry
, SCM_ARGn
, caller
);
2282 SCM_ASSERT (SCM_NULLP (l2
), entry
, SCM_ARGn
, caller
);
2283 SCM_ASSERT (!mutable || !immutable
, entry
, SCM_ARGn
, caller
);
2285 if (!mutable && !immutable
)
2288 mutability
= mutable ? symbol_mutable_location
: symbol_immutable_location
;
2289 new_entry
= scm_cons2 (sym
, mutability
, SCM_EOL
);
2290 result
= scm_cons (new_entry
, result
);
2293 SCM_ASSERT (SCM_NULLP (l
), signature
, SCM_ARGn
, caller
);
2295 /* Dirk:FIXME:: Now we know that signature is syntactically correct. There
2296 * are, however, no checks for symbols entered twice with contradicting
2297 * mutabilities. It would be nice, to implement this test, to be able to
2298 * call the sort functions conveniently from C.
2301 return scm_reverse (result
);
2305 SCM_DEFINE (scm_export_environment_set_signature_x
, "export-environment-set-signature!", 2, 0, 0,
2306 (SCM env
, SCM signature
),
2307 "Change the signature of export environment @var{env}.")
2308 #define FUNC_NAME s_scm_export_environment_set_signature_x
2312 SCM_ASSERT (SCM_EXPORT_ENVIRONMENT_P (env
), env
, SCM_ARG1
, FUNC_NAME
);
2313 parsed_sig
= export_environment_parse_signature (signature
, FUNC_NAME
);
2315 EXPORT_ENVIRONMENT (env
)->signature
= parsed_sig
;
2317 return SCM_UNSPECIFIED
;
2324 scm_environments_prehistory ()
2326 /* create environment smob */
2327 scm_tc16_environment
= scm_make_smob_type ("environment", 0);
2328 scm_set_smob_mark (scm_tc16_environment
, environment_mark
);
2329 scm_set_smob_free (scm_tc16_environment
, environment_free
);
2330 scm_set_smob_print (scm_tc16_environment
, environment_print
);
2332 /* create observer smob */
2333 scm_tc16_observer
= scm_make_smob_type ("observer", 0);
2334 scm_set_smob_mark (scm_tc16_observer
, observer_mark
);
2335 scm_set_smob_print (scm_tc16_observer
, observer_print
);
2337 /* create system environment */
2338 scm_system_environment
= scm_make_leaf_environment ();
2339 scm_permanent_object (scm_system_environment
);
2344 scm_init_environments ()
2346 #include "libguile/environments.x"