(* Sukyoung Ryu, Oukseh Lee, Youil Kim Copyright(c) 2000-2004 KAIST/SNU Research On Program Analysis System (National Creative Research Initiative Center 1998-2003) http://ropas.snu.ac.kr/n All rights reserved. This file is distributed under the terms of an Open Source License. *) structure NMakeGen = struct open Set structure SS = Make(struct type t = string val compare = Pervasives.compare end) open Format open Location open String_ast.Ast open Unix open Filename structure L = List exception Assert_failure of (string * int * int) val print = print_string (* Collect free module identifiers in the ast *) val free_names = ref SS.empty (* Collect bound module identifiers in the ast *) val bound_names = ref SS.empty (* (filename, free_names, bound_names) list *) val infos = ref ([]: (string * SS.t * string list) list) (* 2002-04-27, bluewiz *) val unix_lib_used = ref false (* addmodule: SS.t -> Longid.t -> unit *) fun addmodule bv lid = if lid="Unix" then unix_lib_used := true; if not (SS.mem lid bv) then free_names := SS.add lid !free_names (* add_bound: Longid.t -> unit *) fun add_bound lid = bound_names := SS.add lid !bound_names (* add_ty: SS.t -> ty -> unit *) fun add_ty bv ty = case ty of VarTy _ => () | ConstTy (tys, (strids, _, _), _) => (L.iter (fn (lid,_) => addmodule bv lid) strids; L.iter (add_ty bv) tys) | RecordTy (labtys, _) => L.iter (fn (_, ty', _) => add_ty bv ty') labtys | TupleTy (tys, _) => L.iter (add_ty bv) tys | FunTy (ty1, ty2, _) => (add_ty bv ty1; add_ty bv ty2) (* add_opt: (SS.t -> 'a -> unit) -> SS.t -> 'a option *) (* -> unit *) fun add_opt add_fn bv opt = case opt of None => () | Some x => add_fn bv x (* add_pat: SS.t -> pat -> unit *) fun add_pat bv pat = case pat of ConPat ((strids, _, _), _) => L.iter (fn (lid,_) => addmodule bv lid) strids | AppPat ((strids, _, _), pat', _) => (L.iter (fn (lid,_) => addmodule bv lid) strids; add_pat bv pat') | RecordPat (labpats, _) => L.iter (fn (_, pat', _) => add_pat bv pat') labpats | SubRecordPat (labpats, _) => L.iter (fn (_, pat', _) => add_pat bv pat') labpats | RefPat (pat', _) => add_pat bv pat' | ConstraintPat (pat', ty, _) => (add_pat bv pat'; add_ty bv ty) | AsPat (_, ty_opt, pat', _) => (add_opt add_ty bv ty_opt; add_pat bv pat') | TuplePat (pats, _) => L.iter (add_pat bv) pats | ListPat (pats, _) => L.iter (add_pat bv) pats | ArrayPat (pats, _) => L.iter (add_pat bv) pats | OrPat (pats, _) => L.iter (add_pat bv) pats | _ => () (* add_exp: SS.t -> exp -> unit *) fun add_exp bv exp = case exp of VarExp ((strids, _, _), _) => L.iter (fn (lid,_) => addmodule bv lid) strids | ConExp ((strids, _, _), _) => L.iter (fn (lid,_) => addmodule bv lid) strids | AppExp (exp1, exp2, _) => (add_exp bv exp1; List.iter (add_exp bv) exp2) | RecordExp (labexps, _) => L.iter (fn (_, exp', _) => add_exp bv exp') labexps | RecordFieldExp (exp', _, _) => add_exp bv exp' | ArrayFieldExp (exp1, exp2, _) => (add_exp bv exp1; add_exp bv exp2) | UpdateArrayExp (exp1, exp2, exp3, _) => (add_exp bv exp1; add_exp bv exp2; add_exp bv exp3) | SubstRecordExp (exp1, _, exp2, _) => (add_exp bv exp1; add_exp bv exp2) | TupleExp (exps, _) => L.iter (add_exp bv) exps | ListExp (exps, _) => L.iter (add_exp bv) exps | ArrayExp (exps, _) => L.iter (add_exp bv) exps | LetExp (dec, exp', _) => (add_dec bv dec; add_exp bv exp') | HandleExp (exp', rules, _) => (add_exp bv exp'; add_rules bv rules) | RaiseExp (exp', _) => add_exp bv exp' | FnExp (fnrules, _) => add_fnrules bv fnrules | AssignExp (exp1, exp2, _) => (add_exp bv exp1; add_exp bv exp2) | RefExp (exp', _) => add_exp bv exp' | DeRefExp (exp', _) => add_exp bv exp' | SeqExp (exps, _) => L.iter (add_exp bv) exps | CaseExp (exp', rules, _) => (add_exp bv exp'; add_rules bv rules) | IfExp (exp1, exp2, exp3, _) => (add_exp bv exp1; add_exp bv exp2; add_exp bv exp3) | WhileExp (exp1, exp2, _) => (add_exp bv exp1; add_exp bv exp2) | ForExp (_, exp1, exp2, exp3, exp4, _) => (add_exp bv exp1; add_exp bv exp2; add_exp bv exp3; add_exp bv exp4) | ConstraintExp (exp', ty, _) => (add_exp bv exp'; add_ty bv ty) | _ => () (* add_rules: SS.t -> rule list -> unit *) and add_rules bv rules = L.iter (fn (p,e,_) => (add_pat bv p; add_exp bv e)) rules (* add_fnrules: SS.t -> fnrule list -> unit *) and add_fnrules bv fnrules = L.iter (fn (ps,e,_) => (L.iter (add_pat bv) ps; add_exp bv e)) fnrules (* add_dec: SS.t -> dec -> unit *) and add_dec bv dec = case dec of ValDec (_, vbs, _) => L.iter (fn (_,pat,exp,_) => (add_pat bv pat; add_exp bv exp)) vbs | FunDec (_, fbs, _) => L.iter (fn (bodies, _) => L.iter (fn (_, pats, exp, _) => (L.iter (add_pat bv) pats; add_exp bv exp)) bodies) fbs | TypeDec (tbs, _) => L.iter (add_tb bv) tbs | ExceptionDec (ebs, _) => L.iter (fn con => add_con bv con) ebs | LocalDec (dec1, dec2, _) => (add_dec bv dec1; add_dec bv dec2) | OpenDec (strlids, _) => L.iter (fn (strids, (strid, _), _) => (L.iter (fn (lid,_) => addmodule bv lid) strids; addmodule bv strid)) strlids | SeqDec (decs, _) => L.iter (add_dec bv) decs (* add_tb: SS.t -> typebind -> unit *) and add_tb bv tb = case tb of TypeBind (_,_,ty,_) => add_ty bv ty | DataBind (_,_,cons,_) => L.iter (add_con bv) cons (* add_con: SS.t -> con -> unit *) and add_con bv (_, ty_opt, _) = add_opt add_ty bv ty_opt (* add_spec: SS.t -> spec -> unit *) and add_spec bv spec = case spec of ValSpec (valdescs, _) => L.iter (fn (_,ty,_) => add_ty bv ty) valdescs | TypeSpec (typedescs, _) => L.iter (add_typedesc bv) typedescs | ExnSpec (exndescs, _) => L.iter (fn con => add_con bv con) exndescs | IncludeSpec (sigexp, _) => add_sigexp bv sigexp | StrSpec (strdescs, _) => L.iter (fn ((strid,_),sigexp,_) => (addmodule bv strid; add_sigexp bv sigexp)) strdescs | SeqSpec (specs, _) => L.iter (add_spec bv) specs (* add_typedesc: SS.t -> typedesc -> unit *) and add_typedesc bv typedesc = case typedesc of TypeDesc _ => () | TypeBindDesc (_,_,ty,_) => add_ty bv ty | DataDesc (_,_,cons,_) => L.iter (add_con bv) cons (* add_sigexp: SS.t -> sigexp -> unit *) and add_sigexp bv sigexp = case sigexp of VarSig ((sigid, _), _) => addmodule bv sigid | SigSig (spec, _) => add_spec bv spec | ConstraintSig (sigexp', (longtbs, _), _) => (add_sigexp bv sigexp'; L.iter (fn (_,(strids,_,_),ty,_) => (L.iter (fn (lid,_) => addmodule bv lid) strids; add_ty bv ty)) longtbs) (* add_sigbd: SS.t -> sigbind -> SS.t *) and add_sigbd bv ((sigid,_), sigexp, _) = (add_bound sigid; add_sigexp bv sigexp; SS.add sigid bv) (* add_sigdec: SS.t -> sigdec -> SS.t *) and add_sigdec bv (sigbds,_) = L.fold_left add_sigbd bv sigbds (* add_strexp: SS.t -> strexp -> unit *) and add_strexp bv strexp = case strexp of VarStr ((strids, (strid, _), _), _) => (L.iter (fn (lid,_) => addmodule bv lid) strids; addmodule bv strid) | StrStr (strdec, _) => (add_strdec' bv strdec; ()) | SigStr (strexp', sigexp, _) => (add_strexp bv strexp'; add_sigexp bv sigexp) | FctAppStr ((fctid,_), strexps, _) => (addmodule bv fctid; L.iter (add_strexp bv) strexps) (* add_fctdec: SS.t -> fctdec -> SS.t *) and add_fctdec bv ((fctid,_), fctargs, sigexp_opt, strexp, _) = let val bv'' = L.fold_left (fn bv' ((strid,_),sigexp,_) => (add_sigexp bv sigexp; SS.add strid bv')) bv fctargs in (add_bound fctid; add_opt add_sigexp bv sigexp_opt; add_strexp bv'' strexp; SS.add fctid bv) end (* add_strdec': SS.t -> strdec -> SS.t *) and add_strdec' bv strdec = case strdec of SimpleDec (dec, _) => (add_dec bv dec; bv) | StrDec (strbds, _) => L.fold_left (fn bv' ((strid,_),sigexp_opt,strexp,_) => (add_opt add_sigexp bv' sigexp_opt; add_strexp bv' strexp; SS.add strid bv')) bv strbds | SeqStrDec (strdecs, _) => L.fold_left add_strdec' bv strdecs (* add_strdec: SS.t -> strdec -> SS.t *) and add_strdec bv strdec = case strdec of SimpleDec (dec, _) => (add_dec bv dec; bv) | StrDec (strbds, _) => L.fold_left (fn bv' ((strid,_),sigexp_opt,strexp,_) => (add_bound strid; add_opt add_sigexp bv' sigexp_opt; add_strexp bv' strexp; SS.add strid bv')) bv strbds | SeqStrDec (strdecs, _) => L.fold_left add_strdec bv strdecs (* add_topdec: SS.t -> topdec -> SS.t *) and add_topdec bv topdec = case topdec of Sig (sigdec, _) => add_sigdec bv sigdec | Fct (fctdec, _) => add_fctdec bv fctdec | Str (strdec, _) => add_strdec bv strdec | SeqTopDec (topdecs, _) => L.fold_left add_topdec bv topdecs (********************** Analyze This **********************) val paths = ref ["."] val recur = ref ([]: string list) (* 2002-04-19, bluewiz *) (* signature EnvSig = sig val clear: unit -> unit val put: string -> string -> unit val get: string -> string val update: string -> string -> unit val iter: (string -> string -> unit) -> unit end *) structure Env = struct val env = ref Map.empty fun clear () = env := Map.empty fun put var value = env := Map.add var value !env fun get var = Map.find var !env fun exists var = (ignore (get var); true) handle Not_found => false fun update var value = env := Map.add var value (Map.remove var !env) fun iter f = Map.iter f !env end fun init_env () = Env.clear (); Env.put "NMLC" "nmlc"; Env.put "NMLO" "nmlo"; Env.put "NLEX" "nlex"; Env.put "NYACC" "nyacc"; Env.put "NYACC" "nyacc"; Env.put "OCAMLLEX" "ocamllex"; Env.put "OCAMLYACC" "ocamlyacc"; Env.put "COMPFLAGS" ""; Env.put "DEPFLAGS" ""; Env.put "LINKFLAGS" ""; Env.put "LEXFLAGS" ""; Env.put "YACCFLAGS" ""; Env.put "NMAKEGEN" "" val _ = init_env () val nlex = ref (Env.get "NLEX") val nyacc = ref (Env.get "NYACC") val ocamllex = ref (Env.get "OCAMLLEX") val ocamlyacc = ref (Env.get "OCAMLYACC") val lexflags = ref (Env.get "LEXFLAGS") val yaccflags = ref (Env.get "YACCFLAGS") val nf = ref false val dp = ref false val interactive = ref true val object = ref (if Sys.os_type = "Win32" then "run.exe" else "run") val native = ref (if Sys.os_type = "Win32" then "fly.exe" else "fly") val ocamldep = ref "" val input = ref ([]: string list) val lexs = ref ([]: string list) val yacs = ref ([]: string list) val ocamllexs = ref ([]: string list) val ocamlyacs = ref ([]: string list) open Utils val obj = ref SM.empty val ocamlobj = ref SM.empty (* keep: (string * SS.t * string list) -> unit *) fun keepInfo info = infos := info::(!infos) fun ask s = ( print_string s; print_string " (y/[n])? "; Format.print_flush(); let val x = read_line() in x = "y" || x = "Y" end) fun warning x = ( print_string "Warning: "; print_string x; print_string "\n"; Format.print_flush()) fun fail x = warning ("nmakegen fails to deal with " ^ x) fun stop x = (print_string "Stopped."; print_newline(); exit 0) (* Process one file *) (* file_dependencies: string -> unit *) fun file_dependencies src_file = (Location.input_name := src_file; if Sys.file_exists src_file then if check_suffix src_file ".n" then (let val _ = (free_names := SS.empty;bound_names := SS.empty) val base = chop_suffix src_file ".n" val ic = open_in src_file in let val lb = Lexing.from_channel ic in (ignore(add_topdec SS.empty (Nparse.parse lb)); keepInfo (base,!free_names, SS.elements !bound_names); close_in ic) end handle x => (close_in ic; raise x) end handle x => let fun report_err err = case err of Lexer.Error(err, start, stop) => (fail src_file; fprintf Format.err_formatter "@[%a%a@]@." Location.print {loc_start = start, loc_end = stop, loc_ghost = false} Lexer.report_error err) | Syntaxerr.Error err => (fail src_file; fprintf Format.err_formatter "@[%a@]@." Syntaxerr.report_error err) | Sys_error msg => (fail src_file; fprintf Format.err_formatter "@[I/O error:@ %s@]@." msg) | x => fail src_file in report_err x end) else let val (deps, objs) = Ncamldep.file_dependencies (!ocamlobj) (!paths) src_file in (ocamldep := !ocamldep ^ deps; ocamlobj := objs) end handle x => (print "Warning: ocamldep fails to deal with "; print src_file; print_newline())) fun getFname file = if Sys.file_exists file && !interactive then if ask ("overwrite " ^ file) then file else stop() else file (* Make a .nfiles *) fun quest x = (if Sys.file_exists x then "overwrite " else "generate ")^x fun ask_gen x = if !interactive then ask (quest x) else true fun ask_gen2 x y = if !interactive then ask (quest x ^ " and " ^ quest y) else true fun nfiles pr dir = let val dc = Sys.opendir dir fun full name = dir ^ "/" ^ name in while true do let val file = Sys.readdir dc val is_suffix = check_suffix file val detach = chop_suffix file in if is_suffix ".n" || is_suffix ".ml" || is_suffix ".mli" then pr (full file) else if is_suffix ".nl" then let val name = detach ".nl" val new = full (name^".n") in if ask_gen new then case system ((!nlex)^" "^(!lexflags)^" "^full file) of WEXITED 0 => (lexs := (!lexs) @ [full name]; pr new) | _ => fail (full file) end else if is_suffix ".ny" then let val name = detach ".ny" val new = full (name^".n") in if ask_gen new then case system ((!nyacc)^" "^(!yaccflags)^" "^full file) of WEXITED 0 => (yacs := (!yacs) @ [full name]; pr new) | _ => fail (full file) end else if is_suffix ".mll" then let val name = detach ".mll" val new = full (name ^ ".ml") in if ask_gen new then case system ((!ocamllex)^" "^(!lexflags)^" "^full file) of WEXITED 0 => (ocamllexs := (!ocamllexs) @ [full name]; pr new) | _ => fail (full file) end else if is_suffix ".mly" then let val name = detach ".mly" val new = full (name^".ml") and newi = full (name^".mli") in if ask_gen2 new newi then case system ((!ocamlyacc)^" "^(!yaccflags)^" "^full file) of WEXITED 0 => (ocamlyacs := (!ocamlyacs) @ [full name]; pr new; pr newi) | _ => fail (full file) end end end handle End_of_file => () end fun mkNfiles () = let val oc = open_out (getFname ".nfiles") val dirs = ref (!paths) fun collect path dir = let val dc = Sys.opendir (path^dir) in if not (L.mem dir !dirs) then dirs := (!dirs)@[path^dir]; while true do let val file = Sys.readdir dc in if file <> "." andalso file <> ".." then collect (path^dir^"/") file end end handle End_of_file => Sys.closedir dc end handle Not_found => () in (((L.iter (collect "") (!recur); L.iter (nfiles (fn s => (output_string oc s; output_string oc "\n"))) (!dirs)) handle _ => (close_out oc; stop())); close_out oc) end (* command line arguments *) fun fn_I d = (input := !input@["-I",d]; paths := !paths@[d]) fun fn_r d = (input := !input@["-r",d]; recur := !recur@[d]) fun fn_f _ = (input := !input@["-f"]; interactive := false) fun fn_d _ = (input := !input@["-d"]; dp := true) fun fn_o n = (input := !input@["-o",n]; object := n) fun fn_x n = (input := !input@["-x",n]; native := n) val usage = "Usage: nmakegen [options] [variable=value]*" val doc_I = " Add to the list of include directories" val doc_r = " Add and its subdirectories to the list of\n"^ " include directories except symbolic links" val doc_f = " Do not prompt for confirmation" val doc_d = " till .depend" val doc_o = " Specify the name of the target object" val doc_x = " Specify the name of the target native object" val print_usage_flag = ref false fun print_usage_tail () = let fun f var value = prerr_string (" "^var^"="); prerr_string (if value="" then "(empty)" else value); prerr_newline () in if !print_usage_flag then (prerr_string "\nMakefile variables:\n"; Env.iter f) end val _ = at_exit print_usage_tail val rules = [ ("-I", Arg.String fn_I, doc_I), ("-r", Arg.String fn_r, doc_r), ("-f", Arg.Unit fn_f, doc_f), ("-d", Arg.Unit fn_d, doc_d), ("-o", Arg.String fn_o, doc_o), ("-x", Arg.String fn_x, doc_x) ] exception Invalid_argument exception Unknown_variable (* setenv: string -> unit *) fun setenv s = let val i = String.index s '=' handle Not_found => raise Invalid_argument val l = String.length s val var = String.sub s 0 i val value = String.sub s (i+1) (l-i-1) in if not Env.exists var then warning ("unknown variable "^var); input := !input@[s]; Env.update var value end handle Invalid_argument => warning ("invalid argument "^s) (* doit: unit -> unit *) (* for each n file, collect bound & free signature & structure names *) fun doit () = let val _ = (mkNfiles (); if !nf then exit 0) val ic = open_in ".nfiles" in while true do file_dependencies (input_line ic) end handle End_of_file => (close_in ic) end (* Entry point *) val _ = print_usage_flag := true val _ = Arg.parse rules setenv usage val _ = print_usage_flag := false val _ = ( nlex := Env.get "NLEX"; nyacc := Env.get "NYACC"; ocamllex := Env.get "OCAMLLEX"; ocamlyacc := Env.get "OCAMLYACC"; lexflags := Env.get "LEXFLAGS"; yaccflags := Env.get "YACCFLAGS" ) val _ = doit () val nmlc = Env.get "NMLC" val nmlo = Env.get "NMLO" val compflags = "$(INCLUDES) "^(Env.get "COMPFLAGS") val depflags = "$(INCLUDES) "^(Env.get "DEPFLAGS") val linkflags = Env.get "LINKFLAGS" val nmakegen = Env.get "NMAKEGEN" (* Make a .depend *) val (depends_on, escaped_eol) = case Sys.os_type of "MacOS" => ("\196 ", "\182\n ") | _ => (": ", "\\\n ") (* addL: 'a -> 'a list -> 'a list *) fun addL elmt lst = if L.mem elmt lst then lst else elmt::lst (* delL: 'a -> 'a list -> 'a list *) fun delL elmt lst = L.filter (fn i => i<>elmt) lst (* addObj: string -> string -> unit *) fun addObj less greater = let val l = (chop_extension less)^".cmo" val g = (chop_extension greater)^".cmo" in if l <> g then ((let val nod = SM.find l (!obj) in obj := SM.add l (nod{greater <- addL g nod.greater}) (!obj) end handle Not_found => obj := SM.add l {less=[], greater=[g]} (!obj)); let val nod = SM.find g (!obj) in obj := SM.add g (nod{less <- addL l nod.less}) (!obj) end handle Not_found => obj := SM.add g {less=[l], greater=[]} (!obj)) end (* initObj: string -> unit *) (* 2002-04-22, bluewiz *) fun initObj name = if check_suffix name ".cmo" then (let val _ = SM.find name (!obj) in () end handle Not_found => obj := SM.add name {less=[], greater=[]} (!obj)) (* print_dep: pr -> string -> string list -> unit *) fun print_dep pr target_file [] = initObj target_file | print_dep pr target_file deps = let val _ = (pr target_file; pr depends_on) fun print_items pos [] = pr "\n" | print_items pos (dep::rem) = if pos + String.length dep <= 77 then (pr (dep^" "); addObj dep target_file; print_items (pos + String.length dep + 1) rem) else (pr (escaped_eol^dep^" "); addObj dep target_file; print_items (String.length dep + 5) rem) in print_items (String.length target_file + 2) deps end (* getInfo: string -> string list *) fun getInfo modname = let fun getInfo' nil res = res | getInfo' ((fnm, free, bound)::rest) res = ((case L.find (fn module => module=modname) bound of _ => getInfo' rest (fnm::res)) handle Not_found => getInfo' rest res) in getInfo' (!infos) nil end (* find_dependency: string -> string -> string list -> string list *) fun find_dependency file modname deps = let val name = String.uncapitalize modname in let val filename = Misc.find_in_path !paths (name^".mli") val basename = chop_suffix filename ".mli" in (basename^".cmi")::deps end handle Not_found => let val filename = Misc.find_in_path !paths (name^".ml") val basename = chop_suffix filename ".ml" in (basename^".cmo")::deps end handle Not_found => let val basenames = getInfo modname in if L.exists (fn n => n=file) basenames then deps else (L.map (fn name => name^".cmo") basenames)@deps end handle Not_found => deps end fun find_dependencyx file modname deps = let val name = String.uncapitalize modname in let val filename = Misc.find_in_path !paths (name^".mli") val basename = chop_suffix filename ".mli" in (basename^".cmi")::deps end handle Not_found => let val filename = Misc.find_in_path !paths (name^".ml") val basename = chop_suffix filename ".ml" in (basename^".cmx")::deps end handle Not_found => let val basenames = getInfo modname in if L.exists (fn n => n=file) basenames then deps else (L.map (fn name => name^".cmx") basenames)@deps end handle Not_found => deps end (* remove duplications *) fun rmDup deps itself = let fun rmDup' [] res = res | rmDup' (x::xs) res = if L.mem x res then rmDup' xs res else rmDup' xs (res@[x]) in (L.tl (rmDup' deps itself)) handle _ => nil end val objects = ref ([]: string list) val _ = let val oc = open_out (getFname ".depend") val pr = output_string oc in (pr (!ocamldep); obj := !ocamlobj; L.iter (fn (fnm, free, bound) => let val deps = SS.fold (find_dependency fnm) free [] val depx = SS.fold (find_dependencyx fnm) free [] in print_dep pr (fnm^".cmo") (rmDup deps [fnm^".cmo"]); print_dep pr (fnm^".cmx") (rmDup depx [fnm^".cmx"]) end) (!infos); L.iter (fn x => print_dep pr (x^".cmo") [x^".n"]) (!yacs); L.iter (fn x => print_dep pr (x^".cmx") [x^".n"]) (!yacs); L.iter (fn x => print_dep pr (x^".cmo") [x^".n"]) (!lexs); L.iter (fn x => print_dep pr (x^".cmx") [x^".n"]) (!lexs); L.iter (fn x => print_dep pr (x^".cmi") [x^".mli"]) (!ocamlyacs); L.iter (fn x => print_dep pr (x^".cmo") [x^".ml"]) (!ocamlyacs); L.iter (fn x => print_dep pr (x^".cmx") [x^".ml"]) (!ocamlyacs); L.iter (fn x => print_dep pr (x^".cmo") [x^".ml"]) (!ocamllexs); L.iter (fn x => print_dep pr (x^".cmx") [x^".ml"]) (!ocamllexs); pr "\n"; close_out oc; if !dp then exit 0) end (* Make a Makefile *) fun mkcmd [] = "" | mkcmd [e] = e | mkcmd (h::t) = h^" "^(mkcmd t) fun head pr = (pr ("#\n# Makefile generated\n# by nmakegen "^(mkcmd (!input))^"\n#\n"); (* pr ("\nCAMLC="^(!camlc)^"\nCAMLOPT="^(!camlopt)^"" *) pr ("\nNMLC="^nmlc); pr ("\nNMLO="^nmlo); pr ("\nNLEX="^(!nlex)); pr ("\nNYACC="^(!nyacc)); pr ("\nOCAMLLEX="^(!ocamllex)); pr ("\nOCAMLYACC="^(!ocamlyacc)); pr ("\nCOMPFLAGS="^compflags); pr ("\nDEPFLAGS="^depflags); pr ("\nLINKFLAGS="^linkflags); pr ("\nLEXFLAGS="^(!lexflags)); pr ("\nYACCFLAGS="^(!yaccflags)); pr ("\nNMAKEGEN="^nmakegen); pr ("\nINCLUDES="); L.iter (fn dir => if dir<>"" andalso dir<>"." then pr ("-I "^dir^" ")) (!paths); pr "\n") fun tail pr = (pr ("\nall: $(OBJ)"); pr ("\n\t$(NMLC) $(LINKFLAGS) $(INCLUDES) -o "^(!object)); if !unix_lib_used then pr " unix.cma"; pr " $(OBJ)\n"; pr ("\nopt: $(OBJ:.cmo=.cmx)"); pr ("\n\t$(NMLO) $(LINKFLAGS) $(INCLUDES) -o "^(!native)); if !unix_lib_used then pr " unix.cmxa"; pr " $(OBJ:.cmo=.cmx)\n"; pr "\n.SUFFIXES:\n.SUFFIXES: .ml .mli .n .cmo .cmi .cmx .ny .nl .mly .mll\n"; pr ".n.cmo:\n\t$(NMLC) $(COMPFLAGS) -c $<\n"; pr ".n.cmx:\n\t$(NMLO) $(COMPFLAGS) -c $<\n"; pr ".nl.n:\n\t$(NLEX) $(LEXFLAGS) $<\n"; pr ".ny.n:\n\t$(NYACC) $(YACCFLAGS) $<\n"; pr ".ml.cmo:\n\t$(NMLC) $(COMPFLAGS) -c $<\n"; pr ".mli.cmi:\n\t$(NMLC) $(COMPFLAGS) -c $<\n"; pr ".ml.cmx:\n\t$(NMLO) $(COMPFLAGS) -c $<\n"; pr ".mll.ml:\n\t$(OCAMLLEX) $(LEXFLAGS) $<\n"; pr ".mly.ml:\n\t$(OCAMLYACC) $(YACCFLAGS) $<\n"; pr ".mly.mli:\n\t$(OCAMLYACC) $(YACCFLAGS) $<\n"; pr ("\ndepend:\n\t$(NMAKEGEN) -d"^(if not !interactive then " -f" else "")^ " $(DEPFLAGS) \n"); pr ("\nclean:\n\trm -f *.cm[iox] *.[so] *.obj *.nty "^(!object)^" "^(!native)); pr "\n\trm -f "; L.iter (fn f => pr (f^".n ")) (!lexs); L.iter (fn f => pr (f^".n "^f^".output")) (!yacs); L.iter (fn f => pr (f^".ml ")) (!ocamllexs); L.iter (fn f => pr (f^".ml "^f^".mli "^f^".output ")) (!ocamlyacs); pr "\n\ninclude .depend\n\n") fun pr_obj () = let val todo = ref ([]: (string * string list) list) in (SM.iter (fn nm edg => if edg.less=[] then (objects := (!objects)@[nm]; obj := SM.remove nm (!obj); todo := (nm, edg.greater)::(!todo))) (!obj); L.iter (fn (nm, gs) => L.iter (fn n => let val gedg = SM.find n (!obj) val nedg = gedg{less<-delL nm gedg.less} in obj := SM.add n nedg (!obj) end handle Not_found => ()) gs) (!todo)) end fun middle pr = let fun print_SM sm = SM.iter (fn nm edg => (pr ("\nname="^nm); pr " less="; L.iter (fn s => pr (s^" ")) edg.less; pr " greater="; L.iter (fn s => pr (s^" ")) edg.greater)) sm fun print_items pos [] = pr "\n" | print_items pos (dep::rem) = if pos + String.length dep <= 77 then (pr (dep^" "); print_items (pos + String.length dep + 1) rem) else (pr (escaped_eol^dep^" "); print_items (String.length dep + 5) rem) in (pr "\nOBJ="; SM.iter (fn nm {less,greater} => ignore(L.exists (fn s => if L.mem s greater then raise Failure ("Error: "^nm^" and "^s^ " are mutually recursive.") else false) less)) (!obj); while size_SM (!obj) <> 0 do pr_obj () end; print_items 4 (!objects)) end val _ = let val oc = open_out (getFname "Makefile") val pr = output_string oc in (head pr; middle pr; tail pr; close_out oc) end end (* NMakeGen *)