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