unstable/struct: added struct->list

some (cdr (vector->list (struct->vector x))) => (struct->list x)

svn: r16622

collects/macro-debugger/syntax-browser/pretty-helper.ss

@@ -4,6 +4,7 @@
          scheme/pretty
          macro-debugger/util/class-iop
          syntax/stx
+         unstable/struct
          "interfaces.ss")
 (provide (all-defined-out))
 
@@ -140,7 +141,7 @@
 ;; unfold-pstruct : prefab-struct -> (values (list -> prefab-struct) list)
 (define (unfold-pstruct obj)
   (define key (prefab-struct-key obj))
-  (define fields (cdr (vector->list (struct->vector obj))))
+  (define fields (struct->list obj))
   (values (lambda (new-fields)
             (apply make-prefab-struct key new-fields))
           fields))

collects/syntax/private/stxparse/codegen-data.ss

@@ -3,6 +3,7 @@
          (for-template scheme/base
                        syntax/stx
                        scheme/stxparam
+                       unstable/struct
                        "runtime.ss"))
 (provide (all-defined-out))
 
@@ -16,7 +17,7 @@
                     (let ([xkey (prefab-struct-key x)])
                       (and xkey (equal? xkey (quote key)))))
                 (list (lambda (s d)
-                        #`(datum->syntax #,s (cdr (vector->list (struct->vector #,d))) #,s)))
+                        #`(datum->syntax #,s (struct->list #,d) #,s)))
                 (list #'dfc-add-unpstruct))]))
 
 ;; A Kind is

collects/syntax/private/stxparse/minimatch.ss

@@ -1,5 +1,6 @@
 #lang scheme/base
-(require (for-syntax scheme/base scheme/path))
+(require unstable/struct
+         (for-syntax scheme/base unstable/struct))
 (provide match)
 
 (define-syntax (match stx)
@@ -48,7 +49,7 @@
     [(match-p x s success failure)
      (prefab-struct-key (syntax-e #'s))
      (with-syntax ([key (prefab-struct-key (syntax-e #'s))]
-                   [(p ...) (cdr (vector->list (struct->vector (syntax-e #'s))))])
+                   [(p ...) (struct->list (syntax-e #'s))])
        #'(let ([xkey (prefab-struct-key x)])
            (if (equal? xkey 'key)
                (let ([xps (cdr (vector->list (struct->vector x)))])

collects/syntax/private/stxparse/rep.ss

@@ -8,6 +8,7 @@
          syntax/stx
          syntax/keyword
          unstable/syntax
+         unstable/struct
          "../util.ss"
          "rep-data.ss"
          "codegen-data.ss")
@@ -390,7 +391,7 @@
      (and (struct? (syntax-e #'s)) (prefab-struct-key (syntax-e #'s)))
      (let* ([s (syntax-e #'s)]
             [key (prefab-struct-key s)]
-            [contents (cdr (vector->list (struct->vector s)))])
+            [contents (struct->list s)])
        (let ([lp (parse-single-pattern (datum->syntax #f contents #'s) decls)])
          (create-pat:compound `(#:pstruct ,key) (list lp))))]))
 

collects/unstable/scribblings/struct.scrbl

@@ -24,5 +24,28 @@ is raised at compile time.
   (make triple 3 4 5)
   (make triple 2 4)
 ]
-
+}
+
+@defproc[(struct->list [v any/c]
+                       [#:false-on-opaque? false-on-opaque? boolean? #f])
+         (or/c list? #f)]{
+
+Returns a list containing the struct instance @scheme[v]'s
+fields. Unlike @scheme[struct->vector], the struct name itself is not
+included.
+
+The struct instance @scheme[v] must be fully accessible using the
+current inspector. If any fields are inaccessible, either an error is
+raised or @scheme[#f] is returned, depending on the value of
+@scheme[false-on-opaque?]. The default is to raise an error.
+
+@examples[#:eval the-eval
+(define-struct open (u v) #:transparent)
+(struct->list (make-open 'a 'b))
+(struct->list #s(pre 1 2 3))
+(define-struct secret (x y))
+(struct->list (make-secret 17 22))
+(struct->list (make-secret 17 22) #:false-on-opaque? #t)
+(struct->list 'not-a-struct #:false-on-opaque? #t)
+]
 }

collects/unstable/struct.ss

@@ -2,7 +2,8 @@
 ;; owner: ryanc
 (require (for-syntax scheme/base
                      scheme/struct-info))
-(provide make)
+(provide make
+         struct->list)
 
 ;; (make struct-name field-expr ...)
 ;; Checks that correct number of fields given.
@@ -39,3 +40,16 @@
          (syntax-property #'(constructor expr ...)
                           'disappeared-use
                           #'S)))]))
+
+(define dummy-value (box 'dummy))
+
+;; struct->list : struct? #:false-on-opaque? bool -> (listof any/c)
+(define (struct->list s #:false-on-opaque? [false-on-opaque? #f])
+  (let ([vec (struct->vector s dummy-value)])
+    (and (for/and ([elem (in-vector vec)])
+           (cond [(eq? elem dummy-value)
+                  (unless false-on-opaque?
+                    (raise-type-error 'struct->list "non-opaque struct" s))
+                  #f]
+                 [else #t]))
+         (cdr (vector->list vec)))))

collects/unstable/syntax.ss

@@ -2,6 +2,7 @@
 ;; owner: ryanc
 (require syntax/kerncase
          syntax/stx
+         unstable/struct
          (for-syntax scheme/base
                      scheme/private/sc))
 
@@ -37,7 +38,7 @@
           [(prefab-struct-key x)
            => (lambda (key)
                 (apply make-prefab-struct key
-                       (loop (cdr (vector->list (struct->vector x))))))]
+                       (loop (struct->list x))))]
           [else x])))
 
 ;; Defining pattern variables