Commit d5be1c60 authored by Pietro Abate's avatar Pietro Abate

[r2002-10-10 09:11:23 by cvscast] Initial revision

Original author: cvscast
Date: 2002-10-10 09:11:23+00:00
parents
PARSER = parser/location.cmo
TYPES = types/recursive.cmo types/sortedList.cmo types/sortedMap.cmo types/boolean.cmo types/intervals.cmo types/atoms.cmo types/strings.cmo types/types.cmo types/patterns.cmo types/syntax.cmo
OBJECTS = $(PARSER) $(TYPES)
all.cma: $(OBJECTS)
ocamlc -o all.cma -I +camlp4 gramlib.cma -a $(OBJECTS)
depend:
ocamldep -pp 'camlp4o pa_extend.cmo' parser/*.ml* types/*.ml*
clean:
(cd parser; rm -f *.cmi *.cmo *.cma *~)
(cd types; rm -f *.cmi *.cmo *.cma *~)
rm -f *.cmi *.cmo *.cma *~
.SUFFIXES: .ml .mli .cmo .cmi .cmx
.ml.cmo:
ocamlc -c -pp 'camlp4o pa_extend.cmo' -I +camlp4 $<
.ml.cmx:
ocamlopt -c $<
.mli.cmi:
ocamlc -c $<
# FORTPATH = /users/formel8/frisch/solaris/fort/fort
FORTPATH = /home/frisch/fort
FORTBIN = $(FORTPATH)/fort
FORTLIB = $(FORTPATH)
test: all.cma
$(FORTBIN) -I $(FORTLIB) all.cma test_fort.ml
atoms.cmo: sortedList.cmi atoms.cmi
atoms.cmx: sortedList.cmx atoms.cmi
boolean.cmo: recursive.cmi sortedList.cmi boolean.cmi
boolean.cmx: recursive.cmx sortedList.cmx boolean.cmi
intervals.cmo: intervals.cmi
intervals.cmx: intervals.cmi
patterns.cmo: sortedList.cmi sortedMap.cmi types.cmi patterns.cmi
patterns.cmx: sortedList.cmx sortedMap.cmx types.cmx patterns.cmi
recursive.cmo: recursive.cmi
recursive.cmx: recursive.cmi
sortedList.cmo: sortedList.cmi
sortedList.cmx: sortedList.cmi
sortedMap.cmo: sortedMap.cmi
sortedMap.cmx: sortedMap.cmi
location.cmo: location.cmi
strings.cmo: boolean.cmi recursive.cmi sortedMap.cmi strings.cmi
strings.cmx: boolean.cmx recursive.cmx sortedMap.cmx strings.cmi
syntax.cmo: location.cmi patterns.cmi sortedList.cmi types.cmi syntax.cmi
syntax.cmx: location.cmi patterns.cmx sortedList.cmx types.cmx syntax.cmi
test_fort.cmo: strings.cmi types.cmi
test_fort.cmx: strings.cmx types.cmx
test_types.cmo: strings.cmi types.cmi
test_types.cmx: strings.cmx types.cmx
types.cmo: atoms.cmi boolean.cmi intervals.cmi recursive.cmi sortedList.cmi \
strings.cmi types.cmi
types.cmx: atoms.cmx boolean.cmx intervals.cmx recursive.cmx sortedList.cmx \
strings.cmx types.cmi
patterns.cmi: sortedList.cmi types.cmi
syntax.cmi: patterns.cmi types.cmi
types.cmi: atoms.cmi boolean.cmi intervals.cmi strings.cmi
type expr = expr_descr located
and expr_descr = A | B of expr
type loc = int * int
exception Location of loc * exn
let noloc = (-1,-1)
type loc = int * int
exception Location of loc * exn
val noloc:loc
type t
type descr =
| Pair of t * t
| Record of (Types.label * t) list
| Atom of Types.atom
| Integer of int
| String of string
| Fun of unit (* TODO ... *)
val descr: t -> descr
open Types;;
open Fort;;
let recurs f =
let t = make () in
define t (f t);
internalize t
let recurs' f =
let t = make () in
define t (f t);
t
let cons d =
let t = make () in
define t d;
internalize t
let cons' d =
let t = make () in
define t d;
t
let list t = recurs (fun s -> cup (times t s) (atom 0));;
let square i j k l = times (cons (interval i j)) (cons (interval k l))
let int_list i j = descr (list (cons (interval i j)))
let int i = interval i i
let (---) = diff;;
let (=?) a b = expect_equal a b;;
exception NoException
let exn a x e =
try ignore (a x); raise NoException
with
| NoException -> fail "No exception"
| e' ->
if e' <> e then fail
(Printf.sprintf "Wrong exception: '%s' instead of '%s'"
(Printexc.to_string e')
(Printexc.to_string e)
)
let (??) a = expect_true a;;
expect_pass "Unique representation"
(fun () ->
let t1 = recurs (fun t -> times t t) in
let t2 = recurs (fun t -> times t1 t) in
let t3 = recurs (fun t -> arrow t t) in
let t4 = recurs (fun t -> times t (cons' (times t t))) in
let t5 = recurs (fun t -> cup (times t t) (times t t)) in
id t1 =? id t2;
id t1 =? id t4;
id t1 =? id t5;
?? (id t3 <> id t2);
);;
expect_pass "Interval"
(fun () ->
let t = int_list 1 2 --- int_list 1 1 in
Sample.get t =? Sample.Pair (Sample.Int 2, Sample.Atom 0);
Sample.get (interval 10 20) =? Sample.Int 10;
);;
expect_pass "Record"
(fun () ->
let r l o i j = record l o (cons (interval i j)) in
Sample.get (r 1 false 100 200) =? Sample.Record [(1, Sample.Int 100 )];
Sample.get (r 1 true 100 200) =? Sample.Record [];
Sample.get (r 1 false 100 200 --- r 1 false 100 150)
=? Sample.Record [(1, Sample.Int 151 )];
exn Sample.get (r 1 false 100 200 --- r 1 false 100 250) Not_found;
);;
expect_pass "Regular string expressions"
(fun () ->
let t = string (Strings.Star (Strings.Char 'a')) ---
string Strings.Eps ---
string (Strings.Char 'a')
in
is_empty t =? false;
Sample.get t =? Sample.String "aa";
);;
#load "all.cma";;
open Types;;
let recurs f =
let t = make () in
define t (f t);
internalize t
let cons d =
let t = make () in
define t d;
internalize t
let list t = recurs (fun s -> cup (times t s) (atom 0));;
let square i j k l = times (cons (interval i j)) (cons (interval k l))
let int_list i j = descr (list (cons (interval i j)))
let t1 = recurs (fun t -> times t t);;
let t2 = recurs (fun t -> cup (times t t) (interval 1 2));;
let t3 = recurs (fun t -> record 1 false t2);;
let t4 = recurs (fun t -> arrow t t);;
let t5 = recurs (fun t -> times t3 t4);;
let t6 = cons
(
diff
(square 1 2 1 2)
(cup (square 1 2 1 1) (square 1 1 1 2))
);;
let t7 = cons (diff (int_list 1 2) (int_list 1 1));;
Sample.get (descr t7);;
(*
open Syntax
let v = new_var ();;
let t = cons (Or (cons (Variable v), cons (Capture "x")));;
global v t;;
*)
let t8 = cons (diff (diff
(string (`Star (`Char (65,65))))
(string `Eps)
)
(string (`Char (65,65)))
);;
is_empty (descr t8);;
Sample.get (descr t8);;
let sample typ =
let s = Syntax.parse typ in
let t = Syntax.make_type s in
Types.Sample.get (Types.descr t);;
(* To fix:
let `Type t = Syntax.make (Syntax.parse "/ 'a'+ 'b'? 'c'+ /");;
let `Type t = Syntax.make (Syntax.parse "/ 'a'+ 'b' /");;
let `Type t = Syntax.make (Syntax.parse "/ 'a'+ 'b'? 'c'+ | 'd'+ /");;
Sample.get t;;
*)
sample "'a where 'a = (`X,'a) | (`X,`Y)";;
- Define a 'widening functions' (types -> types) such two
equivalent types become physically equal
type 'a t = Finite of 'a list | Cofinite of 'a list
let empty = Finite []
let full = Cofinite []
let atom x = Finite [x]
let cup s t =
match (s,t) with
| (Finite s, Finite t) -> Finite (SortedList.cup s t)
| (Finite s, Cofinite t) -> Cofinite (SortedList.diff t s)
| (Cofinite s, Finite t) -> Cofinite (SortedList.diff s t)
| (Cofinite s, Cofinite t) -> Cofinite (SortedList.cap s t)
let cap s t =
match (s,t) with
| (Finite s, Finite t) -> Finite (SortedList.cap s t)
| (Finite s, Cofinite t) -> Finite (SortedList.diff s t)
| (Cofinite s, Finite t) -> Finite (SortedList.diff t s)
| (Cofinite s, Cofinite t) -> Cofinite (SortedList.cup s t)
let diff s t =
match (s,t) with
| (Finite s, Cofinite t) -> Finite (SortedList.cap s t)
| (Finite s, Finite t) -> Finite (SortedList.diff s t)
| (Cofinite s, Cofinite t) -> Finite (SortedList.diff t s)
| (Cofinite s, Finite t) -> Cofinite (SortedList.cup s t)
let contains x = function
| Finite s -> SortedList.mem s x
| Cofinite s -> not (SortedList.mem s x)
let is_empty = function
| Finite [] -> true
| _ -> false
let sample except = function
| Finite (x :: _) -> x
| Cofinite l -> except l
| Finite [] -> raise Not_found
let print any f = function
| Finite l -> List.map (fun x ppf -> f ppf x) l
| Cofinite [] ->
[ fun ppf -> Format.fprintf ppf "%s" any ]
| Cofinite [h] ->
[ fun ppf -> Format.fprintf ppf "@[%s - %a@]" any f h ]
| Cofinite (h::t) ->
[ fun ppf ->
Format.fprintf ppf "@[%s - (" any;
f ppf h;
List.iter (fun x -> Format.fprintf ppf " |@ %a" f x) t;
Format.fprintf ppf ")@]" ]
type 'a t (* = Finite of 'a list | Cofinite of 'a list *)
val empty : 'a t
val full : 'a t
val cup : 'a t -> 'a t -> 'a t
val cap : 'a t -> 'a t -> 'a t
val diff : 'a t -> 'a t -> 'a t
val atom : 'a -> 'a t
val contains : 'a -> 'a t -> bool
val is_empty : 'a t -> bool
val sample : ('a list -> 'a) -> 'a t -> 'a
val print : string -> (Format.formatter -> 'a -> unit) -> 'a t ->
(Format.formatter -> unit) list
type 'a t = ('a list * 'a list) list
let empty = [ ]
let full = [ ([],[]) ]
let atom x = [ ([x],[]) ]
let may_remove (p1,n1) (p2,n2) =
(SortedList.subset p2 p1) && (SortedList.subset n2 n1)
let cup t s =
if t == s then t
else if (t == full) || (s == full) then full
else
let s=
List.filter (fun (p,n) -> not (List.exists (may_remove (p,n)) t)) s in
let t=
List.filter (fun (p,n) -> not (List.exists (may_remove (p,n)) s)) t in
SortedList.cup s t
let rec fold2_aux f a x = function
| [] -> x
| h :: t -> fold2_aux f a (f x a h) t
let rec fold2 f x l1 l2 =
match l1 with
| [] -> x
| h :: t -> fold2 f (fold2_aux f h x l2) t l2
let cap s t =
if s == t then s
else if s == full then t
else if t == full then s
else if (s == empty) || (t == empty) then empty
else
let (lines1,common,lines2) = SortedList.split s t in
let lines =
fold2
(fun lines (p1,n1) (p2,n2) ->
if (SortedList.disjoint p1 n2) && (SortedList.disjoint p2 n1)
then (SortedList.cup p1 p2, SortedList.cup n1 n2) :: lines
else lines)
[]
lines1
lines2
in
SortedList.cup common (SortedList.from_list lines)
let diff c1 c2 =
if c2 == full then empty
else if (c1 == empty) || (c2 == empty) then c1
else
let c1 = SortedList.diff c1 c2 in
let line (p,n) =
let acc = List.fold_left (fun acc a -> ([], [a]) :: acc) [] p in
let acc = List.fold_left (fun acc a -> ([a], []) :: acc) acc n in
SortedList.from_list acc
in
List.fold_left (fun c1 l -> cap c1 (line l)) c1 c2
let rec map f t =
let lines =
List.fold_left
(fun lines (p,n) ->
let p = SortedList.map f p and n = SortedList.map f n in
if (SortedList.disjoint p n) then (p,n) :: lines else lines)
[]
t
in
SortedList.from_list lines
let equal_list e l1 l2 =
if List.length l1 <> List.length l2 then raise Recursive.NotEqual;
List.iter2 e l1 l2
let equal_line e (p1,n1) (p2,n2) =
equal_list e p1 p2;
equal_list e n1 n2
let equal e a b =
equal_list (equal_line e) a b
let print any f =
List.map
(function
(p1::p,n) ->
(fun ppf ->
Format.fprintf ppf "@[%a" f p1;
List.iter (fun x -> Format.fprintf ppf " &@ %a" f x) p;
List.iter (fun x -> Format.fprintf ppf " -@ %a" f x) n;
Format.fprintf ppf "@]";
)
| ([],[]) ->
(fun ppf -> Format.fprintf ppf "%s" any)
| ([],[n]) ->
(fun ppf -> Format.fprintf ppf "@[%s - %a@]" any f n)
| ([],n1::n) ->
(fun ppf ->
Format.fprintf ppf "@[%s" any;
List.iter (fun x -> Format.fprintf ppf " -@ %a" f x) n;
Format.fprintf ppf "@]";
)
)
let check b =
SortedList.check b;
List.iter
(fun (p,n) ->
SortedList.check p;
SortedList.check n;
assert (SortedList.disjoint p n)
)
b
(* Implementation of boolean combination in disjunctive normal form (dnf).
A dnf is a disjunction of lines, each line consisting of a
conjunction of atoms and negations of atoms.
A line is coded as a pair (p,n) where p collects atoms and n
the negated atoms. p and n are disjoint and sorted lists without duplicates
(w.r.t Pervasives.compare).
A dnf is coded as a sorted list of lines without duplicated
(w.r.t Pervasives.compare).
*)
type 'a t = ('a SortedList.t * 'a SortedList.t) SortedList.t
val empty : 'a t
val full : 'a t
val cup : 'a t -> 'a t -> 'a t
val cap : 'a t -> 'a t -> 'a t
val diff : 'a t -> 'a t -> 'a t
val atom : 'a -> 'a t
val map : ('a -> 'b) -> 'a t -> 'b t
val equal: ('a -> 'b -> unit) -> 'a t -> 'b t -> unit
val print: string -> (Format.formatter -> 'a -> unit) -> 'a t ->
(Format.formatter -> unit) list
val check: 'a t -> unit
type t = (int*int) list
let empty = []
let full = [min_int,max_int]
let atom (a,b) =
if a<=b then [a,b] else empty
let rec add l ((a,b) as i) = match l with
| [] ->
[i]
| ((a1,_) :: _) as l when (a1<>min_int) && (b < (pred a1)) ->
i::l
| ((a1,b1) as i' :: l') when (b1<>max_int) && (a > (succ b1)) ->
i'::(add l' i)
| (a1,b1) :: l' ->
add l' (min a a1, max b b1)
let rec neg start l = match l with
| [] -> [start,max_int]
| (a,b) :: l' when a<>min_int ->
if b = max_int then [start,pred a] else
(start, pred a) :: (neg (succ b) l')
| (_,b) :: l' ->
if b = max_int then [] else
(neg (succ b) l')
let neg l = neg min_int l
let cup i1 i2 =
List.fold_left add i1 i2
let cap i1 i2 =
neg (cup (neg i1) (neg i2))
let diff i1 i2 =
neg (cup (neg i1) i2)
let is_empty i =
i = [] (* representation unique ! *)
let contains n =
List.exists (fun (a,b) -> (n>=a) && (n<=b))
let sample = function
| (i,j) :: _ -> i
| _ -> raise Not_found
let print =
List.map
(fun (a,b) ->
if a = b
then fun ppf -> Format.fprintf ppf "%i" a
else fun ppf -> Format.fprintf ppf "%i--%i" a b
)
(* Combinaisons booléennes d'intervalles d'entiers;
elle sont representées comme des réunions disjointes d'intervalles,
sous la forme de listes de couples (ai,bi) tq ai<=bi, (bi)+1<a(i+1)
Note: il y a representation unique
*)
type t = (int*int) list
val empty : t
val full : t
val cup : t -> t -> t
val cap : t -> t -> t
val diff : t -> t -> t
val atom : int*int -> t
val is_empty : t -> bool
val contains : int -> t -> bool
val sample : t -> int
val print : t -> (Format.formatter -> unit) list
This diff is collapsed.
type capture = string
type fv = capture SortedList.t
exception IllFormedCup of fv * fv
exception IllFormedCap of fv * fv
(* Pattern algebra *)
type descr
type node
val make: fv -> node
val define: node -> descr -> unit
val constr : Types.node -> descr
val cup : descr -> descr -> descr
val cap : descr -> descr -> descr
val times : node -> node -> descr
val record : Types.label -> node -> descr
val capture : capture -> descr
val constant: capture -> Types.const -> descr
val id: node -> int
val descr: node -> descr
val fv : node -> fv
(* Pattern matching: static semantics *)
val accept : node -> Types.node
val filter : Types.descr -> node -> (capture,Types.node) SortedMap.t
(* Pattern matching: compilation *)
module NF : sig
type nf
val nf : descr -> nf
val show : Format.formatter -> Types.descr -> nf list -> unit
val get : int -> Types.descr * nf list
end
(* $Id: recursive.ml,v 1.1.1.1 2002/10/10 09:11:23 cvscast Exp $ *)
exception NotEqual
exception Incomplete
module type S =
sig
type 'a t
val map: ('a -> 'b) -> ('a t -> 'b t)
val equal: ('a -> 'a -> unit) -> ('a t -> 'a t -> unit)
val iter: ('a -> unit) -> ('a t -> unit)
val hash: ('a -> int) -> ('a t -> int)
val deep: int
end
module Make(X : S) =
struct
type state = Undefined | Defined | Hashed | Intern
(* Two values of this type have either different id or the
same fields (but they are not necessarily == if they have the same id).