[project @ 2002-02-15 22:13:32 by sof]
[ghc-hetmet.git] / ghc / compiler / parser / Parser.y
index e98b1ff..cbc0a5b 100644 (file)
@@ -1,6 +1,6 @@
 {-                                                             -*-haskell-*-
 -----------------------------------------------------------------------------
-$Id: Parser.y,v 1.86 2002/02/11 15:16:26 simonpj Exp $
+$Id: Parser.y,v 1.90 2002/02/15 22:13:33 sof Exp $
 
 Haskell grammar.
 
@@ -21,10 +21,11 @@ import RdrName
 import PrelNames       ( mAIN_Name, unitTyCon_RDR, funTyCon_RDR, 
                          listTyCon_RDR, parrTyCon_RDR, tupleTyCon_RDR, 
                          unitCon_RDR, nilCon_RDR, tupleCon_RDR )
-import ForeignCall     ( Safety(..), CExportSpec(..), CCallSpec(..), 
+import ForeignCall     ( Safety(..), CExportSpec(..), 
                          CCallConv(..), CCallTarget(..), defaultCCallConv,
-                         DNCallSpec(..) )
+                       )
 import OccName         ( UserFS, varName, tcName, dataName, tcClsName, tvName )
+import TyCon           ( DataConDetails(..) )
 import SrcLoc          ( SrcLoc )
 import Module
 import CmdLineOpts     ( opt_SccProfilingOn )
@@ -110,15 +111,16 @@ Conflicts: 21 shift/reduce, -=chak[4Feb2]
  'label'       { ITlabel } 
  'dynamic'     { ITdynamic }
  'safe'                { ITsafe }
+ 'threadsafe'  { ITthreadsafe }
  'unsafe'      { ITunsafe }
  'with'        { ITwith }
  'stdcall'      { ITstdcallconv }
  'ccall'        { ITccallconv }
  'dotnet'       { ITdotnet }
  '_ccall_'     { ITccall (False, False, PlayRisky) }
- '_ccall_GC_'  { ITccall (False, False, PlaySafe)  }
+ '_ccall_GC_'  { ITccall (False, False, PlaySafe False) }
  '_casm_'      { ITccall (False, True,  PlayRisky) }
- '_casm_GC_'   { ITccall (False, True,  PlaySafe)  }
+ '_casm_GC_'   { ITccall (False, True,  PlaySafe False) }
 
  '{-# SPECIALISE'  { ITspecialise_prag }
  '{-# SOURCE'     { ITsource_prag }
@@ -357,11 +359,11 @@ topdecl :: { RdrBinding }
 
        | srcloc 'data' tycl_hdr constrs deriving
                {% returnP (RdrHsDecl (TyClD
-                     (mkTyData DataType $3 (reverse $4) (length $4) $5 $1))) }
+                     (mkTyData DataType $3 (DataCons (reverse $4)) $5 $1))) }
 
        | srcloc 'newtype' tycl_hdr '=' newconstr deriving
                {% returnP (RdrHsDecl (TyClD
-                     (mkTyData NewType $3 [$5] 1 $6 $1))) }
+                     (mkTyData NewType $3 (DataCons [$5]) $6 $1))) }
 
        | srcloc 'class' tycl_hdr fds where
                {% let 
@@ -389,15 +391,25 @@ topdecl :: { RdrBinding }
 --     (Eq a, Ord b) => T a b
 -- Rather a lot of inlining here, else we get reduce/reduce errors
 tycl_hdr :: { (RdrNameContext, RdrName, [RdrNameHsTyVar]) }
-       : '(' comma_types1 ')' '=>' tycon tv_bndrs      {% mapP checkPred $2    `thenP` \ cxt ->
+       : '(' comma_types1 ')' '=>' gtycon tv_bndrs     {% mapP checkPred $2    `thenP` \ cxt ->
                                                           returnP (cxt, $5, $6) }
-       | qtycon atypes1 '=>' tycon atypes0             {% checkTyVars $5       `thenP` \ tvs ->
+          -- qtycon for the class below name would lead to many s/r conflicts
+         --   FIXME: does the renamer pick up all wrong forms and raise an
+         --          error 
+       | gtycon atypes1 '=>' gtycon atypes0            {% checkTyVars $5       `thenP` \ tvs ->
                                                           returnP ([HsClassP $1 $2], $4, tvs) }
-       | qtycon  atypes0                               {% checkTyVars $2       `thenP` \ tvs ->
+       | gtycon  atypes0                               {% checkTyVars $2       `thenP` \ tvs ->
                                                           returnP ([], $1, tvs) }
-               -- We have to have qtycon in this production to avoid s/r conflicts
-               -- with the previous one.  The renamer will complain if we use
-               -- a qualified tycon.
+               -- We have to have qtycon in this production to avoid s/r
+               -- conflicts with the previous one.  The renamer will complain
+               -- if we use a qualified tycon.
+               --
+               -- Using a `gtycon' throughout.  This enables special syntax,
+               -- such as "[]" for tycons as well as tycon ops in
+               -- parentheses.  This is beyond H98, but used repeatedly in
+               -- the Prelude modules.  (So, it would be a good idea to raise
+               -- an error in the renamer if some non-H98 form is used and
+               -- -fglasgow-exts is not given.)  -=chak 
 
 decls  :: { [RdrBinding] }
        : decls ';' decl                { $3 : $1 }
@@ -504,7 +516,7 @@ deprecation :: { RdrBinding }
 --
 fdecl :: { RdrNameHsDecl }
 fdecl : srcloc 'import' callconv safety1 fspec {% mkImport $3 $4       $5 $1 }
-      | srcloc 'import' callconv         fspec {% mkImport $3 PlaySafe $4 $1 }
+      | srcloc 'import' callconv         fspec {% mkImport $3 (PlaySafe False) $4 $1 }
       | srcloc 'export'        callconv         fspec  {% mkExport $3          $4 $1 }
         -- the following syntax is DEPRECATED
       | srcloc fdecl1DEPRECATED                        { ForD ($2 True $1) }
@@ -514,7 +526,7 @@ fdecl1DEPRECATED :: { Bool -> SrcLoc -> ForeignDecl RdrName }
 fdecl1DEPRECATED 
   ----------- DEPRECATED label decls ------------
   : 'label' ext_name varid '::' sigtype
-    { ForeignImport $3 $5 (CImport defaultCCallConv PlaySafe _NIL_ _NIL_ 
+    { ForeignImport $3 $5 (CImport defaultCCallConv (PlaySafe False) _NIL_ _NIL_ 
                                   (CLabel ($2 `orElse` mkExtName $3))) }
 
   ----------- DEPRECATED ccall/stdcall decls ------------
@@ -584,7 +596,7 @@ fdecl1DEPRECATED
     -- DEPRECATED variant #8: use of the special identifier `dynamic' without
     --                       an explicit calling convention (export)
   | 'export' {-no callconv-} 'dynamic' varid '::' sigtype
-    { ForeignImport $3 $5 (CImport defaultCCallConv PlaySafe _NIL_ _NIL_ 
+    { ForeignImport $3 $5 (CImport defaultCCallConv (PlaySafe False) _NIL_ _NIL_ 
                                   CWrapper) }
 
     -- DEPRECATED variant #9: use of the special identifier `dynamic' (export)
@@ -592,7 +604,7 @@ fdecl1DEPRECATED
     {% case $2 of
          DNCall      -> parseError "Illegal format of .NET foreign import"
         CCall cconv -> returnP $
-          ForeignImport $4 $6 (CImport cconv PlaySafe _NIL_ _NIL_ CWrapper) }
+          ForeignImport $4 $6 (CImport cconv (PlaySafe False) _NIL_ _NIL_ CWrapper) }
 
   ----------- DEPRECATED .NET decls ------------
   -- NB: removed the .NET call declaration, as it is entirely subsumed
@@ -613,12 +625,14 @@ callconv :: { CallConv }
 
 safety :: { Safety }
        : 'unsafe'                      { PlayRisky }
-       | 'safe'                        { PlaySafe  }
-       | {- empty -}                   { PlaySafe  }
+       | 'safe'                        { PlaySafe False }
+       | 'threadsafe'                  { PlaySafe True  }
+       | {- empty -}                   { PlaySafe False }
 
 safety1 :: { Safety }
        : 'unsafe'                      { PlayRisky }
-       | 'safe'                        { PlaySafe  }
+       | 'safe'                        { PlaySafe  False }
+       | 'threadsafe'                  { PlaySafe  True }
          -- only needed to avoid conflicts with the DEPRECATED rules
 
 fspec :: { (FAST_STRING, RdrName, RdrNameHsType) }
@@ -886,9 +900,9 @@ exp10 :: { RdrNameHsExpr }
                                                   returnP (HsDo DoExpr stmts $1) }
 
        | '_ccall_'    ccallid aexps0           { HsCCall $2 $3 PlayRisky False placeHolderType }
-       | '_ccall_GC_' ccallid aexps0           { HsCCall $2 $3 PlaySafe  False placeHolderType }
+       | '_ccall_GC_' ccallid aexps0           { HsCCall $2 $3 (PlaySafe False) False placeHolderType }
        | '_casm_'     CLITLIT aexps0           { HsCCall $2 $3 PlayRisky True  placeHolderType }
-       | '_casm_GC_'  CLITLIT aexps0           { HsCCall $2 $3 PlaySafe  True  placeHolderType }
+       | '_casm_GC_'  CLITLIT aexps0           { HsCCall $2 $3 (PlaySafe False) True  placeHolderType }
 
         | scc_annot exp                                { if opt_SccProfilingOn
                                                        then HsSCC $1 $2