mirror/guix
1
0
Fork 0
mirror of https://git.savannah.gnu.org/git/guix.git synced 2025-01-18 13:36:36 +01:00
Code Issues Projects Releases Packages Wiki Activity Actions

DRAFT gexp: Preserve scope across stages.

Browse source 
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 2017-07-05 23:28:58 +02:00
parent 425ab478ac
commit c18c53117f
No known key found for this signature in database
GPG key ID: 090B11993D9AEBB5
2 changed files with 237 additions and 2 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

181
guix/gexp.scm
View file

@ -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

58
tests/gexp.scm
View file

@ -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: