1 /* Copyright (C) 1995, 96, 97, 98, 99, 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. */
42 /* Software engineering face-lift by Greg J. Badros, 11-Dec-1999,
43 gjb@cs.washington.edu, http://www.cs.washington.edu/homes/gjb */
47 /* This file is read twice in order to produce debugging versions of
48 * scm_ceval and scm_apply. These functions, scm_deval and
49 * scm_dapply, are produced when we define the preprocessor macro
50 * DEVAL. The file is divided into sections which are treated
51 * differently with respect to DEVAL. The heads of these sections are
52 * marked with the string "SECTION:".
56 /* SECTION: This code is compiled once.
61 /* We need this to get the definitions for HAVE_ALLOCA_H, etc. */
62 #include "libguile/scmconfig.h"
64 /* AIX requires this to be the first thing in the file. The #pragma
65 directive is indented so pre-ANSI compilers will ignore it, rather
74 # ifndef alloca /* predefined by HP cc +Olibcalls */
82 #include "libguile/_scm.h"
83 #include "libguile/debug.h"
84 #include "libguile/dynwind.h"
85 #include "libguile/alist.h"
86 #include "libguile/eq.h"
87 #include "libguile/continuations.h"
88 #include "libguile/throw.h"
89 #include "libguile/smob.h"
90 #include "libguile/macros.h"
91 #include "libguile/procprop.h"
92 #include "libguile/hashtab.h"
93 #include "libguile/hash.h"
94 #include "libguile/srcprop.h"
95 #include "libguile/stackchk.h"
96 #include "libguile/objects.h"
97 #include "libguile/async.h"
98 #include "libguile/feature.h"
99 #include "libguile/modules.h"
100 #include "libguile/ports.h"
101 #include "libguile/root.h"
102 #include "libguile/vectors.h"
103 #include "libguile/fluids.h"
105 #include "libguile/validate.h"
106 #include "libguile/eval.h"
110 /* The evaluator contains a plethora of EVAL symbols.
111 * This is an attempt at explanation.
113 * The following macros should be used in code which is read twice
114 * (where the choice of evaluator is hard soldered):
116 * SCM_CEVAL is the symbol used within one evaluator to call itself.
117 * Originally, it is defined to scm_ceval, but is redefined to
118 * scm_deval during the second pass.
120 * SIDEVAL corresponds to SCM_CEVAL, but is used in situations where
121 * only side effects of expressions matter. All immediates are
124 * SCM_EVALIM is used when it is known that the expression is an
125 * immediate. (This macro never calls an evaluator.)
127 * EVALCAR evaluates the car of an expression.
129 * EVALCELLCAR is like EVALCAR, but is used when it is known that the
130 * car is a lisp cell.
132 * The following macros should be used in code which is read once
133 * (where the choice of evaluator is dynamic):
135 * SCM_XEVAL takes care of immediates without calling an evaluator. It
136 * then calls scm_ceval *or* scm_deval, depending on the debugging
139 * SCM_XEVALCAR corresponds to EVALCAR, but uses scm_ceval *or* scm_deval
140 * depending on the debugging mode.
142 * The main motivation for keeping this plethora is efficiency
143 * together with maintainability (=> locality of code).
146 #define SCM_CEVAL scm_ceval
147 #define SIDEVAL(x, env) if (SCM_NIMP (x)) SCM_CEVAL((x), (env))
149 #define EVALCELLCAR(x, env) (SCM_SYMBOLP (SCM_CAR (x)) \
150 ? *scm_lookupcar (x, env, 1) \
151 : SCM_CEVAL (SCM_CAR (x), env))
153 #define EVALCAR(x, env) (SCM_NCELLP (SCM_CAR (x)) \
154 ? (SCM_IMP (SCM_CAR (x)) \
155 ? SCM_EVALIM (SCM_CAR (x), env) \
156 : SCM_GLOC_VAL (SCM_CAR (x))) \
157 : EVALCELLCAR (x, env))
159 #define EXTEND_ENV SCM_EXTEND_ENV
161 #ifdef MEMOIZE_LOCALS
164 scm_ilookup (SCM iloc
, SCM env
)
166 register int ir
= SCM_IFRAME (iloc
);
167 register SCM er
= env
;
168 for (; 0 != ir
; --ir
)
171 for (ir
= SCM_IDIST (iloc
); 0 != ir
; --ir
)
173 if (SCM_ICDRP (iloc
))
174 return SCM_CDRLOC (er
);
175 return SCM_CARLOC (SCM_CDR (er
));
181 /* The Lookup Car Race
184 Memoization of variables and special forms is done while executing
185 the code for the first time. As long as there is only one thread
186 everything is fine, but as soon as two threads execute the same
187 code concurrently `for the first time' they can come into conflict.
189 This memoization includes rewriting variable references into more
190 efficient forms and expanding macros. Furthermore, macro expansion
191 includes `compiling' special forms like `let', `cond', etc. into
192 tree-code instructions.
194 There shouldn't normally be a problem with memoizing local and
195 global variable references (into ilocs and glocs), because all
196 threads will mutate the code in *exactly* the same way and (if I
197 read the C code correctly) it is not possible to observe a half-way
198 mutated cons cell. The lookup procedure can handle this
199 transparently without any critical sections.
201 It is different with macro expansion, because macro expansion
202 happens outside of the lookup procedure and can't be
203 undone. Therefore it can't cope with it. It has to indicate
204 failure when it detects a lost race and hope that the caller can
205 handle it. Luckily, it turns out that this is the case.
207 An example to illustrate this: Suppose that the follwing form will
208 be memoized concurrently by two threads
212 Let's first examine the lookup of X in the body. The first thread
213 decides that it has to find the symbol "x" in the environment and
214 starts to scan it. Then the other thread takes over and actually
215 overtakes the first. It looks up "x" and substitutes an
216 appropriate iloc for it. Now the first thread continues and
217 completes its lookup. It comes to exactly the same conclusions as
218 the second one and could - without much ado - just overwrite the
219 iloc with the same iloc.
221 But let's see what will happen when the race occurs while looking
222 up the symbol "let" at the start of the form. It could happen that
223 the second thread interrupts the lookup of the first thread and not
224 only substitutes a gloc for it but goes right ahead and replaces it
225 with the compiled form (#@let* (x 12) x). Now, when the first
226 thread completes its lookup, it would replace the #@let* with a
227 gloc pointing to the "let" binding, effectively reverting the form
228 to (let (x 12) x). This is wrong. It has to detect that it has
229 lost the race and the evaluator has to reconsider the changed form
232 This race condition could be resolved with some kind of traffic
233 light (like mutexes) around scm_lookupcar, but I think that it is
234 best to avoid them in this case. They would serialize memoization
235 completely and because lookup involves calling arbitrary Scheme
236 code (via the lookup-thunk), threads could be blocked for an
237 arbitrary amount of time or even deadlock. But with the current
238 solution a lot of unnecessary work is potentially done. */
240 /* SCM_LOOKUPCAR1 is was SCM_LOOKUPCAR used to be but is allowed to
241 return NULL to indicate a failed lookup due to some race conditions
242 between threads. This only happens when VLOC is the first cell of
243 a special form that will eventually be memoized (like `let', etc.)
244 In that case the whole lookup is bogus and the caller has to
245 reconsider the complete special form.
247 SCM_LOOKUPCAR is still there, of course. It just calls
248 SCM_LOOKUPCAR1 and aborts on recieving NULL. So SCM_LOOKUPCAR
249 should only be called when it is known that VLOC is not the first
250 pair of a special form. Otherwise, use SCM_LOOKUPCAR1 and check
251 for NULL. I think I've found the only places where this
254 #endif /* USE_THREADS */
256 SCM_SYMBOL (scm_unbound_variable_key
, "unbound-variable");
260 scm_lookupcar1 (SCM vloc
, SCM genv
, int check
)
263 scm_lookupcar (SCM vloc
, SCM genv
, int check
)
267 register SCM
*al
, fl
, var
= SCM_CAR (vloc
);
269 register SCM var2
= var
;
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_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
, vcell
;
328 top_thunk
= SCM_CAR (env
); /* env now refers to a top level env thunk */
332 top_thunk
= SCM_BOOL_F
;
333 vcell
= scm_sym2vcell (var
, top_thunk
, SCM_BOOL_F
);
334 if (SCM_FALSEP (vcell
))
340 if (SCM_NNULLP (env
) || SCM_UNBNDP (SCM_CDR (var
)))
344 /* scm_everr (vloc, genv,...) */
348 scm_error (scm_unbound_variable_key
, NULL
, "Unbound variable: ~S",
349 scm_cons (var
, SCM_EOL
), SCM_BOOL_F
);
351 scm_misc_error (NULL
, "Damaged environment: ~S",
352 scm_cons (var
, SCM_EOL
));
355 /* A variable could not be found, but we shall not throw an error. */
356 static SCM undef_object
= SCM_UNDEFINED
;
357 return &undef_object
;
362 if (SCM_CAR (vloc
) != var2
)
364 /* Some other thread has changed the very cell we are working
365 on. In effect, it must have done our job or messed it up
368 var
= SCM_CAR (vloc
);
369 if (SCM_ITAG3 (var
) == scm_tc3_cons_gloc
)
370 return SCM_GLOC_VAL_LOC (var
);
371 #ifdef MEMOIZE_LOCALS
372 if (SCM_ITAG7 (var
) == SCM_ITAG7 (SCM_ILOC00
))
373 return scm_ilookup (var
, genv
);
375 /* We can't cope with anything else than glocs and ilocs. When
376 a special form has been memoized (i.e. `let' into `#@let') we
377 return NULL and expect the calling function to do the right
378 thing. For the evaluator, this means going back and redoing
379 the dispatch on the car of the form. */
382 #endif /* USE_THREADS */
384 SCM_SET_CELL_WORD_0 (vloc
, SCM_UNPACK (var
) + scm_tc3_cons_gloc
);
385 /* Except wait...what if the var is not a vcell,
386 * but syntax or something.... */
387 return SCM_CDRLOC (var
);
392 scm_lookupcar (SCM vloc
, SCM genv
, int check
)
394 SCM
*loc
= scm_lookupcar1 (vloc
, genv
, check
);
401 #define unmemocar scm_unmemocar
404 scm_unmemocar (SCM form
, SCM env
)
411 if (SCM_ITAG3 (c
) == scm_tc3_cons_gloc
)
412 SCM_SETCAR (form
, SCM_GLOC_SYM (c
));
413 #ifdef MEMOIZE_LOCALS
414 #ifdef DEBUG_EXTENSIONS
415 else if (SCM_ILOCP (c
))
419 for (ir
= SCM_IFRAME (c
); ir
!= 0; --ir
)
421 env
= SCM_CAR (SCM_CAR (env
));
422 for (ir
= SCM_IDIST (c
); ir
!= 0; --ir
)
424 SCM_SETCAR (form
, SCM_ICDRP (c
) ? env
: SCM_CAR (env
));
433 scm_eval_car (SCM pair
, SCM env
)
435 return SCM_XEVALCAR (pair
, env
);
440 * The following rewrite expressions and
441 * some memoized forms have different syntax
444 const char scm_s_expression
[] = "missing or extra expression";
445 const char scm_s_test
[] = "bad test";
446 const char scm_s_body
[] = "bad body";
447 const char scm_s_bindings
[] = "bad bindings";
448 const char scm_s_duplicate_bindings
[] = "duplicate bindings";
449 const char scm_s_variable
[] = "bad variable";
450 const char scm_s_clauses
[] = "bad or missing clauses";
451 const char scm_s_formals
[] = "bad formals";
452 const char scm_s_duplicate_formals
[] = "duplicate formals";
454 SCM_GLOBAL_SYMBOL (scm_sym_dot
, ".");
455 SCM_GLOBAL_SYMBOL (scm_sym_arrow
, "=>");
456 SCM_GLOBAL_SYMBOL (scm_sym_else
, "else");
457 SCM_GLOBAL_SYMBOL (scm_sym_unquote
, "unquote");
458 SCM_GLOBAL_SYMBOL (scm_sym_uq_splicing
, "unquote-splicing");
462 #ifdef DEBUG_EXTENSIONS
463 SCM_GLOBAL_SYMBOL (scm_sym_enter_frame
, "enter-frame");
464 SCM_GLOBAL_SYMBOL (scm_sym_apply_frame
, "apply-frame");
465 SCM_GLOBAL_SYMBOL (scm_sym_exit_frame
, "exit-frame");
466 SCM_GLOBAL_SYMBOL (scm_sym_trace
, "trace");
470 /* Check that the body denoted by XORIG is valid and rewrite it into
471 its internal form. The internal form of a body is just the body
472 itself, but prefixed with an ISYM that denotes to what kind of
473 outer construct this body belongs. A lambda body starts with
474 SCM_IM_LAMBDA, for example, a body of a let starts with SCM_IM_LET,
475 etc. The one exception is a body that belongs to a letrec that has
476 been formed by rewriting internal defines: it starts with
479 /* XXX - Besides controlling the rewriting of internal defines, the
480 additional ISYM could be used for improved error messages.
481 This is not done yet. */
484 scm_m_body (SCM op
, SCM xorig
, const char *what
)
486 SCM_ASSYNT (scm_ilength (xorig
) >= 1, xorig
, scm_s_expression
, what
);
488 /* Don't add another ISYM if one is present already. */
489 if (SCM_ISYMP (SCM_CAR (xorig
)))
492 /* Retain possible doc string. */
493 if (!SCM_CONSP (SCM_CAR (xorig
)))
495 if (SCM_NNULLP (SCM_CDR(xorig
)))
496 return scm_cons (SCM_CAR (xorig
),
497 scm_m_body (op
, SCM_CDR(xorig
), what
));
501 return scm_cons (op
, xorig
);
504 SCM_SYNTAX(s_quote
,"quote", scm_makmmacro
, scm_m_quote
);
505 SCM_GLOBAL_SYMBOL(scm_sym_quote
, s_quote
);
508 scm_m_quote (SCM xorig
, SCM env
)
510 SCM x
= scm_copy_tree (SCM_CDR (xorig
));
512 SCM_ASSYNT (scm_ilength (SCM_CDR (xorig
)) == 1,
513 xorig
, scm_s_expression
, s_quote
);
514 return scm_cons (SCM_IM_QUOTE
, x
);
519 SCM_SYNTAX(s_begin
, "begin", scm_makmmacro
, scm_m_begin
);
520 SCM_GLOBAL_SYMBOL(scm_sym_begin
, s_begin
);
523 scm_m_begin (SCM xorig
, SCM env
)
525 SCM_ASSYNT (scm_ilength (SCM_CDR (xorig
)) >= 1,
526 xorig
, scm_s_expression
, s_begin
);
527 return scm_cons (SCM_IM_BEGIN
, SCM_CDR (xorig
));
530 SCM_SYNTAX(s_if
, "if", scm_makmmacro
, scm_m_if
);
531 SCM_GLOBAL_SYMBOL(scm_sym_if
, s_if
);
534 scm_m_if (SCM xorig
, SCM env
)
536 int len
= scm_ilength (SCM_CDR (xorig
));
537 SCM_ASSYNT (len
>= 2 && len
<= 3, xorig
, scm_s_expression
, "if");
538 return scm_cons (SCM_IM_IF
, SCM_CDR (xorig
));
542 /* Will go into the RnRS module when Guile is factorized.
543 SCM_SYNTAX(scm_s_set_x,"set!", scm_makmmacro, scm_m_set_x); */
544 const char scm_s_set_x
[] = "set!";
545 SCM_GLOBAL_SYMBOL(scm_sym_set_x
, scm_s_set_x
);
548 scm_m_set_x (SCM xorig
, SCM env
)
550 SCM x
= SCM_CDR (xorig
);
551 SCM_ASSYNT (2 == scm_ilength (x
), xorig
, scm_s_expression
, scm_s_set_x
);
552 SCM_ASSYNT (SCM_SYMBOLP (SCM_CAR (x
)),
553 xorig
, scm_s_variable
, scm_s_set_x
);
554 return scm_cons (SCM_IM_SET_X
, x
);
558 SCM_SYNTAX(s_and
, "and", scm_makmmacro
, scm_m_and
);
559 SCM_GLOBAL_SYMBOL(scm_sym_and
, s_and
);
562 scm_m_and (SCM xorig
, SCM env
)
564 int len
= scm_ilength (SCM_CDR (xorig
));
565 SCM_ASSYNT (len
>= 0, xorig
, scm_s_test
, s_and
);
567 return scm_cons (SCM_IM_AND
, SCM_CDR (xorig
));
572 SCM_SYNTAX(s_or
,"or", scm_makmmacro
, scm_m_or
);
573 SCM_GLOBAL_SYMBOL(scm_sym_or
,s_or
);
576 scm_m_or (SCM xorig
, SCM env
)
578 int len
= scm_ilength (SCM_CDR (xorig
));
579 SCM_ASSYNT (len
>= 0, xorig
, scm_s_test
, s_or
);
581 return scm_cons (SCM_IM_OR
, SCM_CDR (xorig
));
587 SCM_SYNTAX(s_case
, "case", scm_makmmacro
, scm_m_case
);
588 SCM_GLOBAL_SYMBOL(scm_sym_case
, s_case
);
591 scm_m_case (SCM xorig
, SCM env
)
593 SCM proc
, cdrx
= scm_list_copy (SCM_CDR (xorig
)), x
= cdrx
;
594 SCM_ASSYNT (scm_ilength (x
) >= 2, xorig
, scm_s_clauses
, s_case
);
595 while (SCM_NIMP (x
= SCM_CDR (x
)))
598 SCM_ASSYNT (scm_ilength (proc
) >= 2, xorig
, scm_s_clauses
, s_case
);
599 SCM_ASSYNT (scm_ilength (SCM_CAR (proc
)) >= 0
600 || (SCM_EQ_P (scm_sym_else
, SCM_CAR (proc
))
601 && SCM_NULLP (SCM_CDR (x
))),
602 xorig
, scm_s_clauses
, s_case
);
604 return scm_cons (SCM_IM_CASE
, cdrx
);
608 SCM_SYNTAX(s_cond
, "cond", scm_makmmacro
, scm_m_cond
);
609 SCM_GLOBAL_SYMBOL(scm_sym_cond
, s_cond
);
613 scm_m_cond (SCM xorig
, SCM env
)
615 SCM arg1
, cdrx
= scm_list_copy (SCM_CDR (xorig
)), x
= cdrx
;
616 int len
= scm_ilength (x
);
617 SCM_ASSYNT (len
>= 1, xorig
, scm_s_clauses
, s_cond
);
621 len
= scm_ilength (arg1
);
622 SCM_ASSYNT (len
>= 1, xorig
, scm_s_clauses
, s_cond
);
623 if (SCM_EQ_P (scm_sym_else
, SCM_CAR (arg1
)))
625 SCM_ASSYNT (SCM_NULLP (SCM_CDR (x
)) && len
>= 2,
626 xorig
, "bad ELSE clause", s_cond
);
627 SCM_SETCAR (arg1
, SCM_BOOL_T
);
629 if (len
>= 2 && SCM_EQ_P (scm_sym_arrow
, SCM_CAR (SCM_CDR (arg1
))))
630 SCM_ASSYNT (3 == len
&& SCM_NIMP (SCM_CAR (SCM_CDR (SCM_CDR (arg1
)))),
631 xorig
, "bad recipient", s_cond
);
634 return scm_cons (SCM_IM_COND
, cdrx
);
637 SCM_SYNTAX(s_lambda
, "lambda", scm_makmmacro
, scm_m_lambda
);
638 SCM_GLOBAL_SYMBOL(scm_sym_lambda
, s_lambda
);
640 /* Return #t if OBJ is `eq?' to one of the elements of LIST or to the
641 cdr of the last cons. (Thus, LIST is not required to be a proper
642 list and when OBJ also found in the improper ending.) */
645 scm_c_improper_memq (SCM obj
, SCM list
)
647 for (; SCM_CONSP (list
); list
= SCM_CDR (list
))
649 if (SCM_EQ_P (SCM_CAR (list
), obj
))
652 return SCM_EQ_P (list
, obj
);
656 scm_m_lambda (SCM xorig
, SCM env
)
658 SCM proc
, x
= SCM_CDR (xorig
);
659 if (scm_ilength (x
) < 2)
662 if (SCM_NULLP (proc
))
664 if (SCM_EQ_P (SCM_IM_LET
, proc
)) /* named let */
668 if (SCM_SYMBOLP (proc
))
670 if (SCM_NCONSP (proc
))
672 while (SCM_NIMP (proc
))
674 if (SCM_NCONSP (proc
))
676 if (!SCM_SYMBOLP (proc
))
681 if (!SCM_SYMBOLP (SCM_CAR (proc
)))
683 else if (scm_c_improper_memq (SCM_CAR(proc
), SCM_CDR(proc
)))
684 scm_wta (xorig
, scm_s_duplicate_formals
, s_lambda
);
685 proc
= SCM_CDR (proc
);
687 if (SCM_NNULLP (proc
))
690 scm_wta (xorig
, scm_s_formals
, s_lambda
);
694 return scm_cons2 (SCM_IM_LAMBDA
, SCM_CAR (x
),
695 scm_m_body (SCM_IM_LAMBDA
, SCM_CDR (x
), s_lambda
));
698 SCM_SYNTAX(s_letstar
,"let*", scm_makmmacro
, scm_m_letstar
);
699 SCM_GLOBAL_SYMBOL(scm_sym_letstar
,s_letstar
);
703 scm_m_letstar (SCM xorig
, SCM env
)
705 SCM x
= SCM_CDR (xorig
), arg1
, proc
, vars
= SCM_EOL
, *varloc
= &vars
;
706 int len
= scm_ilength (x
);
707 SCM_ASSYNT (len
>= 2, xorig
, scm_s_body
, s_letstar
);
709 SCM_ASSYNT (scm_ilength (proc
) >= 0, xorig
, scm_s_bindings
, s_letstar
);
710 while (SCM_NIMP (proc
))
712 arg1
= SCM_CAR (proc
);
713 SCM_ASSYNT (2 == scm_ilength (arg1
), xorig
, scm_s_bindings
, s_letstar
);
714 SCM_ASSYNT (SCM_SYMBOLP (SCM_CAR (arg1
)), xorig
, scm_s_variable
, s_letstar
);
715 if (scm_c_improper_memq (SCM_CAR (arg1
), vars
))
716 scm_wta (xorig
, scm_s_duplicate_bindings
, s_letstar
);
717 *varloc
= scm_cons2 (SCM_CAR (arg1
), SCM_CAR (SCM_CDR (arg1
)), SCM_EOL
);
718 varloc
= SCM_CDRLOC (SCM_CDR (*varloc
));
719 proc
= SCM_CDR (proc
);
721 x
= scm_cons (vars
, SCM_CDR (x
));
723 return scm_cons2 (SCM_IM_LETSTAR
, SCM_CAR (x
),
724 scm_m_body (SCM_IM_LETSTAR
, SCM_CDR (x
), s_letstar
));
727 /* DO gets the most radically altered syntax
728 (do ((<var1> <init1> <step1>)
734 (do_mem (varn ... var2 var1)
735 (<init1> <init2> ... <initn>)
738 <step1> <step2> ... <stepn>) ;; missing steps replaced by var
741 SCM_SYNTAX(s_do
, "do", scm_makmmacro
, scm_m_do
);
742 SCM_GLOBAL_SYMBOL(scm_sym_do
, s_do
);
745 scm_m_do (SCM xorig
, SCM env
)
747 SCM x
= SCM_CDR (xorig
), arg1
, proc
;
748 SCM vars
= SCM_EOL
, inits
= SCM_EOL
, steps
= SCM_EOL
;
749 SCM
*initloc
= &inits
, *steploc
= &steps
;
750 int len
= scm_ilength (x
);
751 SCM_ASSYNT (len
>= 2, xorig
, scm_s_test
, "do");
753 SCM_ASSYNT (scm_ilength (proc
) >= 0, xorig
, scm_s_bindings
, "do");
754 while (SCM_NIMP(proc
))
756 arg1
= SCM_CAR (proc
);
757 len
= scm_ilength (arg1
);
758 SCM_ASSYNT (2 == len
|| 3 == len
, xorig
, scm_s_bindings
, "do");
759 SCM_ASSYNT (SCM_SYMBOLP (SCM_CAR (arg1
)), xorig
, scm_s_variable
, "do");
760 /* vars reversed here, inits and steps reversed at evaluation */
761 vars
= scm_cons (SCM_CAR (arg1
), vars
); /* variable */
762 arg1
= SCM_CDR (arg1
);
763 *initloc
= scm_cons (SCM_CAR (arg1
), SCM_EOL
); /* init */
764 initloc
= SCM_CDRLOC (*initloc
);
765 arg1
= SCM_CDR (arg1
);
766 *steploc
= scm_cons (SCM_IMP (arg1
) ? SCM_CAR (vars
) : SCM_CAR (arg1
), SCM_EOL
); /* step */
767 steploc
= SCM_CDRLOC (*steploc
);
768 proc
= SCM_CDR (proc
);
771 SCM_ASSYNT (scm_ilength (SCM_CAR (x
)) >= 1, xorig
, scm_s_test
, "do");
772 x
= scm_cons2 (SCM_CAR (x
), SCM_CDR (x
), steps
);
773 x
= scm_cons2 (vars
, inits
, x
);
774 return scm_cons (SCM_IM_DO
, x
);
777 /* evalcar is small version of inline EVALCAR when we don't care about
780 #define evalcar scm_eval_car
783 static SCM
iqq (SCM form
, SCM env
, int depth
);
785 SCM_SYNTAX(s_quasiquote
, "quasiquote", scm_makacro
, scm_m_quasiquote
);
786 SCM_GLOBAL_SYMBOL(scm_sym_quasiquote
, s_quasiquote
);
789 scm_m_quasiquote (SCM xorig
, SCM env
)
791 SCM x
= SCM_CDR (xorig
);
792 SCM_ASSYNT (scm_ilength (x
) == 1, xorig
, scm_s_expression
, s_quasiquote
);
793 return iqq (SCM_CAR (x
), env
, 1);
798 iqq (SCM form
,SCM env
,int depth
)
804 if (SCM_VECTORP (form
))
806 long i
= SCM_VECTOR_LENGTH (form
);
807 SCM
*data
= SCM_VELTS (form
);
810 tmp
= scm_cons (data
[i
], tmp
);
811 return scm_vector (iqq (tmp
, env
, depth
));
813 if (SCM_NCONSP(form
))
815 tmp
= SCM_CAR (form
);
816 if (SCM_EQ_P (scm_sym_quasiquote
, tmp
))
821 if (SCM_EQ_P (scm_sym_unquote
, tmp
))
825 form
= SCM_CDR (form
);
826 SCM_ASSERT (SCM_ECONSP (form
) && SCM_NULLP (SCM_CDR (form
)),
827 form
, SCM_ARG1
, s_quasiquote
);
829 return evalcar (form
, env
);
830 return scm_cons2 (tmp
, iqq (SCM_CAR (form
), env
, depth
), SCM_EOL
);
832 if (SCM_NIMP (tmp
) && (SCM_EQ_P (scm_sym_uq_splicing
, SCM_CAR (tmp
))))
836 return scm_append (scm_cons2 (evalcar (tmp
, env
), iqq (SCM_CDR (form
), env
, depth
), SCM_EOL
));
838 return scm_cons (iqq (SCM_CAR (form
), env
, edepth
), iqq (SCM_CDR (form
), env
, depth
));
841 /* Here are acros which return values rather than code. */
843 SCM_SYNTAX (s_delay
, "delay", scm_makmmacro
, scm_m_delay
);
844 SCM_GLOBAL_SYMBOL (scm_sym_delay
, s_delay
);
847 scm_m_delay (SCM xorig
, SCM env
)
849 SCM_ASSYNT (scm_ilength (xorig
) == 2, xorig
, scm_s_expression
, s_delay
);
850 return scm_cons2 (SCM_IM_DELAY
, SCM_EOL
, SCM_CDR (xorig
));
854 SCM_SYNTAX(s_define
, "define", scm_makmmacro
, scm_m_define
);
855 SCM_GLOBAL_SYMBOL(scm_sym_define
, s_define
);
858 scm_m_define (SCM x
, SCM env
)
862 SCM_ASSYNT (scm_ilength (x
) >= 2, arg1
, scm_s_expression
, s_define
);
865 while (SCM_CONSP (proc
))
866 { /* nested define syntax */
867 x
= scm_cons (scm_cons2 (scm_sym_lambda
, SCM_CDR (proc
), x
), SCM_EOL
);
868 proc
= SCM_CAR (proc
);
870 SCM_ASSYNT (SCM_SYMBOLP (proc
),
871 arg1
, scm_s_variable
, s_define
);
872 SCM_ASSYNT (1 == scm_ilength (x
), arg1
, scm_s_expression
, s_define
);
873 if (SCM_TOP_LEVEL (env
))
875 x
= evalcar (x
, env
);
876 #ifdef DEBUG_EXTENSIONS
877 if (SCM_REC_PROCNAMES_P
&& SCM_NIMP (x
))
881 if (SCM_CLOSUREP (arg1
)
882 /* Only the first definition determines the name. */
883 && SCM_FALSEP (scm_procedure_property (arg1
, scm_sym_name
)))
884 scm_set_procedure_property_x (arg1
, scm_sym_name
, proc
);
885 else if (SCM_TYP16 (arg1
) == scm_tc16_macro
886 && !SCM_EQ_P (SCM_CDR (arg1
), arg1
))
888 arg1
= SCM_CDR (arg1
);
893 arg1
= scm_sym2vcell (proc
, scm_env_top_level (env
), SCM_BOOL_T
);
894 SCM_SETCDR (arg1
, x
);
896 return scm_cons2 (scm_sym_quote
, SCM_CAR (arg1
), SCM_EOL
);
898 return SCM_UNSPECIFIED
;
901 return scm_cons2 (SCM_IM_DEFINE
, proc
, x
);
907 scm_m_letrec1 (SCM op
, SCM imm
, SCM xorig
, SCM env
)
909 SCM cdrx
= SCM_CDR (xorig
); /* locally mutable version of form */
910 char *what
= SCM_SYMBOL_CHARS (SCM_CAR (xorig
));
911 SCM x
= cdrx
, proc
, arg1
; /* structure traversers */
912 SCM vars
= SCM_EOL
, inits
= SCM_EOL
, *initloc
= &inits
;
915 SCM_ASSYNT (scm_ilength (proc
) >= 1, xorig
, scm_s_bindings
, what
);
918 /* vars scm_list reversed here, inits reversed at evaluation */
919 arg1
= SCM_CAR (proc
);
920 SCM_ASSYNT (2 == scm_ilength (arg1
), xorig
, scm_s_bindings
, what
);
921 SCM_ASSYNT (SCM_SYMBOLP (SCM_CAR (arg1
)), xorig
, scm_s_variable
, what
);
922 if (scm_c_improper_memq (SCM_CAR (arg1
), vars
))
923 scm_wta (xorig
, scm_s_duplicate_bindings
, what
);
924 vars
= scm_cons (SCM_CAR (arg1
), vars
);
925 *initloc
= scm_cons (SCM_CAR (SCM_CDR (arg1
)), SCM_EOL
);
926 initloc
= SCM_CDRLOC (*initloc
);
928 while (SCM_NIMP (proc
= SCM_CDR (proc
)));
930 return scm_cons2 (op
, vars
,
931 scm_cons (inits
, scm_m_body (imm
, SCM_CDR (x
), what
)));
934 SCM_SYNTAX(s_letrec
, "letrec", scm_makmmacro
, scm_m_letrec
);
935 SCM_GLOBAL_SYMBOL(scm_sym_letrec
, s_letrec
);
938 scm_m_letrec (SCM xorig
, SCM env
)
940 SCM x
= SCM_CDR (xorig
);
941 SCM_ASSYNT (scm_ilength (x
) >= 2, xorig
, scm_s_body
, s_letrec
);
943 if (SCM_NULLP (SCM_CAR (x
))) /* null binding, let* faster */
944 return scm_m_letstar (scm_cons2 (SCM_CAR (xorig
), SCM_EOL
,
945 scm_m_body (SCM_IM_LETREC
,
950 return scm_m_letrec1 (SCM_IM_LETREC
, SCM_IM_LETREC
, xorig
, env
);
953 SCM_SYNTAX(s_let
, "let", scm_makmmacro
, scm_m_let
);
954 SCM_GLOBAL_SYMBOL(scm_sym_let
, s_let
);
957 scm_m_let (SCM xorig
, SCM env
)
959 SCM cdrx
= SCM_CDR (xorig
); /* locally mutable version of form */
960 SCM x
= cdrx
, proc
, arg1
, name
; /* structure traversers */
961 SCM vars
= SCM_EOL
, inits
= SCM_EOL
, *varloc
= &vars
, *initloc
= &inits
;
963 SCM_ASSYNT (scm_ilength (x
) >= 2, xorig
, scm_s_body
, s_let
);
967 && SCM_CONSP (SCM_CAR (proc
)) && SCM_NULLP (SCM_CDR (proc
))))
969 /* null or single binding, let* is faster */
970 return scm_m_letstar (scm_cons2 (SCM_CAR (xorig
), proc
,
971 scm_m_body (SCM_IM_LET
,
977 SCM_ASSYNT (SCM_NIMP (proc
), xorig
, scm_s_bindings
, s_let
);
978 if (SCM_CONSP (proc
))
980 /* plain let, proc is <bindings> */
981 return scm_m_letrec1 (SCM_IM_LET
, SCM_IM_LET
, xorig
, env
);
984 if (!SCM_SYMBOLP (proc
))
985 scm_wta (xorig
, scm_s_bindings
, s_let
); /* bad let */
986 name
= proc
; /* named let, build equiv letrec */
988 SCM_ASSYNT (scm_ilength (x
) >= 2, xorig
, scm_s_body
, s_let
);
989 proc
= SCM_CAR (x
); /* bindings list */
990 SCM_ASSYNT (scm_ilength (proc
) >= 0, xorig
, scm_s_bindings
, s_let
);
991 while (SCM_NIMP (proc
))
992 { /* vars and inits both in order */
993 arg1
= SCM_CAR (proc
);
994 SCM_ASSYNT (2 == scm_ilength (arg1
), xorig
, scm_s_bindings
, s_let
);
995 SCM_ASSYNT (SCM_SYMBOLP (SCM_CAR (arg1
)),
996 xorig
, scm_s_variable
, s_let
);
997 *varloc
= scm_cons (SCM_CAR (arg1
), SCM_EOL
);
998 varloc
= SCM_CDRLOC (*varloc
);
999 *initloc
= scm_cons (SCM_CAR (SCM_CDR (arg1
)), SCM_EOL
);
1000 initloc
= SCM_CDRLOC (*initloc
);
1001 proc
= SCM_CDR (proc
);
1004 proc
= scm_cons2 (scm_sym_lambda
, vars
,
1005 scm_m_body (SCM_IM_LET
, SCM_CDR (x
), "let"));
1006 proc
= scm_cons2 (scm_sym_let
, scm_cons (scm_cons2 (name
, proc
, SCM_EOL
),
1008 scm_acons (name
, inits
, SCM_EOL
));
1009 return scm_m_letrec1 (SCM_IM_LETREC
, SCM_IM_LET
, proc
, env
);
1013 SCM_SYNTAX (s_atapply
,"@apply", scm_makmmacro
, scm_m_apply
);
1014 SCM_GLOBAL_SYMBOL (scm_sym_atapply
, s_atapply
);
1015 SCM_GLOBAL_SYMBOL (scm_sym_apply
, s_atapply
+ 1);
1018 scm_m_apply (SCM xorig
, SCM env
)
1020 SCM_ASSYNT (scm_ilength (SCM_CDR (xorig
)) == 2,
1021 xorig
, scm_s_expression
, s_atapply
);
1022 return scm_cons (SCM_IM_APPLY
, SCM_CDR (xorig
));
1026 SCM_SYNTAX(s_atcall_cc
,"@call-with-current-continuation", scm_makmmacro
, scm_m_cont
);
1027 SCM_GLOBAL_SYMBOL(scm_sym_atcall_cc
,s_atcall_cc
);
1031 scm_m_cont (SCM xorig
, SCM env
)
1033 SCM_ASSYNT (scm_ilength (SCM_CDR (xorig
)) == 1,
1034 xorig
, scm_s_expression
, s_atcall_cc
);
1035 return scm_cons (SCM_IM_CONT
, SCM_CDR (xorig
));
1038 /* Multi-language support */
1043 SCM_SYNTAX (s_nil_cond
, "nil-cond", scm_makmmacro
, scm_m_nil_cond
);
1046 scm_m_nil_cond (SCM xorig
, SCM env
)
1048 int len
= scm_ilength (SCM_CDR (xorig
));
1049 SCM_ASSYNT (len
>= 1 && (len
& 1) == 1, xorig
,
1050 scm_s_expression
, "nil-cond");
1051 return scm_cons (SCM_IM_NIL_COND
, SCM_CDR (xorig
));
1054 SCM_SYNTAX (s_nil_ify
, "nil-ify", scm_makmmacro
, scm_m_nil_ify
);
1057 scm_m_nil_ify (SCM xorig
, SCM env
)
1059 SCM_ASSYNT (scm_ilength (SCM_CDR (xorig
)) == 1,
1060 xorig
, 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
)
1069 SCM_ASSYNT (scm_ilength (SCM_CDR (xorig
)) == 1,
1070 xorig
, scm_s_expression
, "t-ify");
1071 return scm_cons (SCM_IM_T_IFY
, SCM_CDR (xorig
));
1074 SCM_SYNTAX (s_0_cond
, "0-cond", scm_makmmacro
, scm_m_0_cond
);
1077 scm_m_0_cond (SCM xorig
, SCM env
)
1079 int len
= scm_ilength (SCM_CDR (xorig
));
1080 SCM_ASSYNT (len
>= 1 && (len
& 1) == 1, xorig
,
1081 scm_s_expression
, "0-cond");
1082 return scm_cons (SCM_IM_0_COND
, SCM_CDR (xorig
));
1085 SCM_SYNTAX (s_0_ify
, "0-ify", scm_makmmacro
, scm_m_0_ify
);
1088 scm_m_0_ify (SCM xorig
, SCM env
)
1090 SCM_ASSYNT (scm_ilength (SCM_CDR (xorig
)) == 1,
1091 xorig
, scm_s_expression
, "0-ify");
1092 return scm_cons (SCM_IM_0_IFY
, SCM_CDR (xorig
));
1095 SCM_SYNTAX (s_1_ify
, "1-ify", scm_makmmacro
, scm_m_1_ify
);
1098 scm_m_1_ify (SCM xorig
, SCM env
)
1100 SCM_ASSYNT (scm_ilength (SCM_CDR (xorig
)) == 1,
1101 xorig
, scm_s_expression
, "1-ify");
1102 return scm_cons (SCM_IM_1_IFY
, SCM_CDR (xorig
));
1105 SCM_SYNTAX (s_atfop
, "@fop", scm_makmmacro
, scm_m_atfop
);
1108 scm_m_atfop (SCM xorig
, SCM env
)
1110 SCM x
= SCM_CDR (xorig
), vcell
;
1111 SCM_ASSYNT (scm_ilength (x
) >= 1, xorig
, scm_s_expression
, "@fop");
1112 vcell
= scm_symbol_fref (SCM_CAR (x
));
1113 SCM_ASSYNT (SCM_CONSP (vcell
), x
,
1114 "Symbol's function definition is void", NULL
);
1115 SCM_SET_CELL_WORD_0 (x
, SCM_UNPACK (vcell
) + scm_tc3_cons_gloc
);
1119 SCM_SYNTAX (s_atbind
, "@bind", scm_makmmacro
, scm_m_atbind
);
1122 scm_m_atbind (SCM xorig
, SCM env
)
1124 SCM x
= SCM_CDR (xorig
);
1125 SCM_ASSYNT (scm_ilength (x
) > 1, xorig
, scm_s_expression
, "@bind");
1131 while (SCM_NIMP (SCM_CDR (env
)))
1132 env
= SCM_CDR (env
);
1133 env
= SCM_CAR (env
);
1134 if (SCM_CONSP (env
))
1139 while (SCM_NIMP (x
))
1141 SCM_SET_CELL_WORD_0 (x
, SCM_UNPACK (scm_sym2vcell (SCM_CAR (x
), env
, SCM_BOOL_T
)) + scm_tc3_cons_gloc
);
1144 return scm_cons (SCM_IM_BIND
, SCM_CDR (xorig
));
1148 scm_m_expand_body (SCM xorig
, SCM env
)
1150 SCM form
, x
= SCM_CDR (xorig
), defs
= SCM_EOL
;
1151 char *what
= SCM_ISYMCHARS (SCM_CAR (xorig
)) + 2;
1153 while (SCM_NIMP (x
))
1156 if (SCM_IMP (form
) || SCM_NCONSP (form
))
1158 if (SCM_IMP (SCM_CAR (form
)))
1160 if (!SCM_SYMBOLP (SCM_CAR (form
)))
1163 form
= scm_macroexp (scm_cons_source (form
,
1168 if (SCM_EQ_P (SCM_IM_DEFINE
, SCM_CAR (form
)))
1170 defs
= scm_cons (SCM_CDR (form
), defs
);
1173 else if (SCM_NIMP(defs
))
1177 else if (SCM_EQ_P (SCM_IM_BEGIN
, SCM_CAR (form
)))
1179 x
= scm_append (scm_cons2 (SCM_CDR (form
), SCM_CDR (x
), SCM_EOL
));
1183 x
= scm_cons (form
, SCM_CDR(x
));
1188 SCM_ASSYNT (SCM_NIMP (x
), SCM_CDR (xorig
), scm_s_body
, what
);
1189 if (SCM_NIMP (defs
))
1191 x
= scm_cons (scm_m_letrec1 (SCM_IM_LETREC
,
1193 scm_cons2 (scm_sym_define
, defs
, x
),
1199 SCM_SETCAR (xorig
, SCM_CAR (x
));
1200 SCM_SETCDR (xorig
, SCM_CDR (x
));
1207 scm_macroexp (SCM x
, SCM env
)
1211 /* Don't bother to produce error messages here. We get them when we
1212 eventually execute the code for real. */
1215 if (!SCM_SYMBOLP (SCM_CAR (x
)))
1220 SCM
*proc_ptr
= scm_lookupcar1 (x
, env
, 0);
1221 if (proc_ptr
== NULL
)
1223 /* We have lost the race. */
1229 proc
= *scm_lookupcar (x
, env
, 0);
1232 /* Only handle memoizing macros. `Acros' and `macros' are really
1233 special forms and should not be evaluated here. */
1236 || scm_tc16_macro
!= SCM_TYP16 (proc
)
1237 || (SCM_CELL_WORD_0 (proc
) >> 16) != 2)
1241 res
= scm_apply (SCM_CDR (proc
), x
, scm_cons (env
, scm_listofnull
));
1243 if (scm_ilength (res
) <= 0)
1244 res
= scm_cons2 (SCM_IM_BEGIN
, res
, SCM_EOL
);
1247 SCM_SETCAR (x
, SCM_CAR (res
));
1248 SCM_SETCDR (x
, SCM_CDR (res
));
1254 /* scm_unmemocopy takes a memoized expression together with its
1255 * environment and rewrites it to its original form. Thus, it is the
1256 * inversion of the rewrite rules above. The procedure is not
1257 * optimized for speed. It's used in scm_iprin1 when printing the
1258 * code of a closure, in scm_procedure_source, in display_frame when
1259 * generating the source for a stackframe in a backtrace, and in
1260 * display_expression.
1263 /* We should introduce an anti-macro interface so that it is possible
1264 * to plug in transformers in both directions from other compilation
1265 * units. unmemocopy could then dispatch to anti-macro transformers.
1266 * (Those transformers could perhaps be written in slightly more
1267 * readable style... :)
1270 #define SCM_BIT8(x) (127 & SCM_UNPACK (x))
1273 unmemocopy (SCM x
, SCM env
)
1276 #ifdef DEBUG_EXTENSIONS
1279 if (SCM_NCELLP (x
) || SCM_NECONSP (x
))
1281 #ifdef DEBUG_EXTENSIONS
1282 p
= scm_whash_lookup (scm_source_whash
, x
);
1284 switch (SCM_TYP7 (x
))
1286 case SCM_BIT8(SCM_IM_AND
):
1287 ls
= z
= scm_cons (scm_sym_and
, SCM_UNSPECIFIED
);
1289 case SCM_BIT8(SCM_IM_BEGIN
):
1290 ls
= z
= scm_cons (scm_sym_begin
, SCM_UNSPECIFIED
);
1292 case SCM_BIT8(SCM_IM_CASE
):
1293 ls
= z
= scm_cons (scm_sym_case
, SCM_UNSPECIFIED
);
1295 case SCM_BIT8(SCM_IM_COND
):
1296 ls
= z
= scm_cons (scm_sym_cond
, SCM_UNSPECIFIED
);
1298 case SCM_BIT8(SCM_IM_DO
):
1299 ls
= scm_cons (scm_sym_do
, SCM_UNSPECIFIED
);
1301 case SCM_BIT8(SCM_IM_IF
):
1302 ls
= z
= scm_cons (scm_sym_if
, SCM_UNSPECIFIED
);
1304 case SCM_BIT8(SCM_IM_LET
):
1305 ls
= scm_cons (scm_sym_let
, SCM_UNSPECIFIED
);
1307 case SCM_BIT8(SCM_IM_LETREC
):
1310 ls
= scm_cons (scm_sym_letrec
, SCM_UNSPECIFIED
);
1314 f
= v
= SCM_CAR (x
);
1316 z
= EXTEND_ENV (f
, SCM_EOL
, env
);
1318 e
= scm_reverse (unmemocopy (SCM_CAR (x
),
1319 SCM_EQ_P (SCM_CAR (ls
), scm_sym_letrec
) ? z
: env
));
1322 s
= SCM_EQ_P (SCM_CAR (ls
), scm_sym_do
)
1323 ? scm_reverse (unmemocopy (SCM_CDR (SCM_CDR (SCM_CDR (x
))), env
))
1325 /* build transformed binding list */
1327 while (SCM_NIMP (v
))
1329 z
= scm_acons (SCM_CAR (v
),
1330 scm_cons (SCM_CAR (e
),
1331 SCM_EQ_P (SCM_CAR (s
), SCM_CAR (v
))
1333 : scm_cons (SCM_CAR (s
), SCM_EOL
)),
1339 z
= scm_cons (z
, SCM_UNSPECIFIED
);
1341 if (SCM_EQ_P (SCM_CAR (ls
), scm_sym_do
))
1345 SCM_SETCDR (z
, scm_cons (unmemocopy (SCM_CAR (x
), env
),
1348 x
= (SCM
) (SCM_CARLOC (SCM_CDR (x
)) - 1);
1349 /* body forms are now to be found in SCM_CDR (x)
1350 (this is how *real* code look like! :) */
1354 case SCM_BIT8(SCM_IM_LETSTAR
):
1362 env
= EXTEND_ENV (SCM_EOL
, SCM_EOL
, env
);
1365 y
= z
= scm_acons (SCM_CAR (b
),
1367 scm_cons (unmemocopy (SCM_CAR (SCM_CDR (b
)), env
), SCM_EOL
), env
),
1369 env
= EXTEND_ENV (SCM_CAR (b
), SCM_BOOL_F
, env
);
1370 b
= SCM_CDR (SCM_CDR (b
));
1373 SCM_SETCDR (y
, SCM_EOL
);
1374 ls
= scm_cons (scm_sym_let
, z
= scm_cons (y
, SCM_UNSPECIFIED
));
1379 SCM_SETCDR (z
, scm_acons (SCM_CAR (b
),
1381 scm_cons (unmemocopy (SCM_CAR (SCM_CDR (b
)), env
), SCM_EOL
), env
),
1384 env
= EXTEND_ENV (SCM_CAR (b
), SCM_BOOL_F
, env
);
1385 b
= SCM_CDR (SCM_CDR (b
));
1387 while (SCM_NIMP (b
));
1388 SCM_SETCDR (z
, SCM_EOL
);
1390 ls
= scm_cons (scm_sym_letstar
, z
= scm_cons (y
, SCM_UNSPECIFIED
));
1393 case SCM_BIT8(SCM_IM_OR
):
1394 ls
= z
= scm_cons (scm_sym_or
, SCM_UNSPECIFIED
);
1396 case SCM_BIT8(SCM_IM_LAMBDA
):
1398 ls
= scm_cons (scm_sym_lambda
,
1399 z
= scm_cons (SCM_CAR (x
), SCM_UNSPECIFIED
));
1400 env
= EXTEND_ENV (SCM_CAR (x
), SCM_EOL
, env
);
1402 case SCM_BIT8(SCM_IM_QUOTE
):
1403 ls
= z
= scm_cons (scm_sym_quote
, SCM_UNSPECIFIED
);
1405 case SCM_BIT8(SCM_IM_SET_X
):
1406 ls
= z
= scm_cons (scm_sym_set_x
, SCM_UNSPECIFIED
);
1408 case SCM_BIT8(SCM_IM_DEFINE
):
1412 ls
= scm_cons (scm_sym_define
,
1413 z
= scm_cons (n
= SCM_CAR (x
), SCM_UNSPECIFIED
));
1414 if (SCM_NNULLP (env
))
1415 SCM_SETCAR (SCM_CAR (env
), scm_cons (n
, SCM_CAR (SCM_CAR (env
))));
1418 case SCM_BIT8(SCM_MAKISYM (0)):
1422 switch (SCM_ISYMNUM (z
))
1424 case (SCM_ISYMNUM (SCM_IM_APPLY
)):
1425 ls
= z
= scm_cons (scm_sym_atapply
, SCM_UNSPECIFIED
);
1427 case (SCM_ISYMNUM (SCM_IM_CONT
)):
1428 ls
= z
= scm_cons (scm_sym_atcall_cc
, SCM_UNSPECIFIED
);
1430 case (SCM_ISYMNUM (SCM_IM_DELAY
)):
1431 ls
= z
= scm_cons (scm_sym_delay
, SCM_UNSPECIFIED
);
1435 /* appease the Sun compiler god: */ ;
1439 ls
= z
= unmemocar (scm_cons (unmemocopy (SCM_CAR (x
), env
),
1444 while (SCM_CELLP (x
= SCM_CDR (x
)) && SCM_ECONSP (x
))
1446 if (SCM_ISYMP (SCM_CAR (x
)))
1447 /* skip body markers */
1449 SCM_SETCDR (z
, unmemocar (scm_cons (unmemocopy (SCM_CAR (x
), env
),
1455 #ifdef DEBUG_EXTENSIONS
1456 if (SCM_NFALSEP (p
))
1457 scm_whash_insert (scm_source_whash
, ls
, p
);
1464 scm_unmemocopy (SCM x
, SCM env
)
1466 if (SCM_NNULLP (env
))
1467 /* Make a copy of the lowest frame to protect it from
1468 modifications by SCM_IM_DEFINE */
1469 return unmemocopy (x
, scm_cons (SCM_CAR (env
), SCM_CDR (env
)));
1471 return unmemocopy (x
, env
);
1474 #ifndef SCM_RECKLESS
1477 scm_badargsp (SCM formals
, SCM args
)
1479 while (SCM_NIMP (formals
))
1481 if (SCM_NCONSP (formals
))
1485 formals
= SCM_CDR (formals
);
1486 args
= SCM_CDR (args
);
1488 return SCM_NNULLP (args
) ? 1 : 0;
1493 scm_badformalsp (SCM closure
, int n
)
1495 SCM formals
= SCM_CAR (SCM_CODE (closure
));
1496 while (SCM_NIMP (formals
))
1498 if (SCM_NCONSP (formals
))
1503 formals
= SCM_CDR (formals
);
1510 scm_eval_args (SCM l
, SCM env
, SCM proc
)
1512 SCM results
= SCM_EOL
, *lloc
= &results
, res
;
1513 while (SCM_NIMP (l
))
1518 if (SCM_IMP (SCM_CAR (l
)))
1519 res
= SCM_EVALIM (SCM_CAR (l
), env
);
1521 res
= EVALCELLCAR (l
, env
);
1523 else if (SCM_TYP3 (l
) == scm_tc3_cons_gloc
)
1525 scm_bits_t vcell
= SCM_STRUCT_VTABLE_DATA (l
) [scm_vtable_index_vcell
];
1527 res
= SCM_CAR (l
); /* struct planted in code */
1529 res
= SCM_PACK (vcell
);
1534 res
= EVALCAR (l
, env
);
1536 *lloc
= scm_cons (res
, SCM_EOL
);
1537 lloc
= SCM_CDRLOC (*lloc
);
1544 scm_wrong_num_args (proc
);
1551 scm_eval_body (SCM code
, SCM env
)
1556 while (SCM_NNULLP (next
= SCM_CDR (next
)))
1558 if (SCM_IMP (SCM_CAR (code
)))
1560 if (SCM_ISYMP (SCM_CAR (code
)))
1562 code
= scm_m_expand_body (code
, env
);
1567 SCM_XEVAL (SCM_CAR (code
), env
);
1570 return SCM_XEVALCAR (code
, env
);
1577 /* SECTION: This code is specific for the debugging support. One
1578 * branch is read when DEVAL isn't defined, the other when DEVAL is
1584 #define SCM_APPLY scm_apply
1585 #define PREP_APPLY(proc, args)
1587 #define RETURN(x) return x;
1588 #ifdef STACK_CHECKING
1589 #ifndef NO_CEVAL_STACK_CHECKING
1590 #define EVAL_STACK_CHECKING
1597 #define SCM_CEVAL scm_deval /* Substitute all uses of scm_ceval */
1599 #define SCM_APPLY scm_dapply
1601 #define PREP_APPLY(p, l) \
1602 { ++debug.info; debug.info->a.proc = p; debug.info->a.args = l; }
1604 #define ENTER_APPLY \
1606 SCM_SET_ARGSREADY (debug);\
1607 if (CHECK_APPLY && SCM_TRAPS_P)\
1608 if (SCM_APPLY_FRAME_P || (SCM_TRACE_P && PROCTRACEP (proc)))\
1610 SCM tmp, tail = SCM_BOOL(SCM_TRACED_FRAME_P (debug)); \
1611 SCM_SET_TRACED_FRAME (debug); \
1612 if (SCM_CHEAPTRAPS_P)\
1614 tmp = scm_make_debugobj (&debug);\
1615 scm_ithrow (scm_sym_apply_frame, scm_cons2 (tmp, tail, SCM_EOL), 0);\
1620 tmp = scm_make_continuation (&first);\
1622 scm_ithrow (scm_sym_apply_frame, scm_cons2 (tmp, tail, SCM_EOL), 0);\
1627 #define RETURN(e) {proc = (e); goto exit;}
1628 #ifdef STACK_CHECKING
1629 #ifndef EVAL_STACK_CHECKING
1630 #define EVAL_STACK_CHECKING
1634 /* scm_ceval_ptr points to the currently selected evaluator.
1635 * *fixme*: Although efficiency is important here, this state variable
1636 * should probably not be a global. It should be related to the
1641 SCM (*scm_ceval_ptr
) (SCM x
, SCM env
);
1643 /* scm_last_debug_frame contains a pointer to the last debugging
1644 * information stack frame. It is accessed very often from the
1645 * debugging evaluator, so it should probably not be indirectly
1646 * addressed. Better to save and restore it from the current root at
1651 scm_debug_frame
*scm_last_debug_frame
;
1654 /* scm_debug_eframe_size is the number of slots available for pseudo
1655 * stack frames at each real stack frame.
1658 int scm_debug_eframe_size
;
1660 int scm_debug_mode
, scm_check_entry_p
, scm_check_apply_p
, scm_check_exit_p
;
1664 scm_option scm_eval_opts
[] = {
1665 { SCM_OPTION_INTEGER
, "stack", 22000, "Size of thread stacks (in machine words)." }
1668 scm_option scm_debug_opts
[] = {
1669 { SCM_OPTION_BOOLEAN
, "cheap", 1,
1670 "*Flyweight representation of the stack at traps." },
1671 { SCM_OPTION_BOOLEAN
, "breakpoints", 0, "*Check for breakpoints." },
1672 { SCM_OPTION_BOOLEAN
, "trace", 0, "*Trace mode." },
1673 { SCM_OPTION_BOOLEAN
, "procnames", 1,
1674 "Record procedure names at definition." },
1675 { SCM_OPTION_BOOLEAN
, "backwards", 0,
1676 "Display backtrace in anti-chronological order." },
1677 { SCM_OPTION_INTEGER
, "width", 79, "Maximal width of backtrace." },
1678 { SCM_OPTION_INTEGER
, "indent", 10, "Maximal indentation in backtrace." },
1679 { SCM_OPTION_INTEGER
, "frames", 3,
1680 "Maximum number of tail-recursive frames in backtrace." },
1681 { SCM_OPTION_INTEGER
, "maxdepth", 1000,
1682 "Maximal number of stored backtrace frames." },
1683 { SCM_OPTION_INTEGER
, "depth", 20, "Maximal length of printed backtrace." },
1684 { SCM_OPTION_BOOLEAN
, "backtrace", 0, "Show backtrace on error." },
1685 { SCM_OPTION_BOOLEAN
, "debug", 0, "Use the debugging evaluator." },
1686 { SCM_OPTION_INTEGER
, "stack", 20000, "Stack size limit (measured in words; 0 = no check)." }
1689 scm_option scm_evaluator_trap_table
[] = {
1690 { SCM_OPTION_BOOLEAN
, "traps", 0, "Enable evaluator traps." },
1691 { SCM_OPTION_BOOLEAN
, "enter-frame", 0, "Trap when eval enters new frame." },
1692 { SCM_OPTION_BOOLEAN
, "apply-frame", 0, "Trap when entering apply." },
1693 { SCM_OPTION_BOOLEAN
, "exit-frame", 0, "Trap when exiting eval or apply." }
1696 SCM_DEFINE (scm_eval_options_interface
, "eval-options-interface", 0, 1, 0,
1698 "Option interface for the evaluation options. Instead of using\n"
1699 "this procedure directly, use the procedures @code{eval-enable},\n"
1700 "@code{eval-disable}, @code{eval-set!} and @var{eval-options}.")
1701 #define FUNC_NAME s_scm_eval_options_interface
1705 ans
= scm_options (setting
,
1709 scm_eval_stack
= SCM_EVAL_STACK
* sizeof (void *);
1715 SCM_DEFINE (scm_evaluator_traps
, "evaluator-traps-interface", 0, 1, 0,
1717 "Option interface for the evaluator trap options.")
1718 #define FUNC_NAME s_scm_evaluator_traps
1722 ans
= scm_options (setting
,
1723 scm_evaluator_trap_table
,
1724 SCM_N_EVALUATOR_TRAPS
,
1726 SCM_RESET_DEBUG_MODE
;
1733 scm_deval_args (SCM l
, SCM env
, SCM proc
, SCM
*lloc
)
1735 SCM
*results
= lloc
, res
;
1736 while (SCM_NIMP (l
))
1741 if (SCM_IMP (SCM_CAR (l
)))
1742 res
= SCM_EVALIM (SCM_CAR (l
), env
);
1744 res
= EVALCELLCAR (l
, env
);
1746 else if (SCM_TYP3 (l
) == scm_tc3_cons_gloc
)
1748 scm_bits_t vcell
= SCM_STRUCT_VTABLE_DATA (l
) [scm_vtable_index_vcell
];
1750 res
= SCM_CAR (l
); /* struct planted in code */
1752 res
= SCM_PACK (vcell
);
1757 res
= EVALCAR (l
, env
);
1759 *lloc
= scm_cons (res
, SCM_EOL
);
1760 lloc
= SCM_CDRLOC (*lloc
);
1767 scm_wrong_num_args (proc
);
1776 /* SECTION: Some local definitions for the evaluator.
1779 /* Update the toplevel environment frame ENV so that it refers to the
1782 #define UPDATE_TOPLEVEL_ENV(env) \
1784 SCM p = scm_current_module_lookup_closure (); \
1785 if (p != SCM_CAR(env)) \
1786 env = scm_top_level_env (p); \
1790 #define CHECK_EQVISH(A,B) (SCM_EQ_P ((A), (B)) || (SCM_NFALSEP (scm_eqv_p ((A), (B)))))
1793 #define BUILTIN_RPASUBR /* Handle rpsubrs and asubrs without calling apply */
1795 /* SECTION: This is the evaluator. Like any real monster, it has
1796 * three heads. This code is compiled twice.
1802 scm_ceval (SCM x
, SCM env
)
1808 scm_deval (SCM x
, SCM env
)
1813 SCM_CEVAL (SCM x
, SCM env
)
1822 scm_debug_frame debug
;
1823 scm_debug_info
*debug_info_end
;
1824 debug
.prev
= scm_last_debug_frame
;
1825 debug
.status
= scm_debug_eframe_size
;
1827 * The debug.vect contains twice as much scm_debug_info frames as the
1828 * user has specified with (debug-set! frames <n>).
1830 * Even frames are eval frames, odd frames are apply frames.
1832 debug
.vect
= (scm_debug_info
*) alloca (scm_debug_eframe_size
1833 * sizeof (debug
.vect
[0]));
1834 debug
.info
= debug
.vect
;
1835 debug_info_end
= debug
.vect
+ scm_debug_eframe_size
;
1836 scm_last_debug_frame
= &debug
;
1838 #ifdef EVAL_STACK_CHECKING
1839 if (scm_stack_checking_enabled_p
1840 && SCM_STACK_OVERFLOW_P ((SCM_STACKITEM
*) &proc
))
1843 debug
.info
->e
.exp
= x
;
1844 debug
.info
->e
.env
= env
;
1846 scm_report_stack_overflow ();
1853 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
1856 SCM_CLEAR_ARGSREADY (debug
);
1857 if (SCM_OVERFLOWP (debug
))
1860 * In theory, this should be the only place where it is necessary to
1861 * check for space in debug.vect since both eval frames and
1862 * available space are even.
1864 * For this to be the case, however, it is necessary that primitive
1865 * special forms which jump back to `loop', `begin' or some similar
1866 * label call PREP_APPLY. A convenient way to do this is to jump to
1867 * `loopnoap' or `cdrxnoap'.
1869 else if (++debug
.info
>= debug_info_end
)
1871 SCM_SET_OVERFLOW (debug
);
1875 debug
.info
->e
.exp
= x
;
1876 debug
.info
->e
.env
= env
;
1877 if (CHECK_ENTRY
&& SCM_TRAPS_P
)
1878 if (SCM_ENTER_FRAME_P
|| (SCM_BREAKPOINTS_P
&& SRCBRKP (x
)))
1880 SCM tail
= SCM_BOOL(SCM_TAILRECP (debug
));
1881 SCM_SET_TAILREC (debug
);
1882 if (SCM_CHEAPTRAPS_P
)
1883 t
.arg1
= scm_make_debugobj (&debug
);
1887 SCM val
= scm_make_continuation (&first
);
1899 /* This gives the possibility for the debugger to
1900 modify the source expression before evaluation. */
1904 scm_ithrow (scm_sym_enter_frame
,
1905 scm_cons2 (t
.arg1
, tail
,
1906 scm_cons (scm_unmemocopy (x
, env
), SCM_EOL
)),
1910 #if defined (USE_THREADS) || defined (DEVAL)
1914 switch (SCM_TYP7 (x
))
1916 case scm_tc7_symbol
:
1917 /* Only happens when called at top level.
1919 x
= scm_cons (x
, SCM_UNDEFINED
);
1922 case SCM_BIT8(SCM_IM_AND
):
1925 while (SCM_NNULLP (t
.arg1
= SCM_CDR (t
.arg1
)))
1926 if (SCM_FALSEP (EVALCAR (x
, env
)))
1928 RETURN (SCM_BOOL_F
);
1932 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
1935 case SCM_BIT8(SCM_IM_BEGIN
):
1936 /* (currently unused)
1938 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
1939 /* (currently unused)
1944 /* If we are on toplevel with a lookup closure, we need to sync
1945 with the current module. */
1946 if (SCM_CONSP(env
) && !SCM_CONSP(SCM_CAR(env
)))
1949 UPDATE_TOPLEVEL_ENV (env
);
1950 while (SCM_NNULLP (t
.arg1
= SCM_CDR (t
.arg1
)))
1954 UPDATE_TOPLEVEL_ENV (env
);
1959 goto nontoplevel_begin
;
1961 nontoplevel_cdrxnoap
:
1962 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
1963 nontoplevel_cdrxbegin
:
1967 while (SCM_NNULLP (t
.arg1
= SCM_CDR (t
.arg1
)))
1969 if (SCM_IMP (SCM_CAR (x
)))
1971 if (SCM_ISYMP (SCM_CAR (x
)))
1973 x
= scm_m_expand_body (x
, env
);
1974 goto nontoplevel_begin
;
1977 SCM_EVALIM2 (SCM_CAR(x
));
1980 SCM_CEVAL (SCM_CAR (x
), env
);
1984 carloop
: /* scm_eval car of last form in list */
1985 if (SCM_NCELLP (SCM_CAR (x
)))
1988 RETURN (SCM_IMP (x
) ? SCM_EVALIM (x
, env
) : SCM_GLOC_VAL (x
))
1991 if (SCM_SYMBOLP (SCM_CAR (x
)))
1994 RETURN (*scm_lookupcar (x
, env
, 1))
1998 goto loop
; /* tail recurse */
2001 case SCM_BIT8(SCM_IM_CASE
):
2003 t
.arg1
= EVALCAR (x
, env
);
2004 while (SCM_NIMP (x
= SCM_CDR (x
)))
2007 if (SCM_EQ_P (scm_sym_else
, SCM_CAR (proc
)))
2010 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
2013 proc
= SCM_CAR (proc
);
2014 while (SCM_NIMP (proc
))
2016 if (CHECK_EQVISH (SCM_CAR (proc
), t
.arg1
))
2018 x
= SCM_CDR (SCM_CAR (x
));
2019 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
2022 proc
= SCM_CDR (proc
);
2025 RETURN (SCM_UNSPECIFIED
)
2028 case SCM_BIT8(SCM_IM_COND
):
2029 while (SCM_NIMP (x
= SCM_CDR (x
)))
2032 t
.arg1
= EVALCAR (proc
, env
);
2033 if (SCM_NFALSEP (t
.arg1
))
2040 if (! SCM_EQ_P (scm_sym_arrow
, SCM_CAR (x
)))
2042 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
2046 proc
= EVALCAR (proc
, env
);
2047 SCM_ASRTGO (SCM_NIMP (proc
), badfun
);
2048 PREP_APPLY (proc
, scm_cons (t
.arg1
, SCM_EOL
));
2050 if (SCM_CLOSUREP(proc
) && scm_badformalsp (proc
, 1))
2051 goto umwrongnumargs
;
2055 RETURN (SCM_UNSPECIFIED
)
2058 case SCM_BIT8(SCM_IM_DO
):
2060 proc
= SCM_CAR (SCM_CDR (x
)); /* inits */
2061 t
.arg1
= SCM_EOL
; /* values */
2062 while (SCM_NIMP (proc
))
2064 t
.arg1
= scm_cons (EVALCAR (proc
, env
), t
.arg1
);
2065 proc
= SCM_CDR (proc
);
2067 env
= EXTEND_ENV (SCM_CAR (x
), t
.arg1
, env
);
2068 x
= SCM_CDR (SCM_CDR (x
));
2069 while (proc
= SCM_CAR (x
), SCM_FALSEP (EVALCAR (proc
, env
)))
2071 for (proc
= SCM_CADR (x
); SCM_NIMP (proc
); proc
= SCM_CDR (proc
))
2073 t
.arg1
= SCM_CAR (proc
); /* body */
2074 SIDEVAL (t
.arg1
, env
);
2076 for (t
.arg1
= SCM_EOL
, proc
= SCM_CDDR (x
);
2078 proc
= SCM_CDR (proc
))
2079 t
.arg1
= scm_cons (EVALCAR (proc
, env
), t
.arg1
); /* steps */
2080 env
= EXTEND_ENV (SCM_CAR (SCM_CAR (env
)), t
.arg1
, SCM_CDR (env
));
2084 RETURN (SCM_UNSPECIFIED
);
2085 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
2086 goto nontoplevel_begin
;
2089 case SCM_BIT8(SCM_IM_IF
):
2091 if (SCM_NFALSEP (EVALCAR (x
, env
)))
2093 else if (SCM_IMP (x
= SCM_CDR (SCM_CDR (x
))))
2095 RETURN (SCM_UNSPECIFIED
);
2097 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
2101 case SCM_BIT8(SCM_IM_LET
):
2103 proc
= SCM_CAR (SCM_CDR (x
));
2107 t
.arg1
= scm_cons (EVALCAR (proc
, env
), t
.arg1
);
2109 while (SCM_NIMP (proc
= SCM_CDR (proc
)));
2110 env
= EXTEND_ENV (SCM_CAR (x
), t
.arg1
, env
);
2112 goto nontoplevel_cdrxnoap
;
2115 case SCM_BIT8(SCM_IM_LETREC
):
2117 env
= EXTEND_ENV (SCM_CAR (x
), scm_undefineds
, env
);
2123 t
.arg1
= scm_cons (EVALCAR (proc
, env
), t
.arg1
);
2125 while (SCM_NIMP (proc
= SCM_CDR (proc
)));
2126 SCM_SETCDR (SCM_CAR (env
), t
.arg1
);
2127 goto nontoplevel_cdrxnoap
;
2130 case SCM_BIT8(SCM_IM_LETSTAR
):
2135 env
= EXTEND_ENV (SCM_EOL
, SCM_EOL
, env
);
2136 goto nontoplevel_cdrxnoap
;
2140 t
.arg1
= SCM_CAR (proc
);
2141 proc
= SCM_CDR (proc
);
2142 env
= EXTEND_ENV (t
.arg1
, EVALCAR (proc
, env
), env
);
2144 while (SCM_NIMP (proc
= SCM_CDR (proc
)));
2145 goto nontoplevel_cdrxnoap
;
2147 case SCM_BIT8(SCM_IM_OR
):
2150 while (SCM_NNULLP (t
.arg1
= SCM_CDR (t
.arg1
)))
2152 x
= EVALCAR (x
, env
);
2153 if (SCM_NFALSEP (x
))
2159 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
2163 case SCM_BIT8(SCM_IM_LAMBDA
):
2164 RETURN (scm_closure (SCM_CDR (x
), env
));
2167 case SCM_BIT8(SCM_IM_QUOTE
):
2168 RETURN (SCM_CAR (SCM_CDR (x
)));
2171 case SCM_BIT8(SCM_IM_SET_X
):
2174 switch (SCM_ITAG3 (proc
))
2177 t
.lloc
= scm_lookupcar (x
, env
, 1);
2179 case scm_tc3_cons_gloc
:
2180 t
.lloc
= SCM_GLOC_VAL_LOC (proc
);
2182 #ifdef MEMOIZE_LOCALS
2184 t
.lloc
= scm_ilookup (proc
, env
);
2189 *t
.lloc
= EVALCAR (x
, env
);
2193 RETURN (SCM_UNSPECIFIED
);
2197 case SCM_BIT8(SCM_IM_DEFINE
): /* only for internal defines */
2198 scm_misc_error (NULL
, "Bad define placement", SCM_EOL
);
2200 /* new syntactic forms go here. */
2201 case SCM_BIT8(SCM_MAKISYM (0)):
2203 SCM_ASRTGO (SCM_ISYMP (proc
), badfun
);
2204 switch SCM_ISYMNUM (proc
)
2206 case (SCM_ISYMNUM (SCM_IM_APPLY
)):
2208 proc
= EVALCAR (proc
, env
);
2209 SCM_ASRTGO (SCM_NIMP (proc
), badfun
);
2210 if (SCM_CLOSUREP (proc
))
2213 PREP_APPLY (proc
, SCM_EOL
);
2214 t
.arg1
= SCM_CDR (SCM_CDR (x
));
2215 t
.arg1
= EVALCAR (t
.arg1
, env
);
2217 debug
.info
->a
.args
= t
.arg1
;
2219 #ifndef SCM_RECKLESS
2220 if (scm_badargsp (SCM_CAR (SCM_CODE (proc
)), t
.arg1
))
2224 /* Copy argument list */
2225 if (SCM_IMP (t
.arg1
))
2229 argl
= tl
= scm_cons (SCM_CAR (t
.arg1
), SCM_UNSPECIFIED
);
2230 while (SCM_NIMP (t
.arg1
= SCM_CDR (t
.arg1
))
2231 && SCM_CONSP (t
.arg1
))
2233 SCM_SETCDR (tl
, scm_cons (SCM_CAR (t
.arg1
),
2237 SCM_SETCDR (tl
, t
.arg1
);
2240 env
= EXTEND_ENV (SCM_CAR (SCM_CODE (proc
)), argl
, SCM_ENV (proc
));
2241 x
= SCM_CODE (proc
);
2242 goto nontoplevel_cdrxbegin
;
2247 case (SCM_ISYMNUM (SCM_IM_CONT
)):
2250 SCM val
= scm_make_continuation (&first
);
2258 proc
= evalcar (proc
, env
);
2259 SCM_ASRTGO (SCM_NIMP (proc
), badfun
);
2260 PREP_APPLY (proc
, scm_cons (t
.arg1
, SCM_EOL
));
2262 if (SCM_CLOSUREP(proc
) && scm_badformalsp (proc
, 1))
2263 goto umwrongnumargs
;
2266 case (SCM_ISYMNUM (SCM_IM_DELAY
)):
2267 RETURN (scm_makprom (scm_closure (SCM_CDR (x
), env
)))
2269 case (SCM_ISYMNUM (SCM_IM_DISPATCH
)):
2270 proc
= SCM_CADR (x
); /* unevaluated operands */
2271 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
2273 arg2
= *scm_ilookup (proc
, env
);
2274 else if (SCM_NCONSP (proc
))
2276 if (SCM_NCELLP (proc
))
2277 arg2
= SCM_GLOC_VAL (proc
);
2279 arg2
= *scm_lookupcar (SCM_CDR (x
), env
, 1);
2283 arg2
= scm_cons (EVALCAR (proc
, env
), SCM_EOL
);
2284 t
.lloc
= SCM_CDRLOC (arg2
);
2285 while (SCM_NIMP (proc
= SCM_CDR (proc
)))
2287 *t
.lloc
= scm_cons (EVALCAR (proc
, env
), SCM_EOL
);
2288 t
.lloc
= SCM_CDRLOC (*t
.lloc
);
2293 /* The type dispatch code is duplicated here
2294 * (c.f. objects.c:scm_mcache_compute_cmethod) since that
2295 * cuts down execution time for type dispatch to 50%.
2298 int i
, n
, end
, mask
;
2299 SCM z
= SCM_CDDR (x
);
2300 n
= SCM_INUM (SCM_CAR (z
)); /* maximum number of specializers */
2301 proc
= SCM_CADR (z
);
2303 if (SCM_NIMP (proc
))
2305 /* Prepare for linear search */
2308 end
= SCM_VECTOR_LENGTH (proc
);
2312 /* Compute a hash value */
2313 int hashset
= SCM_INUM (proc
);
2315 mask
= SCM_INUM (SCM_CAR (z
= SCM_CDDR (z
)));
2316 proc
= SCM_CADR (z
);
2319 if (SCM_NIMP (t
.arg1
))
2322 i
+= SCM_STRUCT_DATA (scm_class_of (SCM_CAR (t
.arg1
)))
2323 [scm_si_hashsets
+ hashset
];
2324 t
.arg1
= SCM_CDR (t
.arg1
);
2326 while (j
-- && SCM_NIMP (t
.arg1
));
2331 /* Search for match */
2335 z
= SCM_VELTS (proc
)[i
];
2336 t
.arg1
= arg2
; /* list of arguments */
2337 if (SCM_NIMP (t
.arg1
))
2340 /* More arguments than specifiers => CLASS != ENV */
2341 if (! SCM_EQ_P (scm_class_of (SCM_CAR (t
.arg1
)), SCM_CAR (z
)))
2343 t
.arg1
= SCM_CDR (t
.arg1
);
2346 while (j
-- && SCM_NIMP (t
.arg1
));
2347 /* Fewer arguments than specifiers => CAR != ENV */
2348 if (!(SCM_IMP (SCM_CAR (z
)) || SCM_CONSP (SCM_CAR (z
))))
2351 env
= EXTEND_ENV (SCM_CAR (SCM_CMETHOD_CODE (z
)),
2353 SCM_CMETHOD_ENV (z
));
2354 x
= SCM_CMETHOD_CODE (z
);
2355 goto nontoplevel_cdrxbegin
;
2360 z
= scm_memoize_method (x
, arg2
);
2364 case (SCM_ISYMNUM (SCM_IM_SLOT_REF
)):
2366 t
.arg1
= EVALCAR (x
, env
);
2367 RETURN (SCM_PACK (SCM_STRUCT_DATA (t
.arg1
) [SCM_INUM (SCM_CADR (x
))]))
2369 case (SCM_ISYMNUM (SCM_IM_SLOT_SET_X
)):
2371 t
.arg1
= EVALCAR (x
, env
);
2374 SCM_STRUCT_DATA (t
.arg1
) [SCM_INUM (SCM_CAR (x
))]
2375 = SCM_UNPACK (EVALCAR (proc
, env
));
2376 RETURN (SCM_UNSPECIFIED
)
2378 case (SCM_ISYMNUM (SCM_IM_NIL_COND
)):
2380 while (SCM_NIMP (x
= SCM_CDR (proc
)))
2382 if (!(SCM_FALSEP (t
.arg1
= EVALCAR (proc
, env
))
2383 || SCM_EQ_P (t
.arg1
, scm_lisp_nil
)))
2385 if (SCM_EQ_P (SCM_CAR (x
), SCM_UNSPECIFIED
))
2387 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
2393 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
2396 case (SCM_ISYMNUM (SCM_IM_NIL_IFY
)):
2398 RETURN ((SCM_FALSEP (proc
= EVALCAR (x
, env
)) || SCM_NULLP (proc
))
2402 case (SCM_ISYMNUM (SCM_IM_T_IFY
)):
2404 RETURN (SCM_NFALSEP (EVALCAR (x
, env
)) ? scm_lisp_t
: scm_lisp_nil
)
2406 case (SCM_ISYMNUM (SCM_IM_0_COND
)):
2408 while (SCM_NIMP (x
= SCM_CDR (proc
)))
2410 if (!(SCM_FALSEP (t
.arg1
= EVALCAR (proc
, env
))
2411 || SCM_EQ_P (t
.arg1
, SCM_INUM0
)))
2413 if (SCM_EQ_P (SCM_CAR (x
), SCM_UNSPECIFIED
))
2415 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
2421 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
2424 case (SCM_ISYMNUM (SCM_IM_0_IFY
)):
2426 RETURN (SCM_FALSEP (proc
= EVALCAR (x
, env
))
2430 case (SCM_ISYMNUM (SCM_IM_1_IFY
)):
2432 RETURN (SCM_NFALSEP (EVALCAR (x
, env
))
2436 case (SCM_ISYMNUM (SCM_IM_BIND
)):
2439 t
.arg1
= SCM_CAR (x
);
2440 arg2
= SCM_CDAR (env
);
2441 while (SCM_NIMP (arg2
))
2443 proc
= SCM_GLOC_VAL (SCM_CAR (t
.arg1
));
2444 SCM_SETCDR (SCM_PACK (SCM_UNPACK (SCM_CAR (t
.arg1
)) - 1L),
2446 SCM_SETCAR (arg2
, proc
);
2447 t
.arg1
= SCM_CDR (t
.arg1
);
2448 arg2
= SCM_CDR (arg2
);
2450 t
.arg1
= SCM_CAR (x
);
2451 scm_dynwinds
= scm_acons (t
.arg1
, SCM_CDAR (env
), scm_dynwinds
);
2453 arg2
= x
= SCM_CDR (x
);
2454 while (SCM_NNULLP (arg2
= SCM_CDR (arg2
)))
2456 SIDEVAL (SCM_CAR (x
), env
);
2459 proc
= EVALCAR (x
, env
);
2461 scm_dynwinds
= SCM_CDR (scm_dynwinds
);
2462 arg2
= SCM_CDAR (env
);
2463 while (SCM_NIMP (arg2
))
2465 SCM_SETCDR (SCM_PACK (SCM_UNPACK (SCM_CAR (t
.arg1
)) - 1L),
2467 t
.arg1
= SCM_CDR (t
.arg1
);
2468 arg2
= SCM_CDR (arg2
);
2480 /* scm_everr (x, env,...) */
2481 scm_misc_error (NULL
,
2482 "Wrong type to apply: ~S",
2483 scm_listify (proc
, SCM_UNDEFINED
));
2484 case scm_tc7_vector
:
2488 case scm_tc7_byvect
:
2495 #ifdef HAVE_LONG_LONGS
2496 case scm_tc7_llvect
:
2499 case scm_tc7_string
:
2500 case scm_tc7_substring
:
2502 case scm_tcs_closures
:
2508 #ifdef MEMOIZE_LOCALS
2509 case SCM_BIT8(SCM_ILOC00
):
2510 proc
= *scm_ilookup (SCM_CAR (x
), env
);
2511 SCM_ASRTGO (SCM_NIMP (proc
), badfun
);
2512 #ifndef SCM_RECKLESS
2518 #endif /* ifdef MEMOIZE_LOCALS */
2521 case scm_tcs_cons_gloc
: {
2522 scm_bits_t vcell
= SCM_STRUCT_VTABLE_DATA (x
) [scm_vtable_index_vcell
];
2524 /* This is a struct implanted in the code, not a gloc. */
2527 proc
= SCM_PACK (vcell
);
2528 SCM_ASRTGO (SCM_NIMP (proc
), badfun
);
2529 #ifndef SCM_RECKLESS
2538 case scm_tcs_cons_nimcar
:
2539 if (SCM_SYMBOLP (SCM_CAR (x
)))
2542 t
.lloc
= scm_lookupcar1 (x
, env
, 1);
2545 /* we have lost the race, start again. */
2550 proc
= *scm_lookupcar (x
, env
, 1);
2558 if (scm_tc16_macro
== SCM_TYP16 (proc
))
2564 /* Set a flag during macro expansion so that macro
2565 application frames can be deleted from the backtrace. */
2566 SCM_SET_MACROEXP (debug
);
2568 t
.arg1
= SCM_APPLY (SCM_CDR (proc
), x
,
2569 scm_cons (env
, scm_listofnull
));
2572 SCM_CLEAR_MACROEXP (debug
);
2574 switch (SCM_CELL_WORD_0 (proc
) >> 16)
2577 if (scm_ilength (t
.arg1
) <= 0)
2578 t
.arg1
= scm_cons2 (SCM_IM_BEGIN
, t
.arg1
, SCM_EOL
);
2580 if (!SCM_CLOSUREP (SCM_CDR (proc
)))
2583 SCM_SETCAR (x
, SCM_CAR (t
.arg1
));
2584 SCM_SETCDR (x
, SCM_CDR (t
.arg1
));
2588 /* Prevent memoizing of debug info expression. */
2589 debug
.info
->e
.exp
= scm_cons_source (debug
.info
->e
.exp
,
2594 SCM_SETCAR (x
, SCM_CAR (t
.arg1
));
2595 SCM_SETCDR (x
, SCM_CDR (t
.arg1
));
2599 if (SCM_NIMP (x
= t
.arg1
))
2607 proc
= SCM_CEVAL (SCM_CAR (x
), env
);
2608 SCM_ASRTGO (SCM_NIMP (proc
), badfun
);
2609 #ifndef SCM_RECKLESS
2613 if (SCM_CLOSUREP (proc
))
2615 arg2
= SCM_CAR (SCM_CODE (proc
));
2616 t
.arg1
= SCM_CDR (x
);
2617 while (SCM_NIMP (arg2
))
2619 if (SCM_NCONSP (arg2
))
2621 if (SCM_IMP (t
.arg1
))
2622 goto umwrongnumargs
;
2623 arg2
= SCM_CDR (arg2
);
2624 t
.arg1
= SCM_CDR (t
.arg1
);
2626 if (SCM_NNULLP (t
.arg1
))
2627 goto umwrongnumargs
;
2629 else if (scm_tc16_macro
== SCM_TYP16 (proc
))
2630 goto handle_a_macro
;
2636 PREP_APPLY (proc
, SCM_EOL
);
2637 if (SCM_NULLP (SCM_CDR (x
))) {
2640 switch (SCM_TYP7 (proc
))
2641 { /* no arguments given */
2642 case scm_tc7_subr_0
:
2643 RETURN (SCM_SUBRF (proc
) ());
2644 case scm_tc7_subr_1o
:
2645 RETURN (SCM_SUBRF (proc
) (SCM_UNDEFINED
));
2647 RETURN (SCM_SUBRF (proc
) (SCM_EOL
));
2648 case scm_tc7_rpsubr
:
2649 RETURN (SCM_BOOL_T
);
2651 RETURN (SCM_SUBRF (proc
) (SCM_UNDEFINED
, SCM_UNDEFINED
));
2653 if (!SCM_SMOB_APPLICABLE_P (proc
))
2655 RETURN (SCM_SMOB_APPLY_0 (proc
));
2658 proc
= SCM_CCLO_SUBR (proc
);
2660 debug
.info
->a
.proc
= proc
;
2661 debug
.info
->a
.args
= scm_cons (t
.arg1
, SCM_EOL
);
2665 proc
= SCM_PROCEDURE (proc
);
2667 debug
.info
->a
.proc
= proc
;
2669 if (!SCM_CLOSUREP (proc
))
2671 if (scm_badformalsp (proc
, 0))
2672 goto umwrongnumargs
;
2673 case scm_tcs_closures
:
2674 x
= SCM_CODE (proc
);
2675 env
= EXTEND_ENV (SCM_CAR (x
), SCM_EOL
, SCM_ENV (proc
));
2676 goto nontoplevel_cdrxbegin
;
2677 case scm_tcs_cons_gloc
:
2678 if (SCM_OBJ_CLASS_FLAGS (proc
) & SCM_CLASSF_PURE_GENERIC
)
2680 x
= SCM_ENTITY_PROCEDURE (proc
);
2684 else if (!SCM_I_OPERATORP (proc
))
2689 proc
= (SCM_I_ENTITYP (proc
)
2690 ? SCM_ENTITY_PROCEDURE (proc
)
2691 : SCM_OPERATOR_PROCEDURE (proc
));
2693 debug
.info
->a
.proc
= proc
;
2694 debug
.info
->a
.args
= scm_cons (t
.arg1
, SCM_EOL
);
2696 if (SCM_NIMP (proc
))
2701 case scm_tc7_subr_1
:
2702 case scm_tc7_subr_2
:
2703 case scm_tc7_subr_2o
:
2705 case scm_tc7_subr_3
:
2706 case scm_tc7_lsubr_2
:
2710 /* scm_everr (x, env,...) */
2711 scm_wrong_num_args (proc
);
2713 /* handle macros here */
2718 /* must handle macros by here */
2723 else if (SCM_CONSP (x
))
2725 if (SCM_IMP (SCM_CAR (x
)))
2726 t
.arg1
= SCM_EVALIM (SCM_CAR (x
), env
);
2728 t
.arg1
= EVALCELLCAR (x
, env
);
2730 else if (SCM_TYP3 (x
) == scm_tc3_cons_gloc
)
2732 scm_bits_t vcell
= SCM_STRUCT_VTABLE_DATA (x
) [scm_vtable_index_vcell
];
2734 t
.arg1
= SCM_CAR (x
); /* struct planted in code */
2736 t
.arg1
= SCM_PACK (vcell
);
2741 t
.arg1
= EVALCAR (x
, env
);
2744 debug
.info
->a
.args
= scm_cons (t
.arg1
, SCM_EOL
);
2751 switch (SCM_TYP7 (proc
))
2752 { /* have one argument in t.arg1 */
2753 case scm_tc7_subr_2o
:
2754 RETURN (SCM_SUBRF (proc
) (t
.arg1
, SCM_UNDEFINED
));
2755 case scm_tc7_subr_1
:
2756 case scm_tc7_subr_1o
:
2757 RETURN (SCM_SUBRF (proc
) (t
.arg1
));
2759 if (SCM_SUBRF (proc
))
2761 if (SCM_INUMP (t
.arg1
))
2763 RETURN (scm_make_real (SCM_DSUBRF (proc
) ((double) SCM_INUM (t
.arg1
))));
2765 SCM_ASRTGO (SCM_NIMP (t
.arg1
), floerr
);
2766 if (SCM_REALP (t
.arg1
))
2768 RETURN (scm_make_real (SCM_DSUBRF (proc
) (SCM_REAL_VALUE (t
.arg1
))));
2771 if (SCM_BIGP (t
.arg1
))
2773 RETURN (scm_make_real (SCM_DSUBRF (proc
) (scm_big2dbl (t
.arg1
))));
2777 SCM_WTA_DISPATCH_1 (*SCM_SUBR_GENERIC (proc
), t
.arg1
,
2778 SCM_ARG1
, SCM_SYMBOL_CHARS (SCM_SNAME (proc
)));
2780 proc
= SCM_SNAME (proc
);
2782 char *chrs
= SCM_SYMBOL_CHARS (proc
) + SCM_SYMBOL_LENGTH (proc
) - 1;
2783 while ('c' != *--chrs
)
2785 SCM_ASSERT (SCM_CONSP (t
.arg1
),
2786 t
.arg1
, SCM_ARG1
, SCM_SYMBOL_CHARS (proc
));
2787 t
.arg1
= ('a' == *chrs
) ? SCM_CAR (t
.arg1
) : SCM_CDR (t
.arg1
);
2791 case scm_tc7_rpsubr
:
2792 RETURN (SCM_BOOL_T
);
2794 RETURN (SCM_SUBRF (proc
) (t
.arg1
, SCM_UNDEFINED
));
2797 RETURN (SCM_SUBRF (proc
) (debug
.info
->a
.args
))
2799 RETURN (SCM_SUBRF (proc
) (scm_cons (t
.arg1
, SCM_EOL
)));
2802 if (!SCM_SMOB_APPLICABLE_P (proc
))
2804 RETURN (SCM_SMOB_APPLY_1 (proc
, t
.arg1
));
2808 proc
= SCM_CCLO_SUBR (proc
);
2810 debug
.info
->a
.args
= scm_cons (t
.arg1
, debug
.info
->a
.args
);
2811 debug
.info
->a
.proc
= proc
;
2815 proc
= SCM_PROCEDURE (proc
);
2817 debug
.info
->a
.proc
= proc
;
2819 if (!SCM_CLOSUREP (proc
))
2821 if (scm_badformalsp (proc
, 1))
2822 goto umwrongnumargs
;
2823 case scm_tcs_closures
:
2825 x
= SCM_CODE (proc
);
2827 env
= EXTEND_ENV (SCM_CAR (x
), debug
.info
->a
.args
, SCM_ENV (proc
));
2829 env
= EXTEND_ENV (SCM_CAR (x
), scm_cons (t
.arg1
, SCM_EOL
), SCM_ENV (proc
));
2831 goto nontoplevel_cdrxbegin
;
2832 case scm_tcs_cons_gloc
:
2833 if (SCM_OBJ_CLASS_FLAGS (proc
) & SCM_CLASSF_PURE_GENERIC
)
2835 x
= SCM_ENTITY_PROCEDURE (proc
);
2837 arg2
= debug
.info
->a
.args
;
2839 arg2
= scm_cons (t
.arg1
, SCM_EOL
);
2843 else if (!SCM_I_OPERATORP (proc
))
2849 proc
= (SCM_I_ENTITYP (proc
)
2850 ? SCM_ENTITY_PROCEDURE (proc
)
2851 : SCM_OPERATOR_PROCEDURE (proc
));
2853 debug
.info
->a
.args
= scm_cons (t
.arg1
, debug
.info
->a
.args
);
2854 debug
.info
->a
.proc
= proc
;
2856 if (SCM_NIMP (proc
))
2861 case scm_tc7_subr_2
:
2862 case scm_tc7_subr_0
:
2863 case scm_tc7_subr_3
:
2864 case scm_tc7_lsubr_2
:
2873 else if (SCM_CONSP (x
))
2875 if (SCM_IMP (SCM_CAR (x
)))
2876 arg2
= SCM_EVALIM (SCM_CAR (x
), env
);
2878 arg2
= EVALCELLCAR (x
, env
);
2880 else if (SCM_TYP3 (x
) == scm_tc3_cons_gloc
)
2882 scm_bits_t vcell
= SCM_STRUCT_VTABLE_DATA (x
) [scm_vtable_index_vcell
];
2884 arg2
= SCM_CAR (x
); /* struct planted in code */
2886 arg2
= SCM_PACK (vcell
);
2891 arg2
= EVALCAR (x
, env
);
2893 { /* have two or more arguments */
2895 debug
.info
->a
.args
= scm_cons2 (t
.arg1
, arg2
, SCM_EOL
);
2898 if (SCM_NULLP (x
)) {
2901 switch (SCM_TYP7 (proc
))
2902 { /* have two arguments */
2903 case scm_tc7_subr_2
:
2904 case scm_tc7_subr_2o
:
2905 RETURN (SCM_SUBRF (proc
) (t
.arg1
, arg2
));
2908 RETURN (SCM_SUBRF (proc
) (debug
.info
->a
.args
))
2910 RETURN (SCM_SUBRF (proc
) (scm_cons2 (t
.arg1
, arg2
, SCM_EOL
)));
2912 case scm_tc7_lsubr_2
:
2913 RETURN (SCM_SUBRF (proc
) (t
.arg1
, arg2
, SCM_EOL
));
2914 case scm_tc7_rpsubr
:
2916 RETURN (SCM_SUBRF (proc
) (t
.arg1
, arg2
));
2918 if (!SCM_SMOB_APPLICABLE_P (proc
))
2920 RETURN (SCM_SMOB_APPLY_2 (proc
, t
.arg1
, arg2
));
2924 RETURN (SCM_APPLY (SCM_CCLO_SUBR (proc
),
2925 scm_cons (proc
, debug
.info
->a
.args
),
2928 RETURN (SCM_APPLY (SCM_CCLO_SUBR (proc
),
2929 scm_cons2 (proc
, t
.arg1
,
2936 case scm_tcs_cons_gloc
:
2937 if (SCM_OBJ_CLASS_FLAGS (proc
) & SCM_CLASSF_PURE_GENERIC
)
2939 x
= SCM_ENTITY_PROCEDURE (proc
);
2941 arg2
= debug
.info
->a
.args
;
2943 arg2
= scm_cons2 (t
.arg1
, arg2
, SCM_EOL
);
2947 else if (!SCM_I_OPERATORP (proc
))
2953 RETURN (SCM_APPLY (SCM_I_ENTITYP (proc
)
2954 ? SCM_ENTITY_PROCEDURE (proc
)
2955 : SCM_OPERATOR_PROCEDURE (proc
),
2956 scm_cons (proc
, debug
.info
->a
.args
),
2959 RETURN (SCM_APPLY (SCM_I_ENTITYP (proc
)
2960 ? SCM_ENTITY_PROCEDURE (proc
)
2961 : SCM_OPERATOR_PROCEDURE (proc
),
2962 scm_cons2 (proc
, t
.arg1
,
2970 case scm_tc7_subr_0
:
2972 case scm_tc7_subr_1o
:
2973 case scm_tc7_subr_1
:
2974 case scm_tc7_subr_3
:
2979 proc
= SCM_PROCEDURE (proc
);
2981 debug
.info
->a
.proc
= proc
;
2983 if (!SCM_CLOSUREP (proc
))
2985 if (scm_badformalsp (proc
, 2))
2986 goto umwrongnumargs
;
2987 case scm_tcs_closures
:
2990 env
= EXTEND_ENV (SCM_CAR (SCM_CODE (proc
)),
2994 env
= EXTEND_ENV (SCM_CAR (SCM_CODE (proc
)),
2995 scm_cons2 (t
.arg1
, arg2
, SCM_EOL
), SCM_ENV (proc
));
2997 x
= SCM_CODE (proc
);
2998 goto nontoplevel_cdrxbegin
;
3002 if (SCM_IMP (x
) || SCM_NECONSP (x
))
3006 debug
.info
->a
.args
= scm_cons2 (t
.arg1
, arg2
,
3007 scm_deval_args (x
, env
, proc
,
3008 SCM_CDRLOC (SCM_CDR (debug
.info
->a
.args
))));
3012 switch (SCM_TYP7 (proc
))
3013 { /* have 3 or more arguments */
3015 case scm_tc7_subr_3
:
3016 SCM_ASRTGO (SCM_NULLP (SCM_CDR (x
)), wrongnumargs
);
3017 RETURN (SCM_SUBRF (proc
) (t
.arg1
, arg2
,
3018 SCM_CADDR (debug
.info
->a
.args
)));
3020 #ifdef BUILTIN_RPASUBR
3021 t
.arg1
= SCM_SUBRF(proc
)(t
.arg1
, arg2
);
3022 arg2
= SCM_CDR (SCM_CDR (debug
.info
->a
.args
));
3025 t
.arg1
= SCM_SUBRF(proc
)(t
.arg1
, SCM_CAR (arg2
));
3026 arg2
= SCM_CDR (arg2
);
3028 while (SCM_NIMP (arg2
));
3030 #endif /* BUILTIN_RPASUBR */
3031 case scm_tc7_rpsubr
:
3032 #ifdef BUILTIN_RPASUBR
3033 if (SCM_FALSEP (SCM_SUBRF (proc
) (t
.arg1
, arg2
)))
3035 t
.arg1
= SCM_CDR (SCM_CDR (debug
.info
->a
.args
));
3038 if (SCM_FALSEP (SCM_SUBRF (proc
) (arg2
, SCM_CAR (t
.arg1
))))
3040 arg2
= SCM_CAR (t
.arg1
);
3041 t
.arg1
= SCM_CDR (t
.arg1
);
3043 while (SCM_NIMP (t
.arg1
));
3045 #else /* BUILTIN_RPASUBR */
3046 RETURN (SCM_APPLY (proc
, t
.arg1
,
3048 SCM_CDR (SCM_CDR (debug
.info
->a
.args
)),
3050 #endif /* BUILTIN_RPASUBR */
3051 case scm_tc7_lsubr_2
:
3052 RETURN (SCM_SUBRF (proc
) (t
.arg1
, arg2
,
3053 SCM_CDR (SCM_CDR (debug
.info
->a
.args
))))
3055 RETURN (SCM_SUBRF (proc
) (debug
.info
->a
.args
))
3057 if (!SCM_SMOB_APPLICABLE_P (proc
))
3059 RETURN (SCM_SMOB_APPLY_3 (proc
, t
.arg1
, arg2
,
3060 SCM_CDDR (debug
.info
->a
.args
)));
3064 proc
= SCM_PROCEDURE (proc
);
3065 debug
.info
->a
.proc
= proc
;
3066 if (!SCM_CLOSUREP (proc
))
3068 if (scm_badargsp (SCM_CAR (SCM_CODE (proc
)), debug
.info
->a
.args
))
3069 goto umwrongnumargs
;
3070 case scm_tcs_closures
:
3071 SCM_SET_ARGSREADY (debug
);
3072 env
= EXTEND_ENV (SCM_CAR (SCM_CODE (proc
)),
3075 x
= SCM_CODE (proc
);
3076 goto nontoplevel_cdrxbegin
;
3078 case scm_tc7_subr_3
:
3079 SCM_ASRTGO (SCM_NULLP (SCM_CDR (x
)), wrongnumargs
);
3080 RETURN (SCM_SUBRF (proc
) (t
.arg1
, arg2
, EVALCAR (x
, env
)));
3082 #ifdef BUILTIN_RPASUBR
3083 t
.arg1
= SCM_SUBRF (proc
) (t
.arg1
, arg2
);
3086 t
.arg1
= SCM_SUBRF(proc
)(t
.arg1
, EVALCAR(x
, env
));
3089 while (SCM_NIMP (x
));
3091 #endif /* BUILTIN_RPASUBR */
3092 case scm_tc7_rpsubr
:
3093 #ifdef BUILTIN_RPASUBR
3094 if (SCM_FALSEP (SCM_SUBRF (proc
) (t
.arg1
, arg2
)))
3098 t
.arg1
= EVALCAR (x
, env
);
3099 if (SCM_FALSEP (SCM_SUBRF (proc
) (arg2
, t
.arg1
)))
3104 while (SCM_NIMP (x
));
3106 #else /* BUILTIN_RPASUBR */
3107 RETURN (SCM_APPLY (proc
, t
.arg1
,
3109 scm_eval_args (x
, env
, proc
),
3111 #endif /* BUILTIN_RPASUBR */
3112 case scm_tc7_lsubr_2
:
3113 RETURN (SCM_SUBRF (proc
) (t
.arg1
, arg2
, scm_eval_args (x
, env
, proc
)));
3115 RETURN (SCM_SUBRF (proc
) (scm_cons2 (t
.arg1
,
3117 scm_eval_args (x
, env
, proc
))));
3119 if (!SCM_SMOB_APPLICABLE_P (proc
))
3121 RETURN (SCM_SMOB_APPLY_3 (proc
, t
.arg1
, arg2
,
3122 scm_eval_args (x
, env
, proc
)));
3126 proc
= SCM_PROCEDURE (proc
);
3127 if (!SCM_CLOSUREP (proc
))
3130 SCM formals
= SCM_CAR (SCM_CODE (proc
));
3131 if (SCM_NULLP (formals
)
3132 || (SCM_CONSP (formals
)
3133 && (SCM_NULLP (SCM_CDR (formals
))
3134 || (SCM_CONSP (SCM_CDR (formals
))
3135 && scm_badargsp (SCM_CDDR (formals
), x
)))))
3136 goto umwrongnumargs
;
3138 case scm_tcs_closures
:
3140 SCM_SET_ARGSREADY (debug
);
3142 env
= EXTEND_ENV (SCM_CAR (SCM_CODE (proc
)),
3145 scm_eval_args (x
, env
, proc
)),
3147 x
= SCM_CODE (proc
);
3148 goto nontoplevel_cdrxbegin
;
3150 case scm_tcs_cons_gloc
:
3151 if (SCM_OBJ_CLASS_FLAGS (proc
) & SCM_CLASSF_PURE_GENERIC
)
3154 arg2
= debug
.info
->a
.args
;
3156 arg2
= scm_cons2 (t
.arg1
, arg2
, scm_eval_args (x
, env
, proc
));
3158 x
= SCM_ENTITY_PROCEDURE (proc
);
3161 else if (!SCM_I_OPERATORP (proc
))
3165 case scm_tc7_subr_2
:
3166 case scm_tc7_subr_1o
:
3167 case scm_tc7_subr_2o
:
3168 case scm_tc7_subr_0
:
3170 case scm_tc7_subr_1
:
3178 if (CHECK_EXIT
&& SCM_TRAPS_P
)
3179 if (SCM_EXIT_FRAME_P
|| (SCM_TRACE_P
&& SCM_TRACED_FRAME_P (debug
)))
3181 SCM_CLEAR_TRACED_FRAME (debug
);
3182 if (SCM_CHEAPTRAPS_P
)
3183 t
.arg1
= scm_make_debugobj (&debug
);
3187 SCM val
= scm_make_continuation (&first
);
3197 scm_ithrow (scm_sym_exit_frame
, scm_cons2 (t
.arg1
, proc
, SCM_EOL
), 0);
3200 scm_last_debug_frame
= debug
.prev
;
3206 /* SECTION: This code is compiled once.
3211 /* This code processes the arguments to apply:
3213 (apply PROC ARG1 ... ARGS)
3215 Given a list (ARG1 ... ARGS), this function conses the ARG1
3216 ... arguments onto the front of ARGS, and returns the resulting
3217 list. Note that ARGS is a list; thus, the argument to this
3218 function is a list whose last element is a list.
3220 Apply calls this function, and applies PROC to the elements of the
3221 result. apply:nconc2last takes care of building the list of
3222 arguments, given (ARG1 ... ARGS).
3224 Rather than do new consing, apply:nconc2last destroys its argument.
3225 On that topic, this code came into my care with the following
3226 beautifully cryptic comment on that topic: "This will only screw
3227 you if you do (scm_apply scm_apply '( ... ))" If you know what
3228 they're referring to, send me a patch to this comment. */
3230 SCM_DEFINE (scm_nconc2last
, "apply:nconc2last", 1, 0, 0,
3232 "Given a list (@var{arg1} @dots{} @var{args}), this function\n"
3233 "conses the @var{arg1} @dots{} arguments onto the front of\n"
3234 "@var{args}, and returns the resulting list. Note that\n"
3235 "@var{args} is a list; thus, the argument to this function is\n"
3236 "a list whose last element is a list.\n"
3237 "Note: Rather than do new consing, @code{apply:nconc2last}\n"
3238 "destroys its argument, so use with care.")
3239 #define FUNC_NAME s_scm_nconc2last
3242 SCM_VALIDATE_NONEMPTYLIST (1,lst
);
3244 while (SCM_NNULLP (SCM_CDR (*lloc
)))
3245 lloc
= SCM_CDRLOC (*lloc
);
3246 SCM_ASSERT (scm_ilength (SCM_CAR (*lloc
)) >= 0, lst
, SCM_ARG1
, FUNC_NAME
);
3247 *lloc
= SCM_CAR (*lloc
);
3255 /* SECTION: When DEVAL is defined this code yields scm_dapply.
3256 * It is compiled twice.
3262 scm_apply (SCM proc
, SCM arg1
, SCM args
)
3269 scm_dapply (SCM proc
, SCM arg1
, SCM args
)
3274 /* Apply a function to a list of arguments.
3276 This function is exported to the Scheme level as taking two
3277 required arguments and a tail argument, as if it were:
3278 (lambda (proc arg1 . args) ...)
3279 Thus, if you just have a list of arguments to pass to a procedure,
3280 pass the list as ARG1, and '() for ARGS. If you have some fixed
3281 args, pass the first as ARG1, then cons any remaining fixed args
3282 onto the front of your argument list, and pass that as ARGS. */
3285 SCM_APPLY (SCM proc
, SCM arg1
, SCM args
)
3287 #ifdef DEBUG_EXTENSIONS
3289 scm_debug_frame debug
;
3290 scm_debug_info debug_vect_body
;
3291 debug
.prev
= scm_last_debug_frame
;
3292 debug
.status
= SCM_APPLYFRAME
;
3293 debug
.vect
= &debug_vect_body
;
3294 debug
.vect
[0].a
.proc
= proc
;
3295 debug
.vect
[0].a
.args
= SCM_EOL
;
3296 scm_last_debug_frame
= &debug
;
3299 return scm_dapply (proc
, arg1
, args
);
3303 SCM_ASRTGO (SCM_NIMP (proc
), badproc
);
3305 /* If ARGS is the empty list, then we're calling apply with only two
3306 arguments --- ARG1 is the list of arguments for PROC. Whatever
3307 the case, futz with things so that ARG1 is the first argument to
3308 give to PROC (or SCM_UNDEFINED if no args), and ARGS contains the
3311 Setting the debug apply frame args this way is pretty messy.
3312 Perhaps we should store arg1 and args directly in the frame as
3313 received, and let scm_frame_arguments unpack them, because that's
3314 a relatively rare operation. This works for now; if the Guile
3315 developer archives are still around, see Mikael's post of
3317 if (SCM_NULLP (args
))
3319 if (SCM_NULLP (arg1
))
3321 arg1
= SCM_UNDEFINED
;
3323 debug
.vect
[0].a
.args
= SCM_EOL
;
3329 debug
.vect
[0].a
.args
= arg1
;
3331 args
= SCM_CDR (arg1
);
3332 arg1
= SCM_CAR (arg1
);
3337 args
= scm_nconc2last (args
);
3339 debug
.vect
[0].a
.args
= scm_cons (arg1
, args
);
3343 if (SCM_ENTER_FRAME_P
&& SCM_TRAPS_P
)
3346 if (SCM_CHEAPTRAPS_P
)
3347 tmp
= scm_make_debugobj (&debug
);
3352 tmp
= scm_make_continuation (&first
);
3356 scm_ithrow (scm_sym_enter_frame
, scm_cons (tmp
, SCM_EOL
), 0);
3362 switch (SCM_TYP7 (proc
))
3364 case scm_tc7_subr_2o
:
3365 args
= SCM_NULLP (args
) ? SCM_UNDEFINED
: SCM_CAR (args
);
3366 RETURN (SCM_SUBRF (proc
) (arg1
, args
))
3367 case scm_tc7_subr_2
:
3368 SCM_ASRTGO (SCM_NNULLP (args
) && SCM_NULLP (SCM_CDR (args
)),
3370 args
= SCM_CAR (args
);
3371 RETURN (SCM_SUBRF (proc
) (arg1
, args
))
3372 case scm_tc7_subr_0
:
3373 SCM_ASRTGO (SCM_UNBNDP (arg1
), wrongnumargs
);
3374 RETURN (SCM_SUBRF (proc
) ())
3375 case scm_tc7_subr_1
:
3376 SCM_ASRTGO (!SCM_UNBNDP (arg1
), wrongnumargs
);
3377 case scm_tc7_subr_1o
:
3378 SCM_ASRTGO (SCM_NULLP (args
), wrongnumargs
);
3379 RETURN (SCM_SUBRF (proc
) (arg1
))
3381 SCM_ASRTGO (SCM_NULLP (args
), wrongnumargs
);
3382 if (SCM_SUBRF (proc
))
3384 if (SCM_INUMP (arg1
))
3386 RETURN (scm_make_real (SCM_DSUBRF (proc
) ((double) SCM_INUM (arg1
))));
3388 SCM_ASRTGO (SCM_NIMP (arg1
), floerr
);
3389 if (SCM_REALP (arg1
))
3391 RETURN (scm_make_real (SCM_DSUBRF (proc
) (SCM_REAL_VALUE (arg1
))));
3394 if (SCM_BIGP (arg1
))
3395 RETURN (scm_make_real (SCM_DSUBRF (proc
) (scm_big2dbl (arg1
))))
3398 SCM_WTA_DISPATCH_1 (*SCM_SUBR_GENERIC (proc
), arg1
,
3399 SCM_ARG1
, SCM_SYMBOL_CHARS (SCM_SNAME (proc
)));
3401 proc
= SCM_SNAME (proc
);
3403 char *chrs
= SCM_SYMBOL_CHARS (proc
) + SCM_SYMBOL_LENGTH (proc
) - 1;
3404 while ('c' != *--chrs
)
3406 SCM_ASSERT (SCM_CONSP (arg1
),
3407 arg1
, SCM_ARG1
, SCM_SYMBOL_CHARS (proc
));
3408 arg1
= ('a' == *chrs
) ? SCM_CAR (arg1
) : SCM_CDR (arg1
);
3412 case scm_tc7_subr_3
:
3413 SCM_ASRTGO (SCM_NNULLP (args
)
3414 && SCM_NNULLP (SCM_CDR (args
))
3415 && SCM_NULLP (SCM_CDDR (args
)),
3417 RETURN (SCM_SUBRF (proc
) (arg1
, SCM_CAR (args
), SCM_CAR (SCM_CDR (args
))))
3420 RETURN (SCM_SUBRF (proc
) (SCM_UNBNDP (arg1
) ? SCM_EOL
: debug
.vect
[0].a
.args
))
3422 RETURN (SCM_SUBRF (proc
) (SCM_UNBNDP (arg1
) ? SCM_EOL
: scm_cons (arg1
, args
)))
3424 case scm_tc7_lsubr_2
:
3425 SCM_ASRTGO (SCM_CONSP (args
), wrongnumargs
);
3426 RETURN (SCM_SUBRF (proc
) (arg1
, SCM_CAR (args
), SCM_CDR (args
)))
3428 if (SCM_NULLP (args
))
3429 RETURN (SCM_SUBRF (proc
) (arg1
, SCM_UNDEFINED
))
3430 while (SCM_NIMP (args
))
3432 SCM_ASSERT (SCM_CONSP (args
), args
, SCM_ARG2
, "apply");
3433 arg1
= SCM_SUBRF (proc
) (arg1
, SCM_CAR (args
));
3434 args
= SCM_CDR (args
);
3437 case scm_tc7_rpsubr
:
3438 if (SCM_NULLP (args
))
3439 RETURN (SCM_BOOL_T
);
3440 while (SCM_NIMP (args
))
3442 SCM_ASSERT (SCM_CONSP (args
), args
, SCM_ARG2
, "apply");
3443 if (SCM_FALSEP (SCM_SUBRF (proc
) (arg1
, SCM_CAR (args
))))
3444 RETURN (SCM_BOOL_F
);
3445 arg1
= SCM_CAR (args
);
3446 args
= SCM_CDR (args
);
3448 RETURN (SCM_BOOL_T
);
3449 case scm_tcs_closures
:
3451 arg1
= (SCM_UNBNDP (arg1
) ? SCM_EOL
: debug
.vect
[0].a
.args
);
3453 arg1
= (SCM_UNBNDP (arg1
) ? SCM_EOL
: scm_cons (arg1
, args
));
3455 #ifndef SCM_RECKLESS
3456 if (scm_badargsp (SCM_CAR (SCM_CODE (proc
)), arg1
))
3460 /* Copy argument list */
3465 SCM tl
= args
= scm_cons (SCM_CAR (arg1
), SCM_UNSPECIFIED
);
3466 while (arg1
= SCM_CDR (arg1
), SCM_CONSP (arg1
))
3468 SCM_SETCDR (tl
, scm_cons (SCM_CAR (arg1
),
3472 SCM_SETCDR (tl
, arg1
);
3475 args
= EXTEND_ENV (SCM_CAR (SCM_CODE (proc
)), args
, SCM_ENV (proc
));
3476 proc
= SCM_CDR (SCM_CODE (proc
));
3479 while (SCM_NNULLP (arg1
= SCM_CDR (arg1
)))
3481 if (SCM_IMP (SCM_CAR (proc
)))
3483 if (SCM_ISYMP (SCM_CAR (proc
)))
3485 proc
= scm_m_expand_body (proc
, args
);
3489 SCM_EVALIM2 (SCM_CAR (proc
));
3492 SCM_CEVAL (SCM_CAR (proc
), args
);
3495 RETURN (EVALCAR (proc
, args
));
3497 if (!SCM_SMOB_APPLICABLE_P (proc
))
3499 if (SCM_UNBNDP (arg1
))
3500 RETURN (SCM_SMOB_APPLY_0 (proc
))
3501 else if (SCM_NULLP (args
))
3502 RETURN (SCM_SMOB_APPLY_1 (proc
, arg1
))
3503 else if (SCM_NULLP (SCM_CDR (args
)))
3504 RETURN (SCM_SMOB_APPLY_2 (proc
, arg1
, SCM_CAR (args
)))
3506 RETURN (SCM_SMOB_APPLY_3 (proc
, arg1
, SCM_CAR (args
), SCM_CDR (args
)));
3509 args
= (SCM_UNBNDP(arg1
) ? SCM_EOL
: debug
.vect
[0].a
.args
);
3511 proc
= SCM_CCLO_SUBR (proc
);
3512 debug
.vect
[0].a
.proc
= proc
;
3513 debug
.vect
[0].a
.args
= scm_cons (arg1
, args
);
3515 args
= (SCM_UNBNDP(arg1
) ? SCM_EOL
: scm_cons (arg1
, args
));
3517 proc
= SCM_CCLO_SUBR (proc
);
3521 proc
= SCM_PROCEDURE (proc
);
3523 debug
.vect
[0].a
.proc
= proc
;
3526 case scm_tcs_cons_gloc
:
3527 if (SCM_OBJ_CLASS_FLAGS (proc
) & SCM_CLASSF_PURE_GENERIC
)
3530 args
= (SCM_UNBNDP(arg1
) ? SCM_EOL
: debug
.vect
[0].a
.args
);
3532 args
= (SCM_UNBNDP(arg1
) ? SCM_EOL
: scm_cons (arg1
, args
));
3534 RETURN (scm_apply_generic (proc
, args
));
3536 else if (!SCM_I_OPERATORP (proc
))
3541 args
= (SCM_UNBNDP(arg1
) ? SCM_EOL
: debug
.vect
[0].a
.args
);
3543 args
= (SCM_UNBNDP(arg1
) ? SCM_EOL
: scm_cons (arg1
, args
));
3546 proc
= (SCM_I_ENTITYP (proc
)
3547 ? SCM_ENTITY_PROCEDURE (proc
)
3548 : SCM_OPERATOR_PROCEDURE (proc
));
3550 debug
.vect
[0].a
.proc
= proc
;
3551 debug
.vect
[0].a
.args
= scm_cons (arg1
, args
);
3553 if (SCM_NIMP (proc
))
3559 scm_wrong_num_args (proc
);
3562 scm_wta (proc
, (char *) SCM_ARG1
, "apply");
3567 if (CHECK_EXIT
&& SCM_TRAPS_P
)
3568 if (SCM_EXIT_FRAME_P
|| (SCM_TRACE_P
&& SCM_TRACED_FRAME_P (debug
)))
3570 SCM_CLEAR_TRACED_FRAME (debug
);
3571 if (SCM_CHEAPTRAPS_P
)
3572 arg1
= scm_make_debugobj (&debug
);
3576 SCM val
= scm_make_continuation (&first
);
3586 scm_ithrow (scm_sym_exit_frame
, scm_cons2 (arg1
, proc
, SCM_EOL
), 0);
3589 scm_last_debug_frame
= debug
.prev
;
3595 /* SECTION: The rest of this file is only read once.
3600 /* Typechecking for multi-argument MAP and FOR-EACH.
3602 Verify that each element of the vector ARGV, except for the first,
3603 is a proper list whose length is LEN. Attribute errors to WHO,
3604 and claim that the i'th element of ARGV is WHO's i+2'th argument. */
3606 check_map_args (SCM argv
,
3613 SCM
*ve
= SCM_VELTS (argv
);
3616 for (i
= SCM_VECTOR_LENGTH (argv
) - 1; i
>= 1; i
--)
3618 int elt_len
= scm_ilength (ve
[i
]);
3623 scm_apply_generic (gf
, scm_cons (proc
, args
));
3625 scm_wrong_type_arg (who
, i
+ 2, ve
[i
]);
3629 scm_out_of_range (who
, ve
[i
]);
3632 scm_remember_upto_here_1 (argv
);
3636 SCM_GPROC (s_map
, "map", 2, 0, 1, scm_map
, g_map
);
3638 /* Note: Currently, scm_map applies PROC to the argument list(s)
3639 sequentially, starting with the first element(s). This is used in
3640 evalext.c where the Scheme procedure `map-in-order', which guarantees
3641 sequential behaviour, is implemented using scm_map. If the
3642 behaviour changes, we need to update `map-in-order'.
3646 scm_map (SCM proc
, SCM arg1
, SCM args
)
3647 #define FUNC_NAME s_map
3652 SCM
*ve
= &args
; /* Keep args from being optimized away. */
3654 len
= scm_ilength (arg1
);
3655 SCM_GASSERTn (len
>= 0,
3656 g_map
, scm_cons2 (proc
, arg1
, args
), SCM_ARG2
, s_map
);
3657 SCM_VALIDATE_REST_ARGUMENT (args
);
3658 if (SCM_NULLP (args
))
3660 while (SCM_NIMP (arg1
))
3662 *pres
= scm_cons (scm_apply (proc
, SCM_CAR (arg1
), scm_listofnull
),
3664 pres
= SCM_CDRLOC (*pres
);
3665 arg1
= SCM_CDR (arg1
);
3669 args
= scm_vector (arg1
= scm_cons (arg1
, args
));
3670 ve
= SCM_VELTS (args
);
3671 #ifndef SCM_RECKLESS
3672 check_map_args (args
, len
, g_map
, proc
, arg1
, s_map
);
3677 for (i
= SCM_VECTOR_LENGTH (args
) - 1; i
>= 0; i
--)
3679 if (SCM_IMP (ve
[i
]))
3681 arg1
= scm_cons (SCM_CAR (ve
[i
]), arg1
);
3682 ve
[i
] = SCM_CDR (ve
[i
]);
3684 *pres
= scm_cons (scm_apply (proc
, arg1
, SCM_EOL
), SCM_EOL
);
3685 pres
= SCM_CDRLOC (*pres
);
3691 SCM_GPROC (s_for_each
, "for-each", 2, 0, 1, scm_for_each
, g_for_each
);
3694 scm_for_each (SCM proc
, SCM arg1
, SCM args
)
3695 #define FUNC_NAME s_for_each
3697 SCM
*ve
= &args
; /* Keep args from being optimized away. */
3699 len
= scm_ilength (arg1
);
3700 SCM_GASSERTn (len
>= 0, g_for_each
, scm_cons2 (proc
, arg1
, args
),
3701 SCM_ARG2
, s_for_each
);
3702 SCM_VALIDATE_REST_ARGUMENT (args
);
3705 while SCM_NIMP (arg1
)
3707 scm_apply (proc
, SCM_CAR (arg1
), scm_listofnull
);
3708 arg1
= SCM_CDR (arg1
);
3710 return SCM_UNSPECIFIED
;
3712 args
= scm_vector (arg1
= scm_cons (arg1
, args
));
3713 ve
= SCM_VELTS (args
);
3714 #ifndef SCM_RECKLESS
3715 check_map_args (args
, len
, g_for_each
, proc
, arg1
, s_for_each
);
3720 for (i
= SCM_VECTOR_LENGTH (args
) - 1; i
>= 0; i
--)
3723 (ve
[i
]) return SCM_UNSPECIFIED
;
3724 arg1
= scm_cons (SCM_CAR (ve
[i
]), arg1
);
3725 ve
[i
] = SCM_CDR (ve
[i
]);
3727 scm_apply (proc
, arg1
, SCM_EOL
);
3734 scm_closure (SCM code
, SCM env
)
3738 SCM_SETCODE (z
, code
);
3739 SCM_SETENV (z
, env
);
3744 scm_bits_t scm_tc16_promise
;
3747 scm_makprom (SCM code
)
3749 SCM_RETURN_NEWSMOB (scm_tc16_promise
, SCM_UNPACK (code
));
3755 promise_print (SCM exp
, SCM port
, scm_print_state
*pstate
)
3757 int writingp
= SCM_WRITINGP (pstate
);
3758 scm_puts ("#<promise ", port
);
3759 SCM_SET_WRITINGP (pstate
, 1);
3760 scm_iprin1 (SCM_CDR (exp
), port
, pstate
);
3761 SCM_SET_WRITINGP (pstate
, writingp
);
3762 scm_putc ('>', port
);
3767 SCM_DEFINE (scm_force
, "force", 1, 0, 0,
3769 "If the promise X has not been computed yet, compute and return\n"
3770 "X, otherwise just return the previously computed value.")
3771 #define FUNC_NAME s_scm_force
3773 SCM_VALIDATE_SMOB (1, x
, promise
);
3774 if (!((1L << 16) & SCM_CELL_WORD_0 (x
)))
3776 SCM ans
= scm_apply (SCM_CELL_OBJECT_1 (x
), SCM_EOL
, SCM_EOL
);
3777 if (!((1L << 16) & SCM_CELL_WORD_0 (x
)))
3780 SCM_SET_CELL_OBJECT_1 (x
, ans
);
3781 SCM_SET_CELL_WORD_0 (x
, SCM_CELL_WORD_0 (x
) | (1L << 16));
3785 return SCM_CELL_OBJECT_1 (x
);
3790 SCM_DEFINE (scm_promise_p
, "promise?", 1, 0, 0,
3792 "Return true if @var{obj} is a promise, i.e. a delayed computation\n"
3793 "(@pxref{Delayed evaluation,,,r4rs.info,The Revised^4 Report on Scheme}).")
3794 #define FUNC_NAME s_scm_promise_p
3796 return SCM_BOOL (SCM_TYP16_PREDICATE (scm_tc16_promise
, x
));
3801 SCM_DEFINE (scm_cons_source
, "cons-source", 3, 0, 0,
3802 (SCM xorig
, SCM x
, SCM y
),
3803 "Create and return a new pair whose car and cdr are @var{x} and @var{y}.\n"
3804 "Any source properties associated with @var{xorig} are also associated\n"
3805 "with the new pair.")
3806 #define FUNC_NAME s_scm_cons_source
3810 SCM_SET_CELL_OBJECT_0 (z
, x
);
3811 SCM_SET_CELL_OBJECT_1 (z
, y
);
3812 /* Copy source properties possibly associated with xorig. */
3813 p
= scm_whash_lookup (scm_source_whash
, xorig
);
3815 scm_whash_insert (scm_source_whash
, z
, p
);
3821 SCM_DEFINE (scm_copy_tree
, "copy-tree", 1, 0, 0,
3823 "Recursively copy the data tree that is bound to @var{obj}, and return a\n"
3824 "pointer to the new data structure. @code{copy-tree} recurses down the\n"
3825 "contents of both pairs and vectors (since both cons cells and vector\n"
3826 "cells may point to arbitrary objects), and stops recursing when it hits\n"
3827 "any other object.")
3828 #define FUNC_NAME s_scm_copy_tree
3833 if (SCM_VECTORP (obj
))
3835 scm_sizet i
= SCM_VECTOR_LENGTH (obj
);
3836 ans
= scm_c_make_vector (i
, SCM_UNSPECIFIED
);
3838 SCM_VELTS (ans
)[i
] = scm_copy_tree (SCM_VELTS (obj
)[i
]);
3841 if (SCM_NCONSP (obj
))
3843 ans
= tl
= scm_cons_source (obj
,
3844 scm_copy_tree (SCM_CAR (obj
)),
3846 while (obj
= SCM_CDR (obj
), SCM_CONSP (obj
))
3848 SCM_SETCDR (tl
, scm_cons (scm_copy_tree (SCM_CAR (obj
)),
3852 SCM_SETCDR (tl
, obj
);
3858 /* We have three levels of EVAL here:
3860 - scm_i_eval (exp, env)
3862 evaluates EXP in environment ENV. ENV is a lexical environment
3863 structure as used by the actual tree code evaluator. When ENV is
3864 a top-level environment, then changes to the current module are
3865 tracked by modifying ENV so that it continues to be in sync with
3868 - scm_primitive_eval (exp)
3870 evaluates EXP in the top-level environment as determined by the
3871 current module. This is done by constructing a suitable
3872 environment and calling scm_i_eval. Thus, changes to the
3873 top-level module are tracked normally.
3875 - scm_eval (exp, mod)
3877 evaluates EXP while MOD is the current module. Thius is done by
3878 setting the current module to MOD, invoking scm_primitive_eval on
3879 EXP, and then restoring the current module to the value it had
3880 previously. That is, while EXP is evaluated, changes to the
3881 current module are tracked, but these changes do not persist when
3884 For each level of evals, there are two variants, distinguished by a
3885 _x suffix: the ordinary variant does not modify EXP while the _x
3886 variant can destructively modify EXP into something completely
3887 unintelligible. A Scheme data structure passed as EXP to one of the
3888 _x variants should not ever be used again for anything. So when in
3889 doubt, use the ordinary variant.
3893 SCM scm_system_transformer
;
3895 /* XXX - scm_i_eval is meant to be useable for evaluation in
3896 non-toplevel environments, for example when used by the debugger.
3897 Can the system transform deal with this? */
3900 scm_i_eval_x (SCM exp
, SCM env
)
3902 SCM transformer
= scm_fluid_ref (SCM_CDR (scm_system_transformer
));
3903 if (SCM_NIMP (transformer
))
3904 exp
= scm_apply (transformer
, exp
, scm_listofnull
);
3905 return SCM_XEVAL (exp
, env
);
3909 scm_i_eval (SCM exp
, SCM env
)
3911 SCM transformer
= scm_fluid_ref (SCM_CDR (scm_system_transformer
));
3912 if (SCM_NIMP (transformer
))
3913 exp
= scm_apply (transformer
, exp
, scm_listofnull
);
3914 exp
= scm_copy_tree (exp
);
3915 return SCM_XEVAL (exp
, env
);
3919 scm_primitive_eval_x (SCM exp
)
3921 SCM env
= scm_top_level_env (scm_current_module_lookup_closure ());
3922 return scm_i_eval_x (exp
, env
);
3925 SCM_DEFINE (scm_primitive_eval
, "primitive-eval", 1, 0, 0,
3927 "Evaluate @var{exp} in the top-level environment specified by\n"
3928 "the current module.")
3929 #define FUNC_NAME s_scm_primitive_eval
3931 SCM env
= scm_top_level_env (scm_current_module_lookup_closure ());
3932 return scm_i_eval (exp
, env
);
3936 /* Eval does not take the second arg optionally. This is intentional
3937 * in order to be R5RS compatible, and to prepare for the new module
3938 * system, where we would like to make the choice of evaluation
3939 * environment explicit. */
3942 change_environment (void *data
)
3944 SCM pair
= SCM_PACK (data
);
3945 SCM new_module
= SCM_CAR (pair
);
3946 SCM old_module
= scm_current_module ();
3947 SCM_SETCDR (pair
, old_module
);
3948 scm_set_current_module (new_module
);
3953 restore_environment (void *data
)
3955 SCM pair
= SCM_PACK (data
);
3956 SCM old_module
= SCM_CDR (pair
);
3957 SCM new_module
= scm_current_module ();
3958 SCM_SETCAR (pair
, new_module
);
3959 scm_set_current_module (old_module
);
3963 inner_eval_x (void *data
)
3965 return scm_primitive_eval_x (SCM_PACK(data
));
3969 scm_eval_x (SCM exp
, SCM module
)
3970 #define FUNC_NAME "eval!"
3972 SCM_VALIDATE_MODULE (2, module
);
3974 return scm_internal_dynamic_wind
3975 (change_environment
, inner_eval_x
, restore_environment
,
3976 (void *) SCM_UNPACK (exp
),
3977 (void *) SCM_UNPACK (scm_cons (module
, SCM_BOOL_F
)));
3982 inner_eval (void *data
)
3984 return scm_primitive_eval (SCM_PACK(data
));
3987 SCM_DEFINE (scm_eval
, "eval", 2, 0, 0,
3988 (SCM exp
, SCM module
),
3989 "Evaluate @var{exp}, a list representing a Scheme expression,\n"
3990 "in the top-level environment specified by @var{module}.\n"
3991 "While @var{exp} is evaluated (using @var{primitive-eval}),\n"
3992 "@var{module} is made the current module. The current module\n"
3993 "is reset to its previous value when @var{eval} returns.")
3994 #define FUNC_NAME s_scm_eval
3996 SCM_VALIDATE_MODULE (2, module
);
3998 return scm_internal_dynamic_wind
3999 (change_environment
, inner_eval
, restore_environment
,
4000 (void *) SCM_UNPACK (exp
),
4001 (void *) SCM_UNPACK (scm_cons (module
, SCM_BOOL_F
)));
4005 #if (SCM_DEBUG_DEPRECATED == 0)
4007 /* Use scm_current_module () or scm_interaction_environment ()
4008 * instead. The former is the module selected during loading of code.
4009 * The latter is the module in which the user of this thread currently
4010 * types expressions.
4013 SCM scm_top_level_lookup_closure_var
;
4015 /* Avoid using this functionality altogether (except for implementing
4016 * libguile, where you can use scm_i_eval or scm_i_eval_x).
4018 * Applications should use either C level scm_eval_x or Scheme
4019 * scm_eval; or scm_primitive_eval_x or scm_primitive_eval. */
4022 scm_eval_3 (SCM obj
, int copyp
, SCM env
)
4025 return scm_i_eval (obj
, env
);
4027 return scm_i_eval_x (obj
, env
);
4030 SCM_DEFINE (scm_eval2
, "eval2", 2, 0, 0,
4031 (SCM obj
, SCM env_thunk
),
4032 "Evaluate @var{exp}, a Scheme expression, in the environment\n"
4033 "designated by @var{lookup}, a symbol-lookup function."
4034 "Do not use this version of eval, it does not play well\n"
4035 "with the module system. Use @code{eval} or\n"
4036 "@code{primitive-eval} instead.")
4037 #define FUNC_NAME s_scm_eval2
4039 return scm_i_eval (obj
, scm_top_level_env (env_thunk
));
4043 #endif /* DEPRECATED */
4046 /* At this point, scm_deval and scm_dapply are generated.
4049 #ifdef DEBUG_EXTENSIONS
4059 scm_init_opts (scm_evaluator_traps
,
4060 scm_evaluator_trap_table
,
4061 SCM_N_EVALUATOR_TRAPS
);
4062 scm_init_opts (scm_eval_options_interface
,
4064 SCM_N_EVAL_OPTIONS
);
4066 scm_tc16_promise
= scm_make_smob_type ("promise", 0);
4067 scm_set_smob_mark (scm_tc16_promise
, scm_markcdr
);
4068 scm_set_smob_print (scm_tc16_promise
, promise_print
);
4070 scm_f_apply
= scm_make_subr ("apply", scm_tc7_lsubr_2
, scm_apply
);
4071 scm_system_transformer
= scm_sysintern ("scm:eval-transformer",
4074 scm_lisp_nil
= scm_sysintern ("nil", SCM_UNDEFINED
);
4075 SCM_SETCDR (scm_lisp_nil
, SCM_CAR (scm_lisp_nil
));
4076 scm_lisp_nil
= SCM_CAR (scm_lisp_nil
);
4077 scm_lisp_t
= scm_sysintern ("t", SCM_UNDEFINED
);
4078 SCM_SETCDR (scm_lisp_t
, SCM_CAR (scm_lisp_t
));
4079 scm_lisp_t
= SCM_CAR (scm_lisp_t
);
4084 #if SCM_DEBUG_DEPRECATED == 0
4085 scm_top_level_lookup_closure_var
=
4086 scm_sysintern ("*top-level-lookup-closure*", scm_make_fluid ());
4089 #ifndef SCM_MAGIC_SNARFER
4090 #include "libguile/eval.x"
4093 scm_add_feature ("delay");