Anonymous avatar Anonymous committed edc6e13

Ajout du tag Double_array_tag.
Deplacement de copy_double dans floats.c.

git-svn-id: http://caml.inria.fr/svn/ocaml/trunk@153 f963ae5c-01c2-4b8c-9fe0-0dff7051ff02

Comments (0)

Files changed (8)

   return result;
 }
 
-value copy_double(d)
-     double d;
-{
-  value res;
-
-  Alloc_small(res, Double_wosize, Double_tag);
-  Store_double_val(res, d);
-  return res;
-}
-
 value copy_string(s)
      char * s;
 {

byterun/compare.c

     double d2 = Double_val(v2);
     if (d1 == d2) return 0; else if (d1 < d2) return -1; else return 1;
   }
+  case Double_array_tag: {
+    mlsize_t sz1 = Wosize_val(v1);
+    mlsize_t sz2 = Wosize_val(v2);
+    mlsize_t i;
+    if (sz1 != sz2) return sz1 - sz2;
+    for (i = 0; i < sz1; i++) {
+      double d1 = Double_field(v1, i);
+      double d2 = Double_field(v2, i);
+      if (d1 != d2) { if (d1 < d2) return -1; else return 1; }
+    }
+    return 0;
+  }
   case Abstract_tag:
   case Final_tag:
     invalid_argument("equal: abstract value");
         break;
       }
       case Double_tag: {
-        double buffer;
         if (sizeof(double) != 8)
           invalid_argument("output_value: non-standard floats");
         putch(chan, CODE_DOUBLE_NATIVE);
-        buffer = Double_val(v);
-        putblock(chan, (char *) &buffer, 8);
-        size_32 += 1 + sizeof(double) / 4;
-        size_64 += 1 + sizeof(double) / 8;
+        putblock(chan, (char *) v, 8);
+        size_32 += 1 + 2;
+        size_64 += 1 + 1;
+        break;
+      }
+      case Double_array_tag: {
+        mlsize_t nfloats;
+        if (sizeof(double) != 8)
+          invalid_argument("output_value: non-standard floats");
+        nfloats = Wosize_val(v) / Double_wosize;
+        output32(chan, CODE_DOUBLE_ARRAY_NATIVE, nfloats);
+        putblock(chan, (char *) v, Bosize_val(v));
+        size_32 += 1 + nfloats * 2;
+        size_64 += 1 + nfloats;
         break;
       }
       case Abstract_tag:
 #endif
 #endif
 
+value copy_double(d)
+     double d;
+{
+  value res;
+
+#define Setup_for_gc
+#define Restore_after_gc
+  Alloc_small(res, Double_wosize, Double_tag);
+#undef Setup_for_gc
+#undef Restore_after_gc
+  Store_double_val(res, d);
+  return res;
+}
+
 value format_float(fmt, arg)    /* ML */
      value fmt, arg;
 {
      value obj;
 {
   unsigned char * p;
-  mlsize_t i;
+  mlsize_t i, j;
   tag_t tag;
 
   hash_univ_limit--;
 #endif
         Combine_small(*p);
       break;
+    case Double_array_tag:
+      hash_univ_count--;
+      for (j = 0; j < Bosize_val(obj); j += sizeof(double)) {
+#ifdef BIG_ENDIAN
+      for (p = &Byte_u(obj, j + sizeof(double) - 1), i = sizeof(double);
+           i > 0;
+           p--, i--)
+#else
+      for (p = &Byte_u(obj, j), i = sizeof(double);
+           i > 0;
+           p++, i--)
+#endif
+        Combine_small(*p);
+      }
+      break;
     case Abstract_tag:
     case Final_tag:
       /* We don't know anything about the contents of the block.
         really_getblock(chan, (char *) v, 8);
         if (code != CODE_DOUBLE_NATIVE) Reverse_double(v);
         break;
+      case CODE_DOUBLE_ARRAY_LITTLE:
+      case CODE_DOUBLE_ARRAY_BIG:
+        if (sizeof(double) != 8) {
+          stat_free((char *) intern_obj_table);
+          Hd_val(intern_block) = intern_header; /* Don't confuse the GC */
+          invalid_argument("input_value: non-standard floats");
+        }
+        len = input32u(chan);
+        size = len * Double_wosize;
+        v = Val_hp(intern_ptr);
+        intern_obj_table[obj_counter++] = v;
+        *intern_ptr = Make_header(size, Double_array_tag, intern_color);
+        intern_ptr += 1 + size;
+        really_getblock(chan, (char *) v, len * 8);
+        if (code != CODE_DOUBLE_NATIVE) {
+          mlsize_t i;
+          for (i = 0; i < len; i++) Reverse_double((value)((double *)v + i));
+        }
+        break;
       }
     }
   }
 #else
 #define CODE_DOUBLE_NATIVE CODE_DOUBLE_LITTLE
 #endif
+#define CODE_DOUBLE_ARRAY_BIG 0xD
+#define CODE_DOUBLE_ARRAY_LITTLE 0xE
+#ifdef BIG_ENDIAN
+#define CODE_DOUBLE_ARRAY_NATIVE CODE_DOUBLE_ARRAY_BIG
+#else
+#define CODE_DOUBLE_ARRAY_NATIVE CODE_DOUBLE_ARRAY_LITTLE
+#endif
 
 /* Initial sizes of data structures for extern */
 

byterun/mlvalues.h

 #endif
 
 /* The lowest tag for blocks containing no value. */
-#define No_scan_tag (Num_tags - 5)
+#define No_scan_tag (Num_tags - 6)
 
 
 /* 1- If tag < No_scan_tag : a tuple of fields.  */
 #define Double_tag (No_scan_tag + 3)
 #define Double_wosize ((sizeof(double) / sizeof(value)))
 #ifndef ALIGN_DOUBLE
-#define Double_val(v) (* (double *) (v))
-#define Store_double_val(v,d) (* (double *) (v) = (d))
+#define Double_val(v) (* (double *)(v))
+#define Store_double_val(v,d) (* (double *)(v) = (d))
 #else
 double Double_val P((value));
 void Store_double_val P((value,double));
 #endif
 
+/* Arrays of floating-point numbers. */
+#define Double_array_tag (No_scan_tag + 4)
+#define Double_field(v,i) Double_val((value)((double *)(v) + (i)))
+#define Store_double_field(v,i,d) \
+  Store_double_val((value)((double *)(v) + (i)),d)
+
 /* Finalized things.  Just like abstract things, but the GC will call the
    [Final_fun] before deallocation.
 */
-#define Final_tag (No_scan_tag + 4)
+#define Final_tag (No_scan_tag + 5)
 typedef void (*final_fun) P((value));
 #define Final_fun(val) (((final_fun *) (val)) [0]) /* Also an l-value. */
 
Tip: Filter by directory path e.g. /media app.js to search for public/media/app.js.
Tip: Use camelCasing e.g. ProjME to search for ProjectModifiedEvent.java.
Tip: Filter by extension type e.g. /repo .js to search for all .js files in the /repo directory.
Tip: Separate your search with spaces e.g. /ssh pom.xml to search for src/ssh/pom.xml.
Tip: Use ↑ and ↓ arrow keys to navigate and return to view the file.
Tip: You can also navigate files with Ctrl+j (next) and Ctrl+k (previous) and view the file with Ctrl+o.
Tip: You can also navigate files with Alt+j (next) and Alt+k (previous) and view the file with Alt+o.