Changeset 29958 in project


Ignore:
Timestamp:
10/26/13 04:09:33 (8 years ago)
Author:
evhan
Message:

r7rs: bytevectors (mostly reexported from srfi-4)

Location:
release/4/r7rs/trunk
Files:
4 edited

Legend:

Unmodified
Added
Removed
  • release/4/r7rs/trunk/NOTES.org

    r29030 r29958  
    1414* Redefinition of "import" causes "re-importing" warnings.
    1515  - The warnings could be removed in core, it's usefulness is not completely clear.
     16
     17* Just renaming procedures (like from srfi-4) doesn't change their lambda-info names.
     18  - This is sort of confusing, do we care (or should we "(define new old)")?
     19  - Also, this makes the locations from errors (from ##sys#check-whatever) wrong/misleading.
  • release/4/r7rs/trunk/scheme.base-interface.scm

    r29954 r29958  
    1616  |#
    1717  boolean? boolean=?
    18   #|
    19   bytevector-append bytevector-copy bytevector-copy!
     18  bytevector
     19  bytevector-append
     20  bytevector-copy bytevector-copy!
    2021  bytevector-length bytevector-u8-ref bytevector-u8-set!
    2122  bytevector?
    22   |#
    2323  car cdr
    2424  caar cadr cdar cddr
     
    114114  |#
    115115  list list-copy list-ref list-set! list-tail list?
    116   #|
    117116  make-bytevector
    118   |#
    119117  make-list
    120118  #|
  • release/4/r7rs/trunk/scheme.base.scm

    r29957 r29958  
    99                %))
    1010(import (except chicken with-exception-handler raise quotient remainder modulo))
     11(import (rename (only srfi-4 ; TODO: utf8<->string
     12                             make-u8vector subu8vector u8vector u8vector?
     13                             u8vector-length u8vector-ref u8vector-set!)
     14                (u8vector? bytevector?)
     15                (make-u8vector make-bytevector)
     16                (u8vector bytevector)
     17                (u8vector-length bytevector-length)
     18                (u8vector-ref bytevector-u8-ref)
     19                (u8vector-set! bytevector-u8-set!)))
    1120(import numbers)
    1221
    1322(include "scheme.base-interface.scm")
     23
     24(require-library srfi-4)
    1425
    1526(begin-for-syntax (require-library r7rs-compile-time))
     
    275286
    276287;;;
     288;;; 6.9. Bytevectors
     289;;;
     290
     291(define-type bytevector u8vector)
     292
     293(: bytevector-copy (bytevector #!optional fixnum fixnum -> bytevector))
     294
     295(define bytevector-copy
     296  (case-lambda
     297    ((v) (bytevector-copy v 0 (bytevector-length v)))
     298    ((v s) (bytevector-copy v s (bytevector-length v)))
     299    ((v s e)
     300     (##sys#check-structure v 'u8vector 'bytevector-copy)
     301     (##sys#check-exact s 'bytevector-copy)
     302     (##sys#check-exact e 'bytevector-copy)
     303     (unless (and (fx<= 0 s) (fx<= s e) (fx<= e (bytevector-length v)))
     304       (error 'bytevector-copy "invalid indices" s e))
     305     (subu8vector v s e))))
     306
     307(: bytevector-copy! (bytevector fixnum bytevector #!optional fixnum fixnum -> undefined))
     308
     309(define bytevector-copy!
     310  (case-lambda
     311    ((t a f) (bytevector-copy! t a f 0 (bytevector-length f)))
     312    ((t a f s) (bytevector-copy! t a f s (bytevector-length f)))
     313    ((t a f s e)
     314     (##sys#check-structure t 'u8vector 'bytevector-copy!)
     315     (##sys#check-structure f 'u8vector 'bytevector-copy!)
     316     (##sys#check-exact a 'bytevector-copy)
     317     (##sys#check-exact s 'bytevector-copy)
     318     (##sys#check-exact e 'bytevector-copy)
     319     (unless (and (fx<= 0 a)
     320                  (fx<= 0 s)
     321                  (fx<= e (bytevector-length f))
     322                  (fx<= (fx- e s) (fx- (bytevector-length t) a)))
     323       (error 'bytevector-copy! "invalid indices" a s e))
     324     (do ((s s (fx+ s 1))
     325          (a a (fx+ a 1)))
     326         ((fx= s e))
     327       (bytevector-u8-set! t a (bytevector-u8-ref f s))))))
     328
     329(: bytevector-append (#!rest bytevector -> bytevector))
     330
     331(define (bytevector-append . vs)
     332  (for-each (cut ##sys#check-structure <> 'u8vector 'bytevector-append) vs)
     333  (let* ((ls (map bytevector-length vs))
     334         (ov (make-bytevector (foldl fx+ 0 ls))))
     335    (let lp ((i 0)
     336             (vs vs)
     337             (ls ls))
     338      (cond ((null? vs) ov)
     339            (else
     340             (bytevector-copy! ov i (car vs) 0 (car ls))
     341             (lp (fx+ i (car ls))
     342                 (cdr vs)
     343                 (cdr ls)))))))
     344
     345;;;
    277346;;; 6.11. Exceptions
    278347;;;
  • release/4/r7rs/trunk/tests/run.scm

    r29954 r29958  
    343343    (test #t (string>=? "b" "b" "a"))
    344344    (test #f (string>=? "b" "a" "b"))))
     345
     346(test-group "6.9: bytevectors"
     347
     348  (test-group "bytevector-copy"
     349    (test-error (bytevector-copy ""))
     350    (test-error (bytevector-copy #u8() #u8()))
     351    (test-error (bytevector-copy #u8() 1))
     352    (test-error (bytevector-copy #u8(0) -1))
     353    (test-error (bytevector-copy #u8(0) 0 2))
     354    (test #u8() (bytevector-copy #u8()))
     355    (test #u8(0 1 2) (bytevector-copy #u8(0 1 2)))
     356    (test #u8(1 2) (bytevector-copy #u8(0 1 2) 1))
     357    (test #u8(1) (bytevector-copy #u8(0 1 2) 1 2))
     358    (test #u8() (bytevector-copy #u8(0 1 2) 1 1)))
     359
     360  (test-group "bytevector-copy!"
     361    (test-error (bytevector-copy! ""))
     362    (test-error (bytevector-copy! #u8(0) 0 ""))
     363    (test-error (bytevector-copy! #u8() #u8() 0))
     364    (test-error (bytevector-copy! #u8() 0 #u8(0)))
     365    (test-error (bytevector-copy! #u8(0) 1 #u8(0)))
     366    (test-error (bytevector-copy! #u8(0) 1 #u8(0) 0))
     367    (test-error (bytevector-copy! #u8(0) 0 #u8(0) 0 2))
     368    (test-error (bytevector-copy! #u8(0) 0 #u8(0 1) 1 0))
     369    (test-assert (bytevector-copy! #u8() 0 #u8()))
     370    (let ((t #u8(0 1 2))
     371          (f #u8(3 4 5 6)))
     372      (bytevector-copy! t 0 f 1 1)
     373      (test "(bytevector-copy! t 1 f 1 1)" #u8(0 1 2) t)
     374      (bytevector-copy! t 0 f 0 1)
     375      (test "(bytevector-copy! t 0 f 0 1)" #u8(3 1 2) t)
     376      (bytevector-copy! t 0 f 1 3)
     377      (test "(bytevector-copy! t 0 f 1 3)" #u8(4 5 2) t)
     378      (bytevector-copy! t 1 f 2)
     379      (test "(bytevector-copy! t 1 f 1)" #u8(4 5 6) t)
     380      (bytevector-copy! t 0 f 1)
     381      (test "(bytevector-copy! t 0 f)" #u8(4 5 6) t)))
     382
     383  (test-group "bytevector-append"
     384    (test-error (bytevector-append #u8() 1))
     385    (test #u8() (bytevector-append))
     386    (test #u8(0) (bytevector-append #u8(0)))
     387    (test #u8() (bytevector-append #u8() #u8()))
     388    (test #u8(0 1) (bytevector-append #u8(0) #u8(1)))
     389    (test #u8(0 1 2 3 4 5) (bytevector-append #u8(0 1) #u8(2 3) #u8(4 5)))))
    345390
    346391(define-syntax catch
Note: See TracChangeset for help on using the changeset viewer.