1 /* Copyright (C) 1995,1996 Free Software Foundation, Inc.
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)
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.
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.
17 * As a special exception, the Free Software Foundation gives permission
18 * for additional uses of the text contained in its release of GUILE.
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.
26 * This exception does not however invalidate any other reasons why
27 * the executable file might be covered by the GNU General Public License.
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.
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.
43 /* This file is read twice in order to produce debugging versions of
44 * scm_ceval and scm_apply. These functions, scm_deval and
45 * scm_dapply, are produced when we define the preprocessor macro
46 * DEVAL. The file is divided into sections which are treated
47 * differently with respect to DEVAL. The heads of these sections are
48 * marked with the string "SECTION:".
52 /* SECTION: This code is compiled once.
62 #include "sequences.h"
64 #include "continuations.h"
72 #ifdef DEBUG_EXTENSIONS
74 #endif /* DEBUG_EXTENSIONS */
82 /* The evaluator contains a plethora of EVAL symbols.
83 * This is an attempt at explanation.
85 * The following macros should be used in code which is read twice
86 * (where the choice of evaluator is hard soldered):
88 * SCM_CEVAL is the symbol used within one evaluator to call itself.
89 * Originally, it is defined to scm_ceval, but is redefined to
90 * scm_deval during the second pass.
92 * SIDEVAL corresponds to SCM_CEVAL, but is used in situations where
93 * only side effects of expressions matter. All immediates are
96 * EVALIM is used when it is known that the expression is an
97 * immediate. (This macro never calls an evaluator.)
99 * EVALCAR evaluates the car of an expression.
101 * EVALCELLCAR is like EVALCAR, but is used when it is known that the
102 * car is a lisp cell.
104 * The following macros should be used in code which is read once
105 * (where the choice of evaluator is dynamic):
107 * XEVAL takes care of immediates without calling an evaluator. It
108 * then calls scm_ceval *or* scm_deval, depending on the debugging
111 * XEVALCAR corresponds to EVALCAR, but uses scm_ceval *or* scm_deval
112 * depending on the debugging mode.
114 * The main motivation for keeping this plethora is efficiency
115 * together with maintainability (=> locality of code).
118 #define EVALCELLCAR(x, env) (SCM_SYMBOLP (SCM_CAR(x)) \
119 ? *scm_lookupcar(x, env) \
120 : SCM_CEVAL(SCM_CAR(x), env))
122 #ifdef MEMOIZE_LOCALS
123 #define EVALIM(x, env) (SCM_ILOCP(x)?*scm_ilookup((x), env):x)
125 #define EVALIM(x, env) x
127 #define EVALCAR(x, env) (SCM_NCELLP(SCM_CAR(x))\
128 ? (SCM_IMP(SCM_CAR(x)) \
129 ? EVALIM(SCM_CAR(x), env) \
130 : SCM_GLOC_VAL(SCM_CAR(x))) \
131 : EVALCELLCAR(x, env))
132 #ifdef DEBUG_EXTENSIONS
133 #define XEVALCAR(x, env) (SCM_NCELLP(SCM_CAR(x)) \
134 ? (SCM_IMP(SCM_CAR(x)) \
135 ? EVALIM(SCM_CAR(x), env) \
136 : SCM_GLOC_VAL(SCM_CAR(x))) \
137 : (SCM_SYMBOLP(SCM_CAR(x)) \
138 ? *scm_lookupcar(x, env) \
139 : (*scm_ceval_ptr) (SCM_CAR(x), env)))
141 #define XEVALCAR(x, env) EVALCAR(x, env)
144 #define EXTEND_ENV SCM_EXTEND_ENV
146 #ifdef MEMOIZE_LOCALS
149 scm_ilookup (iloc
, env
)
153 register int ir
= SCM_IFRAME (iloc
);
154 register SCM er
= env
;
155 for (; 0 != ir
; --ir
)
158 for (ir
= SCM_IDIST (iloc
); 0 != ir
; --ir
)
160 if (SCM_ICDRP (iloc
))
161 return SCM_CDRLOC (er
);
162 return SCM_CARLOC (SCM_CDR (er
));
168 scm_lookupcar (vloc
, genv
)
173 register SCM
*al
, fl
, var
= SCM_CAR (vloc
);
174 #ifdef MEMOIZE_LOCALS
175 register SCM iloc
= SCM_ILOC00
;
177 for (; SCM_NIMP (env
); env
= SCM_CDR (env
))
179 if (SCM_BOOL_T
== scm_procedure_p (SCM_CAR (env
)))
181 al
= SCM_CARLOC (env
);
182 for (fl
= SCM_CAR (*al
); SCM_NIMP (fl
); fl
= SCM_CDR (fl
))
187 #ifdef MEMOIZE_LOCALS
188 SCM_SETCAR (vloc
, iloc
+ SCM_ICDR
);
190 return SCM_CDRLOC (*al
);
194 al
= SCM_CDRLOC (*al
);
195 if (SCM_CAR (fl
) == var
)
197 #ifdef MEMOIZE_LOCALS
198 #ifndef RECKLESS /* letrec inits to SCM_UNDEFINED */
199 if (SCM_UNBNDP (SCM_CAR (*al
)))
205 SCM_SETCAR (vloc
, iloc
);
207 return SCM_CARLOC (*al
);
209 #ifdef MEMOIZE_LOCALS
213 #ifdef MEMOIZE_LOCALS
214 iloc
= (~SCM_IDSTMSK
) & (iloc
+ SCM_IFRINC
);
218 SCM top_thunk
, vcell
;
221 top_thunk
= SCM_CAR(env
); /* env now refers to a top level env thunk */
225 top_thunk
= SCM_BOOL_F
;
226 vcell
= scm_sym2vcell (var
, top_thunk
, SCM_BOOL_F
);
227 if (vcell
== SCM_BOOL_F
)
233 if (SCM_NNULLP (env
) || SCM_UNBNDP (SCM_CDR (var
)))
237 /* scm_everr (vloc, genv,...) */
238 scm_misc_error (NULL
,
240 ? "Unbound variable: %S"
241 : "Damaged environment: %S",
242 scm_listify (var
, SCM_UNDEFINED
));
245 SCM_SETCAR (vloc
, var
+ 1);
246 /* Except wait...what if the var is not a vcell,
247 * but syntax or something....
249 return SCM_CDRLOC (var
);
252 #define unmemocar scm_unmemocar
255 scm_unmemocar (form
, env
)
259 #ifdef DEBUG_EXTENSIONS
268 SCM_SETCAR (form
, SCM_CAR (c
- 1));
269 #ifdef MEMOIZE_LOCALS
270 #ifdef DEBUG_EXTENSIONS
271 else if (SCM_ILOCP (c
))
273 for (ir
= SCM_IFRAME (c
); ir
!= 0; --ir
)
275 env
= SCM_CAR (SCM_CAR (env
));
276 for (ir
= SCM_IDIST (c
); ir
!= 0; --ir
)
278 SCM_SETCAR (form
, SCM_ICDRP (c
) ? env
: SCM_CAR (env
));
287 scm_eval_car (pair
, env
)
291 return XEVALCAR (pair
, env
);
296 * The following rewrite expressions and
297 * some memoized forms have different syntax
300 static char s_expression
[] = "missing or extra expression";
301 static char s_test
[] = "bad test";
302 static char s_body
[] = "bad body";
303 static char s_bindings
[] = "bad bindings";
304 static char s_variable
[] = "bad variable";
305 static char s_clauses
[] = "bad or missing clauses";
306 static char s_formals
[] = "bad formals";
307 #define ASSYNT(_cond, _arg, _pos, _subr) if(!(_cond))scm_wta(_arg, (char *)_pos, _subr);
309 SCM scm_i_dot
, scm_i_quote
, scm_i_quasiquote
, scm_i_lambda
, scm_i_let
,
310 scm_i_arrow
, scm_i_else
, scm_i_unquote
, scm_i_uq_splicing
, scm_i_apply
;
311 SCM scm_i_define
, scm_i_and
, scm_i_begin
, scm_i_case
, scm_i_cond
,
312 scm_i_do
, scm_i_if
, scm_i_let
, scm_i_letrec
, scm_i_letstar
,
313 scm_i_or
, scm_i_set
, scm_i_atapply
, scm_i_atcall_cc
;
314 static char s_quasiquote
[] = "quasiquote";
315 static char s_delay
[] = "delay";
316 static char s_undefine
[] = "undefine";
317 #ifdef DEBUG_EXTENSIONS
318 SCM scm_i_enter_frame
, scm_i_apply_frame
, scm_i_exit_frame
;
322 #define ASRTSYNTAX(cond_, msg_) if(!(cond_))scm_wta(xorig, (msg_), what);
326 static void bodycheck
SCM_P ((SCM xorig
, SCM
*bodyloc
, char *what
));
329 bodycheck (xorig
, bodyloc
, what
)
334 ASRTSYNTAX (scm_ilength (*bodyloc
) >= 1, s_expression
);
340 scm_m_quote (xorig
, env
)
344 ASSYNT (scm_ilength (SCM_CDR (xorig
)) == 1, xorig
, s_expression
, "quote");
345 return scm_cons (SCM_IM_QUOTE
, SCM_CDR (xorig
));
351 scm_m_begin (xorig
, env
)
355 ASSYNT (scm_ilength (SCM_CDR (xorig
)) >= 1, xorig
, s_expression
, "begin");
356 return scm_cons (SCM_IM_BEGIN
, SCM_CDR (xorig
));
362 scm_m_if (xorig
, env
)
366 int len
= scm_ilength (SCM_CDR (xorig
));
367 ASSYNT (len
>= 2 && len
<= 3, xorig
, s_expression
, "if");
368 return scm_cons (SCM_IM_IF
, SCM_CDR (xorig
));
374 scm_m_set (xorig
, env
)
378 SCM x
= SCM_CDR (xorig
);
379 ASSYNT (2 == scm_ilength (x
), xorig
, s_expression
, "set!");
380 ASSYNT (SCM_NIMP (SCM_CAR (x
)) && SCM_SYMBOLP (SCM_CAR (x
)),
381 xorig
, s_variable
, "set!");
382 return scm_cons (SCM_IM_SET
, x
);
389 scm_m_vref (xorig
, env
)
393 SCM x
= SCM_CDR (xorig
);
394 ASSYNT (1 == scm_ilength (x
), xorig
, s_expression
, s_vref
);
395 if (SCM_NIMP(x
) && UDSCM_VARIABLEP (SCM_CAR (x
)))
397 /* scm_everr (SCM_UNDEFINED, env,..., "global variable reference") */
398 scm_misc_error (NULL
,
400 scm_listify (SCM_CAR (SCM_CDR (x
)), SCM_UNDEFINED
));
402 ASSYNT (SCM_NIMP(x
) && DEFSCM_VARIABLEP (SCM_CAR (x
)),
403 xorig
, s_variable
, s_vref
);
405 return scm_cons (IM_VREF
, x
);
411 scm_m_vset (xorig
, env
)
415 SCM x
= SCM_CDR (xorig
);
416 ASSYNT (3 == scm_ilength (x
), xorig
, s_expression
, s_vset
);
417 ASSYNT (( DEFSCM_VARIABLEP (SCM_CAR (x
))
418 || UDSCM_VARIABLEP (SCM_CAR (x
))),
419 xorig
, s_variable
, s_vset
);
420 return scm_cons (IM_VSET
, x
);
427 scm_m_and (xorig
, env
)
431 int len
= scm_ilength (SCM_CDR (xorig
));
432 ASSYNT (len
>= 0, xorig
, s_test
, "and");
434 return scm_cons (SCM_IM_AND
, SCM_CDR (xorig
));
442 scm_m_or (xorig
, env
)
446 int len
= scm_ilength (SCM_CDR (xorig
));
447 ASSYNT (len
>= 0, xorig
, s_test
, "or");
449 return scm_cons (SCM_IM_OR
, SCM_CDR (xorig
));
457 scm_m_case (xorig
, env
)
461 SCM proc
, x
= SCM_CDR (xorig
);
462 ASSYNT (scm_ilength (x
) >= 2, xorig
, s_clauses
, "case");
463 while (SCM_NIMP (x
= SCM_CDR (x
)))
466 ASSYNT (scm_ilength (proc
) >= 2, xorig
, s_clauses
, "case");
467 ASSYNT (scm_ilength (SCM_CAR (proc
)) >= 0 || scm_i_else
== SCM_CAR (proc
),
468 xorig
, s_clauses
, "case");
470 return scm_cons (SCM_IM_CASE
, SCM_CDR (xorig
));
476 scm_m_cond (xorig
, env
)
480 SCM arg1
, x
= SCM_CDR (xorig
);
481 int len
= scm_ilength (x
);
482 ASSYNT (len
>= 1, xorig
, s_clauses
, "cond");
486 len
= scm_ilength (arg1
);
487 ASSYNT (len
>= 1, xorig
, s_clauses
, "cond");
488 if (scm_i_else
== SCM_CAR (arg1
))
490 ASSYNT (SCM_NULLP (SCM_CDR (x
)) && len
>= 2, xorig
, "bad ELSE clause", "cond");
491 SCM_SETCAR (arg1
, SCM_BOOL_T
);
493 if (len
>= 2 && scm_i_arrow
== SCM_CAR (SCM_CDR (arg1
)))
494 ASSYNT (3 == len
&& SCM_NIMP (SCM_CAR (SCM_CDR (SCM_CDR (arg1
)))),
495 xorig
, "bad recipient", "cond");
498 return scm_cons (SCM_IM_COND
, SCM_CDR (xorig
));
504 scm_m_lambda (xorig
, env
)
508 SCM proc
, x
= SCM_CDR (xorig
);
509 if (scm_ilength (x
) < 2)
513 (proc
) goto memlambda
;
515 (proc
) goto badforms
;
517 (proc
) goto memlambda
;
519 (proc
) goto badforms
;
525 if (!SCM_SYMBOLP (proc
))
529 if (!(SCM_NIMP (SCM_CAR (proc
)) && SCM_SYMBOLP (SCM_CAR (proc
))))
531 proc
= SCM_CDR (proc
);
535 badforms
:scm_wta (xorig
, s_formals
, "lambda");
537 bodycheck (xorig
, SCM_CDRLOC (x
), "lambda");
538 return scm_cons (SCM_IM_LAMBDA
, SCM_CDR (xorig
));
544 scm_m_letstar (xorig
, env
)
548 SCM x
= SCM_CDR (xorig
), arg1
, proc
, vars
= SCM_EOL
, *varloc
= &vars
;
549 int len
= scm_ilength (x
);
550 ASSYNT (len
>= 2, xorig
, s_body
, "let*");
552 ASSYNT (scm_ilength (proc
) >= 0, xorig
, s_bindings
, "let*");
553 while SCM_NIMP (proc
)
555 arg1
= SCM_CAR (proc
);
556 ASSYNT (2 == scm_ilength (arg1
), xorig
, s_bindings
, "let*");
557 ASSYNT (SCM_NIMP (SCM_CAR (arg1
)) && SCM_SYMBOLP (SCM_CAR (arg1
)), xorig
, s_variable
, "let*");
558 *varloc
= scm_cons2 (SCM_CAR (arg1
), SCM_CAR (SCM_CDR (arg1
)), SCM_EOL
);
559 varloc
= SCM_CDRLOC (SCM_CDR (*varloc
));
560 proc
= SCM_CDR (proc
);
562 x
= scm_cons (vars
, SCM_CDR (x
));
563 bodycheck (xorig
, SCM_CDRLOC (x
), "let*");
564 return scm_cons (SCM_IM_LETSTAR
, x
);
567 /* DO gets the most radically altered syntax
568 (do ((<var1> <init1> <step1>)
574 (do_mem (varn ... var2 var1)
575 (<init1> <init2> ... <initn>)
578 <step1> <step2> ... <stepn>) ;; missing steps replaced by var
584 scm_m_do (xorig
, env
)
588 SCM x
= SCM_CDR (xorig
), arg1
, proc
;
589 SCM vars
= SCM_EOL
, inits
= SCM_EOL
, steps
= SCM_EOL
;
590 SCM
*initloc
= &inits
, *steploc
= &steps
;
591 int len
= scm_ilength (x
);
592 ASSYNT (len
>= 2, xorig
, s_test
, "do");
594 ASSYNT (scm_ilength (proc
) >= 0, xorig
, s_bindings
, "do");
598 arg1
= SCM_CAR (proc
);
599 len
= scm_ilength (arg1
);
600 ASSYNT (2 == len
|| 3 == len
, xorig
, s_bindings
, "do");
601 ASSYNT (SCM_NIMP (SCM_CAR (arg1
)) && SCM_SYMBOLP (SCM_CAR (arg1
)), xorig
, s_variable
, "do");
602 /* vars reversed here, inits and steps reversed at evaluation */
603 vars
= scm_cons (SCM_CAR (arg1
), vars
); /* variable */
604 arg1
= SCM_CDR (arg1
);
605 *initloc
= scm_cons (SCM_CAR (arg1
), SCM_EOL
); /* init */
606 initloc
= SCM_CDRLOC (*initloc
);
607 arg1
= SCM_CDR (arg1
);
608 *steploc
= scm_cons (SCM_IMP (arg1
) ? SCM_CAR (vars
) : SCM_CAR (arg1
), SCM_EOL
); /* step */
609 steploc
= SCM_CDRLOC (*steploc
);
610 proc
= SCM_CDR (proc
);
613 ASSYNT (scm_ilength (SCM_CAR (x
)) >= 1, xorig
, s_test
, "do");
614 x
= scm_cons2 (SCM_CAR (x
), SCM_CDR (x
), steps
);
615 x
= scm_cons2 (vars
, inits
, x
);
616 bodycheck (xorig
, SCM_CARLOC (SCM_CDR (SCM_CDR (x
))), "do");
617 return scm_cons (SCM_IM_DO
, x
);
620 /* evalcar is small version of inline EVALCAR when we don't care about
623 #define evalcar scm_eval_car
626 static SCM iqq
SCM_P ((SCM form
, SCM env
, int depth
));
629 iqq (form
, env
, depth
)
638 if (SCM_VECTORP (form
))
640 long i
= SCM_LENGTH (form
);
641 SCM
*data
= SCM_VELTS (form
);
644 tmp
= scm_cons (data
[i
], tmp
);
645 return scm_vector (iqq (tmp
, env
, depth
));
649 tmp
= SCM_CAR (form
);
650 if (scm_i_quasiquote
== tmp
)
655 if (scm_i_unquote
== tmp
)
659 form
= SCM_CDR (form
);
660 /* !!! might need a check here to be sure that form isn't a struct. */
661 SCM_ASSERT (SCM_NIMP (form
) && SCM_ECONSP (form
) && SCM_NULLP (SCM_CDR (form
)),
662 form
, SCM_ARG1
, s_quasiquote
);
664 return evalcar (form
, env
);
665 return scm_cons2 (tmp
, iqq (SCM_CAR (form
), env
, depth
), SCM_EOL
);
667 if (SCM_NIMP (tmp
) && (scm_i_uq_splicing
== SCM_CAR (tmp
)))
671 return scm_append (scm_cons2 (evalcar (tmp
, env
), iqq (SCM_CDR (form
), env
, depth
), SCM_EOL
));
673 return scm_cons (iqq (SCM_CAR (form
), env
, edepth
), iqq (SCM_CDR (form
), env
, depth
));
676 /* Here are acros which return values rather than code. */
680 scm_m_quasiquote (xorig
, env
)
684 SCM x
= SCM_CDR (xorig
);
685 ASSYNT (scm_ilength (x
) == 1, xorig
, s_expression
, s_quasiquote
);
686 return iqq (SCM_CAR (x
), env
, 1);
691 scm_m_delay (xorig
, env
)
695 ASSYNT (scm_ilength (xorig
) == 2, xorig
, s_expression
, s_delay
);
696 xorig
= SCM_CDR (xorig
);
697 return scm_makprom (scm_closure (scm_cons2 (SCM_EOL
, SCM_CAR (xorig
), SCM_CDR (xorig
)),
702 static SCM env_top_level
SCM_P ((SCM env
));
708 while (SCM_NIMP(env
))
710 if (SCM_BOOL_T
== scm_procedure_p (SCM_CAR(env
)))
719 scm_m_define (x
, env
)
725 /* ASSYNT(SCM_NULLP(env), x, "bad placement", s_define);*/
726 ASSYNT (scm_ilength (x
) >= 2, arg1
, s_expression
, "define");
729 while (SCM_NIMP (proc
) && SCM_CONSP (proc
))
730 { /* nested define syntax */
731 x
= scm_cons (scm_cons2 (scm_i_lambda
, SCM_CDR (proc
), x
), SCM_EOL
);
732 proc
= SCM_CAR (proc
);
734 ASSYNT (SCM_NIMP (proc
) && SCM_SYMBOLP (proc
), arg1
, s_variable
, "define");
735 ASSYNT (1 == scm_ilength (x
), arg1
, s_expression
, "define");
736 if (SCM_TOP_LEVEL (env
))
738 x
= evalcar (x
, env
);
739 #ifdef DEBUG_EXTENSIONS
740 if (SCM_REC_PROCNAMES_P
)
741 scm_set_procedure_property_x (x
, scm_i_name
, proc
);
743 arg1
= scm_sym2vcell (proc
, env_top_level (env
), SCM_BOOL_T
);
746 if (SCM_NIMP (SCM_CDR (arg1
)) && ((SCM
) SCM_SNAME (SCM_CDR (arg1
)) == proc
)
747 && (SCM_CDR (arg1
) != x
))
748 scm_warn ("redefining built-in ", SCM_CHARS (proc
));
751 if (5 <= scm_verbose
&& SCM_UNDEFINED
!= SCM_CDR (arg1
))
752 scm_warn ("redefining ", SCM_CHARS (proc
));
754 SCM_SETCDR (arg1
, x
);
756 return scm_cons2 (scm_i_quote
, SCM_CAR (arg1
), SCM_EOL
);
758 return SCM_UNSPECIFIED
;
761 return scm_cons2 (SCM_IM_DEFINE
, proc
, x
);
765 scm_m_undefine (x
, env
)
770 ASSYNT (SCM_TOP_LEVEL (env
), arg1
, "bad placement ", s_undefine
);
771 ASSYNT (SCM_NIMP (x
) && SCM_CONSP (x
) && SCM_CDR (x
) == SCM_EOL
,
772 arg1
, s_expression
, s_undefine
);
774 ASSYNT (SCM_NIMP (x
) && SCM_SYMBOLP (x
), arg1
, s_variable
, s_undefine
);
775 arg1
= scm_sym2vcell (x
, env_top_level (env
), SCM_BOOL_F
);
776 ASSYNT (SCM_NFALSEP (arg1
) && !SCM_UNBNDP (SCM_CDR (arg1
)),
777 x
, "variable already unbound ", s_undefine
);
780 if (SCM_NIMP (SCM_CDR (arg1
)) && ((SCM
) SCM_SNAME (SCM_CDR (arg1
)) == x
))
781 scm_warn ("undefining built-in ", SCM_CHARS (x
));
784 if (5 <= scm_verbose
&& SCM_UNDEFINED
!= SCM_CDR (arg1
))
785 scm_warn ("redefining ", SCM_CHARS (x
));
787 SCM_SETCDR (arg1
, SCM_UNDEFINED
);
789 return SCM_CAR (arg1
);
791 return SCM_UNSPECIFIED
;
799 scm_m_letrec (xorig
, env
)
803 SCM cdrx
= SCM_CDR (xorig
); /* locally mutable version of form */
804 char *what
= SCM_CHARS (SCM_CAR (xorig
));
805 SCM x
= cdrx
, proc
, arg1
; /* structure traversers */
806 SCM vars
= SCM_EOL
, inits
= SCM_EOL
, *initloc
= &inits
;
808 ASRTSYNTAX (scm_ilength (x
) >= 2, s_body
);
811 (proc
) return scm_m_letstar (xorig
, env
); /* null binding, let* faster */
812 ASRTSYNTAX (scm_ilength (proc
) >= 1, s_bindings
);
815 /* vars scm_list reversed here, inits reversed at evaluation */
816 arg1
= SCM_CAR (proc
);
817 ASRTSYNTAX (2 == scm_ilength (arg1
), s_bindings
);
818 ASRTSYNTAX (SCM_NIMP (SCM_CAR (arg1
)) && SCM_SYMBOLP (SCM_CAR (arg1
)), s_variable
);
819 vars
= scm_cons (SCM_CAR (arg1
), vars
);
820 *initloc
= scm_cons (SCM_CAR (SCM_CDR (arg1
)), SCM_EOL
);
821 initloc
= SCM_CDRLOC (*initloc
);
824 (proc
= SCM_CDR (proc
));
825 cdrx
= scm_cons2 (vars
, inits
, SCM_CDR (x
));
826 bodycheck (xorig
, SCM_CDRLOC (SCM_CDR (cdrx
)), what
);
827 return scm_cons (SCM_IM_LETREC
, cdrx
);
832 scm_m_let (xorig
, env
)
836 SCM cdrx
= SCM_CDR (xorig
); /* locally mutable version of form */
837 SCM x
= cdrx
, proc
, arg1
, name
; /* structure traversers */
838 SCM vars
= SCM_EOL
, inits
= SCM_EOL
, *varloc
= &vars
, *initloc
= &inits
;
840 ASSYNT (scm_ilength (x
) >= 2, xorig
, s_body
, "let");
843 || (SCM_NIMP (proc
) && SCM_CONSP (proc
)
844 && SCM_NIMP (SCM_CAR (proc
)) && SCM_CONSP (SCM_CAR (proc
)) && SCM_NULLP (SCM_CDR (proc
))))
845 return scm_m_letstar (xorig
, env
); /* null or single binding, let* is faster */
846 ASSYNT (SCM_NIMP (proc
), xorig
, s_bindings
, "let");
847 if (SCM_CONSP (proc
)) /* plain let, proc is <bindings> */
848 return scm_cons (SCM_IM_LET
, SCM_CDR (scm_m_letrec (xorig
, env
)));
849 if (!SCM_SYMBOLP (proc
))
850 scm_wta (xorig
, s_bindings
, "let"); /* bad let */
851 name
= proc
; /* named let, build equiv letrec */
853 ASSYNT (scm_ilength (x
) >= 2, xorig
, s_body
, "let");
854 proc
= SCM_CAR (x
); /* bindings scm_list */
855 ASSYNT (scm_ilength (proc
) >= 0, xorig
, s_bindings
, "let");
858 { /* vars and inits both in order */
859 arg1
= SCM_CAR (proc
);
860 ASSYNT (2 == scm_ilength (arg1
), xorig
, s_bindings
, "let");
861 ASSYNT (SCM_NIMP (SCM_CAR (arg1
)) && SCM_SYMBOLP (SCM_CAR (arg1
)), xorig
, s_variable
, "let");
862 *varloc
= scm_cons (SCM_CAR (arg1
), SCM_EOL
);
863 varloc
= SCM_CDRLOC (*varloc
);
864 *initloc
= scm_cons (SCM_CAR (SCM_CDR (arg1
)), SCM_EOL
);
865 initloc
= SCM_CDRLOC (*initloc
);
866 proc
= SCM_CDR (proc
);
869 scm_m_letrec (scm_cons2 (scm_i_let
,
870 scm_cons (scm_cons2 (name
, scm_cons2 (scm_i_lambda
, vars
, SCM_CDR (x
)), SCM_EOL
), SCM_EOL
),
871 scm_acons (name
, inits
, SCM_EOL
)), /* body */
878 scm_m_apply (xorig
, env
)
882 ASSYNT (scm_ilength (SCM_CDR (xorig
)) == 2, xorig
, s_expression
, "@apply");
883 return scm_cons (SCM_IM_APPLY
, SCM_CDR (xorig
));
886 #define s_atcall_cc (SCM_ISYMCHARS(SCM_IM_CONT)+1)
890 scm_m_cont (xorig
, env
)
894 ASSYNT (scm_ilength (SCM_CDR (xorig
)) == 1, xorig
, s_expression
, "@call-with-current-continuation");
895 return scm_cons (SCM_IM_CONT
, SCM_CDR (xorig
));
898 /* scm_unmemocopy takes a memoized expression together with its
899 * environment and rewrites it to its original form. Thus, it is the
900 * inversion of the rewrite rules above. The procedure is not
901 * optimized for speed. It's used in scm_iprin1 when printing the
902 * code of a closure, in scm_procedure_source and in scm_expr_stack
903 * when generating the source for a stackframe.
907 static SCM unmemocopy
SCM_P ((SCM x
, SCM env
));
915 #ifdef DEBUG_EXTENSIONS
918 if (SCM_NCELLP (x
) || SCM_NECONSP (x
))
920 #ifdef DEBUG_EXTENSIONS
921 p
= scm_whash_lookup (scm_source_whash
, x
);
923 switch (SCM_TYP7 (x
))
925 case (127 & SCM_IM_AND
):
926 ls
= z
= scm_cons (scm_i_and
, SCM_UNSPECIFIED
);
928 case (127 & SCM_IM_BEGIN
):
929 ls
= z
= scm_cons (scm_i_begin
, SCM_UNSPECIFIED
);
931 case (127 & SCM_IM_CASE
):
932 ls
= z
= scm_cons (scm_i_case
, SCM_UNSPECIFIED
);
934 case (127 & SCM_IM_COND
):
935 ls
= z
= scm_cons (scm_i_cond
, SCM_UNSPECIFIED
);
937 case (127 & SCM_IM_DO
):
938 ls
= scm_cons (scm_i_do
, SCM_UNSPECIFIED
);
940 case (127 & SCM_IM_IF
):
941 ls
= z
= scm_cons (scm_i_if
, SCM_UNSPECIFIED
);
943 case (127 & SCM_IM_LET
):
944 ls
= scm_cons (scm_i_let
, SCM_UNSPECIFIED
);
946 case (127 & SCM_IM_LETREC
):
949 ls
= scm_cons (scm_i_letrec
, SCM_UNSPECIFIED
);
954 z
= EXTEND_ENV (f
, SCM_EOL
, env
);
955 e
= scm_reverse (unmemocopy (SCM_CAR (x
),
956 SCM_CAR (ls
) == scm_i_letrec
? z
: env
));
958 s
= SCM_CAR (ls
) == scm_i_do
959 ? scm_reverse (unmemocopy (SCM_CDR (SCM_CDR (SCM_CDR (x
))), env
))
964 z
= scm_acons (SCM_CAR (v
),
965 scm_cons (SCM_CAR (e
),
966 SCM_CAR (s
) == SCM_CAR (v
)
968 : scm_cons (SCM_CAR (s
), SCM_EOL
)),
975 z
= scm_cons (z
, SCM_UNSPECIFIED
);
977 if (SCM_CAR (ls
) == scm_i_do
)
980 SCM_SETCDR (z
, scm_cons (unmemocopy (SCM_CAR (x
), env
),
983 x
= (SCM
) (SCM_CARLOC (SCM_CDR (x
)) - 1);
987 case (127 & SCM_IM_LETSTAR
):
995 env
= EXTEND_ENV (SCM_EOL
, SCM_EOL
, env
);
998 y
= z
= scm_acons (SCM_CAR (b
),
1000 scm_cons (unmemocopy (SCM_CAR (SCM_CDR (b
)), env
), SCM_EOL
), env
),
1002 env
= EXTEND_ENV (SCM_CAR (b
), SCM_BOOL_F
, env
);
1003 b
= SCM_CDR (SCM_CDR (b
));
1006 SCM_SETCDR (y
, SCM_EOL
);
1007 ls
= scm_cons (scm_i_let
, z
= scm_cons (y
, SCM_UNSPECIFIED
));
1012 SCM_SETCDR (z
, scm_acons (SCM_CAR (b
),
1014 scm_cons (unmemocopy (SCM_CAR (SCM_CDR (b
)), env
), SCM_EOL
), env
),
1017 env
= EXTEND_ENV (SCM_CAR (b
), SCM_BOOL_F
, env
);
1018 b
= SCM_CDR (SCM_CDR (b
));
1021 SCM_SETCDR (z
, SCM_EOL
);
1023 ls
= scm_cons (scm_i_letstar
, z
= scm_cons (y
, SCM_UNSPECIFIED
));
1026 case (127 & SCM_IM_OR
):
1027 ls
= z
= scm_cons (scm_i_or
, SCM_UNSPECIFIED
);
1029 case (127 & SCM_IM_LAMBDA
):
1031 ls
= scm_cons (scm_i_lambda
,
1032 z
= scm_cons (SCM_CAR (x
), SCM_UNSPECIFIED
));
1033 env
= EXTEND_ENV (SCM_CAR (x
), SCM_EOL
, env
);
1035 case (127 & SCM_IM_QUOTE
):
1036 ls
= z
= scm_cons (scm_i_quote
, SCM_UNSPECIFIED
);
1038 case (127 & SCM_IM_SET
):
1039 ls
= z
= scm_cons (scm_i_set
, SCM_UNSPECIFIED
);
1041 case (127 & SCM_IM_DEFINE
):
1045 ls
= scm_cons (scm_i_define
,
1046 z
= scm_cons (n
= SCM_CAR (x
), SCM_UNSPECIFIED
));
1047 if (SCM_NNULLP (env
))
1048 SCM_SETCAR (SCM_CAR (env
), scm_cons (n
, SCM_CAR (SCM_CAR (env
))));
1051 case (127 & SCM_MAKISYM (0)):
1055 switch SCM_ISYMNUM (z
)
1057 case (SCM_ISYMNUM (SCM_IM_APPLY
)):
1058 ls
= z
= scm_cons (scm_i_atapply
, SCM_UNSPECIFIED
);
1060 case (SCM_ISYMNUM (SCM_IM_CONT
)):
1061 ls
= z
= scm_cons (scm_i_atcall_cc
, SCM_UNSPECIFIED
);
1067 ls
= z
= unmemocar (scm_cons (unmemocopy (SCM_CAR (x
), env
),
1072 while (SCM_CELLP (x
= SCM_CDR (x
)) && SCM_ECONSP (x
))
1074 SCM_SETCDR (z
, unmemocar (scm_cons (unmemocopy (SCM_CAR (x
), env
),
1080 #ifdef DEBUG_EXTENSIONS
1081 if (SCM_NFALSEP (p
))
1082 scm_whash_insert (scm_source_whash
, ls
, p
);
1089 scm_unmemocopy (x
, env
)
1093 if (SCM_NNULLP (env
))
1094 /* Make a copy of the lowest frame to protect it from
1095 modifications by SCM_IM_DEFINE */
1096 return unmemocopy (x
, scm_cons (SCM_CAR (env
), SCM_CDR (env
)));
1098 return unmemocopy (x
, env
);
1104 scm_badargsp (formals
, args
)
1115 formals
= SCM_CDR (formals
);
1116 args
= SCM_CDR (args
);
1118 return SCM_NNULLP (args
) ? 1 : 0;
1124 long scm_tc16_macro
;
1128 scm_eval_args (l
, env
)
1132 SCM res
= SCM_EOL
, *lloc
= &res
;
1133 while (SCM_NIMP (l
))
1135 *lloc
= scm_cons (EVALCAR (l
, env
), SCM_EOL
);
1136 lloc
= SCM_CDRLOC (*lloc
);
1144 /* SECTION: This code is specific for the debugging support. One
1145 * branch is read when DEVAL isn't defined, the other when DEVAL is
1151 #define SCM_APPLY scm_apply
1152 #define PREP_APPLY(proc, args)
1154 #define RETURN(x) return x;
1155 #ifdef STACK_CHECKING
1156 #ifndef NO_CEVAL_STACK_CHECKING
1157 #define EVAL_STACK_CHECKING
1164 #define SCM_CEVAL scm_deval /* Substitute all uses of scm_ceval */
1166 #define SCM_APPLY scm_dapply
1168 #define PREP_APPLY(p, l) \
1169 { ++debug.info; debug.info->a.proc = p; debug.info->a.args = l; }
1171 #define ENTER_APPLY \
1173 SCM_SET_ARGSREADY (debug);\
1175 if (SCM_APPLY_FRAME_P || (SCM_TRACE_P && PROCTRACEP (proc)))\
1177 SCM tmp, tail = SCM_TRACED_FRAME_P (debug) ? SCM_BOOL_T : SCM_BOOL_F;\
1178 SCM_SET_TRACED_FRAME (debug);\
1179 if (SCM_CHEAPTRAPS_P)\
1181 tmp = scm_make_debugobj ((scm_debug_frame *) &debug);\
1182 scm_ithrow (scm_i_apply_frame, scm_cons2 (tmp, tail, SCM_EOL), 0);\
1186 scm_make_cont (&tmp);\
1187 if (!setjmp (SCM_JMPBUF (tmp)))\
1188 scm_ithrow (scm_i_apply_frame, scm_cons2 (tmp, tail, SCM_EOL), 0);\
1193 #define RETURN(e) {proc = (e); goto exit;}
1194 #ifdef STACK_CHECKING
1195 #ifndef EVAL_STACK_CHECKING
1196 #define EVAL_STACK_CHECKING
1200 /* scm_ceval_ptr points to the currently selected evaluator.
1201 * *fixme*: Although efficiency is important here, this state variable
1202 * should probably not be a global. It should be related to the
1207 SCM (*scm_ceval_ptr
) SCM_P ((SCM x
, SCM env
));
1209 /* scm_last_debug_frame contains a pointer to the last debugging
1210 * information stack frame. It is accessed very often from the
1211 * debugging evaluator, so it should probably not be indirectly
1212 * addressed. Better to save and restore it from the current root at
1217 scm_debug_frame
*scm_last_debug_frame
;
1220 /* scm_debug_eframe_size is the number of slots available for pseudo
1221 * stack frames at each real stack frame.
1224 int scm_debug_eframe_size
;
1226 int scm_debug_mode
, scm_check_entry_p
, scm_check_apply_p
, scm_check_exit_p
;
1228 scm_option scm_debug_opts
[] = {
1229 { SCM_OPTION_BOOLEAN
, "cheap", 1,
1230 "*Flyweight representation of the stack at traps." },
1231 { SCM_OPTION_BOOLEAN
, "breakpoints", 0, "*Check for breakpoints." },
1232 { SCM_OPTION_BOOLEAN
, "trace", 0, "*Trace mode." },
1233 { SCM_OPTION_BOOLEAN
, "procnames", 1,
1234 "Record procedure names at definition." },
1235 { SCM_OPTION_BOOLEAN
, "backwards", 0,
1236 "Display backtrace in anti-chronological order." },
1237 { SCM_OPTION_INTEGER
, "indent", 10, "Maximal indentation in backtrace." },
1238 { SCM_OPTION_INTEGER
, "frames", 3,
1239 "Maximum number of tail-recursive frames in backtrace." },
1240 { SCM_OPTION_INTEGER
, "maxdepth", 1000,
1241 "Maximal number of stored backtrace frames." },
1242 { SCM_OPTION_INTEGER
, "depth", 20, "Maximal length of printed backtrace." },
1243 { SCM_OPTION_BOOLEAN
, "backtrace", 0, "Show backtrace on error." },
1244 { SCM_OPTION_BOOLEAN
, "debug", 0, "Use the debugging evaluator." },
1245 { SCM_OPTION_INTEGER
, "stack", 20000, "Stack size limit (0 = no check)." }
1248 scm_option scm_evaluator_trap_table
[] = {
1249 { SCM_OPTION_BOOLEAN
, "enter-frame", 0, "Trap when eval enters new frame." },
1250 { SCM_OPTION_BOOLEAN
, "apply-frame", 0, "Trap when entering apply." },
1251 { SCM_OPTION_BOOLEAN
, "exit-frame", 0, "Trap when exiting eval or apply." }
1255 scm_deval_args (l
, env
, lloc
)
1259 while (SCM_NIMP (l
))
1261 *lloc
= scm_cons (EVALCAR (l
, env
), SCM_EOL
);
1262 lloc
= SCM_CDRLOC (*lloc
);
1271 /* SECTION: Some local definitions for the evaluator.
1276 #define CHECK_EQVISH(A,B) (((A) == (B)) || (SCM_NFALSEP (scm_eqv_p ((A), (B)))))
1278 #define CHECK_EQVISH(A,B) ((A) == (B))
1283 /* SECTION: This is the evaluator. Like any real monster, it has
1284 * three heads. This code is compiled twice.
1319 scm_debug_frame
*prev
;
1321 scm_debug_info vect
[scm_debug_eframe_size
];
1322 scm_debug_info
*info
;
1324 debug
.prev
= scm_last_debug_frame
;
1325 debug
.status
= scm_debug_eframe_size
;
1326 debug
.info
= &debug
.vect
[0];
1327 scm_last_debug_frame
= (scm_debug_frame
*) &debug
;
1329 #ifdef EVAL_STACK_CHECKING
1330 if (SCM_STACK_OVERFLOW_P ((SCM_STACKITEM
*) &proc
)
1331 && scm_stack_checking_enabled_p
)
1334 debug
.info
->e
.exp
= x
;
1335 debug
.info
->e
.env
= env
;
1337 scm_report_stack_overflow ();
1344 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
1347 #if 0 /* This will probably never have any practical use ... */
1350 if (SINGLE_STEP
|| (SCM_TRACE_P
&& SCM_TRACED_FRAME_P (debug
)))
1353 SCM_RESET_DEBUG_MODE
;
1354 SCM_CLEAR_TRACED_FRAME (debug
);
1355 scm_make_cont (&t
.arg1
);
1356 if (!setjmp (SCM_JMPBUF (t
.arg1
)))
1357 scm_ithrow (scm_i_exit_tail
, scm_cons (t
.arg1
, SCM_EOL
), 0);
1362 SCM_CLEAR_ARGSREADY (debug
);
1363 if (SCM_OVERFLOWP (debug
))
1365 else if (++debug
.info
== (scm_debug_info
*) &debug
.info
)
1367 SCM_SET_OVERFLOW (debug
);
1371 debug
.info
->e
.exp
= x
;
1372 debug
.info
->e
.env
= env
;
1374 if (SCM_ENTER_FRAME_P
|| (SCM_BREAKPOINTS_P
&& SRCBRKP (x
)))
1376 SCM tail
= SCM_TAILRECP (debug
) ? SCM_BOOL_T
: SCM_BOOL_F
;
1377 SCM_SET_TAILREC (debug
);
1378 SCM_ENTER_FRAME_P
= 0;
1379 SCM_RESET_DEBUG_MODE
;
1380 if (SCM_CHEAPTRAPS_P
)
1381 t
.arg1
= scm_make_debugobj ((scm_debug_frame
*) &debug
);
1384 scm_make_cont (&t
.arg1
);
1385 if (setjmp (SCM_JMPBUF (t
.arg1
)))
1387 x
= SCM_THROW_VALUE (t
.arg1
);
1393 /* This gives the possibility for the debugger to
1394 modify the source expression before evaluation. */
1398 scm_ithrow (scm_i_enter_frame
,
1399 scm_cons2 (t
.arg1
, tail
,
1400 scm_cons (scm_unmemocopy (x
, env
), SCM_EOL
)),
1406 switch (SCM_TYP7 (x
))
1408 case scm_tcs_symbols
:
1409 /* Only happens when called at top level.
1411 x
= scm_cons (x
, SCM_UNDEFINED
);
1414 case (127 & SCM_IM_AND
):
1417 while (SCM_NNULLP (t
.arg1
= SCM_CDR (t
.arg1
)))
1418 if (SCM_FALSEP (EVALCAR (x
, env
)))
1420 RETURN (SCM_BOOL_F
);
1424 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
1427 case (127 & SCM_IM_BEGIN
):
1429 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
1435 while (SCM_NNULLP (t
.arg1
= SCM_CDR (t
.arg1
)))
1437 SIDEVAL (SCM_CAR (x
), env
);
1441 carloop
: /* scm_eval car of last form in list */
1442 if (SCM_NCELLP (SCM_CAR (x
)))
1445 RETURN (SCM_IMP (x
) ? EVALIM (x
, env
) : SCM_GLOC_VAL (x
))
1448 if (SCM_SYMBOLP (SCM_CAR (x
)))
1451 RETURN (*scm_lookupcar (x
, env
))
1455 goto loop
; /* tail recurse */
1458 case (127 & SCM_IM_CASE
):
1460 t
.arg1
= EVALCAR (x
, env
);
1461 while (SCM_NIMP (x
= SCM_CDR (x
)))
1464 if (scm_i_else
== SCM_CAR (proc
))
1467 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
1470 proc
= SCM_CAR (proc
);
1471 while (SCM_NIMP (proc
))
1473 if (CHECK_EQVISH (SCM_CAR (proc
), t
.arg1
))
1475 x
= SCM_CDR (SCM_CAR (x
));
1476 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
1479 proc
= SCM_CDR (proc
);
1482 RETURN (SCM_UNSPECIFIED
)
1485 case (127 & SCM_IM_COND
):
1486 while (SCM_NIMP (x
= SCM_CDR (x
)))
1489 t
.arg1
= EVALCAR (proc
, env
);
1490 if (SCM_NFALSEP (t
.arg1
))
1497 if (scm_i_arrow
!= SCM_CAR (x
))
1499 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
1503 proc
= EVALCAR (proc
, env
);
1504 SCM_ASRTGO (SCM_NIMP (proc
), badfun
);
1505 PREP_APPLY (proc
, scm_cons (t
.arg1
, SCM_EOL
));
1510 RETURN (SCM_UNSPECIFIED
)
1513 case (127 & SCM_IM_DO
):
1515 proc
= SCM_CAR (SCM_CDR (x
)); /* inits */
1516 t
.arg1
= SCM_EOL
; /* values */
1517 while (SCM_NIMP (proc
))
1519 t
.arg1
= scm_cons (EVALCAR (proc
, env
), t
.arg1
);
1520 proc
= SCM_CDR (proc
);
1522 env
= EXTEND_ENV (SCM_CAR (x
), t
.arg1
, env
);
1523 x
= SCM_CDR (SCM_CDR (x
));
1524 while (proc
= SCM_CAR (x
), SCM_FALSEP (EVALCAR (proc
, env
)))
1526 for (proc
= SCM_CAR (SCM_CDR (x
)); SCM_NIMP (proc
); proc
= SCM_CDR (proc
))
1528 t
.arg1
= SCM_CAR (proc
); /* body */
1529 SIDEVAL (t
.arg1
, env
);
1531 for (t
.arg1
= SCM_EOL
, proc
= SCM_CDR (SCM_CDR (x
)); SCM_NIMP (proc
); proc
= SCM_CDR (proc
))
1532 t
.arg1
= scm_cons (EVALCAR (proc
, env
), t
.arg1
); /* steps */
1533 env
= EXTEND_ENV (SCM_CAR (SCM_CAR (env
)), t
.arg1
, SCM_CDR (env
));
1537 RETURN (SCM_UNSPECIFIED
);
1538 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
1542 case (127 & SCM_IM_IF
):
1544 if (SCM_NFALSEP (EVALCAR (x
, env
)))
1546 else if (SCM_IMP (x
= SCM_CDR (SCM_CDR (x
))))
1548 RETURN (SCM_UNSPECIFIED
);
1550 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
1554 case (127 & SCM_IM_LET
):
1556 proc
= SCM_CAR (SCM_CDR (x
));
1560 t
.arg1
= scm_cons (EVALCAR (proc
, env
), t
.arg1
);
1562 while (SCM_NIMP (proc
= SCM_CDR (proc
)));
1563 env
= EXTEND_ENV (SCM_CAR (x
), t
.arg1
, env
);
1568 case (127 & SCM_IM_LETREC
):
1570 env
= EXTEND_ENV (SCM_CAR (x
), scm_undefineds
, env
);
1576 t
.arg1
= scm_cons (EVALCAR (proc
, env
), t
.arg1
);
1578 while (SCM_NIMP (proc
= SCM_CDR (proc
)));
1579 SCM_SETCDR (SCM_CAR (env
), t
.arg1
);
1583 case (127 & SCM_IM_LETSTAR
):
1588 env
= EXTEND_ENV (SCM_EOL
, SCM_EOL
, env
);
1593 t
.arg1
= SCM_CAR (proc
);
1594 proc
= SCM_CDR (proc
);
1595 env
= EXTEND_ENV (t
.arg1
, EVALCAR (proc
, env
), env
);
1597 while (SCM_NIMP (proc
= SCM_CDR (proc
)));
1600 case (127 & SCM_IM_OR
):
1603 while (SCM_NNULLP (t
.arg1
= SCM_CDR (t
.arg1
)))
1605 x
= EVALCAR (x
, env
);
1606 if (SCM_NFALSEP (x
))
1612 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
1616 case (127 & SCM_IM_LAMBDA
):
1617 RETURN (scm_closure (SCM_CDR (x
), env
));
1620 case (127 & SCM_IM_QUOTE
):
1621 RETURN (SCM_CAR (SCM_CDR (x
)));
1624 case (127 & SCM_IM_SET
):
1627 switch (7 & (int) proc
)
1630 t
.lloc
= scm_lookupcar (x
, env
);
1633 t
.lloc
= SCM_GLOC_VAL_LOC (proc
);
1635 #ifdef MEMOIZE_LOCALS
1637 t
.lloc
= scm_ilookup (proc
, env
);
1642 *t
.lloc
= EVALCAR (x
, env
);
1646 RETURN (SCM_UNSPECIFIED
);
1650 case (127 & SCM_IM_DEFINE
): /* only for internal defines */
1654 x
= evalcar (x
, env
);
1655 #ifdef DEBUG_EXTENSIONS
1656 if (SCM_REC_PROCNAMES_P
&& SCM_NIMP (x
) && SCM_CLOSUREP (x
))
1657 scm_set_procedure_property_x (x
, scm_i_name
, proc
);
1659 env
= SCM_CAR (env
);
1661 SCM_SETCAR (env
, scm_cons (proc
, SCM_CAR (env
)));
1662 SCM_SETCDR (env
, scm_cons (x
, SCM_CDR (env
)));
1664 RETURN (SCM_UNSPECIFIED
);
1668 /* new syntactic forms go here. */
1669 case (127 & SCM_MAKISYM (0)):
1671 SCM_ASRTGO (SCM_ISYMP (proc
), badfun
);
1672 switch SCM_ISYMNUM (proc
)
1675 case (SCM_ISYMNUM (IM_VREF
)):
1678 var
= SCM_CAR (SCM_CDR (x
));
1679 RETURN (SCM_CDR(var
));
1681 case (SCM_ISYMNUM (IM_VSET
)):
1682 SCM_CDR (SCM_CAR ( SCM_CDR (x
))) = EVALCAR( SCM_CDR ( SCM_CDR (x
)), env
);
1683 SCM_CAR (SCM_CAR ( SCM_CDR (x
))) = scm_tc16_variable
;
1684 RETURN (SCM_UNSPECIFIED
)
1687 case (SCM_ISYMNUM (SCM_IM_APPLY
)):
1689 proc
= EVALCAR (proc
, env
);
1690 SCM_ASRTGO (SCM_NIMP (proc
), badfun
);
1691 if (SCM_CLOSUREP (proc
))
1693 PREP_APPLY (proc
, SCM_EOL
);
1694 t
.arg1
= SCM_CDR (SCM_CDR (x
));
1695 t
.arg1
= EVALCAR (t
.arg1
, env
);
1697 debug
.info
->a
.args
= t
.arg1
;
1700 if (scm_badargsp (SCM_CAR (SCM_CODE (proc
)), t
.arg1
))
1703 env
= EXTEND_ENV (SCM_CAR (SCM_CODE (proc
)), t
.arg1
, SCM_ENV (proc
));
1704 x
= SCM_CODE (proc
);
1710 case (SCM_ISYMNUM (SCM_IM_CONT
)):
1711 scm_make_cont (&t
.arg1
);
1712 if (setjmp (SCM_JMPBUF (t
.arg1
)))
1715 val
= SCM_THROW_VALUE (t
.arg1
);
1719 proc
= evalcar (proc
, env
);
1720 SCM_ASRTGO (SCM_NIMP (proc
), badfun
);
1721 PREP_APPLY (proc
, scm_cons (t
.arg1
, SCM_EOL
));
1732 /* scm_everr (x, env,...) */
1733 scm_misc_error (NULL
,
1734 "Wrong type to apply: %S",
1735 scm_listify (proc
, SCM_UNDEFINED
));
1736 case scm_tc7_vector
:
1739 case scm_tc7_byvect
:
1747 case scm_tc7_llvect
:
1749 case scm_tc7_string
:
1750 case scm_tc7_mb_string
:
1751 case scm_tc7_substring
:
1752 case scm_tc7_mb_substring
:
1754 case scm_tcs_closures
:
1758 #ifdef MEMOIZE_LOCALS
1759 case (127 & SCM_ILOC00
):
1760 proc
= *scm_ilookup (SCM_CAR (x
), env
);
1761 SCM_ASRTGO (SCM_NIMP (proc
), badfun
);
1768 #endif /* ifdef MEMOIZE_LOCALS */
1771 case scm_tcs_cons_gloc
:
1772 proc
= SCM_GLOC_VAL (SCM_CAR (x
));
1773 SCM_ASRTGO (SCM_NIMP (proc
), badfun
);
1782 case scm_tcs_cons_nimcar
:
1783 if (SCM_SYMBOLP (SCM_CAR (x
)))
1785 proc
= *scm_lookupcar (x
, env
);
1791 if (scm_tc16_macro
== SCM_TYP16 (proc
))
1796 t
.arg1
= SCM_APPLY (SCM_CDR (proc
), x
, scm_cons (env
, scm_listofnull
));
1797 switch ((int) (SCM_CAR (proc
) >> 16))
1800 if (scm_ilength (t
.arg1
) <= 0)
1801 t
.arg1
= scm_cons2 (SCM_IM_BEGIN
, t
.arg1
, SCM_EOL
);
1803 if (!SCM_CLOSUREP (SCM_CDR (proc
)))
1805 #if 0 /* Top-level defines doesn't very often occur in backtraces */
1806 if (scm_m_define
== SCM_SUBRF (SCM_CDR (proc
)) && SCM_TOP_LEVEL (env
))
1807 /* Prevent memoizing result of define macro */
1809 debug
.info
->e
.exp
= scm_cons (SCM_CAR (x
), SCM_CDR (x
));
1810 scm_set_source_properties_x (debug
.info
->e
.exp
,
1811 scm_source_properties (x
));
1815 SCM_SETCAR (x
, SCM_CAR (t
.arg1
));
1816 SCM_SETCDR (x
, SCM_CDR (t
.arg1
));
1820 /* Prevent memoizing of debug info expression. */
1821 debug
.info
->e
.exp
= scm_cons (SCM_CAR (x
), SCM_CDR (x
));
1822 scm_set_source_properties_x (debug
.info
->e
.exp
,
1823 scm_source_properties (x
));
1826 SCM_SETCAR (x
, SCM_CAR (t
.arg1
));
1827 SCM_SETCDR (x
, SCM_CDR (t
.arg1
));
1831 if (SCM_NIMP (x
= t
.arg1
))
1839 proc
= SCM_CEVAL (SCM_CAR (x
), env
);
1840 SCM_ASRTGO (SCM_NIMP (proc
), badfun
);
1845 if (SCM_CLOSUREP (proc
))
1847 arg2
= SCM_CAR (SCM_CODE (proc
));
1848 t
.arg1
= SCM_CDR (x
);
1849 while (SCM_NIMP (arg2
))
1851 if (SCM_NCONSP (arg2
))
1853 if (SCM_IMP (t
.arg1
))
1854 goto umwrongnumargs
;
1855 arg2
= SCM_CDR (arg2
);
1856 t
.arg1
= SCM_CDR (t
.arg1
);
1858 if (SCM_NNULLP (t
.arg1
))
1859 goto umwrongnumargs
;
1861 else if (scm_tc16_macro
== SCM_TYP16 (proc
))
1862 goto handle_a_macro
;
1868 PREP_APPLY (proc
, SCM_EOL
);
1869 if (SCM_NULLP (SCM_CDR (x
))) {
1871 switch (SCM_TYP7 (proc
))
1872 { /* no arguments given */
1873 case scm_tc7_subr_0
:
1874 RETURN (SCM_SUBRF (proc
) ());
1875 case scm_tc7_subr_1o
:
1876 RETURN (SCM_SUBRF (proc
) (SCM_UNDEFINED
));
1878 RETURN (SCM_SUBRF (proc
) (SCM_EOL
));
1879 case scm_tc7_rpsubr
:
1880 RETURN (SCM_BOOL_T
);
1882 RETURN (SCM_SUBRF (proc
) (SCM_UNDEFINED
, SCM_UNDEFINED
));
1886 proc
= SCM_CCLO_SUBR (proc
);
1888 debug
.info
->a
.proc
= proc
;
1889 debug
.info
->a
.args
= scm_cons (t
.arg1
, SCM_EOL
);
1893 case scm_tcs_closures
:
1894 x
= SCM_CODE (proc
);
1895 env
= EXTEND_ENV (SCM_CAR (x
), SCM_EOL
, SCM_ENV (proc
));
1897 case scm_tc7_contin
:
1898 case scm_tc7_subr_1
:
1899 case scm_tc7_subr_2
:
1900 case scm_tc7_subr_2o
:
1902 case scm_tc7_subr_3
:
1903 case scm_tc7_lsubr_2
:
1907 /* scm_everr (x, env,...) */
1908 scm_wrong_num_args (proc
);
1910 /* handle macros here */
1915 /* must handle macros by here */
1921 t
.arg1
= EVALCAR (x
, env
);
1923 debug
.info
->a
.args
= scm_cons (t
.arg1
, SCM_EOL
);
1930 switch (SCM_TYP7 (proc
))
1931 { /* have one argument in t.arg1 */
1932 case scm_tc7_subr_2o
:
1933 RETURN (SCM_SUBRF (proc
) (t
.arg1
, SCM_UNDEFINED
));
1934 case scm_tc7_subr_1
:
1935 case scm_tc7_subr_1o
:
1936 RETURN (SCM_SUBRF (proc
) (t
.arg1
));
1939 if (SCM_SUBRF (proc
))
1941 if (SCM_INUMP (t
.arg1
))
1943 RETURN (scm_makdbl (SCM_DSUBRF (proc
) ((double) SCM_INUM (t
.arg1
)),
1946 SCM_ASRTGO (SCM_NIMP (t
.arg1
), floerr
);
1947 if (SCM_REALP (t
.arg1
))
1949 RETURN (scm_makdbl (SCM_DSUBRF (proc
) (SCM_REALPART (t
.arg1
)), 0.0));
1952 if (SCM_BIGP (t
.arg1
))
1954 RETURN (scm_makdbl (SCM_DSUBRF (proc
) (scm_big2dbl (t
.arg1
)), 0.0));
1958 scm_wta (t
.arg1
, (char *) SCM_ARG1
, SCM_CHARS (SCM_SNAME (proc
)));
1961 proc
= (SCM
) SCM_SNAME (proc
);
1963 char *chrs
= SCM_CHARS (proc
) + SCM_LENGTH (proc
) - 1;
1964 while ('c' != *--chrs
)
1966 SCM_ASSERT (SCM_NIMP (t
.arg1
) && SCM_CONSP (t
.arg1
),
1967 t
.arg1
, SCM_ARG1
, SCM_CHARS (proc
));
1968 t
.arg1
= ('a' == *chrs
) ? SCM_CAR (t
.arg1
) : SCM_CDR (t
.arg1
);
1972 case scm_tc7_rpsubr
:
1973 RETURN (SCM_BOOL_T
);
1975 RETURN (SCM_SUBRF (proc
) (t
.arg1
, SCM_UNDEFINED
));
1978 RETURN (SCM_SUBRF (proc
) (debug
.info
->a
.args
))
1980 RETURN (SCM_SUBRF (proc
) (scm_cons (t
.arg1
, SCM_EOL
)));
1986 proc
= SCM_CCLO_SUBR (proc
);
1988 debug
.info
->a
.args
= scm_cons (t
.arg1
, debug
.info
->a
.args
);
1989 debug
.info
->a
.proc
= proc
;
1993 case scm_tcs_closures
:
1994 x
= SCM_CODE (proc
);
1996 env
= EXTEND_ENV (SCM_CAR (x
), debug
.info
->a
.args
, SCM_ENV (proc
));
1998 env
= EXTEND_ENV (SCM_CAR (x
), scm_cons (t
.arg1
, SCM_EOL
), SCM_ENV (proc
));
2001 case scm_tc7_contin
:
2002 scm_call_continuation (proc
, t
.arg1
);
2003 case scm_tc7_subr_2
:
2004 case scm_tc7_subr_0
:
2005 case scm_tc7_subr_3
:
2006 case scm_tc7_lsubr_2
:
2016 { /* have two or more arguments */
2017 arg2
= EVALCAR (x
, env
);
2019 debug
.info
->a
.args
= scm_cons2 (t
.arg1
, arg2
, SCM_EOL
);
2022 if (SCM_NULLP (x
)) {
2027 switch (SCM_TYP7 (proc
))
2028 { /* have two arguments */
2029 case scm_tc7_subr_2
:
2030 case scm_tc7_subr_2o
:
2031 RETURN (SCM_SUBRF (proc
) (t
.arg1
, arg2
));
2034 RETURN (SCM_SUBRF (proc
) (debug
.info
->a
.args
))
2036 RETURN (SCM_SUBRF (proc
) (scm_cons2 (t
.arg1
, arg2
, SCM_EOL
)));
2038 case scm_tc7_lsubr_2
:
2039 RETURN (SCM_SUBRF (proc
) (t
.arg1
, arg2
, SCM_EOL
));
2040 case scm_tc7_rpsubr
:
2042 RETURN (SCM_SUBRF (proc
) (t
.arg1
, arg2
));
2047 RETURN (SCM_APPLY (SCM_CCLO_SUBR (proc
), proc
,
2048 scm_cons (debug
.info
->a
.args
, SCM_EOL
)));
2050 RETURN (SCM_APPLY (SCM_CCLO_SUBR (proc
), proc
,
2051 scm_cons2 (t
.arg1
, arg2
,
2052 scm_cons (scm_eval_args (x
, env
), SCM_EOL
))));
2054 /* case scm_tc7_cclo:
2055 x = scm_cons(arg2, scm_eval_args(x, env));
2058 proc = SCM_CCLO_SUBR(proc);
2061 case scm_tc7_subr_0
:
2063 case scm_tc7_subr_1o
:
2064 case scm_tc7_subr_1
:
2065 case scm_tc7_subr_3
:
2066 case scm_tc7_contin
:
2070 case scm_tcs_closures
:
2072 env
= EXTEND_ENV (SCM_CAR (SCM_CODE (proc
)), debug
.info
->a
.args
, SCM_ENV (proc
));
2074 env
= EXTEND_ENV (SCM_CAR (SCM_CODE (proc
)), scm_cons2 (t
.arg1
, arg2
, SCM_EOL
), SCM_ENV (proc
));
2076 x
= SCM_CODE (proc
);
2081 debug
.info
->a
.args
= scm_cons2 (t
.arg1
, arg2
,
2082 scm_deval_args (x
, env
, SCM_CDRLOC (SCM_CDR (debug
.info
->a
.args
))));
2085 switch (SCM_TYP7 (proc
))
2086 { /* have 3 or more arguments */
2088 case scm_tc7_subr_3
:
2089 SCM_ASRTGO (SCM_NULLP (SCM_CDR (x
)), wrongnumargs
);
2090 RETURN (SCM_SUBRF (proc
) (t
.arg1
, arg2
, SCM_CAR (SCM_CDR (SCM_CDR (debug
.info
->a
.args
)))));
2092 /* t.arg1 = SCM_SUBRF(proc)(t.arg1, arg2);
2094 t.arg1 = SCM_SUBRF(proc)(t.arg1, EVALCAR(x, env));
2098 case scm_tc7_rpsubr
:
2099 RETURN (SCM_APPLY (proc
, t
.arg1
, scm_acons (arg2
, SCM_CDR (SCM_CDR (debug
.info
->a
.args
)), SCM_EOL
)))
2100 case scm_tc7_lsubr_2
:
2101 RETURN (SCM_SUBRF (proc
) (t
.arg1
, arg2
, SCM_CDR (SCM_CDR (debug
.info
->a
.args
))))
2103 RETURN (SCM_SUBRF (proc
) (debug
.info
->a
.args
))
2108 case scm_tcs_closures
:
2109 SCM_SET_ARGSREADY (debug
);
2110 env
= EXTEND_ENV (SCM_CAR (SCM_CODE (proc
)),
2113 x
= SCM_CODE (proc
);
2116 case scm_tc7_subr_3
:
2117 SCM_ASRTGO (SCM_NULLP (SCM_CDR (x
)), wrongnumargs
);
2118 RETURN (SCM_SUBRF (proc
) (t
.arg1
, arg2
, EVALCAR (x
, env
)));
2120 /* t.arg1 = SCM_SUBRF(proc)(t.arg1, arg2);
2122 t.arg1 = SCM_SUBRF(proc)(t.arg1, EVALCAR(x, env));
2126 case scm_tc7_rpsubr
:
2127 RETURN (SCM_APPLY (proc
, t
.arg1
, scm_acons (arg2
, scm_eval_args (x
, env
), SCM_EOL
)));
2128 case scm_tc7_lsubr_2
:
2129 RETURN (SCM_SUBRF (proc
) (t
.arg1
, arg2
, scm_eval_args (x
, env
)));
2131 RETURN (SCM_SUBRF (proc
) (scm_cons2 (t
.arg1
, arg2
, scm_eval_args (x
, env
))));
2136 case scm_tcs_closures
:
2138 SCM_SET_ARGSREADY (debug
);
2140 env
= EXTEND_ENV (SCM_CAR (SCM_CODE (proc
)),
2141 scm_cons2 (t
.arg1
, arg2
, scm_eval_args (x
, env
)),
2143 x
= SCM_CODE (proc
);
2146 case scm_tc7_subr_2
:
2147 case scm_tc7_subr_1o
:
2148 case scm_tc7_subr_2o
:
2149 case scm_tc7_subr_0
:
2151 case scm_tc7_subr_1
:
2152 case scm_tc7_contin
:
2161 if (SCM_EXIT_FRAME_P
|| (SCM_TRACE_P
&& SCM_TRACED_FRAME_P (debug
)))
2163 SCM_EXIT_FRAME_P
= 0;
2164 SCM_RESET_DEBUG_MODE
;
2165 SCM_CLEAR_TRACED_FRAME (debug
);
2166 if (SCM_CHEAPTRAPS_P
)
2167 t
.arg1
= scm_make_debugobj ((scm_debug_frame
*) &debug
);
2170 scm_make_cont (&t
.arg1
);
2171 if (setjmp (SCM_JMPBUF (t
.arg1
)))
2173 proc
= SCM_THROW_VALUE (t
.arg1
);
2177 scm_ithrow (scm_i_exit_frame
, scm_cons2 (t
.arg1
, proc
, SCM_EOL
), 0);
2180 scm_last_debug_frame
= debug
.prev
;
2186 /* SECTION: This code is compiled once.
2191 SCM_PROC(s_procedure_documentation
, "procedure-documentation", 1, 0, 0, scm_procedure_documentation
);
2194 scm_procedure_documentation (proc
)
2198 SCM_ASSERT (SCM_BOOL_T
== scm_procedure_p (proc
) && SCM_NIMP (proc
) && SCM_TYP7 (proc
) != scm_tc7_contin
,
2199 proc
, SCM_ARG1
, s_procedure_documentation
);
2200 switch (SCM_TYP7 (proc
))
2202 case scm_tcs_closures
:
2203 code
= SCM_CDR (SCM_CODE (proc
));
2204 if (SCM_IMP (SCM_CDR (code
)))
2206 code
= SCM_CAR (code
);
2209 if (SCM_STRINGP (code
))
2222 /* This code processes the 'arg ...' parameters to apply.
2224 (apply PROC ARG1 ... ARGS)
2226 The ARG1 ... arguments are consed on to the front of ARGS (which
2227 must be a list), and then PROC is applied to the elements of the
2228 result. apply:nconc2last takes care of building the list of
2229 arguments, given (ARG1 ... ARGS).
2231 apply:nconc2last destroys its argument. On that topic, this code
2232 came into my care with the following beautifully cryptic comment on
2233 that topic: "This will only screw you if you do (scm_apply
2234 scm_apply '( ... ))" If you know what they're referring to, send
2235 me a patch to this comment. */
2237 SCM_PROC(s_nconc2last
, "apply:nconc2last", 1, 0, 0, scm_nconc2last
);
2240 scm_nconc2last (lst
)
2244 SCM_ASSERT (scm_ilength (lst
) > 0, lst
, SCM_ARG1
, s_nconc2last
);
2246 while (SCM_NNULLP (SCM_CDR (*lloc
)))
2247 lloc
= SCM_CDRLOC (*lloc
);
2248 SCM_ASSERT (scm_ilength (SCM_CAR (*lloc
)) >= 0, lst
, SCM_ARG1
, s_nconc2last
);
2249 *lloc
= SCM_CAR (*lloc
);
2256 /* SECTION: When DEVAL is defined this code yields scm_dapply.
2257 * It is compiled twice.
2263 scm_apply (proc
, arg1
, args
)
2273 scm_dapply (proc
, arg1
, args
)
2282 SCM_APPLY (proc
, arg1
, args
)
2287 #ifdef DEBUG_EXTENSIONS
2289 scm_debug_frame debug
;
2290 debug
.prev
= scm_last_debug_frame
;
2291 debug
.status
= SCM_APPLYFRAME
;
2292 debug
.vect
[0].a
.proc
= proc
;
2293 debug
.vect
[0].a
.args
= SCM_EOL
;
2294 scm_last_debug_frame
= &debug
;
2297 return scm_dapply (proc
, arg1
, args
);
2301 SCM_ASRTGO (SCM_NIMP (proc
), badproc
);
2302 if (SCM_NULLP (args
))
2304 if (SCM_NULLP (arg1
))
2305 arg1
= SCM_UNDEFINED
;
2308 args
= SCM_CDR (arg1
);
2309 arg1
= SCM_CAR (arg1
);
2314 /* SCM_ASRTGO(SCM_NIMP(args) && SCM_CONSP(args), wrongnumargs); */
2315 args
= scm_nconc2last (args
);
2318 debug
.vect
[0].a
.args
= scm_cons (arg1
, args
);
2319 if (SCM_ENTER_FRAME_P
)
2322 SCM_ENTER_FRAME_P
= 0;
2323 SCM_RESET_DEBUG_MODE
;
2324 if (SCM_CHEAPTRAPS_P
)
2325 tmp
= scm_make_debugobj ((scm_debug_frame
*) &debug
);
2328 scm_make_cont (&tmp
);
2329 if (setjmp (SCM_JMPBUF (tmp
)))
2332 scm_ithrow (scm_i_enter_frame
, scm_cons (tmp
, SCM_EOL
), 0);
2340 switch (SCM_TYP7 (proc
))
2342 case scm_tc7_subr_2o
:
2343 args
= SCM_NULLP (args
) ? SCM_UNDEFINED
: SCM_CAR (args
);
2344 RETURN (SCM_SUBRF (proc
) (arg1
, args
))
2345 case scm_tc7_subr_2
:
2346 SCM_ASRTGO (SCM_NULLP (SCM_CDR (args
)), wrongnumargs
);
2347 args
= SCM_CAR (args
);
2348 RETURN (SCM_SUBRF (proc
) (arg1
, args
))
2349 case scm_tc7_subr_0
:
2350 SCM_ASRTGO (SCM_UNBNDP (arg1
), wrongnumargs
);
2351 RETURN (SCM_SUBRF (proc
) ())
2352 case scm_tc7_subr_1
:
2353 case scm_tc7_subr_1o
:
2354 SCM_ASRTGO (SCM_NULLP (args
), wrongnumargs
);
2355 RETURN (SCM_SUBRF (proc
) (arg1
))
2357 SCM_ASRTGO (SCM_NULLP (args
), wrongnumargs
);
2359 if (SCM_SUBRF (proc
))
2361 if (SCM_INUMP (arg1
))
2363 RETURN (scm_makdbl (SCM_DSUBRF (proc
) ((double) SCM_INUM (arg1
)), 0.0));
2365 SCM_ASRTGO (SCM_NIMP (arg1
), floerr
);
2366 if (SCM_REALP (arg1
))
2368 RETURN (scm_makdbl (SCM_DSUBRF (proc
) (SCM_REALPART (arg1
)), 0.0));
2373 RETURN (scm_makdbl (SCM_DSUBRF (proc
) (scm_big2dbl (arg1
)), 0.0))
2376 scm_wta (arg1
, (char *) SCM_ARG1
, SCM_CHARS (SCM_SNAME (proc
)));
2379 proc
= (SCM
) SCM_SNAME (proc
);
2381 char *chrs
= SCM_CHARS (proc
) + SCM_LENGTH (proc
) - 1;
2382 while ('c' != *--chrs
)
2384 SCM_ASSERT (SCM_NIMP (arg1
) && SCM_CONSP (arg1
),
2385 arg1
, SCM_ARG1
, SCM_CHARS (proc
));
2386 arg1
= ('a' == *chrs
) ? SCM_CAR (arg1
) : SCM_CDR (arg1
);
2390 case scm_tc7_subr_3
:
2391 RETURN (SCM_SUBRF (proc
) (arg1
, SCM_CAR (args
), SCM_CAR (SCM_CDR (args
))))
2394 RETURN (SCM_SUBRF (proc
) (SCM_UNBNDP (arg1
) ? SCM_EOL
: debug
.vect
[0].a
.args
))
2396 RETURN (SCM_SUBRF (proc
) (SCM_UNBNDP (arg1
) ? SCM_EOL
: scm_cons (arg1
, args
)))
2398 case scm_tc7_lsubr_2
:
2399 SCM_ASRTGO (SCM_NIMP (args
) && SCM_CONSP (args
), wrongnumargs
);
2400 RETURN (SCM_SUBRF (proc
) (arg1
, SCM_CAR (args
), SCM_CDR (args
)))
2402 if (SCM_NULLP (args
))
2403 RETURN (SCM_SUBRF (proc
) (arg1
, SCM_UNDEFINED
))
2404 while (SCM_NIMP (args
))
2406 SCM_ASSERT (SCM_CONSP (args
), args
, SCM_ARG2
, "apply");
2407 arg1
= SCM_SUBRF (proc
) (arg1
, SCM_CAR (args
));
2408 args
= SCM_CDR (args
);
2411 case scm_tc7_rpsubr
:
2412 if (SCM_NULLP (args
))
2413 RETURN (SCM_BOOL_T
);
2414 while (SCM_NIMP (args
))
2416 SCM_ASSERT (SCM_CONSP (args
), args
, SCM_ARG2
, "apply");
2417 if (SCM_FALSEP (SCM_SUBRF (proc
) (arg1
, SCM_CAR (args
))))
2418 RETURN (SCM_BOOL_F
);
2419 arg1
= SCM_CAR (args
);
2420 args
= SCM_CDR (args
);
2422 RETURN (SCM_BOOL_T
);
2423 case scm_tcs_closures
:
2425 arg1
= (SCM_UNBNDP (arg1
) ? SCM_EOL
: debug
.vect
[0].a
.args
);
2427 arg1
= (SCM_UNBNDP (arg1
) ? SCM_EOL
: scm_cons (arg1
, args
));
2430 if (scm_badargsp (SCM_CAR (SCM_CODE (proc
)), arg1
))
2433 args
= EXTEND_ENV (SCM_CAR (SCM_CODE (proc
)), arg1
, SCM_ENV (proc
));
2434 proc
= SCM_CODE (proc
);
2435 while (SCM_NNULLP (proc
= SCM_CDR (proc
)))
2436 arg1
= EVALCAR (proc
, args
);
2438 case scm_tc7_contin
:
2439 SCM_ASRTGO (SCM_NULLP (args
), wrongnumargs
);
2440 scm_call_continuation (proc
, arg1
);
2444 args
= (SCM_UNBNDP(arg1
) ? SCM_EOL
: debug
.vect
[0].a
.args
);
2446 proc
= SCM_CCLO_SUBR (proc
);
2447 debug
.vect
[0].a
.proc
= proc
;
2448 debug
.vect
[0].a
.args
= scm_cons (arg1
, args
);
2450 args
= (SCM_UNBNDP(arg1
) ? SCM_EOL
: scm_cons (arg1
, args
));
2452 proc
= SCM_CCLO_SUBR (proc
);
2457 scm_wrong_num_args (proc
);
2460 scm_wta (proc
, (char *) SCM_ARG1
, "apply");
2466 if (SCM_EXIT_FRAME_P
|| (SCM_TRACE_P
&& SCM_TRACED_FRAME_P (debug
)))
2468 SCM_EXIT_FRAME_P
= 0;
2469 SCM_RESET_DEBUG_MODE
;
2470 SCM_CLEAR_TRACED_FRAME (debug
);
2471 if (SCM_CHEAPTRAPS_P
)
2472 arg1
= scm_make_debugobj ((scm_debug_frame
*) &debug
);
2475 scm_make_cont (&arg1
);
2476 if (setjmp (SCM_JMPBUF (arg1
)))
2478 proc
= SCM_THROW_VALUE (arg1
);
2482 scm_ithrow (scm_i_exit_frame
, scm_cons2 (arg1
, proc
, SCM_EOL
), 0);
2485 scm_last_debug_frame
= debug
.prev
;
2491 /* SECTION: The rest of this file is only read once.
2496 SCM_PROC(s_map
, "map", 2, 0, 1, scm_map
);
2499 scm_map (proc
, arg1
, args
)
2507 SCM
*ve
= &args
; /* Keep args from being optimized away. */
2509 if (SCM_NULLP (arg1
))
2511 SCM_ASSERT (SCM_NIMP (arg1
), arg1
, SCM_ARG2
, s_map
);
2512 if (SCM_NULLP (args
))
2514 while (SCM_NIMP (arg1
))
2516 SCM_ASSERT (SCM_CONSP (arg1
), arg1
, SCM_ARG2
, s_map
);
2517 *pres
= scm_cons (scm_apply (proc
, SCM_CAR (arg1
), scm_listofnull
), SCM_EOL
);
2518 pres
= SCM_CDRLOC (*pres
);
2519 arg1
= SCM_CDR (arg1
);
2523 args
= scm_vector (scm_cons (arg1
, args
));
2524 ve
= SCM_VELTS (args
);
2526 for (i
= SCM_LENGTH (args
) - 1; i
>= 0; i
--)
2527 SCM_ASSERT (SCM_NIMP (ve
[i
]) && SCM_CONSP (ve
[i
]), args
, SCM_ARG2
, s_map
);
2532 for (i
= SCM_LENGTH (args
) - 1; i
>= 0; i
--)
2536 arg1
= scm_cons (SCM_CAR (ve
[i
]), arg1
);
2537 ve
[i
] = SCM_CDR (ve
[i
]);
2539 *pres
= scm_cons (scm_apply (proc
, arg1
, SCM_EOL
), SCM_EOL
);
2540 pres
= SCM_CDRLOC (*pres
);
2545 SCM_PROC(s_for_each
, "for-each", 2, 0, 1, scm_for_each
);
2548 scm_for_each (proc
, arg1
, args
)
2553 SCM
*ve
= &args
; /* Keep args from being optimized away. */
2556 return SCM_UNSPECIFIED
;
2557 SCM_ASSERT (SCM_NIMP (arg1
), arg1
, SCM_ARG2
, s_for_each
);
2560 while SCM_NIMP (arg1
)
2562 SCM_ASSERT (SCM_CONSP (arg1
), arg1
, SCM_ARG2
, s_for_each
);
2563 scm_apply (proc
, SCM_CAR (arg1
), scm_listofnull
);
2564 arg1
= SCM_CDR (arg1
);
2566 return SCM_UNSPECIFIED
;
2568 args
= scm_vector (scm_cons (arg1
, args
));
2569 ve
= SCM_VELTS (args
);
2571 for (i
= SCM_LENGTH (args
) - 1; i
>= 0; i
--)
2572 SCM_ASSERT (SCM_NIMP (ve
[i
]) && SCM_CONSP (ve
[i
]), args
, SCM_ARG2
, s_for_each
);
2577 for (i
= SCM_LENGTH (args
) - 1; i
>= 0; i
--)
2580 (ve
[i
]) return SCM_UNSPECIFIED
;
2581 arg1
= scm_cons (SCM_CAR (ve
[i
]), arg1
);
2582 ve
[i
] = SCM_CDR (ve
[i
]);
2584 scm_apply (proc
, arg1
, SCM_EOL
);
2591 scm_closure (code
, env
)
2597 SCM_SETCODE (z
, code
);
2598 SCM_SETENV (z
, env
);
2603 long scm_tc16_promise
;
2611 SCM_SETCDR (z
, code
);
2612 SCM_SETCAR (z
, scm_tc16_promise
);
2618 static int prinprom
SCM_P ((SCM exp
, SCM port
, scm_print_state
*pstate
));
2621 prinprom (exp
, port
, pstate
)
2624 scm_print_state
*pstate
;
2626 int writingp
= SCM_WRITINGP (pstate
);
2627 scm_gen_puts (scm_regular_string
, "#<promise ", port
);
2628 SCM_SET_WRITINGP (pstate
, 1);
2629 scm_iprin1 (SCM_CDR (exp
), port
, pstate
);
2630 SCM_SET_WRITINGP (pstate
, writingp
);
2631 scm_gen_putc ('>', port
);
2636 SCM_PROC(s_makacro
, "procedure->syntax", 1, 0, 0, scm_makacro
);
2644 SCM_SETCDR (z
, code
);
2645 SCM_SETCAR (z
, scm_tc16_macro
);
2650 SCM_PROC(s_makmacro
, "procedure->macro", 1, 0, 0, scm_makmacro
);
2658 SCM_SETCDR (z
, code
);
2659 SCM_SETCAR (z
, scm_tc16_macro
| (1L << 16));
2664 SCM_PROC(s_makmmacro
, "procedure->memoizing-macro", 1, 0, 0, scm_makmmacro
);
2667 scm_makmmacro (code
)
2672 SCM_SETCDR (z
, code
);
2673 SCM_SETCAR (z
, scm_tc16_macro
| (2L << 16));
2679 static int prinmacro
SCM_P ((SCM exp
, SCM port
, scm_print_state
*pstate
));
2682 prinmacro (exp
, port
, pstate
)
2685 scm_print_state
*pstate
;
2687 int writingp
= SCM_WRITINGP (pstate
);
2688 if (SCM_CAR (exp
) & (3L << 16))
2689 scm_gen_puts (scm_regular_string
, "#<macro", port
);
2691 scm_gen_puts (scm_regular_string
, "#<syntax", port
);
2692 if (SCM_CAR (exp
) & (2L << 16))
2693 scm_gen_putc ('!', port
);
2694 scm_gen_putc (' ', port
);
2695 SCM_SET_WRITINGP (pstate
, 1);
2696 scm_iprin1 (SCM_CDR (exp
), port
, pstate
);
2697 SCM_SET_WRITINGP (pstate
, writingp
);
2698 scm_gen_putc ('>', port
);
2702 SCM_PROC(s_force
, "force", 1, 0, 0, scm_force
);
2708 SCM_ASSERT ((SCM_TYP16 (x
) == scm_tc16_promise
), x
, SCM_ARG1
, s_force
);
2709 if (!((1L << 16) & SCM_CAR (x
)))
2711 SCM ans
= scm_apply (SCM_CDR (x
), SCM_EOL
, SCM_EOL
);
2712 if (!((1L << 16) & SCM_CAR (x
)))
2715 SCM_SETCDR (x
, ans
);
2716 SCM_SETOR_CAR (x
, (1L << 16));
2723 SCM_PROC (s_promise_p
, "promise?", 1, 0, 0, scm_promise_p
);
2729 return ((SCM_NIMP (x
) && (SCM_TYP16 (x
) == scm_tc16_promise
))
2734 SCM_PROC(s_copy_tree
, "copy-tree", 1, 0, 0, scm_copy_tree
);
2743 if (SCM_VECTORP (obj
))
2745 scm_sizet i
= SCM_LENGTH (obj
);
2746 ans
= scm_make_vector (SCM_MAKINUM (i
), SCM_UNSPECIFIED
, SCM_UNDEFINED
);
2748 SCM_VELTS (ans
)[i
] = scm_copy_tree (SCM_VELTS (obj
)[i
]);
2753 /* return scm_cons(scm_copy_tree(SCM_CAR(obj)), scm_copy_tree(SCM_CDR(obj))); */
2754 ans
= tl
= scm_cons (scm_copy_tree (SCM_CAR (obj
)), SCM_UNSPECIFIED
);
2755 while (SCM_NIMP (obj
= SCM_CDR (obj
)) && SCM_CONSP (obj
))
2757 SCM_SETCDR (tl
, scm_cons (scm_copy_tree (SCM_CAR (obj
)),
2761 SCM_SETCDR (tl
, obj
);
2767 scm_eval_3 (obj
, copyp
, env
)
2772 if (SCM_NIMP (SCM_CDR (scm_system_transformer
)))
2773 obj
= scm_apply (SCM_CDR (scm_system_transformer
), obj
, scm_listofnull
);
2775 obj
= scm_copy_tree (obj
);
2776 return XEVAL (obj
, env
);
2781 scm_top_level_env (thunk
)
2787 return scm_cons(thunk
, (SCM
)SCM_EOL
);
2790 SCM_PROC(s_eval2
, "eval2", 2, 0, 0, scm_eval2
);
2793 scm_eval2 (obj
, env_thunk
)
2797 return scm_eval_3 (obj
, 1, scm_top_level_env(env_thunk
));
2800 SCM_PROC(s_eval
, "eval", 1, 0, 0, scm_eval
);
2807 scm_eval_3(obj
, 1, scm_top_level_env(SCM_CDR(scm_top_level_lookup_closure_var
)));
2810 /* SCM_PROC(s_eval_x, "eval!", 1, 0, 0, scm_eval_x); */
2819 scm_top_level_env (SCM_CDR (scm_top_level_lookup_closure_var
)));
2822 SCM_PROC (s_macro_eval_x
, "macro-eval!", 2, 0, 0, scm_macro_eval_x
);
2825 scm_macro_eval_x (exp
, env
)
2829 return scm_eval_3 (exp
, 0, env
);
2834 scm_definedp (x
, env
)
2838 SCM proc
= SCM_CAR (x
= SCM_CDR (x
));
2839 if (SCM_ISYMP (proc
))
2841 else if(SCM_IMP(proc
) || !SCM_SYMBOLP(proc
))
2845 SCM vcell
= scm_sym2vcell(proc
, env_top_level(env
), SCM_BOOL_F
);
2846 return (vcell
== SCM_BOOL_F
|| SCM_UNBNDP(SCM_CDR(vcell
))) ? SCM_BOOL_F
: SCM_BOOL_T
;
2850 static scm_smobfuns promsmob
=
2851 {scm_markcdr
, scm_free0
, prinprom
};
2853 static scm_smobfuns macrosmob
=
2854 {scm_markcdr
, scm_free0
, prinmacro
};
2858 scm_make_synt (name
, macroizer
, fcn
)
2860 SCM (*macroizer
) ();
2863 SCM symcell
= scm_sysintern (name
, SCM_UNDEFINED
);
2864 long tmp
= ((((SCM_CELLPTR
) (SCM_CAR (symcell
))) - scm_heap_org
) << 8);
2866 if ((tmp
>> 8) != ((SCM_CELLPTR
) (SCM_CAR (symcell
)) - scm_heap_org
))
2869 SCM_SUBRF (z
) = fcn
;
2870 SCM_SETCAR (z
, tmp
+ scm_tc7_subr_2
);
2871 SCM_SETCDR (symcell
, macroizer (z
));
2872 return SCM_CAR (symcell
);
2876 /* At this point, scm_deval and scm_dapply are generated.
2879 #ifdef DEBUG_EXTENSIONS
2889 scm_tc16_promise
= scm_newsmob (&promsmob
);
2890 scm_tc16_macro
= scm_newsmob (¯osmob
);
2891 scm_i_apply
= scm_make_subr ("apply", scm_tc7_lsubr_2
, scm_apply
);
2892 scm_system_transformer
= scm_sysintern ("scm:eval-transformer", SCM_UNDEFINED
);
2893 scm_i_dot
= SCM_CAR (scm_sysintern (".", SCM_UNDEFINED
));
2894 scm_i_arrow
= SCM_CAR (scm_sysintern ("=>", SCM_UNDEFINED
));
2895 scm_i_else
= SCM_CAR (scm_sysintern ("else", SCM_UNDEFINED
));
2896 scm_i_unquote
= SCM_CAR (scm_sysintern ("unquote", SCM_UNDEFINED
));
2897 scm_i_uq_splicing
= SCM_CAR (scm_sysintern ("unquote-splicing", SCM_UNDEFINED
));
2900 scm_i_quasiquote
= scm_make_synt (s_quasiquote
, scm_makacro
, scm_m_quasiquote
);
2901 scm_make_synt (s_undefine
, scm_makacro
, scm_m_undefine
);
2902 scm_make_synt (s_delay
, scm_makacro
, scm_m_delay
);
2905 scm_top_level_lookup_closure_var
=
2906 scm_sysintern("*top-level-lookup-closure*", SCM_BOOL_F
);
2908 scm_i_and
= scm_make_synt ("and", scm_makmmacro
, scm_m_and
);
2909 scm_i_begin
= scm_make_synt ("begin", scm_makmmacro
, scm_m_begin
);
2910 scm_i_case
= scm_make_synt ("case", scm_makmmacro
, scm_m_case
);
2911 scm_i_cond
= scm_make_synt ("cond", scm_makmmacro
, scm_m_cond
);
2912 scm_i_define
= scm_make_synt ("define", scm_makmmacro
, scm_m_define
);
2913 scm_i_do
= scm_make_synt ("do", scm_makmmacro
, scm_m_do
);
2914 scm_i_if
= scm_make_synt ("if", scm_makmmacro
, scm_m_if
);
2915 scm_i_lambda
= scm_make_synt ("lambda", scm_makmmacro
, scm_m_lambda
);
2916 scm_i_let
= scm_make_synt ("let", scm_makmmacro
, scm_m_let
);
2917 scm_i_letrec
= scm_make_synt ("letrec", scm_makmmacro
, scm_m_letrec
);
2918 scm_i_letstar
= scm_make_synt ("let*", scm_makmmacro
, scm_m_letstar
);
2919 scm_i_or
= scm_make_synt ("or", scm_makmmacro
, scm_m_or
);
2920 scm_i_quote
= scm_make_synt ("quote", scm_makmmacro
, scm_m_quote
);
2921 scm_i_set
= scm_make_synt ("set!", scm_makmmacro
, scm_m_set
);
2922 scm_i_atapply
= scm_make_synt ("@apply", scm_makmmacro
, scm_m_apply
);
2923 scm_i_atcall_cc
= scm_make_synt ("@call-with-current-continuation",
2924 scm_makmmacro
, scm_m_cont
);
2926 scm_make_synt ("defined?", scm_makmmacro
, scm_definedp
);
2928 #ifdef DEBUG_EXTENSIONS
2929 scm_i_enter_frame
= SCM_CAR (scm_sysintern ("enter-frame", SCM_UNDEFINED
));
2930 scm_i_apply_frame
= SCM_CAR (scm_sysintern ("apply-frame", SCM_UNDEFINED
));
2931 scm_i_exit_frame
= SCM_CAR (scm_sysintern ("exit-frame", SCM_UNDEFINED
));
2932 scm_i_trace
= SCM_CAR (scm_sysintern ("trace", SCM_UNDEFINED
));