1 /* Copyright (C) 1995,1996,1997,1998,1999,2000,2001,2002,2003,2004,2005,2006,2007,2008,2009,2010,2011
2 * Free Software Foundation, Inc.
4 * This library is free software; you can redistribute it and/or
5 * modify it under the terms of the GNU Lesser General Public License
6 * as published by the Free Software Foundation; either version 3 of
7 * the License, or (at your option) any later version.
9 * This library is distributed in the hope that it will be useful, but
10 * WITHOUT ANY WARRANTY; without even the implied warranty of
11 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
12 * Lesser General Public License for more details.
14 * You should have received a copy of the GNU Lesser General Public
15 * License along with this library; if not, write to the Free Software
16 * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
28 #include "libguile/__scm.h"
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/fluids.h"
42 #include "libguile/goops.h"
43 #include "libguile/hash.h"
44 #include "libguile/hashtab.h"
45 #include "libguile/list.h"
46 #include "libguile/macros.h"
47 #include "libguile/memoize.h"
48 #include "libguile/modules.h"
49 #include "libguile/ports.h"
50 #include "libguile/print.h"
51 #include "libguile/procprop.h"
52 #include "libguile/programs.h"
53 #include "libguile/root.h"
54 #include "libguile/smob.h"
55 #include "libguile/srcprop.h"
56 #include "libguile/stackchk.h"
57 #include "libguile/strings.h"
58 #include "libguile/threads.h"
59 #include "libguile/throw.h"
60 #include "libguile/validate.h"
61 #include "libguile/values.h"
62 #include "libguile/vectors.h"
63 #include "libguile/vm.h"
65 #include "libguile/eval.h"
66 #include "libguile/private-options.h"
71 /* We have three levels of EVAL here:
75 evaluates EXP in environment ENV. ENV is a lexical environment
76 structure as used by the actual tree code evaluator. When ENV is
77 a top-level environment, then changes to the current module are
78 tracked by updating ENV so that it continues to be in sync with
81 - scm_primitive_eval (exp)
83 evaluates EXP in the top-level environment as determined by the
84 current module. This is done by constructing a suitable
85 environment and calling eval. Thus, changes to the
86 top-level module are tracked normally.
90 evaluates EXP while MOD is the current module. This is done
91 by setting the current module to MOD_OR_STATE, invoking
92 scm_primitive_eval on EXP, and then restoring the current module
93 to the value it had previously. That is, while EXP is evaluated,
94 changes to the current module (or dynamic state) are tracked,
95 but these changes do not persist when scm_eval returns.
100 /* Boot closures. We only see these when compiling eval.scm, because once
101 eval.scm is in the house, closures are standard VM closures.
104 static scm_t_bits scm_tc16_boot_closure
;
105 #define RETURN_BOOT_CLOSURE(code, env) \
106 SCM_RETURN_NEWSMOB2 (scm_tc16_boot_closure, SCM_UNPACK (code), SCM_UNPACK (env))
107 #define BOOT_CLOSURE_P(obj) SCM_TYP16_PREDICATE (scm_tc16_boot_closure, (obj))
108 #define BOOT_CLOSURE_CODE(x) SCM_SMOB_OBJECT (x)
109 #define BOOT_CLOSURE_ENV(x) SCM_SMOB_OBJECT_2 (x)
110 #define BOOT_CLOSURE_BODY(x) CAR (BOOT_CLOSURE_CODE (x))
111 #define BOOT_CLOSURE_NUM_REQUIRED_ARGS(x) SCM_I_INUM (CADR (BOOT_CLOSURE_CODE (x)))
112 #define BOOT_CLOSURE_IS_FIXED(x) scm_is_null (CDDR (BOOT_CLOSURE_CODE (x)))
113 /* NB: One may only call the following accessors if the closure is not FIXED. */
114 #define BOOT_CLOSURE_HAS_REST_ARGS(x) scm_is_true (CADDR (BOOT_CLOSURE_CODE (x)))
115 #define BOOT_CLOSURE_IS_REST(x) scm_is_null (CDDDR (BOOT_CLOSURE_CODE (x)))
116 /* NB: One may only call the following accessors if the closure is not REST. */
117 #define BOOT_CLOSURE_IS_FULL(x) (1)
118 #define BOOT_CLOSURE_PARSE_FULL(fu_,body,nargs,rest,nopt,kw,inits,alt) \
120 body = CAR (fu); fu = CDR (fu); \
122 rest = kw = alt = SCM_BOOL_F; \
126 nreq = SCM_I_INUM (CAR (fu)); fu = CDR (fu); \
127 if (scm_is_pair (fu)) \
129 rest = CAR (fu); fu = CDR (fu); \
130 if (scm_is_pair (fu)) \
132 nopt = SCM_I_INUM (CAR (fu)); fu = CDR (fu); \
133 kw = CAR (fu); fu = CDR (fu); \
134 inits = CAR (fu); fu = CDR (fu); \
139 static void prepare_boot_closure_env_for_apply (SCM proc
, SCM args
,
140 SCM
*out_body
, SCM
*out_env
);
141 static void prepare_boot_closure_env_for_eval (SCM proc
, unsigned int argc
,
142 SCM exps
, SCM
*out_body
,
146 #define CAR(x) SCM_CAR(x)
147 #define CDR(x) SCM_CDR(x)
148 #define CAAR(x) SCM_CAAR(x)
149 #define CADR(x) SCM_CADR(x)
150 #define CDAR(x) SCM_CDAR(x)
151 #define CDDR(x) SCM_CDDR(x)
152 #define CADDR(x) SCM_CADDR(x)
153 #define CDDDR(x) SCM_CDDDR(x)
156 SCM_SYMBOL (scm_unbound_variable_key
, "unbound-variable");
158 static void error_used_before_defined (void)
160 scm_error (scm_unbound_variable_key
, NULL
,
161 "Variable used before given a value", SCM_EOL
, SCM_BOOL_F
);
164 static void error_invalid_keyword (SCM proc
)
166 scm_error_scm (scm_from_latin1_symbol ("keyword-argument-error"), proc
,
167 scm_from_locale_string ("Invalid keyword"), SCM_EOL
,
171 static void error_unrecognized_keyword (SCM proc
)
173 scm_error_scm (scm_from_latin1_symbol ("keyword-argument-error"), proc
,
174 scm_from_locale_string ("Unrecognized keyword"), SCM_EOL
,
179 /* Multiple values truncation. */
181 truncate_values (SCM x
)
183 if (SCM_LIKELY (!SCM_VALUESP (x
)))
187 SCM l
= scm_struct_ref (x
, SCM_INUM0
);
188 if (SCM_LIKELY (scm_is_pair (l
)))
192 scm_ithrow (scm_from_latin1_symbol ("vm-run"),
193 scm_list_3 (scm_from_latin1_symbol ("vm-run"),
194 scm_from_locale_string
195 ("Too few values returned to continuation"),
203 #define EVAL1(x, env) (truncate_values (eval ((x), (env))))
207 If MOD is #f, it means the environment was captured before modules were
209 If MOD is the literal value '(), we are evaluating at the top level, and so
210 should track changes to the current module. You have to be careful in this
211 case, because further lexical contours should capture the current module.
213 #define CAPTURE_ENV(env) \
214 (scm_is_null (env) ? scm_current_module () : \
215 (scm_is_false (env) ? scm_the_root_module () : env))
218 eval (SCM x
, SCM env
)
221 SCM proc
= SCM_UNDEFINED
, args
= SCM_EOL
;
226 if (!SCM_MEMOIZED_P (x
))
229 mx
= SCM_MEMOIZED_ARGS (x
);
230 switch (SCM_MEMOIZED_TAG (x
))
233 for (; !scm_is_null (CDR (mx
)); mx
= CDR (mx
))
234 eval (CAR (mx
), env
);
239 if (scm_is_true (EVAL1 (CAR (mx
), env
)))
247 SCM inits
= CAR (mx
);
248 SCM new_env
= CAPTURE_ENV (env
);
249 for (; scm_is_pair (inits
); inits
= CDR (inits
))
250 new_env
= scm_cons (EVAL1 (CAR (inits
), env
),
258 RETURN_BOOT_CLOSURE (mx
, CAPTURE_ENV (env
));
264 scm_define (CAR (mx
), EVAL1 (CDR (mx
), env
));
265 return SCM_UNSPECIFIED
;
269 SCM in
, out
, res
, old_winds
;
270 in
= EVAL1 (CAR (mx
), env
);
271 out
= EVAL1 (CDDR (mx
), env
);
273 old_winds
= scm_i_dynwinds ();
274 scm_i_set_dynwinds (scm_acons (in
, out
, old_winds
));
275 res
= eval (CADR (mx
), env
);
276 scm_i_set_dynwinds (old_winds
);
281 case SCM_M_WITH_FLUIDS
:
284 SCM
*fluidv
, *valuesv
, walk
, wf
, res
;
285 len
= scm_ilength (CAR (mx
));
286 fluidv
= alloca (sizeof (SCM
)*len
);
287 for (i
= 0, walk
= CAR (mx
); i
< len
; i
++, walk
= CDR (walk
))
288 fluidv
[i
] = EVAL1 (CAR (walk
), env
);
289 valuesv
= alloca (sizeof (SCM
)*len
);
290 for (i
= 0, walk
= CADR (mx
); i
< len
; i
++, walk
= CDR (walk
))
291 valuesv
[i
] = EVAL1 (CAR (walk
), env
);
293 wf
= scm_i_make_with_fluids (len
, fluidv
, valuesv
);
294 scm_i_swap_with_fluids (wf
, SCM_I_CURRENT_THREAD
->dynamic_state
);
295 scm_i_set_dynwinds (scm_cons (wf
, scm_i_dynwinds ()));
296 res
= eval (CDDR (mx
), env
);
297 scm_i_swap_with_fluids (wf
, SCM_I_CURRENT_THREAD
->dynamic_state
);
298 scm_i_set_dynwinds (CDR (scm_i_dynwinds ()));
304 /* Evaluate the procedure to be applied. */
305 proc
= EVAL1 (CAR (mx
), env
);
306 /* Evaluate the argument holding the list of arguments */
307 args
= EVAL1 (CADR (mx
), env
);
310 /* Go here to tail-apply a procedure. PROC is the procedure and
311 * ARGS is the list of arguments. */
312 if (BOOT_CLOSURE_P (proc
))
314 prepare_boot_closure_env_for_apply (proc
, args
, &x
, &env
);
318 return scm_call_with_vm (scm_the_vm (), proc
, args
);
321 /* Evaluate the procedure to be applied. */
322 proc
= EVAL1 (CAR (mx
), env
);
323 argc
= SCM_I_INUM (CADR (mx
));
326 if (BOOT_CLOSURE_P (proc
))
328 prepare_boot_closure_env_for_eval (proc
, argc
, mx
, &x
, &env
);
336 argv
= alloca (argc
* sizeof (SCM
));
337 for (i
= 0; i
< argc
; i
++, mx
= CDR (mx
))
338 argv
[i
] = EVAL1 (CAR (mx
), env
);
340 return scm_c_vm_run (scm_the_vm (), proc
, argv
, argc
);
344 return scm_i_call_with_current_continuation (EVAL1 (mx
, env
));
346 case SCM_M_CALL_WITH_VALUES
:
351 producer
= EVAL1 (CAR (mx
), env
);
352 /* `proc' is the consumer. */
353 proc
= EVAL1 (CDR (mx
), env
);
354 v
= scm_call_with_vm (scm_the_vm (), producer
, SCM_EOL
);
356 args
= scm_struct_ref (v
, SCM_INUM0
);
358 args
= scm_list_1 (v
);
362 case SCM_M_LEXICAL_REF
:
366 for (n
= SCM_I_INUM (mx
); n
; n
--)
369 if (SCM_UNLIKELY (SCM_UNBNDP (ret
)))
370 /* we don't know what variable, though, because we don't have its
372 error_used_before_defined ();
376 case SCM_M_LEXICAL_SET
:
379 SCM val
= EVAL1 (CDR (mx
), env
);
380 for (n
= SCM_I_INUM (CAR (mx
)); n
; n
--)
382 SCM_SETCAR (env
, val
);
383 return SCM_UNSPECIFIED
;
386 case SCM_M_TOPLEVEL_REF
:
387 if (SCM_VARIABLEP (mx
))
388 return SCM_VARIABLE_REF (mx
);
391 while (scm_is_pair (env
))
393 return SCM_VARIABLE_REF
394 (scm_memoize_variable_access_x (x
, CAPTURE_ENV (env
)));
397 case SCM_M_TOPLEVEL_SET
:
400 SCM val
= EVAL1 (CDR (mx
), env
);
401 if (SCM_VARIABLEP (var
))
403 SCM_VARIABLE_SET (var
, val
);
404 return SCM_UNSPECIFIED
;
408 while (scm_is_pair (env
))
411 (scm_memoize_variable_access_x (x
, CAPTURE_ENV (env
)),
413 return SCM_UNSPECIFIED
;
417 case SCM_M_MODULE_REF
:
418 if (SCM_VARIABLEP (mx
))
419 return SCM_VARIABLE_REF (mx
);
421 return SCM_VARIABLE_REF
422 (scm_memoize_variable_access_x (x
, SCM_BOOL_F
));
424 case SCM_M_MODULE_SET
:
425 if (SCM_VARIABLEP (CDR (mx
)))
427 SCM_VARIABLE_SET (CDR (mx
), EVAL1 (CAR (mx
), env
));
428 return SCM_UNSPECIFIED
;
433 (scm_memoize_variable_access_x (x
, SCM_BOOL_F
),
434 EVAL1 (CAR (mx
), env
));
435 return SCM_UNSPECIFIED
;
441 /* We need the prompt and handler values after a longjmp case,
442 so make sure they are volatile. */
443 volatile SCM handler
, prompt
;
446 prompt
= scm_c_make_prompt (EVAL1 (CAR (mx
), env
),
447 SCM_VM_DATA (vm
)->fp
,
448 SCM_VM_DATA (vm
)->sp
, SCM_VM_DATA (vm
)->ip
,
449 0, -1, scm_i_dynwinds ());
450 handler
= EVAL1 (CDDR (mx
), env
);
451 scm_i_set_dynwinds (scm_cons (prompt
, scm_i_dynwinds ()));
453 if (SCM_PROMPT_SETJMP (prompt
))
455 /* The prompt exited nonlocally. */
457 args
= scm_i_prompt_pop_abort_args_x (scm_the_vm ());
461 res
= eval (CADR (mx
), env
);
462 scm_i_set_dynwinds (CDR (scm_i_dynwinds ()));
473 /* Simple procedure calls
477 scm_call_0 (SCM proc
)
479 return scm_c_vm_run (scm_the_vm (), proc
, NULL
, 0);
483 scm_call_1 (SCM proc
, SCM arg1
)
485 return scm_c_vm_run (scm_the_vm (), proc
, &arg1
, 1);
489 scm_call_2 (SCM proc
, SCM arg1
, SCM arg2
)
491 SCM args
[] = { arg1
, arg2
};
492 return scm_c_vm_run (scm_the_vm (), proc
, args
, 2);
496 scm_call_3 (SCM proc
, SCM arg1
, SCM arg2
, SCM arg3
)
498 SCM args
[] = { arg1
, arg2
, arg3
};
499 return scm_c_vm_run (scm_the_vm (), proc
, args
, 3);
503 scm_call_4 (SCM proc
, SCM arg1
, SCM arg2
, SCM arg3
, SCM arg4
)
505 SCM args
[] = { arg1
, arg2
, arg3
, arg4
};
506 return scm_c_vm_run (scm_the_vm (), proc
, args
, 4);
510 scm_call_5 (SCM proc
, SCM arg1
, SCM arg2
, SCM arg3
, SCM arg4
, SCM arg5
)
512 SCM args
[] = { arg1
, arg2
, arg3
, arg4
, arg5
};
513 return scm_c_vm_run (scm_the_vm (), proc
, args
, 5);
517 scm_call_6 (SCM proc
, SCM arg1
, SCM arg2
, SCM arg3
, SCM arg4
, SCM arg5
,
520 SCM args
[] = { arg1
, arg2
, arg3
, arg4
, arg5
, arg6
};
521 return scm_c_vm_run (scm_the_vm (), proc
, args
, 6);
525 scm_call_n (SCM proc
, SCM
*argv
, size_t nargs
)
527 return scm_c_vm_run (scm_the_vm (), proc
, argv
, nargs
);
530 /* Simple procedure applies
534 scm_apply_0 (SCM proc
, SCM args
)
536 return scm_apply (proc
, args
, SCM_EOL
);
540 scm_apply_1 (SCM proc
, SCM arg1
, SCM args
)
542 return scm_apply (proc
, scm_cons (arg1
, args
), SCM_EOL
);
546 scm_apply_2 (SCM proc
, SCM arg1
, SCM arg2
, SCM args
)
548 return scm_apply (proc
, scm_cons2 (arg1
, arg2
, args
), SCM_EOL
);
552 scm_apply_3 (SCM proc
, SCM arg1
, SCM arg2
, SCM arg3
, SCM args
)
554 return scm_apply (proc
, scm_cons (arg1
, scm_cons2 (arg2
, arg3
, args
)),
558 /* This code processes the arguments to apply:
560 (apply PROC ARG1 ... ARGS)
562 Given a list (ARG1 ... ARGS), this function conses the ARG1
563 ... arguments onto the front of ARGS, and returns the resulting
564 list. Note that ARGS is a list; thus, the argument to this
565 function is a list whose last element is a list.
567 Apply calls this function, and applies PROC to the elements of the
568 result. apply:nconc2last takes care of building the list of
569 arguments, given (ARG1 ... ARGS).
571 Rather than do new consing, apply:nconc2last destroys its argument.
572 On that topic, this code came into my care with the following
573 beautifully cryptic comment on that topic: "This will only screw
574 you if you do (scm_apply scm_apply '( ... ))" If you know what
575 they're referring to, send me a patch to this comment. */
577 SCM_DEFINE (scm_nconc2last
, "apply:nconc2last", 1, 0, 0,
579 "Given a list (@var{arg1} @dots{} @var{args}), this function\n"
580 "conses the @var{arg1} @dots{} arguments onto the front of\n"
581 "@var{args}, and returns the resulting list. Note that\n"
582 "@var{args} is a list; thus, the argument to this function is\n"
583 "a list whose last element is a list.\n"
584 "Note: Rather than do new consing, @code{apply:nconc2last}\n"
585 "destroys its argument, so use with care.")
586 #define FUNC_NAME s_scm_nconc2last
589 SCM_VALIDATE_NONEMPTYLIST (1, lst
);
591 while (!scm_is_null (SCM_CDR (*lloc
)))
592 lloc
= SCM_CDRLOC (*lloc
);
593 SCM_ASSERT (scm_ilength (SCM_CAR (*lloc
)) >= 0, lst
, SCM_ARG1
, FUNC_NAME
);
594 *lloc
= SCM_CAR (*lloc
);
601 scm_map (SCM proc
, SCM arg1
, SCM args
)
603 static SCM var
= SCM_BOOL_F
;
605 if (scm_is_false (var
))
606 var
= scm_private_variable (scm_the_root_module (),
607 scm_from_latin1_symbol ("map"));
609 return scm_apply (scm_variable_ref (var
),
610 scm_cons (proc
, scm_cons (arg1
, args
)), SCM_EOL
);
614 scm_for_each (SCM proc
, SCM arg1
, SCM args
)
616 static SCM var
= SCM_BOOL_F
;
618 if (scm_is_false (var
))
619 var
= scm_private_variable (scm_the_root_module (),
620 scm_from_latin1_symbol ("for-each"));
622 return scm_apply (scm_variable_ref (var
),
623 scm_cons (proc
, scm_cons (arg1
, args
)), SCM_EOL
);
628 scm_c_primitive_eval (SCM exp
)
630 if (!SCM_EXPANDED_P (exp
))
631 exp
= scm_call_1 (scm_current_module_transformer (), exp
);
632 return eval (scm_memoize_expression (exp
), SCM_EOL
);
635 static SCM var_primitive_eval
;
637 scm_primitive_eval (SCM exp
)
639 return scm_c_vm_run (scm_the_vm (), scm_variable_ref (var_primitive_eval
),
644 /* Eval does not take the second arg optionally. This is intentional
645 * in order to be R5RS compatible, and to prepare for the new module
646 * system, where we would like to make the choice of evaluation
647 * environment explicit. */
649 SCM_DEFINE (scm_eval
, "eval", 2, 0, 0,
650 (SCM exp
, SCM module_or_state
),
651 "Evaluate @var{exp}, a list representing a Scheme expression,\n"
652 "in the top-level environment specified by\n"
653 "@var{module_or_state}.\n"
654 "While @var{exp} is evaluated (using @code{primitive-eval}),\n"
655 "@var{module_or_state} is made the current module when\n"
656 "it is a module, or the current dynamic state when it is\n"
658 "Example: (eval '(+ 1 2) (interaction-environment))")
659 #define FUNC_NAME s_scm_eval
663 scm_dynwind_begin (SCM_F_DYNWIND_REWINDABLE
);
664 if (scm_is_dynamic_state (module_or_state
))
665 scm_dynwind_current_dynamic_state (module_or_state
);
666 else if (scm_module_system_booted_p
)
668 SCM_VALIDATE_MODULE (2, module_or_state
);
669 scm_dynwind_current_module (module_or_state
);
671 /* otherwise if the module system isn't booted, ignore the module arg */
673 res
= scm_primitive_eval (exp
);
683 /* Apply a function to a list of arguments.
685 This function is exported to the Scheme level as taking two
686 required arguments and a tail argument, as if it were:
687 (lambda (proc arg1 . args) ...)
688 Thus, if you just have a list of arguments to pass to a procedure,
689 pass the list as ARG1, and '() for ARGS. If you have some fixed
690 args, pass the first as ARG1, then cons any remaining fixed args
691 onto the front of your argument list, and pass that as ARGS. */
694 scm_apply (SCM proc
, SCM arg1
, SCM args
)
696 /* Fix things up so that args contains all args. */
697 if (scm_is_null (args
))
700 args
= scm_cons_star (arg1
, args
);
702 return scm_call_with_vm (scm_the_vm (), proc
, args
);
706 prepare_boot_closure_env_for_apply (SCM proc
, SCM args
,
707 SCM
*out_body
, SCM
*out_env
)
709 int nreq
= BOOT_CLOSURE_NUM_REQUIRED_ARGS (proc
);
710 SCM env
= BOOT_CLOSURE_ENV (proc
);
712 if (BOOT_CLOSURE_IS_FIXED (proc
)
713 || (BOOT_CLOSURE_IS_REST (proc
)
714 && !BOOT_CLOSURE_HAS_REST_ARGS (proc
)))
716 if (SCM_UNLIKELY (scm_ilength (args
) != nreq
))
717 scm_wrong_num_args (proc
);
718 for (; scm_is_pair (args
); args
= CDR (args
))
719 env
= scm_cons (CAR (args
), env
);
720 *out_body
= BOOT_CLOSURE_BODY (proc
);
723 else if (BOOT_CLOSURE_IS_REST (proc
))
725 if (SCM_UNLIKELY (scm_ilength (args
) < nreq
))
726 scm_wrong_num_args (proc
);
727 for (; nreq
; nreq
--, args
= CDR (args
))
728 env
= scm_cons (CAR (args
), env
);
729 env
= scm_cons (args
, env
);
730 *out_body
= BOOT_CLOSURE_BODY (proc
);
735 int i
, argc
, nreq
, nopt
;
736 SCM body
, rest
, kw
, inits
, alt
;
737 SCM mx
= BOOT_CLOSURE_CODE (proc
);
740 BOOT_CLOSURE_PARSE_FULL (mx
, body
, nargs
, rest
, nopt
, kw
, inits
, alt
);
742 argc
= scm_ilength (args
);
745 if (scm_is_true (alt
))
751 scm_wrong_num_args (proc
);
753 if (scm_is_false (kw
) && argc
> nreq
+ nopt
&& scm_is_false (rest
))
755 if (scm_is_true (alt
))
761 scm_wrong_num_args (proc
);
764 for (i
= 0; i
< nreq
; i
++, args
= CDR (args
))
765 env
= scm_cons (CAR (args
), env
);
767 if (scm_is_false (kw
))
769 /* Optional args (possibly), but no keyword args. */
770 for (; i
< argc
&& i
< nreq
+ nopt
;
771 i
++, args
= CDR (args
))
773 env
= scm_cons (CAR (args
), env
);
777 for (; i
< nreq
+ nopt
; i
++, inits
= CDR (inits
))
778 env
= scm_cons (EVAL1 (CAR (inits
), env
), env
);
780 if (scm_is_true (rest
))
781 env
= scm_cons (args
, env
);
790 /* Keyword args. As before, but stop at the first keyword. */
791 for (; i
< argc
&& i
< nreq
+ nopt
&& !scm_is_keyword (CAR (args
));
792 i
++, args
= CDR (args
), inits
= CDR (inits
))
793 env
= scm_cons (CAR (args
), env
);
795 for (; i
< nreq
+ nopt
; i
++, inits
= CDR (inits
))
796 env
= scm_cons (EVAL1 (CAR (inits
), env
), env
);
798 if (scm_is_true (rest
))
800 env
= scm_cons (args
, env
);
804 /* Now fill in env with unbound values, limn the rest of the args for
805 keywords, and fill in unbound values with their inits. */
808 int kw_start_idx
= i
;
810 for (walk
= kw
; scm_is_pair (walk
); walk
= CDR (walk
))
811 if (SCM_I_INUM (CDAR (walk
)) > imax
)
812 imax
= SCM_I_INUM (CDAR (walk
));
813 for (; i
<= imax
; i
++)
814 env
= scm_cons (SCM_UNDEFINED
, env
);
816 if (scm_is_pair (args
) && scm_is_pair (CDR (args
)))
817 for (; scm_is_pair (args
) && scm_is_pair (CDR (args
));
820 k
= CAR (args
); v
= CADR (args
);
821 if (!scm_is_keyword (k
))
823 if (scm_is_true (rest
))
828 for (walk
= kw
; scm_is_pair (walk
); walk
= CDR (walk
))
829 if (scm_is_eq (k
, CAAR (walk
)))
831 /* Well... ok, list-set! isn't the nicest interface, but
833 int iset
= imax
- SCM_I_INUM (CDAR (walk
));
834 scm_list_set_x (env
, SCM_I_MAKINUM (iset
), v
);
838 if (scm_is_null (walk
) && scm_is_false (aok
))
839 error_unrecognized_keyword (proc
);
841 if (scm_is_pair (args
) && scm_is_false (rest
))
842 error_invalid_keyword (proc
);
844 /* Now fill in unbound values, evaluating init expressions in their
845 appropriate environment. */
846 for (i
= imax
- kw_start_idx
; scm_is_pair (inits
); i
--, inits
= CDR (inits
))
848 SCM tail
= scm_list_tail (env
, SCM_I_MAKINUM (i
));
849 if (SCM_UNBNDP (CAR (tail
)))
850 SCM_SETCAR (tail
, EVAL1 (CAR (inits
), CDR (tail
)));
861 prepare_boot_closure_env_for_eval (SCM proc
, unsigned int argc
,
862 SCM exps
, SCM
*out_body
, SCM
*inout_env
)
864 int nreq
= BOOT_CLOSURE_NUM_REQUIRED_ARGS (proc
);
865 SCM new_env
= BOOT_CLOSURE_ENV (proc
);
866 if (BOOT_CLOSURE_IS_FIXED (proc
)
867 || (BOOT_CLOSURE_IS_REST (proc
)
868 && !BOOT_CLOSURE_HAS_REST_ARGS (proc
)))
870 for (; scm_is_pair (exps
); exps
= CDR (exps
), nreq
--)
871 new_env
= scm_cons (EVAL1 (CAR (exps
), *inout_env
),
873 if (SCM_UNLIKELY (nreq
!= 0))
874 scm_wrong_num_args (proc
);
875 *out_body
= BOOT_CLOSURE_BODY (proc
);
876 *inout_env
= new_env
;
878 else if (BOOT_CLOSURE_IS_REST (proc
))
880 if (SCM_UNLIKELY (argc
< nreq
))
881 scm_wrong_num_args (proc
);
882 for (; nreq
; nreq
--, exps
= CDR (exps
))
883 new_env
= scm_cons (EVAL1 (CAR (exps
), *inout_env
),
887 for (; scm_is_pair (exps
); exps
= CDR (exps
))
888 rest
= scm_cons (EVAL1 (CAR (exps
), *inout_env
), rest
);
889 new_env
= scm_cons (scm_reverse (rest
),
892 *out_body
= BOOT_CLOSURE_BODY (proc
);
893 *inout_env
= new_env
;
898 for (; scm_is_pair (exps
); exps
= CDR (exps
))
899 args
= scm_cons (EVAL1 (CAR (exps
), *inout_env
), args
);
900 args
= scm_reverse_x (args
, SCM_UNDEFINED
);
901 prepare_boot_closure_env_for_apply (proc
, args
, out_body
, inout_env
);
906 boot_closure_apply (SCM closure
, SCM args
)
909 prepare_boot_closure_env_for_apply (closure
, args
, &body
, &env
);
910 return eval (body
, env
);
914 boot_closure_print (SCM closure
, SCM port
, scm_print_state
*pstate
)
917 scm_puts ("#<boot-closure ", port
);
918 scm_uintprint ((scm_t_bits
)SCM2PTR (closure
), 16, port
);
919 scm_putc (' ', port
);
920 args
= scm_make_list (scm_from_int (BOOT_CLOSURE_NUM_REQUIRED_ARGS (closure
)),
921 scm_from_latin1_symbol ("_"));
922 if (!BOOT_CLOSURE_IS_FIXED (closure
) && BOOT_CLOSURE_HAS_REST_ARGS (closure
))
923 args
= scm_cons_star (scm_from_latin1_symbol ("_"), args
);
924 /* FIXME: optionals and rests */
925 scm_display (args
, port
);
926 scm_putc ('>', port
);
935 f_apply
= scm_c_define_gsubr ("apply", 2, 0, 1, scm_apply
);
937 scm_tc16_boot_closure
= scm_make_smob_type ("boot-closure", 0);
938 scm_set_smob_apply (scm_tc16_boot_closure
, boot_closure_apply
, 0, 0, 1);
939 scm_set_smob_print (scm_tc16_boot_closure
, boot_closure_print
);
941 primitive_eval
= scm_c_make_gsubr ("primitive-eval", 1, 0, 0,
942 scm_c_primitive_eval
);
943 var_primitive_eval
= scm_define (SCM_SUBR_NAME (primitive_eval
),
946 #include "libguile/eval.x"