- | [x1; x2] -> let o = std o in out_txt2 o n x1 x2
- | _ -> assert false
- in
- {arity_p = arity_p; arity_s = arity_s; body = body; txt_out = txt_out}
-
-let false_fun b =
- let s = if b then "false" else "empty" in
- arity0 s U.mql_false
-
-let true_fun = arity0 "true" U.mql_true
-
-let not_fun =
- let aux r = if r = U.mql_false then U.mql_true else U.mql_false in
- arity1 "!" aux
-
-let count_fun =
- let aux r = [string_of_int (List.length r), []] in
- arity1 "#" aux
-
-let peek_fun =
- let aux = function [] -> [] | hd :: _ -> [hd] in
- arity1 "peek" aux
-
-let diff_fun = arity2 "diff" U.mql_diff
-
-let xor_fun = arity2 "xor" U.xor
-
-let sub_fun = arity2 "sub" U.set_sub
-
-let meet_fun = arity2 "meet" U.set_meet
-
-let eq_fun = arity2 "==" U.set_eq
-
-let le_fun =
- let le v1 v2 =
- if int_of_set v1 <= int_of_set v2 then U.mql_true else U.mql_false
- in
- arity2 "<=" le
-
-let lt_fun =
- let lt v1 v2 =
- if int_of_set v1 < int_of_set v2 then U.mql_true else U.mql_false
- in
- arity2 "<" lt
-
-let stat_fun =
- let arity_p = Const 0 in
- let arity_s = Const 1 in
- let body e o _ _ = function
- | [x] ->
- let t = P.start_time () in
- let r = (e.eval x) in
- let s = P.stop_time t in
- o.out (Printf.sprintf "Stat: %s,%i\n" s (List.length r));
- r
- | _ -> assert false
- in
- let txt_out o _ = function
- | [x] -> let o = std o in o.s_out "stat "; o.s_query x
- | _ -> assert false
- in
- {arity_p = arity_p; arity_s = arity_s; body = body; txt_out = txt_out}
-
-let log_fun xml src =
- let log_src e o x =
- let t = P.start_time () in o.s_query x;
- let s = P.stop_time t in
- if C.set e.conn C.Stat then o.s_out (Printf.sprintf "Log source: %s\n" s);
- e.eval x
- in
- let log_res e o x =
- let s = e.eval x in
- let t = P.start_time () in o.s_result s;
- let r = P.stop_time t in
- if C.set e.conn C.Stat then o.s_out (Printf.sprintf "Log: %s\n" r); s
- in
- let txt_log o =
- if xml then o.s_out "xml ";
- if src then o.s_out "source "
- in
- let arity_p = Const 0 in
- let arity_s = Const 1 in
- let body e o _ _ = function
- | [x] -> let o = std o in if src then log_src e o x else log_res e o x
- | _ -> assert false
- in
- let txt_out o _ = function
- | [x] -> let o = std o in o.s_out "log "; txt_log o; o.s_query x
- | _ -> assert false
- in
- {arity_p = arity_p; arity_s = arity_s; body = body; txt_out = txt_out}
-
-let render_fun =
- let arity_p = Const 0 in
- let arity_s = Const 1 in
- let body e o _ _ = function
- | [x] ->
- let rs = ref "" in
- let out s = rs := ! rs ^ s in
- o.result out " " (e.eval x);
- [! rs, []]
- | _ -> assert false
- in
- let txt_out o _ = function
- | [x] -> let o = std o in o.s_out "render "; o.s_query x
- | _ -> assert false
- in
- {arity_p = arity_p; arity_s = arity_s; body = body; txt_out = txt_out}
-
-let read_fun =
- let arity_p = Const 0 in
- let arity_s = Const 1 in
- let body e o i _ = function
- | [x] ->
- let aux av =
- let ich = open_in (fst av) in
- let r = i.result_in (Lexing.from_channel ich) in
- close_in ich; r
- in
- U.mql_iter aux (e.eval x)
- | _ -> assert false
- in
- let txt_out o _ = function
- | [x] -> let o = std o in o.s_out "read "; o.s_query x
- | _ -> assert false
- in
- {arity_p = arity_p; arity_s = arity_s; body = body; txt_out = txt_out}
-
-let align_fun =
- let aux l (v, g) =
- let c = String.length v in
- if c < l then [(String.make (l - c) ' ' ^ v), g] else [v, g]
- in
- let arity_p = Const 0 in
- let arity_s = Const 2 in
- let body e _ _ _ = function
- | [y; x] ->
- let l = int_of_set (e.eval y) in
- U.mql_iter (aux l) (e.eval x)
- | _ -> assert false
- in
- let txt_out o _ = function
- | [y; x] ->