[Guile-commits] GNU Guile branch, master, updated. release_1-9-6-138-g73788ca

[Andy Wingo]

This is an automated email from the git hooks/post-receive script. It was
generated because a ref change was pushed to the repository containing
the project "GNU Guile".

http://git.savannah.gnu.org/cgit/guile.git/commit/?id=73788ca8bedcb4dd9578a1a992223e51a7d99a0d

The branch, master has been updated
       via  73788ca8bedcb4dd9578a1a992223e51a7d99a0d (commit)
       via  5a9c6dcbb3bdda159cc45edb9d8b34e7b5043b9e (commit)
      from  411313403cac04d1b1b1c7f579da32eaaaf4d80d (commit)

Those revisions listed above that are new to this repository have
not appeared on any other notification email; so we list those
revisions in full, below.

- Log -----------------------------------------------------------------
commit 73788ca8bedcb4dd9578a1a992223e51a7d99a0d
Author: Andy Wingo <address@hidden>
Date:   Mon Jan 11 21:47:10 2010 +0100

    allow compilation of address@hidden(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.

commit 5a9c6dcbb3bdda159cc45edb9d8b34e7b5043b9e
Author: Andy Wingo <address@hidden>
Date:   Mon Jan 11 20:45:52 2010 +0100

    fix erroneous compilation of address@hidden(1 2 3) as #(1 2 3)
    
    * module/language/glil/compile-assembly.scm (dump-object): Fix the
      vector case to only match 0-indexed, vectors, not arrays like 
address@hidden(1 2
      3).

-----------------------------------------------------------------------

Summary of changes:
 libguile/arrays.c                         |   37 ++++++++++++++++++++++++++++-
 libguile/arrays.h                         |    4 ++-
 libguile/vm-i-scheme.c                    |   18 +++++++++++++-
 module/language/glil/compile-assembly.scm |   20 ++++++++++++++-
 4 files changed, 74 insertions(+), 5 deletions(-)

diff --git a/libguile/arrays.c b/libguile/arrays.c
index db62585..89f5e9d 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 964a1fa..a5ce577 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 6faab9b..f5fc47d 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 32c5a9d..8bd61a3 100644
--- a/module/language/glil/compile-assembly.scm
+++ b/module/language/glil/compile-assembly.scm
@@ -1,6 +1,6 @@
 ;;; Guile VM assembler
 
-;; 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
@@ -558,7 +558,8 @@
       `(,@kar
         ,@(dump-object (cdr x) (addr+ addr kar))
         (cons))))
-   ((vector? x)
+   ((and (vector? x)
+         (equal? (array-shape x) (list (list 0 (1- (vector-length x))))))
     (let* ((len (vector-length x))
            (tail (if (>= len 65536)
                      (too-long "vector")
@@ -579,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))))
 


hooks/post-receive
-- 
GNU Guile