From 5f1979b78fa32b120a7c1a9a1731de3bab4e09ae Mon Sep 17 00:00:00 2001
From: sof <unknown>
Date: Wed, 1 Sep 1999 14:08:19 +0000
Subject: [PATCH] [project @ 1999-09-01 14:08:19 by sof] * On foreign decls,
"ext_name"s are now optional. If missing, the ext_name is made equal to the
Haskell name. * Half a dozen special-ids were incorrectly handled when
occurring as tyvars.
---
ghc/compiler/parser/Lex.lhs | 4 ++++
ghc/compiler/parser/ParseUtil.lhs | 22 ++++++++++++++---
ghc/compiler/parser/Parser.y | 40 ++++++++++++++++++-------------
3 files changed, 46 insertions(+), 20 deletions(-)
diff --git a/ghc/compiler/parser/Lex.lhs b/ghc/compiler/parser/Lex.lhs
index e1de35a2ee5b..4ee690be8445 100644
--- a/ghc/compiler/parser/Lex.lhs
+++ b/ghc/compiler/parser/Lex.lhs
@@ -128,6 +128,8 @@ data Token
| ITlabel
| ITdynamic
| ITunsafe
+ | ITstdcallconv
+ | ITccallconv
| ITinterface -- interface keywords
| IT__export
@@ -280,6 +282,8 @@ ghcExtensionKeywordsFM = listToUFM $
( "label", ITlabel ),
( "dynamic", ITdynamic ),
( "unsafe", ITunsafe ),
+ ( "stdcall", ITstdcallconv),
+ ( "ccall", ITccallconv),
("_ccall_", ITccall (False, False, False)),
("_ccall_GC_", ITccall (False, False, True)),
("_casm_", ITccall (False, True, False)),
diff --git a/ghc/compiler/parser/ParseUtil.lhs b/ghc/compiler/parser/ParseUtil.lhs
index ce4f71bfcfb9..395d06c80f35 100644
--- a/ghc/compiler/parser/ParseUtil.lhs
+++ b/ghc/compiler/parser/ParseUtil.lhs
@@ -13,9 +13,10 @@ module ParseUtil (
, mkRecConstrOrUpdate -- HsExp -> [HsFieldUpdate] -> P HsExp
, groupBindings
+
+ , mkExtName -- Maybe ExtName -> RdrName -> ExtName
, checkPrec -- String -> P String
- , checkCallConv -- FAST_STRING -> P CallConv
, checkContext -- HsType -> P HsContext
, checkInstType -- HsType -> P HsType
, checkAssertion -- HsType -> P HsAsst
@@ -35,10 +36,11 @@ module ParseUtil (
-- pseudo-keywords, in var and tyvar forms (all :: RdrName)
, as_var_RDR, hiding_var_RDR, qualified_var_RDR, forall_var_RDR
, export_var_RDR, label_var_RDR, dynamic_var_RDR, unsafe_var_RDR
+ , stdcall_var_RDR, ccall_var_RDR
, as_tyvar_RDR, hiding_tyvar_RDR, qualified_tyvar_RDR
, export_tyvar_RDR, label_tyvar_RDR, dynamic_tyvar_RDR
- , unsafe_tyvar_RDR
+ , unsafe_tyvar_RDR, stdcall_tyvar_RDR, ccall_tyvar_RDR
, minus_RDR, pling_RDR, dot_RDR
@@ -53,7 +55,7 @@ import RdrHsSyn
import RdrName
import CallConv
import PrelMods ( pRELUDE_Name, mkUbxTupNameStr, mkTupNameStr )
-import OccName ( dataName, tcName, varName, tvName, setOccNameSpace )
+import OccName ( dataName, tcName, varName, tvName, setOccNameSpace, occNameFS )
import CmdLineOpts ( opt_NoImplicitPrelude )
import StringBuffer ( lexemeToString )
import FastString ( unpackFS )
@@ -354,6 +356,14 @@ mkRecConstrOrUpdate exp fs@(_:_)
mkRecConstrOrUpdate _ _
= parseError "Empty record update"
+-- supplying the ext_name in a foreign decl is optional ; if it
+-- isn't there, the Haskell name is assumed. Note that no transformation
+-- of the Haskell name is then performed, so if you foreign export (++),
+-- it's external name will be "++". Too bad.
+mkExtName :: Maybe ExtName -> RdrName -> ExtName
+mkExtName Nothing rdrNm = ExtName (occNameFS (rdrNameOcc rdrNm)) Nothing
+mkExtName (Just x) _ = x
+
-----------------------------------------------------------------------------
-- group function bindings into equation groups
@@ -436,6 +446,8 @@ exportName = SLIT("export")
labelName = SLIT("label")
dynamicName = SLIT("dynamic")
unsafeName = SLIT("unsafe")
+stdcallName = SLIT("stdcall")
+ccallName = SLIT("ccall")
as_var_RDR = mkSrcUnqual varName asName
hiding_var_RDR = mkSrcUnqual varName hidingName
@@ -445,6 +457,8 @@ export_var_RDR = mkSrcUnqual varName exportName
label_var_RDR = mkSrcUnqual varName labelName
dynamic_var_RDR = mkSrcUnqual varName dynamicName
unsafe_var_RDR = mkSrcUnqual varName unsafeName
+stdcall_var_RDR = mkSrcUnqual varName stdcallName
+ccall_var_RDR = mkSrcUnqual varName ccallName
as_tyvar_RDR = mkSrcUnqual tvName asName
hiding_tyvar_RDR = mkSrcUnqual tvName hidingName
@@ -453,6 +467,8 @@ export_tyvar_RDR = mkSrcUnqual tvName exportName
label_tyvar_RDR = mkSrcUnqual tvName labelName
dynamic_tyvar_RDR = mkSrcUnqual tvName dynamicName
unsafe_tyvar_RDR = mkSrcUnqual tvName unsafeName
+stdcall_tyvar_RDR = mkSrcUnqual tvName stdcallName
+ccall_tyvar_RDR = mkSrcUnqual tvName ccallName
minus_RDR = mkSrcUnqual varName SLIT("-")
pling_RDR = mkSrcUnqual varName SLIT("!")
diff --git a/ghc/compiler/parser/Parser.y b/ghc/compiler/parser/Parser.y
index 0a44b9420d04..239e64ba4f7e 100644
--- a/ghc/compiler/parser/Parser.y
+++ b/ghc/compiler/parser/Parser.y
@@ -1,10 +1,6 @@
{-
-----------------------------------------------------------------------------
-<<<<<<< Parser.y
-$Id: Parser.y,v 1.13 1999/07/27 09:25:49 simonmar Exp $
-=======
-$Id: Parser.y,v 1.13 1999/07/27 09:25:49 simonmar Exp $
->>>>>>> 1.10
+$Id: Parser.y,v 1.14 1999/09/01 14:08:19 sof Exp $
Haskell grammar.
@@ -97,6 +93,8 @@ Conflicts: 14 shift/reduce
'label' { ITlabel }
'dynamic' { ITdynamic }
'unsafe' { ITunsafe }
+ 'stdcall' { ITstdcallconv }
+ 'ccall' { ITccallconv }
'_ccall_' { ITccall (False, False, False) }
'_ccall_GC_' { ITccall (False, False, True) }
'_casm_' { ITccall (False, True, False) }
@@ -348,13 +346,13 @@ topdecl :: { RdrBinding }
| srcloc 'foreign' 'import' callconv ext_name
unsafe_flag varid_no_unsafe '::' sigtype
- { RdrHsDecl (ForD (ForeignDecl $7 (FoImport $6) $9 $5 $4 $1)) }
+ { RdrHsDecl (ForD (ForeignDecl $7 (FoImport $6) $9 (mkExtName $5 $7) $4 $1)) }
| srcloc 'foreign' 'export' callconv ext_name varid '::' sigtype
- { RdrHsDecl (ForD (ForeignDecl $6 FoExport $8 $5 $4 $1)) }
+ { RdrHsDecl (ForD (ForeignDecl $6 FoExport $8 (mkExtName $5 $6) $4 $1)) }
| srcloc 'foreign' 'label' ext_name varid '::' sigtype
- { RdrHsDecl (ForD (ForeignDecl $5 FoLabel $7 $4
+ { RdrHsDecl (ForD (ForeignDecl $5 FoLabel $7 (mkExtName $4 $5)
defaultCallConv $1)) }
| decl { $1 }
@@ -455,17 +453,19 @@ rule_var :: { RdrNameRuleBndr }
-- Foreign import/export
callconv :: { Int }
- : VARID {% checkCallConv $1 }
+ : 'stdcall' { stdCallConv }
+ | 'ccall' { cCallConv }
| {- empty -} { defaultCallConv }
unsafe_flag :: { Bool }
: 'unsafe' { True }
| {- empty -} { False }
-ext_name :: { ExtName }
- : 'dynamic' { Dynamic }
- | STRING { ExtName $1 Nothing }
- | STRING STRING { ExtName $2 (Just $1) }
+ext_name :: { Maybe ExtName }
+ : 'dynamic' { Just Dynamic }
+ | STRING { Just (ExtName $1 Nothing) }
+ | STRING STRING { Just (ExtName $2 (Just $1)) }
+ | {- empty -} { Nothing }
-----------------------------------------------------------------------------
-- Types
@@ -875,6 +875,8 @@ varid :: { RdrName }
| 'label' { label_var_RDR }
| 'dynamic' { dynamic_var_RDR }
| 'unsafe' { unsafe_var_RDR }
+ | 'stdcall' { stdcall_var_RDR }
+ | 'ccall' { ccall_var_RDR }
varid_no_unsafe :: { RdrName }
: VARID { mkSrcUnqual varName $1 }
@@ -885,6 +887,8 @@ varid_no_unsafe :: { RdrName }
| 'export' { export_var_RDR }
| 'label' { label_var_RDR }
| 'dynamic' { dynamic_var_RDR }
+ | 'stdcall' { stdcall_var_RDR }
+ | 'ccall' { ccall_var_RDR }
-----------------------------------------------------------------------------
-- ConIds
@@ -981,10 +985,12 @@ tyvar :: { RdrName }
| 'as' { as_tyvar_RDR }
| 'qualified' { qualified_tyvar_RDR }
| 'hiding' { hiding_tyvar_RDR }
- | 'export' { export_var_RDR }
- | 'label' { label_var_RDR }
- | 'dynamic' { dynamic_var_RDR }
- | 'unsafe' { unsafe_var_RDR }
+ | 'export' { export_tyvar_RDR }
+ | 'label' { label_tyvar_RDR }
+ | 'dynamic' { dynamic_tyvar_RDR }
+ | 'unsafe' { unsafe_tyvar_RDR }
+ | 'stdcall' { stdcall_tyvar_RDR }
+ | 'ccall' { ccall_tyvar_RDR }
-- NOTE: no 'forall'
-----------------------------------------------------------------------------
--
GitLab