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