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", 1,
1244 "Show backtrace on error (use debugging evaluator)." },
1245 { SCM_OPTION_BOOLEAN
, "deval", 0, "Use the debugging evaluator." },
1246 { SCM_OPTION_INTEGER
, "stack", 20000, "Stack size limit (0 = no check)." }
1249 scm_option scm_evaluator_trap_table
[] = {
1250 { SCM_OPTION_BOOLEAN
, "enter-frame", 0, "Trap when eval enters new frame." },
1251 { SCM_OPTION_BOOLEAN
, "apply-frame", 0, "Trap when entering apply." },
1252 { SCM_OPTION_BOOLEAN
, "exit-frame", 0, "Trap when exiting eval or apply." }
1256 scm_deval_args (l
, env
, lloc
)
1260 while (SCM_NIMP (l
))
1262 *lloc
= scm_cons (EVALCAR (l
, env
), SCM_EOL
);
1263 lloc
= SCM_CDRLOC (*lloc
);
1272 /* SECTION: Some local definitions for the evaluator.
1277 #define CHECK_EQVISH(A,B) (((A) == (B)) || (SCM_NFALSEP (scm_eqv_p ((A), (B)))))
1279 #define CHECK_EQVISH(A,B) ((A) == (B))
1284 /* SECTION: This is the evaluator. Like any real monster, it has
1285 * three heads. This code is compiled twice.
1320 scm_debug_frame
*prev
;
1322 scm_debug_info vect
[scm_debug_eframe_size
];
1323 scm_debug_info
*info
;
1325 debug
.prev
= scm_last_debug_frame
;
1326 debug
.status
= scm_debug_eframe_size
;
1327 debug
.info
= &debug
.vect
[0];
1328 scm_last_debug_frame
= (scm_debug_frame
*) &debug
;
1330 #ifdef EVAL_STACK_CHECKING
1331 if (SCM_STACK_OVERFLOW_P ((SCM_STACKITEM
*) &proc
)
1332 && scm_stack_checking_enabled_p
)
1335 debug
.info
->e
.exp
= x
;
1336 debug
.info
->e
.env
= env
;
1338 scm_report_stack_overflow ();
1345 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
1348 #if 0 /* This will probably never have any practical use ... */
1351 if (SINGLE_STEP
|| (SCM_TRACE_P
&& SCM_TRACED_FRAME_P (debug
)))
1354 SCM_RESET_DEBUG_MODE
;
1355 SCM_CLEAR_TRACED_FRAME (debug
);
1356 scm_make_cont (&t
.arg1
);
1357 if (!setjmp (SCM_JMPBUF (t
.arg1
)))
1358 scm_ithrow (scm_i_exit_tail
, scm_cons (t
.arg1
, SCM_EOL
), 0);
1363 SCM_CLEAR_ARGSREADY (debug
);
1364 if (SCM_OVERFLOWP (debug
))
1366 else if (++debug
.info
== (scm_debug_info
*) &debug
.info
)
1368 SCM_SET_OVERFLOW (debug
);
1372 debug
.info
->e
.exp
= x
;
1373 debug
.info
->e
.env
= env
;
1375 if (SCM_ENTER_FRAME_P
|| (SCM_BREAKPOINTS_P
&& SRCBRKP (x
)))
1377 SCM tail
= SCM_TAILRECP (debug
) ? SCM_BOOL_T
: SCM_BOOL_F
;
1378 SCM_SET_TAILREC (debug
);
1379 SCM_ENTER_FRAME_P
= 0;
1380 SCM_RESET_DEBUG_MODE
;
1381 if (SCM_CHEAPTRAPS_P
)
1382 t
.arg1
= scm_make_debugobj ((scm_debug_frame
*) &debug
);
1385 scm_make_cont (&t
.arg1
);
1386 if (setjmp (SCM_JMPBUF (t
.arg1
)))
1388 x
= SCM_THROW_VALUE (t
.arg1
);
1394 /* This gives the possibility for the debugger to
1395 modify the source expression before evaluation. */
1399 scm_ithrow (scm_i_enter_frame
,
1400 scm_cons2 (t
.arg1
, tail
,
1401 scm_cons (scm_unmemocopy (x
, env
), SCM_EOL
)),
1407 switch (SCM_TYP7 (x
))
1409 case scm_tcs_symbols
:
1410 /* Only happens when called at top level.
1412 x
= scm_cons (x
, SCM_UNDEFINED
);
1415 case (127 & SCM_IM_AND
):
1418 while (SCM_NNULLP (t
.arg1
= SCM_CDR (t
.arg1
)))
1419 if (SCM_FALSEP (EVALCAR (x
, env
)))
1421 RETURN (SCM_BOOL_F
);
1425 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
1428 case (127 & SCM_IM_BEGIN
):
1430 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
1436 while (SCM_NNULLP (t
.arg1
= SCM_CDR (t
.arg1
)))
1438 SIDEVAL (SCM_CAR (x
), env
);
1442 carloop
: /* scm_eval car of last form in list */
1443 if (SCM_NCELLP (SCM_CAR (x
)))
1446 RETURN (SCM_IMP (x
) ? EVALIM (x
, env
) : SCM_GLOC_VAL (x
))
1449 if (SCM_SYMBOLP (SCM_CAR (x
)))
1452 RETURN (*scm_lookupcar (x
, env
))
1456 goto loop
; /* tail recurse */
1459 case (127 & SCM_IM_CASE
):
1461 t
.arg1
= EVALCAR (x
, env
);
1462 while (SCM_NIMP (x
= SCM_CDR (x
)))
1465 if (scm_i_else
== SCM_CAR (proc
))
1468 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
1471 proc
= SCM_CAR (proc
);
1472 while (SCM_NIMP (proc
))
1474 if (CHECK_EQVISH (SCM_CAR (proc
), t
.arg1
))
1476 x
= SCM_CDR (SCM_CAR (x
));
1477 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
1480 proc
= SCM_CDR (proc
);
1483 RETURN (SCM_UNSPECIFIED
)
1486 case (127 & SCM_IM_COND
):
1487 while (SCM_NIMP (x
= SCM_CDR (x
)))
1490 t
.arg1
= EVALCAR (proc
, env
);
1491 if (SCM_NFALSEP (t
.arg1
))
1498 if (scm_i_arrow
!= SCM_CAR (x
))
1500 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
1504 proc
= EVALCAR (proc
, env
);
1505 SCM_ASRTGO (SCM_NIMP (proc
), badfun
);
1506 PREP_APPLY (proc
, scm_cons (t
.arg1
, SCM_EOL
));
1511 RETURN (SCM_UNSPECIFIED
)
1514 case (127 & SCM_IM_DO
):
1516 proc
= SCM_CAR (SCM_CDR (x
)); /* inits */
1517 t
.arg1
= SCM_EOL
; /* values */
1518 while (SCM_NIMP (proc
))
1520 t
.arg1
= scm_cons (EVALCAR (proc
, env
), t
.arg1
);
1521 proc
= SCM_CDR (proc
);
1523 env
= EXTEND_ENV (SCM_CAR (x
), t
.arg1
, env
);
1524 x
= SCM_CDR (SCM_CDR (x
));
1525 while (proc
= SCM_CAR (x
), SCM_FALSEP (EVALCAR (proc
, env
)))
1527 for (proc
= SCM_CAR (SCM_CDR (x
)); SCM_NIMP (proc
); proc
= SCM_CDR (proc
))
1529 t
.arg1
= SCM_CAR (proc
); /* body */
1530 SIDEVAL (t
.arg1
, env
);
1532 for (t
.arg1
= SCM_EOL
, proc
= SCM_CDR (SCM_CDR (x
)); SCM_NIMP (proc
); proc
= SCM_CDR (proc
))
1533 t
.arg1
= scm_cons (EVALCAR (proc
, env
), t
.arg1
); /* steps */
1534 env
= EXTEND_ENV (SCM_CAR (SCM_CAR (env
)), t
.arg1
, SCM_CDR (env
));
1538 RETURN (SCM_UNSPECIFIED
);
1539 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
1543 case (127 & SCM_IM_IF
):
1545 if (SCM_NFALSEP (EVALCAR (x
, env
)))
1547 else if (SCM_IMP (x
= SCM_CDR (SCM_CDR (x
))))
1549 RETURN (SCM_UNSPECIFIED
);
1551 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
1555 case (127 & SCM_IM_LET
):
1557 proc
= SCM_CAR (SCM_CDR (x
));
1561 t
.arg1
= scm_cons (EVALCAR (proc
, env
), t
.arg1
);
1563 while (SCM_NIMP (proc
= SCM_CDR (proc
)));
1564 env
= EXTEND_ENV (SCM_CAR (x
), t
.arg1
, env
);
1569 case (127 & SCM_IM_LETREC
):
1571 env
= EXTEND_ENV (SCM_CAR (x
), scm_undefineds
, env
);
1577 t
.arg1
= scm_cons (EVALCAR (proc
, env
), t
.arg1
);
1579 while (SCM_NIMP (proc
= SCM_CDR (proc
)));
1580 SCM_SETCDR (SCM_CAR (env
), t
.arg1
);
1584 case (127 & SCM_IM_LETSTAR
):
1589 env
= EXTEND_ENV (SCM_EOL
, SCM_EOL
, env
);
1594 t
.arg1
= SCM_CAR (proc
);
1595 proc
= SCM_CDR (proc
);
1596 env
= EXTEND_ENV (t
.arg1
, EVALCAR (proc
, env
), env
);
1598 while (SCM_NIMP (proc
= SCM_CDR (proc
)));
1601 case (127 & SCM_IM_OR
):
1604 while (SCM_NNULLP (t
.arg1
= SCM_CDR (t
.arg1
)))
1606 x
= EVALCAR (x
, env
);
1607 if (SCM_NFALSEP (x
))
1613 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
1617 case (127 & SCM_IM_LAMBDA
):
1618 RETURN (scm_closure (SCM_CDR (x
), env
));
1621 case (127 & SCM_IM_QUOTE
):
1622 RETURN (SCM_CAR (SCM_CDR (x
)));
1625 case (127 & SCM_IM_SET
):
1628 switch (7 & (int) proc
)
1631 t
.lloc
= scm_lookupcar (x
, env
);
1634 t
.lloc
= SCM_GLOC_VAL_LOC (proc
);
1636 #ifdef MEMOIZE_LOCALS
1638 t
.lloc
= scm_ilookup (proc
, env
);
1643 *t
.lloc
= EVALCAR (x
, env
);
1647 RETURN (SCM_UNSPECIFIED
);
1651 case (127 & SCM_IM_DEFINE
): /* only for internal defines */
1655 x
= evalcar (x
, env
);
1656 #ifdef DEBUG_EXTENSIONS
1657 if (SCM_REC_PROCNAMES_P
&& SCM_NIMP (x
) && SCM_CLOSUREP (x
))
1658 scm_set_procedure_property_x (x
, scm_i_name
, proc
);
1660 env
= SCM_CAR (env
);
1662 SCM_SETCAR (env
, scm_cons (proc
, SCM_CAR (env
)));
1663 SCM_SETCDR (env
, scm_cons (x
, SCM_CDR (env
)));
1665 RETURN (SCM_UNSPECIFIED
);
1669 /* new syntactic forms go here. */
1670 case (127 & SCM_MAKISYM (0)):
1672 SCM_ASRTGO (SCM_ISYMP (proc
), badfun
);
1673 switch SCM_ISYMNUM (proc
)
1676 case (SCM_ISYMNUM (IM_VREF
)):
1679 var
= SCM_CAR (SCM_CDR (x
));
1680 RETURN (SCM_CDR(var
));
1682 case (SCM_ISYMNUM (IM_VSET
)):
1683 SCM_CDR (SCM_CAR ( SCM_CDR (x
))) = EVALCAR( SCM_CDR ( SCM_CDR (x
)), env
);
1684 SCM_CAR (SCM_CAR ( SCM_CDR (x
))) = scm_tc16_variable
;
1685 RETURN (SCM_UNSPECIFIED
)
1688 case (SCM_ISYMNUM (SCM_IM_APPLY
)):
1690 proc
= EVALCAR (proc
, env
);
1691 SCM_ASRTGO (SCM_NIMP (proc
), badfun
);
1692 if (SCM_CLOSUREP (proc
))
1694 PREP_APPLY (proc
, SCM_EOL
);
1695 t
.arg1
= SCM_CDR (SCM_CDR (x
));
1696 t
.arg1
= EVALCAR (t
.arg1
, env
);
1698 debug
.info
->a
.args
= t
.arg1
;
1701 if (scm_badargsp (SCM_CAR (SCM_CODE (proc
)), t
.arg1
))
1704 env
= EXTEND_ENV (SCM_CAR (SCM_CODE (proc
)), t
.arg1
, SCM_ENV (proc
));
1705 x
= SCM_CODE (proc
);
1711 case (SCM_ISYMNUM (SCM_IM_CONT
)):
1712 scm_make_cont (&t
.arg1
);
1713 if (setjmp (SCM_JMPBUF (t
.arg1
)))
1716 val
= SCM_THROW_VALUE (t
.arg1
);
1720 proc
= evalcar (proc
, env
);
1721 SCM_ASRTGO (SCM_NIMP (proc
), badfun
);
1722 PREP_APPLY (proc
, scm_cons (t
.arg1
, SCM_EOL
));
1733 /* scm_everr (x, env,...) */
1734 scm_misc_error (NULL
,
1735 "Wrong type to apply: %S",
1736 scm_listify (proc
, SCM_UNDEFINED
));
1737 case scm_tc7_vector
:
1740 case scm_tc7_byvect
:
1748 case scm_tc7_llvect
:
1750 case scm_tc7_string
:
1751 case scm_tc7_mb_string
:
1752 case scm_tc7_substring
:
1753 case scm_tc7_mb_substring
:
1755 case scm_tcs_closures
:
1759 #ifdef MEMOIZE_LOCALS
1760 case (127 & SCM_ILOC00
):
1761 proc
= *scm_ilookup (SCM_CAR (x
), env
);
1762 SCM_ASRTGO (SCM_NIMP (proc
), badfun
);
1769 #endif /* ifdef MEMOIZE_LOCALS */
1772 case scm_tcs_cons_gloc
:
1773 proc
= SCM_GLOC_VAL (SCM_CAR (x
));
1774 SCM_ASRTGO (SCM_NIMP (proc
), badfun
);
1783 case scm_tcs_cons_nimcar
:
1784 if (SCM_SYMBOLP (SCM_CAR (x
)))
1786 proc
= *scm_lookupcar (x
, env
);
1792 if (scm_tc16_macro
== SCM_TYP16 (proc
))
1797 t
.arg1
= SCM_APPLY (SCM_CDR (proc
), x
, scm_cons (env
, scm_listofnull
));
1798 switch ((int) (SCM_CAR (proc
) >> 16))
1801 if (scm_ilength (t
.arg1
) <= 0)
1802 t
.arg1
= scm_cons2 (SCM_IM_BEGIN
, t
.arg1
, SCM_EOL
);
1804 if (!SCM_CLOSUREP (SCM_CDR (proc
)))
1806 #if 0 /* Top-level defines doesn't very often occur in backtraces */
1807 if (scm_m_define
== SCM_SUBRF (SCM_CDR (proc
)) && SCM_TOP_LEVEL (env
))
1808 /* Prevent memoizing result of define macro */
1810 debug
.info
->e
.exp
= scm_cons (SCM_CAR (x
), SCM_CDR (x
));
1811 scm_set_source_properties_x (debug
.info
->e
.exp
,
1812 scm_source_properties (x
));
1816 SCM_SETCAR (x
, SCM_CAR (t
.arg1
));
1817 SCM_SETCDR (x
, SCM_CDR (t
.arg1
));
1821 /* Prevent memoizing of debug info expression. */
1822 debug
.info
->e
.exp
= scm_cons (SCM_CAR (x
), SCM_CDR (x
));
1823 scm_set_source_properties_x (debug
.info
->e
.exp
,
1824 scm_source_properties (x
));
1827 SCM_SETCAR (x
, SCM_CAR (t
.arg1
));
1828 SCM_SETCDR (x
, SCM_CDR (t
.arg1
));
1832 if (SCM_NIMP (x
= t
.arg1
))
1840 proc
= SCM_CEVAL (SCM_CAR (x
), env
);
1841 SCM_ASRTGO (SCM_NIMP (proc
), badfun
);
1846 if (SCM_CLOSUREP (proc
))
1848 arg2
= SCM_CAR (SCM_CODE (proc
));
1849 t
.arg1
= SCM_CDR (x
);
1850 while (SCM_NIMP (arg2
))
1852 if (SCM_NCONSP (arg2
))
1854 if (SCM_IMP (t
.arg1
))
1855 goto umwrongnumargs
;
1856 arg2
= SCM_CDR (arg2
);
1857 t
.arg1
= SCM_CDR (t
.arg1
);
1859 if (SCM_NNULLP (t
.arg1
))
1860 goto umwrongnumargs
;
1862 else if (scm_tc16_macro
== SCM_TYP16 (proc
))
1863 goto handle_a_macro
;
1869 PREP_APPLY (proc
, SCM_EOL
);
1870 if (SCM_NULLP (SCM_CDR (x
))) {
1872 switch (SCM_TYP7 (proc
))
1873 { /* no arguments given */
1874 case scm_tc7_subr_0
:
1875 RETURN (SCM_SUBRF (proc
) ());
1876 case scm_tc7_subr_1o
:
1877 RETURN (SCM_SUBRF (proc
) (SCM_UNDEFINED
));
1879 RETURN (SCM_SUBRF (proc
) (SCM_EOL
));
1880 case scm_tc7_rpsubr
:
1881 RETURN (SCM_BOOL_T
);
1883 RETURN (SCM_SUBRF (proc
) (SCM_UNDEFINED
, SCM_UNDEFINED
));
1887 proc
= SCM_CCLO_SUBR (proc
);
1889 debug
.info
->a
.proc
= proc
;
1890 debug
.info
->a
.args
= scm_cons (t
.arg1
, SCM_EOL
);
1894 case scm_tcs_closures
:
1895 x
= SCM_CODE (proc
);
1896 env
= EXTEND_ENV (SCM_CAR (x
), SCM_EOL
, SCM_ENV (proc
));
1898 case scm_tc7_contin
:
1899 case scm_tc7_subr_1
:
1900 case scm_tc7_subr_2
:
1901 case scm_tc7_subr_2o
:
1903 case scm_tc7_subr_3
:
1904 case scm_tc7_lsubr_2
:
1908 /* scm_everr (x, env,...) */
1909 scm_wrong_num_args (proc
);
1911 /* handle macros here */
1916 /* must handle macros by here */
1922 t
.arg1
= EVALCAR (x
, env
);
1924 debug
.info
->a
.args
= scm_cons (t
.arg1
, SCM_EOL
);
1931 switch (SCM_TYP7 (proc
))
1932 { /* have one argument in t.arg1 */
1933 case scm_tc7_subr_2o
:
1934 RETURN (SCM_SUBRF (proc
) (t
.arg1
, SCM_UNDEFINED
));
1935 case scm_tc7_subr_1
:
1936 case scm_tc7_subr_1o
:
1937 RETURN (SCM_SUBRF (proc
) (t
.arg1
));
1940 if (SCM_SUBRF (proc
))
1942 if (SCM_INUMP (t
.arg1
))
1944 RETURN (scm_makdbl (SCM_DSUBRF (proc
) ((double) SCM_INUM (t
.arg1
)),
1947 SCM_ASRTGO (SCM_NIMP (t
.arg1
), floerr
);
1948 if (SCM_REALP (t
.arg1
))
1950 RETURN (scm_makdbl (SCM_DSUBRF (proc
) (SCM_REALPART (t
.arg1
)), 0.0));
1953 if (SCM_BIGP (t
.arg1
))
1955 RETURN (scm_makdbl (SCM_DSUBRF (proc
) (scm_big2dbl (t
.arg1
)), 0.0));
1959 scm_wta (t
.arg1
, (char *) SCM_ARG1
, SCM_CHARS (SCM_SNAME (proc
)));
1962 proc
= (SCM
) SCM_SNAME (proc
);
1964 char *chrs
= SCM_CHARS (proc
) + SCM_LENGTH (proc
) - 1;
1965 while ('c' != *--chrs
)
1967 SCM_ASSERT (SCM_NIMP (t
.arg1
) && SCM_CONSP (t
.arg1
),
1968 t
.arg1
, SCM_ARG1
, SCM_CHARS (proc
));
1969 t
.arg1
= ('a' == *chrs
) ? SCM_CAR (t
.arg1
) : SCM_CDR (t
.arg1
);
1973 case scm_tc7_rpsubr
:
1974 RETURN (SCM_BOOL_T
);
1976 RETURN (SCM_SUBRF (proc
) (t
.arg1
, SCM_UNDEFINED
));
1979 RETURN (SCM_SUBRF (proc
) (debug
.info
->a
.args
))
1981 RETURN (SCM_SUBRF (proc
) (scm_cons (t
.arg1
, SCM_EOL
)));
1987 proc
= SCM_CCLO_SUBR (proc
);
1989 debug
.info
->a
.args
= scm_cons (t
.arg1
, debug
.info
->a
.args
);
1990 debug
.info
->a
.proc
= proc
;
1994 case scm_tcs_closures
:
1995 x
= SCM_CODE (proc
);
1997 env
= EXTEND_ENV (SCM_CAR (x
), debug
.info
->a
.args
, SCM_ENV (proc
));
1999 env
= EXTEND_ENV (SCM_CAR (x
), scm_cons (t
.arg1
, SCM_EOL
), SCM_ENV (proc
));
2002 case scm_tc7_contin
:
2003 scm_call_continuation (proc
, t
.arg1
);
2004 case scm_tc7_subr_2
:
2005 case scm_tc7_subr_0
:
2006 case scm_tc7_subr_3
:
2007 case scm_tc7_lsubr_2
:
2017 { /* have two or more arguments */
2018 arg2
= EVALCAR (x
, env
);
2020 debug
.info
->a
.args
= scm_cons2 (t
.arg1
, arg2
, SCM_EOL
);
2023 if (SCM_NULLP (x
)) {
2028 switch (SCM_TYP7 (proc
))
2029 { /* have two arguments */
2030 case scm_tc7_subr_2
:
2031 case scm_tc7_subr_2o
:
2032 RETURN (SCM_SUBRF (proc
) (t
.arg1
, arg2
));
2035 RETURN (SCM_SUBRF (proc
) (debug
.info
->a
.args
))
2037 RETURN (SCM_SUBRF (proc
) (scm_cons2 (t
.arg1
, arg2
, SCM_EOL
)));
2039 case scm_tc7_lsubr_2
:
2040 RETURN (SCM_SUBRF (proc
) (t
.arg1
, arg2
, SCM_EOL
));
2041 case scm_tc7_rpsubr
:
2043 RETURN (SCM_SUBRF (proc
) (t
.arg1
, arg2
));
2048 RETURN (SCM_APPLY (SCM_CCLO_SUBR (proc
), proc
,
2049 scm_cons (debug
.info
->a
.args
, SCM_EOL
)));
2051 RETURN (SCM_APPLY (SCM_CCLO_SUBR (proc
), proc
,
2052 scm_cons2 (t
.arg1
, arg2
,
2053 scm_cons (scm_eval_args (x
, env
), SCM_EOL
))));
2055 /* case scm_tc7_cclo:
2056 x = scm_cons(arg2, scm_eval_args(x, env));
2059 proc = SCM_CCLO_SUBR(proc);
2062 case scm_tc7_subr_0
:
2064 case scm_tc7_subr_1o
:
2065 case scm_tc7_subr_1
:
2066 case scm_tc7_subr_3
:
2067 case scm_tc7_contin
:
2071 case scm_tcs_closures
:
2073 env
= EXTEND_ENV (SCM_CAR (SCM_CODE (proc
)), debug
.info
->a
.args
, SCM_ENV (proc
));
2075 env
= EXTEND_ENV (SCM_CAR (SCM_CODE (proc
)), scm_cons2 (t
.arg1
, arg2
, SCM_EOL
), SCM_ENV (proc
));
2077 x
= SCM_CODE (proc
);
2082 debug
.info
->a
.args
= scm_cons2 (t
.arg1
, arg2
,
2083 scm_deval_args (x
, env
, SCM_CDRLOC (SCM_CDR (debug
.info
->a
.args
))));
2086 switch (SCM_TYP7 (proc
))
2087 { /* have 3 or more arguments */
2089 case scm_tc7_subr_3
:
2090 SCM_ASRTGO (SCM_NULLP (SCM_CDR (x
)), wrongnumargs
);
2091 RETURN (SCM_SUBRF (proc
) (t
.arg1
, arg2
, SCM_CAR (SCM_CDR (SCM_CDR (debug
.info
->a
.args
)))));
2093 /* t.arg1 = SCM_SUBRF(proc)(t.arg1, arg2);
2095 t.arg1 = SCM_SUBRF(proc)(t.arg1, EVALCAR(x, env));
2099 case scm_tc7_rpsubr
:
2100 RETURN (SCM_APPLY (proc
, t
.arg1
, scm_acons (arg2
, SCM_CDR (SCM_CDR (debug
.info
->a
.args
)), SCM_EOL
)))
2101 case scm_tc7_lsubr_2
:
2102 RETURN (SCM_SUBRF (proc
) (t
.arg1
, arg2
, SCM_CDR (SCM_CDR (debug
.info
->a
.args
))))
2104 RETURN (SCM_SUBRF (proc
) (debug
.info
->a
.args
))
2109 case scm_tcs_closures
:
2110 SCM_SET_ARGSREADY (debug
);
2111 env
= EXTEND_ENV (SCM_CAR (SCM_CODE (proc
)),
2114 x
= SCM_CODE (proc
);
2117 case scm_tc7_subr_3
:
2118 SCM_ASRTGO (SCM_NULLP (SCM_CDR (x
)), wrongnumargs
);
2119 RETURN (SCM_SUBRF (proc
) (t
.arg1
, arg2
, EVALCAR (x
, env
)));
2121 /* t.arg1 = SCM_SUBRF(proc)(t.arg1, arg2);
2123 t.arg1 = SCM_SUBRF(proc)(t.arg1, EVALCAR(x, env));
2127 case scm_tc7_rpsubr
:
2128 RETURN (SCM_APPLY (proc
, t
.arg1
, scm_acons (arg2
, scm_eval_args (x
, env
), SCM_EOL
)));
2129 case scm_tc7_lsubr_2
:
2130 RETURN (SCM_SUBRF (proc
) (t
.arg1
, arg2
, scm_eval_args (x
, env
)));
2132 RETURN (SCM_SUBRF (proc
) (scm_cons2 (t
.arg1
, arg2
, scm_eval_args (x
, env
))));
2137 case scm_tcs_closures
:
2139 SCM_SET_ARGSREADY (debug
);
2141 env
= EXTEND_ENV (SCM_CAR (SCM_CODE (proc
)),
2142 scm_cons2 (t
.arg1
, arg2
, scm_eval_args (x
, env
)),
2144 x
= SCM_CODE (proc
);
2147 case scm_tc7_subr_2
:
2148 case scm_tc7_subr_1o
:
2149 case scm_tc7_subr_2o
:
2150 case scm_tc7_subr_0
:
2152 case scm_tc7_subr_1
:
2153 case scm_tc7_contin
:
2162 if (SCM_EXIT_FRAME_P
|| (SCM_TRACE_P
&& SCM_TRACED_FRAME_P (debug
)))
2164 SCM_EXIT_FRAME_P
= 0;
2165 SCM_RESET_DEBUG_MODE
;
2166 SCM_CLEAR_TRACED_FRAME (debug
);
2167 if (SCM_CHEAPTRAPS_P
)
2168 t
.arg1
= scm_make_debugobj ((scm_debug_frame
*) &debug
);
2171 scm_make_cont (&t
.arg1
);
2172 if (setjmp (SCM_JMPBUF (t
.arg1
)))
2174 proc
= SCM_THROW_VALUE (t
.arg1
);
2178 scm_ithrow (scm_i_exit_frame
, scm_cons2 (t
.arg1
, proc
, SCM_EOL
), 0);
2181 scm_last_debug_frame
= debug
.prev
;
2187 /* SECTION: This code is compiled once.
2192 SCM_PROC(s_procedure_documentation
, "procedure-documentation", 1, 0, 0, scm_procedure_documentation
);
2195 scm_procedure_documentation (proc
)
2199 SCM_ASSERT (SCM_BOOL_T
== scm_procedure_p (proc
) && SCM_NIMP (proc
) && SCM_TYP7 (proc
) != scm_tc7_contin
,
2200 proc
, SCM_ARG1
, s_procedure_documentation
);
2201 switch (SCM_TYP7 (proc
))
2203 case scm_tcs_closures
:
2204 code
= SCM_CDR (SCM_CODE (proc
));
2205 if (SCM_IMP (SCM_CDR (code
)))
2207 code
= SCM_CAR (code
);
2210 if (SCM_STRINGP (code
))
2223 /* This code processes the 'arg ...' parameters to apply.
2225 (apply PROC ARG1 ... ARGS)
2227 The ARG1 ... arguments are consed on to the front of ARGS (which
2228 must be a list), and then PROC is applied to the elements of the
2229 result. apply:nconc2last takes care of building the list of
2230 arguments, given (ARG1 ... ARGS).
2232 apply:nconc2last destroys its argument. On that topic, this code
2233 came into my care with the following beautifully cryptic comment on
2234 that topic: "This will only screw you if you do (scm_apply
2235 scm_apply '( ... ))" If you know what they're referring to, send
2236 me a patch to this comment. */
2238 SCM_PROC(s_nconc2last
, "apply:nconc2last", 1, 0, 0, scm_nconc2last
);
2241 scm_nconc2last (lst
)
2245 SCM_ASSERT (scm_ilength (lst
) > 0, lst
, SCM_ARG1
, s_nconc2last
);
2247 while (SCM_NNULLP (SCM_CDR (*lloc
)))
2248 lloc
= SCM_CDRLOC (*lloc
);
2249 SCM_ASSERT (scm_ilength (SCM_CAR (*lloc
)) >= 0, lst
, SCM_ARG1
, s_nconc2last
);
2250 *lloc
= SCM_CAR (*lloc
);
2257 /* SECTION: When DEVAL is defined this code yields scm_dapply.
2258 * It is compiled twice.
2264 scm_apply (proc
, arg1
, args
)
2274 scm_dapply (proc
, arg1
, args
)
2283 SCM_APPLY (proc
, arg1
, args
)
2288 #ifdef DEBUG_EXTENSIONS
2290 scm_debug_frame debug
;
2291 debug
.prev
= scm_last_debug_frame
;
2292 debug
.status
= SCM_APPLYFRAME
;
2293 debug
.vect
[0].a
.proc
= proc
;
2294 debug
.vect
[0].a
.args
= SCM_EOL
;
2295 scm_last_debug_frame
= &debug
;
2298 return scm_dapply (proc
, arg1
, args
);
2302 SCM_ASRTGO (SCM_NIMP (proc
), badproc
);
2303 if (SCM_NULLP (args
))
2305 if (SCM_NULLP (arg1
))
2306 arg1
= SCM_UNDEFINED
;
2309 args
= SCM_CDR (arg1
);
2310 arg1
= SCM_CAR (arg1
);
2315 /* SCM_ASRTGO(SCM_NIMP(args) && SCM_CONSP(args), wrongnumargs); */
2316 args
= scm_nconc2last (args
);
2319 debug
.vect
[0].a
.args
= scm_cons (arg1
, args
);
2320 if (SCM_ENTER_FRAME_P
)
2323 SCM_ENTER_FRAME_P
= 0;
2324 SCM_RESET_DEBUG_MODE
;
2325 if (SCM_CHEAPTRAPS_P
)
2326 tmp
= scm_make_debugobj ((scm_debug_frame
*) &debug
);
2329 scm_make_cont (&tmp
);
2330 if (setjmp (SCM_JMPBUF (tmp
)))
2333 scm_ithrow (scm_i_enter_frame
, scm_cons (tmp
, SCM_EOL
), 0);
2341 switch (SCM_TYP7 (proc
))
2343 case scm_tc7_subr_2o
:
2344 args
= SCM_NULLP (args
) ? SCM_UNDEFINED
: SCM_CAR (args
);
2345 RETURN (SCM_SUBRF (proc
) (arg1
, args
))
2346 case scm_tc7_subr_2
:
2347 SCM_ASRTGO (SCM_NULLP (SCM_CDR (args
)), wrongnumargs
);
2348 args
= SCM_CAR (args
);
2349 RETURN (SCM_SUBRF (proc
) (arg1
, args
))
2350 case scm_tc7_subr_0
:
2351 SCM_ASRTGO (SCM_UNBNDP (arg1
), wrongnumargs
);
2352 RETURN (SCM_SUBRF (proc
) ())
2353 case scm_tc7_subr_1
:
2354 case scm_tc7_subr_1o
:
2355 SCM_ASRTGO (SCM_NULLP (args
), wrongnumargs
);
2356 RETURN (SCM_SUBRF (proc
) (arg1
))
2358 SCM_ASRTGO (SCM_NULLP (args
), wrongnumargs
);
2360 if (SCM_SUBRF (proc
))
2362 if (SCM_INUMP (arg1
))
2364 RETURN (scm_makdbl (SCM_DSUBRF (proc
) ((double) SCM_INUM (arg1
)), 0.0));
2366 SCM_ASRTGO (SCM_NIMP (arg1
), floerr
);
2367 if (SCM_REALP (arg1
))
2369 RETURN (scm_makdbl (SCM_DSUBRF (proc
) (SCM_REALPART (arg1
)), 0.0));
2374 RETURN (scm_makdbl (SCM_DSUBRF (proc
) (scm_big2dbl (arg1
)), 0.0))
2377 scm_wta (arg1
, (char *) SCM_ARG1
, SCM_CHARS (SCM_SNAME (proc
)));
2380 proc
= (SCM
) SCM_SNAME (proc
);
2382 char *chrs
= SCM_CHARS (proc
) + SCM_LENGTH (proc
) - 1;
2383 while ('c' != *--chrs
)
2385 SCM_ASSERT (SCM_NIMP (arg1
) && SCM_CONSP (arg1
),
2386 arg1
, SCM_ARG1
, SCM_CHARS (proc
));
2387 arg1
= ('a' == *chrs
) ? SCM_CAR (arg1
) : SCM_CDR (arg1
);
2391 case scm_tc7_subr_3
:
2392 RETURN (SCM_SUBRF (proc
) (arg1
, SCM_CAR (args
), SCM_CAR (SCM_CDR (args
))))
2395 RETURN (SCM_SUBRF (proc
) (SCM_UNBNDP (arg1
) ? SCM_EOL
: debug
.vect
[0].a
.args
))
2397 RETURN (SCM_SUBRF (proc
) (SCM_UNBNDP (arg1
) ? SCM_EOL
: scm_cons (arg1
, args
)))
2399 case scm_tc7_lsubr_2
:
2400 SCM_ASRTGO (SCM_NIMP (args
) && SCM_CONSP (args
), wrongnumargs
);
2401 RETURN (SCM_SUBRF (proc
) (arg1
, SCM_CAR (args
), SCM_CDR (args
)))
2403 if (SCM_NULLP (args
))
2404 RETURN (SCM_SUBRF (proc
) (arg1
, SCM_UNDEFINED
))
2405 while (SCM_NIMP (args
))
2407 SCM_ASSERT (SCM_CONSP (args
), args
, SCM_ARG2
, "apply");
2408 arg1
= SCM_SUBRF (proc
) (arg1
, SCM_CAR (args
));
2409 args
= SCM_CDR (args
);
2412 case scm_tc7_rpsubr
:
2413 if (SCM_NULLP (args
))
2414 RETURN (SCM_BOOL_T
);
2415 while (SCM_NIMP (args
))
2417 SCM_ASSERT (SCM_CONSP (args
), args
, SCM_ARG2
, "apply");
2418 if (SCM_FALSEP (SCM_SUBRF (proc
) (arg1
, SCM_CAR (args
))))
2419 RETURN (SCM_BOOL_F
);
2420 arg1
= SCM_CAR (args
);
2421 args
= SCM_CDR (args
);
2423 RETURN (SCM_BOOL_T
);
2424 case scm_tcs_closures
:
2426 arg1
= (SCM_UNBNDP (arg1
) ? SCM_EOL
: debug
.vect
[0].a
.args
);
2428 arg1
= (SCM_UNBNDP (arg1
) ? SCM_EOL
: scm_cons (arg1
, args
));
2431 if (scm_badargsp (SCM_CAR (SCM_CODE (proc
)), arg1
))
2434 args
= EXTEND_ENV (SCM_CAR (SCM_CODE (proc
)), arg1
, SCM_ENV (proc
));
2435 proc
= SCM_CODE (proc
);
2436 while (SCM_NNULLP (proc
= SCM_CDR (proc
)))
2437 arg1
= EVALCAR (proc
, args
);
2439 case scm_tc7_contin
:
2440 SCM_ASRTGO (SCM_NULLP (args
), wrongnumargs
);
2441 scm_call_continuation (proc
, arg1
);
2445 args
= (SCM_UNBNDP(arg1
) ? SCM_EOL
: debug
.vect
[0].a
.args
);
2447 proc
= SCM_CCLO_SUBR (proc
);
2448 debug
.vect
[0].a
.proc
= proc
;
2449 debug
.vect
[0].a
.args
= scm_cons (arg1
, args
);
2451 args
= (SCM_UNBNDP(arg1
) ? SCM_EOL
: scm_cons (arg1
, args
));
2453 proc
= SCM_CCLO_SUBR (proc
);
2458 scm_wrong_num_args (proc
);
2461 scm_wta (proc
, (char *) SCM_ARG1
, "apply");
2467 if (SCM_EXIT_FRAME_P
|| (SCM_TRACE_P
&& SCM_TRACED_FRAME_P (debug
)))
2469 SCM_EXIT_FRAME_P
= 0;
2470 SCM_RESET_DEBUG_MODE
;
2471 SCM_CLEAR_TRACED_FRAME (debug
);
2472 if (SCM_CHEAPTRAPS_P
)
2473 arg1
= scm_make_debugobj ((scm_debug_frame
*) &debug
);
2476 scm_make_cont (&arg1
);
2477 if (setjmp (SCM_JMPBUF (arg1
)))
2479 proc
= SCM_THROW_VALUE (arg1
);
2483 scm_ithrow (scm_i_exit_frame
, scm_cons2 (arg1
, proc
, SCM_EOL
), 0);
2486 scm_last_debug_frame
= debug
.prev
;
2492 /* SECTION: The rest of this file is only read once.
2497 SCM_PROC(s_map
, "map", 2, 0, 1, scm_map
);
2500 scm_map (proc
, arg1
, args
)
2508 SCM
*ve
= &args
; /* Keep args from being optimized away. */
2510 if (SCM_NULLP (arg1
))
2512 SCM_ASSERT (SCM_NIMP (arg1
), arg1
, SCM_ARG2
, s_map
);
2513 if (SCM_NULLP (args
))
2515 while (SCM_NIMP (arg1
))
2517 SCM_ASSERT (SCM_CONSP (arg1
), arg1
, SCM_ARG2
, s_map
);
2518 *pres
= scm_cons (scm_apply (proc
, SCM_CAR (arg1
), scm_listofnull
), SCM_EOL
);
2519 pres
= SCM_CDRLOC (*pres
);
2520 arg1
= SCM_CDR (arg1
);
2524 args
= scm_vector (scm_cons (arg1
, args
));
2525 ve
= SCM_VELTS (args
);
2527 for (i
= SCM_LENGTH (args
) - 1; i
>= 0; i
--)
2528 SCM_ASSERT (SCM_NIMP (ve
[i
]) && SCM_CONSP (ve
[i
]), args
, SCM_ARG2
, s_map
);
2533 for (i
= SCM_LENGTH (args
) - 1; i
>= 0; i
--)
2537 arg1
= scm_cons (SCM_CAR (ve
[i
]), arg1
);
2538 ve
[i
] = SCM_CDR (ve
[i
]);
2540 *pres
= scm_cons (scm_apply (proc
, arg1
, SCM_EOL
), SCM_EOL
);
2541 pres
= SCM_CDRLOC (*pres
);
2546 SCM_PROC(s_for_each
, "for-each", 2, 0, 1, scm_for_each
);
2549 scm_for_each (proc
, arg1
, args
)
2554 SCM
*ve
= &args
; /* Keep args from being optimized away. */
2557 return SCM_UNSPECIFIED
;
2558 SCM_ASSERT (SCM_NIMP (arg1
), arg1
, SCM_ARG2
, s_for_each
);
2561 while SCM_NIMP (arg1
)
2563 SCM_ASSERT (SCM_CONSP (arg1
), arg1
, SCM_ARG2
, s_for_each
);
2564 scm_apply (proc
, SCM_CAR (arg1
), scm_listofnull
);
2565 arg1
= SCM_CDR (arg1
);
2567 return SCM_UNSPECIFIED
;
2569 args
= scm_vector (scm_cons (arg1
, args
));
2570 ve
= SCM_VELTS (args
);
2572 for (i
= SCM_LENGTH (args
) - 1; i
>= 0; i
--)
2573 SCM_ASSERT (SCM_NIMP (ve
[i
]) && SCM_CONSP (ve
[i
]), args
, SCM_ARG2
, s_for_each
);
2578 for (i
= SCM_LENGTH (args
) - 1; i
>= 0; i
--)
2581 (ve
[i
]) return SCM_UNSPECIFIED
;
2582 arg1
= scm_cons (SCM_CAR (ve
[i
]), arg1
);
2583 ve
[i
] = SCM_CDR (ve
[i
]);
2585 scm_apply (proc
, arg1
, SCM_EOL
);
2592 scm_closure (code
, env
)
2598 SCM_SETCODE (z
, code
);
2599 SCM_SETENV (z
, env
);
2604 long scm_tc16_promise
;
2612 SCM_SETCDR (z
, code
);
2613 SCM_SETCAR (z
, scm_tc16_promise
);
2619 static int prinprom
SCM_P ((SCM exp
, SCM port
, scm_print_state
*pstate
));
2622 prinprom (exp
, port
, pstate
)
2625 scm_print_state
*pstate
;
2627 int writingp
= SCM_WRITINGP (pstate
);
2628 scm_gen_puts (scm_regular_string
, "#<promise ", port
);
2629 SCM_SET_WRITINGP (pstate
, 1);
2630 scm_iprin1 (SCM_CDR (exp
), port
, pstate
);
2631 SCM_SET_WRITINGP (pstate
, writingp
);
2632 scm_gen_putc ('>', port
);
2637 SCM_PROC(s_makacro
, "procedure->syntax", 1, 0, 0, scm_makacro
);
2645 SCM_SETCDR (z
, code
);
2646 SCM_SETCAR (z
, scm_tc16_macro
);
2651 SCM_PROC(s_makmacro
, "procedure->macro", 1, 0, 0, scm_makmacro
);
2659 SCM_SETCDR (z
, code
);
2660 SCM_SETCAR (z
, scm_tc16_macro
| (1L << 16));
2665 SCM_PROC(s_makmmacro
, "procedure->memoizing-macro", 1, 0, 0, scm_makmmacro
);
2668 scm_makmmacro (code
)
2673 SCM_SETCDR (z
, code
);
2674 SCM_SETCAR (z
, scm_tc16_macro
| (2L << 16));
2680 static int prinmacro
SCM_P ((SCM exp
, SCM port
, scm_print_state
*pstate
));
2683 prinmacro (exp
, port
, pstate
)
2686 scm_print_state
*pstate
;
2688 int writingp
= SCM_WRITINGP (pstate
);
2689 if (SCM_CAR (exp
) & (3L << 16))
2690 scm_gen_puts (scm_regular_string
, "#<macro", port
);
2692 scm_gen_puts (scm_regular_string
, "#<syntax", port
);
2693 if (SCM_CAR (exp
) & (2L << 16))
2694 scm_gen_putc ('!', port
);
2695 scm_gen_putc (' ', port
);
2696 SCM_SET_WRITINGP (pstate
, 1);
2697 scm_iprin1 (SCM_CDR (exp
), port
, pstate
);
2698 SCM_SET_WRITINGP (pstate
, writingp
);
2699 scm_gen_putc ('>', port
);
2703 SCM_PROC(s_force
, "force", 1, 0, 0, scm_force
);
2709 SCM_ASSERT ((SCM_TYP16 (x
) == scm_tc16_promise
), x
, SCM_ARG1
, s_force
);
2710 if (!((1L << 16) & SCM_CAR (x
)))
2712 SCM ans
= scm_apply (SCM_CDR (x
), SCM_EOL
, SCM_EOL
);
2713 if (!((1L << 16) & SCM_CAR (x
)))
2716 SCM_SETCDR (x
, ans
);
2717 SCM_SETOR_CAR (x
, (1L << 16));
2724 SCM_PROC (s_promise_p
, "promise?", 1, 0, 0, scm_promise_p
);
2730 return ((SCM_NIMP (x
) && (SCM_TYP16 (x
) == scm_tc16_promise
))
2735 SCM_PROC(s_copy_tree
, "copy-tree", 1, 0, 0, scm_copy_tree
);
2744 if (SCM_VECTORP (obj
))
2746 scm_sizet i
= SCM_LENGTH (obj
);
2747 ans
= scm_make_vector (SCM_MAKINUM (i
), SCM_UNSPECIFIED
, SCM_UNDEFINED
);
2749 SCM_VELTS (ans
)[i
] = scm_copy_tree (SCM_VELTS (obj
)[i
]);
2754 /* return scm_cons(scm_copy_tree(SCM_CAR(obj)), scm_copy_tree(SCM_CDR(obj))); */
2755 ans
= tl
= scm_cons (scm_copy_tree (SCM_CAR (obj
)), SCM_UNSPECIFIED
);
2756 while (SCM_NIMP (obj
= SCM_CDR (obj
)) && SCM_CONSP (obj
))
2758 SCM_SETCDR (tl
, scm_cons (scm_copy_tree (SCM_CAR (obj
)),
2762 SCM_SETCDR (tl
, obj
);
2768 scm_eval_3 (obj
, copyp
, env
)
2773 if (SCM_NIMP (SCM_CDR (scm_system_transformer
)))
2774 obj
= scm_apply (SCM_CDR (scm_system_transformer
), obj
, scm_listofnull
);
2776 obj
= scm_copy_tree (obj
);
2777 return XEVAL (obj
, env
);
2782 scm_top_level_env (thunk
)
2788 return scm_cons(thunk
, (SCM
)SCM_EOL
);
2791 SCM_PROC(s_eval2
, "eval2", 2, 0, 0, scm_eval2
);
2794 scm_eval2 (obj
, env_thunk
)
2798 return scm_eval_3 (obj
, 1, scm_top_level_env(env_thunk
));
2801 SCM_PROC(s_eval
, "eval", 1, 0, 0, scm_eval
);
2808 scm_eval_3(obj
, 1, scm_top_level_env(SCM_CDR(scm_top_level_lookup_thunk_var
)));
2811 SCM_PROC(s_eval_x
, "eval!", 1, 0, 0, scm_eval_x
);
2820 scm_top_level_env (SCM_CDR (scm_top_level_lookup_thunk_var
)));
2823 SCM_PROC (s_macro_eval_x
, "macro-eval!", 2, 0, 0, scm_macro_eval_x
);
2826 scm_macro_eval_x (exp
, env
)
2830 return scm_eval_3 (exp
, 0, env
);
2835 scm_definedp (x
, env
)
2839 SCM proc
= SCM_CAR (x
= SCM_CDR (x
));
2840 if (SCM_ISYMP (proc
))
2842 else if(SCM_IMP(proc
) || !SCM_SYMBOLP(proc
))
2846 SCM vcell
= scm_sym2vcell(proc
, env_top_level(env
), SCM_BOOL_F
);
2847 return (vcell
== SCM_BOOL_F
|| SCM_UNBNDP(SCM_CDR(vcell
))) ? SCM_BOOL_F
: SCM_BOOL_T
;
2851 static scm_smobfuns promsmob
=
2852 {scm_markcdr
, scm_free0
, prinprom
};
2854 static scm_smobfuns macrosmob
=
2855 {scm_markcdr
, scm_free0
, prinmacro
};
2859 scm_make_synt (name
, macroizer
, fcn
)
2861 SCM (*macroizer
) ();
2864 SCM symcell
= scm_sysintern (name
, SCM_UNDEFINED
);
2865 long tmp
= ((((SCM_CELLPTR
) (SCM_CAR (symcell
))) - scm_heap_org
) << 8);
2867 if ((tmp
>> 8) != ((SCM_CELLPTR
) (SCM_CAR (symcell
)) - scm_heap_org
))
2870 SCM_SUBRF (z
) = fcn
;
2871 SCM_SETCAR (z
, tmp
+ scm_tc7_subr_2
);
2872 SCM_SETCDR (symcell
, macroizer (z
));
2873 return SCM_CAR (symcell
);
2877 /* At this point, scm_deval and scm_dapply are generated.
2880 #ifdef DEBUG_EXTENSIONS
2890 scm_tc16_promise
= scm_newsmob (&promsmob
);
2891 scm_tc16_macro
= scm_newsmob (¯osmob
);
2892 scm_i_apply
= scm_make_subr ("apply", scm_tc7_lsubr_2
, scm_apply
);
2893 scm_system_transformer
= scm_sysintern ("scm:eval-transformer", SCM_UNDEFINED
);
2894 scm_i_dot
= SCM_CAR (scm_sysintern (".", SCM_UNDEFINED
));
2895 scm_i_arrow
= SCM_CAR (scm_sysintern ("=>", SCM_UNDEFINED
));
2896 scm_i_else
= SCM_CAR (scm_sysintern ("else", SCM_UNDEFINED
));
2897 scm_i_unquote
= SCM_CAR (scm_sysintern ("unquote", SCM_UNDEFINED
));
2898 scm_i_uq_splicing
= SCM_CAR (scm_sysintern ("unquote-splicing", SCM_UNDEFINED
));
2901 scm_i_quasiquote
= scm_make_synt (s_quasiquote
, scm_makacro
, scm_m_quasiquote
);
2902 scm_make_synt (s_undefine
, scm_makacro
, scm_m_undefine
);
2903 scm_make_synt (s_delay
, scm_makacro
, scm_m_delay
);
2906 scm_top_level_lookup_thunk_var
=
2907 scm_sysintern("*top-level-lookup-thunk*", SCM_BOOL_F
);
2909 scm_i_and
= scm_make_synt ("and", scm_makmmacro
, scm_m_and
);
2910 scm_i_begin
= scm_make_synt ("begin", scm_makmmacro
, scm_m_begin
);
2911 scm_i_case
= scm_make_synt ("case", scm_makmmacro
, scm_m_case
);
2912 scm_i_cond
= scm_make_synt ("cond", scm_makmmacro
, scm_m_cond
);
2913 scm_i_define
= scm_make_synt ("define", scm_makmmacro
, scm_m_define
);
2914 scm_i_do
= scm_make_synt ("do", scm_makmmacro
, scm_m_do
);
2915 scm_i_if
= scm_make_synt ("if", scm_makmmacro
, scm_m_if
);
2916 scm_i_lambda
= scm_make_synt ("lambda", scm_makmmacro
, scm_m_lambda
);
2917 scm_i_let
= scm_make_synt ("let", scm_makmmacro
, scm_m_let
);
2918 scm_i_letrec
= scm_make_synt ("letrec", scm_makmmacro
, scm_m_letrec
);
2919 scm_i_letstar
= scm_make_synt ("let*", scm_makmmacro
, scm_m_letstar
);
2920 scm_i_or
= scm_make_synt ("or", scm_makmmacro
, scm_m_or
);
2921 scm_i_quote
= scm_make_synt ("quote", scm_makmmacro
, scm_m_quote
);
2922 scm_i_set
= scm_make_synt ("set!", scm_makmmacro
, scm_m_set
);
2923 scm_i_atapply
= scm_make_synt ("@apply", scm_makmmacro
, scm_m_apply
);
2924 scm_i_atcall_cc
= scm_make_synt ("@call-with-current-continuation",
2925 scm_makmmacro
, scm_m_cont
);
2927 scm_make_synt ("defined?", scm_makmmacro
, scm_definedp
);
2929 #ifdef DEBUG_EXTENSIONS
2930 scm_i_enter_frame
= SCM_CAR (scm_sysintern ("enter-frame", SCM_UNDEFINED
));
2931 scm_i_apply_frame
= SCM_CAR (scm_sysintern ("apply-frame", SCM_UNDEFINED
));
2932 scm_i_exit_frame
= SCM_CAR (scm_sysintern ("exit-frame", SCM_UNDEFINED
));
2933 scm_i_trace
= SCM_CAR (scm_sysintern ("trace", SCM_UNDEFINED
));