From 8dc8589a9a349da58ddc10bd4ff18eddf2b5484c Mon Sep 17 00:00:00 2001 From: Eli Barzilay Date: Tue, 11 Mar 2008 13:06:29 +0000 Subject: [PATCH] * 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 --- collects/mzlib/foreign.ss | 130 +++++++++++++++++++++++++++++++++++++- 1 file changed, 128 insertions(+), 2 deletions(-) diff --git a/collects/mzlib/foreign.ss b/collects/mzlib/foreign.ss index 40eb915..b4efa6b 100644 --- a/collects/mzlib/foreign.ss +++ b/collects/mzlib/foreign.ss @@ -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] + [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!)