diff options
Diffstat (limited to 'utils/genprimopcode')
| -rw-r--r-- | utils/genprimopcode/Main.hs | 4 | ||||
| -rw-r--r-- | utils/genprimopcode/Parser.y | 4 | ||||
| -rw-r--r-- | utils/genprimopcode/Syntax.hs | 14 |
3 files changed, 11 insertions, 11 deletions
diff --git a/utils/genprimopcode/Main.hs b/utils/genprimopcode/Main.hs index 06a4922aa3..fa4605fb69 100644 --- a/utils/genprimopcode/Main.hs +++ b/utils/genprimopcode/Main.hs @@ -830,10 +830,10 @@ mkPOI_LHS_text i mkPOI_RHS_text :: Entry -> String mkPOI_RHS_text i = case cat i of - Compare + Compare cmp -> case ty i of TyF t1 (TyF _ _) - -> "mkCompare " ++ sl_name i ++ ppType t1 + -> "mkCompare " ++ sl_name i ++ cmp ++ " " ++ ppType t1 _ -> error "Type error in comparison op" GenPrimOp -> let (argTys, resTy) = flatTys (ty i) diff --git a/utils/genprimopcode/Parser.y b/utils/genprimopcode/Parser.y index f39af24c7c..a32b8d8824 100644 --- a/utils/genprimopcode/Parser.y +++ b/utils/genprimopcode/Parser.y @@ -120,7 +120,7 @@ pWithOptions : with pOptions { $2 } | {- empty -} { [] } pCategory :: { Category } -pCategory : compare { Compare } +pCategory : '(' compare upperName ')' { Compare $3 } | genprimop { GenPrimOp } pDesc :: { String } @@ -148,7 +148,7 @@ pVectors : pVector ',' pVectors { [$1] ++ $3 } pVector :: { (String, String, Int) } pVector : '<' upperName ',' upperName ',' integer '>' { ($2, $4, $6) } - + pType :: { Ty } pType : paT '->' pType { TyF $1 $3 } | paT '=>' pType { TyC $1 $3 } diff --git a/utils/genprimopcode/Syntax.hs b/utils/genprimopcode/Syntax.hs index e215a89478..f087cdff94 100644 --- a/utils/genprimopcode/Syntax.hs +++ b/utils/genprimopcode/Syntax.hs @@ -65,7 +65,7 @@ data Option -- categorises primops data Category - = Compare | GenPrimOp + = Compare String | GenPrimOp deriving Show -- types @@ -74,7 +74,7 @@ data Ty | TyC Ty Ty -- We only allow one constraint, keeps the grammar simpler | TyApp TyCon [Ty] | TyVar TyVar - | TyUTup [Ty] -- unboxed tuples; just a TyCon really, + | TyUTup [Ty] -- unboxed tuples; just a TyCon really, -- but convenient like this deriving (Eq,Show) @@ -115,9 +115,9 @@ data SourceText = SourceText String {- Do some simple sanity checks: * all the default field names are unique * for each PrimOpSpec, all override field names are unique - * for each PrimOpSpec, all overridden field names + * for each PrimOpSpec, all overridden field names have a corresponding default value - * that primop types correspond in certain ways to the + * that primop types correspond in certain ways to the Category: eg if Comparison, the type must be of the form T -> T -> Bool. Dies with "error" if there's a problem, else returns (). @@ -130,7 +130,7 @@ sanityTop :: Info -> () sanityTop (Info defs entries) = let opt_names = map get_attrib_name defs primops = filter is_primop entries - in + in if length opt_names /= length (nub opt_names) then error ("non-unique default attribute names: " ++ show opt_names ++ "\n") else myseqAll (map (sanityPrimOp opt_names) primops) () @@ -153,7 +153,7 @@ sanityPrimOp def_names p else () sane_ty :: Category -> Ty -> Bool -sane_ty Compare (TyF t1 (TyF t2 td)) +sane_ty (Compare _cmp) (TyF t1 (TyF t2 td)) | t1 == t2 && td == TyApp (TyCon "Int#") [] = True sane_ty GenPrimOp _ = True @@ -170,7 +170,7 @@ get_attrib_name (OptionFixity _) = "fixity" lookup_attrib :: String -> [Option] -> Maybe Option lookup_attrib _ [] = Nothing -lookup_attrib nm (a:as) +lookup_attrib nm (a:as) = if get_attrib_name a == nm then Just a else lookup_attrib nm as is_vector :: Entry -> Bool |