From 3c29bbda9d7cd8366b0bbe283f75aa1ce00c94d9 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 --- collects/mzlib/foreign.ss | 130 ++++++++++++++++++++++++++++- collects/scheme/modspec-forms.ss | 19 +++++ collects/srfi/4.ss | 138 ++----------------------------- collects/srfi/66/66.ss | 29 ++----- 4 files changed, 160 insertions(+), 156 deletions(-) create mode 100644 collects/scheme/modspec-forms.ss diff --git a/collects/mzlib/foreign.ss b/collects/mzlib/foreign.ss index 40eb915cd7..b4efa6b23f 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!) diff --git a/collects/scheme/modspec-forms.ss b/collects/scheme/modspec-forms.ss new file mode 100644 index 0000000000..3bac06d6d3 --- /dev/null +++ b/collects/scheme/modspec-forms.ss @@ -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))])))) diff --git a/collects/srfi/4.ss b/collects/srfi/4.ss index 69cd22683b..ccf11833cf 100644 --- a/collects/srfi/4.ss +++ b/collects/srfi/4.ss @@ -1,133 +1,11 @@ #lang scheme/base -(require (for-syntax scheme/base)) +(require scheme/modspec-forms) -(require scheme/foreign) - - - -(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 ])) \ No newline at end of file +;; 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. +(require (matching-identifiers-in #px"\\b_?[suf](8|16|32|64)vector\\b" + scheme/foreign)) +(provide (all-from-out scheme/foreign)) diff --git a/collects/srfi/66/66.ss b/collects/srfi/66/66.ss index a89443f56d..add9cbe5cf 100644 --- a/collects/srfi/66/66.ss +++ b/collects/srfi/66/66.ss @@ -1,24 +1,5 @@ -(module |66| mzscheme - (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) - (bytes=? v1 v2)) - - (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)))) +#lang scheme/base + +(require scheme/modspec-forms) +(require (matching-identifiers-in #px"\\bu8vector\\b" scheme/foreign)) +(provide (all-from-out scheme/foreign))