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

stxclass:

Browse Source 
fixed scoping of attributes (wrt declare)
  added 'attribute' form
  added internal/external literals form

svn: r13574
This commit is contained in:
Ryan Culpepper 2009-02-14 12:17:14 +00:00
parent ccce0e4d70
commit 44efc7cb48
10 changed files with 452 additions and 226 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

99
collects/stxclass/private/codegen.ss
View File

@ -42,7 +42,8 @@
(define (parse:clauses stx var failid) (define (parse:clauses stx var failid)
(define clauses-kw-table (define clauses-kw-table
(list (list '#:literals check-literals-list))) (list (list '#:literals check-literals-list)))
(define-values (chunks clauses-stx) (chunk-kw-seq/no-dups stx clauses-kw-table)) (define-values (chunks clauses-stx)
(chunk-kw-seq/no-dups stx clauses-kw-table))
(define literals (define literals
(cond [(assq '#:literals chunks) => caddr] (cond [(assq '#:literals chunks) => caddr]
[else null])) [else null]))
@ -53,18 +54,15 @@
(parse-pattern-directives #'rest (parse-pattern-directives #'rest
#:sc? #f #:sc? #f
#:literals literals)]) #:literals literals)])
(syntax-case rest () (let* ([pattern (parse-whole-pattern #'p decls)])
[(b ...) (syntax-case rest ()
(let* ([pattern (parse-pattern #'p decls 0)]) [(b0 b ...)
(make-pk (list pattern) (let ([body #'(let () b0 b ...)])
(expr:convert-sides sides (make-pk (list pattern)
(pattern-attrs pattern) (wrap-pvars (pattern-attrs pattern)
var (convert-sides sides var body))))]
(lambda (iattrs) [_
(wrap-pattern-body/attrs (wrong-syntax clause "expected body")])))]))
iattrs 0 rest)))))]
[_
(wrong-syntax clause "expected body")]))]))
(unless (stx-list? clauses-stx) (unless (stx-list? clauses-stx)
(wrong-syntax clauses-stx "expected sequence of clauses")) (wrong-syntax clauses-stx "expected sequence of clauses"))
(let ([pks (map clause->pk (stx->list clauses-stx))]) (let ([pks (map clause->pk (stx->list clauses-stx))])
@ -87,57 +85,48 @@
(match rhs (match rhs
[(struct rhs:pattern (orig-stx attrs pattern decls remap sides)) [(struct rhs:pattern (orig-stx attrs pattern decls remap sides))
(parameterize ((current-syntax-context orig-stx)) (parameterize ((current-syntax-context orig-stx))
(list (make-pk (list pattern) (define iattrs
(expr:convert-sides sides (append-attrs
(pattern-attrs pattern) (cons (pattern-attrs pattern)
main-var (for/list ([side sides] #:when (clause:with? side))
(lambda (iattrs) (pattern-attrs (clause:with-pattern side))))))
(expr:sc iattrs (define base-expr
relsattrs (success-expr iattrs relsattrs remap main-var))
remap (define expr
main-var))))))])) (wrap-pvars (pattern-attrs pattern)
(convert-sides sides main-var base-expr)))
(list (make-pk (list pattern) expr)))]))
;; expr:convert-sides : (listof SideClause) (listof IAttr) id stx -> stx ;; convert-sides : (listof SideClause) id stx -> stx
(define (expr:convert-sides sides iattrs main-var k) (define (convert-sides sides main-var body-expr)
(match sides (match sides
['() (k iattrs)] ['() body-expr]
[(cons (struct clause:when (e)) rest) [(cons (struct clause:when (e)) rest)
(let* ([k-rest (expr:convert-sides rest iattrs main-var k)]) #`(if #,e
(with-syntax ([(x) (generate-temporaries #'(x))]) #,(convert-sides rest main-var body-expr)
#`(let ([x #,(wrap-pattern-body/attrs iattrs 0 (list e))]) #,(fail #'enclosing-fail main-var
(if x #:pattern (expectation-of/message "side condition failed")
#,k-rest #:fce (done-frontier main-var)))]
#,(fail #'enclosing-fail main-var
#:pattern (expectation-of/message "side condition failed")
#:fce (done-frontier main-var))))))]
[(cons (struct clause:with (p e)) rest) [(cons (struct clause:with (p e)) rest)
(let* ([new-iattrs (append (pattern-attrs p) iattrs)] (let ([inner
[k-rest (expr:convert-sides rest new-iattrs main-var k)]) (wrap-pvars (pattern-attrs p)
(convert-sides rest main-var body-expr))])
(with-syntax ([(x fail-k) (generate-temporaries #'(x fail-k))]) (with-syntax ([(x fail-k) (generate-temporaries #'(x fail-k))])
#`(let ([x #,(wrap-pattern-body/attrs iattrs 0 (list e))] #`(let ([x #,e]
[fail-k enclosing-fail]) [fail-k enclosing-fail])
#,(parse:pks (list #'x) #,(parse:pks (list #'x)
(list (done-frontier #'x)) (list (done-frontier #'x))
(list (make-pk (list p) k-rest)) (list (make-pk (list p) inner))
#'fail-k))))])) #'fail-k))))]))
;; expr:sc : (listof IAttr) (listof SAttr) env stx -> stx ;; success-expr : (listof IAttr) (listof SAttr) RemapEnv stx -> stx
(define (expr:sc iattrs relsattrs remap main-var) (define (success-expr iattrs relsattrs remap main-var)
(let* ([reliattrs (reorder-iattrs relsattrs iattrs remap)] (let* ([reliattrs (reorder-iattrs relsattrs iattrs remap)]
[flat-reliattrs (flatten-attrs* reliattrs)] [flat-reliattrs (flatten-attrs* reliattrs)]
[relids (map attr-name flat-reliattrs)]) [relids (map attr-name flat-reliattrs)])
(with-syntax ([main main-var] (with-syntax ([main main-var]
[(relid ...) relids]) [(relid ...) relids])
#'(list main relid ...)))) #'(list main (attribute relid) ...))))
;; check-literals-list : syntax -> (listof id)
(define (check-literals-list stx)
(unless (stx-list? stx)
(wrong-syntax stx "expected list of identifiers"))
(for ([id (syntax->list stx)])
(unless (identifier? id)
(wrong-syntax id "expected identifier")))
(syntax->list stx))
;; fail : id id #:pattern datum #:reason datum #:fce FCE #:fstx id -> stx ;; fail : id id #:pattern datum #:reason datum #:fce FCE #:fstx id -> stx
(define (fail k x #:pattern p #:fce fce) (define (fail k x #:pattern p #:fce fce)
@ -584,13 +573,13 @@
(make-pk (list* head tail rest-ps) k)])) (make-pk (list* head tail rest-ps) k)]))
(map shift-pk pks)) (map shift-pk pks))
;; wrap-pattern-body : (listof IAttr) nat stxlist -> stx ;; wrap-pvars : (listof IAttr) stx -> stx
(define (wrap-pattern-body/attrs iattrs depth bs) (define (wrap-pvars iattrs expr)
(let* ([flat-iattrs (flatten-attrs* iattrs depth #f #f)] (let* ([flat-iattrs (flatten-attrs* iattrs 0 #f #f)]
[ids (map attr-name flat-iattrs)] [ids (map attr-name flat-iattrs)]
[depths (map attr-depth flat-iattrs)]) [depths (map attr-depth flat-iattrs)])
(with-syntax ([(id ...) ids] (with-syntax ([(id ...) ids]
[(depth ...) depths] [(depth ...) depths]
[bs bs]) [expr expr])
#`(let-syntax ([id (make-syntax-mapping 'depth (quote-syntax id))] ...) #'(let-attributes ([id depth id] ...)
. bs)))) expr))))

213
collects/stxclass/private/rep-data.ss
View File

@ -2,6 +2,7 @@
(require scheme/contract (require scheme/contract
scheme/match scheme/match
syntax/stx syntax/stx
syntax/boundmap
"../util.ss") "../util.ss")
(provide (struct-out sc) (provide (struct-out sc)
(struct-out attr) (struct-out attr)
@ -24,10 +25,6 @@
#:property prop:procedure (lambda (self stx) (sc-parser-name self)) #:property prop:procedure (lambda (self stx) (sc-parser-name self))
#:transparent) #:transparent)
;; An SSC is one of (make-ssc symbol (listof symbol) (list-of SAttr) identifier)
(define-struct ssc (name inputs attrs parser-name)
#:transparent)
;; An IAttr is (make-attr identifier number (listof SAttr)) ;; An IAttr is (make-attr identifier number (listof SAttr))
;; An SAttr is (make-attr symbol number (listof SAttr)) ;; An SAttr is (make-attr symbol number (listof SAttr))
(define-struct attr (name depth inner) (define-struct attr (name depth inner)
@ -86,19 +83,93 @@
(define (sattr? a) (define (sattr? a)
(and (attr? a) (symbol? (attr-name a)))) (and (attr? a) (symbol? (attr-name a))))
;; Environments
;; DeclEnv maps [id => DeclEntry]
;; DeclEntry =
;; (list 'literal id id)
;; (list 'stxclass id id (listof stx))
;; #f
(define-struct declenv (bm))
(define (new-declenv literals)
(let ([decls (make-declenv (make-bound-identifier-mapping))])
(for ([literal literals])
(declenv-put-literal decls (car literal) (cadr literal)))
decls))
(define (declenv-lookup env id)
(bound-identifier-mapping-get (declenv-bm env) id (lambda () #f)))
(define (declenv-check-unbound env id [stxclass-name #f]
#:blame-declare? [blame-declare? #f])
;; Order goes: literals, pattern, declares
;; So blame-declare? only applies to stxclass declares
(let ([val (declenv-lookup env id)])
(when val
(cond [(eq? 'literal (car val))
(wrong-syntax id "identifier previously declared as literal")]
[(and blame-declare? stxclass-name)
(wrong-syntax (cadr val)
"identifier previously declared with syntax class ~a"
stxclass-name)]
[else
(wrong-syntax (if blame-declare? (cadr val) id)
"identifier previously declared")]))))
(define (declenv-put-literal env internal-id lit-id)
(declenv-check-unbound env internal-id)
(bound-identifier-mapping-put! (declenv-bm env) internal-id
(list 'literal internal-id lit-id)))
(define (declenv-put-stxclass env id stxclass-name args)
(declenv-check-unbound env id)
(bound-identifier-mapping-put! (declenv-bm env) id
(list 'stxclass id stxclass-name args)))
;; returns ids in domain of env but not in given list
(define (declenv-domain-difference env ids)
(define idbm (make-bound-identifier-mapping))
(define excess null)
(for ([id ids]) (bound-identifier-mapping-put! idbm id #t))
(bound-identifier-mapping-for-each
(declenv-bm env)
(lambda (k v)
(when (and (pair? v) (eq? (car v) 'stxclass))
(unless (bound-identifier-mapping-get idbm k (lambda () #f))
(set! excess (cons k excess))))))
excess)
;; A RemapEnv is a bound-identifier-mapping
(define (new-remapenv)
(make-bound-identifier-mapping))
(define (remapenv-lookup env id)
(bound-identifier-mapping-get env id (lambda () (syntax-e id))))
(define (remapenv-put env id sym)
(bound-identifier-mapping-put! env id sym))
(define (remapenv-domain env)
(bound-identifier-mapping-map env (lambda (k v) k)))
(define trivial-remap
(new-remapenv))
;; Contracts ;; Contracts
;; DeclEnv = [id -> (list* id id (listof stx)) or #t or #f
;; #t means literal, #f means undeclared, list means stxclass (w/ args)
(define DeclEnv/c (define DeclEnv/c
(-> identifier? (flat-named-contract "DeclEnv/c" declenv?))
(or/c boolean? (cons/c identifier? (cons/c identifier? (listof syntax?))))))
(define RemapEnv/c (define RemapEnv/c
(-> identifier? symbol?)) (flat-named-contract "RemapEnv/c" bound-identifier-mapping?))
(define SideClause/c (or/c clause:with? clause:when?))
(define SideClause/c
(or/c clause:with? clause:when?))
(provide/contract (provide/contract
[DeclEnv/c contract?] [DeclEnv/c contract?]
@ -109,24 +180,63 @@
[allow-unbound-stxclasses (parameter/c boolean?)] [allow-unbound-stxclasses (parameter/c boolean?)]
[iattr? (any/c . -> . boolean?)] [iattr? (any/c . -> . boolean?)]
[sattr? (any/c . -> . boolean?)] [sattr? (any/c . -> . boolean?)]
[new-declenv
(-> (listof (list/c identifier? identifier?)) DeclEnv/c)]
[declenv-lookup
(-> declenv? identifier? any)]
[declenv-put-literal
(-> declenv? identifier? identifier? any)]
[declenv-put-stxclass
(-> declenv? identifier? identifier? (listof syntax?)
any)]
[declenv-domain-difference
(-> declenv? (listof identifier?)
(listof identifier?))]
[new-remapenv
(-> RemapEnv/c)]
[remapenv-lookup
(-> RemapEnv/c identifier? symbol?)]
[remapenv-put
(-> RemapEnv/c identifier? symbol? any)]
[remapenv-domain
(-> RemapEnv/c list?)]
[trivial-remap
RemapEnv/c]
[iattr->sattr (iattr? . -> . sattr?)] [iattr->sattr (iattr? . -> . sattr?)]
[rename-attr (attr? symbol? . -> . sattr?)] [rename-attr
[iattrs->sattrs ((listof iattr?) (identifier? . -> . symbol?) . -> . (listof sattr?))] (attr? symbol? . -> . sattr?)]
[iattrs->sattrs
(-> (listof iattr?) RemapEnv/c
(listof sattr?))]
[sattr->iattr/id (sattr? identifier? . -> . iattr?)] [sattr->iattr/id (sattr? identifier? . -> . iattr?)]
[get-stxclass (-> identifier? any)] [get-stxclass
[split-id/get-stxclass (-> identifier? any/c any)] (-> identifier? any)]
[get-stxclass/check-arg-count
(-> identifier? exact-nonnegative-integer? any)]
[split-id/get-stxclass
(-> identifier? DeclEnv/c any)]
[intersect-attrss ((listof (listof sattr?)) syntax? . -> . (listof sattr?))] [intersect-attrss ((listof (listof sattr?)) syntax? . -> . (listof sattr?))]
[join-attrs (sattr? sattr? syntax? . -> . sattr?)] [join-attrs (sattr? sattr? syntax? . -> . sattr?)]
[reorder-iattrs [reorder-iattrs
((listof sattr?) (listof iattr?) (identifier? . -> . symbol?) . -> . (listof iattr?))] (-> (listof sattr?) (listof iattr?) RemapEnv/c
(listof iattr?))]
[restrict-iattrs [restrict-iattrs
((listof sattr?) (listof iattr?) (identifier? . -> . symbol?) . -> . (listof iattr?))] (-> (listof sattr?) (listof iattr?) RemapEnv/c
(listof iattr?))]
[flatten-sattrs [flatten-sattrs
([(listof sattr?)] [exact-integer? (or/c symbol? false/c)] . ->* . (listof sattr?))] (->* [(listof sattr?)]
[exact-integer? (or/c symbol? false/c)]
(listof sattr?))]
[intersect-sattrs ((listof sattr?) (listof sattr?) . -> . (listof sattr?))] [intersect-sattrs ((listof sattr?) (listof sattr?) . -> . (listof sattr?))]
[flatten-attrs* any/c] [flatten-attrs*
(->* [(listof iattr?)]
[exact-nonnegative-integer? any/c any/c]
(listof iattr?))]
[append-attrs ((listof (listof iattr?)) . -> . (listof iattr?))] [append-attrs ((listof (listof iattr?)) . -> . (listof iattr?))]
[lookup-sattr (symbol? (listof sattr?) . -> . (or/c sattr? false/c))] [lookup-sattr (symbol? (listof sattr?) . -> . (or/c sattr? false/c))]
[lookup-iattr (identifier? (listof iattr?) . -> . (or/c iattr? false/c))] [lookup-iattr (identifier? (listof iattr?) . -> . (or/c iattr? false/c))]
@ -145,7 +255,7 @@
(define (iattrs->sattrs as remap) (define (iattrs->sattrs as remap)
(if (pair? as) (if (pair? as)
(let ([name* (remap (attr-name (car as)))]) (let ([name* (remapenv-lookup remap (attr-name (car as)))])
(if name* (if name*
(cons (rename-attr (car as) name*) (cons (rename-attr (car as) name*)
(iattrs->sattrs (cdr as) remap)) (iattrs->sattrs (cdr as) remap))
@ -168,35 +278,31 @@
sc sc
(no-good)))) (no-good))))
(define (get-stxclass/check-arg-count id arg-count)
(let* ([sc (get-stxclass id)]
[expected-arg-count (length (sc-inputs sc))])
(unless (or (= expected-arg-count arg-count)
(allow-unbound-stxclasses))
;; (above: don't check error if stxclass may not be defined yet)
(wrong-syntax id
"too few arguments for syntax-class ~a (expected ~s)"
(syntax-e id)
expected-arg-count))
sc))
(define (split-id/get-stxclass id0 decls) (define (split-id/get-stxclass id0 decls)
(cond [(regexp-match #rx"^([^:]*):(.+)$" (symbol->string (syntax-e id0))) (cond [(regexp-match #rx"^([^:]*):(.+)$" (symbol->string (syntax-e id0)))
=> (lambda (m) => (lambda (m)
(define id (datum->syntax id0 (string->symbol (cadr m)) id0 id0)) (define id
(define scname (datum->syntax id0 (string->symbol (caddr m)) id0 id0)) (datum->syntax id0 (string->symbol (cadr m)) id0 id0))
(match (decls id) (define scname
[#t (datum->syntax id0 (string->symbol (caddr m)) id0 id0))
(wrong-syntax id "name already declared as literal")] (declenv-check-unbound decls id (syntax-e scname)
[(list* id2 scname2 args) #:blame-declare? #t)
(wrong-syntax id2 (let ([sc (get-stxclass/check-arg-count scname 0)])
"name already declared with syntax-class ~s"
(syntax-e scname))]
[_ (void)])
(let ([sc (get-stxclass scname)])
(values id sc null)))] (values id sc null)))]
[(decls id0)
=> (lambda (p)
(define scname (cadr p))
(define args (cddr p))
(define stxclass (get-stxclass scname))
(unless (equal? (length (sc-inputs stxclass)) (length args))
(wrong-syntax id0
"too few arguments for syntax-class ~a (expected ~s)"
(sc-name stxclass)
(length (sc-inputs stxclass))))
(values id0 stxclass args))]
[else (values id0 #f null)])) [else (values id0 #f null)]))
;; intersect-attrss : (listof (listof SAttr)) stx -> (listof SAttr) ;; intersect-attrss : (listof (listof SAttr)) stx -> (listof SAttr)
(define (intersect-attrss attrss blamestx) (define (intersect-attrss attrss blamestx)
(cond [(null? attrss) null] (cond [(null? attrss) null]
@ -226,20 +332,21 @@
a a
(begin (begin
(unless (equal? (attr-depth a) (attr-depth b)) (unless (equal? (attr-depth a) (attr-depth b))
(complain "attribute '~a'occurs with different nesting depth" (attr-name a))) (complain "attribute '~a'occurs with different nesting depth"
(attr-name a)))
(make attr (attr-name a) (make attr (attr-name a)
(attr-depth a) (attr-depth a)
(intersect-attrss (list (attr-inner a) (attr-inner b)) blamestx))))) (intersect-attrss (list (attr-inner a) (attr-inner b))
blamestx)))))
;; reorder-iattrs : (listof SAttr) (listof IAttr) env -> (listof IAttr) ;; reorder-iattrs : (listof SAttr) (listof IAttr) RemapEnv/c -> (listof IAttr)
;; Reorders iattrs (and restricts) based on relsattrs ;; Reorders iattrs (and restricts) based on relsattrs
;; If a relsattr is not found, or if depth or contents mismatches, raises error. ;; If a relsattr is not found, or if depth or contents mismatches, raises error.
(define (reorder-iattrs relsattrs iattrs remap) (define (reorder-iattrs relsattrs iattrs remap)
(let ([ht (make-hasheq)]) (let ([ht (make-hasheq)])
(for-each (lambda (iattr) (for ([iattr iattrs])
(let ([remap-name (remap (attr-name iattr))]) (let ([remap-name (remapenv-lookup remap (attr-name iattr))])
(hash-set! ht remap-name iattr))) (hash-set! ht remap-name iattr)))
iattrs)
(let loop ([relsattrs relsattrs]) (let loop ([relsattrs relsattrs])
(match relsattrs (match relsattrs
['() null] ['() null]
@ -256,16 +363,16 @@
(intersect-sattrs inner (attr-inner iattr))) (intersect-sattrs inner (attr-inner iattr)))
(loop rest)))])))) (loop rest)))]))))
;; restrict-iattrs : (listof SAttr) (listof IAttr) env -> (listof IAttr) ;; restrict-iattrs : (listof SAttr) (listof IAttr) RemapEnv/c -> (listof IAttr)
;; Preserves order of iattrs ;; Preserves order of iattrs
(define (restrict-iattrs relsattrs iattrs remap) (define (restrict-iattrs relsattrs iattrs remap)
(match iattrs (match iattrs
['() null] ['() null]
[(cons (struct attr (name depth inner)) rest) [(cons (struct attr (name depth inner)) rest)
(let ([sattr (lookup-sattr (remap name) relsattrs)]) (let ([sattr (lookup-sattr (remapenv-lookup remap name) relsattrs)])
(if (and sattr (= depth (attr-depth sattr))) (if (and sattr (= depth (attr-depth sattr)))
(cons (make attr name depth (cons (make attr name depth
(intersect-sattrs inner (attr-inner sattr))) (intersect-sattrs inner (attr-inner sattr)))
(restrict-iattrs relsattrs (cdr iattrs) remap)) (restrict-iattrs relsattrs (cdr iattrs) remap))
(restrict-iattrs relsattrs (cdr iattrs) remap)))])) (restrict-iattrs relsattrs (cdr iattrs) remap)))]))

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

@ -9,14 +9,19 @@
"rep-data.ss") "rep-data.ss")
(provide/contract (provide/contract
[parse-pattern [parse-whole-pattern
(-> any/c #|syntax?|# DeclEnv/c exact-nonnegative-integer? (-> syntax? DeclEnv/c
pattern?)] pattern?)]
[parse-pattern-directives [parse-pattern-directives
(->* [stx-list?] (->* [stx-list?]
[#:sc? boolean? #:literals (listof identifier?)] [#:sc? boolean? #:literals (listof (list/c identifier? identifier?))]
(values stx-list? DeclEnv/c RemapEnv/c (listof SideClause/c)))] (values stx-list? DeclEnv/c RemapEnv/c (listof SideClause/c)))]
[parse-rhs (syntax? boolean? syntax? . -> . rhs?)]) [parse-rhs
(-> syntax? boolean? syntax?
rhs?)]
[check-literals-list
(-> syntax?
(listof (list/c identifier? identifier?)))])
(define (atomic-datum? stx) (define (atomic-datum? stx)
(let ([datum (syntax-e stx)]) (let ([datum (syntax-e stx)])
@ -93,7 +98,7 @@
null])) null]))
(define patterns (gather-patterns rest)) (define patterns (gather-patterns rest))
(when (null? patterns) (when (null? patterns)
(wrong-syntax ctx "syntax class has no variants")) (wrong-syntax ctx "expected at least one variant"))
(let ([sattrs (let ([sattrs
(or attributes (or attributes
(intersect-attrss (map rhs:pattern-attrs patterns) ctx))]) (intersect-attrss (map rhs:pattern-attrs patterns) ctx))])
@ -108,7 +113,7 @@
[_ [_
(parse-rhs*-patterns rest)])) (parse-rhs*-patterns rest)]))
;; parse-rhs-pattern : stx boolean boolean (listof identifier) -> RHS ;; parse-rhs-pattern : stx boolean boolean (listof id+id) -> RHS
(define (parse-rhs-pattern stx allow-unbound? literals) (define (parse-rhs-pattern stx allow-unbound? literals)
(syntax-case stx (pattern) (syntax-case stx (pattern)
[(pattern p . rest) [(pattern p . rest)
@ -120,7 +125,7 @@
(unless (stx-null? rest) (unless (stx-null? rest)
(wrong-syntax (if (pair? rest) (car rest) rest) (wrong-syntax (if (pair? rest) (car rest) rest)
"unexpected terms after pattern directives")) "unexpected terms after pattern directives"))
(let* ([pattern (parse-pattern #'p decls 0)] (let* ([pattern (parse-whole-pattern #'p decls)]
[with-patterns [with-patterns
(for/list ([c clauses] #:when (clause:with? c)) (for/list ([c clauses] #:when (clause:with? c))
(clause:with-pattern c))] (clause:with-pattern c))]
@ -130,31 +135,37 @@
[sattrs (iattrs->sattrs attrs remap)]) [sattrs (iattrs->sattrs attrs remap)])
(make rhs:pattern stx sattrs pattern decls remap clauses))))])) (make rhs:pattern stx sattrs pattern decls remap clauses))))]))
;; parse-pattern : stx(Pattern) env number -> Pattern ;; parse-whole-pattern : stx DeclEnv -> Pattern
(define (parse-whole-pattern stx decls)
(define pattern (parse-pattern stx decls 0))
(define pvars (map attr-name (pattern-attrs pattern)))
(define excess-domain (declenv-domain-difference decls pvars))
(when (pair? excess-domain)
(wrong-syntax #f "declared pattern variables do not appear in pattern"
#:extra excess-domain))
pattern)
;; parse-pattern : stx(Pattern) DeclEnv number -> Pattern
(define (parse-pattern stx decls depth) (define (parse-pattern stx decls depth)
(syntax-case stx () (syntax-case stx ()
[dots [dots
(or (dots? #'dots) (or (dots? #'dots)
(gdots? #'dots)) (gdots? #'dots))
(wrong-syntax stx "ellipses not allowed here")] (wrong-syntax stx "ellipses not allowed here")]
[id
(and (identifier? #'id) (eq? (decls #'id) #t))
(make pat:literal stx null depth stx)]
[id [id
(identifier? #'id) (identifier? #'id)
(let-values ([(name sc args) (split-id/get-stxclass #'id decls)]) (match (declenv-lookup decls #'id)
(let ([attrs [(list 'literal internal-id literal-id)
(cond [(wildcard? name) null] (make pat:literal stx null depth literal-id)]
[(and (epsilon? name) sc) [(list 'stxclass declared-id scname args)
(map (lambda (a) (let* ([sc (get-stxclass/check-arg-count scname (length args))]
(make attr (datum->syntax #'id (attr-name a)) [attrs (id-pattern-attrs #'id sc depth)])
(+ depth (attr-depth a)) (make pat:id stx attrs depth #'id sc args))]
(attr-inner a))) [#f
(sc-attrs sc))] (let-values ([(name sc args) (split-id/get-stxclass #'id decls)])
[else (let ([attrs (id-pattern-attrs name sc depth)]
(list (make attr name depth (if sc (sc-attrs sc) null)))])] [name (if (epsilon? name) #f name)])
[name (if (epsilon? name) #f name)]) (make pat:id stx attrs depth name sc args)))])]
(make pat:id stx attrs depth name sc args)))]
[datum [datum
(atomic-datum? #'datum) (atomic-datum? #'datum)
(make pat:datum stx null depth (syntax->datum #'datum))] (make pat:datum stx null depth (syntax->datum #'datum))]
@ -178,6 +189,18 @@
(let ([attrs (append-attrs (list (pattern-attrs pa) (pattern-attrs pb)))]) (let ([attrs (append-attrs (list (pattern-attrs pa) (pattern-attrs pb)))])
(make pat:pair stx attrs depth pa pb)))])) (make pat:pair stx attrs depth pa pb)))]))
(define (id-pattern-attrs name sc depth)
(cond [(wildcard? name) null]
[(and (epsilon? name) sc)
(for/list ([a (sc-attrs sc)])
(make attr (datum->syntax name (attr-name a))
(+ depth (attr-depth a))
(attr-inner a)))]
[sc
(list (make attr name depth (sc-attrs sc)))]
[else
(list (make attr name depth null))]))
(define (pattern->head p) (define (pattern->head p)
(match p (match p
[(struct pattern (orig-stx iattrs depth)) [(struct pattern (orig-stx iattrs depth))
@ -268,88 +291,79 @@
occurs-pvar occurs-pvar
(and default-row (caddr default-row)))))) (and default-row (caddr default-row))))))
;; parse-pattern-directives : stxs(PatternDirective) #:literals (listof id) ;; parse-pattern-directives : stxs(PatternDirective) #:literals (listof id+id)
;; -> stx DeclEnv env (listof SideClause) ;; -> stx DeclEnv RemapEnv (listof SideClause)
;; if decls maps a name to #t, 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])
(let ([decl-table (make-bound-identifier-mapping)] (define remap (new-remapenv))
[remap-table (make-bound-identifier-mapping)] (define-values (chunks rest)
[rclauses null]) (chunk-kw-seq stx pattern-directive-table))
(define (process-renames chunks)
(match chunks
[(cons (list '#:rename rename-stx internal-id sym-id) rest)
(unless sc?
(wrong-syntax rename-stx
"only allowed within syntax-class definition"))
(remapenv-put remap internal-id (syntax-e sym-id))
(process-renames rest)]
[(cons decl rest)
(cons decl (process-renames rest))]
['()
'()]))
(define chunks2 (process-renames chunks))
(define-values (decls chunks3)
(grab-decls chunks2 literals))
(values rest decls remap
(parse-pattern-sides chunks3 literals)))
(define (decls id) ;; grab-decls : (listof chunk) (listof id+id)
(bound-identifier-mapping-get decl-table id (lambda () #f))) ;; -> (values DeclEnv/c (listof chunk))
(define (remap id) (define (grab-decls chunks literals)
(bound-identifier-mapping-get remap-table id (lambda () (syntax-e id)))) (define decls (new-declenv literals))
(define (decls-add! id value) (define (loop chunks)
(bound-identifier-mapping-put! decl-table id value)) (match chunks
[(cons (cons '#:declare decl-stx) rest)
(add-decl decl-stx)
(loop rest)]
[else chunks]))
(define (add-decl stx)
(syntax-case stx ()
[(#:declare name sc)
(identifier? #'sc)
(add-decl #'(#:declare name (sc)))]
[(#:declare name (sc expr ...))
(declenv-put-stxclass decls #'name #'sc (syntax->list #'(expr ...)))]
[(#:declare name bad-sc)
(wrong-syntax #'bad-sc
"expected syntax class name (possibly with parameters)")]))
(let ([rest (loop chunks)])
(values decls rest)))
(define (check-in-sc stx) ;; parse-pattern-sides : (listof chunk) (listof id+id)
(unless sc? ;; -> (listof SideClause/c)
(wrong-syntax (if (pair? stx) (car stx) stx) (define (parse-pattern-sides chunks literals)
"not within syntax-class definition"))) (match chunks
(define directive-table [(cons (list '#:declare declare-stx _ _) rest)
(list (list '#:declare check-id values) (wrong-syntax declare-stx
(list '#:rename check-id check-id) "#:declare can only follow pattern or #:with clause")]
(list '#:with values values) [(cons (list '#:when when-stx expr) rest)
(list '#:when values))) (cons (make clause:when expr)
(define-values (chunks rest) (chunk-kw-seq stx directive-table)) (parse-pattern-sides rest literals))]
(define directives (map cdr chunks)) [(cons (list '#:with with-stx pattern expr) rest)
(let-values ([(decls rest) (grab-decls rest literals)])
(cons (make clause:with (parse-whole-pattern pattern decls) expr)
(parse-pattern-sides rest literals)))]
['()
'()]))
(define (for-decl stx)
(syntax-case stx ()
[[#:declare name sc]
(identifier? #'sc)
(for-decl #'[#:declare name (sc)])]
[[#:declare name (sc expr ...)]
(begin
(let ([prev (decls #'name)])
(when (pair? prev)
(wrong-syntax #'name
"duplicate syntax-class declaration for name"))
(when prev
(wrong-syntax #'name
"name already declared as literal")))
(decls-add! #'name
(list* #'name #'sc (syntax->list #'(expr ...)))))]
[[#:declare . _]
(wrong-syntax stx "bad #:declare form")]
[[#:rename id s]
(begin (check-in-sc stx)
(bound-identifier-mapping-put! remap-table #'id
(if (wildcard? #'s)
#f
(syntax-e #'s))))]
[_ (void)]))
(define (for-side stx)
(syntax-case stx ()
[[#:with p expr]
(let* ([pattern (parse-pattern #'p decls 0)])
(set! rclauses
(cons (make clause:with pattern #'expr) rclauses)))]
[[#:when expr]
(set! rclauses
(cons (make clause:when #'expr) rclauses))]
[_ (void)]))
(for ([literal literals])
(bound-identifier-mapping-put! decl-table literal #t))
(for-each for-decl directives)
(for-each for-side directives)
(values rest
decls
remap
(reverse rclauses))))
;; check-attr-arity-list : stx -> (listof SAttr) ;; check-attr-arity-list : stx -> (listof SAttr)
(define (check-attr-arity-list stx) (define (check-attr-arity-list stx)
(unless (stx-list? stx) (unless (stx-list? stx)
(wrong-syntax stx "expected list of attribute declarations")) (wrong-syntax stx "expected list of attribute declarations"))
(let ([iattrs (map check-attr-arity (stx->list stx))]) (let ([iattrs (map check-attr-arity (stx->list stx))])
(iattrs->sattrs (append-attrs (map list iattrs)) syntax-e))) (iattrs->sattrs (append-attrs (map list iattrs)) trivial-remap)))
;; check-attr-arity : stx -> IAttr ;; check-attr-arity : stx -> IAttr
(define (check-attr-arity stx) (define (check-attr-arity stx)
@ -368,9 +382,31 @@
[_ [_
(wrong-syntax stx "expected attribute arity declaration")])) (wrong-syntax stx "expected attribute arity declaration")]))
;; check-literals-list : syntax -> (listof id)
(define (check-literals-list stx)
(unless (stx-list? stx)
(wrong-syntax stx "expected literals list"))
(let ([lits (map check-literal-entry (stx->list stx))])
(let ([dup (check-duplicate-identifier (map car lits))])
(when dup (wrong-syntax dup "duplicate literal identifier")))
lits))
(define (check-literal-entry stx)
(syntax-case stx ()
[(internal external)
(and (identifier? #'internal) (identifier? #'external))
(list #'internal #'external)]
[id
(identifier? #'id)
(list #'id #'id)]
[_
(wrong-syntax stx
"expected literal (identifier or pair of identifiers)")]))
;; rhs-directive-table ;; rhs-directive-table
(define rhs-directive-table (define rhs-directive-table
(list (list '#:literals check-idlist) (list (list '#:literals check-literals-list)
(list '#:description values) (list '#:description values)
(list '#:transparent) (list '#:transparent)
(list '#:attributes check-attr-arity-list))) (list '#:attributes check-attr-arity-list)))
@ -378,3 +414,10 @@
;; basic-rhs-directive-table ;; basic-rhs-directive-table
(define basic-rhs-directive-table (define basic-rhs-directive-table
(list (list '#:transforming))) (list (list '#:transforming)))
;; pattern-directive-table
(define pattern-directive-table
(list (list '#:declare check-id values)
(list '#:rename check-id check-id)
(list '#:with values values)
(list '#:when values)))

47
collects/stxclass/private/runtime.ss
View File

@ -4,6 +4,7 @@
scheme/stxparam scheme/stxparam
(for-syntax scheme/base) (for-syntax scheme/base)
(for-syntax syntax/stx) (for-syntax syntax/stx)
(for-syntax scheme/private/sc)
(for-syntax "rep-data.ss") (for-syntax "rep-data.ss")
(for-syntax "../util/error.ss")) (for-syntax "../util/error.ss"))
(provide pattern (provide pattern
@ -26,7 +27,10 @@
try try
expectation/c expectation/c
expectation-of-null? expectation-of-null?
expectation->string) expectation->string
let-attributes
attribute)
;; Keywords ;; Keywords
@ -123,7 +127,6 @@
[desc-var (sc-description stxclass)] [desc-var (sc-description stxclass)]
[(arg ...) args]) [(arg ...) args])
(certify #`(begin (certify #`(begin
;;(printf "inner failure was ~s\n" #,result-var)
(make-stxclass-expc (make-stxclass-expc
(make-scdyn 'name (desc-var arg ...) (make-scdyn 'name (desc-var arg ...)
(if (failed? #,result-var) #,result-var #f))))))) (if (failed? #,result-var) #,result-var #f)))))))
@ -250,3 +253,43 @@
[(2) (format "~a ~a~a" (car items) ult (cadr items))] [(2) (format "~a ~a~a" (car items) ult (cadr items))]
[else (let ([strings (list* (car items) (loop (cdr items)))]) [else (let ([strings (list* (car items) (loop (cdr items)))])
(apply string-append strings))])) (apply string-append strings))]))
;; Attributes
(begin-for-syntax
(define-struct attribute-mapping (var)
#:omit-define-syntaxes
#:property prop:procedure
(lambda (self stx)
#`(#%expression #,(attribute-mapping-var self)))))
(define-syntax (let-attributes stx)
(syntax-case stx ()
[(let-attributes ([attr depth value] ...) . body)
(with-syntax ([(vtmp ...) (generate-temporaries #'(attr ...))]
[(stmp ...) (generate-temporaries #'(attr ...))])
#'(letrec-syntaxes+values
([(stmp) (make-attribute-mapping (quote-syntax vtmp))]
...)
([(vtmp) value] ...)
(letrec-syntaxes+values
([(attr) (make-syntax-mapping 'depth (quote-syntax stmp))] ...)
()
. body)))]))
(define-syntax (attribute stx)
(parameterize ((current-syntax-context stx))
(syntax-case stx ()
[(attribute name)
(identifier? #'name)
(let ([mapping (syntax-local-value #'name (lambda () #f))])
(unless (syntax-mapping? mapping)
(wrong-syntax #'name "not bound as a pattern variable"))
(let ([var (syntax-mapping-valvar mapping)])
(let ([attr (syntax-local-value var (lambda () #f))])
(unless (attribute-mapping? attr)
(wrong-syntax #'name "not bound as an attribute"))
(syntax-property (attribute-mapping-var attr)
'disappeared-use
#'name))))])))

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

@ -18,9 +18,6 @@
parse-sc parse-sc
attrs-of attrs-of
debug-rhs
debug-pattern
syntax-parse syntax-parse
syntax-parser syntax-parser
with-patterns with-patterns
@ -29,6 +26,8 @@
basic-syntax-class basic-syntax-class
...* ...*
attribute
(struct-out failed) (struct-out failed)
current-expression current-expression
@ -141,7 +140,8 @@
(syntax-case stx () (syntax-case stx ()
[(parse s x arg ...) [(parse s x arg ...)
(parameterize ((current-syntax-context stx)) (parameterize ((current-syntax-context stx))
(let* ([stxclass (get-stxclass #'s)] (let* ([arg-count (length (syntax->list #'(arg ...)))]
[stxclass (get-stxclass/check-arg-count #'s arg-count)]
[attrs (flatten-sattrs (sc-attrs stxclass))]) [attrs (flatten-sattrs (sc-attrs stxclass))])
(with-syntax ([parser (sc-parser-name stxclass)] (with-syntax ([parser (sc-parser-name stxclass)]
[(name ...) (map attr-name attrs)] [(name ...) (map attr-name attrs)]
@ -166,12 +166,6 @@
(let ([rhs (parse-rhs #'rhs #f stx)]) (let ([rhs (parse-rhs #'rhs #f stx)])
#`(quote #,rhs))])) #`(quote #,rhs))]))
(define-syntax (debug-pattern stx)
(syntax-case stx ()
[(debug-pattern p)
(let ([pattern (parse-pattern #'p)])
#`(quote #,pattern))]))
(define-syntax-rule (syntax-parse stx-expr . clauses) (define-syntax-rule (syntax-parse stx-expr . clauses)
(let ([x stx-expr]) (let ([x stx-expr])
(syntax-parse* syntax-parse x . clauses))) (syntax-parse* syntax-parse x . clauses)))

32
collects/stxclass/scribblings/parsing-syntax.scrbl
View File

@ -21,7 +21,9 @@ parsing syntax.
@defform/subs[(syntax-parse stx-expr maybe-literals clause ...) @defform/subs[(syntax-parse stx-expr maybe-literals clause ...)
([maybe-literals code:blank ([maybe-literals code:blank
(code:line #:literals (literal-id ...))] (code:line #:literals (literal ...))]
[literal id
(internal-id external-id)]
[clause (syntax-pattern pattern-directive ... expr)])]{ [clause (syntax-pattern pattern-directive ... expr)])]{
Evaluates @scheme[stx-expr], which should produce a syntax object, and Evaluates @scheme[stx-expr], which should produce a syntax object, and
@ -35,8 +37,12 @@ matches fail the corresponding clauses' side conditions), a syntax
error is raised. The syntax error indicates the first specific subterm error is raised. The syntax error indicates the first specific subterm
for which no pattern matches. for which no pattern matches.
@TODO{Allow literal declarations of form @scheme[(_internal-name A literal in the literals list has two components: the identifier used
_external-name)].} within the pattern to signify the positions to be matched, and the
identifier expected to occur in those positions. If the
single-identifier form is used, the same identifier is used for both
purposes.
} }
@defform[(syntax-parser maybe-literals clause ...)]{ @defform[(syntax-parser maybe-literals clause ...)]{
@ -92,6 +98,11 @@ An identifier that appears in the literals list is not a pattern
variable; instead, it is a literal that matches any identifier variable; instead, it is a literal that matches any identifier
@scheme[free-identifier=?] to it. @scheme[free-identifier=?] to it.
Specifically, if @scheme[literal-id] is the ``internal'' name of an
entry in the literals list, then it represents a pattern that matches
only identifiers @scheme[free-identifier=?] to the ``external''
name. These identifiers are often the same.
} }
@specsubform[atomic-datum]{ @specsubform[atomic-datum]{
@ -237,3 +248,18 @@ generalized sequences. It may not be used as an expression.
} }
@defform[(attribute attr-id)]{
Returns the value associated with the attribute named
@scheme[attr-id]. If @scheme[attr-id] is not bound as an attribute, an
error is raised. If @scheme[attr-id] is an attribute with a nonzero
ellipsis depth, then the result has the corresponding level of list
nesting.
The values returned by @scheme[attribute] never undergo additional
wrapping as syntax objects, unlike values produced by some uses of
@scheme[syntax], @scheme[quasisyntax], etc. Consequently, the
@scheme[attribute] form is preferred when the attribute value is used
as data, not placed in a syntax object.
}

17
collects/stxclass/scribblings/syntax-classes.scrbl
View File

@ -45,7 +45,8 @@ depth is fixed for each syntax class.
([stxclass-options ([stxclass-options
(code:line #:attributes (attr-arity-decl ...)) (code:line #:attributes (attr-arity-decl ...))
(code:line #:description description) (code:line #:description description)
(code:line #:transparent)] (code:line #:transparent)
(code:line #:literals (literal-entry ...))]
[attr-arity-decl [attr-arity-decl
attr-name-id attr-name-id
(attr-name-id depth)] (attr-name-id depth)]
@ -88,6 +89,20 @@ Indicates that errors may be reported with respect to the internal
structure of the syntax class. structure of the syntax class.
} }
@specsubform[(code:line #:literals (literal-entry))]{
Declares the literal identifiers for the syntax class's main patterns
(immediately within @scheme[pattern] variants) and @scheme[#:with]
clauses. The literals list does not affect patterns that occur within
subexpressions inside the syntax class (for example, the condition of
a @scheme[#:when] clause or the right-hand side of a @scheme[#:with]
binding).
A literal can have separate internal and external names, as described
for @scheme[syntax-parse].
}
@specsubform/subs[#:literals (pattern) @specsubform/subs[#:literals (pattern)
(pattern syntax-pattern stxclass-pattern-directive ...) (pattern syntax-pattern stxclass-pattern-directive ...)
([stxclass-pattern-directive ([stxclass-pattern-directive

5
collects/stxclass/util/error.ss
View File

@ -4,7 +4,7 @@
(define current-syntax-context (make-parameter #f)) (define current-syntax-context (make-parameter #f))
(define (wrong-syntax stx format-string . args) (define (wrong-syntax stx #:extra [extras null] format-string . args)
(unless (or (eq? stx #f) (syntax? stx)) (unless (or (eq? stx #f) (syntax? stx))
(raise-type-error 'wrong-syntax "syntax or #f" 0 (list* stx format-string args))) (raise-type-error 'wrong-syntax "syntax or #f" 0 (list* stx format-string args)))
(let* ([ctx (current-syntax-context)] (let* ([ctx (current-syntax-context)]
@ -12,4 +12,5 @@
(raise-syntax-error (if (symbol? blame) blame #f) (raise-syntax-error (if (symbol? blame) blame #f)
(apply format format-string args) (apply format format-string args)
ctx ctx
(or stx ctx)))) (or stx ctx)
extras)))

16
collects/tests/stxclass/stxclass.ss
View File

@ -291,8 +291,16 @@
(with-handlers ([exn? exn-message]) (with-handlers ([exn? exn-message])
(syntax-parse #'(0 1) [_:Transparent 'ok])) (syntax-parse #'(0 1) [_:Transparent 'ok]))
#; (syntax-parse #'(+) #:literals ([plus +])
(syntax-parse #'1 [(plus) (void)])
[_:Transparent 'ok]
[(a b) 'ok])
(define-syntax-class (nat> n)
#:description (format "nat > ~s" n)
(pattern x:nat #:when (> (syntax-e #'x) n)))
(syntax-parse #'(1 2 3)
[(a:nat b0:nat c0:nat)
#:with b #'b0
#:declare b (nat> (attribute a.datum))
#:with c #'c0
#:declare c (nat> (attribute b0.datum))
(void)])

2
collects/typed-scheme/private/parse-type.ss
View File

@ -144,8 +144,8 @@
(define-syntax-class type-app (define-syntax-class type-app
(pattern (i arg:type args:type ...) (pattern (i arg:type args:type ...)
#:when (identifier? #'i)
#:declare i type #:declare i type
#:when (identifier? #'i)
#:with t #:with t
(let loop (let loop
([rator #'i.t] [args (syntax->datum #'(arg.t args.t ...))]) ([rator #'i.t] [args (syntax->datum #'(arg.t args.t ...))])