* 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 original commit: 3c29bbda9d7cd8366b0bbe283f75aa1ce00c94d9
This commit is contained in:
Eli Barzilay
parent
f40329c855
commit
8dc8589a9a
|
|
@ -1,7 +1,7 @@
|
|||
#lang scheme/base
|
||||
|
||||
;; Foreign Scheme interface
|
||||
(require '#%foreign
|
||||
(require '#%foreign
|
||||
setup/dirs
|
||||
(for-syntax scheme/base
|
||||
syntax/stx))
|
||||
|
|
@ -1006,6 +1006,130 @@
|
|||
(define* (list->cvector l type)
|
||||
(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
|
||||
|
|
@ -1425,7 +1549,9 @@
|
|||
(provide* (unsafe register-finalizer))
|
||||
(define (register-finalizer obj finalizer)
|
||||
(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))
|
||||
|
||||
(define-unsafer unsafe!)
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user