From c6748349a833cd61b380259ca8b9d81d7f14128f Mon Sep 17 00:00:00 2001 From: Mark H Weaver Date: Wed, 14 Dec 2011 03:12:43 -0500 Subject: [PATCH] Implement `the-environment' and `local-eval' 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 | 31 + module/ice-9/psyntax-pp.scm |23299 ++++++++++++++++++++++--------------------- module/ice-9/psyntax.scm | 26 +- module/language/tree-il.scm | 8 + 8 files changed, 12095 insertions(+), 11310 deletions(-) diff --git a/module/ice-9/eval.scm b/module/ice-9/eval.scm index c0fa64c..7d6e6c1 100644 --- a/module/ice-9/eval.scm +++ b/module/ice-9/eval.scm @@ -213,6 +213,8 @@ ;;; `eval' in this order, to put the most frequent cases first. ;;; +(define local-eval #f) ;; This is set! from within the primitive-eval block + (define primitive-eval (let () ;; We pre-generate procedures with fixed arities, up to some number of @@ -357,6 +359,14 @@ ;; Finally, eval the body. (eval body env))))))))))))))) + ;; FIXME: make this opaque!! + (define (make-lexical-environment module eval-env memoizer-env expander-env) + (list ' module eval-env memoizer-env expander-env)) + (define lexical-environment:module cadr) + (define lexical-environment:eval-env caddr) + (define lexical-environment:memoizer-env cadddr) + (define (lexical-environment:expander-env env) (car (cddddr env))) + ;; The "engine". EXP is a memoized expression. (define (eval exp env) (memoized-expression-case exp @@ -459,6 +469,12 @@ (eval exp env) (eval handler env))) + (('the-environment (memoizer-env . expander-env)) + (let ((module (capture-env (if (pair? env) + (cdr (last-pair env)) + env)))) + (make-lexical-environment module env memoizer-env expander-env))) + (('call/cc proc) (call/cc (eval proc env))) @@ -468,6 +484,21 @@ var-or-spec (memoize-variable-access! exp #f)) (eval x env))))) + + (set! local-eval + (lambda (exp env) + "Evaluate @var{exp} within the lexical environment @var{env}." + (let ((module (lexical-environment:module env)) + (eval-env (lexical-environment:eval-env env)) + (memoizer-env (lexical-environment:memoizer-env env)) + (expander-env (lexical-environment:expander-env env))) + (eval (memoize-local-expression + (if (macroexpanded? exp) + exp + ((module-transformer module) + exp #:env expander-env)) + memoizer-env) + eval-env)))) ;; primitive-eval (lambda (exp) diff --git a/libguile/memoize.h b/libguile/memoize.h index 26bd5b1..f012d3a 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_the_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_THE_ENVIRONMENT }; SCM_INTERNAL SCM scm_memoize_expression (SCM exp); +SCM_INTERNAL SCM scm_memoize_local_expression (SCM exp, SCM memoizer_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/memoize.c b/libguile/memoize.c index 911d972..f7be46e 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_THE_ENVIRONMENT(memoizer_env, expander_env) \ + MAKMEMO (SCM_M_THE_ENVIRONMENT, scm_cons(memoizer_env, expander_env)) /* Primitives for the evaluator */ @@ -143,6 +145,7 @@ static const char *const memoized_tags[] = "module-ref", "module-set!", "prompt", + "the-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_THE_ENVIRONMENT: + return MAKMEMO_THE_ENVIRONMENT (env, REF (exp, THE_ENVIRONMENT, EXPANDER_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 memoizer_env), + "Memoize the expression @var{exp} within @var{memoizer_env}.") +#define FUNC_NAME s_scm_memoize_local_expression +{ + SCM_ASSERT_TYPE (SCM_EXPANDED_P (exp), exp, 1, FUNC_NAME, "expanded"); + return memoize (exp, memoizer_env); +} +#undef FUNC_NAME + @@ -706,6 +722,8 @@ unmemoize (const SCM expr) unmemoize (CAR (args)), unmemoize (CADR (args)), unmemoize (CDDR (args))); + case SCM_M_THE_ENVIRONMENT: + return scm_list_3 (scm_sym_the_environment, CAR (args), CDR (args)); default: abort (); } diff --git a/libguile/expand.h b/libguile/expand.h index 02e6e17..b150058 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_THE_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_THE_ENVIRONMENT_TYPE_NAME "the-environment" +#define SCM_EXPANDED_THE_ENVIRONMENT_FIELD_NAMES \ + { "src", "expander-env", } +enum + { + SCM_EXPANDED_THE_ENVIRONMENT_SRC, + SCM_EXPANDED_THE_ENVIRONMENT_EXPANDER_ENV, + SCM_NUM_EXPANDED_THE_ENVIRONMENT_FIELDS, + }; +#define SCM_MAKE_EXPANDED_THE_ENVIRONMENT(src, expander_env) \ + scm_c_make_struct (exp_vtables[SCM_EXPANDED_THE_ENVIRONMENT], 0, SCM_NUM_EXPANDED_THE_ENVIRONMENT_FIELDS, SCM_UNPACK (src), SCM_UNPACK (expander_env)) + #endif /* BUILDING_LIBGUILE */ diff --git a/libguile/expand.c b/libguile/expand.c index bdecd80..18d9e40 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 THE_ENVIRONMENT(src, expander_env) \ + SCM_MAKE_EXPANDED_THE_ENVIRONMENT(src, expander_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_the_environment, "the-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 (THE_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..907cc82 100644 --- a/module/language/tree-il.scm +++ b/module/language/tree-il.scm @@ -49,6 +49,7 @@ dynlet? make-dynlet dynlet-src dynlet-fluids dynlet-vals dynlet-body dynref? make-dynref dynref-src dynref-fluid dynset? make-dynset dynset-src dynset-fluid dynset-exp + the-environment? make-the-environment the-environment-src the-environment-expander-env prompt? make-prompt prompt-src prompt-tag prompt-body prompt-handler abort? make-abort abort-src abort-tag abort-args abort-tail @@ -125,6 +126,7 @@ ;; ( names gensyms vals body) ;; ( in-order? names gensyms vals body) ;; ( fluids vals body) + ;; ( expander-env) (define-type ( #:common-slots (src) #:printer print-tree-il) ( names gensyms vals body) @@ -324,6 +326,9 @@ (( fluid exp) `(dynset ,(unparse-tree-il fluid) ,(unparse-tree-il exp))) + (( expander-env) + `(the-environment ,expander-env)) + (( tag body handler) `(prompt ,(unparse-tree-il tag) ,(unparse-tree-il body) ,(unparse-tree-il handler))) @@ -470,6 +475,9 @@ (( fluid exp) `(fluid-set! ,(tree-il->scheme fluid) ,(tree-il->scheme exp))) + (() + '(the-environment)) + (( 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..292f932 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 ' 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-the-environment src expander-env) + (make-the-environment src expander-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 'the-environment + (lambda (e r w s mod) + (syntax-case e () + ((_) (build-the-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,9 +2413,11 @@ ;; 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) + (if env + (expand x (psyntax-env:r env) (psyntax-env:w env) (psyntax-env:mod env)) + (expand-top-sequence (list x) null-env top-wrap #f m esew + (cons 'hygiene (module-name (current-module))))))) (set! identifier? (lambda (x) -- 1.7.5.4