Fixes bug 194259. R6RS records can now be written and read back

through fasl-write and fasl-read.

scheme/ikarus.fasl.ss

@@ -314,6 +314,28 @@
                            (cons x (f (- n 1))))])))])
              (when m (put-mark m ls))
              ls)]
+          [(#\W) ;;; r6rs record type descriptor
+           (let* ([name    (read)]
+                  [parent  (read)]
+                  [uid     (read)]
+                  [sealed? (read)]
+                  [opaque? (read)]
+                  [n       (read)]
+                  [fields  (make-vector n)])
+             (let f ([i 0])
+               (cond
+                 [(= i n) 
+                  (let ([rtd (make-record-type-descriptor
+                               name parent uid sealed? opaque?
+                               fields)])
+                    (when m (put-mark m rtd))
+                    rtd)]
+                 [else
+                  (let* ([field-mutable? (read)]
+                         [field-name (read)])
+                    (vector-set! fields i 
+                      (list (if field-mutable? 'mutable 'immutable) field-name))
+                    (f (+ i 1)))])))]
           [else
            (die who "Unexpected char as a fasl object header" h)])))
     (read))

scheme/ikarus.fasl.write.ss

@@ -199,6 +199,25 @@
                (f (fxadd1 i) n)))
            (fasl-write-object (code-reloc-vector x) p h m))]
         [(struct? x)
+         (cond
+           [(record-type-descriptor? x)
+            (put-tag #\W p)
+            (let* ([m (fasl-write-object (record-type-name x) p h m)]
+                   [m (fasl-write-object (record-type-parent x) p h m)]
+                   [m (fasl-write-object (record-type-uid x) p h m)])
+              (fasl-write-immediate (record-type-sealed? x) p)
+              (fasl-write-immediate (record-type-opaque? x) p)
+              (let* ([fields (record-type-field-names x)]
+                     [n (vector-length fields)])
+                (fasl-write-immediate n p)
+                (let f ([i 0] [m m])
+                  (cond
+                    [(= i n) m]
+                    [else
+                     (fasl-write-immediate (record-field-mutable? x i) p)
+                     (f (+ i 1) 
+                        (fasl-write-object (vector-ref fields i) p h m))]))))]
+           [else
             (let ([rtd (struct-type-descriptor x)])
               (cond
                 [(eq? rtd (base-rtd))
@@ -218,16 +237,17 @@
                 [else
                  ;;; non-rtd record
                  (put-tag #\{ p)
-              (write-int (length (struct-type-field-names rtd)) p)
+                 (let ([n (struct-length x)])
-              (let f ([names (struct-type-field-names rtd)] 
+                   (write-int n p)
+                   (let f ([i 0] 
                            [m (fasl-write-object rtd p h m)])
                      (cond
-                  [(null? names) m]
+                       [(= i n) m]
                        [else
-                   (f (cdr names) 
+                        (f (+ i 1)
                            (fasl-write-object 
-                         ((struct-field-accessor rtd (car names)) x)
+                              (struct-ref x i)
-                         p h m))]))]))]
+                              p h m))])))]))])]
         [(procedure? x)
          (put-tag #\Q p)
          (fasl-write-object ($closure-code x) p h m)]
@@ -313,23 +333,32 @@
               (make-graph ($code-annotation x) h)
               (make-graph (code-reloc-vector x) h)]
              [(struct? x)
-              (when (eq? x (base-rtd))
+              (cond
-                (die 'fasl-write "base-rtd is not writable"))
+                [(eq? x (base-rtd))
+                 (die 'fasl-write "base-rtd is not writable")]
+                [(record-type-descriptor? x) 
+                 (make-graph (record-type-name x) h)
+                 (make-graph (record-type-parent x) h)
+                 (make-graph (record-type-uid x) h)
+                 (vector-for-each 
+                   (lambda (x) (make-graph x h))
+                   (record-type-field-names x))]
+                [else
                  (let ([rtd (struct-type-descriptor x)])
                    (cond
                      [(eq? rtd (base-rtd))
-                   ;;; this is an rtd
+                      ;;; this is a struct rtd
                       (make-graph (struct-type-name x) h)
                       (make-graph (struct-type-symbol x) h)
                       (for-each (lambda (x) (make-graph x h))
                         (struct-type-field-names x))]
                      [else
-                   ;;; this is a record
+                      ;;; this is a struct
                       (make-graph rtd h)
-                   (for-each 
+                      (let f ([i 0] [n (struct-length x)])
-                     (lambda (name) 
+                        (unless (= i n) 
-                       (make-graph ((struct-field-accessor rtd name) x) h))
+                          (make-graph (struct-ref x i) h)
-                     (struct-type-field-names rtd))]))]
+                          (f (+ i 1) n)))]))])]
              [(procedure? x)
               (let ([code ($closure-code x)])
                 (unless (fxzero? (code-freevars code))

scheme/ikarus.records.procedural.ss

@@ -75,7 +75,11 @@
 
   (define (record-type-uid x)
     (if (rtd? x)
-        (rtd-uid x)
+        (or (rtd-uid x)
+            (let ([g (gensym)])
+              (set-rtd-uid! x g) 
+              (intern-rtd! g x)
+              g))
         (die 'record-type-uid "not an rtd" x)))
 
   (define (record-type-sealed? x)
@@ -90,7 +94,7 @@
 
   (define (record-type-generative? x)
     (if (rtd? x)
-        (not (rtd-sealed? x))
+        (not (rtd-sealed? x)) ;;; FIXME: bogus?
         (die 'record-type-generative? "not an rtd" x)))
 
   (define (record-type-field-names x)