guile-commits
[Top][All Lists]
Advanced

[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]

[Guile-commits] GNU Guile branch, stable-2.0, updated. v2.0.3-28-gf7db60


From: Ludovic Courtès
Subject: [Guile-commits] GNU Guile branch, stable-2.0, updated. v2.0.3-28-gf7db607
Date: Mon, 21 Nov 2011 23:26:20 +0000

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=f7db6079bc16354394a1bd90d15c2a7ab985f148

The branch, stable-2.0 has been updated
       via  f7db6079bc16354394a1bd90d15c2a7ab985f148 (commit)
       via  d4b88945205451b0c8f9a565374f3e75ec604419 (commit)
       via  be4b20c3ca6e48277f42b896cad9281dee0f96e6 (commit)
       via  de2c0a10fef8322b3c11acd6d1c149473846ceb8 (commit)
       via  e0a9f02224cdcf0e8e24616038aca905d31b60a7 (commit)
      from  f0d1bacd786147c73862ab3f5ca2155b6f88888e (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 f7db6079bc16354394a1bd90d15c2a7ab985f148
Author: Ludovic Courtès <address@hidden>
Date:   Tue Nov 22 00:21:39 2011 +0100

    Run `guild compile' with `--target=$(host)'.
    
    * am/guilec (.scm.go): Run `guild compile' with `--target=$(host)'.

commit d4b88945205451b0c8f9a565374f3e75ec604419
Author: Ludovic Courtès <address@hidden>
Date:   Tue Nov 22 00:19:03 2011 +0100

    Add a `--target' option to `guild compile'.
    
    * module/scripts/compile.scm (%options)["--target"]: New option.
      (show-version): Update copyright year.
      (compile): Use `with-target' to install the target.
    
    * doc/ref/api-evaluation.texi (Compilation): Mention `--target' option.

commit be4b20c3ca6e48277f42b896cad9281dee0f96e6
Author: Ludovic Courtès <address@hidden>
Date:   Tue Nov 22 00:09:22 2011 +0100

    Add missing implicit `SCM_API' for `scm_c_make_objcode_slice'.
    
    * libguile/objcodes.h (scm_c_make_objcode_slice): Add implicit `SCM_API'.

commit de2c0a10fef8322b3c11acd6d1c149473846ceb8
Author: Ludovic Courtès <address@hidden>
Date:   Mon Nov 21 22:08:22 2011 +0100

    Complete cross-compilation support.
    
    * module/system/base/target.scm (%target-endianness, %target-word-size):
      New fluids.
      (%native-word-size): New variable.
      (with-target): Set these fluids.
      (cpu-endianness, cpu-word-size, triplet-cpu, triplet-vendor,
      triplet-os): New procedures.
      (target-cpu, target-vendor, target-os): Use them.
      (target-endianness, target-word-size): Refer to the corresponding
      fluid.
    
    * libguile/objcodes.c (target_endianness_var, target_word_size_var): New
      global variables.
      (NATIVE_ENDIANNESS): New macro.
      (target_endianness, target_word_size, to_native_order): New functions.
      (make_objcode_from_file): Use `scm_bytecode_to_native_objcode' instead
      of `scm_bytecode_to_objcode'.
      (bytecode_to_objcode): New function, based on `scm_bytecode_to_objcode',
      with the addition of an `endianness' and `word_size' parameters.
      (scm_bytecode_to_objcode): Use it.
      (scm_bytecode_to_native_objcode): New function.
      (scm_write_objcode): Use `target_word_size' and `target_endianness'.
      Convert OBJCODE's len and meta-len to native byte order.
      (scm_init_objcodes): Initialize `target_endianness_var' and
      `target_word_size_var'.
    
    * libguile/objcodes.h (scm_bytecode_to_native_objcode): New declaration.
    
    * libguile/vm.c (really_make_boot_program): Use
      `scm_bytecode_to_native_objcode' instead of `scm_bytecode_to_objcode'.
    
    * test-suite/tests/asm-to-bytecode.test (%objcode-cookie-size): New
      variable.
      (test-target): New procedure.
      ("cross-compilation"): Add `test-target' calls and the "unknown
      target" test.

commit e0a9f02224cdcf0e8e24616038aca905d31b60a7
Author: Ludovic Courtès <address@hidden>
Date:   Mon Nov 21 21:55:13 2011 +0100

    Fix `validate-target' in (system base target).
    
    * module/system/base/target.scm (validate-target): Accept any tuple with
      at least 3 parts.
    
    * test-suite/tests/asm-to-bytecode.test (test-triplet): New procedure.
      ("cross-compilation"): New test prefix.

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

Summary of changes:
 am/guilec                             |    2 +-
 doc/ref/api-evaluation.texi           |    7 ++
 libguile/objcodes.c                   |  130 +++++++++++++++++++++++++--------
 libguile/objcodes.h                   |    3 +-
 libguile/vm.c                         |    2 +-
 module/scripts/compile.scm            |   24 ++++--
 module/system/base/target.scm         |   88 +++++++++++++++++-----
 test-suite/tests/asm-to-bytecode.test |   85 +++++++++++++++++++++-
 8 files changed, 279 insertions(+), 62 deletions(-)

diff --git a/am/guilec b/am/guilec
index 7f4e85d..9af9daf 100644
--- a/am/guilec
+++ b/am/guilec
@@ -28,4 +28,4 @@ SUFFIXES = .scm .go
 .scm.go:
        $(AM_V_GUILEC)GUILE_AUTO_COMPILE=0                              \
        $(top_builddir)/meta/uninstalled-env                    \
-       guild compile $(GUILE_WARNINGS) -o "$@" "$<"
+       guild compile --target="$(host)" $(GUILE_WARNINGS) -o "$@" "$<"
diff --git a/doc/ref/api-evaluation.texi b/doc/ref/api-evaluation.texi
index aa7d9c7..6a09bef 100644
--- a/doc/ref/api-evaluation.texi
+++ b/doc/ref/api-evaluation.texi
@@ -640,6 +640,13 @@ Use @var{lang} as the source language of @var{file}.  If 
this option is omitted,
 Use @var{lang} as the target language of @var{file}.  If this option is 
omitted,
 @code{objcode} is assumed.
 
address@hidden -T @var{target}
address@hidden address@hidden
+Produce bytecode for @var{target} instead of @var{%host-type}
+(@pxref{Build Config, %host-type}).  Target must be a valid GNU triplet,
+such as @code{armv5tel-unknown-linux-gnueabi} (@pxref{Specifying Target
+Triplets,,, autoconf, GNU Autoconf Manual}).
+
 @end table
 
 Each @var{file} is assumed to be UTF-8-encoded, unless it contains a
diff --git a/libguile/objcodes.c b/libguile/objcodes.c
index 6223362..536094f 100644
--- a/libguile/objcodes.c
+++ b/libguile/objcodes.c
@@ -32,6 +32,7 @@
 #include <sys/types.h>
 #include <assert.h>
 #include <alignof.h>
+#include <byteswap.h>
 
 #include <full-read.h>
 
@@ -45,11 +46,55 @@
    The length of the header must be a multiple of 8 bytes.  */
 verify (((sizeof (SCM_OBJCODE_COOKIE) - 1) & 7) == 0);
 
+/* Endianness and word size of the compilation target.  */
+static SCM target_endianness_var = SCM_BOOL_F;
+static SCM target_word_size_var = SCM_BOOL_F;
+
 
 /*
  * Objcode type
  */
 
+/* Endianness of the build machine.  */
+#ifdef WORDS_BIGENDIAN
+# define NATIVE_ENDIANNESS 'B'
+#else
+# define NATIVE_ENDIANNESS 'L'
+#endif
+
+/* Return the endianness of the compilation target.  */
+static char
+target_endianness (void)
+{
+  if (scm_is_true (target_endianness_var))
+    return scm_is_eq (scm_call_0 (scm_variable_ref (target_endianness_var)),
+                     scm_endianness_big) ? 'B' : 'L';
+  else
+    return NATIVE_ENDIANNESS;
+}
+
+/* Return the word size in bytes of the compilation target.  */
+static size_t
+target_word_size (void)
+{
+  if (scm_is_true (target_word_size_var))
+    return scm_to_size_t (scm_call_0
+                         (scm_variable_ref (target_word_size_var)));
+  else
+    return sizeof (void *);
+}
+
+/* Convert X, which is in byte order ENDIANNESS, to its native
+   representation.  */
+static inline uint32_t
+to_native_order (uint32_t x, char endianness)
+{
+  if (endianness == NATIVE_ENDIANNESS)
+    return x;
+  else
+    return bswap_32 (x);
+}
+
 static void
 verify_cookie (char *cookie, struct stat *st, int map_fd, void *map_addr)
 #define FUNC_NAME "make_objcode_from_file"
@@ -183,7 +228,7 @@ make_objcode_from_file (int fd)
 
     verify_cookie (cookie, &st, -1, NULL);
 
-    return scm_bytecode_to_objcode (bv);
+    return scm_bytecode_to_native_objcode (bv);
   }
 #endif
 }
@@ -254,12 +299,12 @@ SCM_DEFINE (scm_objcode_meta, "objcode-meta", 1, 0, 0,
 }
 #undef FUNC_NAME
 
-SCM_DEFINE (scm_bytecode_to_objcode, "bytecode->objcode", 1, 0, 0,
-           (SCM bytecode),
-           "")
-#define FUNC_NAME s_scm_bytecode_to_objcode
+/* Turn BYTECODE into objcode encoded for ENDIANNESS and WORD_SIZE.  */
+static SCM
+bytecode_to_objcode (SCM bytecode, char endianness, size_t word_size)
+#define FUNC_NAME "bytecode->objcode"
 {
-  size_t size;
+  size_t size, len, metalen;
   const scm_t_uint8 *c_bytecode;
   struct scm_objcode *data;
 
@@ -268,14 +313,17 @@ SCM_DEFINE (scm_bytecode_to_objcode, "bytecode->objcode", 
1, 0, 0,
 
   size = SCM_BYTEVECTOR_LENGTH (bytecode);
   c_bytecode = (const scm_t_uint8*)SCM_BYTEVECTOR_CONTENTS (bytecode);
-  
+
   SCM_ASSERT_RANGE (0, bytecode, size >= sizeof(struct scm_objcode));
   data = (struct scm_objcode*)c_bytecode;
 
-  if (data->len + data->metalen != (size - sizeof (*data)))
+  len = to_native_order (data->len, endianness);
+  metalen = to_native_order (data->metalen, endianness);
+
+  if (len + metalen != (size - sizeof (*data)))
     scm_misc_error (FUNC_NAME, "bad bytevector size (~a != ~a)",
                    scm_list_2 (scm_from_size_t (size),
-                               scm_from_uint32 (sizeof (*data) + data->len + 
data->metalen)));
+                               scm_from_uint32 (sizeof (*data) + len + 
metalen)));
 
   /* foolishly, we assume that as long as bytecode is around, that c_bytecode
      will be of the same length; perhaps a bad assumption? */
@@ -284,6 +332,27 @@ SCM_DEFINE (scm_bytecode_to_objcode, "bytecode->objcode", 
1, 0, 0,
 }
 #undef FUNC_NAME
 
+SCM_DEFINE (scm_bytecode_to_objcode, "bytecode->objcode", 1, 0, 0,
+           (SCM bytecode),
+           "")
+#define FUNC_NAME s_scm_bytecode_to_objcode
+{
+  /* Assume we're called from Scheme, which known that to do with
+     `target-type'.  */
+  return bytecode_to_objcode (bytecode, target_endianness (),
+                             target_word_size ());
+}
+#undef FUNC_NAME
+
+/* Like `bytecode->objcode', but ignore the `target-type' fluid.  This
+   is useful for native compilation that happens lazily---e.g., direct
+   calls to this function from libguile itself.  */
+SCM
+scm_bytecode_to_native_objcode (SCM bytecode)
+{
+  return bytecode_to_objcode (bytecode, NATIVE_ENDIANNESS, sizeof (void *));
+}
+
 SCM_DEFINE (scm_load_objcode, "load-objcode", 1, 0, 0,
            (SCM file),
            "")
@@ -327,40 +396,36 @@ SCM_DEFINE (scm_write_objcode, "write-objcode", 2, 0, 0,
            "")
 #define FUNC_NAME s_scm_write_objcode
 {
-  static SCM target_endianness_var = SCM_BOOL_F;
-  static SCM target_word_size_var = SCM_BOOL_F;
-
   char cookie[sizeof (SCM_OBJCODE_COOKIE) - 1];
-  char endianness;
-  char word_size;
+  char endianness, word_size;
+  size_t total_size;
 
   SCM_VALIDATE_OBJCODE (1, objcode);
   SCM_VALIDATE_OUTPUT_PORT (2, port);
-  
-  if (scm_is_false (target_endianness_var))
-    target_endianness_var =
-      scm_c_public_variable ("system base target", "target-endianness");
-  if (scm_is_false (target_word_size_var))
-    target_word_size_var =
-      scm_c_public_variable ("system base target", "target-word-size");
-
-  endianness = 
-    scm_is_eq (scm_call_0 (scm_variable_ref (target_endianness_var)),
-               scm_endianness_big) ? 'B' : 'L';
-  switch (scm_to_int (scm_call_0 (scm_variable_ref (target_word_size_var))))
+  endianness = target_endianness ();
+  switch (target_word_size ())
     {
-    case 4: word_size = '4'; break;
-    case 8: word_size = '8'; break;
-    default: abort ();
+    case 4:
+      word_size = '4';
+      break;
+    case 8:
+      word_size = '8';
+      break;
+    default:
+      abort ();
     }
 
   memcpy (cookie, SCM_OBJCODE_COOKIE, strlen (SCM_OBJCODE_COOKIE));
   cookie[SCM_OBJCODE_ENDIANNESS_OFFSET] = endianness;
   cookie[SCM_OBJCODE_WORD_SIZE_OFFSET] = word_size;
 
+  total_size =
+    to_native_order (SCM_OBJCODE_LEN (objcode), target_endianness ())
+    + to_native_order (SCM_OBJCODE_META_LEN (objcode), target_endianness ());
+
   scm_c_write (port, cookie, strlen (SCM_OBJCODE_COOKIE));
   scm_c_write (port, SCM_OBJCODE_DATA (objcode),
-               sizeof (struct scm_objcode) + SCM_OBJCODE_TOTAL_LEN (objcode));
+               sizeof (struct scm_objcode) + total_size);
 
   return SCM_UNSPECIFIED;
 }
@@ -400,6 +465,11 @@ scm_init_objcodes (void)
 
   scm_c_define ("word-size", scm_from_size_t (sizeof(SCM)));
   scm_c_define ("byte-order", scm_from_uint16 (SCM_BYTE_ORDER));
+
+  target_endianness_var = scm_c_public_variable ("system base target",
+                                                "target-endianness");
+  target_word_size_var = scm_c_public_variable ("system base target",
+                                               "target-word-size");
 }
 
 /*
diff --git a/libguile/objcodes.h b/libguile/objcodes.h
index 2fc43d5..0cfc8e0 100644
--- a/libguile/objcodes.h
+++ b/libguile/objcodes.h
@@ -60,11 +60,12 @@ struct scm_objcode
 #define SCM_OBJCODE_NATIVE_CODE(x) (SCM_CELL_WORD_3 (x))
 #define SCM_SET_OBJCODE_NATIVE_CODE(x, code) (SCM_SET_CELL_WORD_3 (x, code))
 
-SCM scm_c_make_objcode_slice (SCM parent, const scm_t_uint8 *ptr);
+SCM_API SCM scm_c_make_objcode_slice (SCM parent, const scm_t_uint8 *ptr);
 SCM_API SCM scm_load_objcode (SCM file);
 SCM_API SCM scm_objcode_p (SCM obj);
 SCM_API SCM scm_objcode_meta (SCM objcode);
 SCM_API SCM scm_bytecode_to_objcode (SCM bytecode);
+SCM_INTERNAL SCM scm_bytecode_to_native_objcode (SCM bytecode);
 SCM_API SCM scm_objcode_to_bytecode (SCM objcode);
 SCM_API SCM scm_write_objcode (SCM objcode, SCM port);
 
diff --git a/libguile/vm.c b/libguile/vm.c
index 6cb85b7..49df5cb 100644
--- a/libguile/vm.c
+++ b/libguile/vm.c
@@ -392,7 +392,7 @@ really_make_boot_program (long nargs)
 
   u8vec = scm_c_take_gc_bytevector ((scm_t_int8*)bp,
                                     sizeof (struct scm_objcode) + sizeof 
(text));
-  ret = scm_make_program (scm_bytecode_to_objcode (u8vec),
+  ret = scm_make_program (scm_bytecode_to_native_objcode (u8vec),
                           SCM_BOOL_F, SCM_BOOL_F);
   SCM_SET_CELL_WORD_0 (ret, SCM_CELL_WORD_0 (ret) | SCM_F_PROGRAM_IS_BOOT);
 
diff --git a/module/scripts/compile.scm b/module/scripts/compile.scm
index 0651c68..20db944 100644
--- a/module/scripts/compile.scm
+++ b/module/scripts/compile.scm
@@ -30,6 +30,7 @@
 
 (define-module (scripts compile)
   #:use-module ((system base compile) #:select (compile-file))
+  #:use-module (system base target)
   #:use-module (system base message)
   #:use-module (srfi srfi-1)
   #:use-module (srfi srfi-13)
@@ -88,7 +89,12 @@
                (lambda (opt name arg result)
                   (if (assoc-ref result 'to)
                       (fail "`--to' option cannot be specified more than once")
-                      (alist-cons 'to (string->symbol arg) result))))))
+                      (alist-cons 'to (string->symbol arg) result))))
+        (option '(#\T "target") #t #f
+                (lambda (opt name arg result)
+                  (if (assoc-ref result 'target)
+                      (fail "`--target' option cannot be specified more than 
once")
+                      (alist-cons 'target arg result))))))
 
 (define (parse-args args)
   "Parse argument list @var{args} and return an alist with all the relevant
@@ -109,7 +115,7 @@ options."
 
 (define (show-version)
   (format #t "compile (GNU Guile) ~A~%" (version))
-  (format #t "Copyright (C) 2009 Free Software Foundation, Inc.
+  (format #t "Copyright (C) 2009, 2011 Free Software Foundation, Inc.
 License LGPLv3+: GNU LGPL version 3 or later 
<http://gnu.org/licenses/lgpl.html>.
 This is free software: you are free to change and redistribute it.
 There is NO WARRANTY, to the extent permitted by law.~%"))
@@ -134,6 +140,7 @@ There is NO WARRANTY, to the extent permitted by law.~%"))
                                 o)))
          (from            (or (assoc-ref options 'from) 'scheme))
          (to              (or (assoc-ref options 'to) 'objcode))
+         (target          (or (assoc-ref options 'target) %host-type))
         (input-files     (assoc-ref options 'input-files))
         (output-file     (assoc-ref options 'output-file))
         (load-path       (assoc-ref options 'load-path)))
@@ -152,6 +159,7 @@ Compile each Guile source file FILE into a Guile object.
 
   -f, --from=LANG      specify a source language other than `scheme'
   -t, --to=LANG        specify a target language other than `objcode'
+  -T, --target=TRIPLET produce bytecode for host TRIPLET
 
 Note that auto-compilation will be turned off.
 
@@ -171,11 +179,13 @@ Report bugs to <~A>.~%"
     (for-each (lambda (file)
                 (format #t "wrote `~A'\n"
                         (with-fluids ((*current-warning-prefix* ""))
-                          (compile-file file
-                                        #:output-file output-file
-                                        #:from from
-                                        #:to to
-                                        #:opts compile-opts))))
+                          (with-target target
+                            (lambda ()
+                              (compile-file file
+                                            #:output-file output-file
+                                            #:from from
+                                            #:to to
+                                            #:opts compile-opts))))))
               input-files)))
 
 (define main compile)
diff --git a/module/system/base/target.scm b/module/system/base/target.scm
index 573ccca..80d80f3 100644
--- a/module/system/base/target.scm
+++ b/module/system/base/target.scm
@@ -21,6 +21,7 @@
 
 (define-module (system base target)
   #:use-module (rnrs bytevectors)
+  #:use-module (ice-9 regex)
   #:export (target-type with-target
 
             target-cpu target-vendor target-os
@@ -34,43 +35,90 @@
 ;;;
 
 (define %target-type (make-fluid))
+(define %target-endianness (make-fluid))
+(define %target-word-size (make-fluid))
 
-(define (target-type)
-  (or (fluid-ref %target-type)
-      %host-type))
+(define %native-word-size
+  ;; The native word size.  Note: don't use `word-size' from
+  ;; (system vm objcode) to avoid a circular dependency.
+  ((@ (system foreign) sizeof) '*))
 
 (define (validate-target target)
   (if (or (not (string? target))
           (let ((parts (string-split target #\-)))
-            (or (< 3 (length parts))
+            (or (< (length parts) 3)
                 (or-map string-null? parts))))
       (error "invalid target" target)))
 
 (define (with-target target thunk)
   (validate-target target)
-  (with-fluids ((%target-type target))
-    (thunk)))
+  (let ((cpu (triplet-cpu target)))
+    (with-fluids ((%target-type target)
+                  (%target-endianness (cpu-endianness cpu))
+                  (%target-word-size (cpu-word-size cpu)))
+      (thunk))))
+
+(define (cpu-endianness cpu)
+  "Return the endianness for CPU."
+  (if (string=? cpu (triplet-cpu %host-type))
+      (native-endianness)
+      (cond ((string-match "^i[0-9]86$" cpu)
+             (endianness little))
+            ((member cpu '("x86_64" "ia64"
+                           "powerpcle" "powerpc64le" "mipsel" "mips64el"))
+             (endianness little))
+            ((member cpu '("sparc" "sparc64" "powerpc" "powerpc64" "spu"
+                           "mips" "mips64"))
+             (endianness big))
+            ((string-match "^arm.*el" cpu)
+             (endianness little))
+            (else
+             (error "unknown CPU endianness" cpu)))))
+
+(define (cpu-word-size cpu)
+  "Return the word size for CPU."
+  (if (string=? cpu (triplet-cpu %host-type))
+      %native-word-size
+      (cond ((string-match "^i[0-9]86$" cpu) 4)
+            ((string-match "64$" cpu) 8)
+            ((string-match "64[lbe][lbe]$" cpu) 8)
+            ((member cpu '("sparc" "powerpc" "mips")) 4)
+            ((string-match "^arm.*" cpu) 4)
+            (else "unknown CPU word size" cpu))))
+
+(define (triplet-cpu t)
+  (substring t 0 (string-index t #\-)))
+
+(define (triplet-vendor t)
+  (let ((start (1+ (string-index t #\-))))
+    (substring t start (string-index t #\- start))))
+
+(define (triplet-os t)
+  (let ((start (1+ (string-index t #\- (1+ (string-index t #\-))))))
+    (substring t start)))
+
+
+(define (target-type)
+  "Return the GNU configuration triplet of the target platform."
+  (or (fluid-ref %target-type)
+      %host-type))
 
 (define (target-cpu)
-  (let ((t (target-type)))
-    (substring t 0 (string-index t #\-))))
+  "Return the CPU name of the target platform."
+  (triplet-cpu (target-type)))
 
 (define (target-vendor)
-  (let* ((t (target-type))
-         (start (1+ (string-index t #\-))))
-    (substring t start (string-index t #\- start))))
+  "Return the vendor name of the target platform."
+  (triplet-vendor (target-type)))
 
 (define (target-os)
-  (let* ((t (target-type))
-         (start (1+ (string-index t #\- (1+ (string-index t #\-))))))
-    (substring t start)))
+  "Return the operating system name of the target platform."
+  (triplet-os (target-type)))
 
 (define (target-endianness)
-  (if (equal? (target-type) %host-type)
-      (native-endianness)
-      (error "cross-compilation not yet handled" %host-type (target-type))))
+  "Return the endianness object of the target platform."
+  (or (fluid-ref %target-endianness) (native-endianness)))
 
 (define (target-word-size)
-  (if (equal? (target-type) %host-type)
-      ((@ (system foreign) sizeof) '*)
-      (error "cross-compilation not yet handled" %host-type (target-type))))
+  "Return the word size, in bytes, of the target platform."
+  (or (fluid-ref %target-word-size) %native-word-size))
diff --git a/test-suite/tests/asm-to-bytecode.test 
b/test-suite/tests/asm-to-bytecode.test
index 049e4b2..edb9bfd 100644
--- a/test-suite/tests/asm-to-bytecode.test
+++ b/test-suite/tests/asm-to-bytecode.test
@@ -1,15 +1,17 @@
 ;;;; Assembly to bytecode compilation -*- mode: scheme; coding: utf-8; -*-
 ;;;;
+;;;;   Copyright (C) 2010, 2011 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 as published by the Free Software Foundation; either
 ;;;; version 3 of the License, or (at your option) any later version.
-;;;; 
+;;;;
 ;;;; This library is distributed in the hope that it will be useful,
 ;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
 ;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
 ;;;; Lesser General Public License for more details.
-;;;; 
+;;;;
 ;;;; You should have received a copy of the GNU Lesser General Public
 ;;;; License along with this library; if not, write to the Free Software
 ;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 
USA
@@ -19,6 +21,8 @@
   #:use-module ((rnrs io ports) #:select (open-bytevector-output-port))
   #:use-module (test-suite lib)
   #:use-module (system vm instruction)
+  #:use-module (system vm objcode)
+  #:use-module (system base target)
   #:use-module (language assembly)
   #:use-module (language assembly compile-bytecode))
 
@@ -114,3 +118,80 @@
                  (uint32 0)     ;; metalen
                  make-int8 3
                  return))))
+
+
+(define (test-triplet cpu vendor os)
+  (let ((triplet (string-append cpu "-" vendor "-" os)))
+    (pass-if (format #f "triplet ~a" triplet)
+      (with-target triplet
+        (lambda ()
+          (and (string=? (target-cpu) cpu)
+               (string=? (target-vendor) vendor)
+               (string=? (target-os) os)))))))
+
+(define %objcode-cookie-size
+  (string-length "GOOF----LE-8-2.0"))
+
+(define (test-target triplet endian word-size)
+  (pass-if (format #f "target `~a' honored" triplet)
+    (call-with-values (lambda ()
+                        (open-bytevector-output-port))
+      (lambda (p get-objcode)
+        (with-target triplet
+          (lambda ()
+            (let ((b (compile-bytecode
+                      '(load-program () 16 #f
+                                     (assert-nargs-ee/locals 1)
+                                     (make-int8 77)
+                                     (toplevel-ref 1)
+                                     (local-ref 0)
+                                     (mul)
+                                     (add)
+                                     (return)
+                                     (nop) (nop) (nop)
+                                     (nop) (nop))
+                      #f)))
+              (write-objcode (bytecode->objcode b) p)
+              (let ((cookie   (make-bytevector %objcode-cookie-size))
+                    (expected (format #f "GOOF----~a-~a-~a"
+                                      (cond ((eq? endian (endianness little))
+                                             "LE")
+                                            ((eq? endian (endianness big))
+                                             "BE")
+                                            (else
+                                             (error "unknown endianness"
+                                                    endian)))
+                                      word-size
+                                      (effective-version))))
+                (bytevector-copy! (get-objcode) 0 cookie 0
+                                  %objcode-cookie-size)
+                (string=? (utf8->string cookie) expected)))))))))
+
+(with-test-prefix "cross-compilation"
+
+  (test-triplet "i586" "pc" "gnu0.3")
+  (test-triplet "x86_64" "unknown" "linux-gnu")
+  (test-triplet "x86_64" "unknown" "kfreebsd-gnu")
+
+  (test-target "i586-pc-gnu0.3" (endianness little) 4)
+  (test-target "x86_64-pc-linux-gnu" (endianness little) 8)
+  (test-target "powerpc-unknown-linux-gnu" (endianness big) 4)
+  (test-target "sparc64-unknown-freebsd8.2" (endianness big) 8)
+
+  (pass-if-exception "unknown target"
+    exception:miscellaneous-error
+    (call-with-values (lambda ()
+                        (open-bytevector-output-port))
+      (lambda (p get-objcode)
+        (let* ((b (compile-bytecode '(load-program () 3 #f
+                                                   (make-int8 77)
+                                                   (return))
+                                    #f))
+               (o (bytecode->objcode b)))
+          (with-target "fcpu-unknown-gnu1.0"
+            (lambda ()
+              (write-objcode o p))))))))
+
+;; Local Variables:
+;; eval: (put 'with-target 'scheme-indent-function 1)
+;; End:


hooks/post-receive
-- 
GNU Guile



reply via email to

[Prev in Thread] Current Thread [Next in Thread]