suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

u8vector is implemented using bytes

Browse Source 
svn: r5921
This commit is contained in:
Eli Barzilay 2007-04-11 06:46:17 +00:00
parent cb200bbca4
commit bf8cd534cd
2 changed files with 123 additions and 102 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

219
collects/mzlib/foreign.ss
View File

@ -992,110 +992,125 @@
(define-syntaxes (make-srfi-4 define-srfi-4-provider) (define-syntaxes (make-srfi-4 define-srfi-4-provider)
(let ([bindings '()]) (let ([bindings '()])
(values (define (define-srfi-4-provider stx)
(lambda (stx) (syntax-case stx ()
(syntax-case stx () [(_ x) (with-syntax ([(binding ...) bindings])
[(_ TAG type) (identifier? #'TAG) #'(define-syntax x
(let ([name (string-append (syntax-rules ()
(symbol->string (syntax-object->datum #'TAG)) [(_) (provide binding ...)])))]))
"vector")]) (define (make-srfi-4 stx)
(define (make-TAG-id prefix suffix) (syntax-case stx ()
(datum->syntax-object #'TAG [(_ TAG type more ...) (identifier? #'TAG)
(string->symbol (let ([name (string-append
(string-append prefix name suffix)) (symbol->string (syntax-object->datum #'TAG))
#'TAG)) "vector")])
(with-syntax ([TAG? (make-TAG-id "" "?")] (define (make-TAG-id prefix suffix)
[TAG (make-TAG-id "" "")] (datum->syntax-object #'TAG
[make-TAG (make-TAG-id "make-" "")] (string->symbol
[TAG-ptr (make-TAG-id "" "-ptr")] (string-append prefix name suffix))
[TAG-length (make-TAG-id "" "-length")] #'TAG))
[allocate-TAG (make-TAG-id "allocate-" "")] (with-syntax ([TAG? (make-TAG-id "" "?")]
[TAG* (make-TAG-id "" "*")] [TAG (make-TAG-id "" "")]
[list->TAG (make-TAG-id "list->" "")] [make-TAG (make-TAG-id "make-" "")]
[TAG->list (make-TAG-id "" "->list")] [TAG-ptr (make-TAG-id "" "-ptr")]
[TAG-ref (make-TAG-id "" "-ref")] [TAG-length (make-TAG-id "" "-length")]
[TAG-set! (make-TAG-id "" "-set!")] [allocate-TAG (make-TAG-id "allocate-" "")]
[_TAG (make-TAG-id "_" "")] [TAG* (make-TAG-id "" "*")]
[_TAG* (make-TAG-id "_" "*")] [list->TAG (make-TAG-id "list->" "")]
[TAGname name]) [TAG->list (make-TAG-id "" "->list")]
(set! bindings (list* #'TAG? [TAG-ref (make-TAG-id "" "-ref")]
#'TAG-length [TAG-set! (make-TAG-id "" "-set!")]
#'make-TAG [_TAG (make-TAG-id "_" "")]
#'TAG [_TAG* (make-TAG-id "_" "*")]
#'TAG-ref [TAGname name])
#'TAG-set! (set! bindings (list* #'TAG?
#'TAG->list #'TAG-length
#'list->TAG #'make-TAG
#'_TAG #'TAG
bindings)) #'TAG-ref
#'(begin #'TAG-set!
(define-struct TAG (ptr length)) #'TAG->list
(provide TAG? TAG-length) #'list->TAG
(provide (rename allocate-TAG make-TAG)) #'_TAG
(define (allocate-TAG n . init) bindings))
(let* ([p (if (eq? n 0) #f (malloc n type))] (syntax-case #'(more ...) ()
[v (make-TAG p n)]) [(X? X-length make-X X X-ref X-set! X->list list->X _X)
(when (and p (pair? init)) #'(provide (rename X? TAG? )
(let ([init (car init)]) (rename X-length TAG-length)
(let loop ([i (sub1 n)]) (rename make-X make-TAG )
(unless (< i 0) (rename X TAG )
(ptr-set! p type i init) (rename X-ref TAG-ref )
(loop (sub1 i)))))) (rename X-set! TAG-set! )
v)) (rename X->list TAG->list )
(provide (rename TAG* TAG)) (rename list->X list->TAG )
(define (TAG* . vals) (rename _X _TAG ))]
(list->TAG vals)) [()
(define* (TAG-ref v i) #'(begin
(if (TAG? v) (define-struct TAG (ptr length))
(if (and (integer? i) (< -1 i (TAG-length v))) (provide TAG? TAG-length)
(ptr-ref (TAG-ptr v) type i) (provide (rename allocate-TAG make-TAG))
(error 'TAG-ref "bad index ~e for ~a bounds of 0..~e" (define (allocate-TAG n . init)
i 'TAG (sub1 (TAG-length v)))) (let* ([p (if (eq? n 0) #f (malloc n type))]
(raise-type-error 'TAG-ref TAGname v))) [v (make-TAG p n)])
(define* (TAG-set! v i x) (when (and p (pair? init))
(if (TAG? v) (let ([init (car init)])
(if (and (integer? i) (< -1 i (TAG-length v))) (let loop ([i (sub1 n)])
(ptr-set! (TAG-ptr v) type i x) (unless (< i 0)
(error 'TAG-set! "bad index ~e for ~a bounds of 0..~e" (ptr-set! p type i init)
i 'TAG (sub1 (TAG-length v)))) (loop (sub1 i))))))
(raise-type-error 'TAG-set! TAGname v))) v))
(define* (TAG->list v) (provide (rename TAG* TAG))
(if (TAG? v) (define (TAG* . vals)
(cblock->list (TAG-ptr v) type (TAG-length v)) (list->TAG vals))
(raise-type-error 'TAG->list TAGname v))) (define* (TAG-ref v i)
(define* (list->TAG l) (if (TAG? v)
(make-TAG (list->cblock l type) (length l))) (if (and (integer? i) (< -1 i (TAG-length v)))
;; same as the _cvector implementation (ptr-ref (TAG-ptr v) type i)
(provide _TAG) (error 'TAG-ref "bad index ~e for ~a bounds of 0..~e"
(define _TAG* i 'TAG (sub1 (TAG-length v))))
(make-ctype _pointer TAG-ptr (raise-type-error 'TAG-ref TAGname v)))
(lambda (x) (define* (TAG-set! v i x)
(error (if (TAG? v)
'_TAG (if (and (integer? i) (< -1 i (TAG-length v)))
"cannot automatically convert a C pointer to a ~a" (ptr-set! (TAG-ptr v) type i x)
TAGname)))) (error 'TAG-set! "bad index ~e for ~a bounds of 0..~e"
(define-fun-syntax _TAG i 'TAG (sub1 (TAG-length v))))
(syntax-id-rules (i o io) (raise-type-error 'TAG-set! TAGname v)))
[(_ i ) _TAG*] (define* (TAG->list v)
[(_ o n) (type: _pointer (if (TAG? v)
pre: (malloc n type) (cblock->list (TAG-ptr v) type (TAG-length v))
post: (x => (make-TAG x n)))] (raise-type-error 'TAG->list TAGname v)))
[(_ io ) (type: _cvector* (define* (list->TAG l)
bind: tmp (make-TAG (list->cblock l type) (length l)))
pre: (x => (TAG-ptr x)) ;; same as the _cvector implementation
post: (x => tmp))] (provide _TAG)
[(_ . xs) (_TAG* . xs)] (define _TAG*
[_ _TAG*])) (make-ctype _pointer TAG-ptr
)))])) (lambda (x)
(lambda (stx) (error
(syntax-case stx () '_TAG
[(_ x) (with-syntax ([(binding ...) bindings]) "cannot automatically convert a C pointer to a ~a"
#'(define-syntax x TAGname))))
(syntax-rules () (define-fun-syntax _TAG
[(_) (provide binding ...)])))]))))) (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) (make-srfi-4 s8 _int8)
(make-srfi-4 u8 _uint8) ;; 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 s16 _int16)
(make-srfi-4 u16 _uint16) (make-srfi-4 u16 _uint16)
(make-srfi-4 s32 _int32) (make-srfi-4 s32 _int32)

6
collects/mzlib/sandbox.ss
View File

@ -126,7 +126,13 @@
;; computes permissions that are needed for require specs (`read' for all ;; computes permissions that are needed for require specs (`read' for all
;; files and "compiled" subdirs, `exists' for the base-dir) ;; files and "compiled" subdirs, `exists' for the base-dir)
(define (module-specs->path-permissions mods) (define (module-specs->path-permissions mods)
(define _ (with-output-to-file "/dev/stderr"
(lambda () (printf ">>> mods = ~s\n" mods))
'append))
(define paths (module-specs->non-lib-paths mods)) (define paths (module-specs->non-lib-paths mods))
(define _1 (with-output-to-file "/dev/stderr"
(lambda () (printf ">>> paths = ~s\n" paths))
'append))
(define bases (define bases
(let loop ([paths paths] [bases '()]) (let loop ([paths paths] [bases '()])
(if (null? paths) (if (null? paths)