Commit a4005d2d authored by Duncan Coutts's avatar Duncan Coutts

Lexing and parsing for "foreign import prim"

We only allow simple function label imports, not the normal complicated
business with "wrapper" "dynamic" or data label "&var" imports.
parent 71aa4a47
...@@ -484,6 +484,7 @@ data Token ...@@ -484,6 +484,7 @@ data Token
| ITunsafe | ITunsafe
| ITstdcallconv | ITstdcallconv
| ITccallconv | ITccallconv
| ITprimcallconv
| ITdotnet | ITdotnet
| ITmdo | ITmdo
| ITfamily | ITfamily
...@@ -631,6 +632,7 @@ isSpecial ITthreadsafe = True ...@@ -631,6 +632,7 @@ isSpecial ITthreadsafe = True
isSpecial ITunsafe = True isSpecial ITunsafe = True
isSpecial ITccallconv = True isSpecial ITccallconv = True
isSpecial ITstdcallconv = True isSpecial ITstdcallconv = True
isSpecial ITprimcallconv = True
isSpecial ITmdo = True isSpecial ITmdo = True
isSpecial ITfamily = True isSpecial ITfamily = True
isSpecial ITgroup = True isSpecial ITgroup = True
...@@ -692,6 +694,7 @@ reservedWordsFM = listToUFM $ ...@@ -692,6 +694,7 @@ reservedWordsFM = listToUFM $
( "unsafe", ITunsafe, bit ffiBit), ( "unsafe", ITunsafe, bit ffiBit),
( "stdcall", ITstdcallconv, bit ffiBit), ( "stdcall", ITstdcallconv, bit ffiBit),
( "ccall", ITccallconv, bit ffiBit), ( "ccall", ITccallconv, bit ffiBit),
( "prim", ITprimcallconv, bit ffiBit),
( "dotnet", ITdotnet, bit ffiBit), ( "dotnet", ITdotnet, bit ffiBit),
( "rec", ITrec, bit arrowsBit), ( "rec", ITrec, bit arrowsBit),
......
...@@ -246,6 +246,7 @@ incorrect. ...@@ -246,6 +246,7 @@ incorrect.
'family' { L _ ITfamily } 'family' { L _ ITfamily }
'stdcall' { L _ ITstdcallconv } 'stdcall' { L _ ITstdcallconv }
'ccall' { L _ ITccallconv } 'ccall' { L _ ITccallconv }
'prim' { L _ ITprimcallconv }
'dotnet' { L _ ITdotnet } 'dotnet' { L _ ITdotnet }
'proc' { L _ ITproc } -- for arrow notation extension 'proc' { L _ ITproc } -- for arrow notation extension
'rec' { L _ ITrec } -- for arrow notation extension 'rec' { L _ ITrec } -- for arrow notation extension
...@@ -952,6 +953,7 @@ fdecl : 'import' callconv safety fspec ...@@ -952,6 +953,7 @@ fdecl : 'import' callconv safety fspec
callconv :: { CallConv } callconv :: { CallConv }
: 'stdcall' { CCall StdCallConv } : 'stdcall' { CCall StdCallConv }
| 'ccall' { CCall CCallConv } | 'ccall' { CCall CCallConv }
| 'prim' { CCall PrimCallConv}
| 'dotnet' { DNCall } | 'dotnet' { DNCall }
safety :: { Safety } safety :: { Safety }
...@@ -1902,6 +1904,7 @@ special_id ...@@ -1902,6 +1904,7 @@ special_id
| 'dynamic' { L1 (fsLit "dynamic") } | 'dynamic' { L1 (fsLit "dynamic") }
| 'stdcall' { L1 (fsLit "stdcall") } | 'stdcall' { L1 (fsLit "stdcall") }
| 'ccall' { L1 (fsLit "ccall") } | 'ccall' { L1 (fsLit "ccall") }
| 'prim' { L1 (fsLit "prim") }
special_sym :: { Located FastString } special_sym :: { Located FastString }
special_sym : '!' { L1 (fsLit "!") } special_sym : '!' { L1 (fsLit "!") }
......
...@@ -64,7 +64,7 @@ import BasicTypes ( maxPrecedence, Activation, RuleMatchInfo, ...@@ -64,7 +64,7 @@ import BasicTypes ( maxPrecedence, Activation, RuleMatchInfo,
alwaysInlineSpec, neverInlineSpec ) alwaysInlineSpec, neverInlineSpec )
import Lexer ( P, failSpanMsgP, extension, standaloneDerivingEnabled, bangPatEnabled ) import Lexer ( P, failSpanMsgP, extension, standaloneDerivingEnabled, bangPatEnabled )
import TysWiredIn ( unitTyCon ) import TysWiredIn ( unitTyCon )
import ForeignCall ( CCallConv, Safety, CCallTarget(..), CExportSpec(..), import ForeignCall ( CCallConv(..), Safety, CCallTarget(..), CExportSpec(..),
DNCallSpec(..), DNKind(..), CLabelString ) DNCallSpec(..), DNKind(..), CLabelString )
import OccName ( srcDataName, varName, isDataOcc, isTcOcc, import OccName ( srcDataName, varName, isDataOcc, isTcOcc,
occNameString ) occNameString )
...@@ -957,6 +957,11 @@ mkImport :: CallConv ...@@ -957,6 +957,11 @@ mkImport :: CallConv
-> Safety -> Safety
-> (Located FastString, Located RdrName, LHsType RdrName) -> (Located FastString, Located RdrName, LHsType RdrName)
-> P (HsDecl RdrName) -> P (HsDecl RdrName)
mkImport (CCall cconv) safety (entity, v, ty)
| cconv == PrimCallConv = do
let funcTarget = CFunction (StaticTarget (unLoc entity))
importSpec = CImport PrimCallConv safety nilFS nilFS funcTarget
return (ForD (ForeignImport v ty importSpec))
mkImport (CCall cconv) safety (entity, v, ty) = do mkImport (CCall cconv) safety (entity, v, ty) = do
importSpec <- parseCImport entity cconv safety v importSpec <- parseCImport entity cconv safety v
return (ForD (ForeignImport v ty importSpec)) return (ForD (ForeignImport v ty importSpec))
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment