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)
(if (not prcd) ;;; base
(lambda (f*)
(let ([v (lambda flds
(let ([a-record-constructor
(lambda flds
(let ([n (rtd-size main-rtd)])
(unless (= (length flds) size)
(error 'record-constructor
@ -272,22 +273,28 @@
[else
($struct-set! r i (car flds))
(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)]
[sz (rtd-size (rcd-rtd prcd))])
(let ([p (constructor main-rtd sz pprcd (rcd-proc prcd))]
[n (- size sz)]
[proto
[protocol
(if proto
proto
(lambda (new)
(let ([a-record-constructor
(lambda all-fields
(let-values ([(parent-fields myfields)
(split all-fields
(- (length all-fields) (- size sz)))])
(apply (apply new parent-fields) myfields)))))])
(- (length all-fields)
(- size sz)))])
(apply (apply new parent-fields)
myfields)))])
a-record-constructor)))])
(lambda (f*)
(proto
(protocol
(lambda fmls
(lambda flds
(unless (= (length flds) n)
@ -313,6 +320,7 @@
(let ([i (if p (+ k (rtd-size p)) k)])
(unless (fx< i sz)
(error who "not a valid index" k))
(let ([a-record-accessor
(lambda (x)
(cond
[($struct/rtd? x rtd) ($struct-ref x i)]
@ -326,7 +334,8 @@
[(not prtd)
(error who "invalid type" x rtd)]
[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 who 'record-mutator)
@ -341,6 +350,7 @@
(error who "not a valid index" k))
(unless (car (vector-ref (rtd-fields rtd) k))
(error who "field is not mutable" k rtd))
(let ([a-record-mutator
(lambda (x v)
(cond
[($struct/rtd? x rtd) ($struct-set! x i v)]
@ -354,7 +364,8 @@
[(not prtd)
(error who "invalid type" x rtd)]
[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 who 'record-predicate)
@ -362,6 +373,7 @@
(error who "not an rtd" rtd))
(let ([sz (rtd-size rtd)]
[p (rtd-parent rtd)])
(let ([a-record-predicate
(lambda (x)
(cond
[($struct/rtd? x rtd) #t]
@ -373,7 +385,8 @@
[(eq? prtd rtd) #t]
[(not prtd) #f]
[else (f (rtd-parent prtd) rtd)]))))]
[else #f]))))
[else #f]))])
a-record-predicate)))
(define (record-field-mutable? rtd k)

2
scheme/last-revision
View File

@ -1 +1 @@
1096
1097