1 /* Copyright (C) 1995,1996,1997,1998,1999,2000,2001,2002 Free Software Foundation, Inc.
3 * This program is free software; you can redistribute it and/or modify
4 * it under the terms of the GNU General Public License as published by
5 * the Free Software Foundation; either version 2, or (at your option)
8 * This program is distributed in the hope that it will be useful,
9 * but WITHOUT ANY WARRANTY; without even the implied warranty of
10 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
11 * GNU General Public License for more details.
13 * You should have received a copy of the GNU General Public License
14 * along with this software; see the file COPYING. If not, write to
15 * the Free Software Foundation, Inc., 59 Temple Place, Suite 330,
16 * Boston, MA 02111-1307 USA
18 * As a special exception, the Free Software Foundation gives permission
19 * for additional uses of the text contained in its release of GUILE.
21 * The exception is that, if you link the GUILE library with other files
22 * to produce an executable, this does not by itself cause the
23 * resulting executable to be covered by the GNU General Public License.
24 * Your use of that executable is in no way restricted on account of
25 * linking the GUILE library code into it.
27 * This exception does not however invalidate any other reasons why
28 * the executable file might be covered by the GNU General Public License.
30 * This exception applies only to the code released by the
31 * Free Software Foundation under the name GUILE. If you copy
32 * code from other Free Software Foundation releases into a copy of
33 * GUILE, as the General Public License permits, the exception does
34 * not apply to the code that you add in this way. To avoid misleading
35 * anyone as to the status of such modified files, you must delete
36 * this exception notice from them.
38 * If you write modifications of your own for GUILE, it is your choice
39 * whether to permit this exception to apply to your modifications.
40 * If you do not wish that, delete this exception notice. */
44 /* This file is read twice in order to produce debugging versions of
45 * scm_ceval and scm_apply. These functions, scm_deval and
46 * scm_dapply, are produced when we define the preprocessor macro
47 * DEVAL. The file is divided into sections which are treated
48 * differently with respect to DEVAL. The heads of these sections are
49 * marked with the string "SECTION:".
52 /* SECTION: This code is compiled once.
57 /* We need this to get the definitions for HAVE_ALLOCA_H, etc. */
58 #include "libguile/scmconfig.h"
60 /* AIX requires this to be the first thing in the file. The #pragma
61 directive is indented so pre-ANSI compilers will ignore it, rather
70 # ifndef alloca /* predefined by HP cc +Olibcalls */
77 #include "libguile/_scm.h"
78 #include "libguile/debug.h"
79 #include "libguile/dynwind.h"
80 #include "libguile/alist.h"
81 #include "libguile/eq.h"
82 #include "libguile/continuations.h"
83 #include "libguile/throw.h"
84 #include "libguile/smob.h"
85 #include "libguile/macros.h"
86 #include "libguile/procprop.h"
87 #include "libguile/hashtab.h"
88 #include "libguile/hash.h"
89 #include "libguile/srcprop.h"
90 #include "libguile/stackchk.h"
91 #include "libguile/objects.h"
92 #include "libguile/async.h"
93 #include "libguile/feature.h"
94 #include "libguile/modules.h"
95 #include "libguile/ports.h"
96 #include "libguile/root.h"
97 #include "libguile/vectors.h"
98 #include "libguile/fluids.h"
99 #include "libguile/goops.h"
100 #include "libguile/values.h"
102 #include "libguile/validate.h"
103 #include "libguile/eval.h"
104 #include "libguile/lang.h"
108 #define SCM_VALIDATE_NON_EMPTY_COMBINATION(x) \
110 if (SCM_EQ_P ((x), SCM_EOL)) \
111 scm_misc_error (NULL, scm_s_expression, SCM_EOL); \
116 /* The evaluator contains a plethora of EVAL symbols.
117 * This is an attempt at explanation.
119 * The following macros should be used in code which is read twice
120 * (where the choice of evaluator is hard soldered):
122 * SCM_CEVAL is the symbol used within one evaluator to call itself.
123 * Originally, it is defined to scm_ceval, but is redefined to
124 * scm_deval during the second pass.
126 * SCM_EVALIM is used when it is known that the expression is an
127 * immediate. (This macro never calls an evaluator.)
129 * EVALCAR evaluates the car of an expression.
131 * EVALCELLCAR is like EVALCAR, but is used when it is known that the
132 * car is a lisp cell.
134 * The following macros should be used in code which is read once
135 * (where the choice of evaluator is dynamic):
137 * SCM_XEVAL takes care of immediates without calling an evaluator. It
138 * then calls scm_ceval *or* scm_deval, depending on the debugging
141 * SCM_XEVALCAR corresponds to EVALCAR, but uses scm_ceval *or* scm_deval
142 * depending on the debugging mode.
144 * The main motivation for keeping this plethora is efficiency
145 * together with maintainability (=> locality of code).
148 #define SCM_CEVAL scm_ceval
149 #define EVALCELLCAR(x, env) (SCM_SYMBOLP (SCM_CAR (x)) \
150 ? *scm_lookupcar (x, env, 1) \
151 : SCM_CEVAL (SCM_CAR (x), env))
153 #define EVALCAR(x, env) (SCM_IMP (SCM_CAR (x)) \
154 ? SCM_EVALIM (SCM_CAR (x), env) \
155 : EVALCELLCAR (x, env))
157 #define EXTEND_ENV SCM_EXTEND_ENV
159 #ifdef MEMOIZE_LOCALS
162 scm_ilookup (SCM iloc
, SCM env
)
164 register long ir
= SCM_IFRAME (iloc
);
165 register SCM er
= env
;
166 for (; 0 != ir
; --ir
)
169 for (ir
= SCM_IDIST (iloc
); 0 != ir
; --ir
)
171 if (SCM_ICDRP (iloc
))
172 return SCM_CDRLOC (er
);
173 return SCM_CARLOC (SCM_CDR (er
));
179 /* The Lookup Car Race
182 Memoization of variables and special forms is done while executing
183 the code for the first time. As long as there is only one thread
184 everything is fine, but as soon as two threads execute the same
185 code concurrently `for the first time' they can come into conflict.
187 This memoization includes rewriting variable references into more
188 efficient forms and expanding macros. Furthermore, macro expansion
189 includes `compiling' special forms like `let', `cond', etc. into
190 tree-code instructions.
192 There shouldn't normally be a problem with memoizing local and
193 global variable references (into ilocs and variables), because all
194 threads will mutate the code in *exactly* the same way and (if I
195 read the C code correctly) it is not possible to observe a half-way
196 mutated cons cell. The lookup procedure can handle this
197 transparently without any critical sections.
199 It is different with macro expansion, because macro expansion
200 happens outside of the lookup procedure and can't be
201 undone. Therefore the lookup procedure can't cope with it. It has
202 to indicate failure when it detects a lost race and hope that the
203 caller can handle it. Luckily, it turns out that this is the case.
205 An example to illustrate this: Suppose that the following form will
206 be memoized concurrently by two threads
210 Let's first examine the lookup of X in the body. The first thread
211 decides that it has to find the symbol "x" in the environment and
212 starts to scan it. Then the other thread takes over and actually
213 overtakes the first. It looks up "x" and substitutes an
214 appropriate iloc for it. Now the first thread continues and
215 completes its lookup. It comes to exactly the same conclusions as
216 the second one and could - without much ado - just overwrite the
217 iloc with the same iloc.
219 But let's see what will happen when the race occurs while looking
220 up the symbol "let" at the start of the form. It could happen that
221 the second thread interrupts the lookup of the first thread and not
222 only substitutes a variable for it but goes right ahead and
223 replaces it with the compiled form (#@let* (x 12) x). Now, when
224 the first thread completes its lookup, it would replace the #@let*
225 with a variable containing the "let" binding, effectively reverting
226 the form to (let (x 12) x). This is wrong. It has to detect that
227 it has lost the race and the evaluator has to reconsider the
228 changed form completely.
230 This race condition could be resolved with some kind of traffic
231 light (like mutexes) around scm_lookupcar, but I think that it is
232 best to avoid them in this case. They would serialize memoization
233 completely and because lookup involves calling arbitrary Scheme
234 code (via the lookup-thunk), threads could be blocked for an
235 arbitrary amount of time or even deadlock. But with the current
236 solution a lot of unnecessary work is potentially done. */
238 /* SCM_LOOKUPCAR1 is was SCM_LOOKUPCAR used to be but is allowed to
239 return NULL to indicate a failed lookup due to some race conditions
240 between threads. This only happens when VLOC is the first cell of
241 a special form that will eventually be memoized (like `let', etc.)
242 In that case the whole lookup is bogus and the caller has to
243 reconsider the complete special form.
245 SCM_LOOKUPCAR is still there, of course. It just calls
246 SCM_LOOKUPCAR1 and aborts on receiving NULL. So SCM_LOOKUPCAR
247 should only be called when it is known that VLOC is not the first
248 pair of a special form. Otherwise, use SCM_LOOKUPCAR1 and check
249 for NULL. I think I've found the only places where this
252 #endif /* USE_THREADS */
254 SCM_SYMBOL (scm_unbound_variable_key
, "unbound-variable");
258 scm_lookupcar1 (SCM vloc
, SCM genv
, int check
)
261 scm_lookupcar (SCM vloc
, SCM genv
, int check
)
265 register SCM
*al
, fl
, var
= SCM_CAR (vloc
);
266 #ifdef MEMOIZE_LOCALS
267 register SCM iloc
= SCM_ILOC00
;
269 for (; SCM_NIMP (env
); env
= SCM_CDR (env
))
271 if (!SCM_CONSP (SCM_CAR (env
)))
273 al
= SCM_CARLOC (env
);
274 for (fl
= SCM_CAR (*al
); SCM_NIMP (fl
); fl
= SCM_CDR (fl
))
278 if (SCM_EQ_P (fl
, var
))
280 #ifdef MEMOIZE_LOCALS
282 if (! SCM_EQ_P (SCM_CAR (vloc
), var
))
285 SCM_SET_CELL_WORD_0 (vloc
, SCM_UNPACK (iloc
) + SCM_ICDR
);
287 return SCM_CDRLOC (*al
);
292 al
= SCM_CDRLOC (*al
);
293 if (SCM_EQ_P (SCM_CAR (fl
), var
))
295 #ifdef MEMOIZE_LOCALS
296 #ifndef SCM_RECKLESS /* letrec inits to SCM_UNDEFINED */
297 if (SCM_UNBNDP (SCM_CAR (*al
)))
304 if (!SCM_EQ_P (SCM_CAR (vloc
), var
))
307 SCM_SETCAR (vloc
, iloc
);
309 return SCM_CARLOC (*al
);
311 #ifdef MEMOIZE_LOCALS
312 iloc
= SCM_PACK (SCM_UNPACK (iloc
) + SCM_IDINC
);
315 #ifdef MEMOIZE_LOCALS
316 iloc
= SCM_PACK ((~SCM_IDSTMSK
) & (SCM_UNPACK(iloc
) + SCM_IFRINC
));
320 SCM top_thunk
, real_var
;
323 top_thunk
= SCM_CAR (env
); /* env now refers to a
324 top level env thunk */
328 top_thunk
= SCM_BOOL_F
;
329 real_var
= scm_sym2var (var
, top_thunk
, SCM_BOOL_F
);
330 if (SCM_FALSEP (real_var
))
334 if (!SCM_NULLP (env
) || SCM_UNBNDP (SCM_VARIABLE_REF (real_var
)))
340 scm_error (scm_unbound_variable_key
, NULL
,
341 "Unbound variable: ~S",
342 scm_list_1 (var
), SCM_BOOL_F
);
344 scm_misc_error (NULL
, "Damaged environment: ~S",
349 /* A variable could not be found, but we shall
350 not throw an error. */
351 static SCM undef_object
= SCM_UNDEFINED
;
352 return &undef_object
;
358 if (!SCM_EQ_P (SCM_CAR (vloc
), var
))
360 /* Some other thread has changed the very cell we are working
361 on. In effect, it must have done our job or messed it up
364 var
= SCM_CAR (vloc
);
365 if (SCM_VARIABLEP (var
))
366 return SCM_VARIABLE_LOC (var
);
367 #ifdef MEMOIZE_LOCALS
368 if (SCM_ITAG7 (var
) == SCM_ITAG7 (SCM_ILOC00
))
369 return scm_ilookup (var
, genv
);
371 /* We can't cope with anything else than variables and ilocs. When
372 a special form has been memoized (i.e. `let' into `#@let') we
373 return NULL and expect the calling function to do the right
374 thing. For the evaluator, this means going back and redoing
375 the dispatch on the car of the form. */
378 #endif /* USE_THREADS */
380 SCM_SETCAR (vloc
, real_var
);
381 return SCM_VARIABLE_LOC (real_var
);
387 scm_lookupcar (SCM vloc
, SCM genv
, int check
)
389 SCM
*loc
= scm_lookupcar1 (vloc
, genv
, check
);
396 #define unmemocar scm_unmemocar
398 SCM_SYMBOL (sym_three_question_marks
, "???");
401 scm_unmemocar (SCM form
, SCM env
)
403 if (!SCM_CONSP (form
))
407 SCM c
= SCM_CAR (form
);
408 if (SCM_VARIABLEP (c
))
410 SCM sym
= scm_module_reverse_lookup (scm_env_module (env
), c
);
411 if (SCM_FALSEP (sym
))
412 sym
= sym_three_question_marks
;
413 SCM_SETCAR (form
, sym
);
415 #ifdef MEMOIZE_LOCALS
416 else if (SCM_ILOCP (c
))
418 unsigned long int ir
;
420 for (ir
= SCM_IFRAME (c
); ir
!= 0; --ir
)
422 env
= SCM_CAAR (env
);
423 for (ir
= SCM_IDIST (c
); ir
!= 0; --ir
)
425 SCM_SETCAR (form
, SCM_ICDRP (c
) ? env
: SCM_CAR (env
));
434 scm_eval_car (SCM pair
, SCM env
)
436 return SCM_XEVALCAR (pair
, env
);
441 * The following rewrite expressions and
442 * some memoized forms have different syntax
445 const char scm_s_expression
[] = "missing or extra expression";
446 const char scm_s_test
[] = "bad test";
447 const char scm_s_body
[] = "bad body";
448 const char scm_s_bindings
[] = "bad bindings";
449 const char scm_s_duplicate_bindings
[] = "duplicate bindings";
450 const char scm_s_variable
[] = "bad variable";
451 const char scm_s_clauses
[] = "bad or missing clauses";
452 const char scm_s_formals
[] = "bad formals";
453 const char scm_s_duplicate_formals
[] = "duplicate formals";
454 static const char s_splicing
[] = "bad (non-list) result for unquote-splicing";
456 SCM_GLOBAL_SYMBOL (scm_sym_dot
, ".");
457 SCM_GLOBAL_SYMBOL (scm_sym_arrow
, "=>");
458 SCM_GLOBAL_SYMBOL (scm_sym_else
, "else");
459 SCM_GLOBAL_SYMBOL (scm_sym_unquote
, "unquote");
460 SCM_GLOBAL_SYMBOL (scm_sym_uq_splicing
, "unquote-splicing");
464 #ifdef DEBUG_EXTENSIONS
465 SCM_GLOBAL_SYMBOL (scm_sym_enter_frame
, "enter-frame");
466 SCM_GLOBAL_SYMBOL (scm_sym_apply_frame
, "apply-frame");
467 SCM_GLOBAL_SYMBOL (scm_sym_exit_frame
, "exit-frame");
468 SCM_GLOBAL_SYMBOL (scm_sym_trace
, "trace");
472 /* Check that the body denoted by XORIG is valid and rewrite it into
473 its internal form. The internal form of a body is just the body
474 itself, but prefixed with an ISYM that denotes to what kind of
475 outer construct this body belongs. A lambda body starts with
476 SCM_IM_LAMBDA, for example, a body of a let starts with SCM_IM_LET,
477 etc. The one exception is a body that belongs to a letrec that has
478 been formed by rewriting internal defines: it starts with
481 /* XXX - Besides controlling the rewriting of internal defines, the
482 additional ISYM could be used for improved error messages.
483 This is not done yet. */
486 scm_m_body (SCM op
, SCM xorig
, const char *what
)
488 SCM_ASSYNT (scm_ilength (xorig
) >= 1, scm_s_body
, what
);
490 /* Don't add another ISYM if one is present already. */
491 if (SCM_ISYMP (SCM_CAR (xorig
)))
494 /* Retain possible doc string. */
495 if (!SCM_CONSP (SCM_CAR (xorig
)))
497 if (!SCM_NULLP (SCM_CDR (xorig
)))
498 return scm_cons (SCM_CAR (xorig
),
499 scm_m_body (op
, SCM_CDR (xorig
), what
));
503 return scm_cons (op
, xorig
);
507 SCM_SYNTAX (s_quote
, "quote", scm_makmmacro
, scm_m_quote
);
508 SCM_GLOBAL_SYMBOL (scm_sym_quote
, s_quote
);
511 scm_m_quote (SCM xorig
, SCM env SCM_UNUSED
)
513 SCM_ASSYNT (scm_ilength (SCM_CDR (xorig
)) == 1, scm_s_expression
, s_quote
);
514 return scm_cons (SCM_IM_QUOTE
, SCM_CDR (xorig
));
518 SCM_SYNTAX (s_begin
, "begin", scm_makmmacro
, scm_m_begin
);
519 SCM_GLOBAL_SYMBOL (scm_sym_begin
, s_begin
);
522 scm_m_begin (SCM xorig
, SCM env SCM_UNUSED
)
524 SCM_ASSYNT (scm_ilength (SCM_CDR (xorig
)) >= 0, scm_s_expression
, s_begin
);
525 return scm_cons (SCM_IM_BEGIN
, SCM_CDR (xorig
));
529 SCM_SYNTAX (s_if
, "if", scm_makmmacro
, scm_m_if
);
530 SCM_GLOBAL_SYMBOL (scm_sym_if
, s_if
);
533 scm_m_if (SCM xorig
, SCM env SCM_UNUSED
)
535 long len
= scm_ilength (SCM_CDR (xorig
));
536 SCM_ASSYNT (len
>= 2 && len
<= 3, scm_s_expression
, s_if
);
537 return scm_cons (SCM_IM_IF
, SCM_CDR (xorig
));
541 /* Will go into the RnRS module when Guile is factorized.
542 SCM_SYNTAX (scm_s_set_x,"set!", scm_makmmacro, scm_m_set_x); */
543 const char scm_s_set_x
[] = "set!";
544 SCM_GLOBAL_SYMBOL (scm_sym_set_x
, scm_s_set_x
);
547 scm_m_set_x (SCM xorig
, SCM env SCM_UNUSED
)
549 SCM x
= SCM_CDR (xorig
);
550 SCM_ASSYNT (scm_ilength (x
) == 2, scm_s_expression
, scm_s_set_x
);
551 SCM_ASSYNT (SCM_SYMBOLP (SCM_CAR (x
)), scm_s_variable
, scm_s_set_x
);
552 return scm_cons (SCM_IM_SET_X
, x
);
556 SCM_SYNTAX (s_and
, "and", scm_makmmacro
, scm_m_and
);
557 SCM_GLOBAL_SYMBOL (scm_sym_and
, s_and
);
560 scm_m_and (SCM xorig
, SCM env SCM_UNUSED
)
562 long len
= scm_ilength (SCM_CDR (xorig
));
563 SCM_ASSYNT (len
>= 0, scm_s_test
, s_and
);
565 return scm_cons (SCM_IM_AND
, SCM_CDR (xorig
));
571 SCM_SYNTAX (s_or
, "or", scm_makmmacro
, scm_m_or
);
572 SCM_GLOBAL_SYMBOL (scm_sym_or
, s_or
);
575 scm_m_or (SCM xorig
, SCM env SCM_UNUSED
)
577 long len
= scm_ilength (SCM_CDR (xorig
));
578 SCM_ASSYNT (len
>= 0, scm_s_test
, s_or
);
580 return scm_cons (SCM_IM_OR
, SCM_CDR (xorig
));
586 SCM_SYNTAX (s_case
, "case", scm_makmmacro
, scm_m_case
);
587 SCM_GLOBAL_SYMBOL (scm_sym_case
, s_case
);
590 scm_m_case (SCM xorig
, SCM env SCM_UNUSED
)
593 SCM cdrx
= SCM_CDR (xorig
);
594 SCM_ASSYNT (scm_ilength (cdrx
) >= 2, scm_s_clauses
, s_case
);
595 clauses
= SCM_CDR (cdrx
);
596 while (!SCM_NULLP (clauses
))
598 SCM clause
= SCM_CAR (clauses
);
599 SCM_ASSYNT (scm_ilength (clause
) >= 2, scm_s_clauses
, s_case
);
600 SCM_ASSYNT (scm_ilength (SCM_CAR (clause
)) >= 0
601 || (SCM_EQ_P (scm_sym_else
, SCM_CAR (clause
))
602 && SCM_NULLP (SCM_CDR (clauses
))),
603 scm_s_clauses
, s_case
);
604 clauses
= SCM_CDR (clauses
);
606 return scm_cons (SCM_IM_CASE
, cdrx
);
610 SCM_SYNTAX (s_cond
, "cond", scm_makmmacro
, scm_m_cond
);
611 SCM_GLOBAL_SYMBOL (scm_sym_cond
, s_cond
);
614 scm_m_cond (SCM xorig
, SCM env SCM_UNUSED
)
616 SCM cdrx
= SCM_CDR (xorig
);
618 SCM_ASSYNT (scm_ilength (clauses
) >= 1, scm_s_clauses
, s_cond
);
619 while (!SCM_NULLP (clauses
))
621 SCM clause
= SCM_CAR (clauses
);
622 long len
= scm_ilength (clause
);
623 SCM_ASSYNT (len
>= 1, scm_s_clauses
, s_cond
);
624 if (SCM_EQ_P (scm_sym_else
, SCM_CAR (clause
)))
626 int last_clause_p
= SCM_NULLP (SCM_CDR (clauses
));
627 SCM_ASSYNT (len
>= 2 && last_clause_p
, "bad ELSE clause", s_cond
);
629 else if (len
>= 2 && SCM_EQ_P (scm_sym_arrow
, SCM_CADR (clause
)))
631 SCM_ASSYNT (len
> 2, "missing recipient", s_cond
);
632 SCM_ASSYNT (len
== 3, "bad recipient", s_cond
);
634 clauses
= SCM_CDR (clauses
);
636 return scm_cons (SCM_IM_COND
, cdrx
);
640 SCM_SYNTAX (s_lambda
, "lambda", scm_makmmacro
, scm_m_lambda
);
641 SCM_GLOBAL_SYMBOL (scm_sym_lambda
, s_lambda
);
643 /* Return true if OBJ is `eq?' to one of the elements of LIST or to the
644 * cdr of the last cons. (Thus, LIST is not required to be a proper
645 * list and OBJ can also be found in the improper ending.) */
647 scm_c_improper_memq (SCM obj
, SCM list
)
649 for (; SCM_CONSP (list
); list
= SCM_CDR (list
))
651 if (SCM_EQ_P (SCM_CAR (list
), obj
))
654 return SCM_EQ_P (list
, obj
);
658 scm_m_lambda (SCM xorig
, SCM env SCM_UNUSED
)
661 SCM x
= SCM_CDR (xorig
);
663 SCM_ASSYNT (SCM_CONSP (x
), scm_s_formals
, s_lambda
);
665 formals
= SCM_CAR (x
);
666 while (SCM_CONSP (formals
))
668 SCM formal
= SCM_CAR (formals
);
669 SCM_ASSYNT (SCM_SYMBOLP (formal
), scm_s_formals
, s_lambda
);
670 if (scm_c_improper_memq (formal
, SCM_CDR (formals
)))
671 scm_misc_error (s_lambda
, scm_s_duplicate_formals
, SCM_EOL
);
672 formals
= SCM_CDR (formals
);
674 if (!SCM_NULLP (formals
) && !SCM_SYMBOLP (formals
))
675 scm_misc_error (s_lambda
, scm_s_formals
, SCM_EOL
);
677 return scm_cons2 (SCM_IM_LAMBDA
, SCM_CAR (x
),
678 scm_m_body (SCM_IM_LAMBDA
, SCM_CDR (x
), s_lambda
));
682 SCM_SYNTAX (s_letstar
, "let*", scm_makmmacro
, scm_m_letstar
);
683 SCM_GLOBAL_SYMBOL (scm_sym_letstar
, s_letstar
);
685 /* (let* ((v1 i1) (v2 i2) ...) body) with variables v1 .. vk and initializers
686 * i1 .. ik is transformed into the form (#@let* (v1 i1 v2 i2 ...) body*). */
688 scm_m_letstar (SCM xorig
, SCM env SCM_UNUSED
)
691 SCM x
= SCM_CDR (xorig
);
695 SCM_ASSYNT (SCM_CONSP (x
), scm_s_bindings
, s_letstar
);
697 bindings
= SCM_CAR (x
);
698 SCM_ASSYNT (scm_ilength (bindings
) >= 0, scm_s_bindings
, s_letstar
);
699 while (!SCM_NULLP (bindings
))
701 SCM binding
= SCM_CAR (bindings
);
702 SCM_ASSYNT (scm_ilength (binding
) == 2, scm_s_bindings
, s_letstar
);
703 SCM_ASSYNT (SCM_SYMBOLP (SCM_CAR (binding
)), scm_s_variable
, s_letstar
);
704 *varloc
= scm_list_2 (SCM_CAR (binding
), SCM_CADR (binding
));
705 varloc
= SCM_CDRLOC (SCM_CDR (*varloc
));
706 bindings
= SCM_CDR (bindings
);
709 return scm_cons2 (SCM_IM_LETSTAR
, vars
,
710 scm_m_body (SCM_IM_LETSTAR
, SCM_CDR (x
), s_letstar
));
714 /* DO gets the most radically altered syntax. The order of the vars is
715 * reversed here. In contrast, the order of the inits and steps is reversed
716 * during the evaluation:
718 (do ((<var1> <init1> <step1>)
726 (#@do (varn ... var2 var1)
727 (<init1> <init2> ... <initn>)
730 <step1> <step2> ... <stepn>) ;; missing steps replaced by var
733 SCM_SYNTAX(s_do
, "do", scm_makmmacro
, scm_m_do
);
734 SCM_GLOBAL_SYMBOL(scm_sym_do
, s_do
);
737 scm_m_do (SCM xorig
, SCM env SCM_UNUSED
)
740 SCM x
= SCM_CDR (xorig
);
743 SCM
*initloc
= &inits
;
745 SCM
*steploc
= &steps
;
746 SCM_ASSYNT (scm_ilength (x
) >= 2, scm_s_test
, "do");
747 bindings
= SCM_CAR (x
);
748 SCM_ASSYNT (scm_ilength (bindings
) >= 0, scm_s_bindings
, "do");
749 while (!SCM_NULLP (bindings
))
751 SCM binding
= SCM_CAR (bindings
);
752 long len
= scm_ilength (binding
);
753 SCM_ASSYNT (len
== 2 || len
== 3, scm_s_bindings
, "do");
755 SCM name
= SCM_CAR (binding
);
756 SCM init
= SCM_CADR (binding
);
757 SCM step
= (len
== 2) ? name
: SCM_CADDR (binding
);
758 SCM_ASSYNT (SCM_SYMBOLP (name
), scm_s_variable
, "do");
759 vars
= scm_cons (name
, vars
);
760 *initloc
= scm_list_1 (init
);
761 initloc
= SCM_CDRLOC (*initloc
);
762 *steploc
= scm_list_1 (step
);
763 steploc
= SCM_CDRLOC (*steploc
);
764 bindings
= SCM_CDR (bindings
);
768 SCM_ASSYNT (scm_ilength (SCM_CAR (x
)) >= 1, scm_s_test
, "do");
769 x
= scm_cons2 (SCM_CAR (x
), SCM_CDR (x
), steps
);
770 x
= scm_cons2 (vars
, inits
, x
);
771 return scm_cons (SCM_IM_DO
, x
);
775 SCM_SYNTAX (s_quasiquote
, "quasiquote", scm_makacro
, scm_m_quasiquote
);
776 SCM_GLOBAL_SYMBOL (scm_sym_quasiquote
, s_quasiquote
);
778 /* Internal function to handle a quasiquotation: 'form' is the parameter in
779 * the call (quasiquotation form), 'env' is the environment where unquoted
780 * expressions will be evaluated, and 'depth' is the current quasiquotation
781 * nesting level and is known to be greater than zero. */
783 iqq (SCM form
, SCM env
, unsigned long int depth
)
785 if (SCM_CONSP (form
))
787 SCM tmp
= SCM_CAR (form
);
788 if (SCM_EQ_P (tmp
, scm_sym_quasiquote
))
790 SCM args
= SCM_CDR (form
);
791 SCM_ASSYNT (scm_ilength (args
) == 1, scm_s_expression
, s_quasiquote
);
792 return scm_list_2 (tmp
, iqq (SCM_CAR (args
), env
, depth
+ 1));
794 else if (SCM_EQ_P (tmp
, scm_sym_unquote
))
796 SCM args
= SCM_CDR (form
);
797 SCM_ASSYNT (scm_ilength (args
) == 1, scm_s_expression
, s_quasiquote
);
799 return scm_eval_car (args
, env
);
801 return scm_list_2 (tmp
, iqq (SCM_CAR (args
), env
, depth
- 1));
803 else if (SCM_CONSP (tmp
)
804 && SCM_EQ_P (SCM_CAR (tmp
), scm_sym_uq_splicing
))
806 SCM args
= SCM_CDR (tmp
);
807 SCM_ASSYNT (scm_ilength (args
) == 1, scm_s_expression
, s_quasiquote
);
810 SCM list
= scm_eval_car (args
, env
);
811 SCM rest
= SCM_CDR (form
);
812 SCM_ASSYNT (scm_ilength (list
) >= 0, s_splicing
, s_quasiquote
);
813 return scm_append (scm_list_2 (list
, iqq (rest
, env
, depth
)));
816 return scm_cons (iqq (SCM_CAR (form
), env
, depth
- 1),
817 iqq (SCM_CDR (form
), env
, depth
));
820 return scm_cons (iqq (SCM_CAR (form
), env
, depth
),
821 iqq (SCM_CDR (form
), env
, depth
));
823 else if (SCM_VECTORP (form
))
825 size_t i
= SCM_VECTOR_LENGTH (form
);
826 SCM
*data
= SCM_VELTS (form
);
829 tmp
= scm_cons (data
[--i
], tmp
);
830 scm_remember_upto_here_1 (form
);
831 return scm_vector (iqq (tmp
, env
, depth
));
838 scm_m_quasiquote (SCM xorig
, SCM env
)
840 SCM x
= SCM_CDR (xorig
);
841 SCM_ASSYNT (scm_ilength (x
) == 1, scm_s_expression
, s_quasiquote
);
842 return iqq (SCM_CAR (x
), env
, 1);
846 SCM_SYNTAX (s_delay
, "delay", scm_makmmacro
, scm_m_delay
);
847 SCM_GLOBAL_SYMBOL (scm_sym_delay
, s_delay
);
849 /* Promises are implemented as closures with an empty parameter list. Thus,
850 * (delay <expression>) is transformed into (#@delay '() <expression>), where
851 * the empty list represents the empty parameter list. This representation
852 * allows for easy creation of the closure during evaluation. */
854 scm_m_delay (SCM xorig
, SCM env SCM_UNUSED
)
856 SCM_ASSYNT (scm_ilength (xorig
) == 2, scm_s_expression
, s_delay
);
857 return scm_cons2 (SCM_IM_DELAY
, SCM_EOL
, SCM_CDR (xorig
));
861 SCM_SYNTAX(s_define
, "define", scm_makmmacro
, scm_m_define
);
862 SCM_GLOBAL_SYMBOL(scm_sym_define
, s_define
);
864 /* Guile provides an extension to R5RS' define syntax to represent function
865 * currying in a compact way. With this extension, it is allowed to write
866 * (define <nested-variable> <body>), where <nested-variable> has of one of
867 * the forms (<nested-variable> <formals>), (<nested-variable> . <formal>),
868 * (<variable> <formals>) or (<variable> . <formal>). As in R5RS, <formals>
869 * should be either a sequence of zero or more variables, or a sequence of one
870 * or more variables followed by a space-delimited period and another
871 * variable. Each level of argument nesting wraps the <body> within another
872 * lambda expression. For example, the following forms are allowed, each one
873 * followed by an equivalent, more explicit implementation.
875 * (define ((a b . c) . d) <body>) is equivalent to
876 * (define a (lambda (b . c) (lambda d <body>)))
878 * (define (((a) b) c . d) <body>) is equivalent to
879 * (define a (lambda () (lambda (b) (lambda (c . d) <body>))))
881 /* Dirk:FIXME:: We should provide an implementation for 'define' in the R5RS
882 * module that does not implement this extension. */
884 scm_m_define (SCM x
, SCM env
)
888 SCM_ASSYNT (scm_ilength (x
) >= 2, scm_s_expression
, s_define
);
891 while (SCM_CONSP (name
))
893 /* This while loop realizes function currying by variable nesting. */
894 SCM formals
= SCM_CDR (name
);
895 x
= scm_list_1 (scm_cons2 (scm_sym_lambda
, formals
, x
));
896 name
= SCM_CAR (name
);
898 SCM_ASSYNT (SCM_SYMBOLP (name
), scm_s_variable
, s_define
);
899 SCM_ASSYNT (scm_ilength (x
) == 1, scm_s_expression
, s_define
);
900 if (SCM_TOP_LEVEL (env
))
903 x
= scm_eval_car (x
, env
);
904 if (SCM_REC_PROCNAMES_P
)
907 while (SCM_MACROP (tmp
))
908 tmp
= SCM_MACRO_CODE (tmp
);
909 if (SCM_CLOSUREP (tmp
)
910 /* Only the first definition determines the name. */
911 && SCM_FALSEP (scm_procedure_property (tmp
, scm_sym_name
)))
912 scm_set_procedure_property_x (tmp
, scm_sym_name
, name
);
914 var
= scm_sym2var (name
, scm_env_top_level (env
), SCM_BOOL_T
);
915 SCM_VARIABLE_SET (var
, x
);
916 return SCM_UNSPECIFIED
;
919 return scm_cons2 (SCM_IM_DEFINE
, name
, x
);
923 /* The bindings ((v1 i1) (v2 i2) ... (vn in)) are transformed to the lists
924 * (vn ... v2 v1) and (i1 i2 ... in). That is, the list of variables is
925 * reversed here, the list of inits gets reversed during evaluation. */
927 transform_bindings (SCM bindings
, SCM
*rvarloc
, SCM
*initloc
, const char *what
)
933 SCM_ASSYNT (scm_ilength (bindings
) >= 1, scm_s_bindings
, what
);
937 SCM binding
= SCM_CAR (bindings
);
938 SCM_ASSYNT (scm_ilength (binding
) == 2, scm_s_bindings
, what
);
939 SCM_ASSYNT (SCM_SYMBOLP (SCM_CAR (binding
)), scm_s_variable
, what
);
940 if (scm_c_improper_memq (SCM_CAR (binding
), rvars
))
941 scm_misc_error (what
, scm_s_duplicate_bindings
, SCM_EOL
);
942 rvars
= scm_cons (SCM_CAR (binding
), rvars
);
943 *initloc
= scm_list_1 (SCM_CADR (binding
));
944 initloc
= SCM_CDRLOC (*initloc
);
945 bindings
= SCM_CDR (bindings
);
947 while (!SCM_NULLP (bindings
));
953 SCM_SYNTAX(s_letrec
, "letrec", scm_makmmacro
, scm_m_letrec
);
954 SCM_GLOBAL_SYMBOL(scm_sym_letrec
, s_letrec
);
957 scm_m_letrec (SCM xorig
, SCM env
)
959 SCM x
= SCM_CDR (xorig
);
960 SCM_ASSYNT (SCM_CONSP (x
), scm_s_bindings
, s_letrec
);
962 if (SCM_NULLP (SCM_CAR (x
)))
964 /* null binding, let* faster */
965 SCM body
= scm_m_body (SCM_IM_LETREC
, SCM_CDR (x
), s_letrec
);
966 return scm_m_letstar (scm_cons2 (SCM_CAR (xorig
), SCM_EOL
, body
), env
);
970 SCM rvars
, inits
, body
;
971 transform_bindings (SCM_CAR (x
), &rvars
, &inits
, "letrec");
972 body
= scm_m_body (SCM_IM_LETREC
, SCM_CDR (x
), "letrec");
973 return scm_cons2 (SCM_IM_LETREC
, rvars
, scm_cons (inits
, body
));
978 SCM_SYNTAX(s_let
, "let", scm_makmmacro
, scm_m_let
);
979 SCM_GLOBAL_SYMBOL(scm_sym_let
, s_let
);
982 scm_m_let (SCM xorig
, SCM env
)
984 SCM x
= SCM_CDR (xorig
);
987 SCM_ASSYNT (SCM_CONSP (x
), scm_s_bindings
, s_let
);
990 || (scm_ilength (temp
) == 1 && SCM_CONSP (SCM_CAR (temp
))))
992 /* null or single binding, let* is faster */
994 SCM body
= scm_m_body (SCM_IM_LET
, SCM_CDR (x
), s_let
);
995 return scm_m_letstar (scm_cons2 (SCM_CAR (xorig
), bindings
, body
), env
);
997 else if (SCM_CONSP (temp
))
1000 SCM bindings
= temp
;
1001 SCM rvars
, inits
, body
;
1002 transform_bindings (bindings
, &rvars
, &inits
, "let");
1003 body
= scm_m_body (SCM_IM_LET
, SCM_CDR (x
), "let");
1004 return scm_cons2 (SCM_IM_LET
, rvars
, scm_cons (inits
, body
));
1008 /* named let: Transform (let name ((var init) ...) body ...) into
1009 * ((letrec ((name (lambda (var ...) body ...))) name) init ...) */
1013 SCM
*varloc
= &vars
;
1014 SCM inits
= SCM_EOL
;
1015 SCM
*initloc
= &inits
;
1018 SCM_ASSYNT (SCM_SYMBOLP (name
), scm_s_bindings
, s_let
);
1020 SCM_ASSYNT (SCM_CONSP (x
), scm_s_bindings
, s_let
);
1021 bindings
= SCM_CAR (x
);
1022 SCM_ASSYNT (scm_ilength (bindings
) >= 0, scm_s_bindings
, s_let
);
1023 while (!SCM_NULLP (bindings
))
1024 { /* vars and inits both in order */
1025 SCM binding
= SCM_CAR (bindings
);
1026 SCM_ASSYNT (scm_ilength (binding
) == 2, scm_s_bindings
, s_let
);
1027 SCM_ASSYNT (SCM_SYMBOLP (SCM_CAR (binding
)), scm_s_variable
, s_let
);
1028 *varloc
= scm_list_1 (SCM_CAR (binding
));
1029 varloc
= SCM_CDRLOC (*varloc
);
1030 *initloc
= scm_list_1 (SCM_CADR (binding
));
1031 initloc
= SCM_CDRLOC (*initloc
);
1032 bindings
= SCM_CDR (bindings
);
1036 SCM lambda_body
= scm_m_body (SCM_IM_LET
, SCM_CDR (x
), "let");
1037 SCM lambda_form
= scm_cons2 (scm_sym_lambda
, vars
, lambda_body
);
1038 SCM rvar
= scm_list_1 (name
);
1039 SCM init
= scm_list_1 (lambda_form
);
1040 SCM body
= scm_m_body (SCM_IM_LET
, scm_list_1 (name
), "let");
1041 SCM letrec
= scm_cons2 (SCM_IM_LETREC
, rvar
, scm_cons (init
, body
));
1042 return scm_cons (letrec
, inits
);
1048 SCM_SYNTAX (s_atapply
,"@apply", scm_makmmacro
, scm_m_apply
);
1049 SCM_GLOBAL_SYMBOL (scm_sym_atapply
, s_atapply
);
1050 SCM_GLOBAL_SYMBOL (scm_sym_apply
, s_atapply
+ 1);
1053 scm_m_apply (SCM xorig
, SCM env SCM_UNUSED
)
1055 SCM_ASSYNT (scm_ilength (SCM_CDR (xorig
)) == 2, scm_s_expression
, s_atapply
);
1056 return scm_cons (SCM_IM_APPLY
, SCM_CDR (xorig
));
1060 SCM_SYNTAX(s_atcall_cc
,"@call-with-current-continuation", scm_makmmacro
, scm_m_cont
);
1061 SCM_GLOBAL_SYMBOL(scm_sym_atcall_cc
,s_atcall_cc
);
1065 scm_m_cont (SCM xorig
, SCM env SCM_UNUSED
)
1067 SCM_ASSYNT (scm_ilength (SCM_CDR (xorig
)) == 1,
1068 scm_s_expression
, s_atcall_cc
);
1069 return scm_cons (SCM_IM_CONT
, SCM_CDR (xorig
));
1072 #ifdef SCM_ENABLE_ELISP
1074 SCM_SYNTAX (s_nil_cond
, "nil-cond", scm_makmmacro
, scm_m_nil_cond
);
1077 scm_m_nil_cond (SCM xorig
, SCM env SCM_UNUSED
)
1079 long len
= scm_ilength (SCM_CDR (xorig
));
1080 SCM_ASSYNT (len
>= 1 && (len
& 1) == 1, scm_s_expression
, "nil-cond");
1081 return scm_cons (SCM_IM_NIL_COND
, SCM_CDR (xorig
));
1084 SCM_SYNTAX (s_atfop
, "@fop", scm_makmmacro
, scm_m_atfop
);
1087 scm_m_atfop (SCM xorig
, SCM env SCM_UNUSED
)
1089 SCM x
= SCM_CDR (xorig
), var
;
1090 SCM_ASSYNT (scm_ilength (x
) >= 1, scm_s_expression
, "@fop");
1091 var
= scm_symbol_fref (SCM_CAR (x
));
1092 /* Passing the symbol name as the `subr' arg here isn't really
1093 right, but without it it can be very difficult to work out from
1094 the error message which function definition was missing. In any
1095 case, we shouldn't really use SCM_ASSYNT here at all, but instead
1096 something equivalent to (signal void-function (list SYM)) in
1098 SCM_ASSYNT (SCM_VARIABLEP (var
),
1099 "Symbol's function definition is void",
1100 SCM_SYMBOL_CHARS (SCM_CAR (x
)));
1101 /* Support `defalias'. */
1102 while (SCM_SYMBOLP (SCM_VARIABLE_REF (var
)))
1104 var
= scm_symbol_fref (SCM_VARIABLE_REF (var
));
1105 SCM_ASSYNT (SCM_VARIABLEP (var
),
1106 "Symbol's function definition is void",
1107 SCM_SYMBOL_CHARS (SCM_CAR (x
)));
1109 /* Use `var' here rather than `SCM_VARIABLE_REF (var)' because the
1110 former allows for automatically picking up redefinitions of the
1111 corresponding symbol. */
1112 SCM_SETCAR (x
, var
);
1113 /* If the variable contains a procedure, leave the
1114 `transformer-macro' in place so that the procedure's arguments
1115 get properly transformed, and change the initial @fop to
1117 if (!SCM_MACROP (SCM_VARIABLE_REF (var
)))
1119 SCM_SETCAR (xorig
, SCM_IM_APPLY
);
1122 /* Otherwise (the variable contains a macro), the arguments should
1123 not be transformed, so cut the `transformer-macro' out and return
1124 the resulting expression starting with the variable. */
1125 SCM_SETCDR (x
, SCM_CDADR (x
));
1129 #endif /* SCM_ENABLE_ELISP */
1131 /* (@bind ((var exp) ...) body ...)
1133 This will assign the values of the `exp's to the global variables
1134 named by `var's (symbols, not evaluated), creating them if they
1135 don't exist, executes body, and then restores the previous values of
1136 the `var's. Additionally, whenever control leaves body, the values
1137 of the `var's are saved and restored when control returns. It is an
1138 error when a symbol appears more than once among the `var's.
1139 All `exp's are evaluated before any `var' is set.
1141 Think of this as `let' for dynamic scope.
1143 It is memoized into (#@bind ((var ...) . (reversed-val ...)) body ...).
1145 XXX - also implement `@bind*'.
1148 SCM_SYNTAX (s_atbind
, "@bind", scm_makmmacro
, scm_m_atbind
);
1151 scm_m_atbind (SCM xorig
, SCM env
)
1153 SCM x
= SCM_CDR (xorig
);
1154 SCM top_level
= scm_env_top_level (env
);
1155 SCM vars
= SCM_EOL
, var
;
1158 SCM_ASSYNT (scm_ilength (x
) > 1, scm_s_expression
, s_atbind
);
1161 while (SCM_NIMP (x
))
1164 SCM sym_exp
= SCM_CAR (x
);
1165 SCM_ASSYNT (scm_ilength (sym_exp
) == 2, scm_s_bindings
, s_atbind
);
1166 SCM_ASSYNT (SCM_SYMBOLP (SCM_CAR (sym_exp
)), scm_s_bindings
, s_atbind
);
1168 for (rest
= x
; SCM_NIMP (rest
); rest
= SCM_CDR (rest
))
1169 if (SCM_EQ_P (SCM_CAR (sym_exp
), SCM_CAAR (rest
)))
1170 scm_misc_error (s_atbind
, scm_s_duplicate_bindings
, SCM_EOL
);
1171 /* The first call to scm_sym2var will look beyond the current
1172 module, while the second call wont. */
1173 var
= scm_sym2var (SCM_CAR (sym_exp
), top_level
, SCM_BOOL_F
);
1174 if (SCM_FALSEP (var
))
1175 var
= scm_sym2var (SCM_CAR (sym_exp
), top_level
, SCM_BOOL_T
);
1176 vars
= scm_cons (var
, vars
);
1177 exps
= scm_cons (SCM_CADR (sym_exp
), exps
);
1179 return scm_cons (SCM_IM_BIND
,
1180 scm_cons (scm_cons (scm_reverse_x (vars
, SCM_EOL
), exps
),
1184 SCM_SYNTAX (s_at_call_with_values
, "@call-with-values", scm_makmmacro
, scm_m_at_call_with_values
);
1185 SCM_GLOBAL_SYMBOL(scm_sym_at_call_with_values
, s_at_call_with_values
);
1188 scm_m_at_call_with_values (SCM xorig
, SCM env SCM_UNUSED
)
1190 SCM_ASSYNT (scm_ilength (SCM_CDR (xorig
)) == 2,
1191 scm_s_expression
, s_at_call_with_values
);
1192 return scm_cons (SCM_IM_CALL_WITH_VALUES
, SCM_CDR (xorig
));
1196 scm_m_expand_body (SCM xorig
, SCM env
)
1198 SCM x
= SCM_CDR (xorig
), defs
= SCM_EOL
;
1199 char *what
= SCM_ISYMCHARS (SCM_CAR (xorig
)) + 2;
1201 while (SCM_NIMP (x
))
1203 SCM form
= SCM_CAR (x
);
1204 if (!SCM_CONSP (form
))
1206 if (!SCM_SYMBOLP (SCM_CAR (form
)))
1209 form
= scm_macroexp (scm_cons_source (form
,
1214 if (SCM_EQ_P (SCM_IM_DEFINE
, SCM_CAR (form
)))
1216 defs
= scm_cons (SCM_CDR (form
), defs
);
1219 else if (!SCM_IMP (defs
))
1223 else if (SCM_EQ_P (SCM_IM_BEGIN
, SCM_CAR (form
)))
1225 x
= scm_append (scm_list_2 (SCM_CDR (form
), SCM_CDR (x
)));
1229 x
= scm_cons (form
, SCM_CDR (x
));
1234 if (!SCM_NULLP (defs
))
1236 SCM rvars
, inits
, body
, letrec
;
1237 transform_bindings (defs
, &rvars
, &inits
, what
);
1238 body
= scm_m_body (SCM_IM_DEFINE
, x
, what
);
1239 letrec
= scm_cons2 (SCM_IM_LETREC
, rvars
, scm_cons (inits
, body
));
1240 SCM_SETCAR (xorig
, letrec
);
1241 SCM_SETCDR (xorig
, SCM_EOL
);
1245 SCM_ASSYNT (SCM_CONSP (x
), scm_s_body
, what
);
1246 SCM_SETCAR (xorig
, SCM_CAR (x
));
1247 SCM_SETCDR (xorig
, SCM_CDR (x
));
1254 scm_macroexp (SCM x
, SCM env
)
1256 SCM res
, proc
, orig_sym
;
1258 /* Don't bother to produce error messages here. We get them when we
1259 eventually execute the code for real. */
1262 orig_sym
= SCM_CAR (x
);
1263 if (!SCM_SYMBOLP (orig_sym
))
1268 SCM
*proc_ptr
= scm_lookupcar1 (x
, env
, 0);
1269 if (proc_ptr
== NULL
)
1271 /* We have lost the race. */
1277 proc
= *scm_lookupcar (x
, env
, 0);
1280 /* Only handle memoizing macros. `Acros' and `macros' are really
1281 special forms and should not be evaluated here. */
1283 if (!SCM_MACROP (proc
) || SCM_MACRO_TYPE (proc
) != 2)
1286 SCM_SETCAR (x
, orig_sym
); /* Undo memoizing effect of lookupcar */
1287 res
= scm_call_2 (SCM_MACRO_CODE (proc
), x
, env
);
1289 if (scm_ilength (res
) <= 0)
1290 res
= scm_list_2 (SCM_IM_BEGIN
, res
);
1293 SCM_SETCAR (x
, SCM_CAR (res
));
1294 SCM_SETCDR (x
, SCM_CDR (res
));
1300 /* scm_unmemocopy takes a memoized expression together with its
1301 * environment and rewrites it to its original form. Thus, it is the
1302 * inversion of the rewrite rules above. The procedure is not
1303 * optimized for speed. It's used in scm_iprin1 when printing the
1304 * code of a closure, in scm_procedure_source, in display_frame when
1305 * generating the source for a stackframe in a backtrace, and in
1306 * display_expression.
1308 * Unmemoizing is not a reliable process. You cannot in general
1309 * expect to get the original source back.
1311 * However, GOOPS currently relies on this for method compilation.
1312 * This ought to change.
1315 #define SCM_BIT8(x) (127 & SCM_UNPACK (x))
1318 build_binding_list (SCM names
, SCM inits
)
1320 SCM bindings
= SCM_EOL
;
1321 while (!SCM_NULLP (names
))
1323 SCM binding
= scm_list_2 (SCM_CAR (names
), SCM_CAR (inits
));
1324 bindings
= scm_cons (binding
, bindings
);
1325 names
= SCM_CDR (names
);
1326 inits
= SCM_CDR (inits
);
1332 unmemocopy (SCM x
, SCM env
)
1335 #ifdef DEBUG_EXTENSIONS
1340 #ifdef DEBUG_EXTENSIONS
1341 p
= scm_whash_lookup (scm_source_whash
, x
);
1343 switch (SCM_ITAG7 (SCM_CAR (x
)))
1345 case SCM_BIT8(SCM_IM_AND
):
1346 ls
= z
= scm_cons (scm_sym_and
, SCM_UNSPECIFIED
);
1348 case SCM_BIT8(SCM_IM_BEGIN
):
1349 ls
= z
= scm_cons (scm_sym_begin
, SCM_UNSPECIFIED
);
1351 case SCM_BIT8(SCM_IM_CASE
):
1352 ls
= z
= scm_cons (scm_sym_case
, SCM_UNSPECIFIED
);
1354 case SCM_BIT8(SCM_IM_COND
):
1355 ls
= z
= scm_cons (scm_sym_cond
, SCM_UNSPECIFIED
);
1357 case SCM_BIT8 (SCM_IM_DO
):
1359 /* format: (#@do (nk nk-1 ...) (i1 ... ik) (test) (body) s1 ... sk),
1360 * where nx is the name of a local variable, ix is an initializer for
1361 * the local variable, test is the test clause of the do loop, body is
1362 * the body of the do loop and sx are the step clauses for the local
1364 SCM names
, inits
, test
, memoized_body
, steps
, bindings
;
1367 names
= SCM_CAR (x
);
1369 inits
= scm_reverse (unmemocopy (SCM_CAR (x
), env
));
1370 env
= EXTEND_ENV (names
, SCM_EOL
, env
);
1372 test
= unmemocopy (SCM_CAR (x
), env
);
1374 memoized_body
= SCM_CAR (x
);
1376 steps
= scm_reverse (unmemocopy (x
, env
));
1378 /* build transformed binding list */
1380 while (!SCM_NULLP (names
))
1382 SCM name
= SCM_CAR (names
);
1383 SCM init
= SCM_CAR (inits
);
1384 SCM step
= SCM_CAR (steps
);
1385 step
= SCM_EQ_P (step
, name
) ? SCM_EOL
: scm_list_1 (step
);
1387 bindings
= scm_cons (scm_cons2 (name
, init
, step
), bindings
);
1389 names
= SCM_CDR (names
);
1390 inits
= SCM_CDR (inits
);
1391 steps
= SCM_CDR (steps
);
1393 z
= scm_cons (test
, SCM_UNSPECIFIED
);
1394 ls
= scm_cons2 (scm_sym_do
, bindings
, z
);
1396 x
= scm_cons (SCM_BOOL_F
, memoized_body
);
1399 case SCM_BIT8(SCM_IM_IF
):
1400 ls
= z
= scm_cons (scm_sym_if
, SCM_UNSPECIFIED
);
1402 case SCM_BIT8 (SCM_IM_LET
):
1404 /* format: (#@let (nk nk-1 ...) (i1 ... ik) b1 ...),
1405 * where nx is the name of a local variable, ix is an initializer for
1406 * the local variable and by are the body clauses. */
1407 SCM names
, inits
, bindings
;
1410 names
= SCM_CAR (x
);
1412 inits
= scm_reverse (unmemocopy (SCM_CAR (x
), env
));
1413 env
= EXTEND_ENV (names
, SCM_EOL
, env
);
1415 bindings
= build_binding_list (names
, inits
);
1416 z
= scm_cons (bindings
, SCM_UNSPECIFIED
);
1417 ls
= scm_cons (scm_sym_let
, z
);
1420 case SCM_BIT8 (SCM_IM_LETREC
):
1422 /* format: (#@letrec (nk nk-1 ...) (i1 ... ik) b1 ...),
1423 * where nx is the name of a local variable, ix is an initializer for
1424 * the local variable and by are the body clauses. */
1425 SCM names
, inits
, bindings
;
1428 names
= SCM_CAR (x
);
1429 env
= EXTEND_ENV (names
, SCM_EOL
, env
);
1431 inits
= scm_reverse (unmemocopy (SCM_CAR (x
), env
));
1433 bindings
= build_binding_list (names
, inits
);
1434 z
= scm_cons (bindings
, SCM_UNSPECIFIED
);
1435 ls
= scm_cons (scm_sym_letrec
, z
);
1438 case SCM_BIT8(SCM_IM_LETSTAR
):
1446 env
= EXTEND_ENV (SCM_EOL
, SCM_EOL
, env
);
1449 y
= z
= scm_acons (SCM_CAR (b
),
1451 scm_cons (unmemocopy (SCM_CADR (b
), env
), SCM_EOL
), env
),
1453 env
= EXTEND_ENV (SCM_CAR (b
), SCM_BOOL_F
, env
);
1457 SCM_SETCDR (y
, SCM_EOL
);
1458 ls
= scm_cons (scm_sym_let
, z
= scm_cons (y
, SCM_UNSPECIFIED
));
1463 SCM_SETCDR (z
, scm_acons (SCM_CAR (b
),
1465 scm_list_1 (unmemocopy (SCM_CADR (b
), env
)), env
),
1468 env
= EXTEND_ENV (SCM_CAR (b
), SCM_BOOL_F
, env
);
1471 while (SCM_NIMP (b
));
1472 SCM_SETCDR (z
, SCM_EOL
);
1474 ls
= scm_cons (scm_sym_letstar
, z
= scm_cons (y
, SCM_UNSPECIFIED
));
1477 case SCM_BIT8(SCM_IM_OR
):
1478 ls
= z
= scm_cons (scm_sym_or
, SCM_UNSPECIFIED
);
1480 case SCM_BIT8(SCM_IM_LAMBDA
):
1482 z
= scm_cons (SCM_CAR (x
), SCM_UNSPECIFIED
);
1483 ls
= scm_cons (scm_sym_lambda
, z
);
1484 env
= EXTEND_ENV (SCM_CAR (x
), SCM_EOL
, env
);
1486 case SCM_BIT8(SCM_IM_QUOTE
):
1487 ls
= z
= scm_cons (scm_sym_quote
, SCM_UNSPECIFIED
);
1489 case SCM_BIT8(SCM_IM_SET_X
):
1490 ls
= z
= scm_cons (scm_sym_set_x
, SCM_UNSPECIFIED
);
1492 case SCM_BIT8(SCM_IM_DEFINE
):
1497 z
= scm_cons (n
, SCM_UNSPECIFIED
);
1498 ls
= scm_cons (scm_sym_define
, z
);
1499 if (!SCM_NULLP (env
))
1500 SCM_SETCAR (SCM_CAR (env
), scm_cons (n
, SCM_CAAR (env
)));
1503 case SCM_BIT8(SCM_MAKISYM (0)):
1507 switch (SCM_ISYMNUM (z
))
1509 case (SCM_ISYMNUM (SCM_IM_APPLY
)):
1510 ls
= z
= scm_cons (scm_sym_atapply
, SCM_UNSPECIFIED
);
1512 case (SCM_ISYMNUM (SCM_IM_CONT
)):
1513 ls
= z
= scm_cons (scm_sym_atcall_cc
, SCM_UNSPECIFIED
);
1515 case (SCM_ISYMNUM (SCM_IM_DELAY
)):
1516 ls
= z
= scm_cons (scm_sym_delay
, SCM_UNSPECIFIED
);
1519 case (SCM_ISYMNUM (SCM_IM_CALL_WITH_VALUES
)):
1520 ls
= z
= scm_cons (scm_sym_at_call_with_values
, SCM_UNSPECIFIED
);
1523 /* appease the Sun compiler god: */ ;
1527 ls
= z
= unmemocar (scm_cons (unmemocopy (SCM_CAR (x
), env
),
1533 while (SCM_CONSP (x
))
1535 SCM form
= SCM_CAR (x
);
1536 if (!SCM_ISYMP (form
))
1538 SCM copy
= scm_cons (unmemocopy (form
, env
), SCM_UNSPECIFIED
);
1539 SCM_SETCDR (z
, unmemocar (copy
, env
));
1545 #ifdef DEBUG_EXTENSIONS
1546 if (!SCM_FALSEP (p
))
1547 scm_whash_insert (scm_source_whash
, ls
, p
);
1554 scm_unmemocopy (SCM x
, SCM env
)
1556 if (!SCM_NULLP (env
))
1557 /* Make a copy of the lowest frame to protect it from
1558 modifications by SCM_IM_DEFINE */
1559 return unmemocopy (x
, scm_cons (SCM_CAR (env
), SCM_CDR (env
)));
1561 return unmemocopy (x
, env
);
1564 #ifndef SCM_RECKLESS
1567 scm_badargsp (SCM formals
, SCM args
)
1569 while (!SCM_NULLP (formals
))
1571 if (!SCM_CONSP (formals
))
1573 if (SCM_NULLP (args
))
1575 formals
= SCM_CDR (formals
);
1576 args
= SCM_CDR (args
);
1578 return !SCM_NULLP (args
) ? 1 : 0;
1584 scm_badformalsp (SCM closure
, int n
)
1586 SCM formals
= SCM_CLOSURE_FORMALS (closure
);
1587 while (!SCM_NULLP (formals
))
1589 if (!SCM_CONSP (formals
))
1594 formals
= SCM_CDR (formals
);
1601 scm_eval_args (SCM l
, SCM env
, SCM proc
)
1603 SCM results
= SCM_EOL
, *lloc
= &results
, res
;
1604 while (SCM_CONSP (l
))
1606 res
= EVALCAR (l
, env
);
1608 *lloc
= scm_list_1 (res
);
1609 lloc
= SCM_CDRLOC (*lloc
);
1614 scm_wrong_num_args (proc
);
1620 scm_eval_body (SCM code
, SCM env
)
1624 next
= SCM_CDR (code
);
1625 while (!SCM_NULLP (next
))
1627 if (SCM_IMP (SCM_CAR (code
)))
1629 if (SCM_ISYMP (SCM_CAR (code
)))
1631 code
= scm_m_expand_body (code
, env
);
1636 SCM_XEVAL (SCM_CAR (code
), env
);
1638 next
= SCM_CDR (code
);
1640 return SCM_XEVALCAR (code
, env
);
1647 /* SECTION: This code is specific for the debugging support. One
1648 * branch is read when DEVAL isn't defined, the other when DEVAL is
1654 #define SCM_APPLY scm_apply
1655 #define PREP_APPLY(proc, args)
1657 #define RETURN(x) do { return x; } while (0)
1658 #ifdef STACK_CHECKING
1659 #ifndef NO_CEVAL_STACK_CHECKING
1660 #define EVAL_STACK_CHECKING
1667 #define SCM_CEVAL scm_deval /* Substitute all uses of scm_ceval */
1669 #define SCM_APPLY scm_dapply
1671 #define PREP_APPLY(p, l) \
1672 { ++debug.info; debug.info->a.proc = p; debug.info->a.args = l; }
1674 #define ENTER_APPLY \
1676 SCM_SET_ARGSREADY (debug);\
1677 if (CHECK_APPLY && SCM_TRAPS_P)\
1678 if (SCM_APPLY_FRAME_P || (SCM_TRACE_P && PROCTRACEP (proc)))\
1680 SCM tmp, tail = SCM_BOOL(SCM_TRACED_FRAME_P (debug)); \
1681 SCM_SET_TRACED_FRAME (debug); \
1683 if (SCM_CHEAPTRAPS_P)\
1685 tmp = scm_make_debugobj (&debug);\
1686 scm_call_3 (SCM_APPLY_FRAME_HDLR, scm_sym_apply_frame, tmp, tail);\
1691 tmp = scm_make_continuation (&first);\
1693 scm_call_3 (SCM_APPLY_FRAME_HDLR, scm_sym_apply_frame, tmp, tail);\
1699 #define RETURN(e) do { proc = (e); goto exit; } while (0)
1700 #ifdef STACK_CHECKING
1701 #ifndef EVAL_STACK_CHECKING
1702 #define EVAL_STACK_CHECKING
1706 /* scm_ceval_ptr points to the currently selected evaluator.
1707 * *fixme*: Although efficiency is important here, this state variable
1708 * should probably not be a global. It should be related to the
1713 SCM (*scm_ceval_ptr
) (SCM x
, SCM env
);
1715 /* scm_last_debug_frame contains a pointer to the last debugging
1716 * information stack frame. It is accessed very often from the
1717 * debugging evaluator, so it should probably not be indirectly
1718 * addressed. Better to save and restore it from the current root at
1723 scm_t_debug_frame
*scm_last_debug_frame
;
1726 /* scm_debug_eframe_size is the number of slots available for pseudo
1727 * stack frames at each real stack frame.
1730 long scm_debug_eframe_size
;
1732 int scm_debug_mode
, scm_check_entry_p
, scm_check_apply_p
, scm_check_exit_p
;
1734 long scm_eval_stack
;
1736 scm_t_option scm_eval_opts
[] = {
1737 { SCM_OPTION_INTEGER
, "stack", 22000, "Size of thread stacks (in machine words)." }
1740 scm_t_option scm_debug_opts
[] = {
1741 { SCM_OPTION_BOOLEAN
, "cheap", 1,
1742 "*Flyweight representation of the stack at traps." },
1743 { SCM_OPTION_BOOLEAN
, "breakpoints", 0, "*Check for breakpoints." },
1744 { SCM_OPTION_BOOLEAN
, "trace", 0, "*Trace mode." },
1745 { SCM_OPTION_BOOLEAN
, "procnames", 1,
1746 "Record procedure names at definition." },
1747 { SCM_OPTION_BOOLEAN
, "backwards", 0,
1748 "Display backtrace in anti-chronological order." },
1749 { SCM_OPTION_INTEGER
, "width", 79, "Maximal width of backtrace." },
1750 { SCM_OPTION_INTEGER
, "indent", 10, "Maximal indentation in backtrace." },
1751 { SCM_OPTION_INTEGER
, "frames", 3,
1752 "Maximum number of tail-recursive frames in backtrace." },
1753 { SCM_OPTION_INTEGER
, "maxdepth", 1000,
1754 "Maximal number of stored backtrace frames." },
1755 { SCM_OPTION_INTEGER
, "depth", 20, "Maximal length of printed backtrace." },
1756 { SCM_OPTION_BOOLEAN
, "backtrace", 0, "Show backtrace on error." },
1757 { SCM_OPTION_BOOLEAN
, "debug", 0, "Use the debugging evaluator." },
1758 { SCM_OPTION_INTEGER
, "stack", 20000, "Stack size limit (measured in words; 0 = no check)." },
1759 { SCM_OPTION_SCM
, "show-file-name", (unsigned long)SCM_BOOL_T
, "Show file names and line numbers in backtraces when not `#f'. A value of `base' displays only base names, while `#t' displays full names."}
1762 scm_t_option scm_evaluator_trap_table
[] = {
1763 { SCM_OPTION_BOOLEAN
, "traps", 0, "Enable evaluator traps." },
1764 { SCM_OPTION_BOOLEAN
, "enter-frame", 0, "Trap when eval enters new frame." },
1765 { SCM_OPTION_BOOLEAN
, "apply-frame", 0, "Trap when entering apply." },
1766 { SCM_OPTION_BOOLEAN
, "exit-frame", 0, "Trap when exiting eval or apply." },
1767 { SCM_OPTION_SCM
, "enter-frame-handler", (unsigned long)SCM_BOOL_F
, "Handler for enter-frame traps." },
1768 { SCM_OPTION_SCM
, "apply-frame-handler", (unsigned long)SCM_BOOL_F
, "Handler for apply-frame traps." },
1769 { SCM_OPTION_SCM
, "exit-frame-handler", (unsigned long)SCM_BOOL_F
, "Handler for exit-frame traps." }
1772 SCM_DEFINE (scm_eval_options_interface
, "eval-options-interface", 0, 1, 0,
1774 "Option interface for the evaluation options. Instead of using\n"
1775 "this procedure directly, use the procedures @code{eval-enable},\n"
1776 "@code{eval-disable}, @code{eval-set!} and @code{eval-options}.")
1777 #define FUNC_NAME s_scm_eval_options_interface
1781 ans
= scm_options (setting
,
1785 scm_eval_stack
= SCM_EVAL_STACK
* sizeof (void *);
1791 SCM_DEFINE (scm_evaluator_traps
, "evaluator-traps-interface", 0, 1, 0,
1793 "Option interface for the evaluator trap options.")
1794 #define FUNC_NAME s_scm_evaluator_traps
1798 ans
= scm_options (setting
,
1799 scm_evaluator_trap_table
,
1800 SCM_N_EVALUATOR_TRAPS
,
1802 SCM_RESET_DEBUG_MODE
;
1809 deval_args (SCM l
, SCM env
, SCM proc
, SCM
*lloc
)
1811 SCM
*results
= lloc
, res
;
1812 while (SCM_CONSP (l
))
1814 res
= EVALCAR (l
, env
);
1816 *lloc
= scm_list_1 (res
);
1817 lloc
= SCM_CDRLOC (*lloc
);
1822 scm_wrong_num_args (proc
);
1830 /* SECTION: This code is compiled twice.
1834 /* Update the toplevel environment frame ENV so that it refers to the
1835 * current module. */
1836 #define UPDATE_TOPLEVEL_ENV(env) \
1838 SCM p = scm_current_module_lookup_closure (); \
1839 if (p != SCM_CAR(env)) \
1840 env = scm_top_level_env (p); \
1844 /* This is the evaluator. Like any real monster, it has three heads:
1846 * scm_ceval is the non-debugging evaluator, scm_deval is the debugging
1847 * version. Both are implemented using a common code base, using the
1848 * following mechanism: SCM_CEVAL is a macro, which is either defined to
1849 * scm_ceval or scm_deval. Thus, there is no function SCM_CEVAL, but the code
1850 * for SCM_CEVAL actually compiles to either scm_ceval or scm_deval. When
1851 * SCM_CEVAL is defined to scm_ceval, it is known that the macro DEVAL is not
1852 * defined. When SCM_CEVAL is defined to scm_deval, then the macro DEVAL is
1853 * known to be defined. Thus, in SCM_CEVAL parts for the debugging evaluator
1854 * are enclosed within #ifdef DEVAL ... #endif.
1856 * All three (scm_ceval, scm_deval and their common implementation SCM_CEVAL)
1857 * take two input parameters, x and env: x is a single expression to be
1858 * evalutated. env is the environment in which bindings are searched.
1860 * x is known to be a cell (i. e. a pair or any other non-immediate). Since x
1861 * is a single expression, it is necessarily in a tail position. If x is just
1862 * a call to another function like in the expression (foo exp1 exp2 ...), the
1863 * realization of that call therefore _must_not_ increase stack usage (the
1864 * evaluation of exp1, exp2 etc., however, may do so). This is realized by
1865 * making extensive use of 'goto' statements within the evaluator: The gotos
1866 * replace recursive calls to SCM_CEVAL, thus re-using the same stack frame
1867 * that SCM_CEVAL was already using. If, however, x represents some form that
1868 * requires to evaluate a sequence of expressions like (begin exp1 exp2 ...),
1869 * then recursive calls to SCM_CEVAL are performed for all but the last
1870 * expression of that sequence. */
1874 scm_ceval (SCM x
, SCM env
)
1880 scm_deval (SCM x
, SCM env
)
1885 SCM_CEVAL (SCM x
, SCM env
)
1887 SCM proc
, arg1
, arg2
;
1889 scm_t_debug_frame debug
;
1890 scm_t_debug_info
*debug_info_end
;
1891 debug
.prev
= scm_last_debug_frame
;
1894 * The debug.vect contains twice as much scm_t_debug_info frames as the
1895 * user has specified with (debug-set! frames <n>).
1897 * Even frames are eval frames, odd frames are apply frames.
1899 debug
.vect
= (scm_t_debug_info
*) alloca (scm_debug_eframe_size
1900 * sizeof (scm_t_debug_info
));
1901 debug
.info
= debug
.vect
;
1902 debug_info_end
= debug
.vect
+ scm_debug_eframe_size
;
1903 scm_last_debug_frame
= &debug
;
1905 #ifdef EVAL_STACK_CHECKING
1906 if (scm_stack_checking_enabled_p
1907 && SCM_STACK_OVERFLOW_P ((SCM_STACKITEM
*) &proc
))
1910 debug
.info
->e
.exp
= x
;
1911 debug
.info
->e
.env
= env
;
1913 scm_report_stack_overflow ();
1922 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
1925 SCM_CLEAR_ARGSREADY (debug
);
1926 if (SCM_OVERFLOWP (debug
))
1929 * In theory, this should be the only place where it is necessary to
1930 * check for space in debug.vect since both eval frames and
1931 * available space are even.
1933 * For this to be the case, however, it is necessary that primitive
1934 * special forms which jump back to `loop', `begin' or some similar
1935 * label call PREP_APPLY. A convenient way to do this is to jump to
1936 * `loopnoap' or `cdrxnoap'.
1938 else if (++debug
.info
>= debug_info_end
)
1940 SCM_SET_OVERFLOW (debug
);
1945 debug
.info
->e
.exp
= x
;
1946 debug
.info
->e
.env
= env
;
1947 if (CHECK_ENTRY
&& SCM_TRAPS_P
)
1948 if (SCM_ENTER_FRAME_P
|| (SCM_BREAKPOINTS_P
&& SRCBRKP (x
)))
1950 SCM tail
= SCM_BOOL(SCM_TAILRECP (debug
));
1951 SCM_SET_TAILREC (debug
);
1952 if (SCM_CHEAPTRAPS_P
)
1953 arg1
= scm_make_debugobj (&debug
);
1957 SCM val
= scm_make_continuation (&first
);
1967 /* This gives the possibility for the debugger to
1968 modify the source expression before evaluation. */
1973 scm_call_4 (SCM_ENTER_FRAME_HDLR
,
1974 scm_sym_enter_frame
,
1977 scm_unmemocopy (x
, env
));
1981 #if defined (USE_THREADS) || defined (DEVAL)
1985 switch (SCM_TYP7 (x
))
1987 case scm_tc7_symbol
:
1988 /* Only happens when called at top level. */
1989 x
= scm_cons (x
, SCM_UNDEFINED
);
1990 RETURN (*scm_lookupcar (x
, env
, 1));
1992 case SCM_BIT8 (SCM_IM_AND
):
1994 while (!SCM_NULLP (SCM_CDR (x
)))
1996 SCM test_result
= EVALCAR (x
, env
);
1997 if (SCM_FALSEP (test_result
) || SCM_NILP (test_result
))
1998 RETURN (SCM_BOOL_F
);
2002 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
2005 case SCM_BIT8 (SCM_IM_BEGIN
):
2008 RETURN (SCM_UNSPECIFIED
);
2010 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
2013 /* If we are on toplevel with a lookup closure, we need to sync
2014 with the current module. */
2015 if (SCM_CONSP (env
) && !SCM_CONSP (SCM_CAR (env
)))
2017 UPDATE_TOPLEVEL_ENV (env
);
2018 while (!SCM_NULLP (SCM_CDR (x
)))
2021 UPDATE_TOPLEVEL_ENV (env
);
2027 goto nontoplevel_begin
;
2030 while (!SCM_NULLP (SCM_CDR (x
)))
2032 SCM form
= SCM_CAR (x
);
2035 if (SCM_ISYMP (form
))
2037 x
= scm_m_expand_body (x
, env
);
2038 goto nontoplevel_begin
;
2041 SCM_VALIDATE_NON_EMPTY_COMBINATION (form
);
2044 SCM_CEVAL (form
, env
);
2050 /* scm_eval last form in list */
2051 SCM last_form
= SCM_CAR (x
);
2053 if (SCM_CONSP (last_form
))
2055 /* This is by far the most frequent case. */
2057 goto loop
; /* tail recurse */
2059 else if (SCM_IMP (last_form
))
2060 RETURN (SCM_EVALIM (last_form
, env
));
2061 else if (SCM_VARIABLEP (last_form
))
2062 RETURN (SCM_VARIABLE_REF (last_form
));
2063 else if (SCM_SYMBOLP (last_form
))
2064 RETURN (*scm_lookupcar (x
, env
, 1));
2070 case SCM_BIT8 (SCM_IM_CASE
):
2073 SCM key
= EVALCAR (x
, env
);
2075 while (!SCM_NULLP (x
))
2077 SCM clause
= SCM_CAR (x
);
2078 SCM labels
= SCM_CAR (clause
);
2079 if (SCM_EQ_P (labels
, scm_sym_else
))
2081 x
= SCM_CDR (clause
);
2082 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
2085 while (!SCM_NULLP (labels
))
2087 SCM label
= SCM_CAR (labels
);
2088 if (SCM_EQ_P (label
, key
) || !SCM_FALSEP (scm_eqv_p (label
, key
)))
2090 x
= SCM_CDR (clause
);
2091 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
2094 labels
= SCM_CDR (labels
);
2099 RETURN (SCM_UNSPECIFIED
);
2102 case SCM_BIT8 (SCM_IM_COND
):
2104 while (!SCM_NULLP (x
))
2106 SCM clause
= SCM_CAR (x
);
2107 if (SCM_EQ_P (SCM_CAR (clause
), scm_sym_else
))
2109 x
= SCM_CDR (clause
);
2110 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
2115 arg1
= EVALCAR (clause
, env
);
2116 if (!SCM_FALSEP (arg1
) && !SCM_NILP (arg1
))
2118 x
= SCM_CDR (clause
);
2121 else if (!SCM_EQ_P (SCM_CAR (x
), scm_sym_arrow
))
2123 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
2129 proc
= EVALCAR (proc
, env
);
2130 SCM_ASRTGO (!SCM_IMP (proc
), badfun
);
2131 PREP_APPLY (proc
, scm_list_1 (arg1
));
2133 if (SCM_CLOSUREP(proc
) && scm_badformalsp (proc
, 1))
2134 goto umwrongnumargs
;
2142 RETURN (SCM_UNSPECIFIED
);
2145 case SCM_BIT8 (SCM_IM_DO
):
2148 /* Compute the initialization values and the initial environment. */
2149 SCM init_forms
= SCM_CADR (x
);
2150 SCM init_values
= SCM_EOL
;
2151 while (!SCM_NULLP (init_forms
))
2153 init_values
= scm_cons (EVALCAR (init_forms
, env
), init_values
);
2154 init_forms
= SCM_CDR (init_forms
);
2156 env
= EXTEND_ENV (SCM_CAR (x
), init_values
, env
);
2160 SCM test_form
= SCM_CAR (x
);
2161 SCM body_forms
= SCM_CADR (x
);
2162 SCM step_forms
= SCM_CDDR (x
);
2164 SCM test_result
= EVALCAR (test_form
, env
);
2166 while (SCM_FALSEP (test_result
) || SCM_NILP (test_result
))
2169 /* Evaluate body forms. */
2171 for (temp_forms
= body_forms
;
2172 !SCM_NULLP (temp_forms
);
2173 temp_forms
= SCM_CDR (temp_forms
))
2175 SCM form
= SCM_CAR (temp_forms
);
2176 /* Dirk:FIXME: We only need to eval forms, that may have a
2177 * side effect here. This is only true for forms that start
2178 * with a pair. All others are just constants. However,
2179 * since in the common case there is no constant expression
2180 * in a body of a do form, we just check for immediates here
2181 * and have SCM_CEVAL take care of other cases. In the long
2182 * run it would make sense to get rid of this test and have
2183 * the macro transformer of 'do' eliminate all forms that
2184 * have no sideeffect. */
2185 if (!SCM_IMP (form
))
2186 SCM_CEVAL (form
, env
);
2191 /* Evaluate the step expressions. */
2193 SCM step_values
= SCM_EOL
;
2194 for (temp_forms
= step_forms
;
2195 !SCM_NULLP (temp_forms
);
2196 temp_forms
= SCM_CDR (temp_forms
))
2198 SCM value
= EVALCAR (temp_forms
, env
);
2199 step_values
= scm_cons (value
, step_values
);
2201 env
= EXTEND_ENV (SCM_CAAR (env
), step_values
, SCM_CDR (env
));
2204 test_result
= EVALCAR (test_form
, env
);
2209 RETURN (SCM_UNSPECIFIED
);
2210 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
2211 goto nontoplevel_begin
;
2214 case SCM_BIT8 (SCM_IM_IF
):
2217 SCM test_result
= EVALCAR (x
, env
);
2218 if (!SCM_FALSEP (test_result
) && !SCM_NILP (test_result
))
2224 RETURN (SCM_UNSPECIFIED
);
2227 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
2231 case SCM_BIT8 (SCM_IM_LET
):
2234 SCM init_forms
= SCM_CADR (x
);
2235 SCM init_values
= SCM_EOL
;
2238 init_values
= scm_cons (EVALCAR (init_forms
, env
), init_values
);
2239 init_forms
= SCM_CDR (init_forms
);
2241 while (!SCM_NULLP (init_forms
));
2242 env
= EXTEND_ENV (SCM_CAR (x
), init_values
, env
);
2245 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
2246 goto nontoplevel_begin
;
2249 case SCM_BIT8 (SCM_IM_LETREC
):
2251 env
= EXTEND_ENV (SCM_CAR (x
), scm_undefineds
, env
);
2254 SCM init_forms
= SCM_CAR (x
);
2255 SCM init_values
= SCM_EOL
;
2258 init_values
= scm_cons (EVALCAR (init_forms
, env
), init_values
);
2259 init_forms
= SCM_CDR (init_forms
);
2261 while (!SCM_NULLP (init_forms
));
2262 SCM_SETCDR (SCM_CAR (env
), init_values
);
2265 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
2266 goto nontoplevel_begin
;
2269 case SCM_BIT8 (SCM_IM_LETSTAR
):
2272 SCM bindings
= SCM_CAR (x
);
2273 if (SCM_NULLP (bindings
))
2274 env
= EXTEND_ENV (SCM_EOL
, SCM_EOL
, env
);
2279 SCM name
= SCM_CAR (bindings
);
2280 SCM init
= SCM_CDR (bindings
);
2281 env
= EXTEND_ENV (name
, EVALCAR (init
, env
), env
);
2282 bindings
= SCM_CDR (init
);
2284 while (!SCM_NULLP (bindings
));
2288 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
2289 goto nontoplevel_begin
;
2292 case SCM_BIT8 (SCM_IM_OR
):
2294 while (!SCM_NULLP (SCM_CDR (x
)))
2296 SCM val
= EVALCAR (x
, env
);
2297 if (!SCM_FALSEP (val
) && !SCM_NILP (val
))
2302 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
2306 case SCM_BIT8 (SCM_IM_LAMBDA
):
2307 RETURN (scm_closure (SCM_CDR (x
), env
));
2310 case SCM_BIT8 (SCM_IM_QUOTE
):
2311 RETURN (SCM_CADR (x
));
2314 case SCM_BIT8 (SCM_IM_SET_X
):
2318 SCM variable
= SCM_CAR (x
);
2319 #ifdef MEMOIZE_LOCALS
2320 if (SCM_ILOCP (variable
))
2321 location
= scm_ilookup (variable
, env
);
2324 if (SCM_VARIABLEP (variable
))
2325 location
= SCM_VARIABLE_LOC (variable
);
2326 else /* (SCM_SYMBOLP (variable)) is known to be true */
2327 location
= scm_lookupcar (x
, env
, 1);
2329 *location
= EVALCAR (x
, env
);
2331 RETURN (SCM_UNSPECIFIED
);
2334 case SCM_BIT8(SCM_IM_DEFINE
): /* only for internal defines */
2335 scm_misc_error (NULL
, "Bad define placement", SCM_EOL
);
2338 /* new syntactic forms go here. */
2339 case SCM_BIT8 (SCM_MAKISYM (0)):
2341 SCM_ASRTGO (SCM_ISYMP (proc
), badfun
);
2342 switch (SCM_ISYMNUM (proc
))
2346 case (SCM_ISYMNUM (SCM_IM_APPLY
)):
2348 proc
= EVALCAR (proc
, env
);
2349 SCM_ASRTGO (!SCM_IMP (proc
), badfun
);
2350 if (SCM_CLOSUREP (proc
))
2352 PREP_APPLY (proc
, SCM_EOL
);
2353 arg1
= SCM_CDDR (x
);
2354 arg1
= EVALCAR (arg1
, env
);
2356 /* Go here to tail-call a closure. PROC is the closure
2357 and ARG1 is the list of arguments. Do not forget to
2360 SCM formals
= SCM_CLOSURE_FORMALS (proc
);
2362 debug
.info
->a
.args
= arg1
;
2364 #ifndef SCM_RECKLESS
2365 if (scm_badargsp (formals
, arg1
))
2369 /* Copy argument list */
2370 if (SCM_NULL_OR_NIL_P (arg1
))
2371 env
= EXTEND_ENV (formals
, SCM_EOL
, SCM_ENV (proc
));
2374 SCM args
= scm_list_1 (SCM_CAR (arg1
));
2376 arg1
= SCM_CDR (arg1
);
2377 while (!SCM_NULL_OR_NIL_P (arg1
))
2379 SCM new_tail
= scm_list_1 (SCM_CAR (arg1
));
2380 SCM_SETCDR (tail
, new_tail
);
2382 arg1
= SCM_CDR (arg1
);
2384 env
= EXTEND_ENV (formals
, args
, SCM_ENV (proc
));
2387 x
= SCM_CLOSURE_BODY (proc
);
2388 goto nontoplevel_begin
;
2398 case (SCM_ISYMNUM (SCM_IM_CONT
)):
2401 SCM val
= scm_make_continuation (&first
);
2409 proc
= scm_eval_car (proc
, env
);
2410 SCM_ASRTGO (SCM_NIMP (proc
), badfun
);
2411 PREP_APPLY (proc
, scm_list_1 (arg1
));
2413 if (SCM_CLOSUREP(proc
) && scm_badformalsp (proc
, 1))
2414 goto umwrongnumargs
;
2420 case (SCM_ISYMNUM (SCM_IM_DELAY
)):
2421 RETURN (scm_makprom (scm_closure (SCM_CDR (x
), env
)));
2424 case (SCM_ISYMNUM (SCM_IM_DISPATCH
)):
2426 /* If not done yet, evaluate the operand forms. The result is a
2427 * list of arguments stored in arg1, which is used to perform the
2428 * function dispatch. */
2429 SCM operand_forms
= SCM_CADR (x
);
2430 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
2431 if (SCM_ILOCP (operand_forms
))
2432 arg1
= *scm_ilookup (operand_forms
, env
);
2433 else if (SCM_VARIABLEP (operand_forms
))
2434 arg1
= SCM_VARIABLE_REF (operand_forms
);
2435 else if (!SCM_CONSP (operand_forms
))
2436 arg1
= *scm_lookupcar (SCM_CDR (x
), env
, 1);
2439 SCM tail
= arg1
= scm_list_1 (EVALCAR (operand_forms
, env
));
2440 operand_forms
= SCM_CDR (operand_forms
);
2441 while (!SCM_NULLP (operand_forms
))
2443 SCM new_tail
= scm_list_1 (EVALCAR (operand_forms
, env
));
2444 SCM_SETCDR (tail
, new_tail
);
2446 operand_forms
= SCM_CDR (operand_forms
);
2451 /* The type dispatch code is duplicated below
2452 * (c.f. objects.c:scm_mcache_compute_cmethod) since that
2453 * cuts down execution time for type dispatch to 50%. */
2454 type_dispatch
: /* inputs: x, arg1 */
2455 /* Type dispatch means to determine from the types of the function
2456 * arguments (i. e. the 'signature' of the call), which method from
2457 * a generic function is to be called. This process of selecting
2458 * the right method takes some time. To speed it up, guile uses
2459 * caching: Together with the macro call to dispatch the signatures
2460 * of some previous calls to that generic function from the same
2461 * place are stored (in the code!) in a cache that we call the
2462 * 'method cache'. This is done since it is likely, that
2463 * consecutive calls to dispatch from that position in the code will
2464 * have the same signature. Thus, the type dispatch works as
2465 * follows: First, determine a hash value from the signature of the
2466 * actual arguments. Second, use this hash value as an index to
2467 * find that same signature in the method cache stored at this
2468 * position in the code. If found, you have also found the
2469 * corresponding method that belongs to that signature. If the
2470 * signature is not found in the method cache, you have to perform a
2471 * full search over all signatures stored with the generic
2474 unsigned long int specializers
;
2475 unsigned long int hash_value
;
2476 unsigned long int cache_end_pos
;
2477 unsigned long int mask
;
2481 SCM z
= SCM_CDDR (x
);
2482 SCM tmp
= SCM_CADR (z
);
2483 specializers
= SCM_INUM (SCM_CAR (z
));
2485 /* Compute a hash value for searching the method cache. There
2486 * are two variants for computing the hash value, a (rather)
2487 * complicated one, and a simple one. For the complicated one
2488 * explained below, tmp holds a number that is used in the
2490 if (SCM_INUMP (tmp
))
2492 /* Use the signature of the actual arguments to determine
2493 * the hash value. This is done as follows: Each class has
2494 * an array of random numbers, that are determined when the
2495 * class is created. The integer 'hashset' is an index into
2496 * that array of random numbers. Now, from all classes that
2497 * are part of the signature of the actual arguments, the
2498 * random numbers at index 'hashset' are taken and summed
2499 * up, giving the hash value. The value of 'hashset' is
2500 * stored at the call to dispatch. This allows to have
2501 * different 'formulas' for calculating the hash value at
2502 * different places where dispatch is called. This allows
2503 * to optimize the hash formula at every individual place
2504 * where dispatch is called, such that hopefully the hash
2505 * value that is computed will directly point to the right
2506 * method in the method cache. */
2507 unsigned long int hashset
= SCM_INUM (tmp
);
2508 unsigned long int counter
= specializers
+ 1;
2511 while (!SCM_NULLP (tmp_arg
) && counter
!= 0)
2513 SCM
class = scm_class_of (SCM_CAR (tmp_arg
));
2514 hash_value
+= SCM_INSTANCE_HASH (class, hashset
);
2515 tmp_arg
= SCM_CDR (tmp_arg
);
2519 method_cache
= SCM_CADR (z
);
2520 mask
= SCM_INUM (SCM_CAR (z
));
2522 cache_end_pos
= hash_value
;
2526 /* This method of determining the hash value is much
2527 * simpler: Set the hash value to zero and just perform a
2528 * linear search through the method cache. */
2530 mask
= (unsigned long int) ((long) -1);
2532 cache_end_pos
= SCM_VECTOR_LENGTH (method_cache
);
2537 /* Search the method cache for a method with a matching
2538 * signature. Start the search at position 'hash_value'. The
2539 * hashing implementation uses linear probing for conflict
2540 * resolution, that is, if the signature in question is not
2541 * found at the starting index in the hash table, the next table
2542 * entry is tried, and so on, until in the worst case the whole
2543 * cache has been searched, but still the signature has not been
2548 SCM args
= arg1
; /* list of arguments */
2549 z
= SCM_VELTS (method_cache
)[hash_value
];
2550 while (!SCM_NULLP (args
))
2552 /* More arguments than specifiers => CLASS != ENV */
2553 SCM class_of_arg
= scm_class_of (SCM_CAR (args
));
2554 if (!SCM_EQ_P (class_of_arg
, SCM_CAR (z
)))
2556 args
= SCM_CDR (args
);
2559 /* Fewer arguments than specifiers => CAR != ENV */
2560 if (SCM_NULLP (SCM_CAR (z
)) || SCM_CONSP (SCM_CAR (z
)))
2563 hash_value
= (hash_value
+ 1) & mask
;
2564 } while (hash_value
!= cache_end_pos
);
2566 /* No appropriate method was found in the cache. */
2567 z
= scm_memoize_method (x
, arg1
);
2569 apply_cmethod
: /* inputs: z, arg1 */
2571 SCM formals
= SCM_CMETHOD_FORMALS (z
);
2572 env
= EXTEND_ENV (formals
, arg1
, SCM_CMETHOD_ENV (z
));
2573 x
= SCM_CMETHOD_BODY (z
);
2574 goto nontoplevel_begin
;
2580 case (SCM_ISYMNUM (SCM_IM_SLOT_REF
)):
2583 SCM instance
= EVALCAR (x
, env
);
2584 unsigned long int slot
= SCM_INUM (SCM_CADR (x
));
2585 RETURN (SCM_PACK (SCM_STRUCT_DATA (instance
) [slot
]));
2589 case (SCM_ISYMNUM (SCM_IM_SLOT_SET_X
)):
2592 SCM instance
= EVALCAR (x
, env
);
2593 unsigned long int slot
= SCM_INUM (SCM_CADR (x
));
2594 SCM value
= EVALCAR (SCM_CDDR (x
), env
);
2595 SCM_STRUCT_DATA (instance
) [slot
] = SCM_UNPACK (value
);
2596 RETURN (SCM_UNSPECIFIED
);
2600 #ifdef SCM_ENABLE_ELISP
2602 case (SCM_ISYMNUM (SCM_IM_NIL_COND
)):
2604 SCM test_form
= SCM_CDR (x
);
2605 x
= SCM_CDR (test_form
);
2606 while (!SCM_NULL_OR_NIL_P (x
))
2608 SCM test_result
= EVALCAR (test_form
, env
);
2609 if (!(SCM_FALSEP (test_result
)
2610 || SCM_NULL_OR_NIL_P (test_result
)))
2612 if (SCM_EQ_P (SCM_CAR (x
), SCM_UNSPECIFIED
))
2613 RETURN (test_result
);
2614 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
2619 test_form
= SCM_CDR (x
);
2620 x
= SCM_CDR (test_form
);
2624 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
2628 #endif /* SCM_ENABLE_ELISP */
2630 case (SCM_ISYMNUM (SCM_IM_BIND
)):
2632 SCM vars
, exps
, vals
;
2635 vars
= SCM_CAAR (x
);
2636 exps
= SCM_CDAR (x
);
2640 while (SCM_NIMP (exps
))
2642 vals
= scm_cons (EVALCAR (exps
, env
), vals
);
2643 exps
= SCM_CDR (exps
);
2646 scm_swap_bindings (vars
, vals
);
2647 scm_dynwinds
= scm_acons (vars
, vals
, scm_dynwinds
);
2649 /* Ignore all but the last evaluation result. */
2650 for (x
= SCM_CDR (x
); !SCM_NULLP (SCM_CDR (x
)); x
= SCM_CDR (x
))
2652 if (SCM_CONSP (SCM_CAR (x
)))
2653 SCM_CEVAL (SCM_CAR (x
), env
);
2655 proc
= EVALCAR (x
, env
);
2657 scm_dynwinds
= SCM_CDR (scm_dynwinds
);
2658 scm_swap_bindings (vars
, vals
);
2664 case (SCM_ISYMNUM (SCM_IM_CALL_WITH_VALUES
)):
2667 x
= EVALCAR (proc
, env
);
2668 proc
= SCM_CDR (proc
);
2669 proc
= EVALCAR (proc
, env
);
2670 arg1
= SCM_APPLY (x
, SCM_EOL
, SCM_EOL
);
2671 if (SCM_VALUESP (arg1
))
2672 arg1
= scm_struct_ref (arg1
, SCM_INUM0
);
2674 arg1
= scm_list_1 (arg1
);
2675 if (SCM_CLOSUREP (proc
))
2677 PREP_APPLY (proc
, arg1
);
2680 return SCM_APPLY (proc
, arg1
, SCM_EOL
);
2691 scm_misc_error (NULL
, "Wrong type to apply: ~S", scm_list_1 (proc
));
2692 case scm_tc7_vector
:
2696 case scm_tc7_byvect
:
2703 #ifdef HAVE_LONG_LONGS
2704 case scm_tc7_llvect
:
2707 case scm_tc7_string
:
2709 case scm_tcs_closures
:
2713 case scm_tcs_struct
:
2716 case scm_tc7_variable
:
2717 RETURN (SCM_VARIABLE_REF(x
));
2719 #ifdef MEMOIZE_LOCALS
2720 case SCM_BIT8(SCM_ILOC00
):
2721 proc
= *scm_ilookup (SCM_CAR (x
), env
);
2722 SCM_ASRTGO (SCM_NIMP (proc
), badfun
);
2723 #ifndef SCM_RECKLESS
2729 #endif /* ifdef MEMOIZE_LOCALS */
2731 case scm_tcs_cons_nimcar
:
2732 if (SCM_SYMBOLP (SCM_CAR (x
)))
2734 SCM orig_sym
= SCM_CAR (x
);
2737 SCM
*location
= scm_lookupcar1 (x
, env
, 1);
2738 if (location
== NULL
)
2740 /* we have lost the race, start again. */
2746 proc
= *scm_lookupcar (x
, env
, 1);
2751 SCM_SETCAR (x
, orig_sym
); /* Undo memoizing effect of
2755 if (SCM_MACROP (proc
))
2757 SCM_SETCAR (x
, orig_sym
); /* Undo memoizing effect of
2759 handle_a_macro
: /* inputs: x, env, proc */
2761 /* Set a flag during macro expansion so that macro
2762 application frames can be deleted from the backtrace. */
2763 SCM_SET_MACROEXP (debug
);
2765 arg1
= SCM_APPLY (SCM_MACRO_CODE (proc
), x
,
2766 scm_cons (env
, scm_listofnull
));
2769 SCM_CLEAR_MACROEXP (debug
);
2771 switch (SCM_MACRO_TYPE (proc
))
2774 if (scm_ilength (arg1
) <= 0)
2775 arg1
= scm_list_2 (SCM_IM_BEGIN
, arg1
);
2777 if (!SCM_CLOSUREP (SCM_MACRO_CODE (proc
)))
2780 SCM_SETCAR (x
, SCM_CAR (arg1
));
2781 SCM_SETCDR (x
, SCM_CDR (arg1
));
2785 /* Prevent memoizing of debug info expression. */
2786 debug
.info
->e
.exp
= scm_cons_source (debug
.info
->e
.exp
,
2791 SCM_SETCAR (x
, SCM_CAR (arg1
));
2792 SCM_SETCDR (x
, SCM_CDR (arg1
));
2796 if (SCM_NIMP (x
= arg1
))
2804 proc
= SCM_CEVAL (SCM_CAR (x
), env
);
2805 SCM_ASRTGO (!SCM_IMP (proc
), badfun
);
2806 #ifndef SCM_RECKLESS
2810 if (SCM_CLOSUREP (proc
))
2812 SCM formals
= SCM_CLOSURE_FORMALS (proc
);
2813 SCM args
= SCM_CDR (x
);
2814 while (!SCM_NULLP (formals
))
2816 if (!SCM_CONSP (formals
))
2819 goto umwrongnumargs
;
2820 formals
= SCM_CDR (formals
);
2821 args
= SCM_CDR (args
);
2823 if (!SCM_NULLP (args
))
2824 goto umwrongnumargs
;
2826 else if (SCM_MACROP (proc
))
2827 goto handle_a_macro
;
2832 evapply
: /* inputs: x, proc */
2833 PREP_APPLY (proc
, SCM_EOL
);
2834 if (SCM_NULLP (SCM_CDR (x
))) {
2837 switch (SCM_TYP7 (proc
))
2838 { /* no arguments given */
2839 case scm_tc7_subr_0
:
2840 RETURN (SCM_SUBRF (proc
) ());
2841 case scm_tc7_subr_1o
:
2842 RETURN (SCM_SUBRF (proc
) (SCM_UNDEFINED
));
2844 RETURN (SCM_SUBRF (proc
) (SCM_EOL
));
2845 case scm_tc7_rpsubr
:
2846 RETURN (SCM_BOOL_T
);
2848 RETURN (SCM_SUBRF (proc
) (SCM_UNDEFINED
, SCM_UNDEFINED
));
2850 if (!SCM_SMOB_APPLICABLE_P (proc
))
2852 RETURN (SCM_SMOB_APPLY_0 (proc
));
2855 proc
= SCM_CCLO_SUBR (proc
);
2857 debug
.info
->a
.proc
= proc
;
2858 debug
.info
->a
.args
= scm_list_1 (arg1
);
2862 proc
= SCM_PROCEDURE (proc
);
2864 debug
.info
->a
.proc
= proc
;
2866 if (!SCM_CLOSUREP (proc
))
2868 if (scm_badformalsp (proc
, 0))
2869 goto umwrongnumargs
;
2870 case scm_tcs_closures
:
2871 x
= SCM_CLOSURE_BODY (proc
);
2872 env
= EXTEND_ENV (SCM_CLOSURE_FORMALS (proc
), SCM_EOL
, SCM_ENV (proc
));
2873 goto nontoplevel_begin
;
2874 case scm_tcs_struct
:
2875 if (SCM_OBJ_CLASS_FLAGS (proc
) & SCM_CLASSF_PURE_GENERIC
)
2877 x
= SCM_ENTITY_PROCEDURE (proc
);
2881 else if (!SCM_I_OPERATORP (proc
))
2886 proc
= (SCM_I_ENTITYP (proc
)
2887 ? SCM_ENTITY_PROCEDURE (proc
)
2888 : SCM_OPERATOR_PROCEDURE (proc
));
2890 debug
.info
->a
.proc
= proc
;
2891 debug
.info
->a
.args
= scm_list_1 (arg1
);
2893 if (SCM_NIMP (proc
))
2898 case scm_tc7_subr_1
:
2899 case scm_tc7_subr_2
:
2900 case scm_tc7_subr_2o
:
2902 case scm_tc7_subr_3
:
2903 case scm_tc7_lsubr_2
:
2907 scm_wrong_num_args (proc
);
2909 /* handle macros here */
2914 /* must handle macros by here */
2918 arg1
= EVALCAR (x
, env
);
2922 arg1
= EVALCAR (x
, env
);
2925 debug
.info
->a
.args
= scm_list_1 (arg1
);
2932 switch (SCM_TYP7 (proc
))
2933 { /* have one argument in arg1 */
2934 case scm_tc7_subr_2o
:
2935 RETURN (SCM_SUBRF (proc
) (arg1
, SCM_UNDEFINED
));
2936 case scm_tc7_subr_1
:
2937 case scm_tc7_subr_1o
:
2938 RETURN (SCM_SUBRF (proc
) (arg1
));
2940 if (SCM_SUBRF (proc
))
2942 if (SCM_INUMP (arg1
))
2944 RETURN (scm_make_real (SCM_DSUBRF (proc
) ((double) SCM_INUM (arg1
))));
2946 else if (SCM_REALP (arg1
))
2948 RETURN (scm_make_real (SCM_DSUBRF (proc
) (SCM_REAL_VALUE (arg1
))));
2951 else if (SCM_BIGP (arg1
))
2953 RETURN (scm_make_real (SCM_DSUBRF (proc
) (scm_i_big2dbl (arg1
))));
2956 SCM_WTA_DISPATCH_1 (*SCM_SUBR_GENERIC (proc
), arg1
,
2957 SCM_ARG1
, SCM_SYMBOL_CHARS (SCM_SNAME (proc
)));
2959 proc
= SCM_SNAME (proc
);
2961 char *chrs
= SCM_SYMBOL_CHARS (proc
) + SCM_SYMBOL_LENGTH (proc
) - 1;
2962 while ('c' != *--chrs
)
2964 SCM_ASSERT (SCM_CONSP (arg1
),
2965 arg1
, SCM_ARG1
, SCM_SYMBOL_CHARS (proc
));
2966 arg1
= ('a' == *chrs
) ? SCM_CAR (arg1
) : SCM_CDR (arg1
);
2970 case scm_tc7_rpsubr
:
2971 RETURN (SCM_BOOL_T
);
2973 RETURN (SCM_SUBRF (proc
) (arg1
, SCM_UNDEFINED
));
2976 RETURN (SCM_SUBRF (proc
) (debug
.info
->a
.args
));
2978 RETURN (SCM_SUBRF (proc
) (scm_list_1 (arg1
)));
2981 if (!SCM_SMOB_APPLICABLE_P (proc
))
2983 RETURN (SCM_SMOB_APPLY_1 (proc
, arg1
));
2987 proc
= SCM_CCLO_SUBR (proc
);
2989 debug
.info
->a
.args
= scm_cons (arg1
, debug
.info
->a
.args
);
2990 debug
.info
->a
.proc
= proc
;
2994 proc
= SCM_PROCEDURE (proc
);
2996 debug
.info
->a
.proc
= proc
;
2998 if (!SCM_CLOSUREP (proc
))
3000 if (scm_badformalsp (proc
, 1))
3001 goto umwrongnumargs
;
3002 case scm_tcs_closures
:
3004 x
= SCM_CLOSURE_BODY (proc
);
3006 env
= EXTEND_ENV (SCM_CLOSURE_FORMALS (proc
), debug
.info
->a
.args
, SCM_ENV (proc
));
3008 env
= EXTEND_ENV (SCM_CLOSURE_FORMALS (proc
), scm_list_1 (arg1
), SCM_ENV (proc
));
3010 goto nontoplevel_begin
;
3011 case scm_tcs_struct
:
3012 if (SCM_OBJ_CLASS_FLAGS (proc
) & SCM_CLASSF_PURE_GENERIC
)
3014 x
= SCM_ENTITY_PROCEDURE (proc
);
3016 arg1
= debug
.info
->a
.args
;
3018 arg1
= scm_list_1 (arg1
);
3022 else if (!SCM_I_OPERATORP (proc
))
3028 proc
= (SCM_I_ENTITYP (proc
)
3029 ? SCM_ENTITY_PROCEDURE (proc
)
3030 : SCM_OPERATOR_PROCEDURE (proc
));
3032 debug
.info
->a
.args
= scm_cons (arg1
, debug
.info
->a
.args
);
3033 debug
.info
->a
.proc
= proc
;
3035 if (SCM_NIMP (proc
))
3040 case scm_tc7_subr_2
:
3041 case scm_tc7_subr_0
:
3042 case scm_tc7_subr_3
:
3043 case scm_tc7_lsubr_2
:
3052 else if (SCM_CONSP (x
))
3054 if (SCM_IMP (SCM_CAR (x
)))
3055 arg2
= SCM_EVALIM (SCM_CAR (x
), env
);
3057 arg2
= EVALCELLCAR (x
, env
);
3062 arg2
= EVALCAR (x
, env
);
3064 { /* have two or more arguments */
3066 debug
.info
->a
.args
= scm_list_2 (arg1
, arg2
);
3069 if (SCM_NULLP (x
)) {
3072 switch (SCM_TYP7 (proc
))
3073 { /* have two arguments */
3074 case scm_tc7_subr_2
:
3075 case scm_tc7_subr_2o
:
3076 RETURN (SCM_SUBRF (proc
) (arg1
, arg2
));
3079 RETURN (SCM_SUBRF (proc
) (debug
.info
->a
.args
));
3081 RETURN (SCM_SUBRF (proc
) (scm_list_2 (arg1
, arg2
)));
3083 case scm_tc7_lsubr_2
:
3084 RETURN (SCM_SUBRF (proc
) (arg1
, arg2
, SCM_EOL
));
3085 case scm_tc7_rpsubr
:
3087 RETURN (SCM_SUBRF (proc
) (arg1
, arg2
));
3089 if (!SCM_SMOB_APPLICABLE_P (proc
))
3091 RETURN (SCM_SMOB_APPLY_2 (proc
, arg1
, arg2
));
3095 RETURN (SCM_APPLY (SCM_CCLO_SUBR (proc
),
3096 scm_cons (proc
, debug
.info
->a
.args
),
3099 RETURN (SCM_APPLY (SCM_CCLO_SUBR (proc
),
3100 scm_cons2 (proc
, arg1
,
3107 case scm_tcs_struct
:
3108 if (SCM_OBJ_CLASS_FLAGS (proc
) & SCM_CLASSF_PURE_GENERIC
)
3110 x
= SCM_ENTITY_PROCEDURE (proc
);
3112 arg1
= debug
.info
->a
.args
;
3114 arg1
= scm_list_2 (arg1
, arg2
);
3118 else if (!SCM_I_OPERATORP (proc
))
3124 RETURN (SCM_APPLY (SCM_I_ENTITYP (proc
)
3125 ? SCM_ENTITY_PROCEDURE (proc
)
3126 : SCM_OPERATOR_PROCEDURE (proc
),
3127 scm_cons (proc
, debug
.info
->a
.args
),
3130 RETURN (SCM_APPLY (SCM_I_ENTITYP (proc
)
3131 ? SCM_ENTITY_PROCEDURE (proc
)
3132 : SCM_OPERATOR_PROCEDURE (proc
),
3133 scm_cons2 (proc
, arg1
,
3141 case scm_tc7_subr_0
:
3143 case scm_tc7_subr_1o
:
3144 case scm_tc7_subr_1
:
3145 case scm_tc7_subr_3
:
3150 proc
= SCM_PROCEDURE (proc
);
3152 debug
.info
->a
.proc
= proc
;
3154 if (!SCM_CLOSUREP (proc
))
3156 if (scm_badformalsp (proc
, 2))
3157 goto umwrongnumargs
;
3158 case scm_tcs_closures
:
3161 env
= EXTEND_ENV (SCM_CLOSURE_FORMALS (proc
),
3165 env
= EXTEND_ENV (SCM_CLOSURE_FORMALS (proc
),
3166 scm_list_2 (arg1
, arg2
), SCM_ENV (proc
));
3168 x
= SCM_CLOSURE_BODY (proc
);
3169 goto nontoplevel_begin
;
3173 if (SCM_IMP (x
) || !SCM_CONSP (x
))
3177 debug
.info
->a
.args
= scm_cons2 (arg1
, arg2
,
3178 deval_args (x
, env
, proc
, SCM_CDRLOC (SCM_CDR (debug
.info
->a
.args
))));
3182 switch (SCM_TYP7 (proc
))
3183 { /* have 3 or more arguments */
3185 case scm_tc7_subr_3
:
3186 SCM_ASRTGO (SCM_NULLP (SCM_CDR (x
)), wrongnumargs
);
3187 RETURN (SCM_SUBRF (proc
) (arg1
, arg2
,
3188 SCM_CADDR (debug
.info
->a
.args
)));
3190 #ifdef BUILTIN_RPASUBR
3191 arg1
= SCM_SUBRF(proc
)(arg1
, arg2
);
3192 arg2
= SCM_CDDR (debug
.info
->a
.args
);
3195 arg1
= SCM_SUBRF(proc
)(arg1
, SCM_CAR (arg2
));
3196 arg2
= SCM_CDR (arg2
);
3198 while (SCM_NIMP (arg2
));
3200 #endif /* BUILTIN_RPASUBR */
3201 case scm_tc7_rpsubr
:
3202 #ifdef BUILTIN_RPASUBR
3203 if (SCM_FALSEP (SCM_SUBRF (proc
) (arg1
, arg2
)))
3204 RETURN (SCM_BOOL_F
);
3205 arg1
= SCM_CDDR (debug
.info
->a
.args
);
3208 if (SCM_FALSEP (SCM_SUBRF (proc
) (arg2
, SCM_CAR (arg1
))))
3209 RETURN (SCM_BOOL_F
);
3210 arg2
= SCM_CAR (arg1
);
3211 arg1
= SCM_CDR (arg1
);
3213 while (SCM_NIMP (arg1
));
3214 RETURN (SCM_BOOL_T
);
3215 #else /* BUILTIN_RPASUBR */
3216 RETURN (SCM_APPLY (proc
, arg1
,
3218 SCM_CDDR (debug
.info
->a
.args
),
3220 #endif /* BUILTIN_RPASUBR */
3221 case scm_tc7_lsubr_2
:
3222 RETURN (SCM_SUBRF (proc
) (arg1
, arg2
,
3223 SCM_CDDR (debug
.info
->a
.args
)));
3225 RETURN (SCM_SUBRF (proc
) (debug
.info
->a
.args
));
3227 if (!SCM_SMOB_APPLICABLE_P (proc
))
3229 RETURN (SCM_SMOB_APPLY_3 (proc
, arg1
, arg2
,
3230 SCM_CDDR (debug
.info
->a
.args
)));
3234 proc
= SCM_PROCEDURE (proc
);
3235 debug
.info
->a
.proc
= proc
;
3236 if (!SCM_CLOSUREP (proc
))
3238 if (scm_badargsp (SCM_CLOSURE_FORMALS (proc
), debug
.info
->a
.args
))
3239 goto umwrongnumargs
;
3240 case scm_tcs_closures
:
3241 SCM_SET_ARGSREADY (debug
);
3242 env
= EXTEND_ENV (SCM_CLOSURE_FORMALS (proc
),
3245 x
= SCM_CLOSURE_BODY (proc
);
3246 goto nontoplevel_begin
;
3248 case scm_tc7_subr_3
:
3249 SCM_ASRTGO (SCM_NULLP (SCM_CDR (x
)), wrongnumargs
);
3250 RETURN (SCM_SUBRF (proc
) (arg1
, arg2
, EVALCAR (x
, env
)));
3252 #ifdef BUILTIN_RPASUBR
3253 arg1
= SCM_SUBRF (proc
) (arg1
, arg2
);
3256 arg1
= SCM_SUBRF(proc
)(arg1
, EVALCAR(x
, env
));
3259 while (SCM_NIMP (x
));
3261 #endif /* BUILTIN_RPASUBR */
3262 case scm_tc7_rpsubr
:
3263 #ifdef BUILTIN_RPASUBR
3264 if (SCM_FALSEP (SCM_SUBRF (proc
) (arg1
, arg2
)))
3265 RETURN (SCM_BOOL_F
);
3268 arg1
= EVALCAR (x
, env
);
3269 if (SCM_FALSEP (SCM_SUBRF (proc
) (arg2
, arg1
)))
3270 RETURN (SCM_BOOL_F
);
3274 while (SCM_NIMP (x
));
3275 RETURN (SCM_BOOL_T
);
3276 #else /* BUILTIN_RPASUBR */
3277 RETURN (SCM_APPLY (proc
, arg1
,
3279 scm_eval_args (x
, env
, proc
),
3281 #endif /* BUILTIN_RPASUBR */
3282 case scm_tc7_lsubr_2
:
3283 RETURN (SCM_SUBRF (proc
) (arg1
, arg2
, scm_eval_args (x
, env
, proc
)));
3285 RETURN (SCM_SUBRF (proc
) (scm_cons2 (arg1
,
3287 scm_eval_args (x
, env
, proc
))));
3289 if (!SCM_SMOB_APPLICABLE_P (proc
))
3291 RETURN (SCM_SMOB_APPLY_3 (proc
, arg1
, arg2
,
3292 scm_eval_args (x
, env
, proc
)));
3296 proc
= SCM_PROCEDURE (proc
);
3297 if (!SCM_CLOSUREP (proc
))
3300 SCM formals
= SCM_CLOSURE_FORMALS (proc
);
3301 if (SCM_NULLP (formals
)
3302 || (SCM_CONSP (formals
)
3303 && (SCM_NULLP (SCM_CDR (formals
))
3304 || (SCM_CONSP (SCM_CDR (formals
))
3305 && scm_badargsp (SCM_CDDR (formals
), x
)))))
3306 goto umwrongnumargs
;
3308 case scm_tcs_closures
:
3310 SCM_SET_ARGSREADY (debug
);
3312 env
= EXTEND_ENV (SCM_CLOSURE_FORMALS (proc
),
3315 scm_eval_args (x
, env
, proc
)),
3317 x
= SCM_CLOSURE_BODY (proc
);
3318 goto nontoplevel_begin
;
3320 case scm_tcs_struct
:
3321 if (SCM_OBJ_CLASS_FLAGS (proc
) & SCM_CLASSF_PURE_GENERIC
)
3324 arg1
= debug
.info
->a
.args
;
3326 arg1
= scm_cons2 (arg1
, arg2
, scm_eval_args (x
, env
, proc
));
3328 x
= SCM_ENTITY_PROCEDURE (proc
);
3331 else if (!SCM_I_OPERATORP (proc
))
3335 case scm_tc7_subr_2
:
3336 case scm_tc7_subr_1o
:
3337 case scm_tc7_subr_2o
:
3338 case scm_tc7_subr_0
:
3340 case scm_tc7_subr_1
:
3348 if (CHECK_EXIT
&& SCM_TRAPS_P
)
3349 if (SCM_EXIT_FRAME_P
|| (SCM_TRACE_P
&& SCM_TRACED_FRAME_P (debug
)))
3351 SCM_CLEAR_TRACED_FRAME (debug
);
3352 if (SCM_CHEAPTRAPS_P
)
3353 arg1
= scm_make_debugobj (&debug
);
3357 SCM val
= scm_make_continuation (&first
);
3368 scm_call_3 (SCM_EXIT_FRAME_HDLR
, scm_sym_exit_frame
, arg1
, proc
);
3372 scm_last_debug_frame
= debug
.prev
;
3378 /* SECTION: This code is compiled once.
3384 /* Simple procedure calls
3388 scm_call_0 (SCM proc
)
3390 return scm_apply (proc
, SCM_EOL
, SCM_EOL
);
3394 scm_call_1 (SCM proc
, SCM arg1
)
3396 return scm_apply (proc
, arg1
, scm_listofnull
);
3400 scm_call_2 (SCM proc
, SCM arg1
, SCM arg2
)
3402 return scm_apply (proc
, arg1
, scm_cons (arg2
, scm_listofnull
));
3406 scm_call_3 (SCM proc
, SCM arg1
, SCM arg2
, SCM arg3
)
3408 return scm_apply (proc
, arg1
, scm_cons2 (arg2
, arg3
, scm_listofnull
));
3412 scm_call_4 (SCM proc
, SCM arg1
, SCM arg2
, SCM arg3
, SCM arg4
)
3414 return scm_apply (proc
, arg1
, scm_cons2 (arg2
, arg3
,
3415 scm_cons (arg4
, scm_listofnull
)));
3418 /* Simple procedure applies
3422 scm_apply_0 (SCM proc
, SCM args
)
3424 return scm_apply (proc
, args
, SCM_EOL
);
3428 scm_apply_1 (SCM proc
, SCM arg1
, SCM args
)
3430 return scm_apply (proc
, scm_cons (arg1
, args
), SCM_EOL
);
3434 scm_apply_2 (SCM proc
, SCM arg1
, SCM arg2
, SCM args
)
3436 return scm_apply (proc
, scm_cons2 (arg1
, arg2
, args
), SCM_EOL
);
3440 scm_apply_3 (SCM proc
, SCM arg1
, SCM arg2
, SCM arg3
, SCM args
)
3442 return scm_apply (proc
, scm_cons (arg1
, scm_cons2 (arg2
, arg3
, args
)),
3446 /* This code processes the arguments to apply:
3448 (apply PROC ARG1 ... ARGS)
3450 Given a list (ARG1 ... ARGS), this function conses the ARG1
3451 ... arguments onto the front of ARGS, and returns the resulting
3452 list. Note that ARGS is a list; thus, the argument to this
3453 function is a list whose last element is a list.
3455 Apply calls this function, and applies PROC to the elements of the
3456 result. apply:nconc2last takes care of building the list of
3457 arguments, given (ARG1 ... ARGS).
3459 Rather than do new consing, apply:nconc2last destroys its argument.
3460 On that topic, this code came into my care with the following
3461 beautifully cryptic comment on that topic: "This will only screw
3462 you if you do (scm_apply scm_apply '( ... ))" If you know what
3463 they're referring to, send me a patch to this comment. */
3465 SCM_DEFINE (scm_nconc2last
, "apply:nconc2last", 1, 0, 0,
3467 "Given a list (@var{arg1} @dots{} @var{args}), this function\n"
3468 "conses the @var{arg1} @dots{} arguments onto the front of\n"
3469 "@var{args}, and returns the resulting list. Note that\n"
3470 "@var{args} is a list; thus, the argument to this function is\n"
3471 "a list whose last element is a list.\n"
3472 "Note: Rather than do new consing, @code{apply:nconc2last}\n"
3473 "destroys its argument, so use with care.")
3474 #define FUNC_NAME s_scm_nconc2last
3477 SCM_VALIDATE_NONEMPTYLIST (1,lst
);
3479 while (!SCM_NULLP (SCM_CDR (*lloc
))) /* Perhaps should be
3480 SCM_NULL_OR_NIL_P, but not
3481 needed in 99.99% of cases,
3482 and it could seriously hurt
3483 performance. - Neil */
3484 lloc
= SCM_CDRLOC (*lloc
);
3485 SCM_ASSERT (scm_ilength (SCM_CAR (*lloc
)) >= 0, lst
, SCM_ARG1
, FUNC_NAME
);
3486 *lloc
= SCM_CAR (*lloc
);
3494 /* SECTION: When DEVAL is defined this code yields scm_dapply.
3495 * It is compiled twice.
3500 scm_apply (SCM proc
, SCM arg1
, SCM args
)
3506 scm_dapply (SCM proc
, SCM arg1
, SCM args
)
3511 /* Apply a function to a list of arguments.
3513 This function is exported to the Scheme level as taking two
3514 required arguments and a tail argument, as if it were:
3515 (lambda (proc arg1 . args) ...)
3516 Thus, if you just have a list of arguments to pass to a procedure,
3517 pass the list as ARG1, and '() for ARGS. If you have some fixed
3518 args, pass the first as ARG1, then cons any remaining fixed args
3519 onto the front of your argument list, and pass that as ARGS. */
3522 SCM_APPLY (SCM proc
, SCM arg1
, SCM args
)
3524 #ifdef DEBUG_EXTENSIONS
3526 scm_t_debug_frame debug
;
3527 scm_t_debug_info debug_vect_body
;
3528 debug
.prev
= scm_last_debug_frame
;
3529 debug
.status
= SCM_APPLYFRAME
;
3530 debug
.vect
= &debug_vect_body
;
3531 debug
.vect
[0].a
.proc
= proc
;
3532 debug
.vect
[0].a
.args
= SCM_EOL
;
3533 scm_last_debug_frame
= &debug
;
3536 return scm_dapply (proc
, arg1
, args
);
3540 SCM_ASRTGO (SCM_NIMP (proc
), badproc
);
3542 /* If ARGS is the empty list, then we're calling apply with only two
3543 arguments --- ARG1 is the list of arguments for PROC. Whatever
3544 the case, futz with things so that ARG1 is the first argument to
3545 give to PROC (or SCM_UNDEFINED if no args), and ARGS contains the
3548 Setting the debug apply frame args this way is pretty messy.
3549 Perhaps we should store arg1 and args directly in the frame as
3550 received, and let scm_frame_arguments unpack them, because that's
3551 a relatively rare operation. This works for now; if the Guile
3552 developer archives are still around, see Mikael's post of
3554 if (SCM_NULLP (args
))
3556 if (SCM_NULLP (arg1
))
3558 arg1
= SCM_UNDEFINED
;
3560 debug
.vect
[0].a
.args
= SCM_EOL
;
3566 debug
.vect
[0].a
.args
= arg1
;
3568 args
= SCM_CDR (arg1
);
3569 arg1
= SCM_CAR (arg1
);
3574 args
= scm_nconc2last (args
);
3576 debug
.vect
[0].a
.args
= scm_cons (arg1
, args
);
3580 if (SCM_ENTER_FRAME_P
&& SCM_TRAPS_P
)
3583 if (SCM_CHEAPTRAPS_P
)
3584 tmp
= scm_make_debugobj (&debug
);
3589 tmp
= scm_make_continuation (&first
);
3594 scm_call_2 (SCM_ENTER_FRAME_HDLR
, scm_sym_enter_frame
, tmp
);
3601 switch (SCM_TYP7 (proc
))
3603 case scm_tc7_subr_2o
:
3604 args
= SCM_NULLP (args
) ? SCM_UNDEFINED
: SCM_CAR (args
);
3605 RETURN (SCM_SUBRF (proc
) (arg1
, args
));
3606 case scm_tc7_subr_2
:
3607 SCM_ASRTGO (!SCM_NULLP (args
) && SCM_NULLP (SCM_CDR (args
)),
3609 args
= SCM_CAR (args
);
3610 RETURN (SCM_SUBRF (proc
) (arg1
, args
));
3611 case scm_tc7_subr_0
:
3612 SCM_ASRTGO (SCM_UNBNDP (arg1
), wrongnumargs
);
3613 RETURN (SCM_SUBRF (proc
) ());
3614 case scm_tc7_subr_1
:
3615 SCM_ASRTGO (!SCM_UNBNDP (arg1
), wrongnumargs
);
3616 case scm_tc7_subr_1o
:
3617 SCM_ASRTGO (SCM_NULLP (args
), wrongnumargs
);
3618 RETURN (SCM_SUBRF (proc
) (arg1
));
3620 SCM_ASRTGO (!SCM_UNBNDP (arg1
) && SCM_NULLP (args
), wrongnumargs
);
3621 if (SCM_SUBRF (proc
))
3623 if (SCM_INUMP (arg1
))
3625 RETURN (scm_make_real (SCM_DSUBRF (proc
) ((double) SCM_INUM (arg1
))));
3627 else if (SCM_REALP (arg1
))
3629 RETURN (scm_make_real (SCM_DSUBRF (proc
) (SCM_REAL_VALUE (arg1
))));
3632 else if (SCM_BIGP (arg1
))
3633 RETURN (scm_make_real (SCM_DSUBRF (proc
) (scm_i_big2dbl (arg1
))));
3635 SCM_WTA_DISPATCH_1 (*SCM_SUBR_GENERIC (proc
), arg1
,
3636 SCM_ARG1
, SCM_SYMBOL_CHARS (SCM_SNAME (proc
)));
3638 proc
= SCM_SNAME (proc
);
3640 char *chrs
= SCM_SYMBOL_CHARS (proc
) + SCM_SYMBOL_LENGTH (proc
) - 1;
3641 while ('c' != *--chrs
)
3643 SCM_ASSERT (SCM_CONSP (arg1
),
3644 arg1
, SCM_ARG1
, SCM_SYMBOL_CHARS (proc
));
3645 arg1
= ('a' == *chrs
) ? SCM_CAR (arg1
) : SCM_CDR (arg1
);
3649 case scm_tc7_subr_3
:
3650 SCM_ASRTGO (!SCM_NULLP (args
)
3651 && !SCM_NULLP (SCM_CDR (args
))
3652 && SCM_NULLP (SCM_CDDR (args
)),
3654 RETURN (SCM_SUBRF (proc
) (arg1
, SCM_CAR (args
), SCM_CADR (args
)));
3657 RETURN (SCM_SUBRF (proc
) (SCM_UNBNDP (arg1
) ? SCM_EOL
: debug
.vect
[0].a
.args
));
3659 RETURN (SCM_SUBRF (proc
) (SCM_UNBNDP (arg1
) ? SCM_EOL
: scm_cons (arg1
, args
)));
3661 case scm_tc7_lsubr_2
:
3662 SCM_ASRTGO (SCM_CONSP (args
), wrongnumargs
);
3663 RETURN (SCM_SUBRF (proc
) (arg1
, SCM_CAR (args
), SCM_CDR (args
)));
3665 if (SCM_NULLP (args
))
3666 RETURN (SCM_SUBRF (proc
) (arg1
, SCM_UNDEFINED
));
3667 while (SCM_NIMP (args
))
3669 SCM_ASSERT (SCM_CONSP (args
), args
, SCM_ARG2
, "apply");
3670 arg1
= SCM_SUBRF (proc
) (arg1
, SCM_CAR (args
));
3671 args
= SCM_CDR (args
);
3674 case scm_tc7_rpsubr
:
3675 if (SCM_NULLP (args
))
3676 RETURN (SCM_BOOL_T
);
3677 while (SCM_NIMP (args
))
3679 SCM_ASSERT (SCM_CONSP (args
), args
, SCM_ARG2
, "apply");
3680 if (SCM_FALSEP (SCM_SUBRF (proc
) (arg1
, SCM_CAR (args
))))
3681 RETURN (SCM_BOOL_F
);
3682 arg1
= SCM_CAR (args
);
3683 args
= SCM_CDR (args
);
3685 RETURN (SCM_BOOL_T
);
3686 case scm_tcs_closures
:
3688 arg1
= (SCM_UNBNDP (arg1
) ? SCM_EOL
: debug
.vect
[0].a
.args
);
3690 arg1
= (SCM_UNBNDP (arg1
) ? SCM_EOL
: scm_cons (arg1
, args
));
3692 #ifndef SCM_RECKLESS
3693 if (scm_badargsp (SCM_CLOSURE_FORMALS (proc
), arg1
))
3697 /* Copy argument list */
3702 SCM tl
= args
= scm_cons (SCM_CAR (arg1
), SCM_UNSPECIFIED
);
3703 while (arg1
= SCM_CDR (arg1
), SCM_CONSP (arg1
))
3705 SCM_SETCDR (tl
, scm_cons (SCM_CAR (arg1
),
3709 SCM_SETCDR (tl
, arg1
);
3712 args
= EXTEND_ENV (SCM_CLOSURE_FORMALS (proc
), args
, SCM_ENV (proc
));
3713 proc
= SCM_CLOSURE_BODY (proc
);
3716 while (!SCM_NULLP (arg1
= SCM_CDR (arg1
)))
3718 if (SCM_IMP (SCM_CAR (proc
)))
3720 if (SCM_ISYMP (SCM_CAR (proc
)))
3722 proc
= scm_m_expand_body (proc
, args
);
3726 SCM_VALIDATE_NON_EMPTY_COMBINATION (SCM_CAR (proc
));
3729 SCM_CEVAL (SCM_CAR (proc
), args
);
3732 RETURN (EVALCAR (proc
, args
));
3734 if (!SCM_SMOB_APPLICABLE_P (proc
))
3736 if (SCM_UNBNDP (arg1
))
3737 RETURN (SCM_SMOB_APPLY_0 (proc
));
3738 else if (SCM_NULLP (args
))
3739 RETURN (SCM_SMOB_APPLY_1 (proc
, arg1
));
3740 else if (SCM_NULLP (SCM_CDR (args
)))
3741 RETURN (SCM_SMOB_APPLY_2 (proc
, arg1
, SCM_CAR (args
)));
3743 RETURN (SCM_SMOB_APPLY_3 (proc
, arg1
, SCM_CAR (args
), SCM_CDR (args
)));
3746 args
= (SCM_UNBNDP(arg1
) ? SCM_EOL
: debug
.vect
[0].a
.args
);
3748 proc
= SCM_CCLO_SUBR (proc
);
3749 debug
.vect
[0].a
.proc
= proc
;
3750 debug
.vect
[0].a
.args
= scm_cons (arg1
, args
);
3752 args
= (SCM_UNBNDP(arg1
) ? SCM_EOL
: scm_cons (arg1
, args
));
3754 proc
= SCM_CCLO_SUBR (proc
);
3758 proc
= SCM_PROCEDURE (proc
);
3760 debug
.vect
[0].a
.proc
= proc
;
3763 case scm_tcs_struct
:
3764 if (SCM_OBJ_CLASS_FLAGS (proc
) & SCM_CLASSF_PURE_GENERIC
)
3767 args
= (SCM_UNBNDP(arg1
) ? SCM_EOL
: debug
.vect
[0].a
.args
);
3769 args
= (SCM_UNBNDP(arg1
) ? SCM_EOL
: scm_cons (arg1
, args
));
3771 RETURN (scm_apply_generic (proc
, args
));
3773 else if (!SCM_I_OPERATORP (proc
))
3778 args
= (SCM_UNBNDP(arg1
) ? SCM_EOL
: debug
.vect
[0].a
.args
);
3780 args
= (SCM_UNBNDP(arg1
) ? SCM_EOL
: scm_cons (arg1
, args
));
3783 proc
= (SCM_I_ENTITYP (proc
)
3784 ? SCM_ENTITY_PROCEDURE (proc
)
3785 : SCM_OPERATOR_PROCEDURE (proc
));
3787 debug
.vect
[0].a
.proc
= proc
;
3788 debug
.vect
[0].a
.args
= scm_cons (arg1
, args
);
3790 if (SCM_NIMP (proc
))
3796 scm_wrong_num_args (proc
);
3799 scm_wrong_type_arg ("apply", SCM_ARG1
, proc
);
3804 if (CHECK_EXIT
&& SCM_TRAPS_P
)
3805 if (SCM_EXIT_FRAME_P
|| (SCM_TRACE_P
&& SCM_TRACED_FRAME_P (debug
)))
3807 SCM_CLEAR_TRACED_FRAME (debug
);
3808 if (SCM_CHEAPTRAPS_P
)
3809 arg1
= scm_make_debugobj (&debug
);
3813 SCM val
= scm_make_continuation (&first
);
3824 scm_call_3 (SCM_EXIT_FRAME_HDLR
, scm_sym_exit_frame
, arg1
, proc
);
3828 scm_last_debug_frame
= debug
.prev
;
3834 /* SECTION: The rest of this file is only read once.
3839 /* Typechecking for multi-argument MAP and FOR-EACH.
3841 Verify that each element of the vector ARGV, except for the first,
3842 is a proper list whose length is LEN. Attribute errors to WHO,
3843 and claim that the i'th element of ARGV is WHO's i+2'th argument. */
3845 check_map_args (SCM argv
,
3852 SCM
*ve
= SCM_VELTS (argv
);
3855 for (i
= SCM_VECTOR_LENGTH (argv
) - 1; i
>= 1; i
--)
3857 long elt_len
= scm_ilength (ve
[i
]);
3862 scm_apply_generic (gf
, scm_cons (proc
, args
));
3864 scm_wrong_type_arg (who
, i
+ 2, ve
[i
]);
3868 scm_out_of_range (who
, ve
[i
]);
3871 scm_remember_upto_here_1 (argv
);
3875 SCM_GPROC (s_map
, "map", 2, 0, 1, scm_map
, g_map
);
3877 /* Note: Currently, scm_map applies PROC to the argument list(s)
3878 sequentially, starting with the first element(s). This is used in
3879 evalext.c where the Scheme procedure `map-in-order', which guarantees
3880 sequential behaviour, is implemented using scm_map. If the
3881 behaviour changes, we need to update `map-in-order'.
3885 scm_map (SCM proc
, SCM arg1
, SCM args
)
3886 #define FUNC_NAME s_map
3891 SCM
*ve
= &args
; /* Keep args from being optimized away. */
3893 len
= scm_ilength (arg1
);
3894 SCM_GASSERTn (len
>= 0,
3895 g_map
, scm_cons2 (proc
, arg1
, args
), SCM_ARG2
, s_map
);
3896 SCM_VALIDATE_REST_ARGUMENT (args
);
3897 if (SCM_NULLP (args
))
3899 while (SCM_NIMP (arg1
))
3901 *pres
= scm_list_1 (scm_apply (proc
, SCM_CAR (arg1
), scm_listofnull
));
3902 pres
= SCM_CDRLOC (*pres
);
3903 arg1
= SCM_CDR (arg1
);
3907 args
= scm_vector (arg1
= scm_cons (arg1
, args
));
3908 ve
= SCM_VELTS (args
);
3909 #ifndef SCM_RECKLESS
3910 check_map_args (args
, len
, g_map
, proc
, arg1
, s_map
);
3915 for (i
= SCM_VECTOR_LENGTH (args
) - 1; i
>= 0; i
--)
3917 if (SCM_IMP (ve
[i
]))
3919 arg1
= scm_cons (SCM_CAR (ve
[i
]), arg1
);
3920 ve
[i
] = SCM_CDR (ve
[i
]);
3922 *pres
= scm_list_1 (scm_apply (proc
, arg1
, SCM_EOL
));
3923 pres
= SCM_CDRLOC (*pres
);
3929 SCM_GPROC (s_for_each
, "for-each", 2, 0, 1, scm_for_each
, g_for_each
);
3932 scm_for_each (SCM proc
, SCM arg1
, SCM args
)
3933 #define FUNC_NAME s_for_each
3935 SCM
*ve
= &args
; /* Keep args from being optimized away. */
3937 len
= scm_ilength (arg1
);
3938 SCM_GASSERTn (len
>= 0, g_for_each
, scm_cons2 (proc
, arg1
, args
),
3939 SCM_ARG2
, s_for_each
);
3940 SCM_VALIDATE_REST_ARGUMENT (args
);
3941 if (SCM_NULLP (args
))
3943 while (SCM_NIMP (arg1
))
3945 scm_apply (proc
, SCM_CAR (arg1
), scm_listofnull
);
3946 arg1
= SCM_CDR (arg1
);
3948 return SCM_UNSPECIFIED
;
3950 args
= scm_vector (arg1
= scm_cons (arg1
, args
));
3951 ve
= SCM_VELTS (args
);
3952 #ifndef SCM_RECKLESS
3953 check_map_args (args
, len
, g_for_each
, proc
, arg1
, s_for_each
);
3958 for (i
= SCM_VECTOR_LENGTH (args
) - 1; i
>= 0; i
--)
3960 if (SCM_IMP (ve
[i
]))
3961 return SCM_UNSPECIFIED
;
3962 arg1
= scm_cons (SCM_CAR (ve
[i
]), arg1
);
3963 ve
[i
] = SCM_CDR (ve
[i
]);
3965 scm_apply (proc
, arg1
, SCM_EOL
);
3972 scm_closure (SCM code
, SCM env
)
3975 SCM closcar
= scm_cons (code
, SCM_EOL
);
3976 z
= scm_cell (SCM_UNPACK (closcar
) + scm_tc3_closure
, (scm_t_bits
) env
);
3977 scm_remember_upto_here (closcar
);
3982 scm_t_bits scm_tc16_promise
;
3985 scm_makprom (SCM code
)
3987 SCM_RETURN_NEWSMOB (scm_tc16_promise
, SCM_UNPACK (code
));
3993 promise_print (SCM exp
, SCM port
, scm_print_state
*pstate
)
3995 int writingp
= SCM_WRITINGP (pstate
);
3996 scm_puts ("#<promise ", port
);
3997 SCM_SET_WRITINGP (pstate
, 1);
3998 scm_iprin1 (SCM_CELL_OBJECT_1 (exp
), port
, pstate
);
3999 SCM_SET_WRITINGP (pstate
, writingp
);
4000 scm_putc ('>', port
);
4005 SCM_DEFINE (scm_force
, "force", 1, 0, 0,
4007 "If the promise @var{x} has not been computed yet, compute and\n"
4008 "return @var{x}, otherwise just return the previously computed\n"
4010 #define FUNC_NAME s_scm_force
4012 SCM_VALIDATE_SMOB (1, x
, promise
);
4013 if (!((1L << 16) & SCM_CELL_WORD_0 (x
)))
4015 SCM ans
= scm_call_0 (SCM_CELL_OBJECT_1 (x
));
4016 if (!((1L << 16) & SCM_CELL_WORD_0 (x
)))
4019 SCM_SET_CELL_OBJECT_1 (x
, ans
);
4020 SCM_SET_CELL_WORD_0 (x
, SCM_CELL_WORD_0 (x
) | (1L << 16));
4024 return SCM_CELL_OBJECT_1 (x
);
4029 SCM_DEFINE (scm_promise_p
, "promise?", 1, 0, 0,
4031 "Return true if @var{obj} is a promise, i.e. a delayed computation\n"
4032 "(@pxref{Delayed evaluation,,,r5rs.info,The Revised^5 Report on Scheme}).")
4033 #define FUNC_NAME s_scm_promise_p
4035 return SCM_BOOL (SCM_TYP16_PREDICATE (scm_tc16_promise
, obj
));
4040 SCM_DEFINE (scm_cons_source
, "cons-source", 3, 0, 0,
4041 (SCM xorig
, SCM x
, SCM y
),
4042 "Create and return a new pair whose car and cdr are @var{x} and @var{y}.\n"
4043 "Any source properties associated with @var{xorig} are also associated\n"
4044 "with the new pair.")
4045 #define FUNC_NAME s_scm_cons_source
4048 z
= scm_cons (x
, y
);
4049 /* Copy source properties possibly associated with xorig. */
4050 p
= scm_whash_lookup (scm_source_whash
, xorig
);
4052 scm_whash_insert (scm_source_whash
, z
, p
);
4058 SCM_DEFINE (scm_copy_tree
, "copy-tree", 1, 0, 0,
4060 "Recursively copy the data tree that is bound to @var{obj}, and return a\n"
4061 "pointer to the new data structure. @code{copy-tree} recurses down the\n"
4062 "contents of both pairs and vectors (since both cons cells and vector\n"
4063 "cells may point to arbitrary objects), and stops recursing when it hits\n"
4064 "any other object.")
4065 #define FUNC_NAME s_scm_copy_tree
4070 if (SCM_VECTORP (obj
))
4072 unsigned long i
= SCM_VECTOR_LENGTH (obj
);
4073 ans
= scm_c_make_vector (i
, SCM_UNSPECIFIED
);
4075 SCM_VELTS (ans
)[i
] = scm_copy_tree (SCM_VELTS (obj
)[i
]);
4078 if (!SCM_CONSP (obj
))
4080 ans
= tl
= scm_cons_source (obj
,
4081 scm_copy_tree (SCM_CAR (obj
)),
4083 while (obj
= SCM_CDR (obj
), SCM_CONSP (obj
))
4085 SCM_SETCDR (tl
, scm_cons (scm_copy_tree (SCM_CAR (obj
)),
4089 SCM_SETCDR (tl
, obj
);
4095 /* We have three levels of EVAL here:
4097 - scm_i_eval (exp, env)
4099 evaluates EXP in environment ENV. ENV is a lexical environment
4100 structure as used by the actual tree code evaluator. When ENV is
4101 a top-level environment, then changes to the current module are
4102 tracked by updating ENV so that it continues to be in sync with
4105 - scm_primitive_eval (exp)
4107 evaluates EXP in the top-level environment as determined by the
4108 current module. This is done by constructing a suitable
4109 environment and calling scm_i_eval. Thus, changes to the
4110 top-level module are tracked normally.
4112 - scm_eval (exp, mod)
4114 evaluates EXP while MOD is the current module. This is done by
4115 setting the current module to MOD, invoking scm_primitive_eval on
4116 EXP, and then restoring the current module to the value it had
4117 previously. That is, while EXP is evaluated, changes to the
4118 current module are tracked, but these changes do not persist when
4121 For each level of evals, there are two variants, distinguished by a
4122 _x suffix: the ordinary variant does not modify EXP while the _x
4123 variant can destructively modify EXP into something completely
4124 unintelligible. A Scheme data structure passed as EXP to one of the
4125 _x variants should not ever be used again for anything. So when in
4126 doubt, use the ordinary variant.
4131 scm_i_eval_x (SCM exp
, SCM env
)
4133 return SCM_XEVAL (exp
, env
);
4137 scm_i_eval (SCM exp
, SCM env
)
4139 exp
= scm_copy_tree (exp
);
4140 return SCM_XEVAL (exp
, env
);
4144 scm_primitive_eval_x (SCM exp
)
4147 SCM transformer
= scm_current_module_transformer ();
4148 if (SCM_NIMP (transformer
))
4149 exp
= scm_call_1 (transformer
, exp
);
4150 env
= scm_top_level_env (scm_current_module_lookup_closure ());
4151 return scm_i_eval_x (exp
, env
);
4154 SCM_DEFINE (scm_primitive_eval
, "primitive-eval", 1, 0, 0,
4156 "Evaluate @var{exp} in the top-level environment specified by\n"
4157 "the current module.")
4158 #define FUNC_NAME s_scm_primitive_eval
4161 SCM transformer
= scm_current_module_transformer ();
4162 if (SCM_NIMP (transformer
))
4163 exp
= scm_call_1 (transformer
, exp
);
4164 env
= scm_top_level_env (scm_current_module_lookup_closure ());
4165 return scm_i_eval (exp
, env
);
4169 /* Eval does not take the second arg optionally. This is intentional
4170 * in order to be R5RS compatible, and to prepare for the new module
4171 * system, where we would like to make the choice of evaluation
4172 * environment explicit. */
4175 change_environment (void *data
)
4177 SCM pair
= SCM_PACK (data
);
4178 SCM new_module
= SCM_CAR (pair
);
4179 SCM old_module
= scm_current_module ();
4180 SCM_SETCDR (pair
, old_module
);
4181 scm_set_current_module (new_module
);
4186 restore_environment (void *data
)
4188 SCM pair
= SCM_PACK (data
);
4189 SCM old_module
= SCM_CDR (pair
);
4190 SCM new_module
= scm_current_module ();
4191 SCM_SETCAR (pair
, new_module
);
4192 scm_set_current_module (old_module
);
4196 inner_eval_x (void *data
)
4198 return scm_primitive_eval_x (SCM_PACK(data
));
4202 scm_eval_x (SCM exp
, SCM module
)
4203 #define FUNC_NAME "eval!"
4205 SCM_VALIDATE_MODULE (2, module
);
4207 return scm_internal_dynamic_wind
4208 (change_environment
, inner_eval_x
, restore_environment
,
4209 (void *) SCM_UNPACK (exp
),
4210 (void *) SCM_UNPACK (scm_cons (module
, SCM_BOOL_F
)));
4215 inner_eval (void *data
)
4217 return scm_primitive_eval (SCM_PACK(data
));
4220 SCM_DEFINE (scm_eval
, "eval", 2, 0, 0,
4221 (SCM exp
, SCM module
),
4222 "Evaluate @var{exp}, a list representing a Scheme expression,\n"
4223 "in the top-level environment specified by @var{module}.\n"
4224 "While @var{exp} is evaluated (using @code{primitive-eval}),\n"
4225 "@var{module} is made the current module. The current module\n"
4226 "is reset to its previous value when @var{eval} returns.")
4227 #define FUNC_NAME s_scm_eval
4229 SCM_VALIDATE_MODULE (2, module
);
4231 return scm_internal_dynamic_wind
4232 (change_environment
, inner_eval
, restore_environment
,
4233 (void *) SCM_UNPACK (exp
),
4234 (void *) SCM_UNPACK (scm_cons (module
, SCM_BOOL_F
)));
4239 /* At this point, scm_deval and scm_dapply are generated.
4242 #ifdef DEBUG_EXTENSIONS
4252 scm_init_opts (scm_evaluator_traps
,
4253 scm_evaluator_trap_table
,
4254 SCM_N_EVALUATOR_TRAPS
);
4255 scm_init_opts (scm_eval_options_interface
,
4257 SCM_N_EVAL_OPTIONS
);
4259 scm_tc16_promise
= scm_make_smob_type ("promise", 0);
4260 scm_set_smob_mark (scm_tc16_promise
, scm_markcdr
);
4261 scm_set_smob_print (scm_tc16_promise
, promise_print
);
4263 /* Dirk:Fixme:: make scm_undefineds local to eval.c: it's only used here. */
4264 scm_undefineds
= scm_list_1 (SCM_UNDEFINED
);
4265 SCM_SETCDR (scm_undefineds
, scm_undefineds
);
4266 scm_listofnull
= scm_list_1 (SCM_EOL
);
4268 scm_f_apply
= scm_c_define_subr ("apply", scm_tc7_lsubr_2
, scm_apply
);
4273 #include "libguile/eval.x"
4275 scm_add_feature ("delay");