Fix PR 14614

pkgs/plai/datatype.rkt

@@ -56,11 +56,62 @@
     (plai-syntax-error 'type-case stx-loc type-case:not-a-type)))
 
 (require (for-syntax syntax/parse
-                     racket/syntax syntax/stx
+                     syntax/stx
+                     racket/string
+                     racket/match
                      (only-in racket/function curry)))
 
-(define-for-syntax (syntax-string s)
-  (symbol->string (syntax-e s)))
+(begin-for-syntax
+  (define SRBS null)
+  (define (CLEAR-SRBS!)
+    (set! SRBS null))
+  (define (GRAB-SRBS)
+    SRBS)
+
+  (define (format-id lctx fmt #:source src . v)
+    (define-values
+      (fmt+vs-strs final-make-srbs)
+      (let loop ([l (string->list fmt)]
+                 [v v]
+                 [here 0]
+                 [ss empty]
+                 [make-srbs (λ () null)])
+        (match l
+          [(list* #\~ #\a more)
+           (define first-v (first v))
+           (define first-s (format "~a" (syntax->datum first-v)))
+           (define first-len (string-length first-s))
+           (loop more (rest v) (+ here first-len)
+                 (cons first-s ss)
+                 (if (syntax-source first-v)
+                   (λ ()
+                     (cons (vector (syntax-local-introduce this-id)
+                                   here first-len
+                                   (syntax-local-introduce first-v)
+                                   0 first-len)
+                           (make-srbs)))
+                   make-srbs))]
+          [(list* other more)
+           (loop more v (+ here 1)
+                 (cons (string other) ss)
+                 make-srbs)]
+          [(list)
+           (values (reverse ss) make-srbs)])))
+    (define fmt+vs-str
+      (string-append* fmt+vs-strs))
+    (define fmt+vs-sym
+      (string->symbol fmt+vs-str))
+    (define this-id
+      (datum->syntax lctx fmt+vs-sym src))
+    (define srbs
+      (final-make-srbs))
+    (printf "~v -> ~v\n"
+            this-id srbs)
+    (set! SRBS (cons srbs SRBS))
+    this-id)
+
+  (define (syntax-string s)
+    (symbol->string (syntax-e s))))
 
 ;; XXX Copied from racket/private/define-struct
 (begin-for-syntax
@@ -110,6 +161,9 @@
      ;; Ensure type and variant names are unbound
      (map (assert-unbound 'define-type)
           (cons #'datatype? (syntax->list #'(variant ...))))
+
+     (CLEAR-SRBS!)
+
      (with-syntax
          ([(variant* ...)
            (generate-temporaries #'(variant ...))]
@@ -164,6 +218,9 @@
                         #'(variant* ...)
                         #'((field ...) ...))])
 
+           (define srbs (GRAB-SRBS))
+
+           (syntax-property
             (syntax/loc stx
               (begin
                 (define-syntax datatype
@@ -238,7 +295,9 @@
                                                    'set-variant-field! #'field)))
                   ...
                   )
-               ...)))))]))
+                ...))
+            'sub-range-binders
+            srbs))))]))
 
 (define-syntax-rule (lambda-memocontract (field ...) c-expr)
   (let ([cd #f])