Only allow to raise and catch exceptions deriving from BaseException

src/Hython/ExceptionHandling.hs

@@ -3,29 +3,44 @@ where
 
 import Control.Monad.Cont.Class (MonadCont)
 import Data.Text (Text)
+import qualified Data.Text as T
 
 import Hython.Call (call)
+import Hython.Class (isSubClass)
 import Hython.ControlFlow (getExceptionHandler, setCurrentException)
 import Hython.Environment (MonadEnv, lookupName)
-import Hython.Types (MonadInterpreter, newString, Object)
+import Hython.Types hiding (raise)
 import qualified Hython.Types as Types
 
-raise :: MonadInterpreter m => Object -> m ()
-raise exception = do
-    handler <- getExceptionHandler
 
-    setCurrentException exception
-    handler exception
+raiseOr :: (MonadEnv Object m, MonadInterpreter m) => m () -> Object -> m ()
+raiseOr raiseError exc@(Object objectInfo) = do
+    mBaseClass <- lookupName (T.pack "BaseException")
+    case mBaseClass of
+        Just (Class baseClassInfo) ->
+            if isSubClass (objectClass objectInfo) baseClassInfo
+                then do
+                    handler <- getExceptionHandler
+                    setCurrentException exc
+                    handler exc
+                else raiseError
+        _ -> Types.raise "SystemError" "could not find BaseException class"
+raiseOr raiseError _ = raiseError
+
+raiseExternal :: (MonadEnv Object m, MonadInterpreter m) => Object -> m ()
+raiseExternal =
+    raiseOr $ Types.raise "TypeError" "exceptions must derive from BaseException"
 
 raiseInternal :: (MonadCont m, MonadEnv Object m, MonadInterpreter m) => Text -> Text -> m ()
 raiseInternal clsName description = do
     mcls <- lookupName clsName
     case mcls of
-        Just obj    -> do
+        Just cls@(Types.Class _) -> do
             descriptionStr  <- newString description
-            exception       <- call obj [descriptionStr] []
-            raise exception
-        _           -> Types.raise "TypeError" "exceptions must derive from BaseException"
-
-
+            exception       <- call cls [descriptionStr] []
+            raiseOr raiseError exception
+        _ -> raiseError
+  where
+    raiseError = Types.raise "SystemError" ("internally raised invalid exception "
+                     ++ T.unpack clsName ++ "(\"" ++ T.unpack description ++ "\")")
 

src/Hython/Interpreter.hs

@@ -118,7 +118,7 @@ defaultExceptionHandler ex = do
                 putStr . T.unpack . className . objectClass $ info
                 putStr ": "
                 putStrLn msg
-        _ -> liftIO $ putStrLn "o_O: raised a non-object exception"
+        _ -> liftIO $ putStrLn "SystemError: uncaught non-object exception"
 
     liftIO exitFailure
 

src/Hython/Statement.hs

@@ -17,9 +17,10 @@ import qualified Data.Text as T
 import Language.Python
 
 import Hython.Builtins (isInstance, len, setAttr)
+import Hython.Class (isSubClass)
 import Hython.ControlFlow
 import Hython.Environment
-import qualified Hython.ExceptionHandling as EH
+import Hython.ExceptionHandling (raiseExternal)
 import Hython.Expression (evalExpr, evalParam)
 import qualified Hython.Module as Module
 import Hython.Ref
@@ -173,7 +174,7 @@ eval (Nonlocal names) = mapM_ bindNonlocal names
 
 eval (Pass) = return ()
 
-eval (Raise expr _from) = EH.raise =<< evalExpr expr
+eval (Raise expr _from) = raiseExternal =<< evalExpr expr
 
 eval (Reraise) = do
     mexception  <- getCurrentException
@@ -201,13 +202,14 @@ eval (Try clauses block elseBlock finallyBlock) = do
     -- Evaluate exception handler clauses
     handlers <- forM clauses $ \(ExceptClause expr name handlerBlock) -> do
         mcls <- evalExpr expr
-        case mcls of
-            (Class cls) -> return . Just $ ExceptionHandler name cls handlerBlock
-            _           -> do
-                raise "SyntaxError" "invalid class in except block header"
+        mBaseClass <- lookupName (T.pack "BaseException")
+        case (mcls, mBaseClass) of
+            (Class cls, Just (Class baseClass)) | isSubClass cls baseClass ->
+                return . Just $ ExceptionHandler name cls handlerBlock
+            _ -> do
+                raise "TypeError" "catching classes that do not inherit from BaseException is not allowed"
                 return Nothing
 
-    --
     exception <- callCC $ \handler -> do
         setExceptionHandler handler
 

test/control/exception.py

@@ -263,8 +263,7 @@ def test_finally_block_raises_exception():
 try:
     raise Exception("test")
 except Exception as e:
-    if e != None:           # Test that e exists since we don't implement __str__
-        print("Exists!")
+    print(e)
 
 # Test that the correct handler is located, even if it exists in outer scopes
 def test_caught_by_outside_handlers():
@@ -341,3 +340,30 @@ def test_return_in_while():
     print(test_return_in_while())
 finally:
     print("OK!")
+
+# Test that only objects can be raised
+try:
+    raise 3
+except TypeError as e:
+    print("TypeError1")
+
+# Test that only classes derived from BaseException can be raised
+class T:
+    def __str__(self):
+        return "T"
+
+try:
+    raise T("e")
+except TypeError:
+    print("TypeError2")
+
+# Test that only classes derived from BaseException can be caught
+try:
+    try:
+        raise Exception("test")
+    except T:
+        pass
+except TypeError:
+    print("TypeError3")
+except:
+    print("caught something else")