* added (rnrs records procedural) and (rnrs records inspection)
libraries
This commit is contained in:
parent
4eacb210eb
commit
54c1ef370a
BIN
src/ikarus.boot
BIN
src/ikarus.boot
Binary file not shown.
|
@ -887,7 +887,7 @@
|
|||
[(p) (mk-seq (mk-seq a0 a1) (make-constant #t))]
|
||||
[else (giveup)])))
|
||||
(giveup))]
|
||||
[($record-ref $record/rtd? $struct-ref $struct/rtd?)
|
||||
[($struct-ref $struct/rtd?)
|
||||
(or (and (fx= (length rand*) 2)
|
||||
(let ([a0 (car rand*)] [a1 (cadr rand*)])
|
||||
(case ctxt
|
||||
|
|
|
@ -1,22 +1,21 @@
|
|||
|
||||
(library (ikarus.r6rs.records.procedural)
|
||||
(library (ikarus records procedural)
|
||||
(export
|
||||
make-record-type-descriptor
|
||||
make-record-constructor-descriptor
|
||||
record-accessor record-mutator
|
||||
record-constructor record-predicate
|
||||
record? record-rtd record-type-name
|
||||
record-type-parent record-type-uid record-type-generative?
|
||||
record-type-sealed? record-type-opaque? record-type-field-names)
|
||||
make-record-type-descriptor record-type-descriptor?
|
||||
make-record-constructor-descriptor record-accessor
|
||||
record-mutator record-constructor record-predicate record?
|
||||
record-rtd record-type-name record-type-parent record-type-uid
|
||||
record-type-generative? record-type-sealed? record-type-opaque?
|
||||
record-type-field-names record-field-mutable?)
|
||||
(import
|
||||
(except (ikarus) record-constructor record-predicate set-rtd-printer!
|
||||
record? record-type-name record-type-parent
|
||||
record-type-field-names)
|
||||
(prefix (only (ikarus) set-rtd-printer!) core:)
|
||||
(ikarus system $records))
|
||||
(except (ikarus)
|
||||
record-constructor record-predicate record? record-type-name
|
||||
record-type-parent record-type-descriptor?
|
||||
record-type-field-names record-field-mutable?)
|
||||
(ikarus system $structs))
|
||||
|
||||
(define-record rtd
|
||||
(name size old-fields printer symbol parent sealed? opaque? uid fields))
|
||||
(define-struct rtd
|
||||
(name size old-fields printer-proc symbol parent sealed? opaque? uid fields))
|
||||
|
||||
(define rtd-alist '())
|
||||
(define (intern-rtd! uid rtd)
|
||||
|
@ -26,20 +25,19 @@
|
|||
[(assq uid rtd-alist) => cdr]
|
||||
[else #f]))
|
||||
|
||||
|
||||
(define (record-type-descriptor? x) (rtd? x))
|
||||
|
||||
(define (record? x)
|
||||
(and ($record? x)
|
||||
(let ([rtd ($record-rtd x)])
|
||||
(and ($struct? x)
|
||||
(let ([rtd ($struct-rtd x)])
|
||||
(and (rtd? rtd)
|
||||
(not (rtd-opaque? rtd))))))
|
||||
|
||||
(define (record-rtd x)
|
||||
(define (err x)
|
||||
(error 'record-rtd "~s is not a record" x))
|
||||
(if ($record? x)
|
||||
(let ([rtd ($record-rtd x)])
|
||||
(if ($struct? x)
|
||||
(let ([rtd ($struct-rtd x)])
|
||||
(if (rtd? rtd)
|
||||
(if (not (rtd-opaque? rtd))
|
||||
rtd
|
||||
|
@ -187,7 +185,7 @@
|
|||
(generate-rtd name parent uid sealed? opaque? fields)]
|
||||
[else (error who "~s is not a valid uid" uid)]))))
|
||||
|
||||
(define-record rcd (rtd prcd proc))
|
||||
(define-struct rcd (rtd prcd proc))
|
||||
(define (is-parent-of? prtd rtd)
|
||||
(let ([p (rtd-parent rtd)])
|
||||
(cond
|
||||
|
@ -229,11 +227,11 @@
|
|||
(unless (= (length args) n)
|
||||
(error 'record-constructor
|
||||
"incorrect number of arguments to constructor"))
|
||||
(let f ([r ($make-record rtd n)] [i 0] [args args])
|
||||
(let f ([r ($make-struct rtd n)] [i 0] [args args])
|
||||
(cond
|
||||
[(null? args) r]
|
||||
[else
|
||||
($record-set! r i (car args))
|
||||
($struct-set! r i (car args))
|
||||
(f r (add1 i) (cdr args))]))))))
|
||||
|
||||
(define base-constructors
|
||||
|
@ -247,10 +245,10 @@
|
|||
(let ([proc
|
||||
(eval `(lambda (rtd)
|
||||
(lambda ,vars
|
||||
($record rtd . ,vars)))
|
||||
($struct rtd . ,vars)))
|
||||
(environment
|
||||
'(ikarus)
|
||||
'(ikarus system $records)))])
|
||||
'(ikarus system $structs)))])
|
||||
(vector-set! base-constructors n proc)
|
||||
proc)))]
|
||||
[else (general-base-constructor n)]))
|
||||
|
@ -331,14 +329,14 @@
|
|||
(error who "~s is not a valid index" k))
|
||||
(lambda (x)
|
||||
(cond
|
||||
[($record/rtd? x rtd) ($record-ref x i)]
|
||||
[($record? x)
|
||||
(let ([xrtd ($record-rtd x)])
|
||||
[($struct/rtd? x rtd) ($struct-ref x i)]
|
||||
[($struct? x)
|
||||
(let ([xrtd ($struct-rtd x)])
|
||||
(unless (rtd? xrtd)
|
||||
(error who "~s is not of type ~s" x rtd))
|
||||
(let f ([prtd (rtd-parent xrtd)] [rtd rtd] [x x] [i i])
|
||||
(cond
|
||||
[(eq? prtd rtd) ($record-ref x i)]
|
||||
[(eq? prtd rtd) ($struct-ref x i)]
|
||||
[(not prtd)
|
||||
(error who "~s is not of type ~s" x rtd)]
|
||||
[else (f (rtd-parent prtd) rtd x i)])))]
|
||||
|
@ -359,14 +357,14 @@
|
|||
(error who "field ~s of ~s is not mutable" k rtd))
|
||||
(lambda (x v)
|
||||
(cond
|
||||
[($record/rtd? x rtd) ($record-set! x i v)]
|
||||
[($record? x)
|
||||
(let ([xrtd ($record-rtd x)])
|
||||
[($struct/rtd? x rtd) ($struct-set! x i v)]
|
||||
[($struct? x)
|
||||
(let ([xrtd ($struct-rtd x)])
|
||||
(unless (rtd? xrtd)
|
||||
(error who "~s is not of type ~s" x rtd))
|
||||
(let f ([prtd (rtd-parent xrtd)] [rtd rtd] [x x] [i i] [v v])
|
||||
(cond
|
||||
[(eq? prtd rtd) ($record-set! x i v)]
|
||||
[(eq? prtd rtd) ($struct-set! x i v)]
|
||||
[(not prtd)
|
||||
(error who "~s is not of type ~s" x rtd)]
|
||||
[else (f (rtd-parent prtd) rtd x i v)])))]
|
||||
|
@ -380,9 +378,9 @@
|
|||
[p (rtd-parent rtd)])
|
||||
(lambda (x)
|
||||
(cond
|
||||
[($record/rtd? x rtd) #t]
|
||||
[($record? x)
|
||||
(let ([xrtd ($record-rtd x)])
|
||||
[($struct/rtd? x rtd) #t]
|
||||
[($struct x)
|
||||
(let ([xrtd ($struct-rtd x)])
|
||||
(and (rtd? xrtd)
|
||||
(let f ([prtd (rtd-parent xrtd)] [rtd rtd])
|
||||
(cond
|
||||
|
@ -391,15 +389,27 @@
|
|||
[else (f (rtd-parent prtd) rtd)]))))]
|
||||
[else #f]))))
|
||||
|
||||
(core:set-rtd-printer! (type-descriptor rtd)
|
||||
|
||||
(define (record-field-mutable? rtd k)
|
||||
(define who 'record-field-mutable?)
|
||||
(unless (rtd? rtd)
|
||||
(error who "~s is not an rtd" rtd))
|
||||
(unless (and (fixnum? k) (fx>= k 0))
|
||||
(error who "~s is not a valid index" k))
|
||||
(let ([sz (rtd-size rtd)]
|
||||
[p (rtd-parent rtd)])
|
||||
(let ([i (if p (+ k (rtd-size p)) k)])
|
||||
(unless (fx< i sz)
|
||||
(error who "~s is not a valid index" k))
|
||||
(car (vector-ref (rtd-fields rtd) k)))))
|
||||
|
||||
(set-rtd-printer! (type-descriptor rtd)
|
||||
(lambda (x p)
|
||||
(display (format "#<record-type-descriptor ~s>" (rtd-name x)) p)))
|
||||
|
||||
(core:set-rtd-printer! (type-descriptor rcd)
|
||||
(set-rtd-printer! (type-descriptor rcd)
|
||||
(lambda (x p)
|
||||
(display (format "#<record-constructor-descriptor ~s>"
|
||||
(rtd-name (rcd-rtd x))) p)))
|
||||
|
||||
|
||||
|
||||
)
|
|
@ -38,6 +38,7 @@
|
|||
"ikarus.fixnums.ss"
|
||||
"ikarus.chars.ss"
|
||||
"ikarus.structs.ss"
|
||||
"ikarus.records.procedural.ss"
|
||||
"ikarus.strings.ss"
|
||||
"ikarus.transcoders.ss"
|
||||
"ikarus.date-string.ss"
|
||||
|
|
|
@ -0,0 +1,215 @@
|
|||
#!/usr/bin/env ikarus --r6rs-script
|
||||
|
||||
(import
|
||||
(ikarus)
|
||||
(rnrs records inspection)
|
||||
(rnrs records procedural))
|
||||
|
||||
|
||||
|
||||
(define rtd0
|
||||
(make-record-type-descriptor 'rtd0
|
||||
#f #f #f #f
|
||||
'#((immutable x0))))
|
||||
|
||||
(define rcd0-default
|
||||
(make-record-constructor-descriptor rtd0 #f #f))
|
||||
|
||||
(define make-t0-default (record-constructor rcd0-default))
|
||||
(define t0? (record-predicate rtd0))
|
||||
(define t0-x0 (record-accessor rtd0 0))
|
||||
|
||||
(define (test0)
|
||||
(let ([x (make-t0-default 5)])
|
||||
(printf "x=~s\n" x)
|
||||
(assert (not (record-field-mutable? rtd0 0)))
|
||||
(assert (record? x))
|
||||
(assert (t0? x))
|
||||
(assert (= (t0-x0 x) 5))))
|
||||
|
||||
(define rtd1
|
||||
(make-record-type-descriptor 'rtd1
|
||||
rtd0 #f #f #f
|
||||
'#((immutable y0) (mutable y1))))
|
||||
|
||||
(define rcd1-default
|
||||
(make-record-constructor-descriptor rtd1 #f #f))
|
||||
(define make-t1-default (record-constructor rcd1-default))
|
||||
(define t1? (record-predicate rtd1))
|
||||
(define t1-y0 (record-accessor rtd1 0))
|
||||
(define t1-y1 (record-accessor rtd1 1))
|
||||
|
||||
(define (test1)
|
||||
(let ([x (make-t1-default 5 1 2)])
|
||||
(assert (record-field-mutable? rtd1 1))
|
||||
(assert (record? x))
|
||||
(assert (t1? x))
|
||||
(assert (t0? x))
|
||||
(assert (= (t0-x0 x) 5))
|
||||
(assert (= (t1-y0 x) 1))
|
||||
(assert (= (t1-y1 x) 2))))
|
||||
|
||||
(define rcd0-17
|
||||
(make-record-constructor-descriptor rtd0 #f
|
||||
(lambda (p)
|
||||
(lambda ()
|
||||
(p 17)))))
|
||||
|
||||
(define make-rcd0-17 (record-constructor rcd0-17))
|
||||
|
||||
(define (test2)
|
||||
(let ([x (make-rcd0-17)])
|
||||
(assert (record? x))
|
||||
(assert (t0? x))
|
||||
(assert (not (t1? x)))
|
||||
(assert (= (t0-x0 x) 17))))
|
||||
|
||||
(define rcd1-17-rev
|
||||
(make-record-constructor-descriptor rtd1 rcd0-17
|
||||
(lambda (p)
|
||||
(lambda (y0 y1)
|
||||
((p) y1 y0)))))
|
||||
|
||||
(define make-rcd1-17-rev (record-constructor rcd1-17-rev))
|
||||
|
||||
(define (test3)
|
||||
(let ([x (make-rcd1-17-rev 1 2)])
|
||||
(assert (record? x))
|
||||
(assert (t1? x))
|
||||
(assert (t0? x))
|
||||
(assert (= (t0-x0 x) 17))
|
||||
(assert (= (t1-y0 x) 2))
|
||||
(assert (= (t1-y1 x) 1))))
|
||||
|
||||
(define rcd1-17-default
|
||||
(make-record-constructor-descriptor rtd1 rcd0-17
|
||||
(lambda (p) (p))))
|
||||
|
||||
(define make-rcd1-17-default (record-constructor rcd1-17-default))
|
||||
|
||||
(define (test4)
|
||||
(let ([x (make-rcd1-17-default 1 2)])
|
||||
(assert (record? x))
|
||||
(assert (t1? x))
|
||||
(assert (t0? x))
|
||||
(assert (= (t0-x0 x) 17))
|
||||
(assert (= (t1-y0 x) 1))
|
||||
(assert (= (t1-y1 x) 2))))
|
||||
|
||||
(define (test5)
|
||||
(define :point
|
||||
(make-record-type-descriptor 'point
|
||||
#f #f #f #f
|
||||
'#((mutable x) (mutable y))))
|
||||
|
||||
(define :point-cd
|
||||
(make-record-constructor-descriptor :point #f #f))
|
||||
|
||||
(define make-point (record-constructor :point-cd))
|
||||
(define point? (record-predicate :point))
|
||||
(define point-x (record-accessor :point 0))
|
||||
(define point-y (record-accessor :point 1))
|
||||
(define set-point-x! (record-mutator :point 0))
|
||||
(define set-point-y! (record-mutator :point 1))
|
||||
|
||||
(define :point2
|
||||
(make-record-type-descriptor 'point2
|
||||
:point #f #f #f
|
||||
'#((mutable x) (mutable y))))
|
||||
(define make-point2
|
||||
(record-constructor
|
||||
(make-record-constructor-descriptor :point2 #f #f)))
|
||||
(define point2? (record-predicate :point2))
|
||||
(define point2-xx (record-accessor :point2 0))
|
||||
(define point2-yy (record-accessor :point2 1))
|
||||
|
||||
|
||||
|
||||
(define :point-cd/abs
|
||||
(make-record-constructor-descriptor :point #f
|
||||
(lambda (new)
|
||||
(lambda (x y)
|
||||
(printf "point/abs constr ~s ~s\n" x y)
|
||||
(let ([r (new (abs x) (abs y))])
|
||||
(printf "point/abs r=~s\n" r)
|
||||
r)))))
|
||||
|
||||
(define make-point/abs (record-constructor :point-cd/abs))
|
||||
|
||||
(define :cpoint
|
||||
(make-record-type-descriptor 'cpoint :point #f #f #f
|
||||
'#((mutable rgb))))
|
||||
|
||||
(define :cpoint-cd
|
||||
(make-record-constructor-descriptor :cpoint :point-cd
|
||||
(lambda (p)
|
||||
(lambda (x y c)
|
||||
(printf "cpoint constr ~s ~s ~s\n" x y c)
|
||||
(let ([r ((p x y) (color->rgb c))])
|
||||
(printf "cpoint r=~s\n" r)
|
||||
r)))))
|
||||
|
||||
(define make-cpoint
|
||||
(record-constructor :cpoint-cd))
|
||||
|
||||
(define (color->rgb c) (cons 'rgb c))
|
||||
|
||||
(define cpoint-rgb (record-accessor :cpoint 0))
|
||||
|
||||
(define cpoint/abs-cd
|
||||
(make-record-constructor-descriptor :cpoint :point-cd/abs
|
||||
(lambda (p)
|
||||
(lambda (x y c)
|
||||
(printf "cpoint/abs constr ~s ~s ~s\n" x y c)
|
||||
(let ([r ((p x y) (color->rgb c))])
|
||||
(printf "cpointabs r=~s\n" r)
|
||||
r)))))
|
||||
|
||||
(define make-cpoint/abs
|
||||
(record-constructor cpoint/abs-cd))
|
||||
|
||||
(printf "cpoint/abs-cd=~s\n" cpoint/abs-cd)
|
||||
|
||||
(let ()
|
||||
(define p1 (make-point 1 2))
|
||||
(assert (point? p1))
|
||||
(assert (= (point-x p1) 1))
|
||||
(assert (= (point-y p1) 2))
|
||||
(set-point-x! p1 5)
|
||||
(assert (= (point-x p1) 5))
|
||||
(assert (= (point-y p1) 2)))
|
||||
|
||||
(let ()
|
||||
(define p2 (make-point2 1 2 3 4))
|
||||
(assert (point? p2))
|
||||
(assert (= (point-x p2) 1))
|
||||
(assert (= (point-y p2) 2))
|
||||
(assert (= (point2-xx p2) 3))
|
||||
(assert (= (point2-yy p2) 4)))
|
||||
|
||||
|
||||
(let ()
|
||||
(assert (= (point-x (make-point/abs -1 -2)) 1))
|
||||
(assert (= (point-y (make-point/abs -1 -2)) 2)))
|
||||
|
||||
(let ()
|
||||
(assert (equal? (cpoint-rgb (make-cpoint -1 -3 'red)) '(rgb . red)))
|
||||
(assert (equal? (cpoint-rgb (make-cpoint/abs -1 -3 'red)) '(rgb . red)))
|
||||
(assert (= (point-x (make-cpoint -1 -3 'red)) -1))
|
||||
(assert (= (point-x (make-cpoint/abs -1 -3 'red)) 1))
|
||||
)
|
||||
)
|
||||
|
||||
|
||||
(test0)
|
||||
(test1)
|
||||
(test2)
|
||||
(test3)
|
||||
(test4)
|
||||
(test5)
|
||||
(printf "rtd0=~s\n" rtd0)
|
||||
(printf "rcd0=~s\n" rcd0-default)
|
||||
(printf "fields of ~s are ~s\n" rtd1 (record-type-field-names rtd1))
|
||||
(printf "happy happy joy joy\n")
|
||||
|
||||
|
|
@ -695,7 +695,7 @@
|
|||
[file-exists? C fi]
|
||||
[delete-file C fi]
|
||||
;;;
|
||||
[define-record-type X rs]
|
||||
[define-record-type S rs]
|
||||
[fields C rs]
|
||||
[immutable C rs]
|
||||
[mutable C rs]
|
||||
|
@ -703,29 +703,29 @@
|
|||
[parent C rs]
|
||||
[parent-rtd C rs]
|
||||
[protocol C rs]
|
||||
[record-constructor-descriptor X rs]
|
||||
[record-type-descriptor X rs]
|
||||
[record-constructor-descriptor S rs]
|
||||
[record-type-descriptor S rs]
|
||||
[sealed C rs]
|
||||
[nongenerative C rs]
|
||||
;;;
|
||||
[record-field-mutable? X ri]
|
||||
[record-rtd X ri]
|
||||
[record-type-field-names X ri]
|
||||
[record-type-generative? X ri]
|
||||
[record-type-name X ri]
|
||||
[record-type-opaque? X ri]
|
||||
[record-type-parent X ri]
|
||||
[record-type-sealed? X ri]
|
||||
[record-type-uid X ri]
|
||||
[record? X ri]
|
||||
[record-field-mutable? C ri]
|
||||
[record-rtd C ri]
|
||||
[record-type-field-names C ri]
|
||||
[record-type-generative? C ri]
|
||||
[record-type-name C ri]
|
||||
[record-type-opaque? C ri]
|
||||
[record-type-parent C ri]
|
||||
[record-type-sealed? C ri]
|
||||
[record-type-uid C ri]
|
||||
[record? C ri]
|
||||
;;;
|
||||
[make-record-constructor-descriptor X rp]
|
||||
[make-record-type-descriptor X rp]
|
||||
[record-accessor X rp]
|
||||
[record-constructor X rp]
|
||||
[record-mutator X rp]
|
||||
[record-predicate X rp]
|
||||
[record-type-descriptor? X rp]
|
||||
[make-record-constructor-descriptor C rp]
|
||||
[make-record-type-descriptor C rp]
|
||||
[record-accessor C rp]
|
||||
[record-constructor C rp]
|
||||
[record-mutator C rp]
|
||||
[record-predicate C rp]
|
||||
[record-type-descriptor? C rp]
|
||||
;;;
|
||||
[bound-identifier=? C sc]
|
||||
[datum->syntax C sc]
|
||||
|
|
Loading…
Reference in New Issue