1 /* Copyright (C) 1995,1996,1997,1998,1999,2000,2001,2002,2003,2004,2005,2006,2007,2008,2009,2010
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) SCM_RETURN_NEWSMOB2 (scm_tc16_boot_closure, (code), (env))
106 #define BOOT_CLOSURE_P(obj) SCM_TYP16_PREDICATE (scm_tc16_boot_closure, (obj))
107 #define BOOT_CLOSURE_CODE(x) SCM_SMOB_OBJECT (x)
108 #define BOOT_CLOSURE_ENV(x) SCM_SMOB_OBJECT_2 (x)
109 #define BOOT_CLOSURE_BODY(x) CAR (BOOT_CLOSURE_CODE (x))
110 #define BOOT_CLOSURE_NUM_REQUIRED_ARGS(x) SCM_I_INUM (CADR (BOOT_CLOSURE_CODE (x)))
111 #define BOOT_CLOSURE_IS_FIXED(x) scm_is_null (CDDR (BOOT_CLOSURE_CODE (x)))
112 /* NB: One may only call the following accessors if the closure is not FIXED. */
113 #define BOOT_CLOSURE_HAS_REST_ARGS(x) scm_is_true (CADDR (BOOT_CLOSURE_CODE (x)))
114 #define BOOT_CLOSURE_IS_REST(x) scm_is_null (CDDDR (BOOT_CLOSURE_CODE (x)))
115 /* NB: One may only call the following accessors if the closure is not REST. */
116 #define BOOT_CLOSURE_IS_FULL(x) (1)
117 #define BOOT_CLOSURE_PARSE_FULL(fu_,body,nargs,rest,nopt,kw,inits,alt) \
119 body = CAR (fu); fu = CDR (fu); \
121 rest = kw = alt = SCM_BOOL_F; \
125 nreq = SCM_I_INUM (CAR (fu)); fu = CDR (fu); \
126 if (scm_is_pair (fu)) \
128 rest = CAR (fu); fu = CDR (fu); \
129 if (scm_is_pair (fu)) \
131 nopt = SCM_I_INUM (CAR (fu)); fu = CDR (fu); \
132 kw = CAR (fu); fu = CDR (fu); \
133 inits = CAR (fu); fu = CDR (fu); \
138 static void prepare_boot_closure_env_for_apply (SCM proc
, SCM args
,
139 SCM
*out_body
, SCM
*out_env
);
140 static void prepare_boot_closure_env_for_eval (SCM proc
, unsigned int argc
,
141 SCM exps
, SCM
*out_body
,
145 #define CAR(x) SCM_CAR(x)
146 #define CDR(x) SCM_CDR(x)
147 #define CAAR(x) SCM_CAAR(x)
148 #define CADR(x) SCM_CADR(x)
149 #define CDAR(x) SCM_CDAR(x)
150 #define CDDR(x) SCM_CDDR(x)
151 #define CADDR(x) SCM_CADDR(x)
152 #define CDDDR(x) SCM_CDDDR(x)
155 SCM_SYMBOL (scm_unbound_variable_key
, "unbound-variable");
157 static void error_used_before_defined (void)
159 scm_error (scm_unbound_variable_key
, NULL
,
160 "Variable used before given a value", SCM_EOL
, SCM_BOOL_F
);
163 static void error_invalid_keyword (SCM proc
)
165 scm_error_scm (scm_from_locale_symbol ("keyword-argument-error"), proc
,
166 scm_from_locale_string ("Invalid keyword"), SCM_EOL
,
170 static void error_unrecognized_keyword (SCM proc
)
172 scm_error_scm (scm_from_locale_symbol ("keyword-argument-error"), proc
,
173 scm_from_locale_string ("Unrecognized keyword"), SCM_EOL
,
180 If MOD is #f, it means the environment was captured before modules were
182 If MOD is the literal value '(), we are evaluating at the top level, and so
183 should track changes to the current module. You have to be careful in this
184 case, because further lexical contours should capture the current module.
186 #define CAPTURE_ENV(env) \
187 ((env == SCM_EOL) ? scm_current_module () : \
188 ((env == SCM_BOOL_F) ? scm_the_root_module () : env))
191 eval (SCM x
, SCM env
)
194 SCM proc
= SCM_UNDEFINED
, args
= SCM_EOL
;
199 if (!SCM_MEMOIZED_P (x
))
202 mx
= SCM_MEMOIZED_ARGS (x
);
203 switch (SCM_MEMOIZED_TAG (x
))
206 for (; !scm_is_null (CDR (mx
)); mx
= CDR (mx
))
207 eval (CAR (mx
), env
);
212 if (scm_is_true (eval (CAR (mx
), env
)))
220 SCM inits
= CAR (mx
);
221 SCM new_env
= CAPTURE_ENV (env
);
222 for (; scm_is_pair (inits
); inits
= CDR (inits
))
223 new_env
= scm_cons (eval (CAR (inits
), env
), new_env
);
230 RETURN_BOOT_CLOSURE (mx
, CAPTURE_ENV (env
));
236 scm_define (CAR (mx
), eval (CDR (mx
), env
));
237 return SCM_UNSPECIFIED
;
241 SCM in
, out
, res
, old_winds
;
242 in
= eval (CAR (mx
), env
);
243 out
= eval (CDDR (mx
), env
);
245 old_winds
= scm_i_dynwinds ();
246 scm_i_set_dynwinds (scm_acons (in
, out
, old_winds
));
247 res
= eval (CADR (mx
), env
);
248 scm_i_set_dynwinds (old_winds
);
253 case SCM_M_WITH_FLUIDS
:
256 SCM
*fluidv
, *valuesv
, walk
, wf
, res
;
257 len
= scm_ilength (CAR (mx
));
258 fluidv
= alloca (sizeof (SCM
)*len
);
259 for (i
= 0, walk
= CAR (mx
); i
< len
; i
++, walk
= CDR (walk
))
260 fluidv
[i
] = eval (CAR (walk
), env
);
261 valuesv
= alloca (sizeof (SCM
)*len
);
262 for (i
= 0, walk
= CADR (mx
); i
< len
; i
++, walk
= CDR (walk
))
263 valuesv
[i
] = eval (CAR (walk
), env
);
265 wf
= scm_i_make_with_fluids (len
, fluidv
, valuesv
);
266 scm_i_swap_with_fluids (wf
, SCM_I_CURRENT_THREAD
->dynamic_state
);
267 scm_i_set_dynwinds (scm_cons (wf
, scm_i_dynwinds ()));
268 res
= eval (CDDR (mx
), env
);
269 scm_i_swap_with_fluids (wf
, SCM_I_CURRENT_THREAD
->dynamic_state
);
270 scm_i_set_dynwinds (CDR (scm_i_dynwinds ()));
276 /* Evaluate the procedure to be applied. */
277 proc
= eval (CAR (mx
), env
);
278 /* Evaluate the argument holding the list of arguments */
279 args
= eval (CADR (mx
), env
);
282 /* Go here to tail-apply a procedure. PROC is the procedure and
283 * ARGS is the list of arguments. */
284 if (BOOT_CLOSURE_P (proc
))
286 prepare_boot_closure_env_for_apply (proc
, args
, &x
, &env
);
290 return scm_call_with_vm (scm_the_vm (), proc
, args
);
293 /* Evaluate the procedure to be applied. */
294 proc
= eval (CAR (mx
), env
);
295 argc
= SCM_I_INUM (CADR (mx
));
298 if (BOOT_CLOSURE_P (proc
))
300 prepare_boot_closure_env_for_eval (proc
, argc
, mx
, &x
, &env
);
308 argv
= alloca (argc
* sizeof (SCM
));
309 for (i
= 0; i
< argc
; i
++, mx
= CDR (mx
))
310 argv
[i
] = eval (CAR (mx
), env
);
312 return scm_c_vm_run (scm_the_vm (), proc
, argv
, argc
);
316 return scm_i_call_with_current_continuation (eval (mx
, env
));
318 case SCM_M_CALL_WITH_VALUES
:
323 producer
= eval (CAR (mx
), env
);
324 proc
= eval (CDR (mx
), env
); /* proc is the consumer. */
325 v
= scm_call_with_vm (scm_the_vm (), producer
, SCM_EOL
);
327 args
= scm_struct_ref (v
, SCM_INUM0
);
329 args
= scm_list_1 (v
);
333 case SCM_M_LEXICAL_REF
:
337 for (n
= SCM_I_INUM (mx
); n
; n
--)
340 if (SCM_UNLIKELY (SCM_UNBNDP (ret
)))
341 /* we don't know what variable, though, because we don't have its
343 error_used_before_defined ();
347 case SCM_M_LEXICAL_SET
:
350 SCM val
= eval (CDR (mx
), env
);
351 for (n
= SCM_I_INUM (CAR (mx
)); n
; n
--)
353 SCM_SETCAR (env
, val
);
354 return SCM_UNSPECIFIED
;
357 case SCM_M_TOPLEVEL_REF
:
358 if (SCM_VARIABLEP (mx
))
359 return SCM_VARIABLE_REF (mx
);
362 while (scm_is_pair (env
))
364 return SCM_VARIABLE_REF
365 (scm_memoize_variable_access_x (x
, CAPTURE_ENV (env
)));
368 case SCM_M_TOPLEVEL_SET
:
371 SCM val
= eval (CDR (mx
), env
);
372 if (SCM_VARIABLEP (var
))
374 SCM_VARIABLE_SET (var
, val
);
375 return SCM_UNSPECIFIED
;
379 while (scm_is_pair (env
))
382 (scm_memoize_variable_access_x (x
, CAPTURE_ENV (env
)),
384 return SCM_UNSPECIFIED
;
388 case SCM_M_MODULE_REF
:
389 if (SCM_VARIABLEP (mx
))
390 return SCM_VARIABLE_REF (mx
);
392 return SCM_VARIABLE_REF
393 (scm_memoize_variable_access_x (x
, SCM_BOOL_F
));
395 case SCM_M_MODULE_SET
:
396 if (SCM_VARIABLEP (CDR (mx
)))
398 SCM_VARIABLE_SET (CDR (mx
), eval (CAR (mx
), env
));
399 return SCM_UNSPECIFIED
;
404 (scm_memoize_variable_access_x (x
, SCM_BOOL_F
),
405 eval (CAR (mx
), env
));
406 return SCM_UNSPECIFIED
;
411 SCM vm
, prompt
, handler
, res
;
414 prompt
= scm_c_make_prompt (eval (CAR (mx
), env
), SCM_VM_DATA (vm
)->fp
,
415 SCM_VM_DATA (vm
)->sp
, SCM_VM_DATA (vm
)->ip
,
416 0, -1, scm_i_dynwinds ());
417 handler
= eval (CDDR (mx
), env
);
418 scm_i_set_dynwinds (scm_cons (prompt
, scm_i_dynwinds ()));
420 if (SCM_PROMPT_SETJMP (prompt
))
422 /* The prompt exited nonlocally. */
424 args
= scm_i_prompt_pop_abort_args_x (prompt
);
428 res
= eval (CADR (mx
), env
);
429 scm_i_set_dynwinds (CDR (scm_i_dynwinds ()));
440 /* Simple procedure calls
444 scm_call_0 (SCM proc
)
446 return scm_c_vm_run (scm_the_vm (), proc
, NULL
, 0);
450 scm_call_1 (SCM proc
, SCM arg1
)
452 return scm_c_vm_run (scm_the_vm (), proc
, &arg1
, 1);
456 scm_call_2 (SCM proc
, SCM arg1
, SCM arg2
)
458 SCM args
[] = { arg1
, arg2
};
459 return scm_c_vm_run (scm_the_vm (), proc
, args
, 2);
463 scm_call_3 (SCM proc
, SCM arg1
, SCM arg2
, SCM arg3
)
465 SCM args
[] = { arg1
, arg2
, arg3
};
466 return scm_c_vm_run (scm_the_vm (), proc
, args
, 3);
470 scm_call_4 (SCM proc
, SCM arg1
, SCM arg2
, SCM arg3
, SCM arg4
)
472 SCM args
[] = { arg1
, arg2
, arg3
, arg4
};
473 return scm_c_vm_run (scm_the_vm (), proc
, args
, 4);
477 scm_call_n (SCM proc
, SCM
*argv
, size_t nargs
)
479 return scm_c_vm_run (scm_the_vm (), proc
, argv
, nargs
);
482 /* Simple procedure applies
486 scm_apply_0 (SCM proc
, SCM args
)
488 return scm_apply (proc
, args
, SCM_EOL
);
492 scm_apply_1 (SCM proc
, SCM arg1
, SCM args
)
494 return scm_apply (proc
, scm_cons (arg1
, args
), SCM_EOL
);
498 scm_apply_2 (SCM proc
, SCM arg1
, SCM arg2
, SCM args
)
500 return scm_apply (proc
, scm_cons2 (arg1
, arg2
, args
), SCM_EOL
);
504 scm_apply_3 (SCM proc
, SCM arg1
, SCM arg2
, SCM arg3
, SCM args
)
506 return scm_apply (proc
, scm_cons (arg1
, scm_cons2 (arg2
, arg3
, args
)),
510 /* This code processes the arguments to apply:
512 (apply PROC ARG1 ... ARGS)
514 Given a list (ARG1 ... ARGS), this function conses the ARG1
515 ... arguments onto the front of ARGS, and returns the resulting
516 list. Note that ARGS is a list; thus, the argument to this
517 function is a list whose last element is a list.
519 Apply calls this function, and applies PROC to the elements of the
520 result. apply:nconc2last takes care of building the list of
521 arguments, given (ARG1 ... ARGS).
523 Rather than do new consing, apply:nconc2last destroys its argument.
524 On that topic, this code came into my care with the following
525 beautifully cryptic comment on that topic: "This will only screw
526 you if you do (scm_apply scm_apply '( ... ))" If you know what
527 they're referring to, send me a patch to this comment. */
529 SCM_DEFINE (scm_nconc2last
, "apply:nconc2last", 1, 0, 0,
531 "Given a list (@var{arg1} @dots{} @var{args}), this function\n"
532 "conses the @var{arg1} @dots{} arguments onto the front of\n"
533 "@var{args}, and returns the resulting list. Note that\n"
534 "@var{args} is a list; thus, the argument to this function is\n"
535 "a list whose last element is a list.\n"
536 "Note: Rather than do new consing, @code{apply:nconc2last}\n"
537 "destroys its argument, so use with care.")
538 #define FUNC_NAME s_scm_nconc2last
541 SCM_VALIDATE_NONEMPTYLIST (1, lst
);
543 while (!scm_is_null (SCM_CDR (*lloc
))) /* Perhaps should be
544 SCM_NULL_OR_NIL_P, but not
545 needed in 99.99% of cases,
546 and it could seriously hurt
547 performance. - Neil */
548 lloc
= SCM_CDRLOC (*lloc
);
549 SCM_ASSERT (scm_ilength (SCM_CAR (*lloc
)) >= 0, lst
, SCM_ARG1
, FUNC_NAME
);
550 *lloc
= SCM_CAR (*lloc
);
557 /* Typechecking for multi-argument MAP and FOR-EACH.
559 Verify that each element of the vector ARGV, except for the first,
560 is a proper list whose length is LEN. Attribute errors to WHO,
561 and claim that the i'th element of ARGV is WHO's i+2'th argument. */
563 check_map_args (SCM argv
,
572 for (i
= SCM_SIMPLE_VECTOR_LENGTH (argv
) - 1; i
>= 1; i
--)
574 SCM elt
= SCM_SIMPLE_VECTOR_REF (argv
, i
);
575 long elt_len
= scm_ilength (elt
);
580 scm_apply_generic (gf
, scm_cons (proc
, args
));
582 scm_wrong_type_arg (who
, i
+ 2, elt
);
586 scm_out_of_range_pos (who
, elt
, scm_from_long (i
+ 2));
591 SCM_GPROC (s_map
, "map", 2, 0, 1, scm_map
, g_map
);
593 /* Note: Currently, scm_map applies PROC to the argument list(s)
594 sequentially, starting with the first element(s). This is used in
595 evalext.c where the Scheme procedure `map-in-order', which guarantees
596 sequential behaviour, is implemented using scm_map. If the
597 behaviour changes, we need to update `map-in-order'.
601 scm_map (SCM proc
, SCM arg1
, SCM args
)
602 #define FUNC_NAME s_map
608 len
= scm_ilength (arg1
);
609 SCM_GASSERTn (len
>= 0,
610 g_map
, scm_cons2 (proc
, arg1
, args
), SCM_ARG2
, s_map
);
611 SCM_VALIDATE_REST_ARGUMENT (args
);
612 if (scm_is_null (args
))
614 SCM_GASSERT2 (scm_is_true (scm_procedure_p (proc
)), g_map
, proc
, arg1
, SCM_ARG1
, s_map
);
615 while (SCM_NIMP (arg1
))
617 *pres
= scm_list_1 (scm_call_1 (proc
, SCM_CAR (arg1
)));
618 pres
= SCM_CDRLOC (*pres
);
619 arg1
= SCM_CDR (arg1
);
623 if (scm_is_null (SCM_CDR (args
)))
625 SCM arg2
= SCM_CAR (args
);
626 int len2
= scm_ilength (arg2
);
627 SCM_GASSERTn (scm_is_true (scm_procedure_p (proc
)), g_map
,
628 scm_cons2 (proc
, arg1
, args
), SCM_ARG1
, s_map
);
629 SCM_GASSERTn (len2
>= 0,
630 g_map
, scm_cons2 (proc
, arg1
, args
), SCM_ARG3
, s_map
);
632 SCM_OUT_OF_RANGE (3, arg2
);
633 while (SCM_NIMP (arg1
))
635 *pres
= scm_list_1 (scm_call_2 (proc
, SCM_CAR (arg1
), SCM_CAR (arg2
)));
636 pres
= SCM_CDRLOC (*pres
);
637 arg1
= SCM_CDR (arg1
);
638 arg2
= SCM_CDR (arg2
);
642 arg1
= scm_cons (arg1
, args
);
643 args
= scm_vector (arg1
);
644 check_map_args (args
, len
, g_map
, proc
, arg1
, s_map
);
648 for (i
= SCM_SIMPLE_VECTOR_LENGTH (args
) - 1; i
>= 0; i
--)
650 SCM elt
= SCM_SIMPLE_VECTOR_REF (args
, i
);
653 arg1
= scm_cons (SCM_CAR (elt
), arg1
);
654 SCM_SIMPLE_VECTOR_SET (args
, i
, SCM_CDR (elt
));
656 *pres
= scm_list_1 (scm_apply (proc
, arg1
, SCM_EOL
));
657 pres
= SCM_CDRLOC (*pres
);
663 SCM_GPROC (s_for_each
, "for-each", 2, 0, 1, scm_for_each
, g_for_each
);
666 scm_for_each (SCM proc
, SCM arg1
, SCM args
)
667 #define FUNC_NAME s_for_each
670 len
= scm_ilength (arg1
);
671 SCM_GASSERTn (len
>= 0, g_for_each
, scm_cons2 (proc
, arg1
, args
),
672 SCM_ARG2
, s_for_each
);
673 SCM_VALIDATE_REST_ARGUMENT (args
);
674 if (scm_is_null (args
))
676 SCM_GASSERT2 (scm_is_true (scm_procedure_p (proc
)), g_for_each
,
677 proc
, arg1
, SCM_ARG1
, s_for_each
);
678 while (SCM_NIMP (arg1
))
680 scm_call_1 (proc
, SCM_CAR (arg1
));
681 arg1
= SCM_CDR (arg1
);
683 return SCM_UNSPECIFIED
;
685 if (scm_is_null (SCM_CDR (args
)))
687 SCM arg2
= SCM_CAR (args
);
688 int len2
= scm_ilength (arg2
);
689 SCM_GASSERTn (scm_is_true (scm_procedure_p (proc
)), g_for_each
,
690 scm_cons2 (proc
, arg1
, args
), SCM_ARG1
, s_for_each
);
691 SCM_GASSERTn (len2
>= 0, g_for_each
,
692 scm_cons2 (proc
, arg1
, args
), SCM_ARG3
, s_for_each
);
694 SCM_OUT_OF_RANGE (3, arg2
);
695 while (SCM_NIMP (arg1
))
697 scm_call_2 (proc
, SCM_CAR (arg1
), SCM_CAR (arg2
));
698 arg1
= SCM_CDR (arg1
);
699 arg2
= SCM_CDR (arg2
);
701 return SCM_UNSPECIFIED
;
703 arg1
= scm_cons (arg1
, args
);
704 args
= scm_vector (arg1
);
705 check_map_args (args
, len
, g_for_each
, proc
, arg1
, s_for_each
);
709 for (i
= SCM_SIMPLE_VECTOR_LENGTH (args
) - 1; i
>= 0; i
--)
711 SCM elt
= SCM_SIMPLE_VECTOR_REF (args
, i
);
713 return SCM_UNSPECIFIED
;
714 arg1
= scm_cons (SCM_CAR (elt
), arg1
);
715 SCM_SIMPLE_VECTOR_SET (args
, i
, SCM_CDR (elt
));
717 scm_apply (proc
, arg1
, SCM_EOL
);
724 scm_c_primitive_eval (SCM exp
)
726 if (!SCM_EXPANDED_P (exp
))
727 exp
= scm_call_1 (scm_current_module_transformer (), exp
);
728 return eval (scm_memoize_expression (exp
), SCM_EOL
);
731 static SCM var_primitive_eval
;
733 scm_primitive_eval (SCM exp
)
735 return scm_c_vm_run (scm_the_vm (), scm_variable_ref (var_primitive_eval
),
740 /* Eval does not take the second arg optionally. This is intentional
741 * in order to be R5RS compatible, and to prepare for the new module
742 * system, where we would like to make the choice of evaluation
743 * environment explicit. */
745 SCM_DEFINE (scm_eval
, "eval", 2, 0, 0,
746 (SCM exp
, SCM module_or_state
),
747 "Evaluate @var{exp}, a list representing a Scheme expression,\n"
748 "in the top-level environment specified by\n"
749 "@var{module_or_state}.\n"
750 "While @var{exp} is evaluated (using @code{primitive-eval}),\n"
751 "@var{module_or_state} is made the current module when\n"
752 "it is a module, or the current dynamic state when it is\n"
754 "Example: (eval '(+ 1 2) (interaction-environment))")
755 #define FUNC_NAME s_scm_eval
759 scm_dynwind_begin (SCM_F_DYNWIND_REWINDABLE
);
760 if (scm_is_dynamic_state (module_or_state
))
761 scm_dynwind_current_dynamic_state (module_or_state
);
762 else if (scm_module_system_booted_p
)
764 SCM_VALIDATE_MODULE (2, module_or_state
);
765 scm_dynwind_current_module (module_or_state
);
767 /* otherwise if the module system isn't booted, ignore the module arg */
769 res
= scm_primitive_eval (exp
);
779 /* Apply a function to a list of arguments.
781 This function is exported to the Scheme level as taking two
782 required arguments and a tail argument, as if it were:
783 (lambda (proc arg1 . args) ...)
784 Thus, if you just have a list of arguments to pass to a procedure,
785 pass the list as ARG1, and '() for ARGS. If you have some fixed
786 args, pass the first as ARG1, then cons any remaining fixed args
787 onto the front of your argument list, and pass that as ARGS. */
790 scm_apply (SCM proc
, SCM arg1
, SCM args
)
792 /* Fix things up so that args contains all args. */
793 if (scm_is_null (args
))
796 args
= scm_cons_star (arg1
, args
);
798 return scm_call_with_vm (scm_the_vm (), proc
, args
);
802 prepare_boot_closure_env_for_apply (SCM proc
, SCM args
,
803 SCM
*out_body
, SCM
*out_env
)
805 int nreq
= BOOT_CLOSURE_NUM_REQUIRED_ARGS (proc
);
806 SCM env
= BOOT_CLOSURE_ENV (proc
);
808 if (BOOT_CLOSURE_IS_FIXED (proc
)
809 || (BOOT_CLOSURE_IS_REST (proc
)
810 && !BOOT_CLOSURE_HAS_REST_ARGS (proc
)))
812 if (SCM_UNLIKELY (scm_ilength (args
) != nreq
))
813 scm_wrong_num_args (proc
);
814 for (; scm_is_pair (args
); args
= CDR (args
))
815 env
= scm_cons (CAR (args
), env
);
816 *out_body
= BOOT_CLOSURE_BODY (proc
);
819 else if (BOOT_CLOSURE_IS_REST (proc
))
821 if (SCM_UNLIKELY (scm_ilength (args
) < nreq
))
822 scm_wrong_num_args (proc
);
823 for (; nreq
; nreq
--, args
= CDR (args
))
824 env
= scm_cons (CAR (args
), env
);
825 env
= scm_cons (args
, env
);
826 *out_body
= BOOT_CLOSURE_BODY (proc
);
831 int i
, argc
, nreq
, nopt
;
832 SCM body
, rest
, kw
, inits
, alt
;
833 SCM mx
= BOOT_CLOSURE_CODE (proc
);
836 BOOT_CLOSURE_PARSE_FULL (mx
, body
, nargs
, rest
, nopt
, kw
, inits
, alt
);
838 argc
= scm_ilength (args
);
841 if (scm_is_true (alt
))
847 scm_wrong_num_args (proc
);
849 if (scm_is_false (kw
) && argc
> nreq
+ nopt
&& scm_is_false (rest
))
851 if (scm_is_true (alt
))
857 scm_wrong_num_args (proc
);
860 for (i
= 0; i
< nreq
; i
++, args
= CDR (args
))
861 env
= scm_cons (CAR (args
), env
);
863 if (scm_is_false (kw
))
865 /* Optional args (possibly), but no keyword args. */
866 for (; i
< argc
&& i
< nreq
+ nopt
;
867 i
++, args
= CDR (args
))
869 env
= scm_cons (CAR (args
), env
);
873 for (; i
< nreq
+ nopt
; i
++, inits
= CDR (inits
))
874 env
= scm_cons (eval (CAR (inits
), env
), env
);
876 if (scm_is_true (rest
))
877 env
= scm_cons (args
, env
);
886 /* Keyword args. As before, but stop at the first keyword. */
887 for (; i
< argc
&& i
< nreq
+ nopt
&& !scm_is_keyword (CAR (args
));
888 i
++, args
= CDR (args
), inits
= CDR (inits
))
889 env
= scm_cons (CAR (args
), env
);
891 for (; i
< nreq
+ nopt
; i
++, inits
= CDR (inits
))
892 env
= scm_cons (eval (CAR (inits
), env
), env
);
894 if (scm_is_true (rest
))
896 env
= scm_cons (args
, env
);
900 /* Now fill in env with unbound values, limn the rest of the args for
901 keywords, and fill in unbound values with their inits. */
904 int kw_start_idx
= i
;
906 for (walk
= kw
; scm_is_pair (walk
); walk
= CDR (walk
))
907 if (SCM_I_INUM (CDAR (walk
)) > imax
)
908 imax
= SCM_I_INUM (CDAR (walk
));
909 for (; i
<= imax
; i
++)
910 env
= scm_cons (SCM_UNDEFINED
, env
);
912 if (scm_is_pair (args
) && scm_is_pair (CDR (args
)))
913 for (; scm_is_pair (args
) && scm_is_pair (CDR (args
));
916 k
= CAR (args
); v
= CADR (args
);
917 if (!scm_is_keyword (k
))
919 if (scm_is_true (rest
))
924 for (walk
= kw
; scm_is_pair (walk
); walk
= CDR (walk
))
925 if (scm_is_eq (k
, CAAR (walk
)))
927 /* Well... ok, list-set! isn't the nicest interface, but
929 int iset
= imax
- SCM_I_INUM (CDAR (walk
));
930 scm_list_set_x (env
, SCM_I_MAKINUM (iset
), v
);
934 if (scm_is_null (walk
) && scm_is_false (aok
))
935 error_unrecognized_keyword (proc
);
937 if (scm_is_pair (args
) && scm_is_false (rest
))
938 error_invalid_keyword (proc
);
940 /* Now fill in unbound values, evaluating init expressions in their
941 appropriate environment. */
942 for (i
= imax
- kw_start_idx
; scm_is_pair (inits
); i
--, inits
= CDR (inits
))
944 SCM tail
= scm_list_tail (env
, SCM_I_MAKINUM (i
));
945 if (SCM_UNBNDP (CAR (tail
)))
946 SCM_SETCAR (tail
, eval (CAR (inits
), CDR (tail
)));
957 prepare_boot_closure_env_for_eval (SCM proc
, unsigned int argc
,
958 SCM exps
, SCM
*out_body
, SCM
*inout_env
)
960 int nreq
= BOOT_CLOSURE_NUM_REQUIRED_ARGS (proc
);
961 SCM new_env
= BOOT_CLOSURE_ENV (proc
);
962 if (BOOT_CLOSURE_IS_FIXED (proc
)
963 || (BOOT_CLOSURE_IS_REST (proc
)
964 && !BOOT_CLOSURE_HAS_REST_ARGS (proc
)))
966 for (; scm_is_pair (exps
); exps
= CDR (exps
), nreq
--)
967 new_env
= scm_cons (eval (CAR (exps
), *inout_env
), new_env
);
968 if (SCM_UNLIKELY (nreq
!= 0))
969 scm_wrong_num_args (proc
);
970 *out_body
= BOOT_CLOSURE_BODY (proc
);
971 *inout_env
= new_env
;
973 else if (BOOT_CLOSURE_IS_REST (proc
))
975 if (SCM_UNLIKELY (argc
< nreq
))
976 scm_wrong_num_args (proc
);
977 for (; nreq
; nreq
--, exps
= CDR (exps
))
978 new_env
= scm_cons (eval (CAR (exps
), *inout_env
), new_env
);
981 for (; scm_is_pair (exps
); exps
= CDR (exps
))
982 rest
= scm_cons (eval (CAR (exps
), *inout_env
), rest
);
983 new_env
= scm_cons (scm_reverse (rest
),
986 *out_body
= BOOT_CLOSURE_BODY (proc
);
987 *inout_env
= new_env
;
992 for (; scm_is_pair (exps
); exps
= CDR (exps
))
993 args
= scm_cons (eval (CAR (exps
), *inout_env
), args
);
994 args
= scm_reverse_x (args
, SCM_UNDEFINED
);
995 prepare_boot_closure_env_for_apply (proc
, args
, out_body
, inout_env
);
1000 boot_closure_apply (SCM closure
, SCM args
)
1003 prepare_boot_closure_env_for_apply (closure
, args
, &body
, &env
);
1004 return eval (body
, env
);
1008 boot_closure_print (SCM closure
, SCM port
, scm_print_state
*pstate
)
1011 scm_puts ("#<boot-closure ", port
);
1012 scm_uintprint ((unsigned long)SCM2PTR (closure
), 16, port
);
1013 scm_putc (' ', port
);
1014 args
= scm_make_list (scm_from_int (BOOT_CLOSURE_NUM_REQUIRED_ARGS (closure
)),
1015 scm_from_locale_symbol ("_"));
1016 if (!BOOT_CLOSURE_IS_FIXED (closure
) && BOOT_CLOSURE_HAS_REST_ARGS (closure
))
1017 args
= scm_cons_star (scm_from_locale_symbol ("_"), args
);
1018 /* FIXME: optionals and rests */
1019 scm_display (args
, port
);
1020 scm_putc ('>', port
);
1029 f_apply
= scm_c_define_gsubr ("apply", 2, 0, 1, scm_apply
);
1031 scm_tc16_boot_closure
= scm_make_smob_type ("boot-closure", 0);
1032 scm_set_smob_apply (scm_tc16_boot_closure
, boot_closure_apply
, 0, 0, 1);
1033 scm_set_smob_print (scm_tc16_boot_closure
, boot_closure_print
);
1035 primitive_eval
= scm_c_make_gsubr ("primitive-eval", 1, 0, 0,
1036 scm_c_primitive_eval
);
1037 var_primitive_eval
= scm_define (SCM_SUBR_NAME (primitive_eval
),
1040 #include "libguile/eval.x"