Return to be.ml CVS log

Up to [venge] / src / mkc

too tired to compose useful message

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

open List
open Mk
open Printf

let __x = ref 0
let tmpnum _ = incr __x; !__x

let __funcs = ref []
let fnames = Hashtbl.create 10
let add_func filename funcname func =
  if not (Hashtbl.mem fnames filename)
  then 
    begin
      __funcs := func :: (!__funcs);
      Hashtbl.add fnames filename funcname
    end

let trans_action act = 
  let pretty = act ^ "\n" in
  let errstr = "*** Make error: system(\"" ^ act ^ "\") failed\n" in
  let plen = String.length pretty in
  let elen = String.length errstr in
    <:cstmt< 
    write (1, $str:pretty$, $int:plen$); 
    rv = (system($str:act$)); 
    if (rv != 0)
      {
	write (2, $str:errstr$, $int:elen$);
	exit (1);
      }	 
    >>
;;

let rec trans_node (Rule (file, rules, actions)) =  
  if Hashtbl.mem fnames file
  then Hashtbl.find fnames file
  else
    let fname = sprintf "node_%d" (tmpnum ()) in
    let acts = 
      if length actions > 0
      then (map trans_action actions) @ [<:cstmt< return 1; >>] 
      else 
	let errstr = "*** Make error: no rule to make " ^ file ^ "\n" in
	let elen = String.length errstr in 
	  [<:cstmt< write (2, $str:errstr$, $int:elen$); exit(1); >>]
    in
    let satisfy =
      fold_right
	(fun x r -> <:cstmt< rebuild = ($ident:x$(mtime) || rebuild); $stmt:r$  >>) 
	(map trans_node rules)
	<:cstmt< if ( rebuild ) { $stmts:acts$ } else { return (mtime > base); }>>
    in
    let decls = 
      [(<:cdecl< struct stat target;>>);
       (<:cdecl< time_t mtime = 0; >>);
       (<:cdecl< int rebuild = 0; >>);
       (<:cdecl< int rv = 0; >>)]
    in
    let fstmt = 
      (<:cstmt< 
       if (stat ($str:file$, &target) == -1) {
	 rebuild = 1; 
       } else {
	 mtime = target.st_mtime;
       }
       $stmt:satisfy$
       >>)
    in
    let fbody =  (decls, fstmt) in
    let func = <:cfunc< int $ident:fname$ (time_t base) {$body:fbody$} >> 
    in
      add_func file fname func;
      fname
		 
let trans node = 
  let translated_node = trans_node node in
  let translated = 
    <:cfunc< int main (int argc, char **argv) { $ident:translated_node$(0); } >>
  in
    List.iter (fun x -> printf "#include <%s>\n" x)
      ["sys/types.h"; "sys/stat.h"; "unistd.h"; "stdio.h"; "stdlib.h"];
    Cprint.print stdout (rev (!__funcs) @ [translated])