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