Commits

camlspotter committed ab64f2c

revision 12450

Comments (0)

Files changed (28)

 - The official name of the language is now OCaml.
 
 Language features:
-- Added Generalized Abstract Data Types (GADTs) to the language. See
-  testsuite/tests/typing-gadts for the syntax and some examples of
-  use. Please use -principal for testing.
+- Added Generalized Abstract Data Types (GADTs) to the language.
+  See chapter "Language extensions" of the reference manual for documentation.
 - It is now possible to omit type annotations when packing and unpacking
   first-class modules. The type-checker attempts to infer it from the context.
   Using the -principal option guarantees forward compatibility.
 - Set and Map: more efficient implementation of "filter" and "partition"
 - String: new function "map" (PR#3888)
 
-Other libraries:
-- Bigarray: added "release" functions that free memory and file mappings
-  just like GC finalization does eventually, but does it immediately.
-
 Bug Fixes:
 - PR#1643: functions of the Lazy module whose named started with 'lazy_' have
   been deprecated, and new ones without the prefix added
 - PR#5543: in Bigarray.map_file, try to avoid using lseek() when growing file
 - PR#5538: combining -i and -annot in ocamlc
 - PR#5560: incompatible type for tuple pattern with -principal
+- PR#5603: wrong .file debug info generated by ocamlopt -g
+- PR#5610: new unmarshaler (from PR#5318) fails to freshen object identifiers
 - problem with printing of string literals in camlp4 (reported on caml-list)
 - emacs mode: colorization of comments and strings now works correctly
 
 - PR#5478: ocamlopt assumes ar command exists
 - PR#5479: Num.num_of_string may raise an exception, not reflected in the
   documentation.
+- PR#5599: Add warn() tag in ocamlbuild to control -w compiler switch
 - ocamldebug: ability to inspect values that contain code pointers
 - ocamldebug: new 'environment' directive to set environment variables
   for debugee

asmcomp/amd64/emit.mlp

 (*                                                                     *)
 (***********************************************************************)
 
-(* $Id: emit.mlp 12179 2012-02-21 17:41:02Z xleroy $ *)
+(* $Id: emit.mlp 12449 2012-05-12 09:51:45Z xleroy $ *)
 
 (* Emission of x86-64 (AMD 64) assembly code *)
 
 (* Beginning / end of an assembly file *)
 
 let begin_assembly() =
+  reset_debug_info();                   (* PR#5603 *)
   if !Clflags.dlcode then begin
     (* from amd64.S; could emit these constants on demand *)
     if macosx then

asmcomp/emitaux.ml

 (*                                                                     *)
 (***********************************************************************)
 
-(* $Id: emitaux.ml 12179 2012-02-21 17:41:02Z xleroy $ *)
+(* $Id: emitaux.ml 12449 2012-05-12 09:51:45Z xleroy $ *)
 
 (* Common functions for emitting assembly code *)
 
 (* Number of files *)
 let file_pos_num_cnt = ref 1
 
+(* Reset debug state at beginning of asm file *)
+let reset_debug_info () =
+  file_pos_nums := [];
+  file_pos_num_cnt := 1
+
 (* We only diplay .file if the file has not been seen before. We
    display .loc for every instruction. *)
 let emit_debug_info dbg =
-  let line = dbg.Debuginfo.dinfo_line in
-  let file_name = dbg.Debuginfo.dinfo_file in
   if !Clflags.debug && not (Debuginfo.is_none dbg) then (
+    let line = dbg.Debuginfo.dinfo_line in
+    let file_name = dbg.Debuginfo.dinfo_file in
     let file_num =
       try List.assoc file_name !file_pos_nums
       with Not_found ->

asmcomp/emitaux.mli

 (*                                                                     *)
 (***********************************************************************)
 
-(* $Id: emitaux.mli 12179 2012-02-21 17:41:02Z xleroy $ *)
+(* $Id: emitaux.mli 12449 2012-05-12 09:51:45Z xleroy $ *)
 
 (* Common functions for emitting assembly code *)
 
 val emit_float64_split_directive: string -> string -> unit
 val emit_float32_directive: string -> string -> unit
 
+val reset_debug_info: unit -> unit
 val emit_debug_info: Debuginfo.t -> unit
 
 type frame_descr =

asmcomp/i386/emit.mlp

 (*                                                                     *)
 (***********************************************************************)
 
-(* $Id: emit.mlp 12179 2012-02-21 17:41:02Z xleroy $ *)
+(* $Id: emit.mlp 12449 2012-05-12 09:51:45Z xleroy $ *)
 
 (* Emission of Intel 386 assembly code *)
 
 (* Beginning / end of an assembly file *)
 
 let begin_assembly() =
+  reset_debug_info();                   (* PR#5603 *)
   let lbl_begin = Compilenv.make_symbol (Some "data_begin") in
   `	.data\n`;
   `	.globl	{emit_symbol lbl_begin}\n`;
 #                                                                       #
 #########################################################################
 
-# $Id: Makefile 12407 2012-04-27 09:56:05Z weis $
+# $Id: Makefile 12413 2012-05-02 11:00:28Z weis $
 
 include Makefile.common
 
-CFLAGS=-DCAML_NAME_SPACE -O $(BYTECCCOMPOPTS) -fPIC $(IFLEXDIR)
+CFLAGS=-DCAML_NAME_SPACE -O $(BYTECCCOMPOPTS) $(IFLEXDIR)
 DFLAGS=-DCAML_NAME_SPACE -g -DDEBUG $(BYTECCCOMPOPTS) $(IFLEXDIR)
 
 OBJS=$(COMMONOBJS) unix.o main.o
 /*                                                                     */
 /***********************************************************************/
 
-/* $Id: intern.c 12390 2012-04-22 23:37:41Z meyer $ */
+/* $Id: intern.c 12442 2012-05-08 13:49:35Z xleroy $ */
 
 /* Structured input, compact format */
 
   intern_free_stack();
 }
 
+static void readfloat(double * dest, unsigned int code)
+{
+  if (sizeof(double) != 8) {
+    intern_cleanup();
+    caml_invalid_argument("input_value: non-standard floats");
+  }
+  readblock((char *) dest, 8);
+  /* Fix up endianness, if needed */
+#if ARCH_FLOAT_ENDIANNESS == 0x76543210
+  /* Host is big-endian; fix up if data read is little-endian */
+  if (code != CODE_DOUBLE_BIG) Reverse_64(dest, dest);
+#elif ARCH_FLOAT_ENDIANNESS == 0x01234567
+  /* Host is little-endian; fix up if data read is big-endian */
+  if (code != CODE_DOUBLE_LITTLE) Reverse_64(dest, dest);
+#else
+  /* Host is neither big nor little; permute as appropriate */
+  if (code == CODE_DOUBLE_LITTLE)
+    Permute_64(dest, ARCH_FLOAT_ENDIANNESS, dest, 0x01234567)
+  else
+    Permute_64(dest, ARCH_FLOAT_ENDIANNESS, dest, 0x76543210);
+#endif
+}
+
+static void readfloats(double * dest, mlsize_t len, unsigned int code)
+{
+  mlsize_t i;
+  if (sizeof(double) != 8) {
+    intern_cleanup();
+    caml_invalid_argument("input_value: non-standard floats");
+  }
+  readblock((char *) dest, len * 8);
+  /* Fix up endianness, if needed */
+#if ARCH_FLOAT_ENDIANNESS == 0x76543210
+  /* Host is big-endian; fix up if data read is little-endian */
+  if (code != CODE_DOUBLE_ARRAY8_BIG &&
+      code != CODE_DOUBLE_ARRAY32_BIG) {
+    for (i = 0; i < len; i++) Reverse_64(dest + i, dest + i);
+  }
+#elif ARCH_FLOAT_ENDIANNESS == 0x01234567
+  /* Host is little-endian; fix up if data read is big-endian */
+  if (code != CODE_DOUBLE_ARRAY8_LITTLE &&
+      code != CODE_DOUBLE_ARRAY32_LITTLE) {
+    for (i = 0; i < len; i++) Reverse_64(dest + i, dest + i);
+  }
+#else
+  /* Host is neither big nor little; permute as appropriate */
+  if (code == CODE_DOUBLE_ARRAY8_LITTLE ||
+      code == CODE_DOUBLE_ARRAY32_LITTLE) {
+    for (i = 0; i < len; i++)
+      Permute_64(dest + i, ARCH_FLOAT_ENDIANNESS, dest + i, 0x01234567);
+  } else {
+    for (i = 0; i < len; i++)
+      Permute_64(dest + i, ARCH_FLOAT_ENDIANNESS, dest + i, 0x76543210);
+  }
+#endif
+}
+
 /* Item on the stack with defined operation */
 struct intern_item {
   value * dest;
   intnat arg;
   enum {
-    OReadItems,
-    OFreshIOD,
-    OShift
+    OReadItems, /* read arg items and store them in dest[0], dest[1], ... */
+    OFreshOID,  /* generate a fresh OID and store it in *dest */
+    OShift      /* offset *dest by arg */
   } op;
 };
 
     if (sp >= intern_stack_limit) sp = intern_resize_stack(sp);         \
   } while(0)
 
-#define ReadItems(_n)                                                   \
+#define ReadItems(_dest,_n)                                             \
   do {                                                                  \
     if (_n > 0) {                                                       \
       PushItem();                                                       \
       sp->op = OReadItems;                                              \
-      sp->dest = dest;                                                  \
+      sp->dest = _dest;                                                 \
       sp->arg = _n;                                                     \
-      dest += _n;                                                       \
     }                                                                   \
   } while(0)
 
   sp = intern_stack;
 
   /* Initially let's try to read the first object from the stream */
-  v = *dest;
-  ReadItems(1);
+  ReadItems(dest, 1);
 
   /* The un-marshaler loop, the recursion is unrolled */
   while(sp != intern_stack) {
 
-  /* Pop one more item to un-marshal, if any */
+  /* Interpret next item on the stack */
   dest = sp->dest;
-
-  /* Interpret next item on the stack */
-  if (sp->op == OFreshIOD) {
+  switch (sp->op) {
+  case OFreshOID:
     /* Refresh the object ID */
-    if (camlinternaloo_last_id == NULL)
+    if (camlinternaloo_last_id == NULL) {
       camlinternaloo_last_id = caml_named_value("CamlinternalOO.last_id");
-    if (camlinternaloo_last_id == NULL)
-      camlinternaloo_last_id = (value*)-1;
-    else {
+      if (camlinternaloo_last_id == NULL)
+        camlinternaloo_last_id = (value*) (-1);
+    }
+    if (camlinternaloo_last_id != (value*) (-1)) {
       value id = Field(*camlinternaloo_last_id,0);
-      Field(dest,-1) = id;
+      Field(dest, 0) = id;
       Field(*camlinternaloo_last_id,0) = id + 2;
     }
-    if (--(sp->arg) == 0) sp--;
-  } else if (sp->op == OShift) {
+    /* Pop item and iterate */
+    sp--;
+    break;
+  case OShift:
     /* Shift value by an offset */
     *dest += sp->arg;
-  } else if (sp->op == OReadItems) {
-  
-  /* Pop one more item to un-marshal, if any */
-  sp->dest++;
-  if (--(sp->arg) == 0) sp--;
-
-    /* Read an item */
+    /* Pop item and iterate */
+    sp--;
+    break;
+  case OReadItems:
+    /* Pop item */
+    sp->dest++;
+    if (--(sp->arg) == 0) sp--;
+    /* Read a value and set v to this value */
   code = read8u();
   if (code >= PREFIX_SMALL_INT) {
     if (code >= PREFIX_SMALL_BLOCK) {
     read_block:
       if (size == 0) {
         v = Atom(tag);
-        *dest = v; 
       } else {
         v = Val_hp(intern_dest);
-        *dest = v;
         if (intern_obj_table != NULL) intern_obj_table[obj_counter++] = v;
-        dest = (value *) (intern_dest + 1);
         *intern_dest = Make_header(size, tag, intern_color);
         intern_dest += 1 + size;
         /* For objects, we need to freshen the oid */
-        if (tag == Object_tag && camlinternaloo_last_id != (value*)-1) {
-          /* Make a spare buffer for the two elements retrieved later */
-          dest += 2;
+        if (tag == Object_tag) {
+          Assert(size >= 2);
           /* Request to read rest of the elements of the block */
-          ReadItems(size-2);
-          /* Restore back the pointer - the macro increments dest */
-          dest = dest-size;
-          /* Push new item on the stack */
+          ReadItems(&Field(v, 2), size - 2);
+          /* Request freshing OID */
           PushItem();
-          /* Request freshing OID */
-          sp->op = OFreshIOD;                                           
-          sp->dest = dest;                                              
+          sp->op = OFreshOID;                                           
+          sp->dest = &Field(v, 1);
           sp->arg = 1;
-          /* Finally read other two items: fields and methods */
-          ReadItems(2);
+          /* Finally read first two block elements: method table and old OID */
+          ReadItems(&Field(v, 0), 2);
         } else
           /* If it's not an object then read the contents of the block */
-          ReadItems(size);
+          ReadItems(&Field(v, 0), size);
       }
     } else {
       /* Small integer */
       v = Val_int(code & 0x3F);
-      *dest = v;
     }
   } else {
     if (code >= PREFIX_SMALL_STRING) {
         goto read_string;
       case CODE_DOUBLE_LITTLE:
       case CODE_DOUBLE_BIG:
-        if (sizeof(double) != 8) {
-          intern_cleanup();
-          caml_invalid_argument("input_value: non-standard floats");
-        }
         v = Val_hp(intern_dest);
         if (intern_obj_table != NULL) intern_obj_table[obj_counter++] = v;
         *intern_dest = Make_header(Double_wosize, Double_tag, intern_color);
         intern_dest += 1 + Double_wosize;
-        readblock((char *) v, 8);
-#if ARCH_FLOAT_ENDIANNESS == 0x76543210
-        if (code != CODE_DOUBLE_BIG) Reverse_64(v, v);
-#elif ARCH_FLOAT_ENDIANNESS == 0x01234567
-        if (code != CODE_DOUBLE_LITTLE) Reverse_64(v, v);
-#else
-        if (code == CODE_DOUBLE_LITTLE)
-          Permute_64(v, ARCH_FLOAT_ENDIANNESS, v, 0x01234567)
-        else
-          Permute_64(v, ARCH_FLOAT_ENDIANNESS, v, 0x76543210);
-#endif
+        readfloat((double *) v, code);
         break;
       case CODE_DOUBLE_ARRAY8_LITTLE:
       case CODE_DOUBLE_ARRAY8_BIG:
         len = read8u();
       read_double_array:
-        if (sizeof(double) != 8) {
-          intern_cleanup();
-          caml_invalid_argument("input_value: non-standard floats");
-        }
         size = len * Double_wosize;
         v = Val_hp(intern_dest);
         if (intern_obj_table != NULL) intern_obj_table[obj_counter++] = v;
         *intern_dest = Make_header(size, Double_array_tag, intern_color);
         intern_dest += 1 + size;
-        readblock((char *) v, len * 8);
-#if ARCH_FLOAT_ENDIANNESS == 0x76543210
-        if (code != CODE_DOUBLE_ARRAY8_BIG &&
-            code != CODE_DOUBLE_ARRAY32_BIG) {
-          mlsize_t i;
-          for (i = 0; i < len; i++) Reverse_64((value)((double *)v + i),
-                                               (value)((double *)v + i));
-        }
-#elif ARCH_FLOAT_ENDIANNESS == 0x01234567
-        if (code != CODE_DOUBLE_ARRAY8_LITTLE &&
-            code != CODE_DOUBLE_ARRAY32_LITTLE) {
-          mlsize_t i;
-          for (i = 0; i < len; i++) Reverse_64((value)((double *)v + i),
-                                               (value)((double *)v + i));
-        }
-#else
-        if (code == CODE_DOUBLE_ARRAY8_LITTLE ||
-            code == CODE_DOUBLE_ARRAY32_LITTLE) {
-          mlsize_t i;
-          for (i = 0; i < len; i++)
-            Permute_64((value)((double *)v + i), ARCH_FLOAT_ENDIANNESS,
-                       (value)((double *)v + i), 0x01234567);
-        } else {
-          mlsize_t i;
-          for (i = 0; i < len; i++)
-            Permute_64((value)((double *)v + i), ARCH_FLOAT_ENDIANNESS,
-                       (value)((double *)v + i), 0x76543210);
-        }
-#endif
+        readfloats((double *) v, len, code);
         break;
       case CODE_DOUBLE_ARRAY32_LITTLE:
       case CODE_DOUBLE_ARRAY32_BIG:
         break;
       case CODE_INFIXPOINTER:
         ofs = read32u();
+        /* Read a value to *dest, then offset *dest by ofs */
         PushItem();                                                     
+        sp->dest = dest;
         sp->op = OShift;                                                
-        sp->arg = ofs;                                                   
-        ReadItems(1);
-        break;
+        sp->arg = ofs;
+        ReadItems(dest, 1);
+        continue;  /* with next iteration of main loop, skipping *dest = v */
       case CODE_CUSTOM:
         ops = caml_find_custom_operations((char *) intern_src);
         if (ops == NULL) {
         caml_failwith("input_value: ill-formed message");
       }
     }
+  } 
+  /* end of case OReadItems */
   *dest = v;
-  }
+  break;
+  default:
+    Assert(0);
   }
   }
   /* We are done. Cleanup the stack and leave the function */
 (*                                                                     *)
 (***********************************************************************)
 
-(* $Id: lexer.mll 11156 2011-07-27 14:17:02Z doligez $ *)
+(* $Id: lexer.mll 12419 2012-05-02 14:41:55Z doligez $ *)
 
 (* The lexical analyzer for lexer definitions. Bootstrapped! *)
 
 let get_stored_string () = Buffer.contents string_buff
 
 let char_for_backslash = function
-    'n' -> '\n'
-  | 't' -> '\t'
-  | 'b' -> '\b'
-  | 'r' -> '\r'
+    'n' -> '\010'
+  | 'r' -> '\013'
+  | 'b' -> '\008'
+  | 't' -> '\009'
   | c   -> c
 
 let raise_lexical_error lexbuf msg =
 let identbody =
   ['A'-'Z' 'a'-'z' '_' '\192'-'\214' '\216'-'\246' '\248'-'\255' '\'' '0'-'9']
 let backslash_escapes =
-  ['\\' '"' '\'' 'n' 't' 'b' 'r']
+  ['\\' '\'' '"' 'n' 't' 'b' 'r' ' ']
 
 rule main = parse
     [' ' '\013' '\009' '\012' ] +

ocamlbuild/display.ml

     match log_file with
     | None -> None
     | Some fn ->
-        let oc = open_out_gen [Open_text; Open_wronly; Open_creat; Open_trunc] 0o644 fn in
+        let oc = open_out_gen [Open_text; Open_wronly; Open_creat; Open_trunc] 0o666 fn in
         let f = Format.formatter_of_out_channel oc in
         Format.fprintf f "### Starting build.\n";
         Some (f, oc)

ocamlbuild/hygiene.ml

                @ or@ use@ other@ options@ (such@ as@ defining@ hygiene@ exceptions\
                @ or@ using@ the@ -no-hygiene@ option).@]"
                m (if m = 1 then "" else "s") fn;
-            let oc = open_out_gen [Open_wronly; Open_creat; Open_trunc; Open_binary] 0o755 fn in
+            let oc = open_out_gen [Open_wronly; Open_creat; Open_trunc; Open_binary] 0o777 fn in
             (* See PR #5338: under mingw, one produces a shell script, which must follow
                Unix eol convention; hence Open_binary. *)
             let fp = Printf.fprintf in

ocamlbuild/main.ml

 ;;
 
 let show_tags () =
+  Log.eprintf "Warning: these do not include dynamically-generated tags, such as \
+    link, compile, pack, byte, native, c, pdf... (this list is by no means \
+    exhaustive).\n";
   List.iter begin fun path ->
     Log.eprintf "@[<2>Tags for %S:@ {. %a .}@]" path Tags.print (tags_of_pathname path)
   end !Options.show_tags

ocamlbuild/my_std.ml

 (* USEFUL FOR DIGEST DEBUGING
   let digest_log_hash = Hashtbl.create 103;;
   let digest_log = "digest.log";;
-  let digest_log_oc = open_out_gen [Open_append;Open_wronly;Open_text;Open_creat] 0o644 digest_log;;
+  let digest_log_oc = open_out_gen [Open_append;Open_wronly;Open_text;Open_creat] 0o666 digest_log;;
   let my_to_hex x = to_hex x ^ ";";;
   if sys_file_exists digest_log then
     with_input_file digest_log begin fun ic ->

ocamlbuild/ocaml_specific.ml

 let () =
   pflag ["ocaml"; "native"; "compile"] "for-pack"
     (fun param -> S [A "-for-pack"; A param]);
+  pflag ["ocaml"; "native"; "pack"] "for-pack"
+    (fun param -> S [A "-for-pack"; A param]);
   pflag ["ocaml"; "native"; "compile"] "inline"
     (fun param -> S [A "-inline"; A param]);
   pflag ["ocaml"; "compile"] "pp"

otherlibs/bigarray/bigarray.ml

 (*                                                                     *)
 (***********************************************************************)
 
-(* $Id: bigarray.ml 12327 2012-04-09 10:23:50Z xleroy $ *)
+(* $Id: bigarray.ml 12432 2012-05-06 08:23:16Z xleroy $ *)
 
 (* Module [Bigarray]: large, multi-dimensional, numerical arrays *)
 
                      = "caml_ba_map_file_bytecode" "caml_ba_map_file"
   let map_file fd ?(pos = 0L) kind layout shared dims =
     map_internal fd kind layout shared dims pos
-  external release: ('a, 'b, 'c) t -> unit
-     = "caml_ba_release"
 end
 
 module Array1 = struct
     ba
   let map_file fd ?pos kind layout shared dim =
     Genarray.map_file fd ?pos kind layout shared [|dim|]
-  external release: ('a, 'b, 'c) t -> unit
-     = "caml_ba_release"
 end
 
 module Array2 = struct
     ba
   let map_file fd ?pos kind layout shared dim1 dim2 =
     Genarray.map_file fd ?pos kind layout shared [|dim1;dim2|]
-  external release: ('a, 'b, 'c) t -> unit
-     = "caml_ba_release"
 end
 
 module Array3 = struct
     ba
   let map_file fd ?pos kind layout shared dim1 dim2 dim3 =
     Genarray.map_file fd ?pos kind layout shared [|dim1;dim2;dim3|]
-  external release: ('a, 'b, 'c) t -> unit
-     = "caml_ba_release"
 end
 
 external genarray_of_array1: ('a, 'b, 'c) Array1.t -> ('a, 'b, 'c) Genarray.t

otherlibs/bigarray/bigarray.mli

 (*                                                                     *)
 (***********************************************************************)
 
-(* $Id: bigarray.mli 12327 2012-04-09 10:23:50Z xleroy $ *)
+(* $Id: bigarray.mli 12432 2012-05-06 08:23:16Z xleroy $ *)
 
 (** Large, multi-dimensional, numerical arrays.
 
      or a SIGBUS signal may be raised. This happens, for instance, if the
      file is shrinked. *)
 
-  val release: ('a, 'b, 'c) t -> unit
-  (** Release the resources associated with the given big array,
-     then set all of its dimensions to 0, causing subsequent accesses
-     to the big array to fail.  This releasing of resources is performed
-     automatically by the garbage collector when the big array is no longer
-     referenced by the program.  However, memory behavior of the program
-     can be improved by releasing the resources explicitly via
-     [Genarray.release] as soon as the big array is no longer useful.
-
-     If the big array was created with [Genarray.create], the memory
-     space occupied by its data is freed.  If the big array was
-     created with [Genarray.map_file], updates performed on the array
-     are flushed to the file (if the mapping is shared), then the
-     mapping is removed, freeing the corresponding virtual memory
-     space.  If several views on the big array data were created
-     using [Genarray.sub_*] or [Genarray.slice_*], data release occurs
-     when the last not-yet-released view is released.  Multiple calls
-     to [Genarray.release] on the same big array are safe: the second
-     and subsequent calls have no effect. *)
-
-end
+  end
 
 (** {6 One-dimensional arrays} *)
 
   (** Memory mapping of a file as a one-dimensional big array.
      See {!Bigarray.Genarray.map_file} for more details. *)
 
-  val release: ('a, 'b, 'c) t -> unit
-  (** Explicit release of the resources associated with the big array.
-     See {!Bigarray.Genarray.release} for more details. *)
-
   external unsafe_get: ('a, 'b, 'c) t -> int -> 'a = "%caml_ba_unsafe_ref_1"
   (** Like {!Bigarray.Array1.get}, but bounds checking is not always performed.
       Use with caution and only when the program logic guarantees that
-      the access is within bounds and the big array has not been released. *)
+      the access is within bounds. *)
 
   external unsafe_set: ('a, 'b, 'c) t -> int -> 'a -> unit
                      = "%caml_ba_unsafe_set_1"
   (** Like {!Bigarray.Array1.set}, but bounds checking is not always performed.
       Use with caution and only when the program logic guarantees that
-      the access is within bounds and the big array has not been released. *)
+      the access is within bounds. *)
 
 end
 
   (** Memory mapping of a file as a two-dimensional big array.
      See {!Bigarray.Genarray.map_file} for more details. *)
 
-  val release: ('a, 'b, 'c) t -> unit
-  (** Explicit release of the resources associated with the big array.
-     See {!Bigarray.Genarray.release} for more details. *)
-
   external unsafe_get: ('a, 'b, 'c) t -> int -> int -> 'a
                      = "%caml_ba_unsafe_ref_2"
-  (** Like {!Bigarray.Array2.get}, but bounds checking is not always performed.
-      Use with caution and only when the program logic guarantees that
-      the access is within bounds and the big array has not been released. *)
+  (** Like {!Bigarray.Array2.get}, but bounds checking is not always
+      performed. *)
 
   external unsafe_set: ('a, 'b, 'c) t -> int -> int -> 'a -> unit
                      = "%caml_ba_unsafe_set_2"
-  (** Like {!Bigarray.Array2.set}, but bounds checking is not always performed.
-      Use with caution and only when the program logic guarantees that
-      the access is within bounds and the big array has not been released. *)
+  (** Like {!Bigarray.Array2.set}, but bounds checking is not always
+      performed. *)
 
 end
 
   (** Memory mapping of a file as a three-dimensional big array.
      See {!Bigarray.Genarray.map_file} for more details. *)
 
-  val release: ('a, 'b, 'c) t -> unit
-  (** Explicit release of the resources associated with the big array.
-     See {!Bigarray.Genarray.release} for more details. *)
-
   external unsafe_get: ('a, 'b, 'c) t -> int -> int -> int -> 'a
                      = "%caml_ba_unsafe_ref_3"
-  (** Like {!Bigarray.Array3.get}, but bounds checking is not always performed.
-      Use with caution and only when the program logic guarantees that
-      the access is within bounds and the big array has not been released. *)
+  (** Like {!Bigarray.Array3.get}, but bounds checking is not always
+      performed. *)
 
   external unsafe_set: ('a, 'b, 'c) t -> int -> int -> int -> 'a -> unit
                      = "%caml_ba_unsafe_set_3"
-  (** Like {!Bigarray.Array3.set}, but bounds checking is not always performed.
-      Use with caution and only when the program logic guarantees that
-      the access is within bounds and the big array has not been released. *)
+  (** Like {!Bigarray.Array3.set}, but bounds checking is not always
+      performed. *)
 
 end
 

otherlibs/bigarray/bigarray_stubs.c

 /*                                                                     */
 /***********************************************************************/
 
-/* $Id: bigarray_stubs.c 12327 2012-04-09 10:23:50Z xleroy $ */
+/* $Id: bigarray_stubs.c 12432 2012-05-06 08:23:16Z xleroy $ */
 
 #include <stddef.h>
 #include <stdarg.h>
   return Val_int(Caml_ba_array_val(vb)->flags & CAML_BA_LAYOUT_MASK);
 }
 
-/* Finalization / release of a big array */
+/* Finalization of a big array */
 
 static void caml_ba_finalize(value v)
 {
   struct caml_ba_array * b = Caml_ba_array_val(v);
-  intnat i;
 
   switch (b->flags & CAML_BA_MANAGED_MASK) {
   case CAML_BA_EXTERNAL:
     break;
   case CAML_BA_MANAGED:
     if (b->proxy == NULL) {
-      free(b->data);            /* no op if b->data = NULL */
+      free(b->data);
     } else {
       if (-- b->proxy->refcount == 0) {
         free(b->proxy->data);
     }
     break;
   }
-  /* Make sure that subsequent accesses to the bigarray fail (empty bounds)
-     and that subsequent calls to caml_ba_finalize do nothing. */
-  for (i = 0; i < b->num_dims; i++) b->dim[i] = 0;
-  b->data = NULL;
-  b->proxy = NULL;
-}
-
-CAMLprim value caml_ba_release(value v)
-{
-  caml_ba_finalize(v);
-  return Val_unit;
 }
 
 /* Comparison of two big arrays */

parsing/lexer.mll

 (*                                                                     *)
 (***********************************************************************)
 
-(* $Id: lexer.mll 11906 2011-12-21 08:58:56Z frisch $ *)
+(* $Id: lexer.mll 12424 2012-05-03 11:51:08Z doligez $ *)
 
 (* The lexer definition *)
 
 
 }
 
-let newline = ('\010' | '\013' | "\013\010")
+let newline = ('\010' | "\013\010" )
 let blank = [' ' '\009' '\012']
 let lowercase = ['a'-'z' '\223'-'\246' '\248'-'\255' '_']
 let uppercase = ['A'-'Z' '\192'-'\214' '\216'-'\222']

stdlib/pervasives.mli

 (*                                                                     *)
 (***********************************************************************)
 
-(* $Id: pervasives.mli 12407 2012-04-27 09:56:05Z weis $ *)
+(* $Id: pervasives.mli 12417 2012-05-02 14:40:23Z doligez $ *)
 
 (** The initially opened module.
 
 (** List concatenation. *)
 
 
-(** {6 Input/output} *)
+(** {6 Input/output}
+    Note: all input/output functions can raise [Sys_error] when the system
+    calls they invoke fail. *)
 
 type in_channel
 (** The type of input channel. *)

testsuite/tests/lib-bigarray/bigarrays.ml

   test 12 true (test_blit_fill complex64 [Complex.zero; Complex.one; Complex.i]
                              Complex.i 1 1);
 
-  testing_function "release";
-  let a = from_list int [1;2;3;4;5] in
-  test 1 (Array1.dim a) 5;
-  Array1.release a;
-  test 2 (Array1.dim a) 0;
-  
 (* Bi-dimensional arrays *)
 
   print_newline();
   test 7 (Array2.slice_right a 2) (from_list_fortran int [1002;2002;3002;4002;5002]);
   test 8 (Array2.slice_right a 3) (from_list_fortran int [1003;2003;3003;4003;5003]);
 
-  testing_function "release";
-  let a = (make_array2 int c_layout 0 4 6 id) in
-  test 1 (Array2.dim1 a) 4;
-  test 2 (Array2.dim2 a) 6;
-  Array2.release a;
-  test 3 (Array2.dim1 a) 0;
-  test 4 (Array2.dim2 a) 0;
-
 (* Tri-dimensional arrays *)
 
   print_newline();
   test 6 (Array3.slice_right_1 a 1 2) (from_list_fortran int [112;212;312]);
   test 7 (Array3.slice_right_1 a 3 1) (from_list_fortran int [131;231;331]);
 
-  testing_function "release";
-  let a = (make_array3 int c_layout 0 4 5 6 id) in
-  test 1 (Array3.dim1 a) 4;
-  test 2 (Array3.dim2 a) 5;
-  test 3 (Array3.dim3 a) 6;
-  Array3.release a;
-  test 4 (Array3.dim1 a) 0;
-  test 5 (Array3.dim2 a) 0;
-  test 6 (Array3.dim3 a) 0;
-
 (* Reshaping *)
   print_newline();
   testing_function "------ Reshaping --------";
     let a = Array1.map_file fd float64 c_layout true 10000 in
     Unix.close fd;
     for i = 0 to 9999 do a.{i} <- float i done;
-    Array1.release a;
     let fd = Unix.openfile mapped_file [Unix.O_RDONLY] 0 in
     let b = Array2.map_file fd float64 fortran_layout false 100 (-1) in
     Unix.close fd;
       done
     done;
     test 1 !ok true;
-    b.{50,50} <- (-1.0);         (* private mapping -> no effect on file *)
-    Array2.release b;
+    b.{50,50} <- (-1.0);
     let fd = Unix.openfile mapped_file [Unix.O_RDONLY] 0 in
     let c = Array2.map_file fd float64 c_layout false (-1) 100 in
     Unix.close fd;
       done
     done;
     test 2 !ok true;
-    Array2.release c;
     let fd = Unix.openfile mapped_file [Unix.O_RDONLY] 0 in
     let c = Array2.map_file fd ~pos:800L float64 c_layout false (-1) 100 in
     Unix.close fd;
       done
     done;
     test 3 !ok true;
-    Array2.release c;
     let fd = Unix.openfile mapped_file [Unix.O_RDONLY] 0 in
     let c = Array2.map_file fd ~pos:79200L float64 c_layout false (-1) 100 in
     Unix.close fd;
     for j = 0 to 99 do
       if c.{0,j} <> float (100 * 99 + j) then ok := false
     done;
-    test 4 !ok true;
-    Array2.release c;
-    test 5 (Array2.dim1 c) 0;        
-    test 5 (Array2.dim2 c) 0
+    test 4 !ok true
   end;
-  (* Win32 doesn't let us erase the file if any mapping on the file is
-     still active.  Normally, they have all been released explicitly. *)
+  (* Force garbage collection of the mapped bigarrays above, otherwise
+     Win32 doesn't let us erase the file.  Notice the begin...end above
+     so that the VM doesn't keep stack references to the mapped bigarrays. *)
+  Gc.full_major();
   Sys.remove mapped_file;
 
   ()

testsuite/tests/lib-bigarray/bigarrays.reference

  1... 2... 3... 4... 5... 6... 7... 8... 9...
 blit, fill
  1... 2... 3... 4... 5... 6... 7... 8... 9... 10... 11... 12...
-release
- 1... 2...
 
 ------ Array2 --------
 
  1... 2...
 slice
  1... 2... 3... 4... 5... 6... 7... 8...
-release
- 1... 2... 3... 4...
 
 ------ Array3 --------
 
  1... 2... 3... 4... 5... 6...
 slice1
  1... 2... 3... 4... 5... 6... 7...
-release
- 1... 2... 3... 4... 5... 6...
 
 ------ Reshaping --------
 
 output_value/input_value
  1... 2... 3... 4... 5... 6... 7... 8... 9... 10... 11... 12... 13... 14...
 map_file
- 1... 2... 3... 4... 5... 5...
+ 1... 2... 3... 4...

testsuite/tests/lib-marshal/intext.ml

 (* Test for output_value / input_value *)
 
-let max_data_depth = 2600000
+let max_data_depth = 500000
 
 type t = A | B of int | C of float | D of string | E of char
        | F of t | G of t * t | H of int * t | I of t * float | J
 
 (* Test for really deep data structures *)
 let test_deep () =
+  (* Right-leaning *)
   let rec loop acc i =
     if i < max_data_depth
     then loop (i :: acc) (i+1)
     else acc in
   let x = loop [] 0 in
   let s = Marshal.to_string x [] in
-  test 425 (Marshal.from_string s 0 = x)
+  test 425 (Marshal.from_string s 0 = x);
+  (* Left-leaning *)
+  let rec loop acc i =
+    if i < max_data_depth
+    then loop (G(acc, B i)) (i+1)
+    else acc in
+  let x = loop A 0 in
+  let s = Marshal.to_string x [] in
+  test 426 (Marshal.from_string s 0 = x)
 
+(* Test for objects *)
 class foo = object (self : 'self) 
   val data1 = "foo"
   val data2 = "bar"
   let x = new foo in
   let s = Marshal.to_string x [Marshal.Closures] in
   let x = Marshal.from_string s 0 in
-  test 426 (x#test1 = "foobar");
-  test 427 (x#test2 = false);
-  test 428 (x#test3 = "foobar");
-  test 429 (x#test4 = 42L);
+  test 500 (x#test1 = "foobar");
+  test 501 (x#test2 = false);
+  test 502 (x#test3 = "foobar");
+  test 503 (x#test4 = 42L);
   let x = new bar in
   let s = Marshal.to_string x [Marshal.Closures] in
   let x = Marshal.from_string s 0 in
-  test 430 (x#test1 = "footest5test3test442");
-  test 431 (x#test2 = false);
-  test 432 (x#test3 = "footest5test3test442");
-  test 433 (x#test4 = 42L);
-  let x = new foobar in
-  let s = Marshal.to_string x [Marshal.Closures] in
+  test 504 (x#test1 = "footest5test3test442");
+  test 505 (x#test2 = false);
+  test 506 (x#test3 = "footest5test3test442");
+  test 507 (x#test4 = 42L);
+  let x0 = new foobar in
+  let s = Marshal.to_string x0 [Marshal.Closures] in
   let x = Marshal.from_string s 0 in
-  test 434 (x#test1 = "footest5test3test442");
-  test 435 (x#test2 = false);
-  test 436 (x#test3 = "footest5test3test442");
-  test 437 (x#test4 = 42L)
+  test 508 (x#test1 = "footest5test3test442");
+  test 509 (x#test2 = false);
+  test 510 (x#test3 = "footest5test3test442");
+  test 511 (x#test4 = 42L);
+  test 512 (Oo.id x = Oo.id x0 + 1)     (* PR#5610 *)
 
 (* Test for infix pointers *)
 let test_infix () =
-  let is_odd n =
-    let t = true and
-        f = false in
-    let rec odd n =
-      if n = 0
-      then t
-      else even (n-1)
-    and even n =
-      if n = 0
-      then f
-      else odd (n-1)
-    in
-    odd n
+  let t = true and
+      f = false in
+  let rec odd n =
+    if n = 0
+    then f
+    else even (n-1)
+  and even n =
+    if n = 0
+    then t
+    else odd (n-1)
   in
-  let s = Marshal.to_string is_odd [Marshal.Closures] in
-  let is_odd' : int -> bool = Marshal.from_string s 0 in
-  test 438 (is_odd' 41 = false);
-  test 439 (is_odd' 41 = is_odd 41);
-  test 438 (is_odd' 142 = true);
-  test 439 (is_odd' 142 = is_odd 142)
+  let s = Marshal.to_string (odd, even) [Marshal.Closures] in
+  let (odd', even': (int -> bool) * (int -> bool)) = Marshal.from_string s 0 in
+  test 600 (odd' 41 = true);
+  test 601 (odd' 41 = odd 41);
+  test 602 (odd' 142 = false);
+  test 603 (odd' 142 = odd 142);
+  test 604 (even' 41 = false);
+  test 605 (even' 41 = even 41);
+  test 606 (even' 142 = true);
+  test 607 (even' 142 = even 142)
   
 let main() =
   if Array.length Sys.argv <= 2 then begin

testsuite/tests/lib-marshal/intext.reference

 Test 424 passed.
 Test 425 passed.
 Test 426 passed.
-Test 427 passed.
-Test 428 passed.
-Test 429 passed.
-Test 430 passed.
-Test 431 passed.
-Test 432 passed.
-Test 433 passed.
-Test 434 passed.
-Test 435 passed.
-Test 436 passed.
-Test 437 passed.
-Test 438 passed.
-Test 439 passed.
-Test 438 passed.
-Test 439 passed.
+Test 500 passed.
+Test 501 passed.
+Test 502 passed.
+Test 503 passed.
+Test 504 passed.
+Test 505 passed.
+Test 506 passed.
+Test 507 passed.
+Test 508 passed.
+Test 509 passed.
+Test 510 passed.
+Test 511 passed.
+Test 512 passed.
+Test 600 passed.
+Test 601 passed.
+Test 602 passed.
+Test 603 passed.
+Test 604 passed.
+Test 605 passed.
+Test 606 passed.
+Test 607 passed.

testsuite/tests/typing-poly/poly.ml.principal.reference

 Error: Constraints are not satisfied in this type.
        Type 'a u t should be an instance of g t
 # type 'a u = 'a constraint 'a = g
-and 'a v = 'a u t constraint 'a = int
+and 'a v = 'a u t constraint 'a = g
 #     Characters 38-58:
   type 'a u = < m : 'a v > and 'a v = 'a list u;;
       ^^^^^^^^^^^^^^^^^^^^

testsuite/tests/typing-poly/poly.ml.reference

 Error: Constraints are not satisfied in this type.
        Type 'a u t should be an instance of g t
 # type 'a u = 'a constraint 'a = g
-and 'a v = 'a u t constraint 'a = int
+and 'a v = 'a u t constraint 'a = g
 #     Characters 38-58:
   type 'a u = < m : 'a v > and 'a v = 'a list u;;
       ^^^^^^^^^^^^^^^^^^^^
   = struct let f (x : <m : 'a. 'a * ('a * 'foo)> as 'foo) = () end;;
     ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
 Error: Signature mismatch:
-       Modules do not match:
-         sig val f : (< m : 'a. 'a * ('a * 'b) > as 'b) -> unit end
-       is not included in
-         sig
-           val f : < m : 'b. 'b * ('b * < m : 'c. 'c * 'a > as 'a) > -> unit
-         end
+       ...
        Values do not match:
          val f : (< m : 'a. 'a * ('a * 'b) > as 'b) -> unit
        is not included in

toplevel/toploop.ml

 (*                                                                     *)
 (***********************************************************************)
 
-(* $Id: toploop.ml 12399 2012-04-25 07:51:29Z garrigue $ *)
+(* $Id: toploop.ml 12439 2012-05-08 04:26:13Z garrigue $ *)
 
 (* The interactive toplevel loop *)
 
       Typecore.reset_delayed_checks ();
       let (str, sg, newenv) =
         Typemod.type_structure oldenv sstr Location.none in
-      let _ =
-        Includemod.compunit "//toplevel//" sg "(inferred signature)" sg in
+      let sg' = Typemod.simplify_signature sg in
+      ignore (Includemod.signatures oldenv sg sg');
       Typecore.force_delayed_checks ();
       let lam = Translmod.transl_toplevel_definition str in
       Warnings.check_fatal ();
                     let ty = Printtyp.tree_of_type_scheme exp.exp_type in
                     Ophr_eval (outv, ty)
                 | [] -> Ophr_signature []
-                | _ -> Ophr_signature (item_list newenv
-                                             (Typemod.simplify_signature sg))
+                | _ -> Ophr_signature (item_list newenv sg')
               else Ophr_signature []
           | Exception exn ->
               toplevel_env := oldenv;
 (*                                                                     *)
 (***********************************************************************)
 
-(* $Id: ctype.ml 12289 2012-03-28 10:39:05Z garrigue $ *)
+(* $Id: ctype.ml 12439 2012-05-08 04:26:13Z garrigue $ *)
 
 (* Operations on core types *)
 
 let get_level env p = 
   try
     match (Env.find_type p env).type_newtype_level with
-      | None -> Path.binding_time p
-      | Some (x, _) -> x
-  with 
-    | _ -> 
-      (* no newtypes in predef *)
-      Path.binding_time p
+    | None -> Path.binding_time p
+    | Some (x, _) -> x
+  with Not_found -> 
+    (* no newtypes in predef *)
+    Path.binding_time p
 
 let rec update_level env level ty =
   let ty = repr ty in
 let enforce_constraints env ty =
   match ty with
     {desc = Tconstr (path, args, abbrev); level = level} ->
-      let decl = Env.find_type path env in
-      ignore
-        (subst env level Public (ref Mnil) None decl.type_params args
-           (newvar2 level))
+      begin try
+        let decl = Env.find_type path env in
+        ignore
+          (subst env level Public (ref Mnil) None decl.type_params args
+             (newvar2 level))
+      with Not_found -> ()
+      end
   | _ ->
       assert false
 
         with Cannot_expand ->
           if !Clflags.recursive_types &&
             (in_current_module p || in_pervasives p ||
-             is_datatype (Env.find_type p env))
+             try is_datatype (Env.find_type p env) with Not_found -> false)
           then ()
           else iter_type_expr (non_recursive_abbrev env ty0) ty
         end
   in
   iterator t
 
-let is_abstract_newtype env p = 
-  let decl = Env.find_type p env in 
-  not (decl.type_newtype_level = None) &&
-  decl.type_manifest = None &&
-  decl.type_kind = Type_abstract
+let is_abstract_newtype env p =
+  try
+    let decl = Env.find_type p env in 
+    not (decl.type_newtype_level = None) &&
+    decl.type_manifest = None &&
+    decl.type_kind = Type_abstract
+  with Not_found -> false
 
 (* mcomp type_pairs subst env t1 t2 does not raise an 
    exception if it is possible that t1 and t2 are actually
     in_pervasives p ||
     in_current_module p && decl.type_newtype_level = None
   in
-  let decl = Env.find_type p1 env in
-  let decl' = Env.find_type p2 env in
-  if Path.same p1 p2 then
-    if non_aliased p1 decl then mcomp_list type_pairs subst env tl1 tl2 else ()
-  else match decl.type_kind, decl'.type_kind with
-  | Type_record (lst,r), Type_record (lst',r') when r = r' ->
-      mcomp_list type_pairs subst env tl1 tl2;
-      mcomp_record_description type_pairs subst env lst lst'
-  | Type_variant v1, Type_variant v2 ->
-      mcomp_list type_pairs subst env tl1 tl2;
-      mcomp_variant_description type_pairs subst env v1 v2
-  | Type_variant _, Type_record _
-  | Type_record _, Type_variant _ -> raise (Unify [])
-  | _ ->
-      if non_aliased p1 decl && (non_aliased p2 decl' || is_datatype decl')
-      || is_datatype decl && non_aliased p2 decl' then raise (Unify [])
+  try
+    let decl = Env.find_type p1 env in
+    let decl' = Env.find_type p2 env in
+    if Path.same p1 p2 then
+      (if non_aliased p1 decl then mcomp_list type_pairs subst env tl1 tl2)
+    else match decl.type_kind, decl'.type_kind with
+    | Type_record (lst,r), Type_record (lst',r') when r = r' ->
+        mcomp_list type_pairs subst env tl1 tl2;
+        mcomp_record_description type_pairs subst env lst lst'
+    | Type_variant v1, Type_variant v2 ->
+        mcomp_list type_pairs subst env tl1 tl2;
+        mcomp_variant_description type_pairs subst env v1 v2
+    | Type_variant _, Type_record _
+    | Type_record _, Type_variant _ -> raise (Unify [])
+    | _ ->
+        if non_aliased p1 decl && (non_aliased p2 decl' || is_datatype decl')
+        || is_datatype decl && non_aliased p2 decl' then raise (Unify [])
+  with Not_found -> ()
 
 and mcomp_type_option type_pairs subst env t t' = 
   match t, t' with
     end
   in find ty; unmark_type ty; !lowest
 
-let find_newtype_level env path = 
-  match (Env.find_type path env).type_newtype_level with
-    Some x -> x
+let find_newtype_level env path =
+  try match (Env.find_type path env).type_newtype_level with
+  | Some x -> x
   | None -> assert false
+  with Not_found -> assert false
         
 let add_gadt_equation env source destination =
   let destination = duplicate_type destination in 
       | (Tconstr (p1, tl1, _), Tconstr (p2, tl2, _)) when Path.same p1 p2 ->
           if !umode = Expression || not !generate_equations
           || in_current_module p1 || in_pervasives p1
-          || is_datatype (Env.find_type p1 !env)
+          || try is_datatype (Env.find_type p1 !env) with Not_found -> false
           then
             unify_list env tl1 tl2
           else
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.