HCoop / bpt / guile.git / blame
? search:
summary | shortlog | log | commit | commitdiff | tree
blob | blame (incremental) | history | HEAD
* coop-threads.c: Remove K&R function headers.
[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
ff467021 143#define SIDEVAL(x, env) if (SCM_NIMP(x)) SCM_CEVAL((x), (env))
6cb702da 144
0f2d19dd 145#define EVALCELLCAR(x, env) (SCM_SYMBOLP (SCM_CAR(x)) \
26d5b9b4 146 ? *scm_lookupcar(x, env, 1) \
0f2d19dd
JB		 147 : SCM_CEVAL(SCM_CAR(x), env))
148
0f2d19dd
JB		 149#define EVALCAR(x, env) (SCM_NCELLP(SCM_CAR(x))\
150 ? (SCM_IMP(SCM_CAR(x)) \
6cb702da 151 ? SCM_EVALIM(SCM_CAR(x), env) \
0f2d19dd
JB		 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
d0b7bad7 257#ifdef USE_THREADS
8ecf1f13 258static SCM *
26d5b9b4 259scm_lookupcar1 (SCM vloc, SCM genv, int check)
d0b7bad7
MD		 260#else
261SCM *
26d5b9b4 262scm_lookupcar (SCM vloc, SCM genv, int check)
d0b7bad7 263#endif
0f2d19dd
JB		 264{
265 SCM env = genv;
e3173f93
JB		 266 register SCM *al, fl, var = SCM_CAR (vloc);
267#ifdef USE_THREADS
268 register SCM var2 = var;
269#endif
0f2d19dd
JB		 270#ifdef MEMOIZE_LOCALS
271 register SCM iloc = SCM_ILOC00;
272#endif
273 for (; SCM_NIMP (env); env = SCM_CDR (env))
274 {
275 if (SCM_BOOL_T == scm_procedure_p (SCM_CAR (env)))
276 break;
a23afe53 277 al = SCM_CARLOC (env);
0f2d19dd
JB		 278 for (fl = SCM_CAR (*al); SCM_NIMP (fl); fl = SCM_CDR (fl))
279 {
280 if (SCM_NCONSP (fl))
33b97402 281 {
0f2d19dd
JB		 282 if (fl == var)
283 {
284#ifdef MEMOIZE_LOCALS
f8769b1d
MV		 285#ifdef USE_THREADS
286 if (SCM_CAR (vloc) != var)
287 goto race;
288#endif
a23afe53 289 SCM_SETCAR (vloc, iloc + SCM_ICDR);
0f2d19dd 290#endif
a23afe53 291 return SCM_CDRLOC (*al);
0f2d19dd 292 }
33b97402
MD		 293 else
294 break;
295 }
a23afe53 296 al = SCM_CDRLOC (*al);
0f2d19dd
JB		 297 if (SCM_CAR (fl) == var)
298 {
299#ifdef MEMOIZE_LOCALS
cf7c17e9 300#ifndef SCM_RECKLESS /* letrec inits to SCM_UNDEFINED */
0f2d19dd
JB		 301 if (SCM_UNBNDP (SCM_CAR (*al)))
302 {
303 env = SCM_EOL;
304 goto errout;
305 }
f8769b1d
MV		 306#endif
307#ifdef USE_THREADS
308 if (SCM_CAR (vloc) != var)
309 goto race;
0f2d19dd 310#endif
a23afe53 311 SCM_SETCAR (vloc, iloc);
0f2d19dd 312#endif
a23afe53 313 return SCM_CARLOC (*al);
0f2d19dd
JB		 314 }
315#ifdef MEMOIZE_LOCALS
316 iloc += SCM_IDINC;
317#endif
318 }
319#ifdef MEMOIZE_LOCALS
320 iloc = (~SCM_IDSTMSK) & (iloc + SCM_IFRINC);
321#endif
322 }
323 {
324 SCM top_thunk, vcell;
325 if (SCM_NIMP(env))
326 {
327 top_thunk = SCM_CAR(env); /* env now refers to a top level env thunk */
328 env = SCM_CDR (env);
329 }
330 else
331 top_thunk = SCM_BOOL_F;
332 vcell = scm_sym2vcell (var, top_thunk, SCM_BOOL_F);
333 if (vcell == SCM_BOOL_F)
334 goto errout;
335 else
336 var = vcell;
337 }
cf7c17e9 338#ifndef SCM_RECKLESS
0f2d19dd
JB		 339 if (SCM_NNULLP (env) || SCM_UNBNDP (SCM_CDR (var)))
340 {
341 var = SCM_CAR (var);
342 errout:
f5bf2977 343 /* scm_everr (vloc, genv,...) */
26d5b9b4
MD		 344 if (check)
345 scm_misc_error (NULL,
346 SCM_NULLP (env)
347 ? "Unbound variable: %S"
348 : "Damaged environment: %S",
349 scm_listify (var, SCM_UNDEFINED));
350 else
351 return SCM_CDRLOC (&undef_cell);
0f2d19dd
JB		 352 }
353#endif
f8769b1d
MV		 354#ifdef USE_THREADS
355 if (SCM_CAR (vloc) != var2)
356 {
357 /* Some other thread has changed the very cell we are working
358 on. In effect, it must have done our job or messed it up
359 completely. */
360 race:
361 var = SCM_CAR (vloc);
362 if ((var & 7) == 1)
363 return SCM_GLOC_VAL_LOC (var);
364#ifdef MEMOIZE_LOCALS
365 if ((var & 127) == (127 & SCM_ILOC00))
366 return scm_ilookup (var, genv);
367#endif
368 /* We can't cope with anything else than glocs and ilocs. When
369 a special form has been memoized (i.e. `let' into `#@let') we
370 return NULL and expect the calling function to do the right
371 thing. For the evaluator, this means going back and redoing
372 the dispatch on the car of the form. */
373 return NULL;
374 }
375#endif /* USE_THREADS */
376
a23afe53 377 SCM_SETCAR (vloc, var + 1);
0f2d19dd 378 /* Except wait...what if the var is not a vcell,
f8769b1d 379 * but syntax or something.... */
a23afe53 380 return SCM_CDRLOC (var);
0f2d19dd
JB		 381}
382
f8769b1d
MV		 383#ifdef USE_THREADS
384SCM *
6e8d25a6 385scm_lookupcar (SCM vloc, SCM genv, int check)
f8769b1d 386{
26d5b9b4 387 SCM *loc = scm_lookupcar1 (vloc, genv, check);
f8769b1d
MV		 388 if (loc == NULL)
389 abort ();
390 return loc;
391}
f8769b1d
MV		 392#endif
393
0f2d19dd 394#define unmemocar scm_unmemocar
1cc91f1b 395
0f2d19dd 396SCM
6e8d25a6 397scm_unmemocar (SCM form, SCM env)
0f2d19dd 398{
6dbd0af5 399#ifdef DEBUG_EXTENSIONS
0f2d19dd 400 register int ir;
6dbd0af5 401#endif
0f2d19dd
JB		 402 SCM c;
403
404 if (SCM_IMP (form))
405 return form;
406 c = SCM_CAR (form);
407 if (1 == (c & 7))
a23afe53 408 SCM_SETCAR (form, SCM_CAR (c - 1));
0f2d19dd 409#ifdef MEMOIZE_LOCALS
6dbd0af5 410#ifdef DEBUG_EXTENSIONS
0f2d19dd
JB		 411 else if (SCM_ILOCP (c))
412 {
413 for (ir = SCM_IFRAME (c); ir != 0; --ir)
414 env = SCM_CDR (env);
415 env = SCM_CAR (SCM_CAR (env));
416 for (ir = SCM_IDIST (c); ir != 0; --ir)
417 env = SCM_CDR (env);
a23afe53 418 SCM_SETCAR (form, SCM_ICDRP (c) ? env : SCM_CAR (env));
0f2d19dd 419 }
6dbd0af5 420#endif
0f2d19dd
JB		 421#endif
422 return form;
423}
424
1cc91f1b 425
0f2d19dd 426SCM
6e8d25a6 427scm_eval_car (SCM pair, SCM env)
0f2d19dd 428{
6cb702da 429 return SCM_XEVALCAR (pair, env);
0f2d19dd
JB		 430}
431
432\f
433/*
434 * The following rewrite expressions and
435 * some memoized forms have different syntax
436 */
437
3eeba8d4
JB		 438const char scm_s_expression[] = "missing or extra expression";
439const char scm_s_test[] = "bad test";
440const char scm_s_body[] = "bad body";
441const char scm_s_bindings[] = "bad bindings";
442const char scm_s_variable[] = "bad variable";
443const char scm_s_clauses[] = "bad or missing clauses";
444const char scm_s_formals[] = "bad formals";
0f2d19dd 445
81123e6d
MD		 446SCM scm_sym_dot, scm_sym_arrow, scm_sym_else;
447SCM scm_sym_unquote, scm_sym_uq_splicing, scm_sym_apply;
448
449SCM scm_f_apply;
b8229a3b 450
6dbd0af5 451#ifdef DEBUG_EXTENSIONS
2f0d1375
MD		 452SCM scm_sym_enter_frame, scm_sym_apply_frame, scm_sym_exit_frame;
453SCM scm_sym_trace;
6dbd0af5 454#endif
0f2d19dd
JB		 455
456#define ASRTSYNTAX(cond_, msg_) if(!(cond_))scm_wta(xorig, (msg_), what);
457
458
1cc91f1b 459
e4755e5c 460static void bodycheck SCM_P ((SCM xorig, SCM *bodyloc, const char *what));
1cc91f1b 461
0f2d19dd 462static void
6e8d25a6 463bodycheck (SCM xorig, SCM *bodyloc, const char *what)
0f2d19dd 464{
6cb702da 465 ASRTSYNTAX (scm_ilength (*bodyloc) >= 1, scm_s_expression);
0f2d19dd
JB		 466}
467
26d5b9b4
MD		 468/* Check that the body denoted by XORIG is valid and rewrite it into
469 its internal form. The internal form of a body is just the body
470 itself, but prefixed with an ISYM that denotes to what kind of
471 outer construct this body belongs. A lambda body starts with
472 SCM_IM_LAMBDA, for example, a body of a let starts with SCM_IM_LET,
473 etc. The one exception is a body that belongs to a letrec that has
474 been formed by rewriting internal defines: it starts with
475 SCM_IM_DEFINE. */
476
477/* XXX - Besides controlling the rewriting of internal defines, the
478 additional ISYM could be used for improved error messages.
479 This is not done yet. */
480
481static SCM
6e8d25a6 482scm_m_body (SCM op, SCM xorig, const char *what)
26d5b9b4
MD		 483{
484 ASRTSYNTAX (scm_ilength (xorig) >= 1, scm_s_expression);
485
486 /* Don't add another ISYM if one is present already. */
487 if (SCM_ISYMP (SCM_CAR (xorig)))
488 return xorig;
489
490 /* Retain possible doc string. */
491 if (SCM_IMP (SCM_CAR(xorig)) || SCM_NCONSP (SCM_CAR (xorig)))
492 {
493 if (SCM_NNULLP (SCM_CDR(xorig)))
494 return scm_cons (SCM_CAR (xorig),
495 scm_m_body (op, SCM_CDR(xorig), what));
496 return xorig;
497 }
498
499 return scm_cons2 (op, SCM_CAR (xorig), SCM_CDR(xorig));
500}
501
b8229a3b 502SCM_SYNTAX(s_quote,"quote", scm_makmmacro, scm_m_quote);
2f0d1375 503SCM_GLOBAL_SYMBOL(scm_sym_quote, s_quote);
1cc91f1b 504
0f2d19dd 505SCM
6e8d25a6 506scm_m_quote (SCM xorig, SCM env)
0f2d19dd 507{
26d5b9b4
MD		 508 SCM x = scm_copy_tree (SCM_CDR (xorig));
509
6cb702da 510 SCM_ASSYNT (scm_ilength (SCM_CDR (xorig)) == 1,
b8229a3b 511 xorig, scm_s_expression, s_quote);
3a3111a8 512 return scm_cons (SCM_IM_QUOTE, x);
0f2d19dd
JB		 513}
514
515
1cc91f1b 516
b8229a3b 517SCM_SYNTAX(s_begin, "begin", scm_makmmacro, scm_m_begin);
2f0d1375 518SCM_GLOBAL_SYMBOL(scm_sym_begin, s_begin);
b8229a3b 519
0f2d19dd 520SCM
6e8d25a6 521scm_m_begin (SCM xorig, SCM env)
0f2d19dd 522{
6cb702da 523 SCM_ASSYNT (scm_ilength (SCM_CDR (xorig)) >= 1,
b8229a3b 524 xorig, scm_s_expression, s_begin);
3a3111a8 525 return scm_cons (SCM_IM_BEGIN, SCM_CDR (xorig));
0f2d19dd
JB		 526}
527
b8229a3b 528SCM_SYNTAX(s_if, "if", scm_makmmacro, scm_m_if);
2f0d1375 529SCM_GLOBAL_SYMBOL(scm_sym_if, s_if);
1cc91f1b 530
0f2d19dd 531SCM
6e8d25a6 532scm_m_if (SCM xorig, SCM env)
0f2d19dd
JB		 533{
534 int len = scm_ilength (SCM_CDR (xorig));
6cb702da 535 SCM_ASSYNT (len >= 2 && len <= 3, xorig, scm_s_expression, "if");
3a3111a8 536 return scm_cons (SCM_IM_IF, SCM_CDR (xorig));
0f2d19dd
JB		 537}
538
539
89efbff4
MD		 540/* Will go into the RnRS module when Guile is factorized.
541SCM_SYNTAX(scm_s_set_x,"set!", scm_makmmacro, scm_m_set_x); */
542const char scm_s_set_x[] = "set!";
543SCM_GLOBAL_SYMBOL(scm_sym_set_x, scm_s_set_x);
1cc91f1b 544
0f2d19dd 545SCM
6e8d25a6 546scm_m_set_x (SCM xorig, SCM env)
0f2d19dd 547{
6dbd0af5 548 SCM x = SCM_CDR (xorig);
89efbff4 549 SCM_ASSYNT (2 == scm_ilength (x), xorig, scm_s_expression, scm_s_set_x);
6cb702da 550 SCM_ASSYNT (SCM_NIMP (SCM_CAR (x)) && SCM_SYMBOLP (SCM_CAR (x)),
89efbff4 551 xorig, scm_s_variable, scm_s_set_x);
3a3111a8 552 return scm_cons (SCM_IM_SET_X, x);
0f2d19dd
JB		 553}
554
555
556#if 0
1cc91f1b 557
0f2d19dd 558SCM
6e8d25a6 559scm_m_vref (SCM xorig, SCM env)
0f2d19dd
JB		 560{
561 SCM x = SCM_CDR (xorig);
6cb702da 562 SCM_ASSYNT (1 == scm_ilength (x), xorig, scm_s_expression, s_vref);
0f2d19dd
JB		 563 if (SCM_NIMP(x) && UDSCM_VARIABLEP (SCM_CAR (x)))
564 {
f5bf2977 565 /* scm_everr (SCM_UNDEFINED, env,..., "global variable reference") */
523f5266
GH		 566 scm_misc_error (NULL,
567 "Bad variable: %S",
568 scm_listify (SCM_CAR (SCM_CDR (x)), SCM_UNDEFINED));
0f2d19dd 569 }
6cb702da
MD		 570 SCM_ASSYNT (SCM_NIMP(x) && DEFSCM_VARIABLEP (SCM_CAR (x)),
571 xorig, scm_s_variable, s_vref);
0f2d19dd
JB		 572 return scm_cons (IM_VREF, x);
573}
574
575
1cc91f1b 576
0f2d19dd 577SCM
6e8d25a6 578scm_m_vset (SCM xorig, SCM env)
0f2d19dd
JB		 579{
580 SCM x = SCM_CDR (xorig);
6cb702da
MD		 581 SCM_ASSYNT (3 == scm_ilength (x), xorig, scm_s_expression, s_vset);
582 SCM_ASSYNT ((DEFSCM_VARIABLEP (SCM_CAR (x))
583 || UDSCM_VARIABLEP (SCM_CAR (x))),
584 xorig, scm_s_variable, s_vset);
0f2d19dd
JB		 585 return scm_cons (IM_VSET, x);
586}
587#endif
588
589
b8229a3b 590SCM_SYNTAX(s_and, "and", scm_makmmacro, scm_m_and);
2f0d1375 591SCM_GLOBAL_SYMBOL(scm_sym_and, s_and);
1cc91f1b 592
0f2d19dd 593SCM
6e8d25a6 594scm_m_and (SCM xorig, SCM env)
0f2d19dd
JB		 595{
596 int len = scm_ilength (SCM_CDR (xorig));
b8229a3b 597 SCM_ASSYNT (len >= 0, xorig, scm_s_test, s_and);
0f2d19dd 598 if (len >= 1)
3a3111a8 599 return scm_cons (SCM_IM_AND, SCM_CDR (xorig));
0f2d19dd
JB		 600 else
601 return SCM_BOOL_T;
602}
603
b8229a3b 604SCM_SYNTAX(s_or,"or", scm_makmmacro, scm_m_or);
2f0d1375 605SCM_GLOBAL_SYMBOL(scm_sym_or,s_or);
1cc91f1b 606
0f2d19dd 607SCM
6e8d25a6 608scm_m_or (SCM xorig, SCM env)
0f2d19dd
JB		 609{
610 int len = scm_ilength (SCM_CDR (xorig));
b8229a3b 611 SCM_ASSYNT (len >= 0, xorig, scm_s_test, s_or);
0f2d19dd 612 if (len >= 1)
3a3111a8 613 return scm_cons (SCM_IM_OR, SCM_CDR (xorig));
0f2d19dd
JB		 614 else
615 return SCM_BOOL_F;
616}
617
618
b8229a3b 619SCM_SYNTAX(s_case, "case", scm_makmmacro, scm_m_case);
2f0d1375 620SCM_GLOBAL_SYMBOL(scm_sym_case, s_case);
1cc91f1b 621
0f2d19dd 622SCM
6e8d25a6 623scm_m_case (SCM xorig, SCM env)
0f2d19dd 624{
26d5b9b4 625 SCM proc, cdrx = scm_list_copy (SCM_CDR (xorig)), x = cdrx;
b8229a3b 626 SCM_ASSYNT (scm_ilength (x) >= 2, xorig, scm_s_clauses, s_case);
0f2d19dd
JB		 627 while (SCM_NIMP (x = SCM_CDR (x)))
628 {
629 proc = SCM_CAR (x);
b8229a3b 630 SCM_ASSYNT (scm_ilength (proc) >= 2, xorig, scm_s_clauses, s_case);
6cb702da 631 SCM_ASSYNT (scm_ilength (SCM_CAR (proc)) >= 0
2f0d1375 632 || scm_sym_else == SCM_CAR (proc),
b8229a3b 633 xorig, scm_s_clauses, s_case);
0f2d19dd 634 }
3a3111a8 635 return scm_cons (SCM_IM_CASE, cdrx);
0f2d19dd
JB		 636}
637
638
b8229a3b 639SCM_SYNTAX(s_cond, "cond", scm_makmmacro, scm_m_cond);
2f0d1375 640SCM_GLOBAL_SYMBOL(scm_sym_cond, s_cond);
b8229a3b 641
1cc91f1b 642
0f2d19dd 643SCM
6e8d25a6 644scm_m_cond (SCM xorig, SCM env)
0f2d19dd 645{
26d5b9b4 646 SCM arg1, cdrx = scm_list_copy (SCM_CDR (xorig)), x = cdrx;
0f2d19dd 647 int len = scm_ilength (x);
b8229a3b 648 SCM_ASSYNT (len >= 1, xorig, scm_s_clauses, s_cond);
0f2d19dd
JB		 649 while (SCM_NIMP (x))
650 {
651 arg1 = SCM_CAR (x);
652 len = scm_ilength (arg1);
b8229a3b 653 SCM_ASSYNT (len >= 1, xorig, scm_s_clauses, s_cond);
2f0d1375 654 if (scm_sym_else == SCM_CAR (arg1))
0f2d19dd 655 {
6cb702da 656 SCM_ASSYNT (SCM_NULLP (SCM_CDR (x)) && len >= 2,
b8229a3b 657 xorig, "bad ELSE clause", s_cond);
a23afe53 658 SCM_SETCAR (arg1, SCM_BOOL_T);
0f2d19dd 659 }
2f0d1375 660 if (len >= 2 && scm_sym_arrow == SCM_CAR (SCM_CDR (arg1)))
6cb702da 661 SCM_ASSYNT (3 == len && SCM_NIMP (SCM_CAR (SCM_CDR (SCM_CDR (arg1)))),
b8229a3b 662 xorig, "bad recipient", s_cond);
0f2d19dd
JB		 663 x = SCM_CDR (x);
664 }
3a3111a8 665 return scm_cons (SCM_IM_COND, cdrx);
0f2d19dd
JB		 666}
667
b8229a3b 668SCM_SYNTAX(s_lambda, "lambda", scm_makmmacro, scm_m_lambda);
2f0d1375 669SCM_GLOBAL_SYMBOL(scm_sym_lambda, s_lambda);
1cc91f1b 670
0f2d19dd 671SCM
6e8d25a6 672scm_m_lambda (SCM xorig, SCM env)
0f2d19dd
JB		 673{
674 SCM proc, x = SCM_CDR (xorig);
26d5b9b4 675 if (scm_ilength (x) < 2)
0f2d19dd
JB		 676 goto badforms;
677 proc = SCM_CAR (x);
33b97402
MD		 678 if (SCM_NULLP (proc))
679 goto memlambda;
26d5b9b4
MD		 680 if (SCM_IM_LET == proc) /* named let */
681 goto memlambda;
33b97402
MD		 682 if (SCM_IMP (proc))
683 goto badforms;
684 if (SCM_SYMBOLP (proc))
685 goto memlambda;
686 if (SCM_NCONSP (proc))
687 goto badforms;
688 while (SCM_NIMP (proc))
0f2d19dd 689 {
33b97402
MD		 690 if (SCM_NCONSP (proc))
691 {
0f2d19dd 692 if (!SCM_SYMBOLP (proc))
33b97402
MD		 693 goto badforms;
694 else
695 goto memlambda;
696 }
0c95b57d 697 if (!SCM_SYMBOLP (SCM_CAR (proc)))
0f2d19dd
JB		 698 goto badforms;
699 proc = SCM_CDR (proc);
700 }
ff467021 701 if (SCM_NNULLP (proc))
26d5b9b4
MD		 702 {
703 badforms:
704 scm_wta (xorig, scm_s_formals, s_lambda);
705 }
706
707 memlambda:
3a3111a8
MD		 708 return scm_cons2 (SCM_IM_LAMBDA, SCM_CAR (x),
709 scm_m_body (SCM_IM_LAMBDA, SCM_CDR (x), s_lambda));
0f2d19dd
JB		 710}
711
b8229a3b 712SCM_SYNTAX(s_letstar,"let*", scm_makmmacro, scm_m_letstar);
2f0d1375 713SCM_GLOBAL_SYMBOL(scm_sym_letstar,s_letstar);
0f2d19dd 714
1cc91f1b 715
0f2d19dd 716SCM
6e8d25a6 717scm_m_letstar (SCM xorig, SCM env)
0f2d19dd
JB		 718{
719 SCM x = SCM_CDR (xorig), arg1, proc, vars = SCM_EOL, *varloc = &vars;
720 int len = scm_ilength (x);
b8229a3b 721 SCM_ASSYNT (len >= 2, xorig, scm_s_body, s_letstar);
0f2d19dd 722 proc = SCM_CAR (x);
b8229a3b 723 SCM_ASSYNT (scm_ilength (proc) >= 0, xorig, scm_s_bindings, s_letstar);
ff467021 724 while (SCM_NIMP (proc))
0f2d19dd
JB		 725 {
726 arg1 = SCM_CAR (proc);
b8229a3b 727 SCM_ASSYNT (2 == scm_ilength (arg1), xorig, scm_s_bindings, s_letstar);
0c95b57d 728 SCM_ASSYNT (SCM_SYMBOLP (SCM_CAR (arg1)), xorig, scm_s_variable, s_letstar);
0f2d19dd 729 *varloc = scm_cons2 (SCM_CAR (arg1), SCM_CAR (SCM_CDR (arg1)), SCM_EOL);
a23afe53 730 varloc = SCM_CDRLOC (SCM_CDR (*varloc));
0f2d19dd
JB		 731 proc = SCM_CDR (proc);
732 }
733 x = scm_cons (vars, SCM_CDR (x));
26d5b9b4 734
3a3111a8
MD		 735 return scm_cons2 (SCM_IM_LETSTAR, SCM_CAR (x),
736 scm_m_body (SCM_IM_LETSTAR, SCM_CDR (x), s_letstar));
0f2d19dd
JB		 737}
738
739/* DO gets the most radically altered syntax
740 (do ((<var1> <init1> <step1>)
741 (<var2> <init2>)
742 ... )
743 (<test> <return>)
744 <body>)
745 ;; becomes
746 (do_mem (varn ... var2 var1)
747 (<init1> <init2> ... <initn>)
748 (<test> <return>)
749 (<body>)
750 <step1> <step2> ... <stepn>) ;; missing steps replaced by var
751 */
752
b8229a3b 753SCM_SYNTAX(s_do, "do", scm_makmmacro, scm_m_do);
2f0d1375 754SCM_GLOBAL_SYMBOL(scm_sym_do, s_do);
1cc91f1b 755
0f2d19dd 756SCM
6e8d25a6 757scm_m_do (SCM xorig, SCM env)
0f2d19dd
JB		 758{
759 SCM x = SCM_CDR (xorig), arg1, proc;
760 SCM vars = SCM_EOL, inits = SCM_EOL, steps = SCM_EOL;
761 SCM *initloc = &inits, *steploc = &steps;
762 int len = scm_ilength (x);
6cb702da 763 SCM_ASSYNT (len >= 2, xorig, scm_s_test, "do");
0f2d19dd 764 proc = SCM_CAR (x);
6cb702da 765 SCM_ASSYNT (scm_ilength (proc) >= 0, xorig, scm_s_bindings, "do");
ff467021 766 while (SCM_NIMP(proc))
0f2d19dd
JB		 767 {
768 arg1 = SCM_CAR (proc);
769 len = scm_ilength (arg1);
6cb702da 770 SCM_ASSYNT (2 == len || 3 == len, xorig, scm_s_bindings, "do");
0c95b57d 771 SCM_ASSYNT (SCM_SYMBOLP (SCM_CAR (arg1)), xorig, scm_s_variable, "do");
0f2d19dd
JB		 772 /* vars reversed here, inits and steps reversed at evaluation */
773 vars = scm_cons (SCM_CAR (arg1), vars); /* variable */
774 arg1 = SCM_CDR (arg1);
775 *initloc = scm_cons (SCM_CAR (arg1), SCM_EOL); /* init */
a23afe53 776 initloc = SCM_CDRLOC (*initloc);
0f2d19dd
JB		 777 arg1 = SCM_CDR (arg1);
778 *steploc = scm_cons (SCM_IMP (arg1) ? SCM_CAR (vars) : SCM_CAR (arg1), SCM_EOL); /* step */
a23afe53 779 steploc = SCM_CDRLOC (*steploc);
0f2d19dd
JB		 780 proc = SCM_CDR (proc);
781 }
782 x = SCM_CDR (x);
6cb702da 783 SCM_ASSYNT (scm_ilength (SCM_CAR (x)) >= 1, xorig, scm_s_test, "do");
0f2d19dd
JB		 784 x = scm_cons2 (SCM_CAR (x), SCM_CDR (x), steps);
785 x = scm_cons2 (vars, inits, x);
a23afe53 786 bodycheck (xorig, SCM_CARLOC (SCM_CDR (SCM_CDR (x))), "do");
3a3111a8 787 return scm_cons (SCM_IM_DO, x);
0f2d19dd
JB		 788}
789
6dbd0af5
MD		 790/* evalcar is small version of inline EVALCAR when we don't care about
791 * speed
792 */
793#define evalcar scm_eval_car
0f2d19dd 794
1cc91f1b 795
1bbd0b84 796static SCM iqq (SCM form, SCM env, int depth);
1cc91f1b 797
b8229a3b 798SCM_SYNTAX(s_quasiquote, "quasiquote", scm_makacro, scm_m_quasiquote);
2f0d1375 799SCM_GLOBAL_SYMBOL(scm_sym_quasiquote, s_quasiquote);
b8229a3b
MS		 800
801SCM
6e8d25a6 802scm_m_quasiquote (SCM xorig, SCM env)
b8229a3b
MS		 803{
804 SCM x = SCM_CDR (xorig);
805 SCM_ASSYNT (scm_ilength (x) == 1, xorig, scm_s_expression, s_quasiquote);
806 return iqq (SCM_CAR (x), env, 1);
807}
808
809
0f2d19dd 810static SCM
1bbd0b84 811iqq (SCM form,SCM env,int depth)
0f2d19dd
JB		 812{
813 SCM tmp;
814 int edepth = depth;
ff467021
JB		 815 if (SCM_IMP(form))
816 return form;
0f2d19dd
JB		 817 if (SCM_VECTORP (form))
818 {
819 long i = SCM_LENGTH (form);
820 SCM *data = SCM_VELTS (form);
821 tmp = SCM_EOL;
822 for (; --i >= 0;)
823 tmp = scm_cons (data[i], tmp);
824 return scm_vector (iqq (tmp, env, depth));
825 }
ff467021
JB		 826 if (SCM_NCONSP(form))
827 return form;
0f2d19dd 828 tmp = SCM_CAR (form);
2f0d1375 829 if (scm_sym_quasiquote == tmp)
0f2d19dd
JB		 830 {
831 depth++;
832 goto label;
833 }
2f0d1375 834 if (scm_sym_unquote == tmp)
0f2d19dd
JB		 835 {
836 --depth;
837 label:
838 form = SCM_CDR (form);
0c95b57d
GB		 839 SCM_ASSERT (SCM_ECONSP (form) && SCM_NULLP (SCM_CDR (form)),
840 form, SCM_ARG1, s_quasiquote);
0f2d19dd
JB		 841 if (0 == depth)
842 return evalcar (form, env);
843 return scm_cons2 (tmp, iqq (SCM_CAR (form), env, depth), SCM_EOL);
844 }
2f0d1375 845 if (SCM_NIMP (tmp) && (scm_sym_uq_splicing == SCM_CAR (tmp)))
0f2d19dd
JB		 846 {
847 tmp = SCM_CDR (tmp);
848 if (0 == --edepth)
849 return scm_append (scm_cons2 (evalcar (tmp, env), iqq (SCM_CDR (form), env, depth), SCM_EOL));
850 }
851 return scm_cons (iqq (SCM_CAR (form), env, edepth), iqq (SCM_CDR (form), env, depth));
852}
853
854/* Here are acros which return values rather than code. */
855
a570e93a
MD		 856SCM_SYNTAX (s_delay, "delay", scm_makmmacro, scm_m_delay);
857SCM_GLOBAL_SYMBOL (scm_sym_delay, s_delay);
1cc91f1b 858
0f2d19dd 859SCM
6e8d25a6 860scm_m_delay (SCM xorig, SCM env)
0f2d19dd 861{
6cb702da 862 SCM_ASSYNT (scm_ilength (xorig) == 2, xorig, scm_s_expression, s_delay);
a570e93a 863 return scm_cons2 (SCM_IM_DELAY, SCM_EOL, SCM_CDR (xorig));
0f2d19dd
JB		 864}
865
1cc91f1b 866
b8229a3b 867SCM_SYNTAX(s_define, "define", scm_makmmacro, scm_m_define);
2f0d1375 868SCM_GLOBAL_SYMBOL(scm_sym_define, s_define);
1cc91f1b 869
0f2d19dd 870SCM
6e8d25a6 871scm_m_define (SCM x, SCM env)
0f2d19dd
JB		 872{
873 SCM proc, arg1 = x;
874 x = SCM_CDR (x);
6cb702da 875 /* SCM_ASSYNT(SCM_NULLP(env), x, "bad placement", s_define);*/
b8229a3b 876 SCM_ASSYNT (scm_ilength (x) >= 2, arg1, scm_s_expression, s_define);
0f2d19dd
JB		 877 proc = SCM_CAR (x);
878 x = SCM_CDR (x);
0c95b57d 879 while (SCM_CONSP (proc))
0f2d19dd 880 { /* nested define syntax */
2f0d1375 881 x = scm_cons (scm_cons2 (scm_sym_lambda, SCM_CDR (proc), x), SCM_EOL);
0f2d19dd
JB		 882 proc = SCM_CAR (proc);
883 }
0c95b57d 884 SCM_ASSYNT (SCM_SYMBOLP (proc),
b8229a3b
MS		 885 arg1, scm_s_variable, s_define);
886 SCM_ASSYNT (1 == scm_ilength (x), arg1, scm_s_expression, s_define);
0f2d19dd
JB		 887 if (SCM_TOP_LEVEL (env))
888 {
889 x = evalcar (x, env);
6dbd0af5 890#ifdef DEBUG_EXTENSIONS
80ea260c
MD		 891 if (SCM_REC_PROCNAMES_P && SCM_NIMP (x))
892 {
893 arg1 = x;
894 proc:
895 if (SCM_CLOSUREP (arg1)
896 /* Only the first definition determines the name. */
2f0d1375
MD		 897 && scm_procedure_property (arg1, scm_sym_name) == SCM_BOOL_F)
898 scm_set_procedure_property_x (arg1, scm_sym_name, proc);
80ea260c
MD		 899 else if (SCM_TYP16 (arg1) == scm_tc16_macro
900 && SCM_CDR (arg1) != arg1)
901 {
902 arg1 = SCM_CDR (arg1);
903 goto proc;
904 }
905 }
6dbd0af5 906#endif
6cb702da 907 arg1 = scm_sym2vcell (proc, scm_env_top_level (env), SCM_BOOL_T);
0f2d19dd 908#if 0
cf7c17e9 909#ifndef SCM_RECKLESS
0f2d19dd
JB		 910 if (SCM_NIMP (SCM_CDR (arg1)) && ((SCM) SCM_SNAME (SCM_CDR (arg1)) == proc)
911 && (SCM_CDR (arg1) != x))
912 scm_warn ("redefining built-in ", SCM_CHARS (proc));
913 else
914#endif
915 if (5 <= scm_verbose && SCM_UNDEFINED != SCM_CDR (arg1))
916 scm_warn ("redefining ", SCM_CHARS (proc));
0f2d19dd 917#endif
a23afe53 918 SCM_SETCDR (arg1, x);
0f2d19dd 919#ifdef SICP
2f0d1375 920 return scm_cons2 (scm_sym_quote, SCM_CAR (arg1), SCM_EOL);
0f2d19dd
JB		 921#else
922 return SCM_UNSPECIFIED;
923#endif
924 }
925 return scm_cons2 (SCM_IM_DEFINE, proc, x);
926}
6dbd0af5 927
0f2d19dd
JB		 928/* end of acros */
929
26d5b9b4 930static SCM
6e8d25a6 931scm_m_letrec1 (SCM op, SCM imm, SCM xorig, SCM env)
0f2d19dd
JB		 932{
933 SCM cdrx = SCM_CDR (xorig); /* locally mutable version of form */
934 char *what = SCM_CHARS (SCM_CAR (xorig));
935 SCM x = cdrx, proc, arg1; /* structure traversers */
936 SCM vars = SCM_EOL, inits = SCM_EOL, *initloc = &inits;
937
0f2d19dd 938 proc = SCM_CAR (x);
6cb702da 939 ASRTSYNTAX (scm_ilength (proc) >= 1, scm_s_bindings);
0f2d19dd
JB		 940 do
941 {
942 /* vars scm_list reversed here, inits reversed at evaluation */
943 arg1 = SCM_CAR (proc);
6cb702da 944 ASRTSYNTAX (2 == scm_ilength (arg1), scm_s_bindings);
0c95b57d 945 ASRTSYNTAX (SCM_SYMBOLP (SCM_CAR (arg1)),
26d5b9b4 946 scm_s_variable);
0f2d19dd
JB		 947 vars = scm_cons (SCM_CAR (arg1), vars);
948 *initloc = scm_cons (SCM_CAR (SCM_CDR (arg1)), SCM_EOL);
a23afe53 949 initloc = SCM_CDRLOC (*initloc);
0f2d19dd 950 }
ff467021 951 while (SCM_NIMP (proc = SCM_CDR (proc)));
26d5b9b4 952
3a3111a8
MD		 953 return scm_cons2 (op, vars,
954 scm_cons (inits, scm_m_body (imm, SCM_CDR (x), what)));
0f2d19dd
JB		 955}
956
26d5b9b4 957SCM_SYNTAX(s_letrec, "letrec", scm_makmmacro, scm_m_letrec);
2f0d1375 958SCM_GLOBAL_SYMBOL(scm_sym_letrec, s_letrec);
26d5b9b4
MD		 959
960SCM
6e8d25a6 961scm_m_letrec (SCM xorig, SCM env)
26d5b9b4
MD		 962{
963 SCM x = SCM_CDR (xorig);
964 SCM_ASSYNT (scm_ilength (x) >= 2, xorig, scm_s_body, s_letrec);
965
966 if (SCM_NULLP (SCM_CAR (x))) /* null binding, let* faster */
3a3111a8
MD		 967 return scm_m_letstar (scm_cons2 (SCM_CAR (xorig), SCM_EOL,
968 scm_m_body (SCM_IM_LETREC,
969 SCM_CDR (x),
970 s_letrec)),
26d5b9b4
MD		 971 env);
972 else
973 return scm_m_letrec1 (SCM_IM_LETREC, SCM_IM_LETREC, xorig, env);
974}
1cc91f1b 975
b8229a3b 976SCM_SYNTAX(s_let, "let", scm_makmmacro, scm_m_let);
2f0d1375 977SCM_GLOBAL_SYMBOL(scm_sym_let, s_let);
b8229a3b 978
0f2d19dd 979SCM
6e8d25a6 980scm_m_let (SCM xorig, SCM env)
0f2d19dd
JB		 981{
982 SCM cdrx = SCM_CDR (xorig); /* locally mutable version of form */
983 SCM x = cdrx, proc, arg1, name; /* structure traversers */
984 SCM vars = SCM_EOL, inits = SCM_EOL, *varloc = &vars, *initloc = &inits;
985
b8229a3b 986 SCM_ASSYNT (scm_ilength (x) >= 2, xorig, scm_s_body, s_let);
0f2d19dd
JB		 987 proc = SCM_CAR (x);
988 if (SCM_NULLP (proc)
0c95b57d 989 || (SCM_CONSP (proc)
26d5b9b4
MD		 990 && SCM_CONSP (SCM_CAR (proc)) && SCM_NULLP (SCM_CDR (proc))))
991 {
992 /* null or single binding, let* is faster */
3a3111a8
MD		 993 return scm_m_letstar (scm_cons2 (SCM_CAR (xorig), proc,
994 scm_m_body (SCM_IM_LET,
995 SCM_CDR (x),
996 s_let)),
26d5b9b4
MD		 997 env);
998 }
999
b8229a3b 1000 SCM_ASSYNT (SCM_NIMP (proc), xorig, scm_s_bindings, s_let);
26d5b9b4
MD		 1001 if (SCM_CONSP (proc))
1002 {
1003 /* plain let, proc is <bindings> */
1004 return scm_m_letrec1 (SCM_IM_LET, SCM_IM_LET, xorig, env);
1005 }
1006
0f2d19dd 1007 if (!SCM_SYMBOLP (proc))
b8229a3b 1008 scm_wta (xorig, scm_s_bindings, s_let); /* bad let */
0f2d19dd
JB		 1009 name = proc; /* named let, build equiv letrec */
1010 x = SCM_CDR (x);
b8229a3b 1011 SCM_ASSYNT (scm_ilength (x) >= 2, xorig, scm_s_body, s_let);
26d5b9b4 1012 proc = SCM_CAR (x); /* bindings list */
b8229a3b 1013 SCM_ASSYNT (scm_ilength (proc) >= 0, xorig, scm_s_bindings, s_let);
ff467021 1014 while (SCM_NIMP (proc))
0f2d19dd
JB		 1015 { /* vars and inits both in order */
1016 arg1 = SCM_CAR (proc);
b8229a3b 1017 SCM_ASSYNT (2 == scm_ilength (arg1), xorig, scm_s_bindings, s_let);
0c95b57d 1018 SCM_ASSYNT (SCM_SYMBOLP (SCM_CAR (arg1)),
b8229a3b 1019 xorig, scm_s_variable, s_let);
0f2d19dd 1020 *varloc = scm_cons (SCM_CAR (arg1), SCM_EOL);
a23afe53 1021 varloc = SCM_CDRLOC (*varloc);
0f2d19dd 1022 *initloc = scm_cons (SCM_CAR (SCM_CDR (arg1)), SCM_EOL);
a23afe53 1023 initloc = SCM_CDRLOC (*initloc);
0f2d19dd
JB		 1024 proc = SCM_CDR (proc);
1025 }
26d5b9b4 1026
2f0d1375 1027 proc = scm_cons2 (scm_sym_lambda, vars,
26d5b9b4 1028 scm_m_body (SCM_IM_LET, SCM_CDR (x), "let"));
2f0d1375 1029 proc = scm_cons2 (scm_sym_let, scm_cons (scm_cons2 (name, proc, SCM_EOL),
26d5b9b4
MD		 1030 SCM_EOL),
1031 scm_acons (name, inits, SCM_EOL));
1032 return scm_m_letrec1 (SCM_IM_LETREC, SCM_IM_LET, proc, env);
0f2d19dd
JB		 1033}
1034
1035
81123e6d
MD		 1036SCM_SYNTAX (s_atapply,"@apply", scm_makmmacro, scm_m_apply);
1037SCM_GLOBAL_SYMBOL (scm_sym_atapply, s_atapply);
1038SCM_GLOBAL_SYMBOL (scm_sym_apply, s_atapply + 1);
1cc91f1b 1039
0f2d19dd 1040SCM
6e8d25a6 1041scm_m_apply (SCM xorig, SCM env)
0f2d19dd 1042{
6cb702da 1043 SCM_ASSYNT (scm_ilength (SCM_CDR (xorig)) == 2,
b8229a3b 1044 xorig, scm_s_expression, s_atapply);
0f2d19dd
JB		 1045 return scm_cons (SCM_IM_APPLY, SCM_CDR (xorig));
1046}
1047
b8229a3b
MS		 1048
1049SCM_SYNTAX(s_atcall_cc,"@call-with-current-continuation", scm_makmmacro, scm_m_cont);
2f0d1375 1050SCM_GLOBAL_SYMBOL(scm_sym_atcall_cc,s_atcall_cc);
0f2d19dd 1051
1cc91f1b 1052
0f2d19dd 1053SCM
6e8d25a6 1054scm_m_cont (SCM xorig, SCM env)
0f2d19dd 1055{
6cb702da 1056 SCM_ASSYNT (scm_ilength (SCM_CDR (xorig)) == 1,
b8229a3b 1057 xorig, scm_s_expression, s_atcall_cc);
3a3111a8 1058 return scm_cons (SCM_IM_CONT, SCM_CDR (xorig));
0f2d19dd
JB		 1059}
1060
73b64342
MD		 1061/* Multi-language support */
1062
1063SCM scm_nil;
1064SCM scm_t;
1065
1066SCM_SYNTAX (s_nil_cond, "nil-cond", scm_makmmacro, scm_m_nil_cond);
1067
1068SCM
1069scm_m_nil_cond (SCM xorig, SCM env)
1070{
1071 int len = scm_ilength (SCM_CDR (xorig));
1072 SCM_ASSYNT (len >= 1 && (len & 1) == 1, xorig,
1073 scm_s_expression, "nil-cond");
1074 return scm_cons (SCM_IM_NIL_COND, SCM_CDR (xorig));
1075}
1076
1077SCM_SYNTAX (s_nil_ify, "nil-ify", scm_makmmacro, scm_m_nil_ify);
1078
1079SCM
1080scm_m_nil_ify (SCM xorig, SCM env)
1081{
1082 SCM_ASSYNT (scm_ilength (SCM_CDR (xorig)) == 1,
1083 xorig, scm_s_expression, "nil-ify");
1084 return scm_cons (SCM_IM_NIL_IFY, SCM_CDR (xorig));
1085}
1086
1087SCM_SYNTAX (s_t_ify, "t-ify", scm_makmmacro, scm_m_t_ify);
1088
1089SCM
1090scm_m_t_ify (SCM xorig, SCM env)
1091{
1092 SCM_ASSYNT (scm_ilength (SCM_CDR (xorig)) == 1,
1093 xorig, scm_s_expression, "t-ify");
1094 return scm_cons (SCM_IM_T_IFY, SCM_CDR (xorig));
1095}
1096
1097SCM_SYNTAX (s_0_cond, "0-cond", scm_makmmacro, scm_m_0_cond);
1098
1099SCM
1100scm_m_0_cond (SCM xorig, SCM env)
1101{
1102 int len = scm_ilength (SCM_CDR (xorig));
1103 SCM_ASSYNT (len >= 1 && (len & 1) == 1, xorig,
1104 scm_s_expression, "0-cond");
1105 return scm_cons (SCM_IM_0_COND, SCM_CDR (xorig));
1106}
1107
1108SCM_SYNTAX (s_0_ify, "0-ify", scm_makmmacro, scm_m_0_ify);
1109
1110SCM
1111scm_m_0_ify (SCM xorig, SCM env)
1112{
1113 SCM_ASSYNT (scm_ilength (SCM_CDR (xorig)) == 1,
1114 xorig, scm_s_expression, "0-ify");
1115 return scm_cons (SCM_IM_0_IFY, SCM_CDR (xorig));
1116}
1117
1118SCM_SYNTAX (s_1_ify, "1-ify", scm_makmmacro, scm_m_1_ify);
1119
1120SCM
1121scm_m_1_ify (SCM xorig, SCM env)
1122{
1123 SCM_ASSYNT (scm_ilength (SCM_CDR (xorig)) == 1,
1124 xorig, scm_s_expression, "1-ify");
1125 return scm_cons (SCM_IM_1_IFY, SCM_CDR (xorig));
1126}
1127
1128SCM_SYNTAX (s_atfop, "@fop", scm_makmmacro, scm_m_atfop);
1129
1130SCM
1131scm_m_atfop (SCM xorig, SCM env)
1132{
1133 SCM x = SCM_CDR (xorig), vcell;
1134 SCM_ASSYNT (scm_ilength (x) >= 1, xorig, scm_s_expression, "@fop");
1135 vcell = scm_symbol_fref (SCM_CAR (x));
0c95b57d 1136 SCM_ASSYNT (SCM_CONSP (vcell), x,
73b64342
MD		 1137 "Symbol's function definition is void", NULL);
1138 SCM_SETCAR (x, vcell + 1);
1139 return x;
1140}
1141
1142SCM_SYNTAX (s_atbind, "@bind", scm_makmmacro, scm_m_atbind);
1143
1144SCM
1145scm_m_atbind (SCM xorig, SCM env)
1146{
1147 SCM x = SCM_CDR (xorig);
1148 SCM_ASSYNT (scm_ilength (x) > 1, xorig, scm_s_expression, "@bind");
1149
1150 if (SCM_IMP (env))
1151 env = SCM_BOOL_F;
1152 else
1153 {
1154 while (SCM_NIMP (SCM_CDR (env)))
1155 env = SCM_CDR (env);
1156 env = SCM_CAR (env);
1157 if (SCM_CONSP (env))
1158 env = SCM_BOOL_F;
1159 }
1160
1161 x = SCM_CAR (x);
1162 while (SCM_NIMP (x))
1163 {
1164 SCM_SETCAR (x, scm_sym2vcell (SCM_CAR (x), env, SCM_BOOL_T) + 1);
1165 x = SCM_CDR (x);
1166 }
1167 return scm_cons (SCM_IM_BIND, SCM_CDR (xorig));
1168}
73b64342 1169
26d5b9b4
MD		 1170SCM
1171scm_m_expand_body (SCM xorig, SCM env)
1172{
1173 SCM form, x = SCM_CDR (xorig), defs = SCM_EOL;
1174 char *what = SCM_ISYMCHARS (SCM_CAR (xorig)) + 2;
1175
1176 while (SCM_NIMP (x))
1177 {
1178 form = SCM_CAR (x);
1179 if (SCM_IMP (form) || SCM_NCONSP (form))
1180 break;
1181 if (SCM_IMP (SCM_CAR (form)))
1182 break;
1183 if (!SCM_SYMBOLP (SCM_CAR (form)))
1184 break;
1185
3a3111a8
MD		 1186 form = scm_macroexp (scm_cons_source (form,
1187 SCM_CAR (form),
1188 SCM_CDR (form)),
1189 env);
26d5b9b4
MD		 1190
1191 if (SCM_IM_DEFINE == SCM_CAR (form))
1192 {
1193 defs = scm_cons (SCM_CDR (form), defs);
1194 x = SCM_CDR(x);
1195 }
1196 else if (SCM_NIMP(defs))
1197 {
1198 break;
1199 }
1200 else if (SCM_IM_BEGIN == SCM_CAR (form))
1201 {
1202 x = scm_append (scm_cons2 (SCM_CDR (form), SCM_CDR (x), SCM_EOL));
1203 }
1204 else
1205 {
1206 x = scm_cons (form, SCM_CDR(x));
1207 break;
1208 }
1209 }
1210
1211 SCM_ASSYNT (SCM_NIMP (x), SCM_CDR (xorig), scm_s_body, what);
1212 if (SCM_NIMP (defs))
1213 {
1214 x = scm_cons (scm_m_letrec1 (SCM_IM_LETREC,
1215 SCM_IM_DEFINE,
2f0d1375 1216 scm_cons2 (scm_sym_define, defs, x),
26d5b9b4
MD		 1217 env),
1218 SCM_EOL);
1219 }
1220
1221 SCM_DEFER_INTS;
1222 SCM_SETCAR (xorig, SCM_CAR (x));
1223 SCM_SETCDR (xorig, SCM_CDR (x));
1224 SCM_ALLOW_INTS;
1225
1226 return xorig;
1227}
1228
1229SCM
1230scm_macroexp (SCM x, SCM env)
1231{
1232 SCM res, proc;
1233
1234 /* Don't bother to produce error messages here. We get them when we
1235 eventually execute the code for real. */
1236
1237 macro_tail:
1238 if (SCM_IMP (SCM_CAR (x)) || !SCM_SYMBOLP (SCM_CAR (x)))
1239 return x;
1240
1241#ifdef USE_THREADS
1242 {
1243 SCM *proc_ptr = scm_lookupcar1 (x, env, 0);
1244 if (proc_ptr == NULL)
1245 {
1246 /* We have lost the race. */
1247 goto macro_tail;
1248 }
1249 proc = *proc_ptr;
1250 }
1251#else
1252 proc = *scm_lookupcar (x, env, 0);
1253#endif
1254
1255 /* Only handle memoizing macros. `Acros' and `macros' are really
1256 special forms and should not be evaluated here. */
1257
1258 if (SCM_IMP (proc)
1259 || scm_tc16_macro != SCM_TYP16 (proc)
1260 || (int) (SCM_CAR (proc) >> 16) != 2)
1261 return x;
1262
1263 unmemocar (x, env);
1264 res = scm_apply (SCM_CDR (proc), x, scm_cons (env, scm_listofnull));
1265
1266 if (scm_ilength (res) <= 0)
1267 res = scm_cons2 (SCM_IM_BEGIN, res, SCM_EOL);
1268
26d5b9b4
MD		 1269 SCM_DEFER_INTS;
1270 SCM_SETCAR (x, SCM_CAR (res));
1271 SCM_SETCDR (x, SCM_CDR (res));
1272 SCM_ALLOW_INTS;
1273
1274 goto macro_tail;
1275}
73b64342 1276
6dbd0af5
MD		 1277/* scm_unmemocopy takes a memoized expression together with its
1278 * environment and rewrites it to its original form. Thus, it is the
1279 * inversion of the rewrite rules above. The procedure is not
1280 * optimized for speed. It's used in scm_iprin1 when printing the
220ff1eb
MD		 1281 * code of a closure, in scm_procedure_source, in display_frame when
1282 * generating the source for a stackframe in a backtrace, and in
1283 * display_expression.
6dbd0af5
MD		 1284 */
1285
26d5b9b4
MD		 1286/* We should introduce an anti-macro interface so that it is possible
1287 * to plug in transformers in both directions from other compilation
1288 * units. unmemocopy could then dispatch to anti-macro transformers.
1289 * (Those transformers could perhaps be written in slightly more
1290 * readable style... :)
1291 */
1292
6dbd0af5 1293static SCM
1bbd0b84 1294unmemocopy (SCM x, SCM env)
6dbd0af5
MD		 1295{
1296 SCM ls, z;
1297#ifdef DEBUG_EXTENSIONS
1298 SCM p;
1299#endif
1300 if (SCM_NCELLP (x) || SCM_NECONSP (x))
1301 return x;
1302#ifdef DEBUG_EXTENSIONS
1303 p = scm_whash_lookup (scm_source_whash, x);
1304#endif
1305 switch (SCM_TYP7 (x))
1306 {
1307 case (127 & SCM_IM_AND):
2f0d1375 1308 ls = z = scm_cons (scm_sym_and, SCM_UNSPECIFIED);
6dbd0af5
MD		 1309 break;
1310 case (127 & SCM_IM_BEGIN):
2f0d1375 1311 ls = z = scm_cons (scm_sym_begin, SCM_UNSPECIFIED);
6dbd0af5
MD		 1312 break;
1313 case (127 & SCM_IM_CASE):
2f0d1375 1314 ls = z = scm_cons (scm_sym_case, SCM_UNSPECIFIED);
6dbd0af5
MD		 1315 break;
1316 case (127 & SCM_IM_COND):
2f0d1375 1317 ls = z = scm_cons (scm_sym_cond, SCM_UNSPECIFIED);
6dbd0af5
MD		 1318 break;
1319 case (127 & SCM_IM_DO):
2f0d1375 1320 ls = scm_cons (scm_sym_do, SCM_UNSPECIFIED);
6dbd0af5
MD		 1321 goto transform;
1322 case (127 & SCM_IM_IF):
2f0d1375 1323 ls = z = scm_cons (scm_sym_if, SCM_UNSPECIFIED);
6dbd0af5
MD		 1324 break;
1325 case (127 & SCM_IM_LET):
2f0d1375 1326 ls = scm_cons (scm_sym_let, SCM_UNSPECIFIED);
6dbd0af5
MD		 1327 goto transform;
1328 case (127 & SCM_IM_LETREC):
1329 {
1330 SCM f, v, e, s;
2f0d1375 1331 ls = scm_cons (scm_sym_letrec, SCM_UNSPECIFIED);
6dbd0af5
MD		 1332 transform:
1333 x = SCM_CDR (x);
26d5b9b4 1334 /* binding names */
6dbd0af5
MD		 1335 f = v = SCM_CAR (x);
1336 x = SCM_CDR (x);
e2806c10 1337 z = EXTEND_ENV (f, SCM_EOL, env);
26d5b9b4 1338 /* inits */
6dbd0af5 1339 e = scm_reverse (unmemocopy (SCM_CAR (x),
2f0d1375 1340 SCM_CAR (ls) == scm_sym_letrec ? z : env));
6dbd0af5 1341 env = z;
26d5b9b4 1342 /* increments */
2f0d1375 1343 s = SCM_CAR (ls) == scm_sym_do
6dbd0af5
MD		 1344 ? scm_reverse (unmemocopy (SCM_CDR (SCM_CDR (SCM_CDR (x))), env))
1345 : f;
26d5b9b4 1346 /* build transformed binding list */
6dbd0af5
MD		 1347 z = SCM_EOL;
1348 do
1349 {
1350 z = scm_acons (SCM_CAR (v),
1351 scm_cons (SCM_CAR (e),
1352 SCM_CAR (s) == SCM_CAR (v)
1353 ? SCM_EOL
1354 : scm_cons (SCM_CAR (s), SCM_EOL)),
1355 z);
1356 v = SCM_CDR (v);
1357 e = SCM_CDR (e);
1358 s = SCM_CDR (s);
1359 }
ff467021 1360 while (SCM_NIMP (v));
a23afe53
MD		 1361 z = scm_cons (z, SCM_UNSPECIFIED);
1362 SCM_SETCDR (ls, z);
2f0d1375 1363 if (SCM_CAR (ls) == scm_sym_do)
6dbd0af5
MD		 1364 {
1365 x = SCM_CDR (x);
26d5b9b4 1366 /* test clause */
a23afe53 1367 SCM_SETCDR (z, scm_cons (unmemocopy (SCM_CAR (x), env),
6dbd0af5 1368 SCM_UNSPECIFIED));
a23afe53
MD		 1369 z = SCM_CDR (z);
1370 x = (SCM) (SCM_CARLOC (SCM_CDR (x)) - 1);
26d5b9b4
MD		 1371 /* body forms are now to be found in SCM_CDR (x)
1372 (this is how *real* code look like! :) */
6dbd0af5
MD		 1373 }
1374 break;
1375 }
1376 case (127 & SCM_IM_LETSTAR):
1377 {
1378 SCM b, y;
1379 x = SCM_CDR (x);
1380 b = SCM_CAR (x);
1381 y = SCM_EOL;
1382 if SCM_IMP (b)
1383 {
e2806c10 1384 env = EXTEND_ENV (SCM_EOL, SCM_EOL, env);
6dbd0af5
MD		 1385 goto letstar;
1386 }
1387 y = z = scm_acons (SCM_CAR (b),
1388 unmemocar (
1389 scm_cons (unmemocopy (SCM_CAR (SCM_CDR (b)), env), SCM_EOL), env),
1390 SCM_UNSPECIFIED);
e2806c10 1391 env = EXTEND_ENV (SCM_CAR (b), SCM_BOOL_F, env);
6dbd0af5
MD		 1392 b = SCM_CDR (SCM_CDR (b));
1393 if (SCM_IMP (b))
1394 {
1395 SCM_SETCDR (y, SCM_EOL);
2f0d1375 1396 ls = scm_cons (scm_sym_let, z = scm_cons (y, SCM_UNSPECIFIED));
6dbd0af5
MD		 1397 break;
1398 }
1399 do
1400 {
a23afe53
MD		 1401 SCM_SETCDR (z, scm_acons (SCM_CAR (b),
1402 unmemocar (
6dbd0af5 1403 scm_cons (unmemocopy (SCM_CAR (SCM_CDR (b)), env), SCM_EOL), env),
a23afe53
MD		 1404 SCM_UNSPECIFIED));
1405 z = SCM_CDR (z);
e2806c10 1406 env = EXTEND_ENV (SCM_CAR (b), SCM_BOOL_F, env);
6dbd0af5
MD		 1407 b = SCM_CDR (SCM_CDR (b));
1408 }
ff467021 1409 while (SCM_NIMP (b));
a23afe53 1410 SCM_SETCDR (z, SCM_EOL);
6dbd0af5 1411 letstar:
2f0d1375 1412 ls = scm_cons (scm_sym_letstar, z = scm_cons (y, SCM_UNSPECIFIED));
6dbd0af5
MD		 1413 break;
1414 }
1415 case (127 & SCM_IM_OR):
2f0d1375 1416 ls = z = scm_cons (scm_sym_or, SCM_UNSPECIFIED);
6dbd0af5
MD		 1417 break;
1418 case (127 & SCM_IM_LAMBDA):
1419 x = SCM_CDR (x);
2f0d1375 1420 ls = scm_cons (scm_sym_lambda,
6dbd0af5 1421 z = scm_cons (SCM_CAR (x), SCM_UNSPECIFIED));
e2806c10 1422 env = EXTEND_ENV (SCM_CAR (x), SCM_EOL, env);
6dbd0af5
MD		 1423 break;
1424 case (127 & SCM_IM_QUOTE):
2f0d1375 1425 ls = z = scm_cons (scm_sym_quote, SCM_UNSPECIFIED);
6dbd0af5 1426 break;
89efbff4
MD		 1427 case (127 & SCM_IM_SET_X):
1428 ls = z = scm_cons (scm_sym_set_x, SCM_UNSPECIFIED);
6dbd0af5
MD		 1429 break;
1430 case (127 & SCM_IM_DEFINE):
1431 {
1432 SCM n;
1433 x = SCM_CDR (x);
2f0d1375 1434 ls = scm_cons (scm_sym_define,
6dbd0af5
MD		 1435 z = scm_cons (n = SCM_CAR (x), SCM_UNSPECIFIED));
1436 if (SCM_NNULLP (env))
a23afe53 1437 SCM_SETCAR (SCM_CAR (env), scm_cons (n, SCM_CAR (SCM_CAR (env))));
6dbd0af5
MD		 1438 break;
1439 }
1440 case (127 & SCM_MAKISYM (0)):
1441 z = SCM_CAR (x);
1442 if (!SCM_ISYMP (z))
1443 goto unmemo;
ff467021 1444 switch (SCM_ISYMNUM (z))
6dbd0af5
MD		 1445 {
1446 case (SCM_ISYMNUM (SCM_IM_APPLY)):
2f0d1375 1447 ls = z = scm_cons (scm_sym_atapply, SCM_UNSPECIFIED);
6dbd0af5
MD		 1448 goto loop;
1449 case (SCM_ISYMNUM (SCM_IM_CONT)):
2f0d1375 1450 ls = z = scm_cons (scm_sym_atcall_cc, SCM_UNSPECIFIED);
6dbd0af5 1451 goto loop;
a570e93a
MD		 1452 case (SCM_ISYMNUM (SCM_IM_DELAY)):
1453 ls = z = scm_cons (scm_sym_delay, SCM_UNSPECIFIED);
1454 x = SCM_CDR (x);
1455 goto loop;
6dbd0af5 1456 default:
fa888178 1457 /* appease the Sun compiler god: */ ;
6dbd0af5
MD		 1458 }
1459 unmemo:
1460 default:
1461 ls = z = unmemocar (scm_cons (unmemocopy (SCM_CAR (x), env),
1462 SCM_UNSPECIFIED),
1463 env);
1464 }
1465loop:
1466 while (SCM_CELLP (x = SCM_CDR (x)) && SCM_ECONSP (x))
a23afe53 1467 {
26d5b9b4
MD		 1468 if (SCM_IMP (SCM_CAR (x)) && SCM_ISYMP (SCM_CAR (x)))
1469 /* skip body markers */
1470 continue;
a23afe53
MD		 1471 SCM_SETCDR (z, unmemocar (scm_cons (unmemocopy (SCM_CAR (x), env),
1472 SCM_UNSPECIFIED),
1473 env));
1474 z = SCM_CDR (z);
1475 }
1476 SCM_SETCDR (z, x);
6dbd0af5
MD		 1477#ifdef DEBUG_EXTENSIONS
1478 if (SCM_NFALSEP (p))
1479 scm_whash_insert (scm_source_whash, ls, p);
1480#endif
1481 return ls;
1482}
1483
1cc91f1b 1484
6dbd0af5 1485SCM
6e8d25a6 1486scm_unmemocopy (SCM x, SCM env)
6dbd0af5
MD		 1487{
1488 if (SCM_NNULLP (env))
1489 /* Make a copy of the lowest frame to protect it from
1490 modifications by SCM_IM_DEFINE */
1491 return unmemocopy (x, scm_cons (SCM_CAR (env), SCM_CDR (env)));
1492 else
1493 return unmemocopy (x, env);
1494}
1495
cf7c17e9 1496#ifndef SCM_RECKLESS
1cc91f1b 1497
0f2d19dd 1498int
6e8d25a6 1499scm_badargsp (SCM formals, SCM args)
0f2d19dd 1500{
ff467021 1501 while (SCM_NIMP (formals))
0f2d19dd 1502 {
ff467021
JB		 1503 if (SCM_NCONSP (formals))
1504 return 0;
1505 if (SCM_IMP(args))
1506 return 1;
0f2d19dd
JB		 1507 formals = SCM_CDR (formals);
1508 args = SCM_CDR (args);
1509 }
1510 return SCM_NNULLP (args) ? 1 : 0;
1511}
1512#endif
1513
1514
1515\f
6dbd0af5 1516SCM
6e8d25a6 1517scm_eval_args (SCM l, SCM env, SCM proc)
6dbd0af5 1518{
680ed4a8 1519 SCM results = SCM_EOL, *lloc = &results, res;
6dbd0af5
MD		 1520 while (SCM_NIMP (l))
1521 {
cf7c17e9 1522#ifdef SCM_CAUTIOUS
680ed4a8
MD		 1523 if (SCM_IMP (l))
1524 goto wrongnumargs;
1525 else if (SCM_CONSP (l))
1526 {
1527 if (SCM_IMP (SCM_CAR (l)))
6cb702da 1528 res = SCM_EVALIM (SCM_CAR (l), env);
680ed4a8
MD		 1529 else
1530 res = EVALCELLCAR (l, env);
1531 }
1532 else if (SCM_TYP3 (l) == 1)
1533 {
1534 if ((res = SCM_GLOC_VAL (SCM_CAR (l))) == 0)
1535 res = SCM_CAR (l); /* struct planted in code */
1536 }
1537 else
1538 goto wrongnumargs;
1539#else
1540 res = EVALCAR (l, env);
1541#endif
1542 *lloc = scm_cons (res, SCM_EOL);
a23afe53 1543 lloc = SCM_CDRLOC (*lloc);
6dbd0af5
MD		 1544 l = SCM_CDR (l);
1545 }
cf7c17e9 1546#ifdef SCM_CAUTIOUS
680ed4a8
MD		 1547 if (SCM_NNULLP (l))
1548 {
1549 wrongnumargs:
1550 scm_wrong_num_args (proc);
1551 }
1552#endif
1553 return results;
6dbd0af5 1554}
c4ac4d88 1555
9de33deb
MD		 1556SCM
1557scm_eval_body (SCM code, SCM env)
1558{
1559 SCM next;
1560 again:
1561 next = code;
1562 while (SCM_NNULLP (next = SCM_CDR (next)))
1563 {
1564 if (SCM_IMP (SCM_CAR (code)))
1565 {
1566 if (SCM_ISYMP (SCM_CAR (code)))
1567 {
1568 code = scm_m_expand_body (code, env);
1569 goto again;
1570 }
1571 }
1572 else
1573 SCM_XEVAL (SCM_CAR (code), env);
1574 code = next;
1575 }
1576 return SCM_XEVALCAR (code, env);
1577}
1578
c4ac4d88 1579
0f2d19dd
JB		 1580#endif /* !DEVAL */
1581
6dbd0af5
MD		 1582
1583/* SECTION: This code is specific for the debugging support. One
1584 * branch is read when DEVAL isn't defined, the other when DEVAL is
1585 * defined.
1586 */
1587
1588#ifndef DEVAL
1589
1590#define SCM_APPLY scm_apply
1591#define PREP_APPLY(proc, args)
1592#define ENTER_APPLY
1593#define RETURN(x) return x;
b7ff98dd
MD		 1594#ifdef STACK_CHECKING
1595#ifndef NO_CEVAL_STACK_CHECKING
1596#define EVAL_STACK_CHECKING
1597#endif
6dbd0af5
MD		 1598#endif
1599
1600#else /* !DEVAL */
1601
0f2d19dd
JB		 1602#undef SCM_CEVAL
1603#define SCM_CEVAL scm_deval /* Substitute all uses of scm_ceval */
1604#undef SCM_APPLY
1605#define SCM_APPLY scm_dapply
6dbd0af5
MD		 1606#undef PREP_APPLY
1607#define PREP_APPLY(p, l) \
1608{ ++debug.info; debug.info->a.proc = p; debug.info->a.args = l; }
1609#undef ENTER_APPLY
1610#define ENTER_APPLY \
d3a6bc94 1611do { \
b7ff98dd 1612 SCM_SET_ARGSREADY (debug);\
b6d75948 1613 if (CHECK_APPLY && SCM_TRAPS_P)\
b7ff98dd 1614 if (SCM_APPLY_FRAME_P || (SCM_TRACE_P && PROCTRACEP (proc)))\
6dbd0af5 1615 {\
156dcb09 1616 SCM tmp, tail = SCM_BOOL(SCM_TRACED_FRAME_P (debug)); \
c6a4fbce 1617 SCM_SET_TRACED_FRAME (debug); \
b7ff98dd 1618 if (SCM_CHEAPTRAPS_P)\
6dbd0af5 1619 {\
c0ab1b8d 1620 tmp = scm_make_debugobj (&debug);\
2f0d1375 1621 scm_ithrow (scm_sym_apply_frame, scm_cons2 (tmp, tail, SCM_EOL), 0);\
b6d75948 1622 }\
6dbd0af5
MD		 1623 else\
1624 {\
1625 scm_make_cont (&tmp);\
ca6ef71a 1626 if (!setjmp (SCM_JMPBUF (tmp)))\
2f0d1375 1627 scm_ithrow (scm_sym_apply_frame, scm_cons2 (tmp, tail, SCM_EOL), 0);\
6dbd0af5
MD		 1628 }\
1629 }\
d3a6bc94 1630} while (0)
0f2d19dd
JB		 1631#undef RETURN
1632#define RETURN(e) {proc = (e); goto exit;}
b7ff98dd
MD		 1633#ifdef STACK_CHECKING
1634#ifndef EVAL_STACK_CHECKING
1635#define EVAL_STACK_CHECKING
1636#endif
6dbd0af5
MD		 1637#endif
1638
1639/* scm_ceval_ptr points to the currently selected evaluator.
1640 * *fixme*: Although efficiency is important here, this state variable
1641 * should probably not be a global. It should be related to the
1642 * current repl.
1643 */
1644
1cc91f1b 1645
1bbd0b84 1646SCM (*scm_ceval_ptr) (SCM x, SCM env);
0f2d19dd 1647
1646d37b 1648/* scm_last_debug_frame contains a pointer to the last debugging
6dbd0af5
MD		 1649 * information stack frame. It is accessed very often from the
1650 * debugging evaluator, so it should probably not be indirectly
1651 * addressed. Better to save and restore it from the current root at
1652 * any stack swaps.
1653 */
1654
1646d37b
MD		 1655#ifndef USE_THREADS
1656scm_debug_frame *scm_last_debug_frame;
1657#endif
6dbd0af5
MD		 1658
1659/* scm_debug_eframe_size is the number of slots available for pseudo
1660 * stack frames at each real stack frame.
1661 */
1662
1663int scm_debug_eframe_size;
1664
b7ff98dd 1665int scm_debug_mode, scm_check_entry_p, scm_check_apply_p, scm_check_exit_p;
6dbd0af5 1666
a74145b8
MD		 1667int scm_eval_stack;
1668
33b97402 1669scm_option scm_eval_opts[] = {
a74145b8 1670 { SCM_OPTION_INTEGER, "stack", 22000, "Size of thread stacks (in machine words)." }
33b97402
MD		 1671};
1672
6dbd0af5 1673scm_option scm_debug_opts[] = {
b7ff98dd
MD		 1674 { SCM_OPTION_BOOLEAN, "cheap", 1,
1675 "*Flyweight representation of the stack at traps." },
1676 { SCM_OPTION_BOOLEAN, "breakpoints", 0, "*Check for breakpoints." },
1677 { SCM_OPTION_BOOLEAN, "trace", 0, "*Trace mode." },
1678 { SCM_OPTION_BOOLEAN, "procnames", 1,
1679 "Record procedure names at definition." },
1680 { SCM_OPTION_BOOLEAN, "backwards", 0,
1681 "Display backtrace in anti-chronological order." },
274dc5fd 1682 { SCM_OPTION_INTEGER, "width", 79, "Maximal width of backtrace." },
4e646a03
MD		 1683 { SCM_OPTION_INTEGER, "indent", 10, "Maximal indentation in backtrace." },
1684 { SCM_OPTION_INTEGER, "frames", 3,
b7ff98dd 1685 "Maximum number of tail-recursive frames in backtrace." },
4e646a03
MD		 1686 { SCM_OPTION_INTEGER, "maxdepth", 1000,
1687 "Maximal number of stored backtrace frames." },
1688 { SCM_OPTION_INTEGER, "depth", 20, "Maximal length of printed backtrace." },
11f77bfc
MD		 1689 { SCM_OPTION_BOOLEAN, "backtrace", 0, "Show backtrace on error." },
1690 { SCM_OPTION_BOOLEAN, "debug", 0, "Use the debugging evaluator." },
a74145b8 1691 { SCM_OPTION_INTEGER, "stack", 20000, "Stack size limit (measured in words; 0 = no check)." }
6dbd0af5
MD		 1692};
1693
1694scm_option scm_evaluator_trap_table[] = {
b6d75948 1695 { SCM_OPTION_BOOLEAN, "traps", 0, "Enable evaluator traps." },
b7ff98dd
MD		 1696 { SCM_OPTION_BOOLEAN, "enter-frame", 0, "Trap when eval enters new frame." },
1697 { SCM_OPTION_BOOLEAN, "apply-frame", 0, "Trap when entering apply." },
1698 { SCM_OPTION_BOOLEAN, "exit-frame", 0, "Trap when exiting eval or apply." }
6dbd0af5
MD		 1699};
1700
1bbd0b84
GB		 1701GUILE_PROC (scm_eval_options_interface, "eval-options-interface", 0, 1, 0,
1702 (SCM setting),
1703"")
1704#define FUNC_NAME s_scm_eval_options_interface
33b97402
MD		 1705{
1706 SCM ans;
1707 SCM_DEFER_INTS;
1708 ans = scm_options (setting,
1709 scm_eval_opts,
1710 SCM_N_EVAL_OPTIONS,
1bbd0b84 1711 FUNC_NAME);
a74145b8 1712 scm_eval_stack = SCM_EVAL_STACK * sizeof (void *);
33b97402
MD		 1713 SCM_ALLOW_INTS;
1714 return ans;
1715}
1bbd0b84 1716#undef FUNC_NAME
33b97402 1717
1bbd0b84
GB		 1718GUILE_PROC (scm_evaluator_traps, "evaluator-traps-interface", 0, 1, 0,
1719 (SCM setting),
1720"")
1721#define FUNC_NAME s_scm_evaluator_traps
33b97402
MD		 1722{
1723 SCM ans;
1724 SCM_DEFER_INTS;
1725 ans = scm_options (setting,
1726 scm_evaluator_trap_table,
1727 SCM_N_EVALUATOR_TRAPS,
1bbd0b84 1728 FUNC_NAME);
33b97402 1729 SCM_RESET_DEBUG_MODE;
bfc69694 1730 SCM_ALLOW_INTS;
33b97402
MD		 1731 return ans;
1732}
1bbd0b84 1733#undef FUNC_NAME
33b97402 1734
6dbd0af5 1735SCM
6e8d25a6 1736scm_deval_args (SCM l, SCM env, SCM proc, SCM *lloc)
0f2d19dd 1737{
680ed4a8 1738 SCM *results = lloc, res;
0f2d19dd
JB		 1739 while (SCM_NIMP (l))
1740 {
cf7c17e9 1741#ifdef SCM_CAUTIOUS
680ed4a8
MD		 1742 if (SCM_IMP (l))
1743 goto wrongnumargs;
1744 else if (SCM_CONSP (l))
1745 {
1746 if (SCM_IMP (SCM_CAR (l)))
6cb702da 1747 res = SCM_EVALIM (SCM_CAR (l), env);
680ed4a8
MD		 1748 else
1749 res = EVALCELLCAR (l, env);
1750 }
1751 else if (SCM_TYP3 (l) == 1)
1752 {
1753 if ((res = SCM_GLOC_VAL (SCM_CAR (l))) == 0)
1754 res = SCM_CAR (l); /* struct planted in code */
1755 }
1756 else
1757 goto wrongnumargs;
1758#else
1759 res = EVALCAR (l, env);
1760#endif
1761 *lloc = scm_cons (res, SCM_EOL);
a23afe53 1762 lloc = SCM_CDRLOC (*lloc);
0f2d19dd
JB		 1763 l = SCM_CDR (l);
1764 }
cf7c17e9 1765#ifdef SCM_CAUTIOUS
680ed4a8
MD		 1766 if (SCM_NNULLP (l))
1767 {
1768 wrongnumargs:
1769 scm_wrong_num_args (proc);
1770 }
1771#endif
1772 return *results;
0f2d19dd
JB		 1773}
1774
6dbd0af5
MD		 1775#endif /* !DEVAL */
1776
1777
1778/* SECTION: Some local definitions for the evaluator.
1779 */
1780
1781#ifndef DEVAL
1782#ifdef SCM_FLOATS
1783#define CHECK_EQVISH(A,B) (((A) == (B)) || (SCM_NFALSEP (scm_eqv_p ((A), (B)))))
1784#else
1785#define CHECK_EQVISH(A,B) ((A) == (B))
1786#endif
1787#endif /* DEVAL */
1788
399dedcc 1789#define BUILTIN_RPASUBR /* Handle rpsubrs and asubrs without calling apply */
6dbd0af5
MD		 1790
1791/* SECTION: This is the evaluator. Like any real monster, it has
1792 * three heads. This code is compiled twice.
1793 */
1794
0f2d19dd 1795#if 0
1cc91f1b 1796
0f2d19dd 1797SCM
1bbd0b84 1798scm_ceval (SCM x, SCM env)
0f2d19dd
JB		 1799{}
1800#endif
1801#if 0
1cc91f1b 1802
0f2d19dd 1803SCM
1bbd0b84 1804scm_deval (SCM x, SCM env)
0f2d19dd
JB		 1805{}
1806#endif
1807
6dbd0af5 1808SCM
1bbd0b84 1809SCM_CEVAL (SCM x, SCM env)
0f2d19dd
JB		 1810{
1811 union
1812 {
1813 SCM *lloc;
1814 SCM arg1;
f8769b1d 1815 } t;
6dbd0af5
MD		 1816 SCM proc, arg2;
1817#ifdef DEVAL
c0ab1b8d
JB		 1818 scm_debug_frame debug;
1819 scm_debug_info *debug_info_end;
1646d37b 1820 debug.prev = scm_last_debug_frame;
6dbd0af5 1821 debug.status = scm_debug_eframe_size;
04b6c081
MD		 1822 /*
1823 * The debug.vect contains twice as much scm_debug_info frames as the
1824 * user has specified with (debug-set! frames <n>).
1825 *
1826 * Even frames are eval frames, odd frames are apply frames.
1827 */
c0ab1b8d
JB		 1828 debug.vect = (scm_debug_info *) alloca (scm_debug_eframe_size
1829 * sizeof (debug.vect[0]));
1830 debug.info = debug.vect;
1831 debug_info_end = debug.vect + scm_debug_eframe_size;
1832 scm_last_debug_frame = &debug;
6dbd0af5 1833#endif
b7ff98dd
MD		 1834#ifdef EVAL_STACK_CHECKING
1835 if (SCM_STACK_OVERFLOW_P ((SCM_STACKITEM *) &proc)
1836 && scm_stack_checking_enabled_p)
6dbd0af5 1837 {
b7ff98dd 1838#ifdef DEVAL
6dbd0af5
MD		 1839 debug.info->e.exp = x;
1840 debug.info->e.env = env;
b7ff98dd 1841#endif
6dbd0af5
MD		 1842 scm_report_stack_overflow ();
1843 }
1844#endif
1845#ifdef DEVAL
1846 goto start;
1847#endif
1848loopnoap:
1849 PREP_APPLY (SCM_UNDEFINED, SCM_EOL);
1850loop:
1851#ifdef DEVAL
b7ff98dd
MD		 1852 SCM_CLEAR_ARGSREADY (debug);
1853 if (SCM_OVERFLOWP (debug))
6dbd0af5 1854 --debug.info;
04b6c081
MD		 1855 /*
1856 * In theory, this should be the only place where it is necessary to
1857 * check for space in debug.vect since both eval frames and
1858 * available space are even.
1859 *
1860 * For this to be the case, however, it is necessary that primitive
1861 * special forms which jump back to `loop', `begin' or some similar
1862 * label call PREP_APPLY. A convenient way to do this is to jump to
1863 * `loopnoap' or `cdrxnoap'.
1864 */
c0ab1b8d 1865 else if (++debug.info >= debug_info_end)
6dbd0af5 1866 {
b7ff98dd 1867 SCM_SET_OVERFLOW (debug);
6dbd0af5
MD		 1868 debug.info -= 2;
1869 }
1870start:
1871 debug.info->e.exp = x;
1872 debug.info->e.env = env;
b6d75948 1873 if (CHECK_ENTRY && SCM_TRAPS_P)
b7ff98dd 1874 if (SCM_ENTER_FRAME_P || (SCM_BREAKPOINTS_P && SRCBRKP (x)))
6dbd0af5 1875 {
156dcb09 1876 SCM tail = SCM_BOOL(SCM_TAILRECP (debug));
b7ff98dd 1877 SCM_SET_TAILREC (debug);
b7ff98dd 1878 if (SCM_CHEAPTRAPS_P)
c0ab1b8d 1879 t.arg1 = scm_make_debugobj (&debug);
6dbd0af5
MD		 1880 else
1881 {
1882 scm_make_cont (&t.arg1);
ca6ef71a 1883 if (setjmp (SCM_JMPBUF (t.arg1)))
6dbd0af5
MD		 1884 {
1885 x = SCM_THROW_VALUE (t.arg1);
1886 if (SCM_IMP (x))
1887 {
1888 RETURN (x);
1889 }
1890 else
1891 /* This gives the possibility for the debugger to
1892 modify the source expression before evaluation. */
1893 goto dispatch;
1894 }
1895 }
2f0d1375 1896 scm_ithrow (scm_sym_enter_frame,
6dbd0af5
MD		 1897 scm_cons2 (t.arg1, tail,
1898 scm_cons (scm_unmemocopy (x, env), SCM_EOL)),
1899 0);
1900 }
6dbd0af5 1901#endif
e3173f93 1902#if defined (USE_THREADS) || defined (DEVAL)
f8769b1d 1903dispatch:
e3173f93 1904#endif
9cb5124f 1905 SCM_TICK;
0f2d19dd
JB		 1906 switch (SCM_TYP7 (x))
1907 {
1908 case scm_tcs_symbols:
1909 /* Only happens when called at top level.
1910 */
1911 x = scm_cons (x, SCM_UNDEFINED);
1912 goto retval;
1913
1914 case (127 & SCM_IM_AND):
1915 x = SCM_CDR (x);
1916 t.arg1 = x;
1917 while (SCM_NNULLP (t.arg1 = SCM_CDR (t.arg1)))
1918 if (SCM_FALSEP (EVALCAR (x, env)))
1919 {
1920 RETURN (SCM_BOOL_F);
1921 }
1922 else
1923 x = t.arg1;
6dbd0af5 1924 PREP_APPLY (SCM_UNDEFINED, SCM_EOL);
0f2d19dd
JB		 1925 goto carloop;
1926
1927 case (127 & SCM_IM_BEGIN):
6dbd0af5
MD		 1928 cdrxnoap:
1929 PREP_APPLY (SCM_UNDEFINED, SCM_EOL);
0f2d19dd
JB		 1930 cdrxbegin:
1931 x = SCM_CDR (x);
1932
1933 begin:
1934 t.arg1 = x;
1935 while (SCM_NNULLP (t.arg1 = SCM_CDR (t.arg1)))
1936 {
26d5b9b4
MD		 1937 if (SCM_IMP (SCM_CAR (x)))
1938 {
1939 if (SCM_ISYMP (SCM_CAR (x)))
1940 {
1941 x = scm_m_expand_body (x, env);
1942 goto begin;
1943 }
1944 }
1945 else
1946 SCM_CEVAL (SCM_CAR (x), env);
0f2d19dd
JB		 1947 x = t.arg1;
1948 }
1949
1950 carloop: /* scm_eval car of last form in list */
1951 if (SCM_NCELLP (SCM_CAR (x)))
1952 {
1953 x = SCM_CAR (x);
6cb702da 1954 RETURN (SCM_IMP (x) ? SCM_EVALIM (x, env) : SCM_GLOC_VAL (x))
0f2d19dd
JB		 1955 }
1956
1957 if (SCM_SYMBOLP (SCM_CAR (x)))
1958 {
1959 retval:
26d5b9b4 1960 RETURN (*scm_lookupcar (x, env, 1))
0f2d19dd
JB		 1961 }
1962
1963 x = SCM_CAR (x);
1964 goto loop; /* tail recurse */
1965
1966
1967 case (127 & SCM_IM_CASE):
1968 x = SCM_CDR (x);
1969 t.arg1 = EVALCAR (x, env);
1970 while (SCM_NIMP (x = SCM_CDR (x)))
1971 {
1972 proc = SCM_CAR (x);
2f0d1375 1973 if (scm_sym_else == SCM_CAR (proc))
0f2d19dd
JB		 1974 {
1975 x = SCM_CDR (proc);
6dbd0af5 1976 PREP_APPLY (SCM_UNDEFINED, SCM_EOL);
0f2d19dd
JB		 1977 goto begin;
1978 }
1979 proc = SCM_CAR (proc);
1980 while (SCM_NIMP (proc))
1981 {
1982 if (CHECK_EQVISH (SCM_CAR (proc), t.arg1))
1983 {
1984 x = SCM_CDR (SCM_CAR (x));
6dbd0af5 1985 PREP_APPLY (SCM_UNDEFINED, SCM_EOL);
0f2d19dd
JB		 1986 goto begin;
1987 }
1988 proc = SCM_CDR (proc);
1989 }
1990 }
6dbd0af5 1991 RETURN (SCM_UNSPECIFIED)
0f2d19dd
JB		 1992
1993
1994 case (127 & SCM_IM_COND):
1995 while (SCM_NIMP (x = SCM_CDR (x)))
1996 {
1997 proc = SCM_CAR (x);
1998 t.arg1 = EVALCAR (proc, env);
1999 if (SCM_NFALSEP (t.arg1))
2000 {
2001 x = SCM_CDR (proc);
6dbd0af5 2002 if SCM_NULLP (x)
0f2d19dd 2003 {
6dbd0af5 2004 RETURN (t.arg1)
0f2d19dd 2005 }
2f0d1375 2006 if (scm_sym_arrow != SCM_CAR (x))
6dbd0af5
MD		 2007 {
2008 PREP_APPLY (SCM_UNDEFINED, SCM_EOL);
2009 goto begin;
2010 }
0f2d19dd
JB		 2011 proc = SCM_CDR (x);
2012 proc = EVALCAR (proc, env);
2013 SCM_ASRTGO (SCM_NIMP (proc), badfun);
6dbd0af5
MD		 2014 PREP_APPLY (proc, scm_cons (t.arg1, SCM_EOL));
2015 ENTER_APPLY;
0f2d19dd
JB		 2016 goto evap1;
2017 }
2018 }
6dbd0af5 2019 RETURN (SCM_UNSPECIFIED)
0f2d19dd
JB		 2020
2021
2022 case (127 & SCM_IM_DO):
2023 x = SCM_CDR (x);
2024 proc = SCM_CAR (SCM_CDR (x)); /* inits */
2025 t.arg1 = SCM_EOL; /* values */
2026 while (SCM_NIMP (proc))
2027 {
2028 t.arg1 = scm_cons (EVALCAR (proc, env), t.arg1);
2029 proc = SCM_CDR (proc);
2030 }
e2806c10 2031 env = EXTEND_ENV (SCM_CAR (x), t.arg1, env);
0f2d19dd
JB		 2032 x = SCM_CDR (SCM_CDR (x));
2033 while (proc = SCM_CAR (x), SCM_FALSEP (EVALCAR (proc, env)))
2034 {
f3d2630a 2035 for (proc = SCM_CADR (x); SCM_NIMP (proc); proc = SCM_CDR (proc))
0f2d19dd
JB		 2036 {
2037 t.arg1 = SCM_CAR (proc); /* body */
2038 SIDEVAL (t.arg1, env);
2039 }
f3d2630a
MD		 2040 for (t.arg1 = SCM_EOL, proc = SCM_CDDR (x);
2041 SCM_NIMP (proc);
2042 proc = SCM_CDR (proc))
0f2d19dd 2043 t.arg1 = scm_cons (EVALCAR (proc, env), t.arg1); /* steps */
e2806c10 2044 env = EXTEND_ENV (SCM_CAR (SCM_CAR (env)), t.arg1, SCM_CDR (env));
0f2d19dd
JB		 2045 }
2046 x = SCM_CDR (proc);
2047 if (SCM_NULLP (x))
6dbd0af5
MD		 2048 RETURN (SCM_UNSPECIFIED);
2049 PREP_APPLY (SCM_UNDEFINED, SCM_EOL);
0f2d19dd
JB		 2050 goto begin;
2051
2052
2053 case (127 & SCM_IM_IF):
2054 x = SCM_CDR (x);
2055 if (SCM_NFALSEP (EVALCAR (x, env)))
2056 x = SCM_CDR (x);
2057 else if (SCM_IMP (x = SCM_CDR (SCM_CDR (x))))
2058 {
2059 RETURN (SCM_UNSPECIFIED);
2060 }
6dbd0af5 2061 PREP_APPLY (SCM_UNDEFINED, SCM_EOL);
0f2d19dd
JB		 2062 goto carloop;
2063
2064
2065 case (127 & SCM_IM_LET):
2066 x = SCM_CDR (x);
2067 proc = SCM_CAR (SCM_CDR (x));
2068 t.arg1 = SCM_EOL;
2069 do
2070 {
2071 t.arg1 = scm_cons (EVALCAR (proc, env), t.arg1);
2072 }
2073 while (SCM_NIMP (proc = SCM_CDR (proc)));
e2806c10 2074 env = EXTEND_ENV (SCM_CAR (x), t.arg1, env);
0f2d19dd 2075 x = SCM_CDR (x);
6dbd0af5 2076 goto cdrxnoap;
0f2d19dd
JB		 2077
2078
2079 case (127 & SCM_IM_LETREC):
2080 x = SCM_CDR (x);
e2806c10 2081 env = EXTEND_ENV (SCM_CAR (x), scm_undefineds, env);
0f2d19dd
JB		 2082 x = SCM_CDR (x);
2083 proc = SCM_CAR (x);
2084 t.arg1 = SCM_EOL;
2085 do
2086 {
2087 t.arg1 = scm_cons (EVALCAR (proc, env), t.arg1);
2088 }
2089 while (SCM_NIMP (proc = SCM_CDR (proc)));
a23afe53 2090 SCM_SETCDR (SCM_CAR (env), t.arg1);
6dbd0af5 2091 goto cdrxnoap;
0f2d19dd
JB		 2092
2093
2094 case (127 & SCM_IM_LETSTAR):
2095 x = SCM_CDR (x);
2096 proc = SCM_CAR (x);
2097 if (SCM_IMP (proc))
2098 {
e2806c10 2099 env = EXTEND_ENV (SCM_EOL, SCM_EOL, env);
6dbd0af5 2100 goto cdrxnoap;
0f2d19dd
JB		 2101 }
2102 do
2103 {
2104 t.arg1 = SCM_CAR (proc);
2105 proc = SCM_CDR (proc);
e2806c10 2106 env = EXTEND_ENV (t.arg1, EVALCAR (proc, env), env);
0f2d19dd
JB		 2107 }
2108 while (SCM_NIMP (proc = SCM_CDR (proc)));
6dbd0af5 2109 goto cdrxnoap;
0f2d19dd
JB		 2110
2111 case (127 & SCM_IM_OR):
2112 x = SCM_CDR (x);
2113 t.arg1 = x;
2114 while (SCM_NNULLP (t.arg1 = SCM_CDR (t.arg1)))
2115 {
2116 x = EVALCAR (x, env);
2117 if (SCM_NFALSEP (x))
2118 {
2119 RETURN (x);
2120 }
2121 x = t.arg1;
2122 }
6dbd0af5 2123 PREP_APPLY (SCM_UNDEFINED, SCM_EOL);
0f2d19dd
JB		 2124 goto carloop;
2125
2126
2127 case (127 & SCM_IM_LAMBDA):
2128 RETURN (scm_closure (SCM_CDR (x), env));
2129
2130
2131 case (127 & SCM_IM_QUOTE):
2132 RETURN (SCM_CAR (SCM_CDR (x)));
2133
2134
89efbff4 2135 case (127 & SCM_IM_SET_X):
0f2d19dd
JB		 2136 x = SCM_CDR (x);
2137 proc = SCM_CAR (x);
6dbd0af5 2138 switch (7 & (int) proc)
0f2d19dd
JB		 2139 {
2140 case 0:
26d5b9b4 2141 t.lloc = scm_lookupcar (x, env, 1);
0f2d19dd
JB		 2142 break;
2143 case 1:
a23afe53 2144 t.lloc = SCM_GLOC_VAL_LOC (proc);
0f2d19dd
JB		 2145 break;
2146#ifdef MEMOIZE_LOCALS
2147 case 4:
2148 t.lloc = scm_ilookup (proc, env);
2149 break;
2150#endif
2151 }
2152 x = SCM_CDR (x);
2153 *t.lloc = EVALCAR (x, env);
0f2d19dd
JB		 2154#ifdef SICP
2155 RETURN (*t.lloc);
2156#else
2157 RETURN (SCM_UNSPECIFIED);
2158#endif
2159
2160
2161 case (127 & SCM_IM_DEFINE): /* only for internal defines */
26d5b9b4
MD		 2162 scm_misc_error (NULL, "Bad define placement", SCM_EOL);
2163
0f2d19dd
JB		 2164 /* new syntactic forms go here. */
2165 case (127 & SCM_MAKISYM (0)):
2166 proc = SCM_CAR (x);
2167 SCM_ASRTGO (SCM_ISYMP (proc), badfun);
2168 switch SCM_ISYMNUM (proc)
2169 {
2170#if 0
2171 case (SCM_ISYMNUM (IM_VREF)):
2172 {
2173 SCM var;
2174 var = SCM_CAR (SCM_CDR (x));
2175 RETURN (SCM_CDR(var));
2176 }
2177 case (SCM_ISYMNUM (IM_VSET)):
2178 SCM_CDR (SCM_CAR ( SCM_CDR (x))) = EVALCAR( SCM_CDR ( SCM_CDR (x)), env);
2179 SCM_CAR (SCM_CAR ( SCM_CDR (x))) = scm_tc16_variable;
6dbd0af5 2180 RETURN (SCM_UNSPECIFIED)
0f2d19dd
JB		 2181#endif
2182
2183 case (SCM_ISYMNUM (SCM_IM_APPLY)):
2184 proc = SCM_CDR (x);
2185 proc = EVALCAR (proc, env);
2186 SCM_ASRTGO (SCM_NIMP (proc), badfun);
2187 if (SCM_CLOSUREP (proc))
2188 {
1609038c 2189 SCM argl, tl;
6dbd0af5 2190 PREP_APPLY (proc, SCM_EOL);
0f2d19dd
JB		 2191 t.arg1 = SCM_CDR (SCM_CDR (x));
2192 t.arg1 = EVALCAR (t.arg1, env);
6dbd0af5
MD		 2193#ifdef DEVAL
2194 debug.info->a.args = t.arg1;
2195#endif
cf7c17e9 2196#ifndef SCM_RECKLESS
0f2d19dd
JB		 2197 if (scm_badargsp (SCM_CAR (SCM_CODE (proc)), t.arg1))
2198 goto wrongnumargs;
2199#endif
c79450dd 2200 ENTER_APPLY;
1609038c
MD		 2201 /* Copy argument list */
2202 if (SCM_IMP (t.arg1))
2203 argl = t.arg1;
2204 else
2205 {
2206 argl = tl = scm_cons (SCM_CAR (t.arg1), SCM_UNSPECIFIED);
2207 while (SCM_NIMP (t.arg1 = SCM_CDR (t.arg1))
2208 && SCM_CONSP (t.arg1))
2209 {
2210 SCM_SETCDR (tl, scm_cons (SCM_CAR (t.arg1),
2211 SCM_UNSPECIFIED));
2212 tl = SCM_CDR (tl);
2213 }
2214 SCM_SETCDR (tl, t.arg1);
2215 }
2216
2217 env = EXTEND_ENV (SCM_CAR (SCM_CODE (proc)), argl, SCM_ENV (proc));
0f2d19dd
JB		 2218 x = SCM_CODE (proc);
2219 goto cdrxbegin;
2220 }
81123e6d 2221 proc = scm_f_apply;
0f2d19dd
JB		 2222 goto evapply;
2223
2224 case (SCM_ISYMNUM (SCM_IM_CONT)):
2225 scm_make_cont (&t.arg1);
ca6ef71a 2226 if (setjmp (SCM_JMPBUF (t.arg1)))
0f2d19dd
JB		 2227 {
2228 SCM val;
2229 val = SCM_THROW_VALUE (t.arg1);
a570e93a 2230 RETURN (val)
0f2d19dd
JB		 2231 }
2232 proc = SCM_CDR (x);
2233 proc = evalcar (proc, env);
2234 SCM_ASRTGO (SCM_NIMP (proc), badfun);
6dbd0af5
MD		 2235 PREP_APPLY (proc, scm_cons (t.arg1, SCM_EOL));
2236 ENTER_APPLY;
0f2d19dd
JB		 2237 goto evap1;
2238
a570e93a
MD		 2239 case (SCM_ISYMNUM (SCM_IM_DELAY)):
2240 RETURN (scm_makprom (scm_closure (SCM_CDR (x), env)))
2241
89efbff4 2242 case (SCM_ISYMNUM (SCM_IM_DISPATCH)):
195847fa
MD		 2243 proc = SCM_CADR (x); /* unevaluated operands */
2244 PREP_APPLY (SCM_UNDEFINED, SCM_EOL);
2245 if (SCM_IMP (proc))
2246 arg2 = *scm_ilookup (proc, env);
2247 else if (SCM_NCONSP (proc))
2248 {
2249 if (SCM_NCELLP (proc))
2250 arg2 = SCM_GLOC_VAL (proc);
2251 else
2252 arg2 = *scm_lookupcar (SCM_CDR (x), env, 1);
2253 }
2254 else
2255 {
2256 arg2 = scm_cons (EVALCAR (proc, env), SCM_EOL);
2257 t.lloc = SCM_CDRLOC (arg2);
2258 while (SCM_NIMP (proc = SCM_CDR (proc)))
2259 {
2260 *t.lloc = scm_cons (EVALCAR (proc, env), SCM_EOL);
2261 t.lloc = SCM_CDRLOC (*t.lloc);
2262 }
2263 }
2264
2265 type_dispatch:
61364ba6
MD		 2266 /* The type dispatch code is duplicated here
2267 * (c.f. objects.c:scm_mcache_compute_cmethod) since that
2268 * cuts down execution time for type dispatch to 50%.
2269 */
2270 {
2271 int i, n, end, mask;
2272 SCM z = SCM_CDDR (x);
2273 n = SCM_INUM (SCM_CAR (z)); /* maximum number of specializers */
2274 proc = SCM_CADR (z);
2275
2276 if (SCM_NIMP (proc))
2277 {
2278 /* Prepare for linear search */
2279 mask = -1;
2280 i = 0;
2281 end = SCM_LENGTH (proc);
2282 }
2283 else
2284 {
2285 /* Compute a hash value */
2286 int hashset = SCM_INUM (proc);
2287 int j = n;
2288 mask = SCM_INUM (SCM_CAR (z = SCM_CDDR (z)));
2289 proc = SCM_CADR (z);
2290 i = 0;
2291 t.arg1 = arg2;
2292 if (SCM_NIMP (t.arg1))
2293 do
2294 {
2295 i += (SCM_STRUCT_DATA (scm_class_of (SCM_CAR (t.arg1)))
2296 [scm_si_hashsets + hashset]);
2297 t.arg1 = SCM_CDR (t.arg1);
2298 }
2299 while (--j && SCM_NIMP (t.arg1));
2300 i &= mask;
2301 end = i;
2302 }
2303
2304 /* Search for match */
2305 do
2306 {
2307 int j = n;
2308 z = SCM_VELTS (proc)[i];
2309 t.arg1 = arg2; /* list of arguments */
2310 if (SCM_NIMP (t.arg1))
2311 do
2312 {
2313 /* More arguments than specifiers => CLASS != ENV */
2314 if (scm_class_of (SCM_CAR (t.arg1)) != SCM_CAR (z))
2315 goto next_method;
2316 t.arg1 = SCM_CDR (t.arg1);
2317 z = SCM_CDR (z);
2318 }
2319 while (--j && SCM_NIMP (t.arg1));
2320 /* Fewer arguments than specifiers => CAR != ENV */
2321 if (!(SCM_IMP (SCM_CAR (z)) || SCM_CONSP (SCM_CAR (z))))
2322 goto next_method;
2323 apply_cmethod:
2324 env = EXTEND_ENV (SCM_CAR (SCM_CMETHOD_CODE (z)),
2325 arg2,
2326 SCM_CMETHOD_ENV (z));
2327 x = SCM_CMETHOD_CODE (z);
2328 goto cdrxbegin;
2329 next_method:
2330 i = (i + 1) & mask;
2331 } while (i != end);
2332
2333 z = scm_memoize_method (x, arg2);
2334 goto apply_cmethod;
2335 }
73b64342 2336
ca4be6ea
MD		 2337 case (SCM_ISYMNUM (SCM_IM_SLOT_REF)):
2338 x = SCM_CDR (x);
2339 t.arg1 = EVALCAR (x, env);
5623a9b4
MD		 2340 proc = SCM_STRUCT_DATA (t.arg1)[SCM_INUM (SCM_CADR (x))];
2341 if (proc == SCM_UNBOUND)
2342 scm_misc_error (NULL,
5f6d07ad 2343 "Unbound slot in object %S",
5623a9b4
MD		 2344 SCM_LIST1 (t.arg1));
2345 RETURN (proc)
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
GH		 2457 scm_misc_error (NULL,
2458 "Wrong type to apply: %S",
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
1bbd0b84
GB		 3187GUILE_PROC(scm_nconc2last, "apply:nconc2last", 1, 0, 0,
3188 (SCM lst),
3189"")
3190#define FUNC_NAME s_scm_nconc2last
0f2d19dd
JB		 3191{
3192 SCM *lloc;
1bbd0b84 3193 SCM_VALIDATE_LIST(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);
3415 while (SCM_NIMP (arg1 = SCM_CDR (arg1))
3416 && SCM_CONSP (arg1))
3417 {
3418 SCM_SETCDR (tl, scm_cons (SCM_CAR (arg1),
3419 SCM_UNSPECIFIED));
3420 tl = SCM_CDR (tl);
3421 }
3422 SCM_SETCDR (tl, arg1);
3423 }
3424
3425 args = EXTEND_ENV (SCM_CAR (SCM_CODE (proc)), args, SCM_ENV (proc));
2ddb0920 3426 proc = SCM_CDR (SCM_CODE (proc));
e791c18f
MD		 3427 again:
3428 arg1 = proc;
3429 while (SCM_NNULLP (arg1 = SCM_CDR (arg1)))
2ddb0920
MD		 3430 {
3431 if (SCM_IMP (SCM_CAR (proc)))
3432 {
3433 if (SCM_ISYMP (SCM_CAR (proc)))
3434 {
3435 proc = scm_m_expand_body (proc, args);
e791c18f 3436 goto again;
2ddb0920 3437 }
2ddb0920
MD		 3438 }
3439 else
e791c18f
MD		 3440 SCM_CEVAL (SCM_CAR (proc), args);
3441 proc = arg1;
2ddb0920 3442 }
e791c18f 3443 RETURN (EVALCAR (proc, args));
0f2d19dd
JB		 3444 case scm_tc7_contin:
3445 SCM_ASRTGO (SCM_NULLP (args), wrongnumargs);
3446 scm_call_continuation (proc, arg1);
3447#ifdef CCLO
3448 case scm_tc7_cclo:
3449#ifdef DEVAL
6dbd0af5
MD		 3450 args = (SCM_UNBNDP(arg1) ? SCM_EOL : debug.vect[0].a.args);
3451 arg1 = proc;
3452 proc = SCM_CCLO_SUBR (proc);
3453 debug.vect[0].a.proc = proc;
3454 debug.vect[0].a.args = scm_cons (arg1, args);
0f2d19dd
JB		 3455#else
3456 args = (SCM_UNBNDP(arg1) ? SCM_EOL : scm_cons (arg1, args));
0f2d19dd
JB		 3457 arg1 = proc;
3458 proc = SCM_CCLO_SUBR (proc);
6dbd0af5 3459#endif
0f2d19dd
JB		 3460 goto tail;
3461#endif
89efbff4
MD		 3462 case scm_tc7_pws:
3463 proc = SCM_PROCEDURE (proc);
3464#ifdef DEVAL
3465 debug.vect[0].a.proc = proc;
3466#endif
3467 goto tail;
0c32d76c 3468 case scm_tcs_cons_gloc:
f3d2630a
MD		 3469 if (SCM_OBJ_CLASS_FLAGS (proc) & SCM_CLASSF_PURE_GENERIC)
3470 {
3471#ifdef DEVAL
3472 args = (SCM_UNBNDP(arg1) ? SCM_EOL : debug.vect[0].a.args);
3473#else
3474 args = (SCM_UNBNDP(arg1) ? SCM_EOL : scm_cons (arg1, args));
3475#endif
195847fa 3476 RETURN (scm_apply_generic (proc, args));
f3d2630a
MD		 3477 }
3478 else if (!SCM_I_OPERATORP (proc))
9b07e212
MD		 3479 goto badproc;
3480 else
da7f71d7
MD		 3481 {
3482#ifdef DEVAL
3483 args = (SCM_UNBNDP(arg1) ? SCM_EOL : debug.vect[0].a.args);
3484#else
3485 args = (SCM_UNBNDP(arg1) ? SCM_EOL : scm_cons (arg1, args));
3486#endif
3487 arg1 = proc;
195847fa
MD		 3488 proc = (SCM_I_ENTITYP (proc)
3489 ? SCM_ENTITY_PROCEDURE (proc)
3490 : SCM_OPERATOR_PROCEDURE (proc));
da7f71d7
MD		 3491#ifdef DEVAL
3492 debug.vect[0].a.proc = proc;
3493 debug.vect[0].a.args = scm_cons (arg1, args);
3494#endif
195847fa
MD		 3495 if (SCM_NIMP (proc))
3496 goto tail;
3497 else
3498 goto badproc;
da7f71d7 3499 }
0f2d19dd 3500 wrongnumargs:
f5bf2977 3501 scm_wrong_num_args (proc);
0f2d19dd
JB		 3502 default:
3503 badproc:
3504 scm_wta (proc, (char *) SCM_ARG1, "apply");
3505 RETURN (arg1);
3506 }
3507#ifdef DEVAL
6dbd0af5 3508exit:
b6d75948 3509 if (CHECK_EXIT && SCM_TRAPS_P)
b7ff98dd 3510 if (SCM_EXIT_FRAME_P || (SCM_TRACE_P && SCM_TRACED_FRAME_P (debug)))
6dbd0af5 3511 {
b7ff98dd
MD		 3512 SCM_CLEAR_TRACED_FRAME (debug);
3513 if (SCM_CHEAPTRAPS_P)
c0ab1b8d 3514 arg1 = scm_make_debugobj (&debug);
6dbd0af5
MD		 3515 else
3516 {
3517 scm_make_cont (&arg1);
ca6ef71a 3518 if (setjmp (SCM_JMPBUF (arg1)))
6dbd0af5
MD		 3519 {
3520 proc = SCM_THROW_VALUE (arg1);
3521 goto ret;
3522 }
3523 }
2f0d1375 3524 scm_ithrow (scm_sym_exit_frame, scm_cons2 (arg1, proc, SCM_EOL), 0);
6dbd0af5
MD		 3525 }
3526ret:
1646d37b 3527 scm_last_debug_frame = debug.prev;
0f2d19dd
JB		 3528 return proc;
3529#endif
3530}
3531
6dbd0af5
MD		 3532
3533/* SECTION: The rest of this file is only read once.
3534 */
3535
0f2d19dd
JB		 3536#ifndef DEVAL
3537
d9c393f5
JB		 3538/* Typechecking for multi-argument MAP and FOR-EACH.
3539
47c3f06d 3540 Verify that each element of the vector ARGV, except for the first,
d9c393f5 3541 is a proper list whose length is LEN. Attribute errors to WHO,
47c3f06d 3542 and claim that the i'th element of ARGV is WHO's i+2'th argument. */
d9c393f5 3543static inline void
47c3f06d
MD		 3544check_map_args (SCM argv,
3545 long len,
3546 SCM gf,
3547 SCM proc,
3548 SCM args,
3549 const char *who)
d9c393f5 3550{
47c3f06d 3551 SCM *ve = SCM_VELTS (argv);
d9c393f5
JB		 3552 int i;
3553
47c3f06d 3554 for (i = SCM_LENGTH (argv) - 1; i >= 1; i--)
d9c393f5
JB		 3555 {
3556 int elt_len = scm_ilength (ve[i]);
3557
3558 if (elt_len < 0)
47c3f06d
MD		 3559 {
3560 if (gf)
3561 scm_apply_generic (gf, scm_cons (proc, args));
3562 else
3563 scm_wrong_type_arg (who, i + 2, ve[i]);
3564 }
d9c393f5
JB		 3565
3566 if (elt_len != len)
3567 scm_out_of_range (who, ve[i]);
3568 }
3569
47c3f06d 3570 scm_remember (&argv);
d9c393f5
JB		 3571}
3572
3573
47c3f06d 3574SCM_GPROC (s_map, "map", 2, 0, 1, scm_map, g_map);
1cc91f1b 3575
368bf056
MD		 3576/* Note: Currently, scm_map applies PROC to the argument list(s)
3577 sequentially, starting with the first element(s). This is used in
3578 evalext.c where the Scheme procedure `serial-map', which guarantees
3579 sequential behaviour, is implemented using scm_map. If the
3580 behaviour changes, we need to update `serial-map'.
3581*/
3582
0f2d19dd 3583SCM
1bbd0b84 3584scm_map (SCM proc, SCM arg1, SCM args)
0f2d19dd 3585{
d9c393f5 3586 long i, len;
0f2d19dd
JB		 3587 SCM res = SCM_EOL;
3588 SCM *pres = &res;
3589 SCM *ve = &args; /* Keep args from being optimized away. */
3590
3591 if (SCM_NULLP (arg1))
3592 return res;
d9c393f5 3593 len = scm_ilength (arg1);
47c3f06d
MD		 3594 SCM_GASSERTn (len >= 0,
3595 g_map, scm_cons2 (proc, arg1, args), SCM_ARG2, s_map);
0f2d19dd
JB		 3596 if (SCM_NULLP (args))
3597 {
3598 while (SCM_NIMP (arg1))
3599 {
47c3f06d
MD		 3600 SCM_GASSERT2 (SCM_CONSP (arg1), g_map, proc, arg1, SCM_ARG2, s_map);
3601 *pres = scm_cons (scm_apply (proc, SCM_CAR (arg1), scm_listofnull),
3602 SCM_EOL);
a23afe53 3603 pres = SCM_CDRLOC (*pres);
0f2d19dd
JB		 3604 arg1 = SCM_CDR (arg1);
3605 }
3606 return res;
3607 }
47c3f06d 3608 args = scm_vector (arg1 = scm_cons (arg1, args));
0f2d19dd 3609 ve = SCM_VELTS (args);
cf7c17e9 3610#ifndef SCM_RECKLESS
47c3f06d 3611 check_map_args (args, len, g_map, proc, arg1, s_map);
0f2d19dd
JB		 3612#endif
3613 while (1)
3614 {
3615 arg1 = SCM_EOL;
3616 for (i = SCM_LENGTH (args) - 1; i >= 0; i--)
3617 {
d9c393f5
JB		 3618 if (SCM_IMP (ve[i]))
3619 return res;
0f2d19dd
JB		 3620 arg1 = scm_cons (SCM_CAR (ve[i]), arg1);
3621 ve[i] = SCM_CDR (ve[i]);
3622 }
3623 *pres = scm_cons (scm_apply (proc, arg1, SCM_EOL), SCM_EOL);
a23afe53 3624 pres = SCM_CDRLOC (*pres);
0f2d19dd
JB		 3625 }
3626}
3627
3628
47c3f06d 3629SCM_GPROC (s_for_each, "for-each", 2, 0, 1, scm_for_each, g_for_each);
1cc91f1b 3630
0f2d19dd 3631SCM
1bbd0b84 3632scm_for_each (SCM proc, SCM arg1, SCM args)
0f2d19dd
JB		 3633{
3634 SCM *ve = &args; /* Keep args from being optimized away. */
d9c393f5 3635 long i, len;
0f2d19dd
JB		 3636 if SCM_NULLP (arg1)
3637 return SCM_UNSPECIFIED;
d9c393f5 3638 len = scm_ilength (arg1);
47c3f06d
MD		 3639 SCM_GASSERTn (len >= 0, g_for_each, scm_cons2 (proc, arg1, args),
3640 SCM_ARG2, s_for_each);
0f2d19dd
JB		 3641 if SCM_NULLP (args)
3642 {
3643 while SCM_NIMP (arg1)
3644 {
47c3f06d
MD		 3645 SCM_GASSERT2 (SCM_CONSP (arg1),
3646 g_for_each, proc, arg1, SCM_ARG2, s_for_each);
0f2d19dd
JB		 3647 scm_apply (proc, SCM_CAR (arg1), scm_listofnull);
3648 arg1 = SCM_CDR (arg1);
3649 }
3650 return SCM_UNSPECIFIED;
3651 }
47c3f06d 3652 args = scm_vector (arg1 = scm_cons (arg1, args));
0f2d19dd 3653 ve = SCM_VELTS (args);
cf7c17e9 3654#ifndef SCM_RECKLESS
47c3f06d 3655 check_map_args (args, len, g_for_each, proc, arg1, s_for_each);
0f2d19dd
JB		 3656#endif
3657 while (1)
3658 {
3659 arg1 = SCM_EOL;
3660 for (i = SCM_LENGTH (args) - 1; i >= 0; i--)
3661 {
3662 if SCM_IMP
3663 (ve[i]) return SCM_UNSPECIFIED;
3664 arg1 = scm_cons (SCM_CAR (ve[i]), arg1);
3665 ve[i] = SCM_CDR (ve[i]);
3666 }
3667 scm_apply (proc, arg1, SCM_EOL);
3668 }
3669}
3670
3671
1cc91f1b 3672
0f2d19dd 3673SCM
6e8d25a6 3674scm_closure (SCM code, SCM env)
0f2d19dd
JB		 3675{
3676 register SCM z;
3677 SCM_NEWCELL (z);
3678 SCM_SETCODE (z, code);
a23afe53 3679 SCM_SETENV (z, env);
0f2d19dd
JB		 3680 return z;
3681}
3682
3683
3684long scm_tc16_promise;
1cc91f1b 3685
0f2d19dd 3686SCM
6e8d25a6 3687scm_makprom (SCM code)
0f2d19dd 3688{
23a62151 3689 SCM_RETURN_NEWSMOB (scm_tc16_promise, code);
0f2d19dd
JB		 3690}
3691
3692
1cc91f1b 3693
0f2d19dd 3694static int
1bbd0b84 3695prinprom (SCM exp,SCM port,scm_print_state *pstate)
0f2d19dd 3696{
19402679 3697 int writingp = SCM_WRITINGP (pstate);
b7f3516f 3698 scm_puts ("#<promise ", port);
19402679
MD		 3699 SCM_SET_WRITINGP (pstate, 1);
3700 scm_iprin1 (SCM_CDR (exp), port, pstate);
3701 SCM_SET_WRITINGP (pstate, writingp);
b7f3516f 3702 scm_putc ('>', port);
0f2d19dd
JB		 3703 return !0;
3704}
3705
3706
1bbd0b84
GB		 3707GUILE_PROC(scm_force, "force", 1, 0, 0,
3708 (SCM x),
3709"")
3710#define FUNC_NAME s_scm_force
0f2d19dd 3711{
1bbd0b84 3712 SCM_VALIDATE_SMOB(1,x,promise);
0f2d19dd
JB		 3713 if (!((1L << 16) & SCM_CAR (x)))
3714 {
3715 SCM ans = scm_apply (SCM_CDR (x), SCM_EOL, SCM_EOL);
3716 if (!((1L << 16) & SCM_CAR (x)))
3717 {
3718 SCM_DEFER_INTS;
a23afe53
MD		 3719 SCM_SETCDR (x, ans);
3720 SCM_SETOR_CAR (x, (1L << 16));
0f2d19dd
JB		 3721 SCM_ALLOW_INTS;
3722 }
3723 }
3724 return SCM_CDR (x);
3725}
1bbd0b84 3726#undef FUNC_NAME
0f2d19dd 3727
1bbd0b84
GB		 3728GUILE_PROC (scm_promise_p, "promise?", 1, 0, 0,
3729 (SCM x),
4079f87e
GB		 3730"Return true if @var{obj} is a promise, i.e. a delayed computation
3731(@pxref{Delayed evaluation,,,r4rs.info,The Revised^4 Report on Scheme}).")
1bbd0b84 3732#define FUNC_NAME s_scm_promise_p
0f2d19dd 3733{
1bbd0b84 3734 return SCM_BOOL(SCM_NIMP (x) && (SCM_TYP16 (x) == scm_tc16_promise));
0f2d19dd 3735}
1bbd0b84 3736#undef FUNC_NAME
0f2d19dd 3737
1bbd0b84
GB		 3738GUILE_PROC (scm_cons_source, "cons-source", 3, 0, 0,
3739 (SCM xorig, SCM x, SCM y),
3740"")
3741#define FUNC_NAME s_scm_cons_source
26d5b9b4
MD		 3742{
3743 SCM p, z;
3744 SCM_NEWCELL (z);
3745 SCM_SETCAR (z, x);
3746 SCM_SETCDR (z, y);
3747 /* Copy source properties possibly associated with xorig. */
3748 p = scm_whash_lookup (scm_source_whash, xorig);
3749 if (SCM_NIMP (p))
3750 scm_whash_insert (scm_source_whash, z, p);
3751 return z;
3752}
1bbd0b84 3753#undef FUNC_NAME
26d5b9b4 3754
1bbd0b84
GB		 3755GUILE_PROC (scm_copy_tree, "copy-tree", 1, 0, 0,
3756 (SCM obj),
4079f87e
GB		 3757"Recursively copy the data tree that is bound to @var{obj}, and return a
3758pointer to the new data structure. @code{copy-tree} recurses down the
3759contents of both pairs and vectors (since both cons cells and vector
3760cells may point to arbitrary objects), and stops recursing when it hits
3761any other object.")
1bbd0b84 3762#define FUNC_NAME s_scm_copy_tree
0f2d19dd
JB		 3763{
3764 SCM ans, tl;
26d5b9b4 3765 if (SCM_IMP (obj))
ff467021 3766 return obj;
3910272e
MD		 3767 if (SCM_VECTORP (obj))
3768 {
3769 scm_sizet i = SCM_LENGTH (obj);
3770 ans = scm_make_vector (SCM_MAKINUM (i), SCM_UNSPECIFIED);
3771 while (i--)
3772 SCM_VELTS (ans)[i] = scm_copy_tree (SCM_VELTS (obj)[i]);
3773 return ans;
3774 }
ff467021 3775 if (SCM_NCONSP (obj))
0f2d19dd
JB		 3776 return obj;
3777/* return scm_cons(scm_copy_tree(SCM_CAR(obj)), scm_copy_tree(SCM_CDR(obj))); */
26d5b9b4
MD		 3778 ans = tl = scm_cons_source (obj,
3779 scm_copy_tree (SCM_CAR (obj)),
3780 SCM_UNSPECIFIED);
0f2d19dd 3781 while (SCM_NIMP (obj = SCM_CDR (obj)) && SCM_CONSP (obj))
a23afe53
MD		 3782 {
3783 SCM_SETCDR (tl, scm_cons (scm_copy_tree (SCM_CAR (obj)),
3784 SCM_UNSPECIFIED));
3785 tl = SCM_CDR (tl);
3786 }
3787 SCM_SETCDR (tl, obj);
0f2d19dd
JB		 3788 return ans;
3789}
1bbd0b84 3790#undef FUNC_NAME
0f2d19dd 3791
1cc91f1b 3792
0f2d19dd 3793SCM
1bbd0b84 3794scm_eval_3 (SCM obj, int copyp, SCM env)
0f2d19dd
JB		 3795{
3796 if (SCM_NIMP (SCM_CDR (scm_system_transformer)))
3797 obj = scm_apply (SCM_CDR (scm_system_transformer), obj, scm_listofnull);
3798 else if (copyp)
3799 obj = scm_copy_tree (obj);
6cb702da 3800 return SCM_XEVAL (obj, env);
0f2d19dd
JB		 3801}
3802
1bbd0b84
GB		 3803GUILE_PROC(scm_eval2, "eval2", 2, 0, 0,
3804 (SCM obj, SCM env_thunk),
4079f87e
GB		 3805"Evaluate @var{exp}, a Scheme expression, in the environment designated
3806by @var{lookup}, a symbol-lookup function. @code{(eval exp)} is
3807equivalent to @code{(eval2 exp *top-level-lookup-closure*)}.")
1bbd0b84 3808#define FUNC_NAME s_scm_eval2
0f2d19dd 3809{
6bcb0868 3810 return scm_eval_3 (obj, 1, scm_top_level_env (env_thunk));
0f2d19dd 3811}
1bbd0b84 3812#undef FUNC_NAME
0f2d19dd 3813
1bbd0b84
GB		 3814GUILE_PROC(scm_eval, "eval", 1, 0, 0,
3815 (SCM obj),
4079f87e
GB		 3816"Evaluate @var{exp}, a list representing a Scheme expression, in the
3817top-level environment.")
1bbd0b84 3818#define FUNC_NAME s_scm_eval
0f2d19dd 3819{
6bcb0868
MD		 3820 return scm_eval_3 (obj,
3821 1,
3822 scm_top_level_env
3823 (SCM_CDR (scm_top_level_lookup_closure_var)));
0f2d19dd 3824}
1bbd0b84 3825#undef FUNC_NAME
0f2d19dd 3826
1bbd0b84
GB		 3827/*
3828SCM_REGISTER_PROC(s_eval_x, "eval!", 1, 0, 0, scm_eval_x);
3829*/
1cc91f1b 3830
0f2d19dd 3831SCM
1bbd0b84 3832scm_eval_x (SCM obj)
0f2d19dd 3833{
6bcb0868
MD		 3834 return scm_eval_3 (obj,
3835 0,
3836 scm_top_level_env
3837 (SCM_CDR (scm_top_level_lookup_closure_var)));
0f2d19dd
JB		 3838}
3839
6dbd0af5
MD		 3840
3841/* At this point, scm_deval and scm_dapply are generated.
3842 */
3843
0f2d19dd 3844#ifdef DEBUG_EXTENSIONS
6dbd0af5
MD		 3845# define DEVAL
3846# include "eval.c"
0f2d19dd
JB		 3847#endif
3848
3849
1cc91f1b 3850
0f2d19dd
JB		 3851void
3852scm_init_eval ()
0f2d19dd 3853{
33b97402
MD		 3854 scm_init_opts (scm_evaluator_traps,
3855 scm_evaluator_trap_table,
3856 SCM_N_EVALUATOR_TRAPS);
3857 scm_init_opts (scm_eval_options_interface,
3858 scm_eval_opts,
3859 SCM_N_EVAL_OPTIONS);
3860
f99c9c28
MD		 3861 scm_tc16_promise = scm_make_smob_type ("promise", 0);
3862 scm_set_smob_mark (scm_tc16_promise, scm_markcdr);
3863 scm_set_smob_print (scm_tc16_promise, prinprom);
b8229a3b 3864
81123e6d 3865 scm_f_apply = scm_make_subr ("apply", scm_tc7_lsubr_2, scm_apply);
0f2d19dd 3866 scm_system_transformer = scm_sysintern ("scm:eval-transformer", SCM_UNDEFINED);
2f0d1375
MD		 3867 scm_sym_dot = SCM_CAR (scm_sysintern (".", SCM_UNDEFINED));
3868 scm_sym_arrow = SCM_CAR (scm_sysintern ("=>", SCM_UNDEFINED));
3869 scm_sym_else = SCM_CAR (scm_sysintern ("else", SCM_UNDEFINED));
3870 scm_sym_unquote = SCM_CAR (scm_sysintern ("unquote", SCM_UNDEFINED));
3871 scm_sym_uq_splicing = SCM_CAR (scm_sysintern ("unquote-splicing", SCM_UNDEFINED));
0f2d19dd 3872
73b64342
MD		 3873 scm_nil = scm_sysintern ("nil", SCM_UNDEFINED);
3874 SCM_SETCDR (scm_nil, SCM_CAR (scm_nil));
3875 scm_nil = SCM_CAR (scm_nil);
3876 scm_t = scm_sysintern ("t", SCM_UNDEFINED);
3877 SCM_SETCDR (scm_t, SCM_CAR (scm_t));
3878 scm_t = SCM_CAR (scm_t);
73b64342 3879
0f2d19dd 3880 /* acros */
0f2d19dd
JB		 3881 /* end of acros */
3882
dc19d1d2
JB		 3883 scm_top_level_lookup_closure_var =
3884 scm_sysintern("*top-level-lookup-closure*", SCM_BOOL_F);
9b8d3288 3885 scm_can_use_top_level_lookup_closure_var = 1;
0f2d19dd 3886
6dbd0af5 3887#ifdef DEBUG_EXTENSIONS
2f0d1375
MD		 3888 scm_sym_enter_frame = SCM_CAR (scm_sysintern ("enter-frame", SCM_UNDEFINED));
3889 scm_sym_apply_frame = SCM_CAR (scm_sysintern ("apply-frame", SCM_UNDEFINED));
3890 scm_sym_exit_frame = SCM_CAR (scm_sysintern ("exit-frame", SCM_UNDEFINED));
3891 scm_sym_trace = SCM_CAR (scm_sysintern ("trace", SCM_UNDEFINED));
6dbd0af5
MD		 3892#endif
3893
0f2d19dd 3894#include "eval.x"
25eaf21a
MD		 3895
3896 scm_add_feature ("delay");
0f2d19dd 3897}
0f2d19dd 3898
6dbd0af5 3899#endif /* !DEVAL */
Unnamed repository; edit this file 'description' to name the repository.