Commit 5a560c38 authored by Pietro Abate's avatar Pietro Abate

[r2002-10-10 15:02:36 by cvscast] Empty log message

Original author: cvscast
Date: 2002-10-10 15:02:36+00:00
parent ed4544a6
PARSER = parser/location.cmo
PARSER = parser/location.cmo parser/ast.cmo parser/parser.cmo
TYPING = typing/parse_pat.cmo typing/typed.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
types/patterns.cmo
DIRS = parser types
DIRS = parser typing types
OBJECTS = $(PARSER) $(TYPES)
DEPEND = parser/*.ml parser/*.mli types/*.ml types/*.mli
OBJECTS = $(TYPES) $(PARSER) $(TYPING)
DEPEND = parser/*.ml parser/*.mli typing/*.ml typing/*.mli types/*.ml types/*.mli
INCLUDES = -I +camlp4 -I parser -I types
SYNTAX_PARSER = -pp 'camlp4o pa_extend.cmo'
......@@ -19,14 +21,15 @@ all.cma: $(OBJECTS)
compute_depend:
@echo "Computing dependencies ..."
ocamldep $(SYNTAX_PARSER) $(DEPEND) > depend
ocamldep $(INCLUDES) $(SYNTAX_PARSER) $(DEPEND) > depend
run_top: all.cma
ocaml $(INCLUDES) all.cma
ledit ocaml $(INCLUDES) all.cma
clean:
(cd parser; rm -f *.cmi *.cmo *.cma *~)
(cd types; rm -f *.cmi *.cmo *.cma *~)
(cd typing; rm -f *.cmi *.cmo *.cma *~)
rm -f *.cmi *.cmo *.cma *~
.SUFFIXES: .ml .mli .cmo .cmi .cmx
......
parser/ast.cmo: parser/location.cmi types/patterns.cmi types/types.cmi
parser/ast.cmx: parser/location.cmx types/patterns.cmx types/types.cmx
parser/location.cmo: parser/location.cmi
parser/location.cmx: parser/location.cmi
types/atoms.cmo: types/atoms.cmi
types/atoms.cmx: types/atoms.cmi
types/boolean.cmo: types/boolean.cmi
types/boolean.cmx: types/boolean.cmi
parser/parser.cmo: parser/ast.cmo parser/location.cmi types/types.cmi \
parser/parser.cmi
parser/parser.cmx: parser/ast.cmx parser/location.cmx types/types.cmx \
parser/parser.cmi
parser/parser.cmi: parser/ast.cmo
typing/parse_pat.cmo: parser/ast.cmo parser/location.cmi types/patterns.cmi \
types/sortedList.cmi types/types.cmi typing/parse_pat.cmi
typing/parse_pat.cmx: parser/ast.cmx parser/location.cmx types/patterns.cmx \
types/sortedList.cmx types/types.cmx typing/parse_pat.cmi
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/parse_pat.cmi: parser/ast.cmo types/patterns.cmi types/types.cmi
types/atoms.cmo: types/sortedList.cmi types/atoms.cmi
types/atoms.cmx: types/sortedList.cmx types/atoms.cmi
types/boolean.cmo: types/recursive.cmi types/sortedList.cmi types/boolean.cmi
types/boolean.cmx: types/recursive.cmx types/sortedList.cmx types/boolean.cmi
types/intervals.cmo: types/intervals.cmi
types/intervals.cmx: types/intervals.cmi
types/patterns.cmo: types/patterns.cmi
types/patterns.cmx: types/patterns.cmi
types/patterns.cmo: types/sortedList.cmi types/sortedMap.cmi types/types.cmi \
types/patterns.cmi
types/patterns.cmx: types/sortedList.cmx types/sortedMap.cmx types/types.cmx \
types/patterns.cmi
types/recursive.cmo: types/recursive.cmi
types/recursive.cmx: types/recursive.cmi
types/sortedList.cmo: types/sortedList.cmi
types/sortedList.cmx: types/sortedList.cmi
types/sortedMap.cmo: types/sortedMap.cmi
types/sortedMap.cmx: types/sortedMap.cmi
types/strings.cmo: types/strings.cmi
types/strings.cmx: types/strings.cmi
types/syntax.cmo: types/syntax.cmi
types/syntax.cmx: types/syntax.cmi
types/types.cmo: types/types.cmi
types/types.cmx: types/types.cmi
types/strings.cmo: types/boolean.cmi types/intervals.cmi types/recursive.cmi \
types/strings.cmi
types/strings.cmx: types/boolean.cmx types/intervals.cmx types/recursive.cmx \
types/strings.cmi
types/type_bool.cmo: types/boolean.cmi types/recursive.cmi
types/type_bool.cmx: types/boolean.cmx types/recursive.cmx
types/types.cmo: types/atoms.cmi types/boolean.cmi types/intervals.cmi \
types/recursive.cmi types/sortedList.cmi types/sortedMap.cmi \
types/strings.cmi types/types.cmi
types/types.cmx: types/atoms.cmx types/boolean.cmx types/intervals.cmx \
types/recursive.cmx types/sortedList.cmx types/sortedMap.cmx \
types/strings.cmx types/types.cmi
types/boolean.cmi: types/sortedList.cmi
types/patterns.cmi: types/sortedList.cmi types/sortedMap.cmi types/types.cmi
types/sortedMap.cmi: types/sortedList.cmi
types/syntax.cmi: types/patterns.cmi types/types.cmi
types/types.cmi: types/sortedMap.cmi types/strings.cmi
type expr = expr_descr located
and expr_descr = A | B of expr
(* Abstract syntax as produced by the parsed *)
open Location
type pprog = pmodule_item list
and pmodule_item = pmodule_item' located
and pmodule_item' =
| TypeDecl of string * ppat
| PatDecl of string * ppat
| FunDecl of abstr
| LetDecl of ppat * pexpr
| EvalStatement of pexpr
| Debug of string * ([`Pat of ppat | `Expr of pexpr] list)
and pexpr = pexpr' located
and pexpr' =
(* CDuce is a Lambda-calculus ... *)
| Var of string
| Apply of pexpr * pexpr
| Abstraction of abstr
(* Data constructors *)
| Cst of Types.const
| Pair of pexpr * pexpr
| RecordLitt of (Types.label * pexpr) list
(* Data destructors *)
| Op of op * pexpr
| Match of pexpr * branches
| Map of pexpr * branches
and abstr = {
fun_name : string option;
fun_iface : (ppat * ppat) list;
fun_body : branches
}
and branches = (ppat * pexpr) list
and op = string
(* A common syntactic class for patterns and types *)
and ppat = ppat' located
and ppat' =
| PatVar of string
| Recurs of ppat * (string * ppat) list
| Internal of Types.descr
| Or of ppat * ppat
| And of ppat * ppat
| Diff of ppat * ppat
| Prod of ppat * ppat
| Arrow of ppat * ppat
| Record of Types.label * bool * ppat
| Capture of Patterns.capture
| Constant of Patterns.capture * Types.const
| Regexp of regexp * ppat
and regexp =
| Epsilon
| Elem of ppat
| Seq of regexp * regexp
| Alt of regexp * regexp
| Star of regexp
| WeakStar of regexp
| SeqCapture of Patterns.capture * regexp
......@@ -2,3 +2,11 @@ type loc = int * int
exception Location of loc * exn
let noloc = (-1,-1)
type 'a located = { loc : loc; descr : 'a }
type expr = A | B of expr located
let rec recurs f x = f (recurs f) x.loc x.descr
let mk loc x = { loc = loc; descr = x }
......@@ -2,3 +2,8 @@ type loc = int * int
exception Location of loc * exn
val noloc:loc
type 'a located = { loc : loc; descr : 'a }
val recurs: (('a located -> 'b) -> loc -> 'a -> 'b) -> ('a located -> 'b)
val mk: loc -> 'a -> 'a located
open Location
open Ast
module P = struct
let gram = Grammar.create (Plexer.make ())
let expr = Grammar.Entry.create gram "expression"
let pat = Grammar.Entry.create gram "type/pattern expression"
let regexp = Grammar.Entry.create gram "type/pattern regexp"
let const = Grammar.Entry.create gram "scalar constant"
let atom_nil = Types.mk_atom "nil"
let rec multi_prod loc = function
| [ x ] -> x
| x :: l -> mk loc (Prod (x, multi_prod loc l))
| [] -> assert false
let rec tuple loc = function
| [ x ] -> x
| x :: l -> mk loc (Pair (x, tuple loc l))
| [] -> assert false
EXTEND
GLOBAL: expr pat regexp const;
expr: [
"top" RIGHTA
[ "match"; e = SELF; "with"; b = branches -> mk loc (Match (e,b))
| "map"; e = SELF; "with"; b = branches -> mk loc (Map (e,b))
| "fun"; f = OPT LIDENT; "("; a = LIST1 arrow SEP ";"; ")";
b = branches ->
mk loc (Abstraction { fun_name = f; fun_iface = a; fun_body = b })
| (p,e1) = let_binding; "in"; e2 = expr LEVEL "top"->
mk loc (Match (e1,[p,e2]))
]
|
[ e1 = expr; e2 = expr -> mk loc (Apply (e1,e2))
]
| "no_appl"
[ c = const -> mk loc (Cst c)
| "("; l = LIST1 expr SEP ","; ")" -> tuple loc l
| "["; l = LIST0 expr LEVEL "no_appl"; "]" ->
tuple loc (l @ [mk noloc (Cst (Types.Atom atom_nil))])
| "["; l = LIST0 expr LEVEL "no_appl"; ";"; e = expr; "]" ->
tuple loc (l @ [e])
| "<"; t = expr_tag_spec; a = expr_attrib_spec; ">"; c = expr ->
tuple loc [t;a;c]
| "{"; r = [ expr_record_spec | -> mk loc (RecordLitt []) ]; "}" -> r
| a = LIDENT -> mk loc (Var a)
]
];
let_binding: [
[ "let"; p = pat; "="; e = expr -> (p,e)
| "let"; "fun"; f = LIDENT; "("; a = LIST0 arrow SEP ";"; ")";
b = branches ->
let p = mk loc (Capture f) in
let abst = { fun_name = Some f; fun_iface = a; fun_body = b } in
let e = mk loc (Abstraction abst) in
(p,e)
]
];
arrow: [
[ t1 = pat LEVEL "prod"; "->"; t2 = pat -> (t1,t2)]
];
branches: [
[ OPT "|"; l = LIST1 branch SEP "|" ; OPT "end" -> l ]
];
branch: [
[ p = pat; "->"; e = expr -> (p,e) ]
];
regexp: [
[ x = regexp; "|"; y = regexp -> Alt (x,y) ]
| [ x = regexp; y = regexp -> Seq (x,y) ]
| [ a = LIDENT; "::"; x = regexp -> SeqCapture (a,x) ]
| [ x = regexp; "*" -> Star x
| x = regexp; "*?" -> WeakStar x
| x = regexp; "+" -> Seq (x, Star x)
| x = regexp; "+?" -> Seq (x, WeakStar x)
| x = regexp; "?" -> Alt (x, Epsilon)
| x = regexp; "??" -> Alt (Epsilon, x) ]
| [ "("; x = regexp; ")" -> x
| e = pat LEVEL "simple" -> Elem e
]
];
pat: [
[ x = pat; "where";
b = LIST1 [ a = UIDENT; "="; y = pat -> (a,y)] SEP "and"
-> mk loc (Recurs (x,b)) ]
| RIGHTA [ x = pat; "->"; y = pat -> mk loc (Arrow (x,y)) ]
| [ x = pat; "|"; y = pat -> mk loc (Or (x,y)) ]
| "simple" [ x = pat; "&"; y = pat -> mk loc (And (x,y))
| x = pat; "-"; y = pat -> mk loc (Diff (x,y)) ]
|
[ "{"; r = record_spec; "}" -> r
| UIDENT "Any" -> mk loc (Internal Types.any)
| LIDENT "_" -> mk loc (Internal Types.any)
| a = LIDENT -> mk loc (Capture a)
| "("; a = LIDENT; ":="; c = const; ")" -> mk loc (Constant (a,c))
| a = UIDENT -> mk loc (PatVar a)
| i = INT ; "--"; j = INT ->
let i = int_of_string i and j = int_of_string j in
mk loc (Internal (Types.interval i j))
| c = const -> mk loc (Internal (Types.constant c))
| "("; l = LIST1 pat SEP ","; ")" -> multi_prod loc l
| "["; r = [ r = regexp -> r | -> Epsilon ];
q = [ ";"; q = pat -> q
| -> mk noloc (Internal (Types.atom atom_nil)) ];
"]" -> mk loc (Regexp (r,q))
| "<"; t = tag_spec; a = attrib_spec; ">"; c = pat ->
multi_prod loc [t;a;c]
]
];
record_spec:
[ [ r = LIST0 [ l = [LIDENT | UIDENT];
o = ["=?" -> true | "=" -> false];
x = pat ->
mk loc (Record (Types.label l,o,x))
] SEP ";" ->
match r with
| [] -> mk noloc (Internal Types.Record.any)
| h::t -> List.fold_left (fun t1 t2 -> mk noloc (And (t1,t2))) h t
] ];
const:
[
[ i = INT -> Types.Integer (int_of_string i)
| x = STRING -> Types.String (Token.eval_string x)
| "`"; a = [LIDENT | UIDENT] -> Types.Atom (Types.mk_atom a) ]
];
tag_spec:
[
[ a = [LIDENT | UIDENT] ->
mk loc (Internal (Types.atom (Types.mk_atom a))) ]
| [ t = pat -> t ]
];
attrib_spec:
[ [ r = record_spec -> r | "("; t = pat; ")" -> t ] ];
expr_record_spec:
[ [ r = LIST1
[ l = [LIDENT | UIDENT]; "="; x = expr -> (Types.label l,x) ]
SEP ";" ->
mk loc (RecordLitt r)
] ];
expr_tag_spec:
[
[ a = [LIDENT | UIDENT] ->
mk loc (Cst (Types.Atom (Types.mk_atom a))) ]
| [ e = expr LEVEL "no_appl" -> e ]
];
expr_attrib_spec:
[ [ r = expr_record_spec -> r ]
| [ e = expr LEVEL "no_appl" -> e
| -> mk loc (RecordLitt [])
]
];
END
end
let pat_or_typ s = Grammar.Entry.parse P.pat (Stream.of_string s)
let expr s = Grammar.Entry.parse P.expr (Stream.of_string s)
val pat_or_typ : string -> Ast.ppat
val expr : string -> Ast.pexpr
This diff is collapsed.
(* Transform the abstract syntax of types and patterns into
the internal form *)
open Location
open Ast
exception ParsingPattern of string
let raise_loc loc msg = raise (Location loc (ParsingPattern msg))
(* Internal representation as a graph (desugar recursive types and regexp),
to compute freevars, etc... *)
type ti = {
id : int;
mutable loc' : loc;
mutable fv : string SortedList.t option;
mutable descr': descr;
mutable type_node: Types.node option;
mutable pat_node: Patterns.node option
}
and descr =
[ `Alias of ti
| `Type of Types.descr
| `Or of ti * ti
| `And of ti * ti
| `Diff of ti * ti
| `Times of ti * ti
| `Arrow of ti * ti
| `Record of Types.label * bool * ti
| `Capture of Patterns.capture
| `Constant of Patterns.capture * Types.const
]
module S = struct type t = string let compare = compare end
module StringMap = Map.Make(S)
module StringSet = Set.Make(S)
let mk' =
let counter = ref 0 in
fun () ->
incr counter;
let rec x = { id = !counter; loc' = noloc; fv = None; descr' = `Alias x;
type_node = None; pat_node = None } in
x
let cons loc d =
let x = mk' () in
x.loc' <- loc;
x.descr' <- d;
x
(* Note:
Compilation of Regexp is implemented as a ``rewriting'' of
the parsed syntax, in order to be able to print its result
(for debugging for instance)
It would be possible (and a little more efficient) to produce
directly ti nodes.
*)
module Regexp = struct
let memo = Hashtbl.create 51
let defs = ref []
let name =
let c = ref 0 in
fun () ->
incr c;
"#" ^ (string_of_int !c)
let rec seq_vars accu = function
| Epsilon | Elem _ -> accu
| Seq (r1,r2) | Alt (r1,r2) -> seq_vars (seq_vars accu r1) r2
| Star r | WeakStar r -> seq_vars accu r
| SeqCapture (v,r) -> seq_vars (StringSet.add v accu) r
let rec propagate vars = function
| Epsilon -> `Epsilon
| Elem x -> `Elem (vars,x)
| Seq (r1,r2) -> `Seq (propagate vars r1,propagate vars r2)
| Alt (r1,r2) -> `Alt (propagate vars r1, propagate vars r2)
| Star r -> `Star (propagate vars r)
| WeakStar r -> `WeakStar (propagate vars r)
| SeqCapture (v,x) -> propagate (StringSet.add v vars) x
let cup r1 r2 =
match (r1,r2) with
| (_, `Empty) -> r1
| (`Empty, _) -> r2
| (`Res t1, `Res t2) -> `Res (mk noloc (Or (t1,t2)))
let rec compile fin e seq : [`Res of Ast.ppat | `Empty] =
if List.mem seq e then `Empty
else
let e = seq :: e in
match seq with
| [] ->
`Res fin
| `Epsilon :: rest ->
compile fin e rest
| `Elem (vars,x) :: rest ->
let capt = StringSet.fold
(fun v t -> mk noloc (And (t, (mk noloc (Capture v)))))
vars x in
`Res (mk noloc (Prod (capt, guard_compile fin rest)))
| `Seq (r1,r2) :: rest ->
compile fin e (r1 :: r2 :: rest)
| `Alt (r1,r2) :: rest ->
cup (compile fin e (r1::rest)) (compile fin e (r2::rest))
| `Star r :: rest -> cup (compile fin e (r::seq)) (compile fin e rest)
| `WeakStar r :: rest -> cup (compile fin e rest) (compile fin e (r::seq))
and guard_compile fin seq =
try Hashtbl.find memo seq
with
Not_found ->
let n = name () in
let v = mk noloc (PatVar n) in
Hashtbl.add memo seq v;
let d = compile fin [] seq in
(match d with
| `Empty -> assert false
| `Res d -> defs := (n,d) :: !defs);
v
let atom_nil = Types.mk_atom "nil"
let constant_nil v t =
mk noloc (And (t, (mk noloc (Constant (v, Types.Atom atom_nil)))))
let compile regexp queue : ppat =
let vars = seq_vars StringSet.empty regexp in
let fin = StringSet.fold constant_nil vars queue in
let n = guard_compile fin [propagate StringSet.empty regexp] in
Hashtbl.clear memo;
let d = !defs in
defs := [];
mk noloc (Recurs (n,d))
end
let compile_regexp = Regexp.compile
let rec compile env { loc = loc; descr = d } : ti =
match (d : Ast.ppat') with
| PatVar s ->
(try StringMap.find s env
with Not_found -> raise_loc loc "Undefined variable"
)
| Recurs (t, b) ->
let b = List.map (fun (v,t) -> (v,t,mk' ())) b in
let env =
List.fold_left (fun env (v,t,x) -> StringMap.add v x env) env b in
List.iter (fun (v,t,x) -> x.descr' <- `Alias (compile env t)) b;
compile env t
| Regexp (r,q) -> compile env (Regexp.compile r q)
| Internal t -> cons loc (`Type t)
| Or (t1,t2) -> cons loc (`Or (compile env t1, compile env t2))
| And (t1,t2) -> cons loc (`And (compile env t1, compile env t2))
| Diff (t1,t2) -> cons loc (`Diff (compile env t1, compile env t2))
| Prod (t1,t2) -> cons loc (`Times (compile env t1, compile env t2))
| Arrow (t1,t2) -> cons loc (`Arrow (compile env t1, compile env t2))
| Record (l,o,t) -> cons loc (`Record (l,o,compile env t))
| Constant (x,v) -> cons loc (`Constant (x,v))
| Capture x -> cons loc (`Capture x)
let rec comp_fv seen s =
match s.fv with
| Some l -> l
| None ->
let l =
match s.descr' with
| `Alias x -> if List.memq s seen then [] else comp_fv (s :: seen) x
| `Or (s1,s2)
| `And (s1,s2)
| `Diff (s1,s2)
| `Times (s1,s2)
| `Arrow (s1,s2) -> SortedList.cup (comp_fv seen s1) (comp_fv seen s2)
| `Record (l,opt,s) -> comp_fv seen s
| `Type _ -> []
| `Capture x
| `Constant (x,_) -> [x]
in
if seen = [] then s.fv <- Some l;
l
let fv = comp_fv []
let rec typ seen s : Types.descr =
match s.descr' with
| `Alias x ->
if List.memq s seen then failwith "Unguarded recursion in this type"
else typ (s :: seen) x
| `Type t -> t
| `Or (s1,s2) -> Types.cup (typ seen s1) (typ seen s2)
| `And (s1,s2) -> Types.cap (typ seen s1) (typ seen s2)
| `Diff (s1,s2) -> Types.diff (typ seen s1) (typ seen s2)
| `Times (s1,s2) -> Types.times (typ_node s1) (typ_node s2)
| `Arrow (s1,s2) -> Types.arrow (typ_node s1) (typ_node s2)
| `Record (l,o,s) -> Types.record l o (typ_node s)
| _ -> failwith "This is not a type"
and typ_node s : Types.node =
match s.type_node with
| Some x -> x
| None ->
let x = Types.make () in
s.type_node <- Some x;
let t = typ [] s in
Types.define x t;
x
let type_node s = Types.internalize (typ_node s)
let rec pat seen s : Patterns.descr =
if fv s = [] then Patterns.constr (type_node s) else
match s.descr' with
| `Alias x ->
if List.memq s seen then failwith "Unguarded recursion in this pattern"
else pat (s :: seen) x
| `Or (s1,s2) -> Patterns.cup (pat seen s1) (pat seen s2)
| `And (s1,s2) -> Patterns.cap (pat seen s1) (pat seen s2)
| `Diff (s1,s2) when fv s2 = [] ->
let s2 = Types.cons (Types.neg (Types.descr (type_node s2)))in
Patterns.cap (pat seen s1) (Patterns.constr s2)
| `Times (s1,s2) -> Patterns.times (pat_node s1) (pat_node s2)
| `Record (l,false,s) -> Patterns.record l (pat_node s)
| `Capture x -> Patterns.capture x
| `Constant (x,c) -> Patterns.constant x c
| _ -> failwith "This is not a pattern"
and pat_node s : Patterns.node =
match s.pat_node with
| Some x -> x
| None ->
let x = Patterns.make (fv s) in
s.pat_node <- Some x;
let t = pat [] s in
Patterns.define x t;
x
let typ e =
let e = compile StringMap.empty e in
if fv e = [] then type_node e else failwith "This is not a type"
let pat e =
let e = compile StringMap.empty e in
pat_n