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

[r2002-10-26 20:45:22 by cvscast] Empty log message

Original author: cvscast
Date: 2002-10-26 20:45:22+00:00
parent 2d490884
......@@ -3,14 +3,16 @@ parser/ast.cmx: parser/location.cmx types/patterns.cmx types/types.cmx
parser/location.cmo: parser/location.cmi
parser/location.cmx: parser/location.cmi
parser/parser.cmo: parser/ast.cmo types/atoms.cmi types/chars.cmi \
parser/lexer.cmo parser/location.cmi types/sequence.cmi types/types.cmi \
parser/parser.cmi
types/intervals.cmi parser/lexer.cmo parser/location.cmi \
types/sequence.cmi types/types.cmi parser/parser.cmi
parser/parser.cmx: parser/ast.cmx types/atoms.cmx types/chars.cmx \
parser/lexer.cmx parser/location.cmx types/sequence.cmx types/types.cmx \
parser/parser.cmi
types/intervals.cmx parser/lexer.cmx parser/location.cmx \
types/sequence.cmx types/types.cmx parser/parser.cmi
parser/parser.cmi: parser/ast.cmo
typing/typed.cmo: parser/location.cmi types/patterns.cmi types/types.cmi
typing/typed.cmx: parser/location.cmx types/patterns.cmx types/types.cmx
typing/typed.cmo: parser/location.cmi types/patterns.cmi types/sortedMap.cmi \
types/types.cmi
typing/typed.cmx: parser/location.cmx types/patterns.cmx types/sortedMap.cmx \
types/types.cmx
typing/typer.cmo: parser/ast.cmo types/intervals.cmi parser/location.cmi \
types/patterns.cmi types/sequence.cmi types/sortedList.cmi \
typing/typed.cmo types/types.cmi typing/typer.cmi
......@@ -59,12 +61,14 @@ types/sortedMap.cmi: types/sortedList.cmi
types/syntax.cmi: types/patterns.cmi types/types.cmi
types/types.cmi: types/atoms.cmi types/chars.cmi types/intervals.cmi \
types/sortedMap.cmi
runtime/value.cmi: types/chars.cmi typing/typed.cmo types/types.cmi
runtime/value.cmo: types/chars.cmi typing/typed.cmo types/types.cmi \
runtime/value.cmi
runtime/value.cmx: types/chars.cmx typing/typed.cmx types/types.cmx \
runtime/value.cmi
runtime/value.cmi: types/patterns.cmi typing/typed.cmo
runtime/value.cmo: types/chars.cmi types/patterns.cmi types/sequence.cmi \
types/sortedMap.cmi typing/typed.cmo types/types.cmi runtime/value.cmi
runtime/value.cmx: types/chars.cmx types/patterns.cmx types/sequence.cmx \
types/sortedMap.cmx typing/typed.cmx types/types.cmx runtime/value.cmi
driver/cduce.cmo: parser/ast.cmo types/builtin.cmo parser/location.cmi \
parser/parser.cmi types/patterns.cmi typing/typer.cmi types/types.cmi
parser/parser.cmi types/patterns.cmi typing/typer.cmi types/types.cmi \
runtime/value.cmi
driver/cduce.cmx: parser/ast.cmx types/builtin.cmx parser/location.cmx \
parser/parser.cmx types/patterns.cmx typing/typer.cmx types/types.cmx
parser/parser.cmx types/patterns.cmx typing/typer.cmx types/types.cmx \
runtime/value.cmx
......@@ -100,7 +100,7 @@ let phrase ph =
let t = Typer.type_check Typer.Env.empty e Types.any true in
Format.fprintf ppf "|- %a@\n" print_norm t;
let v = Value.eval Value.empty_env e in
Format.fprintf ppf "=> %a@\n" Value.print v
Format.fprintf ppf "=> @[%a@]@\n" Value.print v
| Ast.TypeDecl _ -> ()
| Ast.Debug l -> debug l
| _ -> assert false
......
......@@ -67,10 +67,6 @@ EXTEND
mk loc (Match (e1,[p,e2]))
]
|
[ LIDENT "flatten"; e = expr -> mk loc (Op ("flatten",[e]))
| e1 = expr; e2 = expr -> mk loc (Apply (e1,e2))
]
|
[ e1 = expr; op = ["+" | "-" | "@"]; e2 = expr -> mk loc (Op (op,[e1;e2]))
......@@ -82,6 +78,11 @@ EXTEND
[ e = expr; "."; l = [LIDENT | UIDENT] -> mk loc (Dot (e,Types.label l))
]
|
[ LIDENT "flatten"; e = expr -> mk loc (Op ("flatten",[e]))
| e1 = expr; e2 = expr -> mk loc (Apply (e1,e2))
]
| "no_appl"
[ c = const -> mk loc (Cst c)
| "("; l = LIST1 expr SEP ","; ")" -> tuple loc l
......@@ -185,7 +186,16 @@ EXTEND
| i = INT ; "--"; j = INT ->
let i = Big_int.big_int_of_string i
and j = Big_int.big_int_of_string j in
mk loc (Internal (Types.interval i j))
mk loc (Internal (Types.interval (Intervals.bounded i j)))
| i = INT ->
let i = Big_int.big_int_of_string i in
mk loc (Internal (Types.interval (Intervals.atom i)))
| "*--"; j = INT ->
let j = Big_int.big_int_of_string j in
mk loc (Internal (Types.interval (Intervals.left j)))
| i = INT; "--*" ->
let i = Big_int.big_int_of_string i in
mk loc (Internal (Types.interval (Intervals.right i)))
| i = char ->
mk loc (Internal (Types.char (Chars.char_class i i)))
| i = char ; "--"; j = char ->
......
......@@ -15,24 +15,60 @@ and abstr = {
fun_body : Typed.branches;
}
let rec print ppf = function
| Pair (x,y) ->
Format.fprintf ppf "(%a,%a)" print x print y
| Record l ->
Format.fprintf ppf "{%a}" print_record l
| Atom a ->
Format.fprintf ppf "`%s" (Types.atom_name a)
| Integer i ->
Format.fprintf ppf "%s" (Big_int.string_of_big_int i)
| Char c ->
Chars.Unichar.print ppf c
| Fun c ->
Format.fprintf ppf "<fun>"
let rec is_seq = function
| Pair (_, y) when is_seq y -> true
| Atom a when a = Sequence.nil_atom -> true
| _ -> false
let is_xml = function
| Pair (Atom _, Pair (Record _, s)) when is_seq s -> true
| _ -> false
let rec is_str = function
| Pair (Char _, y) when is_str y -> true
| Atom a when a = Sequence.nil_atom -> true
| _ -> false
let rec print ppf v =
if is_str v then Format.fprintf ppf "\"%a\"" print_quoted_str v
else if is_xml v then print_xml ppf v
else if is_seq v then Format.fprintf ppf "[ %a]" print_seq v
else match v with
| Pair (x,y) -> Format.fprintf ppf "(%a,%a)" print x print y
| Record l -> Format.fprintf ppf "{%a }" print_record l
| Atom a -> Format.fprintf ppf "`%s" (Types.atom_name a)
| Integer i -> Format.fprintf ppf "%s" (Big_int.string_of_big_int i)
| Char c -> Chars.Unichar.print ppf c
| Fun c -> Format.fprintf ppf "<fun>"
and print_quoted_str ppf = function
| Pair (Char c, y) ->
Chars.Unichar.print_in_string ppf c;
print_quoted_str ppf y
| _ -> ()
and print_seq ppf = function
| Pair (Char _, _) as s -> Format.fprintf ppf "'%a" print_str s
| Pair (x,y) -> Format.fprintf ppf "@[%a@]@ %a" print x print_seq y
| _ -> ()
and print_str ppf = function
| Pair (Char c,y) ->
Chars.Unichar.print_in_string ppf c;
print_str ppf y
| v ->
Format.fprintf ppf "\' ";
print_seq ppf v
and print_xml ppf = function
| Pair(Atom tag, Pair (Record attr,content)) ->
Format.fprintf ppf "@[<hv2><%s%a>[@ %a@]]"
(Types.atom_name tag)
print_record attr
print_seq content
| _ -> assert false
and print_record ppf = function
| [] -> ()
| [f] -> print_field ppf f
| f :: rem -> Format.fprintf ppf "%a; %a" print_field f print_record rem
| [f] -> Format.fprintf ppf " %a" print_field f
| f :: rem -> Format.fprintf ppf " %a;%a" print_field f print_record rem
and print_field ppf (l,v) =
Format.fprintf ppf "%s = %a" (Types.label_name l) print v
......@@ -144,11 +180,10 @@ and run_disp_field v bindings fields l vl = function
(* Evaluation of expressions *)
let rec eval env e =
match e.Typed.exp_descr with
let rec eval env e0 =
match e0.Typed.exp_descr with
| Typed.Var s -> Env.find s env
| Typed.Apply (f,arg) ->
eval_apply (eval env f) (eval env arg)
| Typed.Apply (f,arg) -> eval_apply (eval env f) (eval env arg)
| Typed.Abstraction a ->
let a' = {
fun_env = env;
......@@ -160,8 +195,7 @@ let rec eval env e =
| Some f -> a'.fun_env <- Env.add f self a'.fun_env
| None -> ());
self
| Typed.RecordLitt r ->
Record (List.map (fun (l,e) -> (l, eval env e)) r)
| Typed.RecordLitt r -> Record (List.map (fun (l,e) -> (l, eval env e)) r)
| Typed.Pair (e1,e2) -> Pair (eval env e1, eval env e2)
| Typed.Cst c -> const c
| Typed.Match (arg,brs) -> eval_branches env brs (eval env arg)
......
......@@ -4,7 +4,7 @@ type Name = <name>[String];;
type Addr = <addr>[String];;
type Tel = <tel>[String];;
(*
<addrbook>[
<name>["Haruo Hosoya"]
<addr>["Tokyo"]
......@@ -41,7 +41,7 @@ type Tel = <tel>[String];;
<name>["Peter Buneman"]
<addr>["Scotland"]
];;
*)
(*
......
......@@ -19,6 +19,19 @@ let cup t s =
List.filter (fun (p,n) -> not (List.exists (may_remove (p,n)) s)) t in
SortedList.cup s t
let clean t =
let rec aux accu = function
| (p,n) :: rem ->
if (List.exists (may_remove (p,n)) accu)
|| (List.exists (may_remove (p,n)) rem)
then aux accu rem
else aux((p,n) :: accu) rem
| [] -> accu
in
List.rev (aux [] t)
let rec fold2_aux f a x = function
| [] -> x
| h :: t -> fold2_aux f a (f x a h) t
......@@ -45,7 +58,7 @@ let cap s t =
lines1
lines2
in
SortedList.cup common (SortedList.from_list lines)
clean (SortedList.cup common (SortedList.from_list lines))
let diff c1 c2 =
if c2 == full then empty
......
......@@ -17,6 +17,9 @@ module Unichar = struct
if (c < 128)
then Format.fprintf ppf "%C" (Char.chr c)
else Format.fprintf ppf "#x%x" c
let print_in_string ppf c =
Format.fprintf ppf "%c" (Char.chr c)
end
type t = (Unichar.t * Unichar.t) list
......
......@@ -5,6 +5,7 @@ module Unichar : sig
val to_int: t -> int
val print : Format.formatter -> t -> unit
val print_in_string : Format.formatter -> t -> unit
end
type t = (Unichar.t * Unichar.t) list
......
......@@ -38,9 +38,13 @@ let hash = function
let empty = []
let any = [Any]
let atom a b =
let bounded a b =
if le_big_int a b then [Bounded (a,b)] else empty
let left a = [Left a]
let right a = [Right a]
let atom a = bounded a a
let rec iadd_left l b = match l with
| [] -> [Left b]
......
......@@ -9,7 +9,10 @@ val cup : t -> t -> t
val cap : t -> t -> t
val diff : t -> t -> t
val atom : Big_int.big_int -> Big_int.big_int -> t
val bounded : Big_int.big_int -> Big_int.big_int -> t
val left : Big_int.big_int -> t
val right : Big_int.big_int -> t
val atom : Big_int.big_int -> t
val is_empty : t -> bool
......
......@@ -451,6 +451,7 @@ struct
let p = pl.(i) in
let tp = p.Normal.na in
let v = p.Normal.nfv in
(* let tp = Types.normalize tp in *)
`Switch
(num arity v,
aux (Types.cap t tp) (arity + (List.length v)) (i+1),
......@@ -565,6 +566,7 @@ struct
) yes;
unselect.(i) <- no @ unselect.(i) in
Array.iteri (fun i -> List.iter (aux i)) pl;
let sorted = Array.of_list (SortedMap.from_list SortedList.cup !accu) in
let infos = Array.map snd sorted in
let disp = dispatcher t (Array.map fst sorted) in
......@@ -574,6 +576,7 @@ struct
List.iter (fun (j,r) -> List.iter (add r) infos.(j)) m;
d t selected unselect
in
let res = Array.map result disp.codes in
post (disp,res)
......@@ -585,7 +588,7 @@ struct
let t = Types.diff t (p.Normal.a) in
(t, (p,e) :: brs)
) (t,[]) brs in
let pl = Array.map (fun x -> [x]) (Array.of_list brs) in
get_tests
pl
......
......@@ -36,14 +36,14 @@ module I = struct
chars = Chars.any;
}
let interval i j = { empty with ints = Intervals.atom i j }
let interval i = { empty with ints = i }
let times x y = { empty with times = Boolean.atom (x,y) }
let arrow x y = { empty with arrow = Boolean.atom (x,y) }
let record label opt t = { empty with record = Boolean.atom (label,opt,t) }
let atom a = { empty with atoms = a }
let char c = { empty with chars = c }
let constant = function
| Integer i -> interval i i
| Integer i -> interval (Intervals.atom i)
| Atom a -> atom (Atoms.atom a)
| Char c -> char (Chars.atom c)
......
......@@ -33,7 +33,7 @@ val any : descr
(** Constructors **)
val interval : Big_int.big_int -> Big_int.big_int -> descr
val interval : Intervals.t -> descr
val atom : atom Atoms.t -> descr
val times : node -> node -> descr
val arrow : node -> node -> descr
......
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