residual.rkt (10810B)
1 #lang racket/base 2 (require (for-syntax racket/base) 3 racket/stxparam 4 racket/lazy-require 5 racket/private/promise) 6 7 ;; ============================================================ 8 ;; Compile-time 9 10 (require (for-syntax racket/private/sc syntax/parse/private/residual-ct)) 11 (provide (for-syntax (all-from-out syntax/parse/private/residual-ct))) 12 13 (require racket/private/template) 14 (provide (for-syntax attribute-mapping attribute-mapping?)) 15 16 ;; ============================================================ 17 ;; Run-time 18 19 (require "runtime-progress.rkt" 20 "3d-stx.rkt" 21 auto-syntax-e 22 syntax/stx 23 stxparse-info/current-pvars) 24 25 (provide (all-from-out "runtime-progress.rkt") 26 27 this-syntax 28 this-role 29 this-context-syntax 30 attribute 31 attribute-binding 32 check-attr-value 33 stx-list-take 34 stx-list-drop/cx 35 datum->syntax/with-clause 36 check-literal* 37 error/null-eh-match 38 begin-for-syntax/once 39 40 name->too-few/once 41 name->too-few 42 name->too-many 43 normalize-context 44 syntax-patterns-fail) 45 46 ;; == from runtime.rkt 47 48 ;; this-syntax 49 ;; Bound to syntax being matched inside of syntax class 50 (define-syntax-parameter this-syntax 51 (lambda (stx) 52 (raise-syntax-error #f "used out of context: not within a syntax class" stx))) 53 54 (define-syntax-parameter this-role 55 (lambda (stx) 56 (raise-syntax-error #f "used out of context: not within a syntax class" stx))) 57 58 ;; this-context-syntax 59 ;; Bound to (expression that extracts) context syntax (bottom frame in progress) 60 (define-syntax-parameter this-context-syntax 61 (lambda (stx) 62 (raise-syntax-error #f "used out of context: not within a syntax class" stx))) 63 64 (define-syntax (attribute stx) 65 (syntax-case stx () 66 [(attribute name) 67 (identifier? #'name) 68 (let ([mapping (syntax-local-value #'name (lambda () #f))]) 69 (unless (syntax-pattern-variable? mapping) 70 (raise-syntax-error #f "not bound as a pattern variable" stx #'name)) 71 (let ([var (syntax-mapping-valvar mapping)]) 72 (let ([attr (syntax-local-value var (lambda () #f))]) 73 (unless (attribute-mapping? attr) 74 (raise-syntax-error #f "not bound as an attribute" stx #'name)) 75 (syntax-property (attribute-mapping-var attr) 76 'disappeared-use 77 (list (syntax-local-introduce #'name))))))])) 78 79 ;; (attribute-binding id) 80 ;; mostly for debugging/testing 81 (define-syntax (attribute-binding stx) 82 (syntax-case stx () 83 [(attribute-bound? name) 84 (identifier? #'name) 85 (let ([value (syntax-local-value #'name (lambda () #f))]) 86 (if (syntax-pattern-variable? value) 87 (let ([value (syntax-local-value (syntax-mapping-valvar value) (lambda () #f))]) 88 (if (attribute-mapping? value) 89 #`(quote #,(make-attr (attribute-mapping-name value) 90 (attribute-mapping-depth value) 91 (if (attribute-mapping-check value) #f #t))) 92 #'(quote #f))) 93 #'(quote #f)))])) 94 95 ;; stx-list-take : stxish nat -> syntax 96 (define (stx-list-take stx n) 97 (datum->syntax #f 98 (let loop ([stx stx] [n n]) 99 (if (zero? n) 100 null 101 (cons (stx-car stx) 102 (loop (stx-cdr stx) (sub1 n))))))) 103 104 ;; stx-list-drop/cx : stxish stx nat -> (values stxish stx) 105 (define (stx-list-drop/cx x cx n) 106 (let loop ([x x] [cx cx] [n n]) 107 (if (zero? n) 108 (values x 109 (if (syntax? x) x cx)) 110 (loop (stx-cdr x) 111 (if (syntax? x) x cx) 112 (sub1 n))))) 113 114 ;; check-attr-value : Any d:Nat b:Boolean Syntax/#f -> (Listof^d (if b Syntax Any)) 115 (define (check-attr-value v0 depth0 base? ctx) 116 (define (bad kind v) 117 (raise-syntax-error #f (format "attribute contains non-~s value\n value: ~e" kind v) ctx)) 118 (define (depthloop depth v) 119 (if (zero? depth) 120 (if base? (baseloop v) v) 121 (let listloop ([v v] [root? #t]) 122 (cond [(null? v) null] 123 [(pair? v) (let ([new-car (depthloop (sub1 depth) (car v))] 124 [new-cdr (listloop (cdr v) #f)]) 125 (cond [(and (eq? (car v) new-car) (eq? (cdr v) new-cdr)) v] 126 [else (cons new-car new-cdr)]))] 127 [(promise? v) (listloop (force v) root?)] 128 [(and root? (eq? v #f)) (begin (signal-absent-pvar) (bad 'list v))] 129 [else (bad 'list v)])))) 130 (define (baseloop v) 131 (cond [(syntax? v) v] 132 [(promise? v) (baseloop (force v))] 133 [(eq? v #f) (begin (signal-absent-pvar) (bad 'syntax v))] 134 [else (bad 'syntax v)])) 135 (depthloop depth0 v0)) 136 137 ;; datum->syntax/with-clause : any -> syntax 138 (define (datum->syntax/with-clause x) 139 (cond [(syntax? x) x] 140 [(2d-stx? x #:traverse-syntax? #f) 141 (datum->syntax #f x #f)] 142 [else 143 (error 'datum->syntax/with-clause 144 (string-append 145 "implicit conversion to 3D syntax\n" 146 " right-hand side of #:with clause or ~~parse pattern would be 3D syntax\n" 147 " value: ~e") 148 x)])) 149 150 ;; check-literal* : id phase phase (listof phase) stx -> void 151 (define (check-literal* id used-phase mod-phase ok-phases/ct-rel ctx) 152 (unless (or (memv (and used-phase (- used-phase mod-phase)) 153 ok-phases/ct-rel) 154 (identifier-binding id used-phase)) 155 (raise-syntax-error 156 #f 157 (format "literal is unbound in phase ~a (phase ~a relative to the enclosing module)" 158 used-phase 159 (and used-phase (- used-phase mod-phase))) 160 ctx id))) 161 162 ;; error/null-eh-match : -> (escapes) 163 (define (error/null-eh-match) 164 (error 'syntax-parse "an ellipsis-head pattern matched an empty sequence")) 165 166 ;; (begin-for-syntax/once expr/phase1 ...) 167 ;; evaluates in pass 2 of module/intdefs expansion 168 (define-syntax (begin-for-syntax/once stx) 169 (syntax-case stx () 170 [(bfs/o e ...) 171 (cond [(list? (syntax-local-context)) 172 #`(define-values () 173 (begin (begin-for-syntax/once e ...) 174 (values)))] 175 [else 176 #'(let-syntax ([m (lambda _ (begin e ...) #'(void))]) 177 (m))])])) 178 179 ;; == parse.rkt 180 181 (define (name->too-few/once name) 182 (and name (format "missing required occurrence of ~a" name))) 183 184 (define (name->too-few name) 185 (and name (format "too few occurrences of ~a" name))) 186 187 (define (name->too-many name) 188 (and name (format "too many occurrences of ~a" name))) 189 190 ;; == parse.rkt 191 192 ;; normalize-context : Symbol Any Syntax -> (list Symbol/#f Syntax) 193 (define (normalize-context who ctx stx) 194 (cond [(syntax? ctx) 195 (list #f ctx)] 196 [(symbol? ctx) 197 (list ctx stx)] 198 [(eq? ctx #f) 199 (list #f stx)] 200 [(and (list? ctx) 201 (= (length ctx) 2) 202 (or (symbol? (car ctx)) (eq? #f (car ctx))) 203 (syntax? (cadr ctx))) 204 ctx] 205 [else (error who "bad #:context argument\n expected: ~s\n given: ~e" 206 '(or/c syntax? symbol? #f (list/c (or/c symbol? #f) syntax?)) 207 ctx)])) 208 209 ;; == parse.rkt 210 211 (lazy-require 212 ["runtime-report.rkt" 213 (call-current-failure-handler)]) 214 215 ;; syntax-patterns-fail : (list Symbol/#f Syntax) -> (Listof (-> Any)) FailureSet -> escapes 216 (define ((syntax-patterns-fail ctx) undos fs) 217 (unwind-to undos null) 218 (call-current-failure-handler ctx fs)) 219 220 ;; == specialized ellipsis parser 221 ;; returns (values 'ok attr-values) or (values 'fail failure) 222 223 (provide predicate-ellipsis-parser) 224 225 (define (predicate-ellipsis-parser x cx pr es pred? desc rl) 226 (let ([elems (stx->list x)]) 227 (if (and elems (list? elems) (andmap pred? elems)) 228 (values 'ok elems) 229 (let loop ([x x] [cx cx] [i 0]) 230 (cond [(syntax? x) 231 (loop (syntax-e x) x i)] 232 [(pair? x) 233 (if (pred? (car x)) 234 (loop (cdr x) cx (add1 i)) 235 (let* ([pr (ps-add-cdr pr i)] 236 [pr (ps-add-car pr)] 237 [es (es-add-thing pr desc #t rl es)]) 238 (values 'fail (failure pr es))))] 239 [else ;; not null, because stx->list failed 240 (let ([pr (ps-add-cdr pr i)] 241 #| 242 ;; Don't extend es! That way we don't get spurious "expected ()" 243 ;; that *should* have been cancelled out by ineffable pair failures. 244 |#) 245 (values 'fail (failure pr es)))]))))) 246 247 (provide illegal-cut-error) 248 249 (define (illegal-cut-error . _) 250 (error 'syntax-parse "illegal use of cut")) 251 252 ;; ---- 253 254 (provide unwind-to 255 maybe-add-state-undo 256 current-state 257 current-state-writable? 258 state-cons! 259 track-literals) 260 261 (define (unwind-to undos base) 262 ;; PRE: undos = (list* proc/hash ... base) 263 (unless (eq? undos base) 264 (let ([top-undo (car undos)]) 265 (cond [(procedure? top-undo) (top-undo)] 266 [(hash? top-undo) (current-state top-undo)])) 267 (unwind-to (cdr undos) base))) 268 269 (define (maybe-add-state-undo init-state new-state undos) 270 (if (eq? init-state new-state) 271 undos 272 (cons init-state undos))) 273 274 ;; To make adding undos to rewind current-state simpler, only allow updates 275 ;; in a few contexts: 276 ;; - literals (handled automatically) 277 ;; - in ~do/#:do blocks (sets current-state-writable? = #t) 278 279 (define current-state (make-parameter (hasheq))) 280 (define current-state-writable? (make-parameter #f)) 281 282 (define (state-cons! key value) 283 (define state (current-state)) 284 (current-state (hash-set state key (cons value (hash-ref state key null))))) 285 286 (define (track-literals who v #:introduce? [introduce? #t]) 287 (unless (syntax? v) 288 (raise-argument-error who "syntax?" v)) 289 (let* ([literals (hash-ref (current-state) 'literals '())]) 290 (if (null? literals) 291 v 292 (let ([literals* (if (and introduce? (syntax-transforming?) (list? literals)) 293 (for/list ([literal (in-list literals)]) 294 (if (identifier? literal) 295 (syntax-local-introduce literal) 296 literal)) 297 literals)] 298 [old-val (syntax-property v 'disappeared-use)]) 299 (syntax-property v 'disappeared-use 300 (if old-val 301 (cons literals* old-val) 302 literals*))))))