1#lang racket/base 2(require racket/contract/base 3 racket/dict 4 syntax/private/id-table 5 racket/syntax 6 syntax/parse/private/residual-ct ;; keep abs. path 7 "minimatch.rkt" 8 "kws.rkt") 9;; from residual.rkt 10(provide (struct-out stxclass) 11 (struct-out conventions) 12 (struct-out literalset) 13 (struct-out eh-alternative-set) 14 (struct-out eh-alternative)) 15;; from here 16(provide stxclass/s? 17 stxclass/h? 18 (struct-out rhs) 19 (struct-out variant)) 20 21(define (stxclass/s? x) 22 (and (stxclass? x) (not (stxclass-splicing? x)))) 23(define (stxclass/h? x) 24 (and (stxclass? x) (stxclass-splicing? x))) 25 26;; An RHS is #s(rhs SAttrs Bool Stx/#f Variants Stxs Bool Bool) 27(define-struct rhs 28 (attrs ;; (Listof Sattr) 29 transparent? ;; Bool 30 description ;; Syntax/#f 31 variants ;; (Listof Variant) 32 definitions ;; (Listof Stx), aux definitions from txlifts, local conventions?, etc 33 commit? ;; Bool 34 delimit-cut? ;; Bool 35 ) #:prefab) 36 37;; A Variant is (variant Stx SAttrs Pattern Stxs) 38(define-struct variant 39 (ostx ;; Stx 40 attrs ;; (Listof SAttr) 41 pattern ;; Pattern 42 definitions ;; (Listof Stx) 43 ) #:prefab) 44 45;; Environments 46 47#| 48DeclEnv = 49 (make-declenv immutable-bound-id-mapping[id => DeclEntry] 50 (listof ConventionRule)) 51 52DeclEntry = 53- (den:lit Id Id Stx Stx) 54- (den:datum-lit Id Symbol) 55- (den:class Id Id Arguments) 56- (den:magic-class Id Id Arguments Stx) 57- (den:delayed Id Id) 58 59Arguments is defined in rep-patterns.rkt 60 61A DeclEnv is built up in stages: 62 1) syntax-parse (or define-syntax-class) directives 63 #:literals -> den:lit 64 #:datum-literals -> den:datum-lit 65 #:local-conventions -> den:class 66 #:conventions -> den:delayed 67 #:literal-sets -> den:lit 68 2) pattern directives 69 #:declare -> den:magic-class 70 3) create-aux-def creates aux parser defs 71 den:class -> den:delayed 72 73== Scoping == 74 75A #:declare directive results in a den:magic-class entry, which 76indicates that the pattern variable's syntax class arguments (if any) 77have "magical scoping": they are evaluated in the scope where the 78pattern variable occurs. If the variable occurs multiple times, the 79expressions are duplicated, and may be evaluated in different scopes. 80|# 81 82(define-struct declenv (table conventions)) 83 84(define-struct den:class (name class argu)) 85(define-struct den:magic-class (name class argu role)) 86;; and from residual.rkt: 87;; (define-struct den:lit (internal external input-phase lit-phase)) 88;; (define-struct den:datum-lit (internal external)) 89;; (define-struct den:delayed (parser class)) 90 91(define (new-declenv literals #:conventions [conventions null]) 92 (let* ([table (make-immutable-bound-id-table)] 93 [table (for/fold ([table table]) ([literal (in-list literals)]) 94 (let ([id (cond [(den:lit? literal) (den:lit-internal literal)] 95 [(den:datum-lit? literal) (den:datum-lit-internal literal)])]) 96 ;;(eprintf ">> added ~e\n" id) 97 (bound-id-table-set table id literal)))]) 98 (make-declenv table conventions))) 99 100(define (declenv-lookup env id) 101 (bound-id-table-ref (declenv-table env) id #f)) 102 103(define (declenv-apply-conventions env id) 104 (conventions-lookup (declenv-conventions env) id)) 105 106(define (declenv-check-unbound env id [stxclass-name #f] 107 #:blame-declare? [blame-declare? #f]) 108 ;; Order goes: literals, pattern, declares 109 ;; So blame-declare? only applies to stxclass declares 110 (let ([val (declenv-lookup env id)]) 111 (match val 112 [(den:lit _i _e _ip _lp) 113 (wrong-syntax id "identifier previously declared as literal")] 114 [(den:datum-lit _i _e) 115 (wrong-syntax id "identifier previously declared as literal")] 116 [(den:magic-class name _c _a _r) 117 (if (and blame-declare? stxclass-name) 118 (wrong-syntax name 119 "identifier previously declared with syntax class ~a" 120 stxclass-name) 121 (wrong-syntax (if blame-declare? name id) 122 "identifier previously declared"))] 123 [(den:class name _c _a) 124 (if (and blame-declare? stxclass-name) 125 (wrong-syntax name 126 "identifier previously declared with syntax class ~a" 127 stxclass-name) 128 (wrong-syntax (if blame-declare? name id) 129 "identifier previously declared"))] 130 ['#f (void)]))) 131 132(define (declenv-put-stxclass env id stxclass-name argu [role #f]) 133 (declenv-check-unbound env id) 134 (make-declenv 135 (bound-id-table-set (declenv-table env) id 136 (den:magic-class id stxclass-name argu role)) 137 (declenv-conventions env))) 138 139;; declenv-update/fold : DeclEnv (Id/Regexp DeclEntry a -> DeclEntry a) a 140;; -> (values DeclEnv a) 141(define (declenv-update/fold env0 f acc0) 142 (define-values (acc1 rules1) 143 (for/fold ([acc acc0] [newrules null]) 144 ([rule (in-list (declenv-conventions env0))]) 145 (let-values ([(val acc) (f (car rule) (cadr rule) acc)]) 146 (values acc (cons (list (car rule) val) newrules))))) 147 (define-values (acc2 table2) 148 (for/fold ([acc acc1] [table (make-immutable-bound-id-table)]) 149 ([(k v) (in-dict (declenv-table env0))]) 150 (let-values ([(val acc) (f k v acc)]) 151 (values acc (bound-id-table-set table k val))))) 152 (values (make-declenv table2 (reverse rules1)) 153 acc2)) 154 155;; returns ids in domain of env but not in given list 156(define (declenv-domain-difference env ids) 157 (define idbm (make-bound-id-table)) 158 (for ([id (in-list ids)]) (bound-id-table-set! idbm id #t)) 159 (for/list ([(k v) (in-dict (declenv-table env))] 160 #:when (or (den:class? v) (den:magic-class? v)) 161 #:unless (bound-id-table-ref idbm k #f)) 162 k)) 163 164;; Conventions = (listof (list regexp DeclEntry)) 165 166(define (conventions-lookup conventions id) 167 (let ([sym (symbol->string (syntax-e id))]) 168 (for/or ([c (in-list conventions)]) 169 (and (regexp-match? (car c) sym) (cadr c))))) 170 171;; Contracts 172 173(define DeclEnv/c declenv?) 174 175(define DeclEntry/c 176 (or/c den:lit? den:datum-lit? den:class? den:magic-class? den:delayed?)) 177 178(provide (struct-out den:class) 179 (struct-out den:magic-class) 180 ;; from residual.rkt: 181 (struct-out den:lit) 182 (struct-out den:datum-lit) 183 (struct-out den:delayed)) 184 185(provide/contract 186 [DeclEnv/c contract?] 187 [DeclEntry/c contract?] 188 189 [new-declenv 190 (->* [(listof (or/c den:lit? den:datum-lit?))] 191 [#:conventions list?] 192 DeclEnv/c)] 193 [declenv-lookup 194 (-> DeclEnv/c identifier? any)] 195 [declenv-apply-conventions 196 (-> DeclEnv/c identifier? any)] 197 [declenv-put-stxclass 198 (-> DeclEnv/c identifier? identifier? arguments? (or/c syntax? #f) 199 DeclEnv/c)] 200 [declenv-domain-difference 201 (-> DeclEnv/c (listof identifier?) 202 (listof identifier?))] 203 [declenv-update/fold 204 (-> DeclEnv/c 205 (-> (or/c identifier? regexp?) DeclEntry/c any/c (values DeclEntry/c any/c)) 206 any/c 207 (values DeclEnv/c any/c))] 208 [declenv-check-unbound 209 (->* [DeclEnv/c identifier?] [symbol? #:blame-declare? boolean?] any)] 210 211 [get-stxclass 212 (->* [identifier?] [boolean?] (or/c stxclass? #f))] 213 [check-stxclass-arity 214 (-> stxclass? syntax? exact-nonnegative-integer? (listof keyword?) any)] 215 [get-stxclass/check-arity 216 (-> identifier? syntax? exact-nonnegative-integer? (listof keyword?) 217 stxclass?)]) 218 219;; get-stxclass : Identifier [Boolean] -> stxclass/#f 220;; Stxclasses are primarily bound by env / syntax-local-value, but a few 221;; are attached to existing bindings via alt-stxclass-mapping. 222(define (get-stxclass id [allow-undef? #f]) 223 (let loop ([id id] 224 [prev-ids '()]) 225 (cond [(syntax-local-value/record id stxclass?) => values] 226 [(syntax-local-value/record id has-stxclass-prop?) 227 => (lambda (val) 228 (define prop-val (stxclass-prop-ref val)) 229 (define prop-id (if (identifier? prop-val) prop-val (prop-val val))) 230 (loop prop-id (cons id prev-ids)))] 231 [(assoc id (unbox alt-stxclass-mapping) free-identifier=?) => cdr] 232 [allow-undef? #f] 233 [else (wrong-syntax id #:extra prev-ids "not defined as syntax class")]))) 234 235;; check-stxclass-arity : stxclass Syntax Nat (Listof Keyword) -> Void 236(define (check-stxclass-arity sc stx pos-count keywords) 237 (check-arity (stxclass-arity sc) pos-count keywords 238 (lambda (msg) (raise-syntax-error #f msg stx)))) 239 240(define (get-stxclass/check-arity id stx pos-count keywords) 241 (define sc (get-stxclass id)) 242 (check-stxclass-arity sc stx pos-count keywords) 243 sc) 244 245;; ---- 246 247(provide get-eh-alternative-set) 248 249(define (get-eh-alternative-set id) 250 (let ([v (syntax-local-value id (lambda () #f))]) 251 (unless (eh-alternative-set? v) 252 (wrong-syntax id "not defined as an eh-alternative-set")) 253 v)) 254