!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!
module cubetools_userspace
  use gkernel_interfaces
  use gkernel_types
  use cubesyntax_messaging
  use cubetools_parameters
  use cubetools_structure
  use cubelist_types
  !
  public :: userspace_opt_t,userspace_user_t,userspace_t
  public :: cubetools_userspace_array_remove,cubetools_userspace_array_update
  public :: cubetools_userspace_get,cubetools_userspace_query
  public :: overwrite_no,overwrite_user,overwrite_prog
  private
  !
  integer(kind=4), parameter  :: nforbid = 2
  character(len=*), parameter :: forbidden(2) = [strg_star,strg_equal]
  !
  ! Overwriting modes
  integer(kind=4), parameter :: overwrite_no  =100  ! Attempt to overwrite raises an error
  integer(kind=4), parameter :: overwrite_user=101  ! Overwriting a user-defined variable is allowed
  integer(kind=4), parameter :: overwrite_prog=102  ! Overwriting a user or program-defined variable is allowed
  !
  type userspace_opt_t
     type(option_t),      pointer :: opt
     type(keywordlist_comm_t), pointer :: scope
     type(keywordlist_comm_t), pointer :: overwrite
   contains
     procedure :: register  => cubetools_userspace_register
     procedure :: parse     => cubetools_userspace_parse
     procedure :: user2prog => cubetools_userspace_user2prog
  end type userspace_opt_t
  !
  type userspace_user_t
     logical               :: do        = .false.
     character(len=varn_l) :: name      = strg_unk
     character(len=argu_l) :: scope     = strg_unk
     character(len=argu_l) :: overwrite = strg_unk
  end type userspace_user_t
  !
  type, extends(list_object_t) :: userspace_t
     character(len=varn_l)  :: name
     logical                :: scope
     integer(kind=code_k)   :: overwrite
     type(sic_descriptor_t) :: desc ! sic descriptor
   contains
     procedure, private :: copy => cubetools_userspace_copy
     generic, public    :: assignment(=) => copy
     procedure :: delete      => cubetools_sicdef_delete
     procedure :: fetch_desc  => cubetools_sicdef_fetch_descriptor
     procedure :: has_changed => cubetools_sicdef_desc_changed
     procedure, public :: final => cubetools_userspace_final
  end type userspace_t
  !
contains
  !
  subroutine cubetools_userspace_register(opt,error)
    !------------------------------------------------------------------------
    !
    !------------------------------------------------------------------------
    class(userspace_opt_t), intent(out)   :: opt
    logical,                intent(inout) :: error
    !
    type(standard_arg_t) :: stdarg
    type(keywordlist_comm_t)  :: keyarg
    character(len=*), parameter :: scope(2) = ['GLOBAL','LOCAL ']
    character(len=*), parameter :: yesno(2) = ['YES','NO ']
    character(len=*), parameter :: rname='USERSPACE>REGISTER'
    !
    call cubesyntax_message(syntaxseve%trace,rname,'Welcome')
    !
    call cubetools_register_option(&
         'INTO','varname [scope [overwrite]]',&
         'Define the SIC variable name and its status',&
         strg_emp,&
         opt%opt,error)
    if (error) return
    call stdarg%register( &
         'varname',  &
         'Variable name', &
         strg_emp,&
         code_arg_mandatory, &
         error)
    if (error) return
    call keyarg%register( &
         'scope',  &
         'Variable is global or local', &
         'Default is global',&
         code_arg_optional, &
         scope, &
         .not.flexible, &
         opt%scope, &
         error)
    if (error) return
    call keyarg%register( &
         'overwrite',  &
         'Overwrite previous variable of same name', &
         'Default is yes',&
         code_arg_optional, &
         yesno, &
         .not.flexible, &
         opt%overwrite, &
         error)
    if (error) return
  end subroutine cubetools_userspace_register
  !
  subroutine cubetools_userspace_parse(opt,line,user,error)
    !----------------------------------------------------------------------
    !
    !----------------------------------------------------------------------
    class(userspace_opt_t), intent(in)    :: opt
    character(len=*),       intent(in)    :: line
    type(userspace_user_t), intent(out)   :: user
    logical,                intent(inout) :: error
    !
    character(len=*), parameter :: rname='USERSPACE>PARSE'
    !
    call cubesyntax_message(syntaxseve%trace,rname,'Welcome')
    !
    call opt%opt%present(line,user%do,error)
    if (error) return
    if (user%do) then
       call cubetools_getarg(line,opt%opt,1,user%name,mandatory,error)
       if (error) return
       user%scope = 'LOCAL'
       call cubetools_getarg(line,opt%opt,2,user%scope,.not.mandatory,error)
       if (error) return
       user%overwrite = 'YES'
       call cubetools_getarg(line,opt%opt,3,user%overwrite,.not.mandatory,error)
       if (error) return
    endif
  end subroutine cubetools_userspace_parse
  !
  subroutine cubetools_userspace_user2prog(opt,user,prog,error)
    use cubetools_disambiguate
    !----------------------------------------------------------------------
    !
    !----------------------------------------------------------------------
    class(userspace_opt_t), intent(in)    :: opt
    type(userspace_user_t), intent(in)    :: user
    class(userspace_t),     intent(inout) :: prog
    logical,                intent(inout) :: error
    !
    character(len=argu_l) :: scope,overwrite
    integer(kind=4) :: ikey,iforbid
    character(len=*), parameter :: rname='USERSPACE>USER2PROG'
    !
    call cubesyntax_message(syntaxseve%trace,rname,'Welcome')
    !
    do iforbid=1,nforbid
       if (user%name.eq.forbidden(iforbid)) then
          call cubesyntax_message(seve%e,rname,'The name '//trim(user%name)//&
               ' is protected and cannot be used')
          error = .true.
          return
       endif
    enddo
    call cubetools_disambiguate_toupper(user%name,prog%name,error)
    if (error) return
    call cubetools_keywordlist_user2prog(opt%scope,user%scope,ikey,scope,error)
    if (error) return
    prog%scope = scope.eq.'GLOBAL'
    call cubetools_keywordlist_user2prog(opt%overwrite,user%overwrite,ikey,overwrite,error)
    if (error) return
    if (overwrite.eq.'YES') then
      ! NB: user has no access to overwrite_prog (avoid LOAD /INTO PI)
      prog%overwrite = overwrite_user
    else
      prog%overwrite = overwrite_no
    endif
  end subroutine cubetools_userspace_user2prog
  !
  !----------------------------------------------------------------------
  !
  subroutine cubetools_userspace_get(name,userspace,error)
    !----------------------------------------------------------------------
    ! Get a userspace element from a name and a type
    !----------------------------------------------------------------------
    character(len=*),   intent(in)    :: name
    class(userspace_t), intent(out)   :: userspace
    logical,            intent(inout) :: error
    !
    character(len=*), parameter :: rname='USERSPACE>GET'
    !
    call cubesyntax_message(syntaxseve%trace,rname,'Welcome')
    !
    if (.not.sic_varexist(name)) then
      call cubesyntax_message(seve%e,rname,'Variable '//trim(name)//' does not exist')
      error = .true.
      return
    endif
    !
    userspace%name = name
    call userspace%fetch_desc(error)
    if (error) return
    if (userspace%desc%readonly) then
      userspace%overwrite = overwrite_no
    else
      userspace%overwrite = overwrite_user
    endif
    userspace%scope = sic_level(name).eq.0
  end subroutine cubetools_userspace_get
  !
  function cubetools_userspace_query(name)
    !----------------------------------------------------------------------
    ! Tests if a variable with name exists in userspace
    !----------------------------------------------------------------------
    logical :: cubetools_userspace_query
    character(len=*), intent(in) :: name
    !
    cubetools_userspace_query = sic_varexist(name)
  end function cubetools_userspace_query
  !
  !------------------------------------------------------------------------
  !
  subroutine cubetools_sicdef_delete(userspace,error)
    !------------------------------------------------------------------------
    ! Tests if a sic object with that name exists:
    ! - if it does not, simply return
    ! - if it does and overwrite is forbidden, raise an error
    ! - if it does and overwrite is allowed, delete the variable
    !------------------------------------------------------------------------
    class(userspace_t), intent(in)    :: userspace
    logical,            intent(inout) :: error
    !
    logical :: found,user_request
    type(sic_descriptor_t) :: desc
    character(len=*), parameter :: rname='SICDEF>DELETE'
    !
    call cubesyntax_message(syntaxseve%trace,rname,'Welcome')
    !
    found = .false.
    call sic_descriptor(trim(userspace%name),desc,found)
    !
    if (.not.found)  return
    !
    if (userspace%overwrite.eq.overwrite_no) then
      call cubesyntax_message(seve%e,rname,'Variable '//trim(userspace%name)//' already exists')
      error = .true.
      return
    endif
    !
    ! Important: SIC variables must be deleted (sic_delvariable) with
    ! the proper 'user request' flag matching its internal status,
    ! otherwise this messes up the internal list of variables.
    if (desc%status.eq.program_defined) then
      if (userspace%overwrite.eq.overwrite_prog) then
        ! CUBE allows this program-defined variable to be deleted
        user_request = .false.
      else
        ! Any other program-defined variable is protected (e.g. PI)
        user_request = .true.
      endif
    else
      user_request = .true.
    endif
    call cubesyntax_message(syntaxseve%others,rname,trim(userspace%name)//' exists, overwriting it')
    call sic_delvariable(trim(userspace%name),user_request,error)
    if (error) return
  end subroutine cubetools_sicdef_delete
  !
  subroutine cubetools_sicdef_fetch_descriptor(userspace,error)
    !------------------------------------------------------------------------
    ! Fetch sic descriptor for the userspace item
    !------------------------------------------------------------------------
    class(userspace_t), intent(inout) :: userspace
    logical,            intent(inout) :: error
    !
    logical :: found
    character(len=*), parameter :: rname='SICDEF>FETCH>DESCRIPTOR'
    !
    call cubesyntax_message(syntaxseve%trace,rname,'Welcome')
    !
    found = .false.
    call sic_descriptor(userspace%name,userspace%desc,found)
    if (.not.found) then
       call cubesyntax_message(seve%e,rname,'User space item does not exist')
       error = .true.
       return
    endif
  end subroutine cubetools_sicdef_fetch_descriptor
  !
  function cubetools_sicdef_desc_changed(userspace) result(changed)
    !------------------------------------------------------------------------
    ! Checks if descriptor for a userspace object exists, and if it
    ! has changed since created
    !------------------------------------------------------------------------
    class(userspace_t), intent(in) :: userspace
    logical                        :: changed   
    !
    logical :: found
    type(sic_descriptor_t) :: mydesc
    character(len=*), parameter :: rname='SICDEF>DESCRIPTOR>CHANGED'
    !
    call cubesyntax_message(syntaxseve%trace,rname,'Welcome')
    !
    call sic_descriptor(userspace%name,mydesc,found)
    if (.not.found) then
       changed = .true.
       return
    else
       changed = sic_notsamedesc(userspace%desc,mydesc)
    endif
  end function cubetools_sicdef_desc_changed
  !
  !---------------------------------------------------------------------
  !
  subroutine cubetools_userspace_array_remove(arr,uspace,error)
    !-------------------------------------------------------------------
    ! Clean out from the list elements which are "identical" to the
    ! given userspace. This is intended to be used before inserting such
    ! a userspace, i.e. to avoid conflicts.
    !-------------------------------------------------------------------
    type(list_t),       intent(inout) :: arr
    class(userspace_t), intent(in)    :: uspace
    logical,            intent(inout) :: error
    ! Local
    integer(kind=list_k) :: obuf
    class(userspace_t), pointer :: lspace
    !
    obuf = 1
    do while (obuf.le.arr%n)  ! NB: arr%n is expected to change during loop execution
      lspace => cubetools_userspace_ptr(arr%list(obuf)%p,error)
      if (error) return
      if (lspace%name.eq.uspace%name .and.  &
          (lspace%scope.eqv.uspace%scope)) then
        call arr%pop(obuf,error)
        if (error) return
      else
        obuf = obuf+1
      endif
    enddo
  end subroutine cubetools_userspace_array_remove
  !
  subroutine cubetools_userspace_array_update(arr,error)
    !------------------------------------------------------------------------
    ! Update the array list, i.e. check for buffers removed by some
    ! external mean (e.g. user DELETE /VAR) and compress the list
    ! accordingly
    !------------------------------------------------------------------------
    type(list_t), intent(inout) :: arr
    logical,      intent(inout) :: error
    !
    class(userspace_t), pointer :: uspace
    integer(kind=4) :: oldn,newn,obuf
    character(len=*), parameter :: rname='USERSPACE>ARRAY>UPDATE'
    !
    call cubesyntax_message(syntaxseve%trace,rname,'welcome')
    !
    if (arr%n.le.0)  return
    !
    oldn = arr%n
    newn = 0
    do obuf=1,oldn
      uspace => cubetools_userspace_ptr(arr%list(obuf)%p,error)
      if (error) return
      if (uspace%has_changed()) then
        ! Ideally we should use arr%pop(), but I would like
        ! to avoid compressing the list several times, as several
        ! buffers migth be removed here
        if (arr%list(obuf)%code_pointer.eq.code_pointer_allocated)  &
          deallocate(uspace)
      else
        newn = newn+1
        arr%list(newn)%p => uspace
        arr%list(newn)%code_pointer = arr%list(obuf)%code_pointer
      endif
    enddo
    !
    ! There might be unused elements at the end of the list
    do obuf=newn+1,oldn
      arr%list(obuf)%p => null()
      arr%list(obuf)%code_pointer = code_pointer_null
    enddo
    !
    ! Update array size
    arr%n = newn
    !
    if (newn.eq.0) then
      call arr%final(error)
      if (error) return
    endif
  end subroutine cubetools_userspace_array_update
  !
  function cubetools_userspace_ptr(tot,error)
    !-------------------------------------------------------------------
    ! Check if the input class is of class(userspace_t), and return a
    ! pointer to it if relevant.
    !-------------------------------------------------------------------
    class(userspace_t), pointer :: cubetools_userspace_ptr  ! Function value on return
    class(list_object_t), pointer       :: tot
    logical,              intent(inout) :: error
    !
    character(len=*), parameter :: rname='USERSPACE>PTR'
    !
    select type(tot)
    class is (userspace_t)
      cubetools_userspace_ptr => tot
    class default
      cubetools_userspace_ptr => null()
      call cubesyntax_message(seve%e,rname,  &
        'Internal error: object is not a userspace_t class')
      error = .true.
      return
    end select
  end function cubetools_userspace_ptr
  !
  subroutine cubetools_userspace_copy(o,i)
    !-------------------------------------------------------------------
    ! Copy one userspace_t CLASS to another CLASS
    !-------------------------------------------------------------------
    class(userspace_t), intent(inout) :: o
    class(userspace_t), intent(in)    :: i
    !
   !o%list_object_t = i%list_object_t
    o%name          = i%name
    o%scope         = i%scope
    o%overwrite     = i%overwrite
    o%desc          = i%desc
  end subroutine cubetools_userspace_copy
  !
  subroutine cubetools_userspace_final(obj,error)
    !-------------------------------------------------------------------
    !
    !-------------------------------------------------------------------
    class(userspace_t), intent(inout) :: obj
    logical,            intent(inout) :: error
  end subroutine cubetools_userspace_final
  !
end module cubetools_userspace
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
