(******************************************************************* LL(1) parser generator. For CSC 2/454, Spring 2025 (c) Michael L. Scott Builds on code developed starting in 2019 If compiled and run, will execute "main()". Alternatively, can be "#use"-ed (or compiled and then "#load"-ed) into the top-level interpreter. Note: some libraries are pre-loaded by OCaml; some are not. If you are using the ocaml top-level interpreter, you have to say #load "str.cma";; #load "unix.cma";; before you say #use "table_gen.ml";; If you are using utop, you have to say #require "str";; #require "unix";; If you are generating an executable from the shell, you have to include the library name on the command line: ocamlc -o table_gen -I +str -I +unix str.cma unix.cma table_gen.ml (This is for ocaml 5; the "-I +str -I +unix" part can be left out for ocaml 4.) *******************************************************************) open List;; (* The List library includes a large collection of useful functions. Here I've used exists, filter, find, flatten, fold_left, hd, length, map, mem, rev, and sort. *) open Str;; (* for regexp, split, and String.length *) (* The Str library provides a few extra string-processing routines. This library is not automatically available. *) open Unix;; (* for localtime *) open Printf;; (* for formatted output *) let today () : string = let tm = Unix.localtime (Unix.gettimeofday ()) in let months = ["Jan."; "Feb."; "Mar."; "Apr."; "May"; "Jun."; "Jul."; "Aug."; "Sep."; "Oct."; "Nov."; "Dec"] in Printf.sprintf ("%d %s %d") tm.tm_mday (Option.get (nth_opt months tm.tm_mon)) (tm.tm_year + 1900);; (* Surprisingly, compose isn't built in. It's included in various widely used commercial packages, but not in the core libraries. *) let compose f g x = f (g x);; (* Leave only one of any consecutive identical elements in list. *) let rec unique l = match l with | [] -> l | h :: [] -> l | a :: b :: rest -> if a = b (* structural eq *) then unique (b :: rest) else a :: unique (b :: rest);; let unique_sort l = unique (List.sort String.compare l);; type symbol_productions = (string * string list list);; type grammar = symbol_productions list;; (* NB: we assume [or, when creating a grammar, guarantee] that each nonterminal heads ONLY ONE symbol_production in the grammar -- That all the productions with a given LHS are grouped together *) type parse_table = (string * (string list * string list) list) list;; (* nt predict_set rhs *) (* find any duplicate items in l *) let duplicates l = let rec helper suffix dups_so_far = match suffix with | [] -> dups_so_far | h :: [] -> dups_so_far | a :: b :: rest -> if a = b (* structural eq *) then helper rest (a :: dups_so_far) else helper (b :: rest) dups_so_far in unique (helper (List.sort String.compare l) []);; (* list of (lhs, rhs) pairs *) type prod_list = (string * string list) list;; (* Return all individual productions in grammar. *) let productions gram : prod_list = let prods (lhs, rhss) = map (fun rhs -> (lhs, rhs)) rhss in fold_left (@) [] (map prods gram);; (* Return all symbols in grammar. *) let gsymbols gram : string list = unique_sort (fold_left (@) [] (map (compose (fold_left (@) []) snd) gram));; (* Return all elements of l that are not in to_exclude. Assume that both lists are sorted *) let list_minus l to_exclude = let rec helper rest te rtn = match rest with | [] -> rtn | h :: t -> match te with | [] -> (rev rest) @ rtn | h2 :: t2 -> match Stdlib.compare h h2 with | -1 -> helper t te (h :: rtn) | 0 -> helper t t2 rtn | _ -> helper rest t2 rtn in rev (helper l to_exclude []);; (* Return just the nonterminals. Maintains order of LHSs in grammar. *) let nonterminals gram : string list = map fst gram;; (* Return just the terminals, in lexicographic order. *) let terminals gram : string list = list_minus (gsymbols gram) (List.sort String.compare (nonterminals gram));; (* Return the start symbol. Throws exception if grammar is empty. *) let start_symbol gram : string = fst (hd gram);; let is_nonterminal e gram = mem e (nonterminals gram);; let is_terminal e gram = mem e (terminals gram);; let union s1 s2 = unique_sort (s1 @ s2);; (* return suffix of lst that begins with first occurrence of sym (or [] if there is no such occurrence) *) let rec suffix sym lst = match lst with | [] -> [] | h :: t -> if h = sym (* structural eq *) then lst else suffix sym t;; (* Return a list of pairs. Each pair consists of a symbol A and a list of symbols beta such that for some alpha, A -> alpha B beta. *) type right_context = (string * string list) list;; let get_right_context (b:string) gram : right_context = fold_left (@) [] (map (fun prod -> let a = fst prod in let rec helper accum rhs = let b_beta = suffix b rhs in match b_beta with | [] -> accum | x :: beta -> (* assert x = b *) helper ((a, beta) :: accum) beta in helper [] (snd prod)) (productions gram));; type symbol_knowledge = string * bool * string list * string list;; type knowledge = symbol_knowledge list;; let symbol_field (s, e, fi, fo) = s;; let eps_field (s, e, fi, fo) = e;; let first_field (s, e, fi, fo) = fi;; let follow_field (s, e, fi, fo) = fo;; let initial_knowledge gram : knowledge = map (fun a -> (a, false, [], [])) (nonterminals gram);; let get_symbol_knowledge (a:string) (kdg:knowledge) : symbol_knowledge = find (fun (s, e, fi, fo) -> s = a) kdg;; (* Can word list w generate epsilon based on current estimates? if w is an empty list, yes if w is a single terminal, no if w is a single nonterminal, look it up if w is a non-empty list, "iterate" over elements *) let rec generates_epsilon (w:string list) (kdg:knowledge) gram : bool = match w with | [] -> true | h :: t -> if is_terminal h gram then false else eps_field (get_symbol_knowledge h kdg) && generates_epsilon t kdg gram;; (* Return FIRST(w), based on current estimates. if w is an empty list, return [] [empty set] if w is a single terminal, return [w] if w is a single nonterminal, look it up if w is a non-empty list, "iterate" over elements *) let rec first (w:string list) (kdg:knowledge) gram : (string list) = match w with | [] -> [] | x :: _ when is_terminal x gram -> [x] | x :: rest -> let s = first_field (get_symbol_knowledge x kdg) in if generates_epsilon [x] kdg gram then union s (first rest kdg gram) else s;; let follow (a:string) (kdg:knowledge) : string list = follow_field (get_symbol_knowledge a kdg);; let rec map3 f l1 l2 l3 = match (l1, l2, l3) with | ([], [], []) -> [] | (h1 :: t1, h2 :: t2, h3 :: t3) -> (f h1 h2 h3) :: map3 f t1 t2 t3 | _ -> raise (Failure "mismatched_lists in map3");; (* Return knowledge structure for grammar. Start with (initial_knowledge grammar) and "iterate", until the structure doesn't change. Uses (get_right_context B gram), for all nonterminals B, to help compute follow sets. *) let get_knowledge gram : knowledge = let nts : string list = nonterminals gram in let right_contexts : right_context list = map (fun s -> get_right_context s gram) nts in let rec helper kdg = let update : symbol_knowledge -> symbol_productions -> right_context -> symbol_knowledge = fun old_sym_kdg sym_prods sym_right_context -> let my_first s = first s kdg gram in let my_eps s = generates_epsilon s kdg gram in let filtered_follow p = if my_eps (snd p) then (follow (fst p) kdg) else [] in ( symbol_field old_sym_kdg, (* nonterminal itself *) (eps_field old_sym_kdg) (* previous estimate *) || (fold_left (||) false (map my_eps (snd sym_prods))), union (first_field old_sym_kdg) (* previous estimate *) (fold_left union [] (map my_first (snd sym_prods))), union (union (follow_field old_sym_kdg) (* previous estimate *) (fold_left union [] (map my_first (map (fun p -> match snd p with | [] -> [] | h :: t -> [h]) sym_right_context)))) (fold_left union [] (map filtered_follow sym_right_context)) ) in (* end of update *) let new_kdg = map3 update kdg gram right_contexts in (* body of helper: *) if new_kdg = kdg then kdg else helper new_kdg in (* body of get_knowledge: *) helper (initial_knowledge gram);; (* This is the heart of the parser generator *) let get_parse_table (gram:grammar) : parse_table = let kdg = get_knowledge gram in map (fun (lhs, rhss) -> (lhs, (map (fun rhs -> (union (first rhs kdg gram) (if (generates_epsilon rhs kdg gram) then (follow lhs kdg) else []), rhs)) rhss))) gram;; type parse_action = PA_error | PA_prediction of string list;; (* Double-index to find prediction (list of RHS symbols) for nonterminal nt and terminal t. Return PA_error if not found. *) let get_parse_action (nt:string) (t:string) (parse_tab:parse_table) : parse_action = let rec helper l = match l with | [] -> PA_error | (fs, rhs) :: rest -> if mem t fs then PA_prediction(rhs) else helper rest in helper (assoc nt parse_tab);; (* Read standard input and return it as a string *) let read_input () : string = let lines = ref [] in try while true do lines := read_line () :: !lines; done; "" with End_of_file -> String.concat "\n" (rev !lines);; (* Break a string into a [reverse order] list of lists of words *) let line_split s : string list list = map (fun line -> split (regexp "[ \t]+") line) (rev (split (regexp "[\n\r]+") s));; (* Make sure - grammar is non-empty - all lhs-es are unique - no AR number appears more than once - each AR number is well formed - every symbol has a spelling that's acceptable as a Rust enum constant - the symbols Goal and Stop are not used - the attribute routine numbers 0 and 1 are not used ( could also check for useless symbols, but that doesn't seem essential ) *) let error_in (g: grammar) : string option = if g == [] then Some "Input grammar is empty" else if (terminals g) = [] then Some "Input grammar has no terminals" else let nt_dups = unique_sort (duplicates (map fst g)) in if nt_dups != [] then Some ("Each nonterminal must lead exactly one production group; see\n " ^ (String.concat " " nt_dups)) else let bad_sym (w : string) : bool = not (string_match (regexp {|^\([A-Z][A-Za-z]*\)\|\({[0-9][0-9]*}\)$|}) w 0) in let all_syms = flatten (map (fun (lhs, rhss) -> lhs :: (flatten rhss)) g) in let bad_syms = unique_sort (filter bad_sym all_syms) in if bad_syms != [] then Some ("Each symbol must either satisfy the lexical rules of a Rust enum item\n\ or be a brace-bracketed integer (action routine); see\n " ^ (String.concat " " (List.sort String.compare bad_syms))) else if (mem "{0}" all_syms) || (mem "{1}" all_syms) then Some "Action routines {0} and {1} are reserved for the augmenting production." else if (mem "Goal" all_syms) || (mem "Stop" all_syms) then Some "Nonterminals Goal and Stop are reserved for the augmenting production." else let ar_dups = unique_sort (duplicates (filter (fun w -> string_match (regexp {|^{[0-9][0-9]*}$|}) w 0) all_syms)) in if ar_dups != [] then Some ("No action routine number is allowed to appear more than once; see\n " ^ (String.concat " " (sort String.compare ar_dups))) else None;; (* Add an augmenting production to a grammar *) let augment (g : grammar) : grammar = ("Goal", [["{0}"; start_symbol g; "{1}"; "Stop"]]) :: g;; (* Remove attribute routines from a grammar *) let strip_ars (g : grammar) : grammar = let strip_rhs (rhs : string list) : string list = filter (fun w -> (string_match (regexp {|^[A-Z][A-Za-z]*$|}) w 0)) rhs in let strip_rhss (rhss : string list list) : string list list = map strip_rhs rhss in map (fun ((lhs : string), (rhss : string list list)) -> (lhs, (strip_rhss rhss))) g;; (* Parse a [reverse order] list of lists of words, error-check it, and return an optional pair consisting of the CFG it comprises (with attribute routines stripped out) and its productions (before the strip) *) let grammar_of (s : string list list) : ((grammar * prod_list), string) result = let rec consolidate lines rhses gram_so_far : (grammar, string) result = match gram_so_far with | Error msg -> Error msg | Ok gsf -> match lines with | [] -> ( match rhses with | [] -> Ok gsf | _ -> Error "First line has no LHS!" ) | ("->" :: rhs) :: more -> consolidate more (rhs :: rhses) gram_so_far | (lhs :: "->" :: rhs) :: more -> consolidate more [] (Ok ((lhs, (rhs :: rhses)) :: gsf)) | line :: more -> Error ("Malformed line: " ^ (String.concat " " line)) in match consolidate s [] (Ok []) with | Error msg -> Error msg | Ok g -> match error_in g with | Some s -> Error s | None -> let ag = augment g in Ok (strip_ars ag, productions ag);; (* Generate parsing tables as Rust declrations. Parameter s is a string that documents the grammar; harmless if "" *) let rust_tables (s : string) (g : grammar) (t : parse_table) (full_prods : prod_list) : string = let original_start_symbol = match g with | _ :: (oss, _) :: _ -> oss | _ -> raise (Failure "malformed grammar") in let terms = terminals g in let nonterms = nonterminals g in let max_nt_len = fold_left (fun n s -> max n (String.length s)) 0 nonterms in let bare_prods = productions g in let kdg = get_knowledge g in let firsts = map (fun (nt, _, fs, _) -> (nt, fs)) kdg in let follows = map (fun (nt, _, _, fs) -> (nt, fs)) kdg in let per_nt_decs f = String.concat "\n" (map (fun (nt, fs) -> (Printf.sprintf "/* %-*s */ &[%s]," max_nt_len nt (String.concat ", " fs))) f) in (* Do this to a first_set, rhs pair to get an association list that pairs each tok with the production index of the rhs (negated if an epsilon prod): *) let forall_first_toks lhs (tks, rhs) = let i = match find_index (fun (l, r) -> l = lhs && r = rhs) bare_prods with | None -> failwith "production not found" | Some pi -> if (generates_epsilon rhs kdg g) then (-pi) else pi in map (fun t -> (t, i)) tks in (* Use this to convert the alists to one line of the desired table: *) let pt_line al = map (fun t -> match assoc_opt t al with | None -> "Err" | Some i -> Printf.sprintf "%s(%d)" (if i < 0 then "EProd" else "Prod") (abs i)) terms in (* Use this to get the whole table *) let actions = map (fun (nt, pairs) -> (nt, pt_line (concat (map (forall_first_toks nt) pairs)))) t in "/// Output produced by table_gen, " ^ (today ()) ^ "\n/**\n" ^ "Goal -> {0} " ^ original_start_symbol ^ " {1} Stop\n" ^ s ^ "\n*/\n\n" ^ "#[derive(PartialEq, Copy, Clone, Debug)]\n \ // allow tokens to be compared for equality, copied, and (debug) printed\n\ pub enum Tkn { " ^ (hd terms) ^ " = 0, " ^ (String.concat ", " (tl terms)) ^ ", TknSIZE }\n\ pub use Tkn::*; // make enum constants visible without scope id\n\n" ^ "#[derive(PartialEq, Copy, Clone, Debug)]\n \ // allow nonterminals to be compared for equality, copied, and (debug) printed\n\ pub enum Ntm { " ^ (hd nonterms) ^ " = 0, " ^ (String.concat ", " (tl nonterms)) ^ ", NtmSIZE }\n\ pub use Ntm::*; // make enum constants visible without scope id\n\n" ^ "#[derive(PartialEq, Copy, Clone, Debug)]\n \ // allow symbols to be compared for equality, copied, and (debug) printed\n\ pub enum PSitem { Tk(Tkn), NT(Ntm), EoP, AR(u32) }\n\ pub use PSitem::*; // make variants visible without scope id\n\ \n\ #[derive(PartialEq, Copy, Clone, Debug)]\n \ // allow actions to be compared for equality, copied, and (debug) printed\n\ pub enum Act { Err, Prod(usize), EProd(usize) }\n \ // EProd indicates a direct or indirect epsilon production, predicted on the basis\n \ // of FOLLOW sets and thus vulnerable to the immediate error detection problem.\n\ pub use Act::*; // make variants visible without scope id\n\n" ^ (Printf.sprintf "pub const PROD_TAB: [&'static[PSitem]; %d] = [\n" (length full_prods)) ^ (String.concat "\n" (mapi (fun i (lhs, rhs) -> (Printf.sprintf "/* %2d %-*s */ &[%s]," i max_nt_len lhs (String.concat ", " (map (fun s -> if mem s terms then "Tk(" ^ s ^ ")" else if (String.get s 0) = '{' then "AR(" ^ (String.sub s 1 ((String.length s) - 2)) ^ ")" else "NT(" ^ s ^ ")") rhs)))) full_prods)) ^ "\n];\n\n" ^ "pub const FIRST : [&'static[Tkn]; NtmSIZE as usize] = [\n" ^ (per_nt_decs firsts) ^ "\n];\n\n" ^ "pub const FOLLOW : [&'static[Tkn]; NtmSIZE as usize] = [\n" ^ (per_nt_decs follows) ^ "\n];\n\n" ^ "// doubly indexed arrays in Rust are declared inside out; index as PARSE_TAB[nonterm, term]\n\ pub const PARSE_TAB : [&'static[Act; TknSIZE as usize]; NtmSIZE as usize] = [\n\ // " ^ (String.concat ", " terms) ^ "\n" ^ (per_nt_decs actions) ^ "\n];\n\n";; (******************************************************************* Testing *******************************************************************) let calc_gram : grammar = [ ("Goal", [["SL"; "Stop"]]) ; ("SL", [["S"; "SL"]; []]) ; ("S", [ ["Id"; "Gets"; "E"]; ["Read"; "Id"]; ["Write"; "E"]]) ; ("E", [["T"; "TT"]]) ; ("T", [["F"; "FT"]]) ; ("TT", [["AO"; "T"; "TT"]; []]) ; ("FT", [["MO"; "F"; "FT"]; []]) ; ("AO", [["Plus"]; ["Minus"]]) ; ("MO", [["Times"]; ["DivBy"]]) ; ("F", [["Id"]; ["Num"]; ["LParen"; "E"; "RParen"]]) ];; let ecg : grammar = (* extended calculator grammar *) [ ("P", [["SL"; "$$"]]) ; ("SL", [["S"; "SL"]; []]) ; ("S", [ ["int"; "id"; ":="; "E"]; ["real"; "id"; ":="; "E"] ; ["id"; ":="; "E"]; ["read"; "TP"; "id"]; ["write"; "E"] ; ["if"; "C"; "SL"; "fi"]; ["do"; "SL"; "od"] ; ["check"; "C"] ]) ; ("TP", [["int"]; ["real"]; []]) ; ("C", [["E"; "RO"; "E"]]) ; ("E", [["T"; "TT"]]) ; ("TT", [["AO"; "T"; "TT"]; []]) ; ("T", [["F"; "FT"]]) ; ("FT", [["MO"; "F"; "FT"]; []]) ; ("F", [["("; "E"; ")"]; ["id"]; ["i_num"]; ["r_num"] ; ["trunc"; "("; "E"; ")"]; ["float"; "("; "E"; ")"]]) ; ("RO", [["=="]; ["!="]; ["<"]; [">"]; ["<="]; [">="]]) ; ("AO", [["+"]; ["-"]]) ; ("MO", [["*"]; ["/"]]) ];; let cg_parse_table = get_parse_table calc_gram;; let ecg_parse_table = get_parse_table ecg;; let calc_gram_str = " SL -> S {2} SL {3} -> S -> Id Gets E {4} -> Read Id {5} -> Write E {6} E -> T {7} TT {8} T -> F {9} FT {10} TT -> AO T {11} TT {12} -> FT -> MO F {13} FT {14} -> AO -> Plus {15} -> Minus {16} MO -> Times {17} -> DivBy {18} F -> Id {19} -> Num {20} -> LParen E RParen {21}";; let bad_gram_1 = " A -> B -> C B -> X C -> Y A -> Q ";; let bad_gram_2 = " A -> B -> C B -> Goal C -> Y ";; let bad_gram_3 = " x -> y -> z ";; let bad_gram_4 = " A -> {3 B C ";; let bad_gram_5 = " A -> B {2} C B -> C {2} D ";; let bad_gram_6 = " -> X Y Z ";; let bad_gram_7 = " A -> {0} B ";; (******************************************************************* Main *******************************************************************) let print_tables_for s = match grammar_of (line_split s) with | Error msg -> print_string (msg ^ "\n") | Ok (bare_gram, full_prods) -> print_string (rust_tables s bare_gram (get_parse_table bare_gram) full_prods);; let main () = let inp = read_input () in print_tables_for inp;; (* Execute function "main" iff run as a stand-alone program. *) if !Sys.interactive then () else main ();;