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

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

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

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

@ -2,6 +2,7 @@
(require scheme/contract
scheme/match
syntax/stx
syntax/boundmap
"../util.ss")
(provide (struct-out sc)
(struct-out attr)
@ -24,10 +25,6 @@
#:property prop:procedure (lambda (self stx) (sc-parser-name self))
#: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 SAttr is (make-attr symbol number (listof SAttr))
(define-struct attr (name depth inner)
@ -86,19 +83,93 @@
(define (sattr? 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
;; 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
(-> identifier?
(or/c boolean? (cons/c identifier? (cons/c identifier? (listof syntax?))))))
(flat-named-contract "DeclEnv/c" declenv?))
(define RemapEnv/c
(-> identifier? symbol?))
(define SideClause/c (or/c clause:with? clause:when?))
(flat-named-contract "RemapEnv/c" bound-identifier-mapping?))
(define SideClause/c
(or/c clause:with? clause:when?))
(provide/contract
[DeclEnv/c contract?]
@ -109,24 +180,63 @@
[allow-unbound-stxclasses (parameter/c boolean?)]
[iattr? (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?)]
[rename-attr (attr? symbol? . -> . sattr?)]
[iattrs->sattrs ((listof iattr?) (identifier? . -> . symbol?) . -> . (listof sattr?))]
[rename-attr
(attr? symbol? . -> . sattr?)]
[iattrs->sattrs
(-> (listof iattr?) RemapEnv/c
(listof sattr?))]
[sattr->iattr/id (sattr? identifier? . -> . iattr?)]
[get-stxclass (-> identifier? any)]
[split-id/get-stxclass (-> identifier? any/c any)]
[get-stxclass
(-> 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?))]
[join-attrs (sattr? sattr? syntax? . -> . sattr?)]
[reorder-iattrs
((listof sattr?) (listof iattr?) (identifier? . -> . symbol?) . -> . (listof iattr?))]
(-> (listof sattr?) (listof iattr?) RemapEnv/c
(listof iattr?))]
[restrict-iattrs
((listof sattr?) (listof iattr?) (identifier? . -> . symbol?) . -> . (listof iattr?))]
(-> (listof sattr?) (listof iattr?) RemapEnv/c
(listof iattr?))]
[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?))]
[flatten-attrs* any/c]
[flatten-attrs*
(->* [(listof iattr?)]
[exact-nonnegative-integer? any/c any/c]
(listof iattr?))]
[append-attrs ((listof (listof iattr?)) . -> . (listof iattr?))]
[lookup-sattr (symbol? (listof sattr?) . -> . (or/c sattr? false/c))]
[lookup-iattr (identifier? (listof iattr?) . -> . (or/c iattr? false/c))]
@ -145,7 +255,7 @@
(define (iattrs->sattrs as remap)
(if (pair? as)
(let ([name* (remap (attr-name (car as)))])
(let ([name* (remapenv-lookup remap (attr-name (car as)))])
(if name*
(cons (rename-attr (car as) name*)
(iattrs->sattrs (cdr as) remap))
@ -168,35 +278,31 @@
sc
(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)
(cond [(regexp-match #rx"^([^:]*):(.+)$" (symbol->string (syntax-e id0)))
=> (lambda (m)
(define id (datum->syntax id0 (string->symbol (cadr m)) id0 id0))
(define scname (datum->syntax id0 (string->symbol (caddr m)) id0 id0))
(match (decls id)
[#t
(wrong-syntax id "name already declared as literal")]
[(list* id2 scname2 args)
(wrong-syntax id2
"name already declared with syntax-class ~s"
(syntax-e scname))]
[_ (void)])
(let ([sc (get-stxclass scname)])
(define id
(datum->syntax id0 (string->symbol (cadr m)) id0 id0))
(define scname
(datum->syntax id0 (string->symbol (caddr m)) id0 id0))
(declenv-check-unbound decls id (syntax-e scname)
#:blame-declare? #t)
(let ([sc (get-stxclass/check-arg-count scname 0)])
(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)]))
;; intersect-attrss : (listof (listof SAttr)) stx -> (listof SAttr)
(define (intersect-attrss attrss blamestx)
(cond [(null? attrss) null]
@ -226,20 +332,21 @@
a
(begin
(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)
(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
;; If a relsattr is not found, or if depth or contents mismatches, raises error.
(define (reorder-iattrs relsattrs iattrs remap)
(let ([ht (make-hasheq)])
(for-each (lambda (iattr)
(let ([remap-name (remap (attr-name iattr))])
(for ([iattr iattrs])
(let ([remap-name (remapenv-lookup remap (attr-name iattr))])
(hash-set! ht remap-name iattr)))
iattrs)
(let loop ([relsattrs relsattrs])
(match relsattrs
['() null]
@ -256,13 +363,13 @@
(intersect-sattrs inner (attr-inner iattr)))
(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
(define (restrict-iattrs relsattrs iattrs remap)
(match iattrs
['() null]
[(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)))
(cons (make attr name depth
(intersect-sattrs inner (attr-inner sattr)))

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

@ -9,14 +9,19 @@
"rep-data.ss")
(provide/contract
[parse-pattern
(-> any/c #|syntax?|# DeclEnv/c exact-nonnegative-integer?
[parse-whole-pattern
(-> syntax? DeclEnv/c
pattern?)]
[parse-pattern-directives
(->* [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)))]
[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)
(let ([datum (syntax-e stx)])
@ -93,7 +98,7 @@
null]))
(define patterns (gather-patterns rest))
(when (null? patterns)
(wrong-syntax ctx "syntax class has no variants"))
(wrong-syntax ctx "expected at least one variant"))
(let ([sattrs
(or attributes
(intersect-attrss (map rhs:pattern-attrs patterns) ctx))])
@ -108,7 +113,7 @@
[_
(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)
(syntax-case stx (pattern)
[(pattern p . rest)
@ -120,7 +125,7 @@
(unless (stx-null? rest)
(wrong-syntax (if (pair? rest) (car rest) rest)
"unexpected terms after pattern directives"))
(let* ([pattern (parse-pattern #'p decls 0)]
(let* ([pattern (parse-whole-pattern #'p decls)]
[with-patterns
(for/list ([c clauses] #:when (clause:with? c))
(clause:with-pattern c))]
@ -130,31 +135,37 @@
[sattrs (iattrs->sattrs attrs remap)])
(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)
(syntax-case stx ()
[dots
(or (dots? #'dots)
(gdots? #'dots))
(wrong-syntax stx "ellipses not allowed here")]
[id
(and (identifier? #'id) (eq? (decls #'id) #t))
(make pat:literal stx null depth stx)]
[id
(identifier? #'id)
(match (declenv-lookup decls #'id)
[(list 'literal internal-id literal-id)
(make pat:literal stx null depth literal-id)]
[(list 'stxclass declared-id scname args)
(let* ([sc (get-stxclass/check-arg-count scname (length args))]
[attrs (id-pattern-attrs #'id sc depth)])
(make pat:id stx attrs depth #'id sc args))]
[#f
(let-values ([(name sc args) (split-id/get-stxclass #'id decls)])
(let ([attrs
(cond [(wildcard? name) null]
[(and (epsilon? name) sc)
(map (lambda (a)
(make attr (datum->syntax #'id (attr-name a))
(+ depth (attr-depth a))
(attr-inner a)))
(sc-attrs sc))]
[else
(list (make attr name depth (if sc (sc-attrs sc) null)))])]
(let ([attrs (id-pattern-attrs name sc depth)]
[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
(atomic-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)))])
(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)
(match p
[(struct pattern (orig-stx iattrs depth))
@ -268,88 +291,79 @@
occurs-pvar
(and default-row (caddr default-row))))))
;; parse-pattern-directives : stxs(PatternDirective) #:literals (listof id)
;; -> stx DeclEnv env (listof SideClause)
;; if decls maps a name to #t, it indicates literal
;; parse-pattern-directives : stxs(PatternDirective) #:literals (listof id+id)
;; -> stx DeclEnv RemapEnv (listof SideClause)
(define (parse-pattern-directives stx
#:sc? [sc? #f]
#:literals [literals null])
(let ([decl-table (make-bound-identifier-mapping)]
[remap-table (make-bound-identifier-mapping)]
[rclauses null])
(define (decls id)
(bound-identifier-mapping-get decl-table id (lambda () #f)))
(define (remap 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 remap (new-remapenv))
(define-values (chunks rest)
(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 (if (pair? stx) (car stx) stx)
"not within syntax-class definition")))
(define directive-table
(list (list '#:declare check-id values)
(list '#:rename check-id check-id)
(list '#:with values values)
(list '#:when values)))
(define-values (chunks rest) (chunk-kw-seq stx directive-table))
(define directives (map cdr chunks))
(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 (for-decl stx)
;; grab-decls : (listof chunk) (listof id+id)
;; -> (values DeclEnv/c (listof chunk))
(define (grab-decls chunks literals)
(define decls (new-declenv literals))
(define (loop chunks)
(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]
[(#: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)]))
(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)))
(for ([literal literals])
(bound-identifier-mapping-put! decl-table literal #t))
;; parse-pattern-sides : (listof chunk) (listof id+id)
;; -> (listof SideClause/c)
(define (parse-pattern-sides chunks literals)
(match chunks
[(cons (list '#:declare declare-stx _ _) rest)
(wrong-syntax declare-stx
"#:declare can only follow pattern or #:with clause")]
[(cons (list '#:when when-stx expr) rest)
(cons (make clause:when expr)
(parse-pattern-sides rest literals))]
[(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)))]
['()
'()]))
(for-each for-decl directives)
(for-each for-side directives)
(values rest
decls
remap
(reverse rclauses))))
;; check-attr-arity-list : stx -> (listof SAttr)
(define (check-attr-arity-list stx)
(unless (stx-list? stx)
(wrong-syntax stx "expected list of attribute declarations"))
(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
(define (check-attr-arity stx)
@ -368,9 +382,31 @@
[_
(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
(define rhs-directive-table
(list (list '#:literals check-idlist)
(list (list '#:literals check-literals-list)
(list '#:description values)
(list '#:transparent)
(list '#:attributes check-attr-arity-list)))
@ -378,3 +414,10 @@
;; basic-rhs-directive-table
(define basic-rhs-directive-table
(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
(for-syntax scheme/base)
(for-syntax syntax/stx)
(for-syntax scheme/private/sc)
(for-syntax "rep-data.ss")
(for-syntax "../util/error.ss"))
(provide pattern
@ -26,7 +27,10 @@
try
expectation/c
expectation-of-null?
expectation->string)
expectation->string
let-attributes
attribute)
;; Keywords
@ -123,7 +127,6 @@
[desc-var (sc-description stxclass)]
[(arg ...) args])
(certify #`(begin
;;(printf "inner failure was ~s\n" #,result-var)
(make-stxclass-expc
(make-scdyn 'name (desc-var arg ...)
(if (failed? #,result-var) #,result-var #f)))))))
@ -250,3 +253,43 @@
[(2) (format "~a ~a~a" (car items) ult (cadr items))]
[else (let ([strings (list* (car items) (loop (cdr items)))])
(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
attrs-of
debug-rhs
debug-pattern
syntax-parse
syntax-parser
with-patterns
@ -29,6 +26,8 @@
basic-syntax-class
...*
attribute
(struct-out failed)
current-expression
@ -141,7 +140,8 @@
(syntax-case stx ()
[(parse s x arg ...)
(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))])
(with-syntax ([parser (sc-parser-name stxclass)]
[(name ...) (map attr-name attrs)]
@ -166,12 +166,6 @@
(let ([rhs (parse-rhs #'rhs #f stx)])
#`(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)
(let ([x stx-expr])
(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 ...)
([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)])]{
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
for which no pattern matches.
@TODO{Allow literal declarations of form @scheme[(_internal-name
_external-name)].}
A literal in the literals list has two components: the identifier used
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 ...)]{
@ -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
@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]{
@ -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
(code:line #:attributes (attr-arity-decl ...))
(code:line #:description description)
(code:line #:transparent)]
(code:line #:transparent)
(code:line #:literals (literal-entry ...))]
[attr-arity-decl
attr-name-id
(attr-name-id depth)]
@ -88,6 +89,20 @@ Indicates that errors may be reported with respect to the internal
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)
(pattern syntax-pattern 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 (wrong-syntax stx format-string . args)
(define (wrong-syntax stx #:extra [extras null] format-string . args)
(unless (or (eq? stx #f) (syntax? stx))
(raise-type-error 'wrong-syntax "syntax or #f" 0 (list* stx format-string args)))
(let* ([ctx (current-syntax-context)]
@ -12,4 +12,5 @@
(raise-syntax-error (if (symbol? blame) blame #f)
(apply format format-string args)
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])
(syntax-parse #'(0 1) [_:Transparent 'ok]))
#;
(syntax-parse #'1
[_:Transparent 'ok]
[(a b) 'ok])
(syntax-parse #'(+) #:literals ([plus +])
[(plus) (void)])
(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
(pattern (i arg:type args:type ...)
#:when (identifier? #'i)
#:declare i type
#:when (identifier? #'i)
#:with t
(let loop
([rator #'i.t] [args (syntax->datum #'(arg.t args.t ...))])