residual.rkt (11278B)
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 11 syntax/parse/private/residual-ct)) 12 (provide (for-syntax (all-from-out syntax/parse/private/residual-ct))) 13 14 (begin-for-syntax 15 ;; == from runtime.rkt 16 17 (provide make-attribute-mapping 18 attribute-mapping? 19 attribute-mapping-var 20 attribute-mapping-name 21 attribute-mapping-depth 22 attribute-mapping-syntax?) 23 24 (require (only-in (for-template syntax/parse/private/residual) 25 make-attribute-mapping 26 attribute-mapping? 27 attribute-mapping-var 28 attribute-mapping-name 29 attribute-mapping-depth 30 attribute-mapping-syntax?)) 31 #;(define-struct attribute-mapping (var name depth syntax?) 32 #:omit-define-syntaxes 33 #:property prop:procedure 34 (lambda (self stx) 35 (if (attribute-mapping-syntax? self) 36 #`(#%expression #,(attribute-mapping-var self)) 37 (let ([source-name 38 (or (let loop ([p (syntax-property stx 'disappeared-use)]) 39 (cond [(identifier? p) p] 40 [(pair? p) (or (loop (car p)) (loop (cdr p)))] 41 [else #f])) 42 (attribute-mapping-name self))]) 43 #`(let ([value #,(attribute-mapping-var self)]) 44 (if (syntax-list^depth? '#,(attribute-mapping-depth self) value) 45 value 46 (check/force-syntax-list^depth '#,(attribute-mapping-depth self) 47 value 48 (quote-syntax #,source-name)))))))) 49 ) 50 51 ;; ============================================================ 52 ;; Run-time 53 54 (require "runtime-progress.rkt" 55 "3d-stx.rkt" 56 auto-syntax-e 57 syntax/stx 58 stxparse-info/current-pvars) 59 60 (provide (all-from-out "runtime-progress.rkt") 61 62 this-syntax 63 this-role 64 this-context-syntax 65 attribute 66 attribute-binding 67 stx-list-take 68 stx-list-drop/cx 69 datum->syntax/with-clause 70 check/force-syntax-list^depth 71 check-literal* 72 error/null-eh-match 73 begin-for-syntax/once 74 75 name->too-few/once 76 name->too-few 77 name->too-many 78 normalize-context 79 syntax-patterns-fail) 80 81 ;; == from runtime.rkt 82 83 ;; this-syntax 84 ;; Bound to syntax being matched inside of syntax class 85 (define-syntax-parameter this-syntax 86 (lambda (stx) 87 (raise-syntax-error #f "used out of context: not within a syntax class" stx))) 88 89 (define-syntax-parameter this-role 90 (lambda (stx) 91 (raise-syntax-error #f "used out of context: not within a syntax class" stx))) 92 93 ;; this-context-syntax 94 ;; Bound to (expression that extracts) context syntax (bottom frame in progress) 95 (define-syntax-parameter this-context-syntax 96 (lambda (stx) 97 (raise-syntax-error #f "used out of context: not within a syntax class" stx))) 98 99 (define-syntax (attribute stx) 100 (syntax-case stx () 101 [(attribute name) 102 (identifier? #'name) 103 (let ([mapping (syntax-local-value #'name (lambda () #f))]) 104 (unless (syntax-pattern-variable? mapping) 105 (raise-syntax-error #f "not bound as a pattern variable" stx #'name)) 106 (let ([var (syntax-mapping-valvar mapping)]) 107 (let ([attr (syntax-local-value var (lambda () #f))]) 108 (unless (attribute-mapping? attr) 109 (raise-syntax-error #f "not bound as an attribute" stx #'name)) 110 (syntax-property (attribute-mapping-var attr) 111 'disappeared-use 112 (list (syntax-local-introduce #'name))))))])) 113 114 ;; (attribute-binding id) 115 ;; mostly for debugging/testing 116 (define-syntax (attribute-binding stx) 117 (syntax-case stx () 118 [(attribute-bound? name) 119 (identifier? #'name) 120 (let ([value (syntax-local-value #'name (lambda () #f))]) 121 (if (syntax-pattern-variable? value) 122 (let ([value (syntax-local-value (syntax-mapping-valvar value) (lambda () #f))]) 123 (if (attribute-mapping? value) 124 #`(quote #,(make-attr (attribute-mapping-name value) 125 (attribute-mapping-depth value) 126 (attribute-mapping-syntax? value))) 127 #'(quote #f))) 128 #'(quote #f)))])) 129 130 ;; stx-list-take : stxish nat -> syntax 131 (define (stx-list-take stx n) 132 (datum->syntax #f 133 (let loop ([stx stx] [n n]) 134 (if (zero? n) 135 null 136 (cons (stx-car stx) 137 (loop (stx-cdr stx) (sub1 n))))))) 138 139 ;; stx-list-drop/cx : stxish stx nat -> (values stxish stx) 140 (define (stx-list-drop/cx x cx n) 141 (let loop ([x x] [cx cx] [n n]) 142 (if (zero? n) 143 (values x 144 (if (syntax? x) x cx)) 145 (loop (stx-cdr x) 146 (if (syntax? x) x cx) 147 (sub1 n))))) 148 149 ;; check/force-syntax-list^depth : nat any id -> (listof^depth syntax) 150 ;; Checks that value is (listof^depth syntax); forces promises. 151 ;; Slow path for attribute-mapping code, assumes value is not syntax-list^depth? already. 152 (define (check/force-syntax-list^depth depth value0 source-id) 153 (define (bad sub-depth sub-value) 154 (attribute-not-syntax-error depth value0 source-id sub-depth sub-value)) 155 (define (loop depth value) 156 (cond [(promise? value) 157 (loop depth (force value))] 158 [(zero? depth) 159 (if (syntax? value) value (bad depth value))] 160 [else (loop-list depth value)])) 161 (define (loop-list depth value) 162 (cond [(promise? value) 163 (loop-list depth (force value))] 164 [(pair? value) 165 (let ([new-car (loop (sub1 depth) (car value))] 166 [new-cdr (loop-list depth (cdr value))]) 167 ;; Don't copy unless necessary 168 (if (and (eq? new-car (car value)) 169 (eq? new-cdr (cdr value))) 170 value 171 (cons new-car new-cdr)))] 172 [(null? value) 173 null] 174 [else 175 (bad depth value)])) 176 (loop depth value0)) 177 178 (define (attribute-not-syntax-error depth0 value0 source-id sub-depth sub-value) 179 (raise-syntax-error #f 180 (format (string-append "bad attribute value for syntax template" 181 "\n attribute value: ~e" 182 "\n expected for attribute: ~a" 183 "\n sub-value: ~e" 184 "\n expected for sub-value: ~a") 185 value0 186 (describe-depth depth0) 187 sub-value 188 (describe-depth sub-depth)) 189 source-id)) 190 191 (define (describe-depth depth) 192 (cond [(zero? depth) "syntax"] 193 [else (format "list of depth ~s of syntax" depth)])) 194 195 ;; syntax-list^depth? : nat any -> boolean 196 ;; Returns true iff value is (listof^depth syntax). 197 (define (syntax-list^depth? depth value) 198 (if (zero? depth) 199 (syntax? value) 200 (and (list? value) 201 (for/and ([part (in-list value)]) 202 (syntax-list^depth? (sub1 depth) part))))) 203 204 ;; datum->syntax/with-clause : any -> syntax 205 (define (datum->syntax/with-clause x) 206 (cond [(syntax? x) x] 207 [(2d-stx? x #:traverse-syntax? #f) 208 (datum->syntax #f x #f)] 209 [else 210 (error 'datum->syntax/with-clause 211 (string-append 212 "implicit conversion to 3D syntax\n" 213 " right-hand side of #:with clause or ~~parse pattern would be 3D syntax\n" 214 " value: ~e") 215 x)])) 216 217 ;; check-literal* : id phase phase (listof phase) stx -> void 218 (define (check-literal* id used-phase mod-phase ok-phases/ct-rel ctx) 219 (unless (or (memv (and used-phase (- used-phase mod-phase)) 220 ok-phases/ct-rel) 221 (identifier-binding id used-phase)) 222 (raise-syntax-error 223 #f 224 (format "literal is unbound in phase ~a (phase ~a relative to the enclosing module)" 225 used-phase 226 (and used-phase (- used-phase mod-phase))) 227 ctx id))) 228 229 ;; error/null-eh-match : -> (escapes) 230 (define (error/null-eh-match) 231 (error 'syntax-parse "an ellipsis-head pattern matched an empty sequence")) 232 233 ;; (begin-for-syntax/once expr/phase1 ...) 234 ;; evaluates in pass 2 of module/intdefs expansion 235 (define-syntax (begin-for-syntax/once stx) 236 (syntax-case stx () 237 [(bfs/o e ...) 238 (cond [(list? (syntax-local-context)) 239 #`(define-values () 240 (begin (begin-for-syntax/once e ...) 241 (values)))] 242 [else 243 #'(let-syntax ([m (lambda _ (begin e ...) #'(void))]) 244 (m))])])) 245 246 ;; == parse.rkt 247 248 (define (name->too-few/once name) 249 (and name (format "missing required occurrence of ~a" name))) 250 251 (define (name->too-few name) 252 (and name (format "too few occurrences of ~a" name))) 253 254 (define (name->too-many name) 255 (and name (format "too many occurrences of ~a" name))) 256 257 ;; == parse.rkt 258 259 ;; normalize-context : Symbol Any Syntax -> (list Symbol/#f Syntax) 260 (define (normalize-context who ctx stx) 261 (cond [(syntax? ctx) 262 (list #f ctx)] 263 [(symbol? ctx) 264 (list ctx stx)] 265 [(eq? ctx #f) 266 (list #f stx)] 267 [(and (list? ctx) 268 (= (length ctx) 2) 269 (or (symbol? (car ctx)) (eq? #f (car ctx))) 270 (syntax? (cadr ctx))) 271 ctx] 272 [else (error who "bad #:context argument\n expected: ~s\n given: ~e" 273 '(or/c syntax? symbol? #f (list/c (or/c symbol? #f) syntax?)) 274 ctx)])) 275 276 ;; == parse.rkt 277 278 (lazy-require 279 ["runtime-report.rkt" 280 (call-current-failure-handler ctx fs)]) 281 282 ;; syntax-patterns-fail : (list Symbol/#f Syntax) -> FailureSet -> (escapes) 283 (define ((syntax-patterns-fail ctx) fs) 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)))])))))