[r2002-10-16 08:58:50 by cvscast] Empty log message

Original author: cvscast
Date: 2002-10-16 08:58:50+00:00

parser/parser.ml

@@ -24,8 +24,7 @@ open Ast
   GLOBAL: prog expr pat regexp const;
 
   prog: [
-    [ l = LIST0 [ e = expr -> mk loc (EvalStatement e) ] SEP ";;";
-       "EOF"  -> l ]
+    [ l = LIST0 [ e = expr; ";;" -> mk loc (EvalStatement e) ] -> l ]
   ];
 
   expr: [

types/types.ml

@@ -551,44 +551,6 @@ let rec rec_normalize d =
 let normalize n =
   internalize (rec_normalize (descr n))
 
-let apply_simple result left t = 
-  let ok = ref false in
-  let rec aux result accu1 accu2 = function
-    | (t1,s1)::left ->
-        let result = 
-	  let accu1 = diff_t accu1 t1 in
-          if non_empty accu1 then aux result accu1 accu2 left
-          else (ok := true; result) in
-        let result =
-	  let accu2 = cap_t accu2 s1 in
-          aux result accu1 accu2 left in
-	result
-    | [] -> 
-        if subtype accu2 result 
-	then result
-	else cup result accu2
-  in
-  let result = aux result t any left in
-  if !ok then result else raise Not_found
-
-let apply t1 t2 =
-  if is_empty t2 
-  then empty
-  else
-    if non_empty {t1 with arrow = []} 
-    then raise Not_found
-    else
-      List.fold_left
-	(fun accu (left,right) ->
-	   if Sample.check_empty_arrow_line left right 
-	   then accu 
-	   else
-	     apply_simple accu left t2
-	)
-	empty
-	t1.arrow
-  
-
 module Print =
 struct
   let marks = Hashtbl.create 63
@@ -596,7 +558,9 @@ struct
   let count_name = ref 0
   let name () =
     incr count_name;
-    "'a" ^ (string_of_int !count_name)
+    "X" ^ (string_of_int !count_name)
+(* TODO: 
+   check that these generated names does not conflict with declared types *)
 
   let bool_iter f b =
     List.iter (fun (p,n) -> List.iter f p; List.iter f n) b
@@ -715,6 +679,54 @@ struct
 	  ) iface
 end
 
+module Arrow =
+struct
+  type t = descr * (descr * descr) list list
+
+  let get t =
+    List.fold_left
+      (fun ((dom,arr) as accu) (left,right) ->
+	 if Sample.check_empty_arrow_line left right 
+	 then accu
+	 else (
+	   let left =
+	     List.map 
+	       (fun (t,s) -> (descr t, descr s)) left in
+	   let d = List.fold_left (fun d (t,_) -> cup d t) empty left in
+	   (cap dom d, left :: arr)
+	 )
+      )
+      (any, [])
+      t.arrow
+
+  let domain (dom,_) = dom
+
+  let apply_simple t result left = 
+    let rec aux result accu1 accu2 = function
+      | (t1,s1)::left ->
+          let result = 
+	    let accu1 = diff accu1 t1 in
+            if non_empty accu1 then aux result accu1 accu2 left
+            else result in
+          let result =
+	    let accu2 = cap accu2 s1 in
+            aux result accu1 accu2 left in
+	  result
+      | [] -> 
+          if subtype accu2 result 
+	  then result
+	  else cup result accu2
+    in
+    aux result t any left
+      
+  let apply (_,arr) t =
+    List.fold_left (apply_simple t) empty arr
+
+  let any = { empty with arrow = any.arrow }
+end
+  
+
+
 (*
 let rec print_normal_record ppf = function
   | Success -> Format.fprintf ppf "Yes"

types/types.mli

@@ -100,10 +100,20 @@ module Record : sig
     (* Raise Not_found if label is not necessarily present *)
 end
 
+module Arrow : sig
+  val any : descr
 
-val normalize : node -> node
+  type t
+  val get: descr -> t
+    (* Always succeed; no check <= Arrow.any *)
 
-val apply : descr -> descr -> descr
+  val domain: t -> descr
+  val apply: t -> descr -> descr
+    (* Always succeed; no check on the domain *)
+end
+
+
+val normalize : node -> node
 
 (** Subtyping and sample values **)
 

typing/typer.ml

@@ -366,7 +366,23 @@ and compute_type' loc env = function
   | Var s -> Env.find s env
   | Apply (e1,e2) ->
       let t1 = compute_type env e1 and t2 = compute_type env e2 in
-      Types.apply t1 t2
+      if Types.is_empty t2 
+      then Types.empty
+      else 
+	if Types.subtype t1 Types.Arrow.any 
+	then
+	  let t1 = Types.Arrow.get t1 in
+	  let dom = Types.Arrow.domain t1 in
+	  if Types.subtype t2 dom
+	  then Types.Arrow.apply t1 t2
+	  else
+	    raise_loc loc 
+	      (Constraint 
+		 (t2,dom,"The argument is not in the domain of the function"))
+	else
+	  raise_loc loc
+	    (Constraint
+	       (t1,Types.Arrow.any,"The expression in function position is not necessarily a function"))
   | Abstraction a ->
       let env = match a.fun_name with
 	| None -> env