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

Original author: cvscast
Date: 2002-10-10 15:02:36+00:00

Makefile

-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

depend

+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 

parser/ast.ml

-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
+ 

parser/location.ml

@@ -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 }

parser/location.mli

@@ -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

parser/parser.ml

+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)

parser/parser.mli

+val pat_or_typ : string -> Ast.ppat
+val expr : string -> Ast.pexpr

types/syntax.ml

-(** The common internal syntax for types and patterns **)
-open Location
-exception Located of int *  int * string
-
-let raise_loc (i,j) msg = raise (Located (i,j,msg))
-
-
-
-
-type 'a descr = 
-    [ `Type of Types.descr
-    | `Or of 'a * 'a
-    | `And of 'a * 'a
-    | `Diff of 'a * 'a
-    | `Times of 'a * 'a
-    | `Arrow of 'a * 'a
-    | `Record of Types.label * bool * 'a
-    | `Capture of Patterns.capture
-    | `Constant of Patterns.capture * Types.const
-    ]
-
-type t = loc *
-    [ `Variable of string
-    | `Recurs of t * (string * t) list
-    | `Regexp of regexp * t
-    | t descr
-    ]
-and regexp = 
-    [ `Eps
-    | `Elem of t
-    | `Seq of regexp * regexp
-    | `Alt of regexp * regexp
-    | `Star of regexp
-    | `WeakStar of regexp
-    | `Capture of Patterns.capture * regexp
-    ]
-
-type ti = { 
-  id : int; 
-  mutable loc : loc;
-  mutable fv : string SortedList.t option; 
-  mutable descr: [ `Alias of ti | ti descr ];
-  mutable type_node: Types.node option;
-  mutable pat_node: Patterns.node option
-}
-
-
-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
-
-
-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
-    | `Eps | `Elem _ -> accu
-    | `Seq (r1,r2) | `Alt (r1,r2) -> seq_vars (seq_vars accu r1) r2
-    | `Star r | `WeakStar r -> seq_vars accu r
-    | `Capture (v,r) -> seq_vars (StringSet.add v accu) r
-
-  let rec propagate vars = function
-    | `Eps -> `Eps
-    | `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)
-    | `Capture (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 ((noloc, `Or (t1,t2)))
-
-  let rec compile fin e seq = 
-    if List.mem seq e then `Empty
-    else 
-      let e = seq :: e in
-      match seq with
-	| [] ->
-	    `Res fin
-	| `Eps :: rest -> 
-	    compile fin e rest
-	| `Elem (vars,x) :: rest -> 
-	    let capt = StringSet.fold
-			 (fun v t -> (noloc, `And (t, (noloc, `Capture v))))
-			 vars x in
-	    `Res ((noloc, `Times (capt, guard_compile fin rest)))
-	| `Seq (r1,r2) :: rest -> 
-	    compile fin e (r1 :: r2 :: rest)
-	| `Alt (r1,r2) :: rest -> 
-	    let r1 = compile fin e (r1::rest) 
-	    and r2 = compile fin e (r2::rest) in
-	    cup r1 r2
-	| `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
-          Hashtbl.add memo seq (noloc, `Variable n);
-	  let d = compile fin [] seq in
-	  (match d with
-	     | `Empty -> assert false
-	     | `Res d -> defs := (n,d) :: !defs);
-          (noloc, `Variable n)
-
-  let atom_nil = Types.mk_atom "nil"
-  let constant_nil v t = 
-    (noloc, `And (t, (noloc, `Constant (v, Types.Atom atom_nil))))
-
-  let compile regexp queue : t =
-    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 := [];
-    (noloc, `Recurs (n,d))
-end
-
-let rec compile env ((loc,d) : t) : ti = match d with
-  | `Variable s -> 
-      (try StringMap.find s env
-       with Not_found -> raise_loc loc "Undefined variable"
-	 (*cons (Capture s)*)
-      )
-  | `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)
-  | `Type 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))
-  | `Times (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 compute_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 compute_fv (s :: seen) x
-	    | `Or (s1,s2) 
-	    | `And (s1,s2)
-	    | `Diff (s1,s2)
-	    | `Times (s1,s2)
-	    | `Arrow (s1,s2) -> 
-		SortedList.cup (compute_fv seen s1) (compute_fv seen s2)
-	    | `Record (l,opt,s) -> compute_fv seen s
-	    | `Type _ -> []
-	    | `Capture x
-	    | `Constant (x,_) -> [x]
-	in
-	if seen = [] then s.fv <- Some l;
-	l
-
-
-let fv s =
-  compute_fv [] s
-
-let rec type_descr seen s : Types.descr =
-  match s.descr with
-    | `Alias x ->
-	if List.memq s seen then failwith "Unguarded recursion in this type"
-	else type_descr (s :: seen) x
-    | `Type t -> 
-	t
-    | `Or (s1,s2) ->
-	Types.cup (type_descr seen s1) (type_descr seen s2)
-    | `And (s1,s2) -> 
-	Types.cap (type_descr seen s1) (type_descr seen s2)
-    | `Diff (s1,s2) ->
-	Types.diff (type_descr seen s1) (type_descr seen s2)
-    | `Times (s1,s2) ->
-	Types.times (type_node s1) (type_node s2)
-    | `Arrow (s1,s2) ->
-	Types.arrow (type_node s1) (type_node s2)
-    | `Record (l,o,s) ->
-	Types.record l o (type_node s)
-    | _ -> 
-	failwith "This is not a type"