2 files changed, 237 insertions, 2 deletions
diff --git a/guix/gexp.scm b/guix/gexp.scm
index d9c4cb461ee..79b1c5a35f0 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 cf88a9db807..6bdc2331706 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:

diff --git a/guix/gexp.scm b/guix/gexp.scm index d9c4cb461ee..79b1c5a35f0 100644 --- a/guix/gexp.scm +++ b/guix/gexp.scm
@@ -905,11 +905,188 @@ environment."
905	#,(substitute-references #'exp substs)))	905	#,(substitute-references #'exp substs)))
906	(x #''x)))	906	(x #''x)))
907		907
		908	(define (lookup-binding id env)
		909	;; Lookup ID in ENV. Return its corresponding generated identifier or
		910	;; #f.
		911	(any (match-lambda
		912	((x renamed)
		913	(and (bound-identifier=? x id)
		914	renamed)))
		915	env))
		916
		917	(define (generate-bindings lst seed env)
		918	;; Like 'generate-temporaries', but use SEED and ENV as extra data to
		919	;; generate unique identifiers in a deterministic way.
		920	(let ((len (length env)))
		921	(map (lambda (binding)
		922	(datum->syntax
		923	binding
		924	(string->symbol (format #f "~a-~a-~a"
		925	(syntax->datum binding)
		926	(number->string seed 16)
		927	len))))
		928	lst)))
		929
		930	(define (syntax-uid s)
		931	;; Return a unique numeric identifier for S.
		932	(hash s 2147483648))
		933
		934	(define* (alpha-rename stx env stage
		935	#:optional (quoting 0)
		936	(uid (syntax-uid s)))
		937	;; Perform alpha-renaming of all the identifiers introduced in S, using
		938	;; ENV as the lexical environment. The goal is to preserve scope across
		939	;; stages, as illustrated by Kiselyov et al. in MetaScheme. Use UID as
		940	;; a stem when generating unique identifiers.
		941	(syntax-case stx (gexp ungexp ungexp-native
		942	ungexp-splicing ungexp-native-splicing
		943	quote quasiquote unquote
		944	lambda let let* letrec define begin)
		945	((proc arg ...)
		946	(or (not (identifier? #'proc))
		947	(lookup-binding #'proc env))
		948	#`(#,(alpha-rename #'proc env stage quoting)
		949	#,@(map (lambda (arg)
		950	(alpha-rename arg env stage quoting))
		951	#'(arg ...))))
		952	((quote exp)
		953	#'(quote exp))
		954	((quasiquote exp)
		955	#`(quasiquote #,(alpha-rename #'exp env stage
		956	(+ quoting 1))))
		957	((unquote exp)
		958	#`(unquote #,(alpha-rename #'exp env stage (- quoting 1))))
		959	;; TODO: 'syntax', 'unsyntax', etc.
		960	((gexp exp rest ...)
		961	#`(gexp #,(alpha-rename #'exp env (+ stage 1) quoting)
		962	rest ...))
		963	((ungexp exp rest ...)
		964	#`(ungexp #,(alpha-rename #'exp env (- stage 1) quoting)
		965	rest ...))
		966	((ungexp-native exp rest ...)
		967	#`(ungexp-native #,(alpha-rename #'exp env (- stage 1) quoting)
		968	rest ...))
		969	((ungexp-splicing exp)
		970	#`(ungexp-splicing
		971	#,(alpha-rename #'exp env (- stage 1) quoting)))
		972	((ungexp-native-splicing exp)
		973	#`(ungexp-native-splicing
		974	#,(alpha-rename #'exp env (- stage 1) quoting)))
		975	((lambda (bindings ...) body ...)
		976	(with-syntax (((formals ...)
		977	(generate-bindings #'(bindings ...)
		978	uid env)))
		979	#`(lambda (formals ...)
		980	#,(alpha-rename #'(begin body ...)
		981	#`((bindings formals) ... #,@env)
		982	stage quoting))))
		983	;; TODO: lambda*, case-lambda
		984	((let ((bindings values) ...) body ...)
		985	(with-syntax (((renamed ...)
		986	(generate-bindings #'(bindings ...)
		987	(syntax-uid #'(values ...))
		988	env)))
		989	#`(let #,(map (lambda (renamed value)
		990	#`(#,renamed #,(alpha-rename value env
		991	stage quoting)))
		992	#'(renamed ...)
		993	#'(values ...))
		994	#,(alpha-rename #'(begin body ...)
		995	#`((bindings renamed) ... #,@env)
		996	stage quoting))))
		997	;; TODO: named let
		998	((let* ((binding value) rest ...) body ...)
		999	(alpha-rename #'(let ((binding value))
		1000	(let* (rest ...)
		1001	body ...))
		1002	env stage quoting))
		1003	((let* () body ...)
		1004	(alpha-rename #'(begin body ...) env stage quoting))
		1005	((letrec ((bindings values) ...) body ...)
		1006	(with-syntax (((renamed ...)
		1007	(generate-bindings #'(bindings ...)
		1008	(syntax-uid #'(values ...))
		1009	env)))
		1010	(let ((env #`((bindings renamed) ... #,@env)))
		1011	#`(letrec #,(map (lambda (renamed value)
		1012	#`(#,renamed #,(alpha-rename value env
		1013	stage quoting)))
		1014	#'(renamed ...)
		1015	#'(values ...))
		1016	#,(alpha-rename #'(begin body ...) env stage quoting)))))
		1017	;; TODO: letrec*
		1018	;; TODO: let-syntax, letrec-syntax
		1019	((begin exp)
		1020	(alpha-rename #'exp env stage quoting))
		1021	((define (proc formals ...) body ...) ;top-level
		1022	(with-syntax (((renamed ...)
		1023	(generate-bindings #'(formals ...) uid env)))
		1024	#`(define (proc renamed ...)
		1025	#,(alpha-rename #'(begin body ...)
		1026	#`((formals renamed) ... #,@env)
		1027	stage quoting))))
		1028	((define id value) ;top-level
		1029	#`(define id
		1030	#,(alpha-rename #'value env stage quoting)))
		1031	((begin exp ...)
		1032	(null? env) ;top-level
		1033	#`(begin #,@(map (lambda (exp)
		1034	(alpha-rename exp env stage quoting))
		1035	#'(exp ...))))
		1036	((begin exp ...) ;inner 'begin'
		1037	(with-syntax (((bindings ...)
		1038	(filter-map (lambda (exp)
		1039	(syntax-case exp (define)
		1040	((define (proc _ ...) value)
		1041	#'proc)
		1042	((define binding value)
		1043	#'binding)
		1044	(_
		1045	#f)))
		1046	#'(exp ...))))
		1047	(with-syntax (((renamed ...)
		1048	(generate-bindings #'(bindings ...)
		1049	uid env)))
		1050	(let ((env #`((bindings renamed) ... #,@env)))
		1051	#`(begin
		1052	#,@(map (lambda (exp)
		1053	(syntax-case exp (define)
		1054	((define (id formals ...) body ...)
		1055	(with-syntax ((id (lookup-binding #'id env))
		1056	((renamed ...)
		1057	(generate-bindings #'(formals ...)
		1058	uid env)))
		1059	#`(define (id renamed ...)
		1060	#,(alpha-rename #'(begin body ...)
		1061	#`((formals renamed) ...
		1062	#,@env)
		1063	stage quoting))))
		1064	((define id value)
		1065	#`(define #,(lookup-binding #'id env)
		1066	#,(alpha-rename #'value env
		1067	stage quoting)))
		1068	(_
		1069	(alpha-rename exp env stage quoting))))
		1070	#'(exp ...)))))))
		1071	((proc arg ...)
		1072	#`(#,(alpha-rename #'proc env stage quoting)
		1073	#,@(map (lambda (arg)
		1074	(alpha-rename arg env stage quoting))
		1075	#'(arg ...))))
		1076	(id
		1077	(identifier? #'id)
		1078	(if (or (> quoting 0) (< stage 0))
		1079	#'id
		1080	(or (lookup-binding #'id env) #'id)))
		1081	(obj
		1082	#'obj)))
		1083
908	(syntax-case s (ungexp output)	1084	(syntax-case s (ungexp output)
909	((_ exp)	1085	((_ exp)
910	(let* ((escapes (delete-duplicates (collect-escapes #'exp)))	1086	(let* ((exp (alpha-rename #'exp #'() 0))
		1087	(escapes (delete-duplicates (collect-escapes exp)))
911	(formals (generate-temporaries escapes))	1088	(formals (generate-temporaries escapes))
912	(sexp (substitute-references #'exp (zip escapes formals)))	1089	(sexp (substitute-references exp (zip escapes formals)))
913	(refs (map escape->ref escapes)))	1090	(refs (map escape->ref escapes)))
914	#`(make-gexp (list #,@refs)	1091	#`(make-gexp (list #,@refs)
915	current-imported-modules	1092	current-imported-modules


diff --git a/tests/gexp.scm b/tests/gexp.scm index cf88a9db807..6bdc2331706 100644 --- a/tests/gexp.scm +++ b/tests/gexp.scm
@@ -984,6 +984,64 @@
984	'#~(foo #$bar #$baz:out #$(chbouib 42) #$@(list x y z)	984	'#~(foo #$bar #$baz:out #$(chbouib 42) #$@(list x y z)
985	#+foo #+foo:out #+(chbouib 42) #+@(list x y z)))	985	#+foo #+foo:out #+(chbouib 42) #+@(list x y z)))
986		986
		987	(test-equal "hygiene, eval"
		988	42
		989	;; Test: (1) that 'x' in one gexp does not shadow 'x' from the other 'gexp',
		990	;; and (2) that 'x' in 'ungexp' is not mistakenly renamed.
		991	(let* ((inner (lambda (x)
		992	#~(let ((x 40)) (+ x #$x))))
		993	(outer #~(let ((x 2))
		994	#$(inner #~x))))
		995	(primitive-eval (gexp->sexp* outer))))
		996
		997	(test-assert "hygiene, define"
		998	(match (gexp->sexp* #~(begin
		999	;; Top-level defines aren't renamed.
		1000	(define top0 0)
		1001	(define (top1 x) x)
		1002	(define (top2 x y)
		1003	;; Internal define is renamed.
		1004	(define inner1 (* x x))
		1005	(define (inner2 x) (+ x y))
		1006	(+ inner y))))
		1007	(('begin
		1008	('define 'top0 0)
		1009	('define ('top1 x0) x0)
		1010	('define ('top2 x1 y1)
		1011	('begin
		1012	('define inner1 ('* x1 x1))
		1013	('define (inner2 x2) ('+ x2 y1))
		1014	('+ inner y1))))
		1015	(and (not (eq? x0 'x))
		1016	(not (eq? x1 'x))
		1017	(not (eq? y1 'y))
		1018	(not (eq? inner1 'inner1))
		1019	(not (eq? inner2 'inner2))
		1020	(not (eq? x2 x1))))))
		1021
		1022	(test-assert "hygiene, shadowed syntax"
		1023	(match (gexp->sexp* #~(lambda (lambda x)
		1024	(lambda (x) x)))
		1025	(('lambda (arg x)
		1026	(arg (x) x))
		1027	(and (not (eq? arg 'lambda))
		1028	(not (eq? x 'x))))))
		1029
		1030	(test-assert "hygiene, quote"
		1031	(match (gexp->sexp* #~(lambda (x y z)
		1032	(list '(x y z)
		1033	`(x ,x (,y ,z) z))))
		1034	(('lambda (x0 y0 z0)
		1035	('list ('quote ('x 'y 'z))
		1036	('quasiquote
		1037	('x ('unquote x0)
		1038	(('unquote y0)
		1039	('unquote z0))
		1040	'z))))
		1041	(and (not (eq? x0 'x))
		1042	(not (eq? y0 'y))
		1043	(not (eq? z0 'z))))))
		1044
987	(test-end "gexp")	1045	(test-end "gexp")
988		1046
989	;; Local Variables:	1047	;; Local Variables: