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_eval_opts
[] = {
439 { SCM_OPTION_INTEGER
, "stack", 22000, "Size of thread stacks (in machine words)." },
443 scm_t_option scm_debug_opts
[] = {
444 { SCM_OPTION_BOOLEAN
, "cheap", 1,
445 "*This option is now obsolete. Setting it has no effect." },
446 { SCM_OPTION_BOOLEAN
, "breakpoints", 0, "*Check for breakpoints." },
447 { SCM_OPTION_BOOLEAN
, "trace", 0, "*Trace mode." },
448 { SCM_OPTION_BOOLEAN
, "procnames", 1,
449 "Record procedure names at definition." },
450 { SCM_OPTION_BOOLEAN
, "backwards", 0,
451 "Display backtrace in anti-chronological order." },
452 { SCM_OPTION_INTEGER
, "width", 79, "Maximal width of backtrace." },
453 { SCM_OPTION_INTEGER
, "indent", 10, "Maximal indentation in backtrace." },
454 { SCM_OPTION_INTEGER
, "frames", 3,
455 "Maximum number of tail-recursive frames in backtrace." },
456 { SCM_OPTION_INTEGER
, "maxdepth", 1000,
457 "Maximal number of stored backtrace frames." },
458 { SCM_OPTION_INTEGER
, "depth", 20, "Maximal length of printed backtrace." },
459 { SCM_OPTION_BOOLEAN
, "backtrace", 0, "Show backtrace on error." },
460 { SCM_OPTION_BOOLEAN
, "debug", 0, "Use the debugging evaluator." },
461 /* This default stack limit will be overridden by debug.c:init_stack_limit(),
462 if we have getrlimit() and the stack limit is not INFINITY. But it is still
463 important, as some systems have both the soft and the hard limits set to
464 INFINITY; in that case we fall back to this value.
466 The situation is aggravated by certain compilers, which can consume
467 "beaucoup de stack", as they say in France.
469 See http://thread.gmane.org/gmane.lisp.guile.devel/8599/focus=8662 for
470 more discussion. This setting is 640 KB on 32-bit arches (should be enough
471 for anyone!) or a whoppin' 1280 KB on 64-bit arches.
473 { SCM_OPTION_INTEGER
, "stack", 160000, "Stack size limit (measured in words; 0 = no check)." },
474 { SCM_OPTION_SCM
, "show-file-name", (unsigned long)SCM_BOOL_T
,
475 "Show file names and line numbers "
476 "in backtraces when not `#f'. A value of `base' "
477 "displays only base names, while `#t' displays full names."},
478 { SCM_OPTION_BOOLEAN
, "warn-deprecated", 0,
479 "Warn when deprecated features are used." },
485 * this ordering is awkward and illogical, but we maintain it for
486 * compatibility. --hwn
488 scm_t_option scm_evaluator_trap_table
[] = {
489 { SCM_OPTION_BOOLEAN
, "traps", 0, "Enable evaluator traps." },
490 { SCM_OPTION_BOOLEAN
, "enter-frame", 0, "Trap when eval enters new frame." },
491 { SCM_OPTION_BOOLEAN
, "apply-frame", 0, "Trap when entering apply." },
492 { SCM_OPTION_BOOLEAN
, "exit-frame", 0, "Trap when exiting eval or apply." },
493 { SCM_OPTION_SCM
, "enter-frame-handler", (unsigned long)SCM_BOOL_F
, "Handler for enter-frame traps." },
494 { SCM_OPTION_SCM
, "apply-frame-handler", (unsigned long)SCM_BOOL_F
, "Handler for apply-frame traps." },
495 { SCM_OPTION_SCM
, "exit-frame-handler", (unsigned long)SCM_BOOL_F
, "Handler for exit-frame traps." },
496 { SCM_OPTION_BOOLEAN
, "memoize-symbol", 0, "Trap when memoizing a symbol." },
497 { SCM_OPTION_SCM
, "memoize-symbol-handler", (unsigned long)SCM_BOOL_F
, "The handler for memoization." },
502 SCM_DEFINE (scm_eval_options_interface
, "eval-options-interface", 0, 1, 0,
504 "Option interface for the evaluation options. Instead of using\n"
505 "this procedure directly, use the procedures @code{eval-enable},\n"
506 "@code{eval-disable}, @code{eval-set!} and @code{eval-options}.")
507 #define FUNC_NAME s_scm_eval_options_interface
511 scm_dynwind_begin (0);
512 scm_dynwind_critical_section (SCM_BOOL_F
);
513 ans
= scm_options (setting
,
523 SCM_DEFINE (scm_evaluator_traps
, "evaluator-traps-interface", 0, 1, 0,
525 "Option interface for the evaluator trap options.")
526 #define FUNC_NAME s_scm_evaluator_traps
531 scm_options_try (setting
,
532 scm_evaluator_trap_table
,
534 SCM_CRITICAL_SECTION_START
;
535 ans
= scm_options (setting
,
536 scm_evaluator_trap_table
,
539 /* njrev: same again. */
540 SCM_CRITICAL_SECTION_END
;
549 /* Simple procedure calls
553 scm_call_0 (SCM proc
)
555 return scm_c_vm_run (scm_the_vm (), proc
, NULL
, 0);
559 scm_call_1 (SCM proc
, SCM arg1
)
561 return scm_c_vm_run (scm_the_vm (), proc
, &arg1
, 1);
565 scm_call_2 (SCM proc
, SCM arg1
, SCM arg2
)
567 SCM args
[] = { arg1
, arg2
};
568 return scm_c_vm_run (scm_the_vm (), proc
, args
, 2);
572 scm_call_3 (SCM proc
, SCM arg1
, SCM arg2
, SCM arg3
)
574 SCM args
[] = { arg1
, arg2
, arg3
};
575 return scm_c_vm_run (scm_the_vm (), proc
, args
, 3);
579 scm_call_4 (SCM proc
, SCM arg1
, SCM arg2
, SCM arg3
, SCM arg4
)
581 SCM args
[] = { arg1
, arg2
, arg3
, arg4
};
582 return scm_c_vm_run (scm_the_vm (), proc
, args
, 4);
586 scm_call_n (SCM proc
, SCM
*argv
, size_t nargs
)
588 return scm_c_vm_run (scm_the_vm (), proc
, argv
, nargs
);
591 /* Simple procedure applies
595 scm_apply_0 (SCM proc
, SCM args
)
597 return scm_apply (proc
, args
, SCM_EOL
);
601 scm_apply_1 (SCM proc
, SCM arg1
, SCM args
)
603 return scm_apply (proc
, scm_cons (arg1
, args
), SCM_EOL
);
607 scm_apply_2 (SCM proc
, SCM arg1
, SCM arg2
, SCM args
)
609 return scm_apply (proc
, scm_cons2 (arg1
, arg2
, args
), SCM_EOL
);
613 scm_apply_3 (SCM proc
, SCM arg1
, SCM arg2
, SCM arg3
, SCM args
)
615 return scm_apply (proc
, scm_cons (arg1
, scm_cons2 (arg2
, arg3
, args
)),
619 /* This code processes the arguments to apply:
621 (apply PROC ARG1 ... ARGS)
623 Given a list (ARG1 ... ARGS), this function conses the ARG1
624 ... arguments onto the front of ARGS, and returns the resulting
625 list. Note that ARGS is a list; thus, the argument to this
626 function is a list whose last element is a list.
628 Apply calls this function, and applies PROC to the elements of the
629 result. apply:nconc2last takes care of building the list of
630 arguments, given (ARG1 ... ARGS).
632 Rather than do new consing, apply:nconc2last destroys its argument.
633 On that topic, this code came into my care with the following
634 beautifully cryptic comment on that topic: "This will only screw
635 you if you do (scm_apply scm_apply '( ... ))" If you know what
636 they're referring to, send me a patch to this comment. */
638 SCM_DEFINE (scm_nconc2last
, "apply:nconc2last", 1, 0, 0,
640 "Given a list (@var{arg1} @dots{} @var{args}), this function\n"
641 "conses the @var{arg1} @dots{} arguments onto the front of\n"
642 "@var{args}, and returns the resulting list. Note that\n"
643 "@var{args} is a list; thus, the argument to this function is\n"
644 "a list whose last element is a list.\n"
645 "Note: Rather than do new consing, @code{apply:nconc2last}\n"
646 "destroys its argument, so use with care.")
647 #define FUNC_NAME s_scm_nconc2last
650 SCM_VALIDATE_NONEMPTYLIST (1, lst
);
652 while (!scm_is_null (SCM_CDR (*lloc
))) /* Perhaps should be
653 SCM_NULL_OR_NIL_P, but not
654 needed in 99.99% of cases,
655 and it could seriously hurt
656 performance. - Neil */
657 lloc
= SCM_CDRLOC (*lloc
);
658 SCM_ASSERT (scm_ilength (SCM_CAR (*lloc
)) >= 0, lst
, SCM_ARG1
, FUNC_NAME
);
659 *lloc
= SCM_CAR (*lloc
);
666 /* Typechecking for multi-argument MAP and FOR-EACH.
668 Verify that each element of the vector ARGV, except for the first,
669 is a proper list whose length is LEN. Attribute errors to WHO,
670 and claim that the i'th element of ARGV is WHO's i+2'th argument. */
672 check_map_args (SCM argv
,
681 for (i
= SCM_SIMPLE_VECTOR_LENGTH (argv
) - 1; i
>= 1; i
--)
683 SCM elt
= SCM_SIMPLE_VECTOR_REF (argv
, i
);
684 long elt_len
= scm_ilength (elt
);
689 scm_apply_generic (gf
, scm_cons (proc
, args
));
691 scm_wrong_type_arg (who
, i
+ 2, elt
);
695 scm_out_of_range_pos (who
, elt
, scm_from_long (i
+ 2));
700 SCM_GPROC (s_map
, "map", 2, 0, 1, scm_map
, g_map
);
702 /* Note: Currently, scm_map applies PROC to the argument list(s)
703 sequentially, starting with the first element(s). This is used in
704 evalext.c where the Scheme procedure `map-in-order', which guarantees
705 sequential behaviour, is implemented using scm_map. If the
706 behaviour changes, we need to update `map-in-order'.
710 scm_map (SCM proc
, SCM arg1
, SCM args
)
711 #define FUNC_NAME s_map
717 len
= scm_ilength (arg1
);
718 SCM_GASSERTn (len
>= 0,
719 g_map
, scm_cons2 (proc
, arg1
, args
), SCM_ARG2
, s_map
);
720 SCM_VALIDATE_REST_ARGUMENT (args
);
721 if (scm_is_null (args
))
723 SCM_GASSERT2 (scm_is_true (scm_procedure_p (proc
)), g_map
, proc
, arg1
, SCM_ARG1
, s_map
);
724 while (SCM_NIMP (arg1
))
726 *pres
= scm_list_1 (scm_call_1 (proc
, SCM_CAR (arg1
)));
727 pres
= SCM_CDRLOC (*pres
);
728 arg1
= SCM_CDR (arg1
);
732 if (scm_is_null (SCM_CDR (args
)))
734 SCM arg2
= SCM_CAR (args
);
735 int len2
= scm_ilength (arg2
);
736 SCM_GASSERTn (scm_is_true (scm_procedure_p (proc
)), g_map
,
737 scm_cons2 (proc
, arg1
, args
), SCM_ARG1
, s_map
);
738 SCM_GASSERTn (len2
>= 0,
739 g_map
, scm_cons2 (proc
, arg1
, args
), SCM_ARG3
, s_map
);
741 SCM_OUT_OF_RANGE (3, arg2
);
742 while (SCM_NIMP (arg1
))
744 *pres
= scm_list_1 (scm_call_2 (proc
, SCM_CAR (arg1
), SCM_CAR (arg2
)));
745 pres
= SCM_CDRLOC (*pres
);
746 arg1
= SCM_CDR (arg1
);
747 arg2
= SCM_CDR (arg2
);
751 arg1
= scm_cons (arg1
, args
);
752 args
= scm_vector (arg1
);
753 check_map_args (args
, len
, g_map
, proc
, arg1
, s_map
);
757 for (i
= SCM_SIMPLE_VECTOR_LENGTH (args
) - 1; i
>= 0; i
--)
759 SCM elt
= SCM_SIMPLE_VECTOR_REF (args
, i
);
762 arg1
= scm_cons (SCM_CAR (elt
), arg1
);
763 SCM_SIMPLE_VECTOR_SET (args
, i
, SCM_CDR (elt
));
765 *pres
= scm_list_1 (scm_apply (proc
, arg1
, SCM_EOL
));
766 pres
= SCM_CDRLOC (*pres
);
772 SCM_GPROC (s_for_each
, "for-each", 2, 0, 1, scm_for_each
, g_for_each
);
775 scm_for_each (SCM proc
, SCM arg1
, SCM args
)
776 #define FUNC_NAME s_for_each
779 len
= scm_ilength (arg1
);
780 SCM_GASSERTn (len
>= 0, g_for_each
, scm_cons2 (proc
, arg1
, args
),
781 SCM_ARG2
, s_for_each
);
782 SCM_VALIDATE_REST_ARGUMENT (args
);
783 if (scm_is_null (args
))
785 SCM_GASSERT2 (scm_is_true (scm_procedure_p (proc
)), g_for_each
,
786 proc
, arg1
, SCM_ARG1
, s_for_each
);
787 while (SCM_NIMP (arg1
))
789 scm_call_1 (proc
, SCM_CAR (arg1
));
790 arg1
= SCM_CDR (arg1
);
792 return SCM_UNSPECIFIED
;
794 if (scm_is_null (SCM_CDR (args
)))
796 SCM arg2
= SCM_CAR (args
);
797 int len2
= scm_ilength (arg2
);
798 SCM_GASSERTn (scm_is_true (scm_procedure_p (proc
)), g_for_each
,
799 scm_cons2 (proc
, arg1
, args
), SCM_ARG1
, s_for_each
);
800 SCM_GASSERTn (len2
>= 0, g_for_each
,
801 scm_cons2 (proc
, arg1
, args
), SCM_ARG3
, s_for_each
);
803 SCM_OUT_OF_RANGE (3, arg2
);
804 while (SCM_NIMP (arg1
))
806 scm_call_2 (proc
, SCM_CAR (arg1
), SCM_CAR (arg2
));
807 arg1
= SCM_CDR (arg1
);
808 arg2
= SCM_CDR (arg2
);
810 return SCM_UNSPECIFIED
;
812 arg1
= scm_cons (arg1
, args
);
813 args
= scm_vector (arg1
);
814 check_map_args (args
, len
, g_for_each
, proc
, arg1
, s_for_each
);
818 for (i
= SCM_SIMPLE_VECTOR_LENGTH (args
) - 1; i
>= 0; i
--)
820 SCM elt
= SCM_SIMPLE_VECTOR_REF (args
, i
);
822 return SCM_UNSPECIFIED
;
823 arg1
= scm_cons (SCM_CAR (elt
), arg1
);
824 SCM_SIMPLE_VECTOR_SET (args
, i
, SCM_CDR (elt
));
826 scm_apply (proc
, arg1
, SCM_EOL
);
833 scm_c_primitive_eval (SCM exp
)
835 if (!SCM_EXPANDED_P (exp
))
836 exp
= scm_call_1 (scm_current_module_transformer (), exp
);
837 return eval (scm_memoize_expression (exp
), SCM_EOL
);
840 static SCM var_primitive_eval
;
842 scm_primitive_eval (SCM exp
)
844 return scm_c_vm_run (scm_the_vm (), scm_variable_ref (var_primitive_eval
),
849 /* Eval does not take the second arg optionally. This is intentional
850 * in order to be R5RS compatible, and to prepare for the new module
851 * system, where we would like to make the choice of evaluation
852 * environment explicit. */
854 SCM_DEFINE (scm_eval
, "eval", 2, 0, 0,
855 (SCM exp
, SCM module_or_state
),
856 "Evaluate @var{exp}, a list representing a Scheme expression,\n"
857 "in the top-level environment specified by\n"
858 "@var{module_or_state}.\n"
859 "While @var{exp} is evaluated (using @code{primitive-eval}),\n"
860 "@var{module_or_state} is made the current module when\n"
861 "it is a module, or the current dynamic state when it is\n"
863 "Example: (eval '(+ 1 2) (interaction-environment))")
864 #define FUNC_NAME s_scm_eval
868 scm_dynwind_begin (SCM_F_DYNWIND_REWINDABLE
);
869 if (scm_is_dynamic_state (module_or_state
))
870 scm_dynwind_current_dynamic_state (module_or_state
);
871 else if (scm_module_system_booted_p
)
873 SCM_VALIDATE_MODULE (2, module_or_state
);
874 scm_dynwind_current_module (module_or_state
);
876 /* otherwise if the module system isn't booted, ignore the module arg */
878 res
= scm_primitive_eval (exp
);
888 /* Apply a function to a list of arguments.
890 This function is exported to the Scheme level as taking two
891 required arguments and a tail argument, as if it were:
892 (lambda (proc arg1 . args) ...)
893 Thus, if you just have a list of arguments to pass to a procedure,
894 pass the list as ARG1, and '() for ARGS. If you have some fixed
895 args, pass the first as ARG1, then cons any remaining fixed args
896 onto the front of your argument list, and pass that as ARGS. */
899 scm_apply (SCM proc
, SCM arg1
, SCM args
)
901 /* Fix things up so that args contains all args. */
902 if (scm_is_null (args
))
905 args
= scm_cons_star (arg1
, args
);
907 return scm_vm_apply (scm_the_vm (), proc
, args
);
911 prepare_boot_closure_env_for_apply (SCM proc
, SCM args
,
912 SCM
*out_body
, SCM
*out_env
)
914 int nreq
= BOOT_CLOSURE_NUM_REQUIRED_ARGS (proc
);
915 SCM env
= BOOT_CLOSURE_ENV (proc
);
917 if (BOOT_CLOSURE_IS_FIXED (proc
)
918 || (BOOT_CLOSURE_IS_REST (proc
)
919 && !BOOT_CLOSURE_HAS_REST_ARGS (proc
)))
921 if (SCM_UNLIKELY (scm_ilength (args
) != nreq
))
922 scm_wrong_num_args (proc
);
923 for (; scm_is_pair (args
); args
= CDR (args
))
924 env
= scm_cons (CAR (args
), env
);
925 *out_body
= BOOT_CLOSURE_BODY (proc
);
928 else if (BOOT_CLOSURE_IS_REST (proc
))
930 if (SCM_UNLIKELY (scm_ilength (args
) < nreq
))
931 scm_wrong_num_args (proc
);
932 for (; nreq
; nreq
--, args
= CDR (args
))
933 env
= scm_cons (CAR (args
), env
);
934 env
= scm_cons (args
, env
);
935 *out_body
= BOOT_CLOSURE_BODY (proc
);
940 int i
, argc
, nreq
, nopt
;
941 SCM body
, rest
, kw
, inits
, alt
;
942 SCM mx
= BOOT_CLOSURE_CODE (proc
);
945 BOOT_CLOSURE_PARSE_FULL (mx
, body
, nargs
, rest
, nopt
, kw
, inits
, alt
);
947 argc
= scm_ilength (args
);
950 if (scm_is_true (alt
))
956 scm_wrong_num_args (proc
);
958 if (scm_is_false (kw
) && argc
> nreq
+ nopt
&& scm_is_false (rest
))
960 if (scm_is_true (alt
))
966 scm_wrong_num_args (proc
);
969 for (i
= 0; i
< nreq
; i
++, args
= CDR (args
))
970 env
= scm_cons (CAR (args
), env
);
972 if (scm_is_false (kw
))
974 /* Optional args (possibly), but no keyword args. */
975 for (; i
< argc
&& i
< nreq
+ nopt
;
976 i
++, args
= CDR (args
))
978 env
= scm_cons (CAR (args
), env
);
982 for (; i
< nreq
+ nopt
; i
++, inits
= CDR (inits
))
983 env
= scm_cons (eval (CAR (inits
), env
), env
);
985 if (scm_is_true (rest
))
986 env
= scm_cons (args
, env
);
995 /* Keyword args. As before, but stop at the first keyword. */
996 for (; i
< argc
&& i
< nreq
+ nopt
&& !scm_is_keyword (CAR (args
));
997 i
++, args
= CDR (args
), inits
= CDR (inits
))
998 env
= scm_cons (CAR (args
), env
);
1000 for (; i
< nreq
+ nopt
; i
++, inits
= CDR (inits
))
1001 env
= scm_cons (eval (CAR (inits
), env
), env
);
1003 if (scm_is_true (rest
))
1005 env
= scm_cons (args
, env
);
1009 /* Now fill in env with unbound values, limn the rest of the args for
1010 keywords, and fill in unbound values with their inits. */
1013 int kw_start_idx
= i
;
1015 for (walk
= kw
; scm_is_pair (walk
); walk
= CDR (walk
))
1016 if (SCM_I_INUM (CDAR (walk
)) > imax
)
1017 imax
= SCM_I_INUM (CDAR (walk
));
1018 for (; i
<= imax
; i
++)
1019 env
= scm_cons (SCM_UNDEFINED
, env
);
1021 if (scm_is_pair (args
) && scm_is_pair (CDR (args
)))
1022 for (; scm_is_pair (args
) && scm_is_pair (CDR (args
));
1025 k
= CAR (args
); v
= CADR (args
);
1026 if (!scm_is_keyword (k
))
1028 if (scm_is_true (rest
))
1033 for (walk
= kw
; scm_is_pair (walk
); walk
= CDR (walk
))
1034 if (scm_is_eq (k
, CAAR (walk
)))
1036 /* Well... ok, list-set! isn't the nicest interface, but
1038 int iset
= imax
- SCM_I_INUM (CDAR (walk
));
1039 scm_list_set_x (env
, SCM_I_MAKINUM (iset
), v
);
1043 if (scm_is_null (walk
) && scm_is_false (aok
))
1044 error_unrecognized_keyword (proc
);
1046 if (scm_is_pair (args
) && scm_is_false (rest
))
1047 error_invalid_keyword (proc
);
1049 /* Now fill in unbound values, evaluating init expressions in their
1050 appropriate environment. */
1051 for (i
= imax
- kw_start_idx
; scm_is_pair (inits
); i
--, inits
= CDR (inits
))
1053 SCM tail
= scm_list_tail (env
, SCM_I_MAKINUM (i
));
1054 if (SCM_UNBNDP (CAR (tail
)))
1055 SCM_SETCAR (tail
, eval (CAR (inits
), CDR (tail
)));
1066 prepare_boot_closure_env_for_eval (SCM proc
, unsigned int argc
,
1067 SCM exps
, SCM
*out_body
, SCM
*inout_env
)
1069 int nreq
= BOOT_CLOSURE_NUM_REQUIRED_ARGS (proc
);
1070 SCM new_env
= BOOT_CLOSURE_ENV (proc
);
1071 if (BOOT_CLOSURE_IS_FIXED (proc
)
1072 || (BOOT_CLOSURE_IS_REST (proc
)
1073 && !BOOT_CLOSURE_HAS_REST_ARGS (proc
)))
1075 for (; scm_is_pair (exps
); exps
= CDR (exps
), nreq
--)
1076 new_env
= scm_cons (eval (CAR (exps
), *inout_env
), new_env
);
1077 if (SCM_UNLIKELY (nreq
!= 0))
1078 scm_wrong_num_args (proc
);
1079 *out_body
= BOOT_CLOSURE_BODY (proc
);
1080 *inout_env
= new_env
;
1082 else if (BOOT_CLOSURE_IS_REST (proc
))
1084 if (SCM_UNLIKELY (argc
< nreq
))
1085 scm_wrong_num_args (proc
);
1086 for (; nreq
; nreq
--, exps
= CDR (exps
))
1087 new_env
= scm_cons (eval (CAR (exps
), *inout_env
), new_env
);
1090 for (; scm_is_pair (exps
); exps
= CDR (exps
))
1091 rest
= scm_cons (eval (CAR (exps
), *inout_env
), rest
);
1092 new_env
= scm_cons (scm_reverse (rest
),
1095 *out_body
= BOOT_CLOSURE_BODY (proc
);
1096 *inout_env
= new_env
;
1101 for (; scm_is_pair (exps
); exps
= CDR (exps
))
1102 args
= scm_cons (eval (CAR (exps
), *inout_env
), args
);
1103 args
= scm_reverse_x (args
, SCM_UNDEFINED
);
1104 prepare_boot_closure_env_for_apply (proc
, args
, out_body
, inout_env
);
1109 boot_closure_apply (SCM closure
, SCM args
)
1112 prepare_boot_closure_env_for_apply (closure
, args
, &body
, &env
);
1113 return eval (body
, env
);
1117 boot_closure_print (SCM closure
, SCM port
, scm_print_state
*pstate
)
1120 scm_puts ("#<boot-closure ", port
);
1121 scm_uintprint ((unsigned long)SCM2PTR (closure
), 16, port
);
1122 scm_putc (' ', port
);
1123 args
= scm_make_list (scm_from_int (BOOT_CLOSURE_NUM_REQUIRED_ARGS (closure
)),
1124 scm_from_locale_symbol ("_"));
1125 if (!BOOT_CLOSURE_IS_FIXED (closure
) && BOOT_CLOSURE_HAS_REST_ARGS (closure
))
1126 args
= scm_cons_star (scm_from_locale_symbol ("_"), args
);
1127 /* FIXME: optionals and rests */
1128 scm_display (args
, port
);
1129 scm_putc ('>', port
);
1138 scm_init_opts (scm_evaluator_traps
,
1139 scm_evaluator_trap_table
);
1140 scm_init_opts (scm_eval_options_interface
,
1143 f_apply
= scm_c_define_gsubr ("apply", 2, 0, 1, scm_apply
);
1145 scm_tc16_boot_closure
= scm_make_smob_type ("boot-closure", 0);
1146 scm_set_smob_apply (scm_tc16_boot_closure
, boot_closure_apply
, 0, 0, 1);
1147 scm_set_smob_print (scm_tc16_boot_closure
, boot_closure_print
);
1149 primitive_eval
= scm_c_make_gsubr ("primitive-eval", 1, 0, 0,
1150 scm_c_primitive_eval
);
1151 var_primitive_eval
= scm_define (SCM_SUBR_NAME (primitive_eval
),
1154 #include "libguile/eval.x"