[r2003-11-27 11:38:56 by afrisch] Factorisation + broutilles

Original author: afrisch
Date: 2003-11-27 11:38:57+00:00

Makefile.distrib

@@ -128,11 +128,12 @@ OBJECTS = \
  types/builtin.cmo driver/librarian.cmo driver/cduce.cmo
 
 CQL_OBJECTS= query/query.cmo query/query_parse.cmo 
+CQL_OBJECTS_RUN = query/query_run.cmo
 
 VALIDATE_OBJECTS := $(shell for o in $(OBJECTS); do echo $$o; if [ "$$o" = "schema/schema_parser.cmo" ]; then exit 0; fi; done)	# all objects until schema_parser.cmo
 
-CDUCE = $(OBJECTS) driver/run.cmo $(CQL_OBJECTS)
-WEBIFACE  = $(OBJECTS) driver/examples.cmo driver/webiface.cmo
+CDUCE = $(OBJECTS) $(CQL_OBJECTS) driver/run.cmo $(CQL_OBJECTS_RUN)
+WEBIFACE  = $(OBJECTS) $(CQL_OBJECTS) driver/examples.cmo driver/webiface.cmo
 DTD2CDUCE = tools/dtd2cduce.cmo
 
 ALL_OBJECTS = $(OBJECTS) $(CQL_OBJECTS) \

parser/ast.ml

@@ -118,3 +118,10 @@ and regexp =
   | SeqCapture of id * regexp
 
 
+let pat_true = mknoloc (Internal Builtin_defs.true_type)
+let pat_false = mknoloc (Internal Builtin_defs.false_type) 
+let cst_true = Const (Types.Atom Builtin_defs.true_atom)
+let cst_false = Const (Types.Atom Builtin_defs.false_atom)
+
+let cst_nil =  Const Sequence.nil_cst
+let pat_nil = mknoloc (Internal (Sequence.nil_type))

parser/parser.ml

@@ -14,11 +14,6 @@ let error (i,j) s = Location.raise_loc i j (Error s)
 
 let gram    = Grammar.gcreate Ulexer.lex
 
-let true_atom = Atoms.V.mk_ascii "true"
-let false_atom = Atoms.V.mk_ascii "false"
-let true_type = Types.atom (Atoms.atom true_atom)
-let false_type = Types.atom (Atoms.atom false_atom)
-
 let parse_ident = U.mk
 
 let id_dummy = ident (U.mk "$$$")
@@ -52,9 +47,6 @@ let tuple_queue =
 let char = mknoloc (Internal (Types.char Chars.any))
 let string_regexp = Star (Elem char)
 	       
-let cst_nil =  Const (Types.Atom (Atoms.V.mk_ascii "nil"))
-let pat_nil = mknoloc (Internal (Sequence.nil_type))
-		 
 let seq_of_string s =
   let s = Encodings.Utf8.mk s in
   let rec aux i j =
@@ -91,15 +83,12 @@ let is_fun_decl =
 	 | _ -> raise Stream.Failure
      )
 
-let pat_true = mknoloc (Internal true_type)
-let pat_false = mknoloc (Internal false_type) 
-let const_true = Const (Types.Atom (true_atom))
-let const_false = Const (Types.Atom (false_atom))
-
-let logical_and e1 e2 = Match (e1, [pat_true,e2; pat_false,const_false])
-let logical_or e1 e2 = Match (e1, [pat_true,const_true; pat_false,e2])
-let logical_not e = Match (e, [pat_true,const_false; pat_false,const_true])
-
+let if_then_else cond e1 e2 = Match (cond, [pat_true,e1; pat_false,e2])
+ 
+let logical_and e1 e2 = if_then_else e1 e2 cst_false
+let logical_or e1 e2 = if_then_else e1 cst_true e2
+let logical_not e = if_then_else e cst_false cst_true
+ 
 
 EXTEND
   GLOBAL: top_phrases prog expr pat regexp keyword;
@@ -219,9 +208,7 @@ EXTEND
     | "xtransform"; e = SELF; "with"; b = branches -> 
 	exp loc (Xtrans (e,b))
     | "if"; e = SELF; "then"; e1 = SELF; "else"; e2 = SELF ->
-	let p1 = mk loc (Internal true_type)
-	and p2 = mk loc (Internal false_type) in
-	exp loc (Match (e, [p1,e1; p2,e2]))
+	exp loc (if_then_else e e1 e2)
     | "transform"; e = SELF; "with"; b = branches -> 
 	exp loc (Transform (e,b))
     | "validate"; e = SELF; "with"; (kind, schema, typ) = schema_ref ->

parser/parser.mli

@@ -17,7 +17,10 @@ module Hook: sig
 end
 
 (* Helpers *)
+(* TODO: put this in Ast *)
 
 val logical_and: Ast.pexpr -> Ast.pexpr -> Ast.pexpr
 val logical_or: Ast.pexpr -> Ast.pexpr -> Ast.pexpr
 val logical_not: Ast.pexpr -> Ast.pexpr
+
+val if_then_else: Ast.pexpr -> Ast.pexpr -> Ast.pexpr -> Ast.pexpr

query/query.ml

@@ -7,23 +7,11 @@ open Ident
 
 let nooptim = ref false 
 
-let () = Run.specs := 
-      (  "--noquery-optim", Arg.Set nooptim,
-         " do not optimize queries " ) :: !Run.specs
 (********************************)
 
 
 let exp pos e = LocatedExpr (loc_of_pos pos,e)
 
-let cst_nil =  Const (Types.Atom (Atoms.V.mk_ascii "nil"))
-
-let true_atom = Atoms.V.mk_ascii "true"
-let false_atom = Atoms.V.mk_ascii "false"
-let true_type = Types.atom (Atoms.atom true_atom)
-let false_type = Types.atom (Atoms.atom false_atom)
-
-
-
 
 let ou (loc,e1,e2)= exp loc (Parser.logical_or e1 e2)
 let et (loc,e1,e2)= exp loc (Parser.logical_and e1 e2)
@@ -43,8 +31,8 @@ type 'a  boolFormula =
 
 let rec ast_of_bool(c,loc)=
 	match (c,loc) with
-	|(True,loc) -> (Const (Types.Atom (true_atom)))
-	|(False,loc) -> (Const (Types.Atom (false_atom)))
+	|(True,loc) -> cst_true
+	|(False,loc) -> cst_false
 	|(Varb(e),loc) -> e
 	|(Not(Varb(e)),loc) -> non(loc,e)
 	|(OuN([varb]),loc) -> ast_of_bool(varb,loc)
@@ -73,8 +61,8 @@ let rec string_of_ppat p =
              |PatVar(id) -> U.get_str ( id) 
 	     |Cst(Atom a) -> U.get_str a
 	     |Internal(descr) -> 
-	         if descr=true_type then "`true" 
-	         else if descr=false_type then "`false"
+	         if descr=Builtin_defs.true_type then "`true" 
+	         else if descr=Builtin_defs.false_type then "`false"
 		 else if Types.is_empty descr then "Empty"
                  else if Types.atom ( Atoms.any)=descr then "_" 
 		 else if Types.Record.any=descr then "_" 
@@ -525,8 +513,7 @@ let select2(loc,e,t) =
 	   match c with
 	   EtN[OuN[True]] -> e
 	   |True -> e
-	   |c -> exp loc(Match(ast_of_bool(c,loc),[mk loc (Internal true_type),e;
-	         mk loc (Internal false_type),cst_nil]))
+	   |c -> exp loc (Parser.if_then_else (ast_of_bool(c,loc)) e cst_nil)
 	in let rec saux loc e t = 
 	(match t with	
 	     [] -> exp loc (Pair(cst_nil,cst_nil))

query/query_parse.ml

@@ -10,13 +10,7 @@ open Query
 
 let exp pos e = LocatedExpr (loc_of_pos pos,e)
 
-let cst_nil =  Const (Types.Atom (Atoms.V.mk_ascii "nil"))
-
-let true_atom = Atoms.V.mk_ascii "true"
-let false_atom = Atoms.V.mk_ascii "false"
-let true_type = Types.atom (Atoms.atom true_atom)
-let false_type = Types.atom (Atoms.atom false_atom)
-
+let cst_nil =  Const Sequence.nil_cst
 
  
 EXTEND 
@@ -28,20 +22,18 @@ EXTEND
      "select"; e = expr;
      "from";l = LIST1 [ x= pat ; "in"; e = expr -> (x,e)] SEP "," ;
       z=OPT["where"  ; w = cond -> w]  -> 
-     let (condi,fin) =
-      match z with
-           Some w -> let ptrue = mk loc (Internal true_type)
-                    and pfalse = mk loc (Internal false_type)
-                   in (w,exp loc (Match (Query.ast_of_bool(w,loc), [ptrue,exp loc (Pair(e,cst_nil));
-                  pfalse,cst_nil])))
-         | None -> (True,exp loc(Pair(e,cst_nil)))
-     in let s= if !Query.nooptim 
-                then Query.select(loc,fin,l)
-      		else Query.selectOpt(loc,fin,l,condi)
-	 in s		
-
-      
-      
+	let (condi,fin) =
+	  match z with
+              Some w -> 
+                (w, exp loc 
+		   (Parser.if_then_else (Query.ast_of_bool(w,loc)) 
+		      (Pair (e,cst_nil)) 
+		      cst_nil))
+            | None -> (True, exp loc (Pair(e,cst_nil)))
+	in 
+	if !Query.nooptim 
+        then Query.select(loc,fin,l)
+      	else Query.selectOpt(loc,fin,l,condi)
    ] ];
    
   cond:

query/query_run.ml

+let () = Run.specs := 
+      (  "--noquery-optim", Arg.Set Query.nooptim,
+         " do not optimize queries " ) :: !Run.specs

types/sequence.ml

 let nil_atom = Atoms.V.mk_ascii "nil"
 let nil_type = Types.atom (Atoms.atom nil_atom)
 let nil_node = Types.cons nil_type
+let nil_cst  = Types.Atom nil_atom
 
 let decompose t =
   (Types.Atom.has_atom t nil_atom,

types/sequence.mli

 val nil_type: Types.t
 val nil_node: Types.Node.t
 val nil_atom: Atoms.V.t
+val nil_cst:  Types.Const.t
 val any: Types.t
 val seqseq: Types.t
 val string: Types.t