Commits

camlspotter committed 90d681b

dcaml update to 3.12.0

Comments (0)

Files changed (102)

 typing/ctype.cmi: typing/types.cmi typing/path.cmi typing/ident.cmi \
     typing/env.cmi parsing/asttypes.cmi
 typing/datarepr.cmi: typing/types.cmi typing/path.cmi parsing/asttypes.cmi
+typing/dispatch.cmi: typing/types.cmi typing/typedtree.cmi \
+    parsing/parsetree.cmi parsing/location.cmi typing/ident.cmi \
+    typing/env.cmi parsing/asttypes.cmi
 typing/env.cmi: typing/types.cmi typing/path.cmi parsing/longident.cmi \
     typing/ident.cmi utils/consistbl.cmi typing/annot.cmi
 typing/ident.cmi:
     parsing/asttypes.cmi typing/datarepr.cmi
 typing/datarepr.cmx: typing/types.cmx typing/predef.cmx utils/misc.cmx \
     parsing/asttypes.cmi typing/datarepr.cmi
+typing/dispatch.cmo: typing/types.cmi typing/typedtree.cmi \
+    typing/printtyp.cmi typing/path.cmi parsing/parsetree.cmi \
+    typing/mtype.cmi utils/misc.cmi parsing/longident.cmi \
+    parsing/location.cmi typing/ident.cmi typing/env.cmi typing/ctype.cmi \
+    typing/btype.cmi parsing/asttypes.cmi typing/dispatch.cmi
+typing/dispatch.cmx: typing/types.cmx typing/typedtree.cmx \
+    typing/printtyp.cmx typing/path.cmx parsing/parsetree.cmi \
+    typing/mtype.cmx utils/misc.cmx parsing/longident.cmx \
+    parsing/location.cmx typing/ident.cmx typing/env.cmx typing/ctype.cmx \
+    typing/btype.cmx parsing/asttypes.cmi typing/dispatch.cmi
 typing/env.cmo: typing/types.cmi utils/tbl.cmi typing/subst.cmi \
     typing/predef.cmi typing/path.cmi utils/misc.cmi parsing/longident.cmi \
     typing/ident.cmi typing/datarepr.cmi utils/consistbl.cmi utils/config.cmi \
     typing/printtyp.cmi typing/primitive.cmi typing/predef.cmi \
     typing/path.cmi parsing/parsetree.cmi typing/parmatch.cmi \
     typing/oprint.cmi utils/misc.cmi parsing/longident.cmi \
-    parsing/location.cmi typing/ident.cmi typing/env.cmi typing/ctype.cmi \
-    utils/clflags.cmi typing/btype.cmi parsing/asttypes.cmi typing/annot.cmi \
-    typing/typecore.cmi
+    parsing/location.cmi typing/ident.cmi typing/env.cmi typing/dispatch.cmi \
+    typing/ctype.cmi utils/clflags.cmi typing/btype.cmi parsing/asttypes.cmi \
+    typing/annot.cmi typing/typecore.cmi
 typing/typecore.cmx: utils/warnings.cmx typing/typetexp.cmx typing/types.cmx \
     typing/typedtree.cmx typing/subst.cmx typing/stypes.cmx \
     typing/printtyp.cmx typing/primitive.cmx typing/predef.cmx \
     typing/path.cmx parsing/parsetree.cmi typing/parmatch.cmx \
     typing/oprint.cmx utils/misc.cmx parsing/longident.cmx \
-    parsing/location.cmx typing/ident.cmx typing/env.cmx typing/ctype.cmx \
-    utils/clflags.cmx typing/btype.cmx parsing/asttypes.cmi typing/annot.cmi \
-    typing/typecore.cmi
+    parsing/location.cmx typing/ident.cmx typing/env.cmx typing/dispatch.cmx \
+    typing/ctype.cmx utils/clflags.cmx typing/btype.cmx parsing/asttypes.cmi \
+    typing/annot.cmi typing/typecore.cmi
 typing/typedecl.cmo: utils/warnings.cmi typing/typetexp.cmi typing/types.cmi \
     typing/typedtree.cmi typing/subst.cmi typing/printtyp.cmi \
     typing/primitive.cmi typing/predef.cmi typing/path.cmi \
 asmcomp/selection.cmi: asmcomp/mach.cmi asmcomp/cmm.cmi
 asmcomp/spill.cmi: asmcomp/mach.cmi
 asmcomp/split.cmi: asmcomp/mach.cmi
-asmcomp/arch.cmo:
-asmcomp/arch.cmx:
+asmcomp/arch.cmo: utils/misc.cmi utils/config.cmi
+asmcomp/arch.cmx: utils/misc.cmx utils/config.cmx
 asmcomp/asmgen.cmo: bytecomp/translmod.cmi asmcomp/split.cmi \
     asmcomp/spill.cmi asmcomp/selection.cmi asmcomp/scheduling.cmi \
     asmcomp/reload.cmi asmcomp/reg.cmi asmcomp/proc.cmi asmcomp/printmach.cmi \
 asmcomp/debuginfo.cmx: parsing/location.cmx bytecomp/lambda.cmx \
     asmcomp/debuginfo.cmi
 asmcomp/emit.cmo: asmcomp/reg.cmi asmcomp/proc.cmi utils/misc.cmi \
-    asmcomp/mach.cmi asmcomp/linearize.cmi asmcomp/emitaux.cmi \
-    asmcomp/debuginfo.cmi utils/config.cmi asmcomp/compilenv.cmi \
-    asmcomp/cmm.cmi utils/clflags.cmi asmcomp/arch.cmo asmcomp/emit.cmi
+    asmcomp/mach.cmi parsing/location.cmi asmcomp/linearize.cmi \
+    asmcomp/emitaux.cmi asmcomp/debuginfo.cmi utils/config.cmi \
+    asmcomp/compilenv.cmi asmcomp/cmm.cmi utils/clflags.cmi asmcomp/arch.cmo \
+    asmcomp/emit.cmi
 asmcomp/emit.cmx: asmcomp/reg.cmx asmcomp/proc.cmx utils/misc.cmx \
-    asmcomp/mach.cmx asmcomp/linearize.cmx asmcomp/emitaux.cmx \
-    asmcomp/debuginfo.cmx utils/config.cmx asmcomp/compilenv.cmx \
-    asmcomp/cmm.cmx utils/clflags.cmx asmcomp/arch.cmx asmcomp/emit.cmi
+    asmcomp/mach.cmx parsing/location.cmx asmcomp/linearize.cmx \
+    asmcomp/emitaux.cmx asmcomp/debuginfo.cmx utils/config.cmx \
+    asmcomp/compilenv.cmx asmcomp/cmm.cmx utils/clflags.cmx asmcomp/arch.cmx \
+    asmcomp/emit.cmi
 asmcomp/emitaux.cmo: asmcomp/reg.cmi asmcomp/linearize.cmi \
     asmcomp/debuginfo.cmi asmcomp/cmm.cmi asmcomp/arch.cmo \
     asmcomp/emitaux.cmi
     asmcomp/mach.cmx asmcomp/debuginfo.cmx asmcomp/cmm.cmx asmcomp/arch.cmx \
     asmcomp/printmach.cmi
 asmcomp/proc.cmo: asmcomp/reg.cmi utils/misc.cmi asmcomp/mach.cmi \
-    utils/config.cmi asmcomp/cmm.cmi utils/ccomp.cmi asmcomp/arch.cmo \
-    asmcomp/proc.cmi
+    utils/config.cmi asmcomp/cmm.cmi utils/clflags.cmi utils/ccomp.cmi \
+    asmcomp/arch.cmo asmcomp/proc.cmi
 asmcomp/proc.cmx: asmcomp/reg.cmx utils/misc.cmx asmcomp/mach.cmx \
-    utils/config.cmx asmcomp/cmm.cmx utils/ccomp.cmx asmcomp/arch.cmx \
-    asmcomp/proc.cmi
+    utils/config.cmx asmcomp/cmm.cmx utils/clflags.cmx utils/ccomp.cmx \
+    asmcomp/arch.cmx asmcomp/proc.cmi
 asmcomp/reg.cmo: asmcomp/cmm.cmi asmcomp/reg.cmi
 asmcomp/reg.cmx: asmcomp/cmm.cmx asmcomp/reg.cmi
 asmcomp/reload.cmo: asmcomp/reloadgen.cmi asmcomp/reg.cmi asmcomp/mach.cmi \
-    asmcomp/cmm.cmi utils/clflags.cmi asmcomp/arch.cmo asmcomp/reload.cmi
+    asmcomp/cmm.cmi asmcomp/arch.cmo asmcomp/reload.cmi
 asmcomp/reload.cmx: asmcomp/reloadgen.cmx asmcomp/reg.cmx asmcomp/mach.cmx \
-    asmcomp/cmm.cmx utils/clflags.cmx asmcomp/arch.cmx asmcomp/reload.cmi
+    asmcomp/cmm.cmx asmcomp/arch.cmx asmcomp/reload.cmi
 asmcomp/reloadgen.cmo: asmcomp/reg.cmi utils/misc.cmi asmcomp/mach.cmi \
     asmcomp/reloadgen.cmi
 asmcomp/reloadgen.cmx: asmcomp/reg.cmx utils/misc.cmx asmcomp/mach.cmx \
     asmcomp/cmm.cmx asmcomp/arch.cmx asmcomp/selectgen.cmi
 asmcomp/selection.cmo: asmcomp/selectgen.cmi asmcomp/reg.cmi asmcomp/proc.cmi \
     utils/misc.cmi asmcomp/mach.cmi asmcomp/debuginfo.cmi asmcomp/cmm.cmi \
-    utils/clflags.cmi asmcomp/arch.cmo asmcomp/selection.cmi
+    asmcomp/arch.cmo asmcomp/selection.cmi
 asmcomp/selection.cmx: asmcomp/selectgen.cmx asmcomp/reg.cmx asmcomp/proc.cmx \
     utils/misc.cmx asmcomp/mach.cmx asmcomp/debuginfo.cmx asmcomp/cmm.cmx \
-    utils/clflags.cmx asmcomp/arch.cmx asmcomp/selection.cmi
+    asmcomp/arch.cmx asmcomp/selection.cmi
 asmcomp/spill.cmo: asmcomp/reg.cmi asmcomp/proc.cmi utils/misc.cmi \
     asmcomp/mach.cmi asmcomp/spill.cmi
 asmcomp/spill.cmx: asmcomp/reg.cmx asmcomp/proc.cmx utils/misc.cmx \

0scripts/0BUILD.sh

+#!/bin/sh
+
+set -e
+./configure --prefix $PREFIX
+make clean core coreboot
+./build/mixed-boot.sh
+cp boot/myocamlbuild boot/myocamlbuild.boot
+make world opt opt.opt

0scripts/0MAKERELEASE

+#!/usr/bin/perl
+
+$VERSION="0.2.0";
+$PURE_OCAML="ocaml3112";
+
+`/bin/cp ocamlspot/INSTALL-ocamlspot.txt ocamlspot/BRAIN_DEAD_INSTALL.sh .`;
+
+`hg diff -r $PURE_OCAML -r gcaml -X "0*" -X ".hg[a-z]*" -X "ocamlspot" -X "dcaml" -X "dcamlc" -X "dcamlexamples" -X "dcamlmisc" -X "dcamltests" -X "boot" -X "INSTALL-dcaml.txt" > compiler_patch.diff`;
+
+`cd ocamlspot; make clean`;
+@files = ("INSTALL-ocamlspot.txt", "BRAIN_DEAD_INSTALL.sh", "compiler_patch.diff", "ocamlspot", "dcaml", "dcamlc", "dcamlexamples", "INSTALL-dcaml.txt");
+
+
+$tgz = sprintf "dcaml-%s-tmp.tgz", $VERSION;
+
+$com = sprintf "tar zcvf $tgz --exclude=\"*~\" %s", join(' ', @files);
+
+print STDERR "$com\n";
+`$com`;
+
+mkdir (sprintf "dcaml-%s", $VERSION);
+
+$com = sprintf "(cd dcaml-%s; tar zxvf ../$tgz)", $VERSION;
+`$com`;
+
+unlink "$tgz";
+
+
+
+
+

INSTALL-dcaml.txt

+How to build
+============
+
+    $ ./BRAIN_DEAD_INSTALL.sh
+
+  If you are not a living dead, read the script.
+
+How to play
+===========
+
+  Just for playing, you do not need to install the system: after the build, 
+  two scripts ./dcaml (toplevel) and ./dcamlc (compiler) are available. 
+
+  Some examples are available in dcamlexamples/ directory.
+
+Documentation
+=============
+
+  The new features of $'Caml are explained at:
+
+    http://jun.furuse.info/hacks/discaml
+
+
   typing/printtyp.cmo typing/includeclass.cmo \
   typing/mtype.cmo typing/includecore.cmo \
   typing/includemod.cmo typing/parmatch.cmo \
-  typing/typetexp.cmo typing/stypes.cmo typing/typecore.cmo \
+  typing/typetexp.cmo typing/stypes.cmo typing/dispatch.cmo typing/typecore.cmo \
   typing/typedecl.cmo typing/typeclass.cmo \
   typing/typemod.cmo
 
-3.12.0
+3.12.0+dispatch
 
 # The version string is the first line of this file.
 # It must be in the format described in stdlib/sys.mli

asmcomp/.cvsignore

 selection.ml
 reload.ml
 scheduling.ml
+*.annot
+*.spot

bytecomp/.cvsignore

 runtimedef.ml
 opcodes.ml
+*.annot
+*.spot

bytecomp/translcore.ml

           cl_loc = e.exp_loc;
           cl_type = Tcty_signature cty;
           cl_env = e.exp_env }
+  | Texp_dispatch({ contents = Some exp }) -> transl_exp exp
+  | Texp_dispatch _ -> assert false (* CR jfuruse: or an error *)
+  | Texp_rec_id (_, { contents = Some exp }) -> transl_exp exp
+  | Texp_rec_id (id, _) ->
+      Format.eprintf "rec not resolved: %s %a@." 
+	(Ident.name id)
+	Location.print_error e.exp_loc;
+      assert false
 
 and transl_list expr_list =
   List.map transl_exp expr_list
+#!/bin/sh
+byterun/ocamlrun ./ocaml -I stdlib $*
+#!/bin/sh
+byterun/ocamlrun ./ocamlc -I stdlib $*

dcamlexamples/auto-test.pl

+#!/usr/bin/perl
+
+use strict;
+
+sub test {
+  my $file = $_[0];
+  if( $file =~ /dummy/ ){ return; }
+  my $result = `../byterun/ocamlrun ../ocaml -I ../stdlib/ $file 2>&1`;
+  chop $result;
+  $result =~ s/\n/ /g;
+  $result =~ s/File "[^"]+", //g;
+  # $result =~ s/Error: .*/Error!/g;
+  $result =~ s/\s+/ /g;
+  if( $? == 11 ){ $result = "Seg fault!!!"; }
+  elsif( $? == 512 ){ $result = "ERROR: $result"; }
+  elsif( $? != 0 ){ $result = "$?!!!"; }
+  else { $result = "OK"; }
+  if( $file =~ /error/ ){
+      if ($result =~ /^ERROR/ ){
+          $result = "OK (error as intended)";
+      } elsif ( $result =~ /^OK/ ) {
+          $result = "ERROR: passed!";
+      }
+  }
+  print "$file:\t$result\n";
+  while (<IN>) { print $_; }
+}
+
+`cd ..; make ocaml`;
+for my $f (@ARGV) {
+    test($f);
+}

dcamlexamples/ex001_plus.ml

+module Plus : sig
+
+  type 'a t (* type for dispatch. It must be abstract *)
+
+  val (+) : $:'a t -> 'a -> 'a -> 'a
+
+  val int : int t
+  val float : float t
+
+end = struct
+    
+  type 'a t = 'a -> 'a -> 'a
+
+  let (+) $:t = t
+
+  let int = Pervasives.(+)
+  let float = Pervasives.(+.)
+
+end
+
+open Plus
+
+let () = 
+  assert (1 + 2 = 3);
+  assert (1.0 + 2.0 = 3.0)
+;;

dcamlexamples/ex002_plus_sep.ml

+module Plus = struct
+
+  type 'a t = 'a -> 'a -> 'a
+
+  let (+) $:t = t
+
+end
+
+module Int = struct
+
+  let (+) = Pervasives.(+)
+
+end
+
+module Float = struct
+
+  let (+) = Pervasives.(+.)
+
+end
+
+(* To overload things, we need compose the class and instances *)
+
+module Overloaded : sig
+    
+  type 'a t (* must be abstract! *)
+      
+  val (+) : $:'a t -> 'a -> 'a -> 'a
+
+  val int : int t
+  val float : float t
+
+end = struct
+
+  include Plus
+  let int = Int.(+)
+  let float = Float.(+)
+    
+end
+
+open Overloaded
+
+let () = 
+  assert (1 + 2 = 3);
+  assert (1.0 + 2.0 = 3.0)
+;;
+ 
+      
+      

dcamlexamples/ex003_plus_submodules.ml

+module Plus = struct
+
+  type 'a t = 'a -> 'a -> 'a
+
+  let (+) $:t = t
+
+end
+
+module Int = struct
+
+  let (+) = Pervasives.(+)
+
+end
+
+module Float = struct
+
+  let (+) = Pervasives.(+.)
+
+end
+
+(* To overload things, we need compose the class and instances *)
+
+module Overloaded : sig
+    
+  type 'a t (* must be abstract! *)
+      
+  val (+) : $:'a t -> 'a -> 'a -> 'a
+
+  module Int : sig val (+) : int t end
+  module Float : sig val (+) : float t end
+
+end = struct
+
+  include Plus
+
+  (* $'Caml-0.2.0 : sub modules are recursively searched 
+     for instances *) 
+  module Int = Int
+  module Float = Float
+    
+end
+
+open Overloaded
+
+let () = 
+  assert (1 + 2 = 3);
+  assert (1.0 + 2.0 = 3.0)
+;;
+ 
+      
+      

dcamlexamples/ex010_num.ml

+module Num = struct
+
+  type 'a t = {
+    plus : 'a -> 'a -> 'a;
+    minus : 'a -> 'a -> 'a;
+  }
+
+  let (+) $:t = t.plus
+  let (-) $:t = t.minus
+
+end
+
+module Int = struct
+
+  let t : int Num.t = {
+    Num.plus = (+);
+    minus = (-);
+  }
+
+end
+
+module Float = struct
+
+  let t : float Num.t = {
+    Num.plus = (+.);
+    minus = (-.);
+  }
+
+end
+
+(* To overload things, we need compose the class and instances *)
+
+module Overloaded : sig
+    
+  type 'a t (* must be abstract! *)
+      
+  val (+) : $:'a t -> 'a -> 'a -> 'a
+  val (-) : $:'a t -> 'a -> 'a -> 'a
+
+  val int : int t
+  val float : float t
+
+end = struct
+
+  include Num
+  let int = Int.t
+  let float = Float.t
+    
+end
+
+open Overloaded
+
+let () = 
+  assert (1 + 2 - 0 = 3);
+  assert (1.0 + 2.0 - 0.0 = 3.0)
+;;

dcamlexamples/ex020_sum.ml

+module Sum = struct
+
+  type 'a t = 'a -> int
+
+  let sum $:t = t
+
+end
+
+module Int = struct
+
+  let sum : int Sum.t = fun x -> x
+
+end
+
+module List = struct
+
+  let rec sum = function
+    | [] -> 0
+    | x::xs -> Sum.sum x + sum xs
+
+  (* For [x], we cannot use [sum] but [Sum.sum] 
+     to avoid polymorphic recursion.
+
+     On the other hand, for [xs], we cannot call [Sum.sum] but [sum], 
+     to avoid infinite loops of dispatch construciton. 
+  *)
+
+end
+
+module Overloaded : sig
+
+  type 'a t 
+
+  val sum : $:'a t -> 'a -> int
+
+  val int : int t
+  val list : $:'a t -> 'a list t
+
+end = struct
+
+  include Sum
+  let int = Int.sum
+  let list = List.sum
+
+end
+
+let () =
+  assert (Overloaded.sum [[]; [1]; [2;3]; [4;5;6]] = 21)
+;;

dcamlexamples/ex021_sum_error.ml

+module Sum = struct
+
+  type 'a t = 'a -> int
+
+  let sum $:t = t
+
+end
+
+module Int = struct
+
+  let sum : int Sum.t = fun x -> x
+
+end
+
+module List = struct
+
+  let sum = function
+    | [] -> 0
+    | x::xs -> Sum.sum x + Sum.sum xs
+	(* This causes infinite loops at dispatch creation.
+	   $'Caml is not yet clever enough to the second call
+	   of [sum] by [sum]
+	*)
+end
+
+module Overloaded : sig
+
+  type 'a t 
+
+  val sum : $:'a t -> 'a -> int
+
+  val int : int t
+  val list : $:'a t -> 'a list t
+
+end = struct
+
+  include Sum
+  let int = Int.sum
+  let float = Sum.sum
+
+end
+
+let () =
+  assert ([[]; [1]; [2;3]; [4;5;6]] = 21)
+;;

dcamlexamples/ex022_sum_overload.ml

+(* $'Caml 0.2.0 introduces yet another way of overloading *)
+
+module Sum : sig 
+  type 'a t (* It must be abstract *)
+  val sum : $:'a t -> 'a -> int
+  val lift : ('a -> int) -> 'a t
+    (* We need a way to `lift' instance definitions to abstracted values *)
+end = struct
+  type 'a t = 'a -> int
+  let sum $:t = t
+  let lift x = x
+end
+
+module Int = struct
+  let int = Sum.lift (fun x -> x)
+end
+
+module List = struct
+  let rec sum = function
+    | [] -> 0
+    | x::xs -> Sum.sum x + sum xs
+
+  let list = Sum.lift sum
+end
+
+(* Create a module Overload, and just list instances you want to use.
+   The name "Overload" is special to provide a search space 
+   for the overload instance resolution.
+*)
+module Overload = struct
+  include Int
+  include List
+end
+
+let () =
+  assert (Sum.sum 1 = 1);
+  assert (Sum.sum [[]; [1]; [2;3]; [4;5;6]] = 21)
+;;

dcamlexamples/ex030_monad.ml

+(* It is hard to have constructor classes in O'Caml, since there is no way to
+   abstract type names *)
+module Monad = struct
+  (* 'am means 'a 'm, and 'bm means 'b 'm, but they are not valid ocaml types *) 
+  (* Three parameter class! Ugly! *)
+  type ('a, 'am, 'bm) t = {
+    return : 'a -> 'am;
+    bind : 'am -> ('a -> 'bm) -> 'bm
+  }
+  let return $:t = t.return
+  let bind $:t = t.bind
+  ;;
+
+  module Make(M : sig 
+    type 'a t
+    val return : 'a -> 'a t
+    val bind : 'a t -> ('a -> 'b t) -> 'b t
+  end) = struct
+    let t = { return = M.return; bind = M.bind }
+  end
+end
+
+module Option = struct
+
+  type 'a t = 'a option
+
+  let return x = Some x;;
+
+  let bind v f = match v with
+    | None -> None
+    | Some v -> f v
+
+end
+
+module List = struct
+
+  type 'a t = 'a list
+
+  let return x = [x]
+
+  let bind v f = List.flatten (List.map f v)
+
+end
+
+module IO : sig
+
+  type 'a t
+
+  val return : 'a -> 'a t
+    
+  val bind : 'a t -> ('a -> 'b t) -> 'b t
+
+  val run : unit t -> unit
+
+  val putStr : string -> unit t
+
+end = struct
+
+  type 'a t = unit -> 'a
+
+  let return x = fun () -> x
+
+  let bind t f = f (t ())
+
+  let run t = t ()
+
+  let putStr s = fun () -> prerr_endline s
+end
+
+module Overloaded : sig
+  type ('a, 'am, 'bm) t
+  val return : $:('a, 'am, 'bm) t -> 'a -> 'am
+  val bind : $:('a, 'am, 'bm) t -> 'am -> ('a -> 'bm) -> 'bm
+  val option : ('a, 'a option, 'b option) t
+  val list : ('a, 'a list, 'b list) t
+  val io : ('a, 'a IO.t, 'b IO.t) t
+end = struct
+  include Monad
+  module Option = Monad.Make(Option)
+  let option = Option.t
+  module List = Monad.Make(List)
+  let list = List.t
+  module IO = Monad.Make(IO)
+  let io = IO.t
+end
+
+open Overloaded
+
+(* It does not work... need more types.
+
+let () = 
+  assert (bind (return 1) (fun x -> Some (float x)) = Some 1.0);
+  assert (bind (return 1) (fun x -> [float x; float (x+1)]) = [1.0; 2.0]);
+  assert (IO.run (bind (return ()) (fun x -> IO.putStr "hello")) = ())
+*)
+;;
+
+(* It runs if we explicitly deliver dictionaries, for now. 
+
+   We can remove some of them by making the resolution cleverer.
+*)
+
+let () = 
+  assert (bind $:option (return $:option 1) (fun x -> Some (float x)) = Some 1.0);
+  assert (bind $:list (return $:list 1) (fun x -> [float x; float (x+1)]) = [1.0; 2.0]);
+  assert (IO.run (bind $:io (return $:io ()) (fun x -> IO.putStr "hello")) = ())
+;;
+
+let _ = (return 1 : int option)  (* $ abstracted. Well it is understandable *)
+let x : int option = return 1 (* $ abstracted... Hmmm, it is confusing *)

dcamlexamples/ex040_show.ml

+module Show_class = struct
+  type 'a t = 'a -> string
+
+  (* We can use %identity *)    
+  (* let show $:t = t *)
+  external show : $:'a t -> 'a t = "%identity"
+end
+
+module Int = struct
+  let t = string_of_int
+end
+
+module Float = struct
+  let t = string_of_float
+end
+
+module Char = struct
+  let t = String.make 1 
+end
+
+module String = struct
+  let t x = x
+end
+
+module Bool = struct
+  let t = string_of_bool
+end
+
+module Tuple2 = struct
+  let t (x,y) = 
+    "("
+    ^ Show_class.show x
+    ^ ","
+    ^ Show_class.show y
+    ^ ")"
+end
+
+module List = struct
+  let t l = 
+    let rec t = function
+      | [] -> ""
+      | [x] -> Show_class.show x
+      | x::xs -> 
+          Show_class.show x 
+          ^ ";"
+          ^ t xs
+    in
+    "[" ^ t l ^ "]"
+end
+
+module Show : sig
+  type 'a t
+  val show : $:'a t -> 'a -> string
+
+  val int : int t
+  val float : float t
+  val char : char t
+  val string : string t
+  val bool : bool t
+  val tuple2 : $:'a t -> $:'b t -> ('a * 'b) t
+  val list : $:'a t -> 'a list t
+end = struct
+  include Show_class
+  let int = Int.t
+  let float = Float.t
+  let string = String.t
+  let char = Char.t
+  let bool = Bool.t
+  let tuple2 = Tuple2.t
+  let list = List.t
+end
+
+open Show
+
+let () =
+  assert (
+    show [("hello", "world");
+          ("bye", "universe")]
+      = "[(hello,world);(bye,universe)]"
+  )
+

dcamlexamples/ex050_ord.ml

+module Ord : sig
+  type 'a t
+  val compare : $:'a t -> 'a -> 'a -> int
+  val int : int t
+  val float : float t
+  val max : $:'a t -> 'a -> 'a -> 'a
+  val min : $:'a t -> 'a -> 'a -> 'a
+end = struct
+  type 'a t = 'a -> 'a -> int
+  let compare $:t = t
+
+  let max x y = if compare x y >= 0 then x else y
+  let min x y = if compare x y <= 0 then x else y
+
+  let int (x : int) y = Pervasives.compare x y
+  let float (x : float) y = Pervasives.compare x y
+end
+
+open Ord
+let () = assert (max 1 2 = 2); assert (min 1.0 2.3 = 1.0)

dcamlexamples/ex060_coll.ml

+module Ord : sig
+  type 'a t
+  val compare : $:'a t -> 'a -> 'a -> int
+  val int : int t
+  val float : float t
+  val max : $:'a t -> 'a -> 'a -> 'a
+  val min : $:'a t -> 'a -> 'a -> 'a
+end = struct
+  type 'a t = 'a -> 'a -> int
+  let compare $:t = t
+
+  let max x y = if compare x y >= 0 then x else y
+  let min x y = if compare x y <= 0 then x else y
+
+  let int (x : int) y = Pervasives.compare x y
+  let float (x : float) y = Pervasives.compare x y
+end
+
+module Class = struct
+  type ('a, 'ac) t = {
+    empty : 'ac;
+    insert : 'a -> 'ac -> 'ac;
+    mem : 'a -> 'ac -> bool
+  }
+
+  let empty $:t = t.empty
+  let insert $:t = t.insert
+  let mem $:t = t.mem
+
+  module Make(M : sig
+    type 'a c
+    val empty : 'a c
+    val insert : 'a -> 'a c -> 'a c
+    val mem : 'a -> 'a c -> bool
+  end) : sig
+    val t : ('a, 'a M.c) t
+  end = struct
+    open M
+    let t = { empty = empty; insert = insert; mem = mem }
+  end
+
+  module Make_with_ord(M : sig
+    type 'a c
+    val empty : 'a c
+    val insert : $:'a Ord.t -> 'a -> 'a c -> 'a c
+    val mem : $:'a Ord.t -> 'a -> 'a c -> bool
+  end) : sig
+    val t : $:'a Ord.t -> ('a, 'a M.c) t
+  end = struct
+    open M
+    (* CR jfuruse: pity, but we need explicit abstractions for now *)
+    let t $:t = { empty = empty; insert = insert $:t; mem = mem $:t }
+  end
+end
+
+module List = Class.Make(struct
+  type 'a c = 'a list
+  let empty = []
+  let insert x xs = x :: xs
+  let mem = List.mem
+end)
+
+(* polymorphic set using Ord.compare *)
+module Set_impl : sig
+  type 'a c
+  val empty : 'a c
+  val insert : $:'a Ord.t -> 'a -> 'a c -> 'a c
+  val mem : $:'a Ord.t -> 'a -> 'a c -> bool
+end = struct
+  type 'a c = Empty | Node of 'a * 'a c * 'a c
+    
+  let rec height = function
+    | Empty -> 0
+    | Node (_, t1, t2) -> max (height t1) (height t2)
+
+  let empty = Empty
+    
+  let node v t1 t2 = Node (v, t1, t2)
+
+  (* It may not be correct, but who cares ? *)
+  let rotate a t1 t2 =
+    let h1 = height t1 in
+    let h2 = height t2 in
+    if h1 - h2 > 1 then begin
+      match t1 with
+      | Empty -> assert false
+      | Node (a1, t11, t12) ->
+          Node (a1, t11, Node(a, t12, t2))
+    end else if h2 - h1 > 1 then begin
+      match t2 with
+      | Empty -> assert false
+      | Node (a2, t21, t22) ->
+          Node (a2, Node(a, t1, t21), t22)
+    end else Node(a, t1, t2) 
+
+  let rec insert a t =
+    match t with
+    | Empty -> Node (a, Empty, Empty)
+    | Node (a', t1, t2) ->
+        match Ord.compare a a' with
+        | 0 -> t
+        | -1 ->
+            let t1' = insert a t1 in
+            rotate a' t1' t2
+        | 1 ->
+            let t2' = insert a t2 in
+            rotate a' t1 t2'
+        | _ -> assert false
+
+  let rec mem a t =
+    match t with
+    | Empty -> false
+    | Node (a', t1, t2) ->
+        match Ord.compare a a' with
+        | 0 -> true
+        | -1 -> mem a t1
+        | 1 -> mem a t2
+        | _ -> assert false
+end
+
+module Set = Class.Make_with_ord(Set_impl)
+
+open Class
+
+(* Sigh, needs explicit types. Disappointed. *)
+let () = 
+  (* assert (empty = []); (* $:('a, 'b list) Class.t -> unit *) *)
+  (* assert ((empty : int list) = []); (* $:('a, int list) Class.t -> unit *) *)
+  assert (empty $:List.t = []);
+  assert (insert $:List.t 1 [] = [1]);
+  assert (mem $:List.t 1 (empty $:List.t) = false);
+
+  (* It translates Set.t => Set.t Ord.int. That's nice. *) 
+  assert (mem $:Set.t 1 (empty $:Set.t) = false);
+  assert (mem $:(Set.t $:Ord.int) 1 (empty $:(Set.t $:Ord.int)) = false);
+;;
+
+
+  

dcamlexamples/ex061_coll_overload.ml

+(* ex060_coll.ml is too closed. Coll class takes a completely closed overloaded
+   values Ord. Here, using Overload module, one of $'Caml-0.2.0's new features,
+   we introduce some amount of openness.
+*)
+
+module Ord : sig
+  type 'a t
+  val compare : $:'a t -> 'a -> 'a -> int
+  val lift : ('a -> 'a -> int) -> 'a t
+  val max : $:'a t -> 'a -> 'a -> 'a
+  val min : $:'a t -> 'a -> 'a -> 'a
+end = struct
+  type 'a t = 'a -> 'a -> int
+  let compare $:t = t
+  let lift x = x
+  let max x y = if compare x y >= 0 then x else y
+  let min x y = if compare x y <= 0 then x else y
+end
+
+module Ord_int = struct
+  let int (x : int) y = Pervasives.compare x y
+  let int = Ord.lift int
+end
+
+module Ord_float = struct
+  let float (x : float) y = Pervasives.compare x y
+  let float = Ord.lift float
+end
+
+module Class = struct
+  type ('a, 'ac) t = {
+    empty : 'ac;
+    insert : 'a -> 'ac -> 'ac;
+    mem : 'a -> 'ac -> bool
+  }
+
+  let empty $:t = t.empty
+  let insert $:t = t.insert
+  let mem $:t = t.mem
+
+  module Make(M : sig
+    type 'a c
+    val empty : 'a c
+    val insert : 'a -> 'a c -> 'a c
+    val mem : 'a -> 'a c -> bool
+  end) : sig
+    val t : ('a, 'a M.c) t
+  end = struct
+    open M
+    let t = { empty = empty; insert = insert; mem = mem }
+  end
+
+  module Make_with_ord(M : sig
+    type 'a c
+    val empty : 'a c
+    val insert : $:'a Ord.t -> 'a -> 'a c -> 'a c
+    val mem : $:'a Ord.t -> 'a -> 'a c -> bool
+  end) : sig
+    val t : $:'a Ord.t -> ('a, 'a M.c) t
+  end = struct
+    open M
+    (* CR jfuruse: pity, but we need explicit abstractions for now *)
+    let t $:t = { empty = empty; insert = insert $:t; mem = mem $:t }
+  end
+end
+
+module List = Class.Make(struct
+  type 'a c = 'a list
+  let empty = []
+  let insert x xs = x :: xs
+  let mem = List.mem
+end)
+
+(* polymorphic set using Ord.compare *)
+module Set_impl : sig
+  type 'a c
+  val empty : 'a c
+  val insert : $:'a Ord.t -> 'a -> 'a c -> 'a c
+  val mem : $:'a Ord.t -> 'a -> 'a c -> bool
+end = struct
+  type 'a c = Empty | Node of 'a * 'a c * 'a c
+    
+  let rec height = function
+    | Empty -> 0
+    | Node (_, t1, t2) -> max (height t1) (height t2)
+
+  let empty = Empty
+    
+  let node v t1 t2 = Node (v, t1, t2)
+
+  (* It may not be correct, but who cares ? *)
+  let rotate a t1 t2 =
+    let h1 = height t1 in
+    let h2 = height t2 in
+    if h1 - h2 > 1 then begin
+      match t1 with
+      | Empty -> assert false
+      | Node (a1, t11, t12) ->
+          Node (a1, t11, Node(a, t12, t2))
+    end else if h2 - h1 > 1 then begin
+      match t2 with
+      | Empty -> assert false
+      | Node (a2, t21, t22) ->
+          Node (a2, Node(a, t1, t21), t22)
+    end else Node(a, t1, t2) 
+
+  let rec insert a t =
+    match t with
+    | Empty -> Node (a, Empty, Empty)
+    | Node (a', t1, t2) ->
+        match Ord.compare a a' with
+        | 0 -> t
+        | -1 ->
+            let t1' = insert a t1 in
+            rotate a' t1' t2
+        | 1 ->
+            let t2' = insert a t2 in
+            rotate a' t1 t2'
+        | _ -> assert false
+
+  let rec mem a t =
+    match t with
+    | Empty -> false
+    | Node (a', t1, t2) ->
+        match Ord.compare a a' with
+        | 0 -> true
+        | -1 -> mem a t1
+        | 1 -> mem a t2
+        | _ -> assert false
+end
+
+module Set = Class.Make_with_ord(Set_impl)
+
+open Class
+
+(* Sigh, needs explicit types. Disappointed. *)
+let () = 
+  (* assert (empty = []); (* $:('a, 'b list) Class.t -> unit *) *)
+  (* assert ((empty : int list) = []); (* $:('a, int list) Class.t -> unit *) *)
+  assert (empty $:List.t = []);
+  assert (insert $:List.t 1 [] = [1]);
+  assert (mem $:List.t 1 (empty $:List.t) = false);
+
+  (* It translates Set.t => Set.t Ord_int.int That's nice. *) 
+  assert (mem $:Set.t 1 (empty $:Set.t) = false);
+(*
+  assert (mem $:(Set.t $:Ord_int.int) 1 (empty $:(Set.t $:Ord_int.int)) = false);
+*)
+;;

dcamlmisc/DISPATCH

+labeled     labeled-omitted    unlabeled       labeled-abs     omitted-abs   unlabeled-abs
+
+normal
+
+f ~x:y      f ~x               f y             fun ~x:y        fun ~x        fun y
+
+optional
+
+f ~x:y      f ~x               --              fun ?x:y        fun ?x        --
+
+optional dual
+
+f ?x:y      f ?x               --              --              --            --
+
+dispatch
+
+f ?$x:y      f ?$x             f ?$:y (???)     fun ?$x:y      fun ?$x       fun ?$:y
+
+type
+
+dispatch
+
+        $x:t -> ..
+        $:t -> ...
+        
+Lex tokens
+
+
+
+

dcamlmisc/GCAML-BUG.txt

+***
+
+# f 1;;
+Fatal error: exception Assert_failure("typing/typecore.ml", 2274, 27)
+(Program not linked with -g, cannot print stack backtrace)
+
+***
+
+# let f $x = x;;
+val f : $x:'a -> 'a = <fun>
+# let g = f, f;;
+val g : $x:'a -> 'b * 'a = <fun>       (* wrongly unified! *)
+
+*** manual $abst are eliminated+abstracted
+
+# let f $x $y z = [x;y;z];;
+val f : $y:'a -> $x:'a -> 'a -> 'a list = <fun>
+

dcamlmisc/pcrex.ml

+open Pcre
+open Regexp
+
+(* same as Regexp.t *)
+type 'a t = {
+    string : string;
+    typ : typ;
+    result : typ -> string array -> 'a
+  }
+
+let (>>) (t : 'a Regexp.t) f = fun s -> 
+  let t = (Obj.magic t : 'a t) in
+  f (t.result t.typ (extract ~pat: t.string s))
+
+let test s t f = (t >> f) s
+
+let rec pmatch (s : string) = function
+  | [] -> raise Not_found
+  | c::cs -> try c s with Not_found -> pmatch s cs
+
+(* test *)
+
+let _ = 
+  pmatch "hoge" [ [/hoge/] >> (fun o -> "hoge");
+		  [/ha(g)e/] >> (fun o -> o#_1) ]
+
+let subst s (t : 'a Regexp.t) f =
+  let t = (Obj.magic t : 'a t) in
+  substitute ~pat: t.string ~subst: f s
+
+(* callout *)
+
+(* type of our callout:
+   <...> -> unit
+*)

dcamltests/.depend

+dummy.cmi: 
+dummy.cmo: dummy.cmi 
+dummy.cmx: dummy.cmi 
+test.cmo: 
+test.cmx: 

dcamltests/Makefile

+ROOT=..
+
+include $(ROOT)/config/Makefile
+
+# Various commands and dir
+##########################
+CAMLRUN=$(ROOT)/boot/ocamlrun
+OCAMLC   = $(ROOT)/ocamlcomp.sh -annot
+OCAMLOPT = $(ROOT)/ocamlcompopt.sh
+OCAMLDEP = $(CAMLRUN) $(ROOT)/tools/ocamldep
+OCAMLLEX = $(CAMLRUN) $(ROOT)/boot/ocamllex
+OCAMLYACC= $(ROOT)/boot/ocamlyacc
+OCAMLLIB = $(LIBDIR)
+OCAMLBIN = $(BINDIR)
+
+# Compilation
+#############
+OCAMLSRCDIR=..
+INCLUDES_DEP=-I $(OCAMLSRCDIR)/parsing \
+	-I $(OCAMLSRCDIR)/utils \
+	-I $(OCAMLSRCDIR)/typing \
+	-I $(OCAMLSRCDIR)/driver \
+	-I $(OCAMLSRCDIR)/bytecomp \
+	-I $(OCAMLSRCDIR)/tools \
+	-I $(OCAMLSRCDIR)/toplevel/ \
+	-I dir1 -I dir2
+
+OTHERS=$(ROOT)/otherlibs
+
+# Requires unix!
+COMPFLAGS= $(INCLUDES_DEP) -I $(OTHERS)/unix
+
+include Makefile.targets
+
+all: $(TARGETS) 
+
+clean:
+	rm -f *.cm* *.o *.annot *.spot  */*.cm* */*.annot */*.spot
+
+# generic rules :
+#################
+
+.SUFFIXES: .mll .mly .ml .mli .cmo .cmi .cmx
+
+.ml.cmo:
+	$(OCAMLC) $(OCAMLPP) $(COMPFLAGS) -c $<
+
+.mli.cmi:
+	$(OCAMLC) $(OCAMLPP) $(COMPFLAGS) -c $<
+
+.ml.cmx:
+	$(OCAMLOPT) $(OCAMLPP) $(COMPFLAGS) -c $<
+
+.mll.ml:
+	$(OCAMLLEX) $<
+
+.mly.ml:
+	$(OCAMLYACC) -v $<
+
+.mly.mli:
+	$(OCAMLYACC) -v $<
+
+beforedepend::
+
+depend: beforedepend
+	$(CAMLRUN) $(ROOT)/tools/ocamldep $(INCLUDES) *.mli *.ml > .depend
+
+Makefile.targets: *.ml # *.mli
+	echo TARGETS= \\ > $@
+	ls *.ml *.mli | sed -e 's/mli/cmi/' -e 's/ml/cmo/' -e 's/$$/ \\/'	 >> $@
+
+.PHONY: clean install installopt beforedepend depend
+
+include .depend

dcamltests/Makefile.targets

+TARGETS= \
+arith.cmo \
+by_record.cmo \
+class.cmo \
+closed.cmo \
+compaction.cmo \
+complete_class_by_record.cmo \
+constraint.cmo \
+constraint2.cmo \
+derivable.cmo \
+eq.cmo \
+error_unmatched_pattern.cmo \
+expansive.cmo \
+explicit.cmo \
+flat.cmo \
+inherit.cmo \
+loop.cmo \
+multi.cmo \
+multi_error.cmo \
+new_resolution.cmo \
+new_resolution2.cmo \
+nodes.cmo \
+nodes_resolve.cmo \
+non_dabstractable.cmo \
+oo001.cmo \
+oo002.cmo \
+opvar.cmo \
+rec.cmo \
+rec_error.cmo \
+record.cmo \
+resolve.cmo \
+stdlib.cmo \
+sum.cmo \
+sum2.cmo \
+sum3.cmo \
+sum4.cmo \
+sum_class.cmo \
+sum_class_by_functor.cmo \
+sum_ideal.cmo \
+sum_in_blog.cmo \
+test001.cmo \
+test002.cmo \
+test003.cmo \
+test004.cmo \
+tuple.cmo \

dcamltests/arith.ml

+(* to avoid confusion with Pervasives ops *)
+let (+) = ()
+let (-) = ()
+
+module M = struct
+  type 'a t = {
+    plus : 'a -> 'a -> 'a;
+    minus : 'a -> 'a -> 'a;
+  }
+  let (+) $:d = d.plus
+  let (-) $:d = d.minus
+
+  module Int = struct
+    let (+) = Pervasives.(+)
+    let (-) = Pervasives.(-)
+    let t = { plus = (+); minus = (-); }
+  end
+
+  module Float = struct
+    let (+) = Pervasives.(+.)
+    let (-) = Pervasives.(-.)
+    let t = { plus = (+); minus = (-); }
+  end
+end

dcamltests/auto-test.pl

+#!/usr/bin/perl
+
+use strict;
+
+sub test {
+  my $file = $_[0];
+  if( $file =~ /dummy/ ){ return; }
+  my $result = `../byterun/ocamlrun ../ocaml -I ../stdlib/ $file 2>&1`;
+  chop $result;
+  $result =~ s/\n/ /g;
+  $result =~ s/File "[^"]+", //g;
+  # $result =~ s/Error: .*/Error!/g;
+  $result =~ s/\s+/ /g;
+  if( $? == 11 ){ $result = "Seg fault!!!"; }
+  elsif( $? == 512 ){ $result = "ERROR: $result"; }
+  elsif( $? != 0 ){ $result = "$?!!!"; }
+  else { $result = "OK"; }
+  if( $file =~ /error/ ){
+      if ($result =~ /^ERROR/ ){
+          $result = "OK (error as intended)";
+      } elsif ( $result =~ /^OK/ ) {
+          $result = "ERROR: passed!";
+      }
+  }
+  print "$file:\t$result\n";
+  while (<IN>) { print $_; }
+}
+
+`cd ..; make ocaml`;
+for my $f (@ARGV) {
+    test($f);
+}

dcamltests/by_record.ml

+(* an example which might require laziness *)
+module C = struct
+  type 'a t = {
+    sum : 'a -> int;
+    nodes : 'a -> int;
+  }
+
+  let sum $:d = d.sum
+  let nodes $:d = d.nodes
+end
+
+module Int : sig
+  val int : int C.t
+end = struct
+  let int = { C.sum = (fun x -> x);
+              nodes = (fun x -> 0) }
+end
+
+(* infinite loop at resolution *)
+module List0 : sig
+  val list : $:'a C.t -> $:'a list C.t -> 'a list C.t
+end = struct
+  let sum = function
+      | [] -> 0
+      | x::xs -> C.sum x + C.sum xs
+
+  let nodes = function
+      | [] -> 0
+      | x::xs -> C.nodes x + C.nodes xs + 1
+
+  let list = { C.sum = sum;
+               nodes = nodes }
+end
+
+(* infinite loop at resolution *)
+module List1 : sig
+  val list : $:'a C.t -> 'a list C.t
+end = struct
+  let sum = function
+      | [] -> 0
+      | x::xs -> C.sum x + C.sum xs
+
+  let nodes = function
+      | [] -> 0
+      | x::xs -> C.nodes x + C.nodes xs + 1
+
+  let rec list $:d = { C.sum = sum $:d $:(list $:d);
+                       nodes = nodes $:d $:(list $:d) }
+end
+
+module List : sig
+  val list : $:'a C.t -> 'a list C.t
+end = struct
+  let rec sum = function
+      | [] -> 0
+      | x::xs -> C.sum x + sum xs
+
+  let rec nodes = function
+      | [] -> 0
+      | x::xs -> C.nodes x + nodes xs + 1
+
+  let rec list = { C.sum = sum;
+                   nodes = nodes }
+end
+
+module O : sig
+  type 'a t
+  val sum : $:'a t -> 'a -> int
+  val nodes : $:'a t -> 'a -> int
+  val int : int t
+  val list : $:'a t -> 'a list t
+end = struct
+  include C
+  include Int
+  include List
+end
+  

dcamltests/class.ml

+module Num : sig
+  type 'a t
+  val (+) : $:'a t -> 'a -> 'a -> 'a
+  val (-) : $:'a t -> 'a -> 'a -> 'a
+  val int : int t
+  val float : float t
+end = struct
+  class type ['a] _t = object
+    method plus : 'a -> 'a -> 'a
+    method minus : 'a -> 'a -> 'a
+  end
+  type 'a t = 'a _t
+                
+  let (+) $:d = d#plus
+  let (-) $:d = d#minus
+
+  open Pervasives
+  let int = object method plus = (+) method minus = (-) end
+  let float = object method plus = (+.) method minus = (-.) end
+end
+
+open Num
+let double x = x + x
+
+let _ =
+  (* muhahahaha! *)
+  assert (1 + 2 = 3);
+  assert (1.2 + 3.4 = 4.6);
+  assert (2 - 1 = 1);
+  assert (1.2 - 1.2 = 0.0);
+  assert (double 1 = 2 );
+  assert (double 1.2 = 2.4)
+

dcamltests/closed.ml

+let plus $:d = (d : 'a -> 'a -> 'a)
+let f = fun x -> plus (plus x x) (plus x x)
+let g x = f x
+(*
+  let h () = g 4 (* $ is closed! *)
+*)

dcamltests/compaction.ml

+let (+) $:d : 'a -> 'a -> 'a = d
+
+let quad x = x + x + x + x
+
+let _ = assert (quad $:(Pervasives.(+)) 1 = 4)
+let _ = assert (quad $:(Pervasives.(+.)) 1.2 = 4.8)
+
+let (++) $:d = d
+
+let quad' x = x ++ x ++ x ++ x
+
+let _ = assert (quad' $:(Pervasives.(+)) $:(Pervasives.(+)) $:(Pervasives.(+)) 1 = 4)
+let _ = assert (quad' $:(Pervasives.(+.)) $:(Pervasives.(+.)) $:(Pervasives.(+.)) 1.2 = 4.8)

dcamltests/complete_class_by_record.ml

+(* type class declaration *)
+module type NumT = sig
+  type 'a t
+  val add : $:'a t -> 'a -> 'a -> 'a
+  val sub : $:'a t -> 'a -> 'a -> 'a
+
+  (* the following functor can be created automatically by p4 *)
+  module Make(A : sig
+    type a
+    val add : a -> a -> a
+    val sub : a -> a -> a
+  end) : sig
+    val t : A.a t
+  end
+end
+  
+(* a dictionary implementation *)
+module Num0 : NumT = struct
+  type 'a t = { add : 'a -> 'a -> 'a;
+                sub : 'a -> 'a -> 'a }
+  let add $:d = d.add
+  let sub $:d = d.sub
+
+  module Make(A : sig
+    type a
+    val add : a -> a -> a
+    val sub : a -> a -> a
+  end) = struct
+    open A
+    let t : a t = { add = add;
+                    sub = sub; }
+  end
+end
+  
+(* another dictionary implementation *)
+module Num1 : NumT = struct
+  class type ['a] _t = object method add : 'a -> 'a -> 'a method sub : 'a -> 'a -> 'a end
+  type 'a t = 'a _t
+  let add $:d = d#add
+  let sub $:d = d#sub
+
+  module Make(A : sig
+    type a
+    val add : a -> a -> a
+    val sub : a -> a -> a
+  end) = struct
+    open A
+    let t : a t = object method add = add method sub = sub end
+  end
+end
+  
+(* instance *)
+module Int = Num0.Make(struct
+  type a = int
+  let add = (+)
+  let sub = (-)
+end)
+
+(* instance *)
+module Float = Num0.Make(struct
+  type a = float
+  let add = (+.)
+  let sub = (-.)
+end)
+
+(* associate the overload instances to the class *)
+module Num : sig
+  (* we need this to hide the implemetation of type 'a t = 'a Num0.t
+  *)
+  include NumT
+  val int : int t
+  val float : float t
+end = struct
+  include Num0
+  let int = Int.t
+  let float = Float.t
+end
+  
+(* now all done! *)
+
+open Num
+let _ =
+  assert (add 1 2 = 3); assert (add 1.2 2.3 = 3.5);
+  assert (sub 1 2 = -1); assert (sub 1.2 1.2 = 0.0)
+    
+  

dcamltests/constraint.ml

+let plus $:d = (d : 'a -> 'a -> 'a)
+let _ = assert (plus $:(+) 1 2 = 3)
+let plus : $:('a -> 'a -> 'a) -> 'a -> 'a -> 'a = fun $:d -> d   
+let _ = assert (plus $:(+) 1 2 = 3)
+let a = fun x -> plus (plus x x) (plus x x)
+let _ = assert (a $:(+) 1 = 4)
+let b = fun $:d x -> plus $:d (plus $:d x x) (plus $:d x x)
+let _ = assert (b $:(+) 1 = 4)
+let rec c = fun x -> plus (plus x x) (plus x x)
+let _ = assert (c $:(+) 1 = 4)
+let rec d = fun $:d x -> plus $:d (plus $:d x x) (plus $:d x x)
+let _ = assert (d $:(+) 1 = 4)
+
+let g : $:('a -> 'a -> 'a) -> 'a -> 'a = fun $:d x -> plus $:d (plus $:d x x) (plus $:d x x)
+let _ = assert (g $:(+) 1 = 4)
+
+(* 09/04/24: This function should have type $:('a -> 'a -> 'a) -> 'a -> 'a
+   but its first argument is not labeled *)
+let h : $:('a -> 'a -> 'a) -> 'a -> 'a = fun $:d x -> plus $:d (plus $:d x x) (plus $:d x x)
+let _ = assert (h $:(+) 1 = 4)
+
+(* The following is an error:
+let i : $:('a -> 'a -> 'a) -> 'a -> 'a = fun x -> plus (plus x x) (plus x x)
+   since, it is equivalent with
+let i = 
+   (fun x -> plus (plus x x) (plus x x) : : $:('a -> 'a -> 'a) -> 'a -> 'a )
+
+   We need parens to fix this. It is the original OCaml semantics:
+*)
+let (i : $:('a -> 'a -> 'a) -> 'a -> 'a) = fun x -> plus (plus x x) (plus x x)
+let _ = assert (i $:(+) 1 = 4)
+let rec j : $:('a -> 'a -> 'a) -> 'a -> 'a = fun $:d x -> plus $:d (plus $:d x x) (plus $:d x x)
+let _ = assert (j $:(+) 1 = 4)
+let rec (k : $:('a -> 'a -> 'a) -> 'a -> 'a) = fun x -> plus (plus x x) (plus x x)
+let _ = assert (k $:(+) 1 = 4)

dcamltests/constraint2.ml

+let plus $:d = (d : 'a -> 'a -> 'a)
+let plus : $:('a -> 'a -> 'a) -> 'a -> 'a -> 'a = fun $:d -> d   
+
+(* 09/04/24: This function should have type $:('a -> 'a -> 'a) -> 'a -> 'a
+   but its first argument is not labeled *)
+let f = (fun x -> plus (plus x x) (plus x x)  : 'a -> 'a)
+let f = (fun $:d x -> plus (plus x x) (plus x x)  : $:('a -> 'a -> 'a) -> 'a -> 'a)
+

dcamltests/derivable.ml

+module Eq : sig
+  type 'a t
+  val (==) : $:'a t -> 'a -> 'a -> bool
+  val (/=) : $:'a t -> 'a -> 'a -> bool
+    
+  val int : int t
+  val bool : bool t
+end = struct
+  type 'a t = 'a -> 'a -> bool
+  let (==) $:d = d
+  let (/=) x y = not (x == y)
+
+  let int = (=)
+  let bool = (=)
+end
+
+open Eq
+
+let _ = 
+  assert (not (1 == 2));
+  assert (1 == 1);
+  assert (1 /= 2);
+  assert (not (1 /= 1))
+
+  
+let (==) = () (* to avoid confusion between Pervasives.(==) *)
+
+module Eq = struct
+
+  type 'a t = 'a -> 'a -> bool
+  let (==) $:(d : 'a t) = d
+  let (/=) x y = not (x == y)
+
+end
+
+module type EqT = sig
+
+  type 'a t
+  val (==) : $:'a t -> 'a -> 'a -> bool
+  val (/=) : $:'a t -> 'a -> 'a -> bool
+
+end
+
+module Bool = struct
+
+  let t x y =
+    match x, y with
+    | true, true -> true
+    | false, false -> false
+    | _ -> false
+        
+end
+
+module List = struct
+
+  include Eq
+    
+  let rec t x y = (* we need rec for self *)
+    match x, y with
+    | [], [] -> true
+    | x::xs, y::ys -> x == y && xs == ys
+    | _ -> false
+
+end

dcamltests/error_unmatched_pattern.ml

+let z $:d = d
+let (x,y) = z
+

dcamltests/expansive.ml

+let plus $:d = d
+let _ = plus []
+let _ = plus 1 2
+let f $:x $:y () = plus $:x (plus $:y 1 2) 3
+let f () = plus (plus 1 2) 3
+let v = plus (plus 1 2) 3

dcamltests/explicit.ml

+let plus $:d = d
+let double $:d x = plus $:d x x
+let _ = assert (double $:(+) 1 = 2)
+
+let triple $:d x = plus $:d (plus $:d x x) x
+let _ = assert (triple $:(+) 1 = 3)
+
+let triple $:d1 $:d2 x = plus $:d1 (plus $:d2 x x) x
+let _ = assert (triple $:(+) $:(+) 1 = 3)
+

dcamltests/flat.ml

+let flat $:d = d
+
+let base (x : 'a list) = x
+
+let step l = flat (List.flatten l)
+
+let _ = assert (flat $:(step $:base) [[1]] = [1])
+let _ = assert (flat $:(step $:(step $:base)) [[[1]]] = [1])
+let _ = assert (flat $:(step $:(step $:(step $:base))) [[[[1]]]] = [1])
+let _ = assert (flat $:(step $:(step $:base)) [[[[1]]]] = [[1]])
+#!/bin/sh
+../byterun/ocamlrun ../ocaml -I ../stdlib $*

dcamltests/gcamlc

+#!/bin/sh
+../byterun/ocamlrun ../ocamlc -I ../stdlib $*

dcamltests/inherit.ml

+(* type class interface *)
+module type Eq = sig
+  type 'a t
+  val (==) : $:'a t -> 'a -> 'a -> bool
+  val (/=) : $:'a t -> 'a -> 'a -> bool
+end
+
+module type EqBase = sig
+  type 'a t
+  val (==) : $:'a t -> 'a -> 'a -> bool
+end
+
+(* part of the type class is derived *)
+module MakeEq(A : EqBase) : Eq with type 'a t = 'a A.t = struct
+  include A
+  let (/=) x y = not (x == y)
+end
+
+(* implementation must be hidden by interface *)
+module EqBaseImpl = struct
+  type 'a t = 'a -> 'a -> bool
+  let (==) $:d = d
+end
+
+module EqImpl = MakeEq(EqBaseImpl)
+
+module EqInt = struct
+  let int : int EqBaseImpl.t = (=)
+end
+
+module EqBool = struct
+  let bool : bool EqBaseImpl.t = (=)
+end
+

dcamltests/loop.ml

+(* we had problem of this recursion.
+   it was caused using Hashtbl.create
+   instead of a special tbl for pattern *)
+
+let f g =
+  for i = 0 to 10 do
+    let rec loop = function
+      | 1 -> loop 0
+      | _ -> ignore (i + 1)
+    in
+    loop 0 
+  done;
+  ()
+;;

dcamltests/multi.ml

+module C = struct
+  type ('a, 'b, 'c) t = 'a -> 'b -> 'c
+  let add $:d = d
+end
+
+module IS = struct
+  let int_int_int = (+)
+  let int_float_float x y = float x +. y
+  let float_int_float x y = x +. float y
+  let float_float_float = (+.)
+end
+
+module O : sig
+  type ('a, 'b, 'c) t
+  val add : $:('a, 'b, 'c) t -> 'a -> 'b -> 'c
+  val int_int_int : (int, int, int) t
+  val int_float_float : (int, float, float) t
+  val float_int_float : (float, int, float) t
+  val float_float_float : (float, float, float) t
+end = struct
+  include C
+  include IS
+end
+
+open O
+  
+let _ =
+  assert (add 1 2 + 3 = 6);
+  assert (add 1.0 2.0 +. 3.0 = 6.0);
+  assert (add 1.0 2 +. 3.0 = 6.0)
+  

dcamltests/multi_error.ml

+(* multiple candidates *)
+module Sum : sig
+  type 'a t
+  val sum : $:'a t -> 'a -> int
+  val int : int t
+  val int' : int t
+  val list : $:'a t -> 'a list t
+end = struct
+  type 'a t = 'a -> int
+  let sum $:d = d
+  let int x = x
+  let int' x = x + 1
+  let rec list = function
+    | [] -> 0
+    | x::xs -> sum x + list (* it should be sum *) xs
+end
+  
+let _ =
+  assert (Sum.sum 1 = 1);
+;;

dcamltests/new_resolution.ml

+module type Num_sig = sig
+  type 'a t
+
+  val ( + ) : $:'a t -> 'a -> 'a -> 'a
+  val ( - ) : $:'a t -> 'a -> 'a -> 'a
+  val ( * ) : $:'a t -> 'a -> 'a -> 'a
+  val ( / ) : $:'a t -> 'a -> 'a -> 'a
+  val zero : $:'a t -> 'a
+end
+
+(* this is not required *)
+module type Num_class_sig = sig
+
+  include Num_sig
+
+  module type I = sig
+    type a
+    val add : a -> a -> a
+    val sub : a -> a -> a
+    val mul : a -> a -> a
+    val div : a -> a -> a
+    val zero : a
+  end
+
+  module type A = sig
+    type a
+    val t : a t
+  end
+
+  module Make(I:I) : A with type a = I.a
+
+end
+
+(* The following Num_class can be defined almost automatically *)
+module Num_class : Num_class_sig = struct
+  type 'a t = {
+    add : 'a -> 'a -> 'a;
+    sub : 'a -> 'a -> 'a;
+    mul : 'a -> 'a -> 'a;
+    div : 'a -> 'a -> 'a;
+    zero : 'a;
+  }
+      
+  let ( + ) $:d = d.add
+  let ( - ) $:d = d.sub
+  let ( * ) $:d = d.mul
+  let ( / ) $:d = d.div
+  let zero $:d = d.zero
+
+  module type I = sig
+    type a
+    val add : a -> a -> a
+    val sub : a -> a -> a
+    val mul : a -> a -> a
+    val div : a -> a -> a
+    val zero : a
+  end
+
+  module type A = sig
+    type a
+    val t : a t
+  end
+
+  (* translation of a module to a record.
+     silly, but we have no first class modules *)
+  module Make(I:I) (* : A with type a = I.a *) = struct
+    type a = I.a
+    let t : I.a t = {
+      add = I.add;
+      sub = I.sub;
+      mul = I.mul;
+      div = I.div;
+      zero = I.zero
+    }
+  end
+end
+
+open Num_class
+open Pervasives  
+
+module Int = Make(struct
+    type a = int
+    let add = ( + )
+    let sub = ( - )
+    let mul = ( * )
+    let div = ( / )
+    let zero = 0
+  end)
+  
+module Float = Make(struct
+    type a = float
+    let add = ( +. )
+    let sub = ( -. )
+    let mul = ( *. )
+    let div = ( /. )
+    let zero = 0.
+  end)
+  
+module Num : sig
+  include Num_sig
+  module Int : sig val t : int t end
+  module Float : sig val t : float t end
+end = struct
+  include Num_class
+  module Int = Int
+  module Float = Float
+end
+