mirror of
https://git.savannah.gnu.org/git/guix.git
synced 2025-01-31 06:46:50 +01:00
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.
This commit is contained in:
Ludovic Courtès
parent
425ab478ac
commit
c18c53117f
2 changed files with 237 additions and 2 deletions
181
guix/gexp.scm
181
guix/gexp.scm
|
|
@ -905,11 +905,188 @@ (define (substitute-references exp substs)
|
||||||
#,(substitute-references #'exp substs)))
|
#,(substitute-references #'exp substs)))
|
||||||
(x #''x)))
|
(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)
|
(syntax-case s (ungexp output)
|
||||||
((_ exp)
|
((_ exp)
|
||||||
(let* ((escapes (delete-duplicates (collect-escapes #'exp)))
|
(let* ((exp (alpha-rename #'exp #'() 0))
|
||||||
|
(escapes (delete-duplicates (collect-escapes exp)))
|
||||||
(formals (generate-temporaries escapes))
|
(formals (generate-temporaries escapes))
|
||||||
(sexp (substitute-references #'exp (zip escapes formals)))
|
(sexp (substitute-references exp (zip escapes formals)))
|
||||||
(refs (map escape->ref escapes)))
|
(refs (map escape->ref escapes)))
|
||||||
#`(make-gexp (list #,@refs)
|
#`(make-gexp (list #,@refs)
|
||||||
current-imported-modules
|
current-imported-modules
|
||||||
|
|
|
||||||
|
|
@ -984,6 +984,64 @@ (define shebang
|
||||||
'#~(foo #$bar #$baz:out #$(chbouib 42) #$@(list x y z)
|
'#~(foo #$bar #$baz:out #$(chbouib 42) #$@(list x y z)
|
||||||
#+foo #+foo: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")
|
(test-end "gexp")
|
||||||
|
|
||||||
;; Local Variables:
|
;; Local Variables:
|
||||||
|
|
|
||||||
Loading…
Reference in a new issue