diff --git a/collects/stxclass/private/parse.ss b/collects/stxclass/private/codegen.ss similarity index 99% rename from collects/stxclass/private/parse.ss rename to collects/stxclass/private/codegen.ss index df68a76a6d..4181e78d0a 100644 --- a/collects/stxclass/private/parse.ss +++ b/collects/stxclass/private/codegen.ss @@ -9,6 +9,7 @@ scheme/private/sc syntax/stx syntax/boundmap + "rep-data.ss" "rep.ss" "codegen-data.ss" "../util.ss") diff --git a/collects/stxclass/private/messages.ss b/collects/stxclass/private/messages.ss index efc9c765ac..3f34db32b1 100644 --- a/collects/stxclass/private/messages.ss +++ b/collects/stxclass/private/messages.ss @@ -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) diff --git a/collects/stxclass/private/rep-data.ss b/collects/stxclass/private/rep-data.ss new file mode 100644 index 0000000000..e4b7825f16 --- /dev/null +++ b/collects/stxclass/private/rep-data.ss @@ -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 (listof RHS)) +;; (make-rhs:basic 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 identifier SC/#f (listof stx)) +;; (make-pat:datum datum) +;; (make-pat:pair Pattern Pattern) +;; (make-pat:seq Pattern Pattern) +;; (make-pat:gseq (listof Head) Pattern) +;; when = 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 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) + (stringstring (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))])) + + diff --git a/collects/stxclass/private/rep.ss b/collects/stxclass/private/rep.ss index 6a4617a146..466bd97747 100644 --- a/collects/stxclass/private/rep.ss +++ b/collects/stxclass/private/rep.ss @@ -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 (listof RHS)) -;; (make-rhs:basic 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 identifier SC/#f (listof stx)) -;; (make-pat:datum datum) -;; (make-pat:pair Pattern Pattern) -;; (make-pat:seq Pattern Pattern) -;; (make-pat:gseq (listof Head) Pattern) -;; when = 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 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) - (stringstring (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))])) diff --git a/collects/stxclass/private/sc.ss b/collects/stxclass/private/sc.ss index 2409ced275..0028dcd958 100644 --- a/collects/stxclass/private/sc.ss +++ b/collects/stxclass/private/sc.ss @@ -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 diff --git a/collects/stxclass/util/misc.ss b/collects/stxclass/util/misc.ss index 55dfd4d4aa..3e1341e5a0 100644 --- a/collects/stxclass/util/misc.ss +++ b/collects/stxclass/util/misc.ss @@ -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