parsing_cocci/lexer_cocci.mll

   1 (*
   2  * Copyright 2010, INRIA, University of Copenhagen
   3  * Julia Lawall, Rene Rydhof Hansen, Gilles Muller, Nicolas Palix
   4  * Copyright 2005-2009, Ecole des Mines de Nantes, University of Copenhagen
   5  * Yoann Padioleau, Julia Lawall, Rene Rydhof Hansen, Henrik Stuart, Gilles Muller, Nicolas Palix
   6  * This file is part of Coccinelle.
   7  *
   8  * Coccinelle is free software: you can redistribute it and/or modify
   9  * it under the terms of the GNU General Public License as published by
  10  * the Free Software Foundation, according to version 2 of the License.
  11  *
  12  * Coccinelle is distributed in the hope that it will be useful,
  13  * but WITHOUT ANY WARRANTY; without even the implied warranty of
  14  * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  15  * GNU General Public License for more details.
  16  *
  17  * You should have received a copy of the GNU General Public License
  18  * along with Coccinelle.  If not, see <http://www.gnu.org/licenses/>.
  19  *
  20  * The authors reserve the right to distribute this or future versions of
  21  * Coccinelle under other licenses.
  22  *)
  23
  24
  25 {
  26 open Parser_cocci_menhir
  27 module D = Data
  28 module Ast = Ast_cocci
  29 module Ast0 = Ast0_cocci
  30 module P = Parse_aux
  31 exception Lexical of string
  32 let tok = Lexing.lexeme
  33
  34 let line = ref 1
  35 let logical_line = ref 0
  36
  37 (* ---------------------------------------------------------------------- *)
  38 (* control codes *)
  39
  40 (* Defined in data.ml
  41 type line_type = MINUS | OPTMINUS | UNIQUEMINUS | PLUS | CONTEXT | UNIQUE | OPT
  42 *)
  43
  44 let current_line_type = ref (D.CONTEXT,!line,!logical_line)
  45
  46 let prev_plus = ref false
  47 let line_start = ref 0 (* offset of the beginning of the line *)
  48 let get_current_line_type lexbuf =
  49   let (c,l,ll) = !current_line_type in
  50   let lex_start = Lexing.lexeme_start lexbuf in
  51   let preceeding_spaces =
  52     if !line_start < 0 then 0 else lex_start - !line_start in
  53   (*line_start := -1;*)
  54   prev_plus := (c = D.PLUS) or (c = D.PLUSPLUS);
  55   (c,l,ll,lex_start,preceeding_spaces,[],[],[])
  56 let current_line_started = ref false
  57 let col_zero = ref true
  58
  59 let reset_line lexbuf =
  60   line := !line + 1;
  61   current_line_type := (D.CONTEXT,!line,!logical_line);
  62   current_line_started := false;
  63   col_zero := true;
  64   line_start := Lexing.lexeme_start lexbuf + 1
  65
  66 let started_line = ref (-1)
  67
  68 let start_line seen_char =
  69   current_line_started := true;
  70   col_zero := false;
  71   (if seen_char && not(!line = !started_line)
  72   then
  73     begin
  74       started_line := !line;
  75       logical_line := !logical_line + 1
  76     end)
  77
  78 let pass_zero _ = col_zero := false
  79
  80 let lexerr s1 s2 = raise (Lexical (Printf.sprintf "%s%s" s1 s2))
  81
  82 let add_current_line_type x =
  83   match (x,!current_line_type) with
  84     (D.MINUS,(D.CONTEXT,ln,lln))  ->
  85       current_line_type := (D.MINUS,ln,lln)
  86   | (D.MINUS,(D.UNIQUE,ln,lln))   ->
  87       current_line_type := (D.UNIQUEMINUS,ln,lln)
  88   | (D.MINUS,(D.OPT,ln,lln))      ->
  89       current_line_type := (D.OPTMINUS,ln,lln)
  90   | (D.PLUS,(D.CONTEXT,ln,lln))   ->
  91       current_line_type := (D.PLUS,ln,lln)
  92   | (D.PLUSPLUS,(D.CONTEXT,ln,lln))   ->
  93       current_line_type := (D.PLUSPLUS,ln,lln)
  94   | (D.UNIQUE,(D.CONTEXT,ln,lln)) ->
  95       current_line_type := (D.UNIQUE,ln,lln)
  96   | (D.OPT,(D.CONTEXT,ln,lln))    ->
  97       current_line_type := (D.OPT,ln,lln)
  98   | _ -> lexerr "invalid control character combination" ""
  99
 100 let check_minus_context_linetype s =
 101   match !current_line_type with
 102     (D.PLUS,_,_) | (D.PLUSPLUS,_,_) -> lexerr "invalid in a + context: " s
 103   | _ -> ()
 104
 105 let check_context_linetype s =
 106   match !current_line_type with
 107     (D.CONTEXT,_,_) -> ()
 108   | _ -> lexerr "invalid in a nonempty context: " s
 109
 110 let check_plus_linetype s =
 111   match !current_line_type with
 112     (D.PLUS,_,_) | (D.PLUSPLUS,_,_) -> ()
 113   | _ -> lexerr "invalid in a non + context: " s
 114
 115 let check_arity_context_linetype s =
 116   match !current_line_type with
 117     (D.CONTEXT,_,_) | (D.PLUS,_,_) | (D.PLUSPLUS,_,_)
 118   | (D.UNIQUE,_,_) | (D.OPT,_,_) -> ()
 119   | _ -> lexerr "invalid in a nonempty context: " s
 120
 121 let check_comment s =
 122   if not !current_line_started
 123   then lexerr "+ expected at the beginning of the line" s
 124
 125 let process_include start finish str =
 126   (match !current_line_type with
 127     (D.PLUS,_,_) | (D.PLUSPLUS,_,_) ->
 128       (try
 129         let _ = Str.search_forward (Str.regexp "\\.\\.\\.") str start in
 130         lexerr "... not allowed in + include" ""
 131       with Not_found -> ())
 132   | _ -> ());
 133   String.sub str (start + 1) (finish - start - 1)
 134
 135 (* ---------------------------------------------------------------------- *)
 136 type pm = PATCH | MATCH | UNKNOWN
 137
 138 let pm = ref UNKNOWN
 139
 140 let patch_or_match = function
 141     PATCH ->
 142       if not !D.ignore_patch_or_match
 143       then
 144         (match !pm with
 145           MATCH ->
 146             lexerr "- or + not allowed in the first column for a match" ""
 147         | PATCH -> ()
 148         | UNKNOWN -> Flag.sgrep_mode2 := false; pm := PATCH)
 149   | MATCH ->
 150       if not !D.ignore_patch_or_match
 151       then
 152         (match !pm with
 153           PATCH -> lexerr "* not allowed in the first column for a patch" ""
 154         | MATCH -> ()
 155         | UNKNOWN -> Flag.sgrep_mode2 := true; pm := MATCH)
 156   | _ -> failwith "unexpected argument"
 157
 158 (* ---------------------------------------------------------------------- *)
 159 (* identifiers, including metavariables *)
 160
 161 let metavariables = (Hashtbl.create(100) : (string, D.clt -> token) Hashtbl.t)
 162
 163 let all_metavariables =
 164   (Hashtbl.create(100) : (string,(string * (D.clt -> token)) list) Hashtbl.t)
 165
 166 let type_names = (Hashtbl.create(100) : (string, D.clt -> token) Hashtbl.t)
 167
 168 let declarer_names = (Hashtbl.create(100) : (string, D.clt -> token) Hashtbl.t)
 169
 170 let iterator_names = (Hashtbl.create(100) : (string, D.clt -> token) Hashtbl.t)
 171
 172 let rule_names = (Hashtbl.create(100) : (string, unit) Hashtbl.t)
 173
 174 let check_var s linetype =
 175   let fail _ =
 176     if (!Data.in_prolog || !Data.in_rule_name) &&
 177       Str.string_match (Str.regexp "<.*>") s 0
 178     then TPathIsoFile s
 179     else
 180       try (Hashtbl.find metavariables s) linetype
 181       with Not_found ->
 182         (try (Hashtbl.find type_names s) linetype
 183         with Not_found ->
 184           (try (Hashtbl.find declarer_names s) linetype
 185           with Not_found ->
 186             (try (Hashtbl.find iterator_names s) linetype
 187             with Not_found -> TIdent (s,linetype)))) in
 188   if !Data.in_meta or !Data.in_rule_name
 189   then (try Hashtbl.find rule_names s; TRuleName s with Not_found -> fail())
 190   else fail()
 191
 192 let id_tokens lexbuf =
 193   let s = tok lexbuf in
 194   let linetype = get_current_line_type lexbuf in
 195   let in_rule_name = !Data.in_rule_name in
 196   let in_meta = !Data.in_meta && not !Data.saw_struct in
 197   let in_iso = !Data.in_iso in
 198   let in_prolog = !Data.in_prolog in
 199   match s with
 200     "metavariable" when in_meta -> check_arity_context_linetype s; TMetavariable
 201   | "identifier" when in_meta -> check_arity_context_linetype s; TIdentifier
 202   | "type" when in_meta ->       check_arity_context_linetype s; TType
 203   | "parameter" when in_meta ->  check_arity_context_linetype s; TParameter
 204   | "constant"  when in_meta ->  check_arity_context_linetype s; TConstant
 205   | "generated" when in_rule_name && not (!Flag.make_hrule = None) ->
 206       check_arity_context_linetype s; TGenerated
 207   | "expression" when in_meta || in_rule_name ->
 208       check_arity_context_linetype s; TExpression
 209   | "declaration" when in_meta || in_rule_name ->
 210       check_arity_context_linetype s; TDeclaration
 211   | "field" when in_meta || in_rule_name ->
 212       check_arity_context_linetype s; TField
 213   | "initialiser" when in_meta || in_rule_name ->
 214       check_arity_context_linetype s; TInitialiser
 215   | "initializer" when in_meta || in_rule_name ->
 216       check_arity_context_linetype s; TInitialiser
 217   | "idexpression" when in_meta ->
 218       check_arity_context_linetype s; TIdExpression
 219   | "statement" when in_meta ->  check_arity_context_linetype s; TStatement
 220   | "function"  when in_meta ->  check_arity_context_linetype s; TFunction
 221   | "local" when in_meta ->      check_arity_context_linetype s; TLocal
 222   | "list" when in_meta ->       check_arity_context_linetype s; Tlist
 223   | "fresh" when in_meta ->      check_arity_context_linetype s; TFresh
 224   | "typedef" when in_meta ->    check_arity_context_linetype s; TTypedef
 225   | "declarer" when in_meta ->   check_arity_context_linetype s; TDeclarer
 226   | "iterator" when in_meta ->   check_arity_context_linetype s; TIterator
 227   | "name" when in_meta ->       check_arity_context_linetype s; TName
 228   | "position" when in_meta ->   check_arity_context_linetype s; TPosition
 229   | "any" when in_meta ->        check_arity_context_linetype s; TPosAny
 230   | "pure" when in_meta && in_iso ->
 231       check_arity_context_linetype s; TPure
 232   | "context" when in_meta && in_iso ->
 233       check_arity_context_linetype s; TContext
 234   | "error" when in_meta ->      check_arity_context_linetype s; TError
 235   | "words" when in_meta ->      check_context_linetype s; TWords
 236
 237   | "using" when in_rule_name || in_prolog ->  check_context_linetype s; TUsing
 238   | "virtual" when in_prolog or in_rule_name or in_meta ->
 239       (* don't want to allow virtual as a rule name *)
 240       check_context_linetype s; TVirtual
 241   | "disable" when in_rule_name ->  check_context_linetype s; TDisable
 242   | "extends" when in_rule_name -> check_context_linetype s; TExtends
 243   | "depends" when in_rule_name -> check_context_linetype s; TDepends
 244   | "on" when in_rule_name      -> check_context_linetype s; TOn
 245   | "ever" when in_rule_name    -> check_context_linetype s; TEver
 246   | "never" when in_rule_name   -> check_context_linetype s; TNever
 247   (* exists and forall for when are reparsed in parse_cocci.ml *)
 248   | "exists" when in_rule_name  -> check_context_linetype s; TExists
 249   | "forall" when in_rule_name  -> check_context_linetype s; TForall
 250   | "script" when in_rule_name  -> check_context_linetype s; TScript
 251   | "initialize" when in_rule_name -> check_context_linetype s; TInitialize
 252   | "finalize" when in_rule_name   -> check_context_linetype s; TFinalize
 253
 254   | "char" ->       Tchar     linetype
 255   | "short" ->      Tshort    linetype
 256   | "int" ->        Tint      linetype
 257   | "double" ->     Tdouble   linetype
 258   | "float" ->      Tfloat    linetype
 259   | "long" ->       Tlong     linetype
 260   | "void" ->       Tvoid     linetype
 261   | "size_t" ->     Tsize_t   linetype
 262   | "ssize_t" ->    Tssize_t  linetype
 263   | "ptrdiff_t" ->  Tptrdiff_t linetype
 264   (* in_meta is only for the first keyword; drop it now to allow any type
 265      name *)
 266   | "struct" ->     Data.saw_struct := true; Tstruct   linetype
 267   | "union" ->      Data.saw_struct := true; Tunion    linetype
 268   | "enum" ->       Data.saw_struct := true; Tenum     linetype
 269   | "unsigned" ->   Tunsigned linetype
 270   | "signed" ->     Tsigned   linetype
 271
 272   | "auto"  ->      Tauto     linetype
 273   | "register" ->   Tregister linetype
 274   | "extern" ->     Textern   linetype
 275   | "static" ->     Tstatic   linetype
 276   | "inline" ->     Tinline   linetype
 277   | "typedef" ->    Ttypedef  linetype
 278
 279   | "const" ->      Tconst    linetype
 280   | "volatile" ->   Tvolatile linetype
 281
 282   | "if" ->         TIf       linetype
 283   | "else" ->       TElse     linetype
 284   | "while" ->      TWhile    linetype
 285   | "do" ->         TDo       linetype
 286   | "for" ->        TFor      linetype
 287   | "switch" ->     TSwitch   linetype
 288   | "case" ->       TCase     linetype
 289   | "default" ->    TDefault  linetype
 290   | "return" ->     TReturn   linetype
 291   | "break" ->      TBreak    linetype
 292   | "continue" ->   TContinue linetype
 293   | "goto" ->       TGoto     linetype
 294
 295   | "sizeof" ->     TSizeof   linetype
 296
 297   | "Expression"       when !Data.in_iso -> TIsoExpression
 298   | "ArgExpression"    when !Data.in_iso -> TIsoArgExpression
 299   | "TestExpression"   when !Data.in_iso -> TIsoTestExpression
 300   | "ToTestExpression" when !Data.in_iso -> TIsoToTestExpression
 301   | "Statement"        when !Data.in_iso -> TIsoStatement
 302   | "Declaration"      when !Data.in_iso -> TIsoDeclaration
 303   | "Type"             when !Data.in_iso -> TIsoType
 304   | "TopLevel"         when !Data.in_iso -> TIsoTopLevel
 305
 306   | "_" when !Data.in_meta -> TUnderscore
 307
 308   | s -> check_var s linetype
 309
 310 let mkassign op lexbuf =
 311   TAssign (Ast.OpAssign op, (get_current_line_type lexbuf))
 312
 313 let init _ =
 314   line := 1;
 315   logical_line := 0;
 316   prev_plus := false;
 317   line_start := 0;
 318   current_line_started := false;
 319   current_line_type := (D.CONTEXT,0,0);
 320   col_zero := true;
 321   pm := UNKNOWN;
 322   Data.in_rule_name := false;
 323   Data.in_meta := false;
 324   Data.in_prolog := false;
 325   Data.saw_struct := false;
 326   Data.inheritable_positions := [];
 327   Hashtbl.clear all_metavariables;
 328   Hashtbl.clear Data.all_metadecls;
 329   Hashtbl.clear metavariables;
 330   Hashtbl.clear type_names;
 331   Hashtbl.clear rule_names;
 332   Hashtbl.clear iterator_names;
 333   Hashtbl.clear declarer_names;
 334   let get_name (_,x) = x in
 335   Data.add_meta_meta :=
 336     (fun name pure ->
 337       let fn clt = TMeta(name,pure,clt) in
 338       Hashtbl.replace metavariables (get_name name) fn);
 339   Data.add_id_meta :=
 340     (fun name constraints pure ->
 341       let fn clt = TMetaId(name,constraints,Ast.NoVal,pure,clt) in
 342       Hashtbl.replace metavariables (get_name name) fn);
 343   Data.add_virt_id_meta_found :=
 344     (fun name vl ->
 345       let fn clt = TIdent(vl,clt) in
 346       Hashtbl.replace metavariables name fn);
 347   Data.add_virt_id_meta_not_found :=
 348     (fun name pure ->
 349       let fn clt = TMetaId(name,Ast.IdNoConstraint,Ast.NoVal,pure,clt) in
 350       Hashtbl.replace metavariables (get_name name) fn);
 351   Data.add_fresh_id_meta :=
 352     (fun name seed ->
 353       let fn clt = TMetaId(name,Ast.IdNoConstraint,seed,Ast0.Impure,clt) in
 354       Hashtbl.replace metavariables (get_name name) fn);
 355   Data.add_type_meta :=
 356     (fun name pure ->
 357       let fn clt = TMetaType(name,pure,clt) in
 358       Hashtbl.replace metavariables (get_name name) fn);
 359   Data.add_init_meta :=
 360     (fun name pure ->
 361       let fn clt = TMetaInit(name,pure,clt) in
 362       Hashtbl.replace metavariables (get_name name) fn);
 363   Data.add_initlist_meta :=
 364     (function name -> function lenname -> function pure ->
 365       let fn clt = TMetaInitList(name,lenname,pure,clt) in
 366       Hashtbl.replace metavariables (get_name name) fn);
 367   Data.add_param_meta :=
 368     (function name -> function pure ->
 369       let fn clt = TMetaParam(name,pure,clt) in
 370       Hashtbl.replace metavariables (get_name name) fn);
 371   Data.add_paramlist_meta :=
 372     (function name -> function lenname -> function pure ->
 373       let fn clt = TMetaParamList(name,lenname,pure,clt) in
 374       Hashtbl.replace metavariables (get_name name) fn);
 375   Data.add_const_meta :=
 376     (fun tyopt name constraints pure ->
 377       let fn clt = TMetaConst(name,constraints,pure,tyopt,clt) in
 378       Hashtbl.replace metavariables (get_name name) fn);
 379   Data.add_err_meta :=
 380     (fun name constraints pure ->
 381       let fn clt = TMetaErr(name,constraints,pure,clt) in
 382       Hashtbl.replace metavariables (get_name name) fn);
 383   Data.add_exp_meta :=
 384     (fun tyopt name constraints pure ->
 385       let fn clt = TMetaExp(name,constraints,pure,tyopt,clt) in
 386       Hashtbl.replace metavariables (get_name name) fn);
 387   Data.add_idexp_meta :=
 388     (fun tyopt name constraints pure ->
 389       let fn clt = TMetaIdExp(name,constraints,pure,tyopt,clt) in
 390       Hashtbl.replace metavariables (get_name name) fn);
 391   Data.add_local_idexp_meta :=
 392     (fun tyopt name constraints pure ->
 393       let fn clt = TMetaLocalIdExp(name,constraints,pure,tyopt,clt) in
 394       Hashtbl.replace metavariables (get_name name) fn);
 395   Data.add_explist_meta :=
 396     (function name -> function lenname -> function pure ->
 397       let fn clt = TMetaExpList(name,lenname,pure,clt) in
 398       Hashtbl.replace metavariables (get_name name) fn);
 399   Data.add_decl_meta :=
 400     (function name -> function pure ->
 401       let fn clt = TMetaDecl(name,pure,clt) in
 402       Hashtbl.replace metavariables (get_name name) fn);
 403   Data.add_field_meta :=
 404     (function name -> function pure ->
 405       let fn clt = TMetaField(name,pure,clt) in
 406       Hashtbl.replace metavariables (get_name name) fn);
 407   Data.add_field_list_meta :=
 408     (function name -> function lenname -> function pure ->
 409       let fn clt = TMetaFieldList(name,lenname,pure,clt) in
 410       Hashtbl.replace metavariables (get_name name) fn);
 411   Data.add_stm_meta :=
 412     (function name -> function pure ->
 413       let fn clt = TMetaStm(name,pure,clt) in
 414       Hashtbl.replace metavariables (get_name name) fn);
 415   Data.add_stmlist_meta :=
 416     (function name -> function pure ->
 417       let fn clt = TMetaStmList(name,pure,clt) in
 418       Hashtbl.replace metavariables (get_name name) fn);
 419   Data.add_func_meta :=
 420     (fun name constraints pure ->
 421       let fn clt = TMetaFunc(name,constraints,pure,clt) in
 422       Hashtbl.replace metavariables (get_name name) fn);
 423   Data.add_local_func_meta :=
 424     (fun name constraints pure ->
 425       let fn clt = TMetaLocalFunc(name,constraints,pure,clt) in
 426       Hashtbl.replace metavariables (get_name name) fn);
 427   Data.add_iterator_meta :=
 428     (fun name constraints pure ->
 429       let fn clt = TMetaIterator(name,constraints,pure,clt) in
 430       Hashtbl.replace metavariables (get_name name) fn);
 431   Data.add_declarer_meta :=
 432     (fun name constraints pure ->
 433       let fn clt = TMetaDeclarer(name,constraints,pure,clt) in
 434       Hashtbl.replace metavariables (get_name name) fn);
 435   Data.add_pos_meta :=
 436     (fun name constraints any ->
 437       let fn ((d,ln,_,_,_,_,_,_) as clt) =
 438         (if d = Data.PLUS
 439         then
 440           failwith
 441             (Printf.sprintf "%d: positions only allowed in minus code" ln));
 442         TMetaPos(name,constraints,any,clt) in
 443       Hashtbl.replace metavariables (get_name name) fn);
 444   Data.add_type_name :=
 445     (function name ->
 446       let fn clt = TTypeId(name,clt) in
 447       Hashtbl.replace type_names name fn);
 448   Data.add_declarer_name :=
 449     (function name ->
 450       let fn clt = TDeclarerId(name,clt) in
 451       Hashtbl.replace declarer_names name fn);
 452   Data.add_iterator_name :=
 453     (function name ->
 454       let fn clt = TIteratorId(name,clt) in
 455       Hashtbl.replace iterator_names name fn);
 456   Data.init_rule := (function _ -> Hashtbl.clear metavariables);
 457   Data.install_bindings :=
 458     (function parent ->
 459       List.iter (function (name,fn) -> Hashtbl.add metavariables name fn)
 460         (Hashtbl.find all_metavariables parent))
 461
 462 (* the following is needed to properly tokenize include files.  Because an
 463 include file is included after seeing a @, so current_line_started is true.
 464 Current_line_started is not important for parsing the name of a rule, so we
 465 don't have to reset this value to true after parsing an included file. *)
 466 let include_init _ =
 467   current_line_started := false
 468
 469 let drop_spaces s =
 470   let len = String.length s in
 471   let rec loop n =
 472     if n = len
 473     then n
 474     else
 475       if List.mem (String.get s n) [' ';'\t']
 476       then loop (n+1)
 477       else n in
 478   let start = loop 0 in
 479   String.sub s start (len - start)
 480 }
 481
 482 (* ---------------------------------------------------------------------- *)
 483 (* tokens *)
 484
 485 let letter = ['A'-'Z' 'a'-'z' '_']
 486 let digit  = ['0'-'9']
 487
 488 let dec = ['0'-'9']
 489 let oct = ['0'-'7']
 490 let hex = ['0'-'9' 'a'-'f' 'A'-'F']
 491
 492 let decimal = ('0' | (['1'-'9'] dec*))
 493 let octal   = ['0']        oct+
 494 let hexa    = ("0x" |"0X") hex+
 495
 496 let pent   = dec+
 497 let pfract = dec+
 498 let sign = ['-' '+']
 499 let exp  = ['e''E'] sign? dec+
 500 let real = pent exp | ((pent? '.' pfract | pent '.' pfract? ) exp?)
 501
 502
 503 rule token = parse
 504   | [' ' '\t']* ['\n' '\r' '\011' '\012']
 505     { let cls = !current_line_started in
 506
 507       if not cls
 508       then
 509         begin
 510           match !current_line_type with
 511             (D.PLUS,_,_) | (D.PLUSPLUS,_,_) ->
 512               let info = get_current_line_type lexbuf in
 513               reset_line lexbuf;
 514               TPragma (Ast.Noindent "", info)
 515           | _ -> reset_line lexbuf; token lexbuf
 516         end
 517       else (reset_line lexbuf; token lexbuf) }
 518
 519   | [' ' '\t'  ]+  { start_line false; token lexbuf }
 520
 521   | [' ' '\t'  ]* (("//" [^ '\n']*) as after) {
 522     match !current_line_type with
 523       (D.PLUS,_,_) | (D.PLUSPLUS,_,_) ->
 524         let str =
 525           if !current_line_started
 526           then (tok lexbuf)
 527           else after in
 528         start_line true;
 529         TPragma (Ast.Indent str, get_current_line_type lexbuf)
 530     | _ -> start_line false; token lexbuf }
 531
 532   | "__attribute__" [' ' '\t']* "((" _* "))"
 533    { match !current_line_type with
 534       (D.PLUS,_,_) | (D.PLUSPLUS,_,_) ->
 535         start_line true;
 536         TPragma (Ast.Space (tok lexbuf), get_current_line_type lexbuf)
 537     | _ -> failwith "attributes only allowedin + code" }
 538
 539   | "@@" { start_line true; TArobArob }
 540   | "@"  { pass_zero();
 541            if !Data.in_rule_name or not !current_line_started
 542            then (start_line true; TArob)
 543            else (check_minus_context_linetype "@"; TPArob) }
 544
 545   | "=~"  { start_line true; TTildeEq (get_current_line_type lexbuf) }
 546   | "!=~" { start_line true; TTildeExclEq (get_current_line_type lexbuf) }
 547   | "WHEN" | "when"
 548       { start_line true; check_minus_context_linetype (tok lexbuf);
 549         TWhen (get_current_line_type lexbuf) }
 550
 551   | "..."
 552       { start_line true; check_minus_context_linetype (tok lexbuf);
 553         TEllipsis (get_current_line_type lexbuf) }
 554 (*
 555   | "ooo"
 556       { start_line true; check_minus_context_linetype (tok lexbuf);
 557         TCircles (get_current_line_type lexbuf) }
 558
 559   | "***"
 560       { start_line true; check_minus_context_linetype (tok lexbuf);
 561         TStars (get_current_line_type lexbuf) }
 562 *)
 563   | "<..." { start_line true; check_context_linetype (tok lexbuf);
 564              TOEllipsis (get_current_line_type lexbuf) }
 565   | "...>" { start_line true; check_context_linetype (tok lexbuf);
 566              TCEllipsis (get_current_line_type lexbuf) }
 567   | "<+..." { start_line true; check_minus_context_linetype (tok lexbuf);
 568              TPOEllipsis (get_current_line_type lexbuf) }
 569   | "...+>" { start_line true; check_minus_context_linetype (tok lexbuf);
 570              TPCEllipsis (get_current_line_type lexbuf) }
 571 (*
 572   | "<ooo" { start_line true; check_context_linetype (tok lexbuf);
 573              TOCircles (get_current_line_type lexbuf) }
 574   | "ooo>" { start_line true; check_context_linetype (tok lexbuf);
 575              TCCircles (get_current_line_type lexbuf) }
 576
 577   | "<***" { start_line true; check_context_linetype (tok lexbuf);
 578              TOStars (get_current_line_type lexbuf) }
 579   | "***>" { start_line true; check_context_linetype (tok lexbuf);
 580              TCStars (get_current_line_type lexbuf) }
 581 *)
 582   | "-" { pass_zero();
 583           if !current_line_started
 584           then (start_line true; TMinus (get_current_line_type lexbuf))
 585           else (patch_or_match PATCH;
 586                 add_current_line_type D.MINUS; token lexbuf) }
 587   | "+" { pass_zero();
 588           if !current_line_started
 589           then (start_line true; TPlus (get_current_line_type lexbuf))
 590           else if !Data.in_meta
 591           then TPlus0
 592           else (patch_or_match PATCH;
 593                 add_current_line_type D.PLUS; token lexbuf) }
 594   | "?" { pass_zero();
 595           if !current_line_started
 596           then (start_line true; TWhy (get_current_line_type lexbuf))
 597           else if !Data.in_meta
 598           then TWhy0
 599           else (add_current_line_type D.OPT; token lexbuf) }
 600   | "!" { pass_zero();
 601           if !current_line_started
 602           then (start_line true; TBang (get_current_line_type lexbuf))
 603           else if !Data.in_meta
 604           then TBang0
 605           else (add_current_line_type D.UNIQUE; token lexbuf) }
 606   | "(" { if !Data.in_meta or not !col_zero
 607           then (start_line true; TOPar (get_current_line_type lexbuf))
 608           else
 609             (start_line true; check_context_linetype (tok lexbuf);
 610              TOPar0 (get_current_line_type lexbuf))}
 611   | "\\(" { start_line true; TOPar0 (get_current_line_type lexbuf) }
 612   | "|" { if not (!col_zero)
 613           then (start_line true; TOr(get_current_line_type lexbuf))
 614           else (start_line true;
 615                 check_context_linetype (tok lexbuf);
 616                 TMid0 (get_current_line_type lexbuf))}
 617   | "\\|" { start_line true; TMid0 (get_current_line_type lexbuf) }
 618   | ")" { if not !col_zero
 619           then (start_line true; TCPar (get_current_line_type lexbuf))
 620           else
 621             (start_line true; check_context_linetype (tok lexbuf);
 622              TCPar0 (get_current_line_type lexbuf))}
 623   | "\\)" { start_line true; TCPar0 (get_current_line_type lexbuf) }
 624
 625   | '[' { start_line true; TOCro (get_current_line_type lexbuf)   }
 626   | ']' { start_line true; TCCro (get_current_line_type lexbuf)   }
 627   | '{' { start_line true; TOBrace (get_current_line_type lexbuf) }
 628   | '}' { start_line true; TCBrace (get_current_line_type lexbuf) }
 629
 630   | "->"           { start_line true; TPtrOp (get_current_line_type lexbuf)  }
 631   | '.'            { start_line true; TDot (get_current_line_type lexbuf)    }
 632   | ','            { start_line true; TComma (get_current_line_type lexbuf)  }
 633   | ";"            { start_line true;
 634                      if !Data.in_meta
 635                      then TMPtVirg (* works better with tokens_all *)
 636                      else TPtVirg (get_current_line_type lexbuf) }
 637
 638
 639   | '*'            { pass_zero();
 640                      if !current_line_started
 641                      then
 642                        (start_line true; TMul (get_current_line_type lexbuf))
 643                      else
 644                        (patch_or_match MATCH;
 645                         add_current_line_type D.MINUS; token lexbuf) }
 646   | '/'            { start_line true;
 647                      TDmOp (Ast.Div,get_current_line_type lexbuf) }
 648   | '%'            { start_line true;
 649                      TDmOp (Ast.Mod,get_current_line_type lexbuf) }
 650   | '~'            { start_line true;  TTilde (get_current_line_type lexbuf) }
 651
 652   | "++"           { pass_zero();
 653                      if !current_line_started
 654                      then
 655                        (start_line true; TInc (get_current_line_type lexbuf))
 656                      else (patch_or_match PATCH;
 657                            add_current_line_type D.PLUSPLUS; token lexbuf) }
 658   | "--"           { start_line true;  TDec (get_current_line_type lexbuf) }
 659
 660   | "="            { start_line true; TEq (get_current_line_type lexbuf) }
 661
 662   | "-="           { start_line true; mkassign Ast.Minus lexbuf }
 663   | "+="           { start_line true; mkassign Ast.Plus lexbuf }
 664
 665   | "*="           { start_line true; mkassign Ast.Mul lexbuf }
 666   | "/="           { start_line true; mkassign Ast.Div lexbuf }
 667   | "%="           { start_line true; mkassign Ast.Mod lexbuf }
 668
 669   | "&="           { start_line true; mkassign Ast.And lexbuf }
 670   | "|="           { start_line true; mkassign Ast.Or lexbuf }
 671   | "^="           { start_line true; mkassign Ast.Xor lexbuf }
 672
 673   | "<<="          { start_line true; mkassign Ast.DecLeft lexbuf }
 674   | ">>="          { start_line true; mkassign Ast.DecRight lexbuf }
 675
 676   | ":"            { start_line true; TDotDot (get_current_line_type lexbuf) }
 677
 678   | "=="           { start_line true; TEqEq    (get_current_line_type lexbuf) }
 679   | "!="           { start_line true; TNotEq   (get_current_line_type lexbuf) }
 680   | ">="           { start_line true;
 681                      TLogOp(Ast.SupEq,get_current_line_type lexbuf) }
 682   | "<="           { start_line true;
 683                      if !Data.in_meta
 684                      then TSub(get_current_line_type lexbuf)
 685                      else TLogOp(Ast.InfEq,get_current_line_type lexbuf) }
 686   | "<"            { start_line true;
 687                      TLogOp(Ast.Inf,get_current_line_type lexbuf) }
 688   | ">"            { start_line true;
 689                      TLogOp(Ast.Sup,get_current_line_type lexbuf) }
 690
 691   | "&&"           { start_line true; TAndLog (get_current_line_type lexbuf) }
 692   | "||"           { start_line true; TOrLog  (get_current_line_type lexbuf) }
 693
 694   | ">>"           { start_line true;
 695                      TShROp(Ast.DecRight,get_current_line_type lexbuf) }
 696   | "<<"           { start_line true;
 697                      TShLOp(Ast.DecLeft,get_current_line_type lexbuf) }
 698
 699   | "&"            { start_line true; TAnd    (get_current_line_type lexbuf) }
 700   | "^"            { start_line true; TXor(get_current_line_type lexbuf) }
 701
 702   | "##"            { start_line true; TCppConcatOp }
 703   | (( ("#" [' ' '\t']*  "undef" [' ' '\t']+)) as def)
 704     ( (letter (letter |digit)*) as ident)
 705       { start_line true;
 706         let (arity,line,lline,offset,col,strbef,straft,pos) as lt =
 707           get_current_line_type lexbuf in
 708         let off = String.length def in
 709         (* -1 in the code below because the ident is not at the line start *)
 710         TUndef
 711           (lt,
 712            check_var ident
 713              (arity,line,lline,offset+off,col+off,[],[],[])) }
 714   | (( ("#" [' ' '\t']*  "define" [' ' '\t']+)) as def)
 715     ( (letter (letter |digit)*) as ident)
 716       { start_line true;
 717         let (arity,line,lline,offset,col,strbef,straft,pos) as lt =
 718           get_current_line_type lexbuf in
 719         let off = String.length def in
 720         (* -1 in the code below because the ident is not at the line start *)
 721         TDefine
 722           (lt,
 723            check_var ident
 724              (arity,line,lline,offset+off,col+off,[],[],[])) }
 725   | (( ("#" [' ' '\t']*  "define" [' ' '\t']+)) as def)
 726     ( (letter (letter | digit)*) as ident)
 727     '('
 728       { start_line true;
 729         let (arity,line,lline,offset,col,strbef,straft,pos) as lt =
 730           get_current_line_type lexbuf in
 731         let off = String.length def in
 732         TDefineParam
 733         (lt,
 734          check_var ident
 735            (* why pos here but not above? *)
 736            (arity,line,lline,offset+off,col+off,strbef,straft,pos),
 737          offset + off + (String.length ident),
 738          col + off + (String.length ident)) }
 739   | "#" [' ' '\t']* "include" [' ' '\t']* '"' [^ '"']+ '"'
 740       { TIncludeL
 741           (let str = tok lexbuf in
 742           let start = String.index str '"' in
 743           let finish = String.rindex str '"' in
 744           start_line true;
 745           (process_include start finish str,get_current_line_type lexbuf)) }
 746   | "#" [' ' '\t']* "include" [' ' '\t']* '<' [^ '>']+ '>'
 747       { TIncludeNL
 748           (let str = tok lexbuf in
 749           let start = String.index str '<' in
 750           let finish = String.rindex str '>' in
 751           start_line true;
 752           (process_include start finish str,get_current_line_type lexbuf)) }
 753   | "#" [' ' '\t']* "if" [^'\n']*
 754   | "#" [' ' '\t']* "ifdef" [^'\n']*
 755   | "#" [' ' '\t']* "ifndef" [^'\n']*
 756   | "#" [' ' '\t']* "else" [^'\n']*
 757   | "#" [' ' '\t']* "elif" [^'\n']*
 758   | "#" [' ' '\t']* "endif" [^'\n']*
 759   | "#" [' ' '\t']* "error" [^'\n']*
 760       { start_line true; check_plus_linetype (tok lexbuf);
 761         TPragma (Ast.Noindent(tok lexbuf), get_current_line_type lexbuf) }
 762   | "/*"
 763       {
 764        match !current_line_type with
 765         (D.PLUS,_,_) | (D.PLUSPLUS,_,_) ->
 766         start_line true;
 767         (* second argument to TPragma is not quite right, because
 768            it represents only the first token of the comment, but that
 769            should be good enough *)
 770         TPragma (Ast.Indent("/*"^(comment check_comment lexbuf)),
 771                  get_current_line_type lexbuf)
 772       | _ -> let _ = comment (fun _ -> ()) lexbuf in token lexbuf }
 773   | "---" [^'\n']*
 774       { (if !current_line_started
 775       then lexerr "--- must be at the beginning of the line" "");
 776         start_line true;
 777         TMinusFile
 778           (let str = tok lexbuf in
 779           (drop_spaces(String.sub str 3 (String.length str - 3)),
 780            (get_current_line_type lexbuf))) }
 781   | "+++" [^'\n']*
 782       { (if !current_line_started
 783       then lexerr "+++ must be at the beginning of the line" "");
 784         start_line true;
 785         TPlusFile
 786           (let str = tok lexbuf in
 787           (drop_spaces(String.sub str 3 (String.length str - 3)),
 788            (get_current_line_type lexbuf))) }
 789
 790   | letter (letter | digit)*
 791       { start_line true; id_tokens lexbuf }
 792
 793   | "'" { start_line true;
 794           TChar(char lexbuf,get_current_line_type lexbuf) }
 795   | '"' { start_line true;
 796           TString(string lexbuf,(get_current_line_type lexbuf)) }
 797   | (real as x)    { start_line true;
 798                      TFloat(x,(get_current_line_type lexbuf)) }
 799   | ((( decimal | hexa | octal)
 800       ( ['u' 'U']
 801       | ['l' 'L']
 802       | (['l' 'L'] ['u' 'U'])
 803       | (['u' 'U'] ['l' 'L'])
 804       | (['u' 'U'] ['l' 'L'] ['l' 'L'])
 805       | (['l' 'L'] ['l' 'L'])
 806       )?
 807     ) as x) { start_line true; TInt(x,(get_current_line_type lexbuf)) }
 808
 809   | "<=>"          { TIso }
 810   | "=>"           { TRightIso }
 811
 812   | eof            { EOF }
 813
 814   | _ { lexerr "unrecognised symbol, in token rule: " (tok lexbuf) }
 815
 816
 817 and char = parse
 818   | (_ as x)                           { String.make 1 x ^ restchars lexbuf }
 819   (* todo?: as for octal, do exception  beyond radix exception ? *)
 820   | (("\\" (oct | oct oct | oct oct oct)) as x     ) { x ^ restchars lexbuf }
 821   (* this rule must be after the one with octal, lex try first longest
 822    * and when \7  we want an octal, not an exn.
 823    *)
 824   | (("\\x" ((hex | hex hex))) as x           )      { x ^ restchars lexbuf }
 825   | (("\\" (_ as v))           as x           )
 826         {
 827           (match v with (* Machine specific ? *)
 828           | 'n' -> ()  | 't' -> ()   | 'v' -> ()  | 'b' -> () | 'r' -> ()
 829           | 'f' -> () | 'a' -> ()
 830           | '\\' -> () | '?'  -> () | '\'' -> ()  | '"' -> ()
 831           | 'e' -> () (* linuxext: ? *)
 832           | _ ->
 833               Common.pr2 ("LEXER: unrecognised symbol in char:"^tok lexbuf);
 834           );
 835           x ^ restchars lexbuf
 836         }
 837   | _
 838       { Common.pr2 ("LEXER: unrecognised symbol in char:"^tok lexbuf);
 839         tok lexbuf ^ restchars lexbuf
 840       }
 841
 842 and restchars = parse
 843   | "'"                                { "" }
 844   | (_ as x)                           { String.make 1 x ^ restchars lexbuf }
 845   (* todo?: as for octal, do exception  beyond radix exception ? *)
 846   | (("\\" (oct | oct oct | oct oct oct)) as x     ) { x ^ restchars lexbuf }
 847   (* this rule must be after the one with octal, lex try first longest
 848    * and when \7  we want an octal, not an exn.
 849    *)
 850   | (("\\x" ((hex | hex hex))) as x           )      { x ^ restchars lexbuf }
 851   | (("\\" (_ as v))           as x           )
 852         {
 853           (match v with (* Machine specific ? *)
 854           | 'n' -> ()  | 't' -> ()   | 'v' -> ()  | 'b' -> () | 'r' -> ()
 855           | 'f' -> () | 'a' -> ()
 856           | '\\' -> () | '?'  -> () | '\'' -> ()  | '"' -> ()
 857           | 'e' -> () (* linuxext: ? *)
 858           | _ ->
 859               Common.pr2 ("LEXER: unrecognised symbol in char:"^tok lexbuf);
 860           );
 861           x ^ restchars lexbuf
 862         }
 863   | _
 864       { Common.pr2 ("LEXER: unrecognised symbol in char:"^tok lexbuf);
 865         tok lexbuf ^ restchars lexbuf
 866       }
 867
 868 and string  = parse
 869   | '"'                                       { "" }
 870   | (_ as x)                   { Common.string_of_char x ^ string lexbuf }
 871   | ("\\" (oct | oct oct | oct oct oct)) as x { x ^ string lexbuf }
 872   | ("\\x" (hex | hex hex)) as x              { x ^ string lexbuf }
 873   | ("\\" (_ as v)) as x
 874        {
 875          (match v with
 876             | 'n' -> ()  | 't' -> ()   | 'v' -> ()  | 'b' -> () | 'r' -> ()
 877             | 'f' -> () | 'a' -> ()
 878             | '\\' -> () | '?'  -> () | '\'' -> ()  | '"' -> ()
 879             | 'e' -> ()
 880             | '\n' -> ()
 881             | '(' -> () | '|' -> () | ')' -> ()
 882             | _ -> lexerr "unrecognised symbol:" (tok lexbuf)
 883          );
 884           x ^ string lexbuf
 885        }
 886   | _ { lexerr "unrecognised symbol: " (tok lexbuf) }
 887
 888 and comment check_comment = parse
 889   | "*/" { let s = tok lexbuf in check_comment s; start_line true; s }
 890   | ['\n' '\r' '\011' '\012']
 891       { let s = tok lexbuf in
 892         (* even blank line should have a + *)
 893         check_comment s;
 894         reset_line lexbuf; s ^ comment check_comment lexbuf }
 895   | "+" { pass_zero();
 896           if !current_line_started
 897           then (start_line true;
 898                 let s = tok lexbuf in s^(comment check_comment lexbuf))
 899           else (start_line true; comment check_comment lexbuf) }
 900   (* noteopti: *)
 901   | [^ '*']
 902       { let s = tok lexbuf in
 903         check_comment s; start_line true; s ^ comment check_comment lexbuf }
 904   | [ '*']
 905       { let s = tok lexbuf in
 906         check_comment s; start_line true; s ^ comment check_comment lexbuf }
 907   | _
 908       { start_line true; let s = tok lexbuf in
 909         Common.pr2 ("LEXER: unrecognised symbol in comment:"^s);
 910         s ^ comment check_comment lexbuf
 911       }
 912