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_vm_apply (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_vm_apply (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 ()));
438 scm_t_option scm_debug_opts
[] = {
439 { SCM_OPTION_BOOLEAN
, "cheap", 1,
440 "*This option is now obsolete. Setting it has no effect." },
441 { SCM_OPTION_BOOLEAN
, "breakpoints", 0,
442 "*This option is now obsolete. Setting it has no effect." },
443 { SCM_OPTION_BOOLEAN
, "trace", 0,
444 "*This option is now obsolete. Setting it has no effect." },
445 { SCM_OPTION_BOOLEAN
, "procnames", 1,
446 "*This option is now obsolete. Setting it has no effect." },
447 { SCM_OPTION_BOOLEAN
, "backwards", 0,
448 "Display backtrace in anti-chronological order." },
449 { SCM_OPTION_INTEGER
, "width", 79, "Maximal width of backtrace." },
450 { SCM_OPTION_INTEGER
, "indent", 10, "Maximal indentation in backtrace." },
451 { SCM_OPTION_INTEGER
, "frames", 3,
452 "Maximum number of tail-recursive frames in backtrace." },
453 { SCM_OPTION_INTEGER
, "maxdepth", 1000,
454 "Maximal number of stored backtrace frames." },
455 { SCM_OPTION_INTEGER
, "depth", 20, "Maximal length of printed backtrace." },
456 { SCM_OPTION_BOOLEAN
, "backtrace", 0, "Show backtrace on error." },
457 { SCM_OPTION_BOOLEAN
, "debug", 0, "Use the debugging evaluator." },
458 /* This default stack limit will be overridden by debug.c:init_stack_limit(),
459 if we have getrlimit() and the stack limit is not INFINITY. But it is still
460 important, as some systems have both the soft and the hard limits set to
461 INFINITY; in that case we fall back to this value.
463 The situation is aggravated by certain compilers, which can consume
464 "beaucoup de stack", as they say in France.
466 See http://thread.gmane.org/gmane.lisp.guile.devel/8599/focus=8662 for
467 more discussion. This setting is 640 KB on 32-bit arches (should be enough
468 for anyone!) or a whoppin' 1280 KB on 64-bit arches.
470 { SCM_OPTION_INTEGER
, "stack", 160000, "Stack size limit (measured in words; 0 = no check)." },
471 { SCM_OPTION_SCM
, "show-file-name", (unsigned long)SCM_BOOL_T
,
472 "Show file names and line numbers "
473 "in backtraces when not `#f'. A value of `base' "
474 "displays only base names, while `#t' displays full names."},
475 { SCM_OPTION_BOOLEAN
, "warn-deprecated", 0,
476 "Warn when deprecated features are used." },
482 * this ordering is awkward and illogical, but we maintain it for
483 * compatibility. --hwn
485 scm_t_option scm_evaluator_trap_table
[] = {
486 { SCM_OPTION_BOOLEAN
, "traps", 0, "Enable evaluator traps." },
487 { SCM_OPTION_BOOLEAN
, "enter-frame", 0, "Trap when eval enters new frame." },
488 { SCM_OPTION_BOOLEAN
, "apply-frame", 0, "Trap when entering apply." },
489 { SCM_OPTION_BOOLEAN
, "exit-frame", 0, "Trap when exiting eval or apply." },
490 { SCM_OPTION_SCM
, "enter-frame-handler", (unsigned long)SCM_BOOL_F
, "Handler for enter-frame traps." },
491 { SCM_OPTION_SCM
, "apply-frame-handler", (unsigned long)SCM_BOOL_F
, "Handler for apply-frame traps." },
492 { SCM_OPTION_SCM
, "exit-frame-handler", (unsigned long)SCM_BOOL_F
, "Handler for exit-frame traps." },
493 { SCM_OPTION_BOOLEAN
, "memoize-symbol", 0, "Trap when memoizing a symbol." },
494 { SCM_OPTION_SCM
, "memoize-symbol-handler", (unsigned long)SCM_BOOL_F
, "The handler for memoization." },
499 SCM_DEFINE (scm_evaluator_traps
, "evaluator-traps-interface", 0, 1, 0,
501 "Option interface for the evaluator trap options.")
502 #define FUNC_NAME s_scm_evaluator_traps
507 scm_options_try (setting
,
508 scm_evaluator_trap_table
,
510 SCM_CRITICAL_SECTION_START
;
511 ans
= scm_options (setting
,
512 scm_evaluator_trap_table
,
515 /* njrev: same again. */
516 SCM_CRITICAL_SECTION_END
;
525 /* Simple procedure calls
529 scm_call_0 (SCM proc
)
531 return scm_c_vm_run (scm_the_vm (), proc
, NULL
, 0);
535 scm_call_1 (SCM proc
, SCM arg1
)
537 return scm_c_vm_run (scm_the_vm (), proc
, &arg1
, 1);
541 scm_call_2 (SCM proc
, SCM arg1
, SCM arg2
)
543 SCM args
[] = { arg1
, arg2
};
544 return scm_c_vm_run (scm_the_vm (), proc
, args
, 2);
548 scm_call_3 (SCM proc
, SCM arg1
, SCM arg2
, SCM arg3
)
550 SCM args
[] = { arg1
, arg2
, arg3
};
551 return scm_c_vm_run (scm_the_vm (), proc
, args
, 3);
555 scm_call_4 (SCM proc
, SCM arg1
, SCM arg2
, SCM arg3
, SCM arg4
)
557 SCM args
[] = { arg1
, arg2
, arg3
, arg4
};
558 return scm_c_vm_run (scm_the_vm (), proc
, args
, 4);
562 scm_call_n (SCM proc
, SCM
*argv
, size_t nargs
)
564 return scm_c_vm_run (scm_the_vm (), proc
, argv
, nargs
);
567 /* Simple procedure applies
571 scm_apply_0 (SCM proc
, SCM args
)
573 return scm_apply (proc
, args
, SCM_EOL
);
577 scm_apply_1 (SCM proc
, SCM arg1
, SCM args
)
579 return scm_apply (proc
, scm_cons (arg1
, args
), SCM_EOL
);
583 scm_apply_2 (SCM proc
, SCM arg1
, SCM arg2
, SCM args
)
585 return scm_apply (proc
, scm_cons2 (arg1
, arg2
, args
), SCM_EOL
);
589 scm_apply_3 (SCM proc
, SCM arg1
, SCM arg2
, SCM arg3
, SCM args
)
591 return scm_apply (proc
, scm_cons (arg1
, scm_cons2 (arg2
, arg3
, args
)),
595 /* This code processes the arguments to apply:
597 (apply PROC ARG1 ... ARGS)
599 Given a list (ARG1 ... ARGS), this function conses the ARG1
600 ... arguments onto the front of ARGS, and returns the resulting
601 list. Note that ARGS is a list; thus, the argument to this
602 function is a list whose last element is a list.
604 Apply calls this function, and applies PROC to the elements of the
605 result. apply:nconc2last takes care of building the list of
606 arguments, given (ARG1 ... ARGS).
608 Rather than do new consing, apply:nconc2last destroys its argument.
609 On that topic, this code came into my care with the following
610 beautifully cryptic comment on that topic: "This will only screw
611 you if you do (scm_apply scm_apply '( ... ))" If you know what
612 they're referring to, send me a patch to this comment. */
614 SCM_DEFINE (scm_nconc2last
, "apply:nconc2last", 1, 0, 0,
616 "Given a list (@var{arg1} @dots{} @var{args}), this function\n"
617 "conses the @var{arg1} @dots{} arguments onto the front of\n"
618 "@var{args}, and returns the resulting list. Note that\n"
619 "@var{args} is a list; thus, the argument to this function is\n"
620 "a list whose last element is a list.\n"
621 "Note: Rather than do new consing, @code{apply:nconc2last}\n"
622 "destroys its argument, so use with care.")
623 #define FUNC_NAME s_scm_nconc2last
626 SCM_VALIDATE_NONEMPTYLIST (1, lst
);
628 while (!scm_is_null (SCM_CDR (*lloc
))) /* Perhaps should be
629 SCM_NULL_OR_NIL_P, but not
630 needed in 99.99% of cases,
631 and it could seriously hurt
632 performance. - Neil */
633 lloc
= SCM_CDRLOC (*lloc
);
634 SCM_ASSERT (scm_ilength (SCM_CAR (*lloc
)) >= 0, lst
, SCM_ARG1
, FUNC_NAME
);
635 *lloc
= SCM_CAR (*lloc
);
642 /* Typechecking for multi-argument MAP and FOR-EACH.
644 Verify that each element of the vector ARGV, except for the first,
645 is a proper list whose length is LEN. Attribute errors to WHO,
646 and claim that the i'th element of ARGV is WHO's i+2'th argument. */
648 check_map_args (SCM argv
,
657 for (i
= SCM_SIMPLE_VECTOR_LENGTH (argv
) - 1; i
>= 1; i
--)
659 SCM elt
= SCM_SIMPLE_VECTOR_REF (argv
, i
);
660 long elt_len
= scm_ilength (elt
);
665 scm_apply_generic (gf
, scm_cons (proc
, args
));
667 scm_wrong_type_arg (who
, i
+ 2, elt
);
671 scm_out_of_range_pos (who
, elt
, scm_from_long (i
+ 2));
676 SCM_GPROC (s_map
, "map", 2, 0, 1, scm_map
, g_map
);
678 /* Note: Currently, scm_map applies PROC to the argument list(s)
679 sequentially, starting with the first element(s). This is used in
680 evalext.c where the Scheme procedure `map-in-order', which guarantees
681 sequential behaviour, is implemented using scm_map. If the
682 behaviour changes, we need to update `map-in-order'.
686 scm_map (SCM proc
, SCM arg1
, SCM args
)
687 #define FUNC_NAME s_map
693 len
= scm_ilength (arg1
);
694 SCM_GASSERTn (len
>= 0,
695 g_map
, scm_cons2 (proc
, arg1
, args
), SCM_ARG2
, s_map
);
696 SCM_VALIDATE_REST_ARGUMENT (args
);
697 if (scm_is_null (args
))
699 SCM_GASSERT2 (scm_is_true (scm_procedure_p (proc
)), g_map
, proc
, arg1
, SCM_ARG1
, s_map
);
700 while (SCM_NIMP (arg1
))
702 *pres
= scm_list_1 (scm_call_1 (proc
, SCM_CAR (arg1
)));
703 pres
= SCM_CDRLOC (*pres
);
704 arg1
= SCM_CDR (arg1
);
708 if (scm_is_null (SCM_CDR (args
)))
710 SCM arg2
= SCM_CAR (args
);
711 int len2
= scm_ilength (arg2
);
712 SCM_GASSERTn (scm_is_true (scm_procedure_p (proc
)), g_map
,
713 scm_cons2 (proc
, arg1
, args
), SCM_ARG1
, s_map
);
714 SCM_GASSERTn (len2
>= 0,
715 g_map
, scm_cons2 (proc
, arg1
, args
), SCM_ARG3
, s_map
);
717 SCM_OUT_OF_RANGE (3, arg2
);
718 while (SCM_NIMP (arg1
))
720 *pres
= scm_list_1 (scm_call_2 (proc
, SCM_CAR (arg1
), SCM_CAR (arg2
)));
721 pres
= SCM_CDRLOC (*pres
);
722 arg1
= SCM_CDR (arg1
);
723 arg2
= SCM_CDR (arg2
);
727 arg1
= scm_cons (arg1
, args
);
728 args
= scm_vector (arg1
);
729 check_map_args (args
, len
, g_map
, proc
, arg1
, s_map
);
733 for (i
= SCM_SIMPLE_VECTOR_LENGTH (args
) - 1; i
>= 0; i
--)
735 SCM elt
= SCM_SIMPLE_VECTOR_REF (args
, i
);
738 arg1
= scm_cons (SCM_CAR (elt
), arg1
);
739 SCM_SIMPLE_VECTOR_SET (args
, i
, SCM_CDR (elt
));
741 *pres
= scm_list_1 (scm_apply (proc
, arg1
, SCM_EOL
));
742 pres
= SCM_CDRLOC (*pres
);
748 SCM_GPROC (s_for_each
, "for-each", 2, 0, 1, scm_for_each
, g_for_each
);
751 scm_for_each (SCM proc
, SCM arg1
, SCM args
)
752 #define FUNC_NAME s_for_each
755 len
= scm_ilength (arg1
);
756 SCM_GASSERTn (len
>= 0, g_for_each
, scm_cons2 (proc
, arg1
, args
),
757 SCM_ARG2
, s_for_each
);
758 SCM_VALIDATE_REST_ARGUMENT (args
);
759 if (scm_is_null (args
))
761 SCM_GASSERT2 (scm_is_true (scm_procedure_p (proc
)), g_for_each
,
762 proc
, arg1
, SCM_ARG1
, s_for_each
);
763 while (SCM_NIMP (arg1
))
765 scm_call_1 (proc
, SCM_CAR (arg1
));
766 arg1
= SCM_CDR (arg1
);
768 return SCM_UNSPECIFIED
;
770 if (scm_is_null (SCM_CDR (args
)))
772 SCM arg2
= SCM_CAR (args
);
773 int len2
= scm_ilength (arg2
);
774 SCM_GASSERTn (scm_is_true (scm_procedure_p (proc
)), g_for_each
,
775 scm_cons2 (proc
, arg1
, args
), SCM_ARG1
, s_for_each
);
776 SCM_GASSERTn (len2
>= 0, g_for_each
,
777 scm_cons2 (proc
, arg1
, args
), SCM_ARG3
, s_for_each
);
779 SCM_OUT_OF_RANGE (3, arg2
);
780 while (SCM_NIMP (arg1
))
782 scm_call_2 (proc
, SCM_CAR (arg1
), SCM_CAR (arg2
));
783 arg1
= SCM_CDR (arg1
);
784 arg2
= SCM_CDR (arg2
);
786 return SCM_UNSPECIFIED
;
788 arg1
= scm_cons (arg1
, args
);
789 args
= scm_vector (arg1
);
790 check_map_args (args
, len
, g_for_each
, proc
, arg1
, s_for_each
);
794 for (i
= SCM_SIMPLE_VECTOR_LENGTH (args
) - 1; i
>= 0; i
--)
796 SCM elt
= SCM_SIMPLE_VECTOR_REF (args
, i
);
798 return SCM_UNSPECIFIED
;
799 arg1
= scm_cons (SCM_CAR (elt
), arg1
);
800 SCM_SIMPLE_VECTOR_SET (args
, i
, SCM_CDR (elt
));
802 scm_apply (proc
, arg1
, SCM_EOL
);
809 scm_c_primitive_eval (SCM exp
)
811 if (!SCM_EXPANDED_P (exp
))
812 exp
= scm_call_1 (scm_current_module_transformer (), exp
);
813 return eval (scm_memoize_expression (exp
), SCM_EOL
);
816 static SCM var_primitive_eval
;
818 scm_primitive_eval (SCM exp
)
820 return scm_c_vm_run (scm_the_vm (), scm_variable_ref (var_primitive_eval
),
825 /* Eval does not take the second arg optionally. This is intentional
826 * in order to be R5RS compatible, and to prepare for the new module
827 * system, where we would like to make the choice of evaluation
828 * environment explicit. */
830 SCM_DEFINE (scm_eval
, "eval", 2, 0, 0,
831 (SCM exp
, SCM module_or_state
),
832 "Evaluate @var{exp}, a list representing a Scheme expression,\n"
833 "in the top-level environment specified by\n"
834 "@var{module_or_state}.\n"
835 "While @var{exp} is evaluated (using @code{primitive-eval}),\n"
836 "@var{module_or_state} is made the current module when\n"
837 "it is a module, or the current dynamic state when it is\n"
839 "Example: (eval '(+ 1 2) (interaction-environment))")
840 #define FUNC_NAME s_scm_eval
844 scm_dynwind_begin (SCM_F_DYNWIND_REWINDABLE
);
845 if (scm_is_dynamic_state (module_or_state
))
846 scm_dynwind_current_dynamic_state (module_or_state
);
847 else if (scm_module_system_booted_p
)
849 SCM_VALIDATE_MODULE (2, module_or_state
);
850 scm_dynwind_current_module (module_or_state
);
852 /* otherwise if the module system isn't booted, ignore the module arg */
854 res
= scm_primitive_eval (exp
);
864 /* Apply a function to a list of arguments.
866 This function is exported to the Scheme level as taking two
867 required arguments and a tail argument, as if it were:
868 (lambda (proc arg1 . args) ...)
869 Thus, if you just have a list of arguments to pass to a procedure,
870 pass the list as ARG1, and '() for ARGS. If you have some fixed
871 args, pass the first as ARG1, then cons any remaining fixed args
872 onto the front of your argument list, and pass that as ARGS. */
875 scm_apply (SCM proc
, SCM arg1
, SCM args
)
877 /* Fix things up so that args contains all args. */
878 if (scm_is_null (args
))
881 args
= scm_cons_star (arg1
, args
);
883 return scm_vm_apply (scm_the_vm (), proc
, args
);
887 prepare_boot_closure_env_for_apply (SCM proc
, SCM args
,
888 SCM
*out_body
, SCM
*out_env
)
890 int nreq
= BOOT_CLOSURE_NUM_REQUIRED_ARGS (proc
);
891 SCM env
= BOOT_CLOSURE_ENV (proc
);
893 if (BOOT_CLOSURE_IS_FIXED (proc
)
894 || (BOOT_CLOSURE_IS_REST (proc
)
895 && !BOOT_CLOSURE_HAS_REST_ARGS (proc
)))
897 if (SCM_UNLIKELY (scm_ilength (args
) != nreq
))
898 scm_wrong_num_args (proc
);
899 for (; scm_is_pair (args
); args
= CDR (args
))
900 env
= scm_cons (CAR (args
), env
);
901 *out_body
= BOOT_CLOSURE_BODY (proc
);
904 else if (BOOT_CLOSURE_IS_REST (proc
))
906 if (SCM_UNLIKELY (scm_ilength (args
) < nreq
))
907 scm_wrong_num_args (proc
);
908 for (; nreq
; nreq
--, args
= CDR (args
))
909 env
= scm_cons (CAR (args
), env
);
910 env
= scm_cons (args
, env
);
911 *out_body
= BOOT_CLOSURE_BODY (proc
);
916 int i
, argc
, nreq
, nopt
;
917 SCM body
, rest
, kw
, inits
, alt
;
918 SCM mx
= BOOT_CLOSURE_CODE (proc
);
921 BOOT_CLOSURE_PARSE_FULL (mx
, body
, nargs
, rest
, nopt
, kw
, inits
, alt
);
923 argc
= scm_ilength (args
);
926 if (scm_is_true (alt
))
932 scm_wrong_num_args (proc
);
934 if (scm_is_false (kw
) && argc
> nreq
+ nopt
&& scm_is_false (rest
))
936 if (scm_is_true (alt
))
942 scm_wrong_num_args (proc
);
945 for (i
= 0; i
< nreq
; i
++, args
= CDR (args
))
946 env
= scm_cons (CAR (args
), env
);
948 if (scm_is_false (kw
))
950 /* Optional args (possibly), but no keyword args. */
951 for (; i
< argc
&& i
< nreq
+ nopt
;
952 i
++, args
= CDR (args
))
954 env
= scm_cons (CAR (args
), env
);
958 for (; i
< nreq
+ nopt
; i
++, inits
= CDR (inits
))
959 env
= scm_cons (eval (CAR (inits
), env
), env
);
961 if (scm_is_true (rest
))
962 env
= scm_cons (args
, env
);
971 /* Keyword args. As before, but stop at the first keyword. */
972 for (; i
< argc
&& i
< nreq
+ nopt
&& !scm_is_keyword (CAR (args
));
973 i
++, args
= CDR (args
), inits
= CDR (inits
))
974 env
= scm_cons (CAR (args
), env
);
976 for (; i
< nreq
+ nopt
; i
++, inits
= CDR (inits
))
977 env
= scm_cons (eval (CAR (inits
), env
), env
);
979 if (scm_is_true (rest
))
981 env
= scm_cons (args
, env
);
985 /* Now fill in env with unbound values, limn the rest of the args for
986 keywords, and fill in unbound values with their inits. */
989 int kw_start_idx
= i
;
991 for (walk
= kw
; scm_is_pair (walk
); walk
= CDR (walk
))
992 if (SCM_I_INUM (CDAR (walk
)) > imax
)
993 imax
= SCM_I_INUM (CDAR (walk
));
994 for (; i
<= imax
; i
++)
995 env
= scm_cons (SCM_UNDEFINED
, env
);
997 if (scm_is_pair (args
) && scm_is_pair (CDR (args
)))
998 for (; scm_is_pair (args
) && scm_is_pair (CDR (args
));
1001 k
= CAR (args
); v
= CADR (args
);
1002 if (!scm_is_keyword (k
))
1004 if (scm_is_true (rest
))
1009 for (walk
= kw
; scm_is_pair (walk
); walk
= CDR (walk
))
1010 if (scm_is_eq (k
, CAAR (walk
)))
1012 /* Well... ok, list-set! isn't the nicest interface, but
1014 int iset
= imax
- SCM_I_INUM (CDAR (walk
));
1015 scm_list_set_x (env
, SCM_I_MAKINUM (iset
), v
);
1019 if (scm_is_null (walk
) && scm_is_false (aok
))
1020 error_unrecognized_keyword (proc
);
1022 if (scm_is_pair (args
) && scm_is_false (rest
))
1023 error_invalid_keyword (proc
);
1025 /* Now fill in unbound values, evaluating init expressions in their
1026 appropriate environment. */
1027 for (i
= imax
- kw_start_idx
; scm_is_pair (inits
); i
--, inits
= CDR (inits
))
1029 SCM tail
= scm_list_tail (env
, SCM_I_MAKINUM (i
));
1030 if (SCM_UNBNDP (CAR (tail
)))
1031 SCM_SETCAR (tail
, eval (CAR (inits
), CDR (tail
)));
1042 prepare_boot_closure_env_for_eval (SCM proc
, unsigned int argc
,
1043 SCM exps
, SCM
*out_body
, SCM
*inout_env
)
1045 int nreq
= BOOT_CLOSURE_NUM_REQUIRED_ARGS (proc
);
1046 SCM new_env
= BOOT_CLOSURE_ENV (proc
);
1047 if (BOOT_CLOSURE_IS_FIXED (proc
)
1048 || (BOOT_CLOSURE_IS_REST (proc
)
1049 && !BOOT_CLOSURE_HAS_REST_ARGS (proc
)))
1051 for (; scm_is_pair (exps
); exps
= CDR (exps
), nreq
--)
1052 new_env
= scm_cons (eval (CAR (exps
), *inout_env
), new_env
);
1053 if (SCM_UNLIKELY (nreq
!= 0))
1054 scm_wrong_num_args (proc
);
1055 *out_body
= BOOT_CLOSURE_BODY (proc
);
1056 *inout_env
= new_env
;
1058 else if (BOOT_CLOSURE_IS_REST (proc
))
1060 if (SCM_UNLIKELY (argc
< nreq
))
1061 scm_wrong_num_args (proc
);
1062 for (; nreq
; nreq
--, exps
= CDR (exps
))
1063 new_env
= scm_cons (eval (CAR (exps
), *inout_env
), new_env
);
1066 for (; scm_is_pair (exps
); exps
= CDR (exps
))
1067 rest
= scm_cons (eval (CAR (exps
), *inout_env
), rest
);
1068 new_env
= scm_cons (scm_reverse (rest
),
1071 *out_body
= BOOT_CLOSURE_BODY (proc
);
1072 *inout_env
= new_env
;
1077 for (; scm_is_pair (exps
); exps
= CDR (exps
))
1078 args
= scm_cons (eval (CAR (exps
), *inout_env
), args
);
1079 args
= scm_reverse_x (args
, SCM_UNDEFINED
);
1080 prepare_boot_closure_env_for_apply (proc
, args
, out_body
, inout_env
);
1085 boot_closure_apply (SCM closure
, SCM args
)
1088 prepare_boot_closure_env_for_apply (closure
, args
, &body
, &env
);
1089 return eval (body
, env
);
1093 boot_closure_print (SCM closure
, SCM port
, scm_print_state
*pstate
)
1096 scm_puts ("#<boot-closure ", port
);
1097 scm_uintprint ((unsigned long)SCM2PTR (closure
), 16, port
);
1098 scm_putc (' ', port
);
1099 args
= scm_make_list (scm_from_int (BOOT_CLOSURE_NUM_REQUIRED_ARGS (closure
)),
1100 scm_from_locale_symbol ("_"));
1101 if (!BOOT_CLOSURE_IS_FIXED (closure
) && BOOT_CLOSURE_HAS_REST_ARGS (closure
))
1102 args
= scm_cons_star (scm_from_locale_symbol ("_"), args
);
1103 /* FIXME: optionals and rests */
1104 scm_display (args
, port
);
1105 scm_putc ('>', port
);
1114 scm_init_opts (scm_evaluator_traps
,
1115 scm_evaluator_trap_table
);
1117 f_apply
= scm_c_define_gsubr ("apply", 2, 0, 1, scm_apply
);
1119 scm_tc16_boot_closure
= scm_make_smob_type ("boot-closure", 0);
1120 scm_set_smob_apply (scm_tc16_boot_closure
, boot_closure_apply
, 0, 0, 1);
1121 scm_set_smob_print (scm_tc16_boot_closure
, boot_closure_print
);
1123 primitive_eval
= scm_c_make_gsubr ("primitive-eval", 1, 0, 0,
1124 scm_c_primitive_eval
);
1125 var_primitive_eval
= scm_define (SCM_SUBR_NAME (primitive_eval
),
1128 #include "libguile/eval.x"