1 /* Copyright (C) 1995, 96, 97, 98, 99, 2000 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/alist.h"
85 #include "libguile/eq.h"
86 #include "libguile/continuations.h"
87 #include "libguile/throw.h"
88 #include "libguile/smob.h"
89 #include "libguile/macros.h"
90 #include "libguile/procprop.h"
91 #include "libguile/hashtab.h"
92 #include "libguile/hash.h"
93 #include "libguile/srcprop.h"
94 #include "libguile/stackchk.h"
95 #include "libguile/objects.h"
96 #include "libguile/async.h"
97 #include "libguile/feature.h"
98 #include "libguile/modules.h"
99 #include "libguile/ports.h"
100 #include "libguile/root.h"
101 #include "libguile/vectors.h"
103 #include "libguile/validate.h"
104 #include "libguile/eval.h"
106 SCM (*scm_memoize_method
) (SCM
, SCM
);
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_lookupcar returns a pointer to this when a variable could not
257 be found and it should not throw an error. Never assign to this.
259 static SCM undef_object
= SCM_UNDEFINED
;
261 SCM_SYMBOL (scm_unbound_variable_key
, "unbound-variable");
265 scm_lookupcar1 (SCM vloc
, SCM genv
, int check
)
268 scm_lookupcar (SCM vloc
, SCM genv
, int check
)
272 register SCM
*al
, fl
, var
= SCM_CAR (vloc
);
274 register SCM var2
= var
;
276 #ifdef MEMOIZE_LOCALS
277 register SCM iloc
= SCM_ILOC00
;
279 for (; SCM_NIMP (env
); env
= SCM_CDR (env
))
281 if (SCM_TRUE_P (scm_procedure_p (SCM_CAR (env
))))
283 al
= SCM_CARLOC (env
);
284 for (fl
= SCM_CAR (*al
); SCM_NIMP (fl
); fl
= SCM_CDR (fl
))
288 if (SCM_EQ_P (fl
, var
))
290 #ifdef MEMOIZE_LOCALS
292 if (! SCM_EQ_P (SCM_CAR (vloc
), var
))
295 SCM_SET_CELL_WORD_0 (vloc
, SCM_UNPACK (iloc
) + SCM_ICDR
);
297 return SCM_CDRLOC (*al
);
302 al
= SCM_CDRLOC (*al
);
303 if (SCM_EQ_P (SCM_CAR (fl
), var
))
305 #ifdef MEMOIZE_LOCALS
306 #ifndef SCM_RECKLESS /* letrec inits to SCM_UNDEFINED */
307 if (SCM_UNBNDP (SCM_CAR (*al
)))
314 if (SCM_CAR (vloc
) != var
)
317 SCM_SETCAR (vloc
, iloc
);
319 return SCM_CARLOC (*al
);
321 #ifdef MEMOIZE_LOCALS
322 iloc
= SCM_PACK (SCM_UNPACK (iloc
) + SCM_IDINC
);
325 #ifdef MEMOIZE_LOCALS
326 iloc
= SCM_PACK ((~SCM_IDSTMSK
) & (SCM_UNPACK(iloc
) + SCM_IFRINC
));
330 SCM top_thunk
, vcell
;
333 top_thunk
= SCM_CAR(env
); /* env now refers to a top level env thunk */
337 top_thunk
= SCM_BOOL_F
;
338 vcell
= scm_sym2vcell (var
, top_thunk
, SCM_BOOL_F
);
339 if (SCM_FALSEP (vcell
))
345 if (SCM_NNULLP (env
) || SCM_UNBNDP (SCM_CDR (var
)))
349 /* scm_everr (vloc, genv,...) */
353 scm_error (scm_unbound_variable_key
, NULL
, "Unbound variable: ~S",
354 scm_cons (var
, SCM_EOL
), SCM_BOOL_F
);
356 scm_misc_error (NULL
, "Damaged environment: ~S",
357 scm_cons (var
, SCM_EOL
));
360 return &undef_object
;
364 if (SCM_CAR (vloc
) != var2
)
366 /* Some other thread has changed the very cell we are working
367 on. In effect, it must have done our job or messed it up
370 var
= SCM_CAR (vloc
);
371 if (SCM_ITAG3 (var
) == scm_tc3_cons_gloc
)
372 return SCM_GLOC_VAL_LOC (var
);
373 #ifdef MEMOIZE_LOCALS
374 if ((SCM_UNPACK (var
) & 127) == (127 & SCM_UNPACK (SCM_ILOC00
)))
375 return scm_ilookup (var
, genv
);
377 /* We can't cope with anything else than glocs and ilocs. When
378 a special form has been memoized (i.e. `let' into `#@let') we
379 return NULL and expect the calling function to do the right
380 thing. For the evaluator, this means going back and redoing
381 the dispatch on the car of the form. */
384 #endif /* USE_THREADS */
386 SCM_SET_CELL_WORD_0 (vloc
, SCM_UNPACK (var
) + scm_tc3_cons_gloc
);
387 /* Except wait...what if the var is not a vcell,
388 * but syntax or something.... */
389 return SCM_CDRLOC (var
);
394 scm_lookupcar (SCM vloc
, SCM genv
, int check
)
396 SCM
*loc
= scm_lookupcar1 (vloc
, genv
, check
);
403 #define unmemocar scm_unmemocar
406 scm_unmemocar (SCM form
, SCM env
)
413 if (SCM_ITAG3 (c
) == scm_tc3_cons_gloc
)
414 SCM_SETCAR (form
, SCM_GLOC_SYM (c
));
415 #ifdef MEMOIZE_LOCALS
416 #ifdef DEBUG_EXTENSIONS
417 else if (SCM_ILOCP (c
))
421 for (ir
= SCM_IFRAME (c
); ir
!= 0; --ir
)
423 env
= SCM_CAR (SCM_CAR (env
));
424 for (ir
= SCM_IDIST (c
); ir
!= 0; --ir
)
426 SCM_SETCAR (form
, SCM_ICDRP (c
) ? env
: SCM_CAR (env
));
435 scm_eval_car (SCM pair
, SCM env
)
437 return SCM_XEVALCAR (pair
, env
);
442 * The following rewrite expressions and
443 * some memoized forms have different syntax
446 const char scm_s_expression
[] = "missing or extra expression";
447 const char scm_s_test
[] = "bad test";
448 const char scm_s_body
[] = "bad body";
449 const char scm_s_bindings
[] = "bad bindings";
450 const char scm_s_variable
[] = "bad variable";
451 const char scm_s_clauses
[] = "bad or missing clauses";
452 const char scm_s_formals
[] = "bad formals";
454 SCM scm_sym_dot
, scm_sym_arrow
, scm_sym_else
;
455 SCM scm_sym_unquote
, scm_sym_uq_splicing
, scm_sym_apply
;
459 #ifdef DEBUG_EXTENSIONS
460 SCM scm_sym_enter_frame
, scm_sym_apply_frame
, scm_sym_exit_frame
;
464 #define ASRTSYNTAX(cond_, msg_) if(!(cond_))scm_wta(xorig, (msg_), what);
468 static void bodycheck (SCM xorig
, SCM
*bodyloc
, const char *what
);
471 bodycheck (SCM xorig
, SCM
*bodyloc
, const char *what
)
473 ASRTSYNTAX (scm_ilength (*bodyloc
) >= 1, scm_s_expression
);
476 /* Check that the body denoted by XORIG is valid and rewrite it into
477 its internal form. The internal form of a body is just the body
478 itself, but prefixed with an ISYM that denotes to what kind of
479 outer construct this body belongs. A lambda body starts with
480 SCM_IM_LAMBDA, for example, a body of a let starts with SCM_IM_LET,
481 etc. The one exception is a body that belongs to a letrec that has
482 been formed by rewriting internal defines: it starts with
485 /* XXX - Besides controlling the rewriting of internal defines, the
486 additional ISYM could be used for improved error messages.
487 This is not done yet. */
490 scm_m_body (SCM op
, SCM xorig
, const char *what
)
492 ASRTSYNTAX (scm_ilength (xorig
) >= 1, scm_s_expression
);
494 /* Don't add another ISYM if one is present already. */
495 if (SCM_ISYMP (SCM_CAR (xorig
)))
498 /* Retain possible doc string. */
499 if (SCM_IMP (SCM_CAR(xorig
)) || SCM_NCONSP (SCM_CAR (xorig
)))
501 if (SCM_NNULLP (SCM_CDR(xorig
)))
502 return scm_cons (SCM_CAR (xorig
),
503 scm_m_body (op
, SCM_CDR(xorig
), what
));
507 return scm_cons2 (op
, SCM_CAR (xorig
), SCM_CDR(xorig
));
510 SCM_SYNTAX(s_quote
,"quote", scm_makmmacro
, scm_m_quote
);
511 SCM_GLOBAL_SYMBOL(scm_sym_quote
, s_quote
);
514 scm_m_quote (SCM xorig
, SCM env
)
516 SCM x
= scm_copy_tree (SCM_CDR (xorig
));
518 SCM_ASSYNT (scm_ilength (SCM_CDR (xorig
)) == 1,
519 xorig
, scm_s_expression
, s_quote
);
520 return scm_cons (SCM_IM_QUOTE
, x
);
525 SCM_SYNTAX(s_begin
, "begin", scm_makmmacro
, scm_m_begin
);
526 SCM_GLOBAL_SYMBOL(scm_sym_begin
, s_begin
);
529 scm_m_begin (SCM xorig
, SCM env
)
531 SCM_ASSYNT (scm_ilength (SCM_CDR (xorig
)) >= 1,
532 xorig
, scm_s_expression
, s_begin
);
533 return scm_cons (SCM_IM_BEGIN
, SCM_CDR (xorig
));
536 SCM_SYNTAX(s_if
, "if", scm_makmmacro
, scm_m_if
);
537 SCM_GLOBAL_SYMBOL(scm_sym_if
, s_if
);
540 scm_m_if (SCM xorig
, SCM env
)
542 int len
= scm_ilength (SCM_CDR (xorig
));
543 SCM_ASSYNT (len
>= 2 && len
<= 3, xorig
, scm_s_expression
, "if");
544 return scm_cons (SCM_IM_IF
, SCM_CDR (xorig
));
548 /* Will go into the RnRS module when Guile is factorized.
549 SCM_SYNTAX(scm_s_set_x,"set!", scm_makmmacro, scm_m_set_x); */
550 const char scm_s_set_x
[] = "set!";
551 SCM_GLOBAL_SYMBOL(scm_sym_set_x
, scm_s_set_x
);
554 scm_m_set_x (SCM xorig
, SCM env
)
556 SCM x
= SCM_CDR (xorig
);
557 SCM_ASSYNT (2 == scm_ilength (x
), xorig
, scm_s_expression
, scm_s_set_x
);
558 SCM_ASSYNT (SCM_SYMBOLP (SCM_CAR (x
)),
559 xorig
, scm_s_variable
, scm_s_set_x
);
560 return scm_cons (SCM_IM_SET_X
, x
);
567 scm_m_vref (SCM xorig
, SCM env
)
569 SCM x
= SCM_CDR (xorig
);
570 SCM_ASSYNT (1 == scm_ilength (x
), xorig
, scm_s_expression
, s_vref
);
571 if (SCM_NIMP(x
) && UDSCM_VARIABLEP (SCM_CAR (x
)))
573 /* scm_everr (SCM_UNDEFINED, env,..., "global variable reference") */
574 scm_misc_error (NULL
,
576 scm_listify (SCM_CAR (SCM_CDR (x
)), SCM_UNDEFINED
));
578 SCM_ASSYNT (SCM_NIMP(x
) && DEFSCM_VARIABLEP (SCM_CAR (x
)),
579 xorig
, scm_s_variable
, s_vref
);
580 return scm_cons (IM_VREF
, x
);
586 scm_m_vset (SCM xorig
, SCM env
)
588 SCM x
= SCM_CDR (xorig
);
589 SCM_ASSYNT (3 == scm_ilength (x
), xorig
, scm_s_expression
, s_vset
);
590 SCM_ASSYNT ((DEFSCM_VARIABLEP (SCM_CAR (x
))
591 || UDSCM_VARIABLEP (SCM_CAR (x
))),
592 xorig
, scm_s_variable
, s_vset
);
593 return scm_cons (IM_VSET
, x
);
598 SCM_SYNTAX(s_and
, "and", scm_makmmacro
, scm_m_and
);
599 SCM_GLOBAL_SYMBOL(scm_sym_and
, s_and
);
602 scm_m_and (SCM xorig
, SCM env
)
604 int len
= scm_ilength (SCM_CDR (xorig
));
605 SCM_ASSYNT (len
>= 0, xorig
, scm_s_test
, s_and
);
607 return scm_cons (SCM_IM_AND
, SCM_CDR (xorig
));
612 SCM_SYNTAX(s_or
,"or", scm_makmmacro
, scm_m_or
);
613 SCM_GLOBAL_SYMBOL(scm_sym_or
,s_or
);
616 scm_m_or (SCM xorig
, SCM env
)
618 int len
= scm_ilength (SCM_CDR (xorig
));
619 SCM_ASSYNT (len
>= 0, xorig
, scm_s_test
, s_or
);
621 return scm_cons (SCM_IM_OR
, SCM_CDR (xorig
));
627 SCM_SYNTAX(s_case
, "case", scm_makmmacro
, scm_m_case
);
628 SCM_GLOBAL_SYMBOL(scm_sym_case
, s_case
);
631 scm_m_case (SCM xorig
, SCM env
)
633 SCM proc
, cdrx
= scm_list_copy (SCM_CDR (xorig
)), x
= cdrx
;
634 SCM_ASSYNT (scm_ilength (x
) >= 2, xorig
, scm_s_clauses
, s_case
);
635 while (SCM_NIMP (x
= SCM_CDR (x
)))
638 SCM_ASSYNT (scm_ilength (proc
) >= 2, xorig
, scm_s_clauses
, s_case
);
639 SCM_ASSYNT (scm_ilength (SCM_CAR (proc
)) >= 0
640 || SCM_EQ_P (scm_sym_else
, SCM_CAR (proc
)),
641 xorig
, scm_s_clauses
, s_case
);
643 return scm_cons (SCM_IM_CASE
, cdrx
);
647 SCM_SYNTAX(s_cond
, "cond", scm_makmmacro
, scm_m_cond
);
648 SCM_GLOBAL_SYMBOL(scm_sym_cond
, s_cond
);
652 scm_m_cond (SCM xorig
, SCM env
)
654 SCM arg1
, cdrx
= scm_list_copy (SCM_CDR (xorig
)), x
= cdrx
;
655 int len
= scm_ilength (x
);
656 SCM_ASSYNT (len
>= 1, xorig
, scm_s_clauses
, s_cond
);
660 len
= scm_ilength (arg1
);
661 SCM_ASSYNT (len
>= 1, xorig
, scm_s_clauses
, s_cond
);
662 if (SCM_EQ_P (scm_sym_else
, SCM_CAR (arg1
)))
664 SCM_ASSYNT (SCM_NULLP (SCM_CDR (x
)) && len
>= 2,
665 xorig
, "bad ELSE clause", s_cond
);
666 SCM_SETCAR (arg1
, SCM_BOOL_T
);
668 if (len
>= 2 && SCM_EQ_P (scm_sym_arrow
, SCM_CAR (SCM_CDR (arg1
))))
669 SCM_ASSYNT (3 == len
&& SCM_NIMP (SCM_CAR (SCM_CDR (SCM_CDR (arg1
)))),
670 xorig
, "bad recipient", s_cond
);
673 return scm_cons (SCM_IM_COND
, cdrx
);
676 SCM_SYNTAX(s_lambda
, "lambda", scm_makmmacro
, scm_m_lambda
);
677 SCM_GLOBAL_SYMBOL(scm_sym_lambda
, s_lambda
);
680 scm_m_lambda (SCM xorig
, SCM env
)
682 SCM proc
, x
= SCM_CDR (xorig
);
683 if (scm_ilength (x
) < 2)
686 if (SCM_NULLP (proc
))
688 if (SCM_EQ_P (SCM_IM_LET
, proc
)) /* named let */
692 if (SCM_SYMBOLP (proc
))
694 if (SCM_NCONSP (proc
))
696 while (SCM_NIMP (proc
))
698 if (SCM_NCONSP (proc
))
700 if (!SCM_SYMBOLP (proc
))
705 if (!SCM_SYMBOLP (SCM_CAR (proc
)))
707 proc
= SCM_CDR (proc
);
709 if (SCM_NNULLP (proc
))
712 scm_wta (xorig
, scm_s_formals
, s_lambda
);
716 return scm_cons2 (SCM_IM_LAMBDA
, SCM_CAR (x
),
717 scm_m_body (SCM_IM_LAMBDA
, SCM_CDR (x
), s_lambda
));
720 SCM_SYNTAX(s_letstar
,"let*", scm_makmmacro
, scm_m_letstar
);
721 SCM_GLOBAL_SYMBOL(scm_sym_letstar
,s_letstar
);
725 scm_m_letstar (SCM xorig
, SCM env
)
727 SCM x
= SCM_CDR (xorig
), arg1
, proc
, vars
= SCM_EOL
, *varloc
= &vars
;
728 int len
= scm_ilength (x
);
729 SCM_ASSYNT (len
>= 2, xorig
, scm_s_body
, s_letstar
);
731 SCM_ASSYNT (scm_ilength (proc
) >= 0, xorig
, scm_s_bindings
, s_letstar
);
732 while (SCM_NIMP (proc
))
734 arg1
= SCM_CAR (proc
);
735 SCM_ASSYNT (2 == scm_ilength (arg1
), xorig
, scm_s_bindings
, s_letstar
);
736 SCM_ASSYNT (SCM_SYMBOLP (SCM_CAR (arg1
)), xorig
, scm_s_variable
, s_letstar
);
737 *varloc
= scm_cons2 (SCM_CAR (arg1
), SCM_CAR (SCM_CDR (arg1
)), SCM_EOL
);
738 varloc
= SCM_CDRLOC (SCM_CDR (*varloc
));
739 proc
= SCM_CDR (proc
);
741 x
= scm_cons (vars
, SCM_CDR (x
));
743 return scm_cons2 (SCM_IM_LETSTAR
, SCM_CAR (x
),
744 scm_m_body (SCM_IM_LETSTAR
, SCM_CDR (x
), s_letstar
));
747 /* DO gets the most radically altered syntax
748 (do ((<var1> <init1> <step1>)
754 (do_mem (varn ... var2 var1)
755 (<init1> <init2> ... <initn>)
758 <step1> <step2> ... <stepn>) ;; missing steps replaced by var
761 SCM_SYNTAX(s_do
, "do", scm_makmmacro
, scm_m_do
);
762 SCM_GLOBAL_SYMBOL(scm_sym_do
, s_do
);
765 scm_m_do (SCM xorig
, SCM env
)
767 SCM x
= SCM_CDR (xorig
), arg1
, proc
;
768 SCM vars
= SCM_EOL
, inits
= SCM_EOL
, steps
= SCM_EOL
;
769 SCM
*initloc
= &inits
, *steploc
= &steps
;
770 int len
= scm_ilength (x
);
771 SCM_ASSYNT (len
>= 2, xorig
, scm_s_test
, "do");
773 SCM_ASSYNT (scm_ilength (proc
) >= 0, xorig
, scm_s_bindings
, "do");
774 while (SCM_NIMP(proc
))
776 arg1
= SCM_CAR (proc
);
777 len
= scm_ilength (arg1
);
778 SCM_ASSYNT (2 == len
|| 3 == len
, xorig
, scm_s_bindings
, "do");
779 SCM_ASSYNT (SCM_SYMBOLP (SCM_CAR (arg1
)), xorig
, scm_s_variable
, "do");
780 /* vars reversed here, inits and steps reversed at evaluation */
781 vars
= scm_cons (SCM_CAR (arg1
), vars
); /* variable */
782 arg1
= SCM_CDR (arg1
);
783 *initloc
= scm_cons (SCM_CAR (arg1
), SCM_EOL
); /* init */
784 initloc
= SCM_CDRLOC (*initloc
);
785 arg1
= SCM_CDR (arg1
);
786 *steploc
= scm_cons (SCM_IMP (arg1
) ? SCM_CAR (vars
) : SCM_CAR (arg1
), SCM_EOL
); /* step */
787 steploc
= SCM_CDRLOC (*steploc
);
788 proc
= SCM_CDR (proc
);
791 SCM_ASSYNT (scm_ilength (SCM_CAR (x
)) >= 1, xorig
, scm_s_test
, "do");
792 x
= scm_cons2 (SCM_CAR (x
), SCM_CDR (x
), steps
);
793 x
= scm_cons2 (vars
, inits
, x
);
794 bodycheck (xorig
, SCM_CARLOC (SCM_CDR (SCM_CDR (x
))), "do");
795 return scm_cons (SCM_IM_DO
, x
);
798 /* evalcar is small version of inline EVALCAR when we don't care about
801 #define evalcar scm_eval_car
804 static SCM
iqq (SCM form
, SCM env
, int depth
);
806 SCM_SYNTAX(s_quasiquote
, "quasiquote", scm_makacro
, scm_m_quasiquote
);
807 SCM_GLOBAL_SYMBOL(scm_sym_quasiquote
, s_quasiquote
);
810 scm_m_quasiquote (SCM xorig
, SCM env
)
812 SCM x
= SCM_CDR (xorig
);
813 SCM_ASSYNT (scm_ilength (x
) == 1, xorig
, scm_s_expression
, s_quasiquote
);
814 return iqq (SCM_CAR (x
), env
, 1);
819 iqq (SCM form
,SCM env
,int depth
)
825 if (SCM_VECTORP (form
))
827 long i
= SCM_LENGTH (form
);
828 SCM
*data
= SCM_VELTS (form
);
831 tmp
= scm_cons (data
[i
], tmp
);
832 return scm_vector (iqq (tmp
, env
, depth
));
834 if (SCM_NCONSP(form
))
836 tmp
= SCM_CAR (form
);
837 if (SCM_EQ_P (scm_sym_quasiquote
, tmp
))
842 if (SCM_EQ_P (scm_sym_unquote
, tmp
))
846 form
= SCM_CDR (form
);
847 SCM_ASSERT (SCM_ECONSP (form
) && SCM_NULLP (SCM_CDR (form
)),
848 form
, SCM_ARG1
, s_quasiquote
);
850 return evalcar (form
, env
);
851 return scm_cons2 (tmp
, iqq (SCM_CAR (form
), env
, depth
), SCM_EOL
);
853 if (SCM_NIMP (tmp
) && (SCM_EQ_P (scm_sym_uq_splicing
, SCM_CAR (tmp
))))
857 return scm_append (scm_cons2 (evalcar (tmp
, env
), iqq (SCM_CDR (form
), env
, depth
), SCM_EOL
));
859 return scm_cons (iqq (SCM_CAR (form
), env
, edepth
), iqq (SCM_CDR (form
), env
, depth
));
862 /* Here are acros which return values rather than code. */
864 SCM_SYNTAX (s_delay
, "delay", scm_makmmacro
, scm_m_delay
);
865 SCM_GLOBAL_SYMBOL (scm_sym_delay
, s_delay
);
868 scm_m_delay (SCM xorig
, SCM env
)
870 SCM_ASSYNT (scm_ilength (xorig
) == 2, xorig
, scm_s_expression
, s_delay
);
871 return scm_cons2 (SCM_IM_DELAY
, SCM_EOL
, SCM_CDR (xorig
));
875 SCM_SYNTAX(s_define
, "define", scm_makmmacro
, scm_m_define
);
876 SCM_GLOBAL_SYMBOL(scm_sym_define
, s_define
);
879 scm_m_define (SCM x
, SCM env
)
883 /* SCM_ASSYNT(SCM_NULLP(env), x, "bad placement", s_define);*/
884 SCM_ASSYNT (scm_ilength (x
) >= 2, arg1
, scm_s_expression
, s_define
);
887 while (SCM_CONSP (proc
))
888 { /* nested define syntax */
889 x
= scm_cons (scm_cons2 (scm_sym_lambda
, SCM_CDR (proc
), x
), SCM_EOL
);
890 proc
= SCM_CAR (proc
);
892 SCM_ASSYNT (SCM_SYMBOLP (proc
),
893 arg1
, scm_s_variable
, s_define
);
894 SCM_ASSYNT (1 == scm_ilength (x
), arg1
, scm_s_expression
, s_define
);
895 if (SCM_TOP_LEVEL (env
))
897 x
= evalcar (x
, env
);
898 #ifdef DEBUG_EXTENSIONS
899 if (SCM_REC_PROCNAMES_P
&& SCM_NIMP (x
))
903 if (SCM_CLOSUREP (arg1
)
904 /* Only the first definition determines the name. */
905 && SCM_FALSEP (scm_procedure_property (arg1
, scm_sym_name
)))
906 scm_set_procedure_property_x (arg1
, scm_sym_name
, proc
);
907 else if (SCM_TYP16 (arg1
) == scm_tc16_macro
908 && !SCM_EQ_P (SCM_CDR (arg1
), arg1
))
910 arg1
= SCM_CDR (arg1
);
915 arg1
= scm_sym2vcell (proc
, scm_env_top_level (env
), SCM_BOOL_T
);
918 if (SCM_NIMP (SCM_CDR (arg1
)) && (SCM_SNAME (SCM_CDR (arg1
)) == proc
)
919 && (SCM_CDR (arg1
) != x
))
920 scm_warn ("redefining built-in ", SCM_CHARS (proc
));
923 if (5 <= scm_verbose
&& SCM_UNDEFINED
!= SCM_CDR (arg1
))
924 scm_warn ("redefining ", SCM_CHARS (proc
));
926 SCM_SETCDR (arg1
, x
);
928 return scm_cons2 (scm_sym_quote
, SCM_CAR (arg1
), SCM_EOL
);
930 return SCM_UNSPECIFIED
;
933 return scm_cons2 (SCM_IM_DEFINE
, proc
, x
);
939 scm_m_letrec1 (SCM op
, SCM imm
, SCM xorig
, SCM env
)
941 SCM cdrx
= SCM_CDR (xorig
); /* locally mutable version of form */
942 char *what
= SCM_CHARS (SCM_CAR (xorig
));
943 SCM x
= cdrx
, proc
, arg1
; /* structure traversers */
944 SCM vars
= SCM_EOL
, inits
= SCM_EOL
, *initloc
= &inits
;
947 ASRTSYNTAX (scm_ilength (proc
) >= 1, scm_s_bindings
);
950 /* vars scm_list reversed here, inits reversed at evaluation */
951 arg1
= SCM_CAR (proc
);
952 ASRTSYNTAX (2 == scm_ilength (arg1
), scm_s_bindings
);
953 ASRTSYNTAX (SCM_SYMBOLP (SCM_CAR (arg1
)),
955 vars
= scm_cons (SCM_CAR (arg1
), vars
);
956 *initloc
= scm_cons (SCM_CAR (SCM_CDR (arg1
)), SCM_EOL
);
957 initloc
= SCM_CDRLOC (*initloc
);
959 while (SCM_NIMP (proc
= SCM_CDR (proc
)));
961 return scm_cons2 (op
, vars
,
962 scm_cons (inits
, scm_m_body (imm
, SCM_CDR (x
), what
)));
965 SCM_SYNTAX(s_letrec
, "letrec", scm_makmmacro
, scm_m_letrec
);
966 SCM_GLOBAL_SYMBOL(scm_sym_letrec
, s_letrec
);
969 scm_m_letrec (SCM xorig
, SCM env
)
971 SCM x
= SCM_CDR (xorig
);
972 SCM_ASSYNT (scm_ilength (x
) >= 2, xorig
, scm_s_body
, s_letrec
);
974 if (SCM_NULLP (SCM_CAR (x
))) /* null binding, let* faster */
975 return scm_m_letstar (scm_cons2 (SCM_CAR (xorig
), SCM_EOL
,
976 scm_m_body (SCM_IM_LETREC
,
981 return scm_m_letrec1 (SCM_IM_LETREC
, SCM_IM_LETREC
, xorig
, env
);
984 SCM_SYNTAX(s_let
, "let", scm_makmmacro
, scm_m_let
);
985 SCM_GLOBAL_SYMBOL(scm_sym_let
, s_let
);
988 scm_m_let (SCM xorig
, SCM env
)
990 SCM cdrx
= SCM_CDR (xorig
); /* locally mutable version of form */
991 SCM x
= cdrx
, proc
, arg1
, name
; /* structure traversers */
992 SCM vars
= SCM_EOL
, inits
= SCM_EOL
, *varloc
= &vars
, *initloc
= &inits
;
994 SCM_ASSYNT (scm_ilength (x
) >= 2, xorig
, scm_s_body
, s_let
);
998 && SCM_CONSP (SCM_CAR (proc
)) && SCM_NULLP (SCM_CDR (proc
))))
1000 /* null or single binding, let* is faster */
1001 return scm_m_letstar (scm_cons2 (SCM_CAR (xorig
), proc
,
1002 scm_m_body (SCM_IM_LET
,
1008 SCM_ASSYNT (SCM_NIMP (proc
), xorig
, scm_s_bindings
, s_let
);
1009 if (SCM_CONSP (proc
))
1011 /* plain let, proc is <bindings> */
1012 return scm_m_letrec1 (SCM_IM_LET
, SCM_IM_LET
, xorig
, env
);
1015 if (!SCM_SYMBOLP (proc
))
1016 scm_wta (xorig
, scm_s_bindings
, s_let
); /* bad let */
1017 name
= proc
; /* named let, build equiv letrec */
1019 SCM_ASSYNT (scm_ilength (x
) >= 2, xorig
, scm_s_body
, s_let
);
1020 proc
= SCM_CAR (x
); /* bindings list */
1021 SCM_ASSYNT (scm_ilength (proc
) >= 0, xorig
, scm_s_bindings
, s_let
);
1022 while (SCM_NIMP (proc
))
1023 { /* vars and inits both in order */
1024 arg1
= SCM_CAR (proc
);
1025 SCM_ASSYNT (2 == scm_ilength (arg1
), xorig
, scm_s_bindings
, s_let
);
1026 SCM_ASSYNT (SCM_SYMBOLP (SCM_CAR (arg1
)),
1027 xorig
, scm_s_variable
, s_let
);
1028 *varloc
= scm_cons (SCM_CAR (arg1
), SCM_EOL
);
1029 varloc
= SCM_CDRLOC (*varloc
);
1030 *initloc
= scm_cons (SCM_CAR (SCM_CDR (arg1
)), SCM_EOL
);
1031 initloc
= SCM_CDRLOC (*initloc
);
1032 proc
= SCM_CDR (proc
);
1035 proc
= scm_cons2 (scm_sym_lambda
, vars
,
1036 scm_m_body (SCM_IM_LET
, SCM_CDR (x
), "let"));
1037 proc
= scm_cons2 (scm_sym_let
, scm_cons (scm_cons2 (name
, proc
, SCM_EOL
),
1039 scm_acons (name
, inits
, SCM_EOL
));
1040 return scm_m_letrec1 (SCM_IM_LETREC
, SCM_IM_LET
, proc
, env
);
1044 SCM_SYNTAX (s_atapply
,"@apply", scm_makmmacro
, scm_m_apply
);
1045 SCM_GLOBAL_SYMBOL (scm_sym_atapply
, s_atapply
);
1046 SCM_GLOBAL_SYMBOL (scm_sym_apply
, s_atapply
+ 1);
1049 scm_m_apply (SCM xorig
, SCM env
)
1051 SCM_ASSYNT (scm_ilength (SCM_CDR (xorig
)) == 2,
1052 xorig
, scm_s_expression
, s_atapply
);
1053 return scm_cons (SCM_IM_APPLY
, SCM_CDR (xorig
));
1057 SCM_SYNTAX(s_atcall_cc
,"@call-with-current-continuation", scm_makmmacro
, scm_m_cont
);
1058 SCM_GLOBAL_SYMBOL(scm_sym_atcall_cc
,s_atcall_cc
);
1062 scm_m_cont (SCM xorig
, SCM env
)
1064 SCM_ASSYNT (scm_ilength (SCM_CDR (xorig
)) == 1,
1065 xorig
, scm_s_expression
, s_atcall_cc
);
1066 return scm_cons (SCM_IM_CONT
, SCM_CDR (xorig
));
1069 /* Multi-language support */
1074 SCM_SYNTAX (s_nil_cond
, "nil-cond", scm_makmmacro
, scm_m_nil_cond
);
1077 scm_m_nil_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
, "nil-cond");
1082 return scm_cons (SCM_IM_NIL_COND
, SCM_CDR (xorig
));
1085 SCM_SYNTAX (s_nil_ify
, "nil-ify", scm_makmmacro
, scm_m_nil_ify
);
1088 scm_m_nil_ify (SCM xorig
, SCM env
)
1090 SCM_ASSYNT (scm_ilength (SCM_CDR (xorig
)) == 1,
1091 xorig
, scm_s_expression
, "nil-ify");
1092 return scm_cons (SCM_IM_NIL_IFY
, SCM_CDR (xorig
));
1095 SCM_SYNTAX (s_t_ify
, "t-ify", scm_makmmacro
, scm_m_t_ify
);
1098 scm_m_t_ify (SCM xorig
, SCM env
)
1100 SCM_ASSYNT (scm_ilength (SCM_CDR (xorig
)) == 1,
1101 xorig
, scm_s_expression
, "t-ify");
1102 return scm_cons (SCM_IM_T_IFY
, SCM_CDR (xorig
));
1105 SCM_SYNTAX (s_0_cond
, "0-cond", scm_makmmacro
, scm_m_0_cond
);
1108 scm_m_0_cond (SCM xorig
, SCM env
)
1110 int len
= scm_ilength (SCM_CDR (xorig
));
1111 SCM_ASSYNT (len
>= 1 && (len
& 1) == 1, xorig
,
1112 scm_s_expression
, "0-cond");
1113 return scm_cons (SCM_IM_0_COND
, SCM_CDR (xorig
));
1116 SCM_SYNTAX (s_0_ify
, "0-ify", scm_makmmacro
, scm_m_0_ify
);
1119 scm_m_0_ify (SCM xorig
, SCM env
)
1121 SCM_ASSYNT (scm_ilength (SCM_CDR (xorig
)) == 1,
1122 xorig
, scm_s_expression
, "0-ify");
1123 return scm_cons (SCM_IM_0_IFY
, SCM_CDR (xorig
));
1126 SCM_SYNTAX (s_1_ify
, "1-ify", scm_makmmacro
, scm_m_1_ify
);
1129 scm_m_1_ify (SCM xorig
, SCM env
)
1131 SCM_ASSYNT (scm_ilength (SCM_CDR (xorig
)) == 1,
1132 xorig
, scm_s_expression
, "1-ify");
1133 return scm_cons (SCM_IM_1_IFY
, SCM_CDR (xorig
));
1136 SCM_SYNTAX (s_atfop
, "@fop", scm_makmmacro
, scm_m_atfop
);
1139 scm_m_atfop (SCM xorig
, SCM env
)
1141 SCM x
= SCM_CDR (xorig
), vcell
;
1142 SCM_ASSYNT (scm_ilength (x
) >= 1, xorig
, scm_s_expression
, "@fop");
1143 vcell
= scm_symbol_fref (SCM_CAR (x
));
1144 SCM_ASSYNT (SCM_CONSP (vcell
), x
,
1145 "Symbol's function definition is void", NULL
);
1146 SCM_SET_CELL_WORD_0 (x
, SCM_UNPACK (vcell
) + scm_tc3_cons_gloc
);
1150 SCM_SYNTAX (s_atbind
, "@bind", scm_makmmacro
, scm_m_atbind
);
1153 scm_m_atbind (SCM xorig
, SCM env
)
1155 SCM x
= SCM_CDR (xorig
);
1156 SCM_ASSYNT (scm_ilength (x
) > 1, xorig
, scm_s_expression
, "@bind");
1162 while (SCM_NIMP (SCM_CDR (env
)))
1163 env
= SCM_CDR (env
);
1164 env
= SCM_CAR (env
);
1165 if (SCM_CONSP (env
))
1170 while (SCM_NIMP (x
))
1172 SCM_SET_CELL_WORD_0 (x
, SCM_UNPACK (scm_sym2vcell (SCM_CAR (x
), env
, SCM_BOOL_T
)) + scm_tc3_cons_gloc
);
1175 return scm_cons (SCM_IM_BIND
, SCM_CDR (xorig
));
1179 scm_m_expand_body (SCM xorig
, SCM env
)
1181 SCM form
, x
= SCM_CDR (xorig
), defs
= SCM_EOL
;
1182 char *what
= SCM_ISYMCHARS (SCM_CAR (xorig
)) + 2;
1184 while (SCM_NIMP (x
))
1187 if (SCM_IMP (form
) || SCM_NCONSP (form
))
1189 if (SCM_IMP (SCM_CAR (form
)))
1191 if (!SCM_SYMBOLP (SCM_CAR (form
)))
1194 form
= scm_macroexp (scm_cons_source (form
,
1199 if (SCM_EQ_P (SCM_IM_DEFINE
, SCM_CAR (form
)))
1201 defs
= scm_cons (SCM_CDR (form
), defs
);
1204 else if (SCM_NIMP(defs
))
1208 else if (SCM_EQ_P (SCM_IM_BEGIN
, SCM_CAR (form
)))
1210 x
= scm_append (scm_cons2 (SCM_CDR (form
), SCM_CDR (x
), SCM_EOL
));
1214 x
= scm_cons (form
, SCM_CDR(x
));
1219 SCM_ASSYNT (SCM_NIMP (x
), SCM_CDR (xorig
), scm_s_body
, what
);
1220 if (SCM_NIMP (defs
))
1222 x
= scm_cons (scm_m_letrec1 (SCM_IM_LETREC
,
1224 scm_cons2 (scm_sym_define
, defs
, x
),
1230 SCM_SETCAR (xorig
, SCM_CAR (x
));
1231 SCM_SETCDR (xorig
, SCM_CDR (x
));
1238 scm_macroexp (SCM x
, SCM env
)
1242 /* Don't bother to produce error messages here. We get them when we
1243 eventually execute the code for real. */
1246 if (SCM_IMP (SCM_CAR (x
)) || !SCM_SYMBOLP (SCM_CAR (x
)))
1251 SCM
*proc_ptr
= scm_lookupcar1 (x
, env
, 0);
1252 if (proc_ptr
== NULL
)
1254 /* We have lost the race. */
1260 proc
= *scm_lookupcar (x
, env
, 0);
1263 /* Only handle memoizing macros. `Acros' and `macros' are really
1264 special forms and should not be evaluated here. */
1267 || scm_tc16_macro
!= SCM_TYP16 (proc
)
1268 || (int) (SCM_UNPACK_CAR (proc
) >> 16) != 2)
1272 res
= scm_apply (SCM_CDR (proc
), x
, scm_cons (env
, scm_listofnull
));
1274 if (scm_ilength (res
) <= 0)
1275 res
= scm_cons2 (SCM_IM_BEGIN
, res
, SCM_EOL
);
1278 SCM_SETCAR (x
, SCM_CAR (res
));
1279 SCM_SETCDR (x
, SCM_CDR (res
));
1285 /* scm_unmemocopy takes a memoized expression together with its
1286 * environment and rewrites it to its original form. Thus, it is the
1287 * inversion of the rewrite rules above. The procedure is not
1288 * optimized for speed. It's used in scm_iprin1 when printing the
1289 * code of a closure, in scm_procedure_source, in display_frame when
1290 * generating the source for a stackframe in a backtrace, and in
1291 * display_expression.
1294 /* We should introduce an anti-macro interface so that it is possible
1295 * to plug in transformers in both directions from other compilation
1296 * units. unmemocopy could then dispatch to anti-macro transformers.
1297 * (Those transformers could perhaps be written in slightly more
1298 * readable style... :)
1301 #define SCM_BIT8(x) (127 & SCM_UNPACK (x))
1304 unmemocopy (SCM x
, SCM env
)
1307 #ifdef DEBUG_EXTENSIONS
1310 if (SCM_NCELLP (x
) || SCM_NECONSP (x
))
1312 #ifdef DEBUG_EXTENSIONS
1313 p
= scm_whash_lookup (scm_source_whash
, x
);
1315 switch (SCM_TYP7 (x
))
1317 case SCM_BIT8(SCM_IM_AND
):
1318 ls
= z
= scm_cons (scm_sym_and
, SCM_UNSPECIFIED
);
1320 case SCM_BIT8(SCM_IM_BEGIN
):
1321 ls
= z
= scm_cons (scm_sym_begin
, SCM_UNSPECIFIED
);
1323 case SCM_BIT8(SCM_IM_CASE
):
1324 ls
= z
= scm_cons (scm_sym_case
, SCM_UNSPECIFIED
);
1326 case SCM_BIT8(SCM_IM_COND
):
1327 ls
= z
= scm_cons (scm_sym_cond
, SCM_UNSPECIFIED
);
1329 case SCM_BIT8(SCM_IM_DO
):
1330 ls
= scm_cons (scm_sym_do
, SCM_UNSPECIFIED
);
1332 case SCM_BIT8(SCM_IM_IF
):
1333 ls
= z
= scm_cons (scm_sym_if
, SCM_UNSPECIFIED
);
1335 case SCM_BIT8(SCM_IM_LET
):
1336 ls
= scm_cons (scm_sym_let
, SCM_UNSPECIFIED
);
1338 case SCM_BIT8(SCM_IM_LETREC
):
1341 ls
= scm_cons (scm_sym_letrec
, SCM_UNSPECIFIED
);
1345 f
= v
= SCM_CAR (x
);
1347 z
= EXTEND_ENV (f
, SCM_EOL
, env
);
1349 e
= scm_reverse (unmemocopy (SCM_CAR (x
),
1350 SCM_EQ_P (SCM_CAR (ls
), scm_sym_letrec
) ? z
: env
));
1353 s
= SCM_EQ_P (SCM_CAR (ls
), scm_sym_do
)
1354 ? scm_reverse (unmemocopy (SCM_CDR (SCM_CDR (SCM_CDR (x
))), env
))
1356 /* build transformed binding list */
1360 z
= scm_acons (SCM_CAR (v
),
1361 scm_cons (SCM_CAR (e
),
1362 SCM_EQ_P (SCM_CAR (s
), SCM_CAR (v
))
1364 : scm_cons (SCM_CAR (s
), SCM_EOL
)),
1370 while (SCM_NIMP (v
));
1371 z
= scm_cons (z
, SCM_UNSPECIFIED
);
1373 if (SCM_EQ_P (SCM_CAR (ls
), scm_sym_do
))
1377 SCM_SETCDR (z
, scm_cons (unmemocopy (SCM_CAR (x
), env
),
1380 x
= (SCM
) (SCM_CARLOC (SCM_CDR (x
)) - 1);
1381 /* body forms are now to be found in SCM_CDR (x)
1382 (this is how *real* code look like! :) */
1386 case SCM_BIT8(SCM_IM_LETSTAR
):
1394 env
= EXTEND_ENV (SCM_EOL
, SCM_EOL
, env
);
1397 y
= z
= scm_acons (SCM_CAR (b
),
1399 scm_cons (unmemocopy (SCM_CAR (SCM_CDR (b
)), env
), SCM_EOL
), env
),
1401 env
= EXTEND_ENV (SCM_CAR (b
), SCM_BOOL_F
, env
);
1402 b
= SCM_CDR (SCM_CDR (b
));
1405 SCM_SETCDR (y
, SCM_EOL
);
1406 ls
= scm_cons (scm_sym_let
, z
= scm_cons (y
, SCM_UNSPECIFIED
));
1411 SCM_SETCDR (z
, scm_acons (SCM_CAR (b
),
1413 scm_cons (unmemocopy (SCM_CAR (SCM_CDR (b
)), env
), SCM_EOL
), env
),
1416 env
= EXTEND_ENV (SCM_CAR (b
), SCM_BOOL_F
, env
);
1417 b
= SCM_CDR (SCM_CDR (b
));
1419 while (SCM_NIMP (b
));
1420 SCM_SETCDR (z
, SCM_EOL
);
1422 ls
= scm_cons (scm_sym_letstar
, z
= scm_cons (y
, SCM_UNSPECIFIED
));
1425 case SCM_BIT8(SCM_IM_OR
):
1426 ls
= z
= scm_cons (scm_sym_or
, SCM_UNSPECIFIED
);
1428 case SCM_BIT8(SCM_IM_LAMBDA
):
1430 ls
= scm_cons (scm_sym_lambda
,
1431 z
= scm_cons (SCM_CAR (x
), SCM_UNSPECIFIED
));
1432 env
= EXTEND_ENV (SCM_CAR (x
), SCM_EOL
, env
);
1434 case SCM_BIT8(SCM_IM_QUOTE
):
1435 ls
= z
= scm_cons (scm_sym_quote
, SCM_UNSPECIFIED
);
1437 case SCM_BIT8(SCM_IM_SET_X
):
1438 ls
= z
= scm_cons (scm_sym_set_x
, SCM_UNSPECIFIED
);
1440 case SCM_BIT8(SCM_IM_DEFINE
):
1444 ls
= scm_cons (scm_sym_define
,
1445 z
= scm_cons (n
= SCM_CAR (x
), SCM_UNSPECIFIED
));
1446 if (SCM_NNULLP (env
))
1447 SCM_SETCAR (SCM_CAR (env
), scm_cons (n
, SCM_CAR (SCM_CAR (env
))));
1450 case SCM_BIT8(SCM_MAKISYM (0)):
1454 switch (SCM_ISYMNUM (z
))
1456 case (SCM_ISYMNUM (SCM_IM_APPLY
)):
1457 ls
= z
= scm_cons (scm_sym_atapply
, SCM_UNSPECIFIED
);
1459 case (SCM_ISYMNUM (SCM_IM_CONT
)):
1460 ls
= z
= scm_cons (scm_sym_atcall_cc
, SCM_UNSPECIFIED
);
1462 case (SCM_ISYMNUM (SCM_IM_DELAY
)):
1463 ls
= z
= scm_cons (scm_sym_delay
, SCM_UNSPECIFIED
);
1467 /* appease the Sun compiler god: */ ;
1471 ls
= z
= unmemocar (scm_cons (unmemocopy (SCM_CAR (x
), env
),
1476 while (SCM_CELLP (x
= SCM_CDR (x
)) && SCM_ECONSP (x
))
1478 if (SCM_IMP (SCM_CAR (x
)) && SCM_ISYMP (SCM_CAR (x
)))
1479 /* skip body markers */
1481 SCM_SETCDR (z
, unmemocar (scm_cons (unmemocopy (SCM_CAR (x
), env
),
1487 #ifdef DEBUG_EXTENSIONS
1488 if (SCM_NFALSEP (p
))
1489 scm_whash_insert (scm_source_whash
, ls
, p
);
1496 scm_unmemocopy (SCM x
, SCM env
)
1498 if (SCM_NNULLP (env
))
1499 /* Make a copy of the lowest frame to protect it from
1500 modifications by SCM_IM_DEFINE */
1501 return unmemocopy (x
, scm_cons (SCM_CAR (env
), SCM_CDR (env
)));
1503 return unmemocopy (x
, env
);
1506 #ifndef SCM_RECKLESS
1509 scm_badargsp (SCM formals
, SCM args
)
1511 while (SCM_NIMP (formals
))
1513 if (SCM_NCONSP (formals
))
1517 formals
= SCM_CDR (formals
);
1518 args
= SCM_CDR (args
);
1520 return SCM_NNULLP (args
) ? 1 : 0;
1527 scm_eval_args (SCM l
, SCM env
, SCM proc
)
1529 SCM results
= SCM_EOL
, *lloc
= &results
, res
;
1530 while (SCM_NIMP (l
))
1535 else if (SCM_CONSP (l
))
1537 if (SCM_IMP (SCM_CAR (l
)))
1538 res
= SCM_EVALIM (SCM_CAR (l
), env
);
1540 res
= EVALCELLCAR (l
, env
);
1542 else if (SCM_TYP3 (l
) == scm_tc3_cons_gloc
)
1544 scm_bits_t vcell
= SCM_STRUCT_VTABLE_DATA (l
) [scm_vtable_index_vcell
];
1546 res
= SCM_CAR (l
); /* struct planted in code */
1548 res
= SCM_PACK (vcell
);
1553 res
= EVALCAR (l
, env
);
1555 *lloc
= scm_cons (res
, SCM_EOL
);
1556 lloc
= SCM_CDRLOC (*lloc
);
1563 scm_wrong_num_args (proc
);
1570 scm_eval_body (SCM code
, SCM env
)
1575 while (SCM_NNULLP (next
= SCM_CDR (next
)))
1577 if (SCM_IMP (SCM_CAR (code
)))
1579 if (SCM_ISYMP (SCM_CAR (code
)))
1581 code
= scm_m_expand_body (code
, env
);
1586 SCM_XEVAL (SCM_CAR (code
), env
);
1589 return SCM_XEVALCAR (code
, env
);
1596 /* SECTION: This code is specific for the debugging support. One
1597 * branch is read when DEVAL isn't defined, the other when DEVAL is
1603 #define SCM_APPLY scm_apply
1604 #define PREP_APPLY(proc, args)
1606 #define RETURN(x) return x;
1607 #ifdef STACK_CHECKING
1608 #ifndef NO_CEVAL_STACK_CHECKING
1609 #define EVAL_STACK_CHECKING
1616 #define SCM_CEVAL scm_deval /* Substitute all uses of scm_ceval */
1618 #define SCM_APPLY scm_dapply
1620 #define PREP_APPLY(p, l) \
1621 { ++debug.info; debug.info->a.proc = p; debug.info->a.args = l; }
1623 #define ENTER_APPLY \
1625 SCM_SET_ARGSREADY (debug);\
1626 if (CHECK_APPLY && SCM_TRAPS_P)\
1627 if (SCM_APPLY_FRAME_P || (SCM_TRACE_P && PROCTRACEP (proc)))\
1629 SCM tmp, tail = SCM_BOOL(SCM_TRACED_FRAME_P (debug)); \
1630 SCM_SET_TRACED_FRAME (debug); \
1631 if (SCM_CHEAPTRAPS_P)\
1633 tmp = scm_make_debugobj (&debug);\
1634 scm_ithrow (scm_sym_apply_frame, scm_cons2 (tmp, tail, SCM_EOL), 0);\
1638 scm_make_cont (&tmp);\
1639 if (!setjmp (SCM_JMPBUF (tmp)))\
1640 scm_ithrow (scm_sym_apply_frame, scm_cons2 (tmp, tail, SCM_EOL), 0);\
1645 #define RETURN(e) {proc = (e); goto exit;}
1646 #ifdef STACK_CHECKING
1647 #ifndef EVAL_STACK_CHECKING
1648 #define EVAL_STACK_CHECKING
1652 /* scm_ceval_ptr points to the currently selected evaluator.
1653 * *fixme*: Although efficiency is important here, this state variable
1654 * should probably not be a global. It should be related to the
1659 SCM (*scm_ceval_ptr
) (SCM x
, SCM env
);
1661 /* scm_last_debug_frame contains a pointer to the last debugging
1662 * information stack frame. It is accessed very often from the
1663 * debugging evaluator, so it should probably not be indirectly
1664 * addressed. Better to save and restore it from the current root at
1669 scm_debug_frame
*scm_last_debug_frame
;
1672 /* scm_debug_eframe_size is the number of slots available for pseudo
1673 * stack frames at each real stack frame.
1676 int scm_debug_eframe_size
;
1678 int scm_debug_mode
, scm_check_entry_p
, scm_check_apply_p
, scm_check_exit_p
;
1682 scm_option scm_eval_opts
[] = {
1683 { SCM_OPTION_INTEGER
, "stack", 22000, "Size of thread stacks (in machine words)." }
1686 scm_option scm_debug_opts
[] = {
1687 { SCM_OPTION_BOOLEAN
, "cheap", 1,
1688 "*Flyweight representation of the stack at traps." },
1689 { SCM_OPTION_BOOLEAN
, "breakpoints", 0, "*Check for breakpoints." },
1690 { SCM_OPTION_BOOLEAN
, "trace", 0, "*Trace mode." },
1691 { SCM_OPTION_BOOLEAN
, "procnames", 1,
1692 "Record procedure names at definition." },
1693 { SCM_OPTION_BOOLEAN
, "backwards", 0,
1694 "Display backtrace in anti-chronological order." },
1695 { SCM_OPTION_INTEGER
, "width", 79, "Maximal width of backtrace." },
1696 { SCM_OPTION_INTEGER
, "indent", 10, "Maximal indentation in backtrace." },
1697 { SCM_OPTION_INTEGER
, "frames", 3,
1698 "Maximum number of tail-recursive frames in backtrace." },
1699 { SCM_OPTION_INTEGER
, "maxdepth", 1000,
1700 "Maximal number of stored backtrace frames." },
1701 { SCM_OPTION_INTEGER
, "depth", 20, "Maximal length of printed backtrace." },
1702 { SCM_OPTION_BOOLEAN
, "backtrace", 0, "Show backtrace on error." },
1703 { SCM_OPTION_BOOLEAN
, "debug", 0, "Use the debugging evaluator." },
1704 { SCM_OPTION_INTEGER
, "stack", 20000, "Stack size limit (measured in words; 0 = no check)." }
1707 scm_option scm_evaluator_trap_table
[] = {
1708 { SCM_OPTION_BOOLEAN
, "traps", 0, "Enable evaluator traps." },
1709 { SCM_OPTION_BOOLEAN
, "enter-frame", 0, "Trap when eval enters new frame." },
1710 { SCM_OPTION_BOOLEAN
, "apply-frame", 0, "Trap when entering apply." },
1711 { SCM_OPTION_BOOLEAN
, "exit-frame", 0, "Trap when exiting eval or apply." }
1714 SCM_DEFINE (scm_eval_options_interface
, "eval-options-interface", 0, 1, 0,
1717 #define FUNC_NAME s_scm_eval_options_interface
1721 ans
= scm_options (setting
,
1725 scm_eval_stack
= SCM_EVAL_STACK
* sizeof (void *);
1731 SCM_DEFINE (scm_evaluator_traps
, "evaluator-traps-interface", 0, 1, 0,
1734 #define FUNC_NAME s_scm_evaluator_traps
1738 ans
= scm_options (setting
,
1739 scm_evaluator_trap_table
,
1740 SCM_N_EVALUATOR_TRAPS
,
1742 SCM_RESET_DEBUG_MODE
;
1749 scm_deval_args (SCM l
, SCM env
, SCM proc
, SCM
*lloc
)
1751 SCM
*results
= lloc
, res
;
1752 while (SCM_NIMP (l
))
1757 else if (SCM_CONSP (l
))
1759 if (SCM_IMP (SCM_CAR (l
)))
1760 res
= SCM_EVALIM (SCM_CAR (l
), env
);
1762 res
= EVALCELLCAR (l
, env
);
1764 else if (SCM_TYP3 (l
) == scm_tc3_cons_gloc
)
1766 scm_bits_t vcell
= SCM_STRUCT_VTABLE_DATA (l
) [scm_vtable_index_vcell
];
1768 res
= SCM_CAR (l
); /* struct planted in code */
1770 res
= SCM_PACK (vcell
);
1775 res
= EVALCAR (l
, env
);
1777 *lloc
= scm_cons (res
, SCM_EOL
);
1778 lloc
= SCM_CDRLOC (*lloc
);
1785 scm_wrong_num_args (proc
);
1794 /* SECTION: Some local definitions for the evaluator.
1798 #define CHECK_EQVISH(A,B) (SCM_EQ_P ((A), (B)) || (SCM_NFALSEP (scm_eqv_p ((A), (B)))))
1801 #define BUILTIN_RPASUBR /* Handle rpsubrs and asubrs without calling apply */
1803 /* SECTION: This is the evaluator. Like any real monster, it has
1804 * three heads. This code is compiled twice.
1810 scm_ceval (SCM x
, SCM env
)
1816 scm_deval (SCM x
, SCM env
)
1821 SCM_CEVAL (SCM x
, SCM env
)
1830 scm_debug_frame debug
;
1831 scm_debug_info
*debug_info_end
;
1832 debug
.prev
= scm_last_debug_frame
;
1833 debug
.status
= scm_debug_eframe_size
;
1835 * The debug.vect contains twice as much scm_debug_info frames as the
1836 * user has specified with (debug-set! frames <n>).
1838 * Even frames are eval frames, odd frames are apply frames.
1840 debug
.vect
= (scm_debug_info
*) alloca (scm_debug_eframe_size
1841 * sizeof (debug
.vect
[0]));
1842 debug
.info
= debug
.vect
;
1843 debug_info_end
= debug
.vect
+ scm_debug_eframe_size
;
1844 scm_last_debug_frame
= &debug
;
1846 #ifdef EVAL_STACK_CHECKING
1847 if (scm_stack_checking_enabled_p
1848 && SCM_STACK_OVERFLOW_P ((SCM_STACKITEM
*) &proc
))
1851 debug
.info
->e
.exp
= x
;
1852 debug
.info
->e
.env
= env
;
1854 scm_report_stack_overflow ();
1861 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
1864 SCM_CLEAR_ARGSREADY (debug
);
1865 if (SCM_OVERFLOWP (debug
))
1868 * In theory, this should be the only place where it is necessary to
1869 * check for space in debug.vect since both eval frames and
1870 * available space are even.
1872 * For this to be the case, however, it is necessary that primitive
1873 * special forms which jump back to `loop', `begin' or some similar
1874 * label call PREP_APPLY. A convenient way to do this is to jump to
1875 * `loopnoap' or `cdrxnoap'.
1877 else if (++debug
.info
>= debug_info_end
)
1879 SCM_SET_OVERFLOW (debug
);
1883 debug
.info
->e
.exp
= x
;
1884 debug
.info
->e
.env
= env
;
1885 if (CHECK_ENTRY
&& SCM_TRAPS_P
)
1886 if (SCM_ENTER_FRAME_P
|| (SCM_BREAKPOINTS_P
&& SRCBRKP (x
)))
1888 SCM tail
= SCM_BOOL(SCM_TAILRECP (debug
));
1889 SCM_SET_TAILREC (debug
);
1890 if (SCM_CHEAPTRAPS_P
)
1891 t
.arg1
= scm_make_debugobj (&debug
);
1894 scm_make_cont (&t
.arg1
);
1895 if (setjmp (SCM_JMPBUF (t
.arg1
)))
1897 x
= SCM_THROW_VALUE (t
.arg1
);
1903 /* This gives the possibility for the debugger to
1904 modify the source expression before evaluation. */
1908 scm_ithrow (scm_sym_enter_frame
,
1909 scm_cons2 (t
.arg1
, tail
,
1910 scm_cons (scm_unmemocopy (x
, env
), SCM_EOL
)),
1914 #if defined (USE_THREADS) || defined (DEVAL)
1918 switch (SCM_TYP7 (x
))
1920 case scm_tcs_symbols
:
1921 /* Only happens when called at top level.
1923 x
= scm_cons (x
, SCM_UNDEFINED
);
1926 case SCM_BIT8(SCM_IM_AND
):
1929 while (SCM_NNULLP (t
.arg1
= SCM_CDR (t
.arg1
)))
1930 if (SCM_FALSEP (EVALCAR (x
, env
)))
1932 RETURN (SCM_BOOL_F
);
1936 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
1939 case SCM_BIT8(SCM_IM_BEGIN
):
1941 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
1947 while (SCM_NNULLP (t
.arg1
= SCM_CDR (t
.arg1
)))
1949 if (SCM_IMP (SCM_CAR (x
)))
1951 if (SCM_ISYMP (SCM_CAR (x
)))
1953 x
= scm_m_expand_body (x
, env
);
1958 SCM_CEVAL (SCM_CAR (x
), env
);
1962 carloop
: /* scm_eval car of last form in list */
1963 if (SCM_NCELLP (SCM_CAR (x
)))
1966 RETURN (SCM_IMP (x
) ? SCM_EVALIM (x
, env
) : SCM_GLOC_VAL (x
))
1969 if (SCM_SYMBOLP (SCM_CAR (x
)))
1972 RETURN (*scm_lookupcar (x
, env
, 1))
1976 goto loop
; /* tail recurse */
1979 case SCM_BIT8(SCM_IM_CASE
):
1981 t
.arg1
= EVALCAR (x
, env
);
1982 while (SCM_NIMP (x
= SCM_CDR (x
)))
1985 if (SCM_EQ_P (scm_sym_else
, SCM_CAR (proc
)))
1988 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
1991 proc
= SCM_CAR (proc
);
1992 while (SCM_NIMP (proc
))
1994 if (CHECK_EQVISH (SCM_CAR (proc
), t
.arg1
))
1996 x
= SCM_CDR (SCM_CAR (x
));
1997 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
2000 proc
= SCM_CDR (proc
);
2003 RETURN (SCM_UNSPECIFIED
)
2006 case SCM_BIT8(SCM_IM_COND
):
2007 while (SCM_NIMP (x
= SCM_CDR (x
)))
2010 t
.arg1
= EVALCAR (proc
, env
);
2011 if (SCM_NFALSEP (t
.arg1
))
2018 if (! SCM_EQ_P (scm_sym_arrow
, SCM_CAR (x
)))
2020 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
2024 proc
= EVALCAR (proc
, env
);
2025 SCM_ASRTGO (SCM_NIMP (proc
), badfun
);
2026 PREP_APPLY (proc
, scm_cons (t
.arg1
, SCM_EOL
));
2031 RETURN (SCM_UNSPECIFIED
)
2034 case SCM_BIT8(SCM_IM_DO
):
2036 proc
= SCM_CAR (SCM_CDR (x
)); /* inits */
2037 t
.arg1
= SCM_EOL
; /* values */
2038 while (SCM_NIMP (proc
))
2040 t
.arg1
= scm_cons (EVALCAR (proc
, env
), t
.arg1
);
2041 proc
= SCM_CDR (proc
);
2043 env
= EXTEND_ENV (SCM_CAR (x
), t
.arg1
, env
);
2044 x
= SCM_CDR (SCM_CDR (x
));
2045 while (proc
= SCM_CAR (x
), SCM_FALSEP (EVALCAR (proc
, env
)))
2047 for (proc
= SCM_CADR (x
); SCM_NIMP (proc
); proc
= SCM_CDR (proc
))
2049 t
.arg1
= SCM_CAR (proc
); /* body */
2050 SIDEVAL (t
.arg1
, env
);
2052 for (t
.arg1
= SCM_EOL
, proc
= SCM_CDDR (x
);
2054 proc
= SCM_CDR (proc
))
2055 t
.arg1
= scm_cons (EVALCAR (proc
, env
), t
.arg1
); /* steps */
2056 env
= EXTEND_ENV (SCM_CAR (SCM_CAR (env
)), t
.arg1
, SCM_CDR (env
));
2060 RETURN (SCM_UNSPECIFIED
);
2061 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
2065 case SCM_BIT8(SCM_IM_IF
):
2067 if (SCM_NFALSEP (EVALCAR (x
, env
)))
2069 else if (SCM_IMP (x
= SCM_CDR (SCM_CDR (x
))))
2071 RETURN (SCM_UNSPECIFIED
);
2073 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
2077 case SCM_BIT8(SCM_IM_LET
):
2079 proc
= SCM_CAR (SCM_CDR (x
));
2083 t
.arg1
= scm_cons (EVALCAR (proc
, env
), t
.arg1
);
2085 while (SCM_NIMP (proc
= SCM_CDR (proc
)));
2086 env
= EXTEND_ENV (SCM_CAR (x
), t
.arg1
, env
);
2091 case SCM_BIT8(SCM_IM_LETREC
):
2093 env
= EXTEND_ENV (SCM_CAR (x
), scm_undefineds
, env
);
2099 t
.arg1
= scm_cons (EVALCAR (proc
, env
), t
.arg1
);
2101 while (SCM_NIMP (proc
= SCM_CDR (proc
)));
2102 SCM_SETCDR (SCM_CAR (env
), t
.arg1
);
2106 case SCM_BIT8(SCM_IM_LETSTAR
):
2111 env
= EXTEND_ENV (SCM_EOL
, SCM_EOL
, env
);
2116 t
.arg1
= SCM_CAR (proc
);
2117 proc
= SCM_CDR (proc
);
2118 env
= EXTEND_ENV (t
.arg1
, EVALCAR (proc
, env
), env
);
2120 while (SCM_NIMP (proc
= SCM_CDR (proc
)));
2123 case SCM_BIT8(SCM_IM_OR
):
2126 while (SCM_NNULLP (t
.arg1
= SCM_CDR (t
.arg1
)))
2128 x
= EVALCAR (x
, env
);
2129 if (SCM_NFALSEP (x
))
2135 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
2139 case SCM_BIT8(SCM_IM_LAMBDA
):
2140 RETURN (scm_closure (SCM_CDR (x
), env
));
2143 case SCM_BIT8(SCM_IM_QUOTE
):
2144 RETURN (SCM_CAR (SCM_CDR (x
)));
2147 case SCM_BIT8(SCM_IM_SET_X
):
2150 switch (SCM_ITAG3 (proc
))
2153 t
.lloc
= scm_lookupcar (x
, env
, 1);
2155 case scm_tc3_cons_gloc
:
2156 t
.lloc
= SCM_GLOC_VAL_LOC (proc
);
2158 #ifdef MEMOIZE_LOCALS
2160 t
.lloc
= scm_ilookup (proc
, env
);
2165 *t
.lloc
= EVALCAR (x
, env
);
2169 RETURN (SCM_UNSPECIFIED
);
2173 case SCM_BIT8(SCM_IM_DEFINE
): /* only for internal defines */
2174 scm_misc_error (NULL
, "Bad define placement", SCM_EOL
);
2176 /* new syntactic forms go here. */
2177 case SCM_BIT8(SCM_MAKISYM (0)):
2179 SCM_ASRTGO (SCM_ISYMP (proc
), badfun
);
2180 switch SCM_ISYMNUM (proc
)
2183 case (SCM_ISYMNUM (IM_VREF
)):
2186 var
= SCM_CAR (SCM_CDR (x
));
2187 RETURN (SCM_CDR(var
));
2189 case (SCM_ISYMNUM (IM_VSET
)):
2190 SCM_CDR (SCM_CAR ( SCM_CDR (x
))) = EVALCAR( SCM_CDR ( SCM_CDR (x
)), env
);
2191 SCM_CAR (SCM_CAR ( SCM_CDR (x
))) = scm_tc16_variable
;
2192 RETURN (SCM_UNSPECIFIED
)
2195 case (SCM_ISYMNUM (SCM_IM_APPLY
)):
2197 proc
= EVALCAR (proc
, env
);
2198 SCM_ASRTGO (SCM_NIMP (proc
), badfun
);
2199 if (SCM_CLOSUREP (proc
))
2202 PREP_APPLY (proc
, SCM_EOL
);
2203 t
.arg1
= SCM_CDR (SCM_CDR (x
));
2204 t
.arg1
= EVALCAR (t
.arg1
, env
);
2206 debug
.info
->a
.args
= t
.arg1
;
2208 #ifndef SCM_RECKLESS
2209 if (scm_badargsp (SCM_CAR (SCM_CODE (proc
)), t
.arg1
))
2213 /* Copy argument list */
2214 if (SCM_IMP (t
.arg1
))
2218 argl
= tl
= scm_cons (SCM_CAR (t
.arg1
), SCM_UNSPECIFIED
);
2219 while (SCM_NIMP (t
.arg1
= SCM_CDR (t
.arg1
))
2220 && SCM_CONSP (t
.arg1
))
2222 SCM_SETCDR (tl
, scm_cons (SCM_CAR (t
.arg1
),
2226 SCM_SETCDR (tl
, t
.arg1
);
2229 env
= EXTEND_ENV (SCM_CAR (SCM_CODE (proc
)), argl
, SCM_ENV (proc
));
2230 x
= SCM_CODE (proc
);
2236 case (SCM_ISYMNUM (SCM_IM_CONT
)):
2237 scm_make_cont (&t
.arg1
);
2238 if (setjmp (SCM_JMPBUF (t
.arg1
)))
2241 val
= SCM_THROW_VALUE (t
.arg1
);
2245 proc
= evalcar (proc
, env
);
2246 SCM_ASRTGO (SCM_NIMP (proc
), badfun
);
2247 PREP_APPLY (proc
, scm_cons (t
.arg1
, SCM_EOL
));
2251 case (SCM_ISYMNUM (SCM_IM_DELAY
)):
2252 RETURN (scm_makprom (scm_closure (SCM_CDR (x
), env
)))
2254 case (SCM_ISYMNUM (SCM_IM_DISPATCH
)):
2255 proc
= SCM_CADR (x
); /* unevaluated operands */
2256 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
2258 arg2
= *scm_ilookup (proc
, env
);
2259 else if (SCM_NCONSP (proc
))
2261 if (SCM_NCELLP (proc
))
2262 arg2
= SCM_GLOC_VAL (proc
);
2264 arg2
= *scm_lookupcar (SCM_CDR (x
), env
, 1);
2268 arg2
= scm_cons (EVALCAR (proc
, env
), SCM_EOL
);
2269 t
.lloc
= SCM_CDRLOC (arg2
);
2270 while (SCM_NIMP (proc
= SCM_CDR (proc
)))
2272 *t
.lloc
= scm_cons (EVALCAR (proc
, env
), SCM_EOL
);
2273 t
.lloc
= SCM_CDRLOC (*t
.lloc
);
2278 /* The type dispatch code is duplicated here
2279 * (c.f. objects.c:scm_mcache_compute_cmethod) since that
2280 * cuts down execution time for type dispatch to 50%.
2283 int i
, n
, end
, mask
;
2284 SCM z
= SCM_CDDR (x
);
2285 n
= SCM_INUM (SCM_CAR (z
)); /* maximum number of specializers */
2286 proc
= SCM_CADR (z
);
2288 if (SCM_NIMP (proc
))
2290 /* Prepare for linear search */
2293 end
= SCM_LENGTH (proc
);
2297 /* Compute a hash value */
2298 int hashset
= SCM_INUM (proc
);
2300 mask
= SCM_INUM (SCM_CAR (z
= SCM_CDDR (z
)));
2301 proc
= SCM_CADR (z
);
2304 if (SCM_NIMP (t
.arg1
))
2307 i
+= SCM_STRUCT_DATA (scm_class_of (SCM_CAR (t
.arg1
)))
2308 [scm_si_hashsets
+ hashset
];
2309 t
.arg1
= SCM_CDR (t
.arg1
);
2311 while (--j
&& SCM_NIMP (t
.arg1
));
2316 /* Search for match */
2320 z
= SCM_VELTS (proc
)[i
];
2321 t
.arg1
= arg2
; /* list of arguments */
2322 if (SCM_NIMP (t
.arg1
))
2325 /* More arguments than specifiers => CLASS != ENV */
2326 if (! SCM_EQ_P (scm_class_of (SCM_CAR (t
.arg1
)), SCM_CAR (z
)))
2328 t
.arg1
= SCM_CDR (t
.arg1
);
2331 while (--j
&& SCM_NIMP (t
.arg1
));
2332 /* Fewer arguments than specifiers => CAR != ENV */
2333 if (!(SCM_IMP (SCM_CAR (z
)) || SCM_CONSP (SCM_CAR (z
))))
2336 env
= EXTEND_ENV (SCM_CAR (SCM_CMETHOD_CODE (z
)),
2338 SCM_CMETHOD_ENV (z
));
2339 x
= SCM_CMETHOD_CODE (z
);
2345 z
= scm_memoize_method (x
, arg2
);
2349 case (SCM_ISYMNUM (SCM_IM_SLOT_REF
)):
2351 t
.arg1
= EVALCAR (x
, env
);
2352 RETURN (SCM_PACK (SCM_STRUCT_DATA (t
.arg1
) [SCM_INUM (SCM_CADR (x
))]))
2354 case (SCM_ISYMNUM (SCM_IM_SLOT_SET_X
)):
2356 t
.arg1
= EVALCAR (x
, env
);
2359 SCM_STRUCT_DATA (t
.arg1
) [SCM_INUM (SCM_CAR (x
))]
2360 = SCM_UNPACK (EVALCAR (proc
, env
));
2361 RETURN (SCM_UNSPECIFIED
)
2363 case (SCM_ISYMNUM (SCM_IM_NIL_COND
)):
2365 while (SCM_NIMP (x
= SCM_CDR (proc
)))
2367 if (!(SCM_FALSEP (t
.arg1
= EVALCAR (proc
, env
))
2368 || SCM_EQ_P (t
.arg1
, scm_lisp_nil
)))
2370 if (SCM_EQ_P (SCM_CAR (x
), SCM_UNSPECIFIED
))
2372 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
2378 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
2381 case (SCM_ISYMNUM (SCM_IM_NIL_IFY
)):
2383 RETURN ((SCM_FALSEP (proc
= EVALCAR (x
, env
)) || SCM_NULLP (proc
))
2387 case (SCM_ISYMNUM (SCM_IM_T_IFY
)):
2389 RETURN (SCM_NFALSEP (EVALCAR (x
, env
)) ? scm_lisp_t
: scm_lisp_nil
)
2391 case (SCM_ISYMNUM (SCM_IM_0_COND
)):
2393 while (SCM_NIMP (x
= SCM_CDR (proc
)))
2395 if (!(SCM_FALSEP (t
.arg1
= EVALCAR (proc
, env
))
2396 || SCM_EQ_P (t
.arg1
, SCM_INUM0
)))
2398 if (SCM_EQ_P (SCM_CAR (x
), SCM_UNSPECIFIED
))
2400 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
2406 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
2409 case (SCM_ISYMNUM (SCM_IM_0_IFY
)):
2411 RETURN (SCM_FALSEP (proc
= EVALCAR (x
, env
))
2415 case (SCM_ISYMNUM (SCM_IM_1_IFY
)):
2417 RETURN (SCM_NFALSEP (EVALCAR (x
, env
))
2421 case (SCM_ISYMNUM (SCM_IM_BIND
)):
2424 t
.arg1
= SCM_CAR (x
);
2425 arg2
= SCM_CDAR (env
);
2426 while (SCM_NIMP (arg2
))
2428 proc
= SCM_GLOC_VAL (SCM_CAR (t
.arg1
));
2429 SCM_SETCDR (SCM_PACK (SCM_UNPACK (SCM_CAR (t
.arg1
)) - 1L),
2431 SCM_SETCAR (arg2
, proc
);
2432 t
.arg1
= SCM_CDR (t
.arg1
);
2433 arg2
= SCM_CDR (arg2
);
2435 t
.arg1
= SCM_CAR (x
);
2436 scm_dynwinds
= scm_acons (t
.arg1
, SCM_CDAR (env
), scm_dynwinds
);
2438 arg2
= x
= SCM_CDR (x
);
2439 while (SCM_NNULLP (arg2
= SCM_CDR (arg2
)))
2441 SIDEVAL (SCM_CAR (x
), env
);
2444 proc
= EVALCAR (x
, env
);
2446 scm_dynwinds
= SCM_CDR (scm_dynwinds
);
2447 arg2
= SCM_CDAR (env
);
2448 while (SCM_NIMP (arg2
))
2450 SCM_SETCDR (SCM_PACK (SCM_UNPACK (SCM_CAR (t
.arg1
)) - 1L),
2452 t
.arg1
= SCM_CDR (t
.arg1
);
2453 arg2
= SCM_CDR (arg2
);
2465 /* scm_everr (x, env,...) */
2466 scm_misc_error (NULL
,
2467 "Wrong type to apply: ~S",
2468 scm_listify (proc
, SCM_UNDEFINED
));
2469 case scm_tc7_vector
:
2473 case scm_tc7_byvect
:
2480 #ifdef HAVE_LONG_LONGS
2481 case scm_tc7_llvect
:
2484 case scm_tc7_string
:
2485 case scm_tc7_substring
:
2487 case scm_tcs_closures
:
2495 #ifdef MEMOIZE_LOCALS
2496 case SCM_BIT8(SCM_ILOC00
):
2497 proc
= *scm_ilookup (SCM_CAR (x
), env
);
2498 SCM_ASRTGO (SCM_NIMP (proc
), badfun
);
2499 #ifndef SCM_RECKLESS
2505 #endif /* ifdef MEMOIZE_LOCALS */
2508 case scm_tcs_cons_gloc
: {
2509 scm_bits_t vcell
= SCM_STRUCT_VTABLE_DATA (x
) [scm_vtable_index_vcell
];
2511 /* This is a struct implanted in the code, not a gloc. */
2514 proc
= SCM_PACK (vcell
);
2515 SCM_ASRTGO (SCM_NIMP (proc
), badfun
);
2516 #ifndef SCM_RECKLESS
2525 case scm_tcs_cons_nimcar
:
2526 if (SCM_SYMBOLP (SCM_CAR (x
)))
2529 t
.lloc
= scm_lookupcar1 (x
, env
, 1);
2532 /* we have lost the race, start again. */
2537 proc
= *scm_lookupcar (x
, env
, 1);
2545 if (scm_tc16_macro
== SCM_TYP16 (proc
))
2551 /* Set a flag during macro expansion so that macro
2552 application frames can be deleted from the backtrace. */
2553 SCM_SET_MACROEXP (debug
);
2555 t
.arg1
= SCM_APPLY (SCM_CDR (proc
), x
,
2556 scm_cons (env
, scm_listofnull
));
2559 SCM_CLEAR_MACROEXP (debug
);
2561 switch ((int) (SCM_UNPACK_CAR (proc
) >> 16))
2564 if (scm_ilength (t
.arg1
) <= 0)
2565 t
.arg1
= scm_cons2 (SCM_IM_BEGIN
, t
.arg1
, SCM_EOL
);
2567 if (!SCM_CLOSUREP (SCM_CDR (proc
)))
2570 #if 0 /* Top-level defines doesn't very often occur in backtraces */
2571 if (scm_m_define
== SCM_SUBRF (SCM_CDR (proc
)) && SCM_TOP_LEVEL (env
))
2572 /* Prevent memoizing result of define macro */
2574 debug
.info
->e
.exp
= scm_cons (SCM_CAR (x
), SCM_CDR (x
));
2575 scm_set_source_properties_x (debug
.info
->e
.exp
,
2576 scm_source_properties (x
));
2580 SCM_SETCAR (x
, SCM_CAR (t
.arg1
));
2581 SCM_SETCDR (x
, SCM_CDR (t
.arg1
));
2585 /* Prevent memoizing of debug info expression. */
2586 debug
.info
->e
.exp
= scm_cons_source (debug
.info
->e
.exp
,
2591 SCM_SETCAR (x
, SCM_CAR (t
.arg1
));
2592 SCM_SETCDR (x
, SCM_CDR (t
.arg1
));
2596 if (SCM_NIMP (x
= t
.arg1
))
2604 proc
= SCM_CEVAL (SCM_CAR (x
), env
);
2605 SCM_ASRTGO (SCM_NIMP (proc
), badfun
);
2606 #ifndef SCM_RECKLESS
2610 if (SCM_CLOSUREP (proc
))
2612 arg2
= SCM_CAR (SCM_CODE (proc
));
2613 t
.arg1
= SCM_CDR (x
);
2614 while (SCM_NIMP (arg2
))
2616 if (SCM_NCONSP (arg2
))
2618 if (SCM_IMP (t
.arg1
))
2619 goto umwrongnumargs
;
2620 arg2
= SCM_CDR (arg2
);
2621 t
.arg1
= SCM_CDR (t
.arg1
);
2623 if (SCM_NNULLP (t
.arg1
))
2624 goto umwrongnumargs
;
2626 else if (scm_tc16_macro
== SCM_TYP16 (proc
))
2627 goto handle_a_macro
;
2633 PREP_APPLY (proc
, SCM_EOL
);
2634 if (SCM_NULLP (SCM_CDR (x
))) {
2637 switch (SCM_TYP7 (proc
))
2638 { /* no arguments given */
2639 case scm_tc7_subr_0
:
2640 RETURN (SCM_SUBRF (proc
) ());
2641 case scm_tc7_subr_1o
:
2642 RETURN (SCM_SUBRF (proc
) (SCM_UNDEFINED
));
2644 RETURN (SCM_SUBRF (proc
) (SCM_EOL
));
2645 case scm_tc7_rpsubr
:
2646 RETURN (SCM_BOOL_T
);
2648 RETURN (SCM_SUBRF (proc
) (SCM_UNDEFINED
, SCM_UNDEFINED
));
2652 proc
= SCM_CCLO_SUBR (proc
);
2654 debug
.info
->a
.proc
= proc
;
2655 debug
.info
->a
.args
= scm_cons (t
.arg1
, SCM_EOL
);
2660 proc
= SCM_PROCEDURE (proc
);
2662 debug
.info
->a
.proc
= proc
;
2665 case scm_tcs_closures
:
2666 x
= SCM_CODE (proc
);
2667 env
= EXTEND_ENV (SCM_CAR (x
), SCM_EOL
, SCM_ENV (proc
));
2669 case scm_tcs_cons_gloc
:
2670 if (SCM_OBJ_CLASS_FLAGS (proc
) & SCM_CLASSF_PURE_GENERIC
)
2672 x
= SCM_ENTITY_PROCEDURE (proc
);
2676 else if (!SCM_I_OPERATORP (proc
))
2681 proc
= (SCM_I_ENTITYP (proc
)
2682 ? SCM_ENTITY_PROCEDURE (proc
)
2683 : SCM_OPERATOR_PROCEDURE (proc
));
2685 debug
.info
->a
.proc
= proc
;
2686 debug
.info
->a
.args
= scm_cons (t
.arg1
, SCM_EOL
);
2688 if (SCM_NIMP (proc
))
2693 case scm_tc7_contin
:
2694 case scm_tc7_subr_1
:
2695 case scm_tc7_subr_2
:
2696 case scm_tc7_subr_2o
:
2698 case scm_tc7_subr_3
:
2699 case scm_tc7_lsubr_2
:
2703 /* scm_everr (x, env,...) */
2704 scm_wrong_num_args (proc
);
2706 /* handle macros here */
2711 /* must handle macros by here */
2716 else if (SCM_CONSP (x
))
2718 if (SCM_IMP (SCM_CAR (x
)))
2719 t
.arg1
= SCM_EVALIM (SCM_CAR (x
), env
);
2721 t
.arg1
= EVALCELLCAR (x
, env
);
2723 else if (SCM_TYP3 (x
) == scm_tc3_cons_gloc
)
2725 scm_bits_t vcell
= SCM_STRUCT_VTABLE_DATA (x
) [scm_vtable_index_vcell
];
2727 t
.arg1
= SCM_CAR (x
); /* struct planted in code */
2729 t
.arg1
= SCM_PACK (vcell
);
2734 t
.arg1
= EVALCAR (x
, env
);
2737 debug
.info
->a
.args
= scm_cons (t
.arg1
, SCM_EOL
);
2744 switch (SCM_TYP7 (proc
))
2745 { /* have one argument in t.arg1 */
2746 case scm_tc7_subr_2o
:
2747 RETURN (SCM_SUBRF (proc
) (t
.arg1
, SCM_UNDEFINED
));
2748 case scm_tc7_subr_1
:
2749 case scm_tc7_subr_1o
:
2750 RETURN (SCM_SUBRF (proc
) (t
.arg1
));
2752 if (SCM_SUBRF (proc
))
2754 if (SCM_INUMP (t
.arg1
))
2756 RETURN (scm_makdbl (SCM_DSUBRF (proc
) ((double) SCM_INUM (t
.arg1
)),
2759 SCM_ASRTGO (SCM_NIMP (t
.arg1
), floerr
);
2760 if (SCM_REALP (t
.arg1
))
2762 RETURN (scm_makdbl (SCM_DSUBRF (proc
) (SCM_REALPART (t
.arg1
)), 0.0));
2765 if (SCM_BIGP (t
.arg1
))
2767 RETURN (scm_makdbl (SCM_DSUBRF (proc
) (scm_big2dbl (t
.arg1
)), 0.0));
2771 SCM_WTA_DISPATCH_1 (*SCM_SUBR_GENERIC (proc
), t
.arg1
,
2772 SCM_ARG1
, SCM_CHARS (SCM_SNAME (proc
)));
2774 proc
= SCM_SNAME (proc
);
2776 char *chrs
= SCM_CHARS (proc
) + SCM_LENGTH (proc
) - 1;
2777 while ('c' != *--chrs
)
2779 SCM_ASSERT (SCM_CONSP (t
.arg1
),
2780 t
.arg1
, SCM_ARG1
, SCM_CHARS (proc
));
2781 t
.arg1
= ('a' == *chrs
) ? SCM_CAR (t
.arg1
) : SCM_CDR (t
.arg1
);
2785 case scm_tc7_rpsubr
:
2786 RETURN (SCM_BOOL_T
);
2788 RETURN (SCM_SUBRF (proc
) (t
.arg1
, SCM_UNDEFINED
));
2791 RETURN (SCM_SUBRF (proc
) (debug
.info
->a
.args
))
2793 RETURN (SCM_SUBRF (proc
) (scm_cons (t
.arg1
, SCM_EOL
)));
2799 proc
= SCM_CCLO_SUBR (proc
);
2801 debug
.info
->a
.args
= scm_cons (t
.arg1
, debug
.info
->a
.args
);
2802 debug
.info
->a
.proc
= proc
;
2807 proc
= SCM_PROCEDURE (proc
);
2809 debug
.info
->a
.proc
= proc
;
2812 case scm_tcs_closures
:
2814 x
= SCM_CODE (proc
);
2816 env
= EXTEND_ENV (SCM_CAR (x
), debug
.info
->a
.args
, SCM_ENV (proc
));
2818 env
= EXTEND_ENV (SCM_CAR (x
), scm_cons (t
.arg1
, SCM_EOL
), SCM_ENV (proc
));
2821 case scm_tc7_contin
:
2822 scm_call_continuation (proc
, t
.arg1
);
2823 case scm_tcs_cons_gloc
:
2824 if (SCM_OBJ_CLASS_FLAGS (proc
) & SCM_CLASSF_PURE_GENERIC
)
2826 x
= SCM_ENTITY_PROCEDURE (proc
);
2828 arg2
= debug
.info
->a
.args
;
2830 arg2
= scm_cons (t
.arg1
, SCM_EOL
);
2834 else if (!SCM_I_OPERATORP (proc
))
2840 proc
= (SCM_I_ENTITYP (proc
)
2841 ? SCM_ENTITY_PROCEDURE (proc
)
2842 : SCM_OPERATOR_PROCEDURE (proc
));
2844 debug
.info
->a
.args
= scm_cons (t
.arg1
, debug
.info
->a
.args
);
2845 debug
.info
->a
.proc
= proc
;
2847 if (SCM_NIMP (proc
))
2852 case scm_tc7_subr_2
:
2853 case scm_tc7_subr_0
:
2854 case scm_tc7_subr_3
:
2855 case scm_tc7_lsubr_2
:
2864 else if (SCM_CONSP (x
))
2866 if (SCM_IMP (SCM_CAR (x
)))
2867 arg2
= SCM_EVALIM (SCM_CAR (x
), env
);
2869 arg2
= EVALCELLCAR (x
, env
);
2871 else if (SCM_TYP3 (x
) == scm_tc3_cons_gloc
)
2873 scm_bits_t vcell
= SCM_STRUCT_VTABLE_DATA (x
) [scm_vtable_index_vcell
];
2875 arg2
= SCM_CAR (x
); /* struct planted in code */
2877 arg2
= SCM_PACK (vcell
);
2882 arg2
= EVALCAR (x
, env
);
2884 { /* have two or more arguments */
2886 debug
.info
->a
.args
= scm_cons2 (t
.arg1
, arg2
, SCM_EOL
);
2889 if (SCM_NULLP (x
)) {
2894 switch (SCM_TYP7 (proc
))
2895 { /* have two arguments */
2896 case scm_tc7_subr_2
:
2897 case scm_tc7_subr_2o
:
2898 RETURN (SCM_SUBRF (proc
) (t
.arg1
, arg2
));
2901 RETURN (SCM_SUBRF (proc
) (debug
.info
->a
.args
))
2903 RETURN (SCM_SUBRF (proc
) (scm_cons2 (t
.arg1
, arg2
, SCM_EOL
)));
2905 case scm_tc7_lsubr_2
:
2906 RETURN (SCM_SUBRF (proc
) (t
.arg1
, arg2
, SCM_EOL
));
2907 case scm_tc7_rpsubr
:
2909 RETURN (SCM_SUBRF (proc
) (t
.arg1
, arg2
));
2914 RETURN (SCM_APPLY (SCM_CCLO_SUBR (proc
),
2915 scm_cons (proc
, debug
.info
->a
.args
),
2918 RETURN (SCM_APPLY (SCM_CCLO_SUBR (proc
),
2919 scm_cons2 (proc
, t
.arg1
,
2926 /* case scm_tc7_cclo:
2927 x = scm_cons(arg2, scm_eval_args(x, env));
2930 proc = SCM_CCLO_SUBR(proc);
2934 proc
= SCM_PROCEDURE (proc
);
2936 debug
.info
->a
.proc
= proc
;
2939 case scm_tcs_cons_gloc
:
2940 if (SCM_OBJ_CLASS_FLAGS (proc
) & SCM_CLASSF_PURE_GENERIC
)
2942 x
= SCM_ENTITY_PROCEDURE (proc
);
2944 arg2
= debug
.info
->a
.args
;
2946 arg2
= scm_cons2 (t
.arg1
, arg2
, SCM_EOL
);
2950 else if (!SCM_I_OPERATORP (proc
))
2956 RETURN (SCM_APPLY (SCM_I_ENTITYP (proc
)
2957 ? SCM_ENTITY_PROCEDURE (proc
)
2958 : SCM_OPERATOR_PROCEDURE (proc
),
2959 scm_cons (proc
, debug
.info
->a
.args
),
2962 RETURN (SCM_APPLY (SCM_I_ENTITYP (proc
)
2963 ? SCM_ENTITY_PROCEDURE (proc
)
2964 : SCM_OPERATOR_PROCEDURE (proc
),
2965 scm_cons2 (proc
, t
.arg1
,
2973 case scm_tc7_subr_0
:
2975 case scm_tc7_subr_1o
:
2976 case scm_tc7_subr_1
:
2977 case scm_tc7_subr_3
:
2978 case scm_tc7_contin
:
2982 case scm_tcs_closures
:
2985 env
= EXTEND_ENV (SCM_CAR (SCM_CODE (proc
)),
2989 env
= EXTEND_ENV (SCM_CAR (SCM_CODE (proc
)),
2990 scm_cons2 (t
.arg1
, arg2
, SCM_EOL
), SCM_ENV (proc
));
2992 x
= SCM_CODE (proc
);
2997 if (SCM_IMP (x
) || SCM_NECONSP (x
))
3001 debug
.info
->a
.args
= scm_cons2 (t
.arg1
, arg2
,
3002 scm_deval_args (x
, env
, proc
,
3003 SCM_CDRLOC (SCM_CDR (debug
.info
->a
.args
))));
3007 switch (SCM_TYP7 (proc
))
3008 { /* have 3 or more arguments */
3010 case scm_tc7_subr_3
:
3011 SCM_ASRTGO (SCM_NULLP (SCM_CDR (x
)), wrongnumargs
);
3012 RETURN (SCM_SUBRF (proc
) (t
.arg1
, arg2
,
3013 SCM_CADDR (debug
.info
->a
.args
)));
3015 #ifdef BUILTIN_RPASUBR
3016 t
.arg1
= SCM_SUBRF(proc
)(t
.arg1
, arg2
);
3017 arg2
= SCM_CDR (SCM_CDR (debug
.info
->a
.args
));
3020 t
.arg1
= SCM_SUBRF(proc
)(t
.arg1
, SCM_CAR (arg2
));
3021 arg2
= SCM_CDR (arg2
);
3023 while (SCM_NIMP (arg2
));
3025 #endif /* BUILTIN_RPASUBR */
3026 case scm_tc7_rpsubr
:
3027 #ifdef BUILTIN_RPASUBR
3028 if (SCM_FALSEP (SCM_SUBRF (proc
) (t
.arg1
, arg2
)))
3030 t
.arg1
= SCM_CDR (SCM_CDR (debug
.info
->a
.args
));
3033 if (SCM_FALSEP (SCM_SUBRF (proc
) (arg2
, SCM_CAR (t
.arg1
))))
3035 arg2
= SCM_CAR (t
.arg1
);
3036 t
.arg1
= SCM_CDR (t
.arg1
);
3038 while (SCM_NIMP (t
.arg1
));
3040 #else /* BUILTIN_RPASUBR */
3041 RETURN (SCM_APPLY (proc
, t
.arg1
,
3043 SCM_CDR (SCM_CDR (debug
.info
->a
.args
)),
3045 #endif /* BUILTIN_RPASUBR */
3046 case scm_tc7_lsubr_2
:
3047 RETURN (SCM_SUBRF (proc
) (t
.arg1
, arg2
,
3048 SCM_CDR (SCM_CDR (debug
.info
->a
.args
))))
3050 RETURN (SCM_SUBRF (proc
) (debug
.info
->a
.args
))
3056 proc
= SCM_PROCEDURE (proc
);
3057 debug
.info
->a
.proc
= proc
;
3059 case scm_tcs_closures
:
3060 SCM_SET_ARGSREADY (debug
);
3061 env
= EXTEND_ENV (SCM_CAR (SCM_CODE (proc
)),
3064 x
= SCM_CODE (proc
);
3067 case scm_tc7_subr_3
:
3068 SCM_ASRTGO (SCM_NULLP (SCM_CDR (x
)), wrongnumargs
);
3069 RETURN (SCM_SUBRF (proc
) (t
.arg1
, arg2
, EVALCAR (x
, env
)));
3071 #ifdef BUILTIN_RPASUBR
3072 t
.arg1
= SCM_SUBRF (proc
) (t
.arg1
, arg2
);
3075 t
.arg1
= SCM_SUBRF(proc
)(t
.arg1
, EVALCAR(x
, env
));
3078 while (SCM_NIMP (x
));
3080 #endif /* BUILTIN_RPASUBR */
3081 case scm_tc7_rpsubr
:
3082 #ifdef BUILTIN_RPASUBR
3083 if (SCM_FALSEP (SCM_SUBRF (proc
) (t
.arg1
, arg2
)))
3087 t
.arg1
= EVALCAR (x
, env
);
3088 if (SCM_FALSEP (SCM_SUBRF (proc
) (arg2
, t
.arg1
)))
3093 while (SCM_NIMP (x
));
3095 #else /* BUILTIN_RPASUBR */
3096 RETURN (SCM_APPLY (proc
, t
.arg1
,
3098 scm_eval_args (x
, env
, proc
),
3100 #endif /* BUILTIN_RPASUBR */
3101 case scm_tc7_lsubr_2
:
3102 RETURN (SCM_SUBRF (proc
) (t
.arg1
, arg2
, scm_eval_args (x
, env
, proc
)));
3104 RETURN (SCM_SUBRF (proc
) (scm_cons2 (t
.arg1
,
3106 scm_eval_args (x
, env
, proc
))));
3112 proc
= SCM_PROCEDURE (proc
);
3114 case scm_tcs_closures
:
3116 SCM_SET_ARGSREADY (debug
);
3118 env
= EXTEND_ENV (SCM_CAR (SCM_CODE (proc
)),
3121 scm_eval_args (x
, env
, proc
)),
3123 x
= SCM_CODE (proc
);
3126 case scm_tcs_cons_gloc
:
3127 if (SCM_OBJ_CLASS_FLAGS (proc
) & SCM_CLASSF_PURE_GENERIC
)
3130 arg2
= debug
.info
->a
.args
;
3132 arg2
= scm_cons2 (t
.arg1
, arg2
, scm_eval_args (x
, env
, proc
));
3134 x
= SCM_ENTITY_PROCEDURE (proc
);
3137 else if (!SCM_I_OPERATORP (proc
))
3141 case scm_tc7_subr_2
:
3142 case scm_tc7_subr_1o
:
3143 case scm_tc7_subr_2o
:
3144 case scm_tc7_subr_0
:
3146 case scm_tc7_subr_1
:
3147 case scm_tc7_contin
:
3155 if (CHECK_EXIT
&& SCM_TRAPS_P
)
3156 if (SCM_EXIT_FRAME_P
|| (SCM_TRACE_P
&& SCM_TRACED_FRAME_P (debug
)))
3158 SCM_CLEAR_TRACED_FRAME (debug
);
3159 if (SCM_CHEAPTRAPS_P
)
3160 t
.arg1
= scm_make_debugobj (&debug
);
3163 scm_make_cont (&t
.arg1
);
3164 if (setjmp (SCM_JMPBUF (t
.arg1
)))
3166 proc
= SCM_THROW_VALUE (t
.arg1
);
3170 scm_ithrow (scm_sym_exit_frame
, scm_cons2 (t
.arg1
, proc
, SCM_EOL
), 0);
3173 scm_last_debug_frame
= debug
.prev
;
3179 /* SECTION: This code is compiled once.
3184 /* This code processes the arguments to apply:
3186 (apply PROC ARG1 ... ARGS)
3188 Given a list (ARG1 ... ARGS), this function conses the ARG1
3189 ... arguments onto the front of ARGS, and returns the resulting
3190 list. Note that ARGS is a list; thus, the argument to this
3191 function is a list whose last element is a list.
3193 Apply calls this function, and applies PROC to the elements of the
3194 result. apply:nconc2last takes care of building the list of
3195 arguments, given (ARG1 ... ARGS).
3197 Rather than do new consing, apply:nconc2last destroys its argument.
3198 On that topic, this code came into my care with the following
3199 beautifully cryptic comment on that topic: "This will only screw
3200 you if you do (scm_apply scm_apply '( ... ))" If you know what
3201 they're referring to, send me a patch to this comment. */
3203 SCM_DEFINE (scm_nconc2last
, "apply:nconc2last", 1, 0, 0,
3206 #define FUNC_NAME s_scm_nconc2last
3209 SCM_VALIDATE_NONEMPTYLIST (1,lst
);
3211 while (SCM_NNULLP (SCM_CDR (*lloc
)))
3212 lloc
= SCM_CDRLOC (*lloc
);
3213 SCM_ASSERT (scm_ilength (SCM_CAR (*lloc
)) >= 0, lst
, SCM_ARG1
, FUNC_NAME
);
3214 *lloc
= SCM_CAR (*lloc
);
3222 /* SECTION: When DEVAL is defined this code yields scm_dapply.
3223 * It is compiled twice.
3229 scm_apply (SCM proc
, SCM arg1
, SCM args
)
3236 scm_dapply (SCM proc
, SCM arg1
, SCM args
)
3241 /* Apply a function to a list of arguments.
3243 This function is exported to the Scheme level as taking two
3244 required arguments and a tail argument, as if it were:
3245 (lambda (proc arg1 . args) ...)
3246 Thus, if you just have a list of arguments to pass to a procedure,
3247 pass the list as ARG1, and '() for ARGS. If you have some fixed
3248 args, pass the first as ARG1, then cons any remaining fixed args
3249 onto the front of your argument list, and pass that as ARGS. */
3252 SCM_APPLY (SCM proc
, SCM arg1
, SCM args
)
3254 #ifdef DEBUG_EXTENSIONS
3256 scm_debug_frame debug
;
3257 scm_debug_info debug_vect_body
;
3258 debug
.prev
= scm_last_debug_frame
;
3259 debug
.status
= SCM_APPLYFRAME
;
3260 debug
.vect
= &debug_vect_body
;
3261 debug
.vect
[0].a
.proc
= proc
;
3262 debug
.vect
[0].a
.args
= SCM_EOL
;
3263 scm_last_debug_frame
= &debug
;
3266 return scm_dapply (proc
, arg1
, args
);
3270 SCM_ASRTGO (SCM_NIMP (proc
), badproc
);
3272 /* If ARGS is the empty list, then we're calling apply with only two
3273 arguments --- ARG1 is the list of arguments for PROC. Whatever
3274 the case, futz with things so that ARG1 is the first argument to
3275 give to PROC (or SCM_UNDEFINED if no args), and ARGS contains the
3278 Setting the debug apply frame args this way is pretty messy.
3279 Perhaps we should store arg1 and args directly in the frame as
3280 received, and let scm_frame_arguments unpack them, because that's
3281 a relatively rare operation. This works for now; if the Guile
3282 developer archives are still around, see Mikael's post of
3284 if (SCM_NULLP (args
))
3286 if (SCM_NULLP (arg1
))
3288 arg1
= SCM_UNDEFINED
;
3290 debug
.vect
[0].a
.args
= SCM_EOL
;
3296 debug
.vect
[0].a
.args
= arg1
;
3298 args
= SCM_CDR (arg1
);
3299 arg1
= SCM_CAR (arg1
);
3304 /* SCM_ASRTGO(SCM_CONSP(args), wrongnumargs); */
3305 args
= scm_nconc2last (args
);
3307 debug
.vect
[0].a
.args
= scm_cons (arg1
, args
);
3311 if (SCM_ENTER_FRAME_P
&& SCM_TRAPS_P
)
3314 if (SCM_CHEAPTRAPS_P
)
3315 tmp
= scm_make_debugobj (&debug
);
3318 scm_make_cont (&tmp
);
3319 if (setjmp (SCM_JMPBUF (tmp
)))
3322 scm_ithrow (scm_sym_enter_frame
, scm_cons (tmp
, SCM_EOL
), 0);
3330 switch (SCM_TYP7 (proc
))
3332 case scm_tc7_subr_2o
:
3333 args
= SCM_NULLP (args
) ? SCM_UNDEFINED
: SCM_CAR (args
);
3334 RETURN (SCM_SUBRF (proc
) (arg1
, args
))
3335 case scm_tc7_subr_2
:
3336 SCM_ASRTGO (SCM_NNULLP (args
) && SCM_NULLP (SCM_CDR (args
)),
3338 args
= SCM_CAR (args
);
3339 RETURN (SCM_SUBRF (proc
) (arg1
, args
))
3340 case scm_tc7_subr_0
:
3341 SCM_ASRTGO (SCM_UNBNDP (arg1
), wrongnumargs
);
3342 RETURN (SCM_SUBRF (proc
) ())
3343 case scm_tc7_subr_1
:
3344 case scm_tc7_subr_1o
:
3345 SCM_ASRTGO (SCM_NULLP (args
), wrongnumargs
);
3346 RETURN (SCM_SUBRF (proc
) (arg1
))
3348 SCM_ASRTGO (SCM_NULLP (args
), wrongnumargs
);
3349 if (SCM_SUBRF (proc
))
3351 if (SCM_INUMP (arg1
))
3353 RETURN (scm_makdbl (SCM_DSUBRF (proc
) ((double) SCM_INUM (arg1
)), 0.0));
3355 SCM_ASRTGO (SCM_NIMP (arg1
), floerr
);
3356 if (SCM_REALP (arg1
))
3358 RETURN (scm_makdbl (SCM_DSUBRF (proc
) (SCM_REALPART (arg1
)), 0.0));
3361 if (SCM_BIGP (arg1
))
3362 RETURN (scm_makdbl (SCM_DSUBRF (proc
) (scm_big2dbl (arg1
)), 0.0))
3365 SCM_WTA_DISPATCH_1 (*SCM_SUBR_GENERIC (proc
), arg1
,
3366 SCM_ARG1
, SCM_CHARS (SCM_SNAME (proc
)));
3368 proc
= SCM_SNAME (proc
);
3370 char *chrs
= SCM_CHARS (proc
) + SCM_LENGTH (proc
) - 1;
3371 while ('c' != *--chrs
)
3373 SCM_ASSERT (SCM_CONSP (arg1
),
3374 arg1
, SCM_ARG1
, SCM_CHARS (proc
));
3375 arg1
= ('a' == *chrs
) ? SCM_CAR (arg1
) : SCM_CDR (arg1
);
3379 case scm_tc7_subr_3
:
3380 RETURN (SCM_SUBRF (proc
) (arg1
, SCM_CAR (args
), SCM_CAR (SCM_CDR (args
))))
3383 RETURN (SCM_SUBRF (proc
) (SCM_UNBNDP (arg1
) ? SCM_EOL
: debug
.vect
[0].a
.args
))
3385 RETURN (SCM_SUBRF (proc
) (SCM_UNBNDP (arg1
) ? SCM_EOL
: scm_cons (arg1
, args
)))
3387 case scm_tc7_lsubr_2
:
3388 SCM_ASRTGO (SCM_CONSP (args
), wrongnumargs
);
3389 RETURN (SCM_SUBRF (proc
) (arg1
, SCM_CAR (args
), SCM_CDR (args
)))
3391 if (SCM_NULLP (args
))
3392 RETURN (SCM_SUBRF (proc
) (arg1
, SCM_UNDEFINED
))
3393 while (SCM_NIMP (args
))
3395 SCM_ASSERT (SCM_CONSP (args
), args
, SCM_ARG2
, "apply");
3396 arg1
= SCM_SUBRF (proc
) (arg1
, SCM_CAR (args
));
3397 args
= SCM_CDR (args
);
3400 case scm_tc7_rpsubr
:
3401 if (SCM_NULLP (args
))
3402 RETURN (SCM_BOOL_T
);
3403 while (SCM_NIMP (args
))
3405 SCM_ASSERT (SCM_CONSP (args
), args
, SCM_ARG2
, "apply");
3406 if (SCM_FALSEP (SCM_SUBRF (proc
) (arg1
, SCM_CAR (args
))))
3407 RETURN (SCM_BOOL_F
);
3408 arg1
= SCM_CAR (args
);
3409 args
= SCM_CDR (args
);
3411 RETURN (SCM_BOOL_T
);
3412 case scm_tcs_closures
:
3414 arg1
= (SCM_UNBNDP (arg1
) ? SCM_EOL
: debug
.vect
[0].a
.args
);
3416 arg1
= (SCM_UNBNDP (arg1
) ? SCM_EOL
: scm_cons (arg1
, args
));
3418 #ifndef SCM_RECKLESS
3419 if (scm_badargsp (SCM_CAR (SCM_CODE (proc
)), arg1
))
3423 /* Copy argument list */
3428 SCM tl
= args
= scm_cons (SCM_CAR (arg1
), SCM_UNSPECIFIED
);
3429 while (arg1
= SCM_CDR (arg1
), SCM_CONSP (arg1
))
3431 SCM_SETCDR (tl
, scm_cons (SCM_CAR (arg1
),
3435 SCM_SETCDR (tl
, arg1
);
3438 args
= EXTEND_ENV (SCM_CAR (SCM_CODE (proc
)), args
, SCM_ENV (proc
));
3439 proc
= SCM_CDR (SCM_CODE (proc
));
3442 while (SCM_NNULLP (arg1
= SCM_CDR (arg1
)))
3444 if (SCM_IMP (SCM_CAR (proc
)))
3446 if (SCM_ISYMP (SCM_CAR (proc
)))
3448 proc
= scm_m_expand_body (proc
, args
);
3453 SCM_CEVAL (SCM_CAR (proc
), args
);
3456 RETURN (EVALCAR (proc
, args
));
3457 case scm_tc7_contin
:
3458 SCM_ASRTGO (SCM_NULLP (args
), wrongnumargs
);
3459 scm_call_continuation (proc
, arg1
);
3463 args
= (SCM_UNBNDP(arg1
) ? SCM_EOL
: debug
.vect
[0].a
.args
);
3465 proc
= SCM_CCLO_SUBR (proc
);
3466 debug
.vect
[0].a
.proc
= proc
;
3467 debug
.vect
[0].a
.args
= scm_cons (arg1
, args
);
3469 args
= (SCM_UNBNDP(arg1
) ? SCM_EOL
: scm_cons (arg1
, args
));
3471 proc
= SCM_CCLO_SUBR (proc
);
3476 proc
= SCM_PROCEDURE (proc
);
3478 debug
.vect
[0].a
.proc
= proc
;
3481 case scm_tcs_cons_gloc
:
3482 if (SCM_OBJ_CLASS_FLAGS (proc
) & SCM_CLASSF_PURE_GENERIC
)
3485 args
= (SCM_UNBNDP(arg1
) ? SCM_EOL
: debug
.vect
[0].a
.args
);
3487 args
= (SCM_UNBNDP(arg1
) ? SCM_EOL
: scm_cons (arg1
, args
));
3489 RETURN (scm_apply_generic (proc
, args
));
3491 else if (!SCM_I_OPERATORP (proc
))
3496 args
= (SCM_UNBNDP(arg1
) ? SCM_EOL
: debug
.vect
[0].a
.args
);
3498 args
= (SCM_UNBNDP(arg1
) ? SCM_EOL
: scm_cons (arg1
, args
));
3501 proc
= (SCM_I_ENTITYP (proc
)
3502 ? SCM_ENTITY_PROCEDURE (proc
)
3503 : SCM_OPERATOR_PROCEDURE (proc
));
3505 debug
.vect
[0].a
.proc
= proc
;
3506 debug
.vect
[0].a
.args
= scm_cons (arg1
, args
);
3508 if (SCM_NIMP (proc
))
3514 scm_wrong_num_args (proc
);
3517 scm_wta (proc
, (char *) SCM_ARG1
, "apply");
3522 if (CHECK_EXIT
&& SCM_TRAPS_P
)
3523 if (SCM_EXIT_FRAME_P
|| (SCM_TRACE_P
&& SCM_TRACED_FRAME_P (debug
)))
3525 SCM_CLEAR_TRACED_FRAME (debug
);
3526 if (SCM_CHEAPTRAPS_P
)
3527 arg1
= scm_make_debugobj (&debug
);
3530 scm_make_cont (&arg1
);
3531 if (setjmp (SCM_JMPBUF (arg1
)))
3533 proc
= SCM_THROW_VALUE (arg1
);
3537 scm_ithrow (scm_sym_exit_frame
, scm_cons2 (arg1
, proc
, SCM_EOL
), 0);
3540 scm_last_debug_frame
= debug
.prev
;
3546 /* SECTION: The rest of this file is only read once.
3551 /* Typechecking for multi-argument MAP and FOR-EACH.
3553 Verify that each element of the vector ARGV, except for the first,
3554 is a proper list whose length is LEN. Attribute errors to WHO,
3555 and claim that the i'th element of ARGV is WHO's i+2'th argument. */
3557 check_map_args (SCM argv
,
3564 SCM
*ve
= SCM_VELTS (argv
);
3567 for (i
= SCM_LENGTH (argv
) - 1; i
>= 1; i
--)
3569 int elt_len
= scm_ilength (ve
[i
]);
3574 scm_apply_generic (gf
, scm_cons (proc
, args
));
3576 scm_wrong_type_arg (who
, i
+ 2, ve
[i
]);
3580 scm_out_of_range (who
, ve
[i
]);
3583 scm_remember (&argv
);
3587 SCM_GPROC (s_map
, "map", 2, 0, 1, scm_map
, g_map
);
3589 /* Note: Currently, scm_map applies PROC to the argument list(s)
3590 sequentially, starting with the first element(s). This is used in
3591 evalext.c where the Scheme procedure `serial-map', which guarantees
3592 sequential behaviour, is implemented using scm_map. If the
3593 behaviour changes, we need to update `serial-map'.
3597 scm_map (SCM proc
, SCM arg1
, SCM args
)
3602 SCM
*ve
= &args
; /* Keep args from being optimized away. */
3604 if (SCM_NULLP (arg1
))
3606 len
= scm_ilength (arg1
);
3607 SCM_GASSERTn (len
>= 0,
3608 g_map
, scm_cons2 (proc
, arg1
, args
), SCM_ARG2
, s_map
);
3609 if (SCM_NULLP (args
))
3611 while (SCM_NIMP (arg1
))
3613 SCM_GASSERT2 (SCM_CONSP (arg1
), g_map
, proc
, arg1
, SCM_ARG2
, s_map
);
3614 *pres
= scm_cons (scm_apply (proc
, SCM_CAR (arg1
), scm_listofnull
),
3616 pres
= SCM_CDRLOC (*pres
);
3617 arg1
= SCM_CDR (arg1
);
3621 args
= scm_vector (arg1
= scm_cons (arg1
, args
));
3622 ve
= SCM_VELTS (args
);
3623 #ifndef SCM_RECKLESS
3624 check_map_args (args
, len
, g_map
, proc
, arg1
, s_map
);
3629 for (i
= SCM_LENGTH (args
) - 1; i
>= 0; i
--)
3631 if (SCM_IMP (ve
[i
]))
3633 arg1
= scm_cons (SCM_CAR (ve
[i
]), arg1
);
3634 ve
[i
] = SCM_CDR (ve
[i
]);
3636 *pres
= scm_cons (scm_apply (proc
, arg1
, SCM_EOL
), SCM_EOL
);
3637 pres
= SCM_CDRLOC (*pres
);
3642 SCM_GPROC (s_for_each
, "for-each", 2, 0, 1, scm_for_each
, g_for_each
);
3645 scm_for_each (SCM proc
, SCM arg1
, SCM args
)
3647 SCM
*ve
= &args
; /* Keep args from being optimized away. */
3650 return SCM_UNSPECIFIED
;
3651 len
= scm_ilength (arg1
);
3652 SCM_GASSERTn (len
>= 0, g_for_each
, scm_cons2 (proc
, arg1
, args
),
3653 SCM_ARG2
, s_for_each
);
3656 while SCM_NIMP (arg1
)
3658 SCM_GASSERT2 (SCM_CONSP (arg1
),
3659 g_for_each
, proc
, arg1
, SCM_ARG2
, s_for_each
);
3660 scm_apply (proc
, SCM_CAR (arg1
), scm_listofnull
);
3661 arg1
= SCM_CDR (arg1
);
3663 return SCM_UNSPECIFIED
;
3665 args
= scm_vector (arg1
= scm_cons (arg1
, args
));
3666 ve
= SCM_VELTS (args
);
3667 #ifndef SCM_RECKLESS
3668 check_map_args (args
, len
, g_for_each
, proc
, arg1
, s_for_each
);
3673 for (i
= SCM_LENGTH (args
) - 1; i
>= 0; i
--)
3676 (ve
[i
]) return SCM_UNSPECIFIED
;
3677 arg1
= scm_cons (SCM_CAR (ve
[i
]), arg1
);
3678 ve
[i
] = SCM_CDR (ve
[i
]);
3680 scm_apply (proc
, arg1
, SCM_EOL
);
3687 scm_closure (SCM code
, SCM env
)
3691 SCM_SETCODE (z
, code
);
3692 SCM_SETENV (z
, env
);
3697 long scm_tc16_promise
;
3700 scm_makprom (SCM code
)
3702 SCM_RETURN_NEWSMOB (scm_tc16_promise
, SCM_UNPACK (code
));
3708 prinprom (SCM exp
,SCM port
,scm_print_state
*pstate
)
3710 int writingp
= SCM_WRITINGP (pstate
);
3711 scm_puts ("#<promise ", port
);
3712 SCM_SET_WRITINGP (pstate
, 1);
3713 scm_iprin1 (SCM_CDR (exp
), port
, pstate
);
3714 SCM_SET_WRITINGP (pstate
, writingp
);
3715 scm_putc ('>', port
);
3720 SCM_DEFINE (scm_force
, "force", 1, 0, 0,
3723 #define FUNC_NAME s_scm_force
3725 SCM_VALIDATE_SMOB (1,x
,promise
);
3726 if (!((1L << 16) & SCM_UNPACK_CAR (x
)))
3728 SCM ans
= scm_apply (SCM_CDR (x
), SCM_EOL
, SCM_EOL
);
3729 if (!((1L << 16) & SCM_UNPACK_CAR (x
)))
3732 SCM_SETCDR (x
, ans
);
3733 SCM_SETOR_CAR (x
, (1L << 16));
3741 SCM_DEFINE (scm_promise_p
, "promise?", 1, 0, 0,
3743 "Return true if @var{obj} is a promise, i.e. a delayed computation\n"
3744 "(@pxref{Delayed evaluation,,,r4rs.info,The Revised^4 Report on Scheme}).")
3745 #define FUNC_NAME s_scm_promise_p
3747 return SCM_BOOL(SCM_NIMP (x
) && (SCM_TYP16 (x
) == scm_tc16_promise
));
3751 SCM_DEFINE (scm_cons_source
, "cons-source", 3, 0, 0,
3752 (SCM xorig
, SCM x
, SCM y
),
3754 #define FUNC_NAME s_scm_cons_source
3760 /* Copy source properties possibly associated with xorig. */
3761 p
= scm_whash_lookup (scm_source_whash
, xorig
);
3763 scm_whash_insert (scm_source_whash
, z
, p
);
3768 SCM_DEFINE (scm_copy_tree
, "copy-tree", 1, 0, 0,
3770 "Recursively copy the data tree that is bound to @var{obj}, and return a\n"
3771 "pointer to the new data structure. @code{copy-tree} recurses down the\n"
3772 "contents of both pairs and vectors (since both cons cells and vector\n"
3773 "cells may point to arbitrary objects), and stops recursing when it hits\n"
3774 "any other object.")
3775 #define FUNC_NAME s_scm_copy_tree
3780 if (SCM_VECTORP (obj
))
3782 scm_sizet i
= SCM_LENGTH (obj
);
3783 ans
= scm_make_vector (SCM_MAKINUM (i
), SCM_UNSPECIFIED
);
3785 SCM_VELTS (ans
)[i
] = scm_copy_tree (SCM_VELTS (obj
)[i
]);
3788 if (SCM_NCONSP (obj
))
3790 /* return scm_cons(scm_copy_tree(SCM_CAR(obj)), scm_copy_tree(SCM_CDR(obj))); */
3791 ans
= tl
= scm_cons_source (obj
,
3792 scm_copy_tree (SCM_CAR (obj
)),
3794 while (obj
= SCM_CDR (obj
), SCM_CONSP (obj
))
3796 SCM_SETCDR (tl
, scm_cons (scm_copy_tree (SCM_CAR (obj
)),
3800 SCM_SETCDR (tl
, obj
);
3807 scm_eval_3 (SCM obj
, int copyp
, SCM env
)
3809 if (SCM_NIMP (SCM_CDR (scm_system_transformer
)))
3810 obj
= scm_apply (SCM_CDR (scm_system_transformer
), obj
, scm_listofnull
);
3812 obj
= scm_copy_tree (obj
);
3813 return SCM_XEVAL (obj
, env
);
3816 SCM_DEFINE (scm_eval2
, "eval2", 2, 0, 0,
3817 (SCM obj
, SCM env_thunk
),
3818 "Evaluate @var{exp}, a Scheme expression, in the environment designated\n"
3819 "by @var{lookup}, a symbol-lookup function. @code{(eval exp)} is\n"
3820 "equivalent to @code{(eval2 exp *top-level-lookup-closure*)}.")
3821 #define FUNC_NAME s_scm_eval2
3823 return scm_eval_3 (obj
, 1, scm_top_level_env (env_thunk
));
3827 SCM_DEFINE (scm_eval
, "eval", 1, 0, 0,
3829 "Evaluate @var{exp}, a list representing a Scheme expression, in the\n"
3830 "top-level environment.")
3831 #define FUNC_NAME s_scm_eval
3833 return scm_eval_3 (obj
,
3836 (SCM_CDR (scm_top_level_lookup_closure_var
)));
3841 SCM_REGISTER_PROC(s_eval_x, "eval!", 1, 0, 0, scm_eval_x);
3845 scm_eval_x (SCM obj
)
3847 return scm_eval_3 (obj
,
3850 (SCM_CDR (scm_top_level_lookup_closure_var
)));
3854 /* At this point, scm_deval and scm_dapply are generated.
3857 #ifdef DEBUG_EXTENSIONS
3867 scm_init_opts (scm_evaluator_traps
,
3868 scm_evaluator_trap_table
,
3869 SCM_N_EVALUATOR_TRAPS
);
3870 scm_init_opts (scm_eval_options_interface
,
3872 SCM_N_EVAL_OPTIONS
);
3874 scm_tc16_promise
= scm_make_smob_type ("promise", 0);
3875 scm_set_smob_mark (scm_tc16_promise
, scm_markcdr
);
3876 scm_set_smob_print (scm_tc16_promise
, prinprom
);
3878 scm_f_apply
= scm_make_subr ("apply", scm_tc7_lsubr_2
, scm_apply
);
3879 scm_system_transformer
= scm_sysintern ("scm:eval-transformer", SCM_UNDEFINED
);
3880 scm_sym_dot
= SCM_CAR (scm_sysintern (".", SCM_UNDEFINED
));
3881 scm_sym_arrow
= SCM_CAR (scm_sysintern ("=>", SCM_UNDEFINED
));
3882 scm_sym_else
= SCM_CAR (scm_sysintern ("else", SCM_UNDEFINED
));
3883 scm_sym_unquote
= SCM_CAR (scm_sysintern ("unquote", SCM_UNDEFINED
));
3884 scm_sym_uq_splicing
= SCM_CAR (scm_sysintern ("unquote-splicing", SCM_UNDEFINED
));
3886 scm_lisp_nil
= scm_sysintern ("nil", SCM_UNDEFINED
);
3887 SCM_SETCDR (scm_lisp_nil
, SCM_CAR (scm_lisp_nil
));
3888 scm_lisp_nil
= SCM_CAR (scm_lisp_nil
);
3889 scm_lisp_t
= scm_sysintern ("t", SCM_UNDEFINED
);
3890 SCM_SETCDR (scm_lisp_t
, SCM_CAR (scm_lisp_t
));
3891 scm_lisp_t
= SCM_CAR (scm_lisp_t
);
3896 scm_top_level_lookup_closure_var
=
3897 scm_sysintern("*top-level-lookup-closure*", SCM_BOOL_F
);
3898 scm_can_use_top_level_lookup_closure_var
= 1;
3900 #ifdef DEBUG_EXTENSIONS
3901 scm_sym_enter_frame
= SCM_CAR (scm_sysintern ("enter-frame", SCM_UNDEFINED
));
3902 scm_sym_apply_frame
= SCM_CAR (scm_sysintern ("apply-frame", SCM_UNDEFINED
));
3903 scm_sym_exit_frame
= SCM_CAR (scm_sysintern ("exit-frame", SCM_UNDEFINED
));
3904 scm_sym_trace
= SCM_CAR (scm_sysintern ("trace", SCM_UNDEFINED
));
3907 #include "libguile/eval.x"
3909 scm_add_feature ("delay");