conservatory
/
ikarus
4
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

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

through fasl-write and fasl-read.
This commit is contained in:
Abdulaziz Ghuloum 2008-02-26 03:53:00 -05:00
parent c8f9b1dc3d
commit e36b0029f6
3 changed files with 101 additions and 46 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

22
scheme/ikarus.fasl.ss
View File

@ -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))

117
scheme/ikarus.fasl.write.ss
View File

@ -199,35 +199,55 @@
(f (fxadd1 i) n)))
(fasl-write-object (code-reloc-vector x) p h m))]
[(struct? x)
(let ([rtd (struct-type-descriptor x)])
(cond
[(eq? rtd (base-rtd))
;;; rtd record
(put-tag #\R p)
(let ([names (struct-type-field-names x)]
[m
(fasl-write-object (struct-type-symbol x) p h
(fasl-write-object (struct-type-name x) p h m))])
(write-int (length names) p)
(let f ([names names] [m m])
(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
[(null? names) m]
[(= i n) m]
[else
(f (cdr names)
(fasl-write-object (car names) p h m))])))]
[else
;;; non-rtd record
(put-tag #\{ p)
(write-int (length (struct-type-field-names rtd)) p)
(let f ([names (struct-type-field-names rtd)]
[m (fasl-write-object rtd p h m)])
(cond
[(null? names) m]
[else
(f (cdr names)
(fasl-write-object
((struct-field-accessor rtd (car names)) x)
p h m))]))]))]
(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))
;;; rtd record
(put-tag #\R p)
(let ([names (struct-type-field-names x)]
[m
(fasl-write-object (struct-type-symbol x) p h
(fasl-write-object (struct-type-name x) p h m))])
(write-int (length names) p)
(let f ([names names] [m m])
(cond
[(null? names) m]
[else
(f (cdr names)
(fasl-write-object (car names) p h m))])))]
[else
;;; non-rtd record
(put-tag #\{ p)
(let ([n (struct-length x)])
(write-int n p)
(let f ([i 0]
[m (fasl-write-object rtd p h m)])
(cond
[(= i n) m]
[else
(f (+ i 1)
(fasl-write-object
(struct-ref x i)
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))
(die 'fasl-write "base-rtd is not writable"))
(let ([rtd (struct-type-descriptor x)])
(cond
[(eq? rtd (base-rtd))
;;; this is an 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
(make-graph rtd h)
(for-each
(lambda (name)
(make-graph ((struct-field-accessor rtd name) x) h))
(struct-type-field-names rtd))]))]
(cond
[(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 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 struct
(make-graph rtd h)
(let f ([i 0] [n (struct-length x)])
(unless (= i n)
(make-graph (struct-ref x i) h)
(f (+ i 1) n)))]))])]
[(procedure? x)
(let ([code ($closure-code x)])
(unless (fxzero? (code-freevars code))

8
scheme/ikarus.records.procedural.ss
View File

@ -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)