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 (scm_the_vm ());
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_5 (SCM proc
, SCM arg1
, SCM arg2
, SCM arg3
, SCM arg4
, SCM arg5
)
482 SCM args
[] = { arg1
, arg2
, arg3
, arg4
, arg5
};
483 return scm_c_vm_run (scm_the_vm (), proc
, args
, 5);
487 scm_call_6 (SCM proc
, SCM arg1
, SCM arg2
, SCM arg3
, SCM arg4
, SCM arg5
,
490 SCM args
[] = { arg1
, arg2
, arg3
, arg4
, arg5
, arg6
};
491 return scm_c_vm_run (scm_the_vm (), proc
, args
, 6);
495 scm_call_n (SCM proc
, SCM
*argv
, size_t nargs
)
497 return scm_c_vm_run (scm_the_vm (), proc
, argv
, nargs
);
500 /* Simple procedure applies
504 scm_apply_0 (SCM proc
, SCM args
)
506 return scm_apply (proc
, args
, SCM_EOL
);
510 scm_apply_1 (SCM proc
, SCM arg1
, SCM args
)
512 return scm_apply (proc
, scm_cons (arg1
, args
), SCM_EOL
);
516 scm_apply_2 (SCM proc
, SCM arg1
, SCM arg2
, SCM args
)
518 return scm_apply (proc
, scm_cons2 (arg1
, arg2
, args
), SCM_EOL
);
522 scm_apply_3 (SCM proc
, SCM arg1
, SCM arg2
, SCM arg3
, SCM args
)
524 return scm_apply (proc
, scm_cons (arg1
, scm_cons2 (arg2
, arg3
, args
)),
528 /* This code processes the arguments to apply:
530 (apply PROC ARG1 ... ARGS)
532 Given a list (ARG1 ... ARGS), this function conses the ARG1
533 ... arguments onto the front of ARGS, and returns the resulting
534 list. Note that ARGS is a list; thus, the argument to this
535 function is a list whose last element is a list.
537 Apply calls this function, and applies PROC to the elements of the
538 result. apply:nconc2last takes care of building the list of
539 arguments, given (ARG1 ... ARGS).
541 Rather than do new consing, apply:nconc2last destroys its argument.
542 On that topic, this code came into my care with the following
543 beautifully cryptic comment on that topic: "This will only screw
544 you if you do (scm_apply scm_apply '( ... ))" If you know what
545 they're referring to, send me a patch to this comment. */
547 SCM_DEFINE (scm_nconc2last
, "apply:nconc2last", 1, 0, 0,
549 "Given a list (@var{arg1} @dots{} @var{args}), this function\n"
550 "conses the @var{arg1} @dots{} arguments onto the front of\n"
551 "@var{args}, and returns the resulting list. Note that\n"
552 "@var{args} is a list; thus, the argument to this function is\n"
553 "a list whose last element is a list.\n"
554 "Note: Rather than do new consing, @code{apply:nconc2last}\n"
555 "destroys its argument, so use with care.")
556 #define FUNC_NAME s_scm_nconc2last
559 SCM_VALIDATE_NONEMPTYLIST (1, lst
);
561 while (!scm_is_null (SCM_CDR (*lloc
)))
562 lloc
= SCM_CDRLOC (*lloc
);
563 SCM_ASSERT (scm_ilength (SCM_CAR (*lloc
)) >= 0, lst
, SCM_ARG1
, FUNC_NAME
);
564 *lloc
= SCM_CAR (*lloc
);
571 /* Typechecking for multi-argument MAP and FOR-EACH.
573 Verify that each element of the vector ARGV, except for the first,
574 is a proper list whose length is LEN. Attribute errors to WHO,
575 and claim that the i'th element of ARGV is WHO's i+2'th argument. */
577 check_map_args (SCM argv
,
586 for (i
= SCM_SIMPLE_VECTOR_LENGTH (argv
) - 1; i
>= 1; i
--)
588 SCM elt
= SCM_SIMPLE_VECTOR_REF (argv
, i
);
589 long elt_len
= scm_ilength (elt
);
594 scm_apply_generic (gf
, scm_cons (proc
, args
));
596 scm_wrong_type_arg (who
, i
+ 2, elt
);
600 scm_out_of_range_pos (who
, elt
, scm_from_long (i
+ 2));
605 SCM_GPROC (s_map
, "map", 2, 0, 1, scm_map
, g_map
);
607 /* Note: Currently, scm_map applies PROC to the argument list(s)
608 sequentially, starting with the first element(s). This is used in
609 evalext.c where the Scheme procedure `map-in-order', which guarantees
610 sequential behaviour, is implemented using scm_map. If the
611 behaviour changes, we need to update `map-in-order'.
615 scm_map (SCM proc
, SCM arg1
, SCM args
)
616 #define FUNC_NAME s_map
622 len
= scm_ilength (arg1
);
623 SCM_GASSERTn (len
>= 0,
624 g_map
, scm_cons2 (proc
, arg1
, args
), SCM_ARG2
, s_map
);
625 SCM_VALIDATE_REST_ARGUMENT (args
);
626 if (scm_is_null (args
))
628 SCM_GASSERT2 (scm_is_true (scm_procedure_p (proc
)), g_map
, proc
, arg1
, SCM_ARG1
, s_map
);
629 while (SCM_NIMP (arg1
))
631 *pres
= scm_list_1 (scm_call_1 (proc
, SCM_CAR (arg1
)));
632 pres
= SCM_CDRLOC (*pres
);
633 arg1
= SCM_CDR (arg1
);
637 if (scm_is_null (SCM_CDR (args
)))
639 SCM arg2
= SCM_CAR (args
);
640 int len2
= scm_ilength (arg2
);
641 SCM_GASSERTn (scm_is_true (scm_procedure_p (proc
)), g_map
,
642 scm_cons2 (proc
, arg1
, args
), SCM_ARG1
, s_map
);
643 SCM_GASSERTn (len2
>= 0,
644 g_map
, scm_cons2 (proc
, arg1
, args
), SCM_ARG3
, s_map
);
646 SCM_OUT_OF_RANGE (3, arg2
);
647 while (SCM_NIMP (arg1
))
649 *pres
= scm_list_1 (scm_call_2 (proc
, SCM_CAR (arg1
), SCM_CAR (arg2
)));
650 pres
= SCM_CDRLOC (*pres
);
651 arg1
= SCM_CDR (arg1
);
652 arg2
= SCM_CDR (arg2
);
656 arg1
= scm_cons (arg1
, args
);
657 args
= scm_vector (arg1
);
658 check_map_args (args
, len
, g_map
, proc
, arg1
, s_map
);
662 for (i
= SCM_SIMPLE_VECTOR_LENGTH (args
) - 1; i
>= 0; i
--)
664 SCM elt
= SCM_SIMPLE_VECTOR_REF (args
, i
);
667 arg1
= scm_cons (SCM_CAR (elt
), arg1
);
668 SCM_SIMPLE_VECTOR_SET (args
, i
, SCM_CDR (elt
));
670 *pres
= scm_list_1 (scm_apply (proc
, arg1
, SCM_EOL
));
671 pres
= SCM_CDRLOC (*pres
);
677 SCM_GPROC (s_for_each
, "for-each", 2, 0, 1, scm_for_each
, g_for_each
);
680 scm_for_each (SCM proc
, SCM arg1
, SCM args
)
681 #define FUNC_NAME s_for_each
684 len
= scm_ilength (arg1
);
685 SCM_GASSERTn (len
>= 0, g_for_each
, scm_cons2 (proc
, arg1
, args
),
686 SCM_ARG2
, s_for_each
);
687 SCM_VALIDATE_REST_ARGUMENT (args
);
688 if (scm_is_null (args
))
690 SCM_GASSERT2 (scm_is_true (scm_procedure_p (proc
)), g_for_each
,
691 proc
, arg1
, SCM_ARG1
, s_for_each
);
692 while (SCM_NIMP (arg1
))
694 scm_call_1 (proc
, SCM_CAR (arg1
));
695 arg1
= SCM_CDR (arg1
);
697 return SCM_UNSPECIFIED
;
699 if (scm_is_null (SCM_CDR (args
)))
701 SCM arg2
= SCM_CAR (args
);
702 int len2
= scm_ilength (arg2
);
703 SCM_GASSERTn (scm_is_true (scm_procedure_p (proc
)), g_for_each
,
704 scm_cons2 (proc
, arg1
, args
), SCM_ARG1
, s_for_each
);
705 SCM_GASSERTn (len2
>= 0, g_for_each
,
706 scm_cons2 (proc
, arg1
, args
), SCM_ARG3
, s_for_each
);
708 SCM_OUT_OF_RANGE (3, arg2
);
709 while (SCM_NIMP (arg1
))
711 scm_call_2 (proc
, SCM_CAR (arg1
), SCM_CAR (arg2
));
712 arg1
= SCM_CDR (arg1
);
713 arg2
= SCM_CDR (arg2
);
715 return SCM_UNSPECIFIED
;
717 arg1
= scm_cons (arg1
, args
);
718 args
= scm_vector (arg1
);
719 check_map_args (args
, len
, g_for_each
, proc
, arg1
, s_for_each
);
723 for (i
= SCM_SIMPLE_VECTOR_LENGTH (args
) - 1; i
>= 0; i
--)
725 SCM elt
= SCM_SIMPLE_VECTOR_REF (args
, i
);
727 return SCM_UNSPECIFIED
;
728 arg1
= scm_cons (SCM_CAR (elt
), arg1
);
729 SCM_SIMPLE_VECTOR_SET (args
, i
, SCM_CDR (elt
));
731 scm_apply (proc
, arg1
, SCM_EOL
);
738 scm_c_primitive_eval (SCM exp
)
740 if (!SCM_EXPANDED_P (exp
))
741 exp
= scm_call_1 (scm_current_module_transformer (), exp
);
742 return eval (scm_memoize_expression (exp
), SCM_EOL
);
745 static SCM var_primitive_eval
;
747 scm_primitive_eval (SCM exp
)
749 return scm_c_vm_run (scm_the_vm (), scm_variable_ref (var_primitive_eval
),
754 /* Eval does not take the second arg optionally. This is intentional
755 * in order to be R5RS compatible, and to prepare for the new module
756 * system, where we would like to make the choice of evaluation
757 * environment explicit. */
759 SCM_DEFINE (scm_eval
, "eval", 2, 0, 0,
760 (SCM exp
, SCM module_or_state
),
761 "Evaluate @var{exp}, a list representing a Scheme expression,\n"
762 "in the top-level environment specified by\n"
763 "@var{module_or_state}.\n"
764 "While @var{exp} is evaluated (using @code{primitive-eval}),\n"
765 "@var{module_or_state} is made the current module when\n"
766 "it is a module, or the current dynamic state when it is\n"
768 "Example: (eval '(+ 1 2) (interaction-environment))")
769 #define FUNC_NAME s_scm_eval
773 scm_dynwind_begin (SCM_F_DYNWIND_REWINDABLE
);
774 if (scm_is_dynamic_state (module_or_state
))
775 scm_dynwind_current_dynamic_state (module_or_state
);
776 else if (scm_module_system_booted_p
)
778 SCM_VALIDATE_MODULE (2, module_or_state
);
779 scm_dynwind_current_module (module_or_state
);
781 /* otherwise if the module system isn't booted, ignore the module arg */
783 res
= scm_primitive_eval (exp
);
793 /* Apply a function to a list of arguments.
795 This function is exported to the Scheme level as taking two
796 required arguments and a tail argument, as if it were:
797 (lambda (proc arg1 . args) ...)
798 Thus, if you just have a list of arguments to pass to a procedure,
799 pass the list as ARG1, and '() for ARGS. If you have some fixed
800 args, pass the first as ARG1, then cons any remaining fixed args
801 onto the front of your argument list, and pass that as ARGS. */
804 scm_apply (SCM proc
, SCM arg1
, SCM args
)
806 /* Fix things up so that args contains all args. */
807 if (scm_is_null (args
))
810 args
= scm_cons_star (arg1
, args
);
812 return scm_call_with_vm (scm_the_vm (), proc
, args
);
816 prepare_boot_closure_env_for_apply (SCM proc
, SCM args
,
817 SCM
*out_body
, SCM
*out_env
)
819 int nreq
= BOOT_CLOSURE_NUM_REQUIRED_ARGS (proc
);
820 SCM env
= BOOT_CLOSURE_ENV (proc
);
822 if (BOOT_CLOSURE_IS_FIXED (proc
)
823 || (BOOT_CLOSURE_IS_REST (proc
)
824 && !BOOT_CLOSURE_HAS_REST_ARGS (proc
)))
826 if (SCM_UNLIKELY (scm_ilength (args
) != nreq
))
827 scm_wrong_num_args (proc
);
828 for (; scm_is_pair (args
); args
= CDR (args
))
829 env
= scm_cons (CAR (args
), env
);
830 *out_body
= BOOT_CLOSURE_BODY (proc
);
833 else if (BOOT_CLOSURE_IS_REST (proc
))
835 if (SCM_UNLIKELY (scm_ilength (args
) < nreq
))
836 scm_wrong_num_args (proc
);
837 for (; nreq
; nreq
--, args
= CDR (args
))
838 env
= scm_cons (CAR (args
), env
);
839 env
= scm_cons (args
, env
);
840 *out_body
= BOOT_CLOSURE_BODY (proc
);
845 int i
, argc
, nreq
, nopt
;
846 SCM body
, rest
, kw
, inits
, alt
;
847 SCM mx
= BOOT_CLOSURE_CODE (proc
);
850 BOOT_CLOSURE_PARSE_FULL (mx
, body
, nargs
, rest
, nopt
, kw
, inits
, alt
);
852 argc
= scm_ilength (args
);
855 if (scm_is_true (alt
))
861 scm_wrong_num_args (proc
);
863 if (scm_is_false (kw
) && argc
> nreq
+ nopt
&& scm_is_false (rest
))
865 if (scm_is_true (alt
))
871 scm_wrong_num_args (proc
);
874 for (i
= 0; i
< nreq
; i
++, args
= CDR (args
))
875 env
= scm_cons (CAR (args
), env
);
877 if (scm_is_false (kw
))
879 /* Optional args (possibly), but no keyword args. */
880 for (; i
< argc
&& i
< nreq
+ nopt
;
881 i
++, args
= CDR (args
))
883 env
= scm_cons (CAR (args
), env
);
887 for (; i
< nreq
+ nopt
; i
++, inits
= CDR (inits
))
888 env
= scm_cons (eval (CAR (inits
), env
), env
);
890 if (scm_is_true (rest
))
891 env
= scm_cons (args
, env
);
900 /* Keyword args. As before, but stop at the first keyword. */
901 for (; i
< argc
&& i
< nreq
+ nopt
&& !scm_is_keyword (CAR (args
));
902 i
++, args
= CDR (args
), inits
= CDR (inits
))
903 env
= scm_cons (CAR (args
), env
);
905 for (; i
< nreq
+ nopt
; i
++, inits
= CDR (inits
))
906 env
= scm_cons (eval (CAR (inits
), env
), env
);
908 if (scm_is_true (rest
))
910 env
= scm_cons (args
, env
);
914 /* Now fill in env with unbound values, limn the rest of the args for
915 keywords, and fill in unbound values with their inits. */
918 int kw_start_idx
= i
;
920 for (walk
= kw
; scm_is_pair (walk
); walk
= CDR (walk
))
921 if (SCM_I_INUM (CDAR (walk
)) > imax
)
922 imax
= SCM_I_INUM (CDAR (walk
));
923 for (; i
<= imax
; i
++)
924 env
= scm_cons (SCM_UNDEFINED
, env
);
926 if (scm_is_pair (args
) && scm_is_pair (CDR (args
)))
927 for (; scm_is_pair (args
) && scm_is_pair (CDR (args
));
930 k
= CAR (args
); v
= CADR (args
);
931 if (!scm_is_keyword (k
))
933 if (scm_is_true (rest
))
938 for (walk
= kw
; scm_is_pair (walk
); walk
= CDR (walk
))
939 if (scm_is_eq (k
, CAAR (walk
)))
941 /* Well... ok, list-set! isn't the nicest interface, but
943 int iset
= imax
- SCM_I_INUM (CDAR (walk
));
944 scm_list_set_x (env
, SCM_I_MAKINUM (iset
), v
);
948 if (scm_is_null (walk
) && scm_is_false (aok
))
949 error_unrecognized_keyword (proc
);
951 if (scm_is_pair (args
) && scm_is_false (rest
))
952 error_invalid_keyword (proc
);
954 /* Now fill in unbound values, evaluating init expressions in their
955 appropriate environment. */
956 for (i
= imax
- kw_start_idx
; scm_is_pair (inits
); i
--, inits
= CDR (inits
))
958 SCM tail
= scm_list_tail (env
, SCM_I_MAKINUM (i
));
959 if (SCM_UNBNDP (CAR (tail
)))
960 SCM_SETCAR (tail
, eval (CAR (inits
), CDR (tail
)));
971 prepare_boot_closure_env_for_eval (SCM proc
, unsigned int argc
,
972 SCM exps
, SCM
*out_body
, SCM
*inout_env
)
974 int nreq
= BOOT_CLOSURE_NUM_REQUIRED_ARGS (proc
);
975 SCM new_env
= BOOT_CLOSURE_ENV (proc
);
976 if (BOOT_CLOSURE_IS_FIXED (proc
)
977 || (BOOT_CLOSURE_IS_REST (proc
)
978 && !BOOT_CLOSURE_HAS_REST_ARGS (proc
)))
980 for (; scm_is_pair (exps
); exps
= CDR (exps
), nreq
--)
981 new_env
= scm_cons (eval (CAR (exps
), *inout_env
), new_env
);
982 if (SCM_UNLIKELY (nreq
!= 0))
983 scm_wrong_num_args (proc
);
984 *out_body
= BOOT_CLOSURE_BODY (proc
);
985 *inout_env
= new_env
;
987 else if (BOOT_CLOSURE_IS_REST (proc
))
989 if (SCM_UNLIKELY (argc
< nreq
))
990 scm_wrong_num_args (proc
);
991 for (; nreq
; nreq
--, exps
= CDR (exps
))
992 new_env
= scm_cons (eval (CAR (exps
), *inout_env
), new_env
);
995 for (; scm_is_pair (exps
); exps
= CDR (exps
))
996 rest
= scm_cons (eval (CAR (exps
), *inout_env
), rest
);
997 new_env
= scm_cons (scm_reverse (rest
),
1000 *out_body
= BOOT_CLOSURE_BODY (proc
);
1001 *inout_env
= new_env
;
1006 for (; scm_is_pair (exps
); exps
= CDR (exps
))
1007 args
= scm_cons (eval (CAR (exps
), *inout_env
), args
);
1008 args
= scm_reverse_x (args
, SCM_UNDEFINED
);
1009 prepare_boot_closure_env_for_apply (proc
, args
, out_body
, inout_env
);
1014 boot_closure_apply (SCM closure
, SCM args
)
1017 prepare_boot_closure_env_for_apply (closure
, args
, &body
, &env
);
1018 return eval (body
, env
);
1022 boot_closure_print (SCM closure
, SCM port
, scm_print_state
*pstate
)
1025 scm_puts ("#<boot-closure ", port
);
1026 scm_uintprint ((scm_t_bits
)SCM2PTR (closure
), 16, port
);
1027 scm_putc (' ', port
);
1028 args
= scm_make_list (scm_from_int (BOOT_CLOSURE_NUM_REQUIRED_ARGS (closure
)),
1029 scm_from_latin1_symbol ("_"));
1030 if (!BOOT_CLOSURE_IS_FIXED (closure
) && BOOT_CLOSURE_HAS_REST_ARGS (closure
))
1031 args
= scm_cons_star (scm_from_latin1_symbol ("_"), args
);
1032 /* FIXME: optionals and rests */
1033 scm_display (args
, port
);
1034 scm_putc ('>', port
);
1043 f_apply
= scm_c_define_gsubr ("apply", 2, 0, 1, scm_apply
);
1045 scm_tc16_boot_closure
= scm_make_smob_type ("boot-closure", 0);
1046 scm_set_smob_apply (scm_tc16_boot_closure
, boot_closure_apply
, 0, 0, 1);
1047 scm_set_smob_print (scm_tc16_boot_closure
, boot_closure_print
);
1049 primitive_eval
= scm_c_make_gsubr ("primitive-eval", 1, 0, 0,
1050 scm_c_primitive_eval
);
1051 var_primitive_eval
= scm_define (SCM_SUBR_NAME (primitive_eval
),
1054 #include "libguile/eval.x"