ftnlf

Check-in [e32558ae06]
Login

Many hyperlinks are disabled.
Use anonymous login to enable hyperlinks.

Overview
Comment:Fix and test luafunc*
Downloads: Tarball | ZIP archive | SQL archive
Timelines: family | ancestors | descendants | both | multi
Files: files | file ages | folders
SHA1:e32558ae06121a1fc61850d2ca576dff51c8f0e0
User & Date: vadim 2018-05-06 21:07:44
Context
2018-05-06
21:10
Test modified array. check-in: 7098e49cb7 user: vadim tags: multi
21:07
Fix and test luafunc* check-in: e32558ae06 user: vadim tags: multi
20:59
Rework of ftnlf/multi. Tests for luafun* passed. Need to fix luafunc* and do more tests. check-in: e7fb98c94b user: vadim tags: multi
Changes
Hide Diffs Unified Diffs Ignore Whitespace Patch

Changes to ftnlf.f90.

165
166
167
168
169
170
171
172

173
174
175
176
177
178
179
180
181
182
183
184
185
186
...
191
192
193
194
195
196
197
198
199
200
201
202
203






204
205

206
207
208
209
210

211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
        r = luafuna(tbldir, tbl, key, args, fvals, [ real(8) :: ], arr_m, arr_o)
        if (r) &
            fval = fvals(1)

    end function luafun
    
    ! Call lua 'function' from BD (cached), generic case
    function luafunca(tbl, key, args, args_a, fvals, fvals_a) result(r)

        use, intrinsic :: iso_c_binding, only: c_funloc
        character(*), intent(in) :: tbl, key
        real(8), intent(in) :: args(:), args_a(:)
        real(8), intent(inout) :: fvals(:), fvals_a(:)
        logical :: r
        integer(4) :: res, n
        real(8), allocatable, target :: p(:)
        
        r = .false.
        ! Check stack
        ! The possibility of OOM condition is ignored here
        ! If such thing happens, user is already messed up
        if (lua_checkstack(L_st, 3) == 0) then
            ! Stack overflow, return
................................................................................
        ! Cached value
        call lua_pushcfunction(L_st, c_funloc(lfuncallc))

        call lua_pushstring_f(L_st, tbl)
        call lua_pushstring_f(L_st, key)
        
        ! Push function arguments and return sizes
!@        if (.not. packargs(args, args_a, fvals, fvals_a, p)) then
!@            ! Pop previous args
!@            call lua_pop(L_st, 3)
!@            return
!@        endif
        






        ! Call Lua
        n = 3 - 1 + 5

        res = lua_pcall(L_st, n, 1, 0)
        r = lcheck(res)
        if (.not. r) return

!@        call unpackvals(p, fvals, fvals_a)


    end function luafunca

    ! Call lua 'function' from BD (cached), simplified interface
    function luafunc(tbl, key, args, fval) result(r)
        use, intrinsic :: iso_c_binding, only: c_funloc
        character(*), intent(in) :: tbl, key
        real(8), intent(in) :: args(:)
        real(8), intent(out) :: fval
        logical :: r
        real(8) :: fvals(1), fvals_a(0)

        r = luafunca(tbl, key, args, [ real(8) :: ], fvals, fvals_a)
        if (r) &
            fval = fvals(1)
    end function luafunc

    ! Pack arguments
    function packargs(args, fvals, arr_i, arr_m, arr_o) result(r)
        use, intrinsic :: iso_c_binding, only: c_intptr_t







|
>


|
|

|
<







 







|
|
|
|
|

>
>
>
>
>
>

<
>
|



|
>










|

|







165
166
167
168
169
170
171
172
173
174
175
176
177
178
179

180
181
182
183
184
185
186
...
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210

211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
        r = luafuna(tbldir, tbl, key, args, fvals, [ real(8) :: ], arr_m, arr_o)
        if (r) &
            fval = fvals(1)

    end function luafun
    
    ! Call lua 'function' from BD (cached), generic case
    function luafunca(tbl, key, args, fvals, &
        & arr_i, arr_m, arr_o) result(r)
        use, intrinsic :: iso_c_binding, only: c_funloc
        character(*), intent(in) :: tbl, key
        real(8), intent(in) :: args(:), arr_i(:)
        real(8), intent(inout) :: fvals(:), arr_o(:), arr_m(:)
        logical :: r
        integer(4) :: res, n, nv

        
        r = .false.
        ! Check stack
        ! The possibility of OOM condition is ignored here
        ! If such thing happens, user is already messed up
        if (lua_checkstack(L_st, 3) == 0) then
            ! Stack overflow, return
................................................................................
        ! Cached value
        call lua_pushcfunction(L_st, c_funloc(lfuncallc))

        call lua_pushstring_f(L_st, tbl)
        call lua_pushstring_f(L_st, key)
        
        ! Push function arguments and return sizes
        if (.not. packargs(args, fvals, arr_i, arr_m, arr_o)) then
            ! Pop previous args
            call lua_pop(L_st, 3)
            return
        endif
        
        ! Number of arguments
        n = 3 - 1 + size(args) + 4
        ! check stack
        ! < DEBUG >
        if (lua_gettop(L_st) /= n + 1) stop 88

        ! Call Lua

        nv = size(fvals) + 2
        res = lua_pcall(L_st, n, nv, 0)
        r = lcheck(res)
        if (.not. r) return

        call unpackvals(fvals, arr_m, arr_o)
        call lua_pop(L_st, nv)

    end function luafunca

    ! Call lua 'function' from BD (cached), simplified interface
    function luafunc(tbl, key, args, fval) result(r)
        use, intrinsic :: iso_c_binding, only: c_funloc
        character(*), intent(in) :: tbl, key
        real(8), intent(in) :: args(:)
        real(8), intent(out) :: fval
        logical :: r
        real(8) :: fvals(1), arr_o(0), arr_m(0)

        r = luafunca(tbl, key, args, fvals, [ real(8) :: ], arr_m, arr_o)
        if (r) &
            fval = fvals(1)
    end function luafunc

    ! Pack arguments
    function packargs(args, fvals, arr_i, arr_m, arr_o) result(r)
        use, intrinsic :: iso_c_binding, only: c_intptr_t

Changes to test.f90.

29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57

    r = luafun('dir1', 'tbl2', 'v7', [1.d0,-3.5d0], fval)
    write (*,'(L2,1X,1PE11.4)') r, fval

    r = luacache('dir1', 'tbl2', 'tblq')
    write (*,'(L2)') r

!    r = luafunc('tblq', 'v6', [1.d0], fval)
!    write (*,'(L2,1X,1PE11.4)') r, fval

    r = luacache('', 'tbl1', 'tblq')
    write (*,'(L2)') r

!    r = luafunc('tblq', 'v2', [1.d0,-1.7d0], fval)
!    write (*,'(L2,1X,1PE11.4)') r, fval

!    r = luafunc('tblq', 'val1', [1.d0,-1.7d0], fval)
!    write (*,'(L2,1X,1PE11.4)') r, fval

    ! Generic iface, array I/O
    r = luafuna('', 'tbl1', 'valN', [1.d0,-3.5d0], fvals(1:1), &
        & [1.1d0, 1.2d0, 1.3d0, 1.4d0], arr_m, arr_o)
    write (*,'(L2,4(1X,1PE11.4))') r, fvals(1:1), arr_o(1:3)

    ! Finalize
    call ftnlf_done()
    write (0,'(A)') 'Done.'

end program test







|
|




|
|

|
|


|

|






29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57

    r = luafun('dir1', 'tbl2', 'v7', [1.d0,-3.5d0], fval)
    write (*,'(L2,1X,1PE11.4)') r, fval

    r = luacache('dir1', 'tbl2', 'tblq')
    write (*,'(L2)') r

    r = luafunc('tblq', 'v6', [1.d0], fval)
    write (*,'(L2,1X,1PE11.4)') r, fval

    r = luacache('', 'tbl1', 'tblq')
    write (*,'(L2)') r

    r = luafunc('tblq', 'v2', [1.d0,-1.7d0], fval)
    write (*,'(L2,1X,1PE11.4)') r, fval

    r = luafunc('tblq', 'val1', [1.d0,-1.7d0], fval)
    write (*,'(L2,1X,1PE11.4)') r, fval

    ! Generic iface, array I/O
    r = luafuna('', 'tbl1', 'valN', [1.d0,-3.5d0], fvals(1:2), &
        & [1.1d0, 1.2d0, 1.3d0, 1.4d0], arr_m, arr_o)
    write (*,'(L2,5(1X,1PE11.4))') r, fvals(1:2), arr_o(1:3)

    ! Finalize
    call ftnlf_done()
    write (0,'(A)') 'Done.'

end program test

Changes to testdb.lua.

4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
tbl1 = { val1 = 17.4e-1,
v2 = function(x,y) return (x/y) end,
v3 = iii,
valN = function(x,y,ai,am,ao)
ao[1] = (x+y)*ai[1]
ao[2] = (x*y)/ai[2]
ao[3] = math.atan2(y*ai[3],x*ai[4])
return x-y
end
}

dir1 = {
   tbl1 = { v5 = function(x,y) return x-y end },
   tbl2 = { v6 = FXC.interp({-10,1,10,70}), v7 = -29.3e-4},








|







4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
tbl1 = { val1 = 17.4e-1,
v2 = function(x,y) return (x/y) end,
v3 = iii,
valN = function(x,y,ai,am,ao)
ao[1] = (x+y)*ai[1]
ao[2] = (x*y)/ai[2]
ao[3] = math.atan2(y*ai[3],x*ai[4])
return x-y, x+y
end
}

dir1 = {
   tbl1 = { v5 = function(x,y) return x-y end },
   tbl2 = { v6 = FXC.interp({-10,1,10,70}), v7 = -29.3e-4},