1 /* -*-C-*- 2 3 Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994, 4 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005, 5 2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013, 2014 Massachusetts 6 Institute of Technology 7 8 This file is part of MIT/GNU Scheme. 9 10 MIT/GNU Scheme is free software; you can redistribute it and/or modify 11 it under the terms of the GNU General Public License as published by 12 the Free Software Foundation; either version 2 of the License, or (at 13 your option) any later version. 14 15 MIT/GNU Scheme is distributed in the hope that it will be useful, but 16 WITHOUT ANY WARRANTY; without even the implied warranty of 17 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU 18 General Public License for more details. 19 20 You should have received a copy of the GNU General Public License 21 along with MIT/GNU Scheme; if not, write to the Free Software 22 Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, 23 USA. 24 25 */ 26 27 /* Floating-point vector primitives */ 28 29 #include "scheme.h" 30 #include "prims.h" 31 32 #define FLOATING_VECTOR_INDEX_ARG(argument_number, vector) \ 33 (arg_index_integer ((argument_number), (FLOATING_VECTOR_LENGTH (vector)))) 34 35 DEFINE_PRIMITIVE ("FLOATING-VECTOR-CONS", Prim_floating_vector_cons, 1, 1, 0) 36 { 37 PRIMITIVE_HEADER (1); 38 { 39 long length = (arg_nonnegative_integer (1)); 40 long length_in_words = (length * FLONUM_SIZE); 41 SCHEME_OBJECT result; 42 double *vect; 43 44 ALIGN_FLOAT (Free); 45 Primitive_GC_If_Needed (length_in_words + 1); 46 result = (MAKE_POINTER_OBJECT (TC_BIG_FLONUM, Free)); 47 (*Free++) = (MAKE_OBJECT (TC_MANIFEST_NM_VECTOR, length_in_words)); 48 vect = ((double *) Free); 49 while ((length--) > 0) (*vect++) = 0.0; 50 Free = ((SCHEME_OBJECT *) vect); 51 PRIMITIVE_RETURN (result); 52 } 53 } 54 55 DEFINE_PRIMITIVE ("FLOATING-VECTOR-REF", Prim_floating_vector_ref, 2, 2, 0) 56 { 57 PRIMITIVE_HEADER (2); 58 { 59 SCHEME_OBJECT vector = (FLOATING_VECTOR_ARG (1)); 60 Primitive_GC_If_Needed (FLONUM_SIZE + 1); 61 PRIMITIVE_RETURN 62 (FLOAT_TO_FLONUM 63 (FLOATING_VECTOR_REF (vector, 64 (FLOATING_VECTOR_INDEX_ARG (2, vector))))); 65 } 66 } 67 68 extern double arg_flonum (int); 69 70 DEFINE_PRIMITIVE ("FLOATING-VECTOR-SET!", Prim_floating_vector_set, 3, 3, 0) 71 { 72 PRIMITIVE_HEADER (3); 73 { 74 SCHEME_OBJECT vector = (FLOATING_VECTOR_ARG (1)); 75 FLOATING_VECTOR_SET 76 (vector, 77 (FLOATING_VECTOR_INDEX_ARG (2, vector)), 78 (arg_flonum (3))); 79 } 80 PRIMITIVE_RETURN (UNSPECIFIC); 81 } 82 83 DEFINE_PRIMITIVE ("FLOATING-VECTOR-LENGTH", Prim_floating_vector_length, 1, 1, 84 0) 85 { 86 PRIMITIVE_HEADER (1); 87 PRIMITIVE_RETURN 88 (LONG_TO_UNSIGNED_FIXNUM 89 (FLOATING_VECTOR_LENGTH (FLOATING_VECTOR_ARG (1)))); 90 } 91