suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

datum: always force promise

Browse Source
This commit is contained in:
Ryan Culpepper 2019-11-21 14:32:15 +01:00
parent 45fb9b4d63
commit 5c0d75fa3e
2 changed files with 13 additions and 14 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

18
pkgs/racket-test/tests/stxparse/test-datum.rkt
View File

@ -57,14 +57,14 @@
(list (ast:bind #'x (list #'1)) (ast:bind #'y #f))) (list (ast:bind #'x (list #'1)) (ast:bind #'y #f)))
;; ------------------------------------------------------------ ;; ------------------------------------------------------------
;; The strange corner cases... ;; The corner cases...
(require racket/list racket/promise) (require racket/list racket/promise)
;; The following are two consequences of the decision to make (datum a) ;; The following is a consequences of the decision to make (datum a) equivalent,
;; equivalent to (attribute a), where a is an attribute. Thus if a is "absent" ;; or nearly so, to (attribute a), where a is an attribute. In particular, if a
;; (has the value #f), (datum a) returns #f rather than signaling an ;; is "absent" (has the value #f), (datum a) returns #f rather than signaling an
;; error. Likewise, if the value of a is a promise, it just returns the promise. ;; error. However, if value of a is a promise, it forces the promise.
;; 1: ~? catches attempts to iterate over absent attrs, but not uses of absent ;; 1: ~? catches attempts to iterate over absent attrs, but not uses of absent
;; attrs. Maybe add some sort of annotation to get other behavior? ;; attrs. Maybe add some sort of annotation to get other behavior?
@ -77,7 +77,7 @@
[(_ (~optional (x:id ...))) (datum (~? (x ...) default))]) [(_ (~optional (x:id ...))) (datum (~? (x ...) default))])
'default) 'default)
;; 2: Promises are forced only when necessary for iterating over lists. ;; 2: Unlike attribute, datum forces promises.
(define-syntax-class nrange #:attributes ([r 0] [k 1]) (define-syntax-class nrange #:attributes ([r 0] [k 1])
(pattern n:nat (pattern n:nat
@ -85,10 +85,8 @@
#:attr [r 0] (delay (range (syntax-e #'n))) #:attr [r 0] (delay (range (syntax-e #'n)))
#:attr [k 1] (delay (range (syntax-e #'n))))) #:attr [k 1] (delay (range (syntax-e #'n)))))
;; This returns a list of numbers:
(check-equal? (syntax-parse #'(m 10) [(_ n:nrange) (datum (n.k ...))]) (check-equal? (syntax-parse #'(m 10) [(_ n:nrange) (datum (n.k ...))])
(range 10)) (range 10))
;; But this returns a promise: (check-equal? (syntax-parse #'(m 10) [(_ n:nrange) (datum n.r)])
(check-pred promise? (range 10))
(syntax-parse #'(m 10) [(_ n:nrange) (datum n.r)]))

9
racket/collects/syntax/parse/private/residual.rkt
View File

@ -110,12 +110,12 @@
(sub1 n))))) (sub1 n)))))
;; check-attr-value : Any d:Nat b:Boolean Syntax/#f -> (Listof^d (if b Syntax Any)) ;; check-attr-value : Any d:Nat b:Boolean Syntax/#f -> (Listof^d (if b Syntax Any))
(define (check-attr-value v0 depth0 base? ctx) (define (check-attr-value v0 depth0 stx? ctx)
(define (bad kind v) (define (bad kind v)
(raise-syntax-error #f (format "attribute contains non-~s value\n value: ~e" kind v) ctx)) (raise-syntax-error #f (format "attribute contains non-~s value\n value: ~e" kind v) ctx))
(define (depthloop depth v) (define (depthloop depth v)
(if (zero? depth) (if (zero? depth)
(if base? (baseloop v) v) (baseloop v)
(let listloop ([v v] [root? #t]) (let listloop ([v v] [root? #t])
(cond [(null? v) null] (cond [(null? v) null]
[(pair? v) (let ([new-car (depthloop (sub1 depth) (car v))] [(pair? v) (let ([new-car (depthloop (sub1 depth) (car v))]
@ -126,8 +126,9 @@
[(and root? (eq? v #f)) (begin (signal-absent-pvar) (bad 'list v))] [(and root? (eq? v #f)) (begin (signal-absent-pvar) (bad 'list v))]
[else (bad 'list v)])))) [else (bad 'list v)]))))
(define (baseloop v) (define (baseloop v)
(cond [(syntax? v) v] (cond [(promise? v) (baseloop (force v))]
[(promise? v) (baseloop (force v))] [(not stx?) v]
[(syntax? v) v]
[(eq? v #f) (begin (signal-absent-pvar) (bad 'syntax v))] [(eq? v #f) (begin (signal-absent-pvar) (bad 'syntax v))]
[else (bad 'syntax v)])) [else (bad 'syntax v)]))
(depthloop depth0 v0)) (depthloop depth0 v0))