From: Chris Hanson Date: Tue, 3 Jan 2017 22:16:16 +0000 (-0500) Subject: First draft of bytevector primitives. X-Git-Tag: mit-scheme-pucked-9.2.12~227^2~236 X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=e1ed0fb4b488df2cd06b8d038c33cdbbc4031b5a;p=mit-scheme.git First draft of bytevector primitives. --- diff --git a/src/microcode/bytevector.c b/src/microcode/bytevector.c new file mode 100644 index 000000000..bd090dd0c --- /dev/null +++ b/src/microcode/bytevector.c @@ -0,0 +1,147 @@ +/* -*-C-*- + +Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994, + 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005, + 2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013, 2014, 2015, 2016 + Massachusetts Institute of Technology + +This file is part of MIT/GNU Scheme. + +MIT/GNU Scheme 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. + +MIT/GNU Scheme 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 MIT/GNU Scheme; if not, write to the Free Software +Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, +USA. + +*/ + +/* Bytevector primitives */ + +#include "scheme.h" +#include "prims.h" + +#define BYTEVECTOR_LENGTH(v) \ + (OBJECT_DATUM (MEMORY_REF ((v), BYTEVECTOR_LENGTH_INDEX))) + +#define BYTEVECTOR_POINTER(v) ((uint8_t *) (MEMORY_LOC ((v), BYTEVECTOR_DATA))) + +static uint8_t * +arg_bytevector (int n, unsigned long * len_r) +{ + CHECK_ARG (n, BYTEVECTOR_P); + (*len_r) = (BYTEVECTOR_LENGTH (ARG_REF (n))); + return (BYTEVECTOR_POINTER (ARG_REF (n))); +} + +static uint8_t +arg_byte (int n) +{ + CHECK_ARG (n, FIXNUM_P); + SCHEME_OBJECT argument = (ARG_REF (n)); + if (!FIXNUM_TO_ULONG_P (argument)) + error_bad_range_arg (n); + unsigned long value = (FIXNUM_TO_ULONG (argument)); + if (value >= 0x100) + error_bad_range_arg (n); + return (uint8_t) value; +} + +static SCHEME_OBJECT +allocate_bytevector (unsigned long nbytes) +{ + return (allocate_non_marked_vector + (TC_BYTEVECTOR, + ((BYTES_TO_WORDS (nbytes)) + BYTEVECTOR_LENGTH_SIZE), + true)); +} + +static SCHEME_OBJECT +memory_to_bytevector (unsigned long n_bytes, const void * vp) +{ + SCHEME_OBJECT result = (allocate_bytevector (n_bytes)); + memcpy ((BYTEVECTOR_POINTER (result)), vp, n_bytes); + return (result); +} + +DEFINE_PRIMITIVE ("allocate_bytevector", Prim_allocate_bytevector, 1, 1, 0) +{ + PRIMITIVE_HEADER (1); + PRIMITIVE_RETURN (allocate_bytevector (arg_ulong_integer (1))); +} + +DEFINE_PRIMITIVE ("bytevector?", Prim_bytevector_p, 1, 1, 0) +{ + PRIMITIVE_HEADER (1); + PRIMITIVE_RETURN (BOOLEAN_TO_OBJECT (BYTEVECTOR_P (ARG_REF (1)))); +} + +DEFINE_PRIMITIVE ("bytevector-length", Prim_bytevector_length, 1, 1, 0) +{ + PRIMITIVE_HEADER (1); + CHECK_ARG (1, BYTEVECTOR_P); + PRIMITIVE_RETURN (ulong_to_integer (BYTEVECTOR_LENGTH (ARG_REF (1)))); +} + +DEFINE_PRIMITIVE ("bytevector-u8-ref", Prim_bytevector_u8_ref, 2, 2, 0) +{ + PRIMITIVE_HEADER (2); + { + unsigned long length; + uint8_t * v = (arg_bytevector (1, (&length))); + unsigned long index = (arg_ulong_index_integer (2, length)); + PRIMITIVE_RETURN (ulong_to_integer (v[index])); + } +} + +DEFINE_PRIMITIVE ("bytevector-u8-set!", Prim_bytevector_u8_set, 3, 3, 0) +{ + PRIMITIVE_HEADER (3); + { + unsigned long length; + uint8_t * v = (arg_bytevector (1, (&length))); + unsigned long index = (arg_ulong_index_integer (2, length)); + uint8_t value = (arg_byte (3)); + v[index] = value; + } + PRIMITIVE_RETURN (UNSPECIFIC); +} + +DEFINE_PRIMITIVE ("bytevector-copy", Prim_bytevector_copy, 3, 3, 0) +{ + PRIMITIVE_HEADER (3); + { + unsigned long length; + uint8_t * v = (arg_bytevector (1, (&length))); + unsigned long end = (arg_ulong_index_integer (3, length)); + unsigned long start = (arg_ulong_index_integer (2, end)); + return (memory_to_bytevector ((end - start), (v + start))); + } +} + +DEFINE_PRIMITIVE ("bytevector-copy!", Prim_bytevector_copyx, 5, 5, 0) +{ + PRIMITIVE_HEADER (5); + { + unsigned long to_length; + uint8_t * to_v = (arg_bytevector (1, (&to_length))); + unsigned long to_start = (arg_ulong_index_integer (2, to_length)); + unsigned long from_length; + uint8_t * from_v = (arg_bytevector (3, (&from_length))); + unsigned long from_end = (arg_ulong_index_integer (5, from_length)); + unsigned long from_start = (arg_ulong_index_integer (4, from_end)); + unsigned long length = (from_end - from_start); + if ((to_length - to_start) < length) + error_bad_range_arg (5); + memmove ((to_v + to_start), (from_v + from_start), length); + } + PRIMITIVE_RETURN (UNSPECIFIC); +} diff --git a/src/microcode/makegen/files-core.scm b/src/microcode/makegen/files-core.scm index d3c995fb2..0943cbdb1 100644 --- a/src/microcode/makegen/files-core.scm +++ b/src/microcode/makegen/files-core.scm @@ -33,6 +33,7 @@ USA. "bigprm" "bitstr" "boot" +"bytevector" "char" "daemon" "debug" diff --git a/src/microcode/object.h b/src/microcode/object.h index 035e7e786..30c7ac2f4 100644 --- a/src/microcode/object.h +++ b/src/microcode/object.h @@ -43,8 +43,8 @@ typedef unsigned long SCHEME_OBJECT; #define SIZEOF_SCHEME_OBJECT SIZEOF_UNSIGNED_LONG #define OBJECT_LENGTH ((unsigned int) (CHAR_BIT * SIZEOF_UNSIGNED_LONG)) -/* A convenience definition since "unsigned char" is so verbose. */ -typedef unsigned char byte_t; +/* A convenience definition. */ +typedef uint8_t byte_t; #if (TYPE_CODE_LENGTH == 6U) # define N_TYPE_CODES (0x40)