1 (* Copyright (C) 2000, HELM Team.
3 * This file is part of HELM, an Hypertextual, Electronic
4 * Library of Mathematics, developed at the Computer Science
5 * Department, University of Bologna, Italy.
7 * HELM is free software; you can redistribute it and/or
8 * modify it under the terms of the GNU General Public License
9 * as published by the Free Software Foundation; either version 2
10 * of the License, or (at your option) any later version.
12 * HELM is distributed in the hope that it will be useful,
13 * but WITHOUT ANY WARRANTY; without even the implied warranty of
14 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
15 * GNU General Public License for more details.
17 * You should have received a copy of the GNU General Public License
18 * along with HELM; if not, write to the Free Software
19 * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
22 * For details, see the HELM World-Wide-Web page,
23 * http://cs.unibo.it/helm/.
26 (* AUTOR: Ferruccio Guidi <fguidi@cs.unibo.it>
33 (* external function specification ******************************************)
35 type arity_t = Const of int
39 type eval_spec = {eval : M.query -> M.result;
43 type text_out_spec = {out : string -> unit;
45 path : (string -> unit) -> M.path -> unit;
46 query : (string -> unit) -> string -> M.query -> unit;
47 result : (string -> unit) -> string -> M.result -> unit
50 type text_in_spec = {result_in : Lexing.lexbuf -> M.result}
52 type fun_spec = {arity_p : arity_t;
54 body : eval_spec -> text_out_spec -> text_in_spec ->
55 M.path list -> M.query list -> M.result;
56 txt_out : text_out_spec ->
57 M.path list -> M.query list -> unit
60 type gen_spec = {arity : arity_t;
61 code : eval_spec -> M.query list -> M.query
64 exception ArityError of M.path * arity_t * int
66 exception NameError of M.path
68 exception NumberError of M.result
70 type std_text_out_spec = {s_out : string -> unit;
71 s_path : M.path -> unit;
72 s_query : M.query -> unit;
73 s_result : M.result -> unit
76 let check_arity p i = function
77 | Const k when i = k -> ()
78 | Positive when i > 0 -> ()
80 | a -> raise (ArityError (p, a, i))
82 (* external functions implementation ****************************************)
85 {s_out = o.out; s_path = o.path o.out;
86 s_query = o.query o.out o.sep; s_result = o.result o.out o.sep
89 let out_txt2 o n x1 x2 =
90 o.s_out "(" ; o.s_query x1; o.s_out (" " ^ n ^ " "); o.s_query x2; o.s_out ")"
93 if p <> [] then begin o.s_path p; o.s_out " " end;
94 o.s_out "{"; P.flat_list o.s_out o.s_query ", " xl; o.s_out "}"
96 let out_txt_full o p pl xl =
97 o.s_path p; o.s_out " {"; P.flat_list o.s_out o.s_path ", " pl; o.s_out "} {";
98 P.flat_list o.s_out o.s_query ", " xl; o.s_out "}"
100 let fun_arity0 p n r =
101 let arity_p = Const 0 in
102 let arity_s = Const 0 in
103 let body _ _ _ _ _ = r in
105 if n = "" then out_txt_full (std o) p [] [] else (std o).s_out n
107 {arity_p = arity_p; arity_s = arity_s; body = body; txt_out = txt_out}
109 let fun_arity1 p n f =
110 let arity_p = Const 0 in
111 let arity_s = Const 1 in
112 let body e _ _ _ = function
113 | [x] -> f (e.eval x)
116 let txt_out o _ = function
119 if n = "" then out_txt_full o p [] [x] else
120 begin o.s_out (n ^ " "); o.s_query x end
123 {arity_p = arity_p; arity_s = arity_s; body = body; txt_out = txt_out}
125 let fun_arity2 p n f =
126 let arity_p = Const 0 in
127 let arity_s = Const 2 in
128 let body e _ _ _ = function
129 | [x1; x2] -> f (e.eval x1) (e.eval x2)
132 let txt_out o _ = function
135 if n = "" then out_txt_full o p [] [x1; x2] else out_txt2 o n x1 x2
138 {arity_p = arity_p; arity_s = arity_s; body = body; txt_out = txt_out}
140 (* external functions interface *********************************************)
142 let funs = Hashtbl.create 11
144 let fun_register path spec = Hashtbl.add funs path spec
146 let fun_get_spec path =
147 try Hashtbl.find funs path
148 with Not_found -> raise (NameError path)
150 let fun_arity p m n =
151 check_arity p m (fun_get_spec p).arity_p;
152 check_arity p n (fun_get_spec p).arity_s
154 let fun_eval e o i p pl xl = (fun_get_spec p).body e o i pl xl
156 let fun_txt_out o p pl xl =
157 try (fun_get_spec p).txt_out o pl xl
158 with NameError q when q = p -> out_txt_full (std o) p pl xl
160 (* generator functions implementation ***************************************)
162 (* generator functions interface ********************************************)
164 let gens = Hashtbl.create 11
166 let gen_register path spec = Hashtbl.add gens path spec
168 let gen_get_spec path =
169 try Hashtbl.find gens path
170 with Not_found -> raise (NameError path)
172 let gen_arity p n = check_arity p n (gen_get_spec p).arity
174 let gen_eval e p xl = (gen_get_spec p).code e xl