649 lines
25 KiB
Scheme
649 lines
25 KiB
Scheme
|
|
#lang scheme
|
|
(require (for-template "kws.ss")
|
|
(for-template scheme/base)
|
|
scheme/contract
|
|
syntax/boundmap
|
|
syntax/stx
|
|
"util.ss")
|
|
(provide (struct-out sc)
|
|
(struct-out attr)
|
|
(struct-out rhs)
|
|
(struct-out rhs:union)
|
|
(struct-out rhs:pattern)
|
|
(struct-out pattern)
|
|
(struct-out pat:id)
|
|
(struct-out pat:datum)
|
|
(struct-out pat:literal)
|
|
(struct-out pat:pair)
|
|
(struct-out pat:splice)
|
|
(struct-out pat:gseq)
|
|
(struct-out splice-pattern)
|
|
(struct-out pat:splice-id)
|
|
(struct-out head)
|
|
(struct-out clause:where)
|
|
(struct-out clause:with)
|
|
|
|
get-stxclass
|
|
parse-pattern
|
|
parse-pattern-directives
|
|
flatten-attrs*
|
|
format-symbol)
|
|
|
|
;; An SC is one of (make-sc symbol (listof symbol) (list-of SAttr) identifier)
|
|
(define-struct sc (name inputs attrs parser-name)
|
|
#: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)
|
|
#:transparent)
|
|
|
|
;; A RHS is one of
|
|
;; (make-rhs:union <RHS> (listof RHS))
|
|
;; (make-rhs:pattern <RHS> Pattern Env Env (listof SideClause))
|
|
;; where <RHS> is stx (listof SAttr)
|
|
(define-struct rhs (orig-stx attrs) #:transparent)
|
|
(define-struct (rhs:union rhs) (rhss) #:transparent)
|
|
(define-struct (rhs:pattern rhs) (pattern decls remap wheres) #:transparent)
|
|
|
|
;; A Pattern is one of
|
|
;; (make-pat:id <Pattern> identifier SC/#f (listof stx))
|
|
;; (make-pat:datum <Pattern> datum)
|
|
;; (make-pat:pair <Pattern> Pattern Pattern)
|
|
;; (make-pat:seq <Pattern> Pattern Pattern)
|
|
;; (make-pat:gseq <Pattern> (listof Head) Pattern)
|
|
;; where <Pattern> = stx (listof IAttr) number
|
|
(define-struct pattern (orig-stx attrs depth) #:transparent)
|
|
(define-struct (pat:id pattern) (name stxclass args) #:transparent)
|
|
(define-struct (pat:datum pattern) (datum) #:transparent)
|
|
(define-struct (pat:literal pattern) (literal) #:transparent)
|
|
(define-struct (pat:pair pattern) (head tail) #:transparent)
|
|
(define-struct (pat:splice pattern) (head tail) #:transparent)
|
|
(define-struct (pat:gseq pattern) (heads tail) #:transparent)
|
|
|
|
;; A SplicePattern is one of
|
|
;; (make-pat:splice-id <Pattern> identifier SSC (listof stx))
|
|
(define-struct (splice-pattern pattern) ()
|
|
#:transparent)
|
|
(define-struct (pat:splice-id splice-pattern) (name stx-splice-class args)
|
|
#:transparent)
|
|
|
|
;; A Head is
|
|
;; (make-head stx (listof IAttr) nat (listof Pattern) nat/f nat/f boolean id/#f stx/#f)
|
|
(define-struct head (orig-stx attrs depth ps min max as-list? occurs default)
|
|
#:transparent)
|
|
|
|
;; A SideClause is one of
|
|
;; (make-clause:with pattern stx)
|
|
;; (make-clause:where stx)
|
|
(define-struct clause:with (pattern expr) #:transparent)
|
|
(define-struct clause:where (expr) #:transparent)
|
|
|
|
;; make-empty-sc : identifier => SC
|
|
;; Dummy stxclass for calculating attributes of recursive stxclasses.
|
|
(define (make-empty-sc name)
|
|
(make sc (syntax-e name) null null #f))
|
|
|
|
(define (iattr? a)
|
|
(and (attr? a) (identifier? (attr-name a))))
|
|
|
|
(define (sattr? a)
|
|
(and (attr? a) (symbol? (attr-name a))))
|
|
|
|
(provide/contract
|
|
[iattr? (any/c . -> . boolean?)]
|
|
[sattr? (any/c . -> . boolean?)]
|
|
[reorder-iattrs
|
|
((listof sattr?) (listof iattr?) (identifier? . -> . symbol?) . -> . (listof iattr?))]
|
|
[parse-rhs (syntax? boolean? . -> . rhs?)]
|
|
[parse-splice-rhs (syntax? boolean? . -> . rhs?)]
|
|
[flatten-sattrs
|
|
([(listof sattr?)] [exact-integer? (or/c symbol? false/c)] . ->* . (listof sattr?))]
|
|
|
|
#|
|
|
[iattr->sattr (iattr? . -> . sattr?)]
|
|
[rename-attr (attr? symbol? . -> . sattr?)]
|
|
[iattrs->sattrs ((listof iattr?) (identifier? . -> . symbol?) . -> . (listof sattr?))]
|
|
[sattr->iattr/id (sattr? identifier? . -> . iattr?)]
|
|
[atomic-datum? (syntax? . -> . boolean?)]
|
|
[wildcard? (syntax? . -> . boolean?)]
|
|
[dots? (syntax? . -> . boolean?)]
|
|
[append-attrs ((listof (listof iattr?)) syntax? . -> . (listof iattr?))]
|
|
[intersect-attrss ((listof (listof sattr?)) syntax? . -> . (listof sattr?))]
|
|
[join-attrs (sattr? sattr? syntax? . -> . sattr?)]
|
|
[restrict-iattrs
|
|
((listof sattr?) (listof iattr?) (identifier? . -> . symbol?) . -> . (listof iattr?))]
|
|
[intersect-sattrs ((listof sattr?) (listof sattr?) . -> . (listof sattr?))]
|
|
[lookup-sattr (symbol? (listof sattr?) . -> . (or/c sattr? false/c))]
|
|
[lookup-iattr (identifier? (listof iattr?) . -> . (or/c iattr? false/c))]
|
|
|#
|
|
)
|
|
|
|
(define (iattr->sattr a)
|
|
(match a
|
|
[(struct attr (name depth inner))
|
|
(make attr (syntax-e name) depth inner)]))
|
|
|
|
(define (rename-attr a name)
|
|
(make attr name (attr-depth a) (attr-inner a)))
|
|
|
|
(define (iattrs->sattrs as remap)
|
|
(if (pair? as)
|
|
(let ([name* (remap (attr-name (car as)))])
|
|
(if name*
|
|
(cons (rename-attr (car as) name*)
|
|
(iattrs->sattrs (cdr as) remap))
|
|
(iattrs->sattrs (cdr as) remap)))
|
|
null))
|
|
|
|
(define (sattr->iattr/id a id)
|
|
(match a
|
|
[(struct attr (name depth inner))
|
|
(make attr (datum->syntax id name id) depth inner)]))
|
|
|
|
(define (get-stxclass id [blame 'syntax-class])
|
|
(define (no-good)
|
|
(if (allow-unbound-stxclasses)
|
|
(make-empty-sc id)
|
|
(raise-syntax-error blame "not defined as syntax class" id)))
|
|
(let ([sc (syntax-local-value id no-good)])
|
|
(unless (or (sc? sc) (ssc? sc))
|
|
(no-good))
|
|
sc))
|
|
|
|
(define (split-id/get-stxclass id [decls (lambda _ #f)])
|
|
(cond [(regexp-match #rx"^([^:]*):(.+)$" (symbol->string (syntax-e id)))
|
|
=> (lambda (m)
|
|
(when (decls id)
|
|
(raise-syntax-error 'syntax-class
|
|
"name already declared with syntax class"
|
|
id))
|
|
(let ([sc (get-stxclass (datum->syntax id (string->symbol (caddr m))))])
|
|
(values (datum->syntax id (string->symbol (cadr m)) id id)
|
|
sc
|
|
null
|
|
(ssc? sc))))]
|
|
[(decls id)
|
|
=> (lambda (p)
|
|
(let ([stxclass (car p)]
|
|
[args (cdr p)])
|
|
(unless (equal? (length (sc-inputs stxclass)) (length args))
|
|
(raise-syntax-error 'syntax-class
|
|
"too few arguments for syntax class"
|
|
id))
|
|
(values id stxclass args (ssc? stxclass))))]
|
|
[else (values id #f null #f)]))
|
|
|
|
(define (atomic-datum? stx)
|
|
(let ([datum (syntax-e stx)])
|
|
(or (null? datum)
|
|
(boolean? datum)
|
|
(string? datum)
|
|
(number? datum)
|
|
(keyword? datum))))
|
|
|
|
(define (wildcard? stx)
|
|
(and (identifier? stx)
|
|
(or (free-identifier=? stx (quote-syntax _)))))
|
|
|
|
(define (epsilon? stx)
|
|
(and (identifier? stx)
|
|
(free-identifier=? stx (quote-syntax ||))))
|
|
|
|
(define (dots? stx)
|
|
(and (identifier? stx)
|
|
(free-identifier=? stx (quote-syntax ...))))
|
|
|
|
(define (gdots? stx)
|
|
(and (identifier? stx)
|
|
(free-identifier=? stx (quote-syntax ...*))))
|
|
|
|
;; ---
|
|
|
|
(define allow-unbound-stxclasses (make-parameter #f))
|
|
|
|
;; parse-rhs : stx(SyntaxClassRHS) boolean -> RHS
|
|
;; If allow-unbound? is true, then unbound stxclass acts as if it has no attrs.
|
|
;; Used for pass1 (attr collection); parser requires stxclasses to be bound.
|
|
(define (parse-rhs stx allow-unbound?)
|
|
(parse-rhs* stx allow-unbound? #f))
|
|
|
|
;; parse-splice-rhs : stx(SyntaxClassRHS) boolean -> RHS
|
|
;; If allow-unbound? is true, then unbound stxclass acts as if it has no attrs.
|
|
;; Used for pass1 (attr collection); parser requires stxclasses to be bound.
|
|
(define (parse-splice-rhs stx allow-unbound?)
|
|
(parse-rhs* stx allow-unbound? #t))
|
|
|
|
;; parse-rhs* : stx boolean boolean -> RHS
|
|
(define (parse-rhs* stx allow-unbound? splice?)
|
|
(syntax-case stx (pattern union)
|
|
[(pattern p . rest)
|
|
(parameterize ((allow-unbound-stxclasses allow-unbound?))
|
|
(let-values ([(rest decls remap clauses)
|
|
(parse-pattern-directives #'rest #:sc? #t)])
|
|
(unless (stx-null? rest)
|
|
(raise-syntax-error #f "unexpected terms after pattern directives"
|
|
(if (pair? rest) (car rest) rest)))
|
|
(let* ([pattern (parse-pattern #'p decls 0)]
|
|
[_ (when splice?
|
|
(check-proper-list-pattern pattern))]
|
|
[with-patterns
|
|
(for/list ([c clauses] #:when (clause:with? c))
|
|
(clause:with-pattern c))]
|
|
[attrs (append-attrs
|
|
(cons (pattern-attrs pattern)
|
|
(map pattern-attrs with-patterns))
|
|
stx)]
|
|
[sattrs (iattrs->sattrs attrs remap)])
|
|
(make rhs:pattern stx sattrs pattern decls remap clauses))))]
|
|
[(union p ...)
|
|
(let* ([rhss (for/list ([rhs (syntax->list #'(p ...))])
|
|
(parse-rhs* rhs allow-unbound? splice?))]
|
|
[sattrs (intersect-attrss (map rhs-attrs rhss) stx)])
|
|
(make rhs:union stx sattrs rhss))]
|
|
[(id arg ...)
|
|
(identifier? #'id)
|
|
(parse-rhs* (syntax/loc stx (pattern || #:declare || (id arg ...)))
|
|
allow-unbound?
|
|
splice?)]
|
|
[id
|
|
(identifier? #'id)
|
|
(parse-rhs* (syntax/loc stx (pattern || #:declare || id))
|
|
allow-unbound?
|
|
splice?)]))
|
|
|
|
;; parse-pattern : stx(Pattern) env number -> Pattern
|
|
(define (parse-pattern stx [decls (lambda _ #f)] [depth 0] [allow-splice? #f])
|
|
(syntax-case stx ()
|
|
[dots
|
|
(or (dots? #'dots)
|
|
(gdots? #'dots))
|
|
(raise-syntax-error 'pattern "ellipses not allowed here" stx)]
|
|
[id
|
|
(and (identifier? #'id) (eq? (decls #'id) #t))
|
|
(make pat:literal stx null depth stx)]
|
|
[id
|
|
(identifier? #'id)
|
|
(let-values ([(name sc args splice?) (split-id/get-stxclass #'id decls)])
|
|
(when splice?
|
|
(unless allow-splice?
|
|
(raise-syntax-error 'pattern
|
|
"splice-pattern not allowed here"
|
|
stx)))
|
|
(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)))])]
|
|
[name (if (epsilon? name) #f name)])
|
|
(if splice?
|
|
(make pat:splice-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))]
|
|
[(heads gdots . tail)
|
|
(gdots? #'gdots)
|
|
(let* ([heads (parse-heads #'heads decls (add1 depth))]
|
|
[tail (parse-pattern #'tail decls depth)]
|
|
[hattrs (append-attrs (for/list ([head heads]) (head-attrs head)) stx)]
|
|
[tattrs (pattern-attrs tail)])
|
|
(make pat:gseq stx (append-attrs (list hattrs tattrs) stx) depth heads tail))]
|
|
[(head dots . tail)
|
|
(dots? #'dots)
|
|
(let* ([headp (parse-pattern #'head decls (add1 depth))]
|
|
[tail (parse-pattern #'tail decls depth)]
|
|
[head (pattern->head headp)]
|
|
[attrs (append-attrs (list (head-attrs head) (pattern-attrs tail)) stx)])
|
|
(make pat:gseq stx attrs depth (list head) tail))]
|
|
[(a . b)
|
|
(let ([pa (parse-pattern #'a decls depth #t)]
|
|
[pb (parse-pattern #'b decls depth)])
|
|
(let ([attrs (append-attrs (list (pattern-attrs pa) (pattern-attrs pb)) stx)])
|
|
(if (splice-pattern? pa)
|
|
(make pat:splice stx attrs depth pa pb)
|
|
(make pat:pair stx attrs depth pa pb))))]))
|
|
|
|
(define (pattern->head p)
|
|
(match p
|
|
[(struct pattern (orig-stx iattrs depth))
|
|
(make head orig-stx iattrs depth (list p) #f #f #t #f #f)]))
|
|
|
|
(define (parse-heads stx decls depth)
|
|
(syntax-case stx ()
|
|
[({} . more)
|
|
(raise-syntax-error 'pattern "empty head sequence not allowed" (stx-car stx))]
|
|
[({p ...} . more)
|
|
(let* ([heads
|
|
(for/list ([p (syntax->list #'(p ...))])
|
|
(parse-pattern p decls depth))]
|
|
[heads-attrs
|
|
(append-attrs (map pattern-attrs heads) (stx-car stx))])
|
|
(parse-heads-k #'more
|
|
heads
|
|
heads-attrs
|
|
depth
|
|
(lambda (more min max as-list? occurs-pvar default)
|
|
(let ([occurs-attrs
|
|
(if occurs-pvar
|
|
(list (make-attr occurs-pvar depth null))
|
|
null)])
|
|
(cons (make head (stx-car stx)
|
|
(append-attrs (list occurs-attrs heads-attrs)
|
|
(stx-car stx))
|
|
depth
|
|
heads
|
|
min max as-list?
|
|
occurs-pvar
|
|
default)
|
|
(parse-heads more decls depth))))))]
|
|
[()
|
|
null]
|
|
[_
|
|
(raise-syntax-error 'pattern "expected sequence of patterns or sequence directive"
|
|
(if (pair? stx) (car stx) stx))]))
|
|
|
|
(define (check-nat/f stx)
|
|
(let ([d (syntax-e stx)])
|
|
(unless (nat/f d)
|
|
(raise-syntax-error #f "expected exact nonnegative integer or #f" stx))
|
|
stx))
|
|
|
|
(define head-directive-table
|
|
(list (list '#:min check-nat/f)
|
|
(list '#:max check-nat/f)
|
|
(list '#:occurs check-id)
|
|
(list '#:default values)
|
|
(list '#:opt)
|
|
(list '#:mand)))
|
|
|
|
(define (parse-heads-k stx heads heads-attrs heads-depth k)
|
|
(define-values (chunks rest) (chunk-kw-seq stx head-directive-table))
|
|
(reject-duplicate-chunks chunks)
|
|
(let* ([min-row (assq '#:min chunks)]
|
|
[max-row (assq '#:max chunks)]
|
|
[occurs-row (assq '#:occurs chunks)]
|
|
[default-row (assq '#:default chunks)]
|
|
[opt-row (assq '#:opt chunks)]
|
|
[mand-row (assq '#:mand chunks)]
|
|
[min-stx (and min-row (caddr min-row))]
|
|
[max-stx (and max-row (caddr max-row))]
|
|
[min (if min-stx (syntax-e min-stx) #f)]
|
|
[max (if max-stx (syntax-e max-stx) #f)])
|
|
(unless (<= (or min 0) (or max +inf.0))
|
|
(raise-syntax-error #f
|
|
"min-constraint must be less than max-constraint"
|
|
(or min-stx max-stx)))
|
|
(when (and opt-row mand-row)
|
|
(raise-syntax-error #f
|
|
"opt and mand directives incompatible"
|
|
(cadr opt-row)))
|
|
(when (and (or min-row max-row) (or opt-row mand-row))
|
|
(raise-syntax-error #f
|
|
"min/max-constraints incompatible with opt/mand directives"
|
|
(or min-stx max-stx)))
|
|
(when default-row
|
|
(unless opt-row
|
|
(raise-syntax-error #f
|
|
"default only allowed for optional patterns"
|
|
(cadr default-row)))
|
|
(unless (and (pair? head-attrs)
|
|
(null? (cdr head-attrs))
|
|
(= heads-depth (attr-depth (car head-attrs)))
|
|
(null? (attr-inner (car head-attrs))))
|
|
(raise-syntax-error #f
|
|
"default only allowed for patterns with single simple pattern variable"
|
|
(cadr default-row))))
|
|
(k rest
|
|
(cond [opt-row 0] [mand-row 1] [else min])
|
|
(cond [opt-row 1] [mand-row 1] [else max])
|
|
(not (or opt-row mand-row))
|
|
(and occurs-row (caddr occurs-row))
|
|
(and default-row (caddr default-row)))))
|
|
|
|
;; nat/f : any -> boolean
|
|
(define (nat/f x)
|
|
(or (not x) (exact-nonnegative-integer? x)))
|
|
|
|
;; append-attrs : (listof (listof IAttr)) stx -> (listof IAttr)
|
|
(define (append-attrs attrss stx)
|
|
(let* ([all (apply append attrss)]
|
|
[names (map attr-name all)]
|
|
[dup (check-duplicate-identifier names)])
|
|
(when dup
|
|
(raise-syntax-error 'syntax-class "duplicate pattern variable" stx dup))
|
|
all))
|
|
|
|
;; parse-pattern-directives : stxs(PatternDirective) #:literals (listof id)
|
|
;; -> stx DeclEnv env (listof SideClause)
|
|
;; DeclEnv = bound-id-mapping[id => (cons SC (listof stx)) or #t]
|
|
;; if decls maps a name to #t, it indicates literal
|
|
(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 (check-in-sc stx)
|
|
(unless sc?
|
|
(raise-syntax-error 'pattern
|
|
"not within syntax-class definition"
|
|
(if (pair? stx) (car stx) stx))))
|
|
(define directive-table
|
|
(list (list '#:declare check-id values)
|
|
(list '#:rename check-id check-id)
|
|
(list '#:with values values)
|
|
(list '#:where values)))
|
|
(define-values (chunks rest) (chunk-kw-seq stx directive-table))
|
|
(define directives (map cdr chunks))
|
|
|
|
(define (for-decl stx)
|
|
(syntax-case stx ()
|
|
[[#:declare name sc]
|
|
(identifier? #'sc)
|
|
(for-decl #'[#:declare name (sc)])]
|
|
[[#:declare name (sc expr ...)]
|
|
(begin (let ([prev (bound-identifier-mapping-get decl-table #'name (lambda () #f))])
|
|
(when (pair? prev)
|
|
(raise-syntax-error 'pattern
|
|
"duplicate syntax-class declaration for name"
|
|
#'name))
|
|
(when prev
|
|
(raise-syntax-error 'pattern
|
|
"name already declared as literal"
|
|
#'name)))
|
|
(bound-identifier-mapping-put! decl-table #'name
|
|
(cons (get-stxclass #'sc)
|
|
(syntax->list #'(expr ...)))))]
|
|
[[#:declare . _]
|
|
(raise-syntax-error 'pattern "bad #:declare form" stx)]
|
|
[[#: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)))]
|
|
[[#:where expr]
|
|
(set! rclauses
|
|
(cons (make clause:where #'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-proper-list-pattern : Pattern -> void
|
|
(define (check-proper-list-pattern p)
|
|
(define (err stx)
|
|
(raise-syntax-error 'define-syntax-splice-pattern
|
|
"not a proper list pattern"
|
|
stx))
|
|
(match p
|
|
[(struct pat:id (orig-stx _ _ _ _ _))
|
|
(err orig-stx)]
|
|
[(struct pat:datum (orig-stx _ _ datum))
|
|
(unless (null? datum)
|
|
(err orig-stx))]
|
|
[(struct pat:pair (_ _ _ head tail))
|
|
(check-proper-list-pattern tail)]
|
|
[(struct pat:splice (_ _ _ head tail))
|
|
(check-proper-list-pattern tail)]
|
|
[(struct pat:gseq (_ _ _ heads tail))
|
|
(check-proper-list-pattern tail)]))
|
|
|
|
;; intersect-attrss : (listof (listof SAttr)) stx -> (listof SAttr)
|
|
(define (intersect-attrss attrss blamestx)
|
|
(cond [(null? attrss) null]
|
|
[else
|
|
(let* ([namess (map (lambda (attrs) (map attr-name attrs)) attrss)]
|
|
[names (filter (lambda (s)
|
|
(andmap (lambda (names) (memq s names))
|
|
(cdr namess)))
|
|
(car namess))]
|
|
[ht (make-hasheq)]
|
|
[put (lambda (attr) (hash-set! ht (attr-name attr) attr))]
|
|
[fetch-like (lambda (attr) (hash-ref ht (attr-name attr) #f))])
|
|
(for* ([attrs attrss]
|
|
[attr attrs]
|
|
#:when (memq (attr-name attr) names))
|
|
(put (join-attrs attr (fetch-like attr) blamestx)))
|
|
(sort (hash-map ht (lambda (k v) v))
|
|
(lambda (a b)
|
|
(string<? (symbol->string (attr-name a))
|
|
(symbol->string (attr-name b))))))]))
|
|
|
|
;; join-attrs : SAttr SAttr stx -> SAttr
|
|
(define (join-attrs a b blamestx)
|
|
(define (complain str . args)
|
|
(raise-syntax-error 'syntax-class (apply format str args) blamestx))
|
|
(if (not b)
|
|
a
|
|
(begin
|
|
(unless (equal? (attr-depth a) (attr-depth b))
|
|
(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)))))
|
|
|
|
;; reorder-iattrs : (listof SAttr) (listof IAttr) env -> (listof IAttr)
|
|
;; Reorders iattrs (and restricts) based on relsattrs
|
|
(define (reorder-iattrs relsattrs iattrs remap)
|
|
(let ([ht (make-hasheq)])
|
|
(for-each (lambda (iattr)
|
|
(let ([remap-name (remap (attr-name iattr))])
|
|
(hash-set! ht remap-name iattr)))
|
|
iattrs)
|
|
(let loop ([relsattrs relsattrs])
|
|
(match relsattrs
|
|
['() null]
|
|
[(cons (struct attr (name depth inner)) rest)
|
|
(let ([iattr (hash-ref ht name #f)])
|
|
(if iattr
|
|
(cons (make attr (attr-name iattr)
|
|
(attr-depth iattr)
|
|
(intersect-sattrs inner (attr-inner iattr)))
|
|
(loop rest))
|
|
(loop rest)))]))))
|
|
|
|
;; restrict-iattrs : (listof SAttr) (listof IAttr) env -> (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)])
|
|
(if (and sattr (= depth (attr-depth sattr)))
|
|
(cons (make attr name depth
|
|
(intersect-sattrs inner (attr-inner sattr)))
|
|
(restrict-iattrs relsattrs (cdr iattrs) remap))
|
|
(restrict-iattrs relsattrs (cdr iattrs) remap)))]))
|
|
|
|
;; flatten-sattrs : (listof SAttr) num symbol -> (listof SAttr)
|
|
(define (flatten-sattrs sattrs [depth-delta 0] [prefix #f])
|
|
(match sattrs
|
|
['()
|
|
null]
|
|
[(cons (struct attr (name depth nested)) rest)
|
|
(let ([prefixed-name
|
|
(if prefix
|
|
(format-symbol "~a.~a" prefix name)
|
|
name)])
|
|
(append (list (make attr prefixed-name
|
|
(+ depth-delta depth)
|
|
null))
|
|
(flatten-sattrs nested (+ depth depth-delta) prefixed-name)
|
|
(flatten-sattrs rest depth-delta prefix)))]))
|
|
|
|
;; intersect-sattrs : (listof SAttr) (listof SAttr) -> (listof SAttr)
|
|
;; Preserves order of first list of attrs.
|
|
(define (intersect-sattrs as bs)
|
|
(match as
|
|
['() null]
|
|
[(cons (struct attr (name depth inner)) rest)
|
|
(let ([b (lookup-sattr name bs)])
|
|
(if (and b (= depth (attr-depth b)))
|
|
(cons (make attr name depth (intersect-sattrs inner (attr-inner b)))
|
|
(intersect-sattrs (cdr as) bs))
|
|
(intersect-sattrs (cdr as) bs)))]))
|
|
|
|
;; flatten-attrs* : (listof attr) num symbol stx -> (listof attr)
|
|
(define (flatten-attrs* attrs [depth-delta 0] [prefix #f] [ctx #f])
|
|
(match attrs
|
|
['()
|
|
null]
|
|
[(cons (struct attr (name depth nested)) rest)
|
|
(let ([prefixed-name
|
|
(if prefix
|
|
(format-symbol "~a.~a" prefix name)
|
|
(syntax-e name))]
|
|
[ctx (or ctx name)])
|
|
(append (list (make attr (if ctx (datum->syntax ctx prefixed-name) name)
|
|
(+ depth-delta depth)
|
|
null))
|
|
(flatten-attrs* nested (+ depth depth-delta) prefixed-name ctx)
|
|
(flatten-attrs* rest depth-delta prefix ctx)))]))
|
|
|
|
(define (format-symbol fmt . args)
|
|
(string->symbol (apply format fmt args)))
|
|
|
|
(define (lookup-sattr name sattrs)
|
|
(cond [(null? sattrs) #f]
|
|
[(eq? name (attr-name (car sattrs))) (car sattrs)]
|
|
[else (lookup-sattr name (cdr sattrs))]))
|
|
|
|
(define (lookup-iattr name iattrs)
|
|
(cond [(null? iattrs) #f]
|
|
[(bound-identifier=? name (attr-name (car iattrs))) (car iattrs)]
|
|
[else (lookup-iattr name (cdr iattrs))]))
|