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