1 /* Copyright (C) 1995,1996,1997,1998,1999,2000,2001,2002,2003 Free Software Foundation, Inc.
3 * This library is free software; you can redistribute it and/or
4 * modify it under the terms of the GNU Lesser General Public
5 * License as published by the Free Software Foundation; either
6 * version 2.1 of the License, or (at your option) any later version.
8 * This library 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 GNU
11 * Lesser General Public License for more details.
13 * You should have received a copy of the GNU Lesser General Public
14 * License along with this library; if not, write to the Free Software
15 * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
20 /* This file is read twice in order to produce debugging versions of
21 * scm_ceval and scm_apply. These functions, scm_deval and
22 * scm_dapply, are produced when we define the preprocessor macro
23 * DEVAL. The file is divided into sections which are treated
24 * differently with respect to DEVAL. The heads of these sections are
25 * marked with the string "SECTION:".
28 /* SECTION: This code is compiled once.
35 #include "libguile/__scm.h"
39 /* AIX requires this to be the first thing in the file. The #pragma
40 directive is indented so pre-ANSI compilers will ignore it, rather
49 # ifndef alloca /* predefined by HP cc +Olibcalls */
56 #include "libguile/_scm.h"
57 #include "libguile/alist.h"
58 #include "libguile/async.h"
59 #include "libguile/continuations.h"
60 #include "libguile/debug.h"
61 #include "libguile/dynwind.h"
62 #include "libguile/eq.h"
63 #include "libguile/feature.h"
64 #include "libguile/fluids.h"
65 #include "libguile/futures.h"
66 #include "libguile/goops.h"
67 #include "libguile/hash.h"
68 #include "libguile/hashtab.h"
69 #include "libguile/lang.h"
70 #include "libguile/list.h"
71 #include "libguile/macros.h"
72 #include "libguile/modules.h"
73 #include "libguile/objects.h"
74 #include "libguile/ports.h"
75 #include "libguile/procprop.h"
76 #include "libguile/root.h"
77 #include "libguile/smob.h"
78 #include "libguile/srcprop.h"
79 #include "libguile/stackchk.h"
80 #include "libguile/strings.h"
81 #include "libguile/throw.h"
82 #include "libguile/validate.h"
83 #include "libguile/values.h"
84 #include "libguile/vectors.h"
86 #include "libguile/eval.h"
92 * This section defines the message strings for the syntax errors that can be
93 * detected during memoization and the functions and macros that shall be
94 * called by the memoizer code to signal syntax errors. */
97 /* Syntax errors that can be detected during memoization: */
99 /* Circular or improper lists do not form valid scheme expressions. If a
100 * circular list or an improper list is detected in a place where a scheme
101 * expression is expected, a 'Bad expression' error is signalled. */
102 static const char s_bad_expression
[] = "Bad expression";
104 /* If a form is detected that holds less expressions than are required in that
105 * context, a 'Missing expression' error is signalled. */
106 static const char s_missing_expression
[] = "Missing expression in";
108 /* If a form is detected that holds more expressions than are allowed in that
109 * context, an 'Extra expression' error is signalled. */
110 static const char s_extra_expression
[] = "Extra expression in";
112 /* Case or cond expressions must have at least one clause. If a case or cond
113 * expression without any clauses is detected, a 'Missing clauses' error is
115 static const char s_missing_clauses
[] = "Missing clauses";
117 /* If there is an 'else' clause in a case or a cond statement, it must be the
118 * last clause. If after the 'else' case clause further clauses are detected,
119 * a 'Misplaced else clause' error is signalled. */
120 static const char s_misplaced_else_clause
[] = "Misplaced else clause";
122 /* If a case clause is detected that is not in the format
123 * (<label(s)> <expression1> <expression2> ...)
124 * a 'Bad case clause' error is signalled. */
125 static const char s_bad_case_clause
[] = "Bad case clause";
127 /* If a case clause is detected where the <label(s)> element is neither a
128 * proper list nor (in case of the last clause) the syntactic keyword 'else',
129 * a 'Bad case labels' error is signalled. Note: If you encounter this error
130 * for an else-clause which seems to be syntactically correct, check if 'else'
131 * is really a syntactic keyword in that context. If 'else' is bound in the
132 * local or global environment, it is not considered a syntactic keyword, but
133 * will be treated as any other variable. */
134 static const char s_bad_case_labels
[] = "Bad case labels";
136 /* In a case statement all labels have to be distinct. If in a case statement
137 * a label occurs more than once, a 'Duplicate case label' error is
139 static const char s_duplicate_case_label
[] = "Duplicate case label";
141 /* If a cond clause is detected that is not in one of the formats
142 * (<test> <expression1> ...) or (else <expression1> <expression2> ...)
143 * a 'Bad cond clause' error is signalled. */
144 static const char s_bad_cond_clause
[] = "Bad cond clause";
146 /* If a cond clause is detected that uses the alternate '=>' form, but does
147 * not hold a recipient element for the test result, a 'Missing recipient'
148 * error is signalled. */
149 static const char s_missing_recipient
[] = "Missing recipient in";
151 /* If in a position where a variable name is required some other object is
152 * detected, a 'Bad variable' error is signalled. */
153 static const char s_bad_variable
[] = "Bad variable";
155 /* Bindings for forms like 'let' and 'do' have to be given in a proper,
156 * possibly empty list. If any other object is detected in a place where a
157 * list of bindings was required, a 'Bad bindings' error is signalled. */
158 static const char s_bad_bindings
[] = "Bad bindings";
160 /* Depending on the syntactic context, a binding has to be in the format
161 * (<variable> <expression>) or (<variable> <expression1> <expression2>).
162 * If anything else is detected in a place where a binding was expected, a
163 * 'Bad binding' error is signalled. */
164 static const char s_bad_binding
[] = "Bad binding";
166 /* Some syntactic forms don't allow variable names to appear more than once in
167 * a list of bindings. If such a situation is nevertheless detected, a
168 * 'Duplicate binding' error is signalled. */
169 static const char s_duplicate_binding
[] = "Duplicate binding";
171 /* If the exit form of a 'do' expression is not in the format
172 * (<test> <expression> ...)
173 * a 'Bad exit clause' error is signalled. */
174 static const char s_bad_exit_clause
[] = "Bad exit clause";
176 /* The formal function arguments of a lambda expression have to be either a
177 * single symbol or a non-cyclic list. For anything else a 'Bad formals'
178 * error is signalled. */
179 static const char s_bad_formals
[] = "Bad formals";
181 /* If in a lambda expression something else than a symbol is detected at a
182 * place where a formal function argument is required, a 'Bad formal' error is
184 static const char s_bad_formal
[] = "Bad formal";
186 /* If in the arguments list of a lambda expression an argument name occurs
187 * more than once, a 'Duplicate formal' error is signalled. */
188 static const char s_duplicate_formal
[] = "Duplicate formal";
190 /* If something else than an exact integer is detected as the argument for
191 * @slot-ref and @slot-set!, a 'Bad slot number' error is signalled. */
192 static const char s_bad_slot_number
[] = "Bad slot number";
195 /* Signal a syntax error. We distinguish between the form that caused the
196 * error and the enclosing expression. The error message will print out as
197 * shown in the following pattern. The file name and line number are only
198 * given when they can be determined from the erroneous form or from the
199 * enclosing expression.
201 * <filename>: In procedure memoization:
202 * <filename>: In file <name>, line <nr>: <error-message> in <expression>. */
204 SCM_SYMBOL (syntax_error_key
, "syntax-error");
206 /* The prototype is needed to indicate that the function does not return. */
208 syntax_error (const char* const, const SCM
, const SCM
) SCM_NORETURN
;
211 syntax_error (const char* const msg
, const SCM form
, const SCM expr
)
213 const SCM msg_string
= scm_makfrom0str (msg
);
214 SCM filename
= SCM_BOOL_F
;
215 SCM linenr
= SCM_BOOL_F
;
219 if (SCM_CONSP (form
))
221 filename
= scm_source_property (form
, scm_sym_filename
);
222 linenr
= scm_source_property (form
, scm_sym_line
);
225 if (SCM_FALSEP (filename
) && SCM_FALSEP (linenr
) && SCM_CONSP (expr
))
227 filename
= scm_source_property (expr
, scm_sym_filename
);
228 linenr
= scm_source_property (expr
, scm_sym_line
);
231 if (!SCM_UNBNDP (expr
))
233 if (!SCM_FALSEP (filename
))
235 format
= "In file ~S, line ~S: ~A ~S in expression ~S.";
236 args
= scm_list_5 (filename
, linenr
, msg_string
, form
, expr
);
238 else if (!SCM_FALSEP (linenr
))
240 format
= "In line ~S: ~A ~S in expression ~S.";
241 args
= scm_list_4 (linenr
, msg_string
, form
, expr
);
245 format
= "~A ~S in expression ~S.";
246 args
= scm_list_3 (msg_string
, form
, expr
);
251 if (!SCM_FALSEP (filename
))
253 format
= "In file ~S, line ~S: ~A ~S.";
254 args
= scm_list_4 (filename
, linenr
, msg_string
, form
);
256 else if (!SCM_FALSEP (linenr
))
258 format
= "In line ~S: ~A ~S.";
259 args
= scm_list_3 (linenr
, msg_string
, form
);
264 args
= scm_list_2 (msg_string
, form
);
268 scm_error (syntax_error_key
, "memoization", format
, args
, SCM_BOOL_F
);
272 /* Shortcut macros to simplify syntax error handling. */
273 #define ASSERT_SYNTAX(cond, message, form) \
274 { if (!(cond)) syntax_error (message, form, SCM_UNDEFINED); }
275 #define ASSERT_SYNTAX_2(cond, message, form, expr) \
276 { if (!(cond)) syntax_error (message, form, expr); }
282 * Ilocs are memoized references to variables in local environment frames.
283 * They are represented as three values: The relative offset of the
284 * environment frame, the number of the binding within that frame, and a
285 * boolean value indicating whether the binding is the last binding in the
288 #define SCM_ILOC00 SCM_MAKE_ITAG8(0L, scm_tc8_iloc)
289 #define SCM_IDINC (0x00100000L)
290 #define SCM_IDSTMSK (-SCM_IDINC)
291 #define SCM_MAKE_ILOC(frame_nr, binding_nr, last_p) \
294 + ((binding_nr) << 20) \
295 + ((last_p) ? SCM_ICDR : 0) \
298 #if (SCM_DEBUG_DEBUGGING_SUPPORT == 1)
300 SCM
scm_dbg_make_iloc (SCM frame
, SCM binding
, SCM cdrp
);
301 SCM_DEFINE (scm_dbg_make_iloc
, "dbg-make-iloc", 3, 0, 0,
302 (SCM frame
, SCM binding
, SCM cdrp
),
303 "Return a new iloc with frame offset @var{frame}, binding\n"
304 "offset @var{binding} and the cdr flag @var{cdrp}.")
305 #define FUNC_NAME s_scm_dbg_make_iloc
307 SCM_VALIDATE_INUM (1, frame
);
308 SCM_VALIDATE_INUM (2, binding
);
309 return SCM_MAKE_ILOC (SCM_INUM (frame
),
315 SCM
scm_dbg_iloc_p (SCM obj
);
316 SCM_DEFINE (scm_dbg_iloc_p
, "dbg-iloc?", 1, 0, 0,
318 "Return @code{#t} if @var{obj} is an iloc.")
319 #define FUNC_NAME s_scm_dbg_iloc_p
321 return SCM_BOOL (SCM_ILOCP (obj
));
329 #define SCM_VALIDATE_NON_EMPTY_COMBINATION(x) \
331 if (SCM_EQ_P ((x), SCM_EOL)) \
332 scm_misc_error (NULL, s_expression, SCM_EOL); \
337 /* The evaluator contains a plethora of EVAL symbols.
338 * This is an attempt at explanation.
340 * The following macros should be used in code which is read twice
341 * (where the choice of evaluator is hard soldered):
343 * SCM_CEVAL is the symbol used within one evaluator to call itself.
344 * Originally, it is defined to scm_ceval, but is redefined to
345 * scm_deval during the second pass.
347 * SCM_EVALIM is used when it is known that the expression is an
348 * immediate. (This macro never calls an evaluator.)
350 * EVALCAR evaluates the car of an expression.
352 * The following macros should be used in code which is read once
353 * (where the choice of evaluator is dynamic):
355 * SCM_XEVAL takes care of immediates without calling an evaluator. It
356 * then calls scm_ceval *or* scm_deval, depending on the debugging
359 * SCM_XEVALCAR corresponds to EVALCAR, but uses scm_ceval *or* scm_deval
360 * depending on the debugging mode.
362 * The main motivation for keeping this plethora is efficiency
363 * together with maintainability (=> locality of code).
366 #define SCM_CEVAL scm_ceval
368 #define SCM_EVALIM2(x) \
369 ((SCM_EQ_P ((x), SCM_EOL) \
370 ? scm_misc_error (NULL, s_expression, SCM_EOL), 0 \
374 #define SCM_EVALIM(x, env) (SCM_ILOCP (x) \
375 ? *scm_ilookup ((x), env) \
378 #define SCM_XEVAL(x, env) (SCM_IMP (x) \
380 : (*scm_ceval_ptr) ((x), (env)))
382 #define SCM_XEVALCAR(x, env) (SCM_IMP (SCM_CAR (x)) \
383 ? SCM_EVALIM (SCM_CAR (x), env) \
384 : (SCM_SYMBOLP (SCM_CAR (x)) \
385 ? *scm_lookupcar (x, env, 1) \
386 : (*scm_ceval_ptr) (SCM_CAR (x), env)))
388 #define EVALCAR(x, env) (SCM_IMP (SCM_CAR (x)) \
389 ? SCM_EVALIM (SCM_CAR (x), env) \
390 : (SCM_SYMBOLP (SCM_CAR (x)) \
391 ? *scm_lookupcar (x, env, 1) \
392 : SCM_CEVAL (SCM_CAR (x), env)))
394 SCM_REC_MUTEX (source_mutex
);
397 static const char s_expression
[] = "missing or extra expression";
398 static const char s_test
[] = "bad test";
399 static const char s_body
[] = "bad body";
400 static const char s_bindings
[] = "bad bindings";
401 static const char s_duplicate_bindings
[] = "duplicate bindings";
402 static const char s_variable
[] = "bad variable";
403 static const char s_splicing
[] = "bad (non-list) result for unquote-splicing";
406 /* Lookup a given local variable in an environment. The local variable is
407 * given as an iloc, that is a triple <frame, binding, last?>, where frame
408 * indicates the relative number of the environment frame (counting upwards
409 * from the innermost environment frame), binding indicates the number of the
410 * binding within the frame, and last? (which is extracted from the iloc using
411 * the macro SCM_ICDRP) indicates whether the binding forms the binding at the
412 * very end of the improper list of bindings. */
414 scm_ilookup (SCM iloc
, SCM env
)
416 unsigned int frame_nr
= SCM_IFRAME (iloc
);
417 unsigned int binding_nr
= SCM_IDIST (iloc
);
421 for (; 0 != frame_nr
; --frame_nr
)
422 frames
= SCM_CDR (frames
);
424 bindings
= SCM_CAR (frames
);
425 for (; 0 != binding_nr
; --binding_nr
)
426 bindings
= SCM_CDR (bindings
);
428 if (SCM_ICDRP (iloc
))
429 return SCM_CDRLOC (bindings
);
430 return SCM_CARLOC (SCM_CDR (bindings
));
434 /* The Lookup Car Race
437 Memoization of variables and special forms is done while executing
438 the code for the first time. As long as there is only one thread
439 everything is fine, but as soon as two threads execute the same
440 code concurrently `for the first time' they can come into conflict.
442 This memoization includes rewriting variable references into more
443 efficient forms and expanding macros. Furthermore, macro expansion
444 includes `compiling' special forms like `let', `cond', etc. into
445 tree-code instructions.
447 There shouldn't normally be a problem with memoizing local and
448 global variable references (into ilocs and variables), because all
449 threads will mutate the code in *exactly* the same way and (if I
450 read the C code correctly) it is not possible to observe a half-way
451 mutated cons cell. The lookup procedure can handle this
452 transparently without any critical sections.
454 It is different with macro expansion, because macro expansion
455 happens outside of the lookup procedure and can't be
456 undone. Therefore the lookup procedure can't cope with it. It has
457 to indicate failure when it detects a lost race and hope that the
458 caller can handle it. Luckily, it turns out that this is the case.
460 An example to illustrate this: Suppose that the following form will
461 be memoized concurrently by two threads
465 Let's first examine the lookup of X in the body. The first thread
466 decides that it has to find the symbol "x" in the environment and
467 starts to scan it. Then the other thread takes over and actually
468 overtakes the first. It looks up "x" and substitutes an
469 appropriate iloc for it. Now the first thread continues and
470 completes its lookup. It comes to exactly the same conclusions as
471 the second one and could - without much ado - just overwrite the
472 iloc with the same iloc.
474 But let's see what will happen when the race occurs while looking
475 up the symbol "let" at the start of the form. It could happen that
476 the second thread interrupts the lookup of the first thread and not
477 only substitutes a variable for it but goes right ahead and
478 replaces it with the compiled form (#@let* (x 12) x). Now, when
479 the first thread completes its lookup, it would replace the #@let*
480 with a variable containing the "let" binding, effectively reverting
481 the form to (let (x 12) x). This is wrong. It has to detect that
482 it has lost the race and the evaluator has to reconsider the
483 changed form completely.
485 This race condition could be resolved with some kind of traffic
486 light (like mutexes) around scm_lookupcar, but I think that it is
487 best to avoid them in this case. They would serialize memoization
488 completely and because lookup involves calling arbitrary Scheme
489 code (via the lookup-thunk), threads could be blocked for an
490 arbitrary amount of time or even deadlock. But with the current
491 solution a lot of unnecessary work is potentially done. */
493 /* SCM_LOOKUPCAR1 is what SCM_LOOKUPCAR used to be but is allowed to
494 return NULL to indicate a failed lookup due to some race conditions
495 between threads. This only happens when VLOC is the first cell of
496 a special form that will eventually be memoized (like `let', etc.)
497 In that case the whole lookup is bogus and the caller has to
498 reconsider the complete special form.
500 SCM_LOOKUPCAR is still there, of course. It just calls
501 SCM_LOOKUPCAR1 and aborts on receiving NULL. So SCM_LOOKUPCAR
502 should only be called when it is known that VLOC is not the first
503 pair of a special form. Otherwise, use SCM_LOOKUPCAR1 and check
504 for NULL. I think I've found the only places where this
507 SCM_SYMBOL (scm_unbound_variable_key
, "unbound-variable");
510 scm_lookupcar1 (SCM vloc
, SCM genv
, int check
)
513 register SCM
*al
, fl
, var
= SCM_CAR (vloc
);
514 register SCM iloc
= SCM_ILOC00
;
515 for (; SCM_NIMP (env
); env
= SCM_CDR (env
))
517 if (!SCM_CONSP (SCM_CAR (env
)))
519 al
= SCM_CARLOC (env
);
520 for (fl
= SCM_CAR (*al
); SCM_NIMP (fl
); fl
= SCM_CDR (fl
))
524 if (SCM_EQ_P (fl
, var
))
526 if (! SCM_EQ_P (SCM_CAR (vloc
), var
))
528 SCM_SET_CELL_WORD_0 (vloc
, SCM_UNPACK (iloc
) + SCM_ICDR
);
529 return SCM_CDRLOC (*al
);
534 al
= SCM_CDRLOC (*al
);
535 if (SCM_EQ_P (SCM_CAR (fl
), var
))
537 if (SCM_UNBNDP (SCM_CAR (*al
)))
542 if (!SCM_EQ_P (SCM_CAR (vloc
), var
))
544 SCM_SETCAR (vloc
, iloc
);
545 return SCM_CARLOC (*al
);
547 iloc
= SCM_PACK (SCM_UNPACK (iloc
) + SCM_IDINC
);
549 iloc
= SCM_PACK ((~SCM_IDSTMSK
) & (SCM_UNPACK(iloc
) + SCM_IFRINC
));
552 SCM top_thunk
, real_var
;
555 top_thunk
= SCM_CAR (env
); /* env now refers to a
556 top level env thunk */
560 top_thunk
= SCM_BOOL_F
;
561 real_var
= scm_sym2var (var
, top_thunk
, SCM_BOOL_F
);
562 if (SCM_FALSEP (real_var
))
565 if (!SCM_NULLP (env
) || SCM_UNBNDP (SCM_VARIABLE_REF (real_var
)))
571 scm_error (scm_unbound_variable_key
, NULL
,
572 "Unbound variable: ~S",
573 scm_list_1 (var
), SCM_BOOL_F
);
575 scm_misc_error (NULL
, "Damaged environment: ~S",
580 /* A variable could not be found, but we shall
581 not throw an error. */
582 static SCM undef_object
= SCM_UNDEFINED
;
583 return &undef_object
;
587 if (!SCM_EQ_P (SCM_CAR (vloc
), var
))
589 /* Some other thread has changed the very cell we are working
590 on. In effect, it must have done our job or messed it up
593 var
= SCM_CAR (vloc
);
594 if (SCM_VARIABLEP (var
))
595 return SCM_VARIABLE_LOC (var
);
596 if (SCM_ITAG7 (var
) == SCM_ITAG7 (SCM_ILOC00
))
597 return scm_ilookup (var
, genv
);
598 /* We can't cope with anything else than variables and ilocs. When
599 a special form has been memoized (i.e. `let' into `#@let') we
600 return NULL and expect the calling function to do the right
601 thing. For the evaluator, this means going back and redoing
602 the dispatch on the car of the form. */
606 SCM_SETCAR (vloc
, real_var
);
607 return SCM_VARIABLE_LOC (real_var
);
612 scm_lookupcar (SCM vloc
, SCM genv
, int check
)
614 SCM
*loc
= scm_lookupcar1 (vloc
, genv
, check
);
620 /* Return true if the symbol is - from the point of view of a macro
621 * transformer - a literal in the sense specified in chapter "pattern
622 * language" of R5RS. In the code below, however, we don't match the
623 * definition of R5RS exactly: It returns true if the identifier has no
624 * binding or if it is a syntactic keyword. */
626 literal_p (const SCM symbol
, const SCM env
)
628 const SCM x
= scm_cons (symbol
, SCM_UNDEFINED
);
629 const SCM value
= *scm_lookupcar (x
, env
, 0);
630 if (SCM_UNBNDP (value
) || SCM_MACROP (value
))
636 #define unmemocar scm_unmemocar
638 SCM_SYMBOL (sym_three_question_marks
, "???");
641 scm_unmemocar (SCM form
, SCM env
)
643 if (!SCM_CONSP (form
))
647 SCM c
= SCM_CAR (form
);
648 if (SCM_VARIABLEP (c
))
650 SCM sym
= scm_module_reverse_lookup (scm_env_module (env
), c
);
651 if (SCM_FALSEP (sym
))
652 sym
= sym_three_question_marks
;
653 SCM_SETCAR (form
, sym
);
655 else if (SCM_ILOCP (c
))
657 unsigned long int ir
;
659 for (ir
= SCM_IFRAME (c
); ir
!= 0; --ir
)
661 env
= SCM_CAAR (env
);
662 for (ir
= SCM_IDIST (c
); ir
!= 0; --ir
)
664 SCM_SETCAR (form
, SCM_ICDRP (c
) ? env
: SCM_CAR (env
));
672 scm_eval_car (SCM pair
, SCM env
)
674 return SCM_XEVALCAR (pair
, env
);
679 * The following rewrite expressions and
680 * some memoized forms have different syntax
683 SCM_GLOBAL_SYMBOL (scm_sym_else
, "else");
684 SCM_GLOBAL_SYMBOL (scm_sym_unquote
, "unquote");
685 SCM_GLOBAL_SYMBOL (scm_sym_uq_splicing
, "unquote-splicing");
687 SCM_GLOBAL_SYMBOL (scm_sym_enter_frame
, "enter-frame");
688 SCM_GLOBAL_SYMBOL (scm_sym_apply_frame
, "apply-frame");
689 SCM_GLOBAL_SYMBOL (scm_sym_exit_frame
, "exit-frame");
690 SCM_GLOBAL_SYMBOL (scm_sym_trace
, "trace");
693 /* Check that the body denoted by XORIG is valid and rewrite it into
694 its internal form. The internal form of a body is just the body
695 itself, but prefixed with an ISYM that denotes to what kind of
696 outer construct this body belongs. A lambda body starts with
697 SCM_IM_LAMBDA, for example, a body of a let starts with SCM_IM_LET,
698 etc. The one exception is a body that belongs to a letrec that has
699 been formed by rewriting internal defines: it starts with
702 /* XXX - Besides controlling the rewriting of internal defines, the
703 additional ISYM could be used for improved error messages.
704 This is not done yet. */
707 scm_m_body (SCM op
, SCM xorig
, const char *what
)
709 SCM_ASSYNT (scm_ilength (xorig
) >= 1, s_body
, what
);
711 /* Don't add another ISYM if one is present already. */
712 if (SCM_ISYMP (SCM_CAR (xorig
)))
715 /* Retain possible doc string. */
716 if (!SCM_CONSP (SCM_CAR (xorig
)))
718 if (!SCM_NULLP (SCM_CDR (xorig
)))
719 return scm_cons (SCM_CAR (xorig
),
720 scm_m_body (op
, SCM_CDR (xorig
), what
));
724 return scm_cons (op
, xorig
);
728 /* Start of the memoizers for the standard R5RS builtin macros. */
731 SCM_SYNTAX (s_and
, "and", scm_i_makbimacro
, scm_m_and
);
732 SCM_GLOBAL_SYMBOL (scm_sym_and
, s_and
);
735 scm_m_and (SCM expr
, SCM env SCM_UNUSED
)
737 const SCM cdr_expr
= SCM_CDR (expr
);
738 const long length
= scm_ilength (cdr_expr
);
740 ASSERT_SYNTAX (length
>= 0, s_bad_expression
, expr
);
744 /* Special case: (and) is replaced by #t. */
749 SCM_SETCAR (expr
, SCM_IM_AND
);
755 SCM_SYNTAX (s_begin
, "begin", scm_i_makbimacro
, scm_m_begin
);
756 SCM_GLOBAL_SYMBOL (scm_sym_begin
, s_begin
);
759 scm_m_begin (SCM expr
, SCM env SCM_UNUSED
)
761 const SCM cdr_expr
= SCM_CDR (expr
);
762 /* Dirk:FIXME:: An empty begin clause is not generally allowed by R5RS.
763 * That means, there should be a distinction between uses of begin where an
764 * empty clause is OK and where it is not. */
765 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 0, s_bad_expression
, expr
);
767 SCM_SETCAR (expr
, SCM_IM_BEGIN
);
772 SCM_SYNTAX (s_case
, "case", scm_i_makbimacro
, scm_m_case
);
773 SCM_GLOBAL_SYMBOL (scm_sym_case
, s_case
);
776 scm_m_case (SCM expr
, SCM env
)
779 SCM all_labels
= SCM_EOL
;
781 /* Check, whether 'else is a literal, i. e. not bound to a value. */
782 const int else_literal_p
= literal_p (scm_sym_else
, env
);
784 const SCM cdr_expr
= SCM_CDR (expr
);
785 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 0, s_bad_expression
, expr
);
786 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 2, s_missing_clauses
, expr
);
788 clauses
= SCM_CDR (cdr_expr
);
789 while (!SCM_NULLP (clauses
))
793 const SCM clause
= SCM_CAR (clauses
);
794 ASSERT_SYNTAX_2 (scm_ilength (clause
) >= 2,
795 s_bad_case_clause
, clause
, expr
);
797 labels
= SCM_CAR (clause
);
798 if (SCM_CONSP (labels
))
800 ASSERT_SYNTAX_2 (scm_ilength (labels
) >= 0,
801 s_bad_case_labels
, labels
, expr
);
802 all_labels
= scm_append_x (scm_list_2 (labels
, all_labels
));
804 else if (SCM_NULLP (labels
))
806 /* The list of labels is empty. According to R5RS this is allowed.
807 * It means that the sequence of expressions will never be executed.
808 * Therefore, as an optimization, we could remove the whole
813 ASSERT_SYNTAX_2 (SCM_EQ_P (labels
, scm_sym_else
) && else_literal_p
,
814 s_bad_case_labels
, labels
, expr
);
815 ASSERT_SYNTAX_2 (SCM_NULLP (SCM_CDR (clauses
)),
816 s_misplaced_else_clause
, clause
, expr
);
819 /* build the new clause */
820 if (SCM_EQ_P (labels
, scm_sym_else
))
821 SCM_SETCAR (clause
, SCM_IM_ELSE
);
823 clauses
= SCM_CDR (clauses
);
826 /* Check whether all case labels are distinct. */
827 for (; !SCM_NULLP (all_labels
); all_labels
= SCM_CDR (all_labels
))
829 const SCM label
= SCM_CAR (all_labels
);
830 ASSERT_SYNTAX_2 (SCM_FALSEP (scm_c_memq (label
, SCM_CDR (all_labels
))),
831 s_duplicate_case_label
, label
, expr
);
834 SCM_SETCAR (expr
, SCM_IM_CASE
);
839 SCM_SYNTAX (s_cond
, "cond", scm_i_makbimacro
, scm_m_cond
);
840 SCM_GLOBAL_SYMBOL (scm_sym_cond
, s_cond
);
841 SCM_GLOBAL_SYMBOL (scm_sym_arrow
, "=>");
844 scm_m_cond (SCM expr
, SCM env
)
846 /* Check, whether 'else or '=> is a literal, i. e. not bound to a value. */
847 const int else_literal_p
= literal_p (scm_sym_else
, env
);
848 const int arrow_literal_p
= literal_p (scm_sym_arrow
, env
);
850 const SCM clauses
= SCM_CDR (expr
);
853 ASSERT_SYNTAX (scm_ilength (clauses
) >= 0, s_bad_expression
, expr
);
854 ASSERT_SYNTAX (scm_ilength (clauses
) >= 1, s_missing_clauses
, expr
);
856 for (clause_idx
= clauses
;
857 !SCM_NULLP (clause_idx
);
858 clause_idx
= SCM_CDR (clause_idx
))
862 const SCM clause
= SCM_CAR (clause_idx
);
863 const long length
= scm_ilength (clause
);
864 ASSERT_SYNTAX_2 (length
>= 1, s_bad_cond_clause
, clause
, expr
);
866 test
= SCM_CAR (clause
);
867 if (SCM_EQ_P (test
, scm_sym_else
) && else_literal_p
)
869 const int last_clause_p
= SCM_NULLP (SCM_CDR (clause_idx
));
870 ASSERT_SYNTAX_2 (length
>= 2,
871 s_bad_cond_clause
, clause
, expr
);
872 ASSERT_SYNTAX_2 (last_clause_p
,
873 s_misplaced_else_clause
, clause
, expr
);
874 SCM_SETCAR (clause
, SCM_IM_ELSE
);
877 && SCM_EQ_P (SCM_CADR (clause
), scm_sym_arrow
)
880 ASSERT_SYNTAX_2 (length
> 2, s_missing_recipient
, clause
, expr
);
881 ASSERT_SYNTAX_2 (length
== 3, s_extra_expression
, clause
, expr
);
882 SCM_SETCAR (SCM_CDR (clause
), SCM_IM_ARROW
);
886 SCM_SETCAR (expr
, SCM_IM_COND
);
891 SCM_SYNTAX(s_define
, "define", scm_i_makbimacro
, scm_m_define
);
892 SCM_GLOBAL_SYMBOL(scm_sym_define
, s_define
);
894 /* Guile provides an extension to R5RS' define syntax to represent function
895 * currying in a compact way. With this extension, it is allowed to write
896 * (define <nested-variable> <body>), where <nested-variable> has of one of
897 * the forms (<nested-variable> <formals>), (<nested-variable> . <formal>),
898 * (<variable> <formals>) or (<variable> . <formal>). As in R5RS, <formals>
899 * should be either a sequence of zero or more variables, or a sequence of one
900 * or more variables followed by a space-delimited period and another
901 * variable. Each level of argument nesting wraps the <body> within another
902 * lambda expression. For example, the following forms are allowed, each one
903 * followed by an equivalent, more explicit implementation.
905 * (define ((a b . c) . d) <body>) is equivalent to
906 * (define a (lambda (b . c) (lambda d <body>)))
908 * (define (((a) b) c . d) <body>) is equivalent to
909 * (define a (lambda () (lambda (b) (lambda (c . d) <body>))))
911 /* Dirk:FIXME:: We should provide an implementation for 'define' in the R5RS
912 * module that does not implement this extension. */
914 scm_m_define (SCM expr
, SCM env
)
919 const SCM cdr_expr
= SCM_CDR (expr
);
920 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 0, s_bad_expression
, expr
);
921 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 2, s_missing_expression
, expr
);
923 body
= SCM_CDR (cdr_expr
);
924 variable
= SCM_CAR (cdr_expr
);
925 while (SCM_CONSP (variable
))
927 /* This while loop realizes function currying by variable nesting.
928 * Variable is known to be a nested-variable. In every iteration of the
929 * loop another level of lambda expression is created, starting with the
930 * innermost one. Note that we don't check for duplicate formals here:
931 * This will be done by the memoizer of the lambda expression. */
932 const SCM formals
= SCM_CDR (variable
);
933 const SCM tail
= scm_cons (formals
, body
);
935 /* Add source properties to each new lambda expression: */
936 const SCM lambda
= scm_cons_source (variable
, scm_sym_lambda
, tail
);
938 body
= scm_list_1 (lambda
);
939 variable
= SCM_CAR (variable
);
941 ASSERT_SYNTAX_2 (SCM_SYMBOLP (variable
), s_bad_variable
, variable
, expr
);
942 ASSERT_SYNTAX (scm_ilength (body
) == 1, s_expression
, expr
);
944 if (SCM_TOP_LEVEL (env
))
947 const SCM value
= scm_eval_car (body
, env
);
948 if (SCM_REC_PROCNAMES_P
)
951 while (SCM_MACROP (tmp
))
952 tmp
= SCM_MACRO_CODE (tmp
);
953 if (SCM_CLOSUREP (tmp
)
954 /* Only the first definition determines the name. */
955 && SCM_FALSEP (scm_procedure_property (tmp
, scm_sym_name
)))
956 scm_set_procedure_property_x (tmp
, scm_sym_name
, variable
);
958 var
= scm_sym2var (variable
, scm_env_top_level (env
), SCM_BOOL_T
);
959 SCM_VARIABLE_SET (var
, value
);
960 return SCM_UNSPECIFIED
;
964 SCM_SETCAR (expr
, SCM_IM_DEFINE
);
965 SCM_SETCAR (cdr_expr
, variable
);
966 SCM_SETCDR (cdr_expr
, body
);
972 /* This is a helper function for forms (<keyword> <expression>) that are
973 * transformed into (#@<keyword> '() <memoized_expression>) in order to allow
974 * for easy creation of a thunk (i. e. a closure without arguments) using the
975 * ('() <memoized_expression>) tail of the memoized form. */
977 memoize_as_thunk_prototype (const SCM expr
, const SCM env SCM_UNUSED
)
979 const SCM cdr_expr
= SCM_CDR (expr
);
980 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 0, s_bad_expression
, expr
);
981 ASSERT_SYNTAX (scm_ilength (cdr_expr
) == 1, s_expression
, expr
);
983 SCM_SETCDR (expr
, scm_cons (SCM_EOL
, cdr_expr
));
989 SCM_SYNTAX (s_delay
, "delay", scm_i_makbimacro
, scm_m_delay
);
990 SCM_GLOBAL_SYMBOL (scm_sym_delay
, s_delay
);
992 /* Promises are implemented as closures with an empty parameter list. Thus,
993 * (delay <expression>) is transformed into (#@delay '() <expression>), where
994 * the empty list represents the empty parameter list. This representation
995 * allows for easy creation of the closure during evaluation. */
997 scm_m_delay (SCM expr
, SCM env
)
999 const SCM new_expr
= memoize_as_thunk_prototype (expr
, env
);
1000 SCM_SETCAR (new_expr
, SCM_IM_DELAY
);
1005 SCM_SYNTAX(s_do
, "do", scm_i_makbimacro
, scm_m_do
);
1006 SCM_GLOBAL_SYMBOL(scm_sym_do
, s_do
);
1008 /* DO gets the most radically altered syntax. The order of the vars is
1009 * reversed here. During the evaluation this allows for simple consing of the
1010 * results of the inits and steps:
1012 (do ((<var1> <init1> <step1>)
1020 (#@do (<init1> <init2> ... <initn>)
1021 (varn ... var2 var1)
1024 <step1> <step2> ... <stepn>) ;; missing steps replaced by var
1027 scm_m_do (SCM expr
, SCM env SCM_UNUSED
)
1029 SCM variables
= SCM_EOL
;
1030 SCM init_forms
= SCM_EOL
;
1031 SCM step_forms
= SCM_EOL
;
1038 const SCM cdr_expr
= SCM_CDR (expr
);
1039 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 0, s_bad_expression
, expr
);
1040 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 2, s_missing_expression
, expr
);
1042 /* Collect variables, init and step forms. */
1043 binding_idx
= SCM_CAR (cdr_expr
);
1044 ASSERT_SYNTAX_2 (scm_ilength (binding_idx
) >= 0,
1045 s_bad_bindings
, binding_idx
, expr
);
1046 for (; !SCM_NULLP (binding_idx
); binding_idx
= SCM_CDR (binding_idx
))
1048 const SCM binding
= SCM_CAR (binding_idx
);
1049 const long length
= scm_ilength (binding
);
1050 ASSERT_SYNTAX_2 (length
== 2 || length
== 3,
1051 s_bad_binding
, binding
, expr
);
1054 const SCM name
= SCM_CAR (binding
);
1055 const SCM init
= SCM_CADR (binding
);
1056 const SCM step
= (length
== 2) ? name
: SCM_CADDR (binding
);
1057 ASSERT_SYNTAX_2 (SCM_SYMBOLP (name
), s_bad_variable
, name
, expr
);
1058 ASSERT_SYNTAX_2 (SCM_FALSEP (scm_c_memq (name
, variables
)),
1059 s_duplicate_binding
, name
, expr
);
1061 variables
= scm_cons (name
, variables
);
1062 init_forms
= scm_cons (init
, init_forms
);
1063 step_forms
= scm_cons (step
, step_forms
);
1066 init_forms
= scm_reverse_x (init_forms
, SCM_UNDEFINED
);
1067 step_forms
= scm_reverse_x (step_forms
, SCM_UNDEFINED
);
1069 /* Memoize the test form and the exit sequence. */
1070 cddr_expr
= SCM_CDR (cdr_expr
);
1071 exit_clause
= SCM_CAR (cddr_expr
);
1072 ASSERT_SYNTAX_2 (scm_ilength (exit_clause
) >= 1,
1073 s_bad_exit_clause
, exit_clause
, expr
);
1075 commands
= SCM_CDR (cddr_expr
);
1076 tail
= scm_cons2 (exit_clause
, commands
, step_forms
);
1077 tail
= scm_cons2 (init_forms
, variables
, tail
);
1078 SCM_SETCAR (expr
, SCM_IM_DO
);
1079 SCM_SETCDR (expr
, tail
);
1084 SCM_SYNTAX (s_if
, "if", scm_i_makbimacro
, scm_m_if
);
1085 SCM_GLOBAL_SYMBOL (scm_sym_if
, s_if
);
1088 scm_m_if (SCM expr
, SCM env SCM_UNUSED
)
1090 const SCM cdr_expr
= SCM_CDR (expr
);
1091 const long length
= scm_ilength (cdr_expr
);
1092 ASSERT_SYNTAX (length
== 2 || length
== 3, s_expression
, expr
);
1093 SCM_SETCAR (expr
, SCM_IM_IF
);
1098 SCM_SYNTAX (s_lambda
, "lambda", scm_i_makbimacro
, scm_m_lambda
);
1099 SCM_GLOBAL_SYMBOL (scm_sym_lambda
, s_lambda
);
1101 /* A helper function for memoize_lambda to support checking for duplicate
1102 * formal arguments: Return true if OBJ is `eq?' to one of the elements of
1103 * LIST or to the cdr of the last cons. Therefore, LIST may have any of the
1104 * forms that a formal argument can have:
1105 * <rest>, (<arg1> ...), (<arg1> ... . <rest>) */
1107 c_improper_memq (SCM obj
, SCM list
)
1109 for (; SCM_CONSP (list
); list
= SCM_CDR (list
))
1111 if (SCM_EQ_P (SCM_CAR (list
), obj
))
1114 return SCM_EQ_P (list
, obj
);
1118 scm_m_lambda (SCM expr
, SCM env SCM_UNUSED
)
1123 const SCM cdr_expr
= SCM_CDR (expr
);
1124 const long length
= scm_ilength (cdr_expr
);
1125 ASSERT_SYNTAX (length
>= 0, s_bad_expression
, expr
);
1126 ASSERT_SYNTAX (length
>= 2, s_missing_expression
, expr
);
1128 /* Before iterating the list of formal arguments, make sure the formals
1129 * actually are given as either a symbol or a non-cyclic list. */
1130 formals
= SCM_CAR (cdr_expr
);
1131 if (SCM_CONSP (formals
))
1133 /* Dirk:FIXME:: We should check for a cyclic list of formals, and if
1134 * detected, report a 'Bad formals' error. */
1138 ASSERT_SYNTAX_2 (SCM_SYMBOLP (formals
) || SCM_NULLP (formals
),
1139 s_bad_formals
, formals
, expr
);
1142 /* Now iterate the list of formal arguments to check if all formals are
1143 * symbols, and that there are no duplicates. */
1144 formals_idx
= formals
;
1145 while (SCM_CONSP (formals_idx
))
1147 const SCM formal
= SCM_CAR (formals_idx
);
1148 const SCM next_idx
= SCM_CDR (formals_idx
);
1149 ASSERT_SYNTAX_2 (SCM_SYMBOLP (formal
), s_bad_formal
, formal
, expr
);
1150 ASSERT_SYNTAX_2 (!c_improper_memq (formal
, next_idx
),
1151 s_duplicate_formal
, formal
, expr
);
1152 formals_idx
= next_idx
;
1154 ASSERT_SYNTAX_2 (SCM_NULLP (formals_idx
) || SCM_SYMBOLP (formals_idx
),
1155 s_bad_formal
, formals_idx
, expr
);
1157 return scm_cons2 (SCM_IM_LAMBDA
, SCM_CAR (cdr_expr
),
1158 scm_m_body (SCM_IM_LAMBDA
, SCM_CDR (cdr_expr
), s_lambda
));
1162 /* Check if the format of the bindings is ((<symbol> <init-form>) ...). */
1164 check_bindings (const SCM bindings
, const SCM expr
)
1168 ASSERT_SYNTAX_2 (scm_ilength (bindings
) >= 0,
1169 s_bad_bindings
, bindings
, expr
);
1171 binding_idx
= bindings
;
1172 for (; !SCM_NULLP (binding_idx
); binding_idx
= SCM_CDR (binding_idx
))
1174 SCM name
; /* const */
1176 const SCM binding
= SCM_CAR (binding_idx
);
1177 ASSERT_SYNTAX_2 (scm_ilength (binding
) == 2,
1178 s_bad_binding
, binding
, expr
);
1180 name
= SCM_CAR (binding
);
1181 ASSERT_SYNTAX_2 (SCM_SYMBOLP (name
), s_bad_variable
, name
, expr
);
1186 /* The bindings, which must have the format ((v1 i1) (v2 i2) ... (vn in)), are
1187 * transformed to the lists (vn ... v2 v1) and (i1 i2 ... in). That is, the
1188 * variables are returned in a list with their order reversed, and the init
1189 * forms are returned in a list in the same order as they are given in the
1190 * bindings. If a duplicate variable name is detected, an error is
1193 transform_bindings (
1194 const SCM bindings
, const SCM expr
,
1195 SCM
*const rvarptr
, SCM
*const initptr
)
1197 SCM rvariables
= SCM_EOL
;
1198 SCM rinits
= SCM_EOL
;
1199 SCM binding_idx
= bindings
;
1200 for (; !SCM_NULLP (binding_idx
); binding_idx
= SCM_CDR (binding_idx
))
1202 const SCM binding
= SCM_CAR (binding_idx
);
1203 const SCM cdr_binding
= SCM_CDR (binding
);
1204 const SCM name
= SCM_CAR (binding
);
1205 ASSERT_SYNTAX_2 (SCM_FALSEP (scm_c_memq (name
, rvariables
)),
1206 s_duplicate_binding
, name
, expr
);
1207 rvariables
= scm_cons (name
, rvariables
);
1208 rinits
= scm_cons (SCM_CAR (cdr_binding
), rinits
);
1210 *rvarptr
= rvariables
;
1211 *initptr
= scm_reverse_x (rinits
, SCM_UNDEFINED
);
1215 SCM_SYNTAX(s_let
, "let", scm_i_makbimacro
, scm_m_let
);
1216 SCM_GLOBAL_SYMBOL(scm_sym_let
, s_let
);
1218 /* This function is a helper function for memoize_let. It transforms
1219 * (let name ((var init) ...) body ...) into
1220 * ((letrec ((name (lambda (var ...) body ...))) name) init ...)
1221 * and memoizes the expression. It is assumed that the caller has checked
1222 * that name is a symbol and that there are bindings and a body. */
1224 memoize_named_let (const SCM expr
, const SCM env SCM_UNUSED
)
1230 const SCM cdr_expr
= SCM_CDR (expr
);
1231 const SCM name
= SCM_CAR (cdr_expr
);
1232 const SCM cddr_expr
= SCM_CDR (cdr_expr
);
1233 const SCM bindings
= SCM_CAR (cddr_expr
);
1234 check_bindings (bindings
, expr
);
1236 transform_bindings (bindings
, expr
, &rvariables
, &inits
);
1237 variables
= scm_reverse_x (rvariables
, SCM_UNDEFINED
);
1240 const SCM let_body
= SCM_CDR (cddr_expr
);
1241 const SCM lambda_body
= scm_m_body (SCM_IM_LET
, let_body
, "let");
1242 const SCM lambda_tail
= scm_cons (variables
, lambda_body
);
1243 const SCM lambda_form
= scm_cons_source (expr
, scm_sym_lambda
, lambda_tail
);
1245 const SCM rvar
= scm_list_1 (name
);
1246 const SCM init
= scm_list_1 (lambda_form
);
1247 const SCM body
= scm_m_body (SCM_IM_LET
, scm_list_1 (name
), "let");
1248 const SCM letrec_tail
= scm_cons (rvar
, scm_cons (init
, body
));
1249 const SCM letrec_form
= scm_cons_source (expr
, SCM_IM_LETREC
, letrec_tail
);
1250 return scm_cons_source (expr
, letrec_form
, inits
);
1254 /* (let ((v1 i1) (v2 i2) ...) body) with variables v1 .. vn and initializers
1255 * i1 .. in is transformed to (#@let (vn ... v2 v1) (i1 i2 ...) body). */
1257 scm_m_let (SCM expr
, SCM env
)
1261 const SCM cdr_expr
= SCM_CDR (expr
);
1262 const long length
= scm_ilength (cdr_expr
);
1263 ASSERT_SYNTAX (length
>= 0, s_bad_expression
, expr
);
1264 ASSERT_SYNTAX (length
>= 2, s_missing_expression
, expr
);
1266 bindings
= SCM_CAR (cdr_expr
);
1267 if (SCM_SYMBOLP (bindings
))
1269 ASSERT_SYNTAX (length
>= 3, s_missing_expression
, expr
);
1270 return memoize_named_let (expr
, env
);
1273 check_bindings (bindings
, expr
);
1274 if (SCM_NULLP (bindings
) || SCM_NULLP (SCM_CDR (bindings
)))
1276 /* Special case: no bindings or single binding => let* is faster. */
1277 const SCM body
= scm_m_body (SCM_IM_LET
, SCM_CDR (cdr_expr
), s_let
);
1278 return scm_m_letstar (scm_cons2 (SCM_CAR (expr
), bindings
, body
), env
);
1285 transform_bindings (bindings
, expr
, &rvariables
, &inits
);
1288 const SCM new_body
= scm_m_body (SCM_IM_LET
, SCM_CDR (cdr_expr
), "let");
1289 const SCM new_tail
= scm_cons2 (rvariables
, inits
, new_body
);
1290 SCM_SETCAR (expr
, SCM_IM_LET
);
1291 SCM_SETCDR (expr
, new_tail
);
1298 SCM_SYNTAX (s_letstar
, "let*", scm_i_makbimacro
, scm_m_letstar
);
1299 SCM_GLOBAL_SYMBOL (scm_sym_letstar
, s_letstar
);
1301 /* (let* ((v1 i1) (v2 i2) ...) body) with variables v1 .. vn and initializers
1302 * i1 .. in is transformed into the form (#@let* (v1 i1 v2 i2 ...) body). */
1304 scm_m_letstar (SCM expr
, SCM env SCM_UNUSED
)
1307 SCM new_bindings
= SCM_EOL
;
1310 const SCM cdr_expr
= SCM_CDR (expr
);
1311 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 0, s_bad_expression
, expr
);
1312 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 2, s_missing_expression
, expr
);
1314 binding_idx
= SCM_CAR (cdr_expr
);
1315 check_bindings (binding_idx
, expr
);
1317 for (; !SCM_NULLP (binding_idx
); binding_idx
= SCM_CDR (binding_idx
))
1319 const SCM binding
= SCM_CAR (binding_idx
);
1320 const SCM name
= SCM_CAR (binding
);
1321 const SCM init
= SCM_CADR (binding
);
1322 new_bindings
= scm_cons2 (init
, name
, new_bindings
);
1324 new_bindings
= scm_reverse_x (new_bindings
, SCM_UNDEFINED
);
1326 new_body
= scm_m_body (SCM_IM_LETSTAR
, SCM_CDR (cdr_expr
), s_letstar
);
1327 return scm_cons2 (SCM_IM_LETSTAR
, new_bindings
, new_body
);
1331 SCM_SYNTAX(s_letrec
, "letrec", scm_i_makbimacro
, scm_m_letrec
);
1332 SCM_GLOBAL_SYMBOL(scm_sym_letrec
, s_letrec
);
1335 scm_m_letrec (SCM expr
, SCM env
)
1339 const SCM cdr_expr
= SCM_CDR (expr
);
1340 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 0, s_bad_expression
, expr
);
1341 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 2, s_missing_expression
, expr
);
1343 bindings
= SCM_CAR (cdr_expr
);
1344 if (SCM_NULLP (bindings
))
1346 /* no bindings, let* is executed faster */
1347 SCM body
= scm_m_body (SCM_IM_LETREC
, SCM_CDR (cdr_expr
), s_letrec
);
1348 return scm_m_letstar (scm_cons2 (SCM_CAR (expr
), SCM_EOL
, body
), env
);
1356 check_bindings (bindings
, expr
);
1357 transform_bindings (bindings
, expr
, &rvariables
, &inits
);
1358 new_body
= scm_m_body (SCM_IM_LETREC
, SCM_CDR (cdr_expr
), "letrec");
1359 return scm_cons2 (SCM_IM_LETREC
, rvariables
, scm_cons (inits
, new_body
));
1364 SCM_SYNTAX (s_or
, "or", scm_i_makbimacro
, scm_m_or
);
1365 SCM_GLOBAL_SYMBOL (scm_sym_or
, s_or
);
1368 scm_m_or (SCM expr
, SCM env SCM_UNUSED
)
1370 const SCM cdr_expr
= SCM_CDR (expr
);
1371 const long length
= scm_ilength (cdr_expr
);
1373 ASSERT_SYNTAX (length
>= 0, s_bad_expression
, expr
);
1377 /* Special case: (or) is replaced by #f. */
1382 SCM_SETCAR (expr
, SCM_IM_OR
);
1388 SCM_SYNTAX (s_quasiquote
, "quasiquote", scm_makacro
, scm_m_quasiquote
);
1389 SCM_GLOBAL_SYMBOL (scm_sym_quasiquote
, s_quasiquote
);
1391 /* Internal function to handle a quasiquotation: 'form' is the parameter in
1392 * the call (quasiquotation form), 'env' is the environment where unquoted
1393 * expressions will be evaluated, and 'depth' is the current quasiquotation
1394 * nesting level and is known to be greater than zero. */
1396 iqq (SCM form
, SCM env
, unsigned long int depth
)
1398 if (SCM_CONSP (form
))
1400 const SCM tmp
= SCM_CAR (form
);
1401 if (SCM_EQ_P (tmp
, scm_sym_quasiquote
))
1403 const SCM args
= SCM_CDR (form
);
1404 ASSERT_SYNTAX (scm_ilength (args
) == 1, s_expression
, form
);
1405 return scm_list_2 (tmp
, iqq (SCM_CAR (args
), env
, depth
+ 1));
1407 else if (SCM_EQ_P (tmp
, scm_sym_unquote
))
1409 const SCM args
= SCM_CDR (form
);
1410 ASSERT_SYNTAX (scm_ilength (args
) == 1, s_expression
, form
);
1412 return scm_eval_car (args
, env
);
1414 return scm_list_2 (tmp
, iqq (SCM_CAR (args
), env
, depth
- 1));
1416 else if (SCM_CONSP (tmp
)
1417 && SCM_EQ_P (SCM_CAR (tmp
), scm_sym_uq_splicing
))
1419 const SCM args
= SCM_CDR (tmp
);
1420 ASSERT_SYNTAX (scm_ilength (args
) == 1, s_expression
, form
);
1423 const SCM list
= scm_eval_car (args
, env
);
1424 const SCM rest
= SCM_CDR (form
);
1425 ASSERT_SYNTAX_2 (scm_ilength (list
) >= 0,
1426 s_splicing
, list
, form
);
1427 return scm_append (scm_list_2 (list
, iqq (rest
, env
, depth
)));
1430 return scm_cons (iqq (SCM_CAR (form
), env
, depth
- 1),
1431 iqq (SCM_CDR (form
), env
, depth
));
1434 return scm_cons (iqq (SCM_CAR (form
), env
, depth
),
1435 iqq (SCM_CDR (form
), env
, depth
));
1437 else if (SCM_VECTORP (form
))
1439 size_t i
= SCM_VECTOR_LENGTH (form
);
1440 SCM
const *const data
= SCM_VELTS (form
);
1443 tmp
= scm_cons (data
[--i
], tmp
);
1444 scm_remember_upto_here_1 (form
);
1445 return scm_vector (iqq (tmp
, env
, depth
));
1452 scm_m_quasiquote (SCM expr
, SCM env
)
1454 const SCM cdr_expr
= SCM_CDR (expr
);
1455 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 0, s_bad_expression
, expr
);
1456 ASSERT_SYNTAX (scm_ilength (cdr_expr
) == 1, s_expression
, expr
);
1457 return iqq (SCM_CAR (cdr_expr
), env
, 1);
1461 SCM_SYNTAX (s_quote
, "quote", scm_i_makbimacro
, scm_m_quote
);
1462 SCM_GLOBAL_SYMBOL (scm_sym_quote
, s_quote
);
1465 scm_m_quote (SCM expr
, SCM env SCM_UNUSED
)
1469 const SCM cdr_expr
= SCM_CDR (expr
);
1470 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 0, s_bad_expression
, expr
);
1471 ASSERT_SYNTAX (scm_ilength (cdr_expr
) == 1, s_expression
, expr
);
1472 quotee
= SCM_CAR (cdr_expr
);
1473 if (SCM_IMP (quotee
) && !SCM_NULLP (quotee
))
1475 else if (SCM_VECTORP (quotee
))
1478 /* The following optimization would be possible if all variable references
1479 * were resolved during memoization: */
1480 else if (SCM_SYMBOLP (quotee
))
1483 SCM_SETCAR (expr
, SCM_IM_QUOTE
);
1488 /* Will go into the RnRS module when Guile is factorized.
1489 SCM_SYNTAX (s_set_x, "set!", scm_i_makbimacro, scm_m_set_x); */
1490 static const char s_set_x
[] = "set!";
1491 SCM_GLOBAL_SYMBOL (scm_sym_set_x
, s_set_x
);
1494 scm_m_set_x (SCM expr
, SCM env SCM_UNUSED
)
1498 const SCM cdr_expr
= SCM_CDR (expr
);
1499 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 0, s_bad_expression
, expr
);
1500 ASSERT_SYNTAX (scm_ilength (cdr_expr
) == 2, s_expression
, expr
);
1501 variable
= SCM_CAR (cdr_expr
);
1502 ASSERT_SYNTAX_2 (SCM_SYMBOLP (variable
), s_bad_variable
, variable
, expr
);
1504 SCM_SETCAR (expr
, SCM_IM_SET_X
);
1509 /* Start of the memoizers for non-R5RS builtin macros. */
1512 SCM_SYNTAX (s_atapply
, "@apply", scm_i_makbimacro
, scm_m_apply
);
1513 SCM_GLOBAL_SYMBOL (scm_sym_atapply
, s_atapply
);
1514 SCM_GLOBAL_SYMBOL (scm_sym_apply
, s_atapply
+ 1);
1517 scm_m_apply (SCM expr
, SCM env SCM_UNUSED
)
1519 const SCM cdr_expr
= SCM_CDR (expr
);
1520 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 0, s_bad_expression
, expr
);
1521 ASSERT_SYNTAX (scm_ilength (cdr_expr
) == 2, s_missing_expression
, expr
);
1523 SCM_SETCAR (expr
, SCM_IM_APPLY
);
1528 SCM_SYNTAX (s_atbind
, "@bind", scm_i_makbimacro
, scm_m_atbind
);
1530 /* FIXME: The following explanation should go into the documentation: */
1531 /* (@bind ((var init) ...) body ...) will assign the values of the `init's to
1532 * the global variables named by `var's (symbols, not evaluated), creating
1533 * them if they don't exist, executes body, and then restores the previous
1534 * values of the `var's. Additionally, whenever control leaves body, the
1535 * values of the `var's are saved and restored when control returns. It is an
1536 * error when a symbol appears more than once among the `var's. All `init's
1537 * are evaluated before any `var' is set.
1539 * Think of this as `let' for dynamic scope.
1542 /* (@bind ((var1 exp1) ... (varn expn)) body ...) is memoized into
1543 * (#@bind ((varn ... var1) . (exp1 ... expn)) body ...).
1545 * FIXME - also implement `@bind*'.
1548 scm_m_atbind (SCM expr
, SCM env
)
1555 const SCM top_level
= scm_env_top_level (env
);
1557 const SCM cdr_expr
= SCM_CDR (expr
);
1558 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 0, s_bad_expression
, expr
);
1559 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 2, s_missing_expression
, expr
);
1560 bindings
= SCM_CAR (cdr_expr
);
1561 check_bindings (bindings
, expr
);
1562 transform_bindings (bindings
, expr
, &rvariables
, &inits
);
1564 for (variable_idx
= rvariables
;
1565 !SCM_NULLP (variable_idx
);
1566 variable_idx
= SCM_CDR (variable_idx
))
1568 /* The first call to scm_sym2var will look beyond the current module,
1569 * while the second call wont. */
1570 const SCM variable
= SCM_CAR (variable_idx
);
1571 SCM new_variable
= scm_sym2var (variable
, top_level
, SCM_BOOL_F
);
1572 if (SCM_FALSEP (new_variable
))
1573 new_variable
= scm_sym2var (variable
, top_level
, SCM_BOOL_T
);
1574 SCM_SETCAR (variable_idx
, new_variable
);
1577 SCM_SETCAR (expr
, SCM_IM_BIND
);
1578 SCM_SETCAR (cdr_expr
, scm_cons (rvariables
, inits
));
1583 SCM_SYNTAX(s_atcall_cc
, "@call-with-current-continuation", scm_i_makbimacro
, scm_m_cont
);
1584 SCM_GLOBAL_SYMBOL(scm_sym_atcall_cc
, s_atcall_cc
);
1587 scm_m_cont (SCM expr
, SCM env SCM_UNUSED
)
1589 const SCM cdr_expr
= SCM_CDR (expr
);
1590 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 0, s_bad_expression
, expr
);
1591 ASSERT_SYNTAX (scm_ilength (cdr_expr
) == 1, s_expression
, expr
);
1593 SCM_SETCAR (expr
, SCM_IM_CONT
);
1598 SCM_SYNTAX (s_at_call_with_values
, "@call-with-values", scm_i_makbimacro
, scm_m_at_call_with_values
);
1599 SCM_GLOBAL_SYMBOL(scm_sym_at_call_with_values
, s_at_call_with_values
);
1602 scm_m_at_call_with_values (SCM expr
, SCM env SCM_UNUSED
)
1604 const SCM cdr_expr
= SCM_CDR (expr
);
1605 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 0, s_bad_expression
, expr
);
1606 ASSERT_SYNTAX (scm_ilength (cdr_expr
) == 2, s_expression
, expr
);
1608 SCM_SETCAR (expr
, SCM_IM_CALL_WITH_VALUES
);
1613 SCM_SYNTAX (s_future
, "future", scm_i_makbimacro
, scm_m_future
);
1614 SCM_GLOBAL_SYMBOL (scm_sym_future
, s_future
);
1616 /* Like promises, futures are implemented as closures with an empty
1617 * parameter list. Thus, (future <expression>) is transformed into
1618 * (#@future '() <expression>), where the empty list represents the
1619 * empty parameter list. This representation allows for easy creation
1620 * of the closure during evaluation. */
1622 scm_m_future (SCM expr
, SCM env
)
1624 const SCM new_expr
= memoize_as_thunk_prototype (expr
, env
);
1625 SCM_SETCAR (new_expr
, SCM_IM_FUTURE
);
1630 SCM_SYNTAX (s_gset_x
, "set!", scm_i_makbimacro
, scm_m_generalized_set_x
);
1631 SCM_SYMBOL (scm_sym_setter
, "setter");
1634 scm_m_generalized_set_x (SCM expr
, SCM env SCM_UNUSED
)
1638 const SCM cdr_expr
= SCM_CDR (expr
);
1639 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 0, s_bad_expression
, expr
);
1640 ASSERT_SYNTAX (scm_ilength (cdr_expr
) == 2, s_expression
, expr
);
1642 target
= SCM_CAR (cdr_expr
);
1643 if (!SCM_CONSP (target
))
1646 return scm_m_set_x (expr
, env
);
1650 /* (set! (foo bar ...) baz) becomes ((setter foo) bar ... baz) */
1652 const SCM setter_proc_tail
= scm_list_1 (SCM_CAR (target
));
1653 const SCM setter_proc
= scm_cons_source (expr
, scm_sym_setter
, setter_proc_tail
);
1655 const SCM cddr_expr
= SCM_CDR (cdr_expr
);
1656 const SCM setter_args
= scm_append_x (scm_list_2 (SCM_CDR (target
), cddr_expr
));
1658 SCM_SETCAR (expr
, setter_proc
);
1659 SCM_SETCDR (expr
, setter_args
);
1665 /* @slot-ref is bound privately in the (oop goops) module from goops.c. As
1666 * soon as the module system allows us to more freely create bindings in
1667 * arbitrary modules during the startup phase, the code from goops.c should be
1670 scm_m_atslot_ref (SCM expr
, SCM env SCM_UNUSED
)
1674 const SCM cdr_expr
= SCM_CDR (expr
);
1675 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 0, s_bad_expression
, expr
);
1676 ASSERT_SYNTAX (scm_ilength (cdr_expr
) == 2, s_expression
, expr
);
1677 slot_nr
= SCM_CADR (cdr_expr
);
1678 ASSERT_SYNTAX_2 (SCM_INUMP (slot_nr
), s_bad_slot_number
, slot_nr
, expr
);
1680 SCM_SETCAR (expr
, SCM_IM_SLOT_REF
);
1685 /* @slot-set! is bound privately in the (oop goops) module from goops.c. As
1686 * soon as the module system allows us to more freely create bindings in
1687 * arbitrary modules during the startup phase, the code from goops.c should be
1690 scm_m_atslot_set_x (SCM expr
, SCM env SCM_UNUSED
)
1694 const SCM cdr_expr
= SCM_CDR (expr
);
1695 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 0, s_bad_expression
, expr
);
1696 ASSERT_SYNTAX (scm_ilength (cdr_expr
) == 3, s_expression
, expr
);
1697 slot_nr
= SCM_CADR (cdr_expr
);
1698 ASSERT_SYNTAX_2 (SCM_INUMP (slot_nr
), s_bad_slot_number
, slot_nr
, expr
);
1700 SCM_SETCAR (expr
, SCM_IM_SLOT_SET_X
);
1705 #if SCM_ENABLE_ELISP
1707 SCM_SYNTAX (s_nil_cond
, "nil-cond", scm_i_makbimacro
, scm_m_nil_cond
);
1710 scm_m_nil_cond (SCM xorig
, SCM env SCM_UNUSED
)
1712 long len
= scm_ilength (SCM_CDR (xorig
));
1713 SCM_ASSYNT (len
>= 1 && (len
& 1) == 1, s_expression
, "nil-cond");
1714 return scm_cons (SCM_IM_NIL_COND
, SCM_CDR (xorig
));
1718 SCM_SYNTAX (s_atfop
, "@fop", scm_i_makbimacro
, scm_m_atfop
);
1721 scm_m_atfop (SCM xorig
, SCM env SCM_UNUSED
)
1723 SCM x
= SCM_CDR (xorig
), var
;
1724 SCM_ASSYNT (scm_ilength (x
) >= 1, s_expression
, "@fop");
1725 var
= scm_symbol_fref (SCM_CAR (x
));
1726 /* Passing the symbol name as the `subr' arg here isn't really
1727 right, but without it it can be very difficult to work out from
1728 the error message which function definition was missing. In any
1729 case, we shouldn't really use SCM_ASSYNT here at all, but instead
1730 something equivalent to (signal void-function (list SYM)) in
1732 SCM_ASSYNT (SCM_VARIABLEP (var
),
1733 "Symbol's function definition is void",
1734 SCM_SYMBOL_CHARS (SCM_CAR (x
)));
1735 /* Support `defalias'. */
1736 while (SCM_SYMBOLP (SCM_VARIABLE_REF (var
)))
1738 var
= scm_symbol_fref (SCM_VARIABLE_REF (var
));
1739 SCM_ASSYNT (SCM_VARIABLEP (var
),
1740 "Symbol's function definition is void",
1741 SCM_SYMBOL_CHARS (SCM_CAR (x
)));
1743 /* Use `var' here rather than `SCM_VARIABLE_REF (var)' because the
1744 former allows for automatically picking up redefinitions of the
1745 corresponding symbol. */
1746 SCM_SETCAR (x
, var
);
1747 /* If the variable contains a procedure, leave the
1748 `transformer-macro' in place so that the procedure's arguments
1749 get properly transformed, and change the initial @fop to
1751 if (!SCM_MACROP (SCM_VARIABLE_REF (var
)))
1753 SCM_SETCAR (xorig
, SCM_IM_APPLY
);
1756 /* Otherwise (the variable contains a macro), the arguments should
1757 not be transformed, so cut the `transformer-macro' out and return
1758 the resulting expression starting with the variable. */
1759 SCM_SETCDR (x
, SCM_CDADR (x
));
1763 #endif /* SCM_ENABLE_ELISP */
1766 /* Start of the memoizers for deprecated macros. */
1769 #if (SCM_ENABLE_DEPRECATED == 1)
1771 SCM_SYNTAX (s_undefine
, "undefine", scm_makacro
, scm_m_undefine
);
1774 scm_m_undefine (SCM x
, SCM env
)
1778 SCM_ASSYNT (SCM_TOP_LEVEL (env
), "bad placement ", s_undefine
);
1779 SCM_ASSYNT (SCM_CONSP (x
) && SCM_NULLP (SCM_CDR (x
)),
1780 s_expression
, s_undefine
);
1782 SCM_ASSYNT (SCM_SYMBOLP (x
), s_variable
, s_undefine
);
1783 arg1
= scm_sym2var (x
, scm_env_top_level (env
), SCM_BOOL_F
);
1784 SCM_ASSYNT (!SCM_FALSEP (arg1
) && !SCM_UNBNDP (SCM_VARIABLE_REF (arg1
)),
1785 "variable already unbound ", s_undefine
);
1786 SCM_VARIABLE_SET (arg1
, SCM_UNDEFINED
);
1790 return SCM_UNSPECIFIED
;
1798 scm_m_expand_body (SCM xorig
, SCM env
)
1800 SCM x
= SCM_CDR (xorig
), defs
= SCM_EOL
;
1801 char *what
= SCM_ISYMCHARS (SCM_CAR (xorig
)) + 2;
1803 while (SCM_NIMP (x
))
1805 SCM form
= SCM_CAR (x
);
1806 if (!SCM_CONSP (form
))
1808 if (!SCM_SYMBOLP (SCM_CAR (form
)))
1811 form
= scm_macroexp (scm_cons_source (form
,
1816 if (SCM_EQ_P (SCM_IM_DEFINE
, SCM_CAR (form
)))
1818 defs
= scm_cons (SCM_CDR (form
), defs
);
1821 else if (!SCM_IMP (defs
))
1825 else if (SCM_EQ_P (SCM_IM_BEGIN
, SCM_CAR (form
)))
1827 x
= scm_append (scm_list_2 (SCM_CDR (form
), SCM_CDR (x
)));
1831 x
= scm_cons (form
, SCM_CDR (x
));
1836 if (!SCM_NULLP (defs
))
1838 SCM rvars
, inits
, body
, letrec
;
1839 check_bindings (defs
, xorig
);
1840 transform_bindings (defs
, xorig
, &rvars
, &inits
);
1841 body
= scm_m_body (SCM_IM_DEFINE
, x
, what
);
1842 letrec
= scm_cons2 (SCM_IM_LETREC
, rvars
, scm_cons (inits
, body
));
1843 SCM_SETCAR (xorig
, letrec
);
1844 SCM_SETCDR (xorig
, SCM_EOL
);
1848 SCM_ASSYNT (SCM_CONSP (x
), s_body
, what
);
1849 SCM_SETCAR (xorig
, SCM_CAR (x
));
1850 SCM_SETCDR (xorig
, SCM_CDR (x
));
1857 scm_macroexp (SCM x
, SCM env
)
1859 SCM res
, proc
, orig_sym
;
1861 /* Don't bother to produce error messages here. We get them when we
1862 eventually execute the code for real. */
1865 orig_sym
= SCM_CAR (x
);
1866 if (!SCM_SYMBOLP (orig_sym
))
1870 SCM
*proc_ptr
= scm_lookupcar1 (x
, env
, 0);
1871 if (proc_ptr
== NULL
)
1873 /* We have lost the race. */
1879 /* Only handle memoizing macros. `Acros' and `macros' are really
1880 special forms and should not be evaluated here. */
1882 if (!SCM_MACROP (proc
)
1883 || (SCM_MACRO_TYPE (proc
) != 2 && !SCM_BUILTIN_MACRO_P (proc
)))
1886 SCM_SETCAR (x
, orig_sym
); /* Undo memoizing effect of lookupcar */
1887 res
= scm_call_2 (SCM_MACRO_CODE (proc
), x
, env
);
1889 if (scm_ilength (res
) <= 0)
1890 res
= scm_list_2 (SCM_IM_BEGIN
, res
);
1893 SCM_SETCAR (x
, SCM_CAR (res
));
1894 SCM_SETCDR (x
, SCM_CDR (res
));
1900 #define SCM_BIT7(x) (127 & SCM_UNPACK (x))
1902 /* A function object to implement "apply" for non-closure functions. */
1904 /* An endless list consisting of #<undefined> objects: */
1905 static SCM undefineds
;
1907 /* scm_unmemocopy takes a memoized expression together with its
1908 * environment and rewrites it to its original form. Thus, it is the
1909 * inversion of the rewrite rules above. The procedure is not
1910 * optimized for speed. It's used in scm_iprin1 when printing the
1911 * code of a closure, in scm_procedure_source, in display_frame when
1912 * generating the source for a stackframe in a backtrace, and in
1913 * display_expression.
1915 * Unmemoizing is not a reliable process. You cannot in general
1916 * expect to get the original source back.
1918 * However, GOOPS currently relies on this for method compilation.
1919 * This ought to change.
1923 build_binding_list (SCM names
, SCM inits
)
1925 SCM bindings
= SCM_EOL
;
1926 while (!SCM_NULLP (names
))
1928 SCM binding
= scm_list_2 (SCM_CAR (names
), SCM_CAR (inits
));
1929 bindings
= scm_cons (binding
, bindings
);
1930 names
= SCM_CDR (names
);
1931 inits
= SCM_CDR (inits
);
1937 unmemocopy (SCM x
, SCM env
)
1942 if (SCM_VECTORP (x
))
1944 return scm_list_2 (scm_sym_quote
, x
);
1946 else if (!SCM_CONSP (x
))
1949 p
= scm_whash_lookup (scm_source_whash
, x
);
1950 switch (SCM_ITAG7 (SCM_CAR (x
)))
1952 case SCM_BIT7 (SCM_IM_AND
):
1953 ls
= z
= scm_cons (scm_sym_and
, SCM_UNSPECIFIED
);
1955 case SCM_BIT7 (SCM_IM_BEGIN
):
1956 ls
= z
= scm_cons (scm_sym_begin
, SCM_UNSPECIFIED
);
1958 case SCM_BIT7 (SCM_IM_CASE
):
1959 ls
= z
= scm_cons (scm_sym_case
, SCM_UNSPECIFIED
);
1961 case SCM_BIT7 (SCM_IM_COND
):
1962 ls
= z
= scm_cons (scm_sym_cond
, SCM_UNSPECIFIED
);
1964 case SCM_BIT7 (SCM_IM_DO
):
1966 /* format: (#@do (i1 ... ik) (nk nk-1 ...) (test) (body) s1 ... sk),
1967 * where ix is an initializer for a local variable, nx is the name of
1968 * the local variable, test is the test clause of the do loop, body is
1969 * the body of the do loop and sx are the step clauses for the local
1971 SCM names
, inits
, test
, memoized_body
, steps
, bindings
;
1974 inits
= scm_reverse (unmemocopy (SCM_CAR (x
), env
));
1976 names
= SCM_CAR (x
);
1977 env
= SCM_EXTEND_ENV (names
, SCM_EOL
, env
);
1979 test
= unmemocopy (SCM_CAR (x
), env
);
1981 memoized_body
= SCM_CAR (x
);
1983 steps
= scm_reverse (unmemocopy (x
, env
));
1985 /* build transformed binding list */
1987 while (!SCM_NULLP (names
))
1989 SCM name
= SCM_CAR (names
);
1990 SCM init
= SCM_CAR (inits
);
1991 SCM step
= SCM_CAR (steps
);
1992 step
= SCM_EQ_P (step
, name
) ? SCM_EOL
: scm_list_1 (step
);
1994 bindings
= scm_cons (scm_cons2 (name
, init
, step
), bindings
);
1996 names
= SCM_CDR (names
);
1997 inits
= SCM_CDR (inits
);
1998 steps
= SCM_CDR (steps
);
2000 z
= scm_cons (test
, SCM_UNSPECIFIED
);
2001 ls
= scm_cons2 (scm_sym_do
, bindings
, z
);
2003 x
= scm_cons (SCM_BOOL_F
, memoized_body
);
2006 case SCM_BIT7 (SCM_IM_IF
):
2007 ls
= z
= scm_cons (scm_sym_if
, SCM_UNSPECIFIED
);
2009 case SCM_BIT7 (SCM_IM_LET
):
2011 /* format: (#@let (nk nk-1 ...) (i1 ... ik) b1 ...),
2012 * where nx is the name of a local variable, ix is an initializer for
2013 * the local variable and by are the body clauses. */
2014 SCM names
, inits
, bindings
;
2017 names
= SCM_CAR (x
);
2019 inits
= scm_reverse (unmemocopy (SCM_CAR (x
), env
));
2020 env
= SCM_EXTEND_ENV (names
, SCM_EOL
, env
);
2022 bindings
= build_binding_list (names
, inits
);
2023 z
= scm_cons (bindings
, SCM_UNSPECIFIED
);
2024 ls
= scm_cons (scm_sym_let
, z
);
2027 case SCM_BIT7 (SCM_IM_LETREC
):
2029 /* format: (#@letrec (nk nk-1 ...) (i1 ... ik) b1 ...),
2030 * where nx is the name of a local variable, ix is an initializer for
2031 * the local variable and by are the body clauses. */
2032 SCM names
, inits
, bindings
;
2035 names
= SCM_CAR (x
);
2036 env
= SCM_EXTEND_ENV (names
, SCM_EOL
, env
);
2038 inits
= scm_reverse (unmemocopy (SCM_CAR (x
), env
));
2040 bindings
= build_binding_list (names
, inits
);
2041 z
= scm_cons (bindings
, SCM_UNSPECIFIED
);
2042 ls
= scm_cons (scm_sym_letrec
, z
);
2045 case SCM_BIT7 (SCM_IM_LETSTAR
):
2053 env
= SCM_EXTEND_ENV (SCM_EOL
, SCM_EOL
, env
);
2056 y
= z
= scm_acons (SCM_CAR (b
),
2058 scm_cons (unmemocopy (SCM_CADR (b
), env
), SCM_EOL
), env
),
2060 env
= SCM_EXTEND_ENV (SCM_CAR (b
), SCM_BOOL_F
, env
);
2064 SCM_SETCDR (y
, SCM_EOL
);
2065 z
= scm_cons (y
, SCM_UNSPECIFIED
);
2066 ls
= scm_cons (scm_sym_let
, z
);
2071 SCM_SETCDR (z
, scm_acons (SCM_CAR (b
),
2073 scm_list_1 (unmemocopy (SCM_CADR (b
), env
)), env
),
2076 env
= SCM_EXTEND_ENV (SCM_CAR (b
), SCM_BOOL_F
, env
);
2079 while (SCM_NIMP (b
));
2080 SCM_SETCDR (z
, SCM_EOL
);
2082 z
= scm_cons (y
, SCM_UNSPECIFIED
);
2083 ls
= scm_cons (scm_sym_letstar
, z
);
2086 case SCM_BIT7 (SCM_IM_OR
):
2087 ls
= z
= scm_cons (scm_sym_or
, SCM_UNSPECIFIED
);
2089 case SCM_BIT7 (SCM_IM_LAMBDA
):
2091 z
= scm_cons (SCM_CAR (x
), SCM_UNSPECIFIED
);
2092 ls
= scm_cons (scm_sym_lambda
, z
);
2093 env
= SCM_EXTEND_ENV (SCM_CAR (x
), SCM_EOL
, env
);
2095 case SCM_BIT7 (SCM_IM_QUOTE
):
2096 ls
= z
= scm_cons (scm_sym_quote
, SCM_UNSPECIFIED
);
2098 case SCM_BIT7 (SCM_IM_SET_X
):
2099 ls
= z
= scm_cons (scm_sym_set_x
, SCM_UNSPECIFIED
);
2101 case SCM_BIT7 (SCM_MAKISYM (0)):
2103 switch (SCM_ISYMNUM (z
))
2105 case (SCM_ISYMNUM (SCM_IM_DEFINE
)):
2110 z
= scm_cons (n
, SCM_UNSPECIFIED
);
2111 ls
= scm_cons (scm_sym_define
, z
);
2112 if (!SCM_NULLP (env
))
2113 env
= scm_cons (scm_cons (scm_cons (n
, SCM_CAAR (env
)),
2118 case (SCM_ISYMNUM (SCM_IM_APPLY
)):
2119 ls
= z
= scm_cons (scm_sym_atapply
, SCM_UNSPECIFIED
);
2121 case (SCM_ISYMNUM (SCM_IM_CONT
)):
2122 ls
= z
= scm_cons (scm_sym_atcall_cc
, SCM_UNSPECIFIED
);
2124 case (SCM_ISYMNUM (SCM_IM_DELAY
)):
2125 ls
= z
= scm_cons (scm_sym_delay
, SCM_UNSPECIFIED
);
2128 case (SCM_ISYMNUM (SCM_IM_FUTURE
)):
2129 ls
= z
= scm_cons (scm_sym_future
, SCM_UNSPECIFIED
);
2132 case (SCM_ISYMNUM (SCM_IM_CALL_WITH_VALUES
)):
2133 ls
= z
= scm_cons (scm_sym_at_call_with_values
, SCM_UNSPECIFIED
);
2135 case (SCM_ISYMNUM (SCM_IM_ELSE
)):
2136 ls
= z
= scm_cons (scm_sym_else
, SCM_UNSPECIFIED
);
2139 /* appease the Sun compiler god: */ ;
2142 ls
= z
= unmemocar (scm_cons (unmemocopy (SCM_CAR (x
), env
),
2148 while (SCM_CONSP (x
))
2150 SCM form
= SCM_CAR (x
);
2151 if (!SCM_ISYMP (form
))
2153 SCM copy
= scm_cons (unmemocopy (form
, env
), SCM_UNSPECIFIED
);
2154 SCM_SETCDR (z
, unmemocar (copy
, env
));
2157 else if (SCM_EQ_P (form
, SCM_IM_ARROW
))
2159 SCM_SETCDR (z
, scm_cons (scm_sym_arrow
, SCM_UNSPECIFIED
));
2165 if (!SCM_FALSEP (p
))
2166 scm_whash_insert (scm_source_whash
, ls
, p
);
2172 scm_unmemocopy (SCM x
, SCM env
)
2174 if (!SCM_NULLP (env
))
2175 /* Make a copy of the lowest frame to protect it from
2176 modifications by SCM_IM_DEFINE */
2177 return unmemocopy (x
, scm_cons (SCM_CAR (env
), SCM_CDR (env
)));
2179 return unmemocopy (x
, env
);
2184 scm_badargsp (SCM formals
, SCM args
)
2186 while (!SCM_NULLP (formals
))
2188 if (!SCM_CONSP (formals
))
2190 if (SCM_NULLP (args
))
2192 formals
= SCM_CDR (formals
);
2193 args
= SCM_CDR (args
);
2195 return !SCM_NULLP (args
) ? 1 : 0;
2200 scm_eval_args (SCM l
, SCM env
, SCM proc
)
2202 SCM results
= SCM_EOL
, *lloc
= &results
, res
;
2203 while (SCM_CONSP (l
))
2205 res
= EVALCAR (l
, env
);
2207 *lloc
= scm_list_1 (res
);
2208 lloc
= SCM_CDRLOC (*lloc
);
2212 scm_wrong_num_args (proc
);
2218 scm_eval_body (SCM code
, SCM env
)
2222 next
= SCM_CDR (code
);
2223 while (!SCM_NULLP (next
))
2225 if (SCM_IMP (SCM_CAR (code
)))
2227 if (SCM_ISYMP (SCM_CAR (code
)))
2229 scm_rec_mutex_lock (&source_mutex
);
2230 /* check for race condition */
2231 if (SCM_ISYMP (SCM_CAR (code
)))
2232 code
= scm_m_expand_body (code
, env
);
2233 scm_rec_mutex_unlock (&source_mutex
);
2238 SCM_XEVAL (SCM_CAR (code
), env
);
2240 next
= SCM_CDR (code
);
2242 return SCM_XEVALCAR (code
, env
);
2248 /* SECTION: This code is specific for the debugging support. One
2249 * branch is read when DEVAL isn't defined, the other when DEVAL is
2255 #define SCM_APPLY scm_apply
2256 #define PREP_APPLY(proc, args)
2258 #define RETURN(x) do { return x; } while (0)
2259 #ifdef STACK_CHECKING
2260 #ifndef NO_CEVAL_STACK_CHECKING
2261 #define EVAL_STACK_CHECKING
2268 #define SCM_CEVAL scm_deval /* Substitute all uses of scm_ceval */
2270 #define SCM_APPLY scm_dapply
2272 #define PREP_APPLY(p, l) \
2273 { ++debug.info; debug.info->a.proc = p; debug.info->a.args = l; }
2275 #define ENTER_APPLY \
2277 SCM_SET_ARGSREADY (debug);\
2278 if (scm_check_apply_p && SCM_TRAPS_P)\
2279 if (SCM_APPLY_FRAME_P || (SCM_TRACE_P && PROCTRACEP (proc)))\
2281 SCM tmp, tail = SCM_BOOL(SCM_TRACED_FRAME_P (debug)); \
2282 SCM_SET_TRACED_FRAME (debug); \
2284 if (SCM_CHEAPTRAPS_P)\
2286 tmp = scm_make_debugobj (&debug);\
2287 scm_call_3 (SCM_APPLY_FRAME_HDLR, scm_sym_apply_frame, tmp, tail);\
2292 tmp = scm_make_continuation (&first);\
2294 scm_call_3 (SCM_APPLY_FRAME_HDLR, scm_sym_apply_frame, tmp, tail);\
2300 #define RETURN(e) do { proc = (e); goto exit; } while (0)
2301 #ifdef STACK_CHECKING
2302 #ifndef EVAL_STACK_CHECKING
2303 #define EVAL_STACK_CHECKING
2307 /* scm_ceval_ptr points to the currently selected evaluator.
2308 * *fixme*: Although efficiency is important here, this state variable
2309 * should probably not be a global. It should be related to the
2314 SCM (*scm_ceval_ptr
) (SCM x
, SCM env
);
2316 /* scm_last_debug_frame contains a pointer to the last debugging
2317 * information stack frame. It is accessed very often from the
2318 * debugging evaluator, so it should probably not be indirectly
2319 * addressed. Better to save and restore it from the current root at
2323 /* scm_debug_eframe_size is the number of slots available for pseudo
2324 * stack frames at each real stack frame.
2327 long scm_debug_eframe_size
;
2329 int scm_debug_mode
, scm_check_entry_p
, scm_check_apply_p
, scm_check_exit_p
;
2331 long scm_eval_stack
;
2333 scm_t_option scm_eval_opts
[] = {
2334 { SCM_OPTION_INTEGER
, "stack", 22000, "Size of thread stacks (in machine words)." }
2337 scm_t_option scm_debug_opts
[] = {
2338 { SCM_OPTION_BOOLEAN
, "cheap", 1,
2339 "*Flyweight representation of the stack at traps." },
2340 { SCM_OPTION_BOOLEAN
, "breakpoints", 0, "*Check for breakpoints." },
2341 { SCM_OPTION_BOOLEAN
, "trace", 0, "*Trace mode." },
2342 { SCM_OPTION_BOOLEAN
, "procnames", 1,
2343 "Record procedure names at definition." },
2344 { SCM_OPTION_BOOLEAN
, "backwards", 0,
2345 "Display backtrace in anti-chronological order." },
2346 { SCM_OPTION_INTEGER
, "width", 79, "Maximal width of backtrace." },
2347 { SCM_OPTION_INTEGER
, "indent", 10, "Maximal indentation in backtrace." },
2348 { SCM_OPTION_INTEGER
, "frames", 3,
2349 "Maximum number of tail-recursive frames in backtrace." },
2350 { SCM_OPTION_INTEGER
, "maxdepth", 1000,
2351 "Maximal number of stored backtrace frames." },
2352 { SCM_OPTION_INTEGER
, "depth", 20, "Maximal length of printed backtrace." },
2353 { SCM_OPTION_BOOLEAN
, "backtrace", 0, "Show backtrace on error." },
2354 { SCM_OPTION_BOOLEAN
, "debug", 0, "Use the debugging evaluator." },
2355 { SCM_OPTION_INTEGER
, "stack", 20000, "Stack size limit (measured in words; 0 = no check)." },
2356 { SCM_OPTION_SCM
, "show-file-name", (unsigned long)SCM_BOOL_T
, "Show file names and line numbers in backtraces when not `#f'. A value of `base' displays only base names, while `#t' displays full names."}
2359 scm_t_option scm_evaluator_trap_table
[] = {
2360 { SCM_OPTION_BOOLEAN
, "traps", 0, "Enable evaluator traps." },
2361 { SCM_OPTION_BOOLEAN
, "enter-frame", 0, "Trap when eval enters new frame." },
2362 { SCM_OPTION_BOOLEAN
, "apply-frame", 0, "Trap when entering apply." },
2363 { SCM_OPTION_BOOLEAN
, "exit-frame", 0, "Trap when exiting eval or apply." },
2364 { SCM_OPTION_SCM
, "enter-frame-handler", (unsigned long)SCM_BOOL_F
, "Handler for enter-frame traps." },
2365 { SCM_OPTION_SCM
, "apply-frame-handler", (unsigned long)SCM_BOOL_F
, "Handler for apply-frame traps." },
2366 { SCM_OPTION_SCM
, "exit-frame-handler", (unsigned long)SCM_BOOL_F
, "Handler for exit-frame traps." }
2369 SCM_DEFINE (scm_eval_options_interface
, "eval-options-interface", 0, 1, 0,
2371 "Option interface for the evaluation options. Instead of using\n"
2372 "this procedure directly, use the procedures @code{eval-enable},\n"
2373 "@code{eval-disable}, @code{eval-set!} and @code{eval-options}.")
2374 #define FUNC_NAME s_scm_eval_options_interface
2378 ans
= scm_options (setting
,
2382 scm_eval_stack
= SCM_EVAL_STACK
* sizeof (void *);
2389 SCM_DEFINE (scm_evaluator_traps
, "evaluator-traps-interface", 0, 1, 0,
2391 "Option interface for the evaluator trap options.")
2392 #define FUNC_NAME s_scm_evaluator_traps
2396 ans
= scm_options (setting
,
2397 scm_evaluator_trap_table
,
2398 SCM_N_EVALUATOR_TRAPS
,
2400 SCM_RESET_DEBUG_MODE
;
2408 deval_args (SCM l
, SCM env
, SCM proc
, SCM
*lloc
)
2410 SCM
*results
= lloc
, res
;
2411 while (SCM_CONSP (l
))
2413 res
= EVALCAR (l
, env
);
2415 *lloc
= scm_list_1 (res
);
2416 lloc
= SCM_CDRLOC (*lloc
);
2420 scm_wrong_num_args (proc
);
2427 /* SECTION: This code is compiled twice.
2431 /* Update the toplevel environment frame ENV so that it refers to the
2432 * current module. */
2433 #define UPDATE_TOPLEVEL_ENV(env) \
2435 SCM p = scm_current_module_lookup_closure (); \
2436 if (p != SCM_CAR (env)) \
2437 env = scm_top_level_env (p); \
2441 /* This is the evaluator. Like any real monster, it has three heads:
2443 * scm_ceval is the non-debugging evaluator, scm_deval is the debugging
2444 * version. Both are implemented using a common code base, using the
2445 * following mechanism: SCM_CEVAL is a macro, which is either defined to
2446 * scm_ceval or scm_deval. Thus, there is no function SCM_CEVAL, but the code
2447 * for SCM_CEVAL actually compiles to either scm_ceval or scm_deval. When
2448 * SCM_CEVAL is defined to scm_ceval, it is known that the macro DEVAL is not
2449 * defined. When SCM_CEVAL is defined to scm_deval, then the macro DEVAL is
2450 * known to be defined. Thus, in SCM_CEVAL parts for the debugging evaluator
2451 * are enclosed within #ifdef DEVAL ... #endif.
2453 * All three (scm_ceval, scm_deval and their common implementation SCM_CEVAL)
2454 * take two input parameters, x and env: x is a single expression to be
2455 * evalutated. env is the environment in which bindings are searched.
2457 * x is known to be a cell (i. e. a pair or any other non-immediate). Since x
2458 * is a single expression, it is necessarily in a tail position. If x is just
2459 * a call to another function like in the expression (foo exp1 exp2 ...), the
2460 * realization of that call therefore _must_not_ increase stack usage (the
2461 * evaluation of exp1, exp2 etc., however, may do so). This is realized by
2462 * making extensive use of 'goto' statements within the evaluator: The gotos
2463 * replace recursive calls to SCM_CEVAL, thus re-using the same stack frame
2464 * that SCM_CEVAL was already using. If, however, x represents some form that
2465 * requires to evaluate a sequence of expressions like (begin exp1 exp2 ...),
2466 * then recursive calls to SCM_CEVAL are performed for all but the last
2467 * expression of that sequence. */
2471 scm_ceval (SCM x
, SCM env
)
2477 scm_deval (SCM x
, SCM env
)
2482 SCM_CEVAL (SCM x
, SCM env
)
2486 scm_t_debug_frame debug
;
2487 scm_t_debug_info
*debug_info_end
;
2488 debug
.prev
= scm_last_debug_frame
;
2491 * The debug.vect contains twice as much scm_t_debug_info frames as the
2492 * user has specified with (debug-set! frames <n>).
2494 * Even frames are eval frames, odd frames are apply frames.
2496 debug
.vect
= (scm_t_debug_info
*) alloca (scm_debug_eframe_size
2497 * sizeof (scm_t_debug_info
));
2498 debug
.info
= debug
.vect
;
2499 debug_info_end
= debug
.vect
+ scm_debug_eframe_size
;
2500 scm_last_debug_frame
= &debug
;
2502 #ifdef EVAL_STACK_CHECKING
2503 if (scm_stack_checking_enabled_p
&& SCM_STACK_OVERFLOW_P (&proc
))
2506 debug
.info
->e
.exp
= x
;
2507 debug
.info
->e
.env
= env
;
2509 scm_report_stack_overflow ();
2519 SCM_CLEAR_ARGSREADY (debug
);
2520 if (SCM_OVERFLOWP (debug
))
2523 * In theory, this should be the only place where it is necessary to
2524 * check for space in debug.vect since both eval frames and
2525 * available space are even.
2527 * For this to be the case, however, it is necessary that primitive
2528 * special forms which jump back to `loop', `begin' or some similar
2529 * label call PREP_APPLY.
2531 else if (++debug
.info
>= debug_info_end
)
2533 SCM_SET_OVERFLOW (debug
);
2538 debug
.info
->e
.exp
= x
;
2539 debug
.info
->e
.env
= env
;
2540 if (scm_check_entry_p
&& SCM_TRAPS_P
)
2542 if (SCM_ENTER_FRAME_P
2543 || (SCM_BREAKPOINTS_P
&& scm_c_source_property_breakpoint_p (x
)))
2546 SCM tail
= SCM_BOOL (SCM_TAILRECP (debug
));
2547 SCM_SET_TAILREC (debug
);
2548 if (SCM_CHEAPTRAPS_P
)
2549 stackrep
= scm_make_debugobj (&debug
);
2553 SCM val
= scm_make_continuation (&first
);
2563 /* This gives the possibility for the debugger to
2564 modify the source expression before evaluation. */
2569 scm_call_4 (SCM_ENTER_FRAME_HDLR
,
2570 scm_sym_enter_frame
,
2573 scm_unmemocopy (x
, env
));
2580 switch (SCM_TYP7 (x
))
2582 case scm_tc7_symbol
:
2583 /* Only happens when called at top level. */
2584 x
= scm_cons (x
, SCM_UNDEFINED
);
2585 RETURN (*scm_lookupcar (x
, env
, 1));
2587 case SCM_BIT7 (SCM_IM_AND
):
2589 while (!SCM_NULLP (SCM_CDR (x
)))
2591 SCM test_result
= EVALCAR (x
, env
);
2592 if (SCM_FALSEP (test_result
) || SCM_NILP (test_result
))
2593 RETURN (SCM_BOOL_F
);
2597 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
2600 case SCM_BIT7 (SCM_IM_BEGIN
):
2603 RETURN (SCM_UNSPECIFIED
);
2605 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
2608 /* If we are on toplevel with a lookup closure, we need to sync
2609 with the current module. */
2610 if (SCM_CONSP (env
) && !SCM_CONSP (SCM_CAR (env
)))
2612 UPDATE_TOPLEVEL_ENV (env
);
2613 while (!SCM_NULLP (SCM_CDR (x
)))
2616 UPDATE_TOPLEVEL_ENV (env
);
2622 goto nontoplevel_begin
;
2625 while (!SCM_NULLP (SCM_CDR (x
)))
2627 SCM form
= SCM_CAR (x
);
2630 if (SCM_ISYMP (form
))
2632 scm_rec_mutex_lock (&source_mutex
);
2633 /* check for race condition */
2634 if (SCM_ISYMP (SCM_CAR (x
)))
2635 x
= scm_m_expand_body (x
, env
);
2636 scm_rec_mutex_unlock (&source_mutex
);
2637 goto nontoplevel_begin
;
2640 SCM_VALIDATE_NON_EMPTY_COMBINATION (form
);
2643 SCM_CEVAL (form
, env
);
2649 /* scm_eval last form in list */
2650 SCM last_form
= SCM_CAR (x
);
2652 if (SCM_CONSP (last_form
))
2654 /* This is by far the most frequent case. */
2656 goto loop
; /* tail recurse */
2658 else if (SCM_IMP (last_form
))
2659 RETURN (SCM_EVALIM (last_form
, env
));
2660 else if (SCM_VARIABLEP (last_form
))
2661 RETURN (SCM_VARIABLE_REF (last_form
));
2662 else if (SCM_SYMBOLP (last_form
))
2663 RETURN (*scm_lookupcar (x
, env
, 1));
2669 case SCM_BIT7 (SCM_IM_CASE
):
2672 SCM key
= EVALCAR (x
, env
);
2674 while (!SCM_NULLP (x
))
2676 SCM clause
= SCM_CAR (x
);
2677 SCM labels
= SCM_CAR (clause
);
2678 if (SCM_EQ_P (labels
, SCM_IM_ELSE
))
2680 x
= SCM_CDR (clause
);
2681 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
2684 while (!SCM_NULLP (labels
))
2686 SCM label
= SCM_CAR (labels
);
2687 if (SCM_EQ_P (label
, key
) || !SCM_FALSEP (scm_eqv_p (label
, key
)))
2689 x
= SCM_CDR (clause
);
2690 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
2693 labels
= SCM_CDR (labels
);
2698 RETURN (SCM_UNSPECIFIED
);
2701 case SCM_BIT7 (SCM_IM_COND
):
2703 while (!SCM_NULLP (x
))
2705 SCM clause
= SCM_CAR (x
);
2706 if (SCM_EQ_P (SCM_CAR (clause
), SCM_IM_ELSE
))
2708 x
= SCM_CDR (clause
);
2709 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
2714 arg1
= EVALCAR (clause
, env
);
2715 if (!SCM_FALSEP (arg1
) && !SCM_NILP (arg1
))
2717 x
= SCM_CDR (clause
);
2720 else if (!SCM_EQ_P (SCM_CAR (x
), SCM_IM_ARROW
))
2722 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
2728 proc
= EVALCAR (proc
, env
);
2729 PREP_APPLY (proc
, scm_list_1 (arg1
));
2737 RETURN (SCM_UNSPECIFIED
);
2740 case SCM_BIT7 (SCM_IM_DO
):
2743 /* Compute the initialization values and the initial environment. */
2744 SCM init_forms
= SCM_CAR (x
);
2745 SCM init_values
= SCM_EOL
;
2746 while (!SCM_NULLP (init_forms
))
2748 init_values
= scm_cons (EVALCAR (init_forms
, env
), init_values
);
2749 init_forms
= SCM_CDR (init_forms
);
2752 env
= SCM_EXTEND_ENV (SCM_CAR (x
), init_values
, env
);
2756 SCM test_form
= SCM_CAR (x
);
2757 SCM body_forms
= SCM_CADR (x
);
2758 SCM step_forms
= SCM_CDDR (x
);
2760 SCM test_result
= EVALCAR (test_form
, env
);
2762 while (SCM_FALSEP (test_result
) || SCM_NILP (test_result
))
2765 /* Evaluate body forms. */
2767 for (temp_forms
= body_forms
;
2768 !SCM_NULLP (temp_forms
);
2769 temp_forms
= SCM_CDR (temp_forms
))
2771 SCM form
= SCM_CAR (temp_forms
);
2772 /* Dirk:FIXME: We only need to eval forms, that may have a
2773 * side effect here. This is only true for forms that start
2774 * with a pair. All others are just constants. However,
2775 * since in the common case there is no constant expression
2776 * in a body of a do form, we just check for immediates here
2777 * and have SCM_CEVAL take care of other cases. In the long
2778 * run it would make sense to get rid of this test and have
2779 * the macro transformer of 'do' eliminate all forms that
2780 * have no sideeffect. */
2781 if (!SCM_IMP (form
))
2782 SCM_CEVAL (form
, env
);
2787 /* Evaluate the step expressions. */
2789 SCM step_values
= SCM_EOL
;
2790 for (temp_forms
= step_forms
;
2791 !SCM_NULLP (temp_forms
);
2792 temp_forms
= SCM_CDR (temp_forms
))
2794 SCM value
= EVALCAR (temp_forms
, env
);
2795 step_values
= scm_cons (value
, step_values
);
2797 env
= SCM_EXTEND_ENV (SCM_CAAR (env
),
2802 test_result
= EVALCAR (test_form
, env
);
2807 RETURN (SCM_UNSPECIFIED
);
2808 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
2809 goto nontoplevel_begin
;
2812 case SCM_BIT7 (SCM_IM_IF
):
2815 SCM test_result
= EVALCAR (x
, env
);
2816 x
= SCM_CDR (x
); /* then expression */
2817 if (SCM_FALSEP (test_result
) || SCM_NILP (test_result
))
2819 x
= SCM_CDR (x
); /* else expression */
2821 RETURN (SCM_UNSPECIFIED
);
2824 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
2828 case SCM_BIT7 (SCM_IM_LET
):
2831 SCM init_forms
= SCM_CADR (x
);
2832 SCM init_values
= SCM_EOL
;
2835 init_values
= scm_cons (EVALCAR (init_forms
, env
), init_values
);
2836 init_forms
= SCM_CDR (init_forms
);
2838 while (!SCM_NULLP (init_forms
));
2839 env
= SCM_EXTEND_ENV (SCM_CAR (x
), init_values
, env
);
2842 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
2843 goto nontoplevel_begin
;
2846 case SCM_BIT7 (SCM_IM_LETREC
):
2848 env
= SCM_EXTEND_ENV (SCM_CAR (x
), undefineds
, env
);
2851 SCM init_forms
= SCM_CAR (x
);
2852 SCM init_values
= SCM_EOL
;
2855 init_values
= scm_cons (EVALCAR (init_forms
, env
), init_values
);
2856 init_forms
= SCM_CDR (init_forms
);
2858 while (!SCM_NULLP (init_forms
));
2859 SCM_SETCDR (SCM_CAR (env
), init_values
);
2862 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
2863 goto nontoplevel_begin
;
2866 case SCM_BIT7 (SCM_IM_LETSTAR
):
2869 SCM bindings
= SCM_CAR (x
);
2870 if (SCM_NULLP (bindings
))
2871 env
= SCM_EXTEND_ENV (SCM_EOL
, SCM_EOL
, env
);
2876 SCM name
= SCM_CAR (bindings
);
2877 SCM init
= SCM_CDR (bindings
);
2878 env
= SCM_EXTEND_ENV (name
, EVALCAR (init
, env
), env
);
2879 bindings
= SCM_CDR (init
);
2881 while (!SCM_NULLP (bindings
));
2885 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
2886 goto nontoplevel_begin
;
2889 case SCM_BIT7 (SCM_IM_OR
):
2891 while (!SCM_NULLP (SCM_CDR (x
)))
2893 SCM val
= EVALCAR (x
, env
);
2894 if (!SCM_FALSEP (val
) && !SCM_NILP (val
))
2899 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
2903 case SCM_BIT7 (SCM_IM_LAMBDA
):
2904 RETURN (scm_closure (SCM_CDR (x
), env
));
2907 case SCM_BIT7 (SCM_IM_QUOTE
):
2908 RETURN (SCM_CADR (x
));
2911 case SCM_BIT7 (SCM_IM_SET_X
):
2915 SCM variable
= SCM_CAR (x
);
2916 if (SCM_ILOCP (variable
))
2917 location
= scm_ilookup (variable
, env
);
2918 else if (SCM_VARIABLEP (variable
))
2919 location
= SCM_VARIABLE_LOC (variable
);
2920 else /* (SCM_SYMBOLP (variable)) is known to be true */
2921 location
= scm_lookupcar (x
, env
, 1);
2923 *location
= EVALCAR (x
, env
);
2925 RETURN (SCM_UNSPECIFIED
);
2928 /* new syntactic forms go here. */
2929 case SCM_BIT7 (SCM_MAKISYM (0)):
2931 switch (SCM_ISYMNUM (proc
))
2935 case (SCM_ISYMNUM (SCM_IM_DEFINE
)):
2936 /* Top level defines are handled directly by the memoizer and thus
2937 * will never generate memoized code with SCM_IM_DEFINE. Internal
2938 * defines which occur at valid positions will be transformed into
2939 * letrec expressions. Thus, whenever the executor detects
2940 * SCM_IM_DEFINE, this must come from an internal definition at an
2941 * illegal position. */
2942 scm_misc_error (NULL
, "Bad define placement", SCM_EOL
);
2945 case (SCM_ISYMNUM (SCM_IM_APPLY
)):
2947 proc
= EVALCAR (x
, env
);
2948 PREP_APPLY (proc
, SCM_EOL
);
2950 arg1
= EVALCAR (x
, env
);
2953 /* Go here to tail-apply a procedure. PROC is the procedure and
2954 * ARG1 is the list of arguments. PREP_APPLY must have been called
2955 * before jumping to apply_proc. */
2956 if (SCM_CLOSUREP (proc
))
2958 SCM formals
= SCM_CLOSURE_FORMALS (proc
);
2960 debug
.info
->a
.args
= arg1
;
2962 if (scm_badargsp (formals
, arg1
))
2963 scm_wrong_num_args (proc
);
2965 /* Copy argument list */
2966 if (SCM_NULL_OR_NIL_P (arg1
))
2967 env
= SCM_EXTEND_ENV (formals
, SCM_EOL
, SCM_ENV (proc
));
2970 SCM args
= scm_list_1 (SCM_CAR (arg1
));
2972 arg1
= SCM_CDR (arg1
);
2973 while (!SCM_NULL_OR_NIL_P (arg1
))
2975 SCM new_tail
= scm_list_1 (SCM_CAR (arg1
));
2976 SCM_SETCDR (tail
, new_tail
);
2978 arg1
= SCM_CDR (arg1
);
2980 env
= SCM_EXTEND_ENV (formals
, args
, SCM_ENV (proc
));
2983 x
= SCM_CLOSURE_BODY (proc
);
2984 goto nontoplevel_begin
;
2989 RETURN (SCM_APPLY (proc
, arg1
, SCM_EOL
));
2993 case (SCM_ISYMNUM (SCM_IM_CONT
)):
2996 SCM val
= scm_make_continuation (&first
);
3004 proc
= scm_eval_car (proc
, env
);
3005 PREP_APPLY (proc
, scm_list_1 (arg1
));
3012 case (SCM_ISYMNUM (SCM_IM_DELAY
)):
3013 RETURN (scm_makprom (scm_closure (SCM_CDR (x
), env
)));
3016 case (SCM_ISYMNUM (SCM_IM_FUTURE
)):
3017 RETURN (scm_i_make_future (scm_closure (SCM_CDR (x
), env
)));
3020 /* PLACEHOLDER for case (SCM_ISYMNUM (SCM_IM_DISPATCH)): The
3021 following code (type_dispatch) is intended to be the tail
3022 of the case clause for the internal macro
3023 SCM_IM_DISPATCH. Please don't remove it from this
3024 location without discussing it with Mikael
3025 <djurfeldt@nada.kth.se> */
3027 /* The type dispatch code is duplicated below
3028 * (c.f. objects.c:scm_mcache_compute_cmethod) since that
3029 * cuts down execution time for type dispatch to 50%. */
3030 type_dispatch
: /* inputs: x, arg1 */
3031 /* Type dispatch means to determine from the types of the function
3032 * arguments (i. e. the 'signature' of the call), which method from
3033 * a generic function is to be called. This process of selecting
3034 * the right method takes some time. To speed it up, guile uses
3035 * caching: Together with the macro call to dispatch the signatures
3036 * of some previous calls to that generic function from the same
3037 * place are stored (in the code!) in a cache that we call the
3038 * 'method cache'. This is done since it is likely, that
3039 * consecutive calls to dispatch from that position in the code will
3040 * have the same signature. Thus, the type dispatch works as
3041 * follows: First, determine a hash value from the signature of the
3042 * actual arguments. Second, use this hash value as an index to
3043 * find that same signature in the method cache stored at this
3044 * position in the code. If found, you have also found the
3045 * corresponding method that belongs to that signature. If the
3046 * signature is not found in the method cache, you have to perform a
3047 * full search over all signatures stored with the generic
3050 unsigned long int specializers
;
3051 unsigned long int hash_value
;
3052 unsigned long int cache_end_pos
;
3053 unsigned long int mask
;
3057 SCM z
= SCM_CDDR (x
);
3058 SCM tmp
= SCM_CADR (z
);
3059 specializers
= SCM_INUM (SCM_CAR (z
));
3061 /* Compute a hash value for searching the method cache. There
3062 * are two variants for computing the hash value, a (rather)
3063 * complicated one, and a simple one. For the complicated one
3064 * explained below, tmp holds a number that is used in the
3066 if (SCM_INUMP (tmp
))
3068 /* Use the signature of the actual arguments to determine
3069 * the hash value. This is done as follows: Each class has
3070 * an array of random numbers, that are determined when the
3071 * class is created. The integer 'hashset' is an index into
3072 * that array of random numbers. Now, from all classes that
3073 * are part of the signature of the actual arguments, the
3074 * random numbers at index 'hashset' are taken and summed
3075 * up, giving the hash value. The value of 'hashset' is
3076 * stored at the call to dispatch. This allows to have
3077 * different 'formulas' for calculating the hash value at
3078 * different places where dispatch is called. This allows
3079 * to optimize the hash formula at every individual place
3080 * where dispatch is called, such that hopefully the hash
3081 * value that is computed will directly point to the right
3082 * method in the method cache. */
3083 unsigned long int hashset
= SCM_INUM (tmp
);
3084 unsigned long int counter
= specializers
+ 1;
3087 while (!SCM_NULLP (tmp_arg
) && counter
!= 0)
3089 SCM
class = scm_class_of (SCM_CAR (tmp_arg
));
3090 hash_value
+= SCM_INSTANCE_HASH (class, hashset
);
3091 tmp_arg
= SCM_CDR (tmp_arg
);
3095 method_cache
= SCM_CADR (z
);
3096 mask
= SCM_INUM (SCM_CAR (z
));
3098 cache_end_pos
= hash_value
;
3102 /* This method of determining the hash value is much
3103 * simpler: Set the hash value to zero and just perform a
3104 * linear search through the method cache. */
3106 mask
= (unsigned long int) ((long) -1);
3108 cache_end_pos
= SCM_VECTOR_LENGTH (method_cache
);
3113 /* Search the method cache for a method with a matching
3114 * signature. Start the search at position 'hash_value'. The
3115 * hashing implementation uses linear probing for conflict
3116 * resolution, that is, if the signature in question is not
3117 * found at the starting index in the hash table, the next table
3118 * entry is tried, and so on, until in the worst case the whole
3119 * cache has been searched, but still the signature has not been
3124 SCM args
= arg1
; /* list of arguments */
3125 z
= SCM_VELTS (method_cache
)[hash_value
];
3126 while (!SCM_NULLP (args
))
3128 /* More arguments than specifiers => CLASS != ENV */
3129 SCM class_of_arg
= scm_class_of (SCM_CAR (args
));
3130 if (!SCM_EQ_P (class_of_arg
, SCM_CAR (z
)))
3132 args
= SCM_CDR (args
);
3135 /* Fewer arguments than specifiers => CAR != ENV */
3136 if (SCM_NULLP (SCM_CAR (z
)) || SCM_CONSP (SCM_CAR (z
)))
3139 hash_value
= (hash_value
+ 1) & mask
;
3140 } while (hash_value
!= cache_end_pos
);
3142 /* No appropriate method was found in the cache. */
3143 z
= scm_memoize_method (x
, arg1
);
3145 apply_cmethod
: /* inputs: z, arg1 */
3147 SCM formals
= SCM_CMETHOD_FORMALS (z
);
3148 env
= SCM_EXTEND_ENV (formals
, arg1
, SCM_CMETHOD_ENV (z
));
3149 x
= SCM_CMETHOD_BODY (z
);
3150 goto nontoplevel_begin
;
3156 case (SCM_ISYMNUM (SCM_IM_SLOT_REF
)):
3159 SCM instance
= EVALCAR (x
, env
);
3160 unsigned long int slot
= SCM_INUM (SCM_CADR (x
));
3161 RETURN (SCM_PACK (SCM_STRUCT_DATA (instance
) [slot
]));
3165 case (SCM_ISYMNUM (SCM_IM_SLOT_SET_X
)):
3168 SCM instance
= EVALCAR (x
, env
);
3169 unsigned long int slot
= SCM_INUM (SCM_CADR (x
));
3170 SCM value
= EVALCAR (SCM_CDDR (x
), env
);
3171 SCM_STRUCT_DATA (instance
) [slot
] = SCM_UNPACK (value
);
3172 RETURN (SCM_UNSPECIFIED
);
3176 #if SCM_ENABLE_ELISP
3178 case (SCM_ISYMNUM (SCM_IM_NIL_COND
)):
3180 SCM test_form
= SCM_CDR (x
);
3181 x
= SCM_CDR (test_form
);
3182 while (!SCM_NULL_OR_NIL_P (x
))
3184 SCM test_result
= EVALCAR (test_form
, env
);
3185 if (!(SCM_FALSEP (test_result
)
3186 || SCM_NULL_OR_NIL_P (test_result
)))
3188 if (SCM_EQ_P (SCM_CAR (x
), SCM_UNSPECIFIED
))
3189 RETURN (test_result
);
3190 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
3195 test_form
= SCM_CDR (x
);
3196 x
= SCM_CDR (test_form
);
3200 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
3204 #endif /* SCM_ENABLE_ELISP */
3206 case (SCM_ISYMNUM (SCM_IM_BIND
)):
3208 SCM vars
, exps
, vals
;
3211 vars
= SCM_CAAR (x
);
3212 exps
= SCM_CDAR (x
);
3214 while (!SCM_NULLP (exps
))
3216 vals
= scm_cons (EVALCAR (exps
, env
), vals
);
3217 exps
= SCM_CDR (exps
);
3220 scm_swap_bindings (vars
, vals
);
3221 scm_dynwinds
= scm_acons (vars
, vals
, scm_dynwinds
);
3223 /* Ignore all but the last evaluation result. */
3224 for (x
= SCM_CDR (x
); !SCM_NULLP (SCM_CDR (x
)); x
= SCM_CDR (x
))
3226 if (SCM_CONSP (SCM_CAR (x
)))
3227 SCM_CEVAL (SCM_CAR (x
), env
);
3229 proc
= EVALCAR (x
, env
);
3231 scm_dynwinds
= SCM_CDR (scm_dynwinds
);
3232 scm_swap_bindings (vars
, vals
);
3238 case (SCM_ISYMNUM (SCM_IM_CALL_WITH_VALUES
)):
3243 producer
= EVALCAR (x
, env
);
3245 proc
= EVALCAR (x
, env
); /* proc is the consumer. */
3246 arg1
= SCM_APPLY (producer
, SCM_EOL
, SCM_EOL
);
3247 if (SCM_VALUESP (arg1
))
3249 /* The list of arguments is not copied. Rather, it is assumed
3250 * that this has been done by the 'values' procedure. */
3251 arg1
= scm_struct_ref (arg1
, SCM_INUM0
);
3255 arg1
= scm_list_1 (arg1
);
3257 PREP_APPLY (proc
, arg1
);
3270 case scm_tc7_vector
:
3274 case scm_tc7_byvect
:
3281 #if SCM_SIZEOF_LONG_LONG != 0
3282 case scm_tc7_llvect
:
3285 case scm_tc7_number
:
3286 case scm_tc7_string
:
3288 case scm_tcs_closures
:
3292 case scm_tcs_struct
:
3295 case scm_tc7_variable
:
3296 RETURN (SCM_VARIABLE_REF(x
));
3298 case SCM_BIT7 (SCM_ILOC00
):
3299 proc
= *scm_ilookup (SCM_CAR (x
), env
);
3302 case scm_tcs_cons_nimcar
:
3303 if (SCM_SYMBOLP (SCM_CAR (x
)))
3305 SCM orig_sym
= SCM_CAR (x
);
3307 SCM
*location
= scm_lookupcar1 (x
, env
, 1);
3308 if (location
== NULL
)
3310 /* we have lost the race, start again. */
3316 if (SCM_MACROP (proc
))
3318 SCM_SETCAR (x
, orig_sym
); /* Undo memoizing effect of
3320 handle_a_macro
: /* inputs: x, env, proc */
3322 /* Set a flag during macro expansion so that macro
3323 application frames can be deleted from the backtrace. */
3324 SCM_SET_MACROEXP (debug
);
3326 arg1
= SCM_APPLY (SCM_MACRO_CODE (proc
), x
,
3327 scm_cons (env
, scm_listofnull
));
3330 SCM_CLEAR_MACROEXP (debug
);
3332 switch (SCM_MACRO_TYPE (proc
))
3336 if (scm_ilength (arg1
) <= 0)
3337 arg1
= scm_list_2 (SCM_IM_BEGIN
, arg1
);
3339 if (!SCM_CLOSUREP (SCM_MACRO_CODE (proc
)))
3342 SCM_SETCAR (x
, SCM_CAR (arg1
));
3343 SCM_SETCDR (x
, SCM_CDR (arg1
));
3347 /* Prevent memoizing of debug info expression. */
3348 debug
.info
->e
.exp
= scm_cons_source (debug
.info
->e
.exp
,
3353 SCM_SETCAR (x
, SCM_CAR (arg1
));
3354 SCM_SETCDR (x
, SCM_CDR (arg1
));
3356 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
3358 #if SCM_ENABLE_DEPRECATED == 1
3363 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
3375 proc
= SCM_CEVAL (SCM_CAR (x
), env
);
3378 if (SCM_MACROP (proc
))
3379 goto handle_a_macro
;
3383 evapply
: /* inputs: x, proc */
3384 PREP_APPLY (proc
, SCM_EOL
);
3385 if (SCM_NULLP (SCM_CDR (x
))) {
3388 SCM_ASRTGO (!SCM_IMP (proc
), badfun
);
3389 switch (SCM_TYP7 (proc
))
3390 { /* no arguments given */
3391 case scm_tc7_subr_0
:
3392 RETURN (SCM_SUBRF (proc
) ());
3393 case scm_tc7_subr_1o
:
3394 RETURN (SCM_SUBRF (proc
) (SCM_UNDEFINED
));
3396 RETURN (SCM_SUBRF (proc
) (SCM_EOL
));
3397 case scm_tc7_rpsubr
:
3398 RETURN (SCM_BOOL_T
);
3400 RETURN (SCM_SUBRF (proc
) (SCM_UNDEFINED
, SCM_UNDEFINED
));
3402 if (!SCM_SMOB_APPLICABLE_P (proc
))
3404 RETURN (SCM_SMOB_APPLY_0 (proc
));
3407 proc
= SCM_CCLO_SUBR (proc
);
3409 debug
.info
->a
.proc
= proc
;
3410 debug
.info
->a
.args
= scm_list_1 (arg1
);
3414 proc
= SCM_PROCEDURE (proc
);
3416 debug
.info
->a
.proc
= proc
;
3418 if (!SCM_CLOSUREP (proc
))
3421 case scm_tcs_closures
:
3423 const SCM formals
= SCM_CLOSURE_FORMALS (proc
);
3424 if (SCM_CONSP (formals
))
3425 goto umwrongnumargs
;
3426 x
= SCM_CLOSURE_BODY (proc
);
3427 env
= SCM_EXTEND_ENV (formals
, SCM_EOL
, SCM_ENV (proc
));
3428 goto nontoplevel_begin
;
3430 case scm_tcs_struct
:
3431 if (SCM_OBJ_CLASS_FLAGS (proc
) & SCM_CLASSF_PURE_GENERIC
)
3433 x
= SCM_ENTITY_PROCEDURE (proc
);
3437 else if (SCM_I_OPERATORP (proc
))
3440 proc
= (SCM_I_ENTITYP (proc
)
3441 ? SCM_ENTITY_PROCEDURE (proc
)
3442 : SCM_OPERATOR_PROCEDURE (proc
));
3444 debug
.info
->a
.proc
= proc
;
3445 debug
.info
->a
.args
= scm_list_1 (arg1
);
3451 case scm_tc7_subr_1
:
3452 case scm_tc7_subr_2
:
3453 case scm_tc7_subr_2o
:
3456 case scm_tc7_subr_3
:
3457 case scm_tc7_lsubr_2
:
3460 scm_wrong_num_args (proc
);
3463 scm_misc_error (NULL
, "Wrong type to apply: ~S", scm_list_1 (proc
));
3467 /* must handle macros by here */
3470 arg1
= EVALCAR (x
, env
);
3472 scm_wrong_num_args (proc
);
3474 debug
.info
->a
.args
= scm_list_1 (arg1
);
3482 evap1
: /* inputs: proc, arg1 */
3483 SCM_ASRTGO (!SCM_IMP (proc
), badfun
);
3484 switch (SCM_TYP7 (proc
))
3485 { /* have one argument in arg1 */
3486 case scm_tc7_subr_2o
:
3487 RETURN (SCM_SUBRF (proc
) (arg1
, SCM_UNDEFINED
));
3488 case scm_tc7_subr_1
:
3489 case scm_tc7_subr_1o
:
3490 RETURN (SCM_SUBRF (proc
) (arg1
));
3492 if (SCM_INUMP (arg1
))
3494 RETURN (scm_make_real (SCM_DSUBRF (proc
) ((double) SCM_INUM (arg1
))));
3496 else if (SCM_REALP (arg1
))
3498 RETURN (scm_make_real (SCM_DSUBRF (proc
) (SCM_REAL_VALUE (arg1
))));
3500 else if (SCM_BIGP (arg1
))
3502 RETURN (scm_make_real (SCM_DSUBRF (proc
) (scm_i_big2dbl (arg1
))));
3504 SCM_WTA_DISPATCH_1 (*SCM_SUBR_GENERIC (proc
), arg1
,
3505 SCM_ARG1
, SCM_SYMBOL_CHARS (SCM_SNAME (proc
)));
3508 unsigned char pattern
= (scm_t_bits
) SCM_SUBRF (proc
);
3511 SCM_ASSERT (SCM_CONSP (arg1
), arg1
, SCM_ARG1
,
3512 SCM_SYMBOL_CHARS (SCM_SNAME (proc
)));
3513 arg1
= (pattern
& 1) ? SCM_CAR (arg1
) : SCM_CDR (arg1
);
3518 case scm_tc7_rpsubr
:
3519 RETURN (SCM_BOOL_T
);
3521 RETURN (SCM_SUBRF (proc
) (arg1
, SCM_UNDEFINED
));
3524 RETURN (SCM_SUBRF (proc
) (debug
.info
->a
.args
));
3526 RETURN (SCM_SUBRF (proc
) (scm_list_1 (arg1
)));
3529 if (!SCM_SMOB_APPLICABLE_P (proc
))
3531 RETURN (SCM_SMOB_APPLY_1 (proc
, arg1
));
3535 proc
= SCM_CCLO_SUBR (proc
);
3537 debug
.info
->a
.args
= scm_cons (arg1
, debug
.info
->a
.args
);
3538 debug
.info
->a
.proc
= proc
;
3542 proc
= SCM_PROCEDURE (proc
);
3544 debug
.info
->a
.proc
= proc
;
3546 if (!SCM_CLOSUREP (proc
))
3549 case scm_tcs_closures
:
3552 const SCM formals
= SCM_CLOSURE_FORMALS (proc
);
3553 if (SCM_NULLP (formals
)
3554 || (SCM_CONSP (formals
) && SCM_CONSP (SCM_CDR (formals
))))
3555 goto umwrongnumargs
;
3556 x
= SCM_CLOSURE_BODY (proc
);
3558 env
= SCM_EXTEND_ENV (formals
,
3562 env
= SCM_EXTEND_ENV (formals
,
3566 goto nontoplevel_begin
;
3568 case scm_tcs_struct
:
3569 if (SCM_OBJ_CLASS_FLAGS (proc
) & SCM_CLASSF_PURE_GENERIC
)
3571 x
= SCM_ENTITY_PROCEDURE (proc
);
3573 arg1
= debug
.info
->a
.args
;
3575 arg1
= scm_list_1 (arg1
);
3579 else if (SCM_I_OPERATORP (proc
))
3583 proc
= (SCM_I_ENTITYP (proc
)
3584 ? SCM_ENTITY_PROCEDURE (proc
)
3585 : SCM_OPERATOR_PROCEDURE (proc
));
3587 debug
.info
->a
.args
= scm_cons (arg1
, debug
.info
->a
.args
);
3588 debug
.info
->a
.proc
= proc
;
3594 case scm_tc7_subr_2
:
3595 case scm_tc7_subr_0
:
3596 case scm_tc7_subr_3
:
3597 case scm_tc7_lsubr_2
:
3598 scm_wrong_num_args (proc
);
3604 arg2
= EVALCAR (x
, env
);
3606 scm_wrong_num_args (proc
);
3608 { /* have two or more arguments */
3610 debug
.info
->a
.args
= scm_list_2 (arg1
, arg2
);
3613 if (SCM_NULLP (x
)) {
3616 SCM_ASRTGO (!SCM_IMP (proc
), badfun
);
3617 switch (SCM_TYP7 (proc
))
3618 { /* have two arguments */
3619 case scm_tc7_subr_2
:
3620 case scm_tc7_subr_2o
:
3621 RETURN (SCM_SUBRF (proc
) (arg1
, arg2
));
3624 RETURN (SCM_SUBRF (proc
) (debug
.info
->a
.args
));
3626 RETURN (SCM_SUBRF (proc
) (scm_list_2 (arg1
, arg2
)));
3628 case scm_tc7_lsubr_2
:
3629 RETURN (SCM_SUBRF (proc
) (arg1
, arg2
, SCM_EOL
));
3630 case scm_tc7_rpsubr
:
3632 RETURN (SCM_SUBRF (proc
) (arg1
, arg2
));
3634 if (!SCM_SMOB_APPLICABLE_P (proc
))
3636 RETURN (SCM_SMOB_APPLY_2 (proc
, arg1
, arg2
));
3640 RETURN (SCM_APPLY (SCM_CCLO_SUBR (proc
),
3641 scm_cons (proc
, debug
.info
->a
.args
),
3644 RETURN (SCM_APPLY (SCM_CCLO_SUBR (proc
),
3645 scm_cons2 (proc
, arg1
,
3652 case scm_tcs_struct
:
3653 if (SCM_OBJ_CLASS_FLAGS (proc
) & SCM_CLASSF_PURE_GENERIC
)
3655 x
= SCM_ENTITY_PROCEDURE (proc
);
3657 arg1
= debug
.info
->a
.args
;
3659 arg1
= scm_list_2 (arg1
, arg2
);
3663 else if (SCM_I_OPERATORP (proc
))
3667 RETURN (SCM_APPLY (SCM_I_ENTITYP (proc
)
3668 ? SCM_ENTITY_PROCEDURE (proc
)
3669 : SCM_OPERATOR_PROCEDURE (proc
),
3670 scm_cons (proc
, debug
.info
->a
.args
),
3673 RETURN (SCM_APPLY (SCM_I_ENTITYP (proc
)
3674 ? SCM_ENTITY_PROCEDURE (proc
)
3675 : SCM_OPERATOR_PROCEDURE (proc
),
3676 scm_cons2 (proc
, arg1
,
3686 case scm_tc7_subr_0
:
3689 case scm_tc7_subr_1o
:
3690 case scm_tc7_subr_1
:
3691 case scm_tc7_subr_3
:
3692 scm_wrong_num_args (proc
);
3696 proc
= SCM_PROCEDURE (proc
);
3698 debug
.info
->a
.proc
= proc
;
3700 if (!SCM_CLOSUREP (proc
))
3703 case scm_tcs_closures
:
3706 const SCM formals
= SCM_CLOSURE_FORMALS (proc
);
3707 if (SCM_NULLP (formals
)
3708 || (SCM_CONSP (formals
)
3709 && (SCM_NULLP (SCM_CDR (formals
))
3710 || (SCM_CONSP (SCM_CDR (formals
))
3711 && SCM_CONSP (SCM_CDDR (formals
))))))
3712 goto umwrongnumargs
;
3714 env
= SCM_EXTEND_ENV (formals
,
3718 env
= SCM_EXTEND_ENV (formals
,
3719 scm_list_2 (arg1
, arg2
),
3722 x
= SCM_CLOSURE_BODY (proc
);
3723 goto nontoplevel_begin
;
3728 scm_wrong_num_args (proc
);
3730 debug
.info
->a
.args
= scm_cons2 (arg1
, arg2
,
3731 deval_args (x
, env
, proc
,
3732 SCM_CDRLOC (SCM_CDR (debug
.info
->a
.args
))));
3736 SCM_ASRTGO (!SCM_IMP (proc
), badfun
);
3737 switch (SCM_TYP7 (proc
))
3738 { /* have 3 or more arguments */
3740 case scm_tc7_subr_3
:
3741 if (!SCM_NULLP (SCM_CDR (x
)))
3742 scm_wrong_num_args (proc
);
3744 RETURN (SCM_SUBRF (proc
) (arg1
, arg2
,
3745 SCM_CADDR (debug
.info
->a
.args
)));
3747 arg1
= SCM_SUBRF(proc
)(arg1
, arg2
);
3748 arg2
= SCM_CDDR (debug
.info
->a
.args
);
3751 arg1
= SCM_SUBRF(proc
)(arg1
, SCM_CAR (arg2
));
3752 arg2
= SCM_CDR (arg2
);
3754 while (SCM_NIMP (arg2
));
3756 case scm_tc7_rpsubr
:
3757 if (SCM_FALSEP (SCM_SUBRF (proc
) (arg1
, arg2
)))
3758 RETURN (SCM_BOOL_F
);
3759 arg1
= SCM_CDDR (debug
.info
->a
.args
);
3762 if (SCM_FALSEP (SCM_SUBRF (proc
) (arg2
, SCM_CAR (arg1
))))
3763 RETURN (SCM_BOOL_F
);
3764 arg2
= SCM_CAR (arg1
);
3765 arg1
= SCM_CDR (arg1
);
3767 while (SCM_NIMP (arg1
));
3768 RETURN (SCM_BOOL_T
);
3769 case scm_tc7_lsubr_2
:
3770 RETURN (SCM_SUBRF (proc
) (arg1
, arg2
,
3771 SCM_CDDR (debug
.info
->a
.args
)));
3773 RETURN (SCM_SUBRF (proc
) (debug
.info
->a
.args
));
3775 if (!SCM_SMOB_APPLICABLE_P (proc
))
3777 RETURN (SCM_SMOB_APPLY_3 (proc
, arg1
, arg2
,
3778 SCM_CDDR (debug
.info
->a
.args
)));
3782 proc
= SCM_PROCEDURE (proc
);
3783 debug
.info
->a
.proc
= proc
;
3784 if (!SCM_CLOSUREP (proc
))
3787 case scm_tcs_closures
:
3789 const SCM formals
= SCM_CLOSURE_FORMALS (proc
);
3790 if (SCM_NULLP (formals
)
3791 || (SCM_CONSP (formals
)
3792 && (SCM_NULLP (SCM_CDR (formals
))
3793 || (SCM_CONSP (SCM_CDR (formals
))
3794 && scm_badargsp (SCM_CDDR (formals
), x
)))))
3795 goto umwrongnumargs
;
3796 SCM_SET_ARGSREADY (debug
);
3797 env
= SCM_EXTEND_ENV (formals
,
3800 x
= SCM_CLOSURE_BODY (proc
);
3801 goto nontoplevel_begin
;
3804 case scm_tc7_subr_3
:
3805 if (!SCM_NULLP (SCM_CDR (x
)))
3806 scm_wrong_num_args (proc
);
3808 RETURN (SCM_SUBRF (proc
) (arg1
, arg2
, EVALCAR (x
, env
)));
3810 arg1
= SCM_SUBRF (proc
) (arg1
, arg2
);
3813 arg1
= SCM_SUBRF(proc
)(arg1
, EVALCAR(x
, env
));
3816 while (SCM_NIMP (x
));
3818 case scm_tc7_rpsubr
:
3819 if (SCM_FALSEP (SCM_SUBRF (proc
) (arg1
, arg2
)))
3820 RETURN (SCM_BOOL_F
);
3823 arg1
= EVALCAR (x
, env
);
3824 if (SCM_FALSEP (SCM_SUBRF (proc
) (arg2
, arg1
)))
3825 RETURN (SCM_BOOL_F
);
3829 while (SCM_NIMP (x
));
3830 RETURN (SCM_BOOL_T
);
3831 case scm_tc7_lsubr_2
:
3832 RETURN (SCM_SUBRF (proc
) (arg1
, arg2
, scm_eval_args (x
, env
, proc
)));
3834 RETURN (SCM_SUBRF (proc
) (scm_cons2 (arg1
,
3836 scm_eval_args (x
, env
, proc
))));
3838 if (!SCM_SMOB_APPLICABLE_P (proc
))
3840 RETURN (SCM_SMOB_APPLY_3 (proc
, arg1
, arg2
,
3841 scm_eval_args (x
, env
, proc
)));
3845 proc
= SCM_PROCEDURE (proc
);
3846 if (!SCM_CLOSUREP (proc
))
3849 case scm_tcs_closures
:
3851 const SCM formals
= SCM_CLOSURE_FORMALS (proc
);
3852 if (SCM_NULLP (formals
)
3853 || (SCM_CONSP (formals
)
3854 && (SCM_NULLP (SCM_CDR (formals
))
3855 || (SCM_CONSP (SCM_CDR (formals
))
3856 && scm_badargsp (SCM_CDDR (formals
), x
)))))
3857 goto umwrongnumargs
;
3858 env
= SCM_EXTEND_ENV (formals
,
3861 scm_eval_args (x
, env
, proc
)),
3863 x
= SCM_CLOSURE_BODY (proc
);
3864 goto nontoplevel_begin
;
3867 case scm_tcs_struct
:
3868 if (SCM_OBJ_CLASS_FLAGS (proc
) & SCM_CLASSF_PURE_GENERIC
)
3871 arg1
= debug
.info
->a
.args
;
3873 arg1
= scm_cons2 (arg1
, arg2
, scm_eval_args (x
, env
, proc
));
3875 x
= SCM_ENTITY_PROCEDURE (proc
);
3878 else if (SCM_I_OPERATORP (proc
))
3882 case scm_tc7_subr_2
:
3883 case scm_tc7_subr_1o
:
3884 case scm_tc7_subr_2o
:
3885 case scm_tc7_subr_0
:
3888 case scm_tc7_subr_1
:
3889 scm_wrong_num_args (proc
);
3897 if (scm_check_exit_p
&& SCM_TRAPS_P
)
3898 if (SCM_EXIT_FRAME_P
|| (SCM_TRACE_P
&& SCM_TRACED_FRAME_P (debug
)))
3900 SCM_CLEAR_TRACED_FRAME (debug
);
3901 if (SCM_CHEAPTRAPS_P
)
3902 arg1
= scm_make_debugobj (&debug
);
3906 SCM val
= scm_make_continuation (&first
);
3917 scm_call_3 (SCM_EXIT_FRAME_HDLR
, scm_sym_exit_frame
, arg1
, proc
);
3921 scm_last_debug_frame
= debug
.prev
;
3927 /* SECTION: This code is compiled once.
3934 /* Simple procedure calls
3938 scm_call_0 (SCM proc
)
3940 return scm_apply (proc
, SCM_EOL
, SCM_EOL
);
3944 scm_call_1 (SCM proc
, SCM arg1
)
3946 return scm_apply (proc
, arg1
, scm_listofnull
);
3950 scm_call_2 (SCM proc
, SCM arg1
, SCM arg2
)
3952 return scm_apply (proc
, arg1
, scm_cons (arg2
, scm_listofnull
));
3956 scm_call_3 (SCM proc
, SCM arg1
, SCM arg2
, SCM arg3
)
3958 return scm_apply (proc
, arg1
, scm_cons2 (arg2
, arg3
, scm_listofnull
));
3962 scm_call_4 (SCM proc
, SCM arg1
, SCM arg2
, SCM arg3
, SCM arg4
)
3964 return scm_apply (proc
, arg1
, scm_cons2 (arg2
, arg3
,
3965 scm_cons (arg4
, scm_listofnull
)));
3968 /* Simple procedure applies
3972 scm_apply_0 (SCM proc
, SCM args
)
3974 return scm_apply (proc
, args
, SCM_EOL
);
3978 scm_apply_1 (SCM proc
, SCM arg1
, SCM args
)
3980 return scm_apply (proc
, scm_cons (arg1
, args
), SCM_EOL
);
3984 scm_apply_2 (SCM proc
, SCM arg1
, SCM arg2
, SCM args
)
3986 return scm_apply (proc
, scm_cons2 (arg1
, arg2
, args
), SCM_EOL
);
3990 scm_apply_3 (SCM proc
, SCM arg1
, SCM arg2
, SCM arg3
, SCM args
)
3992 return scm_apply (proc
, scm_cons (arg1
, scm_cons2 (arg2
, arg3
, args
)),
3996 /* This code processes the arguments to apply:
3998 (apply PROC ARG1 ... ARGS)
4000 Given a list (ARG1 ... ARGS), this function conses the ARG1
4001 ... arguments onto the front of ARGS, and returns the resulting
4002 list. Note that ARGS is a list; thus, the argument to this
4003 function is a list whose last element is a list.
4005 Apply calls this function, and applies PROC to the elements of the
4006 result. apply:nconc2last takes care of building the list of
4007 arguments, given (ARG1 ... ARGS).
4009 Rather than do new consing, apply:nconc2last destroys its argument.
4010 On that topic, this code came into my care with the following
4011 beautifully cryptic comment on that topic: "This will only screw
4012 you if you do (scm_apply scm_apply '( ... ))" If you know what
4013 they're referring to, send me a patch to this comment. */
4015 SCM_DEFINE (scm_nconc2last
, "apply:nconc2last", 1, 0, 0,
4017 "Given a list (@var{arg1} @dots{} @var{args}), this function\n"
4018 "conses the @var{arg1} @dots{} arguments onto the front of\n"
4019 "@var{args}, and returns the resulting list. Note that\n"
4020 "@var{args} is a list; thus, the argument to this function is\n"
4021 "a list whose last element is a list.\n"
4022 "Note: Rather than do new consing, @code{apply:nconc2last}\n"
4023 "destroys its argument, so use with care.")
4024 #define FUNC_NAME s_scm_nconc2last
4027 SCM_VALIDATE_NONEMPTYLIST (1, lst
);
4029 while (!SCM_NULLP (SCM_CDR (*lloc
))) /* Perhaps should be
4030 SCM_NULL_OR_NIL_P, but not
4031 needed in 99.99% of cases,
4032 and it could seriously hurt
4033 performance. - Neil */
4034 lloc
= SCM_CDRLOC (*lloc
);
4035 SCM_ASSERT (scm_ilength (SCM_CAR (*lloc
)) >= 0, lst
, SCM_ARG1
, FUNC_NAME
);
4036 *lloc
= SCM_CAR (*lloc
);
4044 /* SECTION: When DEVAL is defined this code yields scm_dapply.
4045 * It is compiled twice.
4050 scm_apply (SCM proc
, SCM arg1
, SCM args
)
4056 scm_dapply (SCM proc
, SCM arg1
, SCM args
)
4061 /* Apply a function to a list of arguments.
4063 This function is exported to the Scheme level as taking two
4064 required arguments and a tail argument, as if it were:
4065 (lambda (proc arg1 . args) ...)
4066 Thus, if you just have a list of arguments to pass to a procedure,
4067 pass the list as ARG1, and '() for ARGS. If you have some fixed
4068 args, pass the first as ARG1, then cons any remaining fixed args
4069 onto the front of your argument list, and pass that as ARGS. */
4072 SCM_APPLY (SCM proc
, SCM arg1
, SCM args
)
4075 scm_t_debug_frame debug
;
4076 scm_t_debug_info debug_vect_body
;
4077 debug
.prev
= scm_last_debug_frame
;
4078 debug
.status
= SCM_APPLYFRAME
;
4079 debug
.vect
= &debug_vect_body
;
4080 debug
.vect
[0].a
.proc
= proc
;
4081 debug
.vect
[0].a
.args
= SCM_EOL
;
4082 scm_last_debug_frame
= &debug
;
4085 return scm_dapply (proc
, arg1
, args
);
4088 SCM_ASRTGO (SCM_NIMP (proc
), badproc
);
4090 /* If ARGS is the empty list, then we're calling apply with only two
4091 arguments --- ARG1 is the list of arguments for PROC. Whatever
4092 the case, futz with things so that ARG1 is the first argument to
4093 give to PROC (or SCM_UNDEFINED if no args), and ARGS contains the
4096 Setting the debug apply frame args this way is pretty messy.
4097 Perhaps we should store arg1 and args directly in the frame as
4098 received, and let scm_frame_arguments unpack them, because that's
4099 a relatively rare operation. This works for now; if the Guile
4100 developer archives are still around, see Mikael's post of
4102 if (SCM_NULLP (args
))
4104 if (SCM_NULLP (arg1
))
4106 arg1
= SCM_UNDEFINED
;
4108 debug
.vect
[0].a
.args
= SCM_EOL
;
4114 debug
.vect
[0].a
.args
= arg1
;
4116 args
= SCM_CDR (arg1
);
4117 arg1
= SCM_CAR (arg1
);
4122 args
= scm_nconc2last (args
);
4124 debug
.vect
[0].a
.args
= scm_cons (arg1
, args
);
4128 if (SCM_ENTER_FRAME_P
&& SCM_TRAPS_P
)
4131 if (SCM_CHEAPTRAPS_P
)
4132 tmp
= scm_make_debugobj (&debug
);
4137 tmp
= scm_make_continuation (&first
);
4142 scm_call_2 (SCM_ENTER_FRAME_HDLR
, scm_sym_enter_frame
, tmp
);
4149 switch (SCM_TYP7 (proc
))
4151 case scm_tc7_subr_2o
:
4152 args
= SCM_NULLP (args
) ? SCM_UNDEFINED
: SCM_CAR (args
);
4153 RETURN (SCM_SUBRF (proc
) (arg1
, args
));
4154 case scm_tc7_subr_2
:
4155 if (SCM_NULLP (args
) || !SCM_NULLP (SCM_CDR (args
)))
4156 scm_wrong_num_args (proc
);
4157 args
= SCM_CAR (args
);
4158 RETURN (SCM_SUBRF (proc
) (arg1
, args
));
4159 case scm_tc7_subr_0
:
4160 if (!SCM_UNBNDP (arg1
))
4161 scm_wrong_num_args (proc
);
4163 RETURN (SCM_SUBRF (proc
) ());
4164 case scm_tc7_subr_1
:
4165 if (SCM_UNBNDP (arg1
))
4166 scm_wrong_num_args (proc
);
4167 case scm_tc7_subr_1o
:
4168 if (!SCM_NULLP (args
))
4169 scm_wrong_num_args (proc
);
4171 RETURN (SCM_SUBRF (proc
) (arg1
));
4173 if (SCM_UNBNDP (arg1
) || !SCM_NULLP (args
))
4174 scm_wrong_num_args (proc
);
4175 if (SCM_INUMP (arg1
))
4177 RETURN (scm_make_real (SCM_DSUBRF (proc
) ((double) SCM_INUM (arg1
))));
4179 else if (SCM_REALP (arg1
))
4181 RETURN (scm_make_real (SCM_DSUBRF (proc
) (SCM_REAL_VALUE (arg1
))));
4183 else if (SCM_BIGP (arg1
))
4184 RETURN (scm_make_real (SCM_DSUBRF (proc
) (scm_i_big2dbl (arg1
))));
4185 SCM_WTA_DISPATCH_1 (*SCM_SUBR_GENERIC (proc
), arg1
,
4186 SCM_ARG1
, SCM_SYMBOL_CHARS (SCM_SNAME (proc
)));
4188 if (SCM_UNBNDP (arg1
) || !SCM_NULLP (args
))
4189 scm_wrong_num_args (proc
);
4191 unsigned char pattern
= (scm_t_bits
) SCM_SUBRF (proc
);
4194 SCM_ASSERT (SCM_CONSP (arg1
), arg1
, SCM_ARG1
,
4195 SCM_SYMBOL_CHARS (SCM_SNAME (proc
)));
4196 arg1
= (pattern
& 1) ? SCM_CAR (arg1
) : SCM_CDR (arg1
);
4201 case scm_tc7_subr_3
:
4202 if (SCM_NULLP (args
)
4203 || SCM_NULLP (SCM_CDR (args
))
4204 || !SCM_NULLP (SCM_CDDR (args
)))
4205 scm_wrong_num_args (proc
);
4207 RETURN (SCM_SUBRF (proc
) (arg1
, SCM_CAR (args
), SCM_CADR (args
)));
4210 RETURN (SCM_SUBRF (proc
) (SCM_UNBNDP (arg1
) ? SCM_EOL
: debug
.vect
[0].a
.args
));
4212 RETURN (SCM_SUBRF (proc
) (SCM_UNBNDP (arg1
) ? SCM_EOL
: scm_cons (arg1
, args
)));
4214 case scm_tc7_lsubr_2
:
4215 if (!SCM_CONSP (args
))
4216 scm_wrong_num_args (proc
);
4218 RETURN (SCM_SUBRF (proc
) (arg1
, SCM_CAR (args
), SCM_CDR (args
)));
4220 if (SCM_NULLP (args
))
4221 RETURN (SCM_SUBRF (proc
) (arg1
, SCM_UNDEFINED
));
4222 while (SCM_NIMP (args
))
4224 SCM_ASSERT (SCM_CONSP (args
), args
, SCM_ARG2
, "apply");
4225 arg1
= SCM_SUBRF (proc
) (arg1
, SCM_CAR (args
));
4226 args
= SCM_CDR (args
);
4229 case scm_tc7_rpsubr
:
4230 if (SCM_NULLP (args
))
4231 RETURN (SCM_BOOL_T
);
4232 while (SCM_NIMP (args
))
4234 SCM_ASSERT (SCM_CONSP (args
), args
, SCM_ARG2
, "apply");
4235 if (SCM_FALSEP (SCM_SUBRF (proc
) (arg1
, SCM_CAR (args
))))
4236 RETURN (SCM_BOOL_F
);
4237 arg1
= SCM_CAR (args
);
4238 args
= SCM_CDR (args
);
4240 RETURN (SCM_BOOL_T
);
4241 case scm_tcs_closures
:
4243 arg1
= (SCM_UNBNDP (arg1
) ? SCM_EOL
: debug
.vect
[0].a
.args
);
4245 arg1
= (SCM_UNBNDP (arg1
) ? SCM_EOL
: scm_cons (arg1
, args
));
4247 if (scm_badargsp (SCM_CLOSURE_FORMALS (proc
), arg1
))
4248 scm_wrong_num_args (proc
);
4250 /* Copy argument list */
4255 SCM tl
= args
= scm_cons (SCM_CAR (arg1
), SCM_UNSPECIFIED
);
4256 for (arg1
= SCM_CDR (arg1
); SCM_CONSP (arg1
); arg1
= SCM_CDR (arg1
))
4258 SCM_SETCDR (tl
, scm_cons (SCM_CAR (arg1
), SCM_UNSPECIFIED
));
4261 SCM_SETCDR (tl
, arg1
);
4264 args
= SCM_EXTEND_ENV (SCM_CLOSURE_FORMALS (proc
),
4267 proc
= SCM_CLOSURE_BODY (proc
);
4269 arg1
= SCM_CDR (proc
);
4270 while (!SCM_NULLP (arg1
))
4272 if (SCM_IMP (SCM_CAR (proc
)))
4274 if (SCM_ISYMP (SCM_CAR (proc
)))
4276 scm_rec_mutex_lock (&source_mutex
);
4277 /* check for race condition */
4278 if (SCM_ISYMP (SCM_CAR (proc
)))
4279 proc
= scm_m_expand_body (proc
, args
);
4280 scm_rec_mutex_unlock (&source_mutex
);
4284 SCM_VALIDATE_NON_EMPTY_COMBINATION (SCM_CAR (proc
));
4287 SCM_CEVAL (SCM_CAR (proc
), args
);
4289 arg1
= SCM_CDR (proc
);
4291 RETURN (EVALCAR (proc
, args
));
4293 if (!SCM_SMOB_APPLICABLE_P (proc
))
4295 if (SCM_UNBNDP (arg1
))
4296 RETURN (SCM_SMOB_APPLY_0 (proc
));
4297 else if (SCM_NULLP (args
))
4298 RETURN (SCM_SMOB_APPLY_1 (proc
, arg1
));
4299 else if (SCM_NULLP (SCM_CDR (args
)))
4300 RETURN (SCM_SMOB_APPLY_2 (proc
, arg1
, SCM_CAR (args
)));
4302 RETURN (SCM_SMOB_APPLY_3 (proc
, arg1
, SCM_CAR (args
), SCM_CDR (args
)));
4305 args
= (SCM_UNBNDP(arg1
) ? SCM_EOL
: debug
.vect
[0].a
.args
);
4307 proc
= SCM_CCLO_SUBR (proc
);
4308 debug
.vect
[0].a
.proc
= proc
;
4309 debug
.vect
[0].a
.args
= scm_cons (arg1
, args
);
4311 args
= (SCM_UNBNDP(arg1
) ? SCM_EOL
: scm_cons (arg1
, args
));
4313 proc
= SCM_CCLO_SUBR (proc
);
4317 proc
= SCM_PROCEDURE (proc
);
4319 debug
.vect
[0].a
.proc
= proc
;
4322 case scm_tcs_struct
:
4323 if (SCM_OBJ_CLASS_FLAGS (proc
) & SCM_CLASSF_PURE_GENERIC
)
4326 args
= (SCM_UNBNDP(arg1
) ? SCM_EOL
: debug
.vect
[0].a
.args
);
4328 args
= (SCM_UNBNDP(arg1
) ? SCM_EOL
: scm_cons (arg1
, args
));
4330 RETURN (scm_apply_generic (proc
, args
));
4332 else if (SCM_I_OPERATORP (proc
))
4336 args
= (SCM_UNBNDP(arg1
) ? SCM_EOL
: debug
.vect
[0].a
.args
);
4338 args
= (SCM_UNBNDP(arg1
) ? SCM_EOL
: scm_cons (arg1
, args
));
4341 proc
= (SCM_I_ENTITYP (proc
)
4342 ? SCM_ENTITY_PROCEDURE (proc
)
4343 : SCM_OPERATOR_PROCEDURE (proc
));
4345 debug
.vect
[0].a
.proc
= proc
;
4346 debug
.vect
[0].a
.args
= scm_cons (arg1
, args
);
4348 if (SCM_NIMP (proc
))
4357 scm_wrong_type_arg ("apply", SCM_ARG1
, proc
);
4361 if (scm_check_exit_p
&& SCM_TRAPS_P
)
4362 if (SCM_EXIT_FRAME_P
|| (SCM_TRACE_P
&& SCM_TRACED_FRAME_P (debug
)))
4364 SCM_CLEAR_TRACED_FRAME (debug
);
4365 if (SCM_CHEAPTRAPS_P
)
4366 arg1
= scm_make_debugobj (&debug
);
4370 SCM val
= scm_make_continuation (&first
);
4381 scm_call_3 (SCM_EXIT_FRAME_HDLR
, scm_sym_exit_frame
, arg1
, proc
);
4385 scm_last_debug_frame
= debug
.prev
;
4391 /* SECTION: The rest of this file is only read once.
4398 * Trampolines make it possible to move procedure application dispatch
4399 * outside inner loops. The motivation was clean implementation of
4400 * efficient replacements of R5RS primitives in SRFI-1.
4402 * The semantics is clear: scm_trampoline_N returns an optimized
4403 * version of scm_call_N (or NULL if the procedure isn't applicable
4406 * Applying the optimization to map and for-each increased efficiency
4407 * noticeably. For example, (map abs ls) is now 8 times faster than
4412 call_subr0_0 (SCM proc
)
4414 return SCM_SUBRF (proc
) ();
4418 call_subr1o_0 (SCM proc
)
4420 return SCM_SUBRF (proc
) (SCM_UNDEFINED
);
4424 call_lsubr_0 (SCM proc
)
4426 return SCM_SUBRF (proc
) (SCM_EOL
);
4430 scm_i_call_closure_0 (SCM proc
)
4432 const SCM env
= SCM_EXTEND_ENV (SCM_CLOSURE_FORMALS (proc
),
4435 const SCM result
= scm_eval_body (SCM_CLOSURE_BODY (proc
), env
);
4440 scm_trampoline_0 (SCM proc
)
4446 switch (SCM_TYP7 (proc
))
4448 case scm_tc7_subr_0
:
4449 return call_subr0_0
;
4450 case scm_tc7_subr_1o
:
4451 return call_subr1o_0
;
4453 return call_lsubr_0
;
4454 case scm_tcs_closures
:
4456 SCM formals
= SCM_CLOSURE_FORMALS (proc
);
4457 if (SCM_NULLP (formals
) || !SCM_CONSP (formals
))
4458 return scm_i_call_closure_0
;
4462 case scm_tcs_struct
:
4463 if (SCM_OBJ_CLASS_FLAGS (proc
) & SCM_CLASSF_PURE_GENERIC
)
4464 return scm_call_generic_0
;
4465 else if (SCM_I_OPERATORP (proc
))
4469 if (SCM_SMOB_APPLICABLE_P (proc
))
4470 return SCM_SMOB_DESCRIPTOR (proc
).apply_0
;
4474 case scm_tc7_rpsubr
:
4479 return NULL
; /* not applicable on one arg */
4484 call_subr1_1 (SCM proc
, SCM arg1
)
4486 return SCM_SUBRF (proc
) (arg1
);
4490 call_subr2o_1 (SCM proc
, SCM arg1
)
4492 return SCM_SUBRF (proc
) (arg1
, SCM_UNDEFINED
);
4496 call_lsubr_1 (SCM proc
, SCM arg1
)
4498 return SCM_SUBRF (proc
) (scm_list_1 (arg1
));
4502 call_dsubr_1 (SCM proc
, SCM arg1
)
4504 if (SCM_INUMP (arg1
))
4506 RETURN (scm_make_real (SCM_DSUBRF (proc
) ((double) SCM_INUM (arg1
))));
4508 else if (SCM_REALP (arg1
))
4510 RETURN (scm_make_real (SCM_DSUBRF (proc
) (SCM_REAL_VALUE (arg1
))));
4512 else if (SCM_BIGP (arg1
))
4513 RETURN (scm_make_real (SCM_DSUBRF (proc
) (scm_i_big2dbl (arg1
))));
4514 SCM_WTA_DISPATCH_1 (*SCM_SUBR_GENERIC (proc
), arg1
,
4515 SCM_ARG1
, SCM_SYMBOL_CHARS (SCM_SNAME (proc
)));
4519 call_cxr_1 (SCM proc
, SCM arg1
)
4521 unsigned char pattern
= (scm_t_bits
) SCM_SUBRF (proc
);
4524 SCM_ASSERT (SCM_CONSP (arg1
), arg1
, SCM_ARG1
,
4525 SCM_SYMBOL_CHARS (SCM_SNAME (proc
)));
4526 arg1
= (pattern
& 1) ? SCM_CAR (arg1
) : SCM_CDR (arg1
);
4533 call_closure_1 (SCM proc
, SCM arg1
)
4535 const SCM env
= SCM_EXTEND_ENV (SCM_CLOSURE_FORMALS (proc
),
4538 const SCM result
= scm_eval_body (SCM_CLOSURE_BODY (proc
), env
);
4543 scm_trampoline_1 (SCM proc
)
4549 switch (SCM_TYP7 (proc
))
4551 case scm_tc7_subr_1
:
4552 case scm_tc7_subr_1o
:
4553 return call_subr1_1
;
4554 case scm_tc7_subr_2o
:
4555 return call_subr2o_1
;
4557 return call_lsubr_1
;
4559 return call_dsubr_1
;
4562 case scm_tcs_closures
:
4564 SCM formals
= SCM_CLOSURE_FORMALS (proc
);
4565 if (!SCM_NULLP (formals
)
4566 && (!SCM_CONSP (formals
) || !SCM_CONSP (SCM_CDR (formals
))))
4567 return call_closure_1
;
4571 case scm_tcs_struct
:
4572 if (SCM_OBJ_CLASS_FLAGS (proc
) & SCM_CLASSF_PURE_GENERIC
)
4573 return scm_call_generic_1
;
4574 else if (SCM_I_OPERATORP (proc
))
4578 if (SCM_SMOB_APPLICABLE_P (proc
))
4579 return SCM_SMOB_DESCRIPTOR (proc
).apply_1
;
4583 case scm_tc7_rpsubr
:
4588 return NULL
; /* not applicable on one arg */
4593 call_subr2_2 (SCM proc
, SCM arg1
, SCM arg2
)
4595 return SCM_SUBRF (proc
) (arg1
, arg2
);
4599 call_lsubr2_2 (SCM proc
, SCM arg1
, SCM arg2
)
4601 return SCM_SUBRF (proc
) (arg1
, arg2
, SCM_EOL
);
4605 call_lsubr_2 (SCM proc
, SCM arg1
, SCM arg2
)
4607 return SCM_SUBRF (proc
) (scm_list_2 (arg1
, arg2
));
4611 call_closure_2 (SCM proc
, SCM arg1
, SCM arg2
)
4613 const SCM env
= SCM_EXTEND_ENV (SCM_CLOSURE_FORMALS (proc
),
4614 scm_list_2 (arg1
, arg2
),
4616 const SCM result
= scm_eval_body (SCM_CLOSURE_BODY (proc
), env
);
4621 scm_trampoline_2 (SCM proc
)
4627 switch (SCM_TYP7 (proc
))
4629 case scm_tc7_subr_2
:
4630 case scm_tc7_subr_2o
:
4631 case scm_tc7_rpsubr
:
4633 return call_subr2_2
;
4634 case scm_tc7_lsubr_2
:
4635 return call_lsubr2_2
;
4637 return call_lsubr_2
;
4638 case scm_tcs_closures
:
4640 SCM formals
= SCM_CLOSURE_FORMALS (proc
);
4641 if (!SCM_NULLP (formals
)
4642 && (!SCM_CONSP (formals
)
4643 || (!SCM_NULLP (SCM_CDR (formals
))
4644 && (!SCM_CONSP (SCM_CDR (formals
))
4645 || !SCM_CONSP (SCM_CDDR (formals
))))))
4646 return call_closure_2
;
4650 case scm_tcs_struct
:
4651 if (SCM_OBJ_CLASS_FLAGS (proc
) & SCM_CLASSF_PURE_GENERIC
)
4652 return scm_call_generic_2
;
4653 else if (SCM_I_OPERATORP (proc
))
4657 if (SCM_SMOB_APPLICABLE_P (proc
))
4658 return SCM_SMOB_DESCRIPTOR (proc
).apply_2
;
4665 return NULL
; /* not applicable on two args */
4669 /* Typechecking for multi-argument MAP and FOR-EACH.
4671 Verify that each element of the vector ARGV, except for the first,
4672 is a proper list whose length is LEN. Attribute errors to WHO,
4673 and claim that the i'th element of ARGV is WHO's i+2'th argument. */
4675 check_map_args (SCM argv
,
4682 SCM
const *ve
= SCM_VELTS (argv
);
4685 for (i
= SCM_VECTOR_LENGTH (argv
) - 1; i
>= 1; i
--)
4687 long elt_len
= scm_ilength (ve
[i
]);
4692 scm_apply_generic (gf
, scm_cons (proc
, args
));
4694 scm_wrong_type_arg (who
, i
+ 2, ve
[i
]);
4698 scm_out_of_range_pos (who
, ve
[i
], SCM_MAKINUM (i
+ 2));
4701 scm_remember_upto_here_1 (argv
);
4705 SCM_GPROC (s_map
, "map", 2, 0, 1, scm_map
, g_map
);
4707 /* Note: Currently, scm_map applies PROC to the argument list(s)
4708 sequentially, starting with the first element(s). This is used in
4709 evalext.c where the Scheme procedure `map-in-order', which guarantees
4710 sequential behaviour, is implemented using scm_map. If the
4711 behaviour changes, we need to update `map-in-order'.
4715 scm_map (SCM proc
, SCM arg1
, SCM args
)
4716 #define FUNC_NAME s_map
4721 SCM
const *ve
= &args
; /* Keep args from being optimized away. */
4723 len
= scm_ilength (arg1
);
4724 SCM_GASSERTn (len
>= 0,
4725 g_map
, scm_cons2 (proc
, arg1
, args
), SCM_ARG2
, s_map
);
4726 SCM_VALIDATE_REST_ARGUMENT (args
);
4727 if (SCM_NULLP (args
))
4729 scm_t_trampoline_1 call
= scm_trampoline_1 (proc
);
4730 SCM_GASSERT2 (call
, g_map
, proc
, arg1
, SCM_ARG1
, s_map
);
4731 while (SCM_NIMP (arg1
))
4733 *pres
= scm_list_1 (call (proc
, SCM_CAR (arg1
)));
4734 pres
= SCM_CDRLOC (*pres
);
4735 arg1
= SCM_CDR (arg1
);
4739 if (SCM_NULLP (SCM_CDR (args
)))
4741 SCM arg2
= SCM_CAR (args
);
4742 int len2
= scm_ilength (arg2
);
4743 scm_t_trampoline_2 call
= scm_trampoline_2 (proc
);
4745 g_map
, scm_cons2 (proc
, arg1
, args
), SCM_ARG1
, s_map
);
4746 SCM_GASSERTn (len2
>= 0,
4747 g_map
, scm_cons2 (proc
, arg1
, args
), SCM_ARG3
, s_map
);
4749 SCM_OUT_OF_RANGE (3, arg2
);
4750 while (SCM_NIMP (arg1
))
4752 *pres
= scm_list_1 (call (proc
, SCM_CAR (arg1
), SCM_CAR (arg2
)));
4753 pres
= SCM_CDRLOC (*pres
);
4754 arg1
= SCM_CDR (arg1
);
4755 arg2
= SCM_CDR (arg2
);
4759 arg1
= scm_cons (arg1
, args
);
4760 args
= scm_vector (arg1
);
4761 ve
= SCM_VELTS (args
);
4762 check_map_args (args
, len
, g_map
, proc
, arg1
, s_map
);
4766 for (i
= SCM_VECTOR_LENGTH (args
) - 1; i
>= 0; i
--)
4768 if (SCM_IMP (ve
[i
]))
4770 arg1
= scm_cons (SCM_CAR (ve
[i
]), arg1
);
4771 SCM_VECTOR_SET (args
, i
, SCM_CDR (ve
[i
]));
4773 *pres
= scm_list_1 (scm_apply (proc
, arg1
, SCM_EOL
));
4774 pres
= SCM_CDRLOC (*pres
);
4780 SCM_GPROC (s_for_each
, "for-each", 2, 0, 1, scm_for_each
, g_for_each
);
4783 scm_for_each (SCM proc
, SCM arg1
, SCM args
)
4784 #define FUNC_NAME s_for_each
4786 SCM
const *ve
= &args
; /* Keep args from being optimized away. */
4788 len
= scm_ilength (arg1
);
4789 SCM_GASSERTn (len
>= 0, g_for_each
, scm_cons2 (proc
, arg1
, args
),
4790 SCM_ARG2
, s_for_each
);
4791 SCM_VALIDATE_REST_ARGUMENT (args
);
4792 if (SCM_NULLP (args
))
4794 scm_t_trampoline_1 call
= scm_trampoline_1 (proc
);
4795 SCM_GASSERT2 (call
, g_for_each
, proc
, arg1
, SCM_ARG1
, s_for_each
);
4796 while (SCM_NIMP (arg1
))
4798 call (proc
, SCM_CAR (arg1
));
4799 arg1
= SCM_CDR (arg1
);
4801 return SCM_UNSPECIFIED
;
4803 if (SCM_NULLP (SCM_CDR (args
)))
4805 SCM arg2
= SCM_CAR (args
);
4806 int len2
= scm_ilength (arg2
);
4807 scm_t_trampoline_2 call
= scm_trampoline_2 (proc
);
4808 SCM_GASSERTn (call
, g_for_each
,
4809 scm_cons2 (proc
, arg1
, args
), SCM_ARG1
, s_for_each
);
4810 SCM_GASSERTn (len2
>= 0, g_for_each
,
4811 scm_cons2 (proc
, arg1
, args
), SCM_ARG3
, s_for_each
);
4813 SCM_OUT_OF_RANGE (3, arg2
);
4814 while (SCM_NIMP (arg1
))
4816 call (proc
, SCM_CAR (arg1
), SCM_CAR (arg2
));
4817 arg1
= SCM_CDR (arg1
);
4818 arg2
= SCM_CDR (arg2
);
4820 return SCM_UNSPECIFIED
;
4822 arg1
= scm_cons (arg1
, args
);
4823 args
= scm_vector (arg1
);
4824 ve
= SCM_VELTS (args
);
4825 check_map_args (args
, len
, g_for_each
, proc
, arg1
, s_for_each
);
4829 for (i
= SCM_VECTOR_LENGTH (args
) - 1; i
>= 0; i
--)
4831 if (SCM_IMP (ve
[i
]))
4832 return SCM_UNSPECIFIED
;
4833 arg1
= scm_cons (SCM_CAR (ve
[i
]), arg1
);
4834 SCM_VECTOR_SET (args
, i
, SCM_CDR (ve
[i
]));
4836 scm_apply (proc
, arg1
, SCM_EOL
);
4843 scm_closure (SCM code
, SCM env
)
4846 SCM closcar
= scm_cons (code
, SCM_EOL
);
4847 z
= scm_cell (SCM_UNPACK (closcar
) + scm_tc3_closure
, (scm_t_bits
) env
);
4848 scm_remember_upto_here (closcar
);
4853 scm_t_bits scm_tc16_promise
;
4856 scm_makprom (SCM code
)
4858 SCM_RETURN_NEWSMOB2 (scm_tc16_promise
,
4860 scm_make_rec_mutex ());
4864 promise_free (SCM promise
)
4866 scm_rec_mutex_free (SCM_PROMISE_MUTEX (promise
));
4871 promise_print (SCM exp
, SCM port
, scm_print_state
*pstate
)
4873 int writingp
= SCM_WRITINGP (pstate
);
4874 scm_puts ("#<promise ", port
);
4875 SCM_SET_WRITINGP (pstate
, 1);
4876 scm_iprin1 (SCM_PROMISE_DATA (exp
), port
, pstate
);
4877 SCM_SET_WRITINGP (pstate
, writingp
);
4878 scm_putc ('>', port
);
4882 SCM_DEFINE (scm_force
, "force", 1, 0, 0,
4884 "If the promise @var{x} has not been computed yet, compute and\n"
4885 "return @var{x}, otherwise just return the previously computed\n"
4887 #define FUNC_NAME s_scm_force
4889 SCM_VALIDATE_SMOB (1, promise
, promise
);
4890 scm_rec_mutex_lock (SCM_PROMISE_MUTEX (promise
));
4891 if (!SCM_PROMISE_COMPUTED_P (promise
))
4893 SCM ans
= scm_call_0 (SCM_PROMISE_DATA (promise
));
4894 if (!SCM_PROMISE_COMPUTED_P (promise
))
4896 SCM_SET_PROMISE_DATA (promise
, ans
);
4897 SCM_SET_PROMISE_COMPUTED (promise
);
4900 scm_rec_mutex_unlock (SCM_PROMISE_MUTEX (promise
));
4901 return SCM_PROMISE_DATA (promise
);
4906 SCM_DEFINE (scm_promise_p
, "promise?", 1, 0, 0,
4908 "Return true if @var{obj} is a promise, i.e. a delayed computation\n"
4909 "(@pxref{Delayed evaluation,,,r5rs.info,The Revised^5 Report on Scheme}).")
4910 #define FUNC_NAME s_scm_promise_p
4912 return SCM_BOOL (SCM_TYP16_PREDICATE (scm_tc16_promise
, obj
));
4917 SCM_DEFINE (scm_cons_source
, "cons-source", 3, 0, 0,
4918 (SCM xorig
, SCM x
, SCM y
),
4919 "Create and return a new pair whose car and cdr are @var{x} and @var{y}.\n"
4920 "Any source properties associated with @var{xorig} are also associated\n"
4921 "with the new pair.")
4922 #define FUNC_NAME s_scm_cons_source
4925 z
= scm_cons (x
, y
);
4926 /* Copy source properties possibly associated with xorig. */
4927 p
= scm_whash_lookup (scm_source_whash
, xorig
);
4929 scm_whash_insert (scm_source_whash
, z
, p
);
4935 SCM_DEFINE (scm_copy_tree
, "copy-tree", 1, 0, 0,
4937 "Recursively copy the data tree that is bound to @var{obj}, and return a\n"
4938 "pointer to the new data structure. @code{copy-tree} recurses down the\n"
4939 "contents of both pairs and vectors (since both cons cells and vector\n"
4940 "cells may point to arbitrary objects), and stops recursing when it hits\n"
4941 "any other object.")
4942 #define FUNC_NAME s_scm_copy_tree
4947 if (SCM_VECTORP (obj
))
4949 unsigned long i
= SCM_VECTOR_LENGTH (obj
);
4950 ans
= scm_c_make_vector (i
, SCM_UNSPECIFIED
);
4952 SCM_VECTOR_SET (ans
, i
, scm_copy_tree (SCM_VELTS (obj
)[i
]));
4955 if (!SCM_CONSP (obj
))
4957 ans
= tl
= scm_cons_source (obj
,
4958 scm_copy_tree (SCM_CAR (obj
)),
4960 for (obj
= SCM_CDR (obj
); SCM_CONSP (obj
); obj
= SCM_CDR (obj
))
4962 SCM_SETCDR (tl
, scm_cons (scm_copy_tree (SCM_CAR (obj
)),
4966 SCM_SETCDR (tl
, obj
);
4972 /* We have three levels of EVAL here:
4974 - scm_i_eval (exp, env)
4976 evaluates EXP in environment ENV. ENV is a lexical environment
4977 structure as used by the actual tree code evaluator. When ENV is
4978 a top-level environment, then changes to the current module are
4979 tracked by updating ENV so that it continues to be in sync with
4982 - scm_primitive_eval (exp)
4984 evaluates EXP in the top-level environment as determined by the
4985 current module. This is done by constructing a suitable
4986 environment and calling scm_i_eval. Thus, changes to the
4987 top-level module are tracked normally.
4989 - scm_eval (exp, mod)
4991 evaluates EXP while MOD is the current module. This is done by
4992 setting the current module to MOD, invoking scm_primitive_eval on
4993 EXP, and then restoring the current module to the value it had
4994 previously. That is, while EXP is evaluated, changes to the
4995 current module are tracked, but these changes do not persist when
4998 For each level of evals, there are two variants, distinguished by a
4999 _x suffix: the ordinary variant does not modify EXP while the _x
5000 variant can destructively modify EXP into something completely
5001 unintelligible. A Scheme data structure passed as EXP to one of the
5002 _x variants should not ever be used again for anything. So when in
5003 doubt, use the ordinary variant.
5008 scm_i_eval_x (SCM exp
, SCM env
)
5010 return SCM_XEVAL (exp
, env
);
5014 scm_i_eval (SCM exp
, SCM env
)
5016 exp
= scm_copy_tree (exp
);
5017 return SCM_XEVAL (exp
, env
);
5021 scm_primitive_eval_x (SCM exp
)
5024 SCM transformer
= scm_current_module_transformer ();
5025 if (SCM_NIMP (transformer
))
5026 exp
= scm_call_1 (transformer
, exp
);
5027 env
= scm_top_level_env (scm_current_module_lookup_closure ());
5028 return scm_i_eval_x (exp
, env
);
5031 SCM_DEFINE (scm_primitive_eval
, "primitive-eval", 1, 0, 0,
5033 "Evaluate @var{exp} in the top-level environment specified by\n"
5034 "the current module.")
5035 #define FUNC_NAME s_scm_primitive_eval
5038 SCM transformer
= scm_current_module_transformer ();
5039 if (SCM_NIMP (transformer
))
5040 exp
= scm_call_1 (transformer
, exp
);
5041 env
= scm_top_level_env (scm_current_module_lookup_closure ());
5042 return scm_i_eval (exp
, env
);
5046 /* Eval does not take the second arg optionally. This is intentional
5047 * in order to be R5RS compatible, and to prepare for the new module
5048 * system, where we would like to make the choice of evaluation
5049 * environment explicit. */
5052 change_environment (void *data
)
5054 SCM pair
= SCM_PACK (data
);
5055 SCM new_module
= SCM_CAR (pair
);
5056 SCM old_module
= scm_current_module ();
5057 SCM_SETCDR (pair
, old_module
);
5058 scm_set_current_module (new_module
);
5063 restore_environment (void *data
)
5065 SCM pair
= SCM_PACK (data
);
5066 SCM old_module
= SCM_CDR (pair
);
5067 SCM new_module
= scm_current_module ();
5068 SCM_SETCAR (pair
, new_module
);
5069 scm_set_current_module (old_module
);
5073 inner_eval_x (void *data
)
5075 return scm_primitive_eval_x (SCM_PACK(data
));
5079 scm_eval_x (SCM exp
, SCM module
)
5080 #define FUNC_NAME "eval!"
5082 SCM_VALIDATE_MODULE (2, module
);
5084 return scm_internal_dynamic_wind
5085 (change_environment
, inner_eval_x
, restore_environment
,
5086 (void *) SCM_UNPACK (exp
),
5087 (void *) SCM_UNPACK (scm_cons (module
, SCM_BOOL_F
)));
5092 inner_eval (void *data
)
5094 return scm_primitive_eval (SCM_PACK(data
));
5097 SCM_DEFINE (scm_eval
, "eval", 2, 0, 0,
5098 (SCM exp
, SCM module
),
5099 "Evaluate @var{exp}, a list representing a Scheme expression,\n"
5100 "in the top-level environment specified by @var{module}.\n"
5101 "While @var{exp} is evaluated (using @code{primitive-eval}),\n"
5102 "@var{module} is made the current module. The current module\n"
5103 "is reset to its previous value when @var{eval} returns.")
5104 #define FUNC_NAME s_scm_eval
5106 SCM_VALIDATE_MODULE (2, module
);
5108 return scm_internal_dynamic_wind
5109 (change_environment
, inner_eval
, restore_environment
,
5110 (void *) SCM_UNPACK (exp
),
5111 (void *) SCM_UNPACK (scm_cons (module
, SCM_BOOL_F
)));
5116 /* At this point, scm_deval and scm_dapply are generated.
5126 scm_init_opts (scm_evaluator_traps
,
5127 scm_evaluator_trap_table
,
5128 SCM_N_EVALUATOR_TRAPS
);
5129 scm_init_opts (scm_eval_options_interface
,
5131 SCM_N_EVAL_OPTIONS
);
5133 scm_tc16_promise
= scm_make_smob_type ("promise", 0);
5134 scm_set_smob_mark (scm_tc16_promise
, scm_markcdr
);
5135 scm_set_smob_free (scm_tc16_promise
, promise_free
);
5136 scm_set_smob_print (scm_tc16_promise
, promise_print
);
5138 undefineds
= scm_list_1 (SCM_UNDEFINED
);
5139 SCM_SETCDR (undefineds
, undefineds
);
5140 scm_permanent_object (undefineds
);
5142 scm_listofnull
= scm_list_1 (SCM_EOL
);
5144 f_apply
= scm_c_define_subr ("apply", scm_tc7_lsubr_2
, scm_apply
);
5145 scm_permanent_object (f_apply
);
5147 #include "libguile/eval.x"
5149 scm_add_feature ("delay");