summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorAndy Wingo <wingo@pobox.com>2010-01-11 21:47:10 +0100
committerAndy Wingo <wingo@pobox.com>2010-01-11 21:47:10 +0100
commit73788ca8bedcb4dd9578a1a992223e51a7d99a0d (patch)
treeb83a8c238562869ac0f1e203362812a3406e800d
parent5a9c6dcbb3bdda159cc45edb9d8b34e7b5043b9e (diff)
downloadguile-73788ca8bedcb4dd9578a1a992223e51a7d99a0d.tar.gz
allow compilation of #@2(1 2 3)
* libguile/arrays.h: * libguile/arrays.c (scm_from_contiguous_array): New public function, like scm_from_contiguous_typed_array but for arrays of generic Scheme values. * libguile/vm-i-scheme.c (make-struct): Sync regs before making the struct, so if we get a GC the regs are on the heap. (make-array): New instruction, makes an generic (untyped) Scheme array. * module/language/glil/compile-assembly.scm (dump-object): Correctly compile arrays.
-rw-r--r--libguile/arrays.c37
-rw-r--r--libguile/arrays.h4
-rw-r--r--libguile/vm-i-scheme.c18
-rw-r--r--module/language/glil/compile-assembly.scm15
4 files changed, 71 insertions, 3 deletions
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))))