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

Small improvement on the situation in bug 163984: Wrong name on 

define-record-type proceedures.

Record constructors are now called "a-record-constructor"
Record predicates are called "a-record-predicate"
Record accessors are called "a-record-accessor"
Record mutators are called "a-record-mutator"
This commit is contained in:
Abdulaziz Ghuloum 2007-11-21 01:24:13 -05:00
parent 0644542565
commit 888251df70
2 changed files with 75 additions and 62 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -257,37 +257,44 @@
(define (constructor main-rtd size prcd proto) (define (constructor main-rtd size prcd proto)
(if (not prcd) ;;; base (if (not prcd) ;;; base
(lambda (f*) (lambda (f*)
(let ([v (lambda flds (let ([a-record-constructor
(let ([n (rtd-size main-rtd)]) (lambda flds
(unless (= (length flds) size) (let ([n (rtd-size main-rtd)])
(error 'record-constructor (unless (= (length flds) size)
"main expecting args, got" n flds)) (error 'record-constructor
(let ([r ($make-struct main-rtd n)]) "main expecting args, got" n flds))
(let f ([i 0] [r r] [flds flds] [f* f*]) (let ([r ($make-struct main-rtd n)])
(cond (let f ([i 0] [r r] [flds flds] [f* f*])
[(null? flds) (cond
(if (null? f*) [(null? flds)
r (if (null? f*)
(f i r (car f*) (cdr f*)))] r
[else (f i r (car f*) (cdr f*)))]
($struct-set! r i (car flds)) [else
(f (add1 i) r (cdr flds) f*)])))))]) ($struct-set! r i (car flds))
(if proto (proto v) v))) (f (add1 i) r (cdr flds) f*)])))))])
(if proto
(proto a-record-constructor)
a-record-constructor)))
(let ([pprcd (rcd-prcd prcd)] (let ([pprcd (rcd-prcd prcd)]
[sz (rtd-size (rcd-rtd prcd))]) [sz (rtd-size (rcd-rtd prcd))])
(let ([p (constructor main-rtd sz pprcd (rcd-proc prcd))] (let ([p (constructor main-rtd sz pprcd (rcd-proc prcd))]
[n (- size sz)] [n (- size sz)]
[proto [protocol
(if proto (if proto
proto proto
(lambda (new) (lambda (new)
(lambda all-fields (let ([a-record-constructor
(let-values ([(parent-fields myfields) (lambda all-fields
(split all-fields (let-values ([(parent-fields myfields)
(- (length all-fields) (- size sz)))]) (split all-fields
(apply (apply new parent-fields) myfields)))))]) (- (length all-fields)
(- size sz)))])
(apply (apply new parent-fields)
myfields)))])
a-record-constructor)))])
(lambda (f*) (lambda (f*)
(proto (protocol
(lambda fmls (lambda fmls
(lambda flds (lambda flds
(unless (= (length flds) n) (unless (= (length flds) n)
@ -313,20 +320,22 @@
(let ([i (if p (+ k (rtd-size p)) k)]) (let ([i (if p (+ k (rtd-size p)) k)])
(unless (fx< i sz) (unless (fx< i sz)
(error who "not a valid index" k)) (error who "not a valid index" k))
(lambda (x) (let ([a-record-accessor
(cond (lambda (x)
[($struct/rtd? x rtd) ($struct-ref x i)]
[($struct? x)
(let ([xrtd ($struct-rtd x)])
(unless (rtd? xrtd)
(error who "invalid type" x rtd))
(let f ([prtd (rtd-parent xrtd)] [rtd rtd] [x x] [i i])
(cond (cond
[(eq? prtd rtd) ($struct-ref x i)] [($struct/rtd? x rtd) ($struct-ref x i)]
[(not prtd) [($struct? x)
(error who "invalid type" x rtd)] (let ([xrtd ($struct-rtd x)])
[else (f (rtd-parent prtd) rtd x i)])))] (unless (rtd? xrtd)
[else (error who "invalid type" x rtd)]))))) (error who "invalid type" x rtd))
(let f ([prtd (rtd-parent xrtd)] [rtd rtd] [x x] [i i])
(cond
[(eq? prtd rtd) ($struct-ref x i)]
[(not prtd)
(error who "invalid type" x rtd)]
[else (f (rtd-parent prtd) rtd x i)])))]
[else (error who "invalid type" x rtd)]))])
a-record-accessor))))
(define (record-mutator rtd k) (define (record-mutator rtd k)
(define who 'record-mutator) (define who 'record-mutator)
@ -341,20 +350,22 @@
(error who "not a valid index" k)) (error who "not a valid index" k))
(unless (car (vector-ref (rtd-fields rtd) k)) (unless (car (vector-ref (rtd-fields rtd) k))
(error who "field is not mutable" k rtd)) (error who "field is not mutable" k rtd))
(lambda (x v) (let ([a-record-mutator
(cond (lambda (x v)
[($struct/rtd? x rtd) ($struct-set! x i v)]
[($struct? x)
(let ([xrtd ($struct-rtd x)])
(unless (rtd? xrtd)
(error who "invalid type" x rtd))
(let f ([prtd (rtd-parent xrtd)] [rtd rtd] [x x] [i i] [v v])
(cond (cond
[(eq? prtd rtd) ($struct-set! x i v)] [($struct/rtd? x rtd) ($struct-set! x i v)]
[(not prtd) [($struct? x)
(error who "invalid type" x rtd)] (let ([xrtd ($struct-rtd x)])
[else (f (rtd-parent prtd) rtd x i v)])))] (unless (rtd? xrtd)
[else (error who "invalid type" x rtd)]))))) (error who "invalid type" x rtd))
(let f ([prtd (rtd-parent xrtd)] [rtd rtd] [x x] [i i] [v v])
(cond
[(eq? prtd rtd) ($struct-set! x i v)]
[(not prtd)
(error who "invalid type" x rtd)]
[else (f (rtd-parent prtd) rtd x i v)])))]
[else (error who "invalid type" x rtd)]))])
a-record-mutator))))
(define (record-predicate rtd) (define (record-predicate rtd)
(define who 'record-predicate) (define who 'record-predicate)
@ -362,18 +373,20 @@
(error who "not an rtd" rtd)) (error who "not an rtd" rtd))
(let ([sz (rtd-size rtd)] (let ([sz (rtd-size rtd)]
[p (rtd-parent rtd)]) [p (rtd-parent rtd)])
(lambda (x) (let ([a-record-predicate
(cond (lambda (x)
[($struct/rtd? x rtd) #t] (cond
[($struct? x) [($struct/rtd? x rtd) #t]
(let ([xrtd ($struct-rtd x)]) [($struct? x)
(and (rtd? xrtd) (let ([xrtd ($struct-rtd x)])
(let f ([prtd (rtd-parent xrtd)] [rtd rtd]) (and (rtd? xrtd)
(cond (let f ([prtd (rtd-parent xrtd)] [rtd rtd])
[(eq? prtd rtd) #t] (cond
[(not prtd) #f] [(eq? prtd rtd) #t]
[else (f (rtd-parent prtd) rtd)]))))] [(not prtd) #f]
[else #f])))) [else (f (rtd-parent prtd) rtd)]))))]
[else #f]))])
a-record-predicate)))
(define (record-field-mutable? rtd k) (define (record-field-mutable? rtd k)

2
scheme/last-revision
View File

@ -1 +1 @@
1096 1097