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

stxclass: fixed duplicate id:stxclass declaration error

Browse Source 
svn: r13263
This commit is contained in:
Ryan Culpepper 2009-01-23 07:12:24 +00:00
parent 9b79cc7e8c
commit 167cbbb011
1 changed files with 44 additions and 33 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

77
collects/stxclass/private/rep.ss
View File

@ -167,19 +167,25 @@
(no-good)) (no-good))
sc)) sc))
(define (split-id/get-stxclass id [decls (lambda _ #f)]) (define (split-id/get-stxclass id0 decls)
(cond [(regexp-match #rx"^([^:]*):(.+)$" (symbol->string (syntax-e id))) (cond [(regexp-match #rx"^([^:]*):(.+)$" (symbol->string (syntax-e id0)))
=> (lambda (m) => (lambda (m)
(when (decls id) (define id (datum->syntax id0 (string->symbol (cadr m)) id0 id0))
(raise-syntax-error 'syntax-class (define scname (datum->syntax id0 (string->symbol (caddr m)) id0 id0))
"name already declared with syntax class" (match (decls id)
id)) [#t
(let ([sc (get-stxclass (datum->syntax id (string->symbol (caddr m))))]) (raise-syntax-error 'syntax-class
(values (datum->syntax id (string->symbol (cadr m)) id id) "name already declared as literal"
sc id)]
null [(list* id2 scname2 args)
(ssc? sc))))] (raise-syntax-error 'syntax-class
[(decls id) (format "name already declared with syntax-class '~s'"
(syntax-e scname))
id2)]
[_ (void)])
(let ([sc (get-stxclass scname)])
(values id sc null (ssc? sc))))]
[(decls id0)
=> (lambda (p) => (lambda (p)
(let ([stxclass (car p)] (let ([stxclass (car p)]
[args (cdr p)]) [args (cdr p)])
@ -188,9 +194,9 @@
(format "too few arguments for syntax class ~a (expected ~s)" (format "too few arguments for syntax class ~a (expected ~s)"
(sc-name stxclass) (sc-name stxclass)
(length (sc-inputs stxclass))) (length (sc-inputs stxclass)))
id)) id0))
(values id stxclass args (ssc? stxclass))))] (values id0 stxclass args (ssc? stxclass))))]
[else (values id #f null #f)])) [else (values id0 #f null #f)]))
(define (atomic-datum? stx) (define (atomic-datum? stx)
(let ([datum (syntax-e stx)]) (let ([datum (syntax-e stx)])
@ -250,10 +256,13 @@
(for/list ([attr-stx (syntax->list #'([attr depth] ...))]) (for/list ([attr-stx (syntax->list #'([attr depth] ...))])
(syntax-case attr-stx () (syntax-case attr-stx ()
[(attr depth) [(attr depth)
(begin (unless (and (identifier? #'attr) (begin
(exact-nonnegative-integer? (syntax-e #'depth))) (unless (and (identifier? #'attr)
(raise-syntax-error #f "bad attribute declaration" stx attr-stx)) (exact-nonnegative-integer?
(make-attr (syntax-e #'attr) (syntax-e #'depth) null))])) (syntax-e #'depth)))
(raise-syntax-error #f "bad attribute declaration"
stx attr-stx))
(make-attr (syntax-e #'attr) (syntax-e #'depth) null))]))
transparent? transparent?
description description
#'parser-expr)])) #'parser-expr)]))
@ -474,8 +483,8 @@
;; parse-pattern-directives : stxs(PatternDirective) #:literals (listof id) ;; parse-pattern-directives : stxs(PatternDirective) #:literals (listof id)
;; -> stx DeclEnv env (listof SideClause) ;; -> stx DeclEnv env (listof SideClause)
;; DeclEnv = bound-id-mapping[id => (cons SC (listof stx)) or #t] ;; DeclEnv = bound-id-mapping[id => (list* id id (listof stx)) or #t]
;; if decls maps a name to #t, it indicates literal ;; if decls maps a name to #f, it indicates literal
(define (parse-pattern-directives stx (define (parse-pattern-directives stx
#:sc? [sc? #f] #:sc? [sc? #f]
#:literals [literals null]) #:literals [literals null])
@ -487,6 +496,8 @@
(bound-identifier-mapping-get decl-table id (lambda () #f))) (bound-identifier-mapping-get decl-table id (lambda () #f)))
(define (remap id) (define (remap id)
(bound-identifier-mapping-get remap-table id (lambda () (syntax-e id)))) (bound-identifier-mapping-get remap-table id (lambda () (syntax-e id))))
(define (decls-add! id value)
(bound-identifier-mapping-put! decl-table id value))
(define (check-in-sc stx) (define (check-in-sc stx)
(unless sc? (unless sc?
@ -507,18 +518,18 @@
(identifier? #'sc) (identifier? #'sc)
(for-decl #'[#:declare name (sc)])] (for-decl #'[#:declare name (sc)])]
[[#:declare name (sc expr ...)] [[#:declare name (sc expr ...)]
(begin (let ([prev (bound-identifier-mapping-get decl-table #'name (lambda () #f))]) (begin
(when (pair? prev) (let ([prev (decls #'name)])
(raise-syntax-error 'pattern (when (pair? prev)
"duplicate syntax-class declaration for name" (raise-syntax-error 'pattern
#'name)) "duplicate syntax-class declaration for name"
(when prev #'name))
(raise-syntax-error 'pattern (when prev
"name already declared as literal" (raise-syntax-error 'pattern
#'name))) "name already declared as literal"
(bound-identifier-mapping-put! decl-table #'name #'name)))
(cons (get-stxclass #'sc) (decls-add! #'name
(syntax->list #'(expr ...)))))] (list* #'name #'sc (syntax->list #'(expr ...)))))]
[[#:declare . _] [[#:declare . _]
(raise-syntax-error 'pattern "bad #:declare form" stx)] (raise-syntax-error 'pattern "bad #:declare form" stx)]
[[#:rename id s] [[#:rename id s]