ftnlf

Check-in [c16754483f]
Login

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

Overview
Comment:Remove cross-calls to FX.Core API functions.
Downloads: Tarball | ZIP archive | SQL archive
Timelines: family | ancestors | descendants | both | trunk
Files: files | file ages | folders
SHA1:c16754483ff22dabbf7d97ac4681f0fc23d5dde1
User & Date: vadim 2018-05-21 11:09:34
Context
2018-05-21
11:37
Allocate zero-length FA once and store it as upvalue. check-in: 44d39185ec user: vadim tags: trunk
11:09
Remove cross-calls to FX.Core API functions. check-in: c16754483f user: vadim tags: trunk
2018-05-16
06:42
Replace LuaBinaries files with self-compiled Lua libraries. Also do some cleanup and fixes. check-in: d0702e682c user: vadim tags: trunk
Changes
Hide Diffs Unified Diffs Ignore Whitespace Patch

Changes to ftnlf.f90.

9
10
11
12
13
14
15




16
17
18
19
20
21
22
..
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
..
88
89
90
91
92
93
94












95
96
97
98
99
100
101
...
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
...
300
301
302
303
304
305
306
307

308
309
310
311
312
313
314
    private
    public :: ftnlf_init, ftnlf_done, luacache
    public :: luafun, luafuna, luafunc, luafunca

    type(c_ptr) :: L_st

    type(luaFE_FunctionEntry), allocatable :: fx_loaders(:)





contains
    ! Initialization EP
    function ftnlf_init(fname, loadlist) result(r)
        use, intrinsic :: iso_c_binding, only: c_associated, c_funloc, c_null_ptr
        use ftnlf_fxcore
        use luaFE
................................................................................
            nload = size(loadlist)
            allocate(fx_loaders(1+nload))
            fx_loaders(2:1+nload) = loadlist
        else
            allocate(fx_loaders(1))
        end if
        ! Core
        fx_loaders(1)%name = 'FX.Core'
        fx_loaders(1)%f => ldr_fx_core

        ! The 1st stage of initialization
        res = lua_cpcall(L_st, c_funloc(linit1), c_null_ptr)
        r = lcheck(res)
        if (.not. r) return
        
................................................................................
        call lua_getfield(L, -1, F_C_STR('preload'))

        ! Core
        call luaFE_registerlist(L, fx_loaders)

        ! Pop package and package.preload tables
        call lua_pop(L, 2)













        r = 0
    end function linit1
    
    ! Finalization EP
    subroutine ftnlf_done()
        call lua_close(L_st)
................................................................................
        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
        use ftnlf_fxcore, only: l_fa_new
        real(8), intent(in) :: args(:), arr_i(:)
        real(8), intent(inout) :: fvals(:), arr_o(:), arr_m(:)
        logical :: r
        integer(4) :: na, nv, narr_i, narr_o, narr_m, k, ns
        
        r = .false.

................................................................................
        function createuv(n, ns) result(r)
            use, intrinsic :: iso_c_binding, only: c_funloc
            integer(4), intent(in) :: n
            integer(4), intent(inout) :: ns
            integer(c_int) :: res
            logical :: r
            
            call lua_pushcfunction(L_st, c_funloc(l_fa_new))

            call lua_pushinteger(L_st, INT(n, C_INTPTR_T))
            res = lua_pcall(L_st, 1, 1, 0)
            r = lcheck(res)
            if (r) then
                ! success => +1 value to stack
                ns = ns+1
            else







>
>
>
>







 







|







 







>
>
>
>
>
>
>
>
>
>
>
>







 







<







 







|
>







9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
..
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
..
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
...
261
262
263
264
265
266
267

268
269
270
271
272
273
274
...
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
    private
    public :: ftnlf_init, ftnlf_done, luacache
    public :: luafun, luafuna, luafunc, luafunca

    type(c_ptr) :: L_st

    type(luaFE_FunctionEntry), allocatable :: fx_loaders(:)
    
    character(*), parameter :: FX_Core_name = 'FX.Core'
    
    integer(c_int) :: ref_array ! reference to 'array' function

contains
    ! Initialization EP
    function ftnlf_init(fname, loadlist) result(r)
        use, intrinsic :: iso_c_binding, only: c_associated, c_funloc, c_null_ptr
        use ftnlf_fxcore
        use luaFE
................................................................................
            nload = size(loadlist)
            allocate(fx_loaders(1+nload))
            fx_loaders(2:1+nload) = loadlist
        else
            allocate(fx_loaders(1))
        end if
        ! Core
        fx_loaders(1)%name = FX_Core_name
        fx_loaders(1)%f => ldr_fx_core

        ! The 1st stage of initialization
        res = lua_cpcall(L_st, c_funloc(linit1), c_null_ptr)
        r = lcheck(res)
        if (.not. r) return
        
................................................................................
        call lua_getfield(L, -1, F_C_STR('preload'))

        ! Core
        call luaFE_registerlist(L, fx_loaders)

        ! Pop package and package.preload tables
        call lua_pop(L, 2)

        ! Load module, make reference to 'array' function (l_fa_new)
        call lua_getglobal(L, F_C_STR('require'))
        call lua_pushstring_f(L, FX_Core_name)
        call lua_call(L, 1, 1)
        ! Module table at the top
        ! get array function
        call lua_getfield(L, -1, F_C_STR('array'))
        ! make reference
        ref_array = luaL_ref(L, LUA_REGISTRYINDEX)
        ! Pop module table 
        call lua_pop(L, 1)

        r = 0
    end function linit1
    
    ! Finalization EP
    subroutine ftnlf_done()
        call lua_close(L_st)
................................................................................
        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

        real(8), intent(in) :: args(:), arr_i(:)
        real(8), intent(inout) :: fvals(:), arr_o(:), arr_m(:)
        logical :: r
        integer(4) :: na, nv, narr_i, narr_o, narr_m, k, ns
        
        r = .false.

................................................................................
        function createuv(n, ns) result(r)
            use, intrinsic :: iso_c_binding, only: c_funloc
            integer(4), intent(in) :: n
            integer(4), intent(inout) :: ns
            integer(c_int) :: res
            logical :: r
            
            ! Push 'array' function
            call lua_rawgeti(L_st, LUA_REGISTRYINDEX, ref_array)
            call lua_pushinteger(L_st, INT(n, C_INTPTR_T))
            res = lua_pcall(L_st, 1, 1, 0)
            r = lcheck(res)
            if (r) then
                ! success => +1 value to stack
                ns = ns+1
            else

Changes to ftnlf_fxcore.f90.

15
16
17
18
19
20
21

22
23
24
25
26
27
28





29
30
31
32
33
34
35
36
37
38
...
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
...
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
...
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
...
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
...
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
    character(*), parameter :: mt_FA = 'ftnlf.fx.fa'
    character(*), parameter :: mt_interp = 'ftnlf.fx.interp'

contains

    ! FX.Core module loader
    function ldr_fx_core(L) bind(C, name='luaopen_FX_Core') result(r)

        type(c_ptr), value, intent(in) :: L
        integer(c_int) :: r

        ! Pop package name
        call lua_pop(L, 1)

        call lua_newtable(L)





        call luaFE_register(L, 'array', l_fa_new)
        call luaFE_register(L, 'apack', l_fa_pack)
        call luaFE_register(L, 'apackt', l_fa_packt)
        call luaFE_register(L, 'aunpack', l_fa_unpack)
        call luaFE_register(L, 'interp', l_interp_new)

        r = 1
    end function ldr_fx_core

    ! ======= Fortran Arrays =======
................................................................................
    !  - existing Fortran array where to pack (#arr >= n+ix-1)
    !  - N => create new array of length N (N >= n+ix-1)
    !  - nil => create new array of length (n+ix-1)
    ! where ix is:
    !  - i => start index 
    !  - nil => start index 1
    function l_fa_pack(L) bind(C) result(r)
        use, intrinsic :: iso_c_binding, only: c_f_pointer, c_intptr_t, c_funloc
        type(c_ptr), value, intent(in) :: L
        integer(c_int) :: r

        integer(4) :: nlast1, nlast2, nargs, typ, k, ix

        integer(c_intptr_t) :: s
        type(c_ptr) :: ud
................................................................................
                s = lua_tointeger(L, -1)
            else
                s = 0
                r = luaL_argerror(L, nlast1, F_C_STR('invalid value'))
            end if
            
            ! create new Fortran array of requested size
            call lua_pushcfunction(L, c_funloc(l_fa_new))
            call lua_insert(L, -2)
            call lua_call(L, 1, 1)

            ! Now stack is: arg1 ... argn ud
            ud = lua_touserdata(L, -1)
        end if

................................................................................
    !  - existing Fortran array where to pack (#arr >= n+ix-1)
    !  - N => create new array of length N (N >= n+ix-1)
    !  - nil or none => create new array of length (n+ix-1)
    ! where ix is:
    !  - i => start index 
    !  - nil or none => start index 1
    function l_fa_packt(L) bind(C) result(r)
        use, intrinsic :: iso_c_binding, only: c_f_pointer, c_intptr_t, c_funloc
        type(c_ptr), value, intent(in) :: L
        integer(c_int) :: r

        integer(4) :: nargs, typ, k, ix

        integer(c_intptr_t) :: s
        type(c_ptr) :: ud
................................................................................
                call lua_pushinteger(L, s)
            else
                ! expect number
                s = luaL_checkinteger(L, 2)
            end if
            
            ! create new Fortran array of requested size
            call lua_pushcfunction(L, c_funloc(l_fa_new))
            call lua_insert(L, -2)
            call lua_call(L, 1, 1)

            ! Now stack is: {arg1 ... argn} ud
            ud = lua_touserdata(L, -1)
        end if

        ! check bounds
        if (s < nargs+ix-1) then
            r = luaL_argerror(L, 1, F_C_STR('too many arguments'))
................................................................................
    ! where ix2 is:
    !  - number (1 <= ix2 <= #arr)
    !  - nil or none => ix2 = #arr
    ! unpacks from ix1 to ix2 (ix1:ix2)
    ! if ix2 < ix1, then length is 0

    function l_fa_unpack(L) bind(C) result(r)
        use, intrinsic :: iso_c_binding, only: c_f_pointer, c_intptr_t, c_funloc
        type(c_ptr), value, intent(in) :: L
        integer(c_int) :: r

        integer(c_int) :: k, ix1, ix2, nvals

        integer(c_intptr_t) :: s
        type(c_ptr) :: ud







>







>
>
>
>
>
|
|
|







 







|







 







|







 







|







 







|


<







 







|







15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
...
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
...
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
...
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
...
341
342
343
344
345
346
347
348
349
350

351
352
353
354
355
356
357
...
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
    character(*), parameter :: mt_FA = 'ftnlf.fx.fa'
    character(*), parameter :: mt_interp = 'ftnlf.fx.interp'

contains

    ! FX.Core module loader
    function ldr_fx_core(L) bind(C, name='luaopen_FX_Core') result(r)
        use, intrinsic :: iso_c_binding, only: c_funloc
        type(c_ptr), value, intent(in) :: L
        integer(c_int) :: r

        ! Pop package name
        call lua_pop(L, 1)

        call lua_newtable(L)
        ! register 'array' function (l_fa_new) with nil upvalue
        call lua_pushstring_f(L, 'array')
        call lua_pushnil(L)
        call lua_pushcclosure(L, c_funloc(l_fa_new), 1)
        call lua_settable(L, -3)
        ! call luaFE_register(L, 'array', l_fa_new)
        call luaFE_registerSUV(L, 'apack', l_fa_pack)
        call luaFE_registerSUV(L, 'apackt', l_fa_packt)
        call luaFE_register(L, 'aunpack', l_fa_unpack)
        call luaFE_register(L, 'interp', l_interp_new)

        r = 1
    end function ldr_fx_core

    ! ======= Fortran Arrays =======
................................................................................
    !  - existing Fortran array where to pack (#arr >= n+ix-1)
    !  - N => create new array of length N (N >= n+ix-1)
    !  - nil => create new array of length (n+ix-1)
    ! where ix is:
    !  - i => start index 
    !  - nil => start index 1
    function l_fa_pack(L) bind(C) result(r)
        use, intrinsic :: iso_c_binding, only: c_f_pointer, c_intptr_t
        type(c_ptr), value, intent(in) :: L
        integer(c_int) :: r

        integer(4) :: nlast1, nlast2, nargs, typ, k, ix

        integer(c_intptr_t) :: s
        type(c_ptr) :: ud
................................................................................
                s = lua_tointeger(L, -1)
            else
                s = 0
                r = luaL_argerror(L, nlast1, F_C_STR('invalid value'))
            end if
            
            ! create new Fortran array of requested size
            call lua_getfield(L, lua_upvalueindex(1), F_C_STR('array'))
            call lua_insert(L, -2)
            call lua_call(L, 1, 1)

            ! Now stack is: arg1 ... argn ud
            ud = lua_touserdata(L, -1)
        end if

................................................................................
    !  - existing Fortran array where to pack (#arr >= n+ix-1)
    !  - N => create new array of length N (N >= n+ix-1)
    !  - nil or none => create new array of length (n+ix-1)
    ! where ix is:
    !  - i => start index 
    !  - nil or none => start index 1
    function l_fa_packt(L) bind(C) result(r)
        use, intrinsic :: iso_c_binding, only: c_f_pointer, c_intptr_t
        type(c_ptr), value, intent(in) :: L
        integer(c_int) :: r

        integer(4) :: nargs, typ, k, ix

        integer(c_intptr_t) :: s
        type(c_ptr) :: ud
................................................................................
                call lua_pushinteger(L, s)
            else
                ! expect number
                s = luaL_checkinteger(L, 2)
            end if
            
            ! create new Fortran array of requested size
            call lua_getfield(L, lua_upvalueindex(1), F_C_STR('array'))
            call lua_insert(L, -2)
            call lua_call(L, 1, 1)

            ! Now stack is: {arg1 ... argn} ud
            ud = lua_touserdata(L, -1)
        end if

        ! check bounds
        if (s < nargs+ix-1) then
            r = luaL_argerror(L, 1, F_C_STR('too many arguments'))
................................................................................
    ! where ix2 is:
    !  - number (1 <= ix2 <= #arr)
    !  - nil or none => ix2 = #arr
    ! unpacks from ix1 to ix2 (ix1:ix2)
    ! if ix2 < ix1, then length is 0

    function l_fa_unpack(L) bind(C) result(r)
        use, intrinsic :: iso_c_binding, only: c_f_pointer, c_intptr_t
        type(c_ptr), value, intent(in) :: L
        integer(c_int) :: r

        integer(c_int) :: k, ix1, ix2, nvals

        integer(c_intptr_t) :: s
        type(c_ptr) :: ud

Changes to testdb.lua.

36
37
38
39
40
41
42

T.test2(A)
print('OUT: ')
for k = 1, #A do
   print(A[k])
end

end








>
36
37
38
39
40
41
42
43
T.test2(A)
print('OUT: ')
for k = 1, #A do
   print(A[k])
end

end