Na}{

File Content: `local-eval.scm`

;;; -*- mode: scheme; coding: utf-8; -*-
;;;
;;; Copyright (C) 2012, 2013 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

(define-module (ice-9 local-eval)
  #:use-module (ice-9 format)
  #:use-module (srfi srfi-9)
  #:use-module (srfi srfi-9 gnu)
  #:use-module (system base compile)
  #:use-module (system syntax)
  #:export (the-environment local-eval local-compile))

(define-record-type lexical-environment-type
  (make-lexical-environment scope wrapper boxes patterns)
  lexical-environment?
  (scope             lexenv-scope)
  (wrapper           lexenv-wrapper)
  (boxes             lexenv-boxes)
  (patterns          lexenv-patterns))

(set-record-type-printer!
 lexical-environment-type
 (lambda (e port)
   (format port "#<lexical-environment ~S (~S bindings)>"
           (syntax-module (lexenv-scope e))
           (+ (length (lexenv-boxes e)) (length (lexenv-patterns e))))))

(define-syntax syntax-object-of
  (lambda (form)
    (syntax-case form ()
      ((_ x) #`(quote #,(datum->syntax #'x #'x))))))

(define-syntax-rule (make-box v)
  (case-lambda
   (() v)
   ((x) (set! v x))))

(define (make-transformer-from-box id trans)
  (set-procedure-property! trans 'identifier-syntax-box id)
  trans)

(define-syntax-rule (identifier-syntax-from-box box)
  (make-transformer-from-box
   (syntax-object-of box)
   (identifier-syntax (id          (box))
                      ((set! id x) (box x)))))

(define (unsupported-binding name)
  (make-variable-transformer
   (lambda (x)
     (syntax-violation
      'local-eval
      "unsupported binding captured by (the-environment)"
      x))))

(define (within-nested-ellipses id lvl)
  (let loop ((s id) (n lvl))
    (if (zero? n)
        s
        (loop #`(#,s (... ...)) (- n 1)))))

;; Analyze the set of bound identifiers IDS.  Return four values:
;;
;; capture: A list of forms that will be emitted in the expansion of
;; `the-environment' to capture lexical variables.
;;
;; formals: Corresponding formal parameters for use in the lambda that
;; re-introduces those variables.  These are temporary identifiers, and
;; as such if we have a nested `the-environment', there is no need to
;; capture them.  (See the notes on nested `the-environment' and
;; proxies, below.)
;;
;; wrappers: A list of procedures of type SYNTAX -> SYNTAX, used to wrap
;; the expression to be evaluated in forms that re-introduce the
;; variable.  The forms will be nested so that the variable shadowing
;; semantics of the original form are maintained.
;;
;; patterns: A terrible hack.  The issue is that for pattern variables,
;; we can't emit lexically nested with-syntax forms, like:
;;
;;   (with-syntax ((foo 1)) (the-environment))
;;   => (with-syntax ((foo 1))
;;        ... #'(with-syntax ((foo ...)) ... exp) ...)
;;
;; The reason is that the outer "foo" substitutes into the inner "foo",
;; yielding something like:
;;
;;   (with-syntax ((foo 1))
;;     ... (with-syntax ((1 ...)) ...)
;;            
;; Which ain't what we want.  So we hide the information needed to
;; re-make the inner pattern binding form in the lexical environment
;; object, and then introduce those identifiers via another with-syntax.
;;
;;
;; There are four different kinds of lexical bindings: normal lexicals,
;; macros, displaced lexicals, and pattern variables.  See the
;; documentation of syntax-local-binding for more info on these.
;;
;; We capture normal lexicals via `make-box', which creates a
;; case-lambda that can reference or set a variable.  These get
;; re-introduced with an identifier-syntax.
;;
;; We can't capture macros currently.  However we do recognize our own
;; macros that are actually proxying lexicals, so that nested
;; `the-environment' forms are possible.  In that case we drill down to
;; the identifier for the already-existing box, and just capture that
;; box.
;;
;; And that's it: we skip displaced lexicals, and the pattern variables
;; are discussed above.
;;
(define (analyze-identifiers ids)
  (define (mktmp)
    (datum->syntax #'here (gensym "t ")))
  (let lp ((ids ids) (capture '()) (formals '()) (wrappers '()) (patterns '()))
    (cond
     ((null? ids)
      (values capture formals wrappers patterns))
     (else
      (let ((id (car ids)) (ids (cdr ids)))
        (call-with-values (lambda () (syntax-local-binding id))
          (lambda (type val)
            (case type
              ((lexical)
               (if (or-map (lambda (x) (bound-identifier=? x id)) formals)
                   (lp ids capture formals wrappers patterns)
                   (let ((t (mktmp)))
                     (lp ids
                         (cons #`(make-box #,id) capture)
                         (cons t formals)
                         (cons (lambda (x)
                                 #`(let-syntax ((#,id (identifier-syntax-from-box #,t)))
                                     #,x))
                               wrappers)
                         patterns))))
              ((displaced-lexical)
               (lp ids capture formals wrappers patterns))
              ((macro)
               (let ((b (procedure-property val 'identifier-syntax-box)))
                 (if b
                     (lp ids (cons b capture) (cons b formals)
                         (cons (lambda (x)
                                 #`(let-syntax ((#,id (identifier-syntax-from-box #,b)))
                                     #,x))
                               wrappers)
                         patterns)
                     (lp ids capture formals
                         (cons (lambda (x)
                                 #`(let-syntax ((#,id (unsupported-binding '#,id)))
                                     #,x))
                               wrappers)
                         patterns))))
              ((pattern-variable)
               (let ((t (datum->syntax id (gensym "p ")))
                     (nested (within-nested-ellipses id (cdr val))))
                 (lp ids capture formals
                     (cons (lambda (x)
                             #`(with-syntax ((#,t '#,nested))
                                 #,x))
                           wrappers)
                     ;; This dance is to hide these pattern variables
                     ;; from the expander.
                     (cons (list (datum->syntax #'here (syntax->datum id))
                                 (cdr val)
                                 t)
                           patterns))))
              ((ellipsis)
               (lp ids capture formals
                   (cons (lambda (x)
                           #`(with-ellipsis #,val #,x))
                         wrappers)
                   patterns))
              (else
               (error "what" type val))))))))))

(define-syntax the-environment
  (lambda (x)
    (syntax-case x ()
      ((the-environment)
       #'(the-environment the-environment))
      ((the-environment scope)
       (call-with-values (lambda ()
                           (analyze-identifiers
                            (syntax-locally-bound-identifiers #'scope)))
         (lambda (capture formals wrappers patterns)
           (define (wrap-expression x)
             (let lp ((x x) (wrappers wrappers))
               (if (null? wrappers)
                   x
                   (lp ((car wrappers) x) (cdr wrappers)))))
           (with-syntax (((f ...) formals)
                         ((c ...) capture)
                         (((pname plvl pformal) ...) patterns)
                         (wrapped (wrap-expression #'(begin #f exp))))
             #'(make-lexical-environment
                #'scope
                (lambda (exp pformal ...)
                  (with-syntax ((exp exp)
                                (pformal pformal)
                                ...)
                    #'(lambda (f ...)
                        wrapped)))
                (list c ...)
                (list (list 'pname plvl #'pformal) ...)))))))))

(define (env-module e)
  (cond
   ((lexical-environment? e) (resolve-module (syntax-module (lexenv-scope e))))
   ((module? e) e)
   (else (error "invalid lexical environment" e))))

(define (env-boxes e)
  (cond
   ((lexical-environment? e) (lexenv-boxes e))
   ((module? e) '())
   (else (error "invalid lexical environment" e))))

(define (local-wrap x e)
  (cond
   ((lexical-environment? e)
    (apply (lexenv-wrapper e)
           (datum->syntax (lexenv-scope e) x)
           (map (lambda (l)
                  (let ((name (car l))
                        (lvl (cadr l))
                        (scope (caddr l)))
                    (within-nested-ellipses (datum->syntax scope name) lvl)))
                (lexenv-patterns e))))
   ((module? e) #`(lambda () #f #,x))
   (else (error "invalid lexical environment" e))))

(define (local-eval x e)
  "Evaluate the expression @var{x} within the lexical environment @var{e}."
  (apply (eval (local-wrap x e) (env-module e))
         (env-boxes e)))

(define* (local-compile x e #:key (opts '()))
  "Compile and evaluate the expression @var{x} within the lexical
environment @var{e}."
  (apply (compile (local-wrap x e) #:env (env-module e)
                  #:from 'scheme #:opts opts)
         (env-boxes e)))

Name	Size	Permission
and-let-star.scm	2593 bytes	0644
binary-ports.scm	1921 bytes	0644
boot-9.scm	154720 bytes	0644
buffered-input.scm	4935 bytes	0644
calling.scm	10790 bytes	0644
channel.scm	5312 bytes	0644
command-line.scm	18655 bytes	0644
common-list.scm	9160 bytes	0644
control.scm	4036 bytes	0644
curried-definitions.scm	1829 bytes	0644
debug.scm	1114 bytes	0644
deprecated.scm	31993 bytes	0644
documentation.scm	7432 bytes	0644
eval-string.scm	2997 bytes	0644
eval.scm	21354 bytes	0644
expect.scm	5628 bytes	0644
format.scm	76284 bytes	0644
ftw.scm	24753 bytes	0644
futures.scm	11186 bytes	0644
gap-buffer.scm	10384 bytes	0644
getopt-long.scm	16888 bytes	0644
hash-table.scm	1813 bytes	0644
hcons.scm	2614 bytes	0644
history.scm	2343 bytes	0644
i18n.scm	17778 bytes	0644
iconv.scm	3735 bytes	0644
lineio.scm	3941 bytes	0644
list.scm	1319 bytes	0644
local-eval.scm	9946 bytes	0644
ls.scm	3275 bytes	0644
mapping.scm	4955 bytes	0644
match.scm	2045 bytes	0644
match.upstream.scm	36459 bytes	0644
networking.scm	3407 bytes	0644
null.scm	1157 bytes	0644
occam-channel.scm	7436 bytes	0644
optargs.scm	16123 bytes	0644
poe.scm	3382 bytes	0644
poll.scm	6166 bytes	0644
popen.scm	5806 bytes	0644
posix.scm	2793 bytes	0644
pretty-print.scm	16211 bytes	0644
psyntax-pp.scm	166774 bytes	0644
psyntax.scm	147118 bytes	0644
q.scm	4297 bytes	0644
quasisyntax.scm	5348 bytes	0644
r4rs.scm	9645 bytes	0644
r5rs.scm	1602 bytes	0644
r6rs-libraries.scm	9164 bytes	0644
rdelim.scm	7648 bytes	0644
readline.scm	9786 bytes	0644
receive.scm	1082 bytes	0644
regex.scm	9084 bytes	0644
runq.scm	8379 bytes	0644
rw.scm	1047 bytes	0644
safe-r5rs.scm	3814 bytes	0644
safe.scm	1275 bytes	0644
save-stack.scm	2197 bytes	0644
scm-style-repl.scm	11986 bytes	0644
serialize.scm	3859 bytes	0644
session.scm	18143 bytes	0644
slib.scm	1583 bytes	0644
stack-catch.scm	1983 bytes	0644
streams.scm	7488 bytes	0644
string-fun.scm	8798 bytes	0644
syncase.scm	1556 bytes	0644
threads.scm	6388 bytes	0644
time.scm	2088 bytes	0644
top-repl.scm	2812 bytes	0644
unicode.scm	1005 bytes	0644
vlist.scm	22081 bytes	0644
weak-vector.scm	1288 bytes	0644

File Content: local-eval.scm

File Content: `local-eval.scm`