[Infrastructure to support more kinds of foreign declarations
Einar Karttunen <ekarttun@cs.helsinki.fi>**20060226100932] hunk ./E/FromHs.hs 25
-import C.Prims
+import C.Prims as CP
hunk ./E/FromHs.hs 44
-import HsSyn
+import HsSyn as HS
hunk ./E/FromHs.hs 327
-    cDecl (HsForeignDecl _ ForeignPrimitive s n _) = [(name,var, lamt (foldr ($) (EPrim (primPrim s) (map EVar es) rt) (map ELam es)))]  where
-        name = toName Name.Val n
-        var = tVr (nameToInt name) ty
+    cDecl (HsForeignDecl _ i@(Import {}) HS.Primitive _ n _) = result where 
+        result    = expr $ foldr ($) (EPrim (toPrim i) (map EVar es) rt) (map ELam es)
+        expr x    = [(name,var,lamt x)]
+        name      = toName Name.Val n
+        var       = tVr (nameToInt name) ty
hunk ./E/FromHs.hs 333
-        (ts,rt) = argTypes' ty
-        es = [ (tVr ( n) t) |  t <- ts, not (sortStarLike t) | n <- localVars ]
-    cDecl (HsForeignDecl _ ForeignCCall s n _)
-        | Func _ s _ _ <- p, not isIO =  expr $ createFunc dataTable [4,6..] (map tvrType es) $ \rs -> (,) id $ eStrictLet rtVar' (EPrim (APrim (Func False s (snds rs) rtt) req) [ EVar t | (t,_) <- rs ] rtt') (ELit $ LitCons cn [EVar rtVar'] rt')
-        | Func _ s _ _ <- p, "void" <- toExtType rt' =
-                expr $ (createFunc dataTable [4,6..] (map tvrType es) $ \rs -> (,) (ELam tvrCont . ELam tvrWorld) $
-                    eStrictLet tvrWorld2 (EPrim (APrim (Func True s (snds rs) "void") req) (EVar tvrWorld:[EVar t | (t,_) <- rs ]) tWorld__) (eJustIO (EVar tvrWorld2) vUnit))
-        | Func _ s _ _ <- p =
-                expr $ (createFunc dataTable [4,6..] (map tvrType es) $ \rs -> (,) (ELam tvrCont . ELam tvrWorld) $
-                    eCaseTup' (EPrim (APrim (Func True s (snds rs) rtt) req) (EVar tvrWorld:[EVar t | (t,_) <- rs ]) rttIO')  [tvrWorld2,rtVar'] (eLet rtVar (ELit $ LitCons cn [EVar rtVar'] rt') (eJustIO (EVar tvrWorld2) (EVar rtVar))))
-        | AddrOf _ <- p = let
-            (cn,st,ct) = runIdentity (lookupCType' dataTable rt)
-            (var:_) = freeNames (freeVars rt)
-            vr = tVr var st
-          in expr $ eStrictLet vr (EPrim (APrim p req) [] st) (ELit (LitCons cn [EVar vr] rt))
-        where
+        (ts,rt)   = argTypes' ty
+        es        = [ (tVr ( n) t) |  t <- ts, not (sortStarLike t) | n <- localVars ]
+        toPrim (Import cn is ls) = APrim (PrimPrim cn) (Requires is ls)
+    cDecl (HsForeignDecl _ i@HS.AddrOf {} _ _ n _) = result where
+        (cn,st,ct) = runIdentity (lookupCType' dataTable rt)
+        (ty,lamt)  = pval name
+        (ts,rt)    = argTypes' ty
+        name       = toName Name.Val n
+        hvar       = head $ freeNames $ freeVars rt
+        var        = tVr hvar st
+        expr x     = [(name,var,lamt x)]
+        prim       = APrim (CP.AddrOf cn) (Requires is ls) where HS.AddrOf cn is ls = i
+        result     = expr $ eStrictLet var (EPrim prim [] st) (ELit (LitCons cn [EVar var] rt))
+    cDecl (HsForeignDecl _ i@Import {} HS.CCall _ n _) = result where
hunk ./E/FromHs.hs 348
-        Just (APrim p req) = parsePrimString s
hunk ./E/FromHs.hs 367
+        prim io rs rtt = EPrim (APrim (Func io s (snds rs) rtt) (Requires is ls))
+            where Import s is ls = i
+        cFun    = expr . createFunc dataTable [4,6 ..] (map tvrType es)
+        result | not isIO =
+            cFun $ \rs -> (,) id $ eStrictLet rtVar' (prim False rs rtt [ EVar t | (t,_) <- rs ] rtt') (ELit $ LitCons cn [EVar rtVar'] rt')
+               | "void" <- toExtType rt' =
+            cFun $ \rs -> (,) (ELam tvrCont . ELam tvrWorld) $
+                    eStrictLet tvrWorld2 (prim True rs "void" (EVar tvrWorld:[EVar t | (t,_) <- rs ]) tWorld__) (eJustIO (EVar tvrWorld2) vUnit)
+                                                                                                                | otherwise =
+             cFun $ \rs -> (,) (ELam tvrCont . ELam tvrWorld) $
+                    eCaseTup' (prim True rs rtt (EVar tvrWorld:[EVar t | (t,_) <- rs ]) rttIO')  [tvrWorld2,rtVar'] (eLet rtVar (ELit $ LitCons cn [EVar rtVar'] rt') (eJustIO (EVar tvrWorld2) (EVar rtVar)))
+
+    cDecl x@HsForeignDecl {} = fail ("Unsupported foreign declaration: "++ show x)
+
hunk ./FrontEnd/Desugar.hs 203
-desugarDecl (HsForeignDecl sl ft s n qt) = do
-    qt' <- remSynsQualType qt
-    return [HsForeignDecl sl ft s n qt']
+desugarDecl (HsForeignDecl a b c d e qt) = do
+    qt <- remSynsQualType qt
+    return [HsForeignDecl a b c d e qt]
hunk ./FrontEnd/HsParser.ly 103
+>       'export'        { KW_Export }
hunk ./FrontEnd/HsParser.ly 121
+>       'safe'          { KW_Safe }
+>       'unsafe'        { KW_Unsafe }
+>       'ccall'         { KW_CCall }
+>       'stdcall'       { KW_Stdcall }
+>       'primitive'     { KW_Primitive }
hunk ./FrontEnd/HsParser.ly 290
->	| srcloc 'foreign' 'import' cconv STRING var '::' ctype
->			{ HsForeignDecl $1 $4 $5 $6 $8}
->	| srcloc 'foreign' 'import' cconv var '::' ctype
->			{ HsForeignDecl $1 $4 (show $5) $5 $7}
+>       | 'foreign' srcloc 'export' mcconv mstring var '::' ctype
+>                       {% parseExport $5 $6 >>= \x ->
+>                          return (HsForeignDecl $2 x $4 Safe $6 $8) }
+>       | 'foreign' srcloc 'import' 'primitive' mstring var '::' ctype
+>                       { let i = Import (if null $5 then show $6 else $5) [] []
+>                         in HsForeignDecl $2 i Primitive Safe $6 $8 }
+>       | 'foreign' srcloc 'import' mcconv msafety mstring var '::' ctype
+>                       {% parseImport $6 $7 >>= \x ->
+>                          return (HsForeignDecl $2 x $4 $5 $7 $9) }
+
+
hunk ./FrontEnd/HsParser.ly 315
-> cconv :: { ForeignType }
->        : varid  { if show $1 == "primitive" then ForeignPrimitive else ForeignCCall }
-
hunk ./FrontEnd/HsParser.ly 357
+FFI parts
+
+> mcconv :: { CallConv }
+> mcconv : 'ccall'        { CCall }
+>        | 'stdcall'      { StdCall }
+>        | {- empty -}    { CCall }
+>
+> msafety :: { Safety }
+> msafety : 'safe'        { Safe }
+>         | 'unsafe'      { Unsafe }
+>         | {- empty -}   { Safe }
+>
+> mstring :: { String }
+> mstring : STRING         { $1 }
+>         | {- empty -}    { "" }
+
hunk ./FrontEnd/HsPretty.hs 262
-ppHsDecl fd@(HsForeignDecl _ _ s n qt) = text "ForeignDecl" <+> ppHsName n <+> ppHsQualType qt <+> text (show fd)
+ppHsDecl fd@(HsForeignDecl _ _ _ _ n qt) = text "ForeignDecl" <+> ppHsName n <+> ppHsQualType qt <+> text (show fd)
hunk ./FrontEnd/HsSyn.hs 34
-data ForeignType = ForeignPrimitive | ForeignCCall
-    deriving(Data,Typeable, Eq, Ord, Show)
+-- Foreign Declarations
+
+data Safety = Safe | Unsafe deriving(Data,Eq,Ord,Show,Typeable)
+data CallConv = CCall | StdCall | Primitive deriving(Data,Eq,Ord,Show,Typeable)
+type Includes = [String]
+type Libs     = [String]
+type CName    = String
+
+data HsForeignT = AddrOf CName Libs Includes
+                | Dynamic
+                | Export CName
+                | Import CName Libs Includes
+                | Wrapper
+                  deriving(Data,Eq,Ord,Show,Typeable)
+
+-- Names
hunk ./FrontEnd/HsSyn.hs 146
+    srcLoc HsForeignDecl { hsDeclSrcLoc = sl } = sl
hunk ./FrontEnd/HsSyn.hs 153
-    srcLoc (HsForeignDecl sl _ _ _ _) = sl
hunk ./FrontEnd/HsSyn.hs 167
-	 | HsForeignDecl SrcLoc ForeignType String HsName HsQualType
+         | HsForeignDecl { hsDeclSrcLoc   :: SrcLoc,
+                           hsDeclForeign  :: HsForeignT,
+                           hsDeclCallConv :: CallConv,
+                           hsDeclSafety   :: Safety,
+                           hsDeclName     :: HsName,
+                           hsDeclQualType :: HsQualType
+                         }
hunk ./FrontEnd/Lexer.hs 90
+        | KW_Export
hunk ./FrontEnd/Lexer.hs 108
+        | KW_Safe
+        | KW_Unsafe
+        | KW_CCall
+        | KW_Stdcall
+        | KW_Primitive
hunk ./FrontEnd/Lexer.hs 157
+ ( "export",    KW_Export ),
hunk ./FrontEnd/Lexer.hs 172
+ ( "safe",      KW_Safe ),
+ ( "unsafe",    KW_Unsafe ),
+ ( "ccall",     KW_CCall ),
+ ( "stdcall",   KW_Stdcall ),
+ ( "primitive", KW_Primitive ),
hunk ./FrontEnd/ParseUtils.hs 36
+        , parseImport
+        , parseExport
hunk ./FrontEnd/ParseUtils.hs 365
+-- FFI parsing
+
+parseExport :: Monad m => String -> HsName -> m HsForeignT
+parseExport cn hn =
+    case words cn of
+      [x] | isCName x -> return $ Export x
+      []              -> return $ Export $ show hn
+      _               -> fail ("Invalid cname in export declaration: "++show cn)
+
+parseImport :: Monad m => String -> HsName -> m HsForeignT
+parseImport cn hn =
+    case words cn of
+      ["dynamic"]   -> return Dynamic
+      ["wrapper"]   -> return Wrapper
+      []            -> return $ Import (show hn) [] []
+      ("static":xs) -> parseIS [] [] xs
+      xs            -> parseIS [] [] xs
+
+parseIS a b ['&':n] | isCName n = return $ AddrOf n a b
+parseIS a b [n]     | isCName n = return $ Import n a b
+parseIS a b ["&",n] | isCName n = return $ AddrOf n a b
+parseIS a b (('-':'l':l):r)     = parseIS a (l:b) r
+parseIS a b (i:r)               = parseIS (i:a) b r
+parseIS _ _ x                   = fail ("Syntax error parsing foreign import: "++show x)
+
+isCName []     = False
+isCName (c:cs) = p1 c && all p2 cs
+    where p1 c = isAlpha c    || any (c==) oa
+          p2 c = isAlphaNum c || any (c==) oa
+          oa   = "_-$"
+
hunk ./FrontEnd/Rename.hs 325
-renameHsDecl (HsForeignDecl a b c n t) subTable = do
+renameHsDecl (HsForeignDecl a b c d n t) subTable = do
hunk ./FrontEnd/Rename.hs 329
-    --addDiag $ show (n, "foreigna",t)
-    t <- renameHsQualType t subTable'
-    --addDiag $ show (n, "foreignb",t)
-    return  (HsForeignDecl a b c n t)
+    qt <- renameHsQualType t subTable'
+    return (HsForeignDecl a b c d n t)
hunk ./FrontEnd/Rename.hs 329
-    qt <- renameHsQualType t subTable'
+    t <- renameHsQualType t subTable'
hunk ./FrontEnd/Rename.hs 1179
-getHsNamesAndASrcLocsFromHsDecl (HsForeignDecl a _ _ n _) = [(n,a)]
+getHsNamesAndASrcLocsFromHsDecl (HsForeignDecl a _ _ _ n _) = [(n,a)]
hunk ./FrontEnd/Rename.hs 1202
-    f (HsForeignDecl a _ _ n _)  = tellF [(toName Val n,a,[])]
+    f (HsForeignDecl a _ _ _ n _)  = tellF [(toName Val n,a,[])]
hunk ./FrontEnd/Rename.hs 1259
-namesHsDecl (HsForeignDecl a _ _ n _)  = ([(n,a)],[])
+namesHsDecl (HsForeignDecl a _ _ _ n _)  = ([(n,a)],[])
hunk ./FrontEnd/TI/Main.hs 451
-tiDecl env (HsForeignDecl _ _ _ n _) = do
+tiDecl env d@HsForeignDecl {} = do
hunk ./FrontEnd/TI/Main.hs 453
-    let Just qt =  Map.lookup (toName Val n) sigEnv
+    let Just qt =  Map.lookup (toName Val $ hsDeclName d) sigEnv
hunk ./FrontEnd/TI/Module.hs 212
-        fakeForeignDecls = [ [HsForeignDecl bogusASrcLoc ForeignPrimitive "" (nameName x) (HsQualType [] $ HsTyTuple []) ] | (x,_) <- Map.toList noDefaultSigs]
+        fakeForeignDecls = [ [HsForeignDecl bogusASrcLoc (Import "" [] []) Primitive Safe (nameName x) (HsQualType [] $ HsTyTuple []) ] | (x,_) <- Map.toList noDefaultSigs]
hunk ./FrontEnd/Tc/Main.hs 471
-tcPragmaDecl fd@(HsForeignDecl _ _ _ n qt) = do
+tcPragmaDecl fd@(HsForeignDecl _ _ _ _ n qt) = do
hunk ./FrontEnd/Tc/Module.hs 193
-        fakeForeignDecls = [ [HsForeignDecl bogusASrcLoc ForeignPrimitive "" (nameName x) (HsQualType [] $ HsTyTuple []) ] | (x,_) <- Map.toList noDefaultSigs]
+        fakeForeignDecls = [ [HsForeignDecl bogusASrcLoc (Import "" [] []) Primitive Safe (nameName x) (HsQualType [] $ HsTyTuple []) ] | (x,_) <- Map.toList noDefaultSigs]
hunk ./FrontEnd/TypeSigs.hs 46
-collectSigsFromDecls ((HsForeignDecl sl _ _ n qt):ds) = HsTypeSig sl [n] qt:collectSigsFromDecls ds
+collectSigsFromDecls ((HsForeignDecl sl _ _ _ n qt):ds) = HsTypeSig sl [n] qt:collectSigsFromDecls ds
hunk ./FrontEnd/TypeSyns.hs 98
-renameHsDecl (HsForeignDecl a b c n t) subTable = do
+renameHsDecl (HsForeignDecl a b c d n t) subTable = do
hunk ./FrontEnd/TypeSyns.hs 102
-    return  (HsForeignDecl a b c n t)
+    return  (HsForeignDecl a b c d n t)
hunk ./FrontEnd/TypeSyns.hs 639
-getHsNamesAndASrcLocsFromHsDecl (HsForeignDecl a _ _ n _) = [(n,a)]
+getHsNamesAndASrcLocsFromHsDecl (HsForeignDecl a _ _ _ n _) = [(n,a)]
hunk ./FrontEnd/Utils.hs 34
-maybeGetDeclName (HsForeignDecl _ _ _ n _) = return (toName Val n)
+maybeGetDeclName x@HsForeignDecl {} = return $ toName Val $ hsDeclName x