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_NNULLP (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_NNULLP (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_NCONSP (proc
))
678 while (SCM_NIMP (proc
))
680 if (SCM_NCONSP (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_NNULLP (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_NCELLP (x
) || SCM_NCONSP (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_NNULLP (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_NFALSEP (p
))
1463 scm_whash_insert (scm_source_whash
, ls
, p
);
1470 scm_unmemocopy (SCM x
, SCM env
)
1472 if (SCM_NNULLP (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_NCONSP (formals
))
1491 formals
= SCM_CDR (formals
);
1492 args
= SCM_CDR (args
);
1494 return SCM_NNULLP (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
)
1540 while (SCM_NNULLP (next
= SCM_CDR (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
);
1554 return SCM_XEVALCAR (code
, env
);
1561 /* SECTION: This code is specific for the debugging support. One
1562 * branch is read when DEVAL isn't defined, the other when DEVAL is
1568 #define SCM_APPLY scm_apply
1569 #define PREP_APPLY(proc, args)
1571 #define RETURN(x) return x;
1572 #ifdef STACK_CHECKING
1573 #ifndef NO_CEVAL_STACK_CHECKING
1574 #define EVAL_STACK_CHECKING
1581 #define SCM_CEVAL scm_deval /* Substitute all uses of scm_ceval */
1583 #define SCM_APPLY scm_dapply
1585 #define PREP_APPLY(p, l) \
1586 { ++debug.info; debug.info->a.proc = p; debug.info->a.args = l; }
1588 #define ENTER_APPLY \
1590 SCM_SET_ARGSREADY (debug);\
1591 if (CHECK_APPLY && SCM_TRAPS_P)\
1592 if (SCM_APPLY_FRAME_P || (SCM_TRACE_P && PROCTRACEP (proc)))\
1594 SCM tmp, tail = SCM_BOOL(SCM_TRACED_FRAME_P (debug)); \
1595 SCM_SET_TRACED_FRAME (debug); \
1597 if (SCM_CHEAPTRAPS_P)\
1599 tmp = scm_make_debugobj (&debug);\
1600 scm_call_3 (SCM_APPLY_FRAME_HDLR, scm_sym_apply_frame, tmp, tail);\
1605 tmp = scm_make_continuation (&first);\
1607 scm_call_3 (SCM_APPLY_FRAME_HDLR, scm_sym_apply_frame, tmp, tail);\
1613 #define RETURN(e) {proc = (e); goto exit;}
1614 #ifdef STACK_CHECKING
1615 #ifndef EVAL_STACK_CHECKING
1616 #define EVAL_STACK_CHECKING
1620 /* scm_ceval_ptr points to the currently selected evaluator.
1621 * *fixme*: Although efficiency is important here, this state variable
1622 * should probably not be a global. It should be related to the
1627 SCM (*scm_ceval_ptr
) (SCM x
, SCM env
);
1629 /* scm_last_debug_frame contains a pointer to the last debugging
1630 * information stack frame. It is accessed very often from the
1631 * debugging evaluator, so it should probably not be indirectly
1632 * addressed. Better to save and restore it from the current root at
1637 scm_t_debug_frame
*scm_last_debug_frame
;
1640 /* scm_debug_eframe_size is the number of slots available for pseudo
1641 * stack frames at each real stack frame.
1644 long scm_debug_eframe_size
;
1646 int scm_debug_mode
, scm_check_entry_p
, scm_check_apply_p
, scm_check_exit_p
;
1648 long scm_eval_stack
;
1650 scm_t_option scm_eval_opts
[] = {
1651 { SCM_OPTION_INTEGER
, "stack", 22000, "Size of thread stacks (in machine words)." }
1654 scm_t_option scm_debug_opts
[] = {
1655 { SCM_OPTION_BOOLEAN
, "cheap", 1,
1656 "*Flyweight representation of the stack at traps." },
1657 { SCM_OPTION_BOOLEAN
, "breakpoints", 0, "*Check for breakpoints." },
1658 { SCM_OPTION_BOOLEAN
, "trace", 0, "*Trace mode." },
1659 { SCM_OPTION_BOOLEAN
, "procnames", 1,
1660 "Record procedure names at definition." },
1661 { SCM_OPTION_BOOLEAN
, "backwards", 0,
1662 "Display backtrace in anti-chronological order." },
1663 { SCM_OPTION_INTEGER
, "width", 79, "Maximal width of backtrace." },
1664 { SCM_OPTION_INTEGER
, "indent", 10, "Maximal indentation in backtrace." },
1665 { SCM_OPTION_INTEGER
, "frames", 3,
1666 "Maximum number of tail-recursive frames in backtrace." },
1667 { SCM_OPTION_INTEGER
, "maxdepth", 1000,
1668 "Maximal number of stored backtrace frames." },
1669 { SCM_OPTION_INTEGER
, "depth", 20, "Maximal length of printed backtrace." },
1670 { SCM_OPTION_BOOLEAN
, "backtrace", 0, "Show backtrace on error." },
1671 { SCM_OPTION_BOOLEAN
, "debug", 0, "Use the debugging evaluator." },
1672 { SCM_OPTION_INTEGER
, "stack", 20000, "Stack size limit (measured in words; 0 = no check)." },
1673 { 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."}
1676 scm_t_option scm_evaluator_trap_table
[] = {
1677 { SCM_OPTION_BOOLEAN
, "traps", 0, "Enable evaluator traps." },
1678 { SCM_OPTION_BOOLEAN
, "enter-frame", 0, "Trap when eval enters new frame." },
1679 { SCM_OPTION_BOOLEAN
, "apply-frame", 0, "Trap when entering apply." },
1680 { SCM_OPTION_BOOLEAN
, "exit-frame", 0, "Trap when exiting eval or apply." },
1681 { SCM_OPTION_SCM
, "enter-frame-handler", (unsigned long)SCM_BOOL_F
, "Handler for enter-frame traps." },
1682 { SCM_OPTION_SCM
, "apply-frame-handler", (unsigned long)SCM_BOOL_F
, "Handler for apply-frame traps." },
1683 { SCM_OPTION_SCM
, "exit-frame-handler", (unsigned long)SCM_BOOL_F
, "Handler for exit-frame traps." }
1686 SCM_DEFINE (scm_eval_options_interface
, "eval-options-interface", 0, 1, 0,
1688 "Option interface for the evaluation options. Instead of using\n"
1689 "this procedure directly, use the procedures @code{eval-enable},\n"
1690 "@code{eval-disable}, @code{eval-set!} and @var{eval-options}.")
1691 #define FUNC_NAME s_scm_eval_options_interface
1695 ans
= scm_options (setting
,
1699 scm_eval_stack
= SCM_EVAL_STACK
* sizeof (void *);
1705 SCM_DEFINE (scm_evaluator_traps
, "evaluator-traps-interface", 0, 1, 0,
1707 "Option interface for the evaluator trap options.")
1708 #define FUNC_NAME s_scm_evaluator_traps
1712 ans
= scm_options (setting
,
1713 scm_evaluator_trap_table
,
1714 SCM_N_EVALUATOR_TRAPS
,
1716 SCM_RESET_DEBUG_MODE
;
1723 scm_deval_args (SCM l
, SCM env
, SCM proc
, SCM
*lloc
)
1725 SCM
*results
= lloc
, res
;
1726 while (SCM_CONSP (l
))
1728 res
= EVALCAR (l
, env
);
1730 *lloc
= scm_cons (res
, SCM_EOL
);
1731 lloc
= SCM_CDRLOC (*lloc
);
1736 scm_wrong_num_args (proc
);
1744 /* SECTION: Some local definitions for the evaluator.
1747 /* Update the toplevel environment frame ENV so that it refers to the
1750 #define UPDATE_TOPLEVEL_ENV(env) \
1752 SCM p = scm_current_module_lookup_closure (); \
1753 if (p != SCM_CAR(env)) \
1754 env = scm_top_level_env (p); \
1758 #define CHECK_EQVISH(A,B) (SCM_EQ_P ((A), (B)) || (SCM_NFALSEP (scm_eqv_p ((A), (B)))))
1761 #define BUILTIN_RPASUBR /* Handle rpsubrs and asubrs without calling apply */
1763 /* SECTION: This is the evaluator. Like any real monster, it has
1764 * three heads. This code is compiled twice.
1770 scm_ceval (SCM x
, SCM env
)
1776 scm_deval (SCM x
, SCM env
)
1781 SCM_CEVAL (SCM x
, SCM env
)
1788 SCM proc
, arg2
, orig_sym
;
1790 scm_t_debug_frame debug
;
1791 scm_t_debug_info
*debug_info_end
;
1792 debug
.prev
= scm_last_debug_frame
;
1793 debug
.status
= scm_debug_eframe_size
;
1795 * The debug.vect contains twice as much scm_t_debug_info frames as the
1796 * user has specified with (debug-set! frames <n>).
1798 * Even frames are eval frames, odd frames are apply frames.
1800 debug
.vect
= (scm_t_debug_info
*) alloca (scm_debug_eframe_size
1801 * sizeof (debug
.vect
[0]));
1802 debug
.info
= debug
.vect
;
1803 debug_info_end
= debug
.vect
+ scm_debug_eframe_size
;
1804 scm_last_debug_frame
= &debug
;
1806 #ifdef EVAL_STACK_CHECKING
1807 if (scm_stack_checking_enabled_p
1808 && SCM_STACK_OVERFLOW_P ((SCM_STACKITEM
*) &proc
))
1811 debug
.info
->e
.exp
= x
;
1812 debug
.info
->e
.env
= env
;
1814 scm_report_stack_overflow ();
1821 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
1824 SCM_CLEAR_ARGSREADY (debug
);
1825 if (SCM_OVERFLOWP (debug
))
1828 * In theory, this should be the only place where it is necessary to
1829 * check for space in debug.vect since both eval frames and
1830 * available space are even.
1832 * For this to be the case, however, it is necessary that primitive
1833 * special forms which jump back to `loop', `begin' or some similar
1834 * label call PREP_APPLY. A convenient way to do this is to jump to
1835 * `loopnoap' or `cdrxnoap'.
1837 else if (++debug
.info
>= debug_info_end
)
1839 SCM_SET_OVERFLOW (debug
);
1843 debug
.info
->e
.exp
= x
;
1844 debug
.info
->e
.env
= env
;
1845 if (CHECK_ENTRY
&& SCM_TRAPS_P
)
1846 if (SCM_ENTER_FRAME_P
|| (SCM_BREAKPOINTS_P
&& SRCBRKP (x
)))
1848 SCM tail
= SCM_BOOL(SCM_TAILRECP (debug
));
1849 SCM_SET_TAILREC (debug
);
1850 if (SCM_CHEAPTRAPS_P
)
1851 t
.arg1
= scm_make_debugobj (&debug
);
1855 SCM val
= scm_make_continuation (&first
);
1867 /* This gives the possibility for the debugger to
1868 modify the source expression before evaluation. */
1873 scm_call_4 (SCM_ENTER_FRAME_HDLR
,
1874 scm_sym_enter_frame
,
1877 scm_unmemocopy (x
, env
));
1881 #if defined (USE_THREADS) || defined (DEVAL)
1885 switch (SCM_TYP7 (x
))
1887 case scm_tc7_symbol
:
1888 /* Only happens when called at top level.
1890 x
= scm_cons (x
, SCM_UNDEFINED
);
1893 case SCM_BIT8(SCM_IM_AND
):
1896 while (SCM_NNULLP (t
.arg1
= SCM_CDR (t
.arg1
)))
1897 if (SCM_FALSEP (EVALCAR (x
, env
)))
1899 RETURN (SCM_BOOL_F
);
1903 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
1906 case SCM_BIT8(SCM_IM_BEGIN
):
1907 /* (currently unused)
1909 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
1910 /* (currently unused)
1915 /* If we are on toplevel with a lookup closure, we need to sync
1916 with the current module. */
1917 if (SCM_CONSP (env
) && !SCM_CONSP (SCM_CAR (env
)))
1920 UPDATE_TOPLEVEL_ENV (env
);
1921 while (!SCM_NULLP (t
.arg1
= SCM_CDR (t
.arg1
)))
1925 UPDATE_TOPLEVEL_ENV (env
);
1930 goto nontoplevel_begin
;
1932 nontoplevel_cdrxnoap
:
1933 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
1934 nontoplevel_cdrxbegin
:
1938 while (!SCM_NULLP (t
.arg1
= SCM_CDR (t
.arg1
)))
1940 if (SCM_IMP (SCM_CAR (x
)))
1942 if (SCM_ISYMP (SCM_CAR (x
)))
1944 x
= scm_m_expand_body (x
, env
);
1945 goto nontoplevel_begin
;
1948 SCM_VALIDATE_NON_EMPTY_COMBINATION (SCM_CAR (x
));
1951 SCM_CEVAL (SCM_CAR (x
), env
);
1955 carloop
: /* scm_eval car of last form in list */
1956 if (!SCM_CELLP (SCM_CAR (x
)))
1959 RETURN (SCM_EVALIM (x
, env
))
1962 if (SCM_SYMBOLP (SCM_CAR (x
)))
1965 RETURN (*scm_lookupcar (x
, env
, 1))
1969 goto loop
; /* tail recurse */
1972 case SCM_BIT8(SCM_IM_CASE
):
1974 t
.arg1
= EVALCAR (x
, env
);
1975 while (SCM_NIMP (x
= SCM_CDR (x
)))
1978 if (SCM_EQ_P (scm_sym_else
, SCM_CAR (proc
)))
1981 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
1984 proc
= SCM_CAR (proc
);
1985 while (SCM_NIMP (proc
))
1987 if (CHECK_EQVISH (SCM_CAR (proc
), t
.arg1
))
1989 x
= SCM_CDR (SCM_CAR (x
));
1990 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
1993 proc
= SCM_CDR (proc
);
1996 RETURN (SCM_UNSPECIFIED
)
1999 case SCM_BIT8(SCM_IM_COND
):
2000 while (!SCM_IMP (x
= SCM_CDR (x
)))
2003 t
.arg1
= EVALCAR (proc
, env
);
2004 if (SCM_NFALSEP (t
.arg1
))
2011 if (!SCM_EQ_P (scm_sym_arrow
, SCM_CAR (x
)))
2013 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
2017 proc
= EVALCAR (proc
, env
);
2018 SCM_ASRTGO (SCM_NIMP (proc
), badfun
);
2019 PREP_APPLY (proc
, scm_cons (t
.arg1
, SCM_EOL
));
2021 if (SCM_CLOSUREP(proc
) && scm_badformalsp (proc
, 1))
2022 goto umwrongnumargs
;
2026 RETURN (SCM_UNSPECIFIED
)
2029 case SCM_BIT8(SCM_IM_DO
):
2031 proc
= SCM_CAR (SCM_CDR (x
)); /* inits */
2032 t
.arg1
= SCM_EOL
; /* values */
2033 while (SCM_NIMP (proc
))
2035 t
.arg1
= scm_cons (EVALCAR (proc
, env
), t
.arg1
);
2036 proc
= SCM_CDR (proc
);
2038 env
= EXTEND_ENV (SCM_CAR (x
), t
.arg1
, env
);
2039 x
= SCM_CDR (SCM_CDR (x
));
2040 while (proc
= SCM_CAR (x
), SCM_FALSEP (EVALCAR (proc
, env
)))
2042 for (proc
= SCM_CADR (x
); SCM_NIMP (proc
); proc
= SCM_CDR (proc
))
2044 t
.arg1
= SCM_CAR (proc
); /* body */
2045 SIDEVAL (t
.arg1
, env
);
2047 for (t
.arg1
= SCM_EOL
, proc
= SCM_CDDR (x
);
2049 proc
= SCM_CDR (proc
))
2050 t
.arg1
= scm_cons (EVALCAR (proc
, env
), t
.arg1
); /* steps */
2051 env
= EXTEND_ENV (SCM_CAR (SCM_CAR (env
)), t
.arg1
, SCM_CDR (env
));
2055 RETURN (SCM_UNSPECIFIED
);
2056 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
2057 goto nontoplevel_begin
;
2060 case SCM_BIT8(SCM_IM_IF
):
2062 if (SCM_NFALSEP (EVALCAR (x
, env
)))
2064 else if (SCM_IMP (x
= SCM_CDR (SCM_CDR (x
))))
2066 RETURN (SCM_UNSPECIFIED
);
2068 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
2072 case SCM_BIT8(SCM_IM_LET
):
2074 proc
= SCM_CAR (SCM_CDR (x
));
2078 t
.arg1
= scm_cons (EVALCAR (proc
, env
), t
.arg1
);
2080 while (SCM_NIMP (proc
= SCM_CDR (proc
)));
2081 env
= EXTEND_ENV (SCM_CAR (x
), t
.arg1
, env
);
2083 goto nontoplevel_cdrxnoap
;
2086 case SCM_BIT8(SCM_IM_LETREC
):
2088 env
= EXTEND_ENV (SCM_CAR (x
), scm_undefineds
, env
);
2094 t
.arg1
= scm_cons (EVALCAR (proc
, env
), t
.arg1
);
2096 while (SCM_NIMP (proc
= SCM_CDR (proc
)));
2097 SCM_SETCDR (SCM_CAR (env
), t
.arg1
);
2098 goto nontoplevel_cdrxnoap
;
2101 case SCM_BIT8(SCM_IM_LETSTAR
):
2106 env
= EXTEND_ENV (SCM_EOL
, SCM_EOL
, env
);
2107 goto nontoplevel_cdrxnoap
;
2111 t
.arg1
= SCM_CAR (proc
);
2112 proc
= SCM_CDR (proc
);
2113 env
= EXTEND_ENV (t
.arg1
, EVALCAR (proc
, env
), env
);
2115 while (SCM_NIMP (proc
= SCM_CDR (proc
)));
2116 goto nontoplevel_cdrxnoap
;
2118 case SCM_BIT8(SCM_IM_OR
):
2121 while (!SCM_NULLP (t
.arg1
= SCM_CDR (t
.arg1
)))
2123 x
= EVALCAR (x
, env
);
2124 if (!SCM_FALSEP (x
))
2130 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
2134 case SCM_BIT8(SCM_IM_LAMBDA
):
2135 RETURN (scm_closure (SCM_CDR (x
), env
));
2138 case SCM_BIT8(SCM_IM_QUOTE
):
2139 RETURN (SCM_CAR (SCM_CDR (x
)));
2142 case SCM_BIT8(SCM_IM_SET_X
):
2145 switch (SCM_ITAG3 (proc
))
2148 if (SCM_VARIABLEP (proc
))
2149 t
.lloc
= SCM_VARIABLE_LOC (proc
);
2151 t
.lloc
= scm_lookupcar (x
, env
, 1);
2153 #ifdef MEMOIZE_LOCALS
2155 t
.lloc
= scm_ilookup (proc
, env
);
2160 *t
.lloc
= EVALCAR (x
, env
);
2164 RETURN (SCM_UNSPECIFIED
);
2168 case SCM_BIT8(SCM_IM_DEFINE
): /* only for internal defines */
2169 scm_misc_error (NULL
, "Bad define placement", SCM_EOL
);
2171 /* new syntactic forms go here. */
2172 case SCM_BIT8(SCM_MAKISYM (0)):
2174 SCM_ASRTGO (SCM_ISYMP (proc
), badfun
);
2175 switch SCM_ISYMNUM (proc
)
2177 case (SCM_ISYMNUM (SCM_IM_APPLY
)):
2179 proc
= EVALCAR (proc
, env
);
2180 SCM_ASRTGO (SCM_NIMP (proc
), badfun
);
2181 if (SCM_CLOSUREP (proc
))
2184 PREP_APPLY (proc
, SCM_EOL
);
2185 t
.arg1
= SCM_CDR (SCM_CDR (x
));
2186 t
.arg1
= EVALCAR (t
.arg1
, env
);
2188 /* Go here to tail-call a closure. PROC is the closure
2189 and T.ARG1 is the list of arguments. Do not forget to
2192 debug
.info
->a
.args
= t
.arg1
;
2194 #ifndef SCM_RECKLESS
2195 if (scm_badargsp (SCM_CLOSURE_FORMALS (proc
), t
.arg1
))
2199 /* Copy argument list */
2200 if (SCM_IMP (t
.arg1
))
2204 argl
= tl
= scm_cons (SCM_CAR (t
.arg1
), SCM_UNSPECIFIED
);
2205 while (SCM_NIMP (t
.arg1
= SCM_CDR (t
.arg1
))
2206 && SCM_CONSP (t
.arg1
))
2208 SCM_SETCDR (tl
, scm_cons (SCM_CAR (t
.arg1
),
2212 SCM_SETCDR (tl
, t
.arg1
);
2215 env
= EXTEND_ENV (SCM_CLOSURE_FORMALS (proc
), argl
, SCM_ENV (proc
));
2216 x
= SCM_CODE (proc
);
2217 goto nontoplevel_cdrxbegin
;
2222 case (SCM_ISYMNUM (SCM_IM_CONT
)):
2225 SCM val
= scm_make_continuation (&first
);
2233 proc
= evalcar (proc
, env
);
2234 SCM_ASRTGO (SCM_NIMP (proc
), badfun
);
2235 PREP_APPLY (proc
, scm_cons (t
.arg1
, SCM_EOL
));
2237 if (SCM_CLOSUREP(proc
) && scm_badformalsp (proc
, 1))
2238 goto umwrongnumargs
;
2241 case (SCM_ISYMNUM (SCM_IM_DELAY
)):
2242 RETURN (scm_makprom (scm_closure (SCM_CDR (x
), env
)))
2244 case (SCM_ISYMNUM (SCM_IM_DISPATCH
)):
2245 proc
= SCM_CADR (x
); /* unevaluated operands */
2246 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
2248 arg2
= *scm_ilookup (proc
, env
);
2249 else if (SCM_NCONSP (proc
))
2251 if (SCM_VARIABLEP (proc
))
2252 arg2
= SCM_VARIABLE_REF (proc
);
2254 arg2
= *scm_lookupcar (SCM_CDR (x
), env
, 1);
2258 arg2
= scm_cons (EVALCAR (proc
, env
), SCM_EOL
);
2259 t
.lloc
= SCM_CDRLOC (arg2
);
2260 while (SCM_NIMP (proc
= SCM_CDR (proc
)))
2262 *t
.lloc
= scm_cons (EVALCAR (proc
, env
), SCM_EOL
);
2263 t
.lloc
= SCM_CDRLOC (*t
.lloc
);
2268 /* The type dispatch code is duplicated here
2269 * (c.f. objects.c:scm_mcache_compute_cmethod) since that
2270 * cuts down execution time for type dispatch to 50%.
2273 long i
, n
, end
, mask
;
2274 SCM z
= SCM_CDDR (x
);
2275 n
= SCM_INUM (SCM_CAR (z
)); /* maximum number of specializers */
2276 proc
= SCM_CADR (z
);
2278 if (SCM_NIMP (proc
))
2280 /* Prepare for linear search */
2283 end
= SCM_VECTOR_LENGTH (proc
);
2287 /* Compute a hash value */
2288 long hashset
= SCM_INUM (proc
);
2291 mask
= SCM_INUM (SCM_CAR (z
));
2292 proc
= SCM_CADR (z
);
2295 if (SCM_NIMP (t
.arg1
))
2298 i
+= SCM_STRUCT_DATA (scm_class_of (SCM_CAR (t
.arg1
)))
2299 [scm_si_hashsets
+ hashset
];
2300 t
.arg1
= SCM_CDR (t
.arg1
);
2302 while (j
-- && SCM_NIMP (t
.arg1
));
2307 /* Search for match */
2311 z
= SCM_VELTS (proc
)[i
];
2312 t
.arg1
= arg2
; /* list of arguments */
2313 if (SCM_NIMP (t
.arg1
))
2316 /* More arguments than specifiers => CLASS != ENV */
2317 if (! SCM_EQ_P (scm_class_of (SCM_CAR (t
.arg1
)), SCM_CAR (z
)))
2319 t
.arg1
= SCM_CDR (t
.arg1
);
2322 while (j
-- && SCM_NIMP (t
.arg1
));
2323 /* Fewer arguments than specifiers => CAR != ENV */
2324 if (!(SCM_IMP (SCM_CAR (z
)) || SCM_CONSP (SCM_CAR (z
))))
2327 env
= EXTEND_ENV (SCM_CAR (SCM_CMETHOD_CODE (z
)),
2329 SCM_CMETHOD_ENV (z
));
2330 x
= SCM_CMETHOD_CODE (z
);
2331 goto nontoplevel_cdrxbegin
;
2336 z
= scm_memoize_method (x
, arg2
);
2340 case (SCM_ISYMNUM (SCM_IM_SLOT_REF
)):
2342 t
.arg1
= EVALCAR (x
, env
);
2343 RETURN (SCM_PACK (SCM_STRUCT_DATA (t
.arg1
) [SCM_INUM (SCM_CADR (x
))]))
2345 case (SCM_ISYMNUM (SCM_IM_SLOT_SET_X
)):
2347 t
.arg1
= EVALCAR (x
, env
);
2350 SCM_STRUCT_DATA (t
.arg1
) [SCM_INUM (SCM_CAR (x
))]
2351 = SCM_UNPACK (EVALCAR (proc
, env
));
2352 RETURN (SCM_UNSPECIFIED
)
2354 case (SCM_ISYMNUM (SCM_IM_NIL_COND
)):
2356 while (SCM_NIMP (x
= SCM_CDR (proc
)))
2358 if (!(SCM_FALSEP (t
.arg1
= EVALCAR (proc
, env
))
2359 || SCM_EQ_P (t
.arg1
, scm_lisp_nil
)))
2361 if (SCM_EQ_P (SCM_CAR (x
), SCM_UNSPECIFIED
))
2363 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
2369 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
2372 case (SCM_ISYMNUM (SCM_IM_NIL_IFY
)):
2374 RETURN ((SCM_FALSEP (proc
= EVALCAR (x
, env
)) || SCM_NULLP (proc
))
2378 case (SCM_ISYMNUM (SCM_IM_T_IFY
)):
2380 RETURN (SCM_NFALSEP (EVALCAR (x
, env
)) ? scm_lisp_t
: scm_lisp_nil
)
2382 case (SCM_ISYMNUM (SCM_IM_0_COND
)):
2384 while (SCM_NIMP (x
= SCM_CDR (proc
)))
2386 if (!(SCM_FALSEP (t
.arg1
= EVALCAR (proc
, env
))
2387 || SCM_EQ_P (t
.arg1
, SCM_INUM0
)))
2389 if (SCM_EQ_P (SCM_CAR (x
), SCM_UNSPECIFIED
))
2391 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
2397 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
2400 case (SCM_ISYMNUM (SCM_IM_0_IFY
)):
2402 RETURN (SCM_FALSEP (proc
= EVALCAR (x
, env
))
2406 case (SCM_ISYMNUM (SCM_IM_1_IFY
)):
2408 RETURN (SCM_NFALSEP (EVALCAR (x
, env
))
2412 case (SCM_ISYMNUM (SCM_IM_BIND
)):
2415 t
.arg1
= SCM_CAR (x
);
2416 arg2
= SCM_CDAR (env
);
2417 while (SCM_NIMP (arg2
))
2419 proc
= SCM_VARIABLE_REF (SCM_CAR (t
.arg1
));
2420 SCM_VARIABLE_SET (SCM_CAR (t
.arg1
), SCM_CAR (arg2
));
2421 SCM_SETCAR (arg2
, proc
);
2422 t
.arg1
= SCM_CDR (t
.arg1
);
2423 arg2
= SCM_CDR (arg2
);
2425 t
.arg1
= SCM_CAR (x
);
2426 scm_dynwinds
= scm_acons (t
.arg1
, SCM_CDAR (env
), scm_dynwinds
);
2428 arg2
= x
= SCM_CDR (x
);
2429 while (SCM_NNULLP (arg2
= SCM_CDR (arg2
)))
2431 SIDEVAL (SCM_CAR (x
), env
);
2434 proc
= EVALCAR (x
, env
);
2436 scm_dynwinds
= SCM_CDR (scm_dynwinds
);
2437 arg2
= SCM_CDAR (env
);
2438 while (SCM_NIMP (arg2
))
2440 SCM_VARIABLE_SET (SCM_CAR (t
.arg1
), SCM_CAR (arg2
));
2441 t
.arg1
= SCM_CDR (t
.arg1
);
2442 arg2
= SCM_CDR (arg2
);
2447 case (SCM_ISYMNUM (SCM_IM_CALL_WITH_VALUES
)):
2450 x
= EVALCAR (proc
, env
);
2451 proc
= SCM_CDR (proc
);
2452 proc
= EVALCAR (proc
, env
);
2453 t
.arg1
= SCM_APPLY (x
, SCM_EOL
, SCM_EOL
);
2454 if (SCM_VALUESP (t
.arg1
))
2455 t
.arg1
= scm_struct_ref (t
.arg1
, SCM_INUM0
);
2457 t
.arg1
= scm_cons (t
.arg1
, SCM_EOL
);
2458 if (SCM_CLOSUREP (proc
))
2460 PREP_APPLY (proc
, t
.arg1
);
2463 return SCM_APPLY (proc
, t
.arg1
, SCM_EOL
);
2473 /* scm_everr (x, env,...) */
2474 scm_misc_error (NULL
, "Wrong type to apply: ~S", scm_list_1 (proc
));
2475 case scm_tc7_vector
:
2479 case scm_tc7_byvect
:
2486 #ifdef HAVE_LONG_LONGS
2487 case scm_tc7_llvect
:
2490 case scm_tc7_string
:
2491 case scm_tc7_substring
:
2493 case scm_tcs_closures
:
2497 case scm_tcs_struct
:
2500 case scm_tc7_variable
:
2501 RETURN (SCM_VARIABLE_REF(x
));
2503 #ifdef MEMOIZE_LOCALS
2504 case SCM_BIT8(SCM_ILOC00
):
2505 proc
= *scm_ilookup (SCM_CAR (x
), env
);
2506 SCM_ASRTGO (SCM_NIMP (proc
), badfun
);
2507 #ifndef SCM_RECKLESS
2513 #endif /* ifdef MEMOIZE_LOCALS */
2515 case scm_tcs_cons_nimcar
:
2516 orig_sym
= SCM_CAR (x
);
2517 if (SCM_SYMBOLP (orig_sym
))
2520 t
.lloc
= scm_lookupcar1 (x
, env
, 1);
2523 /* we have lost the race, start again. */
2528 proc
= *scm_lookupcar (x
, env
, 1);
2533 SCM_SETCAR (x
, orig_sym
); /* Undo memoizing effect of
2537 if (SCM_MACROP (proc
))
2539 SCM_SETCAR (x
, orig_sym
); /* Undo memoizing effect of
2543 /* Set a flag during macro expansion so that macro
2544 application frames can be deleted from the backtrace. */
2545 SCM_SET_MACROEXP (debug
);
2547 t
.arg1
= SCM_APPLY (SCM_MACRO_CODE (proc
), x
,
2548 scm_cons (env
, scm_listofnull
));
2551 SCM_CLEAR_MACROEXP (debug
);
2553 switch (SCM_MACRO_TYPE (proc
))
2556 if (scm_ilength (t
.arg1
) <= 0)
2557 t
.arg1
= scm_cons2 (SCM_IM_BEGIN
, t
.arg1
, SCM_EOL
);
2559 if (!SCM_CLOSUREP (SCM_MACRO_CODE (proc
)))
2562 SCM_SETCAR (x
, SCM_CAR (t
.arg1
));
2563 SCM_SETCDR (x
, SCM_CDR (t
.arg1
));
2567 /* Prevent memoizing of debug info expression. */
2568 debug
.info
->e
.exp
= scm_cons_source (debug
.info
->e
.exp
,
2573 SCM_SETCAR (x
, SCM_CAR (t
.arg1
));
2574 SCM_SETCDR (x
, SCM_CDR (t
.arg1
));
2578 if (SCM_NIMP (x
= t
.arg1
))
2586 proc
= SCM_CEVAL (SCM_CAR (x
), env
);
2587 SCM_ASRTGO (!SCM_IMP (proc
), badfun
);
2588 #ifndef SCM_RECKLESS
2592 if (SCM_CLOSUREP (proc
))
2594 arg2
= SCM_CLOSURE_FORMALS (proc
);
2595 t
.arg1
= SCM_CDR (x
);
2596 while (!SCM_NULLP (arg2
))
2598 if (!SCM_CONSP (arg2
))
2600 if (SCM_IMP (t
.arg1
))
2601 goto umwrongnumargs
;
2602 arg2
= SCM_CDR (arg2
);
2603 t
.arg1
= SCM_CDR (t
.arg1
);
2605 if (!SCM_NULLP (t
.arg1
))
2606 goto umwrongnumargs
;
2608 else if (SCM_MACROP (proc
))
2609 goto handle_a_macro
;
2615 PREP_APPLY (proc
, SCM_EOL
);
2616 if (SCM_NULLP (SCM_CDR (x
))) {
2619 switch (SCM_TYP7 (proc
))
2620 { /* no arguments given */
2621 case scm_tc7_subr_0
:
2622 RETURN (SCM_SUBRF (proc
) ());
2623 case scm_tc7_subr_1o
:
2624 RETURN (SCM_SUBRF (proc
) (SCM_UNDEFINED
));
2626 RETURN (SCM_SUBRF (proc
) (SCM_EOL
));
2627 case scm_tc7_rpsubr
:
2628 RETURN (SCM_BOOL_T
);
2630 RETURN (SCM_SUBRF (proc
) (SCM_UNDEFINED
, SCM_UNDEFINED
));
2632 if (!SCM_SMOB_APPLICABLE_P (proc
))
2634 RETURN (SCM_SMOB_APPLY_0 (proc
));
2637 proc
= SCM_CCLO_SUBR (proc
);
2639 debug
.info
->a
.proc
= proc
;
2640 debug
.info
->a
.args
= scm_cons (t
.arg1
, SCM_EOL
);
2644 proc
= SCM_PROCEDURE (proc
);
2646 debug
.info
->a
.proc
= proc
;
2648 if (!SCM_CLOSUREP (proc
))
2650 if (scm_badformalsp (proc
, 0))
2651 goto umwrongnumargs
;
2652 case scm_tcs_closures
:
2653 x
= SCM_CODE (proc
);
2654 env
= EXTEND_ENV (SCM_CLOSURE_FORMALS (proc
), SCM_EOL
, SCM_ENV (proc
));
2655 goto nontoplevel_cdrxbegin
;
2656 case scm_tcs_struct
:
2657 if (SCM_OBJ_CLASS_FLAGS (proc
) & SCM_CLASSF_PURE_GENERIC
)
2659 x
= SCM_ENTITY_PROCEDURE (proc
);
2663 else if (!SCM_I_OPERATORP (proc
))
2668 proc
= (SCM_I_ENTITYP (proc
)
2669 ? SCM_ENTITY_PROCEDURE (proc
)
2670 : SCM_OPERATOR_PROCEDURE (proc
));
2672 debug
.info
->a
.proc
= proc
;
2673 debug
.info
->a
.args
= scm_cons (t
.arg1
, SCM_EOL
);
2675 if (SCM_NIMP (proc
))
2680 case scm_tc7_subr_1
:
2681 case scm_tc7_subr_2
:
2682 case scm_tc7_subr_2o
:
2684 case scm_tc7_subr_3
:
2685 case scm_tc7_lsubr_2
:
2689 /* scm_everr (x, env,...) */
2690 scm_wrong_num_args (proc
);
2692 /* handle macros here */
2697 /* must handle macros by here */
2702 else if (SCM_CONSP (x
))
2704 if (SCM_IMP (SCM_CAR (x
)))
2705 t
.arg1
= SCM_EVALIM (SCM_CAR (x
), env
);
2707 t
.arg1
= EVALCELLCAR (x
, env
);
2712 t
.arg1
= EVALCAR (x
, env
);
2715 debug
.info
->a
.args
= scm_cons (t
.arg1
, SCM_EOL
);
2722 switch (SCM_TYP7 (proc
))
2723 { /* have one argument in t.arg1 */
2724 case scm_tc7_subr_2o
:
2725 RETURN (SCM_SUBRF (proc
) (t
.arg1
, SCM_UNDEFINED
));
2726 case scm_tc7_subr_1
:
2727 case scm_tc7_subr_1o
:
2728 RETURN (SCM_SUBRF (proc
) (t
.arg1
));
2730 if (SCM_SUBRF (proc
))
2732 if (SCM_INUMP (t
.arg1
))
2734 RETURN (scm_make_real (SCM_DSUBRF (proc
) ((double) SCM_INUM (t
.arg1
))));
2736 SCM_ASRTGO (SCM_NIMP (t
.arg1
), floerr
);
2737 if (SCM_REALP (t
.arg1
))
2739 RETURN (scm_make_real (SCM_DSUBRF (proc
) (SCM_REAL_VALUE (t
.arg1
))));
2742 if (SCM_BIGP (t
.arg1
))
2744 RETURN (scm_make_real (SCM_DSUBRF (proc
) (scm_i_big2dbl (t
.arg1
))));
2748 SCM_WTA_DISPATCH_1 (*SCM_SUBR_GENERIC (proc
), t
.arg1
,
2749 SCM_ARG1
, SCM_SYMBOL_CHARS (SCM_SNAME (proc
)));
2751 proc
= SCM_SNAME (proc
);
2753 char *chrs
= SCM_SYMBOL_CHARS (proc
) + SCM_SYMBOL_LENGTH (proc
) - 1;
2754 while ('c' != *--chrs
)
2756 SCM_ASSERT (SCM_CONSP (t
.arg1
),
2757 t
.arg1
, SCM_ARG1
, SCM_SYMBOL_CHARS (proc
));
2758 t
.arg1
= ('a' == *chrs
) ? SCM_CAR (t
.arg1
) : SCM_CDR (t
.arg1
);
2762 case scm_tc7_rpsubr
:
2763 RETURN (SCM_BOOL_T
);
2765 RETURN (SCM_SUBRF (proc
) (t
.arg1
, SCM_UNDEFINED
));
2768 RETURN (SCM_SUBRF (proc
) (debug
.info
->a
.args
))
2770 RETURN (SCM_SUBRF (proc
) (scm_cons (t
.arg1
, SCM_EOL
)));
2773 if (!SCM_SMOB_APPLICABLE_P (proc
))
2775 RETURN (SCM_SMOB_APPLY_1 (proc
, t
.arg1
));
2779 proc
= SCM_CCLO_SUBR (proc
);
2781 debug
.info
->a
.args
= scm_cons (t
.arg1
, debug
.info
->a
.args
);
2782 debug
.info
->a
.proc
= proc
;
2786 proc
= SCM_PROCEDURE (proc
);
2788 debug
.info
->a
.proc
= proc
;
2790 if (!SCM_CLOSUREP (proc
))
2792 if (scm_badformalsp (proc
, 1))
2793 goto umwrongnumargs
;
2794 case scm_tcs_closures
:
2796 x
= SCM_CODE (proc
);
2798 env
= EXTEND_ENV (SCM_CLOSURE_FORMALS (proc
), debug
.info
->a
.args
, SCM_ENV (proc
));
2800 env
= EXTEND_ENV (SCM_CLOSURE_FORMALS (proc
), scm_cons (t
.arg1
, SCM_EOL
), SCM_ENV (proc
));
2802 goto nontoplevel_cdrxbegin
;
2803 case scm_tcs_struct
:
2804 if (SCM_OBJ_CLASS_FLAGS (proc
) & SCM_CLASSF_PURE_GENERIC
)
2806 x
= SCM_ENTITY_PROCEDURE (proc
);
2808 arg2
= debug
.info
->a
.args
;
2810 arg2
= scm_cons (t
.arg1
, SCM_EOL
);
2814 else if (!SCM_I_OPERATORP (proc
))
2820 proc
= (SCM_I_ENTITYP (proc
)
2821 ? SCM_ENTITY_PROCEDURE (proc
)
2822 : SCM_OPERATOR_PROCEDURE (proc
));
2824 debug
.info
->a
.args
= scm_cons (t
.arg1
, debug
.info
->a
.args
);
2825 debug
.info
->a
.proc
= proc
;
2827 if (SCM_NIMP (proc
))
2832 case scm_tc7_subr_2
:
2833 case scm_tc7_subr_0
:
2834 case scm_tc7_subr_3
:
2835 case scm_tc7_lsubr_2
:
2844 else if (SCM_CONSP (x
))
2846 if (SCM_IMP (SCM_CAR (x
)))
2847 arg2
= SCM_EVALIM (SCM_CAR (x
), env
);
2849 arg2
= EVALCELLCAR (x
, env
);
2854 arg2
= EVALCAR (x
, env
);
2856 { /* have two or more arguments */
2858 debug
.info
->a
.args
= scm_cons2 (t
.arg1
, arg2
, SCM_EOL
);
2861 if (SCM_NULLP (x
)) {
2864 switch (SCM_TYP7 (proc
))
2865 { /* have two arguments */
2866 case scm_tc7_subr_2
:
2867 case scm_tc7_subr_2o
:
2868 RETURN (SCM_SUBRF (proc
) (t
.arg1
, arg2
));
2871 RETURN (SCM_SUBRF (proc
) (debug
.info
->a
.args
))
2873 RETURN (SCM_SUBRF (proc
) (scm_cons2 (t
.arg1
, arg2
, SCM_EOL
)));
2875 case scm_tc7_lsubr_2
:
2876 RETURN (SCM_SUBRF (proc
) (t
.arg1
, arg2
, SCM_EOL
));
2877 case scm_tc7_rpsubr
:
2879 RETURN (SCM_SUBRF (proc
) (t
.arg1
, arg2
));
2881 if (!SCM_SMOB_APPLICABLE_P (proc
))
2883 RETURN (SCM_SMOB_APPLY_2 (proc
, t
.arg1
, arg2
));
2887 RETURN (SCM_APPLY (SCM_CCLO_SUBR (proc
),
2888 scm_cons (proc
, debug
.info
->a
.args
),
2891 RETURN (SCM_APPLY (SCM_CCLO_SUBR (proc
),
2892 scm_cons2 (proc
, t
.arg1
,
2899 case scm_tcs_struct
:
2900 if (SCM_OBJ_CLASS_FLAGS (proc
) & SCM_CLASSF_PURE_GENERIC
)
2902 x
= SCM_ENTITY_PROCEDURE (proc
);
2904 arg2
= debug
.info
->a
.args
;
2906 arg2
= scm_cons2 (t
.arg1
, arg2
, SCM_EOL
);
2910 else if (!SCM_I_OPERATORP (proc
))
2916 RETURN (SCM_APPLY (SCM_I_ENTITYP (proc
)
2917 ? SCM_ENTITY_PROCEDURE (proc
)
2918 : SCM_OPERATOR_PROCEDURE (proc
),
2919 scm_cons (proc
, debug
.info
->a
.args
),
2922 RETURN (SCM_APPLY (SCM_I_ENTITYP (proc
)
2923 ? SCM_ENTITY_PROCEDURE (proc
)
2924 : SCM_OPERATOR_PROCEDURE (proc
),
2925 scm_cons2 (proc
, t
.arg1
,
2933 case scm_tc7_subr_0
:
2935 case scm_tc7_subr_1o
:
2936 case scm_tc7_subr_1
:
2937 case scm_tc7_subr_3
:
2942 proc
= SCM_PROCEDURE (proc
);
2944 debug
.info
->a
.proc
= proc
;
2946 if (!SCM_CLOSUREP (proc
))
2948 if (scm_badformalsp (proc
, 2))
2949 goto umwrongnumargs
;
2950 case scm_tcs_closures
:
2953 env
= EXTEND_ENV (SCM_CLOSURE_FORMALS (proc
),
2957 env
= EXTEND_ENV (SCM_CLOSURE_FORMALS (proc
),
2958 scm_cons2 (t
.arg1
, arg2
, SCM_EOL
), SCM_ENV (proc
));
2960 x
= SCM_CODE (proc
);
2961 goto nontoplevel_cdrxbegin
;
2965 if (SCM_IMP (x
) || SCM_NCONSP (x
))
2969 debug
.info
->a
.args
= scm_cons2 (t
.arg1
, arg2
,
2970 scm_deval_args (x
, env
, proc
,
2971 SCM_CDRLOC (SCM_CDR (debug
.info
->a
.args
))));
2975 switch (SCM_TYP7 (proc
))
2976 { /* have 3 or more arguments */
2978 case scm_tc7_subr_3
:
2979 SCM_ASRTGO (SCM_NULLP (SCM_CDR (x
)), wrongnumargs
);
2980 RETURN (SCM_SUBRF (proc
) (t
.arg1
, arg2
,
2981 SCM_CADDR (debug
.info
->a
.args
)));
2983 #ifdef BUILTIN_RPASUBR
2984 t
.arg1
= SCM_SUBRF(proc
)(t
.arg1
, arg2
);
2985 arg2
= SCM_CDR (SCM_CDR (debug
.info
->a
.args
));
2988 t
.arg1
= SCM_SUBRF(proc
)(t
.arg1
, SCM_CAR (arg2
));
2989 arg2
= SCM_CDR (arg2
);
2991 while (SCM_NIMP (arg2
));
2993 #endif /* BUILTIN_RPASUBR */
2994 case scm_tc7_rpsubr
:
2995 #ifdef BUILTIN_RPASUBR
2996 if (SCM_FALSEP (SCM_SUBRF (proc
) (t
.arg1
, arg2
)))
2998 t
.arg1
= SCM_CDR (SCM_CDR (debug
.info
->a
.args
));
3001 if (SCM_FALSEP (SCM_SUBRF (proc
) (arg2
, SCM_CAR (t
.arg1
))))
3003 arg2
= SCM_CAR (t
.arg1
);
3004 t
.arg1
= SCM_CDR (t
.arg1
);
3006 while (SCM_NIMP (t
.arg1
));
3008 #else /* BUILTIN_RPASUBR */
3009 RETURN (SCM_APPLY (proc
, t
.arg1
,
3011 SCM_CDR (SCM_CDR (debug
.info
->a
.args
)),
3013 #endif /* BUILTIN_RPASUBR */
3014 case scm_tc7_lsubr_2
:
3015 RETURN (SCM_SUBRF (proc
) (t
.arg1
, arg2
,
3016 SCM_CDR (SCM_CDR (debug
.info
->a
.args
))))
3018 RETURN (SCM_SUBRF (proc
) (debug
.info
->a
.args
))
3020 if (!SCM_SMOB_APPLICABLE_P (proc
))
3022 RETURN (SCM_SMOB_APPLY_3 (proc
, t
.arg1
, arg2
,
3023 SCM_CDDR (debug
.info
->a
.args
)));
3027 proc
= SCM_PROCEDURE (proc
);
3028 debug
.info
->a
.proc
= proc
;
3029 if (!SCM_CLOSUREP (proc
))
3031 if (scm_badargsp (SCM_CLOSURE_FORMALS (proc
), debug
.info
->a
.args
))
3032 goto umwrongnumargs
;
3033 case scm_tcs_closures
:
3034 SCM_SET_ARGSREADY (debug
);
3035 env
= EXTEND_ENV (SCM_CLOSURE_FORMALS (proc
),
3038 x
= SCM_CODE (proc
);
3039 goto nontoplevel_cdrxbegin
;
3041 case scm_tc7_subr_3
:
3042 SCM_ASRTGO (SCM_NULLP (SCM_CDR (x
)), wrongnumargs
);
3043 RETURN (SCM_SUBRF (proc
) (t
.arg1
, arg2
, EVALCAR (x
, env
)));
3045 #ifdef BUILTIN_RPASUBR
3046 t
.arg1
= SCM_SUBRF (proc
) (t
.arg1
, arg2
);
3049 t
.arg1
= SCM_SUBRF(proc
)(t
.arg1
, EVALCAR(x
, env
));
3052 while (SCM_NIMP (x
));
3054 #endif /* BUILTIN_RPASUBR */
3055 case scm_tc7_rpsubr
:
3056 #ifdef BUILTIN_RPASUBR
3057 if (SCM_FALSEP (SCM_SUBRF (proc
) (t
.arg1
, arg2
)))
3061 t
.arg1
= EVALCAR (x
, env
);
3062 if (SCM_FALSEP (SCM_SUBRF (proc
) (arg2
, t
.arg1
)))
3067 while (SCM_NIMP (x
));
3069 #else /* BUILTIN_RPASUBR */
3070 RETURN (SCM_APPLY (proc
, t
.arg1
,
3072 scm_eval_args (x
, env
, proc
),
3074 #endif /* BUILTIN_RPASUBR */
3075 case scm_tc7_lsubr_2
:
3076 RETURN (SCM_SUBRF (proc
) (t
.arg1
, arg2
, scm_eval_args (x
, env
, proc
)));
3078 RETURN (SCM_SUBRF (proc
) (scm_cons2 (t
.arg1
,
3080 scm_eval_args (x
, env
, proc
))));
3082 if (!SCM_SMOB_APPLICABLE_P (proc
))
3084 RETURN (SCM_SMOB_APPLY_3 (proc
, t
.arg1
, arg2
,
3085 scm_eval_args (x
, env
, proc
)));
3089 proc
= SCM_PROCEDURE (proc
);
3090 if (!SCM_CLOSUREP (proc
))
3093 SCM formals
= SCM_CLOSURE_FORMALS (proc
);
3094 if (SCM_NULLP (formals
)
3095 || (SCM_CONSP (formals
)
3096 && (SCM_NULLP (SCM_CDR (formals
))
3097 || (SCM_CONSP (SCM_CDR (formals
))
3098 && scm_badargsp (SCM_CDDR (formals
), x
)))))
3099 goto umwrongnumargs
;
3101 case scm_tcs_closures
:
3103 SCM_SET_ARGSREADY (debug
);
3105 env
= EXTEND_ENV (SCM_CLOSURE_FORMALS (proc
),
3108 scm_eval_args (x
, env
, proc
)),
3110 x
= SCM_CODE (proc
);
3111 goto nontoplevel_cdrxbegin
;
3113 case scm_tcs_struct
:
3114 if (SCM_OBJ_CLASS_FLAGS (proc
) & SCM_CLASSF_PURE_GENERIC
)
3117 arg2
= debug
.info
->a
.args
;
3119 arg2
= scm_cons2 (t
.arg1
, arg2
, scm_eval_args (x
, env
, proc
));
3121 x
= SCM_ENTITY_PROCEDURE (proc
);
3124 else if (!SCM_I_OPERATORP (proc
))
3128 case scm_tc7_subr_2
:
3129 case scm_tc7_subr_1o
:
3130 case scm_tc7_subr_2o
:
3131 case scm_tc7_subr_0
:
3133 case scm_tc7_subr_1
:
3141 if (CHECK_EXIT
&& SCM_TRAPS_P
)
3142 if (SCM_EXIT_FRAME_P
|| (SCM_TRACE_P
&& SCM_TRACED_FRAME_P (debug
)))
3144 SCM_CLEAR_TRACED_FRAME (debug
);
3145 if (SCM_CHEAPTRAPS_P
)
3146 t
.arg1
= scm_make_debugobj (&debug
);
3150 SCM val
= scm_make_continuation (&first
);
3161 scm_call_3 (SCM_EXIT_FRAME_HDLR
, scm_sym_exit_frame
, t
.arg1
, proc
);
3165 scm_last_debug_frame
= debug
.prev
;
3171 /* SECTION: This code is compiled once.
3177 /* Simple procedure calls
3181 scm_call_0 (SCM proc
)
3183 return scm_apply (proc
, SCM_EOL
, SCM_EOL
);
3187 scm_call_1 (SCM proc
, SCM arg1
)
3189 return scm_apply (proc
, arg1
, scm_listofnull
);
3193 scm_call_2 (SCM proc
, SCM arg1
, SCM arg2
)
3195 return scm_apply (proc
, arg1
, scm_cons (arg2
, scm_listofnull
));
3199 scm_call_3 (SCM proc
, SCM arg1
, SCM arg2
, SCM arg3
)
3201 return scm_apply (proc
, arg1
, scm_cons2 (arg2
, arg3
, scm_listofnull
));
3205 scm_call_4 (SCM proc
, SCM arg1
, SCM arg2
, SCM arg3
, SCM arg4
)
3207 return scm_apply (proc
, arg1
, scm_cons2 (arg2
, arg3
,
3208 scm_cons (arg4
, scm_listofnull
)));
3211 /* Simple procedure applies
3215 scm_apply_0 (SCM proc
, SCM args
)
3217 return scm_apply (proc
, args
, SCM_EOL
);
3221 scm_apply_1 (SCM proc
, SCM arg1
, SCM args
)
3223 return scm_apply (proc
, scm_cons (arg1
, args
), SCM_EOL
);
3227 scm_apply_2 (SCM proc
, SCM arg1
, SCM arg2
, SCM args
)
3229 return scm_apply (proc
, scm_cons2 (arg1
, arg2
, args
), SCM_EOL
);
3233 scm_apply_3 (SCM proc
, SCM arg1
, SCM arg2
, SCM arg3
, SCM args
)
3235 return scm_apply (proc
, scm_cons (arg1
, scm_cons2 (arg2
, arg3
, args
)),
3239 /* This code processes the arguments to apply:
3241 (apply PROC ARG1 ... ARGS)
3243 Given a list (ARG1 ... ARGS), this function conses the ARG1
3244 ... arguments onto the front of ARGS, and returns the resulting
3245 list. Note that ARGS is a list; thus, the argument to this
3246 function is a list whose last element is a list.
3248 Apply calls this function, and applies PROC to the elements of the
3249 result. apply:nconc2last takes care of building the list of
3250 arguments, given (ARG1 ... ARGS).
3252 Rather than do new consing, apply:nconc2last destroys its argument.
3253 On that topic, this code came into my care with the following
3254 beautifully cryptic comment on that topic: "This will only screw
3255 you if you do (scm_apply scm_apply '( ... ))" If you know what
3256 they're referring to, send me a patch to this comment. */
3258 SCM_DEFINE (scm_nconc2last
, "apply:nconc2last", 1, 0, 0,
3260 "Given a list (@var{arg1} @dots{} @var{args}), this function\n"
3261 "conses the @var{arg1} @dots{} arguments onto the front of\n"
3262 "@var{args}, and returns the resulting list. Note that\n"
3263 "@var{args} is a list; thus, the argument to this function is\n"
3264 "a list whose last element is a list.\n"
3265 "Note: Rather than do new consing, @code{apply:nconc2last}\n"
3266 "destroys its argument, so use with care.")
3267 #define FUNC_NAME s_scm_nconc2last
3270 SCM_VALIDATE_NONEMPTYLIST (1,lst
);
3272 while (SCM_NNULLP (SCM_CDR (*lloc
)))
3273 lloc
= SCM_CDRLOC (*lloc
);
3274 SCM_ASSERT (scm_ilength (SCM_CAR (*lloc
)) >= 0, lst
, SCM_ARG1
, FUNC_NAME
);
3275 *lloc
= SCM_CAR (*lloc
);
3283 /* SECTION: When DEVAL is defined this code yields scm_dapply.
3284 * It is compiled twice.
3290 scm_apply (SCM proc
, SCM arg1
, SCM args
)
3297 scm_dapply (SCM proc
, SCM arg1
, SCM args
)
3302 /* Apply a function to a list of arguments.
3304 This function is exported to the Scheme level as taking two
3305 required arguments and a tail argument, as if it were:
3306 (lambda (proc arg1 . args) ...)
3307 Thus, if you just have a list of arguments to pass to a procedure,
3308 pass the list as ARG1, and '() for ARGS. If you have some fixed
3309 args, pass the first as ARG1, then cons any remaining fixed args
3310 onto the front of your argument list, and pass that as ARGS. */
3313 SCM_APPLY (SCM proc
, SCM arg1
, SCM args
)
3315 #ifdef DEBUG_EXTENSIONS
3317 scm_t_debug_frame debug
;
3318 scm_t_debug_info debug_vect_body
;
3319 debug
.prev
= scm_last_debug_frame
;
3320 debug
.status
= SCM_APPLYFRAME
;
3321 debug
.vect
= &debug_vect_body
;
3322 debug
.vect
[0].a
.proc
= proc
;
3323 debug
.vect
[0].a
.args
= SCM_EOL
;
3324 scm_last_debug_frame
= &debug
;
3327 return scm_dapply (proc
, arg1
, args
);
3331 SCM_ASRTGO (SCM_NIMP (proc
), badproc
);
3333 /* If ARGS is the empty list, then we're calling apply with only two
3334 arguments --- ARG1 is the list of arguments for PROC. Whatever
3335 the case, futz with things so that ARG1 is the first argument to
3336 give to PROC (or SCM_UNDEFINED if no args), and ARGS contains the
3339 Setting the debug apply frame args this way is pretty messy.
3340 Perhaps we should store arg1 and args directly in the frame as
3341 received, and let scm_frame_arguments unpack them, because that's
3342 a relatively rare operation. This works for now; if the Guile
3343 developer archives are still around, see Mikael's post of
3345 if (SCM_NULLP (args
))
3347 if (SCM_NULLP (arg1
))
3349 arg1
= SCM_UNDEFINED
;
3351 debug
.vect
[0].a
.args
= SCM_EOL
;
3357 debug
.vect
[0].a
.args
= arg1
;
3359 args
= SCM_CDR (arg1
);
3360 arg1
= SCM_CAR (arg1
);
3365 args
= scm_nconc2last (args
);
3367 debug
.vect
[0].a
.args
= scm_cons (arg1
, args
);
3371 if (SCM_ENTER_FRAME_P
&& SCM_TRAPS_P
)
3374 if (SCM_CHEAPTRAPS_P
)
3375 tmp
= scm_make_debugobj (&debug
);
3380 tmp
= scm_make_continuation (&first
);
3385 scm_call_2 (SCM_ENTER_FRAME_HDLR
, scm_sym_enter_frame
, tmp
);
3392 switch (SCM_TYP7 (proc
))
3394 case scm_tc7_subr_2o
:
3395 args
= SCM_NULLP (args
) ? SCM_UNDEFINED
: SCM_CAR (args
);
3396 RETURN (SCM_SUBRF (proc
) (arg1
, args
))
3397 case scm_tc7_subr_2
:
3398 SCM_ASRTGO (SCM_NNULLP (args
) && SCM_NULLP (SCM_CDR (args
)),
3400 args
= SCM_CAR (args
);
3401 RETURN (SCM_SUBRF (proc
) (arg1
, args
))
3402 case scm_tc7_subr_0
:
3403 SCM_ASRTGO (SCM_UNBNDP (arg1
), wrongnumargs
);
3404 RETURN (SCM_SUBRF (proc
) ())
3405 case scm_tc7_subr_1
:
3406 SCM_ASRTGO (!SCM_UNBNDP (arg1
), wrongnumargs
);
3407 case scm_tc7_subr_1o
:
3408 SCM_ASRTGO (SCM_NULLP (args
), wrongnumargs
);
3409 RETURN (SCM_SUBRF (proc
) (arg1
))
3411 SCM_ASRTGO (!SCM_UNBNDP (arg1
) && SCM_NULLP (args
), wrongnumargs
);
3412 if (SCM_SUBRF (proc
))
3414 if (SCM_INUMP (arg1
))
3416 RETURN (scm_make_real (SCM_DSUBRF (proc
) ((double) SCM_INUM (arg1
))));
3418 SCM_ASRTGO (SCM_NIMP (arg1
), floerr
);
3419 if (SCM_REALP (arg1
))
3421 RETURN (scm_make_real (SCM_DSUBRF (proc
) (SCM_REAL_VALUE (arg1
))));
3424 if (SCM_BIGP (arg1
))
3425 RETURN (scm_make_real (SCM_DSUBRF (proc
) (scm_i_big2dbl (arg1
))))
3428 SCM_WTA_DISPATCH_1 (*SCM_SUBR_GENERIC (proc
), arg1
,
3429 SCM_ARG1
, SCM_SYMBOL_CHARS (SCM_SNAME (proc
)));
3431 proc
= SCM_SNAME (proc
);
3433 char *chrs
= SCM_SYMBOL_CHARS (proc
) + SCM_SYMBOL_LENGTH (proc
) - 1;
3434 while ('c' != *--chrs
)
3436 SCM_ASSERT (SCM_CONSP (arg1
),
3437 arg1
, SCM_ARG1
, SCM_SYMBOL_CHARS (proc
));
3438 arg1
= ('a' == *chrs
) ? SCM_CAR (arg1
) : SCM_CDR (arg1
);
3442 case scm_tc7_subr_3
:
3443 SCM_ASRTGO (SCM_NNULLP (args
)
3444 && SCM_NNULLP (SCM_CDR (args
))
3445 && SCM_NULLP (SCM_CDDR (args
)),
3447 RETURN (SCM_SUBRF (proc
) (arg1
, SCM_CAR (args
), SCM_CAR (SCM_CDR (args
))))
3450 RETURN (SCM_SUBRF (proc
) (SCM_UNBNDP (arg1
) ? SCM_EOL
: debug
.vect
[0].a
.args
))
3452 RETURN (SCM_SUBRF (proc
) (SCM_UNBNDP (arg1
) ? SCM_EOL
: scm_cons (arg1
, args
)))
3454 case scm_tc7_lsubr_2
:
3455 SCM_ASRTGO (SCM_CONSP (args
), wrongnumargs
);
3456 RETURN (SCM_SUBRF (proc
) (arg1
, SCM_CAR (args
), SCM_CDR (args
)))
3458 if (SCM_NULLP (args
))
3459 RETURN (SCM_SUBRF (proc
) (arg1
, SCM_UNDEFINED
))
3460 while (SCM_NIMP (args
))
3462 SCM_ASSERT (SCM_CONSP (args
), args
, SCM_ARG2
, "apply");
3463 arg1
= SCM_SUBRF (proc
) (arg1
, SCM_CAR (args
));
3464 args
= SCM_CDR (args
);
3467 case scm_tc7_rpsubr
:
3468 if (SCM_NULLP (args
))
3469 RETURN (SCM_BOOL_T
);
3470 while (SCM_NIMP (args
))
3472 SCM_ASSERT (SCM_CONSP (args
), args
, SCM_ARG2
, "apply");
3473 if (SCM_FALSEP (SCM_SUBRF (proc
) (arg1
, SCM_CAR (args
))))
3474 RETURN (SCM_BOOL_F
);
3475 arg1
= SCM_CAR (args
);
3476 args
= SCM_CDR (args
);
3478 RETURN (SCM_BOOL_T
);
3479 case scm_tcs_closures
:
3481 arg1
= (SCM_UNBNDP (arg1
) ? SCM_EOL
: debug
.vect
[0].a
.args
);
3483 arg1
= (SCM_UNBNDP (arg1
) ? SCM_EOL
: scm_cons (arg1
, args
));
3485 #ifndef SCM_RECKLESS
3486 if (scm_badargsp (SCM_CLOSURE_FORMALS (proc
), arg1
))
3490 /* Copy argument list */
3495 SCM tl
= args
= scm_cons (SCM_CAR (arg1
), SCM_UNSPECIFIED
);
3496 while (arg1
= SCM_CDR (arg1
), SCM_CONSP (arg1
))
3498 SCM_SETCDR (tl
, scm_cons (SCM_CAR (arg1
),
3502 SCM_SETCDR (tl
, arg1
);
3505 args
= EXTEND_ENV (SCM_CLOSURE_FORMALS (proc
), args
, SCM_ENV (proc
));
3506 proc
= SCM_CDR (SCM_CODE (proc
));
3509 while (SCM_NNULLP (arg1
= SCM_CDR (arg1
)))
3511 if (SCM_IMP (SCM_CAR (proc
)))
3513 if (SCM_ISYMP (SCM_CAR (proc
)))
3515 proc
= scm_m_expand_body (proc
, args
);
3519 SCM_VALIDATE_NON_EMPTY_COMBINATION (SCM_CAR (proc
));
3522 SCM_CEVAL (SCM_CAR (proc
), args
);
3525 RETURN (EVALCAR (proc
, args
));
3527 if (!SCM_SMOB_APPLICABLE_P (proc
))
3529 if (SCM_UNBNDP (arg1
))
3530 RETURN (SCM_SMOB_APPLY_0 (proc
))
3531 else if (SCM_NULLP (args
))
3532 RETURN (SCM_SMOB_APPLY_1 (proc
, arg1
))
3533 else if (SCM_NULLP (SCM_CDR (args
)))
3534 RETURN (SCM_SMOB_APPLY_2 (proc
, arg1
, SCM_CAR (args
)))
3536 RETURN (SCM_SMOB_APPLY_3 (proc
, arg1
, SCM_CAR (args
), SCM_CDR (args
)));
3539 args
= (SCM_UNBNDP(arg1
) ? SCM_EOL
: debug
.vect
[0].a
.args
);
3541 proc
= SCM_CCLO_SUBR (proc
);
3542 debug
.vect
[0].a
.proc
= proc
;
3543 debug
.vect
[0].a
.args
= scm_cons (arg1
, args
);
3545 args
= (SCM_UNBNDP(arg1
) ? SCM_EOL
: scm_cons (arg1
, args
));
3547 proc
= SCM_CCLO_SUBR (proc
);
3551 proc
= SCM_PROCEDURE (proc
);
3553 debug
.vect
[0].a
.proc
= proc
;
3556 case scm_tcs_struct
:
3557 if (SCM_OBJ_CLASS_FLAGS (proc
) & SCM_CLASSF_PURE_GENERIC
)
3560 args
= (SCM_UNBNDP(arg1
) ? SCM_EOL
: debug
.vect
[0].a
.args
);
3562 args
= (SCM_UNBNDP(arg1
) ? SCM_EOL
: scm_cons (arg1
, args
));
3564 RETURN (scm_apply_generic (proc
, args
));
3566 else if (!SCM_I_OPERATORP (proc
))
3571 args
= (SCM_UNBNDP(arg1
) ? SCM_EOL
: debug
.vect
[0].a
.args
);
3573 args
= (SCM_UNBNDP(arg1
) ? SCM_EOL
: scm_cons (arg1
, args
));
3576 proc
= (SCM_I_ENTITYP (proc
)
3577 ? SCM_ENTITY_PROCEDURE (proc
)
3578 : SCM_OPERATOR_PROCEDURE (proc
));
3580 debug
.vect
[0].a
.proc
= proc
;
3581 debug
.vect
[0].a
.args
= scm_cons (arg1
, args
);
3583 if (SCM_NIMP (proc
))
3589 scm_wrong_num_args (proc
);
3592 scm_wrong_type_arg ("apply", SCM_ARG1
, proc
);
3597 if (CHECK_EXIT
&& SCM_TRAPS_P
)
3598 if (SCM_EXIT_FRAME_P
|| (SCM_TRACE_P
&& SCM_TRACED_FRAME_P (debug
)))
3600 SCM_CLEAR_TRACED_FRAME (debug
);
3601 if (SCM_CHEAPTRAPS_P
)
3602 arg1
= scm_make_debugobj (&debug
);
3606 SCM val
= scm_make_continuation (&first
);
3617 scm_call_3 (SCM_EXIT_FRAME_HDLR
, scm_sym_exit_frame
, arg1
, proc
);
3621 scm_last_debug_frame
= debug
.prev
;
3627 /* SECTION: The rest of this file is only read once.
3632 /* Typechecking for multi-argument MAP and FOR-EACH.
3634 Verify that each element of the vector ARGV, except for the first,
3635 is a proper list whose length is LEN. Attribute errors to WHO,
3636 and claim that the i'th element of ARGV is WHO's i+2'th argument. */
3638 check_map_args (SCM argv
,
3645 SCM
*ve
= SCM_VELTS (argv
);
3648 for (i
= SCM_VECTOR_LENGTH (argv
) - 1; i
>= 1; i
--)
3650 long elt_len
= scm_ilength (ve
[i
]);
3655 scm_apply_generic (gf
, scm_cons (proc
, args
));
3657 scm_wrong_type_arg (who
, i
+ 2, ve
[i
]);
3661 scm_out_of_range (who
, ve
[i
]);
3664 scm_remember_upto_here_1 (argv
);
3668 SCM_GPROC (s_map
, "map", 2, 0, 1, scm_map
, g_map
);
3670 /* Note: Currently, scm_map applies PROC to the argument list(s)
3671 sequentially, starting with the first element(s). This is used in
3672 evalext.c where the Scheme procedure `map-in-order', which guarantees
3673 sequential behaviour, is implemented using scm_map. If the
3674 behaviour changes, we need to update `map-in-order'.
3678 scm_map (SCM proc
, SCM arg1
, SCM args
)
3679 #define FUNC_NAME s_map
3684 SCM
*ve
= &args
; /* Keep args from being optimized away. */
3686 len
= scm_ilength (arg1
);
3687 SCM_GASSERTn (len
>= 0,
3688 g_map
, scm_cons2 (proc
, arg1
, args
), SCM_ARG2
, s_map
);
3689 SCM_VALIDATE_REST_ARGUMENT (args
);
3690 if (SCM_NULLP (args
))
3692 while (SCM_NIMP (arg1
))
3694 *pres
= scm_cons (scm_apply (proc
, SCM_CAR (arg1
), scm_listofnull
),
3696 pres
= SCM_CDRLOC (*pres
);
3697 arg1
= SCM_CDR (arg1
);
3701 args
= scm_vector (arg1
= scm_cons (arg1
, args
));
3702 ve
= SCM_VELTS (args
);
3703 #ifndef SCM_RECKLESS
3704 check_map_args (args
, len
, g_map
, proc
, arg1
, s_map
);
3709 for (i
= SCM_VECTOR_LENGTH (args
) - 1; i
>= 0; i
--)
3711 if (SCM_IMP (ve
[i
]))
3713 arg1
= scm_cons (SCM_CAR (ve
[i
]), arg1
);
3714 ve
[i
] = SCM_CDR (ve
[i
]);
3716 *pres
= scm_cons (scm_apply (proc
, arg1
, SCM_EOL
), SCM_EOL
);
3717 pres
= SCM_CDRLOC (*pres
);
3723 SCM_GPROC (s_for_each
, "for-each", 2, 0, 1, scm_for_each
, g_for_each
);
3726 scm_for_each (SCM proc
, SCM arg1
, SCM args
)
3727 #define FUNC_NAME s_for_each
3729 SCM
*ve
= &args
; /* Keep args from being optimized away. */
3731 len
= scm_ilength (arg1
);
3732 SCM_GASSERTn (len
>= 0, g_for_each
, scm_cons2 (proc
, arg1
, args
),
3733 SCM_ARG2
, s_for_each
);
3734 SCM_VALIDATE_REST_ARGUMENT (args
);
3737 while SCM_NIMP (arg1
)
3739 scm_apply (proc
, SCM_CAR (arg1
), scm_listofnull
);
3740 arg1
= SCM_CDR (arg1
);
3742 return SCM_UNSPECIFIED
;
3744 args
= scm_vector (arg1
= scm_cons (arg1
, args
));
3745 ve
= SCM_VELTS (args
);
3746 #ifndef SCM_RECKLESS
3747 check_map_args (args
, len
, g_for_each
, proc
, arg1
, s_for_each
);
3752 for (i
= SCM_VECTOR_LENGTH (args
) - 1; i
>= 0; i
--)
3755 (ve
[i
]) return SCM_UNSPECIFIED
;
3756 arg1
= scm_cons (SCM_CAR (ve
[i
]), arg1
);
3757 ve
[i
] = SCM_CDR (ve
[i
]);
3759 scm_apply (proc
, arg1
, SCM_EOL
);
3766 scm_closure (SCM code
, SCM env
)
3771 SCM_SETCODE (z
, code
);
3772 SCM_SETENV (z
, env
);
3777 scm_t_bits scm_tc16_promise
;
3780 scm_makprom (SCM code
)
3782 SCM_RETURN_NEWSMOB (scm_tc16_promise
, SCM_UNPACK (code
));
3788 promise_print (SCM exp
, SCM port
, scm_print_state
*pstate
)
3790 int writingp
= SCM_WRITINGP (pstate
);
3791 scm_puts ("#<promise ", port
);
3792 SCM_SET_WRITINGP (pstate
, 1);
3793 scm_iprin1 (SCM_CELL_OBJECT_1 (exp
), port
, pstate
);
3794 SCM_SET_WRITINGP (pstate
, writingp
);
3795 scm_putc ('>', port
);
3800 SCM_DEFINE (scm_force
, "force", 1, 0, 0,
3802 "If the promise @var{x} has not been computed yet, compute and\n"
3803 "return @var{x}, otherwise just return the previously computed\n"
3805 #define FUNC_NAME s_scm_force
3807 SCM_VALIDATE_SMOB (1, x
, promise
);
3808 if (!((1L << 16) & SCM_CELL_WORD_0 (x
)))
3810 SCM ans
= scm_call_0 (SCM_CELL_OBJECT_1 (x
));
3811 if (!((1L << 16) & SCM_CELL_WORD_0 (x
)))
3814 SCM_SET_CELL_OBJECT_1 (x
, ans
);
3815 SCM_SET_CELL_WORD_0 (x
, SCM_CELL_WORD_0 (x
) | (1L << 16));
3819 return SCM_CELL_OBJECT_1 (x
);
3824 SCM_DEFINE (scm_promise_p
, "promise?", 1, 0, 0,
3826 "Return true if @var{obj} is a promise, i.e. a delayed computation\n"
3827 "(@pxref{Delayed evaluation,,,r5rs.info,The Revised^5 Report on Scheme}).")
3828 #define FUNC_NAME s_scm_promise_p
3830 return SCM_BOOL (SCM_TYP16_PREDICATE (scm_tc16_promise
, obj
));
3835 SCM_DEFINE (scm_cons_source
, "cons-source", 3, 0, 0,
3836 (SCM xorig
, SCM x
, SCM y
),
3837 "Create and return a new pair whose car and cdr are @var{x} and @var{y}.\n"
3838 "Any source properties associated with @var{xorig} are also associated\n"
3839 "with the new pair.")
3840 #define FUNC_NAME s_scm_cons_source
3844 SCM_SET_CELL_OBJECT_0 (z
, x
);
3845 SCM_SET_CELL_OBJECT_1 (z
, y
);
3846 /* Copy source properties possibly associated with xorig. */
3847 p
= scm_whash_lookup (scm_source_whash
, xorig
);
3849 scm_whash_insert (scm_source_whash
, z
, p
);
3855 SCM_DEFINE (scm_copy_tree
, "copy-tree", 1, 0, 0,
3857 "Recursively copy the data tree that is bound to @var{obj}, and return a\n"
3858 "pointer to the new data structure. @code{copy-tree} recurses down the\n"
3859 "contents of both pairs and vectors (since both cons cells and vector\n"
3860 "cells may point to arbitrary objects), and stops recursing when it hits\n"
3861 "any other object.")
3862 #define FUNC_NAME s_scm_copy_tree
3867 if (SCM_VECTORP (obj
))
3869 unsigned long i
= SCM_VECTOR_LENGTH (obj
);
3870 ans
= scm_c_make_vector (i
, SCM_UNSPECIFIED
);
3872 SCM_VELTS (ans
)[i
] = scm_copy_tree (SCM_VELTS (obj
)[i
]);
3875 if (SCM_NCONSP (obj
))
3877 ans
= tl
= scm_cons_source (obj
,
3878 scm_copy_tree (SCM_CAR (obj
)),
3880 while (obj
= SCM_CDR (obj
), SCM_CONSP (obj
))
3882 SCM_SETCDR (tl
, scm_cons (scm_copy_tree (SCM_CAR (obj
)),
3886 SCM_SETCDR (tl
, obj
);
3892 /* We have three levels of EVAL here:
3894 - scm_i_eval (exp, env)
3896 evaluates EXP in environment ENV. ENV is a lexical environment
3897 structure as used by the actual tree code evaluator. When ENV is
3898 a top-level environment, then changes to the current module are
3899 tracked by updating ENV so that it continues to be in sync with
3902 - scm_primitive_eval (exp)
3904 evaluates EXP in the top-level environment as determined by the
3905 current module. This is done by constructing a suitable
3906 environment and calling scm_i_eval. Thus, changes to the
3907 top-level module are tracked normally.
3909 - scm_eval (exp, mod)
3911 evaluates EXP while MOD is the current module. This is done by
3912 setting the current module to MOD, invoking scm_primitive_eval on
3913 EXP, and then restoring the current module to the value it had
3914 previously. That is, while EXP is evaluated, changes to the
3915 current module are tracked, but these changes do not persist when
3918 For each level of evals, there are two variants, distinguished by a
3919 _x suffix: the ordinary variant does not modify EXP while the _x
3920 variant can destructively modify EXP into something completely
3921 unintelligible. A Scheme data structure passed as EXP to one of the
3922 _x variants should not ever be used again for anything. So when in
3923 doubt, use the ordinary variant.
3928 scm_i_eval_x (SCM exp
, SCM env
)
3930 return SCM_XEVAL (exp
, env
);
3934 scm_i_eval (SCM exp
, SCM env
)
3936 exp
= scm_copy_tree (exp
);
3937 return SCM_XEVAL (exp
, env
);
3941 scm_primitive_eval_x (SCM exp
)
3944 SCM transformer
= scm_current_module_transformer ();
3945 if (SCM_NIMP (transformer
))
3946 exp
= scm_call_1 (transformer
, exp
);
3947 env
= scm_top_level_env (scm_current_module_lookup_closure ());
3948 return scm_i_eval_x (exp
, env
);
3951 SCM_DEFINE (scm_primitive_eval
, "primitive-eval", 1, 0, 0,
3953 "Evaluate @var{exp} in the top-level environment specified by\n"
3954 "the current module.")
3955 #define FUNC_NAME s_scm_primitive_eval
3958 SCM transformer
= scm_current_module_transformer ();
3959 if (SCM_NIMP (transformer
))
3960 exp
= scm_call_1 (transformer
, exp
);
3961 env
= scm_top_level_env (scm_current_module_lookup_closure ());
3962 return scm_i_eval (exp
, env
);
3966 /* Eval does not take the second arg optionally. This is intentional
3967 * in order to be R5RS compatible, and to prepare for the new module
3968 * system, where we would like to make the choice of evaluation
3969 * environment explicit. */
3972 change_environment (void *data
)
3974 SCM pair
= SCM_PACK (data
);
3975 SCM new_module
= SCM_CAR (pair
);
3976 SCM old_module
= scm_current_module ();
3977 SCM_SETCDR (pair
, old_module
);
3978 scm_set_current_module (new_module
);
3983 restore_environment (void *data
)
3985 SCM pair
= SCM_PACK (data
);
3986 SCM old_module
= SCM_CDR (pair
);
3987 SCM new_module
= scm_current_module ();
3988 SCM_SETCAR (pair
, new_module
);
3989 scm_set_current_module (old_module
);
3993 inner_eval_x (void *data
)
3995 return scm_primitive_eval_x (SCM_PACK(data
));
3999 scm_eval_x (SCM exp
, SCM module
)
4000 #define FUNC_NAME "eval!"
4002 SCM_VALIDATE_MODULE (2, module
);
4004 return scm_internal_dynamic_wind
4005 (change_environment
, inner_eval_x
, restore_environment
,
4006 (void *) SCM_UNPACK (exp
),
4007 (void *) SCM_UNPACK (scm_cons (module
, SCM_BOOL_F
)));
4012 inner_eval (void *data
)
4014 return scm_primitive_eval (SCM_PACK(data
));
4017 SCM_DEFINE (scm_eval
, "eval", 2, 0, 0,
4018 (SCM exp
, SCM module
),
4019 "Evaluate @var{exp}, a list representing a Scheme expression,\n"
4020 "in the top-level environment specified by @var{module}.\n"
4021 "While @var{exp} is evaluated (using @var{primitive-eval}),\n"
4022 "@var{module} is made the current module. The current module\n"
4023 "is reset to its previous value when @var{eval} returns.")
4024 #define FUNC_NAME s_scm_eval
4026 SCM_VALIDATE_MODULE (2, module
);
4028 return scm_internal_dynamic_wind
4029 (change_environment
, inner_eval
, restore_environment
,
4030 (void *) SCM_UNPACK (exp
),
4031 (void *) SCM_UNPACK (scm_cons (module
, SCM_BOOL_F
)));
4035 #if (SCM_DEBUG_DEPRECATED == 0)
4037 /* Use scm_current_module () or scm_interaction_environment ()
4038 * instead. The former is the module selected during loading of code.
4039 * The latter is the module in which the user of this thread currently
4040 * types expressions.
4043 SCM scm_top_level_lookup_closure_var
;
4044 SCM scm_system_transformer
;
4046 /* Avoid using this functionality altogether (except for implementing
4047 * libguile, where you can use scm_i_eval or scm_i_eval_x).
4049 * Applications should use either C level scm_eval_x or Scheme
4050 * scm_eval; or scm_primitive_eval_x or scm_primitive_eval. */
4053 scm_eval_3 (SCM obj
, int copyp
, SCM env
)
4056 return scm_i_eval (obj
, env
);
4058 return scm_i_eval_x (obj
, env
);
4061 SCM_DEFINE (scm_eval2
, "eval2", 2, 0, 0,
4062 (SCM obj
, SCM env_thunk
),
4063 "Evaluate @var{exp}, a Scheme expression, in the environment\n"
4064 "designated by @var{lookup}, a symbol-lookup function."
4065 "Do not use this version of eval, it does not play well\n"
4066 "with the module system. Use @code{eval} or\n"
4067 "@code{primitive-eval} instead.")
4068 #define FUNC_NAME s_scm_eval2
4070 return scm_i_eval (obj
, scm_top_level_env (env_thunk
));
4074 #endif /* DEPRECATED */
4077 /* At this point, scm_deval and scm_dapply are generated.
4080 #ifdef DEBUG_EXTENSIONS
4090 scm_init_opts (scm_evaluator_traps
,
4091 scm_evaluator_trap_table
,
4092 SCM_N_EVALUATOR_TRAPS
);
4093 scm_init_opts (scm_eval_options_interface
,
4095 SCM_N_EVAL_OPTIONS
);
4097 scm_tc16_promise
= scm_make_smob_type ("promise", 0);
4098 scm_set_smob_mark (scm_tc16_promise
, scm_markcdr
);
4099 scm_set_smob_print (scm_tc16_promise
, promise_print
);
4101 /* Dirk:Fixme:: make scm_undefineds local to eval.c: it's only used here. */
4102 scm_undefineds
= scm_cons (SCM_UNDEFINED
, SCM_EOL
);
4103 SCM_SETCDR (scm_undefineds
, scm_undefineds
);
4104 scm_listofnull
= scm_cons (SCM_EOL
, SCM_EOL
);
4106 scm_f_apply
= scm_c_define_subr ("apply", scm_tc7_lsubr_2
, scm_apply
);
4111 #if SCM_DEBUG_DEPRECATED == 0
4112 scm_top_level_lookup_closure_var
=
4113 scm_c_define ("*top-level-lookup-closure*", scm_make_fluid ());
4114 scm_system_transformer
=
4115 scm_c_define ("scm:eval-transformer", scm_make_fluid ());
4118 #ifndef SCM_MAGIC_SNARFER
4119 #include "libguile/eval.x"
4122 scm_c_define ("nil", scm_lisp_nil
);
4123 scm_c_define ("t", scm_lisp_t
);
4125 scm_add_feature ("delay");