summaryrefslogtreecommitdiffstats
path: root/otherlibs/labltk/compiler
diff options
context:
space:
mode:
Diffstat (limited to 'otherlibs/labltk/compiler')
-rw-r--r--otherlibs/labltk/compiler/Makefile36
-rw-r--r--otherlibs/labltk/compiler/compile.ml803
-rw-r--r--otherlibs/labltk/compiler/intf.ml83
-rw-r--r--otherlibs/labltk/compiler/lexer.mll141
-rw-r--r--otherlibs/labltk/compiler/maincompile.ml229
-rw-r--r--otherlibs/labltk/compiler/parser.mly312
-rw-r--r--otherlibs/labltk/compiler/tables.ml414
-rw-r--r--otherlibs/labltk/compiler/tsort.ml72
8 files changed, 0 insertions, 2090 deletions
diff --git a/otherlibs/labltk/compiler/Makefile b/otherlibs/labltk/compiler/Makefile
deleted file mode 100644
index 7d826a161..000000000
--- a/otherlibs/labltk/compiler/Makefile
+++ /dev/null
@@ -1,36 +0,0 @@
-include ../Makefile.config
-
-OBJS=tsort.cmo tables.cmo lexer.cmo parser.cmo compile.cmo intf.cmo \
- maincompile.cmo
-
-tkcompiler : $(OBJS)
- $(LABLC) $(LINKFLAGS) -o tkcompiler $(OBJS)
-
-lexer.ml: lexer.mll
- $(LABLLEX) lexer.mll
-
-parser.ml parser.mli: parser.mly
- $(LABLYACC) -v parser.mly
-
-clean :
- rm -f *.cm* parser.ml parser.mli lexer.ml tkcompiler parser.output
-
-scratch :
- rm -f *.cm* parser.ml parser.mli lexer.ml tkcompiler
-
-install:
- cp tkcompiler $(INSTALLDIR)
-
-.SUFFIXES :
-.SUFFIXES : .mli .ml .cmi .cmo .mlp
-
-.mli.cmi:
- $(LABLCOMP) $(COMPFLAGS) $<
-
-.ml.cmo:
- $(LABLCOMP) $(COMPFLAGS) $<
-
-depend: parser.ml parser.mli lexer.ml
- $(LABLDEP) *.mli *.ml > .depend
-
-include .depend
diff --git a/otherlibs/labltk/compiler/compile.ml b/otherlibs/labltk/compiler/compile.ml
deleted file mode 100644
index dbc777da1..000000000
--- a/otherlibs/labltk/compiler/compile.ml
+++ /dev/null
@@ -1,803 +0,0 @@
-(* $Id$ *)
-
-open Tables
-
-(* CONFIGURE *)
-(* if you set it true, ImagePhoto and ImageBitmap will annoy you... *)
-let safetype = false
-
-let lowercase s =
- let r = String.create len:(String.length s) in
- String.blit s pos:0 to:r to_pos:0 len:(String.length s);
- for i = 0 to String.length s - 1
- do
- let c = s.[i] in
- if c >= 'A' & c <= 'Z' then r.[i] <- Char.chr(Char.code c + 32)
- done;
- r
-
-let labeloff :at l = match l with
- "",t -> t
-| l ,t -> raise (Failure ("labeloff : " ^ l ^ " at " ^ at))
-
-let labelstring l = match l with
- "" -> ""
-| _ -> l ^ ":"
-
-let labelprint :w l = w (labelstring l)
-
-let small s =
- let sout = ref "" in
- for i=0 to String.length s - 1 do
- let c =
- if s.[i] >= 'A' && s.[i] <= 'Z' then
- Char.chr(Char.code(s.[i]) - (Char.code 'A' - Char.code 'a'))
- else s.[i]
- in
- sout := !sout ^ (String.make len:1 c)
- done;
- !sout
-
-let small_ident s =
- let idents = ["to"; "raise"; "in"; "class"; "new"]
- in
- let s = small s in
- if List.mem elt:s idents then (String.make len:1 s.[0])^s
- else s
-
-let gettklabel fc =
- match fc.template with
- ListArg( StringArg s :: _ ) ->
- if (try s.[0] = '-' with _ -> false) then
- String.sub s pos:1 len:(String.length s - 1)
- else
- if s = "" then small fc.ml_name else small s
- | _ -> raise (Failure "gettklabel")
-
-let count elt:x l =
- let count = ref 0 in
- List.iter fun:(fun y -> if x = y then incr count) l;
- !count
-
-let catenate_sep :sep =
- function
- [] -> ""
- | x::l -> List.fold_left fun:(fun :acc s' -> acc ^ sep ^ s') acc:x l
-
-(* Extract all types from a template *)
-let rec types_of_template = function
- StringArg _ -> []
- | TypeArg (l,t) -> [l,t]
- | ListArg l -> List.flatten (List.map fun:types_of_template l)
- | OptionalArgs (l,tl,_) ->
- begin
- match List.flatten (List.map fun: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 return then
- sub^"_"^sup^" list"
- else
- begin
- try
- let typdef = Hashtbl.find types_table key:sup in
- let fcl = List.assoc key:sub typdef.subtypes in
- let tklabels = List.map fun:gettklabel fcl in
- let l = List.map fcl fun:
- begin fun fc ->
- "?" ^ begin let p = gettklabel fc in
- if count elt:p tklabels > 1 then small fc.ml_name else p
- end
- ^ ":" ^
- let l = types_of_template fc.template in
- match l with
- [] -> "unit"
- | [lt] -> ppMLtype (labeloff lt at:"ppMLtype")
- | l ->
- "(" ^ catenate_sep sep:"*"
- (List.map l
- fun:(fun lt -> ppMLtype (labeloff lt at:"ppMLtype")))
- ^ ")"
- end in
- catenate_sep sep:" ->\n" l
- with
- Not_found -> Printf.eprintf "ppMLtype %s/%s\n" sup sub; exit (-1)
- end
- | List ty -> (ppMLtype ty) ^ " list"
- | Product tyl -> catenate_sep sep:" * " (List.map fun:ppMLtype tyl)
- | Record tyl ->
- catenate_sep sep:" * "
- (List.map tyl fun:(fun (l,t) -> labelstring l ^ ppMLtype t))
- | Subtype ("widget", sub) -> sub ^ " widget"
- | UserDefined "widget" ->
- if any then "any widget" else
- let c = String.make len:1 (Char.chr(Char.code 'a' + !counter))
- in
- incr counter;
- "'" ^ c ^ " widget"
- | UserDefined s ->
- (* a bit dirty hack for ImageBitmap and ImagePhoto *)
- begin
- try
- let typdef = Hashtbl.find types_table key:s in
- if typdef.variant then
- if return then try
- "[>" ^
- catenate_sep sep:"|"
- (List.map typdef.constructors fun:
- begin
- fun c ->
- "`" ^ c.var_name ^
- (match types_of_template c.template with
- [] -> ""
- | l -> " " ^ ppMLtype (Product (List.map l
- fun:(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') -> s'^"_"^s
- | Function (Product tyl) ->
- raise (Failure "Function (Product tyl) ? ppMLtype")
- | Function (Record tyl) ->
- "(" ^ catenate_sep sep:" -> "
- (List.map tyl fun:(fun (l,t) -> labelstring l ^ ppMLtype t))
- ^ " -> unit)"
- | Function ty ->
- "(" ^ (ppMLtype ty) ^ " -> unit)"
- | As (_, s) -> s
- in
- ppMLtype
-
-(* Produce a documentation version of a template *)
-let rec ppTemplate = function
- StringArg s -> s
- | TypeArg (l,t) -> "<" ^ ppMLtype t ^ ">"
- | ListArg l -> "{" ^ catenate_sep sep:" " (List.map fun:ppTemplate l) ^ "}"
- | OptionalArgs (l,tl,d) ->
- "?" ^ l ^ "{" ^ catenate_sep sep:" " (List.map fun:ppTemplate tl)
- ^ "}[<" ^ catenate_sep sep:" " (List.map fun:ppTemplate d) ^ ">]"
-
-let doc_of_template = function
- ListArg l -> catenate_sep sep:" " (List.map fun: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
- fun:(labeloff at:"write_constructor"))))
- end;
- w "\t\t(* 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 fun:
- begin fun x ->
- w "\n\t| ";
- write_constructor :w x
- end
-
-(* Write an ML variant *)
-let write_variant :w {ml_name = mlconstr; var_name = varname; template = t} =
- w "`";
- w varname;
- begin match types_of_template t with
- [] -> ()
- | l ->
- w " ";
- w (ppMLtype any:true def:true
- (Product (List.map l fun:(labeloff at:"write_variant"))))
- end;
- w "\t\t(* tk option: "; w (doc_of_template t); w " *)"
-
-let write_variants :w = function
- [] -> fatal_error "empty variants"
- | x::l ->
- write_variant :w x;
- List.iter l fun:
- begin fun x ->
- w "\n | ";
- write_variant :w x
- end
-
-(* Definition of a type *)
-let write_type intf:w impl:w' name def:typdef =
-(* if typdef.subtypes = [] then (* If there is no subtypes *)
- begin
- (* The type itself *)
- (* Put markers for extraction *)
- w "(* type *)\n";
- w ("type "^name^" =\n\t");
- write_constructors :w (sort_components typdef.constructors);
- w "\n(* /type *)\n\n"
- end
- else
-*)
- begin
- if typdef.subtypes = [] then
- begin
- w "(* Variant type *)\n";
- w ("type "^name^" = [\n ");
- write_variants :w (sort_components typdef.constructors);
- w "\n]\n\n"
- end
- else
- begin
- (* Dynamic Subtyping *)
- (* All the subtypes *)
- List.iter typdef.subtypes fun:
- begin fun (s,l) ->
- w ("type "^s^"_"^name^" = [\n\t");
- write_variants w:w (sort_components l);
- w ("]\n\n")
- end
- end
- end
-
-(************************************************************)
-(* Converters *)
-(************************************************************)
-
-let rec converterTKtoCAML argname as:ty =
- match ty with
- Int -> "int_of_string " ^ argname
- | Float -> "float_of_string " ^ argname
- | Bool -> "(match " ^ argname ^" with
- \"1\" -> true
- | \"0\" -> false
- | s -> Pervasives.raise (Invalid_argument (\"cTKtoCAMLbool\" ^ s)))"
- | Char -> "String.get "^argname ^" 0"
- | String -> argname
- | UserDefined s -> "cTKtoCAML"^s^" "^argname
- | Subtype ("widget",s') ->
- "(Obj.magic (cTKtoCAMLwidget "^argname^") : "^s'^" widget)"
- | Subtype (s,s') -> "cTKtoCAML"^s'^"_"^s^" "^argname
- | List ty ->
- begin match type_parser_arity ty with
- OneToken ->
- "(List.map (function x -> " ^ (converterTKtoCAML "x) " as:ty)
- ^ argname ^ ")"
- | MultipleToken ->
- "iterate_converter (function x -> " ^
- (converterTKtoCAML "x) " as:ty) ^ argname ^ ")"
- end
- | As (ty, _) -> converterTKtoCAML argname as:ty
- | t -> (prerr_endline ("ERROR with "^argname^" "^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 fname of:ty =
- match ty with
- Unit -> "(function _ -> "^fname^" ())"
- | As (ty, _) -> wrapper_code fname of:ty
- | ty ->
- "(function args ->\n\t\t" ^
- 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 fun:
- begin fun v (l,ty) ->
- match type_parser_arity ty with
- OneToken ->
- "let ("^v^",args) = " ^
- converterTKtoCAML "(List.hd args)" as:ty ^
- ", List.tl args in\n\t\t"
- | MultipleToken ->
- "let ("^v^",args) = " ^
- converterTKtoCAML "args" as:ty ^
- " in\n\t\t"
- end in
- catenate_sep sep:"" readarg ^ fname ^ " " ^
- catenate_sep sep:" "
- (List.map2 fun:(fun v (l,_) -> labelstring l^v) vnames tyl)
-
- (* all other types are read in one operation *)
- | List ty ->
- fname ^ "(" ^ converterTKtoCAML "args" as:ty ^ ")"
- | String ->
- fname ^ "(" ^ converterTKtoCAML "(List.hd args)" as:ty ^ ")"
- | ty ->
- begin match type_parser_arity ty with
- OneToken ->
- fname ^ "(" ^ converterTKtoCAML "(List.hd args)" as:ty ^ ")"
- | MultipleToken ->
- "let (v,_) = " ^ converterTKtoCAML "args" as:ty ^
- " in\n\t\t" ^ fname ^ " 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 pred:
- begin fun c ->
- match c.template with
- ListArg [StringArg s] ->
- pp.zeroary <- (s,"`" ^ c.var_name)::
- pp.zeroary; true
- | ListArg [TypeArg(_,Int)] | ListArg[TypeArg(_,Float)] ->
- if pp.intpar <> [] then false
- else (pp.intpar <- ["`" ^ c.var_name]; true)
- | ListArg [TypeArg(_,String)] ->
- if pp.stringpar <> [] then false
- else (pp.stringpar <- ["`" ^ c.var_name]; true)
- | _ -> false
- end
- then ParserPieces pp
- else NoParser
-
-
-(* We can generate parsers only for simple types *)
-(* we should avoid multiple walks *)
-let 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 ("\tmatch n with\n");
- let first = ref true in
- List.iter pp.zeroary fun:
- begin fun (tk,ml) ->
- if not !first then w "\t| " else w "\t";
- first := false;
- 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
- if not !first then w "\t| " else w "\t";
- w final;
- w "\n\n"
- in
- begin
- write :name consts:typdef.constructors;
- List.iter typdef.subtypes fun: begin
- fun (subname,consts) -> write name:(subname^"_"^name) :consts
- end
- end
-
-(******************************)
-(* 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 as:ty =
- match ty with
- Int -> "TkToken (string_of_int " ^ argname ^ ")"
- | Float -> "TkToken (string_of_float " ^ argname ^ ")"
- | Bool -> "if "^argname^" then TkToken \"1\" else TkToken \"0\""
- | Char -> "TkToken (Char.escaped " ^ argname ^ ")"
- | String -> "TkToken " ^ argname
- | As (ty, _) -> converterCAMLtoTK :context_widget argname as:ty
- | UserDefined s ->
- let name = "cCAMLtoTK"^s^" " in
- let args = argname in
-(*
- let args =
- if is_subtyped s then (* unconstraint subtype *)
- s^"_any_table "^args
- else args in
-*)
- let args =
- if requires_widget_context s then
- context_widget^" "^args
- else args in
- name^args
- | Subtype ("widget",s') ->
- let name = "cCAMLtoTKwidget" in
- let args = "("^argname^" : "^s'^" widget)" in
-(*
- let args =
- if requires_widget_context s then
- context_widget^" "^args
- else args in
-*)
- name^args
- | Subtype (s,s') ->
- let name = "cCAMLtoTK"^s'^"_"^s^" " in
- let args = if safetype then "("^argname^" : "^s'^"_"^s^")" else argname
- in
-(*
- let args = s^"_"^s'^"_table "^argname in
-*)
- let args =
- if requires_widget_context s then
- context_widget^" "^args
- else args in
- name^args
- | Function _ -> fatal_error "unexpected function type in converterCAMLtoTK"
- | Unit -> fatal_error "unexpected unit type in converterCAMLtoTK"
- | Product _ -> fatal_error "unexpected product type in converterCAMLtoTK"
- | Record _ -> fatal_error "unexpected product type in converterCAMLtoTK"
- | List ty -> fatal_error "unexpected list 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) as ty)) ->
- let typdef = Hashtbl.find key:sup types_table in
- let classdef = List.assoc key:sub typdef.subtypes in
- let lbl = gettklabel (List.hd classdef) in
- catch_opts := (sub^"_"^sup, lbl);
- newvar := newvar2;
- "TkTokenList (List.map fun:(function x -> "
- ^ converterCAMLtoTK :context_widget "x" as:ty ^ ") opts)"
- | TypeArg (l,List ty) ->
- "TkTokenList (List.map fun:(function x -> "
- ^ converterCAMLtoTK :context_widget "x" as:ty
- ^ ") " ^ !newvar l ^ ")"
- | TypeArg (l,Function tyarg) ->
- "let id = register_callback " ^context_widget
- ^ " callback: "^ wrapper_code (!newvar l) of:tyarg
- ^ " in TkToken (\"camlcb \"^id)"
- | TypeArg (l,ty) -> converterCAMLtoTK :context_widget (!newvar l) as:ty
- | ListArg l ->
- "TkQuote (TkTokenList ["
- ^ catenate_sep sep:";\n\t" (List.map fun:coderec l) ^ "])"
- | OptionalArgs (l,tl,d) ->
- let nv = !newvar ("?"^l) in
- optionvar := Some nv; (* Store *)
- let argstr = catenate_sep sep:"; " (List.map fun:coderec tl) in
- let defstr = catenate_sep sep:"; " (List.map fun: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 ->
- "[|" ^ catenate_sep sep:";\n\t" (List.map fun:coderec l) ^ "|]"
- | _ -> "[|" ^ coderec template ^ "|]"
- else
- match template with
- ListArg [x] -> coderec x
- | ListArg l ->
- "TkTokenList ["
- ^ catenate_sep sep:";\n\t" (List.map fun: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 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 (catenate_sep sep:", " (List.map fun:(labeloff at:"write_clause") l));
- w ")";
- warrow()
- end;
- w code
-
-
-(* The full converter *)
-let write_CAMLtoTK :w def:typdef ?safetype:st{=true} name =
- let write_one name constrs =
- w ("let cCAMLtoTK"^name);
- let context_widget =
- if typdef.requires_widget_context then begin
- w " w"; "w"
- end
- else
- "dummy" in
- if safetype && st then
- w (" : " ^ name ^ " -> tkArgs ");
- w(" = function\n\t");
- write_clause :w :context_widget (List.hd constrs);
- List.iter (List.tl constrs)
- fun:(fun c -> w "\n\t| "; write_clause :w :context_widget c);
- w "\n\n\n"
- in
- if typdef.subtypes == [] then
- write_one name typdef.constructors
- else
- List.iter typdef.subtypes fun:begin
- fun (subname,constrs) ->
- write_one (subname^"_"^name) constrs
- 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 ->
- w ("\tList.map fun: "^ converterTKtoCAML "(splitlist res)" as: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 "\tlet l = splitlist res in\n";
- w ("\t if List.length l <> " ^ string_of_int (List.length tyl) ^ "\n");
- w ("\t then Pervasives.raise (TkError (\"unexpected result: \" ^ res))");
- w ("\t else ");
- List.iter2 rnames tyl fun:
- begin fun r (l,ty) ->
- if l <> "" then raise (Failure "lables in return type!!!");
- w ("\tlet " ^ r ^ ", l = ");
- begin match type_parser_arity ty with
- OneToken ->
- w (converterTKtoCAML "(List.hd l)" as:ty); w (", List.tl l")
- | MultipleToken ->
- w (converterTKtoCAML "l" as:ty)
- end;
- w (" in\n")
- end;
- w (catenate_sep sep:"," rnames)
- | String ->
- w (converterTKtoCAML "res" as:String)
- | As (ty, _) -> write_result_parsing :w ty
- | ty ->
- match type_parser_arity ty with
- OneToken -> w (converterTKtoCAML "res" as:ty)
- | MultipleToken -> w (converterTKtoCAML "(splitlist res)" as:ty)
-
-let 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
- List.iter (lv@ov) fun:(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 List.iter uv fun:(fun x -> w " "; w x);
- w " ->\n"
- end else begin
- List.iter uv fun:(fun x -> w " "; w x);
- if (ov <> [] || lv = []) && uv = [] then w " ()";
- w " =\n"
- end;
- begin match def.result with
- Unit | As (Unit, _) ->
- w "tkEval "; w code; w ";()";
- | ty ->
- w "let res = tkEval "; w code ; w " in \n";
- write_result_parsing :w ty;
- end;
- if co <> "" then w ")";
- w "\n\n"
-
-let write_create :w clas =
- (w "let create :parent ?:name =\n" : unit);
- w (" "^ clas ^ "_options_optionals (fun options () ->\n");
- w (" let w = new_atom \"" ^ clas ^ "\" :parent ?:name in\n");
- w " tkEval [|";
- w ("TkToken \"" ^ clas ^ "\";\n");
- w (" TkToken (Widget.name w);\n");
- w (" TkTokenList (List.map fun:(cCAMLtoTK" ^ clas ^ "_options dummy) options) |];\n");
- w (" w)\n\n\n")
-
-(* builtin-code: the file (without suffix) is in .template... *)
-(* not efficient, but hell *)
-let write_external :w def =
- match def.template with
- StringArg fname ->
- let ic = open_in_bin (fname ^ ".ml") in
- begin try
- while true do
- w (input_line ic);
- w "\n"
- done
- with
- End_of_file -> close_in ic
- end
- | _ -> raise (Compiler_Error "invalid external definition")
-
-let write_catch_optionals :w clas def:typdef =
- if typdef.subtypes = [] then
- (* begin Printf.eprintf "No subtypes\n";() end *) ()
- else
- (* Printf.eprintf "Type constructors of %s\n" clas; *)
- List.iter typdef.subtypes fun:
- begin fun (subclass, classdefs) ->
-(*
- Printf.eprintf "Subclass %s" subclass;
- List.iter (fun fc ->
- Printf.eprintf " %s\n" fc.ml_name) classdefs;
-*)
- w ("let " ^ subclass ^"_"^ clas ^ "_optionals f = fun\n");
- let tklabels = List.map fun:gettklabel classdefs in
- let l =
- List.map classdefs fun:
- begin fun fc ->
- List.length (types_of_template fc.template),
- types_of_template fc.template,
- (* used as names of variants *)
- fc.var_name,
- begin let p = gettklabel fc in
- if count elt:p tklabels > 1 then small fc.ml_name else p
- end,
- small_ident fc.ml_name (* used as labels *)
- end in
- let p =
- List.map l fun:
- begin fun (_,_,_,s,si) ->
- if s = si then " ?:" ^ s
- else " ?" ^ s ^ ":" ^ si
- end in
- let v =
- List.map l fun:
- begin fun (i,t,c,s,si) ->
- let vars =
- if i = 0 then "()" else
- if i = 1 then "x"
- else
- let s = ref [] in
- for i=1 to i do
- s := !s @ ["x" ^ string_of_int i]
- done;
- "(" ^ catenate_sep sep:"," !s ^ ")"
- in
- let apvars =
- if i = 0 then ""
- (* VERY VERY QUICK HACK FOR 'a widget -> any widget *)
- else if i = 1 && vars = "x" && t = ["",UserDefined "widget"] then
- "(forget_type x)"
- else vars
- in
- "(maycons (fun " ^ vars ^ " -> " ^ "`" ^ c ^ " " ^ apvars ^ ") " ^ si
- end in
- w (catenate_sep sep:"\n" p);
- w " ->\n";
- w " f ";
- w (catenate_sep sep:"\n " v);
- w "\n []";
- w (String.make len:(List.length v) ')');
- w "\n\n"
- end
diff --git a/otherlibs/labltk/compiler/intf.ml b/otherlibs/labltk/compiler/intf.ml
deleted file mode 100644
index 6ecb84ae2..000000000
--- a/otherlibs/labltk/compiler/intf.ml
+++ /dev/null
@@ -1,83 +0,0 @@
-(* $Id$ *)
-
-(* Write .mli for widgets *)
-
-open Tables
-open Compile
-
-let write_create_p :w wname =
- w "val create :\n parent:'a widget ->\n ?name:string ->\n";
- begin
- try
- let option = Hashtbl.find types_table key:"options" in
- let classdefs = List.assoc key:wname option.subtypes in
- let tklabels = List.map fun:gettklabel classdefs in
- let l = List.map classdefs fun:
- begin fun fc ->
- begin let p = gettklabel fc in
- if count elt:p tklabels > 1 then small fc.ml_name else p
- end, fc.template
- end in
- w (catenate_sep sep:" ->\n"
- (List.map l fun:
- 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 fun:(labeloff at:"write_create_p") l)))
- end))
- with Not_found -> fatal_error "in write_create_p"
- end;
- w (" ->\n unit -> "^wname^" widget\n");
- w " (* [create p options ?name] creates a new widget with\n";
- w " parent p and new patch component name.\n";
- w " Options are restricted to the widget class subset,\n";
- w " and checked dynamically. *)\n"
-
-(* Unsafe: write special comment *)
-let 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
- List.iter (ls @ os @ us)
- fun:(fun (l,t) -> labelprint :w l; w (ppMLtype t :counter); w " -> ");
- 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\n"
- else w "\n(* /unsafe *)\n\n"
-
-let write_external_type :w def =
- match def.template with
- StringArg fname ->
- let ic = open_in_bin (fname ^ ".mli") in
- if not def.safe then w "(* unsafe *)\n";
- begin try
- while true do
- w (input_line ic);
- w "\n"
- done
- with End_of_file ->
- close_in ic;
- if def.safe then w "\n\n"
- else w "\n(* /unsafe *)\n\n"
- end
- | _ -> raise (Compiler_Error "invalid external definition")
diff --git a/otherlibs/labltk/compiler/lexer.mll b/otherlibs/labltk/compiler/lexer.mll
deleted file mode 100644
index 065edd3a4..000000000
--- a/otherlibs/labltk/compiler/lexer.mll
+++ /dev/null
@@ -1,141 +0,0 @@
-(* $Id$ *)
-
-{
-open Lexing
-open Parser
-
-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
- fun:(fun (str,tok) -> Hashtbl.add keyword_table key:str data: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 len: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 len:(String.length (!string_buff) * 2) in
- String.blit (!string_buff) pos:0 to:new_buff to_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 pos:i) - 48) +
- 10 * (Char.code(Lexing.lexeme_char lexbuf pos:(i+1)) - 48) +
- (Char.code(Lexing.lexeme_char lexbuf pos:(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 key: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}
- | "#" { comment 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 pos: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 pos:0);
- string lexbuf }
- | _
- { store_string_char(Lexing.lexeme_char lexbuf pos:0);
- string lexbuf }
-
-and comment = parse
- '\010' { incr current_line }
- | eof { () }
- | _ { comment lexbuf }
-
diff --git a/otherlibs/labltk/compiler/maincompile.ml b/otherlibs/labltk/compiler/maincompile.ml
deleted file mode 100644
index aa9412933..000000000
--- a/otherlibs/labltk/compiler/maincompile.ml
+++ /dev/null
@@ -1,229 +0,0 @@
-(* $Id$ *)
-
-open Tables
-open Compile
-open Intf
-
-let flag_verbose = ref false
-let verbose_string s =
- if !flag_verbose then prerr_string s
-let verbose_endline s =
- if !flag_verbose then prerr_endline s
-
-let input_name = ref "Widgets.src"
-
-let usage () =
- prerr_string "Usage: tkcompiler input.src\n";
- flush stderr;
- exit 1
-
-
-let prerr_error_header () =
- prerr_string "File \""; prerr_string !input_name;
- prerr_string "\", line ";
- prerr_string (string_of_int !Lexer.current_line);
- prerr_string ": "
-
-
-let parse_file filename =
- let ic = open_in_bin filename in
- try
- let lexbuf = Lexing.from_channel ic in
- while true do
- Parser.entry Lexer.main lexbuf
- done
- with
- Parsing.Parse_error ->
- close_in ic;
- prerr_error_header();
- prerr_string "Syntax error \n";
- exit 1
- | Lexer.Lexical_error s ->
- close_in ic;
- prerr_error_header();
- prerr_string "Lexical error (";
- prerr_string s;
- prerr_string ")\n";
- exit 1
- | Duplicate_Definition (s,s') ->
- close_in ic;
- prerr_error_header();
- prerr_string s; prerr_string " "; prerr_string s';
- prerr_string " is defined twice.\n";
- exit 1
- | Compiler_Error s ->
- close_in ic;
- prerr_error_header();
- prerr_string "Internal error: "; prerr_string s; prerr_string "\n";
- prerr_string "Please report bug\n";
- exit 1
- | End_of_file ->
- close_in ic
-
-(* hack to provoke production of cCAMLtoTKoptions_constrs *)
-let option_hack oc =
- try
- let typdef = Hashtbl.find types_table key:"options" in
- let hack =
- { parser_arity = OneToken;
- constructors =
- List.map typdef.constructors fun:
- begin fun c ->
- { component = Constructor;
- ml_name = c.ml_name;
- var_name = c.var_name; (* as variants *)
- template =
- begin match c.template with
- ListArg (x::_) -> x
- | _ -> fatal_error "bogus hack"
- end;
- result = UserDefined "options_constrs";
- safe = true }
- end;
- subtypes = [];
- requires_widget_context = false;
- variant = false }
- in
- write_CAMLtoTK w:(output_string to:oc) "options_constrs" def:hack safetype: false
- with Not_found -> ()
-
-let compile () =
-verbose_endline "Creating tkgen.ml ...";
- let oc = open_out_bin "lib/tkgen.ml" in
- let oc' = open_out_bin "lib/tkigen.ml" in
- let oc'' = open_out_bin "lib/tkfgen.ml" in
- let sorted_types = Tsort.sort types_order in
-verbose_endline " writing types ...";
- List.iter sorted_types fun:
- begin fun typname ->
-verbose_string (" "^typname^" ");
- try
- let typdef = Hashtbl.find types_table key:typname in
-verbose_string "type ";
- write_type intf:(output_string to:oc)
- impl:(output_string to:oc')
- typname def:typdef;
-verbose_string "C2T ";
- write_CAMLtoTK w:(output_string to:oc') typname def:typdef;
-verbose_string "T2C ";
- if List.mem elt:typname !types_returned then
- write_TKtoCAML w:(output_string to:oc') typname def:typdef;
-verbose_string "CO ";
- write_catch_optionals w:(output_string to:oc') typname def:typdef;
-verbose_endline "."
- with Not_found ->
- if not (List.mem_assoc key:typname !types_external) then
- begin
- verbose_string "Type ";
- verbose_string typname;
- verbose_string " is undeclared external or undefined\n"
- end
- else verbose_endline "."
- end;
- option_hack oc';
-verbose_endline " writing functions ...";
- List.iter fun:(write_function w:(output_string to:oc'')) !function_table;
- close_out oc;
- close_out oc';
- close_out oc'';
- (* Write the interface for public functions *)
- (* this interface is used only for documentation *)
-verbose_endline "Creating tkgen.mli ...";
- let oc = open_out_bin "lib/tkgen.mli" in
- List.iter (sort_components !function_table)
- fun:(write_function_type w:(output_string to:oc));
- close_out oc;
-verbose_endline "Creating other ml, mli ...";
- Hashtbl.iter module_table fun:
- begin fun key:wname data:wdef ->
-verbose_endline (" "^wname);
- let modname = wname in
- let oc = open_out_bin ("lib/" ^ modname ^ ".ml")
- and oc' = open_out_bin ("lib/" ^ modname ^ ".mli") in
- begin match wdef.module_type with
- Widget -> output_string to:oc' ("(* The "^wname^" widget *)\n")
- | Family -> output_string to:oc' ("(* The "^wname^" commands *)\n")
- end;
- output_string to:oc "open Protocol\n";
- List.iter fun:(fun s -> output_string s to:oc; output_string s to:oc')
- [ "open Tk\n";
- "open Tkintf\n";
- "open Widget\n";
- "open Textvariable\n"
- ];
- begin match wdef.module_type with
- Widget ->
- write_create w:(output_string to:oc) wname;
- write_create_p w:(output_string to:oc') wname
- | Family -> ()
- end;
- List.iter fun:(write_function w:(output_string to:oc))
- (sort_components wdef.commands);
- List.iter fun:(write_function_type w:(output_string to:oc'))
- (sort_components wdef.commands);
- List.iter fun:(write_external w:(output_string to:oc))
- (sort_components wdef.externals);
- List.iter fun:(write_external_type w:(output_string to:oc'))
- (sort_components wdef.externals);
- close_out oc;
- close_out oc'
- end;
- (* write the module list for the Makefile *)
- (* and hack to death until it works *)
- let oc = open_out_bin "lib/modules" in
- output_string to:oc "WIDGETOBJS=";
- Hashtbl.iter module_table
- fun:(fun key:name data:_ ->
- output_string to:oc name;
- output_string to:oc ".cmo ");
- output_string to:oc "\n";
- Hashtbl.iter module_table
- fun:(fun key:name data:_ ->
- output_string to:oc name;
- output_string to:oc ".ml ");
- output_string to:oc ": tkgen.ml\n\n";
- Hashtbl.iter module_table fun:
- begin fun key:name data:_ ->
- output_string to:oc name;
- output_string to:oc ".cmo : ";
- output_string to:oc name;
- output_string to:oc ".ml\n";
- output_string to:oc name;
- output_string to:oc ".cmi : ";
- output_string to:oc name;
- output_string to:oc ".mli\n"
- end;
- close_out oc
-
-let main () =
- Arg.parse
- keywords:[ "-verbose", Arg.Unit (fun () -> flag_verbose := true),
- "Make output verbose" ]
- others:(fun filename -> input_name := filename)
- errmsg:"Usage: tkcompiler <source file>" ;
- try
-verbose_string "Parsing... ";
- parse_file !input_name;
-verbose_string "Compiling... ";
- compile ();
-verbose_string "Finished";
- exit 0
- with
- Lexer.Lexical_error s ->
- prerr_string "Invalid lexical character: ";
- prerr_endline s;
- exit 1
- | Duplicate_Definition (s,s') ->
- prerr_string s; prerr_string " "; prerr_string s';
- prerr_endline " is redefined illegally";
- exit 1
- | Invalid_implicit_constructor c ->
- prerr_string "Constructor ";
- prerr_string c;
- prerr_endline " is used implicitly before defined";
- exit 1
- | Tsort.Cyclic ->
- prerr_endline "Cyclic dependency of types";
- exit 1
-
-let () = Printexc.catch main ()
diff --git a/otherlibs/labltk/compiler/parser.mly b/otherlibs/labltk/compiler/parser.mly
deleted file mode 100644
index 4920c5c62..000000000
--- a/otherlibs/labltk/compiler/parser.mly
+++ /dev/null
@@ -1,312 +0,0 @@
-/* $Id$ */
-
-%{
-
-open Tables
-
-let lowercase s =
- let r = String.create len:(String.length s) in
- String.blit s pos:0 to:r to_pos:0 len:(String.length s);
- let c = s.[0] in
- if c >= 'A' & c <= 'Z' then r.[0] <- Char.chr(Char.code c + 32);
- r
-
-%}
-
-/* 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 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 { lowercase $1 }
- | WIDGET { "widget" }
-;
-
-/* Atomic types */
-Type0 :
- TYINT
- { Int }
- | TYFLOAT
- { Float }
- | TYBOOL
- { Bool }
- | TYCHAR
- { Char }
- | TYSTRING
- { String }
- | TypeName
- { UserDefined $1 }
-;
-
-/* with subtypes */
-Type1 :
- Type0
- { $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) }
-;
-
-/* with list constructors */
-Type2 :
- Type1
- { $1 }
- | Type1 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 (lowercase $2) $4 }
-| EOF
- { raise End_of_file }
-;
diff --git a/otherlibs/labltk/compiler/tables.ml b/otherlibs/labltk/compiler/tables.ml
deleted file mode 100644
index 4a606014d..000000000
--- a/otherlibs/labltk/compiler/tables.ml
+++ /dev/null
@@ -1,414 +0,0 @@
-(* $Id$ *)
-
-(* 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; (* may be no longer useful *)
- var_name : string;
- template : template;
- result : mltype;
- safe : bool
- }
-
-let sort_components =
- Sort.list order:(fun c1 c2 -> 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 key:typname data:typdef;
- typdef
-
-
-(* Assume that types not yet defined are not subtyped *)
-(* Widget is builtin and implicitly subtyped *)
-let is_subtyped s =
- s = "widget" or
- try
- let typdef = Hashtbl.find types_table key:s in
- typdef.subtypes <> []
- with
- Not_found -> false
-
-let requires_widget_context s =
- try
- (Hashtbl.find types_table key:s).requires_widget_context
- with
- Not_found -> false
-
-let declared_type_parser_arity s =
- try
- (Hashtbl.find types_table key:s).parser_arity
- with
- Not_found ->
- try List.assoc key: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 fun:enter_argtype tyl
- | Record tyl -> List.iter tyl fun:(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 fun:enter_template_types l
- | OptionalArgs (_,tl,_) -> List.iter fun: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 fun:(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 fun:(add_template_dependancies s) l
- | OptionalArgs (_,tl,_) -> List.iter fun:(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 pred:has_callback l
- | OptionalArgs (_,tl,_) -> List.exists pred:has_callback tl
-
-(*** Returned types ***)
-let really_add ty =
- if List.mem elt: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 fun:add_return_type tyl
- | Record tyl -> List.iter tyl fun:(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 =
- try
- Hashtbl.find types_table key:typname;
- raise (Duplicate_Definition ("type", typname))
- with Not_found ->
- let typdef = new_type typname arity in
- if variant then typdef.variant <- true;
- List.iter constructors fun:
- 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 or
- 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 key:typ
- with Not_found -> new_type typ arity
- in
- if List.mem_assoc key:subtyp typdef.subtypes
- then raise (Duplicate_Definition ("subtype", typ ^" "^subtyp))
- else begin
- let real_constructors =
- List.map constructors fun:
- 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 or
- 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 , Sort.list real_constructors
- order:(fun c1 c2 -> 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 key:"options"
- with
- Not_found -> raise (Invalid_implicit_constructor optname)
- in find_constructor optname optiontyp.constructors
-
-(* Sort components by type *)
-let rec add_sort acc: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 acc:rest obj)
-
-let separate_components = List.fold_left fun:add_sort acc:[]
-
-let enter_widget name components =
- try
- Hashtbl.find module_table key:name;
- raise (Duplicate_Definition ("widget/module", name))
- with Not_found ->
- let sorted_components = separate_components components in
- List.iter sorted_components fun:
- begin function
- Constructor, l ->
- enter_subtype "options" MultipleToken
- name (List.map fun:(fun c -> Full c) l)
- | Command, l ->
- List.iter fun:enter_component_types l
- | External, _ -> ()
- end;
- let commands =
- try List.assoc key:Command sorted_components
- with Not_found -> []
- and externals =
- try List.assoc key:External sorted_components
- with Not_found -> []
- in
- Hashtbl.add module_table key:name
- data:{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 =
- try
- Hashtbl.find module_table key:name;
- raise (Duplicate_Definition ("widget/module", name))
- with Not_found ->
- let sorted_components = separate_components components in
- List.iter sorted_components fun:
- begin function
- Constructor, l -> fatal_error "unexpected Constructor"
- | Command, l -> List.iter fun:enter_component_types l
- | External, _ -> ()
- end;
- let commands =
- try List.assoc key:Command sorted_components
- with Not_found -> []
- and externals =
- try List.assoc key:External sorted_components
- with Not_found -> []
- in
- Hashtbl.add module_table key:name
- data:{module_type = Family; commands = commands; externals = externals}
-
diff --git a/otherlibs/labltk/compiler/tsort.ml b/otherlibs/labltk/compiler/tsort.ml
deleted file mode 100644
index b82028924..000000000
--- a/otherlibs/labltk/compiler/tsort.ml
+++ /dev/null
@@ -1,72 +0,0 @@
-(* $Id$ *)
-
-(* 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 =
- find_entry order e;
- ()
-
-let sort order =
- let q = Queue.create ()
- and result = ref [] in
- List.iter !order
- fun:(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 fun:
- 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
- fun:(fun node -> if node.pred_count <> 0
- then raise Cyclic)
- end;
- !result
-
-
generated by cgit v1.2.3-70-g09d2 (git 2.46.0) at 2025-03-28 02:59:43 +0000