From 7466b7ec6c89d29cc2899fd499b8ec9ee7e05d41 Mon Sep 17 00:00:00 2001 From: Ryan Culpepper Date: Mon, 3 Jun 2013 14:22:02 -0400 Subject: [PATCH] added 2d check for #:with right-hand side --- collects/syntax/parse/private/3d-stx.rkt | 249 ++++++++++++++++++ collects/syntax/parse/private/parse.rkt | 2 +- collects/syntax/parse/private/residual.rkt | 18 +- .../syntax/scribblings/parse/patterns.scrbl | 10 +- .../syntax/scribblings/parse/stxclasses.scrbl | 6 + 5 files changed, 279 insertions(+), 6 deletions(-) create mode 100644 collects/syntax/parse/private/3d-stx.rkt diff --git a/collects/syntax/parse/private/3d-stx.rkt b/collects/syntax/parse/private/3d-stx.rkt new file mode 100644 index 0000000000..e94dbe6af3 --- /dev/null +++ b/collects/syntax/parse/private/3d-stx.rkt @@ -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)))))) diff --git a/collects/syntax/parse/private/parse.rkt b/collects/syntax/parse/private/parse.rkt index 8b7c5a5674..87364090e3 100644 --- a/collects/syntax/parse/private/parse.rkt +++ b/collects/syntax/parse/private/parse.rkt @@ -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))] diff --git a/collects/syntax/parse/private/residual.rkt b/collects/syntax/parse/private/residual.rkt index 685fa236a8..9438089da4 100644 --- a/collects/syntax/parse/private/residual.rkt +++ b/collects/syntax/parse/private/residual.rkt @@ -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)) diff --git a/collects/syntax/scribblings/parse/patterns.scrbl b/collects/syntax/scribblings/parse/patterns.scrbl index d3caec4c03..51e49bc3b7 100644 --- a/collects/syntax/scribblings/parse/patterns.scrbl +++ b/collects/syntax/scribblings/parse/patterns.scrbl @@ -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 ...+)]{ diff --git a/collects/syntax/scribblings/parse/stxclasses.scrbl b/collects/syntax/scribblings/parse/stxclasses.scrbl index d672545adc..f7094bd25e 100644 --- a/collects/syntax/scribblings/parse/stxclasses.scrbl +++ b/collects/syntax/scribblings/parse/stxclasses.scrbl @@ -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)]{