mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-06-29 22:40:34 +02:00
Code Activity

syntax-case treats _ as placeholder

Browse source 
* module/ice-9/psyntax.scm (underscore?): New helper, like ellipsis?.
  (syntax-case): Treat the _ pattern as a matches-all pattern,
  disallowing it from the keyword list. Another well-thought part of the
  R6RS.
  ($sc-dispatch): Dispatch _ patterns.

* module/ice-9/psyntax-pp.scm: Regenerated.

* test-suite/tests/syncase.test ("_ is a placeholder"): Add a test.
This commit is contained in:
Andy Wingo 2010-06-21 20:54:14 +02:00
parent 233b5d892c
commit b78d91d517
3 changed files with 8640 additions and 7057 deletions
Download patch file Download diff file Expand all files Collapse all files

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

File diff suppressed because it is too large Load diff

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

@ -1539,6 +1539,11 @@
(and (nonsymbol-id? x) (and (nonsymbol-id? x)
(free-id=? x #'(... ...))))) (free-id=? x #'(... ...)))))
(define underscore?
(lambda (x)
(and (nonsymbol-id? x)
(free-id=? x #'_))))
(define lambda-formals (define lambda-formals
(lambda (orig-args) (lambda (orig-args)
(define (req args rreq) (define (req args rreq)
@ -2272,9 +2277,13 @@
(define cvt (define cvt
(lambda (p n ids) (lambda (p n ids)
(if (id? p) (if (id? p)
(if (bound-id-member? p keys) (cond
(values (vector 'free-id p) ids) ((bound-id-member? p keys)
(values 'any (cons (cons p n) ids))) (values (vector 'free-id p) ids))
((free-id=? p #'_)
(values '_ ids))
(else
(values 'any (cons (cons p n) ids))))
(syntax-case p () (syntax-case p ()
((x dots) ((x dots)
(ellipsis? (syntax dots)) (ellipsis? (syntax dots))
@ -2375,20 +2384,22 @@
(if (and (id? #'pat) (if (and (id? #'pat)
(and-map (lambda (x) (not (free-id=? #'pat x))) (and-map (lambda (x) (not (free-id=? #'pat x)))
(cons #'(... ...) keys))) (cons #'(... ...) keys)))
(let ((labels (list (gen-label))) (if (free-id=? #'pad #'_)
(var (gen-var #'pat))) (chi #'exp r empty-wrap mod)
(build-application no-source (let ((labels (list (gen-label)))
(build-simple-lambda (var (gen-var #'pat)))
no-source (list (syntax->datum #'pat)) #f (list var) (build-application no-source
'() (build-simple-lambda
(chi #'exp no-source (list (syntax->datum #'pat)) #f (list var)
(extend-env labels '()
(list (make-binding 'syntax `(,var . 0))) (chi #'exp
r) (extend-env labels
(make-binding-wrap #'(pat) (list (make-binding 'syntax `(,var . 0)))
labels empty-wrap) r)
mod)) (make-binding-wrap #'(pat)
(list x))) labels empty-wrap)
mod))
(list x))))
(gen-clause x keys (cdr clauses) r (gen-clause x keys (cdr clauses) r
#'pat #t #'exp mod))) #'pat #t #'exp mod)))
((pat fender exp) ((pat fender exp)
@ -2401,7 +2412,8 @@
(let ((e (source-wrap e w s mod))) (let ((e (source-wrap e w s mod)))
(syntax-case e () (syntax-case e ()
((_ val (key ...) m ...) ((_ val (key ...) m ...)
(if (and-map (lambda (x) (and (id? x) (not (ellipsis? x)))) (if (and-map (lambda (x)
(and (id? x) (not (ellipsis? x)) (not (underscore? x))))
#'(key ...)) #'(key ...))
(let ((x (gen-var 'tmp))) (let ((x (gen-var 'tmp)))
; fat finger binding and references to temp variable x ; fat finger binding and references to temp variable x
@ -2561,6 +2573,7 @@
(lambda (p r) (lambda (p r)
(cond (cond
((null? p) r) ((null? p) r)
((eq? p '_) r)
((eq? p 'any) (cons '() r)) ((eq? p 'any) (cons '() r))
((pair? p) (match-empty (car p) (match-empty (cdr p) r))) ((pair? p) (match-empty (car p) (match-empty (cdr p) r)))
((eq? p 'each-any) (cons '() r)) ((eq? p 'each-any) (cons '() r))
@ -2621,6 +2634,7 @@
(lambda (e p w r mod) (lambda (e p w r mod)
(cond (cond
((not r) #f) ((not r) #f)
((eq? p '_) r)
((eq? p 'any) (cons (wrap e w mod) r)) ((eq? p 'any) (cons (wrap e w mod) r))
((syntax-object? e) ((syntax-object? e)
(match* (match*
@ -2635,6 +2649,7 @@
(lambda (e p) (lambda (e p)
(cond (cond
((eq? p 'any) (list e)) ((eq? p 'any) (list e))
((eq? p '_) '())
((syntax-object? e) ((syntax-object? e)
(match* (syntax-object-expression e) (match* (syntax-object-expression e)
p (syntax-object-wrap e) '() (syntax-object-module e))) p (syntax-object-wrap e) '() (syntax-object-module e)))

11
test-suite/tests/syncase.test
View file

@ -141,3 +141,14 @@
(with-test-prefix "macro-generating macro" (with-test-prefix "macro-generating macro"
(pass-if "module hygiene" (pass-if "module hygiene"
(eq? (foo) 'hello))) (eq? (foo) 'hello)))
(pass-if "_ is a placeholder"
(equal? (eval '(begin
(define-syntax ciao
(lambda (stx)
(syntax-case stx ()
((_ _)
"ciao"))))
(ciao 1))
(current-module))
"ciao"))