Version française
Home     About     Download     Resources     Contact us    
Browse thread
Patch Caml Light 0.6 -> 0.61
[ Home ] [ Index: by date | by threads ]
[ Search: ]

[ Message by date: previous | next ] [ Message in thread: previous | next ] [ Thread: previous | next ]
Date: -- (:)
From: Xavier Leroy <xleroy@p...>
Subject: Patch Caml Light 0.6 -> 0.61
This patch is to be applied to the Caml Light 0.6 source distribution
and brings it to version 0.61.

Changes:

* Pattern-matching against (C x) where C has several arguments now works
  correctly.
* The fatal error "labels_of_type" has been fixed (it was raised when
  typing e.label, where the type inferred for e is not a record type,
  but an abbreviation for a record type).
* Hashing has been rewritten to give consistent results across all 
  architectures, including when -custom is used.
* output_value and intern_value are now fully compatible across 32-bit and
  64-bit architectures. A 32-bit architecture can read values written
  on a 64-bit architecture.
* Better error message when compiling a .ml whose .mli has not been compiled.
* The preprocessed files are more compatible with cpp: (**) instead of /**/.
* Typos in library interfaces fixed.

To use this patch:

        - cd to the distribution directory for Caml Light 0.6
                (the directory with subdirs src, config, ...)
        - save this message in a file (say, "foo")
        - run "patch -p0 < foo"
        - recompile Caml Light from scratch

diff -c -r /tmp/cl6/src/compiler/compiler.ml ./src/compiler/compiler.ml
*** /tmp/cl6/src/compiler/compiler.ml	Wed Sep 22 23:48:26 1993
--- ./src/compiler/compiler.ml	Tue Nov 16 00:42:06 1993
***************
*** 187,192 ****
--- 187,200 ----
    external_types := [];
    if file_exists (filename ^ ".mli") then begin
      try
+       if not (file_exists (filename ^ ".zi")) then begin
+         prerr_begline " Cannot find file ";
+         prerr_string filename;
+         prerr_string ".zi. Please compile ";
+         prerr_string filename;
+         prerr_endline ".mli first.";
+         raise Toplevel
+       end;
        let intf = read_module (filename ^ ".zi") in
        start_compiling_implementation modname intf;
        enter_interface_definitions intf;
diff -c -r /tmp/cl6/src/compiler/lexer.mlp ./src/compiler/lexer.mlp
*** /tmp/cl6/src/compiler/lexer.mlp	Tue Sep 21 20:03:36 1993
--- ./src/compiler/lexer.mlp	Tue Nov 16 18:34:19 1993
***************
*** 1,8 ****
  (* The lexer definition *)
  
  {
! /**/ #open "misc";;
! /**/ #open "parser";;
  
  (* For nested comments *)
  
--- 1,8 ----
  (* The lexer definition *)
  
  {
! (**) #open "misc";;
! (**) #open "parser";;
  
  (* For nested comments *)
  
diff -c -r /tmp/cl6/src/compiler/parser.mly ./src/compiler/parser.mly
*** /tmp/cl6/src/compiler/parser.mly	Fri Jul 02 21:10:59 1993
--- ./src/compiler/parser.mly	Thu Apr 07 16:56:53 1994
***************
*** 6,13 ****
  #open "globals";;
  #open "builtins";;
  #open "syntax";;
- #open "types";;
- #open "typing";;
  #open "primdecl";;
  %}
  
--- 6,11 ----
diff -c -r /tmp/cl6/src/compiler/tr_env.ml ./src/compiler/tr_env.ml
*** /tmp/cl6/src/compiler/tr_env.ml	Wed Jul 01 19:42:55 1992
--- ./src/compiler/tr_env.ml	Wed Mar 23 23:57:33 1994
***************
*** 11,16 ****
--- 11,17 ----
  type access_path =
      Path_root
    | Path_son of int * access_path
+   | Path_tuple of access_path list
  ;;
  
  type transl_env =
***************
*** 19,27 ****
    | Tenv of (string * access_path) list * transl_env
  ;; 
  
! let translate_path root = transl where rec transl = function
!     Path_root          -> root
!   | Path_son(n, p)     -> Lprim(Pfield n, [transl p])
  ;;
  
  let rec translate_access s env =
--- 20,31 ----
    | Tenv of (string * access_path) list * transl_env
  ;; 
  
! let translate_path root =
!   let rec transl = function
!       Path_root -> root
!     | Path_son(n, p) -> Lprim(Pfield n, [transl p])
!     | Path_tuple pl -> Lprim(Pmakeblock(ConstrRegular(0,1)), map transl pl)
!   in transl
  ;;
  
  let rec translate_access s env =
***************
*** 44,57 ****
    | Tenv(L,env)   ->
        try
          match assoc s L with
!           Path_root -> raise Not_found
          | Path_son(start,rest) ->
              Lprim(Psetfield start, [translate_path (Lvar i) rest; newval])
        with Not_found ->
          transl (i+1) env
    in transl 0 env
  ;;
  
  let rec paths_of_pat path (Pat(desc,loc)) =
    match desc with
      Zvarpat s ->
--- 48,83 ----
    | Tenv(L,env)   ->
        try
          match assoc s L with
!           Path_root -> transl (i+1) env
!             (* We have two occurrences of s in the environment:
!                one is let-bound (path = Path_root) and is the value
!                at the time of the matching,
!                the other is a non-trivial access path in the data structure.
!                The latter is the one that should be modified, so we skip the
!                former. *)
          | Path_son(start,rest) ->
              Lprim(Psetfield start, [translate_path (Lvar i) rest; newval])
+         | Path_tuple pl -> fatal_error "translate_update"
        with Not_found ->
          transl (i+1) env
    in transl 0 env
  ;;
  
+ let rec pat_is_named (Pat(desc,loc)) =
+   match desc with
+     Zvarpat s -> true
+   | Zaliaspat(pat, s) -> true
+   | Zconstraintpat(pat, _) -> pat_is_named pat
+   | _ -> false
+ ;;
+ 
+ let tuple_path nfields path =
+   let rec list_of_fields i =
+     if i >= nfields then [] else Path_son(i, path) :: list_of_fields (succ i)
+   in
+     Path_tuple(list_of_fields 0)
+ ;;
+ 
  let rec paths_of_pat path (Pat(desc,loc)) =
    match desc with
      Zvarpat s ->
***************
*** 69,75 ****
    | Zconstruct1pat(cstr, p) ->
        begin match cstr.info.cs_kind with
          Constr_superfluous n ->
!           paths_of_pat path p
        | _ ->
            paths_of_pat (Path_son(0, path)) p
        end
--- 95,101 ----
    | Zconstruct1pat(cstr, p) ->
        begin match cstr.info.cs_kind with
          Constr_superfluous n ->
!           paths_of_pat (if pat_is_named p then tuple_path n path else path) p
        | _ ->
            paths_of_pat (Path_son(0, path)) p
        end
***************
*** 116,122 ****
        [] -> []
      | var::rest ->
          translate_access var env :: add (Treserved env) rest in
!   Llet(add env varlist, expr)
  ;;
  
  let add_pat_to_env env pat =
--- 142,150 ----
        [] -> []
      | var::rest ->
          translate_access var env :: add (Treserved env) rest in
!   match add env varlist with
!     [] -> expr
!   | el -> Llet(el, expr)
  ;;
  
  let add_pat_to_env env pat =
diff -c -r /tmp/cl6/src/compiler/types.ml ./src/compiler/types.ml
*** /tmp/cl6/src/compiler/types.ml	Tue Aug 24 19:49:37 1993
--- ./src/compiler/types.ml	Tue Nov 16 00:40:47 1993
***************
*** 359,361 ****
--- 359,377 ----
    | (_, _) ->
        raise Unify
  ;;
+ 
+ (* Extract the list of labels of a record type. *)
+ 
+ let rec labels_of_type ty =
+   match (type_repr ty).typ_desc with
+     Tconstr({info = {ty_abbr = Tabbrev(params, body)}}, args) ->
+       labels_of_type (expand_abbrev params body args)
+   | Tconstr(cstr, _) ->
+       begin match (type_descr_of_type_constr cstr).info.ty_desc with
+         Record_type lbl_list -> lbl_list
+       | _ -> fatal_error "labels_of_type"
+       end
+   | _ ->
+       fatal_error "labels_of_type"
+ ;;
+ 
diff -c -r /tmp/cl6/src/compiler/typing.ml ./src/compiler/typing.ml
*** /tmp/cl6/src/compiler/typing.ml	Mon Sep 13 19:28:12 1993
--- ./src/compiler/typing.ml	Tue Nov 16 00:37:25 1993
***************
*** 311,325 ****
              unify_expr expr ty ty_res;
              texp (e, ty_arg))
            lbl_expr_list;
!         let label_list =
!           match (type_repr ty).typ_desc with
!             Tconstr(cstr, _) ->
!               begin match (type_descr_of_type_constr cstr).info.ty_desc with
!                 Record_type lbl_list -> lbl_list
!               | _ -> fatal_error "labels_of_type"
!               end
!           | _ ->
!               fatal_error "labels_of_type" in
          let v = make_vect (list_length label_list) false in
            do_list (fun (lbl, e) ->
              let p = lbl.info.lbl_pos in
--- 311,317 ----
              unify_expr expr ty ty_res;
              texp (e, ty_arg))
            lbl_expr_list;
!         let label_list = labels_of_type ty in
          let v = make_vect (list_length label_list) false in
            do_list (fun (lbl, e) ->
              let p = lbl.info.lbl_pos in
diff -c -r /tmp/cl6/src/lib/fstring.mli ./src/lib/fstring.mli
*** /tmp/cl6/src/lib/fstring.mli	Fri Apr 30 23:27:19 1993
--- ./src/lib/fstring.mli	Tue Mar 08 19:43:28 1994
***************
*** 33,39 ****
    and lt_string : string -> string -> bool = 2 "<string"
    and ge_string : string -> string -> bool = 2 ">=string"
    and gt_string : string -> string -> bool = 2 ">string"
!   and compare_strings : string -> string -> int = 1 "compare_strings"
  ;;
  value string_for_read : string -> string
  ;;
--- 33,39 ----
    and lt_string : string -> string -> bool = 2 "<string"
    and ge_string : string -> string -> bool = 2 ">=string"
    and gt_string : string -> string -> bool = 2 ">string"
!   and compare_strings : string -> string -> int = 2 "compare_strings"
  ;;
  value string_for_read : string -> string
  ;;
diff -c -r /tmp/cl6/src/lib/genlex.mlp ./src/lib/genlex.mlp
*** /tmp/cl6/src/lib/genlex.mlp	Tue Sep 21 20:04:31 1993
--- ./src/lib/genlex.mlp	Fri Dec 10 19:22:20 1993
***************
*** 1,13 ****
  (* A generic lexer *)
  
! /**/ #open "float";;
! /**/ #open "int";;
! /**/ #open "ref";;
! /**/ #open "exc";;
! /**/ #open "list";;
! /**/ #open "fchar";;
! /**/ #open "fstring";;
! /**/ #open "stream";;
  
  (* The string buffering machinery *)
  
--- 1,13 ----
  (* A generic lexer *)
  
! (**) #open "float";;
! (**) #open "int";;
! (**) #open "ref";;
! (**) #open "exc";;
! (**) #open "list";;
! (**) #open "fchar";;
! (**) #open "fstring";;
! (**) #open "stream";;
  
  (* The string buffering machinery *)
  
***************
*** 97,104 ****
    and neg_number = function
      [< '(*'*) `0`..`9` as c; s >] ->
        reset_buffer(); store `-`; store c; number s
!   | [< >] ->
!       keyword_or_error `-`
      
    and number = function
      [< '(*'*) `0`..`9` as c; s >] ->
--- 97,104 ----
    and neg_number = function
      [< '(*'*) `0`..`9` as c; s >] ->
        reset_buffer(); store `-`; store c; number s
!   | [< s >] ->
!       reset_buffer(); store `-`; ident2 s
      
    and number = function
      [< '(*'*) `0`..`9` as c; s >] ->
diff -c -r /tmp/cl6/src/lib/hashtbl.ml ./src/lib/hashtbl.ml
*** /tmp/cl6/src/lib/hashtbl.ml	Mon Jun 07 22:42:36 1993
--- ./src/lib/hashtbl.ml	Tue Nov 16 01:27:01 1993
***************
*** 23,29 ****
  ;;
  
  let clear h =
-   h.max_len <- 2;
    for i = 0 to vect_length h.data - 1 do
      h.data.(i) <- Empty
    done
--- 23,28 ----
diff -c -r /tmp/cl6/src/lib/lexing.mli ./src/lib/lexing.mli
*** /tmp/cl6/src/lib/lexing.mli	Tue Jul 07 17:55:27 1992
--- ./src/lib/lexing.mli	Fri Apr 01 21:32:40 1994
***************
*** 59,65 ****
             of the first character of the matched string. The first character
             of the stream has position 0. *)
    and get_lexeme_end : lexbuf -> int
!         (* [get_lexeme_start lexbuf] returns the position in the input stream
             of the character following the last character of the matched
             string. The first character of the stream has position 0. *)
  ;;
--- 59,65 ----
             of the first character of the matched string. The first character
             of the stream has position 0. *)
    and get_lexeme_end : lexbuf -> int
!         (* [get_lexeme_end lexbuf] returns the position in the input stream
             of the character following the last character of the matched
             string. The first character of the stream has position 0. *)
  ;;
diff -c -r /tmp/cl6/src/runtime/hash.c ./src/runtime/hash.c
*** /tmp/cl6/src/runtime/hash.c	Wed Apr 28 23:46:57 1993
--- ./src/runtime/hash.c	Wed May 11 14:56:10 1994
***************
*** 16,22 ****
    hash_univ_count = Long_val(count);
    hash_accu = 0;
    hash_aux(obj);
!   return Val_long(hash_accu & Max_long);
  }
  
  #define Alpha 65599
--- 16,24 ----
    hash_univ_count = Long_val(count);
    hash_accu = 0;
    hash_aux(obj);
!   return Val_long(hash_accu & 0x3FFFFFFF);
!   /* The & has two purposes: ensure that the return value is positive
!      and give the same result on 32 bit and 64 bit architectures. */
  }
  
  #define Alpha 65599
***************
*** 29,40 ****
  {
    unsigned char * p;
    mlsize_t i;
  
    hash_univ_limit--;
    if (hash_univ_count < 0 || hash_univ_limit < 0) return;
  
!   if (Is_block(obj) && (Is_in_heap(obj) || Is_young(obj)))
!     switch(Tag_val(obj)) {
      case String_tag:
        hash_univ_count--;
        i = string_length(obj);
--- 31,63 ----
  {
    unsigned char * p;
    mlsize_t i;
+   tag_t tag;
  
    hash_univ_limit--;
    if (hash_univ_count < 0 || hash_univ_limit < 0) return;
  
!   if (Is_long(obj)) {
!     hash_univ_count--;
!     Combine(Long_val(obj));
!     return;
!   }
! 
!   /* Atoms are not in the heap, but it's better to hash their tag
!      than to do nothing. */
! 
!   if (obj >= Atom(0) && obj <= Atom(255)) {
!     tag = Tag_val(obj);
!     hash_univ_count--;
!     Combine_small(tag);
!     return;
!   }
! 
!   /* Pointers into the heap are well-structured blocks.
!      We can inspect the block contents. */
!   
!   if (Is_in_heap(obj) || Is_young(obj)) {
!     tag = Tag_val(obj);
!     switch (tag) {
      case String_tag:
        hash_univ_count--;
        i = string_length(obj);
***************
*** 42,58 ****
          Combine_small(*p);
        break;
      case Double_tag:
        hash_univ_count--;
!       i = Wosize_val(obj);
!       while (i != 0) {
!         i--;
!         Combine(Field(obj, i));
!       }
        break;
      case Abstract_tag:
      case Final_tag:
        break;
      default:
        i = Wosize_val(obj);
        while (i != 0) {
          i--;
--- 65,92 ----
          Combine_small(*p);
        break;
      case Double_tag:
+       /* For doubles, we inspect their binary representation, LSB first.
+          The results are consistent among all platforms with IEEE floats. */
        hash_univ_count--;
! #ifdef BIG_ENDIAN
!       for (p = &Byte_u(obj, sizeof(double) - 1), i = sizeof(double);
!            i > 0;
!            p--, i--)
! #else
!       for (p = &Byte_u(obj, 0), 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.
+          Better do nothing. */
        break;
      default:
+       hash_univ_count--;
+       Combine_small(tag);
        i = Wosize_val(obj);
        while (i != 0) {
          i--;
***************
*** 60,67 ****
        }
        break;
      }
!   else {
!     hash_univ_count--;
!     Combine((long) obj);
    }
  }
--- 94,102 ----
        }
        break;
      }
!     return;
    }
+ 
+   /* Otherwise, obj is a pointer outside the heap, to an object with
+      a priori unknown structure. Better to do nothing in this case. */
  }
diff -c -r /tmp/cl6/src/runtime/intext.c ./src/runtime/intext.c
*** /tmp/cl6/src/runtime/intext.c	Tue Apr 27 03:06:55 1993
--- ./src/runtime/intext.c	Tue May 10 17:14:52 1994
***************
*** 24,41 ****
  #define Hash(v) (((asize_t) ((v) >> 2)) % extern_table_size)
  
  #define Base_magic_number 0x8495A6B9
- #ifdef SIXTYFOUR
  #define Big_endian_32_magic_number Base_magic_number
  #define Little_endian_32_magic_number (Base_magic_number + 1)
! #define Big_endian_magic_number (Base_magic_number + 2)
! #define Little_endian_magic_number (Base_magic_number + 3)
  #define First_valid_magic_number Base_magic_number
  #define Last_valid_magic_number (Base_magic_number + 3)
  #else
! #define Big_endian_magic_number Base_magic_number
! #define Little_endian_magic_number (Base_magic_number + 1)
! #define First_valid_magic_number Base_magic_number
! #define Last_valid_magic_number (Base_magic_number + 1)
  #endif
  
  static void alloc_table()
--- 24,48 ----
  #define Hash(v) (((asize_t) ((v) >> 2)) % extern_table_size)
  
  #define Base_magic_number 0x8495A6B9
  #define Big_endian_32_magic_number Base_magic_number
  #define Little_endian_32_magic_number (Base_magic_number + 1)
! #define Big_endian_64_magic_number (Base_magic_number + 2)
! #define Little_endian_64_magic_number (Base_magic_number + 3)
  #define First_valid_magic_number Base_magic_number
  #define Last_valid_magic_number (Base_magic_number + 3)
+ 
+ #ifdef SIXTYFOUR
+ # ifdef BIG_ENDIAN
+ #  define Extern_magic_number Big_endian_64_magic_number
+ # else
+ #  define Extern_magic_number Little_endian_64_magic_number
+ # endif
  #else
! # ifdef BIG_ENDIAN
! #  define Extern_magic_number Big_endian_32_magic_number
! # else
! #  define Extern_magic_number Little_endian_32_magic_number
! # endif
  #endif
  
  static void alloc_table()
***************
*** 179,184 ****
--- 186,192 ----
    offset_t res;
  
    extern_size = INITIAL_EXTERN_SIZE;
+ 
    extern_block =
      (offset_t *) stat_alloc(extern_size * sizeof(unsigned long));
    extern_pos = 0;
***************
*** 188,198 ****
    res = emit_all(v);
    if (extern_pos >= Max_wosize) extern_too_big();
    stat_free((char *) extern_table);
! #ifdef BIG_ENDIAN
!   putword(chan, Big_endian_magic_number);
! #else
!   putword(chan, Little_endian_magic_number);
! #endif
    putword(chan, extern_pos);
    if (extern_pos == 0)
      putword(chan, res);
--- 196,202 ----
    res = emit_all(v);
    if (extern_pos >= Max_wosize) extern_too_big();
    stat_free((char *) extern_table);
!   putword(chan, Extern_magic_number);
    putword(chan, extern_pos);
    if (extern_pos == 0)
      putword(chan, res);
***************
*** 281,286 ****
--- 285,292 ----
  
  #ifdef SIXTYFOUR
  
+ /* Routines to convert 32-bit externed objects to 64-bit memory blocks. */
+ 
  typedef int32 value32;
  
  /* Reverse all words in a block, in case of endianness clash.
***************
*** 287,293 ****
     Works with 32-bit words. */
  
  void rev_pointers_32(p, size)
!      value32 *p;
       mlsize_t size;
  {
    value32 * q;
--- 293,299 ----
     Works with 32-bit words. */
  
  void rev_pointers_32(p, size)
!      value32 * p;
       mlsize_t size;
  {
    value32 * q;
***************
*** 398,406 ****
        }
      case Double_tag:
        *d++ = Make_header(Double_wosize, Double_tag, color);
!       *((double *) d) = *((double *) p);
        p += sizeof(double) / sizeof(value32);
!       d += sizeof(double) / sizeof(value);
        break;
      case Abstract_tag:
      case Final_tag:
--- 404,416 ----
        }
      case Double_tag:
        *d++ = Make_header(Double_wosize, Double_tag, color);
!       /* Cannot do *((double *) d) = *((double *) p) directly
!          because p might not be 64-aligned. */
!       Assert(sizeof(double) == sizeof(value));
!       ((value32 *) d)[0] = p[0];
!       ((value32 *) d)[1] = p[1];
        p += sizeof(double) / sizeof(value32);
!       d += 1;
        break;
      case Abstract_tag:
      case Final_tag:
***************
*** 450,457 ****
--- 460,669 ----
    }
  }
  
+ #else /* !SIXTYFOUR */
+ 
+ #ifndef NO_SIXTYFOUR_INTERN
+ 
+ /* Routines to convert 64-bit externed objects to 32-bit memory blocks. */
+ 
+ typedef double value64;         /* Should work on just about any machine */
+ 
+ #ifdef BIG_ENDIAN
+ #define MSword(p) (((value*) p)[0])
+ #define LSword(p) (((value*) p)[1])
+ #else
+ #define MSword(p) (((value *) p)[1])
+ #define LSword(p) (((value *) p)[0])
  #endif
  
+ /* Reverse all words in a block, in case of endianness clash.
+    Works with 64-bit words.
+    Returns (-1) if a header too large is encountered, 0 otherwise. */
+ 
+ int rev_pointers_64(p, size)
+      value64 * p;
+      mlsize_t size;             /* size in 64-bit words */
+ {
+   value64 * q;
+   header_t hd;
+   mlsize_t n;
+ 
+   q = p + size;
+   while (p < q) {
+     Reverse_int64(p);
+     hd = (header_t) LSword(p);
+     if (MSword(p) != 0) return -1;
+     p++;
+     n = Wosize_hd(hd);
+     switch(Tag_hd(hd)) {
+     case Abstract_tag:
+     case Final_tag:
+       Assert (0);       /* Should not happen. Fall through for compatibility */
+     case String_tag:
+       p += n;
+       break;
+     case Double_tag:
+       Reverse_double(p);
+       p += n;
+       break;
+     default:
+       for( ; n > 0; n --, p++) {
+         Reverse_int64(p);
+       }
+     }
+   }
+   return 0;
+ }
+ 
+ /* Compute the size of the shrinkage of a 64-bit externed block to a
+    32-bit block. The size is returned in 32-bit words.
+    Return 0 if a block cannot be shrunk because its size is too big. */
+ 
+ static mlsize_t size_after_shrinkage(p, len)
+      value64 * p;
+      mlsize_t len;              /* length in 64-bit words */
+ {
+   mlsize_t res;
+   value64 * q;
+   header_t hd;
+   mlsize_t n;
+ 
+   for (q = p + len, res = 0; p < q; /*nothing*/) {
+     hd = (header_t) LSword(p);
+     if (MSword(p) != 0) return 0;
+     p++;
+     n = Wosize_hd(hd);
+     res++;
+     switch(Tag_hd(hd)) {
+     case String_tag:
+       { mlsize_t ofs_last_byte, len, new_sz;
+         ofs_last_byte = n * sizeof(value64) - 1;
+         len = ofs_last_byte - Byte(p, ofs_last_byte);
+         new_sz = (len + sizeof(value)) / sizeof(value);
+         res += new_sz;
+         break;
+       }
+     case Double_tag:
+       res += sizeof(double) / sizeof(value);
+       break;
+     case Abstract_tag:
+     case Final_tag:
+       Assert(0);                /* should not happen. */
+       break;
+     default:
+       res += n;                 /* all fields will be shrunk 64 -> 32 */
+       break;
+     }
+     p += n;
+   }
+   return res;
+ }
+ 
+ /* Convert a 64-bit externed block to a 32-bit block. The resulting block
+    is a valid 32-bit object.
+    Return -1 if the block cannot be shrunk because some integer literals
+    or relative displacements are too large, 0 otherwise. */
+ 
+ static int shrink_block(source, dest, source_len, dest_len, color)
+      value64 * source;
+      value * dest;
+      mlsize_t source_len, dest_len;
+      color_t color;
+ {
+   value64 * p, * q;
+   value * d, * e;
+   header_t hd;
+   mlsize_t sz;
+   tag_t tag;
+   offset_t * forward_addr;
+   offset_t dest_ofs;
+   value v;
+ 
+   /* First pass: copy the objects and set up forwarding pointers.
+      The pointers contained inside blocks are not resolved. */
+ 
+   for (p = source, q = source + source_len, d = dest; p < q; /*nothing*/) {
+     hd = (header_t) LSword(p);
+     p++;
+     sz = Wosize_hd(hd);
+     tag = Tag_hd(hd);
+     forward_addr = (offset_t *) p;
+     dest_ofs = d + 1 - dest;
+     switch(tag) {
+     case String_tag:
+       { mlsize_t ofs_last_byte, len, new_sz;
+         ofs_last_byte = sz * sizeof(value64) - 1;
+         len = ofs_last_byte - Byte(p, ofs_last_byte);
+         new_sz = (len + sizeof(value)) / sizeof(value);
+         *d++ = Make_header(new_sz, String_tag, color);
+         Field(d, new_sz - 1) = 0;
+         bcopy(p, d, len);
+         ofs_last_byte = new_sz * sizeof(value) - 1;
+         Byte(d, ofs_last_byte) = ofs_last_byte - len;
+         p += sz;
+         d += new_sz;
+         break;
+       }
+     case Double_tag:
+       *d++ = Make_header(Double_wosize, Double_tag, color);
+       Store_double_val(d, Double_val(p));
+       p += sizeof(double) / sizeof(value64);
+       d += sizeof(double) / sizeof(value);
+       break;
+     case Abstract_tag:
+     case Final_tag:
+       Assert(0);
+     default:
+       *d++ = Make_header(sz, tag, color);
+       for (/*nothing*/; sz > 0; sz--, p++, d++) {
+         value lsw = LSword(p);
+         value msw = MSword(p);
+         if ((lsw & 1) == 0) {      /* If relative displacement: */
+           if (msw != 0) return -1; /* Check unsigned displacement fits in 32 */
+         } else {                   /* Otherwise, it's a signed integer */
+           if ((lsw >= 0 && msw != 0) || (lsw < 0 && msw != -1)) return -1;
+         }
+         *d = lsw;
+       }
+     }
+     *forward_addr = dest_ofs;   /* store the forwarding pointer */
+   }
+   Assert(d == dest + dest_len);
+ 
+   /* Second pass: resolve pointers contained inside blocks,
+      replacing them by the corresponding forwarding pointer. */
+ 
+   for (d = dest, e = dest + dest_len; d < e; /*nothing*/) {
+     hd = (header_t) *d++;
+     sz = Wosize_hd(hd);
+     tag = Tag_hd(hd);
+     if (tag >= No_scan_tag) {
+       d += sz;
+     } else {
+       for (/*nothing*/; sz > 0; sz--, d++) {
+         v = *d;
+         switch(v & 3) {
+         case 0:                 /* 0: a block represented by its offset */
+           Assert(v >= 0 && v < source_len * sizeof(value64) && (v & 7) == 0);
+           *d = (value) (dest + *((offset_t *)((char *) source + v)));
+           break;
+         case 2:                 /* 2: an atom */
+           v = v >> 2;
+           Assert(v >= 0 && v < 256);
+           *d = Atom(v);
+           break;
+         default:                /* 1 or 3: an integer */
+           break;
+         }
+       }
+     }
+   }
+   return 0;
+ }
+ 
+ #endif /* NO_SIXTYFOUR_INTERN */
+ #endif /* SIXTYFOUR */
+ 
  static int really_getblock(chan, p, n)
       struct channel * chan;
       char * p;
***************
*** 493,498 ****
--- 705,711 ----
  #ifdef SIXTYFOUR
    if (magic == Little_endian_32_magic_number ||
        magic == Big_endian_32_magic_number) {
+     /* Expansion 32 -> 64 required */
      mlsize_t whsize32;
      value32 * block;
      whsize32 = whsize;
***************
*** 503,512 ****
      }
  #ifdef BIG_ENDIAN
      if (magic == Little_endian_32_magic_number)
!       rev_pointers_32(block, whsize);
  #else
      if (magic == Big_endian_32_magic_number)
!       rev_pointers_32(block, whsize);
  #endif
      whsize = size_after_expansion(block, whsize32);
      wosize = Wosize_whsize(whsize);
--- 716,725 ----
      }
  #ifdef BIG_ENDIAN
      if (magic == Little_endian_32_magic_number)
!       rev_pointers_32(block, whsize32);
  #else
      if (magic == Big_endian_32_magic_number)
!       rev_pointers_32(block, whsize32);
  #endif
      whsize = size_after_expansion(block, whsize32);
      wosize = Wosize_whsize(whsize);
***************
*** 516,541 ****
      Assert (color == White || color == Black);
      expand_block(block, Hp_val(res), whsize32, whsize, color);
      stat_free((char *) block);
    }
!   else
  #endif
!   {
      res = alloc_shr(wosize, String_tag);
      hd = Hd_val (res);
      color = Color_hd (hd);
      Assert (color == White || color == Black);
      if (really_getblock(chan, Hp_val(res), bhsize) == 0) {
        Hd_val (res) = hd;                      /* Avoid confusing the GC. */
        failwith ("intern : truncated object");
      }
  #ifdef BIG_ENDIAN
!     if (magic == Little_endian_magic_number)
        rev_pointers(Hp_val (res), whsize);
  #else
!     if (magic == Big_endian_magic_number)
        rev_pointers(Hp_val (res), whsize);
  #endif
      adjust_pointers(Hp_val (res), whsize, color);
    }
    return res;
  }
--- 729,814 ----
      Assert (color == White || color == Black);
      expand_block(block, Hp_val(res), whsize32, whsize, color);
      stat_free((char *) block);
+   } else {
+     /* Block has natural word size (64) */
+     res = alloc_shr(wosize, String_tag);
+     hd = Hd_val (res);
+     color = Color_hd (hd);
+     Assert (color == White || color == Black);
+     if (really_getblock(chan, Hp_val(res), bhsize) == 0) {
+       Hd_val (res) = hd;                      /* Avoid confusing the GC. */
+       failwith ("intern : truncated object");
+     }
+ #ifdef BIG_ENDIAN
+     if (magic == Little_endian_64_magic_number)
+       rev_pointers(Hp_val (res), whsize);
+ #else
+     if (magic == Big_endian_64_magic_number)
+       rev_pointers(Hp_val (res), whsize);
+ #endif
+     adjust_pointers(Hp_val (res), whsize, color);
    }
! #else /* !SIXTYFOUR */
!   if (magic == Little_endian_64_magic_number ||
!       magic == Big_endian_64_magic_number) {
!     /* Shrinkage 64 -> 32 required */
! #ifdef NO_SIXTYFOUR_INTERN
!     failwith("intern: 64-bit object, cannot load");
! #else
!     mlsize_t whsize64;
!     value64 * block;
!     whsize64 = whsize;
!     block = (value64 *) stat_alloc(whsize64 * sizeof(value64));
!     if (really_getblock(chan, block, whsize64 * sizeof(value64)) == 0) {
!       stat_free((char *) block);
!       failwith ("intern : truncated object");
!     }
! #ifdef BIG_ENDIAN
!     if (magic == Little_endian_64_magic_number) {
! #else
!     if (magic == Big_endian_64_magic_number) {
  #endif
!       if (rev_pointers_64(block, whsize64) == -1) {
!         stat_free((char *) block);
!         failwith("intern: 64-bit object too big");
!       }
!     }
!     whsize = size_after_shrinkage(block, whsize64);
!     if (whsize == -1) {
!       stat_free((char *) block);
!       failwith("intern: 64-bit object too big");
!     }
!     wosize = Wosize_whsize(whsize);
      res = alloc_shr(wosize, String_tag);
      hd = Hd_val (res);
      color = Color_hd (hd);
      Assert (color == White || color == Black);
+     if (shrink_block(block, Hp_val(res), whsize64, whsize, color) == -1) {
+       Hd_val (res) = hd;                      /* Avoid confusing the GC. */
+       stat_free((char *) block);
+       failwith("intern: 64-bit object too big");
+     }
+     stat_free((char *) block);
+ #endif /* !NO_SIXTYFOUR_INTERN */
+   } else {
+     /* Block has natural word size (32) */
+     res = alloc_shr(wosize, String_tag);
+     hd = Hd_val (res);
+     color = Color_hd (hd);
+     Assert (color == White || color == Black);
      if (really_getblock(chan, Hp_val(res), bhsize) == 0) {
        Hd_val (res) = hd;                      /* Avoid confusing the GC. */
        failwith ("intern : truncated object");
      }
  #ifdef BIG_ENDIAN
!     if (magic == Little_endian_32_magic_number)
        rev_pointers(Hp_val (res), whsize);
  #else
!     if (magic == Big_endian_32_magic_number)
        rev_pointers(Hp_val (res), whsize);
  #endif
      adjust_pointers(Hp_val (res), whsize, color);
    }
+ #endif /* !SIXTYFOUR */
    return res;
  }
diff -c -r /tmp/cl6/src/runtime/str.c ./src/runtime/str.c
*** /tmp/cl6/src/runtime/str.c	Tue Sep 21 20:13:17 1993
--- ./src/runtime/str.c	Tue May 10 13:49:25 1994
***************
*** 67,83 ****
  }
  
  #ifdef unix
! static unsigned char printable_chars_ascii[32] = /* 0x20-0x7E */
    "\000\000\000\000\377\377\377\377\377\377\377\377\377\377\377\177\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000";
! static unsigned char printable_chars_iso[32] = /* 0x20-0x7E 0xA1-0xFF */
    "\000\000\000\000\377\377\377\377\377\377\377\377\377\377\377\177\000\000\000\000\376\377\377\377\377\377\377\377\377\377\377\377";
  #endif
  #ifdef macintosh
! static unsigned char printable_chars[32] = /* 0x20-0x7E 0x80-0xC9 0xCB-0xD8 */
    "\000\000\000\000\377\377\377\377\377\377\377\377\377\377\377\177\377\377\377\377\377\377\377\377\377\373\377\001\000\000\000\000";
  #endif
  #ifdef MSDOS
! static unsigned char printable_chars[32] = /* 0x20-0xFE */
    "\000\000\000\000\377\377\377\377\377\377\377\377\377\377\377\377\377\377\377\377\377\377\377\377\377\377\377\377\377\377\377\177";
  #endif
  
--- 67,83 ----
  }
  
  #ifdef unix
! static unsigned char printable_chars_ascii[] = /* 0x20-0x7E */
    "\000\000\000\000\377\377\377\377\377\377\377\377\377\377\377\177\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000";
! static unsigned char printable_chars_iso[] = /* 0x20-0x7E 0xA1-0xFF */
    "\000\000\000\000\377\377\377\377\377\377\377\377\377\377\377\177\000\000\000\000\376\377\377\377\377\377\377\377\377\377\377\377";
  #endif
  #ifdef macintosh
! static unsigned char printable_chars[] = /* 0x20-0x7E 0x80-0xC9 0xCB-0xD8 */
    "\000\000\000\000\377\377\377\377\377\377\377\377\377\377\377\177\377\377\377\377\377\377\377\377\377\373\377\001\000\000\000\000";
  #endif
  #ifdef MSDOS
! static unsigned char printable_chars[] = /* 0x20-0xFE */
    "\000\000\000\000\377\377\377\377\377\377\377\377\377\377\377\377\377\377\377\377\377\377\377\377\377\377\377\377\377\377\377\177";
  #endif
  
***************
*** 87,93 ****
    int c;
  #ifdef unix
    static int iso_charset = -1;
!   char * printable_chars;
  
    if (iso_charset == -1) {
      char * lc_ctype = (char *) getenv("LC_CTYPE");
--- 87,93 ----
    int c;
  #ifdef unix
    static int iso_charset = -1;
!   unsigned char * printable_chars;
  
    if (iso_charset == -1) {
      char * lc_ctype = (char *) getenv("LC_CTYPE");
diff -c -r /tmp/cl6/src/tools/dumpobj.ml ./src/tools/dumpobj.ml
*** /tmp/cl6/src/tools/dumpobj.ml	Thu Jul 01 02:16:08 1993
--- ./src/tools/dumpobj.ml	Wed Mar 23 23:21:30 1994
***************
*** 48,58 ****
          if op == ACCESS or op == DUMMY or op == ENDLET
          or op == CONSTBYTE or op == ATOM or op == GETFIELD or op == SETFIELD
          or op == MAKEBLOCK1 or op == MAKEBLOCK2 or op == MAKEBLOCK3
!         or op == MAKEBLOCK4 or op == C_CALL1 or op == C_CALL2 or op == C_CALL3
!         or op == C_CALL4 or op == C_CALL5 then
            print_int(input_byte ic)
!         else if op == GETGLOBAL or op == SETGLOBAL or op == PUSH_GETGLOBAL_APPLY
!         or op == PUSH_GETGLOBAL_APPTERM then
            print_int(input_u16 ic)
          else if op == CONSTSHORT then
            print_int(input_s16 ic)
--- 48,59 ----
          if op == ACCESS or op == DUMMY or op == ENDLET
          or op == CONSTBYTE or op == ATOM or op == GETFIELD or op == SETFIELD
          or op == MAKEBLOCK1 or op == MAKEBLOCK2 or op == MAKEBLOCK3
!         or op == MAKEBLOCK4 then
            print_int(input_byte ic)
!         else if op == GETGLOBAL or op == SETGLOBAL
!         or op == PUSH_GETGLOBAL_APPLY or op == PUSH_GETGLOBAL_APPTERM
!         or op == C_CALL1 or op == C_CALL2 or op == C_CALL3
!         or op == C_CALL4 or op == C_CALL5 then
            print_int(input_u16 ic)
          else if op == CONSTSHORT then
            print_int(input_s16 ic)
***************
*** 74,79 ****
--- 75,84 ----
               done)
          else if op == BRANCHINTERVAL then
            (print_depl ic; print_string ", "; print_depl ic)
+         else if op == C_CALLN then
+           (print_int(input_byte ic);
+            print_string ", ";
+            print_int(input_u16 ic))
          else
            ();
          print_newline()
diff -c /tmp/cl6/KNOWN-BUGS ./KNOWN-BUGS 
*** /tmp/cl6/KNOWN-BUGS Wed Sep 29 20:16:03 1993
--- ./KNOWN-BUGS        Wed May 11 15:57:52 1994
***************
*** 1,23 ****
  The following problems have not been fixed at the time of this release:
  
- 1- Patterns of the format (C x) where C has several arguments:
- 
-    In the following code:
- 
-         type t = A | B of int * int;;
-         match B(1,2) with B x - > x;;
- 
-    the pair bound to x is not equal to (1,2): its first component is 1,
-    its second component is 2, but it is not correctly tagged, hence
-    x = (1,2) returns false, and x and (1,2) have different hash values.
-    The difference between x and (1,2) is observable only with ad-hoc
-    polymorphic primitives such as equality (=) and hashing.
- 
-    To avoid this problem, match against a more precise pattern and rebuild
-    the tuple of arguments in the right-hand side:
- 
-         match B(1,2) with B(y,z) -> (y,z);;
- 
  2- Stream concatenation using [< ... >] does not always preserve the
     sharing among streams, and sometimes duplicate stream subcomponents.
     For instance, if you define s' = [< '1; s >] and then read alternatively
--- 1,5 ----
diff -c /tmp/cl6/src/compiler/version.ml ./src/compiler/version.ml
*** /tmp/cl6/src/compiler/version.ml    Mon Sep 13 19:30:23 1993
--- ./src/compiler/version.ml   Wed May 11 15:59:20 1994
***************
*** 1 ****
! let banner = "The Caml Light compiler, version 0.6";;
--- 1 ----
! let banner = "The Caml Light compiler, version 0.61";;
diff -c /tmp/cl6/src/launch/camlc.tpl ./src/launch/camlc.tpl
*** /tmp/cl6/src/launch/camlc.tpl       Fri Oct 08 18:56:22 1993
--- ./src/launch/camlc.tpl      Wed May 11 15:59:20 1994
***************
*** 45,51 ****
        stdlib=$2
        shift;;
      -v|-version)
!       echo "The Caml Light system, version 0.6"
        echo "  (standard library from $stdlib)"
        camlrun -V
        camlrun $stdlib/camlcomp -version
--- 45,51 ----
        stdlib=$2
        shift;;
      -v|-version)
!       echo "The Caml Light system, version 0.61"
        echo "  (standard library from $stdlib)"
        camlrun -V
        camlrun $stdlib/camlcomp -version
diff -c /tmp/cl6/src/librar/version.ml ./src/librar/version.ml
*** /tmp/cl6/src/librar/version.ml      Mon Sep 13 19:30:23 1993
--- ./src/librar/version.ml     Wed May 11 15:59:20 1994
***************
*** 1 ****
! let banner = "The Caml Light librarian, version 0.6";;
--- 1 ----
! let banner = "The Caml Light librarian, version 0.61";;
diff -c /tmp/cl6/src/linker/version.ml ./src/linker/version.ml
*** /tmp/cl6/src/linker/version.ml      Mon Sep 13 19:30:22 1993
--- ./src/linker/version.ml     Wed May 11 15:59:20 1994
***************
*** 1 ****
! let banner = "The Caml Light linker, version 0.6";;
--- 1 ----
! let banner = "The Caml Light linker, version 0.61";;
diff -c /tmp/cl6/src/runtime/version.c ./src/runtime/version.c
*** /tmp/cl6/src/runtime/version.c      Mon Sep 13 19:30:20 1993
--- ./src/runtime/version.c     Wed May 11 15:59:20 1994
***************
*** 1,2 ****
  char version_string[] =
!   "The Caml Light runtime system, version 0.6\n";
--- 1,2 ----
  char version_string[] =
!   "The Caml Light runtime system, version 0.61\n";
diff -c /tmp/cl6/src/toplevel/version.ml ./src/toplevel/version.ml
*** /tmp/cl6/src/toplevel/version.ml    Mon Sep 13 19:30:21 1993
--- ./src/toplevel/version.ml   Wed May 11 15:59:21 1994
***************
*** 1 ****
! let banner = ">       Caml Light version 0.6";;
--- 1 ----
! let banner = ">       Caml Light version 0.61";;
diff -c /tmp/cl6/README ./README
*** /tmp/cl6/README    Sat Sep 25 01:57:22 1993
--- ./README      Wed May 11 16:23:58 1994
***************
*** 1,4 ****
!   This is the release 0.6 of the Caml Light system, for Unix machines.
  
  OVERVIEW:
  
--- 1,4 ----
!   This is the release 0.61 of the Caml Light system, for Unix machines.
  
  OVERVIEW: