[plt-scheme] Structure cloning

Hi all,

Here is the cloning function I were aiming for.
Comments and simplifications are welcome.

(clone-struct f s)
    Makes a new structure of the same type as s.
    Call the fields of s for f1, ..., fn, then
    the new fields of the new structure is
    (f f1), ..., (f fn).

Example 1:

Simple cloning of structure - add1 is used
instead of a simple copy to show something
actually happens.

(print-struct #t)
(define-struct foo       (a)     (make-inspector))
(define-struct (bar foo) (b c)   (make-inspector))
(define-struct (baz bar) (d e f) (make-inspector))

 > (define s (make-baz 1 2 3 4 5 6))
 > s
#(struct:baz 1 2 3 4 5 6)
 > (clone-struct add1 s)
#(struct:baz 2 3 4 5 6 7)

Example 2:

Cloning a tree of structures with integers as leaves
is done like this:

(print-struct #t)

(define-struct foo       (a)     (make-inspector))
(define-struct (bar foo) (b c)   (make-inspector))
(define-struct (baz bar) (d e f) (make-inspector))

(define-struct yada             (x)   (make-inspector))
(define-struct (yada-yada yada) (y z) (make-inspector))

(define s (make-baz 1 2 3 (make-yada-yada 4 5 6) 7 8))

(define (f o)
  (if (struct? o)
      (clone-struct f o)
      (+ o 1)))

 > (clone-struct f s)
#(struct:baz 2 3 4 #(struct:yada-yada 5 6 7) 8 9)


The actual code:


; struct-constructor : struct -> constructor
;   TODO: In 350 use struct-type-make-constructor instead
(define (struct-constructor s)
  (define (struct->struct-id s)
    (let*-values ([(info _)                   
                   (struct-info s)]
                  [(name _1 _2 _3 _4 _5 _6 _7)
                   (struct-type-info info)])
      name))
  (let* ([name (struct->struct-id s)]
         [make-name (string->symbol
                     (string-append
                      "make-" (symbol->string name)))])
    (namespace-variable-value make-name)))

(define (struct-type s)
  (if (struct? s)
      (let-values ([(type _) (struct-info s)])
        type)
      #f))

(define (super-struct-type t)
  (and t
       (let-values
           ([(name init-k auto-k s-ref s-set! imm super skipped)
             (struct-type-info t)])
         super)))

(define (super-types s)
    (define (super-types-from t)
      (if t
          (cons t (super-types-from
                   (super-struct-type t)))
          '()))
  (reverse! (super-types-from (struct-type s))))

(define (clone-struct f s)
  (define (clone-struct/type! f s ns t)
    (let-values (
        [(name init-k auto-k s-ref s-set! imm super skipped)
         (struct-type-info t)])
      (do ([i 0 (add1 i)])
        ((= i (+ init-k auto-k)))
        (s-set! ns i (f (s-ref s i))))))
 
  (let* ([no-constructor-args
          (let-values ([(_ init-k _1 _2 _3 _4 _5 _6)
                        (struct-type-info (struct-type s))])
            init-k)]
         [new-struct
          (apply (struct-constructor s)
                 (vector->list
                  (make-vector no-constructor-args #f)))])
    (for-each (lambda (t) (clone-struct/type! f s new-struct t))
      (super-types s))
    new-struct))

-- 
Jens Axel Søgaard