1 /* Copyright (C) 1999,2000,2001, 2003 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 31
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_HASHTABLE_N_BUCKETS (obarray
);
535 SCM entry
= scm_cons (symbol
, data
);
536 SCM slot
= scm_cons (entry
, SCM_HASHTABLE_BUCKETS (obarray
)[hash
]);
537 SCM_SET_HASHTABLE_BUCKET (obarray
, hash
, slot
);
538 if (SCM_HASHTABLE_N_ITEMS (obarray
) > SCM_HASHTABLE_UPPER (obarray
))
539 scm_i_rehash (obarray
, scm_i_hash_symbol
, 0, "obarray_enter");
546 * Enter symbol into obarray. An existing entry for symbol is replaced. If
547 * an entry existed, the old (symbol . data) cell is returned, #f otherwise.
550 obarray_replace (SCM obarray
, SCM symbol
, SCM data
)
552 size_t hash
= SCM_SYMBOL_HASH (symbol
) % SCM_HASHTABLE_N_BUCKETS (obarray
);
553 SCM new_entry
= scm_cons (symbol
, data
);
557 for (lsym
= SCM_HASHTABLE_BUCKETS (obarray
)[hash
];
559 lsym
= SCM_CDR (lsym
))
561 SCM old_entry
= SCM_CAR (lsym
);
562 if (SCM_EQ_P (SCM_CAR (old_entry
), symbol
))
564 SCM_SETCAR (lsym
, new_entry
);
569 slot
= scm_cons (new_entry
, SCM_HASHTABLE_BUCKETS (obarray
)[hash
]);
570 SCM_SET_HASHTABLE_BUCKET (obarray
, hash
, slot
);
571 if (SCM_HASHTABLE_N_ITEMS (obarray
) > SCM_HASHTABLE_UPPER (obarray
))
572 scm_i_rehash (obarray
, scm_i_hash_symbol
, 0, "obarray_replace");
579 * Look up symbol in obarray
582 obarray_retrieve (SCM obarray
, SCM sym
)
584 size_t hash
= SCM_SYMBOL_HASH (sym
) % SCM_HASHTABLE_N_BUCKETS (obarray
);
587 for (lsym
= SCM_HASHTABLE_BUCKETS (obarray
)[hash
];
589 lsym
= SCM_CDR (lsym
))
591 SCM entry
= SCM_CAR (lsym
);
592 if (SCM_EQ_P (SCM_CAR (entry
), sym
))
596 return SCM_UNDEFINED
;
601 * Remove entry from obarray. If the symbol was found and removed, the old
602 * (symbol . data) cell is returned, #f otherwise.
605 obarray_remove (SCM obarray
, SCM sym
)
607 size_t hash
= SCM_SYMBOL_HASH (sym
) % SCM_HASHTABLE_N_BUCKETS (obarray
);
608 SCM table_entry
= SCM_HASHTABLE_BUCKETS (obarray
)[hash
];
609 SCM handle
= scm_sloppy_assq (sym
, table_entry
);
611 if (SCM_CONSP (handle
))
613 SCM new_table_entry
= scm_delq1_x (handle
, table_entry
);
614 SCM_SET_HASHTABLE_BUCKET (obarray
, hash
, new_table_entry
);
615 SCM_HASHTABLE_DECREMENT (obarray
);
623 obarray_remove_all (SCM obarray
)
625 size_t size
= SCM_HASHTABLE_N_BUCKETS (obarray
);
628 for (i
= 0; i
< size
; i
++)
630 SCM_SET_HASHTABLE_BUCKET (obarray
, i
, SCM_EOL
);
632 SCM_SET_HASHTABLE_N_ITEMS (obarray
, 0);
637 /* core environments base
639 * This struct and the corresponding functions form a base class for guile's
640 * built-in environment types.
644 struct core_environments_base
{
645 struct scm_environment_funcs
*funcs
;
652 #define CORE_ENVIRONMENTS_BASE(env) \
653 ((struct core_environments_base *) SCM_CELL_WORD_1 (env))
654 #define CORE_ENVIRONMENT_OBSERVERS(env) \
655 (CORE_ENVIRONMENTS_BASE (env)->observers)
656 #define SCM_SET_CORE_ENVIRONMENT_OBSERVERS(env, v) \
657 (CORE_ENVIRONMENT_OBSERVERS (env) = (v))
658 #define CORE_ENVIRONMENT_WEAK_OBSERVER_VECTOR(env) \
659 (CORE_ENVIRONMENTS_BASE (env)->weak_observers)
660 #define CORE_ENVIRONMENT_WEAK_OBSERVERS(env) \
661 (SCM_VELTS (CORE_ENVIRONMENT_WEAK_OBSERVER_VECTOR (env)) [0])
662 #define SCM_SET_CORE_ENVIRONMENT_WEAK_OBSERVERS(env, v) \
663 (SCM_VECTOR_SET (CORE_ENVIRONMENT_WEAK_OBSERVER_VECTOR (env), 0, (v)))
668 core_environments_observe (SCM env
, scm_environment_observer proc
, SCM data
, int weak_p
)
670 SCM observer
= scm_double_cell (scm_tc16_observer
,
677 SCM observers
= CORE_ENVIRONMENT_OBSERVERS (env
);
678 SCM new_observers
= scm_cons (observer
, observers
);
679 SCM_SET_CORE_ENVIRONMENT_OBSERVERS (env
, new_observers
);
683 SCM observers
= CORE_ENVIRONMENT_WEAK_OBSERVERS (env
);
684 SCM new_observers
= scm_acons (SCM_BOOL_F
, observer
, observers
);
685 SCM_SET_CORE_ENVIRONMENT_WEAK_OBSERVERS (env
, new_observers
);
693 core_environments_unobserve (SCM env
, SCM observer
)
695 unsigned int handling_weaks
;
696 for (handling_weaks
= 0; handling_weaks
<= 1; ++handling_weaks
)
698 SCM l
= handling_weaks
699 ? CORE_ENVIRONMENT_WEAK_OBSERVERS (env
)
700 : CORE_ENVIRONMENT_OBSERVERS (env
);
704 SCM rest
= SCM_CDR (l
);
705 SCM first
= handling_weaks
709 if (SCM_EQ_P (first
, observer
))
711 /* Remove the first observer */
713 ? SCM_SET_CORE_ENVIRONMENT_WEAK_OBSERVERS (env
, rest
)
714 : SCM_SET_CORE_ENVIRONMENT_OBSERVERS (env
, rest
);
719 SCM rest
= SCM_CDR (l
);
721 if (!SCM_NULLP (rest
))
723 SCM next
= handling_weaks
727 if (SCM_EQ_P (next
, observer
))
729 SCM_SETCDR (l
, SCM_CDR (rest
));
735 } while (!SCM_NULLP (l
));
739 /* Dirk:FIXME:: What to do now, since the observer is not found? */
744 core_environments_mark (SCM env
)
746 scm_gc_mark (CORE_ENVIRONMENT_OBSERVERS (env
));
747 return CORE_ENVIRONMENT_WEAK_OBSERVER_VECTOR (env
);
752 core_environments_finalize (SCM env SCM_UNUSED
)
758 core_environments_preinit (struct core_environments_base
*body
)
761 body
->observers
= SCM_BOOL_F
;
762 body
->weak_observers
= SCM_BOOL_F
;
767 core_environments_init (struct core_environments_base
*body
,
768 struct scm_environment_funcs
*funcs
)
771 body
->observers
= SCM_EOL
;
772 body
->weak_observers
= scm_make_weak_value_alist_vector (SCM_MAKINUM (1));
776 /* Tell all observers to clear their caches.
778 * Environments have to be informed about changes in the following cases:
779 * - The observed env has a new binding. This must be always reported.
780 * - The observed env has dropped a binding. This must be always reported.
781 * - A binding in the observed environment has changed. This must only be
782 * reported, if there is a chance that the binding is being cached outside.
783 * However, this potential optimization is not performed currently.
785 * Errors that occur while the observers are called are accumulated and
786 * signalled as one single error message to the caller.
797 update_catch_body (void *ptr
)
799 struct update_data
*data
= (struct update_data
*) ptr
;
800 SCM observer
= data
->observer
;
802 (*SCM_OBSERVER_PROC (observer
))
803 (data
->environment
, SCM_OBSERVER_DATA (observer
));
805 return SCM_UNDEFINED
;
810 update_catch_handler (void *ptr
, SCM tag
, SCM args
)
812 struct update_data
*data
= (struct update_data
*) ptr
;
813 SCM observer
= data
->observer
;
814 SCM message
= scm_makfrom0str ("Observer `~A' signals `~A' error: ~S");
816 return scm_cons (message
, scm_list_3 (observer
, tag
, args
));
821 core_environments_broadcast (SCM env
)
822 #define FUNC_NAME "core_environments_broadcast"
824 unsigned int handling_weaks
;
825 SCM errors
= SCM_EOL
;
827 for (handling_weaks
= 0; handling_weaks
<= 1; ++handling_weaks
)
829 SCM observers
= handling_weaks
830 ? CORE_ENVIRONMENT_WEAK_OBSERVERS (env
)
831 : CORE_ENVIRONMENT_OBSERVERS (env
);
833 for (; !SCM_NULLP (observers
); observers
= SCM_CDR (observers
))
835 struct update_data data
;
836 SCM observer
= handling_weaks
837 ? SCM_CDAR (observers
)
838 : SCM_CAR (observers
);
841 data
.observer
= observer
;
842 data
.environment
= env
;
844 error
= scm_internal_catch (SCM_BOOL_T
,
845 update_catch_body
, &data
,
846 update_catch_handler
, &data
);
848 if (!SCM_UNBNDP (error
))
849 errors
= scm_cons (error
, errors
);
853 if (!SCM_NULLP (errors
))
855 /* Dirk:FIXME:: As soon as scm_misc_error is fixed to handle the name
856 * parameter correctly it should not be necessary any more to also pass
857 * namestr in order to get the desired information from the error
860 SCM ordered_errors
= scm_reverse (errors
);
863 "Observers of `~A' have signalled the following errors: ~S",
864 scm_cons2 (env
, ordered_errors
, SCM_EOL
));
873 * A leaf environment is simply a mutable set of definitions. A leaf
874 * environment supports no operations beyond the common set.
876 * Implementation: The obarray of the leaf environment holds (symbol . value)
877 * pairs. No further information is necessary, since all bindings and
878 * locations in a leaf environment are mutable.
882 struct leaf_environment
{
883 struct core_environments_base base
;
889 #define LEAF_ENVIRONMENT(env) \
890 ((struct leaf_environment *) SCM_CELL_WORD_1 (env))
895 leaf_environment_ref (SCM env
, SCM sym
)
897 SCM obarray
= LEAF_ENVIRONMENT (env
)->obarray
;
898 SCM binding
= obarray_retrieve (obarray
, sym
);
899 return SCM_UNBNDP (binding
) ? binding
: SCM_CDR (binding
);
904 leaf_environment_fold (SCM env
, scm_environment_folder proc
, SCM data
, SCM init
)
908 SCM obarray
= LEAF_ENVIRONMENT (env
)->obarray
;
910 for (i
= 0; i
< SCM_HASHTABLE_N_BUCKETS (obarray
); i
++)
913 for (l
= SCM_HASHTABLE_BUCKETS (obarray
)[i
];
917 SCM binding
= SCM_CAR (l
);
918 SCM symbol
= SCM_CAR (binding
);
919 SCM value
= SCM_CDR (binding
);
920 result
= (*proc
) (data
, symbol
, value
, result
);
928 leaf_environment_define (SCM env
, SCM sym
, SCM val
)
929 #define FUNC_NAME "leaf_environment_define"
931 SCM obarray
= LEAF_ENVIRONMENT (env
)->obarray
;
933 obarray_replace (obarray
, sym
, val
);
934 core_environments_broadcast (env
);
936 return SCM_ENVIRONMENT_SUCCESS
;
942 leaf_environment_undefine (SCM env
, SCM sym
)
943 #define FUNC_NAME "leaf_environment_undefine"
945 SCM obarray
= LEAF_ENVIRONMENT (env
)->obarray
;
946 SCM removed
= obarray_remove (obarray
, sym
);
948 if (!SCM_FALSEP (removed
))
949 core_environments_broadcast (env
);
951 return SCM_ENVIRONMENT_SUCCESS
;
957 leaf_environment_set_x (SCM env
, SCM sym
, SCM val
)
958 #define FUNC_NAME "leaf_environment_set_x"
960 SCM obarray
= LEAF_ENVIRONMENT (env
)->obarray
;
961 SCM binding
= obarray_retrieve (obarray
, sym
);
963 if (!SCM_UNBNDP (binding
))
965 SCM_SETCDR (binding
, val
);
966 return SCM_ENVIRONMENT_SUCCESS
;
970 return SCM_UNDEFINED
;
977 leaf_environment_cell (SCM env
, SCM sym
, int for_write SCM_UNUSED
)
979 SCM obarray
= LEAF_ENVIRONMENT (env
)->obarray
;
980 SCM binding
= obarray_retrieve (obarray
, sym
);
986 leaf_environment_mark (SCM env
)
988 scm_gc_mark (LEAF_ENVIRONMENT (env
)->obarray
);
989 return core_environments_mark (env
);
994 leaf_environment_free (SCM env
)
996 core_environments_finalize (env
);
997 scm_gc_free (LEAF_ENVIRONMENT (env
), sizeof (struct leaf_environment
),
1003 leaf_environment_print (SCM type
, SCM port
, scm_print_state
*pstate SCM_UNUSED
)
1005 SCM address
= scm_ulong2num (SCM_UNPACK (type
));
1006 SCM base16
= scm_number_to_string (address
, SCM_MAKINUM (16));
1008 scm_puts ("#<leaf environment ", port
);
1009 scm_puts (SCM_STRING_CHARS (base16
), port
);
1010 scm_puts (">", port
);
1016 static struct scm_environment_funcs leaf_environment_funcs
= {
1017 leaf_environment_ref
,
1018 leaf_environment_fold
,
1019 leaf_environment_define
,
1020 leaf_environment_undefine
,
1021 leaf_environment_set_x
,
1022 leaf_environment_cell
,
1023 core_environments_observe
,
1024 core_environments_unobserve
,
1025 leaf_environment_mark
,
1026 leaf_environment_free
,
1027 leaf_environment_print
1031 void *scm_type_leaf_environment
= &leaf_environment_funcs
;
1034 SCM_DEFINE (scm_make_leaf_environment
, "make-leaf-environment", 0, 0, 0,
1036 "Create a new leaf environment, containing no bindings.\n"
1037 "All bindings and locations created in the new environment\n"
1039 #define FUNC_NAME s_scm_make_leaf_environment
1041 size_t size
= sizeof (struct leaf_environment
);
1042 struct leaf_environment
*body
= scm_gc_malloc (size
, "leaf environment");
1045 core_environments_preinit (&body
->base
);
1046 body
->obarray
= SCM_BOOL_F
;
1048 env
= scm_make_environment (body
);
1050 core_environments_init (&body
->base
, &leaf_environment_funcs
);
1051 body
->obarray
= scm_c_make_hash_table (DEFAULT_OBARRAY_SIZE
);
1058 SCM_DEFINE (scm_leaf_environment_p
, "leaf-environment?", 1, 0, 0,
1060 "Return @code{#t} if object is a leaf environment, or @code{#f}\n"
1062 #define FUNC_NAME s_scm_leaf_environment_p
1064 return SCM_BOOL (SCM_LEAF_ENVIRONMENT_P (object
));
1070 /* eval environments
1072 * A module's source code refers to definitions imported from other modules,
1073 * and definitions made within itself. An eval environment combines two
1074 * environments -- a local environment and an imported environment -- to
1075 * produce a new environment in which both sorts of references can be
1078 * Implementation: The obarray of the eval environment is used to cache
1079 * entries from the local and imported environments such that in most of the
1080 * cases only a single lookup is necessary. Since for neither the local nor
1081 * the imported environment it is known, what kind of environment they form,
1082 * the most general case is assumed. Therefore, entries in the obarray take
1083 * one of the following forms:
1085 * 1) (<symbol> location mutability . source-env), where mutability indicates
1086 * one of the following states: IMMUTABLE if the location is known to be
1087 * immutable, MUTABLE if the location is known to be mutable, UNKNOWN if
1088 * the location has only been requested for non modifying accesses.
1090 * 2) (symbol . source-env) if the symbol has a binding in the source-env, but
1091 * if the source-env can't provide a cell for the binding. Thus, for every
1092 * access, the source-env has to be contacted directly.
1096 struct eval_environment
{
1097 struct core_environments_base base
;
1102 SCM imported_observer
;
1108 #define EVAL_ENVIRONMENT(env) \
1109 ((struct eval_environment *) SCM_CELL_WORD_1 (env))
1111 #define IMMUTABLE SCM_MAKINUM (0)
1112 #define MUTABLE SCM_MAKINUM (1)
1113 #define UNKNOWN SCM_MAKINUM (2)
1115 #define CACHED_LOCATION(x) SCM_CAR (x)
1116 #define CACHED_MUTABILITY(x) SCM_CADR (x)
1117 #define SET_CACHED_MUTABILITY(x, v) SCM_SETCAR (SCM_CDR (x), (v))
1118 #define CACHED_SOURCE_ENVIRONMENT(x) SCM_CDDR (x)
1122 /* eval_environment_lookup will report one of the following distinct results:
1123 * a) (<object> . value) if a cell could be obtained.
1124 * b) <environment> if the environment has to be contacted directly.
1125 * c) IMMUTABLE if an immutable cell was requested for write.
1126 * d) SCM_UNDEFINED if there is no binding for the symbol.
1129 eval_environment_lookup (SCM env
, SCM sym
, int for_write
)
1131 SCM obarray
= EVAL_ENVIRONMENT (env
)->obarray
;
1132 SCM binding
= obarray_retrieve (obarray
, sym
);
1134 if (!SCM_UNBNDP (binding
))
1136 /* The obarray holds an entry for the symbol. */
1138 SCM entry
= SCM_CDR (binding
);
1140 if (SCM_CONSP (entry
))
1142 /* The entry in the obarray is a cached location. */
1144 SCM location
= CACHED_LOCATION (entry
);
1150 mutability
= CACHED_MUTABILITY (entry
);
1151 if (SCM_EQ_P (mutability
, MUTABLE
))
1154 if (SCM_EQ_P (mutability
, UNKNOWN
))
1156 SCM source_env
= CACHED_SOURCE_ENVIRONMENT (entry
);
1157 SCM location
= SCM_ENVIRONMENT_CELL (source_env
, sym
, 1);
1159 if (SCM_CONSP (location
))
1161 SET_CACHED_MUTABILITY (entry
, MUTABLE
);
1164 else /* IMMUTABLE */
1166 SET_CACHED_MUTABILITY (entry
, IMMUTABLE
);
1175 /* The obarray entry is an environment */
1182 /* There is no entry for the symbol in the obarray. This can either
1183 * mean that there has not been a request for the symbol yet, or that
1184 * the symbol is really undefined. We are looking for the symbol in
1185 * both the local and the imported environment. If we find a binding, a
1186 * cached entry is created.
1189 struct eval_environment
*body
= EVAL_ENVIRONMENT (env
);
1190 unsigned int handling_import
;
1192 for (handling_import
= 0; handling_import
<= 1; ++handling_import
)
1194 SCM source_env
= handling_import
? body
->imported
: body
->local
;
1195 SCM location
= SCM_ENVIRONMENT_CELL (source_env
, sym
, for_write
);
1197 if (!SCM_UNBNDP (location
))
1199 if (SCM_CONSP (location
))
1201 SCM mutability
= for_write
? MUTABLE
: UNKNOWN
;
1202 SCM entry
= scm_cons2 (location
, mutability
, source_env
);
1203 obarray_enter (obarray
, sym
, entry
);
1206 else if (SCM_EQ_P (location
, SCM_ENVIRONMENT_LOCATION_NO_CELL
))
1208 obarray_enter (obarray
, sym
, source_env
);
1218 return SCM_UNDEFINED
;
1224 eval_environment_ref (SCM env
, SCM sym
)
1225 #define FUNC_NAME "eval_environment_ref"
1227 SCM location
= eval_environment_lookup (env
, sym
, 0);
1229 if (SCM_CONSP (location
))
1230 return SCM_CDR (location
);
1231 else if (!SCM_UNBNDP (location
))
1232 return SCM_ENVIRONMENT_REF (location
, sym
);
1234 return SCM_UNDEFINED
;
1240 eval_environment_folder (SCM extended_data
, SCM symbol
, SCM value
, SCM tail
)
1242 SCM local
= SCM_CAR (extended_data
);
1244 if (!SCM_ENVIRONMENT_BOUND_P (local
, symbol
))
1246 SCM proc_as_nr
= SCM_CADR (extended_data
);
1247 unsigned long int proc_as_ul
= scm_num2ulong (proc_as_nr
, 0, NULL
);
1248 scm_environment_folder proc
= (scm_environment_folder
) proc_as_ul
;
1249 SCM data
= SCM_CDDR (extended_data
);
1251 return (*proc
) (data
, symbol
, value
, tail
);
1261 eval_environment_fold (SCM env
, scm_environment_folder proc
, SCM data
, SCM init
)
1263 SCM local
= EVAL_ENVIRONMENT (env
)->local
;
1264 SCM imported
= EVAL_ENVIRONMENT (env
)->imported
;
1265 SCM proc_as_nr
= scm_ulong2num ((unsigned long int) proc
);
1266 SCM extended_data
= scm_cons2 (local
, proc_as_nr
, data
);
1267 SCM tmp_result
= scm_c_environment_fold (imported
, eval_environment_folder
, extended_data
, init
);
1269 return scm_c_environment_fold (local
, proc
, data
, tmp_result
);
1274 eval_environment_define (SCM env
, SCM sym
, SCM val
)
1275 #define FUNC_NAME "eval_environment_define"
1277 SCM local
= EVAL_ENVIRONMENT (env
)->local
;
1278 return SCM_ENVIRONMENT_DEFINE (local
, sym
, val
);
1284 eval_environment_undefine (SCM env
, SCM sym
)
1285 #define FUNC_NAME "eval_environment_undefine"
1287 SCM local
= EVAL_ENVIRONMENT (env
)->local
;
1288 return SCM_ENVIRONMENT_UNDEFINE (local
, sym
);
1294 eval_environment_set_x (SCM env
, SCM sym
, SCM val
)
1295 #define FUNC_NAME "eval_environment_set_x"
1297 SCM location
= eval_environment_lookup (env
, sym
, 1);
1299 if (SCM_CONSP (location
))
1301 SCM_SETCDR (location
, val
);
1302 return SCM_ENVIRONMENT_SUCCESS
;
1304 else if (SCM_ENVIRONMENT_P (location
))
1306 return SCM_ENVIRONMENT_SET (location
, sym
, val
);
1308 else if (SCM_EQ_P (location
, IMMUTABLE
))
1310 return SCM_ENVIRONMENT_LOCATION_IMMUTABLE
;
1314 return SCM_UNDEFINED
;
1321 eval_environment_cell (SCM env
, SCM sym
, int for_write
)
1322 #define FUNC_NAME "eval_environment_cell"
1324 SCM location
= eval_environment_lookup (env
, sym
, for_write
);
1326 if (SCM_CONSP (location
))
1328 else if (SCM_ENVIRONMENT_P (location
))
1329 return SCM_ENVIRONMENT_LOCATION_NO_CELL
;
1330 else if (SCM_EQ_P (location
, IMMUTABLE
))
1331 return SCM_ENVIRONMENT_LOCATION_IMMUTABLE
;
1333 return SCM_UNDEFINED
;
1339 eval_environment_mark (SCM env
)
1341 struct eval_environment
*body
= EVAL_ENVIRONMENT (env
);
1343 scm_gc_mark (body
->obarray
);
1344 scm_gc_mark (body
->imported
);
1345 scm_gc_mark (body
->imported_observer
);
1346 scm_gc_mark (body
->local
);
1347 scm_gc_mark (body
->local_observer
);
1349 return core_environments_mark (env
);
1354 eval_environment_free (SCM env
)
1356 core_environments_finalize (env
);
1357 scm_gc_free (EVAL_ENVIRONMENT (env
), sizeof (struct eval_environment
),
1358 "eval environment");
1363 eval_environment_print (SCM type
, SCM port
, scm_print_state
*pstate SCM_UNUSED
)
1365 SCM address
= scm_ulong2num (SCM_UNPACK (type
));
1366 SCM base16
= scm_number_to_string (address
, SCM_MAKINUM (16));
1368 scm_puts ("#<eval environment ", port
);
1369 scm_puts (SCM_STRING_CHARS (base16
), port
);
1370 scm_puts (">", port
);
1376 static struct scm_environment_funcs eval_environment_funcs
= {
1377 eval_environment_ref
,
1378 eval_environment_fold
,
1379 eval_environment_define
,
1380 eval_environment_undefine
,
1381 eval_environment_set_x
,
1382 eval_environment_cell
,
1383 core_environments_observe
,
1384 core_environments_unobserve
,
1385 eval_environment_mark
,
1386 eval_environment_free
,
1387 eval_environment_print
1391 void *scm_type_eval_environment
= &eval_environment_funcs
;
1395 eval_environment_observer (SCM caller SCM_UNUSED
, SCM eval_env
)
1397 SCM obarray
= EVAL_ENVIRONMENT (eval_env
)->obarray
;
1399 obarray_remove_all (obarray
);
1400 core_environments_broadcast (eval_env
);
1404 SCM_DEFINE (scm_make_eval_environment
, "make-eval-environment", 2, 0, 0,
1405 (SCM local
, SCM imported
),
1406 "Return a new environment object eval whose bindings are the\n"
1407 "union of the bindings in the environments @var{local} and\n"
1408 "@var{imported}, with bindings from @var{local} taking\n"
1409 "precedence. Definitions made in eval are placed in @var{local}.\n"
1410 "Applying @code{environment-define} or\n"
1411 "@code{environment-undefine} to eval has the same effect as\n"
1412 "applying the procedure to @var{local}.\n"
1413 "Note that eval incorporates @var{local} and @var{imported} by\n"
1415 "If, after creating eval, the program changes the bindings of\n"
1416 "@var{local} or @var{imported}, those changes will be visible\n"
1418 "Since most Scheme evaluation takes place in eval environments,\n"
1419 "they transparently cache the bindings received from @var{local}\n"
1420 "and @var{imported}. Thus, the first time the program looks up\n"
1421 "a symbol in eval, eval may make calls to @var{local} or\n"
1422 "@var{imported} to find their bindings, but subsequent\n"
1423 "references to that symbol will be as fast as references to\n"
1424 "bindings in finite environments.\n"
1425 "In typical use, @var{local} will be a finite environment, and\n"
1426 "@var{imported} will be an import environment")
1427 #define FUNC_NAME s_scm_make_eval_environment
1430 struct eval_environment
*body
;
1432 SCM_ASSERT (SCM_ENVIRONMENT_P (local
), local
, SCM_ARG1
, FUNC_NAME
);
1433 SCM_ASSERT (SCM_ENVIRONMENT_P (imported
), imported
, SCM_ARG2
, FUNC_NAME
);
1435 body
= scm_gc_malloc (sizeof (struct eval_environment
), "eval environment");
1437 core_environments_preinit (&body
->base
);
1438 body
->obarray
= SCM_BOOL_F
;
1439 body
->imported
= SCM_BOOL_F
;
1440 body
->imported_observer
= SCM_BOOL_F
;
1441 body
->local
= SCM_BOOL_F
;
1442 body
->local_observer
= SCM_BOOL_F
;
1444 env
= scm_make_environment (body
);
1446 core_environments_init (&body
->base
, &eval_environment_funcs
);
1447 body
->obarray
= scm_c_make_hash_table (DEFAULT_OBARRAY_SIZE
);
1448 body
->imported
= imported
;
1449 body
->imported_observer
1450 = SCM_ENVIRONMENT_OBSERVE (imported
, eval_environment_observer
, env
, 1);
1451 body
->local
= local
;
1452 body
->local_observer
1453 = SCM_ENVIRONMENT_OBSERVE (local
, eval_environment_observer
, env
, 1);
1460 SCM_DEFINE (scm_eval_environment_p
, "eval-environment?", 1, 0, 0,
1462 "Return @code{#t} if object is an eval environment, or @code{#f}\n"
1464 #define FUNC_NAME s_scm_eval_environment_p
1466 return SCM_BOOL (SCM_EVAL_ENVIRONMENT_P (object
));
1471 SCM_DEFINE (scm_eval_environment_local
, "eval-environment-local", 1, 0, 0,
1473 "Return the local environment of eval environment @var{env}.")
1474 #define FUNC_NAME s_scm_eval_environment_local
1476 SCM_ASSERT (SCM_EVAL_ENVIRONMENT_P (env
), env
, SCM_ARG1
, FUNC_NAME
);
1478 return EVAL_ENVIRONMENT (env
)->local
;
1483 SCM_DEFINE (scm_eval_environment_set_local_x
, "eval-environment-set-local!", 2, 0, 0,
1484 (SCM env
, SCM local
),
1485 "Change @var{env}'s local environment to @var{local}.")
1486 #define FUNC_NAME s_scm_eval_environment_set_local_x
1488 struct eval_environment
*body
;
1490 SCM_ASSERT (SCM_EVAL_ENVIRONMENT_P (env
), env
, SCM_ARG1
, FUNC_NAME
);
1491 SCM_ASSERT (SCM_ENVIRONMENT_P (local
), local
, SCM_ARG2
, FUNC_NAME
);
1493 body
= EVAL_ENVIRONMENT (env
);
1495 obarray_remove_all (body
->obarray
);
1496 SCM_ENVIRONMENT_UNOBSERVE (body
->local
, body
->local_observer
);
1498 body
->local
= local
;
1499 body
->local_observer
1500 = SCM_ENVIRONMENT_OBSERVE (local
, eval_environment_observer
, env
, 1);
1502 core_environments_broadcast (env
);
1504 return SCM_UNSPECIFIED
;
1509 SCM_DEFINE (scm_eval_environment_imported
, "eval-environment-imported", 1, 0, 0,
1511 "Return the imported environment of eval environment @var{env}.")
1512 #define FUNC_NAME s_scm_eval_environment_imported
1514 SCM_ASSERT (SCM_EVAL_ENVIRONMENT_P (env
), env
, SCM_ARG1
, FUNC_NAME
);
1516 return EVAL_ENVIRONMENT (env
)->imported
;
1521 SCM_DEFINE (scm_eval_environment_set_imported_x
, "eval-environment-set-imported!", 2, 0, 0,
1522 (SCM env
, SCM imported
),
1523 "Change @var{env}'s imported environment to @var{imported}.")
1524 #define FUNC_NAME s_scm_eval_environment_set_imported_x
1526 struct eval_environment
*body
;
1528 SCM_ASSERT (SCM_EVAL_ENVIRONMENT_P (env
), env
, SCM_ARG1
, FUNC_NAME
);
1529 SCM_ASSERT (SCM_ENVIRONMENT_P (imported
), imported
, SCM_ARG2
, FUNC_NAME
);
1531 body
= EVAL_ENVIRONMENT (env
);
1533 obarray_remove_all (body
->obarray
);
1534 SCM_ENVIRONMENT_UNOBSERVE (body
->imported
, body
->imported_observer
);
1536 body
->imported
= imported
;
1537 body
->imported_observer
1538 = SCM_ENVIRONMENT_OBSERVE (imported
, eval_environment_observer
, env
, 1);
1540 core_environments_broadcast (env
);
1542 return SCM_UNSPECIFIED
;
1548 /* import environments
1550 * An import environment combines the bindings of a set of argument
1551 * environments, and checks for naming clashes.
1553 * Implementation: The import environment does no caching at all. For every
1554 * access, the list of imported environments is scanned.
1558 struct import_environment
{
1559 struct core_environments_base base
;
1562 SCM import_observers
;
1568 #define IMPORT_ENVIRONMENT(env) \
1569 ((struct import_environment *) SCM_CELL_WORD_1 (env))
1573 /* Lookup will report one of the following distinct results:
1574 * a) <environment> if only environment binds the symbol.
1575 * b) (env-1 env-2 ...) for conflicting bindings in env-1, ...
1576 * c) SCM_UNDEFINED if there is no binding for the symbol.
1579 import_environment_lookup (SCM env
, SCM sym
)
1581 SCM imports
= IMPORT_ENVIRONMENT (env
)->imports
;
1582 SCM result
= SCM_UNDEFINED
;
1585 for (l
= imports
; !SCM_NULLP (l
); l
= SCM_CDR (l
))
1587 SCM imported
= SCM_CAR (l
);
1589 if (SCM_ENVIRONMENT_BOUND_P (imported
, sym
))
1591 if (SCM_UNBNDP (result
))
1593 else if (SCM_CONSP (result
))
1594 result
= scm_cons (imported
, result
);
1596 result
= scm_cons2 (imported
, result
, SCM_EOL
);
1600 if (SCM_CONSP (result
))
1601 return scm_reverse (result
);
1608 import_environment_conflict (SCM env
, SCM sym
, SCM imports
)
1610 SCM conflict_proc
= IMPORT_ENVIRONMENT (env
)->conflict_proc
;
1611 SCM args
= scm_cons2 (env
, sym
, scm_cons (imports
, SCM_EOL
));
1613 return scm_apply_0 (conflict_proc
, args
);
1618 import_environment_ref (SCM env
, SCM sym
)
1619 #define FUNC_NAME "import_environment_ref"
1621 SCM owner
= import_environment_lookup (env
, sym
);
1623 if (SCM_UNBNDP (owner
))
1625 return SCM_UNDEFINED
;
1627 else if (SCM_CONSP (owner
))
1629 SCM resolve
= import_environment_conflict (env
, sym
, owner
);
1631 if (SCM_ENVIRONMENT_P (resolve
))
1632 return SCM_ENVIRONMENT_REF (resolve
, sym
);
1634 return SCM_UNSPECIFIED
;
1638 return SCM_ENVIRONMENT_REF (owner
, sym
);
1645 import_environment_folder (SCM extended_data
, SCM symbol
, SCM value
, SCM tail
)
1646 #define FUNC_NAME "import_environment_fold"
1648 SCM import_env
= SCM_CAR (extended_data
);
1649 SCM imported_env
= SCM_CADR (extended_data
);
1650 SCM owner
= import_environment_lookup (import_env
, symbol
);
1651 SCM proc_as_nr
= SCM_CADDR (extended_data
);
1652 unsigned long int proc_as_ul
= scm_num2ulong (proc_as_nr
, 0, NULL
);
1653 scm_environment_folder proc
= (scm_environment_folder
) proc_as_ul
;
1654 SCM data
= SCM_CDDDR (extended_data
);
1656 if (SCM_CONSP (owner
) && SCM_EQ_P (SCM_CAR (owner
), imported_env
))
1657 owner
= import_environment_conflict (import_env
, symbol
, owner
);
1659 if (SCM_ENVIRONMENT_P (owner
))
1660 return (*proc
) (data
, symbol
, value
, tail
);
1661 else /* unresolved conflict */
1662 return (*proc
) (data
, symbol
, SCM_UNSPECIFIED
, tail
);
1668 import_environment_fold (SCM env
, scm_environment_folder proc
, SCM data
, SCM init
)
1670 SCM proc_as_nr
= scm_ulong2num ((unsigned long int) proc
);
1674 for (l
= IMPORT_ENVIRONMENT (env
)->imports
; !SCM_NULLP (l
); l
= SCM_CDR (l
))
1676 SCM imported_env
= SCM_CAR (l
);
1677 SCM extended_data
= scm_cons (env
, scm_cons2 (imported_env
, proc_as_nr
, data
));
1679 result
= scm_c_environment_fold (imported_env
, import_environment_folder
, extended_data
, result
);
1687 import_environment_define (SCM env SCM_UNUSED
,
1690 #define FUNC_NAME "import_environment_define"
1692 return SCM_ENVIRONMENT_BINDING_IMMUTABLE
;
1698 import_environment_undefine (SCM env SCM_UNUSED
,
1700 #define FUNC_NAME "import_environment_undefine"
1702 return SCM_ENVIRONMENT_BINDING_IMMUTABLE
;
1708 import_environment_set_x (SCM env
, SCM sym
, SCM val
)
1709 #define FUNC_NAME "import_environment_set_x"
1711 SCM owner
= import_environment_lookup (env
, sym
);
1713 if (SCM_UNBNDP (owner
))
1715 return SCM_UNDEFINED
;
1717 else if (SCM_CONSP (owner
))
1719 SCM resolve
= import_environment_conflict (env
, sym
, owner
);
1721 if (SCM_ENVIRONMENT_P (resolve
))
1722 return SCM_ENVIRONMENT_SET (resolve
, sym
, val
);
1724 return SCM_ENVIRONMENT_LOCATION_IMMUTABLE
;
1728 return SCM_ENVIRONMENT_SET (owner
, sym
, val
);
1735 import_environment_cell (SCM env
, SCM sym
, int for_write
)
1736 #define FUNC_NAME "import_environment_cell"
1738 SCM owner
= import_environment_lookup (env
, sym
);
1740 if (SCM_UNBNDP (owner
))
1742 return SCM_UNDEFINED
;
1744 else if (SCM_CONSP (owner
))
1746 SCM resolve
= import_environment_conflict (env
, sym
, owner
);
1748 if (SCM_ENVIRONMENT_P (resolve
))
1749 return SCM_ENVIRONMENT_CELL (resolve
, sym
, for_write
);
1751 return SCM_ENVIRONMENT_LOCATION_NO_CELL
;
1755 return SCM_ENVIRONMENT_CELL (owner
, sym
, for_write
);
1762 import_environment_mark (SCM env
)
1764 scm_gc_mark (IMPORT_ENVIRONMENT (env
)->imports
);
1765 scm_gc_mark (IMPORT_ENVIRONMENT (env
)->import_observers
);
1766 scm_gc_mark (IMPORT_ENVIRONMENT (env
)->conflict_proc
);
1767 return core_environments_mark (env
);
1772 import_environment_free (SCM env
)
1774 core_environments_finalize (env
);
1775 scm_gc_free (IMPORT_ENVIRONMENT (env
), sizeof (struct import_environment
),
1776 "import environment");
1781 import_environment_print (SCM type
, SCM port
,
1782 scm_print_state
*pstate SCM_UNUSED
)
1784 SCM address
= scm_ulong2num (SCM_UNPACK (type
));
1785 SCM base16
= scm_number_to_string (address
, SCM_MAKINUM (16));
1787 scm_puts ("#<import environment ", port
);
1788 scm_puts (SCM_STRING_CHARS (base16
), port
);
1789 scm_puts (">", port
);
1795 static struct scm_environment_funcs import_environment_funcs
= {
1796 import_environment_ref
,
1797 import_environment_fold
,
1798 import_environment_define
,
1799 import_environment_undefine
,
1800 import_environment_set_x
,
1801 import_environment_cell
,
1802 core_environments_observe
,
1803 core_environments_unobserve
,
1804 import_environment_mark
,
1805 import_environment_free
,
1806 import_environment_print
1810 void *scm_type_import_environment
= &import_environment_funcs
;
1814 import_environment_observer (SCM caller SCM_UNUSED
, SCM import_env
)
1816 core_environments_broadcast (import_env
);
1820 SCM_DEFINE (scm_make_import_environment
, "make-import-environment", 2, 0, 0,
1821 (SCM imports
, SCM conflict_proc
),
1822 "Return a new environment @var{imp} whose bindings are the union\n"
1823 "of the bindings from the environments in @var{imports};\n"
1824 "@var{imports} must be a list of environments. That is,\n"
1825 "@var{imp} binds a symbol to a location when some element of\n"
1826 "@var{imports} does.\n"
1827 "If two different elements of @var{imports} have a binding for\n"
1828 "the same symbol, the @var{conflict-proc} is called with the\n"
1829 "following parameters: the import environment, the symbol and\n"
1830 "the list of the imported environments that bind the symbol.\n"
1831 "If the @var{conflict-proc} returns an environment @var{env},\n"
1832 "the conflict is considered as resolved and the binding from\n"
1833 "@var{env} is used. If the @var{conflict-proc} returns some\n"
1834 "non-environment object, the conflict is considered unresolved\n"
1835 "and the symbol is treated as unspecified in the import\n"
1837 "The checking for conflicts may be performed lazily, i. e. at\n"
1838 "the moment when a value or binding for a certain symbol is\n"
1839 "requested instead of the moment when the environment is\n"
1840 "created or the bindings of the imports change.\n"
1841 "All bindings in @var{imp} are immutable. If you apply\n"
1842 "@code{environment-define} or @code{environment-undefine} to\n"
1843 "@var{imp}, Guile will signal an\n"
1844 " @code{environment:immutable-binding} error. However,\n"
1845 "notice that the set of bindings in @var{imp} may still change,\n"
1846 "if one of its imported environments changes.")
1847 #define FUNC_NAME s_scm_make_import_environment
1849 size_t size
= sizeof (struct import_environment
);
1850 struct import_environment
*body
= scm_gc_malloc (size
, "import environment");
1853 core_environments_preinit (&body
->base
);
1854 body
->imports
= SCM_BOOL_F
;
1855 body
->import_observers
= SCM_BOOL_F
;
1856 body
->conflict_proc
= SCM_BOOL_F
;
1858 env
= scm_make_environment (body
);
1860 core_environments_init (&body
->base
, &import_environment_funcs
);
1861 body
->imports
= SCM_EOL
;
1862 body
->import_observers
= SCM_EOL
;
1863 body
->conflict_proc
= conflict_proc
;
1865 scm_import_environment_set_imports_x (env
, imports
);
1872 SCM_DEFINE (scm_import_environment_p
, "import-environment?", 1, 0, 0,
1874 "Return @code{#t} if object is an import environment, or\n"
1875 "@code{#f} otherwise.")
1876 #define FUNC_NAME s_scm_import_environment_p
1878 return SCM_BOOL (SCM_IMPORT_ENVIRONMENT_P (object
));
1883 SCM_DEFINE (scm_import_environment_imports
, "import-environment-imports", 1, 0, 0,
1885 "Return the list of environments imported by the import\n"
1886 "environment @var{env}.")
1887 #define FUNC_NAME s_scm_import_environment_imports
1889 SCM_ASSERT (SCM_IMPORT_ENVIRONMENT_P (env
), env
, SCM_ARG1
, FUNC_NAME
);
1891 return IMPORT_ENVIRONMENT (env
)->imports
;
1896 SCM_DEFINE (scm_import_environment_set_imports_x
, "import-environment-set-imports!", 2, 0, 0,
1897 (SCM env
, SCM imports
),
1898 "Change @var{env}'s list of imported environments to\n"
1899 "@var{imports}, and check for conflicts.")
1900 #define FUNC_NAME s_scm_import_environment_set_imports_x
1902 struct import_environment
*body
= IMPORT_ENVIRONMENT (env
);
1903 SCM import_observers
= SCM_EOL
;
1906 SCM_ASSERT (SCM_IMPORT_ENVIRONMENT_P (env
), env
, SCM_ARG1
, FUNC_NAME
);
1907 for (l
= imports
; SCM_CONSP (l
); l
= SCM_CDR (l
))
1909 SCM obj
= SCM_CAR (l
);
1910 SCM_ASSERT (SCM_ENVIRONMENT_P (obj
), imports
, SCM_ARG2
, FUNC_NAME
);
1912 SCM_ASSERT (SCM_NULLP (l
), imports
, SCM_ARG2
, FUNC_NAME
);
1914 for (l
= body
->import_observers
; !SCM_NULLP (l
); l
= SCM_CDR (l
))
1916 SCM obs
= SCM_CAR (l
);
1917 SCM_ENVIRONMENT_UNOBSERVE (env
, obs
);
1920 for (l
= imports
; !SCM_NULLP (l
); l
= SCM_CDR (l
))
1922 SCM imp
= SCM_CAR (l
);
1923 SCM obs
= SCM_ENVIRONMENT_OBSERVE (imp
, import_environment_observer
, env
, 1);
1924 import_observers
= scm_cons (obs
, import_observers
);
1927 body
->imports
= imports
;
1928 body
->import_observers
= import_observers
;
1930 return SCM_UNSPECIFIED
;
1936 /* export environments
1938 * An export environment restricts an environment to a specified set of
1941 * Implementation: The export environment does no caching at all. For every
1942 * access, the signature is scanned. The signature that is stored internally
1943 * is an alist of pairs (symbol . (mutability)).
1947 struct export_environment
{
1948 struct core_environments_base base
;
1951 SCM private_observer
;
1957 #define EXPORT_ENVIRONMENT(env) \
1958 ((struct export_environment *) SCM_CELL_WORD_1 (env))
1961 SCM_SYMBOL (symbol_immutable_location
, "immutable-location");
1962 SCM_SYMBOL (symbol_mutable_location
, "mutable-location");
1967 export_environment_ref (SCM env
, SCM sym
)
1968 #define FUNC_NAME "export_environment_ref"
1970 struct export_environment
*body
= EXPORT_ENVIRONMENT (env
);
1971 SCM entry
= scm_assq (sym
, body
->signature
);
1973 if (SCM_FALSEP (entry
))
1974 return SCM_UNDEFINED
;
1976 return SCM_ENVIRONMENT_REF (body
->private, sym
);
1982 export_environment_fold (SCM env
, scm_environment_folder proc
, SCM data
, SCM init
)
1984 struct export_environment
*body
= EXPORT_ENVIRONMENT (env
);
1988 for (l
= body
->signature
; !SCM_NULLP (l
); l
= SCM_CDR (l
))
1990 SCM symbol
= SCM_CAR (l
);
1991 SCM value
= SCM_ENVIRONMENT_REF (body
->private, symbol
);
1992 if (!SCM_UNBNDP (value
))
1993 result
= (*proc
) (data
, symbol
, value
, result
);
2000 export_environment_define (SCM env SCM_UNUSED
,
2003 #define FUNC_NAME "export_environment_define"
2005 return SCM_ENVIRONMENT_BINDING_IMMUTABLE
;
2011 export_environment_undefine (SCM env SCM_UNUSED
, SCM sym SCM_UNUSED
)
2012 #define FUNC_NAME "export_environment_undefine"
2014 return SCM_ENVIRONMENT_BINDING_IMMUTABLE
;
2020 export_environment_set_x (SCM env
, SCM sym
, SCM val
)
2021 #define FUNC_NAME "export_environment_set_x"
2023 struct export_environment
*body
= EXPORT_ENVIRONMENT (env
);
2024 SCM entry
= scm_assq (sym
, body
->signature
);
2026 if (SCM_FALSEP (entry
))
2028 return SCM_UNDEFINED
;
2032 if (SCM_EQ_P (SCM_CADR (entry
), symbol_mutable_location
))
2033 return SCM_ENVIRONMENT_SET (body
->private, sym
, val
);
2035 return SCM_ENVIRONMENT_LOCATION_IMMUTABLE
;
2042 export_environment_cell (SCM env
, SCM sym
, int for_write
)
2043 #define FUNC_NAME "export_environment_cell"
2045 struct export_environment
*body
= EXPORT_ENVIRONMENT (env
);
2046 SCM entry
= scm_assq (sym
, body
->signature
);
2048 if (SCM_FALSEP (entry
))
2050 return SCM_UNDEFINED
;
2054 if (!for_write
|| SCM_EQ_P (SCM_CADR (entry
), symbol_mutable_location
))
2055 return SCM_ENVIRONMENT_CELL (body
->private, sym
, for_write
);
2057 return SCM_ENVIRONMENT_LOCATION_IMMUTABLE
;
2064 export_environment_mark (SCM env
)
2066 struct export_environment
*body
= EXPORT_ENVIRONMENT (env
);
2068 scm_gc_mark (body
->private);
2069 scm_gc_mark (body
->private_observer
);
2070 scm_gc_mark (body
->signature
);
2072 return core_environments_mark (env
);
2077 export_environment_free (SCM env
)
2079 core_environments_finalize (env
);
2080 scm_gc_free (EXPORT_ENVIRONMENT (env
), sizeof (struct export_environment
),
2081 "export environment");
2086 export_environment_print (SCM type
, SCM port
,
2087 scm_print_state
*pstate SCM_UNUSED
)
2089 SCM address
= scm_ulong2num (SCM_UNPACK (type
));
2090 SCM base16
= scm_number_to_string (address
, SCM_MAKINUM (16));
2092 scm_puts ("#<export environment ", port
);
2093 scm_puts (SCM_STRING_CHARS (base16
), port
);
2094 scm_puts (">", port
);
2100 static struct scm_environment_funcs export_environment_funcs
= {
2101 export_environment_ref
,
2102 export_environment_fold
,
2103 export_environment_define
,
2104 export_environment_undefine
,
2105 export_environment_set_x
,
2106 export_environment_cell
,
2107 core_environments_observe
,
2108 core_environments_unobserve
,
2109 export_environment_mark
,
2110 export_environment_free
,
2111 export_environment_print
2115 void *scm_type_export_environment
= &export_environment_funcs
;
2119 export_environment_observer (SCM caller SCM_UNUSED
, SCM export_env
)
2121 core_environments_broadcast (export_env
);
2125 SCM_DEFINE (scm_make_export_environment
, "make-export-environment", 2, 0, 0,
2126 (SCM
private, SCM signature
),
2127 "Return a new environment @var{exp} containing only those\n"
2128 "bindings in private whose symbols are present in\n"
2129 "@var{signature}. The @var{private} argument must be an\n"
2131 "The environment @var{exp} binds symbol to location when\n"
2132 "@var{env} does, and symbol is exported by @var{signature}.\n\n"
2133 "@var{signature} is a list specifying which of the bindings in\n"
2134 "@var{private} should be visible in @var{exp}. Each element of\n"
2135 "@var{signature} should be a list of the form:\n"
2136 " (symbol attribute ...)\n"
2137 "where each attribute is one of the following:\n"
2139 "@item the symbol @code{mutable-location}\n"
2140 " @var{exp} should treat the\n"
2141 " location bound to symbol as mutable. That is, @var{exp}\n"
2142 " will pass calls to @code{environment-set!} or\n"
2143 " @code{environment-cell} directly through to private.\n"
2144 "@item the symbol @code{immutable-location}\n"
2145 " @var{exp} should treat\n"
2146 " the location bound to symbol as immutable. If the program\n"
2147 " applies @code{environment-set!} to @var{exp} and symbol, or\n"
2148 " calls @code{environment-cell} to obtain a writable value\n"
2149 " cell, @code{environment-set!} will signal an\n"
2150 " @code{environment:immutable-location} error. Note that, even\n"
2151 " if an export environment treats a location as immutable, the\n"
2152 " underlying environment may treat it as mutable, so its\n"
2153 " value may change.\n"
2155 "It is an error for an element of signature to specify both\n"
2156 "@code{mutable-location} and @code{immutable-location}. If\n"
2157 "neither is specified, @code{immutable-location} is assumed.\n\n"
2158 "As a special case, if an element of signature is a lone\n"
2159 "symbol @var{sym}, it is equivalent to an element of the form\n"
2161 "All bindings in @var{exp} are immutable. If you apply\n"
2162 "@code{environment-define} or @code{environment-undefine} to\n"
2163 "@var{exp}, Guile will signal an\n"
2164 "@code{environment:immutable-binding} error. However,\n"
2165 "notice that the set of bindings in @var{exp} may still change,\n"
2166 "if the bindings in private change.")
2167 #define FUNC_NAME s_scm_make_export_environment
2170 struct export_environment
*body
;
2173 SCM_ASSERT (SCM_ENVIRONMENT_P (private), private, SCM_ARG1
, FUNC_NAME
);
2175 size
= sizeof (struct export_environment
);
2176 body
= scm_gc_malloc (size
, "export environment");
2178 core_environments_preinit (&body
->base
);
2179 body
->private = SCM_BOOL_F
;
2180 body
->private_observer
= SCM_BOOL_F
;
2181 body
->signature
= SCM_BOOL_F
;
2183 env
= scm_make_environment (body
);
2185 core_environments_init (&body
->base
, &export_environment_funcs
);
2186 body
->private = private;
2187 body
->private_observer
2188 = SCM_ENVIRONMENT_OBSERVE (private, export_environment_observer
, env
, 1);
2189 body
->signature
= SCM_EOL
;
2191 scm_export_environment_set_signature_x (env
, signature
);
2198 SCM_DEFINE (scm_export_environment_p
, "export-environment?", 1, 0, 0,
2200 "Return @code{#t} if object is an export environment, or\n"
2201 "@code{#f} otherwise.")
2202 #define FUNC_NAME s_scm_export_environment_p
2204 return SCM_BOOL (SCM_EXPORT_ENVIRONMENT_P (object
));
2209 SCM_DEFINE (scm_export_environment_private
, "export-environment-private", 1, 0, 0,
2211 "Return the private environment of export environment @var{env}.")
2212 #define FUNC_NAME s_scm_export_environment_private
2214 SCM_ASSERT (SCM_EXPORT_ENVIRONMENT_P (env
), env
, SCM_ARG1
, FUNC_NAME
);
2216 return EXPORT_ENVIRONMENT (env
)->private;
2221 SCM_DEFINE (scm_export_environment_set_private_x
, "export-environment-set-private!", 2, 0, 0,
2222 (SCM env
, SCM
private),
2223 "Change the private environment of export environment @var{env}.")
2224 #define FUNC_NAME s_scm_export_environment_set_private_x
2226 struct export_environment
*body
;
2228 SCM_ASSERT (SCM_EXPORT_ENVIRONMENT_P (env
), env
, SCM_ARG1
, FUNC_NAME
);
2229 SCM_ASSERT (SCM_ENVIRONMENT_P (private), private, SCM_ARG2
, FUNC_NAME
);
2231 body
= EXPORT_ENVIRONMENT (env
);
2232 SCM_ENVIRONMENT_UNOBSERVE (private, body
->private_observer
);
2234 body
->private = private;
2235 body
->private_observer
2236 = SCM_ENVIRONMENT_OBSERVE (private, export_environment_observer
, env
, 1);
2238 return SCM_UNSPECIFIED
;
2243 SCM_DEFINE (scm_export_environment_signature
, "export-environment-signature", 1, 0, 0,
2245 "Return the signature of export environment @var{env}.")
2246 #define FUNC_NAME s_scm_export_environment_signature
2248 SCM_ASSERT (SCM_EXPORT_ENVIRONMENT_P (env
), env
, SCM_ARG1
, FUNC_NAME
);
2250 return EXPORT_ENVIRONMENT (env
)->signature
;
2256 export_environment_parse_signature (SCM signature
, const char* caller
)
2258 SCM result
= SCM_EOL
;
2261 for (l
= signature
; SCM_CONSP (l
); l
= SCM_CDR (l
))
2263 SCM entry
= SCM_CAR (l
);
2265 if (SCM_SYMBOLP (entry
))
2267 SCM new_entry
= scm_cons2 (entry
, symbol_immutable_location
, SCM_EOL
);
2268 result
= scm_cons (new_entry
, result
);
2279 SCM_ASSERT (SCM_CONSP (entry
), entry
, SCM_ARGn
, caller
);
2280 SCM_ASSERT (SCM_SYMBOLP (SCM_CAR (entry
)), entry
, SCM_ARGn
, caller
);
2282 sym
= SCM_CAR (entry
);
2284 for (l2
= SCM_CDR (entry
); SCM_CONSP (l2
); l2
= SCM_CDR (l2
))
2286 SCM attribute
= SCM_CAR (l2
);
2287 if (SCM_EQ_P (attribute
, symbol_immutable_location
))
2289 else if (SCM_EQ_P (attribute
, symbol_mutable_location
))
2292 SCM_ASSERT (0, entry
, SCM_ARGn
, caller
);
2294 SCM_ASSERT (SCM_NULLP (l2
), entry
, SCM_ARGn
, caller
);
2295 SCM_ASSERT (!mutable || !immutable
, entry
, SCM_ARGn
, caller
);
2297 if (!mutable && !immutable
)
2300 mutability
= mutable ? symbol_mutable_location
: symbol_immutable_location
;
2301 new_entry
= scm_cons2 (sym
, mutability
, SCM_EOL
);
2302 result
= scm_cons (new_entry
, result
);
2305 SCM_ASSERT (SCM_NULLP (l
), signature
, SCM_ARGn
, caller
);
2307 /* Dirk:FIXME:: Now we know that signature is syntactically correct. There
2308 * are, however, no checks for symbols entered twice with contradicting
2309 * mutabilities. It would be nice, to implement this test, to be able to
2310 * call the sort functions conveniently from C.
2313 return scm_reverse (result
);
2317 SCM_DEFINE (scm_export_environment_set_signature_x
, "export-environment-set-signature!", 2, 0, 0,
2318 (SCM env
, SCM signature
),
2319 "Change the signature of export environment @var{env}.")
2320 #define FUNC_NAME s_scm_export_environment_set_signature_x
2324 SCM_ASSERT (SCM_EXPORT_ENVIRONMENT_P (env
), env
, SCM_ARG1
, FUNC_NAME
);
2325 parsed_sig
= export_environment_parse_signature (signature
, FUNC_NAME
);
2327 EXPORT_ENVIRONMENT (env
)->signature
= parsed_sig
;
2329 return SCM_UNSPECIFIED
;
2336 scm_environments_prehistory ()
2338 /* create environment smob */
2339 scm_tc16_environment
= scm_make_smob_type ("environment", 0);
2340 scm_set_smob_mark (scm_tc16_environment
, environment_mark
);
2341 scm_set_smob_free (scm_tc16_environment
, environment_free
);
2342 scm_set_smob_print (scm_tc16_environment
, environment_print
);
2344 /* create observer smob */
2345 scm_tc16_observer
= scm_make_smob_type ("observer", 0);
2346 scm_set_smob_mark (scm_tc16_observer
, observer_mark
);
2347 scm_set_smob_print (scm_tc16_observer
, observer_print
);
2349 /* create system environment */
2350 scm_system_environment
= scm_make_leaf_environment ();
2351 scm_permanent_object (scm_system_environment
);
2356 scm_init_environments ()
2358 #include "libguile/environments.x"