(library (core vector-types)
(export (rename (make-a-vector-type make-vector-type))
vector-type?
vector-type-data
vector-type-predicate
typed-vector-constructor
typed-vector-accessor typed-vector-mutator
typed-vector?
typed-vector-type)
(import (core primitives)
(core derived)
(core let)
(core define-values)
(core let-values)
(primitives make-struct-type
make-struct-field-accessor
make-struct-field-mutator
make-struct-type-property
current-inspector
box unbox set-box!))
(define null '())
(define add1 (lambda (x) (+ x 1)))
(define-values (make-vector-type vector-type?
vector-type-data
vector-type-field-count
vector-type-supertype
vector-type-struct-type
vector-type-constructor
vector-type-predicate
vector-type-accessor
vector-type-mutator)
(call-with-values
(lambda ()
(make-struct-type 'vector-type #f 8 0))
(lambda (record-type constructor predicate accessor mutator)
(values constructor
predicate
(make-struct-field-accessor accessor 0 'vector-type-data)
(make-struct-field-accessor accessor 1 'vector-type-field-count)
(make-struct-field-accessor accessor 2 'vector-type-supertype)
(make-struct-field-accessor accessor 3 'vector-type-struct-type)
(make-struct-field-accessor accessor 4 'vector-type-constructor)
(make-struct-field-accessor accessor 5 'vector-type-predicate)
(make-struct-field-accessor accessor 6 'vector-type-accessor)
(make-struct-field-accessor accessor 7 'vector-type-mutator)))))
(define-values (prop:typed-vector typed-vector? typed-vector-ref)
(make-struct-type-property 'typed-vector))
(define (make-a-vector-type name supertype data field-mutability opaque?)
(let* ([super-field-count (if supertype
(vector-type-field-count supertype)
0)]
[field-mutability (list-tail field-mutability super-field-count)]
[bx (box #f)])
(let-values ([(struct: make-s s? s-ref s-set!)
(make-struct-type name
(and supertype
(vector-type-struct-type supertype))
(length field-mutability) 0 #f
(list (cons prop:typed-vector bx))
(and opaque? (current-inspector))
#f (let loop ([field-mutability field-mutability]
[index 0])
(cond
[(null? field-mutability) null]
[(not (car field-mutability)) (cons index
(loop (cdr field-mutability)
(add1 index)))]
[else (loop (cdr field-mutability) (add1 index))])))])
(let ([vt (make-vector-type data
(+ (length field-mutability) super-field-count)
supertype
struct: make-s s?
s-ref s-set!)])
(set-box! bx vt)
vt))))
(define (vector-type-index t pos)
(let* ([supertype (vector-type-supertype t)]
[super-field-count (if supertype
(vector-type-field-count supertype)
0)])
(if (< pos super-field-count)
(vector-type-index supertype pos)
(- pos super-field-count))))
(define (typed-vector-constructor t)
(vector-type-constructor t))
(define (typed-vector-type v)
(unbox (typed-vector-ref v)))
(define (typed-vector-accessor t pos)
(make-struct-field-accessor (vector-type-accessor t) (vector-type-index t pos)))
(define (typed-vector-mutator t pos)
(make-struct-field-mutator (vector-type-mutator t) (vector-type-index t pos)))
)