From 427ce38d4b21c97d32b7c41dfe2cd9d968ef4a34 Mon Sep 17 00:00:00 2001 From: igloo Date: Fri, 2 Apr 2004 02:39:29 +0000 Subject: [PATCH] [project @ 2004-04-02 02:39:26 by igloo] Add support for foreign imports inside quasi-quotes. Gave TH a few more uniques to play with and fixed a typo. --- ghc/compiler/deSugar/DsMeta.hs | 69 +++++++++++++++++++++++++++++++++--- ghc/compiler/prelude/PrelNames.lhs | 2 +- 2 files changed, 66 insertions(+), 5 deletions(-) diff --git a/ghc/compiler/deSugar/DsMeta.hs b/ghc/compiler/deSugar/DsMeta.hs index 94f3496..bba9d9a 100644 --- a/ghc/compiler/deSugar/DsMeta.hs +++ b/ghc/compiler/deSugar/DsMeta.hs @@ -55,6 +55,9 @@ import BasicTypes ( isBoxed ) import Packages ( thPackage ) import Outputable import Bag ( bagToList ) +import FastString ( unpackFS ) +import ForeignCall ( Safety(..), ForeignCall(..), CCallConv(..), + CCallTarget(..) ) import Monad ( zipWithM ) import List ( sortBy ) @@ -112,8 +115,9 @@ repTopDs group val_ds <- mapM rep_bind_group (hs_valds group) ; tycl_ds <- mapM repTyClD (hs_tyclds group) ; inst_ds <- mapM repInstD' (hs_instds group) ; + for_ds <- mapM repForD (hs_fords group) ; -- more needed - return (de_loc $ sort_by_loc $ concat val_ds ++ catMaybes tycl_ds ++ inst_ds) }) ; + return (de_loc $ sort_by_loc $ concat val_ds ++ catMaybes tycl_ds ++ inst_ds ++ for_ds) }) ; decl_ty <- lookupType decQTyConName ; let { core_list = coreList' decl_ty decls } ; @@ -232,6 +236,36 @@ repInstD' (L loc (InstDecl ty binds _)) -- Ignore user pragmas for now where (tvs, cxt, cls, tys) = splitHsInstDeclTy (unLoc ty) +repForD :: Located (ForeignDecl Name) -> DsM (SrcSpan, Core TH.DecQ) +repForD (L loc (ForeignImport name typ (CImport cc s ch cn cis) _)) + = do MkC name' <- lookupLOcc name + MkC typ' <- repLTy typ + MkC cc' <- repCCallConv cc + MkC s' <- repSafety s + MkC str <- coreStringLit $ static + ++ unpackFS ch ++ " " + ++ unpackFS cn ++ " " + ++ conv_cimportspec cis + dec <- rep2 forImpDName [cc', s', str, name', typ'] + return (loc, dec) + where + conv_cimportspec (CLabel cls) = panic "repForD': CLabel Not handled" + conv_cimportspec (CFunction DynamicTarget) = "dynamic" + conv_cimportspec (CFunction (StaticTarget fs)) = unpackFS fs + conv_cimportspec CWrapper = "wrapper" + static = case cis of + CFunction (StaticTarget _) -> "static " + _ -> "" + +repCCallConv :: CCallConv -> DsM (Core TH.Callconv) +repCCallConv CCallConv = rep2 cCallName [] +repCCallConv StdCallConv = rep2 stdCallName [] + +repSafety :: Safety -> DsM (Core TH.Safety) +repSafety PlayRisky = rep2 unsafeName [] +repSafety (PlaySafe False) = rep2 safeName [] +repSafety (PlaySafe True) = rep2 threadsafeName [] + ------------------------------------------------------- -- Constructors ------------------------------------------------------- @@ -1253,7 +1287,7 @@ templateHaskellNames = [ bindSName, letSName, noBindSName, parSName, -- Dec funDName, valDName, dataDName, newtypeDName, tySynDName, - classDName, instanceDName, sigDName, + classDName, instanceDName, sigDName, forImpDName, -- Cxt cxtName, -- Strict @@ -1267,6 +1301,12 @@ templateHaskellNames = [ -- Type forallTName, varTName, conTName, appTName, tupleTName, arrowTName, listTName, + -- Callconv + cCallName, stdCallName, + -- Safety + unsafeName, + safeName, + threadsafeName, -- And the tycons qTyConName, nameTyConName, patTyConName, fieldPatTyConName, matchQTyConName, @@ -1395,6 +1435,7 @@ tySynDName = libFun FSLIT("tySynD") tySynDIdKey classDName = libFun FSLIT("classD") classDIdKey instanceDName = libFun FSLIT("instanceD") instanceDIdKey sigDName = libFun FSLIT("sigD") sigDIdKey +forImpDName = libFun FSLIT("forImpD") forImpDIdKey -- type Ctxt = ... cxtName = libFun FSLIT("cxt") cxtIdKey @@ -1423,6 +1464,15 @@ arrowTName = libFun FSLIT("arrowT") arrowTIdKey listTName = libFun FSLIT("listT") listTIdKey appTName = libFun FSLIT("appT") appTIdKey +-- data Callconv = ... +cCallName = libFun FSLIT("cCall") cCallIdKey +stdCallName = libFun FSLIT("stdCall") stdCallIdKey + +-- data Safety = ... +unsafeName = libFun FSLIT("unsafe") unsafeIdKey +safeName = libFun FSLIT("safe") safeIdKey +threadsafeName = libFun FSLIT("threadsafe") threadsafeIdKey + matchQTyConName = libTc FSLIT("MatchQ") matchQTyConKey clauseQTyConName = libTc FSLIT("ClauseQ") clauseQTyConKey expQTyConName = libTc FSLIT("ExpQ") expQTyConKey @@ -1456,7 +1506,7 @@ fieldExpTyConKey = mkPreludeTyConUnique 116 fieldPatTyConKey = mkPreludeTyConUnique 117 nameTyConKey = mkPreludeTyConUnique 118 --- IdUniques available: 200-299 +-- IdUniques available: 200-399 -- If you want to change this, make sure you check in PrelNames returnQIdKey = mkPreludeMiscIdUnique 200 @@ -1547,6 +1597,7 @@ tySynDIdKey = mkPreludeMiscIdUnique 276 classDIdKey = mkPreludeMiscIdUnique 277 instanceDIdKey = mkPreludeMiscIdUnique 278 sigDIdKey = mkPreludeMiscIdUnique 279 +forImpDIdKey = mkPreludeMiscIdUnique 297 -- type Cxt = ... cxtIdKey = mkPreludeMiscIdUnique 280 @@ -1561,7 +1612,7 @@ recCIdKey = mkPreludeMiscIdUnique 284 infixCIdKey = mkPreludeMiscIdUnique 285 -- type StrictType = ... -strictTKey = mkPreludeMiscIdUnique 2286 +strictTKey = mkPreludeMiscIdUnique 286 -- type VarStrictType = ... varStrictTKey = mkPreludeMiscIdUnique 287 @@ -1574,3 +1625,13 @@ tupleTIdKey = mkPreludeMiscIdUnique 294 arrowTIdKey = mkPreludeMiscIdUnique 295 listTIdKey = mkPreludeMiscIdUnique 296 appTIdKey = mkPreludeMiscIdUnique 293 + +-- data Callconv = ... +cCallIdKey = mkPreludeMiscIdUnique 300 +stdCallIdKey = mkPreludeMiscIdUnique 301 + +-- data Safety = ... +unsafeIdKey = mkPreludeMiscIdUnique 305 +safeIdKey = mkPreludeMiscIdUnique 306 +threadsafeIdKey = mkPreludeMiscIdUnique 307 + diff --git a/ghc/compiler/prelude/PrelNames.lhs b/ghc/compiler/prelude/PrelNames.lhs index ac46d4e..099dc5b 100644 --- a/ghc/compiler/prelude/PrelNames.lhs +++ b/ghc/compiler/prelude/PrelNames.lhs @@ -992,7 +992,7 @@ choiceAIdKey = mkPreludeMiscIdUnique 123 -- ||| loopAIdKey = mkPreludeMiscIdUnique 124 ---------------- Template Haskell ------------------- --- USES IdUniques 200-299 +-- USES IdUniques 200-399 ----------------------------------------------------- \end{code} -- 1.7.10.4