Commit 1109565e authored by Erick's avatar Erick

Moved R7RS (draft-1) blobs to R7RS bytevectors (Draft-3). The implementation is

now in Scheme and fully compatible with u8vectors.
parent 90c9b752
;;;;
;;;; compfile.stk -- STklos File Compiler
;;;;
;;;; Copyright 2001-2010 Erick Gallesio - I3S-CNRS/ESSI <eg@unice.fr>
;;;;
;;;;
;;;; compfile.stk -- STklos File Compiler
;;;;
;;;; Copyright 2001-2011 Erick Gallesio - I3S-CNRS/ESSI <eg@unice.fr>
;;;;
;;;;
;;;; This program is free software; you can redistribute it and/or modify
;;;; it under the terms of the GNU General Public License as published by
;;;; the Free Software Foundation; either version 2 of the License, or
;;;; (at your option) any later version.
;;;;
;;;;
;;;; This program is distributed in the hope that it will be useful,
;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;;;; GNU General Public License for more details.
;;;;
;;;;
;;;; You should have received a copy of the GNU General Public License
;;;; along with this program; if not, write to the Free Software
;;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307,
;;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307,
;;;; USA.
;;;;
;;;;
;;;; Author: Erick Gallesio [eg@unice.fr]
;;;; Creation date: 17-Mar-2001 12:11 (eg)
;;;; Last file update: 10-Aug-2010 12:27 (eg)
;;;; Last file update: 19-Aug-2011 13:51 (eg)
;;;;
(select-module STKLOS-COMPILER)
......@@ -43,7 +43,7 @@
(list :version (version)
:globals globs
:expanders (expander-published-sources))))
(let ((out (open-output-file output))
(globs (compiler-known-globals))
(tm (clock))
......@@ -51,7 +51,7 @@
;; Clear the list containing macros sources
(expander-published-reset!)
;; Defer warning til the end of the compilation of file
;(compiler:warn-use-undefined-postpone #t)
......@@ -65,31 +65,31 @@
(format out "#!/usr/bin/env stklos-script\n")
(format out "; A -*- Scheme -*- generated file *DO NOT EDIT**\n")
(format out "STklos ~S\n" (compute-file-informations globs))
(let ((code (assemble (reverse! *code-instr*))))
(when (compiler:show-assembly-code)
;;Write the assembly code and code vector
(format out "\n#|\n")
(format out "\n#|\n")
(disassemble-code code out)
(format out "\n~S\n|\#\n" code))
;; Write new constants as a vector
(format out "#~S\n" *code-constants*)
;; Write byte-code
(%dump-code out code))
;; Close file
(close-output-port out))
;; Show undefined symbols
(compiler-show-undefined-symbols)
;; Display time used to compile file
(when (and (interactive-port? (current-input-port))
(compiler:time-display))
(format #t "Compilation time ~S\n" (- (clock) tm)))
(format #t "Compilation time ~Sms\n" (- (clock) tm)))
;; Restore Compiler flags
(compiler:warn-use-undefined-postpone copts)))
......
;;;;
;;;; r7rs.stk -- R7RS support (Draft-1)
;;;; r7rs.stk -- R7RS support (Draft-3)
;;;;
;;;; Copyright © 2011 Erick Gallesio - Polytech'Nice-Sophia <eg@unice.fr>
;;;;
......@@ -21,15 +21,13 @@
;;;;
;;;; Author: Erick Gallesio [eg@unice.fr]
;;;; Creation date: 17-Apr-2011 19:36 (eg)
;;;; Last file update: 20-Apr-2011 10:23 (eg)
;;;; Last file update: 19-Aug-2011 13:49 (eg)
;;;;
;;;; ----------------------------------------------------------------------
;;;; 6.3 Other data types
;;;; 6.4 Pairs and lists
;;;; ----------------------------------------------------------------------
;;;; ==== 6.3.2 Pairs and lists
#|
<doc R7RS make-list
* (make-list k)
......@@ -43,8 +41,201 @@ doc>
(define (make-list k :optional (fill (void)))
(vector->list (make-vector k fill)))
;;;; ----------------------------------------------------------------------
;;;; 6.8 Vectors
;;;; ----------------------------------------------------------------------
#|
<doc R7RS vector->string string->vector
* (vector->string string)
* (string->vector vector)
*
* |Vector->string| returns a newly allocated string of the
* objects contained in the elements of |vector|, which must
* be characters allowed in a string. |String->vector| returns
* a newly created vector initialized to the elements of the
* string |string|.
doc>
|#
(define (vector->string v)
(unless (vector? v)
(error "bad vector ~S" v))
(let ((l (vector->list v)))
(unless (every char? l)
(error "all elements of the vector ~S must be characters" v))
(list->string l)))
(define (string->vector str)
(unless (string? str)
(error "bad string ~S" str))
(list->vector (string->list str)))
;;;; ----------------------------------------------------------------------
;;;; 6.9 Bytevectors
;;;; ----------------------------------------------------------------------
#|
<doc R7RS make-bytevector
* (make-bytevector)
*
* Returns a newly allocated bytevector of k bytes. The initial
* contents of each element is 0.
doc>
|#
(define (make-bytevector size :optional (default 0))
(%make-uvector 1 size default))
#|
<doc R7RS bytevector?
* (bytevector? obj)
*
* Returns |!t| if |obj| is a bytevector and returns |!f| otherwise.
doc>
|#
(define (bytevector? obj)
(%uvector? 1 obj))
#|
<doc R7RS bytevector-length
* (bytevector-length bytevector)
*
* Returns the length of |bytevector| in bytes as an exact integer.
doc>
|#
(define (bytevector-length bv)
(%uvector-length 1 bv))
#|
<doc R7RS bytevector-u8-ref
* (bytevector-u8-ref bytevector k)
*
* Returns the byte at index |k| of |bytevector| as an exact integer in the
* range [0..255].
doc>
|#
(define (bytevector-u8-ref bv idx)
(%uvector-ref 1 bv idx))
#|
<doc EXT bytevector-u8-set!
* (bytevector-u8-ref bytevector k u8)
*
* Stores |u8| in the byte at index |k| of |bytevector|. |u8| must be an
* exact integer in the range [0..255]. The value returned by
* |bytevector-u8-set!| is ,(emph "void").
doc>
|#
(define (bytevector-u8-set! bv idx val)
(%uvector-set! 1 bv idx val))
#|
<doc R7RS bytevector-copy
* (bytevector-copy bytevector)
*
* Returns a newly allocated bytevector containing the same bytes as |bytevector|.
doc>
|#
(define (bytevector-copy bv)
(unless (bytevector? bv)
(error "bad bytevector ~S" bv))
(let* ((len (bytevector-length bv))
(new (make-bytevector len)))
(dotimes (i len)
(bytevector-u8-set! new i (bytevector-u8-ref bv i)))
new))
#|
<doc R7RS bytevector-copy!
* (bytevector-copy! from to)
*
* Copy the bytes of bytevector |from| to bytevector |to|, which must not be shorter.
* The value returned by |bytevector-copy!| is ,(emph "void").
doc>
|#
(define (bytevector-copy! from to)
(unless (bytevector? from)
(error "bad bytevector ~S" from))
(unless (bytevector? to)
(error "bad bytevector ~S" to))
(let ((len-from (bytevector-length from))
(len-to (bytevector-length to)))
(when (> len-from len-to)
(error "bytevector ~S is too long for copying it in ~S" from to))
(dotimes (i len-from)
(bytevector-u8-set! to i (bytevector-u8-ref from i)))))
#|
<doc R7RS bytevector-copy-partial
* (bytevector-copy-partial bytevector start end)
*
* Returns a newly allocated bytevector containing the bytes in |bytevector|
* between |start| (inclusive) and |end| (exclusive).
doc>
|#
(define (bytevector-copy-partial bv start end)
(unless (bytevector? bv)
(error "bad bytevector ~S" bv))
(unless (integer? start)
(error "bad starting index ~S" start))
(unless (integer? end)
(error "bad ending intex ~S" end))
(let* ((len (- end start))
(new (make-bytevector len)))
(dotimes (i len)
(bytevector-u8-set! new i (bytevector-u8-ref bv (+ start i))))
new))
#|
<doc R7RS bytevector-copy-partial!
* (bytevector-copy-partial! from start end to at)
*
* Copy the bytes of |bytevector| from between |start| and |end| to bytevector
* |to|, starting at |at|. The order in which bytes are copied
* is unspecified, except that if the source and destination
* overlap, copying takes place as if the source is first copied
* into a temporary bytevector and then into the destination.
* The value returned by |partial-bytevector-copy!| is ,(emph "void").
doc>
|#
(define (bytevector-copy-partial! from start end to at)
(unless (bytevector? from)
(error "bad bytevector ~S" from))
(unless (bytevector? to)
(error "bad bytevector ~S" to))
(unless (integer? start)
(error "bad starting index ~S" start))
(unless (integer? end)
(error "bad ending index ~S" end))
(unless (integer? at)
(error "bad destination index ~S" at))
(let ((len (- end start))
(to-len (bytevector-length to)))
(when (> (+ at len) to-len)
(error "cannot copy ~S bytes in ~S starting at index ~S" len to at))
(cond
((and (eq? from to) (= start at))
;; nothing to do
(void))
((and (eq? from to) (> (+ at len) end))
;; may overlap => copy in reverse
(let ((j (- (+ at len) 1))
(k (- end 1)))
(dotimes (i len)
(bytevector-u8-set! to (- j i) (bytevector-u8-ref from (- k i ))))))
(else
;; normal copy
(dotimes (i len)
(bytevector-u8-set! to (+ at i) (bytevector-u8-ref from (+ start i))))))))
;;;; ----------------------------------------------------------------------
;;;; 6.4 Control features
;;;; 6.10 Control features
;;;; ----------------------------------------------------------------------
#|
......
;;;;
;;;; srfi-4.stk -- Implementation of SRFI-4 (Uniform Vectors)
;;;;
;;;; Copyright 2001-2006 Erick Gallesio - I3S-CNRS/ESSI <eg@unice.fr>
;;;;
;;;;
;;;;
;;;; Copyright 2001-2011 Erick Gallesio - I3S-CNRS/ESSI <eg@unice.fr>
;;;;
;;;;
;;;; This program is free software; you can redistribute it and/or modify
;;;; it under the terms of the GNU General Public License as published by
;;;; the Free Software Foundation; either version 2 of the License, or
;;;; (at your option) any later version.
;;;;
;;;;
;;;; This program is distributed in the hope that it will be useful,
;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;;;; GNU General Public License for more details.
;;;;
;;;;
;;;; You should have received a copy of the GNU General Public License
;;;; along with this program; if not, write to the Free Software
;;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307,
;;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307,
;;;; USA.
;;;;
;;;;
;;;; Author: Erick Gallesio [eg@unice.fr]
;;;; Creation date: 15-Apr-2001 11:36 (eg)
;;;; Last file update: 27-Sep-2006 13:57 (eg)
;;;; Last file update: 19-Aug-2011 11:03 (eg)
;;;;
;; This implementation is built on the uniform layer present in the file
;; src/vector.c. Nearly everything is written in Scheme
;; define the C primitives to avoid warnings
(define %list->uvector #f)
(define %uvector->list #f)
(define %uvector-set! #f)
(define %uvector-ref #f)
(define %uvector-length #f)
(define %uvector #f)
(define %uvector? #f)
(define %make-uvector #f)
;; Internal coding (don't change it without modifying file vector.c
;; src/uvector.c. Nearly everything is written in Scheme
;; Internal coding (don't change it without modifying file uvector.c
;; UVECT_S8 0
;; UVECT_U8 1
;; UVECT_S16 2
......
......@@ -2,7 +2,7 @@
#
# Author: Erick Gallesio [eg@unice.fr]
# Creation date: 11-Apr-2000 10:30 (eg)
# Last file update: 30-Apr-2011 23:54 (eg)
# Last file update: 19-Aug-2011 11:07 (eg)
CC = @CC@
CFLAGS = @CFLAGS@ @STKCFLAGS@
......@@ -27,8 +27,8 @@ if NO_THREAD
THREAD_FILES = thread-none.c mutex-none.c
endif
stklos_SOURCES = base64.c blob.c boolean.c boot.c box.c char.c cond.c \
cpointer.c dynload.c env.c error.c extend.c ffi.c fixnum.c \
stklos_SOURCES = base64.c boolean.c boot.c box.c char.c \
cond.c cpointer.c dynload.c env.c error.c extend.c ffi.c fixnum.c \
fport.c gnu-getopt.c gnu-glob.c hash.c keyword.c lib.c \
list.c misc.c md5.c number.c object.c parameter.c \
path.c port.c print.c proc.c process.c promise.c read.c regexp.c \
......
......@@ -19,7 +19,7 @@
#
# Author: Erick Gallesio [eg@unice.fr]
# Creation date: 11-Apr-2000 10:30 (eg)
# Last file update: 30-Apr-2011 23:54 (eg)
# Last file update: 19-Aug-2011 11:07 (eg)
VPATH = @srcdir@
......@@ -53,15 +53,15 @@ CONFIG_CLEAN_FILES = extraconf.h
CONFIG_CLEAN_VPATH_FILES =
am__installdirs = "$(DESTDIR)$(bindir)" "$(DESTDIR)$(extraincdir)"
PROGRAMS = $(bin_PROGRAMS)
am__stklos_SOURCES_DIST = base64.c blob.c boolean.c boot.c box.c \
char.c cond.c cpointer.c dynload.c env.c error.c extend.c \
ffi.c fixnum.c fport.c gnu-getopt.c gnu-glob.c hash.c \
keyword.c lib.c list.c misc.c md5.c number.c object.c \
parameter.c path.c port.c print.c proc.c process.c promise.c \
read.c regexp.c signal.c sio.c socket.c sport.c stklos.c str.c \
struct.c symbol.c system.c utf8.c uvector.c vector.c vm.c \
vport.c thread-none.c mutex-none.c thread-common.c \
thread-pthreads.c mutex-common.c mutex-pthreads.c
am__stklos_SOURCES_DIST = base64.c boolean.c boot.c box.c char.c \
cond.c cpointer.c dynload.c env.c error.c extend.c ffi.c \
fixnum.c fport.c gnu-getopt.c gnu-glob.c hash.c keyword.c \
lib.c list.c misc.c md5.c number.c object.c parameter.c path.c \
port.c print.c proc.c process.c promise.c read.c regexp.c \
signal.c sio.c socket.c sport.c stklos.c str.c struct.c \
symbol.c system.c utf8.c uvector.c vector.c vm.c vport.c \
thread-none.c mutex-none.c thread-common.c thread-pthreads.c \
mutex-common.c mutex-pthreads.c
@NO_THREAD_FALSE@@PTHREADS_TRUE@am__objects_1 = \
@NO_THREAD_FALSE@@PTHREADS_TRUE@ thread-common.$(OBJEXT) \
@NO_THREAD_FALSE@@PTHREADS_TRUE@ thread-pthreads.$(OBJEXT) \
......@@ -69,21 +69,21 @@ am__stklos_SOURCES_DIST = base64.c blob.c boolean.c boot.c box.c \
@NO_THREAD_FALSE@@PTHREADS_TRUE@ mutex-pthreads.$(OBJEXT)
@NO_THREAD_TRUE@am__objects_1 = thread-none.$(OBJEXT) \
@NO_THREAD_TRUE@ mutex-none.$(OBJEXT)
am_stklos_OBJECTS = base64.$(OBJEXT) blob.$(OBJEXT) boolean.$(OBJEXT) \
boot.$(OBJEXT) box.$(OBJEXT) char.$(OBJEXT) cond.$(OBJEXT) \
cpointer.$(OBJEXT) dynload.$(OBJEXT) env.$(OBJEXT) \
error.$(OBJEXT) extend.$(OBJEXT) ffi.$(OBJEXT) \
fixnum.$(OBJEXT) fport.$(OBJEXT) gnu-getopt.$(OBJEXT) \
gnu-glob.$(OBJEXT) hash.$(OBJEXT) keyword.$(OBJEXT) \
lib.$(OBJEXT) list.$(OBJEXT) misc.$(OBJEXT) md5.$(OBJEXT) \
number.$(OBJEXT) object.$(OBJEXT) parameter.$(OBJEXT) \
path.$(OBJEXT) port.$(OBJEXT) print.$(OBJEXT) proc.$(OBJEXT) \
process.$(OBJEXT) promise.$(OBJEXT) read.$(OBJEXT) \
regexp.$(OBJEXT) signal.$(OBJEXT) sio.$(OBJEXT) \
socket.$(OBJEXT) sport.$(OBJEXT) stklos.$(OBJEXT) \
str.$(OBJEXT) struct.$(OBJEXT) symbol.$(OBJEXT) \
system.$(OBJEXT) utf8.$(OBJEXT) uvector.$(OBJEXT) \
vector.$(OBJEXT) vm.$(OBJEXT) vport.$(OBJEXT) $(am__objects_1)
am_stklos_OBJECTS = base64.$(OBJEXT) boolean.$(OBJEXT) boot.$(OBJEXT) \
box.$(OBJEXT) char.$(OBJEXT) cond.$(OBJEXT) cpointer.$(OBJEXT) \
dynload.$(OBJEXT) env.$(OBJEXT) error.$(OBJEXT) \
extend.$(OBJEXT) ffi.$(OBJEXT) fixnum.$(OBJEXT) \
fport.$(OBJEXT) gnu-getopt.$(OBJEXT) gnu-glob.$(OBJEXT) \
hash.$(OBJEXT) keyword.$(OBJEXT) lib.$(OBJEXT) list.$(OBJEXT) \
misc.$(OBJEXT) md5.$(OBJEXT) number.$(OBJEXT) object.$(OBJEXT) \
parameter.$(OBJEXT) path.$(OBJEXT) port.$(OBJEXT) \
print.$(OBJEXT) proc.$(OBJEXT) process.$(OBJEXT) \
promise.$(OBJEXT) read.$(OBJEXT) regexp.$(OBJEXT) \
signal.$(OBJEXT) sio.$(OBJEXT) socket.$(OBJEXT) \
sport.$(OBJEXT) stklos.$(OBJEXT) str.$(OBJEXT) \
struct.$(OBJEXT) symbol.$(OBJEXT) system.$(OBJEXT) \
utf8.$(OBJEXT) uvector.$(OBJEXT) vector.$(OBJEXT) vm.$(OBJEXT) \
vport.$(OBJEXT) $(am__objects_1)
stklos_OBJECTS = $(am_stklos_OBJECTS)
am__DEPENDENCIES_1 =
stklos_DEPENDENCIES = $(am__DEPENDENCIES_1) $(am__DEPENDENCIES_1) \
......@@ -265,8 +265,8 @@ DOCDB = DOCDB
# what thread support do we put in?
@PTHREADS_TRUE@THREAD_FILES = thread-common.c thread-pthreads.c mutex-common.c mutex-pthreads.c
stklos_SOURCES = base64.c blob.c boolean.c boot.c box.c char.c cond.c \
cpointer.c dynload.c env.c error.c extend.c ffi.c fixnum.c \
stklos_SOURCES = base64.c boolean.c boot.c box.c char.c \
cond.c cpointer.c dynload.c env.c error.c extend.c ffi.c fixnum.c \
fport.c gnu-getopt.c gnu-glob.c hash.c keyword.c lib.c \
list.c misc.c md5.c number.c object.c parameter.c \
path.c port.c print.c proc.c process.c promise.c read.c regexp.c \
......@@ -414,7 +414,6 @@ distclean-compile:
-rm -f *.tab.c
@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/base64.Po@am__quote@
@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/blob.Po@am__quote@
@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/boolean.Po@am__quote@
@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/boot.Po@am__quote@
@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/box.Po@am__quote@
......
/*
* blob.c -- Implementation of R7RS blobs
*
* Copyright 2011 Erick Gallesio - Polytech'Nice-Sophia <eg@unice.fr>
*
*
* This program is free software; you can redistribute it and/or modify
* it under the terms of the GNU General Public License as published by
* the Free Software Foundation; either version 2 of the License, or
* (at your option) any later version.
*
* This program is distributed in the hope that it will be useful,
* but WITHOUT ANY WARRANTY; without even the implied warranty of
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
* GNU General Public License for more details.
*
* You should have received a copy of the GNU General Public License
* along with this program; if not, write to the Free Software
* Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307,
* USA.
*
* Author: Erick Gallesio [eg@unice.fr]
* Creation date: 18-Apr-2011 23:13 (eg)
* Last file update: 20-Apr-2011 10:55 (eg)
*/
#include "stklos.h"
#include <stdint.h>
struct blob_obj {
stk_header header;
int len;
uint8_t data[1]; /* will be sized to a different value when allocated */
};
#define BLOBP(o) (BOXED_TYPE_EQ((o), tc_blob))
#define BLOB_LEN(p) (((struct blob_obj *) (p))->len)
#define BLOB_DATA(p) (((struct blob_obj *) (p))->data)
static void error_bad_blob(SCM obj)
{
STk_error("bad blob ~S", obj);
}
static void error_bad_index(SCM blob, SCM index)
{
STk_error("index ~S out of bounds for ~S", index, blob);
}
static void error_bad_value(SCM obj)
{
STk_error("bad blob value ~S (mus be between 0 and %d)", obj, UINT8_MAX);
}
static void print_blob(SCM obj, SCM port, int mode)
{
STk_fprintf(port, "#[blob len=%d @ %lx]", BLOB_LEN(obj), (unsigned long) obj);
}
static SCM make_blob(int len)
{
SCM z;
NEWCELL_ATOMIC(z, blob, sizeof(struct blob_obj) + len);
BLOB_LEN(z) = len;
memset(BLOB_DATA(z), (uint8_t) 0, len); /* rather than unspecified */
return z;
}
/* ======================================================================*/
/*
<doc R7RS make-blob
* (make-blob)
*
* Returns a newly allocated blob of k bytes. The initial
* contents of each element is 0.
doc>
*/
DEFINE_PRIMITIVE("make-blob", make_blob, subr1, (SCM value))
{
long int len = STk_integer_value(value);
if (len < 0) STk_error("bad blob length ~S", value);
return make_blob(len);
}
/*
<doc R7RS blob?
* (blob? obj)
*
* Returns |#t| if |obj| is a blob and returns |#f| otherwise.
doc>
*/
DEFINE_PRIMITIVE("blob?", blobp, subr1, (SCM obj))
{
return MAKE_BOOLEAN(BLOBP(obj));
}
/*
<doc R7RS blob-length
* (blob-length blob)
*
* Returns the length of |blob| in bytes as an exact integer.
doc>
*/
DEFINE_PRIMITIVE("blob-length", blob_length, subr1, (SCM blob))
{
if (!BLOBP(blob)) error_bad_blob(blob);
return MAKE_INT(BLOB_LEN(blob));
}
/*
<doc R7RS blob-u8-ref
* (blob-u8-ref blob k)
*
* Returns the byte at index |k| of |blob| as an exact integer in the
* range [0..255].
doc>
*/
DEFINE_PRIMITIVE("blob-u8-ref", blob_u8_ref, subr2, (SCM blob, SCM index))
{
long int ind = STk_integer_value(index);
if (!BLOBP(blob)) error_bad_blob(blob);
if (ind < 0 || ind >= BLOB_LEN(blob)) error_bad_index(blob, index);
return MAKE_INT(BLOB_DATA(blob)[ind]);
}
/*
<doc R7RS blob-u8-set!
* (blob-u8-ref blob k u8)
*
* Stores |u8| in the byte at index |k| of |blob|. |u8| must be an exact integer
* in the range [0..255]. The value returned by |blob-u8-set!| is ,(emph "void").
doc>
*/
DEFINE_PRIMITIVE("blob-u8-set!", blob_u8_set, subr3, (SCM blob, SCM index, SCM value))
{
long int ind = STk_integer_value(index);
long int val = STk_integer_value(value);
if (!BLOBP(blob)) error_bad_blob(blob);
if (ind < 0 || ind >= BLOB_LEN(blob)) error_bad_index(blob, index);
if (val < 0 || val > UINT8_MAX) error_bad_value(value);
BLOB_DATA(blob)[ind] = val;
return STk_void;
}
/*
<doc R7RS blob-copy
* (blob-copy blob)
*
* Returns a newly allocated blob containing the same bytes as |blob|.
doc>
*/
DEFINE_PRIMITIVE("blob-copy", blob_copy, subr1, (SCM blob))
{
SCM z;
if (!BLOBP(blob)) error_bad_blob(blob);
z = make_blob(BLOB_LEN(blob));
memcpy(BLOB_DATA(z), BLOB_DATA(blob), BLOB_LEN(blob));
return z;
}
/*
<doc R7RS blob-copy!
* (blob-copy! from to)
*
* Copy the bytes of blob |from- to blob |to|, which must not be shorter.
* The value returned by |blob-copy!| is ,(emph "void").
doc>
*/
DEFINE_PRIMITIVE("blob-copy!", dblob_copy, subr2, (SCM from, SCM to))
{
if (!BLOBP(from)) error_bad_blob(from);
if (!BLOBP(to)) error_bad_blob(to);
if (BLOB_LEN(to) < BLOB_LEN(from))
STk_error("blob ~S is too long for copying it in ~S", from, to);
memcpy(BLOB_DATA(to), BLOB_DATA(from), BLOB_LEN(from));
return STk_void;
}
/*
<doc R7RS partial-blob
* (partal-blob blob start end)
*
* Returns a newly allocated blob containing the bytes in |blob|
* between |start| (inclusive) and |end| (exclusive).
doc>
*/
DEFINE_PRIMITIVE("partial-blob", partial_blob, subr3, (SCM blob, SCM start, SCM end))
{
long int from = STk_integer_value(start);
long int to = STk_integer_value(end);
SCM z;
z = make_blob(to-from);
memcpy(BLOB_DATA(z), BLOB_DATA(blob)+from, to-from);
return z;
}
/*
<doc R7RS partial-blob-copy!
* (partial-blob-copy! from start end to at)
*
* Copy the bytes of |blob| from between |start| and |end| to blob
* |to|, starting at |at|. The order in which bytes are copied
* is unspecified, except that if the source and destination
* overlap, copying takes place as if the source is first copied
* into a temporary blob and then into the destination.
* The value returned by |partial-blob-copy!| is ,(emph "void").
doc>
*/
DEFINE_PRIMITIVE("partial-blob-copy!", partial_blob_copy, subr5,
(SCM from, SCM start, SCM end, SCM to, SCM at))
{
long int istart = STk_integer_value(start);
long int iend = STk_integer_value(end);
long int iat = STk_integer_value(at);
int len;
if (!BLOBP(from)) error_bad_blob(from);
if (!BLOBP(to)) error_bad_blob(to);
len = iend-istart;
if (iat + len > BLOB_LEN(to))
STk_error("cannot copy %d bytes at index ~S of ~S", len, at, to);
memmove(BLOB_DATA(to)+iat, BLOB_DATA(from)+ istart, len);
return STk_void;
}
/*
<doc EXT blob->u8-list u8-list->blob
* (blob->u8-list blob)
* (u8-list->blob list)
*
* |blob->u8-list| returns a newly allocated list of the integers contained in
* the elements of |blob|. |u8-list->blob| returns a newly created blob
* initialized to the elements of the list |list|.
doc>
*/
DEFINE_PRIMITIVE("blob->u8-list", blob2u8list, subr1, (SCM blob))
{
SCM l = STk_nil;
uint8_t *start, *end;
if (!BLOBP(blob)) error_bad_blob(blob);
start = BLOB_DATA(blob);
for (end = BLOB_DATA(blob) + BLOB_LEN(blob) - 1; end >= start; end--) {
l = STk_cons(MAKE_INT(*end), l);
}
return l;
}
DEFINE_PRIMITIVE("u8-list->blob", u8list2blob, subr1, (SCM lst))
{
SCM z;
int i, len = STk_int_length(lst);
if (len < 0) STk_error("bad list ~S", lst);
z = make_blob(len);
for (i = 0; i < len; i++) {
long int val = STk_integer_value(CAR(lst));