1 /* Copyright (C) 1995,1996,1997,1998,1999,2000,2001,2002,2003,2004,2005,2006,2007,2008,2009,2010,2011,2012
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
29 #include "libguile/__scm.h"
31 #include "libguile/_scm.h"
32 #include "libguile/alist.h"
33 #include "libguile/async.h"
34 #include "libguile/continuations.h"
35 #include "libguile/control.h"
36 #include "libguile/debug.h"
37 #include "libguile/deprecation.h"
38 #include "libguile/dynwind.h"
39 #include "libguile/eq.h"
40 #include "libguile/expand.h"
41 #include "libguile/feature.h"
42 #include "libguile/fluids.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 (CADR (BOOT_CLOSURE_CODE (x)))
113 #define BOOT_CLOSURE_IS_FIXED(x) scm_is_null (CDDR (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 (BOOT_CLOSURE_CODE (x)))
116 #define BOOT_CLOSURE_IS_REST(x) scm_is_null (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 = CDR (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)
157 SCM_SYMBOL (scm_unbound_variable_key
, "unbound-variable");
159 static void error_used_before_defined (void)
161 scm_error (scm_unbound_variable_key
, NULL
,
162 "Variable used before given a value", SCM_EOL
, SCM_BOOL_F
);
165 static void error_invalid_keyword (SCM proc
)
167 scm_error_scm (scm_from_latin1_symbol ("keyword-argument-error"), proc
,
168 scm_from_locale_string ("Invalid keyword"), SCM_EOL
,
172 static void error_unrecognized_keyword (SCM proc
)
174 scm_error_scm (scm_from_latin1_symbol ("keyword-argument-error"), proc
,
175 scm_from_locale_string ("Unrecognized keyword"), SCM_EOL
,
180 /* Multiple values truncation. */
182 truncate_values (SCM x
)
184 if (SCM_LIKELY (!SCM_VALUESP (x
)))
188 SCM l
= scm_struct_ref (x
, SCM_INUM0
);
189 if (SCM_LIKELY (scm_is_pair (l
)))
193 scm_ithrow (scm_from_latin1_symbol ("vm-run"),
194 scm_list_3 (scm_from_latin1_symbol ("vm-run"),
195 scm_from_locale_string
196 ("Too few values returned to continuation"),
204 #define EVAL1(x, env) (truncate_values (eval ((x), (env))))
208 If MOD is #f, it means the environment was captured before modules were
210 If MOD is the literal value '(), we are evaluating at the top level, and so
211 should track changes to the current module. You have to be careful in this
212 case, because further lexical contours should capture the current module.
214 #define CAPTURE_ENV(env) \
215 (scm_is_null (env) ? scm_current_module () : \
216 (scm_is_false (env) ? scm_the_root_module () : env))
219 eval (SCM x
, SCM env
)
222 SCM proc
= SCM_UNDEFINED
, args
= SCM_EOL
;
227 if (!SCM_MEMOIZED_P (x
))
230 mx
= SCM_MEMOIZED_ARGS (x
);
231 switch (SCM_MEMOIZED_TAG (x
))
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
;
270 scm_i_thread
*t
= SCM_I_CURRENT_THREAD
;
271 in
= EVAL1 (CAR (mx
), env
);
272 out
= EVAL1 (CDDR (mx
), env
);
274 scm_dynstack_push_dynwind (&t
->dynstack
, in
, out
);
275 res
= eval (CADR (mx
), env
);
276 scm_dynstack_pop (&t
->dynstack
);
281 case SCM_M_WITH_FLUIDS
:
284 SCM
*fluidv
, *valuesv
, walk
, res
;
285 scm_i_thread
*thread
= SCM_I_CURRENT_THREAD
;
287 len
= scm_ilength (CAR (mx
));
288 fluidv
= alloca (sizeof (SCM
)*len
);
289 for (i
= 0, walk
= CAR (mx
); i
< len
; i
++, walk
= CDR (walk
))
290 fluidv
[i
] = EVAL1 (CAR (walk
), env
);
291 valuesv
= alloca (sizeof (SCM
)*len
);
292 for (i
= 0, walk
= CADR (mx
); i
< len
; i
++, walk
= CDR (walk
))
293 valuesv
[i
] = EVAL1 (CAR (walk
), env
);
295 scm_dynstack_push_fluids (&thread
->dynstack
, len
, fluidv
, valuesv
,
296 thread
->dynamic_state
);
297 res
= eval (CDDR (mx
), env
);
298 scm_dynstack_unwind_fluids (&thread
->dynstack
, thread
->dynamic_state
);
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 scm_i_jmp_buf registers
;
442 /* We need the handler after nonlocal return to the setjmp, so
443 make sure it is volatile. */
444 volatile SCM handler
;
446 k
= EVAL1 (CAR (mx
), env
);
447 handler
= EVAL1 (CDDR (mx
), env
);
450 /* Push the prompt onto the dynamic stack. */
451 scm_dynstack_push_prompt (&SCM_I_CURRENT_THREAD
->dynstack
,
452 SCM_F_DYNSTACK_PROMPT_ESCAPE_ONLY
,
454 SCM_VM_DATA (vm
)->fp
,
455 SCM_VM_DATA (vm
)->sp
,
456 SCM_VM_DATA (vm
)->ip
,
459 if (SCM_I_SETJMP (registers
))
461 /* The prompt exited nonlocally. */
463 args
= scm_i_prompt_pop_abort_args_x (scm_the_vm ());
467 res
= eval (CADR (mx
), env
);
468 scm_dynstack_pop (&SCM_I_CURRENT_THREAD
->dynstack
);
479 /* Simple procedure calls
483 scm_call_0 (SCM proc
)
485 return scm_c_vm_run (scm_the_vm (), proc
, NULL
, 0);
489 scm_call_1 (SCM proc
, SCM arg1
)
491 return scm_c_vm_run (scm_the_vm (), proc
, &arg1
, 1);
495 scm_call_2 (SCM proc
, SCM arg1
, SCM arg2
)
497 SCM args
[] = { arg1
, arg2
};
498 return scm_c_vm_run (scm_the_vm (), proc
, args
, 2);
502 scm_call_3 (SCM proc
, SCM arg1
, SCM arg2
, SCM arg3
)
504 SCM args
[] = { arg1
, arg2
, arg3
};
505 return scm_c_vm_run (scm_the_vm (), proc
, args
, 3);
509 scm_call_4 (SCM proc
, SCM arg1
, SCM arg2
, SCM arg3
, SCM arg4
)
511 SCM args
[] = { arg1
, arg2
, arg3
, arg4
};
512 return scm_c_vm_run (scm_the_vm (), proc
, args
, 4);
516 scm_call_5 (SCM proc
, SCM arg1
, SCM arg2
, SCM arg3
, SCM arg4
, SCM arg5
)
518 SCM args
[] = { arg1
, arg2
, arg3
, arg4
, arg5
};
519 return scm_c_vm_run (scm_the_vm (), proc
, args
, 5);
523 scm_call_6 (SCM proc
, SCM arg1
, SCM arg2
, SCM arg3
, SCM arg4
, SCM arg5
,
526 SCM args
[] = { arg1
, arg2
, arg3
, arg4
, arg5
, arg6
};
527 return scm_c_vm_run (scm_the_vm (), proc
, args
, 6);
531 scm_call_7 (SCM proc
, SCM arg1
, SCM arg2
, SCM arg3
, SCM arg4
, SCM arg5
,
534 SCM args
[] = { arg1
, arg2
, arg3
, arg4
, arg5
, arg6
, arg7
};
535 return scm_c_vm_run (scm_the_vm (), proc
, args
, 7);
539 scm_call_8 (SCM proc
, SCM arg1
, SCM arg2
, SCM arg3
, SCM arg4
, SCM arg5
,
540 SCM arg6
, SCM arg7
, SCM arg8
)
542 SCM args
[] = { arg1
, arg2
, arg3
, arg4
, arg5
, arg6
, arg7
, arg8
};
543 return scm_c_vm_run (scm_the_vm (), proc
, args
, 8);
547 scm_call_9 (SCM proc
, SCM arg1
, SCM arg2
, SCM arg3
, SCM arg4
, SCM arg5
,
548 SCM arg6
, SCM arg7
, SCM arg8
, SCM arg9
)
550 SCM args
[] = { arg1
, arg2
, arg3
, arg4
, arg5
, arg6
, arg7
, arg8
, arg9
};
551 return scm_c_vm_run (scm_the_vm (), proc
, args
, 9);
555 scm_call_n (SCM proc
, SCM
*argv
, size_t nargs
)
557 return scm_c_vm_run (scm_the_vm (), proc
, argv
, nargs
);
561 scm_call (SCM proc
, ...)
567 va_start (argp
, proc
);
568 while (!SCM_UNBNDP (va_arg (argp
, SCM
)))
572 argv
= alloca (nargs
* sizeof (SCM
));
573 va_start (argp
, proc
);
574 for (i
= 0; i
< nargs
; i
++)
575 argv
[i
] = va_arg (argp
, SCM
);
578 return scm_c_vm_run (scm_the_vm (), proc
, argv
, nargs
);
581 /* Simple procedure applies
585 scm_apply_0 (SCM proc
, SCM args
)
587 return scm_apply (proc
, args
, SCM_EOL
);
591 scm_apply_1 (SCM proc
, SCM arg1
, SCM args
)
593 return scm_apply (proc
, scm_cons (arg1
, args
), SCM_EOL
);
597 scm_apply_2 (SCM proc
, SCM arg1
, SCM arg2
, SCM args
)
599 return scm_apply (proc
, scm_cons2 (arg1
, arg2
, args
), SCM_EOL
);
603 scm_apply_3 (SCM proc
, SCM arg1
, SCM arg2
, SCM arg3
, SCM args
)
605 return scm_apply (proc
, scm_cons (arg1
, scm_cons2 (arg2
, arg3
, args
)),
609 /* This code processes the arguments to apply:
611 (apply PROC ARG1 ... ARGS)
613 Given a list (ARG1 ... ARGS), this function conses the ARG1
614 ... arguments onto the front of ARGS, and returns the resulting
615 list. Note that ARGS is a list; thus, the argument to this
616 function is a list whose last element is a list.
618 Apply calls this function, and applies PROC to the elements of the
619 result. apply:nconc2last takes care of building the list of
620 arguments, given (ARG1 ... ARGS).
622 Rather than do new consing, apply:nconc2last destroys its argument.
623 On that topic, this code came into my care with the following
624 beautifully cryptic comment on that topic: "This will only screw
625 you if you do (scm_apply scm_apply '( ... ))" If you know what
626 they're referring to, send me a patch to this comment. */
628 SCM_DEFINE (scm_nconc2last
, "apply:nconc2last", 1, 0, 0,
630 "Given a list (@var{arg1} @dots{} @var{args}), this function\n"
631 "conses the @var{arg1} @dots{} arguments onto the front of\n"
632 "@var{args}, and returns the resulting list. Note that\n"
633 "@var{args} is a list; thus, the argument to this function is\n"
634 "a list whose last element is a list.\n"
635 "Note: Rather than do new consing, @code{apply:nconc2last}\n"
636 "destroys its argument, so use with care.")
637 #define FUNC_NAME s_scm_nconc2last
640 SCM_VALIDATE_NONEMPTYLIST (1, lst
);
642 while (!scm_is_null (SCM_CDR (*lloc
)))
643 lloc
= SCM_CDRLOC (*lloc
);
644 SCM_ASSERT (scm_ilength (SCM_CAR (*lloc
)) >= 0, lst
, SCM_ARG1
, FUNC_NAME
);
645 *lloc
= SCM_CAR (*lloc
);
652 scm_map (SCM proc
, SCM arg1
, SCM args
)
654 static SCM var
= SCM_BOOL_F
;
656 if (scm_is_false (var
))
657 var
= scm_private_variable (scm_the_root_module (),
658 scm_from_latin1_symbol ("map"));
660 return scm_apply (scm_variable_ref (var
),
661 scm_cons (proc
, scm_cons (arg1
, args
)), SCM_EOL
);
665 scm_for_each (SCM proc
, SCM arg1
, SCM args
)
667 static SCM var
= SCM_BOOL_F
;
669 if (scm_is_false (var
))
670 var
= scm_private_variable (scm_the_root_module (),
671 scm_from_latin1_symbol ("for-each"));
673 return scm_apply (scm_variable_ref (var
),
674 scm_cons (proc
, scm_cons (arg1
, args
)), SCM_EOL
);
679 scm_c_primitive_eval (SCM exp
)
681 if (!SCM_EXPANDED_P (exp
))
682 exp
= scm_call_1 (scm_current_module_transformer (), exp
);
683 return eval (scm_memoize_expression (exp
), SCM_EOL
);
686 static SCM var_primitive_eval
;
688 scm_primitive_eval (SCM exp
)
690 return scm_c_vm_run (scm_the_vm (), scm_variable_ref (var_primitive_eval
),
695 /* Eval does not take the second arg optionally. This is intentional
696 * in order to be R5RS compatible, and to prepare for the new module
697 * system, where we would like to make the choice of evaluation
698 * environment explicit. */
700 SCM_DEFINE (scm_eval
, "eval", 2, 0, 0,
701 (SCM exp
, SCM module_or_state
),
702 "Evaluate @var{exp}, a list representing a Scheme expression,\n"
703 "in the top-level environment specified by\n"
704 "@var{module_or_state}.\n"
705 "While @var{exp} is evaluated (using @code{primitive-eval}),\n"
706 "@var{module_or_state} is made the current module when\n"
707 "it is a module, or the current dynamic state when it is\n"
709 "Example: (eval '(+ 1 2) (interaction-environment))")
710 #define FUNC_NAME s_scm_eval
714 scm_dynwind_begin (SCM_F_DYNWIND_REWINDABLE
);
715 if (scm_is_dynamic_state (module_or_state
))
716 scm_dynwind_current_dynamic_state (module_or_state
);
717 else if (scm_module_system_booted_p
)
719 SCM_VALIDATE_MODULE (2, module_or_state
);
720 scm_dynwind_current_module (module_or_state
);
722 /* otherwise if the module system isn't booted, ignore the module arg */
724 res
= scm_primitive_eval (exp
);
734 /* Apply a function to a list of arguments.
736 This function is exported to the Scheme level as taking two
737 required arguments and a tail argument, as if it were:
738 (lambda (proc arg1 . args) ...)
739 Thus, if you just have a list of arguments to pass to a procedure,
740 pass the list as ARG1, and '() for ARGS. If you have some fixed
741 args, pass the first as ARG1, then cons any remaining fixed args
742 onto the front of your argument list, and pass that as ARGS. */
745 scm_apply (SCM proc
, SCM arg1
, SCM args
)
747 /* Fix things up so that args contains all args. */
748 if (scm_is_null (args
))
751 args
= scm_cons_star (arg1
, args
);
753 return scm_call_with_vm (scm_the_vm (), proc
, args
);
757 prepare_boot_closure_env_for_apply (SCM proc
, SCM args
,
758 SCM
*out_body
, SCM
*out_env
)
760 int nreq
= BOOT_CLOSURE_NUM_REQUIRED_ARGS (proc
);
761 SCM env
= BOOT_CLOSURE_ENV (proc
);
763 if (BOOT_CLOSURE_IS_FIXED (proc
)
764 || (BOOT_CLOSURE_IS_REST (proc
)
765 && !BOOT_CLOSURE_HAS_REST_ARGS (proc
)))
767 if (SCM_UNLIKELY (scm_ilength (args
) != nreq
))
768 scm_wrong_num_args (proc
);
769 for (; scm_is_pair (args
); args
= CDR (args
))
770 env
= scm_cons (CAR (args
), env
);
771 *out_body
= BOOT_CLOSURE_BODY (proc
);
774 else if (BOOT_CLOSURE_IS_REST (proc
))
776 if (SCM_UNLIKELY (scm_ilength (args
) < nreq
))
777 scm_wrong_num_args (proc
);
778 for (; nreq
; nreq
--, args
= CDR (args
))
779 env
= scm_cons (CAR (args
), env
);
780 env
= scm_cons (args
, env
);
781 *out_body
= BOOT_CLOSURE_BODY (proc
);
786 int i
, argc
, nreq
, nopt
;
787 SCM body
, rest
, kw
, inits
, alt
;
788 SCM mx
= BOOT_CLOSURE_CODE (proc
);
791 BOOT_CLOSURE_PARSE_FULL (mx
, body
, nargs
, rest
, nopt
, kw
, inits
, alt
);
793 argc
= scm_ilength (args
);
796 if (scm_is_true (alt
))
802 scm_wrong_num_args (proc
);
804 if (scm_is_false (kw
) && argc
> nreq
+ nopt
&& scm_is_false (rest
))
806 if (scm_is_true (alt
))
812 scm_wrong_num_args (proc
);
815 for (i
= 0; i
< nreq
; i
++, args
= CDR (args
))
816 env
= scm_cons (CAR (args
), env
);
818 if (scm_is_false (kw
))
820 /* Optional args (possibly), but no keyword args. */
821 for (; i
< argc
&& i
< nreq
+ nopt
;
822 i
++, args
= CDR (args
))
824 env
= scm_cons (CAR (args
), env
);
828 for (; i
< nreq
+ nopt
; i
++, inits
= CDR (inits
))
829 env
= scm_cons (EVAL1 (CAR (inits
), env
), env
);
831 if (scm_is_true (rest
))
832 env
= scm_cons (args
, env
);
841 /* Keyword args. As before, but stop at the first keyword. */
842 for (; i
< argc
&& i
< nreq
+ nopt
&& !scm_is_keyword (CAR (args
));
843 i
++, args
= CDR (args
), inits
= CDR (inits
))
844 env
= scm_cons (CAR (args
), env
);
846 for (; i
< nreq
+ nopt
; i
++, inits
= CDR (inits
))
847 env
= scm_cons (EVAL1 (CAR (inits
), env
), env
);
849 if (scm_is_true (rest
))
851 env
= scm_cons (args
, env
);
855 /* Now fill in env with unbound values, limn the rest of the args for
856 keywords, and fill in unbound values with their inits. */
859 int kw_start_idx
= i
;
861 for (walk
= kw
; scm_is_pair (walk
); walk
= CDR (walk
))
862 if (SCM_I_INUM (CDAR (walk
)) > imax
)
863 imax
= SCM_I_INUM (CDAR (walk
));
864 for (; i
<= imax
; i
++)
865 env
= scm_cons (SCM_UNDEFINED
, env
);
867 if (scm_is_pair (args
) && scm_is_pair (CDR (args
)))
868 for (; scm_is_pair (args
) && scm_is_pair (CDR (args
));
871 k
= CAR (args
); v
= CADR (args
);
872 if (!scm_is_keyword (k
))
874 if (scm_is_true (rest
))
879 for (walk
= kw
; scm_is_pair (walk
); walk
= CDR (walk
))
880 if (scm_is_eq (k
, CAAR (walk
)))
882 /* Well... ok, list-set! isn't the nicest interface, but
884 int iset
= imax
- SCM_I_INUM (CDAR (walk
));
885 scm_list_set_x (env
, SCM_I_MAKINUM (iset
), v
);
889 if (scm_is_null (walk
) && scm_is_false (aok
))
890 error_unrecognized_keyword (proc
);
892 if (scm_is_pair (args
) && scm_is_false (rest
))
893 error_invalid_keyword (proc
);
895 /* Now fill in unbound values, evaluating init expressions in their
896 appropriate environment. */
897 for (i
= imax
- kw_start_idx
; scm_is_pair (inits
); i
--, inits
= CDR (inits
))
899 SCM tail
= scm_list_tail (env
, SCM_I_MAKINUM (i
));
900 if (SCM_UNBNDP (CAR (tail
)))
901 SCM_SETCAR (tail
, EVAL1 (CAR (inits
), CDR (tail
)));
912 prepare_boot_closure_env_for_eval (SCM proc
, unsigned int argc
,
913 SCM exps
, SCM
*out_body
, SCM
*inout_env
)
915 int nreq
= BOOT_CLOSURE_NUM_REQUIRED_ARGS (proc
);
916 SCM new_env
= BOOT_CLOSURE_ENV (proc
);
917 if (BOOT_CLOSURE_IS_FIXED (proc
)
918 || (BOOT_CLOSURE_IS_REST (proc
)
919 && !BOOT_CLOSURE_HAS_REST_ARGS (proc
)))
921 for (; scm_is_pair (exps
); exps
= CDR (exps
), nreq
--)
922 new_env
= scm_cons (EVAL1 (CAR (exps
), *inout_env
),
924 if (SCM_UNLIKELY (nreq
!= 0))
925 scm_wrong_num_args (proc
);
926 *out_body
= BOOT_CLOSURE_BODY (proc
);
927 *inout_env
= new_env
;
929 else if (BOOT_CLOSURE_IS_REST (proc
))
931 if (SCM_UNLIKELY (argc
< nreq
))
932 scm_wrong_num_args (proc
);
933 for (; nreq
; nreq
--, exps
= CDR (exps
))
934 new_env
= scm_cons (EVAL1 (CAR (exps
), *inout_env
),
938 for (; scm_is_pair (exps
); exps
= CDR (exps
))
939 rest
= scm_cons (EVAL1 (CAR (exps
), *inout_env
), rest
);
940 new_env
= scm_cons (scm_reverse (rest
),
943 *out_body
= BOOT_CLOSURE_BODY (proc
);
944 *inout_env
= new_env
;
949 for (; scm_is_pair (exps
); exps
= CDR (exps
))
950 args
= scm_cons (EVAL1 (CAR (exps
), *inout_env
), args
);
951 args
= scm_reverse_x (args
, SCM_UNDEFINED
);
952 prepare_boot_closure_env_for_apply (proc
, args
, out_body
, inout_env
);
957 boot_closure_apply (SCM closure
, SCM args
)
960 prepare_boot_closure_env_for_apply (closure
, args
, &body
, &env
);
961 return eval (body
, env
);
965 boot_closure_print (SCM closure
, SCM port
, scm_print_state
*pstate
)
968 scm_puts_unlocked ("#<boot-closure ", port
);
969 scm_uintprint (SCM_UNPACK (closure
), 16, port
);
970 scm_putc_unlocked (' ', port
);
971 args
= scm_make_list (scm_from_int (BOOT_CLOSURE_NUM_REQUIRED_ARGS (closure
)),
972 scm_from_latin1_symbol ("_"));
973 if (!BOOT_CLOSURE_IS_FIXED (closure
) && BOOT_CLOSURE_HAS_REST_ARGS (closure
))
974 args
= scm_cons_star (scm_from_latin1_symbol ("_"), args
);
975 /* FIXME: optionals and rests */
976 scm_display (args
, port
);
977 scm_putc_unlocked ('>', port
);
986 f_apply
= scm_c_define_gsubr ("apply", 2, 0, 1, scm_apply
);
988 scm_tc16_boot_closure
= scm_make_smob_type ("boot-closure", 0);
989 scm_set_smob_apply (scm_tc16_boot_closure
, boot_closure_apply
, 0, 0, 1);
990 scm_set_smob_print (scm_tc16_boot_closure
, boot_closure_print
);
992 primitive_eval
= scm_c_make_gsubr ("primitive-eval", 1, 0, 0,
993 scm_c_primitive_eval
);
994 var_primitive_eval
= scm_define (SCM_SUBR_NAME (primitive_eval
),
997 #include "libguile/eval.x"