* Moved the srfi-4 functionality back into the foreign library, so its
available from there instead of only from srfi/4 * Added scheme/modspec-forms with `matching-identifiers-in' for a generic regexp-based selection of identifiers * Used this new form to get make srfi/4 reprovide the relevant stuff from foreign * Did the same for srfi/66 (and added the missing renames etc to foreign) svn: r8944
This commit is contained in:
Eli Barzilay
parent
57b9507a89
commit
3c29bbda9d
|
|
@ -1006,6 +1006,130 @@
|
||||||
(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-syntax (srfi-4-define/provide stx)
|
||||||
|
(syntax-case stx ()
|
||||||
|
[(_ TAG type)
|
||||||
|
(identifier? #'TAG)
|
||||||
|
(let ([name (format "~avector" (syntax->datum #'TAG))])
|
||||||
|
(define (id prefix suffix)
|
||||||
|
(let* ([name (if prefix (string-append prefix name) name)]
|
||||||
|
[name (if suffix (string-append name suffix) name)])
|
||||||
|
(datum->syntax #'TAG (string->symbol name) #'TAG)))
|
||||||
|
(with-syntax ([TAG? (id "" "?")]
|
||||||
|
[TAG (id "" "")]
|
||||||
|
[s:TAG (id "s:" "")]
|
||||||
|
[make-TAG (id "make-" "")]
|
||||||
|
[TAG-ptr (id "" "-ptr")]
|
||||||
|
[TAG-length (id "" "-length")]
|
||||||
|
[allocate-TAG (id "allocate-" "")]
|
||||||
|
[TAG* (id "" "*")]
|
||||||
|
[list->TAG (id "list->" "")]
|
||||||
|
[TAG->list (id "" "->list")]
|
||||||
|
[TAG-ref (id "" "-ref")]
|
||||||
|
[TAG-set! (id "" "-set!")]
|
||||||
|
[_TAG (id "_" "")]
|
||||||
|
[_TAG* (id "_" "*")]
|
||||||
|
[TAGname name])
|
||||||
|
#'(begin
|
||||||
|
(define-struct TAG (ptr length))
|
||||||
|
(provide TAG? TAG-length (rename-out [TAG s:TAG]))
|
||||||
|
(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*])))))]
|
||||||
|
[(_ TAG type)
|
||||||
|
(identifier? #'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*)))
|
||||||
|
|
||||||
|
(srfi-4-define/provide s8 _int8)
|
||||||
|
(srfi-4-define/provide s16 _int16)
|
||||||
|
(srfi-4-define/provide u16 _uint16)
|
||||||
|
(srfi-4-define/provide s32 _int32)
|
||||||
|
(srfi-4-define/provide u32 _uint32)
|
||||||
|
(srfi-4-define/provide s64 _int64)
|
||||||
|
(srfi-4-define/provide u64 _uint64)
|
||||||
|
(srfi-4-define/provide f32 _float)
|
||||||
|
(srfi-4-define/provide f64 _double*)
|
||||||
|
|
||||||
|
;; 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 _u8vector ]))
|
||||||
|
;; additional `u8vector' bindings for srfi-66
|
||||||
|
(provide (rename-out [bytes-copy u8vector-copy] [bytes=? u8vector=?]))
|
||||||
|
(define* (u8vector-compare v1 v2)
|
||||||
|
(cond [(bytes<? v1 v2) -1]
|
||||||
|
[(bytes>? v1 v2) 1]
|
||||||
|
[else 0]))
|
||||||
|
(define* (u8vector-copy! src src-start dest dest-start n)
|
||||||
|
(bytes-copy! dest dest-start src src-start (+ src-start n)))
|
||||||
|
|
||||||
;; ----------------------------------------------------------------------------
|
;; ----------------------------------------------------------------------------
|
||||||
;; Tagged pointers
|
;; Tagged pointers
|
||||||
|
|
@ -1425,7 +1549,9 @@
|
||||||
(provide* (unsafe register-finalizer))
|
(provide* (unsafe register-finalizer))
|
||||||
(define (register-finalizer obj finalizer)
|
(define (register-finalizer obj finalizer)
|
||||||
(unless killer-thread
|
(unless killer-thread
|
||||||
(set! killer-thread (thread (lambda () (let loop () (will-execute killer-executor) (loop))))))
|
(set! killer-thread
|
||||||
|
(thread (lambda ()
|
||||||
|
(let loop () (will-execute killer-executor) (loop))))))
|
||||||
(will-register killer-executor obj finalizer))
|
(will-register killer-executor obj finalizer))
|
||||||
|
|
||||||
(define-unsafer unsafe!)
|
(define-unsafer unsafe!)
|
||||||
|
|
|
||||||
19
collects/scheme/modspec-forms.ss
Normal file
19
collects/scheme/modspec-forms.ss
Normal file
|
|
@ -0,0 +1,19 @@
|
||||||
|
#lang scheme/base
|
||||||
|
|
||||||
|
(require (for-syntax scheme/base scheme/require-transform))
|
||||||
|
|
||||||
|
(provide matching-identifiers-in)
|
||||||
|
(define-syntax matching-identifiers-in
|
||||||
|
(make-require-transformer
|
||||||
|
(lambda (stx)
|
||||||
|
(syntax-case stx ()
|
||||||
|
[(_ rx spec)
|
||||||
|
(regexp? (syntax-e #'rx))
|
||||||
|
(let*-values ([(rx) (syntax-e #'rx)]
|
||||||
|
[(imports sources) (expand-import #'spec)])
|
||||||
|
(values
|
||||||
|
(filter (lambda (i)
|
||||||
|
(regexp-match? rx (symbol->string
|
||||||
|
(syntax-e (import-local-id i)))))
|
||||||
|
imports)
|
||||||
|
sources))]))))
|
||||||
|
|
@ -1,133 +1,11 @@
|
||||||
#lang scheme/base
|
#lang scheme/base
|
||||||
|
|
||||||
(require (for-syntax scheme/base))
|
(require scheme/modspec-forms)
|
||||||
|
|
||||||
(require scheme/foreign)
|
;; Note: this also gets additional functions for srfi-66 (u8vector-copy,
|
||||||
|
;; u8vector=?, u8vector-compare, u8vector-copy!) -- but that should be fine,
|
||||||
|
;; just like a future extension of the srfi-4 stuff to provide these for all
|
||||||
|
;; vector types.
|
||||||
(unsafe!)
|
(require (matching-identifiers-in #px"\\b_?[suf](8|16|32|64)vector\\b"
|
||||||
|
scheme/foreign))
|
||||||
(define-syntax (define/provide-srfi-4 stx)
|
(provide (all-from-out scheme/foreign))
|
||||||
(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 ]))
|
|
||||||
|
|
|
||||||
|
|
@ -1,24 +1,5 @@
|
||||||
(module |66| mzscheme
|
#lang scheme/base
|
||||||
(provide (rename bytes? u8vector?)
|
|
||||||
(rename make-bytes make-u8vector)
|
|
||||||
(rename bytes u8vector)
|
|
||||||
(rename bytes->list u8vector->list)
|
|
||||||
(rename list->bytes list->u8vector)
|
|
||||||
(rename bytes-length u8vector-length)
|
|
||||||
(rename bytes-ref u8vector-ref)
|
|
||||||
(rename bytes-set! u8vector-set!)
|
|
||||||
(rename bytes-copy u8vector-copy)
|
|
||||||
u8vector=?
|
|
||||||
u8vector-compare
|
|
||||||
u8vector-copy!)
|
|
||||||
|
|
||||||
(define (u8vector=? v1 v2)
|
(require scheme/modspec-forms)
|
||||||
(bytes=? v1 v2))
|
(require (matching-identifiers-in #px"\\bu8vector\\b" scheme/foreign))
|
||||||
|
(provide (all-from-out scheme/foreign))
|
||||||
(define (u8vector-compare v1 v2)
|
|
||||||
(cond ((bytes<? v1 v2) -1)
|
|
||||||
((bytes>? v1 v2) 1)
|
|
||||||
(else 0)))
|
|
||||||
|
|
||||||
(define (u8vector-copy! src src-start dest dest-start n)
|
|
||||||
(bytes-copy! dest dest-start src src-start (+ src-start n))))
|
|
||||||
|
|
|
||||||
Loading…
Reference in New Issue
Block a user