suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

stxclass: simplified, narrowed provides

Browse Source 
svn: r13260
This commit is contained in:
Ryan Culpepper 2009-01-23 00:07:42 +00:00
parent 4e6039bedd
commit 4dc6192278
3 changed files with 69 additions and 52 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

15
collects/stxclass/main.ss
View File

@ -2,5 +2,18 @@
#lang scheme/base
(require "private/sc.ss"
"private/lib.ss")
(provide (all-from-out "private/sc.ss")
(provide define-syntax-class
define-basic-syntax-class
define-basic-syntax-class*
pattern
syntax-parse
syntax-parser
with-patterns
...*
current-expression
current-macro-name
(all-from-out "private/lib.ss"))

37
collects/stxclass/private/lib.ss
View File

@ -19,7 +19,6 @@
(let ([d (if (syntax? x) (syntax-e x) x)])
(if (pred d)
(list d)
;; (fail-sc x #:pattern 'name)
#f)))))
(define-pred-stxclass identifier symbol?)
@ -40,7 +39,6 @@
(lambda (x)
(if (and (identifier? x) (free-identifier=? x (quote-syntax kw)))
null
;; (fail-sc x #:pattern 'name)
#f))))
(define-kw-stxclass lambda-kw #%lambda)
@ -60,27 +58,16 @@
(lambda (x)
(if (identifier? x)
(let/ec escape
(define (bad)
(escape
(fail-sc x
#:pattern 'static
#:reason "not bound as syntax")))
(define (bad) (escape #f))
(let ([value (syntax-local-value x bad)])
(list (syntax-e x) value)))
;;(fail-sc x
;; #:pattern 'static
;; #:reason "not an identifier")
#f)))
(define-basic-syntax-class (static-of name pred)
([value 0])
(lambda (x name pred)
(let/ec escape
(define (bad)
(escape ;;(fail-sc x
;; #:pattern 'name
;; #:reason (format "not bound as ~a" name))
#f))
(define (bad) (escape #f))
(if (identifier? x)
(let ([value (syntax-local-value x bad)])
(unless (pred value) (bad))
@ -97,12 +84,7 @@
(lambda (x)
(if (identifier? x)
(let/ec escape
(define (bad)
(escape
;;(fail-sc x
;; #:pattern 'struct-name
;; #:reason "not bound as a struct name")
#f))
(define (bad) (escape #f))
(let ([value (syntax-local-value x bad)])
(unless (struct-info? value) (bad))
(let ([lst (extract-struct-info value)])
@ -115,14 +97,13 @@
(list descriptor
constructor
predicate
(if (and (pair? r-accessors) (eq? #f (car r-accessors)))
(if (and (pair? r-accessors)
(eq? #f (car r-accessors)))
(cdr r-accessors)
r-accessors)
super
(or (null? r-accessors) (not (eq? #f (car r-accessors))))))))))
;;(fail-sc x
;; #:pattern 'struct-name
;; #:reason "not bound as a struct name")
(or (null? r-accessors)
(not (eq? #f (car r-accessors))))))))))
#f)))
(define-basic-syntax-class expr/local-expand
@ -178,7 +159,7 @@
(lambda (x)
(if (not (keyword? (syntax-e x)))
(list x)
(fail-sc x #:pattern 'expr #:reason "keyword"))))
#f)))
;; FIXME: hack
(define expr/c-use-contracts? (make-parameter #t))
@ -196,7 +177,6 @@
(quote-syntax #,(syntax/loc x (<there>))))
x)
(list x x))
;;(fail-sc x #:pattern 'expr #:reason "keyword")
#f)))
(define-basic-syntax-class (term parser)
@ -208,7 +188,6 @@
(lambda (x p)
(if (p x)
null
;;(fail-sc x #:pattern 'term/pred)
#f)))
;; Aliases

69
collects/stxclass/private/sc.ss
View File

@ -10,6 +10,7 @@
syntax/stx
"kws.ss"
"messages.ss")
(provide define-syntax-class
define-basic-syntax-class
define-basic-syntax-class*
@ -26,12 +27,57 @@
pattern
...*
fail-sc
(struct-out failed)
current-expression
current-macro-name)
#|
(begin-for-syntax
(define (check-attrlist stx)
(syntax-case stx ()
[(form ...)
(let ([names (for/list ([s (syntax->list #'(form ...))])
(check-attr s)
(stx-car s))])
(check-duplicate-identifier names)
stx)]
[_
(raise-syntax-error 'define-syntax-class
"expected attribute table" stx)]))
(define stxclass-table
`((#:description check-string)
(#:attributes check-attrlist)))
(define (split-rhss rhss stx)
(define-values (chunks rest)
(chunk-kw-seq/no-dups rhss stxclass-table #:context stx))
(define (assq* x alist default)
(cond [(assq x alist) => cdr]
[else default]))
(values (cond [(assq '#:attributes chunks) => caddr]
[else null])
(cond [(assq '#:description chunks) => caddr]
[else #f])
rest)))
(define-syntax (define-syntax-class stx)
(syntax-case stx ()
[(define-syntax-class (name arg ...) . rhss)
(let-values ([(attrs description rhss) (split-rhss #'rhss stx)])
#`(begin (define-syntax name
(make sc
'name
'(arg ...)
'#,attrs
((syntax-local-value) #'parser)
'description))
(define parser
(rhs->parser name #,rhss (arg ...) #,stx))))]
[(define-syntax-class name . rhss)
(syntax/loc stx
(define-syntax-class (name) . rhss))]))
|#
(define-syntax (define-syntax-class stx)
(syntax-case stx ()
[(define-syntax-class (name arg ...) . rhss)
@ -47,21 +93,6 @@
(syntax/loc stx
(define-syntax-class (name) . rhss))]))
#;
(define-syntax (define-syntax-splice-class stx)
(syntax-case stx ()
[(define-syntax-splice-class (name arg ...) . rhss)
#`(begin (define-syntax name
(make ssc 'name
'(arg ...)
(rhs-attrs
(parse-splice-rhs (quote-syntax rhss) #t (quote-syntax #,stx)))
((syntax-local-certifier) #'parser)))
(define parser (splice-rhs->parser name rhss (arg ...) #,stx)))]
[(define-syntax-splice-class name . rhss)
(syntax/loc stx (define-syntax-splice-class (name) . rhss))]))
(define-syntax define-basic-syntax-class
(syntax-rules ()
[(define-basic-syntax-class (name arg ...)
@ -212,9 +243,3 @@
(values x n)]
[(list-rest _ _ rest)
(frontier->syntax rest)]))
(define (fail-sc stx #:pattern [pattern #f] #:reason [reason #f])
(make-failed stx pattern reason #f))
(define (syntax-class-fail stx #:reason [reason #f])
(make-failed stx #f reason #f))