This is a _preliminary_ patch. In particular:
* The compiler does not yet handle (capture-lexical-environment)
(which uses a new tree-il type).
* The lexical environment object is currently non-opaque list structure.
* I deliberately avoided reindenting eval.scm so that the non-whitespace
changes would be evident, to make review easier.
* I wouldn't be surprised if `primitive-local-eval' does the wrong thing
if (current-module) is different from what it was when the associated
`primitive-eval' was called.
* I manually removed the psyntax-pp.scm patch from the output of
git-format-patch (though the header change summary still mentions it),
since it was so huge. I guess you'll need to manually regenerate that
file yourself, since the Makefiles don't do it automatically:
cd guile/module; make ice-9/psyntax-pp.scm.gen
Here's an example session:
mhw:~/guile$ meta/guile
GNU Guile 2.0.3.66-52b7f-dirty
Copyright (C) 1995-2011 Free Software Foundation, Inc.
Guile comes with ABSOLUTELY NO WARRANTY; for details type `,show w'.
This program is free software, and you are welcome to redistribute it
under certain conditions; type `,show c' for details.
Enter `,help' for help.
scheme@(guile-user)> (define env1 (primitive-eval '(let ((x 1) (y 2))
(capture-lexical-environment))))
scheme@(guile-user)> (primitive-local-eval 'x env1)
$1 = 1
scheme@(guile-user)> (primitive-local-eval 'y env1)
$2 = 2
scheme@(guile-user)> (primitive-local-eval '(set! x (+ x 10)) env1)
$3 = 11
scheme@(guile-user)> (primitive-local-eval 'x env1)
$4 = 11
scheme@(guile-user)> (define env2 (primitive-local-eval '(begin (set! x (+ x
1)) (let ((z 3)) (capture-lexical-environment))) env1))
scheme@(guile-user)> (primitive-local-eval 'z env2)
$5 = 3
scheme@(guile-user)> (primitive-local-eval 'x env2)
$6 = 12
scheme@(guile-user)> (primitive-local-eval 'y env2)
$7 = 2
scheme@(guile-user)> (primitive-local-eval 'x env1)
$8 = 12
scheme@(guile-user)> (primitive-local-eval '(set! x (+ x 10)) env1)
$9 = 22
scheme@(guile-user)> (primitive-local-eval 'x env2)
$10 = 22
scheme@(guile-user)> (primitive-local-eval '(set! y (+ y 5)) env2)
$11 = 7
scheme@(guile-user)> (primitive-local-eval 'y env1)
$12 = 7
scheme@(guile-user)> (define foo 35)
scheme@(guile-user)> (primitive-local-eval 'foo env1)
$13 = 35
scheme@(guile-user)> (primitive-local-eval '(set! foo 37) env1)
scheme@(guile-user)> foo
$14 = 37
The preliminary patch follows. Comments solicited.
Mark
>From 417762cbd3d299bb166ac240bc84fcceeb6dcde9 Mon Sep 17 00:00:00 2001
From: Mark H Weaver <m...@netris.org>
Date: Wed, 14 Dec 2011 03:12:43 -0500
Subject: [PATCH] Implement `capture-lexical-environment' in evaluator
PRELIMINARY WORK, not ready for commit.
---
libguile/expand.c | 5 +
libguile/expand.h | 13 +
libguile/memoize.c | 18 +
libguile/memoize.h | 5 +-
module/ice-9/eval.scm | 49 +-
module/ice-9/psyntax-pp.scm |23314 ++++++++++++++++++++++---------------------
module/ice-9/psyntax.scm | 32 +-
module/language/tree-il.scm | 10 +
8 files changed, 12127 insertions(+), 11319 deletions(-)
diff --git a/module/ice-9/eval.scm b/module/ice-9/eval.scm
index c0fa64c..e51c662 100644
--- a/module/ice-9/eval.scm
+++ b/module/ice-9/eval.scm
@@ -213,7 +213,16 @@
;;; `eval' in this order, to put the most frequent cases first.
;;;
-(define primitive-eval
+;; FIXME: make this opaque!!
+(define (make-lexical-environment eval-env memo-env expander-env)
+ (list '<lexical-environment> eval-env memo-env expander-env))
+(define lexical-environment:eval-env cadr)
+(define lexical-environment:memo-env caddr)
+(define lexical-environment:expander-env cadddr)
+
+(define primitive-eval #f)
+(define primitive-local-eval #f)
+
(let ()
;; We pre-generate procedures with fixed arities, up to some number of
;; arguments; see make-fixed-closure above.
@@ -459,6 +468,9 @@
(eval exp env)
(eval handler env)))
+ (('capture-lexical-environment (memo-env . expander-env))
+ (make-lexical-environment env memo-env expander-env))
+
(('call/cc proc)
(call/cc (eval proc env)))
@@ -469,12 +481,29 @@
(memoize-variable-access! exp #f))
(eval x env)))))
- ;; primitive-eval
- (lambda (exp)
- "Evaluate @var{exp} in the current module."
- (eval
- (memoize-expression
- (if (macroexpanded? exp)
- exp
- ((module-transformer (current-module)) exp)))
- '()))))
+ (set! primitive-local-eval
+ (lambda (exp env)
+ "Evaluate @var{exp} within the lexical environment @var{env}."
+ (let ((eval-env (lexical-environment:eval-env env))
+ (memo-env (lexical-environment:memo-env env))
+ (expander-env (lexical-environment:expander-env env)))
+ (let ((module (capture-env (if (pair? eval-env)
+ (cdr (last-pair eval-env))
+ eval-env))))
+ (eval
+ (memoize-local-expression
+ (if (macroexpanded? exp)
+ exp
+ ((module-transformer module) exp #:env expander-env))
+ memo-env)
+ eval-env)))))
+
+ (set! primitive-eval
+ (lambda (exp)
+ "Evaluate @var{exp} in the current module."
+ (eval
+ (memoize-expression
+ (if (macroexpanded? exp)
+ exp
+ ((module-transformer (current-module)) exp)))
+ '()))))
diff --git a/libguile/memoize.c b/libguile/memoize.c
index 911d972..c06d593 100644
--- a/libguile/memoize.c
+++ b/libguile/memoize.c
@@ -112,6 +112,8 @@ scm_t_bits scm_tc16_memoized;
MAKMEMO (SCM_M_MODULE_SET, scm_cons (val, scm_cons (mod, scm_cons (var, public))))
#define MAKMEMO_PROMPT(tag, exp, handler) \
MAKMEMO (SCM_M_PROMPT, scm_cons (tag, scm_cons (exp, handler)))
+#define MAKMEMO_CAPTURE_LEXICAL_ENVIRONMENT(memo_env, expander_env) \
+ MAKMEMO (SCM_M_CAPTURE_LEXICAL_ENVIRONMENT, scm_cons(memo_env, expander_env))
/* Primitives for the evaluator */
@@ -143,6 +145,7 @@ static const char *const memoized_tags[] =
"module-ref",
"module-set!",
"prompt",
+ "capture-lexical-environment",
};
static int
@@ -426,6 +429,9 @@ memoize (SCM exp, SCM env)
memoize_exps (REF (exp, DYNLET, VALS), env),
memoize (REF (exp, DYNLET, BODY), env));
+ case SCM_EXPANDED_CAPTURE_LEXICAL_ENVIRONMENT:
+ return MAKMEMO_CAPTURE_LEXICAL_ENVIRONMENT (env, REF (exp, CAPTURE_LEXICAL_ENVIRONMENT, ENV));
+
default:
abort ();
}
@@ -444,6 +450,16 @@ SCM_DEFINE (scm_memoize_expression, "memoize-expression", 1, 0, 0,
}
#undef FUNC_NAME
+SCM_DEFINE (scm_memoize_local_expression, "memoize-local-expression", 2, 0, 0,
+ (SCM exp, SCM env),
+ "Memoize the expression @var{exp} within the local memoize environment @var{env}.")
+#define FUNC_NAME s_scm_memoize_local_expression
+{
+ SCM_ASSERT_TYPE (SCM_EXPANDED_P (exp), exp, 1, FUNC_NAME, "expanded");
+ return memoize (exp, env);
+}
+#undef FUNC_NAME
+
@@ -706,6 +722,8 @@ unmemoize (const SCM expr)
unmemoize (CAR (args)),
unmemoize (CADR (args)),
unmemoize (CDDR (args)));
+ case SCM_M_CAPTURE_LEXICAL_ENVIRONMENT:
+ return scm_list_3 (scm_sym_capture_lexical_environment, CAR (args), CDR (args));
default:
abort ();
}
diff --git a/libguile/memoize.h b/libguile/memoize.h
index 26bd5b1..4a05bee 100644
--- a/libguile/memoize.h
+++ b/libguile/memoize.h
@@ -44,6 +44,7 @@ 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_capture_lexical_environment;
SCM_API SCM scm_sym_with_fluids;
SCM_API SCM scm_sym_at;
@@ -90,13 +91,15 @@ enum
SCM_M_TOPLEVEL_SET,
SCM_M_MODULE_REF,
SCM_M_MODULE_SET,
- SCM_M_PROMPT
+ SCM_M_PROMPT,
+ SCM_M_CAPTURE_LEXICAL_ENVIRONMENT
};
SCM_INTERNAL SCM scm_memoize_expression (SCM exp);
+SCM_INTERNAL SCM scm_memoize_local_expression (SCM exp, SCM env);
SCM_INTERNAL SCM scm_unmemoize_expression (SCM memoized);
SCM_INTERNAL SCM scm_memoized_expression_typecode (SCM memoized);
SCM_INTERNAL SCM scm_memoized_expression_data (SCM memoized);
diff --git a/libguile/expand.h b/libguile/expand.h
index 02e6e17..b78ef1b 100644
--- a/libguile/expand.h
+++ b/libguile/expand.h
@@ -54,6 +54,7 @@ typedef enum
SCM_EXPANDED_LET,
SCM_EXPANDED_LETREC,
SCM_EXPANDED_DYNLET,
+ SCM_EXPANDED_CAPTURE_LEXICAL_ENVIRONMENT,
SCM_NUM_EXPANDED_TYPES,
} scm_t_expanded_type;
@@ -330,6 +331,18 @@ enum
#define SCM_MAKE_EXPANDED_DYNLET(src, fluids, vals, body) \
scm_c_make_struct (exp_vtables[SCM_EXPANDED_DYNLET], 0, SCM_NUM_EXPANDED_DYNLET_FIELDS, SCM_UNPACK (src), SCM_UNPACK (fluids), SCM_UNPACK (vals), SCM_UNPACK (body))
+#define SCM_EXPANDED_CAPTURE_LEXICAL_ENVIRONMENT_TYPE_NAME "capture-lexical-environment"
+#define SCM_EXPANDED_CAPTURE_LEXICAL_ENVIRONMENT_FIELD_NAMES \
+ { "src", "env", }
+enum
+ {
+ SCM_EXPANDED_CAPTURE_LEXICAL_ENVIRONMENT_SRC,
+ SCM_EXPANDED_CAPTURE_LEXICAL_ENVIRONMENT_ENV,
+ SCM_NUM_EXPANDED_CAPTURE_LEXICAL_ENVIRONMENT_FIELDS,
+ };
+#define SCM_MAKE_EXPANDED_CAPTURE_LEXICAL_ENVIRONMENT(src, env) \
+ scm_c_make_struct (exp_vtables[SCM_EXPANDED_CAPTURE_LEXICAL_ENVIRONMENT], 0, SCM_NUM_EXPANDED_CAPTURE_LEXICAL_ENVIRONMENT_FIELDS, SCM_UNPACK (src), SCM_UNPACK (env))
+
#endif /* BUILDING_LIBGUILE */
diff --git a/libguile/expand.c b/libguile/expand.c
index bdecd80..35d1c3a 100644
--- a/libguile/expand.c
+++ b/libguile/expand.c
@@ -85,6 +85,8 @@ static const char** exp_field_names[SCM_NUM_EXPANDED_TYPES];
SCM_MAKE_EXPANDED_LETREC(src, in_order_p, names, gensyms, vals, body)
#define DYNLET(src, fluids, vals, body) \
SCM_MAKE_EXPANDED_DYNLET(src, fluids, vals, body)
+#define CAPTURE_LEXICAL_ENVIRONMENT(src, env) \
+ SCM_MAKE_EXPANDED_CAPTURE_LEXICAL_ENVIRONMENT(src, env)
#define CAR(x) SCM_CAR(x)
#define CDR(x) SCM_CDR(x)
@@ -203,6 +205,8 @@ SCM_GLOBAL_SYMBOL (scm_sym_unquote, "unquote");
SCM_GLOBAL_SYMBOL (scm_sym_quasiquote, "quasiquote");
SCM_GLOBAL_SYMBOL (scm_sym_uq_splicing, "unquote-splicing");
+SCM_GLOBAL_SYMBOL (scm_sym_capture_lexical_environment, "capture-lexical-environment");
+
SCM_KEYWORD (kw_allow_other_keys, "allow-other-keys");
SCM_KEYWORD (kw_optional, "optional");
SCM_KEYWORD (kw_key, "key");
@@ -1250,6 +1254,7 @@ scm_init_expand ()
DEFINE_NAMES (LET);
DEFINE_NAMES (LETREC);
DEFINE_NAMES (DYNLET);
+ DEFINE_NAMES (CAPTURE_LEXICAL_ENVIRONMENT);
scm_exp_vtable_vtable =
scm_make_vtable (scm_from_locale_string (SCM_VTABLE_BASE_LAYOUT "pwuwpw"),
diff --git a/module/language/tree-il.scm b/module/language/tree-il.scm
index 1d391c4..455dccc 100644
--- a/module/language/tree-il.scm
+++ b/module/language/tree-il.scm
@@ -49,6 +49,9 @@
<dynlet> dynlet? make-dynlet dynlet-src dynlet-fluids dynlet-vals dynlet-body
<dynref> dynref? make-dynref dynref-src dynref-fluid
<dynset> dynset? make-dynset dynset-src dynset-fluid dynset-exp
+ <capture-lexical-environment> capture-lexical-environment?
+ make-capture-lexical-environment
+ capture-lexical-environment-src
<prompt> prompt? make-prompt prompt-src prompt-tag prompt-body prompt-handler
<abort> abort? make-abort abort-src abort-tag abort-args abort-tail
@@ -125,6 +128,7 @@
;; (<let> names gensyms vals body)
;; (<letrec> in-order? names gensyms vals body)
;; (<dynlet> fluids vals body)
+ ;; (<capture-lexical-environment>)
(define-type (<tree-il> #:common-slots (src) #:printer print-tree-il)
(<fix> names gensyms vals body)
@@ -324,6 +328,9 @@
((<dynset> fluid exp)
`(dynset ,(unparse-tree-il fluid) ,(unparse-tree-il exp)))
+ ((<capture-lexical-environment>)
+ '(capture-lexical-environment))
+
((<prompt> tag body handler)
`(prompt ,(unparse-tree-il tag) ,(unparse-tree-il body) ,(unparse-tree-il handler)))
@@ -470,6 +477,9 @@
((<dynset> fluid exp)
`(fluid-set! ,(tree-il->scheme fluid) ,(tree-il->scheme exp)))
+ ((<capture-lexical-environment>)
+ '(capture-lexical-environment))
+
((<prompt> tag body handler)
`(call-with-prompt
,(tree-il->scheme tag)
diff --git a/module/ice-9/psyntax.scm b/module/ice-9/psyntax.scm
index e522f54..d147902 100644
--- a/module/ice-9/psyntax.scm
+++ b/module/ice-9/psyntax.scm
@@ -307,6 +307,14 @@
(if (not (assq 'name meta))
(set-lambda-meta! val (acons 'name name meta))))))
+ ;; data type for exporting the compile-type environment
+ ;; FIXME: make this opaque!
+ (define (make-psyntax-env r w mod)
+ (list '<psyntax-env> r w mod))
+ (define psyntax-env:r cadr)
+ (define psyntax-env:w caddr)
+ (define psyntax-env:mod cadddr)
+
;; output constructors
(define build-void
(lambda (source)
@@ -410,6 +418,9 @@
(define (build-data src exp)
(make-const src exp))
+ (define (build-capture-lexical-environment src env)
+ (make-capture-lexical-environment src env))
+
(define build-sequence
(lambda (src exps)
(if (null? (cdr exps))
@@ -1786,6 +1797,13 @@
(_ (syntax-violation 'quote "bad syntax"
(source-wrap e w s mod))))))
+ (global-extend 'core 'capture-lexical-environment
+ (lambda (e r w s mod)
+ (syntax-case e ()
+ ((_) (build-capture-lexical-environment s (make-psyntax-env r w mod)))
+ (_ (syntax-violation 'quote "bad syntax"
+ (source-wrap e w s mod))))))
+
(global-extend 'core 'syntax
(let ()
(define gen-syntax
@@ -2395,10 +2413,17 @@
;; expanded, and the expanded definitions are also residualized into
;; the object file if we are compiling a file.
(set! macroexpand
- (lambda* (x #:optional (m 'e) (esew '(eval)))
- (expand-top-sequence (list x) null-env top-wrap #f m esew
- (cons 'hygiene (module-name (current-module))))))
+ (lambda* (x #:optional (m 'e) (esew '(eval))
+ #:key (env (make-psyntax-env
+ null-env top-wrap
+ (cons 'hygiene (module-name (current-module))))))
+ (expand-top-sequence (list x)
+ (psyntax-env:r env) ;; null-env
+ (psyntax-env:w env) ;; top-wrap
+ #f
+ m
+ esew
+ (psyntax-env:mod env)))) ;; (cons 'hygiene (module-name (current-module)))
(set! identifier?
(lambda (x)
--
1.7.5.4
