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

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

@ -257,7 +257,8 @@
(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
(lambda flds
(let ([n (rtd-size main-rtd)]) (let ([n (rtd-size main-rtd)])
(unless (= (length flds) size) (unless (= (length flds) size)
(error 'record-constructor (error 'record-constructor
@ -272,22 +273,28 @@
[else [else
($struct-set! r i (car flds)) ($struct-set! r i (car flds))
(f (add1 i) r (cdr flds) f*)])))))]) (f (add1 i) r (cdr flds) f*)])))))])
(if proto (proto v) v))) (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)
(let ([a-record-constructor
(lambda all-fields (lambda all-fields
(let-values ([(parent-fields myfields) (let-values ([(parent-fields myfields)
(split all-fields (split all-fields
(- (length all-fields) (- size sz)))]) (- (length all-fields)
(apply (apply new parent-fields) myfields)))))]) (- 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,6 +320,7 @@
(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))
(let ([a-record-accessor
(lambda (x) (lambda (x)
(cond (cond
[($struct/rtd? x rtd) ($struct-ref x i)] [($struct/rtd? x rtd) ($struct-ref x i)]
@ -326,7 +334,8 @@
[(not prtd) [(not prtd)
(error who "invalid type" x rtd)] (error who "invalid type" x rtd)]
[else (f (rtd-parent prtd) rtd x i)])))] [else (f (rtd-parent prtd) rtd x i)])))]
[else (error who "invalid type" x rtd)]))))) [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,6 +350,7 @@
(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))
(let ([a-record-mutator
(lambda (x v) (lambda (x v)
(cond (cond
[($struct/rtd? x rtd) ($struct-set! x i v)] [($struct/rtd? x rtd) ($struct-set! x i v)]
@ -354,7 +364,8 @@
[(not prtd) [(not prtd)
(error who "invalid type" x rtd)] (error who "invalid type" x rtd)]
[else (f (rtd-parent prtd) rtd x i v)])))] [else (f (rtd-parent prtd) rtd x i v)])))]
[else (error who "invalid type" x rtd)]))))) [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,6 +373,7 @@
(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)])
(let ([a-record-predicate
(lambda (x) (lambda (x)
(cond (cond
[($struct/rtd? x rtd) #t] [($struct/rtd? x rtd) #t]
@ -373,7 +385,8 @@
[(eq? prtd rtd) #t] [(eq? prtd rtd) #t]
[(not prtd) #f] [(not prtd) #f]
[else (f (rtd-parent prtd) rtd)]))))] [else (f (rtd-parent prtd) rtd)]))))]
[else #f])))) [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