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)
|
(define* (list->cvector l type)
|
||||||
(make-cvector (list->cblock l type) type (length l)))
|
(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
|
;; Tagged pointers
|
||||||
|
|
|
||||||
Loading…
Reference in New Issue
Block a user