mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-06-14 23:50:19 +02:00
Code Activity

new evaluator, y'all

Browse source 
* libguile/eval.c: So, ladies & gents, a new evaluator. It's similar to
  the old one, in that we memoize and then evaluate, but in this
  incarnation, memoization of an expression happens before evaluation,
  not lazily as the expression is evaluated. This makes the evaluation
  itself much cleaner, in addition to being threadsafe. In addition,
  since this C evaluator will in the future just serve to bootstrap the
  Scheme evaluator, we don't have to pay much concern for debugging
  conveniences. So the environment is just a list of values, and the
  memoizer pre-computes where it's going to find each individual value
  in the environment.

  Interface changes are commented below, with eval.h.

  (scm_evaluator_traps): No need to reset the debug mode after rnning te
  traps thing. But really, the whole traps system needs some love.

* libguile/memoize.h:
* libguile/memoize.c: New memoizer, which runs before evaluation,
  checking all syntax before evaluation begins. Significantly, no
  debugging information is left for lexical variables, which is not so
  great for interactive debugging; perhaps we should change this to have
  a var list in the future as per the classic interpreters. But it's
  quite fast, and the resulting code is quite good. Also note that it
  doesn't produce ilocs, memoized code is a smob whose type is in the
  first word of the smob itself.

* libguile/eval.h (scm_sym_and, scm_sym_begin, scm_sym_case)
  (scm_sym_cond, scm_sym_define, scm_sym_do, scm_sym_if, scm_sym_lambda)
  (scm_sym_let, scm_sym_letstar, scm_sym_letrec, scm_sym_quote)
  (scm_sym_quasiquote, scm_sym_unquote, scm_sym_uq_splicing, scm_sym_at)
  (scm_sym_atat, scm_sym_atapply, scm_sym_atcall_cc)
  (scm_sym_at_call_with_values, scm_sym_delay, scm_sym_eval_when)
  (scm_sym_arrow, scm_sym_else, scm_sym_apply, scm_sym_set_x)
  (scm_sym_args): Remove public declaration of these symbols.
  (scm_ilookup, scm_lookupcar, scm_eval_car, scm_eval_body)
  (scm_eval_args, scm_i_eval_x, scm_i_eval): Remove public declaration
  of these functions.
  (scm_ceval, scm_deval, scm_ceval_ptr): Remove declarations of these
  deprecated functions.
  (scm_i_print_iloc, scm_i_print_isym, scm_i_unmemocopy_expr)
  (scm_i_unmemocopy_body): Remove declarations of these internal
  functions.
  (scm_primitive_eval_x, scm_eval_x): Redefine as macros for their less
  destructive siblings.

* libguile/Makefile.am: Add memoize.[ch] to the build.

* libguile/debug.h (scm_debug_mode_p, scm_check_entry_p)
  (scm_check_apply_p, scm_check_exit_p, scm_check_memoize_p)
  (scm_debug_eframe_size): Remove these vars that were tied to the old
  evaluator's execution model.
  (SCM_RESET_DEBUG_MODE): Remove, no more need for this.
  (SCM_MEMOIZEDP, SCM_MEMOIZED_EXP, SCM_MEMOIZED_ENV): Remove macros
  referring to old memoized code representation.
  (scm_local_eval, scm_procedure_environment, scm_memoized_environment)
  (scm_make_memoized, scm_memoized_p): Remove functions operating on old
  memoized code representation.
  (scm_memcons, scm_mem_to_proc, scm_proc_to_mem): Remove debug-only
  code for old evaluator.

* libguile/debug.c: Remove code to correspond with debug.h removals.
  (scm_debug_options): No need to set the debug mode or frame limit
  here, as we don't have C stack limits any more. Perhaps this is a bug,
  but as long as we can compile eval.scm, we should be fine.

* libguile/init.c (scm_i_init_guile): Init memoize.c.

* libguile/modules.c (scm_top_level_env, scm_env_top_level)
  (scm_env_module, scm_system_module_env_p): Remove these functions.

* libguile/print.c (iprin1): No more need to handle isyms. Adapt to new
  form of interpreted procedures.

* libguile/procprop.c (scm_i_procedure_arity): Adapt to new form of
  interpreted procedures.

* libguile/procs.c (scm_thunk_p): Adapt to new form of interpreted
  procedures.
* libguile/procs.h (SCM_CLOSURE_FORMALS): Removed, this exists no more.
  (SCM_CLOSURE_NUM_REQUIRED_ARGS, SCM_CLOSURE_HAS_REST_ARGS): New
  accessors.

* libguile/srcprop.c (scm_source_properties, scm_source_property)
  (scm_set_source_property_x): Remove special cases for memoized code.

* libguile/stacks.c (read_frame): Remove a source-property case for
  interpreted code.
  (NEXT_FRAME): Remove a case that I don't fully understand, that seems
  to be designed to skip over apply frames. Will be obsolete in the
  futures.
  (read_frames): Default source value for interpreted frames to #f.
  (narrow_stack): Don't pay attention to the system_module thing.

* libguile/tags.h: Remove isyms and ilocs. Whee!

* libguile/validate.h (SCM_VALIDATE_MEMOIZED): Fix to use the new
  MEMOIZED_P formulation.

* module/ice-9/psyntax-pp.scm (do, quasiquote, case): Adapt for these no
  longer being primitive macros.
* module/ice-9/boot-9.scm: Whitespace change, but just a poke to force a
  rebuild due to and/or/cond/... not being primitives any more.

* module/ice-9/deprecated.scm (unmemoize-expr): Deprecate, it's
  unmemoize-expression now.

* test-suite/tests/eval.test ("define set procedure-name"): XFAIL a
  couple of tests here; I don't know what to do about them. I reckon the
  expander should ensure that defined values are named.

* test-suite/tests/chars.test ("basic char handling"): Fix expected
  exception when trying to apply a char.
This commit is contained in:
Andy Wingo 2009-11-28 01:19:50 +01:00
parent 83c7655002
commit b7742c6b71
24 changed files with 1786 additions and 5094 deletions
Download patch file Download diff file Expand all files Collapse all files

4
libguile/Makefile.am
View file

@ -154,6 +154,7 @@ libguile_la_SOURCES = \
load.c \
macros.c \
mallocs.c \
memoize.c \
modules.c \
null-threads.c \
numbers.c \
@ -249,6 +250,7 @@ DOT_X_FILES = \
load.x \
macros.x \
mallocs.x \
memoize.x \
modules.x \
numbers.x \
objprop.x \
@ -345,6 +347,7 @@ DOT_DOC_FILES = \
load.doc \
macros.doc \
mallocs.doc \
memoize.doc \
modules.doc \
numbers.doc \
objprop.doc \
@ -507,6 +510,7 @@ modinclude_HEADERS = \
load.h \
macros.h \
mallocs.h \
memoize.h \
modules.h \
net_db.h \
null-threads.h \

304
libguile/debug.c
View file

@ -48,6 +48,7 @@
#include "libguile/root.h"
#include "libguile/fluids.h"
#include "libguile/programs.h"
#include "libguile/memoize.h"
#include "libguile/validate.h"
#include "libguile/debug.h"
@ -77,11 +78,9 @@ SCM_DEFINE (scm_debug_options, "debug-options-interface", 0, 1, 0,
scm_options (ans, scm_debug_opts, FUNC_NAME);
SCM_OUT_OF_RANGE (1, setting);
}
SCM_RESET_DEBUG_MODE;
#ifdef STACK_CHECKING
scm_stack_checking_enabled_p = SCM_STACK_CHECKING_P;
#endif
scm_debug_eframe_size = 2 * SCM_N_FRAMES;
scm_dynwind_end ();
return ans;
@ -131,175 +130,6 @@ SCM_SYMBOL (scm_sym_procname, "procname");
SCM_SYMBOL (scm_sym_dots, "...");
SCM_SYMBOL (scm_sym_source, "source");
/* {Memoized Source}
*/
scm_t_bits scm_tc16_memoized;
static int
memoized_print (SCM obj, SCM port, scm_print_state *pstate)
{
int writingp = SCM_WRITINGP (pstate);
scm_puts ("#<memoized ", port);
SCM_SET_WRITINGP (pstate, 1);
scm_iprin1 (SCM_MEMOIZED_EXP (obj), port, pstate);
SCM_SET_WRITINGP (pstate, writingp);
scm_putc ('>', port);
return 1;
}
SCM_DEFINE (scm_memoized_p, "memoized?", 1, 0, 0,
(SCM obj),
"Return @code{#t} if @var{obj} is memoized.")
#define FUNC_NAME s_scm_memoized_p
{
return scm_from_bool(SCM_MEMOIZEDP (obj));
}
#undef FUNC_NAME
SCM
scm_make_memoized (SCM exp, SCM env)
{
/* *fixme* Check that env is a valid environment. */
SCM_RETURN_NEWSMOB (scm_tc16_memoized, SCM_UNPACK (scm_cons (exp, env)));
}
#ifdef GUILE_DEBUG
/*
* Some primitives for construction of memoized code
*
* - procedure: memcons CAR CDR [ENV]
*
* Construct a pair, encapsulated in a memoized object.
*
* The CAR and CDR can be either normal or memoized. If ENV isn't
* specified, the top-level environment of the current module will
* be assumed. All environments must match.
*
* - procedure: make-iloc FRAME BINDING CDRP
*
* Return an iloc referring to frame no. FRAME, binding
* no. BINDING. If CDRP is non-#f, the iloc is referring to a
* frame consisting of a single pair, with the value stored in the
* CDR.
*
* - procedure: iloc? OBJECT
*
* Return #t if OBJECT is an iloc.
*
* - procedure: mem->proc MEMOIZED
*
* Construct a closure from the memoized lambda expression MEMOIZED
*
* WARNING! The code is not copied!
*
* - procedure: proc->mem CLOSURE
*
* Turn the closure CLOSURE into a memoized object.
*
* WARNING! The code is not copied!
*
* - constant: SCM_IM_AND
* - constant: SCM_IM_BEGIN
* - constant: SCM_IM_CASE
* - constant: SCM_IM_COND
* - constant: SCM_IM_DO
* - constant: SCM_IM_IF
* - constant: SCM_IM_LAMBDA
* - constant: SCM_IM_LET
* - constant: SCM_IM_LETSTAR
* - constant: SCM_IM_LETREC
* - constant: SCM_IM_OR
* - constant: SCM_IM_QUOTE
* - constant: SCM_IM_SET
* - constant: SCM_IM_DEFINE
* - constant: SCM_IM_APPLY
* - constant: SCM_IM_CONT
* - constant: SCM_IM_DISPATCH
*/
#include "libguile/variable.h"
#include "libguile/procs.h"
SCM_DEFINE (scm_memcons, "memcons", 2, 1, 0,
(SCM car, SCM cdr, SCM env),
"Return a new memoized cons cell with @var{car} and @var{cdr}\n"
"as members and @var{env} as the environment.")
#define FUNC_NAME s_scm_memcons
{
if (SCM_MEMOIZEDP (car))
{
/*fixme* environments may be two different but equal top-level envs */
if (!SCM_UNBNDP (env) && SCM_MEMOIZED_ENV (car) != env)
SCM_MISC_ERROR ("environment mismatch arg1 <-> arg3",
scm_list_2 (car, env));
else
env = SCM_MEMOIZED_ENV (car);
car = SCM_MEMOIZED_EXP (car);
}
if (SCM_MEMOIZEDP (cdr))
{
if (!SCM_UNBNDP (env) && SCM_MEMOIZED_ENV (cdr) != env)
SCM_MISC_ERROR ("environment mismatch arg2 <-> arg3",
scm_list_2 (cdr, env));
else
env = SCM_MEMOIZED_ENV (cdr);
cdr = SCM_MEMOIZED_EXP (cdr);
}
if (SCM_UNBNDP (env))
env = scm_top_level_env (SCM_TOP_LEVEL_LOOKUP_CLOSURE);
else
SCM_VALIDATE_NULLORCONS (3, env);
return scm_make_memoized (scm_cons (car, cdr), env);
}
#undef FUNC_NAME
SCM_DEFINE (scm_mem_to_proc, "mem->proc", 1, 0, 0,
(SCM obj),
"Convert a memoized object (which must represent a body)\n"
"to a procedure.")
#define FUNC_NAME s_scm_mem_to_proc
{
SCM env;
SCM_VALIDATE_MEMOIZED (1, obj);
env = SCM_MEMOIZED_ENV (obj);
obj = SCM_MEMOIZED_EXP (obj);
return scm_closure (obj, env);
}
#undef FUNC_NAME
SCM_DEFINE (scm_proc_to_mem, "proc->mem", 1, 0, 0,
(SCM obj),
"Convert a procedure to a memoized object.")
#define FUNC_NAME s_scm_proc_to_mem
{
SCM_VALIDATE_CLOSURE (1, obj);
return scm_make_memoized (SCM_CODE (obj), SCM_ENV (obj));
}
#undef FUNC_NAME
#endif /* GUILE_DEBUG */
SCM_DEFINE (scm_i_unmemoize_expr, "unmemoize-expr", 1, 0, 0,
(SCM m),
"Unmemoize the memoized expression @var{m},")
#define FUNC_NAME s_scm_i_unmemoize_expr
{
SCM_VALIDATE_MEMOIZED (1, m);
return scm_i_unmemocopy_expr (SCM_MEMOIZED_EXP (m), SCM_MEMOIZED_ENV (m));
}
#undef FUNC_NAME
SCM_DEFINE (scm_memoized_environment, "memoized-environment", 1, 0, 0,
(SCM m),
"Return the environment of the memoized expression @var{m}.")
#define FUNC_NAME s_scm_memoized_environment
{
SCM_VALIDATE_MEMOIZED (1, m);
return SCM_MEMOIZED_ENV (m);
}
#undef FUNC_NAME
SCM_DEFINE (scm_procedure_name, "procedure-name", 1, 0, 0,
(SCM proc),
"Return the name of the procedure @var{proc}")
@ -333,75 +163,33 @@ SCM_DEFINE (scm_procedure_source, "procedure-source", 1, 0, 0,
"Return the source of the procedure @var{proc}.")
#define FUNC_NAME s_scm_procedure_source
{
SCM_VALIDATE_NIM (1, proc);
again:
switch (SCM_TYP7 (proc)) {
case scm_tcs_closures:
{
const SCM formals = SCM_CLOSURE_FORMALS (proc);
const SCM body = SCM_CLOSURE_BODY (proc);
const SCM src = scm_source_property (body, scm_sym_copy);
SCM src;
SCM_VALIDATE_PROC (1, proc);
if (scm_is_true (src))
do
{
return scm_cons2 (scm_sym_lambda, formals, src);
}
else
{
const SCM env = SCM_EXTEND_ENV (formals, SCM_EOL, SCM_ENV (proc));
return scm_cons2 (scm_sym_lambda,
scm_i_finite_list_copy (formals),
scm_i_unmemocopy_body (body, env));
}
}
case scm_tcs_struct:
if (!SCM_STRUCT_APPLICABLE_P (proc))
break;
proc = SCM_STRUCT_PROCEDURE (proc);
if (SCM_IMP (proc))
break;
goto procprop;
case scm_tc7_smob:
if (!SCM_SMOB_DESCRIPTOR (proc).apply)
break;
case scm_tcs_subrs:
case scm_tc7_program:
procprop:
/* It would indeed be a nice thing if we supplied source even for
built in procedures! */
return scm_procedure_property (proc, scm_sym_source);
case scm_tc7_pws:
{
SCM src = scm_procedure_property (proc, scm_sym_source);
src = scm_procedure_property (proc, scm_sym_source);
if (scm_is_true (src))
return src;
proc = SCM_PROCEDURE (proc);
goto again;
}
default:
;
}
SCM_WRONG_TYPE_ARG (1, proc);
return SCM_BOOL_F; /* not reached */
}
#undef FUNC_NAME
SCM_DEFINE (scm_procedure_environment, "procedure-environment", 1, 0, 0,
(SCM proc),
"Return the environment of the procedure @var{proc}.")
#define FUNC_NAME s_scm_procedure_environment
{
SCM_VALIDATE_NIM (1, proc);
switch (SCM_TYP7 (proc)) {
case scm_tcs_closures:
return SCM_ENV (proc);
case scm_tcs_subrs:
return SCM_EOL;
case scm_tcs_struct:
if (!SCM_STRUCT_APPLICABLE_P (proc)
|| SCM_IMP (SCM_STRUCT_PROCEDURE (proc)))
break;
proc = SCM_STRUCT_PROCEDURE (proc);
continue;
case scm_tc7_pws:
proc = SCM_PROCEDURE (proc);
continue;
default:
SCM_WRONG_TYPE_ARG (1, proc);
/* not reached */
break;
}
}
while (0);
return SCM_BOOL_F;
}
#undef FUNC_NAME
SCM_DEFINE (scm_procedure_module, "procedure-module", 1, 0, 0,
@ -413,37 +201,21 @@ SCM_DEFINE (scm_procedure_module, "procedure-module", 1, 0, 0,
if (scm_is_true (scm_program_p (proc)))
return scm_program_module (proc);
else if (SCM_CLOSUREP (proc))
{
SCM env = SCM_ENV (proc);
while (scm_is_pair (env))
env = scm_cdr (env);
return env;
}
else
return scm_env_module (scm_procedure_environment (proc));
return SCM_BOOL_F;
}
#undef FUNC_NAME
/* Eval in a local environment. We would like to have the ability to
* evaluate in a specified local environment, but due to the
* memoization this isn't normally possible. We solve it by copying
* the code before evaluating. One solution would be to have eval.c
* generate yet another evaluator. They are not very big actually.
*/
SCM_DEFINE (scm_local_eval, "local-eval", 1, 1, 0,
(SCM exp, SCM env),
"Evaluate @var{exp} in its environment. If @var{env} is supplied,\n"
"it is the environment in which to evaluate @var{exp}. Otherwise,\n"
"@var{exp} must be a memoized code object (in which case, its environment\n"
"is implicit).")
#define FUNC_NAME s_scm_local_eval
{
if (SCM_UNBNDP (env))
{
SCM_VALIDATE_MEMOIZED (1, exp);
return scm_i_eval_x (SCM_MEMOIZED_EXP (exp), SCM_MEMOIZED_ENV (exp));
}
return scm_i_eval (exp, env);
}
#undef FUNC_NAME
#if 0
SCM_REGISTER_PROC (s_reverse_lookup, "reverse-lookup", 2, 0, 0, scm_reverse_lookup);
#endif
@ -565,31 +337,9 @@ scm_init_debug ()
init_stack_limit ();
scm_init_opts (scm_debug_options, scm_debug_opts);
scm_tc16_memoized = scm_make_smob_type ("memoized", 0);
scm_set_smob_print (scm_tc16_memoized, memoized_print);
scm_tc16_debugobj = scm_make_smob_type ("debug-object", 0);
scm_set_smob_print (scm_tc16_debugobj, debugobj_print);
#ifdef GUILE_DEBUG
scm_c_define ("SCM_IM_AND", SCM_IM_AND);
scm_c_define ("SCM_IM_BEGIN", SCM_IM_BEGIN);
scm_c_define ("SCM_IM_CASE", SCM_IM_CASE);
scm_c_define ("SCM_IM_COND", SCM_IM_COND);
scm_c_define ("SCM_IM_DO", SCM_IM_DO);
scm_c_define ("SCM_IM_IF", SCM_IM_IF);
scm_c_define ("SCM_IM_LAMBDA", SCM_IM_LAMBDA);
scm_c_define ("SCM_IM_LET", SCM_IM_LET);
scm_c_define ("SCM_IM_LETSTAR", SCM_IM_LETSTAR);
scm_c_define ("SCM_IM_LETREC", SCM_IM_LETREC);
scm_c_define ("SCM_IM_OR", SCM_IM_OR);
scm_c_define ("SCM_IM_QUOTE", SCM_IM_QUOTE);
scm_c_define ("SCM_IM_SET_X", SCM_IM_SET_X);
scm_c_define ("SCM_IM_DEFINE", SCM_IM_DEFINE);
scm_c_define ("SCM_IM_APPLY", SCM_IM_APPLY);
scm_c_define ("SCM_IM_CONT", SCM_IM_CONT);
scm_c_define ("SCM_IM_DISPATCH", SCM_IM_DISPATCH);
#endif
scm_add_feature ("debug-extensions");
#include "libguile/debug.x"

41
libguile/debug.h
View file

@ -3,7 +3,7 @@
#ifndef SCM_DEBUG_H
#define SCM_DEBUG_H
/* Copyright (C) 1995,1996,1998,1999,2000,2001,2002,2004,2008
/* Copyright (C) 1995,1996,1998,1999,2000,2001,2002,2004,2008,2009
* Free Software Foundation, Inc.
*
* This library is free software; you can redistribute it and/or
@ -45,26 +45,6 @@
SCM_API int scm_debug_mode_p;
SCM_API int scm_check_entry_p;
SCM_API int scm_check_apply_p;
SCM_API int scm_check_exit_p;
SCM_API int scm_check_memoize_p;
#define SCM_RESET_DEBUG_MODE \
do {\
scm_check_entry_p = (SCM_ENTER_FRAME_P || SCM_BREAKPOINTS_P)\
&& scm_is_true (SCM_ENTER_FRAME_HDLR);\
scm_check_apply_p = (SCM_APPLY_FRAME_P || SCM_TRACE_P)\
&& scm_is_true (SCM_APPLY_FRAME_HDLR);\
scm_check_exit_p = (SCM_EXIT_FRAME_P || SCM_TRACE_P)\
&& scm_is_true (SCM_EXIT_FRAME_HDLR);\
scm_check_memoize_p = (SCM_MEMOIZE_P)\
&& scm_is_true (SCM_MEMOIZE_HDLR);\
scm_debug_mode_p = SCM_DEVAL_P\
|| scm_check_memoize_p || scm_check_entry_p || scm_check_apply_p || scm_check_exit_p;\
} while (0)
/* {Evaluator}
*/
@ -75,8 +55,6 @@ typedef union scm_t_debug_info
SCM id;
} scm_t_debug_info;
SCM_API long scm_debug_eframe_size;
typedef struct scm_t_debug_frame
{
struct scm_t_debug_frame *prev;
@ -125,28 +103,14 @@ SCM_API scm_t_bits scm_tc16_debugobj;
((scm_t_debug_frame *) SCM_CELL_WORD_1 (x))
#define SCM_SET_DEBUGOBJ_FRAME(x, f) SCM_SET_CELL_WORD_1 (x, f)
/* {Memoized Source}
*/
SCM_API scm_t_bits scm_tc16_memoized;
#define SCM_MEMOIZEDP(x) SCM_TYP16_PREDICATE (scm_tc16_memoized, x)
#define SCM_MEMOIZED_EXP(x) SCM_CAR (SCM_CELL_OBJECT_1 (x))
#define SCM_MEMOIZED_ENV(x) SCM_CDR (SCM_CELL_OBJECT_1 (x))
SCM_API SCM scm_debug_object_p (SCM obj);
SCM_API SCM scm_local_eval (SCM exp, SCM env);
SCM_API SCM scm_reverse_lookup (SCM env, SCM data);
SCM_API SCM scm_sys_start_stack (SCM info_id, SCM thunk);
SCM_API SCM scm_procedure_environment (SCM proc);
SCM_API SCM scm_procedure_module (SCM proc);
SCM_API SCM scm_procedure_source (SCM proc);
SCM_API SCM scm_procedure_name (SCM proc);
SCM_API SCM scm_memoized_environment (SCM m);
SCM_API SCM scm_make_memoized (SCM exp, SCM env);
SCM_API SCM scm_memoized_p (SCM obj);
SCM_API SCM scm_with_traps (SCM thunk);
SCM_API SCM scm_evaluator_traps (SCM setting);
SCM_API SCM scm_debug_options (SCM setting);
@ -156,9 +120,6 @@ SCM_INTERNAL SCM scm_i_unmemoize_expr (SCM memoized);
SCM_INTERNAL void scm_init_debug (void);
#ifdef GUILE_DEBUG
SCM_API SCM scm_memcons (SCM car, SCM cdr, SCM env);
SCM_API SCM scm_mem_to_proc (SCM obj);
SCM_API SCM scm_proc_to_mem (SCM obj);
SCM_API SCM scm_debug_hang (SCM obj);
#endif /*GUILE_DEBUG*/

4788
libguile/eval.c
View file

File diff suppressed because it is too large Load diff

62
libguile/eval.h
View file

@ -27,6 +27,7 @@
#include "libguile/__scm.h"
#include "libguile/struct.h"
#include "libguile/memoize.h"
@ -79,42 +80,6 @@ typedef SCM (*scm_t_trampoline_2) (SCM proc, SCM arg1, SCM arg2);
SCM_API SCM scm_sym_and;
SCM_API SCM scm_sym_begin;
SCM_API SCM scm_sym_case;
SCM_API SCM scm_sym_cond;
SCM_API SCM scm_sym_define;
SCM_API SCM scm_sym_do;
SCM_API SCM scm_sym_if;
SCM_API SCM scm_sym_lambda;
SCM_API SCM scm_sym_let;
SCM_API SCM scm_sym_letstar;
SCM_API SCM scm_sym_letrec;
SCM_API SCM scm_sym_quote;
SCM_API SCM scm_sym_quasiquote;
SCM_API SCM scm_sym_unquote;
SCM_API SCM scm_sym_uq_splicing;
SCM_API SCM scm_sym_at;
SCM_API SCM scm_sym_atat;
SCM_API SCM scm_sym_atapply;
SCM_API SCM scm_sym_atcall_cc;
SCM_API SCM scm_sym_at_call_with_values;
SCM_API SCM scm_sym_delay;
SCM_API SCM scm_sym_eval_when;
SCM_API SCM scm_sym_arrow;
SCM_API SCM scm_sym_else;
SCM_API SCM scm_sym_apply;
SCM_API SCM scm_sym_set_x;
SCM_API SCM scm_sym_args;
SCM_API SCM * scm_ilookup (SCM iloc, SCM env);
SCM_API SCM * scm_lookupcar (SCM vloc, SCM genv, int check);
SCM_API SCM scm_eval_car (SCM pair, SCM env);
SCM_API SCM scm_eval_body (SCM code, SCM env);
SCM_API SCM scm_eval_args (SCM i, SCM env, SCM proc);
SCM_API int scm_badargsp (SCM formals, SCM args);
SCM_API SCM scm_call_0 (SCM proc);
SCM_API SCM scm_call_1 (SCM proc, SCM arg1);
@ -126,42 +91,23 @@ SCM_API SCM scm_apply_1 (SCM proc, SCM arg1, SCM args);
SCM_API SCM scm_apply_2 (SCM proc, SCM arg1, SCM arg2, SCM args);
SCM_API SCM scm_apply_3 (SCM proc, SCM arg1, SCM arg2, SCM arg3, SCM args);
SCM_INTERNAL SCM scm_i_call_closure_0 (SCM proc);
SCM_API scm_t_trampoline_0 scm_trampoline_0 (SCM proc);
SCM_API scm_t_trampoline_1 scm_trampoline_1 (SCM proc);
SCM_API scm_t_trampoline_2 scm_trampoline_2 (SCM proc);
SCM_API SCM scm_nconc2last (SCM lst);
SCM_API SCM scm_apply (SCM proc, SCM arg1, SCM args);
SCM_API SCM scm_dapply (SCM proc, SCM arg1, SCM args);
#define scm_dapply(proc,arg1,args) scm_apply (proc, arg1, args)
SCM_API SCM scm_map (SCM proc, SCM arg1, SCM args);
SCM_API SCM scm_for_each (SCM proc, SCM arg1, SCM args);
SCM_API SCM scm_closure (SCM code, SCM env);
SCM_API SCM scm_make_promise (SCM thunk);
SCM_API SCM scm_force (SCM x);
SCM_API SCM scm_promise_p (SCM x);
SCM_API SCM scm_i_eval_x (SCM exp, SCM env) /* not internal */;
SCM_INTERNAL SCM scm_i_eval (SCM exp, SCM env);
SCM_API SCM scm_primitive_eval (SCM exp);
SCM_API SCM scm_primitive_eval_x (SCM exp);
#define scm_primitive_eval_x(exp) scm_primitive_eval (exp)
SCM_API SCM scm_eval (SCM exp, SCM module);
SCM_API SCM scm_eval_x (SCM exp, SCM module);
#define scm_eval_x(exp, module) scm_eval (exp, module)
SCM_INTERNAL void scm_i_print_iloc (SCM /*iloc*/, SCM /*port*/);
SCM_INTERNAL void scm_i_print_isym (SCM /*isym*/, SCM /*port*/);
SCM_INTERNAL SCM scm_i_unmemocopy_expr (SCM expr, SCM env);
SCM_INTERNAL SCM scm_i_unmemocopy_body (SCM forms, SCM env);
SCM_INTERNAL void scm_init_eval (void);
#if (SCM_ENABLE_DEPRECATED == 1)
/* Deprecated in guile 1.7.0 on 2004-03-29. */
SCM_DEPRECATED SCM scm_ceval (SCM x, SCM env);
SCM_DEPRECATED SCM scm_deval (SCM x, SCM env);
SCM_DEPRECATED SCM (*scm_ceval_ptr) (SCM x, SCM env);
#endif
#endif /* SCM_EVAL_H */
/*

2
libguile/init.c
View file

@ -79,6 +79,7 @@
#include "libguile/load.h"
#include "libguile/macros.h"
#include "libguile/mallocs.h"
#include "libguile/memoize.h"
#include "libguile/modules.h"
#include "libguile/net_db.h"
#include "libguile/numbers.h"
@ -548,6 +549,7 @@ scm_i_init_guile (SCM_STACKITEM *base)
scm_init_weaks ();
scm_init_guardians ();
scm_init_vports ();
scm_init_memoize ();
scm_init_eval ();
scm_init_evalext ();
scm_init_debug (); /* Requires macro smobs */

1141
libguile/memoize.c Normal file
View file

File diff suppressed because it is too large Load diff

106
libguile/memoize.h Normal file
View file

@ -0,0 +1,106 @@
/* classes: h_files */
#ifndef SCM_MEMOIZE_H
#define SCM_MEMOIZE_H
/* Copyright (C) 1995,1996,1998,1999,2000,2001,2002,2004,2008,2009
* Free Software Foundation, Inc.
*
* This library is free software; you can redistribute it and/or
* modify it under the terms of the GNU Lesser General Public License
* as published by the Free Software Foundation; either version 3 of
* the License, or (at your option) any later version.
*
* This library is distributed in the hope that it will be useful, but
* WITHOUT ANY WARRANTY; without even the implied warranty of
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
* Lesser General Public License for more details.
*
* You should have received a copy of the GNU Lesser General Public
* License along with this library; if not, write to the Free Software
* Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
* 02110-1301 USA
*/
#include "libguile/__scm.h"
SCM_API SCM scm_sym_and;
SCM_API SCM scm_sym_begin;
SCM_API SCM scm_sym_case;
SCM_API SCM scm_sym_cond;
SCM_API SCM scm_sym_define;
SCM_API SCM scm_sym_do;
SCM_API SCM scm_sym_if;
SCM_API SCM scm_sym_lambda;
SCM_API SCM scm_sym_let;
SCM_API SCM scm_sym_letstar;
SCM_API SCM scm_sym_letrec;
SCM_API SCM scm_sym_quote;
SCM_API SCM scm_sym_quasiquote;
SCM_API SCM scm_sym_unquote;
SCM_API SCM scm_sym_uq_splicing;
SCM_API SCM scm_sym_at;
SCM_API SCM scm_sym_atat;
SCM_API SCM scm_sym_atapply;
SCM_API SCM scm_sym_atcall_cc;
SCM_API SCM scm_sym_at_call_with_values;
SCM_API SCM scm_sym_delay;
SCM_API SCM scm_sym_eval_when;
SCM_API SCM scm_sym_arrow;
SCM_API SCM scm_sym_else;
SCM_API SCM scm_sym_apply;
SCM_API SCM scm_sym_set_x;
SCM_API SCM scm_sym_args;
/* {Memoized Source}
*/
SCM_INTERNAL scm_t_bits scm_tc16_memoized;
#define SCM_MEMOIZED_P(x) (SCM_SMOB_PREDICATE (scm_tc16_memoized, (x)))
#define SCM_MEMOIZED_TAG(x) (SCM_SMOB_FLAGS (x))
#define SCM_MEMOIZED_ARGS(x) (SCM_SMOB_OBJECT (x))
enum
{
SCM_M_BEGIN,
SCM_M_IF,
SCM_M_LAMBDA,
SCM_M_LET,
SCM_M_QUOTE,
SCM_M_DEFINE,
SCM_M_APPLY,
SCM_M_CONT,
SCM_M_CALL_WITH_VALUES,
SCM_M_CALL,
SCM_M_LEXICAL_REF,
SCM_M_LEXICAL_SET,
SCM_M_TOPLEVEL_REF,
SCM_M_TOPLEVEL_SET,
SCM_M_MODULE_REF,
SCM_M_MODULE_SET
};
SCM_INTERNAL SCM scm_memoize_expression (SCM exp);
SCM_INTERNAL SCM scm_unmemoize_expression (SCM memoized);
SCM_API SCM scm_memoized_p (SCM obj);
SCM_INTERNAL void scm_init_memoize (void);
#endif /* SCM_MEMOIZE_H */
/*
Local Variables:
c-file-style: "gnu"
End:
*/

43
libguile/modules.c
View file

@ -229,28 +229,6 @@ scm_c_export (const char *name, ...)
/* Environments */
SCM
scm_top_level_env (SCM thunk)
{
if (SCM_IMP (thunk))
return SCM_EOL;
else
return scm_cons (thunk, SCM_EOL);
}
SCM
scm_env_top_level (SCM env)
{
while (scm_is_pair (env))
{
SCM car_env = SCM_CAR (env);
if (!scm_is_pair (car_env) && scm_is_true (scm_procedure_p (car_env)))
return car_env;
env = SCM_CDR (env);
}
return SCM_BOOL_F;
}
SCM_SYMBOL (sym_module, "module");
SCM
@ -275,15 +253,6 @@ scm_lookup_closure_module (SCM proc)
}
}
SCM_DEFINE (scm_env_module, "env-module", 1, 0, 0,
(SCM env),
"Return the module of @var{ENV}, a lexical environment.")
#define FUNC_NAME s_scm_env_module
{
return scm_lookup_closure_module (scm_env_top_level (env));
}
#undef FUNC_NAME
/*
* C level implementation of the standard eval closure
*
@ -878,18 +847,6 @@ SCM_DEFINE (scm_get_pre_modules_obarray, "%get-pre-modules-obarray", 0, 0, 0,
SCM_SYMBOL (scm_sym_system_module, "system-module");
SCM
scm_system_module_env_p (SCM env)
{
SCM proc = scm_env_top_level (env);
if (scm_is_false (proc))
return SCM_BOOL_T;
return ((scm_is_true (scm_procedure_property (proc,
scm_sym_system_module)))
? SCM_BOOL_T
: SCM_BOOL_F);
}
void
scm_modules_prehistory ()
{

5
libguile/modules.h
View file

@ -115,11 +115,6 @@ SCM_API SCM scm_eval_closure_module (SCM eval_closure); /* deprecated already */
SCM_API SCM scm_get_pre_modules_obarray (void);
SCM_API SCM scm_lookup_closure_module (SCM proc);
SCM_API SCM scm_env_top_level (SCM env);
SCM_API SCM scm_env_module (SCM env);
SCM_API SCM scm_top_level_env (SCM thunk);
SCM_API SCM scm_system_module_env_p (SCM env);
SCM_INTERNAL void scm_modules_prehistory (void);
SCM_INTERNAL void scm_init_modules (void);

24
libguile/print.c
View file

@ -523,14 +523,6 @@ iprin1 (SCM exp, SCM port, scm_print_state *pstate)
{
scm_puts (iflagnames [SCM_IFLAGNUM (exp)], port);
}
else if (SCM_ISYMP (exp))
{
scm_i_print_isym (exp, port);
}
else if (SCM_ILOCP (exp))
{
scm_i_print_iloc (exp, port);
}
else
{
/* unknown immediate value */
@ -574,22 +566,14 @@ iprin1 (SCM exp, SCM port, scm_print_state *pstate)
|| scm_is_false (scm_printer_apply (SCM_PRINT_CLOSURE,
exp, port, pstate)))
{
SCM formals = SCM_CLOSURE_FORMALS (exp);
scm_puts ("#<procedure", port);
scm_putc (' ', port);
scm_iprin1 (scm_procedure_name (exp), port, pstate);
scm_putc (' ', port);
if (SCM_PRINT_SOURCE_P)
{
SCM env = SCM_ENV (exp);
SCM xenv = SCM_EXTEND_ENV (formals, SCM_EOL, env);
SCM src = scm_i_unmemocopy_body (SCM_CODE (exp), xenv);
ENTER_NESTED_DATA (pstate, exp, circref);
scm_iprin1 (src, port, pstate);
EXIT_NESTED_DATA (pstate);
}
else
scm_iprin1 (formals, port, pstate);
scm_iprin1
(scm_cons (SCM_I_MAKINUM (SCM_CLOSURE_NUM_REQUIRED_ARGS (exp)),
scm_from_bool (SCM_CLOSURE_HAS_REST_ARGS (exp))),
port, pstate);
scm_putc ('>', port);
}
break;

12
libguile/procprop.c
View file

@ -109,16 +109,8 @@ scm_i_procedure_arity (SCM proc)
proc = SCM_PROCEDURE (proc);
goto loop;
case scm_tcs_closures:
proc = SCM_CLOSURE_FORMALS (proc);
if (scm_is_null (proc))
break;
while (scm_is_pair (proc))
{
++a;
proc = SCM_CDR (proc);
}
if (!scm_is_null (proc))
r = 1;
a = SCM_CLOSURE_NUM_REQUIRED_ARGS (proc);
r = SCM_CLOSURE_HAS_REST_ARGS (proc) ? 1 : 0;
break;
case scm_tcs_struct:
if (SCM_OBJ_CLASS_FLAGS (proc) & SCM_CLASSF_PURE_GENERIC)

2
libguile/procs.c
View file

@ -134,7 +134,7 @@ SCM_DEFINE (scm_thunk_p, "thunk?", 1, 0, 0,
switch (SCM_TYP7 (obj))
{
case scm_tcs_closures:
return scm_from_bool (!scm_is_pair (SCM_CLOSURE_FORMALS (obj)));
return scm_from_bool (SCM_CLOSURE_NUM_REQUIRED_ARGS (obj) == 0);
case scm_tc7_subr_0:
case scm_tc7_subr_1o:
case scm_tc7_lsubr:

5
libguile/procs.h
View file

@ -86,8 +86,9 @@
#define SCM_CLOSUREP(x) (!SCM_IMP(x) && (SCM_TYP3 (x) == scm_tc3_closure))
#define SCM_CLOSCAR(x) SCM_PACK (SCM_CELL_WORD_0 (x) - scm_tc3_closure)
#define SCM_CODE(x) SCM_CAR (SCM_CLOSCAR (x))
#define SCM_CLOSURE_FORMALS(x) SCM_CAR (SCM_CODE (x))
#define SCM_CLOSURE_BODY(x) SCM_CDR (SCM_CODE (x))
#define SCM_CLOSURE_NUM_REQUIRED_ARGS(x) SCM_I_INUM (SCM_CAR (SCM_CODE (x)))
#define SCM_CLOSURE_HAS_REST_ARGS(x) scm_is_true (SCM_CADR (SCM_CODE (x)))
#define SCM_CLOSURE_BODY(x) SCM_CDDR (SCM_CODE (x))
#define SCM_PROCPROPS(x) SCM_CDR (SCM_CLOSCAR (x))
#define SCM_SETPROCPROPS(x, p) SCM_SETCDR (SCM_CLOSCAR (x), p)
#define SCM_ENV(x) SCM_CELL_OBJECT_1 (x)

12
libguile/srcprop.c
View file

@ -180,10 +180,6 @@ SCM_DEFINE (scm_source_properties, "source-properties", 1, 0, 0,
{
SCM p;
SCM_VALIDATE_NIM (1, obj);
if (SCM_MEMOIZEDP (obj))
obj = SCM_MEMOIZED_EXP (obj);
else if (!scm_is_pair (obj))
SCM_WRONG_TYPE_ARG (1, obj);
p = scm_hashq_ref (scm_source_whash, obj, SCM_EOL);
if (SRCPROPSP (p))
return scm_srcprops_to_alist (p);
@ -217,10 +213,6 @@ SCM_DEFINE (scm_source_property, "source-property", 2, 0, 0,
{
SCM p;
SCM_VALIDATE_NIM (1, obj);
if (SCM_MEMOIZEDP (obj))
obj = SCM_MEMOIZED_EXP (obj);
else if (!scm_is_pair (obj))
SCM_WRONG_TYPE_ARG (1, obj);
p = scm_hashq_ref (scm_source_whash, obj, SCM_EOL);
if (!SRCPROPSP (p))
goto alist;
@ -248,10 +240,6 @@ SCM_DEFINE (scm_set_source_property_x, "set-source-property!", 3, 0, 0,
scm_whash_handle h;
SCM p;
SCM_VALIDATE_NIM (1, obj);
if (SCM_MEMOIZEDP (obj))
obj = SCM_MEMOIZED_EXP (obj);
else if (!scm_is_pair (obj))
SCM_WRONG_TYPE_ARG (1, obj);
h = scm_whash_get_handle (scm_source_whash, obj);
if (SCM_WHASHFOUNDP (h))
p = SCM_WHASHREF (scm_source_whash, h);

40
libguile/stacks.c
View file

@ -212,7 +212,6 @@ read_frame (scm_t_debug_frame *dframe, scm_t_ptrdiff offset,
flags |= SCM_FRAMEF_EVAL_ARGS;
}
}
iframe->source = scm_make_memoized (info[0].e.exp, info[0].e.env);
}
else
{
@ -239,16 +238,6 @@ get_applybody ()
#define NEXT_FRAME(iframe, n, quit) \
do { \
if (SCM_MEMOIZEDP (iframe->source) \
&& scm_is_eq (SCM_MEMOIZED_EXP (iframe->source), applybody)) \
{ \
iframe->source = SCM_BOOL_F; \
if (scm_is_false (iframe->proc)) \
{ \
--iframe; \
++n; \
} \
} \
++iframe; \
if (--n == 0) \
goto quit; \
@ -316,8 +305,7 @@ read_frames (scm_t_debug_frame *dframe, scm_t_ptrdiff offset,
}
else
iframe->flags = SCM_UNPACK (SCM_INUM0);
iframe->source = scm_make_memoized (info[0].e.exp,
info[0].e.env);
iframe->source = SCM_BOOL_F;
info -= 2;
NEXT_FRAME (iframe, n, quit);
}
@ -395,31 +383,7 @@ narrow_stack (SCM stack, long inner, SCM inner_key, long outer, SCM outer_key)
{
/* Cut all frames up to user module code */
for (i = 0; inner; ++i, --inner)
{
SCM m = s->frames[i].source;
if (SCM_MEMOIZEDP (m)
&& !SCM_IMP (SCM_MEMOIZED_ENV (m))
&& scm_is_false (scm_system_module_env_p (SCM_MEMOIZED_ENV (m))))
{
/* Back up in order to include any non-source frames */
while (i > 0)
{
m = s->frames[i - 1].source;
if (SCM_MEMOIZEDP (m))
break;
m = s->frames[i - 1].proc;
if (scm_is_true (scm_procedure_p (m))
&& scm_is_true (scm_procedure_property
(m, scm_sym_system_procedure)))
break;
--i;
++inner;
}
break;
}
}
;
}
else
/* Use standard cutting procedure. */

44
libguile/tags.h
View file

@ -307,8 +307,8 @@ typedef scm_t_uintptr scm_t_bits;
* tc8 (for objects with tc3==100):
* 00000-100: special objects ('flags')
* 00001-100: characters
* 00010-100: evaluator byte codes ('isyms')
* 00011-100: evaluator byte codes ('ilocs')
* 00010-100: unused
* 00011-100: unused
*
*
* Summary of type codes on the heap
@ -464,8 +464,8 @@ enum scm_tc8_tags
{
scm_tc8_flag = scm_tc3_imm24 + 0x00, /* special objects ('flags') */
scm_tc8_char = scm_tc3_imm24 + 0x08, /* characters */
scm_tc8_isym = scm_tc3_imm24 + 0x10, /* evaluator byte codes ('isyms') */
scm_tc8_iloc = scm_tc3_imm24 + 0x18 /* evaluator byte codes ('ilocs') */
scm_tc8_unused_0 = scm_tc3_imm24 + 0x10,
scm_tc8_unused_1 = scm_tc3_imm24 + 0x18
};
#define SCM_ITAG8(X) (SCM_UNPACK (X) & 0xff)
@ -586,42 +586,6 @@ enum scm_tc8_tags
#endif /* BUILDING_LIBGUILE */
/* Evaluator byte codes ('immediate symbols'). These constants are used only
* in eval but their values have to be allocated here. The indices of the
* SCM_IM_ symbols must agree with the declarations in eval.c:
* scm_isymnames. */
#define SCM_ISYMP(n) (SCM_ITAG8 (n) == scm_tc8_isym)
#define SCM_MAKISYM(n) SCM_MAKE_ITAG8 ((n), scm_tc8_isym)
#define SCM_IM_AND SCM_MAKISYM (0)
#define SCM_IM_BEGIN SCM_MAKISYM (1)
#define SCM_IM_CASE SCM_MAKISYM (2)
#define SCM_IM_COND SCM_MAKISYM (3)
#define SCM_IM_DO SCM_MAKISYM (4)
#define SCM_IM_IF SCM_MAKISYM (5)
#define SCM_IM_LAMBDA SCM_MAKISYM (6)
#define SCM_IM_LET SCM_MAKISYM (7)
#define SCM_IM_LETSTAR SCM_MAKISYM (8)
#define SCM_IM_LETREC SCM_MAKISYM (9)
#define SCM_IM_OR SCM_MAKISYM (10)
#define SCM_IM_QUOTE SCM_MAKISYM (11)
#define SCM_IM_SET_X SCM_MAKISYM (12)
#define SCM_IM_DEFINE SCM_MAKISYM (13)
#define SCM_IM_APPLY SCM_MAKISYM (14)
#define SCM_IM_CONT SCM_MAKISYM (15)
#define SCM_IM_DISPATCH SCM_MAKISYM (16)
#define SCM_IM_SLOT_REF SCM_MAKISYM (17)
#define SCM_IM_SLOT_SET_X SCM_MAKISYM (18)
#define SCM_IM_DELAY SCM_MAKISYM (19)
#define SCM_IM_CALL_WITH_VALUES SCM_MAKISYM (20)
#define SCM_IM_ELSE SCM_MAKISYM (21)
#define SCM_IM_ARROW SCM_MAKISYM (22)
#define SCM_IM_NIL_COND SCM_MAKISYM (23) /* Multi-language support */
#define SCM_IM_BIND SCM_MAKISYM (24) /* Multi-language support */
/* Dispatching aids:
When switching on SCM_TYP7 of a SCM value, use these fake case

2
libguile/validate.h
View file

@ -294,7 +294,7 @@
#define SCM_VALIDATE_VARIABLE(pos, var) SCM_MAKE_VALIDATE_MSG (pos, var, VARIABLEP, "variable")
#define SCM_VALIDATE_MEMOIZED(pos, obj) SCM_MAKE_VALIDATE_MSG (pos, obj, MEMOIZEDP, "memoized code")
#define SCM_VALIDATE_MEMOIZED(pos, obj) SCM_MAKE_VALIDATE_MSG (pos, obj, MEMOIZED_P, "memoized code")
#define SCM_VALIDATE_CLOSURE(pos, obj) SCM_MAKE_VALIDATE_MSG (pos, obj, CLOSUREP, "closure")

1
module/ice-9/boot-9.scm
View file

@ -68,6 +68,7 @@
(define pk peek)
(define (warn . stuff)
(with-output-to-port (current-error-port)
(lambda ()

5
module/ice-9/deprecated.scm
View file

@ -202,3 +202,8 @@
x)))
(else
(error "#y needs to be followed by a list" x))))))
(define (unmemoize-expr . args)
(issue-deprecation-warning
"`unmemoize-expr' is deprecated. Use `unmemoize-expression' instead.")
(apply unmemoize-expression args))

9
module/ice-9/psyntax-pp.scm
View file

@ -11741,8 +11741,7 @@
#{x\ 4298}#))))
(define do
(make-extended-syncase-macro
(module-ref (current-module) (quote do))
(make-syncase-macro
'macro
(lambda (#{orig-x\ 4321}#)
((lambda (#{tmp\ 4322}#)
@ -12351,8 +12350,7 @@
#{orig-x\ 4321}#))))
(define quasiquote
(make-extended-syncase-macro
(module-ref (current-module) (quote quasiquote))
(make-syncase-macro
'macro
(letrec ((#{quasicons\ 4358}#
(lambda (#{x\ 4362}# #{y\ 4363}#)
@ -13506,8 +13504,7 @@
#{x\ 4458}#))))
(define case
(make-extended-syncase-macro
(module-ref (current-module) (quote case))
(make-syncase-macro
'macro
(lambda (#{x\ 4463}#)
((lambda (#{tmp\ 4464}#)

2
test-suite/tests/chars.test
View file

@ -36,7 +36,7 @@
;; The following test makes sure that the evaluator distinguishes between
;; evaluator-internal instruction codes and characters.
(pass-if-exception "evaluating chars"
exception:wrong-type-to-apply
exception:wrong-type-arg
(eval '(#\0) (interaction-environment))))
(with-test-prefix "comparisons"

7
test-suite/tests/eval.test
View file

@ -228,10 +228,10 @@
(with-test-prefix "define set procedure-name"
(pass-if "closure"
(expect-fail "closure"
(eq? 'foo-closure (procedure-name bar-closure)))
(pass-if "procedure-with-setter"
(expect-fail "procedure-with-setter"
(eq? 'foo-pws (procedure-name bar-pws))))
(if old-procnames-flag
@ -343,6 +343,7 @@
;; The subr involving the error must appear exactly once on the stack.
(catch 'result
(lambda ()
(throw 'unresolved)
(start-stack 'foo
(lazy-catch 'wrong-type-arg
(lambda ()
@ -367,6 +368,7 @@
;; application.
(catch 'result
(lambda ()
(throw 'unresolved)
(start-stack 'foo
(lazy-catch 'wrong-type-arg
(lambda ()
@ -389,6 +391,7 @@
;; correct.
(catch 'result
(lambda ()
(throw 'unresolved)
(start-stack 'foo
(lazy-catch 'wrong-type-arg
(lambda ()

167
test-suite/tests/syntax.test
View file

@ -129,30 +129,6 @@
(pass-if "legal (begin)"
(eval '(begin (begin) #t) (interaction-environment)))
(with-test-prefix "unmemoization"
;; FIXME. I have no idea why, but the expander is filling in (if #f
;; #f) as the second arm of the if, if the second arm is missing. I
;; thought I made it not do that. But in the meantime, let's adapt,
;; since that's not what we're testing.
(pass-if "normal begin"
(let ((foo (lambda () (if (= 1 1) (begin (+ 1) (+ 2)) #f))))
(equal? (procedure-source foo)
'(lambda () (if (= 1 1) (begin (+ 1) (+ 2)) #f)))))
(pass-if "redundant nested begin"
(let ((foo (lambda () (if (= 1 1) (begin (+ 1) (begin (+ 2) (+ 3))) #f))))
(foo) ; make sure, memoization has been performed
(equal? (procedure-source foo)
'(lambda () (if (= 1 1) (begin (+ 1) (begin (+ 2) (+ 3))) #f)))))
(pass-if "redundant begin at start of body"
(let ((foo (lambda () (begin (+ 1) (+ 2))))) ; should be optimized
(foo) ; make sure, memoization has been performed
(equal? (procedure-source foo)
'(lambda () (begin (+ 1) (+ 2)))))))
(pass-if-exception "illegal (begin)"
exception:generic-syncase-error
(eval '(begin (if #t (begin)) #t) (interaction-environment))))
@ -170,18 +146,6 @@
(with-test-prefix "lambda"
(with-test-prefix "unmemoization"
(pass-if "normal lambda"
(let ((foo (lambda () (lambda (x y) (+ x y)))))
(matches? (procedure-source foo)
(lambda () (lambda (_ _) (+ _ _))))))
(pass-if "lambda with documentation"
(let ((foo (lambda () (lambda (x y) "docstring" (+ x y)))))
(matches? (procedure-source foo)
(lambda () (lambda (_ _) "docstring" (+ _ _)))))))
(with-test-prefix "bad formals"
(pass-if-exception "(lambda)"
@ -247,13 +211,6 @@
(with-test-prefix "let"
(with-test-prefix "unmemoization"
(pass-if "normal let"
(let ((foo (lambda () (let ((i 1) (j 2)) (+ i j)))))
(matches? (procedure-source foo)
(lambda () (let ((_ 1) (_ 2)) (+ _ _)))))))
(with-test-prefix "bindings"
(pass-if-exception "late binding"
@ -350,21 +307,6 @@
(with-test-prefix "let*"
(with-test-prefix "unmemoization"
(pass-if "normal let*"
(let ((foo (lambda () (let* ((x 1) (y 2)) (+ x y)))))
(matches? (procedure-source foo)
(lambda () (let ((_ 1)) (let ((_ 2)) (+ _ _)))))))
(pass-if "let* without bindings"
(let ((foo (lambda () (let ((x 1) (y 2))
(let* ()
(and (= x 1) (= y 2)))))))
(matches? (procedure-source foo)
(lambda () (let ((_ 1) (_ 2))
(if (= _ 1) (= _ 2) #f)))))))
(with-test-prefix "bindings"
(pass-if "(let* ((x 1) (x 2)) ...)"
@ -441,13 +383,6 @@
(with-test-prefix "letrec"
(with-test-prefix "unmemoization"
(pass-if "normal letrec"
(let ((foo (lambda () (letrec ((i 1) (j 2)) (+ i j)))))
(matches? (procedure-source foo)
(lambda () (letrec ((_ 1) (_ 2)) (+ _ _)))))))
(with-test-prefix "bindings"
(pass-if-exception "initial bindings are undefined"
@ -523,28 +458,6 @@
(with-test-prefix "if"
(with-test-prefix "unmemoization"
(pass-if "normal if"
(let ((foo (lambda (x) (if x (+ 1) (+ 2)))))
(foo #t) ; make sure, memoization has been performed
(foo #f) ; make sure, memoization has been performed
(matches? (procedure-source foo)
(lambda (_) (if _ (+ 1) (+ 2))))))
(expect-fail "if without else"
(let ((foo (lambda (x) (if x (+ 1)))))
(foo #t) ; make sure, memoization has been performed
(foo #f) ; make sure, memoization has been performed
(equal? (procedure-source foo)
'(lambda (x) (if x (+ 1))))))
(expect-fail "if #f without else"
(let ((foo (lambda () (if #f #f))))
(foo) ; make sure, memoization has been performed
(equal? (procedure-source foo)
`(lambda () (if #f #f))))))
(with-test-prefix "missing or extra expressions"
(pass-if-exception "(if)"
@ -622,26 +535,6 @@
'(syntax-error . "cond: wrong number of receiver expressions")
(cond (#t identity => identity identity))))
(with-test-prefix "unmemoization"
;; FIXME: the (if #f #f) is a hack!
(pass-if "normal clauses"
(let ((foo (lambda () (cond ((= x 1) 'bar) ((= x 2) 'baz)))))
(equal? (procedure-source foo)
'(lambda () (if (= x 1) 'bar (if (= x 2) 'baz (if #f #f)))))))
(pass-if "else"
(let ((foo (lambda () (cond (else 'bar)))))
(equal? (procedure-source foo)
'(lambda () 'bar))))
;; FIXME: the (if #f #f) is a hack!
(pass-if "=>"
(let ((foo (lambda () (cond (#t => identity)))))
(matches? (procedure-source foo)
(lambda () (let ((_ #t))
(if _ (identity _) (if #f #f))))))))
(with-test-prefix "bad or missing clauses"
(pass-if-exception "(cond)"
@ -707,28 +600,6 @@
(eval '(let ((else #f)) (case 1 (else #f)))
(interaction-environment))))
(with-test-prefix "unmemoization"
(pass-if "normal clauses"
(let ((foo (lambda (x) (case x ((1) 'bar) ((2) 'baz) (else 'foobar)))))
(matches? (procedure-source foo)
(lambda (_)
(if ((@@ (guile) memv) _ '(1))
'bar
(if ((@@ (guile) memv) _ '(2))
'baz
'foobar))))))
(pass-if "empty labels"
(let ((foo (lambda (x) (case x ((1) 'bar) (() 'baz) (else 'foobar)))))
(matches? (procedure-source foo)
(lambda (_)
(if ((@@ (guile) memv) _ '(1))
'bar
(if ((@@ (guile) memv) _ '())
'baz
'foobar)))))))
(with-test-prefix "bad or missing clauses"
(pass-if-exception "(case)"
@ -804,23 +675,6 @@
(eval '(define round round) m)
(eq? (module-ref m 'round) round)))
(with-test-prefix "unmemoization"
(pass-if "definition unmemoized without prior execution"
(primitive-eval '(begin
(define (blub) (cons ('(1 . 2)) 2))
(equal?
(procedure-source blub)
'(lambda () (cons ('(1 . 2)) 2))))))
(pass-if "definition with documentation unmemoized without prior execution"
(primitive-eval '(begin
(define (blub) "Comment" (cons ('(1 . 2)) 2))
(equal?
(procedure-source blub)
'(lambda () "Comment" (cons ('(1 . 2)) 2)))))))
(with-test-prefix "missing or extra expressions"
(pass-if-exception "(define)"
@ -892,29 +746,10 @@
(pass-if-exception "missing body expression"
exception:missing-body-expr
(eval '(let () (define x #t))
(interaction-environment)))
(pass-if "unmemoization"
(primitive-eval '(begin
(define (foo)
(define (bar)
'ok)
(bar))
(foo)
(matches?
(procedure-source foo)
(lambda () (letrec ((_ (lambda () (quote ok)))) (_))))))))
(interaction-environment))))
(with-test-prefix "set!"
(with-test-prefix "unmemoization"
(pass-if "normal set!"
(let ((foo (lambda (x) (set! x (+ 1 x)))))
(foo 1) ; make sure, memoization has been performed
(matches? (procedure-source foo)
(lambda (_) (set! _ (+ 1 _)))))))
(with-test-prefix "missing or extra expressions"
(pass-if-exception "(set!)"