1 /* Copyright (C) 1995,1996,1997,1998,1999,2000,2001,2002,2003,2004,2005,2006,2007,2008,2009
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"
31 #include "libguile/_scm.h"
32 #include "libguile/alist.h"
33 #include "libguile/async.h"
34 #include "libguile/continuations.h"
35 #include "libguile/debug.h"
36 #include "libguile/deprecation.h"
37 #include "libguile/dynwind.h"
38 #include "libguile/eq.h"
39 #include "libguile/feature.h"
40 #include "libguile/fluids.h"
41 #include "libguile/goops.h"
42 #include "libguile/hash.h"
43 #include "libguile/hashtab.h"
44 #include "libguile/lang.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.
101 #define CAR(x) SCM_CAR(x)
102 #define CDR(x) SCM_CDR(x)
103 #define CAAR(x) SCM_CAAR(x)
104 #define CADR(x) SCM_CADR(x)
105 #define CDAR(x) SCM_CDAR(x)
106 #define CDDR(x) SCM_CDDR(x)
107 #define CADDR(x) SCM_CADDR(x)
108 #define CDDDR(x) SCM_CDDDR(x)
110 #define CAR(x) scm_car(x)
111 #define CDR(x) scm_cdr(x)
112 #define CAAR(x) scm_caar(x)
113 #define CADR(x) scm_cadr(x)
114 #define CDAR(x) scm_cdar(x)
115 #define CDDR(x) scm_cddr(x)
116 #define CADDR(x) scm_caddr(x)
117 #define CDDDR(x) scm_cdddr(x)
121 SCM_SYMBOL (scm_unbound_variable_key
, "unbound-variable");
123 static void error_used_before_defined (void)
125 scm_error (scm_unbound_variable_key
, NULL
,
126 "Variable used before given a value", SCM_EOL
, SCM_BOOL_F
);
130 scm_badargsp (SCM formals
, SCM args
)
132 while (!scm_is_null (formals
))
134 if (!scm_is_pair (formals
))
136 if (scm_is_null (args
))
138 formals
= CDR (formals
);
141 return !scm_is_null (args
) ? 1 : 0;
144 static SCM
apply (SCM proc
, SCM args
);
148 If MOD is #f, it means the environment was captured before modules were
150 If MOD is the literal value '(), we are evaluating at the top level, and so
151 should track changes to the current module. You have to be careful in this
152 case, because further lexical contours should capture the current module.
154 #define CAPTURE_ENV(env) \
155 ((env == SCM_EOL) ? scm_current_module () : \
156 ((env == SCM_BOOL_F) ? scm_the_root_module () : env))
159 eval (SCM x
, SCM env
)
162 SCM proc
= SCM_UNDEFINED
, args
= SCM_EOL
;
166 if (!SCM_MEMOIZED_P (x
))
169 mx
= SCM_MEMOIZED_ARGS (x
);
170 switch (SCM_MEMOIZED_TAG (x
))
173 for (; !scm_is_null (CDR (mx
)); mx
= CDR (mx
))
174 eval (CAR (mx
), env
);
179 if (scm_is_true (eval (CAR (mx
), env
)))
187 SCM inits
= CAR (mx
);
188 SCM new_env
= CAPTURE_ENV (env
);
189 for (; scm_is_pair (inits
); inits
= CDR (inits
))
190 new_env
= scm_cons (eval (CAR (inits
), env
), new_env
);
197 return scm_closure (mx
, CAPTURE_ENV (env
));
203 scm_define (CAR (mx
), eval (CDR (mx
), env
));
204 return SCM_UNSPECIFIED
;
207 /* Evaluate the procedure to be applied. */
208 proc
= eval (CAR (mx
), env
);
209 /* Evaluate the argument holding the list of arguments */
210 args
= eval (CADR (mx
), env
);
213 /* Go here to tail-apply a procedure. PROC is the procedure and
214 * ARGS is the list of arguments. */
215 if (SCM_CLOSUREP (proc
))
217 int nreq
= SCM_CLOSURE_NUM_REQUIRED_ARGS (proc
);
218 SCM new_env
= SCM_ENV (proc
);
219 if (SCM_CLOSURE_HAS_REST_ARGS (proc
))
221 if (SCM_UNLIKELY (scm_ilength (args
) < nreq
))
222 scm_wrong_num_args (proc
);
223 for (; nreq
; nreq
--, args
= CDR (args
))
224 new_env
= scm_cons (CAR (args
), new_env
);
225 new_env
= scm_cons (args
, new_env
);
229 if (SCM_UNLIKELY (scm_ilength (args
) != nreq
))
230 scm_wrong_num_args (proc
);
231 for (; scm_is_pair (args
); args
= CDR (args
))
232 new_env
= scm_cons (CAR (args
), new_env
);
234 x
= SCM_CLOSURE_BODY (proc
);
239 return apply (proc
, args
);
242 /* Evaluate the procedure to be applied. */
243 proc
= eval (CAR (mx
), env
);
247 if (SCM_CLOSUREP (proc
))
249 int nreq
= SCM_CLOSURE_NUM_REQUIRED_ARGS (proc
);
250 SCM new_env
= SCM_ENV (proc
);
251 if (SCM_CLOSURE_HAS_REST_ARGS (proc
))
253 if (SCM_UNLIKELY (scm_ilength (mx
) < nreq
))
254 scm_wrong_num_args (proc
);
255 for (; nreq
; nreq
--, mx
= CDR (mx
))
256 new_env
= scm_cons (eval (CAR (mx
), env
), new_env
);
259 for (; scm_is_pair (mx
); mx
= CDR (mx
))
260 rest
= scm_cons (eval (CAR (mx
), env
), rest
);
261 new_env
= scm_cons (scm_reverse (rest
),
267 for (; scm_is_pair (mx
); mx
= CDR (mx
), nreq
--)
268 new_env
= scm_cons (eval (CAR (mx
), env
), new_env
);
269 if (SCM_UNLIKELY (nreq
!= 0))
270 scm_wrong_num_args (proc
);
272 x
= SCM_CLOSURE_BODY (proc
);
279 for (; scm_is_pair (mx
); mx
= CDR (mx
))
280 rest
= scm_cons (eval (CAR (mx
), env
), rest
);
281 return apply (proc
, scm_reverse (rest
));
287 SCM val
= scm_make_continuation (&first
);
293 proc
= eval (mx
, env
);
294 args
= scm_list_1 (val
);
299 case SCM_M_CALL_WITH_VALUES
:
304 producer
= eval (CAR (mx
), env
);
305 proc
= eval (CDR (mx
), env
); /* proc is the consumer. */
306 v
= apply (producer
, SCM_EOL
);
308 args
= scm_struct_ref (v
, SCM_INUM0
);
310 args
= scm_list_1 (v
);
314 case SCM_M_LEXICAL_REF
:
318 for (n
= SCM_I_INUM (mx
); n
; n
--)
321 if (SCM_UNLIKELY (SCM_UNBNDP (ret
)))
322 /* we don't know what variable, though, because we don't have its
324 error_used_before_defined ();
328 case SCM_M_LEXICAL_SET
:
331 SCM val
= eval (CDR (mx
), env
);
332 for (n
= SCM_I_INUM (CAR (mx
)); n
; n
--)
334 SCM_SETCAR (env
, val
);
335 return SCM_UNSPECIFIED
;
338 case SCM_M_TOPLEVEL_REF
:
339 if (SCM_VARIABLEP (mx
))
340 return SCM_VARIABLE_REF (mx
);
343 while (scm_is_pair (env
))
345 return SCM_VARIABLE_REF
346 (scm_memoize_variable_access_x (x
, CAPTURE_ENV (env
)));
349 case SCM_M_TOPLEVEL_SET
:
352 SCM val
= eval (CDR (mx
), env
);
353 if (SCM_VARIABLEP (var
))
355 SCM_VARIABLE_SET (var
, val
);
356 return SCM_UNSPECIFIED
;
360 while (scm_is_pair (env
))
363 (scm_memoize_variable_access_x (x
, CAPTURE_ENV (env
)),
365 return SCM_UNSPECIFIED
;
369 case SCM_M_MODULE_REF
:
370 if (SCM_VARIABLEP (mx
))
371 return SCM_VARIABLE_REF (mx
);
373 return SCM_VARIABLE_REF
374 (scm_memoize_variable_access_x (x
, SCM_BOOL_F
));
376 case SCM_M_MODULE_SET
:
377 if (SCM_VARIABLEP (CDR (mx
)))
379 SCM_VARIABLE_SET (CDR (mx
), eval (CAR (mx
), env
));
380 return SCM_UNSPECIFIED
;
385 (scm_memoize_variable_access_x (x
, SCM_BOOL_F
),
386 eval (CAR (mx
), env
));
387 return SCM_UNSPECIFIED
;
396 apply (SCM proc
, SCM args
)
398 SCM arg1
, arg2
, arg3
, rest
;
401 SCM_ASRTGO (SCM_NIMP (proc
), badproc
);
403 /* Args contains a list of all args. */
405 int ilen
= scm_ilength (args
);
407 scm_wrong_num_args (proc
);
415 arg1
= SCM_UNDEFINED
; arg2
= SCM_UNDEFINED
;
416 arg3
= SCM_UNDEFINED
; rest
= SCM_EOL
;
419 arg1
= CAR (args
); arg2
= SCM_UNDEFINED
;
420 arg3
= SCM_UNDEFINED
; rest
= SCM_EOL
;
423 arg1
= CAR (args
); arg2
= CADR (args
);
424 arg3
= SCM_UNDEFINED
; rest
= SCM_EOL
;
427 arg1
= CAR (args
); arg2
= CADR (args
);
428 arg3
= CADDR (args
); rest
= CDDDR (args
);
433 switch (SCM_TYP7 (proc
))
435 case scm_tcs_closures
:
437 int nreq
= SCM_CLOSURE_NUM_REQUIRED_ARGS (proc
);
438 SCM env
= SCM_ENV (proc
);
439 if (SCM_CLOSURE_HAS_REST_ARGS (proc
))
441 if (SCM_UNLIKELY (scm_ilength (args
) < nreq
))
442 scm_wrong_num_args (proc
);
443 for (; nreq
; nreq
--, args
= CDR (args
))
444 env
= scm_cons (CAR (args
), env
);
445 env
= scm_cons (args
, env
);
449 for (; scm_is_pair (args
); args
= CDR (args
), nreq
--)
450 env
= scm_cons (CAR (args
), env
);
451 if (SCM_UNLIKELY (nreq
!= 0))
452 scm_wrong_num_args (proc
);
454 return eval (SCM_CLOSURE_BODY (proc
), env
);
456 case scm_tc7_subr_2o
:
457 if (nargs
> 2 || nargs
< 1) scm_wrong_num_args (proc
);
458 return SCM_SUBRF (proc
) (arg1
, arg2
);
460 if (nargs
!= 2) scm_wrong_num_args (proc
);
461 return SCM_SUBRF (proc
) (arg1
, arg2
);
463 if (nargs
!= 0) scm_wrong_num_args (proc
);
464 return SCM_SUBRF (proc
) ();
466 if (nargs
!= 1) scm_wrong_num_args (proc
);
467 return SCM_SUBRF (proc
) (arg1
);
468 case scm_tc7_subr_1o
:
469 if (nargs
> 1) scm_wrong_num_args (proc
);
470 return SCM_SUBRF (proc
) (arg1
);
472 if (nargs
!= 1) scm_wrong_num_args (proc
);
473 if (SCM_I_INUMP (arg1
))
474 return scm_from_double (SCM_DSUBRF (proc
) ((double) SCM_I_INUM (arg1
)));
475 else if (SCM_REALP (arg1
))
476 return scm_from_double (SCM_DSUBRF (proc
) (SCM_REAL_VALUE (arg1
)));
477 else if (SCM_BIGP (arg1
))
478 return scm_from_double (SCM_DSUBRF (proc
) (scm_i_big2dbl (arg1
)));
479 else if (SCM_FRACTIONP (arg1
))
480 return scm_from_double (SCM_DSUBRF (proc
) (scm_i_fraction2double (arg1
)));
481 SCM_WTA_DISPATCH_1 (*SCM_SUBR_GENERIC (proc
), arg1
,
482 SCM_ARG1
, scm_i_symbol_chars (SCM_SUBR_NAME (proc
)));
484 if (nargs
!= 1) scm_wrong_num_args (proc
);
485 return scm_i_chase_pairs (arg1
, (scm_t_bits
) SCM_SUBRF (proc
));
487 if (nargs
!= 3) scm_wrong_num_args (proc
);
488 return SCM_SUBRF (proc
) (arg1
, arg2
, arg3
);
490 return SCM_SUBRF (proc
) (args
);
491 case scm_tc7_lsubr_2
:
492 if (nargs
< 2) scm_wrong_num_args (proc
);
493 return SCM_SUBRF (proc
) (arg1
, arg2
, scm_cddr (args
));
496 return SCM_SUBRF (proc
) (arg1
, SCM_UNDEFINED
);
497 for (args
= CDR (args
); nargs
> 1; args
= CDR (args
), nargs
--)
498 arg1
= SCM_SUBRF (proc
) (arg1
, CAR (args
));
500 case scm_tc7_program
:
501 return scm_vm_apply (scm_the_vm (), proc
, args
);
505 for (args
= CDR (args
); nargs
> 1;
506 arg1
= CAR (args
), args
= CDR (args
), nargs
--)
507 if (scm_is_false (SCM_SUBRF (proc
) (arg1
, CAR (args
))))
511 if (!SCM_SMOB_APPLICABLE_P (proc
))
516 return SCM_SMOB_APPLY_0 (proc
);
518 return SCM_SMOB_APPLY_1 (proc
, arg1
);
520 return SCM_SMOB_APPLY_2 (proc
, arg1
, arg2
);
522 return SCM_SMOB_APPLY_3 (proc
, arg1
, arg2
, scm_cddr (args
));
525 return scm_i_gsubr_apply_list (proc
, args
);
527 return apply (SCM_PROCEDURE (proc
), args
);
529 if (SCM_STRUCT_APPLICABLE_P (proc
))
531 proc
= SCM_STRUCT_PROCEDURE (proc
);
538 scm_wrong_type_arg ("apply", SCM_ARG1
, proc
);
543 scm_closure_apply (SCM proc
, SCM args
)
549 /* Args contains a list of all args. */
551 int ilen
= scm_ilength (args
);
553 scm_wrong_num_args (proc
);
557 nreq
= SCM_CLOSURE_NUM_REQUIRED_ARGS (proc
);
558 env
= SCM_ENV (proc
);
559 if (SCM_CLOSURE_HAS_REST_ARGS (proc
))
561 if (SCM_UNLIKELY (scm_ilength (args
) < nreq
))
562 scm_wrong_num_args (proc
);
563 for (; nreq
; nreq
--, args
= CDR (args
))
564 env
= scm_cons (CAR (args
), env
);
565 env
= scm_cons (args
, env
);
569 for (; scm_is_pair (args
); args
= CDR (args
), nreq
--)
570 env
= scm_cons (CAR (args
), env
);
571 if (SCM_UNLIKELY (nreq
!= 0))
572 scm_wrong_num_args (proc
);
574 return eval (SCM_CLOSURE_BODY (proc
), env
);
578 scm_t_option scm_eval_opts
[] = {
579 { SCM_OPTION_INTEGER
, "stack", 22000, "Size of thread stacks (in machine words)." },
583 scm_t_option scm_debug_opts
[] = {
584 { SCM_OPTION_BOOLEAN
, "cheap", 1,
585 "*This option is now obsolete. Setting it has no effect." },
586 { SCM_OPTION_BOOLEAN
, "breakpoints", 0, "*Check for breakpoints." },
587 { SCM_OPTION_BOOLEAN
, "trace", 0, "*Trace mode." },
588 { SCM_OPTION_BOOLEAN
, "procnames", 1,
589 "Record procedure names at definition." },
590 { SCM_OPTION_BOOLEAN
, "backwards", 0,
591 "Display backtrace in anti-chronological order." },
592 { SCM_OPTION_INTEGER
, "width", 79, "Maximal width of backtrace." },
593 { SCM_OPTION_INTEGER
, "indent", 10, "Maximal indentation in backtrace." },
594 { SCM_OPTION_INTEGER
, "frames", 3,
595 "Maximum number of tail-recursive frames in backtrace." },
596 { SCM_OPTION_INTEGER
, "maxdepth", 1000,
597 "Maximal number of stored backtrace frames." },
598 { SCM_OPTION_INTEGER
, "depth", 20, "Maximal length of printed backtrace." },
599 { SCM_OPTION_BOOLEAN
, "backtrace", 0, "Show backtrace on error." },
600 { SCM_OPTION_BOOLEAN
, "debug", 0, "Use the debugging evaluator." },
601 /* This default stack limit will be overridden by debug.c:init_stack_limit(),
602 if we have getrlimit() and the stack limit is not INFINITY. But it is still
603 important, as some systems have both the soft and the hard limits set to
604 INFINITY; in that case we fall back to this value.
606 The situation is aggravated by certain compilers, which can consume
607 "beaucoup de stack", as they say in France.
609 See http://thread.gmane.org/gmane.lisp.guile.devel/8599/focus=8662 for
610 more discussion. This setting is 640 KB on 32-bit arches (should be enough
611 for anyone!) or a whoppin' 1280 KB on 64-bit arches.
613 { SCM_OPTION_INTEGER
, "stack", 160000, "Stack size limit (measured in words; 0 = no check)." },
614 { SCM_OPTION_SCM
, "show-file-name", (unsigned long)SCM_BOOL_T
,
615 "Show file names and line numbers "
616 "in backtraces when not `#f'. A value of `base' "
617 "displays only base names, while `#t' displays full names."},
618 { SCM_OPTION_BOOLEAN
, "warn-deprecated", 0,
619 "Warn when deprecated features are used." },
625 * this ordering is awkward and illogical, but we maintain it for
626 * compatibility. --hwn
628 scm_t_option scm_evaluator_trap_table
[] = {
629 { SCM_OPTION_BOOLEAN
, "traps", 0, "Enable evaluator traps." },
630 { SCM_OPTION_BOOLEAN
, "enter-frame", 0, "Trap when eval enters new frame." },
631 { SCM_OPTION_BOOLEAN
, "apply-frame", 0, "Trap when entering apply." },
632 { SCM_OPTION_BOOLEAN
, "exit-frame", 0, "Trap when exiting eval or apply." },
633 { SCM_OPTION_SCM
, "enter-frame-handler", (unsigned long)SCM_BOOL_F
, "Handler for enter-frame traps." },
634 { SCM_OPTION_SCM
, "apply-frame-handler", (unsigned long)SCM_BOOL_F
, "Handler for apply-frame traps." },
635 { SCM_OPTION_SCM
, "exit-frame-handler", (unsigned long)SCM_BOOL_F
, "Handler for exit-frame traps." },
636 { SCM_OPTION_BOOLEAN
, "memoize-symbol", 0, "Trap when memoizing a symbol." },
637 { SCM_OPTION_SCM
, "memoize-symbol-handler", (unsigned long)SCM_BOOL_F
, "The handler for memoization." },
642 SCM_DEFINE (scm_eval_options_interface
, "eval-options-interface", 0, 1, 0,
644 "Option interface for the evaluation options. Instead of using\n"
645 "this procedure directly, use the procedures @code{eval-enable},\n"
646 "@code{eval-disable}, @code{eval-set!} and @code{eval-options}.")
647 #define FUNC_NAME s_scm_eval_options_interface
651 scm_dynwind_begin (0);
652 scm_dynwind_critical_section (SCM_BOOL_F
);
653 ans
= scm_options (setting
,
663 SCM_DEFINE (scm_evaluator_traps
, "evaluator-traps-interface", 0, 1, 0,
665 "Option interface for the evaluator trap options.")
666 #define FUNC_NAME s_scm_evaluator_traps
671 scm_options_try (setting
,
672 scm_evaluator_trap_table
,
674 SCM_CRITICAL_SECTION_START
;
675 ans
= scm_options (setting
,
676 scm_evaluator_trap_table
,
679 /* njrev: same again. */
680 SCM_CRITICAL_SECTION_END
;
689 /* Simple procedure calls
693 scm_call_0 (SCM proc
)
695 if (SCM_PROGRAM_P (proc
))
696 return scm_c_vm_run (scm_the_vm (), proc
, NULL
, 0);
698 return scm_apply (proc
, SCM_EOL
, SCM_EOL
);
702 scm_call_1 (SCM proc
, SCM arg1
)
704 if (SCM_PROGRAM_P (proc
))
705 return scm_c_vm_run (scm_the_vm (), proc
, &arg1
, 1);
707 return scm_apply (proc
, arg1
, scm_listofnull
);
711 scm_call_2 (SCM proc
, SCM arg1
, SCM arg2
)
713 if (SCM_PROGRAM_P (proc
))
715 SCM args
[] = { arg1
, arg2
};
716 return scm_c_vm_run (scm_the_vm (), proc
, args
, 2);
719 return scm_apply (proc
, arg1
, scm_cons (arg2
, scm_listofnull
));
723 scm_call_3 (SCM proc
, SCM arg1
, SCM arg2
, SCM arg3
)
725 if (SCM_PROGRAM_P (proc
))
727 SCM args
[] = { arg1
, arg2
, arg3
};
728 return scm_c_vm_run (scm_the_vm (), proc
, args
, 3);
731 return scm_apply (proc
, arg1
, scm_cons2 (arg2
, arg3
, scm_listofnull
));
735 scm_call_4 (SCM proc
, SCM arg1
, SCM arg2
, SCM arg3
, SCM arg4
)
737 if (SCM_PROGRAM_P (proc
))
739 SCM args
[] = { arg1
, arg2
, arg3
, arg4
};
740 return scm_c_vm_run (scm_the_vm (), proc
, args
, 4);
743 return scm_apply (proc
, arg1
, scm_cons2 (arg2
, arg3
,
744 scm_cons (arg4
, scm_listofnull
)));
747 /* Simple procedure applies
751 scm_apply_0 (SCM proc
, SCM args
)
753 return scm_apply (proc
, args
, SCM_EOL
);
757 scm_apply_1 (SCM proc
, SCM arg1
, SCM args
)
759 return scm_apply (proc
, scm_cons (arg1
, args
), SCM_EOL
);
763 scm_apply_2 (SCM proc
, SCM arg1
, SCM arg2
, SCM args
)
765 return scm_apply (proc
, scm_cons2 (arg1
, arg2
, args
), SCM_EOL
);
769 scm_apply_3 (SCM proc
, SCM arg1
, SCM arg2
, SCM arg3
, SCM args
)
771 return scm_apply (proc
, scm_cons (arg1
, scm_cons2 (arg2
, arg3
, args
)),
775 /* This code processes the arguments to apply:
777 (apply PROC ARG1 ... ARGS)
779 Given a list (ARG1 ... ARGS), this function conses the ARG1
780 ... arguments onto the front of ARGS, and returns the resulting
781 list. Note that ARGS is a list; thus, the argument to this
782 function is a list whose last element is a list.
784 Apply calls this function, and applies PROC to the elements of the
785 result. apply:nconc2last takes care of building the list of
786 arguments, given (ARG1 ... ARGS).
788 Rather than do new consing, apply:nconc2last destroys its argument.
789 On that topic, this code came into my care with the following
790 beautifully cryptic comment on that topic: "This will only screw
791 you if you do (scm_apply scm_apply '( ... ))" If you know what
792 they're referring to, send me a patch to this comment. */
794 SCM_DEFINE (scm_nconc2last
, "apply:nconc2last", 1, 0, 0,
796 "Given a list (@var{arg1} @dots{} @var{args}), this function\n"
797 "conses the @var{arg1} @dots{} arguments onto the front of\n"
798 "@var{args}, and returns the resulting list. Note that\n"
799 "@var{args} is a list; thus, the argument to this function is\n"
800 "a list whose last element is a list.\n"
801 "Note: Rather than do new consing, @code{apply:nconc2last}\n"
802 "destroys its argument, so use with care.")
803 #define FUNC_NAME s_scm_nconc2last
806 SCM_VALIDATE_NONEMPTYLIST (1, lst
);
808 while (!scm_is_null (SCM_CDR (*lloc
))) /* Perhaps should be
809 SCM_NULL_OR_NIL_P, but not
810 needed in 99.99% of cases,
811 and it could seriously hurt
812 performance. - Neil */
813 lloc
= SCM_CDRLOC (*lloc
);
814 SCM_ASSERT (scm_ilength (SCM_CAR (*lloc
)) >= 0, lst
, SCM_ARG1
, FUNC_NAME
);
815 *lloc
= SCM_CAR (*lloc
);
822 /* Typechecking for multi-argument MAP and FOR-EACH.
824 Verify that each element of the vector ARGV, except for the first,
825 is a proper list whose length is LEN. Attribute errors to WHO,
826 and claim that the i'th element of ARGV is WHO's i+2'th argument. */
828 check_map_args (SCM argv
,
837 for (i
= SCM_SIMPLE_VECTOR_LENGTH (argv
) - 1; i
>= 1; i
--)
839 SCM elt
= SCM_SIMPLE_VECTOR_REF (argv
, i
);
840 long elt_len
= scm_ilength (elt
);
845 scm_apply_generic (gf
, scm_cons (proc
, args
));
847 scm_wrong_type_arg (who
, i
+ 2, elt
);
851 scm_out_of_range_pos (who
, elt
, scm_from_long (i
+ 2));
856 SCM_GPROC (s_map
, "map", 2, 0, 1, scm_map
, g_map
);
858 /* Note: Currently, scm_map applies PROC to the argument list(s)
859 sequentially, starting with the first element(s). This is used in
860 evalext.c where the Scheme procedure `map-in-order', which guarantees
861 sequential behaviour, is implemented using scm_map. If the
862 behaviour changes, we need to update `map-in-order'.
866 scm_map (SCM proc
, SCM arg1
, SCM args
)
867 #define FUNC_NAME s_map
873 len
= scm_ilength (arg1
);
874 SCM_GASSERTn (len
>= 0,
875 g_map
, scm_cons2 (proc
, arg1
, args
), SCM_ARG2
, s_map
);
876 SCM_VALIDATE_REST_ARGUMENT (args
);
877 if (scm_is_null (args
))
879 SCM_GASSERT2 (scm_is_true (scm_procedure_p (proc
)), g_map
, proc
, arg1
, SCM_ARG1
, s_map
);
880 while (SCM_NIMP (arg1
))
882 *pres
= scm_list_1 (scm_call_1 (proc
, SCM_CAR (arg1
)));
883 pres
= SCM_CDRLOC (*pres
);
884 arg1
= SCM_CDR (arg1
);
888 if (scm_is_null (SCM_CDR (args
)))
890 SCM arg2
= SCM_CAR (args
);
891 int len2
= scm_ilength (arg2
);
892 SCM_GASSERTn (scm_is_true (scm_procedure_p (proc
)), g_map
,
893 scm_cons2 (proc
, arg1
, args
), SCM_ARG1
, s_map
);
894 SCM_GASSERTn (len2
>= 0,
895 g_map
, scm_cons2 (proc
, arg1
, args
), SCM_ARG3
, s_map
);
897 SCM_OUT_OF_RANGE (3, arg2
);
898 while (SCM_NIMP (arg1
))
900 *pres
= scm_list_1 (scm_call_2 (proc
, SCM_CAR (arg1
), SCM_CAR (arg2
)));
901 pres
= SCM_CDRLOC (*pres
);
902 arg1
= SCM_CDR (arg1
);
903 arg2
= SCM_CDR (arg2
);
907 arg1
= scm_cons (arg1
, args
);
908 args
= scm_vector (arg1
);
909 check_map_args (args
, len
, g_map
, proc
, arg1
, s_map
);
913 for (i
= SCM_SIMPLE_VECTOR_LENGTH (args
) - 1; i
>= 0; i
--)
915 SCM elt
= SCM_SIMPLE_VECTOR_REF (args
, i
);
918 arg1
= scm_cons (SCM_CAR (elt
), arg1
);
919 SCM_SIMPLE_VECTOR_SET (args
, i
, SCM_CDR (elt
));
921 *pres
= scm_list_1 (scm_apply (proc
, arg1
, SCM_EOL
));
922 pres
= SCM_CDRLOC (*pres
);
928 SCM_GPROC (s_for_each
, "for-each", 2, 0, 1, scm_for_each
, g_for_each
);
931 scm_for_each (SCM proc
, SCM arg1
, SCM args
)
932 #define FUNC_NAME s_for_each
935 len
= scm_ilength (arg1
);
936 SCM_GASSERTn (len
>= 0, g_for_each
, scm_cons2 (proc
, arg1
, args
),
937 SCM_ARG2
, s_for_each
);
938 SCM_VALIDATE_REST_ARGUMENT (args
);
939 if (scm_is_null (args
))
941 SCM_GASSERT2 (scm_is_true (scm_procedure_p (proc
)), g_for_each
,
942 proc
, arg1
, SCM_ARG1
, s_for_each
);
943 while (SCM_NIMP (arg1
))
945 scm_call_1 (proc
, SCM_CAR (arg1
));
946 arg1
= SCM_CDR (arg1
);
948 return SCM_UNSPECIFIED
;
950 if (scm_is_null (SCM_CDR (args
)))
952 SCM arg2
= SCM_CAR (args
);
953 int len2
= scm_ilength (arg2
);
954 SCM_GASSERTn (scm_is_true (scm_procedure_p (proc
)), g_for_each
,
955 scm_cons2 (proc
, arg1
, args
), SCM_ARG1
, s_for_each
);
956 SCM_GASSERTn (len2
>= 0, g_for_each
,
957 scm_cons2 (proc
, arg1
, args
), SCM_ARG3
, s_for_each
);
959 SCM_OUT_OF_RANGE (3, arg2
);
960 while (SCM_NIMP (arg1
))
962 scm_call_2 (proc
, SCM_CAR (arg1
), SCM_CAR (arg2
));
963 arg1
= SCM_CDR (arg1
);
964 arg2
= SCM_CDR (arg2
);
966 return SCM_UNSPECIFIED
;
968 arg1
= scm_cons (arg1
, args
);
969 args
= scm_vector (arg1
);
970 check_map_args (args
, len
, g_for_each
, proc
, arg1
, s_for_each
);
974 for (i
= SCM_SIMPLE_VECTOR_LENGTH (args
) - 1; i
>= 0; i
--)
976 SCM elt
= SCM_SIMPLE_VECTOR_REF (args
, i
);
978 return SCM_UNSPECIFIED
;
979 arg1
= scm_cons (SCM_CAR (elt
), arg1
);
980 SCM_SIMPLE_VECTOR_SET (args
, i
, SCM_CDR (elt
));
982 scm_apply (proc
, arg1
, SCM_EOL
);
989 scm_closure (SCM code
, SCM env
)
992 SCM closcar
= scm_cons (code
, SCM_EOL
);
993 z
= scm_immutable_cell (SCM_UNPACK (closcar
) + scm_tc3_closure
,
995 scm_remember_upto_here (closcar
);
1000 SCM_DEFINE (scm_primitive_eval
, "primitive-eval", 1, 0, 0,
1002 "Evaluate @var{exp} in the top-level environment specified by\n"
1003 "the current module.")
1004 #define FUNC_NAME s_scm_primitive_eval
1006 SCM transformer
= scm_current_module_transformer ();
1007 if (scm_is_true (transformer
))
1008 exp
= scm_call_1 (transformer
, exp
);
1009 exp
= scm_memoize_expression (exp
);
1010 return eval (exp
, SCM_EOL
);
1015 /* Eval does not take the second arg optionally. This is intentional
1016 * in order to be R5RS compatible, and to prepare for the new module
1017 * system, where we would like to make the choice of evaluation
1018 * environment explicit. */
1020 SCM_DEFINE (scm_eval
, "eval", 2, 0, 0,
1021 (SCM exp
, SCM module_or_state
),
1022 "Evaluate @var{exp}, a list representing a Scheme expression,\n"
1023 "in the top-level environment specified by\n"
1024 "@var{module_or_state}.\n"
1025 "While @var{exp} is evaluated (using @code{primitive-eval}),\n"
1026 "@var{module_or_state} is made the current module when\n"
1027 "it is a module, or the current dynamic state when it is\n"
1029 "Example: (eval '(+ 1 2) (interaction-environment))")
1030 #define FUNC_NAME s_scm_eval
1034 scm_dynwind_begin (SCM_F_DYNWIND_REWINDABLE
);
1035 if (scm_is_dynamic_state (module_or_state
))
1036 scm_dynwind_current_dynamic_state (module_or_state
);
1037 else if (scm_module_system_booted_p
)
1039 SCM_VALIDATE_MODULE (2, module_or_state
);
1040 scm_dynwind_current_module (module_or_state
);
1042 /* otherwise if the module system isn't booted, ignore the module arg */
1044 res
= scm_primitive_eval (exp
);
1054 /* Apply a function to a list of arguments.
1056 This function is exported to the Scheme level as taking two
1057 required arguments and a tail argument, as if it were:
1058 (lambda (proc arg1 . args) ...)
1059 Thus, if you just have a list of arguments to pass to a procedure,
1060 pass the list as ARG1, and '() for ARGS. If you have some fixed
1061 args, pass the first as ARG1, then cons any remaining fixed args
1062 onto the front of your argument list, and pass that as ARGS. */
1065 scm_apply (SCM proc
, SCM arg1
, SCM args
)
1067 /* Fix things up so that args contains all args. */
1068 if (scm_is_null (args
))
1071 args
= scm_cons_star (arg1
, args
);
1073 return apply (proc
, args
);
1080 scm_init_opts (scm_evaluator_traps
,
1081 scm_evaluator_trap_table
);
1082 scm_init_opts (scm_eval_options_interface
,
1085 scm_listofnull
= scm_list_1 (SCM_EOL
);
1087 f_apply
= scm_c_define_subr ("apply", scm_tc7_lsubr_2
, scm_apply
);
1088 scm_permanent_object (f_apply
);
1090 #include "libguile/eval.x"