From 93d89c2b5e8497365be152fb53cb6cd4c5764d34 Mon Sep 17 00:00:00 2001 From: xleroy Date: Wed, 3 Mar 2010 10:25:25 +0000 Subject: Getting rid of CIL git-svn-id: https://yquem.inria.fr/compcert/svn/compcert/trunk@1270 fca1b0fc-160b-0410-b1d3-a4f43f01ea2e --- cil/src/formatparse.mly | 1455 ----------------------------------------------- 1 file changed, 1455 deletions(-) delete mode 100644 cil/src/formatparse.mly (limited to 'cil/src/formatparse.mly') diff --git a/cil/src/formatparse.mly b/cil/src/formatparse.mly deleted file mode 100644 index 75bdbb33..00000000 --- a/cil/src/formatparse.mly +++ /dev/null @@ -1,1455 +0,0 @@ -/* MODIF: Loop constructor replaced by 3 constructors: While, DoWhile, For. */ - -/*(* Parser for constructing CIL from format strings *) -(* - * - * Copyright (c) 2001-2002, - * George C. Necula - * Scott McPeak - * Wes Weimer - * All rights reserved. - * - * Redistribution and use in source and binary forms, with or without - * modification, are permitted 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 names of the contributors may not be used to endorse or promote - * products derived from this software without specific prior written - * permission. - * - * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "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 COPYRIGHT OWNER - * OR CONTRIBUTORS 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. - * - *) -*/ -%{ -open Cil -open Pretty -module E = Errormsg - -let parse_error msg : 'a = (* sm: c++-mode highlight hack: -> ' <- *) - E.hadErrors := true; - E.parse_error - msg - - -let getArg (argname: string) (args: (string * formatArg) list) = - try - snd (List.find (fun (n, a) -> n = argname) args) - with _ -> - E.s (error "Pattern string %s does not have argument with name %s\n" - !Lexerhack.currentPattern argname) - -let wrongArgType (which: string) (expected: string) (found: formatArg) = - E.s (bug "Expecting %s argument (%s) and found %a\n" - expected which d_formatarg found) - -let doUnop (uo: unop) subexp = - ((fun args -> - let e = (fst subexp) args in - UnOp(uo, e, typeOf e)), - - (fun e -> match e with - UnOp(uo', e', _) when uo = uo' -> (snd subexp) e' - | _ -> None)) - -let buildPlus e1 e2 : exp = - let t1 = typeOf e1 in - if isPointerType t1 then - BinOp(PlusPI, e1, e2, t1) - else - BinOp(PlusA, e1, e2, t1) - -let buildMinus e1 e2 : exp = - let t1 = typeOf e1 in - let t2 = typeOf e2 in - if isPointerType t1 then - if isPointerType t2 then - BinOp(MinusPP, e1, e2, intType) - else - BinOp(MinusPI, e1, e2, t1) - else - BinOp(MinusA, e1, e2, t1) - -let doBinop bop e1t e2t = - ((fun args -> - let e1 = (fst e1t) args in - let e2 = (fst e2t) args in - let t1 = typeOf e1 in - BinOp(bop, e1, e2, t1)), - - (fun e -> match e with - BinOp(bop', e1, e2, _) when bop' = bop -> begin - match (snd e1t) e1, (snd e2t) e2 with - Some m1, Some m2 -> Some (m1 @ m2) - | _, _ -> None - end - | _ -> None)) - -(* Check the equivalence of two format lists *) -let rec checkSameFormat (fl1: formatArg list) (fl2: formatArg list) = - match fl1, fl2 with - [], [] -> true - | h1::t1, h2::t2 -> begin - let rec checkOffsetEq o1 o2 = - match o1, o2 with - NoOffset, NoOffset -> true - | Field(f1, o1'), Field(f2, o2') -> - f1.fname = f2.fname && checkOffsetEq o1' o2' - | Index(e1, o1'), Index(e2, o2') -> - checkOffsetEq o1' o2' && checkExpEq e1 e2 - | _, _ -> false - - and checkExpEq e1 e2 = - match e1, e2 with - Const(CInt64(n1, _, _)), Const(CInt64(n2, _, _)) -> n1 = n2 - | Lval l1, Lval l2 -> checkLvalEq l1 l2 - | UnOp(uo1, e1, _), UnOp(uo2, e2, _) -> - uo1 = uo2 && checkExpEq e1 e2 - | BinOp(bo1, e11, e12, _), BinOp(bo2, e21, e22, _) -> - bo1 = bo2 && checkExpEq e11 e21 && checkExpEq e21 e22 - | AddrOf l1, AddrOf l2 -> checkLvalEq l1 l2 - | StartOf l1, StartOf l2 -> checkLvalEq l1 l2 - | SizeOf t1, SizeOf t2 -> typeSig t1 = typeSig t2 - | _, _ -> - ignore (E.warn "checkSameFormat for Fe"); false - - and checkLvalEq l1 l2 = - match l1, l2 with - (Var v1, o1), (Var v2, o2) -> v1 == v2 && checkOffsetEq o1 o2 - | (Mem e1, o1), (Mem e2, o2) -> - checkOffsetEq o1 o2 && checkExpEq e1 e2 - | _, _ -> false - in - let hdeq = - match h1, h2 with - Fv v1, Fv v2 -> v1 == v2 - | Fd n1, Fd n2 -> n1 = n2 - | Fe e1, Fe e2 -> checkExpEq e1 e2 - | Fi i1, Fi i2 -> ignore (E.warn "checkSameFormat for Fi"); false - | Ft t1, Ft t2 -> typeSig t1 = typeSig t2 - | Fl l1, Fl l2 -> checkLvalEq l1 l2 - | Fo o1, Fo o2 -> checkOffsetEq o1 o2 - | Fc c1, Fc c2 -> c1 == c2 - | _, _ -> false - in - hdeq || checkSameFormat t1 t2 - end - | _, _ -> false - -let matchBinopEq (bopeq: binop -> bool) lvt et = - (fun i -> match i with - Set (lv, BinOp(bop', Lval (lv'), e', _), l) when bopeq bop' -> begin - match lvt lv, lvt lv', et e' with - Some m1, Some m1', Some m2 -> - (* Must check that m1 and m2 are the same *) - if checkSameFormat m1 m1' then - Some (m1 @ m2) - else - None - | _, _, _ -> None - end - | _ -> None) - -let doBinopEq bop lvt et = - ((fun loc args -> - let l = (fst lvt) args in - Set(l, BinOp(bop, (Lval l), (fst et) args, typeOfLval l), loc)), - - matchBinopEq (fun bop' -> bop = bop') (snd lvt) (snd et)) - - -let getField (bt: typ) (fname: string) : fieldinfo = - match unrollType bt with - TComp(ci, _) -> begin - try - List.find (fun f -> fname = f.fname) ci.cfields - with Not_found -> - E.s (bug "Cannot find field %s in %s\n" fname (compFullName ci)) - end - | t -> E.s (bug "Trying to access field %s in non-struct\n" fname) - - -let matchIntType (ik: ikind) (t:typ) : formatArg list option = - match unrollType t with - TInt(ik', _) when ik = ik' -> Some [] - | _ -> None - -let matchFloatType (fk: fkind) (t:typ) : formatArg list option = - match unrollType t with - TFloat(fk', _) when fk = fk' -> Some [] - | _ -> None - -let doAttr (id: string) - (aargs: (((string * formatArg) list -> attrparam list) * - (attrparam list -> formatArg list option)) option) - = - let t = match aargs with - Some t -> t - | None -> (fun _ -> []), - (function [] -> Some [] | _ -> None) - in - ((fun args -> Attr (id, (fst t) args)), - - (fun attrs -> - (* Find the attributes with the same ID *) - List.fold_left - (fun acc a -> - match acc, a with - Some _, _ -> acc (* We found one already *) - | None, Attr(id', args) when id = id' -> - (* Now match the arguments *) - (snd t) args - | None, _ -> acc) - None - attrs)) - - -type falist = formatArg list - -type maybeInit = - NoInit - | InitExp of exp - | InitCall of lval * exp list - -%} - -%token IDENT -%token CST_CHAR -%token CST_INT -%token CST_FLOAT -%token CST_STRING -%token CST_WSTRING -%token NAMED_TYPE - -%token EOF -%token CHAR INT DOUBLE FLOAT VOID INT64 INT32 -%token ENUM STRUCT TYPEDEF UNION -%token SIGNED UNSIGNED LONG SHORT -%token VOLATILE EXTERN STATIC CONST RESTRICT AUTO REGISTER - -%token ARG_e ARG_eo ARG_E ARG_u ARG_b ARG_t ARG_d ARG_lo ARG_l ARG_i -%token ARG_o ARG_va ARG_f ARG_F ARG_A ARG_v ARG_k ARG_c ARG_d -%token ARG_s ARG_p ARG_P ARG_I ARG_S ARG_g - -%token SIZEOF ALIGNOF - -%token EQ -%token ARROW DOT - -%token EQ_EQ EXCLAM_EQ INF SUP INF_EQ SUP_EQ -%token MINUS_EQ PLUS_EQ STAR_EQ -%token PLUS MINUS STAR SLASH PERCENT -%token TILDE AND PIPE CIRC -%token EXCLAM AND_AND PIPE_PIPE -%token INF_INF SUP_SUP -%token PLUS_PLUS MINUS_MINUS - -%token RPAREN LPAREN RBRACE LBRACE LBRACKET RBRACKET -%token COLON SEMICOLON COMMA ELLIPSIS QUEST - -%token BREAK CONTINUE GOTO RETURN -%token SWITCH CASE DEFAULT -%token WHILE DO FOR -%token IF THEN ELSE - -%token PLUS_EQ MINUS_EQ STAR_EQ SLASH_EQ PERCENT_EQ -%token AND_EQ PIPE_EQ CIRC_EQ INF_INF_EQ SUP_SUP_EQ - -%token ATTRIBUTE INLINE ASM TYPEOF FUNCTION__ PRETTY_FUNCTION__ LABEL__ -%token BUILTIN_VA_ARG BUILTIN_VA_LIST -%token BLOCKATTRIBUTE -%token DECLSPEC -%token MSASM MSATTR -%token PRAGMA - - -/* operator precedence */ -%nonassoc IF -%nonassoc ELSE - - -%left COMMA - - /*(* Set the following precedences higer than COMMA *)*/ -%nonassoc ARG_e ARG_d ARG_lo ARG_l ARG_i ARG_v ARG_I ARG_g -%right EQ PLUS_EQ MINUS_EQ STAR_EQ SLASH_EQ PERCENT_EQ - AND_EQ PIPE_EQ CIRC_EQ INF_INF_EQ SUP_SUP_EQ -%right COLON -%left PIPE_PIPE -%left AND_AND -%left ARG_b -%left PIPE -%left CIRC -%left AND -%left EQ_EQ EXCLAM_EQ -%left INF SUP INF_EQ SUP_EQ -%left INF_INF SUP_SUP -%left PLUS MINUS -%left STAR SLASH PERCENT CONST RESTRICT VOLATILE -%right ARG_u EXCLAM TILDE PLUS_PLUS MINUS_MINUS CAST RPAREN ADDROF SIZEOF ALIGNOF -%left LBRACKET -%left DOT ARROW LPAREN LBRACE -%nonassoc IDENT QUEST CST_INT - -%start initialize expression typename offset lval instr stmt stmt_list - - -%type initialize -%type <((string -> Cil.typ -> Cil.varinfo) -> Cil.location -> (string * Cil.formatArg) list -> Cil.stmt)> stmt -%type <((string -> Cil.typ -> Cil.varinfo) -> Cil.location -> (string * Cil.formatArg) list -> Cil.stmt list)> stmt_list - -%type <((string * Cil.formatArg) list -> Cil.exp) * (Cil.exp -> Cil.formatArg list option)> expression - -%type <((string * Cil.formatArg) list -> Cil.exp) * (Cil.exp -> Cil.formatArg list option)> constant - -%type <((string * Cil.formatArg) list -> Cil.lval) * (Cil.lval -> Cil.formatArg list option)> lval - -%type <((string * Cil.formatArg) list -> Cil.typ) * (Cil.typ -> Cil.formatArg list option)> typename - -%type <(Cil.attributes -> (string * Cil.formatArg) list -> Cil.typ) * (Cil.typ -> Cil.formatArg list option)> type_spec - -%type <((string * Cil.formatArg) list -> (string * Cil.typ * Cil.attributes) list option * bool) * ((string * Cil.typ * Cil.attributes) list option * bool -> Cil.formatArg list option)> parameters - - -%type <(Cil.location -> (string * Cil.formatArg) list -> Cil.instr) * (Cil.instr -> Cil.formatArg list option)> instr - -%type <(Cil.typ -> (string * Cil.formatArg) list -> Cil.offset) * (Cil.offset -> Cil.formatArg list option)> offset - - -%% - - -initialize: - /* empty */ { } -; - -/* (*** Expressions ***) */ - - -expression: -| ARG_e { (* Count arguments eagerly *) - let currentArg = $1 in - ((fun args -> - match getArg currentArg args with - Fe e -> e - | a -> wrongArgType currentArg - "expression" a), - - (fun e -> Some [ Fe e ])) - } - -| constant { $1 } - -| lval %prec IDENT - { ((fun args -> Lval ((fst $1) args)), - - (fun e -> match e with - Lval l -> (snd $1) l - | _ -> None)) - } - -| SIZEOF expression - { ((fun args -> SizeOfE ((fst $2) args)), - - fun e -> match e with - SizeOfE e' -> (snd $2) e' - | _ -> None) - } - -| SIZEOF LPAREN typename RPAREN - { ((fun args -> SizeOf ((fst $3) args)), - - (fun e -> match e with - SizeOf t -> (snd $3) t - | _ -> None)) - } - -| ALIGNOF expression - { ((fun args -> AlignOfE ((fst $2) args)), - - (fun e -> match e with - AlignOfE e' -> (snd $2) e' | _ -> None)) - } - -| ALIGNOF LPAREN typename RPAREN - { ((fun args -> AlignOf ((fst $3) args)), - - (fun e -> match e with - AlignOf t' -> (snd $3) t' | _ -> None)) - } - -| PLUS expression - { $2 } -| MINUS expression - { doUnop Neg $2 } - -| EXCLAM expression - { doUnop LNot $2 } - -| TILDE expression - { doUnop BNot $2 } - -| argu expression %prec ARG_u - { ((fun args -> - let e = (fst $2) args in - UnOp((fst $1) args, e, typeOf e)), - - (fun e -> match e with - UnOp(uo, e', _) -> begin - match (snd $1) uo, (snd $2) e' with - Some m1, Some m2 -> Some (m1 @ m2) - | _ -> None - end - | _ -> None)) - } - - -| AND expression %prec ADDROF - { ((fun args -> - match (fst $2) args with - Lval l -> mkAddrOf l - | _ -> E.s (bug "AddrOf applied to a non lval")), - (fun e -> match e with - AddrOf l -> (snd $2) (Lval l) - | e -> (snd $2) (Lval (mkMem e NoOffset)))) - } - -| LPAREN expression RPAREN - { $2 } - -| expression PLUS expression - { ((fun args -> buildPlus ((fst $1) args) - ((fst $3) args)), - (fun e -> match e with - BinOp((PlusPI|PlusA), e1, e2, _) -> begin - match (snd $1) e1, (snd $3) e2 with - Some m1, Some m2 -> Some (m1 @ m2) - | _, _ -> None - end - | _ -> None)) - } - -| expression MINUS expression - { ((fun args -> buildMinus ((fst $1) args) - ((fst $3) args)), - - (fun e -> match e with - BinOp((MinusPP|MinusPI|MinusA), e1, e2, _) -> - begin - match (snd $1) e1, (snd $3) e2 with - Some m1, Some m2 -> Some (m1 @ m2) - | _, _ -> None - end - | _ -> None)) - } -| expression argb expression %prec ARG_b - { ((fun args -> - let e1 = (fst $1) args in - let bop = (fst $2) args in - let e2 = (fst $3) args in - let t1 = typeOf e1 in - BinOp(bop, e1, e2, t1)), - - (fun e -> match e with - BinOp(bop, e1, e2, _) -> begin - match (snd $1) e1,(snd $2) bop,(snd $3) e2 with - Some m1, Some m2, Some m3 -> - Some (m1 @ m2 @ m3) - | _, _, _ -> None - end - | _ -> None)) - } - -| expression STAR expression - { doBinop Mult $1 $3 } -| expression SLASH expression - { doBinop Div $1 $3 } -| expression PERCENT expression - { doBinop Mod $1 $3 } -| expression INF_INF expression - { doBinop Shiftlt $1 $3 } -| expression SUP_SUP expression - { doBinop Shiftrt $1 $3 } -| expression AND expression - { doBinop BAnd $1 $3 } -| expression PIPE expression - { doBinop BOr $1 $3 } -| expression CIRC expression - { doBinop BXor $1 $3 } -| expression EQ_EQ expression - { doBinop Eq $1 $3 } -| expression EXCLAM_EQ expression - { doBinop Ne $1 $3 } -| expression INF expression - { doBinop Lt $1 $3 } -| expression SUP expression - { doBinop Gt $1 $3 } -| expression INF_EQ expression - { doBinop Le $1 $3 } -| expression SUP_EQ expression - { doBinop Ge $1 $3 } - -| LPAREN typename RPAREN expression - { ((fun args -> - let t = (fst $2) args in - let e = (fst $4) args in - mkCast e t), - - (fun e -> - let t', e' = - match e with - CastE (t', e') -> t', e' - | _ -> typeOf e, e - in - match (snd $2) t', (snd $4 e') with - Some m1, Some m2 -> Some (m1 @ m2) - | _, _ -> None)) - } -; - -/*(* Separate the ARG_ to ensure that the counting of arguments is right *)*/ -argu : -| ARG_u { let currentArg = $1 in - ((fun args -> - match getArg currentArg args with - Fu uo -> uo - | a -> wrongArgType currentArg "unnop" a), - - fun uo -> Some [ Fu uo ]) - } -; - -argb : -| ARG_b { let currentArg = $1 in - ((fun args -> - match getArg currentArg args with - Fb bo -> bo - | a -> wrongArgType currentArg "binop" a), - - fun bo -> Some [ Fb bo ]) - } -; - -constant: -| ARG_d { let currentArg = $1 in - ((fun args -> - match getArg currentArg args with - Fd n -> integer n - | a -> wrongArgType currentArg "integer" a), - - fun e -> match e with - Const(CInt64(n, _, _)) -> - Some [ Fd (Int64.to_int n) ] - | _ -> None) - } - -| ARG_g { let currentArg = $1 in - ((fun args -> - match getArg currentArg args with - Fg s -> Const(CStr s) - | a -> wrongArgType currentArg "string" a), - - fun e -> match e with - Const(CStr s) -> - Some [ Fg s ] - | _ -> None) - } -| CST_INT { let n = parseInt $1 in - ((fun args -> n), - - (fun e -> match e, n with - Const(CInt64(e', _, _)), - Const(CInt64(n', _, _)) when e' = n' -> Some [] - | _ -> None)) - } -; - - -/*(***************** LVALUES *******************)*/ -lval: -| ARG_l { let currentArg = $1 in - ((fun args -> - match getArg currentArg args with - Fl l -> l - | Fv v -> Var v, NoOffset - | a -> wrongArgType currentArg "lval" a), - - fun l -> Some [ Fl l ]) - } - -| argv offset %prec ARG_v - { ((fun args -> - let v = (fst $1) args in - (Var v, (fst $2) v.vtype args)), - - (fun l -> match l with - Var vi, off -> begin - match (snd $1) vi, (snd $2) off with - Some m1, Some m2 -> Some (m1 @ m2) - | _ -> None - end - | _ -> None)) - } - -| STAR expression { ((fun args -> mkMem ((fst $2) args) NoOffset), - - (fun l -> match l with - Mem e, NoOffset -> (snd $2) e - | _, _ -> None)) - } - -| expression ARROW IDENT offset - { ((fun args -> - let e = (fst $1) args in - let baset = - match unrollTypeDeep (typeOf e) with - TPtr (t, _) -> t - | _ -> E.s (bug "Expecting a pointer for field %s\n" $3) - in - let fi = getField baset $3 in - mkMem e (Field(fi, (fst $4) fi.ftype args))), - - (fun l -> match l with - Mem e, Field(fi, off) when fi.fname = $3 -> begin - match (snd $1) e, (snd $4) off with - Some m1, Some m2 -> Some (m1 @ m2) - | _, _ -> None - end - | _, _ -> None)) - } - -| LPAREN STAR expression RPAREN offset - { ((fun args -> - let e = (fst $3) args in - let baset = - match unrollTypeDeep (typeOf e) with - TPtr (t, _) -> t - | _ -> E.s (bug "Expecting a pointer\n") - in - mkMem e ((fst $5) baset args)), - - (fun l -> match l with - Mem e, off -> begin - match (snd $3) e, (snd $5 off) with - Some m1, Some m2 -> Some (m1 @ m2) - | _, _ -> None - end - | _, _ -> None)) - } - ; - -argv : -| ARG_v { let currentArg = $1 in - ((fun args -> - match getArg currentArg args with - Fv v -> v - | a -> wrongArgType currentArg "varinfo" a), - - fun v -> Some [ Fv v ]) - } -| IDENT { let currentArg = $1 in - ((fun args -> - match getArg currentArg args with - Fv v -> v - | a -> wrongArgType currentArg "varinfo" a), - (fun v -> - E.s (bug "identifiers (%s) are not supported for deconstruction" currentArg))) - } -; - - -/*(********** OFFSETS *************)*/ -offset: -| ARG_o { let currentArg = $1 in - ((fun t args -> - match getArg currentArg args with - Fo o -> o - | a -> wrongArgType currentArg "offset" a), - - (fun off -> Some [ Fo off ])) - } - -| /* empty */ { ((fun t args -> NoOffset), - - (fun off -> match off with - NoOffset -> Some [] - | _ -> None)) - } - -| DOT IDENT offset { ((fun t args -> - let fi = getField t $2 in - Field (fi, (fst $3) fi.ftype args)), - - (fun off -> match off with - Field (fi, off') when fi.fname = $2 -> - (snd $3) off' - | _ -> None)) - } - -| LBRACKET expression RBRACKET offset - { ((fun t args -> - let bt = - match unrollType t with - TArray(bt, _, _) -> bt - | _ -> E.s (error "Formatcil: expecting an array for index") - in - let e = (fst $2) args in - Index(e, (fst $4) bt args)), - - (fun off -> match off with - Index (e, off') -> begin - match (snd $2) e, (snd $4) off with - Some m1, Some m2 -> Some (m1 @ m2) - | _, _ -> None - end - | _ -> None)) - } -; - - -/*(************ TYPES **************)*/ -typename: one_formal { ((fun args -> - let (_, ft, _) = (fst $1) args in - ft), - - (fun t -> (snd $1) ("", t, []))) - } -; - -one_formal: -/*(* Do not allow attributes for the name *)*/ -| type_spec attributes decl - { ((fun args -> - let tal = (fst $2) args in - let ts = (fst $1) tal args in - let (fn, ft, _) = (fst $3) ts args in - (fn, ft, [])), - - (fun (fn, ft, fa) -> - match (snd $3) (fn, ft) with - Some (restt, m3) -> begin - match (snd $1) restt, - (snd $2) (typeAttrs restt)with - Some m1, Some m2 -> - Some (m1 @ m2 @ m3) - | _, _ -> None - end - | _ -> None)) - } - -| ARG_f - { let currentArg = $1 in - ((fun args -> - match getArg currentArg args with - Ff (fn, ft, fa) -> (fn, ft, fa) - | a -> wrongArgType currentArg "formal" a), - - (fun (fn, ft, fa) -> Some [ Ff (fn, ft, fa) ])) - } -; - -type_spec: -| ARG_t { let currentArg = $1 in - ((fun al args -> - match getArg currentArg args with - Ft t -> typeAddAttributes al t - | a -> wrongArgType currentArg "type" a), - - (fun t -> Some [ Ft t ])) - } - -| VOID { ((fun al args -> TVoid al), - - (fun t -> match unrollType t with - TVoid _ -> Some [] - | _ -> None)) } - -| ARG_k { let currentArg = $1 in - ((fun al args -> - match getArg currentArg args with - Fk ik -> TInt(ik, al) - | a -> wrongArgType currentArg "ikind" a), - - (fun t -> match unrollType t with - TInt(ik, _) -> Some [ Fk ik ] - | _ -> None)) - } - -| CHAR { ((fun al args -> TInt(IChar, al)), - (matchIntType IChar)) } -| UNSIGNED CHAR { ((fun al args -> TInt(IUChar, al)), - matchIntType IUChar) } - -| SHORT { ((fun al args -> TInt(IShort, al)), - matchIntType IShort) } -| UNSIGNED SHORT { ((fun al args -> TInt(IUShort, al)), - matchIntType IUShort) } - -| INT { ((fun al args -> TInt(IInt, al)), - matchIntType IInt) } -| UNSIGNED INT { ((fun al args -> TInt(IUInt, al)), matchIntType IUInt) } - -| LONG { ((fun al args -> TInt(ILong, al)), - matchIntType ILong) } -| UNSIGNED LONG { ((fun al args -> TInt(IULong, al)), - matchIntType IULong) } - -| LONG LONG { ((fun al args -> TInt(ILongLong, al)), - - matchIntType ILongLong) - } -| UNSIGNED LONG LONG { ((fun al args -> TInt(IULongLong, al)), - - matchIntType IULongLong) - } - -| FLOAT { ((fun al args -> TFloat(FFloat, al)), - matchFloatType FFloat) - } -| DOUBLE { ((fun al args -> TFloat(FDouble, al)), - matchFloatType FDouble) } - -| STRUCT ARG_c { let currentArg = $2 in - ((fun al args -> - match getArg currentArg args with - Fc ci -> TComp(ci, al) - | a -> wrongArgType currentArg "compinfo" a), - - (fun t -> match unrollType t with - TComp(ci, _) -> Some [ Fc ci ] - | _ -> None)) - } -| UNION ARG_c { let currentArg = $2 in - ((fun al args -> - match getArg currentArg args with - Fc ci -> TComp(ci, al) - | a -> wrongArgType currentArg "compinfo" a), - - (fun t -> match unrollType t with - TComp(ci, _) -> Some [ Fc ci ] - | _ -> None)) - - } - -| TYPEOF LPAREN expression RPAREN - { ((fun al args -> typeAddAttributes al - (typeOf ((fst $3) args))), - - (fun t -> E.s (bug "Cannot match typeof(e)\n"))) - } -; - -decl: -| STAR attributes decl - { ((fun ts args -> - let al = (fst $2) args in - (fst $3) (TPtr(ts, al)) args), - - (fun (fn, ft) -> - match (snd $3) (fn, ft) with - Some (TPtr(bt, al), m2) -> begin - match (snd $2) al with - Some m1 -> Some (bt, m1 @ m2) - | _ -> None - end - | _ -> None)) - } - -| direct_decl { $1 } -; - -direct_decl: -| /* empty */ { ((fun ts args -> ("", ts, [])), - - (* Match any name in this case *) - (fun (fn, ft) -> - Some (unrollType ft, []))) - } - -| IDENT { ((fun ts args -> ($1, ts, [])), - - (fun (fn, ft) -> - if fn = "" || fn = $1 then - Some (unrollType ft, []) - else - None)) - } - -| LPAREN attributes decl RPAREN - { ((fun ts args -> - let al = (fst $2) args in - (fst $3) (typeAddAttributes al ts) args), - - (fun (fn, ft) -> begin - match (snd $3) (fn, ft) with - Some (restt, m2) -> begin - match (snd $2) (typeAttrs restt) with - Some m1 -> Some (restt, m1 @ m2) - | _ -> None - end - | _ -> None - end)) - } - -| direct_decl LBRACKET exp_opt RBRACKET - { ((fun ts args -> - (fst $1) (TArray(ts, (fst $3) args, [])) args), - - (fun (fn, ft) -> - match (snd $1) (fn, ft) with - Some (TArray(bt, lo, _), m1) -> begin - match (snd $3) lo with - Some m2 -> Some (unrollType bt, m1 @ m2) - | _ -> None - end - | _ -> None)) - } - - -/*(* We use parentheses around the function to avoid conflicts *)*/ -| LPAREN attributes decl RPAREN LPAREN parameters RPAREN - { ((fun ts args -> - let al = (fst $2) args in - let pars, isva = (fst $6) args in - (fst $3) (TFun(ts, pars, isva, al)) args), - - (fun (fn, ft) -> - match (snd $3) (fn, ft) with - Some (TFun(rt, args, isva, al), m1) -> begin - match (snd $2) al, (snd $6) (args, isva) with - Some m2, Some m6 - -> Some (unrollType rt, m1 @ m2 @ m6) - | _ -> None - end - | _ -> None)) - } -; - -parameters: -| /* empty */ { ((fun args -> (None, false)), - - (* Match any formals *) - (fun (pars, isva) -> - match pars, isva with - (_, false) -> Some [] - | _ -> None)) - } - -| parameters_ne { ((fun args -> - let (pars : (string * typ * attributes) list), - (isva : bool) = (fst $1) args in - (Some pars), isva), - - (function - ((Some pars), isva) -> (snd $1) (pars, isva) - | _ -> None)) - } -; -parameters_ne: -| ELLIPSIS - { ((fun args -> ([], true)), - - (function - ([], true) -> Some [] - | _ -> None)) - } - -| ARG_va { let currentArg = $1 in - ((fun args -> - match getArg currentArg args with - Fva isva -> ([], isva) - | a -> wrongArgType currentArg "vararg" a), - - (function - ([], isva) -> Some [ Fva isva ] - | _ -> None)) - } - -| ARG_F { let currentArg = $1 in - ((fun args -> - match getArg currentArg args with - FF fl -> ( fl, false) - | a -> wrongArgType currentArg "formals" a), - - (function - (pars, false) -> Some [ FF pars ] - | _ -> None)) - } - -| one_formal { ((fun args -> ([(fst $1) args], false)), - - (function - ([ f ], false) -> (snd $1) f - | _ -> None)) - } - - -| one_formal COMMA parameters_ne - { ((fun args -> - let this = (fst $1) args in - let (rest, isva) = (fst $3) args in - (this :: rest, isva)), - - (function - ((f::rest, isva)) -> begin - match (snd $1) f, (snd $3) (rest, isva) with - Some m1, Some m2 -> Some (m1 @ m2) - | _, _ -> None - end - | _ -> None)) - } -; - - - - - -exp_opt: - /* empty */ { ((fun args -> None), - (* Match anything if the pattern does not have a len *) - (fun _ -> Some [])) } - -| expression { ((fun args -> Some ((fst $1) args)), - - (fun lo -> match lo with - Some e -> (snd $1) e - | _ -> None)) - } -| ARG_eo { let currentArg = $1 in - ((fun args -> - match getArg currentArg args with - Feo lo -> lo - | a -> wrongArgType currentArg "exp_opt" a), - - fun lo -> Some [ Feo lo ]) - } -; - - - -attributes: - /*(* Ignore other attributes *)*/ - /* empty */ { ((fun args -> []), - (fun attrs -> Some [])) } - -| ARG_A { let currentArg = $1 in - ((fun args -> - match getArg currentArg args with - FA al -> al - | a -> wrongArgType currentArg "attributes" a), - - (fun al -> Some [ FA al ])) - } - -| attribute attributes - { ((fun args -> - addAttribute ((fst $1) args) ((fst $2) args)), - (* Pass all the attributes down *) - (fun attrs -> - match (snd $1) attrs, (snd $2) attrs with - Some m1, Some m2 -> Some (m1 @ m2) - | _, _ -> None)) - } -; - -attribute: -| CONST { doAttr "const" None } -| RESTRICT { doAttr "restrict" None } -| VOLATILE { doAttr "volatile" None } -| ATTRIBUTE LPAREN LPAREN attr RPAREN RPAREN - { $4 } - -; - - -attr: -| IDENT - { doAttr $1 None } - -| IDENT LPAREN attr_args_ne RPAREN - { doAttr $1 (Some $3) } -; - -attr_args_ne: - attr_arg { ((fun args -> [ (fst $1) args ]), - - (fun aargs -> match aargs with - [ arg ] -> (snd $1) arg - | _ -> None)) - } -| attr_arg COMMA attr_args_ne { ((fun args -> - let this = (fst $1) args in - this :: ((fst $3) args)), - - (fun aargs -> match aargs with - h :: rest -> begin - match (snd $1) h, (snd $3) rest with - Some m1, Some m2 -> Some (m1 @ m2) - | _, _ -> None - end - | _ -> None)) - } -| ARG_P { let currentArg = $1 in - ((fun args -> - match getArg currentArg args with - FP al -> al - | a -> wrongArgType currentArg "attrparams" a), - - (fun al -> Some [ FP al ])) - } -; - -attr_arg: -| IDENT { ((fun args -> ACons($1, [])), - - (fun aarg -> match aarg with - ACons(id, []) when id = $1 -> Some [] - | _ -> None)) - } -| IDENT LPAREN attr_args_ne RPAREN - { ((fun args -> ACons($1, (fst $3) args)), - - (fun aarg -> match aarg with - ACons(id, args) when id = $1 -> - (snd $3) args - | _ -> None)) - } -| ARG_p { let currentArg = $1 in - ((fun args -> - match getArg currentArg args with - Fp p -> p - | a -> wrongArgType currentArg "attrparam" a), - - (fun ap -> Some [ Fp ap])) - } - -; - -/* (********** INSTRUCTIONS ***********) */ -instr: -| ARG_i SEMICOLON - { let currentArg = $1 in - ((fun loc args -> - match getArg currentArg args with - Fi i -> i - | a -> wrongArgType currentArg "instr" a), - - (fun i -> Some [ Fi i])) - } - -| lval EQ expression SEMICOLON - { ((fun loc args -> - Set((fst $1) args, (fst $3) args, loc)), - - (fun i -> match i with - Set (lv, e, l) -> begin - match (snd $1) lv, (snd $3) e with - Some m1, Some m2 -> Some (m1 @ m2) - | _, _ -> None - end - | _ -> None)) - } - -| lval PLUS_EQ expression SEMICOLON - { ((fun loc args -> - let l = (fst $1) args in - Set(l, buildPlus (Lval l) ((fst $3) args), loc)), - - matchBinopEq - (fun bop -> bop = PlusPI || bop = PlusA) - (snd $1) (snd $3)) - } - -| lval MINUS_EQ expression SEMICOLON - { ((fun loc args -> - let l = (fst $1) args in - Set(l, - buildMinus (Lval l) ((fst $3) args), loc)), - - matchBinopEq (fun bop -> bop = MinusA - || bop = MinusPP - || bop = MinusPI) - (snd $1) (snd $3)) - } -| lval STAR_EQ expression SEMICOLON - { doBinopEq Mult $1 $3 } - -| lval SLASH_EQ expression SEMICOLON - { doBinopEq Div $1 $3 } - -| lval PERCENT_EQ expression SEMICOLON - { doBinopEq Mod $1 $3 } - -| lval AND_EQ expression SEMICOLON - { doBinopEq BAnd $1 $3 } - -| lval PIPE_EQ expression SEMICOLON - { doBinopEq BOr $1 $3 } - -| lval CIRC_EQ expression SEMICOLON - { doBinopEq BXor $1 $3 } - -| lval INF_INF_EQ expression SEMICOLON - { doBinopEq Shiftlt $1 $3 } - -| lval SUP_SUP_EQ expression SEMICOLON - { doBinopEq Shiftrt $1 $3 } - -/* (* Would be nice to be able to condense the next three rules but we get - * into conflicts *)*/ -| lval EQ lval LPAREN arguments RPAREN SEMICOLON - { ((fun loc args -> - Call(Some ((fst $1) args), Lval ((fst $3) args), - (fst $5) args, loc)), - - (fun i -> match i with - Call(Some l, Lval f, args, loc) -> begin - match (snd $1) l, (snd $3) f, (snd $5) args with - Some m1, Some m2, Some m3 -> - Some (m1 @ m2 @ m3) - | _, _, _ -> None - end - | _ -> None)) - } - -| lval LPAREN arguments RPAREN SEMICOLON - { ((fun loc args -> - Call(None, Lval ((fst $1) args), - (fst $3) args, loc)), - - (fun i -> match i with - Call(None, Lval f, args, loc) -> begin - match (snd $1) f, (snd $3) args with - Some m1, Some m2 -> Some (m1 @ m2) - | _, _ -> None - end - | _ -> None)) - } - -| arglo lval LPAREN arguments RPAREN SEMICOLON - { ((fun loc args -> - Call((fst $1) args, Lval ((fst $2) args), - (fst $4) args, loc)), - - (fun i -> match i with - Call(lo, Lval f, args, loc) -> begin - match (snd $1) lo, (snd $2) f, (snd $4) args with - Some m1, Some m2, Some m3 -> - Some (m1 @ m2 @ m3) - | _, _, _ -> None - end - | _ -> None)) - } -; - -/* (* Separate this out to ensure that the counting or arguments is right *)*/ -arglo: - ARG_lo { let currentArg = $1 in - ((fun args -> - let res = - match getArg currentArg args with - Flo x -> x - | a -> wrongArgType currentArg "lval option" a - in - res), - - (fun lo -> Some [ Flo lo ])) - } -; -arguments: - /* empty */ { ((fun args -> []), - - (fun actuals -> match actuals with - [] -> Some [] - | _ -> None)) - } - -| arguments_ne { $1 } -; - -arguments_ne: - expression { ((fun args -> [ (fst $1) args ]), - - (fun actuals -> match actuals with - [ h ] -> (snd $1) h - | _ -> None)) - } - -| ARG_E { let currentArg = $1 in - ((fun args -> - match getArg currentArg args with - FE el -> el - | a -> wrongArgType currentArg "arguments" a), - - (fun actuals -> Some [ FE actuals ])) - } - -| expression COMMA arguments_ne - { ((fun args -> ((fst $1) args) :: ((fst $3) args)), - - (fun actuals -> match actuals with - h :: rest -> begin - match (snd $1) h, (snd $3) rest with - Some m1, Some m2 -> Some (m1 @ m2) - | _, _ -> None - end - | _ -> None)) - } -; - - -/*(******** STATEMENTS *********)*/ -stmt: - IF LPAREN expression RPAREN stmt %prec IF - { (fun mkTemp loc args -> - mkStmt (If((fst $3) args, - mkBlock [ $5 mkTemp loc args ], - mkBlock [], loc))) - } -| IF LPAREN expression RPAREN stmt ELSE stmt - { (fun mkTemp loc args -> - mkStmt (If((fst $3) args, - mkBlock [ $5 mkTemp loc args ], - mkBlock [ $7 mkTemp loc args], loc))) - } -| RETURN exp_opt SEMICOLON - { (fun mkTemp loc args -> - mkStmt (Return((fst $2) args, loc))) - } -| BREAK SEMICOLON - { (fun mkTemp loc args -> - mkStmt (Break loc)) - } -| CONTINUE SEMICOLON - { (fun mkTemp loc args -> - mkStmt (Continue loc)) - } -| LBRACE stmt_list RBRACE - { (fun mkTemp loc args -> - let stmts = $2 mkTemp loc args in - mkStmt (Block (mkBlock (stmts)))) - } -| WHILE LPAREN expression RPAREN stmt - { (fun mkTemp loc args -> - let e = (fst $3) args in - let e = - if isPointerType(typeOf e) then - mkCast e !upointType - else e - in -(* - mkStmt - (Loop (mkBlock [ mkStmt - (If(e, - mkBlock [], - mkBlock [ mkStmt - (Break loc) ], - loc)); - $5 mkTemp loc args ], - loc, None, None)) -*) - mkStmt - (While (e, mkBlock [ $5 mkTemp loc args ], loc))) - } -| instr_list { (fun mkTemp loc args -> - mkStmt (Instr ($1 loc args))) - } -| ARG_s { let currentArg = $1 in - (fun mkTemp loc args -> - match getArg currentArg args with - Fs s -> s - | a -> wrongArgType currentArg "stmt" a) } -; - -stmt_list: - /* empty */ { (fun mkTemp loc args -> []) } - -| ARG_S { let currentArg = $1 in - (fun mkTemp loc args -> - match getArg currentArg args with - | FS sl -> sl - | a -> wrongArgType currentArg "stmts" a) - } -| stmt stmt_list - { (fun mkTemp loc args -> - let this = $1 mkTemp loc args in - this :: ($2 mkTemp loc args)) - } -/* (* We can also have a declaration *) */ -| type_spec attributes decl maybe_init SEMICOLON stmt_list - { (fun mkTemp loc args -> - let tal = (fst $2) args in - let ts = (fst $1) tal args in - let (n, t, _) = (fst $3) ts args in - let init = $4 args in - (* Before we proceed we must create the variable *) - let v = mkTemp n t in - (* Now we parse the rest *) - let rest = $6 mkTemp loc ((n, Fv v) :: args) in - (* Now we add the initialization instruction to the - * front *) - match init with - NoInit -> rest - | InitExp e -> - mkStmtOneInstr (Set((Var v, NoOffset), e, loc)) - :: rest - | InitCall (f, args) -> - mkStmtOneInstr (Call(Some (Var v, NoOffset), - Lval f, args, loc)) - :: rest - - ) - } -; - -instr_list: - /*(* Set this rule to very low precedence to ensure that we shift as - many instructions as possible *)*/ - instr %prec COMMA - { (fun loc args -> [ ((fst $1) loc args) ]) } -| ARG_I { let currentArg = $1 in - (fun loc args -> - match getArg currentArg args with - | FI il -> il - | a -> wrongArgType currentArg "instrs" a) - } -| instr instr_list - { (fun loc args -> - let this = (fst $1) loc args in - this :: ($2 loc args)) - } -; - - -maybe_init: -| { (fun args -> NoInit) } -| EQ expression { (fun args -> InitExp ((fst $2) args)) } -| EQ lval LPAREN arguments RPAREN - { (fun args -> - InitCall((fst $2) args, (fst $4) args)) } -; -%% - - - - - - - -- cgit