Commits

Harald Klimach committed acfd09f

Added interface support for quadruple precision real numbers

While Lua itself supports only floating point numbers with double precision
representation in its default configuration, it might be convenient to have
support for quadruple precision interfaces, if the Fortran compiler supports
it.
This patch adds support for such interfaces if the Fortran compiler has supports
it. Otherwise some dummy code is used to satisfy all dependencies.

Comments (0)

Files changed (14)

source/aot_table_module.f90

   use flu_binding
   use aot_kinds_module, only: double_k, single_k, long_k
   use aot_top_module, only: aot_top_get_val
+  use aot_table_ops_module, only: aot_table_open, aot_table_close, &
+    &                             aot_table_length, aot_table_first, &
+    &                             aot_table_top, aot_table_push
+
+  ! The following module enables an interface for quadruple precision numbers,
+  ! if the compiler supports them. However, you should be aware, that this is
+  ! merely a convenience interface, as the values provided by Lua are only
+  ! double precision.
+  use aot_quadruple_table_module
 
   implicit none
 
   public :: aot_table_set_val, aot_table_set_top
   public :: aot_get_val
 
-  !> This routine provides a way to open a table either as a globally defined
-  !! one, a table within another table or a newly defined one.
-  !!
-  !! After the table is opened, the returned handle can be used to access its
-  !! components.
-  interface aot_table_open
-    module procedure aot_table_global
-    module procedure aot_table_table
-    module procedure aot_table_new
-  end interface
-
   !> Get a value from a table.
   !!
   !! First the given key is looked up, if this fails, the value
 
 contains
 
-  !> Return the position at the top of the stack as a
-  !! table handle.
-  !!
-  !! If it actually exists and is a table, this handle can be used
-  !! for further operations on that table.
-  !! Otherwise a 0 will be returned.
-  function aot_table_top(L) result(thandle)
-    type(flu_state) :: L !< Handle for the Lua script.
-
-    !> A handle for the table on the top of the stack to access it.
-    integer :: thandle
-
-    if (flu_isNoneOrNil(L, -1) .or. (.not. flu_isTable(L, -1))) then
-      thandle = 0
-      call flu_pop(L)
-    else
-      thandle = flu_gettop(L)
-    end if
-  end function aot_table_top
-
-
-  !> Load a globally defined table into the top of the stack.
-  !!
-  !! Return its position in the stack as a handle for this
-  !! table. If it does not exist or the global variable is not
-  !! a table, the handle will be set to 0.
-  subroutine aot_table_global(L, thandle, key)
-    type(flu_state) :: L !< Handle for the Lua script.
-
-    !> A handle for the table to access it, 0 if no table available.
-    integer, intent(out) :: thandle
-
-    !> Name of the global table to access.
-    character(len=*), intent(in) :: key
-
-    call flu_getglobal(L, key)
-
-    thandle = aot_table_top(L)
-  end subroutine aot_table_global
-
-
-  !> This subroutine tries to get a table in a table, and
-  !! return a handle for it.
-  !!
-  !! Return its position in the stack as a handle for this
-  !! table. If it does not exist or the table entry is not
-  !! a table itself, the handle will be set to 0.
-  !! The table can be looked up either by position or name.
-  subroutine aot_table_table(L, parent, thandle, key, pos)
-    type(flu_state) :: L !< Handle for the Lua script.
-
-    !> Handle of the table containing the requested table.
-    integer, intent(in) :: parent
-
-    !> A handle for the table to access it, 0 if no table available.
-    integer, intent(out) :: thandle
-
-    !> Name of the entry in the parent table to access.
-    !!
-    !! The key takes precedence over the position, if both are provided.
-    !! In this case the positional address is only tried, if the access to the
-    !! key failed.
-    character(len=*), intent(in), optional :: key
-
-    !> Position of the entry in the parent table to access.
-    integer, intent(in), optional :: pos
-
-    call aot_table_push(L, parent, key, pos)
-    thandle = aot_table_top(L)
-  end subroutine aot_table_table
-
-
-  !> Open a new, empty table to fill it subsequently.
-  !!
-  !! Return its position in the stack as a handle for this
-  !! table.
-  subroutine aot_table_new(L, thandle)
-    type(flu_state) :: L !< Handle for the Lua script.
-
-    !> A handle for the table to access it.
-    integer, intent(out) :: thandle
-
-    call flu_createtable(L, 0, 0)
-    thandle = flu_gettop(L)
-  end subroutine aot_table_new
-
-  !> Close a table again.
-  !!
-  !! This is done by popping all values above and itself from the stack.
-  subroutine aot_table_close(L, thandle)
-    type(flu_state) :: L !< Handle for the Lua script.
-
-    !> Handle of the table to close.
-    integer, intent(in) :: thandle
-
-    if (thandle > 0) call flu_settop(L, thandle-1)
-  end subroutine aot_table_close
-
-
-  !> This subroutine tries to push the value of the entry given by key or pos
-  !! within the table thandle on the lua stack.
-  !!
-  !! If no corresponding value is found, a nil value is pushed to the stack.
-  !! Key and pos are both optional, but one of them has to be supplied. If one
-  !! is supplied, the key is checked first and only if this fails the entry at
-  !! pos will be looked up.
-  subroutine aot_table_push(L, thandle, key, pos)
-    type(flu_state) :: L !< Handle for the Lua script.
-
-    !> Handle to the table to look in.
-    integer :: thandle
-
-    !> Name of the entry to push to the stack.
-    character(len=*), intent(in), optional :: key
-
-    !> Position of the entry to push to the stack.
-    integer, intent(in), optional :: pos
-
-    if (thandle /= 0) then
-      ! Only proceed if thandle is actually a table
-      ! (Should be received with aot_table_global or aot_table_top)
-
-      if (present(key)) then
-        ! Try to look up the given key first
-        call flu_getfield(L, thandle, key)
-        if (flu_isNoneOrNil(L, -1)) then
-          ! If this is not found, try to retrieve
-          ! the value at the given position
-          if (present(pos)) then
-            call flu_pop(L)
-            call flu_pushInteger(L, pos)
-            call flu_getTable(L, thandle)
-          end if
-        end if
-      else
-        ! No key to look up, just check the given position
-        if (present(pos)) then
-          call flu_pushInteger(L, pos)
-          call flu_getTable(L, thandle)
-        else
-          ! Neither key nor pos present, nothing to look up
-          ! Just push a NIL onto the stack as a result
-          call flu_pushnil(L)
-        end if
-      end if
-
-    else
-
-      call flu_pushnil(L)
-
-    end if
-
-  end subroutine aot_table_push
-
-
-  !> Load the first key-value pair of table thandle on the
-  !! stack.
-  !!
-  !! This serves as an entry point, further traversal
-  !! can be done by flu_next(L, thandle).
-  !! If there are no entries in the table the function
-  !! returns false, otherwise the result will be true.
-  function aot_table_first(L, thandle) result(exists)
-    type(flu_state) :: L !< Handle for the Lua script.
-
-    !> Handle to the table to get the first entry of.
-    integer, intent(in) :: thandle
-
-    !> The return value signals, if there actually is such a first entry.
-    logical :: exists
-
-    if (thandle /= 0) then
-      call flu_pushnil(L)
-      exists = flu_next(L, thandle)
-    else
-      exists = .false.
-    end if
-  end function aot_table_first
-
-
-  !> Count the entries in a lua table.
-  function aot_table_length(L, thandle) result(length)
-    type(flu_state) :: L !< Handle for the Lua script.
-
-    !> Handle of the table to count the enries in.
-    integer, intent(in) :: thandle
-
-    !> Returns the number of entries in the table.
-    integer :: length
-
-    length = 0
-    if (aot_table_first(L, thandle)) then
-      do
-        length = length + 1
-        call flu_pop(L)
-        if (.not. flu_next(L, thandle)) exit
-      end do
-    end if
-  end function aot_table_length
-
-
   !> Retrieve a single precision real value from a table.
   subroutine get_table_real(val, ErrCode, L, thandle, key, pos, default)
     type(flu_State) :: L !< Handle to the Lua script.

source/aot_table_ops_module.f90

+!> This module provides general operations on Lua tables.
+!!
+!! These operations are a common set of actions, that are used by the various
+!! type specific implementations.
+module aot_table_ops_module
+  use flu_binding
+  use aot_kinds_module, only: double_k, single_k, long_k
+  use aot_top_module, only: aot_top_get_val
+
+  implicit none
+
+  private
+
+  public :: aot_table_open, aot_table_close
+  public :: aot_table_top, aot_table_length, aot_table_first, aot_table_push
+
+  !> This routine provides a way to open a table either as a globally defined
+  !! one, a table within another table or a newly defined one.
+  !!
+  !! After the table is opened, the returned handle can be used to access its
+  !! components.
+  interface aot_table_open
+    module procedure aot_table_global
+    module procedure aot_table_table
+    module procedure aot_table_new
+  end interface
+
+contains
+
+  !> Return the position at the top of the stack as a
+  !! table handle.
+  !!
+  !! If it actually exists and is a table, this handle can be used
+  !! for further operations on that table.
+  !! Otherwise a 0 will be returned.
+  function aot_table_top(L) result(thandle)
+    type(flu_state) :: L !< Handle for the Lua script.
+
+    !> A handle for the table on the top of the stack to access it.
+    integer :: thandle
+
+    if (flu_isNoneOrNil(L, -1) .or. (.not. flu_isTable(L, -1))) then
+      thandle = 0
+      call flu_pop(L)
+    else
+      thandle = flu_gettop(L)
+    end if
+  end function aot_table_top
+
+
+  !> Load a globally defined table into the top of the stack.
+  !!
+  !! Return its position in the stack as a handle for this
+  !! table. If it does not exist or the global variable is not
+  !! a table, the handle will be set to 0.
+  subroutine aot_table_global(L, thandle, key)
+    type(flu_state) :: L !< Handle for the Lua script.
+
+    !> A handle for the table to access it, 0 if no table available.
+    integer, intent(out) :: thandle
+
+    !> Name of the global table to access.
+    character(len=*), intent(in) :: key
+
+    call flu_getglobal(L, key)
+
+    thandle = aot_table_top(L)
+  end subroutine aot_table_global
+
+
+  !> This subroutine tries to get a table in a table, and
+  !! return a handle for it.
+  !!
+  !! Return its position in the stack as a handle for this
+  !! table. If it does not exist or the table entry is not
+  !! a table itself, the handle will be set to 0.
+  !! The table can be looked up either by position or name.
+  subroutine aot_table_table(L, parent, thandle, key, pos)
+    type(flu_state) :: L !< Handle for the Lua script.
+
+    !> Handle of the table containing the requested table.
+    integer, intent(in) :: parent
+
+    !> A handle for the table to access it, 0 if no table available.
+    integer, intent(out) :: thandle
+
+    !> Name of the entry in the parent table to access.
+    !!
+    !! The key takes precedence over the position, if both are provided.
+    !! In this case the positional address is only tried, if the access to the
+    !! key failed.
+    character(len=*), intent(in), optional :: key
+
+    !> Position of the entry in the parent table to access.
+    integer, intent(in), optional :: pos
+
+    call aot_table_push(L, parent, key, pos)
+    thandle = aot_table_top(L)
+  end subroutine aot_table_table
+
+
+  !> Open a new, empty table to fill it subsequently.
+  !!
+  !! Return its position in the stack as a handle for this
+  !! table.
+  subroutine aot_table_new(L, thandle)
+    type(flu_state) :: L !< Handle for the Lua script.
+
+    !> A handle for the table to access it.
+    integer, intent(out) :: thandle
+
+    call flu_createtable(L, 0, 0)
+    thandle = flu_gettop(L)
+  end subroutine aot_table_new
+
+  !> Close a table again.
+  !!
+  !! This is done by popping all values above and itself from the stack.
+  subroutine aot_table_close(L, thandle)
+    type(flu_state) :: L !< Handle for the Lua script.
+
+    !> Handle of the table to close.
+    integer, intent(in) :: thandle
+
+    if (thandle > 0) call flu_settop(L, thandle-1)
+  end subroutine aot_table_close
+
+
+  !> This subroutine tries to push the value of the entry given by key or pos
+  !! within the table thandle on the lua stack.
+  !!
+  !! If no corresponding value is found, a nil value is pushed to the stack.
+  !! Key and pos are both optional, but one of them has to be supplied. If one
+  !! is supplied, the key is checked first and only if this fails the entry at
+  !! pos will be looked up.
+  subroutine aot_table_push(L, thandle, key, pos)
+    type(flu_state) :: L !< Handle for the Lua script.
+
+    !> Handle to the table to look in.
+    integer :: thandle
+
+    !> Name of the entry to push to the stack.
+    character(len=*), intent(in), optional :: key
+
+    !> Position of the entry to push to the stack.
+    integer, intent(in), optional :: pos
+
+    if (thandle /= 0) then
+      ! Only proceed if thandle is actually a table
+      ! (Should be received with aot_table_global or aot_table_top)
+
+      if (present(key)) then
+        ! Try to look up the given key first
+        call flu_getfield(L, thandle, key)
+        if (flu_isNoneOrNil(L, -1)) then
+          ! If this is not found, try to retrieve
+          ! the value at the given position
+          if (present(pos)) then
+            call flu_pop(L)
+            call flu_pushInteger(L, pos)
+            call flu_getTable(L, thandle)
+          end if
+        end if
+      else
+        ! No key to look up, just check the given position
+        if (present(pos)) then
+          call flu_pushInteger(L, pos)
+          call flu_getTable(L, thandle)
+        else
+          ! Neither key nor pos present, nothing to look up
+          ! Just push a NIL onto the stack as a result
+          call flu_pushnil(L)
+        end if
+      end if
+
+    else
+
+      call flu_pushnil(L)
+
+    end if
+
+  end subroutine aot_table_push
+
+
+  !> Load the first key-value pair of table thandle on the
+  !! stack.
+  !!
+  !! This serves as an entry point, further traversal
+  !! can be done by flu_next(L, thandle).
+  !! If there are no entries in the table the function
+  !! returns false, otherwise the result will be true.
+  function aot_table_first(L, thandle) result(exists)
+    type(flu_state) :: L !< Handle for the Lua script.
+
+    !> Handle to the table to get the first entry of.
+    integer, intent(in) :: thandle
+
+    !> The return value signals, if there actually is such a first entry.
+    logical :: exists
+
+    if (thandle /= 0) then
+      call flu_pushnil(L)
+      exists = flu_next(L, thandle)
+    else
+      exists = .false.
+    end if
+  end function aot_table_first
+
+
+  !> Count the entries in a lua table.
+  function aot_table_length(L, thandle) result(length)
+    type(flu_state) :: L !< Handle for the Lua script.
+
+    !> Handle of the table to count the enries in.
+    integer, intent(in) :: thandle
+
+    !> Returns the number of entries in the table.
+    integer :: length
+
+    length = 0
+    if (aot_table_first(L, thandle)) then
+      do
+        length = length + 1
+        call flu_pop(L)
+        if (.not. flu_next(L, thandle)) exit
+      end do
+    end if
+  end function aot_table_length
+
+
+end module aot_table_ops_module

source/aot_top_module.f90

   use aot_err_module, only: aoterr_Fatal, aoterr_NonExistent, &
     &                       aoterr_WrongType, aot_err_handler
 
+  ! The following module enables an interface for quadruple precision numbers,
+  ! if the compiler supports them. However, you should be aware, that this is
+  ! merely a convenience interface, as the values provided by Lua are only
+  ! double precision.
+  use aot_quadruple_top_module
+
   implicit none
 
   private

source/aot_vector_module.f90

 module aot_vector_module
   use flu_binding
   use aot_kinds_module, only: double_k, single_k, long_k
-  use aot_table_module, only: aot_table_close, aot_table_top, &
-    &                         aot_table_length, aot_table_push, &
-    &                         aot_table_first
+  use aot_table_ops_module, only: aot_table_close, aot_table_top, &
+    &                             aot_table_length, aot_table_push, &
+    &                             aot_table_first
   use aot_top_module, only: aot_top_get_val, aoterr_NonExistent, aoterr_Fatal
 
+  ! The following module enables an interface for quadruple precision numbers,
+  ! if the compiler supports them. However, you should be aware, that this is
+  ! merely a convenience interface, as the values provided by Lua are only
+  ! double precision.
+  use aot_quadruple_vector_module
+
   implicit none
 
   public :: aot_table_get_val, aot_get_val, aot_top_get_val

source/aotus_module.f90

   use aot_table_module, only: aot_get_val
   use aot_vector_module, only: aot_get_val, aot_top_get_val
 
+  ! The following module enables an interface for quadruple precision numbers,
+  ! if the compiler supports them. However, you should be aware, that this is
+  ! merely a convenience interface, as the values provided by Lua are only
+  ! double precision.
+  use aot_quadruple_module
+
   implicit none
 
   private

source/quadruple/aot_quadruple_module.f90

+module aot_quadruple_module
+  use flu_binding
+  use aot_quadruple_top_module, only: quad_k
+  use aot_top_module, only: aot_top_get_val, aot_err_handler, &
+    &                       aoterr_Fatal, aoterr_NonExistent, aoterr_WrongType
+
+  implicit none
+
+  private
+
+  public :: aot_get_val
+
+  interface aot_get_val
+    module procedure get_config_quadruple
+  end interface
+
+contains
+
+  subroutine get_config_quadruple(val, ErrCode, L, key, default)
+    type(flu_State) :: L !< Handle for the Lua script to get the value from.
+    character(len=*), intent(in) :: key !< Variable name to look for.
+
+    !> Value of the Variable in the script
+    real(kind=quad_k), intent(out) :: val
+
+    !> ErrorCode to indicate what kind of problem might have occured.
+    integer, intent(out) :: ErrCode
+
+    !> Some default value that should be used, if the variable is not set in the
+    !! Lua script.
+    real(kind=quad_k), optional, intent(in) :: default
+
+    call flu_getglobal(L, key)
+    call aot_top_get_val(val, ErrCode, L, default)
+
+  end subroutine get_config_quadruple
+
+end module aot_quadruple_module

source/quadruple/aot_quadruple_table_module.f90

+module aot_quadruple_table_module
+  use flu_binding
+  use aot_kinds_module, only: double_k
+  use aot_quadruple_top_module, only: quad_k
+  use aot_top_module, only: aot_top_get_val
+  use aot_table_ops_module, only: aot_table_open, aot_table_close, &
+    &                             aot_table_length, aot_table_first, &
+    &                             aot_table_top, aot_table_push
+  implicit none
+
+  private
+
+  !> Get a value from a table.
+  !!
+  !! First the given key is looked up, if this fails, the value
+  !! at the given position is looked up, and if this also fails,
+  !! the default value is returned.
+  !! Positional addressing is only valid, as long,
+  !! as no value was provided by an explicit key
+  !! in the list before the entry in question.
+  interface aot_table_get_val
+    module procedure get_table_quadruple
+  end interface
+
+  !> Set a value in a table.
+  !!
+  !! The given value will be put at the entry named by key into the table
+  !! provided in thandle.
+  !! Alternatively you can also put the value by position into the table by
+  !! providing the pos argument.
+  !! If both, pos and key are provided, the key will be used.
+  !! Though, both of them are optional, at least one of them has to be provided.
+  interface aot_table_set_val
+    module procedure set_table_quadruple
+  end interface
+
+  !> Get a value from a table.
+  !!
+  !! First the given key is looked up, if this fails, the value
+  !! at the given position is looked up, and if this also fails,
+  !! the default value is returned.
+  !! Positional addressing is only valid, as long,
+  !! as no value was provided by an explicit key
+  !! in the list before the entry in question.
+  !!
+  !! The interface to access table values looks like:
+  !! `call aot_get_val(val, errCode, L, thandle, key, pos, default)`.
+  !! Position pos and key are both optional, but one of them has to be provided.
+  !! If both are provided the key takes precedence over the pos, and the pos
+  !! will only be tried if the access to the key fails.
+  !! See for example get_table_real() for a more detailed
+  !! description of the parameters.
+  !!
+  !! Note that positional addressing only works intuitively as long as there
+  !! have been no entries specified by keys in the table.
+  !! This kind of resembles the behavior of Fortran interfaces with named or
+  !! unnamed arguments, as soon as you provide a name, all following arguments
+  !! have to be given by key also.
+  !! Just stick to this rule for the Lua tables as well to avoid too much
+  !! headache.
+  !!
+  !! The reason for this is, that positional addressing in Lua refers only to
+  !! the unnamed entries of the tables.
+  interface aot_get_val
+    module procedure get_table_quadruple
+  end interface
+
+  !> This interface enables the simple creation of uniform one dimensional
+  !! arrays as tables in the Lua context.
+  !!
+  !! It takes an one dimensional array of values and returns a thandle to
+  !! identify the newly generated table.
+  interface aot_table_from_1Darray
+    module procedure create_1Darray_quadruple
+  end interface
+
+contains
+
+  !> Retrieve a quadruple precision real value from a table.
+  !!
+  !! NOTE that Lua actually only provides double precision numbers, and this
+  !! interface is merely a convenience for Fortran implementations with
+  !! quadruple precision real numbers.
+  subroutine get_table_quadruple(val, ErrCode, L, thandle, key, pos, &
+    &                            default)
+    type(flu_State) :: L !< Handle to the Lua script.
+
+    !> Handle to the table to look the value up in.
+    integer, intent(in) :: thandle
+
+    !> Value of the table entry if it exists.
+    real(kind=quad_k), intent(out) :: val
+
+    !> Error code to indicate what kind of problem might have occured.
+    integer, intent(out) :: ErrCode
+
+    !> Name of the entry to look for.
+    !!
+    !! Key and pos are both optional, however at least one of them has to be
+    !! supplied.
+    !! The key takes precedence over the pos if both are given.
+    character(len=*), intent(in), optional :: key
+
+    !> Position of the entry to look for in the table.
+    !!
+    !! It allows the access to unnamed arrays in the Lua tables.
+    integer, intent(in), optional :: pos
+
+    !> Some default value, that should be used, if the variable is not set in
+    !! the Lua script.
+    real(kind=quad_k), intent(in), optional :: default
+
+    call aot_table_push(L=L, thandle=thandle, &
+      &                   key=key, pos=pos)
+    call aot_top_get_val(val, ErrCode, L, default)
+
+  end subroutine get_table_quadruple
+
+
+  !> Put a quadruple precision real value into a table.
+  subroutine set_table_quadruple(val, L, thandle, key, pos)
+    type(flu_State) :: L !< Handle to the Lua script.
+
+    !> Handle to the table to look the value up in.
+    integer, intent(in) :: thandle
+
+    !> Value of the table entry if it exists.
+    real(kind=quad_k), intent(in) :: val
+
+    !> Name of the entry to look for.
+    !!
+    !! Key and pos are both optional, however at least one of them has to be
+    !! supplied.
+    !! The key takes precedence over the pos if both are given.
+    character(len=*), intent(in), optional :: key
+
+    !> Position of the entry to look for in the table.
+    !!
+    !! It allows the access to unnamed arrays in the Lua tables.
+    integer, intent(in), optional :: pos
+
+    real(kind=double_k) :: locval
+
+    locval = real(val, kind=double_k)
+
+    if (thandle > 0) then
+      if (present(key)) then
+        ! If there is a key, use that.
+        ! First put the value on the top of the stack
+        call flu_pushNumber(L, locval)
+        ! Now put it into the table
+        call flu_setField(L, thandle, trim(key))
+      else
+        ! No key given, try to put the value by position
+        if (present(pos)) then
+          ! First put the index, where to write the value into the table, on the
+          ! stack.
+          call flu_pushInteger(L, pos)
+          ! Now put the actual value on the top of the stack.
+          call flu_pushNumber(L, locval)
+          ! Get the two entries from the stack into the table.
+          call flu_setTable(L, thandle)
+        end if
+      end if
+    end if
+
+  end subroutine set_table_quadruple
+
+
+  !> This subroutine takes a one dimensional array, and puts it as a table
+  !! into the Lua context.
+  !!
+  !! The returned thandle provides the index to access this newly created
+  !! table.
+  subroutine create_1Darray_quadruple(L, thandle, val)
+    type(flu_State) :: L !< Handle to the Lua script.
+
+    !> Handle to access the newly created table.
+    integer, intent(out) :: thandle
+
+    !> Values to put into the new table.
+    real(kind=quad_k), intent(in) :: val(:)
+
+    integer :: tab
+    integer :: nvals
+    integer :: i
+    real(kind=double_k), allocatable :: locval(:)
+
+    nVals = size(val)
+    allocate(locVal(nVals))
+    locVal = real(val, kind=double_k)
+    call flu_createtable(L, nVals, 0)
+    thandle = flu_gettop(L)
+    tab = thandle
+
+    do i=1,nVals
+      call flu_pushInteger(L, i)
+      call flu_pushNumber(L, locval(i))
+      call flu_settable(L, tab)
+    end do
+
+    deallocate(locval)
+
+  end subroutine create_1Darray_quadruple
+
+
+end module aot_quadruple_table_module

source/quadruple/aot_quadruple_top_module.f90

+module aot_quadruple_top_module
+  use flu_binding
+  use aot_err_module, only: aoterr_Fatal, aoterr_NonExistent, &
+    &                       aoterr_WrongType, aot_err_handler
+
+  implicit none
+
+  private
+
+  public :: aot_top_get_val
+
+  interface aot_top_get_val
+    module procedure aot_top_get_quadruple
+  end interface
+
+  integer, parameter, public :: quad_k = selected_real_kind(33)
+
+contains
+
+  !> Interpret topmost entry on Lua stack as a quadruple precision real.
+  !!
+  !! NOTE that numbers provided by Lua are only double precision.
+  subroutine aot_top_get_quadruple(val, ErrCode, L, default)
+    type(flu_State) :: L !< Handle to the Lua script
+
+    !> Value of the Variable in the script
+    real(kind=quad_k), intent(out) :: val
+
+    !> Error code to indicate what kind of problem might have occured.
+    integer, intent(out) :: ErrCode
+
+    !> Some default value, that should be used, if the variable is not set in
+    !! the Lua script.
+    real(kind=quad_k), optional, intent(in) :: default
+
+    logical :: not_retrievable
+
+    ErrCode = 0
+    not_retrievable = .false.
+
+    if (flu_isNoneOrNil(L, -1)) then
+      ErrCode = ibSet(ErrCode, aoterr_NonExistent)
+      not_retrievable = .true.
+    else
+      if (flu_isNumber(L, -1)) then
+        val = real(flu_toDouble(L, -1), kind=quad_k)
+      else
+        ErrCode = ibSet(ErrCode, aoterr_WrongType)
+        ErrCode = ibSet(ErrCode, aoterr_Fatal)
+        not_retrievable = .true.
+      end if
+    end if
+
+    if (not_retrievable) then
+      if (present(default)) then
+        val = default
+      else
+        ErrCode = ibSet(ErrCode, aoterr_Fatal)
+      end if
+    end if
+    call flu_pop(L)
+
+  end subroutine aot_top_get_quadruple
+
+
+end module aot_quadruple_top_module

source/quadruple/aot_quadruple_vector_module.f90

+!> This module provides some convenience functions to access complete vectors
+!! from a lua table at once.
+!!
+!! It provides two generic interfaces, one for vectors inside tables, and one
+!! for vectors defined as global variables (get_config_val).
+!! Vectors might be accessed with a variable length, to be defined by the
+!! Lua table and allocated in the get_ routines or with a fixed length.
+!! For the variable length vectors, a maximal length has to be provided
+!! up to which the vector might be allocated.
+!! Otherwise the interfaces correspond to the scalar retrieval operations.
+module aot_quadruple_vector_module
+  use flu_binding
+  use aot_quadruple_top_module, only: quad_k
+  use aot_table_ops_module, only: aot_table_close, aot_table_top, &
+    &                             aot_table_length, aot_table_push, &
+    &                             aot_table_first
+  use aot_top_module, only: aot_top_get_val, aoterr_NonExistent, aoterr_Fatal
+
+  implicit none
+
+  public :: aot_table_get_val, aot_get_val, aot_top_get_val
+
+  !> Use these routines to obtain a vector whose length is unknown.
+  !!
+  !! Arrays will be allocated as needed to read the data from the
+  !! Lua script with these routines. A maximal length has to be
+  !! specified to limit the allocated memory by these routines (and make the
+  !! interfaces distinguishable).
+  interface aot_get_val
+    module procedure get_config_quadruple_vvect
+
+    module procedure get_table_quadruple_vvect
+  end interface
+
+  interface aot_table_get_val
+    module procedure get_table_quadruple_vvect
+  end interface
+
+  interface aot_top_get_val
+    module procedure get_top_quadruple_vvect
+  end interface
+
+
+  !> Use these routines to obtain a vector of known length.
+  !!
+  !! The given vector has to exist already and will be filled by
+  !! values from the Lua table, as far as they exist.
+  !! If the Lua table is longer than the available elements in the array
+  !! only the first elements from the table will be stored in the array.
+  interface aot_get_val
+    module procedure get_config_quadruple_v
+
+    module procedure get_table_quadruple_v
+  end interface
+
+  interface aot_table_get_val
+    module procedure get_table_quadruple_v
+  end interface
+
+  interface aot_top_get_val
+    module procedure get_top_quadruple_v
+  end interface
+
+
+  private
+
+
+contains
+
+  !> This routine obtains a vectorial quantity with variable length from a Lua
+  !! table as a whole.
+  !!
+  !! It is intented to ease the reading of vectors on the Fortran side by
+  !! capsulating the parsing of the Lua table internally.
+  !! For the dynamically sized array, which will be allocated, a upper limit
+  !! to allocate has to be specified.
+  subroutine get_table_quadruple_vvect(val, ErrCode, maxlength, L, thandle, &
+    &                                  key, pos, default)
+    type(flu_State) :: L !< Handle to the lua script
+    integer, intent(in) :: thandle !< Handle of the parent table
+
+    !> Vector read from the Lua table, will have the same length as the table
+    !! but not exceed maxlength, if provided.
+    real(kind=quad_k), intent(out), allocatable :: val(:)
+
+    !> Error code describing problems encountered in each of the components.
+    !! Will be allocated with the same length as the returned vector.
+    !! If the complete vector is not given in the Lua script, and no default
+    !! is provided, an zerosized array will be returned.
+    integer, intent(out), allocatable :: ErrCode(:)
+
+    !> Maximal length to allocate for the vector.
+    integer, intent(in) :: maxlength
+
+    !> Name of the variable (vector) to read.
+    character(len=*), intent(in), optional :: key
+
+    !> Position of the (vector) to read.
+    integer, intent(in), optional :: pos
+
+    !> A default vector to use, if no proper definition is found.
+    !! Components will be filled with the help of this default definition.
+    real(kind=quad_k), intent(in), optional :: default(:)
+
+    ! Get the requeseted value from the provided table
+    call aot_table_push(L=L, thandle=thandle, &
+      &                   key=key, pos=pos)
+
+    call aot_top_get_val(val, ErrCode, maxlength, L, default)
+
+  end subroutine get_table_quadruple_vvect
+
+
+  !> This routine obtains a vectorial quantity with variable length from a Lua
+  !! global variable as a whole.
+  !!
+  !! It is intented to ease the reading of vectors on the Fortran side by
+  !! capsulating the parsing of the Lua table internally.
+  !! For the dynamically sized array, which will be allocated, a upper limit
+  !! to allocate has to be specified.
+  subroutine get_config_quadruple_vvect(val, ErrCode, maxlength, L, &
+    &                                   key, default)
+    type(flu_State) :: L !< Handle to the lua script
+
+    !> Vector read from the Lua table, will have the same length as the table
+    !! but not exceed maxlength, if provided.
+    real(kind=quad_k), intent(out), allocatable :: val(:)
+
+    !> Error code describing problems encountered in each of the components.
+    !! Will be allocated with the same length as the returned vector.
+    !! If the complete vector is not given in the Lua script, and no default
+    !! is provided, an zerosized array will be returned.
+    integer, intent(out), allocatable :: ErrCode(:)
+
+    !> Maximal length to allocate for the vector.
+    integer, intent(in) :: maxlength
+
+    !> Name of the variable (vector) to read.
+    character(len=*), intent(in) :: key
+
+    !> A default vector to use, if no proper definition is found.
+    !! Components will be filled with the help of this default definition.
+    real(kind=quad_k), intent(in), optional :: default(:)
+
+    ! Get the requeseted global variable
+    call flu_getglobal(L, key)
+
+    call aot_top_get_val(val, ErrCode, maxlength, L, default)
+
+  end subroutine get_config_quadruple_vvect
+
+
+  !> This routine obtains a vectorial quantity with fixed length from a Lua
+  !! table as a whole.
+  !!
+  !! It is intented to ease the reading of vectors on the Fortran side by
+  !! capsulating the parsing of the Lua table internally.
+  !! Components which are not found are filled with the data given in
+  !! the default vector. For each component an error code will be returned
+  !! to indicate the success when reading it.
+  !! If the vector is not defined at all, all components will be indicated
+  !! as non-existent.
+  !! Components, which are neither defined in the Lua script, nor in the
+  !! default will be marked with the aoterr_Fatal flag.
+  subroutine get_table_quadruple_v(val, ErrCode, L, thandle, key, &
+    &                         pos, default)
+    type(flu_State) :: L !< Handle to the lua script
+    integer, intent(in) :: thandle !< Handle of the parent table
+
+    !> Vector read from the Lua table.
+    real(kind=quad_k), intent(out) :: val(:)
+
+    !> Error code describing problems encountered in each of the components.
+    !! This array has to have the same length as val.
+    integer, intent(out) :: ErrCode(:)
+
+    !> Name of the variable (vector) to read.
+    character(len=*), intent(in), optional :: key
+
+    !> Position of the (vector) to read.
+    integer, intent(in), optional :: pos
+
+    !> A default vector to use, if no proper definition is found.
+    !! Components will be filled with the help of this default definition.
+    real(kind=quad_k), intent(in), optional :: default(:)
+
+    ! Get the requeseted value from the provided table
+    call aot_table_push(L=L, thandle=thandle, &
+      &                 key=key, pos=pos)
+
+    call aot_top_get_val(val, ErrCode, L, default)
+  end subroutine get_table_quadruple_v
+
+
+  !> This routine obtains a vectorial quantity with fixed length from a Lua
+  !! global variable as a whole.
+  !!
+  !! It is intented to ease the reading of vectors on the Fortran side by
+  !! capsulating the parsing of the Lua table internally.
+  !! Components which are not found are filled with the data given in
+  !! the default vector. For each component an error code will be returned
+  !! to indicate the success when reading it.
+  !! If the vector is not defined at all, all components will be indicated
+  !! as non-existent.
+  !! Components, which are neither defined in the Lua script, nor in the
+  !! default will be marked with the aoterr_Fatal flag.
+  subroutine get_config_quadruple_v(val, ErrCode, L, key, default)
+    type(flu_State) :: L !< Handle to the lua script
+
+    !> Vector read from the Lua table.
+    real(kind=quad_k), intent(out) :: val(:)
+
+    !> Error code describing problems encountered in each of the components.
+    !! This array has to have the same length as val.
+    integer, intent(out) :: ErrCode(:)
+
+    !> Name of the variable (vector) to read.
+    character(len=*), intent(in) :: key
+
+    !> A default vector to use, if no proper definition is found.
+    !! Components will be filled with the help of this default definition.
+    real(kind=quad_k), intent(in), optional :: default(:)
+
+    ! Get the requeseted value from the provided table
+    call flu_getglobal(L, key)
+
+    call aot_top_get_val(val, ErrCode, L, default)
+  end subroutine get_config_quadruple_v
+
+
+  subroutine get_top_quadruple_vvect(val, ErrCode, maxlength, L, default)
+    type(flu_State) :: L !< Handle to the lua script
+
+    !> Vector read from the Lua table, will have the same length as the table
+    !! but not exceed maxlength, if provided.
+    real(kind=quad_k), intent(out), allocatable :: val(:)
+
+    !> Error code describing problems encountered in each of the components.
+    !! Will be allocated with the same length as the returned vector.
+    !! If the complete vector is not given in the Lua script, and no default
+    !! is provided, an zerosized array will be returned.
+    integer, intent(out), allocatable :: ErrCode(:)
+
+    !> Maximal length to allocate for the vector.
+    integer, intent(in) :: maxlength
+
+    !> A default vector to use, if no proper definition is found.
+    !! Components will be filled with the help of this default definition.
+    real(kind=quad_k), intent(in), optional :: default(:)
+
+    integer :: vect_handle
+    integer :: table_len, vect_len, def_len
+    integer :: vect_lb
+    integer :: iComp
+
+    ! Try to interpret the top entry on the stack as a table
+    vect_handle = aot_table_top(L=L)
+    table_len = aot_table_length(L=L, thandle=vect_handle)
+
+    ! The size of the vector is limited by maxlength.
+    vect_len = min(maxlength, table_len)
+
+    ! Find the length of the default value, if it is not provided, its 0.
+    def_len = 0
+    if (present(default)) def_len = size(default)
+
+    ! Now parse the table with the vector entries.
+    if (aot_table_first(L, vect_handle)) then
+      allocate(val(vect_len))
+      allocate(errCode(vect_len))
+
+      ! Only if the vector table actually exists, and has at least one entry,
+      ! this parsing has to be done.
+      if (present(default).and.(def_len > 0)) then
+        call aot_top_get_val(val(1), ErrCode(1), L, default(1))
+      else
+        call aot_top_get_val(val(1), ErrCode(1), L)
+      end if
+
+      ! Up to the length of the default value, provide the default settings.
+      do iComp=2,def_len
+        if (.not. flu_next(L, vect_handle)) exit
+        call aot_top_get_val(val(iComp), ErrCode(iComp), L, &
+          &                  default(iComp))
+      end do
+
+      vect_lb = max(2, def_len+1)
+      ! After def_len entries no default values for the components are
+      ! available anymore, proceed without a default setting for the rest.
+      do iComp=vect_lb,vect_len
+        if (.not. flu_next(L, vect_handle)) exit
+        call aot_top_get_val(val(iComp), ErrCode(iComp), L)
+      end do
+    else
+      ! No vector definition found in the Lua script, use the default.
+      if (present(default)) then
+        allocate(val(def_len))
+        allocate(errCode(vect_len))
+        val = default
+        ErrCode = ibSet(ErrCode, aoterr_NonExistent)
+      else
+        ! No vector definition in the Lua script and no default provided,
+        ! return an empty array.
+        allocate(val(0))
+        allocate(errCode(0))
+      end if
+    end if
+    call aot_table_close(L, vect_handle)
+
+  end subroutine get_top_quadruple_vvect
+
+
+  subroutine get_top_quadruple_v(val, ErrCode, L,  default)
+    type(flu_State) :: L !< Handle to the lua script
+
+    !> Vector read from the Lua table.
+    real(kind=quad_k), intent(out) :: val(:)
+
+    !> Error code describing problems encountered in each of the components.
+    !! This array has to have the same length as val.
+    integer, intent(out) :: ErrCode(:)
+
+    !> A default vector to use, if no proper definition is found.
+    !! Components will be filled with the help of this default definition.
+    real(kind=quad_k), intent(in), optional :: default(:)
+
+    integer :: vect_handle
+    integer :: table_len, vect_len, def_len
+    integer :: vect_lb
+    integer :: iComp
+
+    ! Try to interpret it as table.
+    vect_handle = aot_table_top(L=L)
+    table_len = aot_table_length(L=L, thandle=vect_handle)
+
+    vect_len = min(table_len, size(val))
+
+    ! Find the length of the default value, if it is not provided, its 0.
+    def_len = 0
+    if (present(default)) def_len = size(default)
+
+    ! Now parse the table with the vector entries.
+    if (aot_table_first(L, vect_handle).and.(vect_len > 0)) then
+
+      ! Only if the vector table actually exists, and has at least one entry,
+      ! this parsing has to be done.
+      if (present(default).and.(def_len > 0)) then
+        call aot_top_get_val(val(1), ErrCode(1), L, default(1))
+      else
+        call aot_top_get_val(val(1), ErrCode(1), L)
+      end if
+
+      ! Up to the length of the default value, provide the default settings.
+      do iComp=2,def_len
+        if (.not. flu_next(L, vect_handle)) exit
+        call aot_top_get_val(val(iComp), ErrCode(iComp), L, &
+          &                  default(iComp))
+      end do
+
+      vect_lb = max(2, def_len+1)
+      ! After def_len entries no default values for the components are
+      ! available anymore, proceed without a default setting for the rest.
+      do iComp=vect_lb,vect_len
+        if (.not. flu_next(L, vect_handle)) exit
+        call aot_top_get_val(val(iComp), ErrCode(iComp), L)
+      end do
+
+      ! If the table in the Lua script is not long enough, fill the remaining
+      ! components with the default components, as far as they are defined.
+      do iComp=vect_len+1,def_len
+        ErrCode(iComp) = ibSet(ErrCode(iComp), aoterr_NonExistent)
+        val(iComp) = default(iComp)
+      end do
+      vect_lb = max(vect_len+1, def_len)
+      do iComp=vect_lb,vect_len
+        ErrCode(iComp) = ibSet(ErrCode(iComp), aoterr_Fatal)
+      end do
+    else
+      ! No vector definition found in the Lua script, use the default.
+      ErrCode = ibSet(ErrCode, aoterr_NonExistent)
+      if (present(default)) then
+        val(:def_len) = default(:def_len)
+        if (def_len < vect_len) then
+          ErrCode(def_len+1:) = ibSet(ErrCode(def_len+1:), aoterr_Fatal)
+        end if
+      else
+        ! No vector definition in the Lua script and no default provided.
+        ErrCode = ibSet(ErrCode, aoterr_Fatal)
+      end if
+    end if
+    call aot_table_close(L, vect_handle)
+
+  end subroutine get_top_quadruple_v
+
+
+end module aot_quadruple_vector_module

source/quadruple/dummy_quadruple_module.f90

+module aot_quadruple_module
+  implicit none
+
+  private
+
+  integer, parameter :: quad_k = selected_real_kind(33)
+
+end module aot_quadruple_module

source/quadruple/dummy_quadruple_table_module.f90

+module aot_quadruple_table_module
+  implicit none
+
+  private
+
+end module aot_quadruple_table_module

source/quadruple/dummy_quadruple_top_module.f90

+module aot_quadruple_top_module
+
+  implicit none
+
+  private
+
+  integer, parameter :: quad_k = selected_real_kind(33)
+
+end module aot_quadruple_top_module

source/quadruple/dummy_quadruple_vector_module.f90

+module aot_quadruple_vector_module
+
+  implicit none
+
+  private
+
+  integer, parameter :: quad_k = selected_real_kind(33)
+
+end module aot_quadruple_vector_module
                   header_name=['stdio.h'],
                   defines=['LUA_USE_POPEN=1'],
                   uselib_store='POPEN', mandatory=False)
+
+    conf.check_fc(fragment = '''
+       program checkquad
+         implicit none
+         integer, parameter :: quad_k = selected_real_kind(33)
+         real(kind=quad_k) :: a_quad_real
+       end program checkquad''',
+                  msg = 'Checking for Quadruple Precision',
+                  mandatory=False, define_name='quadruple')
+    conf.env['quad_support'] = conf.is_defined('quadruple')
     # Cleanup the DEFINES again
     conf.env.DEFINES = tmpDEF
 
+
 def build(bld):
     core_sources = ['external/lua-5.2.1/src/lapi.c',
                     'external/lua-5.2.1/src/lcode.c',
                      'source/aot_fun_module.f90',
                      'source/aot_kinds_module.f90',
                      'source/aot_table_module.f90',
+                     'source/aot_table_ops_module.f90',
                      'source/aot_top_module.f90',
 		     'source/aot_out_module.f90',
                      'source/aot_path_module.f90',
                      'source/aot_vector_module.f90']
 
+    if bld.env['quad_support']:
+        aotus_sources += ['source/quadruple/aot_quadruple_module.f90']
+        aotus_sources += ['source/quadruple/aot_quadruple_table_module.f90']
+        aotus_sources += ['source/quadruple/aot_quadruple_top_module.f90']
+        aotus_sources += ['source/quadruple/aot_quadruple_vector_module.f90']
+    else:
+        aotus_sources += ['source/quadruple/dummy_quadruple_module.f90']
+        aotus_sources += ['source/quadruple/dummy_quadruple_table_module.f90']
+        aotus_sources += ['source/quadruple/dummy_quadruple_top_module.f90']
+        aotus_sources += ['source/quadruple/dummy_quadruple_vector_module.f90']
+
     bld(
         features = 'c',
         source = core_sources + lib_sources,