1#lang racket/base 2(require syntax/parse/private/residual-ct ;; keep abs. path 3 racket/contract/base 4 syntax/private/id-table 5 racket/syntax 6 "make.rkt") 7 8#| 9An IAttr is (make-attr identifier number boolean) 10An SAttr is (make-attr symbol number boolean) 11 12The number is the ellipsis nesting depth. The boolean is true iff the 13attr is guaranteed to be bound to a value which is a syntax object (or 14a list^depth of syntax objects). 15|# 16 17#| 18SAttr lists are always stored in sorted order, to make comparison 19of signatures easier for reified syntax-classes. 20|# 21 22(define (iattr? a) 23 (and (attr? a) (identifier? (attr-name a)))) 24 25(define (sattr? a) 26 (and (attr? a) (symbol? (attr-name a)))) 27 28;; increase-depth : Attr -> Attr 29(define (increase-depth x) 30 (make attr (attr-name x) (add1 (attr-depth x)) (attr-syntax? x))) 31 32(provide/contract 33 [iattr? (any/c . -> . boolean?)] 34 [sattr? (any/c . -> . boolean?)] 35 36 [increase-depth 37 (-> attr? attr?)] 38 [attr-make-uncertain 39 (-> attr? attr?)] 40 41 ;; IAttr operations 42 [append-iattrs 43 (-> (listof (listof iattr?)) 44 (listof iattr?))] 45 [union-iattrs 46 (-> (listof (listof iattr?)) 47 (listof iattr?))] 48 [reorder-iattrs 49 (-> (listof sattr?) (listof iattr?) 50 (listof iattr?))] 51 52 ;; SAttr operations 53 [iattr->sattr 54 (-> iattr? 55 sattr?)] 56 [iattrs->sattrs 57 (-> (listof iattr?) 58 (listof sattr?))] 59 [sort-sattrs 60 (-> (listof sattr?) 61 (listof sattr?))] 62 63 [intersect-sattrss 64 (-> (listof (listof sattr?)) 65 (listof sattr?))] 66 67 [check-iattrs-subset 68 (-> (listof iattr?) 69 (listof iattr?) 70 (or/c syntax? false/c) 71 any)]) 72 73;; IAttr operations 74 75;; append-iattrs : (listof (listof IAttr)) -> (listof IAttr) 76;; Assumes that each sublist is duplicate-free. 77(define (append-iattrs attrss) 78 (cond [(null? attrss) null] 79 [(null? (cdr attrss)) (car attrss)] 80 [else 81 (let* ([all (apply append attrss)] 82 [names (map attr-name all)] 83 [dup (and (pair? names) (check-duplicate-identifier names))]) 84 (when dup (wrong-syntax dup "duplicate attribute")) 85 all)])) 86 87;; union-iattrs : (listof (listof IAttr)) -> (listof IAttr) 88(define (union-iattrs attrss) 89 (define count-t (make-bound-id-table)) 90 (define attr-t (make-bound-id-table)) 91 (define list-count (length attrss)) 92 (define attr-keys null) 93 (for* ([attrs (in-list attrss)] [attr (in-list attrs)]) 94 (define name (attr-name attr)) 95 (define prev (bound-id-table-ref attr-t name #f)) 96 (unless prev (set! attr-keys (cons name attr-keys))) 97 (bound-id-table-set! attr-t name (join-attrs attr prev)) 98 (let ([pc (bound-id-table-ref count-t name 0)]) 99 (bound-id-table-set! count-t name (add1 pc)))) 100 (for/list ([k (in-list attr-keys)]) 101 (define a (bound-id-table-ref attr-t k)) 102 (if (= (bound-id-table-ref count-t (attr-name a)) list-count) 103 a 104 (attr-make-uncertain a)))) 105 106;; join-attrs : Attr Attr/#f -> Attr 107;; Works with both IAttrs and SAttrs. 108;; Assumes attrs have same name. 109(define (join-attrs a b) 110 (if (and a b) 111 (proper-join-attrs a b) 112 (or a b))) 113 114(define (proper-join-attrs a b) 115 (let ([aname (attr-name a)]) 116 (unless (equal? (attr-depth a) (attr-depth b)) 117 (wrong-syntax (and (syntax? aname) aname) 118 "attribute '~a' occurs with different nesting depth" 119 (if (syntax? aname) (syntax-e aname) aname))) 120 (make attr aname (attr-depth a) (and (attr-syntax? a) (attr-syntax? b))))) 121 122(define (attr-make-uncertain a) 123 (make attr (attr-name a) (attr-depth a) #f)) 124 125(define (iattr->sattr a) 126 (let ([name (attr-name a)] 127 [depth (attr-depth a)] 128 [syntax? (attr-syntax? a)]) 129 (make attr (syntax-e name) depth syntax?))) 130 131(define (iattrs->sattrs as) 132 (sort-sattrs (map iattr->sattr as))) 133 134(define (sort-sattrs as) 135 (sort as string<? 136 #:key (lambda (a) (symbol->string (attr-name a))) 137 #:cache-keys? #t)) 138 139;; intersect-sattrss : (listof (listof SAttr)) -> (listof SAttr) 140;; FIXME: rely on sorted inputs, simplify algorithm and avoid second sort? 141(define (intersect-sattrss attrss) 142 (cond [(null? attrss) null] 143 [else 144 (let* ([namess (map (lambda (attrs) (map attr-name attrs)) attrss)] 145 [names (filter (lambda (s) 146 (andmap (lambda (names) (memq s names)) 147 (cdr namess))) 148 (car namess))] 149 [ht (make-hasheq)] 150 [put (lambda (attr) (hash-set! ht (attr-name attr) attr))] 151 [fetch-like (lambda (attr) (hash-ref ht (attr-name attr) #f))]) 152 (for* ([attrs (in-list attrss)] 153 [attr (in-list attrs)] 154 #:when (memq (attr-name attr) names)) 155 (put (join-attrs attr (fetch-like attr)))) 156 (sort-sattrs (hash-map ht (lambda (k v) v))))])) 157 158;; reorder-iattrs : (listof SAttr) (listof IAttr) -> (listof IAttr) 159;; Reorders iattrs (and restricts) based on relsattrs 160;; If a relsattr is not found, or if depth or contents mismatches, raises error. 161(define (reorder-iattrs relsattrs iattrs) 162 (let ([ht (make-hasheq)]) 163 (for ([iattr (in-list iattrs)]) 164 (let ([remap-name (syntax-e (attr-name iattr))]) 165 (hash-set! ht remap-name iattr))) 166 (let loop ([relsattrs relsattrs]) 167 (if (null? relsattrs) 168 null 169 (let ([sattr (car relsattrs)] 170 [rest (cdr relsattrs)]) 171 (let ([iattr (hash-ref ht (attr-name sattr) #f)]) 172 (check-iattr-satisfies-sattr iattr sattr) 173 (cons iattr (loop rest)))))))) 174 175(define (check-iattr-satisfies-sattr iattr sattr) 176 (unless iattr 177 (wrong-syntax #f "required attribute is not defined: ~s" (attr-name sattr))) 178 (unless (= (attr-depth iattr) (attr-depth sattr)) 179 (wrong-syntax (attr-name iattr) 180 "attribute has wrong depth (expected ~s, found ~s)" 181 (attr-depth sattr) (attr-depth iattr))) 182 (when (and (attr-syntax? sattr) (not (attr-syntax? iattr))) 183 (wrong-syntax (attr-name iattr) 184 "attribute may not be bound to syntax: ~s" 185 (attr-name sattr)))) 186 187;; check-iattrs-subset : (listof IAttr) (listof IAttr) stx -> void 188(define (check-iattrs-subset little big ctx) 189 (define big-t (make-bound-id-table)) 190 (for ([a (in-list big)]) 191 (bound-id-table-set! big-t (attr-name a) #t)) 192 (for ([a (in-list little)]) 193 (unless (bound-id-table-ref big-t (attr-name a) #f) 194 (raise-syntax-error #f 195 "attribute bound in defaults but not in pattern" 196 ctx 197 (attr-name a))))) 198