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

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))))))

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))]

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))

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)
+@specsubform[(@#,defhere[~parse] S-pattern stx-expr)]{
-             #:contracts ([stx-expr syntax?])]{
 
-Evaluates @racket[stx-expr] to a syntax object and matches it against
+Evaluates @racket[stx-expr] and matches it against
-@racket[S-pattern].
+@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 ...+)]{

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)]{