1 graydon 1.2 (* back-end for a simplified make(1) language
 2                copyright (C) 2002 Graydon Hoare <graydon@pobox.com>
 3                GPL 2.x+ no warranty provided or implied *)

 4 graydon 1.1 
 5             open List
 6             open Mk
 7             open Printf
 8             
 9             let __x = ref 0
10             let tmpnum _ = incr __x; !__x
11             
12             let __funcs = ref []
13             let fnames = Hashtbl.create 10
14             let add_func filename funcname func =
15               if not (Hashtbl.mem fnames filename)
16               then 
17                 begin
18                   __funcs := func :: (!__funcs);
19                   Hashtbl.add fnames filename funcname
20                 end
21             
22             let trans_action act = 
23               let pretty = act ^ "\n" in
24                 <:cstmt< printf ($str:pretty$); system ($str:act$); >>
25 graydon 1.1 ;;
26             
27             let rec trans_node (Node (file, rules, actions)) =  
28               if Hashtbl.mem fnames file
29               then Hashtbl.find fnames file
30               else
31                 let fname = sprintf "node_%d" (tmpnum ()) in
32                 let acts = (map trans_action actions) @ [<:cstmt< return 1; >>] in
33                 let satisfy =
34                   fold_right
35             	(fun x r -> <:cstmt< doit = ($ident:x$(mtime) || doit); $stmt:r$  >>) 
36             	(map trans_node rules)
37             	<:cstmt< if ( doit ) { $stmts:acts$ } >>
38                 in
39                 let decls = 
40                   [(<:cdecl< struct stat target;>>);
41                    (<:cdecl< time_t mtime = 0; >>);
42                    (<:cdecl< int doit = 0; >>)]
43                 in
44                 let fstmt = 
45                   (<:cstmt< 
46 graydon 1.1       if (stat ($str:file$, &target) == -1) {
47             	doit = 1; 
48             	mtime = target.st_mtime;
49                   }
50                   doit = (mtime > base) || doit;
51                   $stmt:satisfy$
52                   return doit; >>)
53                 in
54                 let fbody =  (decls, fstmt) in
55                 let func = <:cfunc< int $ident:fname$ (time_t base) {$body:fbody$} >> 
56                 in
57                   add_func file fname func;
58                   fname
59             
60             		 
61             let trans node = 
62               let translated_node = trans_node node in
63               let translated = 
64                 <:cfunc< int main (int argc, char **argv) { $ident:translated_node$(0); } >>
65               in
66                 List.iter (fun x -> Printf.printf "#include <%s>\n" x)
67 graydon 1.1       ["sys/types.h"; "sys/stat.h"; "unistd.h"];
68                 Cprint.print stdout (rev (!__funcs) @ [translated])
69             
70