245 lines
8.0 KiB
OCaml
245 lines
8.0 KiB
OCaml
(*************************************************************************)
|
|
(* *)
|
|
(* Objective Caml LablTk library *)
|
|
(* *)
|
|
(* Francois Rouaix, Francois Pessaux and Jun Furuse *)
|
|
(* projet Cristal, INRIA Rocquencourt *)
|
|
(* Jacques Garrigue, Kyoto University RIMS *)
|
|
(* *)
|
|
(* Copyright 1999 Institut National de Recherche en Informatique et *)
|
|
(* en Automatique and Kyoto University. All rights reserved. *)
|
|
(* This file is distributed under the terms of the GNU Library *)
|
|
(* General Public License. *)
|
|
(* *)
|
|
(*************************************************************************)
|
|
|
|
(* $Id$ *)
|
|
|
|
open Tables
|
|
open Compile
|
|
open Intf
|
|
|
|
let flag_verbose = ref false
|
|
let verbose_string s =
|
|
if !flag_verbose then prerr_string s
|
|
let verbose_endline s =
|
|
if !flag_verbose then prerr_endline s
|
|
|
|
let input_name = ref "Widgets.src"
|
|
|
|
let usage () =
|
|
prerr_string "Usage: tkcompiler input.src\n";
|
|
flush stderr;
|
|
exit 1
|
|
|
|
|
|
let prerr_error_header () =
|
|
prerr_string "File \""; prerr_string !input_name;
|
|
prerr_string "\", line ";
|
|
prerr_string (string_of_int !Lexer.current_line);
|
|
prerr_string ": "
|
|
|
|
|
|
let parse_file filename =
|
|
let ic = open_in_bin filename in
|
|
try
|
|
let lexbuf = Lexing.from_channel ic in
|
|
while true do
|
|
Parser.entry Lexer.main lexbuf
|
|
done
|
|
with
|
|
Parsing.Parse_error ->
|
|
close_in ic;
|
|
prerr_error_header();
|
|
prerr_string "Syntax error \n";
|
|
exit 1
|
|
| Lexer.Lexical_error s ->
|
|
close_in ic;
|
|
prerr_error_header();
|
|
prerr_string "Lexical error (";
|
|
prerr_string s;
|
|
prerr_string ")\n";
|
|
exit 1
|
|
| Duplicate_Definition (s,s') ->
|
|
close_in ic;
|
|
prerr_error_header();
|
|
prerr_string s; prerr_string " "; prerr_string s';
|
|
prerr_string " is defined twice.\n";
|
|
exit 1
|
|
| Compiler_Error s ->
|
|
close_in ic;
|
|
prerr_error_header();
|
|
prerr_string "Internal error: "; prerr_string s; prerr_string "\n";
|
|
prerr_string "Please report bug\n";
|
|
exit 1
|
|
| End_of_file ->
|
|
close_in ic
|
|
|
|
(* hack to provoke production of cCAMLtoTKoptions_constrs *)
|
|
let option_hack oc =
|
|
try
|
|
let typdef = Hashtbl.find types_table key:"options" in
|
|
let hack =
|
|
{ parser_arity = OneToken;
|
|
constructors =
|
|
List.map typdef.constructors fun:
|
|
begin fun c ->
|
|
{ component = Constructor;
|
|
ml_name = c.ml_name;
|
|
var_name = c.var_name; (* as variants *)
|
|
template =
|
|
begin match c.template with
|
|
ListArg (x::_) -> x
|
|
| _ -> fatal_error "bogus hack"
|
|
end;
|
|
result = UserDefined "options_constrs";
|
|
safe = true }
|
|
end;
|
|
subtypes = [];
|
|
requires_widget_context = false;
|
|
variant = false }
|
|
in
|
|
write_CAMLtoTK w:(output_string to:oc) "options_constrs" def:hack safetype: false
|
|
with Not_found -> ()
|
|
|
|
let compile () =
|
|
verbose_endline "Creating tkgen.ml ...";
|
|
let oc = open_out_bin "lib/tkgen.ml" in
|
|
let oc' = open_out_bin "lib/tkigen.ml" in
|
|
let oc'' = open_out_bin "lib/tkfgen.ml" in
|
|
let sorted_types = Tsort.sort types_order in
|
|
verbose_endline " writing types ...";
|
|
List.iter sorted_types fun:
|
|
begin fun typname ->
|
|
verbose_string (" "^typname^" ");
|
|
try
|
|
let typdef = Hashtbl.find types_table key:typname in
|
|
verbose_string "type ";
|
|
write_type intf:(output_string to:oc)
|
|
impl:(output_string to:oc')
|
|
typname def:typdef;
|
|
verbose_string "C2T ";
|
|
write_CAMLtoTK w:(output_string to:oc') typname def:typdef;
|
|
verbose_string "T2C ";
|
|
if List.mem key:typname !types_returned then
|
|
write_TKtoCAML w:(output_string to:oc') typname def:typdef;
|
|
verbose_string "CO ";
|
|
write_catch_optionals w:(output_string to:oc') typname def:typdef;
|
|
verbose_endline "."
|
|
with Not_found ->
|
|
if not (List.mem_assoc key:typname !types_external) then
|
|
begin
|
|
verbose_string "Type ";
|
|
verbose_string typname;
|
|
verbose_string " is undeclared external or undefined\n"
|
|
end
|
|
else verbose_endline "."
|
|
end;
|
|
option_hack oc';
|
|
verbose_endline " writing functions ...";
|
|
List.iter fun:(write_function w:(output_string to:oc'')) !function_table;
|
|
close_out oc;
|
|
close_out oc';
|
|
close_out oc'';
|
|
(* Write the interface for public functions *)
|
|
(* this interface is used only for documentation *)
|
|
verbose_endline "Creating tkgen.mli ...";
|
|
let oc = open_out_bin "lib/tkgen.mli" in
|
|
List.iter (sort_components !function_table)
|
|
fun:(write_function_type w:(output_string to:oc));
|
|
close_out oc;
|
|
verbose_endline "Creating other ml, mli ...";
|
|
Hashtbl.iter module_table fun:
|
|
begin fun key:wname data:wdef ->
|
|
verbose_endline (" "^wname);
|
|
let modname = wname in
|
|
let oc = open_out_bin ("lib/" ^ modname ^ ".ml")
|
|
and oc' = open_out_bin ("lib/" ^ modname ^ ".mli") in
|
|
begin match wdef.module_type with
|
|
Widget -> output_string to:oc' ("(* The "^wname^" widget *)\n")
|
|
| Family -> output_string to:oc' ("(* The "^wname^" commands *)\n")
|
|
end;
|
|
output_string to:oc "open Protocol\n";
|
|
List.iter fun:(fun s -> output_string s to:oc; output_string s to:oc')
|
|
[ "open Tk\n";
|
|
"open Tkintf\n";
|
|
"open Widget\n";
|
|
"open Textvariable\n"
|
|
];
|
|
begin match wdef.module_type with
|
|
Widget ->
|
|
write_create w:(output_string to:oc) wname;
|
|
write_create_p w:(output_string to:oc') wname
|
|
| Family -> ()
|
|
end;
|
|
List.iter fun:(write_function w:(output_string to:oc))
|
|
(sort_components wdef.commands);
|
|
List.iter fun:(write_function_type w:(output_string to:oc'))
|
|
(sort_components wdef.commands);
|
|
List.iter fun:(write_external w:(output_string to:oc))
|
|
(sort_components wdef.externals);
|
|
List.iter fun:(write_external_type w:(output_string to:oc'))
|
|
(sort_components wdef.externals);
|
|
close_out oc;
|
|
close_out oc'
|
|
end;
|
|
(* write the module list for the Makefile *)
|
|
(* and hack to death until it works *)
|
|
let oc = open_out_bin "lib/modules" in
|
|
output_string to:oc "WIDGETOBJS=";
|
|
Hashtbl.iter module_table
|
|
fun:(fun key:name data:_ ->
|
|
output_string to:oc name;
|
|
output_string to:oc ".cmo ");
|
|
output_string to:oc "\n";
|
|
Hashtbl.iter module_table
|
|
fun:(fun key:name data:_ ->
|
|
output_string to:oc name;
|
|
output_string to:oc ".ml ");
|
|
output_string to:oc ": tkgen.ml\n\n";
|
|
Hashtbl.iter module_table fun:
|
|
begin fun key:name data:_ ->
|
|
output_string to:oc name;
|
|
output_string to:oc ".cmo : ";
|
|
output_string to:oc name;
|
|
output_string to:oc ".ml\n";
|
|
output_string to:oc name;
|
|
output_string to:oc ".cmi : ";
|
|
output_string to:oc name;
|
|
output_string to:oc ".mli\n"
|
|
end;
|
|
close_out oc
|
|
|
|
let main () =
|
|
Arg.parse
|
|
keywords:[ "-verbose", Arg.Unit (fun () -> flag_verbose := true),
|
|
"Make output verbose" ]
|
|
others:(fun filename -> input_name := filename)
|
|
errmsg:"Usage: tkcompiler <source file>" ;
|
|
try
|
|
verbose_string "Parsing... ";
|
|
parse_file !input_name;
|
|
verbose_string "Compiling... ";
|
|
compile ();
|
|
verbose_string "Finished";
|
|
exit 0
|
|
with
|
|
Lexer.Lexical_error s ->
|
|
prerr_string "Invalid lexical character: ";
|
|
prerr_endline s;
|
|
exit 1
|
|
| Duplicate_Definition (s,s') ->
|
|
prerr_string s; prerr_string " "; prerr_string s';
|
|
prerr_endline " is redefined illegally";
|
|
exit 1
|
|
| Invalid_implicit_constructor c ->
|
|
prerr_string "Constructor ";
|
|
prerr_string c;
|
|
prerr_endline " is used implicitly before defined";
|
|
exit 1
|
|
| Tsort.Cyclic ->
|
|
prerr_endline "Cyclic dependency of types";
|
|
exit 1
|
|
|
|
let () = Printexc.catch main ()
|