summaryrefslogtreecommitdiffstats
path: root/otherlibs/labltk/compiler
diff options
context:
space:
mode:
Diffstat (limited to 'otherlibs/labltk/compiler')
-rw-r--r--otherlibs/labltk/compiler/compile.ml120
-rw-r--r--otherlibs/labltk/compiler/intf.ml30
-rw-r--r--otherlibs/labltk/compiler/lexer.mll4
-rw-r--r--otherlibs/labltk/compiler/maincompile.ml90
-rw-r--r--otherlibs/labltk/compiler/ppexec.ml34
-rw-r--r--otherlibs/labltk/compiler/pplex.mll2
-rw-r--r--otherlibs/labltk/compiler/ppparse.ml4
7 files changed, 142 insertions, 142 deletions
diff --git a/otherlibs/labltk/compiler/compile.ml b/otherlibs/labltk/compiler/compile.ml
index 78adbcee6..42754dfd3 100644
--- a/otherlibs/labltk/compiler/compile.ml
+++ b/otherlibs/labltk/compiler/compile.ml
@@ -87,7 +87,7 @@ let rec types_of_template = function
| ListArg l -> List.flatten (List.map ~f:types_of_template l)
| OptionalArgs (l, tl, _) ->
begin
- match List.flatten (List.map ~f:types_of_template tl) with
+ 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")
@@ -149,7 +149,7 @@ let ppMLtype ?(any=false) ?(return=false) ?(def=false) ?(counter=ref 0) =
| UserDefined "widget" ->
if !Flags.camltk then "widget"
else begin
- if any then "any widget" else
+ if any then "any widget" else
let c = String.make 1 (Char.chr(Char.code 'a' + !counter)) in
incr counter;
"'" ^ c ^ " widget"
@@ -158,20 +158,20 @@ let ppMLtype ?(any=false) ?(return=false) ?(def=false) ?(counter=ref 0) =
if !Flags.camltk then s
else begin
(* a bit dirty hack for ImageBitmap and ImagePhoto *)
- try
+ try
let typdef = Hashtbl.find types_table s in
if typdef.variant then
if return then try
"[>" ^
String.concat ~sep:"|"
- (List.map typdef.constructors ~f:
+ (List.map typdef.constructors ~f:
begin
fun c ->
"`" ^ c.var_name ^
(match types_of_template c.template with
- [] -> ""
+ [] -> ""
| l -> " of " ^ ppMLtype (Product (List.map l
- ~f:(labeloff ~at:"ppMLtype UserDefined"))))
+ ~f:(labeloff ~at:"ppMLtype UserDefined"))))
end) ^ "]"
with
Not_found -> prerr_endline ("ppMLtype " ^ s ^ " ?"); s
@@ -179,7 +179,7 @@ let ppMLtype ?(any=false) ?(return=false) ?(def=false) ?(counter=ref 0) =
"[< " ^ s ^ "]"
else s
else s
- with Not_found -> s
+ with Not_found -> s
end
| Subtype (s, s') ->
if !Flags.camltk then "(* " ^ s' ^ " *) " ^ s else s' ^ "_" ^ s
@@ -274,10 +274,10 @@ let write_constructor_set ~w ~sep = function
| x::l ->
w ("C" ^ x.ml_name);
List.iter l ~f: (function x ->
- w sep;
- w ("C" ^ x.ml_name))
+ 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";
@@ -335,9 +335,9 @@ let rec converterTKtoCAML ~arg = function
["(Obj.magic (cTKtoCAMLwidget "; arg; ") :"; s'; "widget)"]
| Subtype (s, s') ->
if !Flags.camltk then
- "cTKtoCAML" ^ s ^ " " ^ arg
+ "cTKtoCAML" ^ s ^ " " ^ arg
else
- "cTKtoCAML" ^ s' ^ "_" ^ s ^ " " ^ arg
+ "cTKtoCAML" ^ s' ^ "_" ^ s ^ " " ^ arg
| List ty ->
begin match type_parser_arity ty with
OneToken ->
@@ -400,8 +400,8 @@ let rec wrapper_code ~name ty =
String.concat ~sep:"" readarg ^ name ^ " " ^
String.concat ~sep:" "
(List.map2 ~f:(fun v (l, _) ->
- if !Flags.camltk then v
- else labelstring l ^ v) vnames tyl)
+ if !Flags.camltk then v
+ else labelstring l ^ v) vnames tyl)
(* all other types are read in one operation *)
| List ty ->
@@ -562,11 +562,11 @@ let rec converterCAMLtoTK ~context_widget argname ty =
let name = "cCAMLtoTK" ^ s ^ " " in
let args = argname in
let args =
- if !Flags.camltk then begin
- if is_subtyped s then (* unconstraint subtype *)
- s ^ "_any_table " ^ args
- else args
- end else args
+ if !Flags.camltk then begin
+ if is_subtyped s then (* unconstraint subtype *)
+ s ^ "_any_table " ^ args
+ else args
+ end else args
in
let args =
if requires_widget_context s then
@@ -575,30 +575,30 @@ let rec converterCAMLtoTK ~context_widget argname ty =
name ^ args
| Subtype ("widget", s') ->
if !Flags.camltk then
- let name = "cCAMLtoTKwidget " in
- let args = "widget_"^s'^"_table "^argname in
- let args =
- if requires_widget_context "widget" then
- context_widget^" "^args
+ let name = "cCAMLtoTKwidget " in
+ let args = "widget_"^s'^"_table "^argname in
+ let args =
+ if requires_widget_context "widget" then
+ context_widget^" "^args
else args in
- name^args
+ name^args
else begin
- let name = "cCAMLtoTKwidget " in
- let args = "(" ^ argname ^ " : " ^ s' ^ " widget)" in
- name ^ args
+ let name = "cCAMLtoTKwidget " in
+ let args = "(" ^ argname ^ " : " ^ s' ^ " widget)" in
+ name ^ args
end
| Subtype (s, s') ->
let name =
- if !Flags.camltk then "cCAMLtoTK" ^ s ^ " "
- else "cCAMLtoTK" ^ s' ^ "_" ^ s ^ " "
+ if !Flags.camltk then "cCAMLtoTK" ^ s ^ " "
+ else "cCAMLtoTK" ^ s' ^ "_" ^ s ^ " "
in
let args =
- if !Flags.camltk then begin
- s^"_"^s'^"_table "^argname
- end else begin
+ if !Flags.camltk then begin
+ s^"_"^s'^"_table "^argname
+ end else begin
if safetype then "(" ^ argname ^ " : [< " ^ s' ^ "_" ^ s ^ "])"
else argname
- end
+ end
in
let args =
if requires_widget_context s then context_widget ^ " " ^ args
@@ -648,20 +648,20 @@ let code_of_template ~context_widget ?func:(funtemplate=false) template =
StringArg s -> "TkToken \"" ^ s ^ "\""
| TypeArg (_, List (Subtype (sup, sub) as ty)) when not !Flags.camltk ->
begin try
- let typdef = Hashtbl.find types_table sup in
- let classdef = List.assoc sub typdef.subtypes in
- let lbl = gettklabel (List.hd classdef) in
- catch_opts := (sub ^ "_" ^ sup, lbl);
- newvar := newvar2;
- "TkTokenList opts"
+ let typdef = Hashtbl.find types_table sup in
+ let classdef = List.assoc sub typdef.subtypes in
+ let lbl = gettklabel (List.hd classdef) in
+ catch_opts := (sub ^ "_" ^ sup, lbl);
+ newvar := newvar2;
+ "TkTokenList opts"
with Not_found ->
- raise (Failure (Printf.sprintf "type %s(%s) not found" sup sub));
+ raise (Failure (Printf.sprintf "type %s(%s) not found" sup sub));
end
| TypeArg (l, List ty) ->
(if !Flags.camltk then
- "TkTokenList (List.map (function x -> "
+ "TkTokenList (List.map (function x -> "
else
- "TkTokenList (List.map ~f:(function x -> ")
+ "TkTokenList (List.map ~f:(function x -> ")
^ converterCAMLtoTK ~context_widget "x" ty
^ ") " ^ !newvar l ^ ")"
| TypeArg (l, Function tyarg) ->
@@ -801,9 +801,9 @@ let rec write_result_parsing ~w = function
w "(splitlist res)"
| List ty ->
if !Flags.camltk then
- w (" List.map " ^ converterTKtoCAML ~arg:"(splitlist res)" ty)
+ w (" List.map " ^ converterTKtoCAML ~arg:"(splitlist res)" ty)
else
- w (" List.map ~f: " ^ converterTKtoCAML ~arg:"(splitlist res)" ty)
+ w (" List.map ~f: " ^ converterTKtoCAML ~arg:"(splitlist res)" ty)
| Product tyl -> raise (Failure "Product -> record was done. ???")
| Record tyl -> (* of course all the labels are "" *)
let rnames = varnames ~prefix:"r" (List.length tyl) in
@@ -937,11 +937,11 @@ let camltk_write_function ~w def =
| l ->
let has_normal_argument = ref false in
List.iter (fun (l,x) ->
- w " ";
- if l <> "" then
- if l.[0] = '?' then w (l ^ ":") else has_normal_argument := true
- else has_normal_argument := true;
- w x) l;
+ w " ";
+ if l <> "" then
+ if l.[0] = '?' then w (l ^ ":") else has_normal_argument := true
+ else has_normal_argument := true;
+ w x) l;
if not !has_normal_argument then w " ()";
w " =\n"
end;
@@ -1015,16 +1015,16 @@ let write_external ~w def =
begin try
let realname = find_in_path !search_path (fname ^ ".ml") in
let ic = open_in_bin realname in
- try
- let code_list = Ppparse.parse_channel ic in
- close_in ic;
- List.iter (Ppexec.exec (fun _ -> ()) w)
- (if !Flags.camltk then
- Code.Define "CAMLTK" :: code_list else code_list );
- with
- | Ppparse.Error s ->
- close_in ic;
- raise (Compiler_Error (Printf.sprintf "Preprocess error: %s" s))
+ try
+ let code_list = Ppparse.parse_channel ic in
+ close_in ic;
+ List.iter (Ppexec.exec (fun _ -> ()) w)
+ (if !Flags.camltk then
+ Code.Define "CAMLTK" :: code_list else code_list );
+ with
+ | Ppparse.Error s ->
+ close_in ic;
+ raise (Compiler_Error (Printf.sprintf "Preprocess error: %s" s))
with
| Not_found ->
raise (Compiler_Error ("can't find external file: " ^ fname))
diff --git a/otherlibs/labltk/compiler/intf.ml b/otherlibs/labltk/compiler/intf.ml
index e155ec5ee..58955b962 100644
--- a/otherlibs/labltk/compiler/intf.ml
+++ b/otherlibs/labltk/compiler/intf.ml
@@ -145,11 +145,11 @@ let camltk_write_function_type ~w def =
List.iter tys ~f:
begin fun (l, t) ->
if l <> "" then
- if l.[0] = '?' then w (l^":")
- else begin
- have_normal_arg := true;
- w (" (* " ^ l ^ ":*)")
- end
+ if l.[0] = '?' then w (l^":")
+ else begin
+ have_normal_arg := true;
+ w (" (* " ^ l ^ ":*)")
+ end
else have_normal_arg := true;
w (ppMLtype t ~counter);
w " -> "
@@ -171,19 +171,19 @@ let write_external_type ~w def =
begin try
let realname = find_in_path !search_path (fname ^ ".mli") in
let ic = open_in_bin realname in
- try
- let code_list = Ppparse.parse_channel ic in
- close_in ic;
+ try
+ let code_list = Ppparse.parse_channel ic in
+ close_in ic;
if not def.safe then w "(* unsafe *)\n";
- List.iter (Ppexec.exec (fun _ -> ()) w)
- (if !Flags.camltk then
- Code.Define "CAMLTK" :: code_list else code_list );
+ List.iter (Ppexec.exec (fun _ -> ()) w)
+ (if !Flags.camltk then
+ Code.Define "CAMLTK" :: code_list else code_list );
if def.safe then w "\n\n"
else w "\n(* /unsafe *)\n\n"
- with
- | Ppparse.Error s ->
- close_in ic;
- raise (Compiler_Error (Printf.sprintf "Preprocess error: %s" s))
+ with
+ | Ppparse.Error s ->
+ close_in ic;
+ raise (Compiler_Error (Printf.sprintf "Preprocess error: %s" s))
with
| Not_found ->
raise (Compiler_Error ("can't find external file: " ^ fname))
diff --git a/otherlibs/labltk/compiler/lexer.mll b/otherlibs/labltk/compiler/lexer.mll
index 5c04dc674..c65c9a604 100644
--- a/otherlibs/labltk/compiler/lexer.mll
+++ b/otherlibs/labltk/compiler/lexer.mll
@@ -162,8 +162,8 @@ and comment = parse
and linenum = parse
| ['0'-'9']+ {
let next_line = int_of_string (Lexing.lexeme lexbuf) in
- current_line := next_line - 1
- }
+ current_line := next_line - 1
+ }
| _ { raise (Lexical_error("illegal ##line directive: no line number"))}
and line = parse
diff --git a/otherlibs/labltk/compiler/maincompile.ml b/otherlibs/labltk/compiler/maincompile.ml
index 19b770554..585deecaa 100644
--- a/otherlibs/labltk/compiler/maincompile.ml
+++ b/otherlibs/labltk/compiler/maincompile.ml
@@ -54,16 +54,16 @@ let parse_file filename =
close_in ic;
let buf = Buffer.create 50000 in
List.iter (Ppexec.exec
- (fun l -> Buffer.add_string buf
- (Printf.sprintf "##line %d\n" l))
- (Buffer.add_string buf))
- (if !Flags.camltk then Code.Define "CAMLTK" :: code_list
- else code_list);
+ (fun l -> Buffer.add_string buf
+ (Printf.sprintf "##line %d\n" l))
+ (Buffer.add_string buf))
+ (if !Flags.camltk then Code.Define "CAMLTK" :: code_list
+ else code_list);
Lexing.from_string (Buffer.contents buf)
with
| Ppparse.Error s ->
- close_in ic;
- raise (Compiler_Error (Printf.sprintf "Preprocess error: %s" s))
+ close_in ic;
+ raise (Compiler_Error (Printf.sprintf "Preprocess error: %s" s))
in
try
while true do
@@ -145,22 +145,22 @@ let option_hack oc =
let hack =
{ parser_arity = OneToken;
constructors = begin
- let constrs =
+ let constrs =
List.map typdef.constructors ~f:
begin fun c ->
{ component = Constructor;
- ml_name = (if !Flags.camltk then "C" ^ c.ml_name
- else c.ml_name);
- var_name = c.var_name; (* as variants *)
- template =
- begin match c.template with
- ListArg (x :: _) -> x
- | _ -> fatal_error "bogus hack"
- end;
- result = UserDefined "options_constrs";
- safe = true }
+ ml_name = (if !Flags.camltk then "C" ^ c.ml_name
+ else c.ml_name);
+ var_name = c.var_name; (* as variants *)
+ template =
+ begin match c.template with
+ ListArg (x :: _) -> x
+ | _ -> fatal_error "bogus hack"
+ end;
+ result = UserDefined "options_constrs";
+ safe = true }
end in
- if !Flags.camltk then constrs else uniq_clauses constrs (* JPF ?? *)
+ if !Flags.camltk then constrs else uniq_clauses constrs (* JPF ?? *)
end;
subtypes = [];
requires_widget_context = false;
@@ -238,13 +238,13 @@ let compile () =
end;
List.iter ~f:(fun s -> output_string oc s; output_string oc' s)
begin
- if !Flags.camltk then
- [ "open CTk\n";
+ if !Flags.camltk then
+ [ "open CTk\n";
"open Tkintf\n";
"open Widget\n";
"open Textvariable\n\n" ]
- else
- [ "open StdLabels\n";
+ else
+ [ "open StdLabels\n";
"open Tk\n";
"open Tkintf\n";
"open Widget\n";
@@ -254,14 +254,14 @@ let compile () =
begin match wdef.module_type with
Widget ->
if !Flags.camltk then begin
- camltk_write_create ~w:(output_string oc) wname;
- camltk_write_named_create ~w:(output_string oc) wname;
- camltk_write_create_p ~w:(output_string oc') wname;
- camltk_write_named_create_p ~w:(output_string oc') wname;
- end else begin
- labltk_write_create ~w:(output_string oc) wname;
+ camltk_write_create ~w:(output_string oc) wname;
+ camltk_write_named_create ~w:(output_string oc) wname;
+ camltk_write_create_p ~w:(output_string oc') wname;
+ camltk_write_named_create_p ~w:(output_string oc') wname;
+ end else begin
+ labltk_write_create ~w:(output_string oc) wname;
labltk_write_create_p ~w:(output_string oc') wname
- end
+ end
| Family -> ()
end;
List.iter ~f:(write_function ~w:(output_string oc))
@@ -295,8 +295,8 @@ let compile () =
Hashtbl.iter (fun name _ ->
let cname = realname name in
output_string oc (Printf.sprintf "module %s = %s;;\n"
- (String.capitalize name)
- (String.capitalize cname))) module_table;
+ (String.capitalize name)
+ (String.capitalize cname))) module_table;
close_out oc
end else begin
let oc = open_out_bin (destfile "labltk.ml") in
@@ -316,20 +316,20 @@ module Timer = Timer;;
Hashtbl.iter (fun name _ ->
let cname = realname name in
output_string oc (Printf.sprintf "module %s = %s;;\n"
- (String.capitalize name)
- (String.capitalize name))) module_table;
+ (String.capitalize name)
+ (String.capitalize name))) module_table;
(* widget typer *)
output_string oc "\n(** Widget typers *)\n\nopen Widget\n\n";
Hashtbl.iter (fun name def ->
match def.module_type with
- | Widget ->
- output_string oc (Printf.sprintf
- "let %s (w : any widget) =\n" name);
- output_string oc (Printf.sprintf
- " Rawwidget.check_class w widget_%s_table;\n" name);
- output_string oc (Printf.sprintf
- " (Obj.magic w : %s widget);;\n\n" name);
- | _ -> () ) module_table;
+ | Widget ->
+ output_string oc (Printf.sprintf
+ "let %s (w : any widget) =\n" name);
+ output_string oc (Printf.sprintf
+ " Rawwidget.check_class w widget_%s_table;\n" name);
+ output_string oc (Printf.sprintf
+ " (Obj.magic w : %s widget);;\n\n" name);
+ | _ -> () ) module_table;
close_out oc
end;
@@ -370,9 +370,9 @@ module Timer = Timer;;
output_string oc "camltk.cmo : cTk.cmo ";
Hashtbl.iter
(fun name _ ->
- let name = realname name in
- output_string oc name;
- output_string oc ".cmo ") module_table;
+ let name = realname name in
+ output_string oc name;
+ output_string oc ".cmo ") module_table;
output_string oc "\n"
end;
diff --git a/otherlibs/labltk/compiler/ppexec.ml b/otherlibs/labltk/compiler/ppexec.ml
index 6754a6521..994688203 100644
--- a/otherlibs/labltk/compiler/ppexec.ml
+++ b/otherlibs/labltk/compiler/ppexec.ml
@@ -25,8 +25,8 @@ let rec nop = function
| Ifdef (_, _, c1, c2o) ->
List.iter nop c1;
begin match c2o with
- | Some c2 -> List.iter nop c2
- | None -> ()
+ | Some c2 -> List.iter nop c2
+ | None -> ()
end
| _ -> ()
;;
@@ -34,27 +34,27 @@ let rec nop = function
let rec exec lp f = function
| Line line ->
if !debug then
- prerr_endline (Printf.sprintf "%03d: %s" !linenum
- (String.sub line 0 ((String.length line) - 1)));
+ prerr_endline (Printf.sprintf "%03d: %s" !linenum
+ (String.sub line 0 ((String.length line) - 1)));
f line; incr linenum
| Ifdef (sw, k, c1, c2o) ->
if List.mem k !defined = sw then begin
- List.iter (exec lp f) c1;
- begin match c2o with
- | Some c2 -> List.iter nop c2
- | None -> ()
- end;
- lp !linenum
+ List.iter (exec lp f) c1;
+ begin match c2o with
+ | Some c2 -> List.iter nop c2
+ | None -> ()
+ end;
+ lp !linenum
end else begin
- List.iter nop c1;
- match c2o with
- | Some c2 ->
- lp !linenum;
- List.iter (exec lp f) c2
- | None -> ()
+ List.iter nop c1;
+ match c2o with
+ | Some c2 ->
+ lp !linenum;
+ List.iter (exec lp f) c2
+ | None -> ()
end
| Define k -> defined := k :: !defined
| Undef k ->
defined := List.fold_right (fun k' s ->
- if k = k' then s else k' :: s) [] !defined
+ if k = k' then s else k' :: s) [] !defined
;;
diff --git a/otherlibs/labltk/compiler/pplex.mll b/otherlibs/labltk/compiler/pplex.mll
index d68ee4db6..bb30c233a 100644
--- a/otherlibs/labltk/compiler/pplex.mll
+++ b/otherlibs/labltk/compiler/pplex.mll
@@ -34,7 +34,7 @@ rule token = parse
let str = Lexing.lexeme lexbuf in
let line = !linenum in
if String.length str <> 0 && str.[String.length str - 1] = '\n' then
- begin
+ begin
incr linenum
end;
OTHER (str)
diff --git a/otherlibs/labltk/compiler/ppparse.ml b/otherlibs/labltk/compiler/ppparse.ml
index 91287d34a..3d1ee2af4 100644
--- a/otherlibs/labltk/compiler/ppparse.ml
+++ b/otherlibs/labltk/compiler/ppparse.ml
@@ -26,11 +26,11 @@ let parse_channel ic =
and loc_end = Lexing.lexeme_end lexbuf
in
raise (Error (Printf.sprintf "parse error at char %d, %d: %s"
- loc_start loc_end s))
+ loc_start loc_end s))
| Parsing.Parse_error ->
let loc_start = Lexing.lexeme_start lexbuf
and loc_end = Lexing.lexeme_end lexbuf
in
raise (Error (Printf.sprintf "parse error at char %d, %d"
- loc_start loc_end))
+ loc_start loc_end))
;;
generated by cgit v1.2.3-70-g09d2 (git 2.46.0) at 2025-03-26 15:11:03 +0000