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 eval (CAR (mx
), env
);
238 if (scm_is_true (EVAL1 (CAR (mx
), env
)))
246 SCM inits
= CAR (mx
);
247 SCM new_env
= CAPTURE_ENV (env
);
248 for (; scm_is_pair (inits
); inits
= CDR (inits
))
249 new_env
= scm_cons (EVAL1 (CAR (inits
), env
),
257 RETURN_BOOT_CLOSURE (mx
, CAPTURE_ENV (env
));
263 scm_define (CAR (mx
), EVAL1 (CDR (mx
), env
));
264 return SCM_UNSPECIFIED
;
268 SCM in
, out
, res
, old_winds
;
269 in
= EVAL1 (CAR (mx
), env
);
270 out
= EVAL1 (CDDR (mx
), env
);
272 old_winds
= scm_i_dynwinds ();
273 scm_i_set_dynwinds (scm_acons (in
, out
, old_winds
));
274 res
= eval (CADR (mx
), env
);
275 scm_i_set_dynwinds (old_winds
);
280 case SCM_M_WITH_FLUIDS
:
283 SCM
*fluidv
, *valuesv
, walk
, wf
, res
;
284 len
= scm_ilength (CAR (mx
));
285 fluidv
= alloca (sizeof (SCM
)*len
);
286 for (i
= 0, walk
= CAR (mx
); i
< len
; i
++, walk
= CDR (walk
))
287 fluidv
[i
] = EVAL1 (CAR (walk
), env
);
288 valuesv
= alloca (sizeof (SCM
)*len
);
289 for (i
= 0, walk
= CADR (mx
); i
< len
; i
++, walk
= CDR (walk
))
290 valuesv
[i
] = EVAL1 (CAR (walk
), env
);
292 wf
= scm_i_make_with_fluids (len
, fluidv
, valuesv
);
293 scm_i_swap_with_fluids (wf
, SCM_I_CURRENT_THREAD
->dynamic_state
);
294 scm_i_set_dynwinds (scm_cons (wf
, scm_i_dynwinds ()));
295 res
= eval (CDDR (mx
), env
);
296 scm_i_swap_with_fluids (wf
, SCM_I_CURRENT_THREAD
->dynamic_state
);
297 scm_i_set_dynwinds (CDR (scm_i_dynwinds ()));
303 /* Evaluate the procedure to be applied. */
304 proc
= EVAL1 (CAR (mx
), env
);
305 /* Evaluate the argument holding the list of arguments */
306 args
= EVAL1 (CADR (mx
), env
);
309 /* Go here to tail-apply a procedure. PROC is the procedure and
310 * ARGS is the list of arguments. */
311 if (BOOT_CLOSURE_P (proc
))
313 prepare_boot_closure_env_for_apply (proc
, args
, &x
, &env
);
317 return scm_call_with_vm (scm_the_vm (), proc
, args
);
320 /* Evaluate the procedure to be applied. */
321 proc
= EVAL1 (CAR (mx
), env
);
322 argc
= SCM_I_INUM (CADR (mx
));
325 if (BOOT_CLOSURE_P (proc
))
327 prepare_boot_closure_env_for_eval (proc
, argc
, mx
, &x
, &env
);
335 argv
= alloca (argc
* sizeof (SCM
));
336 for (i
= 0; i
< argc
; i
++, mx
= CDR (mx
))
337 argv
[i
] = EVAL1 (CAR (mx
), env
);
339 return scm_c_vm_run (scm_the_vm (), proc
, argv
, argc
);
343 return scm_i_call_with_current_continuation (EVAL1 (mx
, env
));
345 case SCM_M_CALL_WITH_VALUES
:
350 producer
= EVAL1 (CAR (mx
), env
);
351 /* `proc' is the consumer. */
352 proc
= EVAL1 (CDR (mx
), env
);
353 v
= scm_call_with_vm (scm_the_vm (), producer
, SCM_EOL
);
355 args
= scm_struct_ref (v
, SCM_INUM0
);
357 args
= scm_list_1 (v
);
361 case SCM_M_LEXICAL_REF
:
365 for (n
= SCM_I_INUM (mx
); n
; n
--)
368 if (SCM_UNLIKELY (SCM_UNBNDP (ret
)))
369 /* we don't know what variable, though, because we don't have its
371 error_used_before_defined ();
375 case SCM_M_LEXICAL_SET
:
378 SCM val
= EVAL1 (CDR (mx
), env
);
379 for (n
= SCM_I_INUM (CAR (mx
)); n
; n
--)
381 SCM_SETCAR (env
, val
);
382 return SCM_UNSPECIFIED
;
385 case SCM_M_TOPLEVEL_REF
:
386 if (SCM_VARIABLEP (mx
))
387 return SCM_VARIABLE_REF (mx
);
390 while (scm_is_pair (env
))
392 return SCM_VARIABLE_REF
393 (scm_memoize_variable_access_x (x
, CAPTURE_ENV (env
)));
396 case SCM_M_TOPLEVEL_SET
:
399 SCM val
= EVAL1 (CDR (mx
), env
);
400 if (SCM_VARIABLEP (var
))
402 SCM_VARIABLE_SET (var
, val
);
403 return SCM_UNSPECIFIED
;
407 while (scm_is_pair (env
))
410 (scm_memoize_variable_access_x (x
, CAPTURE_ENV (env
)),
412 return SCM_UNSPECIFIED
;
416 case SCM_M_MODULE_REF
:
417 if (SCM_VARIABLEP (mx
))
418 return SCM_VARIABLE_REF (mx
);
420 return SCM_VARIABLE_REF
421 (scm_memoize_variable_access_x (x
, SCM_BOOL_F
));
423 case SCM_M_MODULE_SET
:
424 if (SCM_VARIABLEP (CDR (mx
)))
426 SCM_VARIABLE_SET (CDR (mx
), EVAL1 (CAR (mx
), env
));
427 return SCM_UNSPECIFIED
;
432 (scm_memoize_variable_access_x (x
, SCM_BOOL_F
),
433 EVAL1 (CAR (mx
), env
));
434 return SCM_UNSPECIFIED
;
440 /* We need the prompt and handler values after a longjmp case,
441 so make sure they are volatile. */
442 volatile SCM handler
, prompt
;
445 prompt
= scm_c_make_prompt (EVAL1 (CAR (mx
), env
),
446 SCM_VM_DATA (vm
)->fp
,
447 SCM_VM_DATA (vm
)->sp
, SCM_VM_DATA (vm
)->ip
,
448 0, -1, scm_i_dynwinds ());
449 handler
= EVAL1 (CDDR (mx
), env
);
450 scm_i_set_dynwinds (scm_cons (prompt
, scm_i_dynwinds ()));
452 if (SCM_PROMPT_SETJMP (prompt
))
454 /* The prompt exited nonlocally. */
456 args
= scm_i_prompt_pop_abort_args_x (scm_the_vm ());
460 res
= eval (CADR (mx
), env
);
461 scm_i_set_dynwinds (CDR (scm_i_dynwinds ()));
472 /* Simple procedure calls
476 scm_call_0 (SCM proc
)
478 return scm_c_vm_run (scm_the_vm (), proc
, NULL
, 0);
482 scm_call_1 (SCM proc
, SCM arg1
)
484 return scm_c_vm_run (scm_the_vm (), proc
, &arg1
, 1);
488 scm_call_2 (SCM proc
, SCM arg1
, SCM arg2
)
490 SCM args
[] = { arg1
, arg2
};
491 return scm_c_vm_run (scm_the_vm (), proc
, args
, 2);
495 scm_call_3 (SCM proc
, SCM arg1
, SCM arg2
, SCM arg3
)
497 SCM args
[] = { arg1
, arg2
, arg3
};
498 return scm_c_vm_run (scm_the_vm (), proc
, args
, 3);
502 scm_call_4 (SCM proc
, SCM arg1
, SCM arg2
, SCM arg3
, SCM arg4
)
504 SCM args
[] = { arg1
, arg2
, arg3
, arg4
};
505 return scm_c_vm_run (scm_the_vm (), proc
, args
, 4);
509 scm_call_5 (SCM proc
, SCM arg1
, SCM arg2
, SCM arg3
, SCM arg4
, SCM arg5
)
511 SCM args
[] = { arg1
, arg2
, arg3
, arg4
, arg5
};
512 return scm_c_vm_run (scm_the_vm (), proc
, args
, 5);
516 scm_call_6 (SCM proc
, SCM arg1
, SCM arg2
, SCM arg3
, SCM arg4
, SCM arg5
,
519 SCM args
[] = { arg1
, arg2
, arg3
, arg4
, arg5
, arg6
};
520 return scm_c_vm_run (scm_the_vm (), proc
, args
, 6);
524 scm_call_n (SCM proc
, SCM
*argv
, size_t nargs
)
526 return scm_c_vm_run (scm_the_vm (), proc
, argv
, nargs
);
529 /* Simple procedure applies
533 scm_apply_0 (SCM proc
, SCM args
)
535 return scm_apply (proc
, args
, SCM_EOL
);
539 scm_apply_1 (SCM proc
, SCM arg1
, SCM args
)
541 return scm_apply (proc
, scm_cons (arg1
, args
), SCM_EOL
);
545 scm_apply_2 (SCM proc
, SCM arg1
, SCM arg2
, SCM args
)
547 return scm_apply (proc
, scm_cons2 (arg1
, arg2
, args
), SCM_EOL
);
551 scm_apply_3 (SCM proc
, SCM arg1
, SCM arg2
, SCM arg3
, SCM args
)
553 return scm_apply (proc
, scm_cons (arg1
, scm_cons2 (arg2
, arg3
, args
)),
557 /* This code processes the arguments to apply:
559 (apply PROC ARG1 ... ARGS)
561 Given a list (ARG1 ... ARGS), this function conses the ARG1
562 ... arguments onto the front of ARGS, and returns the resulting
563 list. Note that ARGS is a list; thus, the argument to this
564 function is a list whose last element is a list.
566 Apply calls this function, and applies PROC to the elements of the
567 result. apply:nconc2last takes care of building the list of
568 arguments, given (ARG1 ... ARGS).
570 Rather than do new consing, apply:nconc2last destroys its argument.
571 On that topic, this code came into my care with the following
572 beautifully cryptic comment on that topic: "This will only screw
573 you if you do (scm_apply scm_apply '( ... ))" If you know what
574 they're referring to, send me a patch to this comment. */
576 SCM_DEFINE (scm_nconc2last
, "apply:nconc2last", 1, 0, 0,
578 "Given a list (@var{arg1} @dots{} @var{args}), this function\n"
579 "conses the @var{arg1} @dots{} arguments onto the front of\n"
580 "@var{args}, and returns the resulting list. Note that\n"
581 "@var{args} is a list; thus, the argument to this function is\n"
582 "a list whose last element is a list.\n"
583 "Note: Rather than do new consing, @code{apply:nconc2last}\n"
584 "destroys its argument, so use with care.")
585 #define FUNC_NAME s_scm_nconc2last
588 SCM_VALIDATE_NONEMPTYLIST (1, lst
);
590 while (!scm_is_null (SCM_CDR (*lloc
)))
591 lloc
= SCM_CDRLOC (*lloc
);
592 SCM_ASSERT (scm_ilength (SCM_CAR (*lloc
)) >= 0, lst
, SCM_ARG1
, FUNC_NAME
);
593 *lloc
= SCM_CAR (*lloc
);
600 scm_map (SCM proc
, SCM arg1
, SCM args
)
602 static SCM var
= SCM_BOOL_F
;
604 if (scm_is_false (var
))
605 var
= scm_private_variable (scm_the_root_module (),
606 scm_from_latin1_symbol ("map"));
608 return scm_apply (scm_variable_ref (var
),
609 scm_cons (proc
, scm_cons (arg1
, args
)), SCM_EOL
);
613 scm_for_each (SCM proc
, SCM arg1
, SCM args
)
615 static SCM var
= SCM_BOOL_F
;
617 if (scm_is_false (var
))
618 var
= scm_private_variable (scm_the_root_module (),
619 scm_from_latin1_symbol ("for-each"));
621 return scm_apply (scm_variable_ref (var
),
622 scm_cons (proc
, scm_cons (arg1
, args
)), SCM_EOL
);
627 scm_c_primitive_eval (SCM exp
)
629 if (!SCM_EXPANDED_P (exp
))
630 exp
= scm_call_1 (scm_current_module_transformer (), exp
);
631 return eval (scm_memoize_expression (exp
), SCM_EOL
);
634 static SCM var_primitive_eval
;
636 scm_primitive_eval (SCM exp
)
638 return scm_c_vm_run (scm_the_vm (), scm_variable_ref (var_primitive_eval
),
643 /* Eval does not take the second arg optionally. This is intentional
644 * in order to be R5RS compatible, and to prepare for the new module
645 * system, where we would like to make the choice of evaluation
646 * environment explicit. */
648 SCM_DEFINE (scm_eval
, "eval", 2, 0, 0,
649 (SCM exp
, SCM module_or_state
),
650 "Evaluate @var{exp}, a list representing a Scheme expression,\n"
651 "in the top-level environment specified by\n"
652 "@var{module_or_state}.\n"
653 "While @var{exp} is evaluated (using @code{primitive-eval}),\n"
654 "@var{module_or_state} is made the current module when\n"
655 "it is a module, or the current dynamic state when it is\n"
657 "Example: (eval '(+ 1 2) (interaction-environment))")
658 #define FUNC_NAME s_scm_eval
662 scm_dynwind_begin (SCM_F_DYNWIND_REWINDABLE
);
663 if (scm_is_dynamic_state (module_or_state
))
664 scm_dynwind_current_dynamic_state (module_or_state
);
665 else if (scm_module_system_booted_p
)
667 SCM_VALIDATE_MODULE (2, module_or_state
);
668 scm_dynwind_current_module (module_or_state
);
670 /* otherwise if the module system isn't booted, ignore the module arg */
672 res
= scm_primitive_eval (exp
);
682 /* Apply a function to a list of arguments.
684 This function is exported to the Scheme level as taking two
685 required arguments and a tail argument, as if it were:
686 (lambda (proc arg1 . args) ...)
687 Thus, if you just have a list of arguments to pass to a procedure,
688 pass the list as ARG1, and '() for ARGS. If you have some fixed
689 args, pass the first as ARG1, then cons any remaining fixed args
690 onto the front of your argument list, and pass that as ARGS. */
693 scm_apply (SCM proc
, SCM arg1
, SCM args
)
695 /* Fix things up so that args contains all args. */
696 if (scm_is_null (args
))
699 args
= scm_cons_star (arg1
, args
);
701 return scm_call_with_vm (scm_the_vm (), proc
, args
);
705 prepare_boot_closure_env_for_apply (SCM proc
, SCM args
,
706 SCM
*out_body
, SCM
*out_env
)
708 int nreq
= BOOT_CLOSURE_NUM_REQUIRED_ARGS (proc
);
709 SCM env
= BOOT_CLOSURE_ENV (proc
);
711 if (BOOT_CLOSURE_IS_FIXED (proc
)
712 || (BOOT_CLOSURE_IS_REST (proc
)
713 && !BOOT_CLOSURE_HAS_REST_ARGS (proc
)))
715 if (SCM_UNLIKELY (scm_ilength (args
) != nreq
))
716 scm_wrong_num_args (proc
);
717 for (; scm_is_pair (args
); args
= CDR (args
))
718 env
= scm_cons (CAR (args
), env
);
719 *out_body
= BOOT_CLOSURE_BODY (proc
);
722 else if (BOOT_CLOSURE_IS_REST (proc
))
724 if (SCM_UNLIKELY (scm_ilength (args
) < nreq
))
725 scm_wrong_num_args (proc
);
726 for (; nreq
; nreq
--, args
= CDR (args
))
727 env
= scm_cons (CAR (args
), env
);
728 env
= scm_cons (args
, env
);
729 *out_body
= BOOT_CLOSURE_BODY (proc
);
734 int i
, argc
, nreq
, nopt
;
735 SCM body
, rest
, kw
, inits
, alt
;
736 SCM mx
= BOOT_CLOSURE_CODE (proc
);
739 BOOT_CLOSURE_PARSE_FULL (mx
, body
, nargs
, rest
, nopt
, kw
, inits
, alt
);
741 argc
= scm_ilength (args
);
744 if (scm_is_true (alt
))
750 scm_wrong_num_args (proc
);
752 if (scm_is_false (kw
) && argc
> nreq
+ nopt
&& scm_is_false (rest
))
754 if (scm_is_true (alt
))
760 scm_wrong_num_args (proc
);
763 for (i
= 0; i
< nreq
; i
++, args
= CDR (args
))
764 env
= scm_cons (CAR (args
), env
);
766 if (scm_is_false (kw
))
768 /* Optional args (possibly), but no keyword args. */
769 for (; i
< argc
&& i
< nreq
+ nopt
;
770 i
++, args
= CDR (args
))
772 env
= scm_cons (CAR (args
), env
);
776 for (; i
< nreq
+ nopt
; i
++, inits
= CDR (inits
))
777 env
= scm_cons (EVAL1 (CAR (inits
), env
), env
);
779 if (scm_is_true (rest
))
780 env
= scm_cons (args
, env
);
789 /* Keyword args. As before, but stop at the first keyword. */
790 for (; i
< argc
&& i
< nreq
+ nopt
&& !scm_is_keyword (CAR (args
));
791 i
++, args
= CDR (args
), inits
= CDR (inits
))
792 env
= scm_cons (CAR (args
), env
);
794 for (; i
< nreq
+ nopt
; i
++, inits
= CDR (inits
))
795 env
= scm_cons (EVAL1 (CAR (inits
), env
), env
);
797 if (scm_is_true (rest
))
799 env
= scm_cons (args
, env
);
803 /* Now fill in env with unbound values, limn the rest of the args for
804 keywords, and fill in unbound values with their inits. */
807 int kw_start_idx
= i
;
809 for (walk
= kw
; scm_is_pair (walk
); walk
= CDR (walk
))
810 if (SCM_I_INUM (CDAR (walk
)) > imax
)
811 imax
= SCM_I_INUM (CDAR (walk
));
812 for (; i
<= imax
; i
++)
813 env
= scm_cons (SCM_UNDEFINED
, env
);
815 if (scm_is_pair (args
) && scm_is_pair (CDR (args
)))
816 for (; scm_is_pair (args
) && scm_is_pair (CDR (args
));
819 k
= CAR (args
); v
= CADR (args
);
820 if (!scm_is_keyword (k
))
822 if (scm_is_true (rest
))
827 for (walk
= kw
; scm_is_pair (walk
); walk
= CDR (walk
))
828 if (scm_is_eq (k
, CAAR (walk
)))
830 /* Well... ok, list-set! isn't the nicest interface, but
832 int iset
= imax
- SCM_I_INUM (CDAR (walk
));
833 scm_list_set_x (env
, SCM_I_MAKINUM (iset
), v
);
837 if (scm_is_null (walk
) && scm_is_false (aok
))
838 error_unrecognized_keyword (proc
);
840 if (scm_is_pair (args
) && scm_is_false (rest
))
841 error_invalid_keyword (proc
);
843 /* Now fill in unbound values, evaluating init expressions in their
844 appropriate environment. */
845 for (i
= imax
- kw_start_idx
; scm_is_pair (inits
); i
--, inits
= CDR (inits
))
847 SCM tail
= scm_list_tail (env
, SCM_I_MAKINUM (i
));
848 if (SCM_UNBNDP (CAR (tail
)))
849 SCM_SETCAR (tail
, EVAL1 (CAR (inits
), CDR (tail
)));
860 prepare_boot_closure_env_for_eval (SCM proc
, unsigned int argc
,
861 SCM exps
, SCM
*out_body
, SCM
*inout_env
)
863 int nreq
= BOOT_CLOSURE_NUM_REQUIRED_ARGS (proc
);
864 SCM new_env
= BOOT_CLOSURE_ENV (proc
);
865 if (BOOT_CLOSURE_IS_FIXED (proc
)
866 || (BOOT_CLOSURE_IS_REST (proc
)
867 && !BOOT_CLOSURE_HAS_REST_ARGS (proc
)))
869 for (; scm_is_pair (exps
); exps
= CDR (exps
), nreq
--)
870 new_env
= scm_cons (EVAL1 (CAR (exps
), *inout_env
),
872 if (SCM_UNLIKELY (nreq
!= 0))
873 scm_wrong_num_args (proc
);
874 *out_body
= BOOT_CLOSURE_BODY (proc
);
875 *inout_env
= new_env
;
877 else if (BOOT_CLOSURE_IS_REST (proc
))
879 if (SCM_UNLIKELY (argc
< nreq
))
880 scm_wrong_num_args (proc
);
881 for (; nreq
; nreq
--, exps
= CDR (exps
))
882 new_env
= scm_cons (EVAL1 (CAR (exps
), *inout_env
),
886 for (; scm_is_pair (exps
); exps
= CDR (exps
))
887 rest
= scm_cons (EVAL1 (CAR (exps
), *inout_env
), rest
);
888 new_env
= scm_cons (scm_reverse (rest
),
891 *out_body
= BOOT_CLOSURE_BODY (proc
);
892 *inout_env
= new_env
;
897 for (; scm_is_pair (exps
); exps
= CDR (exps
))
898 args
= scm_cons (EVAL1 (CAR (exps
), *inout_env
), args
);
899 args
= scm_reverse_x (args
, SCM_UNDEFINED
);
900 prepare_boot_closure_env_for_apply (proc
, args
, out_body
, inout_env
);
905 boot_closure_apply (SCM closure
, SCM args
)
908 prepare_boot_closure_env_for_apply (closure
, args
, &body
, &env
);
909 return eval (body
, env
);
913 boot_closure_print (SCM closure
, SCM port
, scm_print_state
*pstate
)
916 scm_puts ("#<boot-closure ", port
);
917 scm_uintprint ((scm_t_bits
)SCM2PTR (closure
), 16, port
);
918 scm_putc (' ', port
);
919 args
= scm_make_list (scm_from_int (BOOT_CLOSURE_NUM_REQUIRED_ARGS (closure
)),
920 scm_from_latin1_symbol ("_"));
921 if (!BOOT_CLOSURE_IS_FIXED (closure
) && BOOT_CLOSURE_HAS_REST_ARGS (closure
))
922 args
= scm_cons_star (scm_from_latin1_symbol ("_"), args
);
923 /* FIXME: optionals and rests */
924 scm_display (args
, port
);
925 scm_putc ('>', port
);
934 f_apply
= scm_c_define_gsubr ("apply", 2, 0, 1, scm_apply
);
936 scm_tc16_boot_closure
= scm_make_smob_type ("boot-closure", 0);
937 scm_set_smob_apply (scm_tc16_boot_closure
, boot_closure_apply
, 0, 0, 1);
938 scm_set_smob_print (scm_tc16_boot_closure
, boot_closure_print
);
940 primitive_eval
= scm_c_make_gsubr ("primitive-eval", 1, 0, 0,
941 scm_c_primitive_eval
);
942 var_primitive_eval
= scm_define (SCM_SUBR_NAME (primitive_eval
),
945 #include "libguile/eval.x"