module/ice-9/local-eval.scm

   1 ;;; -*- mode: scheme; coding: utf-8; -*-
   2 ;;;
   3 ;;; Copyright (C) 2012, 2013 Free Software Foundation, Inc.
   4 ;;;
   5 ;;; This library is free software; you can redistribute it and/or
   6 ;;; modify it under the terms of the GNU Lesser General Public
   7 ;;; License as published by the Free Software Foundation; either
   8 ;;; version 3 of the License, or (at your option) any later version.
   9 ;;;
  10 ;;; This library is distributed in the hope that it will be useful,
  11 ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  12 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  13 ;;; Lesser General Public License for more details.
  14 ;;;
  15 ;;; You should have received a copy of the GNU Lesser General Public
  16 ;;; License along with this library; if not, write to the Free Software
  17 ;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
  18
  19 (define-module (ice-9 local-eval)
  20   #:use-module (ice-9 format)
  21   #:use-module (srfi srfi-9)
  22   #:use-module (srfi srfi-9 gnu)
  23   #:use-module (system base compile)
  24   #:use-module (system syntax)
  25   #:export (the-environment local-eval local-compile))
  26
  27 (define-record-type lexical-environment-type
  28   (make-lexical-environment scope wrapper boxes patterns)
  29   lexical-environment?
  30   (scope             lexenv-scope)
  31   (wrapper           lexenv-wrapper)
  32   (boxes             lexenv-boxes)
  33   (patterns          lexenv-patterns))
  34
  35 (set-record-type-printer!
  36  lexical-environment-type
  37  (lambda (e port)
  38    (format port "#<lexical-environment ~S (~S bindings)>"
  39            (syntax-module (lexenv-scope e))
  40            (+ (length (lexenv-boxes e)) (length (lexenv-patterns e))))))
  41
  42 (define-syntax syntax-object-of
  43   (lambda (form)
  44     (syntax-case form ()
  45       ((_ x) #`(quote #,(datum->syntax #'x #'x))))))
  46
  47 (define-syntax-rule (make-box v)
  48   (case-lambda
  49    (() v)
  50    ((x) (set! v x))))
  51
  52 (define (make-transformer-from-box id trans)
  53   (set-procedure-property! trans 'identifier-syntax-box id)
  54   trans)
  55
  56 (define-syntax-rule (identifier-syntax-from-box box)
  57   (make-transformer-from-box
  58    (syntax-object-of box)
  59    (identifier-syntax (id          (box))
  60                       ((set! id x) (box x)))))
  61
  62 (define (unsupported-binding name)
  63   (make-variable-transformer
  64    (lambda (x)
  65      (syntax-violation
  66       'local-eval
  67       "unsupported binding captured by (the-environment)"
  68       x))))
  69
  70 (define (within-nested-ellipses id lvl)
  71   (let loop ((s id) (n lvl))
  72     (if (zero? n)
  73         s
  74         (loop #`(#,s (... ...)) (- n 1)))))
  75
  76 ;; Analyze the set of bound identifiers IDS.  Return four values:
  77 ;;
  78 ;; capture: A list of forms that will be emitted in the expansion of
  79 ;; `the-environment' to capture lexical variables.
  80 ;;
  81 ;; formals: Corresponding formal parameters for use in the lambda that
  82 ;; re-introduces those variables.  These are temporary identifiers, and
  83 ;; as such if we have a nested `the-environment', there is no need to
  84 ;; capture them.  (See the notes on nested `the-environment' and
  85 ;; proxies, below.)
  86 ;;
  87 ;; wrappers: A list of procedures of type SYNTAX -> SYNTAX, used to wrap
  88 ;; the expression to be evaluated in forms that re-introduce the
  89 ;; variable.  The forms will be nested so that the variable shadowing
  90 ;; semantics of the original form are maintained.
  91 ;;
  92 ;; patterns: A terrible hack.  The issue is that for pattern variables,
  93 ;; we can't emit lexically nested with-syntax forms, like:
  94 ;;
  95 ;;   (with-syntax ((foo 1)) (the-environment))
  96 ;;   => (with-syntax ((foo 1))
  97 ;;        ... #'(with-syntax ((foo ...)) ... exp) ...)
  98 ;;
  99 ;; The reason is that the outer "foo" substitutes into the inner "foo",
 100 ;; yielding something like:
 101 ;;
 102 ;;   (with-syntax ((foo 1))
 103 ;;     ... (with-syntax ((1 ...)) ...)
 104 ;;
 105 ;; Which ain't what we want.  So we hide the information needed to
 106 ;; re-make the inner pattern binding form in the lexical environment
 107 ;; object, and then introduce those identifiers via another with-syntax.
 108 ;;
 109 ;;
 110 ;; There are four different kinds of lexical bindings: normal lexicals,
 111 ;; macros, displaced lexicals, and pattern variables.  See the
 112 ;; documentation of syntax-local-binding for more info on these.
 113 ;;
 114 ;; We capture normal lexicals via `make-box', which creates a
 115 ;; case-lambda that can reference or set a variable.  These get
 116 ;; re-introduced with an identifier-syntax.
 117 ;;
 118 ;; We can't capture macros currently.  However we do recognize our own
 119 ;; macros that are actually proxying lexicals, so that nested
 120 ;; `the-environment' forms are possible.  In that case we drill down to
 121 ;; the identifier for the already-existing box, and just capture that
 122 ;; box.
 123 ;;
 124 ;; And that's it: we skip displaced lexicals, and the pattern variables
 125 ;; are discussed above.
 126 ;;
 127 (define (analyze-identifiers ids)
 128   (define (mktmp)
 129     (datum->syntax #'here (gensym "t ")))
 130   (let lp ((ids ids) (capture '()) (formals '()) (wrappers '()) (patterns '()))
 131     (cond
 132      ((null? ids)
 133       (values capture formals wrappers patterns))
 134      (else
 135       (let ((id (car ids)) (ids (cdr ids)))
 136         (call-with-values (lambda () (syntax-local-binding id))
 137           (lambda (type val)
 138             (case type
 139               ((lexical)
 140                (if (or-map (lambda (x) (bound-identifier=? x id)) formals)
 141                    (lp ids capture formals wrappers patterns)
 142                    (let ((t (mktmp)))
 143                      (lp ids
 144                          (cons #`(make-box #,id) capture)
 145                          (cons t formals)
 146                          (cons (lambda (x)
 147                                  #`(let-syntax ((#,id (identifier-syntax-from-box #,t)))
 148                                      #,x))
 149                                wrappers)
 150                          patterns))))
 151               ((displaced-lexical)
 152                (lp ids capture formals wrappers patterns))
 153               ((macro)
 154                (let ((b (procedure-property val 'identifier-syntax-box)))
 155                  (if b
 156                      (lp ids (cons b capture) (cons b formals)
 157                          (cons (lambda (x)
 158                                  #`(let-syntax ((#,id (identifier-syntax-from-box #,b)))
 159                                      #,x))
 160                                wrappers)
 161                          patterns)
 162                      (lp ids capture formals
 163                          (cons (lambda (x)
 164                                  #`(let-syntax ((#,id (unsupported-binding '#,id)))
 165                                      #,x))
 166                                wrappers)
 167                          patterns))))
 168               ((pattern-variable)
 169                (let ((t (datum->syntax id (gensym "p ")))
 170                      (nested (within-nested-ellipses id (cdr val))))
 171                  (lp ids capture formals
 172                      (cons (lambda (x)
 173                              #`(with-syntax ((#,t '#,nested))
 174                                  #,x))
 175                            wrappers)
 176                      ;; This dance is to hide these pattern variables
 177                      ;; from the expander.
 178                      (cons (list (datum->syntax #'here (syntax->datum id))
 179                                  (cdr val)
 180                                  t)
 181                            patterns))))
 182               ((ellipsis)
 183                (lp ids capture formals
 184                    (cons (lambda (x)
 185                            #`(with-ellipsis #,val #,x))
 186                          wrappers)
 187                    patterns))
 188               (else
 189                (error "what" type val))))))))))
 190
 191 (define-syntax the-environment
 192   (lambda (x)
 193     (syntax-case x ()
 194       ((the-environment)
 195        #'(the-environment the-environment))
 196       ((the-environment scope)
 197        (call-with-values (lambda ()
 198                            (analyze-identifiers
 199                             (syntax-locally-bound-identifiers #'scope)))
 200          (lambda (capture formals wrappers patterns)
 201            (define (wrap-expression x)
 202              (let lp ((x x) (wrappers wrappers))
 203                (if (null? wrappers)
 204                    x
 205                    (lp ((car wrappers) x) (cdr wrappers)))))
 206            (with-syntax (((f ...) formals)
 207                          ((c ...) capture)
 208                          (((pname plvl pformal) ...) patterns)
 209                          (wrapped (wrap-expression #'(begin #f exp))))
 210              #'(make-lexical-environment
 211                 #'scope
 212                 (lambda (exp pformal ...)
 213                   (with-syntax ((exp exp)
 214                                 (pformal pformal)
 215                                 ...)
 216                     #'(lambda (f ...)
 217                         wrapped)))
 218                 (list c ...)
 219                 (list (list 'pname plvl #'pformal) ...)))))))))
 220
 221 (define (env-module e)
 222   (cond
 223    ((lexical-environment? e) (resolve-module (syntax-module (lexenv-scope e))))
 224    ((module? e) e)
 225    (else (error "invalid lexical environment" e))))
 226
 227 (define (env-boxes e)
 228   (cond
 229    ((lexical-environment? e) (lexenv-boxes e))
 230    ((module? e) '())
 231    (else (error "invalid lexical environment" e))))
 232
 233 (define (local-wrap x e)
 234   (cond
 235    ((lexical-environment? e)
 236     (apply (lexenv-wrapper e)
 237            (datum->syntax (lexenv-scope e) x)
 238            (map (lambda (l)
 239                   (let ((name (car l))
 240                         (lvl (cadr l))
 241                         (scope (caddr l)))
 242                     (within-nested-ellipses (datum->syntax scope name) lvl)))
 243                 (lexenv-patterns e))))
 244    ((module? e) #`(lambda () #f #,x))
 245    (else (error "invalid lexical environment" e))))
 246
 247 (define (local-eval x e)
 248   "Evaluate the expression @var{x} within the lexical environment @var{e}."
 249   (apply (eval (local-wrap x e) (env-module e))
 250          (env-boxes e)))
 251
 252 (define* (local-compile x e #:key (opts '()))
 253   "Compile and evaluate the expression @var{x} within the lexical
 254 environment @var{e}."
 255   (apply (compile (local-wrap x e) #:env (env-module e)
 256                   #:from 'scheme #:opts opts)
 257          (env-boxes e)))