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

* r6rs.records.procedural is almost done.

This commit is contained in:
Abdulaziz Ghuloum 2007-07-05 16:59:06 +03:00
parent 054e076651
commit 598d7ae99c
1 changed files with 34 additions and 21 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

55
src/lab/ikarus.r6rs.records.procedural.ss
View File

@ -6,10 +6,12 @@
record-accessor record-mutator record-accessor record-mutator
record-constructor record-predicate) record-constructor record-predicate)
(import (import
(except (ikarus) record-constructor record-predicate) (except (ikarus) record-constructor record-predicate
set-rtd-printer!)
(ikarus system $records)) (ikarus system $records))
(define-record rtd (name size parent sealed? opaque? uid fields)) (define-record rtd
(name size old-fields printer symbol parent sealed? opaque? uid fields))
(define rtd-alist '()) (define rtd-alist '())
(define (intern-rtd! uid rtd) (define (intern-rtd! uid rtd)
(set! rtd-alist (cons (cons uid rtd) rtd-alist))) (set! rtd-alist (cons (cons uid rtd) rtd-alist)))
@ -24,7 +26,7 @@
(module (make-record-type-descriptor) (module (make-record-type-descriptor)
(define who 'make-record-type-descriptor) (define who 'make-record-type-descriptor)
(define (make-rtd-aux name parent uid sealed? opaque? fields) (define (make-rtd-aux name parent uid sealed? opaque? fields)
(make-rtd name (vector-length fields) parent sealed? opaque? uid fields)) (make-rtd name (vector-length fields) #f #f #f parent sealed? opaque? uid fields))
(define (convert-fields pfv sv) (define (convert-fields pfv sv)
(unless (vector? sv) (unless (vector? sv)
(error who "invalid fields argument ~s" sv)) (error who "invalid fields argument ~s" sv))
@ -151,6 +153,7 @@
(if (= i n) (if (= i n)
'() '()
(cons i (iota (+ i 1) n)))) (cons i (iota (+ i 1) n))))
(define (sym n) (define (sym n)
(string->symbol (format "v~s" n))) (string->symbol (format "v~s" n)))
@ -207,7 +210,7 @@
(let ([v (let ([v (vector-ref extended-constructors n)]) (let ([v (let ([v (vector-ref extended-constructors n)])
(or v (or v
(let ([v (make-vector (+ n 1) #f)]) (let ([v (make-vector (+ n 1) #f)])
(vector-set! extended-constructors n) (vector-set! extended-constructors n v)
v)))]) v)))])
(or (vector-ref v m) (or (vector-ref v m)
(let* ([vars-0m (map sym (iota 0 m))] (let* ([vars-0m (map sym (iota 0 m))]
@ -228,23 +231,33 @@
(unless (rcd? rcd) (unless (rcd? rcd)
(error who "~s is not a record constructor descriptor" rcd)) (error who "~s is not a record constructor descriptor" rcd))
(let ([rtd (rcd-rtd rcd)] (let ([rtd (rcd-rtd rcd)]
[prcd (rcd-prcd rcd)] [prcd (rcd-prcd rcd)])
[proc (rcd-proc rcd)]) (let ([c*
(cond (let ([n (rtd-size rtd)])
[(not prcd) (printf "base=~s\n" n)
(cond (let f ([c0 ((base-constructor-maker n) rtd)]
[(not proc) [prcd prcd]
((base-constructor-maker (rtd-size rtd)) rtd)] [n n])
[(rtd-parent rtd) => (cond
(lambda (parent) [(not prcd) c0]
(let ([n (rtd-size rtd)] [else
[m (rtd-size parent)]) (let ([r (rcd-rtd prcd)])
(let ([c0 ((base-constructor-maker n) rtd)]) (let ([m (rtd-size r)])
(let ([c1 ((extended-constructor-maker n m) c0)]) (printf "ext ~s ~s\n" n m)
(proc c1)))))] (f ((extended-constructor-maker n m) c0)
[else (rcd-prcd prcd)
(proc ((base-constructor-maker (rtd-size rtd)) rtd))])] m)))])))])
[else (error who "BUG22")]))) (let f ([rcd rcd])
(cond
[(not rcd) c*]
[else
(let ([c* (f (rcd-prcd rcd))])
(let ([proc (rcd-proc rcd)])
(if proc (proc c*) c*)))])))))
(define (record-accessor rtd k) (define (record-accessor rtd k)
(define who 'record-accessor) (define who 'record-accessor)