From c18c53117fa527ea34f8386ad344bb0df0113f67 Mon Sep 17 00:00:00 2001
From: Ludovic Courtès <ludo@gnu.org>
Date: Wed, 5 Jul 2017 23:28:58 +0200
Subject: 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 d9c4cb461e..79b1c5a35f 100644
--- a/guix/gexp.scm
+++ b/guix/gexp.scm
@@ -905,11 +905,188 @@ (define (substitute-references exp substs)
                  #,(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 cf88a9db80..6bdc233170 100644
--- a/tests/gexp.scm
+++ b/tests/gexp.scm
@@ -984,6 +984,64 @@ (define shebang
   '#~(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:
-- 
cgit v1.2.3