ftnlf

Check-in [864b71d5b0]
Login

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

Overview
Comment:luafun, part 2. Fixes, tests.
Downloads: Tarball | ZIP archive | SQL archive
Timelines: family | ancestors | descendants | both | trunk
Files: files | file ages | folders
SHA1:864b71d5b01597dee12fea55df6ace4e75466d1b
User & Date: vadim 2016-01-29 10:31:31
Context
2016-01-29
10:44
Two-level tables. check-in: 3d37b7f8c0 user: vadim tags: trunk
10:31
luafun, part 2. Fixes, tests. check-in: 864b71d5b0 user: vadim tags: trunk
06:22
Call Lua functions from Fortran, part 1. check-in: 93e1c25a0a user: vadim tags: trunk
Changes
Hide Diffs Unified Diffs Ignore Whitespace Patch

Changes to CMakeLists.txt.

56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
	luaf/luaf.f90
	luaf/luafe.f90
	${CMAKE_CURRENT_BINARY_DIR}/luaf_conf.fi
	)

add_executable(ftnlf_test ${src})
# Link static
target_link_libraries(ftnlf_test ${LUA_STATIC_LIB})
# Link dynamic
# target_link_libraries(ftnlf ${LUA_LIBRARIES})
set_target_properties(ftnlf_test PROPERTIES COMPILE_FLAGS "${FCFLAGS} ${FCFLAGS90}")
set_target_properties(ftnlf_test PROPERTIES LINK_FLAGS "${LFLAGS}")
# set_target_properties(ftnlf PROPERTIES PREFIX "")

# Ad-hoc
set(CMAKE_SHARED_LIBRARY_LINK_Fortran_FLAGS "")
set(CMAKE_Fortran_FLAGS_RELEASE "")







|









56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
	luaf/luaf.f90
	luaf/luafe.f90
	${CMAKE_CURRENT_BINARY_DIR}/luaf_conf.fi
	)

add_executable(ftnlf_test ${src})
# Link static
target_link_libraries(ftnlf_test ${LUA_STATIC_LIB} ${CMAKE_DL_LIBS})
# Link dynamic
# target_link_libraries(ftnlf ${LUA_LIBRARIES})
set_target_properties(ftnlf_test PROPERTIES COMPILE_FLAGS "${FCFLAGS} ${FCFLAGS90}")
set_target_properties(ftnlf_test PROPERTIES LINK_FLAGS "${LFLAGS}")
# set_target_properties(ftnlf PROPERTIES PREFIX "")

# Ad-hoc
set(CMAKE_SHARED_LIBRARY_LINK_Fortran_FLAGS "")
set(CMAKE_Fortran_FLAGS_RELEASE "")

Changes to ftnlf.f90.

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
58
59
60
..
75
76
77
78
79
80
81
82
83
84
85
86

87
88
89
90
91
92
93
...
122
123
124
125
126
127
128
129
130





131
132
133
134
135
136
137
...
176
177
178
179
180
181
182
183
184
185

186
187
188
189
190
191
192
193
194

195
196
197
198
199
200
201
...
215
216
217
218
219
220
221

222
223
224
225
226
227

228
229
230
231
232
233
234
235
236
237
238
239
240


241
242
243
244


245
246
247
248

249





































250






251
252


253
254

255
256
257
258
259
260
261
262
263
264

        ! The 1st stage of initialization
        res = lua_cpcall(L_st, c_funloc(linit1), c_null_ptr)
        r = lcheck(res)
        if (.not. r) return
        
        ! The 2nd stage -- load database file
        res = luaL_loadfile_r(L_st, F_C_STR(fname))
        r = lcheck(res)
    end function ftnlf_init

    function lcheck(ret) result(lr)
        integer(4), intent(in) :: ret
        character(1024) :: buf
        logical :: lr
................................................................................

        lr = .true.
        if (ret /= 0) then
            lr = lua_tostring_f(L_st, -1, buf)
            write (0,10) trim(buf)
10          format ('Lua error: ',A)
            call lua_pop(L_st, 1)
            call lua_close(L_st)
            lr = .false.
        end if
    end function lcheck

    ! Aux init - Lua EP 1
    function linit1(L) bind(C) result(r)
        use :: ftnlf_interp
................................................................................
    
    ! Finalization EP
    subroutine ftnlf_done()
        call lua_close(L_st)
    end subroutine ftnlf_done
    
    ! Call lua 'function' from BD
    function luafun(tbldir, tbl, key, args) result(r)
        use, intrinsic :: iso_c_binding, only: c_funloc
        character(*), intent(in), optional :: tbldir
        character(*), intent(in) :: tbl, key
        real(8), intent(in) :: args(:)

        logical :: r
        integer(4) :: res, n, ns
        
        r = .false.
        ! Check stack
        ! The possibility of OOM condition is ignored here
        ! If such thing happens, user is already messed up
................................................................................
            ! Pop previous args
            call lua_pop(L_st, ns)
            return
        endif
        
        ! Call Lua
        n = ns - 1 + size(args)
        res = lua_pcall(L_st, 1, n, 0)
        r = lcheck(res)





    end function luafun
    
    ! Push arguments
    function pushargs(args) result(r)
        real(8), intent(in) :: args(:)
        logical :: r
        integer(4) :: i, n
................................................................................
    
    ! Lua EP for evaluation of function from BD (one-level name)
    function lfuncall1(L) bind(C) result(r)
!        use, intrinsic :: iso_c_binding, only: c_funloc
        type(c_ptr), value, intent(in) :: L
        integer(c_int) :: r

        ! Provide stack FIXME
        call luaL_checkstack(L, 99, 'too many arguments')
        

        ! Get table from the globals
        call lua_pushvalue(L, 1)
        call lua_gettable(L, LUA_GLOBALSINDEX)
        call lfun_checktbl(L, 'global ')
        
        ! Remove table name
        call lua_remove(L, 1)
        
        r = lfun_tail(L)

    end function lfuncall1

    ! Lua EP for evaluation of function from BD (cached name)
    function lfuncallc(L) bind(C) result(r)
!        use, intrinsic :: iso_c_binding, only: c_funloc
        type(c_ptr), value, intent(in) :: L
        integer(c_int) :: r
................................................................................
!                    
!                call luaFE_checktype(L, -1, LUA_TTABLE, 'global '//tbldir)
            
        r = 0
    end function lfuncallc

    ! Check if the value at top, whose name is at index 1, corresponds to the table

    subroutine lfun_checktbl(L, what)
        type(c_ptr) :: L
        character(*), intent(in) :: what
        integer(4) :: typ
        character(10) :: tn
        

        if (lua_type(L, -1) /= LUA_TTABLE) then
            call lua_pushstring_f(L, 'Bad type of '//what)
            call lua_pushvalue(L, 1)
            typ = lua_type(L, -1)
            CALL lua_typename_f(L, typ, tn)
            call lua_pushstring_f(L, ': table expected, got '//trim(tn))
            call lua_concat(L, 3)
            typ = lua_error(L)
        end if
    end subroutine lfun_checktbl

    ! Tail of lfuncall* functions
    ! Expecting stack as the following: key arg1 ... argn tbl


    function lfun_tail(L) result(r)
!        use, intrinsic :: iso_c_binding, only: c_funloc
        type(c_ptr) :: L
        integer(4) :: r, typ



        ! Get value from the table 
        call lua_pushvalue(L, 1)
        call lua_gettable(L, -2)

        





































        ! Remove key name






        call lua_remove(L, 1)
        typ = lua_type(L, -1)



!       if (typ == 

        
        !r = lfun_tail(L)
    end function lfun_tail
    
    
    ! Push table tbldir.tbl or tbl if tbldir is '', check for errors 
    subroutine gettblev2(L, tbldir, tbl)
        type(c_ptr) :: L
        character(*), intent(in) :: tbldir, tbl
        







|







 







<







 







|




>







 







|

>
>
>
>
>







 







|
|

>








|
>







 







>






>
|


<








|
>
>
|


|
>
>




>
|
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
|
>
>
>
>
>
>
|
|
>
>
|
<
>

|
<







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
58
59
..
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
...
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
...
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
...
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239

240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311

312
313
314

315
316
317
318
319
320
321

        ! The 1st stage of initialization
        res = lua_cpcall(L_st, c_funloc(linit1), c_null_ptr)
        r = lcheck(res)
        if (.not. r) return
        
        ! The 2nd stage -- load database file
        res = luaL_dofile_r(L_st, F_C_STR(fname))
        r = lcheck(res)
    end function ftnlf_init

    function lcheck(ret) result(lr)
        integer(4), intent(in) :: ret
        character(1024) :: buf
        logical :: lr
................................................................................

        lr = .true.
        if (ret /= 0) then
            lr = lua_tostring_f(L_st, -1, buf)
            write (0,10) trim(buf)
10          format ('Lua error: ',A)
            call lua_pop(L_st, 1)

            lr = .false.
        end if
    end function lcheck

    ! Aux init - Lua EP 1
    function linit1(L) bind(C) result(r)
        use :: ftnlf_interp
................................................................................
    
    ! Finalization EP
    subroutine ftnlf_done()
        call lua_close(L_st)
    end subroutine ftnlf_done
    
    ! Call lua 'function' from BD
    function luafun(tbldir, tbl, key, args, fval) result(r)
        use, intrinsic :: iso_c_binding, only: c_funloc
        character(*), intent(in), optional :: tbldir
        character(*), intent(in) :: tbl, key
        real(8), intent(in) :: args(:)
        real(8), intent(out) :: fval
        logical :: r
        integer(4) :: res, n, ns
        
        r = .false.
        ! Check stack
        ! The possibility of OOM condition is ignored here
        ! If such thing happens, user is already messed up
................................................................................
            ! Pop previous args
            call lua_pop(L_st, ns)
            return
        endif
        
        ! Call Lua
        n = ns - 1 + size(args)
        res = lua_pcall(L_st, n, 1, 0)
        r = lcheck(res)
        if (.not. r) return

        fval = lua_tonumber(L_st, -1)
        call lua_pop(L_st, 1)

    end function luafun
    
    ! Push arguments
    function pushargs(args) result(r)
        real(8), intent(in) :: args(:)
        logical :: r
        integer(4) :: i, n
................................................................................
    
    ! Lua EP for evaluation of function from BD (one-level name)
    function lfuncall1(L) bind(C) result(r)
!        use, intrinsic :: iso_c_binding, only: c_funloc
        type(c_ptr), value, intent(in) :: L
        integer(c_int) :: r

        ! Provide stack
        call luaL_checkstack(L, 4, 'too many arguments')
        
        ! Stack is now: tblname key arg1 ... argn
        ! Get table from the globals
        call lua_pushvalue(L, 1)
        call lua_gettable(L, LUA_GLOBALSINDEX)
        call lfun_checktbl(L, 'global ')
        
        ! Remove table name
        call lua_remove(L, 1)
        
        call lfun_tail(L)
        r = 1
    end function lfuncall1

    ! Lua EP for evaluation of function from BD (cached name)
    function lfuncallc(L) bind(C) result(r)
!        use, intrinsic :: iso_c_binding, only: c_funloc
        type(c_ptr), value, intent(in) :: L
        integer(c_int) :: r
................................................................................
!                    
!                call luaFE_checktype(L, -1, LUA_TTABLE, 'global '//tbldir)
            
        r = 0
    end function lfuncallc

    ! Check if the value at top, whose name is at index 1, corresponds to the table
    ! Stack requirements: 3 slots
    subroutine lfun_checktbl(L, what)
        type(c_ptr) :: L
        character(*), intent(in) :: what
        integer(4) :: typ
        character(10) :: tn
        
        typ = lua_type(L, -1)
        if (typ /= LUA_TTABLE) then
            call lua_pushstring_f(L, 'Bad type of '//what)
            call lua_pushvalue(L, 1)

            CALL lua_typename_f(L, typ, tn)
            call lua_pushstring_f(L, ': table expected, got '//trim(tn))
            call lua_concat(L, 3)
            typ = lua_error(L)
        end if
    end subroutine lfun_checktbl

    ! Tail of lfuncall* functions
    ! Expecting stack on input: key arg1 ... argn tbl
    ! Expecting stack on output: f(args)
    ! Stack requirements: 3 slots
    subroutine lfun_tail(L)
!        use, intrinsic :: iso_c_binding, only: c_funloc
        type(c_ptr) :: L
        integer(4) :: typ, nargs

        nargs = lua_gettop(L)

        ! Get value from the table 
        call lua_pushvalue(L, 1)
        call lua_gettable(L, -2)
        typ = lua_type(L, -1)

        if (typ == LUA_TNUMBER) then
            ! Constant
            ! Move it to stack bottom
            call lua_insert(L, 1)
            ! Pop key name, arguments and the table
        elseif (typ == LUA_TUSERDATA) then
            ! Interpolation table
            ! Expecting one argument
            if (nargs /= 2+1) then
                call lua_pushstring_f(L, &
                    & 'Too many arguments for interpolation function ')
                call lua_pushvalue(L, 1)
                call lua_concat(L, 2)
                typ = lua_error(L)
                return
            end if
            ! Stack is now: key arg tbl fun
            ! Push arg, index userdata w/metamethod
            call lua_pushvalue(L, 2)
            call lua_gettable(L, -2)
            ! Move result to stack bottom
            call lua_insert(L, 1)
            ! Pop key name, arguments, the table and fun
            nargs = nargs+1
        elseif (typ == LUA_TFUNCTION) then
            ! Function of (many) arguments
            ! Stack is now: key arg1 .. argn tbl fun
            ! Move function before arguments
            call lua_insert(L, 2)
            ! Pop table
            call lua_pop(L, 1)
            ! Call function w/out protection, since we're already in pcall
            nargs = nargs-2
            call lua_call(L, nargs, 1)
            ! Stack is now: key res
            ! Move result to stack bottom
            call lua_insert(L, 1)
            ! Pop key name
            nargs = 1
        else
            ! Other types -> signal error
            call lua_pushstring_f(L, &
                & 'Bad type of value ')
            call lua_pushvalue(L, 1)
            call lua_concat(L, 2)
            typ = lua_error(L)
            return
        endif
            

        call lua_pop(L, nargs)
        
    end subroutine lfun_tail

    
    
    ! Push table tbldir.tbl or tbl if tbldir is '', check for errors 
    subroutine gettblev2(L, tbldir, tbl)
        type(c_ptr) :: L
        character(*), intent(in) :: tbldir, tbl
        

Changes to test.f90.

1
2
3
4
5
6

7
8
9
10
11


12


13



14
15

16
17
program test
    ! Mockup for ftnlf
    use ftnlf
    implicit none
    
    logical :: r

    
    ! Initialize
    r = ftnlf_init('testdb.lua')
    if (.not. r) stop 99
    


    


    



    ! Finalize
    call ftnlf_done()


end program test






>





>
>

>
>
|
>
>
>


>

|
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
program test
    ! Mockup for ftnlf
    use ftnlf
    implicit none
    
    logical :: r
    real(8) :: fval
    
    ! Initialize
    r = ftnlf_init('testdb.lua')
    if (.not. r) stop 99
    
    r = luafun('', 'tbl1', 'val1', [1.d0,-3.5d0], fval)
    write (*,'(L,X,1PE11.4)') r, fval
    
    r = luafun('', 'tbl1', 'v2', [1.d0,-3.5d0], fval)
    write (*,'(L,X,1PE11.4)') r, fval

    r = luafun('', 'tbl1', 'v3', [13.5d0], fval)
    write (*,'(L,X,1PE11.4)') r, fval

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

end program test

Changes to testdb.lua.













>
>
>
>
>
>
1
2
3
4
5
6
iii = interp({0,1,10,0,15,-3})

tbl1 = { val1 = 17.4e-1,
v2 = function(x,y) return (x/y) end,
v3 = iii,
}