1 /* Copyright (C) 1995,1996,1997,1998,1999,2000,2001,2002,2003,2004,2005,2006,2007,2008,2009,2010,2011
2 * Free Software Foundation, Inc.
4 * This library is free software; you can redistribute it and/or
5 * modify it under the terms of the GNU Lesser General Public License
6 * as published by the Free Software Foundation; either version 3 of
7 * the License, or (at your option) any later version.
9 * This library is distributed in the hope that it will be useful, but
10 * WITHOUT ANY WARRANTY; without even the implied warranty of
11 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
12 * Lesser General Public License for more details.
14 * You should have received a copy of the GNU Lesser General Public
15 * License along with this library; if not, write to the Free Software
16 * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
28 #include "libguile/__scm.h"
30 #include "libguile/_scm.h"
31 #include "libguile/alist.h"
32 #include "libguile/async.h"
33 #include "libguile/continuations.h"
34 #include "libguile/control.h"
35 #include "libguile/debug.h"
36 #include "libguile/deprecation.h"
37 #include "libguile/dynwind.h"
38 #include "libguile/eq.h"
39 #include "libguile/expand.h"
40 #include "libguile/feature.h"
41 #include "libguile/fluids.h"
42 #include "libguile/goops.h"
43 #include "libguile/hash.h"
44 #include "libguile/hashtab.h"
45 #include "libguile/list.h"
46 #include "libguile/macros.h"
47 #include "libguile/memoize.h"
48 #include "libguile/modules.h"
49 #include "libguile/ports.h"
50 #include "libguile/print.h"
51 #include "libguile/procprop.h"
52 #include "libguile/programs.h"
53 #include "libguile/root.h"
54 #include "libguile/smob.h"
55 #include "libguile/srcprop.h"
56 #include "libguile/stackchk.h"
57 #include "libguile/strings.h"
58 #include "libguile/threads.h"
59 #include "libguile/throw.h"
60 #include "libguile/validate.h"
61 #include "libguile/values.h"
62 #include "libguile/vectors.h"
63 #include "libguile/vm.h"
65 #include "libguile/eval.h"
66 #include "libguile/private-options.h"
71 /* We have three levels of EVAL here:
75 evaluates EXP in environment ENV. ENV is a lexical environment
76 structure as used by the actual tree code evaluator. When ENV is
77 a top-level environment, then changes to the current module are
78 tracked by updating ENV so that it continues to be in sync with
81 - scm_primitive_eval (exp)
83 evaluates EXP in the top-level environment as determined by the
84 current module. This is done by constructing a suitable
85 environment and calling eval. Thus, changes to the
86 top-level module are tracked normally.
90 evaluates EXP while MOD is the current module. This is done
91 by setting the current module to MOD_OR_STATE, invoking
92 scm_primitive_eval on EXP, and then restoring the current module
93 to the value it had previously. That is, while EXP is evaluated,
94 changes to the current module (or dynamic state) are tracked,
95 but these changes do not persist when scm_eval returns.
100 /* Boot closures. We only see these when compiling eval.scm, because once
101 eval.scm is in the house, closures are standard VM closures.
104 static scm_t_bits scm_tc16_boot_closure
;
105 #define RETURN_BOOT_CLOSURE(code, env) 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_latin1_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_latin1_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
;
412 /* We need the prompt and handler values after a longjmp case,
413 so make sure they are volatile. */
414 volatile SCM handler
, prompt
;
417 prompt
= scm_c_make_prompt (eval (CAR (mx
), env
), SCM_VM_DATA (vm
)->fp
,
418 SCM_VM_DATA (vm
)->sp
, SCM_VM_DATA (vm
)->ip
,
419 0, -1, scm_i_dynwinds ());
420 handler
= eval (CDDR (mx
), env
);
421 scm_i_set_dynwinds (scm_cons (prompt
, scm_i_dynwinds ()));
423 if (SCM_PROMPT_SETJMP (prompt
))
425 /* The prompt exited nonlocally. */
427 args
= scm_i_prompt_pop_abort_args_x (prompt
);
431 res
= eval (CADR (mx
), env
);
432 scm_i_set_dynwinds (CDR (scm_i_dynwinds ()));
443 /* Simple procedure calls
447 scm_call_0 (SCM proc
)
449 return scm_c_vm_run (scm_the_vm (), proc
, NULL
, 0);
453 scm_call_1 (SCM proc
, SCM arg1
)
455 return scm_c_vm_run (scm_the_vm (), proc
, &arg1
, 1);
459 scm_call_2 (SCM proc
, SCM arg1
, SCM arg2
)
461 SCM args
[] = { arg1
, arg2
};
462 return scm_c_vm_run (scm_the_vm (), proc
, args
, 2);
466 scm_call_3 (SCM proc
, SCM arg1
, SCM arg2
, SCM arg3
)
468 SCM args
[] = { arg1
, arg2
, arg3
};
469 return scm_c_vm_run (scm_the_vm (), proc
, args
, 3);
473 scm_call_4 (SCM proc
, SCM arg1
, SCM arg2
, SCM arg3
, SCM arg4
)
475 SCM args
[] = { arg1
, arg2
, arg3
, arg4
};
476 return scm_c_vm_run (scm_the_vm (), proc
, args
, 4);
480 scm_call_n (SCM proc
, SCM
*argv
, size_t nargs
)
482 return scm_c_vm_run (scm_the_vm (), proc
, argv
, nargs
);
485 /* Simple procedure applies
489 scm_apply_0 (SCM proc
, SCM args
)
491 return scm_apply (proc
, args
, SCM_EOL
);
495 scm_apply_1 (SCM proc
, SCM arg1
, SCM args
)
497 return scm_apply (proc
, scm_cons (arg1
, args
), SCM_EOL
);
501 scm_apply_2 (SCM proc
, SCM arg1
, SCM arg2
, SCM args
)
503 return scm_apply (proc
, scm_cons2 (arg1
, arg2
, args
), SCM_EOL
);
507 scm_apply_3 (SCM proc
, SCM arg1
, SCM arg2
, SCM arg3
, SCM args
)
509 return scm_apply (proc
, scm_cons (arg1
, scm_cons2 (arg2
, arg3
, args
)),
513 /* This code processes the arguments to apply:
515 (apply PROC ARG1 ... ARGS)
517 Given a list (ARG1 ... ARGS), this function conses the ARG1
518 ... arguments onto the front of ARGS, and returns the resulting
519 list. Note that ARGS is a list; thus, the argument to this
520 function is a list whose last element is a list.
522 Apply calls this function, and applies PROC to the elements of the
523 result. apply:nconc2last takes care of building the list of
524 arguments, given (ARG1 ... ARGS).
526 Rather than do new consing, apply:nconc2last destroys its argument.
527 On that topic, this code came into my care with the following
528 beautifully cryptic comment on that topic: "This will only screw
529 you if you do (scm_apply scm_apply '( ... ))" If you know what
530 they're referring to, send me a patch to this comment. */
532 SCM_DEFINE (scm_nconc2last
, "apply:nconc2last", 1, 0, 0,
534 "Given a list (@var{arg1} @dots{} @var{args}), this function\n"
535 "conses the @var{arg1} @dots{} arguments onto the front of\n"
536 "@var{args}, and returns the resulting list. Note that\n"
537 "@var{args} is a list; thus, the argument to this function is\n"
538 "a list whose last element is a list.\n"
539 "Note: Rather than do new consing, @code{apply:nconc2last}\n"
540 "destroys its argument, so use with care.")
541 #define FUNC_NAME s_scm_nconc2last
544 SCM_VALIDATE_NONEMPTYLIST (1, lst
);
546 while (!scm_is_null (SCM_CDR (*lloc
)))
547 lloc
= SCM_CDRLOC (*lloc
);
548 SCM_ASSERT (scm_ilength (SCM_CAR (*lloc
)) >= 0, lst
, SCM_ARG1
, FUNC_NAME
);
549 *lloc
= SCM_CAR (*lloc
);
556 /* Typechecking for multi-argument MAP and FOR-EACH.
558 Verify that each element of the vector ARGV, except for the first,
559 is a proper list whose length is LEN. Attribute errors to WHO,
560 and claim that the i'th element of ARGV is WHO's i+2'th argument. */
562 check_map_args (SCM argv
,
571 for (i
= SCM_SIMPLE_VECTOR_LENGTH (argv
) - 1; i
>= 1; i
--)
573 SCM elt
= SCM_SIMPLE_VECTOR_REF (argv
, i
);
574 long elt_len
= scm_ilength (elt
);
579 scm_apply_generic (gf
, scm_cons (proc
, args
));
581 scm_wrong_type_arg (who
, i
+ 2, elt
);
585 scm_out_of_range_pos (who
, elt
, scm_from_long (i
+ 2));
590 SCM_GPROC (s_map
, "map", 2, 0, 1, scm_map
, g_map
);
592 /* Note: Currently, scm_map applies PROC to the argument list(s)
593 sequentially, starting with the first element(s). This is used in
594 evalext.c where the Scheme procedure `map-in-order', which guarantees
595 sequential behaviour, is implemented using scm_map. If the
596 behaviour changes, we need to update `map-in-order'.
600 scm_map (SCM proc
, SCM arg1
, SCM args
)
601 #define FUNC_NAME s_map
607 len
= scm_ilength (arg1
);
608 SCM_GASSERTn (len
>= 0,
609 g_map
, scm_cons2 (proc
, arg1
, args
), SCM_ARG2
, s_map
);
610 SCM_VALIDATE_REST_ARGUMENT (args
);
611 if (scm_is_null (args
))
613 SCM_GASSERT2 (scm_is_true (scm_procedure_p (proc
)), g_map
, proc
, arg1
, SCM_ARG1
, s_map
);
614 while (SCM_NIMP (arg1
))
616 *pres
= scm_list_1 (scm_call_1 (proc
, SCM_CAR (arg1
)));
617 pres
= SCM_CDRLOC (*pres
);
618 arg1
= SCM_CDR (arg1
);
622 if (scm_is_null (SCM_CDR (args
)))
624 SCM arg2
= SCM_CAR (args
);
625 int len2
= scm_ilength (arg2
);
626 SCM_GASSERTn (scm_is_true (scm_procedure_p (proc
)), g_map
,
627 scm_cons2 (proc
, arg1
, args
), SCM_ARG1
, s_map
);
628 SCM_GASSERTn (len2
>= 0,
629 g_map
, scm_cons2 (proc
, arg1
, args
), SCM_ARG3
, s_map
);
631 SCM_OUT_OF_RANGE (3, arg2
);
632 while (SCM_NIMP (arg1
))
634 *pres
= scm_list_1 (scm_call_2 (proc
, SCM_CAR (arg1
), SCM_CAR (arg2
)));
635 pres
= SCM_CDRLOC (*pres
);
636 arg1
= SCM_CDR (arg1
);
637 arg2
= SCM_CDR (arg2
);
641 arg1
= scm_cons (arg1
, args
);
642 args
= scm_vector (arg1
);
643 check_map_args (args
, len
, g_map
, proc
, arg1
, s_map
);
647 for (i
= SCM_SIMPLE_VECTOR_LENGTH (args
) - 1; i
>= 0; i
--)
649 SCM elt
= SCM_SIMPLE_VECTOR_REF (args
, i
);
652 arg1
= scm_cons (SCM_CAR (elt
), arg1
);
653 SCM_SIMPLE_VECTOR_SET (args
, i
, SCM_CDR (elt
));
655 *pres
= scm_list_1 (scm_apply (proc
, arg1
, SCM_EOL
));
656 pres
= SCM_CDRLOC (*pres
);
662 SCM_GPROC (s_for_each
, "for-each", 2, 0, 1, scm_for_each
, g_for_each
);
665 scm_for_each (SCM proc
, SCM arg1
, SCM args
)
666 #define FUNC_NAME s_for_each
669 len
= scm_ilength (arg1
);
670 SCM_GASSERTn (len
>= 0, g_for_each
, scm_cons2 (proc
, arg1
, args
),
671 SCM_ARG2
, s_for_each
);
672 SCM_VALIDATE_REST_ARGUMENT (args
);
673 if (scm_is_null (args
))
675 SCM_GASSERT2 (scm_is_true (scm_procedure_p (proc
)), g_for_each
,
676 proc
, arg1
, SCM_ARG1
, s_for_each
);
677 while (SCM_NIMP (arg1
))
679 scm_call_1 (proc
, SCM_CAR (arg1
));
680 arg1
= SCM_CDR (arg1
);
682 return SCM_UNSPECIFIED
;
684 if (scm_is_null (SCM_CDR (args
)))
686 SCM arg2
= SCM_CAR (args
);
687 int len2
= scm_ilength (arg2
);
688 SCM_GASSERTn (scm_is_true (scm_procedure_p (proc
)), g_for_each
,
689 scm_cons2 (proc
, arg1
, args
), SCM_ARG1
, s_for_each
);
690 SCM_GASSERTn (len2
>= 0, g_for_each
,
691 scm_cons2 (proc
, arg1
, args
), SCM_ARG3
, s_for_each
);
693 SCM_OUT_OF_RANGE (3, arg2
);
694 while (SCM_NIMP (arg1
))
696 scm_call_2 (proc
, SCM_CAR (arg1
), SCM_CAR (arg2
));
697 arg1
= SCM_CDR (arg1
);
698 arg2
= SCM_CDR (arg2
);
700 return SCM_UNSPECIFIED
;
702 arg1
= scm_cons (arg1
, args
);
703 args
= scm_vector (arg1
);
704 check_map_args (args
, len
, g_for_each
, proc
, arg1
, s_for_each
);
708 for (i
= SCM_SIMPLE_VECTOR_LENGTH (args
) - 1; i
>= 0; i
--)
710 SCM elt
= SCM_SIMPLE_VECTOR_REF (args
, i
);
712 return SCM_UNSPECIFIED
;
713 arg1
= scm_cons (SCM_CAR (elt
), arg1
);
714 SCM_SIMPLE_VECTOR_SET (args
, i
, SCM_CDR (elt
));
716 scm_apply (proc
, arg1
, SCM_EOL
);
723 scm_c_primitive_eval (SCM exp
)
725 if (!SCM_EXPANDED_P (exp
))
726 exp
= scm_call_1 (scm_current_module_transformer (), exp
);
727 return eval (scm_memoize_expression (exp
), SCM_EOL
);
730 static SCM var_primitive_eval
;
732 scm_primitive_eval (SCM exp
)
734 return scm_c_vm_run (scm_the_vm (), scm_variable_ref (var_primitive_eval
),
739 /* Eval does not take the second arg optionally. This is intentional
740 * in order to be R5RS compatible, and to prepare for the new module
741 * system, where we would like to make the choice of evaluation
742 * environment explicit. */
744 SCM_DEFINE (scm_eval
, "eval", 2, 0, 0,
745 (SCM exp
, SCM module_or_state
),
746 "Evaluate @var{exp}, a list representing a Scheme expression,\n"
747 "in the top-level environment specified by\n"
748 "@var{module_or_state}.\n"
749 "While @var{exp} is evaluated (using @code{primitive-eval}),\n"
750 "@var{module_or_state} is made the current module when\n"
751 "it is a module, or the current dynamic state when it is\n"
753 "Example: (eval '(+ 1 2) (interaction-environment))")
754 #define FUNC_NAME s_scm_eval
758 scm_dynwind_begin (SCM_F_DYNWIND_REWINDABLE
);
759 if (scm_is_dynamic_state (module_or_state
))
760 scm_dynwind_current_dynamic_state (module_or_state
);
761 else if (scm_module_system_booted_p
)
763 SCM_VALIDATE_MODULE (2, module_or_state
);
764 scm_dynwind_current_module (module_or_state
);
766 /* otherwise if the module system isn't booted, ignore the module arg */
768 res
= scm_primitive_eval (exp
);
778 /* Apply a function to a list of arguments.
780 This function is exported to the Scheme level as taking two
781 required arguments and a tail argument, as if it were:
782 (lambda (proc arg1 . args) ...)
783 Thus, if you just have a list of arguments to pass to a procedure,
784 pass the list as ARG1, and '() for ARGS. If you have some fixed
785 args, pass the first as ARG1, then cons any remaining fixed args
786 onto the front of your argument list, and pass that as ARGS. */
789 scm_apply (SCM proc
, SCM arg1
, SCM args
)
791 /* Fix things up so that args contains all args. */
792 if (scm_is_null (args
))
795 args
= scm_cons_star (arg1
, args
);
797 return scm_call_with_vm (scm_the_vm (), proc
, args
);
801 prepare_boot_closure_env_for_apply (SCM proc
, SCM args
,
802 SCM
*out_body
, SCM
*out_env
)
804 int nreq
= BOOT_CLOSURE_NUM_REQUIRED_ARGS (proc
);
805 SCM env
= BOOT_CLOSURE_ENV (proc
);
807 if (BOOT_CLOSURE_IS_FIXED (proc
)
808 || (BOOT_CLOSURE_IS_REST (proc
)
809 && !BOOT_CLOSURE_HAS_REST_ARGS (proc
)))
811 if (SCM_UNLIKELY (scm_ilength (args
) != nreq
))
812 scm_wrong_num_args (proc
);
813 for (; scm_is_pair (args
); args
= CDR (args
))
814 env
= scm_cons (CAR (args
), env
);
815 *out_body
= BOOT_CLOSURE_BODY (proc
);
818 else if (BOOT_CLOSURE_IS_REST (proc
))
820 if (SCM_UNLIKELY (scm_ilength (args
) < nreq
))
821 scm_wrong_num_args (proc
);
822 for (; nreq
; nreq
--, args
= CDR (args
))
823 env
= scm_cons (CAR (args
), env
);
824 env
= scm_cons (args
, env
);
825 *out_body
= BOOT_CLOSURE_BODY (proc
);
830 int i
, argc
, nreq
, nopt
;
831 SCM body
, rest
, kw
, inits
, alt
;
832 SCM mx
= BOOT_CLOSURE_CODE (proc
);
835 BOOT_CLOSURE_PARSE_FULL (mx
, body
, nargs
, rest
, nopt
, kw
, inits
, alt
);
837 argc
= scm_ilength (args
);
840 if (scm_is_true (alt
))
846 scm_wrong_num_args (proc
);
848 if (scm_is_false (kw
) && argc
> nreq
+ nopt
&& scm_is_false (rest
))
850 if (scm_is_true (alt
))
856 scm_wrong_num_args (proc
);
859 for (i
= 0; i
< nreq
; i
++, args
= CDR (args
))
860 env
= scm_cons (CAR (args
), env
);
862 if (scm_is_false (kw
))
864 /* Optional args (possibly), but no keyword args. */
865 for (; i
< argc
&& i
< nreq
+ nopt
;
866 i
++, args
= CDR (args
))
868 env
= scm_cons (CAR (args
), env
);
872 for (; i
< nreq
+ nopt
; i
++, inits
= CDR (inits
))
873 env
= scm_cons (eval (CAR (inits
), env
), env
);
875 if (scm_is_true (rest
))
876 env
= scm_cons (args
, env
);
885 /* Keyword args. As before, but stop at the first keyword. */
886 for (; i
< argc
&& i
< nreq
+ nopt
&& !scm_is_keyword (CAR (args
));
887 i
++, args
= CDR (args
), inits
= CDR (inits
))
888 env
= scm_cons (CAR (args
), env
);
890 for (; i
< nreq
+ nopt
; i
++, inits
= CDR (inits
))
891 env
= scm_cons (eval (CAR (inits
), env
), env
);
893 if (scm_is_true (rest
))
895 env
= scm_cons (args
, env
);
899 /* Now fill in env with unbound values, limn the rest of the args for
900 keywords, and fill in unbound values with their inits. */
903 int kw_start_idx
= i
;
905 for (walk
= kw
; scm_is_pair (walk
); walk
= CDR (walk
))
906 if (SCM_I_INUM (CDAR (walk
)) > imax
)
907 imax
= SCM_I_INUM (CDAR (walk
));
908 for (; i
<= imax
; i
++)
909 env
= scm_cons (SCM_UNDEFINED
, env
);
911 if (scm_is_pair (args
) && scm_is_pair (CDR (args
)))
912 for (; scm_is_pair (args
) && scm_is_pair (CDR (args
));
915 k
= CAR (args
); v
= CADR (args
);
916 if (!scm_is_keyword (k
))
918 if (scm_is_true (rest
))
923 for (walk
= kw
; scm_is_pair (walk
); walk
= CDR (walk
))
924 if (scm_is_eq (k
, CAAR (walk
)))
926 /* Well... ok, list-set! isn't the nicest interface, but
928 int iset
= imax
- SCM_I_INUM (CDAR (walk
));
929 scm_list_set_x (env
, SCM_I_MAKINUM (iset
), v
);
933 if (scm_is_null (walk
) && scm_is_false (aok
))
934 error_unrecognized_keyword (proc
);
936 if (scm_is_pair (args
) && scm_is_false (rest
))
937 error_invalid_keyword (proc
);
939 /* Now fill in unbound values, evaluating init expressions in their
940 appropriate environment. */
941 for (i
= imax
- kw_start_idx
; scm_is_pair (inits
); i
--, inits
= CDR (inits
))
943 SCM tail
= scm_list_tail (env
, SCM_I_MAKINUM (i
));
944 if (SCM_UNBNDP (CAR (tail
)))
945 SCM_SETCAR (tail
, eval (CAR (inits
), CDR (tail
)));
956 prepare_boot_closure_env_for_eval (SCM proc
, unsigned int argc
,
957 SCM exps
, SCM
*out_body
, SCM
*inout_env
)
959 int nreq
= BOOT_CLOSURE_NUM_REQUIRED_ARGS (proc
);
960 SCM new_env
= BOOT_CLOSURE_ENV (proc
);
961 if (BOOT_CLOSURE_IS_FIXED (proc
)
962 || (BOOT_CLOSURE_IS_REST (proc
)
963 && !BOOT_CLOSURE_HAS_REST_ARGS (proc
)))
965 for (; scm_is_pair (exps
); exps
= CDR (exps
), nreq
--)
966 new_env
= scm_cons (eval (CAR (exps
), *inout_env
), new_env
);
967 if (SCM_UNLIKELY (nreq
!= 0))
968 scm_wrong_num_args (proc
);
969 *out_body
= BOOT_CLOSURE_BODY (proc
);
970 *inout_env
= new_env
;
972 else if (BOOT_CLOSURE_IS_REST (proc
))
974 if (SCM_UNLIKELY (argc
< nreq
))
975 scm_wrong_num_args (proc
);
976 for (; nreq
; nreq
--, exps
= CDR (exps
))
977 new_env
= scm_cons (eval (CAR (exps
), *inout_env
), new_env
);
980 for (; scm_is_pair (exps
); exps
= CDR (exps
))
981 rest
= scm_cons (eval (CAR (exps
), *inout_env
), rest
);
982 new_env
= scm_cons (scm_reverse (rest
),
985 *out_body
= BOOT_CLOSURE_BODY (proc
);
986 *inout_env
= new_env
;
991 for (; scm_is_pair (exps
); exps
= CDR (exps
))
992 args
= scm_cons (eval (CAR (exps
), *inout_env
), args
);
993 args
= scm_reverse_x (args
, SCM_UNDEFINED
);
994 prepare_boot_closure_env_for_apply (proc
, args
, out_body
, inout_env
);
999 boot_closure_apply (SCM closure
, SCM args
)
1002 prepare_boot_closure_env_for_apply (closure
, args
, &body
, &env
);
1003 return eval (body
, env
);
1007 boot_closure_print (SCM closure
, SCM port
, scm_print_state
*pstate
)
1010 scm_puts ("#<boot-closure ", port
);
1011 scm_uintprint ((scm_t_bits
)SCM2PTR (closure
), 16, port
);
1012 scm_putc (' ', port
);
1013 args
= scm_make_list (scm_from_int (BOOT_CLOSURE_NUM_REQUIRED_ARGS (closure
)),
1014 scm_from_latin1_symbol ("_"));
1015 if (!BOOT_CLOSURE_IS_FIXED (closure
) && BOOT_CLOSURE_HAS_REST_ARGS (closure
))
1016 args
= scm_cons_star (scm_from_latin1_symbol ("_"), args
);
1017 /* FIXME: optionals and rests */
1018 scm_display (args
, port
);
1019 scm_putc ('>', port
);
1028 f_apply
= scm_c_define_gsubr ("apply", 2, 0, 1, scm_apply
);
1030 scm_tc16_boot_closure
= scm_make_smob_type ("boot-closure", 0);
1031 scm_set_smob_apply (scm_tc16_boot_closure
, boot_closure_apply
, 0, 0, 1);
1032 scm_set_smob_print (scm_tc16_boot_closure
, boot_closure_print
);
1034 primitive_eval
= scm_c_make_gsubr ("primitive-eval", 1, 0, 0,
1035 scm_c_primitive_eval
);
1036 var_primitive_eval
= scm_define (SCM_SUBR_NAME (primitive_eval
),
1039 #include "libguile/eval.x"