HCoop / bpt / guile.git / blame
? search:
summary | shortlog | log | commit | commitdiff | tree
blob | blame (incremental) | history | HEAD
*** empty log message ***
[bpt/guile.git] / libguile / eval.c
CommitLineData
d9c393f5 1/* Copyright (C) 1995,1996,1997,1998, 1999 Free Software Foundation, Inc.
0f2d19dd
JB		 2 *
3 * This program is free software; you can redistribute it and/or modify
4 * it under the terms of the GNU General Public License as published by
5 * the Free Software Foundation; either version 2, or (at your option)
6 * any later version.
7 *
8 * This program is distributed in the hope that it will be useful,
9 * but WITHOUT ANY WARRANTY; without even the implied warranty of
10 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
11 * GNU General Public License for more details.
12 *
13 * You should have received a copy of the GNU General Public License
14 * along with this software; see the file COPYING. If not, write to
82892bed
JB		 15 * the Free Software Foundation, Inc., 59 Temple Place, Suite 330,
16 * Boston, MA 02111-1307 USA
0f2d19dd
JB		 17 *
18 * As a special exception, the Free Software Foundation gives permission
19 * for additional uses of the text contained in its release of GUILE.
20 *
21 * The exception is that, if you link the GUILE library with other files
22 * to produce an executable, this does not by itself cause the
23 * resulting executable to be covered by the GNU General Public License.
24 * Your use of that executable is in no way restricted on account of
25 * linking the GUILE library code into it.
26 *
27 * This exception does not however invalidate any other reasons why
28 * the executable file might be covered by the GNU General Public License.
29 *
30 * This exception applies only to the code released by the
31 * Free Software Foundation under the name GUILE. If you copy
32 * code from other Free Software Foundation releases into a copy of
33 * GUILE, as the General Public License permits, the exception does
34 * not apply to the code that you add in this way. To avoid misleading
35 * anyone as to the status of such modified files, you must delete
36 * this exception notice from them.
37 *
38 * If you write modifications of your own for GUILE, it is your choice
39 * whether to permit this exception to apply to your modifications.
82892bed 40 * If you do not wish that, delete this exception notice. */
1bbd0b84
GB		 41
42/* Software engineering face-lift by Greg J. Badros, 11-Dec-1999,
43 gjb@cs.washington.edu, http://www.cs.washington.edu/homes/gjb */
44
0f2d19dd
JB		 45\f
46
6dbd0af5
MD		 47/* This file is read twice in order to produce debugging versions of
48 * scm_ceval and scm_apply. These functions, scm_deval and
49 * scm_dapply, are produced when we define the preprocessor macro
50 * DEVAL. The file is divided into sections which are treated
51 * differently with respect to DEVAL. The heads of these sections are
52 * marked with the string "SECTION:".
53 */
54
55
56/* SECTION: This code is compiled once.
0f2d19dd
JB		 57 */
58
59#ifndef DEVAL
60
d16332b3
JB		 61/* We need this to get the definitions for HAVE_ALLOCA_H, etc. */
62#include "scmconfig.h"
63
48b96f4b
JB		 64/* AIX requires this to be the first thing in the file. The #pragma
65 directive is indented so pre-ANSI compilers will ignore it, rather
66 than choke on it. */
5862b540 67#ifndef __GNUC__
48b96f4b
JB		 68# if HAVE_ALLOCA_H
69# include <alloca.h>
70# else
71# ifdef _AIX
72 #pragma alloca
73# else
74# ifndef alloca /* predefined by HP cc +Olibcalls */
75char *alloca ();
76# endif
77# endif
78# endif
79#endif
80
0f2d19dd
JB		 81#include <stdio.h>
82#include "_scm.h"
20e6290e 83#include "debug.h"
20e6290e 84#include "alist.h"
20e6290e
JB		 85#include "eq.h"
86#include "continuations.h"
87#include "throw.h"
88#include "smob.h"
6cb702da 89#include "macros.h"
20e6290e
JB		 90#include "procprop.h"
91#include "hashtab.h"
ac46ab16 92#include "hash.h"
20e6290e
JB		 93#include "srcprop.h"
94#include "stackchk.h"
0c32d76c
MD		 95#include "objects.h"
96#include "feature.h"
185905af 97#include "modules.h"
20e6290e 98
1bbd0b84 99#include "scm_validate.h"
20e6290e 100#include "eval.h"
89efbff4 101
61364ba6
MD		 102SCM (*scm_memoize_method) (SCM, SCM);
103
0f2d19dd
JB		 104\f
105
6dbd0af5
MD		 106/* The evaluator contains a plethora of EVAL symbols.
107 * This is an attempt at explanation.
108 *
109 * The following macros should be used in code which is read twice
110 * (where the choice of evaluator is hard soldered):
111 *
112 * SCM_CEVAL is the symbol used within one evaluator to call itself.
113 * Originally, it is defined to scm_ceval, but is redefined to
114 * scm_deval during the second pass.
115 *
116 * SIDEVAL corresponds to SCM_CEVAL, but is used in situations where
117 * only side effects of expressions matter. All immediates are
118 * ignored.
119 *
6cb702da 120 * SCM_EVALIM is used when it is known that the expression is an
6dbd0af5
MD		 121 * immediate. (This macro never calls an evaluator.)
122 *
123 * EVALCAR evaluates the car of an expression.
124 *
125 * EVALCELLCAR is like EVALCAR, but is used when it is known that the
126 * car is a lisp cell.
127 *
128 * The following macros should be used in code which is read once
129 * (where the choice of evaluator is dynamic):
130 *
6cb702da 131 * SCM_XEVAL takes care of immediates without calling an evaluator. It
6dbd0af5
MD		 132 * then calls scm_ceval *or* scm_deval, depending on the debugging
133 * mode.
134 *
6cb702da 135 * SCM_XEVALCAR corresponds to EVALCAR, but uses scm_ceval *or* scm_deval
6dbd0af5
MD		 136 * depending on the debugging mode.
137 *
138 * The main motivation for keeping this plethora is efficiency
139 * together with maintainability (=> locality of code).
140 */
141
6cb702da 142#define SCM_CEVAL scm_ceval
7d2b68a8 143#define SIDEVAL(x, env) if (SCM_NIMP (x)) SCM_CEVAL((x), (env))
6cb702da 144
7d2b68a8
MD		 145#define EVALCELLCAR(x, env) (SCM_SYMBOLP (SCM_CAR (x)) \
146 ? *scm_lookupcar (x, env, 1) \
147 : SCM_CEVAL (SCM_CAR (x), env))
0f2d19dd 148
7d2b68a8
MD		 149#define EVALCAR(x, env) (SCM_NCELLP (SCM_CAR (x)) \
150 ? (SCM_IMP (SCM_CAR (x)) \
151 ? SCM_EVALIM (SCM_CAR (x), env) \
152 : SCM_GLOC_VAL (SCM_CAR (x))) \
153 : EVALCELLCAR (x, env))
0f2d19dd 154
e2806c10 155#define EXTEND_ENV SCM_EXTEND_ENV
0f2d19dd
JB		 156
157#ifdef MEMOIZE_LOCALS
1cc91f1b 158
0f2d19dd 159SCM *
6e8d25a6 160scm_ilookup (SCM iloc, SCM env)
0f2d19dd
JB		 161{
162 register int ir = SCM_IFRAME (iloc);
163 register SCM er = env;
164 for (; 0 != ir; --ir)
165 er = SCM_CDR (er);
166 er = SCM_CAR (er);
167 for (ir = SCM_IDIST (iloc); 0 != ir; --ir)
168 er = SCM_CDR (er);
169 if (SCM_ICDRP (iloc))
a23afe53
MD		 170 return SCM_CDRLOC (er);
171 return SCM_CARLOC (SCM_CDR (er));
0f2d19dd
JB		 172}
173#endif
174
f8769b1d
MV		 175#ifdef USE_THREADS
176
177/* The Lookup Car Race
178 - by Eva Luator
179
180 Memoization of variables and special forms is done while executing
181 the code for the first time. As long as there is only one thread
182 everything is fine, but as soon as two threads execute the same
183 code concurrently `for the first time' they can come into conflict.
184
185 This memoization includes rewriting variable references into more
186 efficient forms and expanding macros. Furthermore, macro expansion
187 includes `compiling' special forms like `let', `cond', etc. into
188 tree-code instructions.
189
190 There shouldn't normally be a problem with memoizing local and
191 global variable references (into ilocs and glocs), because all
192 threads will mutate the code in *exactly* the same way and (if I
193 read the C code correctly) it is not possible to observe a half-way
194 mutated cons cell. The lookup procedure can handle this
195 transparently without any critical sections.
196
197 It is different with macro expansion, because macro expansion
198 happens outside of the lookup procedure and can't be
199 undone. Therefore it can't cope with it. It has to indicate
200 failure when it detects a lost race and hope that the caller can
201 handle it. Luckily, it turns out that this is the case.
202
203 An example to illustrate this: Suppose that the follwing form will
204 be memoized concurrently by two threads
205
206 (let ((x 12)) x)
207
208 Let's first examine the lookup of X in the body. The first thread
209 decides that it has to find the symbol "x" in the environment and
210 starts to scan it. Then the other thread takes over and actually
211 overtakes the first. It looks up "x" and substitutes an
212 appropriate iloc for it. Now the first thread continues and
213 completes its lookup. It comes to exactly the same conclusions as
214 the second one and could - without much ado - just overwrite the
215 iloc with the same iloc.
216
217 But let's see what will happen when the race occurs while looking
218 up the symbol "let" at the start of the form. It could happen that
219 the second thread interrupts the lookup of the first thread and not
220 only substitutes a gloc for it but goes right ahead and replaces it
221 with the compiled form (#@let* (x 12) x). Now, when the first
222 thread completes its lookup, it would replace the #@let* with a
223 gloc pointing to the "let" binding, effectively reverting the form
224 to (let (x 12) x). This is wrong. It has to detect that it has
225 lost the race and the evaluator has to reconsider the changed form
226 completely.
227
228 This race condition could be resolved with some kind of traffic
229 light (like mutexes) around scm_lookupcar, but I think that it is
230 best to avoid them in this case. They would serialize memoization
231 completely and because lookup involves calling arbitrary Scheme
232 code (via the lookup-thunk), threads could be blocked for an
233 arbitrary amount of time or even deadlock. But with the current
234 solution a lot of unnecessary work is potentially done. */
235
236/* SCM_LOOKUPCAR1 is was SCM_LOOKUPCAR used to be but is allowed to
237 return NULL to indicate a failed lookup due to some race conditions
238 between threads. This only happens when VLOC is the first cell of
239 a special form that will eventually be memoized (like `let', etc.)
240 In that case the whole lookup is bogus and the caller has to
241 reconsider the complete special form.
242
243 SCM_LOOKUPCAR is still there, of course. It just calls
244 SCM_LOOKUPCAR1 and aborts on recieving NULL. So SCM_LOOKUPCAR
245 should only be called when it is known that VLOC is not the first
246 pair of a special form. Otherwise, use SCM_LOOKUPCAR1 and check
26d5b9b4
MD		 247 for NULL. I think I've found the only places where this
248 applies. */
f8769b1d
MV		 249
250#endif /* USE_THREADS */
1cc91f1b 251
26d5b9b4
MD		 252/* scm_lookupcar returns a pointer to this when a variable could not
253 be found and it should not throw an error. Never assign to this.
254*/
255static scm_cell undef_cell = { SCM_UNDEFINED, SCM_UNDEFINED };
256
f25f761d
GH		 257SCM_SYMBOL (scm_unbound_variable_key, "unbound-variable");
258
d0b7bad7 259#ifdef USE_THREADS
8ecf1f13 260static SCM *
26d5b9b4 261scm_lookupcar1 (SCM vloc, SCM genv, int check)
d0b7bad7
MD		 262#else
263SCM *
26d5b9b4 264scm_lookupcar (SCM vloc, SCM genv, int check)
d0b7bad7 265#endif
0f2d19dd
JB		 266{
267 SCM env = genv;
e3173f93
JB		 268 register SCM *al, fl, var = SCM_CAR (vloc);
269#ifdef USE_THREADS
270 register SCM var2 = var;
271#endif
0f2d19dd
JB		 272#ifdef MEMOIZE_LOCALS
273 register SCM iloc = SCM_ILOC00;
274#endif
275 for (; SCM_NIMP (env); env = SCM_CDR (env))
276 {
277 if (SCM_BOOL_T == scm_procedure_p (SCM_CAR (env)))
278 break;
a23afe53 279 al = SCM_CARLOC (env);
0f2d19dd
JB		 280 for (fl = SCM_CAR (*al); SCM_NIMP (fl); fl = SCM_CDR (fl))
281 {
282 if (SCM_NCONSP (fl))
33b97402 283 {
0f2d19dd
JB		 284 if (fl == var)
285 {
286#ifdef MEMOIZE_LOCALS
f8769b1d
MV		 287#ifdef USE_THREADS
288 if (SCM_CAR (vloc) != var)
289 goto race;
290#endif
a23afe53 291 SCM_SETCAR (vloc, iloc + SCM_ICDR);
0f2d19dd 292#endif
a23afe53 293 return SCM_CDRLOC (*al);
0f2d19dd 294 }
33b97402
MD		 295 else
296 break;
297 }
a23afe53 298 al = SCM_CDRLOC (*al);
0f2d19dd
JB		 299 if (SCM_CAR (fl) == var)
300 {
301#ifdef MEMOIZE_LOCALS
cf7c17e9 302#ifndef SCM_RECKLESS /* letrec inits to SCM_UNDEFINED */
0f2d19dd
JB		 303 if (SCM_UNBNDP (SCM_CAR (*al)))
304 {
305 env = SCM_EOL;
306 goto errout;
307 }
f8769b1d
MV		 308#endif
309#ifdef USE_THREADS
310 if (SCM_CAR (vloc) != var)
311 goto race;
0f2d19dd 312#endif
a23afe53 313 SCM_SETCAR (vloc, iloc);
0f2d19dd 314#endif
a23afe53 315 return SCM_CARLOC (*al);
0f2d19dd
JB		 316 }
317#ifdef MEMOIZE_LOCALS
318 iloc += SCM_IDINC;
319#endif
320 }
321#ifdef MEMOIZE_LOCALS
322 iloc = (~SCM_IDSTMSK) & (iloc + SCM_IFRINC);
323#endif
324 }
325 {
326 SCM top_thunk, vcell;
327 if (SCM_NIMP(env))
328 {
329 top_thunk = SCM_CAR(env); /* env now refers to a top level env thunk */
330 env = SCM_CDR (env);
331 }
332 else
333 top_thunk = SCM_BOOL_F;
334 vcell = scm_sym2vcell (var, top_thunk, SCM_BOOL_F);
335 if (vcell == SCM_BOOL_F)
336 goto errout;
337 else
338 var = vcell;
339 }
cf7c17e9 340#ifndef SCM_RECKLESS
0f2d19dd
JB		 341 if (SCM_NNULLP (env) || SCM_UNBNDP (SCM_CDR (var)))
342 {
343 var = SCM_CAR (var);
344 errout:
f5bf2977 345 /* scm_everr (vloc, genv,...) */
26d5b9b4 346 if (check)
f25f761d
GH		 347 {
348 if (SCM_NULLP (env))
70d63753 349 scm_error (scm_unbound_variable_key, NULL, "Unbound variable: ~S",
f25f761d
GH		 350 scm_cons (var, SCM_EOL), SCM_BOOL_F);
351 else
70d63753 352 scm_misc_error (NULL, "Damaged environment: ~S",
f25f761d
GH		 353 scm_cons (var, SCM_EOL));
354 }
26d5b9b4
MD		 355 else
356 return SCM_CDRLOC (&undef_cell);
0f2d19dd
JB		 357 }
358#endif
f8769b1d
MV		 359#ifdef USE_THREADS
360 if (SCM_CAR (vloc) != var2)
361 {
362 /* Some other thread has changed the very cell we are working
363 on. In effect, it must have done our job or messed it up
364 completely. */
365 race:
366 var = SCM_CAR (vloc);
367 if ((var & 7) == 1)
368 return SCM_GLOC_VAL_LOC (var);
369#ifdef MEMOIZE_LOCALS
370 if ((var & 127) == (127 & SCM_ILOC00))
371 return scm_ilookup (var, genv);
372#endif
373 /* We can't cope with anything else than glocs and ilocs. When
374 a special form has been memoized (i.e. `let' into `#@let') we
375 return NULL and expect the calling function to do the right
376 thing. For the evaluator, this means going back and redoing
377 the dispatch on the car of the form. */
378 return NULL;
379 }
380#endif /* USE_THREADS */
381
a23afe53 382 SCM_SETCAR (vloc, var + 1);
0f2d19dd 383 /* Except wait...what if the var is not a vcell,
f8769b1d 384 * but syntax or something.... */
a23afe53 385 return SCM_CDRLOC (var);
0f2d19dd
JB		 386}
387
f8769b1d
MV		 388#ifdef USE_THREADS
389SCM *
6e8d25a6 390scm_lookupcar (SCM vloc, SCM genv, int check)
f8769b1d 391{
26d5b9b4 392 SCM *loc = scm_lookupcar1 (vloc, genv, check);
f8769b1d
MV		 393 if (loc == NULL)
394 abort ();
395 return loc;
396}
f8769b1d
MV		 397#endif
398
0f2d19dd 399#define unmemocar scm_unmemocar
1cc91f1b 400
0f2d19dd 401SCM
6e8d25a6 402scm_unmemocar (SCM form, SCM env)
0f2d19dd 403{
6dbd0af5 404#ifdef DEBUG_EXTENSIONS
0f2d19dd 405 register int ir;
6dbd0af5 406#endif
0f2d19dd
JB		 407 SCM c;
408
409 if (SCM_IMP (form))
410 return form;
411 c = SCM_CAR (form);
412 if (1 == (c & 7))
a23afe53 413 SCM_SETCAR (form, SCM_CAR (c - 1));
0f2d19dd 414#ifdef MEMOIZE_LOCALS
6dbd0af5 415#ifdef DEBUG_EXTENSIONS
0f2d19dd
JB		 416 else if (SCM_ILOCP (c))
417 {
418 for (ir = SCM_IFRAME (c); ir != 0; --ir)
419 env = SCM_CDR (env);
420 env = SCM_CAR (SCM_CAR (env));
421 for (ir = SCM_IDIST (c); ir != 0; --ir)
422 env = SCM_CDR (env);
a23afe53 423 SCM_SETCAR (form, SCM_ICDRP (c) ? env : SCM_CAR (env));
0f2d19dd 424 }
6dbd0af5 425#endif
0f2d19dd
JB		 426#endif
427 return form;
428}
429
1cc91f1b 430
0f2d19dd 431SCM
6e8d25a6 432scm_eval_car (SCM pair, SCM env)
0f2d19dd 433{
6cb702da 434 return SCM_XEVALCAR (pair, env);
0f2d19dd
JB		 435}
436
437\f
438/*
439 * The following rewrite expressions and
440 * some memoized forms have different syntax
441 */
442
3eeba8d4
JB		 443const char scm_s_expression[] = "missing or extra expression";
444const char scm_s_test[] = "bad test";
445const char scm_s_body[] = "bad body";
446const char scm_s_bindings[] = "bad bindings";
447const char scm_s_variable[] = "bad variable";
448const char scm_s_clauses[] = "bad or missing clauses";
449const char scm_s_formals[] = "bad formals";
0f2d19dd 450
81123e6d
MD		 451SCM scm_sym_dot, scm_sym_arrow, scm_sym_else;
452SCM scm_sym_unquote, scm_sym_uq_splicing, scm_sym_apply;
453
454SCM scm_f_apply;
b8229a3b 455
6dbd0af5 456#ifdef DEBUG_EXTENSIONS
2f0d1375
MD		 457SCM scm_sym_enter_frame, scm_sym_apply_frame, scm_sym_exit_frame;
458SCM scm_sym_trace;
6dbd0af5 459#endif
0f2d19dd
JB		 460
461#define ASRTSYNTAX(cond_, msg_) if(!(cond_))scm_wta(xorig, (msg_), what);
462
463
1cc91f1b 464
e4755e5c 465static void bodycheck SCM_P ((SCM xorig, SCM *bodyloc, const char *what));
1cc91f1b 466
0f2d19dd 467static void
6e8d25a6 468bodycheck (SCM xorig, SCM *bodyloc, const char *what)
0f2d19dd 469{
6cb702da 470 ASRTSYNTAX (scm_ilength (*bodyloc) >= 1, scm_s_expression);
0f2d19dd
JB		 471}
472
26d5b9b4
MD		 473/* Check that the body denoted by XORIG is valid and rewrite it into
474 its internal form. The internal form of a body is just the body
475 itself, but prefixed with an ISYM that denotes to what kind of
476 outer construct this body belongs. A lambda body starts with
477 SCM_IM_LAMBDA, for example, a body of a let starts with SCM_IM_LET,
478 etc. The one exception is a body that belongs to a letrec that has
479 been formed by rewriting internal defines: it starts with
480 SCM_IM_DEFINE. */
481
482/* XXX - Besides controlling the rewriting of internal defines, the
483 additional ISYM could be used for improved error messages.
484 This is not done yet. */
485
486static SCM
6e8d25a6 487scm_m_body (SCM op, SCM xorig, const char *what)
26d5b9b4
MD		 488{
489 ASRTSYNTAX (scm_ilength (xorig) >= 1, scm_s_expression);
490
491 /* Don't add another ISYM if one is present already. */
492 if (SCM_ISYMP (SCM_CAR (xorig)))
493 return xorig;
494
495 /* Retain possible doc string. */
496 if (SCM_IMP (SCM_CAR(xorig)) || SCM_NCONSP (SCM_CAR (xorig)))
497 {
498 if (SCM_NNULLP (SCM_CDR(xorig)))
499 return scm_cons (SCM_CAR (xorig),
500 scm_m_body (op, SCM_CDR(xorig), what));
501 return xorig;
502 }
503
504 return scm_cons2 (op, SCM_CAR (xorig), SCM_CDR(xorig));
505}
506
b8229a3b 507SCM_SYNTAX(s_quote,"quote", scm_makmmacro, scm_m_quote);
2f0d1375 508SCM_GLOBAL_SYMBOL(scm_sym_quote, s_quote);
1cc91f1b 509
0f2d19dd 510SCM
6e8d25a6 511scm_m_quote (SCM xorig, SCM env)
0f2d19dd 512{
26d5b9b4
MD		 513 SCM x = scm_copy_tree (SCM_CDR (xorig));
514
6cb702da 515 SCM_ASSYNT (scm_ilength (SCM_CDR (xorig)) == 1,
b8229a3b 516 xorig, scm_s_expression, s_quote);
3a3111a8 517 return scm_cons (SCM_IM_QUOTE, x);
0f2d19dd
JB		 518}
519
520
1cc91f1b 521
b8229a3b 522SCM_SYNTAX(s_begin, "begin", scm_makmmacro, scm_m_begin);
2f0d1375 523SCM_GLOBAL_SYMBOL(scm_sym_begin, s_begin);
b8229a3b 524
0f2d19dd 525SCM
6e8d25a6 526scm_m_begin (SCM xorig, SCM env)
0f2d19dd 527{
6cb702da 528 SCM_ASSYNT (scm_ilength (SCM_CDR (xorig)) >= 1,
b8229a3b 529 xorig, scm_s_expression, s_begin);
3a3111a8 530 return scm_cons (SCM_IM_BEGIN, SCM_CDR (xorig));
0f2d19dd
JB		 531}
532
b8229a3b 533SCM_SYNTAX(s_if, "if", scm_makmmacro, scm_m_if);
2f0d1375 534SCM_GLOBAL_SYMBOL(scm_sym_if, s_if);
1cc91f1b 535
0f2d19dd 536SCM
6e8d25a6 537scm_m_if (SCM xorig, SCM env)
0f2d19dd
JB		 538{
539 int len = scm_ilength (SCM_CDR (xorig));
6cb702da 540 SCM_ASSYNT (len >= 2 && len <= 3, xorig, scm_s_expression, "if");
3a3111a8 541 return scm_cons (SCM_IM_IF, SCM_CDR (xorig));
0f2d19dd
JB		 542}
543
544
89efbff4
MD		 545/* Will go into the RnRS module when Guile is factorized.
546SCM_SYNTAX(scm_s_set_x,"set!", scm_makmmacro, scm_m_set_x); */
547const char scm_s_set_x[] = "set!";
548SCM_GLOBAL_SYMBOL(scm_sym_set_x, scm_s_set_x);
1cc91f1b 549
0f2d19dd 550SCM
6e8d25a6 551scm_m_set_x (SCM xorig, SCM env)
0f2d19dd 552{
6dbd0af5 553 SCM x = SCM_CDR (xorig);
89efbff4 554 SCM_ASSYNT (2 == scm_ilength (x), xorig, scm_s_expression, scm_s_set_x);
cabe682c 555 SCM_ASSYNT (SCM_SYMBOLP (SCM_CAR (x)),
89efbff4 556 xorig, scm_s_variable, scm_s_set_x);
3a3111a8 557 return scm_cons (SCM_IM_SET_X, x);
0f2d19dd
JB		 558}
559
560
561#if 0
1cc91f1b 562
0f2d19dd 563SCM
6e8d25a6 564scm_m_vref (SCM xorig, SCM env)
0f2d19dd
JB		 565{
566 SCM x = SCM_CDR (xorig);
6cb702da 567 SCM_ASSYNT (1 == scm_ilength (x), xorig, scm_s_expression, s_vref);
0f2d19dd
JB		 568 if (SCM_NIMP(x) && UDSCM_VARIABLEP (SCM_CAR (x)))
569 {
f5bf2977 570 /* scm_everr (SCM_UNDEFINED, env,..., "global variable reference") */
523f5266 571 scm_misc_error (NULL,
70d63753 572 "Bad variable: ~S",
523f5266 573 scm_listify (SCM_CAR (SCM_CDR (x)), SCM_UNDEFINED));
0f2d19dd 574 }
6cb702da
MD		 575 SCM_ASSYNT (SCM_NIMP(x) && DEFSCM_VARIABLEP (SCM_CAR (x)),
576 xorig, scm_s_variable, s_vref);
0f2d19dd
JB		 577 return scm_cons (IM_VREF, x);
578}
579
580
1cc91f1b 581
0f2d19dd 582SCM
6e8d25a6 583scm_m_vset (SCM xorig, SCM env)
0f2d19dd
JB		 584{
585 SCM x = SCM_CDR (xorig);
6cb702da
MD		 586 SCM_ASSYNT (3 == scm_ilength (x), xorig, scm_s_expression, s_vset);
587 SCM_ASSYNT ((DEFSCM_VARIABLEP (SCM_CAR (x))
588 || UDSCM_VARIABLEP (SCM_CAR (x))),
589 xorig, scm_s_variable, s_vset);
0f2d19dd
JB		 590 return scm_cons (IM_VSET, x);
591}
592#endif
593
594
b8229a3b 595SCM_SYNTAX(s_and, "and", scm_makmmacro, scm_m_and);
2f0d1375 596SCM_GLOBAL_SYMBOL(scm_sym_and, s_and);
1cc91f1b 597
0f2d19dd 598SCM
6e8d25a6 599scm_m_and (SCM xorig, SCM env)
0f2d19dd
JB		 600{
601 int len = scm_ilength (SCM_CDR (xorig));
b8229a3b 602 SCM_ASSYNT (len >= 0, xorig, scm_s_test, s_and);
0f2d19dd 603 if (len >= 1)
3a3111a8 604 return scm_cons (SCM_IM_AND, SCM_CDR (xorig));
0f2d19dd
JB		 605 else
606 return SCM_BOOL_T;
607}
608
b8229a3b 609SCM_SYNTAX(s_or,"or", scm_makmmacro, scm_m_or);
2f0d1375 610SCM_GLOBAL_SYMBOL(scm_sym_or,s_or);
1cc91f1b 611
0f2d19dd 612SCM
6e8d25a6 613scm_m_or (SCM xorig, SCM env)
0f2d19dd
JB		 614{
615 int len = scm_ilength (SCM_CDR (xorig));
b8229a3b 616 SCM_ASSYNT (len >= 0, xorig, scm_s_test, s_or);
0f2d19dd 617 if (len >= 1)
3a3111a8 618 return scm_cons (SCM_IM_OR, SCM_CDR (xorig));
0f2d19dd
JB		 619 else
620 return SCM_BOOL_F;
621}
622
623
b8229a3b 624SCM_SYNTAX(s_case, "case", scm_makmmacro, scm_m_case);
2f0d1375 625SCM_GLOBAL_SYMBOL(scm_sym_case, s_case);
1cc91f1b 626
0f2d19dd 627SCM
6e8d25a6 628scm_m_case (SCM xorig, SCM env)
0f2d19dd 629{
26d5b9b4 630 SCM proc, cdrx = scm_list_copy (SCM_CDR (xorig)), x = cdrx;
b8229a3b 631 SCM_ASSYNT (scm_ilength (x) >= 2, xorig, scm_s_clauses, s_case);
0f2d19dd
JB		 632 while (SCM_NIMP (x = SCM_CDR (x)))
633 {
634 proc = SCM_CAR (x);
b8229a3b 635 SCM_ASSYNT (scm_ilength (proc) >= 2, xorig, scm_s_clauses, s_case);
6cb702da 636 SCM_ASSYNT (scm_ilength (SCM_CAR (proc)) >= 0
2f0d1375 637 || scm_sym_else == SCM_CAR (proc),
b8229a3b 638 xorig, scm_s_clauses, s_case);
0f2d19dd 639 }
3a3111a8 640 return scm_cons (SCM_IM_CASE, cdrx);
0f2d19dd
JB		 641}
642
643
b8229a3b 644SCM_SYNTAX(s_cond, "cond", scm_makmmacro, scm_m_cond);
2f0d1375 645SCM_GLOBAL_SYMBOL(scm_sym_cond, s_cond);
b8229a3b 646
1cc91f1b 647
0f2d19dd 648SCM
6e8d25a6 649scm_m_cond (SCM xorig, SCM env)
0f2d19dd 650{
26d5b9b4 651 SCM arg1, cdrx = scm_list_copy (SCM_CDR (xorig)), x = cdrx;
0f2d19dd 652 int len = scm_ilength (x);
b8229a3b 653 SCM_ASSYNT (len >= 1, xorig, scm_s_clauses, s_cond);
0f2d19dd
JB		 654 while (SCM_NIMP (x))
655 {
656 arg1 = SCM_CAR (x);
657 len = scm_ilength (arg1);
b8229a3b 658 SCM_ASSYNT (len >= 1, xorig, scm_s_clauses, s_cond);
2f0d1375 659 if (scm_sym_else == SCM_CAR (arg1))
0f2d19dd 660 {
6cb702da 661 SCM_ASSYNT (SCM_NULLP (SCM_CDR (x)) && len >= 2,
b8229a3b 662 xorig, "bad ELSE clause", s_cond);
a23afe53 663 SCM_SETCAR (arg1, SCM_BOOL_T);
0f2d19dd 664 }
2f0d1375 665 if (len >= 2 && scm_sym_arrow == SCM_CAR (SCM_CDR (arg1)))
6cb702da 666 SCM_ASSYNT (3 == len && SCM_NIMP (SCM_CAR (SCM_CDR (SCM_CDR (arg1)))),
b8229a3b 667 xorig, "bad recipient", s_cond);
0f2d19dd
JB		 668 x = SCM_CDR (x);
669 }
3a3111a8 670 return scm_cons (SCM_IM_COND, cdrx);
0f2d19dd
JB		 671}
672
b8229a3b 673SCM_SYNTAX(s_lambda, "lambda", scm_makmmacro, scm_m_lambda);
2f0d1375 674SCM_GLOBAL_SYMBOL(scm_sym_lambda, s_lambda);
1cc91f1b 675
0f2d19dd 676SCM
6e8d25a6 677scm_m_lambda (SCM xorig, SCM env)
0f2d19dd
JB		 678{
679 SCM proc, x = SCM_CDR (xorig);
26d5b9b4 680 if (scm_ilength (x) < 2)
0f2d19dd
JB		 681 goto badforms;
682 proc = SCM_CAR (x);
33b97402
MD		 683 if (SCM_NULLP (proc))
684 goto memlambda;
26d5b9b4
MD		 685 if (SCM_IM_LET == proc) /* named let */
686 goto memlambda;
33b97402
MD		 687 if (SCM_IMP (proc))
688 goto badforms;
689 if (SCM_SYMBOLP (proc))
690 goto memlambda;
691 if (SCM_NCONSP (proc))
692 goto badforms;
693 while (SCM_NIMP (proc))
0f2d19dd 694 {
33b97402
MD		 695 if (SCM_NCONSP (proc))
696 {
0f2d19dd 697 if (!SCM_SYMBOLP (proc))
33b97402
MD		 698 goto badforms;
699 else
700 goto memlambda;
701 }
0c95b57d 702 if (!SCM_SYMBOLP (SCM_CAR (proc)))
0f2d19dd
JB		 703 goto badforms;
704 proc = SCM_CDR (proc);
705 }
ff467021 706 if (SCM_NNULLP (proc))
26d5b9b4
MD		 707 {
708 badforms:
709 scm_wta (xorig, scm_s_formals, s_lambda);
710 }
711
712 memlambda:
3a3111a8
MD		 713 return scm_cons2 (SCM_IM_LAMBDA, SCM_CAR (x),
714 scm_m_body (SCM_IM_LAMBDA, SCM_CDR (x), s_lambda));
0f2d19dd
JB		 715}
716
b8229a3b 717SCM_SYNTAX(s_letstar,"let*", scm_makmmacro, scm_m_letstar);
2f0d1375 718SCM_GLOBAL_SYMBOL(scm_sym_letstar,s_letstar);
0f2d19dd 719
1cc91f1b 720
0f2d19dd 721SCM
6e8d25a6 722scm_m_letstar (SCM xorig, SCM env)
0f2d19dd
JB		 723{
724 SCM x = SCM_CDR (xorig), arg1, proc, vars = SCM_EOL, *varloc = &vars;
725 int len = scm_ilength (x);
b8229a3b 726 SCM_ASSYNT (len >= 2, xorig, scm_s_body, s_letstar);
0f2d19dd 727 proc = SCM_CAR (x);
b8229a3b 728 SCM_ASSYNT (scm_ilength (proc) >= 0, xorig, scm_s_bindings, s_letstar);
ff467021 729 while (SCM_NIMP (proc))
0f2d19dd
JB		 730 {
731 arg1 = SCM_CAR (proc);
b8229a3b 732 SCM_ASSYNT (2 == scm_ilength (arg1), xorig, scm_s_bindings, s_letstar);
0c95b57d 733 SCM_ASSYNT (SCM_SYMBOLP (SCM_CAR (arg1)), xorig, scm_s_variable, s_letstar);
0f2d19dd 734 *varloc = scm_cons2 (SCM_CAR (arg1), SCM_CAR (SCM_CDR (arg1)), SCM_EOL);
a23afe53 735 varloc = SCM_CDRLOC (SCM_CDR (*varloc));
0f2d19dd
JB		 736 proc = SCM_CDR (proc);
737 }
738 x = scm_cons (vars, SCM_CDR (x));
26d5b9b4 739
3a3111a8
MD		 740 return scm_cons2 (SCM_IM_LETSTAR, SCM_CAR (x),
741 scm_m_body (SCM_IM_LETSTAR, SCM_CDR (x), s_letstar));
0f2d19dd
JB		 742}
743
744/* DO gets the most radically altered syntax
745 (do ((<var1> <init1> <step1>)
746 (<var2> <init2>)
747 ... )
748 (<test> <return>)
749 <body>)
750 ;; becomes
751 (do_mem (varn ... var2 var1)
752 (<init1> <init2> ... <initn>)
753 (<test> <return>)
754 (<body>)
755 <step1> <step2> ... <stepn>) ;; missing steps replaced by var
756 */
757
b8229a3b 758SCM_SYNTAX(s_do, "do", scm_makmmacro, scm_m_do);
2f0d1375 759SCM_GLOBAL_SYMBOL(scm_sym_do, s_do);
1cc91f1b 760
0f2d19dd 761SCM
6e8d25a6 762scm_m_do (SCM xorig, SCM env)
0f2d19dd
JB		 763{
764 SCM x = SCM_CDR (xorig), arg1, proc;
765 SCM vars = SCM_EOL, inits = SCM_EOL, steps = SCM_EOL;
766 SCM *initloc = &inits, *steploc = &steps;
767 int len = scm_ilength (x);
6cb702da 768 SCM_ASSYNT (len >= 2, xorig, scm_s_test, "do");
0f2d19dd 769 proc = SCM_CAR (x);
6cb702da 770 SCM_ASSYNT (scm_ilength (proc) >= 0, xorig, scm_s_bindings, "do");
ff467021 771 while (SCM_NIMP(proc))
0f2d19dd
JB		 772 {
773 arg1 = SCM_CAR (proc);
774 len = scm_ilength (arg1);
6cb702da 775 SCM_ASSYNT (2 == len || 3 == len, xorig, scm_s_bindings, "do");
0c95b57d 776 SCM_ASSYNT (SCM_SYMBOLP (SCM_CAR (arg1)), xorig, scm_s_variable, "do");
0f2d19dd
JB		 777 /* vars reversed here, inits and steps reversed at evaluation */
778 vars = scm_cons (SCM_CAR (arg1), vars); /* variable */
779 arg1 = SCM_CDR (arg1);
780 *initloc = scm_cons (SCM_CAR (arg1), SCM_EOL); /* init */
a23afe53 781 initloc = SCM_CDRLOC (*initloc);
0f2d19dd
JB		 782 arg1 = SCM_CDR (arg1);
783 *steploc = scm_cons (SCM_IMP (arg1) ? SCM_CAR (vars) : SCM_CAR (arg1), SCM_EOL); /* step */
a23afe53 784 steploc = SCM_CDRLOC (*steploc);
0f2d19dd
JB		 785 proc = SCM_CDR (proc);
786 }
787 x = SCM_CDR (x);
6cb702da 788 SCM_ASSYNT (scm_ilength (SCM_CAR (x)) >= 1, xorig, scm_s_test, "do");
0f2d19dd
JB		 789 x = scm_cons2 (SCM_CAR (x), SCM_CDR (x), steps);
790 x = scm_cons2 (vars, inits, x);
a23afe53 791 bodycheck (xorig, SCM_CARLOC (SCM_CDR (SCM_CDR (x))), "do");
3a3111a8 792 return scm_cons (SCM_IM_DO, x);
0f2d19dd
JB		 793}
794
6dbd0af5
MD		 795/* evalcar is small version of inline EVALCAR when we don't care about
796 * speed
797 */
798#define evalcar scm_eval_car
0f2d19dd 799
1cc91f1b 800
1bbd0b84 801static SCM iqq (SCM form, SCM env, int depth);
1cc91f1b 802
b8229a3b 803SCM_SYNTAX(s_quasiquote, "quasiquote", scm_makacro, scm_m_quasiquote);
2f0d1375 804SCM_GLOBAL_SYMBOL(scm_sym_quasiquote, s_quasiquote);
b8229a3b
MS		 805
806SCM
6e8d25a6 807scm_m_quasiquote (SCM xorig, SCM env)
b8229a3b
MS		 808{
809 SCM x = SCM_CDR (xorig);
810 SCM_ASSYNT (scm_ilength (x) == 1, xorig, scm_s_expression, s_quasiquote);
811 return iqq (SCM_CAR (x), env, 1);
812}
813
814
0f2d19dd 815static SCM
1bbd0b84 816iqq (SCM form,SCM env,int depth)
0f2d19dd
JB		 817{
818 SCM tmp;
819 int edepth = depth;
ff467021
JB		 820 if (SCM_IMP(form))
821 return form;
0f2d19dd
JB		 822 if (SCM_VECTORP (form))
823 {
824 long i = SCM_LENGTH (form);
825 SCM *data = SCM_VELTS (form);
826 tmp = SCM_EOL;
827 for (; --i >= 0;)
828 tmp = scm_cons (data[i], tmp);
829 return scm_vector (iqq (tmp, env, depth));
830 }
ff467021
JB		 831 if (SCM_NCONSP(form))
832 return form;
0f2d19dd 833 tmp = SCM_CAR (form);
2f0d1375 834 if (scm_sym_quasiquote == tmp)
0f2d19dd
JB		 835 {
836 depth++;
837 goto label;
838 }
2f0d1375 839 if (scm_sym_unquote == tmp)
0f2d19dd
JB		 840 {
841 --depth;
842 label:
843 form = SCM_CDR (form);
0c95b57d
GB		 844 SCM_ASSERT (SCM_ECONSP (form) && SCM_NULLP (SCM_CDR (form)),
845 form, SCM_ARG1, s_quasiquote);
0f2d19dd
JB		 846 if (0 == depth)
847 return evalcar (form, env);
848 return scm_cons2 (tmp, iqq (SCM_CAR (form), env, depth), SCM_EOL);
849 }
2f0d1375 850 if (SCM_NIMP (tmp) && (scm_sym_uq_splicing == SCM_CAR (tmp)))
0f2d19dd
JB		 851 {
852 tmp = SCM_CDR (tmp);
853 if (0 == --edepth)
854 return scm_append (scm_cons2 (evalcar (tmp, env), iqq (SCM_CDR (form), env, depth), SCM_EOL));
855 }
856 return scm_cons (iqq (SCM_CAR (form), env, edepth), iqq (SCM_CDR (form), env, depth));
857}
858
859/* Here are acros which return values rather than code. */
860
a570e93a
MD		 861SCM_SYNTAX (s_delay, "delay", scm_makmmacro, scm_m_delay);
862SCM_GLOBAL_SYMBOL (scm_sym_delay, s_delay);
1cc91f1b 863
0f2d19dd 864SCM
6e8d25a6 865scm_m_delay (SCM xorig, SCM env)
0f2d19dd 866{
6cb702da 867 SCM_ASSYNT (scm_ilength (xorig) == 2, xorig, scm_s_expression, s_delay);
a570e93a 868 return scm_cons2 (SCM_IM_DELAY, SCM_EOL, SCM_CDR (xorig));
0f2d19dd
JB		 869}
870
1cc91f1b 871
b8229a3b 872SCM_SYNTAX(s_define, "define", scm_makmmacro, scm_m_define);
2f0d1375 873SCM_GLOBAL_SYMBOL(scm_sym_define, s_define);
1cc91f1b 874
0f2d19dd 875SCM
6e8d25a6 876scm_m_define (SCM x, SCM env)
0f2d19dd
JB		 877{
878 SCM proc, arg1 = x;
879 x = SCM_CDR (x);
6cb702da 880 /* SCM_ASSYNT(SCM_NULLP(env), x, "bad placement", s_define);*/
b8229a3b 881 SCM_ASSYNT (scm_ilength (x) >= 2, arg1, scm_s_expression, s_define);
0f2d19dd
JB		 882 proc = SCM_CAR (x);
883 x = SCM_CDR (x);
0c95b57d 884 while (SCM_CONSP (proc))
0f2d19dd 885 { /* nested define syntax */
2f0d1375 886 x = scm_cons (scm_cons2 (scm_sym_lambda, SCM_CDR (proc), x), SCM_EOL);
0f2d19dd
JB		 887 proc = SCM_CAR (proc);
888 }
0c95b57d 889 SCM_ASSYNT (SCM_SYMBOLP (proc),
b8229a3b
MS		 890 arg1, scm_s_variable, s_define);
891 SCM_ASSYNT (1 == scm_ilength (x), arg1, scm_s_expression, s_define);
0f2d19dd
JB		 892 if (SCM_TOP_LEVEL (env))
893 {
894 x = evalcar (x, env);
6dbd0af5 895#ifdef DEBUG_EXTENSIONS
80ea260c
MD		 896 if (SCM_REC_PROCNAMES_P && SCM_NIMP (x))
897 {
898 arg1 = x;
899 proc:
900 if (SCM_CLOSUREP (arg1)
901 /* Only the first definition determines the name. */
2f0d1375
MD		 902 && scm_procedure_property (arg1, scm_sym_name) == SCM_BOOL_F)
903 scm_set_procedure_property_x (arg1, scm_sym_name, proc);
80ea260c
MD		 904 else if (SCM_TYP16 (arg1) == scm_tc16_macro
905 && SCM_CDR (arg1) != arg1)
906 {
907 arg1 = SCM_CDR (arg1);
908 goto proc;
909 }
910 }
6dbd0af5 911#endif
6cb702da 912 arg1 = scm_sym2vcell (proc, scm_env_top_level (env), SCM_BOOL_T);
0f2d19dd 913#if 0
cf7c17e9 914#ifndef SCM_RECKLESS
0f2d19dd
JB		 915 if (SCM_NIMP (SCM_CDR (arg1)) && ((SCM) SCM_SNAME (SCM_CDR (arg1)) == proc)
916 && (SCM_CDR (arg1) != x))
917 scm_warn ("redefining built-in ", SCM_CHARS (proc));
918 else
919#endif
920 if (5 <= scm_verbose && SCM_UNDEFINED != SCM_CDR (arg1))
921 scm_warn ("redefining ", SCM_CHARS (proc));
0f2d19dd 922#endif
a23afe53 923 SCM_SETCDR (arg1, x);
0f2d19dd 924#ifdef SICP
2f0d1375 925 return scm_cons2 (scm_sym_quote, SCM_CAR (arg1), SCM_EOL);
0f2d19dd
JB		 926#else
927 return SCM_UNSPECIFIED;
928#endif
929 }
930 return scm_cons2 (SCM_IM_DEFINE, proc, x);
931}
6dbd0af5 932
0f2d19dd
JB		 933/* end of acros */
934
26d5b9b4 935static SCM
6e8d25a6 936scm_m_letrec1 (SCM op, SCM imm, SCM xorig, SCM env)
0f2d19dd
JB		 937{
938 SCM cdrx = SCM_CDR (xorig); /* locally mutable version of form */
939 char *what = SCM_CHARS (SCM_CAR (xorig));
940 SCM x = cdrx, proc, arg1; /* structure traversers */
941 SCM vars = SCM_EOL, inits = SCM_EOL, *initloc = &inits;
942
0f2d19dd 943 proc = SCM_CAR (x);
6cb702da 944 ASRTSYNTAX (scm_ilength (proc) >= 1, scm_s_bindings);
0f2d19dd
JB		 945 do
946 {
947 /* vars scm_list reversed here, inits reversed at evaluation */
948 arg1 = SCM_CAR (proc);
6cb702da 949 ASRTSYNTAX (2 == scm_ilength (arg1), scm_s_bindings);
0c95b57d 950 ASRTSYNTAX (SCM_SYMBOLP (SCM_CAR (arg1)),
26d5b9b4 951 scm_s_variable);
0f2d19dd
JB		 952 vars = scm_cons (SCM_CAR (arg1), vars);
953 *initloc = scm_cons (SCM_CAR (SCM_CDR (arg1)), SCM_EOL);
a23afe53 954 initloc = SCM_CDRLOC (*initloc);
0f2d19dd 955 }
ff467021 956 while (SCM_NIMP (proc = SCM_CDR (proc)));
26d5b9b4 957
3a3111a8
MD		 958 return scm_cons2 (op, vars,
959 scm_cons (inits, scm_m_body (imm, SCM_CDR (x), what)));
0f2d19dd
JB		 960}
961
26d5b9b4 962SCM_SYNTAX(s_letrec, "letrec", scm_makmmacro, scm_m_letrec);
2f0d1375 963SCM_GLOBAL_SYMBOL(scm_sym_letrec, s_letrec);
26d5b9b4
MD		 964
965SCM
6e8d25a6 966scm_m_letrec (SCM xorig, SCM env)
26d5b9b4
MD		 967{
968 SCM x = SCM_CDR (xorig);
969 SCM_ASSYNT (scm_ilength (x) >= 2, xorig, scm_s_body, s_letrec);
970
971 if (SCM_NULLP (SCM_CAR (x))) /* null binding, let* faster */
3a3111a8
MD		 972 return scm_m_letstar (scm_cons2 (SCM_CAR (xorig), SCM_EOL,
973 scm_m_body (SCM_IM_LETREC,
974 SCM_CDR (x),
975 s_letrec)),
26d5b9b4
MD		 976 env);
977 else
978 return scm_m_letrec1 (SCM_IM_LETREC, SCM_IM_LETREC, xorig, env);
979}
1cc91f1b 980
b8229a3b 981SCM_SYNTAX(s_let, "let", scm_makmmacro, scm_m_let);
2f0d1375 982SCM_GLOBAL_SYMBOL(scm_sym_let, s_let);
b8229a3b 983
0f2d19dd 984SCM
6e8d25a6 985scm_m_let (SCM xorig, SCM env)
0f2d19dd
JB		 986{
987 SCM cdrx = SCM_CDR (xorig); /* locally mutable version of form */
988 SCM x = cdrx, proc, arg1, name; /* structure traversers */
989 SCM vars = SCM_EOL, inits = SCM_EOL, *varloc = &vars, *initloc = &inits;
990
b8229a3b 991 SCM_ASSYNT (scm_ilength (x) >= 2, xorig, scm_s_body, s_let);
0f2d19dd
JB		 992 proc = SCM_CAR (x);
993 if (SCM_NULLP (proc)
0c95b57d 994 || (SCM_CONSP (proc)
26d5b9b4
MD		 995 && SCM_CONSP (SCM_CAR (proc)) && SCM_NULLP (SCM_CDR (proc))))
996 {
997 /* null or single binding, let* is faster */
3a3111a8
MD		 998 return scm_m_letstar (scm_cons2 (SCM_CAR (xorig), proc,
999 scm_m_body (SCM_IM_LET,
1000 SCM_CDR (x),
1001 s_let)),
26d5b9b4
MD		 1002 env);
1003 }
1004
b8229a3b 1005 SCM_ASSYNT (SCM_NIMP (proc), xorig, scm_s_bindings, s_let);
26d5b9b4
MD		 1006 if (SCM_CONSP (proc))
1007 {
1008 /* plain let, proc is <bindings> */
1009 return scm_m_letrec1 (SCM_IM_LET, SCM_IM_LET, xorig, env);
1010 }
1011
0f2d19dd 1012 if (!SCM_SYMBOLP (proc))
b8229a3b 1013 scm_wta (xorig, scm_s_bindings, s_let); /* bad let */
0f2d19dd
JB		 1014 name = proc; /* named let, build equiv letrec */
1015 x = SCM_CDR (x);
b8229a3b 1016 SCM_ASSYNT (scm_ilength (x) >= 2, xorig, scm_s_body, s_let);
26d5b9b4 1017 proc = SCM_CAR (x); /* bindings list */
b8229a3b 1018 SCM_ASSYNT (scm_ilength (proc) >= 0, xorig, scm_s_bindings, s_let);
ff467021 1019 while (SCM_NIMP (proc))
0f2d19dd
JB		 1020 { /* vars and inits both in order */
1021 arg1 = SCM_CAR (proc);
b8229a3b 1022 SCM_ASSYNT (2 == scm_ilength (arg1), xorig, scm_s_bindings, s_let);
0c95b57d 1023 SCM_ASSYNT (SCM_SYMBOLP (SCM_CAR (arg1)),
b8229a3b 1024 xorig, scm_s_variable, s_let);
0f2d19dd 1025 *varloc = scm_cons (SCM_CAR (arg1), SCM_EOL);
a23afe53 1026 varloc = SCM_CDRLOC (*varloc);
0f2d19dd 1027 *initloc = scm_cons (SCM_CAR (SCM_CDR (arg1)), SCM_EOL);
a23afe53 1028 initloc = SCM_CDRLOC (*initloc);
0f2d19dd
JB		 1029 proc = SCM_CDR (proc);
1030 }
26d5b9b4 1031
2f0d1375 1032 proc = scm_cons2 (scm_sym_lambda, vars,
26d5b9b4 1033 scm_m_body (SCM_IM_LET, SCM_CDR (x), "let"));
2f0d1375 1034 proc = scm_cons2 (scm_sym_let, scm_cons (scm_cons2 (name, proc, SCM_EOL),
26d5b9b4
MD		 1035 SCM_EOL),
1036 scm_acons (name, inits, SCM_EOL));
1037 return scm_m_letrec1 (SCM_IM_LETREC, SCM_IM_LET, proc, env);
0f2d19dd
JB		 1038}
1039
1040
81123e6d
MD		 1041SCM_SYNTAX (s_atapply,"@apply", scm_makmmacro, scm_m_apply);
1042SCM_GLOBAL_SYMBOL (scm_sym_atapply, s_atapply);
1043SCM_GLOBAL_SYMBOL (scm_sym_apply, s_atapply + 1);
1cc91f1b 1044
0f2d19dd 1045SCM
6e8d25a6 1046scm_m_apply (SCM xorig, SCM env)
0f2d19dd 1047{
6cb702da 1048 SCM_ASSYNT (scm_ilength (SCM_CDR (xorig)) == 2,
b8229a3b 1049 xorig, scm_s_expression, s_atapply);
0f2d19dd
JB		 1050 return scm_cons (SCM_IM_APPLY, SCM_CDR (xorig));
1051}
1052
b8229a3b
MS		 1053
1054SCM_SYNTAX(s_atcall_cc,"@call-with-current-continuation", scm_makmmacro, scm_m_cont);
2f0d1375 1055SCM_GLOBAL_SYMBOL(scm_sym_atcall_cc,s_atcall_cc);
0f2d19dd 1056
1cc91f1b 1057
0f2d19dd 1058SCM
6e8d25a6 1059scm_m_cont (SCM xorig, SCM env)
0f2d19dd 1060{
6cb702da 1061 SCM_ASSYNT (scm_ilength (SCM_CDR (xorig)) == 1,
b8229a3b 1062 xorig, scm_s_expression, s_atcall_cc);
3a3111a8 1063 return scm_cons (SCM_IM_CONT, SCM_CDR (xorig));
0f2d19dd
JB		 1064}
1065
73b64342
MD		 1066/* Multi-language support */
1067
1068SCM scm_nil;
1069SCM scm_t;
1070
1071SCM_SYNTAX (s_nil_cond, "nil-cond", scm_makmmacro, scm_m_nil_cond);
1072
1073SCM
1074scm_m_nil_cond (SCM xorig, SCM env)
1075{
1076 int len = scm_ilength (SCM_CDR (xorig));
1077 SCM_ASSYNT (len >= 1 && (len & 1) == 1, xorig,
1078 scm_s_expression, "nil-cond");
1079 return scm_cons (SCM_IM_NIL_COND, SCM_CDR (xorig));
1080}
1081
1082SCM_SYNTAX (s_nil_ify, "nil-ify", scm_makmmacro, scm_m_nil_ify);
1083
1084SCM
1085scm_m_nil_ify (SCM xorig, SCM env)
1086{
1087 SCM_ASSYNT (scm_ilength (SCM_CDR (xorig)) == 1,
1088 xorig, scm_s_expression, "nil-ify");
1089 return scm_cons (SCM_IM_NIL_IFY, SCM_CDR (xorig));
1090}
1091
1092SCM_SYNTAX (s_t_ify, "t-ify", scm_makmmacro, scm_m_t_ify);
1093
1094SCM
1095scm_m_t_ify (SCM xorig, SCM env)
1096{
1097 SCM_ASSYNT (scm_ilength (SCM_CDR (xorig)) == 1,
1098 xorig, scm_s_expression, "t-ify");
1099 return scm_cons (SCM_IM_T_IFY, SCM_CDR (xorig));
1100}
1101
1102SCM_SYNTAX (s_0_cond, "0-cond", scm_makmmacro, scm_m_0_cond);
1103
1104SCM
1105scm_m_0_cond (SCM xorig, SCM env)
1106{
1107 int len = scm_ilength (SCM_CDR (xorig));
1108 SCM_ASSYNT (len >= 1 && (len & 1) == 1, xorig,
1109 scm_s_expression, "0-cond");
1110 return scm_cons (SCM_IM_0_COND, SCM_CDR (xorig));
1111}
1112
1113SCM_SYNTAX (s_0_ify, "0-ify", scm_makmmacro, scm_m_0_ify);
1114
1115SCM
1116scm_m_0_ify (SCM xorig, SCM env)
1117{
1118 SCM_ASSYNT (scm_ilength (SCM_CDR (xorig)) == 1,
1119 xorig, scm_s_expression, "0-ify");
1120 return scm_cons (SCM_IM_0_IFY, SCM_CDR (xorig));
1121}
1122
1123SCM_SYNTAX (s_1_ify, "1-ify", scm_makmmacro, scm_m_1_ify);
1124
1125SCM
1126scm_m_1_ify (SCM xorig, SCM env)
1127{
1128 SCM_ASSYNT (scm_ilength (SCM_CDR (xorig)) == 1,
1129 xorig, scm_s_expression, "1-ify");
1130 return scm_cons (SCM_IM_1_IFY, SCM_CDR (xorig));
1131}
1132
1133SCM_SYNTAX (s_atfop, "@fop", scm_makmmacro, scm_m_atfop);
1134
1135SCM
1136scm_m_atfop (SCM xorig, SCM env)
1137{
1138 SCM x = SCM_CDR (xorig), vcell;
1139 SCM_ASSYNT (scm_ilength (x) >= 1, xorig, scm_s_expression, "@fop");
1140 vcell = scm_symbol_fref (SCM_CAR (x));
0c95b57d 1141 SCM_ASSYNT (SCM_CONSP (vcell), x,
73b64342
MD		 1142 "Symbol's function definition is void", NULL);
1143 SCM_SETCAR (x, vcell + 1);
1144 return x;
1145}
1146
1147SCM_SYNTAX (s_atbind, "@bind", scm_makmmacro, scm_m_atbind);
1148
1149SCM
1150scm_m_atbind (SCM xorig, SCM env)
1151{
1152 SCM x = SCM_CDR (xorig);
1153 SCM_ASSYNT (scm_ilength (x) > 1, xorig, scm_s_expression, "@bind");
1154
1155 if (SCM_IMP (env))
1156 env = SCM_BOOL_F;
1157 else
1158 {
1159 while (SCM_NIMP (SCM_CDR (env)))
1160 env = SCM_CDR (env);
1161 env = SCM_CAR (env);
1162 if (SCM_CONSP (env))
1163 env = SCM_BOOL_F;
1164 }
1165
1166 x = SCM_CAR (x);
1167 while (SCM_NIMP (x))
1168 {
1169 SCM_SETCAR (x, scm_sym2vcell (SCM_CAR (x), env, SCM_BOOL_T) + 1);
1170 x = SCM_CDR (x);
1171 }
1172 return scm_cons (SCM_IM_BIND, SCM_CDR (xorig));
1173}
73b64342 1174
26d5b9b4
MD		 1175SCM
1176scm_m_expand_body (SCM xorig, SCM env)
1177{
1178 SCM form, x = SCM_CDR (xorig), defs = SCM_EOL;
1179 char *what = SCM_ISYMCHARS (SCM_CAR (xorig)) + 2;
1180
1181 while (SCM_NIMP (x))
1182 {
1183 form = SCM_CAR (x);
1184 if (SCM_IMP (form) || SCM_NCONSP (form))
1185 break;
1186 if (SCM_IMP (SCM_CAR (form)))
1187 break;
1188 if (!SCM_SYMBOLP (SCM_CAR (form)))
1189 break;
1190
3a3111a8
MD		 1191 form = scm_macroexp (scm_cons_source (form,
1192 SCM_CAR (form),
1193 SCM_CDR (form)),
1194 env);
26d5b9b4
MD		 1195
1196 if (SCM_IM_DEFINE == SCM_CAR (form))
1197 {
1198 defs = scm_cons (SCM_CDR (form), defs);
1199 x = SCM_CDR(x);
1200 }
1201 else if (SCM_NIMP(defs))
1202 {
1203 break;
1204 }
1205 else if (SCM_IM_BEGIN == SCM_CAR (form))
1206 {
1207 x = scm_append (scm_cons2 (SCM_CDR (form), SCM_CDR (x), SCM_EOL));
1208 }
1209 else
1210 {
1211 x = scm_cons (form, SCM_CDR(x));
1212 break;
1213 }
1214 }
1215
1216 SCM_ASSYNT (SCM_NIMP (x), SCM_CDR (xorig), scm_s_body, what);
1217 if (SCM_NIMP (defs))
1218 {
1219 x = scm_cons (scm_m_letrec1 (SCM_IM_LETREC,
1220 SCM_IM_DEFINE,
2f0d1375 1221 scm_cons2 (scm_sym_define, defs, x),
26d5b9b4
MD		 1222 env),
1223 SCM_EOL);
1224 }
1225
1226 SCM_DEFER_INTS;
1227 SCM_SETCAR (xorig, SCM_CAR (x));
1228 SCM_SETCDR (xorig, SCM_CDR (x));
1229 SCM_ALLOW_INTS;
1230
1231 return xorig;
1232}
1233
1234SCM
1235scm_macroexp (SCM x, SCM env)
1236{
1237 SCM res, proc;
1238
1239 /* Don't bother to produce error messages here. We get them when we
1240 eventually execute the code for real. */
1241
1242 macro_tail:
1243 if (SCM_IMP (SCM_CAR (x)) || !SCM_SYMBOLP (SCM_CAR (x)))
1244 return x;
1245
1246#ifdef USE_THREADS
1247 {
1248 SCM *proc_ptr = scm_lookupcar1 (x, env, 0);
1249 if (proc_ptr == NULL)
1250 {
1251 /* We have lost the race. */
1252 goto macro_tail;
1253 }
1254 proc = *proc_ptr;
1255 }
1256#else
1257 proc = *scm_lookupcar (x, env, 0);
1258#endif
1259
1260 /* Only handle memoizing macros. `Acros' and `macros' are really
1261 special forms and should not be evaluated here. */
1262
1263 if (SCM_IMP (proc)
1264 || scm_tc16_macro != SCM_TYP16 (proc)
1265 || (int) (SCM_CAR (proc) >> 16) != 2)
1266 return x;
1267
1268 unmemocar (x, env);
1269 res = scm_apply (SCM_CDR (proc), x, scm_cons (env, scm_listofnull));
1270
1271 if (scm_ilength (res) <= 0)
1272 res = scm_cons2 (SCM_IM_BEGIN, res, SCM_EOL);
1273
26d5b9b4
MD		 1274 SCM_DEFER_INTS;
1275 SCM_SETCAR (x, SCM_CAR (res));
1276 SCM_SETCDR (x, SCM_CDR (res));
1277 SCM_ALLOW_INTS;
1278
1279 goto macro_tail;
1280}
73b64342 1281
6dbd0af5
MD		 1282/* scm_unmemocopy takes a memoized expression together with its
1283 * environment and rewrites it to its original form. Thus, it is the
1284 * inversion of the rewrite rules above. The procedure is not
1285 * optimized for speed. It's used in scm_iprin1 when printing the
220ff1eb
MD		 1286 * code of a closure, in scm_procedure_source, in display_frame when
1287 * generating the source for a stackframe in a backtrace, and in
1288 * display_expression.
6dbd0af5
MD		 1289 */
1290
26d5b9b4
MD		 1291/* We should introduce an anti-macro interface so that it is possible
1292 * to plug in transformers in both directions from other compilation
1293 * units. unmemocopy could then dispatch to anti-macro transformers.
1294 * (Those transformers could perhaps be written in slightly more
1295 * readable style... :)
1296 */
1297
6dbd0af5 1298static SCM
1bbd0b84 1299unmemocopy (SCM x, SCM env)
6dbd0af5
MD		 1300{
1301 SCM ls, z;
1302#ifdef DEBUG_EXTENSIONS
1303 SCM p;
1304#endif
1305 if (SCM_NCELLP (x) || SCM_NECONSP (x))
1306 return x;
1307#ifdef DEBUG_EXTENSIONS
1308 p = scm_whash_lookup (scm_source_whash, x);
1309#endif
1310 switch (SCM_TYP7 (x))
1311 {
1312 case (127 & SCM_IM_AND):
2f0d1375 1313 ls = z = scm_cons (scm_sym_and, SCM_UNSPECIFIED);
6dbd0af5
MD		 1314 break;
1315 case (127 & SCM_IM_BEGIN):
2f0d1375 1316 ls = z = scm_cons (scm_sym_begin, SCM_UNSPECIFIED);
6dbd0af5
MD		 1317 break;
1318 case (127 & SCM_IM_CASE):
2f0d1375 1319 ls = z = scm_cons (scm_sym_case, SCM_UNSPECIFIED);
6dbd0af5
MD		 1320 break;
1321 case (127 & SCM_IM_COND):
2f0d1375 1322 ls = z = scm_cons (scm_sym_cond, SCM_UNSPECIFIED);
6dbd0af5
MD		 1323 break;
1324 case (127 & SCM_IM_DO):
2f0d1375 1325 ls = scm_cons (scm_sym_do, SCM_UNSPECIFIED);
6dbd0af5
MD		 1326 goto transform;
1327 case (127 & SCM_IM_IF):
2f0d1375 1328 ls = z = scm_cons (scm_sym_if, SCM_UNSPECIFIED);
6dbd0af5
MD		 1329 break;
1330 case (127 & SCM_IM_LET):
2f0d1375 1331 ls = scm_cons (scm_sym_let, SCM_UNSPECIFIED);
6dbd0af5
MD		 1332 goto transform;
1333 case (127 & SCM_IM_LETREC):
1334 {
1335 SCM f, v, e, s;
2f0d1375 1336 ls = scm_cons (scm_sym_letrec, SCM_UNSPECIFIED);
6dbd0af5
MD		 1337 transform:
1338 x = SCM_CDR (x);
26d5b9b4 1339 /* binding names */
6dbd0af5
MD		 1340 f = v = SCM_CAR (x);
1341 x = SCM_CDR (x);
e2806c10 1342 z = EXTEND_ENV (f, SCM_EOL, env);
26d5b9b4 1343 /* inits */
6dbd0af5 1344 e = scm_reverse (unmemocopy (SCM_CAR (x),
2f0d1375 1345 SCM_CAR (ls) == scm_sym_letrec ? z : env));
6dbd0af5 1346 env = z;
26d5b9b4 1347 /* increments */
2f0d1375 1348 s = SCM_CAR (ls) == scm_sym_do
6dbd0af5
MD		 1349 ? scm_reverse (unmemocopy (SCM_CDR (SCM_CDR (SCM_CDR (x))), env))
1350 : f;
26d5b9b4 1351 /* build transformed binding list */
6dbd0af5
MD		 1352 z = SCM_EOL;
1353 do
1354 {
1355 z = scm_acons (SCM_CAR (v),
1356 scm_cons (SCM_CAR (e),
1357 SCM_CAR (s) == SCM_CAR (v)
1358 ? SCM_EOL
1359 : scm_cons (SCM_CAR (s), SCM_EOL)),
1360 z);
1361 v = SCM_CDR (v);
1362 e = SCM_CDR (e);
1363 s = SCM_CDR (s);
1364 }
ff467021 1365 while (SCM_NIMP (v));
a23afe53
MD		 1366 z = scm_cons (z, SCM_UNSPECIFIED);
1367 SCM_SETCDR (ls, z);
2f0d1375 1368 if (SCM_CAR (ls) == scm_sym_do)
6dbd0af5
MD		 1369 {
1370 x = SCM_CDR (x);
26d5b9b4 1371 /* test clause */
a23afe53 1372 SCM_SETCDR (z, scm_cons (unmemocopy (SCM_CAR (x), env),
6dbd0af5 1373 SCM_UNSPECIFIED));
a23afe53
MD		 1374 z = SCM_CDR (z);
1375 x = (SCM) (SCM_CARLOC (SCM_CDR (x)) - 1);
26d5b9b4
MD		 1376 /* body forms are now to be found in SCM_CDR (x)
1377 (this is how *real* code look like! :) */
6dbd0af5
MD		 1378 }
1379 break;
1380 }
1381 case (127 & SCM_IM_LETSTAR):
1382 {
1383 SCM b, y;
1384 x = SCM_CDR (x);
1385 b = SCM_CAR (x);
1386 y = SCM_EOL;
1387 if SCM_IMP (b)
1388 {
e2806c10 1389 env = EXTEND_ENV (SCM_EOL, SCM_EOL, env);
6dbd0af5
MD		 1390 goto letstar;
1391 }
1392 y = z = scm_acons (SCM_CAR (b),
1393 unmemocar (
1394 scm_cons (unmemocopy (SCM_CAR (SCM_CDR (b)), env), SCM_EOL), env),
1395 SCM_UNSPECIFIED);
e2806c10 1396 env = EXTEND_ENV (SCM_CAR (b), SCM_BOOL_F, env);
6dbd0af5
MD		 1397 b = SCM_CDR (SCM_CDR (b));
1398 if (SCM_IMP (b))
1399 {
1400 SCM_SETCDR (y, SCM_EOL);
2f0d1375 1401 ls = scm_cons (scm_sym_let, z = scm_cons (y, SCM_UNSPECIFIED));
6dbd0af5
MD		 1402 break;
1403 }
1404 do
1405 {
a23afe53
MD		 1406 SCM_SETCDR (z, scm_acons (SCM_CAR (b),
1407 unmemocar (
6dbd0af5 1408 scm_cons (unmemocopy (SCM_CAR (SCM_CDR (b)), env), SCM_EOL), env),
a23afe53
MD		 1409 SCM_UNSPECIFIED));
1410 z = SCM_CDR (z);
e2806c10 1411 env = EXTEND_ENV (SCM_CAR (b), SCM_BOOL_F, env);
6dbd0af5
MD		 1412 b = SCM_CDR (SCM_CDR (b));
1413 }
ff467021 1414 while (SCM_NIMP (b));
a23afe53 1415 SCM_SETCDR (z, SCM_EOL);
6dbd0af5 1416 letstar:
2f0d1375 1417 ls = scm_cons (scm_sym_letstar, z = scm_cons (y, SCM_UNSPECIFIED));
6dbd0af5
MD		 1418 break;
1419 }
1420 case (127 & SCM_IM_OR):
2f0d1375 1421 ls = z = scm_cons (scm_sym_or, SCM_UNSPECIFIED);
6dbd0af5
MD		 1422 break;
1423 case (127 & SCM_IM_LAMBDA):
1424 x = SCM_CDR (x);
2f0d1375 1425 ls = scm_cons (scm_sym_lambda,
6dbd0af5 1426 z = scm_cons (SCM_CAR (x), SCM_UNSPECIFIED));
e2806c10 1427 env = EXTEND_ENV (SCM_CAR (x), SCM_EOL, env);
6dbd0af5
MD		 1428 break;
1429 case (127 & SCM_IM_QUOTE):
2f0d1375 1430 ls = z = scm_cons (scm_sym_quote, SCM_UNSPECIFIED);
6dbd0af5 1431 break;
89efbff4
MD		 1432 case (127 & SCM_IM_SET_X):
1433 ls = z = scm_cons (scm_sym_set_x, SCM_UNSPECIFIED);
6dbd0af5
MD		 1434 break;
1435 case (127 & SCM_IM_DEFINE):
1436 {
1437 SCM n;
1438 x = SCM_CDR (x);
2f0d1375 1439 ls = scm_cons (scm_sym_define,
6dbd0af5
MD		 1440 z = scm_cons (n = SCM_CAR (x), SCM_UNSPECIFIED));
1441 if (SCM_NNULLP (env))
a23afe53 1442 SCM_SETCAR (SCM_CAR (env), scm_cons (n, SCM_CAR (SCM_CAR (env))));
6dbd0af5
MD		 1443 break;
1444 }
1445 case (127 & SCM_MAKISYM (0)):
1446 z = SCM_CAR (x);
1447 if (!SCM_ISYMP (z))
1448 goto unmemo;
ff467021 1449 switch (SCM_ISYMNUM (z))
6dbd0af5
MD		 1450 {
1451 case (SCM_ISYMNUM (SCM_IM_APPLY)):
2f0d1375 1452 ls = z = scm_cons (scm_sym_atapply, SCM_UNSPECIFIED);
6dbd0af5
MD		 1453 goto loop;
1454 case (SCM_ISYMNUM (SCM_IM_CONT)):
2f0d1375 1455 ls = z = scm_cons (scm_sym_atcall_cc, SCM_UNSPECIFIED);
6dbd0af5 1456 goto loop;
a570e93a
MD		 1457 case (SCM_ISYMNUM (SCM_IM_DELAY)):
1458 ls = z = scm_cons (scm_sym_delay, SCM_UNSPECIFIED);
1459 x = SCM_CDR (x);
1460 goto loop;
6dbd0af5 1461 default:
fa888178 1462 /* appease the Sun compiler god: */ ;
6dbd0af5
MD		 1463 }
1464 unmemo:
1465 default:
1466 ls = z = unmemocar (scm_cons (unmemocopy (SCM_CAR (x), env),
1467 SCM_UNSPECIFIED),
1468 env);
1469 }
1470loop:
1471 while (SCM_CELLP (x = SCM_CDR (x)) && SCM_ECONSP (x))
a23afe53 1472 {
26d5b9b4
MD		 1473 if (SCM_IMP (SCM_CAR (x)) && SCM_ISYMP (SCM_CAR (x)))
1474 /* skip body markers */
1475 continue;
a23afe53
MD		 1476 SCM_SETCDR (z, unmemocar (scm_cons (unmemocopy (SCM_CAR (x), env),
1477 SCM_UNSPECIFIED),
1478 env));
1479 z = SCM_CDR (z);
1480 }
1481 SCM_SETCDR (z, x);
6dbd0af5
MD		 1482#ifdef DEBUG_EXTENSIONS
1483 if (SCM_NFALSEP (p))
1484 scm_whash_insert (scm_source_whash, ls, p);
1485#endif
1486 return ls;
1487}
1488
1cc91f1b 1489
6dbd0af5 1490SCM
6e8d25a6 1491scm_unmemocopy (SCM x, SCM env)
6dbd0af5
MD		 1492{
1493 if (SCM_NNULLP (env))
1494 /* Make a copy of the lowest frame to protect it from
1495 modifications by SCM_IM_DEFINE */
1496 return unmemocopy (x, scm_cons (SCM_CAR (env), SCM_CDR (env)));
1497 else
1498 return unmemocopy (x, env);
1499}
1500
cf7c17e9 1501#ifndef SCM_RECKLESS
1cc91f1b 1502
0f2d19dd 1503int
6e8d25a6 1504scm_badargsp (SCM formals, SCM args)
0f2d19dd 1505{
ff467021 1506 while (SCM_NIMP (formals))
0f2d19dd 1507 {
ff467021
JB		 1508 if (SCM_NCONSP (formals))
1509 return 0;
1510 if (SCM_IMP(args))
1511 return 1;
0f2d19dd
JB		 1512 formals = SCM_CDR (formals);
1513 args = SCM_CDR (args);
1514 }
1515 return SCM_NNULLP (args) ? 1 : 0;
1516}
1517#endif
1518
1519
1520\f
6dbd0af5 1521SCM
6e8d25a6 1522scm_eval_args (SCM l, SCM env, SCM proc)
6dbd0af5 1523{
680ed4a8 1524 SCM results = SCM_EOL, *lloc = &results, res;
6dbd0af5
MD		 1525 while (SCM_NIMP (l))
1526 {
cf7c17e9 1527#ifdef SCM_CAUTIOUS
680ed4a8
MD		 1528 if (SCM_IMP (l))
1529 goto wrongnumargs;
1530 else if (SCM_CONSP (l))
1531 {
1532 if (SCM_IMP (SCM_CAR (l)))
6cb702da 1533 res = SCM_EVALIM (SCM_CAR (l), env);
680ed4a8
MD		 1534 else
1535 res = EVALCELLCAR (l, env);
1536 }
1537 else if (SCM_TYP3 (l) == 1)
1538 {
1539 if ((res = SCM_GLOC_VAL (SCM_CAR (l))) == 0)
1540 res = SCM_CAR (l); /* struct planted in code */
1541 }
1542 else
1543 goto wrongnumargs;
1544#else
1545 res = EVALCAR (l, env);
1546#endif
1547 *lloc = scm_cons (res, SCM_EOL);
a23afe53 1548 lloc = SCM_CDRLOC (*lloc);
6dbd0af5
MD		 1549 l = SCM_CDR (l);
1550 }
cf7c17e9 1551#ifdef SCM_CAUTIOUS
680ed4a8
MD		 1552 if (SCM_NNULLP (l))
1553 {
1554 wrongnumargs:
1555 scm_wrong_num_args (proc);
1556 }
1557#endif
1558 return results;
6dbd0af5 1559}
c4ac4d88 1560
9de33deb
MD		 1561SCM
1562scm_eval_body (SCM code, SCM env)
1563{
1564 SCM next;
1565 again:
1566 next = code;
1567 while (SCM_NNULLP (next = SCM_CDR (next)))
1568 {
1569 if (SCM_IMP (SCM_CAR (code)))
1570 {
1571 if (SCM_ISYMP (SCM_CAR (code)))
1572 {
1573 code = scm_m_expand_body (code, env);
1574 goto again;
1575 }
1576 }
1577 else
1578 SCM_XEVAL (SCM_CAR (code), env);
1579 code = next;
1580 }
1581 return SCM_XEVALCAR (code, env);
1582}
1583
c4ac4d88 1584
0f2d19dd
JB		 1585#endif /* !DEVAL */
1586
6dbd0af5
MD		 1587
1588/* SECTION: This code is specific for the debugging support. One
1589 * branch is read when DEVAL isn't defined, the other when DEVAL is
1590 * defined.
1591 */
1592
1593#ifndef DEVAL
1594
1595#define SCM_APPLY scm_apply
1596#define PREP_APPLY(proc, args)
1597#define ENTER_APPLY
1598#define RETURN(x) return x;
b7ff98dd
MD		 1599#ifdef STACK_CHECKING
1600#ifndef NO_CEVAL_STACK_CHECKING
1601#define EVAL_STACK_CHECKING
1602#endif
6dbd0af5
MD		 1603#endif
1604
1605#else /* !DEVAL */
1606
0f2d19dd
JB		 1607#undef SCM_CEVAL
1608#define SCM_CEVAL scm_deval /* Substitute all uses of scm_ceval */
1609#undef SCM_APPLY
1610#define SCM_APPLY scm_dapply
6dbd0af5
MD		 1611#undef PREP_APPLY
1612#define PREP_APPLY(p, l) \
1613{ ++debug.info; debug.info->a.proc = p; debug.info->a.args = l; }
1614#undef ENTER_APPLY
1615#define ENTER_APPLY \
d3a6bc94 1616do { \
b7ff98dd 1617 SCM_SET_ARGSREADY (debug);\
b6d75948 1618 if (CHECK_APPLY && SCM_TRAPS_P)\
b7ff98dd 1619 if (SCM_APPLY_FRAME_P || (SCM_TRACE_P && PROCTRACEP (proc)))\
6dbd0af5 1620 {\
156dcb09 1621 SCM tmp, tail = SCM_BOOL(SCM_TRACED_FRAME_P (debug)); \
c6a4fbce 1622 SCM_SET_TRACED_FRAME (debug); \
b7ff98dd 1623 if (SCM_CHEAPTRAPS_P)\
6dbd0af5 1624 {\
c0ab1b8d 1625 tmp = scm_make_debugobj (&debug);\
2f0d1375 1626 scm_ithrow (scm_sym_apply_frame, scm_cons2 (tmp, tail, SCM_EOL), 0);\
b6d75948 1627 }\
6dbd0af5
MD		 1628 else\
1629 {\
1630 scm_make_cont (&tmp);\
ca6ef71a 1631 if (!setjmp (SCM_JMPBUF (tmp)))\
2f0d1375 1632 scm_ithrow (scm_sym_apply_frame, scm_cons2 (tmp, tail, SCM_EOL), 0);\
6dbd0af5
MD		 1633 }\
1634 }\
d3a6bc94 1635} while (0)
0f2d19dd
JB		 1636#undef RETURN
1637#define RETURN(e) {proc = (e); goto exit;}
b7ff98dd
MD		 1638#ifdef STACK_CHECKING
1639#ifndef EVAL_STACK_CHECKING
1640#define EVAL_STACK_CHECKING
1641#endif
6dbd0af5
MD		 1642#endif
1643
1644/* scm_ceval_ptr points to the currently selected evaluator.
1645 * *fixme*: Although efficiency is important here, this state variable
1646 * should probably not be a global. It should be related to the
1647 * current repl.
1648 */
1649
1cc91f1b 1650
1bbd0b84 1651SCM (*scm_ceval_ptr) (SCM x, SCM env);
0f2d19dd 1652
1646d37b 1653/* scm_last_debug_frame contains a pointer to the last debugging
6dbd0af5
MD		 1654 * information stack frame. It is accessed very often from the
1655 * debugging evaluator, so it should probably not be indirectly
1656 * addressed. Better to save and restore it from the current root at
1657 * any stack swaps.
1658 */
1659
1646d37b
MD		 1660#ifndef USE_THREADS
1661scm_debug_frame *scm_last_debug_frame;
1662#endif
6dbd0af5
MD		 1663
1664/* scm_debug_eframe_size is the number of slots available for pseudo
1665 * stack frames at each real stack frame.
1666 */
1667
1668int scm_debug_eframe_size;
1669
b7ff98dd 1670int scm_debug_mode, scm_check_entry_p, scm_check_apply_p, scm_check_exit_p;
6dbd0af5 1671
a74145b8
MD		 1672int scm_eval_stack;
1673
33b97402 1674scm_option scm_eval_opts[] = {
a74145b8 1675 { SCM_OPTION_INTEGER, "stack", 22000, "Size of thread stacks (in machine words)." }
33b97402
MD		 1676};
1677
6dbd0af5 1678scm_option scm_debug_opts[] = {
b7ff98dd
MD		 1679 { SCM_OPTION_BOOLEAN, "cheap", 1,
1680 "*Flyweight representation of the stack at traps." },
1681 { SCM_OPTION_BOOLEAN, "breakpoints", 0, "*Check for breakpoints." },
1682 { SCM_OPTION_BOOLEAN, "trace", 0, "*Trace mode." },
1683 { SCM_OPTION_BOOLEAN, "procnames", 1,
1684 "Record procedure names at definition." },
1685 { SCM_OPTION_BOOLEAN, "backwards", 0,
1686 "Display backtrace in anti-chronological order." },
274dc5fd 1687 { SCM_OPTION_INTEGER, "width", 79, "Maximal width of backtrace." },
4e646a03
MD		 1688 { SCM_OPTION_INTEGER, "indent", 10, "Maximal indentation in backtrace." },
1689 { SCM_OPTION_INTEGER, "frames", 3,
b7ff98dd 1690 "Maximum number of tail-recursive frames in backtrace." },
4e646a03
MD		 1691 { SCM_OPTION_INTEGER, "maxdepth", 1000,
1692 "Maximal number of stored backtrace frames." },
1693 { SCM_OPTION_INTEGER, "depth", 20, "Maximal length of printed backtrace." },
11f77bfc
MD		 1694 { SCM_OPTION_BOOLEAN, "backtrace", 0, "Show backtrace on error." },
1695 { SCM_OPTION_BOOLEAN, "debug", 0, "Use the debugging evaluator." },
a74145b8 1696 { SCM_OPTION_INTEGER, "stack", 20000, "Stack size limit (measured in words; 0 = no check)." }
6dbd0af5
MD		 1697};
1698
1699scm_option scm_evaluator_trap_table[] = {
b6d75948 1700 { SCM_OPTION_BOOLEAN, "traps", 0, "Enable evaluator traps." },
b7ff98dd
MD		 1701 { SCM_OPTION_BOOLEAN, "enter-frame", 0, "Trap when eval enters new frame." },
1702 { SCM_OPTION_BOOLEAN, "apply-frame", 0, "Trap when entering apply." },
1703 { SCM_OPTION_BOOLEAN, "exit-frame", 0, "Trap when exiting eval or apply." }
6dbd0af5
MD		 1704};
1705
a1ec6916 1706SCM_DEFINE (scm_eval_options_interface, "eval-options-interface", 0, 1, 0,
1bbd0b84
GB		 1707 (SCM setting),
1708"")
1709#define FUNC_NAME s_scm_eval_options_interface
33b97402
MD		 1710{
1711 SCM ans;
1712 SCM_DEFER_INTS;
1713 ans = scm_options (setting,
1714 scm_eval_opts,
1715 SCM_N_EVAL_OPTIONS,
1bbd0b84 1716 FUNC_NAME);
a74145b8 1717 scm_eval_stack = SCM_EVAL_STACK * sizeof (void *);
33b97402
MD		 1718 SCM_ALLOW_INTS;
1719 return ans;
1720}
1bbd0b84 1721#undef FUNC_NAME
33b97402 1722
a1ec6916 1723SCM_DEFINE (scm_evaluator_traps, "evaluator-traps-interface", 0, 1, 0,
1bbd0b84
GB		 1724 (SCM setting),
1725"")
1726#define FUNC_NAME s_scm_evaluator_traps
33b97402
MD		 1727{
1728 SCM ans;
1729 SCM_DEFER_INTS;
1730 ans = scm_options (setting,
1731 scm_evaluator_trap_table,
1732 SCM_N_EVALUATOR_TRAPS,
1bbd0b84 1733 FUNC_NAME);
33b97402 1734 SCM_RESET_DEBUG_MODE;
bfc69694 1735 SCM_ALLOW_INTS;
33b97402
MD		 1736 return ans;
1737}
1bbd0b84 1738#undef FUNC_NAME
33b97402 1739
6dbd0af5 1740SCM
6e8d25a6 1741scm_deval_args (SCM l, SCM env, SCM proc, SCM *lloc)
0f2d19dd 1742{
680ed4a8 1743 SCM *results = lloc, res;
0f2d19dd
JB		 1744 while (SCM_NIMP (l))
1745 {
cf7c17e9 1746#ifdef SCM_CAUTIOUS
680ed4a8
MD		 1747 if (SCM_IMP (l))
1748 goto wrongnumargs;
1749 else if (SCM_CONSP (l))
1750 {
1751 if (SCM_IMP (SCM_CAR (l)))
6cb702da 1752 res = SCM_EVALIM (SCM_CAR (l), env);
680ed4a8
MD		 1753 else
1754 res = EVALCELLCAR (l, env);
1755 }
1756 else if (SCM_TYP3 (l) == 1)
1757 {
1758 if ((res = SCM_GLOC_VAL (SCM_CAR (l))) == 0)
1759 res = SCM_CAR (l); /* struct planted in code */
1760 }
1761 else
1762 goto wrongnumargs;
1763#else
1764 res = EVALCAR (l, env);
1765#endif
1766 *lloc = scm_cons (res, SCM_EOL);
a23afe53 1767 lloc = SCM_CDRLOC (*lloc);
0f2d19dd
JB		 1768 l = SCM_CDR (l);
1769 }
cf7c17e9 1770#ifdef SCM_CAUTIOUS
680ed4a8
MD		 1771 if (SCM_NNULLP (l))
1772 {
1773 wrongnumargs:
1774 scm_wrong_num_args (proc);
1775 }
1776#endif
1777 return *results;
0f2d19dd
JB		 1778}
1779
6dbd0af5
MD		 1780#endif /* !DEVAL */
1781
1782
1783/* SECTION: Some local definitions for the evaluator.
1784 */
1785
1786#ifndef DEVAL
1787#ifdef SCM_FLOATS
1788#define CHECK_EQVISH(A,B) (((A) == (B)) || (SCM_NFALSEP (scm_eqv_p ((A), (B)))))
1789#else
1790#define CHECK_EQVISH(A,B) ((A) == (B))
1791#endif
1792#endif /* DEVAL */
1793
399dedcc 1794#define BUILTIN_RPASUBR /* Handle rpsubrs and asubrs without calling apply */
6dbd0af5
MD		 1795
1796/* SECTION: This is the evaluator. Like any real monster, it has
1797 * three heads. This code is compiled twice.
1798 */
1799
0f2d19dd 1800#if 0
1cc91f1b 1801
0f2d19dd 1802SCM
1bbd0b84 1803scm_ceval (SCM x, SCM env)
0f2d19dd
JB		 1804{}
1805#endif
1806#if 0
1cc91f1b 1807
0f2d19dd 1808SCM
1bbd0b84 1809scm_deval (SCM x, SCM env)
0f2d19dd
JB		 1810{}
1811#endif
1812
6dbd0af5 1813SCM
1bbd0b84 1814SCM_CEVAL (SCM x, SCM env)
0f2d19dd
JB		 1815{
1816 union
1817 {
1818 SCM *lloc;
1819 SCM arg1;
f8769b1d 1820 } t;
6dbd0af5
MD		 1821 SCM proc, arg2;
1822#ifdef DEVAL
c0ab1b8d
JB		 1823 scm_debug_frame debug;
1824 scm_debug_info *debug_info_end;
1646d37b 1825 debug.prev = scm_last_debug_frame;
6dbd0af5 1826 debug.status = scm_debug_eframe_size;
04b6c081
MD		 1827 /*
1828 * The debug.vect contains twice as much scm_debug_info frames as the
1829 * user has specified with (debug-set! frames <n>).
1830 *
1831 * Even frames are eval frames, odd frames are apply frames.
1832 */
c0ab1b8d
JB		 1833 debug.vect = (scm_debug_info *) alloca (scm_debug_eframe_size
1834 * sizeof (debug.vect[0]));
1835 debug.info = debug.vect;
1836 debug_info_end = debug.vect + scm_debug_eframe_size;
1837 scm_last_debug_frame = &debug;
6dbd0af5 1838#endif
b7ff98dd 1839#ifdef EVAL_STACK_CHECKING
6f13f9cb
MD		 1840 if (scm_stack_checking_enabled_p
1841 && SCM_STACK_OVERFLOW_P ((SCM_STACKITEM *) &proc))
6dbd0af5 1842 {
b7ff98dd 1843#ifdef DEVAL
6dbd0af5
MD		 1844 debug.info->e.exp = x;
1845 debug.info->e.env = env;
b7ff98dd 1846#endif
6dbd0af5
MD		 1847 scm_report_stack_overflow ();
1848 }
1849#endif
1850#ifdef DEVAL
1851 goto start;
1852#endif
1853loopnoap:
1854 PREP_APPLY (SCM_UNDEFINED, SCM_EOL);
1855loop:
1856#ifdef DEVAL
b7ff98dd
MD		 1857 SCM_CLEAR_ARGSREADY (debug);
1858 if (SCM_OVERFLOWP (debug))
6dbd0af5 1859 --debug.info;
04b6c081
MD		 1860 /*
1861 * In theory, this should be the only place where it is necessary to
1862 * check for space in debug.vect since both eval frames and
1863 * available space are even.
1864 *
1865 * For this to be the case, however, it is necessary that primitive
1866 * special forms which jump back to `loop', `begin' or some similar
1867 * label call PREP_APPLY. A convenient way to do this is to jump to
1868 * `loopnoap' or `cdrxnoap'.
1869 */
c0ab1b8d 1870 else if (++debug.info >= debug_info_end)
6dbd0af5 1871 {
b7ff98dd 1872 SCM_SET_OVERFLOW (debug);
6dbd0af5
MD		 1873 debug.info -= 2;
1874 }
1875start:
1876 debug.info->e.exp = x;
1877 debug.info->e.env = env;
b6d75948 1878 if (CHECK_ENTRY && SCM_TRAPS_P)
b7ff98dd 1879 if (SCM_ENTER_FRAME_P || (SCM_BREAKPOINTS_P && SRCBRKP (x)))
6dbd0af5 1880 {
156dcb09 1881 SCM tail = SCM_BOOL(SCM_TAILRECP (debug));
b7ff98dd 1882 SCM_SET_TAILREC (debug);
b7ff98dd 1883 if (SCM_CHEAPTRAPS_P)
c0ab1b8d 1884 t.arg1 = scm_make_debugobj (&debug);
6dbd0af5
MD		 1885 else
1886 {
1887 scm_make_cont (&t.arg1);
ca6ef71a 1888 if (setjmp (SCM_JMPBUF (t.arg1)))
6dbd0af5
MD		 1889 {
1890 x = SCM_THROW_VALUE (t.arg1);
1891 if (SCM_IMP (x))
1892 {
1893 RETURN (x);
1894 }
1895 else
1896 /* This gives the possibility for the debugger to
1897 modify the source expression before evaluation. */
1898 goto dispatch;
1899 }
1900 }
2f0d1375 1901 scm_ithrow (scm_sym_enter_frame,
6dbd0af5
MD		 1902 scm_cons2 (t.arg1, tail,
1903 scm_cons (scm_unmemocopy (x, env), SCM_EOL)),
1904 0);
1905 }
6dbd0af5 1906#endif
e3173f93 1907#if defined (USE_THREADS) || defined (DEVAL)
f8769b1d 1908dispatch:
e3173f93 1909#endif
9cb5124f 1910 SCM_TICK;
0f2d19dd
JB		 1911 switch (SCM_TYP7 (x))
1912 {
1913 case scm_tcs_symbols:
1914 /* Only happens when called at top level.
1915 */
1916 x = scm_cons (x, SCM_UNDEFINED);
1917 goto retval;
1918
1919 case (127 & SCM_IM_AND):
1920 x = SCM_CDR (x);
1921 t.arg1 = x;
1922 while (SCM_NNULLP (t.arg1 = SCM_CDR (t.arg1)))
1923 if (SCM_FALSEP (EVALCAR (x, env)))
1924 {
1925 RETURN (SCM_BOOL_F);
1926 }
1927 else
1928 x = t.arg1;
6dbd0af5 1929 PREP_APPLY (SCM_UNDEFINED, SCM_EOL);
0f2d19dd
JB		 1930 goto carloop;
1931
1932 case (127 & SCM_IM_BEGIN):
6dbd0af5
MD		 1933 cdrxnoap:
1934 PREP_APPLY (SCM_UNDEFINED, SCM_EOL);
0f2d19dd
JB		 1935 cdrxbegin:
1936 x = SCM_CDR (x);
1937
1938 begin:
1939 t.arg1 = x;
1940 while (SCM_NNULLP (t.arg1 = SCM_CDR (t.arg1)))
1941 {
26d5b9b4
MD		 1942 if (SCM_IMP (SCM_CAR (x)))
1943 {
1944 if (SCM_ISYMP (SCM_CAR (x)))
1945 {
1946 x = scm_m_expand_body (x, env);
1947 goto begin;
1948 }
1949 }
1950 else
1951 SCM_CEVAL (SCM_CAR (x), env);
0f2d19dd
JB		 1952 x = t.arg1;
1953 }
1954
1955 carloop: /* scm_eval car of last form in list */
1956 if (SCM_NCELLP (SCM_CAR (x)))
1957 {
1958 x = SCM_CAR (x);
6cb702da 1959 RETURN (SCM_IMP (x) ? SCM_EVALIM (x, env) : SCM_GLOC_VAL (x))
0f2d19dd
JB		 1960 }
1961
1962 if (SCM_SYMBOLP (SCM_CAR (x)))
1963 {
1964 retval:
26d5b9b4 1965 RETURN (*scm_lookupcar (x, env, 1))
0f2d19dd
JB		 1966 }
1967
1968 x = SCM_CAR (x);
1969 goto loop; /* tail recurse */
1970
1971
1972 case (127 & SCM_IM_CASE):
1973 x = SCM_CDR (x);
1974 t.arg1 = EVALCAR (x, env);
1975 while (SCM_NIMP (x = SCM_CDR (x)))
1976 {
1977 proc = SCM_CAR (x);
2f0d1375 1978 if (scm_sym_else == SCM_CAR (proc))
0f2d19dd
JB		 1979 {
1980 x = SCM_CDR (proc);
6dbd0af5 1981 PREP_APPLY (SCM_UNDEFINED, SCM_EOL);
0f2d19dd
JB		 1982 goto begin;
1983 }
1984 proc = SCM_CAR (proc);
1985 while (SCM_NIMP (proc))
1986 {
1987 if (CHECK_EQVISH (SCM_CAR (proc), t.arg1))
1988 {
1989 x = SCM_CDR (SCM_CAR (x));
6dbd0af5 1990 PREP_APPLY (SCM_UNDEFINED, SCM_EOL);
0f2d19dd
JB		 1991 goto begin;
1992 }
1993 proc = SCM_CDR (proc);
1994 }
1995 }
6dbd0af5 1996 RETURN (SCM_UNSPECIFIED)
0f2d19dd
JB		 1997
1998
1999 case (127 & SCM_IM_COND):
2000 while (SCM_NIMP (x = SCM_CDR (x)))
2001 {
2002 proc = SCM_CAR (x);
2003 t.arg1 = EVALCAR (proc, env);
2004 if (SCM_NFALSEP (t.arg1))
2005 {
2006 x = SCM_CDR (proc);
6dbd0af5 2007 if SCM_NULLP (x)
0f2d19dd 2008 {
6dbd0af5 2009 RETURN (t.arg1)
0f2d19dd 2010 }
2f0d1375 2011 if (scm_sym_arrow != SCM_CAR (x))
6dbd0af5
MD		 2012 {
2013 PREP_APPLY (SCM_UNDEFINED, SCM_EOL);
2014 goto begin;
2015 }
0f2d19dd
JB		 2016 proc = SCM_CDR (x);
2017 proc = EVALCAR (proc, env);
2018 SCM_ASRTGO (SCM_NIMP (proc), badfun);
6dbd0af5
MD		 2019 PREP_APPLY (proc, scm_cons (t.arg1, SCM_EOL));
2020 ENTER_APPLY;
0f2d19dd
JB		 2021 goto evap1;
2022 }
2023 }
6dbd0af5 2024 RETURN (SCM_UNSPECIFIED)
0f2d19dd
JB		 2025
2026
2027 case (127 & SCM_IM_DO):
2028 x = SCM_CDR (x);
2029 proc = SCM_CAR (SCM_CDR (x)); /* inits */
2030 t.arg1 = SCM_EOL; /* values */
2031 while (SCM_NIMP (proc))
2032 {
2033 t.arg1 = scm_cons (EVALCAR (proc, env), t.arg1);
2034 proc = SCM_CDR (proc);
2035 }
e2806c10 2036 env = EXTEND_ENV (SCM_CAR (x), t.arg1, env);
0f2d19dd
JB		 2037 x = SCM_CDR (SCM_CDR (x));
2038 while (proc = SCM_CAR (x), SCM_FALSEP (EVALCAR (proc, env)))
2039 {
f3d2630a 2040 for (proc = SCM_CADR (x); SCM_NIMP (proc); proc = SCM_CDR (proc))
0f2d19dd
JB		 2041 {
2042 t.arg1 = SCM_CAR (proc); /* body */
2043 SIDEVAL (t.arg1, env);
2044 }
f3d2630a
MD		 2045 for (t.arg1 = SCM_EOL, proc = SCM_CDDR (x);
2046 SCM_NIMP (proc);
2047 proc = SCM_CDR (proc))
0f2d19dd 2048 t.arg1 = scm_cons (EVALCAR (proc, env), t.arg1); /* steps */
e2806c10 2049 env = EXTEND_ENV (SCM_CAR (SCM_CAR (env)), t.arg1, SCM_CDR (env));
0f2d19dd
JB		 2050 }
2051 x = SCM_CDR (proc);
2052 if (SCM_NULLP (x))
6dbd0af5
MD		 2053 RETURN (SCM_UNSPECIFIED);
2054 PREP_APPLY (SCM_UNDEFINED, SCM_EOL);
0f2d19dd
JB		 2055 goto begin;
2056
2057
2058 case (127 & SCM_IM_IF):
2059 x = SCM_CDR (x);
2060 if (SCM_NFALSEP (EVALCAR (x, env)))
2061 x = SCM_CDR (x);
2062 else if (SCM_IMP (x = SCM_CDR (SCM_CDR (x))))
2063 {
2064 RETURN (SCM_UNSPECIFIED);
2065 }
6dbd0af5 2066 PREP_APPLY (SCM_UNDEFINED, SCM_EOL);
0f2d19dd
JB		 2067 goto carloop;
2068
2069
2070 case (127 & SCM_IM_LET):
2071 x = SCM_CDR (x);
2072 proc = SCM_CAR (SCM_CDR (x));
2073 t.arg1 = SCM_EOL;
2074 do
2075 {
2076 t.arg1 = scm_cons (EVALCAR (proc, env), t.arg1);
2077 }
2078 while (SCM_NIMP (proc = SCM_CDR (proc)));
e2806c10 2079 env = EXTEND_ENV (SCM_CAR (x), t.arg1, env);
0f2d19dd 2080 x = SCM_CDR (x);
6dbd0af5 2081 goto cdrxnoap;
0f2d19dd
JB		 2082
2083
2084 case (127 & SCM_IM_LETREC):
2085 x = SCM_CDR (x);
e2806c10 2086 env = EXTEND_ENV (SCM_CAR (x), scm_undefineds, env);
0f2d19dd
JB		 2087 x = SCM_CDR (x);
2088 proc = SCM_CAR (x);
2089 t.arg1 = SCM_EOL;
2090 do
2091 {
2092 t.arg1 = scm_cons (EVALCAR (proc, env), t.arg1);
2093 }
2094 while (SCM_NIMP (proc = SCM_CDR (proc)));
a23afe53 2095 SCM_SETCDR (SCM_CAR (env), t.arg1);
6dbd0af5 2096 goto cdrxnoap;
0f2d19dd
JB		 2097
2098
2099 case (127 & SCM_IM_LETSTAR):
2100 x = SCM_CDR (x);
2101 proc = SCM_CAR (x);
2102 if (SCM_IMP (proc))
2103 {
e2806c10 2104 env = EXTEND_ENV (SCM_EOL, SCM_EOL, env);
6dbd0af5 2105 goto cdrxnoap;
0f2d19dd
JB		 2106 }
2107 do
2108 {
2109 t.arg1 = SCM_CAR (proc);
2110 proc = SCM_CDR (proc);
e2806c10 2111 env = EXTEND_ENV (t.arg1, EVALCAR (proc, env), env);
0f2d19dd
JB		 2112 }
2113 while (SCM_NIMP (proc = SCM_CDR (proc)));
6dbd0af5 2114 goto cdrxnoap;
0f2d19dd
JB		 2115
2116 case (127 & SCM_IM_OR):
2117 x = SCM_CDR (x);
2118 t.arg1 = x;
2119 while (SCM_NNULLP (t.arg1 = SCM_CDR (t.arg1)))
2120 {
2121 x = EVALCAR (x, env);
2122 if (SCM_NFALSEP (x))
2123 {
2124 RETURN (x);
2125 }
2126 x = t.arg1;
2127 }
6dbd0af5 2128 PREP_APPLY (SCM_UNDEFINED, SCM_EOL);
0f2d19dd
JB		 2129 goto carloop;
2130
2131
2132 case (127 & SCM_IM_LAMBDA):
2133 RETURN (scm_closure (SCM_CDR (x), env));
2134
2135
2136 case (127 & SCM_IM_QUOTE):
2137 RETURN (SCM_CAR (SCM_CDR (x)));
2138
2139
89efbff4 2140 case (127 & SCM_IM_SET_X):
0f2d19dd
JB		 2141 x = SCM_CDR (x);
2142 proc = SCM_CAR (x);
6dbd0af5 2143 switch (7 & (int) proc)
0f2d19dd
JB		 2144 {
2145 case 0:
26d5b9b4 2146 t.lloc = scm_lookupcar (x, env, 1);
0f2d19dd
JB		 2147 break;
2148 case 1:
a23afe53 2149 t.lloc = SCM_GLOC_VAL_LOC (proc);
0f2d19dd
JB		 2150 break;
2151#ifdef MEMOIZE_LOCALS
2152 case 4:
2153 t.lloc = scm_ilookup (proc, env);
2154 break;
2155#endif
2156 }
2157 x = SCM_CDR (x);
2158 *t.lloc = EVALCAR (x, env);
0f2d19dd
JB		 2159#ifdef SICP
2160 RETURN (*t.lloc);
2161#else
2162 RETURN (SCM_UNSPECIFIED);
2163#endif
2164
2165
2166 case (127 & SCM_IM_DEFINE): /* only for internal defines */
26d5b9b4
MD		 2167 scm_misc_error (NULL, "Bad define placement", SCM_EOL);
2168
0f2d19dd
JB		 2169 /* new syntactic forms go here. */
2170 case (127 & SCM_MAKISYM (0)):
2171 proc = SCM_CAR (x);
2172 SCM_ASRTGO (SCM_ISYMP (proc), badfun);
2173 switch SCM_ISYMNUM (proc)
2174 {
2175#if 0
2176 case (SCM_ISYMNUM (IM_VREF)):
2177 {
2178 SCM var;
2179 var = SCM_CAR (SCM_CDR (x));
2180 RETURN (SCM_CDR(var));
2181 }
2182 case (SCM_ISYMNUM (IM_VSET)):
2183 SCM_CDR (SCM_CAR ( SCM_CDR (x))) = EVALCAR( SCM_CDR ( SCM_CDR (x)), env);
2184 SCM_CAR (SCM_CAR ( SCM_CDR (x))) = scm_tc16_variable;
6dbd0af5 2185 RETURN (SCM_UNSPECIFIED)
0f2d19dd
JB		 2186#endif
2187
2188 case (SCM_ISYMNUM (SCM_IM_APPLY)):
2189 proc = SCM_CDR (x);
2190 proc = EVALCAR (proc, env);
2191 SCM_ASRTGO (SCM_NIMP (proc), badfun);
2192 if (SCM_CLOSUREP (proc))
2193 {
1609038c 2194 SCM argl, tl;
6dbd0af5 2195 PREP_APPLY (proc, SCM_EOL);
0f2d19dd
JB		 2196 t.arg1 = SCM_CDR (SCM_CDR (x));
2197 t.arg1 = EVALCAR (t.arg1, env);
6dbd0af5
MD		 2198#ifdef DEVAL
2199 debug.info->a.args = t.arg1;
2200#endif
cf7c17e9 2201#ifndef SCM_RECKLESS
0f2d19dd
JB		 2202 if (scm_badargsp (SCM_CAR (SCM_CODE (proc)), t.arg1))
2203 goto wrongnumargs;
2204#endif
c79450dd 2205 ENTER_APPLY;
1609038c
MD		 2206 /* Copy argument list */
2207 if (SCM_IMP (t.arg1))
2208 argl = t.arg1;
2209 else
2210 {
2211 argl = tl = scm_cons (SCM_CAR (t.arg1), SCM_UNSPECIFIED);
2212 while (SCM_NIMP (t.arg1 = SCM_CDR (t.arg1))
2213 && SCM_CONSP (t.arg1))
2214 {
2215 SCM_SETCDR (tl, scm_cons (SCM_CAR (t.arg1),
2216 SCM_UNSPECIFIED));
2217 tl = SCM_CDR (tl);
2218 }
2219 SCM_SETCDR (tl, t.arg1);
2220 }
2221
2222 env = EXTEND_ENV (SCM_CAR (SCM_CODE (proc)), argl, SCM_ENV (proc));
0f2d19dd
JB		 2223 x = SCM_CODE (proc);
2224 goto cdrxbegin;
2225 }
81123e6d 2226 proc = scm_f_apply;
0f2d19dd
JB		 2227 goto evapply;
2228
2229 case (SCM_ISYMNUM (SCM_IM_CONT)):
2230 scm_make_cont (&t.arg1);
ca6ef71a 2231 if (setjmp (SCM_JMPBUF (t.arg1)))
0f2d19dd
JB		 2232 {
2233 SCM val;
2234 val = SCM_THROW_VALUE (t.arg1);
a570e93a 2235 RETURN (val)
0f2d19dd
JB		 2236 }
2237 proc = SCM_CDR (x);
2238 proc = evalcar (proc, env);
2239 SCM_ASRTGO (SCM_NIMP (proc), badfun);
6dbd0af5
MD		 2240 PREP_APPLY (proc, scm_cons (t.arg1, SCM_EOL));
2241 ENTER_APPLY;
0f2d19dd
JB		 2242 goto evap1;
2243
a570e93a
MD		 2244 case (SCM_ISYMNUM (SCM_IM_DELAY)):
2245 RETURN (scm_makprom (scm_closure (SCM_CDR (x), env)))
2246
89efbff4 2247 case (SCM_ISYMNUM (SCM_IM_DISPATCH)):
195847fa
MD		 2248 proc = SCM_CADR (x); /* unevaluated operands */
2249 PREP_APPLY (SCM_UNDEFINED, SCM_EOL);
2250 if (SCM_IMP (proc))
2251 arg2 = *scm_ilookup (proc, env);
2252 else if (SCM_NCONSP (proc))
2253 {
2254 if (SCM_NCELLP (proc))
2255 arg2 = SCM_GLOC_VAL (proc);
2256 else
2257 arg2 = *scm_lookupcar (SCM_CDR (x), env, 1);
2258 }
2259 else
2260 {
2261 arg2 = scm_cons (EVALCAR (proc, env), SCM_EOL);
2262 t.lloc = SCM_CDRLOC (arg2);
2263 while (SCM_NIMP (proc = SCM_CDR (proc)))
2264 {
2265 *t.lloc = scm_cons (EVALCAR (proc, env), SCM_EOL);
2266 t.lloc = SCM_CDRLOC (*t.lloc);
2267 }
2268 }
2269
2270 type_dispatch:
61364ba6
MD		 2271 /* The type dispatch code is duplicated here
2272 * (c.f. objects.c:scm_mcache_compute_cmethod) since that
2273 * cuts down execution time for type dispatch to 50%.
2274 */
2275 {
2276 int i, n, end, mask;
2277 SCM z = SCM_CDDR (x);
2278 n = SCM_INUM (SCM_CAR (z)); /* maximum number of specializers */
2279 proc = SCM_CADR (z);
2280
2281 if (SCM_NIMP (proc))
2282 {
2283 /* Prepare for linear search */
2284 mask = -1;
2285 i = 0;
2286 end = SCM_LENGTH (proc);
2287 }
2288 else
2289 {
2290 /* Compute a hash value */
2291 int hashset = SCM_INUM (proc);
2292 int j = n;
2293 mask = SCM_INUM (SCM_CAR (z = SCM_CDDR (z)));
2294 proc = SCM_CADR (z);
2295 i = 0;
2296 t.arg1 = arg2;
2297 if (SCM_NIMP (t.arg1))
2298 do
2299 {
2300 i += (SCM_STRUCT_DATA (scm_class_of (SCM_CAR (t.arg1)))
2301 [scm_si_hashsets + hashset]);
2302 t.arg1 = SCM_CDR (t.arg1);
2303 }
2304 while (--j && SCM_NIMP (t.arg1));
2305 i &= mask;
2306 end = i;
2307 }
2308
2309 /* Search for match */
2310 do
2311 {
2312 int j = n;
2313 z = SCM_VELTS (proc)[i];
2314 t.arg1 = arg2; /* list of arguments */
2315 if (SCM_NIMP (t.arg1))
2316 do
2317 {
2318 /* More arguments than specifiers => CLASS != ENV */
2319 if (scm_class_of (SCM_CAR (t.arg1)) != SCM_CAR (z))
2320 goto next_method;
2321 t.arg1 = SCM_CDR (t.arg1);
2322 z = SCM_CDR (z);
2323 }
2324 while (--j && SCM_NIMP (t.arg1));
2325 /* Fewer arguments than specifiers => CAR != ENV */
2326 if (!(SCM_IMP (SCM_CAR (z)) || SCM_CONSP (SCM_CAR (z))))
2327 goto next_method;
2328 apply_cmethod:
2329 env = EXTEND_ENV (SCM_CAR (SCM_CMETHOD_CODE (z)),
2330 arg2,
2331 SCM_CMETHOD_ENV (z));
2332 x = SCM_CMETHOD_CODE (z);
2333 goto cdrxbegin;
2334 next_method:
2335 i = (i + 1) & mask;
2336 } while (i != end);
2337
2338 z = scm_memoize_method (x, arg2);
2339 goto apply_cmethod;
2340 }
73b64342 2341
ca4be6ea
MD		 2342 case (SCM_ISYMNUM (SCM_IM_SLOT_REF)):
2343 x = SCM_CDR (x);
2344 t.arg1 = EVALCAR (x, env);
7d2b68a8 2345 RETURN (SCM_STRUCT_DATA (t.arg1)[SCM_INUM (SCM_CADR (x))])
ca4be6ea
MD		 2346
2347 case (SCM_ISYMNUM (SCM_IM_SLOT_SET_X)):
2348 x = SCM_CDR (x);
2349 t.arg1 = EVALCAR (x, env);
2350 x = SCM_CDR (x);
2351 proc = SCM_CDR (x);
1f325865
MD		 2352 SCM_STRUCT_DATA (t.arg1)[SCM_INUM (SCM_CAR (x))]
2353 = EVALCAR (proc, env);
5623a9b4 2354 RETURN (SCM_UNSPECIFIED)
ca4be6ea 2355
73b64342
MD		 2356 case (SCM_ISYMNUM (SCM_IM_NIL_COND)):
2357 proc = SCM_CDR (x);
2358 while (SCM_NIMP (x = SCM_CDR (proc)))
2359 {
2360 if (!(SCM_FALSEP (t.arg1 = EVALCAR (proc, env))
2361 || t.arg1 == scm_nil))
2362 {
2363 if (SCM_CAR (x) == SCM_UNSPECIFIED)
2364 RETURN (t.arg1);
2365 PREP_APPLY (SCM_UNDEFINED, SCM_EOL);
2366 goto carloop;
2367 }
2368 proc = SCM_CDR (x);
2369 }
2370 x = proc;
2371 PREP_APPLY (SCM_UNDEFINED, SCM_EOL);
2372 goto carloop;
2373
2374 case (SCM_ISYMNUM (SCM_IM_NIL_IFY)):
2375 x = SCM_CDR (x);
2376 RETURN ((SCM_FALSEP (proc = EVALCAR (x, env)) || SCM_NULLP (proc))
2377 ? scm_nil
2378 : proc)
2379
2380 case (SCM_ISYMNUM (SCM_IM_T_IFY)):
2381 x = SCM_CDR (x);
2382 RETURN (SCM_NFALSEP (EVALCAR (x, env)) ? scm_t : scm_nil)
2383
2384 case (SCM_ISYMNUM (SCM_IM_0_COND)):
2385 proc = SCM_CDR (x);
2386 while (SCM_NIMP (x = SCM_CDR (proc)))
2387 {
2388 if (!(SCM_FALSEP (t.arg1 = EVALCAR (proc, env))
2389 || t.arg1 == SCM_INUM0))
2390 {
2391 if (SCM_CAR (x) == SCM_UNSPECIFIED)
2392 RETURN (t.arg1);
2393 PREP_APPLY (SCM_UNDEFINED, SCM_EOL);
2394 goto carloop;
2395 }
2396 proc = SCM_CDR (x);
2397 }
2398 x = proc;
2399 PREP_APPLY (SCM_UNDEFINED, SCM_EOL);
2400 goto carloop;
2401
2402 case (SCM_ISYMNUM (SCM_IM_0_IFY)):
2403 x = SCM_CDR (x);
2404 RETURN (SCM_FALSEP (proc = EVALCAR (x, env))
2405 ? SCM_INUM0
2406 : proc)
2407
2408 case (SCM_ISYMNUM (SCM_IM_1_IFY)):
2409 x = SCM_CDR (x);
2410 RETURN (SCM_NFALSEP (EVALCAR (x, env))
2411 ? SCM_MAKINUM (1)
2412 : SCM_INUM0)
2413
2414 case (SCM_ISYMNUM (SCM_IM_BIND)):
2415 x = SCM_CDR (x);
2416
2417 t.arg1 = SCM_CAR (x);
2418 arg2 = SCM_CDAR (env);
2419 while (SCM_NIMP (arg2))
2420 {
2421 proc = SCM_GLOC_VAL (SCM_CAR (t.arg1));
2422 SCM_SETCDR (SCM_CAR (t.arg1) - 1L, SCM_CAR (arg2));
2423 SCM_SETCAR (arg2, proc);
2424 t.arg1 = SCM_CDR (t.arg1);
2425 arg2 = SCM_CDR (arg2);
2426 }
2427 t.arg1 = SCM_CAR (x);
2428 scm_dynwinds = scm_acons (t.arg1, SCM_CDAR (env), scm_dynwinds);
89efbff4 2429
73b64342
MD		 2430 arg2 = x = SCM_CDR (x);
2431 while (SCM_NNULLP (arg2 = SCM_CDR (arg2)))
2432 {
2433 SIDEVAL (SCM_CAR (x), env);
2434 x = arg2;
2435 }
2436 proc = EVALCAR (x, env);
2437
2438 scm_dynwinds = SCM_CDR (scm_dynwinds);
2439 arg2 = SCM_CDAR (env);
2440 while (SCM_NIMP (arg2))
2441 {
2442 SCM_SETCDR (SCM_CAR (t.arg1) - 1L, SCM_CAR (arg2));
2443 t.arg1 = SCM_CDR (t.arg1);
2444 arg2 = SCM_CDR (arg2);
2445 }
2446
2447 RETURN (proc)
2448
0f2d19dd
JB		 2449 default:
2450 goto badfun;
2451 }
2452
2453 default:
2454 proc = x;
2455 badfun:
f5bf2977 2456 /* scm_everr (x, env,...) */
523f5266 2457 scm_misc_error (NULL,
70d63753 2458 "Wrong type to apply: ~S",
523f5266 2459 scm_listify (proc, SCM_UNDEFINED));
0f2d19dd
JB		 2460 case scm_tc7_vector:
2461 case scm_tc7_wvect:
afe5177e 2462#ifdef HAVE_ARRAYS
0f2d19dd
JB		 2463 case scm_tc7_bvect:
2464 case scm_tc7_byvect:
2465 case scm_tc7_svect:
2466 case scm_tc7_ivect:
2467 case scm_tc7_uvect:
2468 case scm_tc7_fvect:
2469 case scm_tc7_dvect:
2470 case scm_tc7_cvect:
5c11cc9d 2471#ifdef HAVE_LONG_LONGS
0f2d19dd 2472 case scm_tc7_llvect:
afe5177e 2473#endif
0f2d19dd
JB		 2474#endif
2475 case scm_tc7_string:
0f2d19dd 2476 case scm_tc7_substring:
0f2d19dd
JB		 2477 case scm_tc7_smob:
2478 case scm_tcs_closures:
224822be
MD		 2479#ifdef CCLO
2480 case scm_tc7_cclo:
2481#endif
89efbff4 2482 case scm_tc7_pws:
0f2d19dd
JB		 2483 case scm_tcs_subrs:
2484 RETURN (x);
2485
2486#ifdef MEMOIZE_LOCALS
2487 case (127 & SCM_ILOC00):
2488 proc = *scm_ilookup (SCM_CAR (x), env);
2489 SCM_ASRTGO (SCM_NIMP (proc), badfun);
cf7c17e9
JB		 2490#ifndef SCM_RECKLESS
2491#ifdef SCM_CAUTIOUS
0f2d19dd
JB		 2492 goto checkargs;
2493#endif
2494#endif
2495 break;
2496#endif /* ifdef MEMOIZE_LOCALS */
2497
2498
2499 case scm_tcs_cons_gloc:
2500 proc = SCM_GLOC_VAL (SCM_CAR (x));
aa00bd1e
MD		 2501 if (proc == 0)
2502 /* This is a struct implanted in the code, not a gloc. */
2503 RETURN (x);
0f2d19dd 2504 SCM_ASRTGO (SCM_NIMP (proc), badfun);
cf7c17e9
JB		 2505#ifndef SCM_RECKLESS
2506#ifdef SCM_CAUTIOUS
0f2d19dd
JB		 2507 goto checkargs;
2508#endif
2509#endif
2510 break;
2511
2512
2513 case scm_tcs_cons_nimcar:
2514 if (SCM_SYMBOLP (SCM_CAR (x)))
2515 {
f8769b1d 2516#ifdef USE_THREADS
26d5b9b4 2517 t.lloc = scm_lookupcar1 (x, env, 1);
f8769b1d
MV		 2518 if (t.lloc == NULL)
2519 {
2520 /* we have lost the race, start again. */
2521 goto dispatch;
2522 }
2523 proc = *t.lloc;
2524#else
26d5b9b4 2525 proc = *scm_lookupcar (x, env, 1);
f8769b1d
MV		 2526#endif
2527
0f2d19dd
JB		 2528 if (SCM_IMP (proc))
2529 {
2530 unmemocar (x, env);
2531 goto badfun;
2532 }
2533 if (scm_tc16_macro == SCM_TYP16 (proc))
2534 {
2535 unmemocar (x, env);
2536
2537 handle_a_macro:
368bf056 2538#ifdef DEVAL
7c354052
MD		 2539 /* Set a flag during macro expansion so that macro
2540 application frames can be deleted from the backtrace. */
2541 SCM_SET_MACROEXP (debug);
368bf056 2542#endif
f8769b1d
MV		 2543 t.arg1 = SCM_APPLY (SCM_CDR (proc), x,
2544 scm_cons (env, scm_listofnull));
2545
7c354052
MD		 2546#ifdef DEVAL
2547 SCM_CLEAR_MACROEXP (debug);
2548#endif
0f2d19dd
JB		 2549 switch ((int) (SCM_CAR (proc) >> 16))
2550 {
2551 case 2:
2552 if (scm_ilength (t.arg1) <= 0)
2553 t.arg1 = scm_cons2 (SCM_IM_BEGIN, t.arg1, SCM_EOL);
6dbd0af5
MD		 2554#ifdef DEVAL
2555 if (!SCM_CLOSUREP (SCM_CDR (proc)))
2556 {
f8769b1d 2557
6dbd0af5
MD		 2558#if 0 /* Top-level defines doesn't very often occur in backtraces */
2559 if (scm_m_define == SCM_SUBRF (SCM_CDR (proc)) && SCM_TOP_LEVEL (env))
2560 /* Prevent memoizing result of define macro */
2561 {
2562 debug.info->e.exp = scm_cons (SCM_CAR (x), SCM_CDR (x));
2563 scm_set_source_properties_x (debug.info->e.exp,
2564 scm_source_properties (x));
2565 }
2566#endif
2567 SCM_DEFER_INTS;
a23afe53
MD		 2568 SCM_SETCAR (x, SCM_CAR (t.arg1));
2569 SCM_SETCDR (x, SCM_CDR (t.arg1));
6dbd0af5
MD		 2570 SCM_ALLOW_INTS;
2571 goto dispatch;
2572 }
2573 /* Prevent memoizing of debug info expression. */
6203706f
MD		 2574 debug.info->e.exp = scm_cons_source (debug.info->e.exp,
2575 SCM_CAR (x),
2576 SCM_CDR (x));
6dbd0af5 2577#endif
0f2d19dd 2578 SCM_DEFER_INTS;
a23afe53
MD		 2579 SCM_SETCAR (x, SCM_CAR (t.arg1));
2580 SCM_SETCDR (x, SCM_CDR (t.arg1));
0f2d19dd 2581 SCM_ALLOW_INTS;
6dbd0af5 2582 goto loopnoap;
0f2d19dd
JB		 2583 case 1:
2584 if (SCM_NIMP (x = t.arg1))
6dbd0af5 2585 goto loopnoap;
0f2d19dd
JB		 2586 case 0:
2587 RETURN (t.arg1);
2588 }
2589 }
2590 }
2591 else
2592 proc = SCM_CEVAL (SCM_CAR (x), env);
2593 SCM_ASRTGO (SCM_NIMP (proc), badfun);
cf7c17e9
JB		 2594#ifndef SCM_RECKLESS
2595#ifdef SCM_CAUTIOUS
0f2d19dd
JB		 2596 checkargs:
2597#endif
2598 if (SCM_CLOSUREP (proc))
2599 {
2600 arg2 = SCM_CAR (SCM_CODE (proc));
2601 t.arg1 = SCM_CDR (x);
2602 while (SCM_NIMP (arg2))
2603 {
2604 if (SCM_NCONSP (arg2))
2605 goto evapply;
2606 if (SCM_IMP (t.arg1))
2607 goto umwrongnumargs;
2608 arg2 = SCM_CDR (arg2);
2609 t.arg1 = SCM_CDR (t.arg1);
2610 }
2611 if (SCM_NNULLP (t.arg1))
2612 goto umwrongnumargs;
2613 }
2614 else if (scm_tc16_macro == SCM_TYP16 (proc))
2615 goto handle_a_macro;
2616#endif
2617 }
2618
2619
6dbd0af5
MD		 2620evapply:
2621 PREP_APPLY (proc, SCM_EOL);
2622 if (SCM_NULLP (SCM_CDR (x))) {
2623 ENTER_APPLY;
89efbff4 2624 evap0:
0f2d19dd
JB		 2625 switch (SCM_TYP7 (proc))
2626 { /* no arguments given */
2627 case scm_tc7_subr_0:
2628 RETURN (SCM_SUBRF (proc) ());
2629 case scm_tc7_subr_1o:
2630 RETURN (SCM_SUBRF (proc) (SCM_UNDEFINED));
2631 case scm_tc7_lsubr:
2632 RETURN (SCM_SUBRF (proc) (SCM_EOL));
2633 case scm_tc7_rpsubr:
2634 RETURN (SCM_BOOL_T);
2635 case scm_tc7_asubr:
2636 RETURN (SCM_SUBRF (proc) (SCM_UNDEFINED, SCM_UNDEFINED));
6dbd0af5 2637#ifdef CCLO
0f2d19dd
JB		 2638 case scm_tc7_cclo:
2639 t.arg1 = proc;
2640 proc = SCM_CCLO_SUBR (proc);
6dbd0af5
MD		 2641#ifdef DEVAL
2642 debug.info->a.proc = proc;
2643 debug.info->a.args = scm_cons (t.arg1, SCM_EOL);
2644#endif
0f2d19dd 2645 goto evap1;
6dbd0af5 2646#endif
89efbff4
MD		 2647 case scm_tc7_pws:
2648 proc = SCM_PROCEDURE (proc);
2649#ifdef DEVAL
2650 debug.info->a.proc = proc;
2651#endif
2652 goto evap0;
0f2d19dd
JB		 2653 case scm_tcs_closures:
2654 x = SCM_CODE (proc);
e2806c10 2655 env = EXTEND_ENV (SCM_CAR (x), SCM_EOL, SCM_ENV (proc));
0f2d19dd 2656 goto cdrxbegin;
da7f71d7 2657 case scm_tcs_cons_gloc:
195847fa
MD		 2658 if (SCM_OBJ_CLASS_FLAGS (proc) & SCM_CLASSF_PURE_GENERIC)
2659 {
2660 x = SCM_ENTITY_PROCEDURE (proc);
2661 arg2 = SCM_EOL;
2662 goto type_dispatch;
2663 }
2664 else if (!SCM_I_OPERATORP (proc))
9b07e212
MD		 2665 goto badfun;
2666 else
da7f71d7 2667 {
195847fa
MD		 2668 t.arg1 = proc;
2669 proc = (SCM_I_ENTITYP (proc)
2670 ? SCM_ENTITY_PROCEDURE (proc)
2671 : SCM_OPERATOR_PROCEDURE (proc));
da7f71d7 2672#ifdef DEVAL
195847fa
MD		 2673 debug.info->a.proc = proc;
2674 debug.info->a.args = scm_cons (t.arg1, SCM_EOL);
da7f71d7 2675#endif
195847fa
MD		 2676 if (SCM_NIMP (proc))
2677 goto evap1;
2678 else
2679 goto badfun;
da7f71d7 2680 }
0f2d19dd
JB		 2681 case scm_tc7_contin:
2682 case scm_tc7_subr_1:
2683 case scm_tc7_subr_2:
2684 case scm_tc7_subr_2o:
2685 case scm_tc7_cxr:
2686 case scm_tc7_subr_3:
2687 case scm_tc7_lsubr_2:
2688 umwrongnumargs:
2689 unmemocar (x, env);
2690 wrongnumargs:
f5bf2977
GH		 2691 /* scm_everr (x, env,...) */
2692 scm_wrong_num_args (proc);
0f2d19dd
JB		 2693 default:
2694 /* handle macros here */
2695 goto badfun;
2696 }
6dbd0af5 2697 }
0f2d19dd
JB		 2698
2699 /* must handle macros by here */
2700 x = SCM_CDR (x);
cf7c17e9 2701#ifdef SCM_CAUTIOUS
0f2d19dd
JB		 2702 if (SCM_IMP (x))
2703 goto wrongnumargs;
680ed4a8
MD		 2704 else if (SCM_CONSP (x))
2705 {
2706 if (SCM_IMP (SCM_CAR (x)))
6cb702da 2707 t.arg1 = SCM_EVALIM (SCM_CAR (x), env);
680ed4a8
MD		 2708 else
2709 t.arg1 = EVALCELLCAR (x, env);
2710 }
2711 else if (SCM_TYP3 (x) == 1)
2712 {
2713 if ((t.arg1 = SCM_GLOC_VAL (SCM_CAR (x))) == 0)
2714 t.arg1 = SCM_CAR (x); /* struct planted in code */
2715 }
2716 else
2717 goto wrongnumargs;
2718#else
0f2d19dd 2719 t.arg1 = EVALCAR (x, env);
680ed4a8 2720#endif
6dbd0af5
MD		 2721#ifdef DEVAL
2722 debug.info->a.args = scm_cons (t.arg1, SCM_EOL);
2723#endif
0f2d19dd
JB		 2724 x = SCM_CDR (x);
2725 if (SCM_NULLP (x))
2726 {
6dbd0af5 2727 ENTER_APPLY;
0f2d19dd
JB		 2728 evap1:
2729 switch (SCM_TYP7 (proc))
6dbd0af5 2730 { /* have one argument in t.arg1 */
0f2d19dd
JB		 2731 case scm_tc7_subr_2o:
2732 RETURN (SCM_SUBRF (proc) (t.arg1, SCM_UNDEFINED));
2733 case scm_tc7_subr_1:
2734 case scm_tc7_subr_1o:
2735 RETURN (SCM_SUBRF (proc) (t.arg1));
2736 case scm_tc7_cxr:
2737#ifdef SCM_FLOATS
2738 if (SCM_SUBRF (proc))
2739 {
2740 if (SCM_INUMP (t.arg1))
2741 {
2742 RETURN (scm_makdbl (SCM_DSUBRF (proc) ((double) SCM_INUM (t.arg1)),
2743 0.0));
2744 }
2745 SCM_ASRTGO (SCM_NIMP (t.arg1), floerr);
2746 if (SCM_REALP (t.arg1))
2747 {
2748 RETURN (scm_makdbl (SCM_DSUBRF (proc) (SCM_REALPART (t.arg1)), 0.0));
2749 }
2750#ifdef SCM_BIGDIG
2751 if (SCM_BIGP (t.arg1))
2752 {
2753 RETURN (scm_makdbl (SCM_DSUBRF (proc) (scm_big2dbl (t.arg1)), 0.0));
2754 }
2755#endif
2756 floerr:
9de33deb
MD		 2757 SCM_WTA_DISPATCH_1 (*SCM_SUBR_GENERIC (proc), t.arg1,
2758 SCM_ARG1, SCM_CHARS (SCM_SNAME (proc)));
0f2d19dd
JB		 2759 }
2760#endif
2761 proc = (SCM) SCM_SNAME (proc);
2762 {
2763 char *chrs = SCM_CHARS (proc) + SCM_LENGTH (proc) - 1;
2764 while ('c' != *--chrs)
2765 {
0c95b57d 2766 SCM_ASSERT (SCM_CONSP (t.arg1),
0f2d19dd
JB		 2767 t.arg1, SCM_ARG1, SCM_CHARS (proc));
2768 t.arg1 = ('a' == *chrs) ? SCM_CAR (t.arg1) : SCM_CDR (t.arg1);
2769 }
2770 RETURN (t.arg1);
2771 }
2772 case scm_tc7_rpsubr:
2773 RETURN (SCM_BOOL_T);
2774 case scm_tc7_asubr:
2775 RETURN (SCM_SUBRF (proc) (t.arg1, SCM_UNDEFINED));
2776 case scm_tc7_lsubr:
2777#ifdef DEVAL
6dbd0af5 2778 RETURN (SCM_SUBRF (proc) (debug.info->a.args))
0f2d19dd
JB		 2779#else
2780 RETURN (SCM_SUBRF (proc) (scm_cons (t.arg1, SCM_EOL)));
2781#endif
6dbd0af5 2782#ifdef CCLO
0f2d19dd
JB		 2783 case scm_tc7_cclo:
2784 arg2 = t.arg1;
2785 t.arg1 = proc;
2786 proc = SCM_CCLO_SUBR (proc);
6dbd0af5
MD		 2787#ifdef DEVAL
2788 debug.info->a.args = scm_cons (t.arg1, debug.info->a.args);
2789 debug.info->a.proc = proc;
2790#endif
0f2d19dd 2791 goto evap2;
6dbd0af5 2792#endif
89efbff4
MD		 2793 case scm_tc7_pws:
2794 proc = SCM_PROCEDURE (proc);
2795#ifdef DEVAL
2796 debug.info->a.proc = proc;
2797#endif
2798 goto evap1;
0f2d19dd 2799 case scm_tcs_closures:
195847fa 2800 /* clos1: */
0f2d19dd
JB		 2801 x = SCM_CODE (proc);
2802#ifdef DEVAL
e2806c10 2803 env = EXTEND_ENV (SCM_CAR (x), debug.info->a.args, SCM_ENV (proc));
0f2d19dd 2804#else
e2806c10 2805 env = EXTEND_ENV (SCM_CAR (x), scm_cons (t.arg1, SCM_EOL), SCM_ENV (proc));
0f2d19dd
JB		 2806#endif
2807 goto cdrxbegin;
65e41721
MD		 2808 case scm_tc7_contin:
2809 scm_call_continuation (proc, t.arg1);
0c32d76c 2810 case scm_tcs_cons_gloc:
f3d2630a
MD		 2811 if (SCM_OBJ_CLASS_FLAGS (proc) & SCM_CLASSF_PURE_GENERIC)
2812 {
195847fa 2813 x = SCM_ENTITY_PROCEDURE (proc);
f3d2630a
MD		 2814#ifdef DEVAL
2815 arg2 = debug.info->a.args;
2816#else
2817 arg2 = scm_cons (t.arg1, SCM_EOL);
2818#endif
f3d2630a
MD		 2819 goto type_dispatch;
2820 }
2821 else if (!SCM_I_OPERATORP (proc))
9b07e212
MD		 2822 goto badfun;
2823 else
0c32d76c 2824 {
195847fa
MD		 2825 arg2 = t.arg1;
2826 t.arg1 = proc;
2827 proc = (SCM_I_ENTITYP (proc)
2828 ? SCM_ENTITY_PROCEDURE (proc)
2829 : SCM_OPERATOR_PROCEDURE (proc));
0c32d76c 2830#ifdef DEVAL
195847fa
MD		 2831 debug.info->a.args = scm_cons (t.arg1, debug.info->a.args);
2832 debug.info->a.proc = proc;
0c32d76c 2833#endif
195847fa
MD		 2834 if (SCM_NIMP (proc))
2835 goto evap2;
2836 else
2837 goto badfun;
0c32d76c 2838 }
0f2d19dd
JB		 2839 case scm_tc7_subr_2:
2840 case scm_tc7_subr_0:
2841 case scm_tc7_subr_3:
2842 case scm_tc7_lsubr_2:
2843 goto wrongnumargs;
2844 default:
2845 goto badfun;
2846 }
2847 }
cf7c17e9 2848#ifdef SCM_CAUTIOUS
0f2d19dd
JB		 2849 if (SCM_IMP (x))
2850 goto wrongnumargs;
680ed4a8
MD		 2851 else if (SCM_CONSP (x))
2852 {
2853 if (SCM_IMP (SCM_CAR (x)))
6cb702da 2854 arg2 = SCM_EVALIM (SCM_CAR (x), env);
680ed4a8
MD		 2855 else
2856 arg2 = EVALCELLCAR (x, env);
2857 }
2858 else if (SCM_TYP3 (x) == 1)
2859 {
2860 if ((arg2 = SCM_GLOC_VAL (SCM_CAR (x))) == 0)
2861 arg2 = SCM_CAR (x); /* struct planted in code */
2862 }
2863 else
2864 goto wrongnumargs;
2865#else
2866 arg2 = EVALCAR (x, env);
0f2d19dd
JB		 2867#endif
2868 { /* have two or more arguments */
6dbd0af5
MD		 2869#ifdef DEVAL
2870 debug.info->a.args = scm_cons2 (t.arg1, arg2, SCM_EOL);
2871#endif
0f2d19dd
JB		 2872 x = SCM_CDR (x);
2873 if (SCM_NULLP (x)) {
6dbd0af5 2874 ENTER_APPLY;
0f2d19dd
JB		 2875#ifdef CCLO
2876 evap2:
2877#endif
6dbd0af5
MD		 2878 switch (SCM_TYP7 (proc))
2879 { /* have two arguments */
2880 case scm_tc7_subr_2:
2881 case scm_tc7_subr_2o:
2882 RETURN (SCM_SUBRF (proc) (t.arg1, arg2));
2883 case scm_tc7_lsubr:
0f2d19dd 2884#ifdef DEVAL
6dbd0af5
MD		 2885 RETURN (SCM_SUBRF (proc) (debug.info->a.args))
2886#else
2887 RETURN (SCM_SUBRF (proc) (scm_cons2 (t.arg1, arg2, SCM_EOL)));
0f2d19dd 2888#endif
6dbd0af5
MD		 2889 case scm_tc7_lsubr_2:
2890 RETURN (SCM_SUBRF (proc) (t.arg1, arg2, SCM_EOL));
2891 case scm_tc7_rpsubr:
2892 case scm_tc7_asubr:
2893 RETURN (SCM_SUBRF (proc) (t.arg1, arg2));
2894#ifdef CCLO
2895 cclon:
2896 case scm_tc7_cclo:
0f2d19dd 2897#ifdef DEVAL
195847fa
MD		 2898 RETURN (SCM_APPLY (SCM_CCLO_SUBR (proc),
2899 scm_cons (proc, debug.info->a.args),
2900 SCM_EOL));
0f2d19dd 2901#else
195847fa
MD		 2902 RETURN (SCM_APPLY (SCM_CCLO_SUBR (proc),
2903 scm_cons2 (proc, t.arg1,
2904 scm_cons (arg2,
2905 scm_eval_args (x,
2906 env,
2907 proc))),
2908 SCM_EOL));
0f2d19dd 2909#endif
6dbd0af5
MD		 2910 /* case scm_tc7_cclo:
2911 x = scm_cons(arg2, scm_eval_args(x, env));
2912 arg2 = t.arg1;
2913 t.arg1 = proc;
2914 proc = SCM_CCLO_SUBR(proc);
2915 goto evap3; */
2916#endif
89efbff4
MD		 2917 case scm_tc7_pws:
2918 proc = SCM_PROCEDURE (proc);
2919#ifdef DEVAL
2920 debug.info->a.proc = proc;
2921#endif
2922 goto evap2;
0c32d76c 2923 case scm_tcs_cons_gloc:
f3d2630a
MD		 2924 if (SCM_OBJ_CLASS_FLAGS (proc) & SCM_CLASSF_PURE_GENERIC)
2925 {
195847fa 2926 x = SCM_ENTITY_PROCEDURE (proc);
f3d2630a
MD		 2927#ifdef DEVAL
2928 arg2 = debug.info->a.args;
2929#else
2930 arg2 = scm_cons2 (t.arg1, arg2, SCM_EOL);
2931#endif
f3d2630a
MD		 2932 goto type_dispatch;
2933 }
2934 else if (!SCM_I_OPERATORP (proc))
9b07e212
MD		 2935 goto badfun;
2936 else
0c32d76c 2937 {
195847fa 2938 operatorn:
0c32d76c 2939#ifdef DEVAL
195847fa
MD		 2940 RETURN (SCM_APPLY (SCM_I_ENTITYP (proc)
2941 ? SCM_ENTITY_PROCEDURE (proc)
2942 : SCM_OPERATOR_PROCEDURE (proc),
2943 scm_cons (proc, debug.info->a.args),
2944 SCM_EOL));
2945#else
2946 RETURN (SCM_APPLY (SCM_I_ENTITYP (proc)
2947 ? SCM_ENTITY_PROCEDURE (proc)
2948 : SCM_OPERATOR_PROCEDURE (proc),
2949 scm_cons2 (proc, t.arg1,
2950 scm_cons (arg2,
2951 scm_eval_args (x,
2952 env,
2953 proc))),
2954 SCM_EOL));
2955#endif
0c32d76c 2956 }
6dbd0af5
MD		 2957 case scm_tc7_subr_0:
2958 case scm_tc7_cxr:
2959 case scm_tc7_subr_1o:
2960 case scm_tc7_subr_1:
2961 case scm_tc7_subr_3:
2962 case scm_tc7_contin:
2963 goto wrongnumargs;
2964 default:
2965 goto badfun;
2966 case scm_tcs_closures:
195847fa 2967 /* clos2: */
0f2d19dd 2968#ifdef DEVAL
da7f71d7
MD		 2969 env = EXTEND_ENV (SCM_CAR (SCM_CODE (proc)),
2970 debug.info->a.args,
2971 SCM_ENV (proc));
0f2d19dd 2972#else
da7f71d7
MD		 2973 env = EXTEND_ENV (SCM_CAR (SCM_CODE (proc)),
2974 scm_cons2 (t.arg1, arg2, SCM_EOL), SCM_ENV (proc));
0f2d19dd 2975#endif
6dbd0af5
MD		 2976 x = SCM_CODE (proc);
2977 goto cdrxbegin;
2978 }
0f2d19dd 2979 }
cf7c17e9 2980#ifdef SCM_CAUTIOUS
680ed4a8
MD		 2981 if (SCM_IMP (x) || SCM_NECONSP (x))
2982 goto wrongnumargs;
2983#endif
0f2d19dd 2984#ifdef DEVAL
6dbd0af5 2985 debug.info->a.args = scm_cons2 (t.arg1, arg2,
680ed4a8
MD		 2986 scm_deval_args (x, env, proc,
2987 SCM_CDRLOC (SCM_CDR (debug.info->a.args))));
0f2d19dd 2988#endif
6dbd0af5 2989 ENTER_APPLY;
89efbff4 2990 evap3:
6dbd0af5
MD		 2991 switch (SCM_TYP7 (proc))
2992 { /* have 3 or more arguments */
0f2d19dd 2993#ifdef DEVAL
6dbd0af5
MD		 2994 case scm_tc7_subr_3:
2995 SCM_ASRTGO (SCM_NULLP (SCM_CDR (x)), wrongnumargs);
da7f71d7
MD		 2996 RETURN (SCM_SUBRF (proc) (t.arg1, arg2,
2997 SCM_CADDR (debug.info->a.args)));
6dbd0af5 2998 case scm_tc7_asubr:
399dedcc
MD		 2999#ifdef BUILTIN_RPASUBR
3000 t.arg1 = SCM_SUBRF(proc)(t.arg1, arg2);
3001 arg2 = SCM_CDR (SCM_CDR (debug.info->a.args));
da7f71d7
MD		 3002 do
3003 {
3004 t.arg1 = SCM_SUBRF(proc)(t.arg1, SCM_CAR (arg2));
3005 arg2 = SCM_CDR (arg2);
3006 }
3007 while (SCM_NIMP (arg2));
399dedcc
MD		 3008 RETURN (t.arg1)
3009#endif /* BUILTIN_RPASUBR */
6dbd0af5 3010 case scm_tc7_rpsubr:
71d3aa6d
MD		 3011#ifdef BUILTIN_RPASUBR
3012 if (SCM_FALSEP (SCM_SUBRF (proc) (t.arg1, arg2)))
3013 RETURN (SCM_BOOL_F)
3014 t.arg1 = SCM_CDR (SCM_CDR (debug.info->a.args));
da7f71d7
MD		 3015 do
3016 {
3017 if (SCM_FALSEP (SCM_SUBRF (proc) (arg2, SCM_CAR (t.arg1))))
3018 RETURN (SCM_BOOL_F)
3019 arg2 = SCM_CAR (t.arg1);
3020 t.arg1 = SCM_CDR (t.arg1);
3021 }
3022 while (SCM_NIMP (t.arg1));
71d3aa6d
MD		 3023 RETURN (SCM_BOOL_T)
3024#else /* BUILTIN_RPASUBR */
da7f71d7
MD		 3025 RETURN (SCM_APPLY (proc, t.arg1,
3026 scm_acons (arg2,
3027 SCM_CDR (SCM_CDR (debug.info->a.args)),
3028 SCM_EOL)))
71d3aa6d 3029#endif /* BUILTIN_RPASUBR */
399dedcc 3030 case scm_tc7_lsubr_2:
da7f71d7
MD		 3031 RETURN (SCM_SUBRF (proc) (t.arg1, arg2,
3032 SCM_CDR (SCM_CDR (debug.info->a.args))))
399dedcc
MD		 3033 case scm_tc7_lsubr:
3034 RETURN (SCM_SUBRF (proc) (debug.info->a.args))
0f2d19dd 3035#ifdef CCLO
6dbd0af5
MD		 3036 case scm_tc7_cclo:
3037 goto cclon;
0f2d19dd 3038#endif
89efbff4
MD		 3039 case scm_tc7_pws:
3040 proc = SCM_PROCEDURE (proc);
3041 debug.info->a.proc = proc;
3042 goto evap3;
6dbd0af5 3043 case scm_tcs_closures:
b7ff98dd 3044 SCM_SET_ARGSREADY (debug);
e2806c10 3045 env = EXTEND_ENV (SCM_CAR (SCM_CODE (proc)),
6dbd0af5
MD		 3046 debug.info->a.args,
3047 SCM_ENV (proc));
3048 x = SCM_CODE (proc);
3049 goto cdrxbegin;
3050#else /* DEVAL */
3051 case scm_tc7_subr_3:
3052 SCM_ASRTGO (SCM_NULLP (SCM_CDR (x)), wrongnumargs);
3053 RETURN (SCM_SUBRF (proc) (t.arg1, arg2, EVALCAR (x, env)));
3054 case scm_tc7_asubr:
399dedcc 3055#ifdef BUILTIN_RPASUBR
da7f71d7
MD		 3056 t.arg1 = SCM_SUBRF (proc) (t.arg1, arg2);
3057 do
3058 {
3059 t.arg1 = SCM_SUBRF(proc)(t.arg1, EVALCAR(x, env));
3060 x = SCM_CDR(x);
3061 }
3062 while (SCM_NIMP (x));
399dedcc
MD		 3063 RETURN (t.arg1)
3064#endif /* BUILTIN_RPASUBR */
6dbd0af5 3065 case scm_tc7_rpsubr:
71d3aa6d
MD		 3066#ifdef BUILTIN_RPASUBR
3067 if (SCM_FALSEP (SCM_SUBRF (proc) (t.arg1, arg2)))
3068 RETURN (SCM_BOOL_F)
da7f71d7
MD		 3069 do
3070 {
3071 t.arg1 = EVALCAR (x, env);
3072 if (SCM_FALSEP (SCM_SUBRF (proc) (arg2, t.arg1)))
3073 RETURN (SCM_BOOL_F)
3074 arg2 = t.arg1;
3075 x = SCM_CDR (x);
3076 }
3077 while (SCM_NIMP (x));
71d3aa6d
MD		 3078 RETURN (SCM_BOOL_T)
3079#else /* BUILTIN_RPASUBR */
da7f71d7 3080 RETURN (SCM_APPLY (proc, t.arg1,
680ed4a8
MD		 3081 scm_acons (arg2,
3082 scm_eval_args (x, env, proc),
3083 SCM_EOL)));
71d3aa6d 3084#endif /* BUILTIN_RPASUBR */
6dbd0af5 3085 case scm_tc7_lsubr_2:
680ed4a8 3086 RETURN (SCM_SUBRF (proc) (t.arg1, arg2, scm_eval_args (x, env, proc)));
6dbd0af5 3087 case scm_tc7_lsubr:
680ed4a8
MD		 3088 RETURN (SCM_SUBRF (proc) (scm_cons2 (t.arg1,
3089 arg2,
3090 scm_eval_args (x, env, proc))));
0f2d19dd 3091#ifdef CCLO
6dbd0af5
MD		 3092 case scm_tc7_cclo:
3093 goto cclon;
0f2d19dd 3094#endif
89efbff4
MD		 3095 case scm_tc7_pws:
3096 proc = SCM_PROCEDURE (proc);
3097 goto evap3;
6dbd0af5
MD		 3098 case scm_tcs_closures:
3099#ifdef DEVAL
b7ff98dd 3100 SCM_SET_ARGSREADY (debug);
6dbd0af5 3101#endif
e2806c10 3102 env = EXTEND_ENV (SCM_CAR (SCM_CODE (proc)),
680ed4a8
MD		 3103 scm_cons2 (t.arg1,
3104 arg2,
3105 scm_eval_args (x, env, proc)),
6dbd0af5
MD		 3106 SCM_ENV (proc));
3107 x = SCM_CODE (proc);
3108 goto cdrxbegin;
0f2d19dd 3109#endif /* DEVAL */
0c32d76c 3110 case scm_tcs_cons_gloc:
f3d2630a
MD		 3111 if (SCM_OBJ_CLASS_FLAGS (proc) & SCM_CLASSF_PURE_GENERIC)
3112 {
3113#ifdef DEVAL
3114 arg2 = debug.info->a.args;
3115#else
3116 arg2 = scm_cons2 (t.arg1, arg2, scm_eval_args (x, env, proc));
3117#endif
195847fa 3118 x = SCM_ENTITY_PROCEDURE (proc);
f3d2630a
MD		 3119 goto type_dispatch;
3120 }
3121 else if (!SCM_I_OPERATORP (proc))
9b07e212
MD		 3122 goto badfun;
3123 else
195847fa 3124 goto operatorn;
6dbd0af5
MD		 3125 case scm_tc7_subr_2:
3126 case scm_tc7_subr_1o:
3127 case scm_tc7_subr_2o:
3128 case scm_tc7_subr_0:
3129 case scm_tc7_cxr:
3130 case scm_tc7_subr_1:
3131 case scm_tc7_contin:
3132 goto wrongnumargs;
3133 default:
3134 goto badfun;
3135 }
0f2d19dd
JB		 3136 }
3137#ifdef DEVAL
6dbd0af5 3138exit:
b6d75948 3139 if (CHECK_EXIT && SCM_TRAPS_P)
b7ff98dd 3140 if (SCM_EXIT_FRAME_P || (SCM_TRACE_P && SCM_TRACED_FRAME_P (debug)))
6dbd0af5 3141 {
b7ff98dd
MD		 3142 SCM_CLEAR_TRACED_FRAME (debug);
3143 if (SCM_CHEAPTRAPS_P)
c0ab1b8d 3144 t.arg1 = scm_make_debugobj (&debug);
6dbd0af5
MD		 3145 else
3146 {
3147 scm_make_cont (&t.arg1);
ca6ef71a 3148 if (setjmp (SCM_JMPBUF (t.arg1)))
6dbd0af5
MD		 3149 {
3150 proc = SCM_THROW_VALUE (t.arg1);
3151 goto ret;
3152 }
3153 }
2f0d1375 3154 scm_ithrow (scm_sym_exit_frame, scm_cons2 (t.arg1, proc, SCM_EOL), 0);
6dbd0af5
MD		 3155 }
3156ret:
1646d37b 3157 scm_last_debug_frame = debug.prev;
0f2d19dd
JB		 3158 return proc;
3159#endif
3160}
3161
6dbd0af5
MD		 3162
3163/* SECTION: This code is compiled once.
3164 */
3165
0f2d19dd
JB		 3166#ifndef DEVAL
3167
82a2622a 3168/* This code processes the arguments to apply:
b145c172
JB		 3169
3170 (apply PROC ARG1 ... ARGS)
3171
82a2622a
JB		 3172 Given a list (ARG1 ... ARGS), this function conses the ARG1
3173 ... arguments onto the front of ARGS, and returns the resulting
3174 list. Note that ARGS is a list; thus, the argument to this
3175 function is a list whose last element is a list.
3176
3177 Apply calls this function, and applies PROC to the elements of the
b145c172
JB		 3178 result. apply:nconc2last takes care of building the list of
3179 arguments, given (ARG1 ... ARGS).
3180
82a2622a
JB		 3181 Rather than do new consing, apply:nconc2last destroys its argument.
3182 On that topic, this code came into my care with the following
3183 beautifully cryptic comment on that topic: "This will only screw
3184 you if you do (scm_apply scm_apply '( ... ))" If you know what
3185 they're referring to, send me a patch to this comment. */
b145c172 3186
3b3b36dd 3187SCM_DEFINE (scm_nconc2last, "apply:nconc2last", 1, 0, 0,
1bbd0b84
GB		 3188 (SCM lst),
3189"")
3190#define FUNC_NAME s_scm_nconc2last
0f2d19dd
JB		 3191{
3192 SCM *lloc;
c1bfcf60 3193 SCM_VALIDATE_NONEMPTYLIST (1,lst);
0f2d19dd
JB		 3194 lloc = &lst;
3195 while (SCM_NNULLP (SCM_CDR (*lloc)))
a23afe53 3196 lloc = SCM_CDRLOC (*lloc);
1bbd0b84 3197 SCM_ASSERT (scm_ilength (SCM_CAR (*lloc)) >= 0, lst, SCM_ARG1, FUNC_NAME);
0f2d19dd
JB		 3198 *lloc = SCM_CAR (*lloc);
3199 return lst;
3200}
1bbd0b84 3201#undef FUNC_NAME
0f2d19dd
JB		 3202
3203#endif /* !DEVAL */
3204
6dbd0af5
MD		 3205
3206/* SECTION: When DEVAL is defined this code yields scm_dapply.
3207 * It is compiled twice.
3208 */
3209
0f2d19dd 3210#if 0
1cc91f1b 3211
0f2d19dd 3212SCM
6e8d25a6 3213scm_apply (SCM proc, SCM arg1, SCM args)
0f2d19dd
JB		 3214{}
3215#endif
3216
3217#if 0
1cc91f1b 3218
0f2d19dd 3219SCM
6e8d25a6
GB		 3220scm_dapply (SCM proc, SCM arg1, SCM args)
3221{ /* empty */ }
0f2d19dd
JB		 3222#endif
3223
1cc91f1b 3224
82a2622a
JB		 3225/* Apply a function to a list of arguments.
3226
3227 This function is exported to the Scheme level as taking two
3228 required arguments and a tail argument, as if it were:
3229 (lambda (proc arg1 . args) ...)
3230 Thus, if you just have a list of arguments to pass to a procedure,
3231 pass the list as ARG1, and '() for ARGS. If you have some fixed
3232 args, pass the first as ARG1, then cons any remaining fixed args
3233 onto the front of your argument list, and pass that as ARGS. */
3234
0f2d19dd 3235SCM
1bbd0b84 3236SCM_APPLY (SCM proc, SCM arg1, SCM args)
0f2d19dd
JB		 3237{
3238#ifdef DEBUG_EXTENSIONS
3239#ifdef DEVAL
6dbd0af5 3240 scm_debug_frame debug;
c0ab1b8d 3241 scm_debug_info debug_vect_body;
1646d37b 3242 debug.prev = scm_last_debug_frame;
b7ff98dd 3243 debug.status = SCM_APPLYFRAME;
c0ab1b8d 3244 debug.vect = &debug_vect_body;
6dbd0af5
MD		 3245 debug.vect[0].a.proc = proc;
3246 debug.vect[0].a.args = SCM_EOL;
1646d37b 3247 scm_last_debug_frame = &debug;
0f2d19dd 3248#else
b7ff98dd 3249 if (SCM_DEBUGGINGP)
0f2d19dd
JB		 3250 return scm_dapply (proc, arg1, args);
3251#endif
3252#endif
3253
3254 SCM_ASRTGO (SCM_NIMP (proc), badproc);
82a2622a
JB		 3255
3256 /* If ARGS is the empty list, then we're calling apply with only two
3257 arguments --- ARG1 is the list of arguments for PROC. Whatever
3258 the case, futz with things so that ARG1 is the first argument to
3259 give to PROC (or SCM_UNDEFINED if no args), and ARGS contains the
30000774
JB		 3260 rest.
3261
3262 Setting the debug apply frame args this way is pretty messy.
3263 Perhaps we should store arg1 and args directly in the frame as
3264 received, and let scm_frame_arguments unpack them, because that's
3265 a relatively rare operation. This works for now; if the Guile
3266 developer archives are still around, see Mikael's post of
3267 11-Apr-97. */
0f2d19dd
JB		 3268 if (SCM_NULLP (args))
3269 {
3270 if (SCM_NULLP (arg1))
30000774
JB		 3271 {
3272 arg1 = SCM_UNDEFINED;
3273#ifdef DEVAL
3274 debug.vect[0].a.args = SCM_EOL;
3275#endif
3276 }
0f2d19dd
JB		 3277 else
3278 {
30000774
JB		 3279#ifdef DEVAL
3280 debug.vect[0].a.args = arg1;
3281#endif
0f2d19dd
JB		 3282 args = SCM_CDR (arg1);
3283 arg1 = SCM_CAR (arg1);
3284 }
3285 }
3286 else
3287 {
0c95b57d 3288 /* SCM_ASRTGO(SCM_CONSP(args), wrongnumargs); */
0f2d19dd 3289 args = scm_nconc2last (args);
30000774
JB		 3290#ifdef DEVAL
3291 debug.vect[0].a.args = scm_cons (arg1, args);
3292#endif
0f2d19dd 3293 }
0f2d19dd 3294#ifdef DEVAL
b6d75948 3295 if (SCM_ENTER_FRAME_P && SCM_TRAPS_P)
6dbd0af5
MD		 3296 {
3297 SCM tmp;
b7ff98dd 3298 if (SCM_CHEAPTRAPS_P)
c0ab1b8d 3299 tmp = scm_make_debugobj (&debug);
6dbd0af5
MD		 3300 else
3301 {
3302 scm_make_cont (&tmp);
ca6ef71a 3303 if (setjmp (SCM_JMPBUF (tmp)))
6dbd0af5
MD		 3304 goto entap;
3305 }
2f0d1375 3306 scm_ithrow (scm_sym_enter_frame, scm_cons (tmp, SCM_EOL), 0);
6dbd0af5
MD		 3307 }
3308entap:
3309 ENTER_APPLY;
3310#endif
3311#ifdef CCLO
3312tail:
0f2d19dd
JB		 3313#endif
3314 switch (SCM_TYP7 (proc))
3315 {
3316 case scm_tc7_subr_2o:
3317 args = SCM_NULLP (args) ? SCM_UNDEFINED : SCM_CAR (args);
3318 RETURN (SCM_SUBRF (proc) (arg1, args))
3319 case scm_tc7_subr_2:
269861c7
MD		 3320 SCM_ASRTGO (SCM_NNULLP (args) && SCM_NULLP (SCM_CDR (args)),
3321 wrongnumargs);
0f2d19dd
JB		 3322 args = SCM_CAR (args);
3323 RETURN (SCM_SUBRF (proc) (arg1, args))
3324 case scm_tc7_subr_0:
3325 SCM_ASRTGO (SCM_UNBNDP (arg1), wrongnumargs);
3326 RETURN (SCM_SUBRF (proc) ())
3327 case scm_tc7_subr_1:
3328 case scm_tc7_subr_1o:
3329 SCM_ASRTGO (SCM_NULLP (args), wrongnumargs);
3330 RETURN (SCM_SUBRF (proc) (arg1))
3331 case scm_tc7_cxr:
3332 SCM_ASRTGO (SCM_NULLP (args), wrongnumargs);
3333#ifdef SCM_FLOATS
3334 if (SCM_SUBRF (proc))
3335 {
6dbd0af5
MD		 3336 if (SCM_INUMP (arg1))
3337 {
3338 RETURN (scm_makdbl (SCM_DSUBRF (proc) ((double) SCM_INUM (arg1)), 0.0));
3339 }
0f2d19dd 3340 SCM_ASRTGO (SCM_NIMP (arg1), floerr);
6dbd0af5
MD		 3341 if (SCM_REALP (arg1))
3342 {
3343 RETURN (scm_makdbl (SCM_DSUBRF (proc) (SCM_REALPART (arg1)), 0.0));
3344 }
0f2d19dd 3345#ifdef SCM_BIGDIG
26d5b9b4 3346 if (SCM_BIGP (arg1))
0f2d19dd
JB		 3347 RETURN (scm_makdbl (SCM_DSUBRF (proc) (scm_big2dbl (arg1)), 0.0))
3348#endif
3349 floerr:
9de33deb
MD		 3350 SCM_WTA_DISPATCH_1 (*SCM_SUBR_GENERIC (proc), arg1,
3351 SCM_ARG1, SCM_CHARS (SCM_SNAME (proc)));
0f2d19dd
JB		 3352 }
3353#endif
3354 proc = (SCM) SCM_SNAME (proc);
3355 {
3356 char *chrs = SCM_CHARS (proc) + SCM_LENGTH (proc) - 1;
3357 while ('c' != *--chrs)
3358 {
0c95b57d 3359 SCM_ASSERT (SCM_CONSP (arg1),
0f2d19dd
JB		 3360 arg1, SCM_ARG1, SCM_CHARS (proc));
3361 arg1 = ('a' == *chrs) ? SCM_CAR (arg1) : SCM_CDR (arg1);
3362 }
3363 RETURN (arg1)
3364 }
3365 case scm_tc7_subr_3:
3366 RETURN (SCM_SUBRF (proc) (arg1, SCM_CAR (args), SCM_CAR (SCM_CDR (args))))
3367 case scm_tc7_lsubr:
3368#ifdef DEVAL
6dbd0af5 3369 RETURN (SCM_SUBRF (proc) (SCM_UNBNDP (arg1) ? SCM_EOL : debug.vect[0].a.args))
0f2d19dd
JB		 3370#else
3371 RETURN (SCM_SUBRF (proc) (SCM_UNBNDP (arg1) ? SCM_EOL : scm_cons (arg1, args)))
3372#endif
3373 case scm_tc7_lsubr_2:
0c95b57d 3374 SCM_ASRTGO (SCM_CONSP (args), wrongnumargs);
0f2d19dd
JB		 3375 RETURN (SCM_SUBRF (proc) (arg1, SCM_CAR (args), SCM_CDR (args)))
3376 case scm_tc7_asubr:
3377 if (SCM_NULLP (args))
3378 RETURN (SCM_SUBRF (proc) (arg1, SCM_UNDEFINED))
3379 while (SCM_NIMP (args))
3380 {
3381 SCM_ASSERT (SCM_CONSP (args), args, SCM_ARG2, "apply");
3382 arg1 = SCM_SUBRF (proc) (arg1, SCM_CAR (args));
3383 args = SCM_CDR (args);
3384 }
3385 RETURN (arg1);
3386 case scm_tc7_rpsubr:
3387 if (SCM_NULLP (args))
3388 RETURN (SCM_BOOL_T);
3389 while (SCM_NIMP (args))
3390 {
3391 SCM_ASSERT (SCM_CONSP (args), args, SCM_ARG2, "apply");
3392 if (SCM_FALSEP (SCM_SUBRF (proc) (arg1, SCM_CAR (args))))
3393 RETURN (SCM_BOOL_F);
3394 arg1 = SCM_CAR (args);
3395 args = SCM_CDR (args);
3396 }
3397 RETURN (SCM_BOOL_T);
3398 case scm_tcs_closures:
3399#ifdef DEVAL
6dbd0af5 3400 arg1 = (SCM_UNBNDP (arg1) ? SCM_EOL : debug.vect[0].a.args);
0f2d19dd
JB		 3401#else
3402 arg1 = (SCM_UNBNDP (arg1) ? SCM_EOL : scm_cons (arg1, args));
3403#endif
cf7c17e9 3404#ifndef SCM_RECKLESS
0f2d19dd
JB		 3405 if (scm_badargsp (SCM_CAR (SCM_CODE (proc)), arg1))
3406 goto wrongnumargs;
3407#endif
1609038c
MD		 3408
3409 /* Copy argument list */
3410 if (SCM_IMP (arg1))
3411 args = arg1;
3412 else
3413 {
3414 SCM tl = args = scm_cons (SCM_CAR (arg1), SCM_UNSPECIFIED);
cabe682c 3415 while (arg1 = SCM_CDR (arg1), SCM_CONSP (arg1))
1609038c
MD		 3416 {
3417 SCM_SETCDR (tl, scm_cons (SCM_CAR (arg1),
3418 SCM_UNSPECIFIED));
3419 tl = SCM_CDR (tl);
3420 }
3421 SCM_SETCDR (tl, arg1);
3422 }
3423
3424 args = EXTEND_ENV (SCM_CAR (SCM_CODE (proc)), args, SCM_ENV (proc));
2ddb0920 3425 proc = SCM_CDR (SCM_CODE (proc));
e791c18f
MD		 3426 again:
3427 arg1 = proc;
3428 while (SCM_NNULLP (arg1 = SCM_CDR (arg1)))
2ddb0920
MD		 3429 {
3430 if (SCM_IMP (SCM_CAR (proc)))
3431 {
3432 if (SCM_ISYMP (SCM_CAR (proc)))
3433 {
3434 proc = scm_m_expand_body (proc, args);
e791c18f 3435 goto again;
2ddb0920 3436 }
2ddb0920
MD		 3437 }
3438 else
e791c18f
MD		 3439 SCM_CEVAL (SCM_CAR (proc), args);
3440 proc = arg1;
2ddb0920 3441 }
e791c18f 3442 RETURN (EVALCAR (proc, args));
0f2d19dd
JB		 3443 case scm_tc7_contin:
3444 SCM_ASRTGO (SCM_NULLP (args), wrongnumargs);
3445 scm_call_continuation (proc, arg1);
3446#ifdef CCLO
3447 case scm_tc7_cclo:
3448#ifdef DEVAL
6dbd0af5
MD		 3449 args = (SCM_UNBNDP(arg1) ? SCM_EOL : debug.vect[0].a.args);
3450 arg1 = proc;
3451 proc = SCM_CCLO_SUBR (proc);
3452 debug.vect[0].a.proc = proc;
3453 debug.vect[0].a.args = scm_cons (arg1, args);
0f2d19dd
JB		 3454#else
3455 args = (SCM_UNBNDP(arg1) ? SCM_EOL : scm_cons (arg1, args));
0f2d19dd
JB		 3456 arg1 = proc;
3457 proc = SCM_CCLO_SUBR (proc);
6dbd0af5 3458#endif
0f2d19dd
JB		 3459 goto tail;
3460#endif
89efbff4
MD		 3461 case scm_tc7_pws:
3462 proc = SCM_PROCEDURE (proc);
3463#ifdef DEVAL
3464 debug.vect[0].a.proc = proc;
3465#endif
3466 goto tail;
0c32d76c 3467 case scm_tcs_cons_gloc:
f3d2630a
MD		 3468 if (SCM_OBJ_CLASS_FLAGS (proc) & SCM_CLASSF_PURE_GENERIC)
3469 {
3470#ifdef DEVAL
3471 args = (SCM_UNBNDP(arg1) ? SCM_EOL : debug.vect[0].a.args);
3472#else
3473 args = (SCM_UNBNDP(arg1) ? SCM_EOL : scm_cons (arg1, args));
3474#endif
195847fa 3475 RETURN (scm_apply_generic (proc, args));
f3d2630a
MD		 3476 }
3477 else if (!SCM_I_OPERATORP (proc))
9b07e212
MD		 3478 goto badproc;
3479 else
da7f71d7
MD		 3480 {
3481#ifdef DEVAL
3482 args = (SCM_UNBNDP(arg1) ? SCM_EOL : debug.vect[0].a.args);
3483#else
3484 args = (SCM_UNBNDP(arg1) ? SCM_EOL : scm_cons (arg1, args));
3485#endif
3486 arg1 = proc;
195847fa
MD		 3487 proc = (SCM_I_ENTITYP (proc)
3488 ? SCM_ENTITY_PROCEDURE (proc)
3489 : SCM_OPERATOR_PROCEDURE (proc));
da7f71d7
MD		 3490#ifdef DEVAL
3491 debug.vect[0].a.proc = proc;
3492 debug.vect[0].a.args = scm_cons (arg1, args);
3493#endif
195847fa
MD		 3494 if (SCM_NIMP (proc))
3495 goto tail;
3496 else
3497 goto badproc;
da7f71d7 3498 }
0f2d19dd 3499 wrongnumargs:
f5bf2977 3500 scm_wrong_num_args (proc);
0f2d19dd
JB		 3501 default:
3502 badproc:
3503 scm_wta (proc, (char *) SCM_ARG1, "apply");
3504 RETURN (arg1);
3505 }
3506#ifdef DEVAL
6dbd0af5 3507exit:
b6d75948 3508 if (CHECK_EXIT && SCM_TRAPS_P)
b7ff98dd 3509 if (SCM_EXIT_FRAME_P || (SCM_TRACE_P && SCM_TRACED_FRAME_P (debug)))
6dbd0af5 3510 {
b7ff98dd
MD		 3511 SCM_CLEAR_TRACED_FRAME (debug);
3512 if (SCM_CHEAPTRAPS_P)
c0ab1b8d 3513 arg1 = scm_make_debugobj (&debug);
6dbd0af5
MD		 3514 else
3515 {
3516 scm_make_cont (&arg1);
ca6ef71a 3517 if (setjmp (SCM_JMPBUF (arg1)))
6dbd0af5
MD		 3518 {
3519 proc = SCM_THROW_VALUE (arg1);
3520 goto ret;
3521 }
3522 }
2f0d1375 3523 scm_ithrow (scm_sym_exit_frame, scm_cons2 (arg1, proc, SCM_EOL), 0);
6dbd0af5
MD		 3524 }
3525ret:
1646d37b 3526 scm_last_debug_frame = debug.prev;
0f2d19dd
JB		 3527 return proc;
3528#endif
3529}
3530
6dbd0af5
MD		 3531
3532/* SECTION: The rest of this file is only read once.
3533 */
3534
0f2d19dd
JB		 3535#ifndef DEVAL
3536
d9c393f5
JB		 3537/* Typechecking for multi-argument MAP and FOR-EACH.
3538
47c3f06d 3539 Verify that each element of the vector ARGV, except for the first,
d9c393f5 3540 is a proper list whose length is LEN. Attribute errors to WHO,
47c3f06d 3541 and claim that the i'th element of ARGV is WHO's i+2'th argument. */
d9c393f5 3542static inline void
47c3f06d
MD		 3543check_map_args (SCM argv,
3544 long len,
3545 SCM gf,
3546 SCM proc,
3547 SCM args,
3548 const char *who)
d9c393f5 3549{
47c3f06d 3550 SCM *ve = SCM_VELTS (argv);
d9c393f5
JB		 3551 int i;
3552
47c3f06d 3553 for (i = SCM_LENGTH (argv) - 1; i >= 1; i--)
d9c393f5
JB		 3554 {
3555 int elt_len = scm_ilength (ve[i]);
3556
3557 if (elt_len < 0)
47c3f06d
MD		 3558 {
3559 if (gf)
3560 scm_apply_generic (gf, scm_cons (proc, args));
3561 else
3562 scm_wrong_type_arg (who, i + 2, ve[i]);
3563 }
d9c393f5
JB		 3564
3565 if (elt_len != len)
3566 scm_out_of_range (who, ve[i]);
3567 }
3568
47c3f06d 3569 scm_remember (&argv);
d9c393f5
JB		 3570}
3571
3572
47c3f06d 3573SCM_GPROC (s_map, "map", 2, 0, 1, scm_map, g_map);
1cc91f1b 3574
368bf056
MD		 3575/* Note: Currently, scm_map applies PROC to the argument list(s)
3576 sequentially, starting with the first element(s). This is used in
3577 evalext.c where the Scheme procedure `serial-map', which guarantees
3578 sequential behaviour, is implemented using scm_map. If the
3579 behaviour changes, we need to update `serial-map'.
3580*/
3581
0f2d19dd 3582SCM
1bbd0b84 3583scm_map (SCM proc, SCM arg1, SCM args)
0f2d19dd 3584{
d9c393f5 3585 long i, len;
0f2d19dd
JB		 3586 SCM res = SCM_EOL;
3587 SCM *pres = &res;
3588 SCM *ve = &args; /* Keep args from being optimized away. */
3589
3590 if (SCM_NULLP (arg1))
3591 return res;
d9c393f5 3592 len = scm_ilength (arg1);
47c3f06d
MD		 3593 SCM_GASSERTn (len >= 0,
3594 g_map, scm_cons2 (proc, arg1, args), SCM_ARG2, s_map);
0f2d19dd
JB		 3595 if (SCM_NULLP (args))
3596 {
3597 while (SCM_NIMP (arg1))
3598 {
47c3f06d
MD		 3599 SCM_GASSERT2 (SCM_CONSP (arg1), g_map, proc, arg1, SCM_ARG2, s_map);
3600 *pres = scm_cons (scm_apply (proc, SCM_CAR (arg1), scm_listofnull),
3601 SCM_EOL);
a23afe53 3602 pres = SCM_CDRLOC (*pres);
0f2d19dd
JB		 3603 arg1 = SCM_CDR (arg1);
3604 }
3605 return res;
3606 }
47c3f06d 3607 args = scm_vector (arg1 = scm_cons (arg1, args));
0f2d19dd 3608 ve = SCM_VELTS (args);
cf7c17e9 3609#ifndef SCM_RECKLESS
47c3f06d 3610 check_map_args (args, len, g_map, proc, arg1, s_map);
0f2d19dd
JB		 3611#endif
3612 while (1)
3613 {
3614 arg1 = SCM_EOL;
3615 for (i = SCM_LENGTH (args) - 1; i >= 0; i--)
3616 {
d9c393f5
JB		 3617 if (SCM_IMP (ve[i]))
3618 return res;
0f2d19dd
JB		 3619 arg1 = scm_cons (SCM_CAR (ve[i]), arg1);
3620 ve[i] = SCM_CDR (ve[i]);
3621 }
3622 *pres = scm_cons (scm_apply (proc, arg1, SCM_EOL), SCM_EOL);
a23afe53 3623 pres = SCM_CDRLOC (*pres);
0f2d19dd
JB		 3624 }
3625}
3626
3627
47c3f06d 3628SCM_GPROC (s_for_each, "for-each", 2, 0, 1, scm_for_each, g_for_each);
1cc91f1b 3629
0f2d19dd 3630SCM
1bbd0b84 3631scm_for_each (SCM proc, SCM arg1, SCM args)
0f2d19dd
JB		 3632{
3633 SCM *ve = &args; /* Keep args from being optimized away. */
d9c393f5 3634 long i, len;
0f2d19dd
JB		 3635 if SCM_NULLP (arg1)
3636 return SCM_UNSPECIFIED;
d9c393f5 3637 len = scm_ilength (arg1);
47c3f06d
MD		 3638 SCM_GASSERTn (len >= 0, g_for_each, scm_cons2 (proc, arg1, args),
3639 SCM_ARG2, s_for_each);
0f2d19dd
JB		 3640 if SCM_NULLP (args)
3641 {
3642 while SCM_NIMP (arg1)
3643 {
47c3f06d
MD		 3644 SCM_GASSERT2 (SCM_CONSP (arg1),
3645 g_for_each, proc, arg1, SCM_ARG2, s_for_each);
0f2d19dd
JB		 3646 scm_apply (proc, SCM_CAR (arg1), scm_listofnull);
3647 arg1 = SCM_CDR (arg1);
3648 }
3649 return SCM_UNSPECIFIED;
3650 }
47c3f06d 3651 args = scm_vector (arg1 = scm_cons (arg1, args));
0f2d19dd 3652 ve = SCM_VELTS (args);
cf7c17e9 3653#ifndef SCM_RECKLESS
47c3f06d 3654 check_map_args (args, len, g_for_each, proc, arg1, s_for_each);
0f2d19dd
JB		 3655#endif
3656 while (1)
3657 {
3658 arg1 = SCM_EOL;
3659 for (i = SCM_LENGTH (args) - 1; i >= 0; i--)
3660 {
3661 if SCM_IMP
3662 (ve[i]) return SCM_UNSPECIFIED;
3663 arg1 = scm_cons (SCM_CAR (ve[i]), arg1);
3664 ve[i] = SCM_CDR (ve[i]);
3665 }
3666 scm_apply (proc, arg1, SCM_EOL);
3667 }
3668}
3669
3670
1cc91f1b 3671
0f2d19dd 3672SCM
6e8d25a6 3673scm_closure (SCM code, SCM env)
0f2d19dd
JB		 3674{
3675 register SCM z;
3676 SCM_NEWCELL (z);
3677 SCM_SETCODE (z, code);
a23afe53 3678 SCM_SETENV (z, env);
0f2d19dd
JB		 3679 return z;
3680}
3681
3682
3683long scm_tc16_promise;
1cc91f1b 3684
0f2d19dd 3685SCM
6e8d25a6 3686scm_makprom (SCM code)
0f2d19dd 3687{
23a62151 3688 SCM_RETURN_NEWSMOB (scm_tc16_promise, code);
0f2d19dd
JB		 3689}
3690
3691
1cc91f1b 3692
0f2d19dd 3693static int
1bbd0b84 3694prinprom (SCM exp,SCM port,scm_print_state *pstate)
0f2d19dd 3695{
19402679 3696 int writingp = SCM_WRITINGP (pstate);
b7f3516f 3697 scm_puts ("#<promise ", port);
19402679
MD		 3698 SCM_SET_WRITINGP (pstate, 1);
3699 scm_iprin1 (SCM_CDR (exp), port, pstate);
3700 SCM_SET_WRITINGP (pstate, writingp);
b7f3516f 3701 scm_putc ('>', port);
0f2d19dd
JB		 3702 return !0;
3703}
3704
3705
3b3b36dd 3706SCM_DEFINE (scm_force, "force", 1, 0, 0,
1bbd0b84
GB		 3707 (SCM x),
3708"")
3709#define FUNC_NAME s_scm_force
0f2d19dd 3710{
3b3b36dd 3711 SCM_VALIDATE_SMOB (1,x,promise);
0f2d19dd
JB		 3712 if (!((1L << 16) & SCM_CAR (x)))
3713 {
3714 SCM ans = scm_apply (SCM_CDR (x), SCM_EOL, SCM_EOL);
3715 if (!((1L << 16) & SCM_CAR (x)))
3716 {
3717 SCM_DEFER_INTS;
a23afe53
MD		 3718 SCM_SETCDR (x, ans);
3719 SCM_SETOR_CAR (x, (1L << 16));
0f2d19dd
JB		 3720 SCM_ALLOW_INTS;
3721 }
3722 }
3723 return SCM_CDR (x);
3724}
1bbd0b84 3725#undef FUNC_NAME
0f2d19dd 3726
a1ec6916 3727SCM_DEFINE (scm_promise_p, "promise?", 1, 0, 0,
1bbd0b84 3728 (SCM x),
4079f87e
GB		 3729"Return true if @var{obj} is a promise, i.e. a delayed computation
3730(@pxref{Delayed evaluation,,,r4rs.info,The Revised^4 Report on Scheme}).")
1bbd0b84 3731#define FUNC_NAME s_scm_promise_p
0f2d19dd 3732{
1bbd0b84 3733 return SCM_BOOL(SCM_NIMP (x) && (SCM_TYP16 (x) == scm_tc16_promise));
0f2d19dd 3734}
1bbd0b84 3735#undef FUNC_NAME
0f2d19dd 3736
a1ec6916 3737SCM_DEFINE (scm_cons_source, "cons-source", 3, 0, 0,
1bbd0b84
GB		 3738 (SCM xorig, SCM x, SCM y),
3739"")
3740#define FUNC_NAME s_scm_cons_source
26d5b9b4
MD		 3741{
3742 SCM p, z;
3743 SCM_NEWCELL (z);
3744 SCM_SETCAR (z, x);
3745 SCM_SETCDR (z, y);
3746 /* Copy source properties possibly associated with xorig. */
3747 p = scm_whash_lookup (scm_source_whash, xorig);
3748 if (SCM_NIMP (p))
3749 scm_whash_insert (scm_source_whash, z, p);
3750 return z;
3751}
1bbd0b84 3752#undef FUNC_NAME
26d5b9b4 3753
a1ec6916 3754SCM_DEFINE (scm_copy_tree, "copy-tree", 1, 0, 0,
1bbd0b84 3755 (SCM obj),
4079f87e
GB		 3756"Recursively copy the data tree that is bound to @var{obj}, and return a
3757pointer to the new data structure. @code{copy-tree} recurses down the
3758contents of both pairs and vectors (since both cons cells and vector
3759cells may point to arbitrary objects), and stops recursing when it hits
3760any other object.")
1bbd0b84 3761#define FUNC_NAME s_scm_copy_tree
0f2d19dd
JB		 3762{
3763 SCM ans, tl;
26d5b9b4 3764 if (SCM_IMP (obj))
ff467021 3765 return obj;
3910272e
MD		 3766 if (SCM_VECTORP (obj))
3767 {
3768 scm_sizet i = SCM_LENGTH (obj);
3769 ans = scm_make_vector (SCM_MAKINUM (i), SCM_UNSPECIFIED);
3770 while (i--)
3771 SCM_VELTS (ans)[i] = scm_copy_tree (SCM_VELTS (obj)[i]);
3772 return ans;
3773 }
ff467021 3774 if (SCM_NCONSP (obj))
0f2d19dd
JB		 3775 return obj;
3776/* return scm_cons(scm_copy_tree(SCM_CAR(obj)), scm_copy_tree(SCM_CDR(obj))); */
26d5b9b4
MD		 3777 ans = tl = scm_cons_source (obj,
3778 scm_copy_tree (SCM_CAR (obj)),
3779 SCM_UNSPECIFIED);
cabe682c 3780 while (obj = SCM_CDR (obj), SCM_CONSP (obj))
a23afe53
MD		 3781 {
3782 SCM_SETCDR (tl, scm_cons (scm_copy_tree (SCM_CAR (obj)),
3783 SCM_UNSPECIFIED));
3784 tl = SCM_CDR (tl);
3785 }
3786 SCM_SETCDR (tl, obj);
0f2d19dd
JB		 3787 return ans;
3788}
1bbd0b84 3789#undef FUNC_NAME
0f2d19dd 3790
1cc91f1b 3791
0f2d19dd 3792SCM
1bbd0b84 3793scm_eval_3 (SCM obj, int copyp, SCM env)
0f2d19dd
JB		 3794{
3795 if (SCM_NIMP (SCM_CDR (scm_system_transformer)))
3796 obj = scm_apply (SCM_CDR (scm_system_transformer), obj, scm_listofnull);
3797 else if (copyp)
3798 obj = scm_copy_tree (obj);
6cb702da 3799 return SCM_XEVAL (obj, env);
0f2d19dd
JB		 3800}
3801
3b3b36dd 3802SCM_DEFINE (scm_eval2, "eval2", 2, 0, 0,
1bbd0b84 3803 (SCM obj, SCM env_thunk),
4079f87e
GB		 3804"Evaluate @var{exp}, a Scheme expression, in the environment designated
3805by @var{lookup}, a symbol-lookup function. @code{(eval exp)} is
3806equivalent to @code{(eval2 exp *top-level-lookup-closure*)}.")
1bbd0b84 3807#define FUNC_NAME s_scm_eval2
0f2d19dd 3808{
6bcb0868 3809 return scm_eval_3 (obj, 1, scm_top_level_env (env_thunk));
0f2d19dd 3810}
1bbd0b84 3811#undef FUNC_NAME
0f2d19dd 3812
3b3b36dd 3813SCM_DEFINE (scm_eval, "eval", 1, 0, 0,
1bbd0b84 3814 (SCM obj),
4079f87e
GB		 3815"Evaluate @var{exp}, a list representing a Scheme expression, in the
3816top-level environment.")
1bbd0b84 3817#define FUNC_NAME s_scm_eval
0f2d19dd 3818{
6bcb0868
MD		 3819 return scm_eval_3 (obj,
3820 1,
3821 scm_top_level_env
3822 (SCM_CDR (scm_top_level_lookup_closure_var)));
0f2d19dd 3823}
1bbd0b84 3824#undef FUNC_NAME
0f2d19dd 3825
1bbd0b84
GB		 3826/*
3827SCM_REGISTER_PROC(s_eval_x, "eval!", 1, 0, 0, scm_eval_x);
3828*/
1cc91f1b 3829
0f2d19dd 3830SCM
1bbd0b84 3831scm_eval_x (SCM obj)
0f2d19dd 3832{
6bcb0868
MD		 3833 return scm_eval_3 (obj,
3834 0,
3835 scm_top_level_env
3836 (SCM_CDR (scm_top_level_lookup_closure_var)));
0f2d19dd
JB		 3837}
3838
6dbd0af5
MD		 3839
3840/* At this point, scm_deval and scm_dapply are generated.
3841 */
3842
0f2d19dd 3843#ifdef DEBUG_EXTENSIONS
6dbd0af5
MD		 3844# define DEVAL
3845# include "eval.c"
0f2d19dd
JB		 3846#endif
3847
3848
1cc91f1b 3849
0f2d19dd
JB		 3850void
3851scm_init_eval ()
0f2d19dd 3852{
33b97402
MD		 3853 scm_init_opts (scm_evaluator_traps,
3854 scm_evaluator_trap_table,
3855 SCM_N_EVALUATOR_TRAPS);
3856 scm_init_opts (scm_eval_options_interface,
3857 scm_eval_opts,
3858 SCM_N_EVAL_OPTIONS);
3859
f99c9c28
MD		 3860 scm_tc16_promise = scm_make_smob_type ("promise", 0);
3861 scm_set_smob_mark (scm_tc16_promise, scm_markcdr);
3862 scm_set_smob_print (scm_tc16_promise, prinprom);
b8229a3b 3863
81123e6d 3864 scm_f_apply = scm_make_subr ("apply", scm_tc7_lsubr_2, scm_apply);
0f2d19dd 3865 scm_system_transformer = scm_sysintern ("scm:eval-transformer", SCM_UNDEFINED);
2f0d1375
MD		 3866 scm_sym_dot = SCM_CAR (scm_sysintern (".", SCM_UNDEFINED));
3867 scm_sym_arrow = SCM_CAR (scm_sysintern ("=>", SCM_UNDEFINED));
3868 scm_sym_else = SCM_CAR (scm_sysintern ("else", SCM_UNDEFINED));
3869 scm_sym_unquote = SCM_CAR (scm_sysintern ("unquote", SCM_UNDEFINED));
3870 scm_sym_uq_splicing = SCM_CAR (scm_sysintern ("unquote-splicing", SCM_UNDEFINED));
0f2d19dd 3871
73b64342
MD		 3872 scm_nil = scm_sysintern ("nil", SCM_UNDEFINED);
3873 SCM_SETCDR (scm_nil, SCM_CAR (scm_nil));
3874 scm_nil = SCM_CAR (scm_nil);
3875 scm_t = scm_sysintern ("t", SCM_UNDEFINED);
3876 SCM_SETCDR (scm_t, SCM_CAR (scm_t));
3877 scm_t = SCM_CAR (scm_t);
73b64342 3878
0f2d19dd 3879 /* acros */
0f2d19dd
JB		 3880 /* end of acros */
3881
dc19d1d2
JB		 3882 scm_top_level_lookup_closure_var =
3883 scm_sysintern("*top-level-lookup-closure*", SCM_BOOL_F);
9b8d3288 3884 scm_can_use_top_level_lookup_closure_var = 1;
0f2d19dd 3885
6dbd0af5 3886#ifdef DEBUG_EXTENSIONS
2f0d1375
MD		 3887 scm_sym_enter_frame = SCM_CAR (scm_sysintern ("enter-frame", SCM_UNDEFINED));
3888 scm_sym_apply_frame = SCM_CAR (scm_sysintern ("apply-frame", SCM_UNDEFINED));
3889 scm_sym_exit_frame = SCM_CAR (scm_sysintern ("exit-frame", SCM_UNDEFINED));
3890 scm_sym_trace = SCM_CAR (scm_sysintern ("trace", SCM_UNDEFINED));
6dbd0af5
MD		 3891#endif
3892
0f2d19dd 3893#include "eval.x"
25eaf21a
MD		 3894
3895 scm_add_feature ("delay");
0f2d19dd 3896}
0f2d19dd 3897
6dbd0af5 3898#endif /* !DEVAL */
Unnamed repository; edit this file 'description' to name the repository.