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.

diff --git a/libguile/arrays.c b/libguile/arrays.c
index db6258512ea3da98aae4371a82d4a79cb621a08b..89f5e9d09b0713b40ad0c5c823416cd9e0873450 100644 (file)
--- 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 964a1facaa23a1952dbc2a0e290da120c18d51a0..a5ce57727ee8a184daef425c54db19e4786fa052 100644 (file)
--- 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 6faab9be1b345ae160c4f1e664d7a66c81d90471..f5fc47dd7cce8b4785a81f5e7fc39cac2eb420e8 100644 (file)
--- 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 21ef95975405f48f46150e17fea83f244aefd632..8bd61a3a20e4a452d5c41fa179c0673676abc223 100644 (file)
--- 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))))