mirror of
https://git.savannah.gnu.org/git/guile.git
synced 2025-04-29 19:30:36 +02:00
5804c977d7
* libguile/scm.h (struct scm_thread, scm_thread): Rename from scm_i_thread. * libguile/deprecated.h (scm_i_thread): Add deprecated typedef. * libguile/threads.h: Adapt to renaming. * libguile/intrinsics.h: * libguile/scmsigs.h: * libguile/cache-internal.h: Remove threads.h includes; unnecessary with the forward decl. * libguile/continuations.h: * libguile/gc-inline.h: * libguile/async.h: Adapt scm_thread type name change. * libguile/async.c: * libguile/continuations.c: * libguile/control.c: * libguile/dynstack.c: * libguile/dynwind.c: * libguile/eval.c: * libguile/finalizers.c: * libguile/fluids.c: * libguile/gc.c: * libguile/intrinsics.c: * libguile/load.c: * libguile/memoize.c: * libguile/print.c: * libguile/read.c: * libguile/scmsigs.c: * libguile/script.c: * libguile/stackchk.c: * libguile/stacks.c: * libguile/symbols.c: * libguile/threads.c: * libguile/throw.c: * libguile/vm-engine.c: * libguile/vm.c: Adapt to type name change, and add additional includes as needed.
916 lines
27 KiB
C
916 lines
27 KiB
C
/* Copyright 1995-2015,2018
|
||
Free Software Foundation, Inc.
|
||
|
||
This file is part of Guile.
|
||
|
||
Guile 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.
|
||
|
||
Guile 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 Guile. If not, see
|
||
<https://www.gnu.org/licenses/>. */
|
||
|
||
|
||
|
||
#ifdef HAVE_CONFIG_H
|
||
# include <config.h>
|
||
#endif
|
||
|
||
#include <string.h>
|
||
#include <stdio.h>
|
||
|
||
#include "alist.h"
|
||
#include "boolean.h"
|
||
#include "continuations.h"
|
||
#include "dynstack.h"
|
||
#include "eq.h"
|
||
#include "expand.h"
|
||
#include "gsubr.h"
|
||
#include "list.h"
|
||
#include "macros.h"
|
||
#include "modules.h"
|
||
#include "numbers.h"
|
||
#include "pairs.h"
|
||
#include "ports.h"
|
||
#include "print.h"
|
||
#include "srcprop.h"
|
||
#include "strings.h"
|
||
#include "symbols.h"
|
||
#include "threads.h"
|
||
#include "throw.h"
|
||
#include "variable.h"
|
||
#include "vectors.h"
|
||
|
||
#include "memoize.h"
|
||
|
||
|
||
|
||
|
||
|
||
#define CAR(x) SCM_CAR(x)
|
||
#define CDR(x) SCM_CDR(x)
|
||
#define CAAR(x) SCM_CAAR(x)
|
||
#define CADR(x) SCM_CADR(x)
|
||
#define CDAR(x) SCM_CDAR(x)
|
||
#define CDDR(x) SCM_CDDR(x)
|
||
#define CADDR(x) SCM_CADDR(x)
|
||
#define CDDDR(x) SCM_CDDDR(x)
|
||
#define CADDDR(x) SCM_CADDDR(x)
|
||
|
||
#define VECTOR_REF(v, i) (SCM_SIMPLE_VECTOR_REF (v, i))
|
||
#define VECTOR_SET(v, i, x) (SCM_SIMPLE_VECTOR_SET (v, i, x))
|
||
#define VECTOR_LENGTH(v) (SCM_SIMPLE_VECTOR_LENGTH (v))
|
||
|
||
SCM_SYMBOL (sym_case_lambda_star, "case-lambda*");
|
||
|
||
|
||
|
||
|
||
/* Primitives not exposed to general Scheme. */
|
||
static SCM wind;
|
||
static SCM unwind;
|
||
static SCM push_fluid;
|
||
static SCM pop_fluid;
|
||
static SCM push_dynamic_state;
|
||
static SCM pop_dynamic_state;
|
||
|
||
static SCM
|
||
do_wind (SCM in, SCM out)
|
||
{
|
||
scm_dynstack_push_dynwind (&SCM_I_CURRENT_THREAD->dynstack, in, out);
|
||
return SCM_UNSPECIFIED;
|
||
}
|
||
|
||
static SCM
|
||
do_unwind (void)
|
||
{
|
||
scm_dynstack_pop (&SCM_I_CURRENT_THREAD->dynstack);
|
||
return SCM_UNSPECIFIED;
|
||
}
|
||
|
||
static SCM
|
||
do_push_fluid (SCM fluid, SCM val)
|
||
{
|
||
scm_thread *thread = SCM_I_CURRENT_THREAD;
|
||
scm_dynstack_push_fluid (&thread->dynstack, fluid, val,
|
||
thread->dynamic_state);
|
||
return SCM_UNSPECIFIED;
|
||
}
|
||
|
||
static SCM
|
||
do_pop_fluid (void)
|
||
{
|
||
scm_thread *thread = SCM_I_CURRENT_THREAD;
|
||
scm_dynstack_unwind_fluid (&thread->dynstack, thread->dynamic_state);
|
||
return SCM_UNSPECIFIED;
|
||
}
|
||
|
||
static SCM
|
||
do_push_dynamic_state (SCM state)
|
||
{
|
||
scm_thread *thread = SCM_I_CURRENT_THREAD;
|
||
scm_dynstack_push_dynamic_state (&thread->dynstack, state,
|
||
thread->dynamic_state);
|
||
return SCM_UNSPECIFIED;
|
||
}
|
||
|
||
static SCM
|
||
do_pop_dynamic_state (void)
|
||
{
|
||
scm_thread *thread = SCM_I_CURRENT_THREAD;
|
||
scm_dynstack_unwind_dynamic_state (&thread->dynstack,
|
||
thread->dynamic_state);
|
||
return SCM_UNSPECIFIED;
|
||
}
|
||
|
||
|
||
|
||
|
||
/* {Evaluator memoized expressions}
|
||
*/
|
||
|
||
scm_t_bits scm_tc16_memoized;
|
||
|
||
#define MAKMEMO(n, args) \
|
||
(scm_cons (SCM_I_MAKINUM (n), args))
|
||
|
||
#define MAKMEMO_SEQ(head,tail) \
|
||
MAKMEMO (SCM_M_SEQ, scm_cons (head, tail))
|
||
#define MAKMEMO_IF(test, then, else_) \
|
||
MAKMEMO (SCM_M_IF, scm_cons (test, scm_cons (then, else_)))
|
||
#define FIXED_ARITY(nreq) \
|
||
scm_list_1 (SCM_I_MAKINUM (nreq))
|
||
#define REST_ARITY(nreq, rest) \
|
||
scm_list_2 (SCM_I_MAKINUM (nreq), rest)
|
||
#define FULL_ARITY(nreq, rest, nopt, kw, ninits, unbound, alt) \
|
||
scm_list_n (SCM_I_MAKINUM (nreq), rest, SCM_I_MAKINUM (nopt), kw, \
|
||
SCM_I_MAKINUM (ninits), unbound, alt, SCM_UNDEFINED)
|
||
#define MAKMEMO_LAMBDA(body, arity, meta) \
|
||
MAKMEMO (SCM_M_LAMBDA, \
|
||
scm_cons (body, scm_cons (meta, arity)))
|
||
#define MAKMEMO_CAPTURE_ENV(vars, body) \
|
||
MAKMEMO (SCM_M_CAPTURE_ENV, scm_cons (vars, body))
|
||
#define MAKMEMO_LET(inits, body) \
|
||
MAKMEMO (SCM_M_LET, scm_cons (inits, body))
|
||
#define MAKMEMO_QUOTE(exp) \
|
||
MAKMEMO (SCM_M_QUOTE, exp)
|
||
#define MAKMEMO_CAPTURE_MODULE(exp) \
|
||
MAKMEMO (SCM_M_CAPTURE_MODULE, exp)
|
||
#define MAKMEMO_APPLY(proc, args)\
|
||
MAKMEMO (SCM_M_APPLY, scm_list_2 (proc, args))
|
||
#define MAKMEMO_CONT(proc) \
|
||
MAKMEMO (SCM_M_CONT, proc)
|
||
#define MAKMEMO_CALL_WITH_VALUES(prod, cons) \
|
||
MAKMEMO (SCM_M_CALL_WITH_VALUES, scm_cons (prod, cons))
|
||
#define MAKMEMO_CALL(proc, args) \
|
||
MAKMEMO (SCM_M_CALL, scm_cons (proc, args))
|
||
#define MAKMEMO_LEX_REF(pos) \
|
||
MAKMEMO (SCM_M_LEXICAL_REF, pos)
|
||
#define MAKMEMO_LEX_SET(pos, val) \
|
||
MAKMEMO (SCM_M_LEXICAL_SET, scm_cons (pos, val))
|
||
#define MAKMEMO_BOX_REF(box) \
|
||
MAKMEMO (SCM_M_BOX_REF, box)
|
||
#define MAKMEMO_BOX_SET(box, val) \
|
||
MAKMEMO (SCM_M_BOX_SET, scm_cons (box, val))
|
||
#define MAKMEMO_TOP_BOX(mode, var) \
|
||
MAKMEMO (SCM_M_RESOLVE, scm_cons (SCM_I_MAKINUM (mode), var))
|
||
#define MAKMEMO_MOD_BOX(mode, mod, var, public) \
|
||
MAKMEMO (SCM_M_RESOLVE, \
|
||
scm_cons (SCM_I_MAKINUM (mode), \
|
||
scm_cons (mod, scm_cons (var, public))))
|
||
#define MAKMEMO_CALL_WITH_PROMPT(tag, thunk, handler) \
|
||
MAKMEMO (SCM_M_CALL_WITH_PROMPT, scm_cons (tag, scm_cons (thunk, handler)))
|
||
|
||
|
||
|
||
|
||
/* This table must agree with the list of M_ constants in memoize.h */
|
||
static const char *const memoized_tags[] =
|
||
{
|
||
"seq",
|
||
"if",
|
||
"lambda",
|
||
"capture-env",
|
||
"let",
|
||
"quote",
|
||
"capture-module",
|
||
"apply",
|
||
"call/cc",
|
||
"call-with-values",
|
||
"call",
|
||
"lexical-ref",
|
||
"lexical-set!",
|
||
"box-ref",
|
||
"box-set!",
|
||
"resolve",
|
||
"call-with-prompt",
|
||
};
|
||
|
||
|
||
|
||
|
||
|
||
/* Memoization-time environments mirror the structure of eval-time
|
||
environments. Each link in the chain at memoization-time corresponds
|
||
to a link at eval-time.
|
||
|
||
env := module | (link, env)
|
||
module := #f | #t
|
||
link := flat-link . nested-link
|
||
flat-link := (#t . ((var . pos) ...))
|
||
nested-link := (#f . #(var ...))
|
||
|
||
A module of #f indicates that the current module has not yet been
|
||
captured. Memoizing a capture-module expression will capture the
|
||
module.
|
||
|
||
Flat environments copy the values for a set of free variables into a
|
||
flat environment, via the capture-env expression. During memoization
|
||
a flat link collects the values of free variables, along with their
|
||
resolved outer locations. We are able to copy values because the
|
||
incoming expression has already been assignment-converted. Flat
|
||
environments prevent closures from hanging on to too much memory.
|
||
|
||
Nested environments have a rib of "let" bindings, and link to an
|
||
outer environment.
|
||
*/
|
||
|
||
static int
|
||
try_lookup_rib (SCM x, SCM rib)
|
||
{
|
||
int idx = 0;
|
||
for (; idx < VECTOR_LENGTH (rib); idx++)
|
||
if (scm_is_eq (x, VECTOR_REF (rib, idx)))
|
||
return idx; /* bound */
|
||
return -1;
|
||
}
|
||
|
||
static int
|
||
lookup_rib (SCM x, SCM rib)
|
||
{
|
||
int idx = try_lookup_rib (x, rib);
|
||
if (idx < 0)
|
||
abort ();
|
||
return idx;
|
||
}
|
||
|
||
static SCM
|
||
make_pos (int depth, int width)
|
||
{
|
||
return scm_cons (SCM_I_MAKINUM (depth), SCM_I_MAKINUM (width));
|
||
}
|
||
|
||
static SCM
|
||
push_nested_link (SCM vars, SCM env)
|
||
{
|
||
return scm_acons (SCM_BOOL_F, vars, env);
|
||
}
|
||
|
||
static SCM
|
||
push_flat_link (SCM env)
|
||
{
|
||
return scm_acons (SCM_BOOL_T, SCM_EOL, env);
|
||
}
|
||
|
||
static int
|
||
env_link_is_flat (SCM env_link)
|
||
{
|
||
return scm_is_true (CAR (env_link));
|
||
}
|
||
|
||
static SCM
|
||
env_link_vars (SCM env_link)
|
||
{
|
||
return CDR (env_link);
|
||
}
|
||
|
||
static void
|
||
env_link_add_flat_var (SCM env_link, SCM var, SCM pos)
|
||
{
|
||
SCM vars = env_link_vars (env_link);
|
||
if (scm_is_false (scm_assq (var, vars)))
|
||
scm_set_cdr_x (env_link, scm_acons (var, pos, vars));
|
||
}
|
||
|
||
static SCM
|
||
lookup (SCM x, SCM env)
|
||
{
|
||
int d = 0;
|
||
for (; scm_is_pair (env); env = CDR (env), d++)
|
||
{
|
||
SCM link = CAR (env);
|
||
if (env_link_is_flat (link))
|
||
{
|
||
int w;
|
||
SCM vars;
|
||
|
||
for (vars = env_link_vars (link), w = scm_ilength (vars) - 1;
|
||
scm_is_pair (vars);
|
||
vars = CDR (vars), w--)
|
||
if (scm_is_eq (x, (CAAR (vars))))
|
||
return make_pos (d, w);
|
||
|
||
env_link_add_flat_var (link, x, lookup (x, CDR (env)));
|
||
return make_pos (d, scm_ilength (env_link_vars (link)) - 1);
|
||
}
|
||
else
|
||
{
|
||
int w = try_lookup_rib (x, env_link_vars (link));
|
||
if (w < 0)
|
||
continue;
|
||
return make_pos (d, w);
|
||
}
|
||
}
|
||
abort ();
|
||
}
|
||
|
||
static SCM
|
||
capture_flat_env (SCM lambda, SCM env)
|
||
{
|
||
int nenv;
|
||
SCM vars, link, locs;
|
||
|
||
link = CAR (env);
|
||
vars = env_link_vars (link);
|
||
nenv = scm_ilength (vars);
|
||
locs = scm_c_make_vector (nenv, SCM_BOOL_F);
|
||
|
||
for (; scm_is_pair (vars); vars = CDR (vars))
|
||
scm_c_vector_set_x (locs, --nenv, CDAR (vars));
|
||
|
||
return MAKMEMO_CAPTURE_ENV (locs, lambda);
|
||
}
|
||
|
||
/* Abbreviate SCM_EXPANDED_REF. Copied because I'm not sure about symbol pasting */
|
||
#define REF(x,type,field) \
|
||
(scm_struct_ref (x, SCM_I_MAKINUM (SCM_EXPANDED_##type##_##field)))
|
||
|
||
static SCM list_of_guile = SCM_BOOL_F;
|
||
|
||
static SCM memoize (SCM exp, SCM env);
|
||
|
||
static SCM
|
||
memoize_exps (SCM exps, SCM env)
|
||
{
|
||
SCM ret;
|
||
for (ret = SCM_EOL; scm_is_pair (exps); exps = CDR (exps))
|
||
ret = scm_cons (memoize (CAR (exps), env), ret);
|
||
return scm_reverse_x (ret, SCM_UNDEFINED);
|
||
}
|
||
|
||
static SCM
|
||
capture_env (SCM env)
|
||
{
|
||
if (scm_is_false (env))
|
||
return SCM_BOOL_T;
|
||
return env;
|
||
}
|
||
|
||
static SCM
|
||
maybe_makmemo_capture_module (SCM exp, SCM env)
|
||
{
|
||
if (scm_is_false (env))
|
||
return MAKMEMO_CAPTURE_MODULE (exp);
|
||
return exp;
|
||
}
|
||
|
||
static SCM
|
||
memoize (SCM exp, SCM env)
|
||
{
|
||
if (!SCM_EXPANDED_P (exp))
|
||
abort ();
|
||
|
||
switch (SCM_EXPANDED_TYPE (exp))
|
||
{
|
||
case SCM_EXPANDED_VOID:
|
||
return MAKMEMO_QUOTE (SCM_UNSPECIFIED);
|
||
|
||
case SCM_EXPANDED_CONST:
|
||
return MAKMEMO_QUOTE (REF (exp, CONST, EXP));
|
||
|
||
case SCM_EXPANDED_PRIMITIVE_REF:
|
||
if (scm_is_eq (scm_current_module (), scm_the_root_module ()))
|
||
return maybe_makmemo_capture_module
|
||
(MAKMEMO_BOX_REF (MAKMEMO_TOP_BOX (SCM_EXPANDED_TOPLEVEL_REF,
|
||
REF (exp, PRIMITIVE_REF, NAME))),
|
||
env);
|
||
else
|
||
return MAKMEMO_BOX_REF (MAKMEMO_MOD_BOX (SCM_EXPANDED_MODULE_REF,
|
||
list_of_guile,
|
||
REF (exp, PRIMITIVE_REF, NAME),
|
||
SCM_BOOL_F));
|
||
|
||
case SCM_EXPANDED_LEXICAL_REF:
|
||
return MAKMEMO_LEX_REF (lookup (REF (exp, LEXICAL_REF, GENSYM), env));
|
||
|
||
case SCM_EXPANDED_LEXICAL_SET:
|
||
return MAKMEMO_LEX_SET (lookup (REF (exp, LEXICAL_SET, GENSYM), env),
|
||
memoize (REF (exp, LEXICAL_SET, EXP), env));
|
||
|
||
case SCM_EXPANDED_MODULE_REF:
|
||
return MAKMEMO_BOX_REF (MAKMEMO_MOD_BOX
|
||
(SCM_EXPANDED_MODULE_REF,
|
||
REF (exp, MODULE_REF, MOD),
|
||
REF (exp, MODULE_REF, NAME),
|
||
REF (exp, MODULE_REF, PUBLIC)));
|
||
|
||
case SCM_EXPANDED_MODULE_SET:
|
||
return MAKMEMO_BOX_SET (MAKMEMO_MOD_BOX
|
||
(SCM_EXPANDED_MODULE_SET,
|
||
REF (exp, MODULE_SET, MOD),
|
||
REF (exp, MODULE_SET, NAME),
|
||
REF (exp, MODULE_SET, PUBLIC)),
|
||
memoize (REF (exp, MODULE_SET, EXP), env));
|
||
|
||
case SCM_EXPANDED_TOPLEVEL_REF:
|
||
return maybe_makmemo_capture_module
|
||
(MAKMEMO_BOX_REF (MAKMEMO_TOP_BOX (SCM_EXPANDED_TOPLEVEL_REF,
|
||
REF (exp, TOPLEVEL_REF, NAME))),
|
||
env);
|
||
|
||
case SCM_EXPANDED_TOPLEVEL_SET:
|
||
return maybe_makmemo_capture_module
|
||
(MAKMEMO_BOX_SET (MAKMEMO_TOP_BOX (SCM_EXPANDED_TOPLEVEL_SET,
|
||
REF (exp, TOPLEVEL_SET, NAME)),
|
||
memoize (REF (exp, TOPLEVEL_SET, EXP),
|
||
capture_env (env))),
|
||
env);
|
||
|
||
case SCM_EXPANDED_TOPLEVEL_DEFINE:
|
||
return maybe_makmemo_capture_module
|
||
(MAKMEMO_BOX_SET (MAKMEMO_TOP_BOX (SCM_EXPANDED_TOPLEVEL_DEFINE,
|
||
REF (exp, TOPLEVEL_DEFINE, NAME)),
|
||
memoize (REF (exp, TOPLEVEL_DEFINE, EXP),
|
||
capture_env (env))),
|
||
env);
|
||
|
||
case SCM_EXPANDED_CONDITIONAL:
|
||
return MAKMEMO_IF (memoize (REF (exp, CONDITIONAL, TEST), env),
|
||
memoize (REF (exp, CONDITIONAL, CONSEQUENT), env),
|
||
memoize (REF (exp, CONDITIONAL, ALTERNATE), env));
|
||
|
||
case SCM_EXPANDED_CALL:
|
||
{
|
||
SCM proc, args;
|
||
|
||
proc = REF (exp, CALL, PROC);
|
||
args = memoize_exps (REF (exp, CALL, ARGS), env);
|
||
|
||
return MAKMEMO_CALL (memoize (proc, env), args);
|
||
}
|
||
|
||
case SCM_EXPANDED_PRIMCALL:
|
||
{
|
||
SCM name, args;
|
||
int nargs;
|
||
|
||
name = REF (exp, PRIMCALL, NAME);
|
||
args = memoize_exps (REF (exp, PRIMCALL, ARGS), env);
|
||
nargs = scm_ilength (args);
|
||
|
||
if (nargs == 3
|
||
&& scm_is_eq (name, scm_from_latin1_symbol ("call-with-prompt")))
|
||
return MAKMEMO_CALL_WITH_PROMPT (CAR (args),
|
||
CADR (args),
|
||
CADDR (args));
|
||
else if (nargs == 2
|
||
&& scm_is_eq (name, scm_from_latin1_symbol ("apply")))
|
||
return MAKMEMO_APPLY (CAR (args), CADR (args));
|
||
else if (nargs == 1
|
||
&& scm_is_eq (name,
|
||
scm_from_latin1_symbol
|
||
("call-with-current-continuation")))
|
||
return MAKMEMO_CONT (CAR (args));
|
||
else if (nargs == 2
|
||
&& scm_is_eq (name,
|
||
scm_from_latin1_symbol ("call-with-values")))
|
||
return MAKMEMO_CALL_WITH_VALUES (CAR (args), CADR (args));
|
||
else if (nargs == 1
|
||
&& scm_is_eq (name,
|
||
scm_from_latin1_symbol ("variable-ref")))
|
||
return MAKMEMO_BOX_REF (CAR (args));
|
||
else if (nargs == 2
|
||
&& scm_is_eq (name,
|
||
scm_from_latin1_symbol ("variable-set!")))
|
||
return MAKMEMO_BOX_SET (CAR (args), CADR (args));
|
||
else if (nargs == 2
|
||
&& scm_is_eq (name, scm_from_latin1_symbol ("wind")))
|
||
return MAKMEMO_CALL (MAKMEMO_QUOTE (wind), args);
|
||
else if (nargs == 0
|
||
&& scm_is_eq (name, scm_from_latin1_symbol ("unwind")))
|
||
return MAKMEMO_CALL (MAKMEMO_QUOTE (unwind), SCM_EOL);
|
||
else if (nargs == 2
|
||
&& scm_is_eq (name, scm_from_latin1_symbol ("push-fluid")))
|
||
return MAKMEMO_CALL (MAKMEMO_QUOTE (push_fluid), args);
|
||
else if (nargs == 0
|
||
&& scm_is_eq (name, scm_from_latin1_symbol ("pop-fluid")))
|
||
return MAKMEMO_CALL (MAKMEMO_QUOTE (pop_fluid), SCM_EOL);
|
||
else if (nargs == 1
|
||
&& scm_is_eq (name,
|
||
scm_from_latin1_symbol ("push-dynamic-state")))
|
||
return MAKMEMO_CALL (MAKMEMO_QUOTE (push_dynamic_state), args);
|
||
else if (nargs == 0
|
||
&& scm_is_eq (name,
|
||
scm_from_latin1_symbol ("pop-dynamic-state")))
|
||
return MAKMEMO_CALL (MAKMEMO_QUOTE (pop_dynamic_state), SCM_EOL);
|
||
else if (scm_is_eq (scm_current_module (), scm_the_root_module ()))
|
||
return MAKMEMO_CALL (maybe_makmemo_capture_module
|
||
(MAKMEMO_BOX_REF
|
||
(MAKMEMO_TOP_BOX (SCM_EXPANDED_TOPLEVEL_REF,
|
||
name)),
|
||
env),
|
||
args);
|
||
else
|
||
return MAKMEMO_CALL (MAKMEMO_BOX_REF
|
||
(MAKMEMO_MOD_BOX (SCM_EXPANDED_MODULE_REF,
|
||
list_of_guile,
|
||
name,
|
||
SCM_BOOL_F)),
|
||
args);
|
||
}
|
||
|
||
case SCM_EXPANDED_SEQ:
|
||
return MAKMEMO_SEQ (memoize (REF (exp, SEQ, HEAD), env),
|
||
memoize (REF (exp, SEQ, TAIL), env));
|
||
|
||
case SCM_EXPANDED_LAMBDA:
|
||
/* The body will be a lambda-case. */
|
||
{
|
||
SCM meta, body, proc, new_env;
|
||
|
||
meta = REF (exp, LAMBDA, META);
|
||
body = REF (exp, LAMBDA, BODY);
|
||
new_env = push_flat_link (capture_env (env));
|
||
proc = memoize (body, new_env);
|
||
SCM_SETCAR (SCM_CDR (SCM_MEMOIZED_ARGS (proc)), meta);
|
||
|
||
return maybe_makmemo_capture_module (capture_flat_env (proc, new_env),
|
||
env);
|
||
}
|
||
|
||
case SCM_EXPANDED_LAMBDA_CASE:
|
||
{
|
||
SCM req, rest, opt, kw, inits, vars, body, alt;
|
||
SCM unbound, arity, rib, new_env;
|
||
int nreq, nopt, ninits;
|
||
|
||
req = REF (exp, LAMBDA_CASE, REQ);
|
||
rest = scm_not (scm_not (REF (exp, LAMBDA_CASE, REST)));
|
||
opt = REF (exp, LAMBDA_CASE, OPT);
|
||
kw = REF (exp, LAMBDA_CASE, KW);
|
||
inits = REF (exp, LAMBDA_CASE, INITS);
|
||
vars = REF (exp, LAMBDA_CASE, GENSYMS);
|
||
body = REF (exp, LAMBDA_CASE, BODY);
|
||
alt = REF (exp, LAMBDA_CASE, ALTERNATE);
|
||
|
||
nreq = scm_ilength (req);
|
||
nopt = scm_is_pair (opt) ? scm_ilength (opt) : 0;
|
||
ninits = scm_ilength (inits);
|
||
/* This relies on assignment conversion turning inits into a
|
||
sequence of CONST expressions whose values are a unique
|
||
"unbound" token. */
|
||
unbound = ninits ? REF (CAR (inits), CONST, EXP) : SCM_BOOL_F;
|
||
rib = scm_vector (vars);
|
||
new_env = push_nested_link (rib, env);
|
||
|
||
if (scm_is_true (kw))
|
||
{
|
||
/* (aok? (kw name sym) ...) -> (aok? (kw . index) ...) */
|
||
SCM aok = CAR (kw), indices = SCM_EOL;
|
||
for (kw = CDR (kw); scm_is_pair (kw); kw = CDR (kw))
|
||
{
|
||
SCM k;
|
||
int idx;
|
||
|
||
k = CAR (CAR (kw));
|
||
idx = lookup_rib (CADDR (CAR (kw)), rib);
|
||
indices = scm_acons (k, SCM_I_MAKINUM (idx), indices);
|
||
}
|
||
kw = scm_cons (aok, scm_reverse_x (indices, SCM_UNDEFINED));
|
||
}
|
||
|
||
if (scm_is_false (alt) && scm_is_false (kw) && scm_is_false (opt))
|
||
{
|
||
if (scm_is_false (rest))
|
||
arity = FIXED_ARITY (nreq);
|
||
else
|
||
arity = REST_ARITY (nreq, SCM_BOOL_T);
|
||
}
|
||
else if (scm_is_true (alt))
|
||
arity = FULL_ARITY (nreq, rest, nopt, kw, ninits, unbound,
|
||
SCM_MEMOIZED_ARGS (memoize (alt, env)));
|
||
else
|
||
arity = FULL_ARITY (nreq, rest, nopt, kw, ninits, unbound,
|
||
SCM_BOOL_F);
|
||
|
||
return MAKMEMO_LAMBDA (memoize (body, new_env), arity,
|
||
SCM_EOL /* meta, filled in later */);
|
||
}
|
||
|
||
case SCM_EXPANDED_LET:
|
||
{
|
||
SCM vars, exps, body, varsv, inits, new_env;
|
||
int i;
|
||
|
||
vars = REF (exp, LET, GENSYMS);
|
||
exps = REF (exp, LET, VALS);
|
||
body = REF (exp, LET, BODY);
|
||
|
||
varsv = scm_vector (vars);
|
||
inits = scm_c_make_vector (VECTOR_LENGTH (varsv),
|
||
SCM_BOOL_F);
|
||
new_env = push_nested_link (varsv, capture_env (env));
|
||
for (i = 0; scm_is_pair (exps); exps = CDR (exps), i++)
|
||
VECTOR_SET (inits, i, memoize (CAR (exps), env));
|
||
|
||
return maybe_makmemo_capture_module
|
||
(MAKMEMO_LET (inits, memoize (body, new_env)), env);
|
||
}
|
||
|
||
default:
|
||
abort ();
|
||
}
|
||
}
|
||
|
||
|
||
|
||
|
||
SCM_DEFINE (scm_memoize_expression, "memoize-expression", 1, 0, 0,
|
||
(SCM exp),
|
||
"Memoize the expression @var{exp}.")
|
||
#define FUNC_NAME s_scm_memoize_expression
|
||
{
|
||
SCM_ASSERT_TYPE (SCM_EXPANDED_P (exp), exp, 1, FUNC_NAME, "expanded");
|
||
return memoize (scm_convert_assignment (exp), SCM_BOOL_F);
|
||
}
|
||
#undef FUNC_NAME
|
||
|
||
|
||
|
||
|
||
SCM_SYMBOL (sym_placeholder, "_");
|
||
|
||
static SCM unmemoize (SCM expr);
|
||
|
||
static SCM
|
||
unmemoize_exprs (SCM exprs)
|
||
{
|
||
SCM ret, tail;
|
||
if (scm_is_null (exprs))
|
||
return SCM_EOL;
|
||
ret = scm_list_1 (unmemoize (CAR (exprs)));
|
||
tail = ret;
|
||
for (exprs = CDR (exprs); !scm_is_null (exprs); exprs = CDR (exprs))
|
||
{
|
||
SCM_SETCDR (tail, scm_list_1 (unmemoize (CAR (exprs))));
|
||
tail = CDR (tail);
|
||
}
|
||
return ret;
|
||
}
|
||
|
||
static SCM
|
||
unmemoize_bindings (SCM inits)
|
||
{
|
||
SCM ret = SCM_EOL;
|
||
int n = scm_c_vector_length (inits);
|
||
|
||
while (n--)
|
||
ret = scm_cons (unmemoize (scm_c_vector_ref (inits, n)), ret);
|
||
|
||
return ret;
|
||
}
|
||
|
||
static SCM
|
||
unmemoize_lexical (SCM n)
|
||
{
|
||
char buf[32];
|
||
buf[31] = 0;
|
||
snprintf (buf, 31, "<%u,%u>", scm_to_uint32 (CAR (n)),
|
||
scm_to_uint32 (CDR (n)));
|
||
return scm_from_utf8_symbol (buf);
|
||
}
|
||
|
||
static SCM
|
||
unmemoize (const SCM expr)
|
||
{
|
||
SCM args;
|
||
|
||
args = SCM_MEMOIZED_ARGS (expr);
|
||
switch (SCM_MEMOIZED_TAG (expr))
|
||
{
|
||
case SCM_M_APPLY:
|
||
return scm_cons (scm_from_latin1_symbol ("apply"),
|
||
unmemoize_exprs (args));
|
||
case SCM_M_SEQ:
|
||
return scm_list_3 (scm_sym_begin, unmemoize (CAR (args)),
|
||
unmemoize (CDR (args)));
|
||
case SCM_M_CALL:
|
||
return unmemoize_exprs (args);
|
||
case SCM_M_CONT:
|
||
return scm_list_2 (scm_from_latin1_symbol
|
||
("call-with-current_continuation"),
|
||
unmemoize (args));
|
||
case SCM_M_CALL_WITH_VALUES:
|
||
return scm_list_3 (scm_from_latin1_symbol ("call-with-values"),
|
||
unmemoize (CAR (args)), unmemoize (CDR (args)));
|
||
case SCM_M_CAPTURE_MODULE:
|
||
return scm_list_2 (scm_from_latin1_symbol ("capture-module"),
|
||
unmemoize (args));
|
||
case SCM_M_IF:
|
||
return scm_list_4 (scm_sym_if, unmemoize (scm_car (args)),
|
||
unmemoize (scm_cadr (args)), unmemoize (scm_cddr (args)));
|
||
case SCM_M_LAMBDA:
|
||
{
|
||
SCM body = CAR (args), spec = CDDR (args);
|
||
|
||
if (scm_is_null (CDR (spec)))
|
||
return scm_list_3 (scm_sym_lambda,
|
||
scm_make_list (CAR (spec), sym_placeholder),
|
||
unmemoize (CAR (args)));
|
||
else if (scm_is_null (SCM_CDDR (spec)))
|
||
{
|
||
SCM formals = scm_make_list (CAR (spec), sym_placeholder);
|
||
return scm_list_3 (scm_sym_lambda,
|
||
scm_is_true (CADR (spec))
|
||
? scm_cons_star (sym_placeholder, formals)
|
||
: formals,
|
||
unmemoize (CAR (args)));
|
||
}
|
||
else
|
||
{
|
||
SCM alt, tail;
|
||
|
||
alt = CADDDR (CDDDR (spec));
|
||
if (scm_is_true (alt))
|
||
tail = CDR (unmemoize (alt));
|
||
else
|
||
tail = SCM_EOL;
|
||
|
||
return scm_cons
|
||
(sym_case_lambda_star,
|
||
scm_cons (scm_list_2 (scm_list_5 (CAR (spec),
|
||
CADR (spec),
|
||
CADDR (spec),
|
||
CADDDR (spec),
|
||
CADR (CDDDR (spec))),
|
||
unmemoize (body)),
|
||
tail));
|
||
}
|
||
}
|
||
case SCM_M_CAPTURE_ENV:
|
||
return scm_list_3 (scm_from_latin1_symbol ("capture-env"),
|
||
CAR (args),
|
||
unmemoize (CDR (args)));
|
||
case SCM_M_LET:
|
||
return scm_list_3 (scm_sym_let,
|
||
unmemoize_bindings (CAR (args)),
|
||
unmemoize (CDR (args)));
|
||
case SCM_M_QUOTE:
|
||
return scm_list_2 (scm_sym_quote, args);
|
||
case SCM_M_LEXICAL_REF:
|
||
return unmemoize_lexical (args);
|
||
case SCM_M_LEXICAL_SET:
|
||
return scm_list_3 (scm_sym_set_x, unmemoize_lexical (CAR (args)),
|
||
unmemoize (CDR (args)));
|
||
case SCM_M_BOX_REF:
|
||
return scm_list_2 (scm_from_latin1_symbol ("variable-ref"),
|
||
unmemoize (args));
|
||
case SCM_M_BOX_SET:
|
||
return scm_list_3 (scm_from_latin1_symbol ("variable-set!"),
|
||
unmemoize (CAR (args)),
|
||
unmemoize (CDR (args)));
|
||
case SCM_M_RESOLVE:
|
||
if (SCM_VARIABLEP (args))
|
||
return args;
|
||
else if (scm_is_symbol (CDR (args)))
|
||
return CDR (args);
|
||
else
|
||
return scm_list_3
|
||
(scm_is_true (CDDDR (args)) ? scm_sym_at : scm_sym_atat,
|
||
scm_i_finite_list_copy (CADR (args)),
|
||
CADDR (args));
|
||
case SCM_M_CALL_WITH_PROMPT:
|
||
return scm_list_4 (scm_from_latin1_symbol ("call-with-prompt"),
|
||
unmemoize (CAR (args)),
|
||
unmemoize (CADR (args)),
|
||
unmemoize (CDDR (args)));
|
||
default:
|
||
abort ();
|
||
}
|
||
}
|
||
|
||
|
||
|
||
|
||
SCM_DEFINE (scm_unmemoize_expression, "unmemoize-expression", 1, 0, 0,
|
||
(SCM m),
|
||
"Unmemoize the memoized expression @var{m}.")
|
||
#define FUNC_NAME s_scm_unmemoize_expression
|
||
{
|
||
return unmemoize (m);
|
||
}
|
||
#undef FUNC_NAME
|
||
|
||
SCM_DEFINE (scm_memoized_typecode, "memoized-typecode", 1, 0, 0,
|
||
(SCM sym),
|
||
"Return the memoized typecode corresponding to the symbol @var{sym}.")
|
||
#define FUNC_NAME s_scm_memoized_typecode
|
||
{
|
||
int i;
|
||
|
||
SCM_VALIDATE_SYMBOL (1, sym);
|
||
|
||
for (i = 0; i < sizeof(memoized_tags)/sizeof(const char*); i++)
|
||
if (strcmp (scm_i_symbol_chars (sym), memoized_tags[i]) == 0)
|
||
return scm_from_int32 (i);
|
||
|
||
return SCM_BOOL_F;
|
||
}
|
||
#undef FUNC_NAME
|
||
|
||
SCM_SYMBOL (scm_unbound_variable_key, "unbound-variable");
|
||
static void error_unbound_variable (SCM symbol) SCM_NORETURN;
|
||
static void error_unbound_variable (SCM symbol)
|
||
{
|
||
scm_error (scm_unbound_variable_key, NULL, "Unbound variable: ~S",
|
||
scm_list_1 (symbol), SCM_BOOL_F);
|
||
}
|
||
|
||
SCM_DEFINE (scm_sys_resolve_variable, "%resolve-variable", 2, 0, 0,
|
||
(SCM loc, SCM mod),
|
||
"Look up and return the variable for @var{loc}.")
|
||
#define FUNC_NAME s_scm_sys_resolve_variable
|
||
{
|
||
int mode;
|
||
|
||
if (scm_is_false (mod))
|
||
mod = scm_the_root_module ();
|
||
|
||
mode = scm_to_int (scm_car (loc));
|
||
loc = scm_cdr (loc);
|
||
|
||
switch (mode)
|
||
{
|
||
case SCM_EXPANDED_TOPLEVEL_REF:
|
||
case SCM_EXPANDED_TOPLEVEL_SET:
|
||
{
|
||
SCM var = scm_module_variable (mod, loc);
|
||
if (scm_is_false (var)
|
||
|| (mode == SCM_EXPANDED_TOPLEVEL_REF
|
||
&& scm_is_false (scm_variable_bound_p (var))))
|
||
error_unbound_variable (loc);
|
||
return var;
|
||
}
|
||
|
||
case SCM_EXPANDED_TOPLEVEL_DEFINE:
|
||
{
|
||
return scm_module_ensure_local_variable (mod, loc);
|
||
}
|
||
|
||
case SCM_EXPANDED_MODULE_REF:
|
||
case SCM_EXPANDED_MODULE_SET:
|
||
{
|
||
SCM var;
|
||
mod = scm_resolve_module (scm_car (loc));
|
||
if (scm_is_true (scm_cddr (loc)))
|
||
mod = scm_module_public_interface (mod);
|
||
var = scm_module_lookup (mod, scm_cadr (loc));
|
||
if (mode == SCM_EXPANDED_MODULE_SET
|
||
&& scm_is_false (scm_variable_bound_p (var)))
|
||
error_unbound_variable (scm_cadr (loc));
|
||
return var;
|
||
}
|
||
|
||
default:
|
||
scm_wrong_type_arg (FUNC_NAME, 1, loc);
|
||
return SCM_BOOL_F;
|
||
}
|
||
}
|
||
#undef FUNC_NAME
|
||
|
||
|
||
|
||
|
||
void
|
||
scm_init_memoize ()
|
||
{
|
||
#include "memoize.x"
|
||
|
||
wind = scm_c_make_gsubr ("wind", 2, 0, 0, do_wind);
|
||
unwind = scm_c_make_gsubr ("unwind", 0, 0, 0, do_unwind);
|
||
push_fluid = scm_c_make_gsubr ("push-fluid", 2, 0, 0, do_push_fluid);
|
||
pop_fluid = scm_c_make_gsubr ("pop-fluid", 0, 0, 0, do_pop_fluid);
|
||
push_dynamic_state = scm_c_make_gsubr ("push-dynamic_state", 1, 0, 0,
|
||
do_push_dynamic_state);
|
||
pop_dynamic_state = scm_c_make_gsubr ("pop-dynamic_state", 0, 0, 0,
|
||
do_pop_dynamic_state);
|
||
|
||
list_of_guile = scm_list_1 (scm_from_latin1_symbol ("guile"));
|
||
}
|