Commit ff5cd107 authored by Pietro Abate's avatar Pietro Abate
Browse files

[r2002-10-22 14:01:35 by cvscast] Empty log message

Original author: cvscast
Date: 2002-10-22 14:01:36+00:00
parent 8061cfdb
......@@ -65,6 +65,8 @@ let rec print_exn ppf = function
print_norm t;
Format.fprintf ppf "Sample value: %a@\n"
Types.Print.print_sample (Types.Sample.get t)
| Typer.UnboundId x ->
Format.fprintf ppf "Unbound identifier %s@\n" x
| exn ->
Format.fprintf ppf "%s@\n" (Printexc.to_string exn)
......@@ -73,7 +75,7 @@ let phrase ph =
| Ast.EvalStatement e ->
let (fv,e) = Typer.expr e in
let t = Typer.type_check Typer.Env.empty e Types.any true in
Format.fprintf ppf "%a@\n" Types.Print.print_descr t
Format.fprintf ppf "%a@\n" print_norm t
| Ast.TypeDecl _ -> ()
| _ -> assert false
......@@ -89,7 +91,8 @@ let () =
Typer.register_global_types type_decls;
List.iter phrase p
with
| (Failure _) as e -> raise e (* To get the ocamlrun stack trace *)
| (Failure _ | Not_found) as e ->
raise e (* To get the ocamlrun stack trace *)
| exn -> print_exn ppf exn
......
type Person = FPerson | MPerson;;
type FPerson = <person gender=1>[ Name Children ];;
type MPerson = <person gender=2>[ Name Children ];;
type FPerson = <person gender=["F"]>[ Name Children ];;
type MPerson = <person gender=["M"]>[ Name Children ];;
type Children = <children>[Person*];;
type Name = <name>[String];;
......@@ -11,7 +11,8 @@ type Daughters = <daughters>[ Woman* ];;
let fun sort (MPerson -> Man ; FPerson -> Woman)
<person gender=g>[ n <children>[(mc::MPerson | fc::FPerson)*] ] ->
let tag = match g with 1 -> `woman | 2 -> `man in
let s = map mc with x -> sort x in
let tag = match g with ["F"] -> `woman | ["M"] -> `man in
let s = map mc with (x & MPerson) -> sort x in
let d = map fc with x -> sort x in
<(tag)>[ n <sons>s <daughters>d ] in sort;;
\ No newline at end of file
<(tag)>[ n <sons>s <daughters>d ]
in sort;;
......@@ -10,6 +10,7 @@ exception MultipleLabel of Types.label
exception Constraint of Types.descr * Types.descr * string
exception ShouldHave of Types.descr * string
exception WrongLabel of Types.descr * Types.label
exception UnboundId of string
let raise_loc loc exn = raise (Location (loc,exn))
......@@ -287,6 +288,7 @@ let register_global_types b =
let env = compile_many !global_types b in
List.iter (fun (v,_) ->
let d = Types.descr (mk_typ (StringMap.find v env)) in
let d = Types.normalize d in
Types.Print.register_global v d
) b;
global_types := env
......@@ -399,8 +401,8 @@ let check loc t s msg =
let rec type_check env e constr precise =
(* Format.fprintf Format.std_formatter "constr=%a precise=%b@\n"
Types.Print.print_descr constr precise;
*)
Types.Print.print_descr constr precise; *)
let d = type_check' e.exp_loc env e.exp_descr constr precise in
e.exp_typ <- Types.cup e.exp_typ d;
......@@ -477,9 +479,12 @@ and type_check' loc env e constr precise = match e with
let constr' = Sequence.approx (Types.cap Sequence.any constr) in
let exact = Types.subtype (Sequence.star constr') constr in
if exact then
let res = type_check_branches loc env t b constr' precise in
if exact then (
(* Note: typing mail fail because of the approx on t *)
let res = type_check_branches loc env (Sequence.approx t)
b constr' precise in
if precise then Sequence.star res else constr
)
else
(* Note:
- could be more precise by integrating the decomposition
......@@ -531,7 +536,10 @@ and compute_type env e =
and compute_type' loc env = function
| DebugTyper t -> Types.descr t
| Var s -> Env.find s env
| Var s ->
(try Env.find s env
with Not_found -> raise_loc loc (UnboundId s)
)
| Apply (e1,e2) ->
let t1 = type_check env e1 Types.Arrow.any true in
let t1 = Types.Arrow.get t1 in
......
......@@ -4,6 +4,7 @@ exception MultipleLabel of Types.label
exception Constraint of Types.descr * Types.descr * string
exception ShouldHave of Types.descr * string
exception WrongLabel of Types.descr * Types.label
exception UnboundId of string
val compile_regexp : Ast.regexp -> Ast.ppat -> Ast.ppat
......
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