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_unbound_variable (SCM symbol
) SCM_NORETURN
;
124 static void error_unbound_variable (SCM symbol
)
126 scm_error (scm_unbound_variable_key
, NULL
, "Unbound variable: ~S",
127 scm_list_1 (symbol
), SCM_BOOL_F
);
130 static void error_used_before_defined (void)
132 scm_error (scm_unbound_variable_key
, NULL
,
133 "Variable used before given a value", SCM_EOL
, SCM_BOOL_F
);
137 scm_badargsp (SCM formals
, SCM args
)
139 while (!scm_is_null (formals
))
141 if (!scm_is_pair (formals
))
143 if (scm_is_null (args
))
145 formals
= CDR (formals
);
148 return !scm_is_null (args
) ? 1 : 0;
151 static SCM
apply (SCM proc
, SCM args
);
154 ((SYM . VAL) (SYM . VAL) ... . MOD)
155 If MOD is #f, it means the environment was captured before modules were
157 If MOD is the literal value '(), we are evaluating at the top level, and so
158 should track changes to the current module. You have to be careful in this
159 case, because further lexical contours should capture the current module.
161 #define CAPTURE_ENV(env) \
162 ((env == SCM_EOL) ? scm_current_module () : \
163 ((env == SCM_BOOL_F) ? scm_the_root_module () : env))
166 eval (SCM x
, SCM env
)
169 SCM proc
= SCM_UNDEFINED
, args
= SCM_EOL
;
173 if (!SCM_MEMOIZED_P (x
))
176 mx
= SCM_MEMOIZED_ARGS (x
);
177 switch (SCM_MEMOIZED_TAG (x
))
180 for (; !scm_is_null (CDR (mx
)); mx
= CDR (mx
))
181 eval (CAR (mx
), env
);
186 if (scm_is_true (eval (CAR (mx
), env
)))
194 SCM inits
= CAR (mx
);
195 SCM new_env
= CAPTURE_ENV (env
);
196 for (; scm_is_pair (inits
); inits
= CDR (inits
))
197 new_env
= scm_cons (eval (CAR (inits
), env
), new_env
);
204 return scm_closure (mx
, CAPTURE_ENV (env
));
210 scm_define (CAR (mx
), eval (CDR (mx
), env
));
211 return SCM_UNSPECIFIED
;
214 /* Evaluate the procedure to be applied. */
215 proc
= eval (CAR (mx
), env
);
216 /* Evaluate the argument holding the list of arguments */
217 args
= eval (CADR (mx
), env
);
220 /* Go here to tail-apply a procedure. PROC is the procedure and
221 * ARGS is the list of arguments. */
222 if (SCM_CLOSUREP (proc
))
224 int nreq
= SCM_CLOSURE_NUM_REQUIRED_ARGS (proc
);
225 SCM new_env
= SCM_ENV (proc
);
226 if (SCM_CLOSURE_HAS_REST_ARGS (proc
))
228 if (SCM_UNLIKELY (scm_ilength (args
) < nreq
))
229 scm_wrong_num_args (proc
);
230 for (; nreq
; nreq
--, args
= CDR (args
))
231 new_env
= scm_cons (CAR (args
), new_env
);
232 new_env
= scm_cons (args
, new_env
);
236 if (SCM_UNLIKELY (scm_ilength (args
) != nreq
))
237 scm_wrong_num_args (proc
);
238 for (; scm_is_pair (args
); args
= CDR (args
))
239 new_env
= scm_cons (CAR (args
), new_env
);
241 x
= SCM_CLOSURE_BODY (proc
);
246 return apply (proc
, args
);
249 /* Evaluate the procedure to be applied. */
250 proc
= eval (CAR (mx
), env
);
254 if (SCM_CLOSUREP (proc
))
256 int nreq
= SCM_CLOSURE_NUM_REQUIRED_ARGS (proc
);
257 SCM new_env
= SCM_ENV (proc
);
258 if (SCM_CLOSURE_HAS_REST_ARGS (proc
))
260 if (SCM_UNLIKELY (scm_ilength (mx
) < nreq
))
261 scm_wrong_num_args (proc
);
262 for (; nreq
; nreq
--, mx
= CDR (mx
))
263 new_env
= scm_cons (eval (CAR (mx
), env
), new_env
);
266 for (; scm_is_pair (mx
); mx
= CDR (mx
))
267 rest
= scm_cons (eval (CAR (mx
), env
), rest
);
268 new_env
= scm_cons (scm_reverse (rest
),
274 for (; scm_is_pair (mx
); mx
= CDR (mx
), nreq
--)
275 new_env
= scm_cons (eval (CAR (mx
), env
), new_env
);
276 if (SCM_UNLIKELY (nreq
!= 0))
277 scm_wrong_num_args (proc
);
279 x
= SCM_CLOSURE_BODY (proc
);
286 for (; scm_is_pair (mx
); mx
= CDR (mx
))
287 rest
= scm_cons (eval (CAR (mx
), env
), rest
);
288 return apply (proc
, scm_reverse (rest
));
294 SCM val
= scm_make_continuation (&first
);
300 proc
= eval (mx
, env
);
301 args
= scm_list_1 (val
);
306 case SCM_M_CALL_WITH_VALUES
:
311 producer
= eval (CAR (mx
), env
);
312 proc
= eval (CDR (mx
), env
); /* proc is the consumer. */
313 v
= apply (producer
, SCM_EOL
);
315 args
= scm_struct_ref (v
, SCM_INUM0
);
317 args
= scm_list_1 (v
);
321 case SCM_M_LEXICAL_REF
:
325 for (n
= SCM_I_INUM (mx
); n
; n
--)
328 if (SCM_UNLIKELY (SCM_UNBNDP (ret
)))
329 /* we don't know what variable, though, because we don't have its
331 error_used_before_defined ();
335 case SCM_M_LEXICAL_SET
:
338 SCM val
= eval (CDR (mx
), env
);
339 for (n
= SCM_I_INUM (CAR (mx
)); n
; n
--)
341 SCM_SETCAR (env
, val
);
342 return SCM_UNSPECIFIED
;
345 case SCM_M_TOPLEVEL_REF
:
346 if (SCM_VARIABLEP (mx
))
347 return SCM_VARIABLE_REF (mx
);
351 while (scm_is_pair (env
))
353 var
= scm_module_variable (CAPTURE_ENV (env
), mx
);
354 if (scm_is_false (var
) || scm_is_false (scm_variable_bound_p (var
)))
355 error_unbound_variable (mx
);
356 SCM_SET_SMOB_OBJECT (x
, var
);
357 return SCM_VARIABLE_REF (var
);
360 case SCM_M_TOPLEVEL_SET
:
363 SCM val
= eval (CDR (mx
), env
);
364 if (SCM_VARIABLEP (var
))
366 SCM_VARIABLE_SET (var
, val
);
367 return SCM_UNSPECIFIED
;
371 while (scm_is_pair (env
))
373 var
= scm_module_variable (CAPTURE_ENV (env
), var
);
374 if (scm_is_false (var
) || scm_is_false (scm_variable_bound_p (var
)))
375 error_unbound_variable (CAR (mx
));
376 SCM_SETCAR (mx
, var
);
377 SCM_VARIABLE_SET (var
, val
);
378 return SCM_UNSPECIFIED
;
382 case SCM_M_MODULE_REF
:
383 if (SCM_VARIABLEP (mx
))
384 return SCM_VARIABLE_REF (mx
);
388 mod
= scm_resolve_module (CAR (mx
));
389 if (scm_is_true (CDDR (mx
)))
390 mod
= scm_module_public_interface (mod
);
391 var
= scm_module_lookup (mod
, CADR (mx
));
392 if (scm_is_true (scm_variable_bound_p (var
)))
393 SCM_SET_SMOB_OBJECT (x
, var
);
394 return scm_variable_ref (var
);
397 case SCM_M_MODULE_SET
:
398 if (SCM_VARIABLEP (CDR (mx
)))
400 SCM_VARIABLE_SET (CDR (mx
), eval (CAR (mx
), env
));
401 return SCM_UNSPECIFIED
;
406 mod
= scm_resolve_module (CADR (mx
));
407 if (scm_is_true (CDDDR (mx
)))
408 mod
= scm_module_public_interface (mod
);
409 var
= scm_module_lookup (mod
, CADDR (mx
));
410 SCM_SET_SMOB_OBJECT (x
, var
);
411 SCM_VARIABLE_SET (var
, eval (CAR (mx
), env
));
412 return SCM_UNSPECIFIED
;
421 apply (SCM proc
, SCM args
)
423 SCM arg1
, arg2
, arg3
, rest
;
426 SCM_ASRTGO (SCM_NIMP (proc
), badproc
);
428 /* Args contains a list of all args. */
430 int ilen
= scm_ilength (args
);
432 scm_wrong_num_args (proc
);
440 arg1
= SCM_UNDEFINED
; arg2
= SCM_UNDEFINED
;
441 arg3
= SCM_UNDEFINED
; rest
= SCM_EOL
;
444 arg1
= CAR (args
); arg2
= SCM_UNDEFINED
;
445 arg3
= SCM_UNDEFINED
; rest
= SCM_EOL
;
448 arg1
= CAR (args
); arg2
= CADR (args
);
449 arg3
= SCM_UNDEFINED
; rest
= SCM_EOL
;
452 arg1
= CAR (args
); arg2
= CADR (args
);
453 arg3
= CADDR (args
); rest
= CDDDR (args
);
458 switch (SCM_TYP7 (proc
))
460 case scm_tcs_closures
:
462 int nreq
= SCM_CLOSURE_NUM_REQUIRED_ARGS (proc
);
463 SCM env
= SCM_ENV (proc
);
464 if (SCM_CLOSURE_HAS_REST_ARGS (proc
))
466 if (SCM_UNLIKELY (scm_ilength (args
) < nreq
))
467 scm_wrong_num_args (proc
);
468 for (; nreq
; nreq
--, args
= CDR (args
))
469 env
= scm_cons (CAR (args
), env
);
470 env
= scm_cons (args
, env
);
474 for (; scm_is_pair (args
); args
= CDR (args
), nreq
--)
475 env
= scm_cons (CAR (args
), env
);
476 if (SCM_UNLIKELY (nreq
!= 0))
477 scm_wrong_num_args (proc
);
479 return eval (SCM_CLOSURE_BODY (proc
), env
);
481 case scm_tc7_subr_2o
:
482 if (nargs
> 2 || nargs
< 1) scm_wrong_num_args (proc
);
483 return SCM_SUBRF (proc
) (arg1
, arg2
);
485 if (nargs
!= 2) scm_wrong_num_args (proc
);
486 return SCM_SUBRF (proc
) (arg1
, arg2
);
488 if (nargs
!= 0) scm_wrong_num_args (proc
);
489 return SCM_SUBRF (proc
) ();
491 if (nargs
!= 1) scm_wrong_num_args (proc
);
492 return SCM_SUBRF (proc
) (arg1
);
493 case scm_tc7_subr_1o
:
494 if (nargs
> 1) scm_wrong_num_args (proc
);
495 return SCM_SUBRF (proc
) (arg1
);
497 if (nargs
!= 1) scm_wrong_num_args (proc
);
498 if (SCM_I_INUMP (arg1
))
499 return scm_from_double (SCM_DSUBRF (proc
) ((double) SCM_I_INUM (arg1
)));
500 else if (SCM_REALP (arg1
))
501 return scm_from_double (SCM_DSUBRF (proc
) (SCM_REAL_VALUE (arg1
)));
502 else if (SCM_BIGP (arg1
))
503 return scm_from_double (SCM_DSUBRF (proc
) (scm_i_big2dbl (arg1
)));
504 else if (SCM_FRACTIONP (arg1
))
505 return scm_from_double (SCM_DSUBRF (proc
) (scm_i_fraction2double (arg1
)));
506 SCM_WTA_DISPATCH_1 (*SCM_SUBR_GENERIC (proc
), arg1
,
507 SCM_ARG1
, scm_i_symbol_chars (SCM_SUBR_NAME (proc
)));
509 if (nargs
!= 1) scm_wrong_num_args (proc
);
510 return scm_i_chase_pairs (arg1
, (scm_t_bits
) SCM_SUBRF (proc
));
512 if (nargs
!= 3) scm_wrong_num_args (proc
);
513 return SCM_SUBRF (proc
) (arg1
, arg2
, arg3
);
515 return SCM_SUBRF (proc
) (args
);
516 case scm_tc7_lsubr_2
:
517 if (nargs
< 2) scm_wrong_num_args (proc
);
518 return SCM_SUBRF (proc
) (arg1
, arg2
, scm_cddr (args
));
521 return SCM_SUBRF (proc
) (arg1
, SCM_UNDEFINED
);
522 for (args
= CDR (args
); nargs
> 1; args
= CDR (args
), nargs
--)
523 arg1
= SCM_SUBRF (proc
) (arg1
, CAR (args
));
525 case scm_tc7_program
:
526 return scm_vm_apply (scm_the_vm (), proc
, args
);
530 for (args
= CDR (args
); nargs
> 1;
531 arg1
= CAR (args
), args
= CDR (args
), nargs
--)
532 if (scm_is_false (SCM_SUBRF (proc
) (arg1
, CAR (args
))))
536 if (!SCM_SMOB_APPLICABLE_P (proc
))
541 return SCM_SMOB_APPLY_0 (proc
);
543 return SCM_SMOB_APPLY_1 (proc
, arg1
);
545 return SCM_SMOB_APPLY_2 (proc
, arg1
, arg2
);
547 return SCM_SMOB_APPLY_3 (proc
, arg1
, arg2
, scm_cddr (args
));
550 return scm_i_gsubr_apply_list (proc
, args
);
552 return apply (SCM_PROCEDURE (proc
), args
);
554 if (SCM_STRUCT_APPLICABLE_P (proc
))
556 proc
= SCM_STRUCT_PROCEDURE (proc
);
563 scm_wrong_type_arg ("apply", SCM_ARG1
, proc
);
568 scm_t_option scm_eval_opts
[] = {
569 { SCM_OPTION_INTEGER
, "stack", 22000, "Size of thread stacks (in machine words)." },
573 scm_t_option scm_debug_opts
[] = {
574 { SCM_OPTION_BOOLEAN
, "cheap", 1,
575 "*This option is now obsolete. Setting it has no effect." },
576 { SCM_OPTION_BOOLEAN
, "breakpoints", 0, "*Check for breakpoints." },
577 { SCM_OPTION_BOOLEAN
, "trace", 0, "*Trace mode." },
578 { SCM_OPTION_BOOLEAN
, "procnames", 1,
579 "Record procedure names at definition." },
580 { SCM_OPTION_BOOLEAN
, "backwards", 0,
581 "Display backtrace in anti-chronological order." },
582 { SCM_OPTION_INTEGER
, "width", 79, "Maximal width of backtrace." },
583 { SCM_OPTION_INTEGER
, "indent", 10, "Maximal indentation in backtrace." },
584 { SCM_OPTION_INTEGER
, "frames", 3,
585 "Maximum number of tail-recursive frames in backtrace." },
586 { SCM_OPTION_INTEGER
, "maxdepth", 1000,
587 "Maximal number of stored backtrace frames." },
588 { SCM_OPTION_INTEGER
, "depth", 20, "Maximal length of printed backtrace." },
589 { SCM_OPTION_BOOLEAN
, "backtrace", 0, "Show backtrace on error." },
590 { SCM_OPTION_BOOLEAN
, "debug", 0, "Use the debugging evaluator." },
591 /* This default stack limit will be overridden by debug.c:init_stack_limit(),
592 if we have getrlimit() and the stack limit is not INFINITY. But it is still
593 important, as some systems have both the soft and the hard limits set to
594 INFINITY; in that case we fall back to this value.
596 The situation is aggravated by certain compilers, which can consume
597 "beaucoup de stack", as they say in France.
599 See http://thread.gmane.org/gmane.lisp.guile.devel/8599/focus=8662 for
600 more discussion. This setting is 640 KB on 32-bit arches (should be enough
601 for anyone!) or a whoppin' 1280 KB on 64-bit arches.
603 { SCM_OPTION_INTEGER
, "stack", 160000, "Stack size limit (measured in words; 0 = no check)." },
604 { SCM_OPTION_SCM
, "show-file-name", (unsigned long)SCM_BOOL_T
,
605 "Show file names and line numbers "
606 "in backtraces when not `#f'. A value of `base' "
607 "displays only base names, while `#t' displays full names."},
608 { SCM_OPTION_BOOLEAN
, "warn-deprecated", 0,
609 "Warn when deprecated features are used." },
615 * this ordering is awkward and illogical, but we maintain it for
616 * compatibility. --hwn
618 scm_t_option scm_evaluator_trap_table
[] = {
619 { SCM_OPTION_BOOLEAN
, "traps", 0, "Enable evaluator traps." },
620 { SCM_OPTION_BOOLEAN
, "enter-frame", 0, "Trap when eval enters new frame." },
621 { SCM_OPTION_BOOLEAN
, "apply-frame", 0, "Trap when entering apply." },
622 { SCM_OPTION_BOOLEAN
, "exit-frame", 0, "Trap when exiting eval or apply." },
623 { SCM_OPTION_SCM
, "enter-frame-handler", (unsigned long)SCM_BOOL_F
, "Handler for enter-frame traps." },
624 { SCM_OPTION_SCM
, "apply-frame-handler", (unsigned long)SCM_BOOL_F
, "Handler for apply-frame traps." },
625 { SCM_OPTION_SCM
, "exit-frame-handler", (unsigned long)SCM_BOOL_F
, "Handler for exit-frame traps." },
626 { SCM_OPTION_BOOLEAN
, "memoize-symbol", 0, "Trap when memoizing a symbol." },
627 { SCM_OPTION_SCM
, "memoize-symbol-handler", (unsigned long)SCM_BOOL_F
, "The handler for memoization." },
632 SCM_DEFINE (scm_eval_options_interface
, "eval-options-interface", 0, 1, 0,
634 "Option interface for the evaluation options. Instead of using\n"
635 "this procedure directly, use the procedures @code{eval-enable},\n"
636 "@code{eval-disable}, @code{eval-set!} and @code{eval-options}.")
637 #define FUNC_NAME s_scm_eval_options_interface
641 scm_dynwind_begin (0);
642 scm_dynwind_critical_section (SCM_BOOL_F
);
643 ans
= scm_options (setting
,
653 SCM_DEFINE (scm_evaluator_traps
, "evaluator-traps-interface", 0, 1, 0,
655 "Option interface for the evaluator trap options.")
656 #define FUNC_NAME s_scm_evaluator_traps
661 scm_options_try (setting
,
662 scm_evaluator_trap_table
,
664 SCM_CRITICAL_SECTION_START
;
665 ans
= scm_options (setting
,
666 scm_evaluator_trap_table
,
669 /* njrev: same again. */
670 SCM_CRITICAL_SECTION_END
;
679 /* Simple procedure calls
683 scm_call_0 (SCM proc
)
685 if (SCM_PROGRAM_P (proc
))
686 return scm_c_vm_run (scm_the_vm (), proc
, NULL
, 0);
688 return scm_apply (proc
, SCM_EOL
, SCM_EOL
);
692 scm_call_1 (SCM proc
, SCM arg1
)
694 if (SCM_PROGRAM_P (proc
))
695 return scm_c_vm_run (scm_the_vm (), proc
, &arg1
, 1);
697 return scm_apply (proc
, arg1
, scm_listofnull
);
701 scm_call_2 (SCM proc
, SCM arg1
, SCM arg2
)
703 if (SCM_PROGRAM_P (proc
))
705 SCM args
[] = { arg1
, arg2
};
706 return scm_c_vm_run (scm_the_vm (), proc
, args
, 2);
709 return scm_apply (proc
, arg1
, scm_cons (arg2
, scm_listofnull
));
713 scm_call_3 (SCM proc
, SCM arg1
, SCM arg2
, SCM arg3
)
715 if (SCM_PROGRAM_P (proc
))
717 SCM args
[] = { arg1
, arg2
, arg3
};
718 return scm_c_vm_run (scm_the_vm (), proc
, args
, 3);
721 return scm_apply (proc
, arg1
, scm_cons2 (arg2
, arg3
, scm_listofnull
));
725 scm_call_4 (SCM proc
, SCM arg1
, SCM arg2
, SCM arg3
, SCM arg4
)
727 if (SCM_PROGRAM_P (proc
))
729 SCM args
[] = { arg1
, arg2
, arg3
, arg4
};
730 return scm_c_vm_run (scm_the_vm (), proc
, args
, 4);
733 return scm_apply (proc
, arg1
, scm_cons2 (arg2
, arg3
,
734 scm_cons (arg4
, scm_listofnull
)));
737 /* Simple procedure applies
741 scm_apply_0 (SCM proc
, SCM args
)
743 return scm_apply (proc
, args
, SCM_EOL
);
747 scm_apply_1 (SCM proc
, SCM arg1
, SCM args
)
749 return scm_apply (proc
, scm_cons (arg1
, args
), SCM_EOL
);
753 scm_apply_2 (SCM proc
, SCM arg1
, SCM arg2
, SCM args
)
755 return scm_apply (proc
, scm_cons2 (arg1
, arg2
, args
), SCM_EOL
);
759 scm_apply_3 (SCM proc
, SCM arg1
, SCM arg2
, SCM arg3
, SCM args
)
761 return scm_apply (proc
, scm_cons (arg1
, scm_cons2 (arg2
, arg3
, args
)),
765 /* This code processes the arguments to apply:
767 (apply PROC ARG1 ... ARGS)
769 Given a list (ARG1 ... ARGS), this function conses the ARG1
770 ... arguments onto the front of ARGS, and returns the resulting
771 list. Note that ARGS is a list; thus, the argument to this
772 function is a list whose last element is a list.
774 Apply calls this function, and applies PROC to the elements of the
775 result. apply:nconc2last takes care of building the list of
776 arguments, given (ARG1 ... ARGS).
778 Rather than do new consing, apply:nconc2last destroys its argument.
779 On that topic, this code came into my care with the following
780 beautifully cryptic comment on that topic: "This will only screw
781 you if you do (scm_apply scm_apply '( ... ))" If you know what
782 they're referring to, send me a patch to this comment. */
784 SCM_DEFINE (scm_nconc2last
, "apply:nconc2last", 1, 0, 0,
786 "Given a list (@var{arg1} @dots{} @var{args}), this function\n"
787 "conses the @var{arg1} @dots{} arguments onto the front of\n"
788 "@var{args}, and returns the resulting list. Note that\n"
789 "@var{args} is a list; thus, the argument to this function is\n"
790 "a list whose last element is a list.\n"
791 "Note: Rather than do new consing, @code{apply:nconc2last}\n"
792 "destroys its argument, so use with care.")
793 #define FUNC_NAME s_scm_nconc2last
796 SCM_VALIDATE_NONEMPTYLIST (1, lst
);
798 while (!scm_is_null (SCM_CDR (*lloc
))) /* Perhaps should be
799 SCM_NULL_OR_NIL_P, but not
800 needed in 99.99% of cases,
801 and it could seriously hurt
802 performance. - Neil */
803 lloc
= SCM_CDRLOC (*lloc
);
804 SCM_ASSERT (scm_ilength (SCM_CAR (*lloc
)) >= 0, lst
, SCM_ARG1
, FUNC_NAME
);
805 *lloc
= SCM_CAR (*lloc
);
812 /* Typechecking for multi-argument MAP and FOR-EACH.
814 Verify that each element of the vector ARGV, except for the first,
815 is a proper list whose length is LEN. Attribute errors to WHO,
816 and claim that the i'th element of ARGV is WHO's i+2'th argument. */
818 check_map_args (SCM argv
,
827 for (i
= SCM_SIMPLE_VECTOR_LENGTH (argv
) - 1; i
>= 1; i
--)
829 SCM elt
= SCM_SIMPLE_VECTOR_REF (argv
, i
);
830 long elt_len
= scm_ilength (elt
);
835 scm_apply_generic (gf
, scm_cons (proc
, args
));
837 scm_wrong_type_arg (who
, i
+ 2, elt
);
841 scm_out_of_range_pos (who
, elt
, scm_from_long (i
+ 2));
846 SCM_GPROC (s_map
, "map", 2, 0, 1, scm_map
, g_map
);
848 /* Note: Currently, scm_map applies PROC to the argument list(s)
849 sequentially, starting with the first element(s). This is used in
850 evalext.c where the Scheme procedure `map-in-order', which guarantees
851 sequential behaviour, is implemented using scm_map. If the
852 behaviour changes, we need to update `map-in-order'.
856 scm_map (SCM proc
, SCM arg1
, SCM args
)
857 #define FUNC_NAME s_map
863 len
= scm_ilength (arg1
);
864 SCM_GASSERTn (len
>= 0,
865 g_map
, scm_cons2 (proc
, arg1
, args
), SCM_ARG2
, s_map
);
866 SCM_VALIDATE_REST_ARGUMENT (args
);
867 if (scm_is_null (args
))
869 SCM_GASSERT2 (scm_is_true (scm_procedure_p (proc
)), g_map
, proc
, arg1
, SCM_ARG1
, s_map
);
870 while (SCM_NIMP (arg1
))
872 *pres
= scm_list_1 (scm_call_1 (proc
, SCM_CAR (arg1
)));
873 pres
= SCM_CDRLOC (*pres
);
874 arg1
= SCM_CDR (arg1
);
878 if (scm_is_null (SCM_CDR (args
)))
880 SCM arg2
= SCM_CAR (args
);
881 int len2
= scm_ilength (arg2
);
882 SCM_GASSERTn (scm_is_true (scm_procedure_p (proc
)), g_map
,
883 scm_cons2 (proc
, arg1
, args
), SCM_ARG1
, s_map
);
884 SCM_GASSERTn (len2
>= 0,
885 g_map
, scm_cons2 (proc
, arg1
, args
), SCM_ARG3
, s_map
);
887 SCM_OUT_OF_RANGE (3, arg2
);
888 while (SCM_NIMP (arg1
))
890 *pres
= scm_list_1 (scm_call_2 (proc
, SCM_CAR (arg1
), SCM_CAR (arg2
)));
891 pres
= SCM_CDRLOC (*pres
);
892 arg1
= SCM_CDR (arg1
);
893 arg2
= SCM_CDR (arg2
);
897 arg1
= scm_cons (arg1
, args
);
898 args
= scm_vector (arg1
);
899 check_map_args (args
, len
, g_map
, proc
, arg1
, s_map
);
903 for (i
= SCM_SIMPLE_VECTOR_LENGTH (args
) - 1; i
>= 0; i
--)
905 SCM elt
= SCM_SIMPLE_VECTOR_REF (args
, i
);
908 arg1
= scm_cons (SCM_CAR (elt
), arg1
);
909 SCM_SIMPLE_VECTOR_SET (args
, i
, SCM_CDR (elt
));
911 *pres
= scm_list_1 (scm_apply (proc
, arg1
, SCM_EOL
));
912 pres
= SCM_CDRLOC (*pres
);
918 SCM_GPROC (s_for_each
, "for-each", 2, 0, 1, scm_for_each
, g_for_each
);
921 scm_for_each (SCM proc
, SCM arg1
, SCM args
)
922 #define FUNC_NAME s_for_each
925 len
= scm_ilength (arg1
);
926 SCM_GASSERTn (len
>= 0, g_for_each
, scm_cons2 (proc
, arg1
, args
),
927 SCM_ARG2
, s_for_each
);
928 SCM_VALIDATE_REST_ARGUMENT (args
);
929 if (scm_is_null (args
))
931 SCM_GASSERT2 (scm_is_true (scm_procedure_p (proc
)), g_for_each
,
932 proc
, arg1
, SCM_ARG1
, s_for_each
);
933 while (SCM_NIMP (arg1
))
935 scm_call_1 (proc
, SCM_CAR (arg1
));
936 arg1
= SCM_CDR (arg1
);
938 return SCM_UNSPECIFIED
;
940 if (scm_is_null (SCM_CDR (args
)))
942 SCM arg2
= SCM_CAR (args
);
943 int len2
= scm_ilength (arg2
);
944 SCM_GASSERTn (scm_is_true (scm_procedure_p (proc
)), g_for_each
,
945 scm_cons2 (proc
, arg1
, args
), SCM_ARG1
, s_for_each
);
946 SCM_GASSERTn (len2
>= 0, g_for_each
,
947 scm_cons2 (proc
, arg1
, args
), SCM_ARG3
, s_for_each
);
949 SCM_OUT_OF_RANGE (3, arg2
);
950 while (SCM_NIMP (arg1
))
952 scm_call_2 (proc
, SCM_CAR (arg1
), SCM_CAR (arg2
));
953 arg1
= SCM_CDR (arg1
);
954 arg2
= SCM_CDR (arg2
);
956 return SCM_UNSPECIFIED
;
958 arg1
= scm_cons (arg1
, args
);
959 args
= scm_vector (arg1
);
960 check_map_args (args
, len
, g_for_each
, proc
, arg1
, s_for_each
);
964 for (i
= SCM_SIMPLE_VECTOR_LENGTH (args
) - 1; i
>= 0; i
--)
966 SCM elt
= SCM_SIMPLE_VECTOR_REF (args
, i
);
968 return SCM_UNSPECIFIED
;
969 arg1
= scm_cons (SCM_CAR (elt
), arg1
);
970 SCM_SIMPLE_VECTOR_SET (args
, i
, SCM_CDR (elt
));
972 scm_apply (proc
, arg1
, SCM_EOL
);
979 scm_closure (SCM code
, SCM env
)
982 SCM closcar
= scm_cons (code
, SCM_EOL
);
983 z
= scm_immutable_cell (SCM_UNPACK (closcar
) + scm_tc3_closure
,
985 scm_remember_upto_here (closcar
);
990 scm_t_bits scm_tc16_promise
;
992 SCM_DEFINE (scm_make_promise
, "make-promise", 1, 0, 0,
994 "Create a new promise object.\n\n"
995 "@code{make-promise} is a procedural form of @code{delay}.\n"
996 "These two expressions are equivalent:\n"
998 "(delay @var{exp})\n"
999 "(make-promise (lambda () @var{exp}))\n"
1001 #define FUNC_NAME s_scm_make_promise
1003 SCM_VALIDATE_THUNK (1, thunk
);
1004 SCM_RETURN_NEWSMOB2 (scm_tc16_promise
,
1006 scm_make_recursive_mutex ());
1011 promise_print (SCM exp
, SCM port
, scm_print_state
*pstate
)
1013 int writingp
= SCM_WRITINGP (pstate
);
1014 scm_puts ("#<promise ", port
);
1015 SCM_SET_WRITINGP (pstate
, 1);
1016 scm_iprin1 (SCM_PROMISE_DATA (exp
), port
, pstate
);
1017 SCM_SET_WRITINGP (pstate
, writingp
);
1018 scm_putc ('>', port
);
1022 SCM_DEFINE (scm_force
, "force", 1, 0, 0,
1024 "If the promise @var{x} has not been computed yet, compute and\n"
1025 "return @var{x}, otherwise just return the previously computed\n"
1027 #define FUNC_NAME s_scm_force
1029 SCM_VALIDATE_SMOB (1, promise
, promise
);
1030 scm_lock_mutex (SCM_PROMISE_MUTEX (promise
));
1031 if (!SCM_PROMISE_COMPUTED_P (promise
))
1033 SCM ans
= scm_call_0 (SCM_PROMISE_DATA (promise
));
1034 if (!SCM_PROMISE_COMPUTED_P (promise
))
1036 SCM_SET_PROMISE_DATA (promise
, ans
);
1037 SCM_SET_PROMISE_COMPUTED (promise
);
1040 scm_unlock_mutex (SCM_PROMISE_MUTEX (promise
));
1041 return SCM_PROMISE_DATA (promise
);
1046 SCM_DEFINE (scm_promise_p
, "promise?", 1, 0, 0,
1048 "Return true if @var{obj} is a promise, i.e. a delayed computation\n"
1049 "(@pxref{Delayed evaluation,,,r5rs.info,The Revised^5 Report on Scheme}).")
1050 #define FUNC_NAME s_scm_promise_p
1052 return scm_from_bool (SCM_TYP16_PREDICATE (scm_tc16_promise
, obj
));
1056 SCM_DEFINE (scm_primitive_eval
, "primitive-eval", 1, 0, 0,
1058 "Evaluate @var{exp} in the top-level environment specified by\n"
1059 "the current module.")
1060 #define FUNC_NAME s_scm_primitive_eval
1062 SCM transformer
= scm_current_module_transformer ();
1063 if (scm_is_true (transformer
))
1064 exp
= scm_call_1 (transformer
, exp
);
1065 exp
= scm_memoize_expression (exp
);
1066 return eval (exp
, SCM_EOL
);
1071 /* Eval does not take the second arg optionally. This is intentional
1072 * in order to be R5RS compatible, and to prepare for the new module
1073 * system, where we would like to make the choice of evaluation
1074 * environment explicit. */
1076 SCM_DEFINE (scm_eval
, "eval", 2, 0, 0,
1077 (SCM exp
, SCM module_or_state
),
1078 "Evaluate @var{exp}, a list representing a Scheme expression,\n"
1079 "in the top-level environment specified by\n"
1080 "@var{module_or_state}.\n"
1081 "While @var{exp} is evaluated (using @code{primitive-eval}),\n"
1082 "@var{module_or_state} is made the current module when\n"
1083 "it is a module, or the current dynamic state when it is\n"
1085 "Example: (eval '(+ 1 2) (interaction-environment))")
1086 #define FUNC_NAME s_scm_eval
1090 scm_dynwind_begin (SCM_F_DYNWIND_REWINDABLE
);
1091 if (scm_is_dynamic_state (module_or_state
))
1092 scm_dynwind_current_dynamic_state (module_or_state
);
1093 else if (scm_module_system_booted_p
)
1095 SCM_VALIDATE_MODULE (2, module_or_state
);
1096 scm_dynwind_current_module (module_or_state
);
1098 /* otherwise if the module system isn't booted, ignore the module arg */
1100 res
= scm_primitive_eval (exp
);
1110 /* Apply a function to a list of arguments.
1112 This function is exported to the Scheme level as taking two
1113 required arguments and a tail argument, as if it were:
1114 (lambda (proc arg1 . args) ...)
1115 Thus, if you just have a list of arguments to pass to a procedure,
1116 pass the list as ARG1, and '() for ARGS. If you have some fixed
1117 args, pass the first as ARG1, then cons any remaining fixed args
1118 onto the front of your argument list, and pass that as ARGS. */
1121 scm_apply (SCM proc
, SCM arg1
, SCM args
)
1123 /* Fix things up so that args contains all args. */
1124 if (scm_is_null (args
))
1127 args
= scm_cons_star (arg1
, args
);
1129 return apply (proc
, args
);
1136 scm_init_opts (scm_evaluator_traps
,
1137 scm_evaluator_trap_table
);
1138 scm_init_opts (scm_eval_options_interface
,
1141 scm_tc16_promise
= scm_make_smob_type ("promise", 0);
1142 scm_set_smob_print (scm_tc16_promise
, promise_print
);
1144 scm_listofnull
= scm_list_1 (SCM_EOL
);
1146 f_apply
= scm_c_define_subr ("apply", scm_tc7_lsubr_2
, scm_apply
);
1147 scm_permanent_object (f_apply
);
1149 #include "libguile/eval.x"
1151 scm_add_feature ("delay");