-- # -*- mode: haskell -*- { -- -- Ivory parser. -- -- Copyright (C) 2014, Galois, Inc. -- All rights reserved. -- -- TODO -- types for allocs module Ivory.Language.Syntax.Concrete.Parser where import Prelude () import Prelude.Compat import Ivory.Language.Syntax.Concrete.ParseCore import Ivory.Language.Syntax.Concrete.ParseAST import Ivory.Language.Syntax.Concrete.Lexer import Ivory.Language.Syntax.Concrete.Lexeme ( Token(..), Lexeme ) import Ivory.Language.Syntax.Concrete.Location import Data.Monoid.Compat } %name topParser defs %name stmtsParser stmts %tokentype { Lexeme } %monad { Parser } { (>>=) } { return } %lexer { lexer } { Located mempty TokEOF } %error { parseError } %token integer { $$@Located { locValue = TokInteger _ } } floatlit { $$@Located { locValue = TokFloat _ } } bitlit { $$@Located { locValue = TokBitLit _ } } identifier { $$@Located { locValue = TokIdent _ } } tyidentifier { $$@Located { locValue = TokTyIdent _ } } str { $$@Located { locValue = TokString _ } } -- Statements if { Located $$ (TokReserved "if") } else { Located $$ (TokReserved "else") } assert { Located $$ (TokReserved "assert") } assume { Located $$ (TokReserved "assume") } pre { Located $$ (TokReserved "pre") } post { Located $$ (TokReserved "post") } assign { Located $$ (TokReserved "let") } return { Located $$ (TokReserved "return") } alloc { Located $$ (TokReserved "alloc") } store { Located $$ (TokReserved "store") } refCopy { Located $$ (TokReserved "memcpy") } mapArr { Located $$ (TokReserved "map") } upTo { Located $$ (TokReserved "upTo") } upFromTo { Located $$ (TokReserved "upFromTo") } downFrom { Located $$ (TokReserved "downFrom") } downFromTo { Located $$ (TokReserved "downFromTo") } forever { Located $$ (TokReserved "forever") } break { Located $$ (TokReserved "break") } -- Start of Ivory macros iMacro { Located $$ (TokSym "$") } -- Expressions abs { Located $$ (TokReserved "abs") } signum { Located $$ (TokReserved "signum") } expOp { Located $$ (TokReserved "exp") } sqrt { Located $$ (TokReserved "sqrt") } log { Located $$ (TokReserved "log") } pow { Located $$ (TokReserved "pow") } div { Located $$ (TokReserved "div") } sin { Located $$ (TokReserved "sin") } cos { Located $$ (TokReserved "cos") } tan { Located $$ (TokReserved "tan") } asin { Located $$ (TokReserved "asin") } acos { Located $$ (TokReserved "acos") } atan { Located $$ (TokReserved "atan") } atan2 { Located $$ (TokReserved "atan2") } sinh { Located $$ (TokReserved "sinh") } cosh { Located $$ (TokReserved "cosh") } tanh { Located $$ (TokReserved "tanh") } asinh { Located $$ (TokReserved "asinh") } acosh { Located $$ (TokReserved "acosh") } atanh { Located $$ (TokReserved "atanh") } isnan { Located $$ (TokReserved "isnan") } isinf { Located $$ (TokReserved "isinf") } round { Located $$ (TokReserved "round") } ceil { Located $$ (TokReserved "ceil") } floor { Located $$ (TokReserved "floor") } const { Located $$ (TokReserved "const") } -- Casting safeCast { Located $$ (TokReserved "safeCast") } bitCast { Located $$ (TokReserved "bitCast") } castWith { Located $$ (TokReserved "castWith") } twosCompCast { Located $$ (TokReserved "twosCompCast") } twosCompRep { Located $$ (TokReserved "twosCompRep") } -- Other internals fromIx { Located $$ (TokReserved "fromIx") } ixSize { Located $$ (TokReserved "ixSize") } toIx { Located $$ (TokReserved "toIx") } toCArray { Located $$ (TokReserved "toCArray") } arrayLen { Located $$ (TokReserved "arrayLen") } sizeOf { Located $$ (TokReserved "sizeOf") } nullPtr { Located $$ (TokReserved "nullPtr") } refToPtr { Located $$ (TokReserved "refToPtr") } -- Type '::' { Located $$ (TokSym "::") } '?' { Located $$ (TokSym "?") } ':' { Located $$ (TokSym ":") } -- Struct field dereference '.' { Located $$ (TokSym ".") } '->' { Located $$ (TokSym "->") } '==' { Located $$ (TokSym "==") } '!=' { Located $$ (TokSym "!=") } -- Used for deref and mult '*' { Located $$ (TokSym "*") } '/' { Located $$ (TokSym "/") } '+' { Located $$ (TokSym "+") } '-' { Located $$ (TokSym "-") } '%' { Located $$ (TokSym "%") } '=' { Located $$ (TokSym "=") } '<' { Located $$ (TokSym "<") } '<=' { Located $$ (TokSym "<=") } '>=' { Located $$ (TokSym ">=") } '>' { Located $$ (TokSym ">") } '|' { Located $$ (TokSym "|") } '&' { Located $$ (TokSym "&") } '^' { Located $$ (TokSym "^") } '~' { Located $$ (TokSym "~") } '!' { Located $$ (TokSym "!") } '&&' { Located $$ (TokSym "&&") } '||' { Located $$ (TokSym "||") } '<<' { Located $$ (TokSym "<<") } '>>' { Located $$ (TokSym ">>") } -- Other symbols '(' { Located $$ (TokBrack "(") } ')' { Located $$ (TokBrack ")") } '{' { Located $$ (TokBrack "{") } '}' { Located $$ (TokBrack "}") } '[' { Located $$ (TokBrack "[") } ']' { Located $$ (TokBrack "]") } ';' { Located $$ (TokSep ";") } ',' { Located $$ (TokSep ",") } '@' { Located $$ (TokSym "@") } '<-' { Located $$ (TokSym "<-") } -- Types bool { Located $$ (TokReserved "bool") } char { Located $$ (TokReserved "char") } float { Located $$ (TokReserved "float") } double { Located $$ (TokReserved "double") } void { Located $$ (TokReserved "void") } int8_t { Located $$ (TokReserved "int8_t") } int16_t { Located $$ (TokReserved "int16_t") } int32_t { Located $$ (TokReserved "int32_t") } int64_t { Located $$ (TokReserved "int64_t") } uint8_t { Located $$ (TokReserved "uint8_t") } uint16_t { Located $$ (TokReserved "uint16_t") } uint32_t { Located $$ (TokReserved "uint32_t") } uint64_t { Located $$ (TokReserved "uint64_t") } S { Located $$ (TokReserved "S") } G { Located $$ (TokReserved "G") } IBool { Located $$ (TokReserved "IBool") } IChar { Located $$ (TokReserved "IChar") } IFloat { Located $$ (TokReserved "IFloat") } IDouble { Located $$ (TokReserved "IDouble") } IString { Located $$ (TokReserved "IString") } Sint8 { Located $$ (TokReserved "Sint8") } Sint16 { Located $$ (TokReserved "Sint16") } Sint32 { Located $$ (TokReserved "Sint32") } Sint64 { Located $$ (TokReserved "Sint64") } Uint8 { Located $$ (TokReserved "Uint8") } Uint16 { Located $$ (TokReserved "Uint16") } Uint32 { Located $$ (TokReserved "Uint32") } Uint64 { Located $$ (TokReserved "Uint64") } Ix { Located $$ (TokReserved "Ix") } ix_t { Located $$ (TokReserved "ix_t") } Ref { Located $$ (TokReserved "Ref") } ConstRef { Located $$ (TokReserved "ConstRef") } Array { Located $$ (TokReserved "Array") } Struct { Located $$ (TokReserved "Struct") } Stored { Located $$ (TokReserved "Stored") } Stack { Located $$ (TokReserved "Stack") } Global { Located $$ (TokReserved "Global") } -- Keywords struct { Located $$ (TokReserved "struct") } abstract { Located $$ (TokReserved "abstract") } string { Located $$ (TokReserved "string") } ty { Located $$ (TokReserved "type") } include { Located $$ (TokReserved "include") } import { Located $$ (TokReserved "import") } extern { Located $$ (TokReserved "extern") } -- Bit data bitdata { Located $$ (TokReserved "bitdata") } Bit { Located $$ (TokReserved "Bit") } Bits { Located $$ (TokReserved "Bits") } BitArray { Located $$ (TokReserved "BitArray") } as { Located $$ (TokReserved "as") } '_' { Located $$ (TokSym "_") } '#' { Located $$ (TokSym "#") } -------------------------------------------------------------------------------- -- Precedence %right '#' %right '?' ':' %left '||' %left '&&' %left '|' '&' %left '^' %nonassoc '==' '!=' %nonassoc '<' '<=' '>' '>=' %left '<<' '>>' %left '+' '-' %left '*' '/' '%' %right '*' '~' '!' '-' -- '[' assumed to be followed by ']' %left '.' '@' '->' '[' ']' %right ADDR -- Tighter than normal binding %right abs signum expOp sqrt log pow sin cos tan asin acos atan sinh cosh tanh asinh acosh atanh isnan isinf round ceil floor const div %% ---------------------------------------- -- Top-level definitions defs :: { [GlobalSym] } defs : defs procDef { GlobalProc $2 : $1 } | defs includeProc { GlobalInclProc $2 : $1 } | defs importExtern { GlobalExtern $2 : $1 } | defs structDef { GlobalStruct $2 : $1 } | defs bdDef { GlobalBitData $2 : $1 } | defs typeDef { GlobalTypeDef $2 : $1 } | defs constDef { GlobalConstDef $2 : $1 } | defs includeDef { GlobalInclude $2 : $1 } | defs areaDef { GlobalArea $2 : $1 } | defs areaImportDef { GlobalAreaImport $2 : $1 } | {- empty -} { [] } ---------------------------------------- -- Include areas areaDef :: { AreaDef } areaDef : type allocRef { AreaDef False $1 (unLoc $2) (getLoc $2) } | type const allocRef { AreaDef True $1 (unLoc $3) (getLoc $3) } areaImportDef :: { AreaImportDef } areaImportDef : import header type allocIdent { AreaImportDef (unLoc $4) False $3 $2 (getLoc $1 <> getLoc $4) } | import header type const allocIdent { AreaImportDef (unLoc $5) True $3 $2 (getLoc $1 <> getLoc $5) } ---------------------------------------- -- header paths filepath :: { [String] } filepath : filepath ident '/' { (unLoc $2 ++ "/") : $1 } | {- empty -} { [] } header :: { String } header : filepath ident '.' ident { concat (reverse $1) ++ unLoc $2 ++ ('.' : unLoc $4) } ---------------------------------------- -- Include other modules (Ivory's "depend") includeDef :: { IncludeDef } includeDef : include ident { IncludeDef (unLoc $2) ($1 <> getLoc $2) } ---------------------------------------- -- Constant definitions constDef :: { ConstDef } constDef : ident '=' exp ';' { ConstDef (unLoc $1) $3 Nothing (getLoc $1 <> getLoc $3) } | type ident '=' exp ';' { ConstDef (unLoc $2) $4 (Just $1) (mconcat [ getLoc $1 , getLoc $2 , getLoc $4]) } ---------------------------------------- -- Procs -- Defined procedure procDef :: { ProcDef } procDef : type ident '(' args ')' '{' stmts '}' prePostBlk { ProcDef $1 (unLoc $2) (reverse $4) (reverse $7) $9 (mconcat [ getLoc $1 , getLoc $2 , getLoc $7 , getLoc $9 ]) } -- Externally-defined procedure includeProc :: { IncludeProc } includeProc : import '(' header ',' ident ')' type ident '(' args ')' { IncludeProc $7 (unLoc $8) (reverse $10) ($3, unLoc $5) (mconcat [ getLoc $1 , getLoc $5 , getLoc $8 ]) } -- Externally-defined symbols importExtern :: { Extern } importExtern : extern header type ident { Extern (unLoc $4) $2 $3 (mconcat [ getLoc $1, getLoc $4]) } tyArg :: { (Type, Var) } tyArg : type ident { ($1, unLoc $2) } -- Zero or more typed arguments, separated by arbitrary many ','s. args :: { [(Type, Var)] } args : args ',' tyArg { $3 : $1 } | args ',' { $1 } | tyArg { [$1] } | {- empty -} { [] } -- pre/post conditions prePostBlk :: { [PrePost] } prePostBlk : '{' prePosts '}' { reverse $2 } | {- empty -} { [] } prePosts :: { [PrePost] } prePosts : prePosts prePost ';' { $2 : $1 } | prePost ';' { [$1] } prePost :: { PrePost } prePost : pre '(' exp ')' { PreCond $3 } | post '(' exp ')' { PostCond $3 } ---------------------------------------- -- Allocations ptrIdent :: { Located RefVar } ptrIdent : '*' ident { $2 } arrIdent :: { Located RefVar } arrIdent : ident '[' ']' { $1 } structIdent :: { Located RefVar } structIdent : ident '{' '}' { $1 } allocIdent :: { Located RefVar } allocIdent : ptrIdent { $1 } | arrIdent { $1 } | structIdent {$1 } allocRef :: { Located AllocRef } allocRef : alloc ptrIdent ';' { atBin (AllocBase (unLoc $2) Nothing) $1 $3 } | alloc ptrIdent '=' exp ';' { atList (AllocBase (unLoc $2) (Just $4)) [$1, getLoc $2, getLoc $4] } | alloc arrIdent ';' { atBin (AllocArr (unLoc $2) []) $1 $2 } | alloc arrIdent '=' '{' exps '}' ';' { atList (AllocArr (unLoc $2) (reverse $5)) [ $1, getLoc $2, getLoc $5] } | alloc structIdent ';' { atBin (AllocStruct (unLoc $2) Empty) $1 $2 } | alloc structIdent '=' structInit ';' { atBin (AllocStruct (unLoc $2) $4) $1 $2 } ---------------------------------------- -- Statements simpleStmt :: { Stmt } simpleStmt : assert exp ';' { LocStmt (atBin (Assert $2) $1 $2) } | assume exp ';' { LocStmt (atBin (Assume $2) $1 $2) } | assign ident '=' exp ';' { LocStmt (atList (Assign (unLoc $2) $4 Nothing) [ $1, getLoc $2, getLoc $4 ]) } | assign type ident '=' exp ';' { LocStmt (atList (Assign (unLoc $3) $5 (Just $2)) [ $1, getLoc $2, getLoc $3, getLoc $5]) } | return ';' { LocStmt (ReturnVoid `at` $1) } | return exp ';' { LocStmt (atBin (Return $2) $1 $2) } | refCopy ident ident ';' { LocStmt (atList (RefCopy (ExpVar (unLoc $2)) (ExpVar (unLoc $3))) [$1, getLoc $2, getLoc $3]) } | allocRef { LocStmt (AllocRef (unLoc $1) `at` (getLoc $1)) } -- Storing | store exp as exp ';' { LocStmt (atList (Store $2 $4) [$1, getLoc $2, getLoc $4]) } -- Function calls | ident expArgs ';' { LocStmt (atBin (NoBindCall (unLoc $1) $2) $1 $2) } | ivoryMacro ';' { LocStmt ((IvoryMacroStmt Nothing (unLoc $1)) `at` getLoc $1) } | ident '<-' ivoryMacro ';' { LocStmt (atBin (IvoryMacroStmt (Just (unLoc $1)) (unLoc $3)) $1 $3) } | break ';' { LocStmt (Break `at` $1) } ivoryMacro :: { Located (String, [Exp]) } ivoryMacro : iMacro ident { atBin (unLoc $2, []) $1 (getLoc $2) } | iMacro ident expArgs { atList (unLoc $2, $3) [$1, getLoc $2, getLoc $3] } blkStmt :: { Stmt } blkStmt : mapArr ident '{' stmts '}' { LocStmt (atList (MapArr (unLoc $2) (reverse $4)) [$1, getLoc $2, getLoc $4]) } | upTo exp ident '{' stmts '}' { LocStmt (atList (UpTo $2 (unLoc $3) (reverse $5)) [$1, getLoc $2, getLoc $3, getLoc $5]) } | downFrom exp ident '{' stmts '}' { LocStmt (atList (DownFrom $2 (unLoc $3) (reverse $5)) [$1, getLoc $2, getLoc $3, getLoc $5]) } | upFromTo '(' exp ',' exp ')' ident '{' stmts '}' { LocStmt (atList (UpFromTo $3 $5 (unLoc $7) (reverse $9)) [$1, getLoc $3, getLoc $5, getLoc $7, getLoc $9]) } | downFromTo '(' exp ',' exp ')' ident '{' stmts '}' { LocStmt (atList (DownFromTo $3 $5 (unLoc $7) (reverse $9)) [$1, getLoc $3, getLoc $5, getLoc $7, getLoc $9]) } | forever '{' stmts '}' { LocStmt (atBin (Forever (reverse $3)) $1 $2) } | if exp '{' stmts '}' else '{' stmts '}' { LocStmt (atList (IfTE $2 (reverse $4) (reverse $8)) [ getLoc $2, getLoc $4, getLoc $8 ]) } -- Zero or more statements. stmts :: { [Stmt] } stmts : stmts simpleStmt { $2 : $1 } | stmts blkStmt { $2 : $1 } | {- empty -} { [] } expArgs :: { [Exp] } expArgs : '(' exps ')' { reverse $2 } -- Zero or more expressions, separated by arbitrary many ','s. exps :: { [Exp] } exps : exps ',' exp { $3 : $1 } | exps ',' { $1 } | exp { [$1] } | {- empty -} { [] } structInit :: { StructInit } structInit : ivoryMacro { MacroInit (unLoc $1) } | '{' fieldAssigns '}' { FieldInits $2 } fieldAssigns :: { [(FieldNm, Exp)] } fieldAssigns : fieldAssigns ',' fieldAssign { $3 : $1 } | fieldAssigns ',' { $1 } | fieldAssign { [$1] } | {- empty -} { [] } fieldAssign :: { (FieldNm, Exp) } fieldAssign : ident '=' exp { (unLoc $1, $3) } ---------------------------------------- -- Expressions exp :: { Exp } exp : integer { let TokInteger i = unLoc $1 in LocExp (ExpLit (LitInteger i) `at` $1) } | str { let TokString s = unLoc $1 in LocExp (ExpLit (LitString s) `at` $1) } | floatlit { let TokFloat f = unLoc $1 in LocExp (ExpLit (LitFloat f) `at` $1) } -- Works for Haskell values, too! | ident { LocExp ((ExpVar (unLoc $1)) `at` $1) } -- Used only in post-conditions (otherwise, it's a statement). | return { LocExp (ExpRet `at` $1) } | '(' exp ')' { $2 } -- Areas | '*' exp { LocExp (atBin (ExpDeref $2) $1 $2) } | exp '@' exp { LocExp (atBin (ExpArray $1 $3) $1 $3) } | exp '[' exp ']' { LocExp (atBin (ExpDeref (ExpArray $1 $3)) $1 $3) } | exp '.' exp { LocExp (atBin (ExpStruct $1 $3) $1 $3) } | exp '->' exp { LocExp (atBin (ExpDeref (ExpStruct $1 $3)) $1 $3) } | '&' ident { LocExp (atBin (ExpAddrOf (unLoc $2)) $1 $2) } | libFuncExp { $1 } -- Ivory expression macros | ivoryMacro { LocExp (IvoryMacroExp `fmap` $1) } -- Function calls | ident expArgs { LocExp (atBin (ExpCall (unLoc $1) $2) $1 $2) } -- Unary operators | '!' exp { LocExp (atBin (ExpOp NotOp [$2]) $1 $2) } | '-' exp { LocExp (atBin (mkNegate $2) $1 $2) } | '~' exp { LocExp (atBin (ExpOp BitComplementOp [$2]) $1 $2) } -- Binary operators | exp '||' exp { LocExp (atBin (ExpOp OrOp [$1, $3]) $1 $3) } | exp '&&' exp { LocExp (atBin (ExpOp AndOp [$1, $3]) $1 $3) } | exp '|' exp { LocExp (atBin (ExpOp BitOrOp [$1, $3]) $1 $3) } | exp '^' exp { LocExp (atBin (ExpOp BitXorOp [$1, $3]) $1 $3) } | exp '&' exp { LocExp (atBin (ExpOp BitAndOp [$1, $3]) $1 $3) } | exp '<<' exp { LocExp (atBin (ExpOp BitShiftLOp [$1, $3]) $1 $3) } | exp '>>' exp { LocExp (atBin (ExpOp BitShiftROp [$1, $3]) $1 $3) } | exp '==' exp { LocExp (atBin (ExpOp EqOp [$1, $3]) $1 $3) } | exp '!=' exp { LocExp (atBin (ExpOp NeqOp [$1, $3]) $1 $3) } | exp '<' exp { LocExp (atBin (ExpOp (LtOp False) [$1, $3]) $1 $3) } | exp '<=' exp { LocExp (atBin (ExpOp (LtOp True) [$1, $3] ) $1 $3)} | exp '>' exp { LocExp (atBin (ExpOp (GtOp False) [$1, $3]) $1 $3) } | exp '>=' exp { LocExp (atBin (ExpOp (GtOp True) [$1, $3] ) $1 $3)} | exp '+' exp { LocExp (atBin (ExpOp AddOp [$1, $3]) $1 $3) } | exp '-' exp { LocExp (atBin (ExpOp SubOp [$1, $3]) $1 $3) } | exp '*' exp { LocExp (atBin (ExpOp MulOp [$1, $3]) $1 $3) } | exp '/' exp { LocExp (atBin (ExpOp DivOp [$1, $3]) $1 $3) } | exp '%' exp { LocExp (atBin (ExpOp ModOp [$1, $3]) $1 $3) } -- Tertiary operators | exp '?' exp ':' exp { LocExp ((ExpOp CondOp [$1, $3, $5]) `at` (getLoc [$1, $3, $5])) } libFuncExp :: { Exp } libFuncExp : abs expArgs { LocExp (atBin (ExpOp AbsOp $2) $1 $2) } | signum expArgs { LocExp (atBin (ExpOp SignumOp $2) $1 $2) } | expOp expArgs { LocExp (atBin (ExpOp FExpOp $2) $1 $2) } | sqrt expArgs { LocExp (atBin (ExpOp FSqrtOp $2) $1 $2) } | log expArgs { LocExp (atBin (ExpOp FLogOp $2) $1 $2) } | pow expArgs { LocExp (atBin (ExpOp FPowOp $2) $1 $2) } | sin expArgs { LocExp (atBin (ExpOp FSinOp $2) $1 $2) } | cos expArgs { LocExp (atBin (ExpOp FCosOp $2) $1 $2) } | tan expArgs { LocExp (atBin (ExpOp FTanOp $2) $1 $2) } | asin expArgs { LocExp (atBin (ExpOp FAsinOp $2) $1 $2) } | acos expArgs { LocExp (atBin (ExpOp FAcosOp $2) $1 $2) } | atan expArgs { LocExp (atBin (ExpOp FAtanOp $2) $1 $2) } | atan2 expArgs { LocExp (atBin (ExpOp FAtan2Op $2) $1 $2) } | sinh expArgs { LocExp (atBin (ExpOp FSinhOp $2) $1 $2) } | cosh expArgs { LocExp (atBin (ExpOp FCoshOp $2) $1 $2) } | tanh expArgs { LocExp (atBin (ExpOp FTanhOp $2) $1 $2) } | asinh expArgs { LocExp (atBin (ExpOp FAsinhOp $2) $1 $2) } | acosh expArgs { LocExp (atBin (ExpOp FAcoshOp $2) $1 $2) } | atanh expArgs { LocExp (atBin (ExpOp FAtanhOp $2) $1 $2) } | isnan expArgs { LocExp (atBin (ExpOp IsNanOp $2) $1 $2) } | isinf expArgs { LocExp (atBin (ExpOp IsInfOp $2) $1 $2) } | round expArgs { LocExp (atBin (ExpOp RoundFOp $2) $1 $2) } | ceil expArgs { LocExp (atBin (ExpOp CeilFOp $2) $1 $2) } | floor expArgs { LocExp (atBin (ExpOp FloorFOp $2) $1 $2) } | const expArgs { LocExp (atBin (ExpOp ConstRefOp $2) $1 $2) } | div expArgs { LocExp (atBin (ExpOp EucDivOp $2) $1 $2) } | castWith expArgs { LocExp (atBin (ExpOp CastWith $2) $1 $2) } | safeCast expArgs { LocExp (atBin (ExpOp SafeCast $2) $1 $2) } | bitCast expArgs { LocExp (atBin (ExpOp BitCast $2) $1 $2) } | twosCompCast expArgs { LocExp (atBin (ExpOp TwosCompCast $2) $1 $2) } | twosCompRep expArgs { LocExp (atBin (ExpOp TwosCompRep $2) $1 $2) } | toIx expArgs { LocExp (atBin (ExpOp ToIx $2) $1 $2) } | fromIx expArgs { LocExp (atBin (ExpOp FromIx $2) $1 $2) } | ixSize expArgs { LocExp (atBin (ExpOp IxSize $2) $1 $2) } | arrayLen expArgs { LocExp (atBin (ExpOp ArrayLen $2) $1 $2) } | sizeOf expArgs { LocExp (atBin (ExpOp SizeOf $2) $1 $2) } | nullPtr expArgs { LocExp (atBin (ExpOp NullPtr $2) $1 $2) } | refToPtr expArgs { LocExp (atBin (ExpOp RefToPtr $2) $1 $2) } | toCArray expArgs { LocExp (atBin (ExpOp ToCArray $2) $1 $2) } ---------------------------------------- -- Types typeDef :: { TypeDef } typeDef : ty tyident '=' type ';' { TypeDef (unLoc $2) $4 (mconcat [$1, getLoc $2, getLoc $4]) } type :: { Type } type : baseType { $1 } | cType { $1 } | '(' type ')' { $2 } baseType :: { Type } baseType : simpleCType { $1 } | tyident { LocTy (TySynonym (unLoc $1) `at` $1) } -- C-style types simpleCType :: { Type } simpleCType : bool { LocTy (TyBool `at` getLoc $1) } | char { LocTy (TyChar `at` getLoc $1) } | float { LocTy (TyFloat `at` getLoc $1) } | double { LocTy (TyDouble `at` getLoc $1) } | string { LocTy (TyString `at` getLoc $1) } | void { LocTy (TyVoid `at` getLoc $1) } | int8_t { LocTy ((TyInt Int8) `at` getLoc $1) } | int16_t { LocTy ((TyInt Int16) `at` getLoc $1) } | int32_t { LocTy ((TyInt Int32) `at` getLoc $1) } | int64_t { LocTy ((TyInt Int64) `at` getLoc $1) } | uint8_t { LocTy ((TyWord Word8) `at` getLoc $1) } | uint16_t { LocTy ((TyWord Word16) `at` getLoc $1) } | uint32_t { LocTy ((TyWord Word32) `at` getLoc $1) } | uint64_t { LocTy ((TyWord Word64) `at` getLoc $1) } | ix_t integer { let TokInteger i = unLoc $2 in LocTy (atBin (TyIx i) $1 $2) } idxs :: { [SzType] } idxs : idxs '[' szType ']' { unLoc $3 : $1 } | {- empty -} { [] } szType :: { Located SzType } szType : iMacro tyidentifier { let TokTyIdent i = unLoc $2 in Left i `at` $2 } | integer { let TokInteger i = unLoc $1 in Right i `at` $1 } cType :: { Type } cType : scopeC '*' type { LocTy (atBin (TyRef (unLoc $1) $3) $1 $3) } | const scopeC '*' type { LocTy (atList (TyConstRef (unLoc $2) $4) [$1, getLoc $2, getLoc $4]) } | baseType '[' szType ']' idxs { LocTy (atBin (tyArray $1 (unLoc $3) $5) $1 $3) } | struct structName { LocTy (atBin (TyStruct (unLoc $2)) $1 $2) } | '&' type %prec ADDR { LocTy (atBin (TyStored $2) $1 $2) } scopeC :: { Located Scope } scopeC : S { Stack Nothing `at` $1 } | G { Global `at` $1 } | ident { PolyMem (Just (unLoc $1)) `at` (getLoc $1) } | {- empty -} { PolyMem Nothing `at` NoLoc } typeHS :: { Type } typeHS : simpleHSType { $1 } | hsType { $1 } | tyident { LocTy (TySynonym (unLoc $1) `at` $1) } | '(' typeHS ')' { $2 } -- Haskell-style types simpleHSType :: { Type } simpleHSType : IBool { LocTy (TyBool `at` getLoc $1) } | IChar { LocTy (TyChar `at` getLoc $1) } | IFloat { LocTy (TyFloat `at` getLoc $1) } | IDouble { LocTy (TyDouble `at` getLoc $1) } | IString { LocTy (TyString `at` getLoc $1) } | '(' ')' { LocTy (TyVoid `at` getLoc $1) } | Sint8 { LocTy ((TyInt Int8) `at` getLoc $1) } | Sint16 { LocTy ((TyInt Int16) `at` getLoc $1) } | Sint32 { LocTy ((TyInt Int32)`at` getLoc $1) } | Sint64 { LocTy ((TyInt Int64) `at` getLoc $1) } | Uint8 { LocTy ((TyWord Word8) `at` getLoc $1) } | Uint16 { LocTy ((TyWord Word16) `at` getLoc $1) } | Uint32 { LocTy ((TyWord Word32) `at` getLoc $1) } | Uint64 { LocTy ((TyWord Word64) `at` getLoc $1) } | Ix integer { let TokInteger i = unLoc $2 in LocTy (atBin (TyIx i) $1 $2) } hsType :: { Type } hsType : Ref scopeHS typeHS { LocTy (atList (TyRef (unLoc $2) $3) [ getLoc $1 , getLoc $2 , getLoc $3 ]) } | ConstRef scopeHS typeHS { LocTy (atList (TyConstRef (unLoc $2) $3) [ getLoc $1 , getLoc $2 , getLoc $3 ]) } | Array szType typeHS { LocTy (atList (TyArray $3 (unLoc $2)) [ getLoc $1, getLoc $2, getLoc $3]) } | Struct structName { LocTy (atBin (TyStruct (unLoc $2)) $1 $2) } | Stored typeHS { LocTy (atBin (TyStored $2) $1 $2) } scopeHS :: { Located Scope } scopeHS : Stack tyident { atBin (Stack (Just (unLoc $2))) $1 $2 } | Global { Global `at` $1 } -- Bit types bitType :: { BitTy } bitType : Bit { LocBitTy (Bit `at` $1) } | Bits integer { let TokInteger i = unLoc $2 in LocBitTy (atBin (Bits i) $1 $2) } | BitArray integer bitType { let TokInteger i = unLoc $2 in LocBitTy (atList (BitArray i $3) [ getLoc $1 , getLoc $2 , getLoc $3 ]) } | '(' bitType ')' { $2 } | tyident { LocBitTy (BitTySynonym `fmap` $1) } ---------------------------------------- -- Struct definitions structDef :: { StructDef } structDef : struct structName '{' fields '}' { StructDef (unLoc $2) (reverse $4) (getLoc $2) } -- Remove parsed quotes first | abstract struct structName str { let TokString f = unLoc $4 in AbstractDef (unLoc $3) (filter (/= '\"') f) (getLoc $3) } | string struct structName integer { let TokInteger i = unLoc $4 in StringDef (unLoc $3) i (getLoc $3) } structName :: { Located String } structName : tyident { $1 } | ident { $1 } field :: { Field } field : -- Haskell style ident '::' typeHS { Field (unLoc $1) $3 (getLoc $1 <> getLoc $3) } -- C style | type ident { Field (unLoc $2) $1 (getLoc $1 <> getLoc $2)} -- 1 or more fields, separated (but optionally ending with) ';'. fields :: { [Field] } fields : fields ';' field { $3 : $1 } | fields ';' { $1 } | field { [$1] } -------------------------------------------------------------------------------- -- Bit data -- Bitdata definition bdDef :: { BitDataDef } bdDef : bitdata tyident '::' bitType '=' bdConstrs { BitDataDef (unLoc $2) $4 (reverse $6) (mconcat [ getLoc $1, getLoc $2, getLoc $3, getLoc $6 ]) } -- One or more bitdata constructors, separated by '|' bdConstrs :: { [Constr] } bdConstrs : bdConstrs '|' bdConstr { $3 : $1 } | bdConstr { [$1] } bdConstr :: { Constr } bdConstr : ident bdRecord bdLayout { Constr (unLoc $1) $2 $3 (mconcat [ getLoc $1, getLoc $2 ]) } -- Zero or more fields. bdRecord :: { [BitField] } bdRecord : '{' bdFields '}' { reverse $2 } | {- empty -} { [] } bdFields :: { [BitField] } bdFields : bdFields ',' bdField { $3 : $1 } | bdField { [$1] } bdField :: { BitField } bdField : ident '::' bitType { BitField (Just (unLoc $1)) $3 (getLoc $1 <> getLoc $3) } | '_' '::' bitType { BitField Nothing $3 ($1 <> getLoc $3) } bdLayout :: { [LayoutItem] } bdLayout : as bdItems { reverse $2 } | {- empty -} { [] } -- One or more items, separated by # bdItems :: { [LayoutItem] } bdItems : bdItems '#' bdItem { $3 : $1 } | bdItem { [$1] } bdItem :: { LayoutItem } bdItem : ident { LayoutField (unLoc $1) } | integer { let TokInteger i = unLoc $1 in LayoutConst (BitLitUnknown i) } | bitLiteral { LayoutConst $1 } -- Parse n-bit natural, e.g., -- -- 8b0 -- 8 0-bits -- -- 2b01 -- 01 -- First field is width, second is "b[0,1]+" bitLiteral :: { BitLiteral } bitLiteral : bitlit { let TokBitLit bl = unLoc $1 in BitLitKnown (fst bl) (snd bl) } -------------------------------------------------------------------------------- -- Namespaces ident :: { Located String } ident : identifier { let TokIdent i = unLoc $1 in i `at` $1 } | tyidentifier '.' identifier { let TokTyIdent t = unLoc $1 in let TokIdent i = unLoc $3 in atBin (t ++ '.':i) $1 $3 } tyident :: { Located String } tyident : tyidentifier { let TokTyIdent t = unLoc $1 in t `at` $1 } | tyidentifier '.' tyidentifier { let TokTyIdent t0 = unLoc $1 in let TokTyIdent t1 = unLoc $3 in atBin (t0 ++ '.':t1) $1 $3 } -------------------------------------------------------------------------------- { mkNegate :: Exp -> Exp mkNegate e = go e where go (ExpLit l) = case l of LitInteger i -> ExpLit (LitInteger (-i)) LitFloat f -> ExpLit (LitFloat (-f)) _ -> ExpOp NegateOp [e] go (LocExp x) = go (locValue x) go _ = ExpOp NegateOp [e] }