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_SYMBOL (scm_unbound_variable_key
, "unbound-variable");
260 scm_lookupcar1 (SCM vloc
, SCM genv
, int check
)
263 scm_lookupcar (SCM vloc
, SCM genv
, int check
)
267 register SCM
*al
, fl
, var
= SCM_CAR (vloc
);
269 register SCM var2
= var
;
271 #ifdef MEMOIZE_LOCALS
272 register SCM iloc
= SCM_ILOC00
;
274 for (; SCM_NIMP (env
); env
= SCM_CDR (env
))
276 if (SCM_TRUE_P (scm_procedure_p (SCM_CAR (env
))))
278 al
= SCM_CARLOC (env
);
279 for (fl
= SCM_CAR (*al
); SCM_NIMP (fl
); fl
= SCM_CDR (fl
))
283 if (SCM_EQ_P (fl
, var
))
285 #ifdef MEMOIZE_LOCALS
287 if (! SCM_EQ_P (SCM_CAR (vloc
), var
))
290 SCM_SET_CELL_WORD_0 (vloc
, SCM_UNPACK (iloc
) + SCM_ICDR
);
292 return SCM_CDRLOC (*al
);
297 al
= SCM_CDRLOC (*al
);
298 if (SCM_EQ_P (SCM_CAR (fl
), var
))
300 #ifdef MEMOIZE_LOCALS
301 #ifndef SCM_RECKLESS /* letrec inits to SCM_UNDEFINED */
302 if (SCM_UNBNDP (SCM_CAR (*al
)))
309 if (SCM_CAR (vloc
) != var
)
312 SCM_SETCAR (vloc
, iloc
);
314 return SCM_CARLOC (*al
);
316 #ifdef MEMOIZE_LOCALS
317 iloc
= SCM_PACK (SCM_UNPACK (iloc
) + SCM_IDINC
);
320 #ifdef MEMOIZE_LOCALS
321 iloc
= SCM_PACK ((~SCM_IDSTMSK
) & (SCM_UNPACK(iloc
) + SCM_IFRINC
));
325 SCM top_thunk
, vcell
;
328 top_thunk
= SCM_CAR(env
); /* env now refers to a top level env thunk */
332 top_thunk
= SCM_BOOL_F
;
333 vcell
= scm_sym2vcell (var
, top_thunk
, SCM_BOOL_F
);
334 if (SCM_FALSEP (vcell
))
340 if (SCM_NNULLP (env
) || SCM_UNBNDP (SCM_CDR (var
)))
344 /* scm_everr (vloc, genv,...) */
348 scm_error (scm_unbound_variable_key
, NULL
, "Unbound variable: ~S",
349 scm_cons (var
, SCM_EOL
), SCM_BOOL_F
);
351 scm_misc_error (NULL
, "Damaged environment: ~S",
352 scm_cons (var
, SCM_EOL
));
355 /* A variable could not be found, but we shall not throw an error. */
356 static SCM undef_object
= SCM_UNDEFINED
;
357 return &undef_object
;
362 if (SCM_CAR (vloc
) != var2
)
364 /* Some other thread has changed the very cell we are working
365 on. In effect, it must have done our job or messed it up
368 var
= SCM_CAR (vloc
);
369 if (SCM_ITAG3 (var
) == scm_tc3_cons_gloc
)
370 return SCM_GLOC_VAL_LOC (var
);
371 #ifdef MEMOIZE_LOCALS
372 if ((SCM_UNPACK (var
) & 127) == (127 & SCM_UNPACK (SCM_ILOC00
)))
373 return scm_ilookup (var
, genv
);
375 /* We can't cope with anything else than glocs and ilocs. When
376 a special form has been memoized (i.e. `let' into `#@let') we
377 return NULL and expect the calling function to do the right
378 thing. For the evaluator, this means going back and redoing
379 the dispatch on the car of the form. */
382 #endif /* USE_THREADS */
384 SCM_SET_CELL_WORD_0 (vloc
, SCM_UNPACK (var
) + scm_tc3_cons_gloc
);
385 /* Except wait...what if the var is not a vcell,
386 * but syntax or something.... */
387 return SCM_CDRLOC (var
);
392 scm_lookupcar (SCM vloc
, SCM genv
, int check
)
394 SCM
*loc
= scm_lookupcar1 (vloc
, genv
, check
);
401 #define unmemocar scm_unmemocar
404 scm_unmemocar (SCM form
, SCM env
)
411 if (SCM_ITAG3 (c
) == scm_tc3_cons_gloc
)
412 SCM_SETCAR (form
, SCM_GLOC_SYM (c
));
413 #ifdef MEMOIZE_LOCALS
414 #ifdef DEBUG_EXTENSIONS
415 else if (SCM_ILOCP (c
))
419 for (ir
= SCM_IFRAME (c
); ir
!= 0; --ir
)
421 env
= SCM_CAR (SCM_CAR (env
));
422 for (ir
= SCM_IDIST (c
); ir
!= 0; --ir
)
424 SCM_SETCAR (form
, SCM_ICDRP (c
) ? env
: SCM_CAR (env
));
433 scm_eval_car (SCM pair
, SCM env
)
435 return SCM_XEVALCAR (pair
, env
);
440 * The following rewrite expressions and
441 * some memoized forms have different syntax
444 const char scm_s_expression
[] = "missing or extra expression";
445 const char scm_s_test
[] = "bad test";
446 const char scm_s_body
[] = "bad body";
447 const char scm_s_bindings
[] = "bad bindings";
448 const char scm_s_variable
[] = "bad variable";
449 const char scm_s_clauses
[] = "bad or missing clauses";
450 const char scm_s_formals
[] = "bad formals";
452 SCM scm_sym_dot
, scm_sym_arrow
, scm_sym_else
;
453 SCM scm_sym_unquote
, scm_sym_uq_splicing
, scm_sym_apply
;
457 #ifdef DEBUG_EXTENSIONS
458 SCM scm_sym_enter_frame
, scm_sym_apply_frame
, scm_sym_exit_frame
;
462 #define ASRTSYNTAX(cond_, msg_) if(!(cond_))scm_wta(xorig, (msg_), what);
466 static void bodycheck (SCM xorig
, SCM
*bodyloc
, const char *what
);
469 bodycheck (SCM xorig
, SCM
*bodyloc
, const char *what
)
471 ASRTSYNTAX (scm_ilength (*bodyloc
) >= 1, scm_s_expression
);
474 /* Check that the body denoted by XORIG is valid and rewrite it into
475 its internal form. The internal form of a body is just the body
476 itself, but prefixed with an ISYM that denotes to what kind of
477 outer construct this body belongs. A lambda body starts with
478 SCM_IM_LAMBDA, for example, a body of a let starts with SCM_IM_LET,
479 etc. The one exception is a body that belongs to a letrec that has
480 been formed by rewriting internal defines: it starts with
483 /* XXX - Besides controlling the rewriting of internal defines, the
484 additional ISYM could be used for improved error messages.
485 This is not done yet. */
488 scm_m_body (SCM op
, SCM xorig
, const char *what
)
490 ASRTSYNTAX (scm_ilength (xorig
) >= 1, scm_s_expression
);
492 /* Don't add another ISYM if one is present already. */
493 if (SCM_ISYMP (SCM_CAR (xorig
)))
496 /* Retain possible doc string. */
497 if (!SCM_CONSP (SCM_CAR (xorig
)))
499 if (SCM_NNULLP (SCM_CDR(xorig
)))
500 return scm_cons (SCM_CAR (xorig
),
501 scm_m_body (op
, SCM_CDR(xorig
), what
));
505 return scm_cons2 (op
, SCM_CAR (xorig
), SCM_CDR(xorig
));
508 SCM_SYNTAX(s_quote
,"quote", scm_makmmacro
, scm_m_quote
);
509 SCM_GLOBAL_SYMBOL(scm_sym_quote
, s_quote
);
512 scm_m_quote (SCM xorig
, SCM env
)
514 SCM x
= scm_copy_tree (SCM_CDR (xorig
));
516 SCM_ASSYNT (scm_ilength (SCM_CDR (xorig
)) == 1,
517 xorig
, scm_s_expression
, s_quote
);
518 return scm_cons (SCM_IM_QUOTE
, x
);
523 SCM_SYNTAX(s_begin
, "begin", scm_makmmacro
, scm_m_begin
);
524 SCM_GLOBAL_SYMBOL(scm_sym_begin
, s_begin
);
527 scm_m_begin (SCM xorig
, SCM env
)
529 SCM_ASSYNT (scm_ilength (SCM_CDR (xorig
)) >= 1,
530 xorig
, scm_s_expression
, s_begin
);
531 return scm_cons (SCM_IM_BEGIN
, SCM_CDR (xorig
));
534 SCM_SYNTAX(s_if
, "if", scm_makmmacro
, scm_m_if
);
535 SCM_GLOBAL_SYMBOL(scm_sym_if
, s_if
);
538 scm_m_if (SCM xorig
, SCM env
)
540 int len
= scm_ilength (SCM_CDR (xorig
));
541 SCM_ASSYNT (len
>= 2 && len
<= 3, xorig
, scm_s_expression
, "if");
542 return scm_cons (SCM_IM_IF
, SCM_CDR (xorig
));
546 /* Will go into the RnRS module when Guile is factorized.
547 SCM_SYNTAX(scm_s_set_x,"set!", scm_makmmacro, scm_m_set_x); */
548 const char scm_s_set_x
[] = "set!";
549 SCM_GLOBAL_SYMBOL(scm_sym_set_x
, scm_s_set_x
);
552 scm_m_set_x (SCM xorig
, SCM env
)
554 SCM x
= SCM_CDR (xorig
);
555 SCM_ASSYNT (2 == scm_ilength (x
), xorig
, scm_s_expression
, scm_s_set_x
);
556 SCM_ASSYNT (SCM_SYMBOLP (SCM_CAR (x
)),
557 xorig
, scm_s_variable
, scm_s_set_x
);
558 return scm_cons (SCM_IM_SET_X
, x
);
565 scm_m_vref (SCM xorig
, SCM env
)
567 SCM x
= SCM_CDR (xorig
);
568 SCM_ASSYNT (1 == scm_ilength (x
), xorig
, scm_s_expression
, s_vref
);
569 if (SCM_NIMP(x
) && UDSCM_VARIABLEP (SCM_CAR (x
)))
571 /* scm_everr (SCM_UNDEFINED, env,..., "global variable reference") */
572 scm_misc_error (NULL
,
574 scm_listify (SCM_CAR (SCM_CDR (x
)), SCM_UNDEFINED
));
576 SCM_ASSYNT (SCM_NIMP(x
) && DEFSCM_VARIABLEP (SCM_CAR (x
)),
577 xorig
, scm_s_variable
, s_vref
);
578 return scm_cons (IM_VREF
, x
);
584 scm_m_vset (SCM xorig
, SCM env
)
586 SCM x
= SCM_CDR (xorig
);
587 SCM_ASSYNT (3 == scm_ilength (x
), xorig
, scm_s_expression
, s_vset
);
588 SCM_ASSYNT ((DEFSCM_VARIABLEP (SCM_CAR (x
))
589 || UDSCM_VARIABLEP (SCM_CAR (x
))),
590 xorig
, scm_s_variable
, s_vset
);
591 return scm_cons (IM_VSET
, x
);
596 SCM_SYNTAX(s_and
, "and", scm_makmmacro
, scm_m_and
);
597 SCM_GLOBAL_SYMBOL(scm_sym_and
, s_and
);
600 scm_m_and (SCM xorig
, SCM env
)
602 int len
= scm_ilength (SCM_CDR (xorig
));
603 SCM_ASSYNT (len
>= 0, xorig
, scm_s_test
, s_and
);
605 return scm_cons (SCM_IM_AND
, SCM_CDR (xorig
));
610 SCM_SYNTAX(s_or
,"or", scm_makmmacro
, scm_m_or
);
611 SCM_GLOBAL_SYMBOL(scm_sym_or
,s_or
);
614 scm_m_or (SCM xorig
, SCM env
)
616 int len
= scm_ilength (SCM_CDR (xorig
));
617 SCM_ASSYNT (len
>= 0, xorig
, scm_s_test
, s_or
);
619 return scm_cons (SCM_IM_OR
, SCM_CDR (xorig
));
625 SCM_SYNTAX(s_case
, "case", scm_makmmacro
, scm_m_case
);
626 SCM_GLOBAL_SYMBOL(scm_sym_case
, s_case
);
629 scm_m_case (SCM xorig
, SCM env
)
631 SCM proc
, cdrx
= scm_list_copy (SCM_CDR (xorig
)), x
= cdrx
;
632 SCM_ASSYNT (scm_ilength (x
) >= 2, xorig
, scm_s_clauses
, s_case
);
633 while (SCM_NIMP (x
= SCM_CDR (x
)))
636 SCM_ASSYNT (scm_ilength (proc
) >= 2, xorig
, scm_s_clauses
, s_case
);
637 SCM_ASSYNT (scm_ilength (SCM_CAR (proc
)) >= 0
638 || SCM_EQ_P (scm_sym_else
, SCM_CAR (proc
)),
639 xorig
, scm_s_clauses
, s_case
);
641 return scm_cons (SCM_IM_CASE
, cdrx
);
645 SCM_SYNTAX(s_cond
, "cond", scm_makmmacro
, scm_m_cond
);
646 SCM_GLOBAL_SYMBOL(scm_sym_cond
, s_cond
);
650 scm_m_cond (SCM xorig
, SCM env
)
652 SCM arg1
, cdrx
= scm_list_copy (SCM_CDR (xorig
)), x
= cdrx
;
653 int len
= scm_ilength (x
);
654 SCM_ASSYNT (len
>= 1, xorig
, scm_s_clauses
, s_cond
);
658 len
= scm_ilength (arg1
);
659 SCM_ASSYNT (len
>= 1, xorig
, scm_s_clauses
, s_cond
);
660 if (SCM_EQ_P (scm_sym_else
, SCM_CAR (arg1
)))
662 SCM_ASSYNT (SCM_NULLP (SCM_CDR (x
)) && len
>= 2,
663 xorig
, "bad ELSE clause", s_cond
);
664 SCM_SETCAR (arg1
, SCM_BOOL_T
);
666 if (len
>= 2 && SCM_EQ_P (scm_sym_arrow
, SCM_CAR (SCM_CDR (arg1
))))
667 SCM_ASSYNT (3 == len
&& SCM_NIMP (SCM_CAR (SCM_CDR (SCM_CDR (arg1
)))),
668 xorig
, "bad recipient", s_cond
);
671 return scm_cons (SCM_IM_COND
, cdrx
);
674 SCM_SYNTAX(s_lambda
, "lambda", scm_makmmacro
, scm_m_lambda
);
675 SCM_GLOBAL_SYMBOL(scm_sym_lambda
, s_lambda
);
678 scm_m_lambda (SCM xorig
, SCM env
)
680 SCM proc
, x
= SCM_CDR (xorig
);
681 if (scm_ilength (x
) < 2)
684 if (SCM_NULLP (proc
))
686 if (SCM_EQ_P (SCM_IM_LET
, proc
)) /* named let */
690 if (SCM_SYMBOLP (proc
))
692 if (SCM_NCONSP (proc
))
694 while (SCM_NIMP (proc
))
696 if (SCM_NCONSP (proc
))
698 if (!SCM_SYMBOLP (proc
))
703 if (!SCM_SYMBOLP (SCM_CAR (proc
)))
705 proc
= SCM_CDR (proc
);
707 if (SCM_NNULLP (proc
))
710 scm_wta (xorig
, scm_s_formals
, s_lambda
);
714 return scm_cons2 (SCM_IM_LAMBDA
, SCM_CAR (x
),
715 scm_m_body (SCM_IM_LAMBDA
, SCM_CDR (x
), s_lambda
));
718 SCM_SYNTAX(s_letstar
,"let*", scm_makmmacro
, scm_m_letstar
);
719 SCM_GLOBAL_SYMBOL(scm_sym_letstar
,s_letstar
);
723 scm_m_letstar (SCM xorig
, SCM env
)
725 SCM x
= SCM_CDR (xorig
), arg1
, proc
, vars
= SCM_EOL
, *varloc
= &vars
;
726 int len
= scm_ilength (x
);
727 SCM_ASSYNT (len
>= 2, xorig
, scm_s_body
, s_letstar
);
729 SCM_ASSYNT (scm_ilength (proc
) >= 0, xorig
, scm_s_bindings
, s_letstar
);
730 while (SCM_NIMP (proc
))
732 arg1
= SCM_CAR (proc
);
733 SCM_ASSYNT (2 == scm_ilength (arg1
), xorig
, scm_s_bindings
, s_letstar
);
734 SCM_ASSYNT (SCM_SYMBOLP (SCM_CAR (arg1
)), xorig
, scm_s_variable
, s_letstar
);
735 *varloc
= scm_cons2 (SCM_CAR (arg1
), SCM_CAR (SCM_CDR (arg1
)), SCM_EOL
);
736 varloc
= SCM_CDRLOC (SCM_CDR (*varloc
));
737 proc
= SCM_CDR (proc
);
739 x
= scm_cons (vars
, SCM_CDR (x
));
741 return scm_cons2 (SCM_IM_LETSTAR
, SCM_CAR (x
),
742 scm_m_body (SCM_IM_LETSTAR
, SCM_CDR (x
), s_letstar
));
745 /* DO gets the most radically altered syntax
746 (do ((<var1> <init1> <step1>)
752 (do_mem (varn ... var2 var1)
753 (<init1> <init2> ... <initn>)
756 <step1> <step2> ... <stepn>) ;; missing steps replaced by var
759 SCM_SYNTAX(s_do
, "do", scm_makmmacro
, scm_m_do
);
760 SCM_GLOBAL_SYMBOL(scm_sym_do
, s_do
);
763 scm_m_do (SCM xorig
, SCM env
)
765 SCM x
= SCM_CDR (xorig
), arg1
, proc
;
766 SCM vars
= SCM_EOL
, inits
= SCM_EOL
, steps
= SCM_EOL
;
767 SCM
*initloc
= &inits
, *steploc
= &steps
;
768 int len
= scm_ilength (x
);
769 SCM_ASSYNT (len
>= 2, xorig
, scm_s_test
, "do");
771 SCM_ASSYNT (scm_ilength (proc
) >= 0, xorig
, scm_s_bindings
, "do");
772 while (SCM_NIMP(proc
))
774 arg1
= SCM_CAR (proc
);
775 len
= scm_ilength (arg1
);
776 SCM_ASSYNT (2 == len
|| 3 == len
, xorig
, scm_s_bindings
, "do");
777 SCM_ASSYNT (SCM_SYMBOLP (SCM_CAR (arg1
)), xorig
, scm_s_variable
, "do");
778 /* vars reversed here, inits and steps reversed at evaluation */
779 vars
= scm_cons (SCM_CAR (arg1
), vars
); /* variable */
780 arg1
= SCM_CDR (arg1
);
781 *initloc
= scm_cons (SCM_CAR (arg1
), SCM_EOL
); /* init */
782 initloc
= SCM_CDRLOC (*initloc
);
783 arg1
= SCM_CDR (arg1
);
784 *steploc
= scm_cons (SCM_IMP (arg1
) ? SCM_CAR (vars
) : SCM_CAR (arg1
), SCM_EOL
); /* step */
785 steploc
= SCM_CDRLOC (*steploc
);
786 proc
= SCM_CDR (proc
);
789 SCM_ASSYNT (scm_ilength (SCM_CAR (x
)) >= 1, xorig
, scm_s_test
, "do");
790 x
= scm_cons2 (SCM_CAR (x
), SCM_CDR (x
), steps
);
791 x
= scm_cons2 (vars
, inits
, x
);
792 bodycheck (xorig
, SCM_CARLOC (SCM_CDR (SCM_CDR (x
))), "do");
793 return scm_cons (SCM_IM_DO
, x
);
796 /* evalcar is small version of inline EVALCAR when we don't care about
799 #define evalcar scm_eval_car
802 static SCM
iqq (SCM form
, SCM env
, int depth
);
804 SCM_SYNTAX(s_quasiquote
, "quasiquote", scm_makacro
, scm_m_quasiquote
);
805 SCM_GLOBAL_SYMBOL(scm_sym_quasiquote
, s_quasiquote
);
808 scm_m_quasiquote (SCM xorig
, SCM env
)
810 SCM x
= SCM_CDR (xorig
);
811 SCM_ASSYNT (scm_ilength (x
) == 1, xorig
, scm_s_expression
, s_quasiquote
);
812 return iqq (SCM_CAR (x
), env
, 1);
817 iqq (SCM form
,SCM env
,int depth
)
823 if (SCM_VECTORP (form
))
825 long i
= SCM_LENGTH (form
);
826 SCM
*data
= SCM_VELTS (form
);
829 tmp
= scm_cons (data
[i
], tmp
);
830 return scm_vector (iqq (tmp
, env
, depth
));
832 if (SCM_NCONSP(form
))
834 tmp
= SCM_CAR (form
);
835 if (SCM_EQ_P (scm_sym_quasiquote
, tmp
))
840 if (SCM_EQ_P (scm_sym_unquote
, tmp
))
844 form
= SCM_CDR (form
);
845 SCM_ASSERT (SCM_ECONSP (form
) && SCM_NULLP (SCM_CDR (form
)),
846 form
, SCM_ARG1
, s_quasiquote
);
848 return evalcar (form
, env
);
849 return scm_cons2 (tmp
, iqq (SCM_CAR (form
), env
, depth
), SCM_EOL
);
851 if (SCM_NIMP (tmp
) && (SCM_EQ_P (scm_sym_uq_splicing
, SCM_CAR (tmp
))))
855 return scm_append (scm_cons2 (evalcar (tmp
, env
), iqq (SCM_CDR (form
), env
, depth
), SCM_EOL
));
857 return scm_cons (iqq (SCM_CAR (form
), env
, edepth
), iqq (SCM_CDR (form
), env
, depth
));
860 /* Here are acros which return values rather than code. */
862 SCM_SYNTAX (s_delay
, "delay", scm_makmmacro
, scm_m_delay
);
863 SCM_GLOBAL_SYMBOL (scm_sym_delay
, s_delay
);
866 scm_m_delay (SCM xorig
, SCM env
)
868 SCM_ASSYNT (scm_ilength (xorig
) == 2, xorig
, scm_s_expression
, s_delay
);
869 return scm_cons2 (SCM_IM_DELAY
, SCM_EOL
, SCM_CDR (xorig
));
873 SCM_SYNTAX(s_define
, "define", scm_makmmacro
, scm_m_define
);
874 SCM_GLOBAL_SYMBOL(scm_sym_define
, s_define
);
877 scm_m_define (SCM x
, SCM env
)
881 /* SCM_ASSYNT(SCM_NULLP(env), x, "bad placement", s_define);*/
882 SCM_ASSYNT (scm_ilength (x
) >= 2, arg1
, scm_s_expression
, s_define
);
885 while (SCM_CONSP (proc
))
886 { /* nested define syntax */
887 x
= scm_cons (scm_cons2 (scm_sym_lambda
, SCM_CDR (proc
), x
), SCM_EOL
);
888 proc
= SCM_CAR (proc
);
890 SCM_ASSYNT (SCM_SYMBOLP (proc
),
891 arg1
, scm_s_variable
, s_define
);
892 SCM_ASSYNT (1 == scm_ilength (x
), arg1
, scm_s_expression
, s_define
);
893 if (SCM_TOP_LEVEL (env
))
895 x
= evalcar (x
, env
);
896 #ifdef DEBUG_EXTENSIONS
897 if (SCM_REC_PROCNAMES_P
&& SCM_NIMP (x
))
901 if (SCM_CLOSUREP (arg1
)
902 /* Only the first definition determines the name. */
903 && SCM_FALSEP (scm_procedure_property (arg1
, scm_sym_name
)))
904 scm_set_procedure_property_x (arg1
, scm_sym_name
, proc
);
905 else if (SCM_TYP16 (arg1
) == scm_tc16_macro
906 && !SCM_EQ_P (SCM_CDR (arg1
), arg1
))
908 arg1
= SCM_CDR (arg1
);
913 arg1
= scm_sym2vcell (proc
, scm_env_top_level (env
), SCM_BOOL_T
);
916 if (SCM_NIMP (SCM_CDR (arg1
)) && (SCM_SNAME (SCM_CDR (arg1
)) == proc
)
917 && (SCM_CDR (arg1
) != x
))
918 scm_warn ("redefining built-in ", SCM_CHARS (proc
));
921 if (5 <= scm_verbose
&& SCM_UNDEFINED
!= SCM_CDR (arg1
))
922 scm_warn ("redefining ", SCM_CHARS (proc
));
924 SCM_SETCDR (arg1
, x
);
926 return scm_cons2 (scm_sym_quote
, SCM_CAR (arg1
), SCM_EOL
);
928 return SCM_UNSPECIFIED
;
931 return scm_cons2 (SCM_IM_DEFINE
, proc
, x
);
937 scm_m_letrec1 (SCM op
, SCM imm
, SCM xorig
, SCM env
)
939 SCM cdrx
= SCM_CDR (xorig
); /* locally mutable version of form */
940 char *what
= SCM_CHARS (SCM_CAR (xorig
));
941 SCM x
= cdrx
, proc
, arg1
; /* structure traversers */
942 SCM vars
= SCM_EOL
, inits
= SCM_EOL
, *initloc
= &inits
;
945 ASRTSYNTAX (scm_ilength (proc
) >= 1, scm_s_bindings
);
948 /* vars scm_list reversed here, inits reversed at evaluation */
949 arg1
= SCM_CAR (proc
);
950 ASRTSYNTAX (2 == scm_ilength (arg1
), scm_s_bindings
);
951 ASRTSYNTAX (SCM_SYMBOLP (SCM_CAR (arg1
)),
953 vars
= scm_cons (SCM_CAR (arg1
), vars
);
954 *initloc
= scm_cons (SCM_CAR (SCM_CDR (arg1
)), SCM_EOL
);
955 initloc
= SCM_CDRLOC (*initloc
);
957 while (SCM_NIMP (proc
= SCM_CDR (proc
)));
959 return scm_cons2 (op
, vars
,
960 scm_cons (inits
, scm_m_body (imm
, SCM_CDR (x
), what
)));
963 SCM_SYNTAX(s_letrec
, "letrec", scm_makmmacro
, scm_m_letrec
);
964 SCM_GLOBAL_SYMBOL(scm_sym_letrec
, s_letrec
);
967 scm_m_letrec (SCM xorig
, SCM env
)
969 SCM x
= SCM_CDR (xorig
);
970 SCM_ASSYNT (scm_ilength (x
) >= 2, xorig
, scm_s_body
, s_letrec
);
972 if (SCM_NULLP (SCM_CAR (x
))) /* null binding, let* faster */
973 return scm_m_letstar (scm_cons2 (SCM_CAR (xorig
), SCM_EOL
,
974 scm_m_body (SCM_IM_LETREC
,
979 return scm_m_letrec1 (SCM_IM_LETREC
, SCM_IM_LETREC
, xorig
, env
);
982 SCM_SYNTAX(s_let
, "let", scm_makmmacro
, scm_m_let
);
983 SCM_GLOBAL_SYMBOL(scm_sym_let
, s_let
);
986 scm_m_let (SCM xorig
, SCM env
)
988 SCM cdrx
= SCM_CDR (xorig
); /* locally mutable version of form */
989 SCM x
= cdrx
, proc
, arg1
, name
; /* structure traversers */
990 SCM vars
= SCM_EOL
, inits
= SCM_EOL
, *varloc
= &vars
, *initloc
= &inits
;
992 SCM_ASSYNT (scm_ilength (x
) >= 2, xorig
, scm_s_body
, s_let
);
996 && SCM_CONSP (SCM_CAR (proc
)) && SCM_NULLP (SCM_CDR (proc
))))
998 /* null or single binding, let* is faster */
999 return scm_m_letstar (scm_cons2 (SCM_CAR (xorig
), proc
,
1000 scm_m_body (SCM_IM_LET
,
1006 SCM_ASSYNT (SCM_NIMP (proc
), xorig
, scm_s_bindings
, s_let
);
1007 if (SCM_CONSP (proc
))
1009 /* plain let, proc is <bindings> */
1010 return scm_m_letrec1 (SCM_IM_LET
, SCM_IM_LET
, xorig
, env
);
1013 if (!SCM_SYMBOLP (proc
))
1014 scm_wta (xorig
, scm_s_bindings
, s_let
); /* bad let */
1015 name
= proc
; /* named let, build equiv letrec */
1017 SCM_ASSYNT (scm_ilength (x
) >= 2, xorig
, scm_s_body
, s_let
);
1018 proc
= SCM_CAR (x
); /* bindings list */
1019 SCM_ASSYNT (scm_ilength (proc
) >= 0, xorig
, scm_s_bindings
, s_let
);
1020 while (SCM_NIMP (proc
))
1021 { /* vars and inits both in order */
1022 arg1
= SCM_CAR (proc
);
1023 SCM_ASSYNT (2 == scm_ilength (arg1
), xorig
, scm_s_bindings
, s_let
);
1024 SCM_ASSYNT (SCM_SYMBOLP (SCM_CAR (arg1
)),
1025 xorig
, scm_s_variable
, s_let
);
1026 *varloc
= scm_cons (SCM_CAR (arg1
), SCM_EOL
);
1027 varloc
= SCM_CDRLOC (*varloc
);
1028 *initloc
= scm_cons (SCM_CAR (SCM_CDR (arg1
)), SCM_EOL
);
1029 initloc
= SCM_CDRLOC (*initloc
);
1030 proc
= SCM_CDR (proc
);
1033 proc
= scm_cons2 (scm_sym_lambda
, vars
,
1034 scm_m_body (SCM_IM_LET
, SCM_CDR (x
), "let"));
1035 proc
= scm_cons2 (scm_sym_let
, scm_cons (scm_cons2 (name
, proc
, SCM_EOL
),
1037 scm_acons (name
, inits
, SCM_EOL
));
1038 return scm_m_letrec1 (SCM_IM_LETREC
, SCM_IM_LET
, proc
, env
);
1042 SCM_SYNTAX (s_atapply
,"@apply", scm_makmmacro
, scm_m_apply
);
1043 SCM_GLOBAL_SYMBOL (scm_sym_atapply
, s_atapply
);
1044 SCM_GLOBAL_SYMBOL (scm_sym_apply
, s_atapply
+ 1);
1047 scm_m_apply (SCM xorig
, SCM env
)
1049 SCM_ASSYNT (scm_ilength (SCM_CDR (xorig
)) == 2,
1050 xorig
, scm_s_expression
, s_atapply
);
1051 return scm_cons (SCM_IM_APPLY
, SCM_CDR (xorig
));
1055 SCM_SYNTAX(s_atcall_cc
,"@call-with-current-continuation", scm_makmmacro
, scm_m_cont
);
1056 SCM_GLOBAL_SYMBOL(scm_sym_atcall_cc
,s_atcall_cc
);
1060 scm_m_cont (SCM xorig
, SCM env
)
1062 SCM_ASSYNT (scm_ilength (SCM_CDR (xorig
)) == 1,
1063 xorig
, scm_s_expression
, s_atcall_cc
);
1064 return scm_cons (SCM_IM_CONT
, SCM_CDR (xorig
));
1067 /* Multi-language support */
1072 SCM_SYNTAX (s_nil_cond
, "nil-cond", scm_makmmacro
, scm_m_nil_cond
);
1075 scm_m_nil_cond (SCM xorig
, SCM env
)
1077 int len
= scm_ilength (SCM_CDR (xorig
));
1078 SCM_ASSYNT (len
>= 1 && (len
& 1) == 1, xorig
,
1079 scm_s_expression
, "nil-cond");
1080 return scm_cons (SCM_IM_NIL_COND
, SCM_CDR (xorig
));
1083 SCM_SYNTAX (s_nil_ify
, "nil-ify", scm_makmmacro
, scm_m_nil_ify
);
1086 scm_m_nil_ify (SCM xorig
, SCM env
)
1088 SCM_ASSYNT (scm_ilength (SCM_CDR (xorig
)) == 1,
1089 xorig
, scm_s_expression
, "nil-ify");
1090 return scm_cons (SCM_IM_NIL_IFY
, SCM_CDR (xorig
));
1093 SCM_SYNTAX (s_t_ify
, "t-ify", scm_makmmacro
, scm_m_t_ify
);
1096 scm_m_t_ify (SCM xorig
, SCM env
)
1098 SCM_ASSYNT (scm_ilength (SCM_CDR (xorig
)) == 1,
1099 xorig
, scm_s_expression
, "t-ify");
1100 return scm_cons (SCM_IM_T_IFY
, SCM_CDR (xorig
));
1103 SCM_SYNTAX (s_0_cond
, "0-cond", scm_makmmacro
, scm_m_0_cond
);
1106 scm_m_0_cond (SCM xorig
, SCM env
)
1108 int len
= scm_ilength (SCM_CDR (xorig
));
1109 SCM_ASSYNT (len
>= 1 && (len
& 1) == 1, xorig
,
1110 scm_s_expression
, "0-cond");
1111 return scm_cons (SCM_IM_0_COND
, SCM_CDR (xorig
));
1114 SCM_SYNTAX (s_0_ify
, "0-ify", scm_makmmacro
, scm_m_0_ify
);
1117 scm_m_0_ify (SCM xorig
, SCM env
)
1119 SCM_ASSYNT (scm_ilength (SCM_CDR (xorig
)) == 1,
1120 xorig
, scm_s_expression
, "0-ify");
1121 return scm_cons (SCM_IM_0_IFY
, SCM_CDR (xorig
));
1124 SCM_SYNTAX (s_1_ify
, "1-ify", scm_makmmacro
, scm_m_1_ify
);
1127 scm_m_1_ify (SCM xorig
, SCM env
)
1129 SCM_ASSYNT (scm_ilength (SCM_CDR (xorig
)) == 1,
1130 xorig
, scm_s_expression
, "1-ify");
1131 return scm_cons (SCM_IM_1_IFY
, SCM_CDR (xorig
));
1134 SCM_SYNTAX (s_atfop
, "@fop", scm_makmmacro
, scm_m_atfop
);
1137 scm_m_atfop (SCM xorig
, SCM env
)
1139 SCM x
= SCM_CDR (xorig
), vcell
;
1140 SCM_ASSYNT (scm_ilength (x
) >= 1, xorig
, scm_s_expression
, "@fop");
1141 vcell
= scm_symbol_fref (SCM_CAR (x
));
1142 SCM_ASSYNT (SCM_CONSP (vcell
), x
,
1143 "Symbol's function definition is void", NULL
);
1144 SCM_SET_CELL_WORD_0 (x
, SCM_UNPACK (vcell
) + scm_tc3_cons_gloc
);
1148 SCM_SYNTAX (s_atbind
, "@bind", scm_makmmacro
, scm_m_atbind
);
1151 scm_m_atbind (SCM xorig
, SCM env
)
1153 SCM x
= SCM_CDR (xorig
);
1154 SCM_ASSYNT (scm_ilength (x
) > 1, xorig
, scm_s_expression
, "@bind");
1160 while (SCM_NIMP (SCM_CDR (env
)))
1161 env
= SCM_CDR (env
);
1162 env
= SCM_CAR (env
);
1163 if (SCM_CONSP (env
))
1168 while (SCM_NIMP (x
))
1170 SCM_SET_CELL_WORD_0 (x
, SCM_UNPACK (scm_sym2vcell (SCM_CAR (x
), env
, SCM_BOOL_T
)) + scm_tc3_cons_gloc
);
1173 return scm_cons (SCM_IM_BIND
, SCM_CDR (xorig
));
1177 scm_m_expand_body (SCM xorig
, SCM env
)
1179 SCM form
, x
= SCM_CDR (xorig
), defs
= SCM_EOL
;
1180 char *what
= SCM_ISYMCHARS (SCM_CAR (xorig
)) + 2;
1182 while (SCM_NIMP (x
))
1185 if (SCM_IMP (form
) || SCM_NCONSP (form
))
1187 if (SCM_IMP (SCM_CAR (form
)))
1189 if (!SCM_SYMBOLP (SCM_CAR (form
)))
1192 form
= scm_macroexp (scm_cons_source (form
,
1197 if (SCM_EQ_P (SCM_IM_DEFINE
, SCM_CAR (form
)))
1199 defs
= scm_cons (SCM_CDR (form
), defs
);
1202 else if (SCM_NIMP(defs
))
1206 else if (SCM_EQ_P (SCM_IM_BEGIN
, SCM_CAR (form
)))
1208 x
= scm_append (scm_cons2 (SCM_CDR (form
), SCM_CDR (x
), SCM_EOL
));
1212 x
= scm_cons (form
, SCM_CDR(x
));
1217 SCM_ASSYNT (SCM_NIMP (x
), SCM_CDR (xorig
), scm_s_body
, what
);
1218 if (SCM_NIMP (defs
))
1220 x
= scm_cons (scm_m_letrec1 (SCM_IM_LETREC
,
1222 scm_cons2 (scm_sym_define
, defs
, x
),
1228 SCM_SETCAR (xorig
, SCM_CAR (x
));
1229 SCM_SETCDR (xorig
, SCM_CDR (x
));
1236 scm_macroexp (SCM x
, SCM env
)
1240 /* Don't bother to produce error messages here. We get them when we
1241 eventually execute the code for real. */
1244 if (!SCM_SYMBOLP (SCM_CAR (x
)))
1249 SCM
*proc_ptr
= scm_lookupcar1 (x
, env
, 0);
1250 if (proc_ptr
== NULL
)
1252 /* We have lost the race. */
1258 proc
= *scm_lookupcar (x
, env
, 0);
1261 /* Only handle memoizing macros. `Acros' and `macros' are really
1262 special forms and should not be evaluated here. */
1265 || scm_tc16_macro
!= SCM_TYP16 (proc
)
1266 || (int) (SCM_UNPACK_CAR (proc
) >> 16) != 2)
1270 res
= scm_apply (SCM_CDR (proc
), x
, scm_cons (env
, scm_listofnull
));
1272 if (scm_ilength (res
) <= 0)
1273 res
= scm_cons2 (SCM_IM_BEGIN
, res
, SCM_EOL
);
1276 SCM_SETCAR (x
, SCM_CAR (res
));
1277 SCM_SETCDR (x
, SCM_CDR (res
));
1283 /* scm_unmemocopy takes a memoized expression together with its
1284 * environment and rewrites it to its original form. Thus, it is the
1285 * inversion of the rewrite rules above. The procedure is not
1286 * optimized for speed. It's used in scm_iprin1 when printing the
1287 * code of a closure, in scm_procedure_source, in display_frame when
1288 * generating the source for a stackframe in a backtrace, and in
1289 * display_expression.
1292 /* We should introduce an anti-macro interface so that it is possible
1293 * to plug in transformers in both directions from other compilation
1294 * units. unmemocopy could then dispatch to anti-macro transformers.
1295 * (Those transformers could perhaps be written in slightly more
1296 * readable style... :)
1299 #define SCM_BIT8(x) (127 & SCM_UNPACK (x))
1302 unmemocopy (SCM x
, SCM env
)
1305 #ifdef DEBUG_EXTENSIONS
1308 if (SCM_NCELLP (x
) || SCM_NECONSP (x
))
1310 #ifdef DEBUG_EXTENSIONS
1311 p
= scm_whash_lookup (scm_source_whash
, x
);
1313 switch (SCM_TYP7 (x
))
1315 case SCM_BIT8(SCM_IM_AND
):
1316 ls
= z
= scm_cons (scm_sym_and
, SCM_UNSPECIFIED
);
1318 case SCM_BIT8(SCM_IM_BEGIN
):
1319 ls
= z
= scm_cons (scm_sym_begin
, SCM_UNSPECIFIED
);
1321 case SCM_BIT8(SCM_IM_CASE
):
1322 ls
= z
= scm_cons (scm_sym_case
, SCM_UNSPECIFIED
);
1324 case SCM_BIT8(SCM_IM_COND
):
1325 ls
= z
= scm_cons (scm_sym_cond
, SCM_UNSPECIFIED
);
1327 case SCM_BIT8(SCM_IM_DO
):
1328 ls
= scm_cons (scm_sym_do
, SCM_UNSPECIFIED
);
1330 case SCM_BIT8(SCM_IM_IF
):
1331 ls
= z
= scm_cons (scm_sym_if
, SCM_UNSPECIFIED
);
1333 case SCM_BIT8(SCM_IM_LET
):
1334 ls
= scm_cons (scm_sym_let
, SCM_UNSPECIFIED
);
1336 case SCM_BIT8(SCM_IM_LETREC
):
1339 ls
= scm_cons (scm_sym_letrec
, SCM_UNSPECIFIED
);
1343 f
= v
= SCM_CAR (x
);
1345 z
= EXTEND_ENV (f
, SCM_EOL
, env
);
1347 e
= scm_reverse (unmemocopy (SCM_CAR (x
),
1348 SCM_EQ_P (SCM_CAR (ls
), scm_sym_letrec
) ? z
: env
));
1351 s
= SCM_EQ_P (SCM_CAR (ls
), scm_sym_do
)
1352 ? scm_reverse (unmemocopy (SCM_CDR (SCM_CDR (SCM_CDR (x
))), env
))
1354 /* build transformed binding list */
1358 z
= scm_acons (SCM_CAR (v
),
1359 scm_cons (SCM_CAR (e
),
1360 SCM_EQ_P (SCM_CAR (s
), SCM_CAR (v
))
1362 : scm_cons (SCM_CAR (s
), SCM_EOL
)),
1368 while (SCM_NIMP (v
));
1369 z
= scm_cons (z
, SCM_UNSPECIFIED
);
1371 if (SCM_EQ_P (SCM_CAR (ls
), scm_sym_do
))
1375 SCM_SETCDR (z
, scm_cons (unmemocopy (SCM_CAR (x
), env
),
1378 x
= (SCM
) (SCM_CARLOC (SCM_CDR (x
)) - 1);
1379 /* body forms are now to be found in SCM_CDR (x)
1380 (this is how *real* code look like! :) */
1384 case SCM_BIT8(SCM_IM_LETSTAR
):
1392 env
= EXTEND_ENV (SCM_EOL
, SCM_EOL
, env
);
1395 y
= z
= scm_acons (SCM_CAR (b
),
1397 scm_cons (unmemocopy (SCM_CAR (SCM_CDR (b
)), env
), SCM_EOL
), env
),
1399 env
= EXTEND_ENV (SCM_CAR (b
), SCM_BOOL_F
, env
);
1400 b
= SCM_CDR (SCM_CDR (b
));
1403 SCM_SETCDR (y
, SCM_EOL
);
1404 ls
= scm_cons (scm_sym_let
, z
= scm_cons (y
, SCM_UNSPECIFIED
));
1409 SCM_SETCDR (z
, scm_acons (SCM_CAR (b
),
1411 scm_cons (unmemocopy (SCM_CAR (SCM_CDR (b
)), env
), SCM_EOL
), env
),
1414 env
= EXTEND_ENV (SCM_CAR (b
), SCM_BOOL_F
, env
);
1415 b
= SCM_CDR (SCM_CDR (b
));
1417 while (SCM_NIMP (b
));
1418 SCM_SETCDR (z
, SCM_EOL
);
1420 ls
= scm_cons (scm_sym_letstar
, z
= scm_cons (y
, SCM_UNSPECIFIED
));
1423 case SCM_BIT8(SCM_IM_OR
):
1424 ls
= z
= scm_cons (scm_sym_or
, SCM_UNSPECIFIED
);
1426 case SCM_BIT8(SCM_IM_LAMBDA
):
1428 ls
= scm_cons (scm_sym_lambda
,
1429 z
= scm_cons (SCM_CAR (x
), SCM_UNSPECIFIED
));
1430 env
= EXTEND_ENV (SCM_CAR (x
), SCM_EOL
, env
);
1432 case SCM_BIT8(SCM_IM_QUOTE
):
1433 ls
= z
= scm_cons (scm_sym_quote
, SCM_UNSPECIFIED
);
1435 case SCM_BIT8(SCM_IM_SET_X
):
1436 ls
= z
= scm_cons (scm_sym_set_x
, SCM_UNSPECIFIED
);
1438 case SCM_BIT8(SCM_IM_DEFINE
):
1442 ls
= scm_cons (scm_sym_define
,
1443 z
= scm_cons (n
= SCM_CAR (x
), SCM_UNSPECIFIED
));
1444 if (SCM_NNULLP (env
))
1445 SCM_SETCAR (SCM_CAR (env
), scm_cons (n
, SCM_CAR (SCM_CAR (env
))));
1448 case SCM_BIT8(SCM_MAKISYM (0)):
1452 switch (SCM_ISYMNUM (z
))
1454 case (SCM_ISYMNUM (SCM_IM_APPLY
)):
1455 ls
= z
= scm_cons (scm_sym_atapply
, SCM_UNSPECIFIED
);
1457 case (SCM_ISYMNUM (SCM_IM_CONT
)):
1458 ls
= z
= scm_cons (scm_sym_atcall_cc
, SCM_UNSPECIFIED
);
1460 case (SCM_ISYMNUM (SCM_IM_DELAY
)):
1461 ls
= z
= scm_cons (scm_sym_delay
, SCM_UNSPECIFIED
);
1465 /* appease the Sun compiler god: */ ;
1469 ls
= z
= unmemocar (scm_cons (unmemocopy (SCM_CAR (x
), env
),
1474 while (SCM_CELLP (x
= SCM_CDR (x
)) && SCM_ECONSP (x
))
1476 if (SCM_ISYMP (SCM_CAR (x
)))
1477 /* skip body markers */
1479 SCM_SETCDR (z
, unmemocar (scm_cons (unmemocopy (SCM_CAR (x
), env
),
1485 #ifdef DEBUG_EXTENSIONS
1486 if (SCM_NFALSEP (p
))
1487 scm_whash_insert (scm_source_whash
, ls
, p
);
1494 scm_unmemocopy (SCM x
, SCM env
)
1496 if (SCM_NNULLP (env
))
1497 /* Make a copy of the lowest frame to protect it from
1498 modifications by SCM_IM_DEFINE */
1499 return unmemocopy (x
, scm_cons (SCM_CAR (env
), SCM_CDR (env
)));
1501 return unmemocopy (x
, env
);
1504 #ifndef SCM_RECKLESS
1507 scm_badargsp (SCM formals
, SCM args
)
1509 while (SCM_NIMP (formals
))
1511 if (SCM_NCONSP (formals
))
1515 formals
= SCM_CDR (formals
);
1516 args
= SCM_CDR (args
);
1518 return SCM_NNULLP (args
) ? 1 : 0;
1525 scm_eval_args (SCM l
, SCM env
, SCM proc
)
1527 SCM results
= SCM_EOL
, *lloc
= &results
, res
;
1528 while (SCM_NIMP (l
))
1533 if (SCM_IMP (SCM_CAR (l
)))
1534 res
= SCM_EVALIM (SCM_CAR (l
), env
);
1536 res
= EVALCELLCAR (l
, env
);
1538 else if (SCM_TYP3 (l
) == scm_tc3_cons_gloc
)
1540 scm_bits_t vcell
= SCM_STRUCT_VTABLE_DATA (l
) [scm_vtable_index_vcell
];
1542 res
= SCM_CAR (l
); /* struct planted in code */
1544 res
= SCM_PACK (vcell
);
1549 res
= EVALCAR (l
, env
);
1551 *lloc
= scm_cons (res
, SCM_EOL
);
1552 lloc
= SCM_CDRLOC (*lloc
);
1559 scm_wrong_num_args (proc
);
1566 scm_eval_body (SCM code
, SCM env
)
1571 while (SCM_NNULLP (next
= SCM_CDR (next
)))
1573 if (SCM_IMP (SCM_CAR (code
)))
1575 if (SCM_ISYMP (SCM_CAR (code
)))
1577 code
= scm_m_expand_body (code
, env
);
1582 SCM_XEVAL (SCM_CAR (code
), env
);
1585 return SCM_XEVALCAR (code
, env
);
1592 /* SECTION: This code is specific for the debugging support. One
1593 * branch is read when DEVAL isn't defined, the other when DEVAL is
1599 #define SCM_APPLY scm_apply
1600 #define PREP_APPLY(proc, args)
1602 #define RETURN(x) return x;
1603 #ifdef STACK_CHECKING
1604 #ifndef NO_CEVAL_STACK_CHECKING
1605 #define EVAL_STACK_CHECKING
1612 #define SCM_CEVAL scm_deval /* Substitute all uses of scm_ceval */
1614 #define SCM_APPLY scm_dapply
1616 #define PREP_APPLY(p, l) \
1617 { ++debug.info; debug.info->a.proc = p; debug.info->a.args = l; }
1619 #define ENTER_APPLY \
1621 SCM_SET_ARGSREADY (debug);\
1622 if (CHECK_APPLY && SCM_TRAPS_P)\
1623 if (SCM_APPLY_FRAME_P || (SCM_TRACE_P && PROCTRACEP (proc)))\
1625 SCM tmp, tail = SCM_BOOL(SCM_TRACED_FRAME_P (debug)); \
1626 SCM_SET_TRACED_FRAME (debug); \
1627 if (SCM_CHEAPTRAPS_P)\
1629 tmp = scm_make_debugobj (&debug);\
1630 scm_ithrow (scm_sym_apply_frame, scm_cons2 (tmp, tail, SCM_EOL), 0);\
1634 scm_make_cont (&tmp);\
1635 if (!setjmp (SCM_JMPBUF (tmp)))\
1636 scm_ithrow (scm_sym_apply_frame, scm_cons2 (tmp, tail, SCM_EOL), 0);\
1641 #define RETURN(e) {proc = (e); goto exit;}
1642 #ifdef STACK_CHECKING
1643 #ifndef EVAL_STACK_CHECKING
1644 #define EVAL_STACK_CHECKING
1648 /* scm_ceval_ptr points to the currently selected evaluator.
1649 * *fixme*: Although efficiency is important here, this state variable
1650 * should probably not be a global. It should be related to the
1655 SCM (*scm_ceval_ptr
) (SCM x
, SCM env
);
1657 /* scm_last_debug_frame contains a pointer to the last debugging
1658 * information stack frame. It is accessed very often from the
1659 * debugging evaluator, so it should probably not be indirectly
1660 * addressed. Better to save and restore it from the current root at
1665 scm_debug_frame
*scm_last_debug_frame
;
1668 /* scm_debug_eframe_size is the number of slots available for pseudo
1669 * stack frames at each real stack frame.
1672 int scm_debug_eframe_size
;
1674 int scm_debug_mode
, scm_check_entry_p
, scm_check_apply_p
, scm_check_exit_p
;
1678 scm_option scm_eval_opts
[] = {
1679 { SCM_OPTION_INTEGER
, "stack", 22000, "Size of thread stacks (in machine words)." }
1682 scm_option scm_debug_opts
[] = {
1683 { SCM_OPTION_BOOLEAN
, "cheap", 1,
1684 "*Flyweight representation of the stack at traps." },
1685 { SCM_OPTION_BOOLEAN
, "breakpoints", 0, "*Check for breakpoints." },
1686 { SCM_OPTION_BOOLEAN
, "trace", 0, "*Trace mode." },
1687 { SCM_OPTION_BOOLEAN
, "procnames", 1,
1688 "Record procedure names at definition." },
1689 { SCM_OPTION_BOOLEAN
, "backwards", 0,
1690 "Display backtrace in anti-chronological order." },
1691 { SCM_OPTION_INTEGER
, "width", 79, "Maximal width of backtrace." },
1692 { SCM_OPTION_INTEGER
, "indent", 10, "Maximal indentation in backtrace." },
1693 { SCM_OPTION_INTEGER
, "frames", 3,
1694 "Maximum number of tail-recursive frames in backtrace." },
1695 { SCM_OPTION_INTEGER
, "maxdepth", 1000,
1696 "Maximal number of stored backtrace frames." },
1697 { SCM_OPTION_INTEGER
, "depth", 20, "Maximal length of printed backtrace." },
1698 { SCM_OPTION_BOOLEAN
, "backtrace", 0, "Show backtrace on error." },
1699 { SCM_OPTION_BOOLEAN
, "debug", 0, "Use the debugging evaluator." },
1700 { SCM_OPTION_INTEGER
, "stack", 20000, "Stack size limit (measured in words; 0 = no check)." }
1703 scm_option scm_evaluator_trap_table
[] = {
1704 { SCM_OPTION_BOOLEAN
, "traps", 0, "Enable evaluator traps." },
1705 { SCM_OPTION_BOOLEAN
, "enter-frame", 0, "Trap when eval enters new frame." },
1706 { SCM_OPTION_BOOLEAN
, "apply-frame", 0, "Trap when entering apply." },
1707 { SCM_OPTION_BOOLEAN
, "exit-frame", 0, "Trap when exiting eval or apply." }
1710 SCM_DEFINE (scm_eval_options_interface
, "eval-options-interface", 0, 1, 0,
1713 #define FUNC_NAME s_scm_eval_options_interface
1717 ans
= scm_options (setting
,
1721 scm_eval_stack
= SCM_EVAL_STACK
* sizeof (void *);
1727 SCM_DEFINE (scm_evaluator_traps
, "evaluator-traps-interface", 0, 1, 0,
1730 #define FUNC_NAME s_scm_evaluator_traps
1734 ans
= scm_options (setting
,
1735 scm_evaluator_trap_table
,
1736 SCM_N_EVALUATOR_TRAPS
,
1738 SCM_RESET_DEBUG_MODE
;
1745 scm_deval_args (SCM l
, SCM env
, SCM proc
, SCM
*lloc
)
1747 SCM
*results
= lloc
, res
;
1748 while (SCM_NIMP (l
))
1753 if (SCM_IMP (SCM_CAR (l
)))
1754 res
= SCM_EVALIM (SCM_CAR (l
), env
);
1756 res
= EVALCELLCAR (l
, env
);
1758 else if (SCM_TYP3 (l
) == scm_tc3_cons_gloc
)
1760 scm_bits_t vcell
= SCM_STRUCT_VTABLE_DATA (l
) [scm_vtable_index_vcell
];
1762 res
= SCM_CAR (l
); /* struct planted in code */
1764 res
= SCM_PACK (vcell
);
1769 res
= EVALCAR (l
, env
);
1771 *lloc
= scm_cons (res
, SCM_EOL
);
1772 lloc
= SCM_CDRLOC (*lloc
);
1779 scm_wrong_num_args (proc
);
1788 /* SECTION: Some local definitions for the evaluator.
1792 #define CHECK_EQVISH(A,B) (SCM_EQ_P ((A), (B)) || (SCM_NFALSEP (scm_eqv_p ((A), (B)))))
1795 #define BUILTIN_RPASUBR /* Handle rpsubrs and asubrs without calling apply */
1797 /* SECTION: This is the evaluator. Like any real monster, it has
1798 * three heads. This code is compiled twice.
1804 scm_ceval (SCM x
, SCM env
)
1810 scm_deval (SCM x
, SCM env
)
1815 SCM_CEVAL (SCM x
, SCM env
)
1824 scm_debug_frame debug
;
1825 scm_debug_info
*debug_info_end
;
1826 debug
.prev
= scm_last_debug_frame
;
1827 debug
.status
= scm_debug_eframe_size
;
1829 * The debug.vect contains twice as much scm_debug_info frames as the
1830 * user has specified with (debug-set! frames <n>).
1832 * Even frames are eval frames, odd frames are apply frames.
1834 debug
.vect
= (scm_debug_info
*) alloca (scm_debug_eframe_size
1835 * sizeof (debug
.vect
[0]));
1836 debug
.info
= debug
.vect
;
1837 debug_info_end
= debug
.vect
+ scm_debug_eframe_size
;
1838 scm_last_debug_frame
= &debug
;
1840 #ifdef EVAL_STACK_CHECKING
1841 if (scm_stack_checking_enabled_p
1842 && SCM_STACK_OVERFLOW_P ((SCM_STACKITEM
*) &proc
))
1845 debug
.info
->e
.exp
= x
;
1846 debug
.info
->e
.env
= env
;
1848 scm_report_stack_overflow ();
1855 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
1858 SCM_CLEAR_ARGSREADY (debug
);
1859 if (SCM_OVERFLOWP (debug
))
1862 * In theory, this should be the only place where it is necessary to
1863 * check for space in debug.vect since both eval frames and
1864 * available space are even.
1866 * For this to be the case, however, it is necessary that primitive
1867 * special forms which jump back to `loop', `begin' or some similar
1868 * label call PREP_APPLY. A convenient way to do this is to jump to
1869 * `loopnoap' or `cdrxnoap'.
1871 else if (++debug
.info
>= debug_info_end
)
1873 SCM_SET_OVERFLOW (debug
);
1877 debug
.info
->e
.exp
= x
;
1878 debug
.info
->e
.env
= env
;
1879 if (CHECK_ENTRY
&& SCM_TRAPS_P
)
1880 if (SCM_ENTER_FRAME_P
|| (SCM_BREAKPOINTS_P
&& SRCBRKP (x
)))
1882 SCM tail
= SCM_BOOL(SCM_TAILRECP (debug
));
1883 SCM_SET_TAILREC (debug
);
1884 if (SCM_CHEAPTRAPS_P
)
1885 t
.arg1
= scm_make_debugobj (&debug
);
1888 scm_make_cont (&t
.arg1
);
1889 if (setjmp (SCM_JMPBUF (t
.arg1
)))
1891 x
= SCM_THROW_VALUE (t
.arg1
);
1897 /* This gives the possibility for the debugger to
1898 modify the source expression before evaluation. */
1902 scm_ithrow (scm_sym_enter_frame
,
1903 scm_cons2 (t
.arg1
, tail
,
1904 scm_cons (scm_unmemocopy (x
, env
), SCM_EOL
)),
1908 #if defined (USE_THREADS) || defined (DEVAL)
1912 switch (SCM_TYP7 (x
))
1914 case scm_tcs_symbols
:
1915 /* Only happens when called at top level.
1917 x
= scm_cons (x
, SCM_UNDEFINED
);
1920 case SCM_BIT8(SCM_IM_AND
):
1923 while (SCM_NNULLP (t
.arg1
= SCM_CDR (t
.arg1
)))
1924 if (SCM_FALSEP (EVALCAR (x
, env
)))
1926 RETURN (SCM_BOOL_F
);
1930 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
1933 case SCM_BIT8(SCM_IM_BEGIN
):
1935 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
1941 while (SCM_NNULLP (t
.arg1
= SCM_CDR (t
.arg1
)))
1943 if (SCM_IMP (SCM_CAR (x
)))
1945 if (SCM_ISYMP (SCM_CAR (x
)))
1947 x
= scm_m_expand_body (x
, env
);
1952 SCM_CEVAL (SCM_CAR (x
), env
);
1956 carloop
: /* scm_eval car of last form in list */
1957 if (SCM_NCELLP (SCM_CAR (x
)))
1960 RETURN (SCM_IMP (x
) ? SCM_EVALIM (x
, env
) : SCM_GLOC_VAL (x
))
1963 if (SCM_SYMBOLP (SCM_CAR (x
)))
1966 RETURN (*scm_lookupcar (x
, env
, 1))
1970 goto loop
; /* tail recurse */
1973 case SCM_BIT8(SCM_IM_CASE
):
1975 t
.arg1
= EVALCAR (x
, env
);
1976 while (SCM_NIMP (x
= SCM_CDR (x
)))
1979 if (SCM_EQ_P (scm_sym_else
, SCM_CAR (proc
)))
1982 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
1985 proc
= SCM_CAR (proc
);
1986 while (SCM_NIMP (proc
))
1988 if (CHECK_EQVISH (SCM_CAR (proc
), t
.arg1
))
1990 x
= SCM_CDR (SCM_CAR (x
));
1991 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
1994 proc
= SCM_CDR (proc
);
1997 RETURN (SCM_UNSPECIFIED
)
2000 case SCM_BIT8(SCM_IM_COND
):
2001 while (SCM_NIMP (x
= SCM_CDR (x
)))
2004 t
.arg1
= EVALCAR (proc
, env
);
2005 if (SCM_NFALSEP (t
.arg1
))
2012 if (! SCM_EQ_P (scm_sym_arrow
, SCM_CAR (x
)))
2014 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
2018 proc
= EVALCAR (proc
, env
);
2019 SCM_ASRTGO (SCM_NIMP (proc
), badfun
);
2020 PREP_APPLY (proc
, scm_cons (t
.arg1
, SCM_EOL
));
2025 RETURN (SCM_UNSPECIFIED
)
2028 case SCM_BIT8(SCM_IM_DO
):
2030 proc
= SCM_CAR (SCM_CDR (x
)); /* inits */
2031 t
.arg1
= SCM_EOL
; /* values */
2032 while (SCM_NIMP (proc
))
2034 t
.arg1
= scm_cons (EVALCAR (proc
, env
), t
.arg1
);
2035 proc
= SCM_CDR (proc
);
2037 env
= EXTEND_ENV (SCM_CAR (x
), t
.arg1
, env
);
2038 x
= SCM_CDR (SCM_CDR (x
));
2039 while (proc
= SCM_CAR (x
), SCM_FALSEP (EVALCAR (proc
, env
)))
2041 for (proc
= SCM_CADR (x
); SCM_NIMP (proc
); proc
= SCM_CDR (proc
))
2043 t
.arg1
= SCM_CAR (proc
); /* body */
2044 SIDEVAL (t
.arg1
, env
);
2046 for (t
.arg1
= SCM_EOL
, proc
= SCM_CDDR (x
);
2048 proc
= SCM_CDR (proc
))
2049 t
.arg1
= scm_cons (EVALCAR (proc
, env
), t
.arg1
); /* steps */
2050 env
= EXTEND_ENV (SCM_CAR (SCM_CAR (env
)), t
.arg1
, SCM_CDR (env
));
2054 RETURN (SCM_UNSPECIFIED
);
2055 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
2059 case SCM_BIT8(SCM_IM_IF
):
2061 if (SCM_NFALSEP (EVALCAR (x
, env
)))
2063 else if (SCM_IMP (x
= SCM_CDR (SCM_CDR (x
))))
2065 RETURN (SCM_UNSPECIFIED
);
2067 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
2071 case SCM_BIT8(SCM_IM_LET
):
2073 proc
= SCM_CAR (SCM_CDR (x
));
2077 t
.arg1
= scm_cons (EVALCAR (proc
, env
), t
.arg1
);
2079 while (SCM_NIMP (proc
= SCM_CDR (proc
)));
2080 env
= EXTEND_ENV (SCM_CAR (x
), t
.arg1
, env
);
2085 case SCM_BIT8(SCM_IM_LETREC
):
2087 env
= EXTEND_ENV (SCM_CAR (x
), scm_undefineds
, env
);
2093 t
.arg1
= scm_cons (EVALCAR (proc
, env
), t
.arg1
);
2095 while (SCM_NIMP (proc
= SCM_CDR (proc
)));
2096 SCM_SETCDR (SCM_CAR (env
), t
.arg1
);
2100 case SCM_BIT8(SCM_IM_LETSTAR
):
2105 env
= EXTEND_ENV (SCM_EOL
, SCM_EOL
, env
);
2110 t
.arg1
= SCM_CAR (proc
);
2111 proc
= SCM_CDR (proc
);
2112 env
= EXTEND_ENV (t
.arg1
, EVALCAR (proc
, env
), env
);
2114 while (SCM_NIMP (proc
= SCM_CDR (proc
)));
2117 case SCM_BIT8(SCM_IM_OR
):
2120 while (SCM_NNULLP (t
.arg1
= SCM_CDR (t
.arg1
)))
2122 x
= EVALCAR (x
, env
);
2123 if (SCM_NFALSEP (x
))
2129 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
2133 case SCM_BIT8(SCM_IM_LAMBDA
):
2134 RETURN (scm_closure (SCM_CDR (x
), env
));
2137 case SCM_BIT8(SCM_IM_QUOTE
):
2138 RETURN (SCM_CAR (SCM_CDR (x
)));
2141 case SCM_BIT8(SCM_IM_SET_X
):
2144 switch (SCM_ITAG3 (proc
))
2147 t
.lloc
= scm_lookupcar (x
, env
, 1);
2149 case scm_tc3_cons_gloc
:
2150 t
.lloc
= SCM_GLOC_VAL_LOC (proc
);
2152 #ifdef MEMOIZE_LOCALS
2154 t
.lloc
= scm_ilookup (proc
, env
);
2159 *t
.lloc
= EVALCAR (x
, env
);
2163 RETURN (SCM_UNSPECIFIED
);
2167 case SCM_BIT8(SCM_IM_DEFINE
): /* only for internal defines */
2168 scm_misc_error (NULL
, "Bad define placement", SCM_EOL
);
2170 /* new syntactic forms go here. */
2171 case SCM_BIT8(SCM_MAKISYM (0)):
2173 SCM_ASRTGO (SCM_ISYMP (proc
), badfun
);
2174 switch SCM_ISYMNUM (proc
)
2177 case (SCM_ISYMNUM (IM_VREF
)):
2180 var
= SCM_CAR (SCM_CDR (x
));
2181 RETURN (SCM_CDR(var
));
2183 case (SCM_ISYMNUM (IM_VSET
)):
2184 SCM_CDR (SCM_CAR ( SCM_CDR (x
))) = EVALCAR( SCM_CDR ( SCM_CDR (x
)), env
);
2185 SCM_CAR (SCM_CAR ( SCM_CDR (x
))) = scm_tc16_variable
;
2186 RETURN (SCM_UNSPECIFIED
)
2189 case (SCM_ISYMNUM (SCM_IM_APPLY
)):
2191 proc
= EVALCAR (proc
, env
);
2192 SCM_ASRTGO (SCM_NIMP (proc
), badfun
);
2193 if (SCM_CLOSUREP (proc
))
2196 PREP_APPLY (proc
, SCM_EOL
);
2197 t
.arg1
= SCM_CDR (SCM_CDR (x
));
2198 t
.arg1
= EVALCAR (t
.arg1
, env
);
2200 debug
.info
->a
.args
= t
.arg1
;
2202 #ifndef SCM_RECKLESS
2203 if (scm_badargsp (SCM_CAR (SCM_CODE (proc
)), t
.arg1
))
2207 /* Copy argument list */
2208 if (SCM_IMP (t
.arg1
))
2212 argl
= tl
= scm_cons (SCM_CAR (t
.arg1
), SCM_UNSPECIFIED
);
2213 while (SCM_NIMP (t
.arg1
= SCM_CDR (t
.arg1
))
2214 && SCM_CONSP (t
.arg1
))
2216 SCM_SETCDR (tl
, scm_cons (SCM_CAR (t
.arg1
),
2220 SCM_SETCDR (tl
, t
.arg1
);
2223 env
= EXTEND_ENV (SCM_CAR (SCM_CODE (proc
)), argl
, SCM_ENV (proc
));
2224 x
= SCM_CODE (proc
);
2230 case (SCM_ISYMNUM (SCM_IM_CONT
)):
2231 scm_make_cont (&t
.arg1
);
2232 if (setjmp (SCM_JMPBUF (t
.arg1
)))
2235 val
= SCM_THROW_VALUE (t
.arg1
);
2239 proc
= evalcar (proc
, env
);
2240 SCM_ASRTGO (SCM_NIMP (proc
), badfun
);
2241 PREP_APPLY (proc
, scm_cons (t
.arg1
, SCM_EOL
));
2245 case (SCM_ISYMNUM (SCM_IM_DELAY
)):
2246 RETURN (scm_makprom (scm_closure (SCM_CDR (x
), env
)))
2248 case (SCM_ISYMNUM (SCM_IM_DISPATCH
)):
2249 proc
= SCM_CADR (x
); /* unevaluated operands */
2250 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
2252 arg2
= *scm_ilookup (proc
, env
);
2253 else if (SCM_NCONSP (proc
))
2255 if (SCM_NCELLP (proc
))
2256 arg2
= SCM_GLOC_VAL (proc
);
2258 arg2
= *scm_lookupcar (SCM_CDR (x
), env
, 1);
2262 arg2
= scm_cons (EVALCAR (proc
, env
), SCM_EOL
);
2263 t
.lloc
= SCM_CDRLOC (arg2
);
2264 while (SCM_NIMP (proc
= SCM_CDR (proc
)))
2266 *t
.lloc
= scm_cons (EVALCAR (proc
, env
), SCM_EOL
);
2267 t
.lloc
= SCM_CDRLOC (*t
.lloc
);
2272 /* The type dispatch code is duplicated here
2273 * (c.f. objects.c:scm_mcache_compute_cmethod) since that
2274 * cuts down execution time for type dispatch to 50%.
2277 int i
, n
, end
, mask
;
2278 SCM z
= SCM_CDDR (x
);
2279 n
= SCM_INUM (SCM_CAR (z
)); /* maximum number of specializers */
2280 proc
= SCM_CADR (z
);
2282 if (SCM_NIMP (proc
))
2284 /* Prepare for linear search */
2287 end
= SCM_LENGTH (proc
);
2291 /* Compute a hash value */
2292 int hashset
= SCM_INUM (proc
);
2294 mask
= SCM_INUM (SCM_CAR (z
= SCM_CDDR (z
)));
2295 proc
= SCM_CADR (z
);
2298 if (SCM_NIMP (t
.arg1
))
2301 i
+= SCM_STRUCT_DATA (scm_class_of (SCM_CAR (t
.arg1
)))
2302 [scm_si_hashsets
+ hashset
];
2303 t
.arg1
= SCM_CDR (t
.arg1
);
2305 while (--j
&& SCM_NIMP (t
.arg1
));
2310 /* Search for match */
2314 z
= SCM_VELTS (proc
)[i
];
2315 t
.arg1
= arg2
; /* list of arguments */
2316 if (SCM_NIMP (t
.arg1
))
2319 /* More arguments than specifiers => CLASS != ENV */
2320 if (! SCM_EQ_P (scm_class_of (SCM_CAR (t
.arg1
)), SCM_CAR (z
)))
2322 t
.arg1
= SCM_CDR (t
.arg1
);
2325 while (--j
&& SCM_NIMP (t
.arg1
));
2326 /* Fewer arguments than specifiers => CAR != ENV */
2327 if (!(SCM_IMP (SCM_CAR (z
)) || SCM_CONSP (SCM_CAR (z
))))
2330 env
= EXTEND_ENV (SCM_CAR (SCM_CMETHOD_CODE (z
)),
2332 SCM_CMETHOD_ENV (z
));
2333 x
= SCM_CMETHOD_CODE (z
);
2339 z
= scm_memoize_method (x
, arg2
);
2343 case (SCM_ISYMNUM (SCM_IM_SLOT_REF
)):
2345 t
.arg1
= EVALCAR (x
, env
);
2346 RETURN (SCM_PACK (SCM_STRUCT_DATA (t
.arg1
) [SCM_INUM (SCM_CADR (x
))]))
2348 case (SCM_ISYMNUM (SCM_IM_SLOT_SET_X
)):
2350 t
.arg1
= EVALCAR (x
, env
);
2353 SCM_STRUCT_DATA (t
.arg1
) [SCM_INUM (SCM_CAR (x
))]
2354 = SCM_UNPACK (EVALCAR (proc
, env
));
2355 RETURN (SCM_UNSPECIFIED
)
2357 case (SCM_ISYMNUM (SCM_IM_NIL_COND
)):
2359 while (SCM_NIMP (x
= SCM_CDR (proc
)))
2361 if (!(SCM_FALSEP (t
.arg1
= EVALCAR (proc
, env
))
2362 || SCM_EQ_P (t
.arg1
, scm_lisp_nil
)))
2364 if (SCM_EQ_P (SCM_CAR (x
), SCM_UNSPECIFIED
))
2366 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
2372 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
2375 case (SCM_ISYMNUM (SCM_IM_NIL_IFY
)):
2377 RETURN ((SCM_FALSEP (proc
= EVALCAR (x
, env
)) || SCM_NULLP (proc
))
2381 case (SCM_ISYMNUM (SCM_IM_T_IFY
)):
2383 RETURN (SCM_NFALSEP (EVALCAR (x
, env
)) ? scm_lisp_t
: scm_lisp_nil
)
2385 case (SCM_ISYMNUM (SCM_IM_0_COND
)):
2387 while (SCM_NIMP (x
= SCM_CDR (proc
)))
2389 if (!(SCM_FALSEP (t
.arg1
= EVALCAR (proc
, env
))
2390 || SCM_EQ_P (t
.arg1
, SCM_INUM0
)))
2392 if (SCM_EQ_P (SCM_CAR (x
), SCM_UNSPECIFIED
))
2394 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
2400 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
2403 case (SCM_ISYMNUM (SCM_IM_0_IFY
)):
2405 RETURN (SCM_FALSEP (proc
= EVALCAR (x
, env
))
2409 case (SCM_ISYMNUM (SCM_IM_1_IFY
)):
2411 RETURN (SCM_NFALSEP (EVALCAR (x
, env
))
2415 case (SCM_ISYMNUM (SCM_IM_BIND
)):
2418 t
.arg1
= SCM_CAR (x
);
2419 arg2
= SCM_CDAR (env
);
2420 while (SCM_NIMP (arg2
))
2422 proc
= SCM_GLOC_VAL (SCM_CAR (t
.arg1
));
2423 SCM_SETCDR (SCM_PACK (SCM_UNPACK (SCM_CAR (t
.arg1
)) - 1L),
2425 SCM_SETCAR (arg2
, proc
);
2426 t
.arg1
= SCM_CDR (t
.arg1
);
2427 arg2
= SCM_CDR (arg2
);
2429 t
.arg1
= SCM_CAR (x
);
2430 scm_dynwinds
= scm_acons (t
.arg1
, SCM_CDAR (env
), scm_dynwinds
);
2432 arg2
= x
= SCM_CDR (x
);
2433 while (SCM_NNULLP (arg2
= SCM_CDR (arg2
)))
2435 SIDEVAL (SCM_CAR (x
), env
);
2438 proc
= EVALCAR (x
, env
);
2440 scm_dynwinds
= SCM_CDR (scm_dynwinds
);
2441 arg2
= SCM_CDAR (env
);
2442 while (SCM_NIMP (arg2
))
2444 SCM_SETCDR (SCM_PACK (SCM_UNPACK (SCM_CAR (t
.arg1
)) - 1L),
2446 t
.arg1
= SCM_CDR (t
.arg1
);
2447 arg2
= SCM_CDR (arg2
);
2459 /* scm_everr (x, env,...) */
2460 scm_misc_error (NULL
,
2461 "Wrong type to apply: ~S",
2462 scm_listify (proc
, SCM_UNDEFINED
));
2463 case scm_tc7_vector
:
2467 case scm_tc7_byvect
:
2474 #ifdef HAVE_LONG_LONGS
2475 case scm_tc7_llvect
:
2478 case scm_tc7_string
:
2479 case scm_tc7_substring
:
2481 case scm_tcs_closures
:
2489 #ifdef MEMOIZE_LOCALS
2490 case SCM_BIT8(SCM_ILOC00
):
2491 proc
= *scm_ilookup (SCM_CAR (x
), env
);
2492 SCM_ASRTGO (SCM_NIMP (proc
), badfun
);
2493 #ifndef SCM_RECKLESS
2499 #endif /* ifdef MEMOIZE_LOCALS */
2502 case scm_tcs_cons_gloc
: {
2503 scm_bits_t vcell
= SCM_STRUCT_VTABLE_DATA (x
) [scm_vtable_index_vcell
];
2505 /* This is a struct implanted in the code, not a gloc. */
2508 proc
= SCM_PACK (vcell
);
2509 SCM_ASRTGO (SCM_NIMP (proc
), badfun
);
2510 #ifndef SCM_RECKLESS
2519 case scm_tcs_cons_nimcar
:
2520 if (SCM_SYMBOLP (SCM_CAR (x
)))
2523 t
.lloc
= scm_lookupcar1 (x
, env
, 1);
2526 /* we have lost the race, start again. */
2531 proc
= *scm_lookupcar (x
, env
, 1);
2539 if (scm_tc16_macro
== SCM_TYP16 (proc
))
2545 /* Set a flag during macro expansion so that macro
2546 application frames can be deleted from the backtrace. */
2547 SCM_SET_MACROEXP (debug
);
2549 t
.arg1
= SCM_APPLY (SCM_CDR (proc
), x
,
2550 scm_cons (env
, scm_listofnull
));
2553 SCM_CLEAR_MACROEXP (debug
);
2555 switch ((int) (SCM_UNPACK_CAR (proc
) >> 16))
2558 if (scm_ilength (t
.arg1
) <= 0)
2559 t
.arg1
= scm_cons2 (SCM_IM_BEGIN
, t
.arg1
, SCM_EOL
);
2561 if (!SCM_CLOSUREP (SCM_CDR (proc
)))
2564 #if 0 /* Top-level defines doesn't very often occur in backtraces */
2565 if (scm_m_define
== SCM_SUBRF (SCM_CDR (proc
)) && SCM_TOP_LEVEL (env
))
2566 /* Prevent memoizing result of define macro */
2568 debug
.info
->e
.exp
= scm_cons (SCM_CAR (x
), SCM_CDR (x
));
2569 scm_set_source_properties_x (debug
.info
->e
.exp
,
2570 scm_source_properties (x
));
2574 SCM_SETCAR (x
, SCM_CAR (t
.arg1
));
2575 SCM_SETCDR (x
, SCM_CDR (t
.arg1
));
2579 /* Prevent memoizing of debug info expression. */
2580 debug
.info
->e
.exp
= scm_cons_source (debug
.info
->e
.exp
,
2585 SCM_SETCAR (x
, SCM_CAR (t
.arg1
));
2586 SCM_SETCDR (x
, SCM_CDR (t
.arg1
));
2590 if (SCM_NIMP (x
= t
.arg1
))
2598 proc
= SCM_CEVAL (SCM_CAR (x
), env
);
2599 SCM_ASRTGO (SCM_NIMP (proc
), badfun
);
2600 #ifndef SCM_RECKLESS
2604 if (SCM_CLOSUREP (proc
))
2606 arg2
= SCM_CAR (SCM_CODE (proc
));
2607 t
.arg1
= SCM_CDR (x
);
2608 while (SCM_NIMP (arg2
))
2610 if (SCM_NCONSP (arg2
))
2612 if (SCM_IMP (t
.arg1
))
2613 goto umwrongnumargs
;
2614 arg2
= SCM_CDR (arg2
);
2615 t
.arg1
= SCM_CDR (t
.arg1
);
2617 if (SCM_NNULLP (t
.arg1
))
2618 goto umwrongnumargs
;
2620 else if (scm_tc16_macro
== SCM_TYP16 (proc
))
2621 goto handle_a_macro
;
2627 PREP_APPLY (proc
, SCM_EOL
);
2628 if (SCM_NULLP (SCM_CDR (x
))) {
2631 switch (SCM_TYP7 (proc
))
2632 { /* no arguments given */
2633 case scm_tc7_subr_0
:
2634 RETURN (SCM_SUBRF (proc
) ());
2635 case scm_tc7_subr_1o
:
2636 RETURN (SCM_SUBRF (proc
) (SCM_UNDEFINED
));
2638 RETURN (SCM_SUBRF (proc
) (SCM_EOL
));
2639 case scm_tc7_rpsubr
:
2640 RETURN (SCM_BOOL_T
);
2642 RETURN (SCM_SUBRF (proc
) (SCM_UNDEFINED
, SCM_UNDEFINED
));
2646 proc
= SCM_CCLO_SUBR (proc
);
2648 debug
.info
->a
.proc
= proc
;
2649 debug
.info
->a
.args
= scm_cons (t
.arg1
, SCM_EOL
);
2654 proc
= SCM_PROCEDURE (proc
);
2656 debug
.info
->a
.proc
= proc
;
2659 case scm_tcs_closures
:
2660 x
= SCM_CODE (proc
);
2661 env
= EXTEND_ENV (SCM_CAR (x
), SCM_EOL
, SCM_ENV (proc
));
2663 case scm_tcs_cons_gloc
:
2664 if (SCM_OBJ_CLASS_FLAGS (proc
) & SCM_CLASSF_PURE_GENERIC
)
2666 x
= SCM_ENTITY_PROCEDURE (proc
);
2670 else if (!SCM_I_OPERATORP (proc
))
2675 proc
= (SCM_I_ENTITYP (proc
)
2676 ? SCM_ENTITY_PROCEDURE (proc
)
2677 : SCM_OPERATOR_PROCEDURE (proc
));
2679 debug
.info
->a
.proc
= proc
;
2680 debug
.info
->a
.args
= scm_cons (t
.arg1
, SCM_EOL
);
2682 if (SCM_NIMP (proc
))
2687 case scm_tc7_contin
:
2688 case scm_tc7_subr_1
:
2689 case scm_tc7_subr_2
:
2690 case scm_tc7_subr_2o
:
2692 case scm_tc7_subr_3
:
2693 case scm_tc7_lsubr_2
:
2697 /* scm_everr (x, env,...) */
2698 scm_wrong_num_args (proc
);
2700 /* handle macros here */
2705 /* must handle macros by here */
2710 else if (SCM_CONSP (x
))
2712 if (SCM_IMP (SCM_CAR (x
)))
2713 t
.arg1
= SCM_EVALIM (SCM_CAR (x
), env
);
2715 t
.arg1
= EVALCELLCAR (x
, env
);
2717 else if (SCM_TYP3 (x
) == scm_tc3_cons_gloc
)
2719 scm_bits_t vcell
= SCM_STRUCT_VTABLE_DATA (x
) [scm_vtable_index_vcell
];
2721 t
.arg1
= SCM_CAR (x
); /* struct planted in code */
2723 t
.arg1
= SCM_PACK (vcell
);
2728 t
.arg1
= EVALCAR (x
, env
);
2731 debug
.info
->a
.args
= scm_cons (t
.arg1
, SCM_EOL
);
2738 switch (SCM_TYP7 (proc
))
2739 { /* have one argument in t.arg1 */
2740 case scm_tc7_subr_2o
:
2741 RETURN (SCM_SUBRF (proc
) (t
.arg1
, SCM_UNDEFINED
));
2742 case scm_tc7_subr_1
:
2743 case scm_tc7_subr_1o
:
2744 RETURN (SCM_SUBRF (proc
) (t
.arg1
));
2746 if (SCM_SUBRF (proc
))
2748 if (SCM_INUMP (t
.arg1
))
2750 RETURN (scm_make_real (SCM_DSUBRF (proc
) ((double) SCM_INUM (t
.arg1
))));
2752 SCM_ASRTGO (SCM_NIMP (t
.arg1
), floerr
);
2753 if (SCM_REALP (t
.arg1
))
2755 RETURN (scm_make_real (SCM_DSUBRF (proc
) (SCM_REALPART (t
.arg1
))));
2758 if (SCM_BIGP (t
.arg1
))
2760 RETURN (scm_make_real (SCM_DSUBRF (proc
) (scm_big2dbl (t
.arg1
))));
2764 SCM_WTA_DISPATCH_1 (*SCM_SUBR_GENERIC (proc
), t
.arg1
,
2765 SCM_ARG1
, SCM_CHARS (SCM_SNAME (proc
)));
2767 proc
= SCM_SNAME (proc
);
2769 char *chrs
= SCM_CHARS (proc
) + SCM_LENGTH (proc
) - 1;
2770 while ('c' != *--chrs
)
2772 SCM_ASSERT (SCM_CONSP (t
.arg1
),
2773 t
.arg1
, SCM_ARG1
, SCM_CHARS (proc
));
2774 t
.arg1
= ('a' == *chrs
) ? SCM_CAR (t
.arg1
) : SCM_CDR (t
.arg1
);
2778 case scm_tc7_rpsubr
:
2779 RETURN (SCM_BOOL_T
);
2781 RETURN (SCM_SUBRF (proc
) (t
.arg1
, SCM_UNDEFINED
));
2784 RETURN (SCM_SUBRF (proc
) (debug
.info
->a
.args
))
2786 RETURN (SCM_SUBRF (proc
) (scm_cons (t
.arg1
, SCM_EOL
)));
2792 proc
= SCM_CCLO_SUBR (proc
);
2794 debug
.info
->a
.args
= scm_cons (t
.arg1
, debug
.info
->a
.args
);
2795 debug
.info
->a
.proc
= proc
;
2800 proc
= SCM_PROCEDURE (proc
);
2802 debug
.info
->a
.proc
= proc
;
2805 case scm_tcs_closures
:
2807 x
= SCM_CODE (proc
);
2809 env
= EXTEND_ENV (SCM_CAR (x
), debug
.info
->a
.args
, SCM_ENV (proc
));
2811 env
= EXTEND_ENV (SCM_CAR (x
), scm_cons (t
.arg1
, SCM_EOL
), SCM_ENV (proc
));
2814 case scm_tc7_contin
:
2815 scm_call_continuation (proc
, t
.arg1
);
2816 case scm_tcs_cons_gloc
:
2817 if (SCM_OBJ_CLASS_FLAGS (proc
) & SCM_CLASSF_PURE_GENERIC
)
2819 x
= SCM_ENTITY_PROCEDURE (proc
);
2821 arg2
= debug
.info
->a
.args
;
2823 arg2
= scm_cons (t
.arg1
, SCM_EOL
);
2827 else if (!SCM_I_OPERATORP (proc
))
2833 proc
= (SCM_I_ENTITYP (proc
)
2834 ? SCM_ENTITY_PROCEDURE (proc
)
2835 : SCM_OPERATOR_PROCEDURE (proc
));
2837 debug
.info
->a
.args
= scm_cons (t
.arg1
, debug
.info
->a
.args
);
2838 debug
.info
->a
.proc
= proc
;
2840 if (SCM_NIMP (proc
))
2845 case scm_tc7_subr_2
:
2846 case scm_tc7_subr_0
:
2847 case scm_tc7_subr_3
:
2848 case scm_tc7_lsubr_2
:
2857 else if (SCM_CONSP (x
))
2859 if (SCM_IMP (SCM_CAR (x
)))
2860 arg2
= SCM_EVALIM (SCM_CAR (x
), env
);
2862 arg2
= EVALCELLCAR (x
, env
);
2864 else if (SCM_TYP3 (x
) == scm_tc3_cons_gloc
)
2866 scm_bits_t vcell
= SCM_STRUCT_VTABLE_DATA (x
) [scm_vtable_index_vcell
];
2868 arg2
= SCM_CAR (x
); /* struct planted in code */
2870 arg2
= SCM_PACK (vcell
);
2875 arg2
= EVALCAR (x
, env
);
2877 { /* have two or more arguments */
2879 debug
.info
->a
.args
= scm_cons2 (t
.arg1
, arg2
, SCM_EOL
);
2882 if (SCM_NULLP (x
)) {
2887 switch (SCM_TYP7 (proc
))
2888 { /* have two arguments */
2889 case scm_tc7_subr_2
:
2890 case scm_tc7_subr_2o
:
2891 RETURN (SCM_SUBRF (proc
) (t
.arg1
, arg2
));
2894 RETURN (SCM_SUBRF (proc
) (debug
.info
->a
.args
))
2896 RETURN (SCM_SUBRF (proc
) (scm_cons2 (t
.arg1
, arg2
, SCM_EOL
)));
2898 case scm_tc7_lsubr_2
:
2899 RETURN (SCM_SUBRF (proc
) (t
.arg1
, arg2
, SCM_EOL
));
2900 case scm_tc7_rpsubr
:
2902 RETURN (SCM_SUBRF (proc
) (t
.arg1
, arg2
));
2907 RETURN (SCM_APPLY (SCM_CCLO_SUBR (proc
),
2908 scm_cons (proc
, debug
.info
->a
.args
),
2911 RETURN (SCM_APPLY (SCM_CCLO_SUBR (proc
),
2912 scm_cons2 (proc
, t
.arg1
,
2919 /* case scm_tc7_cclo:
2920 x = scm_cons(arg2, scm_eval_args(x, env));
2923 proc = SCM_CCLO_SUBR(proc);
2927 proc
= SCM_PROCEDURE (proc
);
2929 debug
.info
->a
.proc
= proc
;
2932 case scm_tcs_cons_gloc
:
2933 if (SCM_OBJ_CLASS_FLAGS (proc
) & SCM_CLASSF_PURE_GENERIC
)
2935 x
= SCM_ENTITY_PROCEDURE (proc
);
2937 arg2
= debug
.info
->a
.args
;
2939 arg2
= scm_cons2 (t
.arg1
, arg2
, SCM_EOL
);
2943 else if (!SCM_I_OPERATORP (proc
))
2949 RETURN (SCM_APPLY (SCM_I_ENTITYP (proc
)
2950 ? SCM_ENTITY_PROCEDURE (proc
)
2951 : SCM_OPERATOR_PROCEDURE (proc
),
2952 scm_cons (proc
, debug
.info
->a
.args
),
2955 RETURN (SCM_APPLY (SCM_I_ENTITYP (proc
)
2956 ? SCM_ENTITY_PROCEDURE (proc
)
2957 : SCM_OPERATOR_PROCEDURE (proc
),
2958 scm_cons2 (proc
, t
.arg1
,
2966 case scm_tc7_subr_0
:
2968 case scm_tc7_subr_1o
:
2969 case scm_tc7_subr_1
:
2970 case scm_tc7_subr_3
:
2971 case scm_tc7_contin
:
2975 case scm_tcs_closures
:
2978 env
= EXTEND_ENV (SCM_CAR (SCM_CODE (proc
)),
2982 env
= EXTEND_ENV (SCM_CAR (SCM_CODE (proc
)),
2983 scm_cons2 (t
.arg1
, arg2
, SCM_EOL
), SCM_ENV (proc
));
2985 x
= SCM_CODE (proc
);
2990 if (SCM_IMP (x
) || SCM_NECONSP (x
))
2994 debug
.info
->a
.args
= scm_cons2 (t
.arg1
, arg2
,
2995 scm_deval_args (x
, env
, proc
,
2996 SCM_CDRLOC (SCM_CDR (debug
.info
->a
.args
))));
3000 switch (SCM_TYP7 (proc
))
3001 { /* have 3 or more arguments */
3003 case scm_tc7_subr_3
:
3004 SCM_ASRTGO (SCM_NULLP (SCM_CDR (x
)), wrongnumargs
);
3005 RETURN (SCM_SUBRF (proc
) (t
.arg1
, arg2
,
3006 SCM_CADDR (debug
.info
->a
.args
)));
3008 #ifdef BUILTIN_RPASUBR
3009 t
.arg1
= SCM_SUBRF(proc
)(t
.arg1
, arg2
);
3010 arg2
= SCM_CDR (SCM_CDR (debug
.info
->a
.args
));
3013 t
.arg1
= SCM_SUBRF(proc
)(t
.arg1
, SCM_CAR (arg2
));
3014 arg2
= SCM_CDR (arg2
);
3016 while (SCM_NIMP (arg2
));
3018 #endif /* BUILTIN_RPASUBR */
3019 case scm_tc7_rpsubr
:
3020 #ifdef BUILTIN_RPASUBR
3021 if (SCM_FALSEP (SCM_SUBRF (proc
) (t
.arg1
, arg2
)))
3023 t
.arg1
= SCM_CDR (SCM_CDR (debug
.info
->a
.args
));
3026 if (SCM_FALSEP (SCM_SUBRF (proc
) (arg2
, SCM_CAR (t
.arg1
))))
3028 arg2
= SCM_CAR (t
.arg1
);
3029 t
.arg1
= SCM_CDR (t
.arg1
);
3031 while (SCM_NIMP (t
.arg1
));
3033 #else /* BUILTIN_RPASUBR */
3034 RETURN (SCM_APPLY (proc
, t
.arg1
,
3036 SCM_CDR (SCM_CDR (debug
.info
->a
.args
)),
3038 #endif /* BUILTIN_RPASUBR */
3039 case scm_tc7_lsubr_2
:
3040 RETURN (SCM_SUBRF (proc
) (t
.arg1
, arg2
,
3041 SCM_CDR (SCM_CDR (debug
.info
->a
.args
))))
3043 RETURN (SCM_SUBRF (proc
) (debug
.info
->a
.args
))
3049 proc
= SCM_PROCEDURE (proc
);
3050 debug
.info
->a
.proc
= proc
;
3052 case scm_tcs_closures
:
3053 SCM_SET_ARGSREADY (debug
);
3054 env
= EXTEND_ENV (SCM_CAR (SCM_CODE (proc
)),
3057 x
= SCM_CODE (proc
);
3060 case scm_tc7_subr_3
:
3061 SCM_ASRTGO (SCM_NULLP (SCM_CDR (x
)), wrongnumargs
);
3062 RETURN (SCM_SUBRF (proc
) (t
.arg1
, arg2
, EVALCAR (x
, env
)));
3064 #ifdef BUILTIN_RPASUBR
3065 t
.arg1
= SCM_SUBRF (proc
) (t
.arg1
, arg2
);
3068 t
.arg1
= SCM_SUBRF(proc
)(t
.arg1
, EVALCAR(x
, env
));
3071 while (SCM_NIMP (x
));
3073 #endif /* BUILTIN_RPASUBR */
3074 case scm_tc7_rpsubr
:
3075 #ifdef BUILTIN_RPASUBR
3076 if (SCM_FALSEP (SCM_SUBRF (proc
) (t
.arg1
, arg2
)))
3080 t
.arg1
= EVALCAR (x
, env
);
3081 if (SCM_FALSEP (SCM_SUBRF (proc
) (arg2
, t
.arg1
)))
3086 while (SCM_NIMP (x
));
3088 #else /* BUILTIN_RPASUBR */
3089 RETURN (SCM_APPLY (proc
, t
.arg1
,
3091 scm_eval_args (x
, env
, proc
),
3093 #endif /* BUILTIN_RPASUBR */
3094 case scm_tc7_lsubr_2
:
3095 RETURN (SCM_SUBRF (proc
) (t
.arg1
, arg2
, scm_eval_args (x
, env
, proc
)));
3097 RETURN (SCM_SUBRF (proc
) (scm_cons2 (t
.arg1
,
3099 scm_eval_args (x
, env
, proc
))));
3105 proc
= SCM_PROCEDURE (proc
);
3107 case scm_tcs_closures
:
3109 SCM_SET_ARGSREADY (debug
);
3111 env
= EXTEND_ENV (SCM_CAR (SCM_CODE (proc
)),
3114 scm_eval_args (x
, env
, proc
)),
3116 x
= SCM_CODE (proc
);
3119 case scm_tcs_cons_gloc
:
3120 if (SCM_OBJ_CLASS_FLAGS (proc
) & SCM_CLASSF_PURE_GENERIC
)
3123 arg2
= debug
.info
->a
.args
;
3125 arg2
= scm_cons2 (t
.arg1
, arg2
, scm_eval_args (x
, env
, proc
));
3127 x
= SCM_ENTITY_PROCEDURE (proc
);
3130 else if (!SCM_I_OPERATORP (proc
))
3134 case scm_tc7_subr_2
:
3135 case scm_tc7_subr_1o
:
3136 case scm_tc7_subr_2o
:
3137 case scm_tc7_subr_0
:
3139 case scm_tc7_subr_1
:
3140 case scm_tc7_contin
:
3148 if (CHECK_EXIT
&& SCM_TRAPS_P
)
3149 if (SCM_EXIT_FRAME_P
|| (SCM_TRACE_P
&& SCM_TRACED_FRAME_P (debug
)))
3151 SCM_CLEAR_TRACED_FRAME (debug
);
3152 if (SCM_CHEAPTRAPS_P
)
3153 t
.arg1
= scm_make_debugobj (&debug
);
3156 scm_make_cont (&t
.arg1
);
3157 if (setjmp (SCM_JMPBUF (t
.arg1
)))
3159 proc
= SCM_THROW_VALUE (t
.arg1
);
3163 scm_ithrow (scm_sym_exit_frame
, scm_cons2 (t
.arg1
, proc
, SCM_EOL
), 0);
3166 scm_last_debug_frame
= debug
.prev
;
3172 /* SECTION: This code is compiled once.
3177 /* This code processes the arguments to apply:
3179 (apply PROC ARG1 ... ARGS)
3181 Given a list (ARG1 ... ARGS), this function conses the ARG1
3182 ... arguments onto the front of ARGS, and returns the resulting
3183 list. Note that ARGS is a list; thus, the argument to this
3184 function is a list whose last element is a list.
3186 Apply calls this function, and applies PROC to the elements of the
3187 result. apply:nconc2last takes care of building the list of
3188 arguments, given (ARG1 ... ARGS).
3190 Rather than do new consing, apply:nconc2last destroys its argument.
3191 On that topic, this code came into my care with the following
3192 beautifully cryptic comment on that topic: "This will only screw
3193 you if you do (scm_apply scm_apply '( ... ))" If you know what
3194 they're referring to, send me a patch to this comment. */
3196 SCM_DEFINE (scm_nconc2last
, "apply:nconc2last", 1, 0, 0,
3199 #define FUNC_NAME s_scm_nconc2last
3202 SCM_VALIDATE_NONEMPTYLIST (1,lst
);
3204 while (SCM_NNULLP (SCM_CDR (*lloc
)))
3205 lloc
= SCM_CDRLOC (*lloc
);
3206 SCM_ASSERT (scm_ilength (SCM_CAR (*lloc
)) >= 0, lst
, SCM_ARG1
, FUNC_NAME
);
3207 *lloc
= SCM_CAR (*lloc
);
3215 /* SECTION: When DEVAL is defined this code yields scm_dapply.
3216 * It is compiled twice.
3222 scm_apply (SCM proc
, SCM arg1
, SCM args
)
3229 scm_dapply (SCM proc
, SCM arg1
, SCM args
)
3234 /* Apply a function to a list of arguments.
3236 This function is exported to the Scheme level as taking two
3237 required arguments and a tail argument, as if it were:
3238 (lambda (proc arg1 . args) ...)
3239 Thus, if you just have a list of arguments to pass to a procedure,
3240 pass the list as ARG1, and '() for ARGS. If you have some fixed
3241 args, pass the first as ARG1, then cons any remaining fixed args
3242 onto the front of your argument list, and pass that as ARGS. */
3245 SCM_APPLY (SCM proc
, SCM arg1
, SCM args
)
3247 #ifdef DEBUG_EXTENSIONS
3249 scm_debug_frame debug
;
3250 scm_debug_info debug_vect_body
;
3251 debug
.prev
= scm_last_debug_frame
;
3252 debug
.status
= SCM_APPLYFRAME
;
3253 debug
.vect
= &debug_vect_body
;
3254 debug
.vect
[0].a
.proc
= proc
;
3255 debug
.vect
[0].a
.args
= SCM_EOL
;
3256 scm_last_debug_frame
= &debug
;
3259 return scm_dapply (proc
, arg1
, args
);
3263 SCM_ASRTGO (SCM_NIMP (proc
), badproc
);
3265 /* If ARGS is the empty list, then we're calling apply with only two
3266 arguments --- ARG1 is the list of arguments for PROC. Whatever
3267 the case, futz with things so that ARG1 is the first argument to
3268 give to PROC (or SCM_UNDEFINED if no args), and ARGS contains the
3271 Setting the debug apply frame args this way is pretty messy.
3272 Perhaps we should store arg1 and args directly in the frame as
3273 received, and let scm_frame_arguments unpack them, because that's
3274 a relatively rare operation. This works for now; if the Guile
3275 developer archives are still around, see Mikael's post of
3277 if (SCM_NULLP (args
))
3279 if (SCM_NULLP (arg1
))
3281 arg1
= SCM_UNDEFINED
;
3283 debug
.vect
[0].a
.args
= SCM_EOL
;
3289 debug
.vect
[0].a
.args
= arg1
;
3291 args
= SCM_CDR (arg1
);
3292 arg1
= SCM_CAR (arg1
);
3297 /* SCM_ASRTGO(SCM_CONSP(args), wrongnumargs); */
3298 args
= scm_nconc2last (args
);
3300 debug
.vect
[0].a
.args
= scm_cons (arg1
, args
);
3304 if (SCM_ENTER_FRAME_P
&& SCM_TRAPS_P
)
3307 if (SCM_CHEAPTRAPS_P
)
3308 tmp
= scm_make_debugobj (&debug
);
3311 scm_make_cont (&tmp
);
3312 if (setjmp (SCM_JMPBUF (tmp
)))
3315 scm_ithrow (scm_sym_enter_frame
, scm_cons (tmp
, SCM_EOL
), 0);
3323 switch (SCM_TYP7 (proc
))
3325 case scm_tc7_subr_2o
:
3326 args
= SCM_NULLP (args
) ? SCM_UNDEFINED
: SCM_CAR (args
);
3327 RETURN (SCM_SUBRF (proc
) (arg1
, args
))
3328 case scm_tc7_subr_2
:
3329 SCM_ASRTGO (SCM_NNULLP (args
) && SCM_NULLP (SCM_CDR (args
)),
3331 args
= SCM_CAR (args
);
3332 RETURN (SCM_SUBRF (proc
) (arg1
, args
))
3333 case scm_tc7_subr_0
:
3334 SCM_ASRTGO (SCM_UNBNDP (arg1
), wrongnumargs
);
3335 RETURN (SCM_SUBRF (proc
) ())
3336 case scm_tc7_subr_1
:
3337 case scm_tc7_subr_1o
:
3338 SCM_ASRTGO (SCM_NULLP (args
), wrongnumargs
);
3339 RETURN (SCM_SUBRF (proc
) (arg1
))
3341 SCM_ASRTGO (SCM_NULLP (args
), wrongnumargs
);
3342 if (SCM_SUBRF (proc
))
3344 if (SCM_INUMP (arg1
))
3346 RETURN (scm_make_real (SCM_DSUBRF (proc
) ((double) SCM_INUM (arg1
))));
3348 SCM_ASRTGO (SCM_NIMP (arg1
), floerr
);
3349 if (SCM_REALP (arg1
))
3351 RETURN (scm_make_real (SCM_DSUBRF (proc
) (SCM_REALPART (arg1
))));
3354 if (SCM_BIGP (arg1
))
3355 RETURN (scm_make_real (SCM_DSUBRF (proc
) (scm_big2dbl (arg1
))))
3358 SCM_WTA_DISPATCH_1 (*SCM_SUBR_GENERIC (proc
), arg1
,
3359 SCM_ARG1
, SCM_CHARS (SCM_SNAME (proc
)));
3361 proc
= SCM_SNAME (proc
);
3363 char *chrs
= SCM_CHARS (proc
) + SCM_LENGTH (proc
) - 1;
3364 while ('c' != *--chrs
)
3366 SCM_ASSERT (SCM_CONSP (arg1
),
3367 arg1
, SCM_ARG1
, SCM_CHARS (proc
));
3368 arg1
= ('a' == *chrs
) ? SCM_CAR (arg1
) : SCM_CDR (arg1
);
3372 case scm_tc7_subr_3
:
3373 RETURN (SCM_SUBRF (proc
) (arg1
, SCM_CAR (args
), SCM_CAR (SCM_CDR (args
))))
3376 RETURN (SCM_SUBRF (proc
) (SCM_UNBNDP (arg1
) ? SCM_EOL
: debug
.vect
[0].a
.args
))
3378 RETURN (SCM_SUBRF (proc
) (SCM_UNBNDP (arg1
) ? SCM_EOL
: scm_cons (arg1
, args
)))
3380 case scm_tc7_lsubr_2
:
3381 SCM_ASRTGO (SCM_CONSP (args
), wrongnumargs
);
3382 RETURN (SCM_SUBRF (proc
) (arg1
, SCM_CAR (args
), SCM_CDR (args
)))
3384 if (SCM_NULLP (args
))
3385 RETURN (SCM_SUBRF (proc
) (arg1
, SCM_UNDEFINED
))
3386 while (SCM_NIMP (args
))
3388 SCM_ASSERT (SCM_CONSP (args
), args
, SCM_ARG2
, "apply");
3389 arg1
= SCM_SUBRF (proc
) (arg1
, SCM_CAR (args
));
3390 args
= SCM_CDR (args
);
3393 case scm_tc7_rpsubr
:
3394 if (SCM_NULLP (args
))
3395 RETURN (SCM_BOOL_T
);
3396 while (SCM_NIMP (args
))
3398 SCM_ASSERT (SCM_CONSP (args
), args
, SCM_ARG2
, "apply");
3399 if (SCM_FALSEP (SCM_SUBRF (proc
) (arg1
, SCM_CAR (args
))))
3400 RETURN (SCM_BOOL_F
);
3401 arg1
= SCM_CAR (args
);
3402 args
= SCM_CDR (args
);
3404 RETURN (SCM_BOOL_T
);
3405 case scm_tcs_closures
:
3407 arg1
= (SCM_UNBNDP (arg1
) ? SCM_EOL
: debug
.vect
[0].a
.args
);
3409 arg1
= (SCM_UNBNDP (arg1
) ? SCM_EOL
: scm_cons (arg1
, args
));
3411 #ifndef SCM_RECKLESS
3412 if (scm_badargsp (SCM_CAR (SCM_CODE (proc
)), arg1
))
3416 /* Copy argument list */
3421 SCM tl
= args
= scm_cons (SCM_CAR (arg1
), SCM_UNSPECIFIED
);
3422 while (arg1
= SCM_CDR (arg1
), SCM_CONSP (arg1
))
3424 SCM_SETCDR (tl
, scm_cons (SCM_CAR (arg1
),
3428 SCM_SETCDR (tl
, arg1
);
3431 args
= EXTEND_ENV (SCM_CAR (SCM_CODE (proc
)), args
, SCM_ENV (proc
));
3432 proc
= SCM_CDR (SCM_CODE (proc
));
3435 while (SCM_NNULLP (arg1
= SCM_CDR (arg1
)))
3437 if (SCM_IMP (SCM_CAR (proc
)))
3439 if (SCM_ISYMP (SCM_CAR (proc
)))
3441 proc
= scm_m_expand_body (proc
, args
);
3446 SCM_CEVAL (SCM_CAR (proc
), args
);
3449 RETURN (EVALCAR (proc
, args
));
3450 case scm_tc7_contin
:
3451 SCM_ASRTGO (SCM_NULLP (args
), wrongnumargs
);
3452 scm_call_continuation (proc
, arg1
);
3456 args
= (SCM_UNBNDP(arg1
) ? SCM_EOL
: debug
.vect
[0].a
.args
);
3458 proc
= SCM_CCLO_SUBR (proc
);
3459 debug
.vect
[0].a
.proc
= proc
;
3460 debug
.vect
[0].a
.args
= scm_cons (arg1
, args
);
3462 args
= (SCM_UNBNDP(arg1
) ? SCM_EOL
: scm_cons (arg1
, args
));
3464 proc
= SCM_CCLO_SUBR (proc
);
3469 proc
= SCM_PROCEDURE (proc
);
3471 debug
.vect
[0].a
.proc
= proc
;
3474 case scm_tcs_cons_gloc
:
3475 if (SCM_OBJ_CLASS_FLAGS (proc
) & SCM_CLASSF_PURE_GENERIC
)
3478 args
= (SCM_UNBNDP(arg1
) ? SCM_EOL
: debug
.vect
[0].a
.args
);
3480 args
= (SCM_UNBNDP(arg1
) ? SCM_EOL
: scm_cons (arg1
, args
));
3482 RETURN (scm_apply_generic (proc
, args
));
3484 else if (!SCM_I_OPERATORP (proc
))
3489 args
= (SCM_UNBNDP(arg1
) ? SCM_EOL
: debug
.vect
[0].a
.args
);
3491 args
= (SCM_UNBNDP(arg1
) ? SCM_EOL
: scm_cons (arg1
, args
));
3494 proc
= (SCM_I_ENTITYP (proc
)
3495 ? SCM_ENTITY_PROCEDURE (proc
)
3496 : SCM_OPERATOR_PROCEDURE (proc
));
3498 debug
.vect
[0].a
.proc
= proc
;
3499 debug
.vect
[0].a
.args
= scm_cons (arg1
, args
);
3501 if (SCM_NIMP (proc
))
3507 scm_wrong_num_args (proc
);
3510 scm_wta (proc
, (char *) SCM_ARG1
, "apply");
3515 if (CHECK_EXIT
&& SCM_TRAPS_P
)
3516 if (SCM_EXIT_FRAME_P
|| (SCM_TRACE_P
&& SCM_TRACED_FRAME_P (debug
)))
3518 SCM_CLEAR_TRACED_FRAME (debug
);
3519 if (SCM_CHEAPTRAPS_P
)
3520 arg1
= scm_make_debugobj (&debug
);
3523 scm_make_cont (&arg1
);
3524 if (setjmp (SCM_JMPBUF (arg1
)))
3526 proc
= SCM_THROW_VALUE (arg1
);
3530 scm_ithrow (scm_sym_exit_frame
, scm_cons2 (arg1
, proc
, SCM_EOL
), 0);
3533 scm_last_debug_frame
= debug
.prev
;
3539 /* SECTION: The rest of this file is only read once.
3544 /* Typechecking for multi-argument MAP and FOR-EACH.
3546 Verify that each element of the vector ARGV, except for the first,
3547 is a proper list whose length is LEN. Attribute errors to WHO,
3548 and claim that the i'th element of ARGV is WHO's i+2'th argument. */
3550 check_map_args (SCM argv
,
3557 SCM
*ve
= SCM_VELTS (argv
);
3560 for (i
= SCM_LENGTH (argv
) - 1; i
>= 1; i
--)
3562 int elt_len
= scm_ilength (ve
[i
]);
3567 scm_apply_generic (gf
, scm_cons (proc
, args
));
3569 scm_wrong_type_arg (who
, i
+ 2, ve
[i
]);
3573 scm_out_of_range (who
, ve
[i
]);
3576 scm_remember (&argv
);
3580 SCM_GPROC (s_map
, "map", 2, 0, 1, scm_map
, g_map
);
3582 /* Note: Currently, scm_map applies PROC to the argument list(s)
3583 sequentially, starting with the first element(s). This is used in
3584 evalext.c where the Scheme procedure `serial-map', which guarantees
3585 sequential behaviour, is implemented using scm_map. If the
3586 behaviour changes, we need to update `serial-map'.
3590 scm_map (SCM proc
, SCM arg1
, SCM args
)
3595 SCM
*ve
= &args
; /* Keep args from being optimized away. */
3597 if (SCM_NULLP (arg1
))
3599 len
= scm_ilength (arg1
);
3600 SCM_GASSERTn (len
>= 0,
3601 g_map
, scm_cons2 (proc
, arg1
, args
), SCM_ARG2
, s_map
);
3602 if (SCM_NULLP (args
))
3604 while (SCM_NIMP (arg1
))
3606 SCM_GASSERT2 (SCM_CONSP (arg1
), g_map
, proc
, arg1
, SCM_ARG2
, s_map
);
3607 *pres
= scm_cons (scm_apply (proc
, SCM_CAR (arg1
), scm_listofnull
),
3609 pres
= SCM_CDRLOC (*pres
);
3610 arg1
= SCM_CDR (arg1
);
3614 args
= scm_vector (arg1
= scm_cons (arg1
, args
));
3615 ve
= SCM_VELTS (args
);
3616 #ifndef SCM_RECKLESS
3617 check_map_args (args
, len
, g_map
, proc
, arg1
, s_map
);
3622 for (i
= SCM_LENGTH (args
) - 1; i
>= 0; i
--)
3624 if (SCM_IMP (ve
[i
]))
3626 arg1
= scm_cons (SCM_CAR (ve
[i
]), arg1
);
3627 ve
[i
] = SCM_CDR (ve
[i
]);
3629 *pres
= scm_cons (scm_apply (proc
, arg1
, SCM_EOL
), SCM_EOL
);
3630 pres
= SCM_CDRLOC (*pres
);
3635 SCM_GPROC (s_for_each
, "for-each", 2, 0, 1, scm_for_each
, g_for_each
);
3638 scm_for_each (SCM proc
, SCM arg1
, SCM args
)
3640 SCM
*ve
= &args
; /* Keep args from being optimized away. */
3643 return SCM_UNSPECIFIED
;
3644 len
= scm_ilength (arg1
);
3645 SCM_GASSERTn (len
>= 0, g_for_each
, scm_cons2 (proc
, arg1
, args
),
3646 SCM_ARG2
, s_for_each
);
3649 while SCM_NIMP (arg1
)
3651 SCM_GASSERT2 (SCM_CONSP (arg1
),
3652 g_for_each
, proc
, arg1
, SCM_ARG2
, s_for_each
);
3653 scm_apply (proc
, SCM_CAR (arg1
), scm_listofnull
);
3654 arg1
= SCM_CDR (arg1
);
3656 return SCM_UNSPECIFIED
;
3658 args
= scm_vector (arg1
= scm_cons (arg1
, args
));
3659 ve
= SCM_VELTS (args
);
3660 #ifndef SCM_RECKLESS
3661 check_map_args (args
, len
, g_for_each
, proc
, arg1
, s_for_each
);
3666 for (i
= SCM_LENGTH (args
) - 1; i
>= 0; i
--)
3669 (ve
[i
]) return SCM_UNSPECIFIED
;
3670 arg1
= scm_cons (SCM_CAR (ve
[i
]), arg1
);
3671 ve
[i
] = SCM_CDR (ve
[i
]);
3673 scm_apply (proc
, arg1
, SCM_EOL
);
3680 scm_closure (SCM code
, SCM env
)
3684 SCM_SETCODE (z
, code
);
3685 SCM_SETENV (z
, env
);
3690 long scm_tc16_promise
;
3693 scm_makprom (SCM code
)
3695 SCM_RETURN_NEWSMOB (scm_tc16_promise
, SCM_UNPACK (code
));
3701 prinprom (SCM exp
,SCM port
,scm_print_state
*pstate
)
3703 int writingp
= SCM_WRITINGP (pstate
);
3704 scm_puts ("#<promise ", port
);
3705 SCM_SET_WRITINGP (pstate
, 1);
3706 scm_iprin1 (SCM_CDR (exp
), port
, pstate
);
3707 SCM_SET_WRITINGP (pstate
, writingp
);
3708 scm_putc ('>', port
);
3713 SCM_DEFINE (scm_force
, "force", 1, 0, 0,
3716 #define FUNC_NAME s_scm_force
3718 SCM_VALIDATE_SMOB (1,x
,promise
);
3719 if (!((1L << 16) & SCM_UNPACK_CAR (x
)))
3721 SCM ans
= scm_apply (SCM_CDR (x
), SCM_EOL
, SCM_EOL
);
3722 if (!((1L << 16) & SCM_UNPACK_CAR (x
)))
3725 SCM_SETCDR (x
, ans
);
3726 SCM_SETOR_CAR (x
, (1L << 16));
3734 SCM_DEFINE (scm_promise_p
, "promise?", 1, 0, 0,
3736 "Return true if @var{obj} is a promise, i.e. a delayed computation\n"
3737 "(@pxref{Delayed evaluation,,,r4rs.info,The Revised^4 Report on Scheme}).")
3738 #define FUNC_NAME s_scm_promise_p
3740 return SCM_BOOL(SCM_NIMP (x
) && (SCM_TYP16 (x
) == scm_tc16_promise
));
3744 SCM_DEFINE (scm_cons_source
, "cons-source", 3, 0, 0,
3745 (SCM xorig
, SCM x
, SCM y
),
3747 #define FUNC_NAME s_scm_cons_source
3753 /* Copy source properties possibly associated with xorig. */
3754 p
= scm_whash_lookup (scm_source_whash
, xorig
);
3756 scm_whash_insert (scm_source_whash
, z
, p
);
3761 SCM_DEFINE (scm_copy_tree
, "copy-tree", 1, 0, 0,
3763 "Recursively copy the data tree that is bound to @var{obj}, and return a\n"
3764 "pointer to the new data structure. @code{copy-tree} recurses down the\n"
3765 "contents of both pairs and vectors (since both cons cells and vector\n"
3766 "cells may point to arbitrary objects), and stops recursing when it hits\n"
3767 "any other object.")
3768 #define FUNC_NAME s_scm_copy_tree
3773 if (SCM_VECTORP (obj
))
3775 scm_sizet i
= SCM_LENGTH (obj
);
3776 ans
= scm_make_vector (SCM_MAKINUM (i
), SCM_UNSPECIFIED
);
3778 SCM_VELTS (ans
)[i
] = scm_copy_tree (SCM_VELTS (obj
)[i
]);
3781 if (SCM_NCONSP (obj
))
3783 /* return scm_cons(scm_copy_tree(SCM_CAR(obj)), scm_copy_tree(SCM_CDR(obj))); */
3784 ans
= tl
= scm_cons_source (obj
,
3785 scm_copy_tree (SCM_CAR (obj
)),
3787 while (obj
= SCM_CDR (obj
), SCM_CONSP (obj
))
3789 SCM_SETCDR (tl
, scm_cons (scm_copy_tree (SCM_CAR (obj
)),
3793 SCM_SETCDR (tl
, obj
);
3800 scm_eval_3 (SCM obj
, int copyp
, SCM env
)
3802 if (SCM_NIMP (SCM_CDR (scm_system_transformer
)))
3803 obj
= scm_apply (SCM_CDR (scm_system_transformer
), obj
, scm_listofnull
);
3805 obj
= scm_copy_tree (obj
);
3806 return SCM_XEVAL (obj
, env
);
3809 SCM_DEFINE (scm_eval2
, "eval2", 2, 0, 0,
3810 (SCM obj
, SCM env_thunk
),
3811 "Evaluate @var{exp}, a Scheme expression, in the environment designated\n"
3812 "by @var{lookup}, a symbol-lookup function. @code{(eval exp)} is\n"
3813 "equivalent to @code{(eval2 exp *top-level-lookup-closure*)}.")
3814 #define FUNC_NAME s_scm_eval2
3816 return scm_eval_3 (obj
, 1, scm_top_level_env (env_thunk
));
3820 SCM_DEFINE (scm_eval
, "eval", 1, 0, 0,
3822 "Evaluate @var{exp}, a list representing a Scheme expression, in the\n"
3823 "top-level environment.")
3824 #define FUNC_NAME s_scm_eval
3826 return scm_eval_3 (obj
,
3829 (SCM_CDR (scm_top_level_lookup_closure_var
)));
3834 SCM_REGISTER_PROC(s_eval_x, "eval!", 1, 0, 0, scm_eval_x);
3838 scm_eval_x (SCM obj
)
3840 return scm_eval_3 (obj
,
3843 (SCM_CDR (scm_top_level_lookup_closure_var
)));
3847 /* At this point, scm_deval and scm_dapply are generated.
3850 #ifdef DEBUG_EXTENSIONS
3860 scm_init_opts (scm_evaluator_traps
,
3861 scm_evaluator_trap_table
,
3862 SCM_N_EVALUATOR_TRAPS
);
3863 scm_init_opts (scm_eval_options_interface
,
3865 SCM_N_EVAL_OPTIONS
);
3867 scm_tc16_promise
= scm_make_smob_type ("promise", 0);
3868 scm_set_smob_mark (scm_tc16_promise
, scm_markcdr
);
3869 scm_set_smob_print (scm_tc16_promise
, prinprom
);
3871 scm_f_apply
= scm_make_subr ("apply", scm_tc7_lsubr_2
, scm_apply
);
3872 scm_system_transformer
= scm_sysintern ("scm:eval-transformer", SCM_UNDEFINED
);
3873 scm_sym_dot
= SCM_CAR (scm_sysintern (".", SCM_UNDEFINED
));
3874 scm_sym_arrow
= SCM_CAR (scm_sysintern ("=>", SCM_UNDEFINED
));
3875 scm_sym_else
= SCM_CAR (scm_sysintern ("else", SCM_UNDEFINED
));
3876 scm_sym_unquote
= SCM_CAR (scm_sysintern ("unquote", SCM_UNDEFINED
));
3877 scm_sym_uq_splicing
= SCM_CAR (scm_sysintern ("unquote-splicing", SCM_UNDEFINED
));
3879 scm_lisp_nil
= scm_sysintern ("nil", SCM_UNDEFINED
);
3880 SCM_SETCDR (scm_lisp_nil
, SCM_CAR (scm_lisp_nil
));
3881 scm_lisp_nil
= SCM_CAR (scm_lisp_nil
);
3882 scm_lisp_t
= scm_sysintern ("t", SCM_UNDEFINED
);
3883 SCM_SETCDR (scm_lisp_t
, SCM_CAR (scm_lisp_t
));
3884 scm_lisp_t
= SCM_CAR (scm_lisp_t
);
3889 scm_top_level_lookup_closure_var
=
3890 scm_sysintern("*top-level-lookup-closure*", SCM_BOOL_F
);
3891 scm_can_use_top_level_lookup_closure_var
= 1;
3893 #ifdef DEBUG_EXTENSIONS
3894 scm_sym_enter_frame
= SCM_CAR (scm_sysintern ("enter-frame", SCM_UNDEFINED
));
3895 scm_sym_apply_frame
= SCM_CAR (scm_sysintern ("apply-frame", SCM_UNDEFINED
));
3896 scm_sym_exit_frame
= SCM_CAR (scm_sysintern ("exit-frame", SCM_UNDEFINED
));
3897 scm_sym_trace
= SCM_CAR (scm_sysintern ("trace", SCM_UNDEFINED
));
3900 #include "libguile/eval.x"
3902 scm_add_feature ("delay");