ocaml/test/Lex/lexgen.ml

253 lines
6.9 KiB
OCaml

(* Compiling a lexer definition *)
open Syntax
(* Deep abstract syntax for regular expressions *)
type regexp =
Empty
| Chars of int
| Action of int
| Seq of regexp * regexp
| Alt of regexp * regexp
| Star of regexp
(* From shallow to deep syntax *)
(***
let print_char_class c =
let print_interval low high =
prerr_int low;
if high - 1 > low then begin
prerr_char '-';
prerr_int (high-1)
end;
prerr_char ' ' in
let rec print_class first next = function
[] -> print_interval first next
| c::l ->
if char.code c = next
then print_class first (next+1) l
else begin
print_interval first next;
print_class (char.code c) (char.code c + 1) l
end in
match c with
[] -> prerr_newline()
| c::l -> print_class (char.code c) (char.code c + 1) l; prerr_newline()
let rec print_regexp = function
Empty -> prerr_string "Empty"
| Chars n -> prerr_string "Chars "; prerr_int n
| Action n -> prerr_string "Action "; prerr_int n
| Seq(r1,r2) -> print_regexp r1; prerr_string "; "; print_regexp r2
| Alt(r1,r2) -> prerr_string "("; print_regexp r1; prerr_string " | "; print_regexp r2; prerr_string ")"
| Star r -> prerr_string "("; print_regexp r; prerr_string ")*"
***)
let chars = ref ([] : char list list)
let chars_count = ref 0
let actions = ref ([] : (int * location) list)
let actions_count = ref 0
let rec encode_regexp = function
Epsilon -> Empty
| Characters cl ->
let n = !chars_count in
(*** prerr_int n; prerr_char ' '; print_char_class cl; ***)
chars := cl :: !chars;
chars_count := !chars_count + 1;
Chars(n)
| Sequence(r1,r2) ->
Seq(encode_regexp r1, encode_regexp r2)
| Alternative(r1,r2) ->
Alt(encode_regexp r1, encode_regexp r2)
| Repetition r ->
Star (encode_regexp r)
let encode_casedef =
List.fold_left
(fun reg (expr,act) ->
let act_num = !actions_count in
actions_count := !actions_count + 1;
actions := (act_num, act) :: !actions;
Alt(reg, Seq(encode_regexp expr, Action act_num)))
Empty
let encode_lexdef (Lexdef(_, ld)) =
chars := [];
chars_count := 0;
actions := [];
actions_count := 0;
let name_regexp_list =
List.map (fun (name, casedef) -> (name, encode_casedef casedef)) ld in
(* List.iter print_char_class chars; *)
let chr = Array.of_list (List.rev !chars)
and act = !actions in
chars := [];
actions := [];
(chr, name_regexp_list, act)
(* To generate directly a NFA from a regular expression.
Confer Aho-Sethi-Ullman, dragon book, chap. 3 *)
type transition =
OnChars of int
| ToAction of int
let rec merge_trans l1 l2 =
match (l1, l2) with
([], s2) -> s2
| (s1, []) -> s1
| ((OnChars n1 as t1) :: r1 as s1), ((OnChars n2 as t2) :: r2 as s2) ->
if n1 = n2 then t1 :: merge_trans r1 r2 else
if n1 < n2 then t1 :: merge_trans r1 s2 else
t2 :: merge_trans s1 r2
| ((ToAction n1 as t1) :: r1 as s1), ((ToAction n2 as t2) :: r2 as s2) ->
if n1 = n2 then t1 :: merge_trans r1 r2 else
if n1 < n2 then t1 :: merge_trans r1 s2 else
t2 :: merge_trans s1 r2
| ((OnChars n1 as t1) :: r1 as s1), ((ToAction n2 as t2) :: r2 as s2) ->
t1 :: merge_trans r1 s2
| ((ToAction n1 as t1) :: r1 as s1), ((OnChars n2 as t2) :: r2 as s2) ->
t2 :: merge_trans s1 r2
let rec nullable = function
Empty -> true
| Chars _ -> false
| Action _ -> false
| Seq(r1,r2) -> nullable r1 & nullable r2
| Alt(r1,r2) -> nullable r1 or nullable r2
| Star r -> true
let rec firstpos = function
Empty -> []
| Chars pos -> [OnChars pos]
| Action act -> [ToAction act]
| Seq(r1,r2) -> if nullable r1
then merge_trans (firstpos r1) (firstpos r2)
else firstpos r1
| Alt(r1,r2) -> merge_trans (firstpos r1) (firstpos r2)
| Star r -> firstpos r
let rec lastpos = function
Empty -> []
| Chars pos -> [OnChars pos]
| Action act -> [ToAction act]
| Seq(r1,r2) -> if nullable r2
then merge_trans (lastpos r1) (lastpos r2)
else lastpos r2
| Alt(r1,r2) -> merge_trans (lastpos r1) (lastpos r2)
| Star r -> lastpos r
let followpos size name_regexp_list =
let v = Array.new size [] in
let fill_pos first = function
OnChars pos -> v.(pos) <- merge_trans first v.(pos); ()
| ToAction _ -> () in
let rec fill = function
Seq(r1,r2) ->
fill r1; fill r2;
List.iter (fill_pos (firstpos r2)) (lastpos r1)
| Alt(r1,r2) ->
fill r1; fill r2
| Star r ->
fill r;
List.iter (fill_pos (firstpos r)) (lastpos r)
| _ -> () in
List.iter (fun (name, regexp) -> fill regexp) name_regexp_list;
v
let no_action = 0x3FFFFFFF
let split_trans_set =
List.fold_left
(fun (act, pos_set as act_pos_set) trans ->
match trans with
OnChars pos -> (act, pos :: pos_set)
| ToAction act1 -> if act1 < act then (act1, pos_set)
else act_pos_set)
(no_action, [])
let memory = (Hashtbl.new 131 : (transition list, int) Hashtbl.t)
let todo = ref ([] : (transition list * int) list)
let next = ref 0
let get_state st =
try
Hashtbl.find memory st
with Not_found ->
let nbr = !next in
next := !next + 1;
Hashtbl.add memory st nbr;
todo := (st, nbr) :: !todo;
nbr
let rec map_on_states f =
match !todo with
[] -> []
| (st,i)::r -> todo := r; let res = f st in (res,i) :: map_on_states f
let number_of_states () = !next
let goto_state = function
[] -> Backtrack
| ps -> Goto (get_state ps)
let transition_from chars follow pos_set =
let tr = Array.new 256 []
and shift = Array.new 256 Backtrack in
List.iter
(fun pos ->
List.iter
(fun c ->
tr.(Char.code c) <-
merge_trans tr.(Char.code c) follow.(pos))
chars.(pos))
pos_set;
for i = 0 to 255 do
shift.(i) <- goto_state tr.(i)
done;
shift
let translate_state chars follow state =
match split_trans_set state with
n, [] -> Perform n
| n, ps -> Shift( (if n = no_action then No_remember else Remember n),
transition_from chars follow ps)
let make_dfa lexdef =
let (chars, name_regexp_list, actions) =
encode_lexdef lexdef in
(**
List.iter (fun (name, regexp) -> prerr_string name; prerr_string " = "; print_regexp regexp; prerr_newline()) name_regexp_list;
**)
let follow =
followpos (Array.length chars) name_regexp_list in
let initial_states =
List.map (fun (name, regexp) -> (name, get_state(firstpos regexp)))
name_regexp_list in
let states =
map_on_states (translate_state chars follow) in
let v =
Array.new (number_of_states()) (Perform 0) in
List.iter (fun (auto, i) -> v.(i) <- auto) states;
(initial_states, v, actions)