2007-06-27 06:15:51 -04:00
|
|
|
|
|
|
|
(library (ikarus.r6rs.records.procedural)
|
|
|
|
(export
|
|
|
|
make-record-type-descriptor
|
|
|
|
make-record-constructor-descriptor
|
|
|
|
record-accessor record-mutator
|
|
|
|
record-constructor record-predicate)
|
|
|
|
(import
|
|
|
|
(except (ikarus) record-constructor record-predicate)
|
|
|
|
(ikarus system $records))
|
|
|
|
|
|
|
|
(define-record rtd (name size parent sealed? opaque? uid fields))
|
|
|
|
(define rtd-alist '())
|
|
|
|
(define (intern-rtd! uid rtd)
|
|
|
|
(set! rtd-alist (cons (cons uid rtd) rtd-alist)))
|
|
|
|
(define (lookup-rtd uid)
|
|
|
|
(cond
|
|
|
|
[(assq uid rtd-alist) => cdr]
|
|
|
|
[else #f]))
|
|
|
|
|
|
|
|
|
|
|
|
(define (record-type-descriptor? x) (rtd? x))
|
|
|
|
|
|
|
|
(module (make-record-type-descriptor)
|
|
|
|
(define who 'make-record-type-descriptor)
|
|
|
|
(define (make-rtd-aux name parent uid sealed? opaque? fields)
|
|
|
|
(make-rtd name (vector-length fields) parent sealed? opaque? uid fields))
|
|
|
|
(define (convert-fields pfv sv)
|
|
|
|
(unless (vector? sv)
|
|
|
|
(error who "invalid fields argument ~s" sv))
|
|
|
|
(let ([n1 (vector-length pfv)]
|
|
|
|
[n2 (vector-length sv)])
|
|
|
|
(let ([v (make-vector (+ n1 n2))])
|
|
|
|
(let f ([i 0])
|
|
|
|
(unless (= i n1)
|
|
|
|
(vector-set! v i (vector-ref pfv i))
|
|
|
|
(f (add1 i))))
|
|
|
|
(let f ([i 0])
|
|
|
|
(unless (= i n2)
|
|
|
|
(let ([x (vector-ref sv i)])
|
|
|
|
(if (pair? x)
|
|
|
|
(let ([m/u (car x)] [x (cdr x)])
|
|
|
|
(if (pair? x)
|
|
|
|
(let ([name (car x)])
|
|
|
|
(unless (and (null? (cdr x)) (symbol? name))
|
|
|
|
(error who "invalid fields argument ~s" sv))
|
|
|
|
(vector-set! v (+ i n1)
|
|
|
|
(cons (case m/u
|
|
|
|
[(mutable) #t]
|
|
|
|
[(immutable) #f]
|
|
|
|
[else
|
|
|
|
(error who "invalid fields argument ~s" sv)])
|
|
|
|
name)))
|
|
|
|
(error who "invalid fields argument ~s" sv)))
|
|
|
|
(error who "invalid fields argument ~s" sv)))
|
|
|
|
(f (add1 i))))
|
|
|
|
v)))
|
|
|
|
(define generate-rtd
|
|
|
|
(lambda (name parent uid sealed? opaque? fields)
|
|
|
|
(cond
|
|
|
|
[(rtd? parent)
|
|
|
|
(when (rtd-sealed? parent)
|
|
|
|
(error who "cannot extend sealed parent ~s" parent))
|
|
|
|
(make-rtd-aux name parent uid sealed?
|
|
|
|
(or opaque? (rtd-opaque? parent))
|
|
|
|
(convert-fields (rtd-fields parent) fields))]
|
|
|
|
[(eqv? parent #f)
|
|
|
|
(make-rtd-aux name parent uid sealed? opaque?
|
|
|
|
(convert-fields '#() fields))]
|
|
|
|
[else (error who "~s is not a valid parent" parent)])))
|
|
|
|
(define (same-fields-as-rtd? fields rtd)
|
|
|
|
(let* ([fv (rtd-fields rtd)]
|
|
|
|
[n (vector-length fv)])
|
|
|
|
(and (vector? fields)
|
|
|
|
(= (vector-length fields) n)
|
|
|
|
(let f ([i 0])
|
|
|
|
(or (= i n)
|
|
|
|
(let ([a (vector-ref fields i)]
|
|
|
|
[b (vector-ref fv i)])
|
|
|
|
(and
|
|
|
|
(pair? a)
|
|
|
|
(case (car a)
|
|
|
|
[(mutable) (eqv? (car b) #t)]
|
|
|
|
[(immutable) (eqv? (car b) #f)]
|
|
|
|
[else #f])
|
|
|
|
(let ([a (cdr a)])
|
|
|
|
(and (pair? a)
|
|
|
|
(null? (cdr a))
|
|
|
|
(eq? (car a) (cdr b))))
|
|
|
|
(f (+ i 1)))))))))
|
|
|
|
(define make-nongenerative-rtd
|
|
|
|
(lambda (name parent uid sealed? opaque? fields)
|
|
|
|
(cond
|
|
|
|
[(lookup-rtd uid) =>
|
|
|
|
(lambda (rtd)
|
|
|
|
(unless
|
|
|
|
(and (eqv? name (rtd-name rtd))
|
|
|
|
(eqv? parent (rtd-parent rtd))
|
|
|
|
(eqv? sealed? (rtd-sealed? rtd))
|
|
|
|
(eqv? opaque? (rtd-opaque? rtd))
|
|
|
|
(same-fields-as-rtd? fields rtd))
|
|
|
|
(error who "invalid arguments"))
|
|
|
|
rtd)]
|
|
|
|
[else
|
|
|
|
(let ([rtd (generate-rtd name parent uid sealed? opaque? fields)])
|
|
|
|
(intern-rtd! uid rtd)
|
|
|
|
rtd)])))
|
|
|
|
(define make-record-type-descriptor
|
|
|
|
(lambda (name parent uid sealed? opaque? fields)
|
|
|
|
(unless (symbol? name)
|
|
|
|
(error who "~s is not a valid record type name" name))
|
|
|
|
(unless (boolean? sealed?)
|
|
|
|
(error who "~s is not a valid sealed? argument" sealed?))
|
|
|
|
(unless (boolean? opaque?)
|
|
|
|
(error who "~s is not a valid opaque? argument" opaque?))
|
|
|
|
(cond
|
|
|
|
[(symbol? uid)
|
|
|
|
(make-nongenerative-rtd name parent uid sealed? opaque? fields)]
|
|
|
|
[(eqv? uid #f)
|
|
|
|
(generate-rtd name parent uid sealed? opaque? fields)]
|
|
|
|
[else (error who "~s is not a valid uid" uid)]))))
|
|
|
|
|
2007-07-05 04:48:40 -04:00
|
|
|
(define-record rcd (rtd prcd proc))
|
|
|
|
(define (is-parent-of? prtd rtd)
|
|
|
|
(let ([p (rtd-parent rtd)])
|
|
|
|
(cond
|
|
|
|
[(eq? p prtd) #t]
|
|
|
|
[(not p) #f]
|
|
|
|
[else (is-parent-of? prtd p)])))
|
|
|
|
|
2007-06-27 06:15:51 -04:00
|
|
|
(define make-record-constructor-descriptor
|
2007-07-05 04:48:40 -04:00
|
|
|
(lambda (rtd prcd protocol)
|
2007-06-27 06:15:51 -04:00
|
|
|
(define who 'make-record-constructor-descriptor)
|
|
|
|
(unless (rtd? rtd)
|
2007-07-05 04:48:40 -04:00
|
|
|
(error who "~s is not a record type descriptor" rtd))
|
|
|
|
(unless (or (not protocol) (procedure? protocol))
|
|
|
|
(error who "invalid protocol ~s" protocol))
|
|
|
|
(let ([prtd (rtd-parent rtd)])
|
|
|
|
(cond
|
|
|
|
[(not prcd)
|
|
|
|
(make-rcd rtd #f protocol)]
|
|
|
|
[(rcd? prcd)
|
|
|
|
(unless (is-parent-of? (rcd-rtd prcd) rtd)
|
|
|
|
(error who "descriptor ~s does not apply to ~s"
|
|
|
|
prcd rtd))
|
|
|
|
(make-rcd rtd prcd protocol)]
|
|
|
|
[else (error who "~s is not a valid record constructor
|
|
|
|
descriptor" prcd)]))))
|
2007-06-27 06:15:51 -04:00
|
|
|
|
|
|
|
(define (iota i n)
|
|
|
|
(if (= i n)
|
|
|
|
'()
|
|
|
|
(cons i (iota (+ i 1) n))))
|
|
|
|
(define (sym n)
|
|
|
|
(string->symbol (format "v~s" n)))
|
|
|
|
|
2007-07-05 04:48:40 -04:00
|
|
|
(define general-base-constructor
|
|
|
|
(lambda (n)
|
|
|
|
(lambda (rtd)
|
|
|
|
(lambda args
|
|
|
|
(unless (= (length args) n)
|
|
|
|
(error 'record-constructor
|
|
|
|
"incorrect number of arguments to constructor"))
|
|
|
|
(let f ([r ($make-record rtd n)] [i 0] [args args])
|
|
|
|
(cond
|
|
|
|
[(null? args) r]
|
|
|
|
[else
|
|
|
|
($record-set! r i (car args))
|
|
|
|
(f r (add1 i) (cdr args))]))))))
|
2007-06-27 06:15:51 -04:00
|
|
|
|
2007-07-05 04:48:40 -04:00
|
|
|
(define base-constructors
|
|
|
|
'#(#f #f #f #f #f #f #f #f #f #f #f #f))
|
2007-06-27 06:15:51 -04:00
|
|
|
|
2007-07-05 04:48:40 -04:00
|
|
|
(define (base-constructor-maker n)
|
|
|
|
(cond
|
|
|
|
[(< n (vector-length base-constructors))
|
|
|
|
(or (vector-ref base-constructors n)
|
|
|
|
(let ([vars (map sym (iota 0 n))])
|
|
|
|
(let ([proc
|
|
|
|
(eval `(lambda (rtd)
|
|
|
|
(lambda ,vars
|
|
|
|
($record rtd . ,vars)))
|
|
|
|
(environment
|
|
|
|
'(ikarus)
|
|
|
|
'(ikarus system $records)))])
|
|
|
|
(vector-set! base-constructors n proc)
|
|
|
|
proc)))]
|
|
|
|
[else (general-base-constructor n)]))
|
|
|
|
|
|
|
|
(define extended-constructors
|
|
|
|
'#(#f #f #f #f #f #f #f #f #f #f #f #f))
|
|
|
|
|
|
|
|
(define general-extended-constructor
|
|
|
|
(lambda (n m)
|
|
|
|
(lambda (record-constructor)
|
|
|
|
(lambda args-n
|
|
|
|
(unless (= (length args-n) n)
|
|
|
|
(error 'record-constructor "incorrect arguments"))
|
|
|
|
(lambda args-m
|
|
|
|
(unless (= (length args-m) m)
|
|
|
|
(error 'record-constructor "incorrect arguments"))
|
|
|
|
(apply record-constructor (append args-n args-m)))))))
|
|
|
|
|
|
|
|
(define (extended-constructor-maker n m)
|
|
|
|
(cond
|
|
|
|
[(< n (vector-length extended-constructors))
|
|
|
|
(let ([v (let ([v (vector-ref extended-constructors n)])
|
|
|
|
(or v
|
|
|
|
(let ([v (make-vector (+ n 1) #f)])
|
|
|
|
(vector-set! extended-constructors n)
|
|
|
|
v)))])
|
|
|
|
(or (vector-ref v m)
|
|
|
|
(let* ([vars-0m (map sym (iota 0 m))]
|
|
|
|
[vars-mn (map sym (iota m n))]
|
|
|
|
[proc
|
|
|
|
(eval
|
|
|
|
`(lambda (record-constructor)
|
|
|
|
(lambda ,vars-0m
|
|
|
|
(lambda ,vars-mn
|
|
|
|
(record-constructor ,@vars-0m ,@vars-mn))))
|
|
|
|
(environment '(ikarus)))])
|
|
|
|
(vector-set! v m proc)
|
|
|
|
proc)))]
|
|
|
|
[else (general-extended-constructor n m)]))
|
2007-06-27 06:15:51 -04:00
|
|
|
|
|
|
|
(define (record-constructor rcd)
|
|
|
|
(define who 'record-constructor)
|
|
|
|
(unless (rcd? rcd)
|
|
|
|
(error who "~s is not a record constructor descriptor" rcd))
|
|
|
|
(let ([rtd (rcd-rtd rcd)]
|
2007-07-05 04:48:40 -04:00
|
|
|
[prcd (rcd-prcd rcd)]
|
2007-06-27 06:15:51 -04:00
|
|
|
[proc (rcd-proc rcd)])
|
|
|
|
(cond
|
2007-07-05 04:48:40 -04:00
|
|
|
[(not prcd)
|
2007-06-27 06:15:51 -04:00
|
|
|
(cond
|
|
|
|
[(not proc)
|
2007-07-05 04:48:40 -04:00
|
|
|
((base-constructor-maker (rtd-size rtd)) rtd)]
|
|
|
|
[(rtd-parent rtd) =>
|
|
|
|
(lambda (parent)
|
|
|
|
(let ([n (rtd-size rtd)]
|
|
|
|
[m (rtd-size parent)])
|
|
|
|
(let ([c0 ((base-constructor-maker n) rtd)])
|
|
|
|
(let ([c1 ((extended-constructor-maker n m) c0)])
|
|
|
|
(proc c1)))))]
|
|
|
|
[else
|
|
|
|
(proc ((base-constructor-maker (rtd-size rtd)) rtd))])]
|
|
|
|
[else (error who "BUG22")])))
|
2007-06-27 06:15:51 -04:00
|
|
|
|
|
|
|
(define (record-accessor rtd k)
|
|
|
|
(define who 'record-accessor)
|
|
|
|
(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))
|
|
|
|
(lambda (x)
|
|
|
|
(cond
|
|
|
|
[($record/rtd? x rtd) ($record-ref x i)]
|
|
|
|
[($record? x)
|
|
|
|
(let ([xrtd ($record-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)]
|
|
|
|
[(not prtd)
|
|
|
|
(error who "~s is not of type ~s" x rtd)]
|
|
|
|
[else (f (rtd-parent prtd) rtd x i)])))]
|
|
|
|
[else (error who "~s is not of type ~s" x rtd)])))))
|
|
|
|
|
|
|
|
(define (record-mutator rtd k)
|
|
|
|
(define who 'record-mutator)
|
|
|
|
(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))
|
|
|
|
(unless (car (vector-ref (rtd-fields rtd) k))
|
|
|
|
(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)])
|
|
|
|
(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)]
|
|
|
|
[(not prtd)
|
|
|
|
(error who "~s is not of type ~s" x rtd)]
|
|
|
|
[else (f (rtd-parent prtd) rtd x i v)])))]
|
|
|
|
[else (error who "~s is not of type ~s" x rtd)])))))
|
|
|
|
|
|
|
|
(define (record-predicate rtd)
|
|
|
|
(define who 'record-predicate)
|
|
|
|
(unless (rtd? rtd)
|
|
|
|
(error who "~s is not an rtd" rtd))
|
|
|
|
(let ([sz (rtd-size rtd)]
|
|
|
|
[p (rtd-parent rtd)])
|
|
|
|
(lambda (x)
|
|
|
|
(cond
|
|
|
|
[($record/rtd? x rtd) #t]
|
|
|
|
[($record? x)
|
|
|
|
(let ([xrtd ($record-rtd x)])
|
|
|
|
(and (rtd? xrtd)
|
|
|
|
(let f ([prtd (rtd-parent xrtd)] [rtd rtd])
|
|
|
|
(cond
|
|
|
|
[(eq? prtd rtd) #t]
|
|
|
|
[(not prtd) #f]
|
|
|
|
[else (f (rtd-parent prtd) rtd)]))))]
|
|
|
|
[else #f]))))
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
)
|