1 /* Copyright (C) 1995,1996,1997,1998,1999,2000,2001,2002,2003,2004,
2 * 2005,2006,2007,2008,2009,2010,2011,2012,2013
3 * Free Software Foundation, Inc.
5 * This library is free software; you can redistribute it and/or
6 * modify it under the terms of the GNU Lesser General Public License
7 * as published by the Free Software Foundation; either version 3 of
8 * the License, or (at your option) any later version.
10 * This library is distributed in the hope that it will be useful, but
11 * WITHOUT ANY WARRANTY; without even the implied warranty of
12 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
13 * Lesser General Public License for more details.
15 * You should have received a copy of the GNU Lesser General Public
16 * License along with this library; if not, write to the Free Software
17 * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
30 #include "libguile/__scm.h"
32 #include "libguile/_scm.h"
33 #include "libguile/alist.h"
34 #include "libguile/async.h"
35 #include "libguile/continuations.h"
36 #include "libguile/control.h"
37 #include "libguile/debug.h"
38 #include "libguile/deprecation.h"
39 #include "libguile/dynwind.h"
40 #include "libguile/eq.h"
41 #include "libguile/expand.h"
42 #include "libguile/feature.h"
43 #include "libguile/fluids.h"
44 #include "libguile/goops.h"
45 #include "libguile/hash.h"
46 #include "libguile/hashtab.h"
47 #include "libguile/list.h"
48 #include "libguile/macros.h"
49 #include "libguile/memoize.h"
50 #include "libguile/modules.h"
51 #include "libguile/ports.h"
52 #include "libguile/print.h"
53 #include "libguile/procprop.h"
54 #include "libguile/programs.h"
55 #include "libguile/root.h"
56 #include "libguile/smob.h"
57 #include "libguile/srcprop.h"
58 #include "libguile/stackchk.h"
59 #include "libguile/strings.h"
60 #include "libguile/threads.h"
61 #include "libguile/throw.h"
62 #include "libguile/validate.h"
63 #include "libguile/values.h"
64 #include "libguile/vectors.h"
65 #include "libguile/vm.h"
67 #include "libguile/eval.h"
68 #include "libguile/private-options.h"
73 /* We have three levels of EVAL here:
77 evaluates EXP in environment ENV. ENV is a lexical environment
78 structure as used by the actual tree code evaluator. When ENV is
79 a top-level environment, then changes to the current module are
80 tracked by updating ENV so that it continues to be in sync with
83 - scm_primitive_eval (exp)
85 evaluates EXP in the top-level environment as determined by the
86 current module. This is done by constructing a suitable
87 environment and calling eval. Thus, changes to the
88 top-level module are tracked normally.
92 evaluates EXP while MOD is the current module. This is done
93 by setting the current module to MOD_OR_STATE, invoking
94 scm_primitive_eval on EXP, and then restoring the current module
95 to the value it had previously. That is, while EXP is evaluated,
96 changes to the current module (or dynamic state) are tracked,
97 but these changes do not persist when scm_eval returns.
102 /* Boot closures. We only see these when compiling eval.scm, because once
103 eval.scm is in the house, closures are standard VM closures.
106 static scm_t_bits scm_tc16_boot_closure
;
107 #define RETURN_BOOT_CLOSURE(code, env) \
108 SCM_RETURN_NEWSMOB2 (scm_tc16_boot_closure, SCM_UNPACK (code), SCM_UNPACK (env))
109 #define BOOT_CLOSURE_P(obj) SCM_TYP16_PREDICATE (scm_tc16_boot_closure, (obj))
110 #define BOOT_CLOSURE_CODE(x) SCM_SMOB_OBJECT (x)
111 #define BOOT_CLOSURE_ENV(x) SCM_SMOB_OBJECT_2 (x)
112 #define BOOT_CLOSURE_BODY(x) CAR (BOOT_CLOSURE_CODE (x))
113 #define BOOT_CLOSURE_NUM_REQUIRED_ARGS(x) (SCM_I_INUM (CADDR (BOOT_CLOSURE_CODE (x))))
114 #define BOOT_CLOSURE_IS_FIXED(x) (scm_is_null (CDDDR (BOOT_CLOSURE_CODE (x))))
115 /* NB: One may only call the following accessors if the closure is not FIXED. */
116 #define BOOT_CLOSURE_HAS_REST_ARGS(x) scm_is_true (CADDR (SCM_CDR (BOOT_CLOSURE_CODE (x))))
117 #define BOOT_CLOSURE_IS_REST(x) scm_is_null (SCM_CDR (CDDDR (BOOT_CLOSURE_CODE (x))))
118 /* NB: One may only call the following accessors if the closure is not REST. */
119 #define BOOT_CLOSURE_IS_FULL(x) (1)
120 #define BOOT_CLOSURE_PARSE_FULL(fu_,body,nargs,rest,nopt,kw,inits,alt) \
122 body = CAR (fu); fu = CDDR (fu); \
124 rest = kw = alt = SCM_BOOL_F; \
128 nreq = SCM_I_INUM (CAR (fu)); fu = CDR (fu); \
129 if (scm_is_pair (fu)) \
131 rest = CAR (fu); fu = CDR (fu); \
132 if (scm_is_pair (fu)) \
134 nopt = SCM_I_INUM (CAR (fu)); fu = CDR (fu); \
135 kw = CAR (fu); fu = CDR (fu); \
136 inits = CAR (fu); fu = CDR (fu); \
141 static void prepare_boot_closure_env_for_apply (SCM proc
, SCM args
,
142 SCM
*out_body
, SCM
*out_env
);
143 static void prepare_boot_closure_env_for_eval (SCM proc
, unsigned int argc
,
144 SCM exps
, SCM
*out_body
,
148 #define CAR(x) SCM_CAR(x)
149 #define CDR(x) SCM_CDR(x)
150 #define CAAR(x) SCM_CAAR(x)
151 #define CADR(x) SCM_CADR(x)
152 #define CDAR(x) SCM_CDAR(x)
153 #define CDDR(x) SCM_CDDR(x)
154 #define CADDR(x) SCM_CADDR(x)
155 #define CDDDR(x) SCM_CDDDR(x)
158 SCM_SYMBOL (scm_unbound_variable_key
, "unbound-variable");
160 static void error_used_before_defined (void)
162 scm_error (scm_unbound_variable_key
, NULL
,
163 "Variable used before given a value", SCM_EOL
, SCM_BOOL_F
);
166 static void error_invalid_keyword (SCM proc
)
168 scm_error_scm (scm_from_latin1_symbol ("keyword-argument-error"), proc
,
169 scm_from_locale_string ("Invalid keyword"), SCM_EOL
,
173 static void error_unrecognized_keyword (SCM proc
)
175 scm_error_scm (scm_from_latin1_symbol ("keyword-argument-error"), proc
,
176 scm_from_locale_string ("Unrecognized keyword"), SCM_EOL
,
181 /* Multiple values truncation. */
183 truncate_values (SCM x
)
185 if (SCM_LIKELY (!SCM_VALUESP (x
)))
189 SCM l
= scm_struct_ref (x
, SCM_INUM0
);
190 if (SCM_LIKELY (scm_is_pair (l
)))
194 scm_ithrow (scm_from_latin1_symbol ("vm-run"),
195 scm_list_3 (scm_from_latin1_symbol ("vm-run"),
196 scm_from_locale_string
197 ("Too few values returned to continuation"),
205 #define EVAL1(x, env) (truncate_values (eval ((x), (env))))
209 If MOD is #f, it means the environment was captured before modules were
211 If MOD is the literal value '(), we are evaluating at the top level, and so
212 should track changes to the current module. You have to be careful in this
213 case, because further lexical contours should capture the current module.
215 #define CAPTURE_ENV(env) \
216 (scm_is_null (env) ? scm_current_module () : \
217 (scm_is_false (env) ? scm_the_root_module () : env))
220 eval (SCM x
, SCM env
)
223 SCM proc
= SCM_UNDEFINED
, args
= SCM_EOL
;
228 if (!SCM_MEMOIZED_P (x
))
231 mx
= SCM_MEMOIZED_ARGS (x
);
232 switch (SCM_MEMOIZED_TAG (x
))
235 eval (CAR (mx
), env
);
240 if (scm_is_true (EVAL1 (CAR (mx
), env
)))
248 SCM inits
= CAR (mx
);
249 SCM new_env
= CAPTURE_ENV (env
);
250 for (; scm_is_pair (inits
); inits
= CDR (inits
))
251 new_env
= scm_cons (EVAL1 (CAR (inits
), env
),
259 RETURN_BOOT_CLOSURE (mx
, CAPTURE_ENV (env
));
265 scm_define (CAR (mx
), EVAL1 (CDR (mx
), env
));
266 return SCM_UNSPECIFIED
;
271 scm_i_thread
*t
= SCM_I_CURRENT_THREAD
;
272 in
= EVAL1 (CAR (mx
), env
);
273 out
= EVAL1 (CDDR (mx
), env
);
275 scm_dynstack_push_dynwind (&t
->dynstack
, in
, out
);
276 res
= eval (CADR (mx
), env
);
277 scm_dynstack_pop (&t
->dynstack
);
282 case SCM_M_WITH_FLUIDS
:
285 SCM
*fluidv
, *valuesv
, walk
, res
;
286 scm_i_thread
*thread
= SCM_I_CURRENT_THREAD
;
288 len
= scm_ilength (CAR (mx
));
289 fluidv
= alloca (sizeof (SCM
)*len
);
290 for (i
= 0, walk
= CAR (mx
); i
< len
; i
++, walk
= CDR (walk
))
291 fluidv
[i
] = EVAL1 (CAR (walk
), env
);
292 valuesv
= alloca (sizeof (SCM
)*len
);
293 for (i
= 0, walk
= CADR (mx
); i
< len
; i
++, walk
= CDR (walk
))
294 valuesv
[i
] = EVAL1 (CAR (walk
), env
);
296 scm_dynstack_push_fluids (&thread
->dynstack
, len
, fluidv
, valuesv
,
297 thread
->dynamic_state
);
298 res
= eval (CDDR (mx
), env
);
299 scm_dynstack_unwind_fluids (&thread
->dynstack
, thread
->dynamic_state
);
305 /* Evaluate the procedure to be applied. */
306 proc
= EVAL1 (CAR (mx
), env
);
307 /* Evaluate the argument holding the list of arguments */
308 args
= EVAL1 (CADR (mx
), env
);
311 /* Go here to tail-apply a procedure. PROC is the procedure and
312 * ARGS is the list of arguments. */
313 if (BOOT_CLOSURE_P (proc
))
315 prepare_boot_closure_env_for_apply (proc
, args
, &x
, &env
);
319 return scm_call_with_vm (scm_the_vm (), proc
, args
);
322 /* Evaluate the procedure to be applied. */
323 proc
= EVAL1 (CAR (mx
), env
);
324 argc
= SCM_I_INUM (CADR (mx
));
327 if (BOOT_CLOSURE_P (proc
))
329 prepare_boot_closure_env_for_eval (proc
, argc
, mx
, &x
, &env
);
337 argv
= alloca (argc
* sizeof (SCM
));
338 for (i
= 0; i
< argc
; i
++, mx
= CDR (mx
))
339 argv
[i
] = EVAL1 (CAR (mx
), env
);
341 return scm_c_vm_run (scm_the_vm (), proc
, argv
, argc
);
345 return scm_i_call_with_current_continuation (EVAL1 (mx
, env
));
347 case SCM_M_CALL_WITH_VALUES
:
352 producer
= EVAL1 (CAR (mx
), env
);
353 /* `proc' is the consumer. */
354 proc
= EVAL1 (CDR (mx
), env
);
355 v
= scm_call_with_vm (scm_the_vm (), producer
, SCM_EOL
);
357 args
= scm_struct_ref (v
, SCM_INUM0
);
359 args
= scm_list_1 (v
);
363 case SCM_M_LEXICAL_REF
:
367 for (n
= SCM_I_INUM (mx
); n
; n
--)
370 if (SCM_UNLIKELY (SCM_UNBNDP (ret
)))
371 /* we don't know what variable, though, because we don't have its
373 error_used_before_defined ();
377 case SCM_M_LEXICAL_SET
:
380 SCM val
= EVAL1 (CDR (mx
), env
);
381 for (n
= SCM_I_INUM (CAR (mx
)); n
; n
--)
383 SCM_SETCAR (env
, val
);
384 return SCM_UNSPECIFIED
;
387 case SCM_M_TOPLEVEL_REF
:
388 if (SCM_VARIABLEP (mx
))
389 return SCM_VARIABLE_REF (mx
);
392 while (scm_is_pair (env
))
394 return SCM_VARIABLE_REF
395 (scm_memoize_variable_access_x (x
, CAPTURE_ENV (env
)));
398 case SCM_M_TOPLEVEL_SET
:
401 SCM val
= EVAL1 (CDR (mx
), env
);
402 if (SCM_VARIABLEP (var
))
404 SCM_VARIABLE_SET (var
, val
);
405 return SCM_UNSPECIFIED
;
409 while (scm_is_pair (env
))
412 (scm_memoize_variable_access_x (x
, CAPTURE_ENV (env
)),
414 return SCM_UNSPECIFIED
;
418 case SCM_M_MODULE_REF
:
419 if (SCM_VARIABLEP (mx
))
420 return SCM_VARIABLE_REF (mx
);
422 return SCM_VARIABLE_REF
423 (scm_memoize_variable_access_x (x
, SCM_BOOL_F
));
425 case SCM_M_MODULE_SET
:
426 if (SCM_VARIABLEP (CDR (mx
)))
428 SCM_VARIABLE_SET (CDR (mx
), EVAL1 (CAR (mx
), env
));
429 return SCM_UNSPECIFIED
;
434 (scm_memoize_variable_access_x (x
, SCM_BOOL_F
),
435 EVAL1 (CAR (mx
), env
));
436 return SCM_UNSPECIFIED
;
439 case SCM_M_CALL_WITH_PROMPT
:
442 scm_i_jmp_buf registers
;
443 /* We need the handler after nonlocal return to the setjmp, so
444 make sure it is volatile. */
445 volatile SCM handler
;
447 k
= EVAL1 (CAR (mx
), env
);
448 handler
= EVAL1 (CDDR (mx
), env
);
451 /* Push the prompt onto the dynamic stack. */
452 scm_dynstack_push_prompt (&SCM_I_CURRENT_THREAD
->dynstack
,
453 SCM_F_DYNSTACK_PROMPT_ESCAPE_ONLY
,
455 SCM_VM_DATA (vm
)->fp
,
456 SCM_VM_DATA (vm
)->sp
,
457 SCM_VM_DATA (vm
)->ip
,
460 if (SCM_I_SETJMP (registers
))
462 /* The prompt exited nonlocally. */
464 args
= scm_i_prompt_pop_abort_args_x (scm_the_vm ());
468 res
= scm_call_0 (eval (CADR (mx
), env
));
469 scm_dynstack_pop (&SCM_I_CURRENT_THREAD
->dynstack
);
480 /* Simple procedure calls
484 scm_call_0 (SCM proc
)
486 return scm_c_vm_run (scm_the_vm (), proc
, NULL
, 0);
490 scm_call_1 (SCM proc
, SCM arg1
)
492 return scm_c_vm_run (scm_the_vm (), proc
, &arg1
, 1);
496 scm_call_2 (SCM proc
, SCM arg1
, SCM arg2
)
498 SCM args
[] = { arg1
, arg2
};
499 return scm_c_vm_run (scm_the_vm (), proc
, args
, 2);
503 scm_call_3 (SCM proc
, SCM arg1
, SCM arg2
, SCM arg3
)
505 SCM args
[] = { arg1
, arg2
, arg3
};
506 return scm_c_vm_run (scm_the_vm (), proc
, args
, 3);
510 scm_call_4 (SCM proc
, SCM arg1
, SCM arg2
, SCM arg3
, SCM arg4
)
512 SCM args
[] = { arg1
, arg2
, arg3
, arg4
};
513 return scm_c_vm_run (scm_the_vm (), proc
, args
, 4);
517 scm_call_5 (SCM proc
, SCM arg1
, SCM arg2
, SCM arg3
, SCM arg4
, SCM arg5
)
519 SCM args
[] = { arg1
, arg2
, arg3
, arg4
, arg5
};
520 return scm_c_vm_run (scm_the_vm (), proc
, args
, 5);
524 scm_call_6 (SCM proc
, SCM arg1
, SCM arg2
, SCM arg3
, SCM arg4
, SCM arg5
,
527 SCM args
[] = { arg1
, arg2
, arg3
, arg4
, arg5
, arg6
};
528 return scm_c_vm_run (scm_the_vm (), proc
, args
, 6);
532 scm_call_7 (SCM proc
, SCM arg1
, SCM arg2
, SCM arg3
, SCM arg4
, SCM arg5
,
535 SCM args
[] = { arg1
, arg2
, arg3
, arg4
, arg5
, arg6
, arg7
};
536 return scm_c_vm_run (scm_the_vm (), proc
, args
, 7);
540 scm_call_8 (SCM proc
, SCM arg1
, SCM arg2
, SCM arg3
, SCM arg4
, SCM arg5
,
541 SCM arg6
, SCM arg7
, SCM arg8
)
543 SCM args
[] = { arg1
, arg2
, arg3
, arg4
, arg5
, arg6
, arg7
, arg8
};
544 return scm_c_vm_run (scm_the_vm (), proc
, args
, 8);
548 scm_call_9 (SCM proc
, SCM arg1
, SCM arg2
, SCM arg3
, SCM arg4
, SCM arg5
,
549 SCM arg6
, SCM arg7
, SCM arg8
, SCM arg9
)
551 SCM args
[] = { arg1
, arg2
, arg3
, arg4
, arg5
, arg6
, arg7
, arg8
, arg9
};
552 return scm_c_vm_run (scm_the_vm (), proc
, args
, 9);
556 scm_call_n (SCM proc
, SCM
*argv
, size_t nargs
)
558 return scm_c_vm_run (scm_the_vm (), proc
, argv
, nargs
);
562 scm_call (SCM proc
, ...)
568 va_start (argp
, proc
);
569 while (!SCM_UNBNDP (va_arg (argp
, SCM
)))
573 argv
= alloca (nargs
* sizeof (SCM
));
574 va_start (argp
, proc
);
575 for (i
= 0; i
< nargs
; i
++)
576 argv
[i
] = va_arg (argp
, SCM
);
579 return scm_c_vm_run (scm_the_vm (), proc
, argv
, nargs
);
582 /* Simple procedure applies
586 scm_apply_0 (SCM proc
, SCM args
)
588 return scm_apply (proc
, args
, SCM_EOL
);
592 scm_apply_1 (SCM proc
, SCM arg1
, SCM args
)
594 return scm_apply (proc
, scm_cons (arg1
, args
), SCM_EOL
);
598 scm_apply_2 (SCM proc
, SCM arg1
, SCM arg2
, SCM args
)
600 return scm_apply (proc
, scm_cons2 (arg1
, arg2
, args
), SCM_EOL
);
604 scm_apply_3 (SCM proc
, SCM arg1
, SCM arg2
, SCM arg3
, SCM args
)
606 return scm_apply (proc
, scm_cons (arg1
, scm_cons2 (arg2
, arg3
, args
)),
610 /* This code processes the arguments to apply:
612 (apply PROC ARG1 ... ARGS)
614 Given a list (ARG1 ... ARGS), this function conses the ARG1
615 ... arguments onto the front of ARGS, and returns the resulting
616 list. Note that ARGS is a list; thus, the argument to this
617 function is a list whose last element is a list.
619 Apply calls this function, and applies PROC to the elements of the
620 result. apply:nconc2last takes care of building the list of
621 arguments, given (ARG1 ... ARGS).
623 Rather than do new consing, apply:nconc2last destroys its argument.
624 On that topic, this code came into my care with the following
625 beautifully cryptic comment on that topic: "This will only screw
626 you if you do (scm_apply scm_apply '( ... ))" If you know what
627 they're referring to, send me a patch to this comment. */
629 SCM_DEFINE (scm_nconc2last
, "apply:nconc2last", 1, 0, 0,
631 "Given a list (@var{arg1} @dots{} @var{args}), this function\n"
632 "conses the @var{arg1} @dots{} arguments onto the front of\n"
633 "@var{args}, and returns the resulting list. Note that\n"
634 "@var{args} is a list; thus, the argument to this function is\n"
635 "a list whose last element is a list.\n"
636 "Note: Rather than do new consing, @code{apply:nconc2last}\n"
637 "destroys its argument, so use with care.")
638 #define FUNC_NAME s_scm_nconc2last
641 SCM_VALIDATE_NONEMPTYLIST (1, lst
);
643 while (!scm_is_null (SCM_CDR (*lloc
)))
644 lloc
= SCM_CDRLOC (*lloc
);
645 SCM_ASSERT (scm_ilength (SCM_CAR (*lloc
)) >= 0, lst
, SCM_ARG1
, FUNC_NAME
);
646 *lloc
= SCM_CAR (*lloc
);
653 scm_map (SCM proc
, SCM arg1
, SCM args
)
655 static SCM var
= SCM_BOOL_F
;
657 if (scm_is_false (var
))
658 var
= scm_private_variable (scm_the_root_module (),
659 scm_from_latin1_symbol ("map"));
661 return scm_apply (scm_variable_ref (var
),
662 scm_cons (proc
, scm_cons (arg1
, args
)), SCM_EOL
);
666 scm_for_each (SCM proc
, SCM arg1
, SCM args
)
668 static SCM var
= SCM_BOOL_F
;
670 if (scm_is_false (var
))
671 var
= scm_private_variable (scm_the_root_module (),
672 scm_from_latin1_symbol ("for-each"));
674 return scm_apply (scm_variable_ref (var
),
675 scm_cons (proc
, scm_cons (arg1
, args
)), SCM_EOL
);
680 scm_c_primitive_eval (SCM exp
)
682 if (!SCM_EXPANDED_P (exp
))
683 exp
= scm_call_1 (scm_current_module_transformer (), exp
);
684 return eval (scm_memoize_expression (exp
), SCM_EOL
);
687 static SCM var_primitive_eval
;
689 scm_primitive_eval (SCM exp
)
691 return scm_c_vm_run (scm_the_vm (), scm_variable_ref (var_primitive_eval
),
696 /* Eval does not take the second arg optionally. This is intentional
697 * in order to be R5RS compatible, and to prepare for the new module
698 * system, where we would like to make the choice of evaluation
699 * environment explicit. */
701 SCM_DEFINE (scm_eval
, "eval", 2, 0, 0,
702 (SCM exp
, SCM module_or_state
),
703 "Evaluate @var{exp}, a list representing a Scheme expression,\n"
704 "in the top-level environment specified by\n"
705 "@var{module_or_state}.\n"
706 "While @var{exp} is evaluated (using @code{primitive-eval}),\n"
707 "@var{module_or_state} is made the current module when\n"
708 "it is a module, or the current dynamic state when it is\n"
710 "Example: (eval '(+ 1 2) (interaction-environment))")
711 #define FUNC_NAME s_scm_eval
715 scm_dynwind_begin (SCM_F_DYNWIND_REWINDABLE
);
716 if (scm_is_dynamic_state (module_or_state
))
717 scm_dynwind_current_dynamic_state (module_or_state
);
718 else if (scm_module_system_booted_p
)
720 SCM_VALIDATE_MODULE (2, module_or_state
);
721 scm_dynwind_current_module (module_or_state
);
723 /* otherwise if the module system isn't booted, ignore the module arg */
725 res
= scm_primitive_eval (exp
);
735 /* Apply a function to a list of arguments.
737 This function is exported to the Scheme level as taking two
738 required arguments and a tail argument, as if it were:
739 (lambda (proc arg1 . args) ...)
740 Thus, if you just have a list of arguments to pass to a procedure,
741 pass the list as ARG1, and '() for ARGS. If you have some fixed
742 args, pass the first as ARG1, then cons any remaining fixed args
743 onto the front of your argument list, and pass that as ARGS. */
746 scm_apply (SCM proc
, SCM arg1
, SCM args
)
748 /* Fix things up so that args contains all args. */
749 if (scm_is_null (args
))
752 args
= scm_cons_star (arg1
, args
);
754 return scm_call_with_vm (scm_the_vm (), proc
, args
);
758 prepare_boot_closure_env_for_apply (SCM proc
, SCM args
,
759 SCM
*out_body
, SCM
*out_env
)
761 int nreq
= BOOT_CLOSURE_NUM_REQUIRED_ARGS (proc
);
762 SCM env
= BOOT_CLOSURE_ENV (proc
);
764 if (BOOT_CLOSURE_IS_FIXED (proc
)
765 || (BOOT_CLOSURE_IS_REST (proc
)
766 && !BOOT_CLOSURE_HAS_REST_ARGS (proc
)))
768 if (SCM_UNLIKELY (scm_ilength (args
) != nreq
))
769 scm_wrong_num_args (proc
);
770 for (; scm_is_pair (args
); args
= CDR (args
))
771 env
= scm_cons (CAR (args
), env
);
772 *out_body
= BOOT_CLOSURE_BODY (proc
);
775 else if (BOOT_CLOSURE_IS_REST (proc
))
777 if (SCM_UNLIKELY (scm_ilength (args
) < nreq
))
778 scm_wrong_num_args (proc
);
779 for (; nreq
; nreq
--, args
= CDR (args
))
780 env
= scm_cons (CAR (args
), env
);
781 env
= scm_cons (args
, env
);
782 *out_body
= BOOT_CLOSURE_BODY (proc
);
787 int i
, argc
, nreq
, nopt
;
788 SCM body
, rest
, kw
, inits
, alt
;
789 SCM mx
= BOOT_CLOSURE_CODE (proc
);
792 BOOT_CLOSURE_PARSE_FULL (mx
, body
, nargs
, rest
, nopt
, kw
, inits
, alt
);
794 argc
= scm_ilength (args
);
797 if (scm_is_true (alt
))
803 scm_wrong_num_args (proc
);
805 if (scm_is_false (kw
) && argc
> nreq
+ nopt
&& scm_is_false (rest
))
807 if (scm_is_true (alt
))
813 scm_wrong_num_args (proc
);
816 for (i
= 0; i
< nreq
; i
++, args
= CDR (args
))
817 env
= scm_cons (CAR (args
), env
);
819 if (scm_is_false (kw
))
821 /* Optional args (possibly), but no keyword args. */
822 for (; i
< argc
&& i
< nreq
+ nopt
;
823 i
++, args
= CDR (args
))
825 env
= scm_cons (CAR (args
), env
);
829 for (; i
< nreq
+ nopt
; i
++, inits
= CDR (inits
))
830 env
= scm_cons (EVAL1 (CAR (inits
), env
), env
);
832 if (scm_is_true (rest
))
833 env
= scm_cons (args
, env
);
842 /* Keyword args. As before, but stop at the first keyword. */
843 for (; i
< argc
&& i
< nreq
+ nopt
&& !scm_is_keyword (CAR (args
));
844 i
++, args
= CDR (args
), inits
= CDR (inits
))
845 env
= scm_cons (CAR (args
), env
);
847 for (; i
< nreq
+ nopt
; i
++, inits
= CDR (inits
))
848 env
= scm_cons (EVAL1 (CAR (inits
), env
), env
);
850 if (scm_is_true (rest
))
852 env
= scm_cons (args
, env
);
855 else if (scm_is_true (alt
)
856 && scm_is_pair (args
) && !scm_is_keyword (CAR (args
)))
858 /* Too many positional args, no rest arg, and we have an
864 /* Now fill in env with unbound values, limn the rest of the args for
865 keywords, and fill in unbound values with their inits. */
868 int kw_start_idx
= i
;
870 for (walk
= kw
; scm_is_pair (walk
); walk
= CDR (walk
))
871 if (SCM_I_INUM (CDAR (walk
)) > imax
)
872 imax
= SCM_I_INUM (CDAR (walk
));
873 for (; i
<= imax
; i
++)
874 env
= scm_cons (SCM_UNDEFINED
, env
);
876 if (scm_is_pair (args
) && scm_is_pair (CDR (args
)))
877 for (; scm_is_pair (args
) && scm_is_pair (CDR (args
));
880 k
= CAR (args
); v
= CADR (args
);
881 if (!scm_is_keyword (k
))
883 if (scm_is_true (rest
))
888 for (walk
= kw
; scm_is_pair (walk
); walk
= CDR (walk
))
889 if (scm_is_eq (k
, CAAR (walk
)))
891 /* Well... ok, list-set! isn't the nicest interface, but
893 int iset
= imax
- SCM_I_INUM (CDAR (walk
));
894 scm_list_set_x (env
, SCM_I_MAKINUM (iset
), v
);
898 if (scm_is_null (walk
) && scm_is_false (aok
))
899 error_unrecognized_keyword (proc
);
901 if (scm_is_pair (args
) && scm_is_false (rest
))
902 error_invalid_keyword (proc
);
904 /* Now fill in unbound values, evaluating init expressions in their
905 appropriate environment. */
906 for (i
= imax
- kw_start_idx
; scm_is_pair (inits
); i
--, inits
= CDR (inits
))
908 SCM tail
= scm_list_tail (env
, SCM_I_MAKINUM (i
));
909 if (SCM_UNBNDP (CAR (tail
)))
910 SCM_SETCAR (tail
, EVAL1 (CAR (inits
), CDR (tail
)));
921 prepare_boot_closure_env_for_eval (SCM proc
, unsigned int argc
,
922 SCM exps
, SCM
*out_body
, SCM
*inout_env
)
924 int nreq
= BOOT_CLOSURE_NUM_REQUIRED_ARGS (proc
);
925 SCM new_env
= BOOT_CLOSURE_ENV (proc
);
926 if (BOOT_CLOSURE_IS_FIXED (proc
)
927 || (BOOT_CLOSURE_IS_REST (proc
)
928 && !BOOT_CLOSURE_HAS_REST_ARGS (proc
)))
930 for (; scm_is_pair (exps
); exps
= CDR (exps
), nreq
--)
931 new_env
= scm_cons (EVAL1 (CAR (exps
), *inout_env
),
933 if (SCM_UNLIKELY (nreq
!= 0))
934 scm_wrong_num_args (proc
);
935 *out_body
= BOOT_CLOSURE_BODY (proc
);
936 *inout_env
= new_env
;
938 else if (BOOT_CLOSURE_IS_REST (proc
))
940 if (SCM_UNLIKELY (argc
< nreq
))
941 scm_wrong_num_args (proc
);
942 for (; nreq
; nreq
--, exps
= CDR (exps
))
943 new_env
= scm_cons (EVAL1 (CAR (exps
), *inout_env
),
947 for (; scm_is_pair (exps
); exps
= CDR (exps
))
948 rest
= scm_cons (EVAL1 (CAR (exps
), *inout_env
), rest
);
949 new_env
= scm_cons (scm_reverse (rest
),
952 *out_body
= BOOT_CLOSURE_BODY (proc
);
953 *inout_env
= new_env
;
958 for (; scm_is_pair (exps
); exps
= CDR (exps
))
959 args
= scm_cons (EVAL1 (CAR (exps
), *inout_env
), args
);
960 args
= scm_reverse_x (args
, SCM_UNDEFINED
);
961 prepare_boot_closure_env_for_apply (proc
, args
, out_body
, inout_env
);
966 boot_closure_apply (SCM closure
, SCM args
)
969 prepare_boot_closure_env_for_apply (closure
, args
, &body
, &env
);
970 return eval (body
, env
);
974 boot_closure_print (SCM closure
, SCM port
, scm_print_state
*pstate
)
977 scm_puts_unlocked ("#<boot-closure ", port
);
978 scm_uintprint (SCM_UNPACK (closure
), 16, port
);
979 scm_putc_unlocked (' ', port
);
980 args
= scm_make_list (scm_from_int (BOOT_CLOSURE_NUM_REQUIRED_ARGS (closure
)),
981 scm_from_latin1_symbol ("_"));
982 if (!BOOT_CLOSURE_IS_FIXED (closure
) && BOOT_CLOSURE_HAS_REST_ARGS (closure
))
983 args
= scm_cons_star (scm_from_latin1_symbol ("_"), args
);
984 /* FIXME: optionals and rests */
985 scm_display (args
, port
);
986 scm_putc_unlocked ('>', port
);
995 f_apply
= scm_c_define_gsubr ("apply", 2, 0, 1, scm_apply
);
997 scm_tc16_boot_closure
= scm_make_smob_type ("boot-closure", 0);
998 scm_set_smob_apply (scm_tc16_boot_closure
, boot_closure_apply
, 0, 0, 1);
999 scm_set_smob_print (scm_tc16_boot_closure
, boot_closure_print
);
1001 primitive_eval
= scm_c_make_gsubr ("primitive-eval", 1, 0, 0,
1002 scm_c_primitive_eval
);
1003 var_primitive_eval
= scm_define (SCM_SUBR_NAME (primitive_eval
),
1006 #include "libguile/eval.x"