[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.

diff --git a/ghc/compiler/parser/Lex.lhs b/ghc/compiler/parser/Lex.lhs
index e1de35a..4ee690b 100644 (file)
--- 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 ce4f71b..395d06c 100644 (file)
--- 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 0a44b94..239e64b 100644 (file)
--- 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'
 
 -----------------------------------------------------------------------------