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
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
;
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_7 (SCM proc
, SCM arg1
, SCM arg2
, SCM arg3
, SCM arg4
, SCM arg5
,
528 SCM args
[] = { arg1
, arg2
, arg3
, arg4
, arg5
, arg6
, arg7
};
529 return scm_c_vm_run (scm_the_vm (), proc
, args
, 7);
533 scm_call_8 (SCM proc
, SCM arg1
, SCM arg2
, SCM arg3
, SCM arg4
, SCM arg5
,
534 SCM arg6
, SCM arg7
, SCM arg8
)
536 SCM args
[] = { arg1
, arg2
, arg3
, arg4
, arg5
, arg6
, arg7
, arg8
};
537 return scm_c_vm_run (scm_the_vm (), proc
, args
, 8);
541 scm_call_9 (SCM proc
, SCM arg1
, SCM arg2
, SCM arg3
, SCM arg4
, SCM arg5
,
542 SCM arg6
, SCM arg7
, SCM arg8
, SCM arg9
)
544 SCM args
[] = { arg1
, arg2
, arg3
, arg4
, arg5
, arg6
, arg7
, arg8
, arg9
};
545 return scm_c_vm_run (scm_the_vm (), proc
, args
, 9);
549 scm_call_n (SCM proc
, SCM
*argv
, size_t nargs
)
551 return scm_c_vm_run (scm_the_vm (), proc
, argv
, nargs
);
555 scm_call (SCM proc
, ...)
561 va_start (argp
, proc
);
562 while (!SCM_UNBNDP (va_arg (argp
, SCM
)))
566 argv
= alloca (nargs
* sizeof (SCM
));
567 va_start (argp
, proc
);
568 for (i
= 0; i
< nargs
; i
++)
569 argv
[i
] = va_arg (argp
, SCM
);
572 return scm_c_vm_run (scm_the_vm (), proc
, argv
, nargs
);
575 /* Simple procedure applies
579 scm_apply_0 (SCM proc
, SCM args
)
581 return scm_apply (proc
, args
, SCM_EOL
);
585 scm_apply_1 (SCM proc
, SCM arg1
, SCM args
)
587 return scm_apply (proc
, scm_cons (arg1
, args
), SCM_EOL
);
591 scm_apply_2 (SCM proc
, SCM arg1
, SCM arg2
, SCM args
)
593 return scm_apply (proc
, scm_cons2 (arg1
, arg2
, args
), SCM_EOL
);
597 scm_apply_3 (SCM proc
, SCM arg1
, SCM arg2
, SCM arg3
, SCM args
)
599 return scm_apply (proc
, scm_cons (arg1
, scm_cons2 (arg2
, arg3
, args
)),
603 /* This code processes the arguments to apply:
605 (apply PROC ARG1 ... ARGS)
607 Given a list (ARG1 ... ARGS), this function conses the ARG1
608 ... arguments onto the front of ARGS, and returns the resulting
609 list. Note that ARGS is a list; thus, the argument to this
610 function is a list whose last element is a list.
612 Apply calls this function, and applies PROC to the elements of the
613 result. apply:nconc2last takes care of building the list of
614 arguments, given (ARG1 ... ARGS).
616 Rather than do new consing, apply:nconc2last destroys its argument.
617 On that topic, this code came into my care with the following
618 beautifully cryptic comment on that topic: "This will only screw
619 you if you do (scm_apply scm_apply '( ... ))" If you know what
620 they're referring to, send me a patch to this comment. */
622 SCM_DEFINE (scm_nconc2last
, "apply:nconc2last", 1, 0, 0,
624 "Given a list (@var{arg1} @dots{} @var{args}), this function\n"
625 "conses the @var{arg1} @dots{} arguments onto the front of\n"
626 "@var{args}, and returns the resulting list. Note that\n"
627 "@var{args} is a list; thus, the argument to this function is\n"
628 "a list whose last element is a list.\n"
629 "Note: Rather than do new consing, @code{apply:nconc2last}\n"
630 "destroys its argument, so use with care.")
631 #define FUNC_NAME s_scm_nconc2last
634 SCM_VALIDATE_NONEMPTYLIST (1, lst
);
636 while (!scm_is_null (SCM_CDR (*lloc
)))
637 lloc
= SCM_CDRLOC (*lloc
);
638 SCM_ASSERT (scm_ilength (SCM_CAR (*lloc
)) >= 0, lst
, SCM_ARG1
, FUNC_NAME
);
639 *lloc
= SCM_CAR (*lloc
);
646 scm_map (SCM proc
, SCM arg1
, SCM args
)
648 static SCM var
= SCM_BOOL_F
;
650 if (scm_is_false (var
))
651 var
= scm_private_variable (scm_the_root_module (),
652 scm_from_latin1_symbol ("map"));
654 return scm_apply (scm_variable_ref (var
),
655 scm_cons (proc
, scm_cons (arg1
, args
)), SCM_EOL
);
659 scm_for_each (SCM proc
, SCM arg1
, SCM args
)
661 static SCM var
= SCM_BOOL_F
;
663 if (scm_is_false (var
))
664 var
= scm_private_variable (scm_the_root_module (),
665 scm_from_latin1_symbol ("for-each"));
667 return scm_apply (scm_variable_ref (var
),
668 scm_cons (proc
, scm_cons (arg1
, args
)), SCM_EOL
);
673 scm_c_primitive_eval (SCM exp
)
675 if (!SCM_EXPANDED_P (exp
))
676 exp
= scm_call_1 (scm_current_module_transformer (), exp
);
677 return eval (scm_memoize_expression (exp
), SCM_EOL
);
680 static SCM var_primitive_eval
;
682 scm_primitive_eval (SCM exp
)
684 return scm_c_vm_run (scm_the_vm (), scm_variable_ref (var_primitive_eval
),
689 /* Eval does not take the second arg optionally. This is intentional
690 * in order to be R5RS compatible, and to prepare for the new module
691 * system, where we would like to make the choice of evaluation
692 * environment explicit. */
694 SCM_DEFINE (scm_eval
, "eval", 2, 0, 0,
695 (SCM exp
, SCM module_or_state
),
696 "Evaluate @var{exp}, a list representing a Scheme expression,\n"
697 "in the top-level environment specified by\n"
698 "@var{module_or_state}.\n"
699 "While @var{exp} is evaluated (using @code{primitive-eval}),\n"
700 "@var{module_or_state} is made the current module when\n"
701 "it is a module, or the current dynamic state when it is\n"
703 "Example: (eval '(+ 1 2) (interaction-environment))")
704 #define FUNC_NAME s_scm_eval
708 scm_dynwind_begin (SCM_F_DYNWIND_REWINDABLE
);
709 if (scm_is_dynamic_state (module_or_state
))
710 scm_dynwind_current_dynamic_state (module_or_state
);
711 else if (scm_module_system_booted_p
)
713 SCM_VALIDATE_MODULE (2, module_or_state
);
714 scm_dynwind_current_module (module_or_state
);
716 /* otherwise if the module system isn't booted, ignore the module arg */
718 res
= scm_primitive_eval (exp
);
728 /* Apply a function to a list of arguments.
730 This function is exported to the Scheme level as taking two
731 required arguments and a tail argument, as if it were:
732 (lambda (proc arg1 . args) ...)
733 Thus, if you just have a list of arguments to pass to a procedure,
734 pass the list as ARG1, and '() for ARGS. If you have some fixed
735 args, pass the first as ARG1, then cons any remaining fixed args
736 onto the front of your argument list, and pass that as ARGS. */
739 scm_apply (SCM proc
, SCM arg1
, SCM args
)
741 /* Fix things up so that args contains all args. */
742 if (scm_is_null (args
))
745 args
= scm_cons_star (arg1
, args
);
747 return scm_call_with_vm (scm_the_vm (), proc
, args
);
751 prepare_boot_closure_env_for_apply (SCM proc
, SCM args
,
752 SCM
*out_body
, SCM
*out_env
)
754 int nreq
= BOOT_CLOSURE_NUM_REQUIRED_ARGS (proc
);
755 SCM env
= BOOT_CLOSURE_ENV (proc
);
757 if (BOOT_CLOSURE_IS_FIXED (proc
)
758 || (BOOT_CLOSURE_IS_REST (proc
)
759 && !BOOT_CLOSURE_HAS_REST_ARGS (proc
)))
761 if (SCM_UNLIKELY (scm_ilength (args
) != nreq
))
762 scm_wrong_num_args (proc
);
763 for (; scm_is_pair (args
); args
= CDR (args
))
764 env
= scm_cons (CAR (args
), env
);
765 *out_body
= BOOT_CLOSURE_BODY (proc
);
768 else if (BOOT_CLOSURE_IS_REST (proc
))
770 if (SCM_UNLIKELY (scm_ilength (args
) < nreq
))
771 scm_wrong_num_args (proc
);
772 for (; nreq
; nreq
--, args
= CDR (args
))
773 env
= scm_cons (CAR (args
), env
);
774 env
= scm_cons (args
, env
);
775 *out_body
= BOOT_CLOSURE_BODY (proc
);
780 int i
, argc
, nreq
, nopt
;
781 SCM body
, rest
, kw
, inits
, alt
;
782 SCM mx
= BOOT_CLOSURE_CODE (proc
);
785 BOOT_CLOSURE_PARSE_FULL (mx
, body
, nargs
, rest
, nopt
, kw
, inits
, alt
);
787 argc
= scm_ilength (args
);
790 if (scm_is_true (alt
))
796 scm_wrong_num_args (proc
);
798 if (scm_is_false (kw
) && argc
> nreq
+ nopt
&& scm_is_false (rest
))
800 if (scm_is_true (alt
))
806 scm_wrong_num_args (proc
);
809 for (i
= 0; i
< nreq
; i
++, args
= CDR (args
))
810 env
= scm_cons (CAR (args
), env
);
812 if (scm_is_false (kw
))
814 /* Optional args (possibly), but no keyword args. */
815 for (; i
< argc
&& i
< nreq
+ nopt
;
816 i
++, args
= CDR (args
))
818 env
= scm_cons (CAR (args
), env
);
822 for (; i
< nreq
+ nopt
; i
++, inits
= CDR (inits
))
823 env
= scm_cons (EVAL1 (CAR (inits
), env
), env
);
825 if (scm_is_true (rest
))
826 env
= scm_cons (args
, env
);
835 /* Keyword args. As before, but stop at the first keyword. */
836 for (; i
< argc
&& i
< nreq
+ nopt
&& !scm_is_keyword (CAR (args
));
837 i
++, args
= CDR (args
), inits
= CDR (inits
))
838 env
= scm_cons (CAR (args
), env
);
840 for (; i
< nreq
+ nopt
; i
++, inits
= CDR (inits
))
841 env
= scm_cons (EVAL1 (CAR (inits
), env
), env
);
843 if (scm_is_true (rest
))
845 env
= scm_cons (args
, env
);
849 /* Now fill in env with unbound values, limn the rest of the args for
850 keywords, and fill in unbound values with their inits. */
853 int kw_start_idx
= i
;
855 for (walk
= kw
; scm_is_pair (walk
); walk
= CDR (walk
))
856 if (SCM_I_INUM (CDAR (walk
)) > imax
)
857 imax
= SCM_I_INUM (CDAR (walk
));
858 for (; i
<= imax
; i
++)
859 env
= scm_cons (SCM_UNDEFINED
, env
);
861 if (scm_is_pair (args
) && scm_is_pair (CDR (args
)))
862 for (; scm_is_pair (args
) && scm_is_pair (CDR (args
));
865 k
= CAR (args
); v
= CADR (args
);
866 if (!scm_is_keyword (k
))
868 if (scm_is_true (rest
))
873 for (walk
= kw
; scm_is_pair (walk
); walk
= CDR (walk
))
874 if (scm_is_eq (k
, CAAR (walk
)))
876 /* Well... ok, list-set! isn't the nicest interface, but
878 int iset
= imax
- SCM_I_INUM (CDAR (walk
));
879 scm_list_set_x (env
, SCM_I_MAKINUM (iset
), v
);
883 if (scm_is_null (walk
) && scm_is_false (aok
))
884 error_unrecognized_keyword (proc
);
886 if (scm_is_pair (args
) && scm_is_false (rest
))
887 error_invalid_keyword (proc
);
889 /* Now fill in unbound values, evaluating init expressions in their
890 appropriate environment. */
891 for (i
= imax
- kw_start_idx
; scm_is_pair (inits
); i
--, inits
= CDR (inits
))
893 SCM tail
= scm_list_tail (env
, SCM_I_MAKINUM (i
));
894 if (SCM_UNBNDP (CAR (tail
)))
895 SCM_SETCAR (tail
, EVAL1 (CAR (inits
), CDR (tail
)));
906 prepare_boot_closure_env_for_eval (SCM proc
, unsigned int argc
,
907 SCM exps
, SCM
*out_body
, SCM
*inout_env
)
909 int nreq
= BOOT_CLOSURE_NUM_REQUIRED_ARGS (proc
);
910 SCM new_env
= BOOT_CLOSURE_ENV (proc
);
911 if (BOOT_CLOSURE_IS_FIXED (proc
)
912 || (BOOT_CLOSURE_IS_REST (proc
)
913 && !BOOT_CLOSURE_HAS_REST_ARGS (proc
)))
915 for (; scm_is_pair (exps
); exps
= CDR (exps
), nreq
--)
916 new_env
= scm_cons (EVAL1 (CAR (exps
), *inout_env
),
918 if (SCM_UNLIKELY (nreq
!= 0))
919 scm_wrong_num_args (proc
);
920 *out_body
= BOOT_CLOSURE_BODY (proc
);
921 *inout_env
= new_env
;
923 else if (BOOT_CLOSURE_IS_REST (proc
))
925 if (SCM_UNLIKELY (argc
< nreq
))
926 scm_wrong_num_args (proc
);
927 for (; nreq
; nreq
--, exps
= CDR (exps
))
928 new_env
= scm_cons (EVAL1 (CAR (exps
), *inout_env
),
932 for (; scm_is_pair (exps
); exps
= CDR (exps
))
933 rest
= scm_cons (EVAL1 (CAR (exps
), *inout_env
), rest
);
934 new_env
= scm_cons (scm_reverse (rest
),
937 *out_body
= BOOT_CLOSURE_BODY (proc
);
938 *inout_env
= new_env
;
943 for (; scm_is_pair (exps
); exps
= CDR (exps
))
944 args
= scm_cons (EVAL1 (CAR (exps
), *inout_env
), args
);
945 args
= scm_reverse_x (args
, SCM_UNDEFINED
);
946 prepare_boot_closure_env_for_apply (proc
, args
, out_body
, inout_env
);
951 boot_closure_apply (SCM closure
, SCM args
)
954 prepare_boot_closure_env_for_apply (closure
, args
, &body
, &env
);
955 return eval (body
, env
);
959 boot_closure_print (SCM closure
, SCM port
, scm_print_state
*pstate
)
962 scm_puts_unlocked ("#<boot-closure ", port
);
963 scm_uintprint (SCM_UNPACK (closure
), 16, port
);
964 scm_putc_unlocked (' ', port
);
965 args
= scm_make_list (scm_from_int (BOOT_CLOSURE_NUM_REQUIRED_ARGS (closure
)),
966 scm_from_latin1_symbol ("_"));
967 if (!BOOT_CLOSURE_IS_FIXED (closure
) && BOOT_CLOSURE_HAS_REST_ARGS (closure
))
968 args
= scm_cons_star (scm_from_latin1_symbol ("_"), args
);
969 /* FIXME: optionals and rests */
970 scm_display (args
, port
);
971 scm_putc_unlocked ('>', port
);
980 f_apply
= scm_c_define_gsubr ("apply", 2, 0, 1, scm_apply
);
982 scm_tc16_boot_closure
= scm_make_smob_type ("boot-closure", 0);
983 scm_set_smob_apply (scm_tc16_boot_closure
, boot_closure_apply
, 0, 0, 1);
984 scm_set_smob_print (scm_tc16_boot_closure
, boot_closure_print
);
986 primitive_eval
= scm_c_make_gsubr ("primitive-eval", 1, 0, 0,
987 scm_c_primitive_eval
);
988 var_primitive_eval
= scm_define (SCM_SUBR_NAME (primitive_eval
),
991 #include "libguile/eval.x"