1
/* Copyright (C) 1999,2000,2001, 2003, 2006 Free Software Foundation, Inc.
3
* This library is free software; you can redistribute it and/or
4
* modify it under the terms of the GNU Lesser General Public
5
* License as published by the Free Software Foundation; either
6
* version 2.1 of the License, or (at your option) any later version.
8
* This library 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 GNU
11
* Lesser General Public License for more details.
13
* You should have received a copy of the GNU Lesser General Public
14
* License along with this library; if not, write to the Free Software
15
* Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
20
#include "libguile/_scm.h"
21
#include "libguile/alist.h"
22
#include "libguile/eval.h"
23
#include "libguile/gh.h"
24
#include "libguile/hash.h"
25
#include "libguile/list.h"
26
#include "libguile/ports.h"
27
#include "libguile/smob.h"
28
#include "libguile/symbols.h"
29
#include "libguile/vectors.h"
30
#include "libguile/weaks.h"
32
#include "libguile/environments.h"
36
scm_t_bits scm_tc16_environment;
37
scm_t_bits scm_tc16_observer;
38
#define DEFAULT_OBARRAY_SIZE 31
40
SCM scm_system_environment;
44
/* error conditions */
47
* Throw an error if symbol is not bound in environment func
50
scm_error_environment_unbound (const char *func, SCM env, SCM symbol)
52
/* Dirk:FIXME:: Should throw an environment:unbound type error */
53
char error[] = "Symbol `~A' not bound in environment `~A'.";
54
SCM arguments = scm_cons2 (symbol, env, SCM_EOL);
55
scm_misc_error (func, error, arguments);
60
* Throw an error if func tried to create (define) or remove
61
* (undefine) a new binding for symbol in env
64
scm_error_environment_immutable_binding (const char *func, SCM env, SCM symbol)
66
/* Dirk:FIXME:: Should throw an environment:immutable-binding type error */
67
char error[] = "Immutable binding in environment ~A (symbol: `~A').";
68
SCM arguments = scm_cons2 (env, symbol, SCM_EOL);
69
scm_misc_error (func, error, arguments);
74
* Throw an error if func tried to change an immutable location.
77
scm_error_environment_immutable_location (const char *func, SCM env, SCM symbol)
79
/* Dirk:FIXME:: Should throw an environment:immutable-location type error */
80
char error[] = "Immutable location in environment `~A' (symbol: `~A').";
81
SCM arguments = scm_cons2 (env, symbol, SCM_EOL);
82
scm_misc_error (func, error, arguments);
87
/* generic environments */
90
/* Create an environment for the given type. Dereferencing type twice must
91
* deliver the initialized set of environment functions. Thus, type will
92
* also determine the signature of the underlying environment implementation.
93
* Dereferencing type once will typically deliver the data fields used by the
94
* underlying environment implementation.
97
scm_make_environment (void *type)
99
return scm_cell (scm_tc16_environment, (scm_t_bits) type);
103
SCM_DEFINE (scm_environment_p, "environment?", 1, 0, 0,
105
"Return @code{#t} if @var{obj} is an environment, or @code{#f}\n"
107
#define FUNC_NAME s_scm_environment_p
109
return scm_from_bool (SCM_ENVIRONMENT_P (obj));
114
SCM_DEFINE (scm_environment_bound_p, "environment-bound?", 2, 0, 0,
116
"Return @code{#t} if @var{sym} is bound in @var{env}, or\n"
117
"@code{#f} otherwise.")
118
#define FUNC_NAME s_scm_environment_bound_p
120
SCM_ASSERT (SCM_ENVIRONMENT_P (env), env, SCM_ARG1, FUNC_NAME);
121
SCM_ASSERT (scm_is_symbol (sym), sym, SCM_ARG2, FUNC_NAME);
123
return scm_from_bool (SCM_ENVIRONMENT_BOUND_P (env, sym));
128
SCM_DEFINE (scm_environment_ref, "environment-ref", 2, 0, 0,
130
"Return the value of the location bound to @var{sym} in\n"
131
"@var{env}. If @var{sym} is unbound in @var{env}, signal an\n"
132
"@code{environment:unbound} error.")
133
#define FUNC_NAME s_scm_environment_ref
137
SCM_ASSERT (SCM_ENVIRONMENT_P (env), env, SCM_ARG1, FUNC_NAME);
138
SCM_ASSERT (scm_is_symbol (sym), sym, SCM_ARG2, FUNC_NAME);
140
val = SCM_ENVIRONMENT_REF (env, sym);
142
if (!SCM_UNBNDP (val))
145
scm_error_environment_unbound (FUNC_NAME, env, sym);
150
/* This C function is identical to environment-ref, except that if symbol is
151
* unbound in env, it returns the value SCM_UNDEFINED, instead of signalling
155
scm_c_environment_ref (SCM env, SCM sym)
157
SCM_ASSERT (SCM_ENVIRONMENT_P (env), env, SCM_ARG1, "scm_c_environment_ref");
158
SCM_ASSERT (scm_is_symbol (sym), sym, SCM_ARG2, "scm_c_environment_ref");
159
return SCM_ENVIRONMENT_REF (env, sym);
164
environment_default_folder (SCM proc, SCM symbol, SCM value, SCM tail)
166
return scm_call_3 (proc, symbol, value, tail);
170
SCM_DEFINE (scm_environment_fold, "environment-fold", 3, 0, 0,
171
(SCM env, SCM proc, SCM init),
172
"Iterate over all the bindings in @var{env}, accumulating some\n"
174
"For each binding in @var{env}, apply @var{proc} to the symbol\n"
175
"bound, its value, and the result from the previous application\n"
177
"Use @var{init} as @var{proc}'s third argument the first time\n"
178
"@var{proc} is applied.\n"
179
"If @var{env} contains no bindings, this function simply returns\n"
181
"If @var{env} binds the symbol sym1 to the value val1, sym2 to\n"
182
"val2, and so on, then this procedure computes:\n"
190
"Each binding in @var{env} will be processed exactly once.\n"
191
"@code{environment-fold} makes no guarantees about the order in\n"
192
"which the bindings are processed.\n"
193
"Here is a function which, given an environment, constructs an\n"
194
"association list representing that environment's bindings,\n"
195
"using environment-fold:\n"
197
" (define (environment->alist env)\n"
198
" (environment-fold env\n"
199
" (lambda (sym val tail)\n"
200
" (cons (cons sym val) tail))\n"
203
#define FUNC_NAME s_scm_environment_fold
205
SCM_ASSERT (SCM_ENVIRONMENT_P (env), env, SCM_ARG1, FUNC_NAME);
206
SCM_ASSERT (scm_is_true (scm_procedure_p (proc)),
207
proc, SCM_ARG2, FUNC_NAME);
209
return SCM_ENVIRONMENT_FOLD (env, environment_default_folder, proc, init);
214
/* This is the C-level analog of environment-fold. For each binding in ENV,
216
* (*proc) (data, symbol, value, previous)
217
* where previous is the value returned from the last call to *PROC, or INIT
218
* for the first call. If ENV contains no bindings, return INIT.
221
scm_c_environment_fold (SCM env, scm_environment_folder proc, SCM data, SCM init)
223
SCM_ASSERT (SCM_ENVIRONMENT_P (env), env, SCM_ARG1, "scm_c_environment_fold");
225
return SCM_ENVIRONMENT_FOLD (env, proc, data, init);
229
SCM_DEFINE (scm_environment_define, "environment-define", 3, 0, 0,
230
(SCM env, SCM sym, SCM val),
231
"Bind @var{sym} to a new location containing @var{val} in\n"
232
"@var{env}. If @var{sym} is already bound to another location\n"
233
"in @var{env} and the binding is mutable, that binding is\n"
234
"replaced. The new binding and location are both mutable. The\n"
235
"return value is unspecified.\n"
236
"If @var{sym} is already bound in @var{env}, and the binding is\n"
237
"immutable, signal an @code{environment:immutable-binding} error.")
238
#define FUNC_NAME s_scm_environment_define
242
SCM_ASSERT (SCM_ENVIRONMENT_P (env), env, SCM_ARG1, FUNC_NAME);
243
SCM_ASSERT (scm_is_symbol (sym), sym, SCM_ARG2, FUNC_NAME);
245
status = SCM_ENVIRONMENT_DEFINE (env, sym, val);
247
if (scm_is_eq (status, SCM_ENVIRONMENT_SUCCESS))
248
return SCM_UNSPECIFIED;
249
else if (scm_is_eq (status, SCM_ENVIRONMENT_BINDING_IMMUTABLE))
250
scm_error_environment_immutable_binding (FUNC_NAME, env, sym);
257
SCM_DEFINE (scm_environment_undefine, "environment-undefine", 2, 0, 0,
259
"Remove any binding for @var{sym} from @var{env}. If @var{sym}\n"
260
"is unbound in @var{env}, do nothing. The return value is\n"
262
"If @var{sym} is already bound in @var{env}, and the binding is\n"
263
"immutable, signal an @code{environment:immutable-binding} error.")
264
#define FUNC_NAME s_scm_environment_undefine
268
SCM_ASSERT(SCM_ENVIRONMENT_P(env), env, SCM_ARG1, FUNC_NAME);
269
SCM_ASSERT(scm_is_symbol(sym), sym, SCM_ARG2, FUNC_NAME);
271
status = SCM_ENVIRONMENT_UNDEFINE (env, sym);
273
if (scm_is_eq (status, SCM_ENVIRONMENT_SUCCESS))
274
return SCM_UNSPECIFIED;
275
else if (scm_is_eq (status, SCM_ENVIRONMENT_BINDING_IMMUTABLE))
276
scm_error_environment_immutable_binding (FUNC_NAME, env, sym);
283
SCM_DEFINE (scm_environment_set_x, "environment-set!", 3, 0, 0,
284
(SCM env, SCM sym, SCM val),
285
"If @var{env} binds @var{sym} to some location, change that\n"
286
"location's value to @var{val}. The return value is\n"
288
"If @var{sym} is not bound in @var{env}, signal an\n"
289
"@code{environment:unbound} error. If @var{env} binds @var{sym}\n"
290
"to an immutable location, signal an\n"
291
"@code{environment:immutable-location} error.")
292
#define FUNC_NAME s_scm_environment_set_x
296
SCM_ASSERT (SCM_ENVIRONMENT_P (env), env, SCM_ARG1, FUNC_NAME);
297
SCM_ASSERT (scm_is_symbol (sym), sym, SCM_ARG2, FUNC_NAME);
299
status = SCM_ENVIRONMENT_SET (env, sym, val);
301
if (scm_is_eq (status, SCM_ENVIRONMENT_SUCCESS))
302
return SCM_UNSPECIFIED;
303
else if (SCM_UNBNDP (status))
304
scm_error_environment_unbound (FUNC_NAME, env, sym);
305
else if (scm_is_eq (status, SCM_ENVIRONMENT_LOCATION_IMMUTABLE))
306
scm_error_environment_immutable_binding (FUNC_NAME, env, sym);
313
SCM_DEFINE (scm_environment_cell, "environment-cell", 3, 0, 0,
314
(SCM env, SCM sym, SCM for_write),
315
"Return the value cell which @var{env} binds to @var{sym}, or\n"
316
"@code{#f} if the binding does not live in a value cell.\n"
317
"The argument @var{for-write} indicates whether the caller\n"
318
"intends to modify the variable's value by mutating the value\n"
319
"cell. If the variable is immutable, then\n"
320
"@code{environment-cell} signals an\n"
321
"@code{environment:immutable-location} error.\n"
322
"If @var{sym} is unbound in @var{env}, signal an\n"
323
"@code{environment:unbound} error.\n"
324
"If you use this function, you should consider using\n"
325
"@code{environment-observe}, to be notified when @var{sym} gets\n"
326
"re-bound to a new value cell, or becomes undefined.")
327
#define FUNC_NAME s_scm_environment_cell
331
SCM_ASSERT (SCM_ENVIRONMENT_P (env), env, SCM_ARG1, FUNC_NAME);
332
SCM_ASSERT (scm_is_symbol (sym), sym, SCM_ARG2, FUNC_NAME);
333
SCM_ASSERT (scm_is_bool (for_write), for_write, SCM_ARG3, FUNC_NAME);
335
location = SCM_ENVIRONMENT_CELL (env, sym, scm_is_true (for_write));
336
if (!SCM_IMP (location))
338
else if (SCM_UNBNDP (location))
339
scm_error_environment_unbound (FUNC_NAME, env, sym);
340
else if (scm_is_eq (location, SCM_ENVIRONMENT_LOCATION_IMMUTABLE))
341
scm_error_environment_immutable_location (FUNC_NAME, env, sym);
348
/* This C function is identical to environment-cell, with the following
349
* exceptions: If symbol is unbound in env, it returns the value
350
* SCM_UNDEFINED, instead of signalling an error. If symbol is bound to an
351
* immutable location but the cell is requested for write, the value
352
* SCM_ENVIRONMENT_LOCATION_IMMUTABLE is returned.
355
scm_c_environment_cell(SCM env, SCM sym, int for_write)
357
SCM_ASSERT (SCM_ENVIRONMENT_P (env), env, SCM_ARG1, "scm_c_environment_cell");
358
SCM_ASSERT (scm_is_symbol (sym), sym, SCM_ARG2, "scm_c_environment_cell");
360
return SCM_ENVIRONMENT_CELL (env, sym, for_write);
365
environment_default_observer (SCM env, SCM proc)
367
scm_call_1 (proc, env);
371
SCM_DEFINE (scm_environment_observe, "environment-observe", 2, 0, 0,
373
"Whenever @var{env}'s bindings change, apply @var{proc} to\n"
375
"This function returns an object, token, which you can pass to\n"
376
"@code{environment-unobserve} to remove @var{proc} from the set\n"
377
"of procedures observing @var{env}. The type and value of\n"
378
"token is unspecified.")
379
#define FUNC_NAME s_scm_environment_observe
381
SCM_ASSERT (SCM_ENVIRONMENT_P (env), env, SCM_ARG1, FUNC_NAME);
383
return SCM_ENVIRONMENT_OBSERVE (env, environment_default_observer, proc, 0);
388
SCM_DEFINE (scm_environment_observe_weak, "environment-observe-weak", 2, 0, 0,
390
"This function is the same as environment-observe, except that\n"
391
"the reference @var{env} retains to @var{proc} is a weak\n"
392
"reference. This means that, if there are no other live,\n"
393
"non-weak references to @var{proc}, it will be\n"
394
"garbage-collected, and dropped from @var{env}'s\n"
395
"list of observing procedures.")
396
#define FUNC_NAME s_scm_environment_observe_weak
398
SCM_ASSERT (SCM_ENVIRONMENT_P (env), env, SCM_ARG1, FUNC_NAME);
400
return SCM_ENVIRONMENT_OBSERVE (env, environment_default_observer, proc, 1);
405
/* This is the C-level analog of the Scheme functions environment-observe and
406
* environment-observe-weak. Whenever env's bindings change, call the
407
* function proc, passing it env and data. If weak_p is non-zero, env will
408
* retain only a weak reference to data, and if data is garbage collected, the
409
* entire observation will be dropped. This function returns a token, with
410
* the same meaning as those returned by environment-observe and
411
* environment-observe-weak.
414
scm_c_environment_observe (SCM env, scm_environment_observer proc, SCM data, int weak_p)
415
#define FUNC_NAME "scm_c_environment_observe"
417
SCM_ASSERT (SCM_ENVIRONMENT_P (env), env, SCM_ARG1, FUNC_NAME);
419
return SCM_ENVIRONMENT_OBSERVE (env, proc, data, weak_p);
424
SCM_DEFINE (scm_environment_unobserve, "environment-unobserve", 1, 0, 0,
426
"Cancel the observation request which returned the value\n"
427
"@var{token}. The return value is unspecified.\n"
428
"If a call @code{(environment-observe env proc)} returns\n"
429
"@var{token}, then the call @code{(environment-unobserve token)}\n"
430
"will cause @var{proc} to no longer be called when @var{env}'s\n"
432
#define FUNC_NAME s_scm_environment_unobserve
436
SCM_ASSERT (SCM_OBSERVER_P (token), token, SCM_ARG1, FUNC_NAME);
438
env = SCM_OBSERVER_ENVIRONMENT (token);
439
SCM_ENVIRONMENT_UNOBSERVE (env, token);
441
return SCM_UNSPECIFIED;
447
environment_mark (SCM env)
449
return (*(SCM_ENVIRONMENT_FUNCS (env)->mark)) (env);
454
environment_free (SCM env)
456
(*(SCM_ENVIRONMENT_FUNCS (env)->free)) (env);
462
environment_print (SCM env, SCM port, scm_print_state *pstate)
464
return (*(SCM_ENVIRONMENT_FUNCS (env)->print)) (env, port, pstate);
472
observer_mark (SCM observer)
474
scm_gc_mark (SCM_OBSERVER_ENVIRONMENT (observer));
475
scm_gc_mark (SCM_OBSERVER_DATA (observer));
481
observer_print (SCM type, SCM port, scm_print_state *pstate SCM_UNUSED)
483
SCM address = scm_from_size_t (SCM_UNPACK (type));
484
SCM base16 = scm_number_to_string (address, scm_from_int (16));
486
scm_puts ("#<observer ", port);
487
scm_display (base16, port);
488
scm_puts (">", port);
497
* Obarrays form the basic lookup tables used to implement most of guile's
498
* built-in environment types. An obarray is implemented as a hash table with
499
* symbols as keys. The content of the data depends on the environment type.
504
* Enter symbol into obarray. The symbol must not already exist in obarray.
505
* The freshly generated (symbol . data) cell is returned.
508
obarray_enter (SCM obarray, SCM symbol, SCM data)
510
size_t hash = scm_i_symbol_hash (symbol) % SCM_HASHTABLE_N_BUCKETS (obarray);
511
SCM entry = scm_cons (symbol, data);
512
SCM slot = scm_cons (entry, SCM_HASHTABLE_BUCKET (obarray, hash));
513
SCM_SET_HASHTABLE_BUCKET (obarray, hash, slot);
514
SCM_HASHTABLE_INCREMENT (obarray);
515
if (SCM_HASHTABLE_N_ITEMS (obarray) > SCM_HASHTABLE_UPPER (obarray))
516
scm_i_rehash (obarray, scm_i_hash_symbol, 0, "obarray_enter");
523
* Enter symbol into obarray. An existing entry for symbol is replaced. If
524
* an entry existed, the old (symbol . data) cell is returned, #f otherwise.
527
obarray_replace (SCM obarray, SCM symbol, SCM data)
529
size_t hash = scm_i_symbol_hash (symbol) % SCM_HASHTABLE_N_BUCKETS (obarray);
530
SCM new_entry = scm_cons (symbol, data);
534
for (lsym = SCM_HASHTABLE_BUCKET (obarray, hash);
536
lsym = SCM_CDR (lsym))
538
SCM old_entry = SCM_CAR (lsym);
539
if (scm_is_eq (SCM_CAR (old_entry), symbol))
541
SCM_SETCAR (lsym, new_entry);
546
slot = scm_cons (new_entry, SCM_HASHTABLE_BUCKET (obarray, hash));
547
SCM_SET_HASHTABLE_BUCKET (obarray, hash, slot);
548
SCM_HASHTABLE_INCREMENT (obarray);
549
if (SCM_HASHTABLE_N_ITEMS (obarray) > SCM_HASHTABLE_UPPER (obarray))
550
scm_i_rehash (obarray, scm_i_hash_symbol, 0, "obarray_replace");
557
* Look up symbol in obarray
560
obarray_retrieve (SCM obarray, SCM sym)
562
size_t hash = scm_i_symbol_hash (sym) % SCM_HASHTABLE_N_BUCKETS (obarray);
565
for (lsym = SCM_HASHTABLE_BUCKET (obarray, hash);
567
lsym = SCM_CDR (lsym))
569
SCM entry = SCM_CAR (lsym);
570
if (scm_is_eq (SCM_CAR (entry), sym))
574
return SCM_UNDEFINED;
579
* Remove entry from obarray. If the symbol was found and removed, the old
580
* (symbol . data) cell is returned, #f otherwise.
583
obarray_remove (SCM obarray, SCM sym)
585
size_t hash = scm_i_symbol_hash (sym) % SCM_HASHTABLE_N_BUCKETS (obarray);
586
SCM table_entry = SCM_HASHTABLE_BUCKET (obarray, hash);
587
SCM handle = scm_sloppy_assq (sym, table_entry);
589
if (scm_is_pair (handle))
591
SCM new_table_entry = scm_delq1_x (handle, table_entry);
592
SCM_SET_HASHTABLE_BUCKET (obarray, hash, new_table_entry);
593
SCM_HASHTABLE_DECREMENT (obarray);
601
obarray_remove_all (SCM obarray)
603
size_t size = SCM_HASHTABLE_N_BUCKETS (obarray);
606
for (i = 0; i < size; i++)
608
SCM_SET_HASHTABLE_BUCKET (obarray, i, SCM_EOL);
610
SCM_SET_HASHTABLE_N_ITEMS (obarray, 0);
615
/* core environments base
617
* This struct and the corresponding functions form a base class for guile's
618
* built-in environment types.
622
struct core_environments_base {
623
struct scm_environment_funcs *funcs;
630
#define CORE_ENVIRONMENTS_BASE(env) \
631
((struct core_environments_base *) SCM_CELL_WORD_1 (env))
632
#define CORE_ENVIRONMENT_OBSERVERS(env) \
633
(CORE_ENVIRONMENTS_BASE (env)->observers)
634
#define SCM_SET_CORE_ENVIRONMENT_OBSERVERS(env, v) \
635
(CORE_ENVIRONMENT_OBSERVERS (env) = (v))
636
#define CORE_ENVIRONMENT_WEAK_OBSERVER_VECTOR(env) \
637
(CORE_ENVIRONMENTS_BASE (env)->weak_observers)
638
#define CORE_ENVIRONMENT_WEAK_OBSERVERS(env) \
639
(scm_c_vector_ref (CORE_ENVIRONMENT_WEAK_OBSERVER_VECTOR (env), 0))
640
#define SCM_SET_CORE_ENVIRONMENT_WEAK_OBSERVERS(env, v) \
641
(scm_c_vector_set_x (CORE_ENVIRONMENT_WEAK_OBSERVER_VECTOR (env), 0, (v)))
646
core_environments_observe (SCM env, scm_environment_observer proc, SCM data, int weak_p)
648
SCM observer = scm_double_cell (scm_tc16_observer,
655
SCM observers = CORE_ENVIRONMENT_OBSERVERS (env);
656
SCM new_observers = scm_cons (observer, observers);
657
SCM_SET_CORE_ENVIRONMENT_OBSERVERS (env, new_observers);
661
SCM observers = CORE_ENVIRONMENT_WEAK_OBSERVERS (env);
662
SCM new_observers = scm_acons (SCM_BOOL_F, observer, observers);
663
SCM_SET_CORE_ENVIRONMENT_WEAK_OBSERVERS (env, new_observers);
671
core_environments_unobserve (SCM env, SCM observer)
673
unsigned int handling_weaks;
674
for (handling_weaks = 0; handling_weaks <= 1; ++handling_weaks)
676
SCM l = handling_weaks
677
? CORE_ENVIRONMENT_WEAK_OBSERVERS (env)
678
: CORE_ENVIRONMENT_OBSERVERS (env);
680
if (!scm_is_null (l))
682
SCM rest = SCM_CDR (l);
683
SCM first = handling_weaks
687
if (scm_is_eq (first, observer))
689
/* Remove the first observer */
691
SCM_SET_CORE_ENVIRONMENT_WEAK_OBSERVERS (env, rest);
693
SCM_SET_CORE_ENVIRONMENT_OBSERVERS (env, rest);
698
SCM rest = SCM_CDR (l);
700
if (!scm_is_null (rest))
702
SCM next = handling_weaks
706
if (scm_is_eq (next, observer))
708
SCM_SETCDR (l, SCM_CDR (rest));
714
} while (!scm_is_null (l));
718
/* Dirk:FIXME:: What to do now, since the observer is not found? */
723
core_environments_mark (SCM env)
725
scm_gc_mark (CORE_ENVIRONMENT_OBSERVERS (env));
726
return CORE_ENVIRONMENT_WEAK_OBSERVER_VECTOR (env);
731
core_environments_finalize (SCM env SCM_UNUSED)
737
core_environments_preinit (struct core_environments_base *body)
740
body->observers = SCM_BOOL_F;
741
body->weak_observers = SCM_BOOL_F;
746
core_environments_init (struct core_environments_base *body,
747
struct scm_environment_funcs *funcs)
750
body->observers = SCM_EOL;
751
body->weak_observers = scm_make_weak_value_alist_vector (scm_from_int (1));
755
/* Tell all observers to clear their caches.
757
* Environments have to be informed about changes in the following cases:
758
* - The observed env has a new binding. This must be always reported.
759
* - The observed env has dropped a binding. This must be always reported.
760
* - A binding in the observed environment has changed. This must only be
761
* reported, if there is a chance that the binding is being cached outside.
762
* However, this potential optimization is not performed currently.
764
* Errors that occur while the observers are called are accumulated and
765
* signalled as one single error message to the caller.
776
update_catch_body (void *ptr)
778
struct update_data *data = (struct update_data *) ptr;
779
SCM observer = data->observer;
781
(*SCM_OBSERVER_PROC (observer))
782
(data->environment, SCM_OBSERVER_DATA (observer));
784
return SCM_UNDEFINED;
789
update_catch_handler (void *ptr, SCM tag, SCM args)
791
struct update_data *data = (struct update_data *) ptr;
792
SCM observer = data->observer;
794
scm_from_locale_string ("Observer `~A' signals `~A' error: ~S");
796
return scm_cons (message, scm_list_3 (observer, tag, args));
801
core_environments_broadcast (SCM env)
802
#define FUNC_NAME "core_environments_broadcast"
804
unsigned int handling_weaks;
805
SCM errors = SCM_EOL;
807
for (handling_weaks = 0; handling_weaks <= 1; ++handling_weaks)
809
SCM observers = handling_weaks
810
? CORE_ENVIRONMENT_WEAK_OBSERVERS (env)
811
: CORE_ENVIRONMENT_OBSERVERS (env);
813
for (; !scm_is_null (observers); observers = SCM_CDR (observers))
815
struct update_data data;
816
SCM observer = handling_weaks
817
? SCM_CDAR (observers)
818
: SCM_CAR (observers);
821
data.observer = observer;
822
data.environment = env;
824
error = scm_internal_catch (SCM_BOOL_T,
825
update_catch_body, &data,
826
update_catch_handler, &data);
828
if (!SCM_UNBNDP (error))
829
errors = scm_cons (error, errors);
833
if (!scm_is_null (errors))
835
/* Dirk:FIXME:: As soon as scm_misc_error is fixed to handle the name
836
* parameter correctly it should not be necessary any more to also pass
837
* namestr in order to get the desired information from the error
840
SCM ordered_errors = scm_reverse (errors);
843
"Observers of `~A' have signalled the following errors: ~S",
844
scm_cons2 (env, ordered_errors, SCM_EOL));
853
* A leaf environment is simply a mutable set of definitions. A leaf
854
* environment supports no operations beyond the common set.
856
* Implementation: The obarray of the leaf environment holds (symbol . value)
857
* pairs. No further information is necessary, since all bindings and
858
* locations in a leaf environment are mutable.
862
struct leaf_environment {
863
struct core_environments_base base;
869
#define LEAF_ENVIRONMENT(env) \
870
((struct leaf_environment *) SCM_CELL_WORD_1 (env))
875
leaf_environment_ref (SCM env, SCM sym)
877
SCM obarray = LEAF_ENVIRONMENT (env)->obarray;
878
SCM binding = obarray_retrieve (obarray, sym);
879
return SCM_UNBNDP (binding) ? binding : SCM_CDR (binding);
884
leaf_environment_fold (SCM env, scm_environment_folder proc, SCM data, SCM init)
888
SCM obarray = LEAF_ENVIRONMENT (env)->obarray;
890
for (i = 0; i < SCM_HASHTABLE_N_BUCKETS (obarray); i++)
893
for (l = SCM_HASHTABLE_BUCKET (obarray, i);
897
SCM binding = SCM_CAR (l);
898
SCM symbol = SCM_CAR (binding);
899
SCM value = SCM_CDR (binding);
900
result = (*proc) (data, symbol, value, result);
908
leaf_environment_define (SCM env, SCM sym, SCM val)
909
#define FUNC_NAME "leaf_environment_define"
911
SCM obarray = LEAF_ENVIRONMENT (env)->obarray;
913
obarray_replace (obarray, sym, val);
914
core_environments_broadcast (env);
916
return SCM_ENVIRONMENT_SUCCESS;
922
leaf_environment_undefine (SCM env, SCM sym)
923
#define FUNC_NAME "leaf_environment_undefine"
925
SCM obarray = LEAF_ENVIRONMENT (env)->obarray;
926
SCM removed = obarray_remove (obarray, sym);
928
if (scm_is_true (removed))
929
core_environments_broadcast (env);
931
return SCM_ENVIRONMENT_SUCCESS;
937
leaf_environment_set_x (SCM env, SCM sym, SCM val)
938
#define FUNC_NAME "leaf_environment_set_x"
940
SCM obarray = LEAF_ENVIRONMENT (env)->obarray;
941
SCM binding = obarray_retrieve (obarray, sym);
943
if (!SCM_UNBNDP (binding))
945
SCM_SETCDR (binding, val);
946
return SCM_ENVIRONMENT_SUCCESS;
950
return SCM_UNDEFINED;
957
leaf_environment_cell (SCM env, SCM sym, int for_write SCM_UNUSED)
959
SCM obarray = LEAF_ENVIRONMENT (env)->obarray;
960
SCM binding = obarray_retrieve (obarray, sym);
966
leaf_environment_mark (SCM env)
968
scm_gc_mark (LEAF_ENVIRONMENT (env)->obarray);
969
return core_environments_mark (env);
974
leaf_environment_free (SCM env)
976
core_environments_finalize (env);
977
scm_gc_free (LEAF_ENVIRONMENT (env), sizeof (struct leaf_environment),
983
leaf_environment_print (SCM type, SCM port, scm_print_state *pstate SCM_UNUSED)
985
SCM address = scm_from_size_t (SCM_UNPACK (type));
986
SCM base16 = scm_number_to_string (address, scm_from_int (16));
988
scm_puts ("#<leaf environment ", port);
989
scm_display (base16, port);
990
scm_puts (">", port);
996
static struct scm_environment_funcs leaf_environment_funcs = {
997
leaf_environment_ref,
998
leaf_environment_fold,
999
leaf_environment_define,
1000
leaf_environment_undefine,
1001
leaf_environment_set_x,
1002
leaf_environment_cell,
1003
core_environments_observe,
1004
core_environments_unobserve,
1005
leaf_environment_mark,
1006
leaf_environment_free,
1007
leaf_environment_print
1011
void *scm_type_leaf_environment = &leaf_environment_funcs;
1014
SCM_DEFINE (scm_make_leaf_environment, "make-leaf-environment", 0, 0, 0,
1016
"Create a new leaf environment, containing no bindings.\n"
1017
"All bindings and locations created in the new environment\n"
1019
#define FUNC_NAME s_scm_make_leaf_environment
1021
size_t size = sizeof (struct leaf_environment);
1022
struct leaf_environment *body = scm_gc_malloc (size, "leaf environment");
1025
core_environments_preinit (&body->base);
1026
body->obarray = SCM_BOOL_F;
1028
env = scm_make_environment (body);
1030
core_environments_init (&body->base, &leaf_environment_funcs);
1031
body->obarray = scm_c_make_hash_table (DEFAULT_OBARRAY_SIZE);
1038
SCM_DEFINE (scm_leaf_environment_p, "leaf-environment?", 1, 0, 0,
1040
"Return @code{#t} if object is a leaf environment, or @code{#f}\n"
1042
#define FUNC_NAME s_scm_leaf_environment_p
1044
return scm_from_bool (SCM_LEAF_ENVIRONMENT_P (object));
1050
/* eval environments
1052
* A module's source code refers to definitions imported from other modules,
1053
* and definitions made within itself. An eval environment combines two
1054
* environments -- a local environment and an imported environment -- to
1055
* produce a new environment in which both sorts of references can be
1058
* Implementation: The obarray of the eval environment is used to cache
1059
* entries from the local and imported environments such that in most of the
1060
* cases only a single lookup is necessary. Since for neither the local nor
1061
* the imported environment it is known, what kind of environment they form,
1062
* the most general case is assumed. Therefore, entries in the obarray take
1063
* one of the following forms:
1065
* 1) (<symbol> location mutability . source-env), where mutability indicates
1066
* one of the following states: IMMUTABLE if the location is known to be
1067
* immutable, MUTABLE if the location is known to be mutable, UNKNOWN if
1068
* the location has only been requested for non modifying accesses.
1070
* 2) (symbol . source-env) if the symbol has a binding in the source-env, but
1071
* if the source-env can't provide a cell for the binding. Thus, for every
1072
* access, the source-env has to be contacted directly.
1076
struct eval_environment {
1077
struct core_environments_base base;
1082
SCM imported_observer;
1088
#define EVAL_ENVIRONMENT(env) \
1089
((struct eval_environment *) SCM_CELL_WORD_1 (env))
1091
#define IMMUTABLE SCM_I_MAKINUM (0)
1092
#define MUTABLE SCM_I_MAKINUM (1)
1093
#define UNKNOWN SCM_I_MAKINUM (2)
1095
#define CACHED_LOCATION(x) SCM_CAR (x)
1096
#define CACHED_MUTABILITY(x) SCM_CADR (x)
1097
#define SET_CACHED_MUTABILITY(x, v) SCM_SETCAR (SCM_CDR (x), (v))
1098
#define CACHED_SOURCE_ENVIRONMENT(x) SCM_CDDR (x)
1102
/* eval_environment_lookup will report one of the following distinct results:
1103
* a) (<object> . value) if a cell could be obtained.
1104
* b) <environment> if the environment has to be contacted directly.
1105
* c) IMMUTABLE if an immutable cell was requested for write.
1106
* d) SCM_UNDEFINED if there is no binding for the symbol.
1109
eval_environment_lookup (SCM env, SCM sym, int for_write)
1111
SCM obarray = EVAL_ENVIRONMENT (env)->obarray;
1112
SCM binding = obarray_retrieve (obarray, sym);
1114
if (!SCM_UNBNDP (binding))
1116
/* The obarray holds an entry for the symbol. */
1118
SCM entry = SCM_CDR (binding);
1120
if (scm_is_pair (entry))
1122
/* The entry in the obarray is a cached location. */
1124
SCM location = CACHED_LOCATION (entry);
1130
mutability = CACHED_MUTABILITY (entry);
1131
if (scm_is_eq (mutability, MUTABLE))
1134
if (scm_is_eq (mutability, UNKNOWN))
1136
SCM source_env = CACHED_SOURCE_ENVIRONMENT (entry);
1137
SCM location = SCM_ENVIRONMENT_CELL (source_env, sym, 1);
1139
if (scm_is_pair (location))
1141
SET_CACHED_MUTABILITY (entry, MUTABLE);
1144
else /* IMMUTABLE */
1146
SET_CACHED_MUTABILITY (entry, IMMUTABLE);
1155
/* The obarray entry is an environment */
1162
/* There is no entry for the symbol in the obarray. This can either
1163
* mean that there has not been a request for the symbol yet, or that
1164
* the symbol is really undefined. We are looking for the symbol in
1165
* both the local and the imported environment. If we find a binding, a
1166
* cached entry is created.
1169
struct eval_environment *body = EVAL_ENVIRONMENT (env);
1170
unsigned int handling_import;
1172
for (handling_import = 0; handling_import <= 1; ++handling_import)
1174
SCM source_env = handling_import ? body->imported : body->local;
1175
SCM location = SCM_ENVIRONMENT_CELL (source_env, sym, for_write);
1177
if (!SCM_UNBNDP (location))
1179
if (scm_is_pair (location))
1181
SCM mutability = for_write ? MUTABLE : UNKNOWN;
1182
SCM entry = scm_cons2 (location, mutability, source_env);
1183
obarray_enter (obarray, sym, entry);
1186
else if (scm_is_eq (location, SCM_ENVIRONMENT_LOCATION_NO_CELL))
1188
obarray_enter (obarray, sym, source_env);
1198
return SCM_UNDEFINED;
1204
eval_environment_ref (SCM env, SCM sym)
1205
#define FUNC_NAME "eval_environment_ref"
1207
SCM location = eval_environment_lookup (env, sym, 0);
1209
if (scm_is_pair (location))
1210
return SCM_CDR (location);
1211
else if (!SCM_UNBNDP (location))
1212
return SCM_ENVIRONMENT_REF (location, sym);
1214
return SCM_UNDEFINED;
1220
eval_environment_folder (SCM extended_data, SCM symbol, SCM value, SCM tail)
1222
SCM local = SCM_CAR (extended_data);
1224
if (!SCM_ENVIRONMENT_BOUND_P (local, symbol))
1226
SCM proc_as_nr = SCM_CADR (extended_data);
1227
unsigned long int proc_as_ul = scm_to_ulong (proc_as_nr);
1228
scm_environment_folder proc = (scm_environment_folder) proc_as_ul;
1229
SCM data = SCM_CDDR (extended_data);
1231
return (*proc) (data, symbol, value, tail);
1241
eval_environment_fold (SCM env, scm_environment_folder proc, SCM data, SCM init)
1243
SCM local = EVAL_ENVIRONMENT (env)->local;
1244
SCM imported = EVAL_ENVIRONMENT (env)->imported;
1245
SCM proc_as_nr = scm_from_ulong ((unsigned long) proc);
1246
SCM extended_data = scm_cons2 (local, proc_as_nr, data);
1247
SCM tmp_result = scm_c_environment_fold (imported, eval_environment_folder, extended_data, init);
1249
return scm_c_environment_fold (local, proc, data, tmp_result);
1254
eval_environment_define (SCM env, SCM sym, SCM val)
1255
#define FUNC_NAME "eval_environment_define"
1257
SCM local = EVAL_ENVIRONMENT (env)->local;
1258
return SCM_ENVIRONMENT_DEFINE (local, sym, val);
1264
eval_environment_undefine (SCM env, SCM sym)
1265
#define FUNC_NAME "eval_environment_undefine"
1267
SCM local = EVAL_ENVIRONMENT (env)->local;
1268
return SCM_ENVIRONMENT_UNDEFINE (local, sym);
1274
eval_environment_set_x (SCM env, SCM sym, SCM val)
1275
#define FUNC_NAME "eval_environment_set_x"
1277
SCM location = eval_environment_lookup (env, sym, 1);
1279
if (scm_is_pair (location))
1281
SCM_SETCDR (location, val);
1282
return SCM_ENVIRONMENT_SUCCESS;
1284
else if (SCM_ENVIRONMENT_P (location))
1286
return SCM_ENVIRONMENT_SET (location, sym, val);
1288
else if (scm_is_eq (location, IMMUTABLE))
1290
return SCM_ENVIRONMENT_LOCATION_IMMUTABLE;
1294
return SCM_UNDEFINED;
1301
eval_environment_cell (SCM env, SCM sym, int for_write)
1302
#define FUNC_NAME "eval_environment_cell"
1304
SCM location = eval_environment_lookup (env, sym, for_write);
1306
if (scm_is_pair (location))
1308
else if (SCM_ENVIRONMENT_P (location))
1309
return SCM_ENVIRONMENT_LOCATION_NO_CELL;
1310
else if (scm_is_eq (location, IMMUTABLE))
1311
return SCM_ENVIRONMENT_LOCATION_IMMUTABLE;
1313
return SCM_UNDEFINED;
1319
eval_environment_mark (SCM env)
1321
struct eval_environment *body = EVAL_ENVIRONMENT (env);
1323
scm_gc_mark (body->obarray);
1324
scm_gc_mark (body->imported);
1325
scm_gc_mark (body->imported_observer);
1326
scm_gc_mark (body->local);
1327
scm_gc_mark (body->local_observer);
1329
return core_environments_mark (env);
1334
eval_environment_free (SCM env)
1336
core_environments_finalize (env);
1337
scm_gc_free (EVAL_ENVIRONMENT (env), sizeof (struct eval_environment),
1338
"eval environment");
1343
eval_environment_print (SCM type, SCM port, scm_print_state *pstate SCM_UNUSED)
1345
SCM address = scm_from_size_t (SCM_UNPACK (type));
1346
SCM base16 = scm_number_to_string (address, scm_from_int (16));
1348
scm_puts ("#<eval environment ", port);
1349
scm_display (base16, port);
1350
scm_puts (">", port);
1356
static struct scm_environment_funcs eval_environment_funcs = {
1357
eval_environment_ref,
1358
eval_environment_fold,
1359
eval_environment_define,
1360
eval_environment_undefine,
1361
eval_environment_set_x,
1362
eval_environment_cell,
1363
core_environments_observe,
1364
core_environments_unobserve,
1365
eval_environment_mark,
1366
eval_environment_free,
1367
eval_environment_print
1371
void *scm_type_eval_environment = &eval_environment_funcs;
1375
eval_environment_observer (SCM caller SCM_UNUSED, SCM eval_env)
1377
SCM obarray = EVAL_ENVIRONMENT (eval_env)->obarray;
1379
obarray_remove_all (obarray);
1380
core_environments_broadcast (eval_env);
1384
SCM_DEFINE (scm_make_eval_environment, "make-eval-environment", 2, 0, 0,
1385
(SCM local, SCM imported),
1386
"Return a new environment object eval whose bindings are the\n"
1387
"union of the bindings in the environments @var{local} and\n"
1388
"@var{imported}, with bindings from @var{local} taking\n"
1389
"precedence. Definitions made in eval are placed in @var{local}.\n"
1390
"Applying @code{environment-define} or\n"
1391
"@code{environment-undefine} to eval has the same effect as\n"
1392
"applying the procedure to @var{local}.\n"
1393
"Note that eval incorporates @var{local} and @var{imported} by\n"
1395
"If, after creating eval, the program changes the bindings of\n"
1396
"@var{local} or @var{imported}, those changes will be visible\n"
1398
"Since most Scheme evaluation takes place in eval environments,\n"
1399
"they transparently cache the bindings received from @var{local}\n"
1400
"and @var{imported}. Thus, the first time the program looks up\n"
1401
"a symbol in eval, eval may make calls to @var{local} or\n"
1402
"@var{imported} to find their bindings, but subsequent\n"
1403
"references to that symbol will be as fast as references to\n"
1404
"bindings in finite environments.\n"
1405
"In typical use, @var{local} will be a finite environment, and\n"
1406
"@var{imported} will be an import environment")
1407
#define FUNC_NAME s_scm_make_eval_environment
1410
struct eval_environment *body;
1412
SCM_ASSERT (SCM_ENVIRONMENT_P (local), local, SCM_ARG1, FUNC_NAME);
1413
SCM_ASSERT (SCM_ENVIRONMENT_P (imported), imported, SCM_ARG2, FUNC_NAME);
1415
body = scm_gc_malloc (sizeof (struct eval_environment), "eval environment");
1417
core_environments_preinit (&body->base);
1418
body->obarray = SCM_BOOL_F;
1419
body->imported = SCM_BOOL_F;
1420
body->imported_observer = SCM_BOOL_F;
1421
body->local = SCM_BOOL_F;
1422
body->local_observer = SCM_BOOL_F;
1424
env = scm_make_environment (body);
1426
core_environments_init (&body->base, &eval_environment_funcs);
1427
body->obarray = scm_c_make_hash_table (DEFAULT_OBARRAY_SIZE);
1428
body->imported = imported;
1429
body->imported_observer
1430
= SCM_ENVIRONMENT_OBSERVE (imported, eval_environment_observer, env, 1);
1431
body->local = local;
1432
body->local_observer
1433
= SCM_ENVIRONMENT_OBSERVE (local, eval_environment_observer, env, 1);
1440
SCM_DEFINE (scm_eval_environment_p, "eval-environment?", 1, 0, 0,
1442
"Return @code{#t} if object is an eval environment, or @code{#f}\n"
1444
#define FUNC_NAME s_scm_eval_environment_p
1446
return scm_from_bool (SCM_EVAL_ENVIRONMENT_P (object));
1451
SCM_DEFINE (scm_eval_environment_local, "eval-environment-local", 1, 0, 0,
1453
"Return the local environment of eval environment @var{env}.")
1454
#define FUNC_NAME s_scm_eval_environment_local
1456
SCM_ASSERT (SCM_EVAL_ENVIRONMENT_P (env), env, SCM_ARG1, FUNC_NAME);
1458
return EVAL_ENVIRONMENT (env)->local;
1463
SCM_DEFINE (scm_eval_environment_set_local_x, "eval-environment-set-local!", 2, 0, 0,
1464
(SCM env, SCM local),
1465
"Change @var{env}'s local environment to @var{local}.")
1466
#define FUNC_NAME s_scm_eval_environment_set_local_x
1468
struct eval_environment *body;
1470
SCM_ASSERT (SCM_EVAL_ENVIRONMENT_P (env), env, SCM_ARG1, FUNC_NAME);
1471
SCM_ASSERT (SCM_ENVIRONMENT_P (local), local, SCM_ARG2, FUNC_NAME);
1473
body = EVAL_ENVIRONMENT (env);
1475
obarray_remove_all (body->obarray);
1476
SCM_ENVIRONMENT_UNOBSERVE (body->local, body->local_observer);
1478
body->local = local;
1479
body->local_observer
1480
= SCM_ENVIRONMENT_OBSERVE (local, eval_environment_observer, env, 1);
1482
core_environments_broadcast (env);
1484
return SCM_UNSPECIFIED;
1489
SCM_DEFINE (scm_eval_environment_imported, "eval-environment-imported", 1, 0, 0,
1491
"Return the imported environment of eval environment @var{env}.")
1492
#define FUNC_NAME s_scm_eval_environment_imported
1494
SCM_ASSERT (SCM_EVAL_ENVIRONMENT_P (env), env, SCM_ARG1, FUNC_NAME);
1496
return EVAL_ENVIRONMENT (env)->imported;
1501
SCM_DEFINE (scm_eval_environment_set_imported_x, "eval-environment-set-imported!", 2, 0, 0,
1502
(SCM env, SCM imported),
1503
"Change @var{env}'s imported environment to @var{imported}.")
1504
#define FUNC_NAME s_scm_eval_environment_set_imported_x
1506
struct eval_environment *body;
1508
SCM_ASSERT (SCM_EVAL_ENVIRONMENT_P (env), env, SCM_ARG1, FUNC_NAME);
1509
SCM_ASSERT (SCM_ENVIRONMENT_P (imported), imported, SCM_ARG2, FUNC_NAME);
1511
body = EVAL_ENVIRONMENT (env);
1513
obarray_remove_all (body->obarray);
1514
SCM_ENVIRONMENT_UNOBSERVE (body->imported, body->imported_observer);
1516
body->imported = imported;
1517
body->imported_observer
1518
= SCM_ENVIRONMENT_OBSERVE (imported, eval_environment_observer, env, 1);
1520
core_environments_broadcast (env);
1522
return SCM_UNSPECIFIED;
1528
/* import environments
1530
* An import environment combines the bindings of a set of argument
1531
* environments, and checks for naming clashes.
1533
* Implementation: The import environment does no caching at all. For every
1534
* access, the list of imported environments is scanned.
1538
struct import_environment {
1539
struct core_environments_base base;
1542
SCM import_observers;
1548
#define IMPORT_ENVIRONMENT(env) \
1549
((struct import_environment *) SCM_CELL_WORD_1 (env))
1553
/* Lookup will report one of the following distinct results:
1554
* a) <environment> if only environment binds the symbol.
1555
* b) (env-1 env-2 ...) for conflicting bindings in env-1, ...
1556
* c) SCM_UNDEFINED if there is no binding for the symbol.
1559
import_environment_lookup (SCM env, SCM sym)
1561
SCM imports = IMPORT_ENVIRONMENT (env)->imports;
1562
SCM result = SCM_UNDEFINED;
1565
for (l = imports; !scm_is_null (l); l = SCM_CDR (l))
1567
SCM imported = SCM_CAR (l);
1569
if (SCM_ENVIRONMENT_BOUND_P (imported, sym))
1571
if (SCM_UNBNDP (result))
1573
else if (scm_is_pair (result))
1574
result = scm_cons (imported, result);
1576
result = scm_cons2 (imported, result, SCM_EOL);
1580
if (scm_is_pair (result))
1581
return scm_reverse (result);
1588
import_environment_conflict (SCM env, SCM sym, SCM imports)
1590
SCM conflict_proc = IMPORT_ENVIRONMENT (env)->conflict_proc;
1591
SCM args = scm_cons2 (env, sym, scm_cons (imports, SCM_EOL));
1593
return scm_apply_0 (conflict_proc, args);
1598
import_environment_ref (SCM env, SCM sym)
1599
#define FUNC_NAME "import_environment_ref"
1601
SCM owner = import_environment_lookup (env, sym);
1603
if (SCM_UNBNDP (owner))
1605
return SCM_UNDEFINED;
1607
else if (scm_is_pair (owner))
1609
SCM resolve = import_environment_conflict (env, sym, owner);
1611
if (SCM_ENVIRONMENT_P (resolve))
1612
return SCM_ENVIRONMENT_REF (resolve, sym);
1614
return SCM_UNSPECIFIED;
1618
return SCM_ENVIRONMENT_REF (owner, sym);
1625
import_environment_folder (SCM extended_data, SCM symbol, SCM value, SCM tail)
1626
#define FUNC_NAME "import_environment_fold"
1628
SCM import_env = SCM_CAR (extended_data);
1629
SCM imported_env = SCM_CADR (extended_data);
1630
SCM owner = import_environment_lookup (import_env, symbol);
1631
SCM proc_as_nr = SCM_CADDR (extended_data);
1632
unsigned long int proc_as_ul = scm_to_ulong (proc_as_nr);
1633
scm_environment_folder proc = (scm_environment_folder) proc_as_ul;
1634
SCM data = SCM_CDDDR (extended_data);
1636
if (scm_is_pair (owner) && scm_is_eq (SCM_CAR (owner), imported_env))
1637
owner = import_environment_conflict (import_env, symbol, owner);
1639
if (SCM_ENVIRONMENT_P (owner))
1640
return (*proc) (data, symbol, value, tail);
1641
else /* unresolved conflict */
1642
return (*proc) (data, symbol, SCM_UNSPECIFIED, tail);
1648
import_environment_fold (SCM env, scm_environment_folder proc, SCM data, SCM init)
1650
SCM proc_as_nr = scm_from_ulong ((unsigned long) proc);
1654
for (l = IMPORT_ENVIRONMENT (env)->imports; !scm_is_null (l); l = SCM_CDR (l))
1656
SCM imported_env = SCM_CAR (l);
1657
SCM extended_data = scm_cons (env, scm_cons2 (imported_env, proc_as_nr, data));
1659
result = scm_c_environment_fold (imported_env, import_environment_folder, extended_data, result);
1667
import_environment_define (SCM env SCM_UNUSED,
1670
#define FUNC_NAME "import_environment_define"
1672
return SCM_ENVIRONMENT_BINDING_IMMUTABLE;
1678
import_environment_undefine (SCM env SCM_UNUSED,
1680
#define FUNC_NAME "import_environment_undefine"
1682
return SCM_ENVIRONMENT_BINDING_IMMUTABLE;
1688
import_environment_set_x (SCM env, SCM sym, SCM val)
1689
#define FUNC_NAME "import_environment_set_x"
1691
SCM owner = import_environment_lookup (env, sym);
1693
if (SCM_UNBNDP (owner))
1695
return SCM_UNDEFINED;
1697
else if (scm_is_pair (owner))
1699
SCM resolve = import_environment_conflict (env, sym, owner);
1701
if (SCM_ENVIRONMENT_P (resolve))
1702
return SCM_ENVIRONMENT_SET (resolve, sym, val);
1704
return SCM_ENVIRONMENT_LOCATION_IMMUTABLE;
1708
return SCM_ENVIRONMENT_SET (owner, sym, val);
1715
import_environment_cell (SCM env, SCM sym, int for_write)
1716
#define FUNC_NAME "import_environment_cell"
1718
SCM owner = import_environment_lookup (env, sym);
1720
if (SCM_UNBNDP (owner))
1722
return SCM_UNDEFINED;
1724
else if (scm_is_pair (owner))
1726
SCM resolve = import_environment_conflict (env, sym, owner);
1728
if (SCM_ENVIRONMENT_P (resolve))
1729
return SCM_ENVIRONMENT_CELL (resolve, sym, for_write);
1731
return SCM_ENVIRONMENT_LOCATION_NO_CELL;
1735
return SCM_ENVIRONMENT_CELL (owner, sym, for_write);
1742
import_environment_mark (SCM env)
1744
scm_gc_mark (IMPORT_ENVIRONMENT (env)->imports);
1745
scm_gc_mark (IMPORT_ENVIRONMENT (env)->import_observers);
1746
scm_gc_mark (IMPORT_ENVIRONMENT (env)->conflict_proc);
1747
return core_environments_mark (env);
1752
import_environment_free (SCM env)
1754
core_environments_finalize (env);
1755
scm_gc_free (IMPORT_ENVIRONMENT (env), sizeof (struct import_environment),
1756
"import environment");
1761
import_environment_print (SCM type, SCM port,
1762
scm_print_state *pstate SCM_UNUSED)
1764
SCM address = scm_from_size_t (SCM_UNPACK (type));
1765
SCM base16 = scm_number_to_string (address, scm_from_int (16));
1767
scm_puts ("#<import environment ", port);
1768
scm_display (base16, port);
1769
scm_puts (">", port);
1775
static struct scm_environment_funcs import_environment_funcs = {
1776
import_environment_ref,
1777
import_environment_fold,
1778
import_environment_define,
1779
import_environment_undefine,
1780
import_environment_set_x,
1781
import_environment_cell,
1782
core_environments_observe,
1783
core_environments_unobserve,
1784
import_environment_mark,
1785
import_environment_free,
1786
import_environment_print
1790
void *scm_type_import_environment = &import_environment_funcs;
1794
import_environment_observer (SCM caller SCM_UNUSED, SCM import_env)
1796
core_environments_broadcast (import_env);
1800
SCM_DEFINE (scm_make_import_environment, "make-import-environment", 2, 0, 0,
1801
(SCM imports, SCM conflict_proc),
1802
"Return a new environment @var{imp} whose bindings are the union\n"
1803
"of the bindings from the environments in @var{imports};\n"
1804
"@var{imports} must be a list of environments. That is,\n"
1805
"@var{imp} binds a symbol to a location when some element of\n"
1806
"@var{imports} does.\n"
1807
"If two different elements of @var{imports} have a binding for\n"
1808
"the same symbol, the @var{conflict-proc} is called with the\n"
1809
"following parameters: the import environment, the symbol and\n"
1810
"the list of the imported environments that bind the symbol.\n"
1811
"If the @var{conflict-proc} returns an environment @var{env},\n"
1812
"the conflict is considered as resolved and the binding from\n"
1813
"@var{env} is used. If the @var{conflict-proc} returns some\n"
1814
"non-environment object, the conflict is considered unresolved\n"
1815
"and the symbol is treated as unspecified in the import\n"
1817
"The checking for conflicts may be performed lazily, i. e. at\n"
1818
"the moment when a value or binding for a certain symbol is\n"
1819
"requested instead of the moment when the environment is\n"
1820
"created or the bindings of the imports change.\n"
1821
"All bindings in @var{imp} are immutable. If you apply\n"
1822
"@code{environment-define} or @code{environment-undefine} to\n"
1823
"@var{imp}, Guile will signal an\n"
1824
" @code{environment:immutable-binding} error. However,\n"
1825
"notice that the set of bindings in @var{imp} may still change,\n"
1826
"if one of its imported environments changes.")
1827
#define FUNC_NAME s_scm_make_import_environment
1829
size_t size = sizeof (struct import_environment);
1830
struct import_environment *body = scm_gc_malloc (size, "import environment");
1833
core_environments_preinit (&body->base);
1834
body->imports = SCM_BOOL_F;
1835
body->import_observers = SCM_BOOL_F;
1836
body->conflict_proc = SCM_BOOL_F;
1838
env = scm_make_environment (body);
1840
core_environments_init (&body->base, &import_environment_funcs);
1841
body->imports = SCM_EOL;
1842
body->import_observers = SCM_EOL;
1843
body->conflict_proc = conflict_proc;
1845
scm_import_environment_set_imports_x (env, imports);
1852
SCM_DEFINE (scm_import_environment_p, "import-environment?", 1, 0, 0,
1854
"Return @code{#t} if object is an import environment, or\n"
1855
"@code{#f} otherwise.")
1856
#define FUNC_NAME s_scm_import_environment_p
1858
return scm_from_bool (SCM_IMPORT_ENVIRONMENT_P (object));
1863
SCM_DEFINE (scm_import_environment_imports, "import-environment-imports", 1, 0, 0,
1865
"Return the list of environments imported by the import\n"
1866
"environment @var{env}.")
1867
#define FUNC_NAME s_scm_import_environment_imports
1869
SCM_ASSERT (SCM_IMPORT_ENVIRONMENT_P (env), env, SCM_ARG1, FUNC_NAME);
1871
return IMPORT_ENVIRONMENT (env)->imports;
1876
SCM_DEFINE (scm_import_environment_set_imports_x, "import-environment-set-imports!", 2, 0, 0,
1877
(SCM env, SCM imports),
1878
"Change @var{env}'s list of imported environments to\n"
1879
"@var{imports}, and check for conflicts.")
1880
#define FUNC_NAME s_scm_import_environment_set_imports_x
1882
struct import_environment *body = IMPORT_ENVIRONMENT (env);
1883
SCM import_observers = SCM_EOL;
1886
SCM_ASSERT (SCM_IMPORT_ENVIRONMENT_P (env), env, SCM_ARG1, FUNC_NAME);
1887
for (l = imports; scm_is_pair (l); l = SCM_CDR (l))
1889
SCM obj = SCM_CAR (l);
1890
SCM_ASSERT (SCM_ENVIRONMENT_P (obj), imports, SCM_ARG2, FUNC_NAME);
1892
SCM_ASSERT (scm_is_null (l), imports, SCM_ARG2, FUNC_NAME);
1894
for (l = body->import_observers; !scm_is_null (l); l = SCM_CDR (l))
1896
SCM obs = SCM_CAR (l);
1897
SCM_ENVIRONMENT_UNOBSERVE (env, obs);
1900
for (l = imports; !scm_is_null (l); l = SCM_CDR (l))
1902
SCM imp = SCM_CAR (l);
1903
SCM obs = SCM_ENVIRONMENT_OBSERVE (imp, import_environment_observer, env, 1);
1904
import_observers = scm_cons (obs, import_observers);
1907
body->imports = imports;
1908
body->import_observers = import_observers;
1910
return SCM_UNSPECIFIED;
1916
/* export environments
1918
* An export environment restricts an environment to a specified set of
1921
* Implementation: The export environment does no caching at all. For every
1922
* access, the signature is scanned. The signature that is stored internally
1923
* is an alist of pairs (symbol . (mutability)).
1927
struct export_environment {
1928
struct core_environments_base base;
1931
SCM private_observer;
1937
#define EXPORT_ENVIRONMENT(env) \
1938
((struct export_environment *) SCM_CELL_WORD_1 (env))
1941
SCM_SYMBOL (symbol_immutable_location, "immutable-location");
1942
SCM_SYMBOL (symbol_mutable_location, "mutable-location");
1947
export_environment_ref (SCM env, SCM sym)
1948
#define FUNC_NAME "export_environment_ref"
1950
struct export_environment *body = EXPORT_ENVIRONMENT (env);
1951
SCM entry = scm_assq (sym, body->signature);
1953
if (scm_is_false (entry))
1954
return SCM_UNDEFINED;
1956
return SCM_ENVIRONMENT_REF (body->private, sym);
1962
export_environment_fold (SCM env, scm_environment_folder proc, SCM data, SCM init)
1964
struct export_environment *body = EXPORT_ENVIRONMENT (env);
1968
for (l = body->signature; !scm_is_null (l); l = SCM_CDR (l))
1970
SCM symbol = SCM_CAR (l);
1971
SCM value = SCM_ENVIRONMENT_REF (body->private, symbol);
1972
if (!SCM_UNBNDP (value))
1973
result = (*proc) (data, symbol, value, result);
1980
export_environment_define (SCM env SCM_UNUSED,
1983
#define FUNC_NAME "export_environment_define"
1985
return SCM_ENVIRONMENT_BINDING_IMMUTABLE;
1991
export_environment_undefine (SCM env SCM_UNUSED, SCM sym SCM_UNUSED)
1992
#define FUNC_NAME "export_environment_undefine"
1994
return SCM_ENVIRONMENT_BINDING_IMMUTABLE;
2000
export_environment_set_x (SCM env, SCM sym, SCM val)
2001
#define FUNC_NAME "export_environment_set_x"
2003
struct export_environment *body = EXPORT_ENVIRONMENT (env);
2004
SCM entry = scm_assq (sym, body->signature);
2006
if (scm_is_false (entry))
2008
return SCM_UNDEFINED;
2012
if (scm_is_eq (SCM_CADR (entry), symbol_mutable_location))
2013
return SCM_ENVIRONMENT_SET (body->private, sym, val);
2015
return SCM_ENVIRONMENT_LOCATION_IMMUTABLE;
2022
export_environment_cell (SCM env, SCM sym, int for_write)
2023
#define FUNC_NAME "export_environment_cell"
2025
struct export_environment *body = EXPORT_ENVIRONMENT (env);
2026
SCM entry = scm_assq (sym, body->signature);
2028
if (scm_is_false (entry))
2030
return SCM_UNDEFINED;
2034
if (!for_write || scm_is_eq (SCM_CADR (entry), symbol_mutable_location))
2035
return SCM_ENVIRONMENT_CELL (body->private, sym, for_write);
2037
return SCM_ENVIRONMENT_LOCATION_IMMUTABLE;
2044
export_environment_mark (SCM env)
2046
struct export_environment *body = EXPORT_ENVIRONMENT (env);
2048
scm_gc_mark (body->private);
2049
scm_gc_mark (body->private_observer);
2050
scm_gc_mark (body->signature);
2052
return core_environments_mark (env);
2057
export_environment_free (SCM env)
2059
core_environments_finalize (env);
2060
scm_gc_free (EXPORT_ENVIRONMENT (env), sizeof (struct export_environment),
2061
"export environment");
2066
export_environment_print (SCM type, SCM port,
2067
scm_print_state *pstate SCM_UNUSED)
2069
SCM address = scm_from_size_t (SCM_UNPACK (type));
2070
SCM base16 = scm_number_to_string (address, scm_from_int (16));
2072
scm_puts ("#<export environment ", port);
2073
scm_display (base16, port);
2074
scm_puts (">", port);
2080
static struct scm_environment_funcs export_environment_funcs = {
2081
export_environment_ref,
2082
export_environment_fold,
2083
export_environment_define,
2084
export_environment_undefine,
2085
export_environment_set_x,
2086
export_environment_cell,
2087
core_environments_observe,
2088
core_environments_unobserve,
2089
export_environment_mark,
2090
export_environment_free,
2091
export_environment_print
2095
void *scm_type_export_environment = &export_environment_funcs;
2099
export_environment_observer (SCM caller SCM_UNUSED, SCM export_env)
2101
core_environments_broadcast (export_env);
2105
SCM_DEFINE (scm_make_export_environment, "make-export-environment", 2, 0, 0,
2106
(SCM private, SCM signature),
2107
"Return a new environment @var{exp} containing only those\n"
2108
"bindings in private whose symbols are present in\n"
2109
"@var{signature}. The @var{private} argument must be an\n"
2111
"The environment @var{exp} binds symbol to location when\n"
2112
"@var{env} does, and symbol is exported by @var{signature}.\n\n"
2113
"@var{signature} is a list specifying which of the bindings in\n"
2114
"@var{private} should be visible in @var{exp}. Each element of\n"
2115
"@var{signature} should be a list of the form:\n"
2116
" (symbol attribute ...)\n"
2117
"where each attribute is one of the following:\n"
2119
"@item the symbol @code{mutable-location}\n"
2120
" @var{exp} should treat the\n"
2121
" location bound to symbol as mutable. That is, @var{exp}\n"
2122
" will pass calls to @code{environment-set!} or\n"
2123
" @code{environment-cell} directly through to private.\n"
2124
"@item the symbol @code{immutable-location}\n"
2125
" @var{exp} should treat\n"
2126
" the location bound to symbol as immutable. If the program\n"
2127
" applies @code{environment-set!} to @var{exp} and symbol, or\n"
2128
" calls @code{environment-cell} to obtain a writable value\n"
2129
" cell, @code{environment-set!} will signal an\n"
2130
" @code{environment:immutable-location} error. Note that, even\n"
2131
" if an export environment treats a location as immutable, the\n"
2132
" underlying environment may treat it as mutable, so its\n"
2133
" value may change.\n"
2135
"It is an error for an element of signature to specify both\n"
2136
"@code{mutable-location} and @code{immutable-location}. If\n"
2137
"neither is specified, @code{immutable-location} is assumed.\n\n"
2138
"As a special case, if an element of signature is a lone\n"
2139
"symbol @var{sym}, it is equivalent to an element of the form\n"
2141
"All bindings in @var{exp} are immutable. If you apply\n"
2142
"@code{environment-define} or @code{environment-undefine} to\n"
2143
"@var{exp}, Guile will signal an\n"
2144
"@code{environment:immutable-binding} error. However,\n"
2145
"notice that the set of bindings in @var{exp} may still change,\n"
2146
"if the bindings in private change.")
2147
#define FUNC_NAME s_scm_make_export_environment
2150
struct export_environment *body;
2153
SCM_ASSERT (SCM_ENVIRONMENT_P (private), private, SCM_ARG1, FUNC_NAME);
2155
size = sizeof (struct export_environment);
2156
body = scm_gc_malloc (size, "export environment");
2158
core_environments_preinit (&body->base);
2159
body->private = SCM_BOOL_F;
2160
body->private_observer = SCM_BOOL_F;
2161
body->signature = SCM_BOOL_F;
2163
env = scm_make_environment (body);
2165
core_environments_init (&body->base, &export_environment_funcs);
2166
body->private = private;
2167
body->private_observer
2168
= SCM_ENVIRONMENT_OBSERVE (private, export_environment_observer, env, 1);
2169
body->signature = SCM_EOL;
2171
scm_export_environment_set_signature_x (env, signature);
2178
SCM_DEFINE (scm_export_environment_p, "export-environment?", 1, 0, 0,
2180
"Return @code{#t} if object is an export environment, or\n"
2181
"@code{#f} otherwise.")
2182
#define FUNC_NAME s_scm_export_environment_p
2184
return scm_from_bool (SCM_EXPORT_ENVIRONMENT_P (object));
2189
SCM_DEFINE (scm_export_environment_private, "export-environment-private", 1, 0, 0,
2191
"Return the private environment of export environment @var{env}.")
2192
#define FUNC_NAME s_scm_export_environment_private
2194
SCM_ASSERT (SCM_EXPORT_ENVIRONMENT_P (env), env, SCM_ARG1, FUNC_NAME);
2196
return EXPORT_ENVIRONMENT (env)->private;
2201
SCM_DEFINE (scm_export_environment_set_private_x, "export-environment-set-private!", 2, 0, 0,
2202
(SCM env, SCM private),
2203
"Change the private environment of export environment @var{env}.")
2204
#define FUNC_NAME s_scm_export_environment_set_private_x
2206
struct export_environment *body;
2208
SCM_ASSERT (SCM_EXPORT_ENVIRONMENT_P (env), env, SCM_ARG1, FUNC_NAME);
2209
SCM_ASSERT (SCM_ENVIRONMENT_P (private), private, SCM_ARG2, FUNC_NAME);
2211
body = EXPORT_ENVIRONMENT (env);
2212
SCM_ENVIRONMENT_UNOBSERVE (private, body->private_observer);
2214
body->private = private;
2215
body->private_observer
2216
= SCM_ENVIRONMENT_OBSERVE (private, export_environment_observer, env, 1);
2218
return SCM_UNSPECIFIED;
2223
SCM_DEFINE (scm_export_environment_signature, "export-environment-signature", 1, 0, 0,
2225
"Return the signature of export environment @var{env}.")
2226
#define FUNC_NAME s_scm_export_environment_signature
2228
SCM_ASSERT (SCM_EXPORT_ENVIRONMENT_P (env), env, SCM_ARG1, FUNC_NAME);
2230
return EXPORT_ENVIRONMENT (env)->signature;
2236
export_environment_parse_signature (SCM signature, const char* caller)
2238
SCM result = SCM_EOL;
2241
for (l = signature; scm_is_pair (l); l = SCM_CDR (l))
2243
SCM entry = SCM_CAR (l);
2245
if (scm_is_symbol (entry))
2247
SCM new_entry = scm_cons2 (entry, symbol_immutable_location, SCM_EOL);
2248
result = scm_cons (new_entry, result);
2259
SCM_ASSERT (scm_is_pair (entry), entry, SCM_ARGn, caller);
2260
SCM_ASSERT (scm_is_symbol (SCM_CAR (entry)), entry, SCM_ARGn, caller);
2262
sym = SCM_CAR (entry);
2264
for (l2 = SCM_CDR (entry); scm_is_pair (l2); l2 = SCM_CDR (l2))
2266
SCM attribute = SCM_CAR (l2);
2267
if (scm_is_eq (attribute, symbol_immutable_location))
2269
else if (scm_is_eq (attribute, symbol_mutable_location))
2272
SCM_ASSERT (0, entry, SCM_ARGn, caller);
2274
SCM_ASSERT (scm_is_null (l2), entry, SCM_ARGn, caller);
2275
SCM_ASSERT (!mutable || !immutable, entry, SCM_ARGn, caller);
2277
if (!mutable && !immutable)
2280
mutability = mutable ? symbol_mutable_location : symbol_immutable_location;
2281
new_entry = scm_cons2 (sym, mutability, SCM_EOL);
2282
result = scm_cons (new_entry, result);
2285
SCM_ASSERT (scm_is_null (l), signature, SCM_ARGn, caller);
2287
/* Dirk:FIXME:: Now we know that signature is syntactically correct. There
2288
* are, however, no checks for symbols entered twice with contradicting
2289
* mutabilities. It would be nice, to implement this test, to be able to
2290
* call the sort functions conveniently from C.
2293
return scm_reverse (result);
2297
SCM_DEFINE (scm_export_environment_set_signature_x, "export-environment-set-signature!", 2, 0, 0,
2298
(SCM env, SCM signature),
2299
"Change the signature of export environment @var{env}.")
2300
#define FUNC_NAME s_scm_export_environment_set_signature_x
2304
SCM_ASSERT (SCM_EXPORT_ENVIRONMENT_P (env), env, SCM_ARG1, FUNC_NAME);
2305
parsed_sig = export_environment_parse_signature (signature, FUNC_NAME);
2307
EXPORT_ENVIRONMENT (env)->signature = parsed_sig;
2309
return SCM_UNSPECIFIED;
2316
scm_environments_prehistory ()
2318
/* create environment smob */
2319
scm_tc16_environment = scm_make_smob_type ("environment", 0);
2320
scm_set_smob_mark (scm_tc16_environment, environment_mark);
2321
scm_set_smob_free (scm_tc16_environment, environment_free);
2322
scm_set_smob_print (scm_tc16_environment, environment_print);
2324
/* create observer smob */
2325
scm_tc16_observer = scm_make_smob_type ("observer", 0);
2326
scm_set_smob_mark (scm_tc16_observer, observer_mark);
2327
scm_set_smob_print (scm_tc16_observer, observer_print);
2329
/* create system environment */
2330
scm_system_environment = scm_make_leaf_environment ();
2331
scm_permanent_object (scm_system_environment);
2336
scm_init_environments ()
2338
#include "libguile/environments.x"
added
removed
libguile/environments.c
