litconv.rkt (11541B)
1 #lang racket/base 2 (require (for-syntax racket/base 3 racket/lazy-require 4 "sc.rkt" 5 "lib.rkt" 6 syntax/parse/private/kws 7 racket/syntax) 8 syntax/parse/private/residual-ct ;; keep abs. path 9 stxparse-info/parse/private/residual) ;; keep abs. path 10 (begin-for-syntax 11 (lazy-require 12 [syntax/private/keyword (options-select-value parse-keyword-options)] 13 [stxparse-info/parse/private/rep ;; keep abs. path 14 (parse-kw-formals 15 check-conventions-rules 16 check-datum-literals-list 17 create-aux-def)])) 18 ;; FIXME: workaround for phase>0 bug in racket/runtime-path (and thus lazy-require) 19 ;; Without this, dependencies don't get collected. 20 (require racket/runtime-path racket/syntax (for-meta 2 '#%kernel)) 21 (define-runtime-module-path-index _unused_ 'stxparse-info/parse/private/rep) 22 23 (provide define-conventions 24 define-literal-set 25 literal-set->predicate 26 kernel-literals) 27 28 (define-syntax (define-conventions stx) 29 30 (define-syntax-class header 31 #:description "name or name with formal parameters" 32 #:commit 33 (pattern name:id 34 #:with formals #'() 35 #:attr arity (arity 0 0 null null)) 36 (pattern (name:id . formals) 37 #:attr arity (parse-kw-formals #'formals #:context stx))) 38 39 (syntax-parse stx 40 [(define-conventions h:header rule ...) 41 (let () 42 (define rules (check-conventions-rules #'(rule ...) stx)) 43 (define rxs (map car rules)) 44 (define dens0 (map cadr rules)) 45 (define den+defs-list 46 (for/list ([den0 (in-list dens0)]) 47 (let-values ([(den defs) (create-aux-def den0)]) 48 (cons den defs)))) 49 (define dens (map car den+defs-list)) 50 (define defs (apply append (map cdr den+defs-list))) 51 52 (define/with-syntax (rx ...) rxs) 53 (define/with-syntax (def ...) defs) 54 (define/with-syntax (parser ...) 55 (map den:delayed-parser dens)) 56 (define/with-syntax (class-name ...) 57 (map den:delayed-class dens)) 58 59 ;; FIXME: could move make-den:delayed to user of conventions 60 ;; and eliminate from residual.rkt 61 #'(begin 62 (define-syntax h.name 63 (make-conventions 64 (quote-syntax get-parsers) 65 (lambda () 66 (let ([class-names (list (quote-syntax class-name) ...)]) 67 (map list 68 (list 'rx ...) 69 (map make-den:delayed 70 (generate-temporaries class-names) 71 class-names)))))) 72 (define get-parsers 73 (lambda formals 74 def ... 75 (list parser ...)))))])) 76 77 (define-for-syntax (check-phase-level stx ctx) 78 (unless (or (exact-integer? (syntax-e stx)) 79 (eq? #f (syntax-e stx))) 80 (raise-syntax-error #f "expected phase-level (exact integer or #f)" ctx stx)) 81 stx) 82 83 ;; check-litset-list : stx stx -> (listof (cons id literalset)) 84 (define-for-syntax (check-litset-list stx ctx) 85 (syntax-case stx () 86 [(litset-id ...) 87 (for/list ([litset-id (syntax->list #'(litset-id ...))]) 88 (let* ([val (and (identifier? litset-id) 89 (syntax-local-value/record litset-id literalset?))]) 90 (if val 91 (cons litset-id val) 92 (raise-syntax-error #f "expected literal set name" ctx litset-id))))] 93 [_ (raise-syntax-error #f "expected list of literal set names" ctx stx)])) 94 95 ;; check-literal-entry/litset : stx stx -> (list id id) 96 (define-for-syntax (check-literal-entry/litset stx ctx) 97 (syntax-case stx () 98 [(internal external) 99 (and (identifier? #'internal) (identifier? #'external)) 100 (list #'internal #'external)] 101 [id 102 (identifier? #'id) 103 (list #'id #'id)] 104 [_ (raise-syntax-error #f "expected literal entry" ctx stx)])) 105 106 (define-for-syntax (check-duplicate-literals ctx imports lits datum-lits) 107 (let ([lit-t (make-hasheq)]) ;; sym => #t 108 (define (check+enter! key blame-stx) 109 (when (hash-ref lit-t key #f) 110 (raise-syntax-error #f (format "duplicate literal: ~a" key) ctx blame-stx)) 111 (hash-set! lit-t key #t)) 112 (for ([id+litset (in-list imports)]) 113 (let ([litset-id (car id+litset)] 114 [litset (cdr id+litset)]) 115 (for ([entry (in-list (literalset-literals litset))]) 116 (cond [(lse:lit? entry) 117 (check+enter! (lse:lit-internal entry) litset-id)] 118 [(lse:datum-lit? entry) 119 (check+enter! (lse:datum-lit-internal entry) litset-id)])))) 120 (for ([datum-lit (in-list datum-lits)]) 121 (let ([internal (den:datum-lit-internal datum-lit)]) 122 (check+enter! (syntax-e internal) internal))) 123 (for ([lit (in-list lits)]) 124 (check+enter! (syntax-e (car lit)) (car lit))))) 125 126 (define-syntax (define-literal-set stx) 127 (syntax-case stx () 128 [(define-literal-set name . rest) 129 (let-values ([(chunks rest) 130 (parse-keyword-options 131 #'rest 132 `((#:literal-sets ,check-litset-list) 133 (#:datum-literals ,check-datum-literals-list) 134 (#:phase ,check-phase-level) 135 (#:for-template) 136 (#:for-syntax) 137 (#:for-label)) 138 #:incompatible '((#:phase #:for-template #:for-syntax #:for-label)) 139 #:context stx 140 #:no-duplicates? #t)]) 141 (unless (identifier? #'name) 142 (raise-syntax-error #f "expected identifier" stx #'name)) 143 (let ([relphase 144 (cond [(assq '#:for-template chunks) -1] 145 [(assq '#:for-syntax chunks) 1] 146 [(assq '#:for-label chunks) #f] 147 [else (options-select-value chunks '#:phase #:default 0)])] 148 [datum-lits 149 (options-select-value chunks '#:datum-literals #:default null)] 150 [lits (syntax-case rest () 151 [( (lit ...) ) 152 (for/list ([lit (in-list (syntax->list #'(lit ...)))]) 153 (check-literal-entry/litset lit stx))] 154 [_ (raise-syntax-error #f "bad syntax" stx)])] 155 [imports (options-select-value chunks '#:literal-sets #:default null)]) 156 (check-duplicate-literals stx imports lits datum-lits) 157 (with-syntax ([((internal external) ...) lits] 158 [(datum-internal ...) (map den:datum-lit-internal datum-lits)] 159 [(datum-external ...) (map den:datum-lit-external datum-lits)] 160 [(litset-id ...) (map car imports)] 161 [relphase relphase]) 162 #`(begin 163 (define phase-of-literals 164 (and 'relphase 165 (+ (variable-reference->module-base-phase (#%variable-reference)) 166 'relphase))) 167 (define-syntax name 168 (make-literalset 169 (append (literalset-literals (syntax-local-value (quote-syntax litset-id))) 170 ... 171 (list (make-lse:lit 'internal 172 (quote-syntax external) 173 (quote-syntax phase-of-literals)) 174 ... 175 (make-lse:datum-lit 'datum-internal 176 'datum-external) 177 ...)))) 178 (begin-for-syntax/once 179 (for ([x (in-list (syntax->list #'(external ...)))]) 180 (unless (identifier-binding x 'relphase) 181 (raise-syntax-error #f 182 (format "literal is unbound in phase ~a~a~a" 183 'relphase 184 (case 'relphase 185 ((1) " (for-syntax)") 186 ((-1) " (for-template)") 187 ((#f) " (for-label)") 188 (else "")) 189 " relative to the enclosing module") 190 (quote-syntax #,stx) x))))))))])) 191 192 #| 193 NOTES ON PHASES AND BINDINGS 194 195 (module M .... 196 .... (define-literal-set LS #:phase PL ....) 197 ....) 198 199 For the expansion of the define-literal-set form, the bindings of the literals 200 can be accessed by (identifier-binding lit PL), because the phase of the enclosing 201 module (M) is 0. 202 203 LS may be used, however, in a context where the phase of the enclosing 204 module is not 0, so each instantiation of LS needs to calculate the 205 phase of M and add that to PL. 206 207 -- 208 209 Normally, literal sets that define the same name conflict. But it 210 would be nice to allow them to both be imported in the case where they 211 refer to the same binding. 212 213 Problem: Can't do the check eagerly, because the binding of L may 214 change between when define-literal-set is compiled and the comparison 215 involving L. For example: 216 217 (module M racket 218 (require stxparse-info/parse) 219 (define-literal-set LS (lambda)) 220 (require (only-in some-other-lang lambda)) 221 .... LS ....) 222 223 The expansion of the LS definition sees a different lambda than the 224 one that the literal in LS actually refers to. 225 226 Similarly, a literal in LS might not be defined when the expander 227 runs, but might get defined later. (Although I think that will already 228 cause an error, so don't worry about that case.) 229 |# 230 231 ;; FIXME: keep one copy of each identifier (?) 232 233 (define-syntax (literal-set->predicate stx) 234 (syntax-case stx () 235 [(literal-set->predicate litset-id) 236 (let ([val (and (identifier? #'litset-id) 237 (syntax-local-value/record #'litset-id literalset?))]) 238 (unless val (raise-syntax-error #f "expected literal set name" stx #'litset-id)) 239 (let ([lits (literalset-literals val)]) 240 (with-syntax ([((lit phase-var) ...) 241 (for/list ([lit (in-list lits)] 242 #:when (lse:lit? lit)) 243 (list (lse:lit-external lit) (lse:lit-phase lit)))] 244 [(datum-lit ...) 245 (for/list ([lit (in-list lits)] 246 #:when (lse:datum-lit? lit)) 247 (lse:datum-lit-external lit))]) 248 #'(make-literal-set-predicate (list (list (quote-syntax lit) phase-var) ...) 249 '(datum-lit ...)))))])) 250 251 (define (make-literal-set-predicate lits datum-lits) 252 (lambda (x [phase (syntax-local-phase-level)]) 253 (or (for/or ([lit (in-list lits)]) 254 (let ([lit-id (car lit)] 255 [lit-phase (cadr lit)]) 256 (free-identifier=? x lit-id phase lit-phase))) 257 (and (memq (syntax-e x) datum-lits) #t)))) 258 259 ;; Literal sets 260 261 (define-literal-set kernel-literals 262 (begin 263 begin0 264 define-values 265 define-syntaxes 266 define-values-for-syntax ;; kept for compat. 267 begin-for-syntax 268 set! 269 let-values 270 letrec-values 271 #%plain-lambda 272 case-lambda 273 if 274 quote 275 quote-syntax 276 letrec-syntaxes+values 277 with-continuation-mark 278 #%expression 279 #%plain-app 280 #%top 281 #%datum 282 #%variable-reference 283 module module* #%provide #%require #%declare 284 #%plain-module-begin))