local-eval.scm 9.8 KB

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