Changeset 342

Timestamp:

02/28/05 20:25:26 (4 years ago)

Author:

autrijus

svk:copy_cache_prev:

1619

Message:

* Isaac (SyntaxNinja?)'s massive -Wall cleanup landed; also move S03.t into 03operator.t

Files:

• AUTHORS (modified) (1 prop)
• ChangeLog (modified) (1 prop)
• LICENSE/Artistic-2 (modified) (1 prop)
• LICENSE/GPL-2 (modified) (1 prop)
• MANIFEST (modified) (1 prop)
• MANIFEST.SKIP (modified) (1 prop)
• META.yml (modified) (1 prop)
• Makefile.PL (modified) (1 diff, 2 props)
• README (modified) (1 prop)
• SIGNATURE (modified) (1 prop)
• docs/01Overview.html (modified) (1 prop)
• examples/fp.p6 (modified) (1 prop)
• examples/life.p6 (modified) (1 prop)
• examples/mandel.p6 (modified) (1 prop)
• examples/quicksort.p6 (modified) (1 prop)
• examples/sendmoremoney.p6 (modified) (1 prop)
• examples/shuffle.p6 (modified) (1 prop)
• inc/Module/Install.pm (modified) (1 prop)
• inc/Module/Install/Base.pm (modified) (1 prop)
• inc/Module/Install/Can.pm (modified) (1 prop)
• inc/Module/Install/Fetch.pm (modified) (1 prop)
• inc/Module/Install/Makefile.pm (modified) (1 prop)
• inc/Module/Install/Metadata.pm (modified) (1 prop)
• inc/Module/Install/Scripts.pm (modified) (1 prop)
• inc/Module/Install/Win32.pm (modified) (1 prop)
• inc/Module/Install/WriteAll.pm (modified) (1 prop)
• inc/Test/Harness.pm (modified) (1 prop)
• inc/Test/Harness/Assert.pm (modified) (1 prop)
• inc/Test/Harness/Iterator.pm (modified) (1 prop)
• inc/Test/Harness/Straps.pm (modified) (1 prop)
• inc/Test/Harness/TAP.pod (modified) (1 prop)
• lib/Perl6/Pugs.pm (modified) (1 prop)
• lib/Perl6/lib/Kwid.pm (modified) (1 prop)
• lib/Perl6/lib/Test.pm (modified) (1 prop)
• lib/Perl6/lib/perlkwid.kwid (modified) (1 prop)
• src/AST.hs (modified) (15 diffs, 2 props)
• src/Bind.hs (modified) (3 diffs, 2 props)
• src/Cont.hs (modified) (1 diff, 2 props)
• src/Context.hs (modified) (4 diffs, 2 props)
• src/Eval.hs (modified) (17 diffs, 2 props)
• src/Help.hs (modified) (1 diff, 2 props)
• src/Internals.hs (modified) (4 diffs, 2 props)
• src/Junc.hs (modified) (2 diffs, 2 props)
• src/Lexer.hs (modified) (4 diffs, 2 props)
• src/Main.hs (modified) (3 diffs, 2 props)
• src/Monads.hs (modified) (3 diffs, 2 props)
• src/Parser.hs (modified) (6 diffs, 2 props)
• src/Posix.hs (modified) (1 diff, 2 props)
• src/Pretty.hs (modified) (2 diffs, 2 props)
• src/Prim.hs (modified) (3 diffs, 2 props)
• src/Rule.hs (modified) (2 props)
• src/Rule/Char.hs (modified) (1 diff, 2 props)
• src/Rule/Combinator.hs (modified) (1 diff, 2 props)
• src/Rule/Error.hs (modified) (3 diffs, 2 props)
• src/Rule/Expr.hs (modified) (2 props)
• src/Rule/LICENSE (modified) (1 prop)
• src/Rule/Language.hs (modified) (2 props)
• src/Rule/Perm.hs (modified) (2 props)
• src/Rule/Pos.hs (modified) (4 diffs, 2 props)
• src/Rule/Prim.hs (modified) (8 diffs, 2 props)
• src/Rule/Token.hs (modified) (2 props)
• src/Shell.hs (modified) (1 diff, 2 props)
• src/builtins.pod (modified) (1 prop)
• t/01basic.t (modified) (2 props)
• t/02atoms.t (modified) (2 props)
• t/03operator.t (modified) (2 diffs, 2 props)
• t/06sub.t (modified) (2 props)
• t/Dialects/perlego/isrw.t (modified) (2 props)
• t/Dialects/perlego/sigilless.t (modified) (2 props)
• t/S03.t (deleted)
• t/Synopsis/S01.pod (modified) (1 prop)
• t/Synopsis/S02.pod (modified) (1 prop)
• t/Synopsis/S03.pod (modified) (1 prop)
• t/Synopsis/S04.pod (modified) (1 prop)
• t/Synopsis/S05.pod (modified) (1 prop)
• t/Synopsis/S06.pod (modified) (1 prop)
• t/Synopsis/S09.pod (modified) (1 prop)
• t/Synopsis/S10.pod (modified) (1 prop)
• t/Synopsis/S11.pod (modified) (1 prop)
• t/Synopsis/S12.pod (modified) (1 prop)
• t/Synopsis/S13.pod (modified) (1 prop)
• t/base/anon_block.t (modified) (2 props)
• t/base/cond.t (modified) (2 props)
• t/base/for.t (modified) (2 props)
• t/base/if.t (modified) (2 props)
• t/base/num.t (modified) (2 props)
• t/base/unless.t (modified) (2 props)
• t/base/until.t (modified) (2 props)
• t/base/while.t (modified) (2 props)
• t/op/append.t (modified) (2 props)
• t/op/arith.t (modified) (2 props)
• t/op/array.t (modified) (2 props)
• t/op/array_ref.t (modified) (2 props)
• t/op/auto.t (modified) (2 props)
• t/op/binding.t (modified) (2 props)
• t/op/bit.t (modified) (2 props)
• t/op/defined.t (modified) (2 props)
• t/op/die.t (modified) (2 props)
• t/op/eq.t (modified) (2 props)
• t/op/eval.t (modified) (2 props)
• t/op/grep.t (modified) (2 props)
• t/op/hash.t (modified) (2 props)
• t/op/inc.t (modified) (2 props)
• t/op/int.t (modified) (2 props)
• t/op/join.t (modified) (2 props)
• t/op/magic.t (modified) (2 props)
• t/op/map.t (modified) (2 props)
• t/op/multi_dimensional_array.t (modified) (2 props)
• t/op/not.t (modified) (2 props)
• t/op/pair.t (modified) (2 props)
• t/op/pop.t (modified) (2 props)
• t/op/push.t (modified) (2 props)
• t/op/recurse.t (modified) (2 props)
• t/op/relational.t (modified) (2 props)
• t/op/repeat.t (modified) (2 props)
• t/op/shift.t (modified) (2 props)
• t/op/split.t (modified) (2 props)
• t/op/string_interpolation.t (modified) (2 props)
• t/op/unshift.t (modified) (2 props)
• t/unspecced/cont.t (modified) (2 props)

Makefile.PL

@@ -115 +115 @@
 postamble(<< ".");
 $pugs: @{[glob("src/*.hs"), glob("src/Rule/*.hs")]} $version_h
-        ghc --make -o pugs src/Main.hs -isrc
+        ghc --make -Wall -fno-warn-missing-signatures -fno-warn-name-shadowing -o pugs src/Main.hs -isrc
 
 tags ::

src/AST.hs

@@ -27 +27 @@
     vCast v             = doCast v
     castV :: n -> Val
-    castV v = error $ "cannot cast into Val"
+    castV _ = error $ "cannot cast into Val"
     doCast :: Val -> n
     doCast v = error $ "cannot cast from Val: " ++ (show v)
@@ -40 +40 @@
     vCast v             = case vCast v of
         [x, y]  -> (x, y)
-        other   -> error $ "cannot cast into VPair: " ++ (show v)
+        _       -> error $ "cannot cast into VPair: " ++ (show v)
 
 instance Value VHash where
@@ -95 +95 @@
     = (1 ==) . length . filter vCast $ setToList vs
 
+readMVal :: MonadIO m => Val -> m Val
 readMVal (MVal mv) = readMVal =<< liftIO (readIORef mv)
 readMVal v         = return v
@@ -129 +130 @@
     doCast (VArray (MkArray a))    = genericLength a
     doCast (VHash (MkHash h))    = fromIntegral $ sizeFM h
-    doCast x            = 0/0 -- error $ "cannot cast as Num: " ++ (show x)
+    doCast _            = 0/0 -- error $ "cannot cast as Num: " ++ (show x)
 
 instance Value VComplex where
@@ -141 +142 @@
     vCast (VBool b)     = if b then "1" else ""
     vCast (VInt i)      = show i
-    vCast (VRat r)      = showNum $ realToFrac r
+    vCast (VRat r)      = showNum $ (realToFrac r :: Double)
     vCast (VNum n)      = showNum n
     vCast (VList l)     = unwords $ map vCast l
@@ -151 +152 @@
     vCast x             = error $ "cannot cast as Str: " ++ (show x)
 
+showNum :: Show a => a -> String
 showNum x
     | (i, ".0") <- break (== '.') str
@@ -163 +165 @@
 
 instance Value MVal where
-    castV ref = error "bye~" --unsafePerformIO $ readIORef ref
+    castV _ = error "Cannot cast MVal into Value!"
     vCast (MVal x)      = x
     vCast (VRef v)      = vCast v
@@ -209 +211 @@
     castV = id -- XXX not really correct; need to referencify things
 
+strRangeInf :: String -> [String]
 strRangeInf s = (s:strRangeInf (strInc s))
 
+strRange :: String -> String -> [String]
 strRange s1 s2
     | s1 == s2              = [s2]
@@ -216 +220 @@
     | otherwise             = (s1:strRange (strInc s1) s2)
 
+strInc :: String -> String
 strInc []       = "1"
 strInc "z"      = "aa"
@@ -229 +234 @@
     xs  = init str
 
+charInc :: Char -> Char
 charInc x   = chr $ 1 + ord x
 
+intCast :: Num b => Val -> b
 intCast x   = fromIntegral (vCast x :: VInt)
 
@@ -272 +279 @@
     deriving (Show, Eq, Ord)
 
+valType :: Val -> String
 valType VUndef          = "Any"
 valType (VRef v)        = valType v
@@ -342 +350 @@
 instance (Ord a, Ord b) => Ord (FiniteMap a b)
 instance Ord MVal where
-    compare x y = LT -- compare (castV x) (castV y)
+    compare _ _ = EQ -- compare (castV x) (castV y)
 instance Show MVal where
     show _ = "<mval>"
@@ -369 +377 @@
 instance Eq (CharParser Env Exp)
 instance Ord (CharParser Env Exp) where
-    compare _ _ = LT
+    compare _ _ = EQ
 
 extractExp :: Exp -> ([Exp], [String]) -> ([Exp], [String])
-extractExp exp (exps, vs) = (exp':exps, vs')
-    where
-    (exp', vs') = extract (exp, vs)
+extractExp ex (exps, vs) = (ex':exps, vs')
+    where
+    (ex', vs') = extract (ex, vs)
 
 extract :: (Exp, [String]) -> (Exp, [String])
@@ -398 +406 @@
     | otherwise
     = (Var name, vs)
-extract ((Parens exp), vs) = ((Parens exp'), vs')
-    where
-    (exp', vs') = extract (exp, vs)
+extract ((Parens ex), vs) = ((Parens ex'), vs')
+    where
+    (ex', vs') = extract (ex, vs)
 extract other = other
 
+cxtOfSigil :: Char -> String
 cxtOfSigil '$'  = "Scalar"
 cxtOfSigil '@'  = "Array"
 cxtOfSigil '%'  = "Hash"
 cxtOfSigil '&'  = "Code"
+cxtOfSigil x    = internalError $ "cxtOfSigil: unexpected character: " ++ (show x)
 
 --- cxtOf '*' '$'   = "List"
+cxtOf :: Char -> Char -> String
 cxtOf '*' '@'   = "List"
 cxtOf _   _     = "Scalar"
 
-buildParam cxt sigil name exp = Param
+buildParam :: String -> String -> String -> Exp -> Param
+buildParam cxt sigil name e = Param
     { isInvocant    = False
     , isSlurpy      = (sigil == "*")
@@ -420 +432 @@
     , paramName     = name
     , paramContext  = if null cxt then defaultCxt else cxt
-    , paramDefault  = exp
+    , paramDefault  = e
     }
     where
     sig = if null sigil then ' ' else head sigil
     defaultCxt = cxtOf sig (head name) 
+
+defaultArrayParam :: Param
+defaultHashParam :: Param
+defaultScalarParam :: Param
 
 defaultArrayParam   = buildParam "" "*" "@_" (Val VUndef)

src/Bind.hs

@@ -35 +35 @@
 
 bindHash :: [Exp] -> [Param] -> MaybeError [(Param, Exp)]
-bindHash vs []          = return []
+bindHash _ []          = return []
 bindHash [] [p]         = return [ (p, emptyHashExp) ]
 bindHash vs (p:ps@(_:_))= do
@@ -59 +59 @@
 doBindArray :: Exp -> ([(Param, Exp)], VInt) -> (Param, Char) -> MaybeError ([(Param, Exp)], VInt)
 doBindArray _ (xs, -1) (p, '@') = return (((p, emptyArrayExp):xs), -1)
-doBindArray _ (xs, -1) (p, '$') = fail $ "Slurpy array followed by slurpy scalar: " ++ show p
+doBindArray _ (_, -1) (p, '$') = fail $ "Slurpy array followed by slurpy scalar: " ++ show p
 doBindArray v (xs, n)  (p, '@') = return (((p, doSlice v [n..]):xs), -1)
 doBindArray v (xs, n)  (p, '$') = case v of
     (Syn "," [])    -> fail $ "Insufficient arguments for slurpy scalar"
     _               -> return (((p, doIndex v n):xs), n+1)
+doBindArray _ (_, _)  (_, x) = internalError $ "doBindArray: unexpected char: " ++ (show x)
 
 bindEmpty :: Param -> MaybeError (Param, Exp)
@@ -69 +70 @@
     ('@':_) -> return (p, emptyArrayExp)
     ('$':_) -> fail $ "Unbound slurpy scalar: " ++ show p
-    other   -> error $ "Impossible - unknown slurpy sigil in param: " ++ other
+    (x:_)   -> internalError $ "bindEmpty: unexpected char: " ++ (show x)
+    []      -> internalError $ "bindEmpty: empty string encountered"
 
 isPair :: Exp -> Bool
-isPair (Syn "=>" [(Val v), _])   = True
-isPair (Val (VPair (_, _)))             = True
-isPair _                                = False
+isPair (Syn "=>" [(Val _), _])   = True
+isPair (Val (VPair (_, _)))      = True
+isPair _                         = False
 
 unPair :: Exp -> (String, Exp)

src/Cont.hs

@@ -1 @@
-{-# OPTIONS -fglasgow-exts #-}
+{-# OPTIONS -fglasgow-exts -fno-warn-unused-binds #-}
 
 {-

src/Context.hs

@@ -15 +15 @@
 type Cxt = String
 
+countTree :: Tree Type -> Int
 countTree (Node _ []) = 0
 countTree (Node _ cs) = 1 + sum (map countTree cs)
@@ -39 +40 @@
     l2 = findList target tree
 
+castOk :: a -> b -> Bool
 castOk _ _ = True
 
+compareList :: (Eq a) => [a] -> [a] -> Int
 compareList [] _ = 0
 compareList _ [] = 0
@@ -48 +51 @@
     | otherwise = compareList l1 (init l2)
 
+findList :: Eq [a] => [a] -> Tree [a] -> [[a]]
 findList [] _ = []
 findList base (Node l cs)
@@ -56 +60 @@
     found = map (findList base) cs
 
+prettyTypes :: String
 prettyTypes = drawTree initTree
 

src/Eval.hs

@@ -70 +70 @@
 evaluate (Val v@(MVal mv)) = do
     lvalue  <- asks envLValue
-    cxt     <- asks envContext
+    _       <- asks envContext
     if lvalue
         then return v
@@ -122 +122 @@
     shiftT $ \_ -> return $ VError str exp
 
-newMVal val@(MVal r) = newMVal =<< liftIO (readIORef r)
+newMVal (MVal r) = newMVal =<< liftIO (readIORef r)
 newMVal val = do
     mval <- liftIO $ newIORef val
     return $ MVal mval
 
-writeMVal l (MVal r)    = writeMVal l =<< liftIO (readIORef r)
-writeMVal (MVal l) r    = liftIO $ writeIORef l r
-writeMVal l@(VError s e) _ = retError s e
-writeMVal _ l@(VError s e) = retError s e
-writeMVal x y           = retError "Can't write a constant item" (Val x)
+writeMVal l (MVal r)     = writeMVal l =<< liftIO (readIORef r)
+writeMVal (MVal l) r     = liftIO $ writeIORef l r
+writeMVal (VError s e) _ = retError s e
+writeMVal _ (VError s e) = retError s e
+writeMVal x _            = retError "Can't write a constant item" (Val x)
 
 -- readMVal (MVal mv) =  liftIO $ readIORef mv
@@ -144 +144 @@
 reduceStatements ([], exp) = reduceExp exp
 reduceStatements (((exp, pos):rest), lastVal)
-    | Syn "sym" (Sym sym@(Symbol _ _ vexp@(Syn "sub" [sub])):other) <- exp = do
+    | Syn "sym" (Sym sym@(Symbol _ _ vexp@(Syn "sub" [_])):other) <- exp = do
         (VSub sub) <- enterEvalContext "Code" vexp
         lex <- asks envLexical
@@ -178 +178 @@
         reduceStatements ((app, pos):rest, lastVal)
     | null rest = do
-        cxt <- asks envContext
+        _   <- asks envContext
         val <- enterLex (posSyms pos) $ reduceExp exp
         retVal val
@@ -204 +204 @@
 
 evalVar name = do
-    env <- ask
+    _   <- ask
     val <- local (\e -> e{ envLValue = True }) $ do
         rv <- findVar name
@@ -246 +246 @@
 
 -- Reduction for mutables
-reduce env exp@(Val val@(MVal mv)) = do
+reduce _ (Val val@(MVal _)) = do
     lvalue  <- asks envLValue
     if lvalue
@@ -255 +255 @@
 
 -- Reduction for constants
-reduce env exp@(Val v) = do
+reduce _ (Val v) = do
     return v
 
 -- Reduction for variables
-reduce env exp@(Var name) = do
+reduce _ exp@(Var name) = do
     rv <- findVar name
     case rv of
@@ -266 +266 @@
         _ -> retError ("Undefined variable " ++ name) exp
 
-reduce env (Statements stmts) = do
+reduce _ (Statements stmts) = do
     let (global, local) = partition isGlobalExp stmts
     reduceStatements (global ++ local, Val VUndef)
@@ -348 +348 @@
         retVal val
     "::=" -> do -- XXX wrong
-        let [Var name, exp] = exps
-        val     <- evalExp exp
+        let [Var _, exp] = exps
+        evalExp exp
         retVal VUndef -- XXX wrong
     "=>" -> do
@@ -420 +420 @@
         retVal val
 
-reduce env@Env{ envClasses = cls, envContext = cxt, envLexical = lex, envGlobal = glob } exp@(App name invs args) = do
+reduce Env{ envClasses = cls, envContext = cxt, envLexical = lex, envGlobal = glob } exp@(App name invs args) = do
     syms    <- liftIO $ readIORef glob
     subSyms <- mapM evalSym
@@ -428 +428 @@
         ]
     lens    <- mapM argSlurpLen (invs ++ args)
-    case findSub (sum lens) subSyms name of
+    case findSub (sum lens) subSyms of
         Just sub    -> applySub subSyms sub invs args
-        otherwise   -> retError ("No compatible subroutine found: " ++ name) exp
+        Nothing     -> retError ("No compatible subroutine found: " ++ name) exp
     where