mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-05-20 03:30:27 +02:00
Code Activity

Document datum->syntax extensions

Browse source 
* doc/ref/api-macros.texi (Syntax Case): Document that template-id can
  be false, and document srcloc.
* module/ice-9/psyntax-pp.scm: Regenerate.
* module/ice-9/psyntax.scm (syntax?): Allow the lexical context to be
  null.  Allow srcloc to be a source properties alist.  Inspired by
  Racket.
This commit is contained in:
Andy Wingo 2021-02-21 11:27:32 +01:00
parent 50d3dd83f0
commit 1bba859000
3 changed files with 80 additions and 62 deletions
Download patch file Download diff file Expand all files Collapse all files

18
doc/ref/api-macros.texi
View file

@ -1,6 +1,6 @@
@c -*-texinfo-*- @c -*-texinfo-*-
@c This is part of the GNU Guile Reference Manual. @c This is part of the GNU Guile Reference Manual.
@c Copyright (C) 1996, 1997, 2000-2004, 2009-2015, 2018 @c Copyright (C) 1996, 1997, 2000-2004, 2009-2015, 2018, 2021
@c Free Software Foundation, Inc. @c Free Software Foundation, Inc.
@c See the file guile.texi for copying conditions. @c See the file guile.texi for copying conditions.
@ -638,9 +638,19 @@ won't have access to the binding of @code{it}.
But they can, if we explicitly introduce a binding via @code{datum->syntax}. But they can, if we explicitly introduce a binding via @code{datum->syntax}.
@deffn {Scheme Procedure} datum->syntax template-id datum @deffn {Scheme Procedure} datum->syntax template-id datum [srcloc]
Create a syntax object that wraps @var{datum}, within the lexical context Create a syntax object that wraps @var{datum}, within the lexical
corresponding to the identifier @var{template-id}. context corresponding to the identifier @var{template-id}. If
@var{template-id} is false, the datum will have no lexical context
information.
Syntax objects have an associated source location. @xref{Source
Properties}. If a syntax object is passed as @var{srcloc}, the
resulting syntax object will have the source properties of @var{srcloc}.
Otherwise if @var{srcloc} is a source properties alist, those will be
the source properties of the resulting syntax object. Otherwise if
@var{srcloc} is false, the source properties are computed as
@code{(source-properties @var{datum})}.
@end deffn @end deffn
For completeness, we should mention that it is possible to strip the metadata For completeness, we should mention that it is possible to strip the metadata

107
module/ice-9/psyntax-pp.scm
View file

@ -991,11 +991,11 @@
(source-wrap e w (cdr w) mod) (source-wrap e w (cdr w) mod)
x)) x))
(else (decorate-source x s)))))) (else (decorate-source x s))))))
(let* ((t-680b775fb37a463-d74 transformer-environment) (let* ((t-680b775fb37a463-d78 transformer-environment)
(t-680b775fb37a463-d75 (lambda (k) (k e r w s rib mod)))) (t-680b775fb37a463-d79 (lambda (k) (k e r w s rib mod))))
(with-fluid* (with-fluid*
t-680b775fb37a463-d74 t-680b775fb37a463-d78
t-680b775fb37a463-d75 t-680b775fb37a463-d79
(lambda () (lambda ()
(rebuild-macro-output (rebuild-macro-output
(p (source-wrap e (anti-mark w) s mod)) (p (source-wrap e (anti-mark w) s mod))
@ -1562,11 +1562,11 @@
s s
mod mod
get-formals get-formals
(map (lambda (tmp-680b775fb37a463-fe5 (map (lambda (tmp-680b775fb37a463-fe9
tmp-680b775fb37a463-fe4 tmp-680b775fb37a463-fe8
tmp-680b775fb37a463-fe3) tmp-680b775fb37a463-fe7)
(cons tmp-680b775fb37a463-fe3 (cons tmp-680b775fb37a463-fe7
(cons tmp-680b775fb37a463-fe4 tmp-680b775fb37a463-fe5))) (cons tmp-680b775fb37a463-fe8 tmp-680b775fb37a463-fe9)))
e2* e2*
e1* e1*
args*))) args*)))
@ -1864,11 +1864,11 @@
(apply (lambda (args e1 e2) (apply (lambda (args e1 e2)
(build-it (build-it
'() '()
(map (lambda (tmp-680b775fb37a463-69c (map (lambda (tmp-680b775fb37a463-6a0
tmp-680b775fb37a463-69b tmp-680b775fb37a463-69f
tmp-680b775fb37a463-69a) tmp-680b775fb37a463-69e)
(cons tmp-680b775fb37a463-69a (cons tmp-680b775fb37a463-69e
(cons tmp-680b775fb37a463-69b tmp-680b775fb37a463-69c))) (cons tmp-680b775fb37a463-69f tmp-680b775fb37a463-6a0)))
e2 e2
e1 e1
args))) args)))
@ -1880,11 +1880,11 @@
(apply (lambda (docstring args e1 e2) (apply (lambda (docstring args e1 e2)
(build-it (build-it
(list (cons 'documentation (syntax->datum docstring))) (list (cons 'documentation (syntax->datum docstring)))
(map (lambda (tmp-680b775fb37a463-6b2 (map (lambda (tmp-680b775fb37a463-6b6
tmp-680b775fb37a463-6b1 tmp-680b775fb37a463-6b5
tmp-680b775fb37a463-6b0) tmp-680b775fb37a463-6b4)
(cons tmp-680b775fb37a463-6b0 (cons tmp-680b775fb37a463-6b4
(cons tmp-680b775fb37a463-6b1 tmp-680b775fb37a463-6b2))) (cons tmp-680b775fb37a463-6b5 tmp-680b775fb37a463-6b6)))
e2 e2
e1 e1
args))) args)))
@ -1907,9 +1907,9 @@
(apply (lambda (args e1 e2) (apply (lambda (args e1 e2)
(build-it (build-it
'() '()
(map (lambda (tmp-680b775fb37a463-2 tmp-680b775fb37a463-1 tmp-680b775fb37a463) (map (lambda (tmp-680b775fb37a463-66a tmp-680b775fb37a463-1 tmp-680b775fb37a463)
(cons tmp-680b775fb37a463 (cons tmp-680b775fb37a463
(cons tmp-680b775fb37a463-1 tmp-680b775fb37a463-2))) (cons tmp-680b775fb37a463-1 tmp-680b775fb37a463-66a)))
e2 e2
e1 e1
args))) args)))
@ -1921,11 +1921,9 @@
(apply (lambda (docstring args e1 e2) (apply (lambda (docstring args e1 e2)
(build-it (build-it
(list (cons 'documentation (syntax->datum docstring))) (list (cons 'documentation (syntax->datum docstring)))
(map (lambda (tmp-680b775fb37a463-67c (map (lambda (tmp-680b775fb37a463 tmp-680b775fb37a463-67f tmp-680b775fb37a463-67e)
tmp-680b775fb37a463-67b (cons tmp-680b775fb37a463-67e
tmp-680b775fb37a463-67a) (cons tmp-680b775fb37a463-67f tmp-680b775fb37a463)))
(cons tmp-680b775fb37a463-67a
(cons tmp-680b775fb37a463-67b tmp-680b775fb37a463-67c)))
e2 e2
e1 e1
args))) args)))
@ -2426,9 +2424,13 @@
(lambda* (id datum #:optional (srcloc #f)) (lambda* (id datum #:optional (srcloc #f))
(make-syntax (make-syntax
datum datum
(syntax-wrap id) (if id (syntax-wrap id) '((top)))
(if id
(syntax-module id) (syntax-module id)
(if srcloc (syntax-source srcloc) (source-properties datum))))) (cons 'hygiene (module-name (current-module))))
(cond ((not srcloc) (source-properties datum))
((and (list? srcloc) (and-map pair? srcloc)) srcloc)
(else (syntax-source srcloc))))))
(set! syntax->datum (lambda (x) (strip x '(())))) (set! syntax->datum (lambda (x) (strip x '(()))))
(set! generate-temporaries (set! generate-temporaries
(lambda (ls) (lambda (ls)
@ -2855,11 +2857,11 @@
#f #f
k k
(list docstring) (list docstring)
(map (lambda (tmp-680b775fb37a463-112b (map (lambda (tmp-680b775fb37a463-112f
tmp-680b775fb37a463-112a tmp-680b775fb37a463-112e
tmp-680b775fb37a463) tmp-680b775fb37a463-112d)
(list (cons tmp-680b775fb37a463 tmp-680b775fb37a463-112a) (list (cons tmp-680b775fb37a463-112d tmp-680b775fb37a463-112e)
tmp-680b775fb37a463-112b)) tmp-680b775fb37a463-112f))
template template
pattern pattern
keyword))) keyword)))
@ -3066,8 +3068,8 @@
(apply (lambda (p) (apply (lambda (p)
(if (= lev 0) (if (= lev 0)
(quasiappend (quasiappend
(map (lambda (tmp-680b775fb37a463) (map (lambda (tmp-680b775fb37a463-121c)
(list "value" tmp-680b775fb37a463)) (list "value" tmp-680b775fb37a463-121c))
p) p)
(quasi q lev)) (quasi q lev))
(quasicons (quasicons
@ -3101,8 +3103,7 @@
(apply (lambda (p) (apply (lambda (p)
(if (= lev 0) (if (= lev 0)
(quasilist* (quasilist*
(map (lambda (tmp-680b775fb37a463-122e) (map (lambda (tmp-680b775fb37a463) (list "value" tmp-680b775fb37a463))
(list "value" tmp-680b775fb37a463-122e))
p) p)
(vquasi q lev)) (vquasi q lev))
(quasicons (quasicons
@ -3212,8 +3213,7 @@
(let ((tmp-1 ls)) (let ((tmp-1 ls))
(let ((tmp ($sc-dispatch tmp-1 'each-any))) (let ((tmp ($sc-dispatch tmp-1 'each-any)))
(if tmp (if tmp
(apply (lambda (t-680b775fb37a463-127c) (apply (lambda (t-680b775fb37a463) (cons "vector" t-680b775fb37a463))
(cons "vector" t-680b775fb37a463-127c))
tmp) tmp)
(syntax-violation (syntax-violation
#f #f
@ -3223,7 +3223,8 @@
(let ((tmp-1 ($sc-dispatch tmp '(#(atom "quote") each-any)))) (let ((tmp-1 ($sc-dispatch tmp '(#(atom "quote") each-any))))
(if tmp-1 (if tmp-1
(apply (lambda (y) (apply (lambda (y)
(k (map (lambda (tmp-680b775fb37a463) (list "quote" tmp-680b775fb37a463)) (k (map (lambda (tmp-680b775fb37a463-128c)
(list "quote" tmp-680b775fb37a463-128c))
y))) y)))
tmp-1) tmp-1)
(let ((tmp-1 ($sc-dispatch tmp '(#(atom "list") . each-any)))) (let ((tmp-1 ($sc-dispatch tmp '(#(atom "list") . each-any))))
@ -3234,8 +3235,8 @@
(apply (lambda (y z) (f z (lambda (ls) (k (append y ls))))) tmp-1) (apply (lambda (y z) (f z (lambda (ls) (k (append y ls))))) tmp-1)
(let ((else tmp)) (let ((else tmp))
(let ((tmp x)) (let ((tmp x))
(let ((t-680b775fb37a463 tmp)) (let ((t-680b775fb37a463-129b tmp))
(list "list->vector" t-680b775fb37a463))))))))))))))))) (list "list->vector" t-680b775fb37a463-129b)))))))))))))))))
(emit (lambda (x) (emit (lambda (x)
(let ((tmp x)) (let ((tmp x))
(let ((tmp-1 ($sc-dispatch tmp '(#(atom "quote") any)))) (let ((tmp-1 ($sc-dispatch tmp '(#(atom "quote") any))))
@ -3248,9 +3249,9 @@
(let ((tmp-1 (map emit x))) (let ((tmp-1 (map emit x)))
(let ((tmp ($sc-dispatch tmp-1 'each-any))) (let ((tmp ($sc-dispatch tmp-1 'each-any)))
(if tmp (if tmp
(apply (lambda (t-680b775fb37a463-12a6) (apply (lambda (t-680b775fb37a463-12aa)
(cons (make-syntax 'list '((top)) '(hygiene guile)) (cons (make-syntax 'list '((top)) '(hygiene guile))
t-680b775fb37a463-12a6)) t-680b775fb37a463-12aa))
tmp) tmp)
(syntax-violation (syntax-violation
#f #f
@ -3266,10 +3267,10 @@
(let ((tmp-1 (list (emit (car x*)) (f (cdr x*))))) (let ((tmp-1 (list (emit (car x*)) (f (cdr x*)))))
(let ((tmp ($sc-dispatch tmp-1 '(any any)))) (let ((tmp ($sc-dispatch tmp-1 '(any any))))
(if tmp (if tmp
(apply (lambda (t-680b775fb37a463-12ba t-680b775fb37a463-12b9) (apply (lambda (t-680b775fb37a463-12be t-680b775fb37a463-12bd)
(list (make-syntax 'cons '((top)) '(hygiene guile)) (list (make-syntax 'cons '((top)) '(hygiene guile))
t-680b775fb37a463-12ba t-680b775fb37a463-12be
t-680b775fb37a463-12b9)) t-680b775fb37a463-12bd))
tmp) tmp)
(syntax-violation (syntax-violation
#f #f
@ -3282,9 +3283,9 @@
(let ((tmp-1 (map emit x))) (let ((tmp-1 (map emit x)))
(let ((tmp ($sc-dispatch tmp-1 'each-any))) (let ((tmp ($sc-dispatch tmp-1 'each-any)))
(if tmp (if tmp
(apply (lambda (t-680b775fb37a463-12c6) (apply (lambda (t-680b775fb37a463-12ca)
(cons (make-syntax 'append '((top)) '(hygiene guile)) (cons (make-syntax 'append '((top)) '(hygiene guile))
t-680b775fb37a463-12c6)) t-680b775fb37a463-12ca))
tmp) tmp)
(syntax-violation (syntax-violation
#f #f
@ -3297,9 +3298,9 @@
(let ((tmp-1 (map emit x))) (let ((tmp-1 (map emit x)))
(let ((tmp ($sc-dispatch tmp-1 'each-any))) (let ((tmp ($sc-dispatch tmp-1 'each-any)))
(if tmp (if tmp
(apply (lambda (t-680b775fb37a463-12d2) (apply (lambda (t-680b775fb37a463-12d6)
(cons (make-syntax 'vector '((top)) '(hygiene guile)) (cons (make-syntax 'vector '((top)) '(hygiene guile))
t-680b775fb37a463-12d2)) t-680b775fb37a463-12d6))
tmp) tmp)
(syntax-violation (syntax-violation
#f #f
@ -3310,9 +3311,9 @@
(if tmp-1 (if tmp-1
(apply (lambda (x) (apply (lambda (x)
(let ((tmp (emit x))) (let ((tmp (emit x)))
(let ((t-680b775fb37a463-12de tmp)) (let ((t-680b775fb37a463-12e2 tmp))
(list (make-syntax 'list->vector '((top)) '(hygiene guile)) (list (make-syntax 'list->vector '((top)) '(hygiene guile))
t-680b775fb37a463-12de)))) t-680b775fb37a463-12e2))))
tmp-1) tmp-1)
(let ((tmp-1 ($sc-dispatch tmp '(#(atom "value") any)))) (let ((tmp-1 ($sc-dispatch tmp '(#(atom "value") any))))
(if tmp-1 (if tmp-1

15
module/ice-9/psyntax.scm
View file

@ -2764,10 +2764,17 @@
(set! datum->syntax (set! datum->syntax
(lambda* (id datum #:optional srcloc) (lambda* (id datum #:optional srcloc)
(make-syntax datum (syntax-wrap id) (syntax-module id) (make-syntax datum
(if srcloc (if id
(syntax-source srcloc) (syntax-wrap id)
(source-properties datum))))) top-wrap)
(if id
(syntax-module id)
(cons 'hygiene (module-name (current-module))))
(cond
((not srcloc) (source-properties datum))
((and (list? srcloc) (and-map pair? srcloc)) srcloc)
(else (syntax-source srcloc))))))
(set! syntax->datum (set! syntax->datum
;; accepts any object, since syntax objects may consist partially ;; accepts any object, since syntax objects may consist partially