Commit bef7d4fa authored by Erick's avatar Erick

Added R7RS blobs

parent 785df565
;;;;
;;;; extract-doc.stk -- Extrcat Documentation from STklos source files
;;;;
;;;; Copyright © 2000-2005 Erick Gallesio - I3S-CNRS/ESSI <eg@unice.fr>
;;;;
;;;;
;;;;
;;;; Copyright © 2000-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: 24-Nov-2000 11:08 (eg)
;;;; Last file update: 5-Apr-2005 21:38 (eg)
;;;; Last file update: 20-Apr-2011 10:24 (eg)
;;;;
(define start-doc-rgxp (string->regexp "^<doc "))
......@@ -62,11 +62,11 @@
;; Determine the type (procedure, syntax, ..) of this header
(let ((item (read in)))
(case item
((ext EXT) (set! type 'extended))
((ext-syntax EXT-SYNTAX) (set! type 'extended-syntax))
((syntax SYNTAX) (set! type 'syntax))
(else (set! type 'procedure)
(set! l (list item)))))
((ext EXT R7RS) (set! type 'extended))
((ext-syntax EXT-SYNTAX SYNTAX-R7RS) (set! type 'extended-syntax))
((syntax SYNTAX) (set! type 'syntax))
(else (set! type 'procedure)
(set! l (list item)))))
;; Read all the item on the line
(do ((proc (read in) (read in)))
((eof-object? proc))
......@@ -77,12 +77,12 @@
(define (parse-synopsys in)
(parse-until in (lambda (l) (regexp-match end-synopsys-rgxp l))))
(define (parse-description in)
(define (parse-description in)
(parse-until in (lambda (l) (regexp-match end-doc-rgxp l))))
;;
;; parse-proc-starts here
;; parse-proc-starts here
;;
(let* ((infos (analyse-documentation-header first-line))
(type (car infos))
......@@ -111,7 +111,7 @@
;======================================================================
;
; Program starts here
; Program starts here
;
;======================================================================
(when (null? (argv))
......
......@@ -21,7 +21,7 @@
;;;;
;;;; Author: Erick Gallesio [eg@unice.fr]
;;;; Creation date: 17-Apr-2011 19:36 (eg)
;;;; Last file update: 17-Apr-2011 22:23 (eg)
;;;; Last file update: 20-Apr-2011 10:23 (eg)
;;;;
;;;; ----------------------------------------------------------------------
......@@ -31,7 +31,7 @@
;;;; ==== 6.3.2 Pairs and lists
#|
<doc r7rs-proc make-list
<doc R7RS make-list
* (make-list k)
* (make-list k fill)
*
......@@ -48,7 +48,7 @@ doc>
;;;; ----------------------------------------------------------------------
#|
<doc r7rs-proc string-map
<doc R7RS string-map
* (string-map proc string1 string2 ...)
*
* The |strings| must be strings, and |proc| must be a procedure taking as
......@@ -92,7 +92,7 @@ doc>
(list->string res)))
#|
<doc r7rs-proc vector-map
<doc R7RS vector-map
* (vector-map proc vector1 vector2 ...)
*
* The |vectors| must be vectors, and |proc| must be a procedure
......@@ -130,7 +130,7 @@ doc>
(list->vector (apply map proc (map vector->list vectors))))
#|
<doc r7rs-proc string-for-each
<doc R7RS string-for-each
* (string-for-each proc string1 string2 ...)
*
* The arguments to |string-for-each| are like the arguments to
......@@ -161,7 +161,7 @@ doc>
#|
<doc r7rs-proc vector-for-each
<doc R7RS vector-for-each
* (vector-for-each proc vector1 vector2 ...)
*
* The arguments to |vector-for-each| are like the arguments to
......
;;;;
;;;
;;;; srfi-74.stk -- SRFI-74 implementation
;;;;
;;;; Copyright 2010 Erick Gallesio - Polytech'Nice-Sophia <eg@unice.fr>
;;;;
;;;;
;;;; Copyright 2010-2011 Erick Gallesio - Polytech'Nice-Sophia <eg@unice.fr>
;;;;
;;;; Author: Michael Sperber
;;;; Modified by: Erick Gallesio [eg@unice.fr]
;;;; Creation date: 2005
;;;; Last file update: 4-Apr-2010 19:55 (eg)
;;;; Last file update: 20-Apr-2011 09:39 (eg)
;;;;
;;;; This code is an adaptation of the reference implementation provided
;;;; with the SRFI document by Michael Sperber.
;;;; This code is an adaptation of the reference implementation provided
;;;; with the SRFI document by Michael Sperber.
; Octet-addressed binary objects
; Copyright (C) Michael Sperber (2005). All Rights Reserved.
;
; Copyright (C) Michael Sperber (2005). All Rights Reserved.
;
; Permission is hereby granted, free of charge, to any person
; obtaining a copy of this software and associated documentation files
; (the "Software"), to deal in the Software without restriction,
......@@ -22,10 +22,10 @@
; publish, distribute, sublicense, and/or sell copies of the Software,
; and to permit persons to whom the Software is furnished to do so,
; subject to the following conditions:
;
;
; The above copyright notice and this permission notice shall be
; included in all copies or substantial portions of the Software.
;
;
; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
......@@ -42,9 +42,8 @@
(require "srfi-66")
(define-module SRFI-74
(export endianness blob? make-blob blob-length
blob-u8-ref blob-s8-ref
blob-u8-set! blob-s8-set!
(export endianness
blob-s8-ref blob-s8-set!
blob-uint-ref blob-sint-ref
blob-uint-set! blob-sint-set!
......@@ -60,10 +59,12 @@
blob-s64-native-ref blob-u64-set! blob-s64-set!
blob-u64-native-set! blob-s64-native-set!
blob=? blob-copy! blob-copy blob->u8-list u8-list->blob
blob=? blob->u8-list u8-list->blob
blob->uint-list blob->sint-list uint-list->
blob sint-list->blob)
blob sint-list->blob
srfi74-blob-copy!)
(define *endianness/little* (list 'little))
(define *endianness/big* (list 'big))
......@@ -76,21 +77,8 @@
((endianness big) (in-module SRFI-74 *endianness/big*))
((endianness native) (in-module SRFI-74 *endianness/native*))))
(define blob? u8vector?)
(define (make-blob k)
(make-u8vector k 0))
(define (blob-length b)
(u8vector-length b))
(define (blob-u8-ref b k)
(u8vector-ref b k))
(define (blob-u8-set! b k octet)
(u8vector-set! b k octet))
(define (blob-s8-ref b k)
(u8->s8 (u8vector-ref b k)))
(u8->s8 (blob-u8-ref b k)))
(define (u8->s8 octet)
(if (> octet 127)
......@@ -98,7 +86,7 @@
octet))
(define (blob-s8-set! b k val)
(u8vector-set! b k (s8->u8 val)))
(blob-u8-set! b k (s8->u8 val)))
(define (s8->u8 val)
(if (negative? val)
......@@ -127,10 +115,10 @@
(eq? (endianness big) endness)
0
(lambda (index acc)
(+ (u8vector-ref blob index) (arithmetic-shift acc 8)))))
(+ (blob-u8-ref blob index) (arithmetic-shift acc 8)))))
(define (blob-sint-ref size endness blob index)
(let ((high-byte (u8vector-ref blob
(let ((high-byte (blob-u8-ref blob
(if (eq? endness (endianness big))
index
(- (+ index size) 1)))))
......@@ -141,13 +129,13 @@
(eq? (endianness big) endness)
0
(lambda (index acc)
(+ (- 255 (u8vector-ref blob index))
(+ (- 255 (blob-u8-ref blob index))
(arithmetic-shift acc 8))))))
(index-iterate index size
(eq? (endianness big) endness)
0
(lambda (index acc)
(+ (u8vector-ref blob index) (arithmetic-shift acc 8)))))))
(+ (blob-u8-ref blob index) (arithmetic-shift acc 8)))))))
(define (make-uint-ref size)
(cut blob-uint-ref size <> <> <>))
......@@ -159,7 +147,7 @@
(index-iterate index size (eq? (endianness little) endness)
val
(lambda (index acc)
(u8vector-set! blob index (remainder acc 256))
(blob-u8-set! blob index (remainder acc 256))
(quotient acc 256)))
(values))
......@@ -168,17 +156,17 @@
(index-iterate index size (eq? (endianness little) endness)
(- -1 val)
(lambda (index acc)
(u8vector-set! blob index (- 255 (remainder acc 256)))
(blob-u8-set! blob index (- 255 (remainder acc 256)))
(quotient acc 256)))
(index-iterate index size (eq? (endianness little) endness)
val
(lambda (index acc)
(u8vector-set! blob index (remainder acc 256))
(blob-u8-set! blob index (remainder acc 256))
(quotient acc 256))))
(values))
(define (make-uint-set! size)
(cut blob-uint-set! size <> <> <> <>))
(define (make-sint-set! size)
......@@ -227,24 +215,19 @@
; Auxiliary stuff
(define (blob-copy! source source-start target target-start count)
(u8vector-copy! source source-start target target-start count))
(define (srfi74-blob-copy! source source-start target target-start count)
;; SRFI-74 defines a blob-copy! which is incompatible with R7RS.
(partial-blob-copy! source source-start (+ source-start count) target target-start))
(define (blob-copy b)
(u8vector-copy b))
(define (blob=? b1 b2)
(u8vector=? b1 b2))
(equal? b1 b2))
(define (blob->u8-list b)
(u8vector->list b))
(define (blob->s8-list b)
(map u8->s8 (u8vector->list b)))
(map u8->s8 (blob->u8-list b)))
(define (u8-list->blob l)
(list->u8vector l))
(define (s8-list->blob l)
(list->u8vector (map s8->u8 l)))
(u8-list->blob (map s8->u8 l)))
(define (make-blob->int-list blob-ref)
(lambda (size endness b)
......@@ -276,5 +259,17 @@
)
;; ----------------------------------------------------------------------
(select-module stklos)
;; Redefine blob-copy! to accept either 2 or 5 parameters to comply both R7RS and
;; SRFI-74
(let ((r7rs-blob-copy! (in-module |SCHEME| blob-copy!)))
(set! blob-copy!
(lambda args
(case (length args)
((2) (apply r7rs-blob-copy args))
((5) (apply srfi74-blob-copy! args))
(else (error 'blob-copy! "number of parameters must be 2 or 5."))))))
(import SRFI-74)
(provide "srfi-74")
......@@ -2,7 +2,7 @@
#
# Author: Erick Gallesio [eg@unice.fr]
# Creation date: 11-Apr-2000 10:30 (eg)
# Last file update: 3-Oct-2009 21:51 (eg)
# Last file update: 18-Apr-2011 23:49 (eg)
CC = @CC@
CFLAGS = @CFLAGS@ @STKCFLAGS@
......@@ -27,7 +27,7 @@ if NO_THREAD
THREAD_FILES = thread-none.c mutex-none.c
endif
stklos_SOURCES = base64.c boolean.c boot.c box.c char.c cond.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 \
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 \
......@@ -42,14 +42,14 @@ stklos_SOURCES = base64.c boolean.c boot.c box.c char.c cond.c \
### extend.c fport.c hash.c keyword.c lib.c list.c misc.c number.c \
### object.c path.c port.c print.c proc.c process.c promise.c read.c \
### regexp.c signal.c sio.c sport.c str.c symbol.c system.c \
### uvector.c vector.c vm.c
###
###
### uvector.c vector.c vm.c
###
###
### stklos_SOURCES = stklos.c
# gtklib = @GTK_CONFIG_LIBS@
# COMPAT LIB
# COMPAT LIB
#compatlib = -L$(top_srcdir)/compat -lcompat
# GC LIBRARY
......@@ -57,7 +57,7 @@ gc = @GC@
gclib = @GCLIB@
gcinc = @GCINC@
# GMP LIBRARY
# GMP LIBRARY
gmp = @GMP@
gmplib = @GMPLIB@
gmpinc = @GMPINC@
......@@ -72,7 +72,7 @@ ffi = @FFI@
ffilib = @FFILIB@
ffiinc = @FFIINC@
stklos_LDADD = $(compatlib) $(gmplib) $(pcrelib) $(ffilib) $(gclib) -lm
stklos_LDADD = $(compatlib) $(gmplib) $(pcrelib) $(ffilib) $(gclib) -lm
stklos_LDFLAGS = @SH_MAIN_LOAD_FLAGS@
INCLUDES = $(gmpinc) $(pcreinc) $(ffiinc) $(gcinc)
......@@ -81,7 +81,7 @@ struct.o cond.o: struct.h
doc: $(DOCDB)
$(DOCDB): $(stklos_SOURCES)
$(DOCDB): $(stklos_SOURCES)
./stklos -b boot.img -c -q -f ../doc/extract-doc $(stklos_SOURCES) > $(DOCDB)
clean:
......
......@@ -19,7 +19,7 @@
#
# Author: Erick Gallesio [eg@unice.fr]
# Creation date: 11-Apr-2000 10:30 (eg)
# Last file update: 3-Oct-2009 21:51 (eg)
# Last file update: 18-Apr-2011 23:49 (eg)
VPATH = @srcdir@
......@@ -53,13 +53,13 @@ CONFIG_CLEAN_FILES = extraconf.h
CONFIG_CLEAN_VPATH_FILES =
am__installdirs = "$(DESTDIR)$(bindir)" "$(DESTDIR)$(extraincdir)"
PROGRAMS = $(bin_PROGRAMS)
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 uvector.c vector.c vm.c vport.c \
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 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 = \
......@@ -69,21 +69,21 @@ am__stklos_SOURCES_DIST = base64.c boolean.c boot.c box.c char.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) 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) \
uvector.$(OBJEXT) vector.$(OBJEXT) vm.$(OBJEXT) \
vport.$(OBJEXT) $(am__objects_1)
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) 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) \
......@@ -269,7 +269,7 @@ 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 boolean.c boot.c box.c char.c cond.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 \
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 \
......@@ -284,14 +284,14 @@ stklos_SOURCES = base64.c boolean.c boot.c box.c char.c cond.c \
### extend.c fport.c hash.c keyword.c lib.c list.c misc.c number.c \
### object.c path.c port.c print.c proc.c process.c promise.c read.c \
### regexp.c signal.c sio.c sport.c str.c symbol.c system.c \
### uvector.c vector.c vm.c
###
###
### uvector.c vector.c vm.c
###
###
### stklos_SOURCES = stklos.c
# gtklib = @GTK_CONFIG_LIBS@
# COMPAT LIB
# COMPAT LIB
#compatlib = -L$(top_srcdir)/compat -lcompat
# GC LIBRARY
......@@ -299,7 +299,7 @@ gc = @GC@
gclib = @GCLIB@
gcinc = @GCINC@
# GMP LIBRARY
# GMP LIBRARY
gmp = @GMP@
gmplib = @GMPLIB@
gmpinc = @GMPINC@
......@@ -313,7 +313,7 @@ pcreinc = @PCREINC@
ffi = @FFI@
ffilib = @FFILIB@
ffiinc = @FFIINC@
stklos_LDADD = $(compatlib) $(gmplib) $(pcrelib) $(ffilib) $(gclib) -lm
stklos_LDADD = $(compatlib) $(gmplib) $(pcrelib) $(ffilib) $(gclib) -lm
stklos_LDFLAGS = @SH_MAIN_LOAD_FLAGS@
INCLUDES = $(gmpinc) $(pcreinc) $(ffiinc) $(gcinc)
all: stklosconf.h
......@@ -418,6 +418,7 @@ 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@
......@@ -706,7 +707,7 @@ struct.o cond.o: struct.h
doc: $(DOCDB)
$(DOCDB): $(stklos_SOURCES)
$(DOCDB): $(stklos_SOURCES)
./stklos -b boot.img -c -q -f ../doc/extract-doc $(stklos_SOURCES) > $(DOCDB)
clean:
......
/*
* 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>