Vous avez reçu un message "Your GitLab account has been locked ..." ? Pas d'inquiétude : lisez cet article https://docs.gricad-pages.univ-grenoble-alpes.fr/help/unlock/

Lexer.mll 26.5 KB
Newer Older
1
2
3
4
5
6
7
8
(* *********************************************************************)
(*                                                                     *)
(*              The Compcert verified compiler                         *)
(*                                                                     *)
(*          Jacques-Henri Jourdan, INRIA Paris-Rocquencourt            *)
(*                                                                     *)
(*  Copyright Institut National de Recherche en Informatique et en     *)
(*  Automatique.  All rights reserved.  This file is distributed       *)
9
10
11
12
13
(*  under the terms of the GNU Lesser General Public License as        *)
(*  published by the Free Software Foundation, either version 2.1 of   *)
(*  the License, or  (at your option) any later version.               *)
(*  This file is also distributed under the terms of the               *)
(*  INRIA Non-Commercial License Agreement.                            *)
14
15
16
(*                                                                     *)
(* *********************************************************************)

17
18
{
open Lexing
19
20
21
open Pre_parser
open Pre_parser_aux

22
module SSet = Set.Make(String)
23

24
let lexicon : (string, Cabs.loc -> token) Hashtbl.t = Hashtbl.create 17
25
let ignored_keywords : SSet.t ref = ref SSet.empty
26

27
28
29
30
let reserved_keyword loc id =
  Diagnostics.fatal_error (loc.Cabs.filename, loc.Cabs.lineno)
    "illegal use of reserved keyword `%s'" id

31
32
let () =
  List.iter (fun (key, builder) -> Hashtbl.add lexicon key builder)
33
34
    [ 
      ("_Alignas", fun loc -> ALIGNAS loc);
35
36
      ("_Alignof", fun loc -> ALIGNOF loc);
      ("_Bool", fun loc -> UNDERSCORE_BOOL loc);
37
38
      ("_Complex", fun loc -> reserved_keyword loc "_Complex");
      ("_Imaginary", fun loc -> reserved_keyword loc "_Imaginary");
Xavier Leroy's avatar
Xavier Leroy committed
39
      ("_Static_assert", fun loc -> STATIC_ASSERT loc);
40
41
42
43
44
45
46
      ("__alignof", fun loc -> ALIGNOF loc);
      ("__alignof__", fun loc -> ALIGNOF loc);
      ("__asm", fun loc -> ASM loc);
      ("__asm__", fun loc -> ASM loc);
      ("__attribute", fun loc -> ATTRIBUTE loc);
      ("__attribute__", fun loc -> ATTRIBUTE loc);
      ("__builtin_va_arg", fun loc -> BUILTIN_VA_ARG loc);
47
      ("__builtin_offsetof", fun loc -> BUILTIN_OFFSETOF loc);
48
49
50
51
52
53
54
55
56
57
58
59
60
      ("__const", fun loc -> CONST loc);
      ("__const__", fun loc -> CONST loc);
      ("__inline", fun loc -> INLINE loc);
      ("__inline__", fun loc -> INLINE loc);
      ("__packed__", fun loc -> PACKED loc);
      ("__restrict", fun loc -> RESTRICT loc);
      ("__restrict__", fun loc -> RESTRICT loc);
      ("__signed", fun loc -> SIGNED loc);
      ("__signed__", fun loc -> SIGNED loc);
      ("__volatile", fun loc -> VOLATILE loc);
      ("__volatile__", fun loc -> VOLATILE loc);
      ("asm", fun loc -> ASM loc);
      ("auto", fun loc -> AUTO loc);
61
62
63
      ("break", fun loc -> BREAK loc);
      ("case", fun loc -> CASE loc);
      ("char", fun loc -> CHAR loc);
64
      ("const", fun loc -> CONST loc);
65
66
67
68
69
70
      ("continue", fun loc -> CONTINUE loc);
      ("default", fun loc -> DEFAULT loc);
      ("do", fun loc -> DO loc);
      ("double", fun loc -> DOUBLE loc);
      ("else", fun loc -> ELSE loc);
      ("enum", fun loc -> ENUM loc);
71
      ("extern", fun loc -> EXTERN loc);
72
73
74
75
76
      ("float", fun loc -> FLOAT loc);
      ("for", fun loc -> FOR loc);
      ("goto", fun loc -> GOTO loc);
      ("if", fun loc -> IF loc);
      ("inline", fun loc -> INLINE loc);
David Monniaux's avatar
David Monniaux committed
77
      ("_Thread_local", fun loc -> THREAD_LOCAL loc);
78
      ("_Noreturn", fun loc -> NORETURN loc);
79
      ("int", fun loc -> INT loc);
80
81
      ("long", fun loc -> LONG loc);
      ("register", fun loc -> REGISTER loc);
82
83
84
      ("restrict", fun loc -> RESTRICT loc);
      ("return", fun loc -> RETURN loc);
      ("short", fun loc -> SHORT loc);
85
      ("signed", fun loc -> SIGNED loc);
86
87
      ("sizeof", fun loc -> SIZEOF loc);
      ("static", fun loc -> STATIC loc);
88
      ("struct", fun loc -> STRUCT loc);
89
      ("switch", fun loc -> SWITCH loc);
90
91
      ("typedef", fun loc -> TYPEDEF loc);
      ("union", fun loc -> UNION loc);
92
93
94
      ("unsigned", fun loc -> UNSIGNED loc);
      ("void", fun loc -> VOID loc);
      ("volatile", fun loc -> VOLATILE loc);
95
96
97
      ("while", fun loc -> WHILE loc)];
  if Configuration.system <> "diab" then
    (* We can ignore the __extension__ GCC keyword. *)
98
    ignored_keywords := SSet.add "__extension__" !ignored_keywords
99

100
101
let init_ctx = SSet.of_list (List.map fst CBuiltins.builtins.C.builtin_typedefs)

102
let types_context : SSet.t ref = ref init_ctx
103
104
105

let _ =
  (* See comments in pre_parser_aux.ml *)
106
107
108
  save_context := begin fun () ->
    let save = !types_context in
    fun () -> types_context := save
109
  end;
110

111
  declare_varname := begin fun id ->
112
    types_context := SSet.remove id !types_context
113
114
115
  end;

  declare_typename := begin fun id ->
116
    types_context := SSet.add id !types_context
117
  end
118

119
let init filename channel : Lexing.lexbuf =
120
  let lb = Lexing.from_channel channel in
121
  lb.lex_curr_p <- {lb.lex_curr_p with pos_fname = filename; pos_lnum = 1};
122
  lb
123

124
125
126
127
128
129
130
131
132
133
134
135
let currentLoc =
  let nextident = ref 0 in
  let getident () =
    nextident := !nextident + 1;
    !nextident
  in
  fun lb ->
    let p = Lexing.lexeme_start_p lb in
    Cabs.({ lineno   = p.Lexing.pos_lnum;
            filename = p.Lexing.pos_fname;
            byteno   = p.Lexing.pos_cnum;
            ident    = getident ();})
136

137
138
139
(* Error reporting *)

let fatal_error lb fmt =
140
  Diagnostics.fatal_error
141
    (lb.lex_curr_p.pos_fname,lb.lex_curr_p.pos_lnum) fmt
142
143

let error lb fmt =
144
  Diagnostics.error
145
    (lb.lex_curr_p.pos_fname,lb.lex_curr_p.pos_lnum) fmt
146
147

let warning lb fmt =
148
  Diagnostics.warning
149
      (lb.lex_curr_p.pos_fname,lb.lex_curr_p.pos_lnum) Diagnostics.Unnamed fmt
150
151
152
153
154
155
156
157
158
159
160
161
162

(* Simple character escapes *)

let convert_escape = function
  | 'a' -> 7L  (* bell *)
  | 'b' -> 8L  (* backspace  *)
  | 'e' -> 27L (* escape (GCC extension) *)
  | 'f' -> 12L (* form feed *)
  | 'n' -> 10L (* new line *)
  | 'r' -> 13L (* carriage return *)
  | 't' -> 9L  (* horizontal tab *)
  | 'v' -> 11L (* vertical tab *)
  | c   -> Int64.of_int (Char.code c)
163
}
164

165
166
167
168
169
170
171
172
(* Identifiers *)
let digit = ['0'-'9']
let hexadecimal_digit = ['0'-'9' 'A'-'F' 'a'-'f']
let nondigit = ['_' 'a'-'z' 'A'-'Z']

let hex_quad = hexadecimal_digit hexadecimal_digit
                 hexadecimal_digit hexadecimal_digit
let universal_character_name =
173
174
    "\\u" (hex_quad as n)
  | "\\U" (hex_quad hex_quad as n)
175
176
177
178
179
180
181
182
183

let identifier_nondigit =
    nondigit
(*| universal_character_name*)
  | '$'

let identifier = identifier_nondigit (identifier_nondigit|digit)*

(* Whitespaces *)
184
let whitespace_char_no_newline = [' ' '\t'  '\011' '\012' '\r']
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221

(* Integer constants *)
let nonzero_digit = ['1'-'9']
let decimal_constant = nonzero_digit digit*

let octal_digit = ['0'-'7']
let octal_constant = '0' octal_digit*

let hexadecimal_prefix = "0x" | "0X"
let hexadecimal_constant =
  hexadecimal_prefix hexadecimal_digit+

let unsigned_suffix = ['u' 'U']
let long_suffix = ['l' 'L']
let long_long_suffix = "ll" | "LL"
let integer_suffix =
    unsigned_suffix long_suffix?
  | unsigned_suffix long_long_suffix
  | long_suffix unsigned_suffix?
  | long_long_suffix unsigned_suffix?

let integer_constant =
    decimal_constant integer_suffix?
  | octal_constant integer_suffix?
  | hexadecimal_constant integer_suffix?

(* Floating constants *)
let sign = ['-' '+']
let digit_sequence = digit+
let floating_suffix = ['f' 'l' 'F' 'L'] as suffix

let fractional_constant =
    (digit_sequence as intpart)? '.' (digit_sequence as frac)
  | (digit_sequence as intpart) '.'
let exponent_part =
    'e' ((sign? digit_sequence) as expo)
  | 'E' ((sign? digit_sequence) as expo)
222
let decimal_floating_constant =
223
224
225
226
227
228
229
230
231
232
    fractional_constant exponent_part? floating_suffix?
  | (digit_sequence as intpart) exponent_part floating_suffix?

let hexadecimal_digit_sequence = hexadecimal_digit+
let hexadecimal_fractional_constant =
    (hexadecimal_digit_sequence as intpart)? '.' (hexadecimal_digit_sequence as frac)
  | (hexadecimal_digit_sequence as intpart) '.'
let binary_exponent_part =
    'p' ((sign? digit_sequence) as expo)
  | 'P' ((sign? digit_sequence) as expo)
233
let hexadecimal_floating_constant =
234
235
236
237
238
    hexadecimal_prefix hexadecimal_fractional_constant
        binary_exponent_part floating_suffix?
  | hexadecimal_prefix (hexadecimal_digit_sequence as intpart)
        binary_exponent_part floating_suffix?

239
240
241
242
243
(* Preprocessing numbers *)
let preprocessing_number =
  '.'? ['0'-'9']
  (['0'-'9' 'A'-'Z' 'a'-'z' '_' '.'] | ['e' 'E' 'p' 'P']['+' '-'])*

244
(* Character and string constants *)
245
let simple_escape_sequence =
246
  '\\' ( ['\''  '\"'  '?'  '\\'  'a'  'b'  'e'  'f'  'n'  'r'  't'  'v'] as c)
247
let octal_escape_sequence =
248
249
250
251
  '\\' ((octal_digit
         | octal_digit octal_digit
         | octal_digit octal_digit octal_digit) as n)
let hexadecimal_escape_sequence = "\\x" (hexadecimal_digit+ as n)
252
253
254
255
256
257
258
259
let escape_sequence =
    simple_escape_sequence
  | octal_escape_sequence
  | hexadecimal_escape_sequence
  | universal_character_name

rule initial = parse
  | '\n'                          { new_line lexbuf; initial_linebegin lexbuf }
260
261
262
  | whitespace_char_no_newline +  { initial lexbuf }
  | "/*"                          { multiline_comment lexbuf; initial lexbuf }
  | "//"                          { singleline_comment lexbuf; initial lexbuf }
263
264
265
266
267
268
269
270
271
272
  | integer_constant as s         { CONSTANT (Cabs.CONST_INT s, currentLoc lexbuf) }
  | decimal_floating_constant     { CONSTANT (Cabs.CONST_FLOAT
                                      {Cabs.isHex_FI = false;
                                       Cabs.integer_FI = intpart;
                                       Cabs.fraction_FI = frac;
                                       Cabs.exponent_FI = expo;
                                       Cabs.suffix_FI =
                                         match suffix with
                                         | None -> None
                                         | Some c -> Some (String.make 1 c) },
jjourdan's avatar
jjourdan committed
273
                                      currentLoc lexbuf) }
274
275
276
277
278
279
280
281
282
283
  | hexadecimal_floating_constant { CONSTANT (Cabs.CONST_FLOAT
                                      {Cabs.isHex_FI = true;
                                       Cabs.integer_FI = intpart;
                                       Cabs.fraction_FI = frac;
                                       Cabs.exponent_FI = Some expo;
                                       Cabs.suffix_FI =
                                         match suffix with
                                           | None -> None
                                           | Some c -> Some (String.make 1 c) },
                                      currentLoc lexbuf)}
284
285
  | preprocessing_number as s     { error lexbuf "invalid numerical constant '%s'@ These characters form a preprocessor number, but not a constant" s;
                                    CONSTANT (Cabs.CONST_INT "0", currentLoc lexbuf) }
286
  | "'"                           { let l = char_literal lexbuf.lex_start_p [] lexbuf in
287
288
                                    CONSTANT (Cabs.CONST_CHAR(false, l),
                                              currentLoc lexbuf) }
289
  | "L'"                          { let l = char_literal lexbuf.lex_start_p [] lexbuf in
290
291
                                    CONSTANT (Cabs.CONST_CHAR(true, l),
                                              currentLoc lexbuf) }
292
  | "\""                          { let l = string_literal lexbuf.lex_start_p [] lexbuf in
293
                                    STRING_LITERAL(false, l, currentLoc lexbuf) }
294
  | "L\""                         { let l = string_literal lexbuf.lex_start_p [] lexbuf in
295
                                    STRING_LITERAL(true, l, currentLoc lexbuf) }
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
  | "..."                         { ELLIPSIS(currentLoc lexbuf) }
  | "+="                          { ADD_ASSIGN(currentLoc lexbuf) }
  | "-="                          { SUB_ASSIGN(currentLoc lexbuf) }
  | "*="                          { MUL_ASSIGN(currentLoc lexbuf) }
  | "/="                          { DIV_ASSIGN(currentLoc lexbuf) }
  | "%="                          { MOD_ASSIGN(currentLoc lexbuf) }
  | "|="                          { OR_ASSIGN(currentLoc lexbuf) }
  | "&="                          { AND_ASSIGN(currentLoc lexbuf) }
  | "^="                          { XOR_ASSIGN(currentLoc lexbuf) }
  | "<<="                         { LEFT_ASSIGN(currentLoc lexbuf) }
  | ">>="                         { RIGHT_ASSIGN(currentLoc lexbuf) }
  | "<<"                          { LEFT(currentLoc lexbuf) }
  | ">>"                          { RIGHT(currentLoc lexbuf) }
  | "=="                          { EQEQ(currentLoc lexbuf) }
  | "!="                          { NEQ(currentLoc lexbuf) }
  | "<="                          { LEQ(currentLoc lexbuf) }
  | ">="                          { GEQ(currentLoc lexbuf) }
  | "="                           { EQ(currentLoc lexbuf) }
  | "<"                           { LT(currentLoc lexbuf) }
  | ">"                           { GT(currentLoc lexbuf) }
  | "++"                          { INC(currentLoc lexbuf) }
  | "--"                          { DEC(currentLoc lexbuf) }
  | "->"                          { PTR(currentLoc lexbuf) }
  | "+"                           { PLUS(currentLoc lexbuf) }
  | "-"                           { MINUS(currentLoc lexbuf) }
  | "*"                           { STAR(currentLoc lexbuf) }
  | "/"                           { SLASH(currentLoc lexbuf) }
  | "%"                           { PERCENT(currentLoc lexbuf) }
  | "!"                           { BANG(currentLoc lexbuf) }
  | "&&"                          { ANDAND(currentLoc lexbuf) }
  | "||"                          { BARBAR(currentLoc lexbuf) }
  | "&"                           { AND(currentLoc lexbuf) }
  | "|"                           { BAR(currentLoc lexbuf) }
  | "^"                           { HAT(currentLoc lexbuf) }
  | "?"                           { QUESTION(currentLoc lexbuf) }
  | ":"                           { COLON(currentLoc lexbuf) }
  | "~"                           { TILDE(currentLoc lexbuf) }
  | "{"|"<%"                      { LBRACE(currentLoc lexbuf) }
  | "}"|"%>"                      { RBRACE(currentLoc lexbuf) }
  | "["|"<:"                      { LBRACK(currentLoc lexbuf) }
  | "]"|":>"                      { RBRACK(currentLoc lexbuf) }
  | "("                           { LPAREN(currentLoc lexbuf) }
  | ")"                           { RPAREN(currentLoc lexbuf) }
  | ";"                           { SEMICOLON(currentLoc lexbuf) }
  | ","                           { COMMA(currentLoc lexbuf) }
  | "."                           { DOT(currentLoc lexbuf) }
  | identifier as id              {
343
    if SSet.mem id !ignored_keywords then
344
345
      initial lexbuf
    else
346
347
      try Hashtbl.find lexicon id (currentLoc lexbuf)
      with Not_found -> PRE_NAME id }
348
  | eof                           { EOF }
349
  | _ as c                        { fatal_error lexbuf "invalid symbol %C" c }
350
351
352
353
354
355
356

and initial_linebegin = parse
  | '\n'                          { new_line lexbuf; initial_linebegin lexbuf }
  | whitespace_char_no_newline    { initial_linebegin lexbuf }
  | '#'                           { hash lexbuf }
  | ""                            { initial lexbuf }

357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
and char = parse
  | universal_character_name
      { try
          Int64.of_string ("0x" ^ n)
        with Failure _ ->
          error lexbuf "overflow in universal character name";
          0L
      }
  | hexadecimal_escape_sequence
      { try
          Int64.of_string ("0x" ^ n)
        with Failure _ ->
          error lexbuf "overflow in hexadecimal escape sequence";
          0L
      }
  | octal_escape_sequence
      { Int64.of_string  ("0o" ^ n) }
  | simple_escape_sequence
      { convert_escape c }
  | '\\' (_ as c)
377
      { error lexbuf "incorrect escape sequence '\\%c'" c;
378
379
380
381
        Int64.of_int (Char.code c) }
  | _ as c
      { Int64.of_int (Char.code c) }

382
383
384
and char_literal startp accu = parse
  | '\''       { lexbuf.lex_start_p <- startp;
                 List.rev accu }
385
  | '\n' | eof { fatal_error lexbuf "missing terminating \"'\" character" }
386
  | ""         { let c = char lexbuf in char_literal startp (c :: accu) lexbuf }
387

388
389
390
and string_literal startp accu = parse
  | '\"'       { lexbuf.lex_start_p <- startp;
                 List.rev accu }
391
  | '\n' | eof { fatal_error lexbuf "missing terminating '\"' character" }
392
  | ""         { let c = char lexbuf in string_literal startp (c :: accu) lexbuf }
393

394
(* We assume gcc -E syntax but try to tolerate variations. *)
395
and hash = parse
396
  | whitespace_char_no_newline +
397
    (digit + as n)
398
399
400
    whitespace_char_no_newline *
    "\"" ([^ '\n' '\"']* as file) "\""
    [^ '\n']* '\n'
401
      { let n =
402
403
404
405
          try
            int_of_string n
          with Failure _ ->
            warning lexbuf "invalid line number"; lexbuf.lex_curr_p.pos_lnum
406
407
408
409
410
411
412
413
        in
        lexbuf.lex_curr_p <- {
          lexbuf.lex_curr_p with
            pos_fname = file;
            pos_lnum = n;
            pos_bol = lexbuf.lex_curr_p.pos_cnum
        };
        initial_linebegin lexbuf }
414
415
416
417
  | whitespace_char_no_newline *
    "pragma"
    whitespace_char_no_newline +
    ([^ '\n']* as s) '\n'
418
      { new_line lexbuf; PRAGMA (s, currentLoc lexbuf) }
419
  | [^ '\n']* '\n'
420
      { warning lexbuf "unrecognized '#' line";
421
        new_line lexbuf; initial_linebegin lexbuf }
422
  | [^ '\n']* eof
423
      { fatal_error lexbuf "unexpected end of file" }
424
  | _ as c
425
      { fatal_error lexbuf "invalid symbol %C" c }
426

427
428
429
(* Multi-line comment terminated by "*/" *)
and multiline_comment = parse
  | "*/"   { () }
430
  | eof    { error lexbuf "unterminated comment" }
431
432
433
434
435
436
  | '\n'   { new_line lexbuf; multiline_comment lexbuf }
  | _      { multiline_comment lexbuf }

(* Single-line comment terminated by a newline *)
and singleline_comment = parse
  | '\n'   { new_line lexbuf }
437
  | eof    { () }
438
439
  | _      { singleline_comment lexbuf }

440
{
441
  open Parser.MenhirLibParser.Inter
442

443
444
445
446
447
448
449
450
451
  (* This is the main entry point to the lexer. *)

  let lexer : lexbuf -> Pre_parser.token =
    fun lexbuf ->
      if lexbuf.lex_curr_p.pos_cnum = lexbuf.lex_curr_p.pos_bol then
        initial_linebegin lexbuf
      else
        initial lexbuf

452
453
454
  (* [lexer tokens buffer] is a new lexer, which wraps [lexer], and also: 1-
     records the token stream into the FIFO queue [tokens] and 2- records the
     start and end positions of the last two tokens in the two-place buffer
455
456
     [buffer] and 3- duplicates identifier tokens into PRE_NAME and
     VAR/TYPE_NAME. *)
457

458
  let lexer tokens buffer : lexbuf -> Pre_parser.token =
459
    let curr_id = ref None in
460
    types_context := init_ctx;
461
    fun lexbuf ->
462
463
464
465
      match !curr_id with
      | Some id ->
        curr_id := None;
        let loc = currentLoc lexbuf in
466
        let token =
467
468
          if SSet.mem id !types_context then Pre_parser.TYPEDEF_NAME (id, ref TypedefId, loc)
          else Pre_parser.VAR_NAME (id, ref VarId, loc)
469
        in
470
471
        Queue.push token tokens;
        token
472
      | None ->
473
474
        let token = lexer lexbuf in
        begin match token with
475
        | PRE_NAME id -> curr_id := Some id
476
        | _ -> Queue.push token tokens
477
        end;
478
479
480
481
        let startp = lexbuf.lex_start_p
        and endp = lexbuf.lex_curr_p in
        buffer := ErrorReports.update !buffer (startp, endp);
        token
482

483
484
485
  (* [invoke_pre_parser] is in charge of calling the pre_parser. It uses
     the incremental API, which allows us to do our own error handling. *)

486
  let invoke_pre_parser filename text lexer buffer =
487
    let lexbuf = Lexing.from_string text in
488
    lexbuf.lex_curr_p <- {lexbuf.lex_curr_p with pos_fname = filename; pos_lnum = 1};
489
    let module I = Pre_parser.MenhirInterpreter in
490
    let checkpoint = Pre_parser.Incremental.translation_unit_file lexbuf.lex_curr_p
491
492
493
    and supplier = I.lexer_lexbuf_to_supplier lexer lexbuf
    and succeed () = ()
    and fail checkpoint =
494
      Diagnostics.fatal_error_raw "%s" (ErrorReports.report text !buffer checkpoint)
495
496
497
    in
    I.loop_handle succeed fail supplier checkpoint

498
499
500
  (* [tokens_stream filename text] runs the pre_parser and produces a stream
     of (appropriately classified) tokens. *)

501
  let tokens_stream filename text : buffer =
502
    let tokens = Queue.create () in
503
504
    let buffer = ref ErrorReports.Zero in
    invoke_pre_parser filename text (lexer tokens buffer) buffer;
505
506
    let rec compute_buffer () =
      let loop t = Buf_cons (t, Lazy.from_fun compute_buffer) in
507
      match Queue.pop tokens with
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
      | Pre_parser.ADD_ASSIGN loc -> loop (Parser.ADD_ASSIGN loc)
      | Pre_parser.AND loc -> loop (Parser.AND loc)
      | Pre_parser.ANDAND loc -> loop (Parser.ANDAND loc)
      | Pre_parser.AND_ASSIGN loc -> loop (Parser.AND_ASSIGN loc)
      | Pre_parser.AUTO loc -> loop (Parser.AUTO loc)
      | Pre_parser.BANG loc -> loop (Parser.BANG loc)
      | Pre_parser.BAR loc -> loop (Parser.BAR loc)
      | Pre_parser.BARBAR loc -> loop (Parser.BARBAR loc)
      | Pre_parser.UNDERSCORE_BOOL loc -> loop (Parser.UNDERSCORE_BOOL loc)
      | Pre_parser.BREAK loc -> loop (Parser.BREAK loc)
      | Pre_parser.BUILTIN_VA_ARG loc -> loop (Parser.BUILTIN_VA_ARG loc)
      | Pre_parser.BUILTIN_OFFSETOF loc -> loop (Parser.BUILTIN_OFFSETOF loc)
      | Pre_parser.CASE loc -> loop (Parser.CASE loc)
      | Pre_parser.CHAR loc -> loop (Parser.CHAR loc)
      | Pre_parser.COLON loc -> loop (Parser.COLON loc)
      | Pre_parser.COMMA loc -> loop (Parser.COMMA loc)
      | Pre_parser.CONST loc -> loop (Parser.CONST loc)
      | Pre_parser.CONSTANT (cst, loc) -> loop (Parser.CONSTANT (cst, loc))
      | Pre_parser.CONTINUE loc -> loop (Parser.CONTINUE loc)
      | Pre_parser.DEC loc -> loop (Parser.DEC loc)
      | Pre_parser.DEFAULT loc -> loop (Parser.DEFAULT loc)
      | Pre_parser.DIV_ASSIGN loc -> loop (Parser.DIV_ASSIGN loc)
      | Pre_parser.DO loc -> loop (Parser.DO loc)
      | Pre_parser.DOT loc -> loop (Parser.DOT loc)
      | Pre_parser.DOUBLE loc -> loop (Parser.DOUBLE loc)
      | Pre_parser.ELLIPSIS loc -> loop (Parser.ELLIPSIS loc)
      | Pre_parser.ELSE loc -> loop (Parser.ELSE loc)
      | Pre_parser.ENUM loc -> loop (Parser.ENUM loc)
      | Pre_parser.EOF -> loop (Parser.EOF ())
      | Pre_parser.EQ loc -> loop (Parser.EQ loc)
      | Pre_parser.EQEQ loc -> loop (Parser.EQEQ loc)
      | Pre_parser.EXTERN loc -> loop (Parser.EXTERN loc)
      | Pre_parser.FLOAT loc -> loop (Parser.FLOAT loc)
      | Pre_parser.FOR loc -> loop (Parser.FOR loc)
      | Pre_parser.GEQ loc -> loop (Parser.GEQ loc)
      | Pre_parser.GOTO loc -> loop (Parser.GOTO loc)
      | Pre_parser.GT loc -> loop (Parser.GT loc)
      | Pre_parser.HAT loc -> loop (Parser.HAT loc)
      | Pre_parser.IF loc -> loop (Parser.IF_ loc)
      | Pre_parser.INC loc -> loop (Parser.INC loc)
      | Pre_parser.INLINE loc -> loop (Parser.INLINE loc)
David Monniaux's avatar
David Monniaux committed
549
      | Pre_parser.THREAD_LOCAL loc -> loop (Parser.THREAD_LOCAL loc)
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
      | Pre_parser.INT loc -> loop (Parser.INT loc)
      | Pre_parser.LBRACE loc -> loop (Parser.LBRACE loc)
      | Pre_parser.LBRACK loc -> loop (Parser.LBRACK loc)
      | Pre_parser.LEFT loc -> loop (Parser.LEFT loc)
      | Pre_parser.LEFT_ASSIGN loc -> loop (Parser.LEFT_ASSIGN loc)
      | Pre_parser.LEQ loc -> loop (Parser.LEQ loc)
      | Pre_parser.LONG loc -> loop (Parser.LONG loc)
      | Pre_parser.LPAREN loc -> loop (Parser.LPAREN loc)
      | Pre_parser.LT loc -> loop (Parser.LT loc)
      | Pre_parser.MINUS loc -> loop (Parser.MINUS loc)
      | Pre_parser.MOD_ASSIGN loc -> loop (Parser.MOD_ASSIGN loc)
      | Pre_parser.MUL_ASSIGN loc -> loop (Parser.MUL_ASSIGN loc)
      | Pre_parser.NEQ loc -> loop (Parser.NEQ loc)
      | Pre_parser.NORETURN loc -> loop (Parser.NORETURN loc)
      | Pre_parser.OR_ASSIGN loc -> loop (Parser.OR_ASSIGN loc)
      | Pre_parser.PACKED loc -> loop (Parser.PACKED loc)
      | Pre_parser.PERCENT loc -> loop (Parser.PERCENT loc)
      | Pre_parser.PLUS loc -> loop (Parser.PLUS loc)
      | Pre_parser.PTR loc -> loop (Parser.PTR loc)
      | Pre_parser.QUESTION loc -> loop (Parser.QUESTION loc)
      | Pre_parser.RBRACE loc -> loop (Parser.RBRACE loc)
      | Pre_parser.RBRACK loc -> loop (Parser.RBRACK loc)
      | Pre_parser.REGISTER loc -> loop (Parser.REGISTER loc)
      | Pre_parser.RESTRICT loc -> loop (Parser.RESTRICT loc)
      | Pre_parser.RETURN loc -> loop (Parser.RETURN loc)
      | Pre_parser.RIGHT loc -> loop (Parser.RIGHT loc)
      | Pre_parser.RIGHT_ASSIGN loc -> loop (Parser.RIGHT_ASSIGN loc)
      | Pre_parser.RPAREN loc -> loop (Parser.RPAREN loc)
      | Pre_parser.SEMICOLON loc -> loop (Parser.SEMICOLON loc)
      | Pre_parser.SHORT loc -> loop (Parser.SHORT loc)
      | Pre_parser.SIGNED loc -> loop (Parser.SIGNED loc)
      | Pre_parser.SIZEOF loc -> loop (Parser.SIZEOF loc)
      | Pre_parser.SLASH loc -> loop (Parser.SLASH loc)
      | Pre_parser.STAR loc -> loop (Parser.STAR loc)
      | Pre_parser.STATIC loc -> loop (Parser.STATIC loc)
Xavier Leroy's avatar
Xavier Leroy committed
585
      | Pre_parser.STATIC_ASSERT loc -> loop (Parser.STATIC_ASSERT loc)
586
      | Pre_parser.STRING_LITERAL (wide, str, loc) ->
587
          (* Merge consecutive string literals *)
588
          let rec doConcat wide str =
589
590
591
592
593
594
595
596
597
            match Queue.peek tokens with
            | Pre_parser.STRING_LITERAL (wide', str', loc) ->
               ignore (Queue.pop tokens);
               let (wide'', str'') = doConcat wide' str' in
               if str'' <> []
               then (wide || wide'', str @ str'')
               else (wide, str)
            | _ -> (wide, str)
            | exception Queue.Empty -> (wide, str)
598
          in
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
          let (wide', str') = doConcat wide str in
          loop (Parser.STRING_LITERAL ((wide', str'), loc))
      | Pre_parser.STRUCT loc -> loop (Parser.STRUCT loc)
      | Pre_parser.SUB_ASSIGN loc -> loop (Parser.SUB_ASSIGN loc)
      | Pre_parser.SWITCH loc -> loop (Parser.SWITCH loc)
      | Pre_parser.TILDE loc -> loop (Parser.TILDE loc)
      | Pre_parser.TYPEDEF loc -> loop (Parser.TYPEDEF loc)
      | Pre_parser.TYPEDEF_NAME (id, typ, loc)
      | Pre_parser.VAR_NAME (id, typ, loc) ->
          begin match !typ with
          | VarId -> loop (Parser.VAR_NAME (id, loc))
          | TypedefId -> loop (Parser.TYPEDEF_NAME (id, loc))
          | OtherId -> loop (Parser.OTHER_NAME (id, loc))
          end
      | Pre_parser.UNION loc -> loop (Parser.UNION loc)
      | Pre_parser.UNSIGNED loc -> loop (Parser.UNSIGNED loc)
      | Pre_parser.VOID loc -> loop (Parser.VOID loc)
      | Pre_parser.VOLATILE loc -> loop (Parser.VOLATILE loc)
      | Pre_parser.WHILE loc -> loop (Parser.WHILE loc)
      | Pre_parser.XOR_ASSIGN loc -> loop (Parser.XOR_ASSIGN loc)
      | Pre_parser.ALIGNAS loc -> loop (Parser.ALIGNAS loc)
      | Pre_parser.ALIGNOF loc -> loop (Parser.ALIGNOF loc)
      | Pre_parser.ATTRIBUTE loc -> loop (Parser.ATTRIBUTE loc)
      | Pre_parser.ASM loc -> loop (Parser.ASM loc)
      | Pre_parser.PRAGMA (s, loc) -> loop (Parser.PRAGMA (s, loc))
      | Pre_parser.PRE_NAME _ -> assert false
625
    in
626
    Lazy.from_fun compute_buffer
627
628

}