summaryrefslogtreecommitdiffstats
path: root/otherlibs/labltk/compiler
diff options
context:
space:
mode:
Diffstat (limited to 'otherlibs/labltk/compiler')
-rw-r--r--otherlibs/labltk/compiler/.cvsignore5
-rw-r--r--otherlibs/labltk/compiler/.depend14
-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
10 files changed, 2109 insertions, 0 deletions
diff --git a/otherlibs/labltk/compiler/.cvsignore b/otherlibs/labltk/compiler/.cvsignore
new file mode 100644
index 000000000..178a0fab7
--- /dev/null
+++ b/otherlibs/labltk/compiler/.cvsignore
@@ -0,0 +1,5 @@
+lexer.ml
+parser.output
+parser.ml
+parser.mli
+tkcompiler
diff --git a/otherlibs/labltk/compiler/.depend b/otherlibs/labltk/compiler/.depend
new file mode 100644
index 000000000..16916fe66
--- /dev/null
+++ b/otherlibs/labltk/compiler/.depend
@@ -0,0 +1,14 @@
+compile.cmo: tables.cmo
+compile.cmx: tables.cmx
+intf.cmo: compile.cmo tables.cmo
+intf.cmx: compile.cmx tables.cmx
+lexer.cmo: parser.cmi
+lexer.cmx: parser.cmx
+maincompile.cmo: compile.cmo intf.cmo lexer.cmo parser.cmi tables.cmo \
+ tsort.cmo
+maincompile.cmx: compile.cmx intf.cmx lexer.cmx parser.cmx tables.cmx \
+ tsort.cmx
+parser.cmo: tables.cmo parser.cmi
+parser.cmx: tables.cmx parser.cmi
+tables.cmo: tsort.cmo
+tables.cmx: tsort.cmx
diff --git a/otherlibs/labltk/compiler/Makefile b/otherlibs/labltk/compiler/Makefile
new file mode 100644
index 000000000..7d826a161
--- /dev/null
+++ b/otherlibs/labltk/compiler/Makefile
@@ -0,0 +1,36 @@
+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
new file mode 100644
index 000000000..dbc777da1
--- /dev/null
+++ b/otherlibs/labltk/compiler/compile.ml
@@ -0,0 +1,803 @@
+(* $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
new file mode 100644
index 000000000..6ecb84ae2
--- /dev/null
+++ b/otherlibs/labltk/compiler/intf.ml
@@ -0,0 +1,83 @@
+(* $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
new file mode 100644
index 000000000..065edd3a4
--- /dev/null
+++ b/otherlibs/labltk/compiler/lexer.mll
@@ -0,0 +1,141 @@
+(* $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
new file mode 100644
index 000000000..aa9412933
--- /dev/null
+++ b/otherlibs/labltk/compiler/maincompile.ml
@@ -0,0 +1,229 @@
+(* $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
new file mode 100644
index 000000000..4920c5c62
--- /dev/null
+++ b/otherlibs/labltk/compiler/parser.mly
@@ -0,0 +1,312 @@
+/* $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
new file mode 100644
index 000000000..4a606014d
--- /dev/null
+++ b/otherlibs/labltk/compiler/tables.ml
@@ -0,0 +1,414 @@
+(* $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
new file mode 100644
index 000000000..b82028924
--- /dev/null
+++ b/otherlibs/labltk/compiler/tsort.ml
@@ -0,0 +1,72 @@
+(* $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-22 05:55:11 +0000