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

added 2d check for #:with right-hand side

Browse Source
This commit is contained in:
Ryan Culpepper 2013-06-03 14:22:02 -04:00
parent 03bd431e1d
commit 7466b7ec6c
5 changed files with 279 additions and 6 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

249
collects/syntax/parse/private/3d-stx.rkt Normal file
View File

@ -0,0 +1,249 @@
#lang racket/base
(require (only-in '#%flfxnum flvector? fxvector?)
(only-in '#%extfl extflonum? extflvector?))
(provide 2d-stx?
check-datum)
;; Checks for 3D syntax (syntax that contains unwritable values, etc)
(define INIT-FUEL #e1e6)
;; TO DO:
;; - extension via proc (any -> list/#f),
;; value considered good if result is list, all values in list are good
;; --
#|
Some other predicates one might like to have:
- would (read (write x)) succeed and be equal/similar to x?
- would (datum->syntax #f x) succeed?
- would (syntax->datum (datum->syntax #f x)) succeed and be equal/similar to x?
- would (eval (read (write (compile `(quote ,x))))) succeed and be equal/similar to x?
where equal/similar could mean one of the following:
- equal?, which equates eg (vector 1 2 3) and (vector-immutable 1 2 3)
- equal? relaxed to equate eg mutable and immutable hashes (but not prefabs)
- equal? but also requiring same mutability at every point
Some aux definitions:
(define (rt x)
(define-values (in out) (make-pipe))
(write x out)
(close-output-port out)
(read in))
(define (wrsd x)
(define-values (in out) (make-pipe))
(write x out)
(close-output-port out)
(syntax->datum (read-syntax #f in)))
(define (dsd x)
(syntax->datum (datum->syntax #f x)))
(define (evalc x) ;; mimics compiled zo-file constraints
(eval (rt (compile `(quote ,x)))))
How mutability behaves:
- for vectors, boxes:
- read always mutable
- read-syntax always immutable
- (dsd x) always immutable
- (evalc x) always immutable
- for hashes:
- read always immutable
- (dsd x) same as x
- (evalc x) always immutable (!!!)
- for prefab structs:
- read same as x
- read-syntax same as x
- (dsd x) same as x
- (evalc x) same as x
Symbols
- (dsd x) same as x
- (evalc x) preserves interned, unreadable, makes new uninterned (loses eq-ness)
Chaperones allow the lazy generation of infinite trees of data
undetectable by eq?-based cycle detection. Might be helpful to have
chaperone-eq? (not recursive, just chaperones of same object) and
chaperone-eq?-hash-code, to use with make-custom-hash.)
Impersonators allow the lazy generation of infinite trees of data,
period.
|#
;; ----
;; 2d-stx? : any ... -> boolean
;; Would (write (compile `(quote-syntax ,x))) succeed?
;; If traverse-syntax? is #t, recurs into existing syntax
;; If traverse-syntax? is #f, assumes existing stxobjs are 2d, and only
;; checks if *new* 3d syntax would be created.
(define (2d-stx? x
#:traverse-syntax? [traverse-syntax? #t]
#:irritant [irritant-box #f])
(check-datum x
#:syntax-mode (if traverse-syntax? 'compound 'atomic)
#:allow-impersonators? #f
#:allow-mutable? 'no-hash/prefab
#:allow-unreadable-symbols? #t
#:allow-cycles? #t
#:irritant irritant-box))
;; ----
;; check-datum : any ... -> boolean
;; where StxMode = (U 'atomic 'compound #f)
;; Returns nat if x is "good", #f if "bad"
;; If irritant-b is a box, the first bad subvalue found is put in the box.
;; If visited-t is a hash, it is used to detect cycles.
(define (check-datum x
#:syntax-mode [stx-mode #f]
#:allow-impersonators? [allow-impersonators? #f]
#:allow-mutable? [allow-mutable? #f]
#:allow-unreadable-symbols? [allow-unreadable? #f]
#:allow-cycles? [allow-cycles? #f]
#:irritant [irritant-b #f])
;; Try once with some fuel. If runs out of fuel, try again with cycle checking.
(define (run fuel visited-t)
(check* x fuel visited-t
stx-mode allow-impersonators? allow-mutable? allow-unreadable? allow-cycles?
irritant-b))
(let ([result (run INIT-FUEL #f)])
(cond [(not (equal? result 0)) ;; nat>0 or #f
(and result #t)]
[else
;; (eprintf "out of fuel, restarting\n")
(and (run +inf.0 (make-hasheq)) #t)])))
;; check* : any nat/+inf.0 StxMode boolean boolean boolean box -> nat/#f
;; Returns #f if bad, positive nat if good, 0 if ran out of fuel
;; If bad, places bad subvalue in irritant-b, if box
(define (check* x0 fuel0 visited-t
stx-mode allow-impersonators? allow-mutable? allow-unreadable? allow-cycles?
irritant-b)
(define no-mutable? (not allow-mutable?))
(define no-mutable-hash/prefab? (or no-mutable? (eq? allow-mutable? 'no-hash/prefab)))
(define no-cycle? (not allow-cycles?))
(define no-impersonator? (not allow-impersonators?))
(define (loop x fuel)
(if (and fuel (not (zero? fuel)))
(loop* x fuel)
fuel))
(define (loop* x fuel)
(define (bad) (when irritant-b (set-box! irritant-b x)) #f)
(define-syntax-rule (with-mutable-check mutable? body ...) ;; don't use for hash or prefab
(cond [(and no-mutable? mutable?)
(bad)]
[else
body ...]))
(define-syntax-rule (with-cycle-check body ...)
(cond [(and visited-t (hash-ref visited-t x #f))
=> (lambda (status)
(cond [(and no-cycle? (eq? status 'traversing))
(bad)]
[else
fuel]))]
[else
(when visited-t
(hash-set! visited-t x 'traversing))
(begin0 (begin body ...)
(when visited-t
(hash-remove! visited-t x)))]))
;; (eprintf "-- checking ~s, fuel ~s\n" x fuel)
(cond
;; Immutable compound
[(and visited-t (list? x))
;; space optimization: if list (finite), no need to store all cdr pairs in cycle table
;; don't do unless visited-t present, else expands fuel by arbitrary factors
(with-cycle-check
(for/fold ([fuel (sub1 fuel)]) ([e (in-list x)] #:break (not fuel))
(loop e fuel)))]
[(pair? x)
(with-cycle-check
(let ([fuel (loop (car x) (sub1 fuel))])
(loop (cdr x) fuel)))]
;; Atomic
[(or (null? x)
(boolean? x)
(number? x)
(char? x)
(keyword? x)
(regexp? x)
(extflonum? x))
fuel]
[(symbol? x)
(cond [(symbol-interned? x)
fuel]
[(symbol-unreadable? x)
(if allow-unreadable? fuel (bad))]
[else ;; uninterned
(if (eq? allow-unreadable? #t) fuel (bad))])]
;; Mutable flat
[(or (string? x)
(bytes? x))
(with-mutable-check (not (immutable? x))
fuel)]
[(or (fxvector? x)
(flvector? x)
(extflvector? x))
(with-mutable-check (not (immutable? x))
fuel)]
;; Syntax
[(syntax? x)
(case stx-mode
((atomic) fuel)
((compound) (loop (syntax-e x) fuel))
(else (bad)))]
;; Impersonators and chaperones
[(and no-impersonator? (impersonator? x)) ;; else continue to chaperoned type
(bad)]
[(and no-impersonator? (chaperone? x)) ;; else continue to impersonated type
(bad)]
[else
(with-cycle-check
(cond
;; Mutable (maybe) compound
[(vector? x)
(with-mutable-check (not (immutable? x))
(for/fold ([fuel fuel]) ([e (in-vector x)] #:break (not fuel))
(loop e fuel)))]
[(box? x)
(with-mutable-check (not (immutable? x))
(loop (unbox x) (sub1 fuel)))]
[(prefab-struct-key x)
=> (lambda (key)
(cond [(and no-mutable-hash/prefab? (mutable-prefab-key? key))
(bad)]
[else
;; traverse key, since contains arbitrary auto-value
(let ([fuel (loop key fuel)])
(loop (struct->vector x) fuel))]))]
[(hash? x)
(cond [(and no-mutable-hash/prefab? (not (immutable? x)))
(bad)]
[else
(for/fold ([fuel fuel]) ([(k v) (in-hash x)] #:break (not fuel))
(let ([fuel (loop k fuel)])
(loop v fuel)))])]
;; Bad
[else
(bad)]))]))
(loop x0 fuel0))
;; mutable-prefab-key? : prefab-key -> boolean
(define (mutable-prefab-key? key)
;; A prefab-key is either
;; - symbol
;; - (list* symbol maybe-nat maybe-list maybe-vector prefab-key)
;; where mutable fields indicated by vector
;; This code is probably overly general; racket seems to normalize keys.
(let loop ([k key])
(and (pair? k)
(or (and (vector? (car k))
(positive? (vector-length (car k))))
(loop (cdr k))))))

2
collects/syntax/parse/private/parse.rkt
View File

@ -679,7 +679,7 @@ Conventions:
(fail (failure pr* es*)))
k))]
[#s(action:parse _ pattern expr)
#`(let* ([y (datum->syntax #f (wrap-user-code expr) #f)]
#`(let* ([y (datum->syntax/with-clause (wrap-user-code expr))]
[cy y]
[pr* (ps-add-stx pr y)])
(parse:S y cy pattern pr* es k))]

18
collects/syntax/parse/private/residual.rkt
View File

@ -45,6 +45,7 @@
;; Run-time
(require "runtime-progress.rkt"
"3d-stx.rkt"
syntax/stx)
(provide (all-from-out "runtime-progress.rkt")
@ -56,6 +57,8 @@
attribute-binding
stx-list-take
stx-list-drop/cx
datum->syntax/with-clause
check/force-syntax-list^depth
check-literal*
begin-for-syntax/once
@ -138,7 +141,7 @@
(define (check/force-syntax-list^depth depth value0 source-id)
(define (bad)
(raise-syntax-error #f
(format "attribute is bound to non-syntax value: ~e" value0)
(format "attribute is bound to non-syntax value\n value: ~e" value0)
source-id))
(define (loop depth value)
(cond [(promise? value)
@ -172,6 +175,19 @@
(for/and ([part (in-list value)])
(syntax-list^depth? (sub1 depth) part)))))
;; datum->syntax/with-clause : any -> syntax
(define (datum->syntax/with-clause x)
(cond [(syntax? x) x]
[(2d-stx? x #:traverse-syntax? #f)
(datum->syntax #f x #f)]
[else
(error 'datum->syntax/with-clause
(string-append
"implicit conversion to 3D syntax\n"
" right-hand side of #:with clause or ~~parse pattern would be 3D syntax\n"
" value: ~e")
x)]))
;; check-literal* : id phase phase (listof phase) stx -> void
(define (check-literal* id used-phase mod-phase ok-phases/ct-rel ctx)
(unless (or (memv (and used-phase (- used-phase mod-phase))

10
collects/syntax/scribblings/parse/patterns.scrbl
View File

@ -1003,11 +1003,13 @@ specific ill-formed terms and address them with custom failure
messages.
}
@specsubform[(@#,defhere[~parse] S-pattern stx-expr)
#:contracts ([stx-expr syntax?])]{
@specsubform[(@#,defhere[~parse] S-pattern stx-expr)]{
Evaluates @racket[stx-expr] to a syntax object and matches it against
@racket[S-pattern].
Evaluates @racket[stx-expr] and matches it against
@racket[S-pattern]. If @racket[stx-expr] does not produce a syntax
object, the value is implicitly converted to a syntax object, unless
the conversion would produce @tech{3D syntax}, in which case an
exception is raised instead.
}
@specsubform[(@#,def[~and a] A-pattern ...+)]{

6
collects/syntax/scribblings/parse/stxclasses.scrbl
View File

@ -209,6 +209,12 @@ evaluation of subsequent side conditions. If the @racket[#:with] match
fails, the matching process backtracks. Since a syntax object may
match a pattern in several ways, backtracking may cause the same
clause to be tried multiple times before the next clause is reached.
If the value of @racket[stx-expr] is not a syntax object, it is
implicitly converted to a syntax object. If the the conversion would
produce @deftech{3D syntax}---that is, syntax that contains unwritable
values such as procedures, non-prefab structures, etc---then an
exception is raised instead.
}
@specsubform[(code:line #:attr attr-arity-decl expr)]{