diff --git a/collects/stxclass/main.ss b/collects/stxclass/main.ss index 215873a6ef..3779837637 100644 --- a/collects/stxclass/main.ss +++ b/collects/stxclass/main.ss @@ -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")) diff --git a/collects/stxclass/private/lib.ss b/collects/stxclass/private/lib.ss index 94ecf5b428..c57591d67b 100644 --- a/collects/stxclass/private/lib.ss +++ b/collects/stxclass/private/lib.ss @@ -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 ()))) 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 diff --git a/collects/stxclass/private/sc.ss b/collects/stxclass/private/sc.ss index bbd192aa76..261cd42a09 100644 --- a/collects/stxclass/private/sc.ss +++ b/collects/stxclass/private/sc.ss @@ -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))