|
Packit |
bd2e5d |
(***********************************************************************)
|
|
Packit |
bd2e5d |
(* *)
|
|
Packit |
bd2e5d |
(* MLTk, Tcl/Tk interface of OCaml *)
|
|
Packit |
bd2e5d |
(* *)
|
|
Packit |
bd2e5d |
(* Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis *)
|
|
Packit |
bd2e5d |
(* projet Cristal, INRIA Rocquencourt *)
|
|
Packit |
bd2e5d |
(* Jacques Garrigue, Kyoto University RIMS *)
|
|
Packit |
bd2e5d |
(* *)
|
|
Packit |
bd2e5d |
(* Copyright 2002 Institut National de Recherche en Informatique et *)
|
|
Packit |
bd2e5d |
(* en Automatique and Kyoto University. All rights reserved. *)
|
|
Packit |
bd2e5d |
(* This file is distributed under the terms of the GNU Library *)
|
|
Packit |
bd2e5d |
(* General Public License, with the special exception on linking *)
|
|
Packit |
bd2e5d |
(* described in file LICENSE found in the OCaml source tree. *)
|
|
Packit |
bd2e5d |
(* *)
|
|
Packit |
bd2e5d |
(***********************************************************************)
|
|
Packit |
bd2e5d |
|
|
Packit |
bd2e5d |
(* $Id$ *)
|
|
Packit |
bd2e5d |
|
|
Packit |
bd2e5d |
open StdLabels
|
|
Packit |
bd2e5d |
|
|
Packit |
bd2e5d |
(* Write .mli for widgets *)
|
|
Packit |
bd2e5d |
|
|
Packit |
bd2e5d |
open Tables
|
|
Packit |
bd2e5d |
open Compile
|
|
Packit |
bd2e5d |
|
|
Packit |
bd2e5d |
let labltk_write_create_p ~w wname =
|
|
Packit |
bd2e5d |
w "val create :\n ?name:string ->\n";
|
|
Packit |
bd2e5d |
begin
|
|
Packit |
bd2e5d |
try
|
|
Packit |
bd2e5d |
let option = Hashtbl.find types_table "options" in
|
|
Packit |
bd2e5d |
let classdefs = List.assoc wname option.subtypes in
|
|
Packit |
bd2e5d |
let tklabels = List.map ~f:gettklabel classdefs in
|
|
Packit |
bd2e5d |
let l = List.map classdefs ~f:
|
|
Packit |
bd2e5d |
begin fun fc ->
|
|
Packit |
bd2e5d |
begin let p = gettklabel fc in
|
|
Packit |
bd2e5d |
if count ~item:p tklabels > 1 then small fc.var_name else p
|
|
Packit |
bd2e5d |
end,
|
|
Packit |
bd2e5d |
fc.template
|
|
Packit |
bd2e5d |
end in
|
|
Packit |
bd2e5d |
w (String.concat ~sep:" ->\n"
|
|
Packit |
bd2e5d |
(List.map l ~f:
|
|
Packit |
bd2e5d |
begin fun (s, t) ->
|
|
Packit |
bd2e5d |
" ?" ^ s ^ ":"
|
|
Packit |
bd2e5d |
^(ppMLtype
|
|
Packit |
bd2e5d |
(match types_of_template t with
|
|
Packit |
bd2e5d |
| [t] -> labeloff t ~at:"write_create_p"
|
|
Packit |
bd2e5d |
| [] -> fatal_error "multiple"
|
|
Packit |
bd2e5d |
| l -> Product (List.map ~f:(labeloff ~at:"write_create_p") l)))
|
|
Packit |
bd2e5d |
end))
|
|
Packit |
bd2e5d |
with Not_found -> fatal_error "in write_create_p"
|
|
Packit |
bd2e5d |
end;
|
|
Packit |
bd2e5d |
w (" ->\n 'a widget -> " ^ caml_name wname ^ " widget\n");
|
|
Packit |
bd2e5d |
w "(** [create ?name parent options...] creates a new widget with\n";
|
|
Packit |
bd2e5d |
w " parent [parent] and new patch component [name], if specified. *)\n\n"
|
|
Packit |
bd2e5d |
;;
|
|
Packit |
bd2e5d |
|
|
Packit |
bd2e5d |
let camltk_write_create_p ~w wname =
|
|
Packit |
bd2e5d |
w "val create : ?name: string -> widget -> options list -> widget \n";
|
|
Packit |
bd2e5d |
w "(** [create ?name parent options] creates a new widget with\n";
|
|
Packit |
bd2e5d |
w " parent [parent] and new patch component [name] if specified.\n";
|
|
Packit |
bd2e5d |
w " Options are restricted to the widget class subset, and checked\n";
|
|
Packit |
bd2e5d |
w " dynamically. *)\n\n"
|
|
Packit |
bd2e5d |
;;
|
|
Packit |
bd2e5d |
|
|
Packit |
bd2e5d |
let camltk_write_named_create_p ~w wname =
|
|
Packit |
bd2e5d |
w "val create_named : widget -> string -> options list -> widget \n";
|
|
Packit |
bd2e5d |
w "(** [create_named parent name options] creates a new widget with\n";
|
|
Packit |
bd2e5d |
w " parent [parent] and new patch component [name].\n";
|
|
Packit |
bd2e5d |
w " This function is now obsolete and unified with [create]. *)\n\n";
|
|
Packit |
bd2e5d |
;;
|
|
Packit |
bd2e5d |
|
|
Packit |
bd2e5d |
(* Unsafe: write special comment *)
|
|
Packit |
bd2e5d |
let labltk_write_function_type ~w def =
|
|
Packit |
bd2e5d |
if not def.safe then w "(* unsafe *)\n";
|
|
Packit |
bd2e5d |
w "val "; w def.ml_name; w " : ";
|
|
Packit |
bd2e5d |
let us, ls, os =
|
|
Packit |
bd2e5d |
let tys = types_of_template def.template in
|
|
Packit |
bd2e5d |
let rec replace_args ~u ~l ~o = function
|
|
Packit |
bd2e5d |
[] -> u, l, o
|
|
Packit |
bd2e5d |
| (_, List(Subtype _) as x)::ls ->
|
|
Packit |
bd2e5d |
replace_args ~u ~l ~o:(x::o) ls
|
|
Packit |
bd2e5d |
| ("", _ as x)::ls ->
|
|
Packit |
bd2e5d |
replace_args ~u:(x::u) ~l ~o ls
|
|
Packit |
bd2e5d |
| (p, _ as x)::ls when p.[0] = '?' ->
|
|
Packit |
bd2e5d |
replace_args ~u ~l ~o:(x::o) ls
|
|
Packit |
bd2e5d |
| x::ls ->
|
|
Packit |
bd2e5d |
replace_args ~u ~l:(x::l) ~o ls
|
|
Packit |
bd2e5d |
in
|
|
Packit |
bd2e5d |
replace_args ~u:[] ~l:[] ~o:[] (List.rev tys)
|
|
Packit |
bd2e5d |
in
|
|
Packit |
bd2e5d |
let counter = ref 0 in
|
|
Packit |
bd2e5d |
let params =
|
|
Packit |
bd2e5d |
if os = [] then us @ ls else ls @ os @ us in
|
|
Packit |
bd2e5d |
List.iter params ~f:
|
|
Packit |
bd2e5d |
begin fun (l, t) ->
|
|
Packit |
bd2e5d |
if l <> "" then w (l ^ ":");
|
|
Packit |
bd2e5d |
w (ppMLtype t ~counter);
|
|
Packit |
bd2e5d |
w " -> "
|
|
Packit |
bd2e5d |
end;
|
|
Packit |
bd2e5d |
if (os <> [] || ls = []) && us = [] then w "unit -> ";
|
|
Packit |
bd2e5d |
w (ppMLtype ~any:true ~return:true def.result); (* RETURN TYPE !!! *)
|
|
Packit |
bd2e5d |
w " \n";
|
|
Packit |
bd2e5d |
(* w "(* tk invocation: "; w (doc_of_template def.template); w " *)"; *)
|
|
Packit |
bd2e5d |
if def.safe then w "\n"
|
|
Packit |
bd2e5d |
else w "\n(* /unsafe *)\n"
|
|
Packit |
bd2e5d |
|
|
Packit |
bd2e5d |
let camltk_write_function_type ~w def =
|
|
Packit |
bd2e5d |
if not def.safe then w "(* unsafe *)\n";
|
|
Packit |
bd2e5d |
w "val "; w def.ml_name; w " : ";
|
|
Packit |
bd2e5d |
let us, os =
|
|
Packit |
bd2e5d |
let tys = types_of_template def.template in
|
|
Packit |
bd2e5d |
let rec replace_args ~u ~o = function
|
|
Packit |
bd2e5d |
[] -> u, o
|
|
Packit |
bd2e5d |
| ("", _ as x)::ls ->
|
|
Packit |
bd2e5d |
replace_args ~u:(x::u) ~o ls
|
|
Packit |
bd2e5d |
| (p, _ as x)::ls when p.[0] = '?' ->
|
|
Packit |
bd2e5d |
replace_args ~u ~o:(x::o) ls
|
|
Packit |
bd2e5d |
| x::ls ->
|
|
Packit |
bd2e5d |
replace_args ~u:(x::u) ~o ls
|
|
Packit |
bd2e5d |
in
|
|
Packit |
bd2e5d |
replace_args ~u:[] ~o:[] (List.rev tys)
|
|
Packit |
bd2e5d |
in
|
|
Packit |
bd2e5d |
let counter = ref 0 in
|
|
Packit |
bd2e5d |
let params =
|
|
Packit |
bd2e5d |
if os = [] then us else os @ us in
|
|
Packit |
bd2e5d |
List.iter params ~f:
|
|
Packit |
bd2e5d |
begin fun (l, t) ->
|
|
Packit |
bd2e5d |
if l <> "" then if l.[0] = '?' then w (l ^ ":");
|
|
Packit |
bd2e5d |
w (ppMLtype t ~counter);
|
|
Packit |
bd2e5d |
w " -> "
|
|
Packit |
bd2e5d |
end;
|
|
Packit |
bd2e5d |
if us = [] then w "unit -> ";
|
|
Packit |
bd2e5d |
w (ppMLtype ~any:true ~return:true def.result); (* RETURN TYPE !!! *)
|
|
Packit |
bd2e5d |
w " \n";
|
|
Packit |
bd2e5d |
(* w "(* tk invocation: "; w (doc_of_template def.template); w " *)"; *)
|
|
Packit |
bd2e5d |
if def.safe then w "\n"
|
|
Packit |
bd2e5d |
else w "\n(* /unsafe *)\n"
|
|
Packit |
bd2e5d |
|
|
Packit |
bd2e5d |
(*
|
|
Packit |
bd2e5d |
if not def.safe then w "(* unsafe *)\n";
|
|
Packit |
bd2e5d |
w "val "; w def.ml_name; w " : ";
|
|
Packit |
bd2e5d |
let tys = types_of_template def.template in
|
|
Packit |
bd2e5d |
let counter = ref 0 in
|
|
Packit |
bd2e5d |
let have_normal_arg = ref false in
|
|
Packit |
bd2e5d |
List.iter tys ~f:
|
|
Packit |
bd2e5d |
begin fun (l, t) ->
|
|
Packit |
bd2e5d |
if l <> "" then
|
|
Packit |
bd2e5d |
if l.[0] = '?' then w (l^":")
|
|
Packit |
bd2e5d |
else begin
|
|
Packit |
bd2e5d |
have_normal_arg := true;
|
|
Packit |
bd2e5d |
w (" (* " ^ l ^ ":*)")
|
|
Packit |
bd2e5d |
end
|
|
Packit |
bd2e5d |
else have_normal_arg := true;
|
|
Packit |
bd2e5d |
w (ppMLtype t ~counter);
|
|
Packit |
bd2e5d |
w " -> "
|
|
Packit |
bd2e5d |
end;
|
|
Packit |
bd2e5d |
if not !have_normal_arg then w "unit -> ";
|
|
Packit |
bd2e5d |
w (ppMLtype ~any:true ~return:true def.result); (* RETURN TYPE !!! *)
|
|
Packit |
bd2e5d |
w " \n";
|
|
Packit |
bd2e5d |
if def.safe then w "\n"
|
|
Packit |
bd2e5d |
else w "\n(* /unsafe *)\n"
|
|
Packit |
bd2e5d |
*)
|
|
Packit |
bd2e5d |
|
|
Packit |
bd2e5d |
let write_function_type ~w def =
|
|
Packit |
bd2e5d |
if !Flags.camltk then camltk_write_function_type ~w def
|
|
Packit |
bd2e5d |
else labltk_write_function_type ~w def
|
|
Packit |
bd2e5d |
|
|
Packit |
bd2e5d |
let write_external_type ~w def =
|
|
Packit |
bd2e5d |
match def.template with
|
|
Packit |
bd2e5d |
| StringArg fname ->
|
|
Packit |
bd2e5d |
begin try
|
|
Packit |
bd2e5d |
let realname = find_in_path !search_path (fname ^ ".mli") in
|
|
Packit |
bd2e5d |
let ic = open_in_bin realname in
|
|
Packit |
bd2e5d |
try
|
|
Packit |
bd2e5d |
let code_list = Ppparse.parse_channel ic in
|
|
Packit |
bd2e5d |
close_in ic;
|
|
Packit |
bd2e5d |
if not def.safe then w "(* unsafe *)\n";
|
|
Packit |
bd2e5d |
List.iter (Ppexec.exec (fun _ -> ()) w)
|
|
Packit |
bd2e5d |
(if !Flags.camltk then
|
|
Packit |
bd2e5d |
Code.Define "CAMLTK" :: code_list else code_list );
|
|
Packit |
bd2e5d |
if def.safe then w "\n\n"
|
|
Packit |
bd2e5d |
else w "\n(* /unsafe *)\n\n"
|
|
Packit |
bd2e5d |
with
|
|
Packit |
bd2e5d |
| Ppparse.Error s ->
|
|
Packit |
bd2e5d |
close_in ic;
|
|
Packit |
bd2e5d |
raise (Compiler_Error (Printf.sprintf "Preprocess error: %s" s))
|
|
Packit |
bd2e5d |
with
|
|
Packit |
bd2e5d |
| Not_found ->
|
|
Packit |
bd2e5d |
raise (Compiler_Error ("can't find external file: " ^ fname))
|
|
Packit |
bd2e5d |
end
|
|
Packit |
bd2e5d |
| _ -> raise (Compiler_Error "invalid external definition")
|