HCoop / bpt / guile.git / blame
? search:
summary | shortlog | log | commit | commitdiff | tree
blob | blame (incremental) | history | HEAD
maintainer changed: was lord, now jimb; first import
[bpt/guile.git] / libguile / eval.c
CommitLineData
0f2d19dd
JB		 1/* Copyright (C) 1995,1996 Free Software Foundation, Inc.
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
15 * the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
16 *
17 * As a special exception, the Free Software Foundation gives permission
18 * for additional uses of the text contained in its release of GUILE.
19 *
20 * The exception is that, if you link the GUILE library with other files
21 * to produce an executable, this does not by itself cause the
22 * resulting executable to be covered by the GNU General Public License.
23 * Your use of that executable is in no way restricted on account of
24 * linking the GUILE library code into it.
25 *
26 * This exception does not however invalidate any other reasons why
27 * the executable file might be covered by the GNU General Public License.
28 *
29 * This exception applies only to the code released by the
30 * Free Software Foundation under the name GUILE. If you copy
31 * code from other Free Software Foundation releases into a copy of
32 * GUILE, as the General Public License permits, the exception does
33 * not apply to the code that you add in this way. To avoid misleading
34 * anyone as to the status of such modified files, you must delete
35 * this exception notice from them.
36 *
37 * If you write modifications of your own for GUILE, it is your choice
38 * whether to permit this exception to apply to your modifications.
39 * If you do not wish that, delete this exception notice.
40 */
41\f
42
43/* This file is read twice in order to produce a second debugging
44 * version of scm_ceval called scm_deval. scm_deval is produced when
45 * we define the preprocessor macro DEVAL.
46 */
47
48#ifndef DEVAL
49
50#include <stdio.h>
51#include "_scm.h"
52
53\f
54
55#define EVALCELLCAR(x, env) (SCM_SYMBOLP (SCM_CAR(x)) \
56 ? *scm_lookupcar(x, env) \
57 : SCM_CEVAL(SCM_CAR(x), env))
58
59#ifdef MEMOIZE_LOCALS
60#define EVALIMP(x, env) (SCM_ILOCP(x)?*scm_ilookup((x), env):x)
61#else
62#define EVALIMP(x, env) x
63#endif
64#define EVALCAR(x, env) (SCM_NCELLP(SCM_CAR(x))\
65 ? (SCM_IMP(SCM_CAR(x)) \
66 ? EVALIMP(SCM_CAR(x), env) \
67 : SCM_GLOC_VAL(SCM_CAR(x))) \
68 : EVALCELLCAR(x, env))
69#ifdef DEBUG_EXTENSIONS
70#define XEVALCAR(x, env) (SCM_NCELLP(SCM_CAR(x)) \
71 ? (SCM_IMP(SCM_CAR(x)) \
72 ? EVALIMP(SCM_CAR(x), env) \
73 : SCM_GLOC_VAL(SCM_CAR(x))) \
74 : (SCM_SYMBOLP(SCM_CAR(x)) \
75 ? *scm_lookupcar(x, env) \
76 : (*scm_ceval_ptr) (SCM_CAR(x), env)))
77#else
78#define XEVALCAR(x, env) EVALCAR(x, env)
79#endif
80
81#define EXTEND_SCM_ENV SCM_EXTEND_SCM_ENV
82
83#ifdef MEMOIZE_LOCALS
84#ifdef __STDC__
85SCM *
86scm_ilookup (SCM iloc, SCM env)
87#else
88SCM *
89scm_ilookup (iloc, env)
90 SCM iloc;
91 SCM env;
92#endif
93{
94 register int ir = SCM_IFRAME (iloc);
95 register SCM er = env;
96 for (; 0 != ir; --ir)
97 er = SCM_CDR (er);
98 er = SCM_CAR (er);
99 for (ir = SCM_IDIST (iloc); 0 != ir; --ir)
100 er = SCM_CDR (er);
101 if (SCM_ICDRP (iloc))
102 return &SCM_CDR (er);
103 return &SCM_CAR (SCM_CDR (er));
104}
105#endif
106
107#ifdef __STDC__
108SCM *
109scm_lookupcar (SCM vloc, SCM genv)
110#else
111SCM *
112scm_lookupcar (vloc, genv)
113 SCM vloc;
114 SCM genv;
115#endif
116{
117 SCM env = genv;
118 register SCM *al, fl, var = SCM_CAR (vloc);
119#ifdef MEMOIZE_LOCALS
120 register SCM iloc = SCM_ILOC00;
121#endif
122 for (; SCM_NIMP (env); env = SCM_CDR (env))
123 {
124 if (SCM_BOOL_T == scm_procedure_p (SCM_CAR (env)))
125 break;
126 al = &SCM_CAR (env);
127 for (fl = SCM_CAR (*al); SCM_NIMP (fl); fl = SCM_CDR (fl))
128 {
129 if (SCM_NCONSP (fl))
130 if (fl == var)
131 {
132#ifdef MEMOIZE_LOCALS
133 SCM_CAR (vloc) = iloc + SCM_ICDR;
134#endif
135 return &SCM_CDR (*al);
136 }
137 else
138 break;
139 al = &SCM_CDR (*al);
140 if (SCM_CAR (fl) == var)
141 {
142#ifdef MEMOIZE_LOCALS
143#ifndef RECKLESS /* letrec inits to SCM_UNDEFINED */
144 if (SCM_UNBNDP (SCM_CAR (*al)))
145 {
146 env = SCM_EOL;
147 goto errout;
148 }
149#endif
150 SCM_CAR (vloc) = iloc;
151#endif
152 return &SCM_CAR (*al);
153 }
154#ifdef MEMOIZE_LOCALS
155 iloc += SCM_IDINC;
156#endif
157 }
158#ifdef MEMOIZE_LOCALS
159 iloc = (~SCM_IDSTMSK) & (iloc + SCM_IFRINC);
160#endif
161 }
162 {
163 SCM top_thunk, vcell;
164 if (SCM_NIMP(env))
165 {
166 top_thunk = SCM_CAR(env); /* env now refers to a top level env thunk */
167 env = SCM_CDR (env);
168 }
169 else
170 top_thunk = SCM_BOOL_F;
171 vcell = scm_sym2vcell (var, top_thunk, SCM_BOOL_F);
172 if (vcell == SCM_BOOL_F)
173 goto errout;
174 else
175 var = vcell;
176 }
177#ifndef RECKLESS
178 if (SCM_NNULLP (env) || SCM_UNBNDP (SCM_CDR (var)))
179 {
180 var = SCM_CAR (var);
181 errout:
182 scm_everr (vloc, genv, var,
183 (SCM_NULLP (env)
184 ? "unbound variable: "
185 : "damaged environment"),
186 "");
187 }
188#endif
189 SCM_CAR (vloc) = var + 1;
190 /* Except wait...what if the var is not a vcell,
191 * but syntax or something....
192 */
193 return &SCM_CDR (var);
194}
195
196#define unmemocar scm_unmemocar
197#ifdef __STDC__
198SCM
199scm_unmemocar (SCM form, SCM env)
200#else
201SCM
202scm_unmemocar (form, env)
203 SCM form;
204 SCM env;
205#endif
206{
207 register int ir;
208 SCM c;
209
210 if (SCM_IMP (form))
211 return form;
212 c = SCM_CAR (form);
213 if (1 == (c & 7))
214 SCM_CAR (form) = SCM_CAR (c - 1);
215#ifdef MEMOIZE_LOCALS
216 else if (SCM_ILOCP (c))
217 {
218 for (ir = SCM_IFRAME (c); ir != 0; --ir)
219 env = SCM_CDR (env);
220 env = SCM_CAR (SCM_CAR (env));
221 for (ir = SCM_IDIST (c); ir != 0; --ir)
222 env = SCM_CDR (env);
223 SCM_CAR (form) = SCM_ICDRP (c) ? env : SCM_CAR (env);
224 }
225#endif
226 return form;
227}
228
229#ifdef __STDC__
230SCM
231scm_eval_car (SCM pair, SCM env)
232#else
233SCM
234scm_eval_car (pair, env)
235 SCM pair;
236 SCM env;
237#endif
238{
239 return EVALCAR (pair, env);
240}
241
242\f
243/*
244 * The following rewrite expressions and
245 * some memoized forms have different syntax
246 */
247
248static char s_expression[] = "missing or extra expression";
249static char s_test[] = "bad test";
250static char s_body[] = "bad body";
251static char s_bindings[] = "bad bindings";
252static char s_variable[] = "bad variable";
253static char s_clauses[] = "bad or missing clauses";
254static char s_formals[] = "bad formals";
255#define ASSYNT(_cond, _arg, _pos, _subr) if(!(_cond))scm_wta(_arg, (char *)_pos, _subr);
256
257SCM scm_i_dot, scm_i_quote, scm_i_quasiquote, scm_i_lambda, scm_i_let,
258 scm_i_arrow, scm_i_else, scm_i_unquote, scm_i_uq_splicing, scm_i_apply;
259SCM scm_i_name;
260#ifdef DEBUG_EXTENSIONS
261static SCM enter_frame_sym, exit_frame_sym;
262#endif
263static char s_quasiquote[] = "quasiquote";
264static char s_delay[] = "delay";
265
266#define ASRTSYNTAX(cond_, msg_) if(!(cond_))scm_wta(xorig, (msg_), what);
267
268
269#ifdef __STDC__
270static void
271bodycheck (SCM xorig, SCM *bodyloc, char *what)
272#else
273static void
274bodycheck (xorig, bodyloc, what)
275 SCM xorig;
276 SCM *bodyloc;
277 char *what;
278#endif
279{
280 ASRTSYNTAX (scm_ilength (*bodyloc) >= 1, s_expression);
281}
282
283
284#ifdef __STDC__
285SCM
286scm_m_quote (SCM xorig, SCM env)
287#else
288SCM
289scm_m_quote (xorig, env)
290 SCM xorig;
291 SCM env;
292#endif
293{
294 ASSYNT (scm_ilength (SCM_CDR (xorig)) == 1, xorig, s_expression, "quote");
295 return scm_cons (SCM_IM_QUOTE, SCM_CDR (xorig));
296}
297
298
299#ifdef __STDC__
300SCM
301scm_m_begin (SCM xorig, SCM env)
302#else
303SCM
304scm_m_begin (xorig, env)
305 SCM xorig;
306 SCM env;
307#endif
308{
309 ASSYNT (scm_ilength (SCM_CDR (xorig)) >= 1, xorig, s_expression, "begin");
310 return scm_cons (SCM_IM_BEGIN, SCM_CDR (xorig));
311}
312
313
314#ifdef __STDC__
315SCM
316scm_m_if (SCM xorig, SCM env)
317#else
318SCM
319scm_m_if (xorig, env)
320 SCM xorig;
321 SCM env;
322#endif
323{
324 int len = scm_ilength (SCM_CDR (xorig));
325 ASSYNT (len >= 2 && len <= 3, xorig, s_expression, "if");
326 return scm_cons (SCM_IM_IF, SCM_CDR (xorig));
327}
328
329
330#ifdef __STDC__
331SCM
332scm_m_set (SCM xorig, SCM env)
333#else
334SCM
335scm_m_set (xorig, env)
336 SCM xorig;
337 SCM env;
338#endif
339{
340 SCM x;
341 int len;
342
343 x = SCM_CDR (xorig);
344 len = scm_ilength (x);
345 ASSYNT ((len > 0) && !(len & 1), xorig, s_expression, "set!");
346
347 {
348 SCM y;
349 y = x;
350 while (len)
351 {
352 ASSYNT (SCM_NIMP (SCM_CAR (y)) && SCM_SYMBOLP (SCM_CAR (y)),
353 xorig, s_variable, "set!");
354 y = SCM_CDR (SCM_CDR (x));
355 len -= 2;
356 }
357 }
358 return scm_cons (SCM_IM_SET, x);
359}
360
361
362#if 0
363#ifdef __STDC__
364SCM
365scm_m_vref (SCM xorig, SCM env)
366#else
367SCM
368scm_m_vref (xorig, env)
369 SCM xorig;
370 SCM env;
371#endif
372{
373 SCM x = SCM_CDR (xorig);
374 ASSYNT (1 == scm_ilength (x), xorig, s_expression, s_vref);
375 if (SCM_NIMP(x) && UDSCM_VARIABLEP (SCM_CAR (x)))
376 {
377 scm_everr (SCM_UNDEFINED, env, SCM_CAR(SCM_CDR(x)), s_variable,
378 "global variable reference");
379 }
380 ASSYNT (SCM_NIMP(x) && DEFSCM_VARIABLEP (SCM_CAR (x)),
381 xorig, s_variable, s_vref);
382 return
383 return scm_cons (IM_VREF, x);
384}
385
386
387#ifdef __STDC__
388SCM
389scm_m_vset (SCM xorig, SCM env)
390#else
391SCM
392scm_m_vset (xorig, env)
393 SCM xorig;
394 SCM env;
395#endif
396{
397 SCM x = SCM_CDR (xorig);
398 ASSYNT (3 == scm_ilength (x), xorig, s_expression, s_vset);
399 ASSYNT (( DEFSCM_VARIABLEP (SCM_CAR (x))
400 || UDSCM_VARIABLEP (SCM_CAR (x))),
401 xorig, s_variable, s_vset);
402 return scm_cons (IM_VSET, x);
403}
404#endif
405
406
407#ifdef __STDC__
408SCM
409scm_m_and (SCM xorig, SCM env)
410#else
411SCM
412scm_m_and (xorig, env)
413 SCM xorig;
414 SCM env;
415#endif
416{
417 int len = scm_ilength (SCM_CDR (xorig));
418 ASSYNT (len >= 0, xorig, s_test, "and");
419 if (len >= 1)
420 return scm_cons (SCM_IM_AND, SCM_CDR (xorig));
421 else
422 return SCM_BOOL_T;
423}
424
425
426#ifdef __STDC__
427SCM
428scm_m_or (SCM xorig, SCM env)
429#else
430SCM
431scm_m_or (xorig, env)
432 SCM xorig;
433 SCM env;
434#endif
435{
436 int len = scm_ilength (SCM_CDR (xorig));
437 ASSYNT (len >= 0, xorig, s_test, "or");
438 if (len >= 1)
439 return scm_cons (SCM_IM_OR, SCM_CDR (xorig));
440 else
441 return SCM_BOOL_F;
442}
443
444
445#ifdef __STDC__
446SCM
447scm_m_case (SCM xorig, SCM env)
448#else
449SCM
450scm_m_case (xorig, env)
451 SCM xorig;
452 SCM env;
453#endif
454{
455 SCM proc, x = SCM_CDR (xorig);
456 ASSYNT (scm_ilength (x) >= 2, xorig, s_clauses, "case");
457 while (SCM_NIMP (x = SCM_CDR (x)))
458 {
459 proc = SCM_CAR (x);
460 ASSYNT (scm_ilength (proc) >= 2, xorig, s_clauses, "case");
461 ASSYNT (scm_ilength (SCM_CAR (proc)) >= 0 || scm_i_else == SCM_CAR (proc),
462 xorig, s_clauses, "case");
463 }
464 return scm_cons (SCM_IM_CASE, SCM_CDR (xorig));
465}
466
467
468#ifdef __STDC__
469SCM
470scm_m_cond (SCM xorig, SCM env)
471#else
472SCM
473scm_m_cond (xorig, env)
474 SCM xorig;
475 SCM env;
476#endif
477{
478 SCM arg1, x = SCM_CDR (xorig);
479 int len = scm_ilength (x);
480 ASSYNT (len >= 1, xorig, s_clauses, "cond");
481 while (SCM_NIMP (x))
482 {
483 arg1 = SCM_CAR (x);
484 len = scm_ilength (arg1);
485 ASSYNT (len >= 1, xorig, s_clauses, "cond");
486 if (scm_i_else == SCM_CAR (arg1))
487 {
488 ASSYNT (SCM_NULLP (SCM_CDR (x)) && len >= 2, xorig, "bad ELSE clause", "cond");
489 SCM_CAR (arg1) = SCM_BOOL_T;
490 }
491 if (len >= 2 && scm_i_arrow == SCM_CAR (SCM_CDR (arg1)))
492 ASSYNT (3 == len && SCM_NIMP (SCM_CAR (SCM_CDR (SCM_CDR (arg1)))),
493 xorig, "bad recipient", "cond");
494 x = SCM_CDR (x);
495 }
496 return scm_cons (SCM_IM_COND, SCM_CDR (xorig));
497}
498
499
500#ifdef __STDC__
501SCM
502scm_m_lambda (SCM xorig, SCM env)
503#else
504SCM
505scm_m_lambda (xorig, env)
506 SCM xorig;
507 SCM env;
508#endif
509{
510 SCM proc, x = SCM_CDR (xorig);
511 if (scm_ilength (x) < 2)
512 goto badforms;
513 proc = SCM_CAR (x);
514 if SCM_NULLP
515 (proc) goto memlambda;
516 if SCM_IMP
517 (proc) goto badforms;
518 if SCM_SYMBOLP
519 (proc) goto memlambda;
520 if SCM_NCONSP
521 (proc) goto badforms;
522 while SCM_NIMP
523 (proc)
524 {
525 if SCM_NCONSP
526 (proc)
527 if (!SCM_SYMBOLP (proc))
528 goto badforms;
529 else
530 goto memlambda;
531 if (!(SCM_NIMP (SCM_CAR (proc)) && SCM_SYMBOLP (SCM_CAR (proc))))
532 goto badforms;
533 proc = SCM_CDR (proc);
534 }
535 if SCM_NNULLP
536 (proc)
537 badforms:scm_wta (xorig, s_formals, "lambda");
538memlambda:
539 bodycheck (xorig, &SCM_CDR (x), "lambda");
540 return scm_cons (SCM_IM_LAMBDA, SCM_CDR (xorig));
541}
542
543
544#ifdef __STDC__
545SCM
546scm_m_letstar (SCM xorig, SCM env)
547#else
548SCM
549scm_m_letstar (xorig, env)
550 SCM xorig;
551 SCM env;
552#endif
553{
554 SCM x = SCM_CDR (xorig), arg1, proc, vars = SCM_EOL, *varloc = &vars;
555 int len = scm_ilength (x);
556 ASSYNT (len >= 2, xorig, s_body, "let*");
557 proc = SCM_CAR (x);
558 ASSYNT (scm_ilength (proc) >= 0, xorig, s_bindings, "let*");
559 while SCM_NIMP
560 (proc)
561 {
562 arg1 = SCM_CAR (proc);
563 ASSYNT (2 == scm_ilength (arg1), xorig, s_bindings, "let*");
564 ASSYNT (SCM_NIMP (SCM_CAR (arg1)) && SCM_SYMBOLP (SCM_CAR (arg1)), xorig, s_variable, "let*");
565 *varloc = scm_cons2 (SCM_CAR (arg1), SCM_CAR (SCM_CDR (arg1)), SCM_EOL);
566 varloc = &SCM_CDR (SCM_CDR (*varloc));
567 proc = SCM_CDR (proc);
568 }
569 x = scm_cons (vars, SCM_CDR (x));
570 bodycheck (xorig, &SCM_CDR (x), "let*");
571 return scm_cons (SCM_IM_LETSTAR, x);
572}
573
574/* DO gets the most radically altered syntax
575 (do ((<var1> <init1> <step1>)
576 (<var2> <init2>)
577 ... )
578 (<test> <return>)
579 <body>)
580 ;; becomes
581 (do_mem (varn ... var2 var1)
582 (<init1> <init2> ... <initn>)
583 (<test> <return>)
584 (<body>)
585 <step1> <step2> ... <stepn>) ;; missing steps replaced by var
586 */
587
588
589#ifdef __STDC__
590SCM
591scm_m_do (SCM xorig, SCM env)
592#else
593SCM
594scm_m_do (xorig, env)
595 SCM xorig;
596 SCM env;
597#endif
598{
599 SCM x = SCM_CDR (xorig), arg1, proc;
600 SCM vars = SCM_EOL, inits = SCM_EOL, steps = SCM_EOL;
601 SCM *initloc = &inits, *steploc = &steps;
602 int len = scm_ilength (x);
603 ASSYNT (len >= 2, xorig, s_test, "do");
604 proc = SCM_CAR (x);
605 ASSYNT (scm_ilength (proc) >= 0, xorig, s_bindings, "do");
606 while SCM_NIMP
607 (proc)
608 {
609 arg1 = SCM_CAR (proc);
610 len = scm_ilength (arg1);
611 ASSYNT (2 == len || 3 == len, xorig, s_bindings, "do");
612 ASSYNT (SCM_NIMP (SCM_CAR (arg1)) && SCM_SYMBOLP (SCM_CAR (arg1)), xorig, s_variable, "do");
613 /* vars reversed here, inits and steps reversed at evaluation */
614 vars = scm_cons (SCM_CAR (arg1), vars); /* variable */
615 arg1 = SCM_CDR (arg1);
616 *initloc = scm_cons (SCM_CAR (arg1), SCM_EOL); /* init */
617 initloc = &SCM_CDR (*initloc);
618 arg1 = SCM_CDR (arg1);
619 *steploc = scm_cons (SCM_IMP (arg1) ? SCM_CAR (vars) : SCM_CAR (arg1), SCM_EOL); /* step */
620 steploc = &SCM_CDR (*steploc);
621 proc = SCM_CDR (proc);
622 }
623 x = SCM_CDR (x);
624 ASSYNT (scm_ilength (SCM_CAR (x)) >= 1, xorig, s_test, "do");
625 x = scm_cons2 (SCM_CAR (x), SCM_CDR (x), steps);
626 x = scm_cons2 (vars, inits, x);
627 bodycheck (xorig, &SCM_CAR (SCM_CDR (SCM_CDR (x))), "do");
628 return scm_cons (SCM_IM_DO, x);
629}
630
631/* evalcar is small version of inline EVALCAR when we don't care about speed */
632#ifdef __STDC__
633static SCM
634evalcar (SCM x, SCM env)
635#else
636static SCM
637evalcar (x, env)
638 SCM x;
639 SCM env;
640#endif
641{
642 return XEVALCAR (x, env);
643}
644
645#ifdef __STDC__
646static SCM
647iqq (SCM form, SCM env, int depth)
648#else
649static SCM
650iqq (form, env, depth)
651 SCM form;
652 SCM env;
653 int depth;
654#endif
655{
656 SCM tmp;
657 int edepth = depth;
658 if SCM_IMP
659 (form) return form;
660 if (SCM_VECTORP (form))
661 {
662 long i = SCM_LENGTH (form);
663 SCM *data = SCM_VELTS (form);
664 tmp = SCM_EOL;
665 for (; --i >= 0;)
666 tmp = scm_cons (data[i], tmp);
667 return scm_vector (iqq (tmp, env, depth));
668 }
669 if SCM_NCONSP
670 (form) return form;
671 tmp = SCM_CAR (form);
672 if (scm_i_quasiquote == tmp)
673 {
674 depth++;
675 goto label;
676 }
677 if (scm_i_unquote == tmp)
678 {
679 --depth;
680 label:
681 form = SCM_CDR (form);
682 /* !!! might need a check here to be sure that form isn't a struct. */
683 SCM_ASSERT (SCM_NIMP (form) && SCM_ECONSP (form) && SCM_NULLP (SCM_CDR (form)),
684 form, SCM_ARG1, s_quasiquote);
685 if (0 == depth)
686 return evalcar (form, env);
687 return scm_cons2 (tmp, iqq (SCM_CAR (form), env, depth), SCM_EOL);
688 }
689 if (SCM_NIMP (tmp) && (scm_i_uq_splicing == SCM_CAR (tmp)))
690 {
691 tmp = SCM_CDR (tmp);
692 if (0 == --edepth)
693 return scm_append (scm_cons2 (evalcar (tmp, env), iqq (SCM_CDR (form), env, depth), SCM_EOL));
694 }
695 return scm_cons (iqq (SCM_CAR (form), env, edepth), iqq (SCM_CDR (form), env, depth));
696}
697
698/* Here are acros which return values rather than code. */
699
700#ifdef __STDC__
701SCM
702scm_m_quasiquote (SCM xorig, SCM env)
703#else
704SCM
705scm_m_quasiquote (xorig, env)
706 SCM xorig;
707 SCM env;
708#endif
709{
710 SCM x = SCM_CDR (xorig);
711 ASSYNT (scm_ilength (x) == 1, xorig, s_expression, s_quasiquote);
712 return iqq (SCM_CAR (x), env, 1);
713}
714
715#ifdef __STDC__
716SCM
717scm_m_delay (SCM xorig, SCM env)
718#else
719SCM
720scm_m_delay (xorig, env)
721 SCM xorig;
722 SCM env;
723#endif
724{
725 ASSYNT (scm_ilength (xorig) == 2, xorig, s_expression, s_delay);
726 xorig = SCM_CDR (xorig);
727 return scm_makprom (scm_closure (scm_cons2 (SCM_EOL, SCM_CAR (xorig), SCM_CDR (xorig)),
728 env));
729}
730
731#ifdef __STDC__
732static SCM
733env_top_level (SCM env)
734#else
735static SCM
736env_top_level (env)
737 SCM env;
738#endif
739{
740 while (SCM_NIMP(env))
741 {
742 if (SCM_BOOL_T == scm_procedure_p (SCM_CAR(env)))
743 return SCM_CAR(env);
744 env = SCM_CDR (env);
745 }
746 return SCM_BOOL_F;
747}
748
749#ifdef __STDC__
750SCM
751scm_m_define (SCM x, SCM env)
752#else
753SCM
754scm_m_define (x, env)
755 SCM x;
756 SCM env;
757#endif
758{
759 SCM proc, arg1 = x;
760 x = SCM_CDR (x);
761 /* ASSYNT(SCM_NULLP(env), x, "bad placement", s_define);*/
762 ASSYNT (scm_ilength (x) >= 2, arg1, s_expression, "define");
763 proc = SCM_CAR (x);
764 x = SCM_CDR (x);
765 while (SCM_NIMP (proc) && SCM_CONSP (proc))
766 { /* nested define syntax */
767 x = scm_cons (scm_cons2 (scm_i_lambda, SCM_CDR (proc), x), SCM_EOL);
768 proc = SCM_CAR (proc);
769 }
770 ASSYNT (SCM_NIMP (proc) && SCM_SYMBOLP (proc), arg1, s_variable, "define");
771 ASSYNT (1 == scm_ilength (x), arg1, s_expression, "define");
772 if (SCM_TOP_LEVEL (env))
773 {
774 x = evalcar (x, env);
775 arg1 = scm_sym2vcell (proc, env_top_level (env), SCM_BOOL_T);
776#if 0
777#ifndef RECKLESS
778 if (SCM_NIMP (SCM_CDR (arg1)) && ((SCM) SCM_SNAME (SCM_CDR (arg1)) == proc)
779 && (SCM_CDR (arg1) != x))
780 scm_warn ("redefining built-in ", SCM_CHARS (proc));
781 else
782#endif
783 if (5 <= scm_verbose && SCM_UNDEFINED != SCM_CDR (arg1))
784 scm_warn ("redefining ", SCM_CHARS (proc));
785#endif
786#ifdef DEBUG_EXTENSIONS
787 if (RECORD_PROCNAMES && SCM_NIMP (x) && SCM_CLOSUREP (x))
788 scm_set_procedure_property_x (x, scm_i_name, proc);
789#endif
790 SCM_CDR (arg1) = x;
791#ifdef SICP
792 return scm_cons2 (scm_i_quote, SCM_CAR (arg1), SCM_EOL);
793#else
794 return SCM_UNSPECIFIED;
795#endif
796 }
797 return scm_cons2 (SCM_IM_DEFINE, proc, x);
798}
799/* end of acros */
800
801#ifdef __STDC__
802SCM
803scm_m_letrec (SCM xorig, SCM env)
804#else
805SCM
806scm_m_letrec (xorig, env)
807 SCM xorig;
808 SCM env;
809#endif
810{
811 SCM cdrx = SCM_CDR (xorig); /* locally mutable version of form */
812 char *what = SCM_CHARS (SCM_CAR (xorig));
813 SCM x = cdrx, proc, arg1; /* structure traversers */
814 SCM vars = SCM_EOL, inits = SCM_EOL, *initloc = &inits;
815
816 ASRTSYNTAX (scm_ilength (x) >= 2, s_body);
817 proc = SCM_CAR (x);
818 if SCM_NULLP
819 (proc) return scm_m_letstar (xorig, env); /* null binding, let* faster */
820 ASRTSYNTAX (scm_ilength (proc) >= 1, s_bindings);
821 do
822 {
823 /* vars scm_list reversed here, inits reversed at evaluation */
824 arg1 = SCM_CAR (proc);
825 ASRTSYNTAX (2 == scm_ilength (arg1), s_bindings);
826 ASRTSYNTAX (SCM_NIMP (SCM_CAR (arg1)) && SCM_SYMBOLP (SCM_CAR (arg1)), s_variable);
827 vars = scm_cons (SCM_CAR (arg1), vars);
828 *initloc = scm_cons (SCM_CAR (SCM_CDR (arg1)), SCM_EOL);
829 initloc = &SCM_CDR (*initloc);
830 }
831 while SCM_NIMP
832 (proc = SCM_CDR (proc));
833 cdrx = scm_cons2 (vars, inits, SCM_CDR (x));
834 bodycheck (xorig, &SCM_CDR (SCM_CDR (cdrx)), what);
835 return scm_cons (SCM_IM_LETREC, cdrx);
836}
837
838#ifdef __STDC__
839SCM
840scm_m_let (SCM xorig, SCM env)
841#else
842SCM
843scm_m_let (xorig, env)
844 SCM xorig;
845 SCM env;
846#endif
847{
848 SCM cdrx = SCM_CDR (xorig); /* locally mutable version of form */
849 SCM x = cdrx, proc, arg1, name; /* structure traversers */
850 SCM vars = SCM_EOL, inits = SCM_EOL, *varloc = &vars, *initloc = &inits;
851
852 ASSYNT (scm_ilength (x) >= 2, xorig, s_body, "let");
853 proc = SCM_CAR (x);
854 if (SCM_NULLP (proc)
855 || (SCM_NIMP (proc) && SCM_CONSP (proc)
856 && SCM_NIMP (SCM_CAR (proc)) && SCM_CONSP (SCM_CAR (proc)) && SCM_NULLP (SCM_CDR (proc))))
857 return scm_m_letstar (xorig, env); /* null or single binding, let* is faster */
858 ASSYNT (SCM_NIMP (proc), xorig, s_bindings, "let");
859 if (SCM_CONSP (proc)) /* plain let, proc is <bindings> */
860 return scm_cons (SCM_IM_LET, SCM_CDR (scm_m_letrec (xorig, env)));
861 if (!SCM_SYMBOLP (proc))
862 scm_wta (xorig, s_bindings, "let"); /* bad let */
863 name = proc; /* named let, build equiv letrec */
864 x = SCM_CDR (x);
865 ASSYNT (scm_ilength (x) >= 2, xorig, s_body, "let");
866 proc = SCM_CAR (x); /* bindings scm_list */
867 ASSYNT (scm_ilength (proc) >= 0, xorig, s_bindings, "let");
868 while SCM_NIMP
869 (proc)
870 { /* vars and inits both in order */
871 arg1 = SCM_CAR (proc);
872 ASSYNT (2 == scm_ilength (arg1), xorig, s_bindings, "let");
873 ASSYNT (SCM_NIMP (SCM_CAR (arg1)) && SCM_SYMBOLP (SCM_CAR (arg1)), xorig, s_variable, "let");
874 *varloc = scm_cons (SCM_CAR (arg1), SCM_EOL);
875 varloc = &SCM_CDR (*varloc);
876 *initloc = scm_cons (SCM_CAR (SCM_CDR (arg1)), SCM_EOL);
877 initloc = &SCM_CDR (*initloc);
878 proc = SCM_CDR (proc);
879 }
880 return
881 scm_m_letrec (scm_cons2 (scm_i_let,
882 scm_cons (scm_cons2 (name, scm_cons2 (scm_i_lambda, vars, SCM_CDR (x)), SCM_EOL), SCM_EOL),
883 scm_acons (name, inits, SCM_EOL)), /* body */
884 env);
885}
886
887
888#ifdef __STDC__
889SCM
890scm_m_apply (SCM xorig, SCM env)
891#else
892SCM
893scm_m_apply (xorig, env)
894 SCM xorig;
895 SCM env;
896#endif
897{
898 ASSYNT (scm_ilength (SCM_CDR (xorig)) == 2, xorig, s_expression, "@apply");
899 return scm_cons (SCM_IM_APPLY, SCM_CDR (xorig));
900}
901
902#define s_atcall_cc (SCM_ISYMSCM_CHARS(SCM_IM_CONT)+1)
903
904#ifdef __STDC__
905SCM
906scm_m_cont (SCM xorig, SCM env)
907#else
908SCM
909scm_m_cont (xorig, env)
910 SCM xorig;
911 SCM env;
912#endif
913{
914 ASSYNT (scm_ilength (SCM_CDR (xorig)) == 1, xorig, s_expression, "@call-with-current-continuation");
915 return scm_cons (SCM_IM_CONT, SCM_CDR (xorig));
916}
917
918#ifndef RECKLESS
919#ifdef __STDC__
920int
921scm_badargsp (SCM formals, SCM args)
922#else
923int
924scm_badargsp (formals, args)
925 SCM formals;
926 SCM args;
927#endif
928{
929 while SCM_NIMP
930 (formals)
931 {
932 if SCM_NCONSP
933 (formals) return 0;
934 if SCM_IMP
935 (args) return 1;
936 formals = SCM_CDR (formals);
937 args = SCM_CDR (args);
938 }
939 return SCM_NNULLP (args) ? 1 : 0;
940}
941#endif
942
943
944\f
945long scm_tc16_macro;
946
947#endif /* !DEVAL */
948
949#ifdef DEVAL
950#undef SCM_EVAL_ARGS
951#define SCM_EVAL_ARGS scm_deval_args
952#undef SCM_CEVAL
953#define SCM_CEVAL scm_deval /* Substitute all uses of scm_ceval */
954#undef SCM_APPLY
955#define SCM_APPLY scm_dapply
956#undef RETURN
957#define RETURN(e) {proc = (e); goto exit;}
958#else
959#define SCM_EVAL_ARGS scm_eval_args
960#define RETURN(x) return x;
961#endif
962
963SCM
964SCM_EVAL_ARGS (l, env)
965 SCM l, env;
966{
967 SCM res = SCM_EOL, *lloc = &res;
968 while (SCM_NIMP (l))
969 {
970 *lloc = scm_cons (EVALCAR (l, env), SCM_EOL);
971 lloc = &SCM_CDR (*lloc);
972 l = SCM_CDR (l);
973 }
974 return res;
975}
976
977#if 0
978#ifdef __STDC__
979SCM
980scm_ceval (SCM x, SCM env)
981#else
982SCM
983scm_ceval (x, env)
984 SCM x;
985 SCM env;
986#endif
987{}
988#endif
989#if 0
990#ifdef __STDC__
991SCM
992scm_deval (SCM x, SCM env)
993#else
994SCM
995scm_deval (x, env)
996 SCM x;
997 SCM env;
998#endif
999{}
1000#endif
1001
1002#ifdef SCM_FLOATS
1003#define CHECK_EQVISH(A,B) (((A) == (B)) || (SCM_NFALSEP (scm_eqv_p ((A), (B)))))
1004#else
1005#define CHECK_EQVISH(A,B) ((A) == (B))
1006#endif
1007
1008
1009SCM
1010SCM_CEVAL (x, env)
1011 SCM x;
1012 SCM env;
1013{
1014 union
1015 {
1016 SCM *lloc;
1017 SCM arg1;
1018 } t;
1019 SCM proc;
1020 SCM arg2;
1021
1022 SCM_CHECK_STACK;
1023
1024 loop:
1025 SCM_ASYNC_TICK;
1026
1027 switch (SCM_TYP7 (x))
1028 {
1029 case scm_tcs_symbols:
1030 /* Only happens when called at top level.
1031 */
1032 x = scm_cons (x, SCM_UNDEFINED);
1033 goto retval;
1034
1035 case (127 & SCM_IM_AND):
1036 x = SCM_CDR (x);
1037 t.arg1 = x;
1038 while (SCM_NNULLP (t.arg1 = SCM_CDR (t.arg1)))
1039 if (SCM_FALSEP (EVALCAR (x, env)))
1040 {
1041 RETURN (SCM_BOOL_F);
1042 }
1043 else
1044 x = t.arg1;
1045 goto carloop;
1046
1047 case (127 & SCM_IM_BEGIN):
1048
1049 cdrxbegin:
1050 x = SCM_CDR (x);
1051
1052 begin:
1053 t.arg1 = x;
1054 while (SCM_NNULLP (t.arg1 = SCM_CDR (t.arg1)))
1055 {
1056 SIDEVAL (SCM_CAR (x), env);
1057 x = t.arg1;
1058 }
1059
1060 carloop: /* scm_eval car of last form in list */
1061 if (SCM_NCELLP (SCM_CAR (x)))
1062 {
1063 x = SCM_CAR (x);
1064 RETURN (SCM_IMP (x) ? EVALIMP (x, env) : SCM_GLOC_VAL (x));
1065 }
1066
1067 if (SCM_SYMBOLP (SCM_CAR (x)))
1068 {
1069 retval:
1070 RETURN (*scm_lookupcar (x, env));
1071 }
1072
1073 x = SCM_CAR (x);
1074 goto loop; /* tail recurse */
1075
1076
1077 case (127 & SCM_IM_CASE):
1078 x = SCM_CDR (x);
1079 t.arg1 = EVALCAR (x, env);
1080 while (SCM_NIMP (x = SCM_CDR (x)))
1081 {
1082 proc = SCM_CAR (x);
1083 if (scm_i_else == SCM_CAR (proc))
1084 {
1085 x = SCM_CDR (proc);
1086 goto begin;
1087 }
1088 proc = SCM_CAR (proc);
1089 while (SCM_NIMP (proc))
1090 {
1091 if (CHECK_EQVISH (SCM_CAR (proc), t.arg1))
1092 {
1093 x = SCM_CDR (SCM_CAR (x));
1094 goto begin;
1095 }
1096 proc = SCM_CDR (proc);
1097 }
1098 }
1099 RETURN (SCM_UNSPECIFIED);
1100
1101
1102 case (127 & SCM_IM_COND):
1103 while (SCM_NIMP (x = SCM_CDR (x)))
1104 {
1105 proc = SCM_CAR (x);
1106 t.arg1 = EVALCAR (proc, env);
1107 if (SCM_NFALSEP (t.arg1))
1108 {
1109 x = SCM_CDR (proc);
1110 if (SCM_NULLP (x))
1111 {
1112 RETURN (t.arg1);
1113 }
1114 if (scm_i_arrow != SCM_CAR (x))
1115 goto begin;
1116 proc = SCM_CDR (x);
1117 proc = EVALCAR (proc, env);
1118 SCM_ASRTGO (SCM_NIMP (proc), badfun);
1119 goto evap1;
1120 }
1121 }
1122 RETURN (SCM_UNSPECIFIED);
1123
1124
1125 case (127 & SCM_IM_DO):
1126 x = SCM_CDR (x);
1127 proc = SCM_CAR (SCM_CDR (x)); /* inits */
1128 t.arg1 = SCM_EOL; /* values */
1129 while (SCM_NIMP (proc))
1130 {
1131 t.arg1 = scm_cons (EVALCAR (proc, env), t.arg1);
1132 proc = SCM_CDR (proc);
1133 }
1134 env = EXTEND_SCM_ENV (SCM_CAR (x), t.arg1, env);
1135 x = SCM_CDR (SCM_CDR (x));
1136 while (proc = SCM_CAR (x), SCM_FALSEP (EVALCAR (proc, env)))
1137 {
1138 for (proc = SCM_CAR (SCM_CDR (x)); SCM_NIMP (proc); proc = SCM_CDR (proc))
1139 {
1140 t.arg1 = SCM_CAR (proc); /* body */
1141 SIDEVAL (t.arg1, env);
1142 }
1143 for (t.arg1 = SCM_EOL, proc = SCM_CDR (SCM_CDR (x)); SCM_NIMP (proc); proc = SCM_CDR (proc))
1144 t.arg1 = scm_cons (EVALCAR (proc, env), t.arg1); /* steps */
1145 env = EXTEND_SCM_ENV (SCM_CAR (SCM_CAR (env)), t.arg1, SCM_CDR (env));
1146 }
1147 x = SCM_CDR (proc);
1148 if (SCM_NULLP (x))
1149 {
1150 RETURN (SCM_UNSPECIFIED);
1151 }
1152 goto begin;
1153
1154
1155 case (127 & SCM_IM_IF):
1156 x = SCM_CDR (x);
1157 if (SCM_NFALSEP (EVALCAR (x, env)))
1158 x = SCM_CDR (x);
1159 else if (SCM_IMP (x = SCM_CDR (SCM_CDR (x))))
1160 {
1161 RETURN (SCM_UNSPECIFIED);
1162 }
1163 goto carloop;
1164
1165
1166 case (127 & SCM_IM_LET):
1167 x = SCM_CDR (x);
1168 proc = SCM_CAR (SCM_CDR (x));
1169 t.arg1 = SCM_EOL;
1170 do
1171 {
1172 t.arg1 = scm_cons (EVALCAR (proc, env), t.arg1);
1173 }
1174 while (SCM_NIMP (proc = SCM_CDR (proc)));
1175 env = EXTEND_SCM_ENV (SCM_CAR (x), t.arg1, env);
1176 x = SCM_CDR (x);
1177 goto cdrxbegin;
1178
1179
1180 case (127 & SCM_IM_LETREC):
1181 x = SCM_CDR (x);
1182 env = EXTEND_SCM_ENV (SCM_CAR (x), scm_undefineds, env);
1183 x = SCM_CDR (x);
1184 proc = SCM_CAR (x);
1185 t.arg1 = SCM_EOL;
1186 do
1187 {
1188 t.arg1 = scm_cons (EVALCAR (proc, env), t.arg1);
1189 }
1190 while (SCM_NIMP (proc = SCM_CDR (proc)));
1191 SCM_CDR (SCM_CAR (env)) = t.arg1;
1192 goto cdrxbegin;
1193
1194
1195 case (127 & SCM_IM_LETSTAR):
1196 x = SCM_CDR (x);
1197 proc = SCM_CAR (x);
1198 if (SCM_IMP (proc))
1199 {
1200 env = EXTEND_SCM_ENV (SCM_EOL, SCM_EOL, env);
1201 goto cdrxbegin;
1202 }
1203 do
1204 {
1205 t.arg1 = SCM_CAR (proc);
1206 proc = SCM_CDR (proc);
1207 env = EXTEND_SCM_ENV (t.arg1, EVALCAR (proc, env), env);
1208 }
1209 while (SCM_NIMP (proc = SCM_CDR (proc)));
1210 goto cdrxbegin;
1211
1212 case (127 & SCM_IM_OR):
1213 x = SCM_CDR (x);
1214 t.arg1 = x;
1215 while (SCM_NNULLP (t.arg1 = SCM_CDR (t.arg1)))
1216 {
1217 x = EVALCAR (x, env);
1218 if (SCM_NFALSEP (x))
1219 {
1220 RETURN (x);
1221 }
1222 x = t.arg1;
1223 }
1224 goto carloop;
1225
1226
1227 case (127 & SCM_IM_LAMBDA):
1228 RETURN (scm_closure (SCM_CDR (x), env));
1229
1230
1231 case (127 & SCM_IM_QUOTE):
1232 RETURN (SCM_CAR (SCM_CDR (x)));
1233
1234
1235 case (127 & SCM_IM_SET):
1236 set_some_more:
1237 x = SCM_CDR (x);
1238 proc = SCM_CAR (x);
1239 switch (7 & (int)proc)
1240 {
1241 case 0:
1242 t.lloc = scm_lookupcar (x, env);
1243 break;
1244 case 1:
1245 t.lloc = &SCM_GLOC_VAL (proc);
1246 break;
1247#ifdef MEMOIZE_LOCALS
1248 case 4:
1249 t.lloc = scm_ilookup (proc, env);
1250 break;
1251#endif
1252 }
1253 x = SCM_CDR (x);
1254 *t.lloc = EVALCAR (x, env);
1255 if (!SCM_NULLP (SCM_CDR(x)))
1256 goto set_some_more;
1257#ifdef SICP
1258 RETURN (*t.lloc);
1259#else
1260 RETURN (SCM_UNSPECIFIED);
1261#endif
1262
1263
1264 case (127 & SCM_IM_DEFINE): /* only for internal defines */
1265 x = SCM_CDR (x);
1266 proc = SCM_CAR (x);
1267 x = SCM_CDR (x);
1268 x = evalcar (x, env);
1269 env = SCM_CAR (env);
1270 SCM_DEFER_INTS;
1271 SCM_CAR (env) = scm_cons (proc, SCM_CAR (env));
1272 SCM_CDR (env) = scm_cons (x, SCM_CDR (env));
1273 SCM_ALLOW_INTS;
1274 RETURN (SCM_UNSPECIFIED);
1275
1276
1277
1278 /* new syntactic forms go here. */
1279 case (127 & SCM_MAKISYM (0)):
1280 proc = SCM_CAR (x);
1281 SCM_ASRTGO (SCM_ISYMP (proc), badfun);
1282 switch SCM_ISYMNUM (proc)
1283 {
1284#if 0
1285 case (SCM_ISYMNUM (IM_VREF)):
1286 {
1287 SCM var;
1288 var = SCM_CAR (SCM_CDR (x));
1289 RETURN (SCM_CDR(var));
1290 }
1291 case (SCM_ISYMNUM (IM_VSET)):
1292 SCM_CDR (SCM_CAR ( SCM_CDR (x))) = EVALCAR( SCM_CDR ( SCM_CDR (x)), env);
1293 SCM_CAR (SCM_CAR ( SCM_CDR (x))) = scm_tc16_variable;
1294 RETURN (SCM_UNSPECIFIED);
1295#endif
1296
1297 case (SCM_ISYMNUM (SCM_IM_APPLY)):
1298 proc = SCM_CDR (x);
1299 proc = EVALCAR (proc, env);
1300 SCM_ASRTGO (SCM_NIMP (proc), badfun);
1301 if (SCM_CLOSUREP (proc))
1302 {
1303 t.arg1 = SCM_CDR (SCM_CDR (x));
1304 t.arg1 = EVALCAR (t.arg1, env);
1305#ifndef RECKLESS
1306 if (scm_badargsp (SCM_CAR (SCM_CODE (proc)), t.arg1))
1307 goto wrongnumargs;
1308#endif
1309 env = EXTEND_SCM_ENV (SCM_CAR (SCM_CODE (proc)), t.arg1, SCM_ENV (proc));
1310 x = SCM_CODE (proc);
1311 goto cdrxbegin;
1312 }
1313 proc = scm_i_apply;
1314 goto evapply;
1315
1316 case (SCM_ISYMNUM (SCM_IM_CONT)):
1317 scm_make_cont (&t.arg1);
1318 if (setjmp (SCM_JMPBUF (t.arg1)))
1319 {
1320 SCM val;
1321 val = SCM_THROW_VALUE (t.arg1);
1322 RETURN (val);;
1323 }
1324 proc = SCM_CDR (x);
1325 proc = evalcar (proc, env);
1326 SCM_ASRTGO (SCM_NIMP (proc), badfun);
1327 goto evap1;
1328
1329 default:
1330 goto badfun;
1331 }
1332
1333 default:
1334 proc = x;
1335 badfun:
1336 scm_everr (x, env, proc, "Wrong type to apply: ", "");
1337
1338 case scm_tc7_vector:
1339 case scm_tc7_wvect:
1340 case scm_tc7_bvect:
1341 case scm_tc7_byvect:
1342 case scm_tc7_svect:
1343 case scm_tc7_ivect:
1344 case scm_tc7_uvect:
1345 case scm_tc7_fvect:
1346 case scm_tc7_dvect:
1347 case scm_tc7_cvect:
1348#ifdef LONGLONGS
1349 case scm_tc7_llvect:
1350#endif
1351 case scm_tc7_string:
1352 case scm_tc7_mb_string:
1353 case scm_tc7_substring:
1354 case scm_tc7_mb_substring:
1355 case scm_tc7_smob:
1356 case scm_tcs_closures:
1357 case scm_tcs_subrs:
1358 RETURN (x);
1359
1360#ifdef MEMOIZE_LOCALS
1361 case (127 & SCM_ILOC00):
1362 proc = *scm_ilookup (SCM_CAR (x), env);
1363 SCM_ASRTGO (SCM_NIMP (proc), badfun);
1364#ifndef RECKLESS
1365#ifdef CAUTIOUS
1366 goto checkargs;
1367#endif
1368#endif
1369 break;
1370#endif /* ifdef MEMOIZE_LOCALS */
1371
1372
1373 case scm_tcs_cons_gloc:
1374 proc = SCM_GLOC_VAL (SCM_CAR (x));
1375 SCM_ASRTGO (SCM_NIMP (proc), badfun);
1376#ifndef RECKLESS
1377#ifdef CAUTIOUS
1378 goto checkargs;
1379#endif
1380#endif
1381 break;
1382
1383
1384 case scm_tcs_cons_nimcar:
1385 if (SCM_SYMBOLP (SCM_CAR (x)))
1386 {
1387 proc = *scm_lookupcar (x, env);
1388 if (SCM_IMP (proc))
1389 {
1390 unmemocar (x, env);
1391 goto badfun;
1392 }
1393 if (scm_tc16_macro == SCM_TYP16 (proc))
1394 {
1395 unmemocar (x, env);
1396
1397 handle_a_macro:
1398 t.arg1 = SCM_APPLY (SCM_CDR (proc), x, scm_cons (env, scm_listofnull));
1399 switch ((int) (SCM_CAR (proc) >> 16))
1400 {
1401 case 2:
1402 if (scm_ilength (t.arg1) <= 0)
1403 t.arg1 = scm_cons2 (SCM_IM_BEGIN, t.arg1, SCM_EOL);
1404 SCM_DEFER_INTS;
1405 SCM_CAR (x) = SCM_CAR (t.arg1);
1406 SCM_CDR (x) = SCM_CDR (t.arg1);
1407 SCM_ALLOW_INTS;
1408 goto loop;
1409 case 1:
1410 if (SCM_NIMP (x = t.arg1))
1411 goto loop;
1412 case 0:
1413 RETURN (t.arg1);
1414 }
1415 }
1416 }
1417 else
1418 proc = SCM_CEVAL (SCM_CAR (x), env);
1419 SCM_ASRTGO (SCM_NIMP (proc), badfun);
1420#ifndef RECKLESS
1421#ifdef CAUTIOUS
1422 checkargs:
1423#endif
1424 if (SCM_CLOSUREP (proc))
1425 {
1426 arg2 = SCM_CAR (SCM_CODE (proc));
1427 t.arg1 = SCM_CDR (x);
1428 while (SCM_NIMP (arg2))
1429 {
1430 if (SCM_NCONSP (arg2))
1431 goto evapply;
1432 if (SCM_IMP (t.arg1))
1433 goto umwrongnumargs;
1434 arg2 = SCM_CDR (arg2);
1435 t.arg1 = SCM_CDR (t.arg1);
1436 }
1437 if (SCM_NNULLP (t.arg1))
1438 goto umwrongnumargs;
1439 }
1440 else if (scm_tc16_macro == SCM_TYP16 (proc))
1441 goto handle_a_macro;
1442#endif
1443 }
1444
1445
1446 evapply:
1447 if (SCM_NULLP (SCM_CDR (x)))
1448 switch (SCM_TYP7 (proc))
1449 { /* no arguments given */
1450 case scm_tc7_subr_0:
1451 RETURN (SCM_SUBRF (proc) ());
1452 case scm_tc7_subr_1o:
1453 RETURN (SCM_SUBRF (proc) (SCM_UNDEFINED));
1454 case scm_tc7_lsubr:
1455 RETURN (SCM_SUBRF (proc) (SCM_EOL));
1456 case scm_tc7_rpsubr:
1457 RETURN (SCM_BOOL_T);
1458 case scm_tc7_asubr:
1459 RETURN (SCM_SUBRF (proc) (SCM_UNDEFINED, SCM_UNDEFINED));
1460 case scm_tc7_cclo:
1461 t.arg1 = proc;
1462 proc = SCM_CCLO_SUBR (proc);
1463 goto evap1;
1464 case scm_tcs_closures:
1465 x = SCM_CODE (proc);
1466 env = EXTEND_SCM_ENV (SCM_CAR (x), SCM_EOL, SCM_ENV (proc));
1467 goto cdrxbegin;
1468 case scm_tc7_contin:
1469 case scm_tc7_subr_1:
1470 case scm_tc7_subr_2:
1471 case scm_tc7_subr_2o:
1472 case scm_tc7_cxr:
1473 case scm_tc7_subr_3:
1474 case scm_tc7_lsubr_2:
1475 umwrongnumargs:
1476 unmemocar (x, env);
1477 wrongnumargs:
1478 scm_everr (x, env, proc, (char *) SCM_WNA, "");
1479 default:
1480 /* handle macros here */
1481 goto badfun;
1482 }
1483
1484
1485 /* must handle macros by here */
1486 x = SCM_CDR (x);
1487#ifdef CAUTIOUS
1488 if (SCM_IMP (x))
1489 goto wrongnumargs;
1490#endif
1491 t.arg1 = EVALCAR (x, env);
1492 x = SCM_CDR (x);
1493 if (SCM_NULLP (x))
1494 {
1495 evap1:
1496 switch (SCM_TYP7 (proc))
1497 { /* have one argument in t.arg1 */
1498 case scm_tc7_subr_2o:
1499 RETURN (SCM_SUBRF (proc) (t.arg1, SCM_UNDEFINED));
1500 case scm_tc7_subr_1:
1501 case scm_tc7_subr_1o:
1502 RETURN (SCM_SUBRF (proc) (t.arg1));
1503 case scm_tc7_cxr:
1504#ifdef SCM_FLOATS
1505 if (SCM_SUBRF (proc))
1506 {
1507 if (SCM_INUMP (t.arg1))
1508 {
1509 RETURN (scm_makdbl (SCM_DSUBRF (proc) ((double) SCM_INUM (t.arg1)),
1510 0.0));
1511 }
1512 SCM_ASRTGO (SCM_NIMP (t.arg1), floerr);
1513 if (SCM_REALP (t.arg1))
1514 {
1515 RETURN (scm_makdbl (SCM_DSUBRF (proc) (SCM_REALPART (t.arg1)), 0.0));
1516 }
1517#ifdef SCM_BIGDIG
1518 if (SCM_BIGP (t.arg1))
1519 {
1520 RETURN (scm_makdbl (SCM_DSUBRF (proc) (scm_big2dbl (t.arg1)), 0.0));
1521 }
1522#endif
1523 floerr:
1524 scm_wta (t.arg1, (char *) SCM_ARG1, SCM_CHARS (SCM_SNAME (proc)));
1525 }
1526#endif
1527 proc = (SCM) SCM_SNAME (proc);
1528 {
1529 char *chrs = SCM_CHARS (proc) + SCM_LENGTH (proc) - 1;
1530 while ('c' != *--chrs)
1531 {
1532 SCM_ASSERT (SCM_NIMP (t.arg1) && SCM_CONSP (t.arg1),
1533 t.arg1, SCM_ARG1, SCM_CHARS (proc));
1534 t.arg1 = ('a' == *chrs) ? SCM_CAR (t.arg1) : SCM_CDR (t.arg1);
1535 }
1536 RETURN (t.arg1);
1537 }
1538 case scm_tc7_rpsubr:
1539 RETURN (SCM_BOOL_T);
1540 case scm_tc7_asubr:
1541 RETURN (SCM_SUBRF (proc) (t.arg1, SCM_UNDEFINED));
1542 case scm_tc7_lsubr:
1543#ifdef DEVAL
1544 RETURN (SCM_SUBRF (proc) (dbg_info.args));
1545#else
1546 RETURN (SCM_SUBRF (proc) (scm_cons (t.arg1, SCM_EOL)));
1547#endif
1548 case scm_tc7_cclo:
1549 arg2 = t.arg1;
1550 t.arg1 = proc;
1551 proc = SCM_CCLO_SUBR (proc);
1552 goto evap2;
1553 case scm_tcs_closures:
1554 x = SCM_CODE (proc);
1555#ifdef DEVAL
1556 env = EXTEND_SCM_ENV (SCM_CAR (x), dbg_info.args, SCM_ENV (proc));
1557#else
1558 env = EXTEND_SCM_ENV (SCM_CAR (x), scm_cons (t.arg1, SCM_EOL), SCM_ENV (proc));
1559#endif
1560 goto cdrxbegin;
1561 case scm_tc7_contin:
1562 scm_call_continuation (proc, t.arg1);
1563 case scm_tc7_subr_2:
1564 case scm_tc7_subr_0:
1565 case scm_tc7_subr_3:
1566 case scm_tc7_lsubr_2:
1567 goto wrongnumargs;
1568 default:
1569 goto badfun;
1570 }
1571 }
1572#ifdef CAUTIOUS
1573 if (SCM_IMP (x))
1574 goto wrongnumargs;
1575#endif
1576 { /* have two or more arguments */
1577 arg2 = EVALCAR (x, env);
1578 x = SCM_CDR (x);
1579 if (SCM_NULLP (x)) {
1580#ifdef CCLO
1581 evap2:
1582#endif
1583#ifdef DEVAL
1584 dbg_info.args = scm_cons2 (t.arg1, arg2, SCM_EOL);
1585#endif
1586 switch SCM_TYP7
1587 (proc)
1588 { /* have two arguments */
1589 case scm_tc7_subr_2:
1590 case scm_tc7_subr_2o:
1591 RETURN (SCM_SUBRF (proc) (t.arg1, arg2));
1592 case scm_tc7_lsubr:
1593#ifdef DEVAL
1594 RETURN (SCM_SUBRF (proc) (dbg_info.args));
1595#else
1596 RETURN (SCM_SUBRF (proc) (scm_cons2 (t.arg1, arg2, SCM_EOL)));
1597#endif
1598 case scm_tc7_lsubr_2:
1599 RETURN (SCM_SUBRF (proc) (t.arg1, arg2, SCM_EOL));
1600 case scm_tc7_rpsubr:
1601 case scm_tc7_asubr:
1602 RETURN (SCM_SUBRF (proc) (t.arg1, arg2));
1603#ifdef CCLO
1604 cclon: case scm_tc7_cclo:
1605 RETURN (SCM_APPLY (SCM_CCLO_SUBR (proc), proc,
1606 scm_cons2 (t.arg1, arg2, scm_cons (SCM_EVAL_ARGS (x, env), SCM_EOL))));
1607 /* case scm_tc7_cclo:
1608 x = scm_cons(arg2, scm_eval_args(x, env));
1609 arg2 = t.arg1;
1610 t.arg1 = proc;
1611 proc = SCM_CCLO_SUBR(proc);
1612 goto evap3; */
1613#endif
1614 case scm_tc7_subr_0:
1615 case scm_tc7_cxr:
1616 case scm_tc7_subr_1o:
1617 case scm_tc7_subr_1:
1618 case scm_tc7_subr_3:
1619 case scm_tc7_contin:
1620 goto wrongnumargs;
1621 default:
1622 goto badfun;
1623 case scm_tcs_closures:
1624#ifdef DEVAL
1625 env = EXTEND_SCM_ENV (SCM_CAR (SCM_CODE (proc)), dbg_info.args, SCM_ENV (proc));
1626#else
1627 env = EXTEND_SCM_ENV (SCM_CAR (SCM_CODE (proc)), scm_cons2 (t.arg1, arg2, SCM_EOL), SCM_ENV (proc));
1628#endif
1629 x = SCM_CODE (proc);
1630 goto cdrxbegin;
1631 }
1632 }
1633#ifdef DEVAL
1634 dbg_info.args = scm_cons2 (t.arg1, arg2, scm_deval_args (x, env));
1635#endif
1636 switch SCM_TYP7
1637 (proc)
1638 { /* have 3 or more arguments */
1639#ifdef DEVAL
1640 case scm_tc7_subr_3:
1641 SCM_ASRTGO (SCM_NULLP (SCM_CDR (x)), wrongnumargs);
1642 RETURN (SCM_SUBRF (proc) (t.arg1, arg2, SCM_CAR (SCM_CDR (SCM_CDR (dbg_info.args)))));
1643 case scm_tc7_asubr:
1644 /* t.arg1 = SCM_SUBRF(proc)(t.arg1, arg2);
1645 while SCM_NIMP(x) {
1646 t.arg1 = SCM_SUBRF(proc)(t.arg1, EVALCAR(x, env));
1647 x = SCM_CDR(x);
1648 }
1649 RETURN (t.arg1) */
1650 case scm_tc7_rpsubr:
1651 RETURN (SCM_APPLY (proc, t.arg1, scm_acons (arg2, SCM_CDR (SCM_CDR (dbg_info.args)), SCM_EOL)));
1652 case scm_tc7_lsubr_2:
1653 RETURN (SCM_SUBRF (proc) (t.arg1, arg2, SCM_CDR (SCM_CDR (dbg_info.args))));
1654 case scm_tc7_lsubr:
1655 RETURN (SCM_SUBRF (proc) (dbg_info.args));
1656#ifdef CCLO
1657 case scm_tc7_cclo:
1658 goto cclon;
1659#endif
1660 case scm_tcs_closures:
1661 env = EXTEND_SCM_ENV (SCM_CAR (SCM_CODE (proc)),
1662 dbg_info.args,
1663 SCM_ENV (proc));
1664 x = SCM_CODE (proc);
1665 goto cdrxbegin;
1666#else
1667 case scm_tc7_subr_3:
1668 SCM_ASRTGO (SCM_NULLP (SCM_CDR (x)), wrongnumargs);
1669 RETURN (SCM_SUBRF (proc) (t.arg1, arg2, EVALCAR (x, env)));
1670 case scm_tc7_asubr:
1671 /* t.arg1 = SCM_SUBRF(proc)(t.arg1, arg2);
1672 while SCM_NIMP(x) {
1673 t.arg1 = SCM_SUBRF(proc)(t.arg1, EVALCAR(x, env));
1674 x = SCM_CDR(x);
1675 }
1676 RETURN (t.arg1) */
1677 case scm_tc7_rpsubr:
1678 RETURN (SCM_APPLY (proc, t.arg1, scm_acons (arg2, scm_eval_args (x, env), SCM_EOL)));
1679 case scm_tc7_lsubr_2:
1680 RETURN (SCM_SUBRF (proc) (t.arg1, arg2, scm_eval_args (x, env)));
1681 case scm_tc7_lsubr:
1682 RETURN (SCM_SUBRF (proc) (scm_cons2 (t.arg1, arg2, scm_eval_args (x, env))));
1683#ifdef CCLO
1684 case scm_tc7_cclo:
1685 goto cclon;
1686#endif
1687 case scm_tcs_closures:
1688 env = EXTEND_SCM_ENV (SCM_CAR (SCM_CODE (proc)),
1689 scm_cons2 (t.arg1, arg2, scm_eval_args (x, env)),
1690 SCM_ENV (proc));
1691 x = SCM_CODE (proc);
1692 goto cdrxbegin;
1693#endif /* DEVAL */
1694 case scm_tc7_subr_2:
1695 case scm_tc7_subr_1o:
1696 case scm_tc7_subr_2o:
1697 case scm_tc7_subr_0:
1698 case scm_tc7_cxr:
1699 case scm_tc7_subr_1:
1700 case scm_tc7_contin:
1701 goto wrongnumargs;
1702 default:
1703 goto badfun;
1704 }
1705 }
1706#ifdef DEVAL
1707 exit:
1708 if (CHECK_SCM_EXIT)
1709 {
1710 /* if (SINGLE_STEP) ... but this is always fulfilled. */
1711 SINGLE_STEP = 0;
1712 scm_make_cont (&t.arg1);
1713 if (setjmp (SCM_JMPBUF (t.arg1)))
1714 {
1715 proc = SCM_THROW_VALUE(t.arg1);
1716 goto ret;
1717 }
1718 scm_ithrow (exit_frame_sym, proc, 0);
1719 }
1720 ret:
1721 last_debug_info_frame = dbg_info.prev;
1722 return proc;
1723#endif
1724}
1725
1726#ifndef DEVAL
1727
1728SCM_PROC(s_procedure_documentation, "procedure-documentation", 1, 0, 0, scm_procedure_documentation);
1729#ifdef __STDC__
1730SCM
1731scm_procedure_documentation (SCM proc)
1732#else
1733SCM
1734scm_procedure_documentation (proc)
1735 SCM proc;
1736#endif
1737{
1738 SCM code;
1739 SCM_ASSERT (SCM_BOOL_T == scm_procedure_p (proc) && SCM_NIMP (proc) && SCM_TYP7 (proc) != scm_tc7_contin,
1740 proc, SCM_ARG1, s_procedure_documentation);
1741 switch (SCM_TYP7 (proc))
1742 {
1743 case scm_tcs_closures:
1744 code = SCM_CDR (SCM_CODE (proc));
1745 if (SCM_IMP (SCM_CDR (code)))
1746 return SCM_BOOL_F;
1747 code = SCM_CAR (code);
1748 if (SCM_IMP (code))
1749 return SCM_BOOL_F;
1750 if (SCM_STRINGP (code))
1751 return code;
1752 default:
1753 return SCM_BOOL_F;
1754/*
1755 case scm_tcs_subrs:
1756#ifdef CCLO
1757 case scm_tc7_cclo:
1758#endif
1759*/
1760 }
1761}
1762
1763/* This code is for scm_apply. it is destructive on multiple args.
1764 * This will only screw you if you do (scm_apply scm_apply '( ... ))
1765 */
1766SCM_PROC(s_nconc2last, "apply:nconc2last", 1, 0, 0, scm_nconc2last);
1767#ifdef __STDC__
1768SCM
1769scm_nconc2last (SCM lst)
1770#else
1771SCM
1772scm_nconc2last (lst)
1773 SCM lst;
1774#endif
1775{
1776 SCM *lloc;
1777 if (SCM_EOL == lst)
1778 return lst;
1779 SCM_ASSERT (SCM_NIMP (lst) && SCM_CONSP (lst), lst, SCM_ARG1, s_nconc2last);
1780 lloc = &lst;
1781 while (SCM_NNULLP (SCM_CDR (*lloc)))
1782 {
1783 lloc = &SCM_CDR (*lloc);
1784 SCM_ASSERT (SCM_NIMP (*lloc) && SCM_CONSP (*lloc), lst, SCM_ARG1, s_nconc2last);
1785 }
1786 *lloc = SCM_CAR (*lloc);
1787 return lst;
1788}
1789
1790#endif /* !DEVAL */
1791
1792#if 0
1793#ifdef __STDC__
1794SCM
1795scm_apply (SCM proc, SCM arg1, SCM args)
1796#else
1797SCM
1798scm_apply (proc, arg1, args)
1799 SCM proc;
1800 SCM arg1;
1801 SCM args;
1802#endif
1803{}
1804#endif
1805
1806#if 0
1807#ifdef __STDC__
1808SCM
1809scm_dapply (SCM proc, SCM arg1, SCM args)
1810#else
1811SCM
1812scm_dapply (proc, arg1, args)
1813 SCM proc;
1814 SCM arg1;
1815 SCM args;
1816#endif
1817{}
1818#endif
1819
1820
1821
1822#ifdef __STDC__
1823SCM
1824SCM_APPLY (SCM proc, SCM arg1, SCM args)
1825#else
1826SCM
1827SCM_APPLY (proc, arg1, args)
1828 SCM proc;
1829 SCM arg1;
1830 SCM args;
1831#endif
1832{
1833#ifdef DEBUG_EXTENSIONS
1834#ifdef DEVAL
1835 debug_info dbg_info;
1836 dbg_info.prev = last_debug_info_frame;
1837 dbg_info.exp = SCM_UNDEFINED;
1838 dbg_info.proc = proc;
1839 dbg_info.args = SCM_UNDEFINED;
1840 last_debug_info_frame = &dbg_info;
1841#else
1842 if (DEBUGGINGP)
1843 return scm_dapply (proc, arg1, args);
1844#endif
1845#endif
1846
1847 SCM_ASRTGO (SCM_NIMP (proc), badproc);
1848 if (SCM_NULLP (args))
1849 {
1850 if (SCM_NULLP (arg1))
1851 arg1 = SCM_UNDEFINED;
1852 else
1853 {
1854 args = SCM_CDR (arg1);
1855 arg1 = SCM_CAR (arg1);
1856 }
1857 }
1858 else
1859 {
1860 /* SCM_ASRTGO(SCM_NIMP(args) && SCM_CONSP(args), wrongnumargs); */
1861 args = scm_nconc2last (args);
1862 }
1863#ifdef CCLO
1864 tail:
1865#endif
1866#ifdef DEVAL
1867 dbg_info.args = scm_cons (arg1, args);
1868#endif
1869 switch (SCM_TYP7 (proc))
1870 {
1871 case scm_tc7_subr_2o:
1872 args = SCM_NULLP (args) ? SCM_UNDEFINED : SCM_CAR (args);
1873 RETURN (SCM_SUBRF (proc) (arg1, args))
1874 case scm_tc7_subr_2:
1875 SCM_ASRTGO (SCM_NULLP (SCM_CDR (args)), wrongnumargs);
1876 args = SCM_CAR (args);
1877 RETURN (SCM_SUBRF (proc) (arg1, args))
1878 case scm_tc7_subr_0:
1879 SCM_ASRTGO (SCM_UNBNDP (arg1), wrongnumargs);
1880 RETURN (SCM_SUBRF (proc) ())
1881 case scm_tc7_subr_1:
1882 case scm_tc7_subr_1o:
1883 SCM_ASRTGO (SCM_NULLP (args), wrongnumargs);
1884 RETURN (SCM_SUBRF (proc) (arg1))
1885 case scm_tc7_cxr:
1886 SCM_ASRTGO (SCM_NULLP (args), wrongnumargs);
1887#ifdef SCM_FLOATS
1888 if (SCM_SUBRF (proc))
1889 {
1890 if SCM_INUMP
1891 (arg1)
1892 RETURN (scm_makdbl (SCM_DSUBRF (proc) ((double) SCM_INUM (arg1)), 0.0))
1893 SCM_ASRTGO (SCM_NIMP (arg1), floerr);
1894 if SCM_REALP
1895 (arg1)
1896 RETURN (scm_makdbl (SCM_DSUBRF (proc) (SCM_REALPART (arg1)), 0.0))
1897#ifdef SCM_BIGDIG
1898 if SCM_BIGP
1899 (arg1)
1900 RETURN (scm_makdbl (SCM_DSUBRF (proc) (scm_big2dbl (arg1)), 0.0))
1901#endif
1902 floerr:
1903 scm_wta (arg1, (char *) SCM_ARG1, SCM_CHARS (SCM_SNAME (proc)));
1904 }
1905#endif
1906 proc = (SCM) SCM_SNAME (proc);
1907 {
1908 char *chrs = SCM_CHARS (proc) + SCM_LENGTH (proc) - 1;
1909 while ('c' != *--chrs)
1910 {
1911 SCM_ASSERT (SCM_NIMP (arg1) && SCM_CONSP (arg1),
1912 arg1, SCM_ARG1, SCM_CHARS (proc));
1913 arg1 = ('a' == *chrs) ? SCM_CAR (arg1) : SCM_CDR (arg1);
1914 }
1915 RETURN (arg1)
1916 }
1917 case scm_tc7_subr_3:
1918 RETURN (SCM_SUBRF (proc) (arg1, SCM_CAR (args), SCM_CAR (SCM_CDR (args))))
1919 case scm_tc7_lsubr:
1920#ifdef DEVAL
1921 RETURN (SCM_SUBRF (proc) (SCM_UNBNDP (arg1) ? SCM_EOL : dbg_info.args))
1922#else
1923 RETURN (SCM_SUBRF (proc) (SCM_UNBNDP (arg1) ? SCM_EOL : scm_cons (arg1, args)))
1924#endif
1925 case scm_tc7_lsubr_2:
1926 SCM_ASRTGO (SCM_NIMP (args) && SCM_CONSP (args), wrongnumargs);
1927 RETURN (SCM_SUBRF (proc) (arg1, SCM_CAR (args), SCM_CDR (args)))
1928 case scm_tc7_asubr:
1929 if (SCM_NULLP (args))
1930 RETURN (SCM_SUBRF (proc) (arg1, SCM_UNDEFINED))
1931 while (SCM_NIMP (args))
1932 {
1933 SCM_ASSERT (SCM_CONSP (args), args, SCM_ARG2, "apply");
1934 arg1 = SCM_SUBRF (proc) (arg1, SCM_CAR (args));
1935 args = SCM_CDR (args);
1936 }
1937 RETURN (arg1);
1938 case scm_tc7_rpsubr:
1939 if (SCM_NULLP (args))
1940 RETURN (SCM_BOOL_T);
1941 while (SCM_NIMP (args))
1942 {
1943 SCM_ASSERT (SCM_CONSP (args), args, SCM_ARG2, "apply");
1944 if (SCM_FALSEP (SCM_SUBRF (proc) (arg1, SCM_CAR (args))))
1945 RETURN (SCM_BOOL_F);
1946 arg1 = SCM_CAR (args);
1947 args = SCM_CDR (args);
1948 }
1949 RETURN (SCM_BOOL_T);
1950 case scm_tcs_closures:
1951#ifdef DEVAL
1952 arg1 = (SCM_UNBNDP (arg1) ? SCM_EOL : dbg_info.args);
1953#else
1954 arg1 = (SCM_UNBNDP (arg1) ? SCM_EOL : scm_cons (arg1, args));
1955#endif
1956#ifndef RECKLESS
1957 if (scm_badargsp (SCM_CAR (SCM_CODE (proc)), arg1))
1958 goto wrongnumargs;
1959#endif
1960 args = EXTEND_SCM_ENV (SCM_CAR (SCM_CODE (proc)), arg1, SCM_ENV (proc));
1961 proc = SCM_CODE (proc);
1962 while (SCM_NNULLP (proc = SCM_CDR (proc)))
1963 arg1 = EVALCAR (proc, args);
1964 RETURN (arg1);
1965 case scm_tc7_contin:
1966 SCM_ASRTGO (SCM_NULLP (args), wrongnumargs);
1967 scm_call_continuation (proc, arg1);
1968#ifdef CCLO
1969 case scm_tc7_cclo:
1970#ifdef DEVAL
1971 args = (SCM_UNBNDP(arg1) ? SCM_EOL : dbg_info.args);
1972#else
1973 args = (SCM_UNBNDP(arg1) ? SCM_EOL : scm_cons (arg1, args));
1974#endif
1975 arg1 = proc;
1976 proc = SCM_CCLO_SUBR (proc);
1977 goto tail;
1978#endif
1979 wrongnumargs:
1980 scm_wta (proc, (char *) SCM_WNA, "apply");
1981 default:
1982 badproc:
1983 scm_wta (proc, (char *) SCM_ARG1, "apply");
1984 RETURN (arg1);
1985 }
1986#ifdef DEVAL
1987 exit:
1988 if (CHECK_SCM_EXIT)
1989 {
1990 /* if (SINGLE_STEP) ... but this is always fulfilled. */
1991 SINGLE_STEP = 0;
1992 scm_make_cont (&arg1);
1993 if (setjmp (SCM_JMPBUF (arg1)))
1994 {
1995 proc = SCM_THROW_VALUE(arg1);
1996 goto ret;
1997 }
1998 scm_ithrow (exit_frame_sym, proc, 0);
1999 }
2000 ret:
2001 last_debug_info_frame = dbg_info.prev;
2002 return proc;
2003#endif
2004}
2005
2006#ifndef DEVAL
2007
2008SCM_PROC(s_map, "map", 2, 0, 1, scm_map);
2009#ifdef __STDC__
2010SCM
2011scm_map (SCM proc, SCM arg1, SCM args)
2012#else
2013SCM
2014scm_map (proc, arg1, args)
2015 SCM proc;
2016 SCM arg1;
2017 SCM args;
2018#endif
2019{
2020 long i;
2021 SCM res = SCM_EOL;
2022 SCM *pres = &res;
2023 SCM *ve = &args; /* Keep args from being optimized away. */
2024
2025 if (SCM_NULLP (arg1))
2026 return res;
2027 SCM_ASSERT (SCM_NIMP (arg1), arg1, SCM_ARG2, s_map);
2028 if (SCM_NULLP (args))
2029 {
2030 while (SCM_NIMP (arg1))
2031 {
2032 SCM_ASSERT (SCM_CONSP (arg1), arg1, SCM_ARG2, s_map);
2033 *pres = scm_cons (scm_apply (proc, SCM_CAR (arg1), scm_listofnull), SCM_EOL);
2034 pres = &SCM_CDR (*pres);
2035 arg1 = SCM_CDR (arg1);
2036 }
2037 return res;
2038 }
2039 args = scm_vector (scm_cons (arg1, args));
2040 ve = SCM_VELTS (args);
2041#ifndef RECKLESS
2042 for (i = SCM_LENGTH (args) - 1; i >= 0; i--)
2043 SCM_ASSERT (SCM_NIMP (ve[i]) && SCM_CONSP (ve[i]), args, SCM_ARG2, s_map);
2044#endif
2045 while (1)
2046 {
2047 arg1 = SCM_EOL;
2048 for (i = SCM_LENGTH (args) - 1; i >= 0; i--)
2049 {
2050 if SCM_IMP
2051 (ve[i]) return res;
2052 arg1 = scm_cons (SCM_CAR (ve[i]), arg1);
2053 ve[i] = SCM_CDR (ve[i]);
2054 }
2055 *pres = scm_cons (scm_apply (proc, arg1, SCM_EOL), SCM_EOL);
2056 pres = &SCM_CDR (*pres);
2057 }
2058}
2059
2060
2061SCM_PROC(s_for_each, "for-each", 2, 0, 1, scm_for_each);
2062#ifdef __STDC__
2063SCM
2064scm_for_each (SCM proc, SCM arg1, SCM args)
2065#else
2066SCM
2067scm_for_each (proc, arg1, args)
2068 SCM proc;
2069 SCM arg1;
2070 SCM args;
2071#endif
2072{
2073 SCM *ve = &args; /* Keep args from being optimized away. */
2074 long i;
2075 if SCM_NULLP (arg1)
2076 return SCM_UNSPECIFIED;
2077 SCM_ASSERT (SCM_NIMP (arg1), arg1, SCM_ARG2, s_for_each);
2078 if SCM_NULLP (args)
2079 {
2080 while SCM_NIMP (arg1)
2081 {
2082 SCM_ASSERT (SCM_CONSP (arg1), arg1, SCM_ARG2, s_for_each);
2083 scm_apply (proc, SCM_CAR (arg1), scm_listofnull);
2084 arg1 = SCM_CDR (arg1);
2085 }
2086 return SCM_UNSPECIFIED;
2087 }
2088 args = scm_vector (scm_cons (arg1, args));
2089 ve = SCM_VELTS (args);
2090#ifndef RECKLESS
2091 for (i = SCM_LENGTH (args) - 1; i >= 0; i--)
2092 SCM_ASSERT (SCM_NIMP (ve[i]) && SCM_CONSP (ve[i]), args, SCM_ARG2, s_for_each);
2093#endif
2094 while (1)
2095 {
2096 arg1 = SCM_EOL;
2097 for (i = SCM_LENGTH (args) - 1; i >= 0; i--)
2098 {
2099 if SCM_IMP
2100 (ve[i]) return SCM_UNSPECIFIED;
2101 arg1 = scm_cons (SCM_CAR (ve[i]), arg1);
2102 ve[i] = SCM_CDR (ve[i]);
2103 }
2104 scm_apply (proc, arg1, SCM_EOL);
2105 }
2106}
2107
2108
2109#ifdef __STDC__
2110SCM
2111scm_closure (SCM code, SCM env)
2112#else
2113SCM
2114scm_closure (code, env)
2115 SCM code;
2116 SCM env;
2117#endif
2118{
2119 register SCM z;
2120 SCM_NEWCELL (z);
2121 SCM_SETCODE (z, code);
2122 SCM_ENV (z) = env;
2123 return z;
2124}
2125
2126
2127long scm_tc16_promise;
2128#ifdef __STDC__
2129SCM
2130scm_makprom (SCM code)
2131#else
2132SCM
2133scm_makprom (code)
2134 SCM code;
2135#endif
2136{
2137 register SCM z;
2138 SCM_NEWCELL (z);
2139 SCM_CDR (z) = code;
2140 SCM_CAR (z) = scm_tc16_promise;
2141 return z;
2142}
2143
2144
2145#ifdef __STDC__
2146static int
2147prinprom (SCM exp, SCM port, int writing)
2148#else
2149static int
2150prinprom (exp, port, writing)
2151 SCM exp;
2152 SCM port;
2153 int writing;
2154#endif
2155{
2156 scm_gen_puts (scm_regular_string, "#<promise ", port);
2157 scm_iprin1 (SCM_CDR (exp), port, writing);
2158 scm_gen_putc ('>', port);
2159 return !0;
2160}
2161
2162
2163SCM_PROC(s_makacro, "procedure->syntax", 1, 0, 0, scm_makacro);
2164#ifdef __STDC__
2165SCM
2166scm_makacro (SCM code)
2167#else
2168SCM
2169scm_makacro (code)
2170 SCM code;
2171#endif
2172{
2173 register SCM z;
2174 SCM_NEWCELL (z);
2175 SCM_CDR (z) = code;
2176 SCM_CAR (z) = scm_tc16_macro;
2177 return z;
2178}
2179
2180
2181SCM_PROC(s_makmacro, "procedure->macro", 1, 0, 0, scm_makmacro);
2182#ifdef __STDC__
2183SCM
2184scm_makmacro (SCM code)
2185#else
2186SCM
2187scm_makmacro (code)
2188 SCM code;
2189#endif
2190{
2191 register SCM z;
2192 SCM_NEWCELL (z);
2193 SCM_CDR (z) = code;
2194 SCM_CAR (z) = scm_tc16_macro | (1L << 16);
2195 return z;
2196}
2197
2198
2199SCM_PROC(s_makmmacro, "procedure->memoizing-macro", 1, 0, 0, scm_makmmacro);
2200#ifdef __STDC__
2201SCM
2202scm_makmmacro (SCM code)
2203#else
2204SCM
2205scm_makmmacro (code)
2206 SCM code;
2207#endif
2208{
2209 register SCM z;
2210 SCM_NEWCELL (z);
2211 SCM_CDR (z) = code;
2212 SCM_CAR (z) = scm_tc16_macro | (2L << 16);
2213 return z;
2214}
2215
2216
2217#ifdef __STDC__
2218static int
2219prinmacro (SCM exp, SCM port, int writing)
2220#else
2221static int
2222prinmacro (exp, port, writing)
2223 SCM exp;
2224 SCM port;
2225 int writing;
2226#endif
2227{
2228 if (SCM_CAR (exp) & (3L << 16))
2229 scm_gen_puts (scm_regular_string, "#<macro", port);
2230 else
2231 scm_gen_puts (scm_regular_string, "#<syntax", port);
2232 if (SCM_CAR (exp) & (2L << 16))
2233 scm_gen_putc ('!', port);
2234 scm_gen_putc (' ', port);
2235 scm_iprin1 (SCM_CDR (exp), port, writing);
2236 scm_gen_putc ('>', port);
2237 return !0;
2238}
2239
2240SCM_PROC(s_force, "force", 1, 0, 0, scm_force);
2241#ifdef __STDC__
2242SCM
2243scm_force (SCM x)
2244#else
2245SCM
2246scm_force (x)
2247 SCM x;
2248#endif
2249{
2250 SCM_ASSERT ((SCM_TYP16 (x) == scm_tc16_promise), x, SCM_ARG1, s_force);
2251 if (!((1L << 16) & SCM_CAR (x)))
2252 {
2253 SCM ans = scm_apply (SCM_CDR (x), SCM_EOL, SCM_EOL);
2254 if (!((1L << 16) & SCM_CAR (x)))
2255 {
2256 SCM_DEFER_INTS;
2257 SCM_CDR (x) = ans;
2258 SCM_CAR (x) |= (1L << 16);
2259 SCM_ALLOW_INTS;
2260 }
2261 }
2262 return SCM_CDR (x);
2263}
2264
2265SCM_PROC (s_promise_p, "promise?", 1, 0, 0, scm_promise_p);
2266#ifdef __STDC__
2267SCM
2268scm_promise_p (SCM x)
2269#else
2270SCM
2271scm_promise_p (x)
2272 SCM x;
2273#endif
2274{
2275 return ((SCM_NIMP (x) && (SCM_TYP16 (x) == scm_tc16_promise))
2276 ? SCM_BOOL_T
2277 : SCM_BOOL_F);
2278}
2279
2280SCM_PROC(s_copy_tree, "copy-tree", 1, 0, 0, scm_copy_tree);
2281#ifdef __STDC__
2282SCM
2283scm_copy_tree (SCM obj)
2284#else
2285SCM
2286scm_copy_tree (obj)
2287 SCM obj;
2288#endif
2289{
2290 SCM ans, tl;
2291 if SCM_IMP
2292 (obj) return obj;
2293 if (SCM_VECTORP (obj))
2294 {
2295 scm_sizet i = SCM_LENGTH (obj);
2296 ans = scm_make_vector (SCM_MAKINUM (i), SCM_UNSPECIFIED, SCM_UNDEFINED);
2297 while (i--)
2298 SCM_VELTS (ans)[i] = scm_copy_tree (SCM_VELTS (obj)[i]);
2299 return ans;
2300 }
2301 if SCM_NCONSP (obj)
2302 return obj;
2303/* return scm_cons(scm_copy_tree(SCM_CAR(obj)), scm_copy_tree(SCM_CDR(obj))); */
2304 ans = tl = scm_cons (scm_copy_tree (SCM_CAR (obj)), SCM_UNSPECIFIED);
2305 while (SCM_NIMP (obj = SCM_CDR (obj)) && SCM_CONSP (obj))
2306 tl = (SCM_CDR (tl) = scm_cons (scm_copy_tree (SCM_CAR (obj)), SCM_UNSPECIFIED));
2307 SCM_CDR (tl) = obj;
2308 return ans;
2309}
2310
2311#ifdef __STDC__
2312SCM
2313scm_eval_3 (SCM obj, int copyp, SCM env)
2314#else
2315SCM
2316scm_eval_3 (obj, copyp, env)
2317 SCM obj;
2318 int copyp;
2319 SCM env;
2320#endif
2321{
2322 if (SCM_NIMP (SCM_CDR (scm_system_transformer)))
2323 obj = scm_apply (SCM_CDR (scm_system_transformer), obj, scm_listofnull);
2324 else if (copyp)
2325 obj = scm_copy_tree (obj);
2326 return EVAL (obj, env);
2327}
2328
2329#ifdef __STDC__
2330SCM
2331scm_top_level_env (SCM thunk)
2332#else
2333SCM
2334scm_top_level_env (thunk)
2335 SCM thunk;
2336#endif
2337{
2338 if (SCM_IMP(thunk))
2339 return SCM_EOL;
2340 else
2341 return scm_cons(thunk, (SCM)SCM_EOL);
2342}
2343
2344SCM_PROC(s_eval2, "eval2", 2, 0, 0, scm_eval2);
2345#ifdef __STDC__
2346SCM
2347scm_eval2 (SCM obj, SCM env_thunk)
2348#else
2349SCM
2350scm_eval2 (obj, env_thunk)
2351 SCM obj;
2352 SCM env_thunk;
2353#endif
2354{
2355 return scm_eval_3 (obj, 1, scm_top_level_env(env_thunk));
2356}
2357
2358SCM_PROC(s_eval, "eval", 1, 0, 0, scm_eval);
2359#ifdef __STDC__
2360SCM
2361scm_eval (SCM obj)
2362#else
2363SCM
2364scm_eval (obj)
2365 SCM obj;
2366#endif
2367{
2368 return
2369 scm_eval_3(obj, 1, scm_top_level_env(SCM_CDR(scm_top_level_lookup_thunk_var)));
2370}
2371
2372SCM_PROC(s_eval_x, "eval!", 1, 0, 0, scm_eval_x);
2373#ifdef __STDC__
2374SCM
2375scm_eval_x (SCM obj)
2376#else
2377SCM
2378scm_eval_x (obj)
2379 SCM obj;
2380#endif
2381{
2382 return
2383 scm_eval_3(obj,
2384 0,
2385 scm_top_level_env (SCM_CDR (scm_top_level_lookup_thunk_var)));
2386}
2387
2388SCM_PROC (s_macro_eval_x, "macro-eval!", 2, 0, 0, scm_macro_eval_x);
2389#ifdef __STDC__
2390SCM
2391scm_macro_eval_x (SCM exp, SCM env)
2392#else
2393SCM
2394scm_macro_eval_x (exp, env)
2395 SCM exp;
2396 SCM env;
2397#endif
2398{
2399 return scm_eval_3 (exp, 0, env);
2400}
2401
2402#ifdef __STDC__
2403SCM
2404scm_definedp (SCM x, SCM env)
2405#else
2406SCM
2407scm_definedp (x, env)
2408 SCM x;
2409 SCM env;
2410#endif
2411{
2412 SCM proc = SCM_CAR (x = SCM_CDR (x));
2413 if (SCM_ISYMP (proc))
2414 return SCM_BOOL_T;
2415 else if(SCM_IMP(proc) || !SCM_SYMBOLP(proc))
2416 return SCM_BOOL_F;
2417 else
2418 {
2419 SCM vcell = scm_sym2vcell(proc, env_top_level(env), SCM_BOOL_F);
2420 return (vcell == SCM_BOOL_F || SCM_UNBNDP(SCM_CDR(vcell))) ? SCM_BOOL_F : SCM_BOOL_T;
2421 }
2422}
2423
2424static scm_smobfuns promsmob =
2425{scm_markcdr, scm_free0, prinprom};
2426
2427static scm_smobfuns macrosmob =
2428{scm_markcdr, scm_free0, prinmacro};
2429
2430#ifdef __STDC__
2431SCM
2432scm_make_synt (char *name, SCM (*macroizer) (), SCM (*fcn) ())
2433#else
2434SCM
2435scm_make_synt (name, macroizer, fcn)
2436 char *name;
2437 SCM (*macroizer) ();
2438 SCM (*fcn) ();
2439#endif
2440{
2441 SCM symcell = scm_sysintern (name, SCM_UNDEFINED);
2442 long tmp = ((((SCM_CELLPTR) (SCM_CAR (symcell))) - scm_heap_org) << 8);
2443 register SCM z;
2444 if ((tmp >> 8) != ((SCM_CELLPTR) (SCM_CAR (symcell)) - scm_heap_org))
2445 tmp = 0;
2446 SCM_NEWCELL (z);
2447 SCM_SUBRF (z) = fcn;
2448 SCM_CAR (z) = tmp + scm_tc7_subr_2;
2449 SCM_CDR (symcell) = macroizer (z);
2450 return SCM_CAR (symcell);
2451}
2452
2453#ifdef DEBUG_EXTENSIONS
2454# ifndef DEVAL
2455# define DEVAL
2456# include "eval.c"
2457# endif
2458#endif
2459
2460
2461#ifdef __STDC__
2462void
2463scm_init_eval (void)
2464#else
2465void
2466scm_init_eval ()
2467#endif
2468{
2469#ifdef DEBUG_EXTENSIONS
2470 enter_frame_sym = SCM_CAR (scm_sysintern ("enter-frame", SCM_UNDEFINED));
2471 exit_frame_sym = SCM_CAR (scm_sysintern ("exit-frame", SCM_UNDEFINED));
2472#endif
2473 scm_tc16_promise = scm_newsmob (&promsmob);
2474 scm_tc16_macro = scm_newsmob (&macrosmob);
2475 scm_i_apply = scm_make_subr ("apply", scm_tc7_lsubr_2, scm_apply);
2476 scm_system_transformer = scm_sysintern ("scm:eval-transformer", SCM_UNDEFINED);
2477 scm_i_dot = SCM_CAR (scm_sysintern (".", SCM_UNDEFINED));
2478 scm_i_arrow = SCM_CAR (scm_sysintern ("=>", SCM_UNDEFINED));
2479 scm_i_else = SCM_CAR (scm_sysintern ("else", SCM_UNDEFINED));
2480 scm_i_unquote = SCM_CAR (scm_sysintern ("unquote", SCM_UNDEFINED));
2481 scm_i_uq_splicing = SCM_CAR (scm_sysintern ("unquote-splicing", SCM_UNDEFINED));
2482
2483 /* acros */
2484 scm_i_quasiquote = scm_make_synt (s_quasiquote, scm_makacro, scm_m_quasiquote);
2485 scm_make_synt ("define", scm_makmmacro, scm_m_define);
2486 scm_make_synt (s_delay, scm_makacro, scm_m_delay);
2487 /* end of acros */
2488
2489 scm_top_level_lookup_thunk_var =
2490 scm_sysintern("*top-level-lookup-thunk*", SCM_BOOL_F);
2491
2492 scm_make_synt ("and", scm_makmmacro, scm_m_and);
2493 scm_make_synt ("begin", scm_makmmacro, scm_m_begin);
2494 scm_make_synt ("case", scm_makmmacro, scm_m_case);
2495 scm_make_synt ("cond", scm_makmmacro, scm_m_cond);
2496 scm_make_synt ("do", scm_makmmacro, scm_m_do);
2497 scm_make_synt ("if", scm_makmmacro, scm_m_if);
2498 scm_i_lambda = scm_make_synt ("lambda", scm_makmmacro, scm_m_lambda);
2499 scm_i_let = scm_make_synt ("let", scm_makmmacro, scm_m_let);
2500 scm_make_synt ("letrec", scm_makmmacro, scm_m_letrec);
2501 scm_make_synt ("let*", scm_makmmacro, scm_m_letstar);
2502 scm_make_synt ("or", scm_makmmacro, scm_m_or);
2503 scm_i_quote = scm_make_synt ("quote", scm_makmmacro, scm_m_quote);
2504 scm_make_synt ("set!", scm_makmmacro, scm_m_set);
2505 scm_make_synt ("@apply", scm_makmmacro, scm_m_apply);
2506 scm_make_synt ("@call-with-current-continuation", scm_makmmacro, scm_m_cont);
2507 scm_make_synt ("defined?", scm_makmmacro, scm_definedp);
2508 scm_i_name = SCM_CAR (scm_sysintern ("name", SCM_UNDEFINED));
2509 scm_permanent_object (scm_i_name);
2510#include "eval.x"
2511}
2512#endif /* !DEVAL */
2513
Unnamed repository; edit this file 'description' to name the repository.