Ada: exception support

repos/libports/include/ada/exception.h

@@ -0,0 +1,18 @@
+
+#include <base/exception.h>
+
+namespace Ada {
+    namespace Exception {
+        class Program_Error : Genode::Exception {};
+        class Constraint_Error : Genode::Exception {};
+        class Storage_Error : Genode::Exception {};
+
+        class Length_Check : Constraint_Error {};
+        class Overflow_Check : Constraint_Error {};
+        class Invalid_Data : Constraint_Error {};
+        class Range_Check : Constraint_Error {};
+        class Index_Check : Constraint_Error {};
+        class Discriminant_Check : Constraint_Error {};
+        class Divide_By_Zero : Constraint_Error {};
+    };
+};

repos/libports/lib/mk/ada.mk

@@ -3,7 +3,7 @@ include $(REP_DIR)/lib/import/import-ada.mk
 ADALIB = $(ADA_RTS)/adalib
 ADAINCLUDE = $(ADA_RTS)/adainclude
 
-PACKAGES = system s-stoele s-secsta
+PACKAGES = system s-stoele s-secsta a-except s-conca2
 
 body_exists := $(filter $1.adb,$(shell if [ -e $2/$1.adb ]; then echo $1.adb; fi))
 
@@ -18,10 +18,10 @@ CUSTOM_ADA_OPT     = $(CC_ADA_OPT)
 CUSTOM_ADA_INCLUDE = -I- -I$(REP_DIR)/src/lib/ada/runtime -I$(ADA_RTS_SOURCE) -I$(REP_DIR)/src/lib/ada/runtimelib
 
 # pure C runtime implementations
-SRC_CC += a-except_c.cc s-soflin_c.cc
+SRC_CC += a-except_c.cc s-soflin_c.cc a-exctab_c.cc
 
 # C runtime glue code
-SRC_CC += s-secsta_c.cc gnat_except.cc
+SRC_CC += s-secsta_c.cc
 
 # Ada packages that implement runtime functionality
 SRC_ADB += ss_utils.adb

repos/libports/run/ada_exception.run

@@ -0,0 +1,33 @@
+build "core init test/ada_exception"
+
+create_boot_directory
+
+install_config {
+	<config>
+		<parent-provides>
+			<service name="LOG"/>
+			<service name="PD"/>
+			<service name="CPU"/>
+			<service name="ROM"/>
+		</parent-provides>
+		<default-route>
+			<any-service> <parent/> </any-service>
+		</default-route>
+		<default caps="100"/>
+		<start name="test-ada_exception">
+			<resource name="RAM" quantum="10M"/>
+		</start>
+	</config>
+}
+
+build_boot_image "core ld.lib.so ada.lib.so init test-ada_exception"
+
+append qemu_args "-nographic "
+
+run_genode_until {child "test-ada_secondary_stack" exited with exit value 0.*} 20
+
+grep_output {successful}
+
+compare_output_to {
+	[init -> test-ada_secondary_stack] secondary stack test successful
+}

repos/libports/src/lib/ada/runtime/a-except.adb

@@ -0,0 +1,70 @@
+package body Ada.Exceptions is
+
+   ----------------------------
+   -- Raise_Exception_Always --
+   ----------------------------
+
+   procedure Raise_Exception_Always (
+                                     E       : Exception_Id;
+                                     Message : String := ""
+                                    )
+   is
+      procedure Raise_Ada_Exception (
+                                     Name : System.Address;
+                                     Msg  : System.Address
+                                    )
+        with
+          Import,
+          Convention => C,
+          External_Name => "raise_ada_exception";
+      C_Msg : String := Message & Character'Val (0);
+   begin
+      Warn_Not_Implemented ("Raise_Exception_Always");
+      Raise_Ada_Exception (E.Full_Name, C_Msg'Address);
+   end Raise_Exception_Always;
+
+   procedure Raise_Exception (
+                              E       : Exception_Id;
+                              Message : String := ""
+                             )
+   is
+   begin
+      Raise_Exception_Always (E, Message);
+   end Raise_Exception;
+
+   procedure Reraise_Occurrence_No_Defer (
+                                          X : Exception_Occurrence
+                                         )
+   is
+      pragma Unreferenced (X);
+   begin
+      Warn_Not_Implemented ("Reraise_Occurrence_No_Defer");
+   end Reraise_Occurrence_No_Defer;
+
+   procedure Save_Occurrence (
+                              Target : out Exception_Occurrence;
+                              Source : Exception_Occurrence
+                             )
+   is
+   begin
+      Warn_Not_Implemented ("Save_Occurrence");
+      Target := Source;
+   end Save_Occurrence;
+
+   procedure Warn_Not_Implemented (
+                                   Name : String
+                                  )
+   is
+      procedure C_Warn_Unimplemented_Function (
+                                               Func : System.Address
+                                              )
+        with
+          Import,
+          Convention => C,
+          External_Name => "warn_unimplemented_function";
+      C_Name : String := Name & Character'Val (0);
+   begin
+      C_Warn_Unimplemented_Function (C_Name'Address);
+   end Warn_Not_Implemented;
+
+end Ada.Exceptions;

repos/libports/src/lib/ada/runtime/a-except.ads

@@ -0,0 +1,60 @@
+with System;
+
+package Ada.Exceptions is
+
+   type Exception_Id is private;
+   type Exception_Occurrence is limited private;
+   type Exception_Occurrence_Access is access all Exception_Occurrence;
+
+   procedure Raise_Exception_Always (
+                                     E : Exception_Id;
+                                     Message : String := ""
+                                    )
+     with
+       Export,
+       Convention => Ada,
+       External_Name => "__gnat_raise_exception";
+
+   procedure Raise_Exception (
+                              E : Exception_Id;
+                              Message : String := ""
+                             );
+
+   procedure Reraise_Occurrence_No_Defer (
+                                          X : Exception_Occurrence
+                                         );
+
+   procedure Save_Occurrence (
+                              Target : out Exception_Occurrence;
+                              Source : Exception_Occurrence
+                             );
+
+private
+
+   --  the following declarations belong to s-stalib.ads
+   --  begin s-stalib.ads
+   type Exception_Data;
+   type Exception_Data_Ptr is access all Exception_Data;
+   type Raise_Action is access procedure;
+
+   type Exception_Data is record
+      Not_Handled_By_Others : Boolean;
+      Lang                  : Character;
+      Name_Length           : Natural;
+      Full_Name             : System.Address;
+      HTable_Ptr            : Exception_Data_Ptr;
+      Foreign_Data          : System.Address;
+      Raise_Hook            : Raise_Action;
+   end record;
+   --  end s-stalib.ads
+
+   type Exception_Id is new Exception_Data_Ptr;
+   type Exception_Occurrence is record
+      null;
+   end record;
+
+   procedure Warn_Not_Implemented (
+                                   Name : String
+                                  );
+
+end Ada.Exceptions;

repos/libports/src/lib/ada/runtime/s-secsta.ads

@@ -21,6 +21,9 @@ package System.Secondary_Stack is
 
 private
 
+   SS_Pool : Integer;
+   --  This is not used but needed since the build will fail otherwise
+
    type Mark_Id is record
       Sstk : System.Address;
       Sptr : SSE.Integer_Address;

repos/libports/src/lib/ada/runtimelib/a-except.h

@@ -1,7 +0,0 @@
-
-extern "C" {
-
-    void ada__exceptions__reraise_occurrence_no_defer();
-    void ada__exceptions__save_occurrence();
-
-}

repos/libports/src/lib/ada/runtimelib/a-except_c.cc

@@ -1,16 +1,97 @@
 
 #include <base/log.h>
+#include <util/string.h>
+#include <ada/exception.h>
 
 extern "C" {
 
-    void ada__exceptions__reraise_occurrence_no_defer()
+    /* Program Error */
+    void __gnat_rcheck_PE_Explicit_Raise(char *file, int line)
     {
-        Genode::warning(__func__, " not implemented");
+        Genode::error("Program Error in ", Genode::Cstring(file), " at line ", line);
+        throw Ada::Exception::Program_Error();
     }
 
-    void ada__exceptions__save_occurrence()
+    /* Constraint Error */
+    void __gnat_rcheck_CE_Explicit_Raise(char *file, int line)
     {
-        Genode::warning(__func__, " not implemented");
+        Genode::error("Constraint Error in ", Genode::Cstring(file), " at line ", line);
+        throw Ada::Exception::Constraint_Error();
+    }
+
+    /* Storage Error */
+    void __gnat_rcheck_SE_Explicit_Raise(char *file, int line)
+    {
+        Genode::error("Storage Error in ", Genode::Cstring(file), " at line ", line);
+        throw Ada::Exception::Storage_Error();
+    }
+
+    /* Constraint Error subtypes */
+
+    /* Length check failed */
+    void __gnat_rcheck_CE_Length_Check(char *file, int line)
+    {
+        Genode::error("Constraint Error: Length check failed in ",
+                Genode::Cstring(file), " at line ", line);
+        throw Ada::Exception::Length_Check();
+    }
+
+    /* Overflow check failed */
+    void __gnat_rcheck_CE_Overflow_Check(char *file, int line)
+    {
+        Genode::error("Constraint Error: Overflow check failed in ",
+                Genode::Cstring(file), " at line ", line);
+        throw Ada::Exception::Overflow_Check();
+    }
+
+    /* Invalid data */
+    void __gnat_rcheck_CE_Invalid_Data(char *file, int line)
+    {
+        Genode::error("Constraint Error: Invalid data in ",
+                Genode::Cstring(file), " at line ", line);
+        throw Ada::Exception::Invalid_Data();
+    }
+
+    /* Range check failed */
+    void __gnat_rcheck_CE_Range_Check(char *file, int line)
+    {
+        Genode::error("Constraint Error: Range check failed in ",
+                Genode::Cstring(file), " at line ", line);
+        throw Ada::Exception::Range_Check();
+    }
+
+    /* Index check failed */
+    void __gnat_rcheck_CE_Index_Check(char *file, int line)
+    {
+        Genode::error("Constraint Error: Index check failed in ",
+                Genode::Cstring(file), " at line ", line);
+        throw Ada::Exception::Index_Check();
+    }
+
+    /* Discriminant check failed */
+    void __gnat_rcheck_CE_Discriminant_Check(char *file, int line)
+    {
+        Genode::error("Constraint Error: Discriminant check failed in ",
+                Genode::Cstring(file), " at line ", line);
+        throw Ada::Exception::Discriminant_Check();
+    }
+
+    /* Divide by 0 */
+    void __gnat_rcheck_CE_Divide_By_Zero (char *file, int line)
+    {
+        Genode::error("Constraint Error: Divide by zero in ",
+                Genode::Cstring(file), " at line ", line);
+        throw Ada::Exception::Divide_By_Zero();
+    }
+
+    void raise_ada_exception(char *name, char *message)
+    {
+        Genode::error(Genode::Cstring(name), " raised: ", Genode::Cstring(message));
+    }
+
+    void warn_unimplemented_function(char *func)
+    {
+        Genode::warning(Genode::Cstring(func), " unimplemented");
     }
 
 }

repos/libports/src/lib/ada/runtimelib/a-exctab_c.cc

@@ -0,0 +1,11 @@
+
+#include <base/log.h>
+
+extern "C" {
+
+    void system__exception_table__register()
+    {
+        Genode::warning(__func__, " not implemented");
+    }
+
+}

repos/libports/src/lib/ada/runtimelib/gnat_except.cc

@@ -1,21 +0,0 @@
-
-#include <base/log.h>
-
-extern "C" {
-
-    void __gnat_rcheck_CE_Explicit_Raise()
-    {
-        Genode::warning("Unhandled Ada exception: Constraint_Error");
-    }
-
-    void __gnat_rcheck_SE_Explicit_Raise()
-    {
-        Genode::warning("Unhandled Ada exception: Storage_Error");
-    }
-
-    void __gnat_rcheck_PE_Explicit_Raise()
-    {
-        Genode::warning("Unhandled Ada exception: Program_Error");
-    }
-
-}

repos/libports/src/lib/ada/runtimelib/s-soflin.h

@@ -1,9 +0,0 @@
-
-extern "C" {
-
-    void system__soft_links__get_current_excep();
-    void system__soft_links__get_gnat_exception();
-    void system__soft_links__get_jmpbuf_address_soft();
-    void system__soft_links__set_jmpbuf_address_soft();
-
-}

repos/libports/src/lib/ada/runtimelib/s-soflin_c.cc

@@ -23,4 +23,14 @@ extern "C" {
         Genode::warning(__func__, " not implemented");
     }
 
+    void system__soft_links__lock_task()
+    {
+        Genode::warning(__func__, " not implemented");
+    }
+
+    void system__soft_links__unlock_task()
+    {
+        Genode::warning(__func__, " not implemented");
+    }
+
 }

repos/libports/src/test/ada_exception/except.adb

@@ -0,0 +1,9 @@
+package body Except is
+
+    procedure Raise_Task
+    is
+    begin
+        raise Program_Error;
+    end Raise_Task;
+
+end Except;

repos/libports/src/test/ada_exception/except.ads

@@ -0,0 +1,5 @@
+package Except is
+
+    procedure Raise_Task;
+
+end Except;

repos/libports/src/test/ada_exception/main.cc

@@ -0,0 +1,14 @@
+
+#include <base/log.h>
+#include <base/component.h>
+
+extern "C" void except__raise_task();
+
+void Component::construct(Genode::Env &env)
+{
+    Genode::log("Ada exception test");
+
+    except__raise_task();
+
+    env.parent().exit(0);
+}

repos/libports/src/test/ada_exception/target.mk

@@ -0,0 +1,5 @@
+TARGET   = test-ada_exception
+SRC_ADB  = except.adb
+SRC_CC   = main.cc
+LIBS     = base ada
+INC_DIR += $(PRG_DIR)