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

stxclass: split and renamed modules

Browse Source 
svn: r13369
This commit is contained in:
Ryan Culpepper 2009-02-02 22:25:53 +00:00
parent 7d956d4864
commit ebd77ba75b
6 changed files with 344 additions and 324 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

1
collects/stxclass/private/parse.ss → collects/stxclass/private/codegen.ss
View File

@ -9,6 +9,7 @@
scheme/private/sc
syntax/stx
syntax/boundmap
"rep-data.ss"
"rep.ss"
"codegen-data.ss"
"../util.ss")

2
collects/stxclass/private/messages.ss
View File

@ -1,5 +1,5 @@
#lang scheme/base
(require (for-syntax scheme/base "rep.ss")
(require (for-syntax scheme/base "rep-data.ss")
scheme/match)
(provide (for-syntax expectation-of-stxclass
expectation-of-constants)

328
collects/stxclass/private/rep-data.ss Normal file
View File

@ -0,0 +1,328 @@
#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:basic)
(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:when)
(struct-out clause:with))
;; An SC is one of (make-sc symbol (listof symbol) (list-of SAttr) identifier)
(define-struct sc (name inputs attrs parser-name description)
#: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)
;; RHSBase is stx (listof SAttr) boolean stx/#f
(define-struct rhs (orig-stx attrs transparent? description)
#:transparent)
;; A RHS is one of
;; (make-rhs:union <RHSBase> (listof RHS))
;; (make-rhs:basic <RHSBase> stx)
(define-struct (rhs:union rhs) (patterns)
#:transparent)
(define-struct (rhs:basic rhs) (parser)
#:transparent)
;; An RHSPattern is
;; (make-rhs:pattern stx (listof SAttr) Pattern Env Env (listof SideClause))
(define-struct rhs:pattern (stx attrs pattern decls remap whens)
#: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)
;; when <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:when stx)
(define-struct clause:with (pattern expr) #:transparent)
(define-struct clause:when (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 #f))
(define (iattr? a)
(and (attr? a) (identifier? (attr-name a))))
(define (sattr? a)
(and (attr? a) (symbol? (attr-name a))))
(provide/contract
[make-empty-sc (-> identifier? sc?)]
[allow-unbound-stxclasses (parameter/c boolean?)]
[iattr? (any/c . -> . boolean?)]
[sattr? (any/c . -> . boolean?)]
[iattr->sattr (iattr? . -> . sattr?)]
[rename-attr (attr? symbol? . -> . sattr?)]
[iattrs->sattrs ((listof iattr?) (identifier? . -> . symbol?) . -> . (listof sattr?))]
[sattr->iattr/id (sattr? identifier? . -> . iattr?)]
[get-stxclass (-> identifier? any)]
[split-id/get-stxclass (-> identifier? any/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?))]
[restrict-iattrs
((listof sattr?) (listof iattr?) (identifier? . -> . symbol?) . -> . (listof iattr?))]
[flatten-sattrs
([(listof sattr?)] [exact-integer? (or/c symbol? false/c)] . ->* . (listof sattr?))]
[intersect-sattrs ((listof sattr?) (listof sattr?) . -> . (listof sattr?))]
[flatten-attrs* any/c]
[append-attrs ((listof (listof iattr?)) syntax? . -> . (listof iattr?))]
[lookup-sattr (symbol? (listof sattr?) . -> . (or/c sattr? false/c))]
[lookup-iattr (identifier? (listof iattr?) . -> . (or/c iattr? false/c))]
)
(define allow-unbound-stxclasses (make-parameter #f))
(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)
(define (no-good)
(if (allow-unbound-stxclasses)
(make-empty-sc id)
(wrong-syntax id "not defined as syntax class")))
(let ([sc (syntax-local-value id no-good)])
(unless (or (sc? sc) (ssc? sc))
(no-good))
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)])
(values id sc null (ssc? sc))))]
[(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 (ssc? stxclass)))]
[else (values id0 #f null #f)]))
;; 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)
(apply wrong-syntax blamestx str args))
(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)))]))
;; 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))
(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))]))

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

@ -5,195 +5,14 @@
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:basic)
(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:when)
(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 description)
#: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)
;; RHSBase is stx (listof SAttr) boolean stx/#f
(define-struct rhs (orig-stx attrs transparent? description)
#:transparent)
;; A RHS is one of
;; (make-rhs:union <RHSBase> (listof RHS))
;; (make-rhs:basic <RHSBase> stx)
(define-struct (rhs:union rhs) (patterns)
#:transparent)
(define-struct (rhs:basic rhs) (parser)
#:transparent)
;; An RHSPattern is
;; (make-rhs:pattern stx (listof SAttr) Pattern Env Env (listof SideClause))
(define-struct rhs:pattern (stx attrs pattern decls remap whens)
#: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)
;; when <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:when stx)
(define-struct clause:with (pattern expr) #:transparent)
(define-struct clause:when (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 #f))
(define (iattr? a)
(and (attr? a) (identifier? (attr-name a))))
(define (sattr? a)
(and (attr? a) (symbol? (attr-name a))))
"../util.ss"
"rep-data.ss")
(provide parse-pattern
parse-pattern-directives)
(provide/contract
[iattr? (any/c . -> . boolean?)]
[sattr? (any/c . -> . boolean?)]
[reorder-iattrs
((listof sattr?) (listof iattr?) (identifier? . -> . symbol?) . -> . (listof iattr?))]
[parse-rhs (syntax? boolean? syntax? . -> . rhs?)]
[parse-splice-rhs (syntax? boolean? syntax? . -> . rhs?)]
[flatten-sattrs
([(listof sattr?)] [exact-integer? (or/c symbol? false/c)] . ->* . (listof sattr?))]
[parse-splice-rhs (syntax? boolean? syntax? . -> . rhs?)])
#|
[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)
(define (no-good)
(if (allow-unbound-stxclasses)
(make-empty-sc id)
(wrong-syntax id "not defined as syntax class")))
(let ([sc (syntax-local-value id no-good)])
(unless (or (sc? sc) (ssc? sc))
(no-good))
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)])
(values id sc null (ssc? sc))))]
[(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 (ssc? stxclass)))]
[else (values id0 #f null #f)]))
(define (atomic-datum? stx)
(let ([datum (syntax-e stx)])
@ -221,8 +40,6 @@
;; ---
(define allow-unbound-stxclasses (make-parameter #f))
;; parse-rhs : stx(SyntaxClassRHS) boolean stx -> 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.
@ -463,15 +280,6 @@
occurs-pvar
(and default-row (caddr default-row))))))
;; 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 => (list* id id (listof stx)) or #t]
@ -565,128 +373,3 @@
(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)
(apply wrong-syntax blamestx str args))
(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))]))

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

@ -3,8 +3,9 @@
(require (for-syntax scheme/base
scheme/match
scheme/private/sc
"rep-data.ss"
"rep.ss"
"parse.ss"
"codegen.ss"
"../util.ss")
scheme/match
syntax/stx

7
collects/stxclass/util/misc.ss
View File

@ -10,6 +10,8 @@
generate-temporary
generate-n-temporaries
format-symbol
chunk-kw-seq/no-dups
chunk-kw-seq
reject-duplicate-chunks
@ -41,6 +43,11 @@
(for/list ([i (in-range n)])
(string->symbol (format "g~sx" i)))))
;; Symbol Formatting
(define (format-symbol fmt . args)
(let ([args (for/list ([arg args]) (if (syntax? arg) (syntax->datum arg) arg))])
(string->symbol (apply format fmt args))))
;; Parsing keyword arguments