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 a different number of expressions than are
105 * required in that context, a 'Missing or extra expression' error is
107 static const char s_expression
[] = "Missing or extra expression in";
109 /* If a form is detected that holds less expressions than are required in that
110 * context, a 'Missing expression' error is signalled. */
111 static const char s_missing_expression
[] = "Missing expression in";
113 /* If a form is detected that holds more expressions than are allowed in that
114 * context, an 'Extra expression' error is signalled. */
115 static const char s_extra_expression
[] = "Extra expression in";
117 /* The empty combination '()' is not allowed as an expression in scheme. If
118 * it is detected in a place where an expression is expected, an 'Illegal
119 * empty combination' error is signalled. Note: If you encounter this error
120 * message, it is very likely that you intended to denote the empty list. To
121 * do so, you need to quote the empty list like (quote ()) or '(). */
122 static const char s_empty_combination
[] = "Illegal empty combination";
124 /* Case or cond expressions must have at least one clause. If a case or cond
125 * expression without any clauses is detected, a 'Missing clauses' error is
127 static const char s_missing_clauses
[] = "Missing clauses";
129 /* If there is an 'else' clause in a case or a cond statement, it must be the
130 * last clause. If after the 'else' case clause further clauses are detected,
131 * a 'Misplaced else clause' error is signalled. */
132 static const char s_misplaced_else_clause
[] = "Misplaced else clause";
134 /* If a case clause is detected that is not in the format
135 * (<label(s)> <expression1> <expression2> ...)
136 * a 'Bad case clause' error is signalled. */
137 static const char s_bad_case_clause
[] = "Bad case clause";
139 /* If a case clause is detected where the <label(s)> element is neither a
140 * proper list nor (in case of the last clause) the syntactic keyword 'else',
141 * a 'Bad case labels' error is signalled. Note: If you encounter this error
142 * for an else-clause which seems to be syntactically correct, check if 'else'
143 * is really a syntactic keyword in that context. If 'else' is bound in the
144 * local or global environment, it is not considered a syntactic keyword, but
145 * will be treated as any other variable. */
146 static const char s_bad_case_labels
[] = "Bad case labels";
148 /* In a case statement all labels have to be distinct. If in a case statement
149 * a label occurs more than once, a 'Duplicate case label' error is
151 static const char s_duplicate_case_label
[] = "Duplicate case label";
153 /* If a cond clause is detected that is not in one of the formats
154 * (<test> <expression1> ...) or (else <expression1> <expression2> ...)
155 * a 'Bad cond clause' error is signalled. */
156 static const char s_bad_cond_clause
[] = "Bad cond clause";
158 /* If a cond clause is detected that uses the alternate '=>' form, but does
159 * not hold a recipient element for the test result, a 'Missing recipient'
160 * error is signalled. */
161 static const char s_missing_recipient
[] = "Missing recipient in";
163 /* If in a position where a variable name is required some other object is
164 * detected, a 'Bad variable' error is signalled. */
165 static const char s_bad_variable
[] = "Bad variable";
167 /* Bindings for forms like 'let' and 'do' have to be given in a proper,
168 * possibly empty list. If any other object is detected in a place where a
169 * list of bindings was required, a 'Bad bindings' error is signalled. */
170 static const char s_bad_bindings
[] = "Bad bindings";
172 /* Depending on the syntactic context, a binding has to be in the format
173 * (<variable> <expression>) or (<variable> <expression1> <expression2>).
174 * If anything else is detected in a place where a binding was expected, a
175 * 'Bad binding' error is signalled. */
176 static const char s_bad_binding
[] = "Bad binding";
178 /* Some syntactic forms don't allow variable names to appear more than once in
179 * a list of bindings. If such a situation is nevertheless detected, a
180 * 'Duplicate binding' error is signalled. */
181 static const char s_duplicate_binding
[] = "Duplicate binding";
183 /* If the exit form of a 'do' expression is not in the format
184 * (<test> <expression> ...)
185 * a 'Bad exit clause' error is signalled. */
186 static const char s_bad_exit_clause
[] = "Bad exit clause";
188 /* The formal function arguments of a lambda expression have to be either a
189 * single symbol or a non-cyclic list. For anything else a 'Bad formals'
190 * error is signalled. */
191 static const char s_bad_formals
[] = "Bad formals";
193 /* If in a lambda expression something else than a symbol is detected at a
194 * place where a formal function argument is required, a 'Bad formal' error is
196 static const char s_bad_formal
[] = "Bad formal";
198 /* If in the arguments list of a lambda expression an argument name occurs
199 * more than once, a 'Duplicate formal' error is signalled. */
200 static const char s_duplicate_formal
[] = "Duplicate formal";
202 /* If something else than an exact integer is detected as the argument for
203 * @slot-ref and @slot-set!, a 'Bad slot number' error is signalled. */
204 static const char s_bad_slot_number
[] = "Bad slot number";
207 /* Signal a syntax error. We distinguish between the form that caused the
208 * error and the enclosing expression. The error message will print out as
209 * shown in the following pattern. The file name and line number are only
210 * given when they can be determined from the erroneous form or from the
211 * enclosing expression.
213 * <filename>: In procedure memoization:
214 * <filename>: In file <name>, line <nr>: <error-message> in <expression>. */
216 SCM_SYMBOL (syntax_error_key
, "syntax-error");
218 /* The prototype is needed to indicate that the function does not return. */
220 syntax_error (const char* const, const SCM
, const SCM
) SCM_NORETURN
;
223 syntax_error (const char* const msg
, const SCM form
, const SCM expr
)
225 const SCM msg_string
= scm_makfrom0str (msg
);
226 SCM filename
= SCM_BOOL_F
;
227 SCM linenr
= SCM_BOOL_F
;
231 if (SCM_CONSP (form
))
233 filename
= scm_source_property (form
, scm_sym_filename
);
234 linenr
= scm_source_property (form
, scm_sym_line
);
237 if (SCM_FALSEP (filename
) && SCM_FALSEP (linenr
) && SCM_CONSP (expr
))
239 filename
= scm_source_property (expr
, scm_sym_filename
);
240 linenr
= scm_source_property (expr
, scm_sym_line
);
243 if (!SCM_UNBNDP (expr
))
245 if (!SCM_FALSEP (filename
))
247 format
= "In file ~S, line ~S: ~A ~S in expression ~S.";
248 args
= scm_list_5 (filename
, linenr
, msg_string
, form
, expr
);
250 else if (!SCM_FALSEP (linenr
))
252 format
= "In line ~S: ~A ~S in expression ~S.";
253 args
= scm_list_4 (linenr
, msg_string
, form
, expr
);
257 format
= "~A ~S in expression ~S.";
258 args
= scm_list_3 (msg_string
, form
, expr
);
263 if (!SCM_FALSEP (filename
))
265 format
= "In file ~S, line ~S: ~A ~S.";
266 args
= scm_list_4 (filename
, linenr
, msg_string
, form
);
268 else if (!SCM_FALSEP (linenr
))
270 format
= "In line ~S: ~A ~S.";
271 args
= scm_list_3 (linenr
, msg_string
, form
);
276 args
= scm_list_2 (msg_string
, form
);
280 scm_error (syntax_error_key
, "memoization", format
, args
, SCM_BOOL_F
);
284 /* Shortcut macros to simplify syntax error handling. */
285 #define ASSERT_SYNTAX(cond, message, form) \
286 { if (!(cond)) syntax_error (message, form, SCM_UNDEFINED); }
287 #define ASSERT_SYNTAX_2(cond, message, form, expr) \
288 { if (!(cond)) syntax_error (message, form, expr); }
294 * Ilocs are memoized references to variables in local environment frames.
295 * They are represented as three values: The relative offset of the
296 * environment frame, the number of the binding within that frame, and a
297 * boolean value indicating whether the binding is the last binding in the
300 #define SCM_ILOC00 SCM_MAKE_ITAG8(0L, scm_tc8_iloc)
301 #define SCM_IDINC (0x00100000L)
302 #define SCM_IDSTMSK (-SCM_IDINC)
303 #define SCM_MAKE_ILOC(frame_nr, binding_nr, last_p) \
306 + ((binding_nr) << 20) \
307 + ((last_p) ? SCM_ICDR : 0) \
310 #if (SCM_DEBUG_DEBUGGING_SUPPORT == 1)
312 SCM
scm_dbg_make_iloc (SCM frame
, SCM binding
, SCM cdrp
);
313 SCM_DEFINE (scm_dbg_make_iloc
, "dbg-make-iloc", 3, 0, 0,
314 (SCM frame
, SCM binding
, SCM cdrp
),
315 "Return a new iloc with frame offset @var{frame}, binding\n"
316 "offset @var{binding} and the cdr flag @var{cdrp}.")
317 #define FUNC_NAME s_scm_dbg_make_iloc
319 SCM_VALIDATE_INUM (1, frame
);
320 SCM_VALIDATE_INUM (2, binding
);
321 return SCM_MAKE_ILOC (SCM_INUM (frame
),
327 SCM
scm_dbg_iloc_p (SCM obj
);
328 SCM_DEFINE (scm_dbg_iloc_p
, "dbg-iloc?", 1, 0, 0,
330 "Return @code{#t} if @var{obj} is an iloc.")
331 #define FUNC_NAME s_scm_dbg_iloc_p
333 return SCM_BOOL (SCM_ILOCP (obj
));
341 #define SCM_VALIDATE_NON_EMPTY_COMBINATION(x) \
342 ASSERT_SYNTAX (!SCM_EQ_P ((x), SCM_EOL), s_empty_combination, x)
346 /* The evaluator contains a plethora of EVAL symbols.
347 * This is an attempt at explanation.
349 * The following macros should be used in code which is read twice
350 * (where the choice of evaluator is hard soldered):
352 * SCM_CEVAL is the symbol used within one evaluator to call itself.
353 * Originally, it is defined to scm_ceval, but is redefined to
354 * scm_deval during the second pass.
356 * SCM_EVALIM is used when it is known that the expression is an
357 * immediate. (This macro never calls an evaluator.)
359 * EVALCAR evaluates the car of an expression.
361 * The following macros should be used in code which is read once
362 * (where the choice of evaluator is dynamic):
364 * SCM_XEVAL takes care of immediates without calling an evaluator. It
365 * then calls scm_ceval *or* scm_deval, depending on the debugging
368 * SCM_XEVALCAR corresponds to EVALCAR, but uses scm_ceval *or* scm_deval
369 * depending on the debugging mode.
371 * The main motivation for keeping this plethora is efficiency
372 * together with maintainability (=> locality of code).
375 #define SCM_CEVAL scm_ceval
377 #define SCM_EVALIM2(x) \
378 ((SCM_EQ_P ((x), SCM_EOL) \
379 ? syntax_error (s_empty_combination, (x), SCM_UNDEFINED), 0 \
383 #define SCM_EVALIM(x, env) (SCM_ILOCP (x) \
384 ? *scm_ilookup ((x), env) \
387 #define SCM_XEVAL(x, env) (SCM_IMP (x) \
389 : (*scm_ceval_ptr) ((x), (env)))
391 #define SCM_XEVALCAR(x, env) (SCM_IMP (SCM_CAR (x)) \
392 ? SCM_EVALIM (SCM_CAR (x), env) \
393 : (SCM_SYMBOLP (SCM_CAR (x)) \
394 ? *scm_lookupcar (x, env, 1) \
395 : (*scm_ceval_ptr) (SCM_CAR (x), env)))
397 #define EVALCAR(x, env) (SCM_IMP (SCM_CAR (x)) \
398 ? SCM_EVALIM (SCM_CAR (x), env) \
399 : (SCM_SYMBOLP (SCM_CAR (x)) \
400 ? *scm_lookupcar (x, env, 1) \
401 : SCM_CEVAL (SCM_CAR (x), env)))
403 SCM_REC_MUTEX (source_mutex
);
406 static const char s_test
[] = "bad test";
407 static const char s_body
[] = "bad body";
408 static const char s_bindings
[] = "bad bindings";
409 static const char s_duplicate_bindings
[] = "duplicate bindings";
410 static const char s_variable
[] = "bad variable";
411 static const char s_splicing
[] = "bad (non-list) result for unquote-splicing";
414 /* Lookup a given local variable in an environment. The local variable is
415 * given as an iloc, that is a triple <frame, binding, last?>, where frame
416 * indicates the relative number of the environment frame (counting upwards
417 * from the innermost environment frame), binding indicates the number of the
418 * binding within the frame, and last? (which is extracted from the iloc using
419 * the macro SCM_ICDRP) indicates whether the binding forms the binding at the
420 * very end of the improper list of bindings. */
422 scm_ilookup (SCM iloc
, SCM env
)
424 unsigned int frame_nr
= SCM_IFRAME (iloc
);
425 unsigned int binding_nr
= SCM_IDIST (iloc
);
429 for (; 0 != frame_nr
; --frame_nr
)
430 frames
= SCM_CDR (frames
);
432 bindings
= SCM_CAR (frames
);
433 for (; 0 != binding_nr
; --binding_nr
)
434 bindings
= SCM_CDR (bindings
);
436 if (SCM_ICDRP (iloc
))
437 return SCM_CDRLOC (bindings
);
438 return SCM_CARLOC (SCM_CDR (bindings
));
442 SCM_SYMBOL (scm_unbound_variable_key
, "unbound-variable");
444 static void error_unbound_variable (SCM symbol
) SCM_NORETURN
;
446 error_unbound_variable (SCM symbol
)
448 scm_error (scm_unbound_variable_key
, NULL
,
449 "Unbound variable: ~S",
450 scm_list_1 (symbol
), SCM_BOOL_F
);
454 /* The Lookup Car Race
457 Memoization of variables and special forms is done while executing
458 the code for the first time. As long as there is only one thread
459 everything is fine, but as soon as two threads execute the same
460 code concurrently `for the first time' they can come into conflict.
462 This memoization includes rewriting variable references into more
463 efficient forms and expanding macros. Furthermore, macro expansion
464 includes `compiling' special forms like `let', `cond', etc. into
465 tree-code instructions.
467 There shouldn't normally be a problem with memoizing local and
468 global variable references (into ilocs and variables), because all
469 threads will mutate the code in *exactly* the same way and (if I
470 read the C code correctly) it is not possible to observe a half-way
471 mutated cons cell. The lookup procedure can handle this
472 transparently without any critical sections.
474 It is different with macro expansion, because macro expansion
475 happens outside of the lookup procedure and can't be
476 undone. Therefore the lookup procedure can't cope with it. It has
477 to indicate failure when it detects a lost race and hope that the
478 caller can handle it. Luckily, it turns out that this is the case.
480 An example to illustrate this: Suppose that the following form will
481 be memoized concurrently by two threads
485 Let's first examine the lookup of X in the body. The first thread
486 decides that it has to find the symbol "x" in the environment and
487 starts to scan it. Then the other thread takes over and actually
488 overtakes the first. It looks up "x" and substitutes an
489 appropriate iloc for it. Now the first thread continues and
490 completes its lookup. It comes to exactly the same conclusions as
491 the second one and could - without much ado - just overwrite the
492 iloc with the same iloc.
494 But let's see what will happen when the race occurs while looking
495 up the symbol "let" at the start of the form. It could happen that
496 the second thread interrupts the lookup of the first thread and not
497 only substitutes a variable for it but goes right ahead and
498 replaces it with the compiled form (#@let* (x 12) x). Now, when
499 the first thread completes its lookup, it would replace the #@let*
500 with a variable containing the "let" binding, effectively reverting
501 the form to (let (x 12) x). This is wrong. It has to detect that
502 it has lost the race and the evaluator has to reconsider the
503 changed form completely.
505 This race condition could be resolved with some kind of traffic
506 light (like mutexes) around scm_lookupcar, but I think that it is
507 best to avoid them in this case. They would serialize memoization
508 completely and because lookup involves calling arbitrary Scheme
509 code (via the lookup-thunk), threads could be blocked for an
510 arbitrary amount of time or even deadlock. But with the current
511 solution a lot of unnecessary work is potentially done. */
513 /* SCM_LOOKUPCAR1 is what SCM_LOOKUPCAR used to be but is allowed to
514 return NULL to indicate a failed lookup due to some race conditions
515 between threads. This only happens when VLOC is the first cell of
516 a special form that will eventually be memoized (like `let', etc.)
517 In that case the whole lookup is bogus and the caller has to
518 reconsider the complete special form.
520 SCM_LOOKUPCAR is still there, of course. It just calls
521 SCM_LOOKUPCAR1 and aborts on receiving NULL. So SCM_LOOKUPCAR
522 should only be called when it is known that VLOC is not the first
523 pair of a special form. Otherwise, use SCM_LOOKUPCAR1 and check
524 for NULL. I think I've found the only places where this
528 scm_lookupcar1 (SCM vloc
, SCM genv
, int check
)
531 register SCM
*al
, fl
, var
= SCM_CAR (vloc
);
532 register SCM iloc
= SCM_ILOC00
;
533 for (; SCM_NIMP (env
); env
= SCM_CDR (env
))
535 if (!SCM_CONSP (SCM_CAR (env
)))
537 al
= SCM_CARLOC (env
);
538 for (fl
= SCM_CAR (*al
); SCM_NIMP (fl
); fl
= SCM_CDR (fl
))
542 if (SCM_EQ_P (fl
, var
))
544 if (! SCM_EQ_P (SCM_CAR (vloc
), var
))
546 SCM_SET_CELL_WORD_0 (vloc
, SCM_UNPACK (iloc
) + SCM_ICDR
);
547 return SCM_CDRLOC (*al
);
552 al
= SCM_CDRLOC (*al
);
553 if (SCM_EQ_P (SCM_CAR (fl
), var
))
555 if (SCM_UNBNDP (SCM_CAR (*al
)))
560 if (!SCM_EQ_P (SCM_CAR (vloc
), var
))
562 SCM_SETCAR (vloc
, iloc
);
563 return SCM_CARLOC (*al
);
565 iloc
= SCM_PACK (SCM_UNPACK (iloc
) + SCM_IDINC
);
567 iloc
= SCM_PACK ((~SCM_IDSTMSK
) & (SCM_UNPACK(iloc
) + SCM_IFRINC
));
570 SCM top_thunk
, real_var
;
573 top_thunk
= SCM_CAR (env
); /* env now refers to a
574 top level env thunk */
578 top_thunk
= SCM_BOOL_F
;
579 real_var
= scm_sym2var (var
, top_thunk
, SCM_BOOL_F
);
580 if (SCM_FALSEP (real_var
))
583 if (!SCM_NULLP (env
) || SCM_UNBNDP (SCM_VARIABLE_REF (real_var
)))
589 error_unbound_variable (var
);
591 scm_misc_error (NULL
, "Damaged environment: ~S",
596 /* A variable could not be found, but we shall
597 not throw an error. */
598 static SCM undef_object
= SCM_UNDEFINED
;
599 return &undef_object
;
603 if (!SCM_EQ_P (SCM_CAR (vloc
), var
))
605 /* Some other thread has changed the very cell we are working
606 on. In effect, it must have done our job or messed it up
609 var
= SCM_CAR (vloc
);
610 if (SCM_VARIABLEP (var
))
611 return SCM_VARIABLE_LOC (var
);
612 if (SCM_ITAG7 (var
) == SCM_ITAG7 (SCM_ILOC00
))
613 return scm_ilookup (var
, genv
);
614 /* We can't cope with anything else than variables and ilocs. When
615 a special form has been memoized (i.e. `let' into `#@let') we
616 return NULL and expect the calling function to do the right
617 thing. For the evaluator, this means going back and redoing
618 the dispatch on the car of the form. */
622 SCM_SETCAR (vloc
, real_var
);
623 return SCM_VARIABLE_LOC (real_var
);
628 scm_lookupcar (SCM vloc
, SCM genv
, int check
)
630 SCM
*loc
= scm_lookupcar1 (vloc
, genv
, check
);
636 /* Return true if the symbol is - from the point of view of a macro
637 * transformer - a literal in the sense specified in chapter "pattern
638 * language" of R5RS. In the code below, however, we don't match the
639 * definition of R5RS exactly: It returns true if the identifier has no
640 * binding or if it is a syntactic keyword. */
642 literal_p (const SCM symbol
, const SCM env
)
644 const SCM x
= scm_cons (symbol
, SCM_UNDEFINED
);
645 const SCM value
= *scm_lookupcar (x
, env
, 0);
646 if (SCM_UNBNDP (value
) || SCM_MACROP (value
))
654 scm_eval_car (SCM pair
, SCM env
)
656 return SCM_XEVALCAR (pair
, env
);
661 * The following rewrite expressions and
662 * some memoized forms have different syntax
665 SCM_GLOBAL_SYMBOL (scm_sym_else
, "else");
666 SCM_GLOBAL_SYMBOL (scm_sym_unquote
, "unquote");
667 SCM_GLOBAL_SYMBOL (scm_sym_uq_splicing
, "unquote-splicing");
669 SCM_GLOBAL_SYMBOL (scm_sym_enter_frame
, "enter-frame");
670 SCM_GLOBAL_SYMBOL (scm_sym_apply_frame
, "apply-frame");
671 SCM_GLOBAL_SYMBOL (scm_sym_exit_frame
, "exit-frame");
672 SCM_GLOBAL_SYMBOL (scm_sym_trace
, "trace");
675 /* Rewrite the body (which is given as the list of expressions forming the
676 * body) into its internal form. The internal form of a body (<expr> ...) is
677 * just the body itself, but prefixed with an ISYM that denotes to what kind
678 * of outer construct this body belongs: (<ISYM> <expr> ...). A lambda body
679 * starts with SCM_IM_LAMBDA, for example, a body of a let starts with
680 * SCM_IM_LET, etc. The one exception is a body that belongs to a letrec that
681 * has been formed by rewriting internal defines: It starts with SCM_IM_DEFINE
682 * (instead of SCM_IM_LETREC).
684 * It is assumed that the calling expression has already made sure that the
685 * body is a proper list. */
687 scm_m_body (SCM op
, SCM exprs
)
689 /* Don't add another ISYM if one is present already. */
690 if (SCM_ISYMP (SCM_CAR (exprs
)))
693 return scm_cons (op
, exprs
);
697 /* Start of the memoizers for the standard R5RS builtin macros. */
700 SCM_SYNTAX (s_and
, "and", scm_i_makbimacro
, scm_m_and
);
701 SCM_GLOBAL_SYMBOL (scm_sym_and
, s_and
);
704 scm_m_and (SCM expr
, SCM env SCM_UNUSED
)
706 const SCM cdr_expr
= SCM_CDR (expr
);
707 const long length
= scm_ilength (cdr_expr
);
709 ASSERT_SYNTAX (length
>= 0, s_bad_expression
, expr
);
713 /* Special case: (and) is replaced by #t. */
718 SCM_SETCAR (expr
, SCM_IM_AND
);
724 SCM_SYNTAX (s_begin
, "begin", scm_i_makbimacro
, scm_m_begin
);
725 SCM_GLOBAL_SYMBOL (scm_sym_begin
, s_begin
);
728 scm_m_begin (SCM expr
, SCM env SCM_UNUSED
)
730 const SCM cdr_expr
= SCM_CDR (expr
);
731 /* Dirk:FIXME:: An empty begin clause is not generally allowed by R5RS.
732 * That means, there should be a distinction between uses of begin where an
733 * empty clause is OK and where it is not. */
734 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 0, s_bad_expression
, expr
);
736 SCM_SETCAR (expr
, SCM_IM_BEGIN
);
741 SCM_SYNTAX (s_case
, "case", scm_i_makbimacro
, scm_m_case
);
742 SCM_GLOBAL_SYMBOL (scm_sym_case
, s_case
);
745 scm_m_case (SCM expr
, SCM env
)
748 SCM all_labels
= SCM_EOL
;
750 /* Check, whether 'else is a literal, i. e. not bound to a value. */
751 const int else_literal_p
= literal_p (scm_sym_else
, env
);
753 const SCM cdr_expr
= SCM_CDR (expr
);
754 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 0, s_bad_expression
, expr
);
755 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 2, s_missing_clauses
, expr
);
757 clauses
= SCM_CDR (cdr_expr
);
758 while (!SCM_NULLP (clauses
))
762 const SCM clause
= SCM_CAR (clauses
);
763 ASSERT_SYNTAX_2 (scm_ilength (clause
) >= 2,
764 s_bad_case_clause
, clause
, expr
);
766 labels
= SCM_CAR (clause
);
767 if (SCM_CONSP (labels
))
769 ASSERT_SYNTAX_2 (scm_ilength (labels
) >= 0,
770 s_bad_case_labels
, labels
, expr
);
771 all_labels
= scm_append_x (scm_list_2 (labels
, all_labels
));
773 else if (SCM_NULLP (labels
))
775 /* The list of labels is empty. According to R5RS this is allowed.
776 * It means that the sequence of expressions will never be executed.
777 * Therefore, as an optimization, we could remove the whole
782 ASSERT_SYNTAX_2 (SCM_EQ_P (labels
, scm_sym_else
) && else_literal_p
,
783 s_bad_case_labels
, labels
, expr
);
784 ASSERT_SYNTAX_2 (SCM_NULLP (SCM_CDR (clauses
)),
785 s_misplaced_else_clause
, clause
, expr
);
788 /* build the new clause */
789 if (SCM_EQ_P (labels
, scm_sym_else
))
790 SCM_SETCAR (clause
, SCM_IM_ELSE
);
792 clauses
= SCM_CDR (clauses
);
795 /* Check whether all case labels are distinct. */
796 for (; !SCM_NULLP (all_labels
); all_labels
= SCM_CDR (all_labels
))
798 const SCM label
= SCM_CAR (all_labels
);
799 ASSERT_SYNTAX_2 (SCM_FALSEP (scm_c_memq (label
, SCM_CDR (all_labels
))),
800 s_duplicate_case_label
, label
, expr
);
803 SCM_SETCAR (expr
, SCM_IM_CASE
);
808 SCM_SYNTAX (s_cond
, "cond", scm_i_makbimacro
, scm_m_cond
);
809 SCM_GLOBAL_SYMBOL (scm_sym_cond
, s_cond
);
810 SCM_GLOBAL_SYMBOL (scm_sym_arrow
, "=>");
813 scm_m_cond (SCM expr
, SCM env
)
815 /* Check, whether 'else or '=> is a literal, i. e. not bound to a value. */
816 const int else_literal_p
= literal_p (scm_sym_else
, env
);
817 const int arrow_literal_p
= literal_p (scm_sym_arrow
, env
);
819 const SCM clauses
= SCM_CDR (expr
);
822 ASSERT_SYNTAX (scm_ilength (clauses
) >= 0, s_bad_expression
, expr
);
823 ASSERT_SYNTAX (scm_ilength (clauses
) >= 1, s_missing_clauses
, expr
);
825 for (clause_idx
= clauses
;
826 !SCM_NULLP (clause_idx
);
827 clause_idx
= SCM_CDR (clause_idx
))
831 const SCM clause
= SCM_CAR (clause_idx
);
832 const long length
= scm_ilength (clause
);
833 ASSERT_SYNTAX_2 (length
>= 1, s_bad_cond_clause
, clause
, expr
);
835 test
= SCM_CAR (clause
);
836 if (SCM_EQ_P (test
, scm_sym_else
) && else_literal_p
)
838 const int last_clause_p
= SCM_NULLP (SCM_CDR (clause_idx
));
839 ASSERT_SYNTAX_2 (length
>= 2,
840 s_bad_cond_clause
, clause
, expr
);
841 ASSERT_SYNTAX_2 (last_clause_p
,
842 s_misplaced_else_clause
, clause
, expr
);
843 SCM_SETCAR (clause
, SCM_IM_ELSE
);
846 && SCM_EQ_P (SCM_CADR (clause
), scm_sym_arrow
)
849 ASSERT_SYNTAX_2 (length
> 2, s_missing_recipient
, clause
, expr
);
850 ASSERT_SYNTAX_2 (length
== 3, s_extra_expression
, clause
, expr
);
851 SCM_SETCAR (SCM_CDR (clause
), SCM_IM_ARROW
);
855 SCM_SETCAR (expr
, SCM_IM_COND
);
860 SCM_SYNTAX(s_define
, "define", scm_i_makbimacro
, scm_m_define
);
861 SCM_GLOBAL_SYMBOL(scm_sym_define
, s_define
);
863 /* Guile provides an extension to R5RS' define syntax to represent function
864 * currying in a compact way. With this extension, it is allowed to write
865 * (define <nested-variable> <body>), where <nested-variable> has of one of
866 * the forms (<nested-variable> <formals>), (<nested-variable> . <formal>),
867 * (<variable> <formals>) or (<variable> . <formal>). As in R5RS, <formals>
868 * should be either a sequence of zero or more variables, or a sequence of one
869 * or more variables followed by a space-delimited period and another
870 * variable. Each level of argument nesting wraps the <body> within another
871 * lambda expression. For example, the following forms are allowed, each one
872 * followed by an equivalent, more explicit implementation.
874 * (define ((a b . c) . d) <body>) is equivalent to
875 * (define a (lambda (b . c) (lambda d <body>)))
877 * (define (((a) b) c . d) <body>) is equivalent to
878 * (define a (lambda () (lambda (b) (lambda (c . d) <body>))))
880 /* Dirk:FIXME:: We should provide an implementation for 'define' in the R5RS
881 * module that does not implement this extension. */
883 scm_m_define (SCM expr
, SCM env
)
888 const SCM cdr_expr
= SCM_CDR (expr
);
889 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 0, s_bad_expression
, expr
);
890 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 2, s_missing_expression
, expr
);
892 body
= SCM_CDR (cdr_expr
);
893 variable
= SCM_CAR (cdr_expr
);
894 while (SCM_CONSP (variable
))
896 /* This while loop realizes function currying by variable nesting.
897 * Variable is known to be a nested-variable. In every iteration of the
898 * loop another level of lambda expression is created, starting with the
899 * innermost one. Note that we don't check for duplicate formals here:
900 * This will be done by the memoizer of the lambda expression. */
901 const SCM formals
= SCM_CDR (variable
);
902 const SCM tail
= scm_cons (formals
, body
);
904 /* Add source properties to each new lambda expression: */
905 const SCM lambda
= scm_cons_source (variable
, scm_sym_lambda
, tail
);
907 body
= scm_list_1 (lambda
);
908 variable
= SCM_CAR (variable
);
910 ASSERT_SYNTAX_2 (SCM_SYMBOLP (variable
), s_bad_variable
, variable
, expr
);
911 ASSERT_SYNTAX (scm_ilength (body
) == 1, s_expression
, expr
);
913 if (SCM_TOP_LEVEL (env
))
916 const SCM value
= scm_eval_car (body
, env
);
917 if (SCM_REC_PROCNAMES_P
)
920 while (SCM_MACROP (tmp
))
921 tmp
= SCM_MACRO_CODE (tmp
);
922 if (SCM_CLOSUREP (tmp
)
923 /* Only the first definition determines the name. */
924 && SCM_FALSEP (scm_procedure_property (tmp
, scm_sym_name
)))
925 scm_set_procedure_property_x (tmp
, scm_sym_name
, variable
);
927 var
= scm_sym2var (variable
, scm_env_top_level (env
), SCM_BOOL_T
);
928 SCM_VARIABLE_SET (var
, value
);
929 return SCM_UNSPECIFIED
;
933 SCM_SETCAR (expr
, SCM_IM_DEFINE
);
934 SCM_SETCAR (cdr_expr
, variable
);
935 SCM_SETCDR (cdr_expr
, body
);
941 /* This is a helper function for forms (<keyword> <expression>) that are
942 * transformed into (#@<keyword> '() <memoized_expression>) in order to allow
943 * for easy creation of a thunk (i. e. a closure without arguments) using the
944 * ('() <memoized_expression>) tail of the memoized form. */
946 memoize_as_thunk_prototype (const SCM expr
, const SCM env SCM_UNUSED
)
948 const SCM cdr_expr
= SCM_CDR (expr
);
949 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 0, s_bad_expression
, expr
);
950 ASSERT_SYNTAX (scm_ilength (cdr_expr
) == 1, s_expression
, expr
);
952 SCM_SETCDR (expr
, scm_cons (SCM_EOL
, cdr_expr
));
958 SCM_SYNTAX (s_delay
, "delay", scm_i_makbimacro
, scm_m_delay
);
959 SCM_GLOBAL_SYMBOL (scm_sym_delay
, s_delay
);
961 /* Promises are implemented as closures with an empty parameter list. Thus,
962 * (delay <expression>) is transformed into (#@delay '() <expression>), where
963 * the empty list represents the empty parameter list. This representation
964 * allows for easy creation of the closure during evaluation. */
966 scm_m_delay (SCM expr
, SCM env
)
968 const SCM new_expr
= memoize_as_thunk_prototype (expr
, env
);
969 SCM_SETCAR (new_expr
, SCM_IM_DELAY
);
974 SCM_SYNTAX(s_do
, "do", scm_i_makbimacro
, scm_m_do
);
975 SCM_GLOBAL_SYMBOL(scm_sym_do
, s_do
);
977 /* DO gets the most radically altered syntax. The order of the vars is
978 * reversed here. During the evaluation this allows for simple consing of the
979 * results of the inits and steps:
981 (do ((<var1> <init1> <step1>)
989 (#@do (<init1> <init2> ... <initn>)
993 <step1> <step2> ... <stepn>) ;; missing steps replaced by var
996 scm_m_do (SCM expr
, SCM env SCM_UNUSED
)
998 SCM variables
= SCM_EOL
;
999 SCM init_forms
= SCM_EOL
;
1000 SCM step_forms
= SCM_EOL
;
1007 const SCM cdr_expr
= SCM_CDR (expr
);
1008 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 0, s_bad_expression
, expr
);
1009 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 2, s_missing_expression
, expr
);
1011 /* Collect variables, init and step forms. */
1012 binding_idx
= SCM_CAR (cdr_expr
);
1013 ASSERT_SYNTAX_2 (scm_ilength (binding_idx
) >= 0,
1014 s_bad_bindings
, binding_idx
, expr
);
1015 for (; !SCM_NULLP (binding_idx
); binding_idx
= SCM_CDR (binding_idx
))
1017 const SCM binding
= SCM_CAR (binding_idx
);
1018 const long length
= scm_ilength (binding
);
1019 ASSERT_SYNTAX_2 (length
== 2 || length
== 3,
1020 s_bad_binding
, binding
, expr
);
1023 const SCM name
= SCM_CAR (binding
);
1024 const SCM init
= SCM_CADR (binding
);
1025 const SCM step
= (length
== 2) ? name
: SCM_CADDR (binding
);
1026 ASSERT_SYNTAX_2 (SCM_SYMBOLP (name
), s_bad_variable
, name
, expr
);
1027 ASSERT_SYNTAX_2 (SCM_FALSEP (scm_c_memq (name
, variables
)),
1028 s_duplicate_binding
, name
, expr
);
1030 variables
= scm_cons (name
, variables
);
1031 init_forms
= scm_cons (init
, init_forms
);
1032 step_forms
= scm_cons (step
, step_forms
);
1035 init_forms
= scm_reverse_x (init_forms
, SCM_UNDEFINED
);
1036 step_forms
= scm_reverse_x (step_forms
, SCM_UNDEFINED
);
1038 /* Memoize the test form and the exit sequence. */
1039 cddr_expr
= SCM_CDR (cdr_expr
);
1040 exit_clause
= SCM_CAR (cddr_expr
);
1041 ASSERT_SYNTAX_2 (scm_ilength (exit_clause
) >= 1,
1042 s_bad_exit_clause
, exit_clause
, expr
);
1044 commands
= SCM_CDR (cddr_expr
);
1045 tail
= scm_cons2 (exit_clause
, commands
, step_forms
);
1046 tail
= scm_cons2 (init_forms
, variables
, tail
);
1047 SCM_SETCAR (expr
, SCM_IM_DO
);
1048 SCM_SETCDR (expr
, tail
);
1053 SCM_SYNTAX (s_if
, "if", scm_i_makbimacro
, scm_m_if
);
1054 SCM_GLOBAL_SYMBOL (scm_sym_if
, s_if
);
1057 scm_m_if (SCM expr
, SCM env SCM_UNUSED
)
1059 const SCM cdr_expr
= SCM_CDR (expr
);
1060 const long length
= scm_ilength (cdr_expr
);
1061 ASSERT_SYNTAX (length
== 2 || length
== 3, s_expression
, expr
);
1062 SCM_SETCAR (expr
, SCM_IM_IF
);
1067 SCM_SYNTAX (s_lambda
, "lambda", scm_i_makbimacro
, scm_m_lambda
);
1068 SCM_GLOBAL_SYMBOL (scm_sym_lambda
, s_lambda
);
1070 /* A helper function for memoize_lambda to support checking for duplicate
1071 * formal arguments: Return true if OBJ is `eq?' to one of the elements of
1072 * LIST or to the cdr of the last cons. Therefore, LIST may have any of the
1073 * forms that a formal argument can have:
1074 * <rest>, (<arg1> ...), (<arg1> ... . <rest>) */
1076 c_improper_memq (SCM obj
, SCM list
)
1078 for (; SCM_CONSP (list
); list
= SCM_CDR (list
))
1080 if (SCM_EQ_P (SCM_CAR (list
), obj
))
1083 return SCM_EQ_P (list
, obj
);
1087 scm_m_lambda (SCM expr
, SCM env SCM_UNUSED
)
1096 const SCM cdr_expr
= SCM_CDR (expr
);
1097 const long length
= scm_ilength (cdr_expr
);
1098 ASSERT_SYNTAX (length
>= 0, s_bad_expression
, expr
);
1099 ASSERT_SYNTAX (length
>= 2, s_missing_expression
, expr
);
1101 /* Before iterating the list of formal arguments, make sure the formals
1102 * actually are given as either a symbol or a non-cyclic list. */
1103 formals
= SCM_CAR (cdr_expr
);
1104 if (SCM_CONSP (formals
))
1106 /* Dirk:FIXME:: We should check for a cyclic list of formals, and if
1107 * detected, report a 'Bad formals' error. */
1111 ASSERT_SYNTAX_2 (SCM_SYMBOLP (formals
) || SCM_NULLP (formals
),
1112 s_bad_formals
, formals
, expr
);
1115 /* Now iterate the list of formal arguments to check if all formals are
1116 * symbols, and that there are no duplicates. */
1117 formals_idx
= formals
;
1118 while (SCM_CONSP (formals_idx
))
1120 const SCM formal
= SCM_CAR (formals_idx
);
1121 const SCM next_idx
= SCM_CDR (formals_idx
);
1122 ASSERT_SYNTAX_2 (SCM_SYMBOLP (formal
), s_bad_formal
, formal
, expr
);
1123 ASSERT_SYNTAX_2 (!c_improper_memq (formal
, next_idx
),
1124 s_duplicate_formal
, formal
, expr
);
1125 formals_idx
= next_idx
;
1127 ASSERT_SYNTAX_2 (SCM_NULLP (formals_idx
) || SCM_SYMBOLP (formals_idx
),
1128 s_bad_formal
, formals_idx
, expr
);
1130 /* Memoize the body. Keep a potential documentation string. */
1131 /* Dirk:FIXME:: We should probably extract the documentation string to
1132 * some external database. Otherwise it will slow down execution, since
1133 * the documentation string will have to be skipped with every execution
1134 * of the closure. */
1135 cddr_expr
= SCM_CDR (cdr_expr
);
1136 documentation
= (length
>= 3 && SCM_STRINGP (SCM_CAR (cddr_expr
)));
1137 body
= documentation
? SCM_CDR (cddr_expr
) : cddr_expr
;
1138 new_body
= scm_m_body (SCM_IM_LAMBDA
, body
);
1140 SCM_SETCAR (expr
, SCM_IM_LAMBDA
);
1142 SCM_SETCDR (cddr_expr
, new_body
);
1144 SCM_SETCDR (cdr_expr
, new_body
);
1149 /* Check if the format of the bindings is ((<symbol> <init-form>) ...). */
1151 check_bindings (const SCM bindings
, const SCM expr
)
1155 ASSERT_SYNTAX_2 (scm_ilength (bindings
) >= 0,
1156 s_bad_bindings
, bindings
, expr
);
1158 binding_idx
= bindings
;
1159 for (; !SCM_NULLP (binding_idx
); binding_idx
= SCM_CDR (binding_idx
))
1161 SCM name
; /* const */
1163 const SCM binding
= SCM_CAR (binding_idx
);
1164 ASSERT_SYNTAX_2 (scm_ilength (binding
) == 2,
1165 s_bad_binding
, binding
, expr
);
1167 name
= SCM_CAR (binding
);
1168 ASSERT_SYNTAX_2 (SCM_SYMBOLP (name
), s_bad_variable
, name
, expr
);
1173 /* The bindings, which must have the format ((v1 i1) (v2 i2) ... (vn in)), are
1174 * transformed to the lists (vn ... v2 v1) and (i1 i2 ... in). That is, the
1175 * variables are returned in a list with their order reversed, and the init
1176 * forms are returned in a list in the same order as they are given in the
1177 * bindings. If a duplicate variable name is detected, an error is
1180 transform_bindings (
1181 const SCM bindings
, const SCM expr
,
1182 SCM
*const rvarptr
, SCM
*const initptr
)
1184 SCM rvariables
= SCM_EOL
;
1185 SCM rinits
= SCM_EOL
;
1186 SCM binding_idx
= bindings
;
1187 for (; !SCM_NULLP (binding_idx
); binding_idx
= SCM_CDR (binding_idx
))
1189 const SCM binding
= SCM_CAR (binding_idx
);
1190 const SCM cdr_binding
= SCM_CDR (binding
);
1191 const SCM name
= SCM_CAR (binding
);
1192 ASSERT_SYNTAX_2 (SCM_FALSEP (scm_c_memq (name
, rvariables
)),
1193 s_duplicate_binding
, name
, expr
);
1194 rvariables
= scm_cons (name
, rvariables
);
1195 rinits
= scm_cons (SCM_CAR (cdr_binding
), rinits
);
1197 *rvarptr
= rvariables
;
1198 *initptr
= scm_reverse_x (rinits
, SCM_UNDEFINED
);
1202 SCM_SYNTAX(s_let
, "let", scm_i_makbimacro
, scm_m_let
);
1203 SCM_GLOBAL_SYMBOL(scm_sym_let
, s_let
);
1205 /* This function is a helper function for memoize_let. It transforms
1206 * (let name ((var init) ...) body ...) into
1207 * ((letrec ((name (lambda (var ...) body ...))) name) init ...)
1208 * and memoizes the expression. It is assumed that the caller has checked
1209 * that name is a symbol and that there are bindings and a body. */
1211 memoize_named_let (const SCM expr
, const SCM env SCM_UNUSED
)
1217 const SCM cdr_expr
= SCM_CDR (expr
);
1218 const SCM name
= SCM_CAR (cdr_expr
);
1219 const SCM cddr_expr
= SCM_CDR (cdr_expr
);
1220 const SCM bindings
= SCM_CAR (cddr_expr
);
1221 check_bindings (bindings
, expr
);
1223 transform_bindings (bindings
, expr
, &rvariables
, &inits
);
1224 variables
= scm_reverse_x (rvariables
, SCM_UNDEFINED
);
1227 const SCM let_body
= SCM_CDR (cddr_expr
);
1228 const SCM lambda_body
= scm_m_body (SCM_IM_LET
, let_body
);
1229 const SCM lambda_tail
= scm_cons (variables
, lambda_body
);
1230 const SCM lambda_form
= scm_cons_source (expr
, scm_sym_lambda
, lambda_tail
);
1232 const SCM rvar
= scm_list_1 (name
);
1233 const SCM init
= scm_list_1 (lambda_form
);
1234 const SCM body
= scm_m_body (SCM_IM_LET
, scm_list_1 (name
));
1235 const SCM letrec_tail
= scm_cons (rvar
, scm_cons (init
, body
));
1236 const SCM letrec_form
= scm_cons_source (expr
, SCM_IM_LETREC
, letrec_tail
);
1237 return scm_cons_source (expr
, letrec_form
, inits
);
1241 /* (let ((v1 i1) (v2 i2) ...) body) with variables v1 .. vn and initializers
1242 * i1 .. in is transformed to (#@let (vn ... v2 v1) (i1 i2 ...) body). */
1244 scm_m_let (SCM expr
, SCM env
)
1248 const SCM cdr_expr
= SCM_CDR (expr
);
1249 const long length
= scm_ilength (cdr_expr
);
1250 ASSERT_SYNTAX (length
>= 0, s_bad_expression
, expr
);
1251 ASSERT_SYNTAX (length
>= 2, s_missing_expression
, expr
);
1253 bindings
= SCM_CAR (cdr_expr
);
1254 if (SCM_SYMBOLP (bindings
))
1256 ASSERT_SYNTAX (length
>= 3, s_missing_expression
, expr
);
1257 return memoize_named_let (expr
, env
);
1260 check_bindings (bindings
, expr
);
1261 if (SCM_NULLP (bindings
) || SCM_NULLP (SCM_CDR (bindings
)))
1263 /* Special case: no bindings or single binding => let* is faster. */
1264 const SCM body
= scm_m_body (SCM_IM_LET
, SCM_CDR (cdr_expr
));
1265 return scm_m_letstar (scm_cons2 (SCM_CAR (expr
), bindings
, body
), env
);
1272 transform_bindings (bindings
, expr
, &rvariables
, &inits
);
1275 const SCM new_body
= scm_m_body (SCM_IM_LET
, SCM_CDR (cdr_expr
));
1276 const SCM new_tail
= scm_cons2 (rvariables
, inits
, new_body
);
1277 SCM_SETCAR (expr
, SCM_IM_LET
);
1278 SCM_SETCDR (expr
, new_tail
);
1285 SCM_SYNTAX (s_letstar
, "let*", scm_i_makbimacro
, scm_m_letstar
);
1286 SCM_GLOBAL_SYMBOL (scm_sym_letstar
, s_letstar
);
1288 /* (let* ((v1 i1) (v2 i2) ...) body) with variables v1 .. vn and initializers
1289 * i1 .. in is transformed into the form (#@let* (v1 i1 v2 i2 ...) body). */
1291 scm_m_letstar (SCM expr
, SCM env SCM_UNUSED
)
1294 SCM new_bindings
= SCM_EOL
;
1297 const SCM cdr_expr
= SCM_CDR (expr
);
1298 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 0, s_bad_expression
, expr
);
1299 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 2, s_missing_expression
, expr
);
1301 binding_idx
= SCM_CAR (cdr_expr
);
1302 check_bindings (binding_idx
, expr
);
1304 for (; !SCM_NULLP (binding_idx
); binding_idx
= SCM_CDR (binding_idx
))
1306 const SCM binding
= SCM_CAR (binding_idx
);
1307 const SCM name
= SCM_CAR (binding
);
1308 const SCM init
= SCM_CADR (binding
);
1309 new_bindings
= scm_cons2 (init
, name
, new_bindings
);
1311 new_bindings
= scm_reverse_x (new_bindings
, SCM_UNDEFINED
);
1313 new_body
= scm_m_body (SCM_IM_LETSTAR
, SCM_CDR (cdr_expr
));
1314 return scm_cons2 (SCM_IM_LETSTAR
, new_bindings
, new_body
);
1318 SCM_SYNTAX(s_letrec
, "letrec", scm_i_makbimacro
, scm_m_letrec
);
1319 SCM_GLOBAL_SYMBOL(scm_sym_letrec
, s_letrec
);
1322 scm_m_letrec (SCM expr
, SCM env
)
1326 const SCM cdr_expr
= SCM_CDR (expr
);
1327 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 0, s_bad_expression
, expr
);
1328 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 2, s_missing_expression
, expr
);
1330 bindings
= SCM_CAR (cdr_expr
);
1331 if (SCM_NULLP (bindings
))
1333 /* no bindings, let* is executed faster */
1334 SCM body
= scm_m_body (SCM_IM_LETREC
, SCM_CDR (cdr_expr
));
1335 return scm_m_letstar (scm_cons2 (SCM_CAR (expr
), SCM_EOL
, body
), env
);
1343 check_bindings (bindings
, expr
);
1344 transform_bindings (bindings
, expr
, &rvariables
, &inits
);
1345 new_body
= scm_m_body (SCM_IM_LETREC
, SCM_CDR (cdr_expr
));
1346 return scm_cons2 (SCM_IM_LETREC
, rvariables
, scm_cons (inits
, new_body
));
1351 SCM_SYNTAX (s_or
, "or", scm_i_makbimacro
, scm_m_or
);
1352 SCM_GLOBAL_SYMBOL (scm_sym_or
, s_or
);
1355 scm_m_or (SCM expr
, SCM env SCM_UNUSED
)
1357 const SCM cdr_expr
= SCM_CDR (expr
);
1358 const long length
= scm_ilength (cdr_expr
);
1360 ASSERT_SYNTAX (length
>= 0, s_bad_expression
, expr
);
1364 /* Special case: (or) is replaced by #f. */
1369 SCM_SETCAR (expr
, SCM_IM_OR
);
1375 SCM_SYNTAX (s_quasiquote
, "quasiquote", scm_makacro
, scm_m_quasiquote
);
1376 SCM_GLOBAL_SYMBOL (scm_sym_quasiquote
, s_quasiquote
);
1378 /* Internal function to handle a quasiquotation: 'form' is the parameter in
1379 * the call (quasiquotation form), 'env' is the environment where unquoted
1380 * expressions will be evaluated, and 'depth' is the current quasiquotation
1381 * nesting level and is known to be greater than zero. */
1383 iqq (SCM form
, SCM env
, unsigned long int depth
)
1385 if (SCM_CONSP (form
))
1387 const SCM tmp
= SCM_CAR (form
);
1388 if (SCM_EQ_P (tmp
, scm_sym_quasiquote
))
1390 const SCM args
= SCM_CDR (form
);
1391 ASSERT_SYNTAX (scm_ilength (args
) == 1, s_expression
, form
);
1392 return scm_list_2 (tmp
, iqq (SCM_CAR (args
), env
, depth
+ 1));
1394 else if (SCM_EQ_P (tmp
, scm_sym_unquote
))
1396 const SCM args
= SCM_CDR (form
);
1397 ASSERT_SYNTAX (scm_ilength (args
) == 1, s_expression
, form
);
1399 return scm_eval_car (args
, env
);
1401 return scm_list_2 (tmp
, iqq (SCM_CAR (args
), env
, depth
- 1));
1403 else if (SCM_CONSP (tmp
)
1404 && SCM_EQ_P (SCM_CAR (tmp
), scm_sym_uq_splicing
))
1406 const SCM args
= SCM_CDR (tmp
);
1407 ASSERT_SYNTAX (scm_ilength (args
) == 1, s_expression
, form
);
1410 const SCM list
= scm_eval_car (args
, env
);
1411 const SCM rest
= SCM_CDR (form
);
1412 ASSERT_SYNTAX_2 (scm_ilength (list
) >= 0,
1413 s_splicing
, list
, form
);
1414 return scm_append (scm_list_2 (list
, iqq (rest
, env
, depth
)));
1417 return scm_cons (iqq (SCM_CAR (form
), env
, depth
- 1),
1418 iqq (SCM_CDR (form
), env
, depth
));
1421 return scm_cons (iqq (SCM_CAR (form
), env
, depth
),
1422 iqq (SCM_CDR (form
), env
, depth
));
1424 else if (SCM_VECTORP (form
))
1426 size_t i
= SCM_VECTOR_LENGTH (form
);
1427 SCM
const *const data
= SCM_VELTS (form
);
1430 tmp
= scm_cons (data
[--i
], tmp
);
1431 scm_remember_upto_here_1 (form
);
1432 return scm_vector (iqq (tmp
, env
, depth
));
1439 scm_m_quasiquote (SCM expr
, SCM env
)
1441 const SCM cdr_expr
= SCM_CDR (expr
);
1442 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 0, s_bad_expression
, expr
);
1443 ASSERT_SYNTAX (scm_ilength (cdr_expr
) == 1, s_expression
, expr
);
1444 return iqq (SCM_CAR (cdr_expr
), env
, 1);
1448 SCM_SYNTAX (s_quote
, "quote", scm_i_makbimacro
, scm_m_quote
);
1449 SCM_GLOBAL_SYMBOL (scm_sym_quote
, s_quote
);
1452 scm_m_quote (SCM expr
, SCM env SCM_UNUSED
)
1456 const SCM cdr_expr
= SCM_CDR (expr
);
1457 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 0, s_bad_expression
, expr
);
1458 ASSERT_SYNTAX (scm_ilength (cdr_expr
) == 1, s_expression
, expr
);
1459 quotee
= SCM_CAR (cdr_expr
);
1460 if (SCM_IMP (quotee
) && !SCM_NULLP (quotee
))
1462 else if (SCM_VECTORP (quotee
))
1465 /* The following optimization would be possible if all variable references
1466 * were resolved during memoization: */
1467 else if (SCM_SYMBOLP (quotee
))
1470 SCM_SETCAR (expr
, SCM_IM_QUOTE
);
1475 /* Will go into the RnRS module when Guile is factorized.
1476 SCM_SYNTAX (s_set_x, "set!", scm_i_makbimacro, scm_m_set_x); */
1477 static const char s_set_x
[] = "set!";
1478 SCM_GLOBAL_SYMBOL (scm_sym_set_x
, s_set_x
);
1481 scm_m_set_x (SCM expr
, SCM env SCM_UNUSED
)
1485 const SCM cdr_expr
= SCM_CDR (expr
);
1486 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 0, s_bad_expression
, expr
);
1487 ASSERT_SYNTAX (scm_ilength (cdr_expr
) == 2, s_expression
, expr
);
1488 variable
= SCM_CAR (cdr_expr
);
1489 ASSERT_SYNTAX_2 (SCM_SYMBOLP (variable
), s_bad_variable
, variable
, expr
);
1491 SCM_SETCAR (expr
, SCM_IM_SET_X
);
1496 /* Start of the memoizers for non-R5RS builtin macros. */
1499 SCM_SYNTAX (s_atapply
, "@apply", scm_i_makbimacro
, scm_m_apply
);
1500 SCM_GLOBAL_SYMBOL (scm_sym_atapply
, s_atapply
);
1501 SCM_GLOBAL_SYMBOL (scm_sym_apply
, s_atapply
+ 1);
1504 scm_m_apply (SCM expr
, SCM env SCM_UNUSED
)
1506 const SCM cdr_expr
= SCM_CDR (expr
);
1507 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 0, s_bad_expression
, expr
);
1508 ASSERT_SYNTAX (scm_ilength (cdr_expr
) == 2, s_missing_expression
, expr
);
1510 SCM_SETCAR (expr
, SCM_IM_APPLY
);
1515 SCM_SYNTAX (s_atbind
, "@bind", scm_i_makbimacro
, scm_m_atbind
);
1517 /* FIXME: The following explanation should go into the documentation: */
1518 /* (@bind ((var init) ...) body ...) will assign the values of the `init's to
1519 * the global variables named by `var's (symbols, not evaluated), creating
1520 * them if they don't exist, executes body, and then restores the previous
1521 * values of the `var's. Additionally, whenever control leaves body, the
1522 * values of the `var's are saved and restored when control returns. It is an
1523 * error when a symbol appears more than once among the `var's. All `init's
1524 * are evaluated before any `var' is set.
1526 * Think of this as `let' for dynamic scope.
1529 /* (@bind ((var1 exp1) ... (varn expn)) body ...) is memoized into
1530 * (#@bind ((varn ... var1) . (exp1 ... expn)) body ...).
1532 * FIXME - also implement `@bind*'.
1535 scm_m_atbind (SCM expr
, SCM env
)
1542 const SCM top_level
= scm_env_top_level (env
);
1544 const SCM cdr_expr
= SCM_CDR (expr
);
1545 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 0, s_bad_expression
, expr
);
1546 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 2, s_missing_expression
, expr
);
1547 bindings
= SCM_CAR (cdr_expr
);
1548 check_bindings (bindings
, expr
);
1549 transform_bindings (bindings
, expr
, &rvariables
, &inits
);
1551 for (variable_idx
= rvariables
;
1552 !SCM_NULLP (variable_idx
);
1553 variable_idx
= SCM_CDR (variable_idx
))
1555 /* The first call to scm_sym2var will look beyond the current module,
1556 * while the second call wont. */
1557 const SCM variable
= SCM_CAR (variable_idx
);
1558 SCM new_variable
= scm_sym2var (variable
, top_level
, SCM_BOOL_F
);
1559 if (SCM_FALSEP (new_variable
))
1560 new_variable
= scm_sym2var (variable
, top_level
, SCM_BOOL_T
);
1561 SCM_SETCAR (variable_idx
, new_variable
);
1564 SCM_SETCAR (expr
, SCM_IM_BIND
);
1565 SCM_SETCAR (cdr_expr
, scm_cons (rvariables
, inits
));
1570 SCM_SYNTAX(s_atcall_cc
, "@call-with-current-continuation", scm_i_makbimacro
, scm_m_cont
);
1571 SCM_GLOBAL_SYMBOL(scm_sym_atcall_cc
, s_atcall_cc
);
1574 scm_m_cont (SCM expr
, SCM env SCM_UNUSED
)
1576 const SCM cdr_expr
= SCM_CDR (expr
);
1577 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 0, s_bad_expression
, expr
);
1578 ASSERT_SYNTAX (scm_ilength (cdr_expr
) == 1, s_expression
, expr
);
1580 SCM_SETCAR (expr
, SCM_IM_CONT
);
1585 SCM_SYNTAX (s_at_call_with_values
, "@call-with-values", scm_i_makbimacro
, scm_m_at_call_with_values
);
1586 SCM_GLOBAL_SYMBOL(scm_sym_at_call_with_values
, s_at_call_with_values
);
1589 scm_m_at_call_with_values (SCM expr
, SCM env SCM_UNUSED
)
1591 const SCM cdr_expr
= SCM_CDR (expr
);
1592 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 0, s_bad_expression
, expr
);
1593 ASSERT_SYNTAX (scm_ilength (cdr_expr
) == 2, s_expression
, expr
);
1595 SCM_SETCAR (expr
, SCM_IM_CALL_WITH_VALUES
);
1600 SCM_SYNTAX (s_future
, "future", scm_i_makbimacro
, scm_m_future
);
1601 SCM_GLOBAL_SYMBOL (scm_sym_future
, s_future
);
1603 /* Like promises, futures are implemented as closures with an empty
1604 * parameter list. Thus, (future <expression>) is transformed into
1605 * (#@future '() <expression>), where the empty list represents the
1606 * empty parameter list. This representation allows for easy creation
1607 * of the closure during evaluation. */
1609 scm_m_future (SCM expr
, SCM env
)
1611 const SCM new_expr
= memoize_as_thunk_prototype (expr
, env
);
1612 SCM_SETCAR (new_expr
, SCM_IM_FUTURE
);
1617 SCM_SYNTAX (s_gset_x
, "set!", scm_i_makbimacro
, scm_m_generalized_set_x
);
1618 SCM_SYMBOL (scm_sym_setter
, "setter");
1621 scm_m_generalized_set_x (SCM expr
, SCM env SCM_UNUSED
)
1625 const SCM cdr_expr
= SCM_CDR (expr
);
1626 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 0, s_bad_expression
, expr
);
1627 ASSERT_SYNTAX (scm_ilength (cdr_expr
) == 2, s_expression
, expr
);
1629 target
= SCM_CAR (cdr_expr
);
1630 if (!SCM_CONSP (target
))
1633 return scm_m_set_x (expr
, env
);
1637 /* (set! (foo bar ...) baz) becomes ((setter foo) bar ... baz) */
1639 const SCM setter_proc_tail
= scm_list_1 (SCM_CAR (target
));
1640 const SCM setter_proc
= scm_cons_source (expr
, scm_sym_setter
, setter_proc_tail
);
1642 const SCM cddr_expr
= SCM_CDR (cdr_expr
);
1643 const SCM setter_args
= scm_append_x (scm_list_2 (SCM_CDR (target
), cddr_expr
));
1645 SCM_SETCAR (expr
, setter_proc
);
1646 SCM_SETCDR (expr
, setter_args
);
1652 /* @slot-ref is bound privately in the (oop goops) module from goops.c. As
1653 * soon as the module system allows us to more freely create bindings in
1654 * arbitrary modules during the startup phase, the code from goops.c should be
1657 scm_m_atslot_ref (SCM expr
, SCM env SCM_UNUSED
)
1661 const SCM cdr_expr
= SCM_CDR (expr
);
1662 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 0, s_bad_expression
, expr
);
1663 ASSERT_SYNTAX (scm_ilength (cdr_expr
) == 2, s_expression
, expr
);
1664 slot_nr
= SCM_CADR (cdr_expr
);
1665 ASSERT_SYNTAX_2 (SCM_INUMP (slot_nr
), s_bad_slot_number
, slot_nr
, expr
);
1667 SCM_SETCAR (expr
, SCM_IM_SLOT_REF
);
1672 /* @slot-set! is bound privately in the (oop goops) module from goops.c. As
1673 * soon as the module system allows us to more freely create bindings in
1674 * arbitrary modules during the startup phase, the code from goops.c should be
1677 scm_m_atslot_set_x (SCM expr
, SCM env SCM_UNUSED
)
1681 const SCM cdr_expr
= SCM_CDR (expr
);
1682 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 0, s_bad_expression
, expr
);
1683 ASSERT_SYNTAX (scm_ilength (cdr_expr
) == 3, s_expression
, expr
);
1684 slot_nr
= SCM_CADR (cdr_expr
);
1685 ASSERT_SYNTAX_2 (SCM_INUMP (slot_nr
), s_bad_slot_number
, slot_nr
, expr
);
1687 SCM_SETCAR (expr
, SCM_IM_SLOT_SET_X
);
1692 #if SCM_ENABLE_ELISP
1694 static const char s_defun
[] = "Symbol's function definition is void";
1696 SCM_SYNTAX (s_nil_cond
, "nil-cond", scm_i_makbimacro
, scm_m_nil_cond
);
1698 /* nil-cond expressions have the form
1699 * (nil-cond COND VAL COND VAL ... ELSEVAL) */
1701 scm_m_nil_cond (SCM expr
, SCM env SCM_UNUSED
)
1703 const long length
= scm_ilength (SCM_CDR (expr
));
1704 ASSERT_SYNTAX (length
>= 0, s_bad_expression
, expr
);
1705 ASSERT_SYNTAX (length
>= 1 && (length
% 2) == 1, s_expression
, expr
);
1707 SCM_SETCAR (expr
, SCM_IM_NIL_COND
);
1712 SCM_SYNTAX (s_atfop
, "@fop", scm_i_makbimacro
, scm_m_atfop
);
1714 /* The @fop-macro handles procedure and macro applications for elisp. The
1715 * input expression must have the form
1716 * (@fop <var> (transformer-macro <expr> ...))
1717 * where <var> must be a symbol. The expression is transformed into the
1718 * memoized form of either
1719 * (apply <un-aliased var> (transformer-macro <expr> ...))
1720 * if the value of var (across all aliasing) is not a macro, or
1721 * (<un-aliased var> <expr> ...)
1722 * if var is a macro. */
1724 scm_m_atfop (SCM expr
, SCM env SCM_UNUSED
)
1729 const SCM cdr_expr
= SCM_CDR (expr
);
1730 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 0, s_bad_expression
, expr
);
1731 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 1, s_missing_expression
, expr
);
1733 symbol
= SCM_CAR (cdr_expr
);
1734 ASSERT_SYNTAX_2 (SCM_SYMBOLP (symbol
), s_bad_variable
, symbol
, expr
);
1736 location
= scm_symbol_fref (symbol
);
1737 ASSERT_SYNTAX_2 (SCM_VARIABLEP (location
), s_defun
, symbol
, expr
);
1739 /* The elisp function `defalias' allows to define aliases for symbols. To
1740 * look up such definitions, the chain of symbol definitions has to be
1741 * followed up to the terminal symbol. */
1742 while (SCM_SYMBOLP (SCM_VARIABLE_REF (location
)))
1744 const SCM alias
= SCM_VARIABLE_REF (location
);
1745 location
= scm_symbol_fref (alias
);
1746 ASSERT_SYNTAX_2 (SCM_VARIABLEP (location
), s_defun
, symbol
, expr
);
1749 /* Memoize the value location belonging to the terminal symbol. */
1750 SCM_SETCAR (cdr_expr
, location
);
1752 if (!SCM_MACROP (SCM_VARIABLE_REF (location
)))
1754 /* Since the location does not contain a macro, the form is a procedure
1755 * application. Replace `@fop' by `@apply' and transform the expression
1756 * including the `transformer-macro'. */
1757 SCM_SETCAR (expr
, SCM_IM_APPLY
);
1762 /* Since the location contains a macro, the arguments should not be
1763 * transformed, so the `transformer-macro' is cut out. The resulting
1764 * expression starts with the memoized variable, that is at the cdr of
1765 * the input expression. */
1766 SCM_SETCDR (cdr_expr
, SCM_CDADR (cdr_expr
));
1771 #endif /* SCM_ENABLE_ELISP */
1774 /* Start of the memoizers for deprecated macros. */
1777 #if (SCM_ENABLE_DEPRECATED == 1)
1779 SCM_SYNTAX (s_undefine
, "undefine", scm_makacro
, scm_m_undefine
);
1782 scm_m_undefine (SCM expr
, SCM env
)
1787 const SCM cdr_expr
= SCM_CDR (expr
);
1788 ASSERT_SYNTAX (SCM_TOP_LEVEL (env
), "Bad undefine placement in", expr
);
1789 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 0, s_bad_expression
, expr
);
1790 ASSERT_SYNTAX (scm_ilength (cdr_expr
) == 1, s_expression
, expr
);
1792 variable
= SCM_CAR (cdr_expr
);
1793 ASSERT_SYNTAX_2 (SCM_SYMBOLP (variable
), s_bad_variable
, variable
, expr
);
1794 location
= scm_sym2var (variable
, scm_env_top_level (env
), SCM_BOOL_F
);
1795 ASSERT_SYNTAX_2 (!SCM_FALSEP (location
)
1796 && !SCM_UNBNDP (SCM_VARIABLE_REF (location
)),
1797 "variable already unbound ", variable
, expr
);
1798 SCM_VARIABLE_SET (location
, SCM_UNDEFINED
);
1799 return SCM_UNSPECIFIED
;
1806 scm_m_expand_body (SCM xorig
, SCM env
)
1808 SCM x
= SCM_CDR (xorig
), defs
= SCM_EOL
;
1809 char *what
= SCM_ISYMCHARS (SCM_CAR (xorig
)) + 2;
1811 while (SCM_NIMP (x
))
1813 SCM form
= SCM_CAR (x
);
1814 if (!SCM_CONSP (form
))
1816 if (!SCM_SYMBOLP (SCM_CAR (form
)))
1819 form
= scm_macroexp (scm_cons_source (form
,
1824 if (SCM_EQ_P (SCM_IM_DEFINE
, SCM_CAR (form
)))
1826 defs
= scm_cons (SCM_CDR (form
), defs
);
1829 else if (!SCM_IMP (defs
))
1833 else if (SCM_EQ_P (SCM_IM_BEGIN
, SCM_CAR (form
)))
1835 x
= scm_append (scm_list_2 (SCM_CDR (form
), SCM_CDR (x
)));
1839 x
= scm_cons (form
, SCM_CDR (x
));
1844 if (!SCM_NULLP (defs
))
1846 SCM rvars
, inits
, body
, letrec
;
1847 check_bindings (defs
, xorig
);
1848 transform_bindings (defs
, xorig
, &rvars
, &inits
);
1849 body
= scm_m_body (SCM_IM_DEFINE
, x
);
1850 letrec
= scm_cons2 (SCM_IM_LETREC
, rvars
, scm_cons (inits
, body
));
1851 SCM_SETCAR (xorig
, letrec
);
1852 SCM_SETCDR (xorig
, SCM_EOL
);
1856 SCM_ASSYNT (SCM_CONSP (x
), s_body
, what
);
1857 SCM_SETCAR (xorig
, SCM_CAR (x
));
1858 SCM_SETCDR (xorig
, SCM_CDR (x
));
1866 scm_macroexp (SCM x
, SCM env
)
1868 SCM res
, proc
, orig_sym
;
1870 /* Don't bother to produce error messages here. We get them when we
1871 eventually execute the code for real. */
1874 orig_sym
= SCM_CAR (x
);
1875 if (!SCM_SYMBOLP (orig_sym
))
1879 SCM
*proc_ptr
= scm_lookupcar1 (x
, env
, 0);
1880 if (proc_ptr
== NULL
)
1882 /* We have lost the race. */
1888 /* Only handle memoizing macros. `Acros' and `macros' are really
1889 special forms and should not be evaluated here. */
1891 if (!SCM_MACROP (proc
)
1892 || (SCM_MACRO_TYPE (proc
) != 2 && !SCM_BUILTIN_MACRO_P (proc
)))
1895 SCM_SETCAR (x
, orig_sym
); /* Undo memoizing effect of lookupcar */
1896 res
= scm_call_2 (SCM_MACRO_CODE (proc
), x
, env
);
1898 if (scm_ilength (res
) <= 0)
1899 res
= scm_list_2 (SCM_IM_BEGIN
, res
);
1902 SCM_SETCAR (x
, SCM_CAR (res
));
1903 SCM_SETCDR (x
, SCM_CDR (res
));
1909 #define SCM_BIT7(x) (127 & SCM_UNPACK (x))
1911 /* A function object to implement "apply" for non-closure functions. */
1913 /* An endless list consisting of #<undefined> objects: */
1914 static SCM undefineds
;
1917 /* scm_unmemocopy takes a memoized expression together with its
1918 * environment and rewrites it to its original form. Thus, it is the
1919 * inversion of the rewrite rules above. The procedure is not
1920 * optimized for speed. It's used in scm_iprin1 when printing the
1921 * code of a closure, in scm_procedure_source, in display_frame when
1922 * generating the source for a stackframe in a backtrace, and in
1923 * display_expression.
1925 * Unmemoizing is not a reliable process. You cannot in general
1926 * expect to get the original source back.
1928 * However, GOOPS currently relies on this for method compilation.
1929 * This ought to change.
1933 build_binding_list (SCM rnames
, SCM rinits
)
1935 SCM bindings
= SCM_EOL
;
1936 while (!SCM_NULLP (rnames
))
1938 SCM binding
= scm_list_2 (SCM_CAR (rnames
), SCM_CAR (rinits
));
1939 bindings
= scm_cons (binding
, bindings
);
1940 rnames
= SCM_CDR (rnames
);
1941 rinits
= SCM_CDR (rinits
);
1947 SCM_SYMBOL (sym_three_question_marks
, "???");
1949 #define unmemocar scm_unmemocar
1952 scm_unmemocar (SCM form
, SCM env
)
1954 if (!SCM_CONSP (form
))
1958 SCM c
= SCM_CAR (form
);
1959 if (SCM_VARIABLEP (c
))
1961 SCM sym
= scm_module_reverse_lookup (scm_env_module (env
), c
);
1962 if (SCM_FALSEP (sym
))
1963 sym
= sym_three_question_marks
;
1964 SCM_SETCAR (form
, sym
);
1966 else if (SCM_ILOCP (c
))
1968 unsigned long int ir
;
1970 for (ir
= SCM_IFRAME (c
); ir
!= 0; --ir
)
1971 env
= SCM_CDR (env
);
1972 env
= SCM_CAAR (env
);
1973 for (ir
= SCM_IDIST (c
); ir
!= 0; --ir
)
1974 env
= SCM_CDR (env
);
1975 SCM_SETCAR (form
, SCM_ICDRP (c
) ? env
: SCM_CAR (env
));
1982 unmemocopy (SCM x
, SCM env
)
1987 if (SCM_VECTORP (x
))
1989 return scm_list_2 (scm_sym_quote
, x
);
1991 else if (!SCM_CONSP (x
))
1994 p
= scm_whash_lookup (scm_source_whash
, x
);
1995 switch (SCM_ITAG7 (SCM_CAR (x
)))
1997 case SCM_BIT7 (SCM_IM_AND
):
1998 ls
= z
= scm_cons (scm_sym_and
, SCM_UNSPECIFIED
);
2000 case SCM_BIT7 (SCM_IM_BEGIN
):
2001 ls
= z
= scm_cons (scm_sym_begin
, SCM_UNSPECIFIED
);
2003 case SCM_BIT7 (SCM_IM_CASE
):
2004 ls
= z
= scm_cons (scm_sym_case
, SCM_UNSPECIFIED
);
2006 case SCM_BIT7 (SCM_IM_COND
):
2007 ls
= z
= scm_cons (scm_sym_cond
, SCM_UNSPECIFIED
);
2009 case SCM_BIT7 (SCM_IM_DO
):
2011 /* format: (#@do (i1 ... ik) (nk nk-1 ...) (test) (body) s1 ... sk),
2012 * where ix is an initializer for a local variable, nx is the name of
2013 * the local variable, test is the test clause of the do loop, body is
2014 * the body of the do loop and sx are the step clauses for the local
2016 SCM names
, inits
, test
, memoized_body
, steps
, bindings
;
2019 inits
= scm_reverse (unmemocopy (SCM_CAR (x
), env
));
2021 names
= SCM_CAR (x
);
2022 env
= SCM_EXTEND_ENV (names
, SCM_EOL
, env
);
2024 test
= unmemocopy (SCM_CAR (x
), env
);
2026 memoized_body
= SCM_CAR (x
);
2028 steps
= scm_reverse (unmemocopy (x
, env
));
2030 /* build transformed binding list */
2032 while (!SCM_NULLP (names
))
2034 SCM name
= SCM_CAR (names
);
2035 SCM init
= SCM_CAR (inits
);
2036 SCM step
= SCM_CAR (steps
);
2037 step
= SCM_EQ_P (step
, name
) ? SCM_EOL
: scm_list_1 (step
);
2039 bindings
= scm_cons (scm_cons2 (name
, init
, step
), bindings
);
2041 names
= SCM_CDR (names
);
2042 inits
= SCM_CDR (inits
);
2043 steps
= SCM_CDR (steps
);
2045 z
= scm_cons (test
, SCM_UNSPECIFIED
);
2046 ls
= scm_cons2 (scm_sym_do
, bindings
, z
);
2048 x
= scm_cons (SCM_BOOL_F
, memoized_body
);
2051 case SCM_BIT7 (SCM_IM_IF
):
2052 ls
= z
= scm_cons (scm_sym_if
, SCM_UNSPECIFIED
);
2054 case SCM_BIT7 (SCM_IM_LET
):
2056 /* format: (#@let (nk nk-1 ...) (i1 ... ik) b1 ...),
2057 * where nx is the name of a local variable, ix is an initializer for
2058 * the local variable and by are the body clauses. */
2059 SCM rnames
, rinits
, bindings
;
2062 rnames
= SCM_CAR (x
);
2064 rinits
= scm_reverse (unmemocopy (SCM_CAR (x
), env
));
2065 env
= SCM_EXTEND_ENV (rnames
, SCM_EOL
, env
);
2067 bindings
= build_binding_list (rnames
, rinits
);
2068 z
= scm_cons (bindings
, SCM_UNSPECIFIED
);
2069 ls
= scm_cons (scm_sym_let
, z
);
2072 case SCM_BIT7 (SCM_IM_LETREC
):
2074 /* format: (#@letrec (vn ... v2 v1) (i1 i2 ... in) b1 ...),
2075 * where vx is the name of a local variable, ix is an initializer for
2076 * the local variable and by are the body clauses. */
2077 SCM rnames
, rinits
, bindings
;
2080 rnames
= SCM_CAR (x
);
2081 env
= SCM_EXTEND_ENV (rnames
, SCM_EOL
, env
);
2083 rinits
= scm_reverse (unmemocopy (SCM_CAR (x
), env
));
2085 bindings
= build_binding_list (rnames
, rinits
);
2086 z
= scm_cons (bindings
, SCM_UNSPECIFIED
);
2087 ls
= scm_cons (scm_sym_letrec
, z
);
2090 case SCM_BIT7 (SCM_IM_LETSTAR
):
2098 env
= SCM_EXTEND_ENV (SCM_EOL
, SCM_EOL
, env
);
2101 y
= z
= scm_acons (SCM_CAR (b
),
2103 scm_cons (unmemocopy (SCM_CADR (b
), env
), SCM_EOL
), env
),
2105 env
= SCM_EXTEND_ENV (SCM_CAR (b
), SCM_BOOL_F
, env
);
2109 SCM_SETCDR (y
, SCM_EOL
);
2110 z
= scm_cons (y
, SCM_UNSPECIFIED
);
2111 ls
= scm_cons (scm_sym_let
, z
);
2116 SCM_SETCDR (z
, scm_acons (SCM_CAR (b
),
2118 scm_list_1 (unmemocopy (SCM_CADR (b
), env
)), env
),
2121 env
= SCM_EXTEND_ENV (SCM_CAR (b
), SCM_BOOL_F
, env
);
2124 while (SCM_NIMP (b
));
2125 SCM_SETCDR (z
, SCM_EOL
);
2127 z
= scm_cons (y
, SCM_UNSPECIFIED
);
2128 ls
= scm_cons (scm_sym_letstar
, z
);
2131 case SCM_BIT7 (SCM_IM_OR
):
2132 ls
= z
= scm_cons (scm_sym_or
, SCM_UNSPECIFIED
);
2134 case SCM_BIT7 (SCM_IM_LAMBDA
):
2136 z
= scm_cons (SCM_CAR (x
), SCM_UNSPECIFIED
);
2137 ls
= scm_cons (scm_sym_lambda
, z
);
2138 env
= SCM_EXTEND_ENV (SCM_CAR (x
), SCM_EOL
, env
);
2140 case SCM_BIT7 (SCM_IM_QUOTE
):
2141 ls
= z
= scm_cons (scm_sym_quote
, SCM_UNSPECIFIED
);
2143 case SCM_BIT7 (SCM_IM_SET_X
):
2144 ls
= z
= scm_cons (scm_sym_set_x
, SCM_UNSPECIFIED
);
2146 case SCM_BIT7 (SCM_MAKISYM (0)):
2148 switch (SCM_ISYMNUM (z
))
2150 case (SCM_ISYMNUM (SCM_IM_DEFINE
)):
2155 z
= scm_cons (n
, SCM_UNSPECIFIED
);
2156 ls
= scm_cons (scm_sym_define
, z
);
2157 if (!SCM_NULLP (env
))
2158 env
= scm_cons (scm_cons (scm_cons (n
, SCM_CAAR (env
)),
2163 case (SCM_ISYMNUM (SCM_IM_APPLY
)):
2164 ls
= z
= scm_cons (scm_sym_atapply
, SCM_UNSPECIFIED
);
2166 case (SCM_ISYMNUM (SCM_IM_CONT
)):
2167 ls
= z
= scm_cons (scm_sym_atcall_cc
, SCM_UNSPECIFIED
);
2169 case (SCM_ISYMNUM (SCM_IM_DELAY
)):
2170 ls
= z
= scm_cons (scm_sym_delay
, SCM_UNSPECIFIED
);
2173 case (SCM_ISYMNUM (SCM_IM_FUTURE
)):
2174 ls
= z
= scm_cons (scm_sym_future
, SCM_UNSPECIFIED
);
2177 case (SCM_ISYMNUM (SCM_IM_CALL_WITH_VALUES
)):
2178 ls
= z
= scm_cons (scm_sym_at_call_with_values
, SCM_UNSPECIFIED
);
2180 case (SCM_ISYMNUM (SCM_IM_ELSE
)):
2181 ls
= z
= scm_cons (scm_sym_else
, SCM_UNSPECIFIED
);
2184 /* appease the Sun compiler god: */ ;
2187 ls
= z
= unmemocar (scm_cons (unmemocopy (SCM_CAR (x
), env
),
2193 while (SCM_CONSP (x
))
2195 SCM form
= SCM_CAR (x
);
2196 if (!SCM_ISYMP (form
))
2198 SCM copy
= scm_cons (unmemocopy (form
, env
), SCM_UNSPECIFIED
);
2199 SCM_SETCDR (z
, unmemocar (copy
, env
));
2202 else if (SCM_EQ_P (form
, SCM_IM_ARROW
))
2204 SCM_SETCDR (z
, scm_cons (scm_sym_arrow
, SCM_UNSPECIFIED
));
2210 if (!SCM_FALSEP (p
))
2211 scm_whash_insert (scm_source_whash
, ls
, p
);
2217 scm_unmemocopy (SCM x
, SCM env
)
2219 if (!SCM_NULLP (env
))
2220 /* Make a copy of the lowest frame to protect it from
2221 modifications by SCM_IM_DEFINE */
2222 return unmemocopy (x
, scm_cons (SCM_CAR (env
), SCM_CDR (env
)));
2224 return unmemocopy (x
, env
);
2229 scm_badargsp (SCM formals
, SCM args
)
2231 while (!SCM_NULLP (formals
))
2233 if (!SCM_CONSP (formals
))
2235 if (SCM_NULLP (args
))
2237 formals
= SCM_CDR (formals
);
2238 args
= SCM_CDR (args
);
2240 return !SCM_NULLP (args
) ? 1 : 0;
2245 scm_eval_args (SCM l
, SCM env
, SCM proc
)
2247 SCM results
= SCM_EOL
, *lloc
= &results
, res
;
2248 while (SCM_CONSP (l
))
2250 res
= EVALCAR (l
, env
);
2252 *lloc
= scm_list_1 (res
);
2253 lloc
= SCM_CDRLOC (*lloc
);
2257 scm_wrong_num_args (proc
);
2263 scm_eval_body (SCM code
, SCM env
)
2267 next
= SCM_CDR (code
);
2268 while (!SCM_NULLP (next
))
2270 if (SCM_IMP (SCM_CAR (code
)))
2272 if (SCM_ISYMP (SCM_CAR (code
)))
2274 scm_rec_mutex_lock (&source_mutex
);
2275 /* check for race condition */
2276 if (SCM_ISYMP (SCM_CAR (code
)))
2277 code
= scm_m_expand_body (code
, env
);
2278 scm_rec_mutex_unlock (&source_mutex
);
2283 SCM_XEVAL (SCM_CAR (code
), env
);
2285 next
= SCM_CDR (code
);
2287 return SCM_XEVALCAR (code
, env
);
2293 /* SECTION: This code is specific for the debugging support. One
2294 * branch is read when DEVAL isn't defined, the other when DEVAL is
2300 #define SCM_APPLY scm_apply
2301 #define PREP_APPLY(proc, args)
2303 #define RETURN(x) do { return x; } while (0)
2304 #ifdef STACK_CHECKING
2305 #ifndef NO_CEVAL_STACK_CHECKING
2306 #define EVAL_STACK_CHECKING
2313 #define SCM_CEVAL scm_deval /* Substitute all uses of scm_ceval */
2315 #define SCM_APPLY scm_dapply
2317 #define PREP_APPLY(p, l) \
2318 { ++debug.info; debug.info->a.proc = p; debug.info->a.args = l; }
2320 #define ENTER_APPLY \
2322 SCM_SET_ARGSREADY (debug);\
2323 if (scm_check_apply_p && SCM_TRAPS_P)\
2324 if (SCM_APPLY_FRAME_P || (SCM_TRACE_P && PROCTRACEP (proc)))\
2326 SCM tmp, tail = SCM_BOOL(SCM_TRACED_FRAME_P (debug)); \
2327 SCM_SET_TRACED_FRAME (debug); \
2329 if (SCM_CHEAPTRAPS_P)\
2331 tmp = scm_make_debugobj (&debug);\
2332 scm_call_3 (SCM_APPLY_FRAME_HDLR, scm_sym_apply_frame, tmp, tail);\
2337 tmp = scm_make_continuation (&first);\
2339 scm_call_3 (SCM_APPLY_FRAME_HDLR, scm_sym_apply_frame, tmp, tail);\
2345 #define RETURN(e) do { proc = (e); goto exit; } while (0)
2346 #ifdef STACK_CHECKING
2347 #ifndef EVAL_STACK_CHECKING
2348 #define EVAL_STACK_CHECKING
2352 /* scm_ceval_ptr points to the currently selected evaluator.
2353 * *fixme*: Although efficiency is important here, this state variable
2354 * should probably not be a global. It should be related to the
2359 SCM (*scm_ceval_ptr
) (SCM x
, SCM env
);
2361 /* scm_last_debug_frame contains a pointer to the last debugging
2362 * information stack frame. It is accessed very often from the
2363 * debugging evaluator, so it should probably not be indirectly
2364 * addressed. Better to save and restore it from the current root at
2368 /* scm_debug_eframe_size is the number of slots available for pseudo
2369 * stack frames at each real stack frame.
2372 long scm_debug_eframe_size
;
2374 int scm_debug_mode
, scm_check_entry_p
, scm_check_apply_p
, scm_check_exit_p
;
2376 long scm_eval_stack
;
2378 scm_t_option scm_eval_opts
[] = {
2379 { SCM_OPTION_INTEGER
, "stack", 22000, "Size of thread stacks (in machine words)." }
2382 scm_t_option scm_debug_opts
[] = {
2383 { SCM_OPTION_BOOLEAN
, "cheap", 1,
2384 "*Flyweight representation of the stack at traps." },
2385 { SCM_OPTION_BOOLEAN
, "breakpoints", 0, "*Check for breakpoints." },
2386 { SCM_OPTION_BOOLEAN
, "trace", 0, "*Trace mode." },
2387 { SCM_OPTION_BOOLEAN
, "procnames", 1,
2388 "Record procedure names at definition." },
2389 { SCM_OPTION_BOOLEAN
, "backwards", 0,
2390 "Display backtrace in anti-chronological order." },
2391 { SCM_OPTION_INTEGER
, "width", 79, "Maximal width of backtrace." },
2392 { SCM_OPTION_INTEGER
, "indent", 10, "Maximal indentation in backtrace." },
2393 { SCM_OPTION_INTEGER
, "frames", 3,
2394 "Maximum number of tail-recursive frames in backtrace." },
2395 { SCM_OPTION_INTEGER
, "maxdepth", 1000,
2396 "Maximal number of stored backtrace frames." },
2397 { SCM_OPTION_INTEGER
, "depth", 20, "Maximal length of printed backtrace." },
2398 { SCM_OPTION_BOOLEAN
, "backtrace", 0, "Show backtrace on error." },
2399 { SCM_OPTION_BOOLEAN
, "debug", 0, "Use the debugging evaluator." },
2400 { SCM_OPTION_INTEGER
, "stack", 20000, "Stack size limit (measured in words; 0 = no check)." },
2401 { 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."}
2404 scm_t_option scm_evaluator_trap_table
[] = {
2405 { SCM_OPTION_BOOLEAN
, "traps", 0, "Enable evaluator traps." },
2406 { SCM_OPTION_BOOLEAN
, "enter-frame", 0, "Trap when eval enters new frame." },
2407 { SCM_OPTION_BOOLEAN
, "apply-frame", 0, "Trap when entering apply." },
2408 { SCM_OPTION_BOOLEAN
, "exit-frame", 0, "Trap when exiting eval or apply." },
2409 { SCM_OPTION_SCM
, "enter-frame-handler", (unsigned long)SCM_BOOL_F
, "Handler for enter-frame traps." },
2410 { SCM_OPTION_SCM
, "apply-frame-handler", (unsigned long)SCM_BOOL_F
, "Handler for apply-frame traps." },
2411 { SCM_OPTION_SCM
, "exit-frame-handler", (unsigned long)SCM_BOOL_F
, "Handler for exit-frame traps." }
2414 SCM_DEFINE (scm_eval_options_interface
, "eval-options-interface", 0, 1, 0,
2416 "Option interface for the evaluation options. Instead of using\n"
2417 "this procedure directly, use the procedures @code{eval-enable},\n"
2418 "@code{eval-disable}, @code{eval-set!} and @code{eval-options}.")
2419 #define FUNC_NAME s_scm_eval_options_interface
2423 ans
= scm_options (setting
,
2427 scm_eval_stack
= SCM_EVAL_STACK
* sizeof (void *);
2434 SCM_DEFINE (scm_evaluator_traps
, "evaluator-traps-interface", 0, 1, 0,
2436 "Option interface for the evaluator trap options.")
2437 #define FUNC_NAME s_scm_evaluator_traps
2441 ans
= scm_options (setting
,
2442 scm_evaluator_trap_table
,
2443 SCM_N_EVALUATOR_TRAPS
,
2445 SCM_RESET_DEBUG_MODE
;
2453 deval_args (SCM l
, SCM env
, SCM proc
, SCM
*lloc
)
2455 SCM
*results
= lloc
, res
;
2456 while (SCM_CONSP (l
))
2458 res
= EVALCAR (l
, env
);
2460 *lloc
= scm_list_1 (res
);
2461 lloc
= SCM_CDRLOC (*lloc
);
2465 scm_wrong_num_args (proc
);
2472 /* SECTION: This code is compiled twice.
2476 /* Update the toplevel environment frame ENV so that it refers to the
2477 * current module. */
2478 #define UPDATE_TOPLEVEL_ENV(env) \
2480 SCM p = scm_current_module_lookup_closure (); \
2481 if (p != SCM_CAR (env)) \
2482 env = scm_top_level_env (p); \
2486 /* This is the evaluator. Like any real monster, it has three heads:
2488 * scm_ceval is the non-debugging evaluator, scm_deval is the debugging
2489 * version. Both are implemented using a common code base, using the
2490 * following mechanism: SCM_CEVAL is a macro, which is either defined to
2491 * scm_ceval or scm_deval. Thus, there is no function SCM_CEVAL, but the code
2492 * for SCM_CEVAL actually compiles to either scm_ceval or scm_deval. When
2493 * SCM_CEVAL is defined to scm_ceval, it is known that the macro DEVAL is not
2494 * defined. When SCM_CEVAL is defined to scm_deval, then the macro DEVAL is
2495 * known to be defined. Thus, in SCM_CEVAL parts for the debugging evaluator
2496 * are enclosed within #ifdef DEVAL ... #endif.
2498 * All three (scm_ceval, scm_deval and their common implementation SCM_CEVAL)
2499 * take two input parameters, x and env: x is a single expression to be
2500 * evalutated. env is the environment in which bindings are searched.
2502 * x is known to be a cell (i. e. a pair or any other non-immediate). Since x
2503 * is a single expression, it is necessarily in a tail position. If x is just
2504 * a call to another function like in the expression (foo exp1 exp2 ...), the
2505 * realization of that call therefore _must_not_ increase stack usage (the
2506 * evaluation of exp1, exp2 etc., however, may do so). This is realized by
2507 * making extensive use of 'goto' statements within the evaluator: The gotos
2508 * replace recursive calls to SCM_CEVAL, thus re-using the same stack frame
2509 * that SCM_CEVAL was already using. If, however, x represents some form that
2510 * requires to evaluate a sequence of expressions like (begin exp1 exp2 ...),
2511 * then recursive calls to SCM_CEVAL are performed for all but the last
2512 * expression of that sequence. */
2516 scm_ceval (SCM x
, SCM env
)
2522 scm_deval (SCM x
, SCM env
)
2527 SCM_CEVAL (SCM x
, SCM env
)
2531 scm_t_debug_frame debug
;
2532 scm_t_debug_info
*debug_info_end
;
2533 debug
.prev
= scm_last_debug_frame
;
2536 * The debug.vect contains twice as much scm_t_debug_info frames as the
2537 * user has specified with (debug-set! frames <n>).
2539 * Even frames are eval frames, odd frames are apply frames.
2541 debug
.vect
= (scm_t_debug_info
*) alloca (scm_debug_eframe_size
2542 * sizeof (scm_t_debug_info
));
2543 debug
.info
= debug
.vect
;
2544 debug_info_end
= debug
.vect
+ scm_debug_eframe_size
;
2545 scm_last_debug_frame
= &debug
;
2547 #ifdef EVAL_STACK_CHECKING
2548 if (scm_stack_checking_enabled_p
&& SCM_STACK_OVERFLOW_P (&proc
))
2551 debug
.info
->e
.exp
= x
;
2552 debug
.info
->e
.env
= env
;
2554 scm_report_stack_overflow ();
2564 SCM_CLEAR_ARGSREADY (debug
);
2565 if (SCM_OVERFLOWP (debug
))
2568 * In theory, this should be the only place where it is necessary to
2569 * check for space in debug.vect since both eval frames and
2570 * available space are even.
2572 * For this to be the case, however, it is necessary that primitive
2573 * special forms which jump back to `loop', `begin' or some similar
2574 * label call PREP_APPLY.
2576 else if (++debug
.info
>= debug_info_end
)
2578 SCM_SET_OVERFLOW (debug
);
2583 debug
.info
->e
.exp
= x
;
2584 debug
.info
->e
.env
= env
;
2585 if (scm_check_entry_p
&& SCM_TRAPS_P
)
2587 if (SCM_ENTER_FRAME_P
2588 || (SCM_BREAKPOINTS_P
&& scm_c_source_property_breakpoint_p (x
)))
2591 SCM tail
= SCM_BOOL (SCM_TAILRECP (debug
));
2592 SCM_SET_TAILREC (debug
);
2593 if (SCM_CHEAPTRAPS_P
)
2594 stackrep
= scm_make_debugobj (&debug
);
2598 SCM val
= scm_make_continuation (&first
);
2608 /* This gives the possibility for the debugger to
2609 modify the source expression before evaluation. */
2614 scm_call_4 (SCM_ENTER_FRAME_HDLR
,
2615 scm_sym_enter_frame
,
2618 scm_unmemocopy (x
, env
));
2625 switch (SCM_TYP7 (x
))
2627 case SCM_BIT7 (SCM_IM_AND
):
2629 while (!SCM_NULLP (SCM_CDR (x
)))
2631 SCM test_result
= EVALCAR (x
, env
);
2632 if (SCM_FALSEP (test_result
) || SCM_NILP (test_result
))
2633 RETURN (SCM_BOOL_F
);
2637 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
2640 case SCM_BIT7 (SCM_IM_BEGIN
):
2643 RETURN (SCM_UNSPECIFIED
);
2645 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
2648 /* If we are on toplevel with a lookup closure, we need to sync
2649 with the current module. */
2650 if (SCM_CONSP (env
) && !SCM_CONSP (SCM_CAR (env
)))
2652 UPDATE_TOPLEVEL_ENV (env
);
2653 while (!SCM_NULLP (SCM_CDR (x
)))
2656 UPDATE_TOPLEVEL_ENV (env
);
2662 goto nontoplevel_begin
;
2665 while (!SCM_NULLP (SCM_CDR (x
)))
2667 SCM form
= SCM_CAR (x
);
2670 if (SCM_ISYMP (form
))
2672 scm_rec_mutex_lock (&source_mutex
);
2673 /* check for race condition */
2674 if (SCM_ISYMP (SCM_CAR (x
)))
2675 x
= scm_m_expand_body (x
, env
);
2676 scm_rec_mutex_unlock (&source_mutex
);
2677 goto nontoplevel_begin
;
2680 SCM_VALIDATE_NON_EMPTY_COMBINATION (form
);
2683 SCM_CEVAL (form
, env
);
2689 /* scm_eval last form in list */
2690 SCM last_form
= SCM_CAR (x
);
2692 if (SCM_CONSP (last_form
))
2694 /* This is by far the most frequent case. */
2696 goto loop
; /* tail recurse */
2698 else if (SCM_IMP (last_form
))
2699 RETURN (SCM_EVALIM (last_form
, env
));
2700 else if (SCM_VARIABLEP (last_form
))
2701 RETURN (SCM_VARIABLE_REF (last_form
));
2702 else if (SCM_SYMBOLP (last_form
))
2703 RETURN (*scm_lookupcar (x
, env
, 1));
2709 case SCM_BIT7 (SCM_IM_CASE
):
2712 SCM key
= EVALCAR (x
, env
);
2714 while (!SCM_NULLP (x
))
2716 SCM clause
= SCM_CAR (x
);
2717 SCM labels
= SCM_CAR (clause
);
2718 if (SCM_EQ_P (labels
, SCM_IM_ELSE
))
2720 x
= SCM_CDR (clause
);
2721 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
2724 while (!SCM_NULLP (labels
))
2726 SCM label
= SCM_CAR (labels
);
2727 if (SCM_EQ_P (label
, key
) || !SCM_FALSEP (scm_eqv_p (label
, key
)))
2729 x
= SCM_CDR (clause
);
2730 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
2733 labels
= SCM_CDR (labels
);
2738 RETURN (SCM_UNSPECIFIED
);
2741 case SCM_BIT7 (SCM_IM_COND
):
2743 while (!SCM_NULLP (x
))
2745 SCM clause
= SCM_CAR (x
);
2746 if (SCM_EQ_P (SCM_CAR (clause
), SCM_IM_ELSE
))
2748 x
= SCM_CDR (clause
);
2749 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
2754 arg1
= EVALCAR (clause
, env
);
2755 if (!SCM_FALSEP (arg1
) && !SCM_NILP (arg1
))
2757 x
= SCM_CDR (clause
);
2760 else if (!SCM_EQ_P (SCM_CAR (x
), SCM_IM_ARROW
))
2762 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
2768 proc
= EVALCAR (proc
, env
);
2769 PREP_APPLY (proc
, scm_list_1 (arg1
));
2777 RETURN (SCM_UNSPECIFIED
);
2780 case SCM_BIT7 (SCM_IM_DO
):
2783 /* Compute the initialization values and the initial environment. */
2784 SCM init_forms
= SCM_CAR (x
);
2785 SCM init_values
= SCM_EOL
;
2786 while (!SCM_NULLP (init_forms
))
2788 init_values
= scm_cons (EVALCAR (init_forms
, env
), init_values
);
2789 init_forms
= SCM_CDR (init_forms
);
2792 env
= SCM_EXTEND_ENV (SCM_CAR (x
), init_values
, env
);
2796 SCM test_form
= SCM_CAR (x
);
2797 SCM body_forms
= SCM_CADR (x
);
2798 SCM step_forms
= SCM_CDDR (x
);
2800 SCM test_result
= EVALCAR (test_form
, env
);
2802 while (SCM_FALSEP (test_result
) || SCM_NILP (test_result
))
2805 /* Evaluate body forms. */
2807 for (temp_forms
= body_forms
;
2808 !SCM_NULLP (temp_forms
);
2809 temp_forms
= SCM_CDR (temp_forms
))
2811 SCM form
= SCM_CAR (temp_forms
);
2812 /* Dirk:FIXME: We only need to eval forms, that may have a
2813 * side effect here. This is only true for forms that start
2814 * with a pair. All others are just constants. However,
2815 * since in the common case there is no constant expression
2816 * in a body of a do form, we just check for immediates here
2817 * and have SCM_CEVAL take care of other cases. In the long
2818 * run it would make sense to get rid of this test and have
2819 * the macro transformer of 'do' eliminate all forms that
2820 * have no sideeffect. */
2821 if (!SCM_IMP (form
))
2822 SCM_CEVAL (form
, env
);
2827 /* Evaluate the step expressions. */
2829 SCM step_values
= SCM_EOL
;
2830 for (temp_forms
= step_forms
;
2831 !SCM_NULLP (temp_forms
);
2832 temp_forms
= SCM_CDR (temp_forms
))
2834 SCM value
= EVALCAR (temp_forms
, env
);
2835 step_values
= scm_cons (value
, step_values
);
2837 env
= SCM_EXTEND_ENV (SCM_CAAR (env
),
2842 test_result
= EVALCAR (test_form
, env
);
2847 RETURN (SCM_UNSPECIFIED
);
2848 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
2849 goto nontoplevel_begin
;
2852 case SCM_BIT7 (SCM_IM_IF
):
2855 SCM test_result
= EVALCAR (x
, env
);
2856 x
= SCM_CDR (x
); /* then expression */
2857 if (SCM_FALSEP (test_result
) || SCM_NILP (test_result
))
2859 x
= SCM_CDR (x
); /* else expression */
2861 RETURN (SCM_UNSPECIFIED
);
2864 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
2868 case SCM_BIT7 (SCM_IM_LET
):
2871 SCM init_forms
= SCM_CADR (x
);
2872 SCM init_values
= SCM_EOL
;
2875 init_values
= scm_cons (EVALCAR (init_forms
, env
), init_values
);
2876 init_forms
= SCM_CDR (init_forms
);
2878 while (!SCM_NULLP (init_forms
));
2879 env
= SCM_EXTEND_ENV (SCM_CAR (x
), init_values
, env
);
2882 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
2883 goto nontoplevel_begin
;
2886 case SCM_BIT7 (SCM_IM_LETREC
):
2888 env
= SCM_EXTEND_ENV (SCM_CAR (x
), undefineds
, env
);
2891 SCM init_forms
= SCM_CAR (x
);
2892 SCM init_values
= SCM_EOL
;
2895 init_values
= scm_cons (EVALCAR (init_forms
, env
), init_values
);
2896 init_forms
= SCM_CDR (init_forms
);
2898 while (!SCM_NULLP (init_forms
));
2899 SCM_SETCDR (SCM_CAR (env
), init_values
);
2902 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
2903 goto nontoplevel_begin
;
2906 case SCM_BIT7 (SCM_IM_LETSTAR
):
2909 SCM bindings
= SCM_CAR (x
);
2910 if (SCM_NULLP (bindings
))
2911 env
= SCM_EXTEND_ENV (SCM_EOL
, SCM_EOL
, env
);
2916 SCM name
= SCM_CAR (bindings
);
2917 SCM init
= SCM_CDR (bindings
);
2918 env
= SCM_EXTEND_ENV (name
, EVALCAR (init
, env
), env
);
2919 bindings
= SCM_CDR (init
);
2921 while (!SCM_NULLP (bindings
));
2925 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
2926 goto nontoplevel_begin
;
2929 case SCM_BIT7 (SCM_IM_OR
):
2931 while (!SCM_NULLP (SCM_CDR (x
)))
2933 SCM val
= EVALCAR (x
, env
);
2934 if (!SCM_FALSEP (val
) && !SCM_NILP (val
))
2939 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
2943 case SCM_BIT7 (SCM_IM_LAMBDA
):
2944 RETURN (scm_closure (SCM_CDR (x
), env
));
2947 case SCM_BIT7 (SCM_IM_QUOTE
):
2948 RETURN (SCM_CADR (x
));
2951 case SCM_BIT7 (SCM_IM_SET_X
):
2955 SCM variable
= SCM_CAR (x
);
2956 if (SCM_ILOCP (variable
))
2957 location
= scm_ilookup (variable
, env
);
2958 else if (SCM_VARIABLEP (variable
))
2959 location
= SCM_VARIABLE_LOC (variable
);
2960 else /* (SCM_SYMBOLP (variable)) is known to be true */
2961 location
= scm_lookupcar (x
, env
, 1);
2963 *location
= EVALCAR (x
, env
);
2965 RETURN (SCM_UNSPECIFIED
);
2968 /* new syntactic forms go here. */
2969 case SCM_BIT7 (SCM_MAKISYM (0)):
2971 switch (SCM_ISYMNUM (proc
))
2975 case (SCM_ISYMNUM (SCM_IM_DEFINE
)):
2976 /* Top level defines are handled directly by the memoizer and thus
2977 * will never generate memoized code with SCM_IM_DEFINE. Internal
2978 * defines which occur at valid positions will be transformed into
2979 * letrec expressions. Thus, whenever the executor detects
2980 * SCM_IM_DEFINE, this must come from an internal definition at an
2981 * illegal position. */
2982 scm_misc_error (NULL
, "Bad define placement", SCM_EOL
);
2985 case (SCM_ISYMNUM (SCM_IM_APPLY
)):
2987 proc
= EVALCAR (x
, env
);
2988 PREP_APPLY (proc
, SCM_EOL
);
2990 arg1
= EVALCAR (x
, env
);
2993 /* Go here to tail-apply a procedure. PROC is the procedure and
2994 * ARG1 is the list of arguments. PREP_APPLY must have been called
2995 * before jumping to apply_proc. */
2996 if (SCM_CLOSUREP (proc
))
2998 SCM formals
= SCM_CLOSURE_FORMALS (proc
);
3000 debug
.info
->a
.args
= arg1
;
3002 if (scm_badargsp (formals
, arg1
))
3003 scm_wrong_num_args (proc
);
3005 /* Copy argument list */
3006 if (SCM_NULL_OR_NIL_P (arg1
))
3007 env
= SCM_EXTEND_ENV (formals
, SCM_EOL
, SCM_ENV (proc
));
3010 SCM args
= scm_list_1 (SCM_CAR (arg1
));
3012 arg1
= SCM_CDR (arg1
);
3013 while (!SCM_NULL_OR_NIL_P (arg1
))
3015 SCM new_tail
= scm_list_1 (SCM_CAR (arg1
));
3016 SCM_SETCDR (tail
, new_tail
);
3018 arg1
= SCM_CDR (arg1
);
3020 env
= SCM_EXTEND_ENV (formals
, args
, SCM_ENV (proc
));
3023 x
= SCM_CLOSURE_BODY (proc
);
3024 goto nontoplevel_begin
;
3029 RETURN (SCM_APPLY (proc
, arg1
, SCM_EOL
));
3033 case (SCM_ISYMNUM (SCM_IM_CONT
)):
3036 SCM val
= scm_make_continuation (&first
);
3044 proc
= scm_eval_car (proc
, env
);
3045 PREP_APPLY (proc
, scm_list_1 (arg1
));
3052 case (SCM_ISYMNUM (SCM_IM_DELAY
)):
3053 RETURN (scm_makprom (scm_closure (SCM_CDR (x
), env
)));
3056 case (SCM_ISYMNUM (SCM_IM_FUTURE
)):
3057 RETURN (scm_i_make_future (scm_closure (SCM_CDR (x
), env
)));
3060 /* PLACEHOLDER for case (SCM_ISYMNUM (SCM_IM_DISPATCH)): The
3061 following code (type_dispatch) is intended to be the tail
3062 of the case clause for the internal macro
3063 SCM_IM_DISPATCH. Please don't remove it from this
3064 location without discussing it with Mikael
3065 <djurfeldt@nada.kth.se> */
3067 /* The type dispatch code is duplicated below
3068 * (c.f. objects.c:scm_mcache_compute_cmethod) since that
3069 * cuts down execution time for type dispatch to 50%. */
3070 type_dispatch
: /* inputs: x, arg1 */
3071 /* Type dispatch means to determine from the types of the function
3072 * arguments (i. e. the 'signature' of the call), which method from
3073 * a generic function is to be called. This process of selecting
3074 * the right method takes some time. To speed it up, guile uses
3075 * caching: Together with the macro call to dispatch the signatures
3076 * of some previous calls to that generic function from the same
3077 * place are stored (in the code!) in a cache that we call the
3078 * 'method cache'. This is done since it is likely, that
3079 * consecutive calls to dispatch from that position in the code will
3080 * have the same signature. Thus, the type dispatch works as
3081 * follows: First, determine a hash value from the signature of the
3082 * actual arguments. Second, use this hash value as an index to
3083 * find that same signature in the method cache stored at this
3084 * position in the code. If found, you have also found the
3085 * corresponding method that belongs to that signature. If the
3086 * signature is not found in the method cache, you have to perform a
3087 * full search over all signatures stored with the generic
3090 unsigned long int specializers
;
3091 unsigned long int hash_value
;
3092 unsigned long int cache_end_pos
;
3093 unsigned long int mask
;
3097 SCM z
= SCM_CDDR (x
);
3098 SCM tmp
= SCM_CADR (z
);
3099 specializers
= SCM_INUM (SCM_CAR (z
));
3101 /* Compute a hash value for searching the method cache. There
3102 * are two variants for computing the hash value, a (rather)
3103 * complicated one, and a simple one. For the complicated one
3104 * explained below, tmp holds a number that is used in the
3106 if (SCM_INUMP (tmp
))
3108 /* Use the signature of the actual arguments to determine
3109 * the hash value. This is done as follows: Each class has
3110 * an array of random numbers, that are determined when the
3111 * class is created. The integer 'hashset' is an index into
3112 * that array of random numbers. Now, from all classes that
3113 * are part of the signature of the actual arguments, the
3114 * random numbers at index 'hashset' are taken and summed
3115 * up, giving the hash value. The value of 'hashset' is
3116 * stored at the call to dispatch. This allows to have
3117 * different 'formulas' for calculating the hash value at
3118 * different places where dispatch is called. This allows
3119 * to optimize the hash formula at every individual place
3120 * where dispatch is called, such that hopefully the hash
3121 * value that is computed will directly point to the right
3122 * method in the method cache. */
3123 unsigned long int hashset
= SCM_INUM (tmp
);
3124 unsigned long int counter
= specializers
+ 1;
3127 while (!SCM_NULLP (tmp_arg
) && counter
!= 0)
3129 SCM
class = scm_class_of (SCM_CAR (tmp_arg
));
3130 hash_value
+= SCM_INSTANCE_HASH (class, hashset
);
3131 tmp_arg
= SCM_CDR (tmp_arg
);
3135 method_cache
= SCM_CADR (z
);
3136 mask
= SCM_INUM (SCM_CAR (z
));
3138 cache_end_pos
= hash_value
;
3142 /* This method of determining the hash value is much
3143 * simpler: Set the hash value to zero and just perform a
3144 * linear search through the method cache. */
3146 mask
= (unsigned long int) ((long) -1);
3148 cache_end_pos
= SCM_VECTOR_LENGTH (method_cache
);
3153 /* Search the method cache for a method with a matching
3154 * signature. Start the search at position 'hash_value'. The
3155 * hashing implementation uses linear probing for conflict
3156 * resolution, that is, if the signature in question is not
3157 * found at the starting index in the hash table, the next table
3158 * entry is tried, and so on, until in the worst case the whole
3159 * cache has been searched, but still the signature has not been
3164 SCM args
= arg1
; /* list of arguments */
3165 z
= SCM_VELTS (method_cache
)[hash_value
];
3166 while (!SCM_NULLP (args
))
3168 /* More arguments than specifiers => CLASS != ENV */
3169 SCM class_of_arg
= scm_class_of (SCM_CAR (args
));
3170 if (!SCM_EQ_P (class_of_arg
, SCM_CAR (z
)))
3172 args
= SCM_CDR (args
);
3175 /* Fewer arguments than specifiers => CAR != ENV */
3176 if (SCM_NULLP (SCM_CAR (z
)) || SCM_CONSP (SCM_CAR (z
)))
3179 hash_value
= (hash_value
+ 1) & mask
;
3180 } while (hash_value
!= cache_end_pos
);
3182 /* No appropriate method was found in the cache. */
3183 z
= scm_memoize_method (x
, arg1
);
3185 apply_cmethod
: /* inputs: z, arg1 */
3187 SCM formals
= SCM_CMETHOD_FORMALS (z
);
3188 env
= SCM_EXTEND_ENV (formals
, arg1
, SCM_CMETHOD_ENV (z
));
3189 x
= SCM_CMETHOD_BODY (z
);
3190 goto nontoplevel_begin
;
3196 case (SCM_ISYMNUM (SCM_IM_SLOT_REF
)):
3199 SCM instance
= EVALCAR (x
, env
);
3200 unsigned long int slot
= SCM_INUM (SCM_CADR (x
));
3201 RETURN (SCM_PACK (SCM_STRUCT_DATA (instance
) [slot
]));
3205 case (SCM_ISYMNUM (SCM_IM_SLOT_SET_X
)):
3208 SCM instance
= EVALCAR (x
, env
);
3209 unsigned long int slot
= SCM_INUM (SCM_CADR (x
));
3210 SCM value
= EVALCAR (SCM_CDDR (x
), env
);
3211 SCM_STRUCT_DATA (instance
) [slot
] = SCM_UNPACK (value
);
3212 RETURN (SCM_UNSPECIFIED
);
3216 #if SCM_ENABLE_ELISP
3218 case (SCM_ISYMNUM (SCM_IM_NIL_COND
)):
3220 SCM test_form
= SCM_CDR (x
);
3221 x
= SCM_CDR (test_form
);
3222 while (!SCM_NULL_OR_NIL_P (x
))
3224 SCM test_result
= EVALCAR (test_form
, env
);
3225 if (!(SCM_FALSEP (test_result
)
3226 || SCM_NULL_OR_NIL_P (test_result
)))
3228 if (SCM_EQ_P (SCM_CAR (x
), SCM_UNSPECIFIED
))
3229 RETURN (test_result
);
3230 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
3235 test_form
= SCM_CDR (x
);
3236 x
= SCM_CDR (test_form
);
3240 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
3244 #endif /* SCM_ENABLE_ELISP */
3246 case (SCM_ISYMNUM (SCM_IM_BIND
)):
3248 SCM vars
, exps
, vals
;
3251 vars
= SCM_CAAR (x
);
3252 exps
= SCM_CDAR (x
);
3254 while (!SCM_NULLP (exps
))
3256 vals
= scm_cons (EVALCAR (exps
, env
), vals
);
3257 exps
= SCM_CDR (exps
);
3260 scm_swap_bindings (vars
, vals
);
3261 scm_dynwinds
= scm_acons (vars
, vals
, scm_dynwinds
);
3263 /* Ignore all but the last evaluation result. */
3264 for (x
= SCM_CDR (x
); !SCM_NULLP (SCM_CDR (x
)); x
= SCM_CDR (x
))
3266 if (SCM_CONSP (SCM_CAR (x
)))
3267 SCM_CEVAL (SCM_CAR (x
), env
);
3269 proc
= EVALCAR (x
, env
);
3271 scm_dynwinds
= SCM_CDR (scm_dynwinds
);
3272 scm_swap_bindings (vars
, vals
);
3278 case (SCM_ISYMNUM (SCM_IM_CALL_WITH_VALUES
)):
3283 producer
= EVALCAR (x
, env
);
3285 proc
= EVALCAR (x
, env
); /* proc is the consumer. */
3286 arg1
= SCM_APPLY (producer
, SCM_EOL
, SCM_EOL
);
3287 if (SCM_VALUESP (arg1
))
3289 /* The list of arguments is not copied. Rather, it is assumed
3290 * that this has been done by the 'values' procedure. */
3291 arg1
= scm_struct_ref (arg1
, SCM_INUM0
);
3295 arg1
= scm_list_1 (arg1
);
3297 PREP_APPLY (proc
, arg1
);
3312 case scm_tc7_vector
:
3316 case scm_tc7_byvect
:
3323 #if SCM_SIZEOF_LONG_LONG != 0
3324 case scm_tc7_llvect
:
3327 case scm_tc7_number
:
3328 case scm_tc7_string
:
3330 case scm_tcs_closures
:
3334 case scm_tcs_struct
:
3337 case scm_tc7_symbol
:
3338 /* Only happens when called at top level. */
3339 x
= scm_cons (x
, SCM_UNDEFINED
);
3340 RETURN (*scm_lookupcar (x
, env
, 1));
3342 case scm_tc7_variable
:
3343 RETURN (SCM_VARIABLE_REF(x
));
3345 case SCM_BIT7 (SCM_ILOC00
):
3346 proc
= *scm_ilookup (SCM_CAR (x
), env
);
3349 case scm_tcs_cons_nimcar
:
3350 if (SCM_SYMBOLP (SCM_CAR (x
)))
3352 SCM orig_sym
= SCM_CAR (x
);
3354 SCM
*location
= scm_lookupcar1 (x
, env
, 1);
3355 if (location
== NULL
)
3357 /* we have lost the race, start again. */
3363 if (SCM_MACROP (proc
))
3365 SCM_SETCAR (x
, orig_sym
); /* Undo memoizing effect of
3367 handle_a_macro
: /* inputs: x, env, proc */
3369 /* Set a flag during macro expansion so that macro
3370 application frames can be deleted from the backtrace. */
3371 SCM_SET_MACROEXP (debug
);
3373 arg1
= SCM_APPLY (SCM_MACRO_CODE (proc
), x
,
3374 scm_cons (env
, scm_listofnull
));
3377 SCM_CLEAR_MACROEXP (debug
);
3379 switch (SCM_MACRO_TYPE (proc
))
3383 if (scm_ilength (arg1
) <= 0)
3384 arg1
= scm_list_2 (SCM_IM_BEGIN
, arg1
);
3386 if (!SCM_CLOSUREP (SCM_MACRO_CODE (proc
)))
3389 SCM_SETCAR (x
, SCM_CAR (arg1
));
3390 SCM_SETCDR (x
, SCM_CDR (arg1
));
3394 /* Prevent memoizing of debug info expression. */
3395 debug
.info
->e
.exp
= scm_cons_source (debug
.info
->e
.exp
,
3400 SCM_SETCAR (x
, SCM_CAR (arg1
));
3401 SCM_SETCDR (x
, SCM_CDR (arg1
));
3403 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
3405 #if SCM_ENABLE_DEPRECATED == 1
3410 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
3422 proc
= SCM_CEVAL (SCM_CAR (x
), env
);
3425 if (SCM_MACROP (proc
))
3426 goto handle_a_macro
;
3430 evapply
: /* inputs: x, proc */
3431 PREP_APPLY (proc
, SCM_EOL
);
3432 if (SCM_NULLP (SCM_CDR (x
))) {
3435 SCM_ASRTGO (!SCM_IMP (proc
), badfun
);
3436 switch (SCM_TYP7 (proc
))
3437 { /* no arguments given */
3438 case scm_tc7_subr_0
:
3439 RETURN (SCM_SUBRF (proc
) ());
3440 case scm_tc7_subr_1o
:
3441 RETURN (SCM_SUBRF (proc
) (SCM_UNDEFINED
));
3443 RETURN (SCM_SUBRF (proc
) (SCM_EOL
));
3444 case scm_tc7_rpsubr
:
3445 RETURN (SCM_BOOL_T
);
3447 RETURN (SCM_SUBRF (proc
) (SCM_UNDEFINED
, SCM_UNDEFINED
));
3449 if (!SCM_SMOB_APPLICABLE_P (proc
))
3451 RETURN (SCM_SMOB_APPLY_0 (proc
));
3454 proc
= SCM_CCLO_SUBR (proc
);
3456 debug
.info
->a
.proc
= proc
;
3457 debug
.info
->a
.args
= scm_list_1 (arg1
);
3461 proc
= SCM_PROCEDURE (proc
);
3463 debug
.info
->a
.proc
= proc
;
3465 if (!SCM_CLOSUREP (proc
))
3468 case scm_tcs_closures
:
3470 const SCM formals
= SCM_CLOSURE_FORMALS (proc
);
3471 if (SCM_CONSP (formals
))
3472 goto umwrongnumargs
;
3473 x
= SCM_CLOSURE_BODY (proc
);
3474 env
= SCM_EXTEND_ENV (formals
, SCM_EOL
, SCM_ENV (proc
));
3475 goto nontoplevel_begin
;
3477 case scm_tcs_struct
:
3478 if (SCM_OBJ_CLASS_FLAGS (proc
) & SCM_CLASSF_PURE_GENERIC
)
3480 x
= SCM_ENTITY_PROCEDURE (proc
);
3484 else if (SCM_I_OPERATORP (proc
))
3487 proc
= (SCM_I_ENTITYP (proc
)
3488 ? SCM_ENTITY_PROCEDURE (proc
)
3489 : SCM_OPERATOR_PROCEDURE (proc
));
3491 debug
.info
->a
.proc
= proc
;
3492 debug
.info
->a
.args
= scm_list_1 (arg1
);
3498 case scm_tc7_subr_1
:
3499 case scm_tc7_subr_2
:
3500 case scm_tc7_subr_2o
:
3503 case scm_tc7_subr_3
:
3504 case scm_tc7_lsubr_2
:
3507 scm_wrong_num_args (proc
);
3510 scm_misc_error (NULL
, "Wrong type to apply: ~S", scm_list_1 (proc
));
3514 /* must handle macros by here */
3517 arg1
= EVALCAR (x
, env
);
3519 scm_wrong_num_args (proc
);
3521 debug
.info
->a
.args
= scm_list_1 (arg1
);
3529 evap1
: /* inputs: proc, arg1 */
3530 SCM_ASRTGO (!SCM_IMP (proc
), badfun
);
3531 switch (SCM_TYP7 (proc
))
3532 { /* have one argument in arg1 */
3533 case scm_tc7_subr_2o
:
3534 RETURN (SCM_SUBRF (proc
) (arg1
, SCM_UNDEFINED
));
3535 case scm_tc7_subr_1
:
3536 case scm_tc7_subr_1o
:
3537 RETURN (SCM_SUBRF (proc
) (arg1
));
3539 if (SCM_INUMP (arg1
))
3541 RETURN (scm_make_real (SCM_DSUBRF (proc
) ((double) SCM_INUM (arg1
))));
3543 else if (SCM_REALP (arg1
))
3545 RETURN (scm_make_real (SCM_DSUBRF (proc
) (SCM_REAL_VALUE (arg1
))));
3547 else if (SCM_BIGP (arg1
))
3549 RETURN (scm_make_real (SCM_DSUBRF (proc
) (scm_i_big2dbl (arg1
))));
3551 SCM_WTA_DISPATCH_1 (*SCM_SUBR_GENERIC (proc
), arg1
,
3552 SCM_ARG1
, SCM_SYMBOL_CHARS (SCM_SNAME (proc
)));
3555 unsigned char pattern
= (scm_t_bits
) SCM_SUBRF (proc
);
3558 SCM_ASSERT (SCM_CONSP (arg1
), arg1
, SCM_ARG1
,
3559 SCM_SYMBOL_CHARS (SCM_SNAME (proc
)));
3560 arg1
= (pattern
& 1) ? SCM_CAR (arg1
) : SCM_CDR (arg1
);
3565 case scm_tc7_rpsubr
:
3566 RETURN (SCM_BOOL_T
);
3568 RETURN (SCM_SUBRF (proc
) (arg1
, SCM_UNDEFINED
));
3571 RETURN (SCM_SUBRF (proc
) (debug
.info
->a
.args
));
3573 RETURN (SCM_SUBRF (proc
) (scm_list_1 (arg1
)));
3576 if (!SCM_SMOB_APPLICABLE_P (proc
))
3578 RETURN (SCM_SMOB_APPLY_1 (proc
, arg1
));
3582 proc
= SCM_CCLO_SUBR (proc
);
3584 debug
.info
->a
.args
= scm_cons (arg1
, debug
.info
->a
.args
);
3585 debug
.info
->a
.proc
= proc
;
3589 proc
= SCM_PROCEDURE (proc
);
3591 debug
.info
->a
.proc
= proc
;
3593 if (!SCM_CLOSUREP (proc
))
3596 case scm_tcs_closures
:
3599 const SCM formals
= SCM_CLOSURE_FORMALS (proc
);
3600 if (SCM_NULLP (formals
)
3601 || (SCM_CONSP (formals
) && SCM_CONSP (SCM_CDR (formals
))))
3602 goto umwrongnumargs
;
3603 x
= SCM_CLOSURE_BODY (proc
);
3605 env
= SCM_EXTEND_ENV (formals
,
3609 env
= SCM_EXTEND_ENV (formals
,
3613 goto nontoplevel_begin
;
3615 case scm_tcs_struct
:
3616 if (SCM_OBJ_CLASS_FLAGS (proc
) & SCM_CLASSF_PURE_GENERIC
)
3618 x
= SCM_ENTITY_PROCEDURE (proc
);
3620 arg1
= debug
.info
->a
.args
;
3622 arg1
= scm_list_1 (arg1
);
3626 else if (SCM_I_OPERATORP (proc
))
3630 proc
= (SCM_I_ENTITYP (proc
)
3631 ? SCM_ENTITY_PROCEDURE (proc
)
3632 : SCM_OPERATOR_PROCEDURE (proc
));
3634 debug
.info
->a
.args
= scm_cons (arg1
, debug
.info
->a
.args
);
3635 debug
.info
->a
.proc
= proc
;
3641 case scm_tc7_subr_2
:
3642 case scm_tc7_subr_0
:
3643 case scm_tc7_subr_3
:
3644 case scm_tc7_lsubr_2
:
3645 scm_wrong_num_args (proc
);
3651 arg2
= EVALCAR (x
, env
);
3653 scm_wrong_num_args (proc
);
3655 { /* have two or more arguments */
3657 debug
.info
->a
.args
= scm_list_2 (arg1
, arg2
);
3660 if (SCM_NULLP (x
)) {
3663 SCM_ASRTGO (!SCM_IMP (proc
), badfun
);
3664 switch (SCM_TYP7 (proc
))
3665 { /* have two arguments */
3666 case scm_tc7_subr_2
:
3667 case scm_tc7_subr_2o
:
3668 RETURN (SCM_SUBRF (proc
) (arg1
, arg2
));
3671 RETURN (SCM_SUBRF (proc
) (debug
.info
->a
.args
));
3673 RETURN (SCM_SUBRF (proc
) (scm_list_2 (arg1
, arg2
)));
3675 case scm_tc7_lsubr_2
:
3676 RETURN (SCM_SUBRF (proc
) (arg1
, arg2
, SCM_EOL
));
3677 case scm_tc7_rpsubr
:
3679 RETURN (SCM_SUBRF (proc
) (arg1
, arg2
));
3681 if (!SCM_SMOB_APPLICABLE_P (proc
))
3683 RETURN (SCM_SMOB_APPLY_2 (proc
, arg1
, arg2
));
3687 RETURN (SCM_APPLY (SCM_CCLO_SUBR (proc
),
3688 scm_cons (proc
, debug
.info
->a
.args
),
3691 RETURN (SCM_APPLY (SCM_CCLO_SUBR (proc
),
3692 scm_cons2 (proc
, arg1
,
3699 case scm_tcs_struct
:
3700 if (SCM_OBJ_CLASS_FLAGS (proc
) & SCM_CLASSF_PURE_GENERIC
)
3702 x
= SCM_ENTITY_PROCEDURE (proc
);
3704 arg1
= debug
.info
->a
.args
;
3706 arg1
= scm_list_2 (arg1
, arg2
);
3710 else if (SCM_I_OPERATORP (proc
))
3714 RETURN (SCM_APPLY (SCM_I_ENTITYP (proc
)
3715 ? SCM_ENTITY_PROCEDURE (proc
)
3716 : SCM_OPERATOR_PROCEDURE (proc
),
3717 scm_cons (proc
, debug
.info
->a
.args
),
3720 RETURN (SCM_APPLY (SCM_I_ENTITYP (proc
)
3721 ? SCM_ENTITY_PROCEDURE (proc
)
3722 : SCM_OPERATOR_PROCEDURE (proc
),
3723 scm_cons2 (proc
, arg1
,
3733 case scm_tc7_subr_0
:
3736 case scm_tc7_subr_1o
:
3737 case scm_tc7_subr_1
:
3738 case scm_tc7_subr_3
:
3739 scm_wrong_num_args (proc
);
3743 proc
= SCM_PROCEDURE (proc
);
3745 debug
.info
->a
.proc
= proc
;
3747 if (!SCM_CLOSUREP (proc
))
3750 case scm_tcs_closures
:
3753 const SCM formals
= SCM_CLOSURE_FORMALS (proc
);
3754 if (SCM_NULLP (formals
)
3755 || (SCM_CONSP (formals
)
3756 && (SCM_NULLP (SCM_CDR (formals
))
3757 || (SCM_CONSP (SCM_CDR (formals
))
3758 && SCM_CONSP (SCM_CDDR (formals
))))))
3759 goto umwrongnumargs
;
3761 env
= SCM_EXTEND_ENV (formals
,
3765 env
= SCM_EXTEND_ENV (formals
,
3766 scm_list_2 (arg1
, arg2
),
3769 x
= SCM_CLOSURE_BODY (proc
);
3770 goto nontoplevel_begin
;
3775 scm_wrong_num_args (proc
);
3777 debug
.info
->a
.args
= scm_cons2 (arg1
, arg2
,
3778 deval_args (x
, env
, proc
,
3779 SCM_CDRLOC (SCM_CDR (debug
.info
->a
.args
))));
3783 SCM_ASRTGO (!SCM_IMP (proc
), badfun
);
3784 switch (SCM_TYP7 (proc
))
3785 { /* have 3 or more arguments */
3787 case scm_tc7_subr_3
:
3788 if (!SCM_NULLP (SCM_CDR (x
)))
3789 scm_wrong_num_args (proc
);
3791 RETURN (SCM_SUBRF (proc
) (arg1
, arg2
,
3792 SCM_CADDR (debug
.info
->a
.args
)));
3794 arg1
= SCM_SUBRF(proc
)(arg1
, arg2
);
3795 arg2
= SCM_CDDR (debug
.info
->a
.args
);
3798 arg1
= SCM_SUBRF(proc
)(arg1
, SCM_CAR (arg2
));
3799 arg2
= SCM_CDR (arg2
);
3801 while (SCM_NIMP (arg2
));
3803 case scm_tc7_rpsubr
:
3804 if (SCM_FALSEP (SCM_SUBRF (proc
) (arg1
, arg2
)))
3805 RETURN (SCM_BOOL_F
);
3806 arg1
= SCM_CDDR (debug
.info
->a
.args
);
3809 if (SCM_FALSEP (SCM_SUBRF (proc
) (arg2
, SCM_CAR (arg1
))))
3810 RETURN (SCM_BOOL_F
);
3811 arg2
= SCM_CAR (arg1
);
3812 arg1
= SCM_CDR (arg1
);
3814 while (SCM_NIMP (arg1
));
3815 RETURN (SCM_BOOL_T
);
3816 case scm_tc7_lsubr_2
:
3817 RETURN (SCM_SUBRF (proc
) (arg1
, arg2
,
3818 SCM_CDDR (debug
.info
->a
.args
)));
3820 RETURN (SCM_SUBRF (proc
) (debug
.info
->a
.args
));
3822 if (!SCM_SMOB_APPLICABLE_P (proc
))
3824 RETURN (SCM_SMOB_APPLY_3 (proc
, arg1
, arg2
,
3825 SCM_CDDR (debug
.info
->a
.args
)));
3829 proc
= SCM_PROCEDURE (proc
);
3830 debug
.info
->a
.proc
= proc
;
3831 if (!SCM_CLOSUREP (proc
))
3834 case scm_tcs_closures
:
3836 const SCM formals
= SCM_CLOSURE_FORMALS (proc
);
3837 if (SCM_NULLP (formals
)
3838 || (SCM_CONSP (formals
)
3839 && (SCM_NULLP (SCM_CDR (formals
))
3840 || (SCM_CONSP (SCM_CDR (formals
))
3841 && scm_badargsp (SCM_CDDR (formals
), x
)))))
3842 goto umwrongnumargs
;
3843 SCM_SET_ARGSREADY (debug
);
3844 env
= SCM_EXTEND_ENV (formals
,
3847 x
= SCM_CLOSURE_BODY (proc
);
3848 goto nontoplevel_begin
;
3851 case scm_tc7_subr_3
:
3852 if (!SCM_NULLP (SCM_CDR (x
)))
3853 scm_wrong_num_args (proc
);
3855 RETURN (SCM_SUBRF (proc
) (arg1
, arg2
, EVALCAR (x
, env
)));
3857 arg1
= SCM_SUBRF (proc
) (arg1
, arg2
);
3860 arg1
= SCM_SUBRF(proc
)(arg1
, EVALCAR(x
, env
));
3863 while (SCM_NIMP (x
));
3865 case scm_tc7_rpsubr
:
3866 if (SCM_FALSEP (SCM_SUBRF (proc
) (arg1
, arg2
)))
3867 RETURN (SCM_BOOL_F
);
3870 arg1
= EVALCAR (x
, env
);
3871 if (SCM_FALSEP (SCM_SUBRF (proc
) (arg2
, arg1
)))
3872 RETURN (SCM_BOOL_F
);
3876 while (SCM_NIMP (x
));
3877 RETURN (SCM_BOOL_T
);
3878 case scm_tc7_lsubr_2
:
3879 RETURN (SCM_SUBRF (proc
) (arg1
, arg2
, scm_eval_args (x
, env
, proc
)));
3881 RETURN (SCM_SUBRF (proc
) (scm_cons2 (arg1
,
3883 scm_eval_args (x
, env
, proc
))));
3885 if (!SCM_SMOB_APPLICABLE_P (proc
))
3887 RETURN (SCM_SMOB_APPLY_3 (proc
, arg1
, arg2
,
3888 scm_eval_args (x
, env
, proc
)));
3892 proc
= SCM_PROCEDURE (proc
);
3893 if (!SCM_CLOSUREP (proc
))
3896 case scm_tcs_closures
:
3898 const SCM formals
= SCM_CLOSURE_FORMALS (proc
);
3899 if (SCM_NULLP (formals
)
3900 || (SCM_CONSP (formals
)
3901 && (SCM_NULLP (SCM_CDR (formals
))
3902 || (SCM_CONSP (SCM_CDR (formals
))
3903 && scm_badargsp (SCM_CDDR (formals
), x
)))))
3904 goto umwrongnumargs
;
3905 env
= SCM_EXTEND_ENV (formals
,
3908 scm_eval_args (x
, env
, proc
)),
3910 x
= SCM_CLOSURE_BODY (proc
);
3911 goto nontoplevel_begin
;
3914 case scm_tcs_struct
:
3915 if (SCM_OBJ_CLASS_FLAGS (proc
) & SCM_CLASSF_PURE_GENERIC
)
3918 arg1
= debug
.info
->a
.args
;
3920 arg1
= scm_cons2 (arg1
, arg2
, scm_eval_args (x
, env
, proc
));
3922 x
= SCM_ENTITY_PROCEDURE (proc
);
3925 else if (SCM_I_OPERATORP (proc
))
3929 case scm_tc7_subr_2
:
3930 case scm_tc7_subr_1o
:
3931 case scm_tc7_subr_2o
:
3932 case scm_tc7_subr_0
:
3935 case scm_tc7_subr_1
:
3936 scm_wrong_num_args (proc
);
3944 if (scm_check_exit_p
&& SCM_TRAPS_P
)
3945 if (SCM_EXIT_FRAME_P
|| (SCM_TRACE_P
&& SCM_TRACED_FRAME_P (debug
)))
3947 SCM_CLEAR_TRACED_FRAME (debug
);
3948 if (SCM_CHEAPTRAPS_P
)
3949 arg1
= scm_make_debugobj (&debug
);
3953 SCM val
= scm_make_continuation (&first
);
3964 scm_call_3 (SCM_EXIT_FRAME_HDLR
, scm_sym_exit_frame
, arg1
, proc
);
3968 scm_last_debug_frame
= debug
.prev
;
3974 /* SECTION: This code is compiled once.
3981 /* Simple procedure calls
3985 scm_call_0 (SCM proc
)
3987 return scm_apply (proc
, SCM_EOL
, SCM_EOL
);
3991 scm_call_1 (SCM proc
, SCM arg1
)
3993 return scm_apply (proc
, arg1
, scm_listofnull
);
3997 scm_call_2 (SCM proc
, SCM arg1
, SCM arg2
)
3999 return scm_apply (proc
, arg1
, scm_cons (arg2
, scm_listofnull
));
4003 scm_call_3 (SCM proc
, SCM arg1
, SCM arg2
, SCM arg3
)
4005 return scm_apply (proc
, arg1
, scm_cons2 (arg2
, arg3
, scm_listofnull
));
4009 scm_call_4 (SCM proc
, SCM arg1
, SCM arg2
, SCM arg3
, SCM arg4
)
4011 return scm_apply (proc
, arg1
, scm_cons2 (arg2
, arg3
,
4012 scm_cons (arg4
, scm_listofnull
)));
4015 /* Simple procedure applies
4019 scm_apply_0 (SCM proc
, SCM args
)
4021 return scm_apply (proc
, args
, SCM_EOL
);
4025 scm_apply_1 (SCM proc
, SCM arg1
, SCM args
)
4027 return scm_apply (proc
, scm_cons (arg1
, args
), SCM_EOL
);
4031 scm_apply_2 (SCM proc
, SCM arg1
, SCM arg2
, SCM args
)
4033 return scm_apply (proc
, scm_cons2 (arg1
, arg2
, args
), SCM_EOL
);
4037 scm_apply_3 (SCM proc
, SCM arg1
, SCM arg2
, SCM arg3
, SCM args
)
4039 return scm_apply (proc
, scm_cons (arg1
, scm_cons2 (arg2
, arg3
, args
)),
4043 /* This code processes the arguments to apply:
4045 (apply PROC ARG1 ... ARGS)
4047 Given a list (ARG1 ... ARGS), this function conses the ARG1
4048 ... arguments onto the front of ARGS, and returns the resulting
4049 list. Note that ARGS is a list; thus, the argument to this
4050 function is a list whose last element is a list.
4052 Apply calls this function, and applies PROC to the elements of the
4053 result. apply:nconc2last takes care of building the list of
4054 arguments, given (ARG1 ... ARGS).
4056 Rather than do new consing, apply:nconc2last destroys its argument.
4057 On that topic, this code came into my care with the following
4058 beautifully cryptic comment on that topic: "This will only screw
4059 you if you do (scm_apply scm_apply '( ... ))" If you know what
4060 they're referring to, send me a patch to this comment. */
4062 SCM_DEFINE (scm_nconc2last
, "apply:nconc2last", 1, 0, 0,
4064 "Given a list (@var{arg1} @dots{} @var{args}), this function\n"
4065 "conses the @var{arg1} @dots{} arguments onto the front of\n"
4066 "@var{args}, and returns the resulting list. Note that\n"
4067 "@var{args} is a list; thus, the argument to this function is\n"
4068 "a list whose last element is a list.\n"
4069 "Note: Rather than do new consing, @code{apply:nconc2last}\n"
4070 "destroys its argument, so use with care.")
4071 #define FUNC_NAME s_scm_nconc2last
4074 SCM_VALIDATE_NONEMPTYLIST (1, lst
);
4076 while (!SCM_NULLP (SCM_CDR (*lloc
))) /* Perhaps should be
4077 SCM_NULL_OR_NIL_P, but not
4078 needed in 99.99% of cases,
4079 and it could seriously hurt
4080 performance. - Neil */
4081 lloc
= SCM_CDRLOC (*lloc
);
4082 SCM_ASSERT (scm_ilength (SCM_CAR (*lloc
)) >= 0, lst
, SCM_ARG1
, FUNC_NAME
);
4083 *lloc
= SCM_CAR (*lloc
);
4091 /* SECTION: When DEVAL is defined this code yields scm_dapply.
4092 * It is compiled twice.
4097 scm_apply (SCM proc
, SCM arg1
, SCM args
)
4103 scm_dapply (SCM proc
, SCM arg1
, SCM args
)
4108 /* Apply a function to a list of arguments.
4110 This function is exported to the Scheme level as taking two
4111 required arguments and a tail argument, as if it were:
4112 (lambda (proc arg1 . args) ...)
4113 Thus, if you just have a list of arguments to pass to a procedure,
4114 pass the list as ARG1, and '() for ARGS. If you have some fixed
4115 args, pass the first as ARG1, then cons any remaining fixed args
4116 onto the front of your argument list, and pass that as ARGS. */
4119 SCM_APPLY (SCM proc
, SCM arg1
, SCM args
)
4122 scm_t_debug_frame debug
;
4123 scm_t_debug_info debug_vect_body
;
4124 debug
.prev
= scm_last_debug_frame
;
4125 debug
.status
= SCM_APPLYFRAME
;
4126 debug
.vect
= &debug_vect_body
;
4127 debug
.vect
[0].a
.proc
= proc
;
4128 debug
.vect
[0].a
.args
= SCM_EOL
;
4129 scm_last_debug_frame
= &debug
;
4132 return scm_dapply (proc
, arg1
, args
);
4135 SCM_ASRTGO (SCM_NIMP (proc
), badproc
);
4137 /* If ARGS is the empty list, then we're calling apply with only two
4138 arguments --- ARG1 is the list of arguments for PROC. Whatever
4139 the case, futz with things so that ARG1 is the first argument to
4140 give to PROC (or SCM_UNDEFINED if no args), and ARGS contains the
4143 Setting the debug apply frame args this way is pretty messy.
4144 Perhaps we should store arg1 and args directly in the frame as
4145 received, and let scm_frame_arguments unpack them, because that's
4146 a relatively rare operation. This works for now; if the Guile
4147 developer archives are still around, see Mikael's post of
4149 if (SCM_NULLP (args
))
4151 if (SCM_NULLP (arg1
))
4153 arg1
= SCM_UNDEFINED
;
4155 debug
.vect
[0].a
.args
= SCM_EOL
;
4161 debug
.vect
[0].a
.args
= arg1
;
4163 args
= SCM_CDR (arg1
);
4164 arg1
= SCM_CAR (arg1
);
4169 args
= scm_nconc2last (args
);
4171 debug
.vect
[0].a
.args
= scm_cons (arg1
, args
);
4175 if (SCM_ENTER_FRAME_P
&& SCM_TRAPS_P
)
4178 if (SCM_CHEAPTRAPS_P
)
4179 tmp
= scm_make_debugobj (&debug
);
4184 tmp
= scm_make_continuation (&first
);
4189 scm_call_2 (SCM_ENTER_FRAME_HDLR
, scm_sym_enter_frame
, tmp
);
4196 switch (SCM_TYP7 (proc
))
4198 case scm_tc7_subr_2o
:
4199 args
= SCM_NULLP (args
) ? SCM_UNDEFINED
: SCM_CAR (args
);
4200 RETURN (SCM_SUBRF (proc
) (arg1
, args
));
4201 case scm_tc7_subr_2
:
4202 if (SCM_NULLP (args
) || !SCM_NULLP (SCM_CDR (args
)))
4203 scm_wrong_num_args (proc
);
4204 args
= SCM_CAR (args
);
4205 RETURN (SCM_SUBRF (proc
) (arg1
, args
));
4206 case scm_tc7_subr_0
:
4207 if (!SCM_UNBNDP (arg1
))
4208 scm_wrong_num_args (proc
);
4210 RETURN (SCM_SUBRF (proc
) ());
4211 case scm_tc7_subr_1
:
4212 if (SCM_UNBNDP (arg1
))
4213 scm_wrong_num_args (proc
);
4214 case scm_tc7_subr_1o
:
4215 if (!SCM_NULLP (args
))
4216 scm_wrong_num_args (proc
);
4218 RETURN (SCM_SUBRF (proc
) (arg1
));
4220 if (SCM_UNBNDP (arg1
) || !SCM_NULLP (args
))
4221 scm_wrong_num_args (proc
);
4222 if (SCM_INUMP (arg1
))
4224 RETURN (scm_make_real (SCM_DSUBRF (proc
) ((double) SCM_INUM (arg1
))));
4226 else if (SCM_REALP (arg1
))
4228 RETURN (scm_make_real (SCM_DSUBRF (proc
) (SCM_REAL_VALUE (arg1
))));
4230 else if (SCM_BIGP (arg1
))
4231 RETURN (scm_make_real (SCM_DSUBRF (proc
) (scm_i_big2dbl (arg1
))));
4232 SCM_WTA_DISPATCH_1 (*SCM_SUBR_GENERIC (proc
), arg1
,
4233 SCM_ARG1
, SCM_SYMBOL_CHARS (SCM_SNAME (proc
)));
4235 if (SCM_UNBNDP (arg1
) || !SCM_NULLP (args
))
4236 scm_wrong_num_args (proc
);
4238 unsigned char pattern
= (scm_t_bits
) SCM_SUBRF (proc
);
4241 SCM_ASSERT (SCM_CONSP (arg1
), arg1
, SCM_ARG1
,
4242 SCM_SYMBOL_CHARS (SCM_SNAME (proc
)));
4243 arg1
= (pattern
& 1) ? SCM_CAR (arg1
) : SCM_CDR (arg1
);
4248 case scm_tc7_subr_3
:
4249 if (SCM_NULLP (args
)
4250 || SCM_NULLP (SCM_CDR (args
))
4251 || !SCM_NULLP (SCM_CDDR (args
)))
4252 scm_wrong_num_args (proc
);
4254 RETURN (SCM_SUBRF (proc
) (arg1
, SCM_CAR (args
), SCM_CADR (args
)));
4257 RETURN (SCM_SUBRF (proc
) (SCM_UNBNDP (arg1
) ? SCM_EOL
: debug
.vect
[0].a
.args
));
4259 RETURN (SCM_SUBRF (proc
) (SCM_UNBNDP (arg1
) ? SCM_EOL
: scm_cons (arg1
, args
)));
4261 case scm_tc7_lsubr_2
:
4262 if (!SCM_CONSP (args
))
4263 scm_wrong_num_args (proc
);
4265 RETURN (SCM_SUBRF (proc
) (arg1
, SCM_CAR (args
), SCM_CDR (args
)));
4267 if (SCM_NULLP (args
))
4268 RETURN (SCM_SUBRF (proc
) (arg1
, SCM_UNDEFINED
));
4269 while (SCM_NIMP (args
))
4271 SCM_ASSERT (SCM_CONSP (args
), args
, SCM_ARG2
, "apply");
4272 arg1
= SCM_SUBRF (proc
) (arg1
, SCM_CAR (args
));
4273 args
= SCM_CDR (args
);
4276 case scm_tc7_rpsubr
:
4277 if (SCM_NULLP (args
))
4278 RETURN (SCM_BOOL_T
);
4279 while (SCM_NIMP (args
))
4281 SCM_ASSERT (SCM_CONSP (args
), args
, SCM_ARG2
, "apply");
4282 if (SCM_FALSEP (SCM_SUBRF (proc
) (arg1
, SCM_CAR (args
))))
4283 RETURN (SCM_BOOL_F
);
4284 arg1
= SCM_CAR (args
);
4285 args
= SCM_CDR (args
);
4287 RETURN (SCM_BOOL_T
);
4288 case scm_tcs_closures
:
4290 arg1
= (SCM_UNBNDP (arg1
) ? SCM_EOL
: debug
.vect
[0].a
.args
);
4292 arg1
= (SCM_UNBNDP (arg1
) ? SCM_EOL
: scm_cons (arg1
, args
));
4294 if (scm_badargsp (SCM_CLOSURE_FORMALS (proc
), arg1
))
4295 scm_wrong_num_args (proc
);
4297 /* Copy argument list */
4302 SCM tl
= args
= scm_cons (SCM_CAR (arg1
), SCM_UNSPECIFIED
);
4303 for (arg1
= SCM_CDR (arg1
); SCM_CONSP (arg1
); arg1
= SCM_CDR (arg1
))
4305 SCM_SETCDR (tl
, scm_cons (SCM_CAR (arg1
), SCM_UNSPECIFIED
));
4308 SCM_SETCDR (tl
, arg1
);
4311 args
= SCM_EXTEND_ENV (SCM_CLOSURE_FORMALS (proc
),
4314 proc
= SCM_CLOSURE_BODY (proc
);
4316 arg1
= SCM_CDR (proc
);
4317 while (!SCM_NULLP (arg1
))
4319 if (SCM_IMP (SCM_CAR (proc
)))
4321 if (SCM_ISYMP (SCM_CAR (proc
)))
4323 scm_rec_mutex_lock (&source_mutex
);
4324 /* check for race condition */
4325 if (SCM_ISYMP (SCM_CAR (proc
)))
4326 proc
= scm_m_expand_body (proc
, args
);
4327 scm_rec_mutex_unlock (&source_mutex
);
4331 SCM_VALIDATE_NON_EMPTY_COMBINATION (SCM_CAR (proc
));
4334 SCM_CEVAL (SCM_CAR (proc
), args
);
4336 arg1
= SCM_CDR (proc
);
4338 RETURN (EVALCAR (proc
, args
));
4340 if (!SCM_SMOB_APPLICABLE_P (proc
))
4342 if (SCM_UNBNDP (arg1
))
4343 RETURN (SCM_SMOB_APPLY_0 (proc
));
4344 else if (SCM_NULLP (args
))
4345 RETURN (SCM_SMOB_APPLY_1 (proc
, arg1
));
4346 else if (SCM_NULLP (SCM_CDR (args
)))
4347 RETURN (SCM_SMOB_APPLY_2 (proc
, arg1
, SCM_CAR (args
)));
4349 RETURN (SCM_SMOB_APPLY_3 (proc
, arg1
, SCM_CAR (args
), SCM_CDR (args
)));
4352 args
= (SCM_UNBNDP(arg1
) ? SCM_EOL
: debug
.vect
[0].a
.args
);
4354 proc
= SCM_CCLO_SUBR (proc
);
4355 debug
.vect
[0].a
.proc
= proc
;
4356 debug
.vect
[0].a
.args
= scm_cons (arg1
, args
);
4358 args
= (SCM_UNBNDP(arg1
) ? SCM_EOL
: scm_cons (arg1
, args
));
4360 proc
= SCM_CCLO_SUBR (proc
);
4364 proc
= SCM_PROCEDURE (proc
);
4366 debug
.vect
[0].a
.proc
= proc
;
4369 case scm_tcs_struct
:
4370 if (SCM_OBJ_CLASS_FLAGS (proc
) & SCM_CLASSF_PURE_GENERIC
)
4373 args
= (SCM_UNBNDP(arg1
) ? SCM_EOL
: debug
.vect
[0].a
.args
);
4375 args
= (SCM_UNBNDP(arg1
) ? SCM_EOL
: scm_cons (arg1
, args
));
4377 RETURN (scm_apply_generic (proc
, args
));
4379 else if (SCM_I_OPERATORP (proc
))
4383 args
= (SCM_UNBNDP(arg1
) ? SCM_EOL
: debug
.vect
[0].a
.args
);
4385 args
= (SCM_UNBNDP(arg1
) ? SCM_EOL
: scm_cons (arg1
, args
));
4388 proc
= (SCM_I_ENTITYP (proc
)
4389 ? SCM_ENTITY_PROCEDURE (proc
)
4390 : SCM_OPERATOR_PROCEDURE (proc
));
4392 debug
.vect
[0].a
.proc
= proc
;
4393 debug
.vect
[0].a
.args
= scm_cons (arg1
, args
);
4395 if (SCM_NIMP (proc
))
4404 scm_wrong_type_arg ("apply", SCM_ARG1
, proc
);
4408 if (scm_check_exit_p
&& SCM_TRAPS_P
)
4409 if (SCM_EXIT_FRAME_P
|| (SCM_TRACE_P
&& SCM_TRACED_FRAME_P (debug
)))
4411 SCM_CLEAR_TRACED_FRAME (debug
);
4412 if (SCM_CHEAPTRAPS_P
)
4413 arg1
= scm_make_debugobj (&debug
);
4417 SCM val
= scm_make_continuation (&first
);
4428 scm_call_3 (SCM_EXIT_FRAME_HDLR
, scm_sym_exit_frame
, arg1
, proc
);
4432 scm_last_debug_frame
= debug
.prev
;
4438 /* SECTION: The rest of this file is only read once.
4445 * Trampolines make it possible to move procedure application dispatch
4446 * outside inner loops. The motivation was clean implementation of
4447 * efficient replacements of R5RS primitives in SRFI-1.
4449 * The semantics is clear: scm_trampoline_N returns an optimized
4450 * version of scm_call_N (or NULL if the procedure isn't applicable
4453 * Applying the optimization to map and for-each increased efficiency
4454 * noticeably. For example, (map abs ls) is now 8 times faster than
4459 call_subr0_0 (SCM proc
)
4461 return SCM_SUBRF (proc
) ();
4465 call_subr1o_0 (SCM proc
)
4467 return SCM_SUBRF (proc
) (SCM_UNDEFINED
);
4471 call_lsubr_0 (SCM proc
)
4473 return SCM_SUBRF (proc
) (SCM_EOL
);
4477 scm_i_call_closure_0 (SCM proc
)
4479 const SCM env
= SCM_EXTEND_ENV (SCM_CLOSURE_FORMALS (proc
),
4482 const SCM result
= scm_eval_body (SCM_CLOSURE_BODY (proc
), env
);
4487 scm_trampoline_0 (SCM proc
)
4489 scm_t_trampoline_0 trampoline
;
4494 switch (SCM_TYP7 (proc
))
4496 case scm_tc7_subr_0
:
4497 trampoline
= call_subr0_0
;
4499 case scm_tc7_subr_1o
:
4500 trampoline
= call_subr1o_0
;
4503 trampoline
= call_lsubr_0
;
4505 case scm_tcs_closures
:
4507 SCM formals
= SCM_CLOSURE_FORMALS (proc
);
4508 if (SCM_NULLP (formals
) || !SCM_CONSP (formals
))
4509 trampoline
= scm_i_call_closure_0
;
4514 case scm_tcs_struct
:
4515 if (SCM_OBJ_CLASS_FLAGS (proc
) & SCM_CLASSF_PURE_GENERIC
)
4516 trampoline
= scm_call_generic_0
;
4517 else if (SCM_I_OPERATORP (proc
))
4518 trampoline
= scm_call_0
;
4523 if (SCM_SMOB_APPLICABLE_P (proc
))
4524 trampoline
= SCM_SMOB_DESCRIPTOR (proc
).apply_0
;
4529 case scm_tc7_rpsubr
:
4532 trampoline
= scm_call_0
;
4535 return NULL
; /* not applicable on zero arguments */
4537 /* We only reach this point if a valid trampoline was determined. */
4539 /* If debugging is enabled, we want to see all calls to proc on the stack.
4540 * Thus, we replace the trampoline shortcut with scm_call_0. */
4548 call_subr1_1 (SCM proc
, SCM arg1
)
4550 return SCM_SUBRF (proc
) (arg1
);
4554 call_subr2o_1 (SCM proc
, SCM arg1
)
4556 return SCM_SUBRF (proc
) (arg1
, SCM_UNDEFINED
);
4560 call_lsubr_1 (SCM proc
, SCM arg1
)
4562 return SCM_SUBRF (proc
) (scm_list_1 (arg1
));
4566 call_dsubr_1 (SCM proc
, SCM arg1
)
4568 if (SCM_INUMP (arg1
))
4570 RETURN (scm_make_real (SCM_DSUBRF (proc
) ((double) SCM_INUM (arg1
))));
4572 else if (SCM_REALP (arg1
))
4574 RETURN (scm_make_real (SCM_DSUBRF (proc
) (SCM_REAL_VALUE (arg1
))));
4576 else if (SCM_BIGP (arg1
))
4577 RETURN (scm_make_real (SCM_DSUBRF (proc
) (scm_i_big2dbl (arg1
))));
4578 SCM_WTA_DISPATCH_1 (*SCM_SUBR_GENERIC (proc
), arg1
,
4579 SCM_ARG1
, SCM_SYMBOL_CHARS (SCM_SNAME (proc
)));
4583 call_cxr_1 (SCM proc
, SCM arg1
)
4585 unsigned char pattern
= (scm_t_bits
) SCM_SUBRF (proc
);
4588 SCM_ASSERT (SCM_CONSP (arg1
), arg1
, SCM_ARG1
,
4589 SCM_SYMBOL_CHARS (SCM_SNAME (proc
)));
4590 arg1
= (pattern
& 1) ? SCM_CAR (arg1
) : SCM_CDR (arg1
);
4597 call_closure_1 (SCM proc
, SCM arg1
)
4599 const SCM env
= SCM_EXTEND_ENV (SCM_CLOSURE_FORMALS (proc
),
4602 const SCM result
= scm_eval_body (SCM_CLOSURE_BODY (proc
), env
);
4607 scm_trampoline_1 (SCM proc
)
4609 scm_t_trampoline_1 trampoline
;
4614 switch (SCM_TYP7 (proc
))
4616 case scm_tc7_subr_1
:
4617 case scm_tc7_subr_1o
:
4618 trampoline
= call_subr1_1
;
4620 case scm_tc7_subr_2o
:
4621 trampoline
= call_subr2o_1
;
4624 trampoline
= call_lsubr_1
;
4627 trampoline
= call_dsubr_1
;
4630 trampoline
= call_cxr_1
;
4632 case scm_tcs_closures
:
4634 SCM formals
= SCM_CLOSURE_FORMALS (proc
);
4635 if (!SCM_NULLP (formals
)
4636 && (!SCM_CONSP (formals
) || !SCM_CONSP (SCM_CDR (formals
))))
4637 trampoline
= call_closure_1
;
4642 case scm_tcs_struct
:
4643 if (SCM_OBJ_CLASS_FLAGS (proc
) & SCM_CLASSF_PURE_GENERIC
)
4644 trampoline
= scm_call_generic_1
;
4645 else if (SCM_I_OPERATORP (proc
))
4646 trampoline
= scm_call_1
;
4651 if (SCM_SMOB_APPLICABLE_P (proc
))
4652 trampoline
= SCM_SMOB_DESCRIPTOR (proc
).apply_1
;
4657 case scm_tc7_rpsubr
:
4660 trampoline
= scm_call_1
;
4663 return NULL
; /* not applicable on one arg */
4665 /* We only reach this point if a valid trampoline was determined. */
4667 /* If debugging is enabled, we want to see all calls to proc on the stack.
4668 * Thus, we replace the trampoline shortcut with scm_call_1. */
4676 call_subr2_2 (SCM proc
, SCM arg1
, SCM arg2
)
4678 return SCM_SUBRF (proc
) (arg1
, arg2
);
4682 call_lsubr2_2 (SCM proc
, SCM arg1
, SCM arg2
)
4684 return SCM_SUBRF (proc
) (arg1
, arg2
, SCM_EOL
);
4688 call_lsubr_2 (SCM proc
, SCM arg1
, SCM arg2
)
4690 return SCM_SUBRF (proc
) (scm_list_2 (arg1
, arg2
));
4694 call_closure_2 (SCM proc
, SCM arg1
, SCM arg2
)
4696 const SCM env
= SCM_EXTEND_ENV (SCM_CLOSURE_FORMALS (proc
),
4697 scm_list_2 (arg1
, arg2
),
4699 const SCM result
= scm_eval_body (SCM_CLOSURE_BODY (proc
), env
);
4704 scm_trampoline_2 (SCM proc
)
4706 scm_t_trampoline_2 trampoline
;
4711 switch (SCM_TYP7 (proc
))
4713 case scm_tc7_subr_2
:
4714 case scm_tc7_subr_2o
:
4715 case scm_tc7_rpsubr
:
4717 trampoline
= call_subr2_2
;
4719 case scm_tc7_lsubr_2
:
4720 trampoline
= call_lsubr2_2
;
4723 trampoline
= call_lsubr_2
;
4725 case scm_tcs_closures
:
4727 SCM formals
= SCM_CLOSURE_FORMALS (proc
);
4728 if (!SCM_NULLP (formals
)
4729 && (!SCM_CONSP (formals
)
4730 || (!SCM_NULLP (SCM_CDR (formals
))
4731 && (!SCM_CONSP (SCM_CDR (formals
))
4732 || !SCM_CONSP (SCM_CDDR (formals
))))))
4733 trampoline
= call_closure_2
;
4738 case scm_tcs_struct
:
4739 if (SCM_OBJ_CLASS_FLAGS (proc
) & SCM_CLASSF_PURE_GENERIC
)
4740 trampoline
= scm_call_generic_2
;
4741 else if (SCM_I_OPERATORP (proc
))
4742 trampoline
= scm_call_2
;
4747 if (SCM_SMOB_APPLICABLE_P (proc
))
4748 trampoline
= SCM_SMOB_DESCRIPTOR (proc
).apply_2
;
4754 trampoline
= scm_call_2
;
4757 return NULL
; /* not applicable on two args */
4759 /* We only reach this point if a valid trampoline was determined. */
4761 /* If debugging is enabled, we want to see all calls to proc on the stack.
4762 * Thus, we replace the trampoline shortcut with scm_call_2. */
4769 /* Typechecking for multi-argument MAP and FOR-EACH.
4771 Verify that each element of the vector ARGV, except for the first,
4772 is a proper list whose length is LEN. Attribute errors to WHO,
4773 and claim that the i'th element of ARGV is WHO's i+2'th argument. */
4775 check_map_args (SCM argv
,
4782 SCM
const *ve
= SCM_VELTS (argv
);
4785 for (i
= SCM_VECTOR_LENGTH (argv
) - 1; i
>= 1; i
--)
4787 long elt_len
= scm_ilength (ve
[i
]);
4792 scm_apply_generic (gf
, scm_cons (proc
, args
));
4794 scm_wrong_type_arg (who
, i
+ 2, ve
[i
]);
4798 scm_out_of_range_pos (who
, ve
[i
], SCM_MAKINUM (i
+ 2));
4801 scm_remember_upto_here_1 (argv
);
4805 SCM_GPROC (s_map
, "map", 2, 0, 1, scm_map
, g_map
);
4807 /* Note: Currently, scm_map applies PROC to the argument list(s)
4808 sequentially, starting with the first element(s). This is used in
4809 evalext.c where the Scheme procedure `map-in-order', which guarantees
4810 sequential behaviour, is implemented using scm_map. If the
4811 behaviour changes, we need to update `map-in-order'.
4815 scm_map (SCM proc
, SCM arg1
, SCM args
)
4816 #define FUNC_NAME s_map
4821 SCM
const *ve
= &args
; /* Keep args from being optimized away. */
4823 len
= scm_ilength (arg1
);
4824 SCM_GASSERTn (len
>= 0,
4825 g_map
, scm_cons2 (proc
, arg1
, args
), SCM_ARG2
, s_map
);
4826 SCM_VALIDATE_REST_ARGUMENT (args
);
4827 if (SCM_NULLP (args
))
4829 scm_t_trampoline_1 call
= scm_trampoline_1 (proc
);
4830 SCM_GASSERT2 (call
, g_map
, proc
, arg1
, SCM_ARG1
, s_map
);
4831 while (SCM_NIMP (arg1
))
4833 *pres
= scm_list_1 (call (proc
, SCM_CAR (arg1
)));
4834 pres
= SCM_CDRLOC (*pres
);
4835 arg1
= SCM_CDR (arg1
);
4839 if (SCM_NULLP (SCM_CDR (args
)))
4841 SCM arg2
= SCM_CAR (args
);
4842 int len2
= scm_ilength (arg2
);
4843 scm_t_trampoline_2 call
= scm_trampoline_2 (proc
);
4845 g_map
, scm_cons2 (proc
, arg1
, args
), SCM_ARG1
, s_map
);
4846 SCM_GASSERTn (len2
>= 0,
4847 g_map
, scm_cons2 (proc
, arg1
, args
), SCM_ARG3
, s_map
);
4849 SCM_OUT_OF_RANGE (3, arg2
);
4850 while (SCM_NIMP (arg1
))
4852 *pres
= scm_list_1 (call (proc
, SCM_CAR (arg1
), SCM_CAR (arg2
)));
4853 pres
= SCM_CDRLOC (*pres
);
4854 arg1
= SCM_CDR (arg1
);
4855 arg2
= SCM_CDR (arg2
);
4859 arg1
= scm_cons (arg1
, args
);
4860 args
= scm_vector (arg1
);
4861 ve
= SCM_VELTS (args
);
4862 check_map_args (args
, len
, g_map
, proc
, arg1
, s_map
);
4866 for (i
= SCM_VECTOR_LENGTH (args
) - 1; i
>= 0; i
--)
4868 if (SCM_IMP (ve
[i
]))
4870 arg1
= scm_cons (SCM_CAR (ve
[i
]), arg1
);
4871 SCM_VECTOR_SET (args
, i
, SCM_CDR (ve
[i
]));
4873 *pres
= scm_list_1 (scm_apply (proc
, arg1
, SCM_EOL
));
4874 pres
= SCM_CDRLOC (*pres
);
4880 SCM_GPROC (s_for_each
, "for-each", 2, 0, 1, scm_for_each
, g_for_each
);
4883 scm_for_each (SCM proc
, SCM arg1
, SCM args
)
4884 #define FUNC_NAME s_for_each
4886 SCM
const *ve
= &args
; /* Keep args from being optimized away. */
4888 len
= scm_ilength (arg1
);
4889 SCM_GASSERTn (len
>= 0, g_for_each
, scm_cons2 (proc
, arg1
, args
),
4890 SCM_ARG2
, s_for_each
);
4891 SCM_VALIDATE_REST_ARGUMENT (args
);
4892 if (SCM_NULLP (args
))
4894 scm_t_trampoline_1 call
= scm_trampoline_1 (proc
);
4895 SCM_GASSERT2 (call
, g_for_each
, proc
, arg1
, SCM_ARG1
, s_for_each
);
4896 while (SCM_NIMP (arg1
))
4898 call (proc
, SCM_CAR (arg1
));
4899 arg1
= SCM_CDR (arg1
);
4901 return SCM_UNSPECIFIED
;
4903 if (SCM_NULLP (SCM_CDR (args
)))
4905 SCM arg2
= SCM_CAR (args
);
4906 int len2
= scm_ilength (arg2
);
4907 scm_t_trampoline_2 call
= scm_trampoline_2 (proc
);
4908 SCM_GASSERTn (call
, g_for_each
,
4909 scm_cons2 (proc
, arg1
, args
), SCM_ARG1
, s_for_each
);
4910 SCM_GASSERTn (len2
>= 0, g_for_each
,
4911 scm_cons2 (proc
, arg1
, args
), SCM_ARG3
, s_for_each
);
4913 SCM_OUT_OF_RANGE (3, arg2
);
4914 while (SCM_NIMP (arg1
))
4916 call (proc
, SCM_CAR (arg1
), SCM_CAR (arg2
));
4917 arg1
= SCM_CDR (arg1
);
4918 arg2
= SCM_CDR (arg2
);
4920 return SCM_UNSPECIFIED
;
4922 arg1
= scm_cons (arg1
, args
);
4923 args
= scm_vector (arg1
);
4924 ve
= SCM_VELTS (args
);
4925 check_map_args (args
, len
, g_for_each
, proc
, arg1
, s_for_each
);
4929 for (i
= SCM_VECTOR_LENGTH (args
) - 1; i
>= 0; i
--)
4931 if (SCM_IMP (ve
[i
]))
4932 return SCM_UNSPECIFIED
;
4933 arg1
= scm_cons (SCM_CAR (ve
[i
]), arg1
);
4934 SCM_VECTOR_SET (args
, i
, SCM_CDR (ve
[i
]));
4936 scm_apply (proc
, arg1
, SCM_EOL
);
4943 scm_closure (SCM code
, SCM env
)
4946 SCM closcar
= scm_cons (code
, SCM_EOL
);
4947 z
= scm_cell (SCM_UNPACK (closcar
) + scm_tc3_closure
, (scm_t_bits
) env
);
4948 scm_remember_upto_here (closcar
);
4953 scm_t_bits scm_tc16_promise
;
4956 scm_makprom (SCM code
)
4958 SCM_RETURN_NEWSMOB2 (scm_tc16_promise
,
4960 scm_make_rec_mutex ());
4964 promise_free (SCM promise
)
4966 scm_rec_mutex_free (SCM_PROMISE_MUTEX (promise
));
4971 promise_print (SCM exp
, SCM port
, scm_print_state
*pstate
)
4973 int writingp
= SCM_WRITINGP (pstate
);
4974 scm_puts ("#<promise ", port
);
4975 SCM_SET_WRITINGP (pstate
, 1);
4976 scm_iprin1 (SCM_PROMISE_DATA (exp
), port
, pstate
);
4977 SCM_SET_WRITINGP (pstate
, writingp
);
4978 scm_putc ('>', port
);
4982 SCM_DEFINE (scm_force
, "force", 1, 0, 0,
4984 "If the promise @var{x} has not been computed yet, compute and\n"
4985 "return @var{x}, otherwise just return the previously computed\n"
4987 #define FUNC_NAME s_scm_force
4989 SCM_VALIDATE_SMOB (1, promise
, promise
);
4990 scm_rec_mutex_lock (SCM_PROMISE_MUTEX (promise
));
4991 if (!SCM_PROMISE_COMPUTED_P (promise
))
4993 SCM ans
= scm_call_0 (SCM_PROMISE_DATA (promise
));
4994 if (!SCM_PROMISE_COMPUTED_P (promise
))
4996 SCM_SET_PROMISE_DATA (promise
, ans
);
4997 SCM_SET_PROMISE_COMPUTED (promise
);
5000 scm_rec_mutex_unlock (SCM_PROMISE_MUTEX (promise
));
5001 return SCM_PROMISE_DATA (promise
);
5006 SCM_DEFINE (scm_promise_p
, "promise?", 1, 0, 0,
5008 "Return true if @var{obj} is a promise, i.e. a delayed computation\n"
5009 "(@pxref{Delayed evaluation,,,r5rs.info,The Revised^5 Report on Scheme}).")
5010 #define FUNC_NAME s_scm_promise_p
5012 return SCM_BOOL (SCM_TYP16_PREDICATE (scm_tc16_promise
, obj
));
5017 SCM_DEFINE (scm_cons_source
, "cons-source", 3, 0, 0,
5018 (SCM xorig
, SCM x
, SCM y
),
5019 "Create and return a new pair whose car and cdr are @var{x} and @var{y}.\n"
5020 "Any source properties associated with @var{xorig} are also associated\n"
5021 "with the new pair.")
5022 #define FUNC_NAME s_scm_cons_source
5025 z
= scm_cons (x
, y
);
5026 /* Copy source properties possibly associated with xorig. */
5027 p
= scm_whash_lookup (scm_source_whash
, xorig
);
5029 scm_whash_insert (scm_source_whash
, z
, p
);
5035 SCM_DEFINE (scm_copy_tree
, "copy-tree", 1, 0, 0,
5037 "Recursively copy the data tree that is bound to @var{obj}, and return a\n"
5038 "pointer to the new data structure. @code{copy-tree} recurses down the\n"
5039 "contents of both pairs and vectors (since both cons cells and vector\n"
5040 "cells may point to arbitrary objects), and stops recursing when it hits\n"
5041 "any other object.")
5042 #define FUNC_NAME s_scm_copy_tree
5047 if (SCM_VECTORP (obj
))
5049 unsigned long i
= SCM_VECTOR_LENGTH (obj
);
5050 ans
= scm_c_make_vector (i
, SCM_UNSPECIFIED
);
5052 SCM_VECTOR_SET (ans
, i
, scm_copy_tree (SCM_VELTS (obj
)[i
]));
5055 if (!SCM_CONSP (obj
))
5057 ans
= tl
= scm_cons_source (obj
,
5058 scm_copy_tree (SCM_CAR (obj
)),
5060 for (obj
= SCM_CDR (obj
); SCM_CONSP (obj
); obj
= SCM_CDR (obj
))
5062 SCM_SETCDR (tl
, scm_cons (scm_copy_tree (SCM_CAR (obj
)),
5066 SCM_SETCDR (tl
, obj
);
5072 /* We have three levels of EVAL here:
5074 - scm_i_eval (exp, env)
5076 evaluates EXP in environment ENV. ENV is a lexical environment
5077 structure as used by the actual tree code evaluator. When ENV is
5078 a top-level environment, then changes to the current module are
5079 tracked by updating ENV so that it continues to be in sync with
5082 - scm_primitive_eval (exp)
5084 evaluates EXP in the top-level environment as determined by the
5085 current module. This is done by constructing a suitable
5086 environment and calling scm_i_eval. Thus, changes to the
5087 top-level module are tracked normally.
5089 - scm_eval (exp, mod)
5091 evaluates EXP while MOD is the current module. This is done by
5092 setting the current module to MOD, invoking scm_primitive_eval on
5093 EXP, and then restoring the current module to the value it had
5094 previously. That is, while EXP is evaluated, changes to the
5095 current module are tracked, but these changes do not persist when
5098 For each level of evals, there are two variants, distinguished by a
5099 _x suffix: the ordinary variant does not modify EXP while the _x
5100 variant can destructively modify EXP into something completely
5101 unintelligible. A Scheme data structure passed as EXP to one of the
5102 _x variants should not ever be used again for anything. So when in
5103 doubt, use the ordinary variant.
5108 scm_i_eval_x (SCM exp
, SCM env
)
5110 return SCM_XEVAL (exp
, env
);
5114 scm_i_eval (SCM exp
, SCM env
)
5116 exp
= scm_copy_tree (exp
);
5117 return SCM_XEVAL (exp
, env
);
5121 scm_primitive_eval_x (SCM exp
)
5124 SCM transformer
= scm_current_module_transformer ();
5125 if (SCM_NIMP (transformer
))
5126 exp
= scm_call_1 (transformer
, exp
);
5127 env
= scm_top_level_env (scm_current_module_lookup_closure ());
5128 return scm_i_eval_x (exp
, env
);
5131 SCM_DEFINE (scm_primitive_eval
, "primitive-eval", 1, 0, 0,
5133 "Evaluate @var{exp} in the top-level environment specified by\n"
5134 "the current module.")
5135 #define FUNC_NAME s_scm_primitive_eval
5138 SCM transformer
= scm_current_module_transformer ();
5139 if (SCM_NIMP (transformer
))
5140 exp
= scm_call_1 (transformer
, exp
);
5141 env
= scm_top_level_env (scm_current_module_lookup_closure ());
5142 return scm_i_eval (exp
, env
);
5146 /* Eval does not take the second arg optionally. This is intentional
5147 * in order to be R5RS compatible, and to prepare for the new module
5148 * system, where we would like to make the choice of evaluation
5149 * environment explicit. */
5152 change_environment (void *data
)
5154 SCM pair
= SCM_PACK (data
);
5155 SCM new_module
= SCM_CAR (pair
);
5156 SCM old_module
= scm_current_module ();
5157 SCM_SETCDR (pair
, old_module
);
5158 scm_set_current_module (new_module
);
5163 restore_environment (void *data
)
5165 SCM pair
= SCM_PACK (data
);
5166 SCM old_module
= SCM_CDR (pair
);
5167 SCM new_module
= scm_current_module ();
5168 SCM_SETCAR (pair
, new_module
);
5169 scm_set_current_module (old_module
);
5173 inner_eval_x (void *data
)
5175 return scm_primitive_eval_x (SCM_PACK(data
));
5179 scm_eval_x (SCM exp
, SCM module
)
5180 #define FUNC_NAME "eval!"
5182 SCM_VALIDATE_MODULE (2, module
);
5184 return scm_internal_dynamic_wind
5185 (change_environment
, inner_eval_x
, restore_environment
,
5186 (void *) SCM_UNPACK (exp
),
5187 (void *) SCM_UNPACK (scm_cons (module
, SCM_BOOL_F
)));
5192 inner_eval (void *data
)
5194 return scm_primitive_eval (SCM_PACK(data
));
5197 SCM_DEFINE (scm_eval
, "eval", 2, 0, 0,
5198 (SCM exp
, SCM module
),
5199 "Evaluate @var{exp}, a list representing a Scheme expression,\n"
5200 "in the top-level environment specified by @var{module}.\n"
5201 "While @var{exp} is evaluated (using @code{primitive-eval}),\n"
5202 "@var{module} is made the current module. The current module\n"
5203 "is reset to its previous value when @var{eval} returns.")
5204 #define FUNC_NAME s_scm_eval
5206 SCM_VALIDATE_MODULE (2, module
);
5208 return scm_internal_dynamic_wind
5209 (change_environment
, inner_eval
, restore_environment
,
5210 (void *) SCM_UNPACK (exp
),
5211 (void *) SCM_UNPACK (scm_cons (module
, SCM_BOOL_F
)));
5216 /* At this point, scm_deval and scm_dapply are generated.
5226 scm_init_opts (scm_evaluator_traps
,
5227 scm_evaluator_trap_table
,
5228 SCM_N_EVALUATOR_TRAPS
);
5229 scm_init_opts (scm_eval_options_interface
,
5231 SCM_N_EVAL_OPTIONS
);
5233 scm_tc16_promise
= scm_make_smob_type ("promise", 0);
5234 scm_set_smob_mark (scm_tc16_promise
, scm_markcdr
);
5235 scm_set_smob_free (scm_tc16_promise
, promise_free
);
5236 scm_set_smob_print (scm_tc16_promise
, promise_print
);
5238 undefineds
= scm_list_1 (SCM_UNDEFINED
);
5239 SCM_SETCDR (undefineds
, undefineds
);
5240 scm_permanent_object (undefineds
);
5242 scm_listofnull
= scm_list_1 (SCM_EOL
);
5244 f_apply
= scm_c_define_subr ("apply", scm_tc7_lsubr_2
, scm_apply
);
5245 scm_permanent_object (f_apply
);
5247 #include "libguile/eval.x"
5249 scm_add_feature ("delay");