(* This file is distributed under the terms and conditions of the GNU GPL
(General Public License), as detailed in the file LICENSE.
Copyright (C) 2016 by Gerd Stolpmann.
*)
(* Run this as:
ocaml make.ml <args>
This is a little "make"-like utility. It is not fully implemented, and
mainly intended to help building omake under Windows.
*)
(* TODO:
- globbing for sources
- emulate cp, rm, ln, echo for Windows
- suffix substitution
*)
#warnings "-3";;
#load "str.cma";;
#load "unix.cma";;
open Printf
module StrMap = Map.Make(String)
module StrSet = Set.Make(String)
type exp_rule =
{ targets : string list;
sources : string list;
commands : string list; (* reverse order *)
}
type suffix_rule =
{ target_suffix : string;
source_suffix : string;
sfx_commands : string list; (* reverse order *)
}
type rule =
| Explicit of exp_rule
| DblColon of exp_rule
| Suffix of suffix_rule
type rules =
{ exp_rules : exp_rule StrMap.t; (* keyed by target *)
dblcolon_rules : exp_rule list StrMap.t; (* keyed by target; rev order *)
suffix_rules : suffix_rule list;
enabled_suffixes : StrSet.t;
phonies : StrSet.t;
default : string list;
}
let empty_rules =
{ exp_rules = StrMap.empty;
dblcolon_rules = StrMap.empty;
suffix_rules = [];
enabled_suffixes = StrSet.empty;
phonies = StrSet.empty;
default = [];
}
type expr =
| Concat of expr list
| Literal of string
| Variable of string
| Shell of expr
type varvalue =
| Expanded of string
| Unexpanded of expr
type varmap = varvalue StrMap.t (* keyed by var name *)
let debug_enabled = ref false
let debug s =
if !debug_enabled then
print_endline s
let catch_not_found f arg ~on_result ~on_not_found =
match
try Some(f arg) with Not_found -> None
with
| Some r -> on_result r
| None -> on_not_found()
let starts_with s u =
let sl = String.length s in
let ul = String.length u in
sl >= ul && String.sub s 0 ul = u
let multi_index s k charlist =
let l = String.length s in
let rec search k =
if k >= l then
raise Not_found;
let c = s.[k] in
if List.mem c charlist then
k
else
search (k+1) in
search k
let read_data ch =
(* textual data *)
let buf = Buffer.create 1024 in
try
while true do
let line = input_line ch in
if Buffer.length buf > 0 then
Buffer.add_char buf '\n';
let n = String.length line in
if n > 0 && line.[n-1] = '\r' then
Buffer.add_substring buf line 0 (n-1)
else
Buffer.add_string buf line
done;
assert false
with
| End_of_file ->
Buffer.contents buf
let ws_re = Str.regexp "[ \t\r\n]+"
let wildcard_re = Str.regexp "\\*\\(\\.[a-zA-Z0-9]+\\)"
let expand_command cmd =
(* Windows shells do not expand wildcards, so we need to do it here.
The following is super-primitive and only covers the form *.suffix.
Quoting is not taken into account.
*)
if Sys.os_type = "Win32" then
let words = Str.split ws_re cmd in
if List.exists (fun w -> Str.string_match wildcard_re w 0) words then
let words' =
List.flatten
(List.map
(fun word ->
if Str.string_match wildcard_re word 0 then
let suffix = Str.matched_group 1 word in
List.filter
(fun file -> Filename.check_suffix file suffix)
(Array.to_list(Sys.readdir "."))
else
[word]
)
words
) in
String.concat " " words'
else
cmd
else
cmd
let command_output cmd =
let ch = Unix.open_process_in (expand_command cmd) in
try
let data = read_data ch in
let status = Unix.close_process_in ch in
match status with
| Unix.WEXITED 0 ->
data
| Unix.WEXITED n ->
failwith ("Command exited with error: " ^ cmd)
| _ ->
failwith ("Command exited with signal: " ^ cmd)
with
| Unix.Unix_error(code,_,name) ->
ignore(Unix.close_process_in ch);
let prefix =
if name = "" then "" else name ^ ": " in
raise (Sys_error(prefix ^ Unix.error_message code))
let rec eval_expr active env expr =
match expr with
| Concat l ->
let l' = List.map (eval_expr active env) l in
String.concat "" l'
| Literal s ->
s
| Variable name ->
if StrSet.mem name active then
failwith ("Recursive variable: " ^ name);
let value =
try StrMap.find name env
with Not_found ->
try Expanded(Sys.getenv name)
with Not_found ->
Expanded "" in
( match value with
| Expanded s -> s
| Unexpanded expr -> eval_expr (StrSet.add name active) env expr
)
| Shell expr ->
let cmd = eval_expr active env expr in
command_output cmd
let rec parse_expr s =
let l = String.length s in
let literal_list k0 k1 =
if k1 > k0 then
[ Literal(String.sub s k0 (k1-k0)) ]
else
[] in
let rec find_dollar delims onend acc k =
let delimchars = List.map fst delims in
catch_not_found
(multi_index s k) ('$' :: delimchars)
~on_result:(
fun d ->
let c = s.[d] in
if c = '$' then (
if d+1 >= l then failwith "Bad expression: '$' at end";
let litl = literal_list k d in
let c = s.[d+1] in
match c with
| '$' ->
let acc' = [ Literal "$" ] @ litl @ acc in
find_dollar delims onend acc' (d+2)
| '(' ->
let acc' = litl @ acc in
find_varend delims onend acc' ')' (d+2)
| '{' ->
let acc' = litl @ acc in
find_varend delims onend acc' '}' (d+2)
| _ ->
let name = String.make 1 c in
let acc' = [ Variable name ] @ litl @ acc in
find_dollar delims onend acc' (d+2)
) else
let litl = literal_list k d in
let f = List.assoc c delims in
f (litl @ acc) (d+1)
)
~on_not_found:(
fun () ->
let acc' = literal_list k l @ acc in
onend acc'
)
and find_varend old_delims old_onend acc cend k =
catch_not_found
(multi_index s k) [cend; ' '; '\t'; '('; '{'; '$']
~on_result:(
fun e ->
let c = s.[e] in
if c = cend then
let name = String.sub s k (e-k) in
let acc' = [ Variable name ] @ acc in
find_dollar old_delims old_onend acc' (e+1)
else
match c with
| ' '
| '\t' ->
let name = String.sub s k (e-k) in
if name = "shell" then
let new_delims =
[ cend, (fun subexpr p ->
let acc' =
Shell (Concat (List.rev subexpr)) :: acc in
find_dollar old_delims old_onend acc' p
)
] @ old_delims in
let new_onend _ =
failwith "Bad expression: unterminated shell command" in
find_dollar new_delims new_onend [] (e+1)
else
failwith ("Bad expression: unsupported function: " ^
name)
| _ ->
Printf.eprintf "Char: %c\n%!" c;
failwith "Bad expression: variable ref contains bad char"
)
~on_not_found:(fun () ->
failwith "Bad expression: unterminated variable ref"
)
in
find_dollar [] (fun l -> Concat(List.rev l)) [] 0
let expand env s =
let expr = parse_expr s in
eval_expr StrSet.empty env expr
let ws_re =
Str.regexp "^[ \t\t\n]*$";;
let set_var_re =
Str.regexp "^\\([^ +?=:]+\\)[ \t]*\\([:?+]?=\\)[ \t]*\\(.*\\)$"
let dblcolon_rule_re =
Str.regexp "^\\([^:]+\\)::\\(.*\\)$"
let rule_re =
Str.regexp "^\\([^:]+\\):\\(.*\\)$"
let include_re =
Str.regexp "^include[ \t]+\\([^ \t].*\\)$"
let split_ws_re =
Str.regexp "[ \t\r\n]+"
let rec fold_lines fh f number acc =
match
try Some(input_line fh)
with End_of_file -> None
with
| Some line ->
let acc' = f number line acc in
fold_lines fh f (number+1) acc'
| None ->
acc
let update_env name op value env =
match op with
| "=" ->
let expr = parse_expr value in
StrMap.add name (Unexpanded expr) env
| "?=" ->
let expr = parse_expr value in
if StrMap.mem name env then
env
else
StrMap.add name (Unexpanded expr) env
| "+=" ->
let expr = parse_expr value in
let old_value =
match
try StrMap.find name env
with Not_found -> Unexpanded (Concat [])
with
| Unexpanded e -> e
| Expanded s -> Literal s in
let new_value =
if old_value = Concat [] then
expr
else
Concat [old_value; Literal " "; expr] in
StrMap.add name (Unexpanded new_value) env
| ":=" ->
let expr = parse_expr value in
let value = eval_expr StrSet.empty env expr in
StrMap.add name (Expanded value) env
| _ ->
assert false
let is_empty line =
Str.string_match ws_re line 0
let append_to_rule rule line =
match rule with
| Explicit r -> Explicit { r with commands = line :: r.commands }
| DblColon r -> DblColon { r with commands = line :: r.commands }
| Suffix r -> Suffix { r with sfx_commands = line :: r.sfx_commands }
let same_suffix_rule r1 r2 =
r1.target_suffix = r2.target_suffix &&
r1.source_suffix = r2.source_suffix
let enter_rule1 current env rules =
match current with
| None ->
rules
| Some (Explicit r) ->
if r.commands = [] then
List.fold_left
(fun rules target ->
if StrMap.mem target rules.dblcolon_rules then
failwith "Cannot have both normal and double-colon rules for \
the same target";
if StrMap.mem target rules.exp_rules then
(* add further dependencies to existing explicit rule *)
let r1 = StrMap.find target rules.exp_rules in
let r2 = { r1 with sources = r1.sources @ r.sources } in
{ rules with
exp_rules = StrMap.add target r2 rules.exp_rules
}
else (
debug ("Enter " ^ target);
(* add command-less rule *)
{ rules with
exp_rules = StrMap.add target r rules.exp_rules
}
)
)
rules
r.targets
else (
(* new explicit rule *)
List.iter
(fun target ->
if StrMap.mem target rules.dblcolon_rules then
failwith "Cannot have both normal and double-colon rules for \
the same target";
try
let r = StrMap.find target rules.exp_rules in
if r.commands <> [] then
failwith("Rule for target already exists: " ^ target);
with Not_found -> ()
)
r.targets;
List.fold_left
(fun rules target ->
debug ("Enter " ^ target);
let r1 =
try
let r0 = StrMap.find target rules.exp_rules in
{ r with sources = r0.sources @ r.sources }
with Not_found -> r in
{ rules with
exp_rules = StrMap.add target r1 rules.exp_rules
}
)
rules
r.targets
)
| Some (DblColon r) ->
let target = List.hd r.targets in (* only one target here *)
if StrMap.mem target rules.exp_rules then
failwith "Cannot have both normal and double-colon rules for the \
same target";
( try
let l = StrMap.find target rules.dblcolon_rules in
{ rules with
dblcolon_rules = StrMap.add target (r :: l) rules.dblcolon_rules
}
with
| Not_found ->
{ rules with
dblcolon_rules = StrMap.add target [r] rules.dblcolon_rules
}
)
| Some (Suffix r) ->
if List.exists (same_suffix_rule r) rules.suffix_rules then
failwith ("Suffix rule already exists: " ^
r.source_suffix ^ r.target_suffix);
{ rules with
suffix_rules = r :: rules.suffix_rules
}
let enter_rule current env rules =
let rules = enter_rule1 current env rules in
match current with
| Some (Explicit r) when rules.default = [] ->
{ rules with
default = r.targets
}
| _ ->
rules
let is_suffix_comb suffixes word =
StrSet.fold
(fun source_suffix acc ->
match acc with
| None ->
if starts_with word source_suffix then
let l1 = String.length source_suffix in
let l2 = String.length word in
let target_suffix = String.sub word l1 (l2-l1) in
if StrSet.mem target_suffix suffixes then
Some(target_suffix,source_suffix)
else
None
else
None
| Some _ ->
acc
)
suffixes
None
let match_rule text =
if Str.string_match dblcolon_rule_re text 0 then
let target_str = Str.matched_group 1 text in
let source_str = Str.matched_group 2 text in
Some(`DblColon, target_str, source_str)
else
if Str.string_match rule_re text 0 then
let target_str = Str.matched_group 1 text in
let source_str = Str.matched_group 2 text in
Some(`Colon, target_str, source_str)
else
None
let process_rule env rules' ty target_str source_str =
let target_words0 = Str.split split_ws_re target_str in
(* not handled: glob expressions in sources *)
( match target_words0 with
| [] ->
failwith "Empty target"
| [ ".PHONY" ] ->
if ty = `DblColon then
failwith ".PHONY not possible with double-colon rule";
let source_words =
Str.split split_ws_re (expand env source_str) in
let phonies =
List.fold_left
(fun acc phony -> StrSet.add phony acc)
rules'.phonies
source_words in
let rules'' = { rules' with phonies } in
([],None,env,rules'')
| [ ".SUFFIXES" ] ->
if ty = `DblColon then
failwith ".SUFFIXES not possible with double-colon rule";
let source_words =
Str.split split_ws_re (expand env source_str) in
let enabled_suffixes =
List.fold_left
(fun acc suffix -> StrSet.add suffix acc)
rules'.enabled_suffixes
source_words in
let rules'' = { rules' with enabled_suffixes } in
([],None,env,rules'')
| [ word ] when is_empty source_str ->
( match is_suffix_comb rules'.enabled_suffixes word
with
| Some(target_suffix, source_suffix) ->
if ty = `DblColon then
failwith "Suffix rule not possible with double-colon";
let r =
{ target_suffix;
source_suffix;
sfx_commands = []
} in
([],Some(Suffix r),env,rules')
| None ->
let r =
{ targets = Str.split
split_ws_re
(expand env word);
sources = [];
commands = []
} in
let rule =
match ty with
| `Colon -> Explicit r
| `DblColon -> DblColon r in
([],Some rule,env,rules')
)
| _ ->
let target_words =
Str.split split_ws_re (expand env target_str) in
let source_words =
Str.split split_ws_re (expand env source_str) in
if ty = `DblColon && List.length target_words > 1 then
failwith "Only one target allowed for double-colon rule";
let r =
{ targets = target_words;
sources = source_words;
commands = []
} in
let rule =
match ty with
| `Colon -> Explicit r
| `DblColon -> DblColon r in
([],Some rule,env,rules')
)
let rec parse_statements ?(exec = fun _ _ _ -> ()) env rules file =
let fh = open_in file in
let last_num = ref 0 in
try
let (preceding,current,env,rules) =
fold_lines
fh
(fun number line (preceding,current,env,rules) ->
last_num := number;
let lline = String.length line in
if preceding = [] && (is_empty line || line.[0] = '#') then
(preceding,current,env,rules)
else
if line <> "" && line.[lline - 1] = '\\' then
let data = String.sub line 0 (lline-1) in
(data::preceding,current,env,rules)
else
let multiline =
String.concat "" (List.rev (line :: preceding)) in
if multiline.[0] = '\t' then
match current with
| None ->
failwith "TAB found outside a rule definition"
| Some rule ->
let current' =
Some (append_to_rule rule multiline) in
([],current',env,rules)
else
let rules' =
enter_rule current env rules in
if Str.string_match set_var_re multiline 0 then
let name = Str.matched_group 1 multiline in
let op = Str.matched_group 2 multiline in
let value = Str.matched_group 3 multiline in
let env' = update_env name op value env in
([],None,env',rules')
else
match match_rule multiline with
| Some(ty, target_str, source_str) ->
process_rule env rules' ty target_str source_str
| None ->
if Str.string_match include_re multiline 0 then (
let target = Str.matched_group 1 multiline in
exec env rules target;
let (env',rules'') =
parse_statements ~exec env rules' target in
([],None,env',rules'')
)
else
failwith "Cannot parse line"
)
1
([],None,env,rules) in
if preceding <> [] then
failwith "Last line ends with backslash";
let rules =
enter_rule current env rules in
(env, rules)
with
| Failure msg ->
close_in fh;
failwith ("File " ^ file ^ ", line " ^ string_of_int !last_num ^ ": " ^
msg)
| error ->
close_in fh;
raise error
let strip_spaces_re = Str.regexp "^[ \t]*\\(.*\\)$"
let run_command1 cmd =
if is_empty cmd then
()
else
(* CHECK order: @- or -@ *)
let no_echo, cmd1 =
if cmd <> "" && cmd.[0] = '@' then
true, String.sub cmd 1 (String.length cmd - 1)
else
false, cmd in
let no_errcheck, cmd2 =
if cmd1 <> "" && cmd1.[0] = '-' then
true, String.sub cmd1 1 (String.length cmd1 - 1)
else
false, cmd1 in
if not no_echo then
print_endline cmd2;
let code = Sys.command (expand_command cmd2) in
if not no_errcheck && code <> 0 then
failwith ("Command failed: " ^ cmd2)
let run_command s =
if Str.string_match strip_spaces_re s 0 then
let cmd = Str.matched_group 1 s in
run_command1 cmd
else
run_command1 s
let exec made_targets env rules target =
let rec make ancestors target =
debug ("Make: " ^ target);
if not (StrSet.mem target !made_targets) then (
match search_rule ancestors target with
| Some list ->
List.iter
(fun (r,local_env) ->
let env' =
List.fold_left
(fun acc (n,v) -> StrMap.add n v acc)
env
local_env in
let ancestors' =
StrSet.add target ancestors in
List.iter (make ancestors') r.sources;
let cmds1 = List.rev r.commands in
let cmds2 = List.map (expand env') cmds1 in
List.iter run_command cmds2;
List.iter
(fun tgt ->
made_targets := StrSet.add tgt !made_targets
)
r.targets
)
list
| None ->
if StrSet.mem target rules.phonies then
failwith("No way to execute phony target: " ^ target);
if not(Sys.file_exists target) then
failwith("No way to make target: " ^ target)
);
debug ("Made: " ^ target);
and search_rule ancestors target =
if StrSet.mem target ancestors then
None
else
try
let r = StrMap.find target rules.exp_rules in
if r.commands = [] then raise Not_found;
let localenv =
[ "@", (Expanded (String.concat " " r.targets));
"<", (Expanded (String.concat " " r.sources));
] in
debug (" target: " ^ target ^ " = direct");
Some [r, localenv]
with
| Not_found ->
try
(* Double-colon rules are always executed if r.sources=[].
Well, we always execute anyway, so this does not make a
difference.
*)
let rlist = StrMap.find target rules.dblcolon_rules in
debug (" target: " ^ target ^ " = double-colon");
Some
(List.map
(fun r ->
let localenv =
[ "@", (Expanded (String.concat " " r.targets));
"<", (Expanded (String.concat " " r.sources));
] in
(r,localenv)
)
rlist
)
with
| Not_found ->
search_implicit_rule ancestors target
and search_implicit_rule ancestors target =
debug (" target: " ^ target ^ " = search");
let r_opt =
StrSet.fold
(fun target_suffix rule_opt ->
match rule_opt with
| Some r -> Some r
| None ->
if Filename.check_suffix target target_suffix then (
debug(" target_suffix: " ^ target_suffix);
let irules =
List.filter
(fun suffr ->
suffr.target_suffix = target_suffix
)
rules.suffix_rules in
if irules = [] then
None
else (
let target_base =
Filename.chop_suffix target target_suffix in
try
let ancestors' =
StrSet.add target ancestors in
let irule =
List.find
(fun suffr ->
debug(" source_suffix: " ^ suffr.source_suffix);
let source =
target_base ^ suffr.source_suffix in
search_rule ancestors' source <> None
|| Sys.file_exists source
)
irules in
let source =
target_base ^ irule.source_suffix in
let deps =
try
let r = StrMap.find target rules.exp_rules in
r.sources
with
| Not_found -> [] in
Some
[ { targets = [target];
sources = source :: deps;
commands = irule.sfx_commands
},
[ "*", (Expanded target_base);
"@", (Expanded target);
"<", (Expanded source);
]
]
with Not_found ->
None
)
)
else
None
)
rules.enabled_suffixes
None in
r_opt in
try
make StrSet.empty target
with
| Failure msg ->
let d = Sys.getcwd() in
failwith ("*** Error in directory " ^ d ^ ": " ^ msg)
let set_re = Str.regexp "^\\([^=]+\\)=\\(.*\\)$"
let main() =
let self = Sys.argv.(0) in
let self =
if Filename.is_relative self then
Filename.concat (Sys.getcwd()) self
else
self in
let env = ref StrMap.empty in
let targets = ref [] in
let setvar name value =
env := StrMap.add name (Expanded value) !env in
Arg.parse
[ "-C", Arg.String (fun s -> Sys.chdir s),
"<dir> Change to this directory";
"-debug", Arg.Set debug_enabled,
" Enable debug logging";
]
(fun s ->
if Str.string_match set_re s 0 then
let name = Str.matched_group 1 s in
let value = Str.matched_group 2 s in
setvar name value
else
targets := !targets @ [s]
)
"ocaml make.ml [options] (var=value | target) ...";
setvar
"MAKE"
(sprintf "ocaml %s %s"
self
(if !debug_enabled then "-debug" else "")
);
let made_targets = ref StrSet.empty in
let (env,rules) =
parse_statements ~exec:(exec made_targets) !env empty_rules "Makefile" in
debug("Suffixes: " ^
String.concat "," (StrSet.elements rules.enabled_suffixes));
if !targets = [] then
targets := rules.default;
List.iter
(exec made_targets env rules)
!targets
let () =
try main()
with
| Failure msg
| Arg.Bad msg
| Sys_error msg ->
flush stdout;
prerr_endline msg;
flush stderr;
exit 1
