2. FrontC package

The copyright following applies to this sub-package.
(*
 *
 * Copyright (c) 2001 by
 *  George C. Necula        necula@cs.berkeley.edu
 *  Scott McPeak        smcpeak@cs.berkeley.edu
 *  Wes Weimer          weimer@cs.berkeley.edu
 *
 * All rights reserved.  Permission to use, copy, modify and distribute
 * this software for research purposes only is hereby granted,
 * provided that the following conditions are met:
 * 1. Redistributions of source code must retain the above copyright notice,
 * this list of conditions and the following disclaimer.
 * 2. Redistributions in binary form must reproduce the above copyright notice,
 * this list of conditions and the following disclaimer in the documentation
 * and/or other materials provided with the distribution.
 * 3. The name of the authors may not be used to endorse or promote products
 * derived from  this software without specific prior written permission.
 *
 * DISCLAIMER:
 * THIS SOFTWARE IS PROVIDED BY THE AUTHORS ``AS IS'' AND ANY EXPRESS OR
 * IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES
 * OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED.
 * IN NO EVENT SHALL THE AUTHORS BE LIABLE FOR ANY DIRECT, INDIRECT,
 * INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING,
 * BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS
 * OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON
 * ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
 * (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF
 * THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
 *
 *)
Start ocaml section to src/flx_cil_escape.ml[1 /1 ]
     1: # 40 "./lpsrc/flx_frontc.ipk"
     2: (** OCaml types used to represent wide characters and strings *)
     3: type wchar = int64
     4: type wstring = wchar list
     5: 
     6: 
     7: let escape_char = function
     8:   | '\007' -> "\\a"
     9:   | '\b' -> "\\b"
    10:   | '\t' -> "\\t"
    11:   | '\n' -> "\\n"
    12:   | '\011' -> "\\v"
    13:   | '\012' -> "\\f"
    14:   | '\r' -> "\\r"
    15:   | '"' -> "\\\""
    16:   | '\'' -> "\\'"
    17:   | '\\' -> "\\\\"
    18:   | ' ' .. '~' as printable -> String.make 1 printable
    19:   | unprintable -> Printf.sprintf "\\%03o" (Char.code unprintable)
    20: 
    21: let escape_string str =
    22:   let length = String.length str in
    23:   let buffer = Buffer.create length in
    24:   for index = 0 to length - 1 do
    25:     Buffer.add_string buffer (escape_char (String.get str index))
    26:   done;
    27:   Buffer.contents buffer
    28: 
    29: (* a wide char represented as an int64 *)
    30: let escape_wchar =
    31:   (* limit checks whether upper > probe *)
    32:   let limit upper probe = (Int64.to_float (Int64.sub upper probe)) > 0.5 in
    33:   let fits_byte = limit (Int64.of_int 0x100) in
    34:   let fits_octal_escape = limit (Int64.of_int 0o1000) in
    35:   let fits_universal_4 = limit (Int64.of_int 0x10000) in
    36:   let fits_universal_8 = limit (Int64.of_string "0x100000000") in
    37:   fun charcode ->
    38:     if fits_byte charcode then
    39:       escape_char (Char.chr (Int64.to_int charcode))
    40:     else if fits_octal_escape charcode then
    41:       Printf.sprintf "\\%03Lo" charcode
    42:     else if fits_universal_4 charcode then
    43:       Printf.sprintf "\\u%04Lx" charcode
    44:     else if fits_universal_8 charcode then
    45:       Printf.sprintf "\\u%04Lx" charcode
    46:     else
    47:       invalid_arg "Flx_cil_cprint.escape_string_intlist"
    48: 
    49: (* a wide string represented as a list of int64s *)
    50: let escape_wstring (str : int64 list) =
    51:   let length = List.length str in
    52:   let buffer = Buffer.create length in
    53:   let append charcode =
    54:     let addition = escape_wchar charcode in
    55:     Buffer.add_string buffer addition
    56:   in
    57:   List.iter append str;
    58:   Buffer.contents buffer
    59: 
End ocaml section to src/flx_cil_escape.ml[1]
Start ocaml section to src/flx_cil_escape.mli[1 /1 ]
     1: # 100 "./lpsrc/flx_frontc.ipk"
     2: (*
     3:  * Character and string escaping utilities
     4:  *)
     5: 
     6: (** OCaml types used to represent wide characters and strings *)
     7: type wchar = int64
     8: type wstring = wchar list
     9: 
    10: (** escape various constructs in accordance with C lexical rules *)
    11: val escape_char : char -> string
    12: val escape_string : string -> string
    13: val escape_wchar : wchar -> string
    14: val escape_wstring : wstring -> string
    15: 
End ocaml section to src/flx_cil_escape.mli[1]
Start ocaml section to src/flx_cil_cabs.mli[1 /1 ]
     1: # 116 "./lpsrc/flx_frontc.ipk"
     2: 
     3: (** This file was originally part of Hugues Casee's frontc 2.0, and has been
     4:  * extensively changed since.
     5: **
     6: ** 1.0  3.22.99 Hugues Cassé    First version.
     7: ** 2.0  George Necula 12/12/00: Many extensions
     8:  **)
     9: 
    10: (*
    11: ** Types
    12: *)
    13: 
    14: type cabsloc = {
    15:  lineno : int;
    16:  filename: string;
    17:  byteno: int;
    18: 
    19: }
    20: 
    21: type lang_t = [`C | `Cxx]
    22: 
    23: type typeSpecifier = (* Merge all specifiers into one type *)
    24:   | Tvoid                             (* Type specifier ISO 6.7.2 *)
    25:   | Tbool
    26:   | Tchar
    27:   | Tshort
    28:   | Tint
    29:   | Tlong
    30:   | Tint64
    31:   | Tfloat
    32:   | Tdouble
    33:   | Tsigned
    34:   | Tunsigned
    35:   | Tcomplex
    36:   | Timaginary
    37:   | Tnamed of string
    38:   (* each of the following three kinds of specifiers contains a field
    39:    * or item list iff it corresponds to a definition (as opposed to
    40:    * a forward declaration or simple reference to the type); they
    41:    * also have a list of __attribute__s that appeared between the
    42:    * keyword and the type name (definitions only) *)
    43:   | Tstruct of string * field_group list option * attribute list
    44:   | Tunion of string * field_group list option * attribute list
    45:   | Tenum of string * enum_item list option * attribute list
    46:   | TtypeofE of expression                      (* GCC __typeof__ *)
    47:   | TtypeofT of specifier * decl_type       (* GCC __typeof__ *)
    48: 
    49: and storage =
    50:     NO_STORAGE | AUTO | STATIC | EXTERN | REGISTER
    51: 
    52: and funspec =
    53:     INLINE | VIRTUAL | EXPLICIT
    54: 
    55: and cvspec =
    56:     CV_CONST | CV_VOLATILE | CV_RESTRICT
    57: 
    58: (* Type specifier elements. These appear at the start of a declaration *)
    59: (* Everywhere they appear in this file, they appear as a 'spec_elem list', *)
    60: (* which is not interpreted by cabs -- rather, this "word soup" is passed *)
    61: (* on to the compiler.  Thus, we can represent e.g. 'int long float x' even *)
    62: (* though the compiler will of course choke. *)
    63: and spec_elem =
    64:     SpecTypedef
    65:   | SpecCV of cvspec            (* const/volatile *)
    66:   | SpecAttr of attribute       (* __attribute__ *)
    67:   | SpecStorage of storage
    68:   | SpecInline
    69:   | SpecType of typeSpecifier
    70:   | SpecPattern of string       (* specifier pattern variable *)
    71: 
    72: (* decided to go ahead and replace 'spec_elem list' with specifier *)
    73: and specifier = spec_elem list
    74: 
    75: 
    76: (* Declarator type. They modify the base type given in the specifier. Keep
    77:  * them in the order as they are printed (this means that the top level
    78:  * constructor for ARRAY and PTR is the inner-level in the meaning of the
    79:  * declared type) *)
    80: and decl_type =
    81:  | JUSTBASE                               (* Prints the declared name *)
    82:  | PARENTYPE of attribute list * decl_type * attribute list
    83:                                           (* Prints "(attrs1 decl attrs2)".
    84:                                            * attrs2 are attributes of the
    85:                                            * declared identifier and it is as
    86:                                            * if they appeared at the very end
    87:                                            * of the declarator. attrs1 can
    88:                                            * contain attributes for the
    89:                                            * identifier or attributes for the
    90:                                            * enclosing type.  *)
    91:  | ARRAY of decl_type * attribute list * expression
    92:                                           (* Prints "decl [ attrs exp ]".
    93:                                            * decl is never a PTR. *)
    94:  | PTR of attribute list * decl_type      (* Prints "* attrs decl" *)
    95:  | PROTO of decl_type * single_name list * bool
    96:                                           (* Prints "decl (args[, ...])".
    97:                                            * decl is never a PTR.*)
    98: 
    99: (* The base type and the storage are common to all names. Each name might
   100:  * contain type or storage modifiers *)
   101: (* e.g.: int x, y; *)
   102: and name_group = specifier * name list
   103: 
   104: (* The optional expression is the bitfield *)
   105: and field_group = specifier * (name * expression option) list
   106: 
   107: (* like name_group, except the declared variables are allowed to have initializers *)
   108: (* e.g.: int x=1, y=2; *)
   109: and init_name_group = specifier * init_name list
   110: 
   111: (* The decl_type is in the order in which they are printed. Only the name of
   112:  * the declared identifier is pulled out. The attributes are those that are
   113:  * printed after the declarator *)
   114: (* e.g: in "int *x", "*x" is the declarator; "x" will be pulled out as *)
   115: (* the string, and decl_type will be PTR([], JUSTBASE) *)
   116: and name = string * decl_type * attribute list * cabsloc
   117: 
   118: (* A variable declarator ("name") with an initializer *)
   119: and init_name = name * init_expression
   120: 
   121: (* Single names are for declarations that cannot come in groups, like
   122:  * function parameters and functions *)
   123: and single_name = specifier * name
   124: 
   125: 
   126: and enum_item = string * expression * cabsloc
   127: 
   128: (*
   129: ** Declaration definition (at toplevel)
   130: *)
   131: and base_spec = [
   132:   | `Public of string
   133:   | `Protected of string
   134:   | `Private of string
   135:   | `Public_virtual of string
   136:   | `Protected_virtual of string
   137:   | `Private_virtual of string
   138: ]
   139: 
   140: and definition =
   141:    FUNDEF of single_name * block * cabsloc * cabsloc
   142:  | DECDEF of init_name_group * cabsloc        (* global variable(s), or function prototype *)
   143:  | TYPEDEF of name_group * cabsloc
   144:  | ONLYTYPEDEF of specifier * cabsloc
   145:  | GLOBASM of string * cabsloc
   146:  | PRAGMA of expression * cabsloc
   147:  | LINKAGE of string * cabsloc * definition list (* extern "C" { ... } *)
   148:  | NAMESPACE of string * cabsloc * definition list
   149:  (* toplevel form transformer, from the first definition to the *)
   150:  (* second group of definitions *)
   151:  | TRANSFORMER of definition * definition list * cabsloc
   152:  (* expression transformer: source and destination *)
   153:  | EXPRTRANSFORMER of expression * expression * cabsloc
   154: 
   155: 
   156: (* the string is a file name, and then the list of toplevel forms *)
   157: and file = string * definition list
   158: 
   159: 
   160: (*
   161: ** statements
   162: *)
   163: 
   164: (* A block contains a list of local label declarations ( GCC's ({ __label__
   165:  * l1, l2; ... }) ) , a list of definitions and a list of statements  *)
   166: and block =
   167:     { blabels: string list;
   168:       battrs: attribute list;
   169:       bstmts: statement list
   170:     }
   171: 
   172: and statement =
   173:    NOP of cabsloc
   174:  | COMPUTATION of expression * cabsloc
   175:  | BLOCK of block * cabsloc
   176:  | SEQUENCE of statement * statement * cabsloc
   177:  | IF of expression * statement * statement * cabsloc
   178:  | WHILE of expression * statement * cabsloc
   179:  | DOWHILE of expression * statement * cabsloc
   180:  | FOR of for_clause * expression * expression * statement * cabsloc
   181:  | BREAK of cabsloc
   182:  | CONTINUE of cabsloc
   183:  | RETURN of expression * cabsloc
   184:  | SWITCH of expression * statement * cabsloc
   185:  | CASE of expression * statement * cabsloc
   186:  | CASERANGE of expression * expression * statement * cabsloc
   187:  | DEFAULT of statement * cabsloc
   188:  | LABEL of string * statement * cabsloc
   189:  | GOTO of string * cabsloc
   190:  | COMPGOTO of expression * cabsloc (* GCC's "goto *exp" *)
   191:  | DEFINITION of definition (*definition or declaration of a variable or type*)
   192: 
   193:  | ASM of attribute list * (* typically only volatile and const *)
   194:          string list * (* template *)
   195:        (string * expression) list * (* list of constraints and expressions for
   196:                                    * outputs *)
   197:        (string * expression) list * (* same for inputs *)
   198:        string list * (* clobbered registers *)
   199:        cabsloc
   200: 
   201:    (** MS SEH *)
   202:  | TRY_EXCEPT of block * expression * block * cabsloc
   203:  | TRY_FINALLY of block * block * cabsloc
   204: 
   205: and for_clause =
   206:    FC_EXP of expression
   207:  | FC_DECL of definition
   208: 
   209: (*
   210: ** Expressions
   211: *)
   212: and binary_operator =
   213:     ADD | SUB | MUL | DIV | MOD
   214:   | AND | OR
   215:   | BAND | BOR | XOR | SHL | SHR
   216:   | EQ | NE | LT | GT | LE | GE
   217:   | ASSIGN
   218:   | ADD_ASSIGN | SUB_ASSIGN | MUL_ASSIGN | DIV_ASSIGN | MOD_ASSIGN
   219:   | BAND_ASSIGN | BOR_ASSIGN | XOR_ASSIGN | SHL_ASSIGN | SHR_ASSIGN
   220: 
   221: and unary_operator =
   222:     MINUS | PLUS | NOT | BNOT | MEMOF | ADDROF
   223:   | PREINCR | PREDECR | POSINCR | POSDECR
   224: 
   225: and expression =
   226:     NOTHING
   227:   | UNARY of unary_operator * expression
   228:   | LABELADDR of string  (* GCC's && Label *)
   229:   | BINARY of binary_operator * expression * expression
   230:   | QUESTION of expression * expression * expression
   231: 
   232:    (* A CAST can actually be a constructor expression *)
   233:   | CAST of (specifier * decl_type) * init_expression
   234: 
   235:     (* There is a special form of CALL in which the function called is
   236:        __builtin_va_arg and the second argument is sizeof(T). This
   237:        should be printed as just T *)
   238:   | CALL of expression * expression list
   239:   | COMMA of expression list
   240:   | CONSTANT of constant
   241:   | VARIABLE of string
   242:   | EXPR_SIZEOF of expression
   243:   | TYPE_SIZEOF of specifier * decl_type
   244:   | EXPR_ALIGNOF of expression
   245:   | TYPE_ALIGNOF of specifier * decl_type
   246:   | INDEX of expression * expression
   247:   | MEMBEROF of expression * string
   248:   | MEMBEROFPTR of expression * string
   249:   | GNU_BODY of block
   250:   | EXPR_PATTERN of string     (* pattern variable, and name *)
   251: 
   252: and constant =
   253:   | CONST_INT of string   (* the textual representation *)
   254:   | CONST_FLOAT of string (* the textual representaton *)
   255:   | CONST_CHAR of int64 list
   256:   | CONST_WCHAR of int64 list
   257:   | CONST_STRING of string
   258:   | CONST_WSTRING of int64 list
   259:     (* ww: wstrings are stored as an int64 list at this point because
   260:      * we might need to feed the wide characters piece-wise into an
   261:      * array initializer (e.g., wchar_t foo[] = L"E\xabcd";). If that
   262:      * doesn't happen we will convert it to an (escaped) string before
   263:      * passing it to Flx_cil_cil. *)
   264: 
   265: and init_expression =
   266:   | NO_INIT
   267:   | SINGLE_INIT of expression
   268:   | COMPOUND_INIT of (initwhat * init_expression) list
   269: 
   270: and initwhat =
   271:     NEXT_INIT
   272:   | INFIELD_INIT of string * initwhat
   273:   | ATINDEX_INIT of expression * initwhat
   274:   | ATINDEXRANGE_INIT of expression * expression
   275: 
   276: 
   277:                                         (* Each attribute has a name and some
   278:                                          * optional arguments *)
   279: and attribute = string * expression list
   280: 
End ocaml section to src/flx_cil_cabs.mli[1]
Start ocaml section to src/flx_cil_cabs_helper.mli[1 /1 ]
     1: # 397 "./lpsrc/flx_frontc.ipk"
     2: val cabslu : Flx_cil_cabs.cabsloc
     3: val missingFieldDecl :
     4:   string * Flx_cil_cabs.decl_type * 'a list * Flx_cil_cabs.cabsloc
     5: val isStatic : Flx_cil_cabs.spec_elem list -> bool
     6: val isExtern : Flx_cil_cabs.spec_elem list -> bool
     7: val isInline : Flx_cil_cabs.spec_elem list -> bool
     8: val isTypedef : Flx_cil_cabs.spec_elem list -> bool
     9: val get_definitionloc : Flx_cil_cabs.definition -> Flx_cil_cabs.cabsloc
    10: val get_statementloc : Flx_cil_cabs.statement -> Flx_cil_cabs.cabsloc
    11: val explodeStringToInts : string -> int64 list
    12: val valueOfDigit : char -> int64
    13: val d_cabsloc : unit -> Flx_cil_cabs.cabsloc -> Flx_cil_pretty.doc
    14: 
End ocaml section to src/flx_cil_cabs_helper.mli[1]
Start ocaml section to src/flx_cil_cabs_helper.ml[1 /1 ]
     1: # 412 "./lpsrc/flx_frontc.ipk"
     2: open Flx_cil_cabs
     3: 
     4: let cabslu = {lineno = -10; filename = "cabs loc unknown"; byteno = -10;}
     5: 
     6: 
     7: (*********** HELPER FUNCTIONS **********)
     8: 
     9: let missingFieldDecl = ("___missing_field_name", JUSTBASE, [], cabslu)
    10: 
    11: let rec isStatic = function
    12:     [] -> false
    13:   | (SpecStorage STATIC) :: _ -> true
    14:   | _ :: rest -> isStatic rest
    15: 
    16: let rec isExtern = function
    17:     [] -> false
    18:   | (SpecStorage EXTERN) :: _ -> true
    19:   | _ :: rest -> isExtern rest
    20: 
    21: let rec isInline = function
    22:     [] -> false
    23:   | SpecInline :: _ -> true
    24:   | _ :: rest -> isInline rest
    25: 
    26: let rec isTypedef = function
    27:     [] -> false
    28:   | SpecTypedef :: _ -> true
    29:   | _ :: rest -> isTypedef rest
    30: 
    31: 
    32: let get_definitionloc (d : definition) : cabsloc =
    33:   match d with
    34:   | FUNDEF(_, _, l, _) -> l
    35:   | DECDEF(_, l) -> l
    36:   | TYPEDEF(_, l) -> l
    37:   | ONLYTYPEDEF(_, l) -> l
    38:   | GLOBASM(_, l) -> l
    39:   | PRAGMA(_, l) -> l
    40:   | TRANSFORMER(_, _, l) -> l
    41:   | EXPRTRANSFORMER(_, _, l) -> l
    42:   | LINKAGE (_, l, _) -> l
    43:   | NAMESPACE (_, l, _) -> l
    44: 
    45: let get_statementloc (s : statement) : cabsloc =
    46: begin
    47:   match s with
    48:   | NOP(loc) -> loc
    49:   | COMPUTATION(_,loc) -> loc
    50:   | BLOCK(_,loc) -> loc
    51:   | SEQUENCE(_,_,loc) -> loc
    52:   | IF(_,_,_,loc) -> loc
    53:   | WHILE(_,_,loc) -> loc
    54:   | DOWHILE(_,_,loc) -> loc
    55:   | FOR(_,_,_,_,loc) -> loc
    56:   | BREAK(loc) -> loc
    57:   | CONTINUE(loc) -> loc
    58:   | RETURN(_,loc) -> loc
    59:   | SWITCH(_,_,loc) -> loc
    60:   | CASE(_,_,loc) -> loc
    61:   | CASERANGE(_,_,_,loc) -> loc
    62:   | DEFAULT(_,loc) -> loc
    63:   | LABEL(_,_,loc) -> loc
    64:   | GOTO(_,loc) -> loc
    65:   | COMPGOTO (_, loc) -> loc
    66:   | DEFINITION d -> get_definitionloc d
    67:   | ASM(_,_,_,_,_,loc) -> loc
    68:   | TRY_EXCEPT(_, _, _, loc) -> loc
    69:   | TRY_FINALLY(_, _, loc) -> loc
    70: end
    71: 
    72: 
    73: let explodeStringToInts (s: string) : int64 list =
    74:   let rec allChars i acc =
    75:     if i < 0 then acc
    76:     else allChars (i - 1) (Int64.of_int (Char.code (String.get s i)) :: acc)
    77:   in
    78:   allChars (-1 + String.length s) []
    79: 
    80: let valueOfDigit chr =
    81:   let int_value =
    82:     match chr with
    83:       '0'..'9' -> (Char.code chr) - (Char.code '0')
    84:     | 'a'..'z' -> (Char.code chr) - (Char.code 'a') + 10
    85:     | 'A'..'Z' -> (Char.code chr) - (Char.code 'A') + 10
    86:     | _ -> Flx_cil_errormsg.s (Flx_cil_errormsg.bug "not a digit") in
    87:   Int64.of_int int_value
    88: 
    89: 
    90: open Flx_cil_pretty
    91: let d_cabsloc () cl =
    92:   text cl.filename ++ text ":" ++ num cl.lineno
End ocaml section to src/flx_cil_cabs_helper.ml[1]
Start ocaml section to src/flx_cil_cabsvisit.ml[1 /1 ]
     1: # 505 "./lpsrc/flx_frontc.ipk"
     2: 
     3: (* cabsvisit.ml *)
     4: (* tree visitor and rewriter for cabs *)
     5: 
     6: open Flx_cil_cabs
     7: open Flx_cil_cabs_helper
     8: open Flx_cil_trace
     9: open Flx_cil_pretty
    10: module E = Flx_cil_errormsg
    11: 
    12: (* basic interface for a visitor object *)
    13: 
    14: (* Different visiting actions. 'a will be instantiated with exp, instr, etc. *)
    15: type 'a visitAction =
    16:     SkipChildren                        (* Do not visit the children. Return
    17:                                          * the node as it is *)
    18:   | ChangeTo of 'a                      (* Replace the expression with the
    19:                                          * given one *)
    20:   | DoChildren                          (* Continue with the children of this
    21:                                          * node. Rebuild the node on return
    22:                                          * if any of the children changes
    23:                                          * (use == test) *)
    24:   | ChangeDoChildrenPost of 'a * ('a -> 'a) (* First consider that the entire
    25:                                           * exp is replaced by the first
    26:                                           * paramenter. Then continue with
    27:                                           * the children. On return rebuild
    28:                                           * the node if any of the children
    29:                                           * has changed and then apply the
    30:                                           * function on the node *)
    31: 
    32: type nameKind =
    33:     NVar                                (* Variable or function prototype
    34:                                            name *)
    35:   | NFun                                (* A function definition name *)
    36:   | NField                              (* The name of a field *)
    37:   | NType                               (* The name of a type *)
    38: 
    39: (* All visit methods are called in preorder! (but you can use
    40:  * ChangeDoChildrenPost to change the order) *)
    41: class type cabsVisitor = object
    42:   method vexpr: expression -> expression visitAction   (* expressions *)
    43:   method vinitexpr: init_expression -> init_expression visitAction
    44:   method vstmt: statement -> statement list visitAction
    45:   method vblock: block -> block visitAction
    46:   method vvar: string -> string                  (* use of a variable
    47:                                                         * names *)
    48:   method vdef: definition -> definition list visitAction
    49:   method vtypespec: typeSpecifier -> typeSpecifier visitAction
    50:   method vdecltype: decl_type -> decl_type visitAction
    51: 
    52:       (* For each declaration we call vname *)
    53:   method vname: nameKind -> specifier -> name -> name visitAction
    54:   method vspec: specifier -> specifier visitAction     (* specifier *)
    55:   method vattr: attribute -> attribute list visitAction
    56: 
    57:   method vEnterScope: unit -> unit
    58:   method vExitScope: unit -> unit
    59: end
    60: 
    61: let visitorLocation = ref { filename = ""; lineno = -1; byteno = -1; }
    62: 
    63:         (* a default visitor which does nothing to the tree *)
    64: class nopFlx_cil_cabsVisitor : cabsVisitor = object
    65:   method vexpr (e:expression) = DoChildren
    66:   method vinitexpr (e:init_expression) = DoChildren
    67:   method vstmt (s: statement) =
    68:     visitorLocation := get_statementloc s;
    69:     DoChildren
    70:   method vblock (b: block) = DoChildren
    71:   method vvar (s: string) = s
    72:   method vdef (d: definition) =
    73:     visitorLocation := get_definitionloc d;
    74:     DoChildren
    75:   method vtypespec (ts: typeSpecifier) = DoChildren
    76:   method vdecltype (dt: decl_type) = DoChildren
    77:   method vname k (s:specifier) (n: name) = DoChildren
    78:   method vspec (s:specifier) = DoChildren
    79:   method vattr (a: attribute) = DoChildren
    80: 
    81:   method vEnterScope () = ()
    82:   method vExitScope () = ()
    83: end
    84: 
    85:         (* Map but try not to copy the list unless necessary *)
    86: let rec mapNoCopy (f: 'a -> 'a) = function
    87:     [] -> []
    88:   | (i :: resti) as li ->
    89:       let i' = f i in
    90:       let resti' = mapNoCopy f resti in
    91:       if i' != i || resti' != resti then i' :: resti' else li
    92: 
    93: let rec mapNoCopyList (f: 'a -> 'a list) = function
    94:     [] -> []
    95:   | (i :: resti) as li ->
    96:       let il' = f i in
    97:       let resti' = mapNoCopyList f resti in
    98:       match il' with
    99:         [i'] when i' == i && resti' == resti -> li
   100:       | _ -> il' @ resti'
   101: 
   102: let doVisit (vis: cabsVisitor)
   103:     (startvisit: 'a -> 'a visitAction)
   104:     (children: cabsVisitor -> 'a -> 'a)
   105:     (node: 'a) : 'a =
   106:   let action = startvisit node in
   107:   match action with
   108:     SkipChildren -> node
   109:   | ChangeTo node' -> node'
   110:   | _ ->
   111:       let nodepre = match action with
   112:         ChangeDoChildrenPost (node', _) -> node'
   113:       | _ -> node
   114:       in
   115:       let nodepost = children vis nodepre in
   116:       match action with
   117:         ChangeDoChildrenPost (_, f) -> f nodepost
   118:       | _ -> nodepost
   119: 
   120: (* A visitor for lists *)
   121: let doVisitList (vis: cabsVisitor)
   122:                 (startvisit: 'a -> 'a list visitAction)
   123:                 (children: cabsVisitor -> 'a -> 'a)
   124:                 (node: 'a) : 'a list =
   125:   let action = startvisit node in
   126:   match action with
   127:     SkipChildren -> [node]
   128:   | ChangeTo nodes' -> nodes'
   129:   | _ ->
   130:       let nodespre = match action with
   131:         ChangeDoChildrenPost (nodespre, _) -> nodespre
   132:       | _ -> [node]
   133:       in
   134:       let nodespost = mapNoCopy (children vis) nodespre in
   135:       match action with
   136:         ChangeDoChildrenPost (_, f) -> f nodespost
   137:       | _ -> nodespost
   138: 
   139: 
   140: let rec visit_cabsTypeSpecifier (vis: cabsVisitor) (ts: typeSpecifier) =
   141:   doVisit vis vis#vtypespec childrenTypeSpecifier ts
   142: 
   143: and childrenTypeSpecifier vis ts =
   144:   let childrenFieldGroup ((s, nel) as input) =
   145:     let s' = visit_cabsSpecifier vis s in
   146:     let doOneField ((n, eo) as input) =
   147:       let n' = visit_cabsName vis NField s' n in
   148:       let eo' =
   149:         match eo with
   150:           None -> None
   151:         | Some e -> let e' = visit_cabsExpression vis e in
   152:           if e' != e then Some e' else eo
   153:       in
   154:       if n' != n || eo' != eo then (n', eo') else input
   155:     in
   156:     let nel' = mapNoCopy doOneField nel in
   157:     if s' != s || nel' != nel then (s', nel) else input
   158:   in
   159:   match ts with
   160:     Tstruct (n, Some fg, extraAttrs) ->
   161:       (*(trace "sm" (dprintf "visiting struct %s\n" n));*)
   162:       let fg' = mapNoCopy childrenFieldGroup fg in
   163:       if fg' != fg then Tstruct( n, Some fg', extraAttrs) else ts
   164:   | Tunion (n, Some fg, extraAttrs) ->
   165:       let fg' = mapNoCopy childrenFieldGroup fg in
   166:       if fg' != fg then Tunion( n, Some fg', extraAttrs) else ts
   167:   | Tenum (n, Some ei, extraAttrs) ->
   168:       let doOneEnumItem ((s, e, loc) as ei) =
   169:         let e' = visit_cabsExpression vis e in
   170:         if e' != e then (s, e', loc) else ei
   171:       in
   172:       vis#vEnterScope ();
   173:       let ei' = mapNoCopy doOneEnumItem ei in
   174:       vis#vExitScope();
   175:       if ei' != ei then Tenum( n, Some ei', extraAttrs) else ts
   176:   | TtypeofE e ->
   177:       let e' = visit_cabsExpression vis e in
   178:       if e' != e then TtypeofE e' else ts
   179:   | TtypeofT (s, dt) ->
   180:       let s' = visit_cabsSpecifier vis s in
   181:       let dt' = visit_cabsDeclType vis false dt in
   182:       if s != s' || dt != dt' then TtypeofT (s', dt') else ts
   183:   | ts -> ts
   184: 
   185: and childrenSpecElem (vis: cabsVisitor) (se: spec_elem) : spec_elem =
   186:   match se with
   187:     SpecTypedef | SpecInline | SpecStorage _ | SpecPattern _ -> se
   188:   | SpecCV _ -> se    (* cop out *)
   189:   | SpecAttr a -> begin
   190:       let al' = visit_cabsAttribute vis a in
   191:       match al' with
   192:         [a''] when a'' == a -> se
   193:       | [a''] -> SpecAttr a''
   194:       | _ -> E.s (E.unimp "childrenSpecElem: visit_cabsAttribute returned a list")
   195:   end
   196:   | SpecType ts ->
   197:       let ts' = visit_cabsTypeSpecifier vis ts in
   198:       if ts' != ts then SpecType ts' else se
   199: 
   200: and visit_cabsSpecifier (vis: cabsVisitor) (s: specifier) : specifier =
   201:   doVisit vis vis#vspec childrenSpec s
   202: and childrenSpec vis s = mapNoCopy (childrenSpecElem vis) s
   203: 
   204: 
   205: and visit_cabsDeclType vis (isfundef: bool) (dt: decl_type) : decl_type =
   206:   doVisit vis vis#vdecltype (childrenDeclType isfundef) dt
   207: and childrenDeclType isfundef vis dt =
   208:   match dt with
   209:     JUSTBASE -> dt
   210:   | PARENTYPE (prea, dt1, posta) ->
   211:       let prea' = mapNoCopyList (visit_cabsAttribute vis)  prea in
   212:       let dt1' = visit_cabsDeclType vis isfundef dt1 in
   213:       let posta'= mapNoCopyList (visit_cabsAttribute vis)  posta in
   214:       if prea' != prea || dt1' != dt1 || posta' != posta then
   215:         PARENTYPE (prea', dt1', posta') else dt
   216:   | ARRAY (dt1, al, e) ->
   217:       let dt1' = visit_cabsDeclType vis isfundef dt1 in
   218:       let al' = mapNoCopy (childrenAttribute vis) al in
   219:       let e'= visit_cabsExpression vis e in
   220:       if dt1' != dt1 || al' != al || e' != e then ARRAY(dt1', al', e') else dt
   221:   | PTR (al, dt1) ->
   222:       let al' = mapNoCopy (childrenAttribute vis) al in
   223:       let dt1' = visit_cabsDeclType vis isfundef dt1 in
   224:       if al' != al || dt1' != dt1 then PTR(al', dt1') else dt
   225:   | PROTO (dt1, snl, b) ->
   226:       (* Do not propagate isfundef further *)
   227:       let dt1' = visit_cabsDeclType vis false dt1 in
   228:       let _ = vis#vEnterScope () in
   229:       let snl' = mapNoCopy (childrenSingleName vis NVar) snl in
   230:       (* Exit the scope only if not in a function definition *)
   231:       let _ = if not isfundef then vis#vExitScope () in
   232:       if dt1' != dt1 || snl' != snl then PROTO(dt1', snl', b) else dt
   233: 
   234: 
   235: and childrenNameGroup vis (kind: nameKind) ((s, nl) as input) =
   236:   let s' = visit_cabsSpecifier vis s in
   237:   let nl' = mapNoCopy (visit_cabsName vis kind s') nl in
   238:   if s' != s || nl' != nl then (s', nl') else input
   239: 
   240: 
   241: and childrenInitNameGroup vis ((s, inl) as input) =
   242:   let s' = visit_cabsSpecifier vis s in
   243:   let inl' = mapNoCopy (childrenInitName vis s') inl in
   244:   if s' != s || inl' != inl then (s', inl') else input
   245: 
   246: and visit_cabsName vis (k: nameKind) (s: specifier)
   247:                       (n: name) : name =
   248:   doVisit vis (vis#vname k s) (childrenName s k) n
   249: and childrenName (s: specifier) (k: nameKind) vis (n: name) : name =
   250:   let (sn, dt, al, loc) = n in
   251:   let dt' = visit_cabsDeclType vis (k = NFun) dt in
   252:   let al' = mapNoCopy (childrenAttribute vis) al in
   253:   if dt' != dt || al' != al then (sn, dt', al', loc) else n
   254: 
   255: and childrenInitName vis (s: specifier) (inn: init_name) : init_name =
   256:   let (n, ie) = inn in
   257:   let n' = visit_cabsName vis NVar s n in
   258:   let ie' = visit_cabsInitExpression vis ie in
   259:   if n' != n || ie' != ie then (n', ie') else inn
   260: 
   261: and childrenSingleName vis (k: nameKind) (sn: single_name) : single_name =
   262:   let s, n = sn in
   263:   let s' = visit_cabsSpecifier vis s in
   264:   let n' = visit_cabsName vis k s' n in
   265:   if s' != s || n' != n then (s', n') else sn
   266: 
   267: and visit_cabsDefinition vis (d: definition) : definition list =
   268:   doVisitList vis vis#vdef childrenDefinition d
   269: and childrenDefinition vis d =
   270:   match d with
   271:     FUNDEF (sn, b, l, lend) ->
   272:       let sn' = childrenSingleName vis NFun sn in
   273:       let b' = visit_cabsBlock vis b in
   274:       (* End the scope that was started by childrenFunctionName *)
   275:       vis#vExitScope ();
   276:       if sn' != sn || b' != b then FUNDEF (sn', b', l, lend) else d
   277: 
   278:   | DECDEF ((s, inl), l) ->
   279:       let s' = visit_cabsSpecifier vis s in
   280:       let inl' = mapNoCopy (childrenInitName vis s') inl in
   281:       if s' != s || inl' != inl then DECDEF ((s', inl'), l) else d
   282:   | TYPEDEF (ng, l) ->
   283:       let ng' = childrenNameGroup vis NType ng in
   284:       if ng' != ng then TYPEDEF (ng', l) else d
   285:   | ONLYTYPEDEF (s, l) ->
   286:       let s' = visit_cabsSpecifier vis s in
   287:       if s' != s then ONLYTYPEDEF (s', l) else d
   288:   | GLOBASM _ -> d
   289:   | PRAGMA (e, l) ->
   290:       let e' = visit_cabsExpression vis e in
   291:       if e' != e then PRAGMA (e', l) else d
   292:   | LINKAGE (n, l, dl) ->
   293:       let dl' = mapNoCopyList (visit_cabsDefinition vis) dl in
   294:       if dl' != dl then LINKAGE (n, l, dl') else d
   295: 
   296:   | NAMESPACE (n, l, dl) ->
   297:       let dl' = mapNoCopyList (visit_cabsDefinition vis) dl in
   298:       if dl' != dl then NAMESPACE (n, l, dl') else d
   299: 
   300:   | TRANSFORMER _ -> d
   301:   | EXPRTRANSFORMER _ -> d
   302: 
   303: and visit_cabsBlock vis (b: block) : block =
   304:   doVisit vis vis#vblock childrenBlock b
   305: 
   306: and childrenBlock vis (b: block) : block =
   307:   let _ = vis#vEnterScope () in
   308:   let battrs' = mapNoCopyList (visit_cabsAttribute vis) b.battrs in
   309:   let bstmts' = mapNoCopyList (visit_cabsStatement vis) b.bstmts in
   310:   let _ = vis#vExitScope () in
   311:   if battrs' != b.battrs || bstmts' != b.bstmts then
   312:     { blabels = b.blabels; battrs = battrs'; bstmts = bstmts' }
   313:   else
   314:     b
   315: 
   316: and visit_cabsStatement vis (s: statement) : statement list =
   317:   doVisitList vis vis#vstmt childrenStatement s
   318: and childrenStatement vis s =
   319:   let ve e = visit_cabsExpression vis e in
   320:   let vs l s =
   321:     match visit_cabsStatement vis s with
   322:       [s'] -> s'
   323:     | sl -> BLOCK ({blabels = []; battrs = []; bstmts = sl }, l)
   324:   in
   325:   match s with
   326:     NOP _ -> s
   327:   | COMPUTATION (e, l) ->
   328:       let e' = ve e in
   329:       if e' != e then COMPUTATION (e', l) else s
   330:   | BLOCK (b, l) ->
   331:       let b' = visit_cabsBlock vis b in
   332:       if b' != b then BLOCK (b', l) else s
   333:   | SEQUENCE (s1, s2, l) ->
   334:       let s1' = vs l s1 in
   335:       let s2' = vs l s2 in
   336:       if s1' != s1 || s2' != s2 then SEQUENCE (s1', s2', l) else s
   337:   | IF (e, s1, s2, l) ->
   338:       let e' = ve e in
   339:       let s1' = vs l s1 in
   340:       let s2' = vs l s2 in
   341:       if e' != e || s1' != s1 || s2' != s2 then IF (e', s1', s2', l) else s
   342:   | WHILE (e, s1, l) ->
   343:       let e' = ve e in
   344:       let s1' = vs l s1 in
   345:       if e' != e || s1' != s1 then WHILE (e', s1', l) else s
   346:   | DOWHILE (e, s1, l) ->
   347:       let e' = ve e in
   348:       let s1' = vs l s1 in
   349:       if e' != e || s1' != s1 then DOWHILE (e', s1', l) else s
   350:   | FOR (fc1, e2, e3, s4, l) ->
   351:       let _ = vis#vEnterScope () in
   352:       let fc1' =
   353:         match fc1 with
   354:           FC_EXP e1 ->
   355:             let e1' = ve e1 in
   356:             if e1' != e1 then FC_EXP e1' else fc1
   357:         | FC_DECL d1 ->
   358:             let d1' =
   359:               match visit_cabsDefinition vis d1 with
   360:                 [d1'] -> d1'
   361:               | _ -> E.s (E.unimp "visit_cabs: for can have only one definition")
   362:             in
   363:             if d1' != d1 then FC_DECL d1' else fc1
   364:       in
   365:       let e2' = ve e2 in
   366:       let e3' = ve e3 in
   367:       let s4' = vs l s4 in
   368:       let _ = vis#vExitScope () in
   369:       if fc1' != fc1 || e2' != e2 || e3' != e3 || s4' != s4
   370:       then FOR (fc1', e2', e3', s4', l) else s
   371:   | BREAK _ | CONTINUE _ | GOTO _ -> s
   372:   | RETURN (e, l) ->
   373:       let e' = ve e in
   374:       if e' != e then RETURN (e', l) else s
   375:   | SWITCH (e, s1, l) ->
   376:       let e' = ve e in
   377:       let s1' = vs l s1 in
   378:       if e' != e || s1' != s1 then SWITCH (e', s1', l) else s
   379:   | CASE (e, s1, l) ->
   380:       let e' = ve e in
   381:       let s1' = vs l s1 in
   382:       if e' != e || s1' != s1 then CASE (e', s1', l) else s
   383:   | CASERANGE (e1, e2, s3, l) ->
   384:       let e1' = ve e1 in
   385:       let e2' = ve e2 in
   386:       let s3' = vs l s3 in
   387:       if e1' != e1 || e2' != e2 || s3' != s3 then
   388:         CASERANGE (e1', e2', s3', l) else s
   389:   | DEFAULT (s1, l) ->
   390:       let s1' = vs l s1 in
   391:       if s1' != s1 then DEFAULT (s1', l) else s
   392:   | LABEL (n, s1, l) ->
   393:       let s1' = vs l s1 in
   394:       if s1' != s1 then LABEL (n, s1', l) else s
   395:   | COMPGOTO (e, l) ->
   396:       let e' = ve e in
   397:       if e' != e then COMPGOTO (e', l) else s
   398:   | DEFINITION d -> begin
   399:       match visit_cabsDefinition vis d with
   400:           [d'] when d' == d -> s
   401:         | dl -> let l = get_definitionloc d in
   402:           let dl' = List.map (fun d' -> DEFINITION d') dl in
   403:           BLOCK ({blabels = []; battrs = []; bstmts = dl' }, l)
   404:     end
   405:   | ASM (sl, b, inl, outl, clobs, l) ->
   406:       let childrenStringExp ((s, e) as input) =
   407:         let e' = ve e in
   408:         if e' != e then (s, e') else input
   409:       in
   410:       let inl' = mapNoCopy childrenStringExp inl in
   411:       let outl' = mapNoCopy childrenStringExp outl in
   412:       if inl' != inl || outl' != outl then
   413:         ASM (sl, b, inl', outl', clobs, l) else s
   414:   | TRY_FINALLY (b1, b2, l) ->
   415:       let b1' = visit_cabsBlock vis b1 in
   416:       let b2' = visit_cabsBlock vis b2 in
   417:       if b1' != b1 || b2' != b2 then TRY_FINALLY(b1', b2', l) else s
   418:   | TRY_EXCEPT (b1, e, b2, l) ->
   419:       let b1' = visit_cabsBlock vis b1 in
   420:       let e' = visit_cabsExpression vis e in
   421:       let b2' = visit_cabsBlock vis b2 in
   422:       if b1' != b1 || e' != e || b2' != b2 then TRY_EXCEPT(b1', e', b2', l) else s
   423: 
   424: 
   425: and visit_cabsExpression vis (e: expression) : expression =
   426:   doVisit vis vis#vexpr childrenExpression e
   427: and childrenExpression vis e =
   428:   let ve e = visit_cabsExpression vis e in
   429:   match e with
   430:     NOTHING | LABELADDR _ -> e
   431:   | UNARY (uo, e1) ->
   432:       let e1' = ve e1 in
   433:       if e1' != e1 then UNARY (uo, e1') else e
   434:   | BINARY (bo, e1, e2) ->
   435:       let e1' = ve e1 in
   436:       let e2' = ve e2 in
   437:       if e1' != e1 || e2' != e2 then BINARY (bo, e1', e2') else e
   438:   | QUESTION (e1, e2, e3) ->
   439:       let e1' = ve e1 in
   440:       let e2' = ve e2 in
   441:       let e3' = ve e3 in
   442:       if e1' != e1 || e2' != e2 || e3' != e3 then
   443:         QUESTION (e1', e2', e3') else e
   444:   | CAST ((s, dt), ie) ->
   445:       let s' = visit_cabsSpecifier vis s in
   446:       let dt' = visit_cabsDeclType vis false dt in
   447:       let ie' = visit_cabsInitExpression vis ie in
   448:       if s' != s || dt' != dt || ie' != ie then CAST ((s', dt'), ie') else e
   449:   | CALL (f, el) ->
   450:       let f' = ve f in
   451:       let el' = mapNoCopy ve el in
   452:       if f' != f || el' != el then CALL (f', el') else e
   453:   | COMMA el ->
   454:       let el' = mapNoCopy ve el in
   455:       if el' != el then COMMA (el') else e
   456:   | CONSTANT _ -> e
   457:   | VARIABLE s ->
   458:       let s' = vis#vvar s in
   459:       if s' != s then VARIABLE s' else e
   460:   | EXPR_SIZEOF (e1) ->
   461:       let e1' = ve e1 in
   462:       if e1' != e1 then EXPR_SIZEOF (e1') else e
   463:   | TYPE_SIZEOF (s, dt) ->
   464:       let s' = visit_cabsSpecifier vis s in
   465:       let dt' = visit_cabsDeclType vis false dt in
   466:       if s' != s || dt' != dt then TYPE_SIZEOF (s' ,dt') else e
   467:   | EXPR_ALIGNOF (e1) ->
   468:       let e1' = ve e1 in
   469:       if e1' != e1 then EXPR_ALIGNOF (e1') else e
   470:   | TYPE_ALIGNOF (s, dt) ->
   471:       let s' = visit_cabsSpecifier vis s in
   472:       let dt' = visit_cabsDeclType vis false dt in
   473:       if s' != s || dt' != dt then TYPE_ALIGNOF (s' ,dt') else e
   474:   | INDEX (e1, e2) ->
   475:       let e1' = ve e1 in
   476:       let e2' = ve e2 in
   477:       if e1' != e1 || e2' != e2 then INDEX (e1', e2') else e
   478:   | MEMBEROF (e1, n) ->
   479:       let e1' = ve e1 in
   480:       if e1' != e1 then MEMBEROF (e1', n) else e
   481:   | MEMBEROFPTR (e1, n) ->
   482:       let e1' = ve e1 in
   483:       if e1' != e1 then MEMBEROFPTR (e1', n) else e
   484:   | GNU_BODY b ->
   485:       let b' = visit_cabsBlock vis b in
   486:       if b' != b then GNU_BODY b' else e
   487:   | EXPR_PATTERN _ -> e
   488: 
   489: and visit_cabsInitExpression vis (ie: init_expression) : init_expression =
   490:   doVisit vis vis#vinitexpr childrenInitExpression ie
   491: and childrenInitExpression vis ie =
   492:   let rec childrenInitWhat iw =
   493:     match iw with
   494:       NEXT_INIT -> iw
   495:     | INFIELD_INIT (n, iw1) ->
   496:         let iw1' = childrenInitWhat iw1 in
   497:         if iw1' != iw1 then INFIELD_INIT (n, iw1') else iw
   498:     | ATINDEX_INIT (e, iw1) ->
   499:         let e' = visit_cabsExpression vis e in
   500:         let iw1' = childrenInitWhat iw1 in
   501:         if e' != e || iw1' != iw1 then ATINDEX_INIT (e', iw1') else iw
   502:     | ATINDEXRANGE_INIT (e1, e2) ->
   503:         let e1' = visit_cabsExpression vis e1 in
   504:         let e2' = visit_cabsExpression vis e2 in
   505:         if e1' != e1 || e2' != e2 then ATINDEXRANGE_INIT (e1, e2) else iw
   506:   in
   507:   match ie with
   508:     NO_INIT -> ie
   509:   | SINGLE_INIT e ->
   510:       let e' = visit_cabsExpression vis e in
   511:       if e' != e then SINGLE_INIT e' else ie
   512:   | COMPOUND_INIT il ->
   513:       let childrenOne ((iw, ie) as input) =
   514:         let iw' = childrenInitWhat iw in
   515:         let ie' = visit_cabsInitExpression vis ie in
   516:         if iw' != iw || ie' != ie then (iw', ie') else input
   517:       in
   518:       let il' = mapNoCopy childrenOne il in
   519:       if il' != il then COMPOUND_INIT il' else ie
   520: 
   521: 
   522: and visit_cabsAttribute vis (a: attribute) : attribute list =
   523:   doVisitList vis vis#vattr childrenAttribute a
   524: 
   525: and childrenAttribute vis ((n, el) as input) =
   526:   let el' = mapNoCopy (visit_cabsExpression vis) el in
   527:   if el' != el then (n, el') else input
   528: 
   529: and visit_cabsAttributes vis (al: attribute list) : attribute list =
   530:   mapNoCopyList (visit_cabsAttribute vis) al
   531: 
   532: let visit_cabsFile (vis: cabsVisitor) ((fname, f): file) : file =
   533:   (fname, mapNoCopyList (visit_cabsDefinition vis) f)
   534: 
   535:     (* end of file *)
   536: 
End ocaml section to src/flx_cil_cabsvisit.ml[1]
Start ocaml section to src/flx_cil_cabsvisit.mli[1 /1 ]
     1: # 1042 "./lpsrc/flx_frontc.ipk"
     2: 
     3: (* cabsvisit.mli *)
     4: (* interface for cabsvisit.ml *)
     5: 
     6: (* Different visiting actions. 'a will be instantiated with exp, instr, etc. *)
     7: type 'a visitAction =
     8:     SkipChildren                        (* Do not visit the children. Return
     9:                                          * the node as it is *)
    10:   | ChangeTo of 'a                      (* Replace the expression with the
    11:                                          * given one *)
    12:   | DoChildren                          (* Continue with the children of this
    13:                                          * node. Rebuild the node on return
    14:                                          * if any of the children changes
    15:                                          * (use == test) *)
    16:   | ChangeDoChildrenPost of 'a * ('a -> 'a) (* First consider that the entire
    17:                                           * exp is replaced by the first
    18:                                           * paramenter. Then continue with
    19:                                           * the children. On return rebuild
    20:                                           * the node if any of the children
    21:                                           * has changed and then apply the
    22:                                           * function on the node *)
    23: 
    24: type nameKind =
    25:     NVar                                (** Variable or function prototype
    26:                                            name *)
    27:   | NFun                                (** Function definition name *)
    28:   | NField                              (** The name of a field *)
    29:   | NType                               (** The name of a type *)
    30: 
    31: 
    32: (* All visit methods are called in preorder! (but you can use
    33:  * ChangeDoChildrenPost to change the order) *)
    34: class type cabsVisitor = object
    35:   method vexpr: Flx_cil_cabs.expression -> Flx_cil_cabs.expression visitAction   (* expressions *)
    36:   method vinitexpr: Flx_cil_cabs.init_expression -> Flx_cil_cabs.init_expression visitAction
    37:   method vstmt: Flx_cil_cabs.statement -> Flx_cil_cabs.statement list visitAction
    38:   method vblock: Flx_cil_cabs.block -> Flx_cil_cabs.block visitAction
    39:   method vvar: string -> string                  (* use of a variable
    40:                                                         * names *)
    41:   method vdef: Flx_cil_cabs.definition -> Flx_cil_cabs.definition list visitAction
    42:   method vtypespec: Flx_cil_cabs.typeSpecifier -> Flx_cil_cabs.typeSpecifier visitAction
    43:   method vdecltype: Flx_cil_cabs.decl_type -> Flx_cil_cabs.decl_type visitAction
    44: 
    45:       (* For each declaration we call vname *)
    46:   method vname: nameKind -> Flx_cil_cabs.specifier -> Flx_cil_cabs.name -> Flx_cil_cabs.name visitAction
    47:   method vspec: Flx_cil_cabs.specifier -> Flx_cil_cabs.specifier visitAction     (* specifier *)
    48:   method vattr: Flx_cil_cabs.attribute -> Flx_cil_cabs.attribute list visitAction
    49: 
    50: 
    51:   method vEnterScope: unit -> unit
    52:   method vExitScope: unit -> unit
    53: end
    54: 
    55: 
    56: class nopFlx_cil_cabsVisitor: cabsVisitor
    57: 
    58: 
    59: val visit_cabsTypeSpecifier: cabsVisitor ->
    60:                             Flx_cil_cabs.typeSpecifier -> Flx_cil_cabs.typeSpecifier
    61: val visit_cabsSpecifier: cabsVisitor -> Flx_cil_cabs.specifier -> Flx_cil_cabs.specifier
    62: 
    63: (** Visits a decl_type. The bool argument is saying whether we are ina
    64:   * function definition and thus the scope in a PROTO should extend until the
    65:   * end of the function *)
    66: val visit_cabsDeclType: cabsVisitor -> bool -> Flx_cil_cabs.decl_type -> Flx_cil_cabs.decl_type
    67: val visit_cabsDefinition: cabsVisitor -> Flx_cil_cabs.definition -> Flx_cil_cabs.definition list
    68: val visit_cabsBlock: cabsVisitor -> Flx_cil_cabs.block -> Flx_cil_cabs.block
    69: val visit_cabsStatement: cabsVisitor -> Flx_cil_cabs.statement -> Flx_cil_cabs.statement list
    70: val visit_cabsExpression: cabsVisitor -> Flx_cil_cabs.expression -> Flx_cil_cabs.expression
    71: val visit_cabsAttributes: cabsVisitor -> Flx_cil_cabs.attribute list
    72:                                      -> Flx_cil_cabs.attribute list
    73: val visit_cabsName: cabsVisitor -> nameKind
    74:                    -> Flx_cil_cabs.specifier -> Flx_cil_cabs.name -> Flx_cil_cabs.name
    75: val visit_cabsFile: cabsVisitor -> Flx_cil_cabs.file -> Flx_cil_cabs.file
    76: 
    77: 
    78: 
    79: (** Set by the visitor to the current location *)
    80: val visitorLocation: Flx_cil_cabs.cabsloc ref
End ocaml section to src/flx_cil_cabsvisit.mli[1]
Start ocaml section to src/flx_cil_clexer.mli[1 /1 ]
     1: # 1123 "./lpsrc/flx_frontc.ipk"
     2: 
     3: 
     4: (* This interface is generated manually. The corresponding .ml file is
     5:  * generated automatically and is placed in ../obj/clexer.ml. The reason we
     6:  * want this interface is to avoid confusing make with freshly generated
     7:  * interface files *)
     8: 
     9: 
    10: val init: filename:string -> lang:Flx_cil_cabs.lang_t -> Lexing.lexbuf
    11: val finish: unit -> unit
    12: 
    13: (* This is the main parser function *)
    14: val initial: Lexing.lexbuf -> Flx_cil_cparser.token
    15: 
    16: 
    17: val push_context: unit -> unit (* Start a context  *)
    18: val add_type: string -> unit (* Add a new string as a type name  *)
    19: val add_identifier: string -> unit (* Add a new string as a variable name  *)
    20: val pop_context: unit -> unit (* Remove all names added in this context  *)
    21: 
End ocaml section to src/flx_cil_clexer.mli[1]
Start data section to src/flx_cil_clexer.mll[1 /1 ]
     1: (* FrontC -- lexical analyzer
     2: **
     3: ** 1.0  3.22.99 Hugues Cassé    First version.
     4: ** 2.0  George Necula 12/12/00: Many extensions
     5: *)
     6: {
     7: open Flx_cil_cparser
     8: open Flx_cil_pretty
     9: exception Eof
    10: exception InternalError of string
    11: module E = Flx_cil_errormsg
    12: module H = Hashtbl
    13: 
    14: let currentLoc () =
    15:   let l, f, c = E.getPosition () in
    16:   { Flx_cil_cabs.lineno   = l;
    17:     Flx_cil_cabs.filename = f;
    18:     Flx_cil_cabs.byteno   = c; }
    19: 
    20: (* Some debugging support for line numbers *)
    21: let dbgToken (t: token) =
    22:   if false then begin
    23:     ignore (E.log "%a" insert
    24:               (match t with
    25:                 IDENT (n, l) -> dprintf "IDENT(%s,%d)\n" n l.Flx_cil_cabs.lineno
    26:               | LBRACE l -> dprintf "LBRACE(%d)\n" l.Flx_cil_cabs.lineno
    27:               | RBRACE l -> dprintf "RBRACE(%d)\n" l.Flx_cil_cabs.lineno
    28:               | IF l -> dprintf "IF(%d)\n" l.Flx_cil_cabs.lineno
    29:               | SWITCH l -> dprintf "SWITCH(%d)\n" l.Flx_cil_cabs.lineno
    30:               | RETURN l -> dprintf "RETURN(%d)\n" l.Flx_cil_cabs.lineno
    31:               | _ -> nil));
    32:     t
    33:   end else
    34:     t
    35: 
    36: (*
    37: ** Keyword hashtable
    38: *)
    39: 
    40: let c_keywords =
    41:     [
    42:       ("_Bool", fun loc -> BOOL loc);
    43:       ("_Imaginary", fun loc -> IMAGINARY loc);
    44:       ("_Complex", fun loc -> COMPLEX loc);
    45:       ("auto", fun loc -> AUTO loc);
    46:       ("const", fun loc -> CONST loc);
    47:       ("__const", fun loc -> CONST loc);
    48:       ("__const__", fun loc -> CONST loc);
    49:       ("static", fun loc -> STATIC loc);
    50:       ("extern", fun loc -> EXTERN loc);
    51:       ("long", fun loc -> LONG loc);
    52:       ("short", fun loc -> SHORT loc);
    53:       ("register", fun loc -> REGISTER loc);
    54:       ("signed", fun loc -> SIGNED loc);
    55:       ("__signed", fun loc -> SIGNED loc);
    56:       ("unsigned", fun loc -> UNSIGNED loc);
    57:       ("volatile", fun loc -> VOLATILE loc);
    58:       ("__volatile", fun loc -> VOLATILE loc);
    59:       (* WW: see /usr/include/sys/cdefs.h for why __signed and __volatile
    60:        * are accepted GCC-isms *)
    61:       ("char", fun loc -> CHAR loc);
    62:       ("int", fun loc -> INT loc);
    63:       ("float", fun loc -> FLOAT loc);
    64:       ("double", fun loc -> DOUBLE loc);
    65:       ("void", fun loc -> VOID loc);
    66:       ("enum", fun loc -> ENUM loc);
    67:       ("struct", fun loc -> STRUCT loc);
    68:       ("typedef", fun loc -> TYPEDEF loc);
    69:       ("union", fun loc -> UNION loc);
    70:       ("break", fun loc -> BREAK loc);
    71:       ("continue", fun loc -> CONTINUE loc);
    72:       ("goto", fun loc -> GOTO loc);
    73:       ("return", fun loc -> dbgToken (RETURN loc));
    74:       ("switch", fun loc -> dbgToken (SWITCH loc));
    75:       ("case", fun loc -> CASE loc);
    76:       ("default", fun loc -> DEFAULT loc);
    77:       ("while", fun loc -> WHILE loc);
    78:       ("do", fun loc -> DO loc);
    79:       ("for", fun loc -> FOR loc);
    80:       ("if", fun loc -> dbgToken (IF loc));
    81:       ("else", fun _ -> ELSE);
    82:       (*** Implementation specific keywords ***)
    83:       ("__signed__", fun loc -> SIGNED loc);
    84:       ("__inline__", fun loc -> INLINE loc);
    85:       ("inline", fun loc -> INLINE loc);
    86:       ("__inline", fun loc -> INLINE loc);
    87:       ("_inline", fun loc -> INLINE loc);
    88:       ("__attribute__", fun loc -> ATTRIBUTE loc);
    89:       ("__attribute", fun loc -> ATTRIBUTE loc);
    90:       ("__blockattribute__", fun _ -> BLOCKATTRIBUTE);
    91:       ("__blockattribute", fun _ -> BLOCKATTRIBUTE);
    92:       ("__asm__", fun loc -> ASM loc);
    93:       ("asm", fun loc -> ASM loc);
    94:       ("__typeof__", fun loc -> TYPEOF loc);
    95:       ("__typeof", fun loc -> TYPEOF loc);
    96:       ("typeof", fun loc -> TYPEOF loc);
    97:       ("__alignof", fun loc -> ALIGNOF loc);
    98:       ("__alignof__", fun loc -> ALIGNOF loc);
    99:       ("__volatile__", fun loc -> VOLATILE loc);
   100:       ("__volatile", fun loc -> VOLATILE loc);
   101: 
   102:       ("__FUNCTION__", fun loc -> FUNCTION__ loc);
   103:       ("__func__", fun loc -> FUNCTION__ loc); (* ISO 6.4.2.2 *)
   104:       ("__PRETTY_FUNCTION__", fun loc -> PRETTY_FUNCTION__ loc);
   105:       ("__label__", fun _ -> LABEL__);
   106:       (*** weimer: GCC arcana ***)
   107:       ("__restrict", fun loc -> RESTRICT loc);
   108:       ("restrict", fun loc -> RESTRICT loc);
   109: (*      ("__extension__", EXTENSION); *)
   110:       (**** MS VC ***)
   111:       ("__int64", fun _ -> INT64 (currentLoc ()));
   112:       ("__int32", fun loc -> INT loc);
   113:       ("_cdecl",  fun _ -> MSATTR ("_cdecl", currentLoc ()));
   114:       ("__cdecl", fun _ -> MSATTR ("__cdecl", currentLoc ()));
   115:       ("_stdcall", fun _ -> MSATTR ("_stdcall", currentLoc ()));
   116:       ("__stdcall", fun _ -> MSATTR ("__stdcall", currentLoc ()));
   117:       ("_fastcall", fun _ -> MSATTR ("_fastcall", currentLoc ()));
   118:       ("__fastcall", fun _ -> MSATTR ("__fastcall", currentLoc ()));
   119:       ("__w64", fun _ -> MSATTR("__w64", currentLoc ()));
   120:       ("__declspec", fun loc -> DECLSPEC loc);
   121:       ("__forceinline", fun loc -> INLINE loc); (* !! we turn forceinline
   122:                                                  * into inline *)
   123:       ("__try", fun loc -> TRY loc);
   124:       ("__except", fun loc -> EXCEPT loc);
   125:       ("__finally", fun loc -> FINALLY loc);
   126:       (* weimer: some files produced by 'GCC -E' expect this type to be
   127:        * defined *)
   128:       ("__builtin_va_list",
   129:        fun _ -> NAMED_TYPE ("__builtin_va_list", currentLoc ()));
   130:       ("__builtin_va_arg", fun loc -> BUILTIN_VA_ARG loc);
   131:       (* On some versions of GCC __thread is a regular identifier *)
   132:       ("__thread", fun loc ->
   133:                       if Flx_cil_machdep.__thread_is_keyword then
   134:                          THREAD loc
   135:                        else
   136:                          IDENT ("__thread", loc));
   137:     ]
   138: 
   139: let cxx_extra_keywords = [
   140:       ("class", fun loc -> CLASS loc);
   141:       ("namespace", fun loc -> NAMESPACE loc);
   142:       ("using", fun loc -> USING loc);
   143:       ("typename", fun loc -> TYPENAME loc);
   144:       ("templatename", fun loc -> TEMPLATENAME loc);
   145:       ("public", fun loc -> PUBLIC loc);
   146:       ("private", fun loc -> PRIVATE loc);
   147:       ("protected", fun loc -> PROTECTED loc);
   148:       ("virtual", fun loc -> VIRTUAL loc);
   149: ]
   150: 
   151: let lexicon = H.create 211
   152: let class_list = ref [""]
   153: 
   154: let init_lexicon (langind : Flx_cil_cabs.lang_t) =
   155:   H.clear lexicon;
   156:   List.iter
   157:     (fun (key, builder) -> H.add lexicon key builder)
   158:     c_keywords
   159:   ;
   160:   if langind = `Cxx then
   161:    List.iter
   162:     (fun (key, builder) -> H.add lexicon key builder)
   163:     cxx_extra_keywords
   164:   ;
   165:   class_list := [""]
   166: 
   167: let push_class s = class_list := s :: !class_list
   168: let pop_class () = class_list := List.tl !class_list
   169: 
   170: (* Mark an identifier as a type name. The old mapping is preserved and will
   171:  * be reinstated when we exit this context *)
   172: let add_type name =
   173:    (* ignore (print_string ("adding type name " ^ name ^ "\n"));  *)
   174:    H.add lexicon name (fun loc -> NAMED_TYPE (name, loc))
   175: 
   176: let context : string list list ref = ref []
   177: 
   178: let push_context _ = context := []::!context
   179: 
   180: let pop_context _ =
   181:   match !context with
   182:     [] -> raise (InternalError "Empty context stack")
   183:   | con::sub ->
   184:                 (context := sub;
   185:                 List.iter (fun name ->
   186:                            (* ignore (print_string ("removing lexicon for " ^ name ^ "\n")); *)
   187:                             H.remove lexicon name) con)
   188: 
   189: (* Mark an identifier as a variable name. The old mapping is preserved and
   190:  * will be reinstated when we exit this context  *)
   191: let add_identifier name =
   192:   match !context with
   193:     [] -> () (* Just ignore raise (InternalError "Empty context stack") *)
   194:   | con::sub ->
   195:       (context := (name::con)::sub;
   196:        (*                print_string ("adding IDENT for " ^ name ^ "\n"); *)
   197:        H.add lexicon name (fun loc ->
   198:          dbgToken (IDENT (name, loc))))
   199: 
   200: 
   201: (*
   202: ** Useful primitives
   203: *)
   204: let scan_ident id =
   205:   let here = currentLoc () in
   206:   let s = ref "" in
   207:   for i = 0 to String.length id - 1 do
   208:     let ch = id.[i] in
   209:     if ch > ' ' then s := !s ^ String.make 1 ch
   210:   done;
   211:   try (H.find lexicon !s) here
   212:   (* default to variable name, as opposed to type *)
   213:   with Not_found -> dbgToken (IDENT (!s, here))
   214: 
   215: 
   216: (*
   217: ** Buffer processor
   218: *)
   219: 
   220: let attribDepth = ref 0 (* Remembers the nesting level when parsing
   221:                          * attributes *)
   222: 
   223: 
   224: let init ~(filename: string) ~(lang: Flx_cil_cabs.lang_t) : Lexing.lexbuf =
   225:   attribDepth := 0;
   226:   init_lexicon lang;
   227:   (* Inititialize the pointer in Flx_cil_errormsg *)
   228:   Flx_cil_lexerhack.add_type := add_type;
   229:   Flx_cil_lexerhack.push_context := push_context;
   230:   Flx_cil_lexerhack.pop_context := pop_context;
   231:   Flx_cil_lexerhack.push_class:= push_class;
   232:   Flx_cil_lexerhack.pop_class := pop_class;
   233:   Flx_cil_lexerhack.add_identifier := add_identifier;
   234:   let get_lang () = lang in
   235:   Flx_cil_lexerhack.get_lang := get_lang;
   236:   E.startParsing filename
   237: 
   238: 
   239: let finish () =
   240:   E.finishParsing ()
   241: 
   242: (*** Error handling ***)
   243: let error msg =
   244:   E.parse_error msg
   245: 
   246: 
   247: (*** escape character management ***)
   248: let scan_escape (char: char) : int64 =
   249:   let result = match char with
   250:     'n' -> '\n'
   251:   | 'r' -> '\r'
   252:   | 't' -> '\t'
   253:   | 'b' -> '\b'
   254:   | 'f' -> '\012'  (* ASCII code 12 *)
   255:   | 'v' -> '\011'  (* ASCII code 11 *)
   256:   | 'a' -> '\007'  (* ASCII code 7 *)
   257:   | 'e' -> '\027'  (* ASCII code 27. This is a GCC extension *)
   258:   | '\'' -> '\''
   259:   | '"'-> '"'     (* '"' *)
   260:   | '?' -> '?'
   261:   | '\\' -> '\\'
   262:   | other -> error ("Unrecognized escape sequence: \\" ^ (String.make 1 other))
   263:   in
   264:   Int64.of_int (Char.code result)
   265: 
   266: let scan_hex_escape str =
   267:   let radix = Int64.of_int 16 in
   268:   let the_value = ref Int64.zero in
   269:   (* start at character 2 to skip the \x *)
   270:   for i = 2 to (String.length str) - 1 do
   271:     let thisDigit = Flx_cil_cabs_helper.valueOfDigit (String.get str i) in
   272:     (* the_value := !the_value * 16 + thisDigit *)
   273:     the_value := Int64.add (Int64.mul !the_value radix) thisDigit
   274:   done;
   275:   !the_value
   276: 
   277: let scan_oct_escape str =
   278:   let radix = Int64.of_int 8 in
   279:   let the_value = ref Int64.zero in
   280:   (* start at character 1 to skip the \x *)
   281:   for i = 1 to (String.length str) - 1 do
   282:     let thisDigit = Flx_cil_cabs_helper.valueOfDigit (String.get str i) in
   283:     (* the_value := !the_value * 8 + thisDigit *)
   284:     the_value := Int64.add (Int64.mul !the_value radix) thisDigit
   285:   done;
   286:   !the_value
   287: 
   288: let lex_hex_escape remainder lexbuf =
   289:   let prefix = scan_hex_escape (Lexing.lexeme lexbuf) in
   290:   prefix :: remainder lexbuf
   291: 
   292: let lex_oct_escape remainder lexbuf =
   293:   let prefix = scan_oct_escape (Lexing.lexeme lexbuf) in
   294:   prefix :: remainder lexbuf
   295: 
   296: let lex_simple_escape remainder lexbuf =
   297:   let lexchar = Lexing.lexeme_char lexbuf 1 in
   298:   let prefix = scan_escape lexchar in
   299:   prefix :: remainder lexbuf
   300: 
   301: let lex_unescaped remainder lexbuf =
   302:   let prefix = Int64.of_int (Char.code (Lexing.lexeme_char lexbuf 0)) in
   303:   prefix :: remainder lexbuf
   304: 
   305: let make_char (i:int64):char =
   306:   let min_val = Int64.zero in
   307:   let max_val = Int64.of_int 255 in
   308:   (* if i < 0 || i > 255 then error*)
   309:   if compare i min_val < 0 || compare i max_val > 0 then begin
   310:     let msg = Printf.sprintf "clexer:make_char: character 0x%Lx too big" i in
   311:     error msg
   312:   end;
   313:   Char.chr (Int64.to_int i)
   314: 
   315: 
   316: (* ISO standard locale-specific function to convert a wide character
   317:  * into a sequence of normal characters. Here we work on strings.
   318:  * We convert L"Hi" to "H\000i\000"
   319:   matth: this seems unused.
   320: let wbtowc wstr =
   321:   let len = String.length wstr in
   322:   let dest = String.make (len * 2) '\000' in
   323:   for i = 0 to len-1 do
   324:     dest.[i*2] <- wstr.[i] ;
   325:   done ;
   326:   dest
   327: *)
   328: 
   329: (* This function converst the "Hi" in L"Hi" to { L'H', L'i', L'\0' }
   330:   matth: this seems unused.
   331: let wstr_to_warray wstr =
   332:   let len = String.length wstr in
   333:   let res = ref "{ " in
   334:   for i = 0 to len-1 do
   335:     res := !res ^ (Printf.sprintf "L'%c', " wstr.[i])
   336:   done ;
   337:   res := !res ^ "}" ;
   338:   !res
   339: *)
   340: 
   341: (* Pragmas get explicit end-of-line tokens.
   342:  * Elsewhere they are silently discarded as whitespace. *)
   343: let pragmaLine = ref false
   344: 
   345: }
   346: 
   347: let decdigit = ['0'-'9']
   348: let octdigit = ['0'-'7']
   349: let hexdigit = ['0'-'9' 'a'-'f' 'A'-'F']
   350: let letter = ['a'- 'z' 'A'-'Z']
   351: 
   352: 
   353: let usuffix = ['u' 'U']
   354: let lsuffix = "l"|"L"|"ll"|"LL"
   355: let intsuffix = lsuffix | usuffix | usuffix lsuffix | lsuffix usuffix
   356: 
   357: let hexprefix = '0' ['x' 'X']
   358: 
   359: let intnum = decdigit+ intsuffix?
   360: let octnum = '0' octdigit+ intsuffix?
   361: let hexnum = hexprefix hexdigit+ intsuffix?
   362: 
   363: let exponent = ['e' 'E']['+' '-']? decdigit+
   364: let fraction  = '.' decdigit+
   365: let decfloat = (intnum? fraction)
   366:               |(intnum exponent)
   367:               |(intnum? fraction exponent)
   368:               | (intnum '.')
   369:               | (intnum '.' exponent)
   370: 
   371: let hexfraction = hexdigit* '.' hexdigit+ | hexdigit+
   372: let binexponent = ['p' 'P'] ['+' '-']? decdigit+
   373: let hexfloat = hexprefix hexfraction binexponent
   374:              | hexprefix hexdigit+   binexponent
   375: 
   376: let floatsuffix = ['f' 'F' 'l' 'L']
   377: let floatnum = (decfloat | hexfloat) floatsuffix?
   378: 
   379: let ident = (letter|'_')(letter|decdigit|'_')*
   380: let attribident = (letter|'_')(letter|decdigit|'_'|':')
   381: let blank = [' ' '\t' '\012' '\r']+
   382: let spaces = [' ' '\t' '\012' '\r']*
   383: let escape = '\\' _
   384: let hex_escape = '\\' ['x' 'X'] hexdigit+
   385: let oct_escape = '\\' octdigit octdigit? octdigit?
   386: let sym =
   387:   "<<=" | ">>=" |
   388:   "<<" | ">>" | "==" | "!=" | "<=" | ">=" |
   389:   "+=" | "-=" | "*=" | "/=" | "%=" | "&=" | "|=" | "^=" | "->" |
   390:   "+" | "-" | "*" | "/" | "%" | "&" | "|" | "^" | "!" | "~" | "="
   391: 
   392: 
   393: let operator = "operator" spaces sym
   394: let oident = operator | ident
   395: let qualified_name = ("::" spaces)?oident (spaces "::" spaces oident)*
   396: 
   397: rule initial = parse
   398: | "/*"                    { let _ = comment lexbuf in initial lexbuf}
   399: |               "//"                    { endline lexbuf }
   400: |               blank                   {initial lexbuf}
   401: |               '\n'                    { E.newline ();
   402:                                           if !pragmaLine then
   403:                                             begin
   404:                                               pragmaLine := false;
   405:                                               PRAGMA_EOL
   406:                                             end
   407:                                           else
   408:                                             initial lexbuf }
   409: |               '#'                     { hash lexbuf}
   410: |               "_Pragma"               { PRAGMA (currentLoc ()) }
   411: |               '\''                    { CST_CHAR (chr lexbuf, currentLoc ())}
   412: |               "L'"                    { CST_WCHAR (chr lexbuf, currentLoc ()) }
   413: |               '"'                     { (* '"' *)
   414: (* matth: BUG:  this could be either a regular string or a wide string.
   415:  *  e.g. if it's the "world" in
   416:  *     L"Hello, " "world"
   417:  *  then it should be treated as wide even though there's no L immediately
   418:  *  preceding it.  See test/small1/wchar5.c for a failure case. *)
   419:                                           try CST_STRING (str lexbuf, currentLoc ())
   420:                                           with e ->
   421:                                              raise (InternalError
   422:                                                      ("str: " ^
   423:                                                       Printexc.to_string e))}
   424: |               "L\""                   { (* weimer: wchar_t string literal *)
   425:                                           try CST_WSTRING(str lexbuf, currentLoc ())
   426:                                           with e ->
   427:                                              raise (InternalError
   428:                                                      ("wide string: " ^
   429:                                                       Printexc.to_string e))}
   430: |               floatnum                {CST_FLOAT (Lexing.lexeme lexbuf, currentLoc ())}
   431: |               hexnum                  {CST_INT (Lexing.lexeme lexbuf, currentLoc ())}
   432: |               octnum                  {CST_INT (Lexing.lexeme lexbuf, currentLoc ())}
   433: |               intnum                  {CST_INT (Lexing.lexeme lexbuf, currentLoc ())}
   434: |               "!quit!"                {EOF}
   435: |               "..."                   {ELLIPSIS}
   436: |               "+="                    {PLUS_EQ}
   437: |               "-="                    {MINUS_EQ}
   438: |               "*="                    {STAR_EQ}
   439: |               "/="                    {SLASH_EQ}
   440: |               "%="                    {PERCENT_EQ}
   441: |               "|="                    {PIPE_EQ}
   442: |               "&="                    {AND_EQ}
   443: |               "^="                    {CIRC_EQ}
   444: |               "<<="                   {INF_INF_EQ}
   445: |               ">>="                   {SUP_SUP_EQ}
   446: |               "<<"                    {INF_INF}
   447: |               ">>"                    {SUP_SUP}
   448: |               "=="                    {EQ_EQ}
   449: |               "!="                    {EXCLAM_EQ}
   450: |               "<="                    {INF_EQ}
   451: |               ">="                    {SUP_EQ}
   452: |               "="                             {EQ}
   453: |               "<"                             {INF}
   454: |               ">"                             {SUP}
   455: |               "++"                    {PLUS_PLUS (currentLoc ())}
   456: |               "--"                    {MINUS_MINUS (currentLoc ())}
   457: |               "->"                    {ARROW}
   458: |               '+'                             {PLUS (currentLoc ())}
   459: |               '-'                             {MINUS (currentLoc ())}
   460: |               '*'                             {STAR (currentLoc ())}
   461: |               '/'                             {SLASH}
   462: |               '%'                             {PERCENT}
   463: |               '!'                     {EXCLAM (currentLoc ())}
   464: |               "&&"                    {AND_AND (currentLoc ())}
   465: |               "||"                    {PIPE_PIPE}
   466: |               '&'                             {AND (currentLoc ())}
   467: |               '|'                             {PIPE}
   468: |               '^'                             {CIRC}
   469: |               '?'                             {QUEST}
   470: |               ':'                             {COLON}
   471: |               '~'                    {TILDE (currentLoc ())}
   472: 
   473: |               '{'                    {dbgToken (LBRACE (currentLoc ()))}
   474: |               '}'                    {dbgToken (RBRACE (currentLoc ()))}
   475: |               '['                             {LBRACKET}
   476: |               ']'                             {RBRACKET}
   477: |               '('                    {dbgToken (LPAREN (currentLoc ())) }
   478: |               ')'                             {RPAREN}
   479: |               ';'                    {dbgToken (SEMICOLON (currentLoc ())) }
   480: |               ','                             {COMMA}
   481: |               '.'                             {DOT}
   482: |               "sizeof"                {SIZEOF (currentLoc ())}
   483: |               "__asm"                 { if !Flx_cil_cprint.msvcMode then
   484:                                              MSASM (msasm lexbuf, currentLoc ())
   485:                                           else (ASM (currentLoc ())) }
   486: (* jms: a hack to change unsigned int to plain unsigned to fix
   487: an shift/reduce parsing problem
   488: with C++ class base list/unnamed bitfield *)
   489: 
   490: |              "unsigned" (' '|'\t')+ "int" {UNSIGNED (currentLoc())}
   491: 
   492: (* sm: tree transformation keywords *)
   493: |               "@transform"            {AT_TRANSFORM (currentLoc ())}
   494: |               "@transformExpr"        {AT_TRANSFORMEXPR (currentLoc ())}
   495: |               "@specifier"            {AT_SPECIFIER (currentLoc ())}
   496: |               "@expr"                 {AT_EXPR (currentLoc ())}
   497: |               "@name"                 {AT_NAME}
   498: 
   499: (* __extension__ is a black. The parser runs into some conflicts if we let it
   500:  * pass *)
   501: |               "__extension__"         {initial lexbuf }
   502: |              qualified_name
   503:                {
   504:                  scan_ident (Lexing.lexeme lexbuf)
   505:                }
   506: |               eof                     {EOF}
   507: |               _                       {E.parse_error
   508:                                                 "Invalid symbol"
   509:                                                 (Lexing.lexeme_start lexbuf)
   510:                                                 (Lexing.lexeme_end lexbuf);
   511:                                                 initial lexbuf}
   512: and comment =
   513:     parse
   514:       "*/"                              { () }
   515: |     '\n'                              { E.newline (); comment lexbuf }
   516: |               _                       { comment lexbuf }
   517: 
   518: (* # <line number> <file name> ... *)
   519: and hash = parse
   520:   '\n'          { E.newline (); initial lexbuf}
   521: | blank         { hash lexbuf}
   522: | intnum        { (* We are seeing a line number. This is the number for the
   523:                    * next line *)
   524:                   E.setCurrentLine (int_of_string (Lexing.lexeme lexbuf) - 1);
   525:                   (* A file name must follow *)
   526:                   file lexbuf }
   527: | "line"        { hash lexbuf } (* MSVC line number info *)
   528:                 (* MSVC warning pragmas have very irregular syntax. We parse
   529:                  * them as a whole line. *)
   530: | "pragma" blank "warning" { let here = currentLoc () in
   531:                              PRAGMA_LINE ("warning" ^ pragma lexbuf, here)
   532:                            }
   533: | "pragma" blank "GCC"     { let here = currentLoc () in
   534:                              PRAGMA_LINE ("GCC" ^ pragma lexbuf, here)
   535:                            }
   536: | "pragma"      { pragmaLine := true; PRAGMA (currentLoc ()) }
   537: | _             { endline lexbuf}
   538: 
   539: and file =  parse
   540:         '\n'                    {E.newline (); initial lexbuf}
   541: |       blank                   {file lexbuf}
   542: |       '"' [^ '\012' '\t' '"']* '"'    { (* '"' *)
   543:                                    let n = Lexing.lexeme lexbuf in
   544:                                    let n1 = String.sub n 1
   545:                                        ((String.length n) - 2) in
   546:                                    E.setCurrentFile n1;
   547:                                  endline lexbuf}
   548: 
   549: |       _                       {endline lexbuf}
   550: 
   551: and endline = parse
   552:         '\n'                    { E.newline (); initial lexbuf}
   553: |   eof                         { EOF }
   554: |       _                       { endline lexbuf}
   555: 
   556: and pragma = parse
   557:    '\n'                 { E.newline (); "" }
   558: |   _                   { let cur = Lexing.lexeme lexbuf in
   559:                           cur ^ (pragma lexbuf) }
   560: 
   561: and str = parse
   562:         '"'             {[]} (* no nul terminiation in CST_STRING *)
   563: |       hex_escape      {lex_hex_escape str lexbuf}
   564: |       oct_escape      {lex_oct_escape str lexbuf}
   565: |       escape          {lex_simple_escape str lexbuf}
   566: |       _               {lex_unescaped str lexbuf}
   567: 
   568: and chr =  parse
   569:         '\''            {[]}
   570: |       hex_escape      {lex_hex_escape chr lexbuf}
   571: |       oct_escape      {lex_oct_escape chr lexbuf}
   572: |       escape          {lex_simple_escape chr lexbuf}
   573: |       _               {lex_unescaped chr lexbuf}
   574: 
   575: and msasm = parse
   576:     blank               { msasm lexbuf }
   577: |   '{'                 { msasminbrace lexbuf }
   578: |   _                   { let cur = Lexing.lexeme lexbuf in
   579:                           cur ^ (msasmnobrace lexbuf) }
   580: 
   581: and msasminbrace = parse
   582:     '}'                 { "" }
   583: |   _                   { let cur = Lexing.lexeme lexbuf in
   584:                           cur ^ (msasminbrace lexbuf) }
   585: and msasmnobrace = parse
   586:    ['}' ';' '\n']       { lexbuf.Lexing.lex_curr_pos <-
   587:                                lexbuf.Lexing.lex_curr_pos - 1;
   588:                           "" }
   589: |  "__asm"              { lexbuf.Lexing.lex_curr_pos <-
   590:                                lexbuf.Lexing.lex_curr_pos - 5;
   591:                           "" }
   592: |  _                    { let cur = Lexing.lexeme lexbuf in
   593: 
   594:                           cur ^ (msasmnobrace lexbuf) }
   595: 
   596: and attribute = parse
   597:    '\n'                 { E.newline (); attribute lexbuf }
   598: |  blank                { attribute lexbuf }
   599: |  '('                  { incr attribDepth; LPAREN (currentLoc ()) }
   600: |  ')'                  { decr attribDepth;
   601:                           if !attribDepth = 0 then
   602:                             initial lexbuf (* Skip the last closed paren *)
   603:                           else
   604:                             RPAREN }
   605: |  attribident          { IDENT (Lexing.lexeme lexbuf, currentLoc ()) }
   606: 
   607: |  '\''                 { CST_CHAR (chr lexbuf, currentLoc ())}
   608: |  '"'                  { (* '"' *)
   609:                                           try CST_STRING (str lexbuf, currentLoc ())
   610:                                           with e ->
   611:                                              raise (InternalError "str")}
   612: |  floatnum             {CST_FLOAT (Lexing.lexeme lexbuf, currentLoc ())}
   613: |  hexnum               {CST_INT (Lexing.lexeme lexbuf, currentLoc ())}
   614: |  octnum               {CST_INT (Lexing.lexeme lexbuf, currentLoc ())}
   615: |  intnum               {CST_INT (Lexing.lexeme lexbuf, currentLoc ())}
   616: 
   617: 
   618: {
   619: 
   620: }
   621: 
End data section to src/flx_cil_clexer.mll[1]
Start data section to src/flx_cil_cparser.mly[1 /1 ]
     1: /*
     2: (**
     3: ** 1.0  3.22.99 Hugues Cassé    First version.
     4: ** 2.0  George Necula 12/12/00: Many extensions
     5: *)
     6: */
     7: %{
     8: open Flx_cil_cabs
     9: open Flx_cil_cabs_helper
    10: module E = Flx_cil_errormsg
    11: 
    12: let parse_error msg : unit =       (* sm: c++-mode highlight hack: -> ' <- *)
    13:   E.parse_error msg
    14: 
    15: let print = print_string
    16: 
    17: 
    18: let currentLoc () =
    19:   let l, f, c = E.getPosition () in
    20:   { lineno   = l; filename = f; byteno   = c; }
    21: 
    22: let cabslu = {lineno = -10; filename = "cabs loc unknown"; byteno = -10;}
    23: 
    24: (*
    25: ** Expression building
    26: *)
    27: let smooth_expression lst =
    28:   match lst with
    29:     [] -> NOTHING
    30:   | [expr] -> expr
    31:   | _ -> COMMA (lst)
    32: 
    33: 
    34: let currentFunctionName = ref "<outside any function>"
    35: 
    36: let announceFunctionName ((n, decl, _, _):name) =
    37:   !Flx_cil_lexerhack.add_identifier n;
    38:   (* Start a context that includes the parameter names and the whole body.
    39:    * Will pop when we finish parsing the function body *)
    40:   !Flx_cil_lexerhack.push_context ();
    41:   (* Go through all the parameter names and mark them as identifiers *)
    42:   let rec findProto = function
    43:       PROTO (d, args, _) when isJUSTBASE d ->
    44:         List.iter (fun (_, (an, _, _, _)) -> !Flx_cil_lexerhack.add_identifier an) args
    45: 
    46:     | PROTO (d, _, _) -> findProto d
    47:     | PARENTYPE (_, d, _) -> findProto d
    48:     | PTR (_, d) -> findProto d
    49:     | ARRAY (d, _, _) -> findProto d
    50:     | _ -> parse_error "Cannot find the prototype in a function definition";
    51:            raise Parsing.Parse_error
    52: 
    53:   and isJUSTBASE = function
    54:       JUSTBASE -> true
    55:     | PARENTYPE (_, d, _) -> isJUSTBASE d
    56:     | _ -> false
    57:   in
    58:   findProto decl;
    59:   currentFunctionName := n
    60: 
    61: 
    62: 
    63: let applyPointer (ptspecs: attribute list list) (dt: decl_type)
    64:        : decl_type =
    65:   (* Outer specification first *)
    66:   let rec loop = function
    67:       [] -> dt
    68:     | attrs :: rest -> PTR(attrs, loop rest)
    69:   in
    70:   loop ptspecs
    71: 
    72: let doDeclaration (loc: cabsloc) (specs: spec_elem list) (nl: init_name list) : definition =
    73:   if isTypedef specs then begin
    74:     (* Tell the lexer about the new type names *)
    75:     List.iter (fun ((n, _, _, _), _) -> !Flx_cil_lexerhack.add_type n) nl;
    76:     TYPEDEF ((specs, List.map (fun (n, _) -> n) nl), loc)
    77:   end else
    78:     if nl = [] then
    79:       ONLYTYPEDEF (specs, loc)
    80:     else begin
    81:       (* Tell the lexer about the new variable names *)
    82:       List.iter (fun ((n, _, _, _), _) -> !Flx_cil_lexerhack.add_identifier n) nl;
    83:       DECDEF ((specs, nl), loc)
    84:     end
    85: 
    86: 
    87: let doFunctionDef (loc: cabsloc)
    88:                   (lend: cabsloc)
    89:                   (specs: spec_elem list)
    90:                   (n: name)
    91:                   (b: block) : definition =
    92:   let fname = (specs, n) in
    93:   FUNDEF (fname, b, loc, lend)
    94: 
    95: 
    96: let doOldParDecl (names: string list)
    97:                  ((pardefs: name_group list), (isva: bool))
    98:     : single_name list * bool =
    99:   let findOneName n =
   100:     (* Search in pardefs for the definition for this parameter *)
   101:     let rec loopGroups = function
   102:         [] -> ([SpecType Tint], (n, JUSTBASE, [], cabslu))
   103:       | (specs, names) :: restgroups ->
   104:           let rec loopNames = function
   105:               [] -> loopGroups restgroups
   106:             | ((n',_, _, _) as sn) :: _ when n' = n -> (specs, sn)
   107:             | _ :: restnames -> loopNames restnames
   108:           in
   109:           loopNames names
   110:     in
   111:     loopGroups pardefs
   112:   in
   113:   let args = List.map findOneName names in
   114:   (args, isva)
   115: 
   116: let checkConnective (s : string) : unit =
   117: begin
   118:   (* checking this means I could possibly have more connectives, with *)
   119:   (* different meaning *)
   120:   if (s <> "to") then (
   121:     parse_error "transformer connective must be 'to'";
   122:     raise Parsing.Parse_error
   123:   )
   124:   else ()
   125: end
   126: 
   127: (* takes a not-nul-terminated list, and converts it to a string. *)
   128: let rec intlist_to_string (str: int64 list):string =
   129:   match str with
   130:     [] -> ""  (* add nul-termination *)
   131:   | value::rest ->
   132:       let this_char =
   133:         if (compare value (Int64.of_int 255) > 0)
   134:            || (compare value Int64.zero < 0)
   135:         then begin
   136:           let msg = Printf.sprintf "cparser:intlist_to_string: character 0x%Lx too big" value in
   137:           parse_error msg;
   138:           raise Parsing.Parse_error
   139:         end
   140:         else
   141:           String.make 1 (Char.chr (Int64.to_int value))
   142:       in
   143:       this_char ^ (intlist_to_string rest)
   144: 
   145: let fst3 (result, _, _) = result
   146: let snd3 (_, result, _) = result
   147: let trd3 (_, _, result) = result
   148: 
   149: let mkflds accessible ls =
   150:   let accessible = ref accessible in
   151:   let nls = ref [] in
   152:   List.iter
   153:   (fun x -> match x with
   154:   | `Fields x -> if !accessible then nls := x :: !nls
   155:   | `Access_public -> accessible := true
   156:   | `Access_private | `Access_protected -> accessible := false
   157:   )
   158:   ls
   159:   ;
   160:   Some (List.rev !nls)
   161: 
   162: %}
   163: 
   164: %token <string * Flx_cil_cabs.cabsloc> IDENT
   165: %token <int64 list * Flx_cil_cabs.cabsloc> CST_CHAR
   166: %token <int64 list * Flx_cil_cabs.cabsloc> CST_WCHAR
   167: %token <string * Flx_cil_cabs.cabsloc> CST_INT
   168: %token <string * Flx_cil_cabs.cabsloc> CST_FLOAT
   169: %token <string * Flx_cil_cabs.cabsloc> NAMED_TYPE
   170: 
   171: /* Each character is its own list element, and the terminating nul is not
   172:    included in this list. */
   173: %token <int64 list * Flx_cil_cabs.cabsloc> CST_STRING
   174: %token <int64 list * Flx_cil_cabs.cabsloc> CST_WSTRING
   175: 
   176: %token EOF
   177: %token<Flx_cil_cabs.cabsloc> BOOL CHAR INT DOUBLE FLOAT COMPLEX IMAGINARY VOID INT64 INT32
   178: %token<Flx_cil_cabs.cabsloc> ENUM STRUCT TYPEDEF UNION
   179: %token<Flx_cil_cabs.cabsloc> SIGNED UNSIGNED LONG SHORT
   180: %token<Flx_cil_cabs.cabsloc> VOLATILE EXTERN STATIC CONST RESTRICT AUTO REGISTER
   181: %token<Flx_cil_cabs.cabsloc> THREAD
   182: %token<Flx_cil_cabs.cabsloc> CLASS NAMESPACE USING
   183: %token<Flx_cil_cabs.cabsloc> TYPENAME TEMPLATENAME
   184: %token<Flx_cil_cabs.cabsloc> PUBLIC PRIVATE PROTECTED VIRTUAL
   185: 
   186: %token<Flx_cil_cabs.cabsloc> SIZEOF ALIGNOF
   187: 
   188: %token EQ PLUS_EQ MINUS_EQ STAR_EQ SLASH_EQ PERCENT_EQ
   189: %token AND_EQ PIPE_EQ CIRC_EQ INF_INF_EQ SUP_SUP_EQ
   190: %token ARROW DOT
   191: 
   192: %token EQ_EQ EXCLAM_EQ INF SUP INF_EQ SUP_EQ
   193: %token<Flx_cil_cabs.cabsloc> PLUS MINUS STAR
   194: %token SLASH PERCENT
   195: %token<Flx_cil_cabs.cabsloc> TILDE AND
   196: %token PIPE CIRC
   197: %token<Flx_cil_cabs.cabsloc> EXCLAM AND_AND
   198: %token PIPE_PIPE
   199: %token INF_INF SUP_SUP
   200: %token<Flx_cil_cabs.cabsloc> PLUS_PLUS MINUS_MINUS
   201: 
   202: %token RPAREN
   203: %token<Flx_cil_cabs.cabsloc> LPAREN RBRACE
   204: %token<Flx_cil_cabs.cabsloc> LBRACE
   205: %token LBRACKET RBRACKET
   206: %token COLON XCOLON
   207: %token<Flx_cil_cabs.cabsloc> SEMICOLON
   208: %token COMMA ELLIPSIS QUEST
   209: 
   210: %token<Flx_cil_cabs.cabsloc> BREAK CONTINUE GOTO RETURN
   211: %token<Flx_cil_cabs.cabsloc> SWITCH CASE DEFAULT
   212: %token<Flx_cil_cabs.cabsloc> WHILE DO FOR
   213: %token<Flx_cil_cabs.cabsloc> IF TRY EXCEPT FINALLY
   214: %token ELSE
   215: 
   216: %token<Flx_cil_cabs.cabsloc> ATTRIBUTE INLINE ASM TYPEOF FUNCTION__ PRETTY_FUNCTION__
   217: %token LABEL__
   218: %token<Flx_cil_cabs.cabsloc> BUILTIN_VA_ARG
   219: %token BUILTIN_VA_LIST
   220: %token BLOCKATTRIBUTE
   221: %token<Flx_cil_cabs.cabsloc> DECLSPEC
   222: %token<string * Flx_cil_cabs.cabsloc> MSASM MSATTR
   223: %token<Flx_cil_cabs.cabsloc> PRAGMA
   224: %token<string * Flx_cil_cabs.cabsloc> PRAGMA_LINE
   225: %token PRAGMA_EOL
   226: 
   227: /* sm: cabs tree transformation specification keywords */
   228: %token<Flx_cil_cabs.cabsloc> AT_TRANSFORM AT_TRANSFORMEXPR AT_SPECIFIER AT_EXPR
   229: %token AT_NAME
   230: 
   231: /* operator precedence */
   232: %nonassoc       IF
   233: %nonassoc       ELSE
   234: 
   235: 
   236: %left   COMMA
   237: %right  EQ PLUS_EQ MINUS_EQ STAR_EQ SLASH_EQ PERCENT_EQ
   238:                 AND_EQ PIPE_EQ CIRC_EQ INF_INF_EQ SUP_SUP_EQ
   239: %right  QUEST COLON
   240: %left   PIPE_PIPE
   241: %left   AND_AND
   242: %left   PIPE
   243: %left   CIRC
   244: %left   AND
   245: %left   EQ_EQ EXCLAM_EQ
   246: %left   INF SUP INF_EQ SUP_EQ
   247: %left   INF_INF SUP_SUP
   248: %left   PLUS MINUS
   249: %left   STAR SLASH PERCENT CONST RESTRICT VOLATILE
   250: %right  EXCLAM TILDE PLUS_PLUS MINUS_MINUS CAST RPAREN ADDROF SIZEOF ALIGNOF
   251: %left   LBRACKET
   252: %left   DOT ARROW LPAREN LBRACE
   253: %right  NAMED_TYPE     /* We'll use this to handle redefinitions of
   254:                         * NAMED_TYPE as variables */
   255: %left   IDENT
   256: 
   257: /* Non-terminals informations */
   258: %start interpret file
   259: %type <Flx_cil_cabs.definition list> file interpret globals
   260: 
   261: %type <Flx_cil_cabs.definition> global
   262: 
   263: 
   264: %type <Flx_cil_cabs.attribute list> attributes attributes_with_asm asmattr
   265: %type <Flx_cil_cabs.statement> statement
   266: %type <Flx_cil_cabs.constant * cabsloc> constant
   267: %type <string * cabsloc> string_constant
   268: %type <Flx_cil_cabs.expression * cabsloc> expression
   269: %type <Flx_cil_cabs.expression> opt_expression
   270: %type <Flx_cil_cabs.init_expression> init_expression
   271: %type <Flx_cil_cabs.expression list * cabsloc> comma_expression
   272: %type <Flx_cil_cabs.expression list * cabsloc> paren_comma_expression
   273: %type <Flx_cil_cabs.expression list> arguments
   274: %type <Flx_cil_cabs.expression list> bracket_comma_expression
   275: %type <int64 list * cabsloc> string_list
   276: %type <int64 list * cabsloc> wstring_list
   277: 
   278: %type <Flx_cil_cabs.initwhat * Flx_cil_cabs.init_expression> initializer
   279: %type <(Flx_cil_cabs.initwhat * Flx_cil_cabs.init_expression) list> initializer_list
   280: %type <Flx_cil_cabs.initwhat> init_designators init_designators_opt
   281: 
   282: %type <spec_elem list * cabsloc> decl_spec_list
   283: %type <typeSpecifier * cabsloc> type_spec
   284: /* %type <Flx_cil_cabs.field_group list> struct_decl_list */
   285: 
   286: 
   287: %type <Flx_cil_cabs.name> old_proto_decl
   288: %type <Flx_cil_cabs.single_name> parameter_decl
   289: %type <Flx_cil_cabs.enum_item> enumerator
   290: %type <Flx_cil_cabs.enum_item list> enum_list
   291: %type <Flx_cil_cabs.definition> declaration function_def
   292: %type <cabsloc * spec_elem list * name> function_def_start
   293: %type <Flx_cil_cabs.spec_elem list * Flx_cil_cabs.decl_type> type_name
   294: %type <Flx_cil_cabs.block * cabsloc * cabsloc> block
   295: %type <Flx_cil_cabs.statement list> block_element_list
   296: %type <string list> local_labels local_label_names
   297: %type <string list> old_parameter_list_ne
   298: 
   299: %type <Flx_cil_cabs.init_name> init_declarator
   300: %type <Flx_cil_cabs.init_name list> init_declarator_list
   301: %type <Flx_cil_cabs.name> declarator
   302: %type <Flx_cil_cabs.name * expression option> field_decl
   303: %type <(Flx_cil_cabs.name * expression option) list> field_decl_list
   304: %type <string * Flx_cil_cabs.decl_type> direct_decl
   305: %type <Flx_cil_cabs.decl_type> abs_direct_decl abs_direct_decl_opt
   306: %type <Flx_cil_cabs.decl_type * Flx_cil_cabs.attribute list> abstract_decl
   307: 
   308:  /* (* Each element is a "* <type_quals_opt>". *) */
   309: %type <attribute list list * cabsloc> pointer pointer_opt
   310: %type <Flx_cil_cabs.cabsloc> location
   311: %type <Flx_cil_cabs.spec_elem * cabsloc> cvspec
   312: %%
   313: 
   314: interpret:
   315: | file EOF                              {$1}
   316: ;
   317: file: globals                           {$1}
   318: ;
   319: globals:
   320: | /* empty */                           { [] }
   321: | global globals                        { $1 :: $2 }
   322: | SEMICOLON globals                     { $2 }
   323: ;
   324: 
   325: location:
   326:    /* empty */                  { currentLoc () }  %prec IDENT
   327: 
   328: 
   329: /*** Global Definition ***/
   330: global:
   331: | declaration                           { $1 }
   332: | function_def                          { $1 }
   333: /*(* Some C header files ar shared with the C++ compiler and have linkage
   334:    * specification *)*/
   335: | EXTERN string_constant declaration    { LINKAGE (fst $2, snd $2, [ $3 ]) }
   336: | EXTERN string_constant LBRACE globals RBRACE
   337:   { LINKAGE (fst $2, snd $2, $4)  }
   338: 
   339: | NAMESPACE IDENT LBRACE globals RBRACE
   340:   { NAMESPACE (fst $2, snd $2, $4)  }
   341: 
   342: | ASM LPAREN string_constant RPAREN SEMICOLON
   343:                                         { GLOBASM (fst $3, $1) }
   344: | PRAGMA attr PRAGMA_EOL                { PRAGMA ($2, $1) }
   345: | PRAGMA attr SEMICOLON PRAGMA_EOL      { PRAGMA ($2, $1) }
   346: | PRAGMA_LINE                           { PRAGMA (VARIABLE (fst $1),
   347:                                                   snd $1) }
   348: /* (* Old-style function prototype. This should be somewhere else, like in
   349:     * "declaration". For now we keep it at global scope only because in local
   350:     * scope it looks too much like a function call  *) */
   351: 
   352: | IDENT LPAREN old_parameter_list_ne RPAREN old_pardef_list SEMICOLON
   353:                            { (* Convert pardecl to new style *)
   354:                              let pardecl, isva = doOldParDecl $3 $5 in
   355:                              (* Make the function declarator *)
   356:                              doDeclaration (snd $1) []
   357:                                [((fst $1, PROTO(JUSTBASE, pardecl,isva), [], cabslu),
   358:                                  NO_INIT)]
   359:                             }
   360: /* (* Old style function prototype, but without any arguments *) */
   361: | IDENT LPAREN RPAREN  SEMICOLON
   362:                            { (* Make the function declarator *)
   363:                              doDeclaration (snd $1) []
   364:                                [((fst $1, PROTO(JUSTBASE,[],false), [], cabslu),
   365:                                  NO_INIT)]
   366:                             }
   367: /* transformer for a toplevel construct */
   368: | AT_TRANSFORM LBRACE global RBRACE  IDENT/*to*/  LBRACE globals RBRACE {
   369:     checkConnective(fst $5);
   370:     TRANSFORMER($3, $7, $1)
   371:   }
   372: /* transformer for an expression */
   373: | AT_TRANSFORMEXPR LBRACE expression RBRACE  IDENT/*to*/  LBRACE expression RBRACE {
   374:     checkConnective(fst $5);
   375:     EXPRTRANSFORMER(fst $3, fst $7, $1)
   376:   }
   377: | location error SEMICOLON { PRAGMA (VARIABLE "parse_error", $1) }
   378: ;
   379: 
   380: id_or_typename:
   381: |   IDENT                               {fst $1}
   382: |   NAMED_TYPE                          {fst $1}
   383: |   AT_NAME LPAREN IDENT RPAREN         { "@name(" ^ fst $3 ^ ")" }     /* pattern variable name */
   384: ;
   385: 
   386: maybecomma:
   387: |  /* empty */                          { () }
   388: |  COMMA                                { () }
   389: ;
   390: 
   391: /* *** Expressions *** */
   392: 
   393: 
   394: expression:
   395: |               constant
   396:                         {CONSTANT (fst $1), snd $1}
   397: |               IDENT
   398:                         {VARIABLE (fst $1), snd $1}
   399: |               SIZEOF expression
   400:                         {EXPR_SIZEOF (fst $2), $1}
   401: |               SIZEOF LPAREN type_name RPAREN
   402:                         {let b, d = $3 in TYPE_SIZEOF (b, d), $1}
   403: |               ALIGNOF expression
   404:                         {EXPR_ALIGNOF (fst $2), $1}
   405: |               ALIGNOF LPAREN type_name RPAREN
   406:                         {let b, d = $3 in TYPE_ALIGNOF (b, d), $1}
   407: |               PLUS expression
   408:                         {UNARY (PLUS, fst $2), $1}
   409: |               MINUS expression
   410:                         {UNARY (MINUS, fst $2), $1}
   411: |               STAR expression
   412:                         {UNARY (MEMOF, fst $2), $1}
   413: |               AND expression                          %prec ADDROF
   414:                         {UNARY (ADDROF, fst $2), $1}
   415: |               EXCLAM expression
   416:                         {UNARY (NOT, fst $2), $1}
   417: |               TILDE expression
   418:                         {UNARY (BNOT, fst $2), $1}
   419: |               PLUS_PLUS expression                    %prec CAST
   420:                         {UNARY (PREINCR, fst $2), $1}
   421: |               expression PLUS_PLUS
   422:                         {UNARY (POSINCR, fst $1), snd $1}
   423: |               MINUS_MINUS expression                  %prec CAST
   424:                         {UNARY (PREDECR, fst $2), $1}
   425: |               expression MINUS_MINUS
   426:                         {UNARY (POSDECR, fst $1), snd $1}
   427: |               expression ARROW id_or_typename
   428:                         {MEMBEROFPTR (fst $1, $3), snd $1}
   429: |               expression DOT id_or_typename
   430:                         {MEMBEROF (fst $1, $3), snd $1}
   431: |               LPAREN block RPAREN
   432:                         { GNU_BODY (fst3 $2), $1 }
   433: |               paren_comma_expression
   434:                         {smooth_expression (fst $1), snd $1}
   435: |               expression LPAREN arguments RPAREN
   436:                         {CALL (fst $1, $3), snd $1}
   437: |               BUILTIN_VA_ARG LPAREN expression COMMA type_name RPAREN
   438:                         { let b, d = $5 in
   439:                           CALL (VARIABLE "__builtin_va_arg",
   440:                                 [fst $3; TYPE_SIZEOF (b, d)]), $1 }
   441: |               expression bracket_comma_expression
   442:                         {INDEX (fst $1, smooth_expression $2), snd $1}
   443: |               expression QUEST opt_expression COLON expression
   444:                         {QUESTION (fst $1, $3, fst $5), snd $1}
   445: |               expression PLUS expression
   446:                         {BINARY(ADD, fst $1, fst $3), snd $1}
   447: |               expression MINUS expression
   448:                         {BINARY(SUB, fst $1, fst $3), snd $1}
   449: |               expression STAR expression
   450:                         {BINARY(MUL, fst $1, fst $3), snd $1}
   451: |               expression SLASH expression
   452:                         {BINARY(DIV, fst $1, fst $3), snd $1}
   453: |               expression PERCENT expression
   454:                         {BINARY(MOD, fst $1, fst $3), snd $1}
   455: |               expression AND_AND expression
   456:                         {BINARY(AND, fst $1, fst $3), snd $1}
   457: |               expression PIPE_PIPE expression
   458:                         {BINARY(OR, fst $1, fst $3), snd $1}
   459: |               expression AND expression
   460:                         {BINARY(BAND, fst $1, fst $3), snd $1}
   461: |               expression PIPE expression
   462:                         {BINARY(BOR, fst $1, fst $3), snd $1}
   463: |               expression CIRC expression
   464:                         {BINARY(XOR, fst $1, fst $3), snd $1}
   465: |               expression EQ_EQ expression
   466:                         {BINARY(EQ, fst $1, fst $3), snd $1}
   467: |               expression EXCLAM_EQ expression
   468:                         {BINARY(NE, fst $1, fst $3), snd $1}
   469: |               expression INF expression
   470:                         {BINARY(LT, fst $1, fst $3), snd $1}
   471: |               expression SUP expression
   472:                         {BINARY(GT, fst $1, fst $3), snd $1}
   473: |               expression INF_EQ expression
   474:                         {BINARY(LE, fst $1, fst $3), snd $1}
   475: |               expression SUP_EQ expression
   476:                         {BINARY(GE, fst $1, fst $3), snd $1}
   477: |               expression  INF_INF expression
   478:                         {BINARY(SHL, fst $1, fst $3), snd $1}
   479: |               expression  SUP_SUP expression
   480:                         {BINARY(SHR, fst $1, fst $3), snd $1}
   481: |               expression EQ expression
   482:                         {BINARY(ASSIGN, fst $1, fst $3), snd $1}
   483: |               expression PLUS_EQ expression
   484:                         {BINARY(ADD_ASSIGN, fst $1, fst $3), snd $1}
   485: |               expression MINUS_EQ expression
   486:                         {BINARY(SUB_ASSIGN, fst $1, fst $3), snd $1}
   487: |               expression STAR_EQ expression
   488:                         {BINARY(MUL_ASSIGN, fst $1, fst $3), snd $1}
   489: |               expression SLASH_EQ expression
   490:                         {BINARY(DIV_ASSIGN, fst $1, fst $3), snd $1}
   491: |               expression PERCENT_EQ expression
   492:                         {BINARY(MOD_ASSIGN, fst $1, fst $3), snd $1}
   493: |               expression AND_EQ expression
   494:                         {BINARY(BAND_ASSIGN, fst $1, fst $3), snd $1}
   495: |               expression PIPE_EQ expression
   496:                         {BINARY(BOR_ASSIGN, fst $1, fst $3), snd $1}
   497: |               expression CIRC_EQ expression
   498:                         {BINARY(XOR_ASSIGN, fst $1, fst $3), snd $1}
   499: |               expression INF_INF_EQ expression
   500:                         {BINARY(SHL_ASSIGN, fst $1, fst $3), snd $1}
   501: |               expression SUP_SUP_EQ expression
   502:                         {BINARY(SHR_ASSIGN, fst $1, fst $3), snd $1}
   503: |               LPAREN type_name RPAREN expression
   504:                          { CAST($2, SINGLE_INIT (fst $4)), $1 }
   505: /* (* We handle GCC constructor expressions *) */
   506: |               LPAREN type_name RPAREN LBRACE initializer_list_opt RBRACE
   507:                          { CAST($2, COMPOUND_INIT $5), $1 }
   508: /* (* GCC's address of labels *)  */
   509: |               AND_AND IDENT  { LABELADDR (fst $2), $1 }
   510: |               AT_EXPR LPAREN IDENT RPAREN         /* expression pattern variable */
   511:                          { EXPR_PATTERN(fst $3), $1 }
   512: ;
   513: 
   514: constant:
   515: |   CST_INT                             {CONST_INT (fst $1), snd $1}
   516: |   CST_FLOAT                           {CONST_FLOAT (fst $1), snd $1}
   517: |   CST_CHAR                            {CONST_CHAR (fst $1), snd $1}
   518: |   CST_WCHAR                           {CONST_WCHAR (fst $1), snd $1}
   519: |   string_constant                     {CONST_STRING (fst $1), snd $1}
   520: |   wstring_list                        {CONST_WSTRING (fst $1), snd $1}
   521: ;
   522: 
   523: string_constant:
   524: /* Now that we know this constant isn't part of a wstring, convert it
   525:    back to a string for easy viewing. */
   526: |   string_list                         {intlist_to_string (fst $1), snd $1 }
   527: ;
   528: one_string_constant:
   529: /* Don't concat multiple strings.  For asm templates. */
   530: |   CST_STRING                          {intlist_to_string (fst $1) }
   531: ;
   532: string_list:
   533: |   one_string                          { $1 }
   534: |   string_list one_string              { (fst $1) @ (fst $2), snd $1 }
   535: ;
   536: 
   537: wstring_list:
   538: |   CST_WSTRING                         { $1 }
   539: |   wstring_list one_string             { (fst $1) @ (fst $2), snd $1 }
   540: |   wstring_list CST_WSTRING            { (fst $1) @ (fst $2), snd $1 }
   541: /* Only the first string in the list needs an L, so L"a" "b" is the same
   542:  * as L"ab" or L"a" L"b". */
   543: 
   544: one_string:
   545: |   CST_STRING                          {$1}
   546: |   FUNCTION__                          {(Flx_cil_cabs_helper.explodeStringToInts
   547:                                             !currentFunctionName), $1}
   548: |   PRETTY_FUNCTION__                   {(Flx_cil_cabs_helper.explodeStringToInts
   549:                                             !currentFunctionName), $1}
   550: ;
   551: 
   552: init_expression:
   553: |    expression         { SINGLE_INIT (fst $1) }
   554: |    LBRACE initializer_list_opt RBRACE
   555:                         { COMPOUND_INIT $2}
   556: 
   557: /* ISO 6.7.8. Allow a trailing COMMA */
   558: initializer_list:
   559: |   initializer                             { [$1] }
   560: |   initializer COMMA initializer_list_opt  { $1 :: $3 }
   561: ;
   562: initializer_list_opt:
   563: |   /* empty */                             { [] }
   564: |   initializer_list                        { $1 }
   565: ;
   566: initializer:
   567: |   init_designators eq_opt init_expression { ($1, $3) }
   568: |   gcc_init_designators init_expression { ($1, $2) }
   569: |                       init_expression { (NEXT_INIT, $1) }
   570: ;
   571: eq_opt:
   572: |  EQ                        { () }
   573:    /*(* GCC allows missing = *)*/
   574: |  /*(* empty *)*/               { () }
   575: ;
   576: init_designators:
   577: |   DOT id_or_typename init_designators_opt      { INFIELD_INIT($2, $3) }
   578: |   LBRACKET  expression RBRACKET init_designators_opt
   579:                                         { ATINDEX_INIT(fst $2, $4) }
   580: |   LBRACKET  expression ELLIPSIS expression RBRACKET
   581:                                         { ATINDEXRANGE_INIT(fst $2, fst $4) }
   582: ;
   583: init_designators_opt:
   584: |  /* empty */                          { NEXT_INIT }
   585: |  init_designators                     { $1 }
   586: ;
   587: 
   588: /*(* GCC supports these strange things *)*/
   589: gcc_init_designators:
   590: | id_or_typename COLON                 { INFIELD_INIT($1, NEXT_INIT) }
   591: ;
   592: 
   593: arguments:
   594: |               /* empty */         { [] }
   595: |               comma_expression    { fst $1 }
   596: ;
   597: 
   598: opt_expression:
   599: |               /* empty */
   600:                         {NOTHING}
   601: |               comma_expression
   602:                         {smooth_expression (fst $1)}
   603: ;
   604: 
   605: comma_expression:
   606: |               expression                        {[fst $1], snd $1}
   607: |               expression COMMA comma_expression { fst $1 :: fst $3, snd $1 }
   608: |               error COMMA comma_expression      { $3 }
   609: ;
   610: 
   611: comma_expression_opt:
   612: |               /* empty */         { NOTHING }
   613: |               comma_expression    { smooth_expression (fst $1) }
   614: ;
   615: 
   616: paren_comma_expression:
   617: | LPAREN comma_expression RPAREN                   { $2 }
   618: | LPAREN error RPAREN                              { [], $1 }
   619: ;
   620: 
   621: bracket_comma_expression:
   622: | LBRACKET comma_expression RBRACKET                   { fst $2 }
   623: | LBRACKET error RBRACKET                              { [] }
   624: ;
   625: 
   626: 
   627: /*** statements ***/
   628: /* ISO 6.8.2 */
   629: block:
   630: |   block_begin local_labels block_attrs block_element_list RBRACE
   631:                                          {!Flx_cil_lexerhack.pop_context();
   632:                                           { blabels = $2;
   633:                                             battrs = $3;
   634:                                             bstmts = $4 },
   635:                                             $1, $5
   636:                                          }
   637: |   error location RBRACE                { { blabels = [];
   638:                                              battrs  = [];
   639:                                              bstmts  = [] },
   640:                                              $2, $3
   641:                                          }
   642: ;
   643: block_begin:
   644: |   LBRACE                               {!Flx_cil_lexerhack.push_context (); $1}
   645: ;
   646: 
   647: block_attrs:
   648: |  /* empty */                                              { [] }
   649: |  BLOCKATTRIBUTE paren_attr_list_ne
   650:                                         { [("__blockattribute__", $2)] }
   651: ;
   652: 
   653: /* statements and declarations in a block, in any order (for C99 support) */
   654: block_element_list:
   655: |   /* empty */                          { [] }
   656: |   declaration block_element_list       { DEFINITION($1) :: $2 }
   657: |   statement block_element_list         { $1 :: $2 }
   658: /*(* GCC accepts a label at the end of a block *)*/
   659: |   IDENT COLON                          { [ LABEL (fst $1, NOP (snd $1),
   660:                                                     snd $1)] }
   661: ;
   662: 
   663: local_labels:
   664: |  /* empty */                                       { [] }
   665: |  LABEL__ local_label_names SEMICOLON local_labels  { $2 @ $4 }
   666: ;
   667: local_label_names:
   668: |  IDENT                                 { [ fst $1 ] }
   669: |  IDENT COMMA local_label_names         { fst $1 :: $3 }
   670: ;
   671: 
   672: 
   673: 
   674: statement:
   675: |   SEMICOLON           {NOP $1 }
   676: |   comma_expression SEMICOLON
   677:                         {COMPUTATION (smooth_expression (fst $1), snd $1)}
   678: |   block               {BLOCK (fst3 $1, snd3 $1)}
   679: |   IF paren_comma_expression statement                    %prec IF
   680:                         {IF (smooth_expression (fst $2), $3, NOP $1, $1)}
   681: |   IF paren_comma_expression statement ELSE statement
   682:                         {IF (smooth_expression (fst $2), $3, $5, $1)}
   683: |   SWITCH paren_comma_expression statement
   684:                         {SWITCH (smooth_expression (fst $2), $3, $1)}
   685: |   WHILE paren_comma_expression statement
   686:                         {WHILE (smooth_expression (fst $2), $3, $1)}
   687: |   DO statement WHILE paren_comma_expression SEMICOLON
   688:                                  {DOWHILE (smooth_expression (fst $4), $2, $1)}
   689: |   FOR LPAREN for_clause opt_expression
   690:                 SEMICOLON opt_expression RPAREN statement
   691:                                  {FOR ($3, $4, $6, $8, $1)}
   692: |   IDENT COLON statement
   693:                                  {LABEL (fst $1, $3, snd $1)}
   694: |   CASE expression COLON
   695:                                  {CASE (fst $2, NOP $1, $1)}
   696: |   CASE expression ELLIPSIS expression COLON
   697:                                  {CASERANGE (fst $2, fst $4, NOP $1, $1)}
   698: |   DEFAULT COLON
   699:                                  {DEFAULT (NOP $1, $1)}
   700: |   RETURN SEMICOLON             {RETURN (NOTHING, $1)}
   701: |   RETURN comma_expression SEMICOLON
   702:                                  {RETURN (smooth_expression (fst $2), $1)}
   703: |   BREAK SEMICOLON     {BREAK $1}
   704: |   CONTINUE SEMICOLON   {CONTINUE $1}
   705: |   GOTO IDENT SEMICOLON
   706:                                  {GOTO (fst $2, $1)}
   707: |   GOTO STAR comma_expression SEMICOLON
   708:                                  { COMPGOTO (smooth_expression (fst $3), $1) }
   709: |   ASM asmattr LPAREN asmtemplate asmoutputs RPAREN SEMICOLON
   710:                         { let (outs,ins,clobs) = $5 in
   711:                           ASM ($2, $4, outs, ins, clobs, $1) }
   712: |   MSASM               { ASM ([], [fst $1], [], [], [], snd $1)}
   713: |   TRY block EXCEPT paren_comma_expression block
   714:                         { let b, _, _ = $2 in
   715:                           let h, _, _ = $5 in
   716:                           if not !Flx_cil_cprint.msvcMode then
   717:                             parse_error "try/except in GCC code";
   718:                           TRY_EXCEPT (b, COMMA (fst $4), h, $1) }
   719: |   TRY block FINALLY block
   720:                         { let b, _, _ = $2 in
   721:                           let h, _, _ = $4 in
   722:                           if not !Flx_cil_cprint.msvcMode then
   723:                             parse_error "try/finally in GCC code";
   724:                           TRY_FINALLY (b, h, $1) }
   725: 
   726: |   error location   SEMICOLON   { (NOP $2)}
   727: ;
   728: 
   729: 
   730: for_clause:
   731: |   opt_expression SEMICOLON     { FC_EXP $1 }
   732: |   declaration                  { FC_DECL $1 }
   733: ;
   734: 
   735: /* ISO 6.7.*/
   736: declaration:
   737: |   decl_spec_list init_declarator_list SEMICOLON
   738:                                        { doDeclaration (snd $1) (fst $1) $2 }
   739: |   decl_spec_list SEMICOLON           { doDeclaration (snd $1) (fst $1) [] }
   740: ;
   741: 
   742: /* ISO 6.7 */
   743: init_declarator_list:
   744: |   init_declarator                              { [$1] }
   745: |   init_declarator COMMA init_declarator_list   { $1 :: $3 }
   746: 
   747: ;
   748: 
   749: /* ISO 6.7 */
   750: init_declarator:
   751: |   declarator                          { ($1, NO_INIT) }
   752: |   declarator EQ init_expression
   753:                                         { ($1, $3) }
   754: ;
   755: 
   756: /* ISO 6.7 */
   757: decl_spec_list:
   758:                                         /* ISO 6.7.1 */
   759: |   TYPEDEF decl_spec_list_opt          { SpecTypedef :: $2, $1  }
   760: |   EXTERN decl_spec_list_opt           { SpecStorage EXTERN :: $2, $1 }
   761: |   STATIC  decl_spec_list_opt          { SpecStorage STATIC :: $2, $1 }
   762: |   AUTO   decl_spec_list_opt           { SpecStorage AUTO :: $2, $1 }
   763: |   REGISTER decl_spec_list_opt         { SpecStorage REGISTER :: $2, $1}
   764:                                         /* ISO 6.7.2 */
   765: |   type_spec decl_spec_list_opt_no_named { SpecType (fst $1) :: $2, snd $1 }
   766:                                         /* ISO 6.7.4 */
   767: |   INLINE decl_spec_list_opt           { SpecInline :: $2, $1 }
   768: |   cvspec decl_spec_list_opt           { (fst $1) :: $2, snd $1 }
   769: |   attribute_nocv decl_spec_list_opt   { SpecAttr (fst $1) :: $2, snd $1 }
   770: /* specifier pattern variable (must be last in spec list) */
   771: |   AT_SPECIFIER LPAREN IDENT RPAREN    { [ SpecPattern(fst $3) ], $1 }
   772: ;
   773: /* (* In most cases if we see a NAMED_TYPE we must shift it. Thus we declare
   774:     * NAMED_TYPE to have right associativity  *) */
   775: decl_spec_list_opt:
   776: |   /* empty */                         { [] } %prec NAMED_TYPE
   777: |   decl_spec_list                      { fst $1 }
   778: ;
   779: /* (* We add this separate rule to handle the special case when an appearance
   780:     * of NAMED_TYPE should not be considered as part of the specifiers but as
   781:     * part of the declarator. IDENT has higher precedence than NAMED_TYPE  *)
   782:  */
   783: decl_spec_list_opt_no_named:
   784: |   /* empty */                         { [] } %prec IDENT
   785: |   decl_spec_list                      { fst $1 }
   786: ;
   787: 
   788: 
   789: base:
   790: | id_or_typename { `Public $1 }
   791: | PUBLIC id_or_typename { `Public $2 }
   792: | PROTECTED id_or_typename { `Protected $2 }
   793: | PRIVATE id_or_typename { `Private $2 }
   794: | VIRTUAL id_or_typename { `Public $2 }
   795: | VIRTUAL PUBLIC id_or_typename { `Public $3 }
   796: | VIRTUAL PROTECTED id_or_typename { `Protected $3 }
   797: | VIRTUAL PRIVATE id_or_typename { `Private $3 }
   798: | PUBLIC VIRTUAL id_or_typename { `Public $3 }
   799: | PROTECTED VIRTUAL id_or_typename { `Protected $3 }
   800: | PRIVATE VIRTUAL id_or_typename { `Private $3 }
   801: 
   802: bases:
   803: | base COMMA bases {$1 :: $3 }
   804: | base { [$1] }
   805: 
   806: int_spec:
   807: |   CHAR            { Tchar, $1 }
   808: |   SHORT           { Tshort, $1 }
   809: |   INT             { Tint, $1 }
   810: |   LONG            { Tlong, $1 }
   811: |   INT64           { Tint64, $1 }
   812: |   SIGNED          { Tsigned, $1 }
   813: |   UNSIGNED        { Tunsigned, $1 }
   814: 
   815: /* ISO 6.7.2 */
   816: type_spec:
   817: |   int_spec        { $1 }
   818: |   VOID            { Tvoid, $1}
   819: |   BOOL            { Tbool, $1 }
   820: |   FLOAT           { Tfloat, $1 }
   821: |   COMPLEX         { Tcomplex, $1 }
   822: |   IMAGINARY       { Timaginary, $1 }
   823: |   DOUBLE          { Tdouble, $1 }
   824: 
   825: |   STRUCT id_or_typename
   826:     { Tstruct ($2, None,    []), $1 }
   827: |   STRUCT id_or_typename LBRACE struct_decl_list RBRACE
   828:     { Tstruct ($2, mkflds true $4, []), $1 }
   829: |   STRUCT id_or_typename COLON bases LBRACE struct_decl_list RBRACE
   830:     { Tstruct ($2, mkflds true $6, []), $1 }
   831: |   STRUCT LBRACE struct_decl_list RBRACE
   832:     { Tstruct ("", mkflds true $3, []), $1 }
   833: |   STRUCT just_attributes id_or_typename LBRACE struct_decl_list RBRACE
   834:     { Tstruct ($3, mkflds true $5, $2), $1 }
   835: |   STRUCT just_attributes id_or_typename COLON bases LBRACE struct_decl_list RBRACE
   836:     { Tstruct ($3, mkflds true $7, $2), $1 }
   837: |   STRUCT just_attributes LBRACE struct_decl_list RBRACE
   838:     { Tstruct ("", mkflds true $4, $2), $1 }
   839: 
   840: |   CLASS id_or_typename
   841:     { Tstruct ($2, None,    []), $1 }
   842: |   CLASS id_or_typename LBRACE struct_decl_list RBRACE
   843:     { Tstruct ($2, mkflds false $4, []), $1 }
   844: |   CLASS id_or_typename COLON bases LBRACE struct_decl_list RBRACE
   845:     { Tstruct ($2, mkflds false $6, []), $1 }
   846: |   CLASS LBRACE struct_decl_list RBRACE
   847:     { Tstruct ("", mkflds false $3, []), $1 }
   848: |   CLASS just_attributes id_or_typename LBRACE struct_decl_list RBRACE
   849:     { Tstruct ($3, mkflds false $5, $2), $1 }
   850: |   CLASS just_attributes id_or_typename COLON bases LBRACE struct_decl_list RBRACE
   851:     { Tstruct ($3, mkflds false $7, $2), $1 }
   852: |   CLASS just_attributes LBRACE struct_decl_list RBRACE
   853:     { Tstruct ("", mkflds false $4, $2), $1 }
   854: 
   855: |   UNION id_or_typename
   856:     { Tunion  ($2, None,    []), $1 }
   857: |   UNION id_or_typename LBRACE struct_decl_list RBRACE
   858:     { Tunion  ($2, mkflds true $4, []), $1 }
   859: |   UNION id_or_typename COLON bases LBRACE struct_decl_list RBRACE
   860:     { Tunion  ($2, mkflds true  $6, []), $1 }
   861: |   UNION LBRACE struct_decl_list RBRACE
   862:     { Tunion  ("", mkflds true $3, []), $1 }
   863: |   UNION just_attributes id_or_typename LBRACE struct_decl_list RBRACE
   864:     { Tunion  ($3, mkflds true $5, $2), $1 }
   865: |   UNION just_attributes id_or_typename COLON bases LBRACE struct_decl_list RBRACE
   866:     { Tunion  ($3, mkflds true $7, $2), $1 }
   867: |   UNION just_attributes LBRACE struct_decl_list RBRACE
   868:     { Tunion  ("", mkflds true $4, $2), $1 }
   869: 
   870: |   ENUM                   id_or_typename
   871:                                                    { Tenum   ($2, None,    []), $1 }
   872: |   ENUM                   id_or_typename LBRACE enum_list maybecomma RBRACE
   873:                                                    { Tenum   ($2, Some $4, []), $1 }
   874: |   ENUM                                  LBRACE enum_list maybecomma RBRACE
   875:                                                    { Tenum   ("", Some $3, []), $1 }
   876: |   ENUM   just_attributes id_or_typename LBRACE enum_list maybecomma RBRACE
   877:                                                    { Tenum   ($3, Some $5, $2), $1 }
   878: |   ENUM   just_attributes                LBRACE enum_list maybecomma RBRACE
   879:                                                    { Tenum   ("", Some $4, $2), $1 }
   880: |   NAMED_TYPE      { Tnamed (fst $1), snd $1 }
   881: |   TYPEOF LPAREN expression RPAREN     { TtypeofE (fst $3), $1 }
   882: |   TYPEOF LPAREN type_name RPAREN      { let s, d = $3 in
   883:                                           TtypeofT (s, d), $1 }
   884: ;
   885: 
   886: /* (* ISO 6.7.2. Except that we allow empty structs. We
   887:  * also allow missing field names. *)
   888:  */
   889: struct_decl_list:
   890: |  /* empty */                           { [] }
   891: 
   892: |  decl_spec_list                 SEMICOLON struct_decl_list
   893:    { `Fields (fst $1, [(missingFieldDecl, None)]) :: $3 }
   894: 
   895: /*(* GCC allows extra semicolons *)*/
   896: |                                 SEMICOLON struct_decl_list
   897:    { $2 }
   898: 
   899: |  decl_spec_list field_decl_list SEMICOLON struct_decl_list
   900:    { `Fields (fst $1, $2) :: $4 }
   901: 
   902: /* this is a hack allowing 'int : 2' */
   903: 
   904: |  int_spec COLON expression SEMICOLON struct_decl_list
   905:    {
   906:      let ts: Flx_cil_cabs.spec_elem = SpecType (fst $1) in
   907:      let fld
   908:        : Flx_cil_cabs.name * Flx_cil_cabs.expression option
   909:        = missingFieldDecl,Some (fst $3)
   910:      in
   911:      let x = `Fields ([ts],[fld]) in
   912:      x :: $5
   913:    }
   914: 
   915: 
   916: | PUBLIC COLON struct_decl_list { `Access_public :: $3 }
   917: | PROTECTED COLON struct_decl_list { `Access_protected :: $3 }
   918: | PRIVATE COLON struct_decl_list {`Access_private :: $3 }
   919: |  error                          SEMICOLON struct_decl_list
   920:    { $3 }
   921: ;
   922: 
   923: /* (* ISO 6.7.2 *) */
   924: field_decl_list:
   925: |   field_decl                           { [$1] }
   926: |   field_decl COMMA field_decl_list     { $1 :: $3 }
   927: ;
   928: 
   929: /* (* ISO 6.7.2. Except that we allow unnamed fields. *) */
   930: field_decl:
   931: |   declarator                      { ($1, None) }
   932: |   declarator COLON expression     { ($1, Some (fst $3)) }
   933: 
   934: /* This construction can't be allowed in C++ because
   935: there is a conflict here
   936: 
   937:   struct X : Y
   938: 
   939: between declaring a nested class with a base, and an unnamed bitfield
   940: of type struct X, length Y
   941: */
   942: 
   943: /*
   944: | COLON expression     { (missingFieldDecl, Some (fst $2)) }
   945: */
   946: ;
   947: 
   948: /* (* ISO 6.7.2.2 *) */
   949: enum_list:
   950: |   enumerator                          {[$1]}
   951: |   enum_list COMMA enumerator          {$1 @ [$3]}
   952: |   enum_list COMMA error               { $1 }
   953: ;
   954: enumerator:
   955: |   IDENT                       {(fst $1, NOTHING, snd $1)}
   956: |   IDENT EQ expression         {(fst $1, fst $3, snd $1)}
   957: ;
   958: 
   959: 
   960: /* (* ISO 6.7.5. Plus Microsoft declarators.*) */
   961: declarator:
   962: |  pointer_opt direct_decl attributes_with_asm
   963:     {
   964:       let (n, decl) = $2 in
   965:       (n, applyPointer (fst $1) decl, $3, snd $1)
   966:     }
   967: ;
   968: 
   969: 
   970: /* (* ISO 6.7.5 *) */
   971: direct_decl:
   972:                                    /* (* We want to be able to redefine named
   973:                                     * types as variable names *) */
   974: |   id_or_typename                 { ($1, JUSTBASE) }
   975: 
   976: |   LPAREN attributes declarator RPAREN
   977:                                    { let (n,decl,al,loc) = $3 in
   978:                                      (n, PARENTYPE($2,decl,al)) }
   979: 
   980: |   direct_decl LBRACKET attributes comma_expression_opt RBRACKET
   981:                                    { let (n, decl) = $1 in
   982:                                      (n, ARRAY(decl, $3, $4)) }
   983: |   direct_decl LBRACKET attributes error RBRACKET
   984:                                    { let (n, decl) = $1 in
   985:                                      (n, ARRAY(decl, $3, NOTHING)) }
   986: |   direct_decl parameter_list_startscope rest_par_list RPAREN
   987:                                    { let (n, decl) = $1 in
   988:                                      let (params, isva) = $3 in
   989:                                      !Flx_cil_lexerhack.pop_context ();
   990:                                      (n, PROTO(decl, params, isva))
   991:                                    }
   992: ;
   993: parameter_list_startscope:
   994: |   LPAREN                         { !Flx_cil_lexerhack.push_context () }
   995: ;
   996: rest_par_list:
   997: |   /* empty */                    { ([], false) }
   998: |   parameter_decl rest_par_list1  { let (params, isva) = $2 in
   999:                                      ($1 :: params, isva)
  1000:                                    }
  1001: ;
  1002: rest_par_list1:
  1003: |   /* empty */                         { ([], false) }
  1004: |   COMMA ELLIPSIS                      { ([], true) }
  1005: |   COMMA parameter_decl rest_par_list1 { let (params, isva) = $3 in
  1006:                                           ($2 :: params, isva)
  1007:                                         }
  1008: ;
  1009: 
  1010: 
  1011: /* (* ISO 6.7.5 *) */
  1012: parameter_decl:
  1013: |  decl_spec_list declarator              { (fst $1, $2) }
  1014: |  decl_spec_list abstract_decl           { let d, a = $2 in
  1015:                                             (fst $1, ("", d, a, cabslu)) }
  1016: |  decl_spec_list                         { (fst $1, ("", JUSTBASE, [], cabslu)) }
  1017: |  LPAREN parameter_decl RPAREN           { $2 }
  1018: ;
  1019: 
  1020: /* (* Old style prototypes. Like a declarator *) */
  1021: old_proto_decl:
  1022: | pointer_opt direct_old_proto_decl   { let (n, decl, a) = $2 in
  1023:                                           (n, applyPointer (fst $1) decl, a, snd $1) }
  1024: ;
  1025: direct_old_proto_decl:
  1026: | direct_decl LPAREN old_parameter_list_ne RPAREN old_pardef_list
  1027:                                    { let par_decl, isva = doOldParDecl $3 $5 in
  1028:                                      let n, decl = $1 in
  1029:                                      (n, PROTO(decl, par_decl, isva), [])
  1030:                                    }
  1031: | direct_decl LPAREN                       RPAREN
  1032:                                    { let n, decl = $1 in
  1033:                                      (n, PROTO(decl, [], false), [])
  1034:                                    }
  1035: ;
  1036: 
  1037: old_parameter_list_ne:
  1038: |  IDENT                                       { [fst $1] }
  1039: |  IDENT COMMA old_parameter_list_ne           { let rest = $3 in
  1040:                                                  (fst $1 :: rest) }
  1041: ;
  1042: 
  1043: old_pardef_list:
  1044: |  /* empty */                            { ([], false) }
  1045: |  decl_spec_list old_pardef SEMICOLON ELLIPSIS
  1046:                                           { ([(fst $1, $2)], true) }
  1047: |  decl_spec_list old_pardef SEMICOLON old_pardef_list
  1048:                                           { let rest, isva = $4 in
  1049:                                             ((fst $1, $2) :: rest, isva)
  1050:                                           }
  1051: ;
  1052: 
  1053: old_pardef:
  1054: |  declarator                             { [$1] }
  1055: |  declarator COMMA old_pardef            { $1 :: $3 }
  1056: |  error                                  { [] }
  1057: ;
  1058: 
  1059: 
  1060: /* (* ISO 6.7.5 *) */
  1061: pointer:
  1062: |  STAR attributes pointer_opt  { $2 :: fst $3, $1 }
  1063: ;
  1064: pointer_opt:
  1065: |  /**/                          { [], currentLoc () }
  1066: |  pointer                       { $1 }
  1067: ;
  1068: 
  1069: /* (* ISO 6.7.6 *) */
  1070: type_name:
  1071: | decl_spec_list abstract_decl { let d, a = $2 in
  1072:                                  if a <> [] then begin
  1073:                                    parse_error "attributes in type name";
  1074:                                    raise Parsing.Parse_error
  1075:                                  end;
  1076:                                  (fst $1, d)
  1077:                                }
  1078: | decl_spec_list               { (fst $1, JUSTBASE) }
  1079: ;
  1080: abstract_decl: /* (* ISO 6.7.6. *) */
  1081: | pointer_opt abs_direct_decl attributes  { applyPointer (fst $1) $2, $3 }
  1082: | pointer                                 { applyPointer (fst $1) JUSTBASE, [] }
  1083: ;
  1084: 
  1085: abs_direct_decl: /* (* ISO 6.7.6. We do not support optional declarator for
  1086:                      * functions. Plus Microsoft attributes. See the
  1087:                      * discussion for declarator. *) */
  1088: |   LPAREN attributes abstract_decl RPAREN
  1089:                                    { let d, a = $3 in
  1090:                                      PARENTYPE ($2, d, a)
  1091:                                    }
  1092: 
  1093: |   LPAREN error RPAREN
  1094:                                    { JUSTBASE }
  1095: 
  1096: |   abs_direct_decl_opt LBRACKET comma_expression_opt RBRACKET
  1097:                                    { ARRAY($1, [], $3) }
  1098: /*(* The next shoudl be abs_direct_decl_opt but we get conflicts *)*/
  1099: |   abs_direct_decl  parameter_list_startscope rest_par_list RPAREN
  1100:                                    { let (params, isva) = $3 in
  1101:                                      !Flx_cil_lexerhack.pop_context ();
  1102:                                      PROTO ($1, params, isva)
  1103:                                    }
  1104: ;
  1105: abs_direct_decl_opt:
  1106: |   abs_direct_decl                 { $1 }
  1107: |   /* empty */                     { JUSTBASE }
  1108: ;
  1109: function_def:  /* (* ISO 6.9.1 *) */
  1110: | function_def_start block
  1111:           { let (loc, specs, decl) = $1 in
  1112:             currentFunctionName := "<__FUNCTION__ used outside any functions>";
  1113:             !Flx_cil_lexerhack.pop_context (); (* The context pushed by
  1114:                                     * announceFunctionName *)
  1115:             doFunctionDef loc (trd3 $2) specs decl (fst3 $2)
  1116:           }
  1117: 
  1118: 
  1119: function_def_start:  /* (* ISO 6.9.1 *) */
  1120: | decl_spec_list declarator
  1121:                             { announceFunctionName $2;
  1122:                               (snd $1, fst $1, $2)
  1123:                             }
  1124: 
  1125: /* (* Old-style function prototype *) */
  1126: | decl_spec_list old_proto_decl
  1127:                             { announceFunctionName $2;
  1128:                               (snd $1, fst $1, $2)
  1129:                             }
  1130: /* (* New-style function that does not have a return type *) */
  1131: | IDENT parameter_list_startscope rest_par_list RPAREN
  1132:                            { let (params, isva) = $3 in
  1133:                              let fdec =
  1134:                                (fst $1, PROTO(JUSTBASE, params, isva), [], snd $1) in
  1135:                              announceFunctionName fdec;
  1136:                              (* Default is int type *)
  1137:                              let defSpec = [SpecType Tint] in
  1138:                              (snd $1, defSpec, fdec)
  1139:                            }
  1140: 
  1141: /* (* No return type and old-style parameter list *) */
  1142: | IDENT LPAREN old_parameter_list_ne RPAREN old_pardef_list
  1143:                            { (* Convert pardecl to new style *)
  1144:                              let pardecl, isva = doOldParDecl $3 $5 in
  1145:                              (* Make the function declarator *)
  1146:                              let fdec = (fst $1,
  1147:                                          PROTO(JUSTBASE, pardecl,isva),
  1148:                                          [], snd $1) in
  1149:                              announceFunctionName fdec;
  1150:                              (* Default is int type *)
  1151:                              let defSpec = [SpecType Tint] in
  1152:                              (snd $1, defSpec, fdec)
  1153:                             }
  1154: /* (* No return type and no parameters *) */
  1155: | IDENT LPAREN                      RPAREN
  1156:                            { (* Make the function declarator *)
  1157:                              let fdec = (fst $1,
  1158:                                          PROTO(JUSTBASE, [], false),
  1159:                                          [], snd $1) in
  1160:                              announceFunctionName fdec;
  1161:                              (* Default is int type *)
  1162:                              let defSpec = [SpecType Tint] in
  1163:                              (snd $1, defSpec, fdec)
  1164:                             }
  1165: ;
  1166: 
  1167: /* const/volatile as type specifier elements */
  1168: cvspec:
  1169: |   CONST                               { SpecCV(CV_CONST), $1 }
  1170: |   VOLATILE                            { SpecCV(CV_VOLATILE), $1 }
  1171: |   RESTRICT                            { SpecCV(CV_RESTRICT), $1 }
  1172: ;
  1173: 
  1174: /*** GCC attributes ***/
  1175: attributes:
  1176: |   /* empty */                         { []}
  1177: |   attribute attributes                { fst $1 :: $2 }
  1178: ;
  1179: 
  1180: /* (* In some contexts we can have an inline assembly to specify the name to
  1181:     * be used for a global. We treat this as a name attribute *) */
  1182: attributes_with_asm:
  1183: |   /* empty */                         { [] }
  1184: |   attribute attributes_with_asm       { fst $1 :: $2 }
  1185: |   ASM LPAREN string_constant RPAREN attributes
  1186:                                         { ("__asm__",
  1187:                                            [CONSTANT(CONST_STRING (fst $3))]) :: $5 }
  1188: ;
  1189: 
  1190: /* things like __attribute__, but no const/volatile */
  1191: attribute_nocv:
  1192: |   ATTRIBUTE LPAREN paren_attr_list_ne RPAREN
  1193:                                         { ("__attribute__", $3), $1 }
  1194: |   DECLSPEC paren_attr_list_ne         { ("__declspec", $2), $1 }
  1195: |   MSATTR                              { (fst $1, []), snd $1 }
  1196:                                         /* ISO 6.7.3 */
  1197: |   THREAD                              { ("__thread",[]), $1 }
  1198: ;
  1199: 
  1200: /* __attribute__ plus const/volatile */
  1201: attribute:
  1202: |   attribute_nocv                      { $1 }
  1203: |   CONST                               { ("const", []), $1 }
  1204: |   RESTRICT                            { ("restrict",[]), $1 }
  1205: |   VOLATILE                            { ("volatile",[]), $1 }
  1206: ;
  1207: 
  1208: /* (* sm: I need something that just includes __attribute__ and nothing more,
  1209:  *  to support them appearing between the 'struct' keyword and the type name.
  1210:  * Actually, a declspec can appear there as well (on MSVC) *)  */
  1211: just_attribute:
  1212:     ATTRIBUTE LPAREN paren_attr_list_ne RPAREN
  1213:                                         { ("__attribute__", $3) }
  1214: |   DECLSPEC paren_attr_list_ne         { ("__declspec", $2) }
  1215: ;
  1216: 
  1217: /* this can't be empty, b/c I folded that possibility into the calling
  1218:  * productions to avoid some S/R conflicts */
  1219: just_attributes:
  1220: |   just_attribute                      { [$1] }
  1221: |   just_attribute just_attributes      { $1 :: $2 }
  1222: ;
  1223: 
  1224: /** (* PRAGMAS and ATTRIBUTES *) ***/
  1225: /* (* We want to allow certain strange things that occur in pragmas, so we
  1226:     * cannot use directly the language of expressions *) */
  1227: attr:
  1228: |   id_or_typename                       { VARIABLE $1 }
  1229: |   IDENT IDENT                          { CALL(VARIABLE (fst $1), [VARIABLE (fst $2)]) }
  1230: |   IDENT COLON CST_INT                  { VARIABLE (fst $1 ^ ":" ^ fst $3) }
  1231: 
  1232: |   CST_INT COLON CST_INT                { VARIABLE (fst $1 ^ ":" ^ fst $3) }
  1233: |   DEFAULT COLON CST_INT                { VARIABLE ("default:" ^ fst $3) }
  1234:                                          /* (* use a VARIABLE "" so that the
  1235:                                              * parentheses are printed *) */
  1236: |   IDENT LPAREN  RPAREN                 { CALL(VARIABLE (fst $1), [VARIABLE ""]) }
  1237: |   IDENT paren_attr_list_ne             { CALL(VARIABLE (fst $1), $2) }
  1238: 
  1239: |   CST_INT                              { CONSTANT(CONST_INT (fst $1)) }
  1240: |   string_constant                      { CONSTANT(CONST_STRING (fst $1)) }
  1241:                                            /*(* Const when it appears in
  1242:                                             * attribute lists, is translated
  1243:                                             * to aconst *)*/
  1244: |   CONST                                { VARIABLE "aconst" }
  1245: |   SIZEOF expression                     {EXPR_SIZEOF (fst $2)}
  1246: |   SIZEOF LPAREN type_name RPAREN
  1247:                                          {let b, d = $3 in TYPE_SIZEOF (b, d)}
  1248: 
  1249: |   ALIGNOF expression                   {EXPR_ALIGNOF (fst $2)}
  1250: |   ALIGNOF LPAREN type_name RPAREN      {let b, d = $3 in TYPE_ALIGNOF (b, d)}
  1251: |   PLUS expression                      {UNARY (PLUS, fst $2)}
  1252: |   MINUS expression                    {UNARY (MINUS, fst $2)}
  1253: |   STAR expression                     {UNARY (MEMOF, fst $2)}
  1254: |   AND expression                                               %prec ADDROF
  1255:                                         {UNARY (ADDROF, fst $2)}
  1256: |   EXCLAM expression                   {UNARY (NOT, fst $2)}
  1257: |   TILDE expression                    {UNARY (BNOT, fst $2)}
  1258: |   attr PLUS attr                      {BINARY(ADD ,$1 , $3)}
  1259: |   attr MINUS attr                     {BINARY(SUB ,$1 , $3)}
  1260: |   attr STAR expression                {BINARY(MUL ,$1 , fst $3)}
  1261: |   attr SLASH attr                     {BINARY(DIV ,$1 , $3)}
  1262: |   attr PERCENT attr                   {BINARY(MOD ,$1 , $3)}
  1263: |   attr AND_AND attr                   {BINARY(AND ,$1 , $3)}
  1264: |   attr PIPE_PIPE attr                 {BINARY(OR ,$1 , $3)}
  1265: |   attr AND attr                       {BINARY(BAND ,$1 , $3)}
  1266: |   attr PIPE attr                      {BINARY(BOR ,$1 , $3)}
  1267: |   attr CIRC attr                      {BINARY(XOR ,$1 , $3)}
  1268: |   attr EQ_EQ attr                     {BINARY(EQ ,$1 , $3)}
  1269: |   attr EXCLAM_EQ attr                 {BINARY(NE ,$1 , $3)}
  1270: |   attr INF attr                       {BINARY(LT ,$1 , $3)}
  1271: |   attr SUP attr                       {BINARY(GT ,$1 , $3)}
  1272: |   attr INF_EQ attr                    {BINARY(LE ,$1 , $3)}
  1273: |   attr SUP_EQ attr                    {BINARY(GE ,$1 , $3)}
  1274: |   attr INF_INF attr                   {BINARY(SHL ,$1 , $3)}
  1275: |   attr SUP_SUP attr                   {BINARY(SHR ,$1 , $3)}
  1276: |   attr ARROW id_or_typename           {MEMBEROFPTR ($1, $3)}
  1277: |   attr DOT id_or_typename             {MEMBEROF ($1, $3)}
  1278: |   LPAREN attr RPAREN                  { $2 }
  1279: ;
  1280: 
  1281: attr_list_ne:
  1282: |  attr                                  { [$1] }
  1283: |  attr COMMA attr_list_ne               { $1 :: $3 }
  1284: |  error COMMA attr_list_ne              { $3 }
  1285: ;
  1286: paren_attr_list_ne:
  1287: |  LPAREN attr_list_ne RPAREN            { $2 }
  1288: |  LPAREN error RPAREN                   { [] }
  1289: ;
  1290: /*** GCC ASM instructions ***/
  1291: asmattr:
  1292: |    /* empty */                        { [] }
  1293: |    VOLATILE  asmattr                  { ("volatile", []) :: $2 }
  1294: |    CONST asmattr                      { ("const", []) :: $2 }
  1295: ;
  1296: asmtemplate:
  1297:     one_string_constant                          { [$1] }
  1298: |   one_string_constant asmtemplate              { $1 :: $2 }
  1299: ;
  1300: asmoutputs:
  1301: | /* empty */           { ([], [], []) }
  1302: | COLON asmoperands asminputs
  1303:                         { let (ins, clobs) = $3 in
  1304:                           ($2, ins, clobs) }
  1305: ;
  1306: asmoperands:
  1307: |    /* empty */                        { [] }
  1308: |    asmoperandsne                      { List.rev $1 }
  1309: ;
  1310: asmoperandsne:
  1311: |    asmoperand                         { [$1] }
  1312: |    asmoperandsne COMMA asmoperand     { $3 :: $1 }
  1313: ;
  1314: asmoperand:
  1315: |    string_constant LPAREN expression RPAREN    { (fst $1, fst $3) }
  1316: |    string_constant LPAREN error RPAREN         { (fst $1, NOTHING ) }
  1317: ;
  1318: asminputs:
  1319: | /* empty */                { ([], []) }
  1320: | COLON asmoperands asmclobber
  1321:                         { ($2, $3) }
  1322: ;
  1323: asmclobber:
  1324: |   /* empty */                         { [] }
  1325: | COLON asmcloberlst_ne                 { $2 }
  1326: ;
  1327: asmcloberlst_ne:
  1328: |  one_string_constant                           { [$1] }
  1329: |  one_string_constant COMMA asmcloberlst_ne     { $1 :: $3 }
  1330: ;
  1331: 
  1332: %%
  1333: 
  1334: 
  1335: 
End data section to src/flx_cil_cparser.mly[1]
Start ocaml section to src/flx_cil_cprint.mli[1 /1 ]
     1: # 3105 "./lpsrc/flx_frontc.ipk"
     2: 
     3: val version : string
     4: type loc = { line : int; file : string; }
     5: val lu : loc
     6: val cabslu : Flx_cil_cabs.cabsloc
     7: val curLoc : Flx_cil_cabs.cabsloc ref
     8: val msvcMode : bool ref
     9: val printLn : bool ref
    10: val printLnComment : bool ref
    11: val printCounters : bool ref
    12: val printComments : bool ref
    13: val out : out_channel ref
    14: val width : int ref
    15: val tab : int ref
    16: val max_indent : int ref
    17: val line : string ref
    18: val line_len : int ref
    19: val current : string ref
    20: val current_len : int ref
    21: val spaces : int ref
    22: val follow : int ref
    23: val roll : int ref
    24: val print_tab : int -> unit
    25: val flush : 'a -> unit
    26: val commit : 'a -> unit
    27: val addline : unit -> unit
    28: val new_line : 'a -> unit
    29: val force_new_line : 'a -> unit
    30: val indent : 'a -> unit
    31: val indentline : 'a -> unit
    32: val unindent : 'a -> unit
    33: val space : 'a -> unit
    34: val print : string -> unit
    35: val print_unescaped_string : string -> unit
    36: val setLoc : Flx_cil_cabs.cabsloc -> unit
    37: val print_list : (unit -> unit) -> ('a -> 'b) -> 'a list -> unit
    38: val print_commas : bool -> ('a -> 'b) -> 'a list -> unit
    39: val print_string : string -> unit
    40: val print_wstring : Flx_cil_escape.wstring -> unit
    41: val print_specifiers : Flx_cil_cabs.specifier -> unit
    42: val print_type_spec : Flx_cil_cabs.typeSpecifier -> unit
    43: val print_struct_name_attr :
    44:   string -> string -> Flx_cil_cabs.attribute list -> unit
    45: val print_decl : string -> Flx_cil_cabs.decl_type -> unit
    46: val print_fields : Flx_cil_cabs.field_group list -> unit
    47: val print_enum_items : Flx_cil_cabs.enum_item list -> unit
    48: val print_onlytype : Flx_cil_cabs.specifier * Flx_cil_cabs.decl_type -> unit
    49: val print_name : Flx_cil_cabs.name -> unit
    50: val print_init_name : Flx_cil_cabs.init_name -> unit
    51: val print_name_group : Flx_cil_cabs.name_group -> unit
    52: val print_field_group : Flx_cil_cabs.field_group -> unit
    53: val print_field : Flx_cil_cabs.name * Flx_cil_cabs.expression option -> unit
    54: val print_init_name_group : Flx_cil_cabs.init_name_group -> unit
    55: val print_single_name : Flx_cil_cabs.single_name -> unit
    56: val print_params : Flx_cil_cabs.single_name list -> bool -> unit
    57: val print_old_params : string list -> bool -> unit
    58: val get_operator : Flx_cil_cabs.expression -> string * int
    59: val print_comma_exps : Flx_cil_cabs.expression list -> unit
    60: val print_init_expression : Flx_cil_cabs.init_expression -> unit
    61: val print_expression : Flx_cil_cabs.expression -> unit
    62: val print_expression_level : int -> Flx_cil_cabs.expression -> unit
    63: val print_statement : Flx_cil_cabs.statement -> unit
    64: val print_block : Flx_cil_cabs.block -> unit
    65: val print_substatement : Flx_cil_cabs.statement -> unit
    66: val print_attribute : Flx_cil_cabs.attribute -> unit
    67: val print_attributes : Flx_cil_cabs.attribute list -> unit
    68: val print_defs : Flx_cil_cabs.definition list -> unit
    69: val print_def : Flx_cil_cabs.definition -> unit
    70: val comprint : string -> unit
    71: val comstring : string -> string
    72: val printFile : out_channel -> Flx_cil_cabs.file -> unit
    73: val set_tab : int -> unit
    74: val set_width : int -> unit
    75: 
End ocaml section to src/flx_cil_cprint.mli[1]
Start ocaml section to src/flx_cil_cprint.ml[1 /1 ]
     1: # 3181 "./lpsrc/flx_frontc.ipk"
     2: (* cprint -- pretty printer of C program from abstract syntax
     3: **
     4: ** Project:     FrontC
     5: ** File:        cprint.ml
     6: ** Version:     2.1e
     7: ** Date:        9.1.99
     8: ** Author:      Hugues Cassé
     9: **
    10: **      1.0             2.22.99 Hugues Cassé    First version.
    11: **      2.0             3.18.99 Hugues Cassé    Compatible with Flx_cil_frontc 2.1, use of CAML
    12: **                                                                      pretty printer.
    13: **      2.1             3.22.99 Hugues Cassé    More efficient custom pretty printer used.
    14: **      2.1a    4.12.99 Hugues Cassé    Correctly handle:
    15: **                                                                      char *m, *m, *p; m + (n - p)
    16: **      2.1b    4.15.99 Hugues Cassé    x + (y + z) stays x + (y + z) for
    17: **                                                                      keeping computation order.
    18: **      2.1c    7.23.99 Hugues Cassé    Improvement of case and default display.
    19: **      2.1d    8.25.99 Hugues Cassé    Rebuild escape sequences in string and
    20: **                                                                      characters.
    21: **      2.1e    9.1.99  Hugues Cassé    Fix, recognize and correctly display '\0'.
    22: *)
    23: 
    24: (* George Necula: I changed this pretty dramatically since CABS changed *)
    25: open Flx_cil_cabs
    26: open Flx_cil_cabs_helper
    27: open Flx_cil_escape
    28: let version = "Flx_cil_cprint 2.1e 9.1.99 Hugues Cassé"
    29: 
    30: type loc = { line : int; file : string }
    31: 
    32: let lu = {line = -1; file = "loc unknown";}
    33: let cabslu = {lineno = -10; filename = "cabs loc unknown"; byteno = -10;}
    34: 
    35: let curLoc = ref cabslu
    36: 
    37: let msvcMode = ref false
    38: 
    39: let printLn = ref true
    40: let printLnComment = ref false
    41: 
    42: let printCounters = ref false
    43: let printComments = ref false
    44: 
    45: (*
    46: ** FrontC Flx_cil_pretty printer
    47: *)
    48: let out = ref stdout
    49: let width = ref 80
    50: let tab = ref 2
    51: let max_indent = ref 60
    52: 
    53: let line = ref ""
    54: let line_len = ref 0
    55: let current = ref ""
    56: let current_len = ref 0
    57: let spaces = ref 0
    58: let follow = ref 0
    59: let roll = ref 0
    60: 
    61: let print_tab size =
    62:         for i = 1 to size / 8 do
    63:                 output_char !out '\t'
    64:         done;
    65:         for i  = 1 to size mod 8 do
    66:                 output_char !out ' '
    67:         done
    68: 
    69: let flush _ =
    70:         if !line <> "" then begin
    71:                 print_tab (!spaces + !follow);
    72:                 output_string !out !line;
    73:                 line := "";
    74:                 line_len := 0
    75:         end
    76: 
    77: let commit _ =
    78:   if !current <> "" then begin
    79:     if !line = "" then begin
    80:       line := !current;
    81:       line_len := !current_len
    82:     end else begin
    83:       line := (!line ^ " " ^ !current);
    84:       line_len := !line_len + 1 + !current_len
    85:     end;
    86:     current := "";
    87:     current_len := 0
    88:   end
    89: 
    90: 
    91: let addline () =
    92:   curLoc := {lineno = !curLoc.lineno+1;
    93:               filename = !curLoc.filename;
    94:               byteno = -1; (*sfg: can we do better than this?*) }
    95: 
    96: 
    97: let new_line _ =
    98:   commit ();
    99:   if !line <> "" then begin
   100:     flush ();
   101:     addline();
   102:     output_char !out '\n'
   103:   end;
   104:   follow := 0
   105: 
   106: let force_new_line _ =
   107:   commit ();
   108:   flush ();
   109:   addline();
   110:   output_char !out '\n';
   111:   follow := 0
   112: 
   113: let indent _ =
   114:   new_line ();
   115:   spaces := !spaces + !tab;
   116:   if !spaces >= !max_indent then begin
   117:     spaces := !tab;
   118:     roll := !roll + 1
   119:   end
   120: 
   121: let indentline _ =
   122:   new_line ();
   123:   if !spaces >= !max_indent then begin
   124:     spaces := !tab;
   125:     roll := !roll + 1
   126:   end
   127: 
   128: let unindent _ =
   129:   new_line ();
   130:   spaces := !spaces - !tab;
   131:   if (!spaces <= 0) && (!roll > 0) then begin
   132:     spaces := ((!max_indent - 1) / !tab) * !tab;
   133:     roll := !roll - 1
   134:   end
   135: 
   136: let space _ = commit ()
   137: 
   138: let print str =
   139:   current := !current ^ str;
   140:   current_len := !current_len + (String.length str);
   141:   if (!spaces + !follow + !line_len + 1 + !current_len) > !width
   142:   then begin
   143:     if !line_len = 0 then commit ();
   144:     flush ();
   145:     addline();
   146:     output_char !out '\n';
   147:     if !follow = 0 then follow := !tab
   148:   end
   149: 
   150: (* sm: for some reason I couldn't just call print from frontc.... ? *)
   151: let print_unescaped_string str = print str
   152: 
   153: let setLoc (l : cabsloc) =
   154:   let tempcur = current in
   155:   if !printLn then
   156:     if (l.lineno <> !curLoc.lineno) || l.filename <> !curLoc.filename then
   157:       begin
   158:         let oldspaces = !spaces in
   159:         (* sm: below, we had '//#' instead of '#', which means printLnComment was disregarded *)
   160:         if !printLnComment then print "//" else print "#";
   161:         if !msvcMode then print "line";
   162:         print " ";
   163:         print (string_of_int l.lineno);
   164:         if (l.filename <> !curLoc.filename) then begin
   165:           print (" \"" ^ l.filename ^ "\"")
   166:         end;
   167:         spaces := oldspaces;
   168:         new_line();
   169:         curLoc := l
   170:       end
   171: 
   172: 
   173: 
   174: (*
   175: ** Useful primitives
   176: *)
   177: let print_list print_sep print_elt lst =
   178:   let _ = List.fold_left
   179:       (fun com elt ->
   180:         if com then print_sep ();
   181:         print_elt elt;
   182:         true)
   183:       false
   184:       lst in
   185:   ()
   186: 
   187: let print_commas nl fct lst =
   188:   print_list (fun () -> print ","; if nl then new_line() else space()) fct lst
   189: 
   190: let print_string (s:string) =
   191:   print ("\"" ^ escape_string s ^ "\"")
   192: 
   193: let print_wstring (s: int64 list ) =
   194:   print ("L\"" ^ escape_wstring s ^ "\"")
   195: 
   196: (*
   197: ** Base Type Printing
   198: *)
   199: 
   200: let rec print_specifiers (specs: spec_elem list) =
   201:   comprint "specifier(";
   202:   let print_spec_elem = function
   203:       SpecTypedef -> print "typedef "
   204:     | SpecInline -> print "__inline "
   205:     | SpecStorage sto ->
   206:         print (match sto with
   207:           NO_STORAGE -> (comstring "/*no storage*/")
   208:         | AUTO -> "auto "
   209:         | STATIC -> "static "
   210:         | EXTERN -> "extern "
   211:         | REGISTER -> "register ")
   212:     | SpecCV cv ->
   213:         print (match cv with
   214:         | CV_CONST -> "const "
   215:         | CV_VOLATILE -> "volatile "
   216:         | CV_RESTRICT -> "restrict ")
   217:     | SpecAttr al -> print_attribute al; space ()
   218:     | SpecType bt -> print_type_spec bt
   219:     | SpecPattern name -> print ("@specifier(" ^ name ^ ") ")
   220:   in
   221:   List.iter print_spec_elem specs
   222:   ;comprint ")"
   223: 
   224: 
   225: and print_type_spec = function
   226:     Tvoid -> print "void "
   227:   | Tbool -> print "_Bool "
   228:   | Tchar -> print "char "
   229:   | Tshort -> print "short "
   230:   | Tint -> print "int "
   231:   | Tlong -> print "long "
   232:   | Tint64 -> print "__int64 "
   233:   | Tfloat -> print "float "
   234:   | Tdouble -> print "double "
   235:   | Tcomplex -> print "_Complex "
   236:   | Timaginary -> print "_Imaginary "
   237:   | Tsigned -> print "signed "
   238:   | Tunsigned -> print "unsigned "
   239:   | Tnamed s -> comprint "tnamed"; print s; space ();
   240:   | Tstruct (n, None, _) -> print ("struct " ^ n ^ " ")
   241:   | Tstruct (n, Some flds, extraAttrs) ->
   242:       (print_struct_name_attr "struct" n extraAttrs);
   243:       (print_fields flds)
   244:   | Tunion (n, None, _) -> print ("union " ^ n ^ " ")
   245:   | Tunion (n, Some flds, extraAttrs) ->
   246:       (print_struct_name_attr "union" n extraAttrs);
   247:       (print_fields flds)
   248:   | Tenum (n, None, _) -> print ("enum " ^ n ^ " ")
   249:   | Tenum (n, Some enum_items, extraAttrs) ->
   250:       (print_struct_name_attr "enum" n extraAttrs);
   251:       (print_enum_items enum_items)
   252:   | TtypeofE e -> print "__typeof__("; print_expression e; print ") "
   253:   | TtypeofT (s,d) -> print "__typeof__("; print_onlytype (s, d); print ") "
   254: 
   255: 
   256: (* print "struct foo", but with specified keyword and a list of
   257:  * attributes to put between keyword and name *)
   258: and print_struct_name_attr (keyword: string) (name: string) (extraAttrs: attribute list) =
   259: begin
   260:   if extraAttrs = [] then
   261:     print (keyword ^ " " ^ name)
   262:   else begin
   263:     (print (keyword ^ " "));
   264:     (print_attributes extraAttrs);    (* prints a final space *)
   265:     (print name);
   266:   end
   267: end
   268: 
   269: 
   270: (* This is the main printer for declarations. It is easy bacause the
   271:  * declarations are laid out as they need to be printed. *)
   272: and print_decl (n: string) = function
   273:     JUSTBASE -> if n <> "___missing_field_name" then
   274:                   print n
   275:                 else
   276:                   comprint "missing field name"
   277:   | PARENTYPE (al1, d, al2) ->
   278:       print "(";
   279:       print_attributes al1; space ();
   280:       print_decl n d; space ();
   281:       print_attributes al2; print ")"
   282:   | PTR (al, d) ->
   283:       print "* ";
   284:       print_attributes al; space ();
   285:       print_decl n d
   286:   | ARRAY (d, al, e) ->
   287:       print_decl n d;
   288:       print "[";
   289:       print_attributes al;
   290:       if e <> NOTHING then print_expression e;
   291:       print "]"
   292:   | PROTO(d, args, isva) ->
   293:       comprint "proto(";
   294:       print_decl n d;
   295:       print "(";
   296:       print_params args isva;
   297:       print ")";
   298:       comprint ")"
   299: 
   300: 
   301: and print_fields (flds : field_group list) =
   302:   if flds = [] then print " { } "
   303:   else begin
   304:     print " {";
   305:     indent ();
   306:     List.iter
   307:       (fun fld -> print_field_group fld; print ";"; new_line ())
   308:       flds;
   309:     unindent ();
   310:     print "} "
   311:   end
   312: 
   313: and print_enum_items items =
   314:   if items = [] then print " { } "
   315:   else begin
   316:     print " {";
   317:     indent ();
   318:     print_commas
   319:       true
   320:       (fun (id, exp, loc) -> print id;
   321:         if exp = NOTHING then ()
   322:         else begin
   323:           space ();
   324:           print "= ";
   325:           print_expression exp
   326:         end)
   327:       items;
   328:     unindent ();
   329:     print "} ";
   330:   end
   331: 
   332: 
   333: and print_onlytype (specs, dt) =
   334:   print_specifiers specs;
   335:   print_decl "" dt
   336: 
   337: and print_name ((n, decl, attrs, _) : name) =
   338:   print_decl n decl;
   339:   space ();
   340:   print_attributes attrs
   341: 
   342: and print_init_name ((n, i) : init_name) =
   343:   print_name n;
   344:   if i <> NO_INIT then begin
   345:     space ();
   346:     print "= ";
   347:     print_init_expression i
   348:   end
   349: 
   350: and print_name_group (specs, names) =
   351:   print_specifiers specs;
   352:   print_commas false print_name names
   353: 
   354: and print_field_group (specs, fields) =
   355:   print_specifiers specs;
   356:   print_commas false print_field fields
   357: 
   358: 
   359: and print_field (name, widtho) =
   360:   print_name name;
   361:   (match widtho with
   362:     None -> ()
   363:   | Some w -> print " : ";  print_expression w)
   364: 
   365: and print_init_name_group (specs, names) =
   366:   print_specifiers specs;
   367:   print_commas false print_init_name names
   368: 
   369: and print_single_name (specs, name) =
   370:   print_specifiers specs;
   371:   print_name name
   372: 
   373: and print_params (pars : single_name list) (ell : bool) =
   374:   print_commas false print_single_name pars;
   375:   if ell then print (if pars = [] then "..." else ", ...") else ()
   376: 
   377: and print_old_params pars ell =
   378:   print_commas false (fun id -> print id) pars;
   379:   if ell then print (if pars = [] then "..." else ", ...") else ()
   380: 
   381: 
   382: (*
   383: ** Expression printing
   384: **              Priorities
   385: **              16      variables
   386: **              15      . -> [] call()
   387: **              14  ++, -- (post)
   388: **              13      ++ -- (pre) ~ ! - + & *(cast)
   389: **              12      * / %
   390: **              11      + -
   391: **              10      << >>
   392: **              9       < <= > >=
   393: **              8       == !=
   394: **              7       &
   395: **              6       ^
   396: **              5       |
   397: **              4       &&
   398: **              3       ||
   399: **              2       ? :
   400: **              1       = ?=
   401: **              0       ,
   402: *)
   403: and get_operator exp =
   404:   match exp with
   405:     NOTHING -> ("", 16)
   406:   | UNARY (op, _) ->
   407:       (match op with
   408:         MINUS -> ("-", 13)
   409:       | PLUS -> ("+", 13)
   410:       | NOT -> ("!", 13)
   411:       | BNOT -> ("~", 13)
   412:       | MEMOF -> ("*", 13)
   413:       | ADDROF -> ("&", 13)
   414:       | PREINCR -> ("++", 13)
   415:       | PREDECR -> ("--", 13)
   416:       | POSINCR -> ("++", 14)
   417:       | POSDECR -> ("--", 14))
   418:   | LABELADDR s -> ("", 16)  (* Like a constant *)
   419:   | BINARY (op, _, _) ->
   420:       (match op with
   421:         MUL -> ("*", 12)
   422:       | DIV -> ("/", 12)
   423:       | MOD -> ("%", 12)
   424:       | ADD -> ("+", 11)
   425:       | SUB -> ("-", 11)
   426:       | SHL -> ("<<", 10)
   427:       | SHR -> (">>", 10)
   428:       | LT -> ("<", 9)
   429:       | LE -> ("<=", 9)
   430:       | GT -> (">", 9)
   431:       | GE -> (">=", 9)
   432:       | EQ -> ("==", 8)
   433:       | NE -> ("!=", 8)
   434:       | BAND -> ("&", 7)
   435:       | XOR -> ("^", 6)
   436:       | BOR -> ("|", 5)
   437:       | AND -> ("&&", 4)
   438:       | OR -> ("||", 3)
   439:       | ASSIGN -> ("=", 1)
   440:       | ADD_ASSIGN -> ("+=", 1)
   441:       | SUB_ASSIGN -> ("-=", 1)
   442:       | MUL_ASSIGN -> ("*=", 1)
   443:       | DIV_ASSIGN -> ("/=", 1)
   444:       | MOD_ASSIGN -> ("%=", 1)
   445:       | BAND_ASSIGN -> ("&=", 1)
   446:       | BOR_ASSIGN -> ("|=", 1)
   447:       | XOR_ASSIGN -> ("^=", 1)
   448:       | SHL_ASSIGN -> ("<<=", 1)
   449:       | SHR_ASSIGN -> (">>=", 1))
   450:   | QUESTION _ -> ("", 2)
   451:   | CAST _ -> ("", 13)
   452:   | CALL _ -> ("", 15)
   453:   | COMMA _ -> ("", 0)
   454:   | CONSTANT _ -> ("", 16)
   455:   | VARIABLE name -> ("", 16)
   456:   | EXPR_SIZEOF exp -> ("", 16)
   457:   | TYPE_SIZEOF _ -> ("", 16)
   458:   | EXPR_ALIGNOF exp -> ("", 16)
   459:   | TYPE_ALIGNOF _ -> ("", 16)
   460:   | INDEX (exp, idx) -> ("", 15)
   461:   | MEMBEROF (exp, fld) -> ("", 15)
   462:   | MEMBEROFPTR (exp, fld) -> ("", 15)
   463:   | GNU_BODY _ -> ("", 17)
   464:   | EXPR_PATTERN _ -> ("", 16)     (* sm: not sure about this *)
   465: 
   466: and print_comma_exps exps =
   467:   print_commas false print_expression exps
   468: 
   469: and print_init_expression (iexp: init_expression) : unit =
   470:   match iexp with
   471:     NO_INIT -> ()
   472:   | SINGLE_INIT e -> print_expression e
   473:   | COMPOUND_INIT  initexps ->
   474:       let doinitexp = function
   475:           NEXT_INIT, e -> print_init_expression e
   476:         | i, e ->
   477:             let rec doinit = function
   478:                 NEXT_INIT -> ()
   479:               | INFIELD_INIT (fn, i) -> print ("." ^ fn); doinit i
   480:               | ATINDEX_INIT (e, i) ->
   481:                   print "[";
   482:                   print_expression e;
   483:                   print "]";
   484:                   doinit i
   485:               | ATINDEXRANGE_INIT (s, e) ->
   486:                   print "[";
   487:                   print_expression s;
   488:                   print " ... ";
   489:                   print_expression e;
   490:                   print "]"
   491:                 in
   492:             doinit i; print " = ";
   493:             print_init_expression e
   494:       in
   495:       print "{";
   496:       print_commas false doinitexp initexps;
   497:       print "}"
   498: 
   499: and print_expression (exp: expression) = print_expression_level 1 exp
   500: 
   501: and print_expression_level (lvl: int) (exp : expression) =
   502:   let (txt, lvl') = get_operator exp in
   503:   let _ = if lvl > lvl' then print "(" else () in
   504:   let _ = match exp with
   505:     NOTHING -> ()
   506:   | UNARY (op, exp') ->
   507:       (match op with
   508:         POSINCR | POSDECR ->
   509:           print_expression_level lvl' exp';
   510:           print txt
   511:       | _ ->
   512:           print txt; space (); (* Print the space to avoid --5 *)
   513:           print_expression_level lvl' exp')
   514:   | LABELADDR l -> print ("&& " ^ l)
   515:   | BINARY (op, exp1, exp2) ->
   516:                         (*if (op = SUB) && (lvl <= lvl') then print "(";*)
   517:       print_expression_level lvl' exp1;
   518:       space ();
   519:       print txt;
   520:       space ();
   521:                         (*print_expression exp2 (if op = SUB then (lvl' + 1) else lvl');*)
   522:       print_expression_level (lvl' + 1) exp2
   523:                         (*if (op = SUB) && (lvl <= lvl') then print ")"*)
   524:   | QUESTION (exp1, exp2, exp3) ->
   525:       print_expression_level 2 exp1;
   526:       space ();
   527:       print "? ";
   528:       print_expression_level 2 exp2;
   529:       space ();
   530:       print ": ";
   531:       print_expression_level 2 exp3;
   532:   | CAST (typ, iexp) ->
   533:       print "(";
   534:       print_onlytype typ;
   535:       print ")";
   536:      (* Always print parentheses. In a small number of cases when we print
   537:       * constants we don't need them  *)
   538:       (match iexp with
   539:         SINGLE_INIT e -> print_expression_level 15 e
   540:       | COMPOUND_INIT _ -> (* print "("; *)
   541:           print_init_expression iexp
   542:           (* ; print ")" *)
   543:       | NO_INIT -> print "<NO_INIT in cast. Should never arise>")
   544: 
   545:   | CALL (VARIABLE "__builtin_va_arg", [arg; TYPE_SIZEOF (bt, dt)]) ->
   546:       comprint "variable";
   547:       print "__builtin_va_arg";
   548:       print "(";
   549:       print_expression_level 1 arg;
   550:       print ",";
   551:       print_onlytype (bt, dt);
   552:       print ")"
   553:   | CALL (exp, args) ->
   554:       print_expression_level 16 exp;
   555:       print "(";
   556:       print_comma_exps args;
   557:       print ")"
   558:   | COMMA exps ->
   559:       print_comma_exps exps
   560:   | CONSTANT cst ->
   561:       (match cst with
   562:         CONST_INT i -> print i
   563:       | CONST_FLOAT r -> print r
   564:       | CONST_CHAR c -> print ("'" ^ escape_wstring c ^ "'")
   565:       | CONST_WCHAR c -> print ("L'" ^ escape_wstring c ^ "'")
   566:       | CONST_STRING s -> print_string s
   567:       | CONST_WSTRING ws -> print_wstring ws)
   568:   | VARIABLE name ->
   569:       comprint "variable";
   570:       print name
   571:   | EXPR_SIZEOF exp ->
   572:       print "sizeof(";
   573:       print_expression_level 0 exp;
   574:       print ")"
   575:   | TYPE_SIZEOF (bt,dt) ->
   576:       print "sizeof(";
   577:       print_onlytype (bt, dt);
   578:       print ")"
   579:   | EXPR_ALIGNOF exp ->
   580:       print "__alignof__(";
   581:       print_expression_level 0 exp;
   582:       print ")"
   583:   | TYPE_ALIGNOF (bt,dt) ->
   584:       print "__alignof__(";
   585:       print_onlytype (bt, dt);
   586:       print ")"
   587:   | INDEX (exp, idx) ->
   588:       print_expression_level 16 exp;
   589:       print "[";
   590:       print_expression_level 0 idx;
   591:       print "]"
   592:   | MEMBEROF (exp, fld) ->
   593:       print_expression_level 16 exp;
   594:       print ("." ^ fld)
   595:   | MEMBEROFPTR (exp, fld) ->
   596:       print_expression_level 16 exp;
   597:       print ("->" ^ fld)
   598:   | GNU_BODY (blk) ->
   599:       print "(";
   600:       print_block blk;
   601:       print ")"
   602:   | EXPR_PATTERN (name) ->
   603:       print ("@expr(" ^ name ^ ") ")
   604:   in
   605:   if lvl > lvl' then print ")" else ()
   606: 
   607: 
   608: (*
   609: ** Statement printing
   610: *)
   611: and print_statement stat =
   612:   match stat with
   613:     NOP (loc) ->
   614:       setLoc(loc);
   615:       print ";";
   616:       new_line ()
   617:   | COMPUTATION (exp, loc) ->
   618:       setLoc(loc);
   619:       print_expression exp;
   620:       print ";";
   621:       new_line ()
   622:   | BLOCK (blk, loc) -> print_block blk
   623: 
   624:   | SEQUENCE (s1, s2, loc) ->
   625:       setLoc(loc);
   626:       print_statement s1;
   627:       print_statement s2;
   628:   | IF (exp, s1, s2, loc) ->
   629:       setLoc(loc);
   630:       print "if(";
   631:       print_expression_level 0 exp;
   632:       print ")";
   633:       print_substatement s1;
   634:       (match s2 with
   635:       | NOP(_) -> ()
   636:       | _ -> begin
   637:           print "else";
   638:           print_substatement s2;
   639:         end)
   640:   | WHILE (exp, stat, loc) ->
   641:       setLoc(loc);
   642:       print "while(";
   643:       print_expression_level 0 exp;
   644:       print ")";
   645:       print_substatement stat
   646:   | DOWHILE (exp, stat, loc) ->
   647:       setLoc(loc);
   648:       print "do";
   649:       print_substatement stat;
   650:       print "while(";
   651:       print_expression_level 0 exp;
   652:       print ");";
   653:       new_line ();
   654:   | FOR (fc1, exp2, exp3, stat, loc) ->
   655:       setLoc(loc);
   656:       print "for(";
   657:       (match fc1 with
   658:         FC_EXP exp1 -> print_expression_level 0 exp1; print ";"
   659:       | FC_DECL dec1 -> print_def dec1);
   660:       space ();
   661:       print_expression_level 0 exp2;
   662:       print ";";
   663:       space ();
   664:       print_expression_level 0 exp3;
   665:       print ")";
   666:       print_substatement stat
   667:   | BREAK (loc)->
   668:       setLoc(loc);
   669:       print "break;"; new_line ()
   670:   | CONTINUE (loc) ->
   671:       setLoc(loc);
   672:       print "continue;"; new_line ()
   673:   | RETURN (exp, loc) ->
   674:       setLoc(loc);
   675:       print "return";
   676:       if exp = NOTHING
   677:       then ()
   678:       else begin
   679:         print " ";
   680:         print_expression_level 1 exp
   681:       end;
   682:       print ";";
   683:       new_line ()
   684:   | SWITCH (exp, stat, loc) ->
   685:       setLoc(loc);
   686:       print "switch(";
   687:       print_expression_level 0 exp;
   688:       print ")";
   689:       print_substatement stat
   690:   | CASE (exp, stat, loc) ->
   691:       setLoc(loc);
   692:       unindent ();
   693:       print "case ";
   694:       print_expression_level 1 exp;
   695:       print ":";
   696:       indent ();
   697:       print_substatement stat
   698:   | CASERANGE (expl, exph, stat, loc) ->
   699:       setLoc(loc);
   700:       unindent ();
   701:       print "case ";
   702:       print_expression expl;
   703:       print " ... ";
   704:       print_expression exph;
   705:       print ":";
   706:       indent ();
   707:       print_substatement stat
   708:   | DEFAULT (stat, loc) ->
   709:       setLoc(loc);
   710:       unindent ();
   711:       print "default :";
   712:       indent ();
   713:       print_substatement stat
   714:   | LABEL (name, stat, loc) ->
   715:       setLoc(loc);
   716:       print (name ^ ":");
   717:       space ();
   718:       print_substatement stat
   719:   | GOTO (name, loc) ->
   720:       setLoc(loc);
   721:       print ("goto " ^ name ^ ";");
   722:       new_line ()
   723:   | COMPGOTO (exp, loc) ->
   724:       setLoc(loc);
   725:       print ("goto *"); print_expression exp; print ";"; new_line ()
   726:   | DEFINITION d ->
   727:       print_def d
   728:   | ASM (attrs, tlist, outs, ins, clobs, loc) ->
   729:       setLoc(loc);
   730:       let print_asm_operand (cnstr, e) =
   731:         print_string cnstr; space (); print_expression_level 100 e
   732:       in
   733:       if !msvcMode then begin
   734:         print "__asm {";
   735:         print_list (fun () -> new_line()) print tlist; (* templates *)
   736:         print "};"
   737:       end else begin
   738:         print "__asm__ ";
   739:         print_attributes attrs;
   740:         print "(";
   741:         print_list (fun () -> new_line()) print_string tlist; (* templates *)
   742:         if outs <> [] || ins <> [] || clobs <> [] then begin
   743:           print ":"; space ();
   744:           print_commas false print_asm_operand outs;
   745:           if ins <> [] || clobs <> [] then begin
   746:             print ":"; space ();
   747:             print_commas false print_asm_operand ins;
   748:             if clobs <> [] then begin
   749:               print ":"; space ();
   750:               print_commas false print_string clobs
   751:             end;
   752:           end
   753:         end;
   754:         print ");"
   755:       end;
   756:       new_line ()
   757:   | TRY_FINALLY (b, h, loc) ->
   758:       setLoc loc;
   759:       print "__try ";
   760:       print_block b;
   761:       print "__finally ";
   762:       print_block h
   763: 
   764:   | TRY_EXCEPT (b, e, h, loc) ->
   765:       setLoc loc;
   766:       print "__try ";
   767:       print_block b;
   768:       print "__except("; print_expression e; print ")";
   769:       print_block h
   770: 
   771: and print_block blk =
   772:   new_line();
   773:   print "{";
   774:   indent ();
   775:   if blk.blabels <> [] then begin
   776:     print "__label__ ";
   777:     print_commas false print blk.blabels;
   778:     print ";";
   779:     new_line ();
   780:   end;
   781:   if blk.battrs <> [] then begin
   782:     List.iter print_attribute blk.battrs;
   783:     new_line ();
   784:   end;
   785:   List.iter print_statement blk.bstmts;
   786:   unindent ();
   787:   print "}";
   788:   new_line ()
   789: 
   790: and print_substatement stat =
   791:   match stat with
   792:     IF _
   793:   | SEQUENCE _
   794:   | DOWHILE _ ->
   795:       new_line ();
   796:       print "{";
   797:       indent ();
   798:       print_statement stat;
   799:       unindent ();
   800:       print "}";
   801:       new_line ();
   802:   | BLOCK _ ->
   803:       print_statement stat
   804:   | _ ->
   805:       indent ();
   806:       print_statement stat;
   807:       unindent ()
   808: 
   809: 
   810: (*
   811: ** GCC Attributes
   812: *)
   813: and print_attribute (name,args) =
   814:   if args = [] then print (
   815:     match name with
   816:       "restrict" -> "__restrict"
   817:       (* weimer: Fri Dec  7 17:12:35  2001
   818:        * must not print 'restrict' and the code below does allows some
   819:        * plain 'restrict's to slip though! *)
   820:     | x -> x)
   821:   else begin
   822:     print name;
   823:     print "("; if name = "__attribute__" then print "(";
   824:     (match args with
   825:       [VARIABLE "aconst"] -> print "const"
   826:     | [VARIABLE "restrict"] -> print "__restrict"
   827:     | _ -> print_commas false (fun e -> print_expression e) args);
   828:     print ")"; if name = "__attribute__" then print ")"
   829:   end
   830: 
   831: (* Print attributes. *)
   832: and print_attributes attrs =
   833:   List.iter (fun a -> print_attribute a; space ()) attrs
   834: 
   835: and print_base b = match b with
   836:   | `Public_virtual n -> print "public "; print "virtual "; print n
   837:   | `Protected_virtual n -> print "protected "; print "virtual "; print n
   838:   | `Private_virtual n -> print "private "; print "virtual "; print n
   839:   | `Public n -> print n
   840:   | `Protected n -> print "protected "; print n
   841:   | `Private n -> print "private "; print n
   842: 
   843: 
   844: (*
   845: ** Declaration printing
   846: *)
   847: and print_defs defs =
   848:   let prev = ref false in
   849:   List.iter
   850:     (fun def ->
   851:       (match def with
   852:         DECDEF _ -> prev := false
   853:       | _ ->
   854:           if not !prev then force_new_line ();
   855:           prev := true);
   856:       print_def def)
   857:     defs
   858: 
   859: and print_def def =
   860:   match def with
   861:     FUNDEF (proto, body, loc, _) ->
   862:       comprint "fundef";
   863:       if !printCounters then begin
   864:         try
   865:           let fname =
   866:             match proto with
   867:               (_, (n, _, _, _)) -> n
   868:           in
   869:           print_def (DECDEF (([SpecType Tint],
   870:                               [(fname ^ "__counter", JUSTBASE, [], cabslu),
   871:                                 NO_INIT]), loc));
   872:         with Not_found -> print "/* can't print the counter */"
   873:       end;
   874:       setLoc(loc);
   875:       print_single_name proto;
   876:       print_block body;
   877:       force_new_line ();
   878: 
   879:   | DECDEF (names, loc) ->
   880:       comprint "decdef";
   881:       setLoc(loc);
   882:       print_init_name_group names;
   883:       print ";";
   884:       new_line ()
   885: 
   886:   | TYPEDEF (names, loc) ->
   887:       comprint "typedef";
   888:       setLoc(loc);
   889:       print_name_group names;
   890:       print ";";
   891:       new_line ();
   892:       force_new_line ()
   893: 
   894:   | ONLYTYPEDEF (specs, loc) ->
   895:       comprint "onlytypedef";
   896:       setLoc(loc);
   897:       print_specifiers specs;
   898:       print ";";
   899:       new_line ();
   900:       force_new_line ()
   901: 
   902:   | GLOBASM (asm, loc) ->
   903:       setLoc(loc);
   904:       print "__asm__ (";  print_string asm; print ");";
   905:       new_line ();
   906:       force_new_line ()
   907: 
   908:   | PRAGMA (a,loc) ->
   909:       setLoc(loc);
   910:       force_new_line ();
   911:       print "#pragma ";
   912:       let oldwidth = !width in
   913:       width := 1000000;  (* Do not wrap pragmas *)
   914:       print_expression a;
   915:       width := oldwidth;
   916:       force_new_line ()
   917: 
   918:   | LINKAGE (n, loc, dl) ->
   919:       setLoc (loc);
   920:       force_new_line ();
   921:       print "extern "; print_string n; print_string "  {";
   922:       List.iter print_def dl;
   923:       print_string "}";
   924:       force_new_line ()
   925: 
   926:   | NAMESPACE (n, loc, dl) ->
   927:       setLoc (loc);
   928:       force_new_line ();
   929:       print "namespace "; print n; print_string "  {";
   930:       indent();
   931:       List.iter print_def dl;
   932:       unindent();
   933:       print_string "}";
   934:       force_new_line ()
   935: 
   936:   | TRANSFORMER(srcdef, destdeflist, loc) ->
   937:       setLoc(loc);
   938:       print "@transform {";
   939:       force_new_line();
   940:       print "{";
   941:         force_new_line();
   942:         indent ();
   943:         print_def srcdef;
   944:         unindent();
   945:       print "}";
   946:       force_new_line();
   947:       print "to {";
   948:         force_new_line();
   949:         indent();
   950:         List.iter print_def destdeflist;
   951:         unindent();
   952:       print "}";
   953:       force_new_line()
   954: 
   955:   | EXPRTRANSFORMER(srcexpr, destexpr, loc) ->
   956:       setLoc(loc);
   957:       print "@transformExpr { ";
   958:       print_expression srcexpr;
   959:       print " } to { ";
   960:       print_expression destexpr;
   961:       print " }";
   962:       force_new_line()
   963: 
   964: 
   965: (* sm: print a comment if the printComments flag is set *)
   966: and comprint (str : string) : unit =
   967: begin
   968:   if (!printComments) then (
   969:     print "/*";
   970:     print str;
   971:     print "*/ "
   972:   )
   973:   else
   974:     ()
   975: end
   976: 
   977: (* sm: yield either the given string, or "", depending on printComments *)
   978: and comstring (str : string) : string =
   979: begin
   980:   if (!printComments) then
   981:     str
   982:   else
   983:     ""
   984: end
   985: 
   986: 
   987: (*  print abstrac_syntax -> ()
   988: **              Flx_cil_pretty printing the given abstract syntax program.
   989: *)
   990: let printFile (result : out_channel) ((fname, defs) : file) =
   991:   out := result;
   992:   print_defs defs;
   993:   flush ()     (* sm: should do this here *)
   994: 
   995: let set_tab t = tab := t
   996: let set_width w = width := w
   997: 
End ocaml section to src/flx_cil_cprint.ml[1]
Start ocaml section to src/flx_cil_frontc.ml[1 /1 ]
     1: # 4179 "./lpsrc/flx_frontc.ipk"
     2: 
     3: 
     4: module E = Flx_cil_errormsg
     5: open Flx_cil_trace
     6: open Flx_cil_pretty
     7: 
     8: (* Output management *)
     9: let out : out_channel option ref = ref None
    10: let close_me = ref false
    11: 
    12: let close_output _ =
    13:   match !out with
    14:     None -> ()
    15:   | Some o -> begin
    16:       flush o;
    17:       if !close_me then close_out o else ();
    18:       close_me := false
    19:   end
    20: 
    21: let set_output filename =
    22:   close_output ();
    23:   (try out := Some (open_out filename)
    24:   with (Sys_error msg) ->
    25:     output_string stderr ("Error while opening output: " ^ msg); exit 1);
    26:   close_me := true
    27: 
    28:    (* Signal that we are in MS VC mode *)
    29: let setMSVCMode () =
    30:   Flx_cil_cprint.msvcMode := true
    31: 
    32: (* filename for patching *)
    33: let patchFileName : string ref = ref ""      (* by default do no patching *)
    34: 
    35: (* patching file contents *)
    36: let patchFile : Flx_cil_cabs.file option ref = ref None
    37: 
    38: (* whether to print the patched CABS files *)
    39: let printFlx_cil_patchedFiles : bool ref = ref false
    40: 
    41: (* whether to print a file of prototypes after parsing *)
    42: let doPrintProtos : bool ref = ref false
    43: 
    44: (* this seems like something that should be built-in.. *)
    45: let isNone (o : 'a option) : bool =
    46: begin
    47:   match o with
    48:   | Some _ -> false
    49:   | None -> true
    50: end
    51: 
    52: (*
    53: ** Argument definition
    54: *)
    55: let args : (string * Arg.spec * string) list =
    56: [
    57:   "--cabsonly", Arg.String set_output, "<fname>: CABS output file name";
    58:   "--printComments", Arg.Unit (fun _ -> Flx_cil_cprint.printComments := true),
    59:              ": print cabs tree structure in comments in cabs output";
    60:   "--patchFile", Arg.String (fun pf -> patchFileName := pf),
    61:              "<fname>: name the file containing patching transformations";
    62:   "--printFlx_cil_patched", Arg.Unit (fun _ -> printFlx_cil_patchedFiles := true),
    63:              ": print patched CABS files after patching, to *.patched";
    64:   "--printProtos", Arg.Unit (fun _ -> doPrintProtos := true),
    65:              ": print prototypes to safec.proto.h after parsing";
    66: ]
    67: 
    68: exception ParseError of string
    69: exception Flx_cil_cabsOnly
    70: 
    71: (* parse, and apply patching *)
    72: let rec parse_to_cabs fname lang =
    73: begin
    74:   (* parse the patch file if it isn't parsed already *)
    75:   if ((!patchFileName <> "") && (isNone !patchFile)) then (
    76:     (* parse the patch file *)
    77:     patchFile := Some(parse_to_cabs_inner !patchFileName lang);
    78:     if !E.hadErrors then
    79:       (failwith "There were parsing errors in the patch file")
    80:   );
    81: 
    82:   (* now parse the file we came here to parse *)
    83:   let cabs = parse_to_cabs_inner fname lang in
    84:   if !E.hadErrors then
    85:     E.s (E.error "There were parsing errors in %s\n" fname);
    86: 
    87:   (* and apply the patch file, return transformed file *)
    88:   let patched = match !patchFile with
    89: 
    90:     | Some(pf) -> (
    91:         (* save old value of out so I can use it for debugging during patching *)
    92:         let oldOut = !out in
    93: 
    94:         (* reset out so we don't try to print the patch file to it *)
    95:         out := None;
    96: 
    97:         (trace "patch" (dprintf "newpatching %s\n" fname));
    98:         let result = (Flx_cil_stats.time "newpatch" (Flx_cil_patch.applyFlx_cil_patch pf) cabs) in
    99: 
   100:         if (!printFlx_cil_patchedFiles) then begin
   101:           let outFname:string = fname ^ ".patched" in
   102:           (trace "patch" (dprintf "printing patched version of %s to %s\n"
   103:                                   fname outFname));
   104:           let o = (open_out outFname) in
   105:           (Flx_cil_cprint.printFile o result);
   106:           (close_out o)
   107:         end;
   108: 
   109:         (* restore out *)
   110:         Flx_cil_cprint.flush ();
   111:         out := oldOut;
   112: 
   113:         result
   114:       )
   115:     | None -> cabs
   116:   in
   117: 
   118:   (* print it ... *)
   119:   (match !out with
   120:     Some o -> begin
   121:       (trace "sm" (dprintf "writing the cabs output\n"));
   122:       output_string o ("/* Generated by Flx_cil_frontc */\n");
   123:       Flx_cil_stats.time "printCABS" (Flx_cil_cprint.printFile o) patched;
   124:       close_output ();
   125:       raise Flx_cil_cabsOnly
   126:     end
   127:   | None -> ());
   128:   if !E.hadErrors then
   129:     raise Parsing.Parse_error;
   130: 
   131:   (* and return the patched source *)
   132:   patched
   133: end
   134: 
   135: 
   136: (* just parse *)
   137: and parse_to_cabs_inner (fname : string) (lang : Flx_cil_cabs.lang_t) =
   138:   try
   139:     if !E.verboseFlag then ignore (E.log "Flx_cil_frontc is parsing %s\n" fname);
   140:     flush !E.logChannel;
   141:     E.hadErrors := false;
   142:     let lexbuf = Flx_cil_clexer.init fname lang in
   143:     let cabs = Flx_cil_stats.time "parse" (Flx_cil_cparser.file Flx_cil_clexer.initial) lexbuf in
   144:     Flx_cil_clexer.finish ();
   145:     (fname, cabs)
   146:   with (Sys_error msg) -> begin
   147:     ignore (E.log "Cannot open %s : %s\n" fname msg);
   148:     close_output ();
   149:     raise (ParseError("Cannot open " ^ fname ^ ": " ^ msg ^ "\n"))
   150:   end
   151:   | Parsing.Parse_error -> begin
   152:       ignore (E.log "Parsing error\n");
   153:       close_output ();
   154:       raise (ParseError("Parse error"))
   155:   end
   156:   | e -> begin
   157:       ignore (E.log "Caught %s while parsing\n" (Printexc.to_string e));
   158:       raise e
   159:   end
   160: 
   161: 
   162: (* print to safec.proto.h the prototypes of all functions that are defined *)
   163: let printPrototypes ((fname, file) : Flx_cil_cabs.file) : unit =
   164: begin
   165:   (*ignore (E.log "file has %d defns\n" (List.length file));*)
   166: 
   167:   let chan = open_out "safec.proto.h" in
   168:   ignore (fprintf chan "/* generated prototypes file, %d defs */\n" (List.length file));
   169:   Flx_cil_cprint.out := chan;
   170: 
   171:   let counter : int ref = ref 0 in
   172: 
   173:   let rec loop (d : Flx_cil_cabs.definition) = begin
   174:     match d with
   175:     | Flx_cil_cabs.FUNDEF(name, _, loc, _) -> (
   176:         match name with
   177:         | (_, (funcname, Flx_cil_cabs.PROTO(_,_,_), _, _)) -> (
   178:             incr counter;
   179:             ignore (fprintf chan "\n/* %s from %s:%d */\n"
   180:                                  funcname loc.Flx_cil_cabs.filename loc.Flx_cil_cabs.lineno);
   181:             flush chan;
   182:             Flx_cil_cprint.print_single_name name;
   183:             Flx_cil_cprint.print_unescaped_string ";";
   184:             Flx_cil_cprint.force_new_line ();
   185:             Flx_cil_cprint.flush ()
   186:           )
   187:         | _ -> ()
   188:       )
   189: 
   190:     | _ -> ()
   191:   end in
   192:   (List.iter loop file);
   193: 
   194:   ignore (fprintf chan "\n/* wrote %d prototypes */\n" !counter);
   195:   close_out chan;
   196:   ignore (E.log "printed %d prototypes from %d defns to safec.proto.h\n"
   197:                 !counter (List.length file))
   198: end
   199: 
   200: 
   201: 
   202: let parse fname lang =
   203:   (trace "sm" (dprintf "parsing %s to Flx_cil_cabs\n" fname));
   204:   let cabs = parse_to_cabs fname lang in
   205:   (* Now (return a function that will) convert to CIL *)
   206:   fun _ ->
   207:     (trace "sm" (dprintf "converting %s from Flx_cil_cabs to CIL\n" fname));
   208:     let cil = Flx_cil_stats.time "conv" Flx_cil_cabs2cil.convFile cabs in
   209:     if !doPrintProtos then (printPrototypes cabs);
   210:     cil
   211: 
   212: 
End ocaml section to src/flx_cil_frontc.ml[1]
Start ocaml section to src/flx_cil_frontc.mli[1 /1 ]
     1: # 4392 "./lpsrc/flx_frontc.ipk"
     2: 
     3: 
     4:    (* Signal that we are in MS VC mode *)
     5: val setMSVCMode: unit -> unit
     6: 
     7: 
     8:    (* Parse a file in *)
     9: exception ParseError of string
    10: 
    11:    (* Raised when the front-end is requested to print the CABS and return *)
    12: exception Flx_cil_cabsOnly
    13: 
    14:     (* additional command line arguments *)
    15: val args: (string * Arg.spec * string) list
    16: 
    17:     (* the main command to parse a file. Return a thunk that can be used to
    18:      * convert the AST to CIL. *)
    19: val parse: string -> Flx_cil_cabs.lang_t -> (unit -> Flx_cil_cil.file)
    20: 
End ocaml section to src/flx_cil_frontc.mli[1]
Start ocaml section to src/flx_cil_lexerhack.mli[1 /1 ]
     1: # 4413 "./lpsrc/flx_frontc.ipk"
     2: val get_lang : (unit -> Flx_cil_cabs.lang_t) ref
     3: val add_identifier : (string -> unit) ref
     4: val add_type : (string -> unit) ref
     5: val push_context : (unit -> unit) ref
     6: val pop_context : (unit -> unit) ref
     7: val push_class: (string-> unit) ref
     8: val pop_class : (unit -> unit) ref
     9: val currentPattern : string ref
    10: 
End ocaml section to src/flx_cil_lexerhack.mli[1]
Start ocaml section to src/flx_cil_lexerhack.ml[1 /1 ]
     1: # 4424 "./lpsrc/flx_frontc.ipk"
     2: 
     3: module E = Flx_cil_errormsg
     4: 
     5: (* We provide here a pointer to a function. It will be set by the lexer and
     6:  * used by the parser. In Ocaml lexers depend on parsers, so we we have put
     7:  * such functions in a separate module. *)
     8: let add_identifier: (string -> unit) ref =
     9:   ref (fun _ -> E.s (E.bug "You called an uninitialized add_identifier"))
    10: 
    11: let add_type: (string -> unit) ref =
    12:   ref (fun _ -> E.s (E.bug "You called an uninitialized add_type"))
    13: 
    14: let push_context: (unit -> unit) ref =
    15:   ref (fun _ -> E.s (E.bug "You called an uninitialized push_context"))
    16: 
    17: let pop_context: (unit -> unit) ref =
    18:   ref (fun _ -> E.s (E.bug "You called an uninitialized pop_context"))
    19: 
    20: let push_class: (string -> unit) ref =
    21:   ref (fun _ -> E.s (E.bug "You called an uninitialized push_class"))
    22: 
    23: let pop_class : (unit -> unit) ref =
    24:   ref (fun _ -> E.s (E.bug "You called an uninitialized pop_class"))
    25: 
    26: let get_lang: (unit -> Flx_cil_cabs.lang_t) ref =
    27:   ref (fun _ -> E.s (E.bug "You called an uninitialized get_lang"))
    28: 
    29: (* Keep here the current pattern for formatparse *)
    30: let currentPattern = ref ""
    31: 
End ocaml section to src/flx_cil_lexerhack.ml[1]