1 /* Copyright (C) 1995,1996,1997,1998,1999,2000,2001,2002,2003,2004,2005,2006,2007,2008,2009,2010,2011,2013
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 (CADDR (BOOT_CLOSURE_CODE (x))))
113 #define BOOT_CLOSURE_IS_FIXED(x) (scm_is_null (CDDDR (BOOT_CLOSURE_CODE (x))))
114 /* NB: One may only call the following accessors if the closure is not FIXED. */
115 #define BOOT_CLOSURE_HAS_REST_ARGS(x) scm_is_true (CADDR (SCM_CDR (BOOT_CLOSURE_CODE (x))))
116 #define BOOT_CLOSURE_IS_REST(x) scm_is_null (SCM_CDR (CDDDR (BOOT_CLOSURE_CODE (x))))
117 /* NB: One may only call the following accessors if the closure is not REST. */
118 #define BOOT_CLOSURE_IS_FULL(x) (1)
119 #define BOOT_CLOSURE_PARSE_FULL(fu_,body,nargs,rest,nopt,kw,inits,alt) \
121 body = CAR (fu); fu = CDDR (fu); \
123 rest = kw = alt = SCM_BOOL_F; \
127 nreq = SCM_I_INUM (CAR (fu)); fu = CDR (fu); \
128 if (scm_is_pair (fu)) \
130 rest = CAR (fu); fu = CDR (fu); \
131 if (scm_is_pair (fu)) \
133 nopt = SCM_I_INUM (CAR (fu)); fu = CDR (fu); \
134 kw = CAR (fu); fu = CDR (fu); \
135 inits = CAR (fu); fu = CDR (fu); \
140 static void prepare_boot_closure_env_for_apply (SCM proc
, SCM args
,
141 SCM
*out_body
, SCM
*out_env
);
142 static void prepare_boot_closure_env_for_eval (SCM proc
, unsigned int argc
,
143 SCM exps
, SCM
*out_body
,
147 #define CAR(x) SCM_CAR(x)
148 #define CDR(x) SCM_CDR(x)
149 #define CAAR(x) SCM_CAAR(x)
150 #define CADR(x) SCM_CADR(x)
151 #define CDAR(x) SCM_CDAR(x)
152 #define CDDR(x) SCM_CDDR(x)
153 #define CADDR(x) SCM_CADDR(x)
154 #define CDDDR(x) SCM_CDDDR(x)
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
, SCM obj
)
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
, SCM kw
)
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 for (; !scm_is_null (CDR (mx
)); mx
= CDR (mx
))
235 eval (CAR (mx
), env
);
240 if (scm_is_true (EVAL1 (CAR (mx
), env
)))
248 SCM inits
= CAR (mx
);
249 SCM new_env
= CAPTURE_ENV (env
);
250 for (; scm_is_pair (inits
); inits
= CDR (inits
))
251 new_env
= scm_cons (EVAL1 (CAR (inits
), env
),
259 RETURN_BOOT_CLOSURE (mx
, CAPTURE_ENV (env
));
265 scm_define (CAR (mx
), EVAL1 (CDR (mx
), env
));
266 return SCM_UNSPECIFIED
;
270 SCM in
, out
, res
, old_winds
;
271 in
= EVAL1 (CAR (mx
), env
);
272 out
= EVAL1 (CDDR (mx
), env
);
274 old_winds
= scm_i_dynwinds ();
275 scm_i_set_dynwinds (scm_acons (in
, out
, old_winds
));
276 res
= eval (CADR (mx
), env
);
277 scm_i_set_dynwinds (old_winds
);
282 case SCM_M_WITH_FLUIDS
:
285 SCM
*fluidv
, *valuesv
, walk
, wf
, res
;
286 len
= scm_ilength (CAR (mx
));
287 fluidv
= alloca (sizeof (SCM
)*len
);
288 for (i
= 0, walk
= CAR (mx
); i
< len
; i
++, walk
= CDR (walk
))
289 fluidv
[i
] = EVAL1 (CAR (walk
), env
);
290 valuesv
= alloca (sizeof (SCM
)*len
);
291 for (i
= 0, walk
= CADR (mx
); i
< len
; i
++, walk
= CDR (walk
))
292 valuesv
[i
] = EVAL1 (CAR (walk
), env
);
294 wf
= scm_i_make_with_fluids (len
, fluidv
, valuesv
);
295 scm_i_swap_with_fluids (wf
, SCM_I_CURRENT_THREAD
->dynamic_state
);
296 scm_i_set_dynwinds (scm_cons (wf
, scm_i_dynwinds ()));
297 res
= eval (CDDR (mx
), env
);
298 scm_i_swap_with_fluids (wf
, SCM_I_CURRENT_THREAD
->dynamic_state
);
299 scm_i_set_dynwinds (CDR (scm_i_dynwinds ()));
305 /* Evaluate the procedure to be applied. */
306 proc
= EVAL1 (CAR (mx
), env
);
307 /* Evaluate the argument holding the list of arguments */
308 args
= EVAL1 (CADR (mx
), env
);
311 /* Go here to tail-apply a procedure. PROC is the procedure and
312 * ARGS is the list of arguments. */
313 if (BOOT_CLOSURE_P (proc
))
315 prepare_boot_closure_env_for_apply (proc
, args
, &x
, &env
);
319 return scm_call_with_vm (scm_the_vm (), proc
, args
);
322 /* Evaluate the procedure to be applied. */
323 proc
= EVAL1 (CAR (mx
), env
);
324 argc
= SCM_I_INUM (CADR (mx
));
327 if (BOOT_CLOSURE_P (proc
))
329 prepare_boot_closure_env_for_eval (proc
, argc
, mx
, &x
, &env
);
337 argv
= alloca (argc
* sizeof (SCM
));
338 for (i
= 0; i
< argc
; i
++, mx
= CDR (mx
))
339 argv
[i
] = EVAL1 (CAR (mx
), env
);
341 return scm_c_vm_run (scm_the_vm (), proc
, argv
, argc
);
345 return scm_i_call_with_current_continuation (EVAL1 (mx
, env
));
347 case SCM_M_CALL_WITH_VALUES
:
352 producer
= EVAL1 (CAR (mx
), env
);
353 /* `proc' is the consumer. */
354 proc
= EVAL1 (CDR (mx
), env
);
355 v
= scm_call_with_vm (scm_the_vm (), producer
, SCM_EOL
);
357 args
= scm_struct_ref (v
, SCM_INUM0
);
359 args
= scm_list_1 (v
);
363 case SCM_M_LEXICAL_REF
:
367 for (n
= SCM_I_INUM (mx
); n
; n
--)
370 if (SCM_UNLIKELY (SCM_UNBNDP (ret
)))
371 /* we don't know what variable, though, because we don't have its
373 error_used_before_defined ();
377 case SCM_M_LEXICAL_SET
:
380 SCM val
= EVAL1 (CDR (mx
), env
);
381 for (n
= SCM_I_INUM (CAR (mx
)); n
; n
--)
383 SCM_SETCAR (env
, val
);
384 return SCM_UNSPECIFIED
;
387 case SCM_M_TOPLEVEL_REF
:
388 if (SCM_VARIABLEP (mx
))
389 return SCM_VARIABLE_REF (mx
);
392 while (scm_is_pair (env
))
394 return SCM_VARIABLE_REF
395 (scm_memoize_variable_access_x (x
, CAPTURE_ENV (env
)));
398 case SCM_M_TOPLEVEL_SET
:
401 SCM val
= EVAL1 (CDR (mx
), env
);
402 if (SCM_VARIABLEP (var
))
404 SCM_VARIABLE_SET (var
, val
);
405 return SCM_UNSPECIFIED
;
409 while (scm_is_pair (env
))
412 (scm_memoize_variable_access_x (x
, CAPTURE_ENV (env
)),
414 return SCM_UNSPECIFIED
;
418 case SCM_M_MODULE_REF
:
419 if (SCM_VARIABLEP (mx
))
420 return SCM_VARIABLE_REF (mx
);
422 return SCM_VARIABLE_REF
423 (scm_memoize_variable_access_x (x
, SCM_BOOL_F
));
425 case SCM_M_MODULE_SET
:
426 if (SCM_VARIABLEP (CDR (mx
)))
428 SCM_VARIABLE_SET (CDR (mx
), EVAL1 (CAR (mx
), env
));
429 return SCM_UNSPECIFIED
;
434 (scm_memoize_variable_access_x (x
, SCM_BOOL_F
),
435 EVAL1 (CAR (mx
), env
));
436 return SCM_UNSPECIFIED
;
442 /* We need the prompt and handler values after a longjmp case,
443 so make sure they are volatile. */
444 volatile SCM handler
, prompt
;
447 prompt
= scm_c_make_prompt (EVAL1 (CAR (mx
), env
),
448 SCM_VM_DATA (vm
)->fp
,
449 SCM_VM_DATA (vm
)->sp
, SCM_VM_DATA (vm
)->ip
,
450 0, -1, scm_i_dynwinds ());
451 handler
= EVAL1 (CDDR (mx
), env
);
452 scm_i_set_dynwinds (scm_cons (prompt
, scm_i_dynwinds ()));
454 if (SCM_PROMPT_SETJMP (prompt
))
456 /* The prompt exited nonlocally. */
458 args
= scm_i_prompt_pop_abort_args_x (scm_the_vm ());
462 res
= eval (CADR (mx
), env
);
463 scm_i_set_dynwinds (CDR (scm_i_dynwinds ()));
474 /* Simple procedure calls
478 scm_call_0 (SCM proc
)
480 return scm_c_vm_run (scm_the_vm (), proc
, NULL
, 0);
484 scm_call_1 (SCM proc
, SCM arg1
)
486 return scm_c_vm_run (scm_the_vm (), proc
, &arg1
, 1);
490 scm_call_2 (SCM proc
, SCM arg1
, SCM arg2
)
492 SCM args
[] = { arg1
, arg2
};
493 return scm_c_vm_run (scm_the_vm (), proc
, args
, 2);
497 scm_call_3 (SCM proc
, SCM arg1
, SCM arg2
, SCM arg3
)
499 SCM args
[] = { arg1
, arg2
, arg3
};
500 return scm_c_vm_run (scm_the_vm (), proc
, args
, 3);
504 scm_call_4 (SCM proc
, SCM arg1
, SCM arg2
, SCM arg3
, SCM arg4
)
506 SCM args
[] = { arg1
, arg2
, arg3
, arg4
};
507 return scm_c_vm_run (scm_the_vm (), proc
, args
, 4);
511 scm_call_5 (SCM proc
, SCM arg1
, SCM arg2
, SCM arg3
, SCM arg4
, SCM arg5
)
513 SCM args
[] = { arg1
, arg2
, arg3
, arg4
, arg5
};
514 return scm_c_vm_run (scm_the_vm (), proc
, args
, 5);
518 scm_call_6 (SCM proc
, SCM arg1
, SCM arg2
, SCM arg3
, SCM arg4
, SCM arg5
,
521 SCM args
[] = { arg1
, arg2
, arg3
, arg4
, arg5
, arg6
};
522 return scm_c_vm_run (scm_the_vm (), proc
, args
, 6);
526 scm_call_7 (SCM proc
, SCM arg1
, SCM arg2
, SCM arg3
, SCM arg4
, SCM arg5
,
529 SCM args
[] = { arg1
, arg2
, arg3
, arg4
, arg5
, arg6
, arg7
};
530 return scm_c_vm_run (scm_the_vm (), proc
, args
, 7);
534 scm_call_8 (SCM proc
, SCM arg1
, SCM arg2
, SCM arg3
, SCM arg4
, SCM arg5
,
535 SCM arg6
, SCM arg7
, SCM arg8
)
537 SCM args
[] = { arg1
, arg2
, arg3
, arg4
, arg5
, arg6
, arg7
, arg8
};
538 return scm_c_vm_run (scm_the_vm (), proc
, args
, 8);
542 scm_call_9 (SCM proc
, SCM arg1
, SCM arg2
, SCM arg3
, SCM arg4
, SCM arg5
,
543 SCM arg6
, SCM arg7
, SCM arg8
, SCM arg9
)
545 SCM args
[] = { arg1
, arg2
, arg3
, arg4
, arg5
, arg6
, arg7
, arg8
, arg9
};
546 return scm_c_vm_run (scm_the_vm (), proc
, args
, 9);
550 scm_call_n (SCM proc
, SCM
*argv
, size_t nargs
)
552 return scm_c_vm_run (scm_the_vm (), proc
, argv
, nargs
);
556 scm_call (SCM proc
, ...)
562 va_start (argp
, proc
);
563 while (!SCM_UNBNDP (va_arg (argp
, SCM
)))
567 argv
= alloca (nargs
* sizeof (SCM
));
568 va_start (argp
, proc
);
569 for (i
= 0; i
< nargs
; i
++)
570 argv
[i
] = va_arg (argp
, SCM
);
573 return scm_c_vm_run (scm_the_vm (), proc
, argv
, nargs
);
576 /* Simple procedure applies
580 scm_apply_0 (SCM proc
, SCM args
)
582 return scm_apply (proc
, args
, SCM_EOL
);
586 scm_apply_1 (SCM proc
, SCM arg1
, SCM args
)
588 return scm_apply (proc
, scm_cons (arg1
, args
), SCM_EOL
);
592 scm_apply_2 (SCM proc
, SCM arg1
, SCM arg2
, SCM args
)
594 return scm_apply (proc
, scm_cons2 (arg1
, arg2
, args
), SCM_EOL
);
598 scm_apply_3 (SCM proc
, SCM arg1
, SCM arg2
, SCM arg3
, SCM args
)
600 return scm_apply (proc
, scm_cons (arg1
, scm_cons2 (arg2
, arg3
, args
)),
604 /* This code processes the arguments to apply:
606 (apply PROC ARG1 ... ARGS)
608 Given a list (ARG1 ... ARGS), this function conses the ARG1
609 ... arguments onto the front of ARGS, and returns the resulting
610 list. Note that ARGS is a list; thus, the argument to this
611 function is a list whose last element is a list.
613 Apply calls this function, and applies PROC to the elements of the
614 result. apply:nconc2last takes care of building the list of
615 arguments, given (ARG1 ... ARGS).
617 Rather than do new consing, apply:nconc2last destroys its argument.
618 On that topic, this code came into my care with the following
619 beautifully cryptic comment on that topic: "This will only screw
620 you if you do (scm_apply scm_apply '( ... ))" If you know what
621 they're referring to, send me a patch to this comment. */
623 SCM_DEFINE (scm_nconc2last
, "apply:nconc2last", 1, 0, 0,
625 "Given a list (@var{arg1} @dots{} @var{args}), this function\n"
626 "conses the @var{arg1} @dots{} arguments onto the front of\n"
627 "@var{args}, and returns the resulting list. Note that\n"
628 "@var{args} is a list; thus, the argument to this function is\n"
629 "a list whose last element is a list.\n"
630 "Note: Rather than do new consing, @code{apply:nconc2last}\n"
631 "destroys its argument, so use with care.")
632 #define FUNC_NAME s_scm_nconc2last
635 SCM_VALIDATE_NONEMPTYLIST (1, lst
);
637 while (!scm_is_null (SCM_CDR (*lloc
)))
638 lloc
= SCM_CDRLOC (*lloc
);
639 SCM_ASSERT (scm_ilength (SCM_CAR (*lloc
)) >= 0, lst
, SCM_ARG1
, FUNC_NAME
);
640 *lloc
= SCM_CAR (*lloc
);
645 static SCM map_var
, for_each_var
;
647 static void init_map_var (void)
649 map_var
= scm_private_variable (scm_the_root_module (),
650 scm_from_latin1_symbol ("map"));
653 static void init_for_each_var (void)
655 for_each_var
= scm_private_variable (scm_the_root_module (),
656 scm_from_latin1_symbol ("for-each"));
660 scm_map (SCM proc
, SCM arg1
, SCM args
)
662 static scm_i_pthread_once_t once
= SCM_I_PTHREAD_ONCE_INIT
;
663 scm_i_pthread_once (&once
, init_map_var
);
665 return scm_apply (scm_variable_ref (map_var
),
666 scm_cons (proc
, scm_cons (arg1
, args
)), SCM_EOL
);
670 scm_for_each (SCM proc
, SCM arg1
, SCM args
)
672 static scm_i_pthread_once_t once
= SCM_I_PTHREAD_ONCE_INIT
;
673 scm_i_pthread_once (&once
, init_for_each_var
);
675 return scm_apply (scm_variable_ref (for_each_var
),
676 scm_cons (proc
, scm_cons (arg1
, args
)), SCM_EOL
);
681 scm_c_primitive_eval (SCM exp
)
683 if (!SCM_EXPANDED_P (exp
))
684 exp
= scm_call_1 (scm_current_module_transformer (), exp
);
685 return eval (scm_memoize_expression (exp
), SCM_EOL
);
688 static SCM var_primitive_eval
;
690 scm_primitive_eval (SCM exp
)
692 return scm_c_vm_run (scm_the_vm (), scm_variable_ref (var_primitive_eval
),
697 /* Eval does not take the second arg optionally. This is intentional
698 * in order to be R5RS compatible, and to prepare for the new module
699 * system, where we would like to make the choice of evaluation
700 * environment explicit. */
702 SCM_DEFINE (scm_eval
, "eval", 2, 0, 0,
703 (SCM exp
, SCM module_or_state
),
704 "Evaluate @var{exp}, a list representing a Scheme expression,\n"
705 "in the top-level environment specified by\n"
706 "@var{module_or_state}.\n"
707 "While @var{exp} is evaluated (using @code{primitive-eval}),\n"
708 "@var{module_or_state} is made the current module when\n"
709 "it is a module, or the current dynamic state when it is\n"
711 "Example: (eval '(+ 1 2) (interaction-environment))")
712 #define FUNC_NAME s_scm_eval
716 scm_dynwind_begin (SCM_F_DYNWIND_REWINDABLE
);
717 if (scm_is_dynamic_state (module_or_state
))
718 scm_dynwind_current_dynamic_state (module_or_state
);
719 else if (scm_module_system_booted_p
)
721 SCM_VALIDATE_MODULE (2, module_or_state
);
722 scm_dynwind_current_module (module_or_state
);
724 /* otherwise if the module system isn't booted, ignore the module arg */
726 res
= scm_primitive_eval (exp
);
736 /* Apply a function to a list of arguments.
738 This function is exported to the Scheme level as taking two
739 required arguments and a tail argument, as if it were:
740 (lambda (proc arg1 . args) ...)
741 Thus, if you just have a list of arguments to pass to a procedure,
742 pass the list as ARG1, and '() for ARGS. If you have some fixed
743 args, pass the first as ARG1, then cons any remaining fixed args
744 onto the front of your argument list, and pass that as ARGS. */
747 scm_apply (SCM proc
, SCM arg1
, SCM args
)
749 /* Fix things up so that args contains all args. */
750 if (scm_is_null (args
))
753 args
= scm_cons_star (arg1
, args
);
755 return scm_call_with_vm (scm_the_vm (), proc
, args
);
759 prepare_boot_closure_env_for_apply (SCM proc
, SCM args
,
760 SCM
*out_body
, SCM
*out_env
)
762 int nreq
= BOOT_CLOSURE_NUM_REQUIRED_ARGS (proc
);
763 SCM env
= BOOT_CLOSURE_ENV (proc
);
765 if (BOOT_CLOSURE_IS_FIXED (proc
)
766 || (BOOT_CLOSURE_IS_REST (proc
)
767 && !BOOT_CLOSURE_HAS_REST_ARGS (proc
)))
769 if (SCM_UNLIKELY (scm_ilength (args
) != nreq
))
770 scm_wrong_num_args (proc
);
771 for (; scm_is_pair (args
); args
= CDR (args
))
772 env
= scm_cons (CAR (args
), env
);
773 *out_body
= BOOT_CLOSURE_BODY (proc
);
776 else if (BOOT_CLOSURE_IS_REST (proc
))
778 if (SCM_UNLIKELY (scm_ilength (args
) < nreq
))
779 scm_wrong_num_args (proc
);
780 for (; nreq
; nreq
--, args
= CDR (args
))
781 env
= scm_cons (CAR (args
), env
);
782 env
= scm_cons (args
, env
);
783 *out_body
= BOOT_CLOSURE_BODY (proc
);
788 int i
, argc
, nreq
, nopt
;
789 SCM body
, rest
, kw
, inits
, alt
;
790 SCM mx
= BOOT_CLOSURE_CODE (proc
);
793 BOOT_CLOSURE_PARSE_FULL (mx
, body
, nargs
, rest
, nopt
, kw
, inits
, alt
);
795 argc
= scm_ilength (args
);
798 if (scm_is_true (alt
))
804 scm_wrong_num_args (proc
);
806 if (scm_is_false (kw
) && argc
> nreq
+ nopt
&& scm_is_false (rest
))
808 if (scm_is_true (alt
))
814 scm_wrong_num_args (proc
);
817 for (i
= 0; i
< nreq
; i
++, args
= CDR (args
))
818 env
= scm_cons (CAR (args
), env
);
820 if (scm_is_false (kw
))
822 /* Optional args (possibly), but no keyword args. */
823 for (; i
< argc
&& i
< nreq
+ nopt
;
824 i
++, args
= CDR (args
))
826 env
= scm_cons (CAR (args
), env
);
830 for (; i
< nreq
+ nopt
; i
++, inits
= CDR (inits
))
831 env
= scm_cons (EVAL1 (CAR (inits
), env
), env
);
833 if (scm_is_true (rest
))
834 env
= scm_cons (args
, env
);
843 /* Keyword args. As before, but stop at the first keyword. */
844 for (; i
< argc
&& i
< nreq
+ nopt
&& !scm_is_keyword (CAR (args
));
845 i
++, args
= CDR (args
), inits
= CDR (inits
))
846 env
= scm_cons (CAR (args
), env
);
848 for (; i
< nreq
+ nopt
; i
++, inits
= CDR (inits
))
849 env
= scm_cons (EVAL1 (CAR (inits
), env
), env
);
851 if (scm_is_true (rest
))
853 env
= scm_cons (args
, env
);
856 else if (scm_is_true (alt
)
857 && scm_is_pair (args
) && !scm_is_keyword (CAR (args
)))
859 /* Too many positional args, no rest arg, and we have an
865 /* Now fill in env with unbound values, limn the rest of the args for
866 keywords, and fill in unbound values with their inits. */
869 int kw_start_idx
= i
;
871 for (walk
= kw
; scm_is_pair (walk
); walk
= CDR (walk
))
872 if (SCM_I_INUM (CDAR (walk
)) > imax
)
873 imax
= SCM_I_INUM (CDAR (walk
));
874 for (; i
<= imax
; i
++)
875 env
= scm_cons (SCM_UNDEFINED
, env
);
877 if (scm_is_pair (args
) && scm_is_pair (CDR (args
)))
878 for (; scm_is_pair (args
) && scm_is_pair (CDR (args
));
881 k
= CAR (args
); v
= CADR (args
);
882 if (!scm_is_keyword (k
))
884 if (scm_is_true (rest
))
889 for (walk
= kw
; scm_is_pair (walk
); walk
= CDR (walk
))
890 if (scm_is_eq (k
, CAAR (walk
)))
892 /* Well... ok, list-set! isn't the nicest interface, but
894 int iset
= imax
- SCM_I_INUM (CDAR (walk
));
895 scm_list_set_x (env
, SCM_I_MAKINUM (iset
), v
);
899 if (scm_is_null (walk
) && scm_is_false (aok
))
900 error_unrecognized_keyword (proc
, k
);
902 if (scm_is_pair (args
) && scm_is_false (rest
))
903 error_invalid_keyword (proc
, CAR (args
));
905 /* Now fill in unbound values, evaluating init expressions in their
906 appropriate environment. */
907 for (i
= imax
- kw_start_idx
; scm_is_pair (inits
); i
--, inits
= CDR (inits
))
909 SCM tail
= scm_list_tail (env
, SCM_I_MAKINUM (i
));
910 if (SCM_UNBNDP (CAR (tail
)))
911 SCM_SETCAR (tail
, EVAL1 (CAR (inits
), CDR (tail
)));
922 prepare_boot_closure_env_for_eval (SCM proc
, unsigned int argc
,
923 SCM exps
, SCM
*out_body
, SCM
*inout_env
)
925 int nreq
= BOOT_CLOSURE_NUM_REQUIRED_ARGS (proc
);
926 SCM new_env
= BOOT_CLOSURE_ENV (proc
);
927 if (BOOT_CLOSURE_IS_FIXED (proc
)
928 || (BOOT_CLOSURE_IS_REST (proc
)
929 && !BOOT_CLOSURE_HAS_REST_ARGS (proc
)))
931 for (; scm_is_pair (exps
); exps
= CDR (exps
), nreq
--)
932 new_env
= scm_cons (EVAL1 (CAR (exps
), *inout_env
),
934 if (SCM_UNLIKELY (nreq
!= 0))
935 scm_wrong_num_args (proc
);
936 *out_body
= BOOT_CLOSURE_BODY (proc
);
937 *inout_env
= new_env
;
939 else if (BOOT_CLOSURE_IS_REST (proc
))
941 if (SCM_UNLIKELY (argc
< nreq
))
942 scm_wrong_num_args (proc
);
943 for (; nreq
; nreq
--, exps
= CDR (exps
))
944 new_env
= scm_cons (EVAL1 (CAR (exps
), *inout_env
),
948 for (; scm_is_pair (exps
); exps
= CDR (exps
))
949 rest
= scm_cons (EVAL1 (CAR (exps
), *inout_env
), rest
);
950 new_env
= scm_cons (scm_reverse (rest
),
953 *out_body
= BOOT_CLOSURE_BODY (proc
);
954 *inout_env
= new_env
;
959 for (; scm_is_pair (exps
); exps
= CDR (exps
))
960 args
= scm_cons (EVAL1 (CAR (exps
), *inout_env
), args
);
961 args
= scm_reverse_x (args
, SCM_UNDEFINED
);
962 prepare_boot_closure_env_for_apply (proc
, args
, out_body
, inout_env
);
967 boot_closure_apply (SCM closure
, SCM args
)
970 prepare_boot_closure_env_for_apply (closure
, args
, &body
, &env
);
971 return eval (body
, env
);
975 boot_closure_print (SCM closure
, SCM port
, scm_print_state
*pstate
)
978 scm_puts ("#<boot-closure ", port
);
979 scm_uintprint ((scm_t_bits
)SCM2PTR (closure
), 16, port
);
980 scm_putc (' ', port
);
981 args
= scm_make_list (scm_from_int (BOOT_CLOSURE_NUM_REQUIRED_ARGS (closure
)),
982 scm_from_latin1_symbol ("_"));
983 if (!BOOT_CLOSURE_IS_FIXED (closure
) && BOOT_CLOSURE_HAS_REST_ARGS (closure
))
984 args
= scm_cons_star (scm_from_latin1_symbol ("_"), args
);
985 /* FIXME: optionals and rests */
986 scm_display (args
, port
);
987 scm_putc ('>', port
);
996 f_apply
= scm_c_define_gsubr ("apply", 2, 0, 1, scm_apply
);
998 scm_tc16_boot_closure
= scm_make_smob_type ("boot-closure", 0);
999 scm_set_smob_apply (scm_tc16_boot_closure
, boot_closure_apply
, 0, 0, 1);
1000 scm_set_smob_print (scm_tc16_boot_closure
, boot_closure_print
);
1002 primitive_eval
= scm_c_make_gsubr ("primitive-eval", 1, 0, 0,
1003 scm_c_primitive_eval
);
1004 var_primitive_eval
= scm_define (SCM_SUBR_NAME (primitive_eval
),
1007 #include "libguile/eval.x"