residual.rkt (10824B)
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 "../../case/template.rkt") 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 stx? 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 (baseloop 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 [(promise? v) (baseloop (force v))] 132 [(not stx?) v] 133 [(syntax? v) v] 134 [(eq? v #f) (begin (signal-absent-pvar) (bad 'syntax v))] 135 [else (bad 'syntax v)])) 136 (depthloop depth0 v0)) 137 138 ;; datum->syntax/with-clause : any -> syntax 139 (define (datum->syntax/with-clause x) 140 (cond [(syntax? x) x] 141 [(2d-stx? x #:traverse-syntax? #f) 142 (datum->syntax #f x #f)] 143 [else 144 (error 'datum->syntax/with-clause 145 (string-append 146 "implicit conversion to 3D syntax\n" 147 " right-hand side of #:with clause or ~~parse pattern would be 3D syntax\n" 148 " value: ~e") 149 x)])) 150 151 ;; check-literal* : id phase phase (listof phase) stx -> void 152 (define (check-literal* id used-phase mod-phase ok-phases/ct-rel ctx) 153 (unless (or (memv (and used-phase (- used-phase mod-phase)) 154 ok-phases/ct-rel) 155 (identifier-binding id used-phase)) 156 (raise-syntax-error 157 #f 158 (format "literal is unbound in phase ~a (phase ~a relative to the enclosing module)" 159 used-phase 160 (and used-phase (- used-phase mod-phase))) 161 ctx id))) 162 163 ;; error/null-eh-match : -> (escapes) 164 (define (error/null-eh-match) 165 (error 'syntax-parse "an ellipsis-head pattern matched an empty sequence")) 166 167 ;; (begin-for-syntax/once expr/phase1 ...) 168 ;; evaluates in pass 2 of module/intdefs expansion 169 (define-syntax (begin-for-syntax/once stx) 170 (syntax-case stx () 171 [(bfs/o e ...) 172 (cond [(list? (syntax-local-context)) 173 #`(define-values () 174 (begin (begin-for-syntax/once e ...) 175 (values)))] 176 [else 177 #'(let-syntax ([m (lambda _ (begin e ...) #'(void))]) 178 (m))])])) 179 180 ;; == parse.rkt 181 182 (define (name->too-few/once name) 183 (and name (format "missing required occurrence of ~a" name))) 184 185 (define (name->too-few name) 186 (and name (format "too few occurrences of ~a" name))) 187 188 (define (name->too-many name) 189 (and name (format "too many occurrences of ~a" name))) 190 191 ;; == parse.rkt 192 193 ;; normalize-context : Symbol Any Syntax -> (list Symbol/#f Syntax) 194 (define (normalize-context who ctx stx) 195 (cond [(syntax? ctx) 196 (list #f ctx)] 197 [(symbol? ctx) 198 (list ctx stx)] 199 [(eq? ctx #f) 200 (list #f stx)] 201 [(and (list? ctx) 202 (= (length ctx) 2) 203 (or (symbol? (car ctx)) (eq? #f (car ctx))) 204 (syntax? (cadr ctx))) 205 ctx] 206 [else (error who "bad #:context argument\n expected: ~s\n given: ~e" 207 '(or/c syntax? symbol? #f (list/c (or/c symbol? #f) syntax?)) 208 ctx)])) 209 210 ;; == parse.rkt 211 212 (lazy-require 213 ["runtime-report.rkt" 214 (call-current-failure-handler)]) 215 216 ;; syntax-patterns-fail : (list Symbol/#f Syntax) -> (Listof (-> Any)) FailureSet -> escapes 217 (define ((syntax-patterns-fail ctx) undos fs) 218 (unwind-to undos null) 219 (call-current-failure-handler ctx fs)) 220 221 ;; == specialized ellipsis parser 222 ;; returns (values 'ok attr-values) or (values 'fail failure) 223 224 (provide predicate-ellipsis-parser) 225 226 (define (predicate-ellipsis-parser x cx pr es pred? desc rl) 227 (let ([elems (stx->list x)]) 228 (if (and elems (list? elems) (andmap pred? elems)) 229 (values 'ok elems) 230 (let loop ([x x] [cx cx] [i 0]) 231 (cond [(syntax? x) 232 (loop (syntax-e x) x i)] 233 [(pair? x) 234 (if (pred? (car x)) 235 (loop (cdr x) cx (add1 i)) 236 (let* ([pr (ps-add-cdr pr i)] 237 [pr (ps-add-car pr)] 238 [es (es-add-thing pr desc #t rl es)]) 239 (values 'fail (failure pr es))))] 240 [else ;; not null, because stx->list failed 241 (let ([pr (ps-add-cdr pr i)] 242 #| 243 ;; Don't extend es! That way we don't get spurious "expected ()" 244 ;; that *should* have been cancelled out by ineffable pair failures. 245 |#) 246 (values 'fail (failure* pr es)))]))))) 247 248 (provide illegal-cut-error) 249 250 (define (illegal-cut-error . _) 251 (error 'syntax-parse "illegal use of cut")) 252 253 ;; ---- 254 255 (provide unwind-to 256 maybe-add-state-undo 257 current-state 258 current-state-writable? 259 state-cons! 260 track-literals) 261 262 (define (unwind-to undos base) 263 ;; PRE: undos = (list* proc/hash ... base) 264 (unless (eq? undos base) 265 (let ([top-undo (car undos)]) 266 (cond [(procedure? top-undo) (top-undo)] 267 [(hash? top-undo) (current-state top-undo)])) 268 (unwind-to (cdr undos) base))) 269 270 (define (maybe-add-state-undo init-state new-state undos) 271 (if (eq? init-state new-state) 272 undos 273 (cons init-state undos))) 274 275 ;; To make adding undos to rewind current-state simpler, only allow updates 276 ;; in a few contexts: 277 ;; - literals (handled automatically) 278 ;; - in ~do/#:do blocks (sets current-state-writable? = #t) 279 280 (define current-state (make-parameter (hasheq))) 281 (define current-state-writable? (make-parameter #f)) 282 283 (define (state-cons! key value) 284 (define state (current-state)) 285 (current-state (hash-set state key (cons value (hash-ref state key null))))) 286 287 (define (track-literals who v #:introduce? [introduce? #t]) 288 (unless (syntax? v) 289 (raise-argument-error who "syntax?" v)) 290 (let* ([literals (hash-ref (current-state) 'literals '())]) 291 (if (null? literals) 292 v 293 (let ([literals* (if (and introduce? (syntax-transforming?) (list? literals)) 294 (for/list ([literal (in-list literals)]) 295 (if (identifier? literal) 296 (syntax-local-introduce literal) 297 literal)) 298 literals)] 299 [old-val (syntax-property v 'disappeared-use)]) 300 (syntax-property v 'disappeared-use 301 (if old-val 302 (cons literals* old-val) 303 literals*))))))