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 static const char s_defun
[] = "Symbol's function definition is void";
1709 SCM_SYNTAX (s_nil_cond
, "nil-cond", scm_i_makbimacro
, scm_m_nil_cond
);
1711 /* nil-cond expressions have the form
1712 * (nil-cond COND VAL COND VAL ... ELSEVAL) */
1714 scm_m_nil_cond (SCM expr
, SCM env SCM_UNUSED
)
1716 const long length
= scm_ilength (SCM_CDR (expr
));
1717 ASSERT_SYNTAX (length
>= 0, s_bad_expression
, expr
);
1718 ASSERT_SYNTAX (length
>= 1 && (length
% 2) == 1, s_expression
, expr
);
1720 SCM_SETCAR (expr
, SCM_IM_NIL_COND
);
1725 SCM_SYNTAX (s_atfop
, "@fop", scm_i_makbimacro
, scm_m_atfop
);
1727 /* The @fop-macro handles procedure and macro applications for elisp. The
1728 * input expression must have the form
1729 * (@fop <var> (transformer-macro <expr> ...))
1730 * where <var> must be a symbol. The expression is transformed into the
1731 * memoized form of either
1732 * (apply <un-aliased var> (transformer-macro <expr> ...))
1733 * if the value of var (across all aliasing) is not a macro, or
1734 * (<un-aliased var> <expr> ...)
1735 * if var is a macro. */
1737 scm_m_atfop (SCM expr
, SCM env SCM_UNUSED
)
1742 const SCM cdr_expr
= SCM_CDR (expr
);
1743 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 0, s_bad_expression
, expr
);
1744 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 1, s_missing_expression
, expr
);
1746 symbol
= SCM_CAR (cdr_expr
);
1747 ASSERT_SYNTAX_2 (SCM_SYMBOLP (symbol
), s_bad_variable
, symbol
, expr
);
1749 location
= scm_symbol_fref (symbol
);
1750 ASSERT_SYNTAX_2 (SCM_VARIABLEP (location
), s_defun
, symbol
, expr
);
1752 /* The elisp function `defalias' allows to define aliases for symbols. To
1753 * look up such definitions, the chain of symbol definitions has to be
1754 * followed up to the terminal symbol. */
1755 while (SCM_SYMBOLP (SCM_VARIABLE_REF (location
)))
1757 const SCM alias
= SCM_VARIABLE_REF (location
);
1758 location
= scm_symbol_fref (alias
);
1759 ASSERT_SYNTAX_2 (SCM_VARIABLEP (location
), s_defun
, symbol
, expr
);
1762 /* Memoize the value location belonging to the terminal symbol. */
1763 SCM_SETCAR (cdr_expr
, location
);
1765 if (!SCM_MACROP (SCM_VARIABLE_REF (location
)))
1767 /* Since the location does not contain a macro, the form is a procedure
1768 * application. Replace `@fop' by `@apply' and transform the expression
1769 * including the `transformer-macro'. */
1770 SCM_SETCAR (expr
, SCM_IM_APPLY
);
1775 /* Since the location contains a macro, the arguments should not be
1776 * transformed, so the `transformer-macro' is cut out. The resulting
1777 * expression starts with the memoized variable, that is at the cdr of
1778 * the input expression. */
1779 SCM_SETCDR (cdr_expr
, SCM_CDADR (cdr_expr
));
1784 #endif /* SCM_ENABLE_ELISP */
1787 /* Start of the memoizers for deprecated macros. */
1790 #if (SCM_ENABLE_DEPRECATED == 1)
1792 SCM_SYNTAX (s_undefine
, "undefine", scm_makacro
, scm_m_undefine
);
1795 scm_m_undefine (SCM expr
, SCM env
)
1800 const SCM cdr_expr
= SCM_CDR (expr
);
1801 ASSERT_SYNTAX (SCM_TOP_LEVEL (env
), "Bad undefine placement in", expr
);
1802 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 0, s_bad_expression
, expr
);
1803 ASSERT_SYNTAX (scm_ilength (cdr_expr
) == 1, s_expression
, expr
);
1805 variable
= SCM_CAR (cdr_expr
);
1806 ASSERT_SYNTAX_2 (SCM_SYMBOLP (variable
), s_bad_variable
, variable
, expr
);
1807 location
= scm_sym2var (variable
, scm_env_top_level (env
), SCM_BOOL_F
);
1808 ASSERT_SYNTAX_2 (!SCM_FALSEP (location
)
1809 && !SCM_UNBNDP (SCM_VARIABLE_REF (location
)),
1810 "variable already unbound ", variable
, expr
);
1811 SCM_VARIABLE_SET (location
, SCM_UNDEFINED
);
1812 return SCM_UNSPECIFIED
;
1819 scm_m_expand_body (SCM xorig
, SCM env
)
1821 SCM x
= SCM_CDR (xorig
), defs
= SCM_EOL
;
1822 char *what
= SCM_ISYMCHARS (SCM_CAR (xorig
)) + 2;
1824 while (SCM_NIMP (x
))
1826 SCM form
= SCM_CAR (x
);
1827 if (!SCM_CONSP (form
))
1829 if (!SCM_SYMBOLP (SCM_CAR (form
)))
1832 form
= scm_macroexp (scm_cons_source (form
,
1837 if (SCM_EQ_P (SCM_IM_DEFINE
, SCM_CAR (form
)))
1839 defs
= scm_cons (SCM_CDR (form
), defs
);
1842 else if (!SCM_IMP (defs
))
1846 else if (SCM_EQ_P (SCM_IM_BEGIN
, SCM_CAR (form
)))
1848 x
= scm_append (scm_list_2 (SCM_CDR (form
), SCM_CDR (x
)));
1852 x
= scm_cons (form
, SCM_CDR (x
));
1857 if (!SCM_NULLP (defs
))
1859 SCM rvars
, inits
, body
, letrec
;
1860 check_bindings (defs
, xorig
);
1861 transform_bindings (defs
, xorig
, &rvars
, &inits
);
1862 body
= scm_m_body (SCM_IM_DEFINE
, x
, what
);
1863 letrec
= scm_cons2 (SCM_IM_LETREC
, rvars
, scm_cons (inits
, body
));
1864 SCM_SETCAR (xorig
, letrec
);
1865 SCM_SETCDR (xorig
, SCM_EOL
);
1869 SCM_ASSYNT (SCM_CONSP (x
), s_body
, what
);
1870 SCM_SETCAR (xorig
, SCM_CAR (x
));
1871 SCM_SETCDR (xorig
, SCM_CDR (x
));
1878 scm_macroexp (SCM x
, SCM env
)
1880 SCM res
, proc
, orig_sym
;
1882 /* Don't bother to produce error messages here. We get them when we
1883 eventually execute the code for real. */
1886 orig_sym
= SCM_CAR (x
);
1887 if (!SCM_SYMBOLP (orig_sym
))
1891 SCM
*proc_ptr
= scm_lookupcar1 (x
, env
, 0);
1892 if (proc_ptr
== NULL
)
1894 /* We have lost the race. */
1900 /* Only handle memoizing macros. `Acros' and `macros' are really
1901 special forms and should not be evaluated here. */
1903 if (!SCM_MACROP (proc
)
1904 || (SCM_MACRO_TYPE (proc
) != 2 && !SCM_BUILTIN_MACRO_P (proc
)))
1907 SCM_SETCAR (x
, orig_sym
); /* Undo memoizing effect of lookupcar */
1908 res
= scm_call_2 (SCM_MACRO_CODE (proc
), x
, env
);
1910 if (scm_ilength (res
) <= 0)
1911 res
= scm_list_2 (SCM_IM_BEGIN
, res
);
1914 SCM_SETCAR (x
, SCM_CAR (res
));
1915 SCM_SETCDR (x
, SCM_CDR (res
));
1921 #define SCM_BIT7(x) (127 & SCM_UNPACK (x))
1923 /* A function object to implement "apply" for non-closure functions. */
1925 /* An endless list consisting of #<undefined> objects: */
1926 static SCM undefineds
;
1928 /* scm_unmemocopy takes a memoized expression together with its
1929 * environment and rewrites it to its original form. Thus, it is the
1930 * inversion of the rewrite rules above. The procedure is not
1931 * optimized for speed. It's used in scm_iprin1 when printing the
1932 * code of a closure, in scm_procedure_source, in display_frame when
1933 * generating the source for a stackframe in a backtrace, and in
1934 * display_expression.
1936 * Unmemoizing is not a reliable process. You cannot in general
1937 * expect to get the original source back.
1939 * However, GOOPS currently relies on this for method compilation.
1940 * This ought to change.
1944 build_binding_list (SCM names
, SCM inits
)
1946 SCM bindings
= SCM_EOL
;
1947 while (!SCM_NULLP (names
))
1949 SCM binding
= scm_list_2 (SCM_CAR (names
), SCM_CAR (inits
));
1950 bindings
= scm_cons (binding
, bindings
);
1951 names
= SCM_CDR (names
);
1952 inits
= SCM_CDR (inits
);
1958 unmemocopy (SCM x
, SCM env
)
1963 if (SCM_VECTORP (x
))
1965 return scm_list_2 (scm_sym_quote
, x
);
1967 else if (!SCM_CONSP (x
))
1970 p
= scm_whash_lookup (scm_source_whash
, x
);
1971 switch (SCM_ITAG7 (SCM_CAR (x
)))
1973 case SCM_BIT7 (SCM_IM_AND
):
1974 ls
= z
= scm_cons (scm_sym_and
, SCM_UNSPECIFIED
);
1976 case SCM_BIT7 (SCM_IM_BEGIN
):
1977 ls
= z
= scm_cons (scm_sym_begin
, SCM_UNSPECIFIED
);
1979 case SCM_BIT7 (SCM_IM_CASE
):
1980 ls
= z
= scm_cons (scm_sym_case
, SCM_UNSPECIFIED
);
1982 case SCM_BIT7 (SCM_IM_COND
):
1983 ls
= z
= scm_cons (scm_sym_cond
, SCM_UNSPECIFIED
);
1985 case SCM_BIT7 (SCM_IM_DO
):
1987 /* format: (#@do (i1 ... ik) (nk nk-1 ...) (test) (body) s1 ... sk),
1988 * where ix is an initializer for a local variable, nx is the name of
1989 * the local variable, test is the test clause of the do loop, body is
1990 * the body of the do loop and sx are the step clauses for the local
1992 SCM names
, inits
, test
, memoized_body
, steps
, bindings
;
1995 inits
= scm_reverse (unmemocopy (SCM_CAR (x
), env
));
1997 names
= SCM_CAR (x
);
1998 env
= SCM_EXTEND_ENV (names
, SCM_EOL
, env
);
2000 test
= unmemocopy (SCM_CAR (x
), env
);
2002 memoized_body
= SCM_CAR (x
);
2004 steps
= scm_reverse (unmemocopy (x
, env
));
2006 /* build transformed binding list */
2008 while (!SCM_NULLP (names
))
2010 SCM name
= SCM_CAR (names
);
2011 SCM init
= SCM_CAR (inits
);
2012 SCM step
= SCM_CAR (steps
);
2013 step
= SCM_EQ_P (step
, name
) ? SCM_EOL
: scm_list_1 (step
);
2015 bindings
= scm_cons (scm_cons2 (name
, init
, step
), bindings
);
2017 names
= SCM_CDR (names
);
2018 inits
= SCM_CDR (inits
);
2019 steps
= SCM_CDR (steps
);
2021 z
= scm_cons (test
, SCM_UNSPECIFIED
);
2022 ls
= scm_cons2 (scm_sym_do
, bindings
, z
);
2024 x
= scm_cons (SCM_BOOL_F
, memoized_body
);
2027 case SCM_BIT7 (SCM_IM_IF
):
2028 ls
= z
= scm_cons (scm_sym_if
, SCM_UNSPECIFIED
);
2030 case SCM_BIT7 (SCM_IM_LET
):
2032 /* format: (#@let (nk nk-1 ...) (i1 ... ik) b1 ...),
2033 * where nx is the name of a local variable, ix is an initializer for
2034 * the local variable and by are the body clauses. */
2035 SCM names
, inits
, bindings
;
2038 names
= SCM_CAR (x
);
2040 inits
= scm_reverse (unmemocopy (SCM_CAR (x
), env
));
2041 env
= SCM_EXTEND_ENV (names
, SCM_EOL
, env
);
2043 bindings
= build_binding_list (names
, inits
);
2044 z
= scm_cons (bindings
, SCM_UNSPECIFIED
);
2045 ls
= scm_cons (scm_sym_let
, z
);
2048 case SCM_BIT7 (SCM_IM_LETREC
):
2050 /* format: (#@letrec (nk nk-1 ...) (i1 ... ik) b1 ...),
2051 * where nx is the name of a local variable, ix is an initializer for
2052 * the local variable and by are the body clauses. */
2053 SCM names
, inits
, bindings
;
2056 names
= SCM_CAR (x
);
2057 env
= SCM_EXTEND_ENV (names
, SCM_EOL
, env
);
2059 inits
= scm_reverse (unmemocopy (SCM_CAR (x
), env
));
2061 bindings
= build_binding_list (names
, inits
);
2062 z
= scm_cons (bindings
, SCM_UNSPECIFIED
);
2063 ls
= scm_cons (scm_sym_letrec
, z
);
2066 case SCM_BIT7 (SCM_IM_LETSTAR
):
2074 env
= SCM_EXTEND_ENV (SCM_EOL
, SCM_EOL
, env
);
2077 y
= z
= scm_acons (SCM_CAR (b
),
2079 scm_cons (unmemocopy (SCM_CADR (b
), env
), SCM_EOL
), env
),
2081 env
= SCM_EXTEND_ENV (SCM_CAR (b
), SCM_BOOL_F
, env
);
2085 SCM_SETCDR (y
, SCM_EOL
);
2086 z
= scm_cons (y
, SCM_UNSPECIFIED
);
2087 ls
= scm_cons (scm_sym_let
, z
);
2092 SCM_SETCDR (z
, scm_acons (SCM_CAR (b
),
2094 scm_list_1 (unmemocopy (SCM_CADR (b
), env
)), env
),
2097 env
= SCM_EXTEND_ENV (SCM_CAR (b
), SCM_BOOL_F
, env
);
2100 while (SCM_NIMP (b
));
2101 SCM_SETCDR (z
, SCM_EOL
);
2103 z
= scm_cons (y
, SCM_UNSPECIFIED
);
2104 ls
= scm_cons (scm_sym_letstar
, z
);
2107 case SCM_BIT7 (SCM_IM_OR
):
2108 ls
= z
= scm_cons (scm_sym_or
, SCM_UNSPECIFIED
);
2110 case SCM_BIT7 (SCM_IM_LAMBDA
):
2112 z
= scm_cons (SCM_CAR (x
), SCM_UNSPECIFIED
);
2113 ls
= scm_cons (scm_sym_lambda
, z
);
2114 env
= SCM_EXTEND_ENV (SCM_CAR (x
), SCM_EOL
, env
);
2116 case SCM_BIT7 (SCM_IM_QUOTE
):
2117 ls
= z
= scm_cons (scm_sym_quote
, SCM_UNSPECIFIED
);
2119 case SCM_BIT7 (SCM_IM_SET_X
):
2120 ls
= z
= scm_cons (scm_sym_set_x
, SCM_UNSPECIFIED
);
2122 case SCM_BIT7 (SCM_MAKISYM (0)):
2124 switch (SCM_ISYMNUM (z
))
2126 case (SCM_ISYMNUM (SCM_IM_DEFINE
)):
2131 z
= scm_cons (n
, SCM_UNSPECIFIED
);
2132 ls
= scm_cons (scm_sym_define
, z
);
2133 if (!SCM_NULLP (env
))
2134 env
= scm_cons (scm_cons (scm_cons (n
, SCM_CAAR (env
)),
2139 case (SCM_ISYMNUM (SCM_IM_APPLY
)):
2140 ls
= z
= scm_cons (scm_sym_atapply
, SCM_UNSPECIFIED
);
2142 case (SCM_ISYMNUM (SCM_IM_CONT
)):
2143 ls
= z
= scm_cons (scm_sym_atcall_cc
, SCM_UNSPECIFIED
);
2145 case (SCM_ISYMNUM (SCM_IM_DELAY
)):
2146 ls
= z
= scm_cons (scm_sym_delay
, SCM_UNSPECIFIED
);
2149 case (SCM_ISYMNUM (SCM_IM_FUTURE
)):
2150 ls
= z
= scm_cons (scm_sym_future
, SCM_UNSPECIFIED
);
2153 case (SCM_ISYMNUM (SCM_IM_CALL_WITH_VALUES
)):
2154 ls
= z
= scm_cons (scm_sym_at_call_with_values
, SCM_UNSPECIFIED
);
2156 case (SCM_ISYMNUM (SCM_IM_ELSE
)):
2157 ls
= z
= scm_cons (scm_sym_else
, SCM_UNSPECIFIED
);
2160 /* appease the Sun compiler god: */ ;
2163 ls
= z
= unmemocar (scm_cons (unmemocopy (SCM_CAR (x
), env
),
2169 while (SCM_CONSP (x
))
2171 SCM form
= SCM_CAR (x
);
2172 if (!SCM_ISYMP (form
))
2174 SCM copy
= scm_cons (unmemocopy (form
, env
), SCM_UNSPECIFIED
);
2175 SCM_SETCDR (z
, unmemocar (copy
, env
));
2178 else if (SCM_EQ_P (form
, SCM_IM_ARROW
))
2180 SCM_SETCDR (z
, scm_cons (scm_sym_arrow
, SCM_UNSPECIFIED
));
2186 if (!SCM_FALSEP (p
))
2187 scm_whash_insert (scm_source_whash
, ls
, p
);
2193 scm_unmemocopy (SCM x
, SCM env
)
2195 if (!SCM_NULLP (env
))
2196 /* Make a copy of the lowest frame to protect it from
2197 modifications by SCM_IM_DEFINE */
2198 return unmemocopy (x
, scm_cons (SCM_CAR (env
), SCM_CDR (env
)));
2200 return unmemocopy (x
, env
);
2205 scm_badargsp (SCM formals
, SCM args
)
2207 while (!SCM_NULLP (formals
))
2209 if (!SCM_CONSP (formals
))
2211 if (SCM_NULLP (args
))
2213 formals
= SCM_CDR (formals
);
2214 args
= SCM_CDR (args
);
2216 return !SCM_NULLP (args
) ? 1 : 0;
2221 scm_eval_args (SCM l
, SCM env
, SCM proc
)
2223 SCM results
= SCM_EOL
, *lloc
= &results
, res
;
2224 while (SCM_CONSP (l
))
2226 res
= EVALCAR (l
, env
);
2228 *lloc
= scm_list_1 (res
);
2229 lloc
= SCM_CDRLOC (*lloc
);
2233 scm_wrong_num_args (proc
);
2239 scm_eval_body (SCM code
, SCM env
)
2243 next
= SCM_CDR (code
);
2244 while (!SCM_NULLP (next
))
2246 if (SCM_IMP (SCM_CAR (code
)))
2248 if (SCM_ISYMP (SCM_CAR (code
)))
2250 scm_rec_mutex_lock (&source_mutex
);
2251 /* check for race condition */
2252 if (SCM_ISYMP (SCM_CAR (code
)))
2253 code
= scm_m_expand_body (code
, env
);
2254 scm_rec_mutex_unlock (&source_mutex
);
2259 SCM_XEVAL (SCM_CAR (code
), env
);
2261 next
= SCM_CDR (code
);
2263 return SCM_XEVALCAR (code
, env
);
2269 /* SECTION: This code is specific for the debugging support. One
2270 * branch is read when DEVAL isn't defined, the other when DEVAL is
2276 #define SCM_APPLY scm_apply
2277 #define PREP_APPLY(proc, args)
2279 #define RETURN(x) do { return x; } while (0)
2280 #ifdef STACK_CHECKING
2281 #ifndef NO_CEVAL_STACK_CHECKING
2282 #define EVAL_STACK_CHECKING
2289 #define SCM_CEVAL scm_deval /* Substitute all uses of scm_ceval */
2291 #define SCM_APPLY scm_dapply
2293 #define PREP_APPLY(p, l) \
2294 { ++debug.info; debug.info->a.proc = p; debug.info->a.args = l; }
2296 #define ENTER_APPLY \
2298 SCM_SET_ARGSREADY (debug);\
2299 if (scm_check_apply_p && SCM_TRAPS_P)\
2300 if (SCM_APPLY_FRAME_P || (SCM_TRACE_P && PROCTRACEP (proc)))\
2302 SCM tmp, tail = SCM_BOOL(SCM_TRACED_FRAME_P (debug)); \
2303 SCM_SET_TRACED_FRAME (debug); \
2305 if (SCM_CHEAPTRAPS_P)\
2307 tmp = scm_make_debugobj (&debug);\
2308 scm_call_3 (SCM_APPLY_FRAME_HDLR, scm_sym_apply_frame, tmp, tail);\
2313 tmp = scm_make_continuation (&first);\
2315 scm_call_3 (SCM_APPLY_FRAME_HDLR, scm_sym_apply_frame, tmp, tail);\
2321 #define RETURN(e) do { proc = (e); goto exit; } while (0)
2322 #ifdef STACK_CHECKING
2323 #ifndef EVAL_STACK_CHECKING
2324 #define EVAL_STACK_CHECKING
2328 /* scm_ceval_ptr points to the currently selected evaluator.
2329 * *fixme*: Although efficiency is important here, this state variable
2330 * should probably not be a global. It should be related to the
2335 SCM (*scm_ceval_ptr
) (SCM x
, SCM env
);
2337 /* scm_last_debug_frame contains a pointer to the last debugging
2338 * information stack frame. It is accessed very often from the
2339 * debugging evaluator, so it should probably not be indirectly
2340 * addressed. Better to save and restore it from the current root at
2344 /* scm_debug_eframe_size is the number of slots available for pseudo
2345 * stack frames at each real stack frame.
2348 long scm_debug_eframe_size
;
2350 int scm_debug_mode
, scm_check_entry_p
, scm_check_apply_p
, scm_check_exit_p
;
2352 long scm_eval_stack
;
2354 scm_t_option scm_eval_opts
[] = {
2355 { SCM_OPTION_INTEGER
, "stack", 22000, "Size of thread stacks (in machine words)." }
2358 scm_t_option scm_debug_opts
[] = {
2359 { SCM_OPTION_BOOLEAN
, "cheap", 1,
2360 "*Flyweight representation of the stack at traps." },
2361 { SCM_OPTION_BOOLEAN
, "breakpoints", 0, "*Check for breakpoints." },
2362 { SCM_OPTION_BOOLEAN
, "trace", 0, "*Trace mode." },
2363 { SCM_OPTION_BOOLEAN
, "procnames", 1,
2364 "Record procedure names at definition." },
2365 { SCM_OPTION_BOOLEAN
, "backwards", 0,
2366 "Display backtrace in anti-chronological order." },
2367 { SCM_OPTION_INTEGER
, "width", 79, "Maximal width of backtrace." },
2368 { SCM_OPTION_INTEGER
, "indent", 10, "Maximal indentation in backtrace." },
2369 { SCM_OPTION_INTEGER
, "frames", 3,
2370 "Maximum number of tail-recursive frames in backtrace." },
2371 { SCM_OPTION_INTEGER
, "maxdepth", 1000,
2372 "Maximal number of stored backtrace frames." },
2373 { SCM_OPTION_INTEGER
, "depth", 20, "Maximal length of printed backtrace." },
2374 { SCM_OPTION_BOOLEAN
, "backtrace", 0, "Show backtrace on error." },
2375 { SCM_OPTION_BOOLEAN
, "debug", 0, "Use the debugging evaluator." },
2376 { SCM_OPTION_INTEGER
, "stack", 20000, "Stack size limit (measured in words; 0 = no check)." },
2377 { 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."}
2380 scm_t_option scm_evaluator_trap_table
[] = {
2381 { SCM_OPTION_BOOLEAN
, "traps", 0, "Enable evaluator traps." },
2382 { SCM_OPTION_BOOLEAN
, "enter-frame", 0, "Trap when eval enters new frame." },
2383 { SCM_OPTION_BOOLEAN
, "apply-frame", 0, "Trap when entering apply." },
2384 { SCM_OPTION_BOOLEAN
, "exit-frame", 0, "Trap when exiting eval or apply." },
2385 { SCM_OPTION_SCM
, "enter-frame-handler", (unsigned long)SCM_BOOL_F
, "Handler for enter-frame traps." },
2386 { SCM_OPTION_SCM
, "apply-frame-handler", (unsigned long)SCM_BOOL_F
, "Handler for apply-frame traps." },
2387 { SCM_OPTION_SCM
, "exit-frame-handler", (unsigned long)SCM_BOOL_F
, "Handler for exit-frame traps." }
2390 SCM_DEFINE (scm_eval_options_interface
, "eval-options-interface", 0, 1, 0,
2392 "Option interface for the evaluation options. Instead of using\n"
2393 "this procedure directly, use the procedures @code{eval-enable},\n"
2394 "@code{eval-disable}, @code{eval-set!} and @code{eval-options}.")
2395 #define FUNC_NAME s_scm_eval_options_interface
2399 ans
= scm_options (setting
,
2403 scm_eval_stack
= SCM_EVAL_STACK
* sizeof (void *);
2410 SCM_DEFINE (scm_evaluator_traps
, "evaluator-traps-interface", 0, 1, 0,
2412 "Option interface for the evaluator trap options.")
2413 #define FUNC_NAME s_scm_evaluator_traps
2417 ans
= scm_options (setting
,
2418 scm_evaluator_trap_table
,
2419 SCM_N_EVALUATOR_TRAPS
,
2421 SCM_RESET_DEBUG_MODE
;
2429 deval_args (SCM l
, SCM env
, SCM proc
, SCM
*lloc
)
2431 SCM
*results
= lloc
, res
;
2432 while (SCM_CONSP (l
))
2434 res
= EVALCAR (l
, env
);
2436 *lloc
= scm_list_1 (res
);
2437 lloc
= SCM_CDRLOC (*lloc
);
2441 scm_wrong_num_args (proc
);
2448 /* SECTION: This code is compiled twice.
2452 /* Update the toplevel environment frame ENV so that it refers to the
2453 * current module. */
2454 #define UPDATE_TOPLEVEL_ENV(env) \
2456 SCM p = scm_current_module_lookup_closure (); \
2457 if (p != SCM_CAR (env)) \
2458 env = scm_top_level_env (p); \
2462 /* This is the evaluator. Like any real monster, it has three heads:
2464 * scm_ceval is the non-debugging evaluator, scm_deval is the debugging
2465 * version. Both are implemented using a common code base, using the
2466 * following mechanism: SCM_CEVAL is a macro, which is either defined to
2467 * scm_ceval or scm_deval. Thus, there is no function SCM_CEVAL, but the code
2468 * for SCM_CEVAL actually compiles to either scm_ceval or scm_deval. When
2469 * SCM_CEVAL is defined to scm_ceval, it is known that the macro DEVAL is not
2470 * defined. When SCM_CEVAL is defined to scm_deval, then the macro DEVAL is
2471 * known to be defined. Thus, in SCM_CEVAL parts for the debugging evaluator
2472 * are enclosed within #ifdef DEVAL ... #endif.
2474 * All three (scm_ceval, scm_deval and their common implementation SCM_CEVAL)
2475 * take two input parameters, x and env: x is a single expression to be
2476 * evalutated. env is the environment in which bindings are searched.
2478 * x is known to be a cell (i. e. a pair or any other non-immediate). Since x
2479 * is a single expression, it is necessarily in a tail position. If x is just
2480 * a call to another function like in the expression (foo exp1 exp2 ...), the
2481 * realization of that call therefore _must_not_ increase stack usage (the
2482 * evaluation of exp1, exp2 etc., however, may do so). This is realized by
2483 * making extensive use of 'goto' statements within the evaluator: The gotos
2484 * replace recursive calls to SCM_CEVAL, thus re-using the same stack frame
2485 * that SCM_CEVAL was already using. If, however, x represents some form that
2486 * requires to evaluate a sequence of expressions like (begin exp1 exp2 ...),
2487 * then recursive calls to SCM_CEVAL are performed for all but the last
2488 * expression of that sequence. */
2492 scm_ceval (SCM x
, SCM env
)
2498 scm_deval (SCM x
, SCM env
)
2503 SCM_CEVAL (SCM x
, SCM env
)
2507 scm_t_debug_frame debug
;
2508 scm_t_debug_info
*debug_info_end
;
2509 debug
.prev
= scm_last_debug_frame
;
2512 * The debug.vect contains twice as much scm_t_debug_info frames as the
2513 * user has specified with (debug-set! frames <n>).
2515 * Even frames are eval frames, odd frames are apply frames.
2517 debug
.vect
= (scm_t_debug_info
*) alloca (scm_debug_eframe_size
2518 * sizeof (scm_t_debug_info
));
2519 debug
.info
= debug
.vect
;
2520 debug_info_end
= debug
.vect
+ scm_debug_eframe_size
;
2521 scm_last_debug_frame
= &debug
;
2523 #ifdef EVAL_STACK_CHECKING
2524 if (scm_stack_checking_enabled_p
&& SCM_STACK_OVERFLOW_P (&proc
))
2527 debug
.info
->e
.exp
= x
;
2528 debug
.info
->e
.env
= env
;
2530 scm_report_stack_overflow ();
2540 SCM_CLEAR_ARGSREADY (debug
);
2541 if (SCM_OVERFLOWP (debug
))
2544 * In theory, this should be the only place where it is necessary to
2545 * check for space in debug.vect since both eval frames and
2546 * available space are even.
2548 * For this to be the case, however, it is necessary that primitive
2549 * special forms which jump back to `loop', `begin' or some similar
2550 * label call PREP_APPLY.
2552 else if (++debug
.info
>= debug_info_end
)
2554 SCM_SET_OVERFLOW (debug
);
2559 debug
.info
->e
.exp
= x
;
2560 debug
.info
->e
.env
= env
;
2561 if (scm_check_entry_p
&& SCM_TRAPS_P
)
2563 if (SCM_ENTER_FRAME_P
2564 || (SCM_BREAKPOINTS_P
&& scm_c_source_property_breakpoint_p (x
)))
2567 SCM tail
= SCM_BOOL (SCM_TAILRECP (debug
));
2568 SCM_SET_TAILREC (debug
);
2569 if (SCM_CHEAPTRAPS_P
)
2570 stackrep
= scm_make_debugobj (&debug
);
2574 SCM val
= scm_make_continuation (&first
);
2584 /* This gives the possibility for the debugger to
2585 modify the source expression before evaluation. */
2590 scm_call_4 (SCM_ENTER_FRAME_HDLR
,
2591 scm_sym_enter_frame
,
2594 scm_unmemocopy (x
, env
));
2601 switch (SCM_TYP7 (x
))
2603 case scm_tc7_symbol
:
2604 /* Only happens when called at top level. */
2605 x
= scm_cons (x
, SCM_UNDEFINED
);
2606 RETURN (*scm_lookupcar (x
, env
, 1));
2608 case SCM_BIT7 (SCM_IM_AND
):
2610 while (!SCM_NULLP (SCM_CDR (x
)))
2612 SCM test_result
= EVALCAR (x
, env
);
2613 if (SCM_FALSEP (test_result
) || SCM_NILP (test_result
))
2614 RETURN (SCM_BOOL_F
);
2618 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
2621 case SCM_BIT7 (SCM_IM_BEGIN
):
2624 RETURN (SCM_UNSPECIFIED
);
2626 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
2629 /* If we are on toplevel with a lookup closure, we need to sync
2630 with the current module. */
2631 if (SCM_CONSP (env
) && !SCM_CONSP (SCM_CAR (env
)))
2633 UPDATE_TOPLEVEL_ENV (env
);
2634 while (!SCM_NULLP (SCM_CDR (x
)))
2637 UPDATE_TOPLEVEL_ENV (env
);
2643 goto nontoplevel_begin
;
2646 while (!SCM_NULLP (SCM_CDR (x
)))
2648 SCM form
= SCM_CAR (x
);
2651 if (SCM_ISYMP (form
))
2653 scm_rec_mutex_lock (&source_mutex
);
2654 /* check for race condition */
2655 if (SCM_ISYMP (SCM_CAR (x
)))
2656 x
= scm_m_expand_body (x
, env
);
2657 scm_rec_mutex_unlock (&source_mutex
);
2658 goto nontoplevel_begin
;
2661 SCM_VALIDATE_NON_EMPTY_COMBINATION (form
);
2664 SCM_CEVAL (form
, env
);
2670 /* scm_eval last form in list */
2671 SCM last_form
= SCM_CAR (x
);
2673 if (SCM_CONSP (last_form
))
2675 /* This is by far the most frequent case. */
2677 goto loop
; /* tail recurse */
2679 else if (SCM_IMP (last_form
))
2680 RETURN (SCM_EVALIM (last_form
, env
));
2681 else if (SCM_VARIABLEP (last_form
))
2682 RETURN (SCM_VARIABLE_REF (last_form
));
2683 else if (SCM_SYMBOLP (last_form
))
2684 RETURN (*scm_lookupcar (x
, env
, 1));
2690 case SCM_BIT7 (SCM_IM_CASE
):
2693 SCM key
= EVALCAR (x
, env
);
2695 while (!SCM_NULLP (x
))
2697 SCM clause
= SCM_CAR (x
);
2698 SCM labels
= SCM_CAR (clause
);
2699 if (SCM_EQ_P (labels
, SCM_IM_ELSE
))
2701 x
= SCM_CDR (clause
);
2702 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
2705 while (!SCM_NULLP (labels
))
2707 SCM label
= SCM_CAR (labels
);
2708 if (SCM_EQ_P (label
, key
) || !SCM_FALSEP (scm_eqv_p (label
, key
)))
2710 x
= SCM_CDR (clause
);
2711 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
2714 labels
= SCM_CDR (labels
);
2719 RETURN (SCM_UNSPECIFIED
);
2722 case SCM_BIT7 (SCM_IM_COND
):
2724 while (!SCM_NULLP (x
))
2726 SCM clause
= SCM_CAR (x
);
2727 if (SCM_EQ_P (SCM_CAR (clause
), SCM_IM_ELSE
))
2729 x
= SCM_CDR (clause
);
2730 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
2735 arg1
= EVALCAR (clause
, env
);
2736 if (!SCM_FALSEP (arg1
) && !SCM_NILP (arg1
))
2738 x
= SCM_CDR (clause
);
2741 else if (!SCM_EQ_P (SCM_CAR (x
), SCM_IM_ARROW
))
2743 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
2749 proc
= EVALCAR (proc
, env
);
2750 PREP_APPLY (proc
, scm_list_1 (arg1
));
2758 RETURN (SCM_UNSPECIFIED
);
2761 case SCM_BIT7 (SCM_IM_DO
):
2764 /* Compute the initialization values and the initial environment. */
2765 SCM init_forms
= SCM_CAR (x
);
2766 SCM init_values
= SCM_EOL
;
2767 while (!SCM_NULLP (init_forms
))
2769 init_values
= scm_cons (EVALCAR (init_forms
, env
), init_values
);
2770 init_forms
= SCM_CDR (init_forms
);
2773 env
= SCM_EXTEND_ENV (SCM_CAR (x
), init_values
, env
);
2777 SCM test_form
= SCM_CAR (x
);
2778 SCM body_forms
= SCM_CADR (x
);
2779 SCM step_forms
= SCM_CDDR (x
);
2781 SCM test_result
= EVALCAR (test_form
, env
);
2783 while (SCM_FALSEP (test_result
) || SCM_NILP (test_result
))
2786 /* Evaluate body forms. */
2788 for (temp_forms
= body_forms
;
2789 !SCM_NULLP (temp_forms
);
2790 temp_forms
= SCM_CDR (temp_forms
))
2792 SCM form
= SCM_CAR (temp_forms
);
2793 /* Dirk:FIXME: We only need to eval forms, that may have a
2794 * side effect here. This is only true for forms that start
2795 * with a pair. All others are just constants. However,
2796 * since in the common case there is no constant expression
2797 * in a body of a do form, we just check for immediates here
2798 * and have SCM_CEVAL take care of other cases. In the long
2799 * run it would make sense to get rid of this test and have
2800 * the macro transformer of 'do' eliminate all forms that
2801 * have no sideeffect. */
2802 if (!SCM_IMP (form
))
2803 SCM_CEVAL (form
, env
);
2808 /* Evaluate the step expressions. */
2810 SCM step_values
= SCM_EOL
;
2811 for (temp_forms
= step_forms
;
2812 !SCM_NULLP (temp_forms
);
2813 temp_forms
= SCM_CDR (temp_forms
))
2815 SCM value
= EVALCAR (temp_forms
, env
);
2816 step_values
= scm_cons (value
, step_values
);
2818 env
= SCM_EXTEND_ENV (SCM_CAAR (env
),
2823 test_result
= EVALCAR (test_form
, env
);
2828 RETURN (SCM_UNSPECIFIED
);
2829 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
2830 goto nontoplevel_begin
;
2833 case SCM_BIT7 (SCM_IM_IF
):
2836 SCM test_result
= EVALCAR (x
, env
);
2837 x
= SCM_CDR (x
); /* then expression */
2838 if (SCM_FALSEP (test_result
) || SCM_NILP (test_result
))
2840 x
= SCM_CDR (x
); /* else expression */
2842 RETURN (SCM_UNSPECIFIED
);
2845 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
2849 case SCM_BIT7 (SCM_IM_LET
):
2852 SCM init_forms
= SCM_CADR (x
);
2853 SCM init_values
= SCM_EOL
;
2856 init_values
= scm_cons (EVALCAR (init_forms
, env
), init_values
);
2857 init_forms
= SCM_CDR (init_forms
);
2859 while (!SCM_NULLP (init_forms
));
2860 env
= SCM_EXTEND_ENV (SCM_CAR (x
), init_values
, env
);
2863 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
2864 goto nontoplevel_begin
;
2867 case SCM_BIT7 (SCM_IM_LETREC
):
2869 env
= SCM_EXTEND_ENV (SCM_CAR (x
), undefineds
, env
);
2872 SCM init_forms
= SCM_CAR (x
);
2873 SCM init_values
= SCM_EOL
;
2876 init_values
= scm_cons (EVALCAR (init_forms
, env
), init_values
);
2877 init_forms
= SCM_CDR (init_forms
);
2879 while (!SCM_NULLP (init_forms
));
2880 SCM_SETCDR (SCM_CAR (env
), init_values
);
2883 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
2884 goto nontoplevel_begin
;
2887 case SCM_BIT7 (SCM_IM_LETSTAR
):
2890 SCM bindings
= SCM_CAR (x
);
2891 if (SCM_NULLP (bindings
))
2892 env
= SCM_EXTEND_ENV (SCM_EOL
, SCM_EOL
, env
);
2897 SCM name
= SCM_CAR (bindings
);
2898 SCM init
= SCM_CDR (bindings
);
2899 env
= SCM_EXTEND_ENV (name
, EVALCAR (init
, env
), env
);
2900 bindings
= SCM_CDR (init
);
2902 while (!SCM_NULLP (bindings
));
2906 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
2907 goto nontoplevel_begin
;
2910 case SCM_BIT7 (SCM_IM_OR
):
2912 while (!SCM_NULLP (SCM_CDR (x
)))
2914 SCM val
= EVALCAR (x
, env
);
2915 if (!SCM_FALSEP (val
) && !SCM_NILP (val
))
2920 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
2924 case SCM_BIT7 (SCM_IM_LAMBDA
):
2925 RETURN (scm_closure (SCM_CDR (x
), env
));
2928 case SCM_BIT7 (SCM_IM_QUOTE
):
2929 RETURN (SCM_CADR (x
));
2932 case SCM_BIT7 (SCM_IM_SET_X
):
2936 SCM variable
= SCM_CAR (x
);
2937 if (SCM_ILOCP (variable
))
2938 location
= scm_ilookup (variable
, env
);
2939 else if (SCM_VARIABLEP (variable
))
2940 location
= SCM_VARIABLE_LOC (variable
);
2941 else /* (SCM_SYMBOLP (variable)) is known to be true */
2942 location
= scm_lookupcar (x
, env
, 1);
2944 *location
= EVALCAR (x
, env
);
2946 RETURN (SCM_UNSPECIFIED
);
2949 /* new syntactic forms go here. */
2950 case SCM_BIT7 (SCM_MAKISYM (0)):
2952 switch (SCM_ISYMNUM (proc
))
2956 case (SCM_ISYMNUM (SCM_IM_DEFINE
)):
2957 /* Top level defines are handled directly by the memoizer and thus
2958 * will never generate memoized code with SCM_IM_DEFINE. Internal
2959 * defines which occur at valid positions will be transformed into
2960 * letrec expressions. Thus, whenever the executor detects
2961 * SCM_IM_DEFINE, this must come from an internal definition at an
2962 * illegal position. */
2963 scm_misc_error (NULL
, "Bad define placement", SCM_EOL
);
2966 case (SCM_ISYMNUM (SCM_IM_APPLY
)):
2968 proc
= EVALCAR (x
, env
);
2969 PREP_APPLY (proc
, SCM_EOL
);
2971 arg1
= EVALCAR (x
, env
);
2974 /* Go here to tail-apply a procedure. PROC is the procedure and
2975 * ARG1 is the list of arguments. PREP_APPLY must have been called
2976 * before jumping to apply_proc. */
2977 if (SCM_CLOSUREP (proc
))
2979 SCM formals
= SCM_CLOSURE_FORMALS (proc
);
2981 debug
.info
->a
.args
= arg1
;
2983 if (scm_badargsp (formals
, arg1
))
2984 scm_wrong_num_args (proc
);
2986 /* Copy argument list */
2987 if (SCM_NULL_OR_NIL_P (arg1
))
2988 env
= SCM_EXTEND_ENV (formals
, SCM_EOL
, SCM_ENV (proc
));
2991 SCM args
= scm_list_1 (SCM_CAR (arg1
));
2993 arg1
= SCM_CDR (arg1
);
2994 while (!SCM_NULL_OR_NIL_P (arg1
))
2996 SCM new_tail
= scm_list_1 (SCM_CAR (arg1
));
2997 SCM_SETCDR (tail
, new_tail
);
2999 arg1
= SCM_CDR (arg1
);
3001 env
= SCM_EXTEND_ENV (formals
, args
, SCM_ENV (proc
));
3004 x
= SCM_CLOSURE_BODY (proc
);
3005 goto nontoplevel_begin
;
3010 RETURN (SCM_APPLY (proc
, arg1
, SCM_EOL
));
3014 case (SCM_ISYMNUM (SCM_IM_CONT
)):
3017 SCM val
= scm_make_continuation (&first
);
3025 proc
= scm_eval_car (proc
, env
);
3026 PREP_APPLY (proc
, scm_list_1 (arg1
));
3033 case (SCM_ISYMNUM (SCM_IM_DELAY
)):
3034 RETURN (scm_makprom (scm_closure (SCM_CDR (x
), env
)));
3037 case (SCM_ISYMNUM (SCM_IM_FUTURE
)):
3038 RETURN (scm_i_make_future (scm_closure (SCM_CDR (x
), env
)));
3041 /* PLACEHOLDER for case (SCM_ISYMNUM (SCM_IM_DISPATCH)): The
3042 following code (type_dispatch) is intended to be the tail
3043 of the case clause for the internal macro
3044 SCM_IM_DISPATCH. Please don't remove it from this
3045 location without discussing it with Mikael
3046 <djurfeldt@nada.kth.se> */
3048 /* The type dispatch code is duplicated below
3049 * (c.f. objects.c:scm_mcache_compute_cmethod) since that
3050 * cuts down execution time for type dispatch to 50%. */
3051 type_dispatch
: /* inputs: x, arg1 */
3052 /* Type dispatch means to determine from the types of the function
3053 * arguments (i. e. the 'signature' of the call), which method from
3054 * a generic function is to be called. This process of selecting
3055 * the right method takes some time. To speed it up, guile uses
3056 * caching: Together with the macro call to dispatch the signatures
3057 * of some previous calls to that generic function from the same
3058 * place are stored (in the code!) in a cache that we call the
3059 * 'method cache'. This is done since it is likely, that
3060 * consecutive calls to dispatch from that position in the code will
3061 * have the same signature. Thus, the type dispatch works as
3062 * follows: First, determine a hash value from the signature of the
3063 * actual arguments. Second, use this hash value as an index to
3064 * find that same signature in the method cache stored at this
3065 * position in the code. If found, you have also found the
3066 * corresponding method that belongs to that signature. If the
3067 * signature is not found in the method cache, you have to perform a
3068 * full search over all signatures stored with the generic
3071 unsigned long int specializers
;
3072 unsigned long int hash_value
;
3073 unsigned long int cache_end_pos
;
3074 unsigned long int mask
;
3078 SCM z
= SCM_CDDR (x
);
3079 SCM tmp
= SCM_CADR (z
);
3080 specializers
= SCM_INUM (SCM_CAR (z
));
3082 /* Compute a hash value for searching the method cache. There
3083 * are two variants for computing the hash value, a (rather)
3084 * complicated one, and a simple one. For the complicated one
3085 * explained below, tmp holds a number that is used in the
3087 if (SCM_INUMP (tmp
))
3089 /* Use the signature of the actual arguments to determine
3090 * the hash value. This is done as follows: Each class has
3091 * an array of random numbers, that are determined when the
3092 * class is created. The integer 'hashset' is an index into
3093 * that array of random numbers. Now, from all classes that
3094 * are part of the signature of the actual arguments, the
3095 * random numbers at index 'hashset' are taken and summed
3096 * up, giving the hash value. The value of 'hashset' is
3097 * stored at the call to dispatch. This allows to have
3098 * different 'formulas' for calculating the hash value at
3099 * different places where dispatch is called. This allows
3100 * to optimize the hash formula at every individual place
3101 * where dispatch is called, such that hopefully the hash
3102 * value that is computed will directly point to the right
3103 * method in the method cache. */
3104 unsigned long int hashset
= SCM_INUM (tmp
);
3105 unsigned long int counter
= specializers
+ 1;
3108 while (!SCM_NULLP (tmp_arg
) && counter
!= 0)
3110 SCM
class = scm_class_of (SCM_CAR (tmp_arg
));
3111 hash_value
+= SCM_INSTANCE_HASH (class, hashset
);
3112 tmp_arg
= SCM_CDR (tmp_arg
);
3116 method_cache
= SCM_CADR (z
);
3117 mask
= SCM_INUM (SCM_CAR (z
));
3119 cache_end_pos
= hash_value
;
3123 /* This method of determining the hash value is much
3124 * simpler: Set the hash value to zero and just perform a
3125 * linear search through the method cache. */
3127 mask
= (unsigned long int) ((long) -1);
3129 cache_end_pos
= SCM_VECTOR_LENGTH (method_cache
);
3134 /* Search the method cache for a method with a matching
3135 * signature. Start the search at position 'hash_value'. The
3136 * hashing implementation uses linear probing for conflict
3137 * resolution, that is, if the signature in question is not
3138 * found at the starting index in the hash table, the next table
3139 * entry is tried, and so on, until in the worst case the whole
3140 * cache has been searched, but still the signature has not been
3145 SCM args
= arg1
; /* list of arguments */
3146 z
= SCM_VELTS (method_cache
)[hash_value
];
3147 while (!SCM_NULLP (args
))
3149 /* More arguments than specifiers => CLASS != ENV */
3150 SCM class_of_arg
= scm_class_of (SCM_CAR (args
));
3151 if (!SCM_EQ_P (class_of_arg
, SCM_CAR (z
)))
3153 args
= SCM_CDR (args
);
3156 /* Fewer arguments than specifiers => CAR != ENV */
3157 if (SCM_NULLP (SCM_CAR (z
)) || SCM_CONSP (SCM_CAR (z
)))
3160 hash_value
= (hash_value
+ 1) & mask
;
3161 } while (hash_value
!= cache_end_pos
);
3163 /* No appropriate method was found in the cache. */
3164 z
= scm_memoize_method (x
, arg1
);
3166 apply_cmethod
: /* inputs: z, arg1 */
3168 SCM formals
= SCM_CMETHOD_FORMALS (z
);
3169 env
= SCM_EXTEND_ENV (formals
, arg1
, SCM_CMETHOD_ENV (z
));
3170 x
= SCM_CMETHOD_BODY (z
);
3171 goto nontoplevel_begin
;
3177 case (SCM_ISYMNUM (SCM_IM_SLOT_REF
)):
3180 SCM instance
= EVALCAR (x
, env
);
3181 unsigned long int slot
= SCM_INUM (SCM_CADR (x
));
3182 RETURN (SCM_PACK (SCM_STRUCT_DATA (instance
) [slot
]));
3186 case (SCM_ISYMNUM (SCM_IM_SLOT_SET_X
)):
3189 SCM instance
= EVALCAR (x
, env
);
3190 unsigned long int slot
= SCM_INUM (SCM_CADR (x
));
3191 SCM value
= EVALCAR (SCM_CDDR (x
), env
);
3192 SCM_STRUCT_DATA (instance
) [slot
] = SCM_UNPACK (value
);
3193 RETURN (SCM_UNSPECIFIED
);
3197 #if SCM_ENABLE_ELISP
3199 case (SCM_ISYMNUM (SCM_IM_NIL_COND
)):
3201 SCM test_form
= SCM_CDR (x
);
3202 x
= SCM_CDR (test_form
);
3203 while (!SCM_NULL_OR_NIL_P (x
))
3205 SCM test_result
= EVALCAR (test_form
, env
);
3206 if (!(SCM_FALSEP (test_result
)
3207 || SCM_NULL_OR_NIL_P (test_result
)))
3209 if (SCM_EQ_P (SCM_CAR (x
), SCM_UNSPECIFIED
))
3210 RETURN (test_result
);
3211 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
3216 test_form
= SCM_CDR (x
);
3217 x
= SCM_CDR (test_form
);
3221 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
3225 #endif /* SCM_ENABLE_ELISP */
3227 case (SCM_ISYMNUM (SCM_IM_BIND
)):
3229 SCM vars
, exps
, vals
;
3232 vars
= SCM_CAAR (x
);
3233 exps
= SCM_CDAR (x
);
3235 while (!SCM_NULLP (exps
))
3237 vals
= scm_cons (EVALCAR (exps
, env
), vals
);
3238 exps
= SCM_CDR (exps
);
3241 scm_swap_bindings (vars
, vals
);
3242 scm_dynwinds
= scm_acons (vars
, vals
, scm_dynwinds
);
3244 /* Ignore all but the last evaluation result. */
3245 for (x
= SCM_CDR (x
); !SCM_NULLP (SCM_CDR (x
)); x
= SCM_CDR (x
))
3247 if (SCM_CONSP (SCM_CAR (x
)))
3248 SCM_CEVAL (SCM_CAR (x
), env
);
3250 proc
= EVALCAR (x
, env
);
3252 scm_dynwinds
= SCM_CDR (scm_dynwinds
);
3253 scm_swap_bindings (vars
, vals
);
3259 case (SCM_ISYMNUM (SCM_IM_CALL_WITH_VALUES
)):
3264 producer
= EVALCAR (x
, env
);
3266 proc
= EVALCAR (x
, env
); /* proc is the consumer. */
3267 arg1
= SCM_APPLY (producer
, SCM_EOL
, SCM_EOL
);
3268 if (SCM_VALUESP (arg1
))
3270 /* The list of arguments is not copied. Rather, it is assumed
3271 * that this has been done by the 'values' procedure. */
3272 arg1
= scm_struct_ref (arg1
, SCM_INUM0
);
3276 arg1
= scm_list_1 (arg1
);
3278 PREP_APPLY (proc
, arg1
);
3291 case scm_tc7_vector
:
3295 case scm_tc7_byvect
:
3302 #if SCM_SIZEOF_LONG_LONG != 0
3303 case scm_tc7_llvect
:
3306 case scm_tc7_number
:
3307 case scm_tc7_string
:
3309 case scm_tcs_closures
:
3313 case scm_tcs_struct
:
3316 case scm_tc7_variable
:
3317 RETURN (SCM_VARIABLE_REF(x
));
3319 case SCM_BIT7 (SCM_ILOC00
):
3320 proc
= *scm_ilookup (SCM_CAR (x
), env
);
3323 case scm_tcs_cons_nimcar
:
3324 if (SCM_SYMBOLP (SCM_CAR (x
)))
3326 SCM orig_sym
= SCM_CAR (x
);
3328 SCM
*location
= scm_lookupcar1 (x
, env
, 1);
3329 if (location
== NULL
)
3331 /* we have lost the race, start again. */
3337 if (SCM_MACROP (proc
))
3339 SCM_SETCAR (x
, orig_sym
); /* Undo memoizing effect of
3341 handle_a_macro
: /* inputs: x, env, proc */
3343 /* Set a flag during macro expansion so that macro
3344 application frames can be deleted from the backtrace. */
3345 SCM_SET_MACROEXP (debug
);
3347 arg1
= SCM_APPLY (SCM_MACRO_CODE (proc
), x
,
3348 scm_cons (env
, scm_listofnull
));
3351 SCM_CLEAR_MACROEXP (debug
);
3353 switch (SCM_MACRO_TYPE (proc
))
3357 if (scm_ilength (arg1
) <= 0)
3358 arg1
= scm_list_2 (SCM_IM_BEGIN
, arg1
);
3360 if (!SCM_CLOSUREP (SCM_MACRO_CODE (proc
)))
3363 SCM_SETCAR (x
, SCM_CAR (arg1
));
3364 SCM_SETCDR (x
, SCM_CDR (arg1
));
3368 /* Prevent memoizing of debug info expression. */
3369 debug
.info
->e
.exp
= scm_cons_source (debug
.info
->e
.exp
,
3374 SCM_SETCAR (x
, SCM_CAR (arg1
));
3375 SCM_SETCDR (x
, SCM_CDR (arg1
));
3377 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
3379 #if SCM_ENABLE_DEPRECATED == 1
3384 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
3396 proc
= SCM_CEVAL (SCM_CAR (x
), env
);
3399 if (SCM_MACROP (proc
))
3400 goto handle_a_macro
;
3404 evapply
: /* inputs: x, proc */
3405 PREP_APPLY (proc
, SCM_EOL
);
3406 if (SCM_NULLP (SCM_CDR (x
))) {
3409 SCM_ASRTGO (!SCM_IMP (proc
), badfun
);
3410 switch (SCM_TYP7 (proc
))
3411 { /* no arguments given */
3412 case scm_tc7_subr_0
:
3413 RETURN (SCM_SUBRF (proc
) ());
3414 case scm_tc7_subr_1o
:
3415 RETURN (SCM_SUBRF (proc
) (SCM_UNDEFINED
));
3417 RETURN (SCM_SUBRF (proc
) (SCM_EOL
));
3418 case scm_tc7_rpsubr
:
3419 RETURN (SCM_BOOL_T
);
3421 RETURN (SCM_SUBRF (proc
) (SCM_UNDEFINED
, SCM_UNDEFINED
));
3423 if (!SCM_SMOB_APPLICABLE_P (proc
))
3425 RETURN (SCM_SMOB_APPLY_0 (proc
));
3428 proc
= SCM_CCLO_SUBR (proc
);
3430 debug
.info
->a
.proc
= proc
;
3431 debug
.info
->a
.args
= scm_list_1 (arg1
);
3435 proc
= SCM_PROCEDURE (proc
);
3437 debug
.info
->a
.proc
= proc
;
3439 if (!SCM_CLOSUREP (proc
))
3442 case scm_tcs_closures
:
3444 const SCM formals
= SCM_CLOSURE_FORMALS (proc
);
3445 if (SCM_CONSP (formals
))
3446 goto umwrongnumargs
;
3447 x
= SCM_CLOSURE_BODY (proc
);
3448 env
= SCM_EXTEND_ENV (formals
, SCM_EOL
, SCM_ENV (proc
));
3449 goto nontoplevel_begin
;
3451 case scm_tcs_struct
:
3452 if (SCM_OBJ_CLASS_FLAGS (proc
) & SCM_CLASSF_PURE_GENERIC
)
3454 x
= SCM_ENTITY_PROCEDURE (proc
);
3458 else if (SCM_I_OPERATORP (proc
))
3461 proc
= (SCM_I_ENTITYP (proc
)
3462 ? SCM_ENTITY_PROCEDURE (proc
)
3463 : SCM_OPERATOR_PROCEDURE (proc
));
3465 debug
.info
->a
.proc
= proc
;
3466 debug
.info
->a
.args
= scm_list_1 (arg1
);
3472 case scm_tc7_subr_1
:
3473 case scm_tc7_subr_2
:
3474 case scm_tc7_subr_2o
:
3477 case scm_tc7_subr_3
:
3478 case scm_tc7_lsubr_2
:
3481 scm_wrong_num_args (proc
);
3484 scm_misc_error (NULL
, "Wrong type to apply: ~S", scm_list_1 (proc
));
3488 /* must handle macros by here */
3491 arg1
= EVALCAR (x
, env
);
3493 scm_wrong_num_args (proc
);
3495 debug
.info
->a
.args
= scm_list_1 (arg1
);
3503 evap1
: /* inputs: proc, arg1 */
3504 SCM_ASRTGO (!SCM_IMP (proc
), badfun
);
3505 switch (SCM_TYP7 (proc
))
3506 { /* have one argument in arg1 */
3507 case scm_tc7_subr_2o
:
3508 RETURN (SCM_SUBRF (proc
) (arg1
, SCM_UNDEFINED
));
3509 case scm_tc7_subr_1
:
3510 case scm_tc7_subr_1o
:
3511 RETURN (SCM_SUBRF (proc
) (arg1
));
3513 if (SCM_INUMP (arg1
))
3515 RETURN (scm_make_real (SCM_DSUBRF (proc
) ((double) SCM_INUM (arg1
))));
3517 else if (SCM_REALP (arg1
))
3519 RETURN (scm_make_real (SCM_DSUBRF (proc
) (SCM_REAL_VALUE (arg1
))));
3521 else if (SCM_BIGP (arg1
))
3523 RETURN (scm_make_real (SCM_DSUBRF (proc
) (scm_i_big2dbl (arg1
))));
3525 SCM_WTA_DISPATCH_1 (*SCM_SUBR_GENERIC (proc
), arg1
,
3526 SCM_ARG1
, SCM_SYMBOL_CHARS (SCM_SNAME (proc
)));
3529 unsigned char pattern
= (scm_t_bits
) SCM_SUBRF (proc
);
3532 SCM_ASSERT (SCM_CONSP (arg1
), arg1
, SCM_ARG1
,
3533 SCM_SYMBOL_CHARS (SCM_SNAME (proc
)));
3534 arg1
= (pattern
& 1) ? SCM_CAR (arg1
) : SCM_CDR (arg1
);
3539 case scm_tc7_rpsubr
:
3540 RETURN (SCM_BOOL_T
);
3542 RETURN (SCM_SUBRF (proc
) (arg1
, SCM_UNDEFINED
));
3545 RETURN (SCM_SUBRF (proc
) (debug
.info
->a
.args
));
3547 RETURN (SCM_SUBRF (proc
) (scm_list_1 (arg1
)));
3550 if (!SCM_SMOB_APPLICABLE_P (proc
))
3552 RETURN (SCM_SMOB_APPLY_1 (proc
, arg1
));
3556 proc
= SCM_CCLO_SUBR (proc
);
3558 debug
.info
->a
.args
= scm_cons (arg1
, debug
.info
->a
.args
);
3559 debug
.info
->a
.proc
= proc
;
3563 proc
= SCM_PROCEDURE (proc
);
3565 debug
.info
->a
.proc
= proc
;
3567 if (!SCM_CLOSUREP (proc
))
3570 case scm_tcs_closures
:
3573 const SCM formals
= SCM_CLOSURE_FORMALS (proc
);
3574 if (SCM_NULLP (formals
)
3575 || (SCM_CONSP (formals
) && SCM_CONSP (SCM_CDR (formals
))))
3576 goto umwrongnumargs
;
3577 x
= SCM_CLOSURE_BODY (proc
);
3579 env
= SCM_EXTEND_ENV (formals
,
3583 env
= SCM_EXTEND_ENV (formals
,
3587 goto nontoplevel_begin
;
3589 case scm_tcs_struct
:
3590 if (SCM_OBJ_CLASS_FLAGS (proc
) & SCM_CLASSF_PURE_GENERIC
)
3592 x
= SCM_ENTITY_PROCEDURE (proc
);
3594 arg1
= debug
.info
->a
.args
;
3596 arg1
= scm_list_1 (arg1
);
3600 else if (SCM_I_OPERATORP (proc
))
3604 proc
= (SCM_I_ENTITYP (proc
)
3605 ? SCM_ENTITY_PROCEDURE (proc
)
3606 : SCM_OPERATOR_PROCEDURE (proc
));
3608 debug
.info
->a
.args
= scm_cons (arg1
, debug
.info
->a
.args
);
3609 debug
.info
->a
.proc
= proc
;
3615 case scm_tc7_subr_2
:
3616 case scm_tc7_subr_0
:
3617 case scm_tc7_subr_3
:
3618 case scm_tc7_lsubr_2
:
3619 scm_wrong_num_args (proc
);
3625 arg2
= EVALCAR (x
, env
);
3627 scm_wrong_num_args (proc
);
3629 { /* have two or more arguments */
3631 debug
.info
->a
.args
= scm_list_2 (arg1
, arg2
);
3634 if (SCM_NULLP (x
)) {
3637 SCM_ASRTGO (!SCM_IMP (proc
), badfun
);
3638 switch (SCM_TYP7 (proc
))
3639 { /* have two arguments */
3640 case scm_tc7_subr_2
:
3641 case scm_tc7_subr_2o
:
3642 RETURN (SCM_SUBRF (proc
) (arg1
, arg2
));
3645 RETURN (SCM_SUBRF (proc
) (debug
.info
->a
.args
));
3647 RETURN (SCM_SUBRF (proc
) (scm_list_2 (arg1
, arg2
)));
3649 case scm_tc7_lsubr_2
:
3650 RETURN (SCM_SUBRF (proc
) (arg1
, arg2
, SCM_EOL
));
3651 case scm_tc7_rpsubr
:
3653 RETURN (SCM_SUBRF (proc
) (arg1
, arg2
));
3655 if (!SCM_SMOB_APPLICABLE_P (proc
))
3657 RETURN (SCM_SMOB_APPLY_2 (proc
, arg1
, arg2
));
3661 RETURN (SCM_APPLY (SCM_CCLO_SUBR (proc
),
3662 scm_cons (proc
, debug
.info
->a
.args
),
3665 RETURN (SCM_APPLY (SCM_CCLO_SUBR (proc
),
3666 scm_cons2 (proc
, arg1
,
3673 case scm_tcs_struct
:
3674 if (SCM_OBJ_CLASS_FLAGS (proc
) & SCM_CLASSF_PURE_GENERIC
)
3676 x
= SCM_ENTITY_PROCEDURE (proc
);
3678 arg1
= debug
.info
->a
.args
;
3680 arg1
= scm_list_2 (arg1
, arg2
);
3684 else if (SCM_I_OPERATORP (proc
))
3688 RETURN (SCM_APPLY (SCM_I_ENTITYP (proc
)
3689 ? SCM_ENTITY_PROCEDURE (proc
)
3690 : SCM_OPERATOR_PROCEDURE (proc
),
3691 scm_cons (proc
, debug
.info
->a
.args
),
3694 RETURN (SCM_APPLY (SCM_I_ENTITYP (proc
)
3695 ? SCM_ENTITY_PROCEDURE (proc
)
3696 : SCM_OPERATOR_PROCEDURE (proc
),
3697 scm_cons2 (proc
, arg1
,
3707 case scm_tc7_subr_0
:
3710 case scm_tc7_subr_1o
:
3711 case scm_tc7_subr_1
:
3712 case scm_tc7_subr_3
:
3713 scm_wrong_num_args (proc
);
3717 proc
= SCM_PROCEDURE (proc
);
3719 debug
.info
->a
.proc
= proc
;
3721 if (!SCM_CLOSUREP (proc
))
3724 case scm_tcs_closures
:
3727 const SCM formals
= SCM_CLOSURE_FORMALS (proc
);
3728 if (SCM_NULLP (formals
)
3729 || (SCM_CONSP (formals
)
3730 && (SCM_NULLP (SCM_CDR (formals
))
3731 || (SCM_CONSP (SCM_CDR (formals
))
3732 && SCM_CONSP (SCM_CDDR (formals
))))))
3733 goto umwrongnumargs
;
3735 env
= SCM_EXTEND_ENV (formals
,
3739 env
= SCM_EXTEND_ENV (formals
,
3740 scm_list_2 (arg1
, arg2
),
3743 x
= SCM_CLOSURE_BODY (proc
);
3744 goto nontoplevel_begin
;
3749 scm_wrong_num_args (proc
);
3751 debug
.info
->a
.args
= scm_cons2 (arg1
, arg2
,
3752 deval_args (x
, env
, proc
,
3753 SCM_CDRLOC (SCM_CDR (debug
.info
->a
.args
))));
3757 SCM_ASRTGO (!SCM_IMP (proc
), badfun
);
3758 switch (SCM_TYP7 (proc
))
3759 { /* have 3 or more arguments */
3761 case scm_tc7_subr_3
:
3762 if (!SCM_NULLP (SCM_CDR (x
)))
3763 scm_wrong_num_args (proc
);
3765 RETURN (SCM_SUBRF (proc
) (arg1
, arg2
,
3766 SCM_CADDR (debug
.info
->a
.args
)));
3768 arg1
= SCM_SUBRF(proc
)(arg1
, arg2
);
3769 arg2
= SCM_CDDR (debug
.info
->a
.args
);
3772 arg1
= SCM_SUBRF(proc
)(arg1
, SCM_CAR (arg2
));
3773 arg2
= SCM_CDR (arg2
);
3775 while (SCM_NIMP (arg2
));
3777 case scm_tc7_rpsubr
:
3778 if (SCM_FALSEP (SCM_SUBRF (proc
) (arg1
, arg2
)))
3779 RETURN (SCM_BOOL_F
);
3780 arg1
= SCM_CDDR (debug
.info
->a
.args
);
3783 if (SCM_FALSEP (SCM_SUBRF (proc
) (arg2
, SCM_CAR (arg1
))))
3784 RETURN (SCM_BOOL_F
);
3785 arg2
= SCM_CAR (arg1
);
3786 arg1
= SCM_CDR (arg1
);
3788 while (SCM_NIMP (arg1
));
3789 RETURN (SCM_BOOL_T
);
3790 case scm_tc7_lsubr_2
:
3791 RETURN (SCM_SUBRF (proc
) (arg1
, arg2
,
3792 SCM_CDDR (debug
.info
->a
.args
)));
3794 RETURN (SCM_SUBRF (proc
) (debug
.info
->a
.args
));
3796 if (!SCM_SMOB_APPLICABLE_P (proc
))
3798 RETURN (SCM_SMOB_APPLY_3 (proc
, arg1
, arg2
,
3799 SCM_CDDR (debug
.info
->a
.args
)));
3803 proc
= SCM_PROCEDURE (proc
);
3804 debug
.info
->a
.proc
= proc
;
3805 if (!SCM_CLOSUREP (proc
))
3808 case scm_tcs_closures
:
3810 const SCM formals
= SCM_CLOSURE_FORMALS (proc
);
3811 if (SCM_NULLP (formals
)
3812 || (SCM_CONSP (formals
)
3813 && (SCM_NULLP (SCM_CDR (formals
))
3814 || (SCM_CONSP (SCM_CDR (formals
))
3815 && scm_badargsp (SCM_CDDR (formals
), x
)))))
3816 goto umwrongnumargs
;
3817 SCM_SET_ARGSREADY (debug
);
3818 env
= SCM_EXTEND_ENV (formals
,
3821 x
= SCM_CLOSURE_BODY (proc
);
3822 goto nontoplevel_begin
;
3825 case scm_tc7_subr_3
:
3826 if (!SCM_NULLP (SCM_CDR (x
)))
3827 scm_wrong_num_args (proc
);
3829 RETURN (SCM_SUBRF (proc
) (arg1
, arg2
, EVALCAR (x
, env
)));
3831 arg1
= SCM_SUBRF (proc
) (arg1
, arg2
);
3834 arg1
= SCM_SUBRF(proc
)(arg1
, EVALCAR(x
, env
));
3837 while (SCM_NIMP (x
));
3839 case scm_tc7_rpsubr
:
3840 if (SCM_FALSEP (SCM_SUBRF (proc
) (arg1
, arg2
)))
3841 RETURN (SCM_BOOL_F
);
3844 arg1
= EVALCAR (x
, env
);
3845 if (SCM_FALSEP (SCM_SUBRF (proc
) (arg2
, arg1
)))
3846 RETURN (SCM_BOOL_F
);
3850 while (SCM_NIMP (x
));
3851 RETURN (SCM_BOOL_T
);
3852 case scm_tc7_lsubr_2
:
3853 RETURN (SCM_SUBRF (proc
) (arg1
, arg2
, scm_eval_args (x
, env
, proc
)));
3855 RETURN (SCM_SUBRF (proc
) (scm_cons2 (arg1
,
3857 scm_eval_args (x
, env
, proc
))));
3859 if (!SCM_SMOB_APPLICABLE_P (proc
))
3861 RETURN (SCM_SMOB_APPLY_3 (proc
, arg1
, arg2
,
3862 scm_eval_args (x
, env
, proc
)));
3866 proc
= SCM_PROCEDURE (proc
);
3867 if (!SCM_CLOSUREP (proc
))
3870 case scm_tcs_closures
:
3872 const SCM formals
= SCM_CLOSURE_FORMALS (proc
);
3873 if (SCM_NULLP (formals
)
3874 || (SCM_CONSP (formals
)
3875 && (SCM_NULLP (SCM_CDR (formals
))
3876 || (SCM_CONSP (SCM_CDR (formals
))
3877 && scm_badargsp (SCM_CDDR (formals
), x
)))))
3878 goto umwrongnumargs
;
3879 env
= SCM_EXTEND_ENV (formals
,
3882 scm_eval_args (x
, env
, proc
)),
3884 x
= SCM_CLOSURE_BODY (proc
);
3885 goto nontoplevel_begin
;
3888 case scm_tcs_struct
:
3889 if (SCM_OBJ_CLASS_FLAGS (proc
) & SCM_CLASSF_PURE_GENERIC
)
3892 arg1
= debug
.info
->a
.args
;
3894 arg1
= scm_cons2 (arg1
, arg2
, scm_eval_args (x
, env
, proc
));
3896 x
= SCM_ENTITY_PROCEDURE (proc
);
3899 else if (SCM_I_OPERATORP (proc
))
3903 case scm_tc7_subr_2
:
3904 case scm_tc7_subr_1o
:
3905 case scm_tc7_subr_2o
:
3906 case scm_tc7_subr_0
:
3909 case scm_tc7_subr_1
:
3910 scm_wrong_num_args (proc
);
3918 if (scm_check_exit_p
&& SCM_TRAPS_P
)
3919 if (SCM_EXIT_FRAME_P
|| (SCM_TRACE_P
&& SCM_TRACED_FRAME_P (debug
)))
3921 SCM_CLEAR_TRACED_FRAME (debug
);
3922 if (SCM_CHEAPTRAPS_P
)
3923 arg1
= scm_make_debugobj (&debug
);
3927 SCM val
= scm_make_continuation (&first
);
3938 scm_call_3 (SCM_EXIT_FRAME_HDLR
, scm_sym_exit_frame
, arg1
, proc
);
3942 scm_last_debug_frame
= debug
.prev
;
3948 /* SECTION: This code is compiled once.
3955 /* Simple procedure calls
3959 scm_call_0 (SCM proc
)
3961 return scm_apply (proc
, SCM_EOL
, SCM_EOL
);
3965 scm_call_1 (SCM proc
, SCM arg1
)
3967 return scm_apply (proc
, arg1
, scm_listofnull
);
3971 scm_call_2 (SCM proc
, SCM arg1
, SCM arg2
)
3973 return scm_apply (proc
, arg1
, scm_cons (arg2
, scm_listofnull
));
3977 scm_call_3 (SCM proc
, SCM arg1
, SCM arg2
, SCM arg3
)
3979 return scm_apply (proc
, arg1
, scm_cons2 (arg2
, arg3
, scm_listofnull
));
3983 scm_call_4 (SCM proc
, SCM arg1
, SCM arg2
, SCM arg3
, SCM arg4
)
3985 return scm_apply (proc
, arg1
, scm_cons2 (arg2
, arg3
,
3986 scm_cons (arg4
, scm_listofnull
)));
3989 /* Simple procedure applies
3993 scm_apply_0 (SCM proc
, SCM args
)
3995 return scm_apply (proc
, args
, SCM_EOL
);
3999 scm_apply_1 (SCM proc
, SCM arg1
, SCM args
)
4001 return scm_apply (proc
, scm_cons (arg1
, args
), SCM_EOL
);
4005 scm_apply_2 (SCM proc
, SCM arg1
, SCM arg2
, SCM args
)
4007 return scm_apply (proc
, scm_cons2 (arg1
, arg2
, args
), SCM_EOL
);
4011 scm_apply_3 (SCM proc
, SCM arg1
, SCM arg2
, SCM arg3
, SCM args
)
4013 return scm_apply (proc
, scm_cons (arg1
, scm_cons2 (arg2
, arg3
, args
)),
4017 /* This code processes the arguments to apply:
4019 (apply PROC ARG1 ... ARGS)
4021 Given a list (ARG1 ... ARGS), this function conses the ARG1
4022 ... arguments onto the front of ARGS, and returns the resulting
4023 list. Note that ARGS is a list; thus, the argument to this
4024 function is a list whose last element is a list.
4026 Apply calls this function, and applies PROC to the elements of the
4027 result. apply:nconc2last takes care of building the list of
4028 arguments, given (ARG1 ... ARGS).
4030 Rather than do new consing, apply:nconc2last destroys its argument.
4031 On that topic, this code came into my care with the following
4032 beautifully cryptic comment on that topic: "This will only screw
4033 you if you do (scm_apply scm_apply '( ... ))" If you know what
4034 they're referring to, send me a patch to this comment. */
4036 SCM_DEFINE (scm_nconc2last
, "apply:nconc2last", 1, 0, 0,
4038 "Given a list (@var{arg1} @dots{} @var{args}), this function\n"
4039 "conses the @var{arg1} @dots{} arguments onto the front of\n"
4040 "@var{args}, and returns the resulting list. Note that\n"
4041 "@var{args} is a list; thus, the argument to this function is\n"
4042 "a list whose last element is a list.\n"
4043 "Note: Rather than do new consing, @code{apply:nconc2last}\n"
4044 "destroys its argument, so use with care.")
4045 #define FUNC_NAME s_scm_nconc2last
4048 SCM_VALIDATE_NONEMPTYLIST (1, lst
);
4050 while (!SCM_NULLP (SCM_CDR (*lloc
))) /* Perhaps should be
4051 SCM_NULL_OR_NIL_P, but not
4052 needed in 99.99% of cases,
4053 and it could seriously hurt
4054 performance. - Neil */
4055 lloc
= SCM_CDRLOC (*lloc
);
4056 SCM_ASSERT (scm_ilength (SCM_CAR (*lloc
)) >= 0, lst
, SCM_ARG1
, FUNC_NAME
);
4057 *lloc
= SCM_CAR (*lloc
);
4065 /* SECTION: When DEVAL is defined this code yields scm_dapply.
4066 * It is compiled twice.
4071 scm_apply (SCM proc
, SCM arg1
, SCM args
)
4077 scm_dapply (SCM proc
, SCM arg1
, SCM args
)
4082 /* Apply a function to a list of arguments.
4084 This function is exported to the Scheme level as taking two
4085 required arguments and a tail argument, as if it were:
4086 (lambda (proc arg1 . args) ...)
4087 Thus, if you just have a list of arguments to pass to a procedure,
4088 pass the list as ARG1, and '() for ARGS. If you have some fixed
4089 args, pass the first as ARG1, then cons any remaining fixed args
4090 onto the front of your argument list, and pass that as ARGS. */
4093 SCM_APPLY (SCM proc
, SCM arg1
, SCM args
)
4096 scm_t_debug_frame debug
;
4097 scm_t_debug_info debug_vect_body
;
4098 debug
.prev
= scm_last_debug_frame
;
4099 debug
.status
= SCM_APPLYFRAME
;
4100 debug
.vect
= &debug_vect_body
;
4101 debug
.vect
[0].a
.proc
= proc
;
4102 debug
.vect
[0].a
.args
= SCM_EOL
;
4103 scm_last_debug_frame
= &debug
;
4106 return scm_dapply (proc
, arg1
, args
);
4109 SCM_ASRTGO (SCM_NIMP (proc
), badproc
);
4111 /* If ARGS is the empty list, then we're calling apply with only two
4112 arguments --- ARG1 is the list of arguments for PROC. Whatever
4113 the case, futz with things so that ARG1 is the first argument to
4114 give to PROC (or SCM_UNDEFINED if no args), and ARGS contains the
4117 Setting the debug apply frame args this way is pretty messy.
4118 Perhaps we should store arg1 and args directly in the frame as
4119 received, and let scm_frame_arguments unpack them, because that's
4120 a relatively rare operation. This works for now; if the Guile
4121 developer archives are still around, see Mikael's post of
4123 if (SCM_NULLP (args
))
4125 if (SCM_NULLP (arg1
))
4127 arg1
= SCM_UNDEFINED
;
4129 debug
.vect
[0].a
.args
= SCM_EOL
;
4135 debug
.vect
[0].a
.args
= arg1
;
4137 args
= SCM_CDR (arg1
);
4138 arg1
= SCM_CAR (arg1
);
4143 args
= scm_nconc2last (args
);
4145 debug
.vect
[0].a
.args
= scm_cons (arg1
, args
);
4149 if (SCM_ENTER_FRAME_P
&& SCM_TRAPS_P
)
4152 if (SCM_CHEAPTRAPS_P
)
4153 tmp
= scm_make_debugobj (&debug
);
4158 tmp
= scm_make_continuation (&first
);
4163 scm_call_2 (SCM_ENTER_FRAME_HDLR
, scm_sym_enter_frame
, tmp
);
4170 switch (SCM_TYP7 (proc
))
4172 case scm_tc7_subr_2o
:
4173 args
= SCM_NULLP (args
) ? SCM_UNDEFINED
: SCM_CAR (args
);
4174 RETURN (SCM_SUBRF (proc
) (arg1
, args
));
4175 case scm_tc7_subr_2
:
4176 if (SCM_NULLP (args
) || !SCM_NULLP (SCM_CDR (args
)))
4177 scm_wrong_num_args (proc
);
4178 args
= SCM_CAR (args
);
4179 RETURN (SCM_SUBRF (proc
) (arg1
, args
));
4180 case scm_tc7_subr_0
:
4181 if (!SCM_UNBNDP (arg1
))
4182 scm_wrong_num_args (proc
);
4184 RETURN (SCM_SUBRF (proc
) ());
4185 case scm_tc7_subr_1
:
4186 if (SCM_UNBNDP (arg1
))
4187 scm_wrong_num_args (proc
);
4188 case scm_tc7_subr_1o
:
4189 if (!SCM_NULLP (args
))
4190 scm_wrong_num_args (proc
);
4192 RETURN (SCM_SUBRF (proc
) (arg1
));
4194 if (SCM_UNBNDP (arg1
) || !SCM_NULLP (args
))
4195 scm_wrong_num_args (proc
);
4196 if (SCM_INUMP (arg1
))
4198 RETURN (scm_make_real (SCM_DSUBRF (proc
) ((double) SCM_INUM (arg1
))));
4200 else if (SCM_REALP (arg1
))
4202 RETURN (scm_make_real (SCM_DSUBRF (proc
) (SCM_REAL_VALUE (arg1
))));
4204 else if (SCM_BIGP (arg1
))
4205 RETURN (scm_make_real (SCM_DSUBRF (proc
) (scm_i_big2dbl (arg1
))));
4206 SCM_WTA_DISPATCH_1 (*SCM_SUBR_GENERIC (proc
), arg1
,
4207 SCM_ARG1
, SCM_SYMBOL_CHARS (SCM_SNAME (proc
)));
4209 if (SCM_UNBNDP (arg1
) || !SCM_NULLP (args
))
4210 scm_wrong_num_args (proc
);
4212 unsigned char pattern
= (scm_t_bits
) SCM_SUBRF (proc
);
4215 SCM_ASSERT (SCM_CONSP (arg1
), arg1
, SCM_ARG1
,
4216 SCM_SYMBOL_CHARS (SCM_SNAME (proc
)));
4217 arg1
= (pattern
& 1) ? SCM_CAR (arg1
) : SCM_CDR (arg1
);
4222 case scm_tc7_subr_3
:
4223 if (SCM_NULLP (args
)
4224 || SCM_NULLP (SCM_CDR (args
))
4225 || !SCM_NULLP (SCM_CDDR (args
)))
4226 scm_wrong_num_args (proc
);
4228 RETURN (SCM_SUBRF (proc
) (arg1
, SCM_CAR (args
), SCM_CADR (args
)));
4231 RETURN (SCM_SUBRF (proc
) (SCM_UNBNDP (arg1
) ? SCM_EOL
: debug
.vect
[0].a
.args
));
4233 RETURN (SCM_SUBRF (proc
) (SCM_UNBNDP (arg1
) ? SCM_EOL
: scm_cons (arg1
, args
)));
4235 case scm_tc7_lsubr_2
:
4236 if (!SCM_CONSP (args
))
4237 scm_wrong_num_args (proc
);
4239 RETURN (SCM_SUBRF (proc
) (arg1
, SCM_CAR (args
), SCM_CDR (args
)));
4241 if (SCM_NULLP (args
))
4242 RETURN (SCM_SUBRF (proc
) (arg1
, SCM_UNDEFINED
));
4243 while (SCM_NIMP (args
))
4245 SCM_ASSERT (SCM_CONSP (args
), args
, SCM_ARG2
, "apply");
4246 arg1
= SCM_SUBRF (proc
) (arg1
, SCM_CAR (args
));
4247 args
= SCM_CDR (args
);
4250 case scm_tc7_rpsubr
:
4251 if (SCM_NULLP (args
))
4252 RETURN (SCM_BOOL_T
);
4253 while (SCM_NIMP (args
))
4255 SCM_ASSERT (SCM_CONSP (args
), args
, SCM_ARG2
, "apply");
4256 if (SCM_FALSEP (SCM_SUBRF (proc
) (arg1
, SCM_CAR (args
))))
4257 RETURN (SCM_BOOL_F
);
4258 arg1
= SCM_CAR (args
);
4259 args
= SCM_CDR (args
);
4261 RETURN (SCM_BOOL_T
);
4262 case scm_tcs_closures
:
4264 arg1
= (SCM_UNBNDP (arg1
) ? SCM_EOL
: debug
.vect
[0].a
.args
);
4266 arg1
= (SCM_UNBNDP (arg1
) ? SCM_EOL
: scm_cons (arg1
, args
));
4268 if (scm_badargsp (SCM_CLOSURE_FORMALS (proc
), arg1
))
4269 scm_wrong_num_args (proc
);
4271 /* Copy argument list */
4276 SCM tl
= args
= scm_cons (SCM_CAR (arg1
), SCM_UNSPECIFIED
);
4277 for (arg1
= SCM_CDR (arg1
); SCM_CONSP (arg1
); arg1
= SCM_CDR (arg1
))
4279 SCM_SETCDR (tl
, scm_cons (SCM_CAR (arg1
), SCM_UNSPECIFIED
));
4282 SCM_SETCDR (tl
, arg1
);
4285 args
= SCM_EXTEND_ENV (SCM_CLOSURE_FORMALS (proc
),
4288 proc
= SCM_CLOSURE_BODY (proc
);
4290 arg1
= SCM_CDR (proc
);
4291 while (!SCM_NULLP (arg1
))
4293 if (SCM_IMP (SCM_CAR (proc
)))
4295 if (SCM_ISYMP (SCM_CAR (proc
)))
4297 scm_rec_mutex_lock (&source_mutex
);
4298 /* check for race condition */
4299 if (SCM_ISYMP (SCM_CAR (proc
)))
4300 proc
= scm_m_expand_body (proc
, args
);
4301 scm_rec_mutex_unlock (&source_mutex
);
4305 SCM_VALIDATE_NON_EMPTY_COMBINATION (SCM_CAR (proc
));
4308 SCM_CEVAL (SCM_CAR (proc
), args
);
4310 arg1
= SCM_CDR (proc
);
4312 RETURN (EVALCAR (proc
, args
));
4314 if (!SCM_SMOB_APPLICABLE_P (proc
))
4316 if (SCM_UNBNDP (arg1
))
4317 RETURN (SCM_SMOB_APPLY_0 (proc
));
4318 else if (SCM_NULLP (args
))
4319 RETURN (SCM_SMOB_APPLY_1 (proc
, arg1
));
4320 else if (SCM_NULLP (SCM_CDR (args
)))
4321 RETURN (SCM_SMOB_APPLY_2 (proc
, arg1
, SCM_CAR (args
)));
4323 RETURN (SCM_SMOB_APPLY_3 (proc
, arg1
, SCM_CAR (args
), SCM_CDR (args
)));
4326 args
= (SCM_UNBNDP(arg1
) ? SCM_EOL
: debug
.vect
[0].a
.args
);
4328 proc
= SCM_CCLO_SUBR (proc
);
4329 debug
.vect
[0].a
.proc
= proc
;
4330 debug
.vect
[0].a
.args
= scm_cons (arg1
, args
);
4332 args
= (SCM_UNBNDP(arg1
) ? SCM_EOL
: scm_cons (arg1
, args
));
4334 proc
= SCM_CCLO_SUBR (proc
);
4338 proc
= SCM_PROCEDURE (proc
);
4340 debug
.vect
[0].a
.proc
= proc
;
4343 case scm_tcs_struct
:
4344 if (SCM_OBJ_CLASS_FLAGS (proc
) & SCM_CLASSF_PURE_GENERIC
)
4347 args
= (SCM_UNBNDP(arg1
) ? SCM_EOL
: debug
.vect
[0].a
.args
);
4349 args
= (SCM_UNBNDP(arg1
) ? SCM_EOL
: scm_cons (arg1
, args
));
4351 RETURN (scm_apply_generic (proc
, args
));
4353 else if (SCM_I_OPERATORP (proc
))
4357 args
= (SCM_UNBNDP(arg1
) ? SCM_EOL
: debug
.vect
[0].a
.args
);
4359 args
= (SCM_UNBNDP(arg1
) ? SCM_EOL
: scm_cons (arg1
, args
));
4362 proc
= (SCM_I_ENTITYP (proc
)
4363 ? SCM_ENTITY_PROCEDURE (proc
)
4364 : SCM_OPERATOR_PROCEDURE (proc
));
4366 debug
.vect
[0].a
.proc
= proc
;
4367 debug
.vect
[0].a
.args
= scm_cons (arg1
, args
);
4369 if (SCM_NIMP (proc
))
4378 scm_wrong_type_arg ("apply", SCM_ARG1
, proc
);
4382 if (scm_check_exit_p
&& SCM_TRAPS_P
)
4383 if (SCM_EXIT_FRAME_P
|| (SCM_TRACE_P
&& SCM_TRACED_FRAME_P (debug
)))
4385 SCM_CLEAR_TRACED_FRAME (debug
);
4386 if (SCM_CHEAPTRAPS_P
)
4387 arg1
= scm_make_debugobj (&debug
);
4391 SCM val
= scm_make_continuation (&first
);
4402 scm_call_3 (SCM_EXIT_FRAME_HDLR
, scm_sym_exit_frame
, arg1
, proc
);
4406 scm_last_debug_frame
= debug
.prev
;
4412 /* SECTION: The rest of this file is only read once.
4419 * Trampolines make it possible to move procedure application dispatch
4420 * outside inner loops. The motivation was clean implementation of
4421 * efficient replacements of R5RS primitives in SRFI-1.
4423 * The semantics is clear: scm_trampoline_N returns an optimized
4424 * version of scm_call_N (or NULL if the procedure isn't applicable
4427 * Applying the optimization to map and for-each increased efficiency
4428 * noticeably. For example, (map abs ls) is now 8 times faster than
4433 call_subr0_0 (SCM proc
)
4435 return SCM_SUBRF (proc
) ();
4439 call_subr1o_0 (SCM proc
)
4441 return SCM_SUBRF (proc
) (SCM_UNDEFINED
);
4445 call_lsubr_0 (SCM proc
)
4447 return SCM_SUBRF (proc
) (SCM_EOL
);
4451 scm_i_call_closure_0 (SCM proc
)
4453 const SCM env
= SCM_EXTEND_ENV (SCM_CLOSURE_FORMALS (proc
),
4456 const SCM result
= scm_eval_body (SCM_CLOSURE_BODY (proc
), env
);
4461 scm_trampoline_0 (SCM proc
)
4467 switch (SCM_TYP7 (proc
))
4469 case scm_tc7_subr_0
:
4470 return call_subr0_0
;
4471 case scm_tc7_subr_1o
:
4472 return call_subr1o_0
;
4474 return call_lsubr_0
;
4475 case scm_tcs_closures
:
4477 SCM formals
= SCM_CLOSURE_FORMALS (proc
);
4478 if (SCM_NULLP (formals
) || !SCM_CONSP (formals
))
4479 return scm_i_call_closure_0
;
4483 case scm_tcs_struct
:
4484 if (SCM_OBJ_CLASS_FLAGS (proc
) & SCM_CLASSF_PURE_GENERIC
)
4485 return scm_call_generic_0
;
4486 else if (SCM_I_OPERATORP (proc
))
4490 if (SCM_SMOB_APPLICABLE_P (proc
))
4491 return SCM_SMOB_DESCRIPTOR (proc
).apply_0
;
4495 case scm_tc7_rpsubr
:
4500 return NULL
; /* not applicable on one arg */
4505 call_subr1_1 (SCM proc
, SCM arg1
)
4507 return SCM_SUBRF (proc
) (arg1
);
4511 call_subr2o_1 (SCM proc
, SCM arg1
)
4513 return SCM_SUBRF (proc
) (arg1
, SCM_UNDEFINED
);
4517 call_lsubr_1 (SCM proc
, SCM arg1
)
4519 return SCM_SUBRF (proc
) (scm_list_1 (arg1
));
4523 call_dsubr_1 (SCM proc
, SCM arg1
)
4525 if (SCM_INUMP (arg1
))
4527 RETURN (scm_make_real (SCM_DSUBRF (proc
) ((double) SCM_INUM (arg1
))));
4529 else if (SCM_REALP (arg1
))
4531 RETURN (scm_make_real (SCM_DSUBRF (proc
) (SCM_REAL_VALUE (arg1
))));
4533 else if (SCM_BIGP (arg1
))
4534 RETURN (scm_make_real (SCM_DSUBRF (proc
) (scm_i_big2dbl (arg1
))));
4535 SCM_WTA_DISPATCH_1 (*SCM_SUBR_GENERIC (proc
), arg1
,
4536 SCM_ARG1
, SCM_SYMBOL_CHARS (SCM_SNAME (proc
)));
4540 call_cxr_1 (SCM proc
, SCM arg1
)
4542 unsigned char pattern
= (scm_t_bits
) SCM_SUBRF (proc
);
4545 SCM_ASSERT (SCM_CONSP (arg1
), arg1
, SCM_ARG1
,
4546 SCM_SYMBOL_CHARS (SCM_SNAME (proc
)));
4547 arg1
= (pattern
& 1) ? SCM_CAR (arg1
) : SCM_CDR (arg1
);
4554 call_closure_1 (SCM proc
, SCM arg1
)
4556 const SCM env
= SCM_EXTEND_ENV (SCM_CLOSURE_FORMALS (proc
),
4559 const SCM result
= scm_eval_body (SCM_CLOSURE_BODY (proc
), env
);
4564 scm_trampoline_1 (SCM proc
)
4570 switch (SCM_TYP7 (proc
))
4572 case scm_tc7_subr_1
:
4573 case scm_tc7_subr_1o
:
4574 return call_subr1_1
;
4575 case scm_tc7_subr_2o
:
4576 return call_subr2o_1
;
4578 return call_lsubr_1
;
4580 return call_dsubr_1
;
4583 case scm_tcs_closures
:
4585 SCM formals
= SCM_CLOSURE_FORMALS (proc
);
4586 if (!SCM_NULLP (formals
)
4587 && (!SCM_CONSP (formals
) || !SCM_CONSP (SCM_CDR (formals
))))
4588 return call_closure_1
;
4592 case scm_tcs_struct
:
4593 if (SCM_OBJ_CLASS_FLAGS (proc
) & SCM_CLASSF_PURE_GENERIC
)
4594 return scm_call_generic_1
;
4595 else if (SCM_I_OPERATORP (proc
))
4599 if (SCM_SMOB_APPLICABLE_P (proc
))
4600 return SCM_SMOB_DESCRIPTOR (proc
).apply_1
;
4604 case scm_tc7_rpsubr
:
4609 return NULL
; /* not applicable on one arg */
4614 call_subr2_2 (SCM proc
, SCM arg1
, SCM arg2
)
4616 return SCM_SUBRF (proc
) (arg1
, arg2
);
4620 call_lsubr2_2 (SCM proc
, SCM arg1
, SCM arg2
)
4622 return SCM_SUBRF (proc
) (arg1
, arg2
, SCM_EOL
);
4626 call_lsubr_2 (SCM proc
, SCM arg1
, SCM arg2
)
4628 return SCM_SUBRF (proc
) (scm_list_2 (arg1
, arg2
));
4632 call_closure_2 (SCM proc
, SCM arg1
, SCM arg2
)
4634 const SCM env
= SCM_EXTEND_ENV (SCM_CLOSURE_FORMALS (proc
),
4635 scm_list_2 (arg1
, arg2
),
4637 const SCM result
= scm_eval_body (SCM_CLOSURE_BODY (proc
), env
);
4642 scm_trampoline_2 (SCM proc
)
4648 switch (SCM_TYP7 (proc
))
4650 case scm_tc7_subr_2
:
4651 case scm_tc7_subr_2o
:
4652 case scm_tc7_rpsubr
:
4654 return call_subr2_2
;
4655 case scm_tc7_lsubr_2
:
4656 return call_lsubr2_2
;
4658 return call_lsubr_2
;
4659 case scm_tcs_closures
:
4661 SCM formals
= SCM_CLOSURE_FORMALS (proc
);
4662 if (!SCM_NULLP (formals
)
4663 && (!SCM_CONSP (formals
)
4664 || (!SCM_NULLP (SCM_CDR (formals
))
4665 && (!SCM_CONSP (SCM_CDR (formals
))
4666 || !SCM_CONSP (SCM_CDDR (formals
))))))
4667 return call_closure_2
;
4671 case scm_tcs_struct
:
4672 if (SCM_OBJ_CLASS_FLAGS (proc
) & SCM_CLASSF_PURE_GENERIC
)
4673 return scm_call_generic_2
;
4674 else if (SCM_I_OPERATORP (proc
))
4678 if (SCM_SMOB_APPLICABLE_P (proc
))
4679 return SCM_SMOB_DESCRIPTOR (proc
).apply_2
;
4686 return NULL
; /* not applicable on two args */
4690 /* Typechecking for multi-argument MAP and FOR-EACH.
4692 Verify that each element of the vector ARGV, except for the first,
4693 is a proper list whose length is LEN. Attribute errors to WHO,
4694 and claim that the i'th element of ARGV is WHO's i+2'th argument. */
4696 check_map_args (SCM argv
,
4703 SCM
const *ve
= SCM_VELTS (argv
);
4706 for (i
= SCM_VECTOR_LENGTH (argv
) - 1; i
>= 1; i
--)
4708 long elt_len
= scm_ilength (ve
[i
]);
4713 scm_apply_generic (gf
, scm_cons (proc
, args
));
4715 scm_wrong_type_arg (who
, i
+ 2, ve
[i
]);
4719 scm_out_of_range_pos (who
, ve
[i
], SCM_MAKINUM (i
+ 2));
4722 scm_remember_upto_here_1 (argv
);
4726 SCM_GPROC (s_map
, "map", 2, 0, 1, scm_map
, g_map
);
4728 /* Note: Currently, scm_map applies PROC to the argument list(s)
4729 sequentially, starting with the first element(s). This is used in
4730 evalext.c where the Scheme procedure `map-in-order', which guarantees
4731 sequential behaviour, is implemented using scm_map. If the
4732 behaviour changes, we need to update `map-in-order'.
4736 scm_map (SCM proc
, SCM arg1
, SCM args
)
4737 #define FUNC_NAME s_map
4742 SCM
const *ve
= &args
; /* Keep args from being optimized away. */
4744 len
= scm_ilength (arg1
);
4745 SCM_GASSERTn (len
>= 0,
4746 g_map
, scm_cons2 (proc
, arg1
, args
), SCM_ARG2
, s_map
);
4747 SCM_VALIDATE_REST_ARGUMENT (args
);
4748 if (SCM_NULLP (args
))
4750 scm_t_trampoline_1 call
= scm_trampoline_1 (proc
);
4751 SCM_GASSERT2 (call
, g_map
, proc
, arg1
, SCM_ARG1
, s_map
);
4752 while (SCM_NIMP (arg1
))
4754 *pres
= scm_list_1 (call (proc
, SCM_CAR (arg1
)));
4755 pres
= SCM_CDRLOC (*pres
);
4756 arg1
= SCM_CDR (arg1
);
4760 if (SCM_NULLP (SCM_CDR (args
)))
4762 SCM arg2
= SCM_CAR (args
);
4763 int len2
= scm_ilength (arg2
);
4764 scm_t_trampoline_2 call
= scm_trampoline_2 (proc
);
4766 g_map
, scm_cons2 (proc
, arg1
, args
), SCM_ARG1
, s_map
);
4767 SCM_GASSERTn (len2
>= 0,
4768 g_map
, scm_cons2 (proc
, arg1
, args
), SCM_ARG3
, s_map
);
4770 SCM_OUT_OF_RANGE (3, arg2
);
4771 while (SCM_NIMP (arg1
))
4773 *pres
= scm_list_1 (call (proc
, SCM_CAR (arg1
), SCM_CAR (arg2
)));
4774 pres
= SCM_CDRLOC (*pres
);
4775 arg1
= SCM_CDR (arg1
);
4776 arg2
= SCM_CDR (arg2
);
4780 arg1
= scm_cons (arg1
, args
);
4781 args
= scm_vector (arg1
);
4782 ve
= SCM_VELTS (args
);
4783 check_map_args (args
, len
, g_map
, proc
, arg1
, s_map
);
4787 for (i
= SCM_VECTOR_LENGTH (args
) - 1; i
>= 0; i
--)
4789 if (SCM_IMP (ve
[i
]))
4791 arg1
= scm_cons (SCM_CAR (ve
[i
]), arg1
);
4792 SCM_VECTOR_SET (args
, i
, SCM_CDR (ve
[i
]));
4794 *pres
= scm_list_1 (scm_apply (proc
, arg1
, SCM_EOL
));
4795 pres
= SCM_CDRLOC (*pres
);
4801 SCM_GPROC (s_for_each
, "for-each", 2, 0, 1, scm_for_each
, g_for_each
);
4804 scm_for_each (SCM proc
, SCM arg1
, SCM args
)
4805 #define FUNC_NAME s_for_each
4807 SCM
const *ve
= &args
; /* Keep args from being optimized away. */
4809 len
= scm_ilength (arg1
);
4810 SCM_GASSERTn (len
>= 0, g_for_each
, scm_cons2 (proc
, arg1
, args
),
4811 SCM_ARG2
, s_for_each
);
4812 SCM_VALIDATE_REST_ARGUMENT (args
);
4813 if (SCM_NULLP (args
))
4815 scm_t_trampoline_1 call
= scm_trampoline_1 (proc
);
4816 SCM_GASSERT2 (call
, g_for_each
, proc
, arg1
, SCM_ARG1
, s_for_each
);
4817 while (SCM_NIMP (arg1
))
4819 call (proc
, SCM_CAR (arg1
));
4820 arg1
= SCM_CDR (arg1
);
4822 return SCM_UNSPECIFIED
;
4824 if (SCM_NULLP (SCM_CDR (args
)))
4826 SCM arg2
= SCM_CAR (args
);
4827 int len2
= scm_ilength (arg2
);
4828 scm_t_trampoline_2 call
= scm_trampoline_2 (proc
);
4829 SCM_GASSERTn (call
, g_for_each
,
4830 scm_cons2 (proc
, arg1
, args
), SCM_ARG1
, s_for_each
);
4831 SCM_GASSERTn (len2
>= 0, g_for_each
,
4832 scm_cons2 (proc
, arg1
, args
), SCM_ARG3
, s_for_each
);
4834 SCM_OUT_OF_RANGE (3, arg2
);
4835 while (SCM_NIMP (arg1
))
4837 call (proc
, SCM_CAR (arg1
), SCM_CAR (arg2
));
4838 arg1
= SCM_CDR (arg1
);
4839 arg2
= SCM_CDR (arg2
);
4841 return SCM_UNSPECIFIED
;
4843 arg1
= scm_cons (arg1
, args
);
4844 args
= scm_vector (arg1
);
4845 ve
= SCM_VELTS (args
);
4846 check_map_args (args
, len
, g_for_each
, proc
, arg1
, s_for_each
);
4850 for (i
= SCM_VECTOR_LENGTH (args
) - 1; i
>= 0; i
--)
4852 if (SCM_IMP (ve
[i
]))
4853 return SCM_UNSPECIFIED
;
4854 arg1
= scm_cons (SCM_CAR (ve
[i
]), arg1
);
4855 SCM_VECTOR_SET (args
, i
, SCM_CDR (ve
[i
]));
4857 scm_apply (proc
, arg1
, SCM_EOL
);
4864 scm_closure (SCM code
, SCM env
)
4867 SCM closcar
= scm_cons (code
, SCM_EOL
);
4868 z
= scm_cell (SCM_UNPACK (closcar
) + scm_tc3_closure
, (scm_t_bits
) env
);
4869 scm_remember_upto_here (closcar
);
4874 scm_t_bits scm_tc16_promise
;
4877 scm_makprom (SCM code
)
4879 SCM_RETURN_NEWSMOB2 (scm_tc16_promise
,
4881 scm_make_rec_mutex ());
4885 promise_free (SCM promise
)
4887 scm_rec_mutex_free (SCM_PROMISE_MUTEX (promise
));
4892 promise_print (SCM exp
, SCM port
, scm_print_state
*pstate
)
4894 int writingp
= SCM_WRITINGP (pstate
);
4895 scm_puts ("#<promise ", port
);
4896 SCM_SET_WRITINGP (pstate
, 1);
4897 scm_iprin1 (SCM_PROMISE_DATA (exp
), port
, pstate
);
4898 SCM_SET_WRITINGP (pstate
, writingp
);
4899 scm_putc ('>', port
);
4903 SCM_DEFINE (scm_force
, "force", 1, 0, 0,
4905 "If the promise @var{x} has not been computed yet, compute and\n"
4906 "return @var{x}, otherwise just return the previously computed\n"
4908 #define FUNC_NAME s_scm_force
4910 SCM_VALIDATE_SMOB (1, promise
, promise
);
4911 scm_rec_mutex_lock (SCM_PROMISE_MUTEX (promise
));
4912 if (!SCM_PROMISE_COMPUTED_P (promise
))
4914 SCM ans
= scm_call_0 (SCM_PROMISE_DATA (promise
));
4915 if (!SCM_PROMISE_COMPUTED_P (promise
))
4917 SCM_SET_PROMISE_DATA (promise
, ans
);
4918 SCM_SET_PROMISE_COMPUTED (promise
);
4921 scm_rec_mutex_unlock (SCM_PROMISE_MUTEX (promise
));
4922 return SCM_PROMISE_DATA (promise
);
4927 SCM_DEFINE (scm_promise_p
, "promise?", 1, 0, 0,
4929 "Return true if @var{obj} is a promise, i.e. a delayed computation\n"
4930 "(@pxref{Delayed evaluation,,,r5rs.info,The Revised^5 Report on Scheme}).")
4931 #define FUNC_NAME s_scm_promise_p
4933 return SCM_BOOL (SCM_TYP16_PREDICATE (scm_tc16_promise
, obj
));
4938 SCM_DEFINE (scm_cons_source
, "cons-source", 3, 0, 0,
4939 (SCM xorig
, SCM x
, SCM y
),
4940 "Create and return a new pair whose car and cdr are @var{x} and @var{y}.\n"
4941 "Any source properties associated with @var{xorig} are also associated\n"
4942 "with the new pair.")
4943 #define FUNC_NAME s_scm_cons_source
4946 z
= scm_cons (x
, y
);
4947 /* Copy source properties possibly associated with xorig. */
4948 p
= scm_whash_lookup (scm_source_whash
, xorig
);
4950 scm_whash_insert (scm_source_whash
, z
, p
);
4956 SCM_DEFINE (scm_copy_tree
, "copy-tree", 1, 0, 0,
4958 "Recursively copy the data tree that is bound to @var{obj}, and return a\n"
4959 "pointer to the new data structure. @code{copy-tree} recurses down the\n"
4960 "contents of both pairs and vectors (since both cons cells and vector\n"
4961 "cells may point to arbitrary objects), and stops recursing when it hits\n"
4962 "any other object.")
4963 #define FUNC_NAME s_scm_copy_tree
4968 if (SCM_VECTORP (obj
))
4970 unsigned long i
= SCM_VECTOR_LENGTH (obj
);
4971 ans
= scm_c_make_vector (i
, SCM_UNSPECIFIED
);
4973 SCM_VECTOR_SET (ans
, i
, scm_copy_tree (SCM_VELTS (obj
)[i
]));
4976 if (!SCM_CONSP (obj
))
4978 ans
= tl
= scm_cons_source (obj
,
4979 scm_copy_tree (SCM_CAR (obj
)),
4981 for (obj
= SCM_CDR (obj
); SCM_CONSP (obj
); obj
= SCM_CDR (obj
))
4983 SCM_SETCDR (tl
, scm_cons (scm_copy_tree (SCM_CAR (obj
)),
4987 SCM_SETCDR (tl
, obj
);
4993 /* We have three levels of EVAL here:
4995 - scm_i_eval (exp, env)
4997 evaluates EXP in environment ENV. ENV is a lexical environment
4998 structure as used by the actual tree code evaluator. When ENV is
4999 a top-level environment, then changes to the current module are
5000 tracked by updating ENV so that it continues to be in sync with
5003 - scm_primitive_eval (exp)
5005 evaluates EXP in the top-level environment as determined by the
5006 current module. This is done by constructing a suitable
5007 environment and calling scm_i_eval. Thus, changes to the
5008 top-level module are tracked normally.
5010 - scm_eval (exp, mod)
5012 evaluates EXP while MOD is the current module. This is done by
5013 setting the current module to MOD, invoking scm_primitive_eval on
5014 EXP, and then restoring the current module to the value it had
5015 previously. That is, while EXP is evaluated, changes to the
5016 current module are tracked, but these changes do not persist when
5019 For each level of evals, there are two variants, distinguished by a
5020 _x suffix: the ordinary variant does not modify EXP while the _x
5021 variant can destructively modify EXP into something completely
5022 unintelligible. A Scheme data structure passed as EXP to one of the
5023 _x variants should not ever be used again for anything. So when in
5024 doubt, use the ordinary variant.
5029 scm_i_eval_x (SCM exp
, SCM env
)
5031 return SCM_XEVAL (exp
, env
);
5035 scm_i_eval (SCM exp
, SCM env
)
5037 exp
= scm_copy_tree (exp
);
5038 return SCM_XEVAL (exp
, env
);
5042 scm_primitive_eval_x (SCM exp
)
5045 SCM transformer
= scm_current_module_transformer ();
5046 if (SCM_NIMP (transformer
))
5047 exp
= scm_call_1 (transformer
, exp
);
5048 env
= scm_top_level_env (scm_current_module_lookup_closure ());
5049 return scm_i_eval_x (exp
, env
);
5052 SCM_DEFINE (scm_primitive_eval
, "primitive-eval", 1, 0, 0,
5054 "Evaluate @var{exp} in the top-level environment specified by\n"
5055 "the current module.")
5056 #define FUNC_NAME s_scm_primitive_eval
5059 SCM transformer
= scm_current_module_transformer ();
5060 if (SCM_NIMP (transformer
))
5061 exp
= scm_call_1 (transformer
, exp
);
5062 env
= scm_top_level_env (scm_current_module_lookup_closure ());
5063 return scm_i_eval (exp
, env
);
5067 /* Eval does not take the second arg optionally. This is intentional
5068 * in order to be R5RS compatible, and to prepare for the new module
5069 * system, where we would like to make the choice of evaluation
5070 * environment explicit. */
5073 change_environment (void *data
)
5075 SCM pair
= SCM_PACK (data
);
5076 SCM new_module
= SCM_CAR (pair
);
5077 SCM old_module
= scm_current_module ();
5078 SCM_SETCDR (pair
, old_module
);
5079 scm_set_current_module (new_module
);
5084 restore_environment (void *data
)
5086 SCM pair
= SCM_PACK (data
);
5087 SCM old_module
= SCM_CDR (pair
);
5088 SCM new_module
= scm_current_module ();
5089 SCM_SETCAR (pair
, new_module
);
5090 scm_set_current_module (old_module
);
5094 inner_eval_x (void *data
)
5096 return scm_primitive_eval_x (SCM_PACK(data
));
5100 scm_eval_x (SCM exp
, SCM module
)
5101 #define FUNC_NAME "eval!"
5103 SCM_VALIDATE_MODULE (2, module
);
5105 return scm_internal_dynamic_wind
5106 (change_environment
, inner_eval_x
, restore_environment
,
5107 (void *) SCM_UNPACK (exp
),
5108 (void *) SCM_UNPACK (scm_cons (module
, SCM_BOOL_F
)));
5113 inner_eval (void *data
)
5115 return scm_primitive_eval (SCM_PACK(data
));
5118 SCM_DEFINE (scm_eval
, "eval", 2, 0, 0,
5119 (SCM exp
, SCM module
),
5120 "Evaluate @var{exp}, a list representing a Scheme expression,\n"
5121 "in the top-level environment specified by @var{module}.\n"
5122 "While @var{exp} is evaluated (using @code{primitive-eval}),\n"
5123 "@var{module} is made the current module. The current module\n"
5124 "is reset to its previous value when @var{eval} returns.")
5125 #define FUNC_NAME s_scm_eval
5127 SCM_VALIDATE_MODULE (2, module
);
5129 return scm_internal_dynamic_wind
5130 (change_environment
, inner_eval
, restore_environment
,
5131 (void *) SCM_UNPACK (exp
),
5132 (void *) SCM_UNPACK (scm_cons (module
, SCM_BOOL_F
)));
5137 /* At this point, scm_deval and scm_dapply are generated.
5147 scm_init_opts (scm_evaluator_traps
,
5148 scm_evaluator_trap_table
,
5149 SCM_N_EVALUATOR_TRAPS
);
5150 scm_init_opts (scm_eval_options_interface
,
5152 SCM_N_EVAL_OPTIONS
);
5154 scm_tc16_promise
= scm_make_smob_type ("promise", 0);
5155 scm_set_smob_mark (scm_tc16_promise
, scm_markcdr
);
5156 scm_set_smob_free (scm_tc16_promise
, promise_free
);
5157 scm_set_smob_print (scm_tc16_promise
, promise_print
);
5159 undefineds
= scm_list_1 (SCM_UNDEFINED
);
5160 SCM_SETCDR (undefineds
, undefineds
);
5161 scm_permanent_object (undefineds
);
5163 scm_listofnull
= scm_list_1 (SCM_EOL
);
5165 f_apply
= scm_c_define_subr ("apply", scm_tc7_lsubr_2
, scm_apply
);
5166 scm_permanent_object (f_apply
);
5168 #include "libguile/eval.x"
5170 scm_add_feature ("delay");