diff options
author | Jacques Garrigue <garrigue at math.nagoya-u.ac.jp> | 2001-09-06 08:52:32 +0000 |
---|---|---|
committer | Jacques Garrigue <garrigue at math.nagoya-u.ac.jp> | 2001-09-06 08:52:32 +0000 |
commit | ea299bbbc1dcf8f0f8f3b18558145965391ad224 (patch) | |
tree | 66a42a385bf5243f570afb2c48bf7239ce08f67a /otherlibs/labltk/compiler | |
parent | bc8ff705be9af2f5883b640b1c9e285f380d5f70 (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/Makefile | 8 | ||||
-rw-r--r-- | otherlibs/labltk/compiler/compile.ml | 7 | ||||
-rw-r--r-- | otherlibs/labltk/compiler/intf.ml | 4 | ||||
-rw-r--r-- | otherlibs/labltk/compiler/lexer.mll | 4 | ||||
-rw-r--r-- | otherlibs/labltk/compiler/maincompile.ml | 83 | ||||
-rw-r--r-- | otherlibs/labltk/compiler/tables.ml | 26 | ||||
-rw-r--r-- | otherlibs/labltk/compiler/tsort.ml | 2 |
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 *) |