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
This commit is contained in:
Noel Welsh
parent
81709349fb
commit
a53d243e99
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -1,3 +1,133 @@
|
|||
(module |4| mzscheme
|
||||
(require mzlib/foreign)
|
||||
(provide-srfi-4))
|
||||
#lang scheme/base
|
||||
|
||||
(require (for-syntax scheme/base))
|
||||
|
||||
(require (file "foreign.ss"))
|
||||
|
||||
|
||||
|
||||
(unsafe!)
|
||||
|
||||
(define-syntax (define/provide-srfi-4 stx)
|
||||
(define (make-TAG-id prefix name suffix)
|
||||
(datum->syntax stx
|
||||
(string->symbol
|
||||
(string-append prefix name suffix))
|
||||
stx))
|
||||
(syntax-case stx ()
|
||||
[(_ TAG type)
|
||||
(identifier? #'TAG)
|
||||
(let ([name (string-append
|
||||
(symbol->string (syntax->datum #'TAG))
|
||||
"vector")])
|
||||
(with-syntax ([TAG? (make-TAG-id "" name "?")]
|
||||
[TAG (make-TAG-id "" name "")]
|
||||
[s:TAG (make-TAG-id "s:" name "")]
|
||||
[make-TAG (make-TAG-id "make-" name "")]
|
||||
[TAG-ptr (make-TAG-id "" name "-ptr")]
|
||||
[TAG-length (make-TAG-id "" name "-length")]
|
||||
[allocate-TAG (make-TAG-id "allocate-" name "")]
|
||||
[TAG* (make-TAG-id "" name "*")]
|
||||
[list->TAG (make-TAG-id "list->" name "")]
|
||||
[TAG->list (make-TAG-id "" name "->list")]
|
||||
[TAG-ref (make-TAG-id "" name "-ref")]
|
||||
[TAG-set! (make-TAG-id "" name "-set!")]
|
||||
[_TAG (make-TAG-id "_" name "")]
|
||||
[_TAG* (make-TAG-id "_" name "*")]
|
||||
[TAGname name])
|
||||
#'(begin
|
||||
(define-struct TAG (ptr length))
|
||||
(provide (rename-out [TAG s:TAG]))
|
||||
(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)))
|
||||
(provide TAG-ref)
|
||||
(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)))
|
||||
(provide TAG-set!)
|
||||
(define (TAG->list v)
|
||||
(if (TAG? v)
|
||||
(cblock->list (TAG-ptr v) type (TAG-length v))
|
||||
(raise-type-error 'TAG->list TAGname v)))
|
||||
(provide TAG->list)
|
||||
(define (list->TAG l)
|
||||
(make-TAG (list->cblock l type) (length l)))
|
||||
(provide list->TAG)
|
||||
;; 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*]))
|
||||
)))]
|
||||
))
|
||||
|
||||
|
||||
;; 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*)))
|
||||
|
||||
|
||||
(define/provide-srfi-4 s8 _int8)
|
||||
(define/provide-srfi-4 s16 _int16)
|
||||
(define/provide-srfi-4 u16 _uint16)
|
||||
(define/provide-srfi-4 s32 _int32)
|
||||
(define/provide-srfi-4 u32 _uint32)
|
||||
(define/provide-srfi-4 s64 _int64)
|
||||
(define/provide-srfi-4 u64 _uint64)
|
||||
(define/provide-srfi-4 f32 _float)
|
||||
(define/provide-srfi-4 f64 _double*)
|
||||
|
||||
;; We simply rename bytes to implement the u8vector type
|
||||
(provide (rename-out [bytes? u8vector? ]
|
||||
[bytes-length u8vector-length]
|
||||
[make-bytes make-u8vector ]
|
||||
[bytes u8vector ]
|
||||
[bytes-ref u8vector-ref ]
|
||||
[bytes-set! u8vector-set! ]
|
||||
[bytes->list u8vector->list ]
|
||||
[list->bytes list->u8vector ]
|
||||
[_bytes _uint8 ]))
|
||||
103
collects/tests/srfi/4/srfi-4-test.ss
Normal file
103
collects/tests/srfi/4/srfi-4-test.ss
Normal file
|
|
@ -0,0 +1,103 @@
|
|||
(module srfi-4-test mzscheme
|
||||
|
||||
(require
|
||||
(planet "test.ss" ("schematics" "schemeunit.plt" 2))
|
||||
(planet "text-ui.ss" ("schematics" "schemeunit.plt" 2))
|
||||
srfi/4)
|
||||
|
||||
(provide srfi-4-tests)
|
||||
|
||||
(define-syntax (check-struct-info-binding stx)
|
||||
(syntax-case stx ()
|
||||
[(_ name)
|
||||
(if (identifier? (syntax name))
|
||||
#'#t
|
||||
#'(fail "Identifier not bound"))]))
|
||||
|
||||
(define-check (check-srfi-4-type make pred length ref set to-list from-list)
|
||||
(check-pred pred (from-list '(1 2 3 4)))
|
||||
(check-pred list? (to-list (from-list '(1 2 3 4))))
|
||||
(check-equal? (to-list (from-list '(1 2 3 4))) '(1 2 3 4))
|
||||
(check-pred pred (make 4 1))
|
||||
(let ([vec (make 4 1)])
|
||||
(check-equal? (ref vec 0) 1)
|
||||
(check-equal? (ref vec 1) 1)
|
||||
(check-equal? (ref vec 2) 1)
|
||||
(check-equal? (ref vec 3) 1)
|
||||
(set vec 0 5)
|
||||
(check-equal? (ref vec 0) 5)
|
||||
(check-equal? (length vec) 4)))
|
||||
|
||||
(define-check (check-srfi-4-float-type make pred length ref set to-list from-list)
|
||||
(check-pred pred (from-list '(1. 2. 3. 4.)))
|
||||
(check-pred list? (to-list (from-list '(1. 2. 3. 4.))))
|
||||
(check-equal? (to-list (from-list '(1. 2. 3. 4.))) '(1. 2. 3. 4.))
|
||||
(check-pred pred (make 4 1.))
|
||||
(let ([vec (make 4 1.)])
|
||||
(check-equal? (ref vec 0) 1.)
|
||||
(check-equal? (ref vec 1) 1.)
|
||||
(check-equal? (ref vec 2) 1.)
|
||||
(check-equal? (ref vec 3) 1.)
|
||||
(set vec 0 5.)
|
||||
(check-equal? (ref vec 0) 5.)
|
||||
(check-equal? (length vec) 4)))
|
||||
|
||||
(define srfi-4-tests
|
||||
(test-suite
|
||||
"All tests for srfi-4"
|
||||
|
||||
(test-case
|
||||
"s8"
|
||||
(check-srfi-4-type make-s8vector s8vector? s8vector-length s8vector-ref s8vector-set! s8vector->list list->s8vector)
|
||||
(check-struct-info-binding s8))
|
||||
|
||||
(test-case
|
||||
"u8"
|
||||
(check-srfi-4-type make-u8vector u8vector? u8vector-length u8vector-ref u8vector-set! u8vector->list list->u8vector))
|
||||
|
||||
(test-case
|
||||
"s16"
|
||||
(check-srfi-4-type make-s16vector s16vector? s16vector-length s16vector-ref s16vector-set! s16vector->list list->s16vector)
|
||||
(check-struct-info-binding s16))
|
||||
|
||||
(test-case
|
||||
"u16"
|
||||
(check-srfi-4-type make-u16vector u16vector? u16vector-length u16vector-ref u16vector-set! u16vector->list list->u16vector)
|
||||
(check-struct-info-binding u16))
|
||||
|
||||
(test-case
|
||||
"s32"
|
||||
(check-srfi-4-type make-s32vector s32vector? s32vector-length s32vector-ref s32vector-set! s32vector->list list->s32vector)
|
||||
(check-struct-info-binding s32))
|
||||
|
||||
(test-case
|
||||
"u32"
|
||||
(check-srfi-4-type make-u32vector u32vector? u32vector-length u32vector-ref u32vector-set! u32vector->list list->u32vector)
|
||||
(check-struct-info-binding u32))
|
||||
|
||||
(test-case
|
||||
"s64"
|
||||
(check-srfi-4-type make-s64vector s64vector? s64vector-length s64vector-ref s64vector-set! s64vector->list list->s64vector)
|
||||
(check-struct-info-binding s64))
|
||||
|
||||
(test-case
|
||||
"u64"
|
||||
(check-srfi-4-type make-u64vector u64vector? u64vector-length u64vector-ref u64vector-set! u64vector->list list->u64vector)
|
||||
(check-struct-info-binding u64))
|
||||
|
||||
(test-case
|
||||
"f32"
|
||||
(check-srfi-4-float-type make-f32vector f32vector? f32vector-length f32vector-ref f32vector-set! f32vector->list list->f32vector)
|
||||
(check-struct-info-binding f32))
|
||||
|
||||
(test-case
|
||||
"f64"
|
||||
(check-srfi-4-float-type make-f64vector f64vector? f64vector-length f64vector-ref f64vector-set! f64vector->list list->f64vector)
|
||||
(check-struct-info-binding f64))
|
||||
|
||||
))
|
||||
|
||||
|
||||
(test/text-ui srfi-4-tests)
|
||||
|
||||
)
|
||||
Loading…
Reference in New Issue
Block a user