[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
01/01: DRAFT gexp: Preserve scope across stages.
|
From: |
Ludovic Courtès |
|
Subject: |
01/01: DRAFT gexp: Preserve scope across stages. |
|
Date: |
Wed, 5 Jul 2017 18:00:44 -0400 (EDT) |
civodul pushed a commit to branch wip-gexp-hygiene
in repository guix.
commit c18c53117fa527ea34f8386ad344bb0df0113f67
Author: Ludovic Courtès <address@hidden>
Date: Wed Jul 5 23:28:58 2017 +0200
DRAFT gexp: Preserve scope across stages.
DRAFT: Needs more tests and more testing.
* guix/gexp.scm (gexp)[lookup-binding, generate-bindings]
[syntax-uid, alpha-rename]: New procedures.
Call 'alpha-rename' before doing anything else.
* tests/gexp.scm ("hygiene, eval", "hygiene, define")
("hygiene, shadowed syntax", "hygiene, quote"): New tests.
---
guix/gexp.scm | 181 ++++++++++++++++++++++++++++++++++++++++++++++++++++++++-
tests/gexp.scm | 58 ++++++++++++++++++
2 files changed, 237 insertions(+), 2 deletions(-)
diff --git a/guix/gexp.scm b/guix/gexp.scm
index d9c4cb4..79b1c5a 100644
--- a/guix/gexp.scm
+++ b/guix/gexp.scm
@@ -905,11 +905,188 @@ environment."
#,(substitute-references #'exp substs)))
(x #''x)))
+ (define (lookup-binding id env)
+ ;; Lookup ID in ENV. Return its corresponding generated identifier or
+ ;; #f.
+ (any (match-lambda
+ ((x renamed)
+ (and (bound-identifier=? x id)
+ renamed)))
+ env))
+
+ (define (generate-bindings lst seed env)
+ ;; Like 'generate-temporaries', but use SEED and ENV as extra data to
+ ;; generate unique identifiers in a deterministic way.
+ (let ((len (length env)))
+ (map (lambda (binding)
+ (datum->syntax
+ binding
+ (string->symbol (format #f "~a-~a-~a"
+ (syntax->datum binding)
+ (number->string seed 16)
+ len))))
+ lst)))
+
+ (define (syntax-uid s)
+ ;; Return a unique numeric identifier for S.
+ (hash s 2147483648))
+
+ (define* (alpha-rename stx env stage
+ #:optional (quoting 0)
+ (uid (syntax-uid s)))
+ ;; Perform alpha-renaming of all the identifiers introduced in S, using
+ ;; ENV as the lexical environment. The goal is to preserve scope across
+ ;; stages, as illustrated by Kiselyov et al. in MetaScheme. Use UID as
+ ;; a stem when generating unique identifiers.
+ (syntax-case stx (gexp ungexp ungexp-native
+ ungexp-splicing ungexp-native-splicing
+ quote quasiquote unquote
+ lambda let let* letrec define begin)
+ ((proc arg ...)
+ (or (not (identifier? #'proc))
+ (lookup-binding #'proc env))
+ #`(#,(alpha-rename #'proc env stage quoting)
+ #,@(map (lambda (arg)
+ (alpha-rename arg env stage quoting))
+ #'(arg ...))))
+ ((quote exp)
+ #'(quote exp))
+ ((quasiquote exp)
+ #`(quasiquote #,(alpha-rename #'exp env stage
+ (+ quoting 1))))
+ ((unquote exp)
+ #`(unquote #,(alpha-rename #'exp env stage (- quoting 1))))
+ ;; TODO: 'syntax', 'unsyntax', etc.
+ ((gexp exp rest ...)
+ #`(gexp #,(alpha-rename #'exp env (+ stage 1) quoting)
+ rest ...))
+ ((ungexp exp rest ...)
+ #`(ungexp #,(alpha-rename #'exp env (- stage 1) quoting)
+ rest ...))
+ ((ungexp-native exp rest ...)
+ #`(ungexp-native #,(alpha-rename #'exp env (- stage 1) quoting)
+ rest ...))
+ ((ungexp-splicing exp)
+ #`(ungexp-splicing
+ #,(alpha-rename #'exp env (- stage 1) quoting)))
+ ((ungexp-native-splicing exp)
+ #`(ungexp-native-splicing
+ #,(alpha-rename #'exp env (- stage 1) quoting)))
+ ((lambda (bindings ...) body ...)
+ (with-syntax (((formals ...)
+ (generate-bindings #'(bindings ...)
+ uid env)))
+ #`(lambda (formals ...)
+ #,(alpha-rename #'(begin body ...)
+ #`((bindings formals) ... #,@env)
+ stage quoting))))
+ ;; TODO: lambda*, case-lambda
+ ((let ((bindings values) ...) body ...)
+ (with-syntax (((renamed ...)
+ (generate-bindings #'(bindings ...)
+ (syntax-uid #'(values ...))
+ env)))
+ #`(let #,(map (lambda (renamed value)
+ #`(#,renamed #,(alpha-rename value env
+ stage quoting)))
+ #'(renamed ...)
+ #'(values ...))
+ #,(alpha-rename #'(begin body ...)
+ #`((bindings renamed) ... #,@env)
+ stage quoting))))
+ ;; TODO: named let
+ ((let* ((binding value) rest ...) body ...)
+ (alpha-rename #'(let ((binding value))
+ (let* (rest ...)
+ body ...))
+ env stage quoting))
+ ((let* () body ...)
+ (alpha-rename #'(begin body ...) env stage quoting))
+ ((letrec ((bindings values) ...) body ...)
+ (with-syntax (((renamed ...)
+ (generate-bindings #'(bindings ...)
+ (syntax-uid #'(values ...))
+ env)))
+ (let ((env #`((bindings renamed) ... #,@env)))
+ #`(letrec #,(map (lambda (renamed value)
+ #`(#,renamed #,(alpha-rename value env
+ stage quoting)))
+ #'(renamed ...)
+ #'(values ...))
+ #,(alpha-rename #'(begin body ...) env stage quoting)))))
+ ;; TODO: letrec*
+ ;; TODO: let-syntax, letrec-syntax
+ ((begin exp)
+ (alpha-rename #'exp env stage quoting))
+ ((define (proc formals ...) body ...) ;top-level
+ (with-syntax (((renamed ...)
+ (generate-bindings #'(formals ...) uid env)))
+ #`(define (proc renamed ...)
+ #,(alpha-rename #'(begin body ...)
+ #`((formals renamed) ... #,@env)
+ stage quoting))))
+ ((define id value) ;top-level
+ #`(define id
+ #,(alpha-rename #'value env stage quoting)))
+ ((begin exp ...)
+ (null? env) ;top-level
+ #`(begin #,@(map (lambda (exp)
+ (alpha-rename exp env stage quoting))
+ #'(exp ...))))
+ ((begin exp ...) ;inner 'begin'
+ (with-syntax (((bindings ...)
+ (filter-map (lambda (exp)
+ (syntax-case exp (define)
+ ((define (proc _ ...) value)
+ #'proc)
+ ((define binding value)
+ #'binding)
+ (_
+ #f)))
+ #'(exp ...))))
+ (with-syntax (((renamed ...)
+ (generate-bindings #'(bindings ...)
+ uid env)))
+ (let ((env #`((bindings renamed) ... #,@env)))
+ #`(begin
+ #,@(map (lambda (exp)
+ (syntax-case exp (define)
+ ((define (id formals ...) body ...)
+ (with-syntax ((id (lookup-binding #'id env))
+ ((renamed ...)
+ (generate-bindings #'(formals
...)
+ uid env)))
+ #`(define (id renamed ...)
+ #,(alpha-rename #'(begin body ...)
+ #`((formals renamed) ...
+ #,@env)
+ stage quoting))))
+ ((define id value)
+ #`(define #,(lookup-binding #'id env)
+ #,(alpha-rename #'value env
+ stage quoting)))
+ (_
+ (alpha-rename exp env stage quoting))))
+ #'(exp ...)))))))
+ ((proc arg ...)
+ #`(#,(alpha-rename #'proc env stage quoting)
+ #,@(map (lambda (arg)
+ (alpha-rename arg env stage quoting))
+ #'(arg ...))))
+ (id
+ (identifier? #'id)
+ (if (or (> quoting 0) (< stage 0))
+ #'id
+ (or (lookup-binding #'id env) #'id)))
+ (obj
+ #'obj)))
+
(syntax-case s (ungexp output)
((_ exp)
- (let* ((escapes (delete-duplicates (collect-escapes #'exp)))
+ (let* ((exp (alpha-rename #'exp #'() 0))
+ (escapes (delete-duplicates (collect-escapes exp)))
(formals (generate-temporaries escapes))
- (sexp (substitute-references #'exp (zip escapes formals)))
+ (sexp (substitute-references exp (zip escapes formals)))
(refs (map escape->ref escapes)))
#`(make-gexp (list #,@refs)
current-imported-modules
diff --git a/tests/gexp.scm b/tests/gexp.scm
index cf88a9d..6bdc233 100644
--- a/tests/gexp.scm
+++ b/tests/gexp.scm
@@ -984,6 +984,64 @@
'#~(foo #$bar #$baz:out #$(chbouib 42) #$@(list x y z)
#+foo #+foo:out #+(chbouib 42) #+@(list x y z)))
+(test-equal "hygiene, eval"
+ 42
+ ;; Test: (1) that 'x' in one gexp does not shadow 'x' from the other 'gexp',
+ ;; and (2) that 'x' in 'ungexp' is not mistakenly renamed.
+ (let* ((inner (lambda (x)
+ #~(let ((x 40)) (+ x #$x))))
+ (outer #~(let ((x 2))
+ #$(inner #~x))))
+ (primitive-eval (gexp->sexp* outer))))
+
+(test-assert "hygiene, define"
+ (match (gexp->sexp* #~(begin
+ ;; Top-level defines aren't renamed.
+ (define top0 0)
+ (define (top1 x) x)
+ (define (top2 x y)
+ ;; Internal define is renamed.
+ (define inner1 (* x x))
+ (define (inner2 x) (+ x y))
+ (+ inner y))))
+ (('begin
+ ('define 'top0 0)
+ ('define ('top1 x0) x0)
+ ('define ('top2 x1 y1)
+ ('begin
+ ('define inner1 ('* x1 x1))
+ ('define (inner2 x2) ('+ x2 y1))
+ ('+ inner y1))))
+ (and (not (eq? x0 'x))
+ (not (eq? x1 'x))
+ (not (eq? y1 'y))
+ (not (eq? inner1 'inner1))
+ (not (eq? inner2 'inner2))
+ (not (eq? x2 x1))))))
+
+(test-assert "hygiene, shadowed syntax"
+ (match (gexp->sexp* #~(lambda (lambda x)
+ (lambda (x) x)))
+ (('lambda (arg x)
+ (arg (x) x))
+ (and (not (eq? arg 'lambda))
+ (not (eq? x 'x))))))
+
+(test-assert "hygiene, quote"
+ (match (gexp->sexp* #~(lambda (x y z)
+ (list '(x y z)
+ `(x ,x (,y ,z) z))))
+ (('lambda (x0 y0 z0)
+ ('list ('quote ('x 'y 'z))
+ ('quasiquote
+ ('x ('unquote x0)
+ (('unquote y0)
+ ('unquote z0))
+ 'z))))
+ (and (not (eq? x0 'x))
+ (not (eq? y0 'y))
+ (not (eq? z0 'z))))))
+
(test-end "gexp")
;; Local Variables: