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_VECTOR_SET (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_VECTOR_SET (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
;
591 Remove first occurance of KEY from (cdr ALIST),
592 return (KEY . VAL) if found, otherwise return #f
598 This could also be done by combining scm_delq1_x () and
599 scm_sloppy_assq(), at the cost of walking the list another time.
603 remove_key_from_alist (SCM alist
, SCM key
)
605 SCM cell_cdr
= alist
;
606 alist
=SCM_CDR (alist
);
609 inv: cdr(cell_cdr) == alist
611 while (!SCM_NULLP (alist
))
613 if (SCM_EQ_P(SCM_CAAR (alist
), key
))
615 SCM entry
= SCM_CAR(alist
);
616 SCM_SETCDR(cell_cdr
, SCM_CDR (alist
));
622 cell_cdr
= SCM_CDR (cell_cdr
);
625 if (!SCM_NULLP(alist
))
626 alist
= SCM_CDR (alist
);
635 * Remove entry from obarray. If the symbol was found and removed, the old
636 * (symbol . data) cell is returned, #f otherwise.
639 obarray_remove (SCM obarray
, SCM sym
)
641 size_t hash
= SCM_SYMBOL_HASH (sym
) % SCM_VECTOR_LENGTH (obarray
);
642 SCM table_entry
= SCM_VELTS (obarray
)[hash
];
644 if (SCM_NULLP(table_entry
))
647 if (SCM_EQ_P (SCM_CAAR (table_entry
), sym
))
649 SCM_VECTOR_SET (obarray
, hash
, SCM_CDR(table_entry
));
650 return SCM_CAR(table_entry
);
654 return remove_key_from_alist (table_entry
, sym
);
660 obarray_remove_all (SCM obarray
)
662 size_t size
= SCM_VECTOR_LENGTH (obarray
);
665 for (i
= 0; i
< size
; i
++)
667 SCM_VECTOR_SET (obarray
, i
, SCM_EOL
);
673 /* core environments base
675 * This struct and the corresponding functions form a base class for guile's
676 * built-in environment types.
680 struct core_environments_base
{
681 struct scm_environment_funcs
*funcs
;
688 #define CORE_ENVIRONMENTS_BASE(env) \
689 ((struct core_environments_base *) SCM_CELL_WORD_1 (env))
690 #define CORE_ENVIRONMENT_OBSERVERS(env) \
691 (CORE_ENVIRONMENTS_BASE (env)->observers)
692 #define SCM_SET_CORE_ENVIRONMENT_OBSERVERS(env, v) \
693 (CORE_ENVIRONMENT_OBSERVERS (env) = (v))
694 #define CORE_ENVIRONMENT_WEAK_OBSERVER_VECTOR(env) \
695 (CORE_ENVIRONMENTS_BASE (env)->weak_observers)
696 #define CORE_ENVIRONMENT_WEAK_OBSERVERS(env) \
697 (SCM_VELTS (CORE_ENVIRONMENT_WEAK_OBSERVER_VECTOR (env)) [0])
698 #define SCM_SET_CORE_ENVIRONMENT_WEAK_OBSERVERS(env, v) \
699 (SCM_VECTOR_SET (CORE_ENVIRONMENT_WEAK_OBSERVER_VECTOR (env), 0, (v)))
704 core_environments_observe (SCM env
, scm_environment_observer proc
, SCM data
, int weak_p
)
706 SCM observer
= scm_double_cell (scm_tc16_observer
,
713 SCM observers
= CORE_ENVIRONMENT_OBSERVERS (env
);
714 SCM new_observers
= scm_cons (observer
, observers
);
715 SCM_SET_CORE_ENVIRONMENT_OBSERVERS (env
, new_observers
);
719 SCM observers
= CORE_ENVIRONMENT_WEAK_OBSERVERS (env
);
720 SCM new_observers
= scm_acons (SCM_BOOL_F
, observer
, observers
);
721 SCM_SET_CORE_ENVIRONMENT_WEAK_OBSERVERS (env
, new_observers
);
729 core_environments_unobserve (SCM env
, SCM observer
)
731 unsigned int handling_weaks
;
732 for (handling_weaks
= 0; handling_weaks
<= 1; ++handling_weaks
)
734 SCM l
= handling_weaks
735 ? CORE_ENVIRONMENT_WEAK_OBSERVERS (env
)
736 : CORE_ENVIRONMENT_OBSERVERS (env
);
740 SCM rest
= SCM_CDR (l
);
741 SCM first
= handling_weaks
745 if (SCM_EQ_P (first
, observer
))
747 /* Remove the first observer */
749 ? SCM_SET_CORE_ENVIRONMENT_WEAK_OBSERVERS (env
, rest
)
750 : SCM_SET_CORE_ENVIRONMENT_OBSERVERS (env
, rest
);
755 SCM rest
= SCM_CDR (l
);
757 if (!SCM_NULLP (rest
))
759 SCM next
= handling_weaks
763 if (SCM_EQ_P (next
, observer
))
765 SCM_SETCDR (l
, SCM_CDR (rest
));
771 } while (!SCM_NULLP (l
));
775 /* Dirk:FIXME:: What to do now, since the observer is not found? */
780 core_environments_mark (SCM env
)
782 scm_gc_mark (CORE_ENVIRONMENT_OBSERVERS (env
));
783 return CORE_ENVIRONMENT_WEAK_OBSERVER_VECTOR (env
);
788 core_environments_finalize (SCM env SCM_UNUSED
)
794 core_environments_preinit (struct core_environments_base
*body
)
797 body
->observers
= SCM_BOOL_F
;
798 body
->weak_observers
= SCM_BOOL_F
;
803 core_environments_init (struct core_environments_base
*body
,
804 struct scm_environment_funcs
*funcs
)
807 body
->observers
= SCM_EOL
;
808 body
->weak_observers
= scm_make_weak_value_hash_table (SCM_MAKINUM (1));
812 /* Tell all observers to clear their caches.
814 * Environments have to be informed about changes in the following cases:
815 * - The observed env has a new binding. This must be always reported.
816 * - The observed env has dropped a binding. This must be always reported.
817 * - A binding in the observed environment has changed. This must only be
818 * reported, if there is a chance that the binding is being cached outside.
819 * However, this potential optimization is not performed currently.
821 * Errors that occur while the observers are called are accumulated and
822 * signalled as one single error message to the caller.
833 update_catch_body (void *ptr
)
835 struct update_data
*data
= (struct update_data
*) ptr
;
836 SCM observer
= data
->observer
;
838 (*SCM_OBSERVER_PROC (observer
))
839 (data
->environment
, SCM_OBSERVER_DATA (observer
));
841 return SCM_UNDEFINED
;
846 update_catch_handler (void *ptr
, SCM tag
, SCM args
)
848 struct update_data
*data
= (struct update_data
*) ptr
;
849 SCM observer
= data
->observer
;
850 SCM message
= scm_makfrom0str ("Observer `~A' signals `~A' error: ~S");
852 return scm_cons (message
, scm_list_3 (observer
, tag
, args
));
857 core_environments_broadcast (SCM env
)
858 #define FUNC_NAME "core_environments_broadcast"
860 unsigned int handling_weaks
;
861 SCM errors
= SCM_EOL
;
863 for (handling_weaks
= 0; handling_weaks
<= 1; ++handling_weaks
)
865 SCM observers
= handling_weaks
866 ? CORE_ENVIRONMENT_WEAK_OBSERVERS (env
)
867 : CORE_ENVIRONMENT_OBSERVERS (env
);
869 for (; !SCM_NULLP (observers
); observers
= SCM_CDR (observers
))
871 struct update_data data
;
872 SCM observer
= handling_weaks
873 ? SCM_CDAR (observers
)
874 : SCM_CAR (observers
);
877 data
.observer
= observer
;
878 data
.environment
= env
;
880 error
= scm_internal_catch (SCM_BOOL_T
,
881 update_catch_body
, &data
,
882 update_catch_handler
, &data
);
884 if (!SCM_UNBNDP (error
))
885 errors
= scm_cons (error
, errors
);
889 if (!SCM_NULLP (errors
))
891 /* Dirk:FIXME:: As soon as scm_misc_error is fixed to handle the name
892 * parameter correctly it should not be necessary any more to also pass
893 * namestr in order to get the desired information from the error
896 SCM ordered_errors
= scm_reverse (errors
);
899 "Observers of `~A' have signalled the following errors: ~S",
900 scm_cons2 (env
, ordered_errors
, SCM_EOL
));
909 * A leaf environment is simply a mutable set of definitions. A leaf
910 * environment supports no operations beyond the common set.
912 * Implementation: The obarray of the leaf environment holds (symbol . value)
913 * pairs. No further information is necessary, since all bindings and
914 * locations in a leaf environment are mutable.
918 struct leaf_environment
{
919 struct core_environments_base base
;
925 #define LEAF_ENVIRONMENT(env) \
926 ((struct leaf_environment *) SCM_CELL_WORD_1 (env))
931 leaf_environment_ref (SCM env
, SCM sym
)
933 SCM obarray
= LEAF_ENVIRONMENT (env
)->obarray
;
934 SCM binding
= obarray_retrieve (obarray
, sym
);
935 return SCM_UNBNDP (binding
) ? binding
: SCM_CDR (binding
);
940 leaf_environment_fold (SCM env
, scm_environment_folder proc
, SCM data
, SCM init
)
944 SCM obarray
= LEAF_ENVIRONMENT (env
)->obarray
;
946 for (i
= 0; i
< SCM_VECTOR_LENGTH (obarray
); i
++)
949 for (l
= SCM_VELTS (obarray
)[i
]; !SCM_NULLP (l
); l
= SCM_CDR (l
))
951 SCM binding
= SCM_CAR (l
);
952 SCM symbol
= SCM_CAR (binding
);
953 SCM value
= SCM_CDR (binding
);
954 result
= (*proc
) (data
, symbol
, value
, result
);
962 leaf_environment_define (SCM env
, SCM sym
, SCM val
)
963 #define FUNC_NAME "leaf_environment_define"
965 SCM obarray
= LEAF_ENVIRONMENT (env
)->obarray
;
967 obarray_replace (obarray
, sym
, val
);
968 core_environments_broadcast (env
);
970 return SCM_ENVIRONMENT_SUCCESS
;
976 leaf_environment_undefine (SCM env
, SCM sym
)
977 #define FUNC_NAME "leaf_environment_undefine"
979 SCM obarray
= LEAF_ENVIRONMENT (env
)->obarray
;
980 SCM removed
= obarray_remove (obarray
, sym
);
982 if (!SCM_FALSEP (removed
))
983 core_environments_broadcast (env
);
985 return SCM_ENVIRONMENT_SUCCESS
;
991 leaf_environment_set_x (SCM env
, SCM sym
, SCM val
)
992 #define FUNC_NAME "leaf_environment_set_x"
994 SCM obarray
= LEAF_ENVIRONMENT (env
)->obarray
;
995 SCM binding
= obarray_retrieve (obarray
, sym
);
997 if (!SCM_UNBNDP (binding
))
999 SCM_SETCDR (binding
, val
);
1000 return SCM_ENVIRONMENT_SUCCESS
;
1004 return SCM_UNDEFINED
;
1011 leaf_environment_cell (SCM env
, SCM sym
, int for_write SCM_UNUSED
)
1013 SCM obarray
= LEAF_ENVIRONMENT (env
)->obarray
;
1014 SCM binding
= obarray_retrieve (obarray
, sym
);
1020 leaf_environment_mark (SCM env
)
1022 scm_gc_mark (LEAF_ENVIRONMENT (env
)->obarray
);
1023 return core_environments_mark (env
);
1028 leaf_environment_free (SCM env
)
1030 core_environments_finalize (env
);
1031 scm_gc_free (LEAF_ENVIRONMENT (env
), sizeof (struct leaf_environment
),
1032 "leaf environment");
1037 leaf_environment_print (SCM type
, SCM port
, scm_print_state
*pstate SCM_UNUSED
)
1039 SCM address
= scm_ulong2num (SCM_UNPACK (type
));
1040 SCM base16
= scm_number_to_string (address
, SCM_MAKINUM (16));
1042 scm_puts ("#<leaf environment ", port
);
1043 scm_puts (SCM_STRING_CHARS (base16
), port
);
1044 scm_puts (">", port
);
1050 static struct scm_environment_funcs leaf_environment_funcs
= {
1051 leaf_environment_ref
,
1052 leaf_environment_fold
,
1053 leaf_environment_define
,
1054 leaf_environment_undefine
,
1055 leaf_environment_set_x
,
1056 leaf_environment_cell
,
1057 core_environments_observe
,
1058 core_environments_unobserve
,
1059 leaf_environment_mark
,
1060 leaf_environment_free
,
1061 leaf_environment_print
1065 void *scm_type_leaf_environment
= &leaf_environment_funcs
;
1068 SCM_DEFINE (scm_make_leaf_environment
, "make-leaf-environment", 0, 0, 0,
1070 "Create a new leaf environment, containing no bindings.\n"
1071 "All bindings and locations created in the new environment\n"
1073 #define FUNC_NAME s_scm_make_leaf_environment
1075 size_t size
= sizeof (struct leaf_environment
);
1076 struct leaf_environment
*body
= scm_gc_malloc (size
, "leaf environment");
1079 core_environments_preinit (&body
->base
);
1080 body
->obarray
= SCM_BOOL_F
;
1082 env
= scm_make_environment (body
);
1084 core_environments_init (&body
->base
, &leaf_environment_funcs
);
1085 body
->obarray
= scm_c_make_hash_table (DEFAULT_OBARRAY_SIZE
);
1092 SCM_DEFINE (scm_leaf_environment_p
, "leaf-environment?", 1, 0, 0,
1094 "Return @code{#t} if object is a leaf environment, or @code{#f}\n"
1096 #define FUNC_NAME s_scm_leaf_environment_p
1098 return SCM_BOOL (SCM_LEAF_ENVIRONMENT_P (object
));
1104 /* eval environments
1106 * A module's source code refers to definitions imported from other modules,
1107 * and definitions made within itself. An eval environment combines two
1108 * environments -- a local environment and an imported environment -- to
1109 * produce a new environment in which both sorts of references can be
1112 * Implementation: The obarray of the eval environment is used to cache
1113 * entries from the local and imported environments such that in most of the
1114 * cases only a single lookup is necessary. Since for neither the local nor
1115 * the imported environment it is known, what kind of environment they form,
1116 * the most general case is assumed. Therefore, entries in the obarray take
1117 * one of the following forms:
1119 * 1) (<symbol> location mutability . source-env), where mutability indicates
1120 * one of the following states: IMMUTABLE if the location is known to be
1121 * immutable, MUTABLE if the location is known to be mutable, UNKNOWN if
1122 * the location has only been requested for non modifying accesses.
1124 * 2) (symbol . source-env) if the symbol has a binding in the source-env, but
1125 * if the source-env can't provide a cell for the binding. Thus, for every
1126 * access, the source-env has to be contacted directly.
1130 struct eval_environment
{
1131 struct core_environments_base base
;
1136 SCM imported_observer
;
1142 #define EVAL_ENVIRONMENT(env) \
1143 ((struct eval_environment *) SCM_CELL_WORD_1 (env))
1145 #define IMMUTABLE SCM_MAKINUM (0)
1146 #define MUTABLE SCM_MAKINUM (1)
1147 #define UNKNOWN SCM_MAKINUM (2)
1149 #define CACHED_LOCATION(x) SCM_CAR (x)
1150 #define CACHED_MUTABILITY(x) SCM_CADR (x)
1151 #define SET_CACHED_MUTABILITY(x, v) SCM_SETCAR (SCM_CDR (x), (v))
1152 #define CACHED_SOURCE_ENVIRONMENT(x) SCM_CDDR (x)
1156 /* eval_environment_lookup will report one of the following distinct results:
1157 * a) (<object> . value) if a cell could be obtained.
1158 * b) <environment> if the environment has to be contacted directly.
1159 * c) IMMUTABLE if an immutable cell was requested for write.
1160 * d) SCM_UNDEFINED if there is no binding for the symbol.
1163 eval_environment_lookup (SCM env
, SCM sym
, int for_write
)
1165 SCM obarray
= EVAL_ENVIRONMENT (env
)->obarray
;
1166 SCM binding
= obarray_retrieve (obarray
, sym
);
1168 if (!SCM_UNBNDP (binding
))
1170 /* The obarray holds an entry for the symbol. */
1172 SCM entry
= SCM_CDR (binding
);
1174 if (SCM_CONSP (entry
))
1176 /* The entry in the obarray is a cached location. */
1178 SCM location
= CACHED_LOCATION (entry
);
1184 mutability
= CACHED_MUTABILITY (entry
);
1185 if (SCM_EQ_P (mutability
, MUTABLE
))
1188 if (SCM_EQ_P (mutability
, UNKNOWN
))
1190 SCM source_env
= CACHED_SOURCE_ENVIRONMENT (entry
);
1191 SCM location
= SCM_ENVIRONMENT_CELL (source_env
, sym
, 1);
1193 if (SCM_CONSP (location
))
1195 SET_CACHED_MUTABILITY (entry
, MUTABLE
);
1198 else /* IMMUTABLE */
1200 SET_CACHED_MUTABILITY (entry
, IMMUTABLE
);
1209 /* The obarray entry is an environment */
1216 /* There is no entry for the symbol in the obarray. This can either
1217 * mean that there has not been a request for the symbol yet, or that
1218 * the symbol is really undefined. We are looking for the symbol in
1219 * both the local and the imported environment. If we find a binding, a
1220 * cached entry is created.
1223 struct eval_environment
*body
= EVAL_ENVIRONMENT (env
);
1224 unsigned int handling_import
;
1226 for (handling_import
= 0; handling_import
<= 1; ++handling_import
)
1228 SCM source_env
= handling_import
? body
->imported
: body
->local
;
1229 SCM location
= SCM_ENVIRONMENT_CELL (source_env
, sym
, for_write
);
1231 if (!SCM_UNBNDP (location
))
1233 if (SCM_CONSP (location
))
1235 SCM mutability
= for_write
? MUTABLE
: UNKNOWN
;
1236 SCM entry
= scm_cons2 (location
, mutability
, source_env
);
1237 obarray_enter (obarray
, sym
, entry
);
1240 else if (SCM_EQ_P (location
, SCM_ENVIRONMENT_LOCATION_NO_CELL
))
1242 obarray_enter (obarray
, sym
, source_env
);
1252 return SCM_UNDEFINED
;
1258 eval_environment_ref (SCM env
, SCM sym
)
1259 #define FUNC_NAME "eval_environment_ref"
1261 SCM location
= eval_environment_lookup (env
, sym
, 0);
1263 if (SCM_CONSP (location
))
1264 return SCM_CDR (location
);
1265 else if (!SCM_UNBNDP (location
))
1266 return SCM_ENVIRONMENT_REF (location
, sym
);
1268 return SCM_UNDEFINED
;
1274 eval_environment_folder (SCM extended_data
, SCM symbol
, SCM value
, SCM tail
)
1276 SCM local
= SCM_CAR (extended_data
);
1278 if (!SCM_ENVIRONMENT_BOUND_P (local
, symbol
))
1280 SCM proc_as_nr
= SCM_CADR (extended_data
);
1281 unsigned long int proc_as_ul
= scm_num2ulong (proc_as_nr
, 0, NULL
);
1282 scm_environment_folder proc
= (scm_environment_folder
) proc_as_ul
;
1283 SCM data
= SCM_CDDR (extended_data
);
1285 return (*proc
) (data
, symbol
, value
, tail
);
1295 eval_environment_fold (SCM env
, scm_environment_folder proc
, SCM data
, SCM init
)
1297 SCM local
= EVAL_ENVIRONMENT (env
)->local
;
1298 SCM imported
= EVAL_ENVIRONMENT (env
)->imported
;
1299 SCM proc_as_nr
= scm_ulong2num ((unsigned long int) proc
);
1300 SCM extended_data
= scm_cons2 (local
, proc_as_nr
, data
);
1301 SCM tmp_result
= scm_c_environment_fold (imported
, eval_environment_folder
, extended_data
, init
);
1303 return scm_c_environment_fold (local
, proc
, data
, tmp_result
);
1308 eval_environment_define (SCM env
, SCM sym
, SCM val
)
1309 #define FUNC_NAME "eval_environment_define"
1311 SCM local
= EVAL_ENVIRONMENT (env
)->local
;
1312 return SCM_ENVIRONMENT_DEFINE (local
, sym
, val
);
1318 eval_environment_undefine (SCM env
, SCM sym
)
1319 #define FUNC_NAME "eval_environment_undefine"
1321 SCM local
= EVAL_ENVIRONMENT (env
)->local
;
1322 return SCM_ENVIRONMENT_UNDEFINE (local
, sym
);
1328 eval_environment_set_x (SCM env
, SCM sym
, SCM val
)
1329 #define FUNC_NAME "eval_environment_set_x"
1331 SCM location
= eval_environment_lookup (env
, sym
, 1);
1333 if (SCM_CONSP (location
))
1335 SCM_SETCDR (location
, val
);
1336 return SCM_ENVIRONMENT_SUCCESS
;
1338 else if (SCM_ENVIRONMENT_P (location
))
1340 return SCM_ENVIRONMENT_SET (location
, sym
, val
);
1342 else if (SCM_EQ_P (location
, IMMUTABLE
))
1344 return SCM_ENVIRONMENT_LOCATION_IMMUTABLE
;
1348 return SCM_UNDEFINED
;
1355 eval_environment_cell (SCM env
, SCM sym
, int for_write
)
1356 #define FUNC_NAME "eval_environment_cell"
1358 SCM location
= eval_environment_lookup (env
, sym
, for_write
);
1360 if (SCM_CONSP (location
))
1362 else if (SCM_ENVIRONMENT_P (location
))
1363 return SCM_ENVIRONMENT_LOCATION_NO_CELL
;
1364 else if (SCM_EQ_P (location
, IMMUTABLE
))
1365 return SCM_ENVIRONMENT_LOCATION_IMMUTABLE
;
1367 return SCM_UNDEFINED
;
1373 eval_environment_mark (SCM env
)
1375 struct eval_environment
*body
= EVAL_ENVIRONMENT (env
);
1377 scm_gc_mark (body
->obarray
);
1378 scm_gc_mark (body
->imported
);
1379 scm_gc_mark (body
->imported_observer
);
1380 scm_gc_mark (body
->local
);
1381 scm_gc_mark (body
->local_observer
);
1383 return core_environments_mark (env
);
1388 eval_environment_free (SCM env
)
1390 core_environments_finalize (env
);
1391 scm_gc_free (EVAL_ENVIRONMENT (env
), sizeof (struct eval_environment
),
1392 "eval environment");
1397 eval_environment_print (SCM type
, SCM port
, scm_print_state
*pstate SCM_UNUSED
)
1399 SCM address
= scm_ulong2num (SCM_UNPACK (type
));
1400 SCM base16
= scm_number_to_string (address
, SCM_MAKINUM (16));
1402 scm_puts ("#<eval environment ", port
);
1403 scm_puts (SCM_STRING_CHARS (base16
), port
);
1404 scm_puts (">", port
);
1410 static struct scm_environment_funcs eval_environment_funcs
= {
1411 eval_environment_ref
,
1412 eval_environment_fold
,
1413 eval_environment_define
,
1414 eval_environment_undefine
,
1415 eval_environment_set_x
,
1416 eval_environment_cell
,
1417 core_environments_observe
,
1418 core_environments_unobserve
,
1419 eval_environment_mark
,
1420 eval_environment_free
,
1421 eval_environment_print
1425 void *scm_type_eval_environment
= &eval_environment_funcs
;
1429 eval_environment_observer (SCM caller SCM_UNUSED
, SCM eval_env
)
1431 SCM obarray
= EVAL_ENVIRONMENT (eval_env
)->obarray
;
1433 obarray_remove_all (obarray
);
1434 core_environments_broadcast (eval_env
);
1438 SCM_DEFINE (scm_make_eval_environment
, "make-eval-environment", 2, 0, 0,
1439 (SCM local
, SCM imported
),
1440 "Return a new environment object eval whose bindings are the\n"
1441 "union of the bindings in the environments @var{local} and\n"
1442 "@var{imported}, with bindings from @var{local} taking\n"
1443 "precedence. Definitions made in eval are placed in @var{local}.\n"
1444 "Applying @code{environment-define} or\n"
1445 "@code{environment-undefine} to eval has the same effect as\n"
1446 "applying the procedure to @var{local}.\n"
1447 "Note that eval incorporates @var{local} and @var{imported} by\n"
1449 "If, after creating eval, the program changes the bindings of\n"
1450 "@var{local} or @var{imported}, those changes will be visible\n"
1452 "Since most Scheme evaluation takes place in eval environments,\n"
1453 "they transparently cache the bindings received from @var{local}\n"
1454 "and @var{imported}. Thus, the first time the program looks up\n"
1455 "a symbol in eval, eval may make calls to @var{local} or\n"
1456 "@var{imported} to find their bindings, but subsequent\n"
1457 "references to that symbol will be as fast as references to\n"
1458 "bindings in finite environments.\n"
1459 "In typical use, @var{local} will be a finite environment, and\n"
1460 "@var{imported} will be an import environment")
1461 #define FUNC_NAME s_scm_make_eval_environment
1464 struct eval_environment
*body
;
1466 SCM_ASSERT (SCM_ENVIRONMENT_P (local
), local
, SCM_ARG1
, FUNC_NAME
);
1467 SCM_ASSERT (SCM_ENVIRONMENT_P (imported
), imported
, SCM_ARG2
, FUNC_NAME
);
1469 body
= scm_gc_malloc (sizeof (struct eval_environment
), "eval environment");
1471 core_environments_preinit (&body
->base
);
1472 body
->obarray
= SCM_BOOL_F
;
1473 body
->imported
= SCM_BOOL_F
;
1474 body
->imported_observer
= SCM_BOOL_F
;
1475 body
->local
= SCM_BOOL_F
;
1476 body
->local_observer
= SCM_BOOL_F
;
1478 env
= scm_make_environment (body
);
1480 core_environments_init (&body
->base
, &eval_environment_funcs
);
1481 body
->obarray
= scm_c_make_hash_table (DEFAULT_OBARRAY_SIZE
);
1482 body
->imported
= imported
;
1483 body
->imported_observer
1484 = SCM_ENVIRONMENT_OBSERVE (imported
, eval_environment_observer
, env
, 1);
1485 body
->local
= local
;
1486 body
->local_observer
1487 = SCM_ENVIRONMENT_OBSERVE (local
, eval_environment_observer
, env
, 1);
1494 SCM_DEFINE (scm_eval_environment_p
, "eval-environment?", 1, 0, 0,
1496 "Return @code{#t} if object is an eval environment, or @code{#f}\n"
1498 #define FUNC_NAME s_scm_eval_environment_p
1500 return SCM_BOOL (SCM_EVAL_ENVIRONMENT_P (object
));
1505 SCM_DEFINE (scm_eval_environment_local
, "eval-environment-local", 1, 0, 0,
1507 "Return the local environment of eval environment @var{env}.")
1508 #define FUNC_NAME s_scm_eval_environment_local
1510 SCM_ASSERT (SCM_EVAL_ENVIRONMENT_P (env
), env
, SCM_ARG1
, FUNC_NAME
);
1512 return EVAL_ENVIRONMENT (env
)->local
;
1517 SCM_DEFINE (scm_eval_environment_set_local_x
, "eval-environment-set-local!", 2, 0, 0,
1518 (SCM env
, SCM local
),
1519 "Change @var{env}'s local environment to @var{local}.")
1520 #define FUNC_NAME s_scm_eval_environment_set_local_x
1522 struct eval_environment
*body
;
1524 SCM_ASSERT (SCM_EVAL_ENVIRONMENT_P (env
), env
, SCM_ARG1
, FUNC_NAME
);
1525 SCM_ASSERT (SCM_ENVIRONMENT_P (local
), local
, SCM_ARG2
, FUNC_NAME
);
1527 body
= EVAL_ENVIRONMENT (env
);
1529 obarray_remove_all (body
->obarray
);
1530 SCM_ENVIRONMENT_UNOBSERVE (body
->local
, body
->local_observer
);
1532 body
->local
= local
;
1533 body
->local_observer
1534 = SCM_ENVIRONMENT_OBSERVE (local
, eval_environment_observer
, env
, 1);
1536 core_environments_broadcast (env
);
1538 return SCM_UNSPECIFIED
;
1543 SCM_DEFINE (scm_eval_environment_imported
, "eval-environment-imported", 1, 0, 0,
1545 "Return the imported environment of eval environment @var{env}.")
1546 #define FUNC_NAME s_scm_eval_environment_imported
1548 SCM_ASSERT (SCM_EVAL_ENVIRONMENT_P (env
), env
, SCM_ARG1
, FUNC_NAME
);
1550 return EVAL_ENVIRONMENT (env
)->imported
;
1555 SCM_DEFINE (scm_eval_environment_set_imported_x
, "eval-environment-set-imported!", 2, 0, 0,
1556 (SCM env
, SCM imported
),
1557 "Change @var{env}'s imported environment to @var{imported}.")
1558 #define FUNC_NAME s_scm_eval_environment_set_imported_x
1560 struct eval_environment
*body
;
1562 SCM_ASSERT (SCM_EVAL_ENVIRONMENT_P (env
), env
, SCM_ARG1
, FUNC_NAME
);
1563 SCM_ASSERT (SCM_ENVIRONMENT_P (imported
), imported
, SCM_ARG2
, FUNC_NAME
);
1565 body
= EVAL_ENVIRONMENT (env
);
1567 obarray_remove_all (body
->obarray
);
1568 SCM_ENVIRONMENT_UNOBSERVE (body
->imported
, body
->imported_observer
);
1570 body
->imported
= imported
;
1571 body
->imported_observer
1572 = SCM_ENVIRONMENT_OBSERVE (imported
, eval_environment_observer
, env
, 1);
1574 core_environments_broadcast (env
);
1576 return SCM_UNSPECIFIED
;
1582 /* import environments
1584 * An import environment combines the bindings of a set of argument
1585 * environments, and checks for naming clashes.
1587 * Implementation: The import environment does no caching at all. For every
1588 * access, the list of imported environments is scanned.
1592 struct import_environment
{
1593 struct core_environments_base base
;
1596 SCM import_observers
;
1602 #define IMPORT_ENVIRONMENT(env) \
1603 ((struct import_environment *) SCM_CELL_WORD_1 (env))
1607 /* Lookup will report one of the following distinct results:
1608 * a) <environment> if only environment binds the symbol.
1609 * b) (env-1 env-2 ...) for conflicting bindings in env-1, ...
1610 * c) SCM_UNDEFINED if there is no binding for the symbol.
1613 import_environment_lookup (SCM env
, SCM sym
)
1615 SCM imports
= IMPORT_ENVIRONMENT (env
)->imports
;
1616 SCM result
= SCM_UNDEFINED
;
1619 for (l
= imports
; !SCM_NULLP (l
); l
= SCM_CDR (l
))
1621 SCM imported
= SCM_CAR (l
);
1623 if (SCM_ENVIRONMENT_BOUND_P (imported
, sym
))
1625 if (SCM_UNBNDP (result
))
1627 else if (SCM_CONSP (result
))
1628 result
= scm_cons (imported
, result
);
1630 result
= scm_cons2 (imported
, result
, SCM_EOL
);
1634 if (SCM_CONSP (result
))
1635 return scm_reverse (result
);
1642 import_environment_conflict (SCM env
, SCM sym
, SCM imports
)
1644 SCM conflict_proc
= IMPORT_ENVIRONMENT (env
)->conflict_proc
;
1645 SCM args
= scm_cons2 (env
, sym
, scm_cons (imports
, SCM_EOL
));
1647 return scm_apply_0 (conflict_proc
, args
);
1652 import_environment_ref (SCM env
, SCM sym
)
1653 #define FUNC_NAME "import_environment_ref"
1655 SCM owner
= import_environment_lookup (env
, sym
);
1657 if (SCM_UNBNDP (owner
))
1659 return SCM_UNDEFINED
;
1661 else if (SCM_CONSP (owner
))
1663 SCM resolve
= import_environment_conflict (env
, sym
, owner
);
1665 if (SCM_ENVIRONMENT_P (resolve
))
1666 return SCM_ENVIRONMENT_REF (resolve
, sym
);
1668 return SCM_UNSPECIFIED
;
1672 return SCM_ENVIRONMENT_REF (owner
, sym
);
1679 import_environment_folder (SCM extended_data
, SCM symbol
, SCM value
, SCM tail
)
1680 #define FUNC_NAME "import_environment_fold"
1682 SCM import_env
= SCM_CAR (extended_data
);
1683 SCM imported_env
= SCM_CADR (extended_data
);
1684 SCM owner
= import_environment_lookup (import_env
, symbol
);
1685 SCM proc_as_nr
= SCM_CADDR (extended_data
);
1686 unsigned long int proc_as_ul
= scm_num2ulong (proc_as_nr
, 0, NULL
);
1687 scm_environment_folder proc
= (scm_environment_folder
) proc_as_ul
;
1688 SCM data
= SCM_CDDDR (extended_data
);
1690 if (SCM_CONSP (owner
) && SCM_EQ_P (SCM_CAR (owner
), imported_env
))
1691 owner
= import_environment_conflict (import_env
, symbol
, owner
);
1693 if (SCM_ENVIRONMENT_P (owner
))
1694 return (*proc
) (data
, symbol
, value
, tail
);
1695 else /* unresolved conflict */
1696 return (*proc
) (data
, symbol
, SCM_UNSPECIFIED
, tail
);
1702 import_environment_fold (SCM env
, scm_environment_folder proc
, SCM data
, SCM init
)
1704 SCM proc_as_nr
= scm_ulong2num ((unsigned long int) proc
);
1708 for (l
= IMPORT_ENVIRONMENT (env
)->imports
; !SCM_NULLP (l
); l
= SCM_CDR (l
))
1710 SCM imported_env
= SCM_CAR (l
);
1711 SCM extended_data
= scm_cons (env
, scm_cons2 (imported_env
, proc_as_nr
, data
));
1713 result
= scm_c_environment_fold (imported_env
, import_environment_folder
, extended_data
, result
);
1721 import_environment_define (SCM env SCM_UNUSED
,
1724 #define FUNC_NAME "import_environment_define"
1726 return SCM_ENVIRONMENT_BINDING_IMMUTABLE
;
1732 import_environment_undefine (SCM env SCM_UNUSED
,
1734 #define FUNC_NAME "import_environment_undefine"
1736 return SCM_ENVIRONMENT_BINDING_IMMUTABLE
;
1742 import_environment_set_x (SCM env
, SCM sym
, SCM val
)
1743 #define FUNC_NAME "import_environment_set_x"
1745 SCM owner
= import_environment_lookup (env
, sym
);
1747 if (SCM_UNBNDP (owner
))
1749 return SCM_UNDEFINED
;
1751 else if (SCM_CONSP (owner
))
1753 SCM resolve
= import_environment_conflict (env
, sym
, owner
);
1755 if (SCM_ENVIRONMENT_P (resolve
))
1756 return SCM_ENVIRONMENT_SET (resolve
, sym
, val
);
1758 return SCM_ENVIRONMENT_LOCATION_IMMUTABLE
;
1762 return SCM_ENVIRONMENT_SET (owner
, sym
, val
);
1769 import_environment_cell (SCM env
, SCM sym
, int for_write
)
1770 #define FUNC_NAME "import_environment_cell"
1772 SCM owner
= import_environment_lookup (env
, sym
);
1774 if (SCM_UNBNDP (owner
))
1776 return SCM_UNDEFINED
;
1778 else if (SCM_CONSP (owner
))
1780 SCM resolve
= import_environment_conflict (env
, sym
, owner
);
1782 if (SCM_ENVIRONMENT_P (resolve
))
1783 return SCM_ENVIRONMENT_CELL (resolve
, sym
, for_write
);
1785 return SCM_ENVIRONMENT_LOCATION_NO_CELL
;
1789 return SCM_ENVIRONMENT_CELL (owner
, sym
, for_write
);
1796 import_environment_mark (SCM env
)
1798 scm_gc_mark (IMPORT_ENVIRONMENT (env
)->imports
);
1799 scm_gc_mark (IMPORT_ENVIRONMENT (env
)->import_observers
);
1800 scm_gc_mark (IMPORT_ENVIRONMENT (env
)->conflict_proc
);
1801 return core_environments_mark (env
);
1806 import_environment_free (SCM env
)
1808 core_environments_finalize (env
);
1809 scm_gc_free (IMPORT_ENVIRONMENT (env
), sizeof (struct import_environment
),
1810 "import environment");
1815 import_environment_print (SCM type
, SCM port
,
1816 scm_print_state
*pstate SCM_UNUSED
)
1818 SCM address
= scm_ulong2num (SCM_UNPACK (type
));
1819 SCM base16
= scm_number_to_string (address
, SCM_MAKINUM (16));
1821 scm_puts ("#<import environment ", port
);
1822 scm_puts (SCM_STRING_CHARS (base16
), port
);
1823 scm_puts (">", port
);
1829 static struct scm_environment_funcs import_environment_funcs
= {
1830 import_environment_ref
,
1831 import_environment_fold
,
1832 import_environment_define
,
1833 import_environment_undefine
,
1834 import_environment_set_x
,
1835 import_environment_cell
,
1836 core_environments_observe
,
1837 core_environments_unobserve
,
1838 import_environment_mark
,
1839 import_environment_free
,
1840 import_environment_print
1844 void *scm_type_import_environment
= &import_environment_funcs
;
1848 import_environment_observer (SCM caller SCM_UNUSED
, SCM import_env
)
1850 core_environments_broadcast (import_env
);
1854 SCM_DEFINE (scm_make_import_environment
, "make-import-environment", 2, 0, 0,
1855 (SCM imports
, SCM conflict_proc
),
1856 "Return a new environment @var{imp} whose bindings are the union\n"
1857 "of the bindings from the environments in @var{imports};\n"
1858 "@var{imports} must be a list of environments. That is,\n"
1859 "@var{imp} binds a symbol to a location when some element of\n"
1860 "@var{imports} does.\n"
1861 "If two different elements of @var{imports} have a binding for\n"
1862 "the same symbol, the @var{conflict-proc} is called with the\n"
1863 "following parameters: the import environment, the symbol and\n"
1864 "the list of the imported environments that bind the symbol.\n"
1865 "If the @var{conflict-proc} returns an environment @var{env},\n"
1866 "the conflict is considered as resolved and the binding from\n"
1867 "@var{env} is used. If the @var{conflict-proc} returns some\n"
1868 "non-environment object, the conflict is considered unresolved\n"
1869 "and the symbol is treated as unspecified in the import\n"
1871 "The checking for conflicts may be performed lazily, i. e. at\n"
1872 "the moment when a value or binding for a certain symbol is\n"
1873 "requested instead of the moment when the environment is\n"
1874 "created or the bindings of the imports change.\n"
1875 "All bindings in @var{imp} are immutable. If you apply\n"
1876 "@code{environment-define} or @code{environment-undefine} to\n"
1877 "@var{imp}, Guile will signal an\n"
1878 " @code{environment:immutable-binding} error. However,\n"
1879 "notice that the set of bindings in @var{imp} may still change,\n"
1880 "if one of its imported environments changes.")
1881 #define FUNC_NAME s_scm_make_import_environment
1883 size_t size
= sizeof (struct import_environment
);
1884 struct import_environment
*body
= scm_gc_malloc (size
, "import environment");
1887 core_environments_preinit (&body
->base
);
1888 body
->imports
= SCM_BOOL_F
;
1889 body
->import_observers
= SCM_BOOL_F
;
1890 body
->conflict_proc
= SCM_BOOL_F
;
1892 env
= scm_make_environment (body
);
1894 core_environments_init (&body
->base
, &import_environment_funcs
);
1895 body
->imports
= SCM_EOL
;
1896 body
->import_observers
= SCM_EOL
;
1897 body
->conflict_proc
= conflict_proc
;
1899 scm_import_environment_set_imports_x (env
, imports
);
1906 SCM_DEFINE (scm_import_environment_p
, "import-environment?", 1, 0, 0,
1908 "Return @code{#t} if object is an import environment, or\n"
1909 "@code{#f} otherwise.")
1910 #define FUNC_NAME s_scm_import_environment_p
1912 return SCM_BOOL (SCM_IMPORT_ENVIRONMENT_P (object
));
1917 SCM_DEFINE (scm_import_environment_imports
, "import-environment-imports", 1, 0, 0,
1919 "Return the list of environments imported by the import\n"
1920 "environment @var{env}.")
1921 #define FUNC_NAME s_scm_import_environment_imports
1923 SCM_ASSERT (SCM_IMPORT_ENVIRONMENT_P (env
), env
, SCM_ARG1
, FUNC_NAME
);
1925 return IMPORT_ENVIRONMENT (env
)->imports
;
1930 SCM_DEFINE (scm_import_environment_set_imports_x
, "import-environment-set-imports!", 2, 0, 0,
1931 (SCM env
, SCM imports
),
1932 "Change @var{env}'s list of imported environments to\n"
1933 "@var{imports}, and check for conflicts.")
1934 #define FUNC_NAME s_scm_import_environment_set_imports_x
1936 struct import_environment
*body
= IMPORT_ENVIRONMENT (env
);
1937 SCM import_observers
= SCM_EOL
;
1940 SCM_ASSERT (SCM_IMPORT_ENVIRONMENT_P (env
), env
, SCM_ARG1
, FUNC_NAME
);
1941 for (l
= imports
; SCM_CONSP (l
); l
= SCM_CDR (l
))
1943 SCM obj
= SCM_CAR (l
);
1944 SCM_ASSERT (SCM_ENVIRONMENT_P (obj
), imports
, SCM_ARG2
, FUNC_NAME
);
1946 SCM_ASSERT (SCM_NULLP (l
), imports
, SCM_ARG2
, FUNC_NAME
);
1948 for (l
= body
->import_observers
; !SCM_NULLP (l
); l
= SCM_CDR (l
))
1950 SCM obs
= SCM_CAR (l
);
1951 SCM_ENVIRONMENT_UNOBSERVE (env
, obs
);
1954 for (l
= imports
; !SCM_NULLP (l
); l
= SCM_CDR (l
))
1956 SCM imp
= SCM_CAR (l
);
1957 SCM obs
= SCM_ENVIRONMENT_OBSERVE (imp
, import_environment_observer
, env
, 1);
1958 import_observers
= scm_cons (obs
, import_observers
);
1961 body
->imports
= imports
;
1962 body
->import_observers
= import_observers
;
1964 return SCM_UNSPECIFIED
;
1970 /* export environments
1972 * An export environment restricts an environment to a specified set of
1975 * Implementation: The export environment does no caching at all. For every
1976 * access, the signature is scanned. The signature that is stored internally
1977 * is an alist of pairs (symbol . (mutability)).
1981 struct export_environment
{
1982 struct core_environments_base base
;
1985 SCM private_observer
;
1991 #define EXPORT_ENVIRONMENT(env) \
1992 ((struct export_environment *) SCM_CELL_WORD_1 (env))
1995 SCM_SYMBOL (symbol_immutable_location
, "immutable-location");
1996 SCM_SYMBOL (symbol_mutable_location
, "mutable-location");
2001 export_environment_ref (SCM env
, SCM sym
)
2002 #define FUNC_NAME "export_environment_ref"
2004 struct export_environment
*body
= EXPORT_ENVIRONMENT (env
);
2005 SCM entry
= scm_assq (sym
, body
->signature
);
2007 if (SCM_FALSEP (entry
))
2008 return SCM_UNDEFINED
;
2010 return SCM_ENVIRONMENT_REF (body
->private, sym
);
2016 export_environment_fold (SCM env
, scm_environment_folder proc
, SCM data
, SCM init
)
2018 struct export_environment
*body
= EXPORT_ENVIRONMENT (env
);
2022 for (l
= body
->signature
; !SCM_NULLP (l
); l
= SCM_CDR (l
))
2024 SCM symbol
= SCM_CAR (l
);
2025 SCM value
= SCM_ENVIRONMENT_REF (body
->private, symbol
);
2026 if (!SCM_UNBNDP (value
))
2027 result
= (*proc
) (data
, symbol
, value
, result
);
2034 export_environment_define (SCM env SCM_UNUSED
,
2037 #define FUNC_NAME "export_environment_define"
2039 return SCM_ENVIRONMENT_BINDING_IMMUTABLE
;
2045 export_environment_undefine (SCM env SCM_UNUSED
, SCM sym SCM_UNUSED
)
2046 #define FUNC_NAME "export_environment_undefine"
2048 return SCM_ENVIRONMENT_BINDING_IMMUTABLE
;
2054 export_environment_set_x (SCM env
, SCM sym
, SCM val
)
2055 #define FUNC_NAME "export_environment_set_x"
2057 struct export_environment
*body
= EXPORT_ENVIRONMENT (env
);
2058 SCM entry
= scm_assq (sym
, body
->signature
);
2060 if (SCM_FALSEP (entry
))
2062 return SCM_UNDEFINED
;
2066 if (SCM_EQ_P (SCM_CADR (entry
), symbol_mutable_location
))
2067 return SCM_ENVIRONMENT_SET (body
->private, sym
, val
);
2069 return SCM_ENVIRONMENT_LOCATION_IMMUTABLE
;
2076 export_environment_cell (SCM env
, SCM sym
, int for_write
)
2077 #define FUNC_NAME "export_environment_cell"
2079 struct export_environment
*body
= EXPORT_ENVIRONMENT (env
);
2080 SCM entry
= scm_assq (sym
, body
->signature
);
2082 if (SCM_FALSEP (entry
))
2084 return SCM_UNDEFINED
;
2088 if (!for_write
|| SCM_EQ_P (SCM_CADR (entry
), symbol_mutable_location
))
2089 return SCM_ENVIRONMENT_CELL (body
->private, sym
, for_write
);
2091 return SCM_ENVIRONMENT_LOCATION_IMMUTABLE
;
2098 export_environment_mark (SCM env
)
2100 struct export_environment
*body
= EXPORT_ENVIRONMENT (env
);
2102 scm_gc_mark (body
->private);
2103 scm_gc_mark (body
->private_observer
);
2104 scm_gc_mark (body
->signature
);
2106 return core_environments_mark (env
);
2111 export_environment_free (SCM env
)
2113 core_environments_finalize (env
);
2114 scm_gc_free (EXPORT_ENVIRONMENT (env
), sizeof (struct export_environment
),
2115 "export environment");
2120 export_environment_print (SCM type
, SCM port
,
2121 scm_print_state
*pstate SCM_UNUSED
)
2123 SCM address
= scm_ulong2num (SCM_UNPACK (type
));
2124 SCM base16
= scm_number_to_string (address
, SCM_MAKINUM (16));
2126 scm_puts ("#<export environment ", port
);
2127 scm_puts (SCM_STRING_CHARS (base16
), port
);
2128 scm_puts (">", port
);
2134 static struct scm_environment_funcs export_environment_funcs
= {
2135 export_environment_ref
,
2136 export_environment_fold
,
2137 export_environment_define
,
2138 export_environment_undefine
,
2139 export_environment_set_x
,
2140 export_environment_cell
,
2141 core_environments_observe
,
2142 core_environments_unobserve
,
2143 export_environment_mark
,
2144 export_environment_free
,
2145 export_environment_print
2149 void *scm_type_export_environment
= &export_environment_funcs
;
2153 export_environment_observer (SCM caller SCM_UNUSED
, SCM export_env
)
2155 core_environments_broadcast (export_env
);
2159 SCM_DEFINE (scm_make_export_environment
, "make-export-environment", 2, 0, 0,
2160 (SCM
private, SCM signature
),
2161 "Return a new environment @var{exp} containing only those\n"
2162 "bindings in private whose symbols are present in\n"
2163 "@var{signature}. The @var{private} argument must be an\n"
2165 "The environment @var{exp} binds symbol to location when\n"
2166 "@var{env} does, and symbol is exported by @var{signature}.\n\n"
2167 "@var{signature} is a list specifying which of the bindings in\n"
2168 "@var{private} should be visible in @var{exp}. Each element of\n"
2169 "@var{signature} should be a list of the form:\n"
2170 " (symbol attribute ...)\n"
2171 "where each attribute is one of the following:\n"
2173 "@item the symbol @code{mutable-location}\n"
2174 " @var{exp} should treat the\n"
2175 " location bound to symbol as mutable. That is, @var{exp}\n"
2176 " will pass calls to @code{environment-set!} or\n"
2177 " @code{environment-cell} directly through to private.\n"
2178 "@item the symbol @code{immutable-location}\n"
2179 " @var{exp} should treat\n"
2180 " the location bound to symbol as immutable. If the program\n"
2181 " applies @code{environment-set!} to @var{exp} and symbol, or\n"
2182 " calls @code{environment-cell} to obtain a writable value\n"
2183 " cell, @code{environment-set!} will signal an\n"
2184 " @code{environment:immutable-location} error. Note that, even\n"
2185 " if an export environment treats a location as immutable, the\n"
2186 " underlying environment may treat it as mutable, so its\n"
2187 " value may change.\n"
2189 "It is an error for an element of signature to specify both\n"
2190 "@code{mutable-location} and @code{immutable-location}. If\n"
2191 "neither is specified, @code{immutable-location} is assumed.\n\n"
2192 "As a special case, if an element of signature is a lone\n"
2193 "symbol @var{sym}, it is equivalent to an element of the form\n"
2195 "All bindings in @var{exp} are immutable. If you apply\n"
2196 "@code{environment-define} or @code{environment-undefine} to\n"
2197 "@var{exp}, Guile will signal an\n"
2198 "@code{environment:immutable-binding} error. However,\n"
2199 "notice that the set of bindings in @var{exp} may still change,\n"
2200 "if the bindings in private change.")
2201 #define FUNC_NAME s_scm_make_export_environment
2204 struct export_environment
*body
;
2207 SCM_ASSERT (SCM_ENVIRONMENT_P (private), private, SCM_ARG1
, FUNC_NAME
);
2209 size
= sizeof (struct export_environment
);
2210 body
= scm_gc_malloc (size
, "export environment");
2212 core_environments_preinit (&body
->base
);
2213 body
->private = SCM_BOOL_F
;
2214 body
->private_observer
= SCM_BOOL_F
;
2215 body
->signature
= SCM_BOOL_F
;
2217 env
= scm_make_environment (body
);
2219 core_environments_init (&body
->base
, &export_environment_funcs
);
2220 body
->private = private;
2221 body
->private_observer
2222 = SCM_ENVIRONMENT_OBSERVE (private, export_environment_observer
, env
, 1);
2223 body
->signature
= SCM_EOL
;
2225 scm_export_environment_set_signature_x (env
, signature
);
2232 SCM_DEFINE (scm_export_environment_p
, "export-environment?", 1, 0, 0,
2234 "Return @code{#t} if object is an export environment, or\n"
2235 "@code{#f} otherwise.")
2236 #define FUNC_NAME s_scm_export_environment_p
2238 return SCM_BOOL (SCM_EXPORT_ENVIRONMENT_P (object
));
2243 SCM_DEFINE (scm_export_environment_private
, "export-environment-private", 1, 0, 0,
2245 "Return the private environment of export environment @var{env}.")
2246 #define FUNC_NAME s_scm_export_environment_private
2248 SCM_ASSERT (SCM_EXPORT_ENVIRONMENT_P (env
), env
, SCM_ARG1
, FUNC_NAME
);
2250 return EXPORT_ENVIRONMENT (env
)->private;
2255 SCM_DEFINE (scm_export_environment_set_private_x
, "export-environment-set-private!", 2, 0, 0,
2256 (SCM env
, SCM
private),
2257 "Change the private environment of export environment @var{env}.")
2258 #define FUNC_NAME s_scm_export_environment_set_private_x
2260 struct export_environment
*body
;
2262 SCM_ASSERT (SCM_EXPORT_ENVIRONMENT_P (env
), env
, SCM_ARG1
, FUNC_NAME
);
2263 SCM_ASSERT (SCM_ENVIRONMENT_P (private), private, SCM_ARG2
, FUNC_NAME
);
2265 body
= EXPORT_ENVIRONMENT (env
);
2266 SCM_ENVIRONMENT_UNOBSERVE (private, body
->private_observer
);
2268 body
->private = private;
2269 body
->private_observer
2270 = SCM_ENVIRONMENT_OBSERVE (private, export_environment_observer
, env
, 1);
2272 return SCM_UNSPECIFIED
;
2277 SCM_DEFINE (scm_export_environment_signature
, "export-environment-signature", 1, 0, 0,
2279 "Return the signature of export environment @var{env}.")
2280 #define FUNC_NAME s_scm_export_environment_signature
2282 SCM_ASSERT (SCM_EXPORT_ENVIRONMENT_P (env
), env
, SCM_ARG1
, FUNC_NAME
);
2284 return EXPORT_ENVIRONMENT (env
)->signature
;
2290 export_environment_parse_signature (SCM signature
, const char* caller
)
2292 SCM result
= SCM_EOL
;
2295 for (l
= signature
; SCM_CONSP (l
); l
= SCM_CDR (l
))
2297 SCM entry
= SCM_CAR (l
);
2299 if (SCM_SYMBOLP (entry
))
2301 SCM new_entry
= scm_cons2 (entry
, symbol_immutable_location
, SCM_EOL
);
2302 result
= scm_cons (new_entry
, result
);
2313 SCM_ASSERT (SCM_CONSP (entry
), entry
, SCM_ARGn
, caller
);
2314 SCM_ASSERT (SCM_SYMBOLP (SCM_CAR (entry
)), entry
, SCM_ARGn
, caller
);
2316 sym
= SCM_CAR (entry
);
2318 for (l2
= SCM_CDR (entry
); SCM_CONSP (l2
); l2
= SCM_CDR (l2
))
2320 SCM attribute
= SCM_CAR (l2
);
2321 if (SCM_EQ_P (attribute
, symbol_immutable_location
))
2323 else if (SCM_EQ_P (attribute
, symbol_mutable_location
))
2326 SCM_ASSERT (0, entry
, SCM_ARGn
, caller
);
2328 SCM_ASSERT (SCM_NULLP (l2
), entry
, SCM_ARGn
, caller
);
2329 SCM_ASSERT (!mutable || !immutable
, entry
, SCM_ARGn
, caller
);
2331 if (!mutable && !immutable
)
2334 mutability
= mutable ? symbol_mutable_location
: symbol_immutable_location
;
2335 new_entry
= scm_cons2 (sym
, mutability
, SCM_EOL
);
2336 result
= scm_cons (new_entry
, result
);
2339 SCM_ASSERT (SCM_NULLP (l
), signature
, SCM_ARGn
, caller
);
2341 /* Dirk:FIXME:: Now we know that signature is syntactically correct. There
2342 * are, however, no checks for symbols entered twice with contradicting
2343 * mutabilities. It would be nice, to implement this test, to be able to
2344 * call the sort functions conveniently from C.
2347 return scm_reverse (result
);
2351 SCM_DEFINE (scm_export_environment_set_signature_x
, "export-environment-set-signature!", 2, 0, 0,
2352 (SCM env
, SCM signature
),
2353 "Change the signature of export environment @var{env}.")
2354 #define FUNC_NAME s_scm_export_environment_set_signature_x
2358 SCM_ASSERT (SCM_EXPORT_ENVIRONMENT_P (env
), env
, SCM_ARG1
, FUNC_NAME
);
2359 parsed_sig
= export_environment_parse_signature (signature
, FUNC_NAME
);
2361 EXPORT_ENVIRONMENT (env
)->signature
= parsed_sig
;
2363 return SCM_UNSPECIFIED
;
2370 scm_environments_prehistory ()
2372 /* create environment smob */
2373 scm_tc16_environment
= scm_make_smob_type ("environment", 0);
2374 scm_set_smob_mark (scm_tc16_environment
, environment_mark
);
2375 scm_set_smob_free (scm_tc16_environment
, environment_free
);
2376 scm_set_smob_print (scm_tc16_environment
, environment_print
);
2378 /* create observer smob */
2379 scm_tc16_observer
= scm_make_smob_type ("observer", 0);
2380 scm_set_smob_mark (scm_tc16_observer
, observer_mark
);
2381 scm_set_smob_print (scm_tc16_observer
, observer_print
);
2383 /* create system environment */
2384 scm_system_environment
= scm_make_leaf_environment ();
2385 scm_permanent_object (scm_system_environment
);
2390 scm_init_environments ()
2392 #include "libguile/environments.x"