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"
102 #include "libguile/fluids.h"
104 #include "libguile/validate.h"
105 #include "libguile/eval.h"
107 SCM (*scm_memoize_method
) (SCM
, SCM
);
111 /* The evaluator contains a plethora of EVAL symbols.
112 * This is an attempt at explanation.
114 * The following macros should be used in code which is read twice
115 * (where the choice of evaluator is hard soldered):
117 * SCM_CEVAL is the symbol used within one evaluator to call itself.
118 * Originally, it is defined to scm_ceval, but is redefined to
119 * scm_deval during the second pass.
121 * SIDEVAL corresponds to SCM_CEVAL, but is used in situations where
122 * only side effects of expressions matter. All immediates are
125 * SCM_EVALIM is used when it is known that the expression is an
126 * immediate. (This macro never calls an evaluator.)
128 * EVALCAR evaluates the car of an expression.
130 * EVALCELLCAR is like EVALCAR, but is used when it is known that the
131 * car is a lisp cell.
133 * The following macros should be used in code which is read once
134 * (where the choice of evaluator is dynamic):
136 * SCM_XEVAL takes care of immediates without calling an evaluator. It
137 * then calls scm_ceval *or* scm_deval, depending on the debugging
140 * SCM_XEVALCAR corresponds to EVALCAR, but uses scm_ceval *or* scm_deval
141 * depending on the debugging mode.
143 * The main motivation for keeping this plethora is efficiency
144 * together with maintainability (=> locality of code).
147 #define SCM_CEVAL scm_ceval
148 #define SIDEVAL(x, env) if (SCM_NIMP (x)) SCM_CEVAL((x), (env))
150 #define EVALCELLCAR(x, env) (SCM_SYMBOLP (SCM_CAR (x)) \
151 ? *scm_lookupcar (x, env, 1) \
152 : SCM_CEVAL (SCM_CAR (x), env))
154 #define EVALCAR(x, env) (SCM_NCELLP (SCM_CAR (x)) \
155 ? (SCM_IMP (SCM_CAR (x)) \
156 ? SCM_EVALIM (SCM_CAR (x), env) \
157 : SCM_GLOC_VAL (SCM_CAR (x))) \
158 : EVALCELLCAR (x, env))
160 #define EXTEND_ENV SCM_EXTEND_ENV
162 #ifdef MEMOIZE_LOCALS
165 scm_ilookup (SCM iloc
, SCM env
)
167 register int ir
= SCM_IFRAME (iloc
);
168 register SCM er
= env
;
169 for (; 0 != ir
; --ir
)
172 for (ir
= SCM_IDIST (iloc
); 0 != ir
; --ir
)
174 if (SCM_ICDRP (iloc
))
175 return SCM_CDRLOC (er
);
176 return SCM_CARLOC (SCM_CDR (er
));
182 /* The Lookup Car Race
185 Memoization of variables and special forms is done while executing
186 the code for the first time. As long as there is only one thread
187 everything is fine, but as soon as two threads execute the same
188 code concurrently `for the first time' they can come into conflict.
190 This memoization includes rewriting variable references into more
191 efficient forms and expanding macros. Furthermore, macro expansion
192 includes `compiling' special forms like `let', `cond', etc. into
193 tree-code instructions.
195 There shouldn't normally be a problem with memoizing local and
196 global variable references (into ilocs and glocs), because all
197 threads will mutate the code in *exactly* the same way and (if I
198 read the C code correctly) it is not possible to observe a half-way
199 mutated cons cell. The lookup procedure can handle this
200 transparently without any critical sections.
202 It is different with macro expansion, because macro expansion
203 happens outside of the lookup procedure and can't be
204 undone. Therefore it can't cope with it. It has to indicate
205 failure when it detects a lost race and hope that the caller can
206 handle it. Luckily, it turns out that this is the case.
208 An example to illustrate this: Suppose that the follwing form will
209 be memoized concurrently by two threads
213 Let's first examine the lookup of X in the body. The first thread
214 decides that it has to find the symbol "x" in the environment and
215 starts to scan it. Then the other thread takes over and actually
216 overtakes the first. It looks up "x" and substitutes an
217 appropriate iloc for it. Now the first thread continues and
218 completes its lookup. It comes to exactly the same conclusions as
219 the second one and could - without much ado - just overwrite the
220 iloc with the same iloc.
222 But let's see what will happen when the race occurs while looking
223 up the symbol "let" at the start of the form. It could happen that
224 the second thread interrupts the lookup of the first thread and not
225 only substitutes a gloc for it but goes right ahead and replaces it
226 with the compiled form (#@let* (x 12) x). Now, when the first
227 thread completes its lookup, it would replace the #@let* with a
228 gloc pointing to the "let" binding, effectively reverting the form
229 to (let (x 12) x). This is wrong. It has to detect that it has
230 lost the race and the evaluator has to reconsider the changed form
233 This race condition could be resolved with some kind of traffic
234 light (like mutexes) around scm_lookupcar, but I think that it is
235 best to avoid them in this case. They would serialize memoization
236 completely and because lookup involves calling arbitrary Scheme
237 code (via the lookup-thunk), threads could be blocked for an
238 arbitrary amount of time or even deadlock. But with the current
239 solution a lot of unnecessary work is potentially done. */
241 /* SCM_LOOKUPCAR1 is was SCM_LOOKUPCAR used to be but is allowed to
242 return NULL to indicate a failed lookup due to some race conditions
243 between threads. This only happens when VLOC is the first cell of
244 a special form that will eventually be memoized (like `let', etc.)
245 In that case the whole lookup is bogus and the caller has to
246 reconsider the complete special form.
248 SCM_LOOKUPCAR is still there, of course. It just calls
249 SCM_LOOKUPCAR1 and aborts on recieving NULL. So SCM_LOOKUPCAR
250 should only be called when it is known that VLOC is not the first
251 pair of a special form. Otherwise, use SCM_LOOKUPCAR1 and check
252 for NULL. I think I've found the only places where this
255 #endif /* USE_THREADS */
257 SCM_SYMBOL (scm_unbound_variable_key
, "unbound-variable");
261 scm_lookupcar1 (SCM vloc
, SCM genv
, int check
)
264 scm_lookupcar (SCM vloc
, SCM genv
, int check
)
268 register SCM
*al
, fl
, var
= SCM_CAR (vloc
);
270 register SCM var2
= var
;
272 #ifdef MEMOIZE_LOCALS
273 register SCM iloc
= SCM_ILOC00
;
275 for (; SCM_NIMP (env
); env
= SCM_CDR (env
))
277 if (!SCM_CONSP (SCM_CAR (env
)))
279 al
= SCM_CARLOC (env
);
280 for (fl
= SCM_CAR (*al
); SCM_NIMP (fl
); fl
= SCM_CDR (fl
))
284 if (SCM_EQ_P (fl
, var
))
286 #ifdef MEMOIZE_LOCALS
288 if (! SCM_EQ_P (SCM_CAR (vloc
), var
))
291 SCM_SET_CELL_WORD_0 (vloc
, SCM_UNPACK (iloc
) + SCM_ICDR
);
293 return SCM_CDRLOC (*al
);
298 al
= SCM_CDRLOC (*al
);
299 if (SCM_EQ_P (SCM_CAR (fl
), var
))
301 #ifdef MEMOIZE_LOCALS
302 #ifndef SCM_RECKLESS /* letrec inits to SCM_UNDEFINED */
303 if (SCM_UNBNDP (SCM_CAR (*al
)))
310 if (SCM_CAR (vloc
) != var
)
313 SCM_SETCAR (vloc
, iloc
);
315 return SCM_CARLOC (*al
);
317 #ifdef MEMOIZE_LOCALS
318 iloc
= SCM_PACK (SCM_UNPACK (iloc
) + SCM_IDINC
);
321 #ifdef MEMOIZE_LOCALS
322 iloc
= SCM_PACK ((~SCM_IDSTMSK
) & (SCM_UNPACK(iloc
) + SCM_IFRINC
));
326 SCM top_thunk
, vcell
;
329 top_thunk
= SCM_CAR (env
); /* env now refers to a top level env thunk */
333 top_thunk
= SCM_BOOL_F
;
334 vcell
= scm_sym2vcell (var
, top_thunk
, SCM_BOOL_F
);
335 if (SCM_FALSEP (vcell
))
341 if (SCM_NNULLP (env
) || SCM_UNBNDP (SCM_CDR (var
)))
345 /* scm_everr (vloc, genv,...) */
349 scm_error (scm_unbound_variable_key
, NULL
, "Unbound variable: ~S",
350 scm_cons (var
, SCM_EOL
), SCM_BOOL_F
);
352 scm_misc_error (NULL
, "Damaged environment: ~S",
353 scm_cons (var
, SCM_EOL
));
356 /* A variable could not be found, but we shall not throw an error. */
357 static SCM undef_object
= SCM_UNDEFINED
;
358 return &undef_object
;
363 if (SCM_CAR (vloc
) != var2
)
365 /* Some other thread has changed the very cell we are working
366 on. In effect, it must have done our job or messed it up
369 var
= SCM_CAR (vloc
);
370 if (SCM_ITAG3 (var
) == scm_tc3_cons_gloc
)
371 return SCM_GLOC_VAL_LOC (var
);
372 #ifdef MEMOIZE_LOCALS
373 if ((SCM_UNPACK (var
) & 127) == (127 & SCM_UNPACK (SCM_ILOC00
)))
374 return scm_ilookup (var
, genv
);
376 /* We can't cope with anything else than glocs and ilocs. When
377 a special form has been memoized (i.e. `let' into `#@let') we
378 return NULL and expect the calling function to do the right
379 thing. For the evaluator, this means going back and redoing
380 the dispatch on the car of the form. */
383 #endif /* USE_THREADS */
385 SCM_SET_CELL_WORD_0 (vloc
, SCM_UNPACK (var
) + scm_tc3_cons_gloc
);
386 /* Except wait...what if the var is not a vcell,
387 * but syntax or something.... */
388 return SCM_CDRLOC (var
);
393 scm_lookupcar (SCM vloc
, SCM genv
, int check
)
395 SCM
*loc
= scm_lookupcar1 (vloc
, genv
, check
);
402 #define unmemocar scm_unmemocar
405 scm_unmemocar (SCM form
, SCM env
)
412 if (SCM_ITAG3 (c
) == scm_tc3_cons_gloc
)
413 SCM_SETCAR (form
, SCM_GLOC_SYM (c
));
414 #ifdef MEMOIZE_LOCALS
415 #ifdef DEBUG_EXTENSIONS
416 else if (SCM_ILOCP (c
))
420 for (ir
= SCM_IFRAME (c
); ir
!= 0; --ir
)
422 env
= SCM_CAR (SCM_CAR (env
));
423 for (ir
= SCM_IDIST (c
); ir
!= 0; --ir
)
425 SCM_SETCAR (form
, SCM_ICDRP (c
) ? env
: SCM_CAR (env
));
434 scm_eval_car (SCM pair
, SCM env
)
436 return SCM_XEVALCAR (pair
, env
);
441 * The following rewrite expressions and
442 * some memoized forms have different syntax
445 const char scm_s_expression
[] = "missing or extra expression";
446 const char scm_s_test
[] = "bad test";
447 const char scm_s_body
[] = "bad body";
448 const char scm_s_bindings
[] = "bad 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";
453 SCM scm_sym_dot
, scm_sym_arrow
, scm_sym_else
;
454 SCM scm_sym_unquote
, scm_sym_uq_splicing
, scm_sym_apply
;
458 #ifdef DEBUG_EXTENSIONS
459 SCM scm_sym_enter_frame
, scm_sym_apply_frame
, scm_sym_exit_frame
;
464 /* Check that the body denoted by XORIG is valid and rewrite it into
465 its internal form. The internal form of a body is just the body
466 itself, but prefixed with an ISYM that denotes to what kind of
467 outer construct this body belongs. A lambda body starts with
468 SCM_IM_LAMBDA, for example, a body of a let starts with SCM_IM_LET,
469 etc. The one exception is a body that belongs to a letrec that has
470 been formed by rewriting internal defines: it starts with
473 /* XXX - Besides controlling the rewriting of internal defines, the
474 additional ISYM could be used for improved error messages.
475 This is not done yet. */
478 scm_m_body (SCM op
, SCM xorig
, const char *what
)
480 SCM_ASSYNT (scm_ilength (xorig
) >= 1, xorig
, scm_s_expression
, what
);
482 /* Don't add another ISYM if one is present already. */
483 if (SCM_ISYMP (SCM_CAR (xorig
)))
486 /* Retain possible doc string. */
487 if (!SCM_CONSP (SCM_CAR (xorig
)))
489 if (SCM_NNULLP (SCM_CDR(xorig
)))
490 return scm_cons (SCM_CAR (xorig
),
491 scm_m_body (op
, SCM_CDR(xorig
), what
));
495 return scm_cons (op
, xorig
);
498 SCM_SYNTAX(s_quote
,"quote", scm_makmmacro
, scm_m_quote
);
499 SCM_GLOBAL_SYMBOL(scm_sym_quote
, s_quote
);
502 scm_m_quote (SCM xorig
, SCM env
)
504 SCM x
= scm_copy_tree (SCM_CDR (xorig
));
506 SCM_ASSYNT (scm_ilength (SCM_CDR (xorig
)) == 1,
507 xorig
, scm_s_expression
, s_quote
);
508 return scm_cons (SCM_IM_QUOTE
, x
);
513 SCM_SYNTAX(s_begin
, "begin", scm_makmmacro
, scm_m_begin
);
514 SCM_GLOBAL_SYMBOL(scm_sym_begin
, s_begin
);
517 scm_m_begin (SCM xorig
, SCM env
)
519 SCM_ASSYNT (scm_ilength (SCM_CDR (xorig
)) >= 1,
520 xorig
, scm_s_expression
, s_begin
);
521 return scm_cons (SCM_IM_BEGIN
, SCM_CDR (xorig
));
524 SCM_SYNTAX(s_if
, "if", scm_makmmacro
, scm_m_if
);
525 SCM_GLOBAL_SYMBOL(scm_sym_if
, s_if
);
528 scm_m_if (SCM xorig
, SCM env
)
530 int len
= scm_ilength (SCM_CDR (xorig
));
531 SCM_ASSYNT (len
>= 2 && len
<= 3, xorig
, scm_s_expression
, "if");
532 return scm_cons (SCM_IM_IF
, SCM_CDR (xorig
));
536 /* Will go into the RnRS module when Guile is factorized.
537 SCM_SYNTAX(scm_s_set_x,"set!", scm_makmmacro, scm_m_set_x); */
538 const char scm_s_set_x
[] = "set!";
539 SCM_GLOBAL_SYMBOL(scm_sym_set_x
, scm_s_set_x
);
542 scm_m_set_x (SCM xorig
, SCM env
)
544 SCM x
= SCM_CDR (xorig
);
545 SCM_ASSYNT (2 == scm_ilength (x
), xorig
, scm_s_expression
, scm_s_set_x
);
546 SCM_ASSYNT (SCM_SYMBOLP (SCM_CAR (x
)),
547 xorig
, scm_s_variable
, scm_s_set_x
);
548 return scm_cons (SCM_IM_SET_X
, x
);
555 scm_m_vref (SCM xorig
, SCM env
)
557 SCM x
= SCM_CDR (xorig
);
558 SCM_ASSYNT (1 == scm_ilength (x
), xorig
, scm_s_expression
, s_vref
);
559 if (SCM_NIMP(x
) && UDSCM_VARIABLEP (SCM_CAR (x
)))
561 /* scm_everr (SCM_UNDEFINED, env,..., "global variable reference") */
562 scm_misc_error (NULL
,
564 scm_listify (SCM_CAR (SCM_CDR (x
)), SCM_UNDEFINED
));
566 SCM_ASSYNT (SCM_NIMP(x
) && DEFSCM_VARIABLEP (SCM_CAR (x
)),
567 xorig
, scm_s_variable
, s_vref
);
568 return scm_cons (IM_VREF
, x
);
574 scm_m_vset (SCM xorig
, SCM env
)
576 SCM x
= SCM_CDR (xorig
);
577 SCM_ASSYNT (3 == scm_ilength (x
), xorig
, scm_s_expression
, s_vset
);
578 SCM_ASSYNT ((DEFSCM_VARIABLEP (SCM_CAR (x
))
579 || UDSCM_VARIABLEP (SCM_CAR (x
))),
580 xorig
, scm_s_variable
, s_vset
);
581 return scm_cons (IM_VSET
, x
);
586 SCM_SYNTAX(s_and
, "and", scm_makmmacro
, scm_m_and
);
587 SCM_GLOBAL_SYMBOL(scm_sym_and
, s_and
);
590 scm_m_and (SCM xorig
, SCM env
)
592 int len
= scm_ilength (SCM_CDR (xorig
));
593 SCM_ASSYNT (len
>= 0, xorig
, scm_s_test
, s_and
);
595 return scm_cons (SCM_IM_AND
, SCM_CDR (xorig
));
600 SCM_SYNTAX(s_or
,"or", scm_makmmacro
, scm_m_or
);
601 SCM_GLOBAL_SYMBOL(scm_sym_or
,s_or
);
604 scm_m_or (SCM xorig
, SCM env
)
606 int len
= scm_ilength (SCM_CDR (xorig
));
607 SCM_ASSYNT (len
>= 0, xorig
, scm_s_test
, s_or
);
609 return scm_cons (SCM_IM_OR
, SCM_CDR (xorig
));
615 SCM_SYNTAX(s_case
, "case", scm_makmmacro
, scm_m_case
);
616 SCM_GLOBAL_SYMBOL(scm_sym_case
, s_case
);
619 scm_m_case (SCM xorig
, SCM env
)
621 SCM proc
, cdrx
= scm_list_copy (SCM_CDR (xorig
)), x
= cdrx
;
622 SCM_ASSYNT (scm_ilength (x
) >= 2, xorig
, scm_s_clauses
, s_case
);
623 while (SCM_NIMP (x
= SCM_CDR (x
)))
626 SCM_ASSYNT (scm_ilength (proc
) >= 2, xorig
, scm_s_clauses
, s_case
);
627 SCM_ASSYNT (scm_ilength (SCM_CAR (proc
)) >= 0
628 || SCM_EQ_P (scm_sym_else
, SCM_CAR (proc
)),
629 xorig
, scm_s_clauses
, s_case
);
631 return scm_cons (SCM_IM_CASE
, cdrx
);
635 SCM_SYNTAX(s_cond
, "cond", scm_makmmacro
, scm_m_cond
);
636 SCM_GLOBAL_SYMBOL(scm_sym_cond
, s_cond
);
640 scm_m_cond (SCM xorig
, SCM env
)
642 SCM arg1
, cdrx
= scm_list_copy (SCM_CDR (xorig
)), x
= cdrx
;
643 int len
= scm_ilength (x
);
644 SCM_ASSYNT (len
>= 1, xorig
, scm_s_clauses
, s_cond
);
648 len
= scm_ilength (arg1
);
649 SCM_ASSYNT (len
>= 1, xorig
, scm_s_clauses
, s_cond
);
650 if (SCM_EQ_P (scm_sym_else
, SCM_CAR (arg1
)))
652 SCM_ASSYNT (SCM_NULLP (SCM_CDR (x
)) && len
>= 2,
653 xorig
, "bad ELSE clause", s_cond
);
654 SCM_SETCAR (arg1
, SCM_BOOL_T
);
656 if (len
>= 2 && SCM_EQ_P (scm_sym_arrow
, SCM_CAR (SCM_CDR (arg1
))))
657 SCM_ASSYNT (3 == len
&& SCM_NIMP (SCM_CAR (SCM_CDR (SCM_CDR (arg1
)))),
658 xorig
, "bad recipient", s_cond
);
661 return scm_cons (SCM_IM_COND
, cdrx
);
664 SCM_SYNTAX(s_lambda
, "lambda", scm_makmmacro
, scm_m_lambda
);
665 SCM_GLOBAL_SYMBOL(scm_sym_lambda
, s_lambda
);
668 scm_m_lambda (SCM xorig
, SCM env
)
670 SCM proc
, x
= SCM_CDR (xorig
);
671 if (scm_ilength (x
) < 2)
674 if (SCM_NULLP (proc
))
676 if (SCM_EQ_P (SCM_IM_LET
, proc
)) /* named let */
680 if (SCM_SYMBOLP (proc
))
682 if (SCM_NCONSP (proc
))
684 while (SCM_NIMP (proc
))
686 if (SCM_NCONSP (proc
))
688 if (!SCM_SYMBOLP (proc
))
693 if (!SCM_SYMBOLP (SCM_CAR (proc
)))
695 proc
= SCM_CDR (proc
);
697 if (SCM_NNULLP (proc
))
700 scm_wta (xorig
, scm_s_formals
, s_lambda
);
704 return scm_cons2 (SCM_IM_LAMBDA
, SCM_CAR (x
),
705 scm_m_body (SCM_IM_LAMBDA
, SCM_CDR (x
), s_lambda
));
708 SCM_SYNTAX(s_letstar
,"let*", scm_makmmacro
, scm_m_letstar
);
709 SCM_GLOBAL_SYMBOL(scm_sym_letstar
,s_letstar
);
713 scm_m_letstar (SCM xorig
, SCM env
)
715 SCM x
= SCM_CDR (xorig
), arg1
, proc
, vars
= SCM_EOL
, *varloc
= &vars
;
716 int len
= scm_ilength (x
);
717 SCM_ASSYNT (len
>= 2, xorig
, scm_s_body
, s_letstar
);
719 SCM_ASSYNT (scm_ilength (proc
) >= 0, xorig
, scm_s_bindings
, s_letstar
);
720 while (SCM_NIMP (proc
))
722 arg1
= SCM_CAR (proc
);
723 SCM_ASSYNT (2 == scm_ilength (arg1
), xorig
, scm_s_bindings
, s_letstar
);
724 SCM_ASSYNT (SCM_SYMBOLP (SCM_CAR (arg1
)), xorig
, scm_s_variable
, s_letstar
);
725 *varloc
= scm_cons2 (SCM_CAR (arg1
), SCM_CAR (SCM_CDR (arg1
)), SCM_EOL
);
726 varloc
= SCM_CDRLOC (SCM_CDR (*varloc
));
727 proc
= SCM_CDR (proc
);
729 x
= scm_cons (vars
, SCM_CDR (x
));
731 return scm_cons2 (SCM_IM_LETSTAR
, SCM_CAR (x
),
732 scm_m_body (SCM_IM_LETSTAR
, SCM_CDR (x
), s_letstar
));
735 /* DO gets the most radically altered syntax
736 (do ((<var1> <init1> <step1>)
742 (do_mem (varn ... var2 var1)
743 (<init1> <init2> ... <initn>)
746 <step1> <step2> ... <stepn>) ;; missing steps replaced by var
749 SCM_SYNTAX(s_do
, "do", scm_makmmacro
, scm_m_do
);
750 SCM_GLOBAL_SYMBOL(scm_sym_do
, s_do
);
753 scm_m_do (SCM xorig
, SCM env
)
755 SCM x
= SCM_CDR (xorig
), arg1
, proc
;
756 SCM vars
= SCM_EOL
, inits
= SCM_EOL
, steps
= SCM_EOL
;
757 SCM
*initloc
= &inits
, *steploc
= &steps
;
758 int len
= scm_ilength (x
);
759 SCM_ASSYNT (len
>= 2, xorig
, scm_s_test
, "do");
761 SCM_ASSYNT (scm_ilength (proc
) >= 0, xorig
, scm_s_bindings
, "do");
762 while (SCM_NIMP(proc
))
764 arg1
= SCM_CAR (proc
);
765 len
= scm_ilength (arg1
);
766 SCM_ASSYNT (2 == len
|| 3 == len
, xorig
, scm_s_bindings
, "do");
767 SCM_ASSYNT (SCM_SYMBOLP (SCM_CAR (arg1
)), xorig
, scm_s_variable
, "do");
768 /* vars reversed here, inits and steps reversed at evaluation */
769 vars
= scm_cons (SCM_CAR (arg1
), vars
); /* variable */
770 arg1
= SCM_CDR (arg1
);
771 *initloc
= scm_cons (SCM_CAR (arg1
), SCM_EOL
); /* init */
772 initloc
= SCM_CDRLOC (*initloc
);
773 arg1
= SCM_CDR (arg1
);
774 *steploc
= scm_cons (SCM_IMP (arg1
) ? SCM_CAR (vars
) : SCM_CAR (arg1
), SCM_EOL
); /* step */
775 steploc
= SCM_CDRLOC (*steploc
);
776 proc
= SCM_CDR (proc
);
779 SCM_ASSYNT (scm_ilength (SCM_CAR (x
)) >= 1, xorig
, scm_s_test
, "do");
780 x
= scm_cons2 (SCM_CAR (x
), SCM_CDR (x
), steps
);
781 x
= scm_cons2 (vars
, inits
, x
);
782 return scm_cons (SCM_IM_DO
, x
);
785 /* evalcar is small version of inline EVALCAR when we don't care about
788 #define evalcar scm_eval_car
791 static SCM
iqq (SCM form
, SCM env
, int depth
);
793 SCM_SYNTAX(s_quasiquote
, "quasiquote", scm_makacro
, scm_m_quasiquote
);
794 SCM_GLOBAL_SYMBOL(scm_sym_quasiquote
, s_quasiquote
);
797 scm_m_quasiquote (SCM xorig
, SCM env
)
799 SCM x
= SCM_CDR (xorig
);
800 SCM_ASSYNT (scm_ilength (x
) == 1, xorig
, scm_s_expression
, s_quasiquote
);
801 return iqq (SCM_CAR (x
), env
, 1);
806 iqq (SCM form
,SCM env
,int depth
)
812 if (SCM_VECTORP (form
))
814 long i
= SCM_LENGTH (form
);
815 SCM
*data
= SCM_VELTS (form
);
818 tmp
= scm_cons (data
[i
], tmp
);
819 return scm_vector (iqq (tmp
, env
, depth
));
821 if (SCM_NCONSP(form
))
823 tmp
= SCM_CAR (form
);
824 if (SCM_EQ_P (scm_sym_quasiquote
, tmp
))
829 if (SCM_EQ_P (scm_sym_unquote
, tmp
))
833 form
= SCM_CDR (form
);
834 SCM_ASSERT (SCM_ECONSP (form
) && SCM_NULLP (SCM_CDR (form
)),
835 form
, SCM_ARG1
, s_quasiquote
);
837 return evalcar (form
, env
);
838 return scm_cons2 (tmp
, iqq (SCM_CAR (form
), env
, depth
), SCM_EOL
);
840 if (SCM_NIMP (tmp
) && (SCM_EQ_P (scm_sym_uq_splicing
, SCM_CAR (tmp
))))
844 return scm_append (scm_cons2 (evalcar (tmp
, env
), iqq (SCM_CDR (form
), env
, depth
), SCM_EOL
));
846 return scm_cons (iqq (SCM_CAR (form
), env
, edepth
), iqq (SCM_CDR (form
), env
, depth
));
849 /* Here are acros which return values rather than code. */
851 SCM_SYNTAX (s_delay
, "delay", scm_makmmacro
, scm_m_delay
);
852 SCM_GLOBAL_SYMBOL (scm_sym_delay
, s_delay
);
855 scm_m_delay (SCM xorig
, SCM env
)
857 SCM_ASSYNT (scm_ilength (xorig
) == 2, xorig
, scm_s_expression
, s_delay
);
858 return scm_cons2 (SCM_IM_DELAY
, SCM_EOL
, SCM_CDR (xorig
));
862 SCM_SYNTAX(s_define
, "define", scm_makmmacro
, scm_m_define
);
863 SCM_GLOBAL_SYMBOL(scm_sym_define
, s_define
);
866 scm_m_define (SCM x
, SCM env
)
870 /* SCM_ASSYNT(SCM_NULLP(env), x, "bad placement", s_define);*/
871 SCM_ASSYNT (scm_ilength (x
) >= 2, arg1
, scm_s_expression
, s_define
);
874 while (SCM_CONSP (proc
))
875 { /* nested define syntax */
876 x
= scm_cons (scm_cons2 (scm_sym_lambda
, SCM_CDR (proc
), x
), SCM_EOL
);
877 proc
= SCM_CAR (proc
);
879 SCM_ASSYNT (SCM_SYMBOLP (proc
),
880 arg1
, scm_s_variable
, s_define
);
881 SCM_ASSYNT (1 == scm_ilength (x
), arg1
, scm_s_expression
, s_define
);
882 if (SCM_TOP_LEVEL (env
))
884 x
= evalcar (x
, env
);
885 #ifdef DEBUG_EXTENSIONS
886 if (SCM_REC_PROCNAMES_P
&& SCM_NIMP (x
))
890 if (SCM_CLOSUREP (arg1
)
891 /* Only the first definition determines the name. */
892 && SCM_FALSEP (scm_procedure_property (arg1
, scm_sym_name
)))
893 scm_set_procedure_property_x (arg1
, scm_sym_name
, proc
);
894 else if (SCM_TYP16 (arg1
) == scm_tc16_macro
895 && !SCM_EQ_P (SCM_CDR (arg1
), arg1
))
897 arg1
= SCM_CDR (arg1
);
902 arg1
= scm_sym2vcell (proc
, scm_env_top_level (env
), SCM_BOOL_T
);
905 if (SCM_NIMP (SCM_CDR (arg1
)) && (SCM_SNAME (SCM_CDR (arg1
)) == proc
)
906 && (SCM_CDR (arg1
) != x
))
907 scm_warn ("redefining built-in ", SCM_CHARS (proc
));
910 if (5 <= scm_verbose
&& SCM_UNDEFINED
!= SCM_CDR (arg1
))
911 scm_warn ("redefining ", SCM_CHARS (proc
));
913 SCM_SETCDR (arg1
, x
);
915 return scm_cons2 (scm_sym_quote
, SCM_CAR (arg1
), SCM_EOL
);
917 return SCM_UNSPECIFIED
;
920 return scm_cons2 (SCM_IM_DEFINE
, proc
, x
);
926 scm_m_letrec1 (SCM op
, SCM imm
, SCM xorig
, SCM env
)
928 SCM cdrx
= SCM_CDR (xorig
); /* locally mutable version of form */
929 char *what
= SCM_CHARS (SCM_CAR (xorig
));
930 SCM x
= cdrx
, proc
, arg1
; /* structure traversers */
931 SCM vars
= SCM_EOL
, inits
= SCM_EOL
, *initloc
= &inits
;
934 SCM_ASSYNT (scm_ilength (proc
) >= 1, xorig
, scm_s_bindings
, what
);
937 /* vars scm_list reversed here, inits reversed at evaluation */
938 arg1
= SCM_CAR (proc
);
939 SCM_ASSYNT (2 == scm_ilength (arg1
), xorig
, scm_s_bindings
, what
);
940 SCM_ASSYNT (SCM_SYMBOLP (SCM_CAR (arg1
)), xorig
, scm_s_variable
, what
);
941 vars
= scm_cons (SCM_CAR (arg1
), vars
);
942 *initloc
= scm_cons (SCM_CAR (SCM_CDR (arg1
)), SCM_EOL
);
943 initloc
= SCM_CDRLOC (*initloc
);
945 while (SCM_NIMP (proc
= SCM_CDR (proc
)));
947 return scm_cons2 (op
, vars
,
948 scm_cons (inits
, scm_m_body (imm
, SCM_CDR (x
), what
)));
951 SCM_SYNTAX(s_letrec
, "letrec", scm_makmmacro
, scm_m_letrec
);
952 SCM_GLOBAL_SYMBOL(scm_sym_letrec
, s_letrec
);
955 scm_m_letrec (SCM xorig
, SCM env
)
957 SCM x
= SCM_CDR (xorig
);
958 SCM_ASSYNT (scm_ilength (x
) >= 2, xorig
, scm_s_body
, s_letrec
);
960 if (SCM_NULLP (SCM_CAR (x
))) /* null binding, let* faster */
961 return scm_m_letstar (scm_cons2 (SCM_CAR (xorig
), SCM_EOL
,
962 scm_m_body (SCM_IM_LETREC
,
967 return scm_m_letrec1 (SCM_IM_LETREC
, SCM_IM_LETREC
, xorig
, env
);
970 SCM_SYNTAX(s_let
, "let", scm_makmmacro
, scm_m_let
);
971 SCM_GLOBAL_SYMBOL(scm_sym_let
, s_let
);
974 scm_m_let (SCM xorig
, SCM env
)
976 SCM cdrx
= SCM_CDR (xorig
); /* locally mutable version of form */
977 SCM x
= cdrx
, proc
, arg1
, name
; /* structure traversers */
978 SCM vars
= SCM_EOL
, inits
= SCM_EOL
, *varloc
= &vars
, *initloc
= &inits
;
980 SCM_ASSYNT (scm_ilength (x
) >= 2, xorig
, scm_s_body
, s_let
);
984 && SCM_CONSP (SCM_CAR (proc
)) && SCM_NULLP (SCM_CDR (proc
))))
986 /* null or single binding, let* is faster */
987 return scm_m_letstar (scm_cons2 (SCM_CAR (xorig
), proc
,
988 scm_m_body (SCM_IM_LET
,
994 SCM_ASSYNT (SCM_NIMP (proc
), xorig
, scm_s_bindings
, s_let
);
995 if (SCM_CONSP (proc
))
997 /* plain let, proc is <bindings> */
998 return scm_m_letrec1 (SCM_IM_LET
, SCM_IM_LET
, xorig
, env
);
1001 if (!SCM_SYMBOLP (proc
))
1002 scm_wta (xorig
, scm_s_bindings
, s_let
); /* bad let */
1003 name
= proc
; /* named let, build equiv letrec */
1005 SCM_ASSYNT (scm_ilength (x
) >= 2, xorig
, scm_s_body
, s_let
);
1006 proc
= SCM_CAR (x
); /* bindings list */
1007 SCM_ASSYNT (scm_ilength (proc
) >= 0, xorig
, scm_s_bindings
, s_let
);
1008 while (SCM_NIMP (proc
))
1009 { /* vars and inits both in order */
1010 arg1
= SCM_CAR (proc
);
1011 SCM_ASSYNT (2 == scm_ilength (arg1
), xorig
, scm_s_bindings
, s_let
);
1012 SCM_ASSYNT (SCM_SYMBOLP (SCM_CAR (arg1
)),
1013 xorig
, scm_s_variable
, s_let
);
1014 *varloc
= scm_cons (SCM_CAR (arg1
), SCM_EOL
);
1015 varloc
= SCM_CDRLOC (*varloc
);
1016 *initloc
= scm_cons (SCM_CAR (SCM_CDR (arg1
)), SCM_EOL
);
1017 initloc
= SCM_CDRLOC (*initloc
);
1018 proc
= SCM_CDR (proc
);
1021 proc
= scm_cons2 (scm_sym_lambda
, vars
,
1022 scm_m_body (SCM_IM_LET
, SCM_CDR (x
), "let"));
1023 proc
= scm_cons2 (scm_sym_let
, scm_cons (scm_cons2 (name
, proc
, SCM_EOL
),
1025 scm_acons (name
, inits
, SCM_EOL
));
1026 return scm_m_letrec1 (SCM_IM_LETREC
, SCM_IM_LET
, proc
, env
);
1030 SCM_SYNTAX (s_atapply
,"@apply", scm_makmmacro
, scm_m_apply
);
1031 SCM_GLOBAL_SYMBOL (scm_sym_atapply
, s_atapply
);
1032 SCM_GLOBAL_SYMBOL (scm_sym_apply
, s_atapply
+ 1);
1035 scm_m_apply (SCM xorig
, SCM env
)
1037 SCM_ASSYNT (scm_ilength (SCM_CDR (xorig
)) == 2,
1038 xorig
, scm_s_expression
, s_atapply
);
1039 return scm_cons (SCM_IM_APPLY
, SCM_CDR (xorig
));
1043 SCM_SYNTAX(s_atcall_cc
,"@call-with-current-continuation", scm_makmmacro
, scm_m_cont
);
1044 SCM_GLOBAL_SYMBOL(scm_sym_atcall_cc
,s_atcall_cc
);
1048 scm_m_cont (SCM xorig
, SCM env
)
1050 SCM_ASSYNT (scm_ilength (SCM_CDR (xorig
)) == 1,
1051 xorig
, scm_s_expression
, s_atcall_cc
);
1052 return scm_cons (SCM_IM_CONT
, SCM_CDR (xorig
));
1055 /* Multi-language support */
1060 SCM_SYNTAX (s_nil_cond
, "nil-cond", scm_makmmacro
, scm_m_nil_cond
);
1063 scm_m_nil_cond (SCM xorig
, SCM env
)
1065 int len
= scm_ilength (SCM_CDR (xorig
));
1066 SCM_ASSYNT (len
>= 1 && (len
& 1) == 1, xorig
,
1067 scm_s_expression
, "nil-cond");
1068 return scm_cons (SCM_IM_NIL_COND
, SCM_CDR (xorig
));
1071 SCM_SYNTAX (s_nil_ify
, "nil-ify", scm_makmmacro
, scm_m_nil_ify
);
1074 scm_m_nil_ify (SCM xorig
, SCM env
)
1076 SCM_ASSYNT (scm_ilength (SCM_CDR (xorig
)) == 1,
1077 xorig
, scm_s_expression
, "nil-ify");
1078 return scm_cons (SCM_IM_NIL_IFY
, SCM_CDR (xorig
));
1081 SCM_SYNTAX (s_t_ify
, "t-ify", scm_makmmacro
, scm_m_t_ify
);
1084 scm_m_t_ify (SCM xorig
, SCM env
)
1086 SCM_ASSYNT (scm_ilength (SCM_CDR (xorig
)) == 1,
1087 xorig
, scm_s_expression
, "t-ify");
1088 return scm_cons (SCM_IM_T_IFY
, SCM_CDR (xorig
));
1091 SCM_SYNTAX (s_0_cond
, "0-cond", scm_makmmacro
, scm_m_0_cond
);
1094 scm_m_0_cond (SCM xorig
, SCM env
)
1096 int len
= scm_ilength (SCM_CDR (xorig
));
1097 SCM_ASSYNT (len
>= 1 && (len
& 1) == 1, xorig
,
1098 scm_s_expression
, "0-cond");
1099 return scm_cons (SCM_IM_0_COND
, SCM_CDR (xorig
));
1102 SCM_SYNTAX (s_0_ify
, "0-ify", scm_makmmacro
, scm_m_0_ify
);
1105 scm_m_0_ify (SCM xorig
, SCM env
)
1107 SCM_ASSYNT (scm_ilength (SCM_CDR (xorig
)) == 1,
1108 xorig
, scm_s_expression
, "0-ify");
1109 return scm_cons (SCM_IM_0_IFY
, SCM_CDR (xorig
));
1112 SCM_SYNTAX (s_1_ify
, "1-ify", scm_makmmacro
, scm_m_1_ify
);
1115 scm_m_1_ify (SCM xorig
, SCM env
)
1117 SCM_ASSYNT (scm_ilength (SCM_CDR (xorig
)) == 1,
1118 xorig
, scm_s_expression
, "1-ify");
1119 return scm_cons (SCM_IM_1_IFY
, SCM_CDR (xorig
));
1122 SCM_SYNTAX (s_atfop
, "@fop", scm_makmmacro
, scm_m_atfop
);
1125 scm_m_atfop (SCM xorig
, SCM env
)
1127 SCM x
= SCM_CDR (xorig
), vcell
;
1128 SCM_ASSYNT (scm_ilength (x
) >= 1, xorig
, scm_s_expression
, "@fop");
1129 vcell
= scm_symbol_fref (SCM_CAR (x
));
1130 SCM_ASSYNT (SCM_CONSP (vcell
), x
,
1131 "Symbol's function definition is void", NULL
);
1132 SCM_SET_CELL_WORD_0 (x
, SCM_UNPACK (vcell
) + scm_tc3_cons_gloc
);
1136 SCM_SYNTAX (s_atbind
, "@bind", scm_makmmacro
, scm_m_atbind
);
1139 scm_m_atbind (SCM xorig
, SCM env
)
1141 SCM x
= SCM_CDR (xorig
);
1142 SCM_ASSYNT (scm_ilength (x
) > 1, xorig
, scm_s_expression
, "@bind");
1148 while (SCM_NIMP (SCM_CDR (env
)))
1149 env
= SCM_CDR (env
);
1150 env
= SCM_CAR (env
);
1151 if (SCM_CONSP (env
))
1156 while (SCM_NIMP (x
))
1158 SCM_SET_CELL_WORD_0 (x
, SCM_UNPACK (scm_sym2vcell (SCM_CAR (x
), env
, SCM_BOOL_T
)) + scm_tc3_cons_gloc
);
1161 return scm_cons (SCM_IM_BIND
, SCM_CDR (xorig
));
1165 scm_m_expand_body (SCM xorig
, SCM env
)
1167 SCM form
, x
= SCM_CDR (xorig
), defs
= SCM_EOL
;
1168 char *what
= SCM_ISYMCHARS (SCM_CAR (xorig
)) + 2;
1170 while (SCM_NIMP (x
))
1173 if (SCM_IMP (form
) || SCM_NCONSP (form
))
1175 if (SCM_IMP (SCM_CAR (form
)))
1177 if (!SCM_SYMBOLP (SCM_CAR (form
)))
1180 form
= scm_macroexp (scm_cons_source (form
,
1185 if (SCM_EQ_P (SCM_IM_DEFINE
, SCM_CAR (form
)))
1187 defs
= scm_cons (SCM_CDR (form
), defs
);
1190 else if (SCM_NIMP(defs
))
1194 else if (SCM_EQ_P (SCM_IM_BEGIN
, SCM_CAR (form
)))
1196 x
= scm_append (scm_cons2 (SCM_CDR (form
), SCM_CDR (x
), SCM_EOL
));
1200 x
= scm_cons (form
, SCM_CDR(x
));
1205 SCM_ASSYNT (SCM_NIMP (x
), SCM_CDR (xorig
), scm_s_body
, what
);
1206 if (SCM_NIMP (defs
))
1208 x
= scm_cons (scm_m_letrec1 (SCM_IM_LETREC
,
1210 scm_cons2 (scm_sym_define
, defs
, x
),
1216 SCM_SETCAR (xorig
, SCM_CAR (x
));
1217 SCM_SETCDR (xorig
, SCM_CDR (x
));
1224 scm_macroexp (SCM x
, SCM env
)
1228 /* Don't bother to produce error messages here. We get them when we
1229 eventually execute the code for real. */
1232 if (!SCM_SYMBOLP (SCM_CAR (x
)))
1237 SCM
*proc_ptr
= scm_lookupcar1 (x
, env
, 0);
1238 if (proc_ptr
== NULL
)
1240 /* We have lost the race. */
1246 proc
= *scm_lookupcar (x
, env
, 0);
1249 /* Only handle memoizing macros. `Acros' and `macros' are really
1250 special forms and should not be evaluated here. */
1253 || scm_tc16_macro
!= SCM_TYP16 (proc
)
1254 || (SCM_CELL_WORD_0 (proc
) >> 16) != 2)
1258 res
= scm_apply (SCM_CDR (proc
), x
, scm_cons (env
, scm_listofnull
));
1260 if (scm_ilength (res
) <= 0)
1261 res
= scm_cons2 (SCM_IM_BEGIN
, res
, SCM_EOL
);
1264 SCM_SETCAR (x
, SCM_CAR (res
));
1265 SCM_SETCDR (x
, SCM_CDR (res
));
1271 /* scm_unmemocopy takes a memoized expression together with its
1272 * environment and rewrites it to its original form. Thus, it is the
1273 * inversion of the rewrite rules above. The procedure is not
1274 * optimized for speed. It's used in scm_iprin1 when printing the
1275 * code of a closure, in scm_procedure_source, in display_frame when
1276 * generating the source for a stackframe in a backtrace, and in
1277 * display_expression.
1280 /* We should introduce an anti-macro interface so that it is possible
1281 * to plug in transformers in both directions from other compilation
1282 * units. unmemocopy could then dispatch to anti-macro transformers.
1283 * (Those transformers could perhaps be written in slightly more
1284 * readable style... :)
1287 #define SCM_BIT8(x) (127 & SCM_UNPACK (x))
1290 unmemocopy (SCM x
, SCM env
)
1293 #ifdef DEBUG_EXTENSIONS
1296 if (SCM_NCELLP (x
) || SCM_NECONSP (x
))
1298 #ifdef DEBUG_EXTENSIONS
1299 p
= scm_whash_lookup (scm_source_whash
, x
);
1301 switch (SCM_TYP7 (x
))
1303 case SCM_BIT8(SCM_IM_AND
):
1304 ls
= z
= scm_cons (scm_sym_and
, SCM_UNSPECIFIED
);
1306 case SCM_BIT8(SCM_IM_BEGIN
):
1307 ls
= z
= scm_cons (scm_sym_begin
, SCM_UNSPECIFIED
);
1309 case SCM_BIT8(SCM_IM_CASE
):
1310 ls
= z
= scm_cons (scm_sym_case
, SCM_UNSPECIFIED
);
1312 case SCM_BIT8(SCM_IM_COND
):
1313 ls
= z
= scm_cons (scm_sym_cond
, SCM_UNSPECIFIED
);
1315 case SCM_BIT8(SCM_IM_DO
):
1316 ls
= scm_cons (scm_sym_do
, SCM_UNSPECIFIED
);
1318 case SCM_BIT8(SCM_IM_IF
):
1319 ls
= z
= scm_cons (scm_sym_if
, SCM_UNSPECIFIED
);
1321 case SCM_BIT8(SCM_IM_LET
):
1322 ls
= scm_cons (scm_sym_let
, SCM_UNSPECIFIED
);
1324 case SCM_BIT8(SCM_IM_LETREC
):
1327 ls
= scm_cons (scm_sym_letrec
, SCM_UNSPECIFIED
);
1331 f
= v
= SCM_CAR (x
);
1333 z
= EXTEND_ENV (f
, SCM_EOL
, env
);
1335 e
= scm_reverse (unmemocopy (SCM_CAR (x
),
1336 SCM_EQ_P (SCM_CAR (ls
), scm_sym_letrec
) ? z
: env
));
1339 s
= SCM_EQ_P (SCM_CAR (ls
), scm_sym_do
)
1340 ? scm_reverse (unmemocopy (SCM_CDR (SCM_CDR (SCM_CDR (x
))), env
))
1342 /* build transformed binding list */
1344 while (SCM_NIMP (v
))
1346 z
= scm_acons (SCM_CAR (v
),
1347 scm_cons (SCM_CAR (e
),
1348 SCM_EQ_P (SCM_CAR (s
), SCM_CAR (v
))
1350 : scm_cons (SCM_CAR (s
), SCM_EOL
)),
1356 z
= scm_cons (z
, SCM_UNSPECIFIED
);
1358 if (SCM_EQ_P (SCM_CAR (ls
), scm_sym_do
))
1362 SCM_SETCDR (z
, scm_cons (unmemocopy (SCM_CAR (x
), env
),
1365 x
= (SCM
) (SCM_CARLOC (SCM_CDR (x
)) - 1);
1366 /* body forms are now to be found in SCM_CDR (x)
1367 (this is how *real* code look like! :) */
1371 case SCM_BIT8(SCM_IM_LETSTAR
):
1379 env
= EXTEND_ENV (SCM_EOL
, SCM_EOL
, env
);
1382 y
= z
= scm_acons (SCM_CAR (b
),
1384 scm_cons (unmemocopy (SCM_CAR (SCM_CDR (b
)), env
), SCM_EOL
), env
),
1386 env
= EXTEND_ENV (SCM_CAR (b
), SCM_BOOL_F
, env
);
1387 b
= SCM_CDR (SCM_CDR (b
));
1390 SCM_SETCDR (y
, SCM_EOL
);
1391 ls
= scm_cons (scm_sym_let
, z
= scm_cons (y
, SCM_UNSPECIFIED
));
1396 SCM_SETCDR (z
, scm_acons (SCM_CAR (b
),
1398 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
));
1404 while (SCM_NIMP (b
));
1405 SCM_SETCDR (z
, SCM_EOL
);
1407 ls
= scm_cons (scm_sym_letstar
, z
= scm_cons (y
, SCM_UNSPECIFIED
));
1410 case SCM_BIT8(SCM_IM_OR
):
1411 ls
= z
= scm_cons (scm_sym_or
, SCM_UNSPECIFIED
);
1413 case SCM_BIT8(SCM_IM_LAMBDA
):
1415 ls
= scm_cons (scm_sym_lambda
,
1416 z
= scm_cons (SCM_CAR (x
), SCM_UNSPECIFIED
));
1417 env
= EXTEND_ENV (SCM_CAR (x
), SCM_EOL
, env
);
1419 case SCM_BIT8(SCM_IM_QUOTE
):
1420 ls
= z
= scm_cons (scm_sym_quote
, SCM_UNSPECIFIED
);
1422 case SCM_BIT8(SCM_IM_SET_X
):
1423 ls
= z
= scm_cons (scm_sym_set_x
, SCM_UNSPECIFIED
);
1425 case SCM_BIT8(SCM_IM_DEFINE
):
1429 ls
= scm_cons (scm_sym_define
,
1430 z
= scm_cons (n
= SCM_CAR (x
), SCM_UNSPECIFIED
));
1431 if (SCM_NNULLP (env
))
1432 SCM_SETCAR (SCM_CAR (env
), scm_cons (n
, SCM_CAR (SCM_CAR (env
))));
1435 case SCM_BIT8(SCM_MAKISYM (0)):
1439 switch (SCM_ISYMNUM (z
))
1441 case (SCM_ISYMNUM (SCM_IM_APPLY
)):
1442 ls
= z
= scm_cons (scm_sym_atapply
, SCM_UNSPECIFIED
);
1444 case (SCM_ISYMNUM (SCM_IM_CONT
)):
1445 ls
= z
= scm_cons (scm_sym_atcall_cc
, SCM_UNSPECIFIED
);
1447 case (SCM_ISYMNUM (SCM_IM_DELAY
)):
1448 ls
= z
= scm_cons (scm_sym_delay
, SCM_UNSPECIFIED
);
1452 /* appease the Sun compiler god: */ ;
1456 ls
= z
= unmemocar (scm_cons (unmemocopy (SCM_CAR (x
), env
),
1461 while (SCM_CELLP (x
= SCM_CDR (x
)) && SCM_ECONSP (x
))
1463 if (SCM_ISYMP (SCM_CAR (x
)))
1464 /* skip body markers */
1466 SCM_SETCDR (z
, unmemocar (scm_cons (unmemocopy (SCM_CAR (x
), env
),
1472 #ifdef DEBUG_EXTENSIONS
1473 if (SCM_NFALSEP (p
))
1474 scm_whash_insert (scm_source_whash
, ls
, p
);
1481 scm_unmemocopy (SCM x
, SCM env
)
1483 if (SCM_NNULLP (env
))
1484 /* Make a copy of the lowest frame to protect it from
1485 modifications by SCM_IM_DEFINE */
1486 return unmemocopy (x
, scm_cons (SCM_CAR (env
), SCM_CDR (env
)));
1488 return unmemocopy (x
, env
);
1491 #ifndef SCM_RECKLESS
1494 scm_badargsp (SCM formals
, SCM args
)
1496 while (SCM_NIMP (formals
))
1498 if (SCM_NCONSP (formals
))
1502 formals
= SCM_CDR (formals
);
1503 args
= SCM_CDR (args
);
1505 return SCM_NNULLP (args
) ? 1 : 0;
1510 scm_badformalsp (SCM closure
, int n
)
1512 SCM formals
= SCM_CAR (SCM_CODE (closure
));
1513 while (SCM_NIMP (formals
))
1515 if (SCM_NCONSP (formals
))
1520 formals
= SCM_CDR (formals
);
1527 scm_eval_args (SCM l
, SCM env
, SCM proc
)
1529 SCM results
= SCM_EOL
, *lloc
= &results
, res
;
1530 while (SCM_NIMP (l
))
1535 if (SCM_IMP (SCM_CAR (l
)))
1536 res
= SCM_EVALIM (SCM_CAR (l
), env
);
1538 res
= EVALCELLCAR (l
, env
);
1540 else if (SCM_TYP3 (l
) == scm_tc3_cons_gloc
)
1542 scm_bits_t vcell
= SCM_STRUCT_VTABLE_DATA (l
) [scm_vtable_index_vcell
];
1544 res
= SCM_CAR (l
); /* struct planted in code */
1546 res
= SCM_PACK (vcell
);
1551 res
= EVALCAR (l
, env
);
1553 *lloc
= scm_cons (res
, SCM_EOL
);
1554 lloc
= SCM_CDRLOC (*lloc
);
1561 scm_wrong_num_args (proc
);
1568 scm_eval_body (SCM code
, SCM env
)
1573 while (SCM_NNULLP (next
= SCM_CDR (next
)))
1575 if (SCM_IMP (SCM_CAR (code
)))
1577 if (SCM_ISYMP (SCM_CAR (code
)))
1579 code
= scm_m_expand_body (code
, env
);
1584 SCM_XEVAL (SCM_CAR (code
), env
);
1587 return SCM_XEVALCAR (code
, env
);
1594 /* SECTION: This code is specific for the debugging support. One
1595 * branch is read when DEVAL isn't defined, the other when DEVAL is
1601 #define SCM_APPLY scm_apply
1602 #define PREP_APPLY(proc, args)
1604 #define RETURN(x) return x;
1605 #ifdef STACK_CHECKING
1606 #ifndef NO_CEVAL_STACK_CHECKING
1607 #define EVAL_STACK_CHECKING
1614 #define SCM_CEVAL scm_deval /* Substitute all uses of scm_ceval */
1616 #define SCM_APPLY scm_dapply
1618 #define PREP_APPLY(p, l) \
1619 { ++debug.info; debug.info->a.proc = p; debug.info->a.args = l; }
1621 #define ENTER_APPLY \
1623 SCM_SET_ARGSREADY (debug);\
1624 if (CHECK_APPLY && SCM_TRAPS_P)\
1625 if (SCM_APPLY_FRAME_P || (SCM_TRACE_P && PROCTRACEP (proc)))\
1627 SCM tmp, tail = SCM_BOOL(SCM_TRACED_FRAME_P (debug)); \
1628 SCM_SET_TRACED_FRAME (debug); \
1629 if (SCM_CHEAPTRAPS_P)\
1631 tmp = scm_make_debugobj (&debug);\
1632 scm_ithrow (scm_sym_apply_frame, scm_cons2 (tmp, tail, SCM_EOL), 0);\
1636 scm_make_cont (&tmp);\
1637 if (!setjmp (SCM_JMPBUF (tmp)))\
1638 scm_ithrow (scm_sym_apply_frame, scm_cons2 (tmp, tail, SCM_EOL), 0);\
1643 #define RETURN(e) {proc = (e); goto exit;}
1644 #ifdef STACK_CHECKING
1645 #ifndef EVAL_STACK_CHECKING
1646 #define EVAL_STACK_CHECKING
1650 /* scm_ceval_ptr points to the currently selected evaluator.
1651 * *fixme*: Although efficiency is important here, this state variable
1652 * should probably not be a global. It should be related to the
1657 SCM (*scm_ceval_ptr
) (SCM x
, SCM env
);
1659 /* scm_last_debug_frame contains a pointer to the last debugging
1660 * information stack frame. It is accessed very often from the
1661 * debugging evaluator, so it should probably not be indirectly
1662 * addressed. Better to save and restore it from the current root at
1667 scm_debug_frame
*scm_last_debug_frame
;
1670 /* scm_debug_eframe_size is the number of slots available for pseudo
1671 * stack frames at each real stack frame.
1674 int scm_debug_eframe_size
;
1676 int scm_debug_mode
, scm_check_entry_p
, scm_check_apply_p
, scm_check_exit_p
;
1680 scm_option scm_eval_opts
[] = {
1681 { SCM_OPTION_INTEGER
, "stack", 22000, "Size of thread stacks (in machine words)." }
1684 scm_option scm_debug_opts
[] = {
1685 { SCM_OPTION_BOOLEAN
, "cheap", 1,
1686 "*Flyweight representation of the stack at traps." },
1687 { SCM_OPTION_BOOLEAN
, "breakpoints", 0, "*Check for breakpoints." },
1688 { SCM_OPTION_BOOLEAN
, "trace", 0, "*Trace mode." },
1689 { SCM_OPTION_BOOLEAN
, "procnames", 1,
1690 "Record procedure names at definition." },
1691 { SCM_OPTION_BOOLEAN
, "backwards", 0,
1692 "Display backtrace in anti-chronological order." },
1693 { SCM_OPTION_INTEGER
, "width", 79, "Maximal width of backtrace." },
1694 { SCM_OPTION_INTEGER
, "indent", 10, "Maximal indentation in backtrace." },
1695 { SCM_OPTION_INTEGER
, "frames", 3,
1696 "Maximum number of tail-recursive frames in backtrace." },
1697 { SCM_OPTION_INTEGER
, "maxdepth", 1000,
1698 "Maximal number of stored backtrace frames." },
1699 { SCM_OPTION_INTEGER
, "depth", 20, "Maximal length of printed backtrace." },
1700 { SCM_OPTION_BOOLEAN
, "backtrace", 0, "Show backtrace on error." },
1701 { SCM_OPTION_BOOLEAN
, "debug", 0, "Use the debugging evaluator." },
1702 { SCM_OPTION_INTEGER
, "stack", 20000, "Stack size limit (measured in words; 0 = no check)." }
1705 scm_option scm_evaluator_trap_table
[] = {
1706 { SCM_OPTION_BOOLEAN
, "traps", 0, "Enable evaluator traps." },
1707 { SCM_OPTION_BOOLEAN
, "enter-frame", 0, "Trap when eval enters new frame." },
1708 { SCM_OPTION_BOOLEAN
, "apply-frame", 0, "Trap when entering apply." },
1709 { SCM_OPTION_BOOLEAN
, "exit-frame", 0, "Trap when exiting eval or apply." }
1712 SCM_DEFINE (scm_eval_options_interface
, "eval-options-interface", 0, 1, 0,
1715 #define FUNC_NAME s_scm_eval_options_interface
1719 ans
= scm_options (setting
,
1723 scm_eval_stack
= SCM_EVAL_STACK
* sizeof (void *);
1729 SCM_DEFINE (scm_evaluator_traps
, "evaluator-traps-interface", 0, 1, 0,
1732 #define FUNC_NAME s_scm_evaluator_traps
1736 ans
= scm_options (setting
,
1737 scm_evaluator_trap_table
,
1738 SCM_N_EVALUATOR_TRAPS
,
1740 SCM_RESET_DEBUG_MODE
;
1747 scm_deval_args (SCM l
, SCM env
, SCM proc
, SCM
*lloc
)
1749 SCM
*results
= lloc
, res
;
1750 while (SCM_NIMP (l
))
1755 if (SCM_IMP (SCM_CAR (l
)))
1756 res
= SCM_EVALIM (SCM_CAR (l
), env
);
1758 res
= EVALCELLCAR (l
, env
);
1760 else if (SCM_TYP3 (l
) == scm_tc3_cons_gloc
)
1762 scm_bits_t vcell
= SCM_STRUCT_VTABLE_DATA (l
) [scm_vtable_index_vcell
];
1764 res
= SCM_CAR (l
); /* struct planted in code */
1766 res
= SCM_PACK (vcell
);
1771 res
= EVALCAR (l
, env
);
1773 *lloc
= scm_cons (res
, SCM_EOL
);
1774 lloc
= SCM_CDRLOC (*lloc
);
1781 scm_wrong_num_args (proc
);
1790 /* SECTION: Some local definitions for the evaluator.
1794 #define CHECK_EQVISH(A,B) (SCM_EQ_P ((A), (B)) || (SCM_NFALSEP (scm_eqv_p ((A), (B)))))
1797 #define BUILTIN_RPASUBR /* Handle rpsubrs and asubrs without calling apply */
1799 /* SECTION: This is the evaluator. Like any real monster, it has
1800 * three heads. This code is compiled twice.
1806 scm_ceval (SCM x
, SCM env
)
1812 scm_deval (SCM x
, SCM env
)
1817 SCM_CEVAL (SCM x
, SCM env
)
1826 scm_debug_frame debug
;
1827 scm_debug_info
*debug_info_end
;
1828 debug
.prev
= scm_last_debug_frame
;
1829 debug
.status
= scm_debug_eframe_size
;
1831 * The debug.vect contains twice as much scm_debug_info frames as the
1832 * user has specified with (debug-set! frames <n>).
1834 * Even frames are eval frames, odd frames are apply frames.
1836 debug
.vect
= (scm_debug_info
*) alloca (scm_debug_eframe_size
1837 * sizeof (debug
.vect
[0]));
1838 debug
.info
= debug
.vect
;
1839 debug_info_end
= debug
.vect
+ scm_debug_eframe_size
;
1840 scm_last_debug_frame
= &debug
;
1842 #ifdef EVAL_STACK_CHECKING
1843 if (scm_stack_checking_enabled_p
1844 && SCM_STACK_OVERFLOW_P ((SCM_STACKITEM
*) &proc
))
1847 debug
.info
->e
.exp
= x
;
1848 debug
.info
->e
.env
= env
;
1850 scm_report_stack_overflow ();
1857 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
1860 SCM_CLEAR_ARGSREADY (debug
);
1861 if (SCM_OVERFLOWP (debug
))
1864 * In theory, this should be the only place where it is necessary to
1865 * check for space in debug.vect since both eval frames and
1866 * available space are even.
1868 * For this to be the case, however, it is necessary that primitive
1869 * special forms which jump back to `loop', `begin' or some similar
1870 * label call PREP_APPLY. A convenient way to do this is to jump to
1871 * `loopnoap' or `cdrxnoap'.
1873 else if (++debug
.info
>= debug_info_end
)
1875 SCM_SET_OVERFLOW (debug
);
1879 debug
.info
->e
.exp
= x
;
1880 debug
.info
->e
.env
= env
;
1881 if (CHECK_ENTRY
&& SCM_TRAPS_P
)
1882 if (SCM_ENTER_FRAME_P
|| (SCM_BREAKPOINTS_P
&& SRCBRKP (x
)))
1884 SCM tail
= SCM_BOOL(SCM_TAILRECP (debug
));
1885 SCM_SET_TAILREC (debug
);
1886 if (SCM_CHEAPTRAPS_P
)
1887 t
.arg1
= scm_make_debugobj (&debug
);
1890 scm_make_cont (&t
.arg1
);
1891 if (setjmp (SCM_JMPBUF (t
.arg1
)))
1893 x
= SCM_THROW_VALUE (t
.arg1
);
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_tcs_symbols
:
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
):
1937 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
1943 while (SCM_NNULLP (t
.arg1
= SCM_CDR (t
.arg1
)))
1945 if (SCM_IMP (SCM_CAR (x
)))
1947 if (SCM_ISYMP (SCM_CAR (x
)))
1949 x
= scm_m_expand_body (x
, env
);
1954 SCM_CEVAL (SCM_CAR (x
), env
);
1958 carloop
: /* scm_eval car of last form in list */
1959 if (SCM_NCELLP (SCM_CAR (x
)))
1962 RETURN (SCM_IMP (x
) ? SCM_EVALIM (x
, env
) : SCM_GLOC_VAL (x
))
1965 if (SCM_SYMBOLP (SCM_CAR (x
)))
1968 RETURN (*scm_lookupcar (x
, env
, 1))
1972 goto loop
; /* tail recurse */
1975 case SCM_BIT8(SCM_IM_CASE
):
1977 t
.arg1
= EVALCAR (x
, env
);
1978 while (SCM_NIMP (x
= SCM_CDR (x
)))
1981 if (SCM_EQ_P (scm_sym_else
, SCM_CAR (proc
)))
1984 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
1987 proc
= SCM_CAR (proc
);
1988 while (SCM_NIMP (proc
))
1990 if (CHECK_EQVISH (SCM_CAR (proc
), t
.arg1
))
1992 x
= SCM_CDR (SCM_CAR (x
));
1993 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
1996 proc
= SCM_CDR (proc
);
1999 RETURN (SCM_UNSPECIFIED
)
2002 case SCM_BIT8(SCM_IM_COND
):
2003 while (SCM_NIMP (x
= SCM_CDR (x
)))
2006 t
.arg1
= EVALCAR (proc
, env
);
2007 if (SCM_NFALSEP (t
.arg1
))
2014 if (! SCM_EQ_P (scm_sym_arrow
, SCM_CAR (x
)))
2016 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
2020 proc
= EVALCAR (proc
, env
);
2021 SCM_ASRTGO (SCM_NIMP (proc
), badfun
);
2022 PREP_APPLY (proc
, scm_cons (t
.arg1
, SCM_EOL
));
2027 RETURN (SCM_UNSPECIFIED
)
2030 case SCM_BIT8(SCM_IM_DO
):
2032 proc
= SCM_CAR (SCM_CDR (x
)); /* inits */
2033 t
.arg1
= SCM_EOL
; /* values */
2034 while (SCM_NIMP (proc
))
2036 t
.arg1
= scm_cons (EVALCAR (proc
, env
), t
.arg1
);
2037 proc
= SCM_CDR (proc
);
2039 env
= EXTEND_ENV (SCM_CAR (x
), t
.arg1
, env
);
2040 x
= SCM_CDR (SCM_CDR (x
));
2041 while (proc
= SCM_CAR (x
), SCM_FALSEP (EVALCAR (proc
, env
)))
2043 for (proc
= SCM_CADR (x
); SCM_NIMP (proc
); proc
= SCM_CDR (proc
))
2045 t
.arg1
= SCM_CAR (proc
); /* body */
2046 SIDEVAL (t
.arg1
, env
);
2048 for (t
.arg1
= SCM_EOL
, proc
= SCM_CDDR (x
);
2050 proc
= SCM_CDR (proc
))
2051 t
.arg1
= scm_cons (EVALCAR (proc
, env
), t
.arg1
); /* steps */
2052 env
= EXTEND_ENV (SCM_CAR (SCM_CAR (env
)), t
.arg1
, SCM_CDR (env
));
2056 RETURN (SCM_UNSPECIFIED
);
2057 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
2061 case SCM_BIT8(SCM_IM_IF
):
2063 if (SCM_NFALSEP (EVALCAR (x
, env
)))
2065 else if (SCM_IMP (x
= SCM_CDR (SCM_CDR (x
))))
2067 RETURN (SCM_UNSPECIFIED
);
2069 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
2073 case SCM_BIT8(SCM_IM_LET
):
2075 proc
= SCM_CAR (SCM_CDR (x
));
2079 t
.arg1
= scm_cons (EVALCAR (proc
, env
), t
.arg1
);
2081 while (SCM_NIMP (proc
= SCM_CDR (proc
)));
2082 env
= EXTEND_ENV (SCM_CAR (x
), t
.arg1
, env
);
2087 case SCM_BIT8(SCM_IM_LETREC
):
2089 env
= EXTEND_ENV (SCM_CAR (x
), scm_undefineds
, env
);
2095 t
.arg1
= scm_cons (EVALCAR (proc
, env
), t
.arg1
);
2097 while (SCM_NIMP (proc
= SCM_CDR (proc
)));
2098 SCM_SETCDR (SCM_CAR (env
), t
.arg1
);
2102 case SCM_BIT8(SCM_IM_LETSTAR
):
2107 env
= EXTEND_ENV (SCM_EOL
, SCM_EOL
, env
);
2112 t
.arg1
= SCM_CAR (proc
);
2113 proc
= SCM_CDR (proc
);
2114 env
= EXTEND_ENV (t
.arg1
, EVALCAR (proc
, env
), env
);
2116 while (SCM_NIMP (proc
= SCM_CDR (proc
)));
2119 case SCM_BIT8(SCM_IM_OR
):
2122 while (SCM_NNULLP (t
.arg1
= SCM_CDR (t
.arg1
)))
2124 x
= EVALCAR (x
, env
);
2125 if (SCM_NFALSEP (x
))
2131 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
2135 case SCM_BIT8(SCM_IM_LAMBDA
):
2136 RETURN (scm_closure (SCM_CDR (x
), env
));
2139 case SCM_BIT8(SCM_IM_QUOTE
):
2140 RETURN (SCM_CAR (SCM_CDR (x
)));
2143 case SCM_BIT8(SCM_IM_SET_X
):
2146 switch (SCM_ITAG3 (proc
))
2149 t
.lloc
= scm_lookupcar (x
, env
, 1);
2151 case scm_tc3_cons_gloc
:
2152 t
.lloc
= SCM_GLOC_VAL_LOC (proc
);
2154 #ifdef MEMOIZE_LOCALS
2156 t
.lloc
= scm_ilookup (proc
, env
);
2161 *t
.lloc
= EVALCAR (x
, env
);
2165 RETURN (SCM_UNSPECIFIED
);
2169 case SCM_BIT8(SCM_IM_DEFINE
): /* only for internal defines */
2170 scm_misc_error (NULL
, "Bad define placement", SCM_EOL
);
2172 /* new syntactic forms go here. */
2173 case SCM_BIT8(SCM_MAKISYM (0)):
2175 SCM_ASRTGO (SCM_ISYMP (proc
), badfun
);
2176 switch SCM_ISYMNUM (proc
)
2179 case (SCM_ISYMNUM (IM_VREF
)):
2182 var
= SCM_CAR (SCM_CDR (x
));
2183 RETURN (SCM_CDR(var
));
2185 case (SCM_ISYMNUM (IM_VSET
)):
2186 SCM_CDR (SCM_CAR ( SCM_CDR (x
))) = EVALCAR( SCM_CDR ( SCM_CDR (x
)), env
);
2187 SCM_CAR (SCM_CAR ( SCM_CDR (x
))) = scm_tc16_variable
;
2188 RETURN (SCM_UNSPECIFIED
)
2191 case (SCM_ISYMNUM (SCM_IM_APPLY
)):
2193 proc
= EVALCAR (proc
, env
);
2194 SCM_ASRTGO (SCM_NIMP (proc
), badfun
);
2195 if (SCM_CLOSUREP (proc
))
2198 PREP_APPLY (proc
, SCM_EOL
);
2199 t
.arg1
= SCM_CDR (SCM_CDR (x
));
2200 t
.arg1
= EVALCAR (t
.arg1
, env
);
2202 debug
.info
->a
.args
= t
.arg1
;
2204 #ifndef SCM_RECKLESS
2205 if (scm_badargsp (SCM_CAR (SCM_CODE (proc
)), t
.arg1
))
2209 /* Copy argument list */
2210 if (SCM_IMP (t
.arg1
))
2214 argl
= tl
= scm_cons (SCM_CAR (t
.arg1
), SCM_UNSPECIFIED
);
2215 while (SCM_NIMP (t
.arg1
= SCM_CDR (t
.arg1
))
2216 && SCM_CONSP (t
.arg1
))
2218 SCM_SETCDR (tl
, scm_cons (SCM_CAR (t
.arg1
),
2222 SCM_SETCDR (tl
, t
.arg1
);
2225 env
= EXTEND_ENV (SCM_CAR (SCM_CODE (proc
)), argl
, SCM_ENV (proc
));
2226 x
= SCM_CODE (proc
);
2232 case (SCM_ISYMNUM (SCM_IM_CONT
)):
2233 scm_make_cont (&t
.arg1
);
2234 if (setjmp (SCM_JMPBUF (t
.arg1
)))
2237 val
= SCM_THROW_VALUE (t
.arg1
);
2241 proc
= evalcar (proc
, env
);
2242 SCM_ASRTGO (SCM_NIMP (proc
), badfun
);
2243 PREP_APPLY (proc
, scm_cons (t
.arg1
, SCM_EOL
));
2247 case (SCM_ISYMNUM (SCM_IM_DELAY
)):
2248 RETURN (scm_makprom (scm_closure (SCM_CDR (x
), env
)))
2250 case (SCM_ISYMNUM (SCM_IM_DISPATCH
)):
2251 proc
= SCM_CADR (x
); /* unevaluated operands */
2252 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
2254 arg2
= *scm_ilookup (proc
, env
);
2255 else if (SCM_NCONSP (proc
))
2257 if (SCM_NCELLP (proc
))
2258 arg2
= SCM_GLOC_VAL (proc
);
2260 arg2
= *scm_lookupcar (SCM_CDR (x
), env
, 1);
2264 arg2
= scm_cons (EVALCAR (proc
, env
), SCM_EOL
);
2265 t
.lloc
= SCM_CDRLOC (arg2
);
2266 while (SCM_NIMP (proc
= SCM_CDR (proc
)))
2268 *t
.lloc
= scm_cons (EVALCAR (proc
, env
), SCM_EOL
);
2269 t
.lloc
= SCM_CDRLOC (*t
.lloc
);
2274 /* The type dispatch code is duplicated here
2275 * (c.f. objects.c:scm_mcache_compute_cmethod) since that
2276 * cuts down execution time for type dispatch to 50%.
2279 int i
, n
, end
, mask
;
2280 SCM z
= SCM_CDDR (x
);
2281 n
= SCM_INUM (SCM_CAR (z
)); /* maximum number of specializers */
2282 proc
= SCM_CADR (z
);
2284 if (SCM_NIMP (proc
))
2286 /* Prepare for linear search */
2289 end
= SCM_LENGTH (proc
);
2293 /* Compute a hash value */
2294 int hashset
= SCM_INUM (proc
);
2296 mask
= SCM_INUM (SCM_CAR (z
= SCM_CDDR (z
)));
2297 proc
= SCM_CADR (z
);
2300 if (SCM_NIMP (t
.arg1
))
2303 i
+= SCM_STRUCT_DATA (scm_class_of (SCM_CAR (t
.arg1
)))
2304 [scm_si_hashsets
+ hashset
];
2305 t
.arg1
= SCM_CDR (t
.arg1
);
2307 while (--j
&& SCM_NIMP (t
.arg1
));
2312 /* Search for match */
2316 z
= SCM_VELTS (proc
)[i
];
2317 t
.arg1
= arg2
; /* list of arguments */
2318 if (SCM_NIMP (t
.arg1
))
2321 /* More arguments than specifiers => CLASS != ENV */
2322 if (! SCM_EQ_P (scm_class_of (SCM_CAR (t
.arg1
)), SCM_CAR (z
)))
2324 t
.arg1
= SCM_CDR (t
.arg1
);
2327 while (--j
&& SCM_NIMP (t
.arg1
));
2328 /* Fewer arguments than specifiers => CAR != ENV */
2329 if (!(SCM_IMP (SCM_CAR (z
)) || SCM_CONSP (SCM_CAR (z
))))
2332 env
= EXTEND_ENV (SCM_CAR (SCM_CMETHOD_CODE (z
)),
2334 SCM_CMETHOD_ENV (z
));
2335 x
= SCM_CMETHOD_CODE (z
);
2341 z
= scm_memoize_method (x
, arg2
);
2345 case (SCM_ISYMNUM (SCM_IM_SLOT_REF
)):
2347 t
.arg1
= EVALCAR (x
, env
);
2348 RETURN (SCM_PACK (SCM_STRUCT_DATA (t
.arg1
) [SCM_INUM (SCM_CADR (x
))]))
2350 case (SCM_ISYMNUM (SCM_IM_SLOT_SET_X
)):
2352 t
.arg1
= EVALCAR (x
, env
);
2355 SCM_STRUCT_DATA (t
.arg1
) [SCM_INUM (SCM_CAR (x
))]
2356 = SCM_UNPACK (EVALCAR (proc
, env
));
2357 RETURN (SCM_UNSPECIFIED
)
2359 case (SCM_ISYMNUM (SCM_IM_NIL_COND
)):
2361 while (SCM_NIMP (x
= SCM_CDR (proc
)))
2363 if (!(SCM_FALSEP (t
.arg1
= EVALCAR (proc
, env
))
2364 || SCM_EQ_P (t
.arg1
, scm_lisp_nil
)))
2366 if (SCM_EQ_P (SCM_CAR (x
), SCM_UNSPECIFIED
))
2368 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
2374 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
2377 case (SCM_ISYMNUM (SCM_IM_NIL_IFY
)):
2379 RETURN ((SCM_FALSEP (proc
= EVALCAR (x
, env
)) || SCM_NULLP (proc
))
2383 case (SCM_ISYMNUM (SCM_IM_T_IFY
)):
2385 RETURN (SCM_NFALSEP (EVALCAR (x
, env
)) ? scm_lisp_t
: scm_lisp_nil
)
2387 case (SCM_ISYMNUM (SCM_IM_0_COND
)):
2389 while (SCM_NIMP (x
= SCM_CDR (proc
)))
2391 if (!(SCM_FALSEP (t
.arg1
= EVALCAR (proc
, env
))
2392 || SCM_EQ_P (t
.arg1
, SCM_INUM0
)))
2394 if (SCM_EQ_P (SCM_CAR (x
), SCM_UNSPECIFIED
))
2396 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
2402 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
2405 case (SCM_ISYMNUM (SCM_IM_0_IFY
)):
2407 RETURN (SCM_FALSEP (proc
= EVALCAR (x
, env
))
2411 case (SCM_ISYMNUM (SCM_IM_1_IFY
)):
2413 RETURN (SCM_NFALSEP (EVALCAR (x
, env
))
2417 case (SCM_ISYMNUM (SCM_IM_BIND
)):
2420 t
.arg1
= SCM_CAR (x
);
2421 arg2
= SCM_CDAR (env
);
2422 while (SCM_NIMP (arg2
))
2424 proc
= SCM_GLOC_VAL (SCM_CAR (t
.arg1
));
2425 SCM_SETCDR (SCM_PACK (SCM_UNPACK (SCM_CAR (t
.arg1
)) - 1L),
2427 SCM_SETCAR (arg2
, proc
);
2428 t
.arg1
= SCM_CDR (t
.arg1
);
2429 arg2
= SCM_CDR (arg2
);
2431 t
.arg1
= SCM_CAR (x
);
2432 scm_dynwinds
= scm_acons (t
.arg1
, SCM_CDAR (env
), scm_dynwinds
);
2434 arg2
= x
= SCM_CDR (x
);
2435 while (SCM_NNULLP (arg2
= SCM_CDR (arg2
)))
2437 SIDEVAL (SCM_CAR (x
), env
);
2440 proc
= EVALCAR (x
, env
);
2442 scm_dynwinds
= SCM_CDR (scm_dynwinds
);
2443 arg2
= SCM_CDAR (env
);
2444 while (SCM_NIMP (arg2
))
2446 SCM_SETCDR (SCM_PACK (SCM_UNPACK (SCM_CAR (t
.arg1
)) - 1L),
2448 t
.arg1
= SCM_CDR (t
.arg1
);
2449 arg2
= SCM_CDR (arg2
);
2461 /* scm_everr (x, env,...) */
2462 scm_misc_error (NULL
,
2463 "Wrong type to apply: ~S",
2464 scm_listify (proc
, SCM_UNDEFINED
));
2465 case scm_tc7_vector
:
2469 case scm_tc7_byvect
:
2476 #ifdef HAVE_LONG_LONGS
2477 case scm_tc7_llvect
:
2480 case scm_tc7_string
:
2481 case scm_tc7_substring
:
2483 case scm_tcs_closures
:
2491 #ifdef MEMOIZE_LOCALS
2492 case SCM_BIT8(SCM_ILOC00
):
2493 proc
= *scm_ilookup (SCM_CAR (x
), env
);
2494 SCM_ASRTGO (SCM_NIMP (proc
), badfun
);
2495 #ifndef SCM_RECKLESS
2501 #endif /* ifdef MEMOIZE_LOCALS */
2504 case scm_tcs_cons_gloc
: {
2505 scm_bits_t vcell
= SCM_STRUCT_VTABLE_DATA (x
) [scm_vtable_index_vcell
];
2507 /* This is a struct implanted in the code, not a gloc. */
2510 proc
= SCM_PACK (vcell
);
2511 SCM_ASRTGO (SCM_NIMP (proc
), badfun
);
2512 #ifndef SCM_RECKLESS
2521 case scm_tcs_cons_nimcar
:
2522 if (SCM_SYMBOLP (SCM_CAR (x
)))
2525 t
.lloc
= scm_lookupcar1 (x
, env
, 1);
2528 /* we have lost the race, start again. */
2533 proc
= *scm_lookupcar (x
, env
, 1);
2541 if (scm_tc16_macro
== SCM_TYP16 (proc
))
2547 /* Set a flag during macro expansion so that macro
2548 application frames can be deleted from the backtrace. */
2549 SCM_SET_MACROEXP (debug
);
2551 t
.arg1
= SCM_APPLY (SCM_CDR (proc
), x
,
2552 scm_cons (env
, scm_listofnull
));
2555 SCM_CLEAR_MACROEXP (debug
);
2557 switch (SCM_CELL_WORD_0 (proc
) >> 16)
2560 if (scm_ilength (t
.arg1
) <= 0)
2561 t
.arg1
= scm_cons2 (SCM_IM_BEGIN
, t
.arg1
, SCM_EOL
);
2563 if (!SCM_CLOSUREP (SCM_CDR (proc
)))
2566 #if 0 /* Top-level defines doesn't very often occur in backtraces */
2567 if (scm_m_define
== SCM_SUBRF (SCM_CDR (proc
)) && SCM_TOP_LEVEL (env
))
2568 /* Prevent memoizing result of define macro */
2570 debug
.info
->e
.exp
= scm_cons (SCM_CAR (x
), SCM_CDR (x
));
2571 scm_set_source_properties_x (debug
.info
->e
.exp
,
2572 scm_source_properties (x
));
2576 SCM_SETCAR (x
, SCM_CAR (t
.arg1
));
2577 SCM_SETCDR (x
, SCM_CDR (t
.arg1
));
2581 /* Prevent memoizing of debug info expression. */
2582 debug
.info
->e
.exp
= scm_cons_source (debug
.info
->e
.exp
,
2587 SCM_SETCAR (x
, SCM_CAR (t
.arg1
));
2588 SCM_SETCDR (x
, SCM_CDR (t
.arg1
));
2592 if (SCM_NIMP (x
= t
.arg1
))
2600 proc
= SCM_CEVAL (SCM_CAR (x
), env
);
2601 SCM_ASRTGO (SCM_NIMP (proc
), badfun
);
2602 #ifndef SCM_RECKLESS
2606 if (SCM_CLOSUREP (proc
))
2608 arg2
= SCM_CAR (SCM_CODE (proc
));
2609 t
.arg1
= SCM_CDR (x
);
2610 while (SCM_NIMP (arg2
))
2612 if (SCM_NCONSP (arg2
))
2614 if (SCM_IMP (t
.arg1
))
2615 goto umwrongnumargs
;
2616 arg2
= SCM_CDR (arg2
);
2617 t
.arg1
= SCM_CDR (t
.arg1
);
2619 if (SCM_NNULLP (t
.arg1
))
2620 goto umwrongnumargs
;
2622 else if (scm_tc16_macro
== SCM_TYP16 (proc
))
2623 goto handle_a_macro
;
2629 PREP_APPLY (proc
, SCM_EOL
);
2630 if (SCM_NULLP (SCM_CDR (x
))) {
2633 switch (SCM_TYP7 (proc
))
2634 { /* no arguments given */
2635 case scm_tc7_subr_0
:
2636 RETURN (SCM_SUBRF (proc
) ());
2637 case scm_tc7_subr_1o
:
2638 RETURN (SCM_SUBRF (proc
) (SCM_UNDEFINED
));
2640 RETURN (SCM_SUBRF (proc
) (SCM_EOL
));
2641 case scm_tc7_rpsubr
:
2642 RETURN (SCM_BOOL_T
);
2644 RETURN (SCM_SUBRF (proc
) (SCM_UNDEFINED
, SCM_UNDEFINED
));
2648 proc
= SCM_CCLO_SUBR (proc
);
2650 debug
.info
->a
.proc
= proc
;
2651 debug
.info
->a
.args
= scm_cons (t
.arg1
, SCM_EOL
);
2656 proc
= SCM_PROCEDURE (proc
);
2658 debug
.info
->a
.proc
= proc
;
2660 if (!SCM_CLOSUREP (proc
))
2662 if (scm_badformalsp (proc
, 0))
2663 goto umwrongnumargs
;
2664 case scm_tcs_closures
:
2665 x
= SCM_CODE (proc
);
2666 env
= EXTEND_ENV (SCM_CAR (x
), SCM_EOL
, SCM_ENV (proc
));
2668 case scm_tcs_cons_gloc
:
2669 if (SCM_OBJ_CLASS_FLAGS (proc
) & SCM_CLASSF_PURE_GENERIC
)
2671 x
= SCM_ENTITY_PROCEDURE (proc
);
2675 else if (!SCM_I_OPERATORP (proc
))
2680 proc
= (SCM_I_ENTITYP (proc
)
2681 ? SCM_ENTITY_PROCEDURE (proc
)
2682 : SCM_OPERATOR_PROCEDURE (proc
));
2684 debug
.info
->a
.proc
= proc
;
2685 debug
.info
->a
.args
= scm_cons (t
.arg1
, SCM_EOL
);
2687 if (SCM_NIMP (proc
))
2692 case scm_tc7_contin
:
2693 case scm_tc7_subr_1
:
2694 case scm_tc7_subr_2
:
2695 case scm_tc7_subr_2o
:
2697 case scm_tc7_subr_3
:
2698 case scm_tc7_lsubr_2
:
2702 /* scm_everr (x, env,...) */
2703 scm_wrong_num_args (proc
);
2705 /* handle macros here */
2710 /* must handle macros by here */
2715 else if (SCM_CONSP (x
))
2717 if (SCM_IMP (SCM_CAR (x
)))
2718 t
.arg1
= SCM_EVALIM (SCM_CAR (x
), env
);
2720 t
.arg1
= EVALCELLCAR (x
, env
);
2722 else if (SCM_TYP3 (x
) == scm_tc3_cons_gloc
)
2724 scm_bits_t vcell
= SCM_STRUCT_VTABLE_DATA (x
) [scm_vtable_index_vcell
];
2726 t
.arg1
= SCM_CAR (x
); /* struct planted in code */
2728 t
.arg1
= SCM_PACK (vcell
);
2733 t
.arg1
= EVALCAR (x
, env
);
2736 debug
.info
->a
.args
= scm_cons (t
.arg1
, SCM_EOL
);
2743 switch (SCM_TYP7 (proc
))
2744 { /* have one argument in t.arg1 */
2745 case scm_tc7_subr_2o
:
2746 RETURN (SCM_SUBRF (proc
) (t
.arg1
, SCM_UNDEFINED
));
2747 case scm_tc7_subr_1
:
2748 case scm_tc7_subr_1o
:
2749 RETURN (SCM_SUBRF (proc
) (t
.arg1
));
2751 if (SCM_SUBRF (proc
))
2753 if (SCM_INUMP (t
.arg1
))
2755 RETURN (scm_make_real (SCM_DSUBRF (proc
) ((double) SCM_INUM (t
.arg1
))));
2757 SCM_ASRTGO (SCM_NIMP (t
.arg1
), floerr
);
2758 if (SCM_REALP (t
.arg1
))
2760 RETURN (scm_make_real (SCM_DSUBRF (proc
) (SCM_REAL_VALUE (t
.arg1
))));
2763 if (SCM_BIGP (t
.arg1
))
2765 RETURN (scm_make_real (SCM_DSUBRF (proc
) (scm_big2dbl (t
.arg1
))));
2769 SCM_WTA_DISPATCH_1 (*SCM_SUBR_GENERIC (proc
), t
.arg1
,
2770 SCM_ARG1
, SCM_CHARS (SCM_SNAME (proc
)));
2772 proc
= SCM_SNAME (proc
);
2774 char *chrs
= SCM_CHARS (proc
) + SCM_LENGTH (proc
) - 1;
2775 while ('c' != *--chrs
)
2777 SCM_ASSERT (SCM_CONSP (t
.arg1
),
2778 t
.arg1
, SCM_ARG1
, SCM_CHARS (proc
));
2779 t
.arg1
= ('a' == *chrs
) ? SCM_CAR (t
.arg1
) : SCM_CDR (t
.arg1
);
2783 case scm_tc7_rpsubr
:
2784 RETURN (SCM_BOOL_T
);
2786 RETURN (SCM_SUBRF (proc
) (t
.arg1
, SCM_UNDEFINED
));
2789 RETURN (SCM_SUBRF (proc
) (debug
.info
->a
.args
))
2791 RETURN (SCM_SUBRF (proc
) (scm_cons (t
.arg1
, SCM_EOL
)));
2797 proc
= SCM_CCLO_SUBR (proc
);
2799 debug
.info
->a
.args
= scm_cons (t
.arg1
, debug
.info
->a
.args
);
2800 debug
.info
->a
.proc
= proc
;
2805 proc
= SCM_PROCEDURE (proc
);
2807 debug
.info
->a
.proc
= proc
;
2809 if (!SCM_CLOSUREP (proc
))
2811 if (scm_badformalsp (proc
, 1))
2812 goto umwrongnumargs
;
2813 case scm_tcs_closures
:
2815 x
= SCM_CODE (proc
);
2817 env
= EXTEND_ENV (SCM_CAR (x
), debug
.info
->a
.args
, SCM_ENV (proc
));
2819 env
= EXTEND_ENV (SCM_CAR (x
), scm_cons (t
.arg1
, SCM_EOL
), SCM_ENV (proc
));
2822 case scm_tc7_contin
:
2823 scm_call_continuation (proc
, t
.arg1
);
2824 case scm_tcs_cons_gloc
:
2825 if (SCM_OBJ_CLASS_FLAGS (proc
) & SCM_CLASSF_PURE_GENERIC
)
2827 x
= SCM_ENTITY_PROCEDURE (proc
);
2829 arg2
= debug
.info
->a
.args
;
2831 arg2
= scm_cons (t
.arg1
, SCM_EOL
);
2835 else if (!SCM_I_OPERATORP (proc
))
2841 proc
= (SCM_I_ENTITYP (proc
)
2842 ? SCM_ENTITY_PROCEDURE (proc
)
2843 : SCM_OPERATOR_PROCEDURE (proc
));
2845 debug
.info
->a
.args
= scm_cons (t
.arg1
, debug
.info
->a
.args
);
2846 debug
.info
->a
.proc
= proc
;
2848 if (SCM_NIMP (proc
))
2853 case scm_tc7_subr_2
:
2854 case scm_tc7_subr_0
:
2855 case scm_tc7_subr_3
:
2856 case scm_tc7_lsubr_2
:
2865 else if (SCM_CONSP (x
))
2867 if (SCM_IMP (SCM_CAR (x
)))
2868 arg2
= SCM_EVALIM (SCM_CAR (x
), env
);
2870 arg2
= EVALCELLCAR (x
, env
);
2872 else if (SCM_TYP3 (x
) == scm_tc3_cons_gloc
)
2874 scm_bits_t vcell
= SCM_STRUCT_VTABLE_DATA (x
) [scm_vtable_index_vcell
];
2876 arg2
= SCM_CAR (x
); /* struct planted in code */
2878 arg2
= SCM_PACK (vcell
);
2883 arg2
= EVALCAR (x
, env
);
2885 { /* have two or more arguments */
2887 debug
.info
->a
.args
= scm_cons2 (t
.arg1
, arg2
, SCM_EOL
);
2890 if (SCM_NULLP (x
)) {
2895 switch (SCM_TYP7 (proc
))
2896 { /* have two arguments */
2897 case scm_tc7_subr_2
:
2898 case scm_tc7_subr_2o
:
2899 RETURN (SCM_SUBRF (proc
) (t
.arg1
, arg2
));
2902 RETURN (SCM_SUBRF (proc
) (debug
.info
->a
.args
))
2904 RETURN (SCM_SUBRF (proc
) (scm_cons2 (t
.arg1
, arg2
, SCM_EOL
)));
2906 case scm_tc7_lsubr_2
:
2907 RETURN (SCM_SUBRF (proc
) (t
.arg1
, arg2
, SCM_EOL
));
2908 case scm_tc7_rpsubr
:
2910 RETURN (SCM_SUBRF (proc
) (t
.arg1
, arg2
));
2915 RETURN (SCM_APPLY (SCM_CCLO_SUBR (proc
),
2916 scm_cons (proc
, debug
.info
->a
.args
),
2919 RETURN (SCM_APPLY (SCM_CCLO_SUBR (proc
),
2920 scm_cons2 (proc
, t
.arg1
,
2927 /* case scm_tc7_cclo:
2928 x = scm_cons(arg2, scm_eval_args(x, env));
2931 proc = SCM_CCLO_SUBR(proc);
2934 case scm_tcs_cons_gloc
:
2935 if (SCM_OBJ_CLASS_FLAGS (proc
) & SCM_CLASSF_PURE_GENERIC
)
2937 x
= SCM_ENTITY_PROCEDURE (proc
);
2939 arg2
= debug
.info
->a
.args
;
2941 arg2
= scm_cons2 (t
.arg1
, arg2
, SCM_EOL
);
2945 else if (!SCM_I_OPERATORP (proc
))
2951 RETURN (SCM_APPLY (SCM_I_ENTITYP (proc
)
2952 ? SCM_ENTITY_PROCEDURE (proc
)
2953 : SCM_OPERATOR_PROCEDURE (proc
),
2954 scm_cons (proc
, debug
.info
->a
.args
),
2957 RETURN (SCM_APPLY (SCM_I_ENTITYP (proc
)
2958 ? SCM_ENTITY_PROCEDURE (proc
)
2959 : SCM_OPERATOR_PROCEDURE (proc
),
2960 scm_cons2 (proc
, t
.arg1
,
2968 case scm_tc7_subr_0
:
2970 case scm_tc7_subr_1o
:
2971 case scm_tc7_subr_1
:
2972 case scm_tc7_subr_3
:
2973 case scm_tc7_contin
:
2978 proc
= SCM_PROCEDURE (proc
);
2980 debug
.info
->a
.proc
= proc
;
2982 if (!SCM_CLOSUREP (proc
))
2984 if (scm_badformalsp (proc
, 2))
2985 goto umwrongnumargs
;
2986 case scm_tcs_closures
:
2989 env
= EXTEND_ENV (SCM_CAR (SCM_CODE (proc
)),
2993 env
= EXTEND_ENV (SCM_CAR (SCM_CODE (proc
)),
2994 scm_cons2 (t
.arg1
, arg2
, SCM_EOL
), SCM_ENV (proc
));
2996 x
= SCM_CODE (proc
);
3001 if (SCM_IMP (x
) || SCM_NECONSP (x
))
3005 debug
.info
->a
.args
= scm_cons2 (t
.arg1
, arg2
,
3006 scm_deval_args (x
, env
, proc
,
3007 SCM_CDRLOC (SCM_CDR (debug
.info
->a
.args
))));
3011 switch (SCM_TYP7 (proc
))
3012 { /* have 3 or more arguments */
3014 case scm_tc7_subr_3
:
3015 SCM_ASRTGO (SCM_NULLP (SCM_CDR (x
)), wrongnumargs
);
3016 RETURN (SCM_SUBRF (proc
) (t
.arg1
, arg2
,
3017 SCM_CADDR (debug
.info
->a
.args
)));
3019 #ifdef BUILTIN_RPASUBR
3020 t
.arg1
= SCM_SUBRF(proc
)(t
.arg1
, arg2
);
3021 arg2
= SCM_CDR (SCM_CDR (debug
.info
->a
.args
));
3024 t
.arg1
= SCM_SUBRF(proc
)(t
.arg1
, SCM_CAR (arg2
));
3025 arg2
= SCM_CDR (arg2
);
3027 while (SCM_NIMP (arg2
));
3029 #endif /* BUILTIN_RPASUBR */
3030 case scm_tc7_rpsubr
:
3031 #ifdef BUILTIN_RPASUBR
3032 if (SCM_FALSEP (SCM_SUBRF (proc
) (t
.arg1
, arg2
)))
3034 t
.arg1
= SCM_CDR (SCM_CDR (debug
.info
->a
.args
));
3037 if (SCM_FALSEP (SCM_SUBRF (proc
) (arg2
, SCM_CAR (t
.arg1
))))
3039 arg2
= SCM_CAR (t
.arg1
);
3040 t
.arg1
= SCM_CDR (t
.arg1
);
3042 while (SCM_NIMP (t
.arg1
));
3044 #else /* BUILTIN_RPASUBR */
3045 RETURN (SCM_APPLY (proc
, t
.arg1
,
3047 SCM_CDR (SCM_CDR (debug
.info
->a
.args
)),
3049 #endif /* BUILTIN_RPASUBR */
3050 case scm_tc7_lsubr_2
:
3051 RETURN (SCM_SUBRF (proc
) (t
.arg1
, arg2
,
3052 SCM_CDR (SCM_CDR (debug
.info
->a
.args
))))
3054 RETURN (SCM_SUBRF (proc
) (debug
.info
->a
.args
))
3060 proc
= SCM_PROCEDURE (proc
);
3061 debug
.info
->a
.proc
= proc
;
3062 if (!SCM_CLOSUREP (proc
))
3064 if (scm_badargsp (SCM_CAR (SCM_CODE (proc
)), debug
.info
->a
.args
))
3065 goto umwrongnumargs
;
3066 case scm_tcs_closures
:
3067 SCM_SET_ARGSREADY (debug
);
3068 env
= EXTEND_ENV (SCM_CAR (SCM_CODE (proc
)),
3071 x
= SCM_CODE (proc
);
3074 case scm_tc7_subr_3
:
3075 SCM_ASRTGO (SCM_NULLP (SCM_CDR (x
)), wrongnumargs
);
3076 RETURN (SCM_SUBRF (proc
) (t
.arg1
, arg2
, EVALCAR (x
, env
)));
3078 #ifdef BUILTIN_RPASUBR
3079 t
.arg1
= SCM_SUBRF (proc
) (t
.arg1
, arg2
);
3082 t
.arg1
= SCM_SUBRF(proc
)(t
.arg1
, EVALCAR(x
, env
));
3085 while (SCM_NIMP (x
));
3087 #endif /* BUILTIN_RPASUBR */
3088 case scm_tc7_rpsubr
:
3089 #ifdef BUILTIN_RPASUBR
3090 if (SCM_FALSEP (SCM_SUBRF (proc
) (t
.arg1
, arg2
)))
3094 t
.arg1
= EVALCAR (x
, env
);
3095 if (SCM_FALSEP (SCM_SUBRF (proc
) (arg2
, t
.arg1
)))
3100 while (SCM_NIMP (x
));
3102 #else /* BUILTIN_RPASUBR */
3103 RETURN (SCM_APPLY (proc
, t
.arg1
,
3105 scm_eval_args (x
, env
, proc
),
3107 #endif /* BUILTIN_RPASUBR */
3108 case scm_tc7_lsubr_2
:
3109 RETURN (SCM_SUBRF (proc
) (t
.arg1
, arg2
, scm_eval_args (x
, env
, proc
)));
3111 RETURN (SCM_SUBRF (proc
) (scm_cons2 (t
.arg1
,
3113 scm_eval_args (x
, env
, proc
))));
3119 proc
= SCM_PROCEDURE (proc
);
3120 if (!SCM_CLOSUREP (proc
))
3123 SCM formals
= SCM_CAR (SCM_CODE (proc
));
3124 if (SCM_NULLP (formals
)
3125 || (SCM_CONSP (formals
)
3126 && (SCM_NULLP (SCM_CDR (formals
))
3127 || (SCM_CONSP (SCM_CDR (formals
))
3128 && scm_badargsp (SCM_CDDR (formals
), x
)))))
3129 goto umwrongnumargs
;
3131 case scm_tcs_closures
:
3133 SCM_SET_ARGSREADY (debug
);
3135 env
= EXTEND_ENV (SCM_CAR (SCM_CODE (proc
)),
3138 scm_eval_args (x
, env
, proc
)),
3140 x
= SCM_CODE (proc
);
3143 case scm_tcs_cons_gloc
:
3144 if (SCM_OBJ_CLASS_FLAGS (proc
) & SCM_CLASSF_PURE_GENERIC
)
3147 arg2
= debug
.info
->a
.args
;
3149 arg2
= scm_cons2 (t
.arg1
, arg2
, scm_eval_args (x
, env
, proc
));
3151 x
= SCM_ENTITY_PROCEDURE (proc
);
3154 else if (!SCM_I_OPERATORP (proc
))
3158 case scm_tc7_subr_2
:
3159 case scm_tc7_subr_1o
:
3160 case scm_tc7_subr_2o
:
3161 case scm_tc7_subr_0
:
3163 case scm_tc7_subr_1
:
3164 case scm_tc7_contin
:
3172 if (CHECK_EXIT
&& SCM_TRAPS_P
)
3173 if (SCM_EXIT_FRAME_P
|| (SCM_TRACE_P
&& SCM_TRACED_FRAME_P (debug
)))
3175 SCM_CLEAR_TRACED_FRAME (debug
);
3176 if (SCM_CHEAPTRAPS_P
)
3177 t
.arg1
= scm_make_debugobj (&debug
);
3180 scm_make_cont (&t
.arg1
);
3181 if (setjmp (SCM_JMPBUF (t
.arg1
)))
3183 proc
= SCM_THROW_VALUE (t
.arg1
);
3187 scm_ithrow (scm_sym_exit_frame
, scm_cons2 (t
.arg1
, proc
, SCM_EOL
), 0);
3190 scm_last_debug_frame
= debug
.prev
;
3196 /* SECTION: This code is compiled once.
3201 /* This code processes the arguments to apply:
3203 (apply PROC ARG1 ... ARGS)
3205 Given a list (ARG1 ... ARGS), this function conses the ARG1
3206 ... arguments onto the front of ARGS, and returns the resulting
3207 list. Note that ARGS is a list; thus, the argument to this
3208 function is a list whose last element is a list.
3210 Apply calls this function, and applies PROC to the elements of the
3211 result. apply:nconc2last takes care of building the list of
3212 arguments, given (ARG1 ... ARGS).
3214 Rather than do new consing, apply:nconc2last destroys its argument.
3215 On that topic, this code came into my care with the following
3216 beautifully cryptic comment on that topic: "This will only screw
3217 you if you do (scm_apply scm_apply '( ... ))" If you know what
3218 they're referring to, send me a patch to this comment. */
3220 SCM_DEFINE (scm_nconc2last
, "apply:nconc2last", 1, 0, 0,
3223 #define FUNC_NAME s_scm_nconc2last
3226 SCM_VALIDATE_NONEMPTYLIST (1,lst
);
3228 while (SCM_NNULLP (SCM_CDR (*lloc
)))
3229 lloc
= SCM_CDRLOC (*lloc
);
3230 SCM_ASSERT (scm_ilength (SCM_CAR (*lloc
)) >= 0, lst
, SCM_ARG1
, FUNC_NAME
);
3231 *lloc
= SCM_CAR (*lloc
);
3239 /* SECTION: When DEVAL is defined this code yields scm_dapply.
3240 * It is compiled twice.
3246 scm_apply (SCM proc
, SCM arg1
, SCM args
)
3253 scm_dapply (SCM proc
, SCM arg1
, SCM args
)
3258 /* Apply a function to a list of arguments.
3260 This function is exported to the Scheme level as taking two
3261 required arguments and a tail argument, as if it were:
3262 (lambda (proc arg1 . args) ...)
3263 Thus, if you just have a list of arguments to pass to a procedure,
3264 pass the list as ARG1, and '() for ARGS. If you have some fixed
3265 args, pass the first as ARG1, then cons any remaining fixed args
3266 onto the front of your argument list, and pass that as ARGS. */
3269 SCM_APPLY (SCM proc
, SCM arg1
, SCM args
)
3271 #ifdef DEBUG_EXTENSIONS
3273 scm_debug_frame debug
;
3274 scm_debug_info debug_vect_body
;
3275 debug
.prev
= scm_last_debug_frame
;
3276 debug
.status
= SCM_APPLYFRAME
;
3277 debug
.vect
= &debug_vect_body
;
3278 debug
.vect
[0].a
.proc
= proc
;
3279 debug
.vect
[0].a
.args
= SCM_EOL
;
3280 scm_last_debug_frame
= &debug
;
3283 return scm_dapply (proc
, arg1
, args
);
3287 SCM_ASRTGO (SCM_NIMP (proc
), badproc
);
3289 /* If ARGS is the empty list, then we're calling apply with only two
3290 arguments --- ARG1 is the list of arguments for PROC. Whatever
3291 the case, futz with things so that ARG1 is the first argument to
3292 give to PROC (or SCM_UNDEFINED if no args), and ARGS contains the
3295 Setting the debug apply frame args this way is pretty messy.
3296 Perhaps we should store arg1 and args directly in the frame as
3297 received, and let scm_frame_arguments unpack them, because that's
3298 a relatively rare operation. This works for now; if the Guile
3299 developer archives are still around, see Mikael's post of
3301 if (SCM_NULLP (args
))
3303 if (SCM_NULLP (arg1
))
3305 arg1
= SCM_UNDEFINED
;
3307 debug
.vect
[0].a
.args
= SCM_EOL
;
3313 debug
.vect
[0].a
.args
= arg1
;
3315 args
= SCM_CDR (arg1
);
3316 arg1
= SCM_CAR (arg1
);
3321 /* SCM_ASRTGO(SCM_CONSP(args), wrongnumargs); */
3322 args
= scm_nconc2last (args
);
3324 debug
.vect
[0].a
.args
= scm_cons (arg1
, args
);
3328 if (SCM_ENTER_FRAME_P
&& SCM_TRAPS_P
)
3331 if (SCM_CHEAPTRAPS_P
)
3332 tmp
= scm_make_debugobj (&debug
);
3335 scm_make_cont (&tmp
);
3336 if (setjmp (SCM_JMPBUF (tmp
)))
3339 scm_ithrow (scm_sym_enter_frame
, scm_cons (tmp
, SCM_EOL
), 0);
3347 switch (SCM_TYP7 (proc
))
3349 case scm_tc7_subr_2o
:
3350 args
= SCM_NULLP (args
) ? SCM_UNDEFINED
: SCM_CAR (args
);
3351 RETURN (SCM_SUBRF (proc
) (arg1
, args
))
3352 case scm_tc7_subr_2
:
3353 SCM_ASRTGO (SCM_NNULLP (args
) && SCM_NULLP (SCM_CDR (args
)),
3355 args
= SCM_CAR (args
);
3356 RETURN (SCM_SUBRF (proc
) (arg1
, args
))
3357 case scm_tc7_subr_0
:
3358 SCM_ASRTGO (SCM_UNBNDP (arg1
), wrongnumargs
);
3359 RETURN (SCM_SUBRF (proc
) ())
3360 case scm_tc7_subr_1
:
3361 case scm_tc7_subr_1o
:
3362 SCM_ASRTGO (SCM_NULLP (args
), wrongnumargs
);
3363 RETURN (SCM_SUBRF (proc
) (arg1
))
3365 SCM_ASRTGO (SCM_NULLP (args
), wrongnumargs
);
3366 if (SCM_SUBRF (proc
))
3368 if (SCM_INUMP (arg1
))
3370 RETURN (scm_make_real (SCM_DSUBRF (proc
) ((double) SCM_INUM (arg1
))));
3372 SCM_ASRTGO (SCM_NIMP (arg1
), floerr
);
3373 if (SCM_REALP (arg1
))
3375 RETURN (scm_make_real (SCM_DSUBRF (proc
) (SCM_REAL_VALUE (arg1
))));
3378 if (SCM_BIGP (arg1
))
3379 RETURN (scm_make_real (SCM_DSUBRF (proc
) (scm_big2dbl (arg1
))))
3382 SCM_WTA_DISPATCH_1 (*SCM_SUBR_GENERIC (proc
), arg1
,
3383 SCM_ARG1
, SCM_CHARS (SCM_SNAME (proc
)));
3385 proc
= SCM_SNAME (proc
);
3387 char *chrs
= SCM_CHARS (proc
) + SCM_LENGTH (proc
) - 1;
3388 while ('c' != *--chrs
)
3390 SCM_ASSERT (SCM_CONSP (arg1
),
3391 arg1
, SCM_ARG1
, SCM_CHARS (proc
));
3392 arg1
= ('a' == *chrs
) ? SCM_CAR (arg1
) : SCM_CDR (arg1
);
3396 case scm_tc7_subr_3
:
3397 RETURN (SCM_SUBRF (proc
) (arg1
, SCM_CAR (args
), SCM_CAR (SCM_CDR (args
))))
3400 RETURN (SCM_SUBRF (proc
) (SCM_UNBNDP (arg1
) ? SCM_EOL
: debug
.vect
[0].a
.args
))
3402 RETURN (SCM_SUBRF (proc
) (SCM_UNBNDP (arg1
) ? SCM_EOL
: scm_cons (arg1
, args
)))
3404 case scm_tc7_lsubr_2
:
3405 SCM_ASRTGO (SCM_CONSP (args
), wrongnumargs
);
3406 RETURN (SCM_SUBRF (proc
) (arg1
, SCM_CAR (args
), SCM_CDR (args
)))
3408 if (SCM_NULLP (args
))
3409 RETURN (SCM_SUBRF (proc
) (arg1
, SCM_UNDEFINED
))
3410 while (SCM_NIMP (args
))
3412 SCM_ASSERT (SCM_CONSP (args
), args
, SCM_ARG2
, "apply");
3413 arg1
= SCM_SUBRF (proc
) (arg1
, SCM_CAR (args
));
3414 args
= SCM_CDR (args
);
3417 case scm_tc7_rpsubr
:
3418 if (SCM_NULLP (args
))
3419 RETURN (SCM_BOOL_T
);
3420 while (SCM_NIMP (args
))
3422 SCM_ASSERT (SCM_CONSP (args
), args
, SCM_ARG2
, "apply");
3423 if (SCM_FALSEP (SCM_SUBRF (proc
) (arg1
, SCM_CAR (args
))))
3424 RETURN (SCM_BOOL_F
);
3425 arg1
= SCM_CAR (args
);
3426 args
= SCM_CDR (args
);
3428 RETURN (SCM_BOOL_T
);
3429 case scm_tcs_closures
:
3431 arg1
= (SCM_UNBNDP (arg1
) ? SCM_EOL
: debug
.vect
[0].a
.args
);
3433 arg1
= (SCM_UNBNDP (arg1
) ? SCM_EOL
: scm_cons (arg1
, args
));
3435 #ifndef SCM_RECKLESS
3436 if (scm_badargsp (SCM_CAR (SCM_CODE (proc
)), arg1
))
3440 /* Copy argument list */
3445 SCM tl
= args
= scm_cons (SCM_CAR (arg1
), SCM_UNSPECIFIED
);
3446 while (arg1
= SCM_CDR (arg1
), SCM_CONSP (arg1
))
3448 SCM_SETCDR (tl
, scm_cons (SCM_CAR (arg1
),
3452 SCM_SETCDR (tl
, arg1
);
3455 args
= EXTEND_ENV (SCM_CAR (SCM_CODE (proc
)), args
, SCM_ENV (proc
));
3456 proc
= SCM_CDR (SCM_CODE (proc
));
3459 while (SCM_NNULLP (arg1
= SCM_CDR (arg1
)))
3461 if (SCM_IMP (SCM_CAR (proc
)))
3463 if (SCM_ISYMP (SCM_CAR (proc
)))
3465 proc
= scm_m_expand_body (proc
, args
);
3470 SCM_CEVAL (SCM_CAR (proc
), args
);
3473 RETURN (EVALCAR (proc
, args
));
3474 case scm_tc7_contin
:
3475 SCM_ASRTGO (SCM_NULLP (args
), wrongnumargs
);
3476 scm_call_continuation (proc
, arg1
);
3480 args
= (SCM_UNBNDP(arg1
) ? SCM_EOL
: debug
.vect
[0].a
.args
);
3482 proc
= SCM_CCLO_SUBR (proc
);
3483 debug
.vect
[0].a
.proc
= proc
;
3484 debug
.vect
[0].a
.args
= scm_cons (arg1
, args
);
3486 args
= (SCM_UNBNDP(arg1
) ? SCM_EOL
: scm_cons (arg1
, args
));
3488 proc
= SCM_CCLO_SUBR (proc
);
3493 proc
= SCM_PROCEDURE (proc
);
3495 debug
.vect
[0].a
.proc
= proc
;
3498 case scm_tcs_cons_gloc
:
3499 if (SCM_OBJ_CLASS_FLAGS (proc
) & SCM_CLASSF_PURE_GENERIC
)
3502 args
= (SCM_UNBNDP(arg1
) ? SCM_EOL
: debug
.vect
[0].a
.args
);
3504 args
= (SCM_UNBNDP(arg1
) ? SCM_EOL
: scm_cons (arg1
, args
));
3506 RETURN (scm_apply_generic (proc
, args
));
3508 else if (!SCM_I_OPERATORP (proc
))
3513 args
= (SCM_UNBNDP(arg1
) ? SCM_EOL
: debug
.vect
[0].a
.args
);
3515 args
= (SCM_UNBNDP(arg1
) ? SCM_EOL
: scm_cons (arg1
, args
));
3518 proc
= (SCM_I_ENTITYP (proc
)
3519 ? SCM_ENTITY_PROCEDURE (proc
)
3520 : SCM_OPERATOR_PROCEDURE (proc
));
3522 debug
.vect
[0].a
.proc
= proc
;
3523 debug
.vect
[0].a
.args
= scm_cons (arg1
, args
);
3525 if (SCM_NIMP (proc
))
3531 scm_wrong_num_args (proc
);
3534 scm_wta (proc
, (char *) SCM_ARG1
, "apply");
3539 if (CHECK_EXIT
&& SCM_TRAPS_P
)
3540 if (SCM_EXIT_FRAME_P
|| (SCM_TRACE_P
&& SCM_TRACED_FRAME_P (debug
)))
3542 SCM_CLEAR_TRACED_FRAME (debug
);
3543 if (SCM_CHEAPTRAPS_P
)
3544 arg1
= scm_make_debugobj (&debug
);
3547 scm_make_cont (&arg1
);
3548 if (setjmp (SCM_JMPBUF (arg1
)))
3550 proc
= SCM_THROW_VALUE (arg1
);
3554 scm_ithrow (scm_sym_exit_frame
, scm_cons2 (arg1
, proc
, SCM_EOL
), 0);
3557 scm_last_debug_frame
= debug
.prev
;
3563 /* SECTION: The rest of this file is only read once.
3568 /* Typechecking for multi-argument MAP and FOR-EACH.
3570 Verify that each element of the vector ARGV, except for the first,
3571 is a proper list whose length is LEN. Attribute errors to WHO,
3572 and claim that the i'th element of ARGV is WHO's i+2'th argument. */
3574 check_map_args (SCM argv
,
3581 SCM
*ve
= SCM_VELTS (argv
);
3584 for (i
= SCM_LENGTH (argv
) - 1; i
>= 1; i
--)
3586 int elt_len
= scm_ilength (ve
[i
]);
3591 scm_apply_generic (gf
, scm_cons (proc
, args
));
3593 scm_wrong_type_arg (who
, i
+ 2, ve
[i
]);
3597 scm_out_of_range (who
, ve
[i
]);
3600 scm_remember (&argv
);
3604 SCM_GPROC (s_map
, "map", 2, 0, 1, scm_map
, g_map
);
3606 /* Note: Currently, scm_map applies PROC to the argument list(s)
3607 sequentially, starting with the first element(s). This is used in
3608 evalext.c where the Scheme procedure `map-in-order', which guarantees
3609 sequential behaviour, is implemented using scm_map. If the
3610 behaviour changes, we need to update `map-in-order'.
3614 scm_map (SCM proc
, SCM arg1
, SCM args
)
3615 #define FUNC_NAME s_map
3620 SCM
*ve
= &args
; /* Keep args from being optimized away. */
3622 len
= scm_ilength (arg1
);
3623 SCM_GASSERTn (len
>= 0,
3624 g_map
, scm_cons2 (proc
, arg1
, args
), SCM_ARG2
, s_map
);
3625 SCM_VALIDATE_REST_ARGUMENT (args
);
3626 if (SCM_NULLP (args
))
3628 while (SCM_NIMP (arg1
))
3630 *pres
= scm_cons (scm_apply (proc
, SCM_CAR (arg1
), scm_listofnull
),
3632 pres
= SCM_CDRLOC (*pres
);
3633 arg1
= SCM_CDR (arg1
);
3637 args
= scm_vector (arg1
= scm_cons (arg1
, args
));
3638 ve
= SCM_VELTS (args
);
3639 #ifndef SCM_RECKLESS
3640 check_map_args (args
, len
, g_map
, proc
, arg1
, s_map
);
3645 for (i
= SCM_LENGTH (args
) - 1; i
>= 0; i
--)
3647 if (SCM_IMP (ve
[i
]))
3649 arg1
= scm_cons (SCM_CAR (ve
[i
]), arg1
);
3650 ve
[i
] = SCM_CDR (ve
[i
]);
3652 *pres
= scm_cons (scm_apply (proc
, arg1
, SCM_EOL
), SCM_EOL
);
3653 pres
= SCM_CDRLOC (*pres
);
3659 SCM_GPROC (s_for_each
, "for-each", 2, 0, 1, scm_for_each
, g_for_each
);
3662 scm_for_each (SCM proc
, SCM arg1
, SCM args
)
3663 #define FUNC_NAME s_for_each
3665 SCM
*ve
= &args
; /* Keep args from being optimized away. */
3667 len
= scm_ilength (arg1
);
3668 SCM_GASSERTn (len
>= 0, g_for_each
, scm_cons2 (proc
, arg1
, args
),
3669 SCM_ARG2
, s_for_each
);
3670 SCM_VALIDATE_REST_ARGUMENT (args
);
3673 while SCM_NIMP (arg1
)
3675 scm_apply (proc
, SCM_CAR (arg1
), scm_listofnull
);
3676 arg1
= SCM_CDR (arg1
);
3678 return SCM_UNSPECIFIED
;
3680 args
= scm_vector (arg1
= scm_cons (arg1
, args
));
3681 ve
= SCM_VELTS (args
);
3682 #ifndef SCM_RECKLESS
3683 check_map_args (args
, len
, g_for_each
, proc
, arg1
, s_for_each
);
3688 for (i
= SCM_LENGTH (args
) - 1; i
>= 0; i
--)
3691 (ve
[i
]) return SCM_UNSPECIFIED
;
3692 arg1
= scm_cons (SCM_CAR (ve
[i
]), arg1
);
3693 ve
[i
] = SCM_CDR (ve
[i
]);
3695 scm_apply (proc
, arg1
, SCM_EOL
);
3702 scm_closure (SCM code
, SCM env
)
3706 SCM_SETCODE (z
, code
);
3707 SCM_SETENV (z
, env
);
3712 long scm_tc16_promise
;
3715 scm_makprom (SCM code
)
3717 SCM_RETURN_NEWSMOB (scm_tc16_promise
, SCM_UNPACK (code
));
3723 prinprom (SCM exp
,SCM port
,scm_print_state
*pstate
)
3725 int writingp
= SCM_WRITINGP (pstate
);
3726 scm_puts ("#<promise ", port
);
3727 SCM_SET_WRITINGP (pstate
, 1);
3728 scm_iprin1 (SCM_CDR (exp
), port
, pstate
);
3729 SCM_SET_WRITINGP (pstate
, writingp
);
3730 scm_putc ('>', port
);
3735 SCM_DEFINE (scm_force
, "force", 1, 0, 0,
3737 "If the promise X has not been computed yet, compute and return\n"
3738 "X, otherwise just return the previously computed value.")
3739 #define FUNC_NAME s_scm_force
3741 SCM_VALIDATE_SMOB (1, x
, promise
);
3742 if (!((1L << 16) & SCM_CELL_WORD_0 (x
)))
3744 SCM ans
= scm_apply (SCM_CELL_OBJECT_1 (x
), SCM_EOL
, SCM_EOL
);
3745 if (!((1L << 16) & SCM_CELL_WORD_0 (x
)))
3748 SCM_SET_CELL_OBJECT_1 (x
, ans
);
3749 SCM_SET_CELL_WORD_0 (x
, SCM_CELL_WORD_0 (x
) | (1L << 16));
3753 return SCM_CELL_OBJECT_1 (x
);
3758 SCM_DEFINE (scm_promise_p
, "promise?", 1, 0, 0,
3760 "Return true if @var{obj} is a promise, i.e. a delayed computation\n"
3761 "(@pxref{Delayed evaluation,,,r4rs.info,The Revised^4 Report on Scheme}).")
3762 #define FUNC_NAME s_scm_promise_p
3764 return SCM_BOOL (SCM_SMOB_PREDICATE (scm_tc16_promise
, x
));
3769 SCM_DEFINE (scm_cons_source
, "cons-source", 3, 0, 0,
3770 (SCM xorig
, SCM x
, SCM y
),
3772 #define FUNC_NAME s_scm_cons_source
3776 SCM_SET_CELL_OBJECT_0 (z
, x
);
3777 SCM_SET_CELL_OBJECT_1 (z
, y
);
3778 /* Copy source properties possibly associated with xorig. */
3779 p
= scm_whash_lookup (scm_source_whash
, xorig
);
3781 scm_whash_insert (scm_source_whash
, z
, p
);
3787 SCM_DEFINE (scm_copy_tree
, "copy-tree", 1, 0, 0,
3789 "Recursively copy the data tree that is bound to @var{obj}, and return a\n"
3790 "pointer to the new data structure. @code{copy-tree} recurses down the\n"
3791 "contents of both pairs and vectors (since both cons cells and vector\n"
3792 "cells may point to arbitrary objects), and stops recursing when it hits\n"
3793 "any other object.")
3794 #define FUNC_NAME s_scm_copy_tree
3799 if (SCM_VECTORP (obj
))
3801 scm_sizet i
= SCM_LENGTH (obj
);
3802 ans
= scm_make_vector (SCM_MAKINUM (i
), SCM_UNSPECIFIED
);
3804 SCM_VELTS (ans
)[i
] = scm_copy_tree (SCM_VELTS (obj
)[i
]);
3807 if (SCM_NCONSP (obj
))
3809 /* return scm_cons(scm_copy_tree(SCM_CAR(obj)), scm_copy_tree(SCM_CDR(obj))); */
3810 ans
= tl
= scm_cons_source (obj
,
3811 scm_copy_tree (SCM_CAR (obj
)),
3813 while (obj
= SCM_CDR (obj
), SCM_CONSP (obj
))
3815 SCM_SETCDR (tl
, scm_cons (scm_copy_tree (SCM_CAR (obj
)),
3819 SCM_SETCDR (tl
, obj
);
3825 SCM scm_system_transformer
;
3828 scm_i_eval_x (SCM exp
, SCM env
)
3830 SCM transformer
= scm_fluid_ref (SCM_CDR (scm_system_transformer
));
3831 if (SCM_NIMP (transformer
))
3832 exp
= scm_apply (transformer
, exp
, scm_listofnull
);
3833 return SCM_XEVAL (exp
, env
);
3837 scm_i_eval (SCM exp
, SCM env
)
3839 SCM transformer
= scm_fluid_ref (SCM_CDR (scm_system_transformer
));
3840 if (SCM_NIMP (transformer
))
3841 exp
= scm_apply (transformer
, exp
, scm_listofnull
);
3842 return SCM_XEVAL (scm_copy_tree (exp
), env
);
3846 scm_eval_x (SCM exp
, SCM module
)
3848 return scm_i_eval_x (exp
,
3849 scm_top_level_env (SCM_MODULE_EVAL_CLOSURE (module
)));
3852 /* Eval does not take the second arg optionally. This is intentional
3853 * in order to be R5RS compatible, and to prepare for the new module
3854 * system, where we would like to make the choice of evaluation
3855 * environment explicit.
3858 SCM_DEFINE (scm_eval
, "eval", 2, 0, 0,
3859 (SCM exp
, SCM environment
),
3860 "Evaluate @var{exp}, a list representing a Scheme expression, in the\n"
3861 "environment given by @var{environment specifier}.")
3862 #define FUNC_NAME s_scm_eval
3864 SCM_VALIDATE_MODULE (2, environment
);
3865 return scm_i_eval (scm_copy_tree (exp
),
3866 scm_top_level_env (SCM_MODULE_EVAL_CLOSURE (environment
)));
3870 #if (SCM_DEBUG_DEPRECATED == 0)
3872 /* Use scm_selected_module () or scm_interaction_environment ()
3873 * instead. The former is the module selected during loading of code.
3874 * The latter is the module in which the user of this thread currently
3875 * types expressions.
3878 SCM scm_top_level_lookup_closure_var
;
3880 /* Avoid using this functionality altogether (except for implementing
3881 * libguile, where you can use scm_i_eval or scm_i_eval_x).
3883 * Applications should use either C level scm_eval_x or Scheme scm_eval. */
3886 scm_eval_3 (SCM obj
, int copyp
, SCM env
)
3889 return scm_i_eval (obj
, env
);
3891 return scm_i_eval_x (obj
, env
);
3894 SCM_DEFINE (scm_eval2
, "eval2", 2, 0, 0,
3895 (SCM obj
, SCM env_thunk
),
3896 "Evaluate @var{exp}, a Scheme expression, in the environment designated\n"
3897 "by @var{lookup}, a symbol-lookup function. @code{(eval exp)} is\n"
3898 "equivalent to @code{(eval2 exp *top-level-lookup-closure*)}.")
3899 #define FUNC_NAME s_scm_eval2
3901 return scm_i_eval (obj
, scm_top_level_env (env_thunk
));
3905 #endif /* DEPRECATED */
3908 /* At this point, scm_deval and scm_dapply are generated.
3911 #ifdef DEBUG_EXTENSIONS
3921 scm_init_opts (scm_evaluator_traps
,
3922 scm_evaluator_trap_table
,
3923 SCM_N_EVALUATOR_TRAPS
);
3924 scm_init_opts (scm_eval_options_interface
,
3926 SCM_N_EVAL_OPTIONS
);
3928 scm_tc16_promise
= scm_make_smob_type ("promise", 0);
3929 scm_set_smob_mark (scm_tc16_promise
, scm_markcdr
);
3930 scm_set_smob_print (scm_tc16_promise
, prinprom
);
3932 scm_f_apply
= scm_make_subr ("apply", scm_tc7_lsubr_2
, scm_apply
);
3933 scm_system_transformer
= scm_sysintern ("scm:eval-transformer",
3935 scm_sym_dot
= SCM_CAR (scm_sysintern (".", SCM_UNDEFINED
));
3936 scm_sym_arrow
= SCM_CAR (scm_sysintern ("=>", SCM_UNDEFINED
));
3937 scm_sym_else
= SCM_CAR (scm_sysintern ("else", SCM_UNDEFINED
));
3938 scm_sym_unquote
= SCM_CAR (scm_sysintern ("unquote", SCM_UNDEFINED
));
3939 scm_sym_uq_splicing
= SCM_CAR (scm_sysintern ("unquote-splicing", SCM_UNDEFINED
));
3941 scm_lisp_nil
= scm_sysintern ("nil", SCM_UNDEFINED
);
3942 SCM_SETCDR (scm_lisp_nil
, SCM_CAR (scm_lisp_nil
));
3943 scm_lisp_nil
= SCM_CAR (scm_lisp_nil
);
3944 scm_lisp_t
= scm_sysintern ("t", SCM_UNDEFINED
);
3945 SCM_SETCDR (scm_lisp_t
, SCM_CAR (scm_lisp_t
));
3946 scm_lisp_t
= SCM_CAR (scm_lisp_t
);
3951 #if SCM_DEBUG_DEPRECATED == 0
3952 scm_top_level_lookup_closure_var
=
3953 scm_sysintern ("*top-level-lookup-closure*", scm_make_fluid ());
3956 #ifdef DEBUG_EXTENSIONS
3957 scm_sym_enter_frame
= SCM_CAR (scm_sysintern ("enter-frame", SCM_UNDEFINED
));
3958 scm_sym_apply_frame
= SCM_CAR (scm_sysintern ("apply-frame", SCM_UNDEFINED
));
3959 scm_sym_exit_frame
= SCM_CAR (scm_sysintern ("exit-frame", SCM_UNDEFINED
));
3960 scm_sym_trace
= SCM_CAR (scm_sysintern ("trace", SCM_UNDEFINED
));
3963 #include "libguile/eval.x"
3965 scm_add_feature ("delay");