1structure ReadHMF :> ReadHMF = 2struct 3 4open Holmake_types 5 6datatype cond_position = GrabbingText | NoTrueCondYet | SkippingElses 7val empty_condstate = [] : cond_position list 8 9infix |> 10fun x |> f = f x 11 12fun readline lnum strm = let 13 fun recurse (lnum, acc) latest = 14 case latest of 15 NONE => if null acc then NONE 16 else SOME (lnum + 1, String.concat (List.rev acc)) 17 | SOME "\n" => SOME (lnum + 1, String.concat (List.rev acc)) 18 | SOME s => let 19 val s0 = if String.sub(s, size s - 2) = #"\r" then 20 String.extract(s, 0, SOME (size s - 2)) 21 else String.extract(s, 0, SOME (size s - 1)) 22 in 23 if String.sub(s0, size s0 - 1) = #"\\" then 24 recurse (lnum + 1, 25 " " :: String.extract(s0, 0, SOME (size s0 - 1)) :: acc) 26 (TextIO.inputLine strm) 27 else 28 SOME (lnum + 1, String.concat (List.rev (s0 :: acc))) 29 end 30in 31 recurse (lnum, []) (TextIO.inputLine strm) 32end 33 34datatype buf = B of { lnum : int, 35 strm : TextIO.instream, 36 name : string, 37 curr : (int * string) option } 38 39fun init_buf fname = let 40 val istrm = TextIO.openIn fname 41in 42 B { lnum = 1, strm = istrm, curr = readline 1 istrm, name = fname } 43end 44 45fun close_buf (B r) = TextIO.closeIn (#strm r) 46 47fun currentline (B r) = Option.map #2 (#curr r) 48 49fun advance (b as B r) = 50 case #curr r of 51 NONE => b 52 | SOME (n,s) => B { lnum = n, strm = #strm r, name = #name r, 53 curr = readline n (#strm r) } 54 55fun error (B r) s = 56 raise Fail (#name r ^":"^Int.toString (#lnum r)^": "^s) 57 58fun strip_leading_wspace s = let 59 open Substring 60 val ss = full s 61in 62 string (dropl (fn c => c = #" " orelse c = #"\r") ss) 63end 64 65fun drop_twspace s = let 66 open Substring 67 val ss = full s 68in 69 string (dropr Char.isSpace ss) 70end 71 72 73fun first_special s = let 74 fun recurse i = if i = size s then NONE 75 else if String.sub(s,i) = #"=" then SOME #"=" 76 else if String.sub(s,i) = #":" then SOME #":" 77 else recurse (i + 1) 78in 79 recurse 0 80end 81 82fun strip_trailing_comment s = let 83 fun recurse i = 84 if i >= size s then s 85 else if String.sub(s,i) = #"\\" then recurse (i + 2) 86 else if String.sub(s,i) = #"#" then String.substring(s,0,i) 87 else recurse (i + 1) 88in 89 recurse 0 90end 91 92val ss = Substring.full 93 94fun read_delimited_string b dchar s = let 95 (* assume s begins with dchar *) 96 val s' = String.extract(s,1,NONE) 97 open Substring 98 val (result, rest) = position (str dchar) (ss s') 99 val _ = size rest <> 0 orelse error b ("No matching "^str dchar) 100in 101 (string result, string rest 102 |> (fn s => String.extract(s, 1, NONE)) 103 |> strip_leading_wspace) 104end 105 106fun read_quoted_string b s = let 107 val c = String.sub(s, 0) 108in 109 case c of 110 #"'" => read_delimited_string b c s 111 | #"\"" => read_delimited_string b c s 112 | _ => error b ("Bad argument delimiter: "^str c) 113end 114 115fun split_at_rightmost_rparen ss = let 116 open Substring 117 fun recurse i = 118 if i < 0 then (ss, full "") 119 else if sub(ss,i) = #")" then (slice(ss,0,SOME i), slice(ss,i,NONE)) 120 else recurse (i - 1) 121in 122 recurse (size ss - 1) 123end 124 125fun evaluate_cond b env s = 126 if String.isPrefix "ifdef" s orelse String.isPrefix "ifndef" s then let 127 val (sense, sz, nm) = 128 if String.sub(s,2) = #"n" then (false, 6, "ifndef") 129 else (true, 5, "ifdef") 130 val s' = strip_leading_wspace (String.extract(s, sz, NONE)) 131 val q = extract_normal_quotation (Substring.full s') 132 val s2 = perform_substitution env q 133 in 134 case String.tokens Char.isSpace s2 of 135 [s] => (case lookup env s of 136 [LIT ""] => SOME (not sense) 137 | [] => SOME (not sense) 138 | _ => SOME sense) 139 | _ => error b ("ReadHMF: "^nm^" not followed by a variable name.") 140 end 141 else if String.isPrefix "ifeq" s orelse String.isPrefix "ifneq" s then let 142 val (sense, sz, nm) = 143 if String.sub(s,2) = #"n" then (false, 5, "ifneq") 144 else (true, 4, "ifeq") 145 val s = String.extract(s,sz,NONE) |> strip_leading_wspace |> drop_twspace 146 val (arg1, arg2) = 147 case String.sub(s,0) of 148 #"(" => let 149 open Substring 150 val (arg1s, blob2s) = position "," (full (String.extract(s,1,NONE))) 151 val _ = size blob2s <> 0 orelse 152 error b (nm ^ " with parens requires args separated by \ 153 \commas") 154 val (arg2s, parenblob) = 155 split_at_rightmost_rparen (slice(blob2s,1,NONE)) 156 val _ = size parenblob <> 0 orelse 157 error b ("No right-paren in "^nm^" line") 158 in 159 (arg1s |> string |> drop_twspace |> strip_leading_wspace, 160 arg2s |> string |> drop_twspace |> strip_leading_wspace) 161 end 162 | _ => let 163 val (arg1, s) = read_quoted_string b s 164 val (arg2, s) = read_quoted_string b s 165 val _ = size (drop_twspace s) = 0 orelse 166 error b ("Extraneous junk after complete "^nm^" directive") 167 in 168 (arg1, arg2) 169 end 170 val (q1, q2) = (extract_normal_quotation (ss arg1), 171 extract_normal_quotation (ss arg2)) 172 val (s1, s2) = (perform_substitution env q1, perform_substitution env q2) 173 in 174 SOME ((s1 = s2) = sense) 175 end 176 else NONE 177 178fun getline env (condstate, b) = 179 case (currentline b, condstate) of 180 (NONE, []) => (b, NONE, condstate) 181 | (NONE, _ :: _) => error b "ReadHMF: unterminated conditional" 182 | (SOME s, SkippingElses :: rest) => let 183 val s = strip_leading_wspace s 184 in 185 if String.isPrefix "endif" s then getline env (rest, advance b) 186 else if String.isPrefix "ifdef" s orelse String.isPrefix "ifndef" s orelse 187 String.isPrefix "ifeq" s orelse String.isPrefix "ifneq" s 188 then 189 getline env (SkippingElses::condstate, advance b) 190 else 191 getline env (condstate, advance b) 192 end 193 | (SOME s, NoTrueCondYet::rest) => let 194 val s = strip_leading_wspace s 195 in 196 if String.isPrefix "endif" s then getline env (rest, advance b) 197 else if String.isPrefix "if" s then 198 getline env (SkippingElses :: condstate, advance b) 199 else if String.isPrefix "else" s then let 200 val s = strip_leading_wspace (String.extract(s, 4, NONE)) 201 in 202 if String.isPrefix "if" s then 203 case evaluate_cond b env s of 204 NONE => error b "ReadHMF: bogus string following else" 205 | SOME false => getline env (condstate, advance b) 206 | SOME true => getline env (GrabbingText::rest, advance b) 207 else if s = "" then getline env (GrabbingText::rest, advance b) 208 else error b "ReadHMF: bogus string following else" 209 end 210 else getline env (condstate, advance b) 211 end 212 | (SOME s0, _) => let 213 val s = strip_leading_wspace s0 214 in 215 if String.isPrefix "endif" s then 216 if null condstate then error b "ReadHMF: unpaired endif" 217 else getline env (tl condstate, advance b) 218 else if String.isPrefix "else" s then 219 if null condstate then error b "ReadHMF: unpaired else" 220 else getline env (SkippingElses::tl condstate, advance b) 221 else if String.isPrefix "if" s then 222 case evaluate_cond b env s of 223 NONE => (b, SOME s0, condstate) 224 | SOME false => getline env (NoTrueCondYet::condstate, advance b) 225 | SOME true => getline env (GrabbingText::condstate, advance b) 226 else (b, SOME s0, condstate) 227 end 228 229fun read_commands env (cs,b) head = 230 case getline env (cs, b) of 231 (b, NONE, cs) => ((cs, b), RULE head) 232 | (b, SOME s, cs) => let 233 val s' = strip_leading_wspace s 234 in 235 if s' = "" orelse String.sub(s',0) = #"#" then 236 read_commands env (cs, advance b) head 237 else 238 case String.sub(s',0) of 239 #"\t" => read_commands env (cs, advance b) (head ^ s' ^ "\n") 240 | c => ((cs, b), RULE head) 241 end 242 243 244fun process_line env (condstate, b) = let 245 val (b, line_opt, condstate) = getline env (condstate, b) 246in 247 case line_opt of 248 NONE => ((condstate, b), EOF) 249 | SOME s => let 250 val s' = strip_leading_wspace s 251 in 252 if s' = "" orelse String.sub(s',0) = #"#" then 253 process_line env (condstate, advance b) 254 else let 255 val c1 = String.sub(s',0) 256 in 257 if c1 = #"\t" then error b "TAB starts an unattached command" 258 else 259 case first_special s' of 260 NONE => error b ("Unrecognised character: \""^ 261 String.toString (str c1) ^ "\"") 262 | SOME #"=" => ((condstate, advance b), DEFN (strip_trailing_comment s)) 263 | SOME #":" => read_commands 264 env 265 (condstate, advance b) 266 (strip_trailing_comment s' ^ "\n") 267 | SOME _ => error b "ReadHMF: can't happen" 268 end 269 end 270end 271 272fun readall (acc as (tgt1,env,ruledb,depdb)) csb = 273 case process_line env csb of 274 (csb as (cs, b), EOF) => let 275 val _ = close_buf b 276 fun foldthis (tgt,deps,acc) = 277 case Binarymap.peek(acc,tgt) of 278 NONE => Binarymap.insert(acc,tgt, 279 {dependencies = deps, commands = []}) 280 | SOME {dependencies, commands} => 281 Binarymap.insert(acc,tgt, {dependencies = dependencies @ deps, 282 commands = commands}) 283 in 284 (env,Binarymap.foldl foldthis ruledb depdb,tgt1) 285 end 286 | (csb, x) => let 287 fun warn s = TextIO.output(TextIO.stdErr, s ^ "\n") 288 in 289 case to_token x of 290 HM_defn def => readall (tgt1,env_extend def env, ruledb, depdb) csb 291 | HM_rule rinfo => let 292 val (rdb',depdb',tgts) = extend_ruledb warn env rinfo (ruledb,depdb) 293 val tgt1' = 294 case tgt1 of 295 NONE => List.find (fn s => s <> ".PHONY") tgts 296 | _ => tgt1 297 in 298 readall (tgt1',env,rdb',depdb') csb 299 end 300 end 301 302fun read fname env = 303 readall (NONE, env, empty_ruledb, 304 Binarymap.mkDict String.compare) 305 (empty_condstate, init_buf fname) 306 307fun readlist e vref = 308 map dequote (tokenize (perform_substitution e [VREF vref])) 309 310fun find_includes dirname = 311 let 312 val hm_fname = OS.Path.concat(dirname, "Holmakefile") 313 in 314 if OS.FileSys.access(hm_fname, [OS.FileSys.A_READ]) then 315 let 316 val (e, _, _) = read hm_fname (base_environment()) 317 val raw_incs = readlist e "INCLUDES" @ readlist e "PRE_INCLUDES" 318 in 319 map (fn p => OS.Path.mkAbsolute {path = p, relativeTo = dirname}) 320 raw_incs 321 end 322 else [] 323 end 324 325fun extend {quietp,lpref} envlist s f = let 326 open Holmake_types 327in 328 case envlist s of 329 [] => () 330 | v => (if not quietp then 331 print ("[extending loadPath with Holmakefile "^s^" variable]\n") 332 else (); 333 lpref := f (!lpref, v)) 334end 335 336fun extend_path_with_includes cfg = 337 if OS.FileSys.access ("Holmakefile", [OS.FileSys.A_READ]) then 338 let 339 open Holmake_types 340 val (env, _, _) = read "Holmakefile" (base_environment()) 341 fun envlist id = 342 map dequote (tokenize (perform_substitution env [VREF id])) 343 in 344 extend cfg envlist "INCLUDES" (op@); 345 extend cfg envlist "PRE_INCLUDES" (fn (lp, mfv) => mfv @ lp) 346 end handle e => (if not (#quietp cfg) then 347 (TextIO.output(TextIO.stdErr, 348 "[bogus Holmakefile in current directory \ 349 \- ignoring it]\n"); 350 TextIO.flushOut TextIO.stdErr) 351 else ()) 352 else (); 353 354end (* struct *) 355