1 /* Copyright (C) 1995,1996,1997,1998,1999,2000,2001,2002,2003,2004,
2 * 2005,2006,2007,2008,2009,2010,2011,2012,2013
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,inits,alt) \
121 body = CAR (fu); fu = CDDR (fu); \
123 rest = kw = alt = 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 inits = CAR (fu); fu = CDR (fu); \
140 static void prepare_boot_closure_env_for_apply (SCM proc
, SCM args
,
141 SCM
*out_body
, SCM
*out_env
);
142 static void prepare_boot_closure_env_for_eval (SCM proc
, unsigned int argc
,
143 SCM exps
, SCM
*out_body
,
147 #define CAR(x) SCM_CAR(x)
148 #define CDR(x) SCM_CDR(x)
149 #define CAAR(x) SCM_CAAR(x)
150 #define CADR(x) SCM_CADR(x)
151 #define CDAR(x) SCM_CDAR(x)
152 #define CDDR(x) SCM_CDDR(x)
153 #define CADDR(x) SCM_CADDR(x)
154 #define CDDDR(x) SCM_CDDDR(x)
156 #define VECTOR_REF(v, i) (SCM_SIMPLE_VECTOR_REF (v, i))
157 #define VECTOR_SET(v, i, x) (SCM_SIMPLE_VECTOR_SET (v, i, x))
158 #define VECTOR_LENGTH(v) (SCM_SIMPLE_VECTOR_LENGTH (v))
161 make_env (int n
, SCM init
, SCM next
)
163 SCM env
= scm_c_make_vector (n
+ 1, init
);
164 VECTOR_SET (env
, 0, next
);
171 return VECTOR_REF (env
, 0);
177 while (SCM_I_IS_VECTOR (env
))
178 env
= next_rib (env
);
183 env_ref (SCM env
, int depth
, int width
)
186 env
= next_rib (env
);
187 return VECTOR_REF (env
, width
+ 1);
191 env_set (SCM env
, int depth
, int width
, SCM val
)
194 env
= next_rib (env
);
195 VECTOR_SET (env
, width
+ 1, val
);
199 SCM_SYMBOL (scm_unbound_variable_key
, "unbound-variable");
201 static void error_used_before_defined (void)
203 scm_error (scm_unbound_variable_key
, NULL
,
204 "Variable used before given a value", SCM_EOL
, SCM_BOOL_F
);
207 static void error_invalid_keyword (SCM proc
, SCM obj
)
209 scm_error_scm (scm_from_latin1_symbol ("keyword-argument-error"), proc
,
210 scm_from_locale_string ("Invalid keyword"), SCM_EOL
,
214 static void error_unrecognized_keyword (SCM proc
, SCM kw
)
216 scm_error_scm (scm_from_latin1_symbol ("keyword-argument-error"), proc
,
217 scm_from_locale_string ("Unrecognized keyword"), SCM_EOL
,
222 /* Multiple values truncation. */
224 truncate_values (SCM x
)
226 if (SCM_LIKELY (!SCM_VALUESP (x
)))
230 SCM l
= scm_struct_ref (x
, SCM_INUM0
);
231 if (SCM_LIKELY (scm_is_pair (l
)))
235 scm_ithrow (scm_from_latin1_symbol ("vm-run"),
236 scm_list_3 (scm_from_latin1_symbol ("vm-run"),
237 scm_from_locale_string
238 ("Too few values returned to continuation"),
246 #define EVAL1(x, env) (truncate_values (eval ((x), (env))))
249 eval (SCM x
, SCM env
)
252 SCM proc
= SCM_UNDEFINED
, args
= SCM_EOL
;
258 mx
= SCM_MEMOIZED_ARGS (x
);
259 switch (SCM_I_INUM (SCM_CAR (x
)))
262 eval (CAR (mx
), env
);
267 if (scm_is_true (EVAL1 (CAR (mx
), env
)))
275 SCM inits
= CAR (mx
);
279 new_env
= make_env (VECTOR_LENGTH (inits
), SCM_UNDEFINED
, env
);
280 for (i
= 0; i
< VECTOR_LENGTH (inits
); i
++)
281 env_set (new_env
, 0, i
, EVAL1 (VECTOR_REF (inits
, i
), env
));
288 RETURN_BOOT_CLOSURE (mx
, env
);
294 scm_define (CAR (mx
), EVAL1 (CDR (mx
), env
));
295 return SCM_UNSPECIFIED
;
297 case SCM_M_CAPTURE_MODULE
:
298 return eval (mx
, scm_current_module ());
301 /* Evaluate the procedure to be applied. */
302 proc
= EVAL1 (CAR (mx
), env
);
303 /* Evaluate the argument holding the list of arguments */
304 args
= EVAL1 (CADR (mx
), env
);
307 /* Go here to tail-apply a procedure. PROC is the procedure and
308 * ARGS is the list of arguments. */
309 if (BOOT_CLOSURE_P (proc
))
311 prepare_boot_closure_env_for_apply (proc
, args
, &x
, &env
);
315 return scm_apply_0 (proc
, args
);
318 /* Evaluate the procedure to be applied. */
319 proc
= EVAL1 (CAR (mx
), env
);
320 argc
= SCM_I_INUM (CADR (mx
));
323 if (BOOT_CLOSURE_P (proc
))
325 prepare_boot_closure_env_for_eval (proc
, argc
, mx
, &x
, &env
);
333 argv
= alloca (argc
* sizeof (SCM
));
334 for (i
= 0; i
< argc
; i
++, mx
= CDR (mx
))
335 argv
[i
] = EVAL1 (CAR (mx
), env
);
337 return scm_c_vm_run (scm_the_vm (), proc
, argv
, argc
);
341 return scm_i_call_with_current_continuation (EVAL1 (mx
, env
));
343 case SCM_M_CALL_WITH_VALUES
:
348 producer
= EVAL1 (CAR (mx
), env
);
349 /* `proc' is the consumer. */
350 proc
= EVAL1 (CDR (mx
), env
);
351 v
= scm_call_0 (producer
);
353 args
= scm_struct_ref (v
, SCM_INUM0
);
355 args
= scm_list_1 (v
);
359 case SCM_M_LEXICAL_REF
:
365 depth
= SCM_I_INUM (CAR (pos
));
366 width
= SCM_I_INUM (CDR (pos
));
368 ret
= env_ref (env
, depth
, width
);
370 if (SCM_UNLIKELY (SCM_UNBNDP (ret
)))
371 /* we don't know what variable, though, because we don't have its
373 error_used_before_defined ();
377 case SCM_M_LEXICAL_SET
:
381 SCM val
= EVAL1 (CDR (mx
), env
);
384 depth
= SCM_I_INUM (CAR (pos
));
385 width
= SCM_I_INUM (CDR (pos
));
387 env_set (env
, depth
, width
, val
);
389 return SCM_UNSPECIFIED
;
392 case SCM_M_TOPLEVEL_REF
:
393 if (SCM_VARIABLEP (mx
))
394 return SCM_VARIABLE_REF (mx
);
397 env
= env_tail (env
);
398 return SCM_VARIABLE_REF (scm_memoize_variable_access_x (x
, env
));
401 case SCM_M_TOPLEVEL_SET
:
404 SCM val
= EVAL1 (CDR (mx
), env
);
405 if (SCM_VARIABLEP (var
))
407 SCM_VARIABLE_SET (var
, val
);
408 return SCM_UNSPECIFIED
;
412 env
= env_tail (env
);
413 SCM_VARIABLE_SET (scm_memoize_variable_access_x (x
, env
), val
);
414 return SCM_UNSPECIFIED
;
418 case SCM_M_MODULE_REF
:
419 if (SCM_VARIABLEP (mx
))
420 return SCM_VARIABLE_REF (mx
);
422 return SCM_VARIABLE_REF
423 (scm_memoize_variable_access_x (x
, SCM_BOOL_F
));
425 case SCM_M_MODULE_SET
:
426 if (SCM_VARIABLEP (CDR (mx
)))
428 SCM_VARIABLE_SET (CDR (mx
), EVAL1 (CAR (mx
), env
));
429 return SCM_UNSPECIFIED
;
434 (scm_memoize_variable_access_x (x
, SCM_BOOL_F
),
435 EVAL1 (CAR (mx
), env
));
436 return SCM_UNSPECIFIED
;
439 case SCM_M_CALL_WITH_PROMPT
:
442 scm_i_jmp_buf registers
;
443 /* We need the handler after nonlocal return to the setjmp, so
444 make sure it is volatile. */
445 volatile SCM handler
;
447 k
= EVAL1 (CAR (mx
), env
);
448 handler
= EVAL1 (CDDR (mx
), env
);
451 /* Push the prompt onto the dynamic stack. */
452 scm_dynstack_push_prompt
453 (&SCM_I_CURRENT_THREAD
->dynstack
,
454 SCM_F_DYNSTACK_PROMPT_ESCAPE_ONLY
| SCM_F_DYNSTACK_PROMPT_PUSH_NARGS
,
456 SCM_VM_DATA (vm
)->fp
- SCM_VM_DATA (vm
)->stack_base
,
457 SCM_VM_DATA (vm
)->sp
- SCM_VM_DATA (vm
)->stack_base
,
458 SCM_VM_DATA (vm
)->ip
,
461 if (SCM_I_SETJMP (registers
))
463 /* The prompt exited nonlocally. */
465 args
= scm_i_prompt_pop_abort_args_x (scm_the_vm ());
469 res
= scm_call_0 (eval (CADR (mx
), env
));
470 scm_dynstack_pop (&SCM_I_CURRENT_THREAD
->dynstack
);
481 /* Simple procedure calls
485 scm_call_0 (SCM proc
)
487 return scm_c_vm_run (scm_the_vm (), proc
, NULL
, 0);
491 scm_call_1 (SCM proc
, SCM arg1
)
493 return scm_c_vm_run (scm_the_vm (), proc
, &arg1
, 1);
497 scm_call_2 (SCM proc
, SCM arg1
, SCM arg2
)
499 SCM args
[] = { arg1
, arg2
};
500 return scm_c_vm_run (scm_the_vm (), proc
, args
, 2);
504 scm_call_3 (SCM proc
, SCM arg1
, SCM arg2
, SCM arg3
)
506 SCM args
[] = { arg1
, arg2
, arg3
};
507 return scm_c_vm_run (scm_the_vm (), proc
, args
, 3);
511 scm_call_4 (SCM proc
, SCM arg1
, SCM arg2
, SCM arg3
, SCM arg4
)
513 SCM args
[] = { arg1
, arg2
, arg3
, arg4
};
514 return scm_c_vm_run (scm_the_vm (), proc
, args
, 4);
518 scm_call_5 (SCM proc
, SCM arg1
, SCM arg2
, SCM arg3
, SCM arg4
, SCM arg5
)
520 SCM args
[] = { arg1
, arg2
, arg3
, arg4
, arg5
};
521 return scm_c_vm_run (scm_the_vm (), proc
, args
, 5);
525 scm_call_6 (SCM proc
, SCM arg1
, SCM arg2
, SCM arg3
, SCM arg4
, SCM arg5
,
528 SCM args
[] = { arg1
, arg2
, arg3
, arg4
, arg5
, arg6
};
529 return scm_c_vm_run (scm_the_vm (), proc
, args
, 6);
533 scm_call_7 (SCM proc
, SCM arg1
, SCM arg2
, SCM arg3
, SCM arg4
, SCM arg5
,
536 SCM args
[] = { arg1
, arg2
, arg3
, arg4
, arg5
, arg6
, arg7
};
537 return scm_c_vm_run (scm_the_vm (), proc
, args
, 7);
541 scm_call_8 (SCM proc
, SCM arg1
, SCM arg2
, SCM arg3
, SCM arg4
, SCM arg5
,
542 SCM arg6
, SCM arg7
, SCM arg8
)
544 SCM args
[] = { arg1
, arg2
, arg3
, arg4
, arg5
, arg6
, arg7
, arg8
};
545 return scm_c_vm_run (scm_the_vm (), proc
, args
, 8);
549 scm_call_9 (SCM proc
, SCM arg1
, SCM arg2
, SCM arg3
, SCM arg4
, SCM arg5
,
550 SCM arg6
, SCM arg7
, SCM arg8
, SCM arg9
)
552 SCM args
[] = { arg1
, arg2
, arg3
, arg4
, arg5
, arg6
, arg7
, arg8
, arg9
};
553 return scm_c_vm_run (scm_the_vm (), proc
, args
, 9);
557 scm_call_n (SCM proc
, SCM
*argv
, size_t nargs
)
559 return scm_c_vm_run (scm_the_vm (), proc
, argv
, nargs
);
563 scm_call (SCM proc
, ...)
569 va_start (argp
, proc
);
570 while (!SCM_UNBNDP (va_arg (argp
, SCM
)))
574 argv
= alloca (nargs
* sizeof (SCM
));
575 va_start (argp
, proc
);
576 for (i
= 0; i
< nargs
; i
++)
577 argv
[i
] = va_arg (argp
, SCM
);
580 return scm_c_vm_run (scm_the_vm (), proc
, argv
, nargs
);
583 /* Simple procedure applies
587 scm_apply_0 (SCM proc
, SCM args
)
592 nargs
= scm_ilength (args
);
593 if (SCM_UNLIKELY (nargs
< 0))
594 scm_wrong_type_arg_msg ("apply", 2, args
, "list");
596 /* FIXME: Use vm_builtin_apply instead of alloca. */
597 argv
= alloca (nargs
* sizeof(SCM
));
598 for (i
= 0; i
< nargs
; i
++)
600 argv
[i
] = SCM_CAR (args
);
601 args
= SCM_CDR (args
);
604 return scm_c_vm_run (scm_the_vm (), proc
, argv
, nargs
);
608 scm_apply_1 (SCM proc
, SCM arg1
, SCM args
)
610 return scm_apply_0 (proc
, scm_cons (arg1
, args
));
614 scm_apply_2 (SCM proc
, SCM arg1
, SCM arg2
, SCM args
)
616 return scm_apply_0 (proc
, scm_cons2 (arg1
, arg2
, args
));
620 scm_apply_3 (SCM proc
, SCM arg1
, SCM arg2
, SCM arg3
, SCM args
)
622 return scm_apply_0 (proc
, scm_cons (arg1
, scm_cons2 (arg2
, arg3
, args
)));
627 scm_map (SCM proc
, SCM arg1
, SCM args
)
629 static SCM var
= SCM_BOOL_F
;
631 if (scm_is_false (var
))
632 var
= scm_private_variable (scm_the_root_module (),
633 scm_from_latin1_symbol ("map"));
635 return scm_apply_0 (scm_variable_ref (var
),
636 scm_cons (proc
, scm_cons (arg1
, args
)));
640 scm_for_each (SCM proc
, SCM arg1
, SCM args
)
642 static SCM var
= SCM_BOOL_F
;
644 if (scm_is_false (var
))
645 var
= scm_private_variable (scm_the_root_module (),
646 scm_from_latin1_symbol ("for-each"));
648 return scm_apply_0 (scm_variable_ref (var
),
649 scm_cons (proc
, scm_cons (arg1
, args
)));
654 scm_c_primitive_eval (SCM exp
)
656 if (!SCM_EXPANDED_P (exp
))
657 exp
= scm_call_1 (scm_current_module_transformer (), exp
);
658 return eval (scm_memoize_expression (exp
), SCM_BOOL_F
);
661 static SCM var_primitive_eval
;
663 scm_primitive_eval (SCM exp
)
665 return scm_c_vm_run (scm_the_vm (), scm_variable_ref (var_primitive_eval
),
670 /* Eval does not take the second arg optionally. This is intentional
671 * in order to be R5RS compatible, and to prepare for the new module
672 * system, where we would like to make the choice of evaluation
673 * environment explicit. */
675 SCM_DEFINE (scm_eval
, "eval", 2, 0, 0,
676 (SCM exp
, SCM module_or_state
),
677 "Evaluate @var{exp}, a list representing a Scheme expression,\n"
678 "in the top-level environment specified by\n"
679 "@var{module_or_state}.\n"
680 "While @var{exp} is evaluated (using @code{primitive-eval}),\n"
681 "@var{module_or_state} is made the current module when\n"
682 "it is a module, or the current dynamic state when it is\n"
684 "Example: (eval '(+ 1 2) (interaction-environment))")
685 #define FUNC_NAME s_scm_eval
689 scm_dynwind_begin (SCM_F_DYNWIND_REWINDABLE
);
690 if (scm_is_dynamic_state (module_or_state
))
691 scm_dynwind_current_dynamic_state (module_or_state
);
692 else if (scm_module_system_booted_p
)
694 SCM_VALIDATE_MODULE (2, module_or_state
);
695 scm_dynwind_current_module (module_or_state
);
697 /* otherwise if the module system isn't booted, ignore the module arg */
699 res
= scm_primitive_eval (exp
);
709 /* Apply a function to a list of arguments.
711 This function's interface is a bit wonly. It takes two required
712 arguments and a tail argument, as if it were:
714 (lambda (proc arg1 . args) ...)
716 Usually you want to use scm_apply_0 or one of its cousins. */
719 scm_apply (SCM proc
, SCM arg1
, SCM args
)
721 return scm_apply_0 (proc
,
722 scm_is_null (args
) ? arg1
: scm_cons_star (arg1
, args
));
726 prepare_boot_closure_env_for_apply (SCM proc
, SCM args
,
727 SCM
*out_body
, SCM
*out_env
)
729 int nreq
= BOOT_CLOSURE_NUM_REQUIRED_ARGS (proc
);
730 SCM env
= BOOT_CLOSURE_ENV (proc
);
733 if (BOOT_CLOSURE_IS_FIXED (proc
)
734 || (BOOT_CLOSURE_IS_REST (proc
)
735 && !BOOT_CLOSURE_HAS_REST_ARGS (proc
)))
737 if (SCM_UNLIKELY (scm_ilength (args
) != nreq
))
738 scm_wrong_num_args (proc
);
740 env
= make_env (nreq
, SCM_UNDEFINED
, env
);
741 for (i
= 0; i
< nreq
; args
= CDR (args
), i
++)
742 env_set (env
, 0, i
, CAR (args
));
743 *out_body
= BOOT_CLOSURE_BODY (proc
);
746 else if (BOOT_CLOSURE_IS_REST (proc
))
748 if (SCM_UNLIKELY (scm_ilength (args
) < nreq
))
749 scm_wrong_num_args (proc
);
751 env
= make_env (nreq
+ 1, SCM_UNDEFINED
, env
);
752 for (i
= 0; i
< nreq
; args
= CDR (args
), i
++)
753 env_set (env
, 0, i
, CAR (args
));
754 env_set (env
, 0, i
++, args
);
756 *out_body
= BOOT_CLOSURE_BODY (proc
);
761 int i
, argc
, nreq
, nopt
, nenv
;
762 SCM body
, rest
, kw
, inits
, alt
;
763 SCM mx
= BOOT_CLOSURE_CODE (proc
);
766 BOOT_CLOSURE_PARSE_FULL (mx
, body
, nargs
, rest
, nopt
, kw
, inits
, alt
);
768 argc
= scm_ilength (args
);
771 if (scm_is_true (alt
))
777 scm_wrong_num_args (proc
);
779 if (scm_is_false (kw
) && argc
> nreq
+ nopt
&& scm_is_false (rest
))
781 if (scm_is_true (alt
))
787 scm_wrong_num_args (proc
);
789 if (scm_is_true (kw
) && scm_is_false (rest
))
793 for (walk
= args
; scm_is_pair (walk
); walk
= CDR (walk
), npos
++)
794 if (npos
>= nreq
&& scm_is_keyword (CAR (walk
)))
797 if (npos
> nreq
+ nopt
)
799 /* Too many positional args and no rest arg. */
800 if (scm_is_true (alt
))
806 scm_wrong_num_args (proc
);
810 /* At this point we are committed to the chosen clause. */
811 nenv
= nreq
+ (scm_is_true (rest
) ? 1 : 0) + scm_ilength (inits
);
812 env
= make_env (nenv
, SCM_UNDEFINED
, env
);
814 for (i
= 0; i
< nreq
; i
++, args
= CDR (args
))
815 env_set (env
, 0, i
, CAR (args
));
817 if (scm_is_false (kw
))
819 /* Optional args (possibly), but no keyword args. */
820 for (; i
< argc
&& i
< nreq
+ nopt
;
821 i
++, args
= CDR (args
), inits
= CDR (inits
))
822 env_set (env
, 0, i
, CAR (args
));
824 for (; i
< nreq
+ nopt
; i
++, inits
= CDR (inits
))
825 env_set (env
, 0, i
, EVAL1 (CAR (inits
), env
));
827 if (scm_is_true (rest
))
828 env_set (env
, 0, i
++, args
);
837 /* Optional args. As before, but stop at the first keyword. */
838 for (; i
< argc
&& i
< nreq
+ nopt
&& !scm_is_keyword (CAR (args
));
839 i
++, args
= CDR (args
), inits
= CDR (inits
))
840 env_set (env
, 0, i
, CAR (args
));
842 for (; i
< nreq
+ nopt
; i
++, inits
= CDR (inits
))
843 env_set (env
, 0, i
, EVAL1 (CAR (inits
), env
));
845 if (scm_is_true (rest
))
846 env_set (env
, 0, i
++, args
);
848 /* Parse keyword args. */
850 int kw_start_idx
= i
;
853 if (scm_is_pair (args
) && scm_is_pair (CDR (args
)))
854 for (; scm_is_pair (args
) && scm_is_pair (CDR (args
));
857 SCM k
= CAR (args
), v
= CADR (args
);
858 if (!scm_is_keyword (k
))
860 if (scm_is_true (rest
))
865 for (walk
= kw
; scm_is_pair (walk
); walk
= CDR (walk
))
866 if (scm_is_eq (k
, CAAR (walk
)))
868 env_set (env
, 0, SCM_I_INUM (CDAR (walk
)), v
);
872 if (scm_is_null (walk
) && scm_is_false (aok
))
873 error_unrecognized_keyword (proc
, k
);
875 if (scm_is_pair (args
) && scm_is_false (rest
))
876 error_invalid_keyword (proc
, CAR (args
));
878 /* Now fill in unbound values, evaluating init expressions in their
879 appropriate environment. */
880 for (i
= kw_start_idx
; scm_is_pair (inits
); i
++, inits
= CDR (inits
))
881 if (SCM_UNBNDP (env_ref (env
, 0, i
)))
882 env_set (env
, 0, i
, EVAL1 (CAR (inits
), env
));
886 if (!scm_is_null (inits
))
897 prepare_boot_closure_env_for_eval (SCM proc
, unsigned int argc
,
898 SCM exps
, SCM
*out_body
, SCM
*inout_env
)
900 int nreq
= BOOT_CLOSURE_NUM_REQUIRED_ARGS (proc
);
901 SCM new_env
= BOOT_CLOSURE_ENV (proc
);
902 if ((BOOT_CLOSURE_IS_FIXED (proc
)
903 || (BOOT_CLOSURE_IS_REST (proc
)
904 && !BOOT_CLOSURE_HAS_REST_ARGS (proc
)))
909 new_env
= make_env (nreq
, 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
));
913 *out_body
= BOOT_CLOSURE_BODY (proc
);
914 *inout_env
= new_env
;
916 else if (BOOT_CLOSURE_IS_REST (proc
) && argc
>= nreq
)
921 new_env
= make_env (nreq
+ 1, SCM_UNDEFINED
, new_env
);
922 for (i
= 0; i
< nreq
; exps
= CDR (exps
), i
++)
923 env_set (new_env
, 0, i
, EVAL1 (CAR (exps
), *inout_env
));
924 for (rest
= SCM_EOL
; scm_is_pair (exps
); exps
= CDR (exps
))
925 rest
= scm_cons (EVAL1 (CAR (exps
), *inout_env
), rest
);
926 env_set (new_env
, 0, i
++, scm_reverse_x (rest
, SCM_UNDEFINED
));
928 *out_body
= BOOT_CLOSURE_BODY (proc
);
929 *inout_env
= new_env
;
934 for (; scm_is_pair (exps
); exps
= CDR (exps
))
935 args
= scm_cons (EVAL1 (CAR (exps
), *inout_env
), args
);
936 args
= scm_reverse_x (args
, SCM_UNDEFINED
);
937 prepare_boot_closure_env_for_apply (proc
, args
, out_body
, inout_env
);
942 boot_closure_apply (SCM closure
, SCM args
)
945 prepare_boot_closure_env_for_apply (closure
, args
, &body
, &env
);
946 return eval (body
, env
);
950 boot_closure_print (SCM closure
, SCM port
, scm_print_state
*pstate
)
953 scm_puts_unlocked ("#<boot-closure ", port
);
954 scm_uintprint (SCM_UNPACK (closure
), 16, port
);
955 scm_putc_unlocked (' ', port
);
956 args
= scm_make_list (scm_from_int (BOOT_CLOSURE_NUM_REQUIRED_ARGS (closure
)),
957 scm_from_latin1_symbol ("_"));
958 if (!BOOT_CLOSURE_IS_FIXED (closure
) && BOOT_CLOSURE_HAS_REST_ARGS (closure
))
959 args
= scm_cons_star (scm_from_latin1_symbol ("_"), args
);
960 /* FIXME: optionals and rests */
961 scm_display (args
, port
);
962 scm_putc_unlocked ('>', port
);
971 f_apply
= scm_c_define_gsubr ("apply", 2, 0, 1, scm_apply
);
973 scm_tc16_boot_closure
= scm_make_smob_type ("boot-closure", 0);
974 scm_set_smob_apply (scm_tc16_boot_closure
, boot_closure_apply
, 0, 0, 1);
975 scm_set_smob_print (scm_tc16_boot_closure
, boot_closure_print
);
977 primitive_eval
= scm_c_make_gsubr ("primitive-eval", 1, 0, 0,
978 scm_c_primitive_eval
);
979 var_primitive_eval
= scm_define (SCM_SUBR_NAME (primitive_eval
),
982 #include "libguile/eval.x"