1 /* Copyright (C) 1995-2018 Free Software Foundation, Inc.
2 *
3 * This library is free software; you can redistribute it and/or
4 * modify it under the terms of the GNU Lesser General Public License
5 * as published by the Free Software Foundation; either version 3 of
6 * the License, or (at your option) any later version.
7 *
8 * This library is distributed in the hope that it will be useful, but
9 * WITHOUT ANY WARRANTY; without even the implied warranty of
10 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
11 * Lesser General Public License for more details.
12 *
13 * You should have received a copy of the GNU Lesser General Public
14 * License along with this library; if not, write to the Free Software
15 * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
16 * 02110-1301 USA
17 */
18
19
20
21 #ifdef HAVE_CONFIG_H
22 # include <config.h>
23 #endif
24
25 #include <alloca.h>
26 #include <stdarg.h>
27
28 #include "libguile/__scm.h"
29
30 #include "libguile/_scm.h"
31 #include "libguile/alist.h"
32 #include "libguile/async.h"
33 #include "libguile/continuations.h"
34 #include "libguile/control.h"
35 #include "libguile/debug.h"
36 #include "libguile/deprecation.h"
37 #include "libguile/dynwind.h"
38 #include "libguile/eq.h"
39 #include "libguile/expand.h"
40 #include "libguile/feature.h"
41 #include "libguile/goops.h"
42 #include "libguile/hash.h"
43 #include "libguile/hashtab.h"
44 #include "libguile/list.h"
45 #include "libguile/macros.h"
46 #include "libguile/memoize.h"
47 #include "libguile/modules.h"
48 #include "libguile/ports.h"
49 #include "libguile/print.h"
50 #include "libguile/procprop.h"
51 #include "libguile/programs.h"
52 #include "libguile/smob.h"
53 #include "libguile/srcprop.h"
54 #include "libguile/stackchk.h"
55 #include "libguile/strings.h"
56 #include "libguile/threads.h"
57 #include "libguile/throw.h"
58 #include "libguile/validate.h"
59 #include "libguile/values.h"
60 #include "libguile/vectors.h"
61 #include "libguile/vm.h"
62
63 #include "libguile/eval.h"
64 #include "libguile/private-options.h"
65
66
67
68
69 /* We have three levels of EVAL here:
70
71 - eval (exp, env)
72
73 evaluates EXP in environment ENV. ENV is a lexical environment
74 structure as used by the actual tree code evaluator. When ENV is
75 a top-level environment, then changes to the current module are
76 tracked by updating ENV so that it continues to be in sync with
77 the current module.
78
79 - scm_primitive_eval (exp)
80
81 evaluates EXP in the top-level environment as determined by the
82 current module. This is done by constructing a suitable
83 environment and calling eval. Thus, changes to the
84 top-level module are tracked normally.
85
86 - scm_eval (exp, mod)
87
88 evaluates EXP while MOD is the current module. This is done
89 by setting the current module to MOD_OR_STATE, invoking
90 scm_primitive_eval on EXP, and then restoring the current module
91 to the value it had previously. That is, while EXP is evaluated,
92 changes to the current module (or dynamic state) are tracked,
93 but these changes do not persist when scm_eval returns.
94
95 */
96
97
98 /* Boot closures. We only see these when compiling eval.scm, because once
99 eval.scm is in the house, closures are standard VM closures.
100 */
101
102 static scm_t_bits scm_tc16_boot_closure;
103 #define RETURN_BOOT_CLOSURE(code, env) \
104 SCM_RETURN_NEWSMOB2 (scm_tc16_boot_closure, SCM_UNPACK (code), SCM_UNPACK (env))
105 #define BOOT_CLOSURE_P(obj) SCM_TYP16_PREDICATE (scm_tc16_boot_closure, (obj))
106 #define BOOT_CLOSURE_CODE(x) SCM_SMOB_OBJECT (x)
107 #define BOOT_CLOSURE_ENV(x) SCM_SMOB_OBJECT_2 (x)
108 #define BOOT_CLOSURE_BODY(x) CAR (BOOT_CLOSURE_CODE (x))
109 #define BOOT_CLOSURE_NUM_REQUIRED_ARGS(x) (SCM_I_INUM (CADDR (BOOT_CLOSURE_CODE (x))))
110 #define BOOT_CLOSURE_IS_FIXED(x) (scm_is_null (CDDDR (BOOT_CLOSURE_CODE (x))))
111 /* NB: One may only call the following accessors if the closure is not FIXED. */
112 #define BOOT_CLOSURE_HAS_REST_ARGS(x) scm_is_true (CADDR (SCM_CDR (BOOT_CLOSURE_CODE (x))))
113 #define BOOT_CLOSURE_IS_REST(x) scm_is_null (SCM_CDR (CDDDR (BOOT_CLOSURE_CODE (x))))
114 /* NB: One may only call the following accessors if the closure is not REST. */
115 #define BOOT_CLOSURE_IS_FULL(x) (1)
116 #define BOOT_CLOSURE_PARSE_FULL(fu_,body,nargs,rest,nopt,kw,ninits,unbound,alt) \
117 do { SCM fu = fu_; \
118 body = CAR (fu); fu = CDDR (fu); \
119 \
120 rest = kw = alt = SCM_BOOL_F; \
121 unbound = SCM_BOOL_F; \
122 nopt = ninits = 0; \
123 \
124 nreq = SCM_I_INUM (CAR (fu)); fu = CDR (fu); \
125 if (scm_is_pair (fu)) \
126 { \
127 rest = CAR (fu); fu = CDR (fu); \
128 if (scm_is_pair (fu)) \
129 { \
130 nopt = SCM_I_INUM (CAR (fu)); fu = CDR (fu); \
131 kw = CAR (fu); fu = CDR (fu); \
132 ninits = SCM_I_INUM (CAR (fu)); fu = CDR (fu); \
133 unbound = CAR (fu); fu = CDR (fu); \
134 alt = CAR (fu); \
135 } \
136 } \
137 } while (0)
138 static void prepare_boot_closure_env_for_apply (SCM proc, SCM args,
139 SCM *out_body, SCM *out_env);
140 static void prepare_boot_closure_env_for_eval (SCM proc, unsigned int argc,
141 SCM exps, SCM *out_body,
142 SCM *inout_env);
143
144
145 #define CAR(x) SCM_CAR(x)
146 #define CDR(x) SCM_CDR(x)
147 #define CAAR(x) SCM_CAAR(x)
148 #define CADR(x) SCM_CADR(x)
149 #define CDAR(x) SCM_CDAR(x)
150 #define CDDR(x) SCM_CDDR(x)
151 #define CADDR(x) SCM_CADDR(x)
152 #define CDDDR(x) SCM_CDDDR(x)
153
154 #define VECTOR_REF(v, i) (SCM_SIMPLE_VECTOR_REF (v, i))
155 #define VECTOR_SET(v, i, x) (SCM_SIMPLE_VECTOR_SET (v, i, x))
156 #define VECTOR_LENGTH(v) (SCM_SIMPLE_VECTOR_LENGTH (v))
157
158 static SCM
make_env(int n,SCM init,SCM next)159 make_env (int n, SCM init, SCM next)
160 {
161 SCM env = scm_c_make_vector (n + 1, init);
162 VECTOR_SET (env, 0, next);
163 return env;
164 }
165
166 static SCM
next_rib(SCM env)167 next_rib (SCM env)
168 {
169 return VECTOR_REF (env, 0);
170 }
171
172 static SCM
env_tail(SCM env)173 env_tail (SCM env)
174 {
175 while (SCM_I_IS_VECTOR (env))
176 env = next_rib (env);
177 return env;
178 }
179
180 static SCM
env_ref(SCM env,int depth,int width)181 env_ref (SCM env, int depth, int width)
182 {
183 while (depth--)
184 env = next_rib (env);
185 return VECTOR_REF (env, width + 1);
186 }
187
188 static void
env_set(SCM env,int depth,int width,SCM val)189 env_set (SCM env, int depth, int width, SCM val)
190 {
191 while (depth--)
192 env = next_rib (env);
193 VECTOR_SET (env, width + 1, val);
194 }
195
error_missing_value(SCM proc,SCM kw)196 static void error_missing_value (SCM proc, SCM kw)
197 {
198 scm_error_scm (scm_from_utf8_symbol ("keyword-argument-error"), proc,
199 scm_from_utf8_string ("Keyword argument has no value"), SCM_EOL,
200 scm_list_1 (kw));
201 }
202
error_invalid_keyword(SCM proc,SCM obj)203 static void error_invalid_keyword (SCM proc, SCM obj)
204 {
205 scm_error_scm (scm_from_utf8_symbol ("keyword-argument-error"), proc,
206 scm_from_utf8_string ("Invalid keyword"), SCM_EOL,
207 scm_list_1 (obj));
208 }
209
error_unrecognized_keyword(SCM proc,SCM kw)210 static void error_unrecognized_keyword (SCM proc, SCM kw)
211 {
212 scm_error_scm (scm_from_utf8_symbol ("keyword-argument-error"), proc,
213 scm_from_utf8_string ("Unrecognized keyword"), SCM_EOL,
214 scm_list_1 (kw));
215 }
216
217
218 /* Multiple values truncation. */
219 static SCM
truncate_values(SCM x)220 truncate_values (SCM x)
221 {
222 if (SCM_LIKELY (!SCM_VALUESP (x)))
223 return x;
224 else
225 {
226 SCM l = scm_struct_ref (x, SCM_INUM0);
227 if (SCM_LIKELY (scm_is_pair (l)))
228 return scm_car (l);
229 else
230 {
231 scm_ithrow (scm_from_utf8_symbol ("vm-run"),
232 scm_list_3 (scm_from_utf8_symbol ("vm-run"),
233 scm_from_utf8_string
234 ("Too few values returned to continuation"),
235 SCM_EOL),
236 1);
237 /* Not reached. */
238 return SCM_BOOL_F;
239 }
240 }
241 }
242 #define EVAL1(x, env) (truncate_values (eval ((x), (env))))
243
244 static SCM
eval(SCM x,SCM env)245 eval (SCM x, SCM env)
246 {
247 SCM mx;
248 SCM proc = SCM_UNDEFINED, args = SCM_EOL;
249 unsigned int argc;
250
251 loop:
252 SCM_TICK;
253
254 mx = SCM_MEMOIZED_ARGS (x);
255 switch (SCM_I_INUM (SCM_CAR (x)))
256 {
257 case SCM_M_SEQ:
258 eval (CAR (mx), env);
259 x = CDR (mx);
260 goto loop;
261
262 case SCM_M_IF:
263 if (scm_is_true (EVAL1 (CAR (mx), env)))
264 x = CADR (mx);
265 else
266 x = CDDR (mx);
267 goto loop;
268
269 case SCM_M_LET:
270 {
271 SCM inits = CAR (mx);
272 SCM new_env;
273 int i;
274
275 new_env = make_env (VECTOR_LENGTH (inits), SCM_UNDEFINED, env);
276 for (i = 0; i < VECTOR_LENGTH (inits); i++)
277 env_set (new_env, 0, i, EVAL1 (VECTOR_REF (inits, i), env));
278 env = new_env;
279 x = CDR (mx);
280 goto loop;
281 }
282
283 case SCM_M_LAMBDA:
284 RETURN_BOOT_CLOSURE (mx, env);
285
286 case SCM_M_CAPTURE_ENV:
287 {
288 SCM locs = CAR (mx);
289 SCM new_env;
290 int i;
291
292 new_env = make_env (VECTOR_LENGTH (locs), SCM_BOOL_F, env);
293 for (i = 0; i < VECTOR_LENGTH (locs); i++)
294 {
295 SCM loc = VECTOR_REF (locs, i);
296 int depth, width;
297
298 depth = SCM_I_INUM (CAR (loc));
299 width = SCM_I_INUM (CDR (loc));
300 env_set (new_env, 0, i, env_ref (env, depth, width));
301 }
302
303 env = new_env;
304 x = CDR (mx);
305 goto loop;
306 }
307
308 case SCM_M_QUOTE:
309 return mx;
310
311 case SCM_M_CAPTURE_MODULE:
312 return eval (mx, scm_current_module ());
313
314 case SCM_M_APPLY:
315 /* Evaluate the procedure to be applied. */
316 proc = EVAL1 (CAR (mx), env);
317 /* Evaluate the argument holding the list of arguments */
318 args = EVAL1 (CADR (mx), env);
319
320 apply_proc:
321 /* Go here to tail-apply a procedure. PROC is the procedure and
322 * ARGS is the list of arguments. */
323 if (BOOT_CLOSURE_P (proc))
324 {
325 prepare_boot_closure_env_for_apply (proc, args, &x, &env);
326 goto loop;
327 }
328 else
329 return scm_apply_0 (proc, args);
330
331 case SCM_M_CALL:
332 /* Evaluate the procedure to be applied. */
333 proc = EVAL1 (CAR (mx), env);
334 argc = scm_ilength (CDR (mx));
335 mx = CDR (mx);
336
337 if (BOOT_CLOSURE_P (proc))
338 {
339 prepare_boot_closure_env_for_eval (proc, argc, mx, &x, &env);
340 goto loop;
341 }
342 else
343 {
344 SCM *argv;
345 unsigned int i;
346
347 argv = alloca (argc * sizeof (SCM));
348 for (i = 0; i < argc; i++, mx = CDR (mx))
349 argv[i] = EVAL1 (CAR (mx), env);
350
351 return scm_call_n (proc, argv, argc);
352 }
353
354 case SCM_M_CONT:
355 return scm_i_call_with_current_continuation (EVAL1 (mx, env));
356
357 case SCM_M_CALL_WITH_VALUES:
358 {
359 SCM producer;
360 SCM v;
361
362 producer = EVAL1 (CAR (mx), env);
363 /* `proc' is the consumer. */
364 proc = EVAL1 (CDR (mx), env);
365 v = scm_call_0 (producer);
366 if (SCM_VALUESP (v))
367 args = scm_struct_ref (v, SCM_INUM0);
368 else
369 args = scm_list_1 (v);
370 goto apply_proc;
371 }
372
373 case SCM_M_LEXICAL_REF:
374 {
375 SCM pos;
376 int depth, width;
377
378 pos = mx;
379 depth = SCM_I_INUM (CAR (pos));
380 width = SCM_I_INUM (CDR (pos));
381
382 return env_ref (env, depth, width);
383 }
384
385 case SCM_M_LEXICAL_SET:
386 {
387 SCM pos;
388 int depth, width;
389 SCM val = EVAL1 (CDR (mx), env);
390
391 pos = CAR (mx);
392 depth = SCM_I_INUM (CAR (pos));
393 width = SCM_I_INUM (CDR (pos));
394
395 env_set (env, depth, width, val);
396
397 return SCM_UNSPECIFIED;
398 }
399
400 case SCM_M_BOX_REF:
401 {
402 SCM box = mx;
403
404 return scm_variable_ref (EVAL1 (box, env));
405 }
406
407 case SCM_M_BOX_SET:
408 {
409 SCM box = CAR (mx), val = CDR (mx);
410
411 return scm_variable_set_x (EVAL1 (box, env), EVAL1 (val, env));
412 }
413
414 case SCM_M_RESOLVE:
415 if (SCM_VARIABLEP (mx))
416 return mx;
417 else
418 {
419 SCM var;
420
421 var = scm_sys_resolve_variable (mx, env_tail (env));
422 scm_set_cdr_x (x, var);
423
424 return var;
425 }
426
427 case SCM_M_CALL_WITH_PROMPT:
428 {
429 struct scm_vm *vp;
430 SCM k, handler, res;
431 scm_i_jmp_buf registers;
432 const void *prev_cookie;
433 scm_t_ptrdiff saved_stack_depth;
434
435 k = EVAL1 (CAR (mx), env);
436 handler = EVAL1 (CDDR (mx), env);
437 vp = scm_the_vm ();
438
439 saved_stack_depth = vp->stack_top - vp->sp;
440
441 /* Push the prompt onto the dynamic stack. */
442 scm_dynstack_push_prompt (&SCM_I_CURRENT_THREAD->dynstack,
443 SCM_F_DYNSTACK_PROMPT_ESCAPE_ONLY,
444 k,
445 vp->stack_top - vp->fp,
446 saved_stack_depth,
447 vp->ip,
448 ®isters);
449
450 prev_cookie = vp->resumable_prompt_cookie;
451 if (SCM_I_SETJMP (registers))
452 {
453 /* The prompt exited nonlocally. */
454 vp->resumable_prompt_cookie = prev_cookie;
455 scm_gc_after_nonlocal_exit ();
456 proc = handler;
457 args = scm_i_prompt_pop_abort_args_x (vp, saved_stack_depth);
458 goto apply_proc;
459 }
460
461 res = scm_call_0 (eval (CADR (mx), env));
462 scm_dynstack_pop (&SCM_I_CURRENT_THREAD->dynstack);
463 return res;
464 }
465
466 default:
467 abort ();
468 }
469 }
470
471
472
473 /* Simple procedure calls
474 */
475
476 SCM
scm_call_0(SCM proc)477 scm_call_0 (SCM proc)
478 {
479 return scm_call_n (proc, NULL, 0);
480 }
481
482 SCM
scm_call_1(SCM proc,SCM arg1)483 scm_call_1 (SCM proc, SCM arg1)
484 {
485 return scm_call_n (proc, &arg1, 1);
486 }
487
488 SCM
scm_call_2(SCM proc,SCM arg1,SCM arg2)489 scm_call_2 (SCM proc, SCM arg1, SCM arg2)
490 {
491 SCM args[] = { arg1, arg2 };
492 return scm_call_n (proc, args, 2);
493 }
494
495 SCM
scm_call_3(SCM proc,SCM arg1,SCM arg2,SCM arg3)496 scm_call_3 (SCM proc, SCM arg1, SCM arg2, SCM arg3)
497 {
498 SCM args[] = { arg1, arg2, arg3 };
499 return scm_call_n (proc, args, 3);
500 }
501
502 SCM
scm_call_4(SCM proc,SCM arg1,SCM arg2,SCM arg3,SCM arg4)503 scm_call_4 (SCM proc, SCM arg1, SCM arg2, SCM arg3, SCM arg4)
504 {
505 SCM args[] = { arg1, arg2, arg3, arg4 };
506 return scm_call_n (proc, args, 4);
507 }
508
509 SCM
scm_call_5(SCM proc,SCM arg1,SCM arg2,SCM arg3,SCM arg4,SCM arg5)510 scm_call_5 (SCM proc, SCM arg1, SCM arg2, SCM arg3, SCM arg4, SCM arg5)
511 {
512 SCM args[] = { arg1, arg2, arg3, arg4, arg5 };
513 return scm_call_n (proc, args, 5);
514 }
515
516 SCM
scm_call_6(SCM proc,SCM arg1,SCM arg2,SCM arg3,SCM arg4,SCM arg5,SCM arg6)517 scm_call_6 (SCM proc, SCM arg1, SCM arg2, SCM arg3, SCM arg4, SCM arg5,
518 SCM arg6)
519 {
520 SCM args[] = { arg1, arg2, arg3, arg4, arg5, arg6 };
521 return scm_call_n (proc, args, 6);
522 }
523
524 SCM
scm_call_7(SCM proc,SCM arg1,SCM arg2,SCM arg3,SCM arg4,SCM arg5,SCM arg6,SCM arg7)525 scm_call_7 (SCM proc, SCM arg1, SCM arg2, SCM arg3, SCM arg4, SCM arg5,
526 SCM arg6, SCM arg7)
527 {
528 SCM args[] = { arg1, arg2, arg3, arg4, arg5, arg6, arg7 };
529 return scm_call_n (proc, args, 7);
530 }
531
532 SCM
scm_call_8(SCM proc,SCM arg1,SCM arg2,SCM arg3,SCM arg4,SCM arg5,SCM arg6,SCM arg7,SCM arg8)533 scm_call_8 (SCM proc, SCM arg1, SCM arg2, SCM arg3, SCM arg4, SCM arg5,
534 SCM arg6, SCM arg7, SCM arg8)
535 {
536 SCM args[] = { arg1, arg2, arg3, arg4, arg5, arg6, arg7, arg8 };
537 return scm_call_n (proc, args, 8);
538 }
539
540 SCM
scm_call_9(SCM proc,SCM arg1,SCM arg2,SCM arg3,SCM arg4,SCM arg5,SCM arg6,SCM arg7,SCM arg8,SCM arg9)541 scm_call_9 (SCM proc, SCM arg1, SCM arg2, SCM arg3, SCM arg4, SCM arg5,
542 SCM arg6, SCM arg7, SCM arg8, SCM arg9)
543 {
544 SCM args[] = { arg1, arg2, arg3, arg4, arg5, arg6, arg7, arg8, arg9 };
545 return scm_call_n (proc, args, 9);
546 }
547
548 /* scm_call_n defined in vm.c */
549
550 SCM
scm_call(SCM proc,...)551 scm_call (SCM proc, ...)
552 {
553 va_list argp;
554 SCM *argv = NULL;
555 size_t i, nargs = 0;
556
557 va_start (argp, proc);
558 while (!SCM_UNBNDP (va_arg (argp, SCM)))
559 nargs++;
560 va_end (argp);
561
562 argv = alloca (nargs * sizeof (SCM));
563 va_start (argp, proc);
564 for (i = 0; i < nargs; i++)
565 argv[i] = va_arg (argp, SCM);
566 va_end (argp);
567
568 return scm_call_n (proc, argv, nargs);
569 }
570
571 /* Simple procedure applies
572 */
573
574 SCM
scm_apply_0(SCM proc,SCM args)575 scm_apply_0 (SCM proc, SCM args)
576 {
577 SCM *argv;
578 int i, nargs;
579
580 nargs = scm_ilength (args);
581 if (SCM_UNLIKELY (nargs < 0))
582 scm_wrong_type_arg_msg ("apply", 2, args, "list");
583
584 /* FIXME: Use vm_builtin_apply instead of alloca. */
585 argv = alloca (nargs * sizeof(SCM));
586 for (i = 0; i < nargs; i++)
587 {
588 argv[i] = SCM_CAR (args);
589 args = SCM_CDR (args);
590 }
591
592 return scm_call_n (proc, argv, nargs);
593 }
594
595 SCM
scm_apply_1(SCM proc,SCM arg1,SCM args)596 scm_apply_1 (SCM proc, SCM arg1, SCM args)
597 {
598 return scm_apply_0 (proc, scm_cons (arg1, args));
599 }
600
601 SCM
scm_apply_2(SCM proc,SCM arg1,SCM arg2,SCM args)602 scm_apply_2 (SCM proc, SCM arg1, SCM arg2, SCM args)
603 {
604 return scm_apply_0 (proc, scm_cons2 (arg1, arg2, args));
605 }
606
607 SCM
scm_apply_3(SCM proc,SCM arg1,SCM arg2,SCM arg3,SCM args)608 scm_apply_3 (SCM proc, SCM arg1, SCM arg2, SCM arg3, SCM args)
609 {
610 return scm_apply_0 (proc, scm_cons (arg1, scm_cons2 (arg2, arg3, args)));
611 }
612
613 static SCM map_var, for_each_var;
614
init_map_var(void)615 static void init_map_var (void)
616 {
617 map_var = scm_private_variable (scm_the_root_module (),
618 scm_from_latin1_symbol ("map"));
619 }
620
init_for_each_var(void)621 static void init_for_each_var (void)
622 {
623 for_each_var = scm_private_variable (scm_the_root_module (),
624 scm_from_latin1_symbol ("for-each"));
625 }
626
627 SCM
scm_map(SCM proc,SCM arg1,SCM args)628 scm_map (SCM proc, SCM arg1, SCM args)
629 {
630 static scm_i_pthread_once_t once = SCM_I_PTHREAD_ONCE_INIT;
631 scm_i_pthread_once (&once, init_map_var);
632
633 return scm_apply_0 (scm_variable_ref (map_var),
634 scm_cons (proc, scm_cons (arg1, args)));
635 }
636
637 SCM
scm_for_each(SCM proc,SCM arg1,SCM args)638 scm_for_each (SCM proc, SCM arg1, SCM args)
639 {
640 static scm_i_pthread_once_t once = SCM_I_PTHREAD_ONCE_INIT;
641 scm_i_pthread_once (&once, init_for_each_var);
642
643 return scm_apply_0 (scm_variable_ref (for_each_var),
644 scm_cons (proc, scm_cons (arg1, args)));
645 }
646
647
648 static SCM
scm_c_primitive_eval(SCM exp)649 scm_c_primitive_eval (SCM exp)
650 {
651 if (!SCM_EXPANDED_P (exp))
652 exp = scm_call_1 (scm_current_module_transformer (), exp);
653 return eval (scm_memoize_expression (exp), SCM_BOOL_F);
654 }
655
656 static SCM var_primitive_eval;
657 SCM
scm_primitive_eval(SCM exp)658 scm_primitive_eval (SCM exp)
659 {
660 return scm_call_n (scm_variable_ref (var_primitive_eval),
661 &exp, 1);
662 }
663
664
665 /* Eval does not take the second arg optionally. This is intentional
666 * in order to be R5RS compatible, and to prepare for the new module
667 * system, where we would like to make the choice of evaluation
668 * environment explicit. */
669
670 SCM_DEFINE (scm_eval, "eval", 2, 0, 0,
671 (SCM exp, SCM module_or_state),
672 "Evaluate @var{exp}, a list representing a Scheme expression,\n"
673 "in the top-level environment specified by\n"
674 "@var{module_or_state}.\n"
675 "While @var{exp} is evaluated (using @code{primitive-eval}),\n"
676 "@var{module_or_state} is made the current module when\n"
677 "it is a module, or the current dynamic state when it is\n"
678 "a dynamic state."
679 "Example: (eval '(+ 1 2) (interaction-environment))")
680 #define FUNC_NAME s_scm_eval
681 {
682 SCM res;
683
684 scm_dynwind_begin (SCM_F_DYNWIND_REWINDABLE);
685 if (scm_is_dynamic_state (module_or_state))
686 scm_dynwind_current_dynamic_state (module_or_state);
687 else if (scm_module_system_booted_p)
688 {
689 SCM_VALIDATE_MODULE (2, module_or_state);
690 scm_dynwind_current_module (module_or_state);
691 }
692 /* otherwise if the module system isn't booted, ignore the module arg */
693
694 res = scm_primitive_eval (exp);
695
696 scm_dynwind_end ();
697 return res;
698 }
699 #undef FUNC_NAME
700
701
702 static SCM f_apply;
703
704 /* Apply a function to a list of arguments.
705
706 This function's interface is a bit wonly. It takes two required
707 arguments and a tail argument, as if it were:
708
709 (lambda (proc arg1 . args) ...)
710
711 Usually you want to use scm_apply_0 or one of its cousins. */
712
713 SCM
scm_apply(SCM proc,SCM arg1,SCM args)714 scm_apply (SCM proc, SCM arg1, SCM args)
715 {
716 return scm_apply_0 (proc,
717 scm_is_null (args) ? arg1 : scm_cons_star (arg1, args));
718 }
719
720 static void
prepare_boot_closure_env_for_apply(SCM proc,SCM args,SCM * out_body,SCM * out_env)721 prepare_boot_closure_env_for_apply (SCM proc, SCM args,
722 SCM *out_body, SCM *out_env)
723 {
724 int nreq = BOOT_CLOSURE_NUM_REQUIRED_ARGS (proc);
725 SCM env = BOOT_CLOSURE_ENV (proc);
726 int i;
727
728 if (BOOT_CLOSURE_IS_FIXED (proc)
729 || (BOOT_CLOSURE_IS_REST (proc)
730 && !BOOT_CLOSURE_HAS_REST_ARGS (proc)))
731 {
732 if (SCM_UNLIKELY (scm_ilength (args) != nreq))
733 scm_wrong_num_args (proc);
734
735 env = make_env (nreq, SCM_UNDEFINED, env);
736 for (i = 0; i < nreq; args = CDR (args), i++)
737 env_set (env, 0, i, CAR (args));
738 *out_body = BOOT_CLOSURE_BODY (proc);
739 *out_env = env;
740 }
741 else if (BOOT_CLOSURE_IS_REST (proc))
742 {
743 if (SCM_UNLIKELY (scm_ilength (args) < nreq))
744 scm_wrong_num_args (proc);
745
746 env = make_env (nreq + 1, SCM_UNDEFINED, env);
747 for (i = 0; i < nreq; args = CDR (args), i++)
748 env_set (env, 0, i, CAR (args));
749 env_set (env, 0, i++, args);
750
751 *out_body = BOOT_CLOSURE_BODY (proc);
752 *out_env = env;
753 }
754 else
755 {
756 int i, argc, nreq, nopt, ninits, nenv;
757 SCM body, rest, kw, unbound, alt;
758 SCM mx = BOOT_CLOSURE_CODE (proc);
759
760 loop:
761 BOOT_CLOSURE_PARSE_FULL (mx, body, nargs, rest, nopt, kw,
762 ninits, unbound, alt);
763
764 argc = scm_ilength (args);
765 if (argc < nreq)
766 {
767 if (scm_is_true (alt))
768 {
769 mx = alt;
770 goto loop;
771 }
772 else
773 scm_wrong_num_args (proc);
774 }
775 if (scm_is_false (kw) && argc > nreq + nopt && scm_is_false (rest))
776 {
777 if (scm_is_true (alt))
778 {
779 mx = alt;
780 goto loop;
781 }
782 else
783 scm_wrong_num_args (proc);
784 }
785 if (scm_is_true (kw) && scm_is_false (rest))
786 {
787 int npos = 0;
788 SCM walk;
789 for (walk = args; scm_is_pair (walk); walk = CDR (walk), npos++)
790 if (npos >= nreq && scm_is_keyword (CAR (walk)))
791 break;
792
793 if (npos > nreq + nopt)
794 {
795 /* Too many positional args and no rest arg. */
796 if (scm_is_true (alt))
797 {
798 mx = alt;
799 goto loop;
800 }
801 else
802 scm_wrong_num_args (proc);
803 }
804 }
805
806 /* At this point we are committed to the chosen clause. */
807 nenv = nreq + (scm_is_true (rest) ? 1 : 0) + ninits;
808 env = make_env (nenv, unbound, env);
809
810 for (i = 0; i < nreq; i++, args = CDR (args))
811 env_set (env, 0, i, CAR (args));
812
813 if (scm_is_false (kw))
814 {
815 /* Optional args (possibly), but no keyword args. */
816 for (; i < argc && i < nreq + nopt; i++, args = CDR (args))
817 env_set (env, 0, i, CAR (args));
818 if (scm_is_true (rest))
819 env_set (env, 0, nreq + nopt, args);
820 }
821 else
822 {
823 SCM aok;
824
825 aok = CAR (kw);
826 kw = CDR (kw);
827
828 /* Optional args. As before, but stop at the first keyword. */
829 for (; i < argc && i < nreq + nopt && !scm_is_keyword (CAR (args));
830 i++, args = CDR (args))
831 env_set (env, 0, i, CAR (args));
832 if (scm_is_true (rest))
833 env_set (env, 0, nreq + nopt, args);
834
835 /* Parse keyword args. */
836 {
837 SCM walk;
838
839 while (scm_is_pair (args))
840 {
841 SCM k = CAR (args);
842 args = CDR (args);
843 if (!scm_is_keyword (k))
844 {
845 if (scm_is_true (rest))
846 continue;
847 else
848 break;
849 }
850 for (walk = kw; scm_is_pair (walk); walk = CDR (walk))
851 if (scm_is_eq (k, CAAR (walk)))
852 {
853 if (scm_is_pair (args))
854 {
855 SCM v = CAR (args);
856 args = CDR (args);
857 env_set (env, 0, SCM_I_INUM (CDAR (walk)), v);
858 break;
859 }
860 else
861 error_missing_value (proc, k);
862 }
863 if (scm_is_null (walk))
864 {
865 if (scm_is_false (aok))
866 error_unrecognized_keyword (proc, k);
867 else if (!scm_is_pair (args))
868 /* Advance past argument of unrecognized
869 keyword, if present. */
870 args = CDR (args);
871 }
872 }
873 if (scm_is_pair (args) && scm_is_false (rest))
874 error_invalid_keyword (proc, CAR (args));
875 }
876 }
877
878 *out_body = body;
879 *out_env = env;
880 }
881 }
882
883 static void
prepare_boot_closure_env_for_eval(SCM proc,unsigned int argc,SCM exps,SCM * out_body,SCM * inout_env)884 prepare_boot_closure_env_for_eval (SCM proc, unsigned int argc,
885 SCM exps, SCM *out_body, SCM *inout_env)
886 {
887 int nreq = BOOT_CLOSURE_NUM_REQUIRED_ARGS (proc);
888 SCM new_env = BOOT_CLOSURE_ENV (proc);
889 if ((BOOT_CLOSURE_IS_FIXED (proc)
890 || (BOOT_CLOSURE_IS_REST (proc)
891 && !BOOT_CLOSURE_HAS_REST_ARGS (proc)))
892 && nreq == argc)
893 {
894 int i;
895
896 new_env = make_env (nreq, SCM_UNDEFINED, new_env);
897 for (i = 0; i < nreq; exps = CDR (exps), i++)
898 env_set (new_env, 0, i, EVAL1 (CAR (exps), *inout_env));
899
900 *out_body = BOOT_CLOSURE_BODY (proc);
901 *inout_env = new_env;
902 }
903 else if (!BOOT_CLOSURE_IS_FIXED (proc) &&
904 BOOT_CLOSURE_IS_REST (proc) && argc >= nreq)
905 {
906 SCM rest;
907 int i;
908
909 new_env = make_env (nreq + 1, SCM_UNDEFINED, new_env);
910 for (i = 0; i < nreq; exps = CDR (exps), i++)
911 env_set (new_env, 0, i, EVAL1 (CAR (exps), *inout_env));
912 for (rest = SCM_EOL; scm_is_pair (exps); exps = CDR (exps))
913 rest = scm_cons (EVAL1 (CAR (exps), *inout_env), rest);
914 env_set (new_env, 0, i++, scm_reverse_x (rest, SCM_UNDEFINED));
915
916 *out_body = BOOT_CLOSURE_BODY (proc);
917 *inout_env = new_env;
918 }
919 else
920 {
921 SCM args = SCM_EOL;
922 for (; scm_is_pair (exps); exps = CDR (exps))
923 args = scm_cons (EVAL1 (CAR (exps), *inout_env), args);
924 args = scm_reverse_x (args, SCM_UNDEFINED);
925 prepare_boot_closure_env_for_apply (proc, args, out_body, inout_env);
926 }
927 }
928
929 static SCM
boot_closure_apply(SCM closure,SCM args)930 boot_closure_apply (SCM closure, SCM args)
931 {
932 SCM body, env;
933 prepare_boot_closure_env_for_apply (closure, args, &body, &env);
934 return eval (body, env);
935 }
936
937 static int
boot_closure_print(SCM closure,SCM port,scm_print_state * pstate)938 boot_closure_print (SCM closure, SCM port, scm_print_state *pstate)
939 {
940 SCM args;
941 scm_puts ("#<boot-closure ", port);
942 scm_uintprint (SCM_UNPACK (closure), 16, port);
943 scm_putc (' ', port);
944 args = scm_make_list (scm_from_int (BOOT_CLOSURE_NUM_REQUIRED_ARGS (closure)),
945 scm_from_latin1_symbol ("_"));
946 if (!BOOT_CLOSURE_IS_FIXED (closure) && BOOT_CLOSURE_HAS_REST_ARGS (closure))
947 args = scm_cons_star (scm_from_latin1_symbol ("_"), args);
948 /* FIXME: optionals and rests */
949 scm_display (args, port);
950 scm_putc ('>', port);
951 return 1;
952 }
953
954 void
scm_init_eval()955 scm_init_eval ()
956 {
957 SCM primitive_eval;
958
959 f_apply = scm_c_define_gsubr ("apply", 2, 0, 1, scm_apply);
960
961 scm_tc16_boot_closure = scm_make_smob_type ("boot-closure", 0);
962 scm_set_smob_apply (scm_tc16_boot_closure, boot_closure_apply, 0, 0, 1);
963 scm_set_smob_print (scm_tc16_boot_closure, boot_closure_print);
964
965 primitive_eval = scm_c_make_gsubr ("primitive-eval", 1, 0, 0,
966 scm_c_primitive_eval);
967 var_primitive_eval = scm_define (SCM_SUBR_NAME (primitive_eval),
968 primitive_eval);
969
970 #include "libguile/eval.x"
971 }
972
973 /*
974 Local Variables:
975 c-file-style: "gnu"
976 End:
977 */
978
979