diff options
Diffstat (limited to 'ocaml-binary-annot/otherlibs/labltk/compiler')
21 files changed, 3272 insertions, 0 deletions
diff --git a/ocaml-binary-annot/otherlibs/labltk/compiler/.cvsignore b/ocaml-binary-annot/otherlibs/labltk/compiler/.cvsignore new file mode 100644 index 0000000000..060114e624 --- /dev/null +++ b/ocaml-binary-annot/otherlibs/labltk/compiler/.cvsignore @@ -0,0 +1,11 @@ +lexer.ml +parser.output +parser.ml +parser.mli +tkcompiler +pp +copyright.ml +pplex.ml +ppyac.ml +ppyac.output +ppyac.mli diff --git a/ocaml-binary-annot/otherlibs/labltk/compiler/.depend b/ocaml-binary-annot/otherlibs/labltk/compiler/.depend new file mode 100644 index 0000000000..91ee430407 --- /dev/null +++ b/ocaml-binary-annot/otherlibs/labltk/compiler/.depend @@ -0,0 +1,28 @@ +pplex.cmi: ppyac.cmi +ppyac.cmi: code.cmi +compile.cmo: code.cmi flags.cmo ppexec.cmo ppparse.cmo tables.cmo +compile.cmx: code.cmi flags.cmx ppexec.cmx ppparse.cmx tables.cmx +intf.cmo: code.cmi compile.cmo flags.cmo ppexec.cmo ppparse.cmo tables.cmo +intf.cmx: code.cmi compile.cmx flags.cmx ppexec.cmx ppparse.cmx tables.cmx +lexer.cmo: parser.cmi +lexer.cmx: parser.cmx +maincompile.cmo: code.cmi compile.cmo flags.cmo intf.cmo lexer.cmo parser.cmi \ + ppexec.cmo ppparse.cmo printer.cmo tables.cmo tsort.cmo +maincompile.cmx: code.cmi compile.cmx flags.cmx intf.cmx lexer.cmx parser.cmx \ + ppexec.cmx ppparse.cmx printer.cmx tables.cmx tsort.cmx +parser.cmo: flags.cmo tables.cmo parser.cmi +parser.cmx: flags.cmx tables.cmx parser.cmi +pp.cmo: ppexec.cmo ppparse.cmo +pp.cmx: ppexec.cmx ppparse.cmx +ppexec.cmo: code.cmi +ppexec.cmx: code.cmi +pplex.cmo: ppyac.cmi pplex.cmi +pplex.cmx: ppyac.cmx pplex.cmi +ppparse.cmo: pplex.cmi ppyac.cmi +ppparse.cmx: pplex.cmx ppyac.cmx +ppyac.cmo: code.cmi ppyac.cmi +ppyac.cmx: code.cmi ppyac.cmi +printer.cmo: tables.cmo +printer.cmx: tables.cmx +tables.cmo: tsort.cmo +tables.cmx: tsort.cmx diff --git a/ocaml-binary-annot/otherlibs/labltk/compiler/Makefile b/ocaml-binary-annot/otherlibs/labltk/compiler/Makefile new file mode 100644 index 0000000000..b7db380f65 --- /dev/null +++ b/ocaml-binary-annot/otherlibs/labltk/compiler/Makefile @@ -0,0 +1,63 @@ +include ../support/Makefile.common + +OBJS= ../support/support.cmo flags.cmo copyright.cmo \ + tsort.cmo tables.cmo printer.cmo lexer.cmo \ + pplex.cmo ppyac.cmo ppexec.cmo ppparse.cmo \ + parser.cmo compile.cmo intf.cmo maincompile.cmo + +PPOBJS= pplex.cmo ppyac.cmo ppexec.cmo ppparse.cmo pp.cmo + +all: tkcompiler$(EXE) pp$(EXE) + +tkcompiler$(EXE) : $(OBJS) + $(CAMLC) -g $(LINKFLAGS) -o tkcompiler$(EXE) $(OBJS) + +pp$(EXE): $(PPOBJS) + $(CAMLC) -g $(LINKFLAGS) -o pp$(EXE) $(PPOBJS) + +lexer.ml: lexer.mll + $(CAMLLEX) lexer.mll + +parser.ml parser.mli: parser.mly + $(CAMLYACC) -v parser.mly + +pplex.ml: pplex.mll + $(CAMLLEX) pplex.mll + +pplex.mli: ppyac.cmi + +ppyac.ml ppyac.mli: ppyac.mly + $(CAMLYACC) -v ppyac.mly + +copyright.ml: copyright + (echo "let copyright=\"\\"; \ + sed -e 's/$$/\\n\\/' copyright; \ + echo "\""; \ + echo "let write ~w = w copyright;;") > copyright.ml + +clean : + rm -f *.cm* parser.ml parser.mli lexer.ml copyright.ml + rm -f pplex.ml ppyac.ml ppyac.mli ppyac.output + rm -f tkcompiler$(EXE) pp$(EXE) parser.output + +scratch : + rm -f *.cm* parser.ml parser.mli lexer.ml tkcompiler$(EXE) + rm -f *.cm* pplex.ml ppyac.ml ppyac.mli pp$(EXE) + +install: + cp tkcompiler$(EXE) $(INSTALLDIR) + cp pp$(EXE) $(INSTALLDIR) + +.SUFFIXES : +.SUFFIXES : .mli .ml .cmi .cmo .mlp + +.mli.cmi: + $(CAMLCOMP) $(COMPFLAGS) -I ../support $< + +.ml.cmo: + $(CAMLCOMP) $(COMPFLAGS) -I ../support $< + +depend: parser.ml parser.mli lexer.ml pplex.ml ppyac.ml ppyac.mli + $(CAMLDEP) *.mli *.ml > .depend + +include .depend diff --git a/ocaml-binary-annot/otherlibs/labltk/compiler/Makefile.nt b/ocaml-binary-annot/otherlibs/labltk/compiler/Makefile.nt new file mode 100644 index 0000000000..2b0b5ab535 --- /dev/null +++ b/ocaml-binary-annot/otherlibs/labltk/compiler/Makefile.nt @@ -0,0 +1 @@ +include Makefile diff --git a/ocaml-binary-annot/otherlibs/labltk/compiler/code.mli b/ocaml-binary-annot/otherlibs/labltk/compiler/code.mli new file mode 100644 index 0000000000..6f3e292134 --- /dev/null +++ b/ocaml-binary-annot/otherlibs/labltk/compiler/code.mli @@ -0,0 +1,22 @@ +(***********************************************************************) +(* *) +(* MLTk, Tcl/Tk interface of Objective Caml *) +(* *) +(* Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis *) +(* projet Cristal, INRIA Rocquencourt *) +(* Jacques Garrigue, Kyoto University RIMS *) +(* *) +(* Copyright 2002 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, with the special exception on linking *) +(* described in file LICENSE found in the Objective Caml source tree. *) +(* *) +(***********************************************************************) + +type code = + | Line of string + | Ifdef of bool * string * code list * code list option + | Define of string + | Undef of string +;; diff --git a/ocaml-binary-annot/otherlibs/labltk/compiler/compile.ml b/ocaml-binary-annot/otherlibs/labltk/compiler/compile.ml new file mode 100644 index 0000000000..fd74bc173d --- /dev/null +++ b/ocaml-binary-annot/otherlibs/labltk/compiler/compile.ml @@ -0,0 +1,1074 @@ +(***********************************************************************) +(* *) +(* MLTk, Tcl/Tk interface of Objective Caml *) +(* *) +(* Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis *) +(* projet Cristal, INRIA Rocquencourt *) +(* Jacques Garrigue, Kyoto University RIMS *) +(* *) +(* Copyright 2002 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, with the special exception on linking *) +(* described in file LICENSE found in the Objective Caml source tree. *) +(* *) +(***********************************************************************) + +(* $Id$ *) + +open StdLabels +open Tables + +(* CONFIGURE *) +(* if you set it true, ImagePhoto and ImageBitmap will annoy you... *) +let safetype = true + +let labeloff ~at l = match l with + "", t -> t +| l, t -> raise (Failure ("labeloff: " ^ l ^ " at " ^ at)) + +let labltk_labelstring l = + if l = "" then l else + if l.[0] = '?' then l ^ ":" else + "~" ^ l ^ ":" + +let camltk_labelstring l = + if l = "" then l else + if l.[0] = '?' then l ^ ":" else "" + +let labelstring l = + if !Flags.camltk then camltk_labelstring l + else labltk_labelstring l + +let labltk_typelabel l = + if l = "" then l else l ^ ":" + +let camltk_typelabel l = + if l = "" then l + else if l.[0] = '?' then l ^ ":" else "" + +let typelabel l = + if !Flags.camltk then camltk_typelabel l + else labltk_typelabel l + +let forbidden = [ "class"; "type"; "in"; "from"; "to" ] +let nicknames = + [ "class", "clas"; + "type", "typ" ] + +let small = String.lowercase + +let gettklabel fc = + match fc.template with + ListArg( StringArg s :: _ ) -> + let s = small s in + if s = "" then s else + let s = + if s.[0] = '-' + then String.sub s ~pos:1 ~len:(String.length s - 1) + else s + in begin + if List.mem s forbidden then + try List.assoc s nicknames + with Not_found -> small fc.var_name + else s + end + | _ -> raise (Failure "gettklabel") + +let count ~item:x l = + let count = ref 0 in + List.iter ~f:(fun y -> if x = y then incr count) l; + !count + +(* Extract all types from a template *) +let rec types_of_template = function + StringArg _ -> [] + | TypeArg (l, t) -> [l, t] + | ListArg l -> List.flatten (List.map ~f:types_of_template l) + | OptionalArgs (l, tl, _) -> + begin + match List.flatten (List.map ~f:types_of_template tl) with + ["", t] -> ["?" ^ l, t] + | [_, _] -> raise (Failure "0 label required") + | _ -> raise (Failure "0 or more than 1 args in for optionals") + end + +(* + * Pretty print a type + * used to write ML type definitions + *) +let ppMLtype ?(any=false) ?(return=false) ?(def=false) ?(counter=ref 0) = + let rec ppMLtype = + function + Unit -> "unit" + | Int -> "int" + | Float -> "float" + | Bool -> "bool" + | Char -> "char" + | String -> "string" +(* new *) + | List (Subtype (sup, sub)) -> + if !Flags.camltk then "(* " ^ sub ^ " *) " ^ sup ^ " list" + else begin + if return then + sub ^ "_" ^ sup ^ " list" + else begin + try + let typdef = Hashtbl.find types_table sup in + let fcl = List.assoc sub typdef.subtypes in + let tklabels = List.map ~f:gettklabel fcl in + let l = List.map fcl ~f: + begin fun fc -> + "?" ^ begin let p = gettklabel fc in + if count ~item:p tklabels > 1 then small fc.var_name else p + end + ^ ":" ^ + let l = types_of_template fc.template in + match l with + [] -> "unit" + | [lt] -> ppMLtype (labeloff lt ~at:"ppMLtype") + | l -> + "(" ^ String.concat ~sep:"*" + (List.map l + ~f:(fun lt -> ppMLtype (labeloff lt ~at:"ppMLtype"))) + ^ ")" + end in + String.concat ~sep:" ->\n" l + with + Not_found -> Printf.eprintf "ppMLtype %s/%s\n" sup sub; exit (-1) + end + end + | List ty -> (ppMLtype ty) ^ " list" + | Product tyl -> + "(" ^ String.concat ~sep:" * " (List.map ~f:ppMLtype tyl) ^ ")" + | Record tyl -> + String.concat ~sep:" * " + (List.map tyl ~f:(fun (l, t) -> typelabel l ^ ppMLtype t)) + | Subtype ("widget", sub) -> + if !Flags.camltk then "(* " ^ sub ^" *) widget" else sub ^ " widget" + | UserDefined "widget" -> + if !Flags.camltk then "widget" + else begin + if any then "any widget" else + let c = String.make 1 (Char.chr(Char.code 'a' + !counter)) in + incr counter; + "'" ^ c ^ " widget" + end + | UserDefined s -> + if !Flags.camltk then s + else begin + (* a bit dirty hack for ImageBitmap and ImagePhoto *) + try + let typdef = Hashtbl.find types_table s in + if typdef.variant then + if return then try + "[>" ^ + String.concat ~sep:"|" + (List.map typdef.constructors ~f: + begin + fun c -> + "`" ^ c.var_name ^ + (match types_of_template c.template with + [] -> "" + | l -> " of " ^ ppMLtype (Product (List.map l + ~f:(labeloff ~at:"ppMLtype UserDefined")))) + end) ^ "]" + with + Not_found -> prerr_endline ("ppMLtype " ^ s ^ " ?"); s + else if not def && List.length typdef.constructors > 1 then + "[< " ^ s ^ "]" + else s + else s + with Not_found -> s + end + | Subtype (s, s') -> + if !Flags.camltk then "(* " ^ s' ^ " *) " ^ s else s' ^ "_" ^ s + | Function (Product tyl) -> + raise (Failure "Function (Product tyl) ? ppMLtype") + | Function (Record tyl) -> + "(" ^ String.concat ~sep:" -> " + (List.map tyl ~f:(fun (l, t) -> typelabel l ^ ppMLtype t)) + ^ " -> unit)" + | Function ty -> + "(" ^ (ppMLtype ty) ^ " -> unit)" + | As (t, s) -> + if !Flags.camltk then ppMLtype t + else s + in + ppMLtype + +(* Produce a documentation version of a template *) +let rec ppTemplate = function + StringArg s -> s + | TypeArg (l, t) -> "<" ^ ppMLtype t ^ ">" + | ListArg l -> "{" ^ String.concat ~sep:" " (List.map ~f:ppTemplate l) ^ "}" + | OptionalArgs (l, tl, d) -> + "?" ^ l ^ "{" ^ String.concat ~sep:" " (List.map ~f:ppTemplate tl) + ^ "}[<" ^ String.concat ~sep:" " (List.map ~f:ppTemplate d) ^ ">]" + +let doc_of_template = function + ListArg l -> String.concat ~sep:" " (List.map ~f:ppTemplate l) + | t -> ppTemplate t + +(* + * Type definitions + *) + +(* Write an ML constructor *) +let write_constructor ~w {ml_name = mlconstr; template = t} = + w mlconstr; + begin match types_of_template t with + [] -> () + | l -> w " of "; + w (ppMLtype ~any:true (Product (List.map l + ~f:(labeloff ~at:"write_constructor")))) + end; + w " (* tk option: "; w (doc_of_template t); w " *)" + +(* Write a rhs type decl *) +let write_constructors ~w = function + [] -> fatal_error "empty type" + | x :: l -> + write_constructor ~w x; + List.iter l ~f: + begin fun x -> + w "\n | "; + write_constructor ~w x + end + +(* Write an ML variant *) +let write_variant ~w {var_name = varname; template = t} = + w "`"; + w varname; + begin match types_of_template t with + [] -> () + | l -> + w " of "; + w (ppMLtype ~any:true ~def:true + (Product (List.map l ~f:(labeloff ~at:"write_variant")))) + end; + w " (* tk option: "; w (doc_of_template t); w " *)" + +let write_variants ~w = function + [] -> fatal_error "empty variants" + | l -> + List.iter l ~f: + begin fun x -> + w "\n | "; + write_variant ~w x + end + +(* Definition of a type *) +let labltk_write_type ~intf:w ~impl:w' name ~def:typdef = + (* Only needed if no subtypes, otherwise use optionals *) + if typdef.subtypes = [] then begin + w "(* Variant type *)\n"; + w ("type " ^ name ^ " = ["); + write_variants ~w (sort_components typdef.constructors); + w "\n]\n\n" + end + +(* CamlTk: List of constructors, for runtime subtyping *) +let write_constructor_set ~w ~sep = function + | [] -> fatal_error "empty type" + | x::l -> + w ("C" ^ x.ml_name); + List.iter l ~f: (function x -> + w sep; + w ("C" ^ x.ml_name)) + +(* CamlTk: Definition of a type *) +let camltk_write_type ~intf:w ~impl:w' name ~def:typdef = + (* Put markers for extraction *) + w "(* type *)\n"; + w ("type " ^ name ^ " =\n"); + w " | "; + write_constructors ~w (sort_components typdef.constructors); + w "\n(* /type *)\n\n"; + (* Dynamic Subtyping *) + if typdef.subtypes <> [] then begin + (* The set of its constructors *) + if name = "options" then begin + w "(* type *)\n"; + w ("type "^name^"_constrs =\n\t") + end else begin + (* added some prefix to avoid being picked up in documentation *) + w ("(* no doc *) type "^name^"_constrs =\n") + end; + w " | "; + write_constructor_set ~w:w ~sep: "\n | " + (sort_components typdef.constructors); + w "\n\n"; + (* The set of all constructors *) + w' ("let "^name^"_any_table = ["); + write_constructor_set ~w:w' ~sep:"; " + (sort_components typdef.constructors); + w' ("]\n\n"); + (* The subset of constructors for each subtype *) + List.iter ~f:(function (s,l) -> + w' ("let "^name^"_"^s^"_table = ["); + write_constructor_set ~w:w' ~sep:"; " (sort_components l); + w' ("]\n\n")) + typdef.subtypes + end + +let write_type ~intf:w ~impl:w' name ~def:typdef = + (if !Flags.camltk then camltk_write_type else labltk_write_type) + ~intf:w ~impl:w' name ~def:typdef + +(************************************************************) +(* Converters *) +(************************************************************) + +let rec converterTKtoCAML ~arg = function + | Int -> "int_of_string " ^ arg + | Float -> "float_of_string " ^ arg + | Bool -> "(match " ^ arg ^ " with\n\ + | \"1\" -> true\n\ + | \"0\" -> false\n\ + | s -> Pervasives.raise (Invalid_argument (\"cTKtoCAMLbool\" ^ s)))" + | Char -> "String.get " ^ arg ^ " 0" + | String -> arg + | UserDefined s -> "cTKtoCAML" ^ s ^ " " ^ arg + | Subtype ("widget", s') when not !Flags.camltk -> + String.concat ~sep:" " + ["(Obj.magic (cTKtoCAMLwidget "; arg; ") :"; s'; "widget)"] + | Subtype (s, s') -> + if !Flags.camltk then + "cTKtoCAML" ^ s ^ " " ^ arg + else + "cTKtoCAML" ^ s' ^ "_" ^ s ^ " " ^ arg + | List ty -> + begin match type_parser_arity ty with + OneToken -> + String.concat ~sep:" " + ["(List.map (function x ->"; + converterTKtoCAML ~arg:"x" ty; ")"; arg; ")"] + | MultipleToken -> + String.concat ~sep:" " + ["iterate_converter (function x ->"; + converterTKtoCAML ~arg:"x" ty; ")"; arg; ")"] + end + | As (ty, _) -> converterTKtoCAML ~arg ty + | t -> + prerr_endline ("ERROR with " ^ arg ^ " " ^ ppMLtype t); + fatal_error "converterTKtoCAML" + + +(*******************************) +(* Wrappers *) +(*******************************) +let varnames ~prefix n = + let rec var i = + if i > n then [] + else (prefix ^ string_of_int i) :: var (succ i) + in var 1 + +(* + * generate wrapper source for callbacks + * transform a function ... -> unit in a function : unit -> unit + * using primitives arg_ ... from the protocol + * Warning: sequentiality is important in generated code + * TODO: remove arg_ stuff and process lists directly ? + *) + +let rec wrapper_code ~name ty = + match ty with + Unit -> "(fun _ -> " ^ name ^ " ())" + | As (ty, _) -> wrapper_code ~name ty + | ty -> + "(fun args ->\n " ^ + begin match ty with + Product tyl -> raise (Failure "Product -> record was done. ???") + | Record tyl -> + (* variables for each component of the product *) + let vnames = varnames ~prefix:"a" (List.length tyl) in + (* getting the arguments *) + let readarg = + List.map2 vnames tyl ~f: + begin fun v (l, ty) -> + match type_parser_arity ty with + OneToken -> + "let (" ^ v ^ ", args) = " ^ + converterTKtoCAML ~arg:"(List.hd args)" ty ^ + ", List.tl args in\n " + | MultipleToken -> + "let (" ^ v ^ ", args) = " ^ + converterTKtoCAML ~arg:"args" ty ^ + " in\n " + end in + String.concat ~sep:"" readarg ^ name ^ " " ^ + String.concat ~sep:" " + (List.map2 ~f:(fun v (l, _) -> + if !Flags.camltk then v + else labelstring l ^ v) vnames tyl) + + (* all other types are read in one operation *) + | List ty -> + name ^ "(" ^ converterTKtoCAML ~arg:"args" ty ^ ")" + | String -> + name ^ "(" ^ converterTKtoCAML ~arg:"(List.hd args)" ty ^ ")" + | ty -> + begin match type_parser_arity ty with + OneToken -> + name ^ "(" ^ converterTKtoCAML ~arg:"(List.hd args)" ty ^ ")" + | MultipleToken -> + "let (v, _) = " ^ converterTKtoCAML ~arg:"args" ty ^ + " in\n " ^ name ^ " v" + end + end ^ ")" + +(*************************************************************) +(* Parsers *) +(* are required only for values returned by commands and *) +(* functions (table is computed by the parser) *) + +(* Tuples/Lists are Ok if they don't contain strings *) +(* they will be returned as list of strings *) + +(* Can we generate a "parser" ? + -> all constructors are unit and at most one int and one string, with null constr +*) +type parser_pieces = + { mutable zeroary : (string * string) list ; (* kw string, ml name *) + mutable intpar : string list; (* one at most, mlname *) + mutable stringpar : string list (* idem *) + } + +type mini_parser = + NoParser + | ParserPieces of parser_pieces + +let can_generate_parser constructors = + let pp = {zeroary = []; intpar = []; stringpar = []} in + if List.for_all constructors ~f: + begin fun c -> + let vname = if !Flags.camltk then c.ml_name else c.var_name in + match c.template with + ListArg [StringArg s] -> + pp.zeroary <- (s, vname) :: + pp.zeroary; true + | ListArg [TypeArg(_, Int)] | ListArg[TypeArg(_, Float)] -> + if pp.intpar <> [] then false + else (pp.intpar <- [vname]; true) + | ListArg [TypeArg(_, String)] -> + if pp.stringpar <> [] then false + else (pp.stringpar <- [vname]; true) + | _ -> false + end + then ParserPieces pp + else NoParser + + +(* We can generate parsers only for simple types *) +(* we should avoid multiple walks *) +let labltk_write_TKtoCAML ~w name ~def:typdef = + if typdef.parser_arity = MultipleToken then + prerr_string ("You must write cTKtoCAML" ^ name ^ + " : string list ->" ^ name ^ " * string list\n") + else + let write ~consts ~name = + match can_generate_parser consts with + NoParser -> + prerr_string + ("You must write cTKtoCAML" ^ name ^ " : string ->" ^ name ^ "\n") + | ParserPieces pp -> + w ("let cTKtoCAML" ^ name ^ " n =\n"); + (* First check integer *) + if pp.intpar <> [] then + begin + w (" try `" ^ List.hd pp.intpar ^ " (int_of_string n)\n"); + w (" with _ ->\n") + end; + w (" match n with\n"); + List.iter pp.zeroary ~f: + begin fun (tk, ml) -> + w " | \""; w tk; w "\" -> `"; w ml; w "\n" + end; + let final = if pp.stringpar <> [] then + "n -> `" ^ List.hd pp.stringpar ^ " n" + else "s -> Pervasives.raise (Invalid_argument (\"cTKtoCAML" + ^ name ^ ": \" ^ s))" + in + w " | "; + w final; + w "\n\n" + in + begin + write ~name ~consts:typdef.constructors; + List.iter typdef.subtypes ~f: begin + fun (subname, consts) -> write ~name:(subname ^ "_" ^ name) ~consts + end + end + +let camltk_write_TKtoCAML ~w name ~def:typdef = + if typdef.parser_arity = MultipleToken then + prerr_string ("You must write cTKtoCAML" ^ name ^ + " : string list ->" ^ name ^ " * string list\n") + else + let write ~consts ~name = + match can_generate_parser consts with + NoParser -> + prerr_string + ("You must write cTKtoCAML" ^ name ^ " : string ->" ^ name ^ "\n") + | ParserPieces pp -> + w ("let cTKtoCAML" ^ name ^ " n =\n"); + (* First check integer *) + if pp.intpar <> [] then + begin + w (" try " ^ List.hd pp.intpar ^ " (int_of_string n)\n"); + w (" with _ ->\n") + end; + w (" match n with\n"); + List.iter pp.zeroary ~f: + begin fun (tk, ml) -> + w " | \""; w tk; w "\" -> "; w ml; w "\n" + end; + let final = if pp.stringpar <> [] then + "n -> " ^ List.hd pp.stringpar ^ " n" + else "s -> Pervasives.raise (Invalid_argument (\"cTKtoCAML" + ^ name ^ ": \" ^ s))" + in + w " | "; + w final; + w "\n\n" + in + begin + write ~name ~consts:typdef.constructors; + List.iter typdef.subtypes ~f: begin + fun (subname, consts) -> write ~name:(subname ^ "_" ^ name) ~consts + end + end + +let write_TKtoCAML ~w name ~def:typdef = + (if !Flags.camltk then camltk_write_TKtoCAML else labltk_write_TKtoCAML) + ~w name ~def: typdef + +(******************************) +(* Converters *) +(******************************) + +(* Produce an in-lined converter Caml -> Tk for simple types *) +(* the converter is a function of type: <type> -> string *) +let rec converterCAMLtoTK ~context_widget argname ty = + match ty with + Int -> "TkToken (string_of_int " ^ argname ^ ")" + | Float -> "TkToken (Printf.sprintf \"%g\" " ^ argname ^ ")" + | Bool -> "if " ^ argname ^ " then TkToken \"1\" else TkToken \"0\"" + | Char -> "TkToken (Char.escaped " ^ argname ^ ")" + | String -> "TkToken " ^ argname + | As (ty, _) -> converterCAMLtoTK ~context_widget argname ty + | UserDefined s -> + let name = "cCAMLtoTK" ^ s ^ " " in + let args = argname in + let args = + if !Flags.camltk then begin + if is_subtyped s then (* unconstraint subtype *) + s ^ "_any_table " ^ args + else args + end else args + in + let args = + if requires_widget_context s then + context_widget ^ " " ^ args + else args in + name ^ args + | Subtype ("widget", s') -> + if !Flags.camltk then + let name = "cCAMLtoTKwidget " in + let args = "widget_"^s'^"_table "^argname in + let args = + if requires_widget_context "widget" then + context_widget^" "^args + else args in + name^args + else begin + let name = "cCAMLtoTKwidget " in + let args = "(" ^ argname ^ " : " ^ s' ^ " widget)" in + name ^ args + end + | Subtype (s, s') -> + let name = + if !Flags.camltk then "cCAMLtoTK" ^ s ^ " " + else "cCAMLtoTK" ^ s' ^ "_" ^ s ^ " " + in + let args = + if !Flags.camltk then begin + s^"_"^s'^"_table "^argname + end else begin + if safetype then "(" ^ argname ^ " : [< " ^ s' ^ "_" ^ s ^ "])" + else argname + end + in + let args = + if requires_widget_context s then context_widget ^ " " ^ args + else args in + name ^ args + | Product tyl -> + let vars = varnames ~prefix:"z" (List.length tyl) in + String.concat ~sep:" " + ("let" :: String.concat ~sep:"," vars :: "=" :: argname :: + "in TkTokenList [" :: + String.concat ~sep:"; " + (List.map2 vars tyl ~f:(converterCAMLtoTK ~context_widget)) :: + ["]"]) + | List ty -> (* Just added for Imagephoto.put *) + String.concat ~sep:" " + [(if !Flags.camltk then + "TkQuote (TkTokenList (List.map (fun y -> " + else + "TkQuote (TkTokenList (List.map ~f:(fun y -> "); + converterCAMLtoTK ~context_widget "y" ty; + ")"; + argname; + "))"] + | Function _ -> fatal_error "unexpected function type in converterCAMLtoTK" + | Unit -> fatal_error "unexpected unit type in converterCAMLtoTK" + | Record _ -> fatal_error "unexpected product type in converterCAMLtoTK" + +(* + * Produce a list of arguments from a template + * The idea here is to avoid allocation as much as possible + * + *) + +let code_of_template ~context_widget ?func:(funtemplate=false) template = + let catch_opts = ref ("", "") in (* class name and first option *) + let variables = ref [] in + let variables2 = ref [] in + let varcnter = ref 0 in + let optionvar = ref None in + let newvar1 l = + match !optionvar with + Some v -> optionvar := None; v + | None -> + incr varcnter; + let v = "v" ^ (string_of_int !varcnter) in + variables := (l, v) :: !variables; v in + let newvar2 l = + match !optionvar with + Some v -> optionvar := None; v + | None -> + incr varcnter; + let v = "v" ^ (string_of_int !varcnter) in + variables2 := (l, v) :: !variables2; v in + let newvar = ref newvar1 in + let rec coderec = function + StringArg s -> "TkToken \"" ^ s ^ "\"" + | TypeArg (_, List (Subtype (sup, sub))) when not !Flags.camltk -> + begin try + let typdef = Hashtbl.find types_table sup in + let classdef = List.assoc sub typdef.subtypes in + let lbl = gettklabel (List.hd classdef) in + catch_opts := (sub ^ "_" ^ sup, lbl); + newvar := newvar2; + "TkTokenList opts" + with Not_found -> + raise (Failure (Printf.sprintf "type %s(%s) not found" sup sub)); + end + | TypeArg (l, List ty) -> + (if !Flags.camltk then + "TkTokenList (List.map (function x -> " + else + "TkTokenList (List.map ~f:(function x -> ") + ^ converterCAMLtoTK ~context_widget "x" ty + ^ ") " ^ !newvar l ^ ")" + | TypeArg (l, Function tyarg) -> + "let id = register_callback " ^ context_widget + ^ " ~callback: " ^ wrapper_code ~name:(!newvar l) tyarg + ^ " in TkToken (\"camlcb \" ^ id)" + | TypeArg (l, ty) -> converterCAMLtoTK ~context_widget (!newvar l) ty + | ListArg l -> + "TkQuote (TkTokenList [" + ^ String.concat ~sep:";\n " (List.map ~f:coderec l) ^ "])" + | OptionalArgs (l, tl, d) -> + let nv = !newvar ("?" ^ l) in + optionvar := Some nv; (* Store *) + let argstr = String.concat ~sep:"; " (List.map ~f:coderec tl) in + let defstr = String.concat ~sep:"; " (List.map ~f:coderec d) in + "TkTokenList (match " ^ nv ^ " with\n" + ^ " | Some " ^ nv ^ " -> [" ^ argstr ^ "]\n" + ^ " | None -> [" ^ defstr ^ "])" + in + let code = + if funtemplate then + match template with + ListArg l -> + "[|" ^ String.concat ~sep:";\n " (List.map ~f:coderec l) ^ "|]" + | _ -> "[|" ^ coderec template ^ "|]" + else + match template with + ListArg [x] -> coderec x + | ListArg l -> + "TkTokenList [" ^ + String.concat ~sep:";\n " (List.map ~f:coderec l) ^ + "]" + | _ -> coderec template + in + code, List.rev !variables, List.rev !variables2, !catch_opts + +(* + * Converters for user defined types + *) + +(* For each case of a concrete type *) +let labltk_write_clause ~w ~context_widget comp = + let warrow () = w " -> " in + w "`"; + w comp.var_name; + + let code, variables, variables2, (co, _) = + code_of_template ~context_widget comp.template in + + (* no subtype I think ... *) + if co <> "" then raise (Failure "write_clause subtype ?"); + begin match variables with + | [] -> warrow() + | [x] -> w " "; w (labeloff x ~at:"write_clause"); warrow() + | l -> + w " ( "; + w (String.concat ~sep:", " (List.map ~f:(labeloff ~at:"write_clause") l)); + w ")"; + warrow() + end; + w code + +let camltk_write_clause ~w ~context_widget ~subtype comp = + let warrow () = + w " -> "; + if subtype then + w ("chk_sub \""^comp.ml_name^"\" table C" ^ comp.ml_name ^ "; ") + in + + w comp.ml_name; (* we use ml_name, not var_name, specialized for labltk *) + + let code, variables, variables2, (co, _) = + code_of_template ~context_widget comp.template in + + (* no subtype I think ... *) + if co <> "" then raise (Failure "write_clause subtype ?"); + begin match variables with + | [] -> warrow() + | [x] -> w " "; w (labeloff x ~at:"write_clause"); warrow() + | l -> + w " ( "; + w (String.concat ~sep:", " (List.map ~f:(labeloff ~at:"write_clause") l)); + w ")"; + warrow() + end; + w code + +let write_clause ~w ~context_widget ~subtype comp = + if !Flags.camltk then camltk_write_clause ~w ~context_widget ~subtype comp + else labltk_write_clause ~w ~context_widget comp + +(* The full converter *) +let write_CAMLtoTK ~w ~def:typdef ?safetype:(st = true) name = + let write_one name constrs = + let subtype = typdef.subtypes <> [] in + w ("let cCAMLtoTK" ^ name); + let context_widget = + if typdef.requires_widget_context then begin + w " w"; "w" + end + else + "dummy" in + if !Flags.camltk && subtype then w " table"; + if st then begin + w " : "; + if typdef.variant then w ("[< " ^ name ^ "]") else w name; + w " -> tkArgs " + end; + w (" = function"); + List.iter constrs + ~f:(fun c -> w "\n | "; write_clause ~w ~context_widget ~subtype c); + w "\n\n\n" + in + + let constrs = typdef.constructors in + if !Flags.camltk then write_one name constrs + else begin + (* Only needed if no subtypes, otherwise use optionals *) + if typdef.subtypes == [] then + write_one name constrs + else + List.iter constrs ~f: + begin fun fc -> + let code, vars, _, (co, _) = + code_of_template ~context_widget:"dummy" fc.template in + if co <> "" then fatal_error "optionals in optionals"; + let vars = List.map ~f:snd vars in + w "let ccCAMLtoTK"; w name; w "_"; w (small fc.ml_name); + w " ("; w (String.concat ~sep:", " vars); w ") =\n "; + w code; w "\n\n" + end + end + +(* Tcl does not really return "lists". It returns sp separated tokens *) +let rec write_result_parsing ~w = function + List String -> + w "(splitlist res)" + | List ty -> + if !Flags.camltk then + w (" List.map " ^ converterTKtoCAML ~arg:"(splitlist res)" ty) + else + w (" List.map ~f: " ^ converterTKtoCAML ~arg:"(splitlist res)" ty) + | Product tyl -> raise (Failure "Product -> record was done. ???") + | Record tyl -> (* of course all the labels are "" *) + let rnames = varnames ~prefix:"r" (List.length tyl) in + w " let l = splitlist res in"; + w ("\n if List.length l <> " ^ string_of_int (List.length tyl)); + w ("\n then Pervasives.raise (TkError (\"unexpected result: \" ^ res))"); + w ("\n else "); + List.iter2 rnames tyl ~f: + begin fun r (l, ty) -> + if l <> "" then raise (Failure "lables in return type!!!"); + w (" let " ^ r ^ ", l = "); + begin match type_parser_arity ty with + OneToken -> + w (converterTKtoCAML ~arg:"(List.hd l)" ty); w (", List.tl l") + | MultipleToken -> + w (converterTKtoCAML ~arg:"l" ty) + end; + w (" in\n") + end; + w (String.concat ~sep:", " rnames) + | String -> + w (converterTKtoCAML ~arg:"res" String) + | As (ty, _) -> write_result_parsing ~w ty + | ty -> + match type_parser_arity ty with + OneToken -> w (converterTKtoCAML ~arg:"res" ty) + | MultipleToken -> w (converterTKtoCAML ~arg:"(splitlist res)" ty) + +let labltk_write_function ~w def = + w ("let " ^ def.ml_name); + (* a bit approximative *) + let context_widget = match def.template with + ListArg (TypeArg(_, UserDefined("widget")) :: _) -> "v1" + | ListArg (TypeArg(_, Subtype("widget", _)) :: _) -> "v1" + | _ -> "dummy" in + + let code, variables, variables2, (co, lbl) = + code_of_template ~func:true ~context_widget def.template in + (* Arguments *) + let uv, lv, ov = + let rec replace_args ~u ~l ~o = function + [] -> u, l, o + | ("", x) :: ls -> + replace_args ~u:(x :: u) ~l ~o ls + | (p, _ as x) :: ls when p.[0] = '?' -> + replace_args ~u ~l ~o:(x :: o) ls + | x :: ls -> + replace_args ~u ~l:(x :: l) ~o ls + in + replace_args ~u:[] ~l:[] ~o:[] (List.rev (variables @ variables2)) + in + let has_opts = (ov <> [] || co <> "") in + if not has_opts then List.iter uv ~f:(fun x -> w " "; w x); + List.iter (lv@ov) ~f:(fun (l, v) -> w " "; w (labelstring l); w v); + if co <> "" then begin + if lv = [] && ov = [] then w (" ?" ^ lbl ^ ":eta"); + w " =\n"; + w (co ^ "_optionals"); + if lv = [] && ov = [] then w (" ?" ^ lbl ^ ":eta"); + w " (fun opts"; + if uv = [] then w " ()" else + if has_opts then List.iter uv ~f:(fun x -> w " "; w x); + w " ->\n" + end else begin + if (ov <> [] || lv = []) && uv = [] then w " ()" else + if has_opts then List.iter uv ~f:(fun x -> w " "; w x); + w " =\n" + end; + begin match def.result with + | Unit | As (Unit, _) -> w "tkCommand "; w code + | ty -> + w "let res = tkEval "; w code ; w " in \n"; + write_result_parsing ~w ty + end; + if co <> "" then w ")"; + w "\n\n" + +let camltk_write_function ~w def = + w ("let " ^ def.ml_name); + (* a bit approximative *) + let context_widget = match def.template with + ListArg (TypeArg(_, UserDefined("widget")) :: _) -> "v1" + | ListArg (TypeArg(_, Subtype("widget", _)) :: _) -> "v1" + | _ -> "dummy" in + + let code, variables, variables2, (co, lbl) = + code_of_template ~func:true ~context_widget def.template in + (* Arguments *) + let uv, ov = + let rec replace_args ~u ~o = function + [] -> u, o + | ("", x) :: ls -> + replace_args ~u:(x :: u) ~o ls + | (p, _ as x) :: ls when p.[0] = '?' -> + replace_args ~u ~o:(x :: o) ls + | (_,x) :: ls -> + replace_args ~u:(x::u) ~o ls + in + replace_args ~u:[] ~o:[] (List.rev (variables @ variables2)) + in + let has_opts = ov <> [] (* (ov <> [] || co <> "") *) in + if not has_opts then List.iter uv ~f:(fun x -> w " "; w x); + List.iter ov ~f:(fun (l, v) -> w " "; w (labelstring l); w v); + begin + if uv = [] then w " ()" else + if has_opts then List.iter uv ~f:(fun x -> w " "; w x); + w " =\n" + end; + begin match def.result with + | Unit | As (Unit, _) -> w "tkCommand "; w code + | ty -> + w "let res = tkEval "; w code ; w " in \n"; + write_result_parsing ~w ty + end; + w "\n\n" + +(* + w ("let " ^ def.ml_name); + (* a bit approximative *) + let context_widget = match def.template with + ListArg (TypeArg(_, UserDefined("widget")) :: _) -> "v1" + | ListArg (TypeArg(_, Subtype("widget", _)) :: _) -> "v1" + | _ -> "dummy" in + + let code, variables, variables2, (co, lbl) = + code_of_template ~func:true ~context_widget def.template in + let variables = variables @ variables2 in + (* Arguments *) + begin match variables with + [] -> w " () =\n" + | l -> + let has_normal_argument = ref false in + List.iter (fun (l,x) -> + w " "; + if l <> "" then + if l.[0] = '?' then w (l ^ ":") else has_normal_argument := true + else has_normal_argument := true; + w x) l; + if not !has_normal_argument then w " ()"; + w " =\n" + end; + begin match def.result with + | Unit | As (Unit, _) -> w "tkCommand "; w code + | ty -> + w "let res = tkEval "; w code ; w " in \n"; + write_result_parsing ~w ty + end; + w "\n\n" +*) + +let write_function ~w def = + if !Flags.camltk then camltk_write_function ~w def + else labltk_write_function ~w def +;; + +let labltk_write_create ~w clas = + w ("let create ?name =\n"); + w (" " ^ clas ^ "_options_optionals (fun opts parent ->\n"); + w (" let w = new_atom \"" ^ clas ^ "\" ~parent ?name in\n"); + w " tkCommand [|"; + w ("TkToken \"" ^ clas ^ "\";\n"); + w (" TkToken (Widget.name w);\n"); + w (" TkTokenList opts |];\n"); + w (" w)\n\n\n") + +let camltk_write_create ~w clas = + w ("let create ?name parent options =\n"); + w (" let w = new_atom \"" ^ clas ^ "\" ~parent ?name in\n"); + w " tkCommand [|"; + w ("TkToken \"" ^ clas ^ "\";\n"); + w (" TkToken (Widget.name w);\n"); + w (" TkTokenList (List.map (function x -> "^ + converterCAMLtoTK "w" "x" (Subtype("options",clas)) ^ ") options)\n"); + w (" |];\n"); + w (" w\n\n") + +let camltk_write_named_create ~w clas = + w ("let create_named parent name options =\n"); + w (" let w = new_atom \"" ^ clas ^ "\" ~parent ~name in\n"); + w " tkCommand [|"; + w ("TkToken \"" ^ clas ^ "\";\n"); + w (" TkToken (Widget.name w);\n"); + w (" TkTokenList (List.map (function x -> "^ + converterCAMLtoTK "w" "x" (Subtype("options",clas)) ^ ") options)\n"); + w (" |];\n"); + w (" w\n\n") + +(* Search Path. *) +let search_path = ref ["."] + +(* taken from utils/misc.ml *) +let find_in_path path name = + if not (Filename.is_implicit name) then + if Sys.file_exists name then name else raise Not_found + else begin + let rec try_dir = function + [] -> raise Not_found + | dir :: rem -> + let fullname = Filename.concat dir name in + if Sys.file_exists fullname then fullname else try_dir rem + in try_dir path + end + +(* builtin-code: the file (without suffix) is in .template... *) +(* not efficient, but hell *) +let write_external ~w def = + match def.template with + | StringArg fname -> + begin try + let realname = find_in_path !search_path (fname ^ ".ml") in + let ic = open_in_bin realname in + try + let code_list = Ppparse.parse_channel ic in + close_in ic; + List.iter (Ppexec.exec (fun _ -> ()) w) + (if !Flags.camltk then + Code.Define "CAMLTK" :: code_list else code_list ); + with + | Ppparse.Error s -> + close_in ic; + raise (Compiler_Error (Printf.sprintf "Preprocess error: %s" s)) + with + | Not_found -> + raise (Compiler_Error ("can't find external file: " ^ fname)) + end + | _ -> raise (Compiler_Error "invalid external definition") + +let write_catch_optionals ~w clas ~def:typdef = + if typdef.subtypes = [] then () else + List.iter typdef.subtypes ~f: + begin fun (subclass, classdefs) -> + w ("let " ^ subclass ^ "_" ^ clas ^ "_optionals f = fun\n"); + let tklabels = List.map ~f:gettklabel classdefs in + let l = + List.map classdefs ~f: + begin fun fc -> + (* + let code, vars, _, (co, _) = + code_of_template ~context_widget:"dummy" fc.template in + if co <> "" then fatal_error "optionals in optionals"; + *) + let p = gettklabel fc in + (if count ~item:p tklabels > 1 then small fc.var_name else p), + small fc.ml_name + end in + let p = List.map l ~f:(fun (si, _) -> " ?" ^ si) in + let v = + List.map l ~f: + begin fun (si, s) -> + "(maycons ccCAMLtoTK" ^ clas ^ "_" ^ s ^ " " ^ si + end in + w (String.concat ~sep:"\n" p); + w " ->\n"; + w " f "; + w (String.concat ~sep:"\n " v); + w "\n []"; + w (String.make (List.length v) ')'); + w "\n\n" + end diff --git a/ocaml-binary-annot/otherlibs/labltk/compiler/copyright b/ocaml-binary-annot/otherlibs/labltk/compiler/copyright new file mode 100644 index 0000000000..23dff46dce --- /dev/null +++ b/ocaml-binary-annot/otherlibs/labltk/compiler/copyright @@ -0,0 +1,15 @@ +(***********************************************************************) +(* *) +(* MLTk, Tcl/Tk interface of Objective Caml *) +(* *) +(* Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis *) +(* projet Cristal, INRIA Rocquencourt *) +(* Jacques Garrigue, Kyoto University RIMS *) +(* *) +(* Copyright 2002 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, with the special exception on linking *) +(* described in file LICENSE found in the Objective Caml source tree. *) +(* *) +(***********************************************************************) diff --git a/ocaml-binary-annot/otherlibs/labltk/compiler/flags.ml b/ocaml-binary-annot/otherlibs/labltk/compiler/flags.ml new file mode 100644 index 0000000000..009d5e725a --- /dev/null +++ b/ocaml-binary-annot/otherlibs/labltk/compiler/flags.ml @@ -0,0 +1,17 @@ +(***********************************************************************) +(* *) +(* MLTk, Tcl/Tk interface of Objective Caml *) +(* *) +(* Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis *) +(* projet Cristal, INRIA Rocquencourt *) +(* Jacques Garrigue, Kyoto University RIMS *) +(* *) +(* Copyright 2002 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, with the special exception on linking *) +(* described in file LICENSE found in the Objective Caml source tree. *) +(* *) +(***********************************************************************) + +let camltk = ref false;; diff --git a/ocaml-binary-annot/otherlibs/labltk/compiler/intf.ml b/ocaml-binary-annot/otherlibs/labltk/compiler/intf.ml new file mode 100644 index 0000000000..59608b3815 --- /dev/null +++ b/ocaml-binary-annot/otherlibs/labltk/compiler/intf.ml @@ -0,0 +1,191 @@ +(***********************************************************************) +(* *) +(* MLTk, Tcl/Tk interface of Objective Caml *) +(* *) +(* Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis *) +(* projet Cristal, INRIA Rocquencourt *) +(* Jacques Garrigue, Kyoto University RIMS *) +(* *) +(* Copyright 2002 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, with the special exception on linking *) +(* described in file LICENSE found in the Objective Caml source tree. *) +(* *) +(***********************************************************************) + +(* $Id$ *) + +open StdLabels + +(* Write .mli for widgets *) + +open Tables +open Compile + +let labltk_write_create_p ~w wname = + w "val create :\n ?name:string ->\n"; + begin + try + let option = Hashtbl.find types_table "options" in + let classdefs = List.assoc wname option.subtypes in + let tklabels = List.map ~f:gettklabel classdefs in + let l = List.map classdefs ~f: + begin fun fc -> + begin let p = gettklabel fc in + if count ~item:p tklabels > 1 then small fc.var_name else p + end, + fc.template + end in + w (String.concat ~sep:" ->\n" + (List.map l ~f: + begin fun (s, t) -> + " ?" ^ s ^ ":" + ^(ppMLtype + (match types_of_template t with + | [t] -> labeloff t ~at:"write_create_p" + | [] -> fatal_error "multiple" + | l -> Product (List.map ~f:(labeloff ~at:"write_create_p") l))) + end)) + with Not_found -> fatal_error "in write_create_p" + end; + w (" ->\n 'a widget -> " ^ wname ^ " widget\n"); + w "(** [create ?name parent options...] creates a new widget with\n"; + w " parent [parent] and new patch component [name], if specified. *)\n\n" +;; + +let camltk_write_create_p ~w wname = + w "val create : ?name: string -> widget -> options list -> widget \n"; + w "(** [create ?name parent options] creates a new widget with\n"; + w " parent [parent] and new patch component [name] if specified.\n"; + w " Options are restricted to the widget class subset, and checked\n"; + w " dynamically. *)\n\n" +;; + +let camltk_write_named_create_p ~w wname = + w "val create_named : widget -> string -> options list -> widget \n"; + w "(** [create_named parent name options] creates a new widget with\n"; + w " parent [parent] and new patch component [name].\n"; + w " This function is now obsolete and unified with [create]. *)\n\n"; +;; + +(* Unsafe: write special comment *) +let labltk_write_function_type ~w def = + if not def.safe then w "(* unsafe *)\n"; + w "val "; w def.ml_name; w " : "; + let us, ls, os = + let tys = types_of_template def.template in + let rec replace_args ~u ~l ~o = function + [] -> u, l, o + | (_, List(Subtype _) as x)::ls -> + replace_args ~u ~l ~o:(x::o) ls + | ("", _ as x)::ls -> + replace_args ~u:(x::u) ~l ~o ls + | (p, _ as x)::ls when p.[0] = '?' -> + replace_args ~u ~l ~o:(x::o) ls + | x::ls -> + replace_args ~u ~l:(x::l) ~o ls + in + replace_args ~u:[] ~l:[] ~o:[] (List.rev tys) + in + let counter = ref 0 in + let params = + if os = [] then us @ ls else ls @ os @ us in + List.iter params ~f: + begin fun (l, t) -> + if l <> "" then w (l ^ ":"); + w (ppMLtype t ~counter); + w " -> " + end; + if (os <> [] || ls = []) && us = [] then w "unit -> "; + w (ppMLtype ~any:true ~return:true def.result); (* RETURN TYPE !!! *) + w " \n"; +(* w "(* tk invocation: "; w (doc_of_template def.template); w " *)"; *) + if def.safe then w "\n" + else w "\n(* /unsafe *)\n" + +let camltk_write_function_type ~w def = + if not def.safe then w "(* unsafe *)\n"; + w "val "; w def.ml_name; w " : "; + let us, os = + let tys = types_of_template def.template in + let rec replace_args ~u ~o = function + [] -> u, o + | ("", _ as x)::ls -> + replace_args ~u:(x::u) ~o ls + | (p, _ as x)::ls when p.[0] = '?' -> + replace_args ~u ~o:(x::o) ls + | x::ls -> + replace_args ~u:(x::u) ~o ls + in + replace_args ~u:[] ~o:[] (List.rev tys) + in + let counter = ref 0 in + let params = + if os = [] then us else os @ us in + List.iter params ~f: + begin fun (l, t) -> + if l <> "" then if l.[0] = '?' then w (l ^ ":"); + w (ppMLtype t ~counter); + w " -> " + end; + if us = [] then w "unit -> "; + w (ppMLtype ~any:true ~return:true def.result); (* RETURN TYPE !!! *) + w " \n"; +(* w "(* tk invocation: "; w (doc_of_template def.template); w " *)"; *) + if def.safe then w "\n" + else w "\n(* /unsafe *)\n" + +(* + if not def.safe then w "(* unsafe *)\n"; + w "val "; w def.ml_name; w " : "; + let tys = types_of_template def.template in + let counter = ref 0 in + let have_normal_arg = ref false in + List.iter tys ~f: + begin fun (l, t) -> + if l <> "" then + if l.[0] = '?' then w (l^":") + else begin + have_normal_arg := true; + w (" (* " ^ l ^ ":*)") + end + else have_normal_arg := true; + w (ppMLtype t ~counter); + w " -> " + end; + if not !have_normal_arg then w "unit -> "; + w (ppMLtype ~any:true ~return:true def.result); (* RETURN TYPE !!! *) + w " \n"; + if def.safe then w "\n" + else w "\n(* /unsafe *)\n" +*) + +let write_function_type ~w def = + if !Flags.camltk then camltk_write_function_type ~w def + else labltk_write_function_type ~w def + +let write_external_type ~w def = + match def.template with + | StringArg fname -> + begin try + let realname = find_in_path !search_path (fname ^ ".mli") in + let ic = open_in_bin realname in + try + let code_list = Ppparse.parse_channel ic in + close_in ic; + if not def.safe then w "(* unsafe *)\n"; + List.iter (Ppexec.exec (fun _ -> ()) w) + (if !Flags.camltk then + Code.Define "CAMLTK" :: code_list else code_list ); + if def.safe then w "\n\n" + else w "\n(* /unsafe *)\n\n" + with + | Ppparse.Error s -> + close_in ic; + raise (Compiler_Error (Printf.sprintf "Preprocess error: %s" s)) + with + | Not_found -> + raise (Compiler_Error ("can't find external file: " ^ fname)) + end + | _ -> raise (Compiler_Error "invalid external definition") diff --git a/ocaml-binary-annot/otherlibs/labltk/compiler/lexer.mll b/ocaml-binary-annot/otherlibs/labltk/compiler/lexer.mll new file mode 100644 index 0000000000..f51f0c01f3 --- /dev/null +++ b/ocaml-binary-annot/otherlibs/labltk/compiler/lexer.mll @@ -0,0 +1,170 @@ +(***********************************************************************) +(* *) +(* MLTk, Tcl/Tk interface of Objective Caml *) +(* *) +(* Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis *) +(* projet Cristal, INRIA Rocquencourt *) +(* Jacques Garrigue, Kyoto University RIMS *) +(* *) +(* Copyright 2002 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, with the special exception on linking *) +(* described in file ../LICENSE. *) +(* *) +(***********************************************************************) + +(* $Id$ *) + +{ +open StdLabels +open Lexing +open Parser +open Support + +exception Lexical_error of string +let current_line = ref 1 + + +(* The table of keywords *) + +let keyword_table = (Hashtbl.create 149 : (string, token) Hashtbl.t) + +let _ = List.iter + ~f:(fun (str,tok) -> Hashtbl.add keyword_table str tok) + [ + "int", TYINT; + "float", TYFLOAT; + "bool", TYBOOL; + "char", TYCHAR; + "string", TYSTRING; + "list", LIST; + "as", AS; + "variant", VARIANT; + "widget", WIDGET; + "option", OPTION; + "type", TYPE; + "subtype", SUBTYPE; + "function", FUNCTION; + "module", MODULE; + "external", EXTERNAL; + "sequence", SEQUENCE; + "unsafe", UNSAFE +] + + +(* To buffer string literals *) + +let initial_string_buffer = String.create 256 +let string_buff = ref initial_string_buffer +let string_index = ref 0 + +let reset_string_buffer () = + string_buff := initial_string_buffer; + string_index := 0; + () + +let store_string_char c = + if !string_index >= String.length (!string_buff) then begin + let new_buff = String.create (String.length (!string_buff) * 2) in + String.blit ~src:(!string_buff) ~src_pos:0 ~dst:new_buff ~dst_pos:0 + ~len:(String.length (!string_buff)); + string_buff := new_buff + end; + String.set (!string_buff) (!string_index) c; + incr string_index + +let get_stored_string () = + let s = String.sub (!string_buff) ~pos:0 ~len:(!string_index) in + string_buff := initial_string_buffer; + s +(* To translate escape sequences *) + +let char_for_backslash = function + 'n' -> '\010' + | 'r' -> '\013' + | 'b' -> '\008' + | 't' -> '\009' + | c -> c + +let char_for_decimal_code lexbuf i = + Char.chr(100 * (Char.code(Lexing.lexeme_char lexbuf i) - 48) + + 10 * (Char.code(Lexing.lexeme_char lexbuf (i+1)) - 48) + + (Char.code(Lexing.lexeme_char lexbuf (i+2)) - 48)) + +let saved_string_start = ref 0 + +} + +rule main = parse + '\010' { incr current_line; main lexbuf } + | [' ' '\013' '\009' '\026' '\012'] + + { main lexbuf } + | ['A'-'Z' 'a'-'z' '\192'-'\214' '\216'-'\246' '\248'-'\255' ] + ( '_' ? ['A'-'Z' 'a'-'z' '\192'-'\214' '\216'-'\246' '\248'-'\255' (*'*) '0'-'9' ] ) * + { let s = Lexing.lexeme lexbuf in + try + Hashtbl.find keyword_table s + with Not_found -> + IDENT s } + + | "\"" + { reset_string_buffer(); + (* Start of token is start of string. *) + saved_string_start := lexbuf.lex_start_pos; + string lexbuf; + lexbuf.lex_start_pos <- !saved_string_start; + STRING (get_stored_string()) } + | "(" { LPAREN } + | ")" { RPAREN } + | "[" { LBRACKET } + | "]" { RBRACKET } + | "{" { LBRACE } + | "}" { RBRACE } + | "," { COMMA } + | ";" { SEMICOLON } + | ":" {COLON} + | "?" {QUESTION} + | "/" {SLASH} + | "%" { comment lexbuf; main lexbuf } + | "##line" { line lexbuf; main lexbuf } + | eof { EOF } + | _ + { raise (Lexical_error("illegal character")) } + + +and string = parse + '"' + { () } + | '\\' [' ' '\010' '\013' '\009' '\026' '\012'] + + { string lexbuf } + | '\\' ['\\' '"' 'n' 't' 'b' 'r'] + { store_string_char(char_for_backslash(Lexing.lexeme_char lexbuf 1)); + string lexbuf } + | '\\' ['0'-'9'] ['0'-'9'] ['0'-'9'] + { store_string_char(char_for_decimal_code lexbuf 1); + string lexbuf } + | eof + { raise (Lexical_error("string not terminated")) } + | '\010' + { incr current_line; + store_string_char(Lexing.lexeme_char lexbuf 0); + string lexbuf } + | _ + { store_string_char(Lexing.lexeme_char lexbuf 0); + string lexbuf } + +and comment = parse + '\010' { incr current_line } + | eof { () } + | _ { comment lexbuf } + +and linenum = parse + | ['0'-'9']+ { + let next_line = int_of_string (Lexing.lexeme lexbuf) in + current_line := next_line - 1 + } + | _ { raise (Lexical_error("illegal ##line directive: no line number"))} + +and line = parse + | [' ' '\t']* { linenum lexbuf } diff --git a/ocaml-binary-annot/otherlibs/labltk/compiler/maincompile.ml b/ocaml-binary-annot/otherlibs/labltk/compiler/maincompile.ml new file mode 100644 index 0000000000..d8c72a312d --- /dev/null +++ b/ocaml-binary-annot/otherlibs/labltk/compiler/maincompile.ml @@ -0,0 +1,418 @@ +(***********************************************************************) +(* *) +(* MLTk, Tcl/Tk interface of Objective Caml *) +(* *) +(* Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis *) +(* projet Cristal, INRIA Rocquencourt *) +(* Jacques Garrigue, Kyoto University RIMS *) +(* *) +(* Copyright 2002 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, with the special exception on linking *) +(* described in file LICENSE found in the Objective Caml source tree. *) +(* *) +(***********************************************************************) + +(* $Id$ *) + +open StdLabels +open Support +open Tables +open Printer +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 output_dir = ref "" +let destfile f = Filename.concat !output_dir f + +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 ": " + +(* parse Widget.src config file *) +let parse_file filename = + let ic = open_in_bin filename in + let lexbuf = + try + let code_list = Ppparse.parse_channel ic in + close_in ic; + let buf = Buffer.create 50000 in + List.iter (Ppexec.exec + (fun l -> Buffer.add_string buf + (Printf.sprintf "##line %d\n" l)) + (Buffer.add_string buf)) + (if !Flags.camltk then Code.Define "CAMLTK" :: code_list + else code_list); + Lexing.from_string (Buffer.contents buf) + with + | Ppparse.Error s -> + close_in ic; + raise (Compiler_Error (Printf.sprintf "Preprocess error: %s" s)) + in + try + while true do + Parser.entry Lexer.main lexbuf + done + with + | Parsing.Parse_error -> + prerr_error_header(); + prerr_string "Syntax error \n"; + exit 1 + | Lexer.Lexical_error s -> + prerr_error_header(); + prerr_string "Lexical error ("; + prerr_string s; + prerr_string ")\n"; + exit 1 + | Duplicate_Definition (s,s') -> + prerr_error_header(); + prerr_string s; prerr_string " "; prerr_string s'; + prerr_string " is defined twice.\n"; + exit 1 + | Compiler_Error s -> + prerr_error_header(); + prerr_string "Internal error: "; prerr_string s; prerr_string "\n"; + prerr_string "Please report bug\n"; + exit 1 + | End_of_file -> + () + +(* The hack to provoke the production of cCAMLtoTKoptions_constrs *) + +(* Auxiliary function: the list of all the elements associated to keys + in an hash table. *) +let elements t = + let elems = ref [] in + Hashtbl.iter (fun _ d -> elems := d :: !elems) t; + !elems;; + +(* Verifies that duplicated clauses are semantically equivalent and + returns a unique set of clauses. *) +let uniq_clauses = function + | [] -> [] + | l -> + let check_constr constr1 constr2 = + if constr1.template <> constr2.template then + begin + let code1, vars11, vars12, opts1 = + code_of_template ~context_widget:"dummy" constr1.template in + let code2, vars12, vars22, opts2 = + code_of_template ~context_widget:"dummy" constr2.template in + let err = + Printf.sprintf + "uncompatible redondant clauses for variant %s:\n %s\n and\n %s" + constr1.var_name code1 code2 in + Format.print_newline(); + print_fullcomponent constr1; + Format.print_newline(); + print_fullcomponent constr2; + Format.print_newline(); + prerr_endline err; + fatal_error err + end in + let t = Hashtbl.create 11 in + List.iter l + ~f:(fun constr -> + let c = constr.var_name in + if Hashtbl.mem t c + then (check_constr constr (Hashtbl.find t c)) + else Hashtbl.add t c constr); + elements t;; + +let option_hack oc = + if Hashtbl.mem types_table "options" then + let typdef = Hashtbl.find types_table "options" in + let hack = + { parser_arity = OneToken; + constructors = begin + let constrs = + List.map typdef.constructors ~f: + begin fun c -> + { component = Constructor; + ml_name = (if !Flags.camltk then "C" ^ c.ml_name + else 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 in + if !Flags.camltk then constrs else uniq_clauses constrs (* JPF ?? *) + end; + subtypes = []; + requires_widget_context = false; + variant = false } + in + write_CAMLtoTK + ~w:(output_string oc) ~def:hack ~safetype:false "options_constrs" + +let realname name = + (* module name fix for camltk *) + if !Flags.camltk then "c" ^ String.capitalize name + else name +;; + +(* analize the parsed Widget.src and output source files *) +let compile () = + verbose_endline "Creating _tkgen.ml ..."; + let oc = open_out_bin (destfile "_tkgen.ml") in + let oc' = open_out_bin (destfile "_tkigen.ml") in + let oc'' = open_out_bin (destfile "_tkfgen.ml") in + let sorted_types = Tsort.sort types_order in + verbose_endline " writing types ..."; + List.iter sorted_types ~f: + begin fun typname -> + verbose_string (" " ^ typname ^ " "); + try + let typdef = Hashtbl.find types_table typname in + verbose_string "type "; + write_type ~intf:(output_string oc) + ~impl:(output_string oc') + typname ~def:typdef; + verbose_string "C2T "; + write_CAMLtoTK ~w:(output_string oc') typname ~def:typdef; + verbose_string "T2C "; + if List.mem typname !types_returned then + write_TKtoCAML ~w:(output_string oc') typname ~def:typdef; + verbose_string "CO "; + if not !Flags.camltk then (* only for LablTk *) + write_catch_optionals ~w:(output_string oc') typname ~def:typdef; + verbose_endline "." + with Not_found -> + if not (List.mem_assoc typname !types_external) then + begin + verbose_string "Type "; + verbose_string typname; + verbose_string " is undeclared external or undefined\n" + end + else verbose_endline "." + end; + verbose_endline " option hacking ..."; + option_hack oc'; + verbose_endline " writing functions ..."; + List.iter ~f:(write_function ~w:(output_string 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 (destfile "_tkgen.mli") in + List.iter (sort_components !function_table) + ~f:(write_function_type ~w:(output_string oc)); + close_out oc; + verbose_endline "Creating other ml, mli ..."; + let write_module wname wdef = + verbose_endline (" "^wname); + let modname = realname wname in + let oc = open_out_bin (destfile (modname ^ ".ml")) + and oc' = open_out_bin (destfile (modname ^ ".mli")) in + Copyright.write ~w:(output_string oc); + Copyright.write ~w:(output_string oc'); + begin match wdef.module_type with + Widget -> output_string oc' ("(* The "^wname^" widget *)\n") + | Family -> output_string oc' ("(* The "^wname^" commands *)\n") + end; + List.iter ~f:(fun s -> output_string oc s; output_string oc' s) + begin + if !Flags.camltk then + [ "open CTk\n"; + "open Tkintf\n"; + "open Widget\n"; + "open Textvariable\n\n" ] + else + [ "open StdLabels\n"; + "open Tk\n"; + "open Tkintf\n"; + "open Widget\n"; + "open Textvariable\n\n" ] + end; + output_string oc "open Protocol\n"; + begin match wdef.module_type with + Widget -> + if !Flags.camltk then begin + camltk_write_create ~w:(output_string oc) wname; + camltk_write_named_create ~w:(output_string oc) wname; + camltk_write_create_p ~w:(output_string oc') wname; + camltk_write_named_create_p ~w:(output_string oc') wname; + end else begin + labltk_write_create ~w:(output_string oc) wname; + labltk_write_create_p ~w:(output_string oc') wname + end + | Family -> () + end; + List.iter ~f:(write_function ~w:(output_string oc)) + (sort_components wdef.commands); + List.iter ~f:(write_function_type ~w:(output_string oc')) + (sort_components wdef.commands); + List.iter ~f:(write_external ~w:(output_string oc)) + (sort_components wdef.externals); + List.iter ~f:(write_external_type ~w:(output_string oc')) + (sort_components wdef.externals); + close_out oc; + close_out oc' + in Hashtbl.iter write_module module_table; + + (* wrapper code camltk.ml and labltk.ml *) + if !Flags.camltk then begin + let oc = open_out_bin (destfile "camltk.ml") in + Copyright.write ~w:(output_string oc); + output_string oc +"(** This module Camltk provides the module name spaces of the CamlTk API.\n\ +\n\ + The users of the CamlTk API should open this module first to access\n\ + the types, functions and modules of the CamlTk API easier.\n\ + For the documentation of each sub modules such as [Button] and [Toplevel],\n\ + refer to its defintion file, [cButton.mli], [cToplevel.mli], etc.\n\ + *)\n\ +\n\ +"; + output_string oc "include CTk\n"; + output_string oc "module Tk = CTk\n"; + Hashtbl.iter (fun name _ -> + let cname = realname name in + output_string oc (Printf.sprintf "module %s = %s;;\n" + (String.capitalize name) + (String.capitalize cname))) module_table; + close_out oc + end else begin + let oc = open_out_bin (destfile "labltk.ml") in + Copyright.write ~w:(output_string oc); + output_string oc +"(** This module Labltk provides the module name spaces of the LablTk API,\n\ + useful to call LablTk functions inside CamlTk programs. 100% LablTk users\n\ + do not need to use this. *)\n\ +\n\ +"; + output_string oc "module Widget = Widget;;\n\ +module Protocol = Protocol;;\n\ +module Textvariable = Textvariable;;\n\ +module Fileevent = Fileevent;;\n\ +module Timer = Timer;;\n\ +"; + Hashtbl.iter (fun name _ -> + let cname = realname name in + output_string oc (Printf.sprintf "module %s = %s;;\n" + (String.capitalize name) + (String.capitalize cname))) module_table; + (* widget typer *) + output_string oc "\n(** Widget typers *)\n\nopen Widget\n\n"; + Hashtbl.iter (fun name def -> + match def.module_type with + | Widget -> + output_string oc (Printf.sprintf + "let %s (w : any widget) =\n" name); + output_string oc (Printf.sprintf + " Rawwidget.check_class w widget_%s_table;\n" name); + output_string oc (Printf.sprintf + " (Obj.magic w : %s widget);;\n\n" name); + | _ -> () ) module_table; + close_out oc + end; + + (* write the module list for the Makefile *) + (* and hack to death until it works *) + let oc = open_out_bin (destfile "modules") in + if !Flags.camltk then output_string oc "CWIDGETOBJS=" + else output_string oc "WIDGETOBJS="; + Hashtbl.iter + (fun name _ -> + let name = realname name in + output_string oc name; + output_string oc ".cmo ") + module_table; + output_string oc "\n"; + Hashtbl.iter + (fun name _ -> + let name = realname name in + output_string oc name; + output_string oc ".ml ") + module_table; + output_string oc ": _tkgen.ml\n\n"; + Hashtbl.iter + (fun name _ -> + let name = realname name in + 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; + + (* for camltk.ml wrapper *) + if !Flags.camltk then begin + output_string oc "camltk.cmo : cTk.cmo "; + Hashtbl.iter + (fun name _ -> + let name = realname name in + output_string oc name; + output_string oc ".cmo ") module_table; + output_string oc "\n" + end; + close_out oc + +let main () = + Arg.parse + [ "-verbose", Arg.Unit (fun () -> flag_verbose := true), + "Make output verbose"; + "-camltk", Arg.Unit (fun () -> Flags.camltk := true), + "Make CamlTk interface"; + "-outdir", Arg.String (fun s -> output_dir := s), + "output directory"; + "-debugpp", Arg.Unit (fun () -> Ppexec.debug := true), + "debug preprocessor" + ] + (fun filename -> input_name := filename) + "Usage: tkcompiler <source file>" ; + if !output_dir = "" then begin + prerr_endline "specify -outdir option"; + exit 1 + end; + try + verbose_endline "Parsing..."; + parse_file !input_name; + verbose_endline "Compiling..."; + compile (); + verbose_endline "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 () diff --git a/ocaml-binary-annot/otherlibs/labltk/compiler/parser.mly b/ocaml-binary-annot/otherlibs/labltk/compiler/parser.mly new file mode 100644 index 0000000000..15ced65f8d --- /dev/null +++ b/ocaml-binary-annot/otherlibs/labltk/compiler/parser.mly @@ -0,0 +1,330 @@ +/***********************************************************************/ +/* */ +/* MLTk, Tcl/Tk interface of Objective Caml */ +/* */ +/* Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis */ +/* projet Cristal, INRIA Rocquencourt */ +/* Jacques Garrigue, Kyoto University RIMS */ +/* */ +/* Copyright 2002 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, with the special exception on linking */ +/* described in file ../LICENSE. */ +/* */ +/***********************************************************************/ + +/* $Id$ */ + +%{ + +open Tables + +%} + +/* Tokens */ +%token <string> IDENT +%token <string> STRING +%token EOF + +%token LPAREN /* "(" */ +%token RPAREN /* ")" */ +%token COMMA /* "," */ +%token SEMICOLON /* ";" */ +%token COLON /* ":" */ +%token QUESTION /* "?" */ +%token LBRACKET /* "[" */ +%token RBRACKET /* "]" */ +%token LBRACE /* "{" */ +%token RBRACE /* "}" */ +%token SLASH /* "/" */ + +%token TYINT /* "int" */ +%token TYFLOAT /* "float" */ +%token TYBOOL /* "bool" */ +%token TYCHAR /* "char" */ +%token TYSTRING /* "string" */ +%token LIST /* "list" */ + +%token AS /* "as" */ +%token VARIANT /* "variant" */ +%token WIDGET /* "widget" */ +%token OPTION /* "option" */ +%token TYPE /* "type" */ +%token SEQUENCE /* "sequence" */ +%token SUBTYPE /* "subtype" */ +%token FUNCTION /* "function" */ +%token MODULE /* "module" */ +%token EXTERNAL /* "external" */ +%token UNSAFE /* "unsafe" */ +/* Entry points */ +%start entry +%type <unit> entry + +%% +TypeName: + IDENT { String.uncapitalize $1 } + | WIDGET { "widget" } +; + +/* Atomic types */ +Type0 : + TYINT + { Int } + | TYFLOAT + { Float } + | TYBOOL + { Bool } + | TYCHAR + { Char } + | TYSTRING + { String } + | TypeName + { UserDefined $1 } +; + +/* Camltk/Labltk types */ +Type0_5: + | Type0 SLASH Type0 { if !Flags.camltk then $1 else $3 } + | Type0 { $1 } +; + +/* with subtypes */ +Type1 : + Type0_5 + { $1 } + | TypeName LPAREN IDENT RPAREN + { Subtype ($1, $3) } + | WIDGET LPAREN IDENT RPAREN + { Subtype ("widget", $3) } + | OPTION LPAREN IDENT RPAREN + { Subtype ("options", $3) } + | Type1 AS STRING + { As ($1, $3) } + | LBRACE Type_list RBRACE + { Product $2 } +; + +/* with list constructors */ +Type2 : + Type1 + { $1 } + | Type2 LIST + { List $1 } +; + +Labeled_type2 : + Type2 + { "", $1 } + | IDENT COLON Type2 + { $1, $3 } +; + +/* products */ +Type_list : + Type2 COMMA Type_list + { $1 :: $3 } + | Type2 + { [$1] } +; + +/* records */ +Type_record : + Labeled_type2 COMMA Type_record + { $1 :: $3 } + | Labeled_type2 + { [$1] } +; + +/* callback arguments or function results*/ +FType : + LPAREN RPAREN + { Unit } + | LPAREN Type2 RPAREN + { $2 } + | LPAREN Type_record RPAREN + { Record $2 } +; + +Type : + Type2 + { $1 } + | FUNCTION FType + { Function $2 } +; + + + +SimpleArg: + STRING + {StringArg $1} + | Type + {TypeArg ("", $1) } +; + +Arg: + STRING + {StringArg $1} + | Type + {TypeArg ("", $1) } + | IDENT COLON Type + {TypeArg ($1, $3)} + | QUESTION IDENT COLON LBRACKET SimpleArgList RBRACKET DefaultList + {OptionalArgs ( $2, $5, $7 )} + | QUESTION WIDGET COLON LBRACKET SimpleArgList RBRACKET DefaultList + {OptionalArgs ( "widget", $5, $7 )} + | QUESTION IDENT COLON LBRACKET SimpleArgList RBRACKET + {OptionalArgs ( $2, $5, [] )} + | QUESTION WIDGET COLON LBRACKET SimpleArgList RBRACKET + {OptionalArgs ( "widget", $5, [] )} + | WIDGET COLON Type + {TypeArg ("widget", $3)} + | Template + { $1 } +; + +SimpleArgList: + SimpleArg SEMICOLON SimpleArgList + { $1 :: $3} + | SimpleArg + { [$1] } +; + +ArgList: + Arg SEMICOLON ArgList + { $1 :: $3} + | Arg + { [$1] } +; + +/* DefaultList Only one TypeArg in ArgList and it must be unlabeled */ +DefaultList : + LBRACKET LBRACE ArgList RBRACE RBRACKET + {$3} + +/* Template */ +Template : + LBRACKET ArgList RBRACKET + { ListArg $2 } +; + + +/* Constructors for type declarations */ +Constructor : + IDENT Template + {{ component = Constructor; + ml_name = $1; + var_name = getvarname $1 $2; + template = $2; + result = Unit; + safe = true }} + | IDENT LPAREN IDENT RPAREN Template + {{ component = Constructor; + ml_name = $1; + var_name = $3; + template = $5; + result = Unit; + safe = true }} +; + +AbbrevConstructor : + Constructor + { Full $1 } + | IDENT + { Abbrev $1 } +; + +Constructors : + Constructor Constructors + { $1 :: $2 } +| Constructor + { [$1] } +; + +AbbrevConstructors : + AbbrevConstructor AbbrevConstructors + { $1 :: $2 } +| AbbrevConstructor + { [$1] } +; + +Safe: + /* */ + { true } + | UNSAFE + { false } + +Command : + Safe FUNCTION FType IDENT Template + {{component = Command; ml_name = $4; var_name = ""; + template = $5; result = $3; safe = $1 }} +; + +External : + Safe EXTERNAL IDENT STRING + {{component = External; ml_name = $3; var_name = ""; + template = StringArg $4; result = Unit; safe = $1}} +; + +Option : + OPTION IDENT Template + {{component = Constructor; ml_name = $2; var_name = getvarname $2 $3; + template = $3; result = Unit; safe = true }} + /* Abbreviated */ +| OPTION IDENT LPAREN IDENT RPAREN Template + {{component = Constructor; ml_name = $2; var_name = $4; + template = $6; result = Unit; safe = true }} + /* Abbreviated */ +| OPTION IDENT + { retrieve_option $2 } +; + +WidgetComponents : + /* */ + { [] } + | Command WidgetComponents + { $1 :: $2 } + | Option WidgetComponents + { $1 :: $2 } + | External WidgetComponents + { $1 :: $2 } +; + +ModuleComponents : + /* */ + { [] } + | Command ModuleComponents + { $1 :: $2 } + | External ModuleComponents + { $1 :: $2 } +; + +ParserArity : + /* */ + { OneToken } + | SEQUENCE + { MultipleToken } +; + + + +entry : + TYPE ParserArity TypeName LBRACE Constructors RBRACE + { enter_type $3 $2 $5 } +| VARIANT TYPE ParserArity TypeName LBRACE Constructors RBRACE + { enter_type $4 $3 $6 ~variant: true } +| TYPE ParserArity TypeName EXTERNAL + { enter_external_type $3 $2 } +| SUBTYPE ParserArity OPTION LPAREN IDENT RPAREN LBRACE AbbrevConstructors RBRACE + { enter_subtype "options" $2 $5 $8 } +| SUBTYPE ParserArity TypeName LPAREN IDENT RPAREN LBRACE AbbrevConstructors RBRACE + { enter_subtype $3 $2 $5 $8 } +| Command + { enter_function $1 } +| WIDGET IDENT LBRACE WidgetComponents RBRACE + { enter_widget $2 $4 } +| MODULE IDENT LBRACE ModuleComponents RBRACE + { enter_module (String.uncapitalize $2) $4 } +| EOF + { raise End_of_file } +; diff --git a/ocaml-binary-annot/otherlibs/labltk/compiler/pp.ml b/ocaml-binary-annot/otherlibs/labltk/compiler/pp.ml new file mode 100644 index 0000000000..5c46766af7 --- /dev/null +++ b/ocaml-binary-annot/otherlibs/labltk/compiler/pp.ml @@ -0,0 +1,23 @@ +(***********************************************************************) +(* *) +(* MLTk, Tcl/Tk interface of Objective Caml *) +(* *) +(* Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis *) +(* projet Cristal, INRIA Rocquencourt *) +(* Jacques Garrigue, Kyoto University RIMS *) +(* *) +(* Copyright 2002 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, with the special exception on linking *) +(* described in file LICENSE found in the Objective Caml source tree. *) +(* *) +(***********************************************************************) + +let _ = + try + let code_list = Ppparse.parse_channel stdin in + List.iter (Ppexec.exec (fun _ -> ()) print_string) code_list + with + | Ppparse.Error s -> prerr_endline s; exit 2 +;; diff --git a/ocaml-binary-annot/otherlibs/labltk/compiler/ppexec.ml b/ocaml-binary-annot/otherlibs/labltk/compiler/ppexec.ml new file mode 100644 index 0000000000..71118b9601 --- /dev/null +++ b/ocaml-binary-annot/otherlibs/labltk/compiler/ppexec.ml @@ -0,0 +1,60 @@ +(***********************************************************************) +(* *) +(* MLTk, Tcl/Tk interface of Objective Caml *) +(* *) +(* Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis *) +(* projet Cristal, INRIA Rocquencourt *) +(* Jacques Garrigue, Kyoto University RIMS *) +(* *) +(* Copyright 2002 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, with the special exception on linking *) +(* described in file LICENSE found in the Objective Caml source tree. *) +(* *) +(***********************************************************************) + +open Code + +let debug = ref false +let defined = ref [] +let linenum = ref 1 + +let rec nop = function + | Line _ -> incr linenum + | Ifdef (_, _, c1, c2o) -> + List.iter nop c1; + begin match c2o with + | Some c2 -> List.iter nop c2 + | None -> () + end + | _ -> () +;; + +let rec exec lp f = function + | Line line -> + if !debug then + prerr_endline (Printf.sprintf "%03d: %s" !linenum + (String.sub line 0 ((String.length line) - 1))); + f line; incr linenum + | Ifdef (sw, k, c1, c2o) -> + if List.mem k !defined = sw then begin + List.iter (exec lp f) c1; + begin match c2o with + | Some c2 -> List.iter nop c2 + | None -> () + end; + lp !linenum + end else begin + List.iter nop c1; + match c2o with + | Some c2 -> + lp !linenum; + List.iter (exec lp f) c2 + | None -> () + end + | Define k -> defined := k :: !defined + | Undef k -> + defined := List.fold_right (fun k' s -> + if k = k' then s else k' :: s) [] !defined +;; diff --git a/ocaml-binary-annot/otherlibs/labltk/compiler/pplex.mli b/ocaml-binary-annot/otherlibs/labltk/compiler/pplex.mli new file mode 100644 index 0000000000..4eaa183b24 --- /dev/null +++ b/ocaml-binary-annot/otherlibs/labltk/compiler/pplex.mli @@ -0,0 +1,18 @@ +(***********************************************************************) +(* *) +(* MLTk, Tcl/Tk interface of Objective Caml *) +(* *) +(* Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis *) +(* projet Cristal, INRIA Rocquencourt *) +(* Jacques Garrigue, Kyoto University RIMS *) +(* *) +(* Copyright 2002 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, with the special exception on linking *) +(* described in file LICENSE found in the Objective Caml source tree. *) +(* *) +(***********************************************************************) + +exception Error of string +val token : Lexing.lexbuf -> Ppyac.token diff --git a/ocaml-binary-annot/otherlibs/labltk/compiler/pplex.mll b/ocaml-binary-annot/otherlibs/labltk/compiler/pplex.mll new file mode 100644 index 0000000000..313d1f2dd5 --- /dev/null +++ b/ocaml-binary-annot/otherlibs/labltk/compiler/pplex.mll @@ -0,0 +1,56 @@ +(***********************************************************************) +(* *) +(* MLTk, Tcl/Tk interface of Objective Caml *) +(* *) +(* Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis *) +(* projet Cristal, INRIA Rocquencourt *) +(* Jacques Garrigue, Kyoto University RIMS *) +(* *) +(* Copyright 2002 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, with the special exception on linking *) +(* described in file ../LICENSE. *) +(* *) +(***********************************************************************) + +{ +open Ppyac +exception Error of string +let linenum = ref 1 +} + +let blank = [' ' '\013' '\009' '\012'] +let identchar = + ['A'-'Z' 'a'-'z' '_' '\192'-'\214' '\216'-'\246' '\248'-'\255' '\'' '0'-'9'] +let lowercase = ['a'-'z' '\223'-'\246' '\248'-'\255' '_'] +let uppercase = ['A'-'Z' '\192'-'\214' '\216'-'\222'] + +rule token = parse + blank + { token lexbuf } +| "##" [' ' '\t']* { directive lexbuf } +| ("#")? [^ '#' '\n']* '\n'? { + begin + let str = Lexing.lexeme lexbuf in + if String.length str <> 0 && str.[String.length str - 1] = '\n' then + begin + incr linenum + end; + OTHER (str) + end + } +| eof { EOF } + +and directive = parse +| "ifdef" [' ' '\t']+ { IFDEF (ident lexbuf)} +| "ifndef" [' ' '\t']+ { IFNDEF (ident lexbuf)} +| "else" { ELSE } +| "endif" { ENDIF } +| "define" [' ' '\t']+* { DEFINE (ident lexbuf)} +| "undef" [' ' '\t']+ { UNDEF (ident lexbuf)} +| _ { raise (Error (Printf.sprintf "unknown directive at line %d" !linenum))} + +and ident = parse +| lowercase identchar* | uppercase identchar* + { Lexing.lexeme lexbuf } +| _ { raise (Error (Printf.sprintf "illegal identifier at line %d" !linenum)) } diff --git a/ocaml-binary-annot/otherlibs/labltk/compiler/ppparse.ml b/ocaml-binary-annot/otherlibs/labltk/compiler/ppparse.ml new file mode 100644 index 0000000000..630d675dec --- /dev/null +++ b/ocaml-binary-annot/otherlibs/labltk/compiler/ppparse.ml @@ -0,0 +1,36 @@ +(***********************************************************************) +(* *) +(* MLTk, Tcl/Tk interface of Objective Caml *) +(* *) +(* Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis *) +(* projet Cristal, INRIA Rocquencourt *) +(* Jacques Garrigue, Kyoto University RIMS *) +(* *) +(* Copyright 2002 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, with the special exception on linking *) +(* described in file LICENSE found in the Objective Caml source tree. *) +(* *) +(***********************************************************************) + +exception Error of string + +let parse_channel ic = + let lexbuf = Lexing.from_channel ic in + try + Ppyac.code_list Pplex.token lexbuf + with + | Pplex.Error s -> + let loc_start = Lexing.lexeme_start lexbuf + and loc_end = Lexing.lexeme_end lexbuf + in + raise (Error (Printf.sprintf "parse error at char %d, %d: %s" + loc_start loc_end s)) + | Parsing.Parse_error -> + let loc_start = Lexing.lexeme_start lexbuf + and loc_end = Lexing.lexeme_end lexbuf + in + raise (Error (Printf.sprintf "parse error at char %d, %d" + loc_start loc_end)) +;; diff --git a/ocaml-binary-annot/otherlibs/labltk/compiler/ppyac.mly b/ocaml-binary-annot/otherlibs/labltk/compiler/ppyac.mly new file mode 100644 index 0000000000..da7ee681f2 --- /dev/null +++ b/ocaml-binary-annot/otherlibs/labltk/compiler/ppyac.mly @@ -0,0 +1,52 @@ +/***********************************************************************/ +/* */ +/* MLTk, Tcl/Tk interface of Objective Caml */ +/* */ +/* Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis */ +/* projet Cristal, INRIA Rocquencourt */ +/* Jacques Garrigue, Kyoto University RIMS */ +/* */ +/* Copyright 2002 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, with the special exception on linking */ +/* described in file ../LICENSE. */ +/* */ +/***********************************************************************/ + +%{ +open Code +%} + +%token <string> IFDEF +%token <string> IFNDEF +%token ELSE +%token ENDIF +%token <string> DEFINE +%token <string> UNDEF +%token <string> OTHER +%token EOF + +/* entry */ + +%start code_list +%type <Code.code list> code_list + +%% + +code_list: + /* empty */ { [] } + | code code_list { $1 :: $2 } +; + +code: + | DEFINE { Define $1 } + | UNDEF { Undef $1 } + | IFDEF code_list ELSE code_list ENDIF { Ifdef (true, $1, $2, Some ($4)) } + | IFNDEF code_list ELSE code_list ENDIF { Ifdef (false, $1, $2, Some ($4)) } + | IFDEF code_list ENDIF { Ifdef (true, $1, $2, None) } + | IFNDEF code_list ENDIF { Ifdef (false, $1, $2, None) } + | OTHER { Line $1 } +; + +%% diff --git a/ocaml-binary-annot/otherlibs/labltk/compiler/printer.ml b/ocaml-binary-annot/otherlibs/labltk/compiler/printer.ml new file mode 100644 index 0000000000..be70612aa2 --- /dev/null +++ b/ocaml-binary-annot/otherlibs/labltk/compiler/printer.ml @@ -0,0 +1,173 @@ +(***********************************************************************) +(* *) +(* MLTk, Tcl/Tk interface of Objective Caml *) +(* *) +(* Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis *) +(* projet Cristal, INRIA Rocquencourt *) +(* Jacques Garrigue, Kyoto University RIMS *) +(* *) +(* Copyright 2002 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, with the special exception on linking *) +(* described in file LICENSE found in the Objective Caml source tree. *) +(* *) +(***********************************************************************) + +open Tables;; + +open Format;; + +let escape_string s = + let more = ref 0 in + for i = 0 to String.length s - 1 do + match s.[i] with + | '\\' | '"' -> incr more + | _ -> () + done; + if !more = 0 then s else + let res = String.create (String.length s + !more) in + let j = ref 0 in + for i = 0 to String.length s - 1 do + let c = s.[i] in + match c with + | '\\' | '"' -> res.[!j] <- '\\'; incr j; res.[!j] <- c; incr j + | _ -> res.[!j] <- c; incr j + done; + res;; + +let escape_char c = if c = '\'' then "\\'" else String.make 1 c;; + +let print_quoted_string s = printf "\"%s\"" (escape_string s);; +let print_quoted_char c = printf "'%s'" (escape_char c);; +let print_quoted_int i = + if i < 0 then printf "(%d)" i else printf "%d" i;; +let print_quoted_float f = + if f <= 0.0 then printf "(%f)" f else printf "%f" f;; + +(* Iterators *) +let print_list f l = + printf "@[<1>["; + let rec pl = function + | [] -> printf "@;<0 -1>]@]" + | [x] -> f x; pl [] + | x :: xs -> f x; printf ";@ "; pl xs in + pl l;; + +let print_array f v = + printf "@[<2>[|"; + let l = Array.length v in + if l >= 1 then f v.(0); + if l >= 2 then + for i = 1 to l - 1 do + printf ";@ "; f v.(i) + done; + printf "@;<0 -1>|]@]";; + +let print_option f = function + | None -> print_string "None" + | Some x -> printf "@[<1>Some@ "; f x; printf "@]";; + +let print_bool = function + | true -> print_string "true" | _ -> print_string "false";; + +let print_poly x = print_string "<poly>";; + +(* Types of the description language *) +let rec print_mltype = function + | Unit -> printf "Unit" | Int -> printf "Int" | Float -> printf "Float" + | Bool -> printf "Bool" | Char -> printf "Char" | String -> printf "String" + | List m -> printf "@[<1>(%s@ " "List"; print_mltype m; printf ")@]" + | Product l_m -> + printf "@[<1>(%s@ " "Product"; print_list print_mltype l_m; printf ")@]" + | Record l_t_s_m -> + printf "@[<1>(%s@ " "Record"; + print_list + (function (s, m) -> + printf "@[<1>("; print_quoted_string s; printf ",@ "; print_mltype m; + printf ")@]") + l_t_s_m; + printf ")@]" + | UserDefined s -> + printf "@[<1>(%s@ " "UserDefined"; print_quoted_string s; printf ")@]" + | Subtype (s, s0) -> + printf "@[<1>(%s@ " "Subtype"; printf "@[<1>("; print_quoted_string s; + printf ",@ "; print_quoted_string s0; printf ")@]"; printf ")@]" + | Function m -> + printf "@[<1>(%s@ " "Function"; print_mltype m; printf ")@]" + | As (m, s) -> + printf "@[<1>(%s@ " "As"; printf "@[<1>("; print_mltype m; printf ",@ "; + print_quoted_string s; printf ")@]"; printf ")@]";; + +let rec print_template = function + | StringArg s -> + printf "@[<1>(%s@ " "StringArg"; print_quoted_string s; printf ")@]" + | TypeArg (s, m) -> + printf "@[<1>(%s@ " "TypeArg"; printf "@[<1>("; print_quoted_string s; + printf ",@ "; print_mltype m; printf ")@]"; printf ")@]" + | ListArg l_t -> + printf "@[<1>(%s@ " "ListArg"; print_list print_template l_t; + printf ")@]" + | OptionalArgs (s, l_t, l_t0) -> + printf "@[<1>(%s@ " "OptionalArgs"; printf "@[<1>("; + print_quoted_string s; printf ",@ "; print_list print_template l_t; + printf ",@ "; print_list print_template l_t0; printf ")@]"; printf ")@]";; + +(* Sorts of components *) +let rec print_component_type = function + | Constructor -> printf "Constructor" | Command -> printf "Command" + | External -> printf "External";; + +(* Full definition of a component *) +let rec print_fullcomponent = function + {component = c; ml_name = s; var_name = s0; template = t; result = m; + safe = b; + } -> + printf "@[<1>{"; printf "@[<1>component =@ "; print_component_type c; + printf ";@]@ "; printf "@[<1>ml_name =@ "; print_quoted_string s; + printf ";@]@ "; printf "@[<1>var_name =@ "; print_quoted_string s0; + printf ";@]@ "; printf "@[<1>template =@ "; print_template t; + printf ";@]@ "; printf "@[<1>result =@ "; print_mltype m; printf ";@]@ "; + printf "@[<1>safe =@ "; print_bool b; printf ";@]@ "; printf "@,}@]";; + +(* components are given either in full or abbreviated *) +let rec print_component = function + | Full f -> printf "@[<1>(%s@ " "Full"; print_fullcomponent f; printf ")@]" + | Abbrev s -> + printf "@[<1>(%s@ " "Abbrev"; print_quoted_string s; printf ")@]";; + +(* A type definition *) +(* + requires_widget_context: the converter of the type MUST be passed + an additional argument of type Widget. +*) +let rec print_parser_arity = function + | OneToken -> printf "OneToken" | MultipleToken -> printf "MultipleToken";; + +let rec print_type_def = function + {parser_arity = p; constructors = l_f; subtypes = l_t_s_l_f; + requires_widget_context = b; variant = b0; + } -> + printf "@[<1>{"; printf "@[<1>parser_arity =@ "; print_parser_arity p; + printf ";@]@ "; printf "@[<1>constructors =@ "; + print_list print_fullcomponent l_f; printf ";@]@ "; + printf "@[<1>subtypes =@ "; + print_list + (function (s, l_f0) -> + printf "@[<1>("; print_quoted_string s; printf ",@ "; + print_list print_fullcomponent l_f0; printf ")@]") + l_t_s_l_f; + printf ";@]@ "; printf "@[<1>requires_widget_context =@ "; print_bool b; + printf ";@]@ "; printf "@[<1>variant =@ "; print_bool b0; printf ";@]@ "; + printf "@,}@]";; + +let rec print_module_type = function + | Widget -> printf "Widget" | Family -> printf "Family";; + +let rec print_module_def = function + {module_type = m; commands = l_f; externals = l_f0; } -> + printf "@[<1>{"; printf "@[<1>module_type =@ "; print_module_type m; + printf ";@]@ "; printf "@[<1>commands =@ "; + print_list print_fullcomponent l_f; printf ";@]@ "; + printf "@[<1>externals =@ "; print_list print_fullcomponent l_f0; + printf ";@]@ "; printf "@,}@]";; diff --git a/ocaml-binary-annot/otherlibs/labltk/compiler/tables.ml b/ocaml-binary-annot/otherlibs/labltk/compiler/tables.ml new file mode 100644 index 0000000000..0663dfaadd --- /dev/null +++ b/ocaml-binary-annot/otherlibs/labltk/compiler/tables.ml @@ -0,0 +1,427 @@ +(***********************************************************************) +(* *) +(* MLTk, Tcl/Tk interface of Objective Caml *) +(* *) +(* Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis *) +(* projet Cristal, INRIA Rocquencourt *) +(* Jacques Garrigue, Kyoto University RIMS *) +(* *) +(* Copyright 2002 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, with the special exception on linking *) +(* described in file LICENSE found in the Objective Caml source tree. *) +(* *) +(***********************************************************************) + +(* $Id$ *) + +open StdLabels +open Support + +(* Internal compiler errors *) + +exception Compiler_Error of string +let fatal_error s = raise (Compiler_Error s) + + +(* Types of the description language *) +type mltype = + Unit + | Int + | Float + | Bool + | Char + | String + | List of mltype + | Product of mltype list + | Record of (string * mltype) list + | UserDefined of string + | Subtype of string * string + | Function of mltype (* arg type only *) + | As of mltype * string + +type template = + StringArg of string + | TypeArg of string * mltype + | ListArg of template list + | OptionalArgs of string * template list * template list + +(* Sorts of components *) +type component_type = + Constructor + | Command + | External + +(* Full definition of a component *) +type fullcomponent = { + component : component_type; + ml_name : string; (* used for camltk *) + var_name : string; (* used just for labltk *) + template : template; + result : mltype; + safe : bool + } + +let sort_components = + List.sort ~cmp:(fun c1 c2 -> compare c1.ml_name c2.ml_name) + + +(* components are given either in full or abbreviated *) +type component = + Full of fullcomponent + | Abbrev of string + +(* A type definition *) +(* + requires_widget_context: the converter of the type MUST be passed + an additional argument of type Widget. +*) + +type parser_arity = + OneToken +| MultipleToken + +type type_def = { + parser_arity : parser_arity; + mutable constructors : fullcomponent list; + mutable subtypes : (string * fullcomponent list) list; + mutable requires_widget_context : bool; + mutable variant : bool +} + +type module_type = + Widget + | Family + +type module_def = { + module_type : module_type; + commands : fullcomponent list; + externals : fullcomponent list +} + +(******************** The tables ********************) + +(* the table of all explicitly defined types *) +let types_table = (Hashtbl.create 37 : (string, type_def) Hashtbl.t) +(* "builtin" types *) +let types_external = ref ([] : (string * parser_arity) list) +(* dependancy order *) +let types_order = (Tsort.create () : string Tsort.porder) +(* Types of atomic values returned by Tk functions *) +let types_returned = ref ([] : string list) +(* Function table *) +let function_table = ref ([] : fullcomponent list) +(* Widget/Module table *) +let module_table = (Hashtbl.create 37 : (string, module_def) Hashtbl.t) + + +(* variant name *) +let rec getvarname ml_name temp = + let offhypben s = + let s = String.copy s in + if (try String.sub s ~pos:0 ~len:1 with _ -> "") = "-" then + String.sub s ~pos:1 ~len:(String.length s - 1) + else s + and makecapital s = + begin + try + let cd = s.[0] in + if cd >= 'a' && cd <= 'z' then + s.[0] <- Char.chr (Char.code cd + (Char.code 'A' - Char.code 'a')) + with + _ -> () + end; + s + in + let head = makecapital (offhypben begin + match temp with + StringArg s -> s + | TypeArg (s,t) -> s + | ListArg (h::_) -> getvarname ml_name h + | OptionalArgs (s,_,_) -> s + | ListArg [] -> "" + end) + in + let varname = if head = "" then ml_name + else if head.[0] >= 'A' && head.[0] <= 'Z' then head + else ml_name + in varname + +(***** Some utilities on the various tables *****) +(* Enter a new empty type *) +let new_type typname arity = + Tsort.add_element types_order typname; + let typdef = {parser_arity = arity; + constructors = []; + subtypes = []; + requires_widget_context = false; + variant = false} in + Hashtbl.add types_table typname typdef; + typdef + + +(* Assume that types not yet defined are not subtyped *) +(* Widget is builtin and implicitly subtyped *) +let is_subtyped s = + s = "widget" || + try + let typdef = Hashtbl.find types_table s in + typdef.subtypes <> [] + with + Not_found -> false + +let requires_widget_context s = + try + (Hashtbl.find types_table s).requires_widget_context + with + Not_found -> false + +let declared_type_parser_arity s = + try + (Hashtbl.find types_table s).parser_arity + with + Not_found -> + try List.assoc s !types_external + with + Not_found -> + prerr_string "Type "; prerr_string s; + prerr_string " is undeclared external or undefined\n"; + prerr_string ("Assuming cTKtoCAML"^s^" : string -> "^s^"\n"); + OneToken + +let rec type_parser_arity = function + Unit -> OneToken + | Int -> OneToken + | Float -> OneToken + | Bool -> OneToken + | Char -> OneToken + | String -> OneToken + | List _ -> MultipleToken + | Product _ -> MultipleToken + | Record _ -> MultipleToken + | UserDefined s -> declared_type_parser_arity s + | Subtype (s,_) -> declared_type_parser_arity s + | Function _ -> OneToken + | As (ty, _) -> type_parser_arity ty + +let enter_external_type s v = + types_external := (s,v)::!types_external + +(*** Stuff for topological Sort.list of types ***) +(* Make sure all types used in commands and functions are in *) +(* the table *) +let rec enter_argtype = function + Unit | Int | Float | Bool | Char | String -> () + | List ty -> enter_argtype ty + | Product tyl -> List.iter ~f:enter_argtype tyl + | Record tyl -> List.iter tyl ~f:(fun (l,t) -> enter_argtype t) + | UserDefined s -> Tsort.add_element types_order s + | Subtype (s,_) -> Tsort.add_element types_order s + | Function ty -> enter_argtype ty + | As (ty, _) -> enter_argtype ty + +let rec enter_template_types = function + StringArg _ -> () + | TypeArg (l,t) -> enter_argtype t + | ListArg l -> List.iter ~f:enter_template_types l + | OptionalArgs (_,tl,_) -> List.iter ~f:enter_template_types tl + +(* Find type dependancies on s *) +let rec add_dependancies s = + function + List ty -> add_dependancies s ty + | Product tyl -> List.iter ~f:(add_dependancies s) tyl + | Subtype(s',_) -> if s <> s' then Tsort.add_relation types_order (s', s) + | UserDefined s' -> if s <> s' then Tsort.add_relation types_order (s', s) + | Function ty -> add_dependancies s ty + | As (ty, _) -> add_dependancies s ty + | _ -> () + +let rec add_template_dependancies s = function + StringArg _ -> () + | TypeArg (l,t) -> add_dependancies s t + | ListArg l -> List.iter ~f:(add_template_dependancies s) l + | OptionalArgs (_,tl,_) -> List.iter ~f:(add_template_dependancies s) tl + +(* Assumes functions are not nested in products, which is reasonable due to syntax*) +let rec has_callback = function + StringArg _ -> false + | TypeArg (l,Function _ ) -> true + | TypeArg _ -> false + | ListArg l -> List.exists ~f:has_callback l + | OptionalArgs (_,tl,_) -> List.exists ~f:has_callback tl + +(*** Returned types ***) +let really_add ty = + if List.mem ty !types_returned then () + else types_returned := ty :: !types_returned + +let rec add_return_type = function + Unit -> () + | Int -> () + | Float -> () + | Bool -> () + | Char -> () + | String -> () + | List ty -> add_return_type ty + | Product tyl -> List.iter ~f:add_return_type tyl + | Record tyl -> List.iter tyl ~f:(fun (l,t) -> add_return_type t) + | UserDefined s -> really_add s + | Subtype (s,_) -> really_add s + | Function _ -> fatal_error "unexpected return type (function)" (* whoah *) + | As (ty, _) -> add_return_type ty + +(*** Update tables for a component ***) +let enter_component_types {template = t; result = r} = + add_return_type r; + enter_argtype r; + enter_template_types t + + +(******************** Types and subtypes ********************) +exception Duplicate_Definition of string * string +exception Invalid_implicit_constructor of string + +(* Checking duplicate definition of constructor in subtypes *) +let rec check_duplicate_constr allowed c = + function + [] -> false (* not defined *) + | c'::rest -> + if c.ml_name = c'.ml_name then (* defined *) + if allowed then + if c.template = c'.template then true (* same arg *) + else raise (Duplicate_Definition ("constructor",c.ml_name)) + else raise (Duplicate_Definition ("constructor", c.ml_name)) + else check_duplicate_constr allowed c rest + +(* Retrieve constructor *) +let rec find_constructor cname = function + [] -> raise (Invalid_implicit_constructor cname) + | c::l -> if c.ml_name = cname then c + else find_constructor cname l + +(* Enter a type, must not be previously defined *) +let enter_type typname ?(variant = false) arity constructors = + if Hashtbl.mem types_table typname then + raise (Duplicate_Definition ("type", typname)) else + let typdef = new_type typname arity in + if variant then typdef.variant <- true; + List.iter constructors ~f: + begin fun c -> + if not (check_duplicate_constr false c typdef.constructors) + then begin + typdef.constructors <- c :: typdef.constructors; + add_template_dependancies typname c.template + end; + (* Callbacks require widget context *) + typdef.requires_widget_context <- + typdef.requires_widget_context || + has_callback c.template + end + +(* Enter a subtype *) +let enter_subtype typ arity subtyp constructors = + (* Retrieve the type if already defined, else add a new one *) + let typdef = + try Hashtbl.find types_table typ + with Not_found -> new_type typ arity + in + if List.mem_assoc subtyp typdef.subtypes + then raise (Duplicate_Definition ("subtype", typ ^" "^subtyp)) + else begin + let real_constructors = + List.map constructors ~f: + begin function + Full c -> + if not (check_duplicate_constr true c typdef.constructors) + then begin + add_template_dependancies typ c.template; + typdef.constructors <- c :: typdef.constructors + end; + typdef.requires_widget_context <- + typdef.requires_widget_context || + has_callback c.template; + c + | Abbrev name -> find_constructor name typdef.constructors + end + in + (* TODO: duplicate def in subtype are not checked *) + typdef.subtypes <- + (subtyp , List.sort real_constructors + ~cmp:(fun c1 c2 -> compare c1.var_name c2.var_name)) :: + typdef.subtypes + end + +(******************** Widgets ********************) +(* used by the parser; when enter_widget is called, + all components are assumed to be in Full form *) +let retrieve_option optname = + let optiontyp = + try Hashtbl.find types_table "options" + with + Not_found -> raise (Invalid_implicit_constructor optname) + in find_constructor optname optiontyp.constructors + +(* Sort components by type *) +let rec add_sort l obj = + match l with + [] -> [obj.component ,[obj]] + | (s',l)::rest -> + if obj.component = s' then + (s',obj::l)::rest + else + (s',l)::(add_sort rest obj) + +let separate_components = List.fold_left ~f:add_sort ~init:[] + +let enter_widget name components = + if Hashtbl.mem module_table name then + raise (Duplicate_Definition ("widget/module", name)) else + let sorted_components = separate_components components in + List.iter sorted_components ~f: + begin function + Constructor, l -> + enter_subtype "options" MultipleToken + name (List.map ~f:(fun c -> Full c) l) + | Command, l -> + List.iter ~f:enter_component_types l + | External, _ -> () + end; + let commands = + try List.assoc Command sorted_components + with Not_found -> [] + and externals = + try List.assoc External sorted_components + with Not_found -> [] + in + Hashtbl.add module_table name + {module_type = Widget; commands = commands; externals = externals} + +(******************** Functions ********************) + +let enter_function comp = + enter_component_types comp; + function_table := comp :: !function_table + + +(******************** Modules ********************) +let enter_module name components = + if Hashtbl.mem module_table name then + raise (Duplicate_Definition ("widget/module", name)) else + let sorted_components = separate_components components in + List.iter sorted_components ~f: + begin function + Constructor, l -> fatal_error "unexpected Constructor" + | Command, l -> List.iter ~f:enter_component_types l + | External, _ -> () + end; + let commands = + try List.assoc Command sorted_components + with Not_found -> [] + and externals = + try List.assoc External sorted_components + with Not_found -> [] + in + Hashtbl.add module_table name + {module_type = Family; commands = commands; externals = externals} diff --git a/ocaml-binary-annot/otherlibs/labltk/compiler/tsort.ml b/ocaml-binary-annot/otherlibs/labltk/compiler/tsort.ml new file mode 100644 index 0000000000..6496eaae22 --- /dev/null +++ b/ocaml-binary-annot/otherlibs/labltk/compiler/tsort.ml @@ -0,0 +1,87 @@ +(***********************************************************************) +(* *) +(* MLTk, Tcl/Tk interface of Objective Caml *) +(* *) +(* Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis *) +(* projet Cristal, INRIA Rocquencourt *) +(* Jacques Garrigue, Kyoto University RIMS *) +(* *) +(* Copyright 2002 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, with the special exception on linking *) +(* described in file LICENSE found in the Objective Caml source tree. *) +(* *) +(***********************************************************************) + +(* $Id$ *) + +open StdLabels + +(* Topological Sort.list *) +(* d'apres More Programming Pearls *) + +(* node * pred count * successors *) + +type 'a entry = + {node : 'a; + mutable pred_count : int; + mutable successors : 'a entry list + } + +type 'a porder = 'a entry list ref + +exception Cyclic + +let find_entry order node = + let rec search_entry = + function + [] -> raise Not_found + | x::l -> if x.node = node then x else search_entry l + in + try + search_entry !order + with + Not_found -> let entry = {node = node; + pred_count = 0; + successors = []} in + order := entry::!order; + entry + +let create () = ref [] + +(* Inverted args because Sort.list builds list in reverse order *) +let add_relation order (succ,pred) = + let pred_entry = find_entry order pred + and succ_entry = find_entry order succ in + succ_entry.pred_count <- succ_entry.pred_count + 1; + pred_entry.successors <- succ_entry::pred_entry.successors + +(* Just add it *) +let add_element order e = + ignore (find_entry order e) + +let sort order = + let q = Queue.create () + and result = ref [] in + List.iter !order + ~f:(function {pred_count = n} as node -> + if n = 0 then Queue.add node q); + begin try + while true do + let t = Queue.take q in + result := t.node :: !result; + List.iter t.successors ~f: + begin fun s -> + let n = s.pred_count - 1 in + s.pred_count <- n; + if n = 0 then Queue.add s q + end + done + with + Queue.Empty -> + List.iter !order + ~f:(fun node -> if node.pred_count <> 0 + then raise Cyclic) + end; + !result |