1 /* Copyright (C) 1995,1996,1997,1998,1999,2000,2001,2002,2003,2004,
2 * 2005,2006,2007,2008,2009,2010,2011,2012,2013,2014
3 * Free Software Foundation, Inc.
5 * This library is free software; you can redistribute it and/or
6 * modify it under the terms of the GNU Lesser General Public License
7 * as published by the Free Software Foundation; either version 3 of
8 * the License, or (at your option) any later version.
10 * This library is distributed in the hope that it will be useful, but
11 * WITHOUT ANY WARRANTY; without even the implied warranty of
12 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
13 * Lesser General Public License for more details.
15 * You should have received a copy of the GNU Lesser General Public
16 * License along with this library; if not, write to the Free Software
17 * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
30 #include "libguile/__scm.h"
32 #include "libguile/_scm.h"
33 #include "libguile/alist.h"
34 #include "libguile/async.h"
35 #include "libguile/continuations.h"
36 #include "libguile/control.h"
37 #include "libguile/debug.h"
38 #include "libguile/deprecation.h"
39 #include "libguile/dynwind.h"
40 #include "libguile/eq.h"
41 #include "libguile/expand.h"
42 #include "libguile/feature.h"
43 #include "libguile/goops.h"
44 #include "libguile/hash.h"
45 #include "libguile/hashtab.h"
46 #include "libguile/list.h"
47 #include "libguile/macros.h"
48 #include "libguile/memoize.h"
49 #include "libguile/modules.h"
50 #include "libguile/ports.h"
51 #include "libguile/print.h"
52 #include "libguile/procprop.h"
53 #include "libguile/programs.h"
54 #include "libguile/root.h"
55 #include "libguile/smob.h"
56 #include "libguile/srcprop.h"
57 #include "libguile/stackchk.h"
58 #include "libguile/strings.h"
59 #include "libguile/threads.h"
60 #include "libguile/throw.h"
61 #include "libguile/validate.h"
62 #include "libguile/values.h"
63 #include "libguile/vectors.h"
64 #include "libguile/vm.h"
66 #include "libguile/eval.h"
67 #include "libguile/private-options.h"
72 /* We have three levels of EVAL here:
76 evaluates EXP in environment ENV. ENV is a lexical environment
77 structure as used by the actual tree code evaluator. When ENV is
78 a top-level environment, then changes to the current module are
79 tracked by updating ENV so that it continues to be in sync with
82 - scm_primitive_eval (exp)
84 evaluates EXP in the top-level environment as determined by the
85 current module. This is done by constructing a suitable
86 environment and calling eval. Thus, changes to the
87 top-level module are tracked normally.
91 evaluates EXP while MOD is the current module. This is done
92 by setting the current module to MOD_OR_STATE, invoking
93 scm_primitive_eval on EXP, and then restoring the current module
94 to the value it had previously. That is, while EXP is evaluated,
95 changes to the current module (or dynamic state) are tracked,
96 but these changes do not persist when scm_eval returns.
101 /* Boot closures. We only see these when compiling eval.scm, because once
102 eval.scm is in the house, closures are standard VM closures.
105 static scm_t_bits scm_tc16_boot_closure
;
106 #define RETURN_BOOT_CLOSURE(code, env) \
107 SCM_RETURN_NEWSMOB2 (scm_tc16_boot_closure, SCM_UNPACK (code), SCM_UNPACK (env))
108 #define BOOT_CLOSURE_P(obj) SCM_TYP16_PREDICATE (scm_tc16_boot_closure, (obj))
109 #define BOOT_CLOSURE_CODE(x) SCM_SMOB_OBJECT (x)
110 #define BOOT_CLOSURE_ENV(x) SCM_SMOB_OBJECT_2 (x)
111 #define BOOT_CLOSURE_BODY(x) CAR (BOOT_CLOSURE_CODE (x))
112 #define BOOT_CLOSURE_NUM_REQUIRED_ARGS(x) (SCM_I_INUM (CADDR (BOOT_CLOSURE_CODE (x))))
113 #define BOOT_CLOSURE_IS_FIXED(x) (scm_is_null (CDDDR (BOOT_CLOSURE_CODE (x))))
114 /* NB: One may only call the following accessors if the closure is not FIXED. */
115 #define BOOT_CLOSURE_HAS_REST_ARGS(x) scm_is_true (CADDR (SCM_CDR (BOOT_CLOSURE_CODE (x))))
116 #define BOOT_CLOSURE_IS_REST(x) scm_is_null (SCM_CDR (CDDDR (BOOT_CLOSURE_CODE (x))))
117 /* NB: One may only call the following accessors if the closure is not REST. */
118 #define BOOT_CLOSURE_IS_FULL(x) (1)
119 #define BOOT_CLOSURE_PARSE_FULL(fu_,body,nargs,rest,nopt,kw,ninits,unbound,alt) \
121 body = CAR (fu); fu = CDDR (fu); \
123 rest = kw = alt = SCM_BOOL_F; \
124 unbound = SCM_BOOL_F; \
127 nreq = SCM_I_INUM (CAR (fu)); fu = CDR (fu); \
128 if (scm_is_pair (fu)) \
130 rest = CAR (fu); fu = CDR (fu); \
131 if (scm_is_pair (fu)) \
133 nopt = SCM_I_INUM (CAR (fu)); fu = CDR (fu); \
134 kw = CAR (fu); fu = CDR (fu); \
135 ninits = SCM_I_INUM (CAR (fu)); fu = CDR (fu); \
136 unbound = CAR (fu); fu = CDR (fu); \
141 static void prepare_boot_closure_env_for_apply (SCM proc
, SCM args
,
142 SCM
*out_body
, SCM
*out_env
);
143 static void prepare_boot_closure_env_for_eval (SCM proc
, unsigned int argc
,
144 SCM exps
, SCM
*out_body
,
148 #define CAR(x) SCM_CAR(x)
149 #define CDR(x) SCM_CDR(x)
150 #define CAAR(x) SCM_CAAR(x)
151 #define CADR(x) SCM_CADR(x)
152 #define CDAR(x) SCM_CDAR(x)
153 #define CDDR(x) SCM_CDDR(x)
154 #define CADDR(x) SCM_CADDR(x)
155 #define CDDDR(x) SCM_CDDDR(x)
157 #define VECTOR_REF(v, i) (SCM_SIMPLE_VECTOR_REF (v, i))
158 #define VECTOR_SET(v, i, x) (SCM_SIMPLE_VECTOR_SET (v, i, x))
159 #define VECTOR_LENGTH(v) (SCM_SIMPLE_VECTOR_LENGTH (v))
162 make_env (int n
, SCM init
, SCM next
)
164 SCM env
= scm_c_make_vector (n
+ 1, init
);
165 VECTOR_SET (env
, 0, next
);
172 return VECTOR_REF (env
, 0);
178 while (SCM_I_IS_VECTOR (env
))
179 env
= next_rib (env
);
184 env_ref (SCM env
, int depth
, int width
)
187 env
= next_rib (env
);
188 return VECTOR_REF (env
, width
+ 1);
192 env_set (SCM env
, int depth
, int width
, SCM val
)
195 env
= next_rib (env
);
196 VECTOR_SET (env
, width
+ 1, val
);
200 static void error_invalid_keyword (SCM proc
, SCM obj
)
202 scm_error_scm (scm_from_latin1_symbol ("keyword-argument-error"), proc
,
203 scm_from_locale_string ("Invalid keyword"), SCM_EOL
,
207 static void error_unrecognized_keyword (SCM proc
, SCM kw
)
209 scm_error_scm (scm_from_latin1_symbol ("keyword-argument-error"), proc
,
210 scm_from_locale_string ("Unrecognized keyword"), SCM_EOL
,
215 /* Multiple values truncation. */
217 truncate_values (SCM x
)
219 if (SCM_LIKELY (!SCM_VALUESP (x
)))
223 SCM l
= scm_struct_ref (x
, SCM_INUM0
);
224 if (SCM_LIKELY (scm_is_pair (l
)))
228 scm_ithrow (scm_from_latin1_symbol ("vm-run"),
229 scm_list_3 (scm_from_latin1_symbol ("vm-run"),
230 scm_from_locale_string
231 ("Too few values returned to continuation"),
239 #define EVAL1(x, env) (truncate_values (eval ((x), (env))))
242 eval (SCM x
, SCM env
)
245 SCM proc
= SCM_UNDEFINED
, args
= SCM_EOL
;
251 mx
= SCM_MEMOIZED_ARGS (x
);
252 switch (SCM_I_INUM (SCM_CAR (x
)))
255 eval (CAR (mx
), env
);
260 if (scm_is_true (EVAL1 (CAR (mx
), env
)))
268 SCM inits
= CAR (mx
);
272 new_env
= make_env (VECTOR_LENGTH (inits
), SCM_UNDEFINED
, env
);
273 for (i
= 0; i
< VECTOR_LENGTH (inits
); i
++)
274 env_set (new_env
, 0, i
, EVAL1 (VECTOR_REF (inits
, i
), env
));
281 RETURN_BOOT_CLOSURE (mx
, env
);
287 scm_define (CAR (mx
), EVAL1 (CDR (mx
), env
));
288 return SCM_UNSPECIFIED
;
290 case SCM_M_CAPTURE_MODULE
:
291 return eval (mx
, scm_current_module ());
294 /* Evaluate the procedure to be applied. */
295 proc
= EVAL1 (CAR (mx
), env
);
296 /* Evaluate the argument holding the list of arguments */
297 args
= EVAL1 (CADR (mx
), env
);
300 /* Go here to tail-apply a procedure. PROC is the procedure and
301 * ARGS is the list of arguments. */
302 if (BOOT_CLOSURE_P (proc
))
304 prepare_boot_closure_env_for_apply (proc
, args
, &x
, &env
);
308 return scm_apply_0 (proc
, args
);
311 /* Evaluate the procedure to be applied. */
312 proc
= EVAL1 (CAR (mx
), env
);
313 argc
= SCM_I_INUM (CADR (mx
));
316 if (BOOT_CLOSURE_P (proc
))
318 prepare_boot_closure_env_for_eval (proc
, argc
, mx
, &x
, &env
);
326 argv
= alloca (argc
* sizeof (SCM
));
327 for (i
= 0; i
< argc
; i
++, mx
= CDR (mx
))
328 argv
[i
] = EVAL1 (CAR (mx
), env
);
330 return scm_call_n (proc
, argv
, argc
);
334 return scm_i_call_with_current_continuation (EVAL1 (mx
, env
));
336 case SCM_M_CALL_WITH_VALUES
:
341 producer
= EVAL1 (CAR (mx
), env
);
342 /* `proc' is the consumer. */
343 proc
= EVAL1 (CDR (mx
), env
);
344 v
= scm_call_0 (producer
);
346 args
= scm_struct_ref (v
, SCM_INUM0
);
348 args
= scm_list_1 (v
);
352 case SCM_M_LEXICAL_REF
:
358 depth
= SCM_I_INUM (CAR (pos
));
359 width
= SCM_I_INUM (CDR (pos
));
361 return env_ref (env
, depth
, width
);
364 case SCM_M_LEXICAL_SET
:
368 SCM val
= EVAL1 (CDR (mx
), env
);
371 depth
= SCM_I_INUM (CAR (pos
));
372 width
= SCM_I_INUM (CDR (pos
));
374 env_set (env
, depth
, width
, val
);
376 return SCM_UNSPECIFIED
;
379 case SCM_M_TOPLEVEL_REF
:
380 if (SCM_VARIABLEP (mx
))
381 return SCM_VARIABLE_REF (mx
);
384 env
= env_tail (env
);
385 return SCM_VARIABLE_REF (scm_memoize_variable_access_x (x
, env
));
388 case SCM_M_TOPLEVEL_SET
:
391 SCM val
= EVAL1 (CDR (mx
), env
);
392 if (SCM_VARIABLEP (var
))
394 SCM_VARIABLE_SET (var
, val
);
395 return SCM_UNSPECIFIED
;
399 env
= env_tail (env
);
400 SCM_VARIABLE_SET (scm_memoize_variable_access_x (x
, env
), val
);
401 return SCM_UNSPECIFIED
;
405 case SCM_M_MODULE_REF
:
406 if (SCM_VARIABLEP (mx
))
407 return SCM_VARIABLE_REF (mx
);
409 return SCM_VARIABLE_REF
410 (scm_memoize_variable_access_x (x
, SCM_BOOL_F
));
412 case SCM_M_MODULE_SET
:
413 if (SCM_VARIABLEP (CDR (mx
)))
415 SCM_VARIABLE_SET (CDR (mx
), EVAL1 (CAR (mx
), env
));
416 return SCM_UNSPECIFIED
;
421 (scm_memoize_variable_access_x (x
, SCM_BOOL_F
),
422 EVAL1 (CAR (mx
), env
));
423 return SCM_UNSPECIFIED
;
426 case SCM_M_CALL_WITH_PROMPT
:
430 scm_i_jmp_buf registers
;
431 /* We need the handler after nonlocal return to the setjmp, so
432 make sure it is volatile. */
433 volatile SCM handler
;
435 k
= EVAL1 (CAR (mx
), env
);
436 handler
= EVAL1 (CDDR (mx
), env
);
439 /* Push the prompt onto the dynamic stack. */
440 scm_dynstack_push_prompt (&SCM_I_CURRENT_THREAD
->dynstack
,
441 SCM_F_DYNSTACK_PROMPT_ESCAPE_ONLY
442 | SCM_F_DYNSTACK_PROMPT_PUSH_NARGS
,
444 vp
->fp
- vp
->stack_base
,
445 vp
->sp
- vp
->stack_base
,
449 if (SCM_I_SETJMP (registers
))
451 /* The prompt exited nonlocally. */
452 scm_gc_after_nonlocal_exit ();
455 args
= scm_i_prompt_pop_abort_args_x (vp
);
459 res
= scm_call_0 (eval (CADR (mx
), env
));
460 scm_dynstack_pop (&SCM_I_CURRENT_THREAD
->dynstack
);
471 /* Simple procedure calls
475 scm_call_0 (SCM proc
)
477 return scm_call_n (proc
, NULL
, 0);
481 scm_call_1 (SCM proc
, SCM arg1
)
483 return scm_call_n (proc
, &arg1
, 1);
487 scm_call_2 (SCM proc
, SCM arg1
, SCM arg2
)
489 SCM args
[] = { arg1
, arg2
};
490 return scm_call_n (proc
, args
, 2);
494 scm_call_3 (SCM proc
, SCM arg1
, SCM arg2
, SCM arg3
)
496 SCM args
[] = { arg1
, arg2
, arg3
};
497 return scm_call_n (proc
, args
, 3);
501 scm_call_4 (SCM proc
, SCM arg1
, SCM arg2
, SCM arg3
, SCM arg4
)
503 SCM args
[] = { arg1
, arg2
, arg3
, arg4
};
504 return scm_call_n (proc
, args
, 4);
508 scm_call_5 (SCM proc
, SCM arg1
, SCM arg2
, SCM arg3
, SCM arg4
, SCM arg5
)
510 SCM args
[] = { arg1
, arg2
, arg3
, arg4
, arg5
};
511 return scm_call_n (proc
, args
, 5);
515 scm_call_6 (SCM proc
, SCM arg1
, SCM arg2
, SCM arg3
, SCM arg4
, SCM arg5
,
518 SCM args
[] = { arg1
, arg2
, arg3
, arg4
, arg5
, arg6
};
519 return scm_call_n (proc
, args
, 6);
523 scm_call_7 (SCM proc
, SCM arg1
, SCM arg2
, SCM arg3
, SCM arg4
, SCM arg5
,
526 SCM args
[] = { arg1
, arg2
, arg3
, arg4
, arg5
, arg6
, arg7
};
527 return scm_call_n (proc
, args
, 7);
531 scm_call_8 (SCM proc
, SCM arg1
, SCM arg2
, SCM arg3
, SCM arg4
, SCM arg5
,
532 SCM arg6
, SCM arg7
, SCM arg8
)
534 SCM args
[] = { arg1
, arg2
, arg3
, arg4
, arg5
, arg6
, arg7
, arg8
};
535 return scm_call_n (proc
, args
, 8);
539 scm_call_9 (SCM proc
, SCM arg1
, SCM arg2
, SCM arg3
, SCM arg4
, SCM arg5
,
540 SCM arg6
, SCM arg7
, SCM arg8
, SCM arg9
)
542 SCM args
[] = { arg1
, arg2
, arg3
, arg4
, arg5
, arg6
, arg7
, arg8
, arg9
};
543 return scm_call_n (proc
, args
, 9);
546 /* scm_call_n defined in vm.c */
549 scm_call (SCM proc
, ...)
555 va_start (argp
, proc
);
556 while (!SCM_UNBNDP (va_arg (argp
, SCM
)))
560 argv
= alloca (nargs
* sizeof (SCM
));
561 va_start (argp
, proc
);
562 for (i
= 0; i
< nargs
; i
++)
563 argv
[i
] = va_arg (argp
, SCM
);
566 return scm_call_n (proc
, argv
, nargs
);
569 /* Simple procedure applies
573 scm_apply_0 (SCM proc
, SCM args
)
578 nargs
= scm_ilength (args
);
579 if (SCM_UNLIKELY (nargs
< 0))
580 scm_wrong_type_arg_msg ("apply", 2, args
, "list");
582 /* FIXME: Use vm_builtin_apply instead of alloca. */
583 argv
= alloca (nargs
* sizeof(SCM
));
584 for (i
= 0; i
< nargs
; i
++)
586 argv
[i
] = SCM_CAR (args
);
587 args
= SCM_CDR (args
);
590 return scm_call_n (proc
, argv
, nargs
);
594 scm_apply_1 (SCM proc
, SCM arg1
, SCM args
)
596 return scm_apply_0 (proc
, scm_cons (arg1
, args
));
600 scm_apply_2 (SCM proc
, SCM arg1
, SCM arg2
, SCM args
)
602 return scm_apply_0 (proc
, scm_cons2 (arg1
, arg2
, args
));
606 scm_apply_3 (SCM proc
, SCM arg1
, SCM arg2
, SCM arg3
, SCM args
)
608 return scm_apply_0 (proc
, scm_cons (arg1
, scm_cons2 (arg2
, arg3
, args
)));
611 static SCM map_var
, for_each_var
;
613 static void init_map_var (void)
615 map_var
= scm_private_variable (scm_the_root_module (),
616 scm_from_latin1_symbol ("map"));
619 static void init_for_each_var (void)
621 for_each_var
= scm_private_variable (scm_the_root_module (),
622 scm_from_latin1_symbol ("for-each"));
626 scm_map (SCM proc
, SCM arg1
, SCM args
)
628 static scm_i_pthread_once_t once
= SCM_I_PTHREAD_ONCE_INIT
;
629 scm_i_pthread_once (&once
, init_map_var
);
631 return scm_apply_0 (scm_variable_ref (map_var
),
632 scm_cons (proc
, scm_cons (arg1
, args
)));
636 scm_for_each (SCM proc
, SCM arg1
, SCM args
)
638 static scm_i_pthread_once_t once
= SCM_I_PTHREAD_ONCE_INIT
;
639 scm_i_pthread_once (&once
, init_for_each_var
);
641 return scm_apply_0 (scm_variable_ref (for_each_var
),
642 scm_cons (proc
, scm_cons (arg1
, args
)));
647 scm_c_primitive_eval (SCM exp
)
649 if (!SCM_EXPANDED_P (exp
))
650 exp
= scm_call_1 (scm_current_module_transformer (), exp
);
651 return eval (scm_memoize_expression (exp
), SCM_BOOL_F
);
654 static SCM var_primitive_eval
;
656 scm_primitive_eval (SCM exp
)
658 return scm_call_n (scm_variable_ref (var_primitive_eval
),
663 /* Eval does not take the second arg optionally. This is intentional
664 * in order to be R5RS compatible, and to prepare for the new module
665 * system, where we would like to make the choice of evaluation
666 * environment explicit. */
668 SCM_DEFINE (scm_eval
, "eval", 2, 0, 0,
669 (SCM exp
, SCM module_or_state
),
670 "Evaluate @var{exp}, a list representing a Scheme expression,\n"
671 "in the top-level environment specified by\n"
672 "@var{module_or_state}.\n"
673 "While @var{exp} is evaluated (using @code{primitive-eval}),\n"
674 "@var{module_or_state} is made the current module when\n"
675 "it is a module, or the current dynamic state when it is\n"
677 "Example: (eval '(+ 1 2) (interaction-environment))")
678 #define FUNC_NAME s_scm_eval
682 scm_dynwind_begin (SCM_F_DYNWIND_REWINDABLE
);
683 if (scm_is_dynamic_state (module_or_state
))
684 scm_dynwind_current_dynamic_state (module_or_state
);
685 else if (scm_module_system_booted_p
)
687 SCM_VALIDATE_MODULE (2, module_or_state
);
688 scm_dynwind_current_module (module_or_state
);
690 /* otherwise if the module system isn't booted, ignore the module arg */
692 res
= scm_primitive_eval (exp
);
702 /* Apply a function to a list of arguments.
704 This function's interface is a bit wonly. It takes two required
705 arguments and a tail argument, as if it were:
707 (lambda (proc arg1 . args) ...)
709 Usually you want to use scm_apply_0 or one of its cousins. */
712 scm_apply (SCM proc
, SCM arg1
, SCM args
)
714 return scm_apply_0 (proc
,
715 scm_is_null (args
) ? arg1
: scm_cons_star (arg1
, args
));
719 prepare_boot_closure_env_for_apply (SCM proc
, SCM args
,
720 SCM
*out_body
, SCM
*out_env
)
722 int nreq
= BOOT_CLOSURE_NUM_REQUIRED_ARGS (proc
);
723 SCM env
= BOOT_CLOSURE_ENV (proc
);
726 if (BOOT_CLOSURE_IS_FIXED (proc
)
727 || (BOOT_CLOSURE_IS_REST (proc
)
728 && !BOOT_CLOSURE_HAS_REST_ARGS (proc
)))
730 if (SCM_UNLIKELY (scm_ilength (args
) != nreq
))
731 scm_wrong_num_args (proc
);
733 env
= make_env (nreq
, SCM_UNDEFINED
, env
);
734 for (i
= 0; i
< nreq
; args
= CDR (args
), i
++)
735 env_set (env
, 0, i
, CAR (args
));
736 *out_body
= BOOT_CLOSURE_BODY (proc
);
739 else if (BOOT_CLOSURE_IS_REST (proc
))
741 if (SCM_UNLIKELY (scm_ilength (args
) < nreq
))
742 scm_wrong_num_args (proc
);
744 env
= make_env (nreq
+ 1, SCM_UNDEFINED
, env
);
745 for (i
= 0; i
< nreq
; args
= CDR (args
), i
++)
746 env_set (env
, 0, i
, CAR (args
));
747 env_set (env
, 0, i
++, args
);
749 *out_body
= BOOT_CLOSURE_BODY (proc
);
754 int i
, argc
, nreq
, nopt
, ninits
, nenv
;
755 SCM body
, rest
, kw
, unbound
, alt
;
756 SCM mx
= BOOT_CLOSURE_CODE (proc
);
759 BOOT_CLOSURE_PARSE_FULL (mx
, body
, nargs
, rest
, nopt
, kw
,
760 ninits
, unbound
, alt
);
762 argc
= scm_ilength (args
);
765 if (scm_is_true (alt
))
771 scm_wrong_num_args (proc
);
773 if (scm_is_false (kw
) && argc
> nreq
+ nopt
&& scm_is_false (rest
))
775 if (scm_is_true (alt
))
781 scm_wrong_num_args (proc
);
783 if (scm_is_true (kw
) && scm_is_false (rest
))
787 for (walk
= args
; scm_is_pair (walk
); walk
= CDR (walk
), npos
++)
788 if (npos
>= nreq
&& scm_is_keyword (CAR (walk
)))
791 if (npos
> nreq
+ nopt
)
793 /* Too many positional args and no rest arg. */
794 if (scm_is_true (alt
))
800 scm_wrong_num_args (proc
);
804 /* At this point we are committed to the chosen clause. */
805 nenv
= nreq
+ (scm_is_true (rest
) ? 1 : 0) + ninits
;
806 env
= make_env (nenv
, unbound
, env
);
808 for (i
= 0; i
< nreq
; i
++, args
= CDR (args
))
809 env_set (env
, 0, i
, CAR (args
));
811 if (scm_is_false (kw
))
813 /* Optional args (possibly), but no keyword args. */
814 for (; i
< argc
&& i
< nreq
+ nopt
; i
++, args
= CDR (args
))
815 env_set (env
, 0, i
, CAR (args
));
816 if (scm_is_true (rest
))
817 env_set (env
, 0, nreq
+ nopt
, args
);
826 /* Optional args. As before, but stop at the first keyword. */
827 for (; i
< argc
&& i
< nreq
+ nopt
&& !scm_is_keyword (CAR (args
));
828 i
++, args
= CDR (args
))
829 env_set (env
, 0, i
, CAR (args
));
830 if (scm_is_true (rest
))
831 env_set (env
, 0, nreq
+ nopt
, args
);
833 /* Parse keyword args. */
837 if (scm_is_pair (args
) && scm_is_pair (CDR (args
)))
838 for (; scm_is_pair (args
) && scm_is_pair (CDR (args
));
841 SCM k
= CAR (args
), v
= CADR (args
);
842 if (!scm_is_keyword (k
))
844 if (scm_is_true (rest
))
849 for (walk
= kw
; scm_is_pair (walk
); walk
= CDR (walk
))
850 if (scm_is_eq (k
, CAAR (walk
)))
852 env_set (env
, 0, SCM_I_INUM (CDAR (walk
)), v
);
856 if (scm_is_null (walk
) && scm_is_false (aok
))
857 error_unrecognized_keyword (proc
, k
);
859 if (scm_is_pair (args
) && scm_is_false (rest
))
860 error_invalid_keyword (proc
, CAR (args
));
870 prepare_boot_closure_env_for_eval (SCM proc
, unsigned int argc
,
871 SCM exps
, SCM
*out_body
, SCM
*inout_env
)
873 int nreq
= BOOT_CLOSURE_NUM_REQUIRED_ARGS (proc
);
874 SCM new_env
= BOOT_CLOSURE_ENV (proc
);
875 if ((BOOT_CLOSURE_IS_FIXED (proc
)
876 || (BOOT_CLOSURE_IS_REST (proc
)
877 && !BOOT_CLOSURE_HAS_REST_ARGS (proc
)))
882 new_env
= make_env (nreq
, SCM_UNDEFINED
, new_env
);
883 for (i
= 0; i
< nreq
; exps
= CDR (exps
), i
++)
884 env_set (new_env
, 0, i
, EVAL1 (CAR (exps
), *inout_env
));
886 *out_body
= BOOT_CLOSURE_BODY (proc
);
887 *inout_env
= new_env
;
889 else if (BOOT_CLOSURE_IS_REST (proc
) && argc
>= nreq
)
894 new_env
= make_env (nreq
+ 1, SCM_UNDEFINED
, new_env
);
895 for (i
= 0; i
< nreq
; exps
= CDR (exps
), i
++)
896 env_set (new_env
, 0, i
, EVAL1 (CAR (exps
), *inout_env
));
897 for (rest
= SCM_EOL
; scm_is_pair (exps
); exps
= CDR (exps
))
898 rest
= scm_cons (EVAL1 (CAR (exps
), *inout_env
), rest
);
899 env_set (new_env
, 0, i
++, scm_reverse_x (rest
, SCM_UNDEFINED
));
901 *out_body
= BOOT_CLOSURE_BODY (proc
);
902 *inout_env
= new_env
;
907 for (; scm_is_pair (exps
); exps
= CDR (exps
))
908 args
= scm_cons (EVAL1 (CAR (exps
), *inout_env
), args
);
909 args
= scm_reverse_x (args
, SCM_UNDEFINED
);
910 prepare_boot_closure_env_for_apply (proc
, args
, out_body
, inout_env
);
915 boot_closure_apply (SCM closure
, SCM args
)
918 prepare_boot_closure_env_for_apply (closure
, args
, &body
, &env
);
919 return eval (body
, env
);
923 boot_closure_print (SCM closure
, SCM port
, scm_print_state
*pstate
)
926 scm_puts_unlocked ("#<boot-closure ", port
);
927 scm_uintprint (SCM_UNPACK (closure
), 16, port
);
928 scm_putc_unlocked (' ', port
);
929 args
= scm_make_list (scm_from_int (BOOT_CLOSURE_NUM_REQUIRED_ARGS (closure
)),
930 scm_from_latin1_symbol ("_"));
931 if (!BOOT_CLOSURE_IS_FIXED (closure
) && BOOT_CLOSURE_HAS_REST_ARGS (closure
))
932 args
= scm_cons_star (scm_from_latin1_symbol ("_"), args
);
933 /* FIXME: optionals and rests */
934 scm_display (args
, port
);
935 scm_putc_unlocked ('>', port
);
944 f_apply
= scm_c_define_gsubr ("apply", 2, 0, 1, scm_apply
);
946 scm_tc16_boot_closure
= scm_make_smob_type ("boot-closure", 0);
947 scm_set_smob_apply (scm_tc16_boot_closure
, boot_closure_apply
, 0, 0, 1);
948 scm_set_smob_print (scm_tc16_boot_closure
, boot_closure_print
);
950 primitive_eval
= scm_c_make_gsubr ("primitive-eval", 1, 0, 0,
951 scm_c_primitive_eval
);
952 var_primitive_eval
= scm_define (SCM_SUBR_NAME (primitive_eval
),
955 #include "libguile/eval.x"