parsing_cocci/lexer_cocci.mll

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