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.
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.
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.
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/>.
20 * The authors reserve the right to distribute this or future versions of
21 * Coccinelle under other licenses.
26 open Parser_cocci_menhir
28 module Ast = Ast_cocci
29 module Ast0 = Ast0_cocci
31 exception Lexical of string
32 let tok = Lexing.lexeme
35 let logical_line = ref 0
37 (* ---------------------------------------------------------------------- *)
41 type line_type = MINUS | OPTMINUS | UNIQUEMINUS | PLUS | CONTEXT | UNIQUE | OPT
44 let current_line_type = ref (D.CONTEXT,!line,!logical_line)
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
54 prev_plus := (c = D.PLUS) or (c = D.PLUSPLUS);
55 (c,l,ll,lex_start,preceeding_spaces,[],[],Ast0.NoMetaPos)
56 let current_line_started = ref false
57 let col_zero = ref true
59 let reset_line lexbuf =
61 current_line_type := (D.CONTEXT,!line,!logical_line);
62 current_line_started := false;
64 line_start := Lexing.lexeme_start lexbuf + 1
66 let started_line = ref (-1)
68 let start_line seen_char =
69 current_line_started := true;
71 (if seen_char && not(!line = !started_line)
74 started_line := !line;
75 logical_line := !logical_line + 1
78 let pass_zero _ = col_zero := false
80 let lexerr s1 s2 = raise (Lexical (Printf.sprintf "%s%s" s1 s2))
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" ""
100 let check_minus_context_linetype s =
101 match !current_line_type with
102 (D.PLUS,_,_) | (D.PLUSPLUS,_,_) -> lexerr "invalid in a + context: " s
105 let check_context_linetype s =
106 match !current_line_type with
107 (D.CONTEXT,_,_) -> ()
108 | _ -> lexerr "invalid in a nonempty context: " s
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
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
121 let check_comment s =
122 if not !current_line_started
123 then lexerr "+ expected at the beginning of the line" s
125 let process_include start finish str =
126 (match !current_line_type with
127 (D.PLUS,_,_) | (D.PLUSPLUS,_,_) ->
129 let _ = Str.search_forward (Str.regexp "\\.\\.\\.") str start in
130 lexerr "... not allowed in + include" ""
131 with Not_found -> ())
133 String.sub str (start + 1) (finish - start - 1)
135 (* ---------------------------------------------------------------------- *)
136 type pm = PATCH | MATCH | UNKNOWN
140 let patch_or_match = function
142 if not !D.ignore_patch_or_match
146 lexerr "- or + not allowed in the first column for a match" ""
148 | UNKNOWN -> Flag.sgrep_mode2 := false; pm := PATCH)
150 if not !D.ignore_patch_or_match
153 PATCH -> lexerr "* not allowed in the first column for a patch" ""
155 | UNKNOWN -> Flag.sgrep_mode2 := true; pm := MATCH)
156 | _ -> failwith "unexpected argument"
158 (* ---------------------------------------------------------------------- *)
159 (* identifiers, including metavariables *)
161 let metavariables = (Hashtbl.create(100) : (string, D.clt -> token) Hashtbl.t)
163 let all_metavariables =
164 (Hashtbl.create(100) : (string,(string * (D.clt -> token)) list) Hashtbl.t)
166 let type_names = (Hashtbl.create(100) : (string, D.clt -> token) Hashtbl.t)
168 let declarer_names = (Hashtbl.create(100) : (string, D.clt -> token) Hashtbl.t)
170 let iterator_names = (Hashtbl.create(100) : (string, D.clt -> token) Hashtbl.t)
172 let rule_names = (Hashtbl.create(100) : (string, unit) Hashtbl.t)
174 let check_var s linetype =
176 if (!Data.in_prolog || !Data.in_rule_name) &&
177 Str.string_match (Str.regexp "<.*>") s 0
180 try (Hashtbl.find metavariables s) linetype
182 (try (Hashtbl.find type_names s) linetype
184 (try (Hashtbl.find declarer_names s) linetype
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())
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
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
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
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
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
272 | "auto" -> Tauto linetype
273 | "register" -> Tregister linetype
274 | "extern" -> Textern linetype
275 | "static" -> Tstatic linetype
276 | "inline" -> Tinline linetype
277 | "typedef" -> Ttypedef linetype
279 | "const" -> Tconst linetype
280 | "volatile" -> Tvolatile linetype
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
295 | "sizeof" -> TSizeof linetype
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
306 | "_" when !Data.in_meta -> TUnderscore
308 | s -> check_var s linetype
310 let mkassign op lexbuf =
311 TAssign (Ast.OpAssign op, (get_current_line_type lexbuf))
318 current_line_started := false;
319 current_line_type := (D.CONTEXT,0,0);
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 :=
337 let fn clt = TMeta(name,pure,clt) in
338 Hashtbl.replace metavariables (get_name name) fn);
340 (fun name constraints pure ->
341 let fn clt = TMetaId(name,constraints,pure,clt) in
342 Hashtbl.replace metavariables (get_name name) fn);
343 Data.add_virt_id_meta_found :=
345 let fn clt = TIdent(vl,clt) in
346 Hashtbl.replace metavariables name fn);
347 Data.add_virt_id_meta_not_found :=
349 let fn clt = TMetaId(name,Ast.IdNoConstraint,pure,clt) in
350 Hashtbl.replace metavariables (get_name name) fn);
351 Data.add_fresh_id_meta :=
353 let fn clt = TMetaId(name,Ast.IdNoConstraint,Ast0.Impure,clt) in
354 Hashtbl.replace metavariables (get_name name) fn);
355 Data.add_type_meta :=
357 let fn clt = TMetaType(name,pure,clt) in
358 Hashtbl.replace metavariables (get_name name) fn);
359 Data.add_init_meta :=
361 let fn clt = TMetaInit(name,pure,clt) in
362 Hashtbl.replace metavariables (get_name name) fn);
363 Data.add_param_meta :=
364 (function name -> function pure ->
365 let fn clt = TMetaParam(name,pure,clt) in
366 Hashtbl.replace metavariables (get_name name) fn);
367 Data.add_paramlist_meta :=
368 (function name -> function lenname -> function pure ->
369 let fn clt = TMetaParamList(name,lenname,pure,clt) in
370 Hashtbl.replace metavariables (get_name name) fn);
371 Data.add_const_meta :=
372 (fun tyopt name constraints pure ->
373 let fn clt = TMetaConst(name,constraints,pure,tyopt,clt) in
374 Hashtbl.replace metavariables (get_name name) fn);
376 (fun name constraints pure ->
377 let fn clt = TMetaErr(name,constraints,pure,clt) in
378 Hashtbl.replace metavariables (get_name name) fn);
380 (fun tyopt name constraints pure ->
381 let fn clt = TMetaExp(name,constraints,pure,tyopt,clt) in
382 Hashtbl.replace metavariables (get_name name) fn);
383 Data.add_idexp_meta :=
384 (fun tyopt name constraints pure ->
385 let fn clt = TMetaIdExp(name,constraints,pure,tyopt,clt) in
386 Hashtbl.replace metavariables (get_name name) fn);
387 Data.add_local_idexp_meta :=
388 (fun tyopt name constraints pure ->
389 let fn clt = TMetaLocalIdExp(name,constraints,pure,tyopt,clt) in
390 Hashtbl.replace metavariables (get_name name) fn);
391 Data.add_explist_meta :=
392 (function name -> function lenname -> function pure ->
393 let fn clt = TMetaExpList(name,lenname,pure,clt) in
394 Hashtbl.replace metavariables (get_name name) fn);
395 Data.add_decl_meta :=
396 (function name -> function pure ->
397 let fn clt = TMetaDecl(name,pure,clt) in
398 Hashtbl.replace metavariables (get_name name) fn);
399 Data.add_field_meta :=
400 (function name -> function pure ->
401 let fn clt = TMetaField(name,pure,clt) in
402 Hashtbl.replace metavariables (get_name name) fn);
403 Data.add_field_list_meta :=
404 (function name -> function lenname -> function pure ->
405 let fn clt = TMetaFieldList(name,lenname,pure,clt) in
406 Hashtbl.replace metavariables (get_name name) fn);
408 (function name -> function pure ->
409 let fn clt = TMetaStm(name,pure,clt) in
410 Hashtbl.replace metavariables (get_name name) fn);
411 Data.add_stmlist_meta :=
412 (function name -> function pure ->
413 let fn clt = TMetaStmList(name,pure,clt) in
414 Hashtbl.replace metavariables (get_name name) fn);
415 Data.add_func_meta :=
416 (fun name constraints pure ->
417 let fn clt = TMetaFunc(name,constraints,pure,clt) in
418 Hashtbl.replace metavariables (get_name name) fn);
419 Data.add_local_func_meta :=
420 (fun name constraints pure ->
421 let fn clt = TMetaLocalFunc(name,constraints,pure,clt) in
422 Hashtbl.replace metavariables (get_name name) fn);
423 Data.add_iterator_meta :=
424 (fun name constraints pure ->
425 let fn clt = TMetaIterator(name,constraints,pure,clt) in
426 Hashtbl.replace metavariables (get_name name) fn);
427 Data.add_declarer_meta :=
428 (fun name constraints pure ->
429 let fn clt = TMetaDeclarer(name,constraints,pure,clt) in
430 Hashtbl.replace metavariables (get_name name) fn);
432 (fun name constraints any ->
433 let fn ((d,ln,_,_,_,_,_,_) as clt) =
437 (Printf.sprintf "%d: positions only allowed in minus code" ln));
438 TMetaPos(name,constraints,any,clt) in
439 Hashtbl.replace metavariables (get_name name) fn);
440 Data.add_type_name :=
442 let fn clt = TTypeId(name,clt) in
443 Hashtbl.replace type_names name fn);
444 Data.add_declarer_name :=
446 let fn clt = TDeclarerId(name,clt) in
447 Hashtbl.replace declarer_names name fn);
448 Data.add_iterator_name :=
450 let fn clt = TIteratorId(name,clt) in
451 Hashtbl.replace iterator_names name fn);
452 Data.init_rule := (function _ -> Hashtbl.clear metavariables);
453 Data.install_bindings :=
455 List.iter (function (name,fn) -> Hashtbl.add metavariables name fn)
456 (Hashtbl.find all_metavariables parent))
458 (* the following is needed to properly tokenize include files. Because an
459 include file is included after seeing a @, so current_line_started is true.
460 Current_line_started is not important for parsing the name of a rule, so we
461 don't have to reset this value to true after parsing an included file. *)
463 current_line_started := false
466 let len = String.length s in
471 if List.mem (String.get s n) [' ';'\t']
474 let start = loop 0 in
475 String.sub s start (len - start)
478 (* ---------------------------------------------------------------------- *)
481 let letter = ['A'-'Z' 'a'-'z' '_']
482 let digit = ['0'-'9']
486 let hex = ['0'-'9' 'a'-'f' 'A'-'F']
488 let decimal = ('0' | (['1'-'9'] dec*))
489 let octal = ['0'] oct+
490 let hexa = ("0x" |"0X") hex+
495 let exp = ['e''E'] sign? dec+
496 let real = pent exp | ((pent? '.' pfract | pent '.' pfract? ) exp?)
500 | [' ' '\t']* ['\n' '\r' '\011' '\012']
501 { let cls = !current_line_started in
506 match !current_line_type with
507 (D.PLUS,_,_) | (D.PLUSPLUS,_,_) ->
508 let info = get_current_line_type lexbuf in
510 TPragma (Ast.Noindent "", info)
511 | _ -> reset_line lexbuf; token lexbuf
513 else (reset_line lexbuf; token lexbuf) }
515 | [' ' '\t' ]+ { start_line false; token lexbuf }
518 match !current_line_type with
519 (D.PLUS,_,_) | (D.PLUSPLUS,_,_) ->
521 TPragma (Ast.Indent (tok lexbuf), get_current_line_type lexbuf)
522 | _ -> start_line false; token lexbuf }
524 | "__attribute__" [' ' '\t']* "((" _* "))"
525 { match !current_line_type with
526 (D.PLUS,_,_) | (D.PLUSPLUS,_,_) ->
528 TPragma (Ast.Space (tok lexbuf), get_current_line_type lexbuf)
529 | _ -> failwith "attributes only allowedin + code" }
531 | "@@" { start_line true; TArobArob }
533 if !Data.in_rule_name or not !current_line_started
534 then (start_line true; TArob)
535 else (check_minus_context_linetype "@"; TPArob) }
537 | "~=" { start_line true; TTildeEq (get_current_line_type lexbuf) }
538 | "!~=" { start_line true; TTildeExclEq (get_current_line_type lexbuf) }
540 { start_line true; check_minus_context_linetype (tok lexbuf);
541 TWhen (get_current_line_type lexbuf) }
544 { start_line true; check_minus_context_linetype (tok lexbuf);
545 TEllipsis (get_current_line_type lexbuf) }
548 { start_line true; check_minus_context_linetype (tok lexbuf);
549 TCircles (get_current_line_type lexbuf) }
552 { start_line true; check_minus_context_linetype (tok lexbuf);
553 TStars (get_current_line_type lexbuf) }
555 | "<..." { start_line true; check_context_linetype (tok lexbuf);
556 TOEllipsis (get_current_line_type lexbuf) }
557 | "...>" { start_line true; check_context_linetype (tok lexbuf);
558 TCEllipsis (get_current_line_type lexbuf) }
559 | "<+..." { start_line true; check_minus_context_linetype (tok lexbuf);
560 TPOEllipsis (get_current_line_type lexbuf) }
561 | "...+>" { start_line true; check_minus_context_linetype (tok lexbuf);
562 TPCEllipsis (get_current_line_type lexbuf) }
564 | "<ooo" { start_line true; check_context_linetype (tok lexbuf);
565 TOCircles (get_current_line_type lexbuf) }
566 | "ooo>" { start_line true; check_context_linetype (tok lexbuf);
567 TCCircles (get_current_line_type lexbuf) }
569 | "<***" { start_line true; check_context_linetype (tok lexbuf);
570 TOStars (get_current_line_type lexbuf) }
571 | "***>" { start_line true; check_context_linetype (tok lexbuf);
572 TCStars (get_current_line_type lexbuf) }
575 if !current_line_started
576 then (start_line true; TMinus (get_current_line_type lexbuf))
577 else (patch_or_match PATCH;
578 add_current_line_type D.MINUS; token lexbuf) }
580 if !current_line_started
581 then (start_line true; TPlus (get_current_line_type lexbuf))
582 else if !Data.in_meta
584 else (patch_or_match PATCH;
585 add_current_line_type D.PLUS; token lexbuf) }
587 if !current_line_started
588 then (start_line true; TWhy (get_current_line_type lexbuf))
589 else if !Data.in_meta
591 else (add_current_line_type D.OPT; token lexbuf) }
593 if !current_line_started
594 then (start_line true; TBang (get_current_line_type lexbuf))
595 else if !Data.in_meta
597 else (add_current_line_type D.UNIQUE; token lexbuf) }
598 | "(" { if !Data.in_meta or not !col_zero
599 then (start_line true; TOPar (get_current_line_type lexbuf))
601 (start_line true; check_context_linetype (tok lexbuf);
602 TOPar0 (get_current_line_type lexbuf))}
603 | "\\(" { start_line true; TOPar0 (get_current_line_type lexbuf) }
604 | "|" { if not (!col_zero)
605 then (start_line true; TOr(get_current_line_type lexbuf))
606 else (start_line true;
607 check_context_linetype (tok lexbuf);
608 TMid0 (get_current_line_type lexbuf))}
609 | "\\|" { start_line true; TMid0 (get_current_line_type lexbuf) }
610 | ")" { if not !col_zero
611 then (start_line true; TCPar (get_current_line_type lexbuf))
613 (start_line true; check_context_linetype (tok lexbuf);
614 TCPar0 (get_current_line_type lexbuf))}
615 | "\\)" { start_line true; TCPar0 (get_current_line_type lexbuf) }
617 | '[' { start_line true; TOCro (get_current_line_type lexbuf) }
618 | ']' { start_line true; TCCro (get_current_line_type lexbuf) }
619 | '{' { start_line true; TOBrace (get_current_line_type lexbuf) }
620 | '}' { start_line true; TCBrace (get_current_line_type lexbuf) }
622 | "->" { start_line true; TPtrOp (get_current_line_type lexbuf) }
623 | '.' { start_line true; TDot (get_current_line_type lexbuf) }
624 | ',' { start_line true; TComma (get_current_line_type lexbuf) }
625 | ";" { start_line true;
627 then TMPtVirg (* works better with tokens_all *)
628 else TPtVirg (get_current_line_type lexbuf) }
632 if !current_line_started
634 (start_line true; TMul (get_current_line_type lexbuf))
636 (patch_or_match MATCH;
637 add_current_line_type D.MINUS; token lexbuf) }
638 | '/' { start_line true;
639 TDmOp (Ast.Div,get_current_line_type lexbuf) }
640 | '%' { start_line true;
641 TDmOp (Ast.Mod,get_current_line_type lexbuf) }
642 | '~' { start_line true; TTilde (get_current_line_type lexbuf) }
644 | "++" { pass_zero();
645 if !current_line_started
647 (start_line true; TInc (get_current_line_type lexbuf))
648 else (patch_or_match PATCH;
649 add_current_line_type D.PLUSPLUS; token lexbuf) }
650 | "--" { start_line true; TDec (get_current_line_type lexbuf) }
652 | "=" { start_line true; TEq (get_current_line_type lexbuf) }
654 | "-=" { start_line true; mkassign Ast.Minus lexbuf }
655 | "+=" { start_line true; mkassign Ast.Plus lexbuf }
657 | "*=" { start_line true; mkassign Ast.Mul lexbuf }
658 | "/=" { start_line true; mkassign Ast.Div lexbuf }
659 | "%=" { start_line true; mkassign Ast.Mod lexbuf }
661 | "&=" { start_line true; mkassign Ast.And lexbuf }
662 | "|=" { start_line true; mkassign Ast.Or lexbuf }
663 | "^=" { start_line true; mkassign Ast.Xor lexbuf }
665 | "<<=" { start_line true; mkassign Ast.DecLeft lexbuf }
666 | ">>=" { start_line true; mkassign Ast.DecRight lexbuf }
668 | ":" { start_line true; TDotDot (get_current_line_type lexbuf) }
670 | "==" { start_line true; TEqEq (get_current_line_type lexbuf) }
671 | "!=" { start_line true; TNotEq (get_current_line_type lexbuf) }
672 | ">=" { start_line true;
673 TLogOp(Ast.SupEq,get_current_line_type lexbuf) }
674 | "<=" { start_line true;
676 then TSub(get_current_line_type lexbuf)
677 else TLogOp(Ast.InfEq,get_current_line_type lexbuf) }
678 | "<" { start_line true;
679 TLogOp(Ast.Inf,get_current_line_type lexbuf) }
680 | ">" { start_line true;
681 TLogOp(Ast.Sup,get_current_line_type lexbuf) }
683 | "&&" { start_line true; TAndLog (get_current_line_type lexbuf) }
684 | "||" { start_line true; TOrLog (get_current_line_type lexbuf) }
686 | ">>" { start_line true;
687 TShROp(Ast.DecRight,get_current_line_type lexbuf) }
688 | "<<" { start_line true;
689 TShLOp(Ast.DecLeft,get_current_line_type lexbuf) }
691 | "&" { start_line true; TAnd (get_current_line_type lexbuf) }
692 | "^" { start_line true; TXor(get_current_line_type lexbuf) }
694 | "##" { start_line true; TCppConcatOp }
695 | (( ("#" [' ' '\t']* "undef" [' ' '\t']+)) as def)
696 ( (letter (letter |digit)*) as ident)
698 let (arity,line,lline,offset,col,strbef,straft,pos) as lt =
699 get_current_line_type lexbuf in
700 let off = String.length def in
701 (* -1 in the code below because the ident is not at the line start *)
705 (arity,line,lline,offset+off,col+off,[],[],Ast0.NoMetaPos)) }
706 | (( ("#" [' ' '\t']* "define" [' ' '\t']+)) as def)
707 ( (letter (letter |digit)*) as ident)
709 let (arity,line,lline,offset,col,strbef,straft,pos) as lt =
710 get_current_line_type lexbuf in
711 let off = String.length def in
712 (* -1 in the code below because the ident is not at the line start *)
716 (arity,line,lline,offset+off,col+off,[],[],Ast0.NoMetaPos)) }
717 | (( ("#" [' ' '\t']* "define" [' ' '\t']+)) as def)
718 ( (letter (letter | digit)*) as ident)
721 let (arity,line,lline,offset,col,strbef,straft,pos) as lt =
722 get_current_line_type lexbuf in
723 let off = String.length def in
727 (* why pos here but not above? *)
728 (arity,line,lline,offset+off,col+off,strbef,straft,pos),
729 offset + off + (String.length ident),
730 col + off + (String.length ident)) }
731 | "#" [' ' '\t']* "include" [' ' '\t']* '"' [^ '"']+ '"'
733 (let str = tok lexbuf in
734 let start = String.index str '"' in
735 let finish = String.rindex str '"' in
737 (process_include start finish str,get_current_line_type lexbuf)) }
738 | "#" [' ' '\t']* "include" [' ' '\t']* '<' [^ '>']+ '>'
740 (let str = tok lexbuf in
741 let start = String.index str '<' in
742 let finish = String.rindex str '>' in
744 (process_include start finish str,get_current_line_type lexbuf)) }
745 | "#" [' ' '\t']* "if" [^'\n']*
746 | "#" [' ' '\t']* "ifdef" [^'\n']*
747 | "#" [' ' '\t']* "ifndef" [^'\n']*
748 | "#" [' ' '\t']* "else" [^'\n']*
749 | "#" [' ' '\t']* "elif" [^'\n']*
750 | "#" [' ' '\t']* "endif" [^'\n']*
751 | "#" [' ' '\t']* "error" [^'\n']*
752 { start_line true; check_plus_linetype (tok lexbuf);
753 TPragma (Ast.Noindent(tok lexbuf), get_current_line_type lexbuf) }
755 { start_line true; check_plus_linetype (tok lexbuf);
756 (* second argument to TPragma is not quite right, because
757 it represents only the first token of the comment, but that
758 should be good enough *)
759 TPragma (Ast.Indent("/*"^(comment lexbuf)),
760 get_current_line_type lexbuf) }
762 { (if !current_line_started
763 then lexerr "--- must be at the beginning of the line" "");
766 (let str = tok lexbuf in
767 (drop_spaces(String.sub str 3 (String.length str - 3)),
768 (get_current_line_type lexbuf))) }
770 { (if !current_line_started
771 then lexerr "+++ must be at the beginning of the line" "");
774 (let str = tok lexbuf in
775 (drop_spaces(String.sub str 3 (String.length str - 3)),
776 (get_current_line_type lexbuf))) }
778 | letter (letter | digit)*
779 { start_line true; id_tokens lexbuf }
781 | "'" { start_line true;
782 TChar(char lexbuf,get_current_line_type lexbuf) }
783 | '"' { start_line true;
784 TString(string lexbuf,(get_current_line_type lexbuf)) }
785 | (real as x) { start_line true;
786 TFloat(x,(get_current_line_type lexbuf)) }
787 | ((( decimal | hexa | octal)
790 | (['l' 'L'] ['u' 'U'])
791 | (['u' 'U'] ['l' 'L'])
792 | (['u' 'U'] ['l' 'L'] ['l' 'L'])
793 | (['l' 'L'] ['l' 'L'])
795 ) as x) { start_line true; TInt(x,(get_current_line_type lexbuf)) }
802 | _ { lexerr "unrecognised symbol, in token rule: " (tok lexbuf) }
806 | (_ as x) "'" { String.make 1 x }
807 | (("\\" (oct | oct oct | oct oct oct)) as x "'") { x }
808 | (("\\x" (hex | hex hex)) as x "'") { x }
809 | (("\\" (_ as v)) as x "'")
811 | 'n' -> () | 't' -> () | 'v' -> () | 'b' -> ()
812 | 'r' -> () | 'f' -> () | 'a' -> ()
813 | '\\' -> () | '?' -> () | '\'' -> () | '"' -> ()
815 | _ -> lexerr "unrecognised symbol: " (tok lexbuf)
819 | _ { lexerr "unrecognised symbol: " (tok lexbuf) }
823 | (_ as x) { Common.string_of_char x ^ string lexbuf }
824 | ("\\" (oct | oct oct | oct oct oct)) as x { x ^ string lexbuf }
825 | ("\\x" (hex | hex hex)) as x { x ^ string lexbuf }
826 | ("\\" (_ as v)) as x
829 | 'n' -> () | 't' -> () | 'v' -> () | 'b' -> () | 'r' -> ()
830 | 'f' -> () | 'a' -> ()
831 | '\\' -> () | '?' -> () | '\'' -> () | '"' -> ()
834 | '(' -> () | '|' -> () | ')' -> ()
835 | _ -> lexerr "unrecognised symbol:" (tok lexbuf)
839 | _ { lexerr "unrecognised symbol: " (tok lexbuf) }
842 | "*/" { let s = tok lexbuf in check_comment s; start_line true; s }
843 | ['\n' '\r' '\011' '\012']
844 { let s = tok lexbuf in
845 (* even blank line should have a + *)
847 reset_line lexbuf; s ^ comment lexbuf }
849 if !current_line_started
850 then (start_line true; let s = tok lexbuf in s^(comment lexbuf))
851 else (start_line true; comment lexbuf) }
854 { let s = tok lexbuf in
855 check_comment s; start_line true; s ^ comment lexbuf }
857 { let s = tok lexbuf in
858 check_comment s; start_line true; s ^ comment lexbuf }
860 { start_line true; let s = tok lexbuf in
861 Common.pr2 ("LEXER: unrecognised symbol in comment:"^s);