← Back to branch summary

~ubuntu-branches/debian/sid/ocaml/sid

« back to all changes in this revision

Viewing changes to testsuite/tests/tool-lexyacc/lexgen.ml

  • Committer: Bazaar Package Importer
  • Author(s): Stéphane Glondu
  • Date: 2011-04-21 21:35:08 UTC
  • mfrom: (1.1.11 upstream) (12.1.14 sid)
  • Revision ID: james.westby@ubuntu.com-20110421213508-kg34453aqmb0moha
* Fixes related to -output-obj with g++ (in debian/patches):
  - add Declare-primitive-name-table-as-const-char
  - add Avoid-multiple-declarations-in-generated-.c-files-in
  - fix Embed-bytecode-in-C-object-when-using-custom: the closing
    brace for extern "C" { ... } was missing in some cases

Show diffs side-by-side

added added

removed removed

Lines of Context:
testsuite/tests/tool-lexyacc/lexgen.ml
 
1
(***********************************************************************)
 
2
(*                                                                     *)
 
3
(*                           Objective Caml                            *)
 
4
(*                                                                     *)
 
5
(*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
 
6
(*                                                                     *)
 
7
(*  Copyright 1996 Institut National de Recherche en Informatique et   *)
 
8
(*  en Automatique.  All rights reserved.  This file is distributed    *)
 
9
(*  under the terms of the Q Public License version 1.0.               *)
 
10
(*                                                                     *)
 
11
(***********************************************************************)
 
12
 
 
13
(* $Id: lexgen.ml,v 1.5 2000/12/28 13:06:39 weis Exp $ *)
 
14
 
 
15
(* Compiling a lexer definition *)
 
16
 
 
17
open Syntax
 
18
 
 
19
(* Deep abstract syntax for regular expressions *)
 
20
 
 
21
type regexp =
 
22
    Empty
 
23
  | Chars of int
 
24
  | Action of int
 
25
  | Seq of regexp * regexp
 
26
  | Alt of regexp * regexp
 
27
  | Star of regexp
 
28
 
 
29
(* From shallow to deep syntax *)
 
30
 
 
31
(***
 
32
 
 
33
let print_char_class c =
 
34
  let print_interval low high =
 
35
    prerr_int low;
 
36
    if high - 1 > low then begin
 
37
      prerr_char '-';
 
38
      prerr_int (high-1)
 
39
    end;
 
40
    prerr_char ' ' in
 
41
  let rec print_class first next = function
 
42
    [] -> print_interval first next
 
43
  | c::l ->
 
44
      if char.code c = next
 
45
      then print_class first (next+1) l
 
46
      else begin
 
47
        print_interval first next;
 
48
        print_class (char.code c) (char.code c + 1) l
 
49
      end in
 
50
  match c with
 
51
    [] -> prerr_newline()
 
52
  | c::l -> print_class (char.code c) (char.code c + 1) l; prerr_newline()
 
53
 
 
54
 
 
55
let rec print_regexp = function
 
56
    Empty -> prerr_string "Empty"
 
57
  | Chars n -> prerr_string "Chars "; prerr_int n
 
58
  | Action n -> prerr_string "Action "; prerr_int n
 
59
  | Seq(r1,r2) -> print_regexp r1; prerr_string "; "; print_regexp r2
 
60
  | Alt(r1,r2) -> prerr_string "("; print_regexp r1; prerr_string " | "; print_regexp r2; prerr_string ")"
 
61
  | Star r -> prerr_string "("; print_regexp r; prerr_string ")*"
 
62
 
 
63
***)
 
64
 
 
65
let chars = ref ([] : char list list)
 
66
let chars_count = ref 0
 
67
let actions = ref ([] : (int * location) list)
 
68
let actions_count = ref 0
 
69
 
 
70
let rec encode_regexp = function
 
71
    Epsilon -> Empty
 
72
  | Characters cl ->
 
73
      let n = !chars_count in
 
74
(***      prerr_int n; prerr_char ' '; print_char_class cl; ***)
 
75
      chars := cl :: !chars;
 
76
      chars_count := !chars_count + 1;
 
77
      Chars(n)
 
78
  | Sequence(r1,r2) ->
 
79
      Seq(encode_regexp r1, encode_regexp r2)
 
80
  | Alternative(r1,r2) ->
 
81
      Alt(encode_regexp r1, encode_regexp r2)
 
82
  | Repetition r ->
 
83
      Star (encode_regexp r)
 
84
 
 
85
 
 
86
let encode_casedef =
 
87
  List.fold_left
 
88
   (fun reg (expr,act) ->
 
89
     let act_num = !actions_count in
 
90
     actions_count := !actions_count + 1;
 
91
     actions := (act_num, act) :: !actions;
 
92
     Alt(reg, Seq(encode_regexp expr, Action act_num)))
 
93
  Empty
 
94
 
 
95
 
 
96
let encode_lexdef (Lexdef(_, ld)) =
 
97
  chars := [];
 
98
  chars_count := 0;
 
99
  actions := [];
 
100
  actions_count := 0;
 
101
  let name_regexp_list =
 
102
    List.map (fun (name, casedef) -> (name, encode_casedef casedef)) ld in
 
103
(*  List.iter print_char_class chars; *)
 
104
  let chr = Array.of_list (List.rev !chars)
 
105
  and act = !actions in
 
106
  chars := [];
 
107
  actions := [];
 
108
  (chr, name_regexp_list, act)
 
109
 
 
110
 
 
111
(* To generate directly a NFA from a regular expression.
 
112
   Confer Aho-Sethi-Ullman, dragon book, chap. 3 *)
 
113
 
 
114
type transition =
 
115
    OnChars of int
 
116
  | ToAction of int
 
117
 
 
118
 
 
119
let rec merge_trans l1 l2 =
 
120
  match (l1, l2) with
 
121
    ([], s2) -> s2
 
122
  | (s1, []) -> s1
 
123
  | ((OnChars n1 as t1) :: r1 as s1), ((OnChars n2 as t2) :: r2 as s2) ->
 
124
      if n1 = n2 then t1 :: merge_trans r1 r2 else
 
125
      if n1 < n2 then t1 :: merge_trans r1 s2 else
 
126
                      t2 :: merge_trans s1 r2
 
127
  | ((ToAction n1 as t1) :: r1 as s1), ((ToAction n2 as t2) :: r2 as s2) ->
 
128
      if n1 = n2 then t1 :: merge_trans r1 r2 else
 
129
      if n1 < n2 then t1 :: merge_trans r1 s2 else
 
130
                      t2 :: merge_trans s1 r2
 
131
  | ((OnChars n1 as t1) :: r1), ((ToAction n2) :: r2 as s2) ->
 
132
      t1 :: merge_trans r1 s2
 
133
  | ((ToAction n1) :: r1 as s1), ((OnChars n2 as t2) :: r2) ->
 
134
      t2 :: merge_trans s1 r2
 
135
 
 
136
 
 
137
let rec nullable = function
 
138
    Empty      -> true
 
139
  | Chars _    -> false
 
140
  | Action _   -> false
 
141
  | Seq(r1,r2) -> nullable r1 && nullable r2
 
142
  | Alt(r1,r2) -> nullable r1 || nullable r2
 
143
  | Star r     -> true
 
144
 
 
145
 
 
146
let rec firstpos = function
 
147
    Empty      -> []
 
148
  | Chars pos  -> [OnChars pos]
 
149
  | Action act -> [ToAction act]
 
150
  | Seq(r1,r2) -> if nullable r1
 
151
                  then merge_trans (firstpos r1) (firstpos r2)
 
152
                  else firstpos r1
 
153
  | Alt(r1,r2) -> merge_trans (firstpos r1) (firstpos r2)
 
154
  | Star r     -> firstpos r
 
155
 
 
156
 
 
157
let rec lastpos = function
 
158
    Empty      -> []
 
159
  | Chars pos  -> [OnChars pos]
 
160
  | Action act -> [ToAction act]
 
161
  | Seq(r1,r2) -> if nullable r2
 
162
                  then merge_trans (lastpos r1) (lastpos r2)
 
163
                  else lastpos r2
 
164
  | Alt(r1,r2) -> merge_trans (lastpos r1) (lastpos r2)
 
165
  | Star r     -> lastpos r
 
166
 
 
167
 
 
168
let followpos size name_regexp_list =
 
169
  let v = Array.create size [] in
 
170
    let fill_pos first = function
 
171
        OnChars pos -> v.(pos) <- merge_trans first v.(pos); ()
 
172
      | ToAction _  -> () in
 
173
    let rec fill = function
 
174
        Seq(r1,r2) ->
 
175
          fill r1; fill r2;
 
176
          List.iter (fill_pos (firstpos r2)) (lastpos r1)
 
177
      | Alt(r1,r2) ->
 
178
          fill r1; fill r2
 
179
      | Star r ->
 
180
          fill r;
 
181
          List.iter (fill_pos (firstpos r)) (lastpos r)
 
182
      | _ -> () in
 
183
    List.iter (fun (name, regexp) -> fill regexp) name_regexp_list;
 
184
    v
 
185
 
 
186
 
 
187
let no_action = 0x3FFFFFFF
 
188
 
 
189
let split_trans_set =
 
190
  List.fold_left
 
191
    (fun (act, pos_set as act_pos_set) trans ->
 
192
       match trans with
 
193
         OnChars pos   -> (act, pos :: pos_set)
 
194
       | ToAction act1 -> if act1 < act then (act1, pos_set)
 
195
                                             else act_pos_set)
 
196
    (no_action, [])
 
197
 
 
198
 
 
199
let memory = (Hashtbl.create 131 : (transition list, int) Hashtbl.t)
 
200
let todo = ref ([] : (transition list * int) list)
 
201
let next = ref 0
 
202
 
 
203
let get_state st = 
 
204
  try
 
205
    Hashtbl.find memory st
 
206
  with Not_found ->
 
207
    let nbr = !next in
 
208
    next := !next + 1;
 
209
    Hashtbl.add memory st nbr;
 
210
    todo := (st, nbr) :: !todo;
 
211
    nbr
 
212
 
 
213
let rec map_on_states f =
 
214
  match !todo with
 
215
    []  -> []
 
216
  | (st,i)::r -> todo := r; let res = f st in (res,i) :: map_on_states f
 
217
 
 
218
let number_of_states () = !next
 
219
 
 
220
let goto_state = function
 
221
    [] -> Backtrack
 
222
  | ps -> Goto (get_state ps)
 
223
 
 
224
 
 
225
let transition_from chars follow pos_set = 
 
226
  let tr = Array.create 256 []
 
227
  and shift = Array.create 256 Backtrack in
 
228
    List.iter
 
229
      (fun pos ->
 
230
        List.iter
 
231
          (fun c ->
 
232
             tr.(Char.code c) <-
 
233
               merge_trans tr.(Char.code c) follow.(pos))
 
234
          chars.(pos))
 
235
      pos_set;
 
236
    for i = 0 to 255 do
 
237
      shift.(i) <- goto_state tr.(i)
 
238
    done;
 
239
    shift
 
240
 
 
241
 
 
242
let translate_state chars follow state =
 
243
  match split_trans_set state with
 
244
    n, [] -> Perform n
 
245
  | n, ps -> Shift( (if n = no_action then No_remember else Remember n),
 
246
                    transition_from chars follow ps)
 
247
 
 
248
 
 
249
let make_dfa lexdef =
 
250
  let (chars, name_regexp_list, actions) =
 
251
    encode_lexdef lexdef in
 
252
(**
 
253
  List.iter (fun (name, regexp) -> prerr_string name; prerr_string " = "; print_regexp regexp; prerr_newline()) name_regexp_list;
 
254
**)
 
255
  let follow =
 
256
    followpos (Array.length chars) name_regexp_list in
 
257
  let initial_states =
 
258
    List.map (fun (name, regexp) -> (name, get_state(firstpos regexp)))
 
259
             name_regexp_list in
 
260
  let states =
 
261
    map_on_states (translate_state chars follow) in
 
262
  let v =
 
263
    Array.create (number_of_states()) (Perform 0) in
 
264
  List.iter (fun (auto, i) -> v.(i) <- auto) states;
 
265
  (initial_states, v, actions)
 
266