hdirect-0.21.0: src/Parser.y
{
{-
%
% (c) The GRASP/AQUA Project, Glasgow University, 1998
%
% @(#) $Docid: Jan. 15th 2004 10:33 Sigbjorn Finne $
% @(#) $Contactid: sof@galois.com $
%
A grammar for IDL, DCE / MS (IDL/ODL) style.
Conflicts:
- 1 reduce/reduce conflict due to `default'
both being an attribute and a keyword.
- 7 shift/reduce conflicts due to the overloading
of `const' (t. qualifier and keyword.)
ToDo:
- fix above conflicts.
-}
module Parser ( parseIDL ) where
import LexM
import Lex
import IDLToken
import IDLSyn
import IDLUtils ( mkFunId, mkMethodId, toCConvAttrib,
mkGNUAttrib, toPackedAttrib, exprType )
import BasicTypes
import Literal
import IO ( hPutStrLn, stderr )
{-
BEGIN_GHC_ONLY
import GlaExts
END_GHC_ONLY
-}
}
%name parseIDL
%tokentype { IDLToken }
%monad { LexM } {thenLexM } { returnLexM }
%lexer { lexIDL } { T_eof }
%token
';' { T_semi }
MODULE { T_module }
INTERFACE { T_interface }
'(' { T_oparen }
')' { T_cparen }
'{' { T_ocurly }
'}' { T_ccurly }
':' { T_colon }
',' { T_comma }
'.' { T_dot }
'...' { T_dotdotdot }
CONST { T_const }
VOLATILE { T_volatile }
'=' { T_equal }
'==' { T_eqeq }
'!=' { T_neq }
'|' { T_or }
'||' { T_rel_or }
'^' { T_xor }
'&' { T_and }
'&&' { T_rel_and }
SHIFT { T_shift $$ }
'/' { T_div }
'%' { T_mod }
'~' { T_not }
'!' { T_negate }
'?' { T_question }
TYPEDEF { T_typedef }
EXTERN { T_extern }
TYPE { T_type $$ }
ITYPE { T_idl_type $$ }
FLOAT { T_float $$ }
SHORT { (T_int Short) }
LONG { (T_int Long) }
LONGLONG { (T_int LongLong) }
ULONGLONG { (T_uint LongLong) }
INT { (T_int Natural) }
UNSIGNED { T_unsigned }
SIGNED { T_signed }
CHAR { T_char }
WCHAR { T_wchar }
STRUCT { T_struct }
UNION { T_union }
SWITCH { T_switch }
CASE { T_case }
DEFAULT { T_default }
ENUM { T_enum }
'<' { T_lt }
'<=' { T_le }
'>' { T_gt }
'>=' { T_ge }
'[' { T_osquare }
']' { T_csquare }
SIZEOF { T_sizeof }
VOID { T_void }
MODE { T_mode $$ }
LITERAL { T_literal $$ }
STRING_LIT { T_string_lit $$ }
CALLCONV { T_callconv $$ }
ID { T_id $$ }
DISPINTERFACE { T_dispinterface }
COCLASS { T_coclass }
LIBRARY { T_library }
'+' { T_plus }
'*' { T_times }
'-' { T_minus }
STRING { T_string }
WSTRING { T_wstring }
METHODS { T_methods }
PROPERTIES { T_properties }
CPP_QUOTE { T_cpp_quote }
HS_QUOTE { T_hs_quote }
INCLUDE { T_include $$ }
IMPORTLIB { T_importlib }
INCLUDE_START { T_include_start $$ }
INCLUDE_END { T_include_end }
ATTRIBUTE { T_gnu_attribute }
IMPORT { T_import }
PRAGMA { T_pragma $$ }
HDEFINE { T_hdefine }
SAFEARRAY { T_safearray }
UNKNOWN { T_unknown $$ }
%%
{-
Share the same parser for DCE IDL input and ASFs. To avoid
running into gratuitous conflicts, ASF input is assumed to
be prefixed by a '=' (inserted by the compiler.)
-}
specification :: { Either [Defn] [(Name, Bool, [Attribute])] }
: definitions { Left (reverse $1) }
| '=' attr_defs { Right (reverse $2) }
definitions :: { [Defn] }
: { [] }
| definitions definition { $2 : $1 }
attr_defs :: { [(String, Bool, [Attribute])] }
: {- empty -} { [] }
| attr_defs attr_def { $2 : $1 }
attr_def :: { (String, Bool, [Attribute] ) }
: attr_name ':' opt_attributes { ($1, True, $3) }
| attr_name '=' opt_attributes { ($1, False, $3) }
attr_name :: { String }
: ID { $1 }
| TYPE { $1 }
definition :: { Defn }
: type_dcl ';' { $1 }
| DISPINTERFACE identifier ';' {% let (Id i) = $2 in addIfaceTypedef i >>= \ v -> return (Forward v) }
| attributed semi { $1 }
| cpp_quote semi { $1 }
| hs_quote semi { $1 }
| define { $1 }
| import_dcl ';' { $1 }
| pragma_dcl { $1 }
attributed :: { Defn }
: attributes attr_defn { Attributed $1 $2 }
| attr_defn { $1 }
attr_defn :: { Defn }
: interface_dcl { $1 }
| MODULE identifier { Forward $2 }
| MODULE identifier '{' definitions semi '}'
{ Module $2 (reverse $4) }
| dispinterface { $1 }
| COCLASS identifier '{' coclass_members ';' '}'
{% let (Id i) = $2 in addIfaceTypedef i >>= \ v -> return (CoClass v (reverse $4)) }
| COCLASS TYPE '{' coclass_members ';' '}'
{ CoClass (Id $2) (reverse $4) }
| LIBRARY identifier '{' definitions '}'
{ Library $2 (reverse $4) }
| op_decl { $1 }
{- op_decls at the toplevel isn't legal, but we allow it to be parsed
anyhow, and report the presence of these later on -}
dispinterface :: { Defn }
: dispinterface_hdr '{'
PROPERTIES ':' attr_id_list
METHODS ':' method_decls
'}' {% let (Id i) = $1 in addIfaceTypedef i >>= \ v -> return (DispInterface v $5 (reverse $8)) }
| dispinterface_hdr '{'
INTERFACE simple_declarator ';'
'}' {% let (Id i) = $1 in addIfaceTypedef i >>= \ v -> return (DispInterfaceDecl v $4) }
attr_id_list :: { [([Attribute], Type, Id)] }
: {- empty -} { [] }
| attr_id_list opt_attributes type_spec declarator ';' { ($2,$3,$4):$1 }
coclass_members :: { [CoClassMember] }
: coclass_member { [$1] }
| coclass_members ';' coclass_member { $3 : $1 }
coclass_member :: { CoClassMember }
: opt_coclass_attrs INTERFACE TYPE { (True, Id $3, $1) }
| opt_coclass_attrs DISPINTERFACE TYPE { (False, Id $3, $1) }
| opt_coclass_attrs INTERFACE identifier { (True, $3, $1) }
| opt_coclass_attrs DISPINTERFACE identifier { (False, $3, $1) }
opt_coclass_attrs :: { [Attribute] }
: {- empty -} { [] }
| '[' cc_attributes ']' { $2 }
interface_dcl :: { Defn }
: interface_hdr { Forward $1 }
| interface_hdr inheritance_spec '{' exports '}'
{ Interface $1 $2 (reverse $4) }
{-
We eagerly add the name of an interface as a type name, so
that typedefs inside the interface body can refer to it.
-}
interface_hdr :: { Id }
: INTERFACE identifier {% let (Id i) = $2 in addIfaceTypedef i >>= return }
| INTERFACE TYPE { (Id $2) }
| INTERFACE ITYPE { (Id "Object") }
dispinterface_hdr :: { Id }
: DISPINTERFACE identifier {% let (Id i) = $2 in addIfaceTypedef i >>= return }
| DISPINTERFACE TYPE { (Id $2) }
cpp_quote :: { Defn }
: CPP_QUOTE '(' STRING_LIT ')' { CppQuote $3 }
hs_quote :: { Defn }
: HS_QUOTE '(' STRING_LIT ')' { HsQuote $3 }
| INCLUDE { CInclude $1 }
exports :: { [Defn] }
: {-empty -} { [] }
| exports export { $2 : $1 }
export :: { Defn }
: attributed_exp ';' { $1 }
| type_dcl ';' { $1 }
| cpp_quote semi { $1 }
| hs_quote semi { $1 }
| import_dcl ';' { $1 }
attributed_exp :: { Defn }
: attributes op_decl { Attributed $1 $2 }
| op_decl { $1 }
inheritance_spec :: { Inherit }
: { [] }
| ':' TYPE { [ $2 ] }
| ':' identifier { let (Id i) = $2 in [ i ] }
import_dcl :: { Defn }
: IMPORT string_lit_list {% slurpImports (parseIDL >>= \ (Left y) -> return y) $2 }
| IMPORTLIB '(' STRING_LIT ')' {% handleImportLib (parseIDL >>= \ (Left y) -> return y) $3 }
{- No validation here of what's on the #pragma line -}
pragma_dcl :: { Defn }
: PRAGMA { Pragma $1 }
| INCLUDE_START { IncludeStart $1 }
| INCLUDE_END { IncludeEnd }
define :: { Defn }
: HDEFINE ID const_expr { Constant (Id $2) [] (exprType (TyInteger Natural) $3) $3 }
string_lit_list :: { [String] }
: STRING_LIT { [ $1 ] }
| STRING_LIT ',' string_lit_list { ($1 : $3) }
{-
Not using type_spec for constant types minimises
the shift/reduce conflicts (i.e., no CONST qualifiers
allowed below.)
-}
const_type :: { Type }
: integer_ty { $1 }
| CHAR { TyChar }
| WCHAR { TyWChar }
| FLOAT { TyFloat $1 }
| VOID { TyVoid }
| VOID '*' { TyPointer TyVoid }
| CHAR '*' { TyString Nothing }
| WCHAR '*' { TyWString Nothing }
| string_type { $1 }
| const_type '[' ']' { TyArray $1 [] }
-- my word, what junk C allows here.
| SIGNED { TySigned True }
| UNSIGNED { TySigned False }
| UNSIGNED integer_ty { TyApply (TySigned False) $2 }
| SIGNED integer_ty { TyApply (TySigned True) $2 }
| UNSIGNED CHAR { TyApply (TySigned False) TyChar }
| integer SIGNED INT { TyApply (TySigned True) $1 }
| integer UNSIGNED INT { TyApply (TySigned False) $1 }
| SIGNED CHAR { TyApply (TySigned True) TyChar }
| ID { TyName $1 Nothing }
| TYPE { TyName $1 Nothing }
| TYPE '*' { TyPointer (TyName $1 Nothing) }
| ITYPE { $1 }
| error {% dumpErrMsg >> return TyVoid }
integer :: { Type }
: SHORT { TyInteger Short }
| LONG { TyInteger Long }
| LONG LONG { TyInteger LongLong }
| LONGLONG { TyInteger LongLong }
| ULONGLONG { TyApply (TySigned False) (TyInteger LongLong) }
integer_ty :: { Type }
: integer { $1 }
| integer INT { $1 }
| INT { TyInteger Natural }
const_type_cast :: { Type }
: integer_ty { $1 }
| CHAR { TyChar }
| WCHAR { TyWChar }
| FLOAT { TyFloat $1 }
| VOID { TyVoid }
| string_type { $1 }
| const_type '[' ']' { TyArray $1 [] }
| SIGNED { TySigned True }
| UNSIGNED { TySigned False }
| UNSIGNED integer_ty { TyApply (TySigned False) $2 }
| SIGNED integer_ty { TyApply (TySigned True) $2 }
| integer UNSIGNED INT { TyApply (TySigned False) $1 }
| integer SIGNED INT { TyApply (TySigned True) $1 }
| UNSIGNED CHAR { TyApply (TySigned False) TyChar }
| SIGNED CHAR { TyApply (TySigned True) TyChar }
| TYPE { TyName $1 Nothing }
| ITYPE { $1 }
| error {% dumpErrMsg >> return TyVoid }
const_expr :: { Expr }
: cond_expr { $1 }
cond_expr :: { Expr }
: log_or_expr { $1 }
| cond_expr '?' const_expr ':' log_or_expr { Cond $1 $3 $5 }
log_or_expr :: { Expr }
: log_and_expr { $1 }
| log_or_expr '||' log_and_expr { Binary LogOr $1 $3 }
log_and_expr :: { Expr }
: or_expr { $1 }
| log_and_expr '&&' or_expr { Binary LogAnd $1 $3 }
or_expr :: { Expr }
: xor_expr { $1 }
| or_expr '|' xor_expr { Binary Or $1 $3 }
xor_expr :: { Expr }
: and_expr { $1 }
| xor_expr '^' and_expr { Binary Xor $1 $3 }
and_expr :: { Expr }
: eq_expr { $1 }
| and_expr '&' eq_expr { Binary And $1 $3 }
eq_expr :: { Expr }
: rel_expr { $1 }
| eq_expr eq_op rel_expr { Binary Eq $1 $3 }
eq_op :: { BinaryOp }
: '==' { Eq }
| '!=' { Ne }
rel_expr :: { Expr }
: shift_expr { $1 }
| rel_expr '<' shift_expr { Binary Lt $1 $3 }
| rel_expr '<=' shift_expr { Binary Le $1 $3 }
| rel_expr '>=' shift_expr { Binary Ge $1 $3 }
| rel_expr '>' shift_expr { Binary Gt $1 $3 }
shift_expr :: { Expr }
: add_expr { $1 }
| shift_expr SHIFT add_expr { Binary (Shift $2) $1 $3 }
add_expr :: { Expr }
: mult_expr { $1 }
| add_expr '+' mult_expr { Binary Add $1 $3 }
| add_expr '-' mult_expr { Binary Sub $1 $3 }
mult_expr :: { Expr }
: cast_expr { $1 }
| mult_expr '*' cast_expr { Binary Mul $1 $3 }
| mult_expr '/' cast_expr { Binary Div $1 $3 }
| mult_expr '%' cast_expr { Binary Mod $1 $3 }
cast_expr :: { Expr }
: unary_expr { $1 }
| '(' const_type_cast ')' cast_expr { Cast $2 $4 }
unary_expr :: { Expr }
: primary_expr { $1 }
| SIZEOF '(' const_type ')' { Sizeof $3 }
| unary_operator primary_expr { Unary $1 $2}
unary_operator :: { UnaryOp }
: '-' { Minus } | '+' { Plus } | '~' { Not } | '!' { Negate }
primary_expr :: { Expr }
: identifier { let (Id i) = $1 in Var i }
| LITERAL { Lit $1 }
| STRING_LIT { Lit (StringLit $1) }
| '(' const_expr ')' { $2 }
type_dcl :: { Defn }
: mb_gnu_attributes TYPEDEF opt_attributes type_spec declarators mb_gnu_attributes
{% let decls = reverse $5 in addTypes decls >> return (Typedef $4 $3 decls) }
| attributes struct_or_union_or_enum_spec { Attributed $1 (TypeDecl $2) }
| struct_or_union_or_enum_spec { TypeDecl $1 }
| attributes CONST const_type identifier '=' const_expr { Constant $4 $1 $3 $6 }
| CONST const_type identifier '=' const_expr { Constant $3 [] $2 $5 }
| mb_gnu_attributes EXTERN mb_gnu_attributes type_spec declarators mb_gnu_attributes
{% let decls = reverse $5 in addTypes decls >> return (ExternDecl $4 decls) }
type_spec :: { Type }
: type_specifier { $1 }
| type_spec '[' ']' { TyArray $1 [] }
| type_spec '[' const_expr ']' { TyArray $1 [$3] }
| type_specifier type_qualifier { TyApply (TyQualifier $2) $1 }
| type_qualifier type_spec { TyApply (TyQualifier $1) $2 }
type_spec_no_leading_qual :: { Type }
: type_specifier { $1 }
| type_spec_no_leading_qual '[' ']' { TyArray $1 [] }
| type_specifier type_qualifier { TyApply (TyQualifier $2) $1 }
type_qualifier :: { Qualifier }
: CONST { Const }
| VOLATILE { Volatile }
type_specifier :: { Type }
: FLOAT { TyFloat $1 }
| CHAR { TyChar }
| WCHAR { TyWChar }
| integer_ty { $1 }
| VOID { TyVoid }
| SIGNED { TySigned True }
| UNSIGNED { TySigned False }
| SIGNED signed_type_specifier { TyApply (TySigned True) $2 }
| SIGNED CONST signed_type_specifier { TyApply (TySigned True) $3 }
| UNSIGNED signed_type_specifier { TyApply (TySigned False) $2 }
| UNSIGNED CONST signed_type_specifier { TyApply (TySigned False) $3 }
| integer SIGNED INT { TyApply (TySigned True) $1 }
| integer UNSIGNED INT { TyApply (TySigned False) $1 }
| ID { TyName $1 Nothing }
| TYPE { TyName $1 Nothing }
| ITYPE { $1 }
| SAFEARRAY safearray_type_spec ')' { TySafeArray $2 } {- the oparen is part of the SAFEARRAY lexeme..-}
| struct_or_union_spec { $1 }
| enum_type { $1 }
| error {% dumpErrMsg >> return TyVoid }
signed_type_specifier :: { Type }
: integer_ty { $1 }
| CHAR { TyChar }
| FLOAT { TyFloat $1 }
-- | ID { TyName $1 Nothing }
| TYPE { TyName $1 Nothing }
| ITYPE { $1 }
safearray_type_spec :: { Type }
: type_specifier { $1 }
| safearray_type_spec '*' { TyPointer $1 }
struct_or_union_or_enum_spec :: { Type }
: struct_or_union_spec { $1 }
| enum_type { $1 }
struct_or_union_spec :: { Type }
: struct_type { $1 }
| union_type { $1 }
struct_type :: { Type }
: STRUCT simple_declarator '{' member_list '}' mb_gnu_attributes { TyStruct (Just $2) (reverse $4) (toPackedAttrib $6) }
| STRUCT '{' member_list '}' mb_gnu_attributes { TyStruct Nothing (reverse $3) (toPackedAttrib $5) }
| STRUCT simple_declarator { TyStruct (Just $2) [] Nothing }
union_type :: { Type }
: UNION switch_id SWITCH '(' switch_type_spec identifier ')'
switch_id '{' switch_body '}' { TyUnion $2 $5 $6 $8 (reverse $10) }
| UNION switch_id '{' member_or_switch_list '}' mb_gnu_attributes
{ case $4 of { Left sw -> TyUnionNon $2 (reverse sw) ; Right mem -> TyCUnion $2 (reverse mem) (toPackedAttrib $6) } }
| UNION identifier mb_gnu_attributes { TyCUnion (Just $2) [] (toPackedAttrib $3) }
member_or_switch_list :: { Either [Switch] [Member] }
: switch_body { Left $1 }
| member_list { Right $1 }
declarators :: { [ Id ] }
: declarator { [ $1 ] }
| declarators ',' declarator { $3 : $1 }
declarator :: { Id }
: callconv_or_attr pointer_declarator { $1 $2 }
| pointer_declarator { $1 }
| callconv_or_attr direct_declarator { $1 $2 }
| direct_declarator { $1 }
callconv_or_attr :: { (Id -> Id) }
: gnu_attributes { toCConvAttrib $1 }
| CALLCONV { CConvId $1 }
direct_declarator :: { Id }
: simple_declarator { $1 }
| '(' declarator ')' { $2 }
| function_declarator { $1 }
| array_declarator { $1 }
simple_declarator :: { Id }
: identifier { $1 }
-- bit field info is currently thrown away. ToDo: fix.
| identifier ':' LITERAL { (let { (Id nm) = $1 ; x = mkBitField nm $3 } in BitFieldId x $1) }
| TYPE ':' LITERAL { (let x = mkBitField $1 $3 in BitFieldId x (Id $1)) }
| ':' LITERAL { (let x = mkBitField "" $2 in BitFieldId x (Id "")) }
| TYPE { (Id $1) }
| MODE { (if $1 == In then Id "in" else Id "out") }
pointer_declarator :: { Id }
: pointer direct_declarator { Pointed $1 $2 }
| pointer CALLCONV direct_declarator { Pointed $1 (CConvId $2 $3) }
| pointer gnu_attributes direct_declarator { Pointed $1 (toCConvAttrib $2 $3) }
array_declarator :: { Id }
: direct_declarator '[' ']' { ArrayId $1 [] }
| direct_declarator '[' '*' ']' { ArrayId $1 [] }
| direct_declarator '[' const_expr ']' { ArrayId $1 [$3] }
| direct_declarator '[' primary_expr '.' '.' primary_expr ']' { ArrayId $1 [$3,$6] }
function_declarator :: { Id }
: direct_declarator '(' param_type_spec_list ')' { mkFunId $1 (reverse $3) }
| direct_declarator '(' ')' { mkFunId $1 [] }
pointer :: { [[Qualifier]] }
: '*' { [[]] }
| '*' type_quals { [$2] }
| '*' pointer { [] : $2 }
| '*' type_quals pointer { $2 : $3 }
{- Storage qualifiers on pointers -}
type_quals :: { [ Qualifier ] }
: type_qualifier { [$1] }
| type_quals type_qualifier { $2 : $1 }
member_list :: { [Member] }
: member mb_gnu_attributes ';' { [ $1 ] }
| member_list member mb_gnu_attributes ';' { $2 : $1 }
member :: { Member }
: opt_attributes type_spec declarators { ($2, $1, reverse $3) }
| opt_attributes type_spec { ($2, $1, []) }
-- The last one is unpleasant, unnamed members.
switch_id :: { Maybe Id }
: { Nothing }
| identifier { Just $1 }
switch_type_spec :: { Type }
: integer_ty { $1 }
| CHAR { TyChar }
| enum_type { $1 }
| struct_or_union_spec { $1 }
| ID { TyName $1 Nothing }
| TYPE { TyName $1 Nothing }
switch_body :: { [Switch] }
: case ';' { [ $1 ] }
| switch_body case ';' { $2 : $1 }
case :: { Switch }
: case_labels switch_arm { Switch $1 $2 }
| '[' case_label1 ']' switch1_arm { Switch [$2] $4 }
switch1_arm :: { Maybe SwitchArm }
: {- empty -} { Nothing }
| type_spec declarator { Just (Param $2 $1 []) }
| type_spec { Just (Param (Id "") $1 []) }
switch_arm :: { Maybe SwitchArm }
: {- empty -} { Nothing }
| opt_attributes type_spec declarator { Just (Param $3 $2 $1) }
| opt_attributes type_spec { Just (Param (Id "") $2 $1) }
case_labels :: { [CaseLabel] }
: case_label { [ $1 ] }
| case_labels case_label { $2 : $1 }
case_label :: { CaseLabel }
: CASE const_expr ':' { Case [$2] }
| DEFAULT ':' { Default }
case_label1 :: { CaseLabel }
: CASE '(' const_expr_list ')' { Case (reverse $3) }
| DEFAULT { Default }
const_expr_list :: { [Expr] }
: const_expr { [ $1 ] }
| const_expr_list ',' const_expr { $3 : $1 }
expr_list :: { [Expr] }
: {- empty -} { [] }
| const_expr_list { $1 }
enum_type :: { Type }
: ENUM '{' enumerators opt_comma '}' { TyEnum Nothing (reverse $3) }
| ENUM identifier '{'
enumerators opt_comma
'}' { TyEnum (Just $2) (reverse $4) }
| ENUM identifier { TyEnum (Just $2) [] }
{- NOTE: MIDL does allow a comma trailing the enumerator list -}
enumerators :: { [(Id, [Attribute], Maybe Expr)] }
: enumerator { [ $1 ] }
| enumerators ',' enumerator { $3 : $1 }
enumerator :: { (Id, [Attribute], Maybe Expr) }
: identifier { ($1, [], Nothing) }
| attributes identifier { ($2, $1, Nothing) }
| identifier '=' const_expr { ($1, [], Just $3) }
| attributes identifier '=' const_expr { ($2, $1, Just $4) }
string_type :: { Type }
: string_or_wstring '<' shift_expr '>' { $1 (Just $3) }
| string_or_wstring { $1 Nothing }
string_or_wstring :: { (Maybe Expr -> Type) }
: STRING { TyString }
| WSTRING { TyWString }
method_decls :: { [Defn] }
: {- empty -} { [] }
| method_decls method_decl ';' { $2 : $1 }
method_decl :: { Defn }
: opt_attributes op_type_spec declarator mb_gnu_attributes
{ let m_id = mkMethodId $3 in (Attributed $1 (Operation m_id $2 Nothing Nothing)) }
op_decl :: { Defn }
-- : op_type_spec declarator { Operation $2 $1 Nothing Nothing }
: op_type_spec declarator mb_gnu_attributes { let m_id = mkMethodId $2 in (Operation m_id $1 Nothing Nothing) }
opt_attributes :: { [Attribute] }
: opt_attributes1 { concat $1 }
opt_attributes1 :: { [[Attribute]] }
: {- empty -} { [] }
| attributes opt_attributes1 { $1 : $2 }
attributes :: { [Attribute] }
: '[' ']' { [] }
| '[' attributes1 opt_comma ']' { (reverse $2) }
attributes1 :: { [Attribute] }
: attribute { [ $1 ] }
| attributes1 ',' attribute { $3 : $1 }
attribute :: { Attribute }
: identifier opt_attr_params { Attrib $1 $2 }
| STRING { Attrib (Id "string") [] }
| MODE { Mode $1 }
cc_attributes :: { [Attribute] }
: cc_attribute { [ $1 ] }
| cc_attributes ',' cc_attribute { $3 : $1 }
cc_attribute :: { Attribute }
: identifier { Attrib $1 [] }
| DEFAULT { Attrib (Id "default") [] }
opt_attr_params :: { [AttrParam] }
: {- empty -} { [] }
| '(' attr_params ')' { (reverse $2) }
attr_params :: { [AttrParam] }
: attr_param { [$1] }
| attr_params ',' attr_param { $3:$1 }
attr_param :: { AttrParam }
: const_expr { (AttrExpr $1) }
| {-empty-} { EmptyAttr }
| TYPE { (AttrLit (TypeConst $1)) }
| UNSIGNED TYPE { (AttrLit (TypeConst ("unsigned " ++ $2))) }
| SIGNED TYPE { (AttrLit (TypeConst ("signed " ++ $2))) }
| '{' LITERAL '}' { AttrLit $2 } {- just a guid here, please! -}
| '*' attr_param { (AttrPtr $2) }
op_type_spec :: { Type }
: type_spec_no_leading_qual { $1 }
| string_type { $1 }
param_decl :: { Param }
: opt_attributes type_spec { Param (Id "") $2 $1 }
| opt_attributes type_spec declarator { Param $3 $2 $1 }
| opt_attributes type_spec abstract_declarator { Param $3 $2 $1 }
| '...' { Param (Id "vararg") TyVoid [] }
param_type_spec_list :: { [Param] }
: param_decl { [$1] }
| param_type_spec_list ',' param_decl { $3 : $1 }
abstract_declarator :: { Id }
: pointer { Pointed $1 (Id "") }
| callconv_or_attr abstract_declarator { $1 $2 }
| direct_abstract_declarator { $1 }
| pointer direct_abstract_declarator { Pointed $1 $2 }
direct_abstract_declarator :: { Id }
: '(' abstract_declarator ')' { $2 }
| '(' ')' { FunId (Id "") Nothing [] }
| '(' param_type_spec_list ')' { FunId (Id "") Nothing $2 }
| direct_abstract_declarator '(' ')' { FunId $1 Nothing [] }
| direct_abstract_declarator '(' param_type_spec_list ')' { FunId $1 Nothing $3 }
mb_gnu_attributes :: { [GNUAttrib] }
: {- empty -} { [] }
| gnu_attributes { (reverse $1) }
gnu_attributes :: { [GNUAttrib] }
: gnu_attribute { [$1] }
| gnu_attributes gnu_attribute { ($2:$1) }
gnu_attribute :: { GNUAttrib }
: ATTRIBUTE '(' '(' gnu_attrib ')' ')' { $4 }
gnu_attrib :: { GNUAttrib }
: a_word { mkGNUAttrib $1 [] }
| CALLCONV { CConv $1 }
| a_word '(' ID ')' { mkGNUAttrib $1 [Var $3] }
| a_word '(' ID ',' const_expr_list ')' { mkGNUAttrib $1 (Var $3:$5) }
a_word :: { String }
: ID { $1 }
| TYPE { $1 }
identifier :: { Id }
: ID { (Id $1) }
semi :: { () }
: error { () }
| ';' { () }
opt_comma :: { () }
: {- empty -} { () }
| ',' { () }
{------------------ END OF GRAMMAR --------------}
{
addTypes :: [Id] -> LexM ()
addTypes ids = do
sequence (map addTypedef ls)
return ()
where
ls = map getName ids
getName (Id s) = s
getName (ArrayId i _) = getName i
getName (Pointed _ i) = getName i
getName (CConvId _ i) = getName i
getName (FunId i _ _) = getName i
addIfaceTypedef :: String -> LexM Id
addIfaceTypedef nm = addTypedef nm >> return (Id nm)
mkBitField :: String -> Literal -> Int
mkBitField nm l =
case l of
IntegerLit (ILit _ i) -> fromInteger i
_ -> error ("bitfield " ++ show nm ++ " not an int.")
warningMsg :: String -> LexM ()
warningMsg msg = do
l <- getSrcLoc
ioToLexM (hPutStrLn stderr (show l ++ ": warning: "++msg))
dumpErrMsg :: LexM ()
dumpErrMsg = do
l <- getSrcLoc
str <- getStream
ioToLexM (ioError (userError (show l ++ ": Parse error on input: " ++ takeWhile (/='\n') str)))
happyError :: LexM a
happyError = do
l <- getSrcLoc
str <- getStream
ioToLexM (ioError (userError (show l ++ ": Parse error: " ++ takeWhile (/='\n') str)))
}