1 /* Copyright (C) 1995,1996,1997,1998,1999,2000,2001 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/values.h"
101 #include "libguile/validate.h"
102 #include "libguile/eval.h"
106 #define SCM_VALIDATE_NON_EMPTY_COMBINATION(x) \
108 if (SCM_EQ_P ((x), SCM_EOL)) \
109 scm_misc_error (NULL, scm_s_expression, SCM_EOL); \
114 /* The evaluator contains a plethora of EVAL symbols.
115 * This is an attempt at explanation.
117 * The following macros should be used in code which is read twice
118 * (where the choice of evaluator is hard soldered):
120 * SCM_CEVAL is the symbol used within one evaluator to call itself.
121 * Originally, it is defined to scm_ceval, but is redefined to
122 * scm_deval during the second pass.
124 * SIDEVAL corresponds to SCM_CEVAL, but is used in situations where
125 * only side effects of expressions matter. All immediates are
128 * SCM_EVALIM is used when it is known that the expression is an
129 * immediate. (This macro never calls an evaluator.)
131 * EVALCAR evaluates the car of an expression.
133 * EVALCELLCAR is like EVALCAR, but is used when it is known that the
134 * car is a lisp cell.
136 * The following macros should be used in code which is read once
137 * (where the choice of evaluator is dynamic):
139 * SCM_XEVAL takes care of immediates without calling an evaluator. It
140 * then calls scm_ceval *or* scm_deval, depending on the debugging
143 * SCM_XEVALCAR corresponds to EVALCAR, but uses scm_ceval *or* scm_deval
144 * depending on the debugging mode.
146 * The main motivation for keeping this plethora is efficiency
147 * together with maintainability (=> locality of code).
150 #define SCM_CEVAL scm_ceval
151 #define SIDEVAL(x, env) if (SCM_NIMP (x)) SCM_CEVAL((x), (env))
153 #define EVALCELLCAR(x, env) (SCM_SYMBOLP (SCM_CAR (x)) \
154 ? *scm_lookupcar (x, env, 1) \
155 : SCM_CEVAL (SCM_CAR (x), env))
157 #define EVALCAR(x, env) (SCM_IMP (SCM_CAR (x)) \
158 ? SCM_EVALIM (SCM_CAR (x), env) \
159 : EVALCELLCAR (x, env))
161 #define EXTEND_ENV SCM_EXTEND_ENV
163 #ifdef MEMOIZE_LOCALS
166 scm_ilookup (SCM iloc
, SCM env
)
168 register long ir
= SCM_IFRAME (iloc
);
169 register SCM er
= env
;
170 for (; 0 != ir
; --ir
)
173 for (ir
= SCM_IDIST (iloc
); 0 != ir
; --ir
)
175 if (SCM_ICDRP (iloc
))
176 return SCM_CDRLOC (er
);
177 return SCM_CARLOC (SCM_CDR (er
));
183 /* The Lookup Car Race
186 Memoization of variables and special forms is done while executing
187 the code for the first time. As long as there is only one thread
188 everything is fine, but as soon as two threads execute the same
189 code concurrently `for the first time' they can come into conflict.
191 This memoization includes rewriting variable references into more
192 efficient forms and expanding macros. Furthermore, macro expansion
193 includes `compiling' special forms like `let', `cond', etc. into
194 tree-code instructions.
196 There shouldn't normally be a problem with memoizing local and
197 global variable references (into ilocs and variables), because all
198 threads will mutate the code in *exactly* the same way and (if I
199 read the C code correctly) it is not possible to observe a half-way
200 mutated cons cell. The lookup procedure can handle this
201 transparently without any critical sections.
203 It is different with macro expansion, because macro expansion
204 happens outside of the lookup procedure and can't be
205 undone. Therefore the lookup procedure can't cope with it. It has
206 to indicate failure when it detects a lost race and hope that the
207 caller can handle it. Luckily, it turns out that this is the case.
209 An example to illustrate this: Suppose that the following form will
210 be memoized concurrently by two threads
214 Let's first examine the lookup of X in the body. The first thread
215 decides that it has to find the symbol "x" in the environment and
216 starts to scan it. Then the other thread takes over and actually
217 overtakes the first. It looks up "x" and substitutes an
218 appropriate iloc for it. Now the first thread continues and
219 completes its lookup. It comes to exactly the same conclusions as
220 the second one and could - without much ado - just overwrite the
221 iloc with the same iloc.
223 But let's see what will happen when the race occurs while looking
224 up the symbol "let" at the start of the form. It could happen that
225 the second thread interrupts the lookup of the first thread and not
226 only substitutes a variable for it but goes right ahead and
227 replaces it with the compiled form (#@let* (x 12) x). Now, when
228 the first thread completes its lookup, it would replace the #@let*
229 with a variable containing the "let" binding, effectively reverting
230 the form to (let (x 12) x). This is wrong. It has to detect that
231 it has lost the race and the evaluator has to reconsider the
232 changed form completely.
234 This race condition could be resolved with some kind of traffic
235 light (like mutexes) around scm_lookupcar, but I think that it is
236 best to avoid them in this case. They would serialize memoization
237 completely and because lookup involves calling arbitrary Scheme
238 code (via the lookup-thunk), threads could be blocked for an
239 arbitrary amount of time or even deadlock. But with the current
240 solution a lot of unnecessary work is potentially done. */
242 /* SCM_LOOKUPCAR1 is was SCM_LOOKUPCAR used to be but is allowed to
243 return NULL to indicate a failed lookup due to some race conditions
244 between threads. This only happens when VLOC is the first cell of
245 a special form that will eventually be memoized (like `let', etc.)
246 In that case the whole lookup is bogus and the caller has to
247 reconsider the complete special form.
249 SCM_LOOKUPCAR is still there, of course. It just calls
250 SCM_LOOKUPCAR1 and aborts on receiving NULL. So SCM_LOOKUPCAR
251 should only be called when it is known that VLOC is not the first
252 pair of a special form. Otherwise, use SCM_LOOKUPCAR1 and check
253 for NULL. I think I've found the only places where this
256 #endif /* USE_THREADS */
258 SCM_SYMBOL (scm_unbound_variable_key
, "unbound-variable");
262 scm_lookupcar1 (SCM vloc
, SCM genv
, int check
)
265 scm_lookupcar (SCM vloc
, SCM genv
, int check
)
269 register SCM
*al
, fl
, var
= SCM_CAR (vloc
);
270 #ifdef MEMOIZE_LOCALS
271 register SCM iloc
= SCM_ILOC00
;
273 for (; SCM_NIMP (env
); env
= SCM_CDR (env
))
275 if (!SCM_CONSP (SCM_CAR (env
)))
277 al
= SCM_CARLOC (env
);
278 for (fl
= SCM_CAR (*al
); SCM_NIMP (fl
); fl
= SCM_CDR (fl
))
282 if (SCM_EQ_P (fl
, var
))
284 #ifdef MEMOIZE_LOCALS
286 if (! SCM_EQ_P (SCM_CAR (vloc
), var
))
289 SCM_SET_CELL_WORD_0 (vloc
, SCM_UNPACK (iloc
) + SCM_ICDR
);
291 return SCM_CDRLOC (*al
);
296 al
= SCM_CDRLOC (*al
);
297 if (SCM_EQ_P (SCM_CAR (fl
), var
))
299 #ifdef MEMOIZE_LOCALS
300 #ifndef SCM_RECKLESS /* letrec inits to SCM_UNDEFINED */
301 if (SCM_UNBNDP (SCM_CAR (*al
)))
308 if (!SCM_EQ_P (SCM_CAR (vloc
), var
))
311 SCM_SETCAR (vloc
, iloc
);
313 return SCM_CARLOC (*al
);
315 #ifdef MEMOIZE_LOCALS
316 iloc
= SCM_PACK (SCM_UNPACK (iloc
) + SCM_IDINC
);
319 #ifdef MEMOIZE_LOCALS
320 iloc
= SCM_PACK ((~SCM_IDSTMSK
) & (SCM_UNPACK(iloc
) + SCM_IFRINC
));
324 SCM top_thunk
, real_var
;
327 top_thunk
= SCM_CAR (env
); /* env now refers to a
328 top level env thunk */
332 top_thunk
= SCM_BOOL_F
;
333 real_var
= scm_sym2var (var
, top_thunk
, SCM_BOOL_F
);
334 if (SCM_FALSEP (real_var
))
338 if (!SCM_NULLP (env
) || SCM_UNBNDP (SCM_VARIABLE_REF (real_var
)))
344 scm_error (scm_unbound_variable_key
, NULL
,
345 "Unbound variable: ~S",
346 scm_list_1 (var
), SCM_BOOL_F
);
348 scm_misc_error (NULL
, "Damaged environment: ~S",
353 /* A variable could not be found, but we shall
354 not throw an error. */
355 static SCM undef_object
= SCM_UNDEFINED
;
356 return &undef_object
;
362 if (!SCM_EQ_P (SCM_CAR (vloc
), var
))
364 /* Some other thread has changed the very cell we are working
365 on. In effect, it must have done our job or messed it up
368 var
= SCM_CAR (vloc
);
369 if (SCM_VARIABLEP (var
))
370 return SCM_VARIABLE_LOC (var
);
371 #ifdef MEMOIZE_LOCALS
372 if (SCM_ITAG7 (var
) == SCM_ITAG7 (SCM_ILOC00
))
373 return scm_ilookup (var
, genv
);
375 /* We can't cope with anything else than variables and ilocs. When
376 a special form has been memoized (i.e. `let' into `#@let') we
377 return NULL and expect the calling function to do the right
378 thing. For the evaluator, this means going back and redoing
379 the dispatch on the car of the form. */
382 #endif /* USE_THREADS */
384 SCM_SETCAR (vloc
, real_var
);
385 return SCM_VARIABLE_LOC (real_var
);
391 scm_lookupcar (SCM vloc
, SCM genv
, int check
)
393 SCM
*loc
= scm_lookupcar1 (vloc
, genv
, check
);
400 #define unmemocar scm_unmemocar
402 SCM_SYMBOL (sym_three_question_marks
, "???");
405 scm_unmemocar (SCM form
, SCM env
)
407 if (!SCM_CONSP (form
))
411 SCM c
= SCM_CAR (form
);
412 if (SCM_VARIABLEP (c
))
414 SCM sym
= scm_module_reverse_lookup (scm_env_module (env
), c
);
415 if (SCM_FALSEP (sym
))
416 sym
= sym_three_question_marks
;
417 SCM_SETCAR (form
, sym
);
419 #ifdef MEMOIZE_LOCALS
420 else if (SCM_ILOCP (c
))
422 unsigned long int ir
;
424 for (ir
= SCM_IFRAME (c
); ir
!= 0; --ir
)
426 env
= SCM_CAAR (env
);
427 for (ir
= SCM_IDIST (c
); ir
!= 0; --ir
)
429 SCM_SETCAR (form
, SCM_ICDRP (c
) ? env
: SCM_CAR (env
));
438 scm_eval_car (SCM pair
, SCM env
)
440 return SCM_XEVALCAR (pair
, env
);
445 * The following rewrite expressions and
446 * some memoized forms have different syntax
449 const char scm_s_expression
[] = "missing or extra expression";
450 const char scm_s_test
[] = "bad test";
451 const char scm_s_body
[] = "bad body";
452 const char scm_s_bindings
[] = "bad bindings";
453 const char scm_s_duplicate_bindings
[] = "duplicate bindings";
454 const char scm_s_variable
[] = "bad variable";
455 const char scm_s_clauses
[] = "bad or missing clauses";
456 const char scm_s_formals
[] = "bad formals";
457 const char scm_s_duplicate_formals
[] = "duplicate formals";
458 static const char s_splicing
[] = "bad (non-list) result for unquote-splicing";
460 SCM_GLOBAL_SYMBOL (scm_sym_dot
, ".");
461 SCM_GLOBAL_SYMBOL (scm_sym_arrow
, "=>");
462 SCM_GLOBAL_SYMBOL (scm_sym_else
, "else");
463 SCM_GLOBAL_SYMBOL (scm_sym_unquote
, "unquote");
464 SCM_GLOBAL_SYMBOL (scm_sym_uq_splicing
, "unquote-splicing");
468 #ifdef DEBUG_EXTENSIONS
469 SCM_GLOBAL_SYMBOL (scm_sym_enter_frame
, "enter-frame");
470 SCM_GLOBAL_SYMBOL (scm_sym_apply_frame
, "apply-frame");
471 SCM_GLOBAL_SYMBOL (scm_sym_exit_frame
, "exit-frame");
472 SCM_GLOBAL_SYMBOL (scm_sym_trace
, "trace");
476 /* Check that the body denoted by XORIG is valid and rewrite it into
477 its internal form. The internal form of a body is just the body
478 itself, but prefixed with an ISYM that denotes to what kind of
479 outer construct this body belongs. A lambda body starts with
480 SCM_IM_LAMBDA, for example, a body of a let starts with SCM_IM_LET,
481 etc. The one exception is a body that belongs to a letrec that has
482 been formed by rewriting internal defines: it starts with
485 /* XXX - Besides controlling the rewriting of internal defines, the
486 additional ISYM could be used for improved error messages.
487 This is not done yet. */
490 scm_m_body (SCM op
, SCM xorig
, const char *what
)
492 SCM_ASSYNT (scm_ilength (xorig
) >= 1, scm_s_body
, what
);
494 /* Don't add another ISYM if one is present already. */
495 if (SCM_ISYMP (SCM_CAR (xorig
)))
498 /* Retain possible doc string. */
499 if (!SCM_CONSP (SCM_CAR (xorig
)))
501 if (!SCM_NULLP (SCM_CDR (xorig
)))
502 return scm_cons (SCM_CAR (xorig
),
503 scm_m_body (op
, SCM_CDR (xorig
), what
));
507 return scm_cons (op
, xorig
);
511 SCM_SYNTAX (s_quote
, "quote", scm_makmmacro
, scm_m_quote
);
512 SCM_GLOBAL_SYMBOL (scm_sym_quote
, s_quote
);
515 scm_m_quote (SCM xorig
, SCM env SCM_UNUSED
)
517 SCM_ASSYNT (scm_ilength (SCM_CDR (xorig
)) == 1, scm_s_expression
, s_quote
);
518 return scm_cons (SCM_IM_QUOTE
, SCM_CDR (xorig
));
522 SCM_SYNTAX (s_begin
, "begin", scm_makmmacro
, scm_m_begin
);
523 SCM_GLOBAL_SYMBOL (scm_sym_begin
, s_begin
);
526 scm_m_begin (SCM xorig
, SCM env SCM_UNUSED
)
528 SCM_ASSYNT (scm_ilength (SCM_CDR (xorig
)) >= 0, scm_s_expression
, s_begin
);
529 return scm_cons (SCM_IM_BEGIN
, SCM_CDR (xorig
));
533 SCM_SYNTAX (s_if
, "if", scm_makmmacro
, scm_m_if
);
534 SCM_GLOBAL_SYMBOL (scm_sym_if
, s_if
);
537 scm_m_if (SCM xorig
, SCM env SCM_UNUSED
)
539 long len
= scm_ilength (SCM_CDR (xorig
));
540 SCM_ASSYNT (len
>= 2 && len
<= 3, scm_s_expression
, "if");
541 return scm_cons (SCM_IM_IF
, SCM_CDR (xorig
));
545 /* Will go into the RnRS module when Guile is factorized.
546 SCM_SYNTAX (scm_s_set_x,"set!", scm_makmmacro, scm_m_set_x); */
547 const char scm_s_set_x
[] = "set!";
548 SCM_GLOBAL_SYMBOL (scm_sym_set_x
, scm_s_set_x
);
551 scm_m_set_x (SCM xorig
, SCM env SCM_UNUSED
)
553 SCM x
= SCM_CDR (xorig
);
554 SCM_ASSYNT (scm_ilength (x
) == 2, scm_s_expression
, scm_s_set_x
);
555 SCM_ASSYNT (SCM_SYMBOLP (SCM_CAR (x
)), scm_s_variable
, scm_s_set_x
);
556 return scm_cons (SCM_IM_SET_X
, x
);
560 SCM_SYNTAX (s_and
, "and", scm_makmmacro
, scm_m_and
);
561 SCM_GLOBAL_SYMBOL (scm_sym_and
, s_and
);
564 scm_m_and (SCM xorig
, SCM env SCM_UNUSED
)
566 long len
= scm_ilength (SCM_CDR (xorig
));
567 SCM_ASSYNT (len
>= 0, scm_s_test
, s_and
);
569 return scm_cons (SCM_IM_AND
, SCM_CDR (xorig
));
575 SCM_SYNTAX (s_or
, "or", scm_makmmacro
, scm_m_or
);
576 SCM_GLOBAL_SYMBOL (scm_sym_or
, s_or
);
579 scm_m_or (SCM xorig
, SCM env SCM_UNUSED
)
581 long len
= scm_ilength (SCM_CDR (xorig
));
582 SCM_ASSYNT (len
>= 0, scm_s_test
, s_or
);
584 return scm_cons (SCM_IM_OR
, SCM_CDR (xorig
));
590 SCM_SYNTAX (s_case
, "case", scm_makmmacro
, scm_m_case
);
591 SCM_GLOBAL_SYMBOL (scm_sym_case
, s_case
);
594 scm_m_case (SCM xorig
, SCM env SCM_UNUSED
)
597 SCM cdrx
= SCM_CDR (xorig
);
598 SCM_ASSYNT (scm_ilength (cdrx
) >= 2, scm_s_clauses
, s_case
);
599 clauses
= SCM_CDR (cdrx
);
600 while (!SCM_NULLP (clauses
))
602 SCM clause
= SCM_CAR (clauses
);
603 SCM_ASSYNT (scm_ilength (clause
) >= 2, scm_s_clauses
, s_case
);
604 SCM_ASSYNT (scm_ilength (SCM_CAR (clause
)) >= 0
605 || (SCM_EQ_P (scm_sym_else
, SCM_CAR (clause
))
606 && SCM_NULLP (SCM_CDR (clauses
))),
607 scm_s_clauses
, s_case
);
608 clauses
= SCM_CDR (clauses
);
610 return scm_cons (SCM_IM_CASE
, cdrx
);
614 SCM_SYNTAX (s_cond
, "cond", scm_makmmacro
, scm_m_cond
);
615 SCM_GLOBAL_SYMBOL (scm_sym_cond
, s_cond
);
618 scm_m_cond (SCM xorig
, SCM env SCM_UNUSED
)
620 SCM cdrx
= SCM_CDR (xorig
);
622 SCM_ASSYNT (scm_ilength (clauses
) >= 1, scm_s_clauses
, s_cond
);
623 while (!SCM_NULLP (clauses
))
625 SCM clause
= SCM_CAR (clauses
);
626 long len
= scm_ilength (clause
);
627 SCM_ASSYNT (len
>= 1, scm_s_clauses
, s_cond
);
628 if (SCM_EQ_P (scm_sym_else
, SCM_CAR (clause
)))
630 int last_clause_p
= SCM_NULLP (SCM_CDR (clauses
));
631 SCM_ASSYNT (len
>= 2 && last_clause_p
, "bad ELSE clause", s_cond
);
633 else if (len
>= 2 && SCM_EQ_P (scm_sym_arrow
, SCM_CADR (clause
)))
635 SCM_ASSYNT (len
> 2, "missing recipient", s_cond
);
636 SCM_ASSYNT (len
== 3, "bad recipient", s_cond
);
638 clauses
= SCM_CDR (clauses
);
640 return scm_cons (SCM_IM_COND
, cdrx
);
644 SCM_SYNTAX (s_lambda
, "lambda", scm_makmmacro
, scm_m_lambda
);
645 SCM_GLOBAL_SYMBOL (scm_sym_lambda
, s_lambda
);
647 /* Return true if OBJ is `eq?' to one of the elements of LIST or to the
648 * cdr of the last cons. (Thus, LIST is not required to be a proper
649 * list and OBJ can also be found in the improper ending.) */
651 scm_c_improper_memq (SCM obj
, SCM list
)
653 for (; SCM_CONSP (list
); list
= SCM_CDR (list
))
655 if (SCM_EQ_P (SCM_CAR (list
), obj
))
658 return SCM_EQ_P (list
, obj
);
662 scm_m_lambda (SCM xorig
, SCM env SCM_UNUSED
)
665 SCM x
= SCM_CDR (xorig
);
667 SCM_ASSYNT (SCM_CONSP (x
), scm_s_formals
, s_lambda
);
669 formals
= SCM_CAR (x
);
670 while (SCM_CONSP (formals
))
672 SCM formal
= SCM_CAR (formals
);
673 SCM_ASSYNT (SCM_SYMBOLP (formal
), scm_s_formals
, s_lambda
);
674 if (scm_c_improper_memq (formal
, SCM_CDR (formals
)))
675 scm_misc_error (s_lambda
, scm_s_duplicate_formals
, SCM_EOL
);
676 formals
= SCM_CDR (formals
);
678 if (!SCM_NULLP (formals
) && !SCM_SYMBOLP (formals
))
679 scm_misc_error (s_lambda
, scm_s_formals
, SCM_EOL
);
681 return scm_cons2 (SCM_IM_LAMBDA
, SCM_CAR (x
),
682 scm_m_body (SCM_IM_LAMBDA
, SCM_CDR (x
), s_lambda
));
686 SCM_SYNTAX (s_letstar
, "let*", scm_makmmacro
, scm_m_letstar
);
687 SCM_GLOBAL_SYMBOL (scm_sym_letstar
, s_letstar
);
689 /* (let* ((v1 i1) (v2 i2) ...) body) with variables v1 .. vk and initializers
690 * i1 .. ik is transformed into the form (#@let* (v1 i1 v2 i2 ...) body*). */
692 scm_m_letstar (SCM xorig
, SCM env SCM_UNUSED
)
695 SCM x
= SCM_CDR (xorig
);
699 SCM_ASSYNT (SCM_CONSP (x
), scm_s_bindings
, s_letstar
);
701 bindings
= SCM_CAR (x
);
702 SCM_ASSYNT (scm_ilength (bindings
) >= 0, scm_s_bindings
, s_letstar
);
703 while (!SCM_NULLP (bindings
))
705 SCM binding
= SCM_CAR (bindings
);
706 SCM_ASSYNT (scm_ilength (binding
) == 2, scm_s_bindings
, s_letstar
);
707 SCM_ASSYNT (SCM_SYMBOLP (SCM_CAR (binding
)), scm_s_variable
, s_letstar
);
708 *varloc
= scm_list_2 (SCM_CAR (binding
), SCM_CADR (binding
));
709 varloc
= SCM_CDRLOC (SCM_CDR (*varloc
));
710 bindings
= SCM_CDR (bindings
);
713 return scm_cons2 (SCM_IM_LETSTAR
, vars
,
714 scm_m_body (SCM_IM_LETSTAR
, SCM_CDR (x
), s_letstar
));
718 /* DO gets the most radically altered syntax. The order of the vars is
719 * reversed here. In contrast, the order of the inits and steps is reversed
720 * during the evaluation:
722 (do ((<var1> <init1> <step1>)
730 (#@do (varn ... var2 var1)
731 (<init1> <init2> ... <initn>)
734 <step1> <step2> ... <stepn>) ;; missing steps replaced by var
737 SCM_SYNTAX(s_do
, "do", scm_makmmacro
, scm_m_do
);
738 SCM_GLOBAL_SYMBOL(scm_sym_do
, s_do
);
741 scm_m_do (SCM xorig
, SCM env SCM_UNUSED
)
744 SCM x
= SCM_CDR (xorig
);
747 SCM
*initloc
= &inits
;
749 SCM
*steploc
= &steps
;
750 SCM_ASSYNT (scm_ilength (x
) >= 2, scm_s_test
, "do");
751 bindings
= SCM_CAR (x
);
752 SCM_ASSYNT (scm_ilength (bindings
) >= 0, scm_s_bindings
, "do");
753 while (!SCM_NULLP (bindings
))
755 SCM binding
= SCM_CAR (bindings
);
756 long len
= scm_ilength (binding
);
757 SCM_ASSYNT (len
== 2 || len
== 3, scm_s_bindings
, "do");
759 SCM name
= SCM_CAR (binding
);
760 SCM init
= SCM_CADR (binding
);
761 SCM step
= (len
== 2) ? name
: SCM_CADDR (binding
);
762 SCM_ASSYNT (SCM_SYMBOLP (name
), scm_s_variable
, "do");
763 vars
= scm_cons (name
, vars
);
764 *initloc
= scm_list_1 (init
);
765 initloc
= SCM_CDRLOC (*initloc
);
766 *steploc
= scm_list_1 (step
);
767 steploc
= SCM_CDRLOC (*steploc
);
768 bindings
= SCM_CDR (bindings
);
772 SCM_ASSYNT (scm_ilength (SCM_CAR (x
)) >= 1, scm_s_test
, "do");
773 x
= scm_cons2 (SCM_CAR (x
), SCM_CDR (x
), steps
);
774 x
= scm_cons2 (vars
, inits
, x
);
775 return scm_cons (SCM_IM_DO
, x
);
779 SCM_SYNTAX (s_quasiquote
, "quasiquote", scm_makacro
, scm_m_quasiquote
);
780 SCM_GLOBAL_SYMBOL (scm_sym_quasiquote
, s_quasiquote
);
782 /* Internal function to handle a quasiquotation: 'form' is the parameter in
783 * the call (quasiquotation form), 'env' is the environment where unquoted
784 * expressions will be evaluated, and 'depth' is the current quasiquotation
785 * nesting level and is known to be greater than zero. */
787 iqq (SCM form
, SCM env
, unsigned long int depth
)
789 if (SCM_CONSP (form
))
791 SCM tmp
= SCM_CAR (form
);
792 if (SCM_EQ_P (tmp
, scm_sym_quasiquote
))
794 SCM args
= SCM_CDR (form
);
795 SCM_ASSYNT (scm_ilength (args
) == 1, scm_s_expression
, s_quasiquote
);
796 return scm_list_2 (tmp
, iqq (SCM_CAR (args
), env
, depth
+ 1));
798 else if (SCM_EQ_P (tmp
, scm_sym_unquote
))
800 SCM args
= SCM_CDR (form
);
801 SCM_ASSYNT (scm_ilength (args
) == 1, scm_s_expression
, s_quasiquote
);
803 return scm_eval_car (args
, env
);
805 return scm_list_2 (tmp
, iqq (SCM_CAR (args
), env
, depth
- 1));
807 else if (SCM_CONSP (tmp
)
808 && SCM_EQ_P (SCM_CAR (tmp
), scm_sym_uq_splicing
))
810 SCM args
= SCM_CDR (tmp
);
811 SCM_ASSYNT (scm_ilength (args
) == 1, scm_s_expression
, s_quasiquote
);
814 SCM list
= scm_eval_car (args
, env
);
815 SCM rest
= SCM_CDR (form
);
816 SCM_ASSYNT (scm_ilength (list
) >= 0, s_splicing
, s_quasiquote
);
817 return scm_append (scm_list_2 (list
, iqq (rest
, env
, depth
)));
820 return scm_cons (iqq (SCM_CAR (form
), env
, depth
- 1),
821 iqq (SCM_CDR (form
), env
, depth
));
824 return scm_cons (iqq (SCM_CAR (form
), env
, depth
),
825 iqq (SCM_CDR (form
), env
, depth
));
827 else if (SCM_VECTORP (form
))
829 size_t i
= SCM_VECTOR_LENGTH (form
);
830 SCM
*data
= SCM_VELTS (form
);
833 tmp
= scm_cons (data
[--i
], tmp
);
834 scm_remember_upto_here_1 (form
);
835 return scm_vector (iqq (tmp
, env
, depth
));
842 scm_m_quasiquote (SCM xorig
, SCM env
)
844 SCM x
= SCM_CDR (xorig
);
845 SCM_ASSYNT (scm_ilength (x
) == 1, scm_s_expression
, s_quasiquote
);
846 return iqq (SCM_CAR (x
), env
, 1);
850 SCM_SYNTAX (s_delay
, "delay", scm_makmmacro
, scm_m_delay
);
851 SCM_GLOBAL_SYMBOL (scm_sym_delay
, s_delay
);
853 /* Promises are implemented as closures with an empty parameter list. Thus,
854 * (delay <expression>) is transformed into (#@delay '() <expression>), where
855 * the empty list represents the empty parameter list. This representation
856 * allows for easy creation of the closure during evaluation. */
858 scm_m_delay (SCM xorig
, SCM env SCM_UNUSED
)
860 SCM_ASSYNT (scm_ilength (xorig
) == 2, scm_s_expression
, s_delay
);
861 return scm_cons2 (SCM_IM_DELAY
, SCM_EOL
, SCM_CDR (xorig
));
865 SCM_SYNTAX(s_define
, "define", scm_makmmacro
, scm_m_define
);
866 SCM_GLOBAL_SYMBOL(scm_sym_define
, s_define
);
868 /* Guile provides an extension to R5RS' define syntax to represent function
869 * currying in a compact way. With this extension, it is allowed to write
870 * (define <nested-variable> <body>), where <nested-variable> has of one of
871 * the forms (<nested-variable> <formals>), (<nested-variable> . <formal>),
872 * (<variable> <formals>) or (<variable> . <formal>). As in R5RS, <formals>
873 * should be either a sequence of zero or more variables, or a sequence of one
874 * or more variables followed by a space-delimited period and another
875 * variable. Each level of argument nesting wraps the <body> within another
876 * lambda expression. For example, the following forms are allowed, each one
877 * followed by an equivalent, more explicit implementation.
879 * (define ((a b . c) . d) <body>) is equivalent to
880 * (define a (lambda (b . c) (lambda d <body>)))
882 * (define (((a) b) c . d) <body>) is equivalent to
883 * (define a (lambda () (lambda (b) (lambda (c . d) <body>))))
885 /* Dirk:FIXME:: We should provide an implementation for 'define' in the R5RS
886 * module that does not implement this extension. */
888 scm_m_define (SCM x
, SCM env
)
892 SCM_ASSYNT (scm_ilength (x
) >= 2, scm_s_expression
, s_define
);
895 while (SCM_CONSP (name
))
897 /* This while loop realizes function currying by variable nesting. */
898 SCM formals
= SCM_CDR (name
);
899 x
= scm_list_1 (scm_cons2 (scm_sym_lambda
, formals
, x
));
900 name
= SCM_CAR (name
);
902 SCM_ASSYNT (SCM_SYMBOLP (name
), scm_s_variable
, s_define
);
903 SCM_ASSYNT (scm_ilength (x
) == 1, scm_s_expression
, s_define
);
904 if (SCM_TOP_LEVEL (env
))
907 x
= scm_eval_car (x
, env
);
908 if (SCM_REC_PROCNAMES_P
)
911 while (SCM_MACROP (tmp
))
912 tmp
= SCM_MACRO_CODE (tmp
);
913 if (SCM_CLOSUREP (tmp
)
914 /* Only the first definition determines the name. */
915 && SCM_FALSEP (scm_procedure_property (tmp
, scm_sym_name
)))
916 scm_set_procedure_property_x (tmp
, scm_sym_name
, name
);
918 var
= scm_sym2var (name
, scm_env_top_level (env
), SCM_BOOL_T
);
919 SCM_VARIABLE_SET (var
, x
);
920 return SCM_UNSPECIFIED
;
923 return scm_cons2 (SCM_IM_DEFINE
, name
, x
);
927 /* The bindings ((v1 i1) (v2 i2) ... (vn in)) are transformed to the lists
928 * (vn ... v2 v1) and (i1 i2 ... in). That is, the list of variables is
929 * reversed here, the list of inits gets reversed during evaluation. */
931 transform_bindings (SCM bindings
, SCM
*rvarloc
, SCM
*initloc
, const char *what
)
937 SCM_ASSYNT (scm_ilength (bindings
) >= 1, scm_s_bindings
, what
);
941 SCM binding
= SCM_CAR (bindings
);
942 SCM_ASSYNT (scm_ilength (binding
) == 2, scm_s_bindings
, what
);
943 SCM_ASSYNT (SCM_SYMBOLP (SCM_CAR (binding
)), scm_s_variable
, what
);
944 if (scm_c_improper_memq (SCM_CAR (binding
), rvars
))
945 scm_misc_error (what
, scm_s_duplicate_bindings
, SCM_EOL
);
946 rvars
= scm_cons (SCM_CAR (binding
), rvars
);
947 *initloc
= scm_list_1 (SCM_CADR (binding
));
948 initloc
= SCM_CDRLOC (*initloc
);
949 bindings
= SCM_CDR (bindings
);
951 while (!SCM_NULLP (bindings
));
957 SCM_SYNTAX(s_letrec
, "letrec", scm_makmmacro
, scm_m_letrec
);
958 SCM_GLOBAL_SYMBOL(scm_sym_letrec
, s_letrec
);
961 scm_m_letrec (SCM xorig
, SCM env
)
963 SCM x
= SCM_CDR (xorig
);
964 SCM_ASSYNT (SCM_CONSP (x
), scm_s_bindings
, s_letrec
);
966 if (SCM_NULLP (SCM_CAR (x
)))
968 /* null binding, let* faster */
969 SCM body
= scm_m_body (SCM_IM_LETREC
, SCM_CDR (x
), s_letrec
);
970 return scm_m_letstar (scm_cons2 (SCM_CAR (xorig
), SCM_EOL
, body
), env
);
974 SCM rvars
, inits
, body
;
975 transform_bindings (SCM_CAR (x
), &rvars
, &inits
, "letrec");
976 body
= scm_m_body (SCM_IM_LETREC
, SCM_CDR (x
), "letrec");
977 return scm_cons2 (SCM_IM_LETREC
, rvars
, scm_cons (inits
, body
));
982 SCM_SYNTAX(s_let
, "let", scm_makmmacro
, scm_m_let
);
983 SCM_GLOBAL_SYMBOL(scm_sym_let
, s_let
);
986 scm_m_let (SCM xorig
, SCM env
)
988 SCM x
= SCM_CDR (xorig
);
991 SCM_ASSYNT (SCM_CONSP (x
), scm_s_bindings
, s_let
);
994 || (scm_ilength (temp
) == 1 && SCM_CONSP (SCM_CAR (temp
))))
996 /* null or single binding, let* is faster */
998 SCM body
= scm_m_body (SCM_IM_LET
, SCM_CDR (x
), s_let
);
999 return scm_m_letstar (scm_cons2 (SCM_CAR (xorig
), bindings
, body
), env
);
1001 else if (SCM_CONSP (temp
))
1004 SCM bindings
= temp
;
1005 SCM rvars
, inits
, body
;
1006 transform_bindings (bindings
, &rvars
, &inits
, "let");
1007 body
= scm_m_body (SCM_IM_LET
, SCM_CDR (x
), "let");
1008 return scm_cons2 (SCM_IM_LET
, rvars
, scm_cons (inits
, body
));
1012 /* named let: Transform (let name ((var init) ...) body ...) into
1013 * ((letrec ((name (lambda (var ...) body ...))) name) init ...) */
1017 SCM
*varloc
= &vars
;
1018 SCM inits
= SCM_EOL
;
1019 SCM
*initloc
= &inits
;
1022 SCM_ASSYNT (SCM_SYMBOLP (name
), scm_s_bindings
, s_let
);
1024 SCM_ASSYNT (SCM_CONSP (x
), scm_s_bindings
, s_let
);
1025 bindings
= SCM_CAR (x
);
1026 SCM_ASSYNT (scm_ilength (bindings
) >= 0, scm_s_bindings
, s_let
);
1027 while (!SCM_NULLP (bindings
))
1028 { /* vars and inits both in order */
1029 SCM binding
= SCM_CAR (bindings
);
1030 SCM_ASSYNT (scm_ilength (binding
) == 2, scm_s_bindings
, s_let
);
1031 SCM_ASSYNT (SCM_SYMBOLP (SCM_CAR (binding
)), scm_s_variable
, s_let
);
1032 *varloc
= scm_list_1 (SCM_CAR (binding
));
1033 varloc
= SCM_CDRLOC (*varloc
);
1034 *initloc
= scm_list_1 (SCM_CADR (binding
));
1035 initloc
= SCM_CDRLOC (*initloc
);
1036 bindings
= SCM_CDR (bindings
);
1040 SCM lambda_body
= scm_m_body (SCM_IM_LET
, SCM_CDR (x
), "let");
1041 SCM lambda_form
= scm_cons2 (scm_sym_lambda
, vars
, lambda_body
);
1042 SCM rvar
= scm_list_1 (name
);
1043 SCM init
= scm_list_1 (lambda_form
);
1044 SCM body
= scm_m_body (SCM_IM_LET
, scm_list_1 (name
), "let");
1045 SCM letrec
= scm_cons2 (SCM_IM_LETREC
, rvar
, scm_cons (init
, body
));
1046 return scm_cons (letrec
, inits
);
1052 SCM_SYNTAX (s_atapply
,"@apply", scm_makmmacro
, scm_m_apply
);
1053 SCM_GLOBAL_SYMBOL (scm_sym_atapply
, s_atapply
);
1054 SCM_GLOBAL_SYMBOL (scm_sym_apply
, s_atapply
+ 1);
1057 scm_m_apply (SCM xorig
, SCM env SCM_UNUSED
)
1059 SCM_ASSYNT (scm_ilength (SCM_CDR (xorig
)) == 2, scm_s_expression
, s_atapply
);
1060 return scm_cons (SCM_IM_APPLY
, SCM_CDR (xorig
));
1064 SCM_SYNTAX(s_atcall_cc
,"@call-with-current-continuation", scm_makmmacro
, scm_m_cont
);
1065 SCM_GLOBAL_SYMBOL(scm_sym_atcall_cc
,s_atcall_cc
);
1069 scm_m_cont (SCM xorig
, SCM env SCM_UNUSED
)
1071 SCM_ASSYNT (scm_ilength (SCM_CDR (xorig
)) == 1,
1072 scm_s_expression
, s_atcall_cc
);
1073 return scm_cons (SCM_IM_CONT
, SCM_CDR (xorig
));
1076 /* Multi-language support */
1078 SCM_GLOBAL_SYMBOL (scm_lisp_nil
, "nil");
1079 SCM_GLOBAL_SYMBOL (scm_lisp_t
, "t");
1081 SCM_SYNTAX (s_nil_cond
, "nil-cond", scm_makmmacro
, scm_m_nil_cond
);
1084 scm_m_nil_cond (SCM xorig
, SCM env SCM_UNUSED
)
1086 long len
= scm_ilength (SCM_CDR (xorig
));
1087 SCM_ASSYNT (len
>= 1 && (len
& 1) == 1, scm_s_expression
, "nil-cond");
1088 return scm_cons (SCM_IM_NIL_COND
, SCM_CDR (xorig
));
1091 SCM_SYNTAX (s_nil_ify
, "nil-ify", scm_makmmacro
, scm_m_nil_ify
);
1094 scm_m_nil_ify (SCM xorig
, SCM env SCM_UNUSED
)
1096 SCM_ASSYNT (scm_ilength (SCM_CDR (xorig
)) == 1, scm_s_expression
, "nil-ify");
1097 return scm_cons (SCM_IM_NIL_IFY
, SCM_CDR (xorig
));
1100 SCM_SYNTAX (s_t_ify
, "t-ify", scm_makmmacro
, scm_m_t_ify
);
1103 scm_m_t_ify (SCM xorig
, SCM env SCM_UNUSED
)
1105 SCM_ASSYNT (scm_ilength (SCM_CDR (xorig
)) == 1, scm_s_expression
, "t-ify");
1106 return scm_cons (SCM_IM_T_IFY
, SCM_CDR (xorig
));
1109 SCM_SYNTAX (s_0_cond
, "0-cond", scm_makmmacro
, scm_m_0_cond
);
1112 scm_m_0_cond (SCM xorig
, SCM env SCM_UNUSED
)
1114 long len
= scm_ilength (SCM_CDR (xorig
));
1115 SCM_ASSYNT (len
>= 1 && (len
& 1) == 1, scm_s_expression
, "0-cond");
1116 return scm_cons (SCM_IM_0_COND
, SCM_CDR (xorig
));
1119 SCM_SYNTAX (s_0_ify
, "0-ify", scm_makmmacro
, scm_m_0_ify
);
1122 scm_m_0_ify (SCM xorig
, SCM env SCM_UNUSED
)
1124 SCM_ASSYNT (scm_ilength (SCM_CDR (xorig
)) == 1, scm_s_expression
, "0-ify");
1125 return scm_cons (SCM_IM_0_IFY
, SCM_CDR (xorig
));
1128 SCM_SYNTAX (s_1_ify
, "1-ify", scm_makmmacro
, scm_m_1_ify
);
1131 scm_m_1_ify (SCM xorig
, SCM env SCM_UNUSED
)
1133 SCM_ASSYNT (scm_ilength (SCM_CDR (xorig
)) == 1, scm_s_expression
, "1-ify");
1134 return scm_cons (SCM_IM_1_IFY
, SCM_CDR (xorig
));
1137 SCM_SYNTAX (s_atfop
, "@fop", scm_makmmacro
, scm_m_atfop
);
1140 scm_m_atfop (SCM xorig
, SCM env SCM_UNUSED
)
1142 SCM x
= SCM_CDR (xorig
), var
;
1143 SCM_ASSYNT (scm_ilength (x
) >= 1, scm_s_expression
, "@fop");
1144 var
= scm_symbol_fref (SCM_CAR (x
));
1145 SCM_ASSYNT (SCM_VARIABLEP (var
),
1146 "Symbol's function definition is void", NULL
);
1147 SCM_SETCAR (x
, var
);
1151 /* (@bind ((var exp) ...) body ...)
1153 This will assign the values of the `exp's to the global variables
1154 named by `var's (symbols, not evaluated), creating them if they
1155 don't exist, executes body, and then restores the previous values of
1156 the `var's. Additionally, whenever control leaves body, the values
1157 of the `var's are saved and restored when control returns. It is an
1158 error when a symbol appears more than once among the `var's.
1159 All `exp's are evaluated before any `var' is set.
1161 This of this as `let' for dynamic scope.
1163 It is memoized into (#@bind ((var ...) . (reversed-val ...)) body ...).
1165 XXX - also implement `@bind*'.
1168 SCM_SYNTAX (s_atbind
, "@bind", scm_makmmacro
, scm_m_atbind
);
1171 scm_m_atbind (SCM xorig
, SCM env
)
1173 SCM x
= SCM_CDR (xorig
);
1174 SCM top_level
= scm_env_top_level (env
);
1175 SCM vars
= SCM_EOL
, var
;
1178 SCM_ASSYNT (scm_ilength (x
) > 1, scm_s_expression
, s_atbind
);
1181 while (SCM_NIMP (x
))
1184 SCM sym_exp
= SCM_CAR (x
);
1185 SCM_ASSYNT (scm_ilength (sym_exp
) == 2, scm_s_bindings
, s_atbind
);
1186 SCM_ASSYNT (SCM_SYMBOLP (SCM_CAR (sym_exp
)), scm_s_bindings
, s_atbind
);
1188 for (rest
= x
; SCM_NIMP (rest
); rest
= SCM_CDR (rest
))
1189 if (SCM_EQ_P (SCM_CAR (sym_exp
), SCM_CAAR (rest
)))
1190 scm_misc_error (s_atbind
, scm_s_duplicate_bindings
, SCM_EOL
);
1191 /* The first call to scm_sym2var will look beyond the current
1192 module, while the second call wont. */
1193 var
= scm_sym2var (SCM_CAR (sym_exp
), top_level
, SCM_BOOL_F
);
1194 if (SCM_FALSEP (var
))
1195 var
= scm_sym2var (SCM_CAR (sym_exp
), top_level
, SCM_BOOL_T
);
1196 vars
= scm_cons (var
, vars
);
1197 exps
= scm_cons (SCM_CADR (sym_exp
), exps
);
1199 return scm_cons (SCM_IM_BIND
,
1200 scm_cons (scm_cons (scm_reverse_x (vars
, SCM_EOL
), exps
),
1204 SCM_SYNTAX (s_at_call_with_values
, "@call-with-values", scm_makmmacro
, scm_m_at_call_with_values
);
1205 SCM_GLOBAL_SYMBOL(scm_sym_at_call_with_values
, s_at_call_with_values
);
1208 scm_m_at_call_with_values (SCM xorig
, SCM env SCM_UNUSED
)
1210 SCM_ASSYNT (scm_ilength (SCM_CDR (xorig
)) == 2,
1211 scm_s_expression
, s_at_call_with_values
);
1212 return scm_cons (SCM_IM_CALL_WITH_VALUES
, SCM_CDR (xorig
));
1216 scm_m_expand_body (SCM xorig
, SCM env
)
1218 SCM x
= SCM_CDR (xorig
), defs
= SCM_EOL
;
1219 char *what
= SCM_ISYMCHARS (SCM_CAR (xorig
)) + 2;
1221 while (SCM_NIMP (x
))
1223 SCM form
= SCM_CAR (x
);
1224 if (!SCM_CONSP (form
))
1226 if (!SCM_SYMBOLP (SCM_CAR (form
)))
1229 form
= scm_macroexp (scm_cons_source (form
,
1234 if (SCM_EQ_P (SCM_IM_DEFINE
, SCM_CAR (form
)))
1236 defs
= scm_cons (SCM_CDR (form
), defs
);
1239 else if (!SCM_IMP (defs
))
1243 else if (SCM_EQ_P (SCM_IM_BEGIN
, SCM_CAR (form
)))
1245 x
= scm_append (scm_list_2 (SCM_CDR (form
), SCM_CDR (x
)));
1249 x
= scm_cons (form
, SCM_CDR (x
));
1254 if (!SCM_NULLP (defs
))
1256 SCM rvars
, inits
, body
, letrec
;
1257 transform_bindings (defs
, &rvars
, &inits
, what
);
1258 body
= scm_m_body (SCM_IM_DEFINE
, x
, what
);
1259 letrec
= scm_cons2 (SCM_IM_LETREC
, rvars
, scm_cons (inits
, body
));
1260 SCM_SETCAR (xorig
, letrec
);
1261 SCM_SETCDR (xorig
, SCM_EOL
);
1265 SCM_ASSYNT (SCM_CONSP (x
), scm_s_body
, what
);
1266 SCM_SETCAR (xorig
, SCM_CAR (x
));
1267 SCM_SETCDR (xorig
, SCM_CDR (x
));
1274 scm_macroexp (SCM x
, SCM env
)
1276 SCM res
, proc
, orig_sym
;
1278 /* Don't bother to produce error messages here. We get them when we
1279 eventually execute the code for real. */
1282 orig_sym
= SCM_CAR (x
);
1283 if (!SCM_SYMBOLP (orig_sym
))
1288 SCM
*proc_ptr
= scm_lookupcar1 (x
, env
, 0);
1289 if (proc_ptr
== NULL
)
1291 /* We have lost the race. */
1297 proc
= *scm_lookupcar (x
, env
, 0);
1300 /* Only handle memoizing macros. `Acros' and `macros' are really
1301 special forms and should not be evaluated here. */
1303 if (!SCM_MACROP (proc
) || SCM_MACRO_TYPE (proc
) != 2)
1306 SCM_SETCAR (x
, orig_sym
); /* Undo memoizing effect of lookupcar */
1307 res
= scm_call_2 (SCM_MACRO_CODE (proc
), x
, env
);
1309 if (scm_ilength (res
) <= 0)
1310 res
= scm_list_2 (SCM_IM_BEGIN
, res
);
1313 SCM_SETCAR (x
, SCM_CAR (res
));
1314 SCM_SETCDR (x
, SCM_CDR (res
));
1320 /* scm_unmemocopy takes a memoized expression together with its
1321 * environment and rewrites it to its original form. Thus, it is the
1322 * inversion of the rewrite rules above. The procedure is not
1323 * optimized for speed. It's used in scm_iprin1 when printing the
1324 * code of a closure, in scm_procedure_source, in display_frame when
1325 * generating the source for a stackframe in a backtrace, and in
1326 * display_expression.
1328 * Unmemoizing is not a realiable process. You can not in general
1329 * expect to get the original source back.
1331 * However, GOOPS currently relies on this for method compilation.
1332 * This ought to change.
1335 #define SCM_BIT8(x) (127 & SCM_UNPACK (x))
1338 build_binding_list (SCM names
, SCM inits
)
1340 SCM bindings
= SCM_EOL
;
1341 while (!SCM_NULLP (names
))
1343 SCM binding
= scm_list_2 (SCM_CAR (names
), SCM_CAR (inits
));
1344 bindings
= scm_cons (binding
, bindings
);
1345 names
= SCM_CDR (names
);
1346 inits
= SCM_CDR (inits
);
1352 unmemocopy (SCM x
, SCM env
)
1355 #ifdef DEBUG_EXTENSIONS
1360 #ifdef DEBUG_EXTENSIONS
1361 p
= scm_whash_lookup (scm_source_whash
, x
);
1363 switch (SCM_ITAG7 (SCM_CAR (x
)))
1365 case SCM_BIT8(SCM_IM_AND
):
1366 ls
= z
= scm_cons (scm_sym_and
, SCM_UNSPECIFIED
);
1368 case SCM_BIT8(SCM_IM_BEGIN
):
1369 ls
= z
= scm_cons (scm_sym_begin
, SCM_UNSPECIFIED
);
1371 case SCM_BIT8(SCM_IM_CASE
):
1372 ls
= z
= scm_cons (scm_sym_case
, SCM_UNSPECIFIED
);
1374 case SCM_BIT8(SCM_IM_COND
):
1375 ls
= z
= scm_cons (scm_sym_cond
, SCM_UNSPECIFIED
);
1377 case SCM_BIT8 (SCM_IM_DO
):
1379 /* format: (#@do (nk nk-1 ...) (i1 ... ik) (test) (body) s1 ... sk),
1380 * where nx is the name of a local variable, ix is an initializer for
1381 * the local variable, test is the test clause of the do loop, body is
1382 * the body of the do loop and sx are the step clauses for the local
1384 SCM names
, inits
, test
, memoized_body
, steps
, bindings
;
1387 names
= SCM_CAR (x
);
1389 inits
= scm_reverse (unmemocopy (SCM_CAR (x
), env
));
1390 env
= EXTEND_ENV (names
, SCM_EOL
, env
);
1392 test
= unmemocopy (SCM_CAR (x
), env
);
1394 memoized_body
= SCM_CAR (x
);
1396 steps
= scm_reverse (unmemocopy (x
, env
));
1398 /* build transformed binding list */
1400 while (!SCM_NULLP (names
))
1402 SCM name
= SCM_CAR (names
);
1403 SCM init
= SCM_CAR (inits
);
1404 SCM step
= SCM_CAR (steps
);
1405 step
= SCM_EQ_P (step
, name
) ? SCM_EOL
: scm_list_1 (step
);
1407 bindings
= scm_cons (scm_cons2 (name
, init
, step
), bindings
);
1409 names
= SCM_CDR (names
);
1410 inits
= SCM_CDR (inits
);
1411 steps
= SCM_CDR (steps
);
1413 z
= scm_cons (test
, SCM_UNSPECIFIED
);
1414 ls
= scm_cons2 (scm_sym_do
, bindings
, z
);
1416 x
= scm_cons (SCM_BOOL_F
, memoized_body
);
1419 case SCM_BIT8(SCM_IM_IF
):
1420 ls
= z
= scm_cons (scm_sym_if
, SCM_UNSPECIFIED
);
1422 case SCM_BIT8 (SCM_IM_LET
):
1424 /* format: (#@let (nk nk-1 ...) (i1 ... ik) b1 ...),
1425 * where nx is the name of a local variable, ix is an initializer for
1426 * the local variable and by are the body clauses. */
1427 SCM names
, inits
, bindings
;
1430 names
= SCM_CAR (x
);
1432 inits
= scm_reverse (unmemocopy (SCM_CAR (x
), env
));
1433 env
= EXTEND_ENV (names
, SCM_EOL
, env
);
1435 bindings
= build_binding_list (names
, inits
);
1436 z
= scm_cons (bindings
, SCM_UNSPECIFIED
);
1437 ls
= scm_cons (scm_sym_let
, z
);
1440 case SCM_BIT8 (SCM_IM_LETREC
):
1442 /* format: (#@letrec (nk nk-1 ...) (i1 ... ik) b1 ...),
1443 * where nx is the name of a local variable, ix is an initializer for
1444 * the local variable and by are the body clauses. */
1445 SCM names
, inits
, bindings
;
1448 names
= SCM_CAR (x
);
1449 env
= EXTEND_ENV (names
, SCM_EOL
, env
);
1451 inits
= scm_reverse (unmemocopy (SCM_CAR (x
), env
));
1453 bindings
= build_binding_list (names
, inits
);
1454 z
= scm_cons (bindings
, SCM_UNSPECIFIED
);
1455 ls
= scm_cons (scm_sym_letrec
, z
);
1458 case SCM_BIT8(SCM_IM_LETSTAR
):
1466 env
= EXTEND_ENV (SCM_EOL
, SCM_EOL
, env
);
1469 y
= z
= scm_acons (SCM_CAR (b
),
1471 scm_cons (unmemocopy (SCM_CADR (b
), env
), SCM_EOL
), env
),
1473 env
= EXTEND_ENV (SCM_CAR (b
), SCM_BOOL_F
, env
);
1477 SCM_SETCDR (y
, SCM_EOL
);
1478 ls
= scm_cons (scm_sym_let
, z
= scm_cons (y
, SCM_UNSPECIFIED
));
1483 SCM_SETCDR (z
, scm_acons (SCM_CAR (b
),
1485 scm_list_1 (unmemocopy (SCM_CADR (b
), env
)), env
),
1488 env
= EXTEND_ENV (SCM_CAR (b
), SCM_BOOL_F
, env
);
1491 while (SCM_NIMP (b
));
1492 SCM_SETCDR (z
, SCM_EOL
);
1494 ls
= scm_cons (scm_sym_letstar
, z
= scm_cons (y
, SCM_UNSPECIFIED
));
1497 case SCM_BIT8(SCM_IM_OR
):
1498 ls
= z
= scm_cons (scm_sym_or
, SCM_UNSPECIFIED
);
1500 case SCM_BIT8(SCM_IM_LAMBDA
):
1502 z
= scm_cons (SCM_CAR (x
), SCM_UNSPECIFIED
);
1503 ls
= scm_cons (scm_sym_lambda
, z
);
1504 env
= EXTEND_ENV (SCM_CAR (x
), SCM_EOL
, env
);
1506 case SCM_BIT8(SCM_IM_QUOTE
):
1507 ls
= z
= scm_cons (scm_sym_quote
, SCM_UNSPECIFIED
);
1509 case SCM_BIT8(SCM_IM_SET_X
):
1510 ls
= z
= scm_cons (scm_sym_set_x
, SCM_UNSPECIFIED
);
1512 case SCM_BIT8(SCM_IM_DEFINE
):
1517 z
= scm_cons (n
, SCM_UNSPECIFIED
);
1518 ls
= scm_cons (scm_sym_define
, z
);
1519 if (!SCM_NULLP (env
))
1520 SCM_SETCAR (SCM_CAR (env
), scm_cons (n
, SCM_CAAR (env
)));
1523 case SCM_BIT8(SCM_MAKISYM (0)):
1527 switch (SCM_ISYMNUM (z
))
1529 case (SCM_ISYMNUM (SCM_IM_APPLY
)):
1530 ls
= z
= scm_cons (scm_sym_atapply
, SCM_UNSPECIFIED
);
1532 case (SCM_ISYMNUM (SCM_IM_CONT
)):
1533 ls
= z
= scm_cons (scm_sym_atcall_cc
, SCM_UNSPECIFIED
);
1535 case (SCM_ISYMNUM (SCM_IM_DELAY
)):
1536 ls
= z
= scm_cons (scm_sym_delay
, SCM_UNSPECIFIED
);
1539 case (SCM_ISYMNUM (SCM_IM_CALL_WITH_VALUES
)):
1540 ls
= z
= scm_cons (scm_sym_at_call_with_values
, SCM_UNSPECIFIED
);
1543 /* appease the Sun compiler god: */ ;
1547 ls
= z
= unmemocar (scm_cons (unmemocopy (SCM_CAR (x
), env
),
1553 while (SCM_CONSP (x
))
1555 SCM form
= SCM_CAR (x
);
1556 if (!SCM_ISYMP (form
))
1558 SCM copy
= scm_cons (unmemocopy (form
, env
), SCM_UNSPECIFIED
);
1559 SCM_SETCDR (z
, unmemocar (copy
, env
));
1565 #ifdef DEBUG_EXTENSIONS
1566 if (!SCM_FALSEP (p
))
1567 scm_whash_insert (scm_source_whash
, ls
, p
);
1574 scm_unmemocopy (SCM x
, SCM env
)
1576 if (!SCM_NULLP (env
))
1577 /* Make a copy of the lowest frame to protect it from
1578 modifications by SCM_IM_DEFINE */
1579 return unmemocopy (x
, scm_cons (SCM_CAR (env
), SCM_CDR (env
)));
1581 return unmemocopy (x
, env
);
1584 #ifndef SCM_RECKLESS
1587 scm_badargsp (SCM formals
, SCM args
)
1589 while (SCM_NIMP (formals
))
1591 if (!SCM_CONSP (formals
))
1595 formals
= SCM_CDR (formals
);
1596 args
= SCM_CDR (args
);
1598 return !SCM_NULLP (args
) ? 1 : 0;
1604 scm_badformalsp (SCM closure
, int n
)
1606 SCM formals
= SCM_CLOSURE_FORMALS (closure
);
1607 while (!SCM_NULLP (formals
))
1609 if (!SCM_CONSP (formals
))
1614 formals
= SCM_CDR (formals
);
1621 scm_eval_args (SCM l
, SCM env
, SCM proc
)
1623 SCM results
= SCM_EOL
, *lloc
= &results
, res
;
1624 while (SCM_CONSP (l
))
1626 res
= EVALCAR (l
, env
);
1628 *lloc
= scm_list_1 (res
);
1629 lloc
= SCM_CDRLOC (*lloc
);
1634 scm_wrong_num_args (proc
);
1640 scm_eval_body (SCM code
, SCM env
)
1644 next
= SCM_CDR (code
);
1645 while (!SCM_NULLP (next
))
1647 if (SCM_IMP (SCM_CAR (code
)))
1649 if (SCM_ISYMP (SCM_CAR (code
)))
1651 code
= scm_m_expand_body (code
, env
);
1656 SCM_XEVAL (SCM_CAR (code
), env
);
1658 next
= SCM_CDR (code
);
1660 return SCM_XEVALCAR (code
, env
);
1667 /* SECTION: This code is specific for the debugging support. One
1668 * branch is read when DEVAL isn't defined, the other when DEVAL is
1674 #define SCM_APPLY scm_apply
1675 #define PREP_APPLY(proc, args)
1677 #define RETURN(x) do { return x; } while (0)
1678 #ifdef STACK_CHECKING
1679 #ifndef NO_CEVAL_STACK_CHECKING
1680 #define EVAL_STACK_CHECKING
1687 #define SCM_CEVAL scm_deval /* Substitute all uses of scm_ceval */
1689 #define SCM_APPLY scm_dapply
1691 #define PREP_APPLY(p, l) \
1692 { ++debug.info; debug.info->a.proc = p; debug.info->a.args = l; }
1694 #define ENTER_APPLY \
1696 SCM_SET_ARGSREADY (debug);\
1697 if (CHECK_APPLY && SCM_TRAPS_P)\
1698 if (SCM_APPLY_FRAME_P || (SCM_TRACE_P && PROCTRACEP (proc)))\
1700 SCM tmp, tail = SCM_BOOL(SCM_TRACED_FRAME_P (debug)); \
1701 SCM_SET_TRACED_FRAME (debug); \
1703 if (SCM_CHEAPTRAPS_P)\
1705 tmp = scm_make_debugobj (&debug);\
1706 scm_call_3 (SCM_APPLY_FRAME_HDLR, scm_sym_apply_frame, tmp, tail);\
1711 tmp = scm_make_continuation (&first);\
1713 scm_call_3 (SCM_APPLY_FRAME_HDLR, scm_sym_apply_frame, tmp, tail);\
1719 #define RETURN(e) do { proc = (e); goto exit; } while (0)
1720 #ifdef STACK_CHECKING
1721 #ifndef EVAL_STACK_CHECKING
1722 #define EVAL_STACK_CHECKING
1726 /* scm_ceval_ptr points to the currently selected evaluator.
1727 * *fixme*: Although efficiency is important here, this state variable
1728 * should probably not be a global. It should be related to the
1733 SCM (*scm_ceval_ptr
) (SCM x
, SCM env
);
1735 /* scm_last_debug_frame contains a pointer to the last debugging
1736 * information stack frame. It is accessed very often from the
1737 * debugging evaluator, so it should probably not be indirectly
1738 * addressed. Better to save and restore it from the current root at
1743 scm_t_debug_frame
*scm_last_debug_frame
;
1746 /* scm_debug_eframe_size is the number of slots available for pseudo
1747 * stack frames at each real stack frame.
1750 long scm_debug_eframe_size
;
1752 int scm_debug_mode
, scm_check_entry_p
, scm_check_apply_p
, scm_check_exit_p
;
1754 long scm_eval_stack
;
1756 scm_t_option scm_eval_opts
[] = {
1757 { SCM_OPTION_INTEGER
, "stack", 22000, "Size of thread stacks (in machine words)." }
1760 scm_t_option scm_debug_opts
[] = {
1761 { SCM_OPTION_BOOLEAN
, "cheap", 1,
1762 "*Flyweight representation of the stack at traps." },
1763 { SCM_OPTION_BOOLEAN
, "breakpoints", 0, "*Check for breakpoints." },
1764 { SCM_OPTION_BOOLEAN
, "trace", 0, "*Trace mode." },
1765 { SCM_OPTION_BOOLEAN
, "procnames", 1,
1766 "Record procedure names at definition." },
1767 { SCM_OPTION_BOOLEAN
, "backwards", 0,
1768 "Display backtrace in anti-chronological order." },
1769 { SCM_OPTION_INTEGER
, "width", 79, "Maximal width of backtrace." },
1770 { SCM_OPTION_INTEGER
, "indent", 10, "Maximal indentation in backtrace." },
1771 { SCM_OPTION_INTEGER
, "frames", 3,
1772 "Maximum number of tail-recursive frames in backtrace." },
1773 { SCM_OPTION_INTEGER
, "maxdepth", 1000,
1774 "Maximal number of stored backtrace frames." },
1775 { SCM_OPTION_INTEGER
, "depth", 20, "Maximal length of printed backtrace." },
1776 { SCM_OPTION_BOOLEAN
, "backtrace", 0, "Show backtrace on error." },
1777 { SCM_OPTION_BOOLEAN
, "debug", 0, "Use the debugging evaluator." },
1778 { SCM_OPTION_INTEGER
, "stack", 20000, "Stack size limit (measured in words; 0 = no check)." },
1779 { 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."}
1782 scm_t_option scm_evaluator_trap_table
[] = {
1783 { SCM_OPTION_BOOLEAN
, "traps", 0, "Enable evaluator traps." },
1784 { SCM_OPTION_BOOLEAN
, "enter-frame", 0, "Trap when eval enters new frame." },
1785 { SCM_OPTION_BOOLEAN
, "apply-frame", 0, "Trap when entering apply." },
1786 { SCM_OPTION_BOOLEAN
, "exit-frame", 0, "Trap when exiting eval or apply." },
1787 { SCM_OPTION_SCM
, "enter-frame-handler", (unsigned long)SCM_BOOL_F
, "Handler for enter-frame traps." },
1788 { SCM_OPTION_SCM
, "apply-frame-handler", (unsigned long)SCM_BOOL_F
, "Handler for apply-frame traps." },
1789 { SCM_OPTION_SCM
, "exit-frame-handler", (unsigned long)SCM_BOOL_F
, "Handler for exit-frame traps." }
1792 SCM_DEFINE (scm_eval_options_interface
, "eval-options-interface", 0, 1, 0,
1794 "Option interface for the evaluation options. Instead of using\n"
1795 "this procedure directly, use the procedures @code{eval-enable},\n"
1796 "@code{eval-disable}, @code{eval-set!} and @var{eval-options}.")
1797 #define FUNC_NAME s_scm_eval_options_interface
1801 ans
= scm_options (setting
,
1805 scm_eval_stack
= SCM_EVAL_STACK
* sizeof (void *);
1811 SCM_DEFINE (scm_evaluator_traps
, "evaluator-traps-interface", 0, 1, 0,
1813 "Option interface for the evaluator trap options.")
1814 #define FUNC_NAME s_scm_evaluator_traps
1818 ans
= scm_options (setting
,
1819 scm_evaluator_trap_table
,
1820 SCM_N_EVALUATOR_TRAPS
,
1822 SCM_RESET_DEBUG_MODE
;
1829 deval_args (SCM l
, SCM env
, SCM proc
, SCM
*lloc
)
1831 SCM
*results
= lloc
, res
;
1832 while (SCM_CONSP (l
))
1834 res
= EVALCAR (l
, env
);
1836 *lloc
= scm_list_1 (res
);
1837 lloc
= SCM_CDRLOC (*lloc
);
1842 scm_wrong_num_args (proc
);
1850 /* SECTION: This code is compiled twice.
1854 /* Update the toplevel environment frame ENV so that it refers to the
1855 * current module. */
1856 #define UPDATE_TOPLEVEL_ENV(env) \
1858 SCM p = scm_current_module_lookup_closure (); \
1859 if (p != SCM_CAR(env)) \
1860 env = scm_top_level_env (p); \
1864 #define CHECK_EQVISH(A,B) (SCM_EQ_P ((A), (B)) || (!SCM_FALSEP (scm_eqv_p ((A), (B)))))
1867 /* This is the evaluator. Like any real monster, it has three heads:
1869 * scm_ceval is the non-debugging evaluator, scm_deval is the debugging
1870 * version. Both are implemented using a common code base, using the
1871 * following mechanism: SCM_CEVAL is a macro, which is either defined to
1872 * scm_ceval or scm_deval. Thus, there is no function SCM_CEVAL, but the code
1873 * for SCM_CEVAL actually compiles to either scm_ceval or scm_deval. When
1874 * SCM_CEVAL is defined to scm_ceval, it is known that the macro DEVAL is not
1875 * defined. When SCM_CEVAL is defined to scm_deval, then the macro DEVAL is
1876 * known to be defined. Thus, in SCM_CEVAL parts for the debugging evaluator
1877 * are enclosed within #ifdef DEVAL ... #endif.
1879 * All three (scm_ceval, scm_deval and their common implementation SCM_CEVAL)
1880 * take two input parameters, x and env: x is a single expression to be
1881 * evalutated. env is the environment in which bindings are searched.
1883 * x is known to be a cell (i. e. a pair or any other non-immediate). Since x
1884 * is a single expression, it is necessarily in a tail position. If x is just
1885 * a call to another function like in the expression (foo exp1 exp2 ...), the
1886 * realization of that call therefore _must_not_ increase stack usage (the
1887 * evaluation of exp1, exp2 etc., however, may do so). This is realized by
1888 * making extensive use of 'goto' statements within the evaluator: The gotos
1889 * replace recursive calls to SCM_CEVAL, thus re-using the same stack frame
1890 * that SCM_CEVAL was already using. If, however, x represents some form that
1891 * requires to evaluate a sequence of expressions like (begin exp1 exp2 ...),
1892 * then recursive calls to SCM_CEVAL are performed for all but the last
1893 * expression of that sequence. */
1897 scm_ceval (SCM x
, SCM env
)
1903 scm_deval (SCM x
, SCM env
)
1908 SCM_CEVAL (SCM x
, SCM env
)
1915 SCM proc
, arg2
, orig_sym
;
1917 scm_t_debug_frame debug
;
1918 scm_t_debug_info
*debug_info_end
;
1919 debug
.prev
= scm_last_debug_frame
;
1920 debug
.status
= scm_debug_eframe_size
;
1922 * The debug.vect contains twice as much scm_t_debug_info frames as the
1923 * user has specified with (debug-set! frames <n>).
1925 * Even frames are eval frames, odd frames are apply frames.
1927 debug
.vect
= (scm_t_debug_info
*) alloca (scm_debug_eframe_size
1928 * sizeof (scm_t_debug_info
));
1929 debug
.info
= debug
.vect
;
1930 debug_info_end
= debug
.vect
+ scm_debug_eframe_size
;
1931 scm_last_debug_frame
= &debug
;
1933 #ifdef EVAL_STACK_CHECKING
1934 if (scm_stack_checking_enabled_p
1935 && SCM_STACK_OVERFLOW_P ((SCM_STACKITEM
*) &proc
))
1938 debug
.info
->e
.exp
= x
;
1939 debug
.info
->e
.env
= env
;
1941 scm_report_stack_overflow ();
1948 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
1951 SCM_CLEAR_ARGSREADY (debug
);
1952 if (SCM_OVERFLOWP (debug
))
1955 * In theory, this should be the only place where it is necessary to
1956 * check for space in debug.vect since both eval frames and
1957 * available space are even.
1959 * For this to be the case, however, it is necessary that primitive
1960 * special forms which jump back to `loop', `begin' or some similar
1961 * label call PREP_APPLY. A convenient way to do this is to jump to
1962 * `loopnoap' or `cdrxnoap'.
1964 else if (++debug
.info
>= debug_info_end
)
1966 SCM_SET_OVERFLOW (debug
);
1970 debug
.info
->e
.exp
= x
;
1971 debug
.info
->e
.env
= env
;
1972 if (CHECK_ENTRY
&& SCM_TRAPS_P
)
1973 if (SCM_ENTER_FRAME_P
|| (SCM_BREAKPOINTS_P
&& SRCBRKP (x
)))
1975 SCM tail
= SCM_BOOL(SCM_TAILRECP (debug
));
1976 SCM_SET_TAILREC (debug
);
1977 if (SCM_CHEAPTRAPS_P
)
1978 t
.arg1
= scm_make_debugobj (&debug
);
1982 SCM val
= scm_make_continuation (&first
);
1992 /* This gives the possibility for the debugger to
1993 modify the source expression before evaluation. */
1998 scm_call_4 (SCM_ENTER_FRAME_HDLR
,
1999 scm_sym_enter_frame
,
2002 scm_unmemocopy (x
, env
));
2006 #if defined (USE_THREADS) || defined (DEVAL)
2010 switch (SCM_TYP7 (x
))
2012 case scm_tc7_symbol
:
2013 /* Only happens when called at top level. */
2014 x
= scm_cons (x
, SCM_UNDEFINED
);
2015 RETURN (*scm_lookupcar (x
, env
, 1));
2017 case SCM_BIT8(SCM_IM_AND
):
2019 while (!SCM_NULLP (SCM_CDR (x
)))
2021 if (SCM_FALSEP (EVALCAR (x
, env
)))
2022 RETURN (SCM_BOOL_F
);
2026 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
2029 case SCM_BIT8(SCM_IM_BEGIN
):
2030 if (SCM_NULLP (SCM_CDR (x
)))
2031 RETURN (SCM_UNSPECIFIED
);
2033 /* (currently unused)
2035 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
2036 /* (currently unused)
2041 /* If we are on toplevel with a lookup closure, we need to sync
2042 with the current module. */
2043 if (SCM_CONSP (env
) && !SCM_CONSP (SCM_CAR (env
)))
2045 UPDATE_TOPLEVEL_ENV (env
);
2046 while (!SCM_NULLP (SCM_CDR (x
)))
2049 UPDATE_TOPLEVEL_ENV (env
);
2055 goto nontoplevel_begin
;
2057 nontoplevel_cdrxnoap
:
2058 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
2059 nontoplevel_cdrxbegin
:
2062 while (!SCM_NULLP (SCM_CDR (x
)))
2064 if (SCM_IMP (SCM_CAR (x
)))
2066 if (SCM_ISYMP (SCM_CAR (x
)))
2068 x
= scm_m_expand_body (x
, env
);
2069 goto nontoplevel_begin
;
2072 SCM_VALIDATE_NON_EMPTY_COMBINATION (SCM_CAR (x
));
2075 SCM_CEVAL (SCM_CAR (x
), env
);
2079 carloop
: /* scm_eval car of last form in list */
2080 if (SCM_IMP (SCM_CAR (x
)))
2083 RETURN (SCM_EVALIM (x
, env
));
2086 if (SCM_SYMBOLP (SCM_CAR (x
)))
2087 RETURN (*scm_lookupcar (x
, env
, 1));
2090 goto loop
; /* tail recurse */
2093 case SCM_BIT8(SCM_IM_CASE
):
2095 t
.arg1
= EVALCAR (x
, env
);
2096 while (SCM_NIMP (x
= SCM_CDR (x
)))
2099 if (SCM_EQ_P (scm_sym_else
, SCM_CAR (proc
)))
2102 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
2105 proc
= SCM_CAR (proc
);
2106 while (SCM_NIMP (proc
))
2108 if (CHECK_EQVISH (SCM_CAR (proc
), t
.arg1
))
2111 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
2114 proc
= SCM_CDR (proc
);
2117 RETURN (SCM_UNSPECIFIED
);
2120 case SCM_BIT8 (SCM_IM_COND
):
2122 while (!SCM_NULLP (x
))
2125 if (SCM_EQ_P (SCM_CAR (proc
), scm_sym_else
))
2128 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
2131 t
.arg1
= EVALCAR (proc
, env
);
2132 if (!SCM_FALSEP (t
.arg1
))
2137 if (!SCM_EQ_P (scm_sym_arrow
, SCM_CAR (x
)))
2139 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
2143 proc
= EVALCAR (proc
, env
);
2144 SCM_ASRTGO (SCM_NIMP (proc
), badfun
);
2145 PREP_APPLY (proc
, scm_list_1 (t
.arg1
));
2147 if (SCM_CLOSUREP(proc
) && scm_badformalsp (proc
, 1))
2148 goto umwrongnumargs
;
2153 RETURN (SCM_UNSPECIFIED
);
2156 case SCM_BIT8(SCM_IM_DO
):
2158 proc
= SCM_CADR (x
); /* inits */
2159 t
.arg1
= SCM_EOL
; /* values */
2160 while (SCM_NIMP (proc
))
2162 t
.arg1
= scm_cons (EVALCAR (proc
, env
), t
.arg1
);
2163 proc
= SCM_CDR (proc
);
2165 env
= EXTEND_ENV (SCM_CAR (x
), t
.arg1
, env
);
2167 while (proc
= SCM_CAR (x
), SCM_FALSEP (EVALCAR (proc
, env
)))
2169 for (proc
= SCM_CADR (x
); SCM_NIMP (proc
); proc
= SCM_CDR (proc
))
2171 t
.arg1
= SCM_CAR (proc
); /* body */
2172 SIDEVAL (t
.arg1
, env
);
2174 for (t
.arg1
= SCM_EOL
, proc
= SCM_CDDR (x
);
2176 proc
= SCM_CDR (proc
))
2177 t
.arg1
= scm_cons (EVALCAR (proc
, env
), t
.arg1
); /* steps */
2178 env
= EXTEND_ENV (SCM_CAAR (env
), t
.arg1
, SCM_CDR (env
));
2182 RETURN (SCM_UNSPECIFIED
);
2183 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
2184 goto nontoplevel_begin
;
2187 case SCM_BIT8(SCM_IM_IF
):
2189 if (!SCM_FALSEP (EVALCAR (x
, env
)))
2191 else if (SCM_IMP (x
= SCM_CDDR (x
)))
2192 RETURN (SCM_UNSPECIFIED
);
2193 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
2197 case SCM_BIT8(SCM_IM_LET
):
2199 proc
= SCM_CADR (x
);
2203 t
.arg1
= scm_cons (EVALCAR (proc
, env
), t
.arg1
);
2205 while (SCM_NIMP (proc
= SCM_CDR (proc
)));
2206 env
= EXTEND_ENV (SCM_CAR (x
), t
.arg1
, env
);
2208 goto nontoplevel_cdrxnoap
;
2211 case SCM_BIT8(SCM_IM_LETREC
):
2213 env
= EXTEND_ENV (SCM_CAR (x
), scm_undefineds
, env
);
2219 t
.arg1
= scm_cons (EVALCAR (proc
, env
), t
.arg1
);
2221 while (SCM_NIMP (proc
= SCM_CDR (proc
)));
2222 SCM_SETCDR (SCM_CAR (env
), t
.arg1
);
2223 goto nontoplevel_cdrxnoap
;
2226 case SCM_BIT8(SCM_IM_LETSTAR
):
2229 SCM bindings
= SCM_CAR (x
);
2230 if (SCM_NULLP (bindings
))
2231 env
= EXTEND_ENV (SCM_EOL
, SCM_EOL
, env
);
2236 SCM name
= SCM_CAR (bindings
);
2237 SCM init
= SCM_CDR (bindings
);
2238 env
= EXTEND_ENV (name
, EVALCAR (init
, env
), env
);
2239 bindings
= SCM_CDR (init
);
2241 while (!SCM_NULLP (bindings
));
2244 goto nontoplevel_cdrxnoap
;
2247 case SCM_BIT8(SCM_IM_OR
):
2249 while (!SCM_NULLP (SCM_CDR (x
)))
2251 SCM val
= EVALCAR (x
, env
);
2252 if (!SCM_FALSEP (val
))
2257 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
2261 case SCM_BIT8(SCM_IM_LAMBDA
):
2262 RETURN (scm_closure (SCM_CDR (x
), env
));
2265 case SCM_BIT8(SCM_IM_QUOTE
):
2266 RETURN (SCM_CADR (x
));
2269 case SCM_BIT8(SCM_IM_SET_X
):
2272 switch (SCM_ITAG3 (proc
))
2275 if (SCM_VARIABLEP (proc
))
2276 t
.lloc
= SCM_VARIABLE_LOC (proc
);
2278 t
.lloc
= scm_lookupcar (x
, env
, 1);
2280 #ifdef MEMOIZE_LOCALS
2282 t
.lloc
= scm_ilookup (proc
, env
);
2287 *t
.lloc
= EVALCAR (x
, env
);
2291 RETURN (SCM_UNSPECIFIED
);
2295 case SCM_BIT8(SCM_IM_DEFINE
): /* only for internal defines */
2296 scm_misc_error (NULL
, "Bad define placement", SCM_EOL
);
2298 /* new syntactic forms go here. */
2299 case SCM_BIT8(SCM_MAKISYM (0)):
2301 SCM_ASRTGO (SCM_ISYMP (proc
), badfun
);
2302 switch (SCM_ISYMNUM (proc
))
2304 case (SCM_ISYMNUM (SCM_IM_APPLY
)):
2306 proc
= EVALCAR (proc
, env
);
2307 SCM_ASRTGO (SCM_NIMP (proc
), badfun
);
2308 if (SCM_CLOSUREP (proc
))
2311 PREP_APPLY (proc
, SCM_EOL
);
2312 t
.arg1
= SCM_CDDR (x
);
2313 t
.arg1
= EVALCAR (t
.arg1
, env
);
2315 /* Go here to tail-call a closure. PROC is the closure
2316 and T.ARG1 is the list of arguments. Do not forget to
2319 debug
.info
->a
.args
= t
.arg1
;
2321 #ifndef SCM_RECKLESS
2322 if (scm_badargsp (SCM_CLOSURE_FORMALS (proc
), t
.arg1
))
2326 /* Copy argument list */
2327 if (SCM_IMP (t
.arg1
))
2331 argl
= tl
= scm_cons (SCM_CAR (t
.arg1
), SCM_UNSPECIFIED
);
2332 while (SCM_NIMP (t
.arg1
= SCM_CDR (t
.arg1
))
2333 && SCM_CONSP (t
.arg1
))
2335 SCM_SETCDR (tl
, scm_cons (SCM_CAR (t
.arg1
),
2339 SCM_SETCDR (tl
, t
.arg1
);
2342 env
= EXTEND_ENV (SCM_CLOSURE_FORMALS (proc
), argl
, SCM_ENV (proc
));
2343 x
= SCM_CLOSURE_BODY (proc
);
2344 goto nontoplevel_begin
;
2349 case (SCM_ISYMNUM (SCM_IM_CONT
)):
2352 SCM val
= scm_make_continuation (&first
);
2360 proc
= scm_eval_car (proc
, env
);
2361 SCM_ASRTGO (SCM_NIMP (proc
), badfun
);
2362 PREP_APPLY (proc
, scm_list_1 (t
.arg1
));
2364 if (SCM_CLOSUREP(proc
) && scm_badformalsp (proc
, 1))
2365 goto umwrongnumargs
;
2368 case (SCM_ISYMNUM (SCM_IM_DELAY
)):
2369 RETURN (scm_makprom (scm_closure (SCM_CDR (x
), env
)));
2371 case (SCM_ISYMNUM (SCM_IM_DISPATCH
)):
2372 proc
= SCM_CADR (x
); /* unevaluated operands */
2373 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
2375 arg2
= *scm_ilookup (proc
, env
);
2376 else if (!SCM_CONSP (proc
))
2378 if (SCM_VARIABLEP (proc
))
2379 arg2
= SCM_VARIABLE_REF (proc
);
2381 arg2
= *scm_lookupcar (SCM_CDR (x
), env
, 1);
2385 arg2
= scm_list_1 (EVALCAR (proc
, env
));
2386 t
.lloc
= SCM_CDRLOC (arg2
);
2387 while (SCM_NIMP (proc
= SCM_CDR (proc
)))
2389 *t
.lloc
= scm_list_1 (EVALCAR (proc
, env
));
2390 t
.lloc
= SCM_CDRLOC (*t
.lloc
);
2395 /* The type dispatch code is duplicated here
2396 * (c.f. objects.c:scm_mcache_compute_cmethod) since that
2397 * cuts down execution time for type dispatch to 50%.
2400 long i
, n
, end
, mask
;
2401 SCM z
= SCM_CDDR (x
);
2402 n
= SCM_INUM (SCM_CAR (z
)); /* maximum number of specializers */
2403 proc
= SCM_CADR (z
);
2405 if (SCM_NIMP (proc
))
2407 /* Prepare for linear search */
2410 end
= SCM_VECTOR_LENGTH (proc
);
2414 /* Compute a hash value */
2415 long hashset
= SCM_INUM (proc
);
2418 mask
= SCM_INUM (SCM_CAR (z
));
2419 proc
= SCM_CADR (z
);
2422 if (SCM_NIMP (t
.arg1
))
2425 i
+= SCM_STRUCT_DATA (scm_class_of (SCM_CAR (t
.arg1
)))
2426 [scm_si_hashsets
+ hashset
];
2427 t
.arg1
= SCM_CDR (t
.arg1
);
2429 while (j
-- && SCM_NIMP (t
.arg1
));
2434 /* Search for match */
2438 z
= SCM_VELTS (proc
)[i
];
2439 t
.arg1
= arg2
; /* list of arguments */
2440 if (SCM_NIMP (t
.arg1
))
2443 /* More arguments than specifiers => CLASS != ENV */
2444 if (! SCM_EQ_P (scm_class_of (SCM_CAR (t
.arg1
)), SCM_CAR (z
)))
2446 t
.arg1
= SCM_CDR (t
.arg1
);
2449 while (j
-- && SCM_NIMP (t
.arg1
));
2450 /* Fewer arguments than specifiers => CAR != ENV */
2451 if (!(SCM_IMP (SCM_CAR (z
)) || SCM_CONSP (SCM_CAR (z
))))
2454 env
= EXTEND_ENV (SCM_CAR (SCM_CMETHOD_CODE (z
)),
2456 SCM_CMETHOD_ENV (z
));
2457 x
= SCM_CMETHOD_CODE (z
);
2458 goto nontoplevel_cdrxbegin
;
2463 z
= scm_memoize_method (x
, arg2
);
2467 case (SCM_ISYMNUM (SCM_IM_SLOT_REF
)):
2469 t
.arg1
= EVALCAR (x
, env
);
2470 RETURN (SCM_PACK (SCM_STRUCT_DATA (t
.arg1
) [SCM_INUM (SCM_CADR (x
))]));
2472 case (SCM_ISYMNUM (SCM_IM_SLOT_SET_X
)):
2474 t
.arg1
= EVALCAR (x
, env
);
2477 SCM_STRUCT_DATA (t
.arg1
) [SCM_INUM (SCM_CAR (x
))]
2478 = SCM_UNPACK (EVALCAR (proc
, env
));
2479 RETURN (SCM_UNSPECIFIED
);
2481 case (SCM_ISYMNUM (SCM_IM_NIL_COND
)):
2483 while (SCM_NIMP (x
= SCM_CDR (proc
)))
2485 if (!(SCM_FALSEP (t
.arg1
= EVALCAR (proc
, env
))
2486 || SCM_EQ_P (t
.arg1
, scm_lisp_nil
)))
2488 if (SCM_EQ_P (SCM_CAR (x
), SCM_UNSPECIFIED
))
2490 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
2496 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
2499 case (SCM_ISYMNUM (SCM_IM_NIL_IFY
)):
2501 RETURN ((SCM_FALSEP (proc
= EVALCAR (x
, env
)) || SCM_NULLP (proc
))
2505 case (SCM_ISYMNUM (SCM_IM_T_IFY
)):
2507 RETURN (!SCM_FALSEP (EVALCAR (x
, env
)) ? scm_lisp_t
: scm_lisp_nil
);
2509 case (SCM_ISYMNUM (SCM_IM_0_COND
)):
2511 while (SCM_NIMP (x
= SCM_CDR (proc
)))
2513 if (!(SCM_FALSEP (t
.arg1
= EVALCAR (proc
, env
))
2514 || SCM_EQ_P (t
.arg1
, SCM_INUM0
)))
2516 if (SCM_EQ_P (SCM_CAR (x
), SCM_UNSPECIFIED
))
2518 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
2524 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
2527 case (SCM_ISYMNUM (SCM_IM_0_IFY
)):
2529 RETURN (SCM_FALSEP (proc
= EVALCAR (x
, env
))
2533 case (SCM_ISYMNUM (SCM_IM_1_IFY
)):
2535 RETURN (!SCM_FALSEP (EVALCAR (x
, env
))
2539 case (SCM_ISYMNUM (SCM_IM_BIND
)):
2541 SCM vars
, exps
, vals
;
2544 vars
= SCM_CAAR (x
);
2545 exps
= SCM_CDAR (x
);
2549 while (SCM_NIMP (exps
))
2551 vals
= scm_cons (EVALCAR (exps
, env
), vals
);
2552 exps
= SCM_CDR (exps
);
2555 scm_swap_bindings (vars
, vals
);
2556 scm_dynwinds
= scm_acons (vars
, vals
, scm_dynwinds
);
2558 arg2
= x
= SCM_CDR (x
);
2559 while (!SCM_NULLP (arg2
= SCM_CDR (arg2
)))
2561 SIDEVAL (SCM_CAR (x
), env
);
2564 proc
= EVALCAR (x
, env
);
2566 scm_dynwinds
= SCM_CDR (scm_dynwinds
);
2567 scm_swap_bindings (vars
, vals
);
2572 case (SCM_ISYMNUM (SCM_IM_CALL_WITH_VALUES
)):
2575 x
= EVALCAR (proc
, env
);
2576 proc
= SCM_CDR (proc
);
2577 proc
= EVALCAR (proc
, env
);
2578 t
.arg1
= SCM_APPLY (x
, SCM_EOL
, SCM_EOL
);
2579 if (SCM_VALUESP (t
.arg1
))
2580 t
.arg1
= scm_struct_ref (t
.arg1
, SCM_INUM0
);
2582 t
.arg1
= scm_list_1 (t
.arg1
);
2583 if (SCM_CLOSUREP (proc
))
2585 PREP_APPLY (proc
, t
.arg1
);
2588 return SCM_APPLY (proc
, t
.arg1
, SCM_EOL
);
2598 scm_misc_error (NULL
, "Wrong type to apply: ~S", scm_list_1 (proc
));
2599 case scm_tc7_vector
:
2603 case scm_tc7_byvect
:
2610 #ifdef HAVE_LONG_LONGS
2611 case scm_tc7_llvect
:
2614 case scm_tc7_string
:
2616 case scm_tcs_closures
:
2620 case scm_tcs_struct
:
2623 case scm_tc7_variable
:
2624 RETURN (SCM_VARIABLE_REF(x
));
2626 #ifdef MEMOIZE_LOCALS
2627 case SCM_BIT8(SCM_ILOC00
):
2628 proc
= *scm_ilookup (SCM_CAR (x
), env
);
2629 SCM_ASRTGO (SCM_NIMP (proc
), badfun
);
2630 #ifndef SCM_RECKLESS
2636 #endif /* ifdef MEMOIZE_LOCALS */
2638 case scm_tcs_cons_nimcar
:
2639 orig_sym
= SCM_CAR (x
);
2640 if (SCM_SYMBOLP (orig_sym
))
2643 t
.lloc
= scm_lookupcar1 (x
, env
, 1);
2646 /* we have lost the race, start again. */
2651 proc
= *scm_lookupcar (x
, env
, 1);
2656 SCM_SETCAR (x
, orig_sym
); /* Undo memoizing effect of
2660 if (SCM_MACROP (proc
))
2662 SCM_SETCAR (x
, orig_sym
); /* Undo memoizing effect of
2666 /* Set a flag during macro expansion so that macro
2667 application frames can be deleted from the backtrace. */
2668 SCM_SET_MACROEXP (debug
);
2670 t
.arg1
= SCM_APPLY (SCM_MACRO_CODE (proc
), x
,
2671 scm_cons (env
, scm_listofnull
));
2674 SCM_CLEAR_MACROEXP (debug
);
2676 switch (SCM_MACRO_TYPE (proc
))
2679 if (scm_ilength (t
.arg1
) <= 0)
2680 t
.arg1
= scm_list_2 (SCM_IM_BEGIN
, t
.arg1
);
2682 if (!SCM_CLOSUREP (SCM_MACRO_CODE (proc
)))
2685 SCM_SETCAR (x
, SCM_CAR (t
.arg1
));
2686 SCM_SETCDR (x
, SCM_CDR (t
.arg1
));
2690 /* Prevent memoizing of debug info expression. */
2691 debug
.info
->e
.exp
= scm_cons_source (debug
.info
->e
.exp
,
2696 SCM_SETCAR (x
, SCM_CAR (t
.arg1
));
2697 SCM_SETCDR (x
, SCM_CDR (t
.arg1
));
2701 if (SCM_NIMP (x
= t
.arg1
))
2709 proc
= SCM_CEVAL (SCM_CAR (x
), env
);
2710 SCM_ASRTGO (!SCM_IMP (proc
), badfun
);
2711 #ifndef SCM_RECKLESS
2715 if (SCM_CLOSUREP (proc
))
2717 arg2
= SCM_CLOSURE_FORMALS (proc
);
2718 t
.arg1
= SCM_CDR (x
);
2719 while (!SCM_NULLP (arg2
))
2721 if (!SCM_CONSP (arg2
))
2723 if (SCM_IMP (t
.arg1
))
2724 goto umwrongnumargs
;
2725 arg2
= SCM_CDR (arg2
);
2726 t
.arg1
= SCM_CDR (t
.arg1
);
2728 if (!SCM_NULLP (t
.arg1
))
2729 goto umwrongnumargs
;
2731 else if (SCM_MACROP (proc
))
2732 goto handle_a_macro
;
2738 PREP_APPLY (proc
, SCM_EOL
);
2739 if (SCM_NULLP (SCM_CDR (x
))) {
2742 switch (SCM_TYP7 (proc
))
2743 { /* no arguments given */
2744 case scm_tc7_subr_0
:
2745 RETURN (SCM_SUBRF (proc
) ());
2746 case scm_tc7_subr_1o
:
2747 RETURN (SCM_SUBRF (proc
) (SCM_UNDEFINED
));
2749 RETURN (SCM_SUBRF (proc
) (SCM_EOL
));
2750 case scm_tc7_rpsubr
:
2751 RETURN (SCM_BOOL_T
);
2753 RETURN (SCM_SUBRF (proc
) (SCM_UNDEFINED
, SCM_UNDEFINED
));
2755 if (!SCM_SMOB_APPLICABLE_P (proc
))
2757 RETURN (SCM_SMOB_APPLY_0 (proc
));
2760 proc
= SCM_CCLO_SUBR (proc
);
2762 debug
.info
->a
.proc
= proc
;
2763 debug
.info
->a
.args
= scm_list_1 (t
.arg1
);
2767 proc
= SCM_PROCEDURE (proc
);
2769 debug
.info
->a
.proc
= proc
;
2771 if (!SCM_CLOSUREP (proc
))
2773 if (scm_badformalsp (proc
, 0))
2774 goto umwrongnumargs
;
2775 case scm_tcs_closures
:
2776 x
= SCM_CLOSURE_BODY (proc
);
2777 env
= EXTEND_ENV (SCM_CLOSURE_FORMALS (proc
), SCM_EOL
, SCM_ENV (proc
));
2778 goto nontoplevel_begin
;
2779 case scm_tcs_struct
:
2780 if (SCM_OBJ_CLASS_FLAGS (proc
) & SCM_CLASSF_PURE_GENERIC
)
2782 x
= SCM_ENTITY_PROCEDURE (proc
);
2786 else if (!SCM_I_OPERATORP (proc
))
2791 proc
= (SCM_I_ENTITYP (proc
)
2792 ? SCM_ENTITY_PROCEDURE (proc
)
2793 : SCM_OPERATOR_PROCEDURE (proc
));
2795 debug
.info
->a
.proc
= proc
;
2796 debug
.info
->a
.args
= scm_list_1 (t
.arg1
);
2798 if (SCM_NIMP (proc
))
2803 case scm_tc7_subr_1
:
2804 case scm_tc7_subr_2
:
2805 case scm_tc7_subr_2o
:
2807 case scm_tc7_subr_3
:
2808 case scm_tc7_lsubr_2
:
2812 scm_wrong_num_args (proc
);
2814 /* handle macros here */
2819 /* must handle macros by here */
2824 else if (SCM_CONSP (x
))
2826 if (SCM_IMP (SCM_CAR (x
)))
2827 t
.arg1
= SCM_EVALIM (SCM_CAR (x
), env
);
2829 t
.arg1
= EVALCELLCAR (x
, env
);
2834 t
.arg1
= EVALCAR (x
, env
);
2837 debug
.info
->a
.args
= scm_list_1 (t
.arg1
);
2844 switch (SCM_TYP7 (proc
))
2845 { /* have one argument in t.arg1 */
2846 case scm_tc7_subr_2o
:
2847 RETURN (SCM_SUBRF (proc
) (t
.arg1
, SCM_UNDEFINED
));
2848 case scm_tc7_subr_1
:
2849 case scm_tc7_subr_1o
:
2850 RETURN (SCM_SUBRF (proc
) (t
.arg1
));
2852 if (SCM_SUBRF (proc
))
2854 if (SCM_INUMP (t
.arg1
))
2856 RETURN (scm_make_real (SCM_DSUBRF (proc
) ((double) SCM_INUM (t
.arg1
))));
2858 else if (SCM_REALP (t
.arg1
))
2860 RETURN (scm_make_real (SCM_DSUBRF (proc
) (SCM_REAL_VALUE (t
.arg1
))));
2863 else if (SCM_BIGP (t
.arg1
))
2865 RETURN (scm_make_real (SCM_DSUBRF (proc
) (scm_i_big2dbl (t
.arg1
))));
2868 SCM_WTA_DISPATCH_1 (*SCM_SUBR_GENERIC (proc
), t
.arg1
,
2869 SCM_ARG1
, SCM_SYMBOL_CHARS (SCM_SNAME (proc
)));
2871 proc
= SCM_SNAME (proc
);
2873 char *chrs
= SCM_SYMBOL_CHARS (proc
) + SCM_SYMBOL_LENGTH (proc
) - 1;
2874 while ('c' != *--chrs
)
2876 SCM_ASSERT (SCM_CONSP (t
.arg1
),
2877 t
.arg1
, SCM_ARG1
, SCM_SYMBOL_CHARS (proc
));
2878 t
.arg1
= ('a' == *chrs
) ? SCM_CAR (t
.arg1
) : SCM_CDR (t
.arg1
);
2882 case scm_tc7_rpsubr
:
2883 RETURN (SCM_BOOL_T
);
2885 RETURN (SCM_SUBRF (proc
) (t
.arg1
, SCM_UNDEFINED
));
2888 RETURN (SCM_SUBRF (proc
) (debug
.info
->a
.args
));
2890 RETURN (SCM_SUBRF (proc
) (scm_list_1 (t
.arg1
)));
2893 if (!SCM_SMOB_APPLICABLE_P (proc
))
2895 RETURN (SCM_SMOB_APPLY_1 (proc
, t
.arg1
));
2899 proc
= SCM_CCLO_SUBR (proc
);
2901 debug
.info
->a
.args
= scm_cons (t
.arg1
, debug
.info
->a
.args
);
2902 debug
.info
->a
.proc
= proc
;
2906 proc
= SCM_PROCEDURE (proc
);
2908 debug
.info
->a
.proc
= proc
;
2910 if (!SCM_CLOSUREP (proc
))
2912 if (scm_badformalsp (proc
, 1))
2913 goto umwrongnumargs
;
2914 case scm_tcs_closures
:
2916 x
= SCM_CLOSURE_BODY (proc
);
2918 env
= EXTEND_ENV (SCM_CLOSURE_FORMALS (proc
), debug
.info
->a
.args
, SCM_ENV (proc
));
2920 env
= EXTEND_ENV (SCM_CLOSURE_FORMALS (proc
), scm_list_1 (t
.arg1
), SCM_ENV (proc
));
2922 goto nontoplevel_begin
;
2923 case scm_tcs_struct
:
2924 if (SCM_OBJ_CLASS_FLAGS (proc
) & SCM_CLASSF_PURE_GENERIC
)
2926 x
= SCM_ENTITY_PROCEDURE (proc
);
2928 arg2
= debug
.info
->a
.args
;
2930 arg2
= scm_list_1 (t
.arg1
);
2934 else if (!SCM_I_OPERATORP (proc
))
2940 proc
= (SCM_I_ENTITYP (proc
)
2941 ? SCM_ENTITY_PROCEDURE (proc
)
2942 : SCM_OPERATOR_PROCEDURE (proc
));
2944 debug
.info
->a
.args
= scm_cons (t
.arg1
, debug
.info
->a
.args
);
2945 debug
.info
->a
.proc
= proc
;
2947 if (SCM_NIMP (proc
))
2952 case scm_tc7_subr_2
:
2953 case scm_tc7_subr_0
:
2954 case scm_tc7_subr_3
:
2955 case scm_tc7_lsubr_2
:
2964 else if (SCM_CONSP (x
))
2966 if (SCM_IMP (SCM_CAR (x
)))
2967 arg2
= SCM_EVALIM (SCM_CAR (x
), env
);
2969 arg2
= EVALCELLCAR (x
, env
);
2974 arg2
= EVALCAR (x
, env
);
2976 { /* have two or more arguments */
2978 debug
.info
->a
.args
= scm_list_2 (t
.arg1
, arg2
);
2981 if (SCM_NULLP (x
)) {
2984 switch (SCM_TYP7 (proc
))
2985 { /* have two arguments */
2986 case scm_tc7_subr_2
:
2987 case scm_tc7_subr_2o
:
2988 RETURN (SCM_SUBRF (proc
) (t
.arg1
, arg2
));
2991 RETURN (SCM_SUBRF (proc
) (debug
.info
->a
.args
));
2993 RETURN (SCM_SUBRF (proc
) (scm_list_2 (t
.arg1
, arg2
)));
2995 case scm_tc7_lsubr_2
:
2996 RETURN (SCM_SUBRF (proc
) (t
.arg1
, arg2
, SCM_EOL
));
2997 case scm_tc7_rpsubr
:
2999 RETURN (SCM_SUBRF (proc
) (t
.arg1
, arg2
));
3001 if (!SCM_SMOB_APPLICABLE_P (proc
))
3003 RETURN (SCM_SMOB_APPLY_2 (proc
, t
.arg1
, arg2
));
3007 RETURN (SCM_APPLY (SCM_CCLO_SUBR (proc
),
3008 scm_cons (proc
, debug
.info
->a
.args
),
3011 RETURN (SCM_APPLY (SCM_CCLO_SUBR (proc
),
3012 scm_cons2 (proc
, t
.arg1
,
3019 case scm_tcs_struct
:
3020 if (SCM_OBJ_CLASS_FLAGS (proc
) & SCM_CLASSF_PURE_GENERIC
)
3022 x
= SCM_ENTITY_PROCEDURE (proc
);
3024 arg2
= debug
.info
->a
.args
;
3026 arg2
= scm_list_2 (t
.arg1
, arg2
);
3030 else if (!SCM_I_OPERATORP (proc
))
3036 RETURN (SCM_APPLY (SCM_I_ENTITYP (proc
)
3037 ? SCM_ENTITY_PROCEDURE (proc
)
3038 : SCM_OPERATOR_PROCEDURE (proc
),
3039 scm_cons (proc
, debug
.info
->a
.args
),
3042 RETURN (SCM_APPLY (SCM_I_ENTITYP (proc
)
3043 ? SCM_ENTITY_PROCEDURE (proc
)
3044 : SCM_OPERATOR_PROCEDURE (proc
),
3045 scm_cons2 (proc
, t
.arg1
,
3053 case scm_tc7_subr_0
:
3055 case scm_tc7_subr_1o
:
3056 case scm_tc7_subr_1
:
3057 case scm_tc7_subr_3
:
3062 proc
= SCM_PROCEDURE (proc
);
3064 debug
.info
->a
.proc
= proc
;
3066 if (!SCM_CLOSUREP (proc
))
3068 if (scm_badformalsp (proc
, 2))
3069 goto umwrongnumargs
;
3070 case scm_tcs_closures
:
3073 env
= EXTEND_ENV (SCM_CLOSURE_FORMALS (proc
),
3077 env
= EXTEND_ENV (SCM_CLOSURE_FORMALS (proc
),
3078 scm_list_2 (t
.arg1
, arg2
), SCM_ENV (proc
));
3080 x
= SCM_CLOSURE_BODY (proc
);
3081 goto nontoplevel_begin
;
3085 if (SCM_IMP (x
) || !SCM_CONSP (x
))
3089 debug
.info
->a
.args
= scm_cons2 (t
.arg1
, arg2
,
3090 deval_args (x
, env
, proc
, SCM_CDRLOC (SCM_CDR (debug
.info
->a
.args
))));
3094 switch (SCM_TYP7 (proc
))
3095 { /* have 3 or more arguments */
3097 case scm_tc7_subr_3
:
3098 SCM_ASRTGO (SCM_NULLP (SCM_CDR (x
)), wrongnumargs
);
3099 RETURN (SCM_SUBRF (proc
) (t
.arg1
, arg2
,
3100 SCM_CADDR (debug
.info
->a
.args
)));
3102 #ifdef BUILTIN_RPASUBR
3103 t
.arg1
= SCM_SUBRF(proc
)(t
.arg1
, arg2
);
3104 arg2
= SCM_CDDR (debug
.info
->a
.args
);
3107 t
.arg1
= SCM_SUBRF(proc
)(t
.arg1
, SCM_CAR (arg2
));
3108 arg2
= SCM_CDR (arg2
);
3110 while (SCM_NIMP (arg2
));
3112 #endif /* BUILTIN_RPASUBR */
3113 case scm_tc7_rpsubr
:
3114 #ifdef BUILTIN_RPASUBR
3115 if (SCM_FALSEP (SCM_SUBRF (proc
) (t
.arg1
, arg2
)))
3116 RETURN (SCM_BOOL_F
);
3117 t
.arg1
= SCM_CDDR (debug
.info
->a
.args
);
3120 if (SCM_FALSEP (SCM_SUBRF (proc
) (arg2
, SCM_CAR (t
.arg1
))))
3121 RETURN (SCM_BOOL_F
);
3122 arg2
= SCM_CAR (t
.arg1
);
3123 t
.arg1
= SCM_CDR (t
.arg1
);
3125 while (SCM_NIMP (t
.arg1
));
3126 RETURN (SCM_BOOL_T
);
3127 #else /* BUILTIN_RPASUBR */
3128 RETURN (SCM_APPLY (proc
, t
.arg1
,
3130 SCM_CDDR (debug
.info
->a
.args
),
3132 #endif /* BUILTIN_RPASUBR */
3133 case scm_tc7_lsubr_2
:
3134 RETURN (SCM_SUBRF (proc
) (t
.arg1
, arg2
,
3135 SCM_CDDR (debug
.info
->a
.args
)));
3137 RETURN (SCM_SUBRF (proc
) (debug
.info
->a
.args
));
3139 if (!SCM_SMOB_APPLICABLE_P (proc
))
3141 RETURN (SCM_SMOB_APPLY_3 (proc
, t
.arg1
, arg2
,
3142 SCM_CDDR (debug
.info
->a
.args
)));
3146 proc
= SCM_PROCEDURE (proc
);
3147 debug
.info
->a
.proc
= proc
;
3148 if (!SCM_CLOSUREP (proc
))
3150 if (scm_badargsp (SCM_CLOSURE_FORMALS (proc
), debug
.info
->a
.args
))
3151 goto umwrongnumargs
;
3152 case scm_tcs_closures
:
3153 SCM_SET_ARGSREADY (debug
);
3154 env
= EXTEND_ENV (SCM_CLOSURE_FORMALS (proc
),
3157 x
= SCM_CLOSURE_BODY (proc
);
3158 goto nontoplevel_begin
;
3160 case scm_tc7_subr_3
:
3161 SCM_ASRTGO (SCM_NULLP (SCM_CDR (x
)), wrongnumargs
);
3162 RETURN (SCM_SUBRF (proc
) (t
.arg1
, arg2
, EVALCAR (x
, env
)));
3164 #ifdef BUILTIN_RPASUBR
3165 t
.arg1
= SCM_SUBRF (proc
) (t
.arg1
, arg2
);
3168 t
.arg1
= SCM_SUBRF(proc
)(t
.arg1
, EVALCAR(x
, env
));
3171 while (SCM_NIMP (x
));
3173 #endif /* BUILTIN_RPASUBR */
3174 case scm_tc7_rpsubr
:
3175 #ifdef BUILTIN_RPASUBR
3176 if (SCM_FALSEP (SCM_SUBRF (proc
) (t
.arg1
, arg2
)))
3177 RETURN (SCM_BOOL_F
);
3180 t
.arg1
= EVALCAR (x
, env
);
3181 if (SCM_FALSEP (SCM_SUBRF (proc
) (arg2
, t
.arg1
)))
3182 RETURN (SCM_BOOL_F
);
3186 while (SCM_NIMP (x
));
3187 RETURN (SCM_BOOL_T
);
3188 #else /* BUILTIN_RPASUBR */
3189 RETURN (SCM_APPLY (proc
, t
.arg1
,
3191 scm_eval_args (x
, env
, proc
),
3193 #endif /* BUILTIN_RPASUBR */
3194 case scm_tc7_lsubr_2
:
3195 RETURN (SCM_SUBRF (proc
) (t
.arg1
, arg2
, scm_eval_args (x
, env
, proc
)));
3197 RETURN (SCM_SUBRF (proc
) (scm_cons2 (t
.arg1
,
3199 scm_eval_args (x
, env
, proc
))));
3201 if (!SCM_SMOB_APPLICABLE_P (proc
))
3203 RETURN (SCM_SMOB_APPLY_3 (proc
, t
.arg1
, arg2
,
3204 scm_eval_args (x
, env
, proc
)));
3208 proc
= SCM_PROCEDURE (proc
);
3209 if (!SCM_CLOSUREP (proc
))
3212 SCM formals
= SCM_CLOSURE_FORMALS (proc
);
3213 if (SCM_NULLP (formals
)
3214 || (SCM_CONSP (formals
)
3215 && (SCM_NULLP (SCM_CDR (formals
))
3216 || (SCM_CONSP (SCM_CDR (formals
))
3217 && scm_badargsp (SCM_CDDR (formals
), x
)))))
3218 goto umwrongnumargs
;
3220 case scm_tcs_closures
:
3222 SCM_SET_ARGSREADY (debug
);
3224 env
= EXTEND_ENV (SCM_CLOSURE_FORMALS (proc
),
3227 scm_eval_args (x
, env
, proc
)),
3229 x
= SCM_CLOSURE_BODY (proc
);
3230 goto nontoplevel_begin
;
3232 case scm_tcs_struct
:
3233 if (SCM_OBJ_CLASS_FLAGS (proc
) & SCM_CLASSF_PURE_GENERIC
)
3236 arg2
= debug
.info
->a
.args
;
3238 arg2
= scm_cons2 (t
.arg1
, arg2
, scm_eval_args (x
, env
, proc
));
3240 x
= SCM_ENTITY_PROCEDURE (proc
);
3243 else if (!SCM_I_OPERATORP (proc
))
3247 case scm_tc7_subr_2
:
3248 case scm_tc7_subr_1o
:
3249 case scm_tc7_subr_2o
:
3250 case scm_tc7_subr_0
:
3252 case scm_tc7_subr_1
:
3260 if (CHECK_EXIT
&& SCM_TRAPS_P
)
3261 if (SCM_EXIT_FRAME_P
|| (SCM_TRACE_P
&& SCM_TRACED_FRAME_P (debug
)))
3263 SCM_CLEAR_TRACED_FRAME (debug
);
3264 if (SCM_CHEAPTRAPS_P
)
3265 t
.arg1
= scm_make_debugobj (&debug
);
3269 SCM val
= scm_make_continuation (&first
);
3280 scm_call_3 (SCM_EXIT_FRAME_HDLR
, scm_sym_exit_frame
, t
.arg1
, proc
);
3284 scm_last_debug_frame
= debug
.prev
;
3290 /* SECTION: This code is compiled once.
3296 /* Simple procedure calls
3300 scm_call_0 (SCM proc
)
3302 return scm_apply (proc
, SCM_EOL
, SCM_EOL
);
3306 scm_call_1 (SCM proc
, SCM arg1
)
3308 return scm_apply (proc
, arg1
, scm_listofnull
);
3312 scm_call_2 (SCM proc
, SCM arg1
, SCM arg2
)
3314 return scm_apply (proc
, arg1
, scm_cons (arg2
, scm_listofnull
));
3318 scm_call_3 (SCM proc
, SCM arg1
, SCM arg2
, SCM arg3
)
3320 return scm_apply (proc
, arg1
, scm_cons2 (arg2
, arg3
, scm_listofnull
));
3324 scm_call_4 (SCM proc
, SCM arg1
, SCM arg2
, SCM arg3
, SCM arg4
)
3326 return scm_apply (proc
, arg1
, scm_cons2 (arg2
, arg3
,
3327 scm_cons (arg4
, scm_listofnull
)));
3330 /* Simple procedure applies
3334 scm_apply_0 (SCM proc
, SCM args
)
3336 return scm_apply (proc
, args
, SCM_EOL
);
3340 scm_apply_1 (SCM proc
, SCM arg1
, SCM args
)
3342 return scm_apply (proc
, scm_cons (arg1
, args
), SCM_EOL
);
3346 scm_apply_2 (SCM proc
, SCM arg1
, SCM arg2
, SCM args
)
3348 return scm_apply (proc
, scm_cons2 (arg1
, arg2
, args
), SCM_EOL
);
3352 scm_apply_3 (SCM proc
, SCM arg1
, SCM arg2
, SCM arg3
, SCM args
)
3354 return scm_apply (proc
, scm_cons (arg1
, scm_cons2 (arg2
, arg3
, args
)),
3358 /* This code processes the arguments to apply:
3360 (apply PROC ARG1 ... ARGS)
3362 Given a list (ARG1 ... ARGS), this function conses the ARG1
3363 ... arguments onto the front of ARGS, and returns the resulting
3364 list. Note that ARGS is a list; thus, the argument to this
3365 function is a list whose last element is a list.
3367 Apply calls this function, and applies PROC to the elements of the
3368 result. apply:nconc2last takes care of building the list of
3369 arguments, given (ARG1 ... ARGS).
3371 Rather than do new consing, apply:nconc2last destroys its argument.
3372 On that topic, this code came into my care with the following
3373 beautifully cryptic comment on that topic: "This will only screw
3374 you if you do (scm_apply scm_apply '( ... ))" If you know what
3375 they're referring to, send me a patch to this comment. */
3377 SCM_DEFINE (scm_nconc2last
, "apply:nconc2last", 1, 0, 0,
3379 "Given a list (@var{arg1} @dots{} @var{args}), this function\n"
3380 "conses the @var{arg1} @dots{} arguments onto the front of\n"
3381 "@var{args}, and returns the resulting list. Note that\n"
3382 "@var{args} is a list; thus, the argument to this function is\n"
3383 "a list whose last element is a list.\n"
3384 "Note: Rather than do new consing, @code{apply:nconc2last}\n"
3385 "destroys its argument, so use with care.")
3386 #define FUNC_NAME s_scm_nconc2last
3389 SCM_VALIDATE_NONEMPTYLIST (1,lst
);
3391 while (!SCM_NULLP (SCM_CDR (*lloc
)))
3392 lloc
= SCM_CDRLOC (*lloc
);
3393 SCM_ASSERT (scm_ilength (SCM_CAR (*lloc
)) >= 0, lst
, SCM_ARG1
, FUNC_NAME
);
3394 *lloc
= SCM_CAR (*lloc
);
3402 /* SECTION: When DEVAL is defined this code yields scm_dapply.
3403 * It is compiled twice.
3408 scm_apply (SCM proc
, SCM arg1
, SCM args
)
3414 scm_dapply (SCM proc
, SCM arg1
, SCM args
)
3419 /* Apply a function to a list of arguments.
3421 This function is exported to the Scheme level as taking two
3422 required arguments and a tail argument, as if it were:
3423 (lambda (proc arg1 . args) ...)
3424 Thus, if you just have a list of arguments to pass to a procedure,
3425 pass the list as ARG1, and '() for ARGS. If you have some fixed
3426 args, pass the first as ARG1, then cons any remaining fixed args
3427 onto the front of your argument list, and pass that as ARGS. */
3430 SCM_APPLY (SCM proc
, SCM arg1
, SCM args
)
3432 #ifdef DEBUG_EXTENSIONS
3434 scm_t_debug_frame debug
;
3435 scm_t_debug_info debug_vect_body
;
3436 debug
.prev
= scm_last_debug_frame
;
3437 debug
.status
= SCM_APPLYFRAME
;
3438 debug
.vect
= &debug_vect_body
;
3439 debug
.vect
[0].a
.proc
= proc
;
3440 debug
.vect
[0].a
.args
= SCM_EOL
;
3441 scm_last_debug_frame
= &debug
;
3444 return scm_dapply (proc
, arg1
, args
);
3448 SCM_ASRTGO (SCM_NIMP (proc
), badproc
);
3450 /* If ARGS is the empty list, then we're calling apply with only two
3451 arguments --- ARG1 is the list of arguments for PROC. Whatever
3452 the case, futz with things so that ARG1 is the first argument to
3453 give to PROC (or SCM_UNDEFINED if no args), and ARGS contains the
3456 Setting the debug apply frame args this way is pretty messy.
3457 Perhaps we should store arg1 and args directly in the frame as
3458 received, and let scm_frame_arguments unpack them, because that's
3459 a relatively rare operation. This works for now; if the Guile
3460 developer archives are still around, see Mikael's post of
3462 if (SCM_NULLP (args
))
3464 if (SCM_NULLP (arg1
))
3466 arg1
= SCM_UNDEFINED
;
3468 debug
.vect
[0].a
.args
= SCM_EOL
;
3474 debug
.vect
[0].a
.args
= arg1
;
3476 args
= SCM_CDR (arg1
);
3477 arg1
= SCM_CAR (arg1
);
3482 args
= scm_nconc2last (args
);
3484 debug
.vect
[0].a
.args
= scm_cons (arg1
, args
);
3488 if (SCM_ENTER_FRAME_P
&& SCM_TRAPS_P
)
3491 if (SCM_CHEAPTRAPS_P
)
3492 tmp
= scm_make_debugobj (&debug
);
3497 tmp
= scm_make_continuation (&first
);
3502 scm_call_2 (SCM_ENTER_FRAME_HDLR
, scm_sym_enter_frame
, tmp
);
3509 switch (SCM_TYP7 (proc
))
3511 case scm_tc7_subr_2o
:
3512 args
= SCM_NULLP (args
) ? SCM_UNDEFINED
: SCM_CAR (args
);
3513 RETURN (SCM_SUBRF (proc
) (arg1
, args
));
3514 case scm_tc7_subr_2
:
3515 SCM_ASRTGO (!SCM_NULLP (args
) && SCM_NULLP (SCM_CDR (args
)),
3517 args
= SCM_CAR (args
);
3518 RETURN (SCM_SUBRF (proc
) (arg1
, args
));
3519 case scm_tc7_subr_0
:
3520 SCM_ASRTGO (SCM_UNBNDP (arg1
), wrongnumargs
);
3521 RETURN (SCM_SUBRF (proc
) ());
3522 case scm_tc7_subr_1
:
3523 SCM_ASRTGO (!SCM_UNBNDP (arg1
), wrongnumargs
);
3524 case scm_tc7_subr_1o
:
3525 SCM_ASRTGO (SCM_NULLP (args
), wrongnumargs
);
3526 RETURN (SCM_SUBRF (proc
) (arg1
));
3528 SCM_ASRTGO (!SCM_UNBNDP (arg1
) && SCM_NULLP (args
), wrongnumargs
);
3529 if (SCM_SUBRF (proc
))
3531 if (SCM_INUMP (arg1
))
3533 RETURN (scm_make_real (SCM_DSUBRF (proc
) ((double) SCM_INUM (arg1
))));
3535 else if (SCM_REALP (arg1
))
3537 RETURN (scm_make_real (SCM_DSUBRF (proc
) (SCM_REAL_VALUE (arg1
))));
3540 else if (SCM_BIGP (arg1
))
3541 RETURN (scm_make_real (SCM_DSUBRF (proc
) (scm_i_big2dbl (arg1
))));
3543 SCM_WTA_DISPATCH_1 (*SCM_SUBR_GENERIC (proc
), arg1
,
3544 SCM_ARG1
, SCM_SYMBOL_CHARS (SCM_SNAME (proc
)));
3546 proc
= SCM_SNAME (proc
);
3548 char *chrs
= SCM_SYMBOL_CHARS (proc
) + SCM_SYMBOL_LENGTH (proc
) - 1;
3549 while ('c' != *--chrs
)
3551 SCM_ASSERT (SCM_CONSP (arg1
),
3552 arg1
, SCM_ARG1
, SCM_SYMBOL_CHARS (proc
));
3553 arg1
= ('a' == *chrs
) ? SCM_CAR (arg1
) : SCM_CDR (arg1
);
3557 case scm_tc7_subr_3
:
3558 SCM_ASRTGO (!SCM_NULLP (args
)
3559 && !SCM_NULLP (SCM_CDR (args
))
3560 && SCM_NULLP (SCM_CDDR (args
)),
3562 RETURN (SCM_SUBRF (proc
) (arg1
, SCM_CAR (args
), SCM_CADR (args
)));
3565 RETURN (SCM_SUBRF (proc
) (SCM_UNBNDP (arg1
) ? SCM_EOL
: debug
.vect
[0].a
.args
));
3567 RETURN (SCM_SUBRF (proc
) (SCM_UNBNDP (arg1
) ? SCM_EOL
: scm_cons (arg1
, args
)));
3569 case scm_tc7_lsubr_2
:
3570 SCM_ASRTGO (SCM_CONSP (args
), wrongnumargs
);
3571 RETURN (SCM_SUBRF (proc
) (arg1
, SCM_CAR (args
), SCM_CDR (args
)));
3573 if (SCM_NULLP (args
))
3574 RETURN (SCM_SUBRF (proc
) (arg1
, SCM_UNDEFINED
));
3575 while (SCM_NIMP (args
))
3577 SCM_ASSERT (SCM_CONSP (args
), args
, SCM_ARG2
, "apply");
3578 arg1
= SCM_SUBRF (proc
) (arg1
, SCM_CAR (args
));
3579 args
= SCM_CDR (args
);
3582 case scm_tc7_rpsubr
:
3583 if (SCM_NULLP (args
))
3584 RETURN (SCM_BOOL_T
);
3585 while (SCM_NIMP (args
))
3587 SCM_ASSERT (SCM_CONSP (args
), args
, SCM_ARG2
, "apply");
3588 if (SCM_FALSEP (SCM_SUBRF (proc
) (arg1
, SCM_CAR (args
))))
3589 RETURN (SCM_BOOL_F
);
3590 arg1
= SCM_CAR (args
);
3591 args
= SCM_CDR (args
);
3593 RETURN (SCM_BOOL_T
);
3594 case scm_tcs_closures
:
3596 arg1
= (SCM_UNBNDP (arg1
) ? SCM_EOL
: debug
.vect
[0].a
.args
);
3598 arg1
= (SCM_UNBNDP (arg1
) ? SCM_EOL
: scm_cons (arg1
, args
));
3600 #ifndef SCM_RECKLESS
3601 if (scm_badargsp (SCM_CLOSURE_FORMALS (proc
), arg1
))
3605 /* Copy argument list */
3610 SCM tl
= args
= scm_cons (SCM_CAR (arg1
), SCM_UNSPECIFIED
);
3611 while (arg1
= SCM_CDR (arg1
), SCM_CONSP (arg1
))
3613 SCM_SETCDR (tl
, scm_cons (SCM_CAR (arg1
),
3617 SCM_SETCDR (tl
, arg1
);
3620 args
= EXTEND_ENV (SCM_CLOSURE_FORMALS (proc
), args
, SCM_ENV (proc
));
3621 proc
= SCM_CLOSURE_BODY (proc
);
3624 while (!SCM_NULLP (arg1
= SCM_CDR (arg1
)))
3626 if (SCM_IMP (SCM_CAR (proc
)))
3628 if (SCM_ISYMP (SCM_CAR (proc
)))
3630 proc
= scm_m_expand_body (proc
, args
);
3634 SCM_VALIDATE_NON_EMPTY_COMBINATION (SCM_CAR (proc
));
3637 SCM_CEVAL (SCM_CAR (proc
), args
);
3640 RETURN (EVALCAR (proc
, args
));
3642 if (!SCM_SMOB_APPLICABLE_P (proc
))
3644 if (SCM_UNBNDP (arg1
))
3645 RETURN (SCM_SMOB_APPLY_0 (proc
));
3646 else if (SCM_NULLP (args
))
3647 RETURN (SCM_SMOB_APPLY_1 (proc
, arg1
));
3648 else if (SCM_NULLP (SCM_CDR (args
)))
3649 RETURN (SCM_SMOB_APPLY_2 (proc
, arg1
, SCM_CAR (args
)));
3651 RETURN (SCM_SMOB_APPLY_3 (proc
, arg1
, SCM_CAR (args
), SCM_CDR (args
)));
3654 args
= (SCM_UNBNDP(arg1
) ? SCM_EOL
: debug
.vect
[0].a
.args
);
3656 proc
= SCM_CCLO_SUBR (proc
);
3657 debug
.vect
[0].a
.proc
= proc
;
3658 debug
.vect
[0].a
.args
= scm_cons (arg1
, args
);
3660 args
= (SCM_UNBNDP(arg1
) ? SCM_EOL
: scm_cons (arg1
, args
));
3662 proc
= SCM_CCLO_SUBR (proc
);
3666 proc
= SCM_PROCEDURE (proc
);
3668 debug
.vect
[0].a
.proc
= proc
;
3671 case scm_tcs_struct
:
3672 if (SCM_OBJ_CLASS_FLAGS (proc
) & SCM_CLASSF_PURE_GENERIC
)
3675 args
= (SCM_UNBNDP(arg1
) ? SCM_EOL
: debug
.vect
[0].a
.args
);
3677 args
= (SCM_UNBNDP(arg1
) ? SCM_EOL
: scm_cons (arg1
, args
));
3679 RETURN (scm_apply_generic (proc
, args
));
3681 else if (!SCM_I_OPERATORP (proc
))
3686 args
= (SCM_UNBNDP(arg1
) ? SCM_EOL
: debug
.vect
[0].a
.args
);
3688 args
= (SCM_UNBNDP(arg1
) ? SCM_EOL
: scm_cons (arg1
, args
));
3691 proc
= (SCM_I_ENTITYP (proc
)
3692 ? SCM_ENTITY_PROCEDURE (proc
)
3693 : SCM_OPERATOR_PROCEDURE (proc
));
3695 debug
.vect
[0].a
.proc
= proc
;
3696 debug
.vect
[0].a
.args
= scm_cons (arg1
, args
);
3698 if (SCM_NIMP (proc
))
3704 scm_wrong_num_args (proc
);
3707 scm_wrong_type_arg ("apply", SCM_ARG1
, proc
);
3712 if (CHECK_EXIT
&& SCM_TRAPS_P
)
3713 if (SCM_EXIT_FRAME_P
|| (SCM_TRACE_P
&& SCM_TRACED_FRAME_P (debug
)))
3715 SCM_CLEAR_TRACED_FRAME (debug
);
3716 if (SCM_CHEAPTRAPS_P
)
3717 arg1
= scm_make_debugobj (&debug
);
3721 SCM val
= scm_make_continuation (&first
);
3732 scm_call_3 (SCM_EXIT_FRAME_HDLR
, scm_sym_exit_frame
, arg1
, proc
);
3736 scm_last_debug_frame
= debug
.prev
;
3742 /* SECTION: The rest of this file is only read once.
3747 /* Typechecking for multi-argument MAP and FOR-EACH.
3749 Verify that each element of the vector ARGV, except for the first,
3750 is a proper list whose length is LEN. Attribute errors to WHO,
3751 and claim that the i'th element of ARGV is WHO's i+2'th argument. */
3753 check_map_args (SCM argv
,
3760 SCM
*ve
= SCM_VELTS (argv
);
3763 for (i
= SCM_VECTOR_LENGTH (argv
) - 1; i
>= 1; i
--)
3765 long elt_len
= scm_ilength (ve
[i
]);
3770 scm_apply_generic (gf
, scm_cons (proc
, args
));
3772 scm_wrong_type_arg (who
, i
+ 2, ve
[i
]);
3776 scm_out_of_range (who
, ve
[i
]);
3779 scm_remember_upto_here_1 (argv
);
3783 SCM_GPROC (s_map
, "map", 2, 0, 1, scm_map
, g_map
);
3785 /* Note: Currently, scm_map applies PROC to the argument list(s)
3786 sequentially, starting with the first element(s). This is used in
3787 evalext.c where the Scheme procedure `map-in-order', which guarantees
3788 sequential behaviour, is implemented using scm_map. If the
3789 behaviour changes, we need to update `map-in-order'.
3793 scm_map (SCM proc
, SCM arg1
, SCM args
)
3794 #define FUNC_NAME s_map
3799 SCM
*ve
= &args
; /* Keep args from being optimized away. */
3801 len
= scm_ilength (arg1
);
3802 SCM_GASSERTn (len
>= 0,
3803 g_map
, scm_cons2 (proc
, arg1
, args
), SCM_ARG2
, s_map
);
3804 SCM_VALIDATE_REST_ARGUMENT (args
);
3805 if (SCM_NULLP (args
))
3807 while (SCM_NIMP (arg1
))
3809 *pres
= scm_list_1 (scm_apply (proc
, SCM_CAR (arg1
), scm_listofnull
));
3810 pres
= SCM_CDRLOC (*pres
);
3811 arg1
= SCM_CDR (arg1
);
3815 args
= scm_vector (arg1
= scm_cons (arg1
, args
));
3816 ve
= SCM_VELTS (args
);
3817 #ifndef SCM_RECKLESS
3818 check_map_args (args
, len
, g_map
, proc
, arg1
, s_map
);
3823 for (i
= SCM_VECTOR_LENGTH (args
) - 1; i
>= 0; i
--)
3825 if (SCM_IMP (ve
[i
]))
3827 arg1
= scm_cons (SCM_CAR (ve
[i
]), arg1
);
3828 ve
[i
] = SCM_CDR (ve
[i
]);
3830 *pres
= scm_list_1 (scm_apply (proc
, arg1
, SCM_EOL
));
3831 pres
= SCM_CDRLOC (*pres
);
3837 SCM_GPROC (s_for_each
, "for-each", 2, 0, 1, scm_for_each
, g_for_each
);
3840 scm_for_each (SCM proc
, SCM arg1
, SCM args
)
3841 #define FUNC_NAME s_for_each
3843 SCM
*ve
= &args
; /* Keep args from being optimized away. */
3845 len
= scm_ilength (arg1
);
3846 SCM_GASSERTn (len
>= 0, g_for_each
, scm_cons2 (proc
, arg1
, args
),
3847 SCM_ARG2
, s_for_each
);
3848 SCM_VALIDATE_REST_ARGUMENT (args
);
3851 while SCM_NIMP (arg1
)
3853 scm_apply (proc
, SCM_CAR (arg1
), scm_listofnull
);
3854 arg1
= SCM_CDR (arg1
);
3856 return SCM_UNSPECIFIED
;
3858 args
= scm_vector (arg1
= scm_cons (arg1
, args
));
3859 ve
= SCM_VELTS (args
);
3860 #ifndef SCM_RECKLESS
3861 check_map_args (args
, len
, g_for_each
, proc
, arg1
, s_for_each
);
3866 for (i
= SCM_VECTOR_LENGTH (args
) - 1; i
>= 0; i
--)
3869 (ve
[i
]) return SCM_UNSPECIFIED
;
3870 arg1
= scm_cons (SCM_CAR (ve
[i
]), arg1
);
3871 ve
[i
] = SCM_CDR (ve
[i
]);
3873 scm_apply (proc
, arg1
, SCM_EOL
);
3880 scm_closure (SCM code
, SCM env
)
3883 SCM closcar
= scm_cons (code
, SCM_EOL
);
3884 z
= scm_alloc_cell (SCM_UNPACK (closcar
) + scm_tc3_closure
,
3886 scm_remember_upto_here (closcar
);
3891 scm_t_bits scm_tc16_promise
;
3894 scm_makprom (SCM code
)
3896 SCM_RETURN_NEWSMOB (scm_tc16_promise
, SCM_UNPACK (code
));
3902 promise_print (SCM exp
, SCM port
, scm_print_state
*pstate
)
3904 int writingp
= SCM_WRITINGP (pstate
);
3905 scm_puts ("#<promise ", port
);
3906 SCM_SET_WRITINGP (pstate
, 1);
3907 scm_iprin1 (SCM_CELL_OBJECT_1 (exp
), port
, pstate
);
3908 SCM_SET_WRITINGP (pstate
, writingp
);
3909 scm_putc ('>', port
);
3914 SCM_DEFINE (scm_force
, "force", 1, 0, 0,
3916 "If the promise @var{x} has not been computed yet, compute and\n"
3917 "return @var{x}, otherwise just return the previously computed\n"
3919 #define FUNC_NAME s_scm_force
3921 SCM_VALIDATE_SMOB (1, x
, promise
);
3922 if (!((1L << 16) & SCM_CELL_WORD_0 (x
)))
3924 SCM ans
= scm_call_0 (SCM_CELL_OBJECT_1 (x
));
3925 if (!((1L << 16) & SCM_CELL_WORD_0 (x
)))
3928 SCM_SET_CELL_OBJECT_1 (x
, ans
);
3929 SCM_SET_CELL_WORD_0 (x
, SCM_CELL_WORD_0 (x
) | (1L << 16));
3933 return SCM_CELL_OBJECT_1 (x
);
3938 SCM_DEFINE (scm_promise_p
, "promise?", 1, 0, 0,
3940 "Return true if @var{obj} is a promise, i.e. a delayed computation\n"
3941 "(@pxref{Delayed evaluation,,,r5rs.info,The Revised^5 Report on Scheme}).")
3942 #define FUNC_NAME s_scm_promise_p
3944 return SCM_BOOL (SCM_TYP16_PREDICATE (scm_tc16_promise
, obj
));
3949 SCM_DEFINE (scm_cons_source
, "cons-source", 3, 0, 0,
3950 (SCM xorig
, SCM x
, SCM y
),
3951 "Create and return a new pair whose car and cdr are @var{x} and @var{y}.\n"
3952 "Any source properties associated with @var{xorig} are also associated\n"
3953 "with the new pair.")
3954 #define FUNC_NAME s_scm_cons_source
3957 z
= scm_cons (x
, y
);
3958 /* Copy source properties possibly associated with xorig. */
3959 p
= scm_whash_lookup (scm_source_whash
, xorig
);
3961 scm_whash_insert (scm_source_whash
, z
, p
);
3967 SCM_DEFINE (scm_copy_tree
, "copy-tree", 1, 0, 0,
3969 "Recursively copy the data tree that is bound to @var{obj}, and return a\n"
3970 "pointer to the new data structure. @code{copy-tree} recurses down the\n"
3971 "contents of both pairs and vectors (since both cons cells and vector\n"
3972 "cells may point to arbitrary objects), and stops recursing when it hits\n"
3973 "any other object.")
3974 #define FUNC_NAME s_scm_copy_tree
3979 if (SCM_VECTORP (obj
))
3981 unsigned long i
= SCM_VECTOR_LENGTH (obj
);
3982 ans
= scm_c_make_vector (i
, SCM_UNSPECIFIED
);
3984 SCM_VELTS (ans
)[i
] = scm_copy_tree (SCM_VELTS (obj
)[i
]);
3987 if (!SCM_CONSP (obj
))
3989 ans
= tl
= scm_cons_source (obj
,
3990 scm_copy_tree (SCM_CAR (obj
)),
3992 while (obj
= SCM_CDR (obj
), SCM_CONSP (obj
))
3994 SCM_SETCDR (tl
, scm_cons (scm_copy_tree (SCM_CAR (obj
)),
3998 SCM_SETCDR (tl
, obj
);
4004 /* We have three levels of EVAL here:
4006 - scm_i_eval (exp, env)
4008 evaluates EXP in environment ENV. ENV is a lexical environment
4009 structure as used by the actual tree code evaluator. When ENV is
4010 a top-level environment, then changes to the current module are
4011 tracked by updating ENV so that it continues to be in sync with
4014 - scm_primitive_eval (exp)
4016 evaluates EXP in the top-level environment as determined by the
4017 current module. This is done by constructing a suitable
4018 environment and calling scm_i_eval. Thus, changes to the
4019 top-level module are tracked normally.
4021 - scm_eval (exp, mod)
4023 evaluates EXP while MOD is the current module. This is done by
4024 setting the current module to MOD, invoking scm_primitive_eval on
4025 EXP, and then restoring the current module to the value it had
4026 previously. That is, while EXP is evaluated, changes to the
4027 current module are tracked, but these changes do not persist when
4030 For each level of evals, there are two variants, distinguished by a
4031 _x suffix: the ordinary variant does not modify EXP while the _x
4032 variant can destructively modify EXP into something completely
4033 unintelligible. A Scheme data structure passed as EXP to one of the
4034 _x variants should not ever be used again for anything. So when in
4035 doubt, use the ordinary variant.
4040 scm_i_eval_x (SCM exp
, SCM env
)
4042 return SCM_XEVAL (exp
, env
);
4046 scm_i_eval (SCM exp
, SCM env
)
4048 exp
= scm_copy_tree (exp
);
4049 return SCM_XEVAL (exp
, env
);
4053 scm_primitive_eval_x (SCM exp
)
4056 SCM transformer
= scm_current_module_transformer ();
4057 if (SCM_NIMP (transformer
))
4058 exp
= scm_call_1 (transformer
, exp
);
4059 env
= scm_top_level_env (scm_current_module_lookup_closure ());
4060 return scm_i_eval_x (exp
, env
);
4063 SCM_DEFINE (scm_primitive_eval
, "primitive-eval", 1, 0, 0,
4065 "Evaluate @var{exp} in the top-level environment specified by\n"
4066 "the current module.")
4067 #define FUNC_NAME s_scm_primitive_eval
4070 SCM transformer
= scm_current_module_transformer ();
4071 if (SCM_NIMP (transformer
))
4072 exp
= scm_call_1 (transformer
, exp
);
4073 env
= scm_top_level_env (scm_current_module_lookup_closure ());
4074 return scm_i_eval (exp
, env
);
4078 /* Eval does not take the second arg optionally. This is intentional
4079 * in order to be R5RS compatible, and to prepare for the new module
4080 * system, where we would like to make the choice of evaluation
4081 * environment explicit. */
4084 change_environment (void *data
)
4086 SCM pair
= SCM_PACK (data
);
4087 SCM new_module
= SCM_CAR (pair
);
4088 SCM old_module
= scm_current_module ();
4089 SCM_SETCDR (pair
, old_module
);
4090 scm_set_current_module (new_module
);
4095 restore_environment (void *data
)
4097 SCM pair
= SCM_PACK (data
);
4098 SCM old_module
= SCM_CDR (pair
);
4099 SCM new_module
= scm_current_module ();
4100 SCM_SETCAR (pair
, new_module
);
4101 scm_set_current_module (old_module
);
4105 inner_eval_x (void *data
)
4107 return scm_primitive_eval_x (SCM_PACK(data
));
4111 scm_eval_x (SCM exp
, SCM module
)
4112 #define FUNC_NAME "eval!"
4114 SCM_VALIDATE_MODULE (2, module
);
4116 return scm_internal_dynamic_wind
4117 (change_environment
, inner_eval_x
, restore_environment
,
4118 (void *) SCM_UNPACK (exp
),
4119 (void *) SCM_UNPACK (scm_cons (module
, SCM_BOOL_F
)));
4124 inner_eval (void *data
)
4126 return scm_primitive_eval (SCM_PACK(data
));
4129 SCM_DEFINE (scm_eval
, "eval", 2, 0, 0,
4130 (SCM exp
, SCM module
),
4131 "Evaluate @var{exp}, a list representing a Scheme expression,\n"
4132 "in the top-level environment specified by @var{module}.\n"
4133 "While @var{exp} is evaluated (using @code{primitive-eval}),\n"
4134 "@var{module} is made the current module. The current module\n"
4135 "is reset to its previous value when @var{eval} returns.")
4136 #define FUNC_NAME s_scm_eval
4138 SCM_VALIDATE_MODULE (2, module
);
4140 return scm_internal_dynamic_wind
4141 (change_environment
, inner_eval
, restore_environment
,
4142 (void *) SCM_UNPACK (exp
),
4143 (void *) SCM_UNPACK (scm_cons (module
, SCM_BOOL_F
)));
4148 /* At this point, scm_deval and scm_dapply are generated.
4151 #ifdef DEBUG_EXTENSIONS
4161 scm_init_opts (scm_evaluator_traps
,
4162 scm_evaluator_trap_table
,
4163 SCM_N_EVALUATOR_TRAPS
);
4164 scm_init_opts (scm_eval_options_interface
,
4166 SCM_N_EVAL_OPTIONS
);
4168 scm_tc16_promise
= scm_make_smob_type ("promise", 0);
4169 scm_set_smob_mark (scm_tc16_promise
, scm_markcdr
);
4170 scm_set_smob_print (scm_tc16_promise
, promise_print
);
4172 /* Dirk:Fixme:: make scm_undefineds local to eval.c: it's only used here. */
4173 scm_undefineds
= scm_list_1 (SCM_UNDEFINED
);
4174 SCM_SETCDR (scm_undefineds
, scm_undefineds
);
4175 scm_listofnull
= scm_list_1 (SCM_EOL
);
4177 scm_f_apply
= scm_c_define_subr ("apply", scm_tc7_lsubr_2
, scm_apply
);
4182 #ifndef SCM_MAGIC_SNARFER
4183 #include "libguile/eval.x"
4186 scm_c_define ("nil", scm_lisp_nil
);
4187 scm_c_define ("t", scm_lisp_t
);
4189 scm_add_feature ("delay");