HCoop / bpt / guile.git / blame
? search:
summary | shortlog | log | commit | commitdiff | tree
blob | blame (incremental) | history | HEAD
Smob-related creanup.
[bpt/guile.git] / libguile / environments.c
CommitLineData
5d3e2388
DH		 1/* Copyright (C) 1999, 2000 Free Software Foundation, Inc.
2 *
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)
6 * any later version.
7 *
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.
12 *
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
17 *
18 * As a special exception, the Free Software Foundation gives permission
19 * for additional uses of the text contained in its release of GUILE.
20 *
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.
26 *
27 * This exception does not however invalidate any other reasons why
28 * the executable file might be covered by the GNU General Public License.
29 *
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.
37 *
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. */
41
42\f
43
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"
54
55#include "libguile/environments.h"
56
57\f
58
e841c3e0
KN		 59scm_bits_t scm_tc16_environment;
60scm_bits_t scm_tc16_observer;
93d40df2 61#define DEFAULT_OBARRAY_SIZE 137
5d3e2388
DH		 62
63\f
64
65/* error conditions */
66
67/*
68 * Throw an error if symbol is not bound in environment func
69 */
70void
71scm_error_environment_unbound (const char *func, SCM env, SCM symbol)
72{
73 /* Dirk:FIXME:: Should throw an environment:unbound type error */
74 char error[] = "Symbol `~A' not bound in environment `~A'.";
75 SCM arguments = scm_cons2 (symbol, env, SCM_EOL);
76 scm_misc_error (func, error, arguments);
77}
78
79
80/*
81 * Throw an error if func tried to create (define) or remove
82 * (undefine) a new binding for symbol in env
83 */
84void
85scm_error_environment_immutable_binding (const char *func, SCM env, SCM symbol)
86{
87 /* Dirk:FIXME:: Should throw an environment:immutable-binding type error */
88 char error[] = "Immutable binding in environment ~A (symbol: `~A').";
89 SCM arguments = scm_cons2 (env, symbol, SCM_EOL);
90 scm_misc_error (func, error, arguments);
91}
92
93
94/*
95 * Throw an error if func tried to change an immutable location.
96 */
97void
98scm_error_environment_immutable_location (const char *func, SCM env, SCM symbol)
99{
100 /* Dirk:FIXME:: Should throw an environment:immutable-location type error */
101 char error[] = "Immutable location in environment `~A' (symbol: `~A').";
102 SCM arguments = scm_cons2 (env, symbol, SCM_EOL);
103 scm_misc_error (func, error, arguments);
104}
105
106\f
107
108/* generic environments */
109
110
111/* Create an environment for the given type. Dereferencing type twice must
112 * deliver the initialized set of environment functions. Thus, type will
113 * also determine the signature of the underlying environment implementation.
114 * Dereferencing type once will typically deliver the data fields used by the
115 * underlying environment implementation.
116 */
117SCM
118scm_make_environment (void *type)
119{
120 SCM env;
121
122 SCM_NEWCELL (env);
123 SCM_SET_CELL_WORD_1 (env, type);
124 SCM_SET_CELL_TYPE (env, scm_tc16_environment);
125
126 return env;
127}
128
129
130SCM_DEFINE (scm_environment_p, "environment?", 1, 0, 0,
131 (SCM obj),
132 "Return #t if OBJ is an environment, or #f otherwise.")
133#define FUNC_NAME s_scm_environment_p
134{
135 return SCM_BOOL (SCM_ENVIRONMENT_P (obj));
136}
137#undef FUNC_NAME
138
139
140SCM_DEFINE (scm_environment_bound_p, "environment-bound?", 2, 0, 0,
141 (SCM env, SCM sym),
142 "Return #t if SYM is bound in ENV, or #f otherwise.")
143#define FUNC_NAME s_scm_environment_bound_p
144{
145 SCM_ASSERT (SCM_ENVIRONMENT_P (env), env, SCM_ARG1, FUNC_NAME);
146 SCM_ASSERT (SCM_SYMBOLP (sym), sym, SCM_ARG2, FUNC_NAME);
147
148 return SCM_BOOL (SCM_ENVIRONMENT_BOUND_P (env, sym));
149}
150#undef FUNC_NAME
151
152
153SCM_DEFINE (scm_environment_ref, "environment-ref", 2, 0, 0,
154 (SCM env, SCM sym),
155 "Return the value of the location bound to SYM in ENV.\n"
156 "If SYM is unbound in ENV, signal an environment:unbound\n"
157 "error.")
158#define FUNC_NAME s_scm_environment_ref
159{
160 SCM val;
161
162 SCM_ASSERT (SCM_ENVIRONMENT_P (env), env, SCM_ARG1, FUNC_NAME);
163 SCM_ASSERT (SCM_SYMBOLP (sym), sym, SCM_ARG2, FUNC_NAME);
164
165 val = SCM_ENVIRONMENT_REF (env, sym);
166
167 if (!SCM_UNBNDP (val))
168 return val;
169 else
170 scm_error_environment_unbound (FUNC_NAME, env, sym);
171}
172#undef FUNC_NAME
173
174
175/* This C function is identical to environment-ref, except that if symbol is
176 * unbound in env, it returns the value SCM_UNDEFINED, instead of signalling
177 * an error.
178 */
179SCM
180scm_c_environment_ref (SCM env, SCM sym)
181{
182 SCM_ASSERT (SCM_ENVIRONMENT_P (env), env, SCM_ARG1, "scm_c_environment_ref");
183 SCM_ASSERT (SCM_SYMBOLP (sym), sym, SCM_ARG2, "scm_c_environment_ref");
184 return SCM_ENVIRONMENT_REF (env, sym);
185}
186
187
188static SCM
189environment_default_folder (SCM proc, SCM symbol, SCM value, SCM tail)
190{
191 return gh_call3 (proc, symbol, value, tail);
192}
193
194
195SCM_DEFINE (scm_environment_fold, "environment-fold", 3, 0, 0,
196 (SCM env, SCM proc, SCM init),
197 "Iterate over all the bindings in ENV, accumulating some value.\n"
198 "For each binding in ENV, apply PROC to the symbol bound, its\n"
199 "value, and the result from the previous application of PROC.\n"
200 "Use INIT as PROC's third argument the first time PROC is\n"
201 "applied.\n"
202 "If ENV contains no bindings, this function simply returns INIT.\n"
203 "If ENV binds the symbol sym1 to the value val1, sym2 to val2,\n"
204 "and so on, then this procedure computes:\n"
205 " (proc sym1 val1\n"
206 " (proc sym2 val2\n"
207 " ...\n"
208 " (proc symn valn\n"
209 " init)))\n"
210 "Each binding in ENV will be processed exactly once.\n"
211 "environment-fold makes no guarantees about the order in which\n"
212 "the bindings are processed.\n"
213 "Here is a function which, given an environment, constructs an\n"
214 "association list representing that environment's bindings,\n"
215 "using environment-fold:\n"
216 " (define (environment->alist env)\n"
217 " (environment-fold env\n"
218 " (lambda (sym val tail)\n"
219 " (cons (cons sym val) tail))\n"
220 " '()))")
221#define FUNC_NAME s_scm_environment_fold
222{
223 SCM_ASSERT (SCM_ENVIRONMENT_P (env), env, SCM_ARG1, FUNC_NAME);
224 SCM_ASSERT (SCM_EQ_P (scm_procedure_p (proc), SCM_BOOL_T),
225 proc, SCM_ARG2, FUNC_NAME);
226
227 return SCM_ENVIRONMENT_FOLD (env, environment_default_folder, proc, init);
228}
229#undef FUNC_NAME
230
231
232/* This is the C-level analog of environment-fold. For each binding in ENV,
233 * make the call:
234 * (*proc) (data, symbol, value, previous)
235 * where previous is the value returned from the last call to *PROC, or INIT
236 * for the first call. If ENV contains no bindings, return INIT.
237 */
238SCM
239scm_c_environment_fold (SCM env, scm_environment_folder proc, SCM data, SCM init)
240{
241 SCM_ASSERT (SCM_ENVIRONMENT_P (env), env, SCM_ARG1, "scm_c_environment_fold");
242
243 return SCM_ENVIRONMENT_FOLD (env, proc, data, init);
244}
245
246
247SCM_DEFINE (scm_environment_define, "environment-define", 3, 0, 0,
248 (SCM env, SCM sym, SCM val),
249 "Bind SYM to a new location containing VAL in ENV. If SYM is\n"
250 "already bound to another location in ENV and the binding is\n"
251 "mutable, that binding is replaced. The new binding and\n"
252 "location are both mutable. The return value is unspecified.\n"
253 "If SYM is already bound in ENV, and the binding is immutable,\n"
254 "signal an environment:immutable-binding error.")
255#define FUNC_NAME s_scm_environment_define
256{
257 SCM status;
258
259 SCM_ASSERT (SCM_ENVIRONMENT_P (env), env, SCM_ARG1, FUNC_NAME);
260 SCM_ASSERT (SCM_SYMBOLP (sym), sym, SCM_ARG2, FUNC_NAME);
261
262 status = SCM_ENVIRONMENT_DEFINE (env, sym, val);
263
264 if (SCM_EQ_P (status, SCM_ENVIRONMENT_SUCCESS))
265 return SCM_UNSPECIFIED;
266 else if (SCM_EQ_P (status, SCM_ENVIRONMENT_BINDING_IMMUTABLE))
267 scm_error_environment_immutable_binding (FUNC_NAME, env, sym);
268 else
269 abort();
270}
271#undef FUNC_NAME
272
273
274SCM_DEFINE (scm_environment_undefine, "environment-undefine", 2, 0, 0,
275 (SCM env, SCM sym),
276 "Remove any binding for SYM from ENV. If SYM is unbound in ENV,\n"
277 "do nothing. The return value is unspecified.\n"
278 "If SYM is already bound in ENV, and the binding is immutable,\n"
279 "signal an environment:immutable-binding error.")
280#define FUNC_NAME s_scm_environment_undefine
281{
282 SCM status;
283
284 SCM_ASSERT(SCM_ENVIRONMENT_P(env), env, SCM_ARG1, FUNC_NAME);
285 SCM_ASSERT(SCM_SYMBOLP(sym), sym, SCM_ARG2, FUNC_NAME);
286
287 status = SCM_ENVIRONMENT_UNDEFINE (env, sym);
288
289 if (SCM_EQ_P (status, SCM_ENVIRONMENT_SUCCESS))
290 return SCM_UNSPECIFIED;
291 else if (SCM_EQ_P (status, SCM_ENVIRONMENT_BINDING_IMMUTABLE))
292 scm_error_environment_immutable_binding (FUNC_NAME, env, sym);
293 else
294 abort();
295}
296#undef FUNC_NAME
297
298
299SCM_DEFINE (scm_environment_set_x, "environment-set!", 3, 0, 0,
300 (SCM env, SCM sym, SCM val),
301 "If ENV binds SYM to some location, change that location's\n"
302 "value to VAL. The return value is unspecified.\n"
303 "If SYM is not bound in ENV, signal an environment:unbound\n"
304 "error. If ENV binds SYM to an immutable location, signal an\n"
305 "environment:immutable-location error.")
306#define FUNC_NAME s_scm_environment_set_x
307{
308 SCM status;
309
310 SCM_ASSERT (SCM_ENVIRONMENT_P (env), env, SCM_ARG1, FUNC_NAME);
311 SCM_ASSERT (SCM_SYMBOLP (sym), sym, SCM_ARG2, FUNC_NAME);
312
313 status = SCM_ENVIRONMENT_SET (env, sym, val);
314
315 if (SCM_EQ_P (status, SCM_ENVIRONMENT_SUCCESS))
316 return SCM_UNSPECIFIED;
317 else if (SCM_UNBNDP (status))
318 scm_error_environment_unbound (FUNC_NAME, env, sym);
319 else if (SCM_EQ_P (status, SCM_ENVIRONMENT_LOCATION_IMMUTABLE))
320 scm_error_environment_immutable_binding (FUNC_NAME, env, sym);
321 else
322 abort();
323}
324#undef FUNC_NAME
325
326
327SCM_DEFINE (scm_environment_cell, "environment-cell", 3, 0, 0,
328 (SCM env, SCM sym, SCM for_write),
329 "Return the value cell which ENV binds to SYM, or #f if the\n"
330 "binding does not live in a value cell.\n"
331 "The argument FOR-WRITE indicates whether the caller intends\n"
332 "to modify the variable's value by mutating the value cell. If\n"
333 "the variable is immutable, then environment-cell signals an\n"
334 "environment:immutable-location error.\n"
335 "If SYM is unbound in ENV, signal an environment:unbound error.\n"
336 "If you use this function, you should consider using\n"
337 "environment-observe, to be notified when SYM gets re-bound to\n"
338 "a new value cell, or becomes undefined.")
339#define FUNC_NAME s_scm_environment_cell
340{
341 SCM location;
342
343 SCM_ASSERT (SCM_ENVIRONMENT_P (env), env, SCM_ARG1, FUNC_NAME);
344 SCM_ASSERT (SCM_SYMBOLP (sym), sym, SCM_ARG2, FUNC_NAME);
345 SCM_ASSERT (SCM_BOOLP (for_write), for_write, SCM_ARG3, FUNC_NAME);
346
347 location = SCM_ENVIRONMENT_CELL (env, sym, !SCM_FALSEP (for_write));
348 if (!SCM_IMP (location))
349 return location;
350 else if (SCM_UNBNDP (location))
351 scm_error_environment_unbound (FUNC_NAME, env, sym);
352 else if (SCM_EQ_P (location, SCM_ENVIRONMENT_LOCATION_IMMUTABLE))
353 scm_error_environment_immutable_location (FUNC_NAME, env, sym);
354 else /* no cell */
355 return location;
356}
357#undef FUNC_NAME
358
359
360/* This C function is identical to environment-cell, with the following
361 * exceptions: If symbol is unbound in env, it returns the value
362 * SCM_UNDEFINED, instead of signalling an error. If symbol is bound to an
363 * immutable location but the cell is requested for write, the value
364 * SCM_ENVIRONMENT_LOCATION_IMMUTABLE is returned.
365 */
366SCM
367scm_c_environment_cell(SCM env, SCM sym, int for_write)
368{
369 SCM_ASSERT (SCM_ENVIRONMENT_P (env), env, SCM_ARG1, "scm_c_environment_cell");
370 SCM_ASSERT (SCM_SYMBOLP (sym), sym, SCM_ARG2, "scm_c_environment_cell");
371
372 return SCM_ENVIRONMENT_CELL (env, sym, for_write);
373}
374
375
376static void
377environment_default_observer (SCM env, SCM proc)
378{
379 gh_call1 (proc, env);
380}
381
382
383SCM_DEFINE (scm_environment_observe, "environment-observe", 2, 0, 0,
384 (SCM env, SCM proc),
385 "Whenever ENV's bindings change, apply PROC to ENV.\n"
386 "This function returns an object, token, which you can pass to\n"
387 "environment-unobserve to remove PROC from the set of\n"
388 "procedures observing ENV. The type and value of token is\n"
389 "unspecified.")
390#define FUNC_NAME s_scm_environment_observe
391{
392 SCM_ASSERT (SCM_ENVIRONMENT_P (env), env, SCM_ARG1, FUNC_NAME);
393
394 return SCM_ENVIRONMENT_OBSERVE (env, environment_default_observer, proc, 0);
395}
396#undef FUNC_NAME
397
398
399SCM_DEFINE (scm_environment_observe_weak, "environment-observe-weak", 2, 0, 0,
400 (SCM env, SCM proc),
401 "This function is the same as environment-observe, except that\n"
402 "the reference ENV retains to PROC is a weak reference. This\n"
403 "means that, if there are no other live, non-weak references\n"
404 "to PROC, it will be garbage-collected, and dropped from ENV's\n"
405 "list of observing procedures.")
406#define FUNC_NAME s_scm_environment_observe_weak
407{
408 SCM_ASSERT (SCM_ENVIRONMENT_P (env), env, SCM_ARG1, FUNC_NAME);
409
410 return SCM_ENVIRONMENT_OBSERVE (env, environment_default_observer, proc, 1);
411}
412#undef FUNC_NAME
413
414
415/* This is the C-level analog of the Scheme functions environment-observe and
416 * environment-observe-weak. Whenever env's bindings change, call the
417 * function proc, passing it env and data. If weak_p is non-zero, env will
418 * retain only a weak reference to data, and if data is garbage collected, the
419 * entire observation will be dropped. This function returns a token, with
420 * the same meaning as those returned by environment-observe and
421 * environment-observe-weak.
422 */
423SCM
424scm_c_environment_observe (SCM env, scm_environment_observer proc, SCM data, int weak_p)
425#define FUNC_NAME "scm_c_environment_observe"
426{
427 SCM_ASSERT (SCM_ENVIRONMENT_P (env), env, SCM_ARG1, FUNC_NAME);
428
429 return SCM_ENVIRONMENT_OBSERVE (env, proc, data, weak_p);
430}
431#undef FUNC_NAME
432
433
434SCM_DEFINE (scm_environment_unobserve, "environment-unobserve", 1, 0, 0,
435 (SCM token),
436 "Cancel the observation request which returned the value\n"
437 "TOKEN. The return value is unspecified.\n"
438 "If a call (environment-observe env proc) returns token, then\n"
439 "the call (environment-unobserve token) will cause proc to no\n"
440 "longer be called when env's bindings change.")
441#define FUNC_NAME s_scm_environment_unobserve
442{
443 SCM env;
444
445 SCM_ASSERT (SCM_OBSERVER_P (token), token, SCM_ARG1, FUNC_NAME);
446
447 env = SCM_OBSERVER_ENVIRONMENT (token);
448 SCM_ENVIRONMENT_UNOBSERVE (env, token);
449
450 return SCM_UNSPECIFIED;
451}
452#undef FUNC_NAME
453
454
455static SCM
e841c3e0 456environment_mark (SCM env)
5d3e2388
DH		 457{
458 return (*(SCM_ENVIRONMENT_FUNCS (env)->mark)) (env);
459}
460
461
462static scm_sizet
e841c3e0 463environment_free (SCM env)
5d3e2388
DH		 464{
465 return (*(SCM_ENVIRONMENT_FUNCS (env)->free)) (env);
466}
467
468
469static int
e841c3e0 470environment_print (SCM env, SCM port, scm_print_state *pstate)
5d3e2388
DH		 471{
472 return (*(SCM_ENVIRONMENT_FUNCS (env)->print)) (env, port, pstate);
473}
474
475\f
476
477/* observers */
478
479static SCM
e841c3e0 480observer_mark (SCM observer)
5d3e2388
DH		 481{
482 scm_gc_mark (SCM_OBSERVER_ENVIRONMENT (observer));
483 scm_gc_mark (SCM_OBSERVER_DATA (observer));
484 return SCM_BOOL_F;
485}
486
487
5d3e2388 488static int
e841c3e0 489observer_print (SCM type, SCM port, scm_print_state *pstate)
5d3e2388
DH		 490{
491 SCM address = scm_ulong2num (SCM_UNPACK (type));
492 SCM base16 = scm_number_to_string (address, SCM_MAKINUM (16));
493
494 scm_puts ("#<observer ", port);
86c991c2 495 scm_puts (SCM_STRING_CHARS (base16), port);
5d3e2388
DH		 496 scm_puts (">", port);
497
498 return 1;
499}
500
501\f
502
503/* obarrays
504 *
505 * Obarrays form the basic lookup tables used to implement most of guile's
506 * built-in environment types. An obarray is implemented as a hash table with
507 * symbols as keys. The content of the data depends on the environment type.
508 */
509
510
511/*
a2d47b23
DH		 512 * Enter symbol into obarray. The symbol must not already exist in obarray.
513 * The freshly generated (symbol . data) cell is returned.
5d3e2388
DH		 514 */
515static SCM
516obarray_enter (SCM obarray, SCM symbol, SCM data)
517{
bfa974f0 518 scm_sizet hash = SCM_SYMBOL_HASH (symbol) % SCM_VECTOR_LENGTH (obarray);
5d3e2388
DH		 519 SCM entry = scm_cons (symbol, data);
520 SCM slot = scm_cons (entry, SCM_VELTS (obarray)[hash]);
521 SCM_VELTS (obarray)[hash] = slot;
522
523 return entry;
524}
525
526
a2d47b23
DH		 527/*
528 * Enter symbol into obarray. An existing entry for symbol is replaced. If
529 * an entry existed, the old (symbol . data) cell is returned, #f otherwise.
530 */
531static SCM
532obarray_replace (SCM obarray, SCM symbol, SCM data)
533{
bfa974f0 534 scm_sizet hash = SCM_SYMBOL_HASH (symbol) % SCM_VECTOR_LENGTH (obarray);
a2d47b23
DH		 535 SCM new_entry = scm_cons (symbol, data);
536 SCM lsym;
537 SCM slot;
538
539 for (lsym = SCM_VELTS (obarray)[hash]; !SCM_NULLP (lsym); lsym = SCM_CDR (lsym))
540 {
541 SCM old_entry = SCM_CAR (lsym);
66460dfb 542 if (SCM_EQ_P (SCM_CAR (old_entry), symbol))
a2d47b23
DH		 543 {
544 SCM_SETCAR (lsym, new_entry);
545 return old_entry;
546 }
547 }
548
549 slot = scm_cons (new_entry, SCM_VELTS (obarray)[hash]);
550 SCM_VELTS (obarray)[hash] = slot;
551
552 return SCM_BOOL_F;
553}
554
555
5d3e2388
DH		 556/*
557 * Look up symbol in obarray
558 */
559static SCM
560obarray_retrieve (SCM obarray, SCM sym)
561{
bfa974f0 562 scm_sizet hash = SCM_SYMBOL_HASH (sym) % SCM_VECTOR_LENGTH (obarray);
5d3e2388
DH		 563 SCM lsym;
564
565 for (lsym = SCM_VELTS (obarray)[hash]; !SCM_NULLP (lsym); lsym = SCM_CDR (lsym))
566 {
567 SCM entry = SCM_CAR (lsym);
66460dfb 568 if (SCM_EQ_P (SCM_CAR (entry), sym))
5d3e2388
DH		 569 return entry;
570 }
571
572 return SCM_UNDEFINED;
573}
574
575
576/*
a2d47b23
DH		 577 * Remove entry from obarray. If the symbol was found and removed, the old
578 * (symbol . data) cell is returned, #f otherwise.
5d3e2388
DH		 579 */
580static SCM
581obarray_remove (SCM obarray, SCM sym)
582{
bfa974f0 583 scm_sizet hash = SCM_SYMBOL_HASH (sym) % SCM_VECTOR_LENGTH (obarray);
5d3e2388
DH		 584 SCM lsym;
585 SCM *lsymp;
586
587 /* Dirk:FIXME:: gc problem due to use of &SCM_VELTS[hash] */
588 for (lsym = *(lsymp = &SCM_VELTS (obarray)[hash]);
589 !SCM_NULLP (lsym);
590 lsym = *(lsymp = SCM_CDRLOC (lsym)))
591 {
592 SCM entry = SCM_CAR (lsym);
66460dfb 593 if (SCM_EQ_P (SCM_CAR (entry), sym))
5d3e2388
DH		 594 {
595 *lsymp = SCM_CDR (lsym);
596 return entry;
597 }
598 }
599 return SCM_BOOL_F;
600}
601
602
603static void
604obarray_remove_all (SCM obarray)
605{
bfa974f0 606 scm_sizet size = SCM_VECTOR_LENGTH (obarray);
5d3e2388
DH		 607 scm_sizet i;
608
609 for (i = 0; i < size; i++)
610 {
611 SCM_VELTS (obarray)[i] = SCM_EOL;
612 }
613}
614
615\f
616
617/* core environments base
618 *
619 * This struct and the corresponding functions form a base class for guile's
620 * built-in environment types.
621 */
622
623
624struct core_environments_base {
625 struct scm_environment_funcs *funcs;
626
627 SCM observers;
628 SCM weak_observers;
629};
630
631
632#define CORE_ENVIRONMENTS_BASE(env) \
633 ((struct core_environments_base *) SCM_CELL_WORD_1 (env))
634#define CORE_ENVIRONMENT_OBSERVERS(env) \
635 (CORE_ENVIRONMENTS_BASE (env)->observers)
636#define SCM_SET_CORE_ENVIRONMENT_OBSERVERS(env, v) \
637 (CORE_ENVIRONMENT_OBSERVERS (env) = (v))
638#define CORE_ENVIRONMENT_WEAK_OBSERVER_VECTOR(env) \
639 (CORE_ENVIRONMENTS_BASE (env)->weak_observers)
640#define CORE_ENVIRONMENT_WEAK_OBSERVERS(env) \
641 (SCM_VELTS (CORE_ENVIRONMENT_WEAK_OBSERVER_VECTOR (env)) [0])
642#define SCM_SET_CORE_ENVIRONMENT_WEAK_OBSERVERS(env, v) \
643 (SCM_VELTS (CORE_ENVIRONMENT_WEAK_OBSERVER_VECTOR (env)) [0] = (v))
644
645\f
646
647static SCM
648core_environments_observe (SCM env, scm_environment_observer proc, SCM data, int weak_p)
649{
650 SCM observer;
651
652 SCM_NEWCELL2 (observer);
653 SCM_SET_CELL_OBJECT_1 (observer, env);
654 SCM_SET_CELL_OBJECT_2 (observer, data);
655 SCM_SET_CELL_WORD_3 (observer, proc);
656 SCM_SET_CELL_TYPE (observer, scm_tc16_observer);
657
658 if (!weak_p)
659 {
660 SCM observers = CORE_ENVIRONMENT_OBSERVERS (env);
661 SCM new_observers = scm_cons (observer, observers);
662 SCM_SET_CORE_ENVIRONMENT_OBSERVERS (env, new_observers);
663 }
664 else
665 {
666 SCM observers = CORE_ENVIRONMENT_WEAK_OBSERVERS (env);
667 SCM new_observers = scm_acons (SCM_BOOL_F, observer, observers);
668 SCM_SET_CORE_ENVIRONMENT_WEAK_OBSERVERS (env, new_observers);
669 }
670
671 return observer;
672}
673
674
675static void
676core_environments_unobserve (SCM env, SCM observer)
677{
678 unsigned int handling_weaks;
679 for (handling_weaks = 0; handling_weaks <= 1; ++handling_weaks)
680 {
681 SCM l = handling_weaks
682 ? CORE_ENVIRONMENT_WEAK_OBSERVERS (env)
683 : CORE_ENVIRONMENT_OBSERVERS (env);
684
685 if (!SCM_NULLP (l))
686 {
687 SCM rest = SCM_CDR (l);
688 SCM first = handling_weaks
689 ? SCM_CDAR (l)
690 : SCM_CAR (l);
691
692 if (SCM_EQ_P (first, observer))
693 {
694 /* Remove the first observer */
695 handling_weaks
696 ? SCM_SET_CORE_ENVIRONMENT_WEAK_OBSERVERS (env, rest)
697 : SCM_SET_CORE_ENVIRONMENT_OBSERVERS (env, rest);
698 return;
699 }
700
701 do {
702 SCM rest = SCM_CDR (l);
703
704 if (!SCM_NULLP (rest))
705 {
706 SCM next = handling_weaks
707 ? SCM_CDAR (l)
708 : SCM_CAR (l);
709
710 if (SCM_EQ_P (next, observer))
711 {
712 SCM_SETCDR (l, SCM_CDR (rest));
713 return;
714 }
715 }
716
717 l = rest;
718 } while (!SCM_NULLP (l));
719 }
720 }
721
722 /* Dirk:FIXME:: What to do now, since the observer is not found? */
723}
724
725
726static SCM
727core_environments_mark (SCM env)
728{
729 scm_gc_mark (CORE_ENVIRONMENT_OBSERVERS (env));
730 return CORE_ENVIRONMENT_WEAK_OBSERVER_VECTOR (env);
731}
732
733
734static void
735core_environments_finalize (SCM env)
736{
737}
738
739
740static void
741core_environments_preinit (struct core_environments_base *body)
742{
743 body->funcs = NULL;
744 body->observers = SCM_BOOL_F;
745 body->weak_observers = SCM_BOOL_F;
746}
747
748
749static void
750core_environments_init (struct core_environments_base *body,
751 struct scm_environment_funcs *funcs)
752{
753 body->funcs = funcs;
754 body->observers = SCM_EOL;
755 body->weak_observers = scm_make_weak_value_hash_table (SCM_MAKINUM (1));
756}
757
758
759/* Tell all observers to clear their caches.
760 *
761 * Environments have to be informed about changes in the following cases:
762 * - The observed env has a new binding. This must be always reported.
763 * - The observed env has dropped a binding. This must be always reported.
764 * - A binding in the observed environment has changed. This must only be
765 * reported, if there is a chance that the binding is being cached outside.
766 * However, this potential optimization is not performed currently.
767 *
768 * Errors that occur while the observers are called are accumulated and
769 * signalled as one single error message to the caller.
770 */
771
772struct update_data
773{
774 SCM observer;
775 SCM environment;
776};
777
778
779static SCM
780update_catch_body (void *ptr)
781{
782 struct update_data *data = (struct update_data *) ptr;
783 SCM observer = data->observer;
784
785 (*SCM_OBSERVER_PROC (observer))
786 (data->environment, SCM_OBSERVER_DATA (observer));
787
788 return SCM_UNDEFINED;
789}
790
791
792static SCM
793update_catch_handler (void *ptr, SCM tag, SCM args)
794{
795 struct update_data *data = (struct update_data *) ptr;
796 SCM observer = data->observer;
797 SCM message = scm_makfrom0str ("Observer `~A' signals `~A' error: ~S");
798
799 return scm_cons (message, scm_listify (observer, tag, args, SCM_UNDEFINED));
800}
801
802
803static void
804core_environments_broadcast (SCM env)
805#define FUNC_NAME "core_environments_broadcast"
806{
807 unsigned int handling_weaks;
808 SCM errors = SCM_EOL;
809
810 for (handling_weaks = 0; handling_weaks <= 1; ++handling_weaks)
811 {
812 SCM observers = handling_weaks
813 ? CORE_ENVIRONMENT_WEAK_OBSERVERS (env)
814 : CORE_ENVIRONMENT_OBSERVERS (env);
815
816 for (; !SCM_NULLP (observers); observers = SCM_CDR (observers))
817 {
818 struct update_data data;
819 SCM observer = handling_weaks
820 ? SCM_CDAR (observers)
821 : SCM_CAR (observers);
822 SCM error;
823
824 data.observer = observer;
825 data.environment = env;
826
827 error = scm_internal_catch (SCM_BOOL_T,
828 update_catch_body, &data,
829 update_catch_handler, &data);
830
831 if (!SCM_UNBNDP (error))
832 errors = scm_cons (error, errors);
833 }
834 }
835
836 if (!SCM_NULLP (errors))
837 {
838 /* Dirk:FIXME:: As soon as scm_misc_error is fixed to handle the name
839 * parameter correctly it should not be necessary any more to also pass
840 * namestr in order to get the desired information from the error
841 * message.
842 */
843 SCM ordered_errors = scm_reverse (errors);
844 scm_misc_error
845 (FUNC_NAME,
846 "Observers of `~A' have signalled the following errors: ~S",
847 scm_cons2 (env, ordered_errors, SCM_EOL));
848 }
849}
850#undef FUNC_NAME
851
852\f
853
854/* leaf environments
855 *
856 * A leaf environment is simply a mutable set of definitions. A leaf
857 * environment supports no operations beyond the common set.
858 *
859 * Implementation: The obarray of the leaf environment holds (symbol . value)
860 * pairs. No further information is necessary, since all bindings and
861 * locations in a leaf environment are mutable.
862 */
863
864
865struct leaf_environment {
866 struct core_environments_base base;
867
868 SCM obarray;
869};
870
871
872#define LEAF_ENVIRONMENT(env) \
873 ((struct leaf_environment *) SCM_CELL_WORD_1 (env))
874
875\f
876
877static SCM
878leaf_environment_ref (SCM env, SCM sym)
879{
880 SCM obarray = LEAF_ENVIRONMENT (env)->obarray;
881 SCM binding = obarray_retrieve (obarray, sym);
882 return SCM_UNBNDP (binding) ? binding : SCM_CDR (binding);
883}
884
885
886static SCM
887leaf_environment_fold (SCM env, scm_environment_folder proc, SCM data, SCM init)
888{
889 scm_sizet i;
890 SCM result = init;
891 SCM obarray = LEAF_ENVIRONMENT (env)->obarray;
892
bfa974f0 893 for (i = 0; i < SCM_VECTOR_LENGTH (obarray); i++)
5d3e2388
DH		 894 {
895 SCM l;
896 for (l = SCM_VELTS (obarray)[i]; !SCM_NULLP (l); l = SCM_CDR (l))
897 {
898 SCM binding = SCM_CAR (l);
899 SCM symbol = SCM_CAR (binding);
900 SCM value = SCM_CDR (binding);
901 result = (*proc) (data, symbol, value, result);
902 }
903 }
904 return result;
905}
906
907
908static SCM
909leaf_environment_define (SCM env, SCM sym, SCM val)
910#define FUNC_NAME "leaf_environment_define"
911{
912 SCM obarray = LEAF_ENVIRONMENT (env)->obarray;
5d3e2388 913
a2d47b23 914 obarray_replace (obarray, sym, val);
5d3e2388
DH		 915 core_environments_broadcast (env);
916
917 return SCM_ENVIRONMENT_SUCCESS;
918}
919#undef FUNC_NAME
920
921
922static SCM
923leaf_environment_undefine (SCM env, SCM sym)
924#define FUNC_NAME "leaf_environment_undefine"
925{
926 SCM obarray = LEAF_ENVIRONMENT (env)->obarray;
a2d47b23 927 SCM removed = obarray_remove (obarray, sym);
5d3e2388 928
a2d47b23
DH		 929 if (!SCM_FALSEP (removed))
930 core_environments_broadcast (env);
5d3e2388
DH		 931
932 return SCM_ENVIRONMENT_SUCCESS;
933}
934#undef FUNC_NAME
935
936
937static SCM
938leaf_environment_set_x (SCM env, SCM sym, SCM val)
939#define FUNC_NAME "leaf_environment_set_x"
940{
941 SCM obarray = LEAF_ENVIRONMENT (env)->obarray;
942 SCM binding = obarray_retrieve (obarray, sym);
943
944 if (!SCM_UNBNDP (binding))
945 {
946 SCM_SETCDR (binding, val);
947 return SCM_ENVIRONMENT_SUCCESS;
948 }
949 else
950 {
951 return SCM_UNDEFINED;
952 }
953}
954#undef FUNC_NAME
955
956
957static SCM
958leaf_environment_cell(SCM env, SCM sym, int for_write)
959{
960 SCM obarray = LEAF_ENVIRONMENT (env)->obarray;
961 SCM binding = obarray_retrieve (obarray, sym);
962 return binding;
963}
964
965
966static SCM
e841c3e0 967leaf_environment_mark (SCM env)
5d3e2388
DH		 968{
969 scm_gc_mark (LEAF_ENVIRONMENT (env)->obarray);
970 return core_environments_mark (env);
971}
972
973
974static scm_sizet
e841c3e0 975leaf_environment_free (SCM env)
5d3e2388
DH		 976{
977 core_environments_finalize (env);
978
979 free (LEAF_ENVIRONMENT (env));
980 return sizeof (struct leaf_environment);
981}
982
983
984static int
e841c3e0 985leaf_environment_print (SCM type, SCM port, scm_print_state *pstate)
5d3e2388
DH		 986{
987 SCM address = scm_ulong2num (SCM_UNPACK (type));
988 SCM base16 = scm_number_to_string (address, SCM_MAKINUM (16));
989
990 scm_puts ("#<leaf environment ", port);
86c991c2 991 scm_puts (SCM_STRING_CHARS (base16), port);
5d3e2388
DH		 992 scm_puts (">", port);
993
994 return 1;
995}
996
997
998static struct scm_environment_funcs leaf_environment_funcs = {
999 leaf_environment_ref,
1000 leaf_environment_fold,
1001 leaf_environment_define,
1002 leaf_environment_undefine,
1003 leaf_environment_set_x,
1004 leaf_environment_cell,
1005 core_environments_observe,
1006 core_environments_unobserve,
e841c3e0
KN		 1007 leaf_environment_mark,
1008 leaf_environment_free,
1009 leaf_environment_print
5d3e2388
DH		 1010};
1011
1012
1013void *scm_type_leaf_environment = &leaf_environment_funcs;
1014
1015
1016SCM_DEFINE (scm_make_leaf_environment, "make-leaf-environment", 0, 0, 0,
1017 (),
1018 "Create a new leaf environment, containing no bindings.\n"
1019 "All bindings and locations created in the new environment\n"
1020 "will be mutable.")
1021#define FUNC_NAME s_scm_make_leaf_environment
1022{
1023 scm_sizet size = sizeof (struct leaf_environment);
1024 struct leaf_environment *body = scm_must_malloc (size, FUNC_NAME);
1025 SCM env;
1026
1027 core_environments_preinit (&body->base);
1028 body->obarray = SCM_BOOL_F;
1029
1030 env = scm_make_environment (body);
1031
1032 core_environments_init (&body->base, &leaf_environment_funcs);
93d40df2 1033 body->obarray = scm_make_vector (SCM_MAKINUM (DEFAULT_OBARRAY_SIZE), SCM_EOL);
5d3e2388
DH		 1034
1035 return env;
1036}
1037#undef FUNC_NAME
1038
1039
1040SCM_DEFINE (scm_leaf_environment_p, "leaf-environment?", 1, 0, 0,
1041 (SCM object),
1042 "Return #t if object is a leaf environment, or #f otherwise.")
1043#define FUNC_NAME s_scm_leaf_environment_p
1044{
1045 return SCM_BOOL (SCM_LEAF_ENVIRONMENT_P (object));
1046}
1047#undef FUNC_NAME
1048
1049\f
1050
1051/* eval environments
1052 *
1053 * A module's source code refers to definitions imported from other modules,
1054 * and definitions made within itself. An eval environment combines two
1055 * environments -- a local environment and an imported environment -- to
1056 * produce a new environment in which both sorts of references can be
1057 * resolved.
1058 *
1059 * Implementation: The obarray of the eval environment is used to cache
1060 * entries from the local and imported environments such that in most of the
1061 * cases only a single lookup is necessary. Since for neither the local nor
1062 * the imported environment it is known, what kind of environment they form,
1063 * the most general case is assumed. Therefore, entries in the obarray take
1064 * one of the following forms:
1065 *
1066 * 1) (<symbol> location mutability . source-env), where mutability indicates
1067 * one of the following states: IMMUTABLE if the location is known to be
1068 * immutable, MUTABLE if the location is known to be mutable, UNKNOWN if
1069 * the location has only been requested for non modifying accesses.
1070 *
1071 * 2) (symbol . source-env) if the symbol has a binding in the source-env, but
1072 * if the source-env can't provide a cell for the binding. Thus, for every
1073 * access, the source-env has to be contacted directly.
1074 */
1075
1076
1077struct eval_environment {
1078 struct core_environments_base base;
1079
1080 SCM obarray;
1081
1082 SCM imported;
1083 SCM imported_observer;
1084 SCM local;
1085 SCM local_observer;
1086};
1087
1088
1089#define EVAL_ENVIRONMENT(env) \
1090 ((struct eval_environment *) SCM_CELL_WORD_1 (env))
1091
1092#define IMMUTABLE SCM_MAKINUM (0)
1093#define MUTABLE SCM_MAKINUM (1)
1094#define UNKNOWN SCM_MAKINUM (2)
1095
1096#define CACHED_LOCATION(x) SCM_CAR (x)
1097#define CACHED_MUTABILITY(x) SCM_CADR (x)
1098#define SET_CACHED_MUTABILITY(x, v) SCM_SETCAR (SCM_CDR (x), (v))
1099#define CACHED_SOURCE_ENVIRONMENT(x) SCM_CDDR (x)
1100
1101\f
1102
1103/* eval_environment_lookup will report one of the following distinct results:
1104 * a) (<object> . value) if a cell could be obtained.
1105 * b) <environment> if the environment has to be contacted directly.
1106 * c) IMMUTABLE if an immutable cell was requested for write.
1107 * d) SCM_UNDEFINED if there is no binding for the symbol.
1108 */
1109static SCM
1110eval_environment_lookup (SCM env, SCM sym, int for_write)
1111{
1112 SCM obarray = EVAL_ENVIRONMENT (env)->obarray;
1113 SCM binding = obarray_retrieve (obarray, sym);
1114
1115 if (!SCM_UNBNDP (binding))
1116 {
1117 /* The obarray holds an entry for the symbol. */
1118
1119 SCM entry = SCM_CDR (binding);
1120
1121 if (SCM_CONSP (entry))
1122 {
1123 /* The entry in the obarray is a cached location. */
1124
1125 SCM location = CACHED_LOCATION (entry);
1126 SCM mutability;
1127
1128 if (!for_write)
1129 return location;
1130
1131 mutability = CACHED_MUTABILITY (entry);
1132 if (SCM_EQ_P (mutability, MUTABLE))
1133 return location;
1134
1135 if (SCM_EQ_P (mutability, UNKNOWN))
1136 {
1137 SCM source_env = CACHED_SOURCE_ENVIRONMENT (entry);
1138 SCM location = SCM_ENVIRONMENT_CELL (source_env, sym, 1);
1139
1140 if (SCM_CONSP (location))
1141 {
1142 SET_CACHED_MUTABILITY (entry, MUTABLE);
1143 return location;
1144 }
1145 else /* IMMUTABLE */
1146 {
1147 SET_CACHED_MUTABILITY (entry, IMMUTABLE);
1148 return IMMUTABLE;
1149 }
1150 }
1151
1152 return IMMUTABLE;
1153 }
1154 else
1155 {
1156 /* The obarray entry is an environment */
1157
1158 return entry;
1159 }
1160 }
1161 else
1162 {
1163 /* There is no entry for the symbol in the obarray. This can either
1164 * mean that there has not been a request for the symbol yet, or that
1165 * the symbol is really undefined. We are looking for the symbol in
1166 * both the local and the imported environment. If we find a binding, a
1167 * cached entry is created.
1168 */
1169
1170 struct eval_environment *body = EVAL_ENVIRONMENT (env);
1171 unsigned int handling_import;
1172
1173 for (handling_import = 0; handling_import <= 1; ++handling_import)
1174 {
1175 SCM source_env = handling_import ? body->imported : body->local;
1176 SCM location = SCM_ENVIRONMENT_CELL (source_env, sym, for_write);
1177
1178 if (!SCM_UNBNDP (location))
1179 {
1180 if (SCM_CONSP (location))
1181 {
1182 SCM mutability = for_write ? MUTABLE : UNKNOWN;
1183 SCM entry = scm_cons2 (location, mutability, source_env);
1184 obarray_enter (obarray, sym, entry);
1185 return location;
1186 }
1187 else if (SCM_EQ_P (location, SCM_ENVIRONMENT_LOCATION_NO_CELL))
1188 {
1189 obarray_enter (obarray, sym, source_env);
1190 return source_env;
1191 }
1192 else
1193 {
1194 return IMMUTABLE;
1195 }
1196 }
1197 }
1198
1199 return SCM_UNDEFINED;
1200 }
1201}
1202
1203
1204static SCM
1205eval_environment_ref (SCM env, SCM sym)
1206#define FUNC_NAME "eval_environment_ref"
1207{
1208 SCM location = eval_environment_lookup (env, sym, 0);
1209
1210 if (SCM_CONSP (location))
1211 return SCM_CDR (location);
1212 else if (!SCM_UNBNDP (location))
1213 return SCM_ENVIRONMENT_REF (location, sym);
1214 else
1215 return SCM_UNDEFINED;
1216}
1217#undef FUNC_NAME
1218
1219
1220static SCM
1221eval_environment_folder (SCM extended_data, SCM symbol, SCM value, SCM tail)
1222{
1223 SCM local = SCM_CAR (extended_data);
1224
1225 if (!SCM_ENVIRONMENT_BOUND_P (local, symbol))
1226 {
1227 SCM proc_as_nr = SCM_CADR (extended_data);
1228 unsigned long int proc_as_ul = scm_num2ulong (proc_as_nr, NULL, NULL);
1229 scm_environment_folder proc = (scm_environment_folder) proc_as_ul;
1230 SCM data = SCM_CDDR (extended_data);
1231
1232 return (*proc) (data, symbol, value, tail);
1233 }
1234 else
1235 {
1236 return tail;
1237 }
1238}
1239
1240
1241static SCM
1242eval_environment_fold (SCM env, scm_environment_folder proc, SCM data, SCM init)
1243{
1244 SCM local = EVAL_ENVIRONMENT (env)->local;
1245 SCM imported = EVAL_ENVIRONMENT (env)->imported;
1246 SCM proc_as_nr = scm_ulong2num ((unsigned long int) proc);
1247 SCM extended_data = scm_cons2 (local, proc_as_nr, data);
1248 SCM tmp_result = scm_c_environment_fold (imported, eval_environment_folder, extended_data, init);
1249
1250 return scm_c_environment_fold (local, proc, data, tmp_result);
1251}
1252
1253
1254static SCM
1255eval_environment_define (SCM env, SCM sym, SCM val)
1256#define FUNC_NAME "eval_environment_define"
1257{
1258 SCM local = EVAL_ENVIRONMENT (env)->local;
1259 return SCM_ENVIRONMENT_DEFINE (local, sym, val);
1260}
1261#undef FUNC_NAME
1262
1263
1264static SCM
1265eval_environment_undefine (SCM env, SCM sym)
1266#define FUNC_NAME "eval_environment_undefine"
1267{
1268 SCM local = EVAL_ENVIRONMENT (env)->local;
1269 return SCM_ENVIRONMENT_UNDEFINE (local, sym);
1270}
1271#undef FUNC_NAME
1272
1273
1274static SCM
1275eval_environment_set_x (SCM env, SCM sym, SCM val)
1276#define FUNC_NAME "eval_environment_set_x"
1277{
1278 SCM location = eval_environment_lookup (env, sym, 1);
1279
1280 if (SCM_CONSP (location))
1281 {
1282 SCM_SETCDR (location, val);
1283 return SCM_ENVIRONMENT_SUCCESS;
1284 }
1285 else if (SCM_ENVIRONMENT_P (location))
1286 {
1287 return SCM_ENVIRONMENT_SET (location, sym, val);
1288 }
1289 else if (SCM_EQ_P (location, IMMUTABLE))
1290 {
1291 return SCM_ENVIRONMENT_LOCATION_IMMUTABLE;
1292 }
1293 else
1294 {
1295 return SCM_UNDEFINED;
1296 }
1297}
1298#undef FUNC_NAME
1299
1300
1301static SCM
1302eval_environment_cell (SCM env, SCM sym, int for_write)
1303#define FUNC_NAME "eval_environment_cell"
1304{
1305 SCM location = eval_environment_lookup (env, sym, for_write);
1306
1307 if (SCM_CONSP (location))
1308 return location;
1309 else if (SCM_ENVIRONMENT_P (location))
1310 return SCM_ENVIRONMENT_LOCATION_NO_CELL;
1311 else if (SCM_EQ_P (location, IMMUTABLE))
1312 return SCM_ENVIRONMENT_LOCATION_IMMUTABLE;
1313 else
1314 return SCM_UNDEFINED;
1315}
1316#undef FUNC_NAME
1317
1318
1319static SCM
e841c3e0 1320eval_environment_mark (SCM env)
5d3e2388
DH		 1321{
1322 struct eval_environment *body = EVAL_ENVIRONMENT (env);
1323
1324 scm_gc_mark (body->obarray);
1325 scm_gc_mark (body->imported);
1326 scm_gc_mark (body->imported_observer);
1327 scm_gc_mark (body->local);
1328 scm_gc_mark (body->local_observer);
1329
1330 return core_environments_mark (env);
1331}
1332
1333
1334static scm_sizet
e841c3e0 1335eval_environment_free (SCM env)
5d3e2388
DH		 1336{
1337 core_environments_finalize (env);
1338
1339 free (EVAL_ENVIRONMENT (env));
1340 return sizeof (struct eval_environment);
1341}
1342
1343
1344static int
e841c3e0 1345eval_environment_print (SCM type, SCM port, scm_print_state *pstate)
5d3e2388
DH		 1346{
1347 SCM address = scm_ulong2num (SCM_UNPACK (type));
1348 SCM base16 = scm_number_to_string (address, SCM_MAKINUM (16));
1349
1350 scm_puts ("#<eval environment ", port);
86c991c2 1351 scm_puts (SCM_STRING_CHARS (base16), port);
5d3e2388
DH		 1352 scm_puts (">", port);
1353
1354 return 1;
1355}
1356
1357
1358static struct scm_environment_funcs eval_environment_funcs = {
1359 eval_environment_ref,
1360 eval_environment_fold,
1361 eval_environment_define,
1362 eval_environment_undefine,
1363 eval_environment_set_x,
1364 eval_environment_cell,
1365 core_environments_observe,
1366 core_environments_unobserve,
e841c3e0
KN		 1367 eval_environment_mark,
1368 eval_environment_free,
1369 eval_environment_print
5d3e2388
DH		 1370};
1371
1372
1373void *scm_type_eval_environment = &eval_environment_funcs;
1374
1375
1376static void
1377eval_environment_observer (SCM caller, SCM eval_env)
1378{
1379 SCM obarray = EVAL_ENVIRONMENT (eval_env)->obarray;
1380
1381 obarray_remove_all (obarray);
1382 core_environments_broadcast (eval_env);
1383}
1384
1385
1386SCM_DEFINE (scm_make_eval_environment, "make-eval-environment", 2, 0, 0,
1387 (SCM local, SCM imported),
1388 "Return a new environment object eval whose bindings are the\n"
1389 "union of the bindings in the environments local and imported,\n"
1390 "with bindings from local taking precedence. Definitions made\n"
1391 "in eval are placed in local.\n"
1392 "Applying environment-define or environment-undefine to eval\n"
1393 "has the same effect as applying the procedure to local.\n"
1394 "Note that eval incorporates local and imported by reference:\n"
1395 "If, after creating eval, the program changes the bindings of\n"
1396 "local or imported, those changes will be visible in eval.\n"
1397 "Since most Scheme evaluation takes place in eval environments,\n"
1398 "they transparenty cache the bindings received from local and\n"
1399 "imported. Thus, the first time the program looks up a symbol\n"
1400 "in eval, eval may make calls to local or imported to find\n"
1401 "their bindings, but subsequent references to that symbol will\n"
1402 "be as fast as references to bindings in finite environments.\n"
1403 "In typical use, local will be a finite environment, and\n"
1404 "imported will be an import environment")
1405#define FUNC_NAME s_scm_make_eval_environment
1406{
1407 SCM env;
1408 struct eval_environment *body;
1409
1410 SCM_ASSERT (SCM_ENVIRONMENT_P (local), local, SCM_ARG1, FUNC_NAME);
1411 SCM_ASSERT (SCM_ENVIRONMENT_P (imported), imported, SCM_ARG2, FUNC_NAME);
1412
1413 body = scm_must_malloc (sizeof (struct eval_environment), FUNC_NAME);
1414
1415 core_environments_preinit (&body->base);
1416 body->obarray = SCM_BOOL_F;
1417 body->imported = SCM_BOOL_F;
1418 body->imported_observer = SCM_BOOL_F;
1419 body->local = SCM_BOOL_F;
1420 body->local_observer = SCM_BOOL_F;
1421
1422 env = scm_make_environment (body);
1423
1424 core_environments_init (&body->base, &eval_environment_funcs);
93d40df2 1425 body->obarray = scm_make_vector (SCM_MAKINUM (DEFAULT_OBARRAY_SIZE), SCM_EOL);
5d3e2388
DH		 1426 body->imported = imported;
1427 body->imported_observer
1428 = SCM_ENVIRONMENT_OBSERVE (imported, eval_environment_observer, env, 1);
1429 body->local = local;
1430 body->local_observer
1431 = SCM_ENVIRONMENT_OBSERVE (local, eval_environment_observer, env, 1);
1432
1433 return env;
1434}
1435#undef FUNC_NAME
1436
1437
1438SCM_DEFINE (scm_eval_environment_p, "eval-environment?", 1, 0, 0,
1439 (SCM object),
1440 "Return #t if object is an eval environment, or #f otherwise.")
1441#define FUNC_NAME s_scm_eval_environment_p
1442{
1443 return SCM_BOOL (SCM_EVAL_ENVIRONMENT_P (object));
1444}
1445#undef FUNC_NAME
1446
1447
1448SCM_DEFINE (scm_eval_environment_local, "eval-environment-local", 1, 0, 0,
1449 (SCM env),
1450 "Return the local environment of eval environment env.")
1451#define FUNC_NAME s_scm_eval_environment_local
1452{
1453 SCM_ASSERT (SCM_EVAL_ENVIRONMENT_P (env), env, SCM_ARG1, FUNC_NAME);
1454
1455 return EVAL_ENVIRONMENT (env)->local;
1456}
1457#undef FUNC_NAME
1458
1459
1460SCM_DEFINE (scm_eval_environment_set_local_x, "eval-environment-set-local!", 2, 0, 0,
1461 (SCM env, SCM local),
1462 "Change env's local environment to LOCAL.")
1463#define FUNC_NAME s_scm_eval_environment_set_local_x
1464{
1465 struct eval_environment *body;
1466
1467 SCM_ASSERT (SCM_EVAL_ENVIRONMENT_P (env), env, SCM_ARG1, FUNC_NAME);
1468 SCM_ASSERT (SCM_ENVIRONMENT_P (local), local, SCM_ARG2, FUNC_NAME);
1469
1470 body = EVAL_ENVIRONMENT (env);
1471
1472 obarray_remove_all (body->obarray);
1473 SCM_ENVIRONMENT_UNOBSERVE (body->local, body->local_observer);
1474
1475 body->local = local;
1476 body->local_observer
1477 = SCM_ENVIRONMENT_OBSERVE (local, eval_environment_observer, env, 1);
1478
1479 core_environments_broadcast (env);
1480
1481 return SCM_UNSPECIFIED;
1482}
1483#undef FUNC_NAME
1484
1485
1486SCM_DEFINE (scm_eval_environment_imported, "eval-environment-imported", 1, 0, 0,
1487 (SCM env),
1488 "Return the imported environment of eval environment env.")
1489#define FUNC_NAME s_scm_eval_environment_imported
1490{
1491 SCM_ASSERT (SCM_EVAL_ENVIRONMENT_P (env), env, SCM_ARG1, FUNC_NAME);
1492
1493 return EVAL_ENVIRONMENT (env)->imported;
1494}
1495#undef FUNC_NAME
1496
1497
1498SCM_DEFINE (scm_eval_environment_set_imported_x, "eval-environment-set-imported!", 2, 0, 0,
1499 (SCM env, SCM imported),
1500 "Change env's imported environment to IMPORTED.")
1501#define FUNC_NAME s_scm_eval_environment_set_imported_x
1502{
1503 struct eval_environment *body;
1504
1505 SCM_ASSERT (SCM_EVAL_ENVIRONMENT_P (env), env, SCM_ARG1, FUNC_NAME);
1506 SCM_ASSERT (SCM_ENVIRONMENT_P (imported), imported, SCM_ARG2, FUNC_NAME);
1507
1508 body = EVAL_ENVIRONMENT (env);
1509
1510 obarray_remove_all (body->obarray);
1511 SCM_ENVIRONMENT_UNOBSERVE (body->imported, body->imported_observer);
1512
1513 body->imported = imported;
1514 body->imported_observer
1515 = SCM_ENVIRONMENT_OBSERVE (imported, eval_environment_observer, env, 1);
1516
1517 core_environments_broadcast (env);
1518
1519 return SCM_UNSPECIFIED;
1520}
1521#undef FUNC_NAME
1522
1523\f
1524
1525/* import environments
1526 *
1527 * An import environment combines the bindings of a set of argument
1528 * environments, and checks for naming clashes.
1529 *
1530 * Implementation: The import environment does no caching at all. For every
1531 * access, the list of imported environments is scanned.
1532 */
1533
1534
1535struct import_environment {
1536 struct core_environments_base base;
1537
1538 SCM imports;
1539 SCM import_observers;
1540
1541 SCM conflict_proc;
1542};
1543
1544
1545#define IMPORT_ENVIRONMENT(env) \
1546 ((struct import_environment *) SCM_CELL_WORD_1 (env))
1547
1548\f
1549
1550/* Lookup will report one of the following distinct results:
1551 * a) <environment> if only environment binds the symbol.
1552 * b) (env-1 env-2 ...) for conflicting bindings in env-1, ...
1553 * c) SCM_UNDEFINED if there is no binding for the symbol.
1554 */
1555static SCM
1556import_environment_lookup (SCM env, SCM sym)
1557{
1558 SCM imports = IMPORT_ENVIRONMENT (env)->imports;
1559 SCM result = SCM_UNDEFINED;
1560 SCM l;
1561
1562 for (l = imports; !SCM_NULLP (l); l = SCM_CDR (l))
1563 {
1564 SCM imported = SCM_CAR (l);
1565
1566 if (SCM_ENVIRONMENT_BOUND_P (imported, sym))
1567 {
1568 if (SCM_UNBNDP (result))
1569 result = imported;
1570 else if (SCM_CONSP (result))
1571 result = scm_cons (imported, result);
1572 else
1573 result = scm_cons2 (imported, result, SCM_EOL);
1574 }
1575 }
1576
1577 if (SCM_CONSP (result))
1578 return scm_reverse (result);
1579 else
1580 return result;
1581}
1582
1583
1584static SCM
1585import_environment_conflict (SCM env, SCM sym, SCM imports)
1586{
1587 SCM conflict_proc = IMPORT_ENVIRONMENT (env)->conflict_proc;
1588 SCM args = scm_cons2 (env, sym, scm_cons (imports, SCM_EOL));
1589
1590 return scm_apply (conflict_proc, args, SCM_EOL);
1591}
1592
1593
1594static SCM
1595import_environment_ref (SCM env, SCM sym)
1596#define FUNC_NAME "import_environment_ref"
1597{
1598 SCM owner = import_environment_lookup (env, sym);
1599
1600 if (SCM_UNBNDP (owner))
1601 {
1602 return SCM_UNDEFINED;
1603 }
1604 else if (SCM_CONSP (owner))
1605 {
1606 SCM resolve = import_environment_conflict (env, sym, owner);
1607
1608 if (SCM_ENVIRONMENT_P (resolve))
1609 return SCM_ENVIRONMENT_REF (resolve, sym);
1610 else
1611 return SCM_UNSPECIFIED;
1612 }
1613 else
1614 {
1615 return SCM_ENVIRONMENT_REF (owner, sym);
1616 }
1617}
1618#undef FUNC_NAME
1619
1620
1621static SCM
1622import_environment_folder (SCM extended_data, SCM symbol, SCM value, SCM tail)
1623#define FUNC_NAME "import_environment_fold"
1624{
1625 SCM import_env = SCM_CAR (extended_data);
1626 SCM imported_env = SCM_CADR (extended_data);
1627 SCM owner = import_environment_lookup (import_env, symbol);
1628 SCM proc_as_nr = SCM_CADDR (extended_data);
1629 unsigned long int proc_as_ul = scm_num2ulong (proc_as_nr, NULL, NULL);
1630 scm_environment_folder proc = (scm_environment_folder) proc_as_ul;
1631 SCM data = SCM_CDDDR (extended_data);
1632
1633 if (SCM_CONSP (owner) && SCM_EQ_P (SCM_CAR (owner), imported_env))
1634 owner = import_environment_conflict (import_env, symbol, owner);
1635
1636 if (SCM_ENVIRONMENT_P (owner))
1637 return (*proc) (data, symbol, value, tail);
1638 else /* unresolved conflict */
1639 return (*proc) (data, symbol, SCM_UNSPECIFIED, tail);
1640}
1641#undef FUNC_NAME
1642
1643
1644static SCM
1645import_environment_fold (SCM env, scm_environment_folder proc, SCM data, SCM init)
1646{
1647 SCM proc_as_nr = scm_ulong2num ((unsigned long int) proc);
1648 SCM result = init;
1649 SCM l;
1650
1651 for (l = IMPORT_ENVIRONMENT (env)->imports; !SCM_NULLP (l); l = SCM_CDR (l))
1652 {
1653 SCM imported_env = SCM_CAR (l);
1654 SCM extended_data = scm_cons (env, scm_cons2 (imported_env, proc_as_nr, data));
1655
1656 result = scm_c_environment_fold (imported_env, import_environment_folder, extended_data, result);
1657 }
1658
1659 return result;
1660}
1661
1662
1663static SCM
1664import_environment_define (SCM env, SCM sym, SCM val)
1665#define FUNC_NAME "import_environment_define"
1666{
1667 return SCM_ENVIRONMENT_BINDING_IMMUTABLE;
1668}
1669#undef FUNC_NAME
1670
1671
1672static SCM
1673import_environment_undefine (SCM env, SCM sym)
1674#define FUNC_NAME "import_environment_undefine"
1675{
1676 return SCM_ENVIRONMENT_BINDING_IMMUTABLE;
1677}
1678#undef FUNC_NAME
1679
1680
1681static SCM
1682import_environment_set_x (SCM env, SCM sym, SCM val)
1683#define FUNC_NAME "import_environment_set_x"
1684{
1685 SCM owner = import_environment_lookup (env, sym);
1686
1687 if (SCM_UNBNDP (owner))
1688 {
1689 return SCM_UNDEFINED;
1690 }
1691 else if (SCM_CONSP (owner))
1692 {
1693 SCM resolve = import_environment_conflict (env, sym, owner);
1694
1695 if (SCM_ENVIRONMENT_P (resolve))
1696 return SCM_ENVIRONMENT_SET (resolve, sym, val);
1697 else
1698 return SCM_ENVIRONMENT_LOCATION_IMMUTABLE;
1699 }
1700 else
1701 {
1702 return SCM_ENVIRONMENT_SET (owner, sym, val);
1703 }
1704}
1705#undef FUNC_NAME
1706
1707
1708static SCM
1709import_environment_cell (SCM env, SCM sym, int for_write)
1710#define FUNC_NAME "import_environment_cell"
1711{
1712 SCM owner = import_environment_lookup (env, sym);
1713
1714 if (SCM_UNBNDP (owner))
1715 {
1716 return SCM_UNDEFINED;
1717 }
1718 else if (SCM_CONSP (owner))
1719 {
1720 SCM resolve = import_environment_conflict (env, sym, owner);
1721
1722 if (SCM_ENVIRONMENT_P (resolve))
1723 return SCM_ENVIRONMENT_CELL (resolve, sym, for_write);
1724 else
1725 return SCM_ENVIRONMENT_LOCATION_NO_CELL;
1726 }
1727 else
1728 {
1729 return SCM_ENVIRONMENT_CELL (owner, sym, for_write);
1730 }
1731}
1732#undef FUNC_NAME
1733
1734
1735static SCM
e841c3e0 1736import_environment_mark (SCM env)
5d3e2388
DH		 1737{
1738 scm_gc_mark (IMPORT_ENVIRONMENT (env)->imports);
1739 scm_gc_mark (IMPORT_ENVIRONMENT (env)->import_observers);
1740 scm_gc_mark (IMPORT_ENVIRONMENT (env)->conflict_proc);
1741 return core_environments_mark (env);
1742}
1743
1744
1745static scm_sizet
e841c3e0 1746import_environment_free (SCM env)
5d3e2388
DH		 1747{
1748 core_environments_finalize (env);
1749
1750 free (IMPORT_ENVIRONMENT (env));
1751 return sizeof (struct import_environment);
1752}
1753
1754
1755static int
e841c3e0 1756import_environment_print (SCM type, SCM port, scm_print_state *pstate)
5d3e2388
DH		 1757{
1758 SCM address = scm_ulong2num (SCM_UNPACK (type));
1759 SCM base16 = scm_number_to_string (address, SCM_MAKINUM (16));
1760
1761 scm_puts ("#<import environment ", port);
86c991c2 1762 scm_puts (SCM_STRING_CHARS (base16), port);
5d3e2388
DH		 1763 scm_puts (">", port);
1764
1765 return 1;
1766}
1767
1768
1769static struct scm_environment_funcs import_environment_funcs = {
1770 import_environment_ref,
1771 import_environment_fold,
1772 import_environment_define,
1773 import_environment_undefine,
1774 import_environment_set_x,
1775 import_environment_cell,
1776 core_environments_observe,
1777 core_environments_unobserve,
e841c3e0
KN		 1778 import_environment_mark,
1779 import_environment_free,
1780 import_environment_print
5d3e2388
DH		 1781};
1782
1783
1784void *scm_type_import_environment = &import_environment_funcs;
1785
1786
1787static void
1788import_environment_observer (SCM caller, SCM import_env)
1789{
1790 core_environments_broadcast (import_env);
1791}
1792
1793
1794SCM_DEFINE (scm_make_import_environment, "make-import-environment", 2, 0, 0,
1795 (SCM imports, SCM conflict_proc),
1796 "Return a new environment imp whose bindings are the union of\n"
1797 "the bindings from the environments in imports; imports must\n"
1798 "be a list of environments. That is, imp binds symbol to\n"
1799 "location when some element of imports does.\n"
1800 "If two different elements of imports have a binding for the\n"
1801 "same symbol, the conflict-proc is called with the following\n"
1802 "parameters: the import environment, the symbol and the list\n"
1803 "of the imported environments that bind the symbol. If the\n"
1804 "conflict-proc returns an environment env, the conflict is\n"
1805 "considered as resolved and the binding from env is used. If\n"
1806 "the conflict-proc returns some non-environment object, the\n"
1807 "conflict is considered unresolved and the symbol is treated\n"
1808 "as unspecified in the import environment.\n"
1809 "The checking for conflicts may be performed lazily, i. e. at\m"
1810 "the moment when a value or binding for a certain symbol is\n"
1811 "requested instead of the moment when the environment is\n"
1812 "created or the bindings of the imports change.\n"
1813 "All bindings in imp are immutable. If you apply\n"
1814 "environment-define or environment-undefine to imp, Guile\n"
1815 "will signal an environment:immutable-binding error. However,\n"
1816 "notice that the set of bindings in imp may still change, if\n"
1817 "one of its imported environments changes.")
1818#define FUNC_NAME s_scm_make_import_environment
1819{
1820 scm_sizet size = sizeof (struct import_environment);
1821 struct import_environment *body = scm_must_malloc (size, FUNC_NAME);
1822 SCM env;
1823
1824 core_environments_preinit (&body->base);
1825 body->imports = SCM_BOOL_F;
1826 body->import_observers = SCM_BOOL_F;
1827 body->conflict_proc = SCM_BOOL_F;
1828
1829 env = scm_make_environment (body);
1830
1831 core_environments_init (&body->base, &import_environment_funcs);
1832 body->imports = SCM_EOL;
1833 body->import_observers = SCM_EOL;
1834 body->conflict_proc = conflict_proc;
1835
1836 scm_import_environment_set_imports_x (env, imports);
1837
1838 return env;
1839}
1840#undef FUNC_NAME
1841
1842
1843SCM_DEFINE (scm_import_environment_p, "import-environment?", 1, 0, 0,
1844 (SCM object),
1845 "Return #t if object is an import environment, or #f otherwise.")
1846#define FUNC_NAME s_scm_import_environment_p
1847{
1848 return SCM_BOOL (SCM_IMPORT_ENVIRONMENT_P (object));
1849}
1850#undef FUNC_NAME
1851
1852
1853SCM_DEFINE (scm_import_environment_imports, "import-environment-imports", 1, 0, 0,
1854 (SCM env),
1855 "Return the list of environments imported by the import environment env.")
1856#define FUNC_NAME s_scm_import_environment_imports
1857{
1858 SCM_ASSERT (SCM_IMPORT_ENVIRONMENT_P (env), env, SCM_ARG1, FUNC_NAME);
1859
1860 return IMPORT_ENVIRONMENT (env)->imports;
1861}
1862#undef FUNC_NAME
1863
1864
1865SCM_DEFINE (scm_import_environment_set_imports_x, "import-environment-set-imports!", 2, 0, 0,
1866 (SCM env, SCM imports),
1867 "Change env's list of imported environments to imports, and check for conflicts.")
1868#define FUNC_NAME s_scm_import_environment_set_imports_x
1869{
1870 struct import_environment *body = IMPORT_ENVIRONMENT (env);
1871 SCM import_observers = SCM_EOL;
1872 SCM l;
1873
1874 SCM_ASSERT (SCM_IMPORT_ENVIRONMENT_P (env), env, SCM_ARG1, FUNC_NAME);
1875 for (l = imports; SCM_CONSP (l); l = SCM_CDR (l))
1876 {
1877 SCM obj = SCM_CAR (l);
1878 SCM_ASSERT (SCM_ENVIRONMENT_P (obj), imports, SCM_ARG1, FUNC_NAME);
1879 }
1880 SCM_ASSERT (SCM_NULLP (l), imports, SCM_ARG1, FUNC_NAME);
1881
1882 for (l = body->import_observers; !SCM_NULLP (l); l = SCM_CDR (l))
1883 {
1884 SCM obs = SCM_CAR (l);
1885 SCM_ENVIRONMENT_UNOBSERVE (env, obs);
1886 }
1887
1888 for (l = imports; !SCM_NULLP (l); l = SCM_CDR (l))
1889 {
1890 SCM imp = SCM_CAR (l);
1891 SCM obs = SCM_ENVIRONMENT_OBSERVE (imp, import_environment_observer, env, 1);
1892 import_observers = scm_cons (obs, import_observers);
1893 }
1894
1895 body->imports = imports;
1896 body->import_observers = import_observers;
1897
1898 return SCM_UNSPECIFIED;
1899}
1900#undef FUNC_NAME
1901
1902\f
1903
1904/* export environments
1905 *
1906 * An export environment restricts an environment to a specified set of
1907 * bindings.
1908 *
1909 * Implementation: The export environment does no caching at all. For every
1910 * access, the signature is scanned. The signature that is stored internally
1911 * is an alist of pairs (symbol . (mutability)).
1912 */
1913
1914
1915struct export_environment {
1916 struct core_environments_base base;
1917
1918 SCM private;
1919 SCM private_observer;
1920
1921 SCM signature;
1922};
1923
1924
1925#define EXPORT_ENVIRONMENT(env) \
1926 ((struct export_environment *) SCM_CELL_WORD_1 (env))
1927
1928
1929SCM_SYMBOL (symbol_immutable_location, "immutable-location");
1930SCM_SYMBOL (symbol_mutable_location, "mutable-location");
1931
1932\f
1933
1934static SCM
1935export_environment_ref (SCM env, SCM sym)
1936#define FUNC_NAME "export_environment_ref"
1937{
1938 struct export_environment *body = EXPORT_ENVIRONMENT (env);
1939 SCM entry = scm_assq (sym, body->signature);
1940
1941 if (SCM_FALSEP (entry))
1942 return SCM_UNDEFINED;
1943 else
1944 return SCM_ENVIRONMENT_REF (body->private, sym);
1945}
1946#undef FUNC_NAME
1947
1948
1949static SCM
1950export_environment_fold (SCM env, scm_environment_folder proc, SCM data, SCM init)
1951{
1952 struct export_environment *body = EXPORT_ENVIRONMENT (env);
1953 SCM result = init;
1954 SCM l;
1955
1956 for (l = body->signature; !SCM_NULLP (l); l = SCM_CDR (l))
1957 {
1958 SCM symbol = SCM_CAR (l);
1959 SCM value = SCM_ENVIRONMENT_REF (body->private, symbol);
1960 if (!SCM_UNBNDP (value))
1961 result = (*proc) (data, symbol, value, result);
1962 }
1963 return result;
1964}
1965
1966
1967static SCM
1968export_environment_define (SCM env, SCM sym, SCM val)
1969#define FUNC_NAME "export_environment_define"
1970{
1971 return SCM_ENVIRONMENT_BINDING_IMMUTABLE;
1972}
1973#undef FUNC_NAME
1974
1975
1976static SCM
1977export_environment_undefine (SCM env, SCM sym)
1978#define FUNC_NAME "export_environment_undefine"
1979{
1980 return SCM_ENVIRONMENT_BINDING_IMMUTABLE;
1981}
1982#undef FUNC_NAME
1983
1984
1985static SCM
1986export_environment_set_x (SCM env, SCM sym, SCM val)
1987#define FUNC_NAME "export_environment_set_x"
1988{
1989 struct export_environment *body = EXPORT_ENVIRONMENT (env);
1990 SCM entry = scm_assq (sym, body->signature);
1991
1992 if (SCM_FALSEP (entry))
1993 {
1994 return SCM_UNDEFINED;
1995 }
1996 else
1997 {
1998 if (SCM_EQ_P (SCM_CADR (entry), symbol_mutable_location))
1999 return SCM_ENVIRONMENT_SET (body->private, sym, val);
2000 else
2001 return SCM_ENVIRONMENT_LOCATION_IMMUTABLE;
2002 }
2003}
2004#undef FUNC_NAME
2005
2006
2007static SCM
2008export_environment_cell (SCM env, SCM sym, int for_write)
2009#define FUNC_NAME "export_environment_cell"
2010{
2011 struct export_environment *body = EXPORT_ENVIRONMENT (env);
2012 SCM entry = scm_assq (sym, body->signature);
2013
2014 if (SCM_FALSEP (entry))
2015 {
2016 return SCM_UNDEFINED;
2017 }
2018 else
2019 {
2020 if (!for_write || SCM_EQ_P (SCM_CADR (entry), symbol_mutable_location))
2021 return SCM_ENVIRONMENT_CELL (body->private, sym, for_write);
2022 else
2023 return SCM_ENVIRONMENT_LOCATION_IMMUTABLE;
2024 }
2025}
2026#undef FUNC_NAME
2027
2028
2029static SCM
e841c3e0 2030export_environment_mark (SCM env)
5d3e2388
DH		 2031{
2032 struct export_environment *body = EXPORT_ENVIRONMENT (env);
2033
2034 scm_gc_mark (body->private);
2035 scm_gc_mark (body->private_observer);
2036 scm_gc_mark (body->signature);
2037
2038 return core_environments_mark (env);
2039}
2040
2041
2042static scm_sizet
e841c3e0 2043export_environment_free (SCM env)
5d3e2388
DH		 2044{
2045 core_environments_finalize (env);
2046
2047 free (EXPORT_ENVIRONMENT (env));
2048 return sizeof (struct export_environment);
2049}
2050
2051
2052static int
e841c3e0 2053export_environment_print (SCM type, SCM port, scm_print_state *pstate)
5d3e2388
DH		 2054{
2055 SCM address = scm_ulong2num (SCM_UNPACK (type));
2056 SCM base16 = scm_number_to_string (address, SCM_MAKINUM (16));
2057
2058 scm_puts ("#<export environment ", port);
86c991c2 2059 scm_puts (SCM_STRING_CHARS (base16), port);
5d3e2388
DH		 2060 scm_puts (">", port);
2061
2062 return 1;
2063}
2064
2065
2066static struct scm_environment_funcs export_environment_funcs = {
2067 export_environment_ref,
2068 export_environment_fold,
2069 export_environment_define,
2070 export_environment_undefine,
2071 export_environment_set_x,
2072 export_environment_cell,
2073 core_environments_observe,
2074 core_environments_unobserve,
e841c3e0
KN		 2075 export_environment_mark,
2076 export_environment_free,
2077 export_environment_print
5d3e2388
DH		 2078};
2079
2080
2081void *scm_type_export_environment = &export_environment_funcs;
2082
2083
2084static void
2085export_environment_observer (SCM caller, SCM export_env)
2086{
2087 core_environments_broadcast (export_env);
2088}
2089
2090
2091SCM_DEFINE (scm_make_export_environment, "make-export-environment", 2, 0, 0,
2092 (SCM private, SCM signature),
2093 "Return a new environment exp containing only those bindings\n"
2094 "in private whose symbols are present in signature. The\n"
2095 "private argument must be an environment.\n\n"
2096 "The environment exp binds symbol to location when env does,\n"
2097 "and symbol is exported by signature.\n\n"
2098 "Signature is a list specifying which of the bindings in\n"
2099 "private should be visible in exp. Each element of signature\n"
2100 "should be a list of the form:\n"
2101 " (symbol attribute ...)\n"
2102 "where each attribute is one of the following:\n"
2103 "* the symbol mutable-location exp should treat the location\n"
2104 " bound to symbol as mutable. That is, exp will pass calls\n"
2105 " to env-set! or environment-cell directly through to\n"
2106 " private.\n"
2107 "* the symbol immutable-location exp should treat the\n"
2108 " location bound to symbol as immutable. If the program\n"
2109 " applies environment-set! to exp and symbol, or calls\n"
2110 " environment-cell to obtain a writable value cell,\n"
2111 " environment-set! will signal an\n"
2112 " environment:immutable-location error. Note that, even if\n"
2113 " an export environment treats a location as immutable, the\n"
2114 " underlying environment may treat it as mutable, so its\n"
2115 " value may change.\n"
2116 "It is an error for an element of signature to specify both\n"
2117 "mutable-location and immutable-location. If neither is\n"
2118 "specified, immutable-location is assumed.\n\n"
2119 "As a special case, if an element of signature is a lone\n"
2120 "symbol sym, it is equivalent to an element of the form\n"
2121 "(sym).\n\n"
2122 "All bindings in exp are immutable. If you apply\n"
2123 "environment-define or environment-undefine to exp, Guile\n"
2124 "will signal an environment:immutable-binding error. However,\n"
2125 "notice that the set of bindings in exp may still change, if\n"
2126 "the bindings in private change.")
2127#define FUNC_NAME s_scm_make_export_environment
2128{
2129 scm_sizet size;
2130 struct export_environment *body;
2131 SCM env;
2132
2133 SCM_ASSERT (SCM_ENVIRONMENT_P (private), private, SCM_ARG1, FUNC_NAME);
2134
2135 size = sizeof (struct export_environment);
2136 body = scm_must_malloc (size, FUNC_NAME);
2137
2138 core_environments_preinit (&body->base);
2139 body->private = SCM_BOOL_F;
2140 body->private_observer = SCM_BOOL_F;
2141 body->signature = SCM_BOOL_F;
2142
2143 env = scm_make_environment (body);
2144
2145 core_environments_init (&body->base, &export_environment_funcs);
2146 body->private = private;
2147 body->private_observer
2148 = SCM_ENVIRONMENT_OBSERVE (private, export_environment_observer, env, 1);
2149 body->signature = SCM_EOL;
2150
2151 scm_export_environment_set_signature_x (env, signature);
2152
2153 return env;
2154}
2155#undef FUNC_NAME
2156
2157
2158SCM_DEFINE (scm_export_environment_p, "export-environment?", 1, 0, 0,
2159 (SCM object),
2160 "Return #t if object is an export environment, or #f otherwise.")
2161#define FUNC_NAME s_scm_export_environment_p
2162{
2163 return SCM_BOOL (SCM_EXPORT_ENVIRONMENT_P (object));
2164}
2165#undef FUNC_NAME
2166
2167
2168SCM_DEFINE (scm_export_environment_private, "export-environment-private", 1, 0, 0,
2169 (SCM env),
2170 "Return the private environment of export environment env.")
2171#define FUNC_NAME s_scm_export_environment_private
2172{
2173 SCM_ASSERT (SCM_EXPORT_ENVIRONMENT_P (env), env, SCM_ARG1, FUNC_NAME);
2174
2175 return EXPORT_ENVIRONMENT (env)->private;
2176}
2177#undef FUNC_NAME
2178
2179
2180SCM_DEFINE (scm_export_environment_set_private_x, "export-environment-set-private!", 2, 0, 0,
2181 (SCM env, SCM private),
2182 "Change the private environment of export environment env.")
2183#define FUNC_NAME s_scm_export_environment_set_private_x
2184{
2185 struct export_environment *body;
2186
2187 SCM_ASSERT (SCM_EXPORT_ENVIRONMENT_P (env), env, SCM_ARG1, FUNC_NAME);
2188 SCM_ASSERT (SCM_ENVIRONMENT_P (private), private, SCM_ARG2, FUNC_NAME);
2189
2190 body = EXPORT_ENVIRONMENT (env);
2191 SCM_ENVIRONMENT_UNOBSERVE (private, body->private_observer);
2192
2193 body->private = private;
2194 body->private_observer
2195 = SCM_ENVIRONMENT_OBSERVE (private, export_environment_observer, env, 1);
2196
2197 return SCM_UNSPECIFIED;
2198}
2199#undef FUNC_NAME
2200
2201
2202SCM_DEFINE (scm_export_environment_signature, "export-environment-signature", 1, 0, 0,
2203 (SCM env),
2204 "Return the signature of export environment env.")
2205#define FUNC_NAME s_scm_export_environment_signature
2206{
2207 SCM_ASSERT (SCM_EXPORT_ENVIRONMENT_P (env), env, SCM_ARG1, FUNC_NAME);
2208
2209 return EXPORT_ENVIRONMENT (env)->signature;
2210}
2211#undef FUNC_NAME
2212
2213
2214static SCM
2215export_environment_parse_signature (SCM signature, const char* caller)
2216{
2217 SCM result = SCM_EOL;
2218 SCM l;
2219
2220 for (l = signature; SCM_CONSP (l); l = SCM_CDR (l))
2221 {
2222 SCM entry = SCM_CAR (l);
2223
2224 if (SCM_SYMBOLP (entry))
2225 {
2226 SCM new_entry = scm_cons2 (entry, symbol_immutable_location, SCM_EOL);
2227 result = scm_cons (new_entry, result);
2228 }
2229 else
2230 {
2231 SCM sym;
2232 SCM new_entry;
2233 int immutable = 0;
2234 int mutable = 0;
2235 SCM mutability;
2236 SCM l2;
2237
2238 SCM_ASSERT (SCM_CONSP (entry), entry, SCM_ARGn, caller);
2239 SCM_ASSERT (SCM_SYMBOLP (SCM_CAR (entry)), entry, SCM_ARGn, caller);
2240
2241 sym = SCM_CAR (entry);
2242
2243 for (l2 = SCM_CDR (entry); SCM_CONSP (l2); l2 = SCM_CDR (l2))
2244 {
2245 SCM attribute = SCM_CAR (l2);
2246 if (SCM_EQ_P (attribute, symbol_immutable_location))
2247 immutable = 1;
2248 else if (SCM_EQ_P (attribute, symbol_mutable_location))
2249 mutable = 1;
2250 else
2251 SCM_ASSERT (0, entry, SCM_ARGn, caller);
2252 }
2253 SCM_ASSERT (SCM_NULLP (l2), entry, SCM_ARGn, caller);
2254 SCM_ASSERT (!mutable || !immutable, entry, SCM_ARGn, caller);
2255
2256 if (!mutable && !immutable)
2257 immutable = 1;
2258
2259 mutability = mutable ? symbol_mutable_location : symbol_immutable_location;
2260 new_entry = scm_cons2 (sym, mutability, SCM_EOL);
2261 result = scm_cons (new_entry, result);
2262 }
2263 }
2264 SCM_ASSERT (SCM_NULLP (l), signature, SCM_ARGn, caller);
2265
2266 /* Dirk:FIXME:: Now we know that signature is syntactically correct. There
2267 * are, however, no checks for symbols entered twice with contradicting
2268 * mutabilities. It would be nice, to implement this test, to be able to
2269 * call the sort functions conveniently from C.
2270 */
2271
2272 return scm_reverse (result);
2273}
2274
2275
2276SCM_DEFINE (scm_export_environment_set_signature_x, "export-environment-set-signature!", 2, 0, 0,
2277 (SCM env, SCM signature),
2278 "Change the signature of export environment env.")
2279#define FUNC_NAME s_scm_export_environment_set_signature_x
2280{
2281 SCM parsed_sig;
2282
2283 SCM_ASSERT (SCM_EXPORT_ENVIRONMENT_P (env), env, SCM_ARG1, FUNC_NAME);
2284 parsed_sig = export_environment_parse_signature (signature, FUNC_NAME);
2285
2286 EXPORT_ENVIRONMENT (env)->signature = parsed_sig;
2287
2288 return SCM_UNSPECIFIED;
2289}
2290#undef FUNC_NAME
2291
2292\f
2293
2294void
2295scm_environments_prehistory ()
2296{
2297 /* create environment smob */
2298 scm_tc16_environment = scm_make_smob_type ("environment", 0);
e841c3e0
KN		 2299 scm_set_smob_mark (scm_tc16_environment, environment_mark);
2300 scm_set_smob_free (scm_tc16_environment, environment_free);
2301 scm_set_smob_print (scm_tc16_environment, environment_print);
5d3e2388
DH		 2302
2303 /* create observer smob */
2304 scm_tc16_observer = scm_make_smob_type ("observer", 0);
e841c3e0
KN		 2305 scm_set_smob_mark (scm_tc16_observer, observer_mark);
2306 scm_set_smob_print (scm_tc16_observer, observer_print);
5d3e2388
DH		 2307}
2308
2309
2310void
2311scm_init_environments ()
2312{
8dc9439f 2313#ifndef SCM_MAGIC_SNARFER
480a873c 2314#include "libguile/environments.x"
8dc9439f 2315#endif
5d3e2388
DH		 2316}
2317
2318
2319/*
2320 Local Variables:
2321 c-file-style: "gnu"
2322 End:
2323*/
Unnamed repository; edit this file 'description' to name the repository.