From d1439ef6c61807555b96c37639c4ad4e458766aa Mon Sep 17 00:00:00 2001 From: Ryan Culpepper Date: Sun, 8 Nov 2009 21:17:51 +0000 Subject: [PATCH] unstable/struct: added struct->list some (cdr (vector->list (struct->vector x))) => (struct->list x) svn: r16622 --- .../syntax-browser/pretty-helper.ss | 3 ++- .../syntax/private/stxparse/codegen-data.ss | 3 ++- collects/syntax/private/stxparse/minimatch.ss | 5 ++-- collects/syntax/private/stxparse/rep.ss | 3 ++- collects/unstable/scribblings/struct.scrbl | 25 ++++++++++++++++++- collects/unstable/struct.ss | 16 +++++++++++- collects/unstable/syntax.ss | 3 ++- 7 files changed, 50 insertions(+), 8 deletions(-) diff --git a/collects/macro-debugger/syntax-browser/pretty-helper.ss b/collects/macro-debugger/syntax-browser/pretty-helper.ss index ba501acd74..cf5e265a8b 100644 --- a/collects/macro-debugger/syntax-browser/pretty-helper.ss +++ b/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)) diff --git a/collects/syntax/private/stxparse/codegen-data.ss b/collects/syntax/private/stxparse/codegen-data.ss index 45f71084a3..36d6812111 100644 --- a/collects/syntax/private/stxparse/codegen-data.ss +++ b/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 diff --git a/collects/syntax/private/stxparse/minimatch.ss b/collects/syntax/private/stxparse/minimatch.ss index 863734995c..b0cf4080db 100644 --- a/collects/syntax/private/stxparse/minimatch.ss +++ b/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)))]) diff --git a/collects/syntax/private/stxparse/rep.ss b/collects/syntax/private/stxparse/rep.ss index 230e43a710..3f9cb56893 100644 --- a/collects/syntax/private/stxparse/rep.ss +++ b/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))))])) diff --git a/collects/unstable/scribblings/struct.scrbl b/collects/unstable/scribblings/struct.scrbl index 2480f3facd..0e33658ca0 100644 --- a/collects/unstable/scribblings/struct.scrbl +++ b/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) +] } diff --git a/collects/unstable/struct.ss b/collects/unstable/struct.ss index ecd20380f7..33edfa4557 100644 --- a/collects/unstable/struct.ss +++ b/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))))) diff --git a/collects/unstable/syntax.ss b/collects/unstable/syntax.ss index 87c4a23c2d..0e3477556c 100644 --- a/collects/unstable/syntax.ss +++ b/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