From 38d4b95da932be7b491e69fd9401817539549947 Mon Sep 17 00:00:00 2001 From: Ryan Culpepper Date: Mon, 26 Jan 2009 23:54:13 +0000 Subject: [PATCH] stxclass: #:description takes expression now svn: r13288 --- collects/stxclass/private/lib.ss | 22 ++--- collects/stxclass/private/messages.ss | 10 ++- collects/stxclass/private/parse.ss | 23 +++--- collects/stxclass/private/rep.ss | 4 +- collects/stxclass/private/sc.ss | 113 ++++++++++++++------------ 5 files changed, 93 insertions(+), 79 deletions(-) diff --git a/collects/stxclass/private/lib.ss b/collects/stxclass/private/lib.ss index bdb1bb0475..b80c485e08 100644 --- a/collects/stxclass/private/lib.ss +++ b/collects/stxclass/private/lib.ss @@ -63,16 +63,18 @@ (list (syntax-e x) value))) #f))) -(define-basic-syntax-class (static-of name pred) - ([value 0]) - (lambda (x name pred) - (let/ec escape - (define (bad) (escape #f)) - (if (identifier? x) - (let ([value (syntax-local-value x bad)]) - (unless (pred value) (bad)) - (list value)) - (bad))))) +(define-syntax-class (static-of name pred) + #:description name + (basic-syntax-class + ([value 0]) + (lambda (x name pred) + (let/ec escape + (define (bad) (escape #f)) + (if (identifier? x) + (let ([value (syntax-local-value x bad)]) + (unless (pred value) (bad)) + (list x value)) + (bad)))))) (define-basic-syntax-class struct-name ([descriptor 0] diff --git a/collects/stxclass/private/messages.ss b/collects/stxclass/private/messages.ss index aa292f961e..efc9c765ac 100644 --- a/collects/stxclass/private/messages.ss +++ b/collects/stxclass/private/messages.ss @@ -13,13 +13,17 @@ (define-struct expc (stxclasses pairs? data literals) #:transparent) +(define (make-stxclass-expc scdyn) + (make-expc (list scdyn) #f null null)) + (begin-for-syntax (define certify (syntax-local-certifier)) - (define (expectation-of-stxclass stxclass) + (define (expectation-of-stxclass stxclass args) (if stxclass (with-syntax ([name (sc-name stxclass)] - [desc (sc-description stxclass)]) - (certify #'(make-expc (list (make-scdyn 'name 'desc)) #f null null))) + [desc-var (sc-description stxclass)] + [(arg ...) args]) + (certify #'(make-stxclass-expc (make-scdyn 'name (desc-var arg ...))))) #'#f)) (define (expectation-of-constants pairs? data literals) diff --git a/collects/stxclass/private/parse.ss b/collects/stxclass/private/parse.ss index c88df4c676..e07f14f9eb 100644 --- a/collects/stxclass/private/parse.ss +++ b/collects/stxclass/private/parse.ss @@ -225,18 +225,19 @@ (define (parse:extpk vars fcs extpk failid) (match extpk [(struct idpks (stxclass args pks)) - (with-syntax ([sub-parse-expr - (if stxclass - #`(#,(sc-parser-name stxclass) #,(car vars) #,@args) - #`(list #,(car vars)))] - [var0 (car vars)] + (with-syntax ([var0 (car vars)] + [(arg ...) args] + [(arg-var ...) (generate-temporaries args)] [(r) (generate-temporaries #'(r))]) - #`(let ([r sub-parse-expr]) - (if (ok? r) - #,(parse:pks (cdr vars) (cdr fcs) (shift-pks:id pks #'r) failid) - #,(fail failid (car vars) - #:pattern (expectation-of-stxclass stxclass) - #:fc (car fcs)))))] + #`(let ([arg-var arg] ...) + (let ([r #,(if stxclass + #`(#,(sc-parser-name stxclass) #,(car vars) arg-var ...) + #`(list #,(car vars)))]) + (if (ok? r) + #,(parse:pks (cdr vars) (cdr fcs) (shift-pks:id pks #'r) failid) + #,(fail failid (car vars) + #:pattern (expectation-of-stxclass stxclass #'(arg-var ...)) + #:fc (car fcs))))))] [(struct cpks (pairpks datumpkss literalpkss)) (with-syntax ([var0 (car vars)] [(dvar0) (generate-temporaries (list (car vars)))]) diff --git a/collects/stxclass/private/rep.ss b/collects/stxclass/private/rep.ss index 053b10ab9b..6a4617a146 100644 --- a/collects/stxclass/private/rep.ss +++ b/collects/stxclass/private/rep.ss @@ -45,7 +45,7 @@ (define-struct attr (name depth inner) #:transparent) -;; RHSBase is stx (listof SAttr) boolean string/#f +;; RHSBase is stx (listof SAttr) boolean stx/#f (define-struct rhs (orig-stx attrs transparent? description) #:transparent) @@ -315,7 +315,7 @@ ;; rhs-directive-table (define rhs-directive-table (list (list '#:literals check-idlist) - (list '#:description check-string) + (list '#:description values) (list '#:transparent))) ;; parse-pattern : stx(Pattern) env number -> Pattern diff --git a/collects/stxclass/private/sc.ss b/collects/stxclass/private/sc.ss index 8ee75f5c55..2409ced275 100644 --- a/collects/stxclass/private/sc.ss +++ b/collects/stxclass/private/sc.ss @@ -32,52 +32,6 @@ 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) @@ -90,8 +44,9 @@ '(arg ...) (rhs-attrs the-rhs) ((syntax-local-certifier) #'parser) - (rhs-description the-rhs)))) - (define parser (rhs->parser name rhss (arg ...) #,stx)))] + #'description))) + (define-values (parser description) + (rhs->parser+description name rhss (arg ...) #,stx)))] [(define-syntax-class name . rhss) (syntax/loc stx (define-syntax-class (name) . rhss))])) @@ -128,15 +83,18 @@ ([attr-name attr-depth] ...) (let ([name parser-expr]) name)))])) -(define-syntax (rhs->parser stx) +(define-syntax (rhs->parser+description stx) (syntax-case stx () - [(rhs->parser name rhss (arg ...) ctx) + [(rhs->parser+description name rhss (arg ...) ctx) (parameterize ((current-syntax-context #'ctx)) (let ([rhs (parse-rhs #'rhss #f #'ctx)] [sc (syntax-local-value #'name)]) - (parse:rhs rhs - (sc-attrs sc) - (syntax->list #'(arg ...)))))])) + #`(values #,(parse:rhs rhs + (sc-attrs sc) + (syntax->list #'(arg ...))) + (lambda (arg ...) + #,(or (rhs-description rhs) + #'(symbol->string 'name))))))])) (define-syntax (parse-sc stx) (syntax-case stx () @@ -237,3 +195,52 @@ (values x n)] [(list-rest _ _ rest) (frontier->syntax rest)])) + + + +#| +(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))])) +|# +