Commit 589be5e4 authored by Pietro Abate's avatar Pietro Abate
Browse files

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

Original author: cvscast
Date: 2002-10-16 08:58:50+00:00
parent f2d60961
...@@ -24,8 +24,7 @@ open Ast ...@@ -24,8 +24,7 @@ open Ast
GLOBAL: prog expr pat regexp const; GLOBAL: prog expr pat regexp const;
prog: [ prog: [
[ l = LIST0 [ e = expr -> mk loc (EvalStatement e) ] SEP ";;"; [ l = LIST0 [ e = expr; ";;" -> mk loc (EvalStatement e) ] -> l ]
"EOF" -> l ]
]; ];
expr: [ expr: [
......
...@@ -551,44 +551,6 @@ let rec rec_normalize d = ...@@ -551,44 +551,6 @@ let rec rec_normalize d =
let normalize n = let normalize n =
internalize (rec_normalize (descr 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 = module Print =
struct struct
let marks = Hashtbl.create 63 let marks = Hashtbl.create 63
...@@ -596,7 +558,9 @@ struct ...@@ -596,7 +558,9 @@ struct
let count_name = ref 0 let count_name = ref 0
let name () = let name () =
incr count_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 = let bool_iter f b =
List.iter (fun (p,n) -> List.iter f p; List.iter f n) b List.iter (fun (p,n) -> List.iter f p; List.iter f n) b
...@@ -715,6 +679,54 @@ struct ...@@ -715,6 +679,54 @@ struct
) iface ) iface
end 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 let rec print_normal_record ppf = function
| Success -> Format.fprintf ppf "Yes" | Success -> Format.fprintf ppf "Yes"
......
...@@ -100,10 +100,20 @@ module Record : sig ...@@ -100,10 +100,20 @@ module Record : sig
(* Raise Not_found if label is not necessarily present *) (* Raise Not_found if label is not necessarily present *)
end 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 **) (** Subtyping and sample values **)
......
...@@ -366,7 +366,23 @@ and compute_type' loc env = function ...@@ -366,7 +366,23 @@ and compute_type' loc env = function
| Var s -> Env.find s env | Var s -> Env.find s env
| Apply (e1,e2) -> | Apply (e1,e2) ->
let t1 = compute_type env e1 and t2 = compute_type env e2 in 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 -> | Abstraction a ->
let env = match a.fun_name with let env = match a.fun_name with
| None -> env | None -> env
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment