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
)
122 return scm_cell (scm_tc16_environment
, (scm_t_bits
) type
);
126 SCM_DEFINE (scm_environment_p
, "environment?", 1, 0, 0,
128 "Return @code{#t} if @var{obj} is an environment, or @code{#f}\n"
130 #define FUNC_NAME s_scm_environment_p
132 return SCM_BOOL (SCM_ENVIRONMENT_P (obj
));
137 SCM_DEFINE (scm_environment_bound_p
, "environment-bound?", 2, 0, 0,
139 "Return @code{#t} if @var{sym} is bound in @var{env}, or\n"
140 "@code{#f} otherwise.")
141 #define FUNC_NAME s_scm_environment_bound_p
143 SCM_ASSERT (SCM_ENVIRONMENT_P (env
), env
, SCM_ARG1
, FUNC_NAME
);
144 SCM_ASSERT (SCM_SYMBOLP (sym
), sym
, SCM_ARG2
, FUNC_NAME
);
146 return SCM_BOOL (SCM_ENVIRONMENT_BOUND_P (env
, sym
));
151 SCM_DEFINE (scm_environment_ref
, "environment-ref", 2, 0, 0,
153 "Return the value of the location bound to @var{sym} in\n"
154 "@var{env}. If @var{sym} is unbound in @var{env}, signal an\n"
155 "@code{environment:unbound} error.")
156 #define FUNC_NAME s_scm_environment_ref
160 SCM_ASSERT (SCM_ENVIRONMENT_P (env
), env
, SCM_ARG1
, FUNC_NAME
);
161 SCM_ASSERT (SCM_SYMBOLP (sym
), sym
, SCM_ARG2
, FUNC_NAME
);
163 val
= SCM_ENVIRONMENT_REF (env
, sym
);
165 if (!SCM_UNBNDP (val
))
168 scm_error_environment_unbound (FUNC_NAME
, env
, sym
);
173 /* This C function is identical to environment-ref, except that if symbol is
174 * unbound in env, it returns the value SCM_UNDEFINED, instead of signalling
178 scm_c_environment_ref (SCM env
, SCM sym
)
180 SCM_ASSERT (SCM_ENVIRONMENT_P (env
), env
, SCM_ARG1
, "scm_c_environment_ref");
181 SCM_ASSERT (SCM_SYMBOLP (sym
), sym
, SCM_ARG2
, "scm_c_environment_ref");
182 return SCM_ENVIRONMENT_REF (env
, sym
);
187 environment_default_folder (SCM proc
, SCM symbol
, SCM value
, SCM tail
)
189 return gh_call3 (proc
, symbol
, value
, tail
);
193 SCM_DEFINE (scm_environment_fold
, "environment-fold", 3, 0, 0,
194 (SCM env
, SCM proc
, SCM init
),
195 "Iterate over all the bindings in @var{env}, accumulating some\n"
197 "For each binding in @var{env}, apply @var{proc} to the symbol\n"
198 "bound, its value, and the result from the previous application\n"
200 "Use @var{init} as @var{proc}'s third argument the first time\n"
201 "@var{proc} is applied.\n"
202 "If @var{env} contains no bindings, this function simply returns\n"
204 "If @var{env} binds the symbol sym1 to the value val1, sym2 to\n"
205 "val2, and so on, then this procedure computes:\n"
213 "Each binding in @var{env} will be processed exactly once.\n"
214 "@code{environment-fold} makes no guarantees about the order in\n"
215 "which the bindings are processed.\n"
216 "Here is a function which, given an environment, constructs an\n"
217 "association list representing that environment's bindings,\n"
218 "using environment-fold:\n"
220 " (define (environment->alist env)\n"
221 " (environment-fold env\n"
222 " (lambda (sym val tail)\n"
223 " (cons (cons sym val) tail))\n"
226 #define FUNC_NAME s_scm_environment_fold
228 SCM_ASSERT (SCM_ENVIRONMENT_P (env
), env
, SCM_ARG1
, FUNC_NAME
);
229 SCM_ASSERT (SCM_EQ_P (scm_procedure_p (proc
), SCM_BOOL_T
),
230 proc
, SCM_ARG2
, FUNC_NAME
);
232 return SCM_ENVIRONMENT_FOLD (env
, environment_default_folder
, proc
, init
);
237 /* This is the C-level analog of environment-fold. For each binding in ENV,
239 * (*proc) (data, symbol, value, previous)
240 * where previous is the value returned from the last call to *PROC, or INIT
241 * for the first call. If ENV contains no bindings, return INIT.
244 scm_c_environment_fold (SCM env
, scm_environment_folder proc
, SCM data
, SCM init
)
246 SCM_ASSERT (SCM_ENVIRONMENT_P (env
), env
, SCM_ARG1
, "scm_c_environment_fold");
248 return SCM_ENVIRONMENT_FOLD (env
, proc
, data
, init
);
252 SCM_DEFINE (scm_environment_define
, "environment-define", 3, 0, 0,
253 (SCM env
, SCM sym
, SCM val
),
254 "Bind @var{sym} to a new location containing @var{val} in\n"
255 "@var{env}. If @var{sym} is already bound to another location\n"
256 "in @var{env} and the binding is mutable, that binding is\n"
257 "replaced. The new binding and location are both mutable. The\n"
258 "return value is unspecified.\n"
259 "If @var{sym} is already bound in @var{env}, and the binding is\n"
260 "immutable, signal an @code{environment:immutable-binding} error.")
261 #define FUNC_NAME s_scm_environment_define
265 SCM_ASSERT (SCM_ENVIRONMENT_P (env
), env
, SCM_ARG1
, FUNC_NAME
);
266 SCM_ASSERT (SCM_SYMBOLP (sym
), sym
, SCM_ARG2
, FUNC_NAME
);
268 status
= SCM_ENVIRONMENT_DEFINE (env
, sym
, val
);
270 if (SCM_EQ_P (status
, SCM_ENVIRONMENT_SUCCESS
))
271 return SCM_UNSPECIFIED
;
272 else if (SCM_EQ_P (status
, SCM_ENVIRONMENT_BINDING_IMMUTABLE
))
273 scm_error_environment_immutable_binding (FUNC_NAME
, env
, sym
);
280 SCM_DEFINE (scm_environment_undefine
, "environment-undefine", 2, 0, 0,
282 "Remove any binding for @var{sym} from @var{env}. If @var{sym}\n"
283 "is unbound in @var{env}, do nothing. The return value is\n"
285 "If @var{sym} is already bound in @var{env}, and the binding is\n"
286 "immutable, signal an @code{environment:immutable-binding} error.")
287 #define FUNC_NAME s_scm_environment_undefine
291 SCM_ASSERT(SCM_ENVIRONMENT_P(env
), env
, SCM_ARG1
, FUNC_NAME
);
292 SCM_ASSERT(SCM_SYMBOLP(sym
), sym
, SCM_ARG2
, FUNC_NAME
);
294 status
= SCM_ENVIRONMENT_UNDEFINE (env
, sym
);
296 if (SCM_EQ_P (status
, SCM_ENVIRONMENT_SUCCESS
))
297 return SCM_UNSPECIFIED
;
298 else if (SCM_EQ_P (status
, SCM_ENVIRONMENT_BINDING_IMMUTABLE
))
299 scm_error_environment_immutable_binding (FUNC_NAME
, env
, sym
);
306 SCM_DEFINE (scm_environment_set_x
, "environment-set!", 3, 0, 0,
307 (SCM env
, SCM sym
, SCM val
),
308 "If @var{env} binds @var{sym} to some location, change that\n"
309 "location's value to @var{val}. The return value is\n"
311 "If @var{sym} is not bound in @var{env}, signal an\n"
312 "@code{environment:unbound} error. If @var{env} binds @var{sym}\n"
313 "to an immutable location, signal an\n"
314 "@code{environment:immutable-location} error.")
315 #define FUNC_NAME s_scm_environment_set_x
319 SCM_ASSERT (SCM_ENVIRONMENT_P (env
), env
, SCM_ARG1
, FUNC_NAME
);
320 SCM_ASSERT (SCM_SYMBOLP (sym
), sym
, SCM_ARG2
, FUNC_NAME
);
322 status
= SCM_ENVIRONMENT_SET (env
, sym
, val
);
324 if (SCM_EQ_P (status
, SCM_ENVIRONMENT_SUCCESS
))
325 return SCM_UNSPECIFIED
;
326 else if (SCM_UNBNDP (status
))
327 scm_error_environment_unbound (FUNC_NAME
, env
, sym
);
328 else if (SCM_EQ_P (status
, SCM_ENVIRONMENT_LOCATION_IMMUTABLE
))
329 scm_error_environment_immutable_binding (FUNC_NAME
, env
, sym
);
336 SCM_DEFINE (scm_environment_cell
, "environment-cell", 3, 0, 0,
337 (SCM env
, SCM sym
, SCM for_write
),
338 "Return the value cell which @var{env} binds to @var{sym}, or\n"
339 "@code{#f} if the binding does not live in a value cell.\n"
340 "The argument @var{for-write} indicates whether the caller\n"
341 "intends to modify the variable's value by mutating the value\n"
342 "cell. If the variable is immutable, then\n"
343 "@code{environment-cell} signals an\n"
344 "@code{environment:immutable-location} error.\n"
345 "If @var{sym} is unbound in @var{env}, signal an\n"
346 "@code{environment:unbound} error.\n"
347 "If you use this function, you should consider using\n"
348 "@code{environment-observe}, to be notified when @var{sym} gets\n"
349 "re-bound to a new value cell, or becomes undefined.")
350 #define FUNC_NAME s_scm_environment_cell
354 SCM_ASSERT (SCM_ENVIRONMENT_P (env
), env
, SCM_ARG1
, FUNC_NAME
);
355 SCM_ASSERT (SCM_SYMBOLP (sym
), sym
, SCM_ARG2
, FUNC_NAME
);
356 SCM_ASSERT (SCM_BOOLP (for_write
), for_write
, SCM_ARG3
, FUNC_NAME
);
358 location
= SCM_ENVIRONMENT_CELL (env
, sym
, !SCM_FALSEP (for_write
));
359 if (!SCM_IMP (location
))
361 else if (SCM_UNBNDP (location
))
362 scm_error_environment_unbound (FUNC_NAME
, env
, sym
);
363 else if (SCM_EQ_P (location
, SCM_ENVIRONMENT_LOCATION_IMMUTABLE
))
364 scm_error_environment_immutable_location (FUNC_NAME
, env
, sym
);
371 /* This C function is identical to environment-cell, with the following
372 * exceptions: If symbol is unbound in env, it returns the value
373 * SCM_UNDEFINED, instead of signalling an error. If symbol is bound to an
374 * immutable location but the cell is requested for write, the value
375 * SCM_ENVIRONMENT_LOCATION_IMMUTABLE is returned.
378 scm_c_environment_cell(SCM env
, SCM sym
, int for_write
)
380 SCM_ASSERT (SCM_ENVIRONMENT_P (env
), env
, SCM_ARG1
, "scm_c_environment_cell");
381 SCM_ASSERT (SCM_SYMBOLP (sym
), sym
, SCM_ARG2
, "scm_c_environment_cell");
383 return SCM_ENVIRONMENT_CELL (env
, sym
, for_write
);
388 environment_default_observer (SCM env
, SCM proc
)
390 gh_call1 (proc
, env
);
394 SCM_DEFINE (scm_environment_observe
, "environment-observe", 2, 0, 0,
396 "Whenever @var{env}'s bindings change, apply @var{proc} to\n"
398 "This function returns an object, token, which you can pass to\n"
399 "@code{environment-unobserve} to remove @var{proc} from the set\n"
400 "of procedures observing @var{env}. The type and value of\n"
401 "token is unspecified.")
402 #define FUNC_NAME s_scm_environment_observe
404 SCM_ASSERT (SCM_ENVIRONMENT_P (env
), env
, SCM_ARG1
, FUNC_NAME
);
406 return SCM_ENVIRONMENT_OBSERVE (env
, environment_default_observer
, proc
, 0);
411 SCM_DEFINE (scm_environment_observe_weak
, "environment-observe-weak", 2, 0, 0,
413 "This function is the same as environment-observe, except that\n"
414 "the reference @var{env} retains to @var{proc} is a weak\n"
415 "reference. This means that, if there are no other live,\n"
416 "non-weak references to @var{proc}, it will be\n"
417 "garbage-collected, and dropped from @var{env}'s\n"
418 "list of observing procedures.")
419 #define FUNC_NAME s_scm_environment_observe_weak
421 SCM_ASSERT (SCM_ENVIRONMENT_P (env
), env
, SCM_ARG1
, FUNC_NAME
);
423 return SCM_ENVIRONMENT_OBSERVE (env
, environment_default_observer
, proc
, 1);
428 /* This is the C-level analog of the Scheme functions environment-observe and
429 * environment-observe-weak. Whenever env's bindings change, call the
430 * function proc, passing it env and data. If weak_p is non-zero, env will
431 * retain only a weak reference to data, and if data is garbage collected, the
432 * entire observation will be dropped. This function returns a token, with
433 * the same meaning as those returned by environment-observe and
434 * environment-observe-weak.
437 scm_c_environment_observe (SCM env
, scm_environment_observer proc
, SCM data
, int weak_p
)
438 #define FUNC_NAME "scm_c_environment_observe"
440 SCM_ASSERT (SCM_ENVIRONMENT_P (env
), env
, SCM_ARG1
, FUNC_NAME
);
442 return SCM_ENVIRONMENT_OBSERVE (env
, proc
, data
, weak_p
);
447 SCM_DEFINE (scm_environment_unobserve
, "environment-unobserve", 1, 0, 0,
449 "Cancel the observation request which returned the value\n"
450 "@var{token}. The return value is unspecified.\n"
451 "If a call @code{(environment-observe env proc)} returns\n"
452 "@var{token}, then the call @code{(environment-unobserve token)}\n"
453 "will cause @var{proc} to no longer be called when @var{env}'s\n"
455 #define FUNC_NAME s_scm_environment_unobserve
459 SCM_ASSERT (SCM_OBSERVER_P (token
), token
, SCM_ARG1
, FUNC_NAME
);
461 env
= SCM_OBSERVER_ENVIRONMENT (token
);
462 SCM_ENVIRONMENT_UNOBSERVE (env
, token
);
464 return SCM_UNSPECIFIED
;
470 environment_mark (SCM env
)
472 return (*(SCM_ENVIRONMENT_FUNCS (env
)->mark
)) (env
);
477 environment_free (SCM env
)
479 (*(SCM_ENVIRONMENT_FUNCS (env
)->free
)) (env
);
485 environment_print (SCM env
, SCM port
, scm_print_state
*pstate
)
487 return (*(SCM_ENVIRONMENT_FUNCS (env
)->print
)) (env
, port
, pstate
);
495 observer_mark (SCM observer
)
497 scm_gc_mark (SCM_OBSERVER_ENVIRONMENT (observer
));
498 scm_gc_mark (SCM_OBSERVER_DATA (observer
));
504 observer_print (SCM type
, SCM port
, scm_print_state
*pstate SCM_UNUSED
)
506 SCM address
= scm_ulong2num (SCM_UNPACK (type
));
507 SCM base16
= scm_number_to_string (address
, SCM_MAKINUM (16));
509 scm_puts ("#<observer ", port
);
510 scm_puts (SCM_STRING_CHARS (base16
), port
);
511 scm_puts (">", port
);
520 * Obarrays form the basic lookup tables used to implement most of guile's
521 * built-in environment types. An obarray is implemented as a hash table with
522 * symbols as keys. The content of the data depends on the environment type.
527 * Enter symbol into obarray. The symbol must not already exist in obarray.
528 * The freshly generated (symbol . data) cell is returned.
531 obarray_enter (SCM obarray
, SCM symbol
, SCM data
)
533 size_t hash
= SCM_SYMBOL_HASH (symbol
) % SCM_VECTOR_LENGTH (obarray
);
534 SCM entry
= scm_cons (symbol
, data
);
535 SCM slot
= scm_cons (entry
, SCM_VELTS (obarray
)[hash
]);
536 SCM_VELTS (obarray
)[hash
] = slot
;
543 * Enter symbol into obarray. An existing entry for symbol is replaced. If
544 * an entry existed, the old (symbol . data) cell is returned, #f otherwise.
547 obarray_replace (SCM obarray
, SCM symbol
, SCM data
)
549 size_t hash
= SCM_SYMBOL_HASH (symbol
) % SCM_VECTOR_LENGTH (obarray
);
550 SCM new_entry
= scm_cons (symbol
, data
);
554 for (lsym
= SCM_VELTS (obarray
)[hash
]; !SCM_NULLP (lsym
); lsym
= SCM_CDR (lsym
))
556 SCM old_entry
= SCM_CAR (lsym
);
557 if (SCM_EQ_P (SCM_CAR (old_entry
), symbol
))
559 SCM_SETCAR (lsym
, new_entry
);
564 slot
= scm_cons (new_entry
, SCM_VELTS (obarray
)[hash
]);
565 SCM_VELTS (obarray
)[hash
] = slot
;
572 * Look up symbol in obarray
575 obarray_retrieve (SCM obarray
, SCM sym
)
577 size_t hash
= SCM_SYMBOL_HASH (sym
) % SCM_VECTOR_LENGTH (obarray
);
580 for (lsym
= SCM_VELTS (obarray
)[hash
]; !SCM_NULLP (lsym
); lsym
= SCM_CDR (lsym
))
582 SCM entry
= SCM_CAR (lsym
);
583 if (SCM_EQ_P (SCM_CAR (entry
), sym
))
587 return SCM_UNDEFINED
;
592 * Remove entry from obarray. If the symbol was found and removed, the old
593 * (symbol . data) cell is returned, #f otherwise.
596 obarray_remove (SCM obarray
, SCM sym
)
598 size_t hash
= SCM_SYMBOL_HASH (sym
) % SCM_VECTOR_LENGTH (obarray
);
602 /* Dirk:FIXME:: gc problem due to use of &SCM_VELTS[hash] */
603 for (lsym
= *(lsymp
= &SCM_VELTS (obarray
)[hash
]);
605 lsym
= *(lsymp
= SCM_CDRLOC (lsym
)))
607 SCM entry
= SCM_CAR (lsym
);
608 if (SCM_EQ_P (SCM_CAR (entry
), sym
))
610 *lsymp
= SCM_CDR (lsym
);
619 obarray_remove_all (SCM obarray
)
621 size_t size
= SCM_VECTOR_LENGTH (obarray
);
624 for (i
= 0; i
< size
; i
++)
626 SCM_VELTS (obarray
)[i
] = SCM_EOL
;
632 /* core environments base
634 * This struct and the corresponding functions form a base class for guile's
635 * built-in environment types.
639 struct core_environments_base
{
640 struct scm_environment_funcs
*funcs
;
647 #define CORE_ENVIRONMENTS_BASE(env) \
648 ((struct core_environments_base *) SCM_CELL_WORD_1 (env))
649 #define CORE_ENVIRONMENT_OBSERVERS(env) \
650 (CORE_ENVIRONMENTS_BASE (env)->observers)
651 #define SCM_SET_CORE_ENVIRONMENT_OBSERVERS(env, v) \
652 (CORE_ENVIRONMENT_OBSERVERS (env) = (v))
653 #define CORE_ENVIRONMENT_WEAK_OBSERVER_VECTOR(env) \
654 (CORE_ENVIRONMENTS_BASE (env)->weak_observers)
655 #define CORE_ENVIRONMENT_WEAK_OBSERVERS(env) \
656 (SCM_VELTS (CORE_ENVIRONMENT_WEAK_OBSERVER_VECTOR (env)) [0])
657 #define SCM_SET_CORE_ENVIRONMENT_WEAK_OBSERVERS(env, v) \
658 (SCM_VELTS (CORE_ENVIRONMENT_WEAK_OBSERVER_VECTOR (env)) [0] = (v))
663 core_environments_observe (SCM env
, scm_environment_observer proc
, SCM data
, int weak_p
)
665 SCM observer
= scm_double_cell (scm_tc16_observer
,
672 SCM observers
= CORE_ENVIRONMENT_OBSERVERS (env
);
673 SCM new_observers
= scm_cons (observer
, observers
);
674 SCM_SET_CORE_ENVIRONMENT_OBSERVERS (env
, new_observers
);
678 SCM observers
= CORE_ENVIRONMENT_WEAK_OBSERVERS (env
);
679 SCM new_observers
= scm_acons (SCM_BOOL_F
, observer
, observers
);
680 SCM_SET_CORE_ENVIRONMENT_WEAK_OBSERVERS (env
, new_observers
);
688 core_environments_unobserve (SCM env
, SCM observer
)
690 unsigned int handling_weaks
;
691 for (handling_weaks
= 0; handling_weaks
<= 1; ++handling_weaks
)
693 SCM l
= handling_weaks
694 ? CORE_ENVIRONMENT_WEAK_OBSERVERS (env
)
695 : CORE_ENVIRONMENT_OBSERVERS (env
);
699 SCM rest
= SCM_CDR (l
);
700 SCM first
= handling_weaks
704 if (SCM_EQ_P (first
, observer
))
706 /* Remove the first observer */
708 ? SCM_SET_CORE_ENVIRONMENT_WEAK_OBSERVERS (env
, rest
)
709 : SCM_SET_CORE_ENVIRONMENT_OBSERVERS (env
, rest
);
714 SCM rest
= SCM_CDR (l
);
716 if (!SCM_NULLP (rest
))
718 SCM next
= handling_weaks
722 if (SCM_EQ_P (next
, observer
))
724 SCM_SETCDR (l
, SCM_CDR (rest
));
730 } while (!SCM_NULLP (l
));
734 /* Dirk:FIXME:: What to do now, since the observer is not found? */
739 core_environments_mark (SCM env
)
741 scm_gc_mark (CORE_ENVIRONMENT_OBSERVERS (env
));
742 return CORE_ENVIRONMENT_WEAK_OBSERVER_VECTOR (env
);
747 core_environments_finalize (SCM env SCM_UNUSED
)
753 core_environments_preinit (struct core_environments_base
*body
)
756 body
->observers
= SCM_BOOL_F
;
757 body
->weak_observers
= SCM_BOOL_F
;
762 core_environments_init (struct core_environments_base
*body
,
763 struct scm_environment_funcs
*funcs
)
766 body
->observers
= SCM_EOL
;
767 body
->weak_observers
= scm_make_weak_value_hash_table (SCM_MAKINUM (1));
771 /* Tell all observers to clear their caches.
773 * Environments have to be informed about changes in the following cases:
774 * - The observed env has a new binding. This must be always reported.
775 * - The observed env has dropped a binding. This must be always reported.
776 * - A binding in the observed environment has changed. This must only be
777 * reported, if there is a chance that the binding is being cached outside.
778 * However, this potential optimization is not performed currently.
780 * Errors that occur while the observers are called are accumulated and
781 * signalled as one single error message to the caller.
792 update_catch_body (void *ptr
)
794 struct update_data
*data
= (struct update_data
*) ptr
;
795 SCM observer
= data
->observer
;
797 (*SCM_OBSERVER_PROC (observer
))
798 (data
->environment
, SCM_OBSERVER_DATA (observer
));
800 return SCM_UNDEFINED
;
805 update_catch_handler (void *ptr
, SCM tag
, SCM args
)
807 struct update_data
*data
= (struct update_data
*) ptr
;
808 SCM observer
= data
->observer
;
809 SCM message
= scm_makfrom0str ("Observer `~A' signals `~A' error: ~S");
811 return scm_cons (message
, scm_list_3 (observer
, tag
, args
));
816 core_environments_broadcast (SCM env
)
817 #define FUNC_NAME "core_environments_broadcast"
819 unsigned int handling_weaks
;
820 SCM errors
= SCM_EOL
;
822 for (handling_weaks
= 0; handling_weaks
<= 1; ++handling_weaks
)
824 SCM observers
= handling_weaks
825 ? CORE_ENVIRONMENT_WEAK_OBSERVERS (env
)
826 : CORE_ENVIRONMENT_OBSERVERS (env
);
828 for (; !SCM_NULLP (observers
); observers
= SCM_CDR (observers
))
830 struct update_data data
;
831 SCM observer
= handling_weaks
832 ? SCM_CDAR (observers
)
833 : SCM_CAR (observers
);
836 data
.observer
= observer
;
837 data
.environment
= env
;
839 error
= scm_internal_catch (SCM_BOOL_T
,
840 update_catch_body
, &data
,
841 update_catch_handler
, &data
);
843 if (!SCM_UNBNDP (error
))
844 errors
= scm_cons (error
, errors
);
848 if (!SCM_NULLP (errors
))
850 /* Dirk:FIXME:: As soon as scm_misc_error is fixed to handle the name
851 * parameter correctly it should not be necessary any more to also pass
852 * namestr in order to get the desired information from the error
855 SCM ordered_errors
= scm_reverse (errors
);
858 "Observers of `~A' have signalled the following errors: ~S",
859 scm_cons2 (env
, ordered_errors
, SCM_EOL
));
868 * A leaf environment is simply a mutable set of definitions. A leaf
869 * environment supports no operations beyond the common set.
871 * Implementation: The obarray of the leaf environment holds (symbol . value)
872 * pairs. No further information is necessary, since all bindings and
873 * locations in a leaf environment are mutable.
877 struct leaf_environment
{
878 struct core_environments_base base
;
884 #define LEAF_ENVIRONMENT(env) \
885 ((struct leaf_environment *) SCM_CELL_WORD_1 (env))
890 leaf_environment_ref (SCM env
, SCM sym
)
892 SCM obarray
= LEAF_ENVIRONMENT (env
)->obarray
;
893 SCM binding
= obarray_retrieve (obarray
, sym
);
894 return SCM_UNBNDP (binding
) ? binding
: SCM_CDR (binding
);
899 leaf_environment_fold (SCM env
, scm_environment_folder proc
, SCM data
, SCM init
)
903 SCM obarray
= LEAF_ENVIRONMENT (env
)->obarray
;
905 for (i
= 0; i
< SCM_VECTOR_LENGTH (obarray
); i
++)
908 for (l
= SCM_VELTS (obarray
)[i
]; !SCM_NULLP (l
); l
= SCM_CDR (l
))
910 SCM binding
= SCM_CAR (l
);
911 SCM symbol
= SCM_CAR (binding
);
912 SCM value
= SCM_CDR (binding
);
913 result
= (*proc
) (data
, symbol
, value
, result
);
921 leaf_environment_define (SCM env
, SCM sym
, SCM val
)
922 #define FUNC_NAME "leaf_environment_define"
924 SCM obarray
= LEAF_ENVIRONMENT (env
)->obarray
;
926 obarray_replace (obarray
, sym
, val
);
927 core_environments_broadcast (env
);
929 return SCM_ENVIRONMENT_SUCCESS
;
935 leaf_environment_undefine (SCM env
, SCM sym
)
936 #define FUNC_NAME "leaf_environment_undefine"
938 SCM obarray
= LEAF_ENVIRONMENT (env
)->obarray
;
939 SCM removed
= obarray_remove (obarray
, sym
);
941 if (!SCM_FALSEP (removed
))
942 core_environments_broadcast (env
);
944 return SCM_ENVIRONMENT_SUCCESS
;
950 leaf_environment_set_x (SCM env
, SCM sym
, SCM val
)
951 #define FUNC_NAME "leaf_environment_set_x"
953 SCM obarray
= LEAF_ENVIRONMENT (env
)->obarray
;
954 SCM binding
= obarray_retrieve (obarray
, sym
);
956 if (!SCM_UNBNDP (binding
))
958 SCM_SETCDR (binding
, val
);
959 return SCM_ENVIRONMENT_SUCCESS
;
963 return SCM_UNDEFINED
;
970 leaf_environment_cell (SCM env
, SCM sym
, int for_write SCM_UNUSED
)
972 SCM obarray
= LEAF_ENVIRONMENT (env
)->obarray
;
973 SCM binding
= obarray_retrieve (obarray
, sym
);
979 leaf_environment_mark (SCM env
)
981 scm_gc_mark (LEAF_ENVIRONMENT (env
)->obarray
);
982 return core_environments_mark (env
);
987 leaf_environment_free (SCM env
)
989 core_environments_finalize (env
);
990 scm_gc_free (LEAF_ENVIRONMENT (env
), sizeof (struct leaf_environment
),
996 leaf_environment_print (SCM type
, SCM port
, scm_print_state
*pstate SCM_UNUSED
)
998 SCM address
= scm_ulong2num (SCM_UNPACK (type
));
999 SCM base16
= scm_number_to_string (address
, SCM_MAKINUM (16));
1001 scm_puts ("#<leaf environment ", port
);
1002 scm_puts (SCM_STRING_CHARS (base16
), port
);
1003 scm_puts (">", port
);
1009 static struct scm_environment_funcs leaf_environment_funcs
= {
1010 leaf_environment_ref
,
1011 leaf_environment_fold
,
1012 leaf_environment_define
,
1013 leaf_environment_undefine
,
1014 leaf_environment_set_x
,
1015 leaf_environment_cell
,
1016 core_environments_observe
,
1017 core_environments_unobserve
,
1018 leaf_environment_mark
,
1019 leaf_environment_free
,
1020 leaf_environment_print
1024 void *scm_type_leaf_environment
= &leaf_environment_funcs
;
1027 SCM_DEFINE (scm_make_leaf_environment
, "make-leaf-environment", 0, 0, 0,
1029 "Create a new leaf environment, containing no bindings.\n"
1030 "All bindings and locations created in the new environment\n"
1032 #define FUNC_NAME s_scm_make_leaf_environment
1034 size_t size
= sizeof (struct leaf_environment
);
1035 struct leaf_environment
*body
= scm_gc_malloc (size
, "leaf environment");
1038 core_environments_preinit (&body
->base
);
1039 body
->obarray
= SCM_BOOL_F
;
1041 env
= scm_make_environment (body
);
1043 core_environments_init (&body
->base
, &leaf_environment_funcs
);
1044 body
->obarray
= scm_c_make_hash_table (DEFAULT_OBARRAY_SIZE
);
1051 SCM_DEFINE (scm_leaf_environment_p
, "leaf-environment?", 1, 0, 0,
1053 "Return @code{#t} if object is a leaf environment, or @code{#f}\n"
1055 #define FUNC_NAME s_scm_leaf_environment_p
1057 return SCM_BOOL (SCM_LEAF_ENVIRONMENT_P (object
));
1063 /* eval environments
1065 * A module's source code refers to definitions imported from other modules,
1066 * and definitions made within itself. An eval environment combines two
1067 * environments -- a local environment and an imported environment -- to
1068 * produce a new environment in which both sorts of references can be
1071 * Implementation: The obarray of the eval environment is used to cache
1072 * entries from the local and imported environments such that in most of the
1073 * cases only a single lookup is necessary. Since for neither the local nor
1074 * the imported environment it is known, what kind of environment they form,
1075 * the most general case is assumed. Therefore, entries in the obarray take
1076 * one of the following forms:
1078 * 1) (<symbol> location mutability . source-env), where mutability indicates
1079 * one of the following states: IMMUTABLE if the location is known to be
1080 * immutable, MUTABLE if the location is known to be mutable, UNKNOWN if
1081 * the location has only been requested for non modifying accesses.
1083 * 2) (symbol . source-env) if the symbol has a binding in the source-env, but
1084 * if the source-env can't provide a cell for the binding. Thus, for every
1085 * access, the source-env has to be contacted directly.
1089 struct eval_environment
{
1090 struct core_environments_base base
;
1095 SCM imported_observer
;
1101 #define EVAL_ENVIRONMENT(env) \
1102 ((struct eval_environment *) SCM_CELL_WORD_1 (env))
1104 #define IMMUTABLE SCM_MAKINUM (0)
1105 #define MUTABLE SCM_MAKINUM (1)
1106 #define UNKNOWN SCM_MAKINUM (2)
1108 #define CACHED_LOCATION(x) SCM_CAR (x)
1109 #define CACHED_MUTABILITY(x) SCM_CADR (x)
1110 #define SET_CACHED_MUTABILITY(x, v) SCM_SETCAR (SCM_CDR (x), (v))
1111 #define CACHED_SOURCE_ENVIRONMENT(x) SCM_CDDR (x)
1115 /* eval_environment_lookup will report one of the following distinct results:
1116 * a) (<object> . value) if a cell could be obtained.
1117 * b) <environment> if the environment has to be contacted directly.
1118 * c) IMMUTABLE if an immutable cell was requested for write.
1119 * d) SCM_UNDEFINED if there is no binding for the symbol.
1122 eval_environment_lookup (SCM env
, SCM sym
, int for_write
)
1124 SCM obarray
= EVAL_ENVIRONMENT (env
)->obarray
;
1125 SCM binding
= obarray_retrieve (obarray
, sym
);
1127 if (!SCM_UNBNDP (binding
))
1129 /* The obarray holds an entry for the symbol. */
1131 SCM entry
= SCM_CDR (binding
);
1133 if (SCM_CONSP (entry
))
1135 /* The entry in the obarray is a cached location. */
1137 SCM location
= CACHED_LOCATION (entry
);
1143 mutability
= CACHED_MUTABILITY (entry
);
1144 if (SCM_EQ_P (mutability
, MUTABLE
))
1147 if (SCM_EQ_P (mutability
, UNKNOWN
))
1149 SCM source_env
= CACHED_SOURCE_ENVIRONMENT (entry
);
1150 SCM location
= SCM_ENVIRONMENT_CELL (source_env
, sym
, 1);
1152 if (SCM_CONSP (location
))
1154 SET_CACHED_MUTABILITY (entry
, MUTABLE
);
1157 else /* IMMUTABLE */
1159 SET_CACHED_MUTABILITY (entry
, IMMUTABLE
);
1168 /* The obarray entry is an environment */
1175 /* There is no entry for the symbol in the obarray. This can either
1176 * mean that there has not been a request for the symbol yet, or that
1177 * the symbol is really undefined. We are looking for the symbol in
1178 * both the local and the imported environment. If we find a binding, a
1179 * cached entry is created.
1182 struct eval_environment
*body
= EVAL_ENVIRONMENT (env
);
1183 unsigned int handling_import
;
1185 for (handling_import
= 0; handling_import
<= 1; ++handling_import
)
1187 SCM source_env
= handling_import
? body
->imported
: body
->local
;
1188 SCM location
= SCM_ENVIRONMENT_CELL (source_env
, sym
, for_write
);
1190 if (!SCM_UNBNDP (location
))
1192 if (SCM_CONSP (location
))
1194 SCM mutability
= for_write
? MUTABLE
: UNKNOWN
;
1195 SCM entry
= scm_cons2 (location
, mutability
, source_env
);
1196 obarray_enter (obarray
, sym
, entry
);
1199 else if (SCM_EQ_P (location
, SCM_ENVIRONMENT_LOCATION_NO_CELL
))
1201 obarray_enter (obarray
, sym
, source_env
);
1211 return SCM_UNDEFINED
;
1217 eval_environment_ref (SCM env
, SCM sym
)
1218 #define FUNC_NAME "eval_environment_ref"
1220 SCM location
= eval_environment_lookup (env
, sym
, 0);
1222 if (SCM_CONSP (location
))
1223 return SCM_CDR (location
);
1224 else if (!SCM_UNBNDP (location
))
1225 return SCM_ENVIRONMENT_REF (location
, sym
);
1227 return SCM_UNDEFINED
;
1233 eval_environment_folder (SCM extended_data
, SCM symbol
, SCM value
, SCM tail
)
1235 SCM local
= SCM_CAR (extended_data
);
1237 if (!SCM_ENVIRONMENT_BOUND_P (local
, symbol
))
1239 SCM proc_as_nr
= SCM_CADR (extended_data
);
1240 unsigned long int proc_as_ul
= scm_num2ulong (proc_as_nr
, 0, NULL
);
1241 scm_environment_folder proc
= (scm_environment_folder
) proc_as_ul
;
1242 SCM data
= SCM_CDDR (extended_data
);
1244 return (*proc
) (data
, symbol
, value
, tail
);
1254 eval_environment_fold (SCM env
, scm_environment_folder proc
, SCM data
, SCM init
)
1256 SCM local
= EVAL_ENVIRONMENT (env
)->local
;
1257 SCM imported
= EVAL_ENVIRONMENT (env
)->imported
;
1258 SCM proc_as_nr
= scm_ulong2num ((unsigned long int) proc
);
1259 SCM extended_data
= scm_cons2 (local
, proc_as_nr
, data
);
1260 SCM tmp_result
= scm_c_environment_fold (imported
, eval_environment_folder
, extended_data
, init
);
1262 return scm_c_environment_fold (local
, proc
, data
, tmp_result
);
1267 eval_environment_define (SCM env
, SCM sym
, SCM val
)
1268 #define FUNC_NAME "eval_environment_define"
1270 SCM local
= EVAL_ENVIRONMENT (env
)->local
;
1271 return SCM_ENVIRONMENT_DEFINE (local
, sym
, val
);
1277 eval_environment_undefine (SCM env
, SCM sym
)
1278 #define FUNC_NAME "eval_environment_undefine"
1280 SCM local
= EVAL_ENVIRONMENT (env
)->local
;
1281 return SCM_ENVIRONMENT_UNDEFINE (local
, sym
);
1287 eval_environment_set_x (SCM env
, SCM sym
, SCM val
)
1288 #define FUNC_NAME "eval_environment_set_x"
1290 SCM location
= eval_environment_lookup (env
, sym
, 1);
1292 if (SCM_CONSP (location
))
1294 SCM_SETCDR (location
, val
);
1295 return SCM_ENVIRONMENT_SUCCESS
;
1297 else if (SCM_ENVIRONMENT_P (location
))
1299 return SCM_ENVIRONMENT_SET (location
, sym
, val
);
1301 else if (SCM_EQ_P (location
, IMMUTABLE
))
1303 return SCM_ENVIRONMENT_LOCATION_IMMUTABLE
;
1307 return SCM_UNDEFINED
;
1314 eval_environment_cell (SCM env
, SCM sym
, int for_write
)
1315 #define FUNC_NAME "eval_environment_cell"
1317 SCM location
= eval_environment_lookup (env
, sym
, for_write
);
1319 if (SCM_CONSP (location
))
1321 else if (SCM_ENVIRONMENT_P (location
))
1322 return SCM_ENVIRONMENT_LOCATION_NO_CELL
;
1323 else if (SCM_EQ_P (location
, IMMUTABLE
))
1324 return SCM_ENVIRONMENT_LOCATION_IMMUTABLE
;
1326 return SCM_UNDEFINED
;
1332 eval_environment_mark (SCM env
)
1334 struct eval_environment
*body
= EVAL_ENVIRONMENT (env
);
1336 scm_gc_mark (body
->obarray
);
1337 scm_gc_mark (body
->imported
);
1338 scm_gc_mark (body
->imported_observer
);
1339 scm_gc_mark (body
->local
);
1340 scm_gc_mark (body
->local_observer
);
1342 return core_environments_mark (env
);
1347 eval_environment_free (SCM env
)
1349 core_environments_finalize (env
);
1350 scm_gc_free (EVAL_ENVIRONMENT (env
), sizeof (struct eval_environment
),
1351 "eval environment");
1356 eval_environment_print (SCM type
, SCM port
, scm_print_state
*pstate SCM_UNUSED
)
1358 SCM address
= scm_ulong2num (SCM_UNPACK (type
));
1359 SCM base16
= scm_number_to_string (address
, SCM_MAKINUM (16));
1361 scm_puts ("#<eval environment ", port
);
1362 scm_puts (SCM_STRING_CHARS (base16
), port
);
1363 scm_puts (">", port
);
1369 static struct scm_environment_funcs eval_environment_funcs
= {
1370 eval_environment_ref
,
1371 eval_environment_fold
,
1372 eval_environment_define
,
1373 eval_environment_undefine
,
1374 eval_environment_set_x
,
1375 eval_environment_cell
,
1376 core_environments_observe
,
1377 core_environments_unobserve
,
1378 eval_environment_mark
,
1379 eval_environment_free
,
1380 eval_environment_print
1384 void *scm_type_eval_environment
= &eval_environment_funcs
;
1388 eval_environment_observer (SCM caller SCM_UNUSED
, SCM eval_env
)
1390 SCM obarray
= EVAL_ENVIRONMENT (eval_env
)->obarray
;
1392 obarray_remove_all (obarray
);
1393 core_environments_broadcast (eval_env
);
1397 SCM_DEFINE (scm_make_eval_environment
, "make-eval-environment", 2, 0, 0,
1398 (SCM local
, SCM imported
),
1399 "Return a new environment object eval whose bindings are the\n"
1400 "union of the bindings in the environments @var{local} and\n"
1401 "@var{imported}, with bindings from @var{local} taking\n"
1402 "precedence. Definitions made in eval are placed in @var{local}.\n"
1403 "Applying @code{environment-define} or\n"
1404 "@code{environment-undefine} to eval has the same effect as\n"
1405 "applying the procedure to @var{local}.\n"
1406 "Note that eval incorporates @var{local} and @var{imported} by\n"
1408 "If, after creating eval, the program changes the bindings of\n"
1409 "@var{local} or @var{imported}, those changes will be visible\n"
1411 "Since most Scheme evaluation takes place in eval environments,\n"
1412 "they transparently cache the bindings received from @var{local}\n"
1413 "and @var{imported}. Thus, the first time the program looks up\n"
1414 "a symbol in eval, eval may make calls to @var{local} or\n"
1415 "@var{imported} to find their bindings, but subsequent\n"
1416 "references to that symbol will be as fast as references to\n"
1417 "bindings in finite environments.\n"
1418 "In typical use, @var{local} will be a finite environment, and\n"
1419 "@var{imported} will be an import environment")
1420 #define FUNC_NAME s_scm_make_eval_environment
1423 struct eval_environment
*body
;
1425 SCM_ASSERT (SCM_ENVIRONMENT_P (local
), local
, SCM_ARG1
, FUNC_NAME
);
1426 SCM_ASSERT (SCM_ENVIRONMENT_P (imported
), imported
, SCM_ARG2
, FUNC_NAME
);
1428 body
= scm_gc_malloc (sizeof (struct eval_environment
), "eval environment");
1430 core_environments_preinit (&body
->base
);
1431 body
->obarray
= SCM_BOOL_F
;
1432 body
->imported
= SCM_BOOL_F
;
1433 body
->imported_observer
= SCM_BOOL_F
;
1434 body
->local
= SCM_BOOL_F
;
1435 body
->local_observer
= SCM_BOOL_F
;
1437 env
= scm_make_environment (body
);
1439 core_environments_init (&body
->base
, &eval_environment_funcs
);
1440 body
->obarray
= scm_c_make_hash_table (DEFAULT_OBARRAY_SIZE
);
1441 body
->imported
= imported
;
1442 body
->imported_observer
1443 = SCM_ENVIRONMENT_OBSERVE (imported
, eval_environment_observer
, env
, 1);
1444 body
->local
= local
;
1445 body
->local_observer
1446 = SCM_ENVIRONMENT_OBSERVE (local
, eval_environment_observer
, env
, 1);
1453 SCM_DEFINE (scm_eval_environment_p
, "eval-environment?", 1, 0, 0,
1455 "Return @code{#t} if object is an eval environment, or @code{#f}\n"
1457 #define FUNC_NAME s_scm_eval_environment_p
1459 return SCM_BOOL (SCM_EVAL_ENVIRONMENT_P (object
));
1464 SCM_DEFINE (scm_eval_environment_local
, "eval-environment-local", 1, 0, 0,
1466 "Return the local environment of eval environment @var{env}.")
1467 #define FUNC_NAME s_scm_eval_environment_local
1469 SCM_ASSERT (SCM_EVAL_ENVIRONMENT_P (env
), env
, SCM_ARG1
, FUNC_NAME
);
1471 return EVAL_ENVIRONMENT (env
)->local
;
1476 SCM_DEFINE (scm_eval_environment_set_local_x
, "eval-environment-set-local!", 2, 0, 0,
1477 (SCM env
, SCM local
),
1478 "Change @var{env}'s local environment to @var{local}.")
1479 #define FUNC_NAME s_scm_eval_environment_set_local_x
1481 struct eval_environment
*body
;
1483 SCM_ASSERT (SCM_EVAL_ENVIRONMENT_P (env
), env
, SCM_ARG1
, FUNC_NAME
);
1484 SCM_ASSERT (SCM_ENVIRONMENT_P (local
), local
, SCM_ARG2
, FUNC_NAME
);
1486 body
= EVAL_ENVIRONMENT (env
);
1488 obarray_remove_all (body
->obarray
);
1489 SCM_ENVIRONMENT_UNOBSERVE (body
->local
, body
->local_observer
);
1491 body
->local
= local
;
1492 body
->local_observer
1493 = SCM_ENVIRONMENT_OBSERVE (local
, eval_environment_observer
, env
, 1);
1495 core_environments_broadcast (env
);
1497 return SCM_UNSPECIFIED
;
1502 SCM_DEFINE (scm_eval_environment_imported
, "eval-environment-imported", 1, 0, 0,
1504 "Return the imported environment of eval environment @var{env}.")
1505 #define FUNC_NAME s_scm_eval_environment_imported
1507 SCM_ASSERT (SCM_EVAL_ENVIRONMENT_P (env
), env
, SCM_ARG1
, FUNC_NAME
);
1509 return EVAL_ENVIRONMENT (env
)->imported
;
1514 SCM_DEFINE (scm_eval_environment_set_imported_x
, "eval-environment-set-imported!", 2, 0, 0,
1515 (SCM env
, SCM imported
),
1516 "Change @var{env}'s imported environment to @var{imported}.")
1517 #define FUNC_NAME s_scm_eval_environment_set_imported_x
1519 struct eval_environment
*body
;
1521 SCM_ASSERT (SCM_EVAL_ENVIRONMENT_P (env
), env
, SCM_ARG1
, FUNC_NAME
);
1522 SCM_ASSERT (SCM_ENVIRONMENT_P (imported
), imported
, SCM_ARG2
, FUNC_NAME
);
1524 body
= EVAL_ENVIRONMENT (env
);
1526 obarray_remove_all (body
->obarray
);
1527 SCM_ENVIRONMENT_UNOBSERVE (body
->imported
, body
->imported_observer
);
1529 body
->imported
= imported
;
1530 body
->imported_observer
1531 = SCM_ENVIRONMENT_OBSERVE (imported
, eval_environment_observer
, env
, 1);
1533 core_environments_broadcast (env
);
1535 return SCM_UNSPECIFIED
;
1541 /* import environments
1543 * An import environment combines the bindings of a set of argument
1544 * environments, and checks for naming clashes.
1546 * Implementation: The import environment does no caching at all. For every
1547 * access, the list of imported environments is scanned.
1551 struct import_environment
{
1552 struct core_environments_base base
;
1555 SCM import_observers
;
1561 #define IMPORT_ENVIRONMENT(env) \
1562 ((struct import_environment *) SCM_CELL_WORD_1 (env))
1566 /* Lookup will report one of the following distinct results:
1567 * a) <environment> if only environment binds the symbol.
1568 * b) (env-1 env-2 ...) for conflicting bindings in env-1, ...
1569 * c) SCM_UNDEFINED if there is no binding for the symbol.
1572 import_environment_lookup (SCM env
, SCM sym
)
1574 SCM imports
= IMPORT_ENVIRONMENT (env
)->imports
;
1575 SCM result
= SCM_UNDEFINED
;
1578 for (l
= imports
; !SCM_NULLP (l
); l
= SCM_CDR (l
))
1580 SCM imported
= SCM_CAR (l
);
1582 if (SCM_ENVIRONMENT_BOUND_P (imported
, sym
))
1584 if (SCM_UNBNDP (result
))
1586 else if (SCM_CONSP (result
))
1587 result
= scm_cons (imported
, result
);
1589 result
= scm_cons2 (imported
, result
, SCM_EOL
);
1593 if (SCM_CONSP (result
))
1594 return scm_reverse (result
);
1601 import_environment_conflict (SCM env
, SCM sym
, SCM imports
)
1603 SCM conflict_proc
= IMPORT_ENVIRONMENT (env
)->conflict_proc
;
1604 SCM args
= scm_cons2 (env
, sym
, scm_cons (imports
, SCM_EOL
));
1606 return scm_apply_0 (conflict_proc
, args
);
1611 import_environment_ref (SCM env
, SCM sym
)
1612 #define FUNC_NAME "import_environment_ref"
1614 SCM owner
= import_environment_lookup (env
, sym
);
1616 if (SCM_UNBNDP (owner
))
1618 return SCM_UNDEFINED
;
1620 else if (SCM_CONSP (owner
))
1622 SCM resolve
= import_environment_conflict (env
, sym
, owner
);
1624 if (SCM_ENVIRONMENT_P (resolve
))
1625 return SCM_ENVIRONMENT_REF (resolve
, sym
);
1627 return SCM_UNSPECIFIED
;
1631 return SCM_ENVIRONMENT_REF (owner
, sym
);
1638 import_environment_folder (SCM extended_data
, SCM symbol
, SCM value
, SCM tail
)
1639 #define FUNC_NAME "import_environment_fold"
1641 SCM import_env
= SCM_CAR (extended_data
);
1642 SCM imported_env
= SCM_CADR (extended_data
);
1643 SCM owner
= import_environment_lookup (import_env
, symbol
);
1644 SCM proc_as_nr
= SCM_CADDR (extended_data
);
1645 unsigned long int proc_as_ul
= scm_num2ulong (proc_as_nr
, 0, NULL
);
1646 scm_environment_folder proc
= (scm_environment_folder
) proc_as_ul
;
1647 SCM data
= SCM_CDDDR (extended_data
);
1649 if (SCM_CONSP (owner
) && SCM_EQ_P (SCM_CAR (owner
), imported_env
))
1650 owner
= import_environment_conflict (import_env
, symbol
, owner
);
1652 if (SCM_ENVIRONMENT_P (owner
))
1653 return (*proc
) (data
, symbol
, value
, tail
);
1654 else /* unresolved conflict */
1655 return (*proc
) (data
, symbol
, SCM_UNSPECIFIED
, tail
);
1661 import_environment_fold (SCM env
, scm_environment_folder proc
, SCM data
, SCM init
)
1663 SCM proc_as_nr
= scm_ulong2num ((unsigned long int) proc
);
1667 for (l
= IMPORT_ENVIRONMENT (env
)->imports
; !SCM_NULLP (l
); l
= SCM_CDR (l
))
1669 SCM imported_env
= SCM_CAR (l
);
1670 SCM extended_data
= scm_cons (env
, scm_cons2 (imported_env
, proc_as_nr
, data
));
1672 result
= scm_c_environment_fold (imported_env
, import_environment_folder
, extended_data
, result
);
1680 import_environment_define (SCM env SCM_UNUSED
,
1683 #define FUNC_NAME "import_environment_define"
1685 return SCM_ENVIRONMENT_BINDING_IMMUTABLE
;
1691 import_environment_undefine (SCM env SCM_UNUSED
,
1693 #define FUNC_NAME "import_environment_undefine"
1695 return SCM_ENVIRONMENT_BINDING_IMMUTABLE
;
1701 import_environment_set_x (SCM env
, SCM sym
, SCM val
)
1702 #define FUNC_NAME "import_environment_set_x"
1704 SCM owner
= import_environment_lookup (env
, sym
);
1706 if (SCM_UNBNDP (owner
))
1708 return SCM_UNDEFINED
;
1710 else if (SCM_CONSP (owner
))
1712 SCM resolve
= import_environment_conflict (env
, sym
, owner
);
1714 if (SCM_ENVIRONMENT_P (resolve
))
1715 return SCM_ENVIRONMENT_SET (resolve
, sym
, val
);
1717 return SCM_ENVIRONMENT_LOCATION_IMMUTABLE
;
1721 return SCM_ENVIRONMENT_SET (owner
, sym
, val
);
1728 import_environment_cell (SCM env
, SCM sym
, int for_write
)
1729 #define FUNC_NAME "import_environment_cell"
1731 SCM owner
= import_environment_lookup (env
, sym
);
1733 if (SCM_UNBNDP (owner
))
1735 return SCM_UNDEFINED
;
1737 else if (SCM_CONSP (owner
))
1739 SCM resolve
= import_environment_conflict (env
, sym
, owner
);
1741 if (SCM_ENVIRONMENT_P (resolve
))
1742 return SCM_ENVIRONMENT_CELL (resolve
, sym
, for_write
);
1744 return SCM_ENVIRONMENT_LOCATION_NO_CELL
;
1748 return SCM_ENVIRONMENT_CELL (owner
, sym
, for_write
);
1755 import_environment_mark (SCM env
)
1757 scm_gc_mark (IMPORT_ENVIRONMENT (env
)->imports
);
1758 scm_gc_mark (IMPORT_ENVIRONMENT (env
)->import_observers
);
1759 scm_gc_mark (IMPORT_ENVIRONMENT (env
)->conflict_proc
);
1760 return core_environments_mark (env
);
1765 import_environment_free (SCM env
)
1767 core_environments_finalize (env
);
1768 scm_gc_free (IMPORT_ENVIRONMENT (env
), sizeof (struct import_environment
),
1769 "import environment");
1774 import_environment_print (SCM type
, SCM port
,
1775 scm_print_state
*pstate SCM_UNUSED
)
1777 SCM address
= scm_ulong2num (SCM_UNPACK (type
));
1778 SCM base16
= scm_number_to_string (address
, SCM_MAKINUM (16));
1780 scm_puts ("#<import environment ", port
);
1781 scm_puts (SCM_STRING_CHARS (base16
), port
);
1782 scm_puts (">", port
);
1788 static struct scm_environment_funcs import_environment_funcs
= {
1789 import_environment_ref
,
1790 import_environment_fold
,
1791 import_environment_define
,
1792 import_environment_undefine
,
1793 import_environment_set_x
,
1794 import_environment_cell
,
1795 core_environments_observe
,
1796 core_environments_unobserve
,
1797 import_environment_mark
,
1798 import_environment_free
,
1799 import_environment_print
1803 void *scm_type_import_environment
= &import_environment_funcs
;
1807 import_environment_observer (SCM caller SCM_UNUSED
, SCM import_env
)
1809 core_environments_broadcast (import_env
);
1813 SCM_DEFINE (scm_make_import_environment
, "make-import-environment", 2, 0, 0,
1814 (SCM imports
, SCM conflict_proc
),
1815 "Return a new environment @var{imp} whose bindings are the union\n"
1816 "of the bindings from the environments in @var{imports};\n"
1817 "@var{imports} must be a list of environments. That is,\n"
1818 "@var{imp} binds a symbol to a location when some element of\n"
1819 "@var{imports} does.\n"
1820 "If two different elements of @var{imports} have a binding for\n"
1821 "the same symbol, the @var{conflict-proc} is called with the\n"
1822 "following parameters: the import environment, the symbol and\n"
1823 "the list of the imported environments that bind the symbol.\n"
1824 "If the @var{conflict-proc} returns an environment @var{env},\n"
1825 "the conflict is considered as resolved and the binding from\n"
1826 "@var{env} is used. If the @var{conflict-proc} returns some\n"
1827 "non-environment object, the conflict is considered unresolved\n"
1828 "and the symbol is treated as unspecified in the import\n"
1830 "The checking for conflicts may be performed lazily, i. e. at\n"
1831 "the moment when a value or binding for a certain symbol is\n"
1832 "requested instead of the moment when the environment is\n"
1833 "created or the bindings of the imports change.\n"
1834 "All bindings in @var{imp} are immutable. If you apply\n"
1835 "@code{environment-define} or @code{environment-undefine} to\n"
1836 "@var{imp}, Guile will signal an\n"
1837 " @code{environment:immutable-binding} error. However,\n"
1838 "notice that the set of bindings in @var{imp} may still change,\n"
1839 "if one of its imported environments changes.")
1840 #define FUNC_NAME s_scm_make_import_environment
1842 size_t size
= sizeof (struct import_environment
);
1843 struct import_environment
*body
= scm_gc_malloc (size
, "import environment");
1846 core_environments_preinit (&body
->base
);
1847 body
->imports
= SCM_BOOL_F
;
1848 body
->import_observers
= SCM_BOOL_F
;
1849 body
->conflict_proc
= SCM_BOOL_F
;
1851 env
= scm_make_environment (body
);
1853 core_environments_init (&body
->base
, &import_environment_funcs
);
1854 body
->imports
= SCM_EOL
;
1855 body
->import_observers
= SCM_EOL
;
1856 body
->conflict_proc
= conflict_proc
;
1858 scm_import_environment_set_imports_x (env
, imports
);
1865 SCM_DEFINE (scm_import_environment_p
, "import-environment?", 1, 0, 0,
1867 "Return @code{#t} if object is an import environment, or\n"
1868 "@code{#f} otherwise.")
1869 #define FUNC_NAME s_scm_import_environment_p
1871 return SCM_BOOL (SCM_IMPORT_ENVIRONMENT_P (object
));
1876 SCM_DEFINE (scm_import_environment_imports
, "import-environment-imports", 1, 0, 0,
1878 "Return the list of environments imported by the import\n"
1879 "environment @var{env}.")
1880 #define FUNC_NAME s_scm_import_environment_imports
1882 SCM_ASSERT (SCM_IMPORT_ENVIRONMENT_P (env
), env
, SCM_ARG1
, FUNC_NAME
);
1884 return IMPORT_ENVIRONMENT (env
)->imports
;
1889 SCM_DEFINE (scm_import_environment_set_imports_x
, "import-environment-set-imports!", 2, 0, 0,
1890 (SCM env
, SCM imports
),
1891 "Change @var{env}'s list of imported environments to\n"
1892 "@var{imports}, and check for conflicts.")
1893 #define FUNC_NAME s_scm_import_environment_set_imports_x
1895 struct import_environment
*body
= IMPORT_ENVIRONMENT (env
);
1896 SCM import_observers
= SCM_EOL
;
1899 SCM_ASSERT (SCM_IMPORT_ENVIRONMENT_P (env
), env
, SCM_ARG1
, FUNC_NAME
);
1900 for (l
= imports
; SCM_CONSP (l
); l
= SCM_CDR (l
))
1902 SCM obj
= SCM_CAR (l
);
1903 SCM_ASSERT (SCM_ENVIRONMENT_P (obj
), imports
, SCM_ARG2
, FUNC_NAME
);
1905 SCM_ASSERT (SCM_NULLP (l
), imports
, SCM_ARG2
, FUNC_NAME
);
1907 for (l
= body
->import_observers
; !SCM_NULLP (l
); l
= SCM_CDR (l
))
1909 SCM obs
= SCM_CAR (l
);
1910 SCM_ENVIRONMENT_UNOBSERVE (env
, obs
);
1913 for (l
= imports
; !SCM_NULLP (l
); l
= SCM_CDR (l
))
1915 SCM imp
= SCM_CAR (l
);
1916 SCM obs
= SCM_ENVIRONMENT_OBSERVE (imp
, import_environment_observer
, env
, 1);
1917 import_observers
= scm_cons (obs
, import_observers
);
1920 body
->imports
= imports
;
1921 body
->import_observers
= import_observers
;
1923 return SCM_UNSPECIFIED
;
1929 /* export environments
1931 * An export environment restricts an environment to a specified set of
1934 * Implementation: The export environment does no caching at all. For every
1935 * access, the signature is scanned. The signature that is stored internally
1936 * is an alist of pairs (symbol . (mutability)).
1940 struct export_environment
{
1941 struct core_environments_base base
;
1944 SCM private_observer
;
1950 #define EXPORT_ENVIRONMENT(env) \
1951 ((struct export_environment *) SCM_CELL_WORD_1 (env))
1954 SCM_SYMBOL (symbol_immutable_location
, "immutable-location");
1955 SCM_SYMBOL (symbol_mutable_location
, "mutable-location");
1960 export_environment_ref (SCM env
, SCM sym
)
1961 #define FUNC_NAME "export_environment_ref"
1963 struct export_environment
*body
= EXPORT_ENVIRONMENT (env
);
1964 SCM entry
= scm_assq (sym
, body
->signature
);
1966 if (SCM_FALSEP (entry
))
1967 return SCM_UNDEFINED
;
1969 return SCM_ENVIRONMENT_REF (body
->private, sym
);
1975 export_environment_fold (SCM env
, scm_environment_folder proc
, SCM data
, SCM init
)
1977 struct export_environment
*body
= EXPORT_ENVIRONMENT (env
);
1981 for (l
= body
->signature
; !SCM_NULLP (l
); l
= SCM_CDR (l
))
1983 SCM symbol
= SCM_CAR (l
);
1984 SCM value
= SCM_ENVIRONMENT_REF (body
->private, symbol
);
1985 if (!SCM_UNBNDP (value
))
1986 result
= (*proc
) (data
, symbol
, value
, result
);
1993 export_environment_define (SCM env SCM_UNUSED
,
1996 #define FUNC_NAME "export_environment_define"
1998 return SCM_ENVIRONMENT_BINDING_IMMUTABLE
;
2004 export_environment_undefine (SCM env SCM_UNUSED
, SCM sym SCM_UNUSED
)
2005 #define FUNC_NAME "export_environment_undefine"
2007 return SCM_ENVIRONMENT_BINDING_IMMUTABLE
;
2013 export_environment_set_x (SCM env
, SCM sym
, SCM val
)
2014 #define FUNC_NAME "export_environment_set_x"
2016 struct export_environment
*body
= EXPORT_ENVIRONMENT (env
);
2017 SCM entry
= scm_assq (sym
, body
->signature
);
2019 if (SCM_FALSEP (entry
))
2021 return SCM_UNDEFINED
;
2025 if (SCM_EQ_P (SCM_CADR (entry
), symbol_mutable_location
))
2026 return SCM_ENVIRONMENT_SET (body
->private, sym
, val
);
2028 return SCM_ENVIRONMENT_LOCATION_IMMUTABLE
;
2035 export_environment_cell (SCM env
, SCM sym
, int for_write
)
2036 #define FUNC_NAME "export_environment_cell"
2038 struct export_environment
*body
= EXPORT_ENVIRONMENT (env
);
2039 SCM entry
= scm_assq (sym
, body
->signature
);
2041 if (SCM_FALSEP (entry
))
2043 return SCM_UNDEFINED
;
2047 if (!for_write
|| SCM_EQ_P (SCM_CADR (entry
), symbol_mutable_location
))
2048 return SCM_ENVIRONMENT_CELL (body
->private, sym
, for_write
);
2050 return SCM_ENVIRONMENT_LOCATION_IMMUTABLE
;
2057 export_environment_mark (SCM env
)
2059 struct export_environment
*body
= EXPORT_ENVIRONMENT (env
);
2061 scm_gc_mark (body
->private);
2062 scm_gc_mark (body
->private_observer
);
2063 scm_gc_mark (body
->signature
);
2065 return core_environments_mark (env
);
2070 export_environment_free (SCM env
)
2072 core_environments_finalize (env
);
2073 scm_gc_free (EXPORT_ENVIRONMENT (env
), sizeof (struct export_environment
),
2074 "export environment");
2079 export_environment_print (SCM type
, SCM port
,
2080 scm_print_state
*pstate SCM_UNUSED
)
2082 SCM address
= scm_ulong2num (SCM_UNPACK (type
));
2083 SCM base16
= scm_number_to_string (address
, SCM_MAKINUM (16));
2085 scm_puts ("#<export environment ", port
);
2086 scm_puts (SCM_STRING_CHARS (base16
), port
);
2087 scm_puts (">", port
);
2093 static struct scm_environment_funcs export_environment_funcs
= {
2094 export_environment_ref
,
2095 export_environment_fold
,
2096 export_environment_define
,
2097 export_environment_undefine
,
2098 export_environment_set_x
,
2099 export_environment_cell
,
2100 core_environments_observe
,
2101 core_environments_unobserve
,
2102 export_environment_mark
,
2103 export_environment_free
,
2104 export_environment_print
2108 void *scm_type_export_environment
= &export_environment_funcs
;
2112 export_environment_observer (SCM caller SCM_UNUSED
, SCM export_env
)
2114 core_environments_broadcast (export_env
);
2118 SCM_DEFINE (scm_make_export_environment
, "make-export-environment", 2, 0, 0,
2119 (SCM
private, SCM signature
),
2120 "Return a new environment @var{exp} containing only those\n"
2121 "bindings in private whose symbols are present in\n"
2122 "@var{signature}. The @var{private} argument must be an\n"
2124 "The environment @var{exp} binds symbol to location when\n"
2125 "@var{env} does, and symbol is exported by @var{signature}.\n\n"
2126 "@var{signature} is a list specifying which of the bindings in\n"
2127 "@var{private} should be visible in @var{exp}. Each element of\n"
2128 "@var{signature} should be a list of the form:\n"
2129 " (symbol attribute ...)\n"
2130 "where each attribute is one of the following:\n"
2132 "@item the symbol @code{mutable-location}\n"
2133 " @var{exp} should treat the\n"
2134 " location bound to symbol as mutable. That is, @var{exp}\n"
2135 " will pass calls to @code{environment-set!} or\n"
2136 " @code{environment-cell} directly through to private.\n"
2137 "@item the symbol @code{immutable-location}\n"
2138 " @var{exp} should treat\n"
2139 " the location bound to symbol as immutable. If the program\n"
2140 " applies @code{environment-set!} to @var{exp} and symbol, or\n"
2141 " calls @code{environment-cell} to obtain a writable value\n"
2142 " cell, @code{environment-set!} will signal an\n"
2143 " @code{environment:immutable-location} error. Note that, even\n"
2144 " if an export environment treats a location as immutable, the\n"
2145 " underlying environment may treat it as mutable, so its\n"
2146 " value may change.\n"
2148 "It is an error for an element of signature to specify both\n"
2149 "@code{mutable-location} and @code{immutable-location}. If\n"
2150 "neither is specified, @code{immutable-location} is assumed.\n\n"
2151 "As a special case, if an element of signature is a lone\n"
2152 "symbol @var{sym}, it is equivalent to an element of the form\n"
2154 "All bindings in @var{exp} are immutable. If you apply\n"
2155 "@code{environment-define} or @code{environment-undefine} to\n"
2156 "@var{exp}, Guile will signal an\n"
2157 "@code{environment:immutable-binding} error. However,\n"
2158 "notice that the set of bindings in @var{exp} may still change,\n"
2159 "if the bindings in private change.")
2160 #define FUNC_NAME s_scm_make_export_environment
2163 struct export_environment
*body
;
2166 SCM_ASSERT (SCM_ENVIRONMENT_P (private), private, SCM_ARG1
, FUNC_NAME
);
2168 size
= sizeof (struct export_environment
);
2169 body
= scm_gc_malloc (size
, "export environment");
2171 core_environments_preinit (&body
->base
);
2172 body
->private = SCM_BOOL_F
;
2173 body
->private_observer
= SCM_BOOL_F
;
2174 body
->signature
= SCM_BOOL_F
;
2176 env
= scm_make_environment (body
);
2178 core_environments_init (&body
->base
, &export_environment_funcs
);
2179 body
->private = private;
2180 body
->private_observer
2181 = SCM_ENVIRONMENT_OBSERVE (private, export_environment_observer
, env
, 1);
2182 body
->signature
= SCM_EOL
;
2184 scm_export_environment_set_signature_x (env
, signature
);
2191 SCM_DEFINE (scm_export_environment_p
, "export-environment?", 1, 0, 0,
2193 "Return @code{#t} if object is an export environment, or\n"
2194 "@code{#f} otherwise.")
2195 #define FUNC_NAME s_scm_export_environment_p
2197 return SCM_BOOL (SCM_EXPORT_ENVIRONMENT_P (object
));
2202 SCM_DEFINE (scm_export_environment_private
, "export-environment-private", 1, 0, 0,
2204 "Return the private environment of export environment @var{env}.")
2205 #define FUNC_NAME s_scm_export_environment_private
2207 SCM_ASSERT (SCM_EXPORT_ENVIRONMENT_P (env
), env
, SCM_ARG1
, FUNC_NAME
);
2209 return EXPORT_ENVIRONMENT (env
)->private;
2214 SCM_DEFINE (scm_export_environment_set_private_x
, "export-environment-set-private!", 2, 0, 0,
2215 (SCM env
, SCM
private),
2216 "Change the private environment of export environment @var{env}.")
2217 #define FUNC_NAME s_scm_export_environment_set_private_x
2219 struct export_environment
*body
;
2221 SCM_ASSERT (SCM_EXPORT_ENVIRONMENT_P (env
), env
, SCM_ARG1
, FUNC_NAME
);
2222 SCM_ASSERT (SCM_ENVIRONMENT_P (private), private, SCM_ARG2
, FUNC_NAME
);
2224 body
= EXPORT_ENVIRONMENT (env
);
2225 SCM_ENVIRONMENT_UNOBSERVE (private, body
->private_observer
);
2227 body
->private = private;
2228 body
->private_observer
2229 = SCM_ENVIRONMENT_OBSERVE (private, export_environment_observer
, env
, 1);
2231 return SCM_UNSPECIFIED
;
2236 SCM_DEFINE (scm_export_environment_signature
, "export-environment-signature", 1, 0, 0,
2238 "Return the signature of export environment @var{env}.")
2239 #define FUNC_NAME s_scm_export_environment_signature
2241 SCM_ASSERT (SCM_EXPORT_ENVIRONMENT_P (env
), env
, SCM_ARG1
, FUNC_NAME
);
2243 return EXPORT_ENVIRONMENT (env
)->signature
;
2249 export_environment_parse_signature (SCM signature
, const char* caller
)
2251 SCM result
= SCM_EOL
;
2254 for (l
= signature
; SCM_CONSP (l
); l
= SCM_CDR (l
))
2256 SCM entry
= SCM_CAR (l
);
2258 if (SCM_SYMBOLP (entry
))
2260 SCM new_entry
= scm_cons2 (entry
, symbol_immutable_location
, SCM_EOL
);
2261 result
= scm_cons (new_entry
, result
);
2272 SCM_ASSERT (SCM_CONSP (entry
), entry
, SCM_ARGn
, caller
);
2273 SCM_ASSERT (SCM_SYMBOLP (SCM_CAR (entry
)), entry
, SCM_ARGn
, caller
);
2275 sym
= SCM_CAR (entry
);
2277 for (l2
= SCM_CDR (entry
); SCM_CONSP (l2
); l2
= SCM_CDR (l2
))
2279 SCM attribute
= SCM_CAR (l2
);
2280 if (SCM_EQ_P (attribute
, symbol_immutable_location
))
2282 else if (SCM_EQ_P (attribute
, symbol_mutable_location
))
2285 SCM_ASSERT (0, entry
, SCM_ARGn
, caller
);
2287 SCM_ASSERT (SCM_NULLP (l2
), entry
, SCM_ARGn
, caller
);
2288 SCM_ASSERT (!mutable || !immutable
, entry
, SCM_ARGn
, caller
);
2290 if (!mutable && !immutable
)
2293 mutability
= mutable ? symbol_mutable_location
: symbol_immutable_location
;
2294 new_entry
= scm_cons2 (sym
, mutability
, SCM_EOL
);
2295 result
= scm_cons (new_entry
, result
);
2298 SCM_ASSERT (SCM_NULLP (l
), signature
, SCM_ARGn
, caller
);
2300 /* Dirk:FIXME:: Now we know that signature is syntactically correct. There
2301 * are, however, no checks for symbols entered twice with contradicting
2302 * mutabilities. It would be nice, to implement this test, to be able to
2303 * call the sort functions conveniently from C.
2306 return scm_reverse (result
);
2310 SCM_DEFINE (scm_export_environment_set_signature_x
, "export-environment-set-signature!", 2, 0, 0,
2311 (SCM env
, SCM signature
),
2312 "Change the signature of export environment @var{env}.")
2313 #define FUNC_NAME s_scm_export_environment_set_signature_x
2317 SCM_ASSERT (SCM_EXPORT_ENVIRONMENT_P (env
), env
, SCM_ARG1
, FUNC_NAME
);
2318 parsed_sig
= export_environment_parse_signature (signature
, FUNC_NAME
);
2320 EXPORT_ENVIRONMENT (env
)->signature
= parsed_sig
;
2322 return SCM_UNSPECIFIED
;
2329 scm_environments_prehistory ()
2331 /* create environment smob */
2332 scm_tc16_environment
= scm_make_smob_type ("environment", 0);
2333 scm_set_smob_mark (scm_tc16_environment
, environment_mark
);
2334 scm_set_smob_free (scm_tc16_environment
, environment_free
);
2335 scm_set_smob_print (scm_tc16_environment
, environment_print
);
2337 /* create observer smob */
2338 scm_tc16_observer
= scm_make_smob_type ("observer", 0);
2339 scm_set_smob_mark (scm_tc16_observer
, observer_mark
);
2340 scm_set_smob_print (scm_tc16_observer
, observer_print
);
2342 /* create system environment */
2343 scm_system_environment
= scm_make_leaf_environment ();
2344 scm_permanent_object (scm_system_environment
);
2349 scm_init_environments ()
2351 #include "libguile/environments.x"