Skip to content

GitLab

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

[r2005-03-06 11:58:34 by afrisch] Integrate select-from-where 

Original author: afrisch
Date: 2005-03-06 11:58:34+00:00
parent 1b8969be
Hide whitespace changes
Inline Side-by-side
Makefile.distrib
View file @ e7f8c3b1
......@@ -203,14 +203,17 @@ ifeq ($(EXPAT), true)
endif
CQL_OBJECTS= query/query_aggregates.cmo query/query.cmo query/query_parse.cmo
CQL_OBJECTS_RUN = query/query_run.cmo
#CQL_OBJECTS= query/query_aggregates.cmo query/query.cmo query/query_parse.cmo
#CQL_OBJECTS_RUN = query/query_run.cmo
CQL_OBJECTS=
CQL_OBJECTS_RUN=
OBJECTS += $(CQL_OBJECTS)
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
OBJECTS += $(CQL_OBJECTS_RUN) driver/run.cmo
OBJECTS += $(CQL_OBJECTS_RUN)
OBJECTS += driver/run.cmo
CDUCE = $(OBJECTS) driver/start.cmo
DTD2CDUCE = tools/dtd2cduce.cmo
......
parser/ast.ml
View file @ e7f8c3b1
......@@ -76,6 +76,8 @@ and pexpr =
| Ref of pexpr * ppat
(* CQL *)
| SelectFW of pexpr * (ppat * pexpr) list * pexpr list
and label = U.t
......
parser/parser.ml
View file @ e7f8c3b1
......@@ -117,6 +117,11 @@ let logical_not e = if_then_else e cst_false cst_true
let apply_op2_noloc op e1 e2 = Apply (Apply (Var (ident op), e1), e2)
let apply_op2 loc op e1 e2 = exp loc (apply_op2_noloc op e1 e2)
let set_ref e1 e2 = Apply (Dot (e1, U.mk "set", []), e2)
let get_ref e = Apply (Dot (e, U.mk "get", []), cst_nil)
let let_in e1 p e2 = Match (e1, [p,e2])
let seq e1 e2 = let_in e1 pat_nil e2
let concat e1 e2 = apply_op2_noloc "@" e1 e2
EXTEND
GLOBAL: top_phrases prog expr pat regexp keyword;
......@@ -134,7 +139,7 @@ EXTEND
if f then [ mk loc (FunDecl e) ] else
[ mk loc (LetDecl (p,e)) ]
| (_,p,e1) = let_binding; "in"; e2 = expr LEVEL "top"->
[ mk loc (EvalStatement (exp loc (Match (e1,[p,e2])))) ]
[ mk loc (EvalStatement (exp loc (let_in e1 p e2))) ]
| "type"; x = located_ident; "="; t = pat -> [ mk loc (TypeDecl (x,t)) ]
| "using"; name = IDENT; "="; cu = [ IDENT | STRING2 ] ->
[ mk loc (Using (U.mk name, U.mk cu)) ]
......@@ -212,7 +217,7 @@ EXTEND
| "transform" | "fun" | "in"
| "let" | "type" | "debug" | "include"
| "and" | "validate" | "schema" | "namespace" | "ref" | "alias"
| "not" | "as" | "where"
| "not" | "as" | "where" | "select" | "from"
]
-> a
]
......@@ -234,10 +239,14 @@ EXTEND
exp loc (Transform (e,b))
| "validate"; e = SELF; "with"; (schema, typ) = schema_ref ->
exp loc (Validate (e, schema, typ))
| "select"; e = SELF; "from";
l = LIST1 [ x = pat ; "in"; e = expr -> (x,e)] SEP "," ;
cond = [ "where"; c = LIST1 [ expr ] SEP "and" -> c
| -> [] ] -> exp loc (SelectFW (e,l,cond))
| "fun"; (f,a,b) = fun_decl ->
exp loc (Abstraction { fun_name = f; fun_iface = a; fun_body = b })
| (_,p,e1) = let_binding; "in"; e2 = expr LEVEL "top"->
exp loc (Match (e1,[p,e2]))
exp loc (let_in e1 p e2)
| (name,ns) = namespace_binding; "in"; e2 = expr LEVEL "top" ->
exp loc (NamespaceIn (name, ns, e2))
| e = expr; ":"; p = pat ->
......@@ -245,14 +254,13 @@ EXTEND
| e = expr; ":"; "?"; p = pat ->
exp loc (Check (e,p))
| e1 = expr; ";"; e2 = expr ->
exp loc (Match (e1, [pat_nil,e2]))
exp loc (seq e1 e2)
| "ref"; p = pat; e = expr ->
exp loc (Ref (e,p))
| "not"; e = expr -> exp loc (logical_not e)
]
|
[ e1 = expr; ":="; e2 = expr ->
exp loc (Apply (Dot (e1, U.mk "set", []), e2))
[ e1 = expr; ":="; e2 = expr -> exp loc (set_ref e1 e2)
]
|
[ e1 = expr; op = ["=" | "<=" | "<<" | ">>" | ">=" ]; e2 = expr ->
......@@ -273,14 +281,44 @@ EXTEND
[ e1 = expr; op = ["*"]; e2 = expr -> apply_op2 loc op e1 e2
| e1 = expr; "&&"; e2 = expr -> exp loc (logical_and e1 e2)
| e = expr; op = "/"; p = pat LEVEL "simple" ->
(* transform e with <(Atom)>[($$$::t|_)*] -> [$$$] *)
let tag = mk loc (Internal (Types.atom (Atoms.any))) in
let att = mk loc (Internal Types.Record.any) in
let any = mk loc (Internal (Types.any)) in
let any = mk loc (Internal Types.any) in
let re = Star(Alt(SeqCapture(noloc,id_dummy,Elem p), Elem any)) in
let ct = mk loc (Regexp re) in
let p = mk loc (XmlT (tag, multi_prod loc [att;ct])) in
let b = (p, Var id_dummy) in
exp loc (Transform (e,[b]))
exp loc (Transform (e,[p, Var id_dummy]))
| e = expr; "/@"; a = [IDENT|keyword] ->
(* transform e with <(Atom) {a=$$$}>_ -> [$$$] *)
let tag = mk loc (Internal (Types.atom Atoms.any)) in
let any = mk loc (Internal Types.any) in
let att = mk loc (Record
(true, [(label a,
(mk loc (PatVar (None,id_dummy)),
None))])) in
let p = mk loc (XmlT (tag, multi_prod loc [att;any])) in
let t = (p, Pair (Var id_dummy,cst_nil)) in
exp loc (Transform (e,[t]))
| e = expr; "//" ; p = pat ->
(*
let $stack=ref [p*] [] in
let _ = xtransform e with $$$ & p -> $stack := !$stack @ $$$ in
!stack;;
*)
let stk = U.mk "$stack" in
let assign =
set_ref
(Var stk)
(concat (get_ref (Var stk)) (Pair (Var id_dummy,cst_nil))) in
let capt = mk loc (And (mk loc (PatVar (None,U.mk "$$$")),p)) in
let xt = Xtrans (e,[capt,assign]) in
let rf = Ref (cst_nil, mk loc (Regexp (Star(Elem p)))) in
let body =
let_in rf (mk loc (PatVar (None,stk)))
(let_in xt (mk loc (Internal Types.any)) (get_ref (Var stk)))
in
exp loc body
]
| [
e1 = SELF; IDENT "div"; e2 = expr -> apply_op2 loc "/" e1 e2
......@@ -307,7 +345,7 @@ EXTEND
match x with
| `String (loc,i,j,s) -> exp loc (String (i,j,s,q))
| `Elems ((loc,_),x) -> exp (loc,loc_end) (Pair(x,q))
| `Explode x -> apply_op2_noloc "@" x q
| `Explode x -> concat x q
) l e
in
exp loc l
......@@ -321,8 +359,7 @@ EXTEND
let s = U.mk s in
exp loc (String (U.start_index s, U.end_index s, s, cst_nil))
| a = IDENT -> exp loc (Var (ident a))
| "!"; e = expr ->
exp loc (Apply (Dot (e, U.mk "get", []), cst_nil))
| "!"; e = expr -> exp loc (get_ref e)
| i = INT -> exp loc (Integer (Intervals.V.mk i))
| "`"; a = tag -> a
| c = char -> exp loc (Char c)
......
query/query_parse.ml
View file @ e7f8c3b1
......@@ -50,44 +50,7 @@ EXTEND
if !Query.nooptim
then Query.select(tloc loc,fin,l)
else Query.selectOpt(tloc loc,Pair (e,cst_nil),l,condi)
|
e = expr; "/@";
a = [IDENT|keyword]-> (* projection sur 1 attribut *)
let tag = mk loc (Internal(Types.atom Atoms.any)) in
let any = mk loc (Internal(Types.any)) in
let att = mk loc (Record(true,[(label a,
(mk loc (PatVar(None,U.mk "$$$")),None))]))in
(*let ct= mk loc (Regexp(Elem any , any)) in *)
let p = mk loc(XmlT (tag,multi_prod loc[att;any])) in
let t =(p, Pair(Var id_dummy,cst_nil))
in exp loc (Transform (e,[t]))
| e = expr; "//" ; p = pat -> (* projections sur tous les descendants *)
let assign=
exp loc ( Apply (Dot (Var(U.mk"$stack"), U.mk"set",[]),
(op2 "@" (Apply(Dot(Var(U.mk"$stack"),U.mk"get",[]),cst_nil)) (Pair(Var(U.mk"$$$"),cst_nil)))))
in let branche=Pair(Var id_dummy,cst_nil)
in let branches= exp loc (Match(assign,[pat_nil,branche]))
in let xt=exp loc (Xtrans (e,[(mk loc(And(mk loc(PatVar(None,U.mk "$$$")),p))),branches]))
in let rf=exp loc(Ref(cst_nil,mk loc (Regexp
(Star(Elem p)))))
in exp loc(Match(rf,[mk loc(PatVar(None,U.mk"$stack")),
exp loc(Match(xt,
[mk loc(Internal Types.any),
exp loc (Apply(Dot(Var(U.mk"$stack"),U.mk"get",[]),cst_nil))]))
]))
(* equivalent as:
let $stack=ref [p*] []
in let _ = xtransform e with
$$$ & p -> $stack := [ !$stack @ $$$] ; [$$$]
in !stack;;
NB: order is inversed
*)
]
];
]];
cond:
[ [ a = expr ->
......
typing/typed.ml
View file @ e7f8c3b1
......@@ -66,16 +66,12 @@ and abstr = {
and let_decl = {
let_pat : tpat;
let_body : texpr;
mutable let_compiled :
(Patterns.Compile.dispatcher * (id * int) list) option
}
and branches = {
mutable br_typ : Types.t; (* Type of values that can flow to branches *)
br_accept : Types.t; (* Type accepted by all branches *)
br_branches: branch list;
mutable br_compiled : compiled_branches option;
}
and branch = {
br_loc : loc;
......@@ -84,32 +80,4 @@ and branch = {
br_pat : tpat;
br_body : texpr
}
and compiled_branches =
Patterns.Compile.dispatcher * texpr Patterns.Compile.rhs array
let dispatcher brs =
match brs.br_compiled with
| Some d -> d
| None ->
let aux b = b.br_pat, b.br_body in
let x = Patterns.Compile.make_branches
brs.br_typ
(List.map aux brs.br_branches) in
brs.br_compiled <- Some x;
x
let dispatcher_let_decl l =
match l.let_compiled with
| Some d -> d
| None ->
let comp = Patterns.Compile.make_branches
(Types.descr (Patterns.accept l.let_pat))
[ l.let_pat, () ] in
let x = match comp with
| (disp, [| Patterns.Compile.Match (l, ()) |]) -> (disp,l)
| _ -> assert false
in
l.let_compiled <- Some x;
x
typing/typer.ml
View file @ e7f8c3b1
......@@ -954,12 +954,23 @@ type branch = Branch of Typed.branch * branch list
let cur_branch : branch list ref = ref []
let exp loc fv e =
fv,
{ Typed.exp_loc = loc;
Typed.exp_typ = Types.empty;
Typed.exp_descr = e;
}
let exp' loc e =
{ Typed.exp_loc = loc; Typed.exp_typ = Types.empty; Typed.exp_descr = e; }
let exp loc fv e = fv, exp' loc e
let exp_nil = exp' noloc (Typed.Cst Sequence.nil_cst)
let pat_true =
let n = Patterns.make Fv.empty in
Patterns.define n (Patterns.constr Builtin_defs.true_type);
n
let pat_false =
let n = Patterns.make Fv.empty in
Patterns.define n (Patterns.constr Builtin_defs.false_type);
n
let ops = Hashtbl.create 13
let register_op op arity f = Hashtbl.add ops op (arity,f)
......@@ -1060,6 +1071,8 @@ let rec expr env loc = function
let (fv,e) = expr env loc e in
let uri = find_schema schema env in
exp loc fv (Typed.Validate (e, uri, qname env loc elt))
| SelectFW (e,from,where) ->
select_from_where env loc e from where
| Try (e,b) ->
let (fv1,e) = expr env loc e
and (fv2,b) = branches env b in
......@@ -1070,6 +1083,24 @@ let rec expr env loc = function
| Ref (e,t) ->
let (fv,e) = expr env loc e and t = typ env t in
exp loc fv (Typed.Ref (e,t))
and if_then_else loc cond yes no =
let b = {
Typed.br_typ = Types.empty;
Typed.br_branches = [
{ Typed.br_loc = yes.Typed.exp_loc;
Typed.br_used = false;
Typed.br_vars_empty = Fv.empty;
Typed.br_pat = pat_true;
Typed.br_body = yes };
{ Typed.br_loc = no.Typed.exp_loc;
Typed.br_used = false;
Typed.br_vars_empty = Fv.empty;
Typed.br_pat = pat_false;
Typed.br_body = no } ];
Typed.br_accept = Builtin_defs.bool;
} in
exp' loc (Typed.Match (cond,b))
and extern loc env s args =
let args = List.map (typ env) args in
......@@ -1096,26 +1127,6 @@ and var env loc s =
(try ignore (find_value id env)
with Not_found -> raise_loc loc (UnboundId (id, Env.mem id env.ids)));
exp loc (Fv.singleton id) (Typed.Var id)
(*
match Ns.split_qname s with
| "", id ->
let s = U.get_str id in
if String.contains s '.' then
extern loc env s []
else
let id = ident id in
(try ignore (find_value id env)
with Not_found -> raise_loc loc (UnboundId (id, Env.mem id env.ids)));
exp loc (Fv.singleton id) (Typed.Var id)
| cu, id ->
let cu = find_cu (U.mk cu) env in
let id = ident id in
let t =
try find_value_global cu id env
with Not_found ->
raise_loc loc (UnboundExtId (cu,id) ) in
exp loc Fv.empty (Typed.ExtVar (cu, id, t))
*)
and abstraction env loc a =
let iface =
......@@ -1154,11 +1165,11 @@ and branches env b =
let branch (p,e) =
let cur_br = !cur_branch in
cur_branch := [];
let p' = pat env p in
let fvp = Patterns.fv p' in
let env' = enter_values_dummy fvp env in
let (fv2,e) = expr env' noloc e in
let br_loc = merge_loc p.loc e.Typed.exp_loc in
let ploc = p.loc in
let p = pat env p in
let fvp = Patterns.fv p in
let (fv2,e) = expr (enter_values_dummy fvp env) noloc e in
let br_loc = merge_loc ploc e.Typed.exp_loc in
(match Fv.pick (Fv.diff fvp fv2) with
| None -> ()
| Some x ->
......@@ -1168,13 +1179,13 @@ and branches env b =
" is declared in the pattern but not used in the body of this branch. It might be a misspelled or undeclared type or name (if it isn't, use _ instead)."));
let fv2 = Fv.diff fv2 fvp in
fv := Fv.cup !fv fv2;
accept := Types.cup !accept (Types.descr (Patterns.accept p'));
accept := Types.cup !accept (Types.descr (Patterns.accept p));
let br =
{
Typed.br_loc = br_loc;
Typed.br_used = br_loc == noloc;
Typed.br_vars_empty = Patterns.fv p';
Typed.br_pat = p';
Typed.br_vars_empty = fvp;
Typed.br_pat = p;
Typed.br_body = e } in
cur_branch := Branch (br, !cur_branch) :: cur_br;
br in
......@@ -1184,16 +1195,63 @@ and branches env b =
Typed.br_typ = Types.empty;
Typed.br_branches = b;
Typed.br_accept = !accept;
Typed.br_compiled = None;
}
)
and select_from_where env loc e from where =
let env = ref env in
let all_fv = ref Fv.empty in
let bound_fv = ref Fv.empty in
let clause (p,e) =
let ploc = p.loc in
let p = pat !env p in
let fvp = Patterns.fv p in
let (fv2,e) = expr !env noloc e in
env := enter_values_dummy fvp !env;
all_fv := Fv.cup (Fv.diff fv2 !bound_fv) !all_fv;
bound_fv := Fv.cup fvp !bound_fv;
(ploc,p,fvp,e) in
let from = List.map clause from in
let where = List.map (expr !env noloc) where in
let put_cond rest (fv,cond) =
all_fv := Fv.cup (Fv.diff fv !bound_fv) !all_fv;
if_then_else loc cond rest exp_nil in
let aux (ploc,p,fvp,e) (where,rest) =
(* Put here the conditions that depends on variables in fvp *)
let (above,here) = List.partition (fun (v,_) -> Fv.disjoint v fvp) where in
(* if cond then ... else [] *)
let rest = List.fold_left put_cond rest here in
(* transform e with p -> ... *)
let b = {
Typed.br_typ = Types.empty;
Typed.br_branches = [
{ Typed.br_loc = ploc;
Typed.br_used = false;
Typed.br_vars_empty = fvp;
Typed.br_pat = p;
Typed.br_body = rest } ];
Typed.br_accept = Types.descr (Patterns.accept p);
} in
let br_loc = merge_loc ploc e.Typed.exp_loc in
(above,exp' br_loc (Typed.Transform (e, b)))
in
let (fv,e) = expr !env noloc e in
let (where,rest) = List.fold_right aux from (where,e) in
(* The remaining conditions are constant. Gives a warning for that. *)
(match where with
| (_,e) :: _ ->
warning e.Typed.exp_loc
"This 'where' condition does not depend on any captured variable"
| _ -> ());
let rest = List.fold_left put_cond rest where in
(Fv.cup !all_fv (Fv.diff fv !bound_fv)), rest
let expr env e = snd (expr env noloc e)
let let_decl env p e =
{ Typed.let_pat = pat env p;
Typed.let_body = expr env e;
Typed.let_compiled = None }
Typed.let_body = expr env e }
(* Hide global "typing/parsing" environment *)
......
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