I have changed the SRFI-4 implementation so structure types are exported for types except u8. This allows developers to subtype the SRFI-4 structures. I have also refactored the code, leading to a significantly simpler implementation
svn: r8918 original commit: a53d243e99a1d9a44b6cf9126b5d7eecdd0cb3e9
This commit is contained in:
Noel Welsh
parent
0bbfa652f7
commit
694ebaae8e
|
|
@ -1006,148 +1006,6 @@
|
|||
(define* (list->cvector l type)
|
||||
(make-cvector (list->cblock l type) type (length l)))
|
||||
|
||||
;; ----------------------------------------------------------------------------
|
||||
;; SRFI-4 implementation
|
||||
|
||||
(define-syntaxes (make-srfi-4 define-srfi-4-provider)
|
||||
(let ([bindings '()])
|
||||
(define (define-srfi-4-provider stx)
|
||||
(syntax-case stx ()
|
||||
[(_ x) (with-syntax ([(binding ...) bindings])
|
||||
#'(define-syntax x
|
||||
(syntax-rules ()
|
||||
[(_) (provide binding ...)])))]))
|
||||
(define (make-srfi-4 stx)
|
||||
(syntax-case stx ()
|
||||
[(_ TAG type more ...) (identifier? #'TAG)
|
||||
(let ([name (string-append
|
||||
(symbol->string (syntax->datum #'TAG))
|
||||
"vector")])
|
||||
(define (make-TAG-id prefix suffix)
|
||||
(datum->syntax #'TAG
|
||||
(string->symbol
|
||||
(string-append prefix name suffix))
|
||||
#'TAG))
|
||||
(with-syntax ([TAG? (make-TAG-id "" "?")]
|
||||
[TAG (make-TAG-id "" "")]
|
||||
[make-TAG (make-TAG-id "make-" "")]
|
||||
[TAG-ptr (make-TAG-id "" "-ptr")]
|
||||
[TAG-length (make-TAG-id "" "-length")]
|
||||
[allocate-TAG (make-TAG-id "allocate-" "")]
|
||||
[TAG* (make-TAG-id "" "*")]
|
||||
[list->TAG (make-TAG-id "list->" "")]
|
||||
[TAG->list (make-TAG-id "" "->list")]
|
||||
[TAG-ref (make-TAG-id "" "-ref")]
|
||||
[TAG-set! (make-TAG-id "" "-set!")]
|
||||
[_TAG (make-TAG-id "_" "")]
|
||||
[_TAG* (make-TAG-id "_" "*")]
|
||||
[TAGname name])
|
||||
(set! bindings (list* #'TAG?
|
||||
#'TAG-length
|
||||
#'make-TAG
|
||||
#'TAG
|
||||
#'TAG-ref
|
||||
#'TAG-set!
|
||||
#'TAG->list
|
||||
#'list->TAG
|
||||
#'_TAG
|
||||
bindings))
|
||||
(syntax-case #'(more ...) ()
|
||||
[(X? X-length make-X X X-ref X-set! X->list list->X _X)
|
||||
#'(provide (rename-out [X? TAG? ]
|
||||
[X-length TAG-length]
|
||||
[make-X make-TAG ]
|
||||
[X TAG ]
|
||||
[X-ref TAG-ref ]
|
||||
[X-set! TAG-set! ]
|
||||
[X->list TAG->list ]
|
||||
[list->X list->TAG ]
|
||||
[_X _TAG ]))]
|
||||
[()
|
||||
#'(begin
|
||||
(define-struct TAG (ptr length))
|
||||
(provide TAG? TAG-length)
|
||||
(provide (rename-out [allocate-TAG make-TAG]))
|
||||
(define (allocate-TAG n . init)
|
||||
(let* ([p (if (eq? n 0) #f (malloc n type))]
|
||||
[v (make-TAG p n)])
|
||||
(when (and p (pair? init))
|
||||
(let ([init (car init)])
|
||||
(let loop ([i (sub1 n)])
|
||||
(unless (< i 0)
|
||||
(ptr-set! p type i init)
|
||||
(loop (sub1 i))))))
|
||||
v))
|
||||
(provide (rename-out [TAG* TAG]))
|
||||
(define (TAG* . vals)
|
||||
(list->TAG vals))
|
||||
(define* (TAG-ref v i)
|
||||
(if (TAG? v)
|
||||
(if (and (integer? i) (< -1 i (TAG-length v)))
|
||||
(ptr-ref (TAG-ptr v) type i)
|
||||
(error 'TAG-ref "bad index ~e for ~a bounds of 0..~e"
|
||||
i 'TAG (sub1 (TAG-length v))))
|
||||
(raise-type-error 'TAG-ref TAGname v)))
|
||||
(define* (TAG-set! v i x)
|
||||
(if (TAG? v)
|
||||
(if (and (integer? i) (< -1 i (TAG-length v)))
|
||||
(ptr-set! (TAG-ptr v) type i x)
|
||||
(error 'TAG-set! "bad index ~e for ~a bounds of 0..~e"
|
||||
i 'TAG (sub1 (TAG-length v))))
|
||||
(raise-type-error 'TAG-set! TAGname v)))
|
||||
(define* (TAG->list v)
|
||||
(if (TAG? v)
|
||||
(cblock->list (TAG-ptr v) type (TAG-length v))
|
||||
(raise-type-error 'TAG->list TAGname v)))
|
||||
(define* (list->TAG l)
|
||||
(make-TAG (list->cblock l type) (length l)))
|
||||
;; same as the _cvector implementation
|
||||
(provide _TAG)
|
||||
(define _TAG*
|
||||
(make-ctype _pointer TAG-ptr
|
||||
(lambda (x)
|
||||
(error
|
||||
'_TAG
|
||||
"cannot automatically convert a C pointer to a ~a"
|
||||
TAGname))))
|
||||
(define-fun-syntax _TAG
|
||||
(syntax-id-rules (i o io)
|
||||
[(_ i ) _TAG*]
|
||||
[(_ o n) (type: _pointer
|
||||
pre: (malloc n type)
|
||||
post: (x => (make-TAG x n)))]
|
||||
[(_ io ) (type: _cvector*
|
||||
bind: tmp
|
||||
pre: (x => (TAG-ptr x))
|
||||
post: (x => tmp))]
|
||||
[(_ . xs) (_TAG* . xs)]
|
||||
[_ _TAG*]))
|
||||
)])))]))
|
||||
(values make-srfi-4 define-srfi-4-provider)))
|
||||
|
||||
(make-srfi-4 s8 _int8)
|
||||
;; this one is implemented as byte strings
|
||||
(make-srfi-4 u8 _uint8
|
||||
bytes? bytes-length make-bytes bytes bytes-ref bytes-set!
|
||||
bytes->list list->bytes _bytes)
|
||||
(make-srfi-4 s16 _int16)
|
||||
(make-srfi-4 u16 _uint16)
|
||||
(make-srfi-4 s32 _int32)
|
||||
(make-srfi-4 u32 _uint32)
|
||||
(make-srfi-4 s64 _int64)
|
||||
(make-srfi-4 u64 _uint64)
|
||||
(make-srfi-4 f32 _float)
|
||||
(make-srfi-4 f64 _double*)
|
||||
(define-srfi-4-provider provide-srfi-4)
|
||||
(provide provide-srfi-4)
|
||||
|
||||
;; check that the types that were used above have the proper sizes
|
||||
(unless (= 4 (ctype-sizeof _float))
|
||||
(error 'foreign "internal error: float has a bad size (~s)"
|
||||
(ctype-sizeof _float)))
|
||||
(unless (= 8 (ctype-sizeof _double*))
|
||||
(error 'foreign "internal error: double has a bad size (~s)"
|
||||
(ctype-sizeof _double*)))
|
||||
|
||||
;; ----------------------------------------------------------------------------
|
||||
;; Tagged pointers
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user