summaryrefslogtreecommitdiffstats
path: root/otherlibs/labltk/compiler
diff options
context:
space:
mode:
authorJacques Garrigue <garrigue at math.nagoya-u.ac.jp>2001-09-06 08:52:32 +0000
committerJacques Garrigue <garrigue at math.nagoya-u.ac.jp>2001-09-06 08:52:32 +0000
commitea299bbbc1dcf8f0f8f3b18558145965391ad224 (patch)
tree66a42a385bf5243f570afb2c48bf7239ce08f67a /otherlibs/labltk/compiler
parentbc8ff705be9af2f5883b640b1c9e285f380d5f70 (diff)
passage aux labels stricts
git-svn-id: http://caml.inria.fr/svn/ocaml/trunk@3696 f963ae5c-01c2-4b8c-9fe0-0dff7051ff02
Diffstat (limited to 'otherlibs/labltk/compiler')
-rw-r--r--otherlibs/labltk/compiler/Makefile8
-rw-r--r--otherlibs/labltk/compiler/compile.ml7
-rw-r--r--otherlibs/labltk/compiler/intf.ml4
-rw-r--r--otherlibs/labltk/compiler/lexer.mll4
-rw-r--r--otherlibs/labltk/compiler/maincompile.ml83
-rw-r--r--otherlibs/labltk/compiler/tables.ml26
-rw-r--r--otherlibs/labltk/compiler/tsort.ml2
7 files changed, 73 insertions, 61 deletions
diff --git a/otherlibs/labltk/compiler/Makefile b/otherlibs/labltk/compiler/Makefile
index 6b215dcbf..302ad2588 100644
--- a/otherlibs/labltk/compiler/Makefile
+++ b/otherlibs/labltk/compiler/Makefile
@@ -1,7 +1,7 @@
include ../support/Makefile.common
-OBJS=tsort.cmo tables.cmo printer.cmo lexer.cmo parser.cmo \
- compile.cmo intf.cmo maincompile.cmo
+OBJS= ../support/support.cmo tsort.cmo tables.cmo printer.cmo lexer.cmo \
+ parser.cmo compile.cmo intf.cmo maincompile.cmo
tkcompiler : $(OBJS)
$(LABLC) $(LINKFLAGS) -o tkcompiler $(OBJS)
@@ -25,10 +25,10 @@ install:
.SUFFIXES : .mli .ml .cmi .cmo .mlp
.mli.cmi:
- $(LABLCOMP) $(COMPFLAGS) $<
+ $(LABLCOMP) $(COMPFLAGS) -I ../support $<
.ml.cmo:
- $(LABLCOMP) $(COMPFLAGS) $<
+ $(LABLCOMP) $(COMPFLAGS) -I ../support $<
depend: parser.ml parser.mli lexer.ml
$(LABLDEP) *.mli *.ml > .depend
diff --git a/otherlibs/labltk/compiler/compile.ml b/otherlibs/labltk/compiler/compile.ml
index 25cf3be81..66cfcf7a7 100644
--- a/otherlibs/labltk/compiler/compile.ml
+++ b/otherlibs/labltk/compiler/compile.ml
@@ -15,6 +15,7 @@
(* $Id$ *)
+open StdLabels
open Tables
(* CONFIGURE *)
@@ -51,7 +52,7 @@ let gettklabel fc =
else s
in begin
if List.mem s forbidden then
- try List.assoc s nicknames
+ try List.assoc s ~map:nicknames
with Not_found -> small fc.var_name
else s
end
@@ -96,7 +97,7 @@ let ppMLtype ?(any=false) ?(return=false) ?(def=false) ?(counter=ref 0) =
begin
try
let typdef = Hashtbl.find types_table sup in
- let fcl = List.assoc sub typdef.subtypes in
+ let fcl = List.assoc sub ~map:typdef.subtypes in
let tklabels = List.map ~f:gettklabel fcl in
let l = List.map fcl ~f:
begin fun fc ->
@@ -498,7 +499,7 @@ let code_of_template ~context_widget ?func:(funtemplate=false) template =
StringArg s -> "TkToken \"" ^ s ^ "\""
| TypeArg (_, List (Subtype (sup, sub) as ty)) ->
let typdef = Hashtbl.find types_table sup in
- let classdef = List.assoc sub typdef.subtypes in
+ let classdef = List.assoc sub ~map:typdef.subtypes in
let lbl = gettklabel (List.hd classdef) in
catch_opts := (sub ^ "_" ^ sup, lbl);
newvar := newvar2;
diff --git a/otherlibs/labltk/compiler/intf.ml b/otherlibs/labltk/compiler/intf.ml
index 634e0a315..fdeac2edb 100644
--- a/otherlibs/labltk/compiler/intf.ml
+++ b/otherlibs/labltk/compiler/intf.ml
@@ -15,6 +15,8 @@
(* $Id$ *)
+open StdLabels
+
(* Write .mli for widgets *)
open Tables
@@ -25,7 +27,7 @@ let write_create_p ~w wname =
begin
try
let option = Hashtbl.find types_table "options" in
- let classdefs = List.assoc wname option.subtypes in
+ let classdefs = List.assoc wname ~map:option.subtypes in
let tklabels = List.map ~f:gettklabel classdefs in
let l = List.map classdefs ~f:
begin fun fc ->
diff --git a/otherlibs/labltk/compiler/lexer.mll b/otherlibs/labltk/compiler/lexer.mll
index 89d62417a..8de395681 100644
--- a/otherlibs/labltk/compiler/lexer.mll
+++ b/otherlibs/labltk/compiler/lexer.mll
@@ -16,8 +16,10 @@
(* $Id$ *)
{
+open StdLabels
open Lexing
open Parser
+open Support
exception Lexical_error of string
let current_line = ref 1
@@ -28,7 +30,7 @@ let current_line = ref 1
let keyword_table = (Hashtbl.create 149 : (string, token) Hashtbl.t)
let _ = List.iter
- ~f:(fun (str,tok) -> Hashtbl.add keyword_table ~key:str ~data:tok)
+ ~f:(fun (str,tok) -> Hashtbl'.add keyword_table ~key:str ~data:tok)
[
"int", TYINT;
"float", TYFLOAT;
diff --git a/otherlibs/labltk/compiler/maincompile.ml b/otherlibs/labltk/compiler/maincompile.ml
index c546b173d..65535df79 100644
--- a/otherlibs/labltk/compiler/maincompile.ml
+++ b/otherlibs/labltk/compiler/maincompile.ml
@@ -15,6 +15,8 @@
(* $Id$ *)
+open StdLabels
+open Support
open Tables
open Printer
open Compile
@@ -84,7 +86,7 @@ let parse_file filename =
in an hash table. *)
let elements t =
let elems = ref [] in
- Hashtbl.iter ~f:(fun ~key:_ ~data:d -> elems := d :: !elems) t;
+ Hashtbl.iter (fun _ d -> elems := d :: !elems) t;
!elems;;
(* Verifies that duplicated clauses are semantically equivalent and
@@ -117,7 +119,7 @@ let uniq_clauses = function
let c = constr.var_name in
if Hashtbl.mem t c
then (check_constr constr (Hashtbl.find t c))
- else Hashtbl.add t ~key:c ~data:constr);
+ else Hashtbl'.add t ~key:c ~data:constr);
elements t;;
let option_hack oc =
@@ -198,8 +200,7 @@ let compile () =
~f:(write_function_type ~w:(output_string oc));
close_out oc;
verbose_endline "Creating other ml, mli ...";
- Hashtbl.iter module_table ~f:
- begin fun ~key:wname ~data:wdef ->
+ let write_module wname wdef =
verbose_endline (" "^wname);
let modname = wname in
let oc = open_out_bin (destfile (modname ^ ".ml"))
@@ -210,11 +211,11 @@ let compile () =
end;
output_string oc "open Protocol\n";
List.iter ~f:(fun s -> output_string oc s; output_string oc' s)
- [ "open Tk\n";
- "open Tkintf\n";
- "open Widget\n";
- "open Textvariable\n"
- ];
+ [ "open StdLabels\n";
+ "open Tk\n";
+ "open Tkintf\n";
+ "open Widget\n";
+ "open Textvariable\n" ];
begin match wdef.module_type with
Widget ->
write_create ~w:(output_string oc) wname;
@@ -231,46 +232,48 @@ let compile () =
(sort_components wdef.externals);
close_out oc;
close_out oc'
- end;
+ in Hashtbl.iter write_module module_table;
(* write the module list for the Makefile *)
(* and hack to death until it works *)
let oc = open_out_bin (destfile "modules") in
- output_string oc "WIDGETOBJS=";
- Hashtbl.iter module_table
- ~f:(fun ~key:name ~data:_ ->
- output_string oc name;
- output_string oc ".cmo ");
- output_string oc "\n";
- Hashtbl.iter module_table
- ~f:(fun ~key:name ~data:_ ->
- output_string oc name;
- output_string oc ".ml ");
- output_string oc ": tkgen.ml\n\n";
- Hashtbl.iter module_table ~f:
- begin fun ~key:name ~data:_ ->
- output_string oc name;
- output_string oc ".cmo : ";
- output_string oc name;
- output_string oc ".ml\n";
- output_string oc name;
- output_string oc ".cmi : ";
- output_string oc name;
- output_string oc ".mli\n"
- end;
- close_out oc
+ output_string oc "WIDGETOBJS=";
+ Hashtbl.iter
+ (fun name _ ->
+ output_string oc name;
+ output_string oc ".cmo ")
+ module_table;
+ output_string oc "\n";
+ Hashtbl.iter
+ (fun name _ ->
+ output_string oc name;
+ output_string oc ".ml ")
+ module_table;
+ output_string oc ": tkgen.ml\n\n";
+ Hashtbl.iter
+ (fun name _ ->
+ output_string oc name;
+ output_string oc ".cmo : ";
+ output_string oc name;
+ output_string oc ".ml\n";
+ output_string oc name;
+ output_string oc ".cmi : ";
+ output_string oc name;
+ output_string oc ".mli\n")
+ module_table;
+ 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>" ;
+ [ "-verbose", Arg.Unit (fun () -> flag_verbose := true),
+ "Make output verbose" ]
+ (fun filename -> input_name := filename)
+ "Usage: tkcompiler <source file>" ;
try
- verbose_string "Parsing... ";
+ verbose_endline "Parsing...";
parse_file !input_name;
- verbose_string "Compiling... ";
+ verbose_endline "Compiling...";
compile ();
- verbose_string "Finished";
+ verbose_endline "Finished";
exit 0
with
| Lexer.Lexical_error s ->
diff --git a/otherlibs/labltk/compiler/tables.ml b/otherlibs/labltk/compiler/tables.ml
index f5fc1435c..85029b772 100644
--- a/otherlibs/labltk/compiler/tables.ml
+++ b/otherlibs/labltk/compiler/tables.ml
@@ -15,6 +15,9 @@
(* $Id$ *)
+open StdLabels
+open Support
+
(* Internal compiler errors *)
exception Compiler_Error of string
@@ -60,7 +63,7 @@ type fullcomponent = {
}
let sort_components =
- Sort.list ~order:(fun c1 c2 -> c1.ml_name < c2.ml_name)
+ List.sort ~cmp:(fun c1 c2 -> compare c1.ml_name c2.ml_name)
(* components are given either in full or abbreviated *)
@@ -153,7 +156,7 @@ let new_type typname arity =
subtypes = [];
requires_widget_context = false;
variant = false} in
- Hashtbl.add types_table ~key:typname ~data:typdef;
+ Hashtbl'.add types_table ~key:typname ~data:typdef;
typdef
@@ -178,7 +181,7 @@ let declared_type_parser_arity s =
(Hashtbl.find types_table s).parser_arity
with
Not_found ->
- try List.assoc s !types_external
+ try List.assoc s ~map:!types_external
with
Not_found ->
prerr_string "Type "; prerr_string s;
@@ -344,8 +347,8 @@ let enter_subtype typ arity subtyp constructors =
in
(* TODO: duplicate def in subtype are not checked *)
typdef.subtypes <-
- (subtyp , Sort.list real_constructors
- ~order:(fun c1 c2 -> c1.var_name <= c2.var_name)) ::
+ (subtyp , List.sort real_constructors
+ ~cmp:(fun c1 c2 -> compare c1.var_name c2.var_name)) ::
typdef.subtypes
end
@@ -385,13 +388,13 @@ let enter_widget name components =
| External, _ -> ()
end;
let commands =
- try List.assoc Command sorted_components
+ try List.assoc Command ~map:sorted_components
with Not_found -> []
and externals =
- try List.assoc External sorted_components
+ try List.assoc External ~map:sorted_components
with Not_found -> []
in
- Hashtbl.add module_table ~key:name
+ Hashtbl'.add module_table ~key:name
~data:{module_type = Widget; commands = commands; externals = externals}
(******************** Functions ********************)
@@ -412,12 +415,11 @@ let enter_module name components =
| External, _ -> ()
end;
let commands =
- try List.assoc Command sorted_components
+ try List.assoc Command ~map:sorted_components
with Not_found -> []
and externals =
- try List.assoc External sorted_components
+ try List.assoc External ~map:sorted_components
with Not_found -> []
in
- Hashtbl.add module_table ~key:name
+ Hashtbl'.add module_table ~key:name
~data:{module_type = Family; commands = commands; externals = externals}
-
diff --git a/otherlibs/labltk/compiler/tsort.ml b/otherlibs/labltk/compiler/tsort.ml
index c4d7f6224..993ed0f4a 100644
--- a/otherlibs/labltk/compiler/tsort.ml
+++ b/otherlibs/labltk/compiler/tsort.ml
@@ -15,6 +15,8 @@
(* $Id$ *)
+open StdLabels
+
(* Topological Sort.list *)
(* d'apres More Programming Pearls *)