summaryrefslogtreecommitdiffstats
path: root/otherlibs/labltk/compiler
diff options
context:
space:
mode:
Diffstat (limited to 'otherlibs/labltk/compiler')
-rw-r--r--otherlibs/labltk/compiler/.depend52
-rw-r--r--otherlibs/labltk/compiler/compile.ml192
-rw-r--r--otherlibs/labltk/compiler/intf.ml16
-rw-r--r--otherlibs/labltk/compiler/lexer.mll8
-rw-r--r--otherlibs/labltk/compiler/maincompile.ml44
-rw-r--r--otherlibs/labltk/compiler/parser.mly20
-rw-r--r--otherlibs/labltk/compiler/ppexec.ml10
-rw-r--r--otherlibs/labltk/compiler/pplex.mll10
-rw-r--r--otherlibs/labltk/compiler/ppparse.ml10
-rw-r--r--otherlibs/labltk/compiler/printer.ml6
-rw-r--r--otherlibs/labltk/compiler/tables.ml92
-rw-r--r--otherlibs/labltk/compiler/tsort.ml14
12 files changed, 236 insertions, 238 deletions
diff --git a/otherlibs/labltk/compiler/.depend b/otherlibs/labltk/compiler/.depend
index d33149e8c..91ee43040 100644
--- a/otherlibs/labltk/compiler/.depend
+++ b/otherlibs/labltk/compiler/.depend
@@ -1,28 +1,28 @@
-pplex.cmi: ppyac.cmi
-ppyac.cmi: code.cmi
-compile.cmo: code.cmi flags.cmo ppexec.cmo ppparse.cmo tables.cmo
-compile.cmx: code.cmi flags.cmx ppexec.cmx ppparse.cmx tables.cmx
-intf.cmo: code.cmi compile.cmo flags.cmo ppexec.cmo ppparse.cmo tables.cmo
-intf.cmx: code.cmi compile.cmx flags.cmx ppexec.cmx ppparse.cmx tables.cmx
-lexer.cmo: parser.cmi
-lexer.cmx: parser.cmx
+pplex.cmi: ppyac.cmi
+ppyac.cmi: code.cmi
+compile.cmo: code.cmi flags.cmo ppexec.cmo ppparse.cmo tables.cmo
+compile.cmx: code.cmi flags.cmx ppexec.cmx ppparse.cmx tables.cmx
+intf.cmo: code.cmi compile.cmo flags.cmo ppexec.cmo ppparse.cmo tables.cmo
+intf.cmx: code.cmi compile.cmx flags.cmx ppexec.cmx ppparse.cmx tables.cmx
+lexer.cmo: parser.cmi
+lexer.cmx: parser.cmx
maincompile.cmo: code.cmi compile.cmo flags.cmo intf.cmo lexer.cmo parser.cmi \
- ppexec.cmo ppparse.cmo printer.cmo tables.cmo tsort.cmo
+ ppexec.cmo ppparse.cmo printer.cmo tables.cmo tsort.cmo
maincompile.cmx: code.cmi compile.cmx flags.cmx intf.cmx lexer.cmx parser.cmx \
- ppexec.cmx ppparse.cmx printer.cmx tables.cmx tsort.cmx
-parser.cmo: flags.cmo tables.cmo parser.cmi
-parser.cmx: flags.cmx tables.cmx parser.cmi
-pp.cmo: ppexec.cmo ppparse.cmo
-pp.cmx: ppexec.cmx ppparse.cmx
-ppexec.cmo: code.cmi
-ppexec.cmx: code.cmi
-pplex.cmo: ppyac.cmi pplex.cmi
-pplex.cmx: ppyac.cmx pplex.cmi
-ppparse.cmo: pplex.cmi ppyac.cmi
-ppparse.cmx: pplex.cmx ppyac.cmx
-ppyac.cmo: code.cmi ppyac.cmi
-ppyac.cmx: code.cmi ppyac.cmi
-printer.cmo: tables.cmo
-printer.cmx: tables.cmx
-tables.cmo: tsort.cmo
-tables.cmx: tsort.cmx
+ ppexec.cmx ppparse.cmx printer.cmx tables.cmx tsort.cmx
+parser.cmo: flags.cmo tables.cmo parser.cmi
+parser.cmx: flags.cmx tables.cmx parser.cmi
+pp.cmo: ppexec.cmo ppparse.cmo
+pp.cmx: ppexec.cmx ppparse.cmx
+ppexec.cmo: code.cmi
+ppexec.cmx: code.cmi
+pplex.cmo: ppyac.cmi pplex.cmi
+pplex.cmx: ppyac.cmx pplex.cmi
+ppparse.cmo: pplex.cmi ppyac.cmi
+ppparse.cmx: pplex.cmx ppyac.cmx
+ppyac.cmo: code.cmi ppyac.cmi
+ppyac.cmx: code.cmi ppyac.cmi
+printer.cmo: tables.cmo
+printer.cmx: tables.cmx
+tables.cmo: tsort.cmo
+tables.cmx: tsort.cmx
diff --git a/otherlibs/labltk/compiler/compile.ml b/otherlibs/labltk/compiler/compile.ml
index 529c0548e..fd74bc173 100644
--- a/otherlibs/labltk/compiler/compile.ml
+++ b/otherlibs/labltk/compiler/compile.ml
@@ -37,14 +37,14 @@ let camltk_labelstring l =
if l.[0] = '?' then l ^ ":" else ""
let labelstring l =
- if !Flags.camltk then camltk_labelstring l
- else labltk_labelstring l
+ if !Flags.camltk then camltk_labelstring l
+ else labltk_labelstring l
let labltk_typelabel l =
if l = "" then l else l ^ ":"
let camltk_typelabel l =
- if l = "" then l
+ if l = "" then l
else if l.[0] = '?' then l ^ ":" else ""
let typelabel l =
@@ -58,7 +58,7 @@ let nicknames =
let small = String.lowercase
-let gettklabel fc =
+let gettklabel fc =
match fc.template with
ListArg( StringArg s :: _ ) ->
let s = small s in
@@ -85,15 +85,15 @@ let rec types_of_template = function
StringArg _ -> []
| TypeArg (l, t) -> [l, t]
| ListArg l -> List.flatten (List.map ~f:types_of_template l)
- | OptionalArgs (l, tl, _) ->
- begin
+ | OptionalArgs (l, tl, _) ->
+ begin
match List.flatten (List.map ~f:types_of_template tl) with
["", t] -> ["?" ^ l, t]
| [_, _] -> raise (Failure "0 label required")
| _ -> raise (Failure "0 or more than 1 args in for optionals")
end
-(*
+(*
* Pretty print a type
* used to write ML type definitions
*)
@@ -111,9 +111,9 @@ let ppMLtype ?(any=false) ?(return=false) ?(def=false) ?(counter=ref 0) =
if !Flags.camltk then "(* " ^ sub ^ " *) " ^ sup ^ " list"
else begin
if return then
- sub ^ "_" ^ sup ^ " list"
+ sub ^ "_" ^ sup ^ " list"
else begin
- try
+ try
let typdef = Hashtbl.find types_table sup in
let fcl = List.assoc sub typdef.subtypes in
let tklabels = List.map ~f:gettklabel fcl in
@@ -122,13 +122,13 @@ let ppMLtype ?(any=false) ?(return=false) ?(def=false) ?(counter=ref 0) =
"?" ^ begin let p = gettklabel fc in
if count ~item:p tklabels > 1 then small fc.var_name else p
end
- ^ ":" ^
+ ^ ":" ^
let l = types_of_template fc.template in
match l with
[] -> "unit"
| [lt] -> ppMLtype (labeloff lt ~at:"ppMLtype")
| l ->
- "(" ^ String.concat ~sep:"*"
+ "(" ^ String.concat ~sep:"*"
(List.map l
~f:(fun lt -> ppMLtype (labeloff lt ~at:"ppMLtype")))
^ ")"
@@ -141,20 +141,20 @@ let ppMLtype ?(any=false) ?(return=false) ?(def=false) ?(counter=ref 0) =
| List ty -> (ppMLtype ty) ^ " list"
| Product tyl ->
"(" ^ String.concat ~sep:" * " (List.map ~f:ppMLtype tyl) ^ ")"
- | Record tyl ->
+ | Record tyl ->
String.concat ~sep:" * "
(List.map tyl ~f:(fun (l, t) -> typelabel l ^ ppMLtype t))
- | Subtype ("widget", sub) ->
+ | Subtype ("widget", sub) ->
if !Flags.camltk then "(* " ^ sub ^" *) widget" else sub ^ " widget"
- | UserDefined "widget" ->
+ | UserDefined "widget" ->
if !Flags.camltk then "widget"
else begin
- if any then "any widget" else
- let c = String.make 1 (Char.chr(Char.code 'a' + !counter)) in
+ if any then "any widget" else
+ let c = String.make 1 (Char.chr(Char.code 'a' + !counter)) in
incr counter;
"'" ^ c ^ " widget"
end
- | UserDefined s ->
+ | UserDefined s ->
if !Flags.camltk then s
else begin
(* a bit dirty hack for ImageBitmap and ImagePhoto *)
@@ -163,11 +163,11 @@ let ppMLtype ?(any=false) ?(return=false) ?(def=false) ?(counter=ref 0) =
if typdef.variant then
if return then try
"[>" ^
- String.concat ~sep:"|"
+ String.concat ~sep:"|"
(List.map typdef.constructors ~f:
begin
fun c ->
- "`" ^ c.var_name ^
+ "`" ^ c.var_name ^
(match types_of_template c.template with
[] -> ""
| l -> " of " ^ ppMLtype (Product (List.map l
@@ -181,17 +181,17 @@ let ppMLtype ?(any=false) ?(return=false) ?(def=false) ?(counter=ref 0) =
else s
with Not_found -> s
end
- | Subtype (s, s') ->
+ | Subtype (s, s') ->
if !Flags.camltk then "(* " ^ s' ^ " *) " ^ s else s' ^ "_" ^ s
- | Function (Product tyl) ->
+ | Function (Product tyl) ->
raise (Failure "Function (Product tyl) ? ppMLtype")
- | Function (Record tyl) ->
- "(" ^ String.concat ~sep:" -> "
+ | Function (Record tyl) ->
+ "(" ^ String.concat ~sep:" -> "
(List.map tyl ~f:(fun (l, t) -> typelabel l ^ ppMLtype t))
^ " -> unit)"
| Function ty ->
"(" ^ (ppMLtype ty) ^ " -> unit)"
- | As (t, s) ->
+ | As (t, s) ->
if !Flags.camltk then ppMLtype t
else s
in
@@ -242,7 +242,7 @@ let write_variant ~w {var_name = varname; template = t} =
w varname;
begin match types_of_template t with
[] -> ()
- | l ->
+ | l ->
w " of ";
w (ppMLtype ~any:true ~def:true
(Product (List.map l ~f:(labeloff ~at:"write_variant"))))
@@ -258,7 +258,7 @@ let write_variants ~w = function
write_variant ~w x
end
-(* Definition of a type *)
+(* Definition of a type *)
let labltk_write_type ~intf:w ~impl:w' name ~def:typdef =
(* Only needed if no subtypes, otherwise use optionals *)
if typdef.subtypes = [] then begin
@@ -271,13 +271,13 @@ let labltk_write_type ~intf:w ~impl:w' name ~def:typdef =
(* CamlTk: List of constructors, for runtime subtyping *)
let write_constructor_set ~w ~sep = function
| [] -> fatal_error "empty type"
- | x::l ->
+ | x::l ->
w ("C" ^ x.ml_name);
List.iter l ~f: (function x ->
w sep;
w ("C" ^ x.ml_name))
-(* CamlTk: Definition of a type *)
+(* CamlTk: Definition of a type *)
let camltk_write_type ~intf:w ~impl:w' name ~def:typdef =
(* Put markers for extraction *)
w "(* type *)\n";
@@ -296,12 +296,12 @@ let camltk_write_type ~intf:w ~impl:w' name ~def:typdef =
w ("(* no doc *) type "^name^"_constrs =\n")
end;
w " | ";
- write_constructor_set ~w:w ~sep: "\n | "
+ write_constructor_set ~w:w ~sep: "\n | "
(sort_components typdef.constructors);
w "\n\n";
(* The set of all constructors *)
w' ("let "^name^"_any_table = [");
- write_constructor_set ~w:w' ~sep:"; "
+ write_constructor_set ~w:w' ~sep:"; "
(sort_components typdef.constructors);
w' ("]\n\n");
(* The subset of constructors for each subtype *)
@@ -312,7 +312,7 @@ let camltk_write_type ~intf:w ~impl:w' name ~def:typdef =
typdef.subtypes
end
-let write_type ~intf:w ~impl:w' name ~def:typdef =
+let write_type ~intf:w ~impl:w' name ~def:typdef =
(if !Flags.camltk then camltk_write_type else labltk_write_type)
~intf:w ~impl:w' name ~def:typdef
@@ -333,8 +333,8 @@ let rec converterTKtoCAML ~arg = function
| Subtype ("widget", s') when not !Flags.camltk ->
String.concat ~sep:" "
["(Obj.magic (cTKtoCAMLwidget "; arg; ") :"; s'; "widget)"]
- | Subtype (s, s') ->
- if !Flags.camltk then
+ | Subtype (s, s') ->
+ if !Flags.camltk then
"cTKtoCAML" ^ s ^ " " ^ arg
else
"cTKtoCAML" ^ s' ^ "_" ^ s ^ " " ^ arg
@@ -359,12 +359,12 @@ let rec converterTKtoCAML ~arg = function
(* Wrappers *)
(*******************************)
let varnames ~prefix n =
- let rec var i =
+ 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
@@ -384,7 +384,7 @@ let rec wrapper_code ~name ty =
(* variables for each component of the product *)
let vnames = varnames ~prefix:"a" (List.length tyl) in
(* getting the arguments *)
- let readarg =
+ let readarg =
List.map2 vnames tyl ~f:
begin fun v (l, ty) ->
match type_parser_arity ty with
@@ -398,8 +398,8 @@ let rec wrapper_code ~name ty =
" in\n "
end in
String.concat ~sep:"" readarg ^ name ^ " " ^
- String.concat ~sep:" "
- (List.map2 ~f:(fun v (l, _) ->
+ String.concat ~sep:" "
+ (List.map2 ~f:(fun v (l, _) ->
if !Flags.camltk then v
else labelstring l ^ v) vnames tyl)
@@ -410,7 +410,7 @@ let rec wrapper_code ~name ty =
name ^ "(" ^ converterTKtoCAML ~arg:"(List.hd args)" ty ^ ")"
| ty ->
begin match type_parser_arity ty with
- OneToken ->
+ OneToken ->
name ^ "(" ^ converterTKtoCAML ~arg:"(List.hd args)" ty ^ ")"
| MultipleToken ->
"let (v, _) = " ^ converterTKtoCAML ~arg:"args" ty ^
@@ -435,8 +435,8 @@ type parser_pieces =
mutable stringpar : string list (* idem *)
}
-type mini_parser =
- NoParser
+type mini_parser =
+ NoParser
| ParserPieces of parser_pieces
let can_generate_parser constructors =
@@ -446,9 +446,9 @@ let can_generate_parser constructors =
let vname = if !Flags.camltk then c.ml_name else c.var_name in
match c.template with
ListArg [StringArg s] ->
- pp.zeroary <- (s, vname) ::
+ pp.zeroary <- (s, vname) ::
pp.zeroary; true
- | ListArg [TypeArg(_, Int)] | ListArg[TypeArg(_, Float)] ->
+ | ListArg [TypeArg(_, Int)] | ListArg[TypeArg(_, Float)] ->
if pp.intpar <> [] then false
else (pp.intpar <- [vname]; true)
| ListArg [TypeArg(_, String)] ->
@@ -466,8 +466,8 @@ let labltk_write_TKtoCAML ~w name ~def:typdef =
if typdef.parser_arity = MultipleToken then
prerr_string ("You must write cTKtoCAML" ^ name ^
" : string list ->" ^ name ^ " * string list\n")
- else
- let write ~consts ~name =
+ else
+ let write ~consts ~name =
match can_generate_parser consts with
NoParser ->
prerr_string
@@ -482,7 +482,7 @@ let labltk_write_TKtoCAML ~w name ~def:typdef =
end;
w (" match n with\n");
List.iter pp.zeroary ~f:
- begin fun (tk, ml) ->
+ begin fun (tk, ml) ->
w " | \""; w tk; w "\" -> `"; w ml; w "\n"
end;
let final = if pp.stringpar <> [] then
@@ -505,8 +505,8 @@ let camltk_write_TKtoCAML ~w name ~def:typdef =
if typdef.parser_arity = MultipleToken then
prerr_string ("You must write cTKtoCAML" ^ name ^
" : string list ->" ^ name ^ " * string list\n")
- else
- let write ~consts ~name =
+ else
+ let write ~consts ~name =
match can_generate_parser consts with
NoParser ->
prerr_string
@@ -521,7 +521,7 @@ let camltk_write_TKtoCAML ~w name ~def:typdef =
end;
w (" match n with\n");
List.iter pp.zeroary ~f:
- begin fun (tk, ml) ->
+ begin fun (tk, ml) ->
w " | \""; w tk; w "\" -> "; w ml; w "\n"
end;
let final = if pp.stringpar <> [] then
@@ -558,39 +558,39 @@ let rec converterCAMLtoTK ~context_widget argname ty =
| Char -> "TkToken (Char.escaped " ^ argname ^ ")"
| String -> "TkToken " ^ argname
| As (ty, _) -> converterCAMLtoTK ~context_widget argname ty
- | UserDefined s ->
+ | UserDefined s ->
let name = "cCAMLtoTK" ^ s ^ " " in
let args = argname in
- let args =
+ let args =
if !Flags.camltk then begin
if is_subtyped s then (* unconstraint subtype *)
s ^ "_any_table " ^ args
else args
end else args
in
- let args =
+ let args =
if requires_widget_context s then
context_widget ^ " " ^ args
else args in
name ^ args
| Subtype ("widget", s') ->
- if !Flags.camltk then
+ if !Flags.camltk then
let name = "cCAMLtoTKwidget " in
let args = "widget_"^s'^"_table "^argname in
- let args =
+ let args =
if requires_widget_context "widget" then
context_widget^" "^args
else args in
name^args
- else begin
+ else begin
let name = "cCAMLtoTKwidget " in
let args = "(" ^ argname ^ " : " ^ s' ^ " widget)" in
name ^ args
end
| Subtype (s, s') ->
- let name =
+ let name =
if !Flags.camltk then "cCAMLtoTK" ^ s ^ " "
- else "cCAMLtoTK" ^ s' ^ "_" ^ s ^ " "
+ else "cCAMLtoTK" ^ s' ^ "_" ^ s ^ " "
in
let args =
if !Flags.camltk then begin
@@ -600,7 +600,7 @@ let rec converterCAMLtoTK ~context_widget argname ty =
else argname
end
in
- let args =
+ let args =
if requires_widget_context s then context_widget ^ " " ^ args
else args in
name ^ args
@@ -614,19 +614,19 @@ let rec converterCAMLtoTK ~context_widget argname ty =
["]"])
| List ty -> (* Just added for Imagephoto.put *)
String.concat ~sep:" "
- [(if !Flags.camltk then
- "TkQuote (TkTokenList (List.map (fun y -> "
- else
- "TkQuote (TkTokenList (List.map ~f:(fun y -> ");
- converterCAMLtoTK ~context_widget "y" ty;
- ")";
- argname;
- "))"]
+ [(if !Flags.camltk then
+ "TkQuote (TkTokenList (List.map (fun y -> "
+ else
+ "TkQuote (TkTokenList (List.map ~f:(fun y -> ");
+ converterCAMLtoTK ~context_widget "y" ty;
+ ")";
+ argname;
+ "))"]
| Function _ -> fatal_error "unexpected function type in converterCAMLtoTK"
| Unit -> fatal_error "unexpected unit type in converterCAMLtoTK"
| Record _ -> fatal_error "unexpected product type in converterCAMLtoTK"
-(*
+(*
* Produce a list of arguments from a template
* The idea here is to avoid allocation as much as possible
*
@@ -638,7 +638,7 @@ let code_of_template ~context_widget ?func:(funtemplate=false) template =
let variables2 = ref [] in
let varcnter = ref 0 in
let optionvar = ref None in
- let newvar1 l =
+ let newvar1 l =
match !optionvar with
Some v -> optionvar := None; v
| None ->
@@ -652,7 +652,7 @@ let code_of_template ~context_widget ?func:(funtemplate=false) template =
incr varcnter;
let v = "v" ^ (string_of_int !varcnter) in
variables2 := (l, v) :: !variables2; v in
- let newvar = ref newvar1 in
+ let newvar = ref newvar1 in
let rec coderec = function
StringArg s -> "TkToken \"" ^ s ^ "\""
| TypeArg (_, List (Subtype (sup, sub))) when not !Flags.camltk ->
@@ -663,13 +663,13 @@ let code_of_template ~context_widget ?func:(funtemplate=false) template =
catch_opts := (sub ^ "_" ^ sup, lbl);
newvar := newvar2;
"TkTokenList opts"
- with Not_found ->
+ with Not_found ->
raise (Failure (Printf.sprintf "type %s(%s) not found" sup sub));
end
| TypeArg (l, List ty) ->
- (if !Flags.camltk then
+ (if !Flags.camltk then
"TkTokenList (List.map (function x -> "
- else
+ else
"TkTokenList (List.map ~f:(function x -> ")
^ converterCAMLtoTK ~context_widget "x" ty
^ ") " ^ !newvar l ^ ")"
@@ -680,18 +680,18 @@ let code_of_template ~context_widget ?func:(funtemplate=false) template =
| TypeArg (l, ty) -> converterCAMLtoTK ~context_widget (!newvar l) ty
| ListArg l ->
"TkQuote (TkTokenList ["
- ^ String.concat ~sep:";\n " (List.map ~f:coderec l) ^ "])"
- | OptionalArgs (l, tl, d) ->
+ ^ String.concat ~sep:";\n " (List.map ~f:coderec l) ^ "])"
+ | OptionalArgs (l, tl, d) ->
let nv = !newvar ("?" ^ l) in
optionvar := Some nv; (* Store *)
- let argstr = String.concat ~sep:"; " (List.map ~f:coderec tl) in
+ let argstr = String.concat ~sep:"; " (List.map ~f:coderec tl) in
let defstr = String.concat ~sep:"; " (List.map ~f:coderec d) in
"TkTokenList (match " ^ nv ^ " with\n"
^ " | Some " ^ nv ^ " -> [" ^ argstr ^ "]\n"
^ " | None -> [" ^ defstr ^ "])"
in
- let code =
- if funtemplate then
+ let code =
+ if funtemplate then
match template with
ListArg l ->
"[|" ^ String.concat ~sep:";\n " (List.map ~f:coderec l) ^ "|]"
@@ -721,7 +721,7 @@ let labltk_write_clause ~w ~context_widget comp =
code_of_template ~context_widget comp.template in
(* no subtype I think ... *)
- if co <> "" then raise (Failure "write_clause subtype ?");
+ if co <> "" then raise (Failure "write_clause subtype ?");
begin match variables with
| [] -> warrow()
| [x] -> w " "; w (labeloff x ~at:"write_clause"); warrow()
@@ -734,19 +734,19 @@ let labltk_write_clause ~w ~context_widget comp =
w code
let camltk_write_clause ~w ~context_widget ~subtype comp =
- let warrow () =
+ let warrow () =
w " -> ";
- if subtype then
+ if subtype then
w ("chk_sub \""^comp.ml_name^"\" table C" ^ comp.ml_name ^ "; ")
in
- w comp.ml_name; (* we use ml_name, not var_name, specialized for labltk *)
+ w comp.ml_name; (* we use ml_name, not var_name, specialized for labltk *)
let code, variables, variables2, (co, _) =
code_of_template ~context_widget comp.template in
(* no subtype I think ... *)
- if co <> "" then raise (Failure "write_clause subtype ?");
+ if co <> "" then raise (Failure "write_clause subtype ?");
begin match variables with
| [] -> warrow()
| [x] -> w " "; w (labeloff x ~at:"write_clause"); warrow()
@@ -767,7 +767,7 @@ let write_CAMLtoTK ~w ~def:typdef ?safetype:(st = true) name =
let write_one name constrs =
let subtype = typdef.subtypes <> [] in
w ("let cCAMLtoTK" ^ name);
- let context_widget =
+ let context_widget =
if typdef.requires_widget_context then begin
w " w"; "w"
end
@@ -784,7 +784,7 @@ let write_CAMLtoTK ~w ~def:typdef ?safetype:(st = true) name =
~f:(fun c -> w "\n | "; write_clause ~w ~context_widget ~subtype c);
w "\n\n\n"
in
-
+
let constrs = typdef.constructors in
if !Flags.camltk then write_one name constrs
else begin
@@ -813,7 +813,7 @@ let rec write_result_parsing ~w = function
w (" List.map " ^ converterTKtoCAML ~arg:"(splitlist res)" ty)
else
w (" List.map ~f: " ^ converterTKtoCAML ~arg:"(splitlist res)" ty)
- | Product tyl -> raise (Failure "Product -> record was done. ???")
+ | Product tyl -> raise (Failure "Product -> record was done. ???")
| Record tyl -> (* of course all the labels are "" *)
let rnames = varnames ~prefix:"r" (List.length tyl) in
w " let l = splitlist res in";
@@ -822,7 +822,7 @@ let rec write_result_parsing ~w = function
w ("\n else ");
List.iter2 rnames tyl ~f:
begin fun r (l, ty) ->
- if l <> "" then raise (Failure "lables in return type!!!");
+ if l <> "" then raise (Failure "lables in return type!!!");
w (" let " ^ r ^ ", l = ");
begin match type_parser_arity ty with
OneToken ->
@@ -852,7 +852,7 @@ let labltk_write_function ~w def =
let code, variables, variables2, (co, lbl) =
code_of_template ~func:true ~context_widget def.template in
(* Arguments *)
- let uv, lv, ov =
+ let uv, lv, ov =
let rec replace_args ~u ~l ~o = function
[] -> u, l, o
| ("", x) :: ls ->
@@ -901,7 +901,7 @@ let camltk_write_function ~w def =
let code, variables, variables2, (co, lbl) =
code_of_template ~func:true ~context_widget def.template in
(* Arguments *)
- let uv, ov =
+ let uv, ov =
let rec replace_args ~u ~o = function
[] -> u, o
| ("", x) :: ls ->
@@ -943,20 +943,20 @@ let camltk_write_function ~w def =
(* Arguments *)
begin match variables with
[] -> w " () =\n"
- | l ->
+ | l ->
let has_normal_argument = ref false in
- List.iter (fun (l,x) ->
+ List.iter (fun (l,x) ->
w " ";
- if l <> "" then
+ if l <> "" then
if l.[0] = '?' then w (l ^ ":") else has_normal_argument := true
else has_normal_argument := true;
- w x) l;
+ w x) l;
if not !has_normal_argument then w " ()";
w " =\n"
end;
begin match def.result with
| Unit | As (Unit, _) -> w "tkCommand "; w code
- | ty ->
+ | ty ->
w "let res = tkEval "; w code ; w " in \n";
write_result_parsing ~w ty
end;
@@ -1028,10 +1028,10 @@ let write_external ~w def =
let code_list = Ppparse.parse_channel ic in
close_in ic;
List.iter (Ppexec.exec (fun _ -> ()) w)
- (if !Flags.camltk then
+ (if !Flags.camltk then
Code.Define "CAMLTK" :: code_list else code_list );
with
- | Ppparse.Error s ->
+ | Ppparse.Error s ->
close_in ic;
raise (Compiler_Error (Printf.sprintf "Preprocess error: %s" s))
with
@@ -1046,7 +1046,7 @@ let write_catch_optionals ~w clas ~def:typdef =
begin fun (subclass, classdefs) ->
w ("let " ^ subclass ^ "_" ^ clas ^ "_optionals f = fun\n");
let tklabels = List.map ~f:gettklabel classdefs in
- let l =
+ let l =
List.map classdefs ~f:
begin fun fc ->
(*
diff --git a/otherlibs/labltk/compiler/intf.ml b/otherlibs/labltk/compiler/intf.ml
index 58955b962..59608b381 100644
--- a/otherlibs/labltk/compiler/intf.ml
+++ b/otherlibs/labltk/compiler/intf.ml
@@ -26,7 +26,7 @@ open Compile
let labltk_write_create_p ~w wname =
w "val create :\n ?name:string ->\n";
begin
- try
+ try
let option = Hashtbl.find types_table "options" in
let classdefs = List.assoc wname option.subtypes in
let tklabels = List.map ~f:gettklabel classdefs in
@@ -37,7 +37,7 @@ let labltk_write_create_p ~w wname =
end,
fc.template
end in
- w (String.concat ~sep:" ->\n"
+ w (String.concat ~sep:" ->\n"
(List.map l ~f:
begin fun (s, t) ->
" ?" ^ s ^ ":"
@@ -58,7 +58,7 @@ let camltk_write_create_p ~w wname =
w "val create : ?name: string -> widget -> options list -> widget \n";
w "(** [create ?name parent options] creates a new widget with\n";
w " parent [parent] and new patch component [name] if specified.\n";
- w " Options are restricted to the widget class subset, and checked\n";
+ w " Options are restricted to the widget class subset, and checked\n";
w " dynamically. *)\n\n"
;;
@@ -77,7 +77,7 @@ let labltk_write_function_type ~w def =
let tys = types_of_template def.template in
let rec replace_args ~u ~l ~o = function
[] -> u, l, o
- | (_, List(Subtype _) as x)::ls ->
+ | (_, List(Subtype _) as x)::ls ->
replace_args ~u ~l ~o:(x::o) ls
| ("", _ as x)::ls ->
replace_args ~u:(x::u) ~l ~o ls
@@ -144,7 +144,7 @@ let camltk_write_function_type ~w def =
let have_normal_arg = ref false in
List.iter tys ~f:
begin fun (l, t) ->
- if l <> "" then
+ if l <> "" then
if l.[0] = '?' then w (l^":")
else begin
have_normal_arg := true;
@@ -161,7 +161,7 @@ let camltk_write_function_type ~w def =
else w "\n(* /unsafe *)\n"
*)
-let write_function_type ~w def =
+let write_function_type ~w def =
if !Flags.camltk then camltk_write_function_type ~w def
else labltk_write_function_type ~w def
@@ -176,12 +176,12 @@ let write_external_type ~w def =
close_in ic;
if not def.safe then w "(* unsafe *)\n";
List.iter (Ppexec.exec (fun _ -> ()) w)
- (if !Flags.camltk then
+ (if !Flags.camltk then
Code.Define "CAMLTK" :: code_list else code_list );
if def.safe then w "\n\n"
else w "\n(* /unsafe *)\n\n"
with
- | Ppparse.Error s ->
+ | Ppparse.Error s ->
close_in ic;
raise (Compiler_Error (Printf.sprintf "Preprocess error: %s" s))
with
diff --git a/otherlibs/labltk/compiler/lexer.mll b/otherlibs/labltk/compiler/lexer.mll
index c65c9a604..f51f0c01f 100644
--- a/otherlibs/labltk/compiler/lexer.mll
+++ b/otherlibs/labltk/compiler/lexer.mll
@@ -40,7 +40,7 @@ let _ = List.iter
"string", TYSTRING;
"list", LIST;
"as", AS;
- "variant", VARIANT;
+ "variant", VARIANT;
"widget", WIDGET;
"option", OPTION;
"type", TYPE;
@@ -127,12 +127,12 @@ rule main = parse
| "?" {QUESTION}
| "/" {SLASH}
| "%" { comment lexbuf; main lexbuf }
- | "##line" { line lexbuf; main lexbuf }
+ | "##line" { line lexbuf; main lexbuf }
| eof { EOF }
| _
{ raise (Lexical_error("illegal character")) }
-
+
and string = parse
'"'
{ () }
@@ -160,7 +160,7 @@ and comment = parse
| _ { comment lexbuf }
and linenum = parse
- | ['0'-'9']+ {
+ | ['0'-'9']+ {
let next_line = int_of_string (Lexing.lexeme lexbuf) in
current_line := next_line - 1
}
diff --git a/otherlibs/labltk/compiler/maincompile.ml b/otherlibs/labltk/compiler/maincompile.ml
index 80118fa9b..d8c72a312 100644
--- a/otherlibs/labltk/compiler/maincompile.ml
+++ b/otherlibs/labltk/compiler/maincompile.ml
@@ -24,7 +24,7 @@ open Compile
open Intf
let flag_verbose = ref false
-let verbose_string s =
+let verbose_string s =
if !flag_verbose then prerr_string s
let verbose_endline s =
if !flag_verbose then prerr_endline s
@@ -33,7 +33,7 @@ let input_name = ref "Widgets.src"
let output_dir = ref ""
let destfile f = Filename.concat !output_dir f
-let usage () =
+let usage () =
prerr_string "Usage: tkcompiler input.src\n";
flush stderr;
exit 1
@@ -53,15 +53,15 @@ let parse_file filename =
let code_list = Ppparse.parse_channel ic in
close_in ic;
let buf = Buffer.create 50000 in
- List.iter (Ppexec.exec
+ List.iter (Ppexec.exec
(fun l -> Buffer.add_string buf
(Printf.sprintf "##line %d\n" l))
(Buffer.add_string buf))
- (if !Flags.camltk then Code.Define "CAMLTK" :: code_list
+ (if !Flags.camltk then Code.Define "CAMLTK" :: code_list
else code_list);
Lexing.from_string (Buffer.contents buf)
with
- | Ppparse.Error s ->
+ | Ppparse.Error s ->
close_in ic;
raise (Compiler_Error (Printf.sprintf "Preprocess error: %s" s))
in
@@ -110,9 +110,9 @@ let uniq_clauses = function
let check_constr constr1 constr2 =
if constr1.template <> constr2.template then
begin
- let code1, vars11, vars12, opts1 =
+ let code1, vars11, vars12, opts1 =
code_of_template ~context_widget:"dummy" constr1.template in
- let code2, vars12, vars22, opts2 =
+ let code2, vars12, vars22, opts2 =
code_of_template ~context_widget:"dummy" constr2.template in
let err =
Printf.sprintf
@@ -141,14 +141,14 @@ let option_hack oc =
let hack =
{ parser_arity = OneToken;
constructors = begin
- let constrs =
+ let constrs =
List.map typdef.constructors ~f:
- begin fun c ->
+ begin fun c ->
{ component = Constructor;
- ml_name = (if !Flags.camltk then "C" ^ c.ml_name
+ ml_name = (if !Flags.camltk then "C" ^ c.ml_name
else c.ml_name);
var_name = c.var_name; (* as variants *)
- template =
+ template =
begin match c.template with
ListArg (x :: _) -> x
| _ -> fatal_error "bogus hack"
@@ -159,20 +159,20 @@ let option_hack oc =
if !Flags.camltk then constrs else uniq_clauses constrs (* JPF ?? *)
end;
subtypes = [];
- requires_widget_context = false;
+ requires_widget_context = false;
variant = false }
in
write_CAMLtoTK
~w:(output_string oc) ~def:hack ~safetype:false "options_constrs"
-let realname name =
+let realname name =
(* module name fix for camltk *)
if !Flags.camltk then "c" ^ String.capitalize name
else name
;;
(* analize the parsed Widget.src and output source files *)
-let compile () =
+let compile () =
verbose_endline "Creating _tkgen.ml ...";
let oc = open_out_bin (destfile "_tkgen.ml") in
let oc' = open_out_bin (destfile "_tkigen.ml") in
@@ -197,7 +197,7 @@ let compile () =
if not !Flags.camltk then (* only for LablTk *)
write_catch_optionals ~w:(output_string oc') typname ~def:typdef;
verbose_endline "."
- with Not_found ->
+ with Not_found ->
if not (List.mem_assoc typname !types_external) then
begin
verbose_string "Type ";
@@ -224,8 +224,8 @@ let compile () =
let write_module wname wdef =
verbose_endline (" "^wname);
let modname = realname wname in
- let oc = open_out_bin (destfile (modname ^ ".ml"))
- and oc' = open_out_bin (destfile (modname ^ ".mli")) in
+ let oc = open_out_bin (destfile (modname ^ ".ml"))
+ and oc' = open_out_bin (destfile (modname ^ ".mli")) in
Copyright.write ~w:(output_string oc);
Copyright.write ~w:(output_string oc');
begin match wdef.module_type with
@@ -260,11 +260,11 @@ let compile () =
end
| Family -> ()
end;
- List.iter ~f:(write_function ~w:(output_string oc))
+ List.iter ~f:(write_function ~w:(output_string oc))
(sort_components wdef.commands);
List.iter ~f:(write_function_type ~w:(output_string oc'))
(sort_components wdef.commands);
- List.iter ~f:(write_external ~w:(output_string oc))
+ List.iter ~f:(write_external ~w:(output_string oc))
(sort_components wdef.externals);
List.iter ~f:(write_external_type ~w:(output_string oc'))
(sort_components wdef.externals);
@@ -276,7 +276,7 @@ let compile () =
if !Flags.camltk then begin
let oc = open_out_bin (destfile "camltk.ml") in
Copyright.write ~w:(output_string oc);
- output_string oc
+ output_string oc
"(** This module Camltk provides the module name spaces of the CamlTk API.\n\
\n\
The users of the CamlTk API should open this module first to access\n\
@@ -319,9 +319,9 @@ module Timer = Timer;;\n\
Hashtbl.iter (fun name def ->
match def.module_type with
| Widget ->
- output_string oc (Printf.sprintf
+ output_string oc (Printf.sprintf
"let %s (w : any widget) =\n" name);
- output_string oc (Printf.sprintf
+ output_string oc (Printf.sprintf
" Rawwidget.check_class w widget_%s_table;\n" name);
output_string oc (Printf.sprintf
" (Obj.magic w : %s widget);;\n\n" name);
diff --git a/otherlibs/labltk/compiler/parser.mly b/otherlibs/labltk/compiler/parser.mly
index c797f4fb5..15ced65f8 100644
--- a/otherlibs/labltk/compiler/parser.mly
+++ b/otherlibs/labltk/compiler/parser.mly
@@ -31,7 +31,7 @@ open Tables
%token RPAREN /* ")" */
%token COMMA /* "," */
%token SEMICOLON /* ";" */
-%token COLON /* ":" */
+%token COLON /* ":" */
%token QUESTION /* "?" */
%token LBRACKET /* "[" */
%token RBRACKET /* "]" */
@@ -86,11 +86,11 @@ Type0 :
/* Camltk/Labltk types */
Type0_5:
| Type0 SLASH Type0 { if !Flags.camltk then $1 else $3 }
- | Type0 { $1 }
+ | Type0 { $1 }
;
/* with subtypes */
-Type1 :
+Type1 :
Type0_5
{ $1 }
| TypeName LPAREN IDENT RPAREN
@@ -141,8 +141,8 @@ FType :
LPAREN RPAREN
{ Unit }
| LPAREN Type2 RPAREN
- { $2 }
- | LPAREN Type_record RPAREN
+ { $2 }
+ | LPAREN Type_record RPAREN
{ Record $2 }
;
@@ -168,7 +168,7 @@ Arg:
| Type
{TypeArg ("", $1) }
| IDENT COLON Type
- {TypeArg ($1, $3)}
+ {TypeArg ($1, $3)}
| QUESTION IDENT COLON LBRACKET SimpleArgList RBRACKET DefaultList
{OptionalArgs ( $2, $5, $7 )}
| QUESTION WIDGET COLON LBRACKET SimpleArgList RBRACKET DefaultList
@@ -212,14 +212,14 @@ Template :
/* Constructors for type declarations */
Constructor :
IDENT Template
- {{ component = Constructor;
+ {{ component = Constructor;
ml_name = $1;
var_name = getvarname $1 $2;
template = $2;
result = Unit;
safe = true }}
| IDENT LPAREN IDENT RPAREN Template
- {{ component = Constructor;
+ {{ component = Constructor;
ml_name = $1;
var_name = $3;
template = $5;
@@ -290,7 +290,7 @@ WidgetComponents :
{ $1 :: $2 }
;
-ModuleComponents :
+ModuleComponents :
/* */
{ [] }
| Command ModuleComponents
@@ -319,7 +319,7 @@ entry :
{ enter_subtype "options" $2 $5 $8 }
| SUBTYPE ParserArity TypeName LPAREN IDENT RPAREN LBRACE AbbrevConstructors RBRACE
{ enter_subtype $3 $2 $5 $8 }
-| Command
+| Command
{ enter_function $1 }
| WIDGET IDENT LBRACE WidgetComponents RBRACE
{ enter_widget $2 $4 }
diff --git a/otherlibs/labltk/compiler/ppexec.ml b/otherlibs/labltk/compiler/ppexec.ml
index 994688203..71118b960 100644
--- a/otherlibs/labltk/compiler/ppexec.ml
+++ b/otherlibs/labltk/compiler/ppexec.ml
@@ -32,9 +32,9 @@ let rec nop = function
;;
let rec exec lp f = function
- | Line line ->
- if !debug then
- prerr_endline (Printf.sprintf "%03d: %s" !linenum
+ | Line line ->
+ if !debug then
+ prerr_endline (Printf.sprintf "%03d: %s" !linenum
(String.sub line 0 ((String.length line) - 1)));
f line; incr linenum
| Ifdef (sw, k, c1, c2o) ->
@@ -48,13 +48,13 @@ let rec exec lp f = function
end else begin
List.iter nop c1;
match c2o with
- | Some c2 ->
+ | Some c2 ->
lp !linenum;
List.iter (exec lp f) c2
| None -> ()
end
| Define k -> defined := k :: !defined
- | Undef k ->
+ | Undef k ->
defined := List.fold_right (fun k' s ->
if k = k' then s else k' :: s) [] !defined
;;
diff --git a/otherlibs/labltk/compiler/pplex.mll b/otherlibs/labltk/compiler/pplex.mll
index 61ca9f4b4..313d1f2dd 100644
--- a/otherlibs/labltk/compiler/pplex.mll
+++ b/otherlibs/labltk/compiler/pplex.mll
@@ -18,10 +18,10 @@
open Ppyac
exception Error of string
let linenum = ref 1
-}
+}
let blank = [' ' '\013' '\009' '\012']
-let identchar =
+let identchar =
['A'-'Z' 'a'-'z' '_' '\192'-'\214' '\216'-'\246' '\248'-'\255' '\'' '0'-'9']
let lowercase = ['a'-'z' '\223'-'\246' '\248'-'\255' '_']
let uppercase = ['A'-'Z' '\192'-'\214' '\216'-'\222']
@@ -29,10 +29,10 @@ let uppercase = ['A'-'Z' '\192'-'\214' '\216'-'\222']
rule token = parse
blank + { token lexbuf }
| "##" [' ' '\t']* { directive lexbuf }
-| ("#")? [^ '#' '\n']* '\n'? {
+| ("#")? [^ '#' '\n']* '\n'? {
begin
let str = Lexing.lexeme lexbuf in
- if String.length str <> 0 && str.[String.length str - 1] = '\n' then
+ if String.length str <> 0 && str.[String.length str - 1] = '\n' then
begin
incr linenum
end;
@@ -51,6 +51,6 @@ and directive = parse
| _ { raise (Error (Printf.sprintf "unknown directive at line %d" !linenum))}
and ident = parse
-| lowercase identchar* | uppercase identchar*
+| lowercase identchar* | uppercase identchar*
{ Lexing.lexeme lexbuf }
| _ { raise (Error (Printf.sprintf "illegal identifier at line %d" !linenum)) }
diff --git a/otherlibs/labltk/compiler/ppparse.ml b/otherlibs/labltk/compiler/ppparse.ml
index 3d1ee2af4..630d675de 100644
--- a/otherlibs/labltk/compiler/ppparse.ml
+++ b/otherlibs/labltk/compiler/ppparse.ml
@@ -19,18 +19,18 @@ exception Error of string
let parse_channel ic =
let lexbuf = Lexing.from_channel ic in
try
- Ppyac.code_list Pplex.token lexbuf
+ Ppyac.code_list Pplex.token lexbuf
with
| Pplex.Error s ->
- let loc_start = Lexing.lexeme_start lexbuf
+ let loc_start = Lexing.lexeme_start lexbuf
and loc_end = Lexing.lexeme_end lexbuf
in
- raise (Error (Printf.sprintf "parse error at char %d, %d: %s"
+ raise (Error (Printf.sprintf "parse error at char %d, %d: %s"
loc_start loc_end s))
| Parsing.Parse_error ->
- let loc_start = Lexing.lexeme_start lexbuf
+ let loc_start = Lexing.lexeme_start lexbuf
and loc_end = Lexing.lexeme_end lexbuf
in
- raise (Error (Printf.sprintf "parse error at char %d, %d"
+ raise (Error (Printf.sprintf "parse error at char %d, %d"
loc_start loc_end))
;;
diff --git a/otherlibs/labltk/compiler/printer.ml b/otherlibs/labltk/compiler/printer.ml
index 60362d17f..be70612aa 100644
--- a/otherlibs/labltk/compiler/printer.ml
+++ b/otherlibs/labltk/compiler/printer.ml
@@ -121,7 +121,7 @@ let rec print_component_type = function
(* Full definition of a component *)
let rec print_fullcomponent = function
{component = c; ml_name = s; var_name = s0; template = t; result = m;
- safe = b;
+ safe = b;
} ->
printf "@[<1>{"; printf "@[<1>component =@ "; print_component_type c;
printf ";@]@ "; printf "@[<1>ml_name =@ "; print_quoted_string s;
@@ -137,7 +137,7 @@ let rec print_component = function
printf "@[<1>(%s@ " "Abbrev"; print_quoted_string s; printf ")@]";;
(* A type definition *)
-(*
+(*
requires_widget_context: the converter of the type MUST be passed
an additional argument of type Widget.
*)
@@ -146,7 +146,7 @@ let rec print_parser_arity = function
let rec print_type_def = function
{parser_arity = p; constructors = l_f; subtypes = l_t_s_l_f;
- requires_widget_context = b; variant = b0;
+ requires_widget_context = b; variant = b0;
} ->
printf "@[<1>{"; printf "@[<1>parser_arity =@ "; print_parser_arity p;
printf ";@]@ "; printf "@[<1>constructors =@ ";
diff --git a/otherlibs/labltk/compiler/tables.ml b/otherlibs/labltk/compiler/tables.ml
index 0d395cdc2..0663dfaad 100644
--- a/otherlibs/labltk/compiler/tables.ml
+++ b/otherlibs/labltk/compiler/tables.ml
@@ -21,7 +21,7 @@ open Support
(* Internal compiler errors *)
-exception Compiler_Error of string
+exception Compiler_Error of string
let fatal_error s = raise (Compiler_Error s)
@@ -68,12 +68,12 @@ let sort_components =
(* components are given either in full or abbreviated *)
-type component =
+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.
*)
@@ -117,7 +117,7 @@ let module_table = (Hashtbl.create 37 : (string, module_def) Hashtbl.t)
(* variant name *)
-let rec getvarname ml_name temp =
+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
@@ -125,7 +125,7 @@ let rec getvarname ml_name temp =
else s
and makecapital s =
begin
- try
+ 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'))
@@ -137,24 +137,24 @@ let rec getvarname ml_name temp =
let head = makecapital (offhypben begin
match temp with
StringArg s -> s
- | TypeArg (s,t) -> 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
+ 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 =
+let new_type typname arity =
Tsort.add_element types_order typname;
let typdef = {parser_arity = arity;
- constructors = [];
- subtypes = [];
+ constructors = [];
+ subtypes = [];
requires_widget_context = false;
variant = false} in
Hashtbl.add types_table typname typdef;
@@ -165,23 +165,23 @@ let new_type typname arity =
(* Widget is builtin and implicitly subtyped *)
let is_subtyped s =
s = "widget" ||
- try
+ try
let typdef = Hashtbl.find types_table s in
typdef.subtypes <> []
with
Not_found -> false
-let requires_widget_context s =
- try
+let requires_widget_context s =
+ try
(Hashtbl.find types_table s).requires_widget_context
with
Not_found -> false
-let declared_type_parser_arity s =
- try
+let declared_type_parser_arity s =
+ try
(Hashtbl.find types_table s).parser_arity
with
- Not_found ->
+ Not_found ->
try List.assoc s !types_external
with
Not_found ->
@@ -225,8 +225,8 @@ let rec enter_template_types = function
StringArg _ -> ()
| TypeArg (l,t) -> enter_argtype t
| ListArg l -> List.iter ~f:enter_template_types l
- | OptionalArgs (_,tl,_) -> List.iter ~f:enter_template_types tl
-
+ | OptionalArgs (_,tl,_) -> List.iter ~f:enter_template_types tl
+
(* Find type dependancies on s *)
let rec add_dependancies s =
function
@@ -253,7 +253,7 @@ let rec has_callback = function
| OptionalArgs (_,tl,_) -> List.exists ~f:has_callback tl
(*** Returned types ***)
-let really_add ty =
+let really_add ty =
if List.mem ty !types_returned then ()
else types_returned := ty :: !types_returned
@@ -266,7 +266,7 @@ let rec add_return_type = function
| String -> ()
| List ty -> add_return_type ty
| Product tyl -> List.iter ~f:add_return_type tyl
- | Record tyl -> List.iter tyl ~f:(fun (l,t) -> add_return_type t)
+ | Record tyl -> List.iter tyl ~f:(fun (l,t) -> add_return_type t)
| UserDefined s -> really_add s
| Subtype (s,_) -> really_add s
| Function _ -> fatal_error "unexpected return type (function)" (* whoah *)
@@ -287,9 +287,9 @@ exception Invalid_implicit_constructor of string
let rec check_duplicate_constr allowed c =
function
[] -> false (* not defined *)
- | c'::rest ->
+ | c'::rest ->
if c.ml_name = c'.ml_name then (* defined *)
- if allowed then
+ 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))
@@ -306,16 +306,16 @@ let enter_type typname ?(variant = false) arity constructors =
if Hashtbl.mem types_table typname then
raise (Duplicate_Definition ("type", typname)) else
let typdef = new_type typname arity in
- if variant then typdef.variant <- true;
+ if variant then typdef.variant <- true;
List.iter constructors ~f:
begin fun c ->
if not (check_duplicate_constr false c typdef.constructors)
- then begin
+ 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 <-
typdef.requires_widget_context ||
has_callback c.template
end
@@ -323,17 +323,17 @@ let enter_type typname ?(variant = false) arity constructors =
(* Enter a subtype *)
let enter_subtype typ arity subtyp constructors =
(* Retrieve the type if already defined, else add a new one *)
- let typdef =
+ let typdef =
try Hashtbl.find types_table typ
with Not_found -> new_type typ arity
in
if List.mem_assoc subtyp typdef.subtypes
then raise (Duplicate_Definition ("subtype", typ ^" "^subtyp))
else begin
- let real_constructors =
+ let real_constructors =
List.map constructors ~f:
begin function
- Full c ->
+ Full c ->
if not (check_duplicate_constr true c typdef.constructors)
then begin
add_template_dependancies typ c.template;
@@ -359,10 +359,10 @@ let enter_subtype typ arity subtyp constructors =
let retrieve_option optname =
let optiontyp =
try Hashtbl.find types_table "options"
- with
+ with
Not_found -> raise (Invalid_implicit_constructor optname)
in find_constructor optname optiontyp.constructors
-
+
(* Sort components by type *)
let rec add_sort l obj =
match l with
@@ -370,7 +370,7 @@ let rec add_sort l obj =
| (s',l)::rest ->
if obj.component = s' then
(s',obj::l)::rest
- else
+ else
(s',l)::(add_sort rest obj)
let separate_components = List.fold_left ~f:add_sort ~init:[]
@@ -380,24 +380,24 @@ let enter_widget name components =
raise (Duplicate_Definition ("widget/module", name)) else
let sorted_components = separate_components components in
List.iter sorted_components ~f:
- begin function
+ begin function
Constructor, l ->
- enter_subtype "options" MultipleToken
+ enter_subtype "options" MultipleToken
name (List.map ~f:(fun c -> Full c) l)
- | Command, l ->
+ | Command, l ->
List.iter ~f:enter_component_types l
| External, _ -> ()
end;
- let commands =
+ let commands =
try List.assoc Command sorted_components
- with Not_found -> []
- and externals =
+ with Not_found -> []
+ and externals =
try List.assoc External sorted_components
with Not_found -> []
in
- Hashtbl.add module_table name
+ Hashtbl.add module_table name
{module_type = Widget; commands = commands; externals = externals}
-
+
(******************** Functions ********************)
let enter_function comp =
@@ -406,22 +406,22 @@ let enter_function comp =
(******************** Modules ********************)
-let enter_module name components =
+let enter_module name components =
if Hashtbl.mem module_table name then
raise (Duplicate_Definition ("widget/module", name)) else
let sorted_components = separate_components components in
List.iter sorted_components ~f:
- begin function
+ begin function
Constructor, l -> fatal_error "unexpected Constructor"
| Command, l -> List.iter ~f:enter_component_types l
| External, _ -> ()
end;
- let commands =
+ let commands =
try List.assoc Command sorted_components
- with Not_found -> []
- and externals =
+ with Not_found -> []
+ and externals =
try List.assoc External sorted_components
with Not_found -> []
in
- Hashtbl.add module_table name
+ Hashtbl.add module_table name
{module_type = Family; commands = commands; externals = externals}
diff --git a/otherlibs/labltk/compiler/tsort.ml b/otherlibs/labltk/compiler/tsort.ml
index a174fb3da..6496eaae2 100644
--- a/otherlibs/labltk/compiler/tsort.ml
+++ b/otherlibs/labltk/compiler/tsort.ml
@@ -35,7 +35,7 @@ exception Cyclic
let find_entry order node =
let rec search_entry =
- function
+ function
[] -> raise Not_found
| x::l -> if x.node = node then x else search_entry l
in
@@ -48,7 +48,7 @@ let find_entry order node =
order := entry::!order;
entry
-let create () = ref []
+let create () = ref []
(* Inverted args because Sort.list builds list in reverse order *)
let add_relation order (succ,pred) =
@@ -62,28 +62,26 @@ let add_element order e =
ignore (find_entry order e)
let sort order =
- let q = Queue.create ()
+ let q = Queue.create ()
and result = ref [] in
List.iter !order
~f:(function {pred_count = n} as node ->
if n = 0 then Queue.add node q);
- begin try
+ begin try
while true do
let t = Queue.take q in
result := t.node :: !result;
List.iter t.successors ~f:
- begin fun s ->
+ 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 ->
+ Queue.Empty ->
List.iter !order
~f:(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-27 17:05:51 +0000