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
))) /* Perhaps should be
547 SCM_NULL_OR_NIL_P, but not
548 needed in 99.99% of cases,
549 and it could seriously hurt
550 performance. - Neil */
551 lloc
= SCM_CDRLOC (*lloc
);
552 SCM_ASSERT (scm_ilength (SCM_CAR (*lloc
)) >= 0, lst
, SCM_ARG1
, FUNC_NAME
);
553 *lloc
= SCM_CAR (*lloc
);
560 /* Typechecking for multi-argument MAP and FOR-EACH.
562 Verify that each element of the vector ARGV, except for the first,
563 is a proper list whose length is LEN. Attribute errors to WHO,
564 and claim that the i'th element of ARGV is WHO's i+2'th argument. */
566 check_map_args (SCM argv
,
575 for (i
= SCM_SIMPLE_VECTOR_LENGTH (argv
) - 1; i
>= 1; i
--)
577 SCM elt
= SCM_SIMPLE_VECTOR_REF (argv
, i
);
578 long elt_len
= scm_ilength (elt
);
583 scm_apply_generic (gf
, scm_cons (proc
, args
));
585 scm_wrong_type_arg (who
, i
+ 2, elt
);
589 scm_out_of_range_pos (who
, elt
, scm_from_long (i
+ 2));
594 SCM_GPROC (s_map
, "map", 2, 0, 1, scm_map
, g_map
);
596 /* Note: Currently, scm_map applies PROC to the argument list(s)
597 sequentially, starting with the first element(s). This is used in
598 evalext.c where the Scheme procedure `map-in-order', which guarantees
599 sequential behaviour, is implemented using scm_map. If the
600 behaviour changes, we need to update `map-in-order'.
604 scm_map (SCM proc
, SCM arg1
, SCM args
)
605 #define FUNC_NAME s_map
611 len
= scm_ilength (arg1
);
612 SCM_GASSERTn (len
>= 0,
613 g_map
, scm_cons2 (proc
, arg1
, args
), SCM_ARG2
, s_map
);
614 SCM_VALIDATE_REST_ARGUMENT (args
);
615 if (scm_is_null (args
))
617 SCM_GASSERT2 (scm_is_true (scm_procedure_p (proc
)), g_map
, proc
, arg1
, SCM_ARG1
, s_map
);
618 while (SCM_NIMP (arg1
))
620 *pres
= scm_list_1 (scm_call_1 (proc
, SCM_CAR (arg1
)));
621 pres
= SCM_CDRLOC (*pres
);
622 arg1
= SCM_CDR (arg1
);
626 if (scm_is_null (SCM_CDR (args
)))
628 SCM arg2
= SCM_CAR (args
);
629 int len2
= scm_ilength (arg2
);
630 SCM_GASSERTn (scm_is_true (scm_procedure_p (proc
)), g_map
,
631 scm_cons2 (proc
, arg1
, args
), SCM_ARG1
, s_map
);
632 SCM_GASSERTn (len2
>= 0,
633 g_map
, scm_cons2 (proc
, arg1
, args
), SCM_ARG3
, s_map
);
635 SCM_OUT_OF_RANGE (3, arg2
);
636 while (SCM_NIMP (arg1
))
638 *pres
= scm_list_1 (scm_call_2 (proc
, SCM_CAR (arg1
), SCM_CAR (arg2
)));
639 pres
= SCM_CDRLOC (*pres
);
640 arg1
= SCM_CDR (arg1
);
641 arg2
= SCM_CDR (arg2
);
645 arg1
= scm_cons (arg1
, args
);
646 args
= scm_vector (arg1
);
647 check_map_args (args
, len
, g_map
, proc
, arg1
, s_map
);
651 for (i
= SCM_SIMPLE_VECTOR_LENGTH (args
) - 1; i
>= 0; i
--)
653 SCM elt
= SCM_SIMPLE_VECTOR_REF (args
, i
);
656 arg1
= scm_cons (SCM_CAR (elt
), arg1
);
657 SCM_SIMPLE_VECTOR_SET (args
, i
, SCM_CDR (elt
));
659 *pres
= scm_list_1 (scm_apply (proc
, arg1
, SCM_EOL
));
660 pres
= SCM_CDRLOC (*pres
);
666 SCM_GPROC (s_for_each
, "for-each", 2, 0, 1, scm_for_each
, g_for_each
);
669 scm_for_each (SCM proc
, SCM arg1
, SCM args
)
670 #define FUNC_NAME s_for_each
673 len
= scm_ilength (arg1
);
674 SCM_GASSERTn (len
>= 0, g_for_each
, scm_cons2 (proc
, arg1
, args
),
675 SCM_ARG2
, s_for_each
);
676 SCM_VALIDATE_REST_ARGUMENT (args
);
677 if (scm_is_null (args
))
679 SCM_GASSERT2 (scm_is_true (scm_procedure_p (proc
)), g_for_each
,
680 proc
, arg1
, SCM_ARG1
, s_for_each
);
681 while (SCM_NIMP (arg1
))
683 scm_call_1 (proc
, SCM_CAR (arg1
));
684 arg1
= SCM_CDR (arg1
);
686 return SCM_UNSPECIFIED
;
688 if (scm_is_null (SCM_CDR (args
)))
690 SCM arg2
= SCM_CAR (args
);
691 int len2
= scm_ilength (arg2
);
692 SCM_GASSERTn (scm_is_true (scm_procedure_p (proc
)), g_for_each
,
693 scm_cons2 (proc
, arg1
, args
), SCM_ARG1
, s_for_each
);
694 SCM_GASSERTn (len2
>= 0, g_for_each
,
695 scm_cons2 (proc
, arg1
, args
), SCM_ARG3
, s_for_each
);
697 SCM_OUT_OF_RANGE (3, arg2
);
698 while (SCM_NIMP (arg1
))
700 scm_call_2 (proc
, SCM_CAR (arg1
), SCM_CAR (arg2
));
701 arg1
= SCM_CDR (arg1
);
702 arg2
= SCM_CDR (arg2
);
704 return SCM_UNSPECIFIED
;
706 arg1
= scm_cons (arg1
, args
);
707 args
= scm_vector (arg1
);
708 check_map_args (args
, len
, g_for_each
, proc
, arg1
, s_for_each
);
712 for (i
= SCM_SIMPLE_VECTOR_LENGTH (args
) - 1; i
>= 0; i
--)
714 SCM elt
= SCM_SIMPLE_VECTOR_REF (args
, i
);
716 return SCM_UNSPECIFIED
;
717 arg1
= scm_cons (SCM_CAR (elt
), arg1
);
718 SCM_SIMPLE_VECTOR_SET (args
, i
, SCM_CDR (elt
));
720 scm_apply (proc
, arg1
, SCM_EOL
);
727 scm_c_primitive_eval (SCM exp
)
729 if (!SCM_EXPANDED_P (exp
))
730 exp
= scm_call_1 (scm_current_module_transformer (), exp
);
731 return eval (scm_memoize_expression (exp
), SCM_EOL
);
734 static SCM var_primitive_eval
;
736 scm_primitive_eval (SCM exp
)
738 return scm_c_vm_run (scm_the_vm (), scm_variable_ref (var_primitive_eval
),
743 /* Eval does not take the second arg optionally. This is intentional
744 * in order to be R5RS compatible, and to prepare for the new module
745 * system, where we would like to make the choice of evaluation
746 * environment explicit. */
748 SCM_DEFINE (scm_eval
, "eval", 2, 0, 0,
749 (SCM exp
, SCM module_or_state
),
750 "Evaluate @var{exp}, a list representing a Scheme expression,\n"
751 "in the top-level environment specified by\n"
752 "@var{module_or_state}.\n"
753 "While @var{exp} is evaluated (using @code{primitive-eval}),\n"
754 "@var{module_or_state} is made the current module when\n"
755 "it is a module, or the current dynamic state when it is\n"
757 "Example: (eval '(+ 1 2) (interaction-environment))")
758 #define FUNC_NAME s_scm_eval
762 scm_dynwind_begin (SCM_F_DYNWIND_REWINDABLE
);
763 if (scm_is_dynamic_state (module_or_state
))
764 scm_dynwind_current_dynamic_state (module_or_state
);
765 else if (scm_module_system_booted_p
)
767 SCM_VALIDATE_MODULE (2, module_or_state
);
768 scm_dynwind_current_module (module_or_state
);
770 /* otherwise if the module system isn't booted, ignore the module arg */
772 res
= scm_primitive_eval (exp
);
782 /* Apply a function to a list of arguments.
784 This function is exported to the Scheme level as taking two
785 required arguments and a tail argument, as if it were:
786 (lambda (proc arg1 . args) ...)
787 Thus, if you just have a list of arguments to pass to a procedure,
788 pass the list as ARG1, and '() for ARGS. If you have some fixed
789 args, pass the first as ARG1, then cons any remaining fixed args
790 onto the front of your argument list, and pass that as ARGS. */
793 scm_apply (SCM proc
, SCM arg1
, SCM args
)
795 /* Fix things up so that args contains all args. */
796 if (scm_is_null (args
))
799 args
= scm_cons_star (arg1
, args
);
801 return scm_call_with_vm (scm_the_vm (), proc
, args
);
805 prepare_boot_closure_env_for_apply (SCM proc
, SCM args
,
806 SCM
*out_body
, SCM
*out_env
)
808 int nreq
= BOOT_CLOSURE_NUM_REQUIRED_ARGS (proc
);
809 SCM env
= BOOT_CLOSURE_ENV (proc
);
811 if (BOOT_CLOSURE_IS_FIXED (proc
)
812 || (BOOT_CLOSURE_IS_REST (proc
)
813 && !BOOT_CLOSURE_HAS_REST_ARGS (proc
)))
815 if (SCM_UNLIKELY (scm_ilength (args
) != nreq
))
816 scm_wrong_num_args (proc
);
817 for (; scm_is_pair (args
); args
= CDR (args
))
818 env
= scm_cons (CAR (args
), env
);
819 *out_body
= BOOT_CLOSURE_BODY (proc
);
822 else if (BOOT_CLOSURE_IS_REST (proc
))
824 if (SCM_UNLIKELY (scm_ilength (args
) < nreq
))
825 scm_wrong_num_args (proc
);
826 for (; nreq
; nreq
--, args
= CDR (args
))
827 env
= scm_cons (CAR (args
), env
);
828 env
= scm_cons (args
, env
);
829 *out_body
= BOOT_CLOSURE_BODY (proc
);
834 int i
, argc
, nreq
, nopt
;
835 SCM body
, rest
, kw
, inits
, alt
;
836 SCM mx
= BOOT_CLOSURE_CODE (proc
);
839 BOOT_CLOSURE_PARSE_FULL (mx
, body
, nargs
, rest
, nopt
, kw
, inits
, alt
);
841 argc
= scm_ilength (args
);
844 if (scm_is_true (alt
))
850 scm_wrong_num_args (proc
);
852 if (scm_is_false (kw
) && argc
> nreq
+ nopt
&& scm_is_false (rest
))
854 if (scm_is_true (alt
))
860 scm_wrong_num_args (proc
);
863 for (i
= 0; i
< nreq
; i
++, args
= CDR (args
))
864 env
= scm_cons (CAR (args
), env
);
866 if (scm_is_false (kw
))
868 /* Optional args (possibly), but no keyword args. */
869 for (; i
< argc
&& i
< nreq
+ nopt
;
870 i
++, args
= CDR (args
))
872 env
= scm_cons (CAR (args
), env
);
876 for (; i
< nreq
+ nopt
; i
++, inits
= CDR (inits
))
877 env
= scm_cons (eval (CAR (inits
), env
), env
);
879 if (scm_is_true (rest
))
880 env
= scm_cons (args
, env
);
889 /* Keyword args. As before, but stop at the first keyword. */
890 for (; i
< argc
&& i
< nreq
+ nopt
&& !scm_is_keyword (CAR (args
));
891 i
++, args
= CDR (args
), inits
= CDR (inits
))
892 env
= scm_cons (CAR (args
), env
);
894 for (; i
< nreq
+ nopt
; i
++, inits
= CDR (inits
))
895 env
= scm_cons (eval (CAR (inits
), env
), env
);
897 if (scm_is_true (rest
))
899 env
= scm_cons (args
, env
);
903 /* Now fill in env with unbound values, limn the rest of the args for
904 keywords, and fill in unbound values with their inits. */
907 int kw_start_idx
= i
;
909 for (walk
= kw
; scm_is_pair (walk
); walk
= CDR (walk
))
910 if (SCM_I_INUM (CDAR (walk
)) > imax
)
911 imax
= SCM_I_INUM (CDAR (walk
));
912 for (; i
<= imax
; i
++)
913 env
= scm_cons (SCM_UNDEFINED
, env
);
915 if (scm_is_pair (args
) && scm_is_pair (CDR (args
)))
916 for (; scm_is_pair (args
) && scm_is_pair (CDR (args
));
919 k
= CAR (args
); v
= CADR (args
);
920 if (!scm_is_keyword (k
))
922 if (scm_is_true (rest
))
927 for (walk
= kw
; scm_is_pair (walk
); walk
= CDR (walk
))
928 if (scm_is_eq (k
, CAAR (walk
)))
930 /* Well... ok, list-set! isn't the nicest interface, but
932 int iset
= imax
- SCM_I_INUM (CDAR (walk
));
933 scm_list_set_x (env
, SCM_I_MAKINUM (iset
), v
);
937 if (scm_is_null (walk
) && scm_is_false (aok
))
938 error_unrecognized_keyword (proc
);
940 if (scm_is_pair (args
) && scm_is_false (rest
))
941 error_invalid_keyword (proc
);
943 /* Now fill in unbound values, evaluating init expressions in their
944 appropriate environment. */
945 for (i
= imax
- kw_start_idx
; scm_is_pair (inits
); i
--, inits
= CDR (inits
))
947 SCM tail
= scm_list_tail (env
, SCM_I_MAKINUM (i
));
948 if (SCM_UNBNDP (CAR (tail
)))
949 SCM_SETCAR (tail
, eval (CAR (inits
), CDR (tail
)));
960 prepare_boot_closure_env_for_eval (SCM proc
, unsigned int argc
,
961 SCM exps
, SCM
*out_body
, SCM
*inout_env
)
963 int nreq
= BOOT_CLOSURE_NUM_REQUIRED_ARGS (proc
);
964 SCM new_env
= BOOT_CLOSURE_ENV (proc
);
965 if (BOOT_CLOSURE_IS_FIXED (proc
)
966 || (BOOT_CLOSURE_IS_REST (proc
)
967 && !BOOT_CLOSURE_HAS_REST_ARGS (proc
)))
969 for (; scm_is_pair (exps
); exps
= CDR (exps
), nreq
--)
970 new_env
= scm_cons (eval (CAR (exps
), *inout_env
), new_env
);
971 if (SCM_UNLIKELY (nreq
!= 0))
972 scm_wrong_num_args (proc
);
973 *out_body
= BOOT_CLOSURE_BODY (proc
);
974 *inout_env
= new_env
;
976 else if (BOOT_CLOSURE_IS_REST (proc
))
978 if (SCM_UNLIKELY (argc
< nreq
))
979 scm_wrong_num_args (proc
);
980 for (; nreq
; nreq
--, exps
= CDR (exps
))
981 new_env
= scm_cons (eval (CAR (exps
), *inout_env
), new_env
);
984 for (; scm_is_pair (exps
); exps
= CDR (exps
))
985 rest
= scm_cons (eval (CAR (exps
), *inout_env
), rest
);
986 new_env
= scm_cons (scm_reverse (rest
),
989 *out_body
= BOOT_CLOSURE_BODY (proc
);
990 *inout_env
= new_env
;
995 for (; scm_is_pair (exps
); exps
= CDR (exps
))
996 args
= scm_cons (eval (CAR (exps
), *inout_env
), args
);
997 args
= scm_reverse_x (args
, SCM_UNDEFINED
);
998 prepare_boot_closure_env_for_apply (proc
, args
, out_body
, inout_env
);
1003 boot_closure_apply (SCM closure
, SCM args
)
1006 prepare_boot_closure_env_for_apply (closure
, args
, &body
, &env
);
1007 return eval (body
, env
);
1011 boot_closure_print (SCM closure
, SCM port
, scm_print_state
*pstate
)
1014 scm_puts ("#<boot-closure ", port
);
1015 scm_uintprint ((scm_t_bits
)SCM2PTR (closure
), 16, port
);
1016 scm_putc (' ', port
);
1017 args
= scm_make_list (scm_from_int (BOOT_CLOSURE_NUM_REQUIRED_ARGS (closure
)),
1018 scm_from_latin1_symbol ("_"));
1019 if (!BOOT_CLOSURE_IS_FIXED (closure
) && BOOT_CLOSURE_HAS_REST_ARGS (closure
))
1020 args
= scm_cons_star (scm_from_latin1_symbol ("_"), args
);
1021 /* FIXME: optionals and rests */
1022 scm_display (args
, port
);
1023 scm_putc ('>', port
);
1032 f_apply
= scm_c_define_gsubr ("apply", 2, 0, 1, scm_apply
);
1034 scm_tc16_boot_closure
= scm_make_smob_type ("boot-closure", 0);
1035 scm_set_smob_apply (scm_tc16_boot_closure
, boot_closure_apply
, 0, 0, 1);
1036 scm_set_smob_print (scm_tc16_boot_closure
, boot_closure_print
);
1038 primitive_eval
= scm_c_make_gsubr ("primitive-eval", 1, 0, 0,
1039 scm_c_primitive_eval
);
1040 var_primitive_eval
= scm_define (SCM_SUBR_NAME (primitive_eval
),
1043 #include "libguile/eval.x"