X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Fparser%2FParser.y;h=3348da9d3cdda8d0d8a0acacc35f75df27d0b27b;hb=c52f850d362bc16fc616c08d84f3c83fbbdea464;hp=4a8d726744a145405e9cd85f2e4320a45925a2f1;hpb=904f158f9fe208b8154029dff655a6eab4b2828e;p=ghc-hetmet.git

diff --git a/ghc/compiler/parser/Parser.y b/ghc/compiler/parser/Parser.y
index 4a8d726..3348da9 100644
--- a/ghc/compiler/parser/Parser.y
+++ b/ghc/compiler/parser/Parser.y
@@ -1,6 +1,6 @@
 {-
 -----------------------------------------------------------------------------
-$Id: Parser.y,v 1.1 1999/06/01 16:40:48 simonmar Exp $
+$Id: Parser.y,v 1.9 1999/06/28 16:42:23 simonmar Exp $
 
 Haskell grammar.
 
@@ -23,6 +23,7 @@ import OccName		( varName, dataName, tcClsName, tvName )
 import SrcLoc		( SrcLoc )
 import Module
 import CallConv
+import CmdLineOpts	( opt_SccProfilingOn )
 import BasicTypes	( Fixity(..), FixityDirection(..), NewOrData(..) )
 import Panic
 
@@ -33,7 +34,7 @@ import GlaExts
 
 {-
 -----------------------------------------------------------------------------
-Conflicts: 13 shift/reduce
+Conflicts: 14 shift/reduce
 
 8 for abiguity in 'if x then y else z + 1'
 	(shift parses as 'if x then y else (z + 1)', as per longest-parse rule)
@@ -51,6 +52,10 @@ Conflicts: 13 shift/reduce
 	This saves explicitly defining a grammar for the rule lhs that
 	doesn't include 'forall'.
 
+1 for ambiguity in 'x @ Rec{..}'.  
+	Only sensible parse is 'x @ (Rec{..})', which is what resolving
+	to shift gives us.
+
 -----------------------------------------------------------------------------
 -}
 
@@ -80,6 +85,7 @@ Conflicts: 13 shift/reduce
  'then' 	{ ITthen }
  'type' 	{ ITtype }
  'where' 	{ ITwhere }
+ '_scc_'	{ ITscc }
 
  'forall'	{ ITforall }			-- GHC extension keywords
  'foreign'	{ ITforeign }
@@ -117,7 +123,7 @@ Conflicts: 13 shift/reduce
  '__litlit'	{ ITlit_lit }
  '__string'	{ ITstring_lit }
  '__ccall'	{ ITccall $$ }
- '__scc' 	{ ITscc }
+ '__scc' 	{ IT__scc }
  '__sccC'       { ITsccAllCafs }
 
  '__A'		{ ITarity }
@@ -429,8 +435,7 @@ rules	:: { RdrBinding }
 
 rule  	:: { RdrBinding }
 	: STRING rule_forall fexp '=' srcloc exp
-	     { RdrHsDecl (RuleD (RuleDecl $1 (error "rule tyvars") 
-		  $2 $3 $6 $5)) }
+	     { RdrHsDecl (RuleD (RuleDecl $1 [] $2 $3 $6 $5)) }
 
 rule_forall :: { [RdrNameRuleBndr] }
 	: 'forall' rule_var_list '.'            { $2 }
@@ -496,12 +501,10 @@ inst_type :: { RdrNameHsType }
 	: ctype				{% checkInstType $1 }
 
 ctype	:: { RdrNameHsType }
-	: 'forall' tyvars '.' btype '=>' type
-					{% checkContext $4 `thenP` \c ->
-					   returnP (HsForAllTy (Just $2) c $6) }
+	: 'forall' tyvars '.' context type
+					{ HsForAllTy (Just $2) $4 $5 }
 	| 'forall' tyvars '.' type	{ HsForAllTy (Just $2) [] $4 }
-	| btype '=>' type		{% checkContext $1 `thenP` \c ->
-					   returnP (HsForAllTy Nothing c $3) }
+	| context type			{ HsForAllTy Nothing   $1 $2 }
 	| type				{ $1 }
 
 types0  :: { [RdrNameHsType] }
@@ -526,15 +529,23 @@ constrs :: { [RdrNameConDecl] }
 	: constrs '|' constr		{ $3 : $1 }
 	| constr			{ [$1] }
 
-{- ToDo: existential stuff -}
-
 constr :: { RdrNameConDecl }
-	: srcloc scontype   
-		{ ConDecl (fst $2) [] [] (VanillaCon (snd $2)) $1 }
-	| srcloc sbtype conop sbtype	
-		{ ConDecl $3 [] [] (InfixCon $2 $4) $1 }
-	| srcloc con '{' fielddecls '}' 
-		{ ConDecl $2 [] [] (RecCon (reverse $4)) $1 }
+	: srcloc forall context constr_stuff
+		{ ConDecl (fst $4) $2 $3 (snd $4) $1 }
+	| srcloc forall constr_stuff
+		{ ConDecl (fst $3) $2 [] (snd $3) $1 }
+
+forall :: { [RdrNameHsTyVar] }
+	: 'forall' tyvars '.'		{ $2 }
+	| {- empty -}			{ [] }
+
+context :: { RdrNameContext }
+	: btype '=>'			{% checkContext $1 }
+
+constr_stuff :: { (RdrName, RdrNameConDetails) }
+	: scontype   		 	{ (fst $1, VanillaCon (snd $1)) }
+	| sbtype conop sbtype		{ ($2, InfixCon $1 $3) }
+	| con '{' fielddecls '}' 	{ ($1, RecCon (reverse $3)) }
 
 newconstr :: { RdrNameConDecl }
 	: srcloc conid atype	{ ConDecl $2 [] [] (NewCon $3 Nothing) $1 }
@@ -626,6 +637,10 @@ exp10 :: { RdrNameHsExpr }
 	| '_casm_'     CLITLIT aexps0		{ CCall $2 $3 False True  cbot }
 	| '_casm_GC_'  CLITLIT aexps0		{ CCall $2 $3 True  True  cbot }
 
+        | '_scc_' STRING exp    		{ if opt_SccProfilingOn
+							then HsSCC $2 $3
+							else HsPar $3 }
+
 	| fexp					{ $1 }
 
 ccallid :: { FAST_STRING }
@@ -657,7 +672,7 @@ aexp1	:: { RdrNameHsExpr }
 	| '[' list ']'                  { $2 }
 	| '(' infixexp qop ')'		{ SectionL $2 $3  }
 	| '(' qopm infixexp ')'		{ SectionR $2 $3 }
-	| qvar '@' aexp1		{ EAsPat $1 $3 }
+	| qvar '@' aexp			{ EAsPat $1 $3 }
 	| '_'				{ EWildPat }
 	| '~' aexp1			{ ELazyPat $2 }
 
@@ -749,10 +764,13 @@ stmtlist :: { [RdrNameStmt] }
 	|     layout_on  stmts close	{ reverse $2 }
 
 stmts :: { [RdrNameStmt] }
-	: stmts ';' stmt		{ $3 : $1 }
-	| stmts ';'			{ $1 }
+	: ';' stmts1			{ $2 }
+	| stmts1			{ $1 }
+
+stmts1 :: { [RdrNameStmt] }
+	: stmts1 ';' stmt		{ $3 : $1 }
+	| stmts1 ';'			{ $1 }
 	| stmt 				{ [$1] }
- 	| {- empty -}			{ [] }
 
 stmt  :: { RdrNameStmt }
 	: srcloc infixexp '<-' exp	{% checkPattern $2 `thenP` \p ->