diff --git a/lib/rnrs/bytevectors.scm b/lib/rnrs/bytevectors.scm new file mode 100644 index 00000000..dce1ed8c --- /dev/null +++ b/lib/rnrs/bytevectors.scm @@ -0,0 +1,22 @@ +;; rnrs compatibility +(define (bytevector-u32-native-set! bv index value) + (when (not (= 0 index)) (error "bytevector-u32-native-set! index not zero: " index " value: " value)) + (let ((x (list + (modulo value #x100) + (quotient (modulo value #x10000) #x100) + (quotient (modulo value #x1000000) #x10000) + (quotient value #x1000000)))) + (set-car! bv (car x)) + (set-cdr! bv (cdr x)) + x)) + +(define (bytevector-u16-native-set! bv index value) + (when (not (= 0 index)) (error "bytevector-u16-native-set! index not zero: " index " value: " value)) + (let ((x (list (modulo value #x100) + (quotient (modulo value #x10000) #x100)))) + (set-car! bv (car x)) + (set-cdr! bv (cdr x)) + x)) + +(define (make-bytevector length) + (make-list length 0)) diff --git a/scm.mes b/scm.mes index fe22b8ee..5c17a406 100755 --- a/scm.mes +++ b/scm.mes @@ -52,12 +52,15 @@ (define integer? number?) +(define (make-list n . x) + (let ((fill (if (pair? x) (car x) *unspecified*))) + (let loop ((n n)) + (if (= 0 n) '() + (cons fill (loop (- n 1))))))) + (define (vector . rest) (list->vector rest)) (define (make-vector n . x) - (let ((fill (if (pair? x) (car x) *unspecified*))) - (list->vector (let loop ((n n)) - (if (= 0 n) '() - (cons fill (loop (- n 1)))))))) + (list->vector (apply make-list (cons n x)))) (define (assq-set! alist key val) (let ((entry (assq key alist))) diff --git a/test/scm.test b/test/scm.test index 520f7982..f2511546 100644 --- a/test/scm.test +++ b/test/scm.test @@ -74,6 +74,7 @@ (pass-if "vector?" (vector? #(1 2 c))) (pass-if "vector-length" (seq? (vector-length #(1)) 1)) (pass-if "list->vector" (sequal? (list->vector '(a b c)) #(a b c))) +(pass-if "make-list" (sequal? (make-list 3 1) '(1 1 1))) (pass-if "vector" (sequal? #(vector 0 1 2) #(vector 0 1 2))) (when (not guile?) (pass-if "make-vector" (sequal? (make-vector 3) #(*unspecified* *unspecified* *unspecified*))))