diff --git a/libguile/arrays.c b/libguile/arrays.c index db6258512..89f5e9d09 100644 --- a/libguile/arrays.c +++ b/libguile/arrays.c @@ -1,4 +1,4 @@ -/* Copyright (C) 1995,1996,1997,1998,2000,2001,2002,2003,2004, 2005, 2006, 2009 Free Software Foundation, Inc. +/* Copyright (C) 1995,1996,1997,1998,2000,2001,2002,2003,2004, 2005, 2006, 2009, 2010 Free Software Foundation, Inc. * * This library is free software; you can redistribute it and/or * modify it under the terms of the GNU Lesser General Public License @@ -260,6 +260,41 @@ scm_from_contiguous_typed_array (SCM type, SCM bounds, const void *bytes, } #undef FUNC_NAME +SCM +scm_from_contiguous_array (SCM bounds, const SCM *elts, size_t len) +#define FUNC_NAME "scm_from_contiguous_array" +{ + size_t k, rlen = 1; + scm_t_array_dim *s; + SCM ra; + scm_t_array_handle h; + + ra = scm_i_shap2ra (bounds); + SCM_SET_ARRAY_CONTIGUOUS_FLAG (ra); + s = SCM_I_ARRAY_DIMS (ra); + k = SCM_I_ARRAY_NDIM (ra); + + while (k--) + { + s[k].inc = rlen; + SCM_ASSERT_RANGE (1, bounds, s[k].lbnd <= s[k].ubnd + 1); + rlen = (s[k].ubnd - s[k].lbnd + 1) * s[k].inc; + } + if (rlen != len) + SCM_MISC_ERROR ("element length and dimensions do not match", SCM_EOL); + + SCM_I_ARRAY_V (ra) = scm_c_make_vector (rlen, SCM_UNDEFINED); + scm_array_get_handle (ra, &h); + memcpy (h.writable_elements, elts, rlen * sizeof(SCM)); + scm_array_handle_release (&h); + + if (1 == SCM_I_ARRAY_NDIM (ra) && 0 == SCM_I_ARRAY_BASE (ra)) + if (s->ubnd < s->lbnd || (0 == s->lbnd && 1 == s->inc)) + return SCM_I_ARRAY_V (ra); + return ra; +} +#undef FUNC_NAME + SCM_DEFINE (scm_make_array, "make-array", 1, 0, 1, (SCM fill, SCM bounds), "Create and return an array.") diff --git a/libguile/arrays.h b/libguile/arrays.h index 964a1faca..a5ce57727 100644 --- a/libguile/arrays.h +++ b/libguile/arrays.h @@ -3,7 +3,7 @@ #ifndef SCM_ARRAY_H #define SCM_ARRAY_H -/* Copyright (C) 1995,1996,1997,1999,2000,2001, 2004, 2006, 2008, 2009 Free Software Foundation, Inc. +/* Copyright (C) 1995,1996,1997,1999,2000,2001, 2004, 2006, 2008, 2009, 2010 Free Software Foundation, Inc. * * This library is free software; you can redistribute it and/or * modify it under the terms of the GNU Lesser General Public License @@ -36,6 +36,8 @@ /** Arrays */ SCM_API SCM scm_make_array (SCM fill, SCM bounds); +SCM_API SCM scm_from_contiguous_array (SCM bounds, const SCM *elts, + size_t len); SCM_API SCM scm_make_typed_array (SCM type, SCM fill, SCM bounds); SCM_API SCM scm_from_contiguous_typed_array (SCM type, SCM bounds, const void *bytes, diff --git a/libguile/vm-i-scheme.c b/libguile/vm-i-scheme.c index 6faab9be1..f5fc47dd7 100644 --- a/libguile/vm-i-scheme.c +++ b/libguile/vm-i-scheme.c @@ -1,4 +1,4 @@ -/* Copyright (C) 2001, 2009 Free Software Foundation, Inc. +/* Copyright (C) 2001, 2009, 2010 Free Software Foundation, Inc. * * This library is free software; you can redistribute it and/or * modify it under the terms of the GNU Lesser General Public License @@ -651,10 +651,26 @@ VM_DEFINE_INSTRUCTION (176, make_struct, "make-struct", 2, -1, 1) sp -= n_args - 1; + SYNC_REGISTER (); RETURN (scm_c_make_structv (vtable, scm_to_size_t (n_tail), n_args - 2, (scm_t_bits *) inits)); } +VM_DEFINE_INSTRUCTION (177, make_array, "make-array", 3, -1, 1) +{ + scm_t_uint32 len; + SCM shape, ret; + + len = FETCH (); + len = (len << 8) + FETCH (); + len = (len << 8) + FETCH (); + POP (shape); + SYNC_REGISTER (); + ret = scm_from_contiguous_array (shape, sp - len + 1, len); + DROPN (len); + RETURN (ret); +} + /* (defun renumber-ops () "start from top of buffer and renumber 'VM_DEFINE_FOO (\n' sequences" diff --git a/module/language/glil/compile-assembly.scm b/module/language/glil/compile-assembly.scm index 21ef95975..8bd61a3a2 100644 --- a/module/language/glil/compile-assembly.scm +++ b/module/language/glil/compile-assembly.scm @@ -580,6 +580,21 @@ (addr+ (addr+ addr type) shape) 8 4)))) + ((array? x) + ;; an array of generic scheme values + (let* ((contents (array-contents x)) + (len (vector-length contents))) + (let dump-objects ((i 0) (codes '()) (addr addr)) + (if (< i len) + (let ((code (dump-object (vector-ref x i) addr))) + (dump-objects (1+ i) (cons code codes) + (addr+ addr code))) + (fold append + `(,@(dump-object (array-shape x) addr) + (make-array ,(quotient (ash len -16) 256) + ,(logand #xff (ash len -8)) + ,(logand #xff len))) + codes))))) (else (error "assemble: unrecognized object" x))))