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. */
45 /* This file is read twice in order to produce debugging versions of
46 * scm_ceval and scm_apply. These functions, scm_deval and
47 * scm_dapply, are produced when we define the preprocessor macro
48 * DEVAL. The file is divided into sections which are treated
49 * differently with respect to DEVAL. The heads of these sections are
50 * marked with the string "SECTION:".
53 /* SECTION: This code is compiled once.
58 /* We need this to get the definitions for HAVE_ALLOCA_H, etc. */
59 #include "libguile/scmconfig.h"
61 /* AIX requires this to be the first thing in the file. The #pragma
62 directive is indented so pre-ANSI compilers will ignore it, rather
71 # ifndef alloca /* predefined by HP cc +Olibcalls */
78 #include "libguile/_scm.h"
79 #include "libguile/debug.h"
80 #include "libguile/dynwind.h"
81 #include "libguile/alist.h"
82 #include "libguile/eq.h"
83 #include "libguile/continuations.h"
84 #include "libguile/throw.h"
85 #include "libguile/smob.h"
86 #include "libguile/macros.h"
87 #include "libguile/procprop.h"
88 #include "libguile/hashtab.h"
89 #include "libguile/hash.h"
90 #include "libguile/srcprop.h"
91 #include "libguile/stackchk.h"
92 #include "libguile/objects.h"
93 #include "libguile/async.h"
94 #include "libguile/feature.h"
95 #include "libguile/modules.h"
96 #include "libguile/ports.h"
97 #include "libguile/root.h"
98 #include "libguile/vectors.h"
99 #include "libguile/fluids.h"
100 #include "libguile/values.h"
102 #include "libguile/validate.h"
103 #include "libguile/eval.h"
107 #define SCM_VALIDATE_NON_EMPTY_COMBINATION(x) \
109 if (SCM_EQ_P ((x), SCM_EOL)) \
110 scm_misc_error (NULL, scm_s_expression, SCM_EOL); \
115 /* The evaluator contains a plethora of EVAL symbols.
116 * This is an attempt at explanation.
118 * The following macros should be used in code which is read twice
119 * (where the choice of evaluator is hard soldered):
121 * SCM_CEVAL is the symbol used within one evaluator to call itself.
122 * Originally, it is defined to scm_ceval, but is redefined to
123 * scm_deval during the second pass.
125 * SIDEVAL corresponds to SCM_CEVAL, but is used in situations where
126 * only side effects of expressions matter. All immediates are
129 * SCM_EVALIM is used when it is known that the expression is an
130 * immediate. (This macro never calls an evaluator.)
132 * EVALCAR evaluates the car of an expression.
134 * EVALCELLCAR is like EVALCAR, but is used when it is known that the
135 * car is a lisp cell.
137 * The following macros should be used in code which is read once
138 * (where the choice of evaluator is dynamic):
140 * SCM_XEVAL takes care of immediates without calling an evaluator. It
141 * then calls scm_ceval *or* scm_deval, depending on the debugging
144 * SCM_XEVALCAR corresponds to EVALCAR, but uses scm_ceval *or* scm_deval
145 * depending on the debugging mode.
147 * The main motivation for keeping this plethora is efficiency
148 * together with maintainability (=> locality of code).
151 #define SCM_CEVAL scm_ceval
152 #define SIDEVAL(x, env) if (SCM_NIMP (x)) SCM_CEVAL((x), (env))
154 #define EVALCELLCAR(x, env) (SCM_SYMBOLP (SCM_CAR (x)) \
155 ? *scm_lookupcar (x, env, 1) \
156 : SCM_CEVAL (SCM_CAR (x), env))
158 #define EVALCAR(x, env) (!SCM_CELLP (SCM_CAR (x)) \
159 ? SCM_EVALIM (SCM_CAR (x), env) \
160 : EVALCELLCAR (x, env))
162 #define EXTEND_ENV SCM_EXTEND_ENV
164 #ifdef MEMOIZE_LOCALS
167 scm_ilookup (SCM iloc
, SCM env
)
169 register long ir
= SCM_IFRAME (iloc
);
170 register SCM er
= env
;
171 for (; 0 != ir
; --ir
)
174 for (ir
= SCM_IDIST (iloc
); 0 != ir
; --ir
)
176 if (SCM_ICDRP (iloc
))
177 return SCM_CDRLOC (er
);
178 return SCM_CARLOC (SCM_CDR (er
));
184 /* The Lookup Car Race
187 Memoization of variables and special forms is done while executing
188 the code for the first time. As long as there is only one thread
189 everything is fine, but as soon as two threads execute the same
190 code concurrently `for the first time' they can come into conflict.
192 This memoization includes rewriting variable references into more
193 efficient forms and expanding macros. Furthermore, macro expansion
194 includes `compiling' special forms like `let', `cond', etc. into
195 tree-code instructions.
197 There shouldn't normally be a problem with memoizing local and
198 global variable references (into ilocs and variables), because all
199 threads will mutate the code in *exactly* the same way and (if I
200 read the C code correctly) it is not possible to observe a half-way
201 mutated cons cell. The lookup procedure can handle this
202 transparently without any critical sections.
204 It is different with macro expansion, because macro expansion
205 happens outside of the lookup procedure and can't be
206 undone. Therefore the lookup procedure can't cope with it. It has
207 to indicate failure when it detects a lost race and hope that the
208 caller can handle it. Luckily, it turns out that this is the case.
210 An example to illustrate this: Suppose that the following form will
211 be memoized concurrently by two threads
215 Let's first examine the lookup of X in the body. The first thread
216 decides that it has to find the symbol "x" in the environment and
217 starts to scan it. Then the other thread takes over and actually
218 overtakes the first. It looks up "x" and substitutes an
219 appropriate iloc for it. Now the first thread continues and
220 completes its lookup. It comes to exactly the same conclusions as
221 the second one and could - without much ado - just overwrite the
222 iloc with the same iloc.
224 But let's see what will happen when the race occurs while looking
225 up the symbol "let" at the start of the form. It could happen that
226 the second thread interrupts the lookup of the first thread and not
227 only substitutes a variable for it but goes right ahead and
228 replaces it with the compiled form (#@let* (x 12) x). Now, when
229 the first thread completes its lookup, it would replace the #@let*
230 with a variable containing the "let" binding, effectively reverting
231 the form to (let (x 12) x). This is wrong. It has to detect that
232 it has lost the race and the evaluator has to reconsider the
233 changed form completely.
235 This race condition could be resolved with some kind of traffic
236 light (like mutexes) around scm_lookupcar, but I think that it is
237 best to avoid them in this case. They would serialize memoization
238 completely and because lookup involves calling arbitrary Scheme
239 code (via the lookup-thunk), threads could be blocked for an
240 arbitrary amount of time or even deadlock. But with the current
241 solution a lot of unnecessary work is potentially done. */
243 /* SCM_LOOKUPCAR1 is was SCM_LOOKUPCAR used to be but is allowed to
244 return NULL to indicate a failed lookup due to some race conditions
245 between threads. This only happens when VLOC is the first cell of
246 a special form that will eventually be memoized (like `let', etc.)
247 In that case the whole lookup is bogus and the caller has to
248 reconsider the complete special form.
250 SCM_LOOKUPCAR is still there, of course. It just calls
251 SCM_LOOKUPCAR1 and aborts on recieving NULL. So SCM_LOOKUPCAR
252 should only be called when it is known that VLOC is not the first
253 pair of a special form. Otherwise, use SCM_LOOKUPCAR1 and check
254 for NULL. I think I've found the only places where this
257 #endif /* USE_THREADS */
259 SCM_SYMBOL (scm_unbound_variable_key
, "unbound-variable");
263 scm_lookupcar1 (SCM vloc
, SCM genv
, int check
)
266 scm_lookupcar (SCM vloc
, SCM genv
, int check
)
270 register SCM
*al
, fl
, var
= SCM_CAR (vloc
);
271 #ifdef MEMOIZE_LOCALS
272 register SCM iloc
= SCM_ILOC00
;
274 for (; SCM_NIMP (env
); env
= SCM_CDR (env
))
276 if (!SCM_CONSP (SCM_CAR (env
)))
278 al
= SCM_CARLOC (env
);
279 for (fl
= SCM_CAR (*al
); SCM_NIMP (fl
); fl
= SCM_CDR (fl
))
283 if (SCM_EQ_P (fl
, var
))
285 #ifdef MEMOIZE_LOCALS
287 if (! SCM_EQ_P (SCM_CAR (vloc
), var
))
290 SCM_SET_CELL_WORD_0 (vloc
, SCM_UNPACK (iloc
) + SCM_ICDR
);
292 return SCM_CDRLOC (*al
);
297 al
= SCM_CDRLOC (*al
);
298 if (SCM_EQ_P (SCM_CAR (fl
), var
))
300 #ifdef MEMOIZE_LOCALS
301 #ifndef SCM_RECKLESS /* letrec inits to SCM_UNDEFINED */
302 if (SCM_UNBNDP (SCM_CAR (*al
)))
309 if (!SCM_EQ_P (SCM_CAR (vloc
), var
))
312 SCM_SETCAR (vloc
, iloc
);
314 return SCM_CARLOC (*al
);
316 #ifdef MEMOIZE_LOCALS
317 iloc
= SCM_PACK (SCM_UNPACK (iloc
) + SCM_IDINC
);
320 #ifdef MEMOIZE_LOCALS
321 iloc
= SCM_PACK ((~SCM_IDSTMSK
) & (SCM_UNPACK(iloc
) + SCM_IFRINC
));
325 SCM top_thunk
, real_var
;
328 top_thunk
= SCM_CAR (env
); /* env now refers to a
329 top level env thunk */
333 top_thunk
= SCM_BOOL_F
;
334 real_var
= scm_sym2var (var
, top_thunk
, SCM_BOOL_F
);
335 if (SCM_FALSEP (real_var
))
339 if (!SCM_NULLP (env
) || SCM_UNBNDP (SCM_VARIABLE_REF (real_var
)))
342 /* scm_everr (vloc, genv,...) */
346 scm_error (scm_unbound_variable_key
, NULL
,
347 "Unbound variable: ~S",
348 scm_cons (var
, SCM_EOL
), SCM_BOOL_F
);
350 scm_misc_error (NULL
, "Damaged environment: ~S",
351 scm_cons (var
, SCM_EOL
));
355 /* A variable could not be found, but we shall
356 not throw an error. */
357 static SCM undef_object
= SCM_UNDEFINED
;
358 return &undef_object
;
364 if (!SCM_EQ_P (SCM_CAR (vloc
), var
))
366 /* Some other thread has changed the very cell we are working
367 on. In effect, it must have done our job or messed it up
370 var
= SCM_CAR (vloc
);
371 if (SCM_VARIABLEP (var
))
372 return SCM_VARIABLE_LOC (var
);
373 #ifdef MEMOIZE_LOCALS
374 if (SCM_ITAG7 (var
) == SCM_ITAG7 (SCM_ILOC00
))
375 return scm_ilookup (var
, genv
);
377 /* We can't cope with anything else than variables and ilocs. When
378 a special form has been memoized (i.e. `let' into `#@let') we
379 return NULL and expect the calling function to do the right
380 thing. For the evaluator, this means going back and redoing
381 the dispatch on the car of the form. */
384 #endif /* USE_THREADS */
386 SCM_SETCAR (vloc
, real_var
);
387 return SCM_VARIABLE_LOC (real_var
);
393 scm_lookupcar (SCM vloc
, SCM genv
, int check
)
395 SCM
*loc
= scm_lookupcar1 (vloc
, genv
, check
);
402 #define unmemocar scm_unmemocar
404 SCM_SYMBOL (sym_three_question_marks
, "???");
407 scm_unmemocar (SCM form
, SCM env
)
414 if (SCM_VARIABLEP (c
))
417 scm_module_reverse_lookup (scm_env_module (env
), c
);
418 if (SCM_EQ_P (sym
, SCM_BOOL_F
))
419 sym
= sym_three_question_marks
;
420 SCM_SETCAR (form
, sym
);
422 #ifdef MEMOIZE_LOCALS
423 #ifdef DEBUG_EXTENSIONS
424 else if (SCM_ILOCP (c
))
428 for (ir
= SCM_IFRAME (c
); ir
!= 0; --ir
)
430 env
= SCM_CAR (SCM_CAR (env
));
431 for (ir
= SCM_IDIST (c
); ir
!= 0; --ir
)
433 SCM_SETCAR (form
, SCM_ICDRP (c
) ? env
: SCM_CAR (env
));
442 scm_eval_car (SCM pair
, SCM env
)
444 return SCM_XEVALCAR (pair
, env
);
449 * The following rewrite expressions and
450 * some memoized forms have different syntax
453 const char scm_s_expression
[] = "missing or extra expression";
454 const char scm_s_test
[] = "bad test";
455 const char scm_s_body
[] = "bad body";
456 const char scm_s_bindings
[] = "bad bindings";
457 const char scm_s_duplicate_bindings
[] = "duplicate bindings";
458 const char scm_s_variable
[] = "bad variable";
459 const char scm_s_clauses
[] = "bad or missing clauses";
460 const char scm_s_formals
[] = "bad formals";
461 const char scm_s_duplicate_formals
[] = "duplicate formals";
463 SCM_GLOBAL_SYMBOL (scm_sym_dot
, ".");
464 SCM_GLOBAL_SYMBOL (scm_sym_arrow
, "=>");
465 SCM_GLOBAL_SYMBOL (scm_sym_else
, "else");
466 SCM_GLOBAL_SYMBOL (scm_sym_unquote
, "unquote");
467 SCM_GLOBAL_SYMBOL (scm_sym_uq_splicing
, "unquote-splicing");
471 #ifdef DEBUG_EXTENSIONS
472 SCM_GLOBAL_SYMBOL (scm_sym_enter_frame
, "enter-frame");
473 SCM_GLOBAL_SYMBOL (scm_sym_apply_frame
, "apply-frame");
474 SCM_GLOBAL_SYMBOL (scm_sym_exit_frame
, "exit-frame");
475 SCM_GLOBAL_SYMBOL (scm_sym_trace
, "trace");
479 /* Check that the body denoted by XORIG is valid and rewrite it into
480 its internal form. The internal form of a body is just the body
481 itself, but prefixed with an ISYM that denotes to what kind of
482 outer construct this body belongs. A lambda body starts with
483 SCM_IM_LAMBDA, for example, a body of a let starts with SCM_IM_LET,
484 etc. The one exception is a body that belongs to a letrec that has
485 been formed by rewriting internal defines: it starts with
488 /* XXX - Besides controlling the rewriting of internal defines, the
489 additional ISYM could be used for improved error messages.
490 This is not done yet. */
493 scm_m_body (SCM op
, SCM xorig
, const char *what
)
495 SCM_ASSYNT (scm_ilength (xorig
) >= 1, scm_s_expression
, what
);
497 /* Don't add another ISYM if one is present already. */
498 if (SCM_ISYMP (SCM_CAR (xorig
)))
501 /* Retain possible doc string. */
502 if (!SCM_CONSP (SCM_CAR (xorig
)))
504 if (!SCM_NULLP (SCM_CDR(xorig
)))
505 return scm_cons (SCM_CAR (xorig
),
506 scm_m_body (op
, SCM_CDR(xorig
), what
));
510 return scm_cons (op
, xorig
);
513 SCM_SYNTAX(s_quote
,"quote", scm_makmmacro
, scm_m_quote
);
514 SCM_GLOBAL_SYMBOL(scm_sym_quote
, s_quote
);
517 scm_m_quote (SCM xorig
, SCM env SCM_UNUSED
)
519 SCM x
= scm_copy_tree (SCM_CDR (xorig
));
521 SCM_ASSYNT (scm_ilength (SCM_CDR (xorig
)) == 1, scm_s_expression
, s_quote
);
522 return scm_cons (SCM_IM_QUOTE
, x
);
527 SCM_SYNTAX(s_begin
, "begin", scm_makmmacro
, scm_m_begin
);
528 SCM_GLOBAL_SYMBOL(scm_sym_begin
, s_begin
);
531 scm_m_begin (SCM xorig
, SCM env SCM_UNUSED
)
533 SCM_ASSYNT (scm_ilength (SCM_CDR (xorig
)) >= 1, scm_s_expression
, s_begin
);
534 return scm_cons (SCM_IM_BEGIN
, SCM_CDR (xorig
));
537 SCM_SYNTAX(s_if
, "if", scm_makmmacro
, scm_m_if
);
538 SCM_GLOBAL_SYMBOL(scm_sym_if
, s_if
);
541 scm_m_if (SCM xorig
, SCM env SCM_UNUSED
)
543 long len
= scm_ilength (SCM_CDR (xorig
));
544 SCM_ASSYNT (len
>= 2 && len
<= 3, scm_s_expression
, "if");
545 return scm_cons (SCM_IM_IF
, SCM_CDR (xorig
));
549 /* Will go into the RnRS module when Guile is factorized.
550 SCM_SYNTAX(scm_s_set_x,"set!", scm_makmmacro, scm_m_set_x); */
551 const char scm_s_set_x
[] = "set!";
552 SCM_GLOBAL_SYMBOL(scm_sym_set_x
, scm_s_set_x
);
555 scm_m_set_x (SCM xorig
, SCM env SCM_UNUSED
)
557 SCM x
= SCM_CDR (xorig
);
558 SCM_ASSYNT (2 == scm_ilength (x
), scm_s_expression
, scm_s_set_x
);
559 SCM_ASSYNT (SCM_SYMBOLP (SCM_CAR (x
)), scm_s_variable
, scm_s_set_x
);
560 return scm_cons (SCM_IM_SET_X
, x
);
564 SCM_SYNTAX(s_and
, "and", scm_makmmacro
, scm_m_and
);
565 SCM_GLOBAL_SYMBOL(scm_sym_and
, s_and
);
568 scm_m_and (SCM xorig
, SCM env SCM_UNUSED
)
570 long len
= scm_ilength (SCM_CDR (xorig
));
571 SCM_ASSYNT (len
>= 0, scm_s_test
, s_and
);
573 return scm_cons (SCM_IM_AND
, SCM_CDR (xorig
));
578 SCM_SYNTAX(s_or
,"or", scm_makmmacro
, scm_m_or
);
579 SCM_GLOBAL_SYMBOL(scm_sym_or
,s_or
);
582 scm_m_or (SCM xorig
, SCM env SCM_UNUSED
)
584 long len
= scm_ilength (SCM_CDR (xorig
));
585 SCM_ASSYNT (len
>= 0, scm_s_test
, s_or
);
587 return scm_cons (SCM_IM_OR
, SCM_CDR (xorig
));
593 SCM_SYNTAX(s_case
, "case", scm_makmmacro
, scm_m_case
);
594 SCM_GLOBAL_SYMBOL(scm_sym_case
, s_case
);
597 scm_m_case (SCM xorig
, SCM env SCM_UNUSED
)
599 SCM proc
, cdrx
= scm_list_copy (SCM_CDR (xorig
)), x
= cdrx
;
600 SCM_ASSYNT (scm_ilength (x
) >= 2, scm_s_clauses
, s_case
);
601 while (SCM_NIMP (x
= SCM_CDR (x
)))
604 SCM_ASSYNT (scm_ilength (proc
) >= 2, scm_s_clauses
, s_case
);
605 SCM_ASSYNT (scm_ilength (SCM_CAR (proc
)) >= 0
606 || (SCM_EQ_P (scm_sym_else
, SCM_CAR (proc
))
607 && SCM_NULLP (SCM_CDR (x
))),
608 scm_s_clauses
, s_case
);
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
);
619 scm_m_cond (SCM xorig
, SCM env SCM_UNUSED
)
621 SCM arg1
, cdrx
= scm_list_copy (SCM_CDR (xorig
)), x
= cdrx
;
622 long len
= scm_ilength (x
);
623 SCM_ASSYNT (len
>= 1, scm_s_clauses
, s_cond
);
627 len
= scm_ilength (arg1
);
628 SCM_ASSYNT (len
>= 1, scm_s_clauses
, s_cond
);
629 if (SCM_EQ_P (scm_sym_else
, SCM_CAR (arg1
)))
631 SCM_ASSYNT (SCM_NULLP (SCM_CDR (x
)) && len
>= 2,
632 "bad ELSE clause", s_cond
);
633 SCM_SETCAR (arg1
, SCM_BOOL_T
);
635 if (len
>= 2 && SCM_EQ_P (scm_sym_arrow
, SCM_CAR (SCM_CDR (arg1
))))
636 SCM_ASSYNT (3 == len
&& SCM_NIMP (SCM_CAR (SCM_CDR (SCM_CDR (arg1
)))),
637 "bad recipient", s_cond
);
640 return scm_cons (SCM_IM_COND
, cdrx
);
643 SCM_SYNTAX(s_lambda
, "lambda", scm_makmmacro
, scm_m_lambda
);
644 SCM_GLOBAL_SYMBOL(scm_sym_lambda
, s_lambda
);
646 /* Return true if OBJ is `eq?' to one of the elements of LIST or to the
647 cdr of the last cons. (Thus, LIST is not required to be a proper
648 list and when OBJ also 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
)
664 SCM proc
, x
= SCM_CDR (xorig
);
665 if (scm_ilength (x
) < 2)
668 if (SCM_NULLP (proc
))
670 if (SCM_EQ_P (SCM_IM_LET
, proc
)) /* named let */
674 if (SCM_SYMBOLP (proc
))
676 if (!SCM_CONSP (proc
))
678 while (SCM_NIMP (proc
))
680 if (!SCM_CONSP (proc
))
682 if (!SCM_SYMBOLP (proc
))
687 if (!SCM_SYMBOLP (SCM_CAR (proc
)))
689 else if (scm_c_improper_memq (SCM_CAR(proc
), SCM_CDR(proc
)))
690 scm_misc_error (s_lambda
, scm_s_duplicate_formals
, SCM_EOL
);
691 proc
= SCM_CDR (proc
);
693 if (!SCM_NULLP (proc
))
696 scm_misc_error (s_lambda
, scm_s_formals
, SCM_EOL
);
700 return scm_cons2 (SCM_IM_LAMBDA
, SCM_CAR (x
),
701 scm_m_body (SCM_IM_LAMBDA
, SCM_CDR (x
), s_lambda
));
704 SCM_SYNTAX(s_letstar
,"let*", scm_makmmacro
, scm_m_letstar
);
705 SCM_GLOBAL_SYMBOL(scm_sym_letstar
,s_letstar
);
709 scm_m_letstar (SCM xorig
, SCM env SCM_UNUSED
)
711 SCM x
= SCM_CDR (xorig
), arg1
, proc
, vars
= SCM_EOL
, *varloc
= &vars
;
712 long len
= scm_ilength (x
);
713 SCM_ASSYNT (len
>= 2, scm_s_body
, s_letstar
);
715 SCM_ASSYNT (scm_ilength (proc
) >= 0, scm_s_bindings
, s_letstar
);
716 while (SCM_NIMP (proc
))
718 arg1
= SCM_CAR (proc
);
719 SCM_ASSYNT (2 == scm_ilength (arg1
), scm_s_bindings
, s_letstar
);
720 SCM_ASSYNT (SCM_SYMBOLP (SCM_CAR (arg1
)), scm_s_variable
, s_letstar
);
721 *varloc
= scm_cons2 (SCM_CAR (arg1
), SCM_CAR (SCM_CDR (arg1
)), SCM_EOL
);
722 varloc
= SCM_CDRLOC (SCM_CDR (*varloc
));
723 proc
= SCM_CDR (proc
);
725 x
= scm_cons (vars
, SCM_CDR (x
));
727 return scm_cons2 (SCM_IM_LETSTAR
, SCM_CAR (x
),
728 scm_m_body (SCM_IM_LETSTAR
, SCM_CDR (x
), s_letstar
));
731 /* DO gets the most radically altered syntax
732 (do ((<var1> <init1> <step1>)
738 (do_mem (varn ... var2 var1)
739 (<init1> <init2> ... <initn>)
742 <step1> <step2> ... <stepn>) ;; missing steps replaced by var
745 SCM_SYNTAX(s_do
, "do", scm_makmmacro
, scm_m_do
);
746 SCM_GLOBAL_SYMBOL(scm_sym_do
, s_do
);
749 scm_m_do (SCM xorig
, SCM env SCM_UNUSED
)
751 SCM x
= SCM_CDR (xorig
), arg1
, proc
;
752 SCM vars
= SCM_EOL
, inits
= SCM_EOL
, steps
= SCM_EOL
;
753 SCM
*initloc
= &inits
, *steploc
= &steps
;
754 long len
= scm_ilength (x
);
755 SCM_ASSYNT (len
>= 2, scm_s_test
, "do");
757 SCM_ASSYNT (scm_ilength (proc
) >= 0, scm_s_bindings
, "do");
758 while (SCM_NIMP(proc
))
760 arg1
= SCM_CAR (proc
);
761 len
= scm_ilength (arg1
);
762 SCM_ASSYNT (2 == len
|| 3 == len
, scm_s_bindings
, "do");
763 SCM_ASSYNT (SCM_SYMBOLP (SCM_CAR (arg1
)), scm_s_variable
, "do");
764 /* vars reversed here, inits and steps reversed at evaluation */
765 vars
= scm_cons (SCM_CAR (arg1
), vars
); /* variable */
766 arg1
= SCM_CDR (arg1
);
767 *initloc
= scm_cons (SCM_CAR (arg1
), SCM_EOL
); /* init */
768 initloc
= SCM_CDRLOC (*initloc
);
769 arg1
= SCM_CDR (arg1
);
770 *steploc
= scm_cons (SCM_IMP (arg1
) ? SCM_CAR (vars
) : SCM_CAR (arg1
), SCM_EOL
); /* step */
771 steploc
= SCM_CDRLOC (*steploc
);
772 proc
= SCM_CDR (proc
);
775 SCM_ASSYNT (scm_ilength (SCM_CAR (x
)) >= 1, scm_s_test
, "do");
776 x
= scm_cons2 (SCM_CAR (x
), SCM_CDR (x
), steps
);
777 x
= scm_cons2 (vars
, inits
, x
);
778 return scm_cons (SCM_IM_DO
, x
);
781 /* evalcar is small version of inline EVALCAR when we don't care about
784 #define evalcar scm_eval_car
787 static SCM
iqq (SCM form
, SCM env
, long depth
);
789 SCM_SYNTAX(s_quasiquote
, "quasiquote", scm_makacro
, scm_m_quasiquote
);
790 SCM_GLOBAL_SYMBOL(scm_sym_quasiquote
, s_quasiquote
);
793 scm_m_quasiquote (SCM xorig
, SCM env
)
795 SCM x
= SCM_CDR (xorig
);
796 SCM_ASSYNT (scm_ilength (x
) == 1, scm_s_expression
, s_quasiquote
);
797 return iqq (SCM_CAR (x
), env
, 1);
802 iqq (SCM form
, SCM env
, long depth
)
808 if (SCM_VECTORP (form
))
810 long i
= SCM_VECTOR_LENGTH (form
);
811 SCM
*data
= SCM_VELTS (form
);
814 tmp
= scm_cons (data
[i
], tmp
);
815 return scm_vector (iqq (tmp
, env
, depth
));
817 if (!SCM_CONSP (form
))
819 tmp
= SCM_CAR (form
);
820 if (SCM_EQ_P (scm_sym_quasiquote
, tmp
))
825 if (SCM_EQ_P (scm_sym_unquote
, tmp
))
829 form
= SCM_CDR (form
);
830 SCM_ASSERT (SCM_CONSP (form
) && SCM_NULLP (SCM_CDR (form
)),
831 form
, SCM_ARG1
, s_quasiquote
);
833 return evalcar (form
, env
);
834 return scm_cons2 (tmp
, iqq (SCM_CAR (form
), env
, depth
), SCM_EOL
);
836 if (SCM_CONSP (tmp
) && (SCM_EQ_P (scm_sym_uq_splicing
, SCM_CAR (tmp
))))
840 return scm_append (scm_cons2 (evalcar (tmp
, env
), iqq (SCM_CDR (form
), env
, depth
), SCM_EOL
));
842 return scm_cons (iqq (SCM_CAR (form
), env
, edepth
), iqq (SCM_CDR (form
), env
, depth
));
845 /* Here are acros which return values rather than code. */
847 SCM_SYNTAX (s_delay
, "delay", scm_makmmacro
, scm_m_delay
);
848 SCM_GLOBAL_SYMBOL (scm_sym_delay
, s_delay
);
851 scm_m_delay (SCM xorig
, SCM env SCM_UNUSED
)
853 SCM_ASSYNT (scm_ilength (xorig
) == 2, scm_s_expression
, s_delay
);
854 return scm_cons2 (SCM_IM_DELAY
, SCM_EOL
, SCM_CDR (xorig
));
858 SCM_SYNTAX(s_define
, "define", scm_makmmacro
, scm_m_define
);
859 SCM_GLOBAL_SYMBOL(scm_sym_define
, s_define
);
862 scm_m_define (SCM x
, SCM env
)
866 SCM_ASSYNT (scm_ilength (x
) >= 2, scm_s_expression
, s_define
);
869 while (SCM_CONSP (proc
))
870 { /* nested define syntax */
871 x
= scm_cons (scm_cons2 (scm_sym_lambda
, SCM_CDR (proc
), x
), SCM_EOL
);
872 proc
= SCM_CAR (proc
);
874 SCM_ASSYNT (SCM_SYMBOLP (proc
), scm_s_variable
, s_define
);
875 SCM_ASSYNT (1 == scm_ilength (x
), scm_s_expression
, s_define
);
876 if (SCM_TOP_LEVEL (env
))
878 x
= evalcar (x
, env
);
879 #ifdef DEBUG_EXTENSIONS
880 if (SCM_REC_PROCNAMES_P
&& SCM_NIMP (x
))
884 if (SCM_CLOSUREP (arg1
)
885 /* Only the first definition determines the name. */
886 && SCM_FALSEP (scm_procedure_property (arg1
, scm_sym_name
)))
887 scm_set_procedure_property_x (arg1
, scm_sym_name
, proc
);
888 else if (SCM_MACROP (arg1
)
889 /* Dirk::FIXME: Does the following test make sense? */
890 && !SCM_EQ_P (SCM_MACRO_CODE (arg1
), arg1
))
892 arg1
= SCM_MACRO_CODE (arg1
);
897 arg1
= scm_sym2var (proc
, scm_env_top_level (env
), SCM_BOOL_T
);
898 SCM_VARIABLE_SET (arg1
, x
);
900 return scm_cons2 (scm_sym_quote
, proc
, SCM_EOL
);
902 return SCM_UNSPECIFIED
;
905 return scm_cons2 (SCM_IM_DEFINE
, proc
, x
);
911 scm_m_letrec1 (SCM op
, SCM imm
, SCM xorig
, SCM env SCM_UNUSED
)
913 SCM cdrx
= SCM_CDR (xorig
); /* locally mutable version of form */
914 char *what
= SCM_SYMBOL_CHARS (SCM_CAR (xorig
));
915 SCM x
= cdrx
, proc
, arg1
; /* structure traversers */
916 SCM vars
= SCM_EOL
, inits
= SCM_EOL
, *initloc
= &inits
;
919 SCM_ASSYNT (scm_ilength (proc
) >= 1, scm_s_bindings
, what
);
922 /* vars scm_list reversed here, inits reversed at evaluation */
923 arg1
= SCM_CAR (proc
);
924 SCM_ASSYNT (2 == scm_ilength (arg1
), scm_s_bindings
, what
);
925 SCM_ASSYNT (SCM_SYMBOLP (SCM_CAR (arg1
)), scm_s_variable
, what
);
926 if (scm_c_improper_memq (SCM_CAR (arg1
), vars
))
927 scm_misc_error (what
, scm_s_duplicate_bindings
, SCM_EOL
);
928 vars
= scm_cons (SCM_CAR (arg1
), vars
);
929 *initloc
= scm_cons (SCM_CAR (SCM_CDR (arg1
)), SCM_EOL
);
930 initloc
= SCM_CDRLOC (*initloc
);
932 while (SCM_NIMP (proc
= SCM_CDR (proc
)));
934 return scm_cons2 (op
, vars
,
935 scm_cons (inits
, scm_m_body (imm
, SCM_CDR (x
), what
)));
938 SCM_SYNTAX(s_letrec
, "letrec", scm_makmmacro
, scm_m_letrec
);
939 SCM_GLOBAL_SYMBOL(scm_sym_letrec
, s_letrec
);
942 scm_m_letrec (SCM xorig
, SCM env
)
944 SCM x
= SCM_CDR (xorig
);
945 SCM_ASSYNT (scm_ilength (x
) >= 2, scm_s_body
, s_letrec
);
947 if (SCM_NULLP (SCM_CAR (x
))) /* null binding, let* faster */
948 return scm_m_letstar (scm_cons2 (SCM_CAR (xorig
), SCM_EOL
,
949 scm_m_body (SCM_IM_LETREC
,
954 return scm_m_letrec1 (SCM_IM_LETREC
, SCM_IM_LETREC
, xorig
, env
);
957 SCM_SYNTAX(s_let
, "let", scm_makmmacro
, scm_m_let
);
958 SCM_GLOBAL_SYMBOL(scm_sym_let
, s_let
);
961 scm_m_let (SCM xorig
, SCM env
)
963 SCM cdrx
= SCM_CDR (xorig
); /* locally mutable version of form */
964 SCM x
= cdrx
, proc
, arg1
, name
; /* structure traversers */
965 SCM vars
= SCM_EOL
, inits
= SCM_EOL
, *varloc
= &vars
, *initloc
= &inits
;
967 SCM_ASSYNT (scm_ilength (x
) >= 2, scm_s_body
, s_let
);
971 && SCM_CONSP (SCM_CAR (proc
)) && SCM_NULLP (SCM_CDR (proc
))))
973 /* null or single binding, let* is faster */
974 return scm_m_letstar (scm_cons2 (SCM_CAR (xorig
), proc
,
975 scm_m_body (SCM_IM_LET
,
981 SCM_ASSYNT (SCM_NIMP (proc
), scm_s_bindings
, s_let
);
982 if (SCM_CONSP (proc
))
984 /* plain let, proc is <bindings> */
985 return scm_m_letrec1 (SCM_IM_LET
, SCM_IM_LET
, xorig
, env
);
988 if (!SCM_SYMBOLP (proc
))
989 scm_misc_error (s_let
, scm_s_bindings
, SCM_EOL
); /* bad let */
990 name
= proc
; /* named let, build equiv letrec */
992 SCM_ASSYNT (scm_ilength (x
) >= 2, scm_s_body
, s_let
);
993 proc
= SCM_CAR (x
); /* bindings list */
994 SCM_ASSYNT (scm_ilength (proc
) >= 0, scm_s_bindings
, s_let
);
995 while (SCM_NIMP (proc
))
996 { /* vars and inits both in order */
997 arg1
= SCM_CAR (proc
);
998 SCM_ASSYNT (2 == scm_ilength (arg1
), scm_s_bindings
, s_let
);
999 SCM_ASSYNT (SCM_SYMBOLP (SCM_CAR (arg1
)), scm_s_variable
, s_let
);
1000 *varloc
= scm_cons (SCM_CAR (arg1
), SCM_EOL
);
1001 varloc
= SCM_CDRLOC (*varloc
);
1002 *initloc
= scm_cons (SCM_CAR (SCM_CDR (arg1
)), SCM_EOL
);
1003 initloc
= SCM_CDRLOC (*initloc
);
1004 proc
= SCM_CDR (proc
);
1007 proc
= scm_cons2 (scm_sym_lambda
, vars
,
1008 scm_m_body (SCM_IM_LET
, SCM_CDR (x
), "let"));
1009 proc
= scm_cons2 (scm_sym_let
, scm_cons (scm_cons2 (name
, proc
, SCM_EOL
),
1011 scm_acons (name
, inits
, SCM_EOL
));
1012 return scm_m_letrec1 (SCM_IM_LETREC
, SCM_IM_LET
, proc
, env
);
1016 SCM_SYNTAX (s_atapply
,"@apply", scm_makmmacro
, scm_m_apply
);
1017 SCM_GLOBAL_SYMBOL (scm_sym_atapply
, s_atapply
);
1018 SCM_GLOBAL_SYMBOL (scm_sym_apply
, s_atapply
+ 1);
1021 scm_m_apply (SCM xorig
, SCM env SCM_UNUSED
)
1023 SCM_ASSYNT (scm_ilength (SCM_CDR (xorig
)) == 2, scm_s_expression
, s_atapply
);
1024 return scm_cons (SCM_IM_APPLY
, SCM_CDR (xorig
));
1028 SCM_SYNTAX(s_atcall_cc
,"@call-with-current-continuation", scm_makmmacro
, scm_m_cont
);
1029 SCM_GLOBAL_SYMBOL(scm_sym_atcall_cc
,s_atcall_cc
);
1033 scm_m_cont (SCM xorig
, SCM env SCM_UNUSED
)
1035 SCM_ASSYNT (scm_ilength (SCM_CDR (xorig
)) == 1,
1036 scm_s_expression
, s_atcall_cc
);
1037 return scm_cons (SCM_IM_CONT
, SCM_CDR (xorig
));
1040 /* Multi-language support */
1042 SCM_GLOBAL_SYMBOL (scm_lisp_nil
, "nil");
1043 SCM_GLOBAL_SYMBOL (scm_lisp_t
, "t");
1045 SCM_SYNTAX (s_nil_cond
, "nil-cond", scm_makmmacro
, scm_m_nil_cond
);
1048 scm_m_nil_cond (SCM xorig
, SCM env SCM_UNUSED
)
1050 long len
= scm_ilength (SCM_CDR (xorig
));
1051 SCM_ASSYNT (len
>= 1 && (len
& 1) == 1, scm_s_expression
, "nil-cond");
1052 return scm_cons (SCM_IM_NIL_COND
, SCM_CDR (xorig
));
1055 SCM_SYNTAX (s_nil_ify
, "nil-ify", scm_makmmacro
, scm_m_nil_ify
);
1058 scm_m_nil_ify (SCM xorig
, SCM env SCM_UNUSED
)
1060 SCM_ASSYNT (scm_ilength (SCM_CDR (xorig
)) == 1, scm_s_expression
, "nil-ify");
1061 return scm_cons (SCM_IM_NIL_IFY
, SCM_CDR (xorig
));
1064 SCM_SYNTAX (s_t_ify
, "t-ify", scm_makmmacro
, scm_m_t_ify
);
1067 scm_m_t_ify (SCM xorig
, SCM env SCM_UNUSED
)
1069 SCM_ASSYNT (scm_ilength (SCM_CDR (xorig
)) == 1, scm_s_expression
, "t-ify");
1070 return scm_cons (SCM_IM_T_IFY
, SCM_CDR (xorig
));
1073 SCM_SYNTAX (s_0_cond
, "0-cond", scm_makmmacro
, scm_m_0_cond
);
1076 scm_m_0_cond (SCM xorig
, SCM env SCM_UNUSED
)
1078 long len
= scm_ilength (SCM_CDR (xorig
));
1079 SCM_ASSYNT (len
>= 1 && (len
& 1) == 1, scm_s_expression
, "0-cond");
1080 return scm_cons (SCM_IM_0_COND
, SCM_CDR (xorig
));
1083 SCM_SYNTAX (s_0_ify
, "0-ify", scm_makmmacro
, scm_m_0_ify
);
1086 scm_m_0_ify (SCM xorig
, SCM env SCM_UNUSED
)
1088 SCM_ASSYNT (scm_ilength (SCM_CDR (xorig
)) == 1, scm_s_expression
, "0-ify");
1089 return scm_cons (SCM_IM_0_IFY
, SCM_CDR (xorig
));
1092 SCM_SYNTAX (s_1_ify
, "1-ify", scm_makmmacro
, scm_m_1_ify
);
1095 scm_m_1_ify (SCM xorig
, SCM env SCM_UNUSED
)
1097 SCM_ASSYNT (scm_ilength (SCM_CDR (xorig
)) == 1, scm_s_expression
, "1-ify");
1098 return scm_cons (SCM_IM_1_IFY
, SCM_CDR (xorig
));
1101 SCM_SYNTAX (s_atfop
, "@fop", scm_makmmacro
, scm_m_atfop
);
1104 scm_m_atfop (SCM xorig
, SCM env SCM_UNUSED
)
1106 SCM x
= SCM_CDR (xorig
), var
;
1107 SCM_ASSYNT (scm_ilength (x
) >= 1, scm_s_expression
, "@fop");
1108 var
= scm_symbol_fref (SCM_CAR (x
));
1109 SCM_ASSYNT (SCM_VARIABLEP (var
),
1110 "Symbol's function definition is void", NULL
);
1111 SCM_SETCAR (x
, var
);
1115 SCM_SYNTAX (s_atbind
, "@bind", scm_makmmacro
, scm_m_atbind
);
1118 scm_m_atbind (SCM xorig
, SCM env
)
1120 SCM x
= SCM_CDR (xorig
);
1121 SCM_ASSYNT (scm_ilength (x
) > 1, scm_s_expression
, "@bind");
1127 while (SCM_NIMP (SCM_CDR (env
)))
1128 env
= SCM_CDR (env
);
1129 env
= SCM_CAR (env
);
1130 if (SCM_CONSP (env
))
1135 while (SCM_NIMP (x
))
1137 SCM_SETCAR (x
, scm_sym2var (SCM_CAR (x
), env
, SCM_BOOL_T
));
1140 return scm_cons (SCM_IM_BIND
, SCM_CDR (xorig
));
1143 SCM_SYNTAX (s_at_call_with_values
, "@call-with-values", scm_makmmacro
, scm_m_at_call_with_values
);
1144 SCM_GLOBAL_SYMBOL(scm_sym_at_call_with_values
, s_at_call_with_values
);
1147 scm_m_at_call_with_values (SCM xorig
, SCM env SCM_UNUSED
)
1149 SCM_ASSYNT (scm_ilength (SCM_CDR (xorig
)) == 2,
1150 scm_s_expression
, s_at_call_with_values
);
1151 return scm_cons (SCM_IM_CALL_WITH_VALUES
, SCM_CDR (xorig
));
1155 scm_m_expand_body (SCM xorig
, SCM env
)
1157 SCM x
= SCM_CDR (xorig
), defs
= SCM_EOL
;
1158 char *what
= SCM_ISYMCHARS (SCM_CAR (xorig
)) + 2;
1160 while (SCM_NIMP (x
))
1162 SCM form
= SCM_CAR (x
);
1163 if (!SCM_CONSP (form
))
1165 if (!SCM_SYMBOLP (SCM_CAR (form
)))
1168 form
= scm_macroexp (scm_cons_source (form
,
1173 if (SCM_EQ_P (SCM_IM_DEFINE
, SCM_CAR (form
)))
1175 defs
= scm_cons (SCM_CDR (form
), defs
);
1178 else if (!SCM_IMP (defs
))
1182 else if (SCM_EQ_P (SCM_IM_BEGIN
, SCM_CAR (form
)))
1184 x
= scm_append (scm_cons2 (SCM_CDR (form
), SCM_CDR (x
), SCM_EOL
));
1188 x
= scm_cons (form
, SCM_CDR (x
));
1193 SCM_ASSYNT (SCM_NIMP (x
), scm_s_body
, what
);
1194 if (SCM_NIMP (defs
))
1196 x
= scm_cons (scm_m_letrec1 (SCM_IM_LETREC
,
1198 scm_cons2 (scm_sym_define
, defs
, x
),
1204 SCM_SETCAR (xorig
, SCM_CAR (x
));
1205 SCM_SETCDR (xorig
, SCM_CDR (x
));
1212 scm_macroexp (SCM x
, SCM env
)
1214 SCM res
, proc
, orig_sym
;
1216 /* Don't bother to produce error messages here. We get them when we
1217 eventually execute the code for real. */
1220 orig_sym
= SCM_CAR (x
);
1221 if (!SCM_SYMBOLP (orig_sym
))
1226 SCM
*proc_ptr
= scm_lookupcar1 (x
, env
, 0);
1227 if (proc_ptr
== NULL
)
1229 /* We have lost the race. */
1235 proc
= *scm_lookupcar (x
, env
, 0);
1238 /* Only handle memoizing macros. `Acros' and `macros' are really
1239 special forms and should not be evaluated here. */
1241 if (!SCM_MACROP (proc
) || SCM_MACRO_TYPE (proc
) != 2)
1244 SCM_SETCAR (x
, orig_sym
); /* Undo memoizing effect of lookupcar */
1245 res
= scm_call_2 (SCM_MACRO_CODE (proc
), x
, env
);
1247 if (scm_ilength (res
) <= 0)
1248 res
= scm_cons2 (SCM_IM_BEGIN
, res
, SCM_EOL
);
1251 SCM_SETCAR (x
, SCM_CAR (res
));
1252 SCM_SETCDR (x
, SCM_CDR (res
));
1258 /* scm_unmemocopy takes a memoized expression together with its
1259 * environment and rewrites it to its original form. Thus, it is the
1260 * inversion of the rewrite rules above. The procedure is not
1261 * optimized for speed. It's used in scm_iprin1 when printing the
1262 * code of a closure, in scm_procedure_source, in display_frame when
1263 * generating the source for a stackframe in a backtrace, and in
1264 * display_expression.
1266 * Unmemoizing is not a realiable process. You can not in general
1267 * expect to get the original source back.
1269 * However, GOOPS currently relies on this for method compilation.
1270 * This ought to change.
1273 #define SCM_BIT8(x) (127 & SCM_UNPACK (x))
1276 unmemocopy (SCM x
, SCM env
)
1279 #ifdef DEBUG_EXTENSIONS
1282 if (!SCM_CELLP (x
) || !SCM_CONSP (x
))
1284 #ifdef DEBUG_EXTENSIONS
1285 p
= scm_whash_lookup (scm_source_whash
, x
);
1287 switch (SCM_TYP7 (x
))
1289 case SCM_BIT8(SCM_IM_AND
):
1290 ls
= z
= scm_cons (scm_sym_and
, SCM_UNSPECIFIED
);
1292 case SCM_BIT8(SCM_IM_BEGIN
):
1293 ls
= z
= scm_cons (scm_sym_begin
, SCM_UNSPECIFIED
);
1295 case SCM_BIT8(SCM_IM_CASE
):
1296 ls
= z
= scm_cons (scm_sym_case
, SCM_UNSPECIFIED
);
1298 case SCM_BIT8(SCM_IM_COND
):
1299 ls
= z
= scm_cons (scm_sym_cond
, SCM_UNSPECIFIED
);
1301 case SCM_BIT8(SCM_IM_DO
):
1302 ls
= scm_cons (scm_sym_do
, SCM_UNSPECIFIED
);
1304 case SCM_BIT8(SCM_IM_IF
):
1305 ls
= z
= scm_cons (scm_sym_if
, SCM_UNSPECIFIED
);
1307 case SCM_BIT8(SCM_IM_LET
):
1308 ls
= scm_cons (scm_sym_let
, SCM_UNSPECIFIED
);
1310 case SCM_BIT8(SCM_IM_LETREC
):
1313 ls
= scm_cons (scm_sym_letrec
, SCM_UNSPECIFIED
);
1317 f
= v
= SCM_CAR (x
);
1319 z
= EXTEND_ENV (f
, SCM_EOL
, env
);
1321 e
= scm_reverse (unmemocopy (SCM_CAR (x
),
1322 SCM_EQ_P (SCM_CAR (ls
), scm_sym_letrec
) ? z
: env
));
1325 s
= SCM_EQ_P (SCM_CAR (ls
), scm_sym_do
)
1326 ? scm_reverse (unmemocopy (SCM_CDR (SCM_CDR (SCM_CDR (x
))), env
))
1328 /* build transformed binding list */
1330 while (SCM_NIMP (v
))
1332 z
= scm_acons (SCM_CAR (v
),
1333 scm_cons (SCM_CAR (e
),
1334 SCM_EQ_P (SCM_CAR (s
), SCM_CAR (v
))
1336 : scm_cons (SCM_CAR (s
), SCM_EOL
)),
1342 z
= scm_cons (z
, SCM_UNSPECIFIED
);
1344 if (SCM_EQ_P (SCM_CAR (ls
), scm_sym_do
))
1348 SCM_SETCDR (z
, scm_cons (unmemocopy (SCM_CAR (x
), env
),
1351 x
= (SCM
) (SCM_CARLOC (SCM_CDR (x
)) - 1);
1352 /* body forms are now to be found in SCM_CDR (x)
1353 (this is how *real* code look like! :) */
1357 case SCM_BIT8(SCM_IM_LETSTAR
):
1365 env
= EXTEND_ENV (SCM_EOL
, SCM_EOL
, env
);
1368 y
= z
= scm_acons (SCM_CAR (b
),
1370 scm_cons (unmemocopy (SCM_CAR (SCM_CDR (b
)), env
), SCM_EOL
), env
),
1372 env
= EXTEND_ENV (SCM_CAR (b
), SCM_BOOL_F
, env
);
1373 b
= SCM_CDR (SCM_CDR (b
));
1376 SCM_SETCDR (y
, SCM_EOL
);
1377 ls
= scm_cons (scm_sym_let
, z
= scm_cons (y
, SCM_UNSPECIFIED
));
1382 SCM_SETCDR (z
, scm_acons (SCM_CAR (b
),
1384 scm_cons (unmemocopy (SCM_CAR (SCM_CDR (b
)), env
), SCM_EOL
), env
),
1387 env
= EXTEND_ENV (SCM_CAR (b
), SCM_BOOL_F
, env
);
1388 b
= SCM_CDR (SCM_CDR (b
));
1390 while (SCM_NIMP (b
));
1391 SCM_SETCDR (z
, SCM_EOL
);
1393 ls
= scm_cons (scm_sym_letstar
, z
= scm_cons (y
, SCM_UNSPECIFIED
));
1396 case SCM_BIT8(SCM_IM_OR
):
1397 ls
= z
= scm_cons (scm_sym_or
, SCM_UNSPECIFIED
);
1399 case SCM_BIT8(SCM_IM_LAMBDA
):
1401 ls
= scm_cons (scm_sym_lambda
,
1402 z
= scm_cons (SCM_CAR (x
), SCM_UNSPECIFIED
));
1403 env
= EXTEND_ENV (SCM_CAR (x
), SCM_EOL
, env
);
1405 case SCM_BIT8(SCM_IM_QUOTE
):
1406 ls
= z
= scm_cons (scm_sym_quote
, SCM_UNSPECIFIED
);
1408 case SCM_BIT8(SCM_IM_SET_X
):
1409 ls
= z
= scm_cons (scm_sym_set_x
, SCM_UNSPECIFIED
);
1411 case SCM_BIT8(SCM_IM_DEFINE
):
1415 ls
= scm_cons (scm_sym_define
,
1416 z
= scm_cons (n
= SCM_CAR (x
), SCM_UNSPECIFIED
));
1417 if (!SCM_NULLP (env
))
1418 SCM_SETCAR (SCM_CAR (env
), scm_cons (n
, SCM_CAR (SCM_CAR (env
))));
1421 case SCM_BIT8(SCM_MAKISYM (0)):
1425 switch (SCM_ISYMNUM (z
))
1427 case (SCM_ISYMNUM (SCM_IM_APPLY
)):
1428 ls
= z
= scm_cons (scm_sym_atapply
, SCM_UNSPECIFIED
);
1430 case (SCM_ISYMNUM (SCM_IM_CONT
)):
1431 ls
= z
= scm_cons (scm_sym_atcall_cc
, SCM_UNSPECIFIED
);
1433 case (SCM_ISYMNUM (SCM_IM_DELAY
)):
1434 ls
= z
= scm_cons (scm_sym_delay
, SCM_UNSPECIFIED
);
1437 case (SCM_ISYMNUM (SCM_IM_CALL_WITH_VALUES
)):
1438 ls
= z
= scm_cons (scm_sym_at_call_with_values
, SCM_UNSPECIFIED
);
1441 /* appease the Sun compiler god: */ ;
1445 ls
= z
= unmemocar (scm_cons (unmemocopy (SCM_CAR (x
), env
),
1450 while (SCM_CELLP (x
= SCM_CDR (x
)) && SCM_CONSP (x
))
1452 if (SCM_ISYMP (SCM_CAR (x
)))
1453 /* skip body markers */
1455 SCM_SETCDR (z
, unmemocar (scm_cons (unmemocopy (SCM_CAR (x
), env
),
1461 #ifdef DEBUG_EXTENSIONS
1462 if (!SCM_FALSEP (p
))
1463 scm_whash_insert (scm_source_whash
, ls
, p
);
1470 scm_unmemocopy (SCM x
, SCM env
)
1472 if (!SCM_NULLP (env
))
1473 /* Make a copy of the lowest frame to protect it from
1474 modifications by SCM_IM_DEFINE */
1475 return unmemocopy (x
, scm_cons (SCM_CAR (env
), SCM_CDR (env
)));
1477 return unmemocopy (x
, env
);
1480 #ifndef SCM_RECKLESS
1483 scm_badargsp (SCM formals
, SCM args
)
1485 while (SCM_NIMP (formals
))
1487 if (!SCM_CONSP (formals
))
1491 formals
= SCM_CDR (formals
);
1492 args
= SCM_CDR (args
);
1494 return !SCM_NULLP (args
) ? 1 : 0;
1499 scm_badformalsp (SCM closure
, int n
)
1501 SCM formals
= SCM_CLOSURE_FORMALS (closure
);
1502 while (!SCM_NULLP (formals
))
1504 if (!SCM_CONSP (formals
))
1509 formals
= SCM_CDR (formals
);
1516 scm_eval_args (SCM l
, SCM env
, SCM proc
)
1518 SCM results
= SCM_EOL
, *lloc
= &results
, res
;
1519 while (SCM_CONSP (l
))
1521 res
= EVALCAR (l
, env
);
1523 *lloc
= scm_cons (res
, SCM_EOL
);
1524 lloc
= SCM_CDRLOC (*lloc
);
1529 scm_wrong_num_args (proc
);
1535 scm_eval_body (SCM code
, SCM env
)
1539 next
= SCM_CDR (code
);
1540 while (!SCM_NULLP (next
))
1542 if (SCM_IMP (SCM_CAR (code
)))
1544 if (SCM_ISYMP (SCM_CAR (code
)))
1546 code
= scm_m_expand_body (code
, env
);
1551 SCM_XEVAL (SCM_CAR (code
), env
);
1553 next
= SCM_CDR (code
);
1555 return SCM_XEVALCAR (code
, env
);
1562 /* SECTION: This code is specific for the debugging support. One
1563 * branch is read when DEVAL isn't defined, the other when DEVAL is
1569 #define SCM_APPLY scm_apply
1570 #define PREP_APPLY(proc, args)
1572 #define RETURN(x) return x;
1573 #ifdef STACK_CHECKING
1574 #ifndef NO_CEVAL_STACK_CHECKING
1575 #define EVAL_STACK_CHECKING
1582 #define SCM_CEVAL scm_deval /* Substitute all uses of scm_ceval */
1584 #define SCM_APPLY scm_dapply
1586 #define PREP_APPLY(p, l) \
1587 { ++debug.info; debug.info->a.proc = p; debug.info->a.args = l; }
1589 #define ENTER_APPLY \
1591 SCM_SET_ARGSREADY (debug);\
1592 if (CHECK_APPLY && SCM_TRAPS_P)\
1593 if (SCM_APPLY_FRAME_P || (SCM_TRACE_P && PROCTRACEP (proc)))\
1595 SCM tmp, tail = SCM_BOOL(SCM_TRACED_FRAME_P (debug)); \
1596 SCM_SET_TRACED_FRAME (debug); \
1598 if (SCM_CHEAPTRAPS_P)\
1600 tmp = scm_make_debugobj (&debug);\
1601 scm_call_3 (SCM_APPLY_FRAME_HDLR, scm_sym_apply_frame, tmp, tail);\
1606 tmp = scm_make_continuation (&first);\
1608 scm_call_3 (SCM_APPLY_FRAME_HDLR, scm_sym_apply_frame, tmp, tail);\
1614 #define RETURN(e) {proc = (e); goto exit;}
1615 #ifdef STACK_CHECKING
1616 #ifndef EVAL_STACK_CHECKING
1617 #define EVAL_STACK_CHECKING
1621 /* scm_ceval_ptr points to the currently selected evaluator.
1622 * *fixme*: Although efficiency is important here, this state variable
1623 * should probably not be a global. It should be related to the
1628 SCM (*scm_ceval_ptr
) (SCM x
, SCM env
);
1630 /* scm_last_debug_frame contains a pointer to the last debugging
1631 * information stack frame. It is accessed very often from the
1632 * debugging evaluator, so it should probably not be indirectly
1633 * addressed. Better to save and restore it from the current root at
1638 scm_t_debug_frame
*scm_last_debug_frame
;
1641 /* scm_debug_eframe_size is the number of slots available for pseudo
1642 * stack frames at each real stack frame.
1645 long scm_debug_eframe_size
;
1647 int scm_debug_mode
, scm_check_entry_p
, scm_check_apply_p
, scm_check_exit_p
;
1649 long scm_eval_stack
;
1651 scm_t_option scm_eval_opts
[] = {
1652 { SCM_OPTION_INTEGER
, "stack", 22000, "Size of thread stacks (in machine words)." }
1655 scm_t_option scm_debug_opts
[] = {
1656 { SCM_OPTION_BOOLEAN
, "cheap", 1,
1657 "*Flyweight representation of the stack at traps." },
1658 { SCM_OPTION_BOOLEAN
, "breakpoints", 0, "*Check for breakpoints." },
1659 { SCM_OPTION_BOOLEAN
, "trace", 0, "*Trace mode." },
1660 { SCM_OPTION_BOOLEAN
, "procnames", 1,
1661 "Record procedure names at definition." },
1662 { SCM_OPTION_BOOLEAN
, "backwards", 0,
1663 "Display backtrace in anti-chronological order." },
1664 { SCM_OPTION_INTEGER
, "width", 79, "Maximal width of backtrace." },
1665 { SCM_OPTION_INTEGER
, "indent", 10, "Maximal indentation in backtrace." },
1666 { SCM_OPTION_INTEGER
, "frames", 3,
1667 "Maximum number of tail-recursive frames in backtrace." },
1668 { SCM_OPTION_INTEGER
, "maxdepth", 1000,
1669 "Maximal number of stored backtrace frames." },
1670 { SCM_OPTION_INTEGER
, "depth", 20, "Maximal length of printed backtrace." },
1671 { SCM_OPTION_BOOLEAN
, "backtrace", 0, "Show backtrace on error." },
1672 { SCM_OPTION_BOOLEAN
, "debug", 0, "Use the debugging evaluator." },
1673 { SCM_OPTION_INTEGER
, "stack", 20000, "Stack size limit (measured in words; 0 = no check)." },
1674 { 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."}
1677 scm_t_option scm_evaluator_trap_table
[] = {
1678 { SCM_OPTION_BOOLEAN
, "traps", 0, "Enable evaluator traps." },
1679 { SCM_OPTION_BOOLEAN
, "enter-frame", 0, "Trap when eval enters new frame." },
1680 { SCM_OPTION_BOOLEAN
, "apply-frame", 0, "Trap when entering apply." },
1681 { SCM_OPTION_BOOLEAN
, "exit-frame", 0, "Trap when exiting eval or apply." },
1682 { SCM_OPTION_SCM
, "enter-frame-handler", (unsigned long)SCM_BOOL_F
, "Handler for enter-frame traps." },
1683 { SCM_OPTION_SCM
, "apply-frame-handler", (unsigned long)SCM_BOOL_F
, "Handler for apply-frame traps." },
1684 { SCM_OPTION_SCM
, "exit-frame-handler", (unsigned long)SCM_BOOL_F
, "Handler for exit-frame traps." }
1687 SCM_DEFINE (scm_eval_options_interface
, "eval-options-interface", 0, 1, 0,
1689 "Option interface for the evaluation options. Instead of using\n"
1690 "this procedure directly, use the procedures @code{eval-enable},\n"
1691 "@code{eval-disable}, @code{eval-set!} and @var{eval-options}.")
1692 #define FUNC_NAME s_scm_eval_options_interface
1696 ans
= scm_options (setting
,
1700 scm_eval_stack
= SCM_EVAL_STACK
* sizeof (void *);
1706 SCM_DEFINE (scm_evaluator_traps
, "evaluator-traps-interface", 0, 1, 0,
1708 "Option interface for the evaluator trap options.")
1709 #define FUNC_NAME s_scm_evaluator_traps
1713 ans
= scm_options (setting
,
1714 scm_evaluator_trap_table
,
1715 SCM_N_EVALUATOR_TRAPS
,
1717 SCM_RESET_DEBUG_MODE
;
1724 scm_deval_args (SCM l
, SCM env
, SCM proc
, SCM
*lloc
)
1726 SCM
*results
= lloc
, res
;
1727 while (SCM_CONSP (l
))
1729 res
= EVALCAR (l
, env
);
1731 *lloc
= scm_cons (res
, SCM_EOL
);
1732 lloc
= SCM_CDRLOC (*lloc
);
1737 scm_wrong_num_args (proc
);
1745 /* SECTION: Some local definitions for the evaluator.
1748 /* Update the toplevel environment frame ENV so that it refers to the
1751 #define UPDATE_TOPLEVEL_ENV(env) \
1753 SCM p = scm_current_module_lookup_closure (); \
1754 if (p != SCM_CAR(env)) \
1755 env = scm_top_level_env (p); \
1759 #define CHECK_EQVISH(A,B) (SCM_EQ_P ((A), (B)) || (!SCM_FALSEP (scm_eqv_p ((A), (B)))))
1762 #define BUILTIN_RPASUBR /* Handle rpsubrs and asubrs without calling apply */
1764 /* SECTION: This is the evaluator. Like any real monster, it has
1765 * three heads. This code is compiled twice.
1771 scm_ceval (SCM x
, SCM env
)
1777 scm_deval (SCM x
, SCM env
)
1782 SCM_CEVAL (SCM x
, SCM env
)
1789 SCM proc
, arg2
, orig_sym
;
1791 scm_t_debug_frame debug
;
1792 scm_t_debug_info
*debug_info_end
;
1793 debug
.prev
= scm_last_debug_frame
;
1794 debug
.status
= scm_debug_eframe_size
;
1796 * The debug.vect contains twice as much scm_t_debug_info frames as the
1797 * user has specified with (debug-set! frames <n>).
1799 * Even frames are eval frames, odd frames are apply frames.
1801 debug
.vect
= (scm_t_debug_info
*) alloca (scm_debug_eframe_size
1802 * sizeof (debug
.vect
[0]));
1803 debug
.info
= debug
.vect
;
1804 debug_info_end
= debug
.vect
+ scm_debug_eframe_size
;
1805 scm_last_debug_frame
= &debug
;
1807 #ifdef EVAL_STACK_CHECKING
1808 if (scm_stack_checking_enabled_p
1809 && SCM_STACK_OVERFLOW_P ((SCM_STACKITEM
*) &proc
))
1812 debug
.info
->e
.exp
= x
;
1813 debug
.info
->e
.env
= env
;
1815 scm_report_stack_overflow ();
1822 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
1825 SCM_CLEAR_ARGSREADY (debug
);
1826 if (SCM_OVERFLOWP (debug
))
1829 * In theory, this should be the only place where it is necessary to
1830 * check for space in debug.vect since both eval frames and
1831 * available space are even.
1833 * For this to be the case, however, it is necessary that primitive
1834 * special forms which jump back to `loop', `begin' or some similar
1835 * label call PREP_APPLY. A convenient way to do this is to jump to
1836 * `loopnoap' or `cdrxnoap'.
1838 else if (++debug
.info
>= debug_info_end
)
1840 SCM_SET_OVERFLOW (debug
);
1844 debug
.info
->e
.exp
= x
;
1845 debug
.info
->e
.env
= env
;
1846 if (CHECK_ENTRY
&& SCM_TRAPS_P
)
1847 if (SCM_ENTER_FRAME_P
|| (SCM_BREAKPOINTS_P
&& SRCBRKP (x
)))
1849 SCM tail
= SCM_BOOL(SCM_TAILRECP (debug
));
1850 SCM_SET_TAILREC (debug
);
1851 if (SCM_CHEAPTRAPS_P
)
1852 t
.arg1
= scm_make_debugobj (&debug
);
1856 SCM val
= scm_make_continuation (&first
);
1868 /* This gives the possibility for the debugger to
1869 modify the source expression before evaluation. */
1874 scm_call_4 (SCM_ENTER_FRAME_HDLR
,
1875 scm_sym_enter_frame
,
1878 scm_unmemocopy (x
, env
));
1882 #if defined (USE_THREADS) || defined (DEVAL)
1886 switch (SCM_TYP7 (x
))
1888 case scm_tc7_symbol
:
1889 /* Only happens when called at top level.
1891 x
= scm_cons (x
, SCM_UNDEFINED
);
1894 case SCM_BIT8(SCM_IM_AND
):
1897 while (!SCM_NULLP (t
.arg1
= SCM_CDR (t
.arg1
)))
1898 if (SCM_FALSEP (EVALCAR (x
, env
)))
1900 RETURN (SCM_BOOL_F
);
1904 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
1907 case SCM_BIT8(SCM_IM_BEGIN
):
1908 /* (currently unused)
1910 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
1911 /* (currently unused)
1916 /* If we are on toplevel with a lookup closure, we need to sync
1917 with the current module. */
1918 if (SCM_CONSP (env
) && !SCM_CONSP (SCM_CAR (env
)))
1921 UPDATE_TOPLEVEL_ENV (env
);
1922 while (!SCM_NULLP (t
.arg1
= SCM_CDR (t
.arg1
)))
1926 UPDATE_TOPLEVEL_ENV (env
);
1931 goto nontoplevel_begin
;
1933 nontoplevel_cdrxnoap
:
1934 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
1935 nontoplevel_cdrxbegin
:
1939 while (!SCM_NULLP (t
.arg1
= SCM_CDR (t
.arg1
)))
1941 if (SCM_IMP (SCM_CAR (x
)))
1943 if (SCM_ISYMP (SCM_CAR (x
)))
1945 x
= scm_m_expand_body (x
, env
);
1946 goto nontoplevel_begin
;
1949 SCM_VALIDATE_NON_EMPTY_COMBINATION (SCM_CAR (x
));
1952 SCM_CEVAL (SCM_CAR (x
), env
);
1956 carloop
: /* scm_eval car of last form in list */
1957 if (!SCM_CELLP (SCM_CAR (x
)))
1960 RETURN (SCM_EVALIM (x
, env
))
1963 if (SCM_SYMBOLP (SCM_CAR (x
)))
1966 RETURN (*scm_lookupcar (x
, env
, 1))
1970 goto loop
; /* tail recurse */
1973 case SCM_BIT8(SCM_IM_CASE
):
1975 t
.arg1
= EVALCAR (x
, env
);
1976 while (SCM_NIMP (x
= SCM_CDR (x
)))
1979 if (SCM_EQ_P (scm_sym_else
, SCM_CAR (proc
)))
1982 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
1985 proc
= SCM_CAR (proc
);
1986 while (SCM_NIMP (proc
))
1988 if (CHECK_EQVISH (SCM_CAR (proc
), t
.arg1
))
1990 x
= SCM_CDR (SCM_CAR (x
));
1991 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
1994 proc
= SCM_CDR (proc
);
1997 RETURN (SCM_UNSPECIFIED
)
2000 case SCM_BIT8(SCM_IM_COND
):
2001 while (!SCM_IMP (x
= SCM_CDR (x
)))
2004 t
.arg1
= EVALCAR (proc
, env
);
2005 if (!SCM_FALSEP (t
.arg1
))
2012 if (!SCM_EQ_P (scm_sym_arrow
, SCM_CAR (x
)))
2014 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
2018 proc
= EVALCAR (proc
, env
);
2019 SCM_ASRTGO (SCM_NIMP (proc
), badfun
);
2020 PREP_APPLY (proc
, scm_cons (t
.arg1
, SCM_EOL
));
2022 if (SCM_CLOSUREP(proc
) && scm_badformalsp (proc
, 1))
2023 goto umwrongnumargs
;
2027 RETURN (SCM_UNSPECIFIED
)
2030 case SCM_BIT8(SCM_IM_DO
):
2032 proc
= SCM_CAR (SCM_CDR (x
)); /* inits */
2033 t
.arg1
= SCM_EOL
; /* values */
2034 while (SCM_NIMP (proc
))
2036 t
.arg1
= scm_cons (EVALCAR (proc
, env
), t
.arg1
);
2037 proc
= SCM_CDR (proc
);
2039 env
= EXTEND_ENV (SCM_CAR (x
), t
.arg1
, env
);
2040 x
= SCM_CDR (SCM_CDR (x
));
2041 while (proc
= SCM_CAR (x
), SCM_FALSEP (EVALCAR (proc
, env
)))
2043 for (proc
= SCM_CADR (x
); SCM_NIMP (proc
); proc
= SCM_CDR (proc
))
2045 t
.arg1
= SCM_CAR (proc
); /* body */
2046 SIDEVAL (t
.arg1
, env
);
2048 for (t
.arg1
= SCM_EOL
, proc
= SCM_CDDR (x
);
2050 proc
= SCM_CDR (proc
))
2051 t
.arg1
= scm_cons (EVALCAR (proc
, env
), t
.arg1
); /* steps */
2052 env
= EXTEND_ENV (SCM_CAR (SCM_CAR (env
)), t
.arg1
, SCM_CDR (env
));
2056 RETURN (SCM_UNSPECIFIED
);
2057 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
2058 goto nontoplevel_begin
;
2061 case SCM_BIT8(SCM_IM_IF
):
2063 if (!SCM_FALSEP (EVALCAR (x
, env
)))
2065 else if (SCM_IMP (x
= SCM_CDR (SCM_CDR (x
))))
2067 RETURN (SCM_UNSPECIFIED
);
2069 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
2073 case SCM_BIT8(SCM_IM_LET
):
2075 proc
= SCM_CAR (SCM_CDR (x
));
2079 t
.arg1
= scm_cons (EVALCAR (proc
, env
), t
.arg1
);
2081 while (SCM_NIMP (proc
= SCM_CDR (proc
)));
2082 env
= EXTEND_ENV (SCM_CAR (x
), t
.arg1
, env
);
2084 goto nontoplevel_cdrxnoap
;
2087 case SCM_BIT8(SCM_IM_LETREC
):
2089 env
= EXTEND_ENV (SCM_CAR (x
), scm_undefineds
, env
);
2095 t
.arg1
= scm_cons (EVALCAR (proc
, env
), t
.arg1
);
2097 while (SCM_NIMP (proc
= SCM_CDR (proc
)));
2098 SCM_SETCDR (SCM_CAR (env
), t
.arg1
);
2099 goto nontoplevel_cdrxnoap
;
2102 case SCM_BIT8(SCM_IM_LETSTAR
):
2107 env
= EXTEND_ENV (SCM_EOL
, SCM_EOL
, env
);
2108 goto nontoplevel_cdrxnoap
;
2112 t
.arg1
= SCM_CAR (proc
);
2113 proc
= SCM_CDR (proc
);
2114 env
= EXTEND_ENV (t
.arg1
, EVALCAR (proc
, env
), env
);
2116 while (SCM_NIMP (proc
= SCM_CDR (proc
)));
2117 goto nontoplevel_cdrxnoap
;
2119 case SCM_BIT8(SCM_IM_OR
):
2122 while (!SCM_NULLP (t
.arg1
= SCM_CDR (t
.arg1
)))
2124 x
= EVALCAR (x
, env
);
2125 if (!SCM_FALSEP (x
))
2131 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
2135 case SCM_BIT8(SCM_IM_LAMBDA
):
2136 RETURN (scm_closure (SCM_CDR (x
), env
));
2139 case SCM_BIT8(SCM_IM_QUOTE
):
2140 RETURN (SCM_CAR (SCM_CDR (x
)));
2143 case SCM_BIT8(SCM_IM_SET_X
):
2146 switch (SCM_ITAG3 (proc
))
2149 if (SCM_VARIABLEP (proc
))
2150 t
.lloc
= SCM_VARIABLE_LOC (proc
);
2152 t
.lloc
= scm_lookupcar (x
, env
, 1);
2154 #ifdef MEMOIZE_LOCALS
2156 t
.lloc
= scm_ilookup (proc
, env
);
2161 *t
.lloc
= EVALCAR (x
, env
);
2165 RETURN (SCM_UNSPECIFIED
);
2169 case SCM_BIT8(SCM_IM_DEFINE
): /* only for internal defines */
2170 scm_misc_error (NULL
, "Bad define placement", SCM_EOL
);
2172 /* new syntactic forms go here. */
2173 case SCM_BIT8(SCM_MAKISYM (0)):
2175 SCM_ASRTGO (SCM_ISYMP (proc
), badfun
);
2176 switch SCM_ISYMNUM (proc
)
2178 case (SCM_ISYMNUM (SCM_IM_APPLY
)):
2180 proc
= EVALCAR (proc
, env
);
2181 SCM_ASRTGO (SCM_NIMP (proc
), badfun
);
2182 if (SCM_CLOSUREP (proc
))
2185 PREP_APPLY (proc
, SCM_EOL
);
2186 t
.arg1
= SCM_CDR (SCM_CDR (x
));
2187 t
.arg1
= EVALCAR (t
.arg1
, env
);
2189 /* Go here to tail-call a closure. PROC is the closure
2190 and T.ARG1 is the list of arguments. Do not forget to
2193 debug
.info
->a
.args
= t
.arg1
;
2195 #ifndef SCM_RECKLESS
2196 if (scm_badargsp (SCM_CLOSURE_FORMALS (proc
), t
.arg1
))
2200 /* Copy argument list */
2201 if (SCM_IMP (t
.arg1
))
2205 argl
= tl
= scm_cons (SCM_CAR (t
.arg1
), SCM_UNSPECIFIED
);
2206 while (SCM_NIMP (t
.arg1
= SCM_CDR (t
.arg1
))
2207 && SCM_CONSP (t
.arg1
))
2209 SCM_SETCDR (tl
, scm_cons (SCM_CAR (t
.arg1
),
2213 SCM_SETCDR (tl
, t
.arg1
);
2216 env
= EXTEND_ENV (SCM_CLOSURE_FORMALS (proc
), argl
, SCM_ENV (proc
));
2217 x
= SCM_CODE (proc
);
2218 goto nontoplevel_cdrxbegin
;
2223 case (SCM_ISYMNUM (SCM_IM_CONT
)):
2226 SCM val
= scm_make_continuation (&first
);
2234 proc
= evalcar (proc
, env
);
2235 SCM_ASRTGO (SCM_NIMP (proc
), badfun
);
2236 PREP_APPLY (proc
, scm_cons (t
.arg1
, SCM_EOL
));
2238 if (SCM_CLOSUREP(proc
) && scm_badformalsp (proc
, 1))
2239 goto umwrongnumargs
;
2242 case (SCM_ISYMNUM (SCM_IM_DELAY
)):
2243 RETURN (scm_makprom (scm_closure (SCM_CDR (x
), env
)))
2245 case (SCM_ISYMNUM (SCM_IM_DISPATCH
)):
2246 proc
= SCM_CADR (x
); /* unevaluated operands */
2247 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
2249 arg2
= *scm_ilookup (proc
, env
);
2250 else if (!SCM_CONSP (proc
))
2252 if (SCM_VARIABLEP (proc
))
2253 arg2
= SCM_VARIABLE_REF (proc
);
2255 arg2
= *scm_lookupcar (SCM_CDR (x
), env
, 1);
2259 arg2
= scm_cons (EVALCAR (proc
, env
), SCM_EOL
);
2260 t
.lloc
= SCM_CDRLOC (arg2
);
2261 while (SCM_NIMP (proc
= SCM_CDR (proc
)))
2263 *t
.lloc
= scm_cons (EVALCAR (proc
, env
), SCM_EOL
);
2264 t
.lloc
= SCM_CDRLOC (*t
.lloc
);
2269 /* The type dispatch code is duplicated here
2270 * (c.f. objects.c:scm_mcache_compute_cmethod) since that
2271 * cuts down execution time for type dispatch to 50%.
2274 long i
, n
, end
, mask
;
2275 SCM z
= SCM_CDDR (x
);
2276 n
= SCM_INUM (SCM_CAR (z
)); /* maximum number of specializers */
2277 proc
= SCM_CADR (z
);
2279 if (SCM_NIMP (proc
))
2281 /* Prepare for linear search */
2284 end
= SCM_VECTOR_LENGTH (proc
);
2288 /* Compute a hash value */
2289 long hashset
= SCM_INUM (proc
);
2292 mask
= SCM_INUM (SCM_CAR (z
));
2293 proc
= SCM_CADR (z
);
2296 if (SCM_NIMP (t
.arg1
))
2299 i
+= SCM_STRUCT_DATA (scm_class_of (SCM_CAR (t
.arg1
)))
2300 [scm_si_hashsets
+ hashset
];
2301 t
.arg1
= SCM_CDR (t
.arg1
);
2303 while (j
-- && SCM_NIMP (t
.arg1
));
2308 /* Search for match */
2312 z
= SCM_VELTS (proc
)[i
];
2313 t
.arg1
= arg2
; /* list of arguments */
2314 if (SCM_NIMP (t
.arg1
))
2317 /* More arguments than specifiers => CLASS != ENV */
2318 if (! SCM_EQ_P (scm_class_of (SCM_CAR (t
.arg1
)), SCM_CAR (z
)))
2320 t
.arg1
= SCM_CDR (t
.arg1
);
2323 while (j
-- && SCM_NIMP (t
.arg1
));
2324 /* Fewer arguments than specifiers => CAR != ENV */
2325 if (!(SCM_IMP (SCM_CAR (z
)) || SCM_CONSP (SCM_CAR (z
))))
2328 env
= EXTEND_ENV (SCM_CAR (SCM_CMETHOD_CODE (z
)),
2330 SCM_CMETHOD_ENV (z
));
2331 x
= SCM_CMETHOD_CODE (z
);
2332 goto nontoplevel_cdrxbegin
;
2337 z
= scm_memoize_method (x
, arg2
);
2341 case (SCM_ISYMNUM (SCM_IM_SLOT_REF
)):
2343 t
.arg1
= EVALCAR (x
, env
);
2344 RETURN (SCM_PACK (SCM_STRUCT_DATA (t
.arg1
) [SCM_INUM (SCM_CADR (x
))]))
2346 case (SCM_ISYMNUM (SCM_IM_SLOT_SET_X
)):
2348 t
.arg1
= EVALCAR (x
, env
);
2351 SCM_STRUCT_DATA (t
.arg1
) [SCM_INUM (SCM_CAR (x
))]
2352 = SCM_UNPACK (EVALCAR (proc
, env
));
2353 RETURN (SCM_UNSPECIFIED
)
2355 case (SCM_ISYMNUM (SCM_IM_NIL_COND
)):
2357 while (SCM_NIMP (x
= SCM_CDR (proc
)))
2359 if (!(SCM_FALSEP (t
.arg1
= EVALCAR (proc
, env
))
2360 || SCM_EQ_P (t
.arg1
, scm_lisp_nil
)))
2362 if (SCM_EQ_P (SCM_CAR (x
), SCM_UNSPECIFIED
))
2364 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
2370 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
2373 case (SCM_ISYMNUM (SCM_IM_NIL_IFY
)):
2375 RETURN ((SCM_FALSEP (proc
= EVALCAR (x
, env
)) || SCM_NULLP (proc
))
2379 case (SCM_ISYMNUM (SCM_IM_T_IFY
)):
2381 RETURN (!SCM_FALSEP (EVALCAR (x
, env
)) ? scm_lisp_t
: scm_lisp_nil
)
2383 case (SCM_ISYMNUM (SCM_IM_0_COND
)):
2385 while (SCM_NIMP (x
= SCM_CDR (proc
)))
2387 if (!(SCM_FALSEP (t
.arg1
= EVALCAR (proc
, env
))
2388 || SCM_EQ_P (t
.arg1
, SCM_INUM0
)))
2390 if (SCM_EQ_P (SCM_CAR (x
), SCM_UNSPECIFIED
))
2392 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
2398 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
2401 case (SCM_ISYMNUM (SCM_IM_0_IFY
)):
2403 RETURN (SCM_FALSEP (proc
= EVALCAR (x
, env
))
2407 case (SCM_ISYMNUM (SCM_IM_1_IFY
)):
2409 RETURN (!SCM_FALSEP (EVALCAR (x
, env
))
2413 case (SCM_ISYMNUM (SCM_IM_BIND
)):
2416 t
.arg1
= SCM_CAR (x
);
2417 arg2
= SCM_CDAR (env
);
2418 while (SCM_NIMP (arg2
))
2420 proc
= SCM_VARIABLE_REF (SCM_CAR (t
.arg1
));
2421 SCM_VARIABLE_SET (SCM_CAR (t
.arg1
), SCM_CAR (arg2
));
2422 SCM_SETCAR (arg2
, proc
);
2423 t
.arg1
= SCM_CDR (t
.arg1
);
2424 arg2
= SCM_CDR (arg2
);
2426 t
.arg1
= SCM_CAR (x
);
2427 scm_dynwinds
= scm_acons (t
.arg1
, SCM_CDAR (env
), scm_dynwinds
);
2429 arg2
= x
= SCM_CDR (x
);
2430 while (!SCM_NULLP (arg2
= SCM_CDR (arg2
)))
2432 SIDEVAL (SCM_CAR (x
), env
);
2435 proc
= EVALCAR (x
, env
);
2437 scm_dynwinds
= SCM_CDR (scm_dynwinds
);
2438 arg2
= SCM_CDAR (env
);
2439 while (SCM_NIMP (arg2
))
2441 SCM_VARIABLE_SET (SCM_CAR (t
.arg1
), SCM_CAR (arg2
));
2442 t
.arg1
= SCM_CDR (t
.arg1
);
2443 arg2
= SCM_CDR (arg2
);
2448 case (SCM_ISYMNUM (SCM_IM_CALL_WITH_VALUES
)):
2451 x
= EVALCAR (proc
, env
);
2452 proc
= SCM_CDR (proc
);
2453 proc
= EVALCAR (proc
, env
);
2454 t
.arg1
= SCM_APPLY (x
, SCM_EOL
, SCM_EOL
);
2455 if (SCM_VALUESP (t
.arg1
))
2456 t
.arg1
= scm_struct_ref (t
.arg1
, SCM_INUM0
);
2458 t
.arg1
= scm_cons (t
.arg1
, SCM_EOL
);
2459 if (SCM_CLOSUREP (proc
))
2461 PREP_APPLY (proc
, t
.arg1
);
2464 return SCM_APPLY (proc
, t
.arg1
, SCM_EOL
);
2474 /* scm_everr (x, env,...) */
2475 scm_misc_error (NULL
, "Wrong type to apply: ~S", scm_list_1 (proc
));
2476 case scm_tc7_vector
:
2480 case scm_tc7_byvect
:
2487 #ifdef HAVE_LONG_LONGS
2488 case scm_tc7_llvect
:
2491 case scm_tc7_string
:
2492 case scm_tc7_substring
:
2494 case scm_tcs_closures
:
2498 case scm_tcs_struct
:
2501 case scm_tc7_variable
:
2502 RETURN (SCM_VARIABLE_REF(x
));
2504 #ifdef MEMOIZE_LOCALS
2505 case SCM_BIT8(SCM_ILOC00
):
2506 proc
= *scm_ilookup (SCM_CAR (x
), env
);
2507 SCM_ASRTGO (SCM_NIMP (proc
), badfun
);
2508 #ifndef SCM_RECKLESS
2514 #endif /* ifdef MEMOIZE_LOCALS */
2516 case scm_tcs_cons_nimcar
:
2517 orig_sym
= SCM_CAR (x
);
2518 if (SCM_SYMBOLP (orig_sym
))
2521 t
.lloc
= scm_lookupcar1 (x
, env
, 1);
2524 /* we have lost the race, start again. */
2529 proc
= *scm_lookupcar (x
, env
, 1);
2534 SCM_SETCAR (x
, orig_sym
); /* Undo memoizing effect of
2538 if (SCM_MACROP (proc
))
2540 SCM_SETCAR (x
, orig_sym
); /* Undo memoizing effect of
2544 /* Set a flag during macro expansion so that macro
2545 application frames can be deleted from the backtrace. */
2546 SCM_SET_MACROEXP (debug
);
2548 t
.arg1
= SCM_APPLY (SCM_MACRO_CODE (proc
), x
,
2549 scm_cons (env
, scm_listofnull
));
2552 SCM_CLEAR_MACROEXP (debug
);
2554 switch (SCM_MACRO_TYPE (proc
))
2557 if (scm_ilength (t
.arg1
) <= 0)
2558 t
.arg1
= scm_cons2 (SCM_IM_BEGIN
, t
.arg1
, SCM_EOL
);
2560 if (!SCM_CLOSUREP (SCM_MACRO_CODE (proc
)))
2563 SCM_SETCAR (x
, SCM_CAR (t
.arg1
));
2564 SCM_SETCDR (x
, SCM_CDR (t
.arg1
));
2568 /* Prevent memoizing of debug info expression. */
2569 debug
.info
->e
.exp
= scm_cons_source (debug
.info
->e
.exp
,
2574 SCM_SETCAR (x
, SCM_CAR (t
.arg1
));
2575 SCM_SETCDR (x
, SCM_CDR (t
.arg1
));
2579 if (SCM_NIMP (x
= t
.arg1
))
2587 proc
= SCM_CEVAL (SCM_CAR (x
), env
);
2588 SCM_ASRTGO (!SCM_IMP (proc
), badfun
);
2589 #ifndef SCM_RECKLESS
2593 if (SCM_CLOSUREP (proc
))
2595 arg2
= SCM_CLOSURE_FORMALS (proc
);
2596 t
.arg1
= SCM_CDR (x
);
2597 while (!SCM_NULLP (arg2
))
2599 if (!SCM_CONSP (arg2
))
2601 if (SCM_IMP (t
.arg1
))
2602 goto umwrongnumargs
;
2603 arg2
= SCM_CDR (arg2
);
2604 t
.arg1
= SCM_CDR (t
.arg1
);
2606 if (!SCM_NULLP (t
.arg1
))
2607 goto umwrongnumargs
;
2609 else if (SCM_MACROP (proc
))
2610 goto handle_a_macro
;
2616 PREP_APPLY (proc
, SCM_EOL
);
2617 if (SCM_NULLP (SCM_CDR (x
))) {
2620 switch (SCM_TYP7 (proc
))
2621 { /* no arguments given */
2622 case scm_tc7_subr_0
:
2623 RETURN (SCM_SUBRF (proc
) ());
2624 case scm_tc7_subr_1o
:
2625 RETURN (SCM_SUBRF (proc
) (SCM_UNDEFINED
));
2627 RETURN (SCM_SUBRF (proc
) (SCM_EOL
));
2628 case scm_tc7_rpsubr
:
2629 RETURN (SCM_BOOL_T
);
2631 RETURN (SCM_SUBRF (proc
) (SCM_UNDEFINED
, SCM_UNDEFINED
));
2633 if (!SCM_SMOB_APPLICABLE_P (proc
))
2635 RETURN (SCM_SMOB_APPLY_0 (proc
));
2638 proc
= SCM_CCLO_SUBR (proc
);
2640 debug
.info
->a
.proc
= proc
;
2641 debug
.info
->a
.args
= scm_cons (t
.arg1
, SCM_EOL
);
2645 proc
= SCM_PROCEDURE (proc
);
2647 debug
.info
->a
.proc
= proc
;
2649 if (!SCM_CLOSUREP (proc
))
2651 if (scm_badformalsp (proc
, 0))
2652 goto umwrongnumargs
;
2653 case scm_tcs_closures
:
2654 x
= SCM_CODE (proc
);
2655 env
= EXTEND_ENV (SCM_CLOSURE_FORMALS (proc
), SCM_EOL
, SCM_ENV (proc
));
2656 goto nontoplevel_cdrxbegin
;
2657 case scm_tcs_struct
:
2658 if (SCM_OBJ_CLASS_FLAGS (proc
) & SCM_CLASSF_PURE_GENERIC
)
2660 x
= SCM_ENTITY_PROCEDURE (proc
);
2664 else if (!SCM_I_OPERATORP (proc
))
2669 proc
= (SCM_I_ENTITYP (proc
)
2670 ? SCM_ENTITY_PROCEDURE (proc
)
2671 : SCM_OPERATOR_PROCEDURE (proc
));
2673 debug
.info
->a
.proc
= proc
;
2674 debug
.info
->a
.args
= scm_cons (t
.arg1
, SCM_EOL
);
2676 if (SCM_NIMP (proc
))
2681 case scm_tc7_subr_1
:
2682 case scm_tc7_subr_2
:
2683 case scm_tc7_subr_2o
:
2685 case scm_tc7_subr_3
:
2686 case scm_tc7_lsubr_2
:
2690 /* scm_everr (x, env,...) */
2691 scm_wrong_num_args (proc
);
2693 /* handle macros here */
2698 /* must handle macros by here */
2703 else if (SCM_CONSP (x
))
2705 if (SCM_IMP (SCM_CAR (x
)))
2706 t
.arg1
= SCM_EVALIM (SCM_CAR (x
), env
);
2708 t
.arg1
= EVALCELLCAR (x
, env
);
2713 t
.arg1
= EVALCAR (x
, env
);
2716 debug
.info
->a
.args
= scm_cons (t
.arg1
, SCM_EOL
);
2723 switch (SCM_TYP7 (proc
))
2724 { /* have one argument in t.arg1 */
2725 case scm_tc7_subr_2o
:
2726 RETURN (SCM_SUBRF (proc
) (t
.arg1
, SCM_UNDEFINED
));
2727 case scm_tc7_subr_1
:
2728 case scm_tc7_subr_1o
:
2729 RETURN (SCM_SUBRF (proc
) (t
.arg1
));
2731 if (SCM_SUBRF (proc
))
2733 if (SCM_INUMP (t
.arg1
))
2735 RETURN (scm_make_real (SCM_DSUBRF (proc
) ((double) SCM_INUM (t
.arg1
))));
2737 else if (SCM_REALP (t
.arg1
))
2739 RETURN (scm_make_real (SCM_DSUBRF (proc
) (SCM_REAL_VALUE (t
.arg1
))));
2742 else if (SCM_BIGP (t
.arg1
))
2744 RETURN (scm_make_real (SCM_DSUBRF (proc
) (scm_i_big2dbl (t
.arg1
))));
2747 SCM_WTA_DISPATCH_1 (*SCM_SUBR_GENERIC (proc
), t
.arg1
,
2748 SCM_ARG1
, SCM_SYMBOL_CHARS (SCM_SNAME (proc
)));
2750 proc
= SCM_SNAME (proc
);
2752 char *chrs
= SCM_SYMBOL_CHARS (proc
) + SCM_SYMBOL_LENGTH (proc
) - 1;
2753 while ('c' != *--chrs
)
2755 SCM_ASSERT (SCM_CONSP (t
.arg1
),
2756 t
.arg1
, SCM_ARG1
, SCM_SYMBOL_CHARS (proc
));
2757 t
.arg1
= ('a' == *chrs
) ? SCM_CAR (t
.arg1
) : SCM_CDR (t
.arg1
);
2761 case scm_tc7_rpsubr
:
2762 RETURN (SCM_BOOL_T
);
2764 RETURN (SCM_SUBRF (proc
) (t
.arg1
, SCM_UNDEFINED
));
2767 RETURN (SCM_SUBRF (proc
) (debug
.info
->a
.args
))
2769 RETURN (SCM_SUBRF (proc
) (scm_cons (t
.arg1
, SCM_EOL
)));
2772 if (!SCM_SMOB_APPLICABLE_P (proc
))
2774 RETURN (SCM_SMOB_APPLY_1 (proc
, t
.arg1
));
2778 proc
= SCM_CCLO_SUBR (proc
);
2780 debug
.info
->a
.args
= scm_cons (t
.arg1
, debug
.info
->a
.args
);
2781 debug
.info
->a
.proc
= proc
;
2785 proc
= SCM_PROCEDURE (proc
);
2787 debug
.info
->a
.proc
= proc
;
2789 if (!SCM_CLOSUREP (proc
))
2791 if (scm_badformalsp (proc
, 1))
2792 goto umwrongnumargs
;
2793 case scm_tcs_closures
:
2795 x
= SCM_CODE (proc
);
2797 env
= EXTEND_ENV (SCM_CLOSURE_FORMALS (proc
), debug
.info
->a
.args
, SCM_ENV (proc
));
2799 env
= EXTEND_ENV (SCM_CLOSURE_FORMALS (proc
), scm_cons (t
.arg1
, SCM_EOL
), SCM_ENV (proc
));
2801 goto nontoplevel_cdrxbegin
;
2802 case scm_tcs_struct
:
2803 if (SCM_OBJ_CLASS_FLAGS (proc
) & SCM_CLASSF_PURE_GENERIC
)
2805 x
= SCM_ENTITY_PROCEDURE (proc
);
2807 arg2
= debug
.info
->a
.args
;
2809 arg2
= scm_cons (t
.arg1
, SCM_EOL
);
2813 else if (!SCM_I_OPERATORP (proc
))
2819 proc
= (SCM_I_ENTITYP (proc
)
2820 ? SCM_ENTITY_PROCEDURE (proc
)
2821 : SCM_OPERATOR_PROCEDURE (proc
));
2823 debug
.info
->a
.args
= scm_cons (t
.arg1
, debug
.info
->a
.args
);
2824 debug
.info
->a
.proc
= proc
;
2826 if (SCM_NIMP (proc
))
2831 case scm_tc7_subr_2
:
2832 case scm_tc7_subr_0
:
2833 case scm_tc7_subr_3
:
2834 case scm_tc7_lsubr_2
:
2843 else if (SCM_CONSP (x
))
2845 if (SCM_IMP (SCM_CAR (x
)))
2846 arg2
= SCM_EVALIM (SCM_CAR (x
), env
);
2848 arg2
= EVALCELLCAR (x
, env
);
2853 arg2
= EVALCAR (x
, env
);
2855 { /* have two or more arguments */
2857 debug
.info
->a
.args
= scm_cons2 (t
.arg1
, arg2
, SCM_EOL
);
2860 if (SCM_NULLP (x
)) {
2863 switch (SCM_TYP7 (proc
))
2864 { /* have two arguments */
2865 case scm_tc7_subr_2
:
2866 case scm_tc7_subr_2o
:
2867 RETURN (SCM_SUBRF (proc
) (t
.arg1
, arg2
));
2870 RETURN (SCM_SUBRF (proc
) (debug
.info
->a
.args
))
2872 RETURN (SCM_SUBRF (proc
) (scm_cons2 (t
.arg1
, arg2
, SCM_EOL
)));
2874 case scm_tc7_lsubr_2
:
2875 RETURN (SCM_SUBRF (proc
) (t
.arg1
, arg2
, SCM_EOL
));
2876 case scm_tc7_rpsubr
:
2878 RETURN (SCM_SUBRF (proc
) (t
.arg1
, arg2
));
2880 if (!SCM_SMOB_APPLICABLE_P (proc
))
2882 RETURN (SCM_SMOB_APPLY_2 (proc
, t
.arg1
, arg2
));
2886 RETURN (SCM_APPLY (SCM_CCLO_SUBR (proc
),
2887 scm_cons (proc
, debug
.info
->a
.args
),
2890 RETURN (SCM_APPLY (SCM_CCLO_SUBR (proc
),
2891 scm_cons2 (proc
, t
.arg1
,
2898 case scm_tcs_struct
:
2899 if (SCM_OBJ_CLASS_FLAGS (proc
) & SCM_CLASSF_PURE_GENERIC
)
2901 x
= SCM_ENTITY_PROCEDURE (proc
);
2903 arg2
= debug
.info
->a
.args
;
2905 arg2
= scm_cons2 (t
.arg1
, arg2
, SCM_EOL
);
2909 else if (!SCM_I_OPERATORP (proc
))
2915 RETURN (SCM_APPLY (SCM_I_ENTITYP (proc
)
2916 ? SCM_ENTITY_PROCEDURE (proc
)
2917 : SCM_OPERATOR_PROCEDURE (proc
),
2918 scm_cons (proc
, debug
.info
->a
.args
),
2921 RETURN (SCM_APPLY (SCM_I_ENTITYP (proc
)
2922 ? SCM_ENTITY_PROCEDURE (proc
)
2923 : SCM_OPERATOR_PROCEDURE (proc
),
2924 scm_cons2 (proc
, t
.arg1
,
2932 case scm_tc7_subr_0
:
2934 case scm_tc7_subr_1o
:
2935 case scm_tc7_subr_1
:
2936 case scm_tc7_subr_3
:
2941 proc
= SCM_PROCEDURE (proc
);
2943 debug
.info
->a
.proc
= proc
;
2945 if (!SCM_CLOSUREP (proc
))
2947 if (scm_badformalsp (proc
, 2))
2948 goto umwrongnumargs
;
2949 case scm_tcs_closures
:
2952 env
= EXTEND_ENV (SCM_CLOSURE_FORMALS (proc
),
2956 env
= EXTEND_ENV (SCM_CLOSURE_FORMALS (proc
),
2957 scm_cons2 (t
.arg1
, arg2
, SCM_EOL
), SCM_ENV (proc
));
2959 x
= SCM_CODE (proc
);
2960 goto nontoplevel_cdrxbegin
;
2964 if (SCM_IMP (x
) || !SCM_CONSP (x
))
2968 debug
.info
->a
.args
= scm_cons2 (t
.arg1
, arg2
,
2969 scm_deval_args (x
, env
, proc
,
2970 SCM_CDRLOC (SCM_CDR (debug
.info
->a
.args
))));
2974 switch (SCM_TYP7 (proc
))
2975 { /* have 3 or more arguments */
2977 case scm_tc7_subr_3
:
2978 SCM_ASRTGO (SCM_NULLP (SCM_CDR (x
)), wrongnumargs
);
2979 RETURN (SCM_SUBRF (proc
) (t
.arg1
, arg2
,
2980 SCM_CADDR (debug
.info
->a
.args
)));
2982 #ifdef BUILTIN_RPASUBR
2983 t
.arg1
= SCM_SUBRF(proc
)(t
.arg1
, arg2
);
2984 arg2
= SCM_CDR (SCM_CDR (debug
.info
->a
.args
));
2987 t
.arg1
= SCM_SUBRF(proc
)(t
.arg1
, SCM_CAR (arg2
));
2988 arg2
= SCM_CDR (arg2
);
2990 while (SCM_NIMP (arg2
));
2992 #endif /* BUILTIN_RPASUBR */
2993 case scm_tc7_rpsubr
:
2994 #ifdef BUILTIN_RPASUBR
2995 if (SCM_FALSEP (SCM_SUBRF (proc
) (t
.arg1
, arg2
)))
2997 t
.arg1
= SCM_CDR (SCM_CDR (debug
.info
->a
.args
));
3000 if (SCM_FALSEP (SCM_SUBRF (proc
) (arg2
, SCM_CAR (t
.arg1
))))
3002 arg2
= SCM_CAR (t
.arg1
);
3003 t
.arg1
= SCM_CDR (t
.arg1
);
3005 while (SCM_NIMP (t
.arg1
));
3007 #else /* BUILTIN_RPASUBR */
3008 RETURN (SCM_APPLY (proc
, t
.arg1
,
3010 SCM_CDR (SCM_CDR (debug
.info
->a
.args
)),
3012 #endif /* BUILTIN_RPASUBR */
3013 case scm_tc7_lsubr_2
:
3014 RETURN (SCM_SUBRF (proc
) (t
.arg1
, arg2
,
3015 SCM_CDR (SCM_CDR (debug
.info
->a
.args
))))
3017 RETURN (SCM_SUBRF (proc
) (debug
.info
->a
.args
))
3019 if (!SCM_SMOB_APPLICABLE_P (proc
))
3021 RETURN (SCM_SMOB_APPLY_3 (proc
, t
.arg1
, arg2
,
3022 SCM_CDDR (debug
.info
->a
.args
)));
3026 proc
= SCM_PROCEDURE (proc
);
3027 debug
.info
->a
.proc
= proc
;
3028 if (!SCM_CLOSUREP (proc
))
3030 if (scm_badargsp (SCM_CLOSURE_FORMALS (proc
), debug
.info
->a
.args
))
3031 goto umwrongnumargs
;
3032 case scm_tcs_closures
:
3033 SCM_SET_ARGSREADY (debug
);
3034 env
= EXTEND_ENV (SCM_CLOSURE_FORMALS (proc
),
3037 x
= SCM_CODE (proc
);
3038 goto nontoplevel_cdrxbegin
;
3040 case scm_tc7_subr_3
:
3041 SCM_ASRTGO (SCM_NULLP (SCM_CDR (x
)), wrongnumargs
);
3042 RETURN (SCM_SUBRF (proc
) (t
.arg1
, arg2
, EVALCAR (x
, env
)));
3044 #ifdef BUILTIN_RPASUBR
3045 t
.arg1
= SCM_SUBRF (proc
) (t
.arg1
, arg2
);
3048 t
.arg1
= SCM_SUBRF(proc
)(t
.arg1
, EVALCAR(x
, env
));
3051 while (SCM_NIMP (x
));
3053 #endif /* BUILTIN_RPASUBR */
3054 case scm_tc7_rpsubr
:
3055 #ifdef BUILTIN_RPASUBR
3056 if (SCM_FALSEP (SCM_SUBRF (proc
) (t
.arg1
, arg2
)))
3060 t
.arg1
= EVALCAR (x
, env
);
3061 if (SCM_FALSEP (SCM_SUBRF (proc
) (arg2
, t
.arg1
)))
3066 while (SCM_NIMP (x
));
3068 #else /* BUILTIN_RPASUBR */
3069 RETURN (SCM_APPLY (proc
, t
.arg1
,
3071 scm_eval_args (x
, env
, proc
),
3073 #endif /* BUILTIN_RPASUBR */
3074 case scm_tc7_lsubr_2
:
3075 RETURN (SCM_SUBRF (proc
) (t
.arg1
, arg2
, scm_eval_args (x
, env
, proc
)));
3077 RETURN (SCM_SUBRF (proc
) (scm_cons2 (t
.arg1
,
3079 scm_eval_args (x
, env
, proc
))));
3081 if (!SCM_SMOB_APPLICABLE_P (proc
))
3083 RETURN (SCM_SMOB_APPLY_3 (proc
, t
.arg1
, arg2
,
3084 scm_eval_args (x
, env
, proc
)));
3088 proc
= SCM_PROCEDURE (proc
);
3089 if (!SCM_CLOSUREP (proc
))
3092 SCM formals
= SCM_CLOSURE_FORMALS (proc
);
3093 if (SCM_NULLP (formals
)
3094 || (SCM_CONSP (formals
)
3095 && (SCM_NULLP (SCM_CDR (formals
))
3096 || (SCM_CONSP (SCM_CDR (formals
))
3097 && scm_badargsp (SCM_CDDR (formals
), x
)))))
3098 goto umwrongnumargs
;
3100 case scm_tcs_closures
:
3102 SCM_SET_ARGSREADY (debug
);
3104 env
= EXTEND_ENV (SCM_CLOSURE_FORMALS (proc
),
3107 scm_eval_args (x
, env
, proc
)),
3109 x
= SCM_CODE (proc
);
3110 goto nontoplevel_cdrxbegin
;
3112 case scm_tcs_struct
:
3113 if (SCM_OBJ_CLASS_FLAGS (proc
) & SCM_CLASSF_PURE_GENERIC
)
3116 arg2
= debug
.info
->a
.args
;
3118 arg2
= scm_cons2 (t
.arg1
, arg2
, scm_eval_args (x
, env
, proc
));
3120 x
= SCM_ENTITY_PROCEDURE (proc
);
3123 else if (!SCM_I_OPERATORP (proc
))
3127 case scm_tc7_subr_2
:
3128 case scm_tc7_subr_1o
:
3129 case scm_tc7_subr_2o
:
3130 case scm_tc7_subr_0
:
3132 case scm_tc7_subr_1
:
3140 if (CHECK_EXIT
&& SCM_TRAPS_P
)
3141 if (SCM_EXIT_FRAME_P
|| (SCM_TRACE_P
&& SCM_TRACED_FRAME_P (debug
)))
3143 SCM_CLEAR_TRACED_FRAME (debug
);
3144 if (SCM_CHEAPTRAPS_P
)
3145 t
.arg1
= scm_make_debugobj (&debug
);
3149 SCM val
= scm_make_continuation (&first
);
3160 scm_call_3 (SCM_EXIT_FRAME_HDLR
, scm_sym_exit_frame
, t
.arg1
, proc
);
3164 scm_last_debug_frame
= debug
.prev
;
3170 /* SECTION: This code is compiled once.
3176 /* Simple procedure calls
3180 scm_call_0 (SCM proc
)
3182 return scm_apply (proc
, SCM_EOL
, SCM_EOL
);
3186 scm_call_1 (SCM proc
, SCM arg1
)
3188 return scm_apply (proc
, arg1
, scm_listofnull
);
3192 scm_call_2 (SCM proc
, SCM arg1
, SCM arg2
)
3194 return scm_apply (proc
, arg1
, scm_cons (arg2
, scm_listofnull
));
3198 scm_call_3 (SCM proc
, SCM arg1
, SCM arg2
, SCM arg3
)
3200 return scm_apply (proc
, arg1
, scm_cons2 (arg2
, arg3
, scm_listofnull
));
3204 scm_call_4 (SCM proc
, SCM arg1
, SCM arg2
, SCM arg3
, SCM arg4
)
3206 return scm_apply (proc
, arg1
, scm_cons2 (arg2
, arg3
,
3207 scm_cons (arg4
, scm_listofnull
)));
3210 /* Simple procedure applies
3214 scm_apply_0 (SCM proc
, SCM args
)
3216 return scm_apply (proc
, args
, SCM_EOL
);
3220 scm_apply_1 (SCM proc
, SCM arg1
, SCM args
)
3222 return scm_apply (proc
, scm_cons (arg1
, args
), SCM_EOL
);
3226 scm_apply_2 (SCM proc
, SCM arg1
, SCM arg2
, SCM args
)
3228 return scm_apply (proc
, scm_cons2 (arg1
, arg2
, args
), SCM_EOL
);
3232 scm_apply_3 (SCM proc
, SCM arg1
, SCM arg2
, SCM arg3
, SCM args
)
3234 return scm_apply (proc
, scm_cons (arg1
, scm_cons2 (arg2
, arg3
, args
)),
3238 /* This code processes the arguments to apply:
3240 (apply PROC ARG1 ... ARGS)
3242 Given a list (ARG1 ... ARGS), this function conses the ARG1
3243 ... arguments onto the front of ARGS, and returns the resulting
3244 list. Note that ARGS is a list; thus, the argument to this
3245 function is a list whose last element is a list.
3247 Apply calls this function, and applies PROC to the elements of the
3248 result. apply:nconc2last takes care of building the list of
3249 arguments, given (ARG1 ... ARGS).
3251 Rather than do new consing, apply:nconc2last destroys its argument.
3252 On that topic, this code came into my care with the following
3253 beautifully cryptic comment on that topic: "This will only screw
3254 you if you do (scm_apply scm_apply '( ... ))" If you know what
3255 they're referring to, send me a patch to this comment. */
3257 SCM_DEFINE (scm_nconc2last
, "apply:nconc2last", 1, 0, 0,
3259 "Given a list (@var{arg1} @dots{} @var{args}), this function\n"
3260 "conses the @var{arg1} @dots{} arguments onto the front of\n"
3261 "@var{args}, and returns the resulting list. Note that\n"
3262 "@var{args} is a list; thus, the argument to this function is\n"
3263 "a list whose last element is a list.\n"
3264 "Note: Rather than do new consing, @code{apply:nconc2last}\n"
3265 "destroys its argument, so use with care.")
3266 #define FUNC_NAME s_scm_nconc2last
3269 SCM_VALIDATE_NONEMPTYLIST (1,lst
);
3271 while (!SCM_NULLP (SCM_CDR (*lloc
)))
3272 lloc
= SCM_CDRLOC (*lloc
);
3273 SCM_ASSERT (scm_ilength (SCM_CAR (*lloc
)) >= 0, lst
, SCM_ARG1
, FUNC_NAME
);
3274 *lloc
= SCM_CAR (*lloc
);
3282 /* SECTION: When DEVAL is defined this code yields scm_dapply.
3283 * It is compiled twice.
3289 scm_apply (SCM proc
, SCM arg1
, SCM args
)
3296 scm_dapply (SCM proc
, SCM arg1
, SCM args
)
3301 /* Apply a function to a list of arguments.
3303 This function is exported to the Scheme level as taking two
3304 required arguments and a tail argument, as if it were:
3305 (lambda (proc arg1 . args) ...)
3306 Thus, if you just have a list of arguments to pass to a procedure,
3307 pass the list as ARG1, and '() for ARGS. If you have some fixed
3308 args, pass the first as ARG1, then cons any remaining fixed args
3309 onto the front of your argument list, and pass that as ARGS. */
3312 SCM_APPLY (SCM proc
, SCM arg1
, SCM args
)
3314 #ifdef DEBUG_EXTENSIONS
3316 scm_t_debug_frame debug
;
3317 scm_t_debug_info debug_vect_body
;
3318 debug
.prev
= scm_last_debug_frame
;
3319 debug
.status
= SCM_APPLYFRAME
;
3320 debug
.vect
= &debug_vect_body
;
3321 debug
.vect
[0].a
.proc
= proc
;
3322 debug
.vect
[0].a
.args
= SCM_EOL
;
3323 scm_last_debug_frame
= &debug
;
3326 return scm_dapply (proc
, arg1
, args
);
3330 SCM_ASRTGO (SCM_NIMP (proc
), badproc
);
3332 /* If ARGS is the empty list, then we're calling apply with only two
3333 arguments --- ARG1 is the list of arguments for PROC. Whatever
3334 the case, futz with things so that ARG1 is the first argument to
3335 give to PROC (or SCM_UNDEFINED if no args), and ARGS contains the
3338 Setting the debug apply frame args this way is pretty messy.
3339 Perhaps we should store arg1 and args directly in the frame as
3340 received, and let scm_frame_arguments unpack them, because that's
3341 a relatively rare operation. This works for now; if the Guile
3342 developer archives are still around, see Mikael's post of
3344 if (SCM_NULLP (args
))
3346 if (SCM_NULLP (arg1
))
3348 arg1
= SCM_UNDEFINED
;
3350 debug
.vect
[0].a
.args
= SCM_EOL
;
3356 debug
.vect
[0].a
.args
= arg1
;
3358 args
= SCM_CDR (arg1
);
3359 arg1
= SCM_CAR (arg1
);
3364 args
= scm_nconc2last (args
);
3366 debug
.vect
[0].a
.args
= scm_cons (arg1
, args
);
3370 if (SCM_ENTER_FRAME_P
&& SCM_TRAPS_P
)
3373 if (SCM_CHEAPTRAPS_P
)
3374 tmp
= scm_make_debugobj (&debug
);
3379 tmp
= scm_make_continuation (&first
);
3384 scm_call_2 (SCM_ENTER_FRAME_HDLR
, scm_sym_enter_frame
, tmp
);
3391 switch (SCM_TYP7 (proc
))
3393 case scm_tc7_subr_2o
:
3394 args
= SCM_NULLP (args
) ? SCM_UNDEFINED
: SCM_CAR (args
);
3395 RETURN (SCM_SUBRF (proc
) (arg1
, args
))
3396 case scm_tc7_subr_2
:
3397 SCM_ASRTGO (!SCM_NULLP (args
) && SCM_NULLP (SCM_CDR (args
)),
3399 args
= SCM_CAR (args
);
3400 RETURN (SCM_SUBRF (proc
) (arg1
, args
))
3401 case scm_tc7_subr_0
:
3402 SCM_ASRTGO (SCM_UNBNDP (arg1
), wrongnumargs
);
3403 RETURN (SCM_SUBRF (proc
) ())
3404 case scm_tc7_subr_1
:
3405 SCM_ASRTGO (!SCM_UNBNDP (arg1
), wrongnumargs
);
3406 case scm_tc7_subr_1o
:
3407 SCM_ASRTGO (SCM_NULLP (args
), wrongnumargs
);
3408 RETURN (SCM_SUBRF (proc
) (arg1
))
3410 SCM_ASRTGO (!SCM_UNBNDP (arg1
) && SCM_NULLP (args
), wrongnumargs
);
3411 if (SCM_SUBRF (proc
))
3413 if (SCM_INUMP (arg1
))
3415 RETURN (scm_make_real (SCM_DSUBRF (proc
) ((double) SCM_INUM (arg1
))));
3417 else if (SCM_REALP (arg1
))
3419 RETURN (scm_make_real (SCM_DSUBRF (proc
) (SCM_REAL_VALUE (arg1
))));
3422 else if (SCM_BIGP (arg1
))
3423 RETURN (scm_make_real (SCM_DSUBRF (proc
) (scm_i_big2dbl (arg1
))))
3425 SCM_WTA_DISPATCH_1 (*SCM_SUBR_GENERIC (proc
), arg1
,
3426 SCM_ARG1
, SCM_SYMBOL_CHARS (SCM_SNAME (proc
)));
3428 proc
= SCM_SNAME (proc
);
3430 char *chrs
= SCM_SYMBOL_CHARS (proc
) + SCM_SYMBOL_LENGTH (proc
) - 1;
3431 while ('c' != *--chrs
)
3433 SCM_ASSERT (SCM_CONSP (arg1
),
3434 arg1
, SCM_ARG1
, SCM_SYMBOL_CHARS (proc
));
3435 arg1
= ('a' == *chrs
) ? SCM_CAR (arg1
) : SCM_CDR (arg1
);
3439 case scm_tc7_subr_3
:
3440 SCM_ASRTGO (!SCM_NULLP (args
)
3441 && !SCM_NULLP (SCM_CDR (args
))
3442 && SCM_NULLP (SCM_CDDR (args
)),
3444 RETURN (SCM_SUBRF (proc
) (arg1
, SCM_CAR (args
), SCM_CAR (SCM_CDR (args
))))
3447 RETURN (SCM_SUBRF (proc
) (SCM_UNBNDP (arg1
) ? SCM_EOL
: debug
.vect
[0].a
.args
))
3449 RETURN (SCM_SUBRF (proc
) (SCM_UNBNDP (arg1
) ? SCM_EOL
: scm_cons (arg1
, args
)))
3451 case scm_tc7_lsubr_2
:
3452 SCM_ASRTGO (SCM_CONSP (args
), wrongnumargs
);
3453 RETURN (SCM_SUBRF (proc
) (arg1
, SCM_CAR (args
), SCM_CDR (args
)))
3455 if (SCM_NULLP (args
))
3456 RETURN (SCM_SUBRF (proc
) (arg1
, SCM_UNDEFINED
))
3457 while (SCM_NIMP (args
))
3459 SCM_ASSERT (SCM_CONSP (args
), args
, SCM_ARG2
, "apply");
3460 arg1
= SCM_SUBRF (proc
) (arg1
, SCM_CAR (args
));
3461 args
= SCM_CDR (args
);
3464 case scm_tc7_rpsubr
:
3465 if (SCM_NULLP (args
))
3466 RETURN (SCM_BOOL_T
);
3467 while (SCM_NIMP (args
))
3469 SCM_ASSERT (SCM_CONSP (args
), args
, SCM_ARG2
, "apply");
3470 if (SCM_FALSEP (SCM_SUBRF (proc
) (arg1
, SCM_CAR (args
))))
3471 RETURN (SCM_BOOL_F
);
3472 arg1
= SCM_CAR (args
);
3473 args
= SCM_CDR (args
);
3475 RETURN (SCM_BOOL_T
);
3476 case scm_tcs_closures
:
3478 arg1
= (SCM_UNBNDP (arg1
) ? SCM_EOL
: debug
.vect
[0].a
.args
);
3480 arg1
= (SCM_UNBNDP (arg1
) ? SCM_EOL
: scm_cons (arg1
, args
));
3482 #ifndef SCM_RECKLESS
3483 if (scm_badargsp (SCM_CLOSURE_FORMALS (proc
), arg1
))
3487 /* Copy argument list */
3492 SCM tl
= args
= scm_cons (SCM_CAR (arg1
), SCM_UNSPECIFIED
);
3493 while (arg1
= SCM_CDR (arg1
), SCM_CONSP (arg1
))
3495 SCM_SETCDR (tl
, scm_cons (SCM_CAR (arg1
),
3499 SCM_SETCDR (tl
, arg1
);
3502 args
= EXTEND_ENV (SCM_CLOSURE_FORMALS (proc
), args
, SCM_ENV (proc
));
3503 proc
= SCM_CDR (SCM_CODE (proc
));
3506 while (!SCM_NULLP (arg1
= SCM_CDR (arg1
)))
3508 if (SCM_IMP (SCM_CAR (proc
)))
3510 if (SCM_ISYMP (SCM_CAR (proc
)))
3512 proc
= scm_m_expand_body (proc
, args
);
3516 SCM_VALIDATE_NON_EMPTY_COMBINATION (SCM_CAR (proc
));
3519 SCM_CEVAL (SCM_CAR (proc
), args
);
3522 RETURN (EVALCAR (proc
, args
));
3524 if (!SCM_SMOB_APPLICABLE_P (proc
))
3526 if (SCM_UNBNDP (arg1
))
3527 RETURN (SCM_SMOB_APPLY_0 (proc
))
3528 else if (SCM_NULLP (args
))
3529 RETURN (SCM_SMOB_APPLY_1 (proc
, arg1
))
3530 else if (SCM_NULLP (SCM_CDR (args
)))
3531 RETURN (SCM_SMOB_APPLY_2 (proc
, arg1
, SCM_CAR (args
)))
3533 RETURN (SCM_SMOB_APPLY_3 (proc
, arg1
, SCM_CAR (args
), SCM_CDR (args
)));
3536 args
= (SCM_UNBNDP(arg1
) ? SCM_EOL
: debug
.vect
[0].a
.args
);
3538 proc
= SCM_CCLO_SUBR (proc
);
3539 debug
.vect
[0].a
.proc
= proc
;
3540 debug
.vect
[0].a
.args
= scm_cons (arg1
, args
);
3542 args
= (SCM_UNBNDP(arg1
) ? SCM_EOL
: scm_cons (arg1
, args
));
3544 proc
= SCM_CCLO_SUBR (proc
);
3548 proc
= SCM_PROCEDURE (proc
);
3550 debug
.vect
[0].a
.proc
= proc
;
3553 case scm_tcs_struct
:
3554 if (SCM_OBJ_CLASS_FLAGS (proc
) & SCM_CLASSF_PURE_GENERIC
)
3557 args
= (SCM_UNBNDP(arg1
) ? SCM_EOL
: debug
.vect
[0].a
.args
);
3559 args
= (SCM_UNBNDP(arg1
) ? SCM_EOL
: scm_cons (arg1
, args
));
3561 RETURN (scm_apply_generic (proc
, args
));
3563 else if (!SCM_I_OPERATORP (proc
))
3568 args
= (SCM_UNBNDP(arg1
) ? SCM_EOL
: debug
.vect
[0].a
.args
);
3570 args
= (SCM_UNBNDP(arg1
) ? SCM_EOL
: scm_cons (arg1
, args
));
3573 proc
= (SCM_I_ENTITYP (proc
)
3574 ? SCM_ENTITY_PROCEDURE (proc
)
3575 : SCM_OPERATOR_PROCEDURE (proc
));
3577 debug
.vect
[0].a
.proc
= proc
;
3578 debug
.vect
[0].a
.args
= scm_cons (arg1
, args
);
3580 if (SCM_NIMP (proc
))
3586 scm_wrong_num_args (proc
);
3589 scm_wrong_type_arg ("apply", SCM_ARG1
, proc
);
3594 if (CHECK_EXIT
&& SCM_TRAPS_P
)
3595 if (SCM_EXIT_FRAME_P
|| (SCM_TRACE_P
&& SCM_TRACED_FRAME_P (debug
)))
3597 SCM_CLEAR_TRACED_FRAME (debug
);
3598 if (SCM_CHEAPTRAPS_P
)
3599 arg1
= scm_make_debugobj (&debug
);
3603 SCM val
= scm_make_continuation (&first
);
3614 scm_call_3 (SCM_EXIT_FRAME_HDLR
, scm_sym_exit_frame
, arg1
, proc
);
3618 scm_last_debug_frame
= debug
.prev
;
3624 /* SECTION: The rest of this file is only read once.
3629 /* Typechecking for multi-argument MAP and FOR-EACH.
3631 Verify that each element of the vector ARGV, except for the first,
3632 is a proper list whose length is LEN. Attribute errors to WHO,
3633 and claim that the i'th element of ARGV is WHO's i+2'th argument. */
3635 check_map_args (SCM argv
,
3642 SCM
*ve
= SCM_VELTS (argv
);
3645 for (i
= SCM_VECTOR_LENGTH (argv
) - 1; i
>= 1; i
--)
3647 long elt_len
= scm_ilength (ve
[i
]);
3652 scm_apply_generic (gf
, scm_cons (proc
, args
));
3654 scm_wrong_type_arg (who
, i
+ 2, ve
[i
]);
3658 scm_out_of_range (who
, ve
[i
]);
3661 scm_remember_upto_here_1 (argv
);
3665 SCM_GPROC (s_map
, "map", 2, 0, 1, scm_map
, g_map
);
3667 /* Note: Currently, scm_map applies PROC to the argument list(s)
3668 sequentially, starting with the first element(s). This is used in
3669 evalext.c where the Scheme procedure `map-in-order', which guarantees
3670 sequential behaviour, is implemented using scm_map. If the
3671 behaviour changes, we need to update `map-in-order'.
3675 scm_map (SCM proc
, SCM arg1
, SCM args
)
3676 #define FUNC_NAME s_map
3681 SCM
*ve
= &args
; /* Keep args from being optimized away. */
3683 len
= scm_ilength (arg1
);
3684 SCM_GASSERTn (len
>= 0,
3685 g_map
, scm_cons2 (proc
, arg1
, args
), SCM_ARG2
, s_map
);
3686 SCM_VALIDATE_REST_ARGUMENT (args
);
3687 if (SCM_NULLP (args
))
3689 while (SCM_NIMP (arg1
))
3691 *pres
= scm_cons (scm_apply (proc
, SCM_CAR (arg1
), scm_listofnull
),
3693 pres
= SCM_CDRLOC (*pres
);
3694 arg1
= SCM_CDR (arg1
);
3698 args
= scm_vector (arg1
= scm_cons (arg1
, args
));
3699 ve
= SCM_VELTS (args
);
3700 #ifndef SCM_RECKLESS
3701 check_map_args (args
, len
, g_map
, proc
, arg1
, s_map
);
3706 for (i
= SCM_VECTOR_LENGTH (args
) - 1; i
>= 0; i
--)
3708 if (SCM_IMP (ve
[i
]))
3710 arg1
= scm_cons (SCM_CAR (ve
[i
]), arg1
);
3711 ve
[i
] = SCM_CDR (ve
[i
]);
3713 *pres
= scm_cons (scm_apply (proc
, arg1
, SCM_EOL
), SCM_EOL
);
3714 pres
= SCM_CDRLOC (*pres
);
3720 SCM_GPROC (s_for_each
, "for-each", 2, 0, 1, scm_for_each
, g_for_each
);
3723 scm_for_each (SCM proc
, SCM arg1
, SCM args
)
3724 #define FUNC_NAME s_for_each
3726 SCM
*ve
= &args
; /* Keep args from being optimized away. */
3728 len
= scm_ilength (arg1
);
3729 SCM_GASSERTn (len
>= 0, g_for_each
, scm_cons2 (proc
, arg1
, args
),
3730 SCM_ARG2
, s_for_each
);
3731 SCM_VALIDATE_REST_ARGUMENT (args
);
3734 while SCM_NIMP (arg1
)
3736 scm_apply (proc
, SCM_CAR (arg1
), scm_listofnull
);
3737 arg1
= SCM_CDR (arg1
);
3739 return SCM_UNSPECIFIED
;
3741 args
= scm_vector (arg1
= scm_cons (arg1
, args
));
3742 ve
= SCM_VELTS (args
);
3743 #ifndef SCM_RECKLESS
3744 check_map_args (args
, len
, g_for_each
, proc
, arg1
, s_for_each
);
3749 for (i
= SCM_VECTOR_LENGTH (args
) - 1; i
>= 0; i
--)
3752 (ve
[i
]) return SCM_UNSPECIFIED
;
3753 arg1
= scm_cons (SCM_CAR (ve
[i
]), arg1
);
3754 ve
[i
] = SCM_CDR (ve
[i
]);
3756 scm_apply (proc
, arg1
, SCM_EOL
);
3763 scm_closure (SCM code
, SCM env
)
3768 SCM_SETCODE (z
, code
);
3769 SCM_SETENV (z
, env
);
3774 scm_t_bits scm_tc16_promise
;
3777 scm_makprom (SCM code
)
3779 SCM_RETURN_NEWSMOB (scm_tc16_promise
, SCM_UNPACK (code
));
3785 promise_print (SCM exp
, SCM port
, scm_print_state
*pstate
)
3787 int writingp
= SCM_WRITINGP (pstate
);
3788 scm_puts ("#<promise ", port
);
3789 SCM_SET_WRITINGP (pstate
, 1);
3790 scm_iprin1 (SCM_CELL_OBJECT_1 (exp
), port
, pstate
);
3791 SCM_SET_WRITINGP (pstate
, writingp
);
3792 scm_putc ('>', port
);
3797 SCM_DEFINE (scm_force
, "force", 1, 0, 0,
3799 "If the promise @var{x} has not been computed yet, compute and\n"
3800 "return @var{x}, otherwise just return the previously computed\n"
3802 #define FUNC_NAME s_scm_force
3804 SCM_VALIDATE_SMOB (1, x
, promise
);
3805 if (!((1L << 16) & SCM_CELL_WORD_0 (x
)))
3807 SCM ans
= scm_call_0 (SCM_CELL_OBJECT_1 (x
));
3808 if (!((1L << 16) & SCM_CELL_WORD_0 (x
)))
3811 SCM_SET_CELL_OBJECT_1 (x
, ans
);
3812 SCM_SET_CELL_WORD_0 (x
, SCM_CELL_WORD_0 (x
) | (1L << 16));
3816 return SCM_CELL_OBJECT_1 (x
);
3821 SCM_DEFINE (scm_promise_p
, "promise?", 1, 0, 0,
3823 "Return true if @var{obj} is a promise, i.e. a delayed computation\n"
3824 "(@pxref{Delayed evaluation,,,r5rs.info,The Revised^5 Report on Scheme}).")
3825 #define FUNC_NAME s_scm_promise_p
3827 return SCM_BOOL (SCM_TYP16_PREDICATE (scm_tc16_promise
, obj
));
3832 SCM_DEFINE (scm_cons_source
, "cons-source", 3, 0, 0,
3833 (SCM xorig
, SCM x
, SCM y
),
3834 "Create and return a new pair whose car and cdr are @var{x} and @var{y}.\n"
3835 "Any source properties associated with @var{xorig} are also associated\n"
3836 "with the new pair.")
3837 #define FUNC_NAME s_scm_cons_source
3841 SCM_SET_CELL_OBJECT_0 (z
, x
);
3842 SCM_SET_CELL_OBJECT_1 (z
, y
);
3843 /* Copy source properties possibly associated with xorig. */
3844 p
= scm_whash_lookup (scm_source_whash
, xorig
);
3846 scm_whash_insert (scm_source_whash
, z
, p
);
3852 SCM_DEFINE (scm_copy_tree
, "copy-tree", 1, 0, 0,
3854 "Recursively copy the data tree that is bound to @var{obj}, and return a\n"
3855 "pointer to the new data structure. @code{copy-tree} recurses down the\n"
3856 "contents of both pairs and vectors (since both cons cells and vector\n"
3857 "cells may point to arbitrary objects), and stops recursing when it hits\n"
3858 "any other object.")
3859 #define FUNC_NAME s_scm_copy_tree
3864 if (SCM_VECTORP (obj
))
3866 unsigned long i
= SCM_VECTOR_LENGTH (obj
);
3867 ans
= scm_c_make_vector (i
, SCM_UNSPECIFIED
);
3869 SCM_VELTS (ans
)[i
] = scm_copy_tree (SCM_VELTS (obj
)[i
]);
3872 if (!SCM_CONSP (obj
))
3874 ans
= tl
= scm_cons_source (obj
,
3875 scm_copy_tree (SCM_CAR (obj
)),
3877 while (obj
= SCM_CDR (obj
), SCM_CONSP (obj
))
3879 SCM_SETCDR (tl
, scm_cons (scm_copy_tree (SCM_CAR (obj
)),
3883 SCM_SETCDR (tl
, obj
);
3889 /* We have three levels of EVAL here:
3891 - scm_i_eval (exp, env)
3893 evaluates EXP in environment ENV. ENV is a lexical environment
3894 structure as used by the actual tree code evaluator. When ENV is
3895 a top-level environment, then changes to the current module are
3896 tracked by updating ENV so that it continues to be in sync with
3899 - scm_primitive_eval (exp)
3901 evaluates EXP in the top-level environment as determined by the
3902 current module. This is done by constructing a suitable
3903 environment and calling scm_i_eval. Thus, changes to the
3904 top-level module are tracked normally.
3906 - scm_eval (exp, mod)
3908 evaluates EXP while MOD is the current module. This is done by
3909 setting the current module to MOD, invoking scm_primitive_eval on
3910 EXP, and then restoring the current module to the value it had
3911 previously. That is, while EXP is evaluated, changes to the
3912 current module are tracked, but these changes do not persist when
3915 For each level of evals, there are two variants, distinguished by a
3916 _x suffix: the ordinary variant does not modify EXP while the _x
3917 variant can destructively modify EXP into something completely
3918 unintelligible. A Scheme data structure passed as EXP to one of the
3919 _x variants should not ever be used again for anything. So when in
3920 doubt, use the ordinary variant.
3925 scm_i_eval_x (SCM exp
, SCM env
)
3927 return SCM_XEVAL (exp
, env
);
3931 scm_i_eval (SCM exp
, SCM env
)
3933 exp
= scm_copy_tree (exp
);
3934 return SCM_XEVAL (exp
, env
);
3938 scm_primitive_eval_x (SCM exp
)
3941 SCM transformer
= scm_current_module_transformer ();
3942 if (SCM_NIMP (transformer
))
3943 exp
= scm_call_1 (transformer
, exp
);
3944 env
= scm_top_level_env (scm_current_module_lookup_closure ());
3945 return scm_i_eval_x (exp
, env
);
3948 SCM_DEFINE (scm_primitive_eval
, "primitive-eval", 1, 0, 0,
3950 "Evaluate @var{exp} in the top-level environment specified by\n"
3951 "the current module.")
3952 #define FUNC_NAME s_scm_primitive_eval
3955 SCM transformer
= scm_current_module_transformer ();
3956 if (SCM_NIMP (transformer
))
3957 exp
= scm_call_1 (transformer
, exp
);
3958 env
= scm_top_level_env (scm_current_module_lookup_closure ());
3959 return scm_i_eval (exp
, env
);
3963 /* Eval does not take the second arg optionally. This is intentional
3964 * in order to be R5RS compatible, and to prepare for the new module
3965 * system, where we would like to make the choice of evaluation
3966 * environment explicit. */
3969 change_environment (void *data
)
3971 SCM pair
= SCM_PACK (data
);
3972 SCM new_module
= SCM_CAR (pair
);
3973 SCM old_module
= scm_current_module ();
3974 SCM_SETCDR (pair
, old_module
);
3975 scm_set_current_module (new_module
);
3980 restore_environment (void *data
)
3982 SCM pair
= SCM_PACK (data
);
3983 SCM old_module
= SCM_CDR (pair
);
3984 SCM new_module
= scm_current_module ();
3985 SCM_SETCAR (pair
, new_module
);
3986 scm_set_current_module (old_module
);
3990 inner_eval_x (void *data
)
3992 return scm_primitive_eval_x (SCM_PACK(data
));
3996 scm_eval_x (SCM exp
, SCM module
)
3997 #define FUNC_NAME "eval!"
3999 SCM_VALIDATE_MODULE (2, module
);
4001 return scm_internal_dynamic_wind
4002 (change_environment
, inner_eval_x
, restore_environment
,
4003 (void *) SCM_UNPACK (exp
),
4004 (void *) SCM_UNPACK (scm_cons (module
, SCM_BOOL_F
)));
4009 inner_eval (void *data
)
4011 return scm_primitive_eval (SCM_PACK(data
));
4014 SCM_DEFINE (scm_eval
, "eval", 2, 0, 0,
4015 (SCM exp
, SCM module
),
4016 "Evaluate @var{exp}, a list representing a Scheme expression,\n"
4017 "in the top-level environment specified by @var{module}.\n"
4018 "While @var{exp} is evaluated (using @var{primitive-eval}),\n"
4019 "@var{module} is made the current module. The current module\n"
4020 "is reset to its previous value when @var{eval} returns.")
4021 #define FUNC_NAME s_scm_eval
4023 SCM_VALIDATE_MODULE (2, module
);
4025 return scm_internal_dynamic_wind
4026 (change_environment
, inner_eval
, restore_environment
,
4027 (void *) SCM_UNPACK (exp
),
4028 (void *) SCM_UNPACK (scm_cons (module
, SCM_BOOL_F
)));
4032 #if (SCM_DEBUG_DEPRECATED == 0)
4034 /* Use scm_current_module () or scm_interaction_environment ()
4035 * instead. The former is the module selected during loading of code.
4036 * The latter is the module in which the user of this thread currently
4037 * types expressions.
4040 SCM scm_top_level_lookup_closure_var
;
4041 SCM scm_system_transformer
;
4043 /* Avoid using this functionality altogether (except for implementing
4044 * libguile, where you can use scm_i_eval or scm_i_eval_x).
4046 * Applications should use either C level scm_eval_x or Scheme
4047 * scm_eval; or scm_primitive_eval_x or scm_primitive_eval. */
4050 scm_eval_3 (SCM obj
, int copyp
, SCM env
)
4053 return scm_i_eval (obj
, env
);
4055 return scm_i_eval_x (obj
, env
);
4058 SCM_DEFINE (scm_eval2
, "eval2", 2, 0, 0,
4059 (SCM obj
, SCM env_thunk
),
4060 "Evaluate @var{exp}, a Scheme expression, in the environment\n"
4061 "designated by @var{lookup}, a symbol-lookup function."
4062 "Do not use this version of eval, it does not play well\n"
4063 "with the module system. Use @code{eval} or\n"
4064 "@code{primitive-eval} instead.")
4065 #define FUNC_NAME s_scm_eval2
4067 return scm_i_eval (obj
, scm_top_level_env (env_thunk
));
4071 #endif /* DEPRECATED */
4074 /* At this point, scm_deval and scm_dapply are generated.
4077 #ifdef DEBUG_EXTENSIONS
4087 scm_init_opts (scm_evaluator_traps
,
4088 scm_evaluator_trap_table
,
4089 SCM_N_EVALUATOR_TRAPS
);
4090 scm_init_opts (scm_eval_options_interface
,
4092 SCM_N_EVAL_OPTIONS
);
4094 scm_tc16_promise
= scm_make_smob_type ("promise", 0);
4095 scm_set_smob_mark (scm_tc16_promise
, scm_markcdr
);
4096 scm_set_smob_print (scm_tc16_promise
, promise_print
);
4098 /* Dirk:Fixme:: make scm_undefineds local to eval.c: it's only used here. */
4099 scm_undefineds
= scm_cons (SCM_UNDEFINED
, SCM_EOL
);
4100 SCM_SETCDR (scm_undefineds
, scm_undefineds
);
4101 scm_listofnull
= scm_cons (SCM_EOL
, SCM_EOL
);
4103 scm_f_apply
= scm_c_define_subr ("apply", scm_tc7_lsubr_2
, scm_apply
);
4108 #if SCM_DEBUG_DEPRECATED == 0
4109 scm_top_level_lookup_closure_var
=
4110 scm_c_define ("*top-level-lookup-closure*", scm_make_fluid ());
4111 scm_system_transformer
=
4112 scm_c_define ("scm:eval-transformer", scm_make_fluid ());
4115 #ifndef SCM_MAGIC_SNARFER
4116 #include "libguile/eval.x"
4119 scm_c_define ("nil", scm_lisp_nil
);
4120 scm_c_define ("t", scm_lisp_t
);
4122 scm_add_feature ("delay");